template_lapack_org2r.h

Go to the documentation of this file.
00001 /* Ergo, version 3.2, a program for linear scaling electronic structure
00002  * calculations.
00003  * Copyright (C) 2012 Elias Rudberg, Emanuel H. Rubensson, and Pawel Salek.
00004  * 
00005  * This program is free software: you can redistribute it and/or modify
00006  * it under the terms of the GNU General Public License as published by
00007  * the Free Software Foundation, either version 3 of the License, or
00008  * (at your option) any later version.
00009  * 
00010  * This program is distributed in the hope that it will be useful,
00011  * but WITHOUT ANY WARRANTY; without even the implied warranty of
00012  * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
00013  * GNU General Public License for more details.
00014  * 
00015  * You should have received a copy of the GNU General Public License
00016  * along with this program.  If not, see <http://www.gnu.org/licenses/>.
00017  * 
00018  * Primary academic reference:
00019  * Kohn−Sham Density Functional Theory Electronic Structure Calculations 
00020  * with Linearly Scaling Computational Time and Memory Usage,
00021  * Elias Rudberg, Emanuel H. Rubensson, and Pawel Salek,
00022  * J. Chem. Theory Comput. 7, 340 (2011),
00023  * <http://dx.doi.org/10.1021/ct100611z>
00024  * 
00025  * For further information about Ergo, see <http://www.ergoscf.org>.
00026  */
00027  
00028  /* This file belongs to the template_lapack part of the Ergo source 
00029   * code. The source files in the template_lapack directory are modified
00030   * versions of files originally distributed as CLAPACK, see the
00031   * Copyright/license notice in the file template_lapack/COPYING.
00032   */
00033  
00034 
00035 #ifndef TEMPLATE_LAPACK_ORG2R_HEADER
00036 #define TEMPLATE_LAPACK_ORG2R_HEADER
00037 
00038 
00039 template<class Treal>
00040 int template_lapack_org2r(const integer *m, const integer *n, const integer *k, Treal *
00041         a, const integer *lda, const Treal *tau, Treal *work, integer *info)
00042 {
00043 /*  -- LAPACK routine (version 3.0) --   
00044        Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,   
00045        Courant Institute, Argonne National Lab, and Rice University   
00046        February 29, 1992   
00047 
00048 
00049     Purpose   
00050     =======   
00051 
00052     DORG2R generates an m by n real matrix Q with orthonormal columns,   
00053     which is defined as the first n columns of a product of k elementary   
00054     reflectors of order m   
00055 
00056           Q  =  H(1) H(2) . . . H(k)   
00057 
00058     as returned by DGEQRF.   
00059 
00060     Arguments   
00061     =========   
00062 
00063     M       (input) INTEGER   
00064             The number of rows of the matrix Q. M >= 0.   
00065 
00066     N       (input) INTEGER   
00067             The number of columns of the matrix Q. M >= N >= 0.   
00068 
00069     K       (input) INTEGER   
00070             The number of elementary reflectors whose product defines the   
00071             matrix Q. N >= K >= 0.   
00072 
00073     A       (input/output) DOUBLE PRECISION array, dimension (LDA,N)   
00074             On entry, the i-th column must contain the vector which   
00075             defines the elementary reflector H(i), for i = 1,2,...,k, as   
00076             returned by DGEQRF in the first k columns of its array   
00077             argument A.   
00078             On exit, the m-by-n matrix Q.   
00079 
00080     LDA     (input) INTEGER   
00081             The first dimension of the array A. LDA >= max(1,M).   
00082 
00083     TAU     (input) DOUBLE PRECISION array, dimension (K)   
00084             TAU(i) must contain the scalar factor of the elementary   
00085             reflector H(i), as returned by DGEQRF.   
00086 
00087     WORK    (workspace) DOUBLE PRECISION array, dimension (N)   
00088 
00089     INFO    (output) INTEGER   
00090             = 0: successful exit   
00091             < 0: if INFO = -i, the i-th argument has an illegal value   
00092 
00093     =====================================================================   
00094 
00095 
00096        Test the input arguments   
00097 
00098        Parameter adjustments */
00099     /* Table of constant values */
00100      integer c__1 = 1;
00101     
00102     /* System generated locals */
00103     integer a_dim1, a_offset, i__1, i__2;
00104     Treal d__1;
00105     /* Local variables */
00106      integer i__, j, l;
00107 #define a_ref(a_1,a_2) a[(a_2)*a_dim1 + a_1]
00108 
00109 
00110     a_dim1 = *lda;
00111     a_offset = 1 + a_dim1 * 1;
00112     a -= a_offset;
00113     --tau;
00114     --work;
00115 
00116     /* Function Body */
00117     *info = 0;
00118     if (*m < 0) {
00119         *info = -1;
00120     } else if (*n < 0 || *n > *m) {
00121         *info = -2;
00122     } else if (*k < 0 || *k > *n) {
00123         *info = -3;
00124     } else if (*lda < maxMACRO(1,*m)) {
00125         *info = -5;
00126     }
00127     if (*info != 0) {
00128         i__1 = -(*info);
00129         template_blas_erbla("ORG2R ", &i__1);
00130         return 0;
00131     }
00132 
00133 /*     Quick return if possible */
00134 
00135     if (*n <= 0) {
00136         return 0;
00137     }
00138 
00139 /*     Initialise columns k+1:n to columns of the unit matrix */
00140 
00141     i__1 = *n;
00142     for (j = *k + 1; j <= i__1; ++j) {
00143         i__2 = *m;
00144         for (l = 1; l <= i__2; ++l) {
00145             a_ref(l, j) = 0.;
00146 /* L10: */
00147         }
00148         a_ref(j, j) = 1.;
00149 /* L20: */
00150     }
00151 
00152     for (i__ = *k; i__ >= 1; --i__) {
00153 
00154 /*        Apply H(i) to A(i:m,i:n) from the left */
00155 
00156         if (i__ < *n) {
00157             a_ref(i__, i__) = 1.;
00158             i__1 = *m - i__ + 1;
00159             i__2 = *n - i__;
00160             template_lapack_larf("Left", &i__1, &i__2, &a_ref(i__, i__), &c__1, &tau[i__], &
00161                     a_ref(i__, i__ + 1), lda, &work[1]);
00162         }
00163         if (i__ < *m) {
00164             i__1 = *m - i__;
00165             d__1 = -tau[i__];
00166             template_blas_scal(&i__1, &d__1, &a_ref(i__ + 1, i__), &c__1);
00167         }
00168         a_ref(i__, i__) = 1. - tau[i__];
00169 
00170 /*        Set A(1:i-1,i) to zero */
00171 
00172         i__1 = i__ - 1;
00173         for (l = 1; l <= i__1; ++l) {
00174             a_ref(l, i__) = 0.;
00175 /* L30: */
00176         }
00177 /* L40: */
00178     }
00179     return 0;
00180 
00181 /*     End of DORG2R */
00182 
00183 } /* dorg2r_ */
00184 
00185 #undef a_ref
00186 
00187 
00188 #endif

Generated on Wed Nov 21 09:32:01 2012 for ergo by  doxygen 1.4.7