module M_blas use, intrinsic :: iso_fortran_env, only : int8, int16, int32, int64, real32, real64, real128 !============================================================================== ! xerbla needs a special version for the test programs to run ! so it is a pointer to the standard procedure, but allows for ! xerbla to point to a user-defined procedure for testing ! ! use M_blas, only : set_xerbla, std_xerbla ! call set_mysub(SUBROUTINE_NAME) public :: xerbla public :: set_xerbla private :: std_xerbla public :: xerbla_interface abstract interface subroutine xerbla_interface(srname,info) character(len=*),intent(in) :: srname integer,intent(in) :: info end subroutine xerbla_interface end interface procedure(xerbla_interface),pointer :: xerbla => std_xerbla !============================================================================== contains subroutine set_xerbla(proc) procedure(xerbla_interface) :: proc xerbla => proc end subroutine set_xerbla !> !!##NAME !! xerbla_array(3f) - [BLAS:AUX_BLAS] call XERBLA(3f) with an array of characters instead of a string !! !!##SYNOPSIS !! !! subroutine xerbla_array(srname_array, srname_len, info) !! !! .. Scalar Arguments .. !! integer srname_len, info !! .. !! .. Array Arguments .. !! character(*) srname_array(srname_len) !! .. !! !!##DEFINITION !! !! XERBLA_ARRAY assists other languages in calling XERBLA, the LAPACK !! and BLAS error handler. Rather than taking a Fortran string argument !! as the function's name, XERBLA_ARRAY takes an array of single !! characters along with the array's length. XERBLA_ARRAY then copies !! up to 32 characters of that array into a Fortran string and passes !! that to XERBLA. If called with a non-positive SRNAME_LEN, !! XERBLA_ARRAY will call XERBLA with a string of all blank characters. !! !! Say some macro or other device makes XERBLA_ARRAY available to C99 !! by a name lapack_xerbla and with a common Fortran calling convention. !! Then a C99 program could invoke XERBLA via: !! { !! int flen = strlen(__func__); !! lapack_xerbla(__func__, &flen, &info); !! } !! !! Providing XERBLA_ARRAY is not necessary for intercepting LAPACK !! errors. XERBLA_ARRAY calls XERBLA. !! !!##OPTIONS !! !! SRNAME_ARRAY !! !! SRNAME_ARRAY is CHARACTER(*) array, dimension (SRNAME_LEN) !! The name of the routine which called XERBLA_ARRAY. !! !! SRNAME_LEN !! !! SRNAME_LEN is INTEGER !! The length of the name in SRNAME_ARRAY. !! !! INFO !! !! INFO is INTEGER !! The position of the invalid parameter in the parameter list !! of the calling routine. !! !!##AUTHORS !! !! + Univ. of Tennessee !! + Univ. of California Berkeley !! + Univ. of Colorado Denver !! + NAG Ltd. !! !! date:December 2016 !! !!##SEE ALSO !! Online html documentation available at !! http://www.netlib.org/lapack/explore-html/ ! ===================================================================== subroutine xerbla_array(srname_array, srname_len, info) implicit none ! ! -- Reference BLAS level1 routine (version 3.7.0) -- ! -- Reference BLAS is a software package provided by Univ. of Tennessee, -- ! -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- ! December 2016 ! ! .. Scalar Arguments .. integer,intent(in) :: srname_len, info ! .. ! .. Array Arguments .. character(len=*),intent(in) :: srname_array(srname_len) ! .. ! ! ===================================================================== ! ! .. ! .. Local Scalars .. integer i ! .. ! .. Local Arrays .. character*32 srname ! .. ! .. Intrinsic Functions .. intrinsic min, len ! .. ! .. External Functions .. ! EXTERNAL XERBLA ! .. ! .. Executable Statements .. srname = '' do i = 1, min( srname_len, len( srname ) ) srname( i:i ) = srname_array( i ) enddo call xerbla( srname, info ) end subroutine xerbla_array !> !!##NAME !! xerbla(3f) - [BLAS:AUX_BLAS] error handler routine for the BLAS/LAPACK routines !! !!##SYNOPSIS !! !! subroutine xerbla( srname, info ) !! !! .. Scalar Arguments .. !! character(len=*),intent(in) :: srname !! integer,intent(in) :: info !! .. !! !!##DEFINITION !! !! XERBLA is an error handler for the LAPACK routines. !! It is called by an LAPACK routine if an input parameter has an !! invalid value. A message is printed and execution stops. !! !! Installers may consider modifying the STOP statement in order to !! call system-specific exception-handling facilities. !! !!##OPTIONS !! !! SRNAME !! !! SRNAME is character(len=*),intent(in) !! The name of the routine which called XERBLA. !! !! INFO !! !! INFO is integer,intent(in) !! The position of the invalid parameter in the parameter list !! of the calling routine. !! !!##AUTHORS !! !! + Univ. of Tennessee !! + Univ. of California Berkeley !! + Univ. of Colorado Denver !! + NAG Ltd. !! !! date:December 2016 !! !!##SEE ALSO !! Online html documentation available at !! http://www.netlib.org/lapack/explore-html/ ! ===================================================================== subroutine std_xerbla( srname, info ) implicit none ! ! -- Reference BLAS level1 routine (version 3.7.0) -- ! -- Reference BLAS is a software package provided by Univ. of Tennessee, -- ! -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- ! December 2016 ! ! .. Scalar Arguments .. character(len=*),intent(in) :: srname integer,intent(in) :: info ! .. ! ===================================================================== ! .. Intrinsic Functions .. intrinsic trim ! .. ! .. Executable Statements .. ! write( *, fmt = 9999 )trim(srname), info stop 9999 format( ' ** On entry to ', a, ' parameter number ', i2, ' had ', 'an illegal value' ) end subroutine std_xerbla !> !!##NAME !! caxpy(3f) -- [BLAS:COMPLEX_BLAS_LEVEL1] CY:=CY+CA*CX (constant times a vector plus a vector) !! !!##SYNOPSIS !! !! subroutine caxpy(n,ca,cx,incx,cy,incy) !! !! .. Scalar Arguments .. !! complex,intent(in) :: ca !! integer,intent(in) :: incx,incy,n !! .. !! .. Array Arguments .. !! complex,intent(in) :: cx(*) !! complex,intent(inout) :: cy(*) !! !!##DESCRIPTION !! CAXPY constant times a vector plus a vector. !! !!##OPTIONS !! N number of elements in input vector(s) !! CA On entry, CA specifies the scalar alpha. !! CX CX is COMPLEX array, dimension ( 1 + ( N - 1 )*abs( INCX ) ) !! INCX storage spacing between elements of CX !! CY CY is COMPLEX array, dimension ( 1 + ( N - 1 )*abs( INCY ) ) !! INCY storage spacing between elements of CY !! !!##AUTHORS !! !! + Univ. of Tennessee !! + Univ. of California Berkeley !! + Univ. of Colorado Denver !! + NAG Ltd. !! !! November 2017 !! !! FURTHER DETAILS !! !! Jack Dongarra, linpack, 3/11/78. !! modified 12/3/93, array(1) declarations changed to array(*) !! !!##SEE ALSO !! Online html documentation available at !! http://www.netlib.org/lapack/explore-html/ ! ===================================================================== subroutine caxpy(n,ca,cx,incx,cy,incy) implicit none ! ! -- Reference BLAS level1 routine (version 3.8.0) -- ! -- Reference BLAS is a software package provided by Univ. of Tennessee, -- ! -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- ! November 2017 ! ! .. Scalar Arguments .. complex,intent(in) :: ca integer,intent(in) :: incx,incy,n ! .. ! .. Array Arguments .. complex,intent(in) :: cx(*) complex,intent(inout) :: cy(*) ! .. ! ! ===================================================================== ! ! .. Local Scalars .. integer :: i,ix,iy ! .. ! .. External Functions .. ! .. if (n.le.0) return if (scabs1(ca).eq.0.0e+0) return if (incx.eq.1 .and. incy.eq.1) then ! ! code for both increments equal to 1 ! do i = 1,n cy(i) = cy(i) + ca*cx(i) enddo else ! ! code for unequal increments or equal increments ! not equal to 1 ! ix = 1 iy = 1 if (incx.lt.0) ix = (-n+1)*incx + 1 if (incy.lt.0) iy = (-n+1)*incy + 1 do i = 1,n cy(iy) = cy(iy) + ca*cx(ix) ix = ix + incx iy = iy + incy enddo endif ! end subroutine caxpy !> !!##NAME !! ccopy(3f) - [BLAS:COMPLEX_BLAS_LEVEL1] CY:=CX (copies elements of a vector x to a vector y) !! !!##SYNOPSIS !! !! subroutine ccopy(n,cx,incx,cy,incy) !! !! .. scalar arguments .. !! integer,intent(in) :: incx,incy,n !! .. !! .. array arguments .. !! complex,intent(in) :: cx(*) !! complex,intent(out) :: cy(*) !! !!##DESCRIPTION !! CCOPY copies a vector x to a vector y. !! !!##OPTIONS !! N number of elements in input vector(s) !! CX dimension ( 1 + ( N - 1 )*abs( INCX ) ) !! INCX storage spacing between elements of CX !! CY dimension ( 1 + ( N - 1 )*abs( INCY ) ) !! INCY storage spacing between elements of CY !! !!##AUTHORS !! !! + Univ. of Tennessee !! + Univ. of California Berkeley !! + Univ. of Colorado Denver !! + NAG Ltd. !! !! date:November 2017 !! !! FURTHER DETAILS !! !! jack dongarra, linpack, 3/11/78. !! modified 12/3/93, array(1) declarations changed to array(*) !! !!##SEE ALSO !! Online html documentation available at !! http://www.netlib.org/lapack/explore-html/ ! ===================================================================== subroutine ccopy(n,cx,incx,cy,incy) implicit none ! ! -- Reference BLAS level1 routine (version 3.8.0) -- ! -- Reference BLAS is a software package provided by Univ. of Tennessee, -- ! -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- ! November 2017 ! ! .. Scalar Arguments .. integer,intent(in) :: incx,incy,n ! .. ! .. Array Arguments .. complex,intent(in) :: cx(*) complex,intent(out) :: cy(*) ! .. ! ===================================================================== ! .. Local Scalars .. integer i,ix,iy ! .. if (n.le.0) return if (incx.eq.1 .and. incy.eq.1) then ! code for both increments equal to 1 cy(1:n) = cx(1:n) else ! code for unequal increments or equal increments not equal to 1 ix = 1 iy = 1 if (incx.lt.0) ix = (-n+1)*incx + 1 if (incy.lt.0) iy = (-n+1)*incy + 1 do i = 1,n cy(iy) = cx(ix) ix = ix + incx iy = iy + incy enddo endif end subroutine ccopy ! JSU: N is not the size of X and Y it is the number of elements copied from X to Y ! JSU: as-is CY and CX are assumed of sufficient size for the copies to be in bounds ! JSU: for the simple case where the increments are 1 and N is the size of both arrays a statement of the form X=Y is OK in F90 ! and in other cases simple array syntax statements can replace a call to this procedure !> !!##NAME !! cdotc(3f) - [BLAS:COMPLEX_BLAS_LEVEL1] CDOTC := SUM CONJUGATE(CX) * CY (conjugated vector dot product) !! !!##SYNOPSIS !! !! !! complex function cdotc(n,cx,incx,cy,incy) !! !! .. Scalar Arguments .. !! integer,intent(in) :: incx,incy,n !! .. !! .. Array Arguments .. !! complex,intent(in) :: cx(*),cy(*) !! .. !! !!##DEFINITION !! CDOTC forms the dot product of two complex vectors !! !! CDOTC = X^H * Y !! !!##OPTIONS !! !! N number of elements in input vector(s) !! CX array, dimension ( 1 + ( N - 1 )*abs( INCX ) ) !! INCX storage spacing between elements of CX !! CY array, dimension ( 1 + ( N - 1 )*abs( INCY ) ) !! INCY storage spacing between elements of CY !! !!##AUTHORS !! + Univ. of Tennessee !! + Univ. of California Berkeley !! + Univ. of Colorado Denver !! + NAG Ltd. !! !! date:November 2017 !! !! FURTHER DETAILS !! jack dongarra, linpack, 3/11/78. !! modified 12/3/93, array(1) declarations changed to array(*) !! !!##SEE ALSO !! Online html documentation available at !! http://www.netlib.org/lapack/explore-html/ ! ===================================================================== complex function cdotc(n,cx,incx,cy,incy) implicit none ! ! -- Reference BLAS level1 routine (version 3.8.0) -- ! -- Reference BLAS is a software package provided by Univ. of Tennessee, -- ! -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- ! November 2017 ! ! .. Scalar Arguments .. integer,intent(in) :: incx,incy,n ! .. ! .. Array Arguments .. complex,intent(in) :: cx(*),cy(*) ! .. ! ! ===================================================================== ! ! .. Local Scalars .. complex ctemp integer i,ix,iy ! .. ! .. Intrinsic Functions .. intrinsic conjg ! .. ctemp = (0.0,0.0) cdotc = (0.0,0.0) if (n.le.0) return if (incx.eq.1 .and. incy.eq.1) then ! ! code for both increments equal to 1 ! do i = 1,n ctemp = ctemp + conjg(cx(i))*cy(i) enddo else ! ! code for unequal increments or equal increments ! not equal to 1 ! ix = 1 iy = 1 if (incx.lt.0) ix = (-n+1)*incx + 1 if (incy.lt.0) iy = (-n+1)*incy + 1 do i = 1,n ctemp = ctemp + conjg(cx(ix))*cy(iy) ix = ix + incx iy = iy + incy enddo endif cdotc = ctemp end function cdotc !> !!##NAME !! cdotu(3f) - [BLAS:COMPLEX_BLAS_LEVEL1] CDOTU := SUM CX * CY (unconjugated vector dot product) !! !!##SYNOPSIS !! !! complex function cdotu(n,cx,incx,cy,incy) !! !! .. Scalar Arguments .. !! integer,intent(in) :: incx,incy,n !! .. !! .. Array Arguments .. !! complex,intent(in) :: cx(*),cy(*) !! .. !! !!##DEFINITION !! CDOTU forms the dot product of two complex vectors !! !! CDOTU = X^T * Y !! !!##OPTIONS !! N !! number of elements in input vector(s) !! CX !! array, dimension ( 1 + ( N - 1 )*abs( INCX ) ) !! INCX !! storage spacing between elements of CX !! CY !! array, dimension ( 1 + ( N - 1 )*abs( INCY ) ) !! INCY !! storage spacing between elements of CY !! !!##AUTHORS !! + Univ. of Tennessee !! + Univ. of California Berkeley !! + Univ. of Colorado Denver !! + NAG Ltd. !! !! date:November 2017 !! !! FURTHER DETAILS !! jack dongarra, linpack, 3/11/78. !! modified 12/3/93, array(1) declarations changed to array(*) !! !!##SEE ALSO !! Online html documentation available at !! http://www.netlib.org/lapack/explore-html/ ! ===================================================================== complex function cdotu(n,cx,incx,cy,incy) implicit none ! ! -- Reference BLAS level1 routine (version 3.8.0) -- ! -- Reference BLAS is a software package provided by Univ. of Tennessee, -- ! -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- ! November 2017 ! ! .. Scalar Arguments .. integer,intent(in) :: incx,incy,n ! .. ! .. Array Arguments .. complex,intent(in) :: cx(*),cy(*) ! .. ! ! ===================================================================== ! ! .. Local Scalars .. complex ctemp integer i,ix,iy ! .. ctemp = (0.0,0.0) cdotu = (0.0,0.0) if (n.le.0) return if (incx.eq.1 .and. incy.eq.1) then ! ! code for both increments equal to 1 ! do i = 1,n ctemp = ctemp + cx(i)*cy(i) enddo else ! ! code for unequal increments or equal increments ! not equal to 1 ! ix = 1 iy = 1 if (incx.lt.0) ix = (-n+1)*incx + 1 if (incy.lt.0) iy = (-n+1)*incy + 1 do i = 1,n ctemp = ctemp + cx(ix)*cy(iy) ix = ix + incx iy = iy + incy enddo endif cdotu = ctemp end function cdotu !> !!##NAME !! cgbmv(3f) - [BLAS:COMPLEX_BLAS_LEVEL2] CY := alpha*A*CX + beta*CY; ==> A is a rectangular band matrix). !! !!##SYNOPSIS !! !! !! subroutine cgbmv(trans,m,n,kl,ku,alpha,a,lda,x,incx,beta,y,incy) !! !! .. Scalar Arguments .. !! complex,intent(in) :: alpha,beta !! integer,intent(in) :: incx,incy,kl,ku,lda,m,n !! character,intent(in) :: trans !! .. !! .. Array Arguments .. !! complex,intent(in) :: a(lda,*),x(*) !! complex,intent(inout) :: y(*) !! .. !! !!##DESCRIPTION !! CGBMV performs one of the matrix-vector operations !! !! y := alpha*A*x + beta*y, or y := alpha*A**T*x + beta*y, or !! !! y := alpha*A**H*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. !! !!##OPTIONS !! !! TRANS !! 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**T*x + beta*y. !! !! TRANS = 'C' or 'c' y := alpha*A**H*x + beta*y. !! !! M !! On entry, M specifies the number of rows of the matrix A. !! M must be at least zero. !! !! N !! On entry, N specifies the number of columns of the matrix A. !! N must be at least zero. !! !! KL !! On entry, KL specifies the number of sub-diagonals of the !! matrix A. KL must satisfy 0 .le. KL. !! !! KU !! On entry, KU specifies the number of super-diagonals of the !! matrix A. KU must satisfy 0 .le. KU. !! !! ALPHA !! On entry, ALPHA specifies the scalar alpha. !! !! A !! A is COMPLEX array, 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 !! !! LDA !! On entry, LDA specifies the first dimension of A as declared !! in the calling (sub) program. LDA must be at least !! ( kl + ku + 1 ). !! !! X !! X is COMPLEX array, 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. !! !! INCX !! INCX is INTEGER !! On entry, INCX specifies the increment for the elements of !! X. INCX must not be zero. !! !! BETA !! BETA is COMPLEX !! On entry, BETA specifies the scalar beta. When BETA is !! supplied as zero then Y need not be set on input. !! !! Y !! Y is COMPLEX array, 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 !! INCY is INTEGER !! On entry, INCY specifies the increment for the elements of !! Y. INCY must not be zero. !! !!##AUTHORS !! + Univ. of Tennessee !! + Univ. of California Berkeley !! + Univ. of Colorado Denver !! + NAG Ltd. !! !! date:December 2016 !! !! FURTHER DETAILS !! Level 2 Blas routine. !! The vector and matrix arguments are not referenced when N = 0, or M = 0 !! !! -- Written on 22-October-1986. !! Jack Dongarra, Argonne National Lab. !! Jeremy Du Croz, Nag Central Office. !! Sven Hammarling, Nag Central Office. !! !!##SEE ALSO !! Online html documentation available at !! http://www.netlib.org/lapack/explore-html/ ! ===================================================================== subroutine cgbmv(trans,m,n,kl,ku,alpha,a,lda,x,incx,beta,y,incy) implicit none ! ! -- Reference BLAS level2 routine (version 3.7.0) -- ! -- Reference BLAS is a software package provided by Univ. of Tennessee, -- ! -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- ! December 2016 ! ! .. Scalar Arguments .. complex,intent(in) :: alpha,beta integer,intent(in) :: incx,incy,kl,ku,lda,m,n character,intent(in) :: trans ! .. ! .. Array Arguments .. complex,intent(in) :: a(lda,*),x(*) complex,intent(inout) :: y(*) ! .. ! ! ===================================================================== ! ! .. Parameters .. complex,parameter :: one= (1.0e+0,0.0e+0) complex,parameter :: zero= (0.0e+0,0.0e+0) ! .. ! .. Local Scalars .. complex temp integer i,info,ix,iy,j,jx,jy,k,kup1,kx,ky,lenx,leny logical noconj ! .. ! .. External Functions .. ! .. ! .. External Subroutines .. ! .. ! .. Intrinsic Functions .. intrinsic conjg,max,min ! .. ! ! Test the input parameters. ! info = 0 if (.not.lsame(trans,'N') .and. .not.lsame(trans,'T') .and. .not.lsame(trans,'C')) then info = 1 elseif (m.lt.0) then info = 2 elseif (n.lt.0) then info = 3 elseif (kl.lt.0) then info = 4 elseif (ku.lt.0) then info = 5 elseif (lda.lt. (kl+ku+1)) then info = 8 elseif (incx.eq.0) then info = 10 elseif (incy.eq.0) then info = 13 endif if (info.ne.0) then call xerbla('CGBMV ',info) return endif ! ! Quick return if possible. ! if ((m.eq.0) .or. (n.eq.0) .or. ((alpha.eq.zero).and. (beta.eq.one))) return ! noconj = lsame(trans,'T') ! ! Set LENX and LENY,the lengths of the vectors x and y, and set ! up the start points in X and Y. ! if (lsame(trans,'N')) then lenx = n leny = m else lenx = m leny = n endif if (incx.gt.0) then kx = 1 else kx = 1 - (lenx-1)*incx endif if (incy.gt.0) then ky = 1 else ky = 1 - (leny-1)*incy endif ! ! 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.ne.one) then if (incy.eq.1) then if (beta.eq.zero) then do i = 1,leny y(i) = zero enddo else do i = 1,leny y(i) = beta*y(i) enddo endif else iy = ky if (beta.eq.zero) then do i = 1,leny y(iy) = zero iy = iy + incy enddo else do i = 1,leny y(iy) = beta*y(iy) iy = iy + incy enddo endif endif endif if (alpha.eq.zero) return kup1 = ku + 1 if (lsame(trans,'N')) then ! ! Form y := alpha*A*x + y. ! jx = kx if (incy.eq.1) then do j = 1,n temp = alpha*x(jx) k = kup1 - j do i = max(1,j-ku),min(m,j+kl) y(i) = y(i) + temp*a(k+i,j) enddo jx = jx + incx enddo else do j = 1,n temp = alpha*x(jx) iy = ky k = kup1 - j do i = max(1,j-ku),min(m,j+kl) y(iy) = y(iy) + temp*a(k+i,j) iy = iy + incy enddo jx = jx + incx if (j.gt.ku) ky = ky + incy enddo endif else ! ! Form y := alpha*A**T*x + y or y := alpha*A**H*x + y. ! jy = ky if (incx.eq.1) then do j = 1,n temp = zero k = kup1 - j if (noconj) then do i = max(1,j-ku),min(m,j+kl) temp = temp + a(k+i,j)*x(i) enddo else do i = max(1,j-ku),min(m,j+kl) temp = temp + conjg(a(k+i,j))*x(i) enddo endif y(jy) = y(jy) + alpha*temp jy = jy + incy enddo else do j = 1,n temp = zero ix = kx k = kup1 - j if (noconj) then do i = max(1,j-ku),min(m,j+kl) temp = temp + a(k+i,j)*x(ix) ix = ix + incx enddo else do i = max(1,j-ku),min(m,j+kl) temp = temp + conjg(a(k+i,j))*x(ix) ix = ix + incx enddo endif y(jy) = y(jy) + alpha*temp jy = jy + incy if (j.gt.ku) kx = kx + incx enddo endif endif end subroutine cgbmv !> !!##NAME !! cgemm(3f) - [BLAS:COMPLEX_BLAS_LEVEL3] C:=alpha*A*B+beta*C; ==> A, B, C rectangular. !! !!##SYNOPSIS !! !! !! subroutine cgemm(transa,transb,m,n,k,alpha,a,lda,b,ldb,beta,c,ldc) !! !! .. Scalar Arguments .. !! complex,intent(in) :: alpha,beta !! integer,intent(in) :: k,lda,ldb,ldc,m,n !! character,intent(in) :: transa,transb !! .. !! .. Array Arguments .. !! complex,intent(in) :: a(lda,*),b(ldb,*) !! complex,intent(inout) :: c(ldc,*) !! .. !! !!##DEFINITION !! !! CGEMM 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**T or op( X ) = X**H, !! !! 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. !! !!##OPTIONS !! !! TRANSA !! !! 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**T. !! !! TRANSA = 'C' or 'c', op( A ) = A**H. !! !! TRANSB !! !! TRANSB is 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**T. !! !! TRANSB = 'C' or 'c', op( B ) = B**H. !! !! M !! On entry, M specifies the number of rows of the matrix !! op( A ) and of the matrix C. M must be at least zero. !! !! N !! !! N is 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. !! !! K !! !! K is 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. !! !! ALPHA !! !! ALPHA is COMPLEX !! On entry, ALPHA specifies the scalar alpha. !! !! A !! !! A is COMPLEX array, 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. !! !! LDA !! !! LDA is 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 ). !! !! B !! !! B is COMPLEX array, 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. !! !! LDB !! !! LDB is 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 ). !! !! BETA !! !! BETA is COMPLEX !! On entry, BETA specifies the scalar beta. When BETA is !! supplied as zero then C need not be set on input. !! !! C !! !! C is COMPLEX array, 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 !! !! LDC is 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 ). !! !!##AUTHORS !! !! + Univ. of Tennessee !! + Univ. of California Berkeley !! + Univ. of Colorado Denver !! + NAG Ltd. !! !! date:December 2016 !! !! FURTHER DETAILS !! !! 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. !! !!##SEE ALSO !! Online html documentation available at !! http://www.netlib.org/lapack/explore-html/ ! ===================================================================== subroutine cgemm(transa,transb,m,n,k,alpha,a,lda,b,ldb,beta,c,ldc) implicit none ! ! -- Reference BLAS level3 routine (version 3.7.0) -- ! -- Reference BLAS is a software package provided by Univ. of Tennessee, -- ! -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- ! December 2016 ! ! .. Scalar Arguments .. complex,intent(in) :: alpha,beta integer,intent(in) :: k,lda,ldb,ldc,m,n character,intent(in) :: transa,transb ! .. ! .. Array Arguments .. complex,intent(in) :: a(lda,*),b(ldb,*) complex,intent(inout) :: c(ldc,*) ! .. ! ! ===================================================================== ! ! .. External Functions .. ! .. ! .. External Subroutines .. ! .. ! .. Intrinsic Functions .. intrinsic conjg,max ! .. ! .. Local Scalars .. complex temp integer i,info,j,l,nrowa,nrowb logical conja,conjb,nota,notb ! .. ! .. Parameters .. complex,parameter :: one= (1.0e+0,0.0e+0) complex,parameter :: zero= (0.0e+0,0.0e+0) ! .. ! ! Set NOTA and NOTB as true if A and B respectively are not ! conjugated or transposed, set CONJA and CONJB as true if A and ! B respectively are to be transposed but not conjugated and set ! NROWA and NROWB as the number of rows of A and B respectively. ! nota = lsame(transa,'N') notb = lsame(transb,'N') conja = lsame(transa,'C') conjb = lsame(transb,'C') if (nota) then nrowa = m else nrowa = k endif if (notb) then nrowb = k else nrowb = n endif ! ! Test the input parameters. ! info = 0 if ((.not.nota) .and. (.not.conja) .and. (.not.lsame(transa,'T'))) then info = 1 elseif ((.not.notb) .and. (.not.conjb) .and. (.not.lsame(transb,'T'))) then info = 2 elseif (m.lt.0) then info = 3 elseif (n.lt.0) then info = 4 elseif (k.lt.0) then info = 5 elseif (lda.lt.max(1,nrowa)) then info = 8 elseif (ldb.lt.max(1,nrowb)) then info = 10 elseif (ldc.lt.max(1,m)) then info = 13 endif if (info.ne.0) then call xerbla('CGEMM ',info) return endif ! ! Quick return if possible. ! if ((m.eq.0) .or. (n.eq.0) .or. (((alpha.eq.zero).or. (k.eq.0)).and. (beta.eq.one))) return ! ! And when alpha.eq.zero. ! if (alpha.eq.zero) then if (beta.eq.zero) then do j = 1,n do i = 1,m c(i,j) = zero enddo enddo else do j = 1,n do i = 1,m c(i,j) = beta*c(i,j) enddo enddo endif return endif ! ! Start the operations. ! if (notb) then if (nota) then ! ! Form C := alpha*A*B + beta*C. ! do j = 1,n if (beta.eq.zero) then do i = 1,m c(i,j) = zero enddo elseif (beta.ne.one) then do i = 1,m c(i,j) = beta*c(i,j) enddo endif do l = 1,k temp = alpha*b(l,j) do i = 1,m c(i,j) = c(i,j) + temp*a(i,l) enddo enddo enddo elseif (conja) then ! ! Form C := alpha*A**H*B + beta*C. ! do j = 1,n do i = 1,m temp = zero do l = 1,k temp = temp + conjg(a(l,i))*b(l,j) enddo if (beta.eq.zero) then c(i,j) = alpha*temp else c(i,j) = alpha*temp + beta*c(i,j) endif enddo enddo else ! ! Form C := alpha*A**T*B + beta*C ! do j = 1,n do i = 1,m temp = zero do l = 1,k temp = temp + a(l,i)*b(l,j) enddo if (beta.eq.zero) then c(i,j) = alpha*temp else c(i,j) = alpha*temp + beta*c(i,j) endif enddo enddo endif elseif (nota) then if (conjb) then ! ! Form C := alpha*A*B**H + beta*C. ! do j = 1,n if (beta.eq.zero) then do i = 1,m c(i,j) = zero enddo elseif (beta.ne.one) then do i = 1,m c(i,j) = beta*c(i,j) enddo endif do l = 1,k temp = alpha*conjg(b(j,l)) do i = 1,m c(i,j) = c(i,j) + temp*a(i,l) enddo enddo enddo else ! ! Form C := alpha*A*B**T + beta*C ! do j = 1,n if (beta.eq.zero) then do i = 1,m c(i,j) = zero enddo elseif (beta.ne.one) then do i = 1,m c(i,j) = beta*c(i,j) enddo endif do l = 1,k temp = alpha*b(j,l) do i = 1,m c(i,j) = c(i,j) + temp*a(i,l) enddo enddo enddo endif elseif (conja) then if (conjb) then ! ! Form C := alpha*A**H*B**H + beta*C. ! do j = 1,n do i = 1,m temp = zero do l = 1,k temp = temp + conjg(a(l,i))*conjg(b(j,l)) enddo if (beta.eq.zero) then c(i,j) = alpha*temp else c(i,j) = alpha*temp + beta*c(i,j) endif enddo enddo else ! ! Form C := alpha*A**H*B**T + beta*C ! do j = 1,n do i = 1,m temp = zero do l = 1,k temp = temp + conjg(a(l,i))*b(j,l) enddo if (beta.eq.zero) then c(i,j) = alpha*temp else c(i,j) = alpha*temp + beta*c(i,j) endif enddo enddo endif else if (conjb) then ! ! Form C := alpha*A**T*B**H + beta*C ! do j = 1,n do i = 1,m temp = zero do l = 1,k temp = temp + a(l,i)*conjg(b(j,l)) enddo if (beta.eq.zero) then c(i,j) = alpha*temp else c(i,j) = alpha*temp + beta*c(i,j) endif enddo enddo else ! ! Form C := alpha*A**T*B**T + beta*C ! do j = 1,n do i = 1,m temp = zero do l = 1,k temp = temp + a(l,i)*b(j,l) enddo if (beta.eq.zero) then c(i,j) = alpha*temp else c(i,j) = alpha*temp + beta*c(i,j) endif enddo enddo endif endif ! ! End of CGEMM . ! end subroutine cgemm !> !!##NAME !! cgemv(3f) - [BLAS:COMPLEX_BLAS_LEVEL2] CY := alpha*A*CX + beta*CY; ==> A a rectangular matrix. !! !!##SYNOPSIS !! !! !! subroutine cgemv(trans,m,n,alpha,a,lda,x,incx,beta,y,incy) !! !! .. Scalar Arguments .. !! COMPLEX,intent(in) :: ALPHA,BETA !! INTEGER,intent(in) :: INCX,INCY,LDA,M,N !! CHARACTER,intent(in) :: TRANS !! .. !! .. Array Arguments .. !! COMPLEX,intent(in) :: A(LDA,*),X(*) !! COMPLEX,intent(inout) :: Y(*) !! .. !! !!##DEFINITION !! !! CGEMV performs one of the matrix-vector operations !! !! y := alpha*A*x + beta*y, or y := alpha*A**T*x + beta*y, or !! !! y := alpha*A**H*x + beta*y, !! !! where alpha and beta are scalars, x and y are vectors and A is an !! m by n matrix. !! !!##OPTIONS !! !! TRANS !! !! TRANS is 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**T*x + beta*y. !! !! TRANS = 'C' or 'c' y := alpha*A**H*x + beta*y. !! !! M !! !! M is INTEGER !! On entry, M specifies the number of rows of the matrix A. !! M must be at least zero. !! !! N !! !! N is INTEGER !! On entry, N specifies the number of columns of the matrix A. !! N must be at least zero. !! !! ALPHA !! !! ALPHA is COMPLEX !! On entry, ALPHA specifies the scalar alpha. !! !! A !! !! A is COMPLEX array, dimension ( LDA, N ) !! Before entry, the leading m by n part of the array A must !! contain the matrix of coefficients. !! !! LDA !! !! LDA is 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 ). !! !! X !! !! X is COMPLEX array, 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. !! !! INCX !! !! INCX is INTEGER !! On entry, INCX specifies the increment for the elements of !! X. INCX must not be zero. !! !! BETA !! !! BETA is COMPLEX !! On entry, BETA specifies the scalar beta. When BETA is !! supplied as zero then Y need not be set on input. !! !! Y !! !! Y is COMPLEX array, 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 !! !! INCY is INTEGER !! On entry, INCY specifies the increment for the elements of !! Y. INCY must not be zero. !! !!##AUTHORS !! !! + Univ. of Tennessee !! + Univ. of California Berkeley !! + Univ. of Colorado Denver !! + NAG Ltd. !! !! date:December 2016 !! !! FURTHER DETAILS !! !! Level 2 Blas routine. !! The vector and matrix arguments are not referenced when N = 0, or M = 0 !! !! -- 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. !! !!##SEE ALSO !! Online html documentation available at !! http://www.netlib.org/lapack/explore-html/ ! ===================================================================== subroutine cgemv(trans,m,n,alpha,a,lda,x,incx,beta,y,incy) implicit none ! ! -- Reference BLAS level2 routine (version 3.7.0) -- ! -- Reference BLAS is a software package provided by Univ. of Tennessee, -- ! -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- ! December 2016 ! ! .. Scalar Arguments .. complex,intent(in) :: alpha,beta integer,intent(in) :: incx,incy,lda,m,n character,intent(in) :: trans ! .. ! .. Array Arguments .. complex,intent(in) :: a(lda,*),x(*) complex,intent(inout) :: y(*) ! .. ! ! ===================================================================== ! ! .. Parameters .. complex, parameter :: one= (1.0e+0,0.0e+0) complex, parameter :: zero= (0.0e+0,0.0e+0) ! .. ! .. Local Scalars .. complex temp integer i,info,ix,iy,j,jx,jy,kx,ky,lenx,leny logical noconj ! .. ! .. External Functions .. ! .. ! .. External Subroutines .. ! .. ! .. Intrinsic Functions .. intrinsic conjg,max ! .. ! ! Test the input parameters. ! info = 0 if (.not.lsame(trans,'N') .and. .not.lsame(trans,'T') .and. .not.lsame(trans,'C')) then info = 1 elseif (m.lt.0) then info = 2 elseif (n.lt.0) then info = 3 elseif (lda.lt.max(1,m)) then info = 6 elseif (incx.eq.0) then info = 8 elseif (incy.eq.0) then info = 11 endif if (info.ne.0) then call xerbla('CGEMV ',info) return endif ! ! Quick return if possible. ! if ((m.eq.0) .or. (n.eq.0) .or. ((alpha.eq.zero).and. (beta.eq.one))) return ! noconj = lsame(trans,'T') ! ! Set LENX and LENY, the lengths of the vectors x and y, and set ! up the start points in X and Y. ! if (lsame(trans,'N')) then lenx = n leny = m else lenx = m leny = n endif if (incx.gt.0) then kx = 1 else kx = 1 - (lenx-1)*incx endif if (incy.gt.0) then ky = 1 else ky = 1 - (leny-1)*incy endif ! ! Start the operations. In this version the elements of A are ! accessed sequentially with one pass through A. ! ! First form y := beta*y. ! if (beta.ne.one) then if (incy.eq.1) then if (beta.eq.zero) then y(1:leny) = zero else y(1:leny) = beta*y(1:leny) endif else iy = ky if (beta.eq.zero) then do i = 1,leny y(iy) = zero iy = iy + incy enddo else do i = 1,leny y(iy) = beta*y(iy) iy = iy + incy enddo endif endif endif if (alpha.eq.zero) return if (lsame(trans,'N')) then ! ! Form y := alpha*A*x + y. ! jx = kx if (incy.eq.1) then do j = 1,n temp = alpha*x(jx) do i = 1,m y(i) = y(i) + temp*a(i,j) enddo jx = jx + incx enddo else do j = 1,n temp = alpha*x(jx) iy = ky do i = 1,m y(iy) = y(iy) + temp*a(i,j) iy = iy + incy enddo jx = jx + incx enddo endif else ! ! Form y := alpha*A**T*x + y or y := alpha*A**H*x + y. ! jy = ky if (incx.eq.1) then do j = 1,n temp = zero if (noconj) then do i = 1,m temp = temp + a(i,j)*x(i) enddo else do i = 1,m temp = temp + conjg(a(i,j))*x(i) enddo endif y(jy) = y(jy) + alpha*temp jy = jy + incy enddo else do j = 1,n temp = zero ix = kx if (noconj) then do i = 1,m temp = temp + a(i,j)*x(ix) ix = ix + incx enddo else do i = 1,m temp = temp + conjg(a(i,j))*x(ix) ix = ix + incx enddo endif y(jy) = y(jy) + alpha*temp jy = jy + incy enddo endif endif ! ! End of CGEMV . ! end subroutine cgemv !> !!##NAME !! cgerc(3f) - [BLAS:COMPLEX_BLAS_LEVEL2] A := A + alpha*CX*CONJUGATE-TRANSPOSE(CY); ==> A is a rectangular matrix. !! !!##SYNOPSIS !! !! subroutine cgerc(m,n,alpha,x,incx,y,incy,a,lda) !! !! .. Scalar Arguments .. !! complex,intent(in) :: alpha !! integer,intent(in) :: incx,incy,lda,m,n !! .. !! .. Array Arguments .. !! complex,intent(inout) :: a(lda,*) !! complex,intent(in) :: x(*),y(*) !! .. !! !!##DEFINITION !! !! CGERC performs the rank 1 operation !! !! A := alpha*x*y**H + 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. !! !!##OPTIONS !! !! M !! !! M is INTEGER !! On entry, M specifies the number of rows of the matrix A. !! M must be at least zero. !! !! N !! !! N is INTEGER !! On entry, N specifies the number of columns of the matrix A. !! N must be at least zero. !! !! ALPHA !! !! ALPHA is COMPLEX !! On entry, ALPHA specifies the scalar alpha. !! !! X !! !! X is COMPLEX array, dimension at least !! ( 1 + ( m - 1 )*abs( INCX ) ). !! Before entry, the incremented array X must contain the m !! element vector x. !! !! INCX !! !! INCX is INTEGER !! On entry, INCX specifies the increment for the elements of !! X. INCX must not be zero. !! !! Y !! !! Y is COMPLEX array, dimension at least !! ( 1 + ( n - 1 )*abs( INCY ) ). !! Before entry, the incremented array Y must contain the n !! element vector y. !! !! INCY !! !! INCY is INTEGER !! On entry, INCY specifies the increment for the elements of !! Y. INCY must not be zero. !! !! A !! !! A is COMPLEX array, 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 !! !! LDA is 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 ). !! !!##AUTHORS !! !! + Univ. of Tennessee !! + Univ. of California Berkeley !! + Univ. of Colorado Denver !! + NAG Ltd. !! !! date:December 2016 !! !! FURTHER DETAILS !! !! 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. !! !!##SEE ALSO !! Online html documentation available at !! http://www.netlib.org/lapack/explore-html/ ! ===================================================================== subroutine cgerc(m,n,alpha,x,incx,y,incy,a,lda) implicit none ! ! -- Reference BLAS level2 routine (version 3.7.0) -- ! -- Reference BLAS is a software package provided by Univ. of Tennessee, -- ! -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- ! December 2016 ! ! .. Scalar Arguments .. complex,intent(in) :: alpha integer,intent(in) :: incx,incy,lda,m,n ! .. ! .. Array Arguments .. complex,intent(inout) :: a(lda,*) complex,intent(in) :: x(*),y(*) ! .. ! ! ===================================================================== ! ! .. Parameters .. complex zero parameter (zero= (0.0e+0,0.0e+0)) ! .. ! .. Local Scalars .. complex temp integer i,info,ix,j,jy,kx ! .. ! .. External Subroutines .. ! .. ! .. Intrinsic Functions .. intrinsic conjg,max ! .. ! ! Test the input parameters. ! info = 0 if (m.lt.0) then info = 1 elseif (n.lt.0) then info = 2 elseif (incx.eq.0) then info = 5 elseif (incy.eq.0) then info = 7 elseif (lda.lt.max(1,m)) then info = 9 endif if (info.ne.0) then call xerbla('CGERC ',info) return endif ! ! Quick return if possible. ! if ((m.eq.0) .or. (n.eq.0) .or. (alpha.eq.zero)) return ! ! Start the operations. In this version the elements of A are ! accessed sequentially with one pass through A. ! if (incy.gt.0) then jy = 1 else jy = 1 - (n-1)*incy endif if (incx.eq.1) then do j = 1,n if (y(jy).ne.zero) then temp = alpha*conjg(y(jy)) do i = 1,m a(i,j) = a(i,j) + x(i)*temp enddo endif jy = jy + incy enddo else if (incx.gt.0) then kx = 1 else kx = 1 - (m-1)*incx endif do j = 1,n if (y(jy).ne.zero) then temp = alpha*conjg(y(jy)) ix = kx do i = 1,m a(i,j) = a(i,j) + x(ix)*temp ix = ix + incx enddo endif jy = jy + incy enddo endif end subroutine cgerc !> !!##NAME !! cgeru(3f) - [BLAS:COMPLEX_BLAS_LEVEL2] A := A + alpha*CX*TRANSPOSE(CY); ==> A is a rectangular matrix. !! !!##SYNOPSIS !! !! subroutine cgeru(m,n,alpha,x,incx,y,incy,a,lda) !! !! .. Scalar Arguments .. !! complex,intent(in) :: alpha !! integer,intent(in) :: incx,incy,lda,m,n !! .. !! .. Array Arguments .. !! complex,intent(inout) :: a(lda,*) !! complex,intent(in) :: x(*),y(*) !! .. !! !!##DEFINITION !! !! CGERU performs the rank 1 operation !! !! A := alpha*x*y**T + 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. !! !!##OPTIONS !! !! M !! !! M is INTEGER !! On entry, M specifies the number of rows of the matrix A. !! M must be at least zero. !! !! N !! !! N is INTEGER !! On entry, N specifies the number of columns of the matrix A. !! N must be at least zero. !! !! ALPHA !! !! ALPHA is COMPLEX !! On entry, ALPHA specifies the scalar alpha. !! !! X !! !! X is COMPLEX array, dimension at least !! ( 1 + ( m - 1 )*abs( INCX ) ). !! Before entry, the incremented array X must contain the m !! element vector x. !! !! INCX !! !! INCX is INTEGER !! On entry, INCX specifies the increment for the elements of !! X. INCX must not be zero. !! !! Y !! !! Y is COMPLEX array, dimension at least !! ( 1 + ( n - 1 )*abs( INCY ) ). !! Before entry, the incremented array Y must contain the n !! element vector y. !! !! INCY !! !! INCY is INTEGER !! On entry, INCY specifies the increment for the elements of !! Y. INCY must not be zero. !! !! A !! !! A is COMPLEX array, 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 !! !! LDA is 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 ). !! !!##AUTHORS !! !! + Univ. of Tennessee !! + Univ. of California Berkeley !! + Univ. of Colorado Denver !! + NAG Ltd. !! !! date:December 2016 !! !! FURTHER DETAILS !! !! 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. !! !!##SEE ALSO !! Online html documentation available at !! http://www.netlib.org/lapack/explore-html/ ! ===================================================================== subroutine cgeru(m,n,alpha,x,incx,y,incy,a,lda) implicit none ! ! -- Reference BLAS level2 routine (version 3.7.0) -- ! -- Reference BLAS is a software package provided by Univ. of Tennessee, -- ! -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- ! December 2016 ! ! .. Scalar Arguments .. complex,intent(in) :: alpha integer,intent(in) :: incx,incy,lda,m,n ! .. ! .. Array Arguments .. complex,intent(inout) :: a(lda,*) complex,intent(in) :: x(*),y(*) ! .. ! ! ===================================================================== ! ! .. Parameters .. complex zero parameter (zero= (0.0e+0,0.0e+0)) ! .. ! .. Local Scalars .. complex temp integer i,info,ix,j,jy,kx ! .. ! .. External Subroutines .. ! .. ! .. Intrinsic Functions .. intrinsic max ! .. ! ! Test the input parameters. ! info = 0 if (m.lt.0) then info = 1 elseif (n.lt.0) then info = 2 elseif (incx.eq.0) then info = 5 elseif (incy.eq.0) then info = 7 elseif (lda.lt.max(1,m)) then info = 9 endif if (info.ne.0) then call xerbla('CGERU ',info) return endif ! ! Quick return if possible. ! if ((m.eq.0) .or. (n.eq.0) .or. (alpha.eq.zero)) return ! ! Start the operations. In this version the elements of A are ! accessed sequentially with one pass through A. ! if (incy.gt.0) then jy = 1 else jy = 1 - (n-1)*incy endif if (incx.eq.1) then do j = 1,n if (y(jy).ne.zero) then temp = alpha*y(jy) do i = 1,m a(i,j) = a(i,j) + x(i)*temp enddo endif jy = jy + incy enddo else if (incx.gt.0) then kx = 1 else kx = 1 - (m-1)*incx endif do j = 1,n if (y(jy).ne.zero) then temp = alpha*y(jy) ix = kx do i = 1,m a(i,j) = a(i,j) + x(ix)*temp ix = ix + incx enddo endif jy = jy + incy enddo endif end subroutine cgeru !> !!##NAME !! chbmv(3f) - [BLAS:COMPLEX_BLAS_LEVEL2] CY := alpha*A*CX + beta*CY; ==> A a (square) hermitian band matrix. !! !!##SYNOPSIS !! !! subroutine chbmv(uplo,n,k,alpha,a,lda,x,incx,beta,y,incy) !! !! .. Scalar Arguments .. !! complex,intent(in) :: alpha,beta !! integer,intent(in) :: incx,incy,k,lda,n !! character,intent(in) :: uplo !! .. !! .. Array Arguments .. !! complex,intent(in) :: a(lda,*),x(*) !! complex,intent(inout) :: y(*) !! .. !! !!##DEFINITION !! !! CHBMV(3f) 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 hermitian band matrix, with k super-diagonals. !! !!##OPTIONS !! !! UPLO !! !! UPLO is 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. !! !! N !! !! N is INTEGER !! On entry, N specifies the order of the matrix A. !! N must be at least zero. !! !! K !! !! K is INTEGER !! On entry, K specifies the number of super-diagonals of the !! matrix A. K must satisfy 0 .le. K. !! !! ALPHA !! !! ALPHA is COMPLEX !! On entry, ALPHA specifies the scalar alpha. !! !! A !! !! A is COMPLEX array, 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 hermitian 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 hermitian 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 hermitian 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 hermitian 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 the imaginary parts of the diagonal elements need !! not be set and are assumed to be zero. !! !! LDA !! !! LDA is INTEGER !! On entry, LDA specifies the first dimension of A as declared !! in the calling (sub) program. LDA must be at least !! ( k + 1 ). !! !! X !! !! X is COMPLEX array, dimension at least !! ( 1 + ( n - 1 )*abs( INCX ) ). !! Before entry, the incremented array X must contain the !! vector x. !! !! INCX !! !! INCX is INTEGER !! On entry, INCX specifies the increment for the elements of !! X. INCX must not be zero. !! !! BETA !! !! BETA is COMPLEX !! On entry, BETA specifies the scalar beta. !! !! Y !! !! Y is COMPLEX array, 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 !! !! INCY is INTEGER !! On entry, INCY specifies the increment for the elements of !! Y. INCY must not be zero. !! !!##AUTHORS !! !! + Univ. of Tennessee !! + Univ. of California Berkeley !! + Univ. of Colorado Denver !! + NAG Ltd. !! !! date:December 2016 !! !! FURTHER DETAILS !! !! Level 2 Blas routine. !! The vector and matrix arguments are not referenced when N = 0, or M = 0 !! !! -- 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. !! !!##SEE ALSO !! Online html documentation available at !! http://www.netlib.org/lapack/explore-html/ ! ===================================================================== subroutine chbmv(uplo,n,k,alpha,a,lda,x,incx,beta,y,incy) implicit none ! ! -- Reference BLAS level2 routine (version 3.7.0) -- ! -- Reference BLAS is a software package provided by Univ. of Tennessee, -- ! -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- ! December 2016 ! ! .. Scalar Arguments .. complex,intent(in) :: alpha,beta integer,intent(in) :: incx,incy,k,lda,n character,intent(in) :: uplo ! .. ! .. Array Arguments .. complex,intent(in) :: a(lda,*),x(*) complex,intent(inout) :: y(*) ! .. ! ! ===================================================================== ! ! .. Parameters .. complex one parameter (one= (1.0e+0,0.0e+0)) complex zero parameter (zero= (0.0e+0,0.0e+0)) ! .. ! .. Local Scalars .. complex temp1,temp2 integer i,info,ix,iy,j,jx,jy,kplus1,kx,ky,l ! .. ! .. External Functions .. ! .. ! .. External Subroutines .. ! .. ! .. Intrinsic Functions .. intrinsic conjg,max,min,real ! .. ! ! Test the input parameters. ! info = 0 if (.not.lsame(uplo,'U') .and. .not.lsame(uplo,'L')) then info = 1 elseif (n.lt.0) then info = 2 elseif (k.lt.0) then info = 3 elseif (lda.lt. (k+1)) then info = 6 elseif (incx.eq.0) then info = 8 elseif (incy.eq.0) then info = 11 endif if (info.ne.0) then call xerbla('CHBMV ',info) return endif ! ! Quick return if possible. ! if ((n.eq.0) .or. ((alpha.eq.zero).and. (beta.eq.one))) return ! ! Set up the start points in X and Y. ! if (incx.gt.0) then kx = 1 else kx = 1 - (n-1)*incx endif if (incy.gt.0) then ky = 1 else ky = 1 - (n-1)*incy endif ! ! 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.ne.one) then if (incy.eq.1) then if (beta.eq.zero) then y(1:n) = zero else y(1:n) = beta*y(1:n) endif else iy = ky if (beta.eq.zero) then do i = 1,n y(iy) = zero iy = iy + incy enddo else do i = 1,n y(iy) = beta*y(iy) iy = iy + incy enddo endif endif endif if (alpha.eq.zero) return if (lsame(uplo,'U')) then ! ! Form y when upper triangle of A is stored. ! kplus1 = k + 1 if ((incx.eq.1) .and. (incy.eq.1)) then do j = 1,n temp1 = alpha*x(j) temp2 = zero l = kplus1 - j do i = max(1,j-k),j - 1 y(i) = y(i) + temp1*a(l+i,j) temp2 = temp2 + conjg(a(l+i,j))*x(i) enddo y(j) = y(j) + temp1*real(a(kplus1,j)) + alpha*temp2 enddo else jx = kx jy = ky do j = 1,n temp1 = alpha*x(jx) temp2 = zero ix = kx iy = ky l = kplus1 - j do i = max(1,j-k),j - 1 y(iy) = y(iy) + temp1*a(l+i,j) temp2 = temp2 + conjg(a(l+i,j))*x(ix) ix = ix + incx iy = iy + incy enddo y(jy) = y(jy) + temp1*real(a(kplus1,j)) + alpha*temp2 jx = jx + incx jy = jy + incy if (j.gt.k) then kx = kx + incx ky = ky + incy endif enddo endif else ! ! Form y when lower triangle of A is stored. ! if ((incx.eq.1) .and. (incy.eq.1)) then do j = 1,n temp1 = alpha*x(j) temp2 = zero y(j) = y(j) + temp1*real(a(1,j)) l = 1 - j do i = j + 1,min(n,j+k) y(i) = y(i) + temp1*a(l+i,j) temp2 = temp2 + conjg(a(l+i,j))*x(i) enddo y(j) = y(j) + alpha*temp2 enddo else jx = kx jy = ky do j = 1,n temp1 = alpha*x(jx) temp2 = zero y(jy) = y(jy) + temp1*real(a(1,j)) l = 1 - j ix = jx iy = jy do i = j + 1,min(n,j+k) ix = ix + incx iy = iy + incy y(iy) = y(iy) + temp1*a(l+i,j) temp2 = temp2 + conjg(a(l+i,j))*x(ix) enddo y(jy) = y(jy) + alpha*temp2 jx = jx + incx jy = jy + incy enddo endif endif ! ! End of CHBMV . ! end subroutine chbmv !> !!##NAME !! chemm(3f) - [BLAS:COMPLEX_BLAS_LEVEL3] C:=alpha*A*TRANSPOSE(A)+beta*C; ==> A hermitian, B, C rectangular. !! !!##SYNOPSIS !! !! subroutine chemm(side,uplo,m,n,alpha,a,lda,b,ldb,beta,c,ldc) !! !! .. Scalar Arguments .. !! complex,intent(in) :: alpha,beta !! integer,intent(in) :: lda,ldb,ldc,m,n !! character,intent(in) :: side,uplo !! .. !! .. Array Arguments .. !! complex,intent(in) :: a(lda,*),b(ldb,*) !! complex,intent(inout) :: c(ldc,*) !! .. !! !!##DEFINITION !! !! CHEMM 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 an hermitian matrix and B and !! C are m by n matrices. !! !!##OPTIONS !! !! SIDE !! !! SIDE is CHARACTER*1 !! On entry, SIDE specifies whether the hermitian 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, !! !! UPLO !! !! UPLO is CHARACTER*1 !! On entry, UPLO specifies whether the upper or lower !! triangular part of the hermitian matrix A is to be !! referenced as follows: !! !! UPLO = 'U' or 'u' Only the upper triangular part of the !! hermitian matrix is to be referenced. !! !! UPLO = 'L' or 'l' Only the lower triangular part of the !! hermitian matrix is to be referenced. !! !! M !! !! M is INTEGER !! On entry, M specifies the number of rows of the matrix C. !! M must be at least zero. !! !! N !! !! N is INTEGER !! On entry, N specifies the number of columns of the matrix C. !! N must be at least zero. !! !! ALPHA !! !! ALPHA is COMPLEX !! On entry, ALPHA specifies the scalar alpha. !! !! A !! !! A is COMPLEX array, 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 hermitian 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 hermitian 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 hermitian !! 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 hermitian 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 hermitian 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 hermitian !! matrix and the strictly upper triangular part of A is not !! referenced. !! Note that the imaginary parts of the diagonal elements need !! not be set, they are assumed to be zero. !! !! LDA !! !! LDA is 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 ). !! !! B !! !! B is COMPLEX array, dimension ( LDB, N ) !! Before entry, the leading m by n part of the array B must !! contain the matrix B. !! !! LDB !! !! LDB is 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 ). !! !! BETA !! !! BETA is COMPLEX !! On entry, BETA specifies the scalar beta. When BETA is !! supplied as zero then C need not be set on input. !! !! C !! !! C is COMPLEX array, 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 !! !! LDC is 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 ). !! !!##AUTHORS !! !! + Univ. of Tennessee !! + Univ. of California Berkeley !! + Univ. of Colorado Denver !! + NAG Ltd. !! !! date:December 2016 !! !! FURTHER DETAILS !! !! 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. !! !!##SEE ALSO !! Online html documentation available at !! http://www.netlib.org/lapack/explore-html/ ! ===================================================================== subroutine chemm(side,uplo,m,n,alpha,a,lda,b,ldb,beta,c,ldc) implicit none ! ! -- Reference BLAS level3 routine (version 3.7.0) -- ! -- Reference BLAS is a software package provided by Univ. of Tennessee, -- ! -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- ! December 2016 ! ! .. Scalar Arguments .. complex,intent(in) :: alpha,beta integer,intent(in) :: lda,ldb,ldc,m,n character,intent(in) :: side,uplo ! .. ! .. Array Arguments .. complex,intent(in) :: a(lda,*),b(ldb,*) complex,intent(inout) :: c(ldc,*) ! .. ! ! ===================================================================== ! ! .. External Functions .. ! .. ! .. External Subroutines .. ! .. ! .. Intrinsic Functions .. intrinsic conjg,max,real ! .. ! .. Local Scalars .. complex temp1,temp2 integer i,info,j,k,nrowa logical upper ! .. ! .. Parameters .. complex one parameter (one= (1.0e+0,0.0e+0)) complex zero parameter (zero= (0.0e+0,0.0e+0)) ! .. ! ! Set NROWA as the number of rows of A. ! if (lsame(side,'L')) then nrowa = m else nrowa = n endif upper = lsame(uplo,'U') ! ! Test the input parameters. ! info = 0 if ((.not.lsame(side,'L')) .and. (.not.lsame(side,'R'))) then info = 1 elseif ((.not.upper) .and. (.not.lsame(uplo,'L'))) then info = 2 elseif (m.lt.0) then info = 3 elseif (n.lt.0) then info = 4 elseif (lda.lt.max(1,nrowa)) then info = 7 elseif (ldb.lt.max(1,m)) then info = 9 elseif (ldc.lt.max(1,m)) then info = 12 endif if (info.ne.0) then call xerbla('CHEMM ',info) return endif ! ! Quick return if possible. ! if ((m.eq.0) .or. (n.eq.0) .or. ((alpha.eq.zero).and. (beta.eq.one))) return ! ! And when alpha.eq.zero. ! if (alpha.eq.zero) then if (beta.eq.zero) then c(1:m,1:n) = zero else c(1:m,1:n) = beta*c(1:m,1:n) endif return endif ! ! Start the operations. ! if (lsame(side,'L')) then ! ! Form C := alpha*A*B + beta*C. ! if (upper) then do j = 1,n do i = 1,m temp1 = alpha*b(i,j) temp2 = zero do k = 1,i - 1 c(k,j) = c(k,j) + temp1*a(k,i) temp2 = temp2 + b(k,j)*conjg(a(k,i)) enddo if (beta.eq.zero) then c(i,j) = temp1*real(a(i,i)) + alpha*temp2 else c(i,j) = beta*c(i,j) + temp1*real(a(i,i)) + alpha*temp2 endif enddo enddo else do j = 1,n do i = m,1,-1 temp1 = alpha*b(i,j) temp2 = zero do k = i + 1,m c(k,j) = c(k,j) + temp1*a(k,i) temp2 = temp2 + b(k,j)*conjg(a(k,i)) enddo if (beta.eq.zero) then c(i,j) = temp1*real(a(i,i)) + alpha*temp2 else c(i,j) = beta*c(i,j) + temp1*real(a(i,i)) + alpha*temp2 endif enddo enddo endif else ! ! Form C := alpha*B*A + beta*C. ! do j = 1,n temp1 = alpha*real(a(j,j)) if (beta.eq.zero) then c(1:m,j) = temp1*b(1:m,j) else c(1:m,j) = beta*c(1:m,j) + temp1*b(1:m,j) endif do k = 1,j - 1 if (upper) then temp1 = alpha*a(k,j) else temp1 = alpha*conjg(a(j,k)) endif c(1:m,j) = c(1:m,j) + temp1*b(1:m,k) enddo do k = j + 1,n if (upper) then temp1 = alpha*conjg(a(j,k)) else temp1 = alpha*a(k,j) endif c(1:m,j) = c(1:m,j) + temp1*b(1:m,k) enddo enddo endif ! ! End of CHEMM . ! end subroutine chemm !> !!##NAME !! chemv(3f) - [BLAS:COMPLEX_BLAS_LEVEL2] CY := alpha*A*CX + beta*CY; ==> A a (square) hermitian matrix. !! !!##SYNOPSIS !! !! subroutine chemv(uplo,n,alpha,a,lda,x,incx,beta,y,incy) !! !! .. Scalar Arguments .. !! complex,intent(in) :: alpha,beta !! integer,intent(in) :: incx,incy,lda,n !! character,intent(in) :: uplo !! .. !! .. Array Arguments .. !! complex,intent(in) :: a(lda,*),x(*) !! complex,intent(inout) :: y(*) !! .. !! !!##DEFINITION !! !! CHEMV 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 hermitian matrix. !! !!##OPTIONS !! !! UPLO !! !! UPLO is 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. !! !! N !! !! N is INTEGER !! On entry, N specifies the order of the matrix A. !! N must be at least zero. !! !! ALPHA !! !! ALPHA is COMPLEX !! On entry, ALPHA specifies the scalar alpha. !! !! A !! !! A is COMPLEX array, 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 hermitian 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 hermitian matrix and the strictly !! upper triangular part of A is not referenced. !! Note that the imaginary parts of the diagonal elements need !! not be set and are assumed to be zero. !! !! LDA !! !! LDA is 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 ). !! !! X !! !! X is COMPLEX array, dimension at least !! ( 1 + ( n - 1 )*abs( INCX ) ). !! Before entry, the incremented array X must contain the n !! element vector x. !! !! INCX !! !! INCX is INTEGER !! On entry, INCX specifies the increment for the elements of !! X. INCX must not be zero. !! !! BETA !! !! BETA is COMPLEX !! On entry, BETA specifies the scalar beta. When BETA is !! supplied as zero then Y need not be set on input. !! !! Y !! !! Y is COMPLEX array, 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 !! !! INCY is INTEGER !! On entry, INCY specifies the increment for the elements of !! Y. INCY must not be zero. !! !!##AUTHORS !! !! + Univ. of Tennessee !! + Univ. of California Berkeley !! + Univ. of Colorado Denver !! + NAG Ltd. !! !! date:December 2016 !! !! FURTHER DETAILS !! !! Level 2 Blas routine. !! The vector and matrix arguments are not referenced when N = 0, or M = 0 !! !! -- 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. !! !!##SEE ALSO !! Online html documentation available at !! http://www.netlib.org/lapack/explore-html/ ! ===================================================================== subroutine chemv(uplo,n,alpha,a,lda,x,incx,beta,y,incy) implicit none ! ! -- Reference BLAS level2 routine (version 3.7.0) -- ! -- Reference BLAS is a software package provided by Univ. of Tennessee, -- ! -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- ! December 2016 ! ! .. Scalar Arguments .. complex,intent(in) :: alpha,beta integer,intent(in) :: incx,incy,lda,n character,intent(in) :: uplo ! .. ! .. Array Arguments .. complex,intent(in) :: a(lda,*),x(*) complex,intent(inout) :: y(*) ! .. ! ! ===================================================================== ! ! .. Parameters .. complex one parameter (one= (1.0e+0,0.0e+0)) complex zero parameter (zero= (0.0e+0,0.0e+0)) ! .. ! .. Local Scalars .. complex temp1,temp2 integer i,info,ix,iy,j,jx,jy,kx,ky ! .. ! .. External Functions .. ! .. ! .. External Subroutines .. ! .. ! .. Intrinsic Functions .. intrinsic conjg,max,real ! .. ! ! Test the input parameters. ! info = 0 if (.not.lsame(uplo,'U') .and. .not.lsame(uplo,'L')) then info = 1 elseif (n.lt.0) then info = 2 elseif (lda.lt.max(1,n)) then info = 5 elseif (incx.eq.0) then info = 7 elseif (incy.eq.0) then info = 10 endif if (info.ne.0) then call xerbla('CHEMV ',info) return endif ! ! Quick return if possible. ! if ((n.eq.0) .or. ((alpha.eq.zero).and. (beta.eq.one))) return ! ! Set up the start points in X and Y. ! if (incx.gt.0) then kx = 1 else kx = 1 - (n-1)*incx endif if (incy.gt.0) then ky = 1 else ky = 1 - (n-1)*incy endif ! ! 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.ne.one) then if (incy.eq.1) then if (beta.eq.zero) then y(1:n) = zero else y(1:n) = beta*y(1:n) endif else iy = ky if (beta.eq.zero) then do i = 1,n y(iy) = zero iy = iy + incy enddo else do i = 1,n y(iy) = beta*y(iy) iy = iy + incy enddo endif endif endif if (alpha.eq.zero) return if (lsame(uplo,'U')) then ! ! Form y when A is stored in upper triangle. ! if ((incx.eq.1) .and. (incy.eq.1)) then do j = 1,n temp1 = alpha*x(j) temp2 = zero do i = 1,j - 1 y(i) = y(i) + temp1*a(i,j) temp2 = temp2 + conjg(a(i,j))*x(i) enddo y(j) = y(j) + temp1*real(a(j,j)) + alpha*temp2 enddo else jx = kx jy = ky do j = 1,n temp1 = alpha*x(jx) temp2 = zero ix = kx iy = ky do i = 1,j - 1 y(iy) = y(iy) + temp1*a(i,j) temp2 = temp2 + conjg(a(i,j))*x(ix) ix = ix + incx iy = iy + incy enddo y(jy) = y(jy) + temp1*real(a(j,j)) + alpha*temp2 jx = jx + incx jy = jy + incy enddo endif else ! ! Form y when A is stored in lower triangle. ! if ((incx.eq.1) .and. (incy.eq.1)) then do j = 1,n temp1 = alpha*x(j) temp2 = zero y(j) = y(j) + temp1*real(a(j,j)) do i = j + 1,n y(i) = y(i) + temp1*a(i,j) temp2 = temp2 + conjg(a(i,j))*x(i) enddo y(j) = y(j) + alpha*temp2 enddo else jx = kx jy = ky do j = 1,n temp1 = alpha*x(jx) temp2 = zero y(jy) = y(jy) + temp1*real(a(j,j)) ix = jx iy = jy do i = j + 1,n ix = ix + incx iy = iy + incy y(iy) = y(iy) + temp1*a(i,j) temp2 = temp2 + conjg(a(i,j))*x(ix) enddo y(jy) = y(jy) + alpha*temp2 jx = jx + incx jy = jy + incy enddo endif endif ! end subroutine chemv !> !!##NAME !! cher2(3f) - [BLAS:COMPLEX_BLAS_LEVEL2] A := A + alpha*CX*CONJUGATE-TRANSPOSE(CY)n + CONJUGATE(alpha)*CY*CONJUGATE-TRANSPOSE(CX); !! ==> n A a (square) hermitian matrix. !! (performs the hermitian rank 2 operation) !! !!##SYNOPSIS !! !! subroutine cher2(uplo,n,alpha,x,incx,y,incy,a,lda) !! !! .. Scalar Arguments .. !! complex,intent(in) :: alpha !! integer,intent(in) :: incx,incy,lda,n !! character,intent(in) :: uplo !! .. !! .. Array Arguments .. !! complex,intent(inout) :: a(lda,*) !! complex,intent(in) :: x(*),y(*) !! .. !! !!##DEFINITION !! !! CHER2 performs the hermitian rank 2 operation !! !! A := alpha*x*y**H + conjg( alpha )*y*x**H + A, !! !! where alpha is a scalar, x and y are n element vectors and A is an n !! by n hermitian matrix. !! !!##OPTIONS !! !! UPLO !! !! UPLO is 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. !! !! N !! !! N is INTEGER !! On entry, N specifies the order of the matrix A. !! N must be at least zero. !! !! ALPHA !! !! ALPHA is COMPLEX !! On entry, ALPHA specifies the scalar alpha. !! !! X !! !! X is COMPLEX array, dimension at least !! ( 1 + ( n - 1 )*abs( INCX ) ). !! Before entry, the incremented array X must contain the n !! element vector x. !! !! INCX !! !! INCX is INTEGER !! On entry, INCX specifies the increment for the elements of !! X. INCX must not be zero. !! !! Y !! !! Y is COMPLEX array, dimension at least !! ( 1 + ( n - 1 )*abs( INCY ) ). !! Before entry, the incremented array Y must contain the n !! element vector y. !! !! INCY !! !! INCY is INTEGER !! On entry, INCY specifies the increment for the elements of !! Y. INCY must not be zero. !! !! A !! !! A is COMPLEX array, 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 hermitian 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 hermitian 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. !! Note that the imaginary parts of the diagonal elements need !! not be set, they are assumed to be zero, and on exit they !! are set to zero. !! !! LDA !! !! LDA is 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 ). !! !!##AUTHORS !! !! + Univ. of Tennessee !! + Univ. of California Berkeley !! + Univ. of Colorado Denver !! + NAG Ltd. !! !! date:December 2016 !! !! FURTHER DETAILS !! !! 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. !! !!##SEE ALSO !! Online html documentation available at !! http://www.netlib.org/lapack/explore-html/ ! ===================================================================== subroutine cher2(uplo,n,alpha,x,incx,y,incy,a,lda) implicit none ! ! -- Reference BLAS level2 routine (version 3.7.0) -- ! -- Reference BLAS is a software package provided by Univ. of Tennessee, -- ! -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- ! December 2016 ! ! .. Scalar Arguments .. complex,intent(in) :: alpha integer,intent(in) :: incx,incy,lda,n character,intent(in) :: uplo ! .. ! .. Array Arguments .. complex,intent(inout) :: a(lda,*) complex,intent(in) :: x(*),y(*) ! .. ! ! ===================================================================== ! ! .. Parameters .. complex zero parameter (zero= (0.0e+0,0.0e+0)) ! .. ! .. Local Scalars .. complex temp1,temp2 integer i,info,ix,iy,j,jx,jy,kx,ky ! .. ! .. External Functions .. ! .. ! .. External Subroutines .. ! .. ! .. Intrinsic Functions .. intrinsic conjg,max,real ! .. ! ! Test the input parameters. ! info = 0 if (.not.lsame(uplo,'U') .and. .not.lsame(uplo,'L')) then info = 1 elseif (n.lt.0) then info = 2 elseif (incx.eq.0) then info = 5 elseif (incy.eq.0) then info = 7 elseif (lda.lt.max(1,n)) then info = 9 endif if (info.ne.0) then call xerbla('CHER2 ',info) return endif ! ! Quick return if possible. ! if ((n.eq.0) .or. (alpha.eq.zero)) return ! ! Set up the start points in X and Y if the increments are not both ! unity. ! if ((incx.ne.1) .or. (incy.ne.1)) then if (incx.gt.0) then kx = 1 else kx = 1 - (n-1)*incx endif if (incy.gt.0) then ky = 1 else ky = 1 - (n-1)*incy endif jx = kx jy = ky endif ! ! 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')) then ! ! Form A when A is stored in the upper triangle. ! if ((incx.eq.1) .and. (incy.eq.1)) then do j = 1,n if ((x(j).ne.zero) .or. (y(j).ne.zero)) then temp1 = alpha*conjg(y(j)) temp2 = conjg(alpha*x(j)) do i = 1,j - 1 a(i,j) = a(i,j) + x(i)*temp1 + y(i)*temp2 enddo a(j,j) = real(a(j,j)) + real(x(j)*temp1+y(j)*temp2) else a(j,j) = real(a(j,j)) endif enddo else do j = 1,n if ((x(jx).ne.zero) .or. (y(jy).ne.zero)) then temp1 = alpha*conjg(y(jy)) temp2 = conjg(alpha*x(jx)) ix = kx iy = ky do i = 1,j - 1 a(i,j) = a(i,j) + x(ix)*temp1 + y(iy)*temp2 ix = ix + incx iy = iy + incy enddo a(j,j) = real(a(j,j)) + real(x(jx)*temp1+y(jy)*temp2) else a(j,j) = real(a(j,j)) endif jx = jx + incx jy = jy + incy enddo endif else ! ! Form A when A is stored in the lower triangle. ! if ((incx.eq.1) .and. (incy.eq.1)) then do j = 1,n if ((x(j).ne.zero) .or. (y(j).ne.zero)) then temp1 = alpha*conjg(y(j)) temp2 = conjg(alpha*x(j)) a(j,j) = real(a(j,j)) + real(x(j)*temp1+y(j)*temp2) do i = j + 1,n a(i,j) = a(i,j) + x(i)*temp1 + y(i)*temp2 enddo else a(j,j) = real(a(j,j)) endif enddo else do j = 1,n if ((x(jx).ne.zero) .or. (y(jy).ne.zero)) then temp1 = alpha*conjg(y(jy)) temp2 = conjg(alpha*x(jx)) a(j,j) = real(a(j,j)) + real(x(jx)*temp1+y(jy)*temp2) ix = jx iy = jy do i = j + 1,n ix = ix + incx iy = iy + incy a(i,j) = a(i,j) + x(ix)*temp1 + y(iy)*temp2 enddo else a(j,j) = real(a(j,j)) endif jx = jx + incx jy = jy + incy enddo endif endif ! end subroutine cher2 !> !!##NAME !! cher2k(3f) - [BLAS:COMPLEX_BLAS_LEVEL3] !! C:=alpha*A*TRANSPOSE(B)+alpha*B*TRANSPOSE(A)+beta*C; ==> C hermitian. !! (performs one of the hermitian rank 2k operations) !! !!##SYNOPSIS !! !! subroutine cher2k(uplo,trans,n,k,alpha,a,lda,b,ldb,beta,c,ldc) !! !! .. Scalar Arguments .. !! complex,intent(in) :: alpha !! real,intent(in) :: beta !! integer,intent(in) :: k,lda,ldb,ldc,n !! character,intent(in) :: trans,uplo !! .. !! .. Array Arguments .. !! complex,intent(in) :: a(lda,*),b(ldb,*) !! complex,intent(inout) :: c(ldc,*) !! .. !! !!##DEFINITION !! !! CHER2K performs one of the hermitian rank 2k operations !! !! C := alpha*A*B**H + conjg( alpha )*B*A**H + beta*C, !! !! or !! !! C := alpha*A**H*B + conjg( alpha )*B**H*A + beta*C, !! !! where alpha and beta are scalars with beta real, C is an n by n !! hermitian matrix and A and B are n by k matrices in the first case !! and k by n matrices in the second case. !! !!##OPTIONS !! !! UPLO !! !! UPLO is 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. !! !! TRANS !! !! TRANS is CHARACTER*1 !! On entry, TRANS specifies the operation to be performed as !! follows: !! !! TRANS = 'N' or 'n' C := alpha*A*B**H + !! conjg( alpha )*B*A**H + !! beta*C. !! !! TRANS = 'C' or 'c' C := alpha*A**H*B + !! conjg( alpha )*B**H*A + !! beta*C. !! !! N !! !! N is INTEGER !! On entry, N specifies the order of the matrix C. N must be !! at least zero. !! !! K !! !! K is 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 = 'C' or 'c', K specifies the number of rows of the !! matrices A and B. K must be at least zero. !! !! ALPHA !! !! ALPHA is COMPLEX !! On entry, ALPHA specifies the scalar alpha. !! !! A !! !! A is COMPLEX array, 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. !! !! LDA !! !! LDA is 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 ). !! !! B !! !! B is COMPLEX array, 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. !! !! LDB !! !! LDB is 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 ). !! !! BETA !! !! BETA is REAL !! On entry, BETA specifies the scalar beta. !! !! C !! !! C is COMPLEX array, 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 hermitian 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 hermitian 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. !! Note that the imaginary parts of the diagonal elements need !! not be set, they are assumed to be zero, and on exit they !! are set to zero. !! !! LDC !! !! LDC is 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 ). !! !!##AUTHORS !! !! + Univ. of Tennessee !! + Univ. of California Berkeley !! + Univ. of Colorado Denver !! + NAG Ltd. !! !! date:December 2016 !! !! FURTHER DETAILS !! !! 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. !! !! -- Modified 8-Nov-93 to set C(J,J) to REAL( C(J,J) ) when BETA = 1. !! Ed Anderson, Cray Research Inc. !! !!##SEE ALSO !! Online html documentation available at !! http://www.netlib.org/lapack/explore-html/ ! ===================================================================== subroutine cher2k(uplo,trans,n,k,alpha,a,lda,b,ldb,beta,c,ldc) implicit none ! ! -- Reference BLAS level3 routine (version 3.7.0) -- ! -- Reference BLAS is a software package provided by Univ. of Tennessee, -- ! -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- ! December 2016 ! ! .. Scalar Arguments .. complex,intent(in) :: alpha real,intent(in) :: beta integer,intent(in) :: k,lda,ldb,ldc,n character,intent(in) :: trans,uplo ! .. ! .. Array Arguments .. complex,intent(in) :: a(lda,*),b(ldb,*) complex,intent(inout) :: c(ldc,*) ! .. ! ! ===================================================================== ! ! .. External Functions .. ! .. ! .. External Subroutines .. ! .. ! .. Intrinsic Functions .. intrinsic conjg,max,real ! .. ! .. Local Scalars .. complex temp1,temp2 integer i,info,j,l,nrowa logical upper ! .. ! .. Parameters .. real one parameter (one=1.0e+0) complex zero parameter (zero= (0.0e+0,0.0e+0)) ! .. ! ! Test the input parameters. ! if (lsame(trans,'N')) then nrowa = n else nrowa = k endif upper = lsame(uplo,'U') ! info = 0 if ((.not.upper) .and. (.not.lsame(uplo,'L'))) then info = 1 elseif ((.not.lsame(trans,'N')) .and. (.not.lsame(trans,'C'))) then info = 2 elseif (n.lt.0) then info = 3 elseif (k.lt.0) then info = 4 elseif (lda.lt.max(1,nrowa)) then info = 7 elseif (ldb.lt.max(1,nrowa)) then info = 9 elseif (ldc.lt.max(1,n)) then info = 12 endif if (info.ne.0) then call xerbla('CHER2K',info) return endif ! ! Quick return if possible. ! if ((n.eq.0) .or. (((alpha.eq.zero).or. (k.eq.0)).and. (beta.eq.one))) return ! ! And when alpha.eq.zero. ! if (alpha.eq.zero) then if (upper) then if (beta.eq.real(zero)) then do j = 1,n c(1:j,j) = zero enddo else do j = 1,n do i = 1,j - 1 c(i,j) = beta*c(i,j) enddo c(j,j) = beta*real(c(j,j)) enddo endif else if (beta.eq.real(zero)) then do j = 1,n c(j:n,j) = zero enddo else do j = 1,n c(j,j) = beta*real(c(j,j)) do i = j + 1,n c(i,j) = beta*c(i,j) enddo enddo endif endif return endif ! ! Start the operations. ! if (lsame(trans,'N')) then ! ! Form C := alpha*A*B**H + conjg( alpha )*B*A**H + ! C. ! if (upper) then do j = 1,n if (beta.eq.real(zero)) then do i = 1,j c(i,j) = zero enddo elseif (beta.ne.one) then do i = 1,j - 1 c(i,j) = beta*c(i,j) enddo c(j,j) = beta*real(c(j,j)) else c(j,j) = real(c(j,j)) endif do l = 1,k if ((a(j,l).ne.zero) .or. (b(j,l).ne.zero)) then temp1 = alpha*conjg(b(j,l)) temp2 = conjg(alpha*a(j,l)) do i = 1,j - 1 c(i,j) = c(i,j) + a(i,l)*temp1 + b(i,l)*temp2 enddo c(j,j) = real(c(j,j)) + real(a(j,l)*temp1+b(j,l)*temp2) endif enddo enddo else do j = 1,n if (beta.eq.real(zero)) then c(j:n,j) = zero elseif (beta.ne.one) then do i = j + 1,n c(i,j) = beta*c(i,j) enddo c(j,j) = beta*real(c(j,j)) else c(j,j) = real(c(j,j)) endif do l = 1,k if ((a(j,l).ne.zero) .or. (b(j,l).ne.zero)) then temp1 = alpha*conjg(b(j,l)) temp2 = conjg(alpha*a(j,l)) do i = j + 1,n c(i,j) = c(i,j) + a(i,l)*temp1 + b(i,l)*temp2 enddo c(j,j) = real(c(j,j)) + real(a(j,l)*temp1+b(j,l)*temp2) endif enddo enddo endif else ! ! Form C := alpha*A**H*B + conjg( alpha )*B**H*A + ! C. ! if (upper) then do j = 1,n do i = 1,j temp1 = zero temp2 = zero do l = 1,k temp1 = temp1 + conjg(a(l,i))*b(l,j) temp2 = temp2 + conjg(b(l,i))*a(l,j) enddo if (i.eq.j) then if (beta.eq.real(zero)) then c(j,j) = real(alpha*temp1+ conjg(alpha)*temp2) else c(j,j) = beta*real(c(j,j)) + real(alpha*temp1+ conjg(alpha)*temp2) endif else if (beta.eq.real(zero)) then c(i,j) = alpha*temp1 + conjg(alpha)*temp2 else c(i,j) = beta*c(i,j) + alpha*temp1 + conjg(alpha)*temp2 endif endif enddo enddo else do j = 1,n do i = j,n temp1 = zero temp2 = zero do l = 1,k temp1 = temp1 + conjg(a(l,i))*b(l,j) temp2 = temp2 + conjg(b(l,i))*a(l,j) enddo if (i.eq.j) then if (beta.eq.real(zero)) then c(j,j) = real(alpha*temp1+ conjg(alpha)*temp2) else c(j,j) = beta*real(c(j,j)) + real(alpha*temp1+ conjg(alpha)*temp2) endif else if (beta.eq.real(zero)) then c(i,j) = alpha*temp1 + conjg(alpha)*temp2 else c(i,j) = beta*c(i,j) + alpha*temp1 + conjg(alpha)*temp2 endif endif enddo enddo endif endif ! end subroutine cher2k !> !!##NAME !! cher(3f) - [BLAS:COMPLEX_BLAS_LEVEL2] A := A + alpha*CX*CONJUGATE-TRANSPOSE(CX); ==> A a (square) hermitian matrix. !! (performs the hermitian rank 1 operation) !! !!##SYNOPSIS !! !! subroutine cher(uplo,n,alpha,x,incx,a,lda) !! !! .. Scalar Arguments .. !! real,intent(in) :: alpha !! integer,intent(in) :: incx,lda,n !! character,intent(in) :: uplo !! .. !! .. Array Arguments .. !! complex,intent(inout) :: a(lda,*) !! complex,intent(in) :: x(*) !! .. !! !!##DEFINITION !! !! CHER performs the hermitian rank 1 operation !! !! A := alpha*x*x**H + A, !! !! where alpha is a real scalar, x is an n element vector and A is an !! n by n hermitian matrix. !! !!##OPTIONS !! !! UPLO !! !! UPLO is 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. !! !! N !! !! N is INTEGER !! On entry, N specifies the order of the matrix A. !! N must be at least zero. !! !! ALPHA !! !! ALPHA is REAL !! On entry, ALPHA specifies the scalar alpha. !! !! X !! !! X is COMPLEX array, dimension at least !! ( 1 + ( n - 1 )*abs( INCX ) ). !! Before entry, the incremented array X must contain the n !! element vector x. !! !! INCX !! !! INCX is INTEGER !! On entry, INCX specifies the increment for the elements of !! X. INCX must not be zero. !! !! A !! !! A is COMPLEX array, 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 hermitian 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 hermitian 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. !! Note that the imaginary parts of the diagonal elements need !! not be set, they are assumed to be zero, and on exit they !! are set to zero. !! !! LDA !! !! LDA is 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 ). !! !!##AUTHORS !! !! + Univ. of Tennessee !! + Univ. of California Berkeley !! + Univ. of Colorado Denver !! + NAG Ltd. !! !! date:December 2016 !! !! FURTHER DETAILS !! !! 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. !! !!##SEE ALSO !! Online html documentation available at !! http://www.netlib.org/lapack/explore-html/ ! ===================================================================== subroutine cher(uplo,n,alpha,x,incx,a,lda) implicit none ! ! -- Reference BLAS level2 routine (version 3.7.0) -- ! -- Reference BLAS is a software package provided by Univ. of Tennessee, -- ! -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- ! December 2016 ! ! .. Scalar Arguments .. real,intent(in) :: alpha integer,intent(in) :: incx,lda,n character,intent(in) :: uplo ! .. ! .. Array Arguments .. complex,intent(inout) :: a(lda,*) complex,intent(in) :: x(*) ! .. ! ! ===================================================================== ! ! .. Parameters .. complex zero parameter (zero= (0.0e+0,0.0e+0)) ! .. ! .. Local Scalars .. complex temp integer i,info,ix,j,jx,kx ! .. ! .. External Functions .. ! .. ! .. External Subroutines .. ! .. ! .. Intrinsic Functions .. intrinsic conjg,max,real ! .. ! ! Test the input parameters. ! info = 0 if (.not.lsame(uplo,'U') .and. .not.lsame(uplo,'L')) then info = 1 elseif (n.lt.0) then info = 2 elseif (incx.eq.0) then info = 5 elseif (lda.lt.max(1,n)) then info = 7 endif if (info.ne.0) then call xerbla('CHER ',info) return endif ! ! Quick return if possible. ! if ((n.eq.0) .or. (alpha.eq.real(zero))) return ! ! Set the start point in X if the increment is not unity. ! if (incx.le.0) then kx = 1 - (n-1)*incx elseif (incx.ne.1) then kx = 1 endif ! ! 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')) then ! ! Form A when A is stored in upper triangle. ! if (incx.eq.1) then do j = 1,n if (x(j).ne.zero) then temp = alpha*conjg(x(j)) do i = 1,j - 1 a(i,j) = a(i,j) + x(i)*temp enddo a(j,j) = real(a(j,j)) + real(x(j)*temp) else a(j,j) = real(a(j,j)) endif enddo else jx = kx do j = 1,n if (x(jx).ne.zero) then temp = alpha*conjg(x(jx)) ix = kx do i = 1,j - 1 a(i,j) = a(i,j) + x(ix)*temp ix = ix + incx enddo a(j,j) = real(a(j,j)) + real(x(jx)*temp) else a(j,j) = real(a(j,j)) endif jx = jx + incx enddo endif else ! ! Form A when A is stored in lower triangle. ! if (incx.eq.1) then do j = 1,n if (x(j).ne.zero) then temp = alpha*conjg(x(j)) a(j,j) = real(a(j,j)) + real(temp*x(j)) do i = j + 1,n a(i,j) = a(i,j) + x(i)*temp enddo else a(j,j) = real(a(j,j)) endif enddo else jx = kx do j = 1,n if (x(jx).ne.zero) then temp = alpha*conjg(x(jx)) a(j,j) = real(a(j,j)) + real(temp*x(jx)) ix = jx do i = j + 1,n ix = ix + incx a(i,j) = a(i,j) + x(ix)*temp enddo else a(j,j) = real(a(j,j)) endif jx = jx + incx enddo endif endif ! end subroutine cher !> !!##NAME !! cherk(3f) - [BLAS:COMPLEX_BLAS_LEVEL3] performs one of the hermitian rank k operations !! C:=alpha*A*TRANSPOSE(A)+beta*C, C hermitian. !! !!##SYNOPSIS !! !! subroutine cherk(uplo,trans,n,k,alpha,a,lda,beta,c,ldc) !! !! .. Scalar Arguments .. !! real,intent(in) :: alpha,beta !! integer,intent(in) :: k,lda,ldc,n !! character,intent(in) :: trans,uplo !! .. !! .. Array Arguments .. !! complex,intent(in) :: a(lda,*) !! complex,intent(inout) :: c(ldc,*) !! .. !! !!##DEFINITION !! !! CHERK performs one of the hermitian rank k operations !! !! C := alpha*A*A**H + beta*C, !! !! or !! !! C := alpha*A**H*A + beta*C, !! !! where alpha and beta are real scalars, C is an n by n hermitian !! matrix and A is an n by k matrix in the first case and a k by n !! matrix in the second case. !! !!##OPTIONS !! !! UPLO !! !! UPLO is 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. !! !! TRANS !! !! TRANS is CHARACTER*1 !! On entry, TRANS specifies the operation to be performed as !! follows: !! !! TRANS = 'N' or 'n' C := alpha*A*A**H + beta*C. !! !! TRANS = 'C' or 'c' C := alpha*A**H*A + beta*C. !! !! N !! !! N is INTEGER !! On entry, N specifies the order of the matrix C. N must be !! at least zero. !! !! K !! !! K is INTEGER !! On entry with TRANS = 'N' or 'n', K specifies the number !! of columns of the matrix A, and on entry with !! TRANS = 'C' or 'c', K specifies the number of rows of the !! matrix A. K must be at least zero. !! !! ALPHA !! !! ALPHA is REAL !! On entry, ALPHA specifies the scalar alpha. !! !! A !! !! A is COMPLEX array, 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. !! !! LDA !! !! LDA is 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 ). !! !! BETA !! !! BETA is REAL !! On entry, BETA specifies the scalar beta. !! !! C !! !! C is COMPLEX array, 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 hermitian 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 hermitian 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. !! Note that the imaginary parts of the diagonal elements need !! not be set, they are assumed to be zero, and on exit they !! are set to zero. !! !! LDC !! !! LDC is 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 ). !! !!##AUTHORS !! !! + Univ. of Tennessee !! + Univ. of California Berkeley !! + Univ. of Colorado Denver !! + NAG Ltd. !! !! date:December 2016 !! !! FURTHER DETAILS !! !! 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. !! !! -- Modified 8-Nov-93 to set C(J,J) to REAL( C(J,J) ) when BETA = 1. !! Ed Anderson, Cray Research Inc. !! !!##SEE ALSO !! Online html documentation available at !! http://www.netlib.org/lapack/explore-html/ ! ===================================================================== subroutine cherk(uplo,trans,n,k,alpha,a,lda,beta,c,ldc) implicit none ! ! -- Reference BLAS level3 routine (version 3.7.0) -- ! -- Reference BLAS is a software package provided by Univ. of Tennessee, -- ! -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- ! December 2016 ! ! .. Scalar Arguments .. real,intent(in) :: alpha,beta integer,intent(in) :: k,lda,ldc,n character,intent(in) :: trans,uplo ! .. ! .. Array Arguments .. complex,intent(in) :: a(lda,*) complex,intent(inout) :: c(ldc,*) ! .. ! ! ===================================================================== ! ! .. External Functions .. ! .. ! .. External Subroutines .. ! .. ! .. Intrinsic Functions .. intrinsic cmplx,conjg,max,real ! .. ! .. Local Scalars .. complex temp real rtemp integer i,info,j,l,nrowa logical upper ! .. ! .. Parameters .. real one,zero parameter (one=1.0e+0,zero=0.0e+0) ! .. ! ! Test the input parameters. ! if (lsame(trans,'N')) then nrowa = n else nrowa = k endif upper = lsame(uplo,'U') ! info = 0 if ((.not.upper) .and. (.not.lsame(uplo,'L'))) then info = 1 elseif ((.not.lsame(trans,'N')) .and. (.not.lsame(trans,'C'))) then info = 2 elseif (n.lt.0) then info = 3 elseif (k.lt.0) then info = 4 elseif (lda.lt.max(1,nrowa)) then info = 7 elseif (ldc.lt.max(1,n)) then info = 10 endif if (info.ne.0) then call xerbla('CHERK ',info) return endif ! ! Quick return if possible. ! if ((n.eq.0) .or. (((alpha.eq.zero).or. (k.eq.0)).and. (beta.eq.one))) return ! ! And when alpha.eq.zero. ! if (alpha.eq.zero) then if (upper) then if (beta.eq.zero) then do j = 1,n do i = 1,j c(i,j) = zero enddo enddo else do j = 1,n do i = 1,j - 1 c(i,j) = beta*c(i,j) enddo c(j,j) = beta*real(c(j,j)) enddo endif else if (beta.eq.zero) then do j = 1,n do i = j,n c(i,j) = zero enddo enddo else do j = 1,n c(j,j) = beta*real(c(j,j)) do i = j + 1,n c(i,j) = beta*c(i,j) enddo enddo endif endif return endif ! ! Start the operations. ! if (lsame(trans,'N')) then ! ! Form C := alpha*A*A**H + beta*C. ! if (upper) then do j = 1,n if (beta.eq.zero) then c(1:j,j) = zero elseif (beta.ne.one) then do i = 1,j - 1 c(i,j) = beta*c(i,j) enddo c(j,j) = beta*real(c(j,j)) else c(j,j) = real(c(j,j)) endif do l = 1,k if (a(j,l).ne.cmplx(zero)) then temp = alpha*conjg(a(j,l)) do i = 1,j - 1 c(i,j) = c(i,j) + temp*a(i,l) enddo c(j,j) = real(c(j,j)) + real(temp*a(i,l)) endif enddo enddo else do j = 1,n if (beta.eq.zero) then do i = j,n c(i,j) = zero enddo elseif (beta.ne.one) then c(j,j) = beta*real(c(j,j)) do i = j + 1,n c(i,j) = beta*c(i,j) enddo else c(j,j) = real(c(j,j)) endif do l = 1,k if (a(j,l).ne.cmplx(zero)) then temp = alpha*conjg(a(j,l)) c(j,j) = real(c(j,j)) + real(temp*a(j,l)) do i = j + 1,n c(i,j) = c(i,j) + temp*a(i,l) enddo endif enddo enddo endif else ! ! Form C := alpha*A**H*A + beta*C. ! if (upper) then do j = 1,n do i = 1,j - 1 temp = zero do l = 1,k temp = temp + conjg(a(l,i))*a(l,j) enddo if (beta.eq.zero) then c(i,j) = alpha*temp else c(i,j) = alpha*temp + beta*c(i,j) endif enddo rtemp = zero do l = 1,k rtemp = rtemp + conjg(a(l,j))*a(l,j) enddo if (beta.eq.zero) then c(j,j) = alpha*rtemp else c(j,j) = alpha*rtemp + beta*real(c(j,j)) endif enddo else do j = 1,n rtemp = zero do l = 1,k rtemp = rtemp + conjg(a(l,j))*a(l,j) enddo if (beta.eq.zero) then c(j,j) = alpha*rtemp else c(j,j) = alpha*rtemp + beta*real(c(j,j)) endif do i = j + 1,n temp = zero do l = 1,k temp = temp + conjg(a(l,i))*a(l,j) enddo if (beta.eq.zero) then c(i,j) = alpha*temp else c(i,j) = alpha*temp + beta*c(i,j) endif enddo enddo endif endif ! end subroutine cherk !> !!##NAME !! chpmv(3f) - [BLAS:COMPLEX_BLAS_LEVEL2] !! CY := alpha*A*CX + beta*CY, A a (square) hermitian packed matrix. !! !!##SYNOPSIS !! !! subroutine chpmv(uplo,n,alpha,ap,x,incx,beta,y,incy) !! !! .. Scalar Arguments .. !! complex,intent(in) :: alpha,beta !! integer,intent(in) :: incx,incy,n !! character,intent(in) :: uplo !! .. !! .. Array Arguments .. !! complex,intent(in) :: ap(*),x(*) !! complex,intent(inout) :: y(*) !! .. !! !!##DEFINITION !! !! CHPMV(3f) 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 hermitian matrix, supplied in packed form. !! !!##OPTIONS !! !! UPLO !! !! UPLO is 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. !! !! N !! !! N is INTEGER !! On entry, N specifies the order of the matrix A. !! N must be at least zero. !! !! ALPHA !! !! ALPHA is COMPLEX !! On entry, ALPHA specifies the scalar alpha. !! !! AP !! !! AP is COMPLEX array, 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 hermitian 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 hermitian 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 the imaginary parts of the diagonal elements need !! not be set and are assumed to be zero. !! !! X !! !! X is COMPLEX array, dimension at least !! ( 1 + ( n - 1 )*abs( INCX ) ). !! Before entry, the incremented array X must contain the n !! element vector x. !! !! INCX !! !! INCX is INTEGER !! On entry, INCX specifies the increment for the elements of !! X. INCX must not be zero. !! !! BETA !! !! BETA is COMPLEX !! On entry, BETA specifies the scalar beta. When BETA is !! supplied as zero then Y need not be set on input. !! !! Y !! !! Y is COMPLEX array, 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 !! !! INCY is INTEGER !! On entry, INCY specifies the increment for the elements of !! Y. INCY must not be zero. !! !!##AUTHORS !! !! + Univ. of Tennessee !! + Univ. of California Berkeley !! + Univ. of Colorado Denver !! + NAG Ltd. !! !! date:December 2016 !! !! FURTHER DETAILS !! !! Level 2 Blas routine. !! The vector and matrix arguments are not referenced when N = 0, or M = 0 !! !! -- 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. !! !!##SEE ALSO !! Online html documentation available at !! http://www.netlib.org/lapack/explore-html/ ! ===================================================================== subroutine chpmv(uplo,n,alpha,ap,x,incx,beta,y,incy) implicit none ! ! -- Reference BLAS level2 routine (version 3.7.0) -- ! -- Reference BLAS is a software package provided by Univ. of Tennessee, -- ! -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- ! December 2016 ! ! .. Scalar Arguments .. complex,intent(in) :: alpha,beta integer,intent(in) :: incx,incy,n character,intent(in) :: uplo ! .. ! .. Array Arguments .. complex,intent(in) :: ap(*),x(*) complex,intent(inout) :: y(*) ! .. ! ! ===================================================================== ! ! .. Parameters .. complex one parameter (one= (1.0e+0,0.0e+0)) complex zero parameter (zero= (0.0e+0,0.0e+0)) ! .. ! .. Local Scalars .. complex temp1,temp2 integer i,info,ix,iy,j,jx,jy,k,kk,kx,ky ! .. ! .. External Functions .. ! .. ! .. External Subroutines .. ! .. ! .. Intrinsic Functions .. intrinsic conjg,real ! .. ! ! Test the input parameters. ! info = 0 if (.not.lsame(uplo,'U') .and. .not.lsame(uplo,'L')) then info = 1 elseif (n.lt.0) then info = 2 elseif (incx.eq.0) then info = 6 elseif (incy.eq.0) then info = 9 endif if (info.ne.0) then call xerbla('CHPMV ',info) return endif ! ! Quick return if possible. ! if ((n.eq.0) .or. ((alpha.eq.zero).and. (beta.eq.one))) return ! ! Set up the start points in X and Y. ! if (incx.gt.0) then kx = 1 else kx = 1 - (n-1)*incx endif if (incy.gt.0) then ky = 1 else ky = 1 - (n-1)*incy endif ! ! 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.ne.one) then if (incy.eq.1) then if (beta.eq.zero) then y(1:n) = zero else y(1:n) = beta*y(1:n) endif else iy = ky if (beta.eq.zero) then do i = 1,n y(iy) = zero iy = iy + incy enddo else do i = 1,n y(iy) = beta*y(iy) iy = iy + incy enddo endif endif endif if (alpha.eq.zero) return kk = 1 if (lsame(uplo,'U')) then ! ! Form y when AP contains the upper triangle. ! if ((incx.eq.1) .and. (incy.eq.1)) then do j = 1,n temp1 = alpha*x(j) temp2 = zero k = kk do i = 1,j - 1 y(i) = y(i) + temp1*ap(k) temp2 = temp2 + conjg(ap(k))*x(i) k = k + 1 enddo y(j) = y(j) + temp1*real(ap(kk+j-1)) + alpha*temp2 kk = kk + j enddo else jx = kx jy = ky do j = 1,n temp1 = alpha*x(jx) temp2 = zero ix = kx iy = ky do k = kk,kk + j - 2 y(iy) = y(iy) + temp1*ap(k) temp2 = temp2 + conjg(ap(k))*x(ix) ix = ix + incx iy = iy + incy enddo y(jy) = y(jy) + temp1*real(ap(kk+j-1)) + alpha*temp2 jx = jx + incx jy = jy + incy kk = kk + j enddo endif else ! ! Form y when AP contains the lower triangle. ! if ((incx.eq.1) .and. (incy.eq.1)) then do j = 1,n temp1 = alpha*x(j) temp2 = zero y(j) = y(j) + temp1*real(ap(kk)) k = kk + 1 do i = j + 1,n y(i) = y(i) + temp1*ap(k) temp2 = temp2 + conjg(ap(k))*x(i) k = k + 1 enddo y(j) = y(j) + alpha*temp2 kk = kk + (n-j+1) enddo else jx = kx jy = ky do j = 1,n temp1 = alpha*x(jx) temp2 = zero y(jy) = y(jy) + temp1*real(ap(kk)) ix = jx iy = jy do k = kk + 1,kk + n - j ix = ix + incx iy = iy + incy y(iy) = y(iy) + temp1*ap(k) temp2 = temp2 + conjg(ap(k))*x(ix) enddo y(jy) = y(jy) + alpha*temp2 jx = jx + incx jy = jy + incy kk = kk + (n-j+1) enddo endif endif ! end subroutine chpmv !> !!##NAME !! chpr2(3f) - [BLAS:COMPLEX_BLAS_LEVEL2] performs the hermitian rank 2 operation !! A := A + alpha*CX*CONJUGATE-TRANSPOSE(CY)n + CONJUGATE(ALPHA)*CY*CONJUGATE-TRANSPOSE(CX),n A a (square) hermitian packed matrix. !! !!##SYNOPSIS !! !! subroutine chpr2(uplo,n,alpha,x,incx,y,incy,ap) !! !! .. Scalar Arguments .. !! complex,intent(in) :: alpha !! integer,intent(in) :: incx,incy,n !! character,intent(in) :: uplo !! .. !! .. Array Arguments .. !! complex,intent(inout) :: ap(*) !! complex,intent(in) :: x(*),y(*) !! .. !! !!##DEFINITION !! !! CHPR2 performs the hermitian rank 2 operation !! !! A := alpha*x*y**H + conjg( alpha )*y*x**H + A, !! !! where alpha is a scalar, x and y are n element vectors and A is an !! n by n hermitian matrix, supplied in packed form. !! !!##OPTIONS !! !! UPLO !! !! UPLO is 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. !! !! N !! !! N is INTEGER !! On entry, N specifies the order of the matrix A. !! N must be at least zero. !! !! ALPHA !! !! ALPHA is COMPLEX !! On entry, ALPHA specifies the scalar alpha. !! !! X !! !! X is COMPLEX array, dimension at least !! ( 1 + ( n - 1 )*abs( INCX ) ). !! Before entry, the incremented array X must contain the n !! element vector x. !! !! INCX !! !! INCX is INTEGER !! On entry, INCX specifies the increment for the elements of !! X. INCX must not be zero. !! !! Y !! !! Y is COMPLEX array, dimension at least !! ( 1 + ( n - 1 )*abs( INCY ) ). !! Before entry, the incremented array Y must contain the n !! element vector y. !! !! INCY !! !! INCY is INTEGER !! On entry, INCY specifies the increment for the elements of !! Y. INCY must not be zero. !! !! AP !! !! AP is COMPLEX array, 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 hermitian 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 hermitian 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. !! Note that the imaginary parts of the diagonal elements need !! not be set, they are assumed to be zero, and on exit they !! are set to zero. !! !!##AUTHORS !! !! + Univ. of Tennessee !! + Univ. of California Berkeley !! + Univ. of Colorado Denver !! + NAG Ltd. !! !! date:December 2016 !! !! FURTHER DETAILS !! !! 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. !! !!##SEE ALSO !! Online html documentation available at !! http://www.netlib.org/lapack/explore-html/ ! ===================================================================== subroutine chpr2(uplo,n,alpha,x,incx,y,incy,ap) implicit none ! ! -- Reference BLAS level2 routine (version 3.7.0) -- ! -- Reference BLAS is a software package provided by Univ. of Tennessee, -- ! -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- ! December 2016 ! ! .. Scalar Arguments .. complex,intent(in) :: alpha integer,intent(in) :: incx,incy,n character,intent(in) :: uplo ! .. ! .. Array Arguments .. complex,intent(inout) :: ap(*) complex,intent(in) :: x(*),y(*) ! .. ! ! ===================================================================== ! ! .. Parameters .. complex zero parameter (zero= (0.0e+0,0.0e+0)) ! .. ! .. Local Scalars .. complex temp1,temp2 integer i,info,ix,iy,j,jx,jy,k,kk,kx,ky ! .. ! .. External Functions .. ! .. ! .. External Subroutines .. ! .. ! .. Intrinsic Functions .. intrinsic conjg,real ! .. ! ! Test the input parameters. ! info = 0 if (.not.lsame(uplo,'U') .and. .not.lsame(uplo,'L')) then info = 1 elseif (n.lt.0) then info = 2 elseif (incx.eq.0) then info = 5 elseif (incy.eq.0) then info = 7 endif if (info.ne.0) then call xerbla('CHPR2 ',info) return endif ! ! Quick return if possible. ! if ((n.eq.0) .or. (alpha.eq.zero)) return ! ! Set up the start points in X and Y if the increments are not both ! unity. ! if ((incx.ne.1) .or. (incy.ne.1)) then if (incx.gt.0) then kx = 1 else kx = 1 - (n-1)*incx endif if (incy.gt.0) then ky = 1 else ky = 1 - (n-1)*incy endif jx = kx jy = ky endif ! ! 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')) then ! ! Form A when upper triangle is stored in AP. ! if ((incx.eq.1) .and. (incy.eq.1)) then do j = 1,n if ((x(j).ne.zero) .or. (y(j).ne.zero)) then temp1 = alpha*conjg(y(j)) temp2 = conjg(alpha*x(j)) k = kk do i = 1,j - 1 ap(k) = ap(k) + x(i)*temp1 + y(i)*temp2 k = k + 1 enddo ap(kk+j-1) = real(ap(kk+j-1)) + real(x(j)*temp1+y(j)*temp2) else ap(kk+j-1) = real(ap(kk+j-1)) endif kk = kk + j enddo else do j = 1,n if ((x(jx).ne.zero) .or. (y(jy).ne.zero)) then temp1 = alpha*conjg(y(jy)) temp2 = conjg(alpha*x(jx)) ix = kx iy = ky do k = kk,kk + j - 2 ap(k) = ap(k) + x(ix)*temp1 + y(iy)*temp2 ix = ix + incx iy = iy + incy enddo ap(kk+j-1) = real(ap(kk+j-1)) + real(x(jx)*temp1+y(jy)*temp2) else ap(kk+j-1) = real(ap(kk+j-1)) endif jx = jx + incx jy = jy + incy kk = kk + j enddo endif else ! ! Form A when lower triangle is stored in AP. ! if ((incx.eq.1) .and. (incy.eq.1)) then do j = 1,n if ((x(j).ne.zero) .or. (y(j).ne.zero)) then temp1 = alpha*conjg(y(j)) temp2 = conjg(alpha*x(j)) ap(kk) = real(ap(kk)) + real(x(j)*temp1+y(j)*temp2) k = kk + 1 do i = j + 1,n ap(k) = ap(k) + x(i)*temp1 + y(i)*temp2 k = k + 1 enddo else ap(kk) = real(ap(kk)) endif kk = kk + n - j + 1 enddo else do j = 1,n if ((x(jx).ne.zero) .or. (y(jy).ne.zero)) then temp1 = alpha*conjg(y(jy)) temp2 = conjg(alpha*x(jx)) ap(kk) = real(ap(kk)) + real(x(jx)*temp1+y(jy)*temp2) ix = jx iy = jy do k = kk + 1,kk + n - j ix = ix + incx iy = iy + incy ap(k) = ap(k) + x(ix)*temp1 + y(iy)*temp2 enddo else ap(kk) = real(ap(kk)) endif jx = jx + incx jy = jy + incy kk = kk + n - j + 1 enddo endif endif ! end subroutine chpr2 !> !!##NAME !! chpr(3f) - [BLAS:COMPLEX_BLAS_LEVEL2] performs the hermitian rank 1 operation !! A := A + alpha*CX*CONJUGATE-TRANSPOSE(CX), a a (square) hermitian packed. !! !!##SYNOPSIS !! !! subroutine chpr(uplo,n,alpha,x,incx,ap) !! !! .. Scalar Arguments .. !! real,intent(in) :: alpha !! integer,intent(in) :: incx,n !! character,intent(in) :: uplo !! .. !! .. Array Arguments .. !! complex,intent(inout) :: ap(*) !! complex,intent(in) :: x(*) !! .. !! !!##DEFINITION !! !! CHPR performs the hermitian rank 1 operation !! !! A := alpha*x*x**H + A, !! !! where alpha is a real scalar, x is an n element vector and A is an !! n by n hermitian matrix, supplied in packed form. !! !!##OPTIONS !! !! UPLO !! !! UPLO is 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. !! !! N !! !! N is INTEGER !! On entry, N specifies the order of the matrix A. !! N must be at least zero. !! !! ALPHA !! !! ALPHA is REAL !! On entry, ALPHA specifies the scalar alpha. !! !! X !! !! X is COMPLEX array, dimension at least !! ( 1 + ( n - 1 )*abs( INCX ) ). !! Before entry, the incremented array X must contain the n !! element vector x. !! !! INCX !! !! INCX is INTEGER !! On entry, INCX specifies the increment for the elements of !! X. INCX must not be zero. !! !! AP !! !! AP is COMPLEX array, 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 hermitian 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 hermitian 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. !! Note that the imaginary parts of the diagonal elements need !! not be set, they are assumed to be zero, and on exit they !! are set to zero. !! !!##AUTHORS !! !! + Univ. of Tennessee !! + Univ. of California Berkeley !! + Univ. of Colorado Denver !! + NAG Ltd. !! !! date:December 2016 !! !! FURTHER DETAILS !! !! 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. !! !!##SEE ALSO !! Online html documentation available at !! http://www.netlib.org/lapack/explore-html/ ! ===================================================================== subroutine chpr(uplo,n,alpha,x,incx,ap) implicit none ! ! -- Reference BLAS level2 routine (version 3.7.0) -- ! -- Reference BLAS is a software package provided by Univ. of Tennessee, -- ! -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- ! December 2016 ! ! .. Scalar Arguments .. real,intent(in) :: alpha integer,intent(in) :: incx,n character,intent(in) :: uplo ! .. ! .. Array Arguments .. complex,intent(inout) :: ap(*) complex,intent(in) :: x(*) ! .. ! ! ===================================================================== ! ! .. Parameters .. complex zero parameter (zero= (0.0e+0,0.0e+0)) ! .. ! .. Local Scalars .. complex temp integer i,info,ix,j,jx,k,kk,kx ! .. ! .. External Functions .. ! .. ! .. External Subroutines .. ! .. ! .. Intrinsic Functions .. intrinsic conjg,real ! .. ! ! Test the input parameters. ! info = 0 if (.not.lsame(uplo,'U') .and. .not.lsame(uplo,'L')) then info = 1 elseif (n.lt.0) then info = 2 elseif (incx.eq.0) then info = 5 endif if (info.ne.0) then call xerbla('CHPR ',info) return endif ! ! Quick return if possible. ! if ((n.eq.0) .or. (alpha.eq.real(zero))) return ! ! Set the start point in X if the increment is not unity. ! if (incx.le.0) then kx = 1 - (n-1)*incx elseif (incx.ne.1) then kx = 1 endif ! ! 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')) then ! ! Form A when upper triangle is stored in AP. ! if (incx.eq.1) then do j = 1,n if (x(j).ne.zero) then temp = alpha*conjg(x(j)) k = kk do i = 1,j - 1 ap(k) = ap(k) + x(i)*temp k = k + 1 enddo ap(kk+j-1) = real(ap(kk+j-1)) + real(x(j)*temp) else ap(kk+j-1) = real(ap(kk+j-1)) endif kk = kk + j enddo else jx = kx do j = 1,n if (x(jx).ne.zero) then temp = alpha*conjg(x(jx)) ix = kx do k = kk,kk + j - 2 ap(k) = ap(k) + x(ix)*temp ix = ix + incx enddo ap(kk+j-1) = real(ap(kk+j-1)) + real(x(jx)*temp) else ap(kk+j-1) = real(ap(kk+j-1)) endif jx = jx + incx kk = kk + j enddo endif else ! ! Form A when lower triangle is stored in AP. ! if (incx.eq.1) then do j = 1,n if (x(j).ne.zero) then temp = alpha*conjg(x(j)) ap(kk) = real(ap(kk)) + real(temp*x(j)) k = kk + 1 do i = j + 1,n ap(k) = ap(k) + x(i)*temp k = k + 1 enddo else ap(kk) = real(ap(kk)) endif kk = kk + n - j + 1 enddo else jx = kx do j = 1,n if (x(jx).ne.zero) then temp = alpha*conjg(x(jx)) ap(kk) = real(ap(kk)) + real(temp*x(jx)) ix = jx do k = kk + 1,kk + n - j ix = ix + incx ap(k) = ap(k) + x(ix)*temp enddo else ap(kk) = real(ap(kk)) endif jx = jx + incx kk = kk + n - j + 1 enddo endif endif ! end subroutine chpr !> !!##NAME !! crotg(3f) - [BLAS:SINGLE_BLAS_LEVEL1] Generate a hermitian Given's rotation. !! !!##SYNOPSIS !! !! subroutine CROTG( a, b, c, s ) !! !! .. Scalar Arguments .. !! complex(wp),intent(inout) :: a !! complex(wp),intent(in) :: b !! real(wp),intent(out) :: c !! complex(wp),intent(out) :: s !! !!##DESCRIPTION !! CROTG constructs a plane rotation !! !! [ c s ] [ a ] = [ r ] !! [ -conjg(s) c ] [ b ] [ 0 ] !! !! where c is real, s ic complex, and c**2 + conjg(s)*s = 1. !! !! The computation uses the formulas !! !! |x| = sqrt( Re(x)**2 + Im(x)**2 ) !! sgn(x) = x / |x| if x /= 0 !! = 1 if x = 0 !! c = |a| / sqrt(|a|**2 + |b|**2) !! s = sgn(a) * conjg(b) / sqrt(|a|**2 + |b|**2) !! !! When a and b are real and r /= 0, the formulas simplify to !! !! r = sgn(a)*sqrt(|a|**2 + |b|**2) !! c = a / r !! s = b / r !! !! the same as in CROTG when |a| > |b|. When |b| >= |a|, the !! sign of c and s will be different from those computed by CROTG !! if the signs of a and b are not the same. !! !!##OPTIONS !! A On entry, the scalar a. On exit, the scalar r. !! B The scalar b. !! C The scalar c. !! S The scalar s. !! !!##AUTHORS !! + Edward Anderson, Lockheed Martin !! !!##CONTRIBUTORS !! + Weslley Pereira, University of Colorado Denver, USA !! !!##FURTHER DETAILS !! Anderson E. (2017) !! Algorithm 978: Safe Scaling in the Level 1 BLAS !! ACM Trans Math Softw 44:1--28 !! https://doi.org/10.1145/3061665 !! !!##SEE ALSO !! Online html documentation available at !! http://www.netlib.org/lapack/explore-html/ ! ===================================================================== subroutine crotg( a, b, c, s ) integer, parameter :: wp = kind(1.e0) ! ! -- Reference BLAS level1 routine -- ! -- Reference BLAS is a software package provided by Univ. of Tennessee, -- ! -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- ! ! .. Constants .. real(wp), parameter :: zero = 0.0_wp real(wp), parameter :: one = 1.0_wp complex(wp), parameter :: czero = 0.0_wp ! .. ! .. Scaling constants .. real(wp), parameter :: safmin = real(radix(0._wp),wp)**max( minexponent(0._wp)-1, 1-maxexponent(0._wp) ) real(wp), parameter :: safmax = real(radix(0._wp),wp)**max( 1-minexponent(0._wp), maxexponent(0._wp)-1 ) real(wp), parameter :: rtmin = sqrt( real(radix(0._wp),wp)**max( minexponent(0._wp)-1, 1-maxexponent(0._wp) ) / epsilon(0._wp) ) real(wp), parameter :: rtmax = sqrt( real(radix(0._wp),wp)**max( 1-minexponent(0._wp), maxexponent(0._wp)-1 ) * epsilon(0._wp) ) ! .. ! .. Scalar Arguments .. complex(wp),intent(inout) :: a complex(wp),intent(in) :: b real(wp),intent(out) :: c complex(wp),intent(out) :: s ! .. ! .. Local Scalars .. real(wp) :: d, f1, f2, g1, g2, h2, p, u, uu, v, vv, w complex(wp) :: f, fs, g, gs, r, t ! .. ! .. Intrinsic Functions .. intrinsic :: abs, aimag, conjg, max, min, real, sqrt ! .. ! .. Statement Functions .. real(wp) :: abssq ! .. ! .. Statement Function definitions .. abssq( t ) = real( t )**2 + aimag( t )**2 ! .. ! .. Executable Statements .. ! f = a g = b if( g == czero ) then c = one s = czero r = f elseif ( f == czero ) then c = zero g1 = max( abs(real(g)), abs(aimag(g)) ) if( g1 > rtmin .and. g1 < rtmax ) then ! ! Use unscaled algorithm ! g2 = abssq( g ) d = sqrt( g2 ) s = conjg( g ) / d r = d else ! ! Use scaled algorithm ! u = min( safmax, max( safmin, g1 ) ) uu = one / u gs = g*uu g2 = abssq( gs ) d = sqrt( g2 ) s = conjg( gs ) / d r = d*u endif else f1 = max( abs(real(f)), abs(aimag(f)) ) g1 = max( abs(real(g)), abs(aimag(g)) ) if( f1 > rtmin .and. f1 < rtmax .and. & g1 > rtmin .and. g1 < rtmax ) then ! ! Use unscaled algorithm ! f2 = abssq( f ) g2 = abssq( g ) h2 = f2 + g2 if( f2 > rtmin .and. h2 < rtmax ) then d = sqrt( f2*h2 ) else d = sqrt( f2 )*sqrt( h2 ) endif p = 1 / d c = f2*p s = conjg( g )*( f*p ) r = f*( h2*p ) else ! ! Use scaled algorithm ! u = min( safmax, max( safmin, f1, g1 ) ) uu = one / u gs = g*uu g2 = abssq( gs ) if( f1*uu < rtmin ) then ! ! f is not well-scaled when scaled by g1. ! Use a different scaling for f. ! v = min( safmax, max( safmin, f1 ) ) vv = one / v w = v * uu fs = f*vv f2 = abssq( fs ) h2 = f2*w**2 + g2 else ! ! Otherwise use the same scaling for f and g. ! w = one fs = f*uu f2 = abssq( fs ) h2 = f2 + g2 endif if( f2 > rtmin .and. h2 < rtmax ) then d = sqrt( f2*h2 ) else d = sqrt( f2 )*sqrt( h2 ) endif p = 1 / d c = ( f2*p )*w s = conjg( gs )*( fs*p ) r = ( fs*( h2*p ) )*u endif endif a = r end subroutine crotg !> !!##NAME !! cscal(3f) - [BLAS:COMPLEX_BLAS_LEVEL1] scales a vector by a constant. !! CX:=CA*CX (complex multiplier) !! !!##SYNOPSIS !! !! !! subroutine cscal(n,ca,cx,incx) !! !! .. Scalar Arguments .. !! complex,intent(in) :: ca !! integer,intent(in) :: incx,n !! .. !! .. Array Arguments .. !! complex,intent(inout) :: cx(*) !! .. !! !!##DEFINITION !! !! CSCAL scales a vector by a constant. !! !!##OPTIONS !! N !! number of elements in input vector(s) !! CA !! On entry, CA specifies the scalar alpha. !! CX !! CX is COMPLEX array, dimension ( 1 + ( N - 1 )*abs( INCX ) ) !! INCX !! storage spacing between elements of CX !! !!##AUTHORS !! !! + Univ. of Tennessee !! + Univ. of California Berkeley !! + Univ. of Colorado Denver !! + NAG Ltd. !! !! date:November 2017 !! !! FURTHER DETAILS !! !! 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(*) !! !!##SEE ALSO !! Online html documentation available at !! http://www.netlib.org/lapack/explore-html/ ! ===================================================================== subroutine cscal(n,ca,cx,incx) implicit none ! ! -- Reference BLAS level1 routine (version 3.8.0) -- ! -- Reference BLAS is a software package provided by Univ. of Tennessee, -- ! -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- ! November 2017 ! ! .. Scalar Arguments .. complex,intent(in) :: ca integer,intent(in) :: incx,n ! .. ! .. Array Arguments .. complex,intent(inout) :: cx(*) ! .. ! ! ===================================================================== ! ! .. Local Scalars .. integer i,nincx ! .. if (n.le.0 .or. incx.le.0) return if (incx.eq.1) then ! ! code for increment equal to 1 ! do i = 1,n cx(i) = ca*cx(i) enddo else ! ! code for increment not equal to 1 ! nincx = n*incx do i = 1,nincx,incx cx(i) = ca*cx(i) enddo endif end subroutine cscal !> !!##NAME !! csrot(3f) - [BLAS:COMPLEX_BLAS_LEVEL1] Applies a real Given's rotation to complex vectors. !! !!##SYNOPSIS !! !! !! subroutine csrot( n, cx, incx, cy, incy, c, s ) !! !! .. Scalar Arguments .. !! integer,intent(in) :: incx, incy, n !! real,intent(in) :: c, s !! .. !! .. Array Arguments .. !! complex,intent(inout) :: cx( * ), cy( * ) !! .. !! !!##DEFINITION !! !! CSROT applies a plane rotation, where the cos and sin (c and s) are real !! and the vectors cx and cy are complex. !! jack dongarra, linpack, 3/11/78. !! !!##OPTIONS !! !! N !! !! N is INTEGER !! On entry, N specifies the order of the vectors cx and cy. !! N must be at least zero. !! !! CX !! !! CX is COMPLEX array, dimension at least !! ( 1 + ( N - 1 )*abs( INCX ) ). !! Before entry, the incremented array CX must contain the n !! element vector cx. On exit, CX is overwritten by the updated !! vector cx. !! !! INCX !! !! INCX is INTEGER !! On entry, INCX specifies the increment for the elements of !! CX. INCX must not be zero. !! !! CY !! !! CY is COMPLEX array, dimension at least !! ( 1 + ( N - 1 )*abs( INCY ) ). !! Before entry, the incremented array CY must contain the n !! element vector cy. On exit, CY is overwritten by the updated !! vector cy. !! !! INCY !! !! INCY is INTEGER !! On entry, INCY specifies the increment for the elements of !! CY. INCY must not be zero. !! !! C !! !! C is REAL !! On entry, C specifies the cosine, cos. !! !! S !! !! S is REAL !! On entry, S specifies the sine, sin. !! !!##AUTHORS !! !! + Univ. of Tennessee !! + Univ. of California Berkeley !! + Univ. of Colorado Denver !! + NAG Ltd. !! !! date:December 2016 !! !!##SEE ALSO !! Online html documentation available at !! http://www.netlib.org/lapack/explore-html/ ! ===================================================================== subroutine csrot( n, cx, incx, cy, incy, c, s ) implicit none ! ! -- Reference BLAS level1 routine (version 3.7.0) -- ! -- Reference BLAS is a software package provided by Univ. of Tennessee, -- ! -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- ! December 2016 ! ! .. Scalar Arguments .. integer,intent(in) :: incx, incy, n real,intent(in) :: c, s ! .. ! .. Array Arguments .. complex,intent(inout) :: cx( * ), cy( * ) ! .. ! ! ===================================================================== ! ! .. Local Scalars .. integer i, ix, iy complex ctemp ! .. ! .. Executable Statements .. ! if( n.le.0 ) return if( incx.eq.1 .and. incy.eq.1 ) then ! ! code for both increments equal to 1 ! do i = 1, n ctemp = c*cx( i ) + s*cy( i ) cy( i ) = c*cy( i ) - s*cx( i ) cx( i ) = ctemp enddo else ! ! code for unequal increments or equal increments not equal ! to 1 ! ix = 1 iy = 1 if( incx.lt.0 ) ix = ( -n+1 )*incx + 1 if( incy.lt.0 ) iy = ( -n+1 )*incy + 1 do i = 1, n ctemp = c*cx( ix ) + s*cy( iy ) cy( iy ) = c*cy( iy ) - s*cx( ix ) cx( ix ) = ctemp ix = ix + incx iy = iy + incy enddo endif end subroutine csrot !> !!##NAME !! csscal(3f) - [BLAS:COMPLEX_BLAS_LEVEL1] CSSCAL scales a complex vector by a real constant. !! CX:=SA*CX (real multiplier). !! !!##SYNOPSIS !! !! subroutine csscal(n,sa,cx,incx) !! !! .. scalar arguments .. !! real,intent(in) :: sa !! integer,intent(in) :: incx,n !! .. !! .. Array Arguments .. !! complex,intent(inout) :: cx(*) !! .. !! !!##DEFINITION !! !! CSSCAL scales a complex vector by a real constant. !! !!##OPTIONS !! !! N !! !! N is INTEGER !! number of elements in input vector(s) !! !! SA !! !! SA is REAL !! On entry, SA specifies the scalar alpha. !! !! CX !! !! CX is COMPLEX array, dimension ( 1 + ( N - 1 )*abs( INCX ) ) !! !! INCX !! !! INCX is INTEGER !! storage spacing between elements of CX !! !!##AUTHORS !! !! + Univ. of Tennessee !! + Univ. of California Berkeley !! + Univ. of Colorado Denver !! + NAG Ltd. !! !! date:November 2017 !! !! FURTHER DETAILS !! !! 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(*) !! !!##SEE ALSO !! Online html documentation available at !! http://www.netlib.org/lapack/explore-html/ ! ===================================================================== subroutine csscal(n,sa,cx,incx) implicit none ! ! -- Reference BLAS level1 routine (version 3.8.0) -- ! -- Reference BLAS is a software package provided by Univ. of Tennessee, -- ! -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- ! November 2017 ! ! .. Scalar Arguments .. real,intent(in) :: sa integer,intent(in) :: incx,n ! .. ! .. Array Arguments .. complex,intent(inout) :: cx(*) ! .. ! ! ===================================================================== ! ! .. Local Scalars .. integer i,nincx ! .. ! .. Intrinsic Functions .. intrinsic aimag,cmplx,real ! .. if (n.le.0 .or. incx.le.0) return if (incx.eq.1) then ! ! code for increment equal to 1 ! do i = 1,n cx(i) = cmplx(sa*real(cx(i)),sa*aimag(cx(i))) enddo else ! ! code for increment not equal to 1 ! nincx = n*incx do i = 1,nincx,incx cx(i) = cmplx(sa*real(cx(i)),sa*aimag(cx(i))) enddo endif end subroutine csscal !> !!##NAME !! cswap(3f) - [BLAS:COMPLEX_BLAS_LEVEL1] Interchange vectors CX and CY. !! !!##SYNOPSIS !! !! subroutine cswap(n,cx,incx,cy,incy) !! !! .. Scalar Arguments .. !! integer,intent(in) :: incx,incy,n !! .. !! .. Array Arguments .. !! complex,intent(inout) :: cx(*),cy(*) !! .. !! !!##DEFINITION !! !! CSWAP interchanges two vectors. !! !!##OPTIONS !! !! N !! !! N is INTEGER !! number of elements in input vector(s) !! !! CX !! !! CX is COMPLEX array, dimension ( 1 + ( N - 1 )*abs( INCX ) ) !! !! INCX !! !! INCX is INTEGER !! storage spacing between elements of CX !! !! CY !! !! CY is COMPLEX array, dimension ( 1 + ( N - 1 )*abs( INCY ) ) !! !! INCY !! !! INCY is INTEGER !! storage spacing between elements of CY !! !!##AUTHORS !! !! + Univ. of Tennessee !! + Univ. of California Berkeley !! + Univ. of Colorado Denver !! + NAG Ltd. !! !! date:November 2017 !! !! FURTHER DETAILS !! !! jack dongarra, linpack, 3/11/78. !! modified 12/3/93, array(1) declarations changed to array(*) !! !!##SEE ALSO !! Online html documentation available at !! http://www.netlib.org/lapack/explore-html/ ! ===================================================================== subroutine cswap(n,cx,incx,cy,incy) implicit none ! ! -- Reference BLAS level1 routine (version 3.8.0) -- ! -- Reference BLAS is a software package provided by Univ. of Tennessee, -- ! -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- ! November 2017 ! ! .. Scalar Arguments .. integer,intent(in) :: incx,incy,n ! .. ! .. Array Arguments .. complex,intent(inout) :: cx(*),cy(*) ! .. ! ! ===================================================================== ! ! .. Local Scalars .. complex ctemp integer i,ix,iy ! .. if (n.le.0) return if (incx.eq.1 .and. incy.eq.1) then ! ! code for both increments equal to 1 do i = 1,n ctemp = cx(i) cx(i) = cy(i) cy(i) = ctemp enddo else ! ! code for unequal increments or equal increments not equal ! to 1 ! ix = 1 iy = 1 if (incx.lt.0) ix = (-n+1)*incx + 1 if (incy.lt.0) iy = (-n+1)*incy + 1 do i = 1,n ctemp = cx(ix) cx(ix) = cy(iy) cy(iy) = ctemp ix = ix + incx iy = iy + incy enddo endif end subroutine cswap !> !!##NAME !! csymm(3f) - [BLAS:COMPLEX_BLAS_LEVEL3] !! C:=alpha*A*B+beta*C, A symmetric, B, C rectangular. !! !!##SYNOPSIS !! !! subroutine csymm(side,uplo,m,n,alpha,a,lda,b,ldb,beta,c,ldc) !! !! .. Scalar Arguments .. !! complex,intent(in) :: alpha,beta !! integer,intent(in) :: lda,ldb,ldc,m,n !! character,intent(in) :: side,uplo !! .. !! .. Array Arguments .. !! complex,intent(in) :: a(lda,*),b(ldb,*) !! complex,intent(inout) :: c(ldc,*) !! .. !! !!##DEFINITION !! !! CSYMM 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. !! !!##OPTIONS !! !! SIDE !! !! SIDE is 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, !! !! UPLO !! !! UPLO is 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. !! !! M !! !! M is INTEGER !! On entry, M specifies the number of rows of the matrix C. !! M must be at least zero. !! !! N !! !! N is INTEGER !! On entry, N specifies the number of columns of the matrix C. !! N must be at least zero. !! !! ALPHA !! !! ALPHA is COMPLEX !! On entry, ALPHA specifies the scalar alpha. !! !! A !! !! A is COMPLEX array, 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. !! !! LDA !! !! LDA is 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 ). !! !! B !! !! B is COMPLEX array, dimension ( LDB, N ) !! Before entry, the leading m by n part of the array B must !! contain the matrix B. !! !! LDB !! !! LDB is 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 ). !! !! BETA !! !! BETA is COMPLEX !! On entry, BETA specifies the scalar beta. When BETA is !! supplied as zero then C need not be set on input. !! !! C !! !! C is COMPLEX array, 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 !! !! LDC is 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 ). !! !!##AUTHORS !! !! + Univ. of Tennessee !! + Univ. of California Berkeley !! + Univ. of Colorado Denver !! + NAG Ltd. !! !! date:December 2016 !! !! FURTHER DETAILS !! !! 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. !! !!##SEE ALSO !! Online html documentation available at !! http://www.netlib.org/lapack/explore-html/ ! ===================================================================== subroutine csymm(side,uplo,m,n,alpha,a,lda,b,ldb,beta,c,ldc) implicit none ! ! -- Reference BLAS level3 routine (version 3.7.0) -- ! -- Reference BLAS is a software package provided by Univ. of Tennessee, -- ! -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- ! December 2016 ! ! .. Scalar Arguments .. complex,intent(in) :: alpha,beta integer,intent(in) :: lda,ldb,ldc,m,n character,intent(in) :: side,uplo ! .. ! .. Array Arguments .. complex,intent(in) :: a(lda,*),b(ldb,*) complex,intent(inout) :: c(ldc,*) ! .. ! ! ===================================================================== ! ! .. External Functions .. ! .. ! .. External Subroutines .. ! .. ! .. Intrinsic Functions .. intrinsic max ! .. ! .. Local Scalars .. complex temp1,temp2 integer i,info,j,k,nrowa logical upper ! .. ! .. Parameters .. complex one parameter (one= (1.0e+0,0.0e+0)) complex zero parameter (zero= (0.0e+0,0.0e+0)) ! .. ! ! Set NROWA as the number of rows of A. ! if (lsame(side,'L')) then nrowa = m else nrowa = n endif upper = lsame(uplo,'U') ! ! Test the input parameters. ! info = 0 if ((.not.lsame(side,'L')) .and. (.not.lsame(side,'R'))) then info = 1 elseif ((.not.upper) .and. (.not.lsame(uplo,'L'))) then info = 2 elseif (m.lt.0) then info = 3 elseif (n.lt.0) then info = 4 elseif (lda.lt.max(1,nrowa)) then info = 7 elseif (ldb.lt.max(1,m)) then info = 9 elseif (ldc.lt.max(1,m)) then info = 12 endif if (info.ne.0) then call xerbla('CSYMM ',info) return endif ! ! Quick return if possible. ! if ((m.eq.0) .or. (n.eq.0) .or. ((alpha.eq.zero).and. (beta.eq.one))) return ! ! And when alpha.eq.zero. ! if (alpha.eq.zero) then if (beta.eq.zero) then c(1:m,1:n) = zero else c(1:m,1:n) = beta*c(1:m,1:n) endif return endif ! ! Start the operations. ! if (lsame(side,'L')) then ! ! Form C := alpha*A*B + beta*C. ! if (upper) then do j = 1,n do i = 1,m temp1 = alpha*b(i,j) temp2 = zero do k = 1,i - 1 c(k,j) = c(k,j) + temp1*a(k,i) temp2 = temp2 + b(k,j)*a(k,i) enddo if (beta.eq.zero) then c(i,j) = temp1*a(i,i) + alpha*temp2 else c(i,j) = beta*c(i,j) + temp1*a(i,i) + alpha*temp2 endif enddo enddo else do j = 1,n do i = m,1,-1 temp1 = alpha*b(i,j) temp2 = zero do k = i + 1,m c(k,j) = c(k,j) + temp1*a(k,i) temp2 = temp2 + b(k,j)*a(k,i) enddo if (beta.eq.zero) then c(i,j) = temp1*a(i,i) + alpha*temp2 else c(i,j) = beta*c(i,j) + temp1*a(i,i) + alpha*temp2 endif enddo enddo endif else ! ! Form C := alpha*B*A + beta*C. ! do j = 1,n temp1 = alpha*a(j,j) if (beta.eq.zero) then c(1:m,j) = temp1*b(1:m,j) else c(1:m,j) = beta*c(1:m,j) + temp1*b(1:m,j) endif do k = 1,j - 1 if (upper) then temp1 = alpha*a(k,j) else temp1 = alpha*a(j,k) endif c(1:m,j) = c(1:m,j) + temp1*b(1:m,k) enddo do k = j + 1,n if (upper) then temp1 = alpha*a(j,k) else temp1 = alpha*a(k,j) endif c(1:m,j) = c(1:m,j) + temp1*b(1:m,k) enddo enddo endif ! ! End of CSYMM . ! end subroutine csymm !> !!##NAME !! csyr2k(3f) - [BLAS:COMPLEX_BLAS_LEVEL3] !! C:=alpha*A*TRANSPOSE(B)+alpha*B*TRANSPOSE(A)+beta*C, C symmetric. !! !!##SYNOPSIS !! !! subroutine csyr2k(uplo,trans,n,k,alpha,a,lda,b,ldb,beta,c,ldc) !! !! .. Scalar Arguments .. !! complex,intent(in) :: alpha,beta !! integer,intent(in) :: k,lda,ldb,ldc,n !! character,intent(in) :: trans,uplo !! .. !! .. Array Arguments .. !! complex,intent(in) :: a(lda,*),b(ldb,*) !! complex,intent(inout) :: c(ldc,*) !! .. !! !!##DEFINITION !! !! CSYR2K performs one of the symmetric rank 2k operations !! !! C := alpha*A*B**T + alpha*B*A**T + beta*C, !! !! or !! !! C := alpha*A**T*B + alpha*B**T*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. !! !!##OPTIONS !! !! UPLO !! !! UPLO is 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. !! !! TRANS !! !! TRANS is CHARACTER*1 !! On entry, TRANS specifies the operation to be performed as !! follows: !! !! TRANS = 'N' or 'n' C := alpha*A*B**T + alpha*B*A**T + !! beta*C. !! !! TRANS = 'T' or 't' C := alpha*A**T*B + alpha*B**T*A + !! beta*C. !! !! N !! !! N is INTEGER !! On entry, N specifies the order of the matrix C. N must be !! at least zero. !! !! K !! !! K is 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', K specifies the number of rows of the !! matrices A and B. K must be at least zero. !! !! ALPHA !! !! ALPHA is COMPLEX !! On entry, ALPHA specifies the scalar alpha. !! !! A !! !! A is COMPLEX array, 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. !! !! LDA !! !! LDA is 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 ). !! !! B !! !! B is COMPLEX array, 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. !! !! LDB !! !! LDB is 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 ). !! !! BETA !! !! BETA is COMPLEX !! On entry, BETA specifies the scalar beta. !! !! C !! !! C is COMPLEX array, 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 !! !! LDC is 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 ). !! !!##AUTHORS !! !! + Univ. of Tennessee !! + Univ. of California Berkeley !! + Univ. of Colorado Denver !! + NAG Ltd. !! !! date:December 2016 !! !! FURTHER DETAILS !! !! 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. !! !!##SEE ALSO !! Online html documentation available at !! http://www.netlib.org/lapack/explore-html/ ! ===================================================================== subroutine csyr2k(uplo,trans,n,k,alpha,a,lda,b,ldb,beta,c,ldc) implicit none ! ! -- Reference BLAS level3 routine (version 3.7.0) -- ! -- Reference BLAS is a software package provided by Univ. of Tennessee, -- ! -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- ! December 2016 ! ! .. Scalar Arguments .. complex,intent(in) :: alpha,beta integer,intent(in) :: k,lda,ldb,ldc,n character,intent(in) :: trans,uplo ! .. ! .. Array Arguments .. complex,intent(in) :: a(lda,*),b(ldb,*) complex,intent(inout) :: c(ldc,*) ! .. ! ! ===================================================================== ! ! .. External Functions .. ! .. ! .. External Subroutines .. ! .. ! .. Intrinsic Functions .. intrinsic max ! .. ! .. Local Scalars .. complex temp1,temp2 integer i,info,j,l,nrowa logical upper ! .. ! .. Parameters .. complex one parameter (one= (1.0e+0,0.0e+0)) complex zero parameter (zero= (0.0e+0,0.0e+0)) ! .. ! ! Test the input parameters. ! if (lsame(trans,'N')) then nrowa = n else nrowa = k endif upper = lsame(uplo,'U') ! info = 0 if ((.not.upper) .and. (.not.lsame(uplo,'L'))) then info = 1 elseif ((.not.lsame(trans,'N')) .and. (.not.lsame(trans,'T'))) then info = 2 elseif (n.lt.0) then info = 3 elseif (k.lt.0) then info = 4 elseif (lda.lt.max(1,nrowa)) then info = 7 elseif (ldb.lt.max(1,nrowa)) then info = 9 elseif (ldc.lt.max(1,n)) then info = 12 endif if (info.ne.0) then call xerbla('CSYR2K',info) return endif ! ! Quick return if possible. ! if ((n.eq.0) .or. (((alpha.eq.zero).or. (k.eq.0)).and. (beta.eq.one))) return ! ! And when alpha.eq.zero. ! if (alpha.eq.zero) then if (upper) then if (beta.eq.zero) then do j = 1,n c(1:j,j) = zero enddo else do j = 1,n c(1:j,j) = beta*c(1:j,j) enddo endif else if (beta.eq.zero) then do j = 1,n c(j:n,j) = zero enddo else do j = 1,n c(j:n,j) = beta*c(j:n,j) enddo endif endif return endif ! ! Start the operations. ! if (lsame(trans,'N')) then ! ! Form C := alpha*A*B**T + alpha*B*A**T + C. ! if (upper) then do j = 1,n if (beta.eq.zero) then c(1:j,j) = zero elseif (beta.ne.one) then c(1:j,j) = beta*c(1:j,j) endif do l = 1,k if ((a(j,l).ne.zero) .or. (b(j,l).ne.zero)) then temp1 = alpha*b(j,l) temp2 = alpha*a(j,l) do i = 1,j c(i,j) = c(i,j) + a(i,l)*temp1 + b(i,l)*temp2 enddo endif enddo enddo else do j = 1,n if (beta.eq.zero) then c(j:n,j) = zero elseif (beta.ne.one) then c(j:n,j) = beta*c(j:n,j) endif do l = 1,k if ((a(j,l).ne.zero) .or. (b(j,l).ne.zero)) then temp1 = alpha*b(j,l) temp2 = alpha*a(j,l) do i = j,n c(i,j) = c(i,j) + a(i,l)*temp1 + b(i,l)*temp2 enddo endif enddo enddo endif else ! ! Form C := alpha*A**T*B + alpha*B**T*A + C. ! if (upper) then do j = 1,n do i = 1,j temp1 = zero temp2 = zero do l = 1,k temp1 = temp1 + a(l,i)*b(l,j) temp2 = temp2 + b(l,i)*a(l,j) enddo if (beta.eq.zero) then c(i,j) = alpha*temp1 + alpha*temp2 else c(i,j) = beta*c(i,j) + alpha*temp1 + alpha*temp2 endif enddo enddo else do j = 1,n do i = j,n temp1 = zero temp2 = zero do l = 1,k temp1 = temp1 + a(l,i)*b(l,j) temp2 = temp2 + b(l,i)*a(l,j) enddo if (beta.eq.zero) then c(i,j) = alpha*temp1 + alpha*temp2 else c(i,j) = beta*c(i,j) + alpha*temp1 + alpha*temp2 endif enddo enddo endif endif ! ! End of CSYR2K. ! end subroutine csyr2k !> !!##NAME !! csyrk(3f) - [BLAS:COMPLEX_BLAS_LEVEL3] !! C:=alpha*A*TRANSPOSE(A)+beta*C, C symmetric. !! !!##SYNOPSIS !! !! subroutine csyrk(uplo,trans,n,k,alpha,a,lda,beta,c,ldc) !! !! .. Scalar Arguments .. !! complex,intent(in) :: alpha,beta !! integer,intent(in) :: k,lda,ldc,n !! character,intent(in) :: trans,uplo !! .. !! .. Array Arguments .. !! complex,intent(in) :: a(lda,*) !! complex,intent(inout) :: c(ldc,*) !! .. !! !!##DEFINITION !! !! CSYRK performs one of the symmetric rank k operations !! !! C := alpha*A*A**T + beta*C, !! !! or !! !! C := alpha*A**T*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. !! !!##OPTIONS !! !! UPLO !! !! UPLO is 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. !! !! TRANS !! !! TRANS is CHARACTER*1 !! On entry, TRANS specifies the operation to be performed as !! follows: !! !! TRANS = 'N' or 'n' C := alpha*A*A**T + beta*C. !! !! TRANS = 'T' or 't' C := alpha*A**T*A + beta*C. !! !! N !! !! N is INTEGER !! On entry, N specifies the order of the matrix C. N must be !! at least zero. !! !! K !! !! K is 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. !! !! ALPHA !! !! ALPHA is COMPLEX !! On entry, ALPHA specifies the scalar alpha. !! !! A !! !! A is COMPLEX array, 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. !! !! LDA !! !! LDA is 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 ). !! !! BETA !! !! BETA is COMPLEX !! On entry, BETA specifies the scalar beta. !! !! C !! !! C is COMPLEX array, 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 !! !! LDC is 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 ). !! !!##AUTHORS !! !! + Univ. of Tennessee !! + Univ. of California Berkeley !! + Univ. of Colorado Denver !! + NAG Ltd. !! !! date:December 2016 !! !! FURTHER DETAILS !! !! 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. !! !!##SEE ALSO !! Online html documentation available at !! http://www.netlib.org/lapack/explore-html/ ! ===================================================================== subroutine csyrk(uplo,trans,n,k,alpha,a,lda,beta,c,ldc) implicit none ! ! -- Reference BLAS level3 routine (version 3.7.0) -- ! -- Reference BLAS is a software package provided by Univ. of Tennessee, -- ! -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- ! December 2016 ! ! .. Scalar Arguments .. complex,intent(in) :: alpha,beta integer,intent(in) :: k,lda,ldc,n character,intent(in) :: trans,uplo ! .. ! .. Array Arguments .. complex,intent(in) :: a(lda,*) complex,intent(inout) :: c(ldc,*) ! .. ! ! ===================================================================== ! ! .. External Functions .. ! .. ! .. External Subroutines .. ! .. ! .. Intrinsic Functions .. intrinsic max ! .. ! .. Local Scalars .. complex temp integer i,info,j,l,nrowa logical upper ! .. ! .. Parameters .. complex one parameter (one= (1.0e+0,0.0e+0)) complex zero parameter (zero= (0.0e+0,0.0e+0)) ! .. ! ! Test the input parameters. ! if (lsame(trans,'N')) then nrowa = n else nrowa = k endif upper = lsame(uplo,'U') ! info = 0 if ((.not.upper) .and. (.not.lsame(uplo,'L'))) then info = 1 elseif ((.not.lsame(trans,'N')) .and. (.not.lsame(trans,'T'))) then info = 2 elseif (n.lt.0) then info = 3 elseif (k.lt.0) then info = 4 elseif (lda.lt.max(1,nrowa)) then info = 7 elseif (ldc.lt.max(1,n)) then info = 10 endif if (info.ne.0) then call xerbla('CSYRK ',info) return endif ! ! Quick return if possible. ! if ((n.eq.0) .or. (((alpha.eq.zero).or. (k.eq.0)).and. (beta.eq.one))) return ! ! And when alpha.eq.zero. ! if (alpha.eq.zero) then if (upper) then if (beta.eq.zero) then do j = 1,n c(1:j,j) = zero enddo else do j = 1,n c(1:j,j) = beta*c(1:j,j) enddo endif else if (beta.eq.zero) then do j = 1,n c(j:n,j) = zero enddo else do j = 1,n c(j:n,j) = beta*c(j:n,j) enddo endif endif return endif ! ! Start the operations. ! if (lsame(trans,'N')) then ! ! Form C := alpha*A*A**T + beta*C. ! if (upper) then do j = 1,n if (beta.eq.zero) then c(1:j,j) = zero elseif (beta.ne.one) then c(1:j,j) = beta*c(1:j,j) endif do l = 1,k if (a(j,l).ne.zero) then temp = alpha*a(j,l) c(1:n,j) = c(1:n,j) + temp*a(1:n,l) endif enddo enddo else do j = 1,n if (beta.eq.zero) then c(j:n,j) = zero elseif (beta.ne.one) then c(j:n,j) = beta*c(j:n,j) endif do l = 1,k if (a(j,l).ne.zero) then temp = alpha*a(j,l) do i = j,n c(i,j) = c(i,j) + temp*a(i,l) enddo endif enddo enddo endif else ! ! Form C := alpha*A**T*A + beta*C. ! if (upper) then do j = 1,n do i = 1,j temp = zero do l = 1,k temp = temp + a(l,i)*a(l,j) enddo if (beta.eq.zero) then c(i,j) = alpha*temp else c(i,j) = alpha*temp + beta*c(i,j) endif enddo enddo else do j = 1,n do i = j,n temp = zero do l = 1,k temp = temp + a(l,i)*a(l,j) enddo if (beta.eq.zero) then c(i,j) = alpha*temp else c(i,j) = alpha*temp + beta*c(i,j) endif enddo enddo endif endif ! ! End of CSYRK . ! end subroutine csyrk !> !!##NAME !! ctbmv(3f) - [BLAS:COMPLEX_BLAS_LEVEL2] !! CX := A*CX, A is a triangular band matrix. !! !!##SYNOPSIS !! !! subroutine ctbmv(uplo,trans,diag,n,k,a,lda,x,incx) !! !! .. Scalar Arguments .. !! integer,intent(in) :: incx,k,lda,n !! character,intent(in) :: diag,trans,uplo !! .. !! .. Array Arguments .. !! complex,intent(in) :: a(lda,*) !! complex,intent(inout) :: x(*) !! .. !! !!##DEFINITION !! !! CTBMV performs one of the matrix-vector operations !! !! x := A*x, or x := A**T*x, or x := A**H*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. !! !!##OPTIONS !! !! UPLO !! !! UPLO is 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. !! !! TRANS !! !! TRANS is 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**T*x. !! !! TRANS = 'C' or 'c' x := A**H*x. !! !! DIAG !! !! DIAG is 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. !! !! N !! !! N is INTEGER !! On entry, N specifies the order of the matrix A. !! N must be at least zero. !! !! K !! !! K is 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. !! !! A !! !! A is COMPLEX array, 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. !! !! LDA !! !! LDA is INTEGER !! On entry, LDA specifies the first dimension of A as declared !! in the calling (sub) program. LDA must be at least !! ( k + 1 ). !! !! X !! !! X is COMPLEX array, 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 !! transformed vector x. !! !! INCX !! !! INCX is INTEGER !! On entry, INCX specifies the increment for the elements of !! X. INCX must not be zero. !! !!##AUTHORS !! !! + Univ. of Tennessee !! + Univ. of California Berkeley !! + Univ. of Colorado Denver !! + NAG Ltd. !! !! date:December 2016 !! !! FURTHER DETAILS !! !! Level 2 Blas routine. !! The vector and matrix arguments are not referenced when N = 0, or M = 0 !! !! -- 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. !! !!##SEE ALSO !! Online html documentation available at !! http://www.netlib.org/lapack/explore-html/ ! ===================================================================== subroutine ctbmv(uplo,trans,diag,n,k,a,lda,x,incx) implicit none ! ! -- Reference BLAS level2 routine (version 3.7.0) -- ! -- Reference BLAS is a software package provided by Univ. of Tennessee, -- ! -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- ! December 2016 ! ! .. Scalar Arguments .. integer,intent(in) :: incx,k,lda,n character,intent(in) :: diag,trans,uplo ! .. ! .. Array Arguments .. complex,intent(in) :: a(lda,*) complex,intent(inout) :: x(*) ! .. ! ! ===================================================================== ! ! .. Parameters .. complex zero parameter (zero= (0.0e+0,0.0e+0)) ! .. ! .. Local Scalars .. complex temp integer i,info,ix,j,jx,kplus1,kx,l logical noconj,nounit ! .. ! .. External Functions .. ! .. ! .. External Subroutines .. ! .. ! .. Intrinsic Functions .. intrinsic conjg,max,min ! .. ! ! Test the input parameters. ! info = 0 if (.not.lsame(uplo,'U') .and. .not.lsame(uplo,'L')) then info = 1 elseif (.not.lsame(trans,'N') .and. .not.lsame(trans,'T') .and. .not.lsame(trans,'C')) then info = 2 elseif (.not.lsame(diag,'U') .and. .not.lsame(diag,'N')) then info = 3 elseif (n.lt.0) then info = 4 elseif (k.lt.0) then info = 5 elseif (lda.lt. (k+1)) then info = 7 elseif (incx.eq.0) then info = 9 endif if (info.ne.0) then call xerbla('CTBMV ',info) return endif ! ! Quick return if possible. ! if (n.eq.0) return ! noconj = lsame(trans,'T') nounit = lsame(diag,'N') ! ! Set up the start point in X if the increment is not unity. This ! will be ( N - 1 )*INCX too small for descending loops. ! if (incx.le.0) then kx = 1 - (n-1)*incx elseif (incx.ne.1) then kx = 1 endif ! ! Start the operations. In this version the elements of A are ! accessed sequentially with one pass through A. ! if (lsame(trans,'N')) then ! ! Form x := A*x. ! if (lsame(uplo,'U')) then kplus1 = k + 1 if (incx.eq.1) then do j = 1,n if (x(j).ne.zero) then temp = x(j) l = kplus1 - j do i = max(1,j-k),j - 1 x(i) = x(i) + temp*a(l+i,j) enddo if (nounit) x(j) = x(j)*a(kplus1,j) endif enddo else jx = kx do j = 1,n if (x(jx).ne.zero) then temp = x(jx) ix = kx l = kplus1 - j do i = max(1,j-k),j - 1 x(ix) = x(ix) + temp*a(l+i,j) ix = ix + incx enddo if (nounit) x(jx) = x(jx)*a(kplus1,j) endif jx = jx + incx if (j.gt.k) kx = kx + incx enddo endif else if (incx.eq.1) then do j = n,1,-1 if (x(j).ne.zero) then temp = x(j) l = 1 - j do i = min(n,j+k),j + 1,-1 x(i) = x(i) + temp*a(l+i,j) enddo if (nounit) x(j) = x(j)*a(1,j) endif enddo else kx = kx + (n-1)*incx jx = kx do j = n,1,-1 if (x(jx).ne.zero) then temp = x(jx) ix = kx l = 1 - j do i = min(n,j+k),j + 1,-1 x(ix) = x(ix) + temp*a(l+i,j) ix = ix - incx enddo if (nounit) x(jx) = x(jx)*a(1,j) endif jx = jx - incx if ((n-j).ge.k) kx = kx - incx enddo endif endif else ! ! Form x := A**T*x or x := A**H*x. ! if (lsame(uplo,'U')) then kplus1 = k + 1 if (incx.eq.1) then do j = n,1,-1 temp = x(j) l = kplus1 - j if (noconj) then if (nounit) temp = temp*a(kplus1,j) do i = j - 1,max(1,j-k),-1 temp = temp + a(l+i,j)*x(i) enddo else if (nounit) temp = temp*conjg(a(kplus1,j)) do i = j - 1,max(1,j-k),-1 temp = temp + conjg(a(l+i,j))*x(i) enddo endif x(j) = temp enddo else kx = kx + (n-1)*incx jx = kx do j = n,1,-1 temp = x(jx) kx = kx - incx ix = kx l = kplus1 - j if (noconj) then if (nounit) temp = temp*a(kplus1,j) do i = j - 1,max(1,j-k),-1 temp = temp + a(l+i,j)*x(ix) ix = ix - incx enddo else if (nounit) temp = temp*conjg(a(kplus1,j)) do i = j - 1,max(1,j-k),-1 temp = temp + conjg(a(l+i,j))*x(ix) ix = ix - incx enddo endif x(jx) = temp jx = jx - incx enddo endif else if (incx.eq.1) then do j = 1,n temp = x(j) l = 1 - j if (noconj) then if (nounit) temp = temp*a(1,j) do i = j + 1,min(n,j+k) temp = temp + a(l+i,j)*x(i) enddo else if (nounit) temp = temp*conjg(a(1,j)) do i = j + 1,min(n,j+k) temp = temp + conjg(a(l+i,j))*x(i) enddo endif x(j) = temp enddo else jx = kx do j = 1,n temp = x(jx) kx = kx + incx ix = kx l = 1 - j if (noconj) then if (nounit) temp = temp*a(1,j) do i = j + 1,min(n,j+k) temp = temp + a(l+i,j)*x(ix) ix = ix + incx enddo else if (nounit) temp = temp*conjg(a(1,j)) do i = j + 1,min(n,j+k) temp = temp + conjg(a(l+i,j))*x(ix) ix = ix + incx enddo endif x(jx) = temp jx = jx + incx enddo endif endif endif ! ! End of CTBMV . ! end subroutine ctbmv !> !!##NAME !! ctbsv(3f) - [BLAS:COMPLEX_BLAS_LEVEL2] !! CX := INVERSE(A)*CX, where A is a triangular band matrix. !! !!##SYNOPSIS !! !! subroutine ctbsv(uplo,trans,diag,n,k,a,lda,x,incx) !! !! .. Scalar Arguments .. !! integer,intent(in) :: incx,k,lda,n !! character,intent(in) :: diag,trans,uplo !! .. !! .. Array Arguments .. !! complex,intent(in) :: a(lda,*) !! complex,intent(inout) :: x(*) !! .. !! !!##DEFINITION !! !! CTBSV solves one of the systems of equations !! !! A*x = b, or A**T*x = b, or A**H*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. !! !!##OPTIONS !! !! UPLO !! !! UPLO is 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. !! !! TRANS !! !! TRANS is 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**T*x = b. !! !! TRANS = 'C' or 'c' A**H*x = b. !! !! DIAG !! !! DIAG is 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. !! !! N !! !! N is INTEGER !! On entry, N specifies the order of the matrix A. !! N must be at least zero. !! !! K !! !! K is 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. !! !! A !! !! A is COMPLEX array, 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. !! !! LDA !! !! LDA is INTEGER !! On entry, LDA specifies the first dimension of A as declared !! in the calling (sub) program. LDA must be at least !! ( k + 1 ). !! !! X !! !! X is COMPLEX array, 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 !! !! INCX is INTEGER !! On entry, INCX specifies the increment for the elements of !! X. INCX must not be zero. !! !!##AUTHORS !! !! + Univ. of Tennessee !! + Univ. of California Berkeley !! + Univ. of Colorado Denver !! + NAG Ltd. !! !! date:December 2016 !! !! FURTHER DETAILS !! !! 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. !! !!##SEE ALSO !! Online html documentation available at !! http://www.netlib.org/lapack/explore-html/ ! ===================================================================== subroutine ctbsv(uplo,trans,diag,n,k,a,lda,x,incx) implicit none ! ! -- Reference BLAS level2 routine (version 3.7.0) -- ! -- Reference BLAS is a software package provided by Univ. of Tennessee, -- ! -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- ! December 2016 ! ! .. Scalar Arguments .. integer,intent(in) :: incx,k,lda,n character,intent(in) :: diag,trans,uplo ! .. ! .. Array Arguments .. complex,intent(in) :: a(lda,*) complex,intent(inout) :: x(*) ! .. ! ! ===================================================================== ! ! .. Parameters .. complex zero parameter (zero= (0.0e+0,0.0e+0)) ! .. ! .. Local Scalars .. complex temp integer i,info,ix,j,jx,kplus1,kx,l logical noconj,nounit ! .. ! .. External Functions .. ! .. ! .. External Subroutines .. ! .. ! .. Intrinsic Functions .. intrinsic conjg,max,min ! .. ! ! Test the input parameters. ! info = 0 if (.not.lsame(uplo,'U') .and. .not.lsame(uplo,'L')) then info = 1 elseif (.not.lsame(trans,'N') .and. .not.lsame(trans,'T') .and. .not.lsame(trans,'C')) then info = 2 elseif (.not.lsame(diag,'U') .and. .not.lsame(diag,'N')) then info = 3 elseif (n.lt.0) then info = 4 elseif (k.lt.0) then info = 5 elseif (lda.lt. (k+1)) then info = 7 elseif (incx.eq.0) then info = 9 endif if (info.ne.0) then call xerbla('CTBSV ',info) return endif ! ! Quick return if possible. ! if (n.eq.0) return ! noconj = lsame(trans,'T') nounit = lsame(diag,'N') ! ! Set up the start point in X if the increment is not unity. This ! will be ( N - 1 )*INCX too small for descending loops. ! if (incx.le.0) then kx = 1 - (n-1)*incx elseif (incx.ne.1) then kx = 1 endif ! ! Start the operations. In this version the elements of A are ! accessed by sequentially with one pass through A. ! if (lsame(trans,'N')) then ! ! Form x := inv( A )*x. ! if (lsame(uplo,'U')) then kplus1 = k + 1 if (incx.eq.1) then do j = n,1,-1 if (x(j).ne.zero) then l = kplus1 - j if (nounit) x(j) = x(j)/a(kplus1,j) temp = x(j) do i = j - 1,max(1,j-k),-1 x(i) = x(i) - temp*a(l+i,j) enddo endif enddo else kx = kx + (n-1)*incx jx = kx do j = n,1,-1 kx = kx - incx if (x(jx).ne.zero) then ix = kx l = kplus1 - j if (nounit) x(jx) = x(jx)/a(kplus1,j) temp = x(jx) do i = j - 1,max(1,j-k),-1 x(ix) = x(ix) - temp*a(l+i,j) ix = ix - incx enddo endif jx = jx - incx enddo endif else if (incx.eq.1) then do j = 1,n if (x(j).ne.zero) then l = 1 - j if (nounit) x(j) = x(j)/a(1,j) temp = x(j) do i = j + 1,min(n,j+k) x(i) = x(i) - temp*a(l+i,j) enddo endif enddo else jx = kx do j = 1,n kx = kx + incx if (x(jx).ne.zero) then ix = kx l = 1 - j if (nounit) x(jx) = x(jx)/a(1,j) temp = x(jx) do i = j + 1,min(n,j+k) x(ix) = x(ix) - temp*a(l+i,j) ix = ix + incx enddo endif jx = jx + incx enddo endif endif else ! ! Form x := inv( A**T )*x or x := inv( A**H )*x. ! if (lsame(uplo,'U')) then kplus1 = k + 1 if (incx.eq.1) then do j = 1,n temp = x(j) l = kplus1 - j if (noconj) then do i = max(1,j-k),j - 1 temp = temp - a(l+i,j)*x(i) enddo if (nounit) temp = temp/a(kplus1,j) else do i = max(1,j-k),j - 1 temp = temp - conjg(a(l+i,j))*x(i) enddo if (nounit) temp = temp/conjg(a(kplus1,j)) endif x(j) = temp enddo else jx = kx do j = 1,n temp = x(jx) ix = kx l = kplus1 - j if (noconj) then do i = max(1,j-k),j - 1 temp = temp - a(l+i,j)*x(ix) ix = ix + incx enddo if (nounit) temp = temp/a(kplus1,j) else do i = max(1,j-k),j - 1 temp = temp - conjg(a(l+i,j))*x(ix) ix = ix + incx enddo if (nounit) temp = temp/conjg(a(kplus1,j)) endif x(jx) = temp jx = jx + incx if (j.gt.k) kx = kx + incx enddo endif else if (incx.eq.1) then do j = n,1,-1 temp = x(j) l = 1 - j if (noconj) then do i = min(n,j+k),j + 1,-1 temp = temp - a(l+i,j)*x(i) enddo if (nounit) temp = temp/a(1,j) else do i = min(n,j+k),j + 1,-1 temp = temp - conjg(a(l+i,j))*x(i) enddo if (nounit) temp = temp/conjg(a(1,j)) endif x(j) = temp enddo else kx = kx + (n-1)*incx jx = kx do j = n,1,-1 temp = x(jx) ix = kx l = 1 - j if (noconj) then do i = min(n,j+k),j + 1,-1 temp = temp - a(l+i,j)*x(ix) ix = ix - incx enddo if (nounit) temp = temp/a(1,j) else do i = min(n,j+k),j + 1,-1 temp = temp - conjg(a(l+i,j))*x(ix) ix = ix - incx enddo if (nounit) temp = temp/conjg(a(1,j)) endif x(jx) = temp jx = jx - incx if ((n-j).ge.k) kx = kx - incx enddo endif endif endif ! ! End of CTBSV . ! end subroutine ctbsv !> !!##NAME !! ctpmv(3f) - [BLAS:COMPLEX_BLAS_LEVEL2] !! CX := A*CX, A is a packed triangular band matrix. !! !!##SYNOPSIS !! !! subroutine ctpmv(uplo,trans,diag,n,ap,x,incx) !! !! .. Scalar Arguments .. !! integer,intent(in) :: incx,n !! character,intent(in) :: diag,trans,uplo !! .. !! .. Array Arguments .. !! complex,intent(in) :: ap(*) !! complex,intent(inout) :: x(*) !! .. !! !!##DEFINITION !! !! CTPMV performs one of the matrix-vector operations !! !! x := A*x, or x := A**T*x, or x := A**H*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. !! !!##OPTIONS !! !! UPLO !! !! UPLO is 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. !! !! TRANS !! !! TRANS is 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**T*x. !! !! TRANS = 'C' or 'c' x := A**H*x. !! !! DIAG !! !! DIAG is 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. !! !! N !! !! N is INTEGER !! On entry, N specifies the order of the matrix A. !! N must be at least zero. !! !! AP !! !! AP is COMPLEX array, 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. !! !! X !! !! X is COMPLEX array, 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 !! transformed vector x. !! !! INCX !! !! INCX is INTEGER !! On entry, INCX specifies the increment for the elements of !! X. INCX must not be zero. !! !!##AUTHORS !! !! + Univ. of Tennessee !! + Univ. of California Berkeley !! + Univ. of Colorado Denver !! + NAG Ltd. !! !! date:December 2016 !! !! FURTHER DETAILS !! !! Level 2 Blas routine. !! The vector and matrix arguments are not referenced when N = 0, or M = 0 !! !! -- 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. !! !!##SEE ALSO !! Online html documentation available at !! http://www.netlib.org/lapack/explore-html/ ! ===================================================================== subroutine ctpmv(uplo,trans,diag,n,ap,x,incx) implicit none ! ! -- Reference BLAS level2 routine (version 3.7.0) -- ! -- Reference BLAS is a software package provided by Univ. of Tennessee, -- ! -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- ! December 2016 ! ! .. Scalar Arguments .. integer,intent(in) :: incx,n character,intent(in) :: diag,trans,uplo ! .. ! .. Array Arguments .. complex,intent(in) :: ap(*) complex,intent(inout) :: x(*) ! .. ! ! ===================================================================== ! ! .. Parameters .. complex zero parameter (zero= (0.0e+0,0.0e+0)) ! .. ! .. Local Scalars .. complex temp integer i,info,ix,j,jx,k,kk,kx logical noconj,nounit ! .. ! .. External Functions .. ! .. ! .. External Subroutines .. ! .. ! .. Intrinsic Functions .. intrinsic conjg ! .. ! ! Test the input parameters. ! info = 0 if (.not.lsame(uplo,'U') .and. .not.lsame(uplo,'L')) then info = 1 elseif (.not.lsame(trans,'N') .and. .not.lsame(trans,'T') .and. .not.lsame(trans,'C')) then info = 2 elseif (.not.lsame(diag,'U') .and. .not.lsame(diag,'N')) then info = 3 elseif (n.lt.0) then info = 4 elseif (incx.eq.0) then info = 7 endif if (info.ne.0) then call xerbla('CTPMV ',info) return endif ! ! Quick return if possible. ! if (n.eq.0) return ! noconj = lsame(trans,'T') nounit = lsame(diag,'N') ! ! Set up the start point in X if the increment is not unity. This ! will be ( N - 1 )*INCX too small for descending loops. ! if (incx.le.0) then kx = 1 - (n-1)*incx elseif (incx.ne.1) then kx = 1 endif ! ! Start the operations. In this version the elements of AP are ! accessed sequentially with one pass through AP. ! if (lsame(trans,'N')) then ! ! Form x:= A*x. ! if (lsame(uplo,'U')) then kk = 1 if (incx.eq.1) then do j = 1,n if (x(j).ne.zero) then temp = x(j) k = kk do i = 1,j - 1 x(i) = x(i) + temp*ap(k) k = k + 1 enddo if (nounit) x(j) = x(j)*ap(kk+j-1) endif kk = kk + j enddo else jx = kx do j = 1,n if (x(jx).ne.zero) then temp = x(jx) ix = kx do k = kk,kk + j - 2 x(ix) = x(ix) + temp*ap(k) ix = ix + incx enddo if (nounit) x(jx) = x(jx)*ap(kk+j-1) endif jx = jx + incx kk = kk + j enddo endif else kk = (n* (n+1))/2 if (incx.eq.1) then do j = n,1,-1 if (x(j).ne.zero) then temp = x(j) k = kk do i = n,j + 1,-1 x(i) = x(i) + temp*ap(k) k = k - 1 enddo if (nounit) x(j) = x(j)*ap(kk-n+j) endif kk = kk - (n-j+1) enddo else kx = kx + (n-1)*incx jx = kx do j = n,1,-1 if (x(jx).ne.zero) then temp = x(jx) ix = kx do k = kk,kk - (n- (j+1)),-1 x(ix) = x(ix) + temp*ap(k) ix = ix - incx enddo if (nounit) x(jx) = x(jx)*ap(kk-n+j) endif jx = jx - incx kk = kk - (n-j+1) enddo endif endif else ! ! Form x := A**T*x or x := A**H*x. ! if (lsame(uplo,'U')) then kk = (n* (n+1))/2 if (incx.eq.1) then do j = n,1,-1 temp = x(j) k = kk - 1 if (noconj) then if (nounit) temp = temp*ap(kk) do i = j - 1,1,-1 temp = temp + ap(k)*x(i) k = k - 1 enddo else if (nounit) temp = temp*conjg(ap(kk)) do i = j - 1,1,-1 temp = temp + conjg(ap(k))*x(i) k = k - 1 enddo endif x(j) = temp kk = kk - j enddo else jx = kx + (n-1)*incx do j = n,1,-1 temp = x(jx) ix = jx if (noconj) then if (nounit) temp = temp*ap(kk) do k = kk - 1,kk - j + 1,-1 ix = ix - incx temp = temp + ap(k)*x(ix) enddo else if (nounit) temp = temp*conjg(ap(kk)) do k = kk - 1,kk - j + 1,-1 ix = ix - incx temp = temp + conjg(ap(k))*x(ix) enddo endif x(jx) = temp jx = jx - incx kk = kk - j enddo endif else kk = 1 if (incx.eq.1) then do j = 1,n temp = x(j) k = kk + 1 if (noconj) then if (nounit) temp = temp*ap(kk) do i = j + 1,n temp = temp + ap(k)*x(i) k = k + 1 enddo else if (nounit) temp = temp*conjg(ap(kk)) do i = j + 1,n temp = temp + conjg(ap(k))*x(i) k = k + 1 enddo endif x(j) = temp kk = kk + (n-j+1) enddo else jx = kx do j = 1,n temp = x(jx) ix = jx if (noconj) then if (nounit) temp = temp*ap(kk) do k = kk + 1,kk + n - j ix = ix + incx temp = temp + ap(k)*x(ix) enddo else if (nounit) temp = temp*conjg(ap(kk)) do k = kk + 1,kk + n - j ix = ix + incx temp = temp + conjg(ap(k))*x(ix) enddo endif x(jx) = temp jx = jx + incx kk = kk + (n-j+1) enddo endif endif endif ! ! End of CTPMV . ! end subroutine ctpmv !> !!##NAME !! ctpsv(3f) - [BLAS:COMPLEX_BLAS_LEVEL2] !! CX := INVERSE(A)*CX, where A is a packed triangular band matrix. !! !!##SYNOPSIS !! !! subroutine ctpsv(uplo,trans,diag,n,ap,x,incx) !! !! .. Scalar Arguments .. !! integer,intent(in) :: incx,n !! character,intent(in) :: diag,trans,uplo !! .. !! .. Array Arguments .. !! complex,intent(in) :: ap(*) !! complex,intent(inout) :: x(*) !! .. !! !!##DEFINITION !! !! CTPSV solves one of the systems of equations !! !! A*x = b, or A**T*x = b, or A**H*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. !! !!##OPTIONS !! !! UPLO !! !! UPLO is 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. !! !! TRANS !! !! TRANS is 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**T*x = b. !! !! TRANS = 'C' or 'c' A**H*x = b. !! !! DIAG !! !! DIAG is 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. !! !! N !! !! N is INTEGER !! On entry, N specifies the order of the matrix A. !! N must be at least zero. !! !! AP !! !! AP is COMPLEX array, 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. !! !! X !! !! X is COMPLEX array, 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 !! !! INCX is INTEGER !! On entry, INCX specifies the increment for the elements of !! X. INCX must not be zero. !! !!##AUTHORS !! !! + Univ. of Tennessee !! + Univ. of California Berkeley !! + Univ. of Colorado Denver !! + NAG Ltd. !! !! date:December 2016 !! !! FURTHER DETAILS !! !! 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. !! !!##SEE ALSO !! Online html documentation available at !! http://www.netlib.org/lapack/explore-html/ ! ===================================================================== subroutine ctpsv(uplo,trans,diag,n,ap,x,incx) implicit none ! ! -- Reference BLAS level2 routine (version 3.7.0) -- ! -- Reference BLAS is a software package provided by Univ. of Tennessee, -- ! -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- ! December 2016 ! ! .. Scalar Arguments .. integer,intent(in) :: incx,n character,intent(in) :: diag,trans,uplo ! .. ! .. Array Arguments .. complex,intent(in) :: ap(*) complex,intent(inout) :: x(*) ! .. ! ! ===================================================================== ! ! .. Parameters .. complex zero parameter (zero= (0.0e+0,0.0e+0)) ! .. ! .. Local Scalars .. complex temp integer i,info,ix,j,jx,k,kk,kx logical noconj,nounit ! .. ! .. External Functions .. ! .. ! .. External Subroutines .. ! .. ! .. Intrinsic Functions .. intrinsic conjg ! .. ! ! Test the input parameters. ! info = 0 if (.not.lsame(uplo,'U') .and. .not.lsame(uplo,'L')) then info = 1 elseif (.not.lsame(trans,'N') .and. .not.lsame(trans,'T') .and. .not.lsame(trans,'C')) then info = 2 elseif (.not.lsame(diag,'U') .and. .not.lsame(diag,'N')) then info = 3 elseif (n.lt.0) then info = 4 elseif (incx.eq.0) then info = 7 endif if (info.ne.0) then call xerbla('CTPSV ',info) return endif ! ! Quick return if possible. ! if (n.eq.0) return ! noconj = lsame(trans,'T') nounit = lsame(diag,'N') ! ! Set up the start point in X if the increment is not unity. This ! will be ( N - 1 )*INCX too small for descending loops. ! if (incx.le.0) then kx = 1 - (n-1)*incx elseif (incx.ne.1) then kx = 1 endif ! ! Start the operations. In this version the elements of AP are ! accessed sequentially with one pass through AP. ! if (lsame(trans,'N')) then ! ! Form x := inv( A )*x. ! if (lsame(uplo,'U')) then kk = (n* (n+1))/2 if (incx.eq.1) then do j = n,1,-1 if (x(j).ne.zero) then if (nounit) x(j) = x(j)/ap(kk) temp = x(j) k = kk - 1 do i = j - 1,1,-1 x(i) = x(i) - temp*ap(k) k = k - 1 enddo endif kk = kk - j enddo else jx = kx + (n-1)*incx do j = n,1,-1 if (x(jx).ne.zero) then if (nounit) x(jx) = x(jx)/ap(kk) temp = x(jx) ix = jx do k = kk - 1,kk - j + 1,-1 ix = ix - incx x(ix) = x(ix) - temp*ap(k) enddo endif jx = jx - incx kk = kk - j enddo endif else kk = 1 if (incx.eq.1) then do j = 1,n if (x(j).ne.zero) then if (nounit) x(j) = x(j)/ap(kk) temp = x(j) k = kk + 1 do i = j + 1,n x(i) = x(i) - temp*ap(k) k = k + 1 enddo endif kk = kk + (n-j+1) enddo else jx = kx do j = 1,n if (x(jx).ne.zero) then if (nounit) x(jx) = x(jx)/ap(kk) temp = x(jx) ix = jx do k = kk + 1,kk + n - j ix = ix + incx x(ix) = x(ix) - temp*ap(k) enddo endif jx = jx + incx kk = kk + (n-j+1) enddo endif endif else ! ! Form x := inv( A**T )*x or x := inv( A**H )*x. ! if (lsame(uplo,'U')) then kk = 1 if (incx.eq.1) then do j = 1,n temp = x(j) k = kk if (noconj) then do i = 1,j - 1 temp = temp - ap(k)*x(i) k = k + 1 enddo if (nounit) temp = temp/ap(kk+j-1) else do i = 1,j - 1 temp = temp - conjg(ap(k))*x(i) k = k + 1 enddo if (nounit) temp = temp/conjg(ap(kk+j-1)) endif x(j) = temp kk = kk + j enddo else jx = kx do j = 1,n temp = x(jx) ix = kx if (noconj) then do k = kk,kk + j - 2 temp = temp - ap(k)*x(ix) ix = ix + incx enddo if (nounit) temp = temp/ap(kk+j-1) else do k = kk,kk + j - 2 temp = temp - conjg(ap(k))*x(ix) ix = ix + incx enddo if (nounit) temp = temp/conjg(ap(kk+j-1)) endif x(jx) = temp jx = jx + incx kk = kk + j enddo endif else kk = (n* (n+1))/2 if (incx.eq.1) then do j = n,1,-1 temp = x(j) k = kk if (noconj) then do i = n,j + 1,-1 temp = temp - ap(k)*x(i) k = k - 1 enddo if (nounit) temp = temp/ap(kk-n+j) else do i = n,j + 1,-1 temp = temp - conjg(ap(k))*x(i) k = k - 1 enddo if (nounit) temp = temp/conjg(ap(kk-n+j)) endif x(j) = temp kk = kk - (n-j+1) enddo else kx = kx + (n-1)*incx jx = kx do j = n,1,-1 temp = x(jx) ix = kx if (noconj) then do k = kk,kk - (n- (j+1)),-1 temp = temp - ap(k)*x(ix) ix = ix - incx enddo if (nounit) temp = temp/ap(kk-n+j) else do k = kk,kk - (n- (j+1)),-1 temp = temp - conjg(ap(k))*x(ix) ix = ix - incx enddo if (nounit) temp = temp/conjg(ap(kk-n+j)) endif x(jx) = temp jx = jx - incx kk = kk - (n-j+1) enddo endif endif endif ! ! End of CTPSV . ! end subroutine ctpsv !> !!##NAME !! ctrmm(3f) - [BLAS:COMPLEX_BLAS_LEVEL3] !! B:=A*B or B:=B*A, A triangular, B rectangular. !! !!##SYNOPSIS !! !! subroutine ctrmm(side,uplo,transa,diag,m,n,alpha,a,lda,b,ldb) !! !! .. Scalar Arguments .. !! complex,intent(in) :: alpha !! integer,intent(in) :: lda,ldb,m,n !! character,intent(in) :: diag,side,transa,uplo !! .. !! .. Array Arguments .. !! complex,intent(in) :: a(lda,*) !! complex,intent(inout) :: b(ldb,*) !! .. !! !!##DEFINITION !! !! CTRMM 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**T or op( A ) = A**H. !! !!##OPTIONS !! !! SIDE !! !! SIDE is 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 ). !! !! UPLO !! !! UPLO is 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. !! !! TRANSA !! !! TRANSA is 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**T. !! !! TRANSA = 'C' or 'c' op( A ) = A**H. !! !! DIAG !! !! DIAG is 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. !! !! M !! !! M is INTEGER !! On entry, M specifies the number of rows of B. M must be at !! least zero. !! !! N !! !! N is INTEGER !! On entry, N specifies the number of columns of B. N must be !! at least zero. !! !! ALPHA !! !! ALPHA is COMPLEX !! On entry, ALPHA specifies the scalar alpha. When alpha is !! zero then A is not referenced and B need not be set before !! entry. !! !! A !! !! A is COMPLEX array, 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. !! !! LDA !! !! LDA is 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 ). !! !! B !! !! B is COMPLEX array, 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 !! !! LDB is 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 ). !! !!##AUTHORS !! !! + Univ. of Tennessee !! + Univ. of California Berkeley !! + Univ. of Colorado Denver !! + NAG Ltd. !! !! date:December 2016 !! !! FURTHER DETAILS !! !! 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. !! !!##SEE ALSO !! Online html documentation available at !! http://www.netlib.org/lapack/explore-html/ ! ===================================================================== subroutine ctrmm(side,uplo,transa,diag,m,n,alpha,a,lda,b,ldb) implicit none ! ! -- Reference BLAS level3 routine (version 3.7.0) -- ! -- Reference BLAS is a software package provided by Univ. of Tennessee, -- ! -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- ! December 2016 ! ! .. Scalar Arguments .. complex,intent(in) :: alpha integer,intent(in) :: lda,ldb,m,n character,intent(in) :: diag,side,transa,uplo ! .. ! .. Array Arguments .. complex,intent(in) :: a(lda,*) complex,intent(inout) :: b(ldb,*) ! .. ! ! ===================================================================== ! ! .. External Functions .. ! .. ! .. External Subroutines .. ! .. ! .. Intrinsic Functions .. intrinsic conjg,max ! .. ! .. Local Scalars .. complex temp integer i,info,j,k,nrowa logical lside,noconj,nounit,upper ! .. ! .. Parameters .. complex one parameter (one= (1.0e+0,0.0e+0)) complex zero parameter (zero= (0.0e+0,0.0e+0)) ! .. ! ! Test the input parameters. ! lside = lsame(side,'L') if (lside) then nrowa = m else nrowa = n endif noconj = lsame(transa,'T') nounit = lsame(diag,'N') upper = lsame(uplo,'U') ! info = 0 if ((.not.lside) .and. (.not.lsame(side,'R'))) then info = 1 elseif ((.not.upper) .and. (.not.lsame(uplo,'L'))) then info = 2 elseif ((.not.lsame(transa,'N')) .and. (.not.lsame(transa,'T')) .and. (.not.lsame(transa,'C'))) then info = 3 elseif ((.not.lsame(diag,'U')) .and. (.not.lsame(diag,'N'))) then info = 4 elseif (m.lt.0) then info = 5 elseif (n.lt.0) then info = 6 elseif (lda.lt.max(1,nrowa)) then info = 9 elseif (ldb.lt.max(1,m)) then info = 11 endif if (info.ne.0) then call xerbla('CTRMM ',info) return endif ! ! Quick return if possible. ! if (m.eq.0 .or. n.eq.0) return ! ! And when alpha.eq.zero. ! if (alpha.eq.zero) then b(1:m,1:n) = zero return endif ! ! Start the operations. ! if (lside) then if (lsame(transa,'N')) then ! ! Form B := alpha*A*B. ! if (upper) then do j = 1,n do k = 1,m if (b(k,j).ne.zero) then temp = alpha*b(k,j) do i = 1,k - 1 b(i,j) = b(i,j) + temp*a(i,k) enddo if (nounit) temp = temp*a(k,k) b(k,j) = temp endif enddo enddo else do j = 1,n do k = m,1,-1 if (b(k,j).ne.zero) then temp = alpha*b(k,j) b(k,j) = temp if (nounit) b(k,j) = b(k,j)*a(k,k) do i = k + 1,m b(i,j) = b(i,j) + temp*a(i,k) enddo endif enddo enddo endif else ! ! Form B := alpha*A**T*B or B := alpha*A**H*B. ! if (upper) then do j = 1,n do i = m,1,-1 temp = b(i,j) if (noconj) then if (nounit) temp = temp*a(i,i) do k = 1,i - 1 temp = temp + a(k,i)*b(k,j) enddo else if (nounit) temp = temp*conjg(a(i,i)) do k = 1,i - 1 temp = temp + conjg(a(k,i))*b(k,j) enddo endif b(i,j) = alpha*temp enddo enddo else do j = 1,n do i = 1,m temp = b(i,j) if (noconj) then if (nounit) temp = temp*a(i,i) do k = i + 1,m temp = temp + a(k,i)*b(k,j) enddo else if (nounit) temp = temp*conjg(a(i,i)) do k = i + 1,m temp = temp + conjg(a(k,i))*b(k,j) enddo endif b(i,j) = alpha*temp enddo enddo endif endif else if (lsame(transa,'N')) then ! ! Form B := alpha*B*A. ! if (upper) then do j = n,1,-1 temp = alpha if (nounit) temp = temp*a(j,j) b(1:m,j) = temp*b(1:m,j) do k = 1,j - 1 if (a(k,j).ne.zero) then temp = alpha*a(k,j) b(1:m,j) = b(1:m,j) + temp*b(1:m,k) endif enddo enddo else do j = 1,n temp = alpha if (nounit) temp = temp*a(j,j) b(1:m,j) = temp*b(1:m,j) do k = j + 1,n if (a(k,j).ne.zero) then temp = alpha*a(k,j) b(1:m,j) = b(1:m,j) + temp*b(1:m,k) endif enddo enddo endif else ! ! Form B := alpha*B*A**T or B := alpha*B*A**H. ! if (upper) then do k = 1,n do j = 1,k - 1 if (a(j,k).ne.zero) then if (noconj) then temp = alpha*a(j,k) else temp = alpha*conjg(a(j,k)) endif b(1:m,j) = b(1:m,j) + temp*b(1:m,k) endif enddo temp = alpha if (nounit) then if (noconj) then temp = temp*a(k,k) else temp = temp*conjg(a(k,k)) endif endif if (temp.ne.one) then b(1:m,k) = temp*b(1:m,k) endif enddo else do k = n,1,-1 do j = k + 1,n if (a(j,k).ne.zero) then if (noconj) then temp = alpha*a(j,k) else temp = alpha*conjg(a(j,k)) endif b(1:m,j) = b(1:m,j) + temp*b(1:m,k) endif enddo temp = alpha if (nounit) then if (noconj) then temp = temp*a(k,k) else temp = temp*conjg(a(k,k)) endif endif if (temp.ne.one) then b(1:m,k) = temp*b(1:m,k) endif enddo endif endif endif ! ! End of CTRMM . ! end subroutine ctrmm !> !!##NAME !! ctrmv(3f) - [BLAS:COMPLEX_BLAS_LEVEL2] !! CX := A*CX, A is a triangular matrix. !! !!##SYNOPSIS !! !! subroutine ctrmv(uplo,trans,diag,n,a,lda,x,incx) !! !! .. Scalar Arguments .. !! integer,intent(in) :: incx,lda,n !! character,intent(in) :: diag,trans,uplo !! .. !! .. Array Arguments .. !! complex,intent(in) :: a(lda,*) !! complex,intent(inout) :: x(*) !! .. !! !!##DEFINITION !! !! CTRMV performs one of the matrix-vector operations !! !! x := A*x, or x := A**T*x, or x := A**H*x, !! !! where x is an n element vector and A is an n by n unit, or non-unit, !! upper or lower triangular matrix. !! !!##OPTIONS !! !! UPLO !! !! UPLO is 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. !! !! TRANS !! !! TRANS is 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**T*x. !! !! TRANS = 'C' or 'c' x := A**H*x. !! !! DIAG !! !! DIAG is 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. !! !! N !! !! N is INTEGER !! On entry, N specifies the order of the matrix A. !! N must be at least zero. !! !! A !! !! A is COMPLEX array, 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. !! !! LDA !! !! LDA is 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 ). !! !! X !! !! X is COMPLEX array, 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 !! transformed vector x. !! !! INCX !! !! INCX is INTEGER !! On entry, INCX specifies the increment for the elements of !! X. INCX must not be zero. !! !!##AUTHORS !! !! + Univ. of Tennessee !! + Univ. of California Berkeley !! + Univ. of Colorado Denver !! + NAG Ltd. !! !! date:December 2016 !! !! FURTHER DETAILS !! !! Level 2 Blas routine. !! The vector and matrix arguments are not referenced when N = 0, or M = 0 !! !! -- 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. !! !!##SEE ALSO !! Online html documentation available at !! http://www.netlib.org/lapack/explore-html/ ! ===================================================================== subroutine ctrmv(uplo,trans,diag,n,a,lda,x,incx) implicit none ! ! -- Reference BLAS level2 routine (version 3.7.0) -- ! -- Reference BLAS is a software package provided by Univ. of Tennessee, -- ! -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- ! December 2016 ! ! .. Scalar Arguments .. integer,intent(in) :: incx,lda,n character,intent(in) :: diag,trans,uplo ! .. ! .. Array Arguments .. complex,intent(in) :: a(lda,*) complex,intent(inout) :: x(*) ! .. ! ! ===================================================================== ! ! .. Parameters .. complex zero parameter (zero= (0.0e+0,0.0e+0)) ! .. ! .. Local Scalars .. complex temp integer i,info,ix,j,jx,kx logical noconj,nounit ! .. ! .. External Functions .. ! .. ! .. External Subroutines .. ! .. ! .. Intrinsic Functions .. intrinsic conjg,max ! .. ! ! Test the input parameters. ! info = 0 if (.not.lsame(uplo,'U') .and. .not.lsame(uplo,'L')) then info = 1 elseif (.not.lsame(trans,'N') .and. .not.lsame(trans,'T') .and. .not.lsame(trans,'C')) then info = 2 elseif (.not.lsame(diag,'U') .and. .not.lsame(diag,'N')) then info = 3 elseif (n.lt.0) then info = 4 elseif (lda.lt.max(1,n)) then info = 6 elseif (incx.eq.0) then info = 8 endif if (info.ne.0) then call xerbla('CTRMV ',info) return endif ! ! Quick return if possible. ! if (n.eq.0) return ! noconj = lsame(trans,'T') nounit = lsame(diag,'N') ! ! Set up the start point in X if the increment is not unity. This ! will be ( N - 1 )*INCX too small for descending loops. ! if (incx.le.0) then kx = 1 - (n-1)*incx elseif (incx.ne.1) then kx = 1 endif ! ! Start the operations. In this version the elements of A are ! accessed sequentially with one pass through A. ! if (lsame(trans,'N')) then ! ! Form x := A*x. ! if (lsame(uplo,'U')) then if (incx.eq.1) then do j = 1,n if (x(j).ne.zero) then temp = x(j) do i = 1,j - 1 x(i) = x(i) + temp*a(i,j) enddo if (nounit) x(j) = x(j)*a(j,j) endif enddo else jx = kx do j = 1,n if (x(jx).ne.zero) then temp = x(jx) ix = kx do i = 1,j - 1 x(ix) = x(ix) + temp*a(i,j) ix = ix + incx enddo if (nounit) x(jx) = x(jx)*a(j,j) endif jx = jx + incx enddo endif else if (incx.eq.1) then do j = n,1,-1 if (x(j).ne.zero) then temp = x(j) do i = n,j + 1,-1 x(i) = x(i) + temp*a(i,j) enddo if (nounit) x(j) = x(j)*a(j,j) endif enddo else kx = kx + (n-1)*incx jx = kx do j = n,1,-1 if (x(jx).ne.zero) then temp = x(jx) ix = kx do i = n,j + 1,-1 x(ix) = x(ix) + temp*a(i,j) ix = ix - incx enddo if (nounit) x(jx) = x(jx)*a(j,j) endif jx = jx - incx enddo endif endif else ! ! Form x := A**T*x or x := A**H*x. ! if (lsame(uplo,'U')) then if (incx.eq.1) then do j = n,1,-1 temp = x(j) if (noconj) then if (nounit) temp = temp*a(j,j) do i = j - 1,1,-1 temp = temp + a(i,j)*x(i) enddo else if (nounit) temp = temp*conjg(a(j,j)) do i = j - 1,1,-1 temp = temp + conjg(a(i,j))*x(i) enddo endif x(j) = temp enddo else jx = kx + (n-1)*incx do j = n,1,-1 temp = x(jx) ix = jx if (noconj) then if (nounit) temp = temp*a(j,j) do i = j - 1,1,-1 ix = ix - incx temp = temp + a(i,j)*x(ix) enddo else if (nounit) temp = temp*conjg(a(j,j)) do i = j - 1,1,-1 ix = ix - incx temp = temp + conjg(a(i,j))*x(ix) enddo endif x(jx) = temp jx = jx - incx enddo endif else if (incx.eq.1) then do j = 1,n temp = x(j) if (noconj) then if (nounit) temp = temp*a(j,j) do i = j + 1,n temp = temp + a(i,j)*x(i) enddo else if (nounit) temp = temp*conjg(a(j,j)) do i = j + 1,n temp = temp + conjg(a(i,j))*x(i) enddo endif x(j) = temp enddo else jx = kx do j = 1,n temp = x(jx) ix = jx if (noconj) then if (nounit) temp = temp*a(j,j) do i = j + 1,n ix = ix + incx temp = temp + a(i,j)*x(ix) enddo else if (nounit) temp = temp*conjg(a(j,j)) do i = j + 1,n ix = ix + incx temp = temp + conjg(a(i,j))*x(ix) enddo endif x(jx) = temp jx = jx + incx enddo endif endif endif ! ! End of CTRMV . ! end subroutine ctrmv !> !!##NAME !! ctrsm(3f) - [BLAS:COMPLEX_BLAS_LEVEL3] !! B:=INVERSE(A)*C or B:=C*INVERSE(A), B, C rectangular, A triangular. !! !!##SYNOPSIS !! !! subroutine ctrsm(side,uplo,transa,diag,m,n,alpha,a,lda,b,ldb) !! !! .. Scalar Arguments .. !! complex,intent(in) :: alpha !! integer,intent(in) :: lda,ldb,m,n !! character,intent(in) :: diag,side,transa,uplo !! .. !! .. Array Arguments .. !! complex,intent(in) :: a(lda,*) !! complex,intent(inout) :: b(ldb,*) !! .. !! !!##DEFINITION !! !! CTRSM 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**T or op( A ) = A**H. !! !! The matrix X is overwritten on B. !! !!##OPTIONS !! !! SIDE !! !! SIDE is 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. !! !! UPLO !! !! UPLO is 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. !! !! TRANSA !! !! TRANSA is 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**T. !! !! TRANSA = 'C' or 'c' op( A ) = A**H. !! !! DIAG !! !! DIAG is 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. !! !! M !! !! M is INTEGER !! On entry, M specifies the number of rows of B. M must be at !! least zero. !! !! N !! !! N is INTEGER !! On entry, N specifies the number of columns of B. N must be !! at least zero. !! !! ALPHA !! !! ALPHA is COMPLEX !! On entry, ALPHA specifies the scalar alpha. When alpha is !! zero then A is not referenced and B need not be set before !! entry. !! !! A !! !! A is COMPLEX array, dimension ( LDA, k ), !! where k is m when SIDE = 'L' or 'l' !! and k 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. !! !! LDA !! !! LDA is 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 ). !! !! B !! !! B is COMPLEX 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 !! !! LDB is 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 ). !! !!##AUTHORS !! !! + Univ. of Tennessee !! + Univ. of California Berkeley !! + Univ. of Colorado Denver !! + NAG Ltd. !! !! date:December 2016 !! !! FURTHER DETAILS !! !! 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. !! !!##SEE ALSO !! Online html documentation available at !! http://www.netlib.org/lapack/explore-html/ ! ===================================================================== subroutine ctrsm(side,uplo,transa,diag,m,n,alpha,a,lda,b,ldb) implicit none ! ! -- Reference BLAS level3 routine (version 3.7.0) -- ! -- Reference BLAS is a software package provided by Univ. of Tennessee, -- ! -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- ! December 2016 ! ! .. Scalar Arguments .. complex,intent(in) :: alpha integer,intent(in) :: lda,ldb,m,n character,intent(in) :: diag,side,transa,uplo ! .. ! .. Array Arguments .. complex,intent(in) :: a(lda,*) complex,intent(inout) :: b(ldb,*) ! .. ! ===================================================================== ! .. External Functions .. ! .. ! .. External Subroutines .. ! .. ! .. Intrinsic Functions .. intrinsic conjg,max ! .. ! .. Local Scalars .. complex temp integer i,info,j,k,nrowa logical lside,noconj,nounit,upper ! .. ! .. Parameters .. complex one parameter (one= (1.0e+0,0.0e+0)) complex zero parameter (zero= (0.0e+0,0.0e+0)) ! .. ! ! Test the input parameters. ! lside = lsame(side,'L') if (lside) then nrowa = m else nrowa = n endif noconj = lsame(transa,'T') nounit = lsame(diag,'N') upper = lsame(uplo,'U') ! info = 0 if ((.not.lside) .and. (.not.lsame(side,'R'))) then info = 1 elseif ((.not.upper) .and. (.not.lsame(uplo,'L'))) then info = 2 elseif ((.not.lsame(transa,'N')) .and. (.not.lsame(transa,'T')) .and. (.not.lsame(transa,'C'))) then info = 3 elseif ((.not.lsame(diag,'U')) .and. (.not.lsame(diag,'N'))) then info = 4 elseif (m.lt.0) then info = 5 elseif (n.lt.0) then info = 6 elseif (lda.lt.max(1,nrowa)) then info = 9 elseif (ldb.lt.max(1,m)) then info = 11 endif if (info.ne.0) then call xerbla('CTRSM ',info) return endif ! ! Quick return if possible. ! if (m.eq.0 .or. n.eq.0) return ! ! And when alpha.eq.zero. ! if (alpha.eq.zero) then b(1:m,1:n) = zero return endif ! ! Start the operations. ! if (lside) then if (lsame(transa,'N')) then ! ! Form B := alpha*inv( A )*B. ! if (upper) then do j = 1,n if (alpha.ne.one) then b(1:m,j) = alpha*b(1:m,j) endif do k = m,1,-1 if (b(k,j).ne.zero) then if (nounit) b(k,j) = b(k,j)/a(k,k) do i = 1,k - 1 b(i,j) = b(i,j) - b(k,j)*a(i,k) enddo endif enddo enddo else do j = 1,n if (alpha.ne.one) then b(1:m,j) = alpha*b(1:m,j) endif do k = 1,m if (b(k,j).ne.zero) then if (nounit) b(k,j) = b(k,j)/a(k,k) do i = k + 1,m b(i,j) = b(i,j) - b(k,j)*a(i,k) enddo endif enddo enddo endif else ! ! Form B := alpha*inv( A**T )*B ! or B := alpha*inv( A**H )*B. ! if (upper) then do j = 1,n do i = 1,m temp = alpha*b(i,j) if (noconj) then do k = 1,i - 1 temp = temp - a(k,i)*b(k,j) enddo if (nounit) temp = temp/a(i,i) else do k = 1,i - 1 temp = temp - conjg(a(k,i))*b(k,j) enddo if (nounit) temp = temp/conjg(a(i,i)) endif b(i,j) = temp enddo enddo else do j = 1,n do i = m,1,-1 temp = alpha*b(i,j) if (noconj) then do k = i + 1,m temp = temp - a(k,i)*b(k,j) enddo if (nounit) temp = temp/a(i,i) else do k = i + 1,m temp = temp - conjg(a(k,i))*b(k,j) enddo if (nounit) temp = temp/conjg(a(i,i)) endif b(i,j) = temp enddo enddo endif endif else if (lsame(transa,'N')) then ! ! Form B := alpha*B*inv( A ). ! if (upper) then do j = 1,n if (alpha.ne.one) then b(1:m,j) = alpha*b(1:m,j) endif do k = 1,j - 1 if (a(k,j).ne.zero) then b(1:m,j) = b(1:m,j) - a(k,j)*b(1:m,k) endif enddo if (nounit) then temp = one/a(j,j) b(1:m,j) = temp*b(1:m,j) endif enddo else do j = n,1,-1 if (alpha.ne.one) then b(1:m,j) = alpha*b(1:m,j) endif do k = j + 1,n if (a(k,j).ne.zero) then b(1:m,j) = b(1:m,j) - a(k,j)*b(1:m,k) endif enddo if (nounit) then temp = one/a(j,j) b(1:m,j) = temp*b(1:m,j) endif enddo endif else ! ! Form B := alpha*B*inv( A**T ) ! or B := alpha*B*inv( A**H ). ! if (upper) then do k = n,1,-1 if (nounit) then if (noconj) then temp = one/a(k,k) else temp = one/conjg(a(k,k)) endif b(1:m,k) = temp*b(1:m,k) endif do j = 1,k - 1 if (a(j,k).ne.zero) then if (noconj) then temp = a(j,k) else temp = conjg(a(j,k)) endif b(1:m,j) = b(1:m,j) - temp*b(1:m,k) endif enddo if (alpha.ne.one) then b(1:m,k) = alpha*b(1:m,k) endif enddo else do k = 1,n if (nounit) then if (noconj) then temp = one/a(k,k) else temp = one/conjg(a(k,k)) endif b(1:m,k) = temp*b(1:m,k) endif do j = k + 1,n if (a(j,k).ne.zero) then if (noconj) then temp = a(j,k) else temp = conjg(a(j,k)) endif b(1:m,j) = b(1:m,j) - temp*b(1:m,k) endif enddo if (alpha.ne.one) then b(1:m,k) = alpha*b(1:m,k) endif enddo endif endif endif end subroutine ctrsm !> !!##NAME !! ctrsv(3f) - [BLAS:COMPLEX_BLAS_LEVEL2] !! CX := INVERSE(A)*CX, where A is a triangular matrix. !! !!##SYNOPSIS !! !! subroutine ctrsv(uplo,trans,diag,n,a,lda,x,incx) !! !! .. Scalar Arguments .. !! integer,intent(in) :: incx,lda,n !! character,intent(in) :: diag,trans,uplo !! .. !! .. Array Arguments .. !! complex,intent(in) :: a(lda,*) !! complex,intent(inout) :: x(*) !! .. !! !!##DEFINITION !! !! CTRSV solves one of the systems of equations !! !! A*x = b, or A**T*x = b, or A**H*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. !! !!##OPTIONS !! !! UPLO !! !! UPLO is 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. !! !! TRANS !! !! TRANS is 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**T*x = b. !! !! TRANS = 'C' or 'c' A**H*x = b. !! !! DIAG !! !! DIAG is 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. !! !! N !! !! N is INTEGER !! On entry, N specifies the order of the matrix A. !! N must be at least zero. !! !! A !! !! A is COMPLEX array, 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. !! !! LDA !! !! LDA is 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 ). !! !! X !! !! X is COMPLEX array, 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 !! !! INCX is INTEGER !! On entry, INCX specifies the increment for the elements of !! X. INCX must not be zero. !! !!##AUTHORS !! !! + Univ. of Tennessee !! + Univ. of California Berkeley !! + Univ. of Colorado Denver !! + NAG Ltd. !! !! date:December 2016 !! !! FURTHER DETAILS !! !! 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. !! !!##SEE ALSO !! Online html documentation available at !! http://www.netlib.org/lapack/explore-html/ ! ===================================================================== subroutine ctrsv(uplo,trans,diag,n,a,lda,x,incx) implicit none ! ! -- Reference BLAS level2 routine (version 3.7.0) -- ! -- Reference BLAS is a software package provided by Univ. of Tennessee, -- ! -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- ! December 2016 ! ! .. Scalar Arguments .. integer,intent(in) :: incx,lda,n character,intent(in) :: diag,trans,uplo ! .. ! .. Array Arguments .. complex,intent(in) :: a(lda,*) complex,intent(inout) :: x(*) ! .. ! ! ===================================================================== ! ! .. Parameters .. complex zero parameter (zero= (0.0e+0,0.0e+0)) ! .. ! .. Local Scalars .. complex temp integer i,info,ix,j,jx,kx logical noconj,nounit ! .. ! .. External Functions .. ! .. ! .. External Subroutines .. ! .. ! .. Intrinsic Functions .. intrinsic conjg,max ! .. ! ! Test the input parameters. ! info = 0 if (.not.lsame(uplo,'U') .and. .not.lsame(uplo,'L')) then info = 1 elseif (.not.lsame(trans,'N') .and. .not.lsame(trans,'T') .and. .not.lsame(trans,'C')) then info = 2 elseif (.not.lsame(diag,'U') .and. .not.lsame(diag,'N')) then info = 3 elseif (n.lt.0) then info = 4 elseif (lda.lt.max(1,n)) then info = 6 elseif (incx.eq.0) then info = 8 endif if (info.ne.0) then call xerbla('CTRSV ',info) return endif ! ! Quick return if possible. ! if (n.eq.0) return ! noconj = lsame(trans,'T') nounit = lsame(diag,'N') ! ! Set up the start point in X if the increment is not unity. This ! will be ( N - 1 )*INCX too small for descending loops. ! if (incx.le.0) then kx = 1 - (n-1)*incx elseif (incx.ne.1) then kx = 1 endif ! ! Start the operations. In this version the elements of A are ! accessed sequentially with one pass through A. ! if (lsame(trans,'N')) then ! ! Form x := inv( A )*x. ! if (lsame(uplo,'U')) then if (incx.eq.1) then do j = n,1,-1 if (x(j).ne.zero) then if (nounit) x(j) = x(j)/a(j,j) temp = x(j) do i = j - 1,1,-1 x(i) = x(i) - temp*a(i,j) enddo endif enddo else jx = kx + (n-1)*incx do j = n,1,-1 if (x(jx).ne.zero) then if (nounit) x(jx) = x(jx)/a(j,j) temp = x(jx) ix = jx do i = j - 1,1,-1 ix = ix - incx x(ix) = x(ix) - temp*a(i,j) enddo endif jx = jx - incx enddo endif else if (incx.eq.1) then do j = 1,n if (x(j).ne.zero) then if (nounit) x(j) = x(j)/a(j,j) temp = x(j) do i = j + 1,n x(i) = x(i) - temp*a(i,j) enddo endif enddo else jx = kx do j = 1,n if (x(jx).ne.zero) then if (nounit) x(jx) = x(jx)/a(j,j) temp = x(jx) ix = jx do i = j + 1,n ix = ix + incx x(ix) = x(ix) - temp*a(i,j) enddo endif jx = jx + incx enddo endif endif else ! ! Form x := inv( A**T )*x or x := inv( A**H )*x. ! if (lsame(uplo,'U')) then if (incx.eq.1) then do j = 1,n temp = x(j) if (noconj) then do i = 1,j - 1 temp = temp - a(i,j)*x(i) enddo if (nounit) temp = temp/a(j,j) else do i = 1,j - 1 temp = temp - conjg(a(i,j))*x(i) enddo if (nounit) temp = temp/conjg(a(j,j)) endif x(j) = temp enddo else jx = kx do j = 1,n ix = kx temp = x(jx) if (noconj) then do i = 1,j - 1 temp = temp - a(i,j)*x(ix) ix = ix + incx enddo if (nounit) temp = temp/a(j,j) else do i = 1,j - 1 temp = temp - conjg(a(i,j))*x(ix) ix = ix + incx enddo if (nounit) temp = temp/conjg(a(j,j)) endif x(jx) = temp jx = jx + incx enddo endif else if (incx.eq.1) then do j = n,1,-1 temp = x(j) if (noconj) then do i = n,j + 1,-1 temp = temp - a(i,j)*x(i) enddo if (nounit) temp = temp/a(j,j) else do i = n,j + 1,-1 temp = temp - conjg(a(i,j))*x(i) enddo if (nounit) temp = temp/conjg(a(j,j)) endif x(j) = temp enddo else kx = kx + (n-1)*incx jx = kx do j = n,1,-1 ix = kx temp = x(jx) if (noconj) then do i = n,j + 1,-1 temp = temp - a(i,j)*x(ix) ix = ix - incx enddo if (nounit) temp = temp/a(j,j) else do i = n,j + 1,-1 temp = temp - conjg(a(i,j))*x(ix) ix = ix - incx enddo if (nounit) temp = temp/conjg(a(j,j)) endif x(jx) = temp jx = jx - incx enddo endif endif endif ! ! End of CTRSV . ! end subroutine ctrsv !> !!##NAME !! dasum(3f) - [BLAS:DOUBLE_BLAS_LEVEL1] takes the sum of the absolute values. !! !!##SYNOPSIS !! !! double precision function dasum(n,dx,incx) !! !! .. Scalar Arguments .. !! integer,intent(in) :: incx,n !! .. !! .. Array Arguments .. !! double precision,intent(in) :: dx(*) !! .. !! !!##DEFINITION !! !! DASUM takes the sum of the absolute values. !! !!##OPTIONS !! !! N !! !! N is INTEGER !! number of elements in input vector(s) !! !! DX !! !! DX is DOUBLE PRECISION array, dimension ( 1 + ( N - 1 )*abs( INCX ) ) !! !! INCX !! !! INCX is INTEGER !! storage spacing between elements of DX !! !!##AUTHORS !! !! + Univ. of Tennessee !! + Univ. of California Berkeley !! + Univ. of Colorado Denver !! + NAG Ltd. !! !! date:November 2017 !! !! FURTHER DETAILS !! !! 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(*) !! !!##SEE ALSO !! Online html documentation available at !! http://www.netlib.org/lapack/explore-html/ ! ===================================================================== pure double precision function dasum(n,dx,incx) implicit none ! ! -- Reference BLAS level1 routine (version 3.8.0) -- ! -- Reference BLAS is a software package provided by Univ. of Tennessee, -- ! -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- ! November 2017 ! ! .. Scalar Arguments .. integer,intent(in) :: incx,n ! .. ! .. Array Arguments .. double precision,intent(in) :: dx(*) ! .. ! ! ===================================================================== ! ! .. Local Scalars .. double precision dtemp integer i,m,mp1,nincx ! .. ! .. Intrinsic Functions .. intrinsic dabs,mod ! .. dasum = 0.0d0 dtemp = 0.0d0 if (n.le.0 .or. incx.le.0) return if (incx.eq.1) then ! code for increment equal to 1 ! ! ! clean-up loop ! m = mod(n,6) if (m.ne.0) then do i = 1,m dtemp = dtemp + dabs(dx(i)) enddo if (n.lt.6) then dasum = dtemp return endif endif mp1 = m + 1 do i = mp1,n,6 dtemp = dtemp + dabs(dx(i)) + dabs(dx(i+1)) + dabs(dx(i+2)) + dabs(dx(i+3)) + dabs(dx(i+4)) + dabs(dx(i+5)) enddo else ! ! code for increment not equal to 1 ! nincx = n*incx do i = 1,nincx,incx dtemp = dtemp + dabs(dx(i)) enddo endif dasum = dtemp end function dasum !> !!##NAME !! daxpy(3f) - [BLAS:DOUBLE_BLAS_LEVEL1] constant times a vector plus a vector. !! !!##SYNOPSIS !! !! subroutine daxpy(n,da,dx,incx,dy,incy) !! !! .. Scalar Arguments .. !! double precision,intent(in) :: da !! integer,intent(in) :: incx,incy,n !! .. !! .. Array Arguments .. !! double precision,intent(in) :: dx(*) !! double precision,intent(inout) :: dy(*) !! .. !! !!##DEFINITION !! !! DAXPY constant times a vector plus a vector. !! uses unrolled loops for increments equal to one. !! !!##OPTIONS !! !! N !! !! N is INTEGER !! number of elements in input vector(s) !! !! DA !! !! DA is DOUBLE PRECISION !! On entry, DA specifies the scalar alpha. !! !! DX !! !! DX is DOUBLE PRECISION array, dimension ( 1 + ( N - 1 )*abs( INCX ) ) !! !! INCX !! !! INCX is INTEGER !! storage spacing between elements of DX !! !! DY !! !! DY is DOUBLE PRECISION array, dimension ( 1 + ( N - 1 )*abs( INCY ) ) !! !! INCY !! !! INCY is INTEGER !! storage spacing between elements of DY !! !!##AUTHORS !! !! + Univ. of Tennessee !! + Univ. of California Berkeley !! + Univ. of Colorado Denver !! + NAG Ltd. !! !! date:November 2017 !! !! FURTHER DETAILS !! !! jack dongarra, linpack, 3/11/78. !! modified 12/3/93, array(1) declarations changed to array(*) !! !!##SEE ALSO !! Online html documentation available at !! http://www.netlib.org/lapack/explore-html/ ! ===================================================================== subroutine daxpy(n,da,dx,incx,dy,incy) implicit none ! ! -- Reference BLAS level1 routine (version 3.8.0) -- ! -- Reference BLAS is a software package provided by Univ. of Tennessee, -- ! -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- ! November 2017 ! ! .. Scalar Arguments .. double precision,intent(in) :: da integer,intent(in) :: incx,incy,n ! .. ! .. Array Arguments .. double precision,intent(in) :: dx(*) double precision,intent(inout) :: dy(*) ! .. ! ! ===================================================================== ! ! .. Local Scalars .. integer i,ix,iy,m,mp1 ! .. ! .. Intrinsic Functions .. intrinsic mod ! .. if (n.le.0) return if (da.eq.0.0d0) return if (incx.eq.1 .and. incy.eq.1) then ! ! code for both increments equal to 1 ! ! ! clean-up loop ! m = mod(n,4) if (m.ne.0) then do i = 1,m dy(i) = dy(i) + da*dx(i) enddo endif if (n.lt.4) return mp1 = m + 1 do i = mp1,n,4 dy(i) = dy(i) + da*dx(i) dy(i+1) = dy(i+1) + da*dx(i+1) dy(i+2) = dy(i+2) + da*dx(i+2) dy(i+3) = dy(i+3) + da*dx(i+3) enddo else ! ! code for unequal increments or equal increments ! not equal to 1 ! ix = 1 iy = 1 if (incx.lt.0) ix = (-n+1)*incx + 1 if (incy.lt.0) iy = (-n+1)*incy + 1 do i = 1,n dy(iy) = dy(iy) + da*dx(ix) ix = ix + incx iy = iy + incy enddo endif end subroutine daxpy !> !!##NAME !! dcabs1(3f) - [BLAS:DOUBLE_BLAS_LEVEL1] DCABS1 computes !! |Re(.)| + |Im(.)| of a double complex number !! !!##SYNOPSIS !! !! double precision function dcabs1(z) !! !! .. Scalar Arguments .. !! complex(kind=real64),intent(in) :: Z !! .. !! !!##DEFINITION !! !! DCABS1 computes |Re(.)| + |Im(.)| of a double complex number !! !!##OPTIONS !! !! Z !! !! Z is complex(kind=real64) !! !!##AUTHORS !! !! + Univ. of Tennessee !! + Univ. of California Berkeley !! + Univ. of Colorado Denver !! + NAG Ltd. !! !! date:November 2017 !! !!##SEE ALSO !! Online html documentation available at !! http://www.netlib.org/lapack/explore-html/ ! ===================================================================== pure double precision function dcabs1(z) implicit none ! ! -- Reference BLAS level1 routine (version 3.8.0) -- ! -- Reference BLAS is a software package provided by Univ. of Tennessee, -- ! -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- ! November 2017 ! ! .. Scalar Arguments .. complex(kind=real64),intent(in) :: z ! .. ! ===================================================================== ! ! .. Intrinsic Functions .. intrinsic abs,dble,dimag ! dcabs1 = abs(dble(z)) + abs(dimag(z)) end function dcabs1 !> !!##NAME !! dcopy(3f) - [BLAS:DOUBLE_BLAS_LEVEL1] copies elements of a vector, !! x, to a vector, y. !! !!##SYNOPSIS !! !! subroutine dcopy(n,dx,incx,dy,incy) !! !! .. Scalar Arguments .. !! integer,intent(in) :: incx,incy,n !! .. !! .. Array Arguments .. !! double precision,intent(in) :: dx(*) !! double precision,intent(out) :: dy(*) !! .. !! !!##DEFINITION !! !! DCOPY copies a vector, x, to a vector, y. !! uses unrolled loops for increments equal to 1. !! !!##OPTIONS !! !! N !! !! N is INTEGER !! number of elements in input vector(s) !! !! DX !! !! DX is DOUBLE PRECISION array, dimension ( 1 + ( N - 1 )*abs( INCX ) ) !! !! INCX !! !! INCX is INTEGER !! storage spacing between elements of DX !! !! DY !! !! DY is DOUBLE PRECISION array, dimension ( 1 + ( N - 1 )*abs( INCY ) ) !! !! INCY !! !! INCY is INTEGER !! storage spacing between elements of DY !! !!##AUTHORS !! !! + Univ. of Tennessee !! + Univ. of California Berkeley !! + Univ. of Colorado Denver !! + NAG Ltd. !! !! date:November 2017 !! !! FURTHER DETAILS !! !! jack dongarra, linpack, 3/11/78. !! modified 12/3/93, array(1) declarations changed to array(*) !! !!##SEE ALSO !! Online html documentation available at !! http://www.netlib.org/lapack/explore-html/ ! ===================================================================== subroutine dcopy(n,dx,incx,dy,incy) implicit none ! ! -- Reference BLAS level1 routine (version 3.8.0) -- ! -- Reference BLAS is a software package provided by Univ. of Tennessee, -- ! -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- ! November 2017 ! ! .. Scalar Arguments .. integer,intent(in) :: incx,incy,n ! .. ! .. Array Arguments .. double precision,intent(in) :: dx(*) double precision,intent(out) :: dy(*) ! .. ! ! ===================================================================== ! ! .. Local Scalars .. integer i,ix,iy,m,mp1 ! .. ! .. Intrinsic Functions .. intrinsic mod ! .. if (n.le.0) return if (incx.eq.1 .and. incy.eq.1) then ! ! code for both increments equal to 1 ! ! ! clean-up loop ! m = mod(n,7) if (m.ne.0) then do i = 1,m dy(i) = dx(i) enddo if (n.lt.7) return endif mp1 = m + 1 do i = mp1,n,7 dy(i) = dx(i) dy(i+1) = dx(i+1) dy(i+2) = dx(i+2) dy(i+3) = dx(i+3) dy(i+4) = dx(i+4) dy(i+5) = dx(i+5) dy(i+6) = dx(i+6) enddo else ! ! code for unequal increments or equal increments ! not equal to 1 ! ix = 1 iy = 1 if (incx.lt.0) ix = (-n+1)*incx + 1 if (incy.lt.0) iy = (-n+1)*incy + 1 do i = 1,n dy(iy) = dx(ix) ix = ix + incx iy = iy + incy enddo endif end subroutine dcopy !> !!##NAME !! ddot(3f) - [BLAS:DOUBLE_BLAS_LEVEL1] forms the dot product of two vectors. !! !!##SYNOPSIS !! !! double precision function ddot(n,dx,incx,dy,incy) !! !! .. Scalar Arguments .. !! integer,intent(in) :: incx,incy,n !! .. !! .. Array Arguments .. !! double precision,intent(in) :: dx(*),dy(*) !! .. !! !!##DEFINITION !! !! DDOT forms the dot product of two vectors. !! uses unrolled loops for increments equal to one. !! !!##OPTIONS !! !! N !! !! N is INTEGER !! number of elements in input vector(s) !! !! DX !! !! DX is DOUBLE PRECISION array, dimension ( 1 + ( N - 1 )*abs( INCX ) ) !! !! INCX !! !! INCX is INTEGER !! storage spacing between elements of DX !! !! DY !! !! DY is DOUBLE PRECISION array, dimension ( 1 + ( N - 1 )*abs( INCY ) ) !! !! INCY !! !! INCY is INTEGER !! storage spacing between elements of DY !! !!##AUTHORS !! !! + Univ. of Tennessee !! + Univ. of California Berkeley !! + Univ. of Colorado Denver !! + NAG Ltd. !! !! date:November 2017 !! !! FURTHER DETAILS !! !! jack dongarra, linpack, 3/11/78. !! modified 12/3/93, array(1) declarations changed to array(*) !! !!##SEE ALSO !! Online html documentation available at !! http://www.netlib.org/lapack/explore-html/ ! ===================================================================== pure double precision function ddot(n,dx,incx,dy,incy) implicit none ! ! -- Reference BLAS level1 routine (version 3.8.0) -- ! -- Reference BLAS is a software package provided by Univ. of Tennessee, -- ! -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- ! November 2017 ! ! .. Scalar Arguments .. integer,intent(in) :: incx,incy,n ! .. ! .. Array Arguments .. double precision,intent(in) :: dx(*),dy(*) ! .. ! ! ===================================================================== ! ! .. Local Scalars .. double precision dtemp integer i,ix,iy,m,mp1 ! .. ! .. Intrinsic Functions .. intrinsic mod ! .. ddot = 0.0d0 dtemp = 0.0d0 if (n.le.0) return if (incx.eq.1 .and. incy.eq.1) then ! ! code for both increments equal to 1 ! ! ! clean-up loop ! m = mod(n,5) if (m.ne.0) then do i = 1,m dtemp = dtemp + dx(i)*dy(i) enddo if (n.lt.5) then ddot=dtemp return endif endif mp1 = m + 1 do i = mp1,n,5 dtemp = dtemp + dx(i)*dy(i) + dx(i+1)*dy(i+1) + dx(i+2)*dy(i+2) + dx(i+3)*dy(i+3) + dx(i+4)*dy(i+4) enddo else ! ! code for unequal increments or equal increments ! not equal to 1 ! ix = 1 iy = 1 if (incx.lt.0) ix = (-n+1)*incx + 1 if (incy.lt.0) iy = (-n+1)*incy + 1 do i = 1,n dtemp = dtemp + dx(ix)*dy(iy) ix = ix + incx iy = iy + incy enddo endif ddot = dtemp end function ddot !> !!##NAME !! dgbmv(3f) - [BLAS:DOUBLE_BLAS_LEVEL2] !! !!##SYNOPSIS !! !! subroutine dgbmv(trans,m,n,kl,ku,alpha,a,lda,x,incx,beta,y,incy) !! !! .. Scalar Arguments .. !! double precision,intent(in) :: alpha,beta !! integer,intent(in) :: incx,incy,kl,ku,lda,m,n !! character,intent(in) :: trans !! .. !! .. Array Arguments .. !! double precision,intent(in) :: a(lda,*),x(*) !! double precision,intent(inout) :: y(*) !! .. !! !!##DEFINITION !! !! DGBMV performs one of the matrix-vector operations !! !! y := alpha*A*x + beta*y, or y := alpha*A**T*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. !! !!##OPTIONS !! !! TRANS !! !! TRANS is 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**T*x + beta*y. !! !! TRANS = 'C' or 'c' y := alpha*A**T*x + beta*y. !! !! M !! !! M is INTEGER !! On entry, M specifies the number of rows of the matrix A. !! M must be at least zero. !! !! N !! !! N is INTEGER !! On entry, N specifies the number of columns of the matrix A. !! N must be at least zero. !! !! KL !! !! KL is INTEGER !! On entry, KL specifies the number of sub-diagonals of the !! matrix A. KL must satisfy 0 .le. KL. !! !! KU !! !! KU is INTEGER !! On entry, KU specifies the number of super-diagonals of the !! matrix A. KU must satisfy 0 .le. KU. !! !! ALPHA !! !! ALPHA is DOUBLE PRECISION. !! On entry, ALPHA specifies the scalar alpha. !! !! A !! !! A is DOUBLE PRECISION array, 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 !! !! LDA !! !! LDA is 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 ). !! !! X !! !! X is DOUBLE PRECISION array, 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. !! !! INCX !! !! INCX is INTEGER !! On entry, INCX specifies the increment for the elements of !! X. INCX must not be zero. !! !! BETA !! !! BETA is DOUBLE PRECISION. !! On entry, BETA specifies the scalar beta. When BETA is !! supplied as zero then Y need not be set on input. !! !! Y !! !! Y is DOUBLE PRECISION array, 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 !! !! INCY is INTEGER !! On entry, INCY specifies the increment for the elements of !! Y. INCY must not be zero. !! !!##AUTHORS !! !! + Univ. of Tennessee !! + Univ. of California Berkeley !! + Univ. of Colorado Denver !! + NAG Ltd. !! !! date:December 2016 !! !! FURTHER DETAILS !! !! Level 2 Blas routine. !! The vector and matrix arguments are not referenced when N = 0, or M = 0 !! !! -- 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. !! !!##SEE ALSO !! Online html documentation available at !! http://www.netlib.org/lapack/explore-html/ ! ===================================================================== subroutine dgbmv(trans,m,n,kl,ku,alpha,a,lda,x,incx,beta,y,incy) implicit none ! ! -- Reference BLAS level2 routine (version 3.7.0) -- ! -- Reference BLAS is a software package provided by Univ. of Tennessee, -- ! -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- ! December 2016 ! ! .. Scalar Arguments .. double precision,intent(in) :: alpha,beta integer,intent(in) :: incx,incy,kl,ku,lda,m,n character,intent(in) :: trans ! .. ! .. Array Arguments .. double precision,intent(in) :: a(lda,*),x(*) double precision,intent(inout) :: y(*) ! .. ! ! ===================================================================== ! ! .. Parameters .. double precision one,zero parameter (one=1.0d+0,zero=0.0d+0) ! .. ! .. Local Scalars .. double precision temp integer i,info,ix,iy,j,jx,jy,k,kup1,kx,ky,lenx,leny ! .. ! .. External Functions .. ! .. ! .. External Subroutines .. ! .. ! .. Intrinsic Functions .. intrinsic max,min ! .. ! ! Test the input parameters. ! info = 0 if (.not.lsame(trans,'N') .and. .not.lsame(trans,'T') .and. .not.lsame(trans,'C')) then info = 1 elseif (m.lt.0) then info = 2 elseif (n.lt.0) then info = 3 elseif (kl.lt.0) then info = 4 elseif (ku.lt.0) then info = 5 elseif (lda.lt. (kl+ku+1)) then info = 8 elseif (incx.eq.0) then info = 10 elseif (incy.eq.0) then info = 13 endif if (info.ne.0) then call xerbla('DGBMV ',info) return endif ! ! Quick return if possible. ! if ((m.eq.0) .or. (n.eq.0) .or. ((alpha.eq.zero).and. (beta.eq.one))) return ! ! Set LENX and LENY, the lengths of the vectors x and y, and set ! up the start points in X and Y. ! if (lsame(trans,'N')) then lenx = n leny = m else lenx = m leny = n endif if (incx.gt.0) then kx = 1 else kx = 1 - (lenx-1)*incx endif if (incy.gt.0) then ky = 1 else ky = 1 - (leny-1)*incy endif ! ! 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.ne.one) then if (incy.eq.1) then if (beta.eq.zero) then y(1:leny) = zero else y(1:leny) = beta*y(1:leny) endif else iy = ky if (beta.eq.zero) then do i = 1,leny y(iy) = zero iy = iy + incy enddo else do i = 1,leny y(iy) = beta*y(iy) iy = iy + incy enddo endif endif endif if (alpha.eq.zero) return kup1 = ku + 1 if (lsame(trans,'N')) then ! ! Form y := alpha*A*x + y. ! jx = kx if (incy.eq.1) then do j = 1,n temp = alpha*x(jx) k = kup1 - j do i = max(1,j-ku),min(m,j+kl) y(i) = y(i) + temp*a(k+i,j) enddo jx = jx + incx enddo else do j = 1,n temp = alpha*x(jx) iy = ky k = kup1 - j do i = max(1,j-ku),min(m,j+kl) y(iy) = y(iy) + temp*a(k+i,j) iy = iy + incy enddo jx = jx + incx if (j.gt.ku) ky = ky + incy enddo endif else ! ! Form y := alpha*A**T*x + y. ! jy = ky if (incx.eq.1) then do j = 1,n temp = zero k = kup1 - j do i = max(1,j-ku),min(m,j+kl) temp = temp + a(k+i,j)*x(i) enddo y(jy) = y(jy) + alpha*temp jy = jy + incy enddo else do j = 1,n temp = zero ix = kx k = kup1 - j do i = max(1,j-ku),min(m,j+kl) temp = temp + a(k+i,j)*x(ix) ix = ix + incx enddo y(jy) = y(jy) + alpha*temp jy = jy + incy if (j.gt.ku) kx = kx + incx enddo endif endif ! end subroutine dgbmv !> !!##NAME !! dgemm(3f) - [BLAS:DOUBLE_BLAS_LEVEL3] !! !!##SYNOPSIS !! !! subroutine dgemm(transa,transb,m,n,k,alpha,a,lda,b,ldb,beta,c,ldc) !! !! .. Scalar Arguments .. !! DOUBLE PRECISION,intent(in) :: ALPHA,BETA !! integer,intent(in) :: k,lda,ldb,ldc,m,n !! character,intent(in) :: transa,transb !! .. !! .. Array Arguments .. !! double precision,intent(in) :: a(lda,*),b(ldb,*) !! double precision,intent(inout) :: c(ldc,*) !! .. !! !!##DEFINITION !! !! 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**T, !! !! 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. !! !!##OPTIONS !! !! TRANSA !! !! TRANSA is 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**T. !! !! TRANSA = 'C' or 'c', op( A ) = A**T. !! !! TRANSB !! !! TRANSB is 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**T. !! !! TRANSB = 'C' or 'c', op( B ) = B**T. !! !! M !! !! M is 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. !! !! N !! !! N is 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. !! !! K !! !! K is 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. !! !! ALPHA !! !! ALPHA is DOUBLE PRECISION. !! On entry, ALPHA specifies the scalar alpha. !! !! A !! !! A is DOUBLE PRECISION array, 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. !! !! LDA !! !! LDA is 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 ). !! !! B !! !! B is DOUBLE PRECISION array, 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. !! !! LDB !! !! LDB is 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 ). !! !! BETA !! !! BETA is DOUBLE PRECISION. !! On entry, BETA specifies the scalar beta. When BETA is !! supplied as zero then C need not be set on input. !! !! C !! !! C is DOUBLE PRECISION array, 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 !! !! LDC is 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 ). !! !!##AUTHORS !! !! + Univ. of Tennessee !! + Univ. of California Berkeley !! + Univ. of Colorado Denver !! + NAG Ltd. !! !! date:December 2016 !! !! FURTHER DETAILS !! !! 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. !! !!##SEE ALSO !! Online html documentation available at !! http://www.netlib.org/lapack/explore-html/ ! ===================================================================== subroutine dgemm(transa,transb,m,n,k,alpha,a,lda,b,ldb,beta,c,ldc) implicit none ! ! -- Reference BLAS level3 routine (version 3.7.0) -- ! -- Reference BLAS is a software package provided by Univ. of Tennessee, -- ! -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- ! December 2016 ! ! .. Scalar Arguments .. double precision,intent(in) :: alpha,beta integer,intent(in) :: k,lda,ldb,ldc,m,n character,intent(in) :: transa,transb ! .. ! .. Array Arguments .. double precision,intent(in) :: a(lda,*),b(ldb,*) double precision,intent(inout) :: c(ldc,*) ! .. ! ! ===================================================================== ! ! .. External Functions .. ! .. ! .. External Subroutines .. ! .. ! .. Intrinsic Functions .. intrinsic max ! .. ! .. Local Scalars .. double precision temp integer i,info,j,l,nrowa,nrowb logical nota,notb ! .. ! .. Parameters .. double precision one,zero parameter (one=1.0d+0,zero=0.0d+0) ! .. ! ! Set NOTA and NOTB as true if A and B respectively are not ! transposed and set NROWA and NROWB as the number of rows of A ! and B respectively. ! nota = lsame(transa,'N') notb = lsame(transb,'N') if (nota) then nrowa = m else nrowa = k endif if (notb) then nrowb = k else nrowb = n endif ! ! Test the input parameters. ! info = 0 if ((.not.nota) .and. (.not.lsame(transa,'C')) .and. (.not.lsame(transa,'T'))) then info = 1 else if ((.not.notb) .and. (.not.lsame(transb,'C')) .and. (.not.lsame(transb,'T'))) then info = 2 else if (m.lt.0) then info = 3 else if (n.lt.0) then info = 4 else if (k.lt.0) then info = 5 else if (lda.lt.max(1,nrowa)) then info = 8 else if (ldb.lt.max(1,nrowb)) then info = 10 else if (ldc.lt.max(1,m)) then info = 13 endif if (info.ne.0) then call xerbla('DGEMM ',info) return endif ! ! Quick return if possible. ! if ((m.eq.0) .or. (n.eq.0) .or. (((alpha.eq.zero).or. (k.eq.0)).and. (beta.eq.one))) return ! ! And if alpha.eq.zero. ! if (alpha.eq.zero) then if (beta.eq.zero) then do j = 1,n c(1:m,j) = zero enddo else do j = 1,n c(1:m,j) = beta*c(1:m,j) enddo endif return endif ! ! Start the operations. ! if (notb) then if (nota) then ! ! Form C := alpha*A*B + beta*C. ! do j = 1,n if (beta.eq.zero) then c(1:m,j) = zero else if (beta.ne.one) then c(1:m,j) = beta*c(1:m,j) endif do l = 1,k temp = alpha*b(l,j) do i = 1,m c(i,j) = c(i,j) + temp*a(i,l) enddo enddo enddo else ! ! Form C := alpha*A**T*B + beta*C ! do j = 1,n do i = 1,m temp = zero do l = 1,k temp = temp + a(l,i)*b(l,j) enddo if (beta.eq.zero) then c(i,j) = alpha*temp else c(i,j) = alpha*temp + beta*c(i,j) endif enddo enddo endif else if (nota) then ! ! Form C := alpha*A*B**T + beta*C ! do j = 1,n if (beta.eq.zero) then do i = 1,m c(i,j) = zero enddo else if (beta.ne.one) then do i = 1,m c(i,j) = beta*c(i,j) enddo endif do l = 1,k temp = alpha*b(j,l) do i = 1,m c(i,j) = c(i,j) + temp*a(i,l) enddo enddo enddo else ! ! Form C := alpha*A**T*B**T + beta*C ! do j = 1,n do i = 1,m temp = zero do l = 1,k temp = temp + a(l,i)*b(j,l) enddo if (beta.eq.zero) then c(i,j) = alpha*temp else c(i,j) = alpha*temp + beta*c(i,j) endif enddo enddo endif endif ! end subroutine dgemm !> !!##NAME !! dgemv(3f) - [BLAS:DOUBLE_BLAS_LEVEL2] !! !!##SYNOPSIS !! !! subroutine dgemv(trans,m,n,alpha,a,lda,x,incx,beta,y,incy) !! !! .. Scalar Arguments .. !! double precision,intent(in) :: alpha,beta !! integer,intent(in) :: incx,incy,lda,m,n !! character,intent(in) :: trans !! .. !! .. Array Arguments .. !! double precision,intent(in) :: a(lda,*),x(*) !! double precision,intent(inout) :: y(*) !! .. !! !!##DEFINITION !! !! DGEMV performs one of the matrix-vector operations !! !! y := alpha*A*x + beta*y, or y := alpha*A**T*x + beta*y, !! !! where alpha and beta are scalars, x and y are vectors and A is an !! m by n matrix. !! !!##OPTIONS !! !! TRANS !! !! TRANS is 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**T*x + beta*y. !! !! TRANS = 'C' or 'c' y := alpha*A**T*x + beta*y. !! !! M !! !! M is INTEGER !! On entry, M specifies the number of rows of the matrix A. !! M must be at least zero. !! !! N !! !! N is INTEGER !! On entry, N specifies the number of columns of the matrix A. !! N must be at least zero. !! !! ALPHA !! !! ALPHA is DOUBLE PRECISION. !! On entry, ALPHA specifies the scalar alpha. !! !! A !! !! A is DOUBLE PRECISION array, dimension ( LDA, N ) !! Before entry, the leading m by n part of the array A must !! contain the matrix of coefficients. !! !! LDA !! !! LDA is 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 ). !! !! X !! !! X is DOUBLE PRECISION array, 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. !! !! INCX !! !! INCX is INTEGER !! On entry, INCX specifies the increment for the elements of !! X. INCX must not be zero. !! !! BETA !! !! BETA is DOUBLE PRECISION. !! On entry, BETA specifies the scalar beta. When BETA is !! supplied as zero then Y need not be set on input. !! !! Y !! !! Y is DOUBLE PRECISION array, 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 !! !! INCY is INTEGER !! On entry, INCY specifies the increment for the elements of !! Y. INCY must not be zero. !! !!##AUTHORS !! !! + Univ. of Tennessee !! + Univ. of California Berkeley !! + Univ. of Colorado Denver !! + NAG Ltd. !! !! date:December 2016 !! !! FURTHER DETAILS !! !! Level 2 Blas routine. !! The vector and matrix arguments are not referenced when N = 0, or M = 0 !! !! -- 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. !! !!##SEE ALSO !! Online html documentation available at !! http://www.netlib.org/lapack/explore-html/ ! ===================================================================== subroutine dgemv(trans,m,n,alpha,a,lda,x,incx,beta,y,incy) implicit none ! ! -- Reference BLAS level2 routine (version 3.7.0) -- ! -- Reference BLAS is a software package provided by Univ. of Tennessee, -- ! -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- ! December 2016 ! ! .. Scalar Arguments .. double precision,intent(in) :: alpha,beta integer,intent(in) :: incx,incy,lda,m,n character,intent(in) :: trans ! .. ! .. Array Arguments .. double precision,intent(in) :: a(lda,*),x(*) double precision,intent(inout) :: y(*) ! .. ! ! ===================================================================== ! ! .. Parameters .. double precision one,zero parameter (one=1.0d+0,zero=0.0d+0) ! .. ! .. Local Scalars .. double precision temp integer i,info,ix,iy,j,jx,jy,kx,ky,lenx,leny ! .. ! .. External Functions .. ! .. ! .. External Subroutines .. ! .. ! .. Intrinsic Functions .. intrinsic max ! .. ! ! Test the input parameters. ! info = 0 if (.not.lsame(trans,'N') .and. .not.lsame(trans,'T') .and. .not.lsame(trans,'C')) then info = 1 else if (m.lt.0) then info = 2 else if (n.lt.0) then info = 3 else if (lda.lt.max(1,m)) then info = 6 else if (incx.eq.0) then info = 8 else if (incy.eq.0) then info = 11 endif if (info.ne.0) then call xerbla('DGEMV ',info) return endif ! ! Quick return if possible. ! if ((m.eq.0) .or. (n.eq.0) .or. ((alpha.eq.zero).and. (beta.eq.one))) return ! ! Set LENX and LENY, the lengths of the vectors x and y, and set ! up the start points in X and Y. ! if (lsame(trans,'N')) then lenx = n leny = m else lenx = m leny = n endif if (incx.gt.0) then kx = 1 else kx = 1 - (lenx-1)*incx endif if (incy.gt.0) then ky = 1 else ky = 1 - (leny-1)*incy endif ! ! Start the operations. In this version the elements of A are ! accessed sequentially with one pass through A. ! ! First form y := beta*y. ! if (beta.ne.one) then if (incy.eq.1) then if (beta.eq.zero) then y(1:leny) = zero else y(1:leny) = beta*y(1:leny) endif else iy = ky if (beta.eq.zero) then do i = 1,leny y(iy) = zero iy = iy + incy enddo else do i = 1,leny y(iy) = beta*y(iy) iy = iy + incy enddo endif endif endif if (alpha.eq.zero) return if (lsame(trans,'N')) then ! ! Form y := alpha*A*x + y. ! jx = kx if (incy.eq.1) then do j = 1,n temp = alpha*x(jx) y(1:m) = y(1:m) + temp*a(1:m,j) jx = jx + incx enddo else do j = 1,n temp = alpha*x(jx) iy = ky do i = 1,m y(iy) = y(iy) + temp*a(i,j) iy = iy + incy enddo jx = jx + incx enddo endif else ! ! Form y := alpha*A**T*x + y. ! jy = ky if (incx.eq.1) then do j = 1,n temp = zero do i = 1,m temp = temp + a(i,j)*x(i) enddo y(jy) = y(jy) + alpha*temp jy = jy + incy enddo else do j = 1,n temp = zero ix = kx do i = 1,m temp = temp + a(i,j)*x(ix) ix = ix + incx enddo y(jy) = y(jy) + alpha*temp jy = jy + incy enddo endif endif ! end subroutine dgemv !> !!##NAME !! dger(3f) - [BLAS:DOUBLE_BLAS_LEVEL2] !! !!##SYNOPSIS !! !! subroutine dger(m,n,alpha,x,incx,y,incy,a,lda) !! !! .. Scalar Arguments .. !! double precision,intent(in) :: alpha !! integer,intent(in) :: incx,incy,lda,m,n !! .. !! .. Array Arguments .. !! double precision,intent(in) :: x(*),y(*) !! double precision,intent(inout) :: a(lda,*) !! .. !! !!##DEFINITION !! !! DGER performs the rank 1 operation !! !! A := alpha*x*y**T + 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. !! !!##OPTIONS !! !! M !! !! M is INTEGER !! On entry, M specifies the number of rows of the matrix A. !! M must be at least zero. !! !! N !! !! N is INTEGER !! On entry, N specifies the number of columns of the matrix A. !! N must be at least zero. !! !! ALPHA !! !! ALPHA is DOUBLE PRECISION. !! On entry, ALPHA specifies the scalar alpha. !! !! X !! !! X is DOUBLE PRECISION array, dimension at least !! ( 1 + ( m - 1 )*abs( INCX ) ). !! Before entry, the incremented array X must contain the m !! element vector x. !! !! INCX !! !! INCX is INTEGER !! On entry, INCX specifies the increment for the elements of !! X. INCX must not be zero. !! !! Y !! !! Y is DOUBLE PRECISION array, dimension at least !! ( 1 + ( n - 1 )*abs( INCY ) ). !! Before entry, the incremented array Y must contain the n !! element vector y. !! !! INCY !! !! INCY is INTEGER !! On entry, INCY specifies the increment for the elements of !! Y. INCY must not be zero. !! !! A !! !! A is DOUBLE PRECISION array, 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 !! !! LDA is 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 ). !! !!##AUTHORS !! !! + Univ. of Tennessee !! + Univ. of California Berkeley !! + Univ. of Colorado Denver !! + NAG Ltd. !! !! date:December 2016 !! !! FURTHER DETAILS !! !! 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. !! !!##SEE ALSO !! Online html documentation available at !! http://www.netlib.org/lapack/explore-html/ ! ===================================================================== subroutine dger(m,n,alpha,x,incx,y,incy,a,lda) implicit none ! ! -- Reference BLAS level2 routine (version 3.7.0) -- ! -- Reference BLAS is a software package provided by Univ. of Tennessee, -- ! -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- ! December 2016 ! ! .. Scalar Arguments .. double precision,intent(in) :: alpha integer,intent(in) :: incx,incy,lda,m,n ! .. ! .. Array Arguments .. double precision,intent(in) :: x(*),y(*) double precision,intent(inout) :: a(lda,*) ! .. ! ! ===================================================================== ! ! .. Parameters .. double precision zero parameter (zero=0.0d+0) ! .. ! .. Local Scalars .. double precision temp integer i,info,ix,j,jy,kx ! .. ! .. External Subroutines .. ! .. ! .. Intrinsic Functions .. intrinsic max ! .. ! ! Test the input parameters. ! info = 0 if (m.lt.0) then info = 1 elseif (n.lt.0) then info = 2 elseif (incx.eq.0) then info = 5 elseif (incy.eq.0) then info = 7 elseif (lda.lt.max(1,m)) then info = 9 endif if (info.ne.0) then call xerbla('DGER ',info) return endif ! ! Quick return if possible. ! if ((m.eq.0) .or. (n.eq.0) .or. (alpha.eq.zero)) return ! ! Start the operations. In this version the elements of A are ! accessed sequentially with one pass through A. ! if (incy.gt.0) then jy = 1 else jy = 1 - (n-1)*incy endif if (incx.eq.1) then do j = 1,n if (y(jy).ne.zero) then temp = alpha*y(jy) do i = 1,m a(i,j) = a(i,j) + x(i)*temp enddo endif jy = jy + incy enddo else if (incx.gt.0) then kx = 1 else kx = 1 - (m-1)*incx endif do j = 1,n if (y(jy).ne.zero) then temp = alpha*y(jy) ix = kx do i = 1,m a(i,j) = a(i,j) + x(ix)*temp ix = ix + incx enddo endif jy = jy + incy enddo endif ! end subroutine dger !> !!##NAME !! dnrm2(3f) - [BLAS:SINGLE_BLAS_LEVEL1] returns the euclidean norm of !! a vector via the function name !! !!##SYNOPSIS !! !! double precision function dnrm2(n,x,incx) !! !! .. Scalar Arguments .. !! integer,intent(in) :: incx, n !! .. !! .. Array Arguments .. !! real(wp),intent(in) :: x(*) !! .. !! !!##DEFINITION !! !! DNRM2 returns the euclidean norm of a vector via the function !! name, so that !! !! DNRM2 := sqrt( x'*x ) !! !!##OPTIONS !! N !! number of elements in input vector(s) !! X !! X is DOUBLE PRECISION array, dimension ( 1 + ( N - 1 )*abs( INCX ) ) !! INCX !! INCX is INTEGER, storage spacing between elements of X !! !! If INCX > 0, X(1+(i-1)*INCX) = x(i) for 1 <= i <= n !! If INCX < 0, X(1-(n-i)*INCX) = x(i) for 1 <= i <= n !! If INCX = 0, x isn't a vector so there is no need to call !! this subroutine. If you call it anyway, it will count x(1) !! in the vector norm N times. !! !!##AUTHORS !! !! + Edward Anderson, Lockheed Martin !! !! date:August 2016 !! !! \par Contributors: !! !! Weslley Pereira, University of Colorado Denver, USA !! !! FURTHER DETAILS !! !! Anderson E. (2017) !! Algorithm 978: Safe Scaling in the Level 1 BLAS !! ACM Trans Math Softw 44:1--28 !! https://doi.org/10.1145/3061665 !! !! Blue, James L. (1978) !! A Portable Fortran Program to Find the Euclidean Norm of a Vector !! ACM Trans Math Softw 4:15--23 !! https://doi.org/10.1145/355769.355771 !! !!##SEE ALSO !! Online html documentation available at !! http://www.netlib.org/lapack/explore-html/ ! ===================================================================== pure function dnrm2( n, x, incx ) integer, parameter :: wp = kind(1.d0) real(wp) :: dnrm2 ! ! -- Reference BLAS level1 routine (version 3.9.1) -- ! -- Reference BLAS is a software package provided by Univ. of Tennessee, -- ! -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- ! March 2021 ! ! .. Constants .. real(wp), parameter :: zero = 0.0_wp real(wp), parameter :: one = 1.0_wp real(wp), parameter :: maxn = huge(0.0_wp) ! .. ! .. Blue's scaling constants .. real(wp), parameter :: tsml = real(radix(0._wp), wp)**ceiling( (minexponent(0._wp) - 1) * 0.5_wp) real(wp), parameter :: tbig = real(radix(0._wp), wp)**floor( (maxexponent(0._wp) - digits(0._wp) + 1) * 0.5_wp) real(wp), parameter :: ssml = real(radix(0._wp), wp)**( - floor( (minexponent(0._wp) - 1) * 0.5_wp)) real(wp), parameter :: sbig = real(radix(0._wp), wp)**( - ceiling( (maxexponent(0._wp) - digits(0._wp) + 1) * 0.5_wp)) ! .. ! .. Scalar Arguments .. integer,intent(in) :: incx, n ! .. ! .. Array Arguments .. real(wp),intent(in) :: x(*) ! .. ! .. Local Scalars .. integer :: i, ix logical :: notbig real(wp) :: abig, amed, asml, ax, scl, sumsq, ymax, ymin ! ! Quick return if possible ! dnrm2 = zero if( n <= 0 ) return ! scl = one sumsq = zero ! ! Compute the sum of squares in 3 accumulators: ! abig -- sums of squares scaled down to avoid overflow ! asml -- sums of squares scaled up to avoid underflow ! amed -- sums of squares that do not require scaling ! The thresholds and multipliers are ! tbig -- values bigger than this are scaled down by sbig ! tsml -- values smaller than this are scaled up by ssml ! notbig = .true. asml = zero amed = zero abig = zero ix = 1 if( incx < 0 ) ix = 1 - (n-1)*incx do i = 1, n ax = abs(x(ix)) if (ax > tbig) then abig = abig + (ax*sbig)**2 notbig = .false. elseif (ax < tsml) then if (notbig) asml = asml + (ax*ssml)**2 else amed = amed + ax**2 endif ix = ix + incx enddo ! ! Combine abig and amed or amed and asml if more than one ! accumulator was used. ! if (abig > zero) then ! ! Combine abig and amed if abig > 0. ! if ( (amed > zero) .or. (amed > maxn) .or. (amed /= amed) ) then abig = abig + (amed*sbig)*sbig endif scl = one / sbig sumsq = abig elseif (asml > zero) then ! ! Combine amed and asml if asml > 0. ! if ( (amed > zero) .or. (amed > maxn) .or. (amed /= amed) ) then amed = sqrt(amed) asml = sqrt(asml) / ssml if (asml > amed) then ymin = amed ymax = asml else ymin = asml ymax = amed endif scl = one sumsq = ymax**2*( one + (ymin/ymax)**2 ) else scl = one / ssml sumsq = asml endif else ! ! Otherwise all values are mid-range ! scl = one sumsq = amed endif dnrm2 = scl*sqrt( sumsq ) return end function !> !!##NAME !! drot(3f) - [BLAS:SINGLE_BLAS_LEVEL1] DROT applies a plane rotation. !! !!##SYNOPSIS !! !! subroutine drot(n,dx,incx,dy,incy,c,s) applies a plane rotation. !! !! .. Scalar Arguments .. !! double precision,intent(in) :: c,s !! integer,intent(in) :: incx,incy,n !! .. !! .. Array Arguments .. !! double precision,intent(inout) :: dx(*),dy(*) !! .. !! !!##DEFINITION !! !! DROT applies a plane rotation. !! !!##OPTIONS !! !! N !! number of elements in input vector(s) !! DX !! array, dimension ( 1 + ( N - 1 )*abs( INCX ) ) !! INCX !! !! storage spacing between elements of DX !! !! DY !! DY is DOUBLE PRECISION array, dimension ( 1 + ( N - 1 )*abs( INCY ) ) !! INCY !! storage spacing between elements of DY !! C !! S !! !!##AUTHORS !! !! + Univ. of Tennessee !! + Univ. of California Berkeley !! + Univ. of Colorado Denver !! + NAG Ltd. !! !! date:November 2017 !! !! \ingroup double_blas_level1 !! !! FURTHER DETAILS !! !! jack dongarra, linpack, 3/11/78. !! modified 12/3/93, array(1) declarations changed to array(*) !! !!##SEE ALSO !! Online html documentation available at !! http://www.netlib.org/lapack/explore-html/ ! ===================================================================== subroutine drot(n,dx,incx,dy,incy,c,s) implicit none ! ! -- Reference BLAS level1 routine (version 3.8.0) -- ! -- Reference BLAS is a software package provided by Univ. of Tennessee, -- ! -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- ! November 2017 ! ! .. Scalar Arguments .. double precision,intent(in) :: c,s integer,intent(in) :: incx,incy,n ! .. ! .. Array Arguments .. double precision,intent(inout) :: dx(*),dy(*) ! .. ! ! ===================================================================== ! ! .. Local Scalars .. double precision dtemp integer i,ix,iy ! .. if (n.le.0) return if (incx.eq.1 .and. incy.eq.1) then ! ! code for both increments equal to 1 ! do i = 1,n dtemp = c*dx(i) + s*dy(i) dy(i) = c*dy(i) - s*dx(i) dx(i) = dtemp enddo else ! ! code for unequal increments or equal increments not equal ! to 1 ! ix = 1 iy = 1 if (incx.lt.0) ix = (-n+1)*incx + 1 if (incy.lt.0) iy = (-n+1)*incy + 1 do i = 1,n dtemp = c*dx(ix) + s*dy(iy) dy(iy) = c*dy(iy) - s*dx(ix) dx(ix) = dtemp ix = ix + incx iy = iy + incy enddo endif end subroutine drot !> !!##NAME !! drotg(3f) - [BLAS:SINGLE_BLAS_LEVEL1] constructs a plane rotation !! !!##SYNOPSIS !! !! subroutine DROTG( a, b, c, s ) !! !! .. Scalar Arguments .. !! real(wp),intent(inout) :: a, b !! real(wp),intent(out) :: c, s !! !!##DEFINITION !! DROTG constructs a plane rotation !! !! [ c s ] [ a ] = [ r ] !! [ -s c ] [ b ] [ 0 ] !! !! satisfying c**2 + s**2 = 1. !! !! The computation uses the formulas !! !! sigma = sgn(a) if |a| > |b| !! = sgn(b) if |b| >= |a| !! r = sigma*sqrt( a**2 + b**2 ) !! c = 1; s = 0 if r = 0 !! c = a/r; s = b/r if r != 0 !! !! The subroutine also computes !! !! z = s if |a| > |b|, !! = 1/c if |b| >= |a| and c != 0 !! = 1 if c = 0 !! !! This allows c and s to be reconstructed from z as follows: !! !! If z = 1, set c = 0, s = 1. !! If |z| < 1, set c = sqrt(1 - z**2) and s = z. !! If |z| > 1, set c = 1/z and s = sqrt( 1 - c**2). !! !!##OPTIONS !! !! A !! On entry, the scalar a. !! On exit, the scalar r. !! !! B !! On entry, the scalar b. !! On exit, the scalar z. !! !! C !! The scalar c. !! !! S !! The scalar s. !! !!##AUTHORS !! !! + Edward Anderson, Lockheed Martin !! !! \par Contributors: !! !! Weslley Pereira, University of Colorado Denver, USA !! !! \ingroup single_blas_level1 !! !! FURTHER DETAILS !! !! Anderson E. (2017) !! Algorithm 978: Safe Scaling in the Level 1 BLAS !! ACM Trans Math Softw 44:1--28 !! https://doi.org/10.1145/3061665 !! !!##SEE ALSO !! Online html documentation available at !! http://www.netlib.org/lapack/explore-html/ ! ===================================================================== subroutine drotg( a, b, c, s ) integer, parameter :: wp = kind(1.d0) ! ! -- Reference BLAS level1 routine -- ! -- Reference BLAS is a software package provided by Univ. of Tennessee, -- ! -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- ! ! .. Constants .. real(wp), parameter :: zero = 0.0_wp real(wp), parameter :: one = 1.0_wp ! .. ! .. Scaling constants .. real(wp), parameter :: safmin = real(radix(0.0_wp),wp)**max( minexponent(0.0_wp)-1, 1-maxexponent(0.0_wp) ) real(wp), parameter :: safmax = real(radix(0.0_wp),wp)**max( 1-minexponent(0.0_wp), maxexponent(0.0_wp)-1 ) ! .. ! .. Scalar Arguments .. real(wp),intent(inout) :: a, b real(wp),intent(out) :: c, s ! .. ! .. Local Scalars .. real(wp) :: anorm, bnorm, scl, sigma, r, z ! .. anorm = abs(a) bnorm = abs(b) if( bnorm == zero ) then c = one s = zero b = zero elseif ( anorm == zero ) then c = zero s = one a = b b = one else scl = min( safmax, max( safmin, anorm, bnorm ) ) if( anorm > bnorm ) then sigma = sign(one,a) else sigma = sign(one,b) endif r = sigma*( scl*sqrt((a/scl)**2 + (b/scl)**2) ) c = a/r s = b/r if( anorm > bnorm ) then z = s elseif ( c /= zero ) then z = one/c else z = one endif a = r b = z endif return end subroutine !> !!##NAME !! drotm(3f) - [BLAS:SINGLE_BLAS_LEVEL1] Apply the Modified Givens !! Transformation, H, to the 2 by N matrix !! !!##SYNOPSIS !! !! subroutine drotm(n,dx,incx,dy,incy,dparam) !! !! .. Scalar Arguments .. !! integer,intent(in) :: incx,incy,n !! .. !! .. Array Arguments .. !! double precision,intent(in) :: dparam(5) !! double precision,intent(inout) :: dx(*),dy(*) !! .. !! !!##DEFINITION !! !! 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. !! !!##OPTIONS !! N !! number of elements in input vector(s) !! DX !! DX is DOUBLE PRECISION array, dimension ( 1 + ( N - 1 )*abs( INCX ) ) !! !! INCX !! storage spacing between elements of DX !! !! DY !! DY is DOUBLE PRECISION array, dimension ( 1 + ( N - 1 )*abs( INCY ) ) !! INCY !! storage spacing between elements of DY !! !! DPARAM !! array, dimension (5) !! !! DPARAM(1)=DFLAG !! DPARAM(2)=DH11 !! DPARAM(3)=DH21 !! DPARAM(4)=DH12 !! DPARAM(5)=DH22 !! !!##AUTHORS !! !! + Univ. of Tennessee !! + Univ. of California Berkeley !! + Univ. of Colorado Denver !! + NAG Ltd. !! !! date:November 2017 !! !! \ingroup double_blas_level1 !! !!##SEE ALSO !! Online html documentation available at !! http://www.netlib.org/lapack/explore-html/ ! ===================================================================== subroutine drotm(n,dx,incx,dy,incy,dparam) implicit none ! ! -- Reference BLAS level1 routine (version 3.8.0) -- ! -- Reference BLAS is a software package provided by Univ. of Tennessee, -- ! -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- ! November 2017 ! ! .. Scalar Arguments .. integer,intent(in) :: incx,incy,n ! .. ! .. Array Arguments .. double precision,intent(in) :: dparam(5) double precision,intent(inout) :: dx(*),dy(*) ! .. ! ! ===================================================================== ! ! .. Local Scalars .. double precision dflag,dh11,dh12,dh21,dh22,w,z integer i,kx,ky,nsteps ! .. doubleprecision,parameter :: zero=0.0d0 doubleprecision,parameter :: two=2.0d0 ! .. ! dflag = dparam(1) if (n.le.0 .or. (dflag+two.eq.zero)) return if (incx.eq.incy.and.incx.gt.0) then ! nsteps = n*incx if (dflag.lt.zero) then dh11 = dparam(2) dh12 = dparam(4) dh21 = dparam(3) dh22 = dparam(5) do i = 1,nsteps,incx w = dx(i) z = dy(i) dx(i) = w*dh11 + z*dh12 dy(i) = w*dh21 + z*dh22 enddo elseif (dflag.eq.zero) then dh12 = dparam(4) dh21 = dparam(3) do i = 1,nsteps,incx w = dx(i) z = dy(i) dx(i) = w + z*dh12 dy(i) = w*dh21 + z enddo else dh11 = dparam(2) dh22 = dparam(5) do i = 1,nsteps,incx w = dx(i) z = dy(i) dx(i) = w*dh11 + z dy(i) = -w + dh22*z enddo endif else kx = 1 ky = 1 if (incx.lt.0) kx = 1 + (1-n)*incx if (incy.lt.0) ky = 1 + (1-n)*incy ! if (dflag.lt.zero) then dh11 = dparam(2) dh12 = dparam(4) dh21 = dparam(3) dh22 = dparam(5) do i = 1,n w = dx(kx) z = dy(ky) dx(kx) = w*dh11 + z*dh12 dy(ky) = w*dh21 + z*dh22 kx = kx + incx ky = ky + incy enddo elseif (dflag.eq.zero) then dh12 = dparam(4) dh21 = dparam(3) do i = 1,n w = dx(kx) z = dy(ky) dx(kx) = w + z*dh12 dy(ky) = w*dh21 + z kx = kx + incx ky = ky + incy enddo else dh11 = dparam(2) dh22 = dparam(5) do i = 1,n w = dx(kx) z = dy(ky) dx(kx) = w*dh11 + z dy(ky) = -w + dh22*z kx = kx + incx ky = ky + incy enddo endif endif end subroutine drotm !> !!##NAME !! drotmg(3f) - [BLAS:DOUBLE_BLAS_LEVEL1] !! !!##SYNOPSIS !! !! subroutine drotmg(dd1,dd2,dx1,dy1,dparam) !! !! .. Scalar Arguments .. !! double precision,intent(inout) :: dd1,dd2,dx1 !! double precision,intent(in) :: dy1 !! .. !! .. Array Arguments .. !! double precision,intent(out) :: dparam(5) !! .. !! !!##DEFINITION !! !! 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. !! !!##OPTIONS !! !! DD1 !! !! DD1 is DOUBLE PRECISION !! !! DD2 !! !! DD2 is DOUBLE PRECISION !! !! DX1 !! !! DX1 is DOUBLE PRECISION !! !! DY1 !! !! DY1 is DOUBLE PRECISION !! !! DPARAM !! !! DPARAM is DOUBLE PRECISION array, dimension (5) !! DPARAM(1)=DFLAG !! DPARAM(2)=DH11 !! DPARAM(3)=DH21 !! DPARAM(4)=DH12 !! DPARAM(5)=DH22 !! !!##AUTHORS !! !! + Univ. of Tennessee !! + Univ. of California Berkeley !! + Univ. of Colorado Denver !! + NAG Ltd. !! !! date:November 2017 !! !!##SEE ALSO !! Online html documentation available at !! http://www.netlib.org/lapack/explore-html/ ! ===================================================================== subroutine drotmg(dd1,dd2,dx1,dy1,dparam) implicit none ! ! -- Reference BLAS level1 routine (version 3.8.0) -- ! -- Reference BLAS is a software package provided by Univ. of Tennessee, -- ! -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- ! November 2017 ! ! .. Scalar Arguments .. double precision,intent(inout) :: dd1,dd2,dx1 double precision,intent(in) :: dy1 ! .. ! .. Array Arguments .. double precision,intent(out) :: dparam(5) ! .. ! ! ===================================================================== ! ! .. Local Scalars .. double precision dflag,dh11,dh12,dh21,dh22,dp1,dp2,dq1,dq2,dtemp, du ! .. ! .. Intrinsic Functions .. intrinsic dabs ! .. ! .. Data statements .. ! doubleprecision,parameter :: zero=0.0d0 doubleprecision,parameter :: one=1.0d0 doubleprecision,parameter :: two=2.0d0 doubleprecision,parameter :: gam=4096.d0 doubleprecision,parameter :: gamsq=16777216.d0 doubleprecision,parameter :: rgamsq=5.9604645d-8 ! .. if (dd1.lt.zero) then ! GO ZERO-H-D-AND-DX1.. dflag = -one dh11 = zero dh12 = zero dh21 = zero dh22 = zero ! dd1 = zero dd2 = zero dx1 = zero else ! CASE-DD1-NONNEGATIVE dp2 = dd2*dy1 if (dp2.eq.zero) then dflag = -two dparam(1) = dflag return endif ! REGULAR-CASE.. dp1 = dd1*dx1 dq2 = dp2*dy1 dq1 = dp1*dx1 ! if (dabs(dq1).gt.dabs(dq2)) then dh21 = -dy1/dx1 dh12 = dp2/dp1 ! du = one - dh12*dh21 ! if (du.gt.zero) then dflag = zero dd1 = dd1/du dd2 = dd2/du dx1 = dx1*du else ! This code path if here for safety. We do not expect this ! condition to ever hold except in edge cases with rounding ! errors. See DOI: 10.1145/355841.355847 dflag = -one dh11 = zero dh12 = zero dh21 = zero dh22 = zero ! dd1 = zero dd2 = zero dx1 = zero endif else if (dq2.lt.zero) then ! GO ZERO-H-D-AND-DX1.. dflag = -one dh11 = zero dh12 = zero dh21 = zero dh22 = zero ! dd1 = zero dd2 = zero dx1 = zero else dflag = one dh11 = dp1/dp2 dh22 = dx1/dy1 du = one + dh11*dh22 dtemp = dd2/du dd2 = dd1/du dd1 = dtemp dx1 = dy1*du endif endif ! PROCEDURE..SCALE-CHECK if (dd1.ne.zero) then do while ((dd1.le.rgamsq) .or. (dd1.ge.gamsq)) if (dflag.eq.zero) then dh11 = one dh22 = one dflag = -one else dh21 = -one dh12 = one dflag = -one endif if (dd1.le.rgamsq) then dd1 = dd1*gam**2 dx1 = dx1/gam dh11 = dh11/gam dh12 = dh12/gam else dd1 = dd1/gam**2 dx1 = dx1*gam dh11 = dh11*gam dh12 = dh12*gam endif enddo endif if (dd2.ne.zero) then do while ( (dabs(dd2).le.rgamsq) .or. (dabs(dd2).ge.gamsq) ) if (dflag.eq.zero) then dh11 = one dh22 = one dflag = -one else dh21 = -one dh12 = one dflag = -one endif if (dabs(dd2).le.rgamsq) then dd2 = dd2*gam**2 dh21 = dh21/gam dh22 = dh22/gam else dd2 = dd2/gam**2 dh21 = dh21*gam dh22 = dh22*gam endif enddo endif endif if (dflag.lt.zero) then dparam(2) = dh11 dparam(3) = dh21 dparam(4) = dh12 dparam(5) = dh22 elseif (dflag.eq.zero) then dparam(3) = dh21 dparam(4) = dh12 else dparam(2) = dh11 dparam(5) = dh22 endif dparam(1) = dflag end subroutine drotmg !> !!##NAME !! dsbmv(3f) - [BLAS:DOUBLE_BLAS_LEVEL2] !! !!##SYNOPSIS !! !! subroutine dsbmv(uplo,n,k,alpha,a,lda,x,incx,beta,y,incy) !! !! .. Scalar Arguments .. !! double precision,intent(in) :: alpha,beta !! integer,intent(in) :: incx,incy,k,lda,n !! character,intent(in) :: uplo !! .. !! .. Array Arguments .. !! double precision,intent(in) :: a(lda,*),x(*) !! double precision,intent(inout) :: y(*) !! .. !! !!##DEFINITION !! !! 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. !! !!##OPTIONS !! !! UPLO !! !! UPLO is 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. !! !! N !! !! N is INTEGER !! On entry, N specifies the order of the matrix A. !! N must be at least zero. !! !! K !! !! K is INTEGER !! On entry, K specifies the number of super-diagonals of the !! matrix A. K must satisfy 0 .le. K. !! !! ALPHA !! !! ALPHA is DOUBLE PRECISION. !! On entry, ALPHA specifies the scalar alpha. !! !! A !! !! A is DOUBLE PRECISION array, 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 !! !! LDA !! !! LDA is INTEGER !! On entry, LDA specifies the first dimension of A as declared !! in the calling (sub) program. LDA must be at least !! ( k + 1 ). !! !! X !! !! X is DOUBLE PRECISION array, dimension at least !! ( 1 + ( n - 1 )*abs( INCX ) ). !! Before entry, the incremented array X must contain the !! vector x. !! !! INCX !! !! INCX is INTEGER !! On entry, INCX specifies the increment for the elements of !! X. INCX must not be zero. !! !! BETA !! !! BETA is DOUBLE PRECISION. !! On entry, BETA specifies the scalar beta. !! !! Y !! !! Y is DOUBLE PRECISION array, 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 !! !! INCY is INTEGER !! On entry, INCY specifies the increment for the elements of !! Y. INCY must not be zero. !! !!##AUTHORS !! !! + Univ. of Tennessee !! + Univ. of California Berkeley !! + Univ. of Colorado Denver !! + NAG Ltd. !! !! date:December 2016 !! !! FURTHER DETAILS !! !! Level 2 Blas routine. !! The vector and matrix arguments are not referenced when N = 0, or M = 0 !! !! -- 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. !! !!##SEE ALSO !! Online html documentation available at !! http://www.netlib.org/lapack/explore-html/ ! ===================================================================== subroutine dsbmv(uplo,n,k,alpha,a,lda,x,incx,beta,y,incy) implicit none ! ! -- Reference BLAS level2 routine (version 3.7.0) -- ! -- Reference BLAS is a software package provided by Univ. of Tennessee, -- ! -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- ! December 2016 ! ! .. Scalar Arguments .. double precision,intent(in) :: alpha,beta integer,intent(in) :: incx,incy,k,lda,n character,intent(in) :: uplo ! .. ! .. Array Arguments .. double precision,intent(in) :: a(lda,*),x(*) double precision,intent(inout) :: y(*) ! .. ! ! ===================================================================== ! ! .. Parameters .. double precision one,zero parameter (one=1.0d+0,zero=0.0d+0) ! .. ! .. Local Scalars .. double precision temp1,temp2 integer i,info,ix,iy,j,jx,jy,kplus1,kx,ky,l ! .. ! .. External Functions .. ! .. ! .. External Subroutines .. ! .. ! .. Intrinsic Functions .. intrinsic max,min ! .. ! ! Test the input parameters. ! info = 0 if (.not.lsame(uplo,'U') .and. .not.lsame(uplo,'L')) then info = 1 elseif (n.lt.0) then info = 2 elseif (k.lt.0) then info = 3 elseif (lda.lt. (k+1)) then info = 6 elseif (incx.eq.0) then info = 8 elseif (incy.eq.0) then info = 11 endif if (info.ne.0) then call xerbla('DSBMV ',info) return endif ! ! Quick return if possible. ! if ((n.eq.0) .or. ((alpha.eq.zero).and. (beta.eq.one))) return ! ! Set up the start points in X and Y. ! if (incx.gt.0) then kx = 1 else kx = 1 - (n-1)*incx endif if (incy.gt.0) then ky = 1 else ky = 1 - (n-1)*incy endif ! ! 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.ne.one) then if (incy.eq.1) then if (beta.eq.zero) then y(1:n) = zero else y(1:n) = beta*y(1:n) endif else iy = ky if (beta.eq.zero) then do i = 1,n y(iy) = zero iy = iy + incy enddo else do i = 1,n y(iy) = beta*y(iy) iy = iy + incy enddo endif endif endif if (alpha.eq.zero) return if (lsame(uplo,'U')) then ! ! Form y when upper triangle of A is stored. ! kplus1 = k + 1 if ((incx.eq.1) .and. (incy.eq.1)) then do j = 1,n temp1 = alpha*x(j) temp2 = zero l = kplus1 - j do i = max(1,j-k),j - 1 y(i) = y(i) + temp1*a(l+i,j) temp2 = temp2 + a(l+i,j)*x(i) enddo y(j) = y(j) + temp1*a(kplus1,j) + alpha*temp2 enddo else jx = kx jy = ky do j = 1,n temp1 = alpha*x(jx) temp2 = zero ix = kx iy = ky l = kplus1 - j do i = max(1,j-k),j - 1 y(iy) = y(iy) + temp1*a(l+i,j) temp2 = temp2 + a(l+i,j)*x(ix) ix = ix + incx iy = iy + incy enddo y(jy) = y(jy) + temp1*a(kplus1,j) + alpha*temp2 jx = jx + incx jy = jy + incy if (j.gt.k) then kx = kx + incx ky = ky + incy endif enddo endif else ! ! Form y when lower triangle of A is stored. ! if ((incx.eq.1) .and. (incy.eq.1)) then do j = 1,n temp1 = alpha*x(j) temp2 = zero y(j) = y(j) + temp1*a(1,j) l = 1 - j do i = j + 1,min(n,j+k) y(i) = y(i) + temp1*a(l+i,j) temp2 = temp2 + a(l+i,j)*x(i) enddo y(j) = y(j) + alpha*temp2 enddo else jx = kx jy = ky do j = 1,n temp1 = alpha*x(jx) temp2 = zero y(jy) = y(jy) + temp1*a(1,j) l = 1 - j ix = jx iy = jy do i = j + 1,min(n,j+k) ix = ix + incx iy = iy + incy y(iy) = y(iy) + temp1*a(l+i,j) temp2 = temp2 + a(l+i,j)*x(ix) enddo y(jy) = y(jy) + alpha*temp2 jx = jx + incx jy = jy + incy enddo endif endif ! end subroutine dsbmv !> !!##NAME !! dscal(3f) - [BLAS:DOUBLE_BLAS_LEVEL1] scales a vector by a constant. !! !!##SYNOPSIS !! !! subroutine dscal(n,da,dx,incx) !! !! .. Scalar Arguments .. !! double precision,intent(in) :: da !! integer,intent(in) :: incx,n !! .. !! .. Array Arguments .. !! double precision,intent(inout) :: dx(*) !! .. !! !!##DEFINITION !! !! DSCAL scales a vector by a constant. !! uses unrolled loops for increment equal to 1. !! !!##OPTIONS !! N !! number of elements in input vector(s) !! DA !! On entry, DA specifies the scalar alpha. !! DX !! array, dimension ( 1 + ( N - 1 )*abs( INCX ) ) !! INCX !! storage spacing between elements of DX !! !!##AUTHORS !! !! + Univ. of Tennessee !! + Univ. of California Berkeley !! + Univ. of Colorado Denver !! + NAG Ltd. !! !! date:November 2017 !! !! FURTHER DETAILS !! !! 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(*) !! !!##SEE ALSO !! Online html documentation available at !! http://www.netlib.org/lapack/explore-html/ ! ===================================================================== subroutine dscal(n,da,dx,incx) implicit none ! ! -- Reference BLAS level1 routine (version 3.8.0) -- ! -- Reference BLAS is a software package provided by Univ. of Tennessee, -- ! -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- ! November 2017 ! ! .. Scalar Arguments .. double precision,intent(in) :: da integer,intent(in) :: incx,n ! .. ! .. Array Arguments .. double precision,intent(inout) :: dx(*) ! .. ! ===================================================================== ! .. Local Scalars .. integer i,m,mp1,nincx ! .. ! .. Intrinsic Functions .. intrinsic mod ! .. if (n.le.0 .or. incx.le.0) return if (incx.eq.1) then ! ! code for increment equal to 1 ! ! ! clean-up loop ! m = mod(n,5) if (m.ne.0) then do i = 1,m dx(i) = da*dx(i) enddo if (n.lt.5) return endif mp1 = m + 1 do i = mp1,n,5 dx(i) = da*dx(i) dx(i+1) = da*dx(i+1) dx(i+2) = da*dx(i+2) dx(i+3) = da*dx(i+3) dx(i+4) = da*dx(i+4) enddo else ! ! code for increment not equal to 1 ! nincx = n*incx do i = 1,nincx,incx dx(i) = da*dx(i) enddo endif end subroutine dscal !> !!##NAME !! dsdot(3f) - [BLAS:DOUBLE_BLAS_LEVEL1] !! !!##SYNOPSIS !! !! double precision function dsdot(n,sx,incx,sy,incy) !! !! .. Scalar Arguments .. !! integer,intent(in) :: incx,incy,n !! .. !! .. Array Arguments .. !! real,intent(in) :: sx(*),sy(*) !! .. !! !! !!##DEFINITION !! !! 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. !! !!##OPTIONS !! !! N number of elements in input vector(s) !! SX array, dimension(N) !! single precision vector with N elements !! INCX storage spacing between elements of SX !! SY array, dimension(N) !! single precision vector with N elements !! INCY storage spacing between elements of SY !! !!##RETURN !! !! DSDOT dot product (zero if N.LE.0) !! !!##AUTHORS !! !! + Univ. of Tennessee !! + Univ. of California Berkeley !! + Univ. of Colorado Denver !! + NAG Ltd. !! !! date:December 2016 !! !! FURTHER DETAILS !! !! Lawson, C. L., (JPL), Hanson, R. J., (SNLA), !! Kincaid, D. R., (U. of Texas), Krogh, F. T., (JPL) !! !! 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 !! !! 1979-10-01 DATE WRITTEN !! 1989-08-31 Modified array declarations. (WRB) !! 1989-08-31 REVISION DATE from Version 3.2 !! 1989-12-14 Prologue converted to Version 4.0 format. (BAB) !! 1992-03-10 Corrected definition of LX in DESCRIPTION. (WRB) !! 1992-05-01 Reformatted the REFERENCES section. (WRB) !! 1907-01-18 Reformat to LAPACK style (JL) !! !!##SEE ALSO !! Online html documentation available at !! http://www.netlib.org/lapack/explore-html/ ! ===================================================================== pure double precision function dsdot(n,sx,incx,sy,incy) implicit none ! ! -- Reference BLAS level1 routine (version 3.7.0) -- ! -- Reference BLAS is a software package provided by Univ. of Tennessee, -- ! -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- ! December 2016 ! ! .. Scalar Arguments .. integer,intent(in) :: incx,incy,n ! .. ! .. Array Arguments .. real,intent(in) :: sx(*),sy(*) ! .. ! ! Authors: ! ======== ! Lawson, C. L., (JPL), Hanson, R. J., (SNLA), ! Kincaid, D. R., (U. of Texas), Krogh, F. T., (JPL) ! ===================================================================== ! ! .. Local Scalars .. integer i,kx,ky,ns ! .. ! .. Intrinsic Functions .. intrinsic dble ! .. dsdot = 0.0d0 if (n.le.0) return if (incx.eq.incy .and. incx.gt.0) then ! ! Code for equal, positive, non-unit increments. ! ns = n*incx do i = 1,ns,incx dsdot = dsdot + dble(sx(i))*dble(sy(i)) enddo else ! ! Code for unequal or nonpositive increments. ! kx = 1 ky = 1 if (incx.lt.0) kx = 1 + (1-n)*incx if (incy.lt.0) ky = 1 + (1-n)*incy do i = 1,n dsdot = dsdot + dble(sx(kx))*dble(sy(ky)) kx = kx + incx ky = ky + incy enddo endif end function dsdot !> !!##NAME !! dspmv(3f) - [BLAS:DOUBLE_BLAS_LEVEL2] !! !!##SYNOPSIS !! !! subroutine dspmv(uplo,n,alpha,ap,x,incx,beta,y,incy) !! !! .. Scalar Arguments .. !! double precision,intent(in) :: alpha,beta !! integer,intent(in) :: incx,incy,n !! character,intent(in) :: uplo !! .. !! .. Array Arguments .. !! double precision,intent(in) :: ap(*),x(*) !! double precision,intent(inout) :: y(*) !! .. !! !!##DEFINITION !! !! 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. !! !!##OPTIONS !! !! UPLO !! !! UPLO is 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. !! !! N !! !! N is INTEGER !! On entry, N specifies the order of the matrix A. !! N must be at least zero. !! !! ALPHA !! !! ALPHA is DOUBLE PRECISION. !! On entry, ALPHA specifies the scalar alpha. !! !! AP !! !! AP is DOUBLE PRECISION array, 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. !! !! X !! !! X is DOUBLE PRECISION array, dimension at least !! ( 1 + ( n - 1 )*abs( INCX ) ). !! Before entry, the incremented array X must contain the n !! element vector x. !! !! INCX !! !! INCX is INTEGER !! On entry, INCX specifies the increment for the elements of !! X. INCX must not be zero. !! !! BETA !! !! BETA is DOUBLE PRECISION. !! On entry, BETA specifies the scalar beta. When BETA is !! supplied as zero then Y need not be set on input. !! !! Y !! !! Y is DOUBLE PRECISION array, 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 !! !! INCY is INTEGER !! On entry, INCY specifies the increment for the elements of !! Y. INCY must not be zero. !! !!##AUTHORS !! !! + Univ. of Tennessee !! + Univ. of California Berkeley !! + Univ. of Colorado Denver !! + NAG Ltd. !! !! date:December 2016 !! !! FURTHER DETAILS !! !! Level 2 Blas routine. !! The vector and matrix arguments are not referenced when N = 0, or M = 0 !! !! -- 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. !! !!##SEE ALSO !! Online html documentation available at !! http://www.netlib.org/lapack/explore-html/ ! ===================================================================== subroutine dspmv(uplo,n,alpha,ap,x,incx,beta,y,incy) implicit none ! ! -- Reference BLAS level2 routine (version 3.7.0) -- ! -- Reference BLAS is a software package provided by Univ. of Tennessee, -- ! -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- ! December 2016 ! ! .. Scalar Arguments .. double precision,intent(in) :: alpha,beta integer,intent(in) :: incx,incy,n character,intent(in) :: uplo ! .. ! .. Array Arguments .. double precision,intent(in) :: ap(*),x(*) double precision,intent(inout) :: y(*) ! .. ! ! ===================================================================== ! ! .. Parameters .. double precision one,zero parameter (one=1.0d+0,zero=0.0d+0) ! .. ! .. Local Scalars .. double precision temp1,temp2 integer i,info,ix,iy,j,jx,jy,k,kk,kx,ky ! .. ! .. External Functions .. ! .. ! .. External Subroutines .. ! .. ! ! Test the input parameters. ! info = 0 if (.not.lsame(uplo,'U') .and. .not.lsame(uplo,'L')) then info = 1 elseif (n.lt.0) then info = 2 elseif (incx.eq.0) then info = 6 elseif (incy.eq.0) then info = 9 endif if (info.ne.0) then call xerbla('DSPMV ',info) return endif ! ! Quick return if possible. ! if ((n.eq.0) .or. ((alpha.eq.zero).and. (beta.eq.one))) return ! ! Set up the start points in X and Y. ! if (incx.gt.0) then kx = 1 else kx = 1 - (n-1)*incx endif if (incy.gt.0) then ky = 1 else ky = 1 - (n-1)*incy endif ! ! 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.ne.one) then if (incy.eq.1) then if (beta.eq.zero) then y(1:n) = zero else y(1:n) = beta*y(1:n) endif else iy = ky if (beta.eq.zero) then do i = 1,n y(iy) = zero iy = iy + incy enddo else do i = 1,n y(iy) = beta*y(iy) iy = iy + incy enddo endif endif endif if (alpha.eq.zero) return kk = 1 if (lsame(uplo,'U')) then ! ! Form y when AP contains the upper triangle. ! if ((incx.eq.1) .and. (incy.eq.1)) then do j = 1,n temp1 = alpha*x(j) temp2 = zero k = kk do i = 1,j - 1 y(i) = y(i) + temp1*ap(k) temp2 = temp2 + ap(k)*x(i) k = k + 1 enddo y(j) = y(j) + temp1*ap(kk+j-1) + alpha*temp2 kk = kk + j enddo else jx = kx jy = ky do j = 1,n temp1 = alpha*x(jx) temp2 = zero ix = kx iy = ky do k = kk,kk + j - 2 y(iy) = y(iy) + temp1*ap(k) temp2 = temp2 + ap(k)*x(ix) ix = ix + incx iy = iy + incy enddo y(jy) = y(jy) + temp1*ap(kk+j-1) + alpha*temp2 jx = jx + incx jy = jy + incy kk = kk + j enddo endif else ! ! Form y when AP contains the lower triangle. ! if ((incx.eq.1) .and. (incy.eq.1)) then do j = 1,n temp1 = alpha*x(j) temp2 = zero y(j) = y(j) + temp1*ap(kk) k = kk + 1 do i = j + 1,n y(i) = y(i) + temp1*ap(k) temp2 = temp2 + ap(k)*x(i) k = k + 1 enddo y(j) = y(j) + alpha*temp2 kk = kk + (n-j+1) enddo else jx = kx jy = ky do j = 1,n temp1 = alpha*x(jx) temp2 = zero y(jy) = y(jy) + temp1*ap(kk) ix = jx iy = jy do k = kk + 1,kk + n - j ix = ix + incx iy = iy + incy y(iy) = y(iy) + temp1*ap(k) temp2 = temp2 + ap(k)*x(ix) enddo y(jy) = y(jy) + alpha*temp2 jx = jx + incx jy = jy + incy kk = kk + (n-j+1) enddo endif endif ! end subroutine dspmv !> !!##NAME !! dspr2(3f) - [BLAS:DOUBLE_BLAS_LEVEL2] !! !!##SYNOPSIS !! !! subroutine dspr2(uplo,n,alpha,x,incx,y,incy,ap) !! !! .. Scalar Arguments .. !! double precision,intent(in) :: alpha !! integer,intent(in) :: incx,incy,n !! character,intent(in) :: uplo !! .. !! .. Array Arguments .. !! double precision,intent(inout) :: ap(*) !! double precision,intent(in) :: x(*),y(*) !! .. !! !!##DEFINITION !! DSPR2 performs the symmetric rank 2 operation !! !! A := alpha*x*y**T + alpha*y*x**T + 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. !! !!##OPTIONS !! !! UPLO !! !! UPLO is 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. !! !! N !! !! N is INTEGER !! On entry, N specifies the order of the matrix A. !! N must be at least zero. !! !! ALPHA !! !! ALPHA is DOUBLE PRECISION. !! On entry, ALPHA specifies the scalar alpha. !! !! X !! !! X is DOUBLE PRECISION array, dimension at least !! ( 1 + ( n - 1 )*abs( INCX ) ). !! Before entry, the incremented array X must contain the n !! element vector x. !! !! INCX !! !! INCX is INTEGER !! On entry, INCX specifies the increment for the elements of !! X. INCX must not be zero. !! !! Y !! !! Y is DOUBLE PRECISION array, dimension at least !! ( 1 + ( n - 1 )*abs( INCY ) ). !! Before entry, the incremented array Y must contain the n !! element vector y. !! !! INCY !! !! INCY is INTEGER !! On entry, INCY specifies the increment for the elements of !! Y. INCY must not be zero. !! !! AP !! !! AP is DOUBLE PRECISION array, 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. !! !!##AUTHORS !! !! + Univ. of Tennessee !! + Univ. of California Berkeley !! + Univ. of Colorado Denver !! + NAG Ltd. !! !! date:December 2016 !! !! FURTHER DETAILS !! !! 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. !! !!##SEE ALSO !! Online html documentation available at !! http://www.netlib.org/lapack/explore-html/ ! ===================================================================== subroutine dspr2(uplo,n,alpha,x,incx,y,incy,ap) implicit none ! ! -- Reference BLAS level2 routine (version 3.7.0) -- ! -- Reference BLAS is a software package provided by Univ. of Tennessee, -- ! -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- ! December 2016 ! ! .. Scalar Arguments .. double precision,intent(in) :: alpha integer,intent(in) :: incx,incy,n character,intent(in) :: uplo ! .. ! .. Array Arguments .. double precision,intent(inout) :: ap(*) double precision,intent(in) :: x(*),y(*) ! .. ! ! ===================================================================== ! ! .. Parameters .. double precision zero parameter (zero=0.0d+0) ! .. ! .. Local Scalars .. double precision temp1,temp2 integer i,info,ix,iy,j,jx,jy,k,kk,kx,ky ! .. ! .. External Functions .. ! .. ! .. External Subroutines .. ! .. ! ! Test the input parameters. ! info = 0 if (.not.lsame(uplo,'U') .and. .not.lsame(uplo,'L')) then info = 1 elseif (n.lt.0) then info = 2 elseif (incx.eq.0) then info = 5 elseif (incy.eq.0) then info = 7 endif if (info.ne.0) then call xerbla('DSPR2 ',info) return endif ! ! Quick return if possible. ! if ((n.eq.0) .or. (alpha.eq.zero)) return ! ! Set up the start points in X and Y if the increments are not both ! unity. ! if ((incx.ne.1) .or. (incy.ne.1)) then if (incx.gt.0) then kx = 1 else kx = 1 - (n-1)*incx endif if (incy.gt.0) then ky = 1 else ky = 1 - (n-1)*incy endif jx = kx jy = ky endif ! ! 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')) then ! ! Form A when upper triangle is stored in AP. ! if ((incx.eq.1) .and. (incy.eq.1)) then do j = 1,n if ((x(j).ne.zero) .or. (y(j).ne.zero)) then temp1 = alpha*y(j) temp2 = alpha*x(j) k = kk do i = 1,j ap(k) = ap(k) + x(i)*temp1 + y(i)*temp2 k = k + 1 enddo endif kk = kk + j enddo else do j = 1,n if ((x(jx).ne.zero) .or. (y(jy).ne.zero)) then temp1 = alpha*y(jy) temp2 = alpha*x(jx) ix = kx iy = ky do k = kk,kk + j - 1 ap(k) = ap(k) + x(ix)*temp1 + y(iy)*temp2 ix = ix + incx iy = iy + incy enddo endif jx = jx + incx jy = jy + incy kk = kk + j enddo endif else ! ! Form A when lower triangle is stored in AP. ! if ((incx.eq.1) .and. (incy.eq.1)) then do j = 1,n if ((x(j).ne.zero) .or. (y(j).ne.zero)) then temp1 = alpha*y(j) temp2 = alpha*x(j) k = kk do i = j,n ap(k) = ap(k) + x(i)*temp1 + y(i)*temp2 k = k + 1 enddo endif kk = kk + n - j + 1 enddo else do j = 1,n if ((x(jx).ne.zero) .or. (y(jy).ne.zero)) then temp1 = alpha*y(jy) temp2 = alpha*x(jx) ix = jx iy = jy do k = kk,kk + n - j ap(k) = ap(k) + x(ix)*temp1 + y(iy)*temp2 ix = ix + incx iy = iy + incy enddo endif jx = jx + incx jy = jy + incy kk = kk + n - j + 1 enddo endif endif ! end subroutine dspr2 !> !!##NAME !! dspr(3f) - [BLAS:DOUBLE_BLAS_LEVEL2] !! !!##SYNOPSIS !! !! subroutine dspr(uplo,n,alpha,x,incx,ap) !! !! .. Scalar Arguments .. !! double precision,intent(in) :: alpha !! integer,intent(in) :: incx,n !! character,intent(in) :: uplo !! .. !! .. Array Arguments .. !! double precision,intent(inout) :: ap(*) !! double precision,intent(in) :: x(*) !! .. !! !!##DESCRIPTION !! !! DSPR performs the symmetric rank 1 operation !! !! A := alpha*x*x**T + 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. !! !!##OPTIONS !! !! UPLO !! !! UPLO is 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. !! !! N !! !! N is INTEGER !! On entry, N specifies the order of the matrix A. !! N must be at least zero. !! !! ALPHA !! !! ALPHA is DOUBLE PRECISION. !! On entry, ALPHA specifies the scalar alpha. !! !! X !! !! X is DOUBLE PRECISION array, dimension at least !! ( 1 + ( n - 1 )*abs( INCX ) ). !! Before entry, the incremented array X must contain the n !! element vector x. !! !! INCX !! !! INCX is INTEGER !! On entry, INCX specifies the increment for the elements of !! X. INCX must not be zero. !! !! AP !! !! AP is DOUBLE PRECISION array, 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. !! !!##AUTHORS !! !! + Univ. of Tennessee !! + Univ. of California Berkeley !! + Univ. of Colorado Denver !! + NAG Ltd. !! !! date:December 2016 !! !! FURTHER DETAILS !! !! 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. !! !!##SEE ALSO !! Online html documentation available at !! http://www.netlib.org/lapack/explore-html/ ! ===================================================================== subroutine dspr(uplo,n,alpha,x,incx,ap) implicit none ! ! -- Reference BLAS level2 routine (version 3.7.0) -- ! -- Reference BLAS is a software package provided by Univ. of Tennessee, -- ! -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- ! December 2016 ! ! .. Scalar Arguments .. double precision,intent(in) :: alpha integer,intent(in) :: incx,n character,intent(in) :: uplo ! .. ! .. Array Arguments .. double precision,intent(inout) :: ap(*) double precision,intent(in) :: x(*) ! .. ! ! ===================================================================== ! ! .. Parameters .. double precision zero parameter (zero=0.0d+0) ! .. ! .. Local Scalars .. double precision temp integer i,info,ix,j,jx,k,kk,kx ! .. ! .. External Functions .. ! .. ! .. External Subroutines .. ! .. ! ! Test the input parameters. ! info = 0 if (.not.lsame(uplo,'U') .and. .not.lsame(uplo,'L')) then info = 1 elseif (n.lt.0) then info = 2 elseif (incx.eq.0) then info = 5 endif if (info.ne.0) then call xerbla('DSPR ',info) return endif ! ! Quick return if possible. ! if ((n.eq.0) .or. (alpha.eq.zero)) return ! ! Set the start point in X if the increment is not unity. ! if (incx.le.0) then kx = 1 - (n-1)*incx elseif (incx.ne.1) then kx = 1 endif ! ! 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')) then ! ! Form A when upper triangle is stored in AP. ! if (incx.eq.1) then do j = 1,n if (x(j).ne.zero) then temp = alpha*x(j) k = kk do i = 1,j ap(k) = ap(k) + x(i)*temp k = k + 1 enddo endif kk = kk + j enddo else jx = kx do j = 1,n if (x(jx).ne.zero) then temp = alpha*x(jx) ix = kx do k = kk,kk + j - 1 ap(k) = ap(k) + x(ix)*temp ix = ix + incx enddo endif jx = jx + incx kk = kk + j enddo endif else ! ! Form A when lower triangle is stored in AP. ! if (incx.eq.1) then do j = 1,n if (x(j).ne.zero) then temp = alpha*x(j) k = kk do i = j,n ap(k) = ap(k) + x(i)*temp k = k + 1 enddo endif kk = kk + n - j + 1 enddo else jx = kx do j = 1,n if (x(jx).ne.zero) then temp = alpha*x(jx) ix = jx do k = kk,kk + n - j ap(k) = ap(k) + x(ix)*temp ix = ix + incx enddo endif jx = jx + incx kk = kk + n - j + 1 enddo endif endif ! end subroutine dspr !> !!##NAME !! dswap(3f) - [BLAS:DOUBLE_BLAS_LEVEL1] interchanges two vectors. !! !!##SYNOPSIS !! !! subroutine dswap(n,dx,incx,dy,incy) !! !! .. Scalar Arguments .. !! integer,intent(in) :: incx,incy,n !! .. !! .. Array Arguments .. !! double precision,intent(inout) :: dx(*),dy(*) !! .. !! !!##DEFINITION !! !! DSWAP interchanges two vectors. !! uses unrolled loops for increments equal to 1. !! !!##OPTIONS !! !! N !! !! N is INTEGER !! number of elements in input vector(s) !! !! DX !! !! DX is DOUBLE PRECISION array, dimension ( 1 + ( N - 1 )*abs( INCX ) ) !! !! INCX !! !! INCX is INTEGER !! storage spacing between elements of DX !! !! DY !! !! DY is DOUBLE PRECISION array, dimension ( 1 + ( N - 1 )*abs( INCY ) ) !! !! INCY !! !! INCY is INTEGER !! storage spacing between elements of DY !! !!##AUTHORS !! !! + Univ. of Tennessee !! + Univ. of California Berkeley !! + Univ. of Colorado Denver !! + NAG Ltd. !! !! date:November 2017 !! !! FURTHER DETAILS !! !! jack dongarra, linpack, 3/11/78. !! modified 12/3/93, array(1) declarations changed to array(*) !! !!##SEE ALSO !! Online html documentation available at !! http://www.netlib.org/lapack/explore-html/ ! ===================================================================== subroutine dswap(n,dx,incx,dy,incy) implicit none ! ! -- Reference BLAS level1 routine (version 3.8.0) -- ! -- Reference BLAS is a software package provided by Univ. of Tennessee, -- ! -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- ! November 2017 ! ! .. Scalar Arguments .. integer,intent(in) :: incx,incy,n ! .. ! .. Array Arguments .. double precision,intent(inout) :: dx(*),dy(*) ! .. ! ! ===================================================================== ! ! .. Local Scalars .. double precision dtemp integer i,ix,iy,m,mp1 ! .. ! .. Intrinsic Functions .. intrinsic mod ! .. if (n.le.0) return if (incx.eq.1 .and. incy.eq.1) then ! ! code for both increments equal to 1 ! ! ! clean-up loop ! m = mod(n,3) if (m.ne.0) then do i = 1,m dtemp = dx(i) dx(i) = dy(i) dy(i) = dtemp enddo if (n.lt.3) return endif mp1 = m + 1 do i = mp1,n,3 dtemp = dx(i) dx(i) = dy(i) dy(i) = dtemp dtemp = dx(i+1) dx(i+1) = dy(i+1) dy(i+1) = dtemp dtemp = dx(i+2) dx(i+2) = dy(i+2) dy(i+2) = dtemp enddo else ! ! code for unequal increments or equal increments not equal ! to 1 ! ix = 1 iy = 1 if (incx.lt.0) ix = (-n+1)*incx + 1 if (incy.lt.0) iy = (-n+1)*incy + 1 do i = 1,n dtemp = dx(ix) dx(ix) = dy(iy) dy(iy) = dtemp ix = ix + incx iy = iy + incy enddo endif end subroutine dswap !> !!##NAME !! dsymm(3f) - [BLAS:DOUBLE_BLAS_LEVEL3] !! !!##SYNOPSIS !! !! subroutine dsymm(side,uplo,m,n,alpha,a,lda,b,ldb,beta,c,ldc) !! !! .. Scalar Arguments .. !! double precision,intent(in) :: alpha,beta !! integer,intent(in) :: lda,ldb,ldc,m,n !! character,intent(in) :: side,uplo !! .. !! .. Array Arguments .. !! double precision,intent(in) :: a(lda,*),b(ldb,*) !! double precision,intent(inout) :: c(ldc,*) !! .. !! !!##DEFINITION !! !! 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. !! !!##OPTIONS !! !! SIDE !! !! SIDE is 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, !! !! UPLO !! !! UPLO is 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. !! !! M !! !! M is INTEGER !! On entry, M specifies the number of rows of the matrix C. !! M must be at least zero. !! !! N !! !! N is INTEGER !! On entry, N specifies the number of columns of the matrix C. !! N must be at least zero. !! !! ALPHA !! !! ALPHA is DOUBLE PRECISION. !! On entry, ALPHA specifies the scalar alpha. !! !! A !! !! A is DOUBLE PRECISION array, 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. !! !! LDA !! !! LDA is 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 ). !! !! B !! !! B is DOUBLE PRECISION array, dimension ( LDB, N ) !! Before entry, the leading m by n part of the array B must !! contain the matrix B. !! !! LDB !! !! LDB is 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 ). !! !! BETA !! !! BETA is DOUBLE PRECISION. !! On entry, BETA specifies the scalar beta. When BETA is !! supplied as zero then C need not be set on input. !! !! C !! !! C is DOUBLE PRECISION array, 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 !! !! LDC is 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 ). !! !!##AUTHORS !! !! + Univ. of Tennessee !! + Univ. of California Berkeley !! + Univ. of Colorado Denver !! + NAG Ltd. !! !! date:December 2016 !! !! FURTHER DETAILS !! !! 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. !! !!##SEE ALSO !! Online html documentation available at !! http://www.netlib.org/lapack/explore-html/ ! ===================================================================== subroutine dsymm(side,uplo,m,n,alpha,a,lda,b,ldb,beta,c,ldc) implicit none ! ! -- Reference BLAS level3 routine (version 3.7.0) -- ! -- Reference BLAS is a software package provided by Univ. of Tennessee, -- ! -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- ! December 2016 ! ! .. Scalar Arguments .. double precision,intent(in) :: alpha,beta integer,intent(in) :: lda,ldb,ldc,m,n character,intent(in) :: side,uplo ! .. ! .. Array Arguments .. double precision,intent(in) :: a(lda,*),b(ldb,*) double precision,intent(inout) :: c(ldc,*) ! .. ! ! ===================================================================== ! ! .. External Functions .. ! .. ! .. External Subroutines .. ! .. ! .. Intrinsic Functions .. intrinsic max ! .. ! .. Local Scalars .. double precision temp1,temp2 integer i,info,j,k,nrowa logical upper ! .. ! .. Parameters .. double precision one,zero parameter (one=1.0d+0,zero=0.0d+0) ! .. ! ! Set NROWA as the number of rows of A. ! if (lsame(side,'L')) then nrowa = m else nrowa = n endif upper = lsame(uplo,'U') ! ! Test the input parameters. ! info = 0 if ((.not.lsame(side,'L')) .and. (.not.lsame(side,'R'))) then info = 1 elseif ((.not.upper) .and. (.not.lsame(uplo,'L'))) then info = 2 elseif (m.lt.0) then info = 3 elseif (n.lt.0) then info = 4 elseif (lda.lt.max(1,nrowa)) then info = 7 elseif (ldb.lt.max(1,m)) then info = 9 elseif (ldc.lt.max(1,m)) then info = 12 endif if (info.ne.0) then call xerbla('DSYMM ',info) return endif ! ! Quick return if possible. ! if ((m.eq.0) .or. (n.eq.0) .or. ((alpha.eq.zero).and. (beta.eq.one))) return ! ! And when alpha.eq.zero. ! if (alpha.eq.zero) then if (beta.eq.zero) then c(1:m,1:n) = zero else c(1:m,1:n) = beta*c(1:m,1:n) endif return endif ! ! Start the operations. ! if (lsame(side,'L')) then ! ! Form C := alpha*A*B + beta*C. ! if (upper) then do j = 1,n do i = 1,m temp1 = alpha*b(i,j) temp2 = zero do k = 1,i - 1 c(k,j) = c(k,j) + temp1*a(k,i) temp2 = temp2 + b(k,j)*a(k,i) enddo if (beta.eq.zero) then c(i,j) = temp1*a(i,i) + alpha*temp2 else c(i,j) = beta*c(i,j) + temp1*a(i,i) + alpha*temp2 endif enddo enddo else do j = 1,n do i = m,1,-1 temp1 = alpha*b(i,j) temp2 = zero do k = i + 1,m c(k,j) = c(k,j) + temp1*a(k,i) temp2 = temp2 + b(k,j)*a(k,i) enddo if (beta.eq.zero) then c(i,j) = temp1*a(i,i) + alpha*temp2 else c(i,j) = beta*c(i,j) + temp1*a(i,i) + alpha*temp2 endif enddo enddo endif else ! ! Form C := alpha*B*A + beta*C. ! do j = 1,n temp1 = alpha*a(j,j) if (beta.eq.zero) then c(1:m,j) = temp1*b(1:m,j) else c(1:m,j) = beta*c(1:m,j) + temp1*b(1:m,j) endif do k = 1,j - 1 if (upper) then temp1 = alpha*a(k,j) else temp1 = alpha*a(j,k) endif c(1:m,j) = c(1:m,j) + temp1*b(1:m,k) enddo do k = j + 1,n if (upper) then temp1 = alpha*a(j,k) else temp1 = alpha*a(k,j) endif c(1:m,j) = c(1:m,j) + temp1*b(1:m,k) enddo enddo endif ! end subroutine dsymm !> !!##NAME !! dsymv(3f) - [BLAS:DOUBLE_BLAS_LEVEL2] !! !!##SYNOPSIS !! !! subroutine dsymv(uplo,n,alpha,a,lda,x,incx,beta,y,incy) !! !! .. Scalar Arguments .. !! double precision,intent(in) :: alpha,beta !! integer,intent(in) :: incx,incy,lda,n !! character,intent(in) :: uplo !! .. !! .. Array Arguments .. !! double precision,intent(in) :: a(lda,*),x(*) !! double precision,intent(inout) :: y(*) !! .. !! !!##DEFINITION !! !! 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. !! !!##OPTIONS !! !! UPLO !! !! UPLO is 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. !! !! N !! !! N is INTEGER !! On entry, N specifies the order of the matrix A. !! N must be at least zero. !! !! ALPHA !! !! ALPHA is DOUBLE PRECISION. !! On entry, ALPHA specifies the scalar alpha. !! !! A !! !! A is DOUBLE PRECISION array, 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. !! !! LDA !! !! LDA is 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 ). !! !! X !! !! X is DOUBLE PRECISION array, dimension at least !! ( 1 + ( n - 1 )*abs( INCX ) ). !! Before entry, the incremented array X must contain the n !! element vector x. !! !! INCX !! !! INCX is INTEGER !! On entry, INCX specifies the increment for the elements of !! X. INCX must not be zero. !! !! BETA !! !! BETA is DOUBLE PRECISION. !! On entry, BETA specifies the scalar beta. When BETA is !! supplied as zero then Y need not be set on input. !! !! Y !! !! Y is DOUBLE PRECISION array, 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 !! !! INCY is INTEGER !! On entry, INCY specifies the increment for the elements of !! Y. INCY must not be zero. !! !!##AUTHORS !! !! + Univ. of Tennessee !! + Univ. of California Berkeley !! + Univ. of Colorado Denver !! + NAG Ltd. !! !! date:December 2016 !! !! FURTHER DETAILS !! !! Level 2 Blas routine. !! The vector and matrix arguments are not referenced when N = 0, or M = 0 !! !! -- 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. !! !!##SEE ALSO !! Online html documentation available at !! http://www.netlib.org/lapack/explore-html/ ! ===================================================================== subroutine dsymv(uplo,n,alpha,a,lda,x,incx,beta,y,incy) implicit none ! ! -- Reference BLAS level2 routine (version 3.7.0) -- ! -- Reference BLAS is a software package provided by Univ. of Tennessee, -- ! -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- ! December 2016 ! ! .. Scalar Arguments .. double precision,intent(in) :: alpha,beta integer,intent(in) :: incx,incy,lda,n character,intent(in) :: uplo ! .. ! .. Array Arguments .. double precision,intent(in) :: a(lda,*),x(*) double precision,intent(inout) :: y(*) ! .. ! ! ===================================================================== ! ! .. Parameters .. double precision one,zero parameter (one=1.0d+0,zero=0.0d+0) ! .. ! .. Local Scalars .. double precision temp1,temp2 integer i,info,ix,iy,j,jx,jy,kx,ky ! .. ! .. External Functions .. ! .. ! .. External Subroutines .. ! .. ! .. Intrinsic Functions .. intrinsic max ! .. ! ! Test the input parameters. ! info = 0 if (.not.lsame(uplo,'U') .and. .not.lsame(uplo,'L')) then info = 1 elseif (n.lt.0) then info = 2 elseif (lda.lt.max(1,n)) then info = 5 elseif (incx.eq.0) then info = 7 elseif (incy.eq.0) then info = 10 endif if (info.ne.0) then call xerbla('DSYMV ',info) return endif ! ! Quick return if possible. ! if ((n.eq.0) .or. ((alpha.eq.zero).and. (beta.eq.one))) return ! ! Set up the start points in X and Y. ! if (incx.gt.0) then kx = 1 else kx = 1 - (n-1)*incx endif if (incy.gt.0) then ky = 1 else ky = 1 - (n-1)*incy endif ! ! 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.ne.one) then if (incy.eq.1) then if (beta.eq.zero) then y(1:n) = zero else y(1:n) = beta*y(1:n) endif else iy = ky if (beta.eq.zero) then do i = 1,n y(iy) = zero iy = iy + incy enddo else do i = 1,n y(iy) = beta*y(iy) iy = iy + incy enddo endif endif endif if (alpha.eq.zero) return if (lsame(uplo,'U')) then ! ! Form y when A is stored in upper triangle. ! if ((incx.eq.1) .and. (incy.eq.1)) then do j = 1,n temp1 = alpha*x(j) temp2 = zero do i = 1,j - 1 y(i) = y(i) + temp1*a(i,j) temp2 = temp2 + a(i,j)*x(i) enddo y(j) = y(j) + temp1*a(j,j) + alpha*temp2 enddo else jx = kx jy = ky do j = 1,n temp1 = alpha*x(jx) temp2 = zero ix = kx iy = ky do i = 1,j - 1 y(iy) = y(iy) + temp1*a(i,j) temp2 = temp2 + a(i,j)*x(ix) ix = ix + incx iy = iy + incy enddo y(jy) = y(jy) + temp1*a(j,j) + alpha*temp2 jx = jx + incx jy = jy + incy enddo endif else ! ! Form y when A is stored in lower triangle. ! if ((incx.eq.1) .and. (incy.eq.1)) then do j = 1,n temp1 = alpha*x(j) temp2 = zero y(j) = y(j) + temp1*a(j,j) do i = j + 1,n y(i) = y(i) + temp1*a(i,j) temp2 = temp2 + a(i,j)*x(i) enddo y(j) = y(j) + alpha*temp2 enddo else jx = kx jy = ky do j = 1,n temp1 = alpha*x(jx) temp2 = zero y(jy) = y(jy) + temp1*a(j,j) ix = jx iy = jy do i = j + 1,n ix = ix + incx iy = iy + incy y(iy) = y(iy) + temp1*a(i,j) temp2 = temp2 + a(i,j)*x(ix) enddo y(jy) = y(jy) + alpha*temp2 jx = jx + incx jy = jy + incy enddo endif endif ! end subroutine dsymv !> !!##NAME !! dsyr2(3f) - [BLAS:DOUBLE_BLAS_LEVEL2] !! !!##SYNOPSIS !! !! subroutine dsyr2(uplo,n,alpha,x,incx,y,incy,a,lda) !! !! .. Scalar Arguments .. !! double precision,intent(in) :: alpha !! integer,intent(in) :: incx,incy,lda,n !! character,intent(in) :: uplo !! .. !! .. Array Arguments .. !! double precision,intent(inout) :: a(lda,*) !! double precision,intent(in) :: x(*),y(*) !! .. !! !!##DEFINITION !! !! DSYR2 performs the symmetric rank 2 operation !! !! A := alpha*x*y**T + alpha*y*x**T + A, !! !! where alpha is a scalar, x and y are n element vectors and A is an n !! by n symmetric matrix. !! !!##OPTIONS !! !! UPLO !! !! UPLO is 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. !! !! N !! !! N is INTEGER !! On entry, N specifies the order of the matrix A. !! N must be at least zero. !! !! ALPHA !! !! ALPHA is DOUBLE PRECISION. !! On entry, ALPHA specifies the scalar alpha. !! !! X !! !! X is DOUBLE PRECISION array, dimension at least !! ( 1 + ( n - 1 )*abs( INCX ) ). !! Before entry, the incremented array X must contain the n !! element vector x. !! !! INCX !! !! INCX is INTEGER !! On entry, INCX specifies the increment for the elements of !! X. INCX must not be zero. !! !! Y !! !! Y is DOUBLE PRECISION array, dimension at least !! ( 1 + ( n - 1 )*abs( INCY ) ). !! Before entry, the incremented array Y must contain the n !! element vector y. !! !! INCY !! !! INCY is INTEGER !! On entry, INCY specifies the increment for the elements of !! Y. INCY must not be zero. !! !! A !! !! A is DOUBLE PRECISION array, 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 !! !! LDA is 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 ). !! !!##AUTHORS !! !! + Univ. of Tennessee !! + Univ. of California Berkeley !! + Univ. of Colorado Denver !! + NAG Ltd. !! !! date:December 2016 !! !! FURTHER DETAILS !! !! 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. !! !!##SEE ALSO !! Online html documentation available at !! http://www.netlib.org/lapack/explore-html/ ! ===================================================================== subroutine dsyr2(uplo,n,alpha,x,incx,y,incy,a,lda) implicit none ! ! -- Reference BLAS level2 routine (version 3.7.0) -- ! -- Reference BLAS is a software package provided by Univ. of Tennessee, -- ! -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- ! December 2016 ! ! .. Scalar Arguments .. double precision,intent(in) :: alpha integer,intent(in) :: incx,incy,lda,n character,intent(in) :: uplo ! .. ! .. Array Arguments .. double precision,intent(inout) :: a(lda,*) double precision,intent(in) :: x(*),y(*) ! .. ! ! ===================================================================== ! ! .. Parameters .. double precision zero parameter (zero=0.0d+0) ! .. ! .. Local Scalars .. double precision temp1,temp2 integer i,info,ix,iy,j,jx,jy,kx,ky ! .. ! .. External Functions .. ! .. ! .. External Subroutines .. ! .. ! .. Intrinsic Functions .. intrinsic max ! .. ! ! Test the input parameters. ! info = 0 if (.not.lsame(uplo,'U') .and. .not.lsame(uplo,'L')) then info = 1 elseif (n.lt.0) then info = 2 elseif (incx.eq.0) then info = 5 elseif (incy.eq.0) then info = 7 elseif (lda.lt.max(1,n)) then info = 9 endif if (info.ne.0) then call xerbla('DSYR2 ',info) return endif ! ! Quick return if possible. ! if ((n.eq.0) .or. (alpha.eq.zero)) return ! ! Set up the start points in X and Y if the increments are not both ! unity. ! if ((incx.ne.1) .or. (incy.ne.1)) then if (incx.gt.0) then kx = 1 else kx = 1 - (n-1)*incx endif if (incy.gt.0) then ky = 1 else ky = 1 - (n-1)*incy endif jx = kx jy = ky endif ! ! 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')) then ! ! Form A when A is stored in the upper triangle. ! if ((incx.eq.1) .and. (incy.eq.1)) then do j = 1,n if ((x(j).ne.zero) .or. (y(j).ne.zero)) then temp1 = alpha*y(j) temp2 = alpha*x(j) do i = 1,j a(i,j) = a(i,j) + x(i)*temp1 + y(i)*temp2 enddo endif enddo else do j = 1,n if ((x(jx).ne.zero) .or. (y(jy).ne.zero)) then temp1 = alpha*y(jy) temp2 = alpha*x(jx) ix = kx iy = ky do i = 1,j a(i,j) = a(i,j) + x(ix)*temp1 + y(iy)*temp2 ix = ix + incx iy = iy + incy enddo endif jx = jx + incx jy = jy + incy enddo endif else ! ! Form A when A is stored in the lower triangle. ! if ((incx.eq.1) .and. (incy.eq.1)) then do j = 1,n if ((x(j).ne.zero) .or. (y(j).ne.zero)) then temp1 = alpha*y(j) temp2 = alpha*x(j) do i = j,n a(i,j) = a(i,j) + x(i)*temp1 + y(i)*temp2 enddo endif enddo else do j = 1,n if ((x(jx).ne.zero) .or. (y(jy).ne.zero)) then temp1 = alpha*y(jy) temp2 = alpha*x(jx) ix = jx iy = jy do i = j,n a(i,j) = a(i,j) + x(ix)*temp1 + y(iy)*temp2 ix = ix + incx iy = iy + incy enddo endif jx = jx + incx jy = jy + incy enddo endif endif ! end subroutine dsyr2 !> !!##NAME !! dsyr2k(3f) - [BLAS:DOUBLE_BLAS_LEVEL3] !! !!##SYNOPSIS !! !! subroutine dsyr2k(uplo,trans,n,k,alpha,a,lda,b,ldb,beta,c,ldc) !! !! .. Scalar Arguments .. !! double precision,intent(in) :: alpha,beta !! integer,intent(in) :: k,lda,ldb,ldc,n !! character,intent(in) :: trans,uplo !! .. !! .. Array Arguments .. !! double precision,intent(in) :: a(lda,*),b(ldb,*) !! double precision,intent(inout) :: c(ldc,*) !! .. !! !!##DEFINITION !! !! DSYR2K performs one of the symmetric rank 2k operations !! !! C := alpha*A*B**T + alpha*B*A**T + beta*C, !! !! or !! !! C := alpha*A**T*B + alpha*B**T*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. !! !!##OPTIONS !! !! UPLO !! !! 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. !! !! TRANS !! !! On entry, TRANS specifies the operation to be performed as !! follows: !! !! TRANS = 'N' or 'n' C := alpha*A*B**T + alpha*B*A**T + !! beta*C. !! !! TRANS = 'T' or 't' C := alpha*A**T*B + alpha*B**T*A + !! beta*C. !! !! TRANS = 'C' or 'c' C := alpha*A**T*B + alpha*B**T*A + !! beta*C. !! !! N !! !! On entry, N specifies the order of the matrix C. N must be !! at least zero. !! !! K !! !! K is 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. !! !! ALPHA !! !! ALPHA is DOUBLE PRECISION. !! On entry, ALPHA specifies the scalar alpha. !! !! A !! !! A is DOUBLE PRECISION array, 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. !! !! LDA !! !! LDA is 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 ). !! !! B !! !! B is DOUBLE PRECISION array, 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. !! !! LDB !! !! LDB is 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 ). !! !! BETA !! !! BETA is DOUBLE PRECISION. !! On entry, BETA specifies the scalar beta. !! !! C !! !! C is DOUBLE PRECISION array, 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 !! !! LDC is 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 ). !! !!##AUTHORS !! !! + Univ. of Tennessee !! + Univ. of California Berkeley !! + Univ. of Colorado Denver !! + NAG Ltd. !! !! date:December 2016 !! !! FURTHER DETAILS !! !! 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. !! !!##SEE ALSO !! Online html documentation available at !! http://www.netlib.org/lapack/explore-html/ ! ===================================================================== subroutine dsyr2k(uplo,trans,n,k,alpha,a,lda,b,ldb,beta,c,ldc) implicit none ! ! -- Reference BLAS level3 routine (version 3.7.0) -- ! -- Reference BLAS is a software package provided by Univ. of Tennessee, -- ! -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- ! December 2016 ! ! .. Scalar Arguments .. double precision,intent(in) :: alpha,beta integer,intent(in) :: k,lda,ldb,ldc,n character,intent(in) :: trans,uplo ! .. ! .. Array Arguments .. double precision,intent(in) :: a(lda,*),b(ldb,*) double precision,intent(inout) :: c(ldc,*) ! .. ! ! ===================================================================== ! ! .. External Functions .. ! .. ! .. External Subroutines .. ! .. ! .. Intrinsic Functions .. intrinsic max ! .. ! .. Local Scalars .. double precision temp1,temp2 integer i,info,j,l,nrowa logical upper ! .. ! .. Parameters .. double precision one,zero parameter (one=1.0d+0,zero=0.0d+0) ! .. ! ! Test the input parameters. ! if (lsame(trans,'N')) then nrowa = n else nrowa = k endif upper = lsame(uplo,'U') ! info = 0 if ((.not.upper) .and. (.not.lsame(uplo,'L'))) then info = 1 elseif ((.not.lsame(trans,'N')) .and. (.not.lsame(trans,'T')) .and. (.not.lsame(trans,'C'))) then info = 2 elseif (n.lt.0) then info = 3 elseif (k.lt.0) then info = 4 elseif (lda.lt.max(1,nrowa)) then info = 7 elseif (ldb.lt.max(1,nrowa)) then info = 9 elseif (ldc.lt.max(1,n)) then info = 12 endif if (info.ne.0) then call xerbla('DSYR2K',info) return endif ! ! Quick return if possible. ! if ((n.eq.0) .or. (((alpha.eq.zero).or. (k.eq.0)).and. (beta.eq.one))) return ! ! And when alpha.eq.zero. ! if (alpha.eq.zero) then if (upper) then if (beta.eq.zero) then do j = 1,n c(1:j,j) = zero enddo else do j = 1,n c(1:j,j) = beta*c(1:j,j) enddo endif else if (beta.eq.zero) then do j = 1,n c(j:n,j) = zero enddo else do j = 1,n c(j:n,j) = beta*c(j:n,j) enddo endif endif return endif ! ! Start the operations. ! if (lsame(trans,'N')) then ! ! Form C := alpha*A*B**T + alpha*B*A**T + C. ! if (upper) then do j = 1,n if (beta.eq.zero) then c(1:j,j) = zero elseif (beta.ne.one) then c(1:j,j) = beta*c(1:j,j) endif do l = 1,k if ((a(j,l).ne.zero) .or. (b(j,l).ne.zero)) then temp1 = alpha*b(j,l) temp2 = alpha*a(j,l) do i = 1,j c(i,j) = c(i,j) + a(i,l)*temp1 + b(i,l)*temp2 enddo endif enddo enddo else do j = 1,n if (beta.eq.zero) then c(j:n,j) = zero elseif (beta.ne.one) then c(j:n,j) = beta*c(j:n,j) endif do l = 1,k if ((a(j,l).ne.zero) .or. (b(j,l).ne.zero)) then temp1 = alpha*b(j,l) temp2 = alpha*a(j,l) do i = j,n c(i,j) = c(i,j) + a(i,l)*temp1 + b(i,l)*temp2 enddo endif enddo enddo endif else ! ! Form C := alpha*A**T*B + alpha*B**T*A + C. ! if (upper) then do j = 1,n do i = 1,j temp1 = zero temp2 = zero do l = 1,k temp1 = temp1 + a(l,i)*b(l,j) temp2 = temp2 + b(l,i)*a(l,j) enddo if (beta.eq.zero) then c(i,j) = alpha*temp1 + alpha*temp2 else c(i,j) = beta*c(i,j) + alpha*temp1 + alpha*temp2 endif enddo enddo else do j = 1,n do i = j,n temp1 = zero temp2 = zero do l = 1,k temp1 = temp1 + a(l,i)*b(l,j) temp2 = temp2 + b(l,i)*a(l,j) enddo if (beta.eq.zero) then c(i,j) = alpha*temp1 + alpha*temp2 else c(i,j) = beta*c(i,j) + alpha*temp1 + alpha*temp2 endif enddo enddo endif endif ! end subroutine dsyr2k !> !!##NAME !! dsyr(3f) - [BLAS:DOUBLE_BLAS_LEVEL3] !! !!##SYNOPSIS !! !! subroutine dsyr(uplo,n,alpha,x,incx,a,lda) !! !! .. Scalar Arguments .. !! double precision,intent(in) :: alpha !! integer,intent(in) :: incx,lda,n !! character,intent(in) :: uplo !! .. !! .. Array Arguments .. !! double precision,intent(inout) :: a(lda,*) !! double precision,intent(in) :: x(*) !! .. !! !!##DEFINITION !! !! DSYR performs the symmetric rank 1 operation !! !! A := alpha*x*x**T + A, !! !! where alpha is a real scalar, x is an n element vector and A is an !! n by n symmetric matrix. !! !!##OPTIONS !! !! UPLO !! !! UPLO is 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. !! !! N !! !! N is INTEGER !! On entry, N specifies the order of the matrix A. !! N must be at least zero. !! !! ALPHA !! !! ALPHA is DOUBLE PRECISION. !! On entry, ALPHA specifies the scalar alpha. !! !! X !! !! X is DOUBLE PRECISION array, dimension at least !! ( 1 + ( n - 1 )*abs( INCX ) ). !! Before entry, the incremented array X must contain the n !! element vector x. !! !! INCX !! !! INCX is INTEGER !! On entry, INCX specifies the increment for the elements of !! X. INCX must not be zero. !! !! A !! !! A is DOUBLE PRECISION array, 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 !! !! LDA is 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 ). !! !!##AUTHORS !! !! + Univ. of Tennessee !! + Univ. of California Berkeley !! + Univ. of Colorado Denver !! + NAG Ltd. !! !! date:December 2016 !! !! \ingroup double_blas_level2 !! !! FURTHER DETAILS !! !! 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. !! !!##SEE ALSO !! Online html documentation available at !! http://www.netlib.org/lapack/explore-html/ ! ===================================================================== subroutine dsyr(uplo,n,alpha,x,incx,a,lda) implicit none ! ! -- Reference BLAS level2 routine (version 3.7.0) -- ! -- Reference BLAS is a software package provided by Univ. of Tennessee, -- ! -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- ! December 2016 ! ! .. Scalar Arguments .. double precision,intent(in) :: alpha integer,intent(in) :: incx,lda,n character,intent(in) :: uplo ! .. ! .. Array Arguments .. double precision,intent(inout) :: a(lda,*) double precision,intent(in) :: x(*) ! .. ! ! ===================================================================== ! ! .. Parameters .. double precision zero parameter (zero=0.0d+0) ! .. ! .. Local Scalars .. double precision temp integer i,info,ix,j,jx,kx ! .. ! .. External Functions .. ! .. ! .. External Subroutines .. ! .. ! .. Intrinsic Functions .. intrinsic max ! .. ! ! Test the input parameters. ! info = 0 if (.not.lsame(uplo,'U') .and. .not.lsame(uplo,'L')) then info = 1 elseif (n.lt.0) then info = 2 elseif (incx.eq.0) then info = 5 elseif (lda.lt.max(1,n)) then info = 7 endif if (info.ne.0) then call xerbla('DSYR ',info) return endif ! ! Quick return if possible. ! if ((n.eq.0) .or. (alpha.eq.zero)) return ! ! Set the start point in X if the increment is not unity. ! if (incx.le.0) then kx = 1 - (n-1)*incx elseif (incx.ne.1) then kx = 1 endif ! ! 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')) then ! ! Form A when A is stored in upper triangle. ! if (incx.eq.1) then do j = 1,n if (x(j).ne.zero) then temp = alpha*x(j) a(1:j,j) = a(1:j,j) + x(1:j)*temp endif enddo else jx = kx do j = 1,n if (x(jx).ne.zero) then temp = alpha*x(jx) ix = kx do i = 1,j a(i,j) = a(i,j) + x(ix)*temp ix = ix + incx enddo endif jx = jx + incx enddo endif else ! ! Form A when A is stored in lower triangle. ! if (incx.eq.1) then do j = 1,n if (x(j).ne.zero) then temp = alpha*x(j) a(j:n,j) = a(j:n,j) + x(j:n)*temp endif enddo else jx = kx do j = 1,n if (x(jx).ne.zero) then temp = alpha*x(jx) ix = jx do i = j,n a(i,j) = a(i,j) + x(ix)*temp ix = ix + incx enddo endif jx = jx + incx enddo endif endif ! end subroutine dsyr !> !!##NAME !! dsyrk(3f) - [BLAS:DOUBLE_BLAS_LEVEL3] !! !!##SYNOPSIS !! !! subroutine dsyrk(uplo,trans,n,k,alpha,a,lda,beta,c,ldc) !! !! .. Scalar Arguments .. !! double precision,intent(in) :: alpha,beta !! integer,intent(in) :: k,lda,ldc,n !! character,intent(in) :: trans,uplo !! .. !! .. Array Arguments .. !! double precision,intent(in) :: a(lda,*) !! double precision,intent(inout) :: c(ldc,*) !! .. !! !!##DEFINITION !! !! DSYRK performs one of the symmetric rank k operations !! !! C := alpha*A*A**T + beta*C, !! !! or !! !! C := alpha*A**T*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. !! !!##OPTIONS !! !! UPLO !! !! UPLO is 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. !! !! TRANS !! !! TRANS is CHARACTER*1 !! On entry, TRANS specifies the operation to be performed as !! follows: !! !! TRANS = 'N' or 'n' C := alpha*A*A**T + beta*C. !! !! TRANS = 'T' or 't' C := alpha*A**T*A + beta*C. !! !! TRANS = 'C' or 'c' C := alpha*A**T*A + beta*C. !! !! N !! !! N is INTEGER !! On entry, N specifies the order of the matrix C. N must be !! at least zero. !! !! K !! !! K is 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. !! !! ALPHA !! !! ALPHA is DOUBLE PRECISION. !! On entry, ALPHA specifies the scalar alpha. !! !! A !! !! A is DOUBLE PRECISION array, 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. !! !! LDA !! !! LDA is 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 ). !! !! BETA !! !! BETA is DOUBLE PRECISION. !! On entry, BETA specifies the scalar beta. !! !! C !! !! C is DOUBLE PRECISION array, 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 !! !! LDC is 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 ). !! !!##AUTHORS !! !! + Univ. of Tennessee !! + Univ. of California Berkeley !! + Univ. of Colorado Denver !! + NAG Ltd. !! !! date:December 2016 !! !! \ingroup double_blas_level3 !! !! FURTHER DETAILS !! !! 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. !! !!##SEE ALSO !! Online html documentation available at !! http://www.netlib.org/lapack/explore-html/ ! ===================================================================== subroutine dsyrk(uplo,trans,n,k,alpha,a,lda,beta,c,ldc) implicit none ! ! -- Reference BLAS level3 routine (version 3.7.0) -- ! -- Reference BLAS is a software package provided by Univ. of Tennessee, -- ! -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- ! December 2016 ! ! .. Scalar Arguments .. double precision,intent(in) :: alpha,beta integer,intent(in) :: k,lda,ldc,n character,intent(in) :: trans,uplo ! .. ! .. Array Arguments .. double precision,intent(in) :: a(lda,*) double precision,intent(inout) :: c(ldc,*) ! .. ! ! ===================================================================== ! ! .. External Functions .. ! .. ! .. External Subroutines .. ! .. ! .. Intrinsic Functions .. intrinsic max ! .. ! .. Local Scalars .. double precision temp integer i,info,j,l,nrowa logical upper ! .. ! .. Parameters .. double precision one,zero parameter (one=1.0d+0,zero=0.0d+0) ! .. ! ! Test the input parameters. ! if (lsame(trans,'N')) then nrowa = n else nrowa = k endif upper = lsame(uplo,'U') ! info = 0 if ((.not.upper) .and. (.not.lsame(uplo,'L'))) then info = 1 else if ((.not.lsame(trans,'N')) .and. (.not.lsame(trans,'T')) .and. (.not.lsame(trans,'C'))) then info = 2 else if (n.lt.0) then info = 3 else if (k.lt.0) then info = 4 else if (lda.lt.max(1,nrowa)) then info = 7 else if (ldc.lt.max(1,n)) then info = 10 endif if (info.ne.0) then call xerbla('DSYRK ',info) return endif ! ! Quick return if possible. ! if ((n.eq.0) .or. (((alpha.eq.zero).or. (k.eq.0)).and. (beta.eq.one))) return ! ! And when alpha.eq.zero. ! if (alpha.eq.zero) then if (upper) then if (beta.eq.zero) then do j = 1,n c(1:j,j) = zero enddo else do j = 1,n c(1:j,j) = beta*c(1:j,j) enddo endif else if (beta.eq.zero) then do j = 1,n c(j:n,j) = zero enddo else do j = 1,n c(j:n,j) = beta*c(j:n,j) enddo endif endif return endif ! ! Start the operations. ! if (lsame(trans,'N')) then ! ! Form C := alpha*A*A**T + beta*C. ! if (upper) then do j = 1,n if (beta.eq.zero) then c(1:j,j) = zero else if (beta.ne.one) then c(1:j,j) = beta*c(1:j,j) endif do l = 1,k if (a(j,l).ne.zero) then temp = alpha*a(j,l) c(1:j,j) = c(1:j,j) + temp*a(1:j,l) endif enddo enddo else do j = 1,n if (beta.eq.zero) then c(j:n,j) = zero else if (beta.ne.one) then c(j:n,j) = beta*c(j:n,j) endif do l = 1,k if (a(j,l).ne.zero) then temp = alpha*a(j,l) c(j:n,j) = c(j:n,j) + temp*a(j:n,l) endif enddo enddo endif else ! ! Form C := alpha*A**T*A + beta*C. ! if (upper) then do j = 1,n do i = 1,j temp = zero do l = 1,k temp = temp + a(l,i)*a(l,j) enddo if (beta.eq.zero) then c(i,j) = alpha*temp else c(i,j) = alpha*temp + beta*c(i,j) endif enddo enddo else do j = 1,n do i = j,n temp = zero do l = 1,k temp = temp + a(l,i)*a(l,j) enddo if (beta.eq.zero) then c(i,j) = alpha*temp else c(i,j) = alpha*temp + beta*c(i,j) endif enddo enddo endif endif ! end subroutine dsyrk !> !!##NAME !! dtbmv(3f) - [BLAS:DOUBLE_BLAS_LEVEL3] !! !!##SYNOPSIS !! !! subroutine dtbmv(uplo,trans,diag,n,k,a,lda,x,incx) !! !! .. Scalar Arguments .. !! integer,intent(in) :: incx,k,lda,n !! character,intent(in) :: diag,trans,uplo !! .. !! .. Array Arguments .. !! double precision,intent(in) :: a(lda,*) !! double precision,intent(inout) :: x(*) !! .. !! !!##DEFINITION !! !! DTBMV performs one of the matrix-vector operations !! !! x := A*x, or x := A**T*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. !! !!##OPTIONS !! !! UPLO !! !! UPLO is 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. !! !! TRANS !! !! TRANS is 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**T*x. !! !! TRANS = 'C' or 'c' x := A**T*x. !! !! DIAG !! !! DIAG is 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. !! !! N !! !! N is INTEGER !! On entry, N specifies the order of the matrix A. !! N must be at least zero. !! !! K !! !! K is 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. !! !! A !! !! A is DOUBLE PRECISION array, 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. !! !! LDA !! !! LDA is INTEGER !! On entry, LDA specifies the first dimension of A as declared !! in the calling (sub) program. LDA must be at least !! ( k + 1 ). !! !! X !! !! X is DOUBLE PRECISION array, 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 !! transformed vector x. !! !! INCX !! !! INCX is INTEGER !! On entry, INCX specifies the increment for the elements of !! X. INCX must not be zero. !! !!##AUTHORS !! !! + Univ. of Tennessee !! + Univ. of California Berkeley !! + Univ. of Colorado Denver !! + NAG Ltd. !! !! date:December 2016 !! !! \ingroup double_blas_level2 !! !! FURTHER DETAILS !! !! Level 2 Blas routine. !! The vector and matrix arguments are not referenced when N = 0, or M = 0 !! !! -- 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. !! !!##SEE ALSO !! Online html documentation available at !! http://www.netlib.org/lapack/explore-html/ ! ===================================================================== subroutine dtbmv(uplo,trans,diag,n,k,a,lda,x,incx) implicit none ! ! -- Reference BLAS level2 routine (version 3.7.0) -- ! -- Reference BLAS is a software package provided by Univ. of Tennessee, -- ! -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- ! December 2016 ! ! .. Scalar Arguments .. integer,intent(in) :: incx,k,lda,n character,intent(in) :: diag,trans,uplo ! .. ! .. Array Arguments .. double precision,intent(in) :: a(lda,*) double precision,intent(inout) :: x(*) ! .. ! ! ===================================================================== ! ! .. Parameters .. double precision zero parameter (zero=0.0d+0) ! .. ! .. Local Scalars .. double precision temp integer i,info,ix,j,jx,kplus1,kx,l logical nounit ! .. ! .. External Functions .. ! .. ! .. External Subroutines .. ! .. ! .. Intrinsic Functions .. intrinsic max,min ! .. ! ! Test the input parameters. ! info = 0 if (.not.lsame(uplo,'U') .and. .not.lsame(uplo,'L')) then info = 1 elseif (.not.lsame(trans,'N') .and. .not.lsame(trans,'T') .and. .not.lsame(trans,'C')) then info = 2 elseif (.not.lsame(diag,'U') .and. .not.lsame(diag,'N')) then info = 3 elseif (n.lt.0) then info = 4 elseif (k.lt.0) then info = 5 elseif (lda.lt. (k+1)) then info = 7 elseif (incx.eq.0) then info = 9 endif if (info.ne.0) then call xerbla('DTBMV ',info) return endif ! ! Quick return if possible. ! if (n.eq.0) return ! nounit = lsame(diag,'N') ! ! Set up the start point in X if the increment is not unity. This ! will be ( N - 1 )*INCX too small for descending loops. ! if (incx.le.0) then kx = 1 - (n-1)*incx elseif (incx.ne.1) then kx = 1 endif ! ! Start the operations. In this version the elements of A are ! accessed sequentially with one pass through A. ! if (lsame(trans,'N')) then ! ! Form x := A*x. ! if (lsame(uplo,'U')) then kplus1 = k + 1 if (incx.eq.1) then do j = 1,n if (x(j).ne.zero) then temp = x(j) l = kplus1 - j do i = max(1,j-k),j - 1 x(i) = x(i) + temp*a(l+i,j) enddo if (nounit) x(j) = x(j)*a(kplus1,j) endif enddo else jx = kx do j = 1,n if (x(jx).ne.zero) then temp = x(jx) ix = kx l = kplus1 - j do i = max(1,j-k),j - 1 x(ix) = x(ix) + temp*a(l+i,j) ix = ix + incx enddo if (nounit) x(jx) = x(jx)*a(kplus1,j) endif jx = jx + incx if (j.gt.k) kx = kx + incx enddo endif else if (incx.eq.1) then do j = n,1,-1 if (x(j).ne.zero) then temp = x(j) l = 1 - j do i = min(n,j+k),j + 1,-1 x(i) = x(i) + temp*a(l+i,j) enddo if (nounit) x(j) = x(j)*a(1,j) endif enddo else kx = kx + (n-1)*incx jx = kx do j = n,1,-1 if (x(jx).ne.zero) then temp = x(jx) ix = kx l = 1 - j do i = min(n,j+k),j + 1,-1 x(ix) = x(ix) + temp*a(l+i,j) ix = ix - incx enddo if (nounit) x(jx) = x(jx)*a(1,j) endif jx = jx - incx if ((n-j).ge.k) kx = kx - incx enddo endif endif else ! ! Form x := A**T*x. ! if (lsame(uplo,'U')) then kplus1 = k + 1 if (incx.eq.1) then do j = n,1,-1 temp = x(j) l = kplus1 - j if (nounit) temp = temp*a(kplus1,j) do i = j - 1,max(1,j-k),-1 temp = temp + a(l+i,j)*x(i) enddo x(j) = temp enddo else kx = kx + (n-1)*incx jx = kx do j = n,1,-1 temp = x(jx) kx = kx - incx ix = kx l = kplus1 - j if (nounit) temp = temp*a(kplus1,j) do i = j - 1,max(1,j-k),-1 temp = temp + a(l+i,j)*x(ix) ix = ix - incx enddo x(jx) = temp jx = jx - incx enddo endif else if (incx.eq.1) then do j = 1,n temp = x(j) l = 1 - j if (nounit) temp = temp*a(1,j) do i = j + 1,min(n,j+k) temp = temp + a(l+i,j)*x(i) enddo x(j) = temp enddo else jx = kx do j = 1,n temp = x(jx) kx = kx + incx ix = kx l = 1 - j if (nounit) temp = temp*a(1,j) do i = j + 1,min(n,j+k) temp = temp + a(l+i,j)*x(ix) ix = ix + incx enddo x(jx) = temp jx = jx + incx enddo endif endif endif ! end subroutine dtbmv !> !!##NAME !! dtbsv(3f) - [BLAS:DOUBLE_BLAS_LEVEL3] !! !!##SYNOPSIS !! !! subroutine dtbsv(uplo,trans,diag,n,k,a,lda,x,incx) !! !! .. Scalar Arguments .. !! integer,intent(in) :: incx,k,lda,n !! character,intent(in) :: diag,trans,uplo !! .. !! .. Array Arguments .. !! double precision,intent(in) :: a(lda,*) !! double precision,intent(inout) :: x(*) !! .. !! !!##DEFINITION !! !! DTBSV solves one of the systems of equations !! !! A*x = b, or A**T*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. !! !!##OPTIONS !! !! UPLO !! !! UPLO is 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. !! !! TRANS !! !! TRANS is 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**T*x = b. !! !! TRANS = 'C' or 'c' A**T*x = b. !! !! DIAG !! !! DIAG is 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. !! !! N !! !! N is INTEGER !! On entry, N specifies the order of the matrix A. !! N must be at least zero. !! !! K !! !! K is 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. !! !! A !! !! A is DOUBLE PRECISION array, 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. !! !! LDA !! !! LDA is INTEGER !! On entry, LDA specifies the first dimension of A as declared !! in the calling (sub) program. LDA must be at least !! ( k + 1 ). !! !! X !! !! X is DOUBLE PRECISION array, 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 !! !! INCX is INTEGER !! On entry, INCX specifies the increment for the elements of !! X. INCX must not be zero. !! !!##AUTHORS !! !! + Univ. of Tennessee !! + Univ. of California Berkeley !! + Univ. of Colorado Denver !! + NAG Ltd. !! !! date:December 2016 !! !! \ingroup double_blas_level2 !! !! FURTHER DETAILS !! !! 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. !! !!##SEE ALSO !! Online html documentation available at !! http://www.netlib.org/lapack/explore-html/ ! ===================================================================== subroutine dtbsv(uplo,trans,diag,n,k,a,lda,x,incx) implicit none ! ! -- Reference BLAS level2 routine (version 3.7.0) -- ! -- Reference BLAS is a software package provided by Univ. of Tennessee, -- ! -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- ! December 2016 ! ! .. Scalar Arguments .. integer,intent(in) :: incx,k,lda,n character,intent(in) :: diag,trans,uplo ! .. ! .. Array Arguments .. double precision,intent(in) :: a(lda,*) double precision,intent(inout) :: x(*) ! .. ! ! ===================================================================== ! ! .. Parameters .. double precision zero parameter (zero=0.0d+0) ! .. ! .. Local Scalars .. double precision temp integer i,info,ix,j,jx,kplus1,kx,l logical nounit ! .. ! .. External Functions .. ! .. ! .. External Subroutines .. ! .. ! .. Intrinsic Functions .. intrinsic max,min ! .. ! ! Test the input parameters. ! info = 0 if (.not.lsame(uplo,'U') .and. .not.lsame(uplo,'L')) then info = 1 elseif (.not.lsame(trans,'N') .and. .not.lsame(trans,'T') .and. .not.lsame(trans,'C')) then info = 2 elseif (.not.lsame(diag,'U') .and. .not.lsame(diag,'N')) then info = 3 elseif (n.lt.0) then info = 4 elseif (k.lt.0) then info = 5 elseif (lda.lt. (k+1)) then info = 7 elseif (incx.eq.0) then info = 9 endif if (info.ne.0) then call xerbla('DTBSV ',info) return endif ! ! Quick return if possible. ! if (n.eq.0) return ! nounit = lsame(diag,'N') ! ! Set up the start point in X if the increment is not unity. This ! will be ( N - 1 )*INCX too small for descending loops. ! if (incx.le.0) then kx = 1 - (n-1)*incx elseif (incx.ne.1) then kx = 1 endif ! ! Start the operations. In this version the elements of A are ! accessed by sequentially with one pass through A. ! if (lsame(trans,'N')) then ! ! Form x := inv( A )*x. ! if (lsame(uplo,'U')) then kplus1 = k + 1 if (incx.eq.1) then do j = n,1,-1 if (x(j).ne.zero) then l = kplus1 - j if (nounit) x(j) = x(j)/a(kplus1,j) temp = x(j) do i = j - 1,max(1,j-k),-1 x(i) = x(i) - temp*a(l+i,j) enddo endif enddo else kx = kx + (n-1)*incx jx = kx do j = n,1,-1 kx = kx - incx if (x(jx).ne.zero) then ix = kx l = kplus1 - j if (nounit) x(jx) = x(jx)/a(kplus1,j) temp = x(jx) do i = j - 1,max(1,j-k),-1 x(ix) = x(ix) - temp*a(l+i,j) ix = ix - incx enddo endif jx = jx - incx enddo endif else if (incx.eq.1) then do j = 1,n if (x(j).ne.zero) then l = 1 - j if (nounit) x(j) = x(j)/a(1,j) temp = x(j) do i = j + 1,min(n,j+k) x(i) = x(i) - temp*a(l+i,j) enddo endif enddo else jx = kx do j = 1,n kx = kx + incx if (x(jx).ne.zero) then ix = kx l = 1 - j if (nounit) x(jx) = x(jx)/a(1,j) temp = x(jx) do i = j + 1,min(n,j+k) x(ix) = x(ix) - temp*a(l+i,j) ix = ix + incx enddo endif jx = jx + incx enddo endif endif else ! ! Form x := inv( A**T)*x. ! if (lsame(uplo,'U')) then kplus1 = k + 1 if (incx.eq.1) then do j = 1,n temp = x(j) l = kplus1 - j do i = max(1,j-k),j - 1 temp = temp - a(l+i,j)*x(i) enddo if (nounit) temp = temp/a(kplus1,j) x(j) = temp enddo else jx = kx do j = 1,n temp = x(jx) ix = kx l = kplus1 - j do i = max(1,j-k),j - 1 temp = temp - a(l+i,j)*x(ix) ix = ix + incx enddo if (nounit) temp = temp/a(kplus1,j) x(jx) = temp jx = jx + incx if (j.gt.k) kx = kx + incx enddo endif else if (incx.eq.1) then do j = n,1,-1 temp = x(j) l = 1 - j do i = min(n,j+k),j + 1,-1 temp = temp - a(l+i,j)*x(i) enddo if (nounit) temp = temp/a(1,j) x(j) = temp enddo else kx = kx + (n-1)*incx jx = kx do j = n,1,-1 temp = x(jx) ix = kx l = 1 - j do i = min(n,j+k),j + 1,-1 temp = temp - a(l+i,j)*x(ix) ix = ix - incx enddo if (nounit) temp = temp/a(1,j) x(jx) = temp jx = jx - incx if ((n-j).ge.k) kx = kx - incx enddo endif endif endif ! end subroutine dtbsv !> !!##NAME !! dtpmv(3f) - [BLAS:DOUBLE_BLAS_LEVEL3] !! !!##SYNOPSIS !! !! subroutine dtpmv(uplo,trans,diag,n,ap,x,incx) !! !! .. Scalar Arguments .. !! integer,intent(in) :: incx,n !! character,intent(in) :: diag,trans,uplo !! .. !! .. Array Arguments .. !! double precision,intent(in) :: ap(*) !! double precision,intent(inout) :: x(*) !! .. !! !!##DEFINITION !! !! DTPMV performs one of the matrix-vector operations !! !! x := A*x, or x := A**T*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. !! !!##OPTIONS !! !! UPLO !! !! UPLO is 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. !! !! TRANS !! !! TRANS is 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**T*x. !! !! TRANS = 'C' or 'c' x := A**T*x. !! !! DIAG !! !! DIAG is 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. !! !! N !! !! N is INTEGER !! On entry, N specifies the order of the matrix A. !! N must be at least zero. !! !! AP !! !! AP is DOUBLE PRECISION array, 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. !! !! X !! !! X is DOUBLE PRECISION array, 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 !! transformed vector x. !! !! INCX !! !! INCX is INTEGER !! On entry, INCX specifies the increment for the elements of !! X. INCX must not be zero. !! !!##AUTHORS !! !! + Univ. of Tennessee !! + Univ. of California Berkeley !! + Univ. of Colorado Denver !! + NAG Ltd. !! !! date:December 2016 !! !! \ingroup double_blas_level2 !! !! FURTHER DETAILS !! !! Level 2 Blas routine. !! The vector and matrix arguments are not referenced when N = 0, or M = 0 !! !! -- 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. !! !!##SEE ALSO !! Online html documentation available at !! http://www.netlib.org/lapack/explore-html/ ! ===================================================================== subroutine dtpmv(uplo,trans,diag,n,ap,x,incx) implicit none ! ! -- Reference BLAS level2 routine (version 3.7.0) -- ! -- Reference BLAS is a software package provided by Univ. of Tennessee, -- ! -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- ! December 2016 ! ! .. Scalar Arguments .. integer,intent(in) :: incx,n character,intent(in) :: diag,trans,uplo ! .. ! .. Array Arguments .. double precision,intent(in) :: ap(*) double precision,intent(inout) :: x(*) ! .. ! ! ===================================================================== ! ! .. Parameters .. double precision zero parameter (zero=0.0d+0) ! .. ! .. Local Scalars .. double precision temp integer i,info,ix,j,jx,k,kk,kx logical nounit ! .. ! .. External Functions .. ! .. ! .. External Subroutines .. ! .. ! ! Test the input parameters. ! info = 0 if (.not.lsame(uplo,'U') .and. .not.lsame(uplo,'L')) then info = 1 elseif (.not.lsame(trans,'N') .and. .not.lsame(trans,'T') .and. .not.lsame(trans,'C')) then info = 2 elseif (.not.lsame(diag,'U') .and. .not.lsame(diag,'N')) then info = 3 elseif (n.lt.0) then info = 4 elseif (incx.eq.0) then info = 7 endif if (info.ne.0) then call xerbla('DTPMV ',info) return endif ! ! Quick return if possible. ! if (n.eq.0) return ! nounit = lsame(diag,'N') ! ! Set up the start point in X if the increment is not unity. This ! will be ( N - 1 )*INCX too small for descending loops. ! if (incx.le.0) then kx = 1 - (n-1)*incx elseif (incx.ne.1) then kx = 1 endif ! ! Start the operations. In this version the elements of AP are ! accessed sequentially with one pass through AP. ! if (lsame(trans,'N')) then ! ! Form x:= A*x. ! if (lsame(uplo,'U')) then kk = 1 if (incx.eq.1) then do j = 1,n if (x(j).ne.zero) then temp = x(j) k = kk do i = 1,j - 1 x(i) = x(i) + temp*ap(k) k = k + 1 enddo if (nounit) x(j) = x(j)*ap(kk+j-1) endif kk = kk + j enddo else jx = kx do j = 1,n if (x(jx).ne.zero) then temp = x(jx) ix = kx do k = kk,kk + j - 2 x(ix) = x(ix) + temp*ap(k) ix = ix + incx enddo if (nounit) x(jx) = x(jx)*ap(kk+j-1) endif jx = jx + incx kk = kk + j enddo endif else kk = (n* (n+1))/2 if (incx.eq.1) then do j = n,1,-1 if (x(j).ne.zero) then temp = x(j) k = kk do i = n,j + 1,-1 x(i) = x(i) + temp*ap(k) k = k - 1 enddo if (nounit) x(j) = x(j)*ap(kk-n+j) endif kk = kk - (n-j+1) enddo else kx = kx + (n-1)*incx jx = kx do j = n,1,-1 if (x(jx).ne.zero) then temp = x(jx) ix = kx do k = kk,kk - (n- (j+1)),-1 x(ix) = x(ix) + temp*ap(k) ix = ix - incx enddo if (nounit) x(jx) = x(jx)*ap(kk-n+j) endif jx = jx - incx kk = kk - (n-j+1) enddo endif endif else ! ! Form x := A**T*x. ! if (lsame(uplo,'U')) then kk = (n* (n+1))/2 if (incx.eq.1) then do j = n,1,-1 temp = x(j) if (nounit) temp = temp*ap(kk) k = kk - 1 do i = j - 1,1,-1 temp = temp + ap(k)*x(i) k = k - 1 enddo x(j) = temp kk = kk - j enddo else jx = kx + (n-1)*incx do j = n,1,-1 temp = x(jx) ix = jx if (nounit) temp = temp*ap(kk) do k = kk - 1,kk - j + 1,-1 ix = ix - incx temp = temp + ap(k)*x(ix) enddo x(jx) = temp jx = jx - incx kk = kk - j enddo endif else kk = 1 if (incx.eq.1) then do j = 1,n temp = x(j) if (nounit) temp = temp*ap(kk) k = kk + 1 do i = j + 1,n temp = temp + ap(k)*x(i) k = k + 1 enddo x(j) = temp kk = kk + (n-j+1) enddo else jx = kx do j = 1,n temp = x(jx) ix = jx if (nounit) temp = temp*ap(kk) do k = kk + 1,kk + n - j ix = ix + incx temp = temp + ap(k)*x(ix) enddo x(jx) = temp jx = jx + incx kk = kk + (n-j+1) enddo endif endif endif ! end subroutine dtpmv !> !!##NAME !! dtpsv(3f) - [BLAS:DOUBLE_BLAS_LEVEL2] !! !!##SYNOPSIS !! !! subroutine dtpsv(uplo,trans,diag,n,ap,x,incx) !! !! .. Scalar Arguments .. !! integer,intent(in) :: incx,n !! character,intent(in) :: diag,trans,uplo !! .. !! .. Array Arguments .. !! double precision,intent(in) :: ap(*) !! double precision,intent(inout) :: x(*) !! .. !! !!##DEFINITION !! !! DTPSV solves one of the systems of equations !! !! A*x = b, or A**T*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. !! !!##OPTIONS !! !! UPLO !! !! UPLO is 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. !! !! TRANS !! !! TRANS is 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**T*x = b. !! !! TRANS = 'C' or 'c' A**T*x = b. !! !! DIAG !! !! DIAG is 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. !! !! N !! !! N is INTEGER !! On entry, N specifies the order of the matrix A. !! N must be at least zero. !! !! AP !! !! AP is DOUBLE PRECISION array, 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. !! !! X !! !! X is DOUBLE PRECISION array, 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 !! !! INCX is INTEGER !! On entry, INCX specifies the increment for the elements of !! X. INCX must not be zero. !! !!##AUTHORS !! !! + Univ. of Tennessee !! + Univ. of California Berkeley !! + Univ. of Colorado Denver !! + NAG Ltd. !! !! date:December 2016 !! !! FURTHER DETAILS !! !! 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. !! !!##SEE ALSO !! Online html documentation available at !! http://www.netlib.org/lapack/explore-html/ ! ===================================================================== subroutine dtpsv(uplo,trans,diag,n,ap,x,incx) implicit none ! ! -- Reference BLAS level2 routine (version 3.7.0) -- ! -- Reference BLAS is a software package provided by Univ. of Tennessee, -- ! -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- ! December 2016 ! ! .. Scalar Arguments .. integer,intent(in) :: incx,n character,intent(in) :: diag,trans,uplo ! .. ! .. Array Arguments .. double precision,intent(in) :: ap(*) double precision,intent(inout) :: x(*) ! .. ! ! ===================================================================== ! ! .. Parameters .. double precision zero parameter (zero=0.0d+0) ! .. ! .. Local Scalars .. double precision temp integer i,info,ix,j,jx,k,kk,kx logical nounit ! .. ! .. External Functions .. ! .. ! .. External Subroutines .. ! .. ! ! Test the input parameters. ! info = 0 if (.not.lsame(uplo,'U') .and. .not.lsame(uplo,'L')) then info = 1 elseif (.not.lsame(trans,'N') .and. .not.lsame(trans,'T') .and. .not.lsame(trans,'C')) then info = 2 elseif (.not.lsame(diag,'U') .and. .not.lsame(diag,'N')) then info = 3 elseif (n.lt.0) then info = 4 elseif (incx.eq.0) then info = 7 endif if (info.ne.0) then call xerbla('DTPSV ',info) return endif ! ! Quick return if possible. ! if (n.eq.0) return ! nounit = lsame(diag,'N') ! ! Set up the start point in X if the increment is not unity. This ! will be ( N - 1 )*INCX too small for descending loops. ! if (incx.le.0) then kx = 1 - (n-1)*incx elseif (incx.ne.1) then kx = 1 endif ! ! Start the operations. In this version the elements of AP are ! accessed sequentially with one pass through AP. ! if (lsame(trans,'N')) then ! ! Form x := inv( A )*x. ! if (lsame(uplo,'U')) then kk = (n* (n+1))/2 if (incx.eq.1) then do j = n,1,-1 if (x(j).ne.zero) then if (nounit) x(j) = x(j)/ap(kk) temp = x(j) k = kk - 1 do i = j - 1,1,-1 x(i) = x(i) - temp*ap(k) k = k - 1 enddo endif kk = kk - j enddo else jx = kx + (n-1)*incx do j = n,1,-1 if (x(jx).ne.zero) then if (nounit) x(jx) = x(jx)/ap(kk) temp = x(jx) ix = jx do k = kk - 1,kk - j + 1,-1 ix = ix - incx x(ix) = x(ix) - temp*ap(k) enddo endif jx = jx - incx kk = kk - j enddo endif else kk = 1 if (incx.eq.1) then do j = 1,n if (x(j).ne.zero) then if (nounit) x(j) = x(j)/ap(kk) temp = x(j) k = kk + 1 do i = j + 1,n x(i) = x(i) - temp*ap(k) k = k + 1 enddo endif kk = kk + (n-j+1) enddo else jx = kx do j = 1,n if (x(jx).ne.zero) then if (nounit) x(jx) = x(jx)/ap(kk) temp = x(jx) ix = jx do k = kk + 1,kk + n - j ix = ix + incx x(ix) = x(ix) - temp*ap(k) enddo endif jx = jx + incx kk = kk + (n-j+1) enddo endif endif else ! ! Form x := inv( A**T )*x. ! if (lsame(uplo,'U')) then kk = 1 if (incx.eq.1) then do j = 1,n temp = x(j) k = kk do i = 1,j - 1 temp = temp - ap(k)*x(i) k = k + 1 enddo if (nounit) temp = temp/ap(kk+j-1) x(j) = temp kk = kk + j enddo else jx = kx do j = 1,n temp = x(jx) ix = kx do k = kk,kk + j - 2 temp = temp - ap(k)*x(ix) ix = ix + incx enddo if (nounit) temp = temp/ap(kk+j-1) x(jx) = temp jx = jx + incx kk = kk + j enddo endif else kk = (n* (n+1))/2 if (incx.eq.1) then do j = n,1,-1 temp = x(j) k = kk do i = n,j + 1,-1 temp = temp - ap(k)*x(i) k = k - 1 enddo if (nounit) temp = temp/ap(kk-n+j) x(j) = temp kk = kk - (n-j+1) enddo else kx = kx + (n-1)*incx jx = kx do j = n,1,-1 temp = x(jx) ix = kx do k = kk,kk - (n- (j+1)),-1 temp = temp - ap(k)*x(ix) ix = ix - incx enddo if (nounit) temp = temp/ap(kk-n+j) x(jx) = temp jx = jx - incx kk = kk - (n-j+1) enddo endif endif endif ! end subroutine dtpsv !> !!##NAME !! dtrmm(3f) - [BLAS:DOUBLE_BLAS_LEVEL3] !! !!##SYNOPSIS !! !! subroutine dtrmm(side,uplo,transa,diag,m,n,alpha,a,lda,b,ldb) !! !! .. Scalar Arguments .. !! double precision,intent(in) :: alpha !! integer,intent(in) :: lda,ldb,m,n !! character,intent(in) :: diag,side,transa,uplo !! .. !! .. Array Arguments .. !! double precision,intent(in) :: a(lda,*) !! double precision,intent(inout) :: b(ldb,*) !! .. !! !!##DEFINITION !! !! 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**T. !! !!##OPTIONS !! !! SIDE !! !! SIDE is 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 ). !! !! UPLO !! !! UPLO is 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. !! !! TRANSA !! !! TRANSA is 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**T. !! !! TRANSA = 'C' or 'c' op( A ) = A**T. !! !! DIAG !! !! DIAG is 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. !! !! M !! !! M is INTEGER !! On entry, M specifies the number of rows of B. M must be at !! least zero. !! !! N !! !! N is INTEGER !! On entry, N specifies the number of columns of B. N must be !! at least zero. !! !! ALPHA !! !! ALPHA is 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. !! !! A !! !! A is DOUBLE PRECISION array, 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. !! !! LDA !! !! LDA is 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 ). !! !! B !! !! B is DOUBLE PRECISION array, 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 !! !! LDB is 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 ). !! !!##AUTHORS !! !! + Univ. of Tennessee !! + Univ. of California Berkeley !! + Univ. of Colorado Denver !! + NAG Ltd. !! !! date:December 2016 !! !! FURTHER DETAILS !! !! 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. !! !!##SEE ALSO !! Online html documentation available at !! http://www.netlib.org/lapack/explore-html/ ! ===================================================================== subroutine dtrmm(side,uplo,transa,diag,m,n,alpha,a,lda,b,ldb) implicit none ! ! -- Reference BLAS level3 routine (version 3.7.0) -- ! -- Reference BLAS is a software package provided by Univ. of Tennessee, -- ! -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- ! December 2016 ! ! .. Scalar Arguments .. double precision,intent(in) :: alpha integer,intent(in) :: lda,ldb,m,n character,intent(in) :: diag,side,transa,uplo ! .. ! .. Array Arguments .. double precision,intent(in) :: a(lda,*) double precision,intent(inout) :: b(ldb,*) ! .. ! ! ===================================================================== ! ! .. External Functions .. ! .. ! .. External Subroutines .. ! .. ! .. Intrinsic Functions .. intrinsic max ! .. ! .. Local Scalars .. double precision temp integer i,info,j,k,nrowa logical lside,nounit,upper ! .. ! .. Parameters .. double precision one,zero parameter (one=1.0d+0,zero=0.0d+0) ! .. ! ! Test the input parameters. ! lside = lsame(side,'L') if (lside) then nrowa = m else nrowa = n endif nounit = lsame(diag,'N') upper = lsame(uplo,'U') ! info = 0 if ((.not.lside) .and. (.not.lsame(side,'R'))) then info = 1 elseif ((.not.upper) .and. (.not.lsame(uplo,'L'))) then info = 2 elseif ((.not.lsame(transa,'N')) .and. (.not.lsame(transa,'T')) .and. (.not.lsame(transa,'C'))) then info = 3 elseif ((.not.lsame(diag,'U')) .and. (.not.lsame(diag,'N'))) then info = 4 elseif (m.lt.0) then info = 5 elseif (n.lt.0) then info = 6 elseif (lda.lt.max(1,nrowa)) then info = 9 elseif (ldb.lt.max(1,m)) then info = 11 endif if (info.ne.0) then call xerbla('DTRMM ',info) return endif ! ! Quick return if possible. ! if (m.eq.0 .or. n.eq.0) return ! ! And when alpha.eq.zero. ! if (alpha.eq.zero) then b(1:m,1:n) = zero return endif ! ! Start the operations. ! if (lside) then if (lsame(transa,'N')) then ! ! Form B := alpha*A*B. ! if (upper) then do j = 1,n do k = 1,m if (b(k,j).ne.zero) then temp = alpha*b(k,j) do i = 1,k - 1 b(i,j) = b(i,j) + temp*a(i,k) enddo if (nounit) temp = temp*a(k,k) b(k,j) = temp endif enddo enddo else do j = 1,n do k = m,1,-1 if (b(k,j).ne.zero) then temp = alpha*b(k,j) b(k,j) = temp if (nounit) b(k,j) = b(k,j)*a(k,k) do i = k + 1,m b(i,j) = b(i,j) + temp*a(i,k) enddo endif enddo enddo endif else ! ! Form B := alpha*A**T*B. ! if (upper) then do j = 1,n do i = m,1,-1 temp = b(i,j) if (nounit) temp = temp*a(i,i) do k = 1,i - 1 temp = temp + a(k,i)*b(k,j) enddo b(i,j) = alpha*temp enddo enddo else do j = 1,n do i = 1,m temp = b(i,j) if (nounit) temp = temp*a(i,i) do k = i + 1,m temp = temp + a(k,i)*b(k,j) enddo b(i,j) = alpha*temp enddo enddo endif endif else if (lsame(transa,'N')) then ! ! Form B := alpha*B*A. ! if (upper) then do j = n,1,-1 temp = alpha if (nounit) temp = temp*a(j,j) b(1:m,j) = temp*b(1:m,j) do k = 1,j - 1 if (a(k,j).ne.zero) then temp = alpha*a(k,j) b(1:m,j) = b(1:m,j) + temp*b(1:m,k) endif enddo enddo else do j = 1,n temp = alpha if (nounit) temp = temp*a(j,j) b(1:m,j) = temp*b(1:m,j) do k = j + 1,n if (a(k,j).ne.zero) then temp = alpha*a(k,j) b(1:m,j) = b(1:m,j) + temp*b(1:m,k) endif enddo enddo endif else ! ! Form B := alpha*B*A**T. ! if (upper) then do k = 1,n do j = 1,k - 1 if (a(j,k).ne.zero) then temp = alpha*a(j,k) b(1:m,j) = b(1:m,j) + temp*b(1:m,k) endif enddo temp = alpha if (nounit) temp = temp*a(k,k) if (temp.ne.one) then b(1:m,k) = temp*b(1:m,k) endif enddo else do k = n,1,-1 do j = k + 1,n if (a(j,k).ne.zero) then temp = alpha*a(j,k) b(1:m,j) = b(1:m,j) + temp*b(1:m,k) endif enddo temp = alpha if (nounit) temp = temp*a(k,k) if (temp.ne.one) then b(1:m,k) = temp*b(1:m,k) endif enddo endif endif endif ! end subroutine dtrmm !> !!##NAME !! dtrmv(3f) - [BLAS:DOUBLE_BLAS_LEVEL2] !! !!##SYNOPSIS !! !! subroutine dtrmv(uplo,trans,diag,n,a,lda,x,incx) !! !! .. Scalar Arguments .. !! integer,intent(in) :: incx,lda,n !! character,intent(in) :: diag,trans,uplo !! .. !! .. Array Arguments .. !! double precision,intent(in) :: a(lda,*) !! double precision,intent(inout) :: x(*) !! .. !! !!##DEFINITION !! !! DTRMV performs one of the matrix-vector operations !! !! x := A*x, or x := A**T*x, !! !! where x is an n element vector and A is an n by n unit, or non-unit, !! upper or lower triangular matrix. !! !!##OPTIONS !! !! UPLO !! !! UPLO is 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. !! !! TRANS !! !! TRANS is 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**T*x. !! !! TRANS = 'C' or 'c' x := A**T*x. !! !! DIAG !! !! DIAG is 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. !! !! N !! !! N is INTEGER !! On entry, N specifies the order of the matrix A. !! N must be at least zero. !! !! A !! !! A is DOUBLE PRECISION array, 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. !! !! LDA !! !! LDA is 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 ). !! !! X !! !! X is DOUBLE PRECISION array, 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 !! transformed vector x. !! !! INCX !! !! INCX is INTEGER !! On entry, INCX specifies the increment for the elements of !! X. INCX must not be zero. !! !!##AUTHORS !! !! + Univ. of Tennessee !! + Univ. of California Berkeley !! + Univ. of Colorado Denver !! + NAG Ltd. !! !! date:December 2016 !! !! FURTHER DETAILS !! !! Level 2 Blas routine. !! The vector and matrix arguments are not referenced when N = 0, or M = 0 !! !! -- 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. !! !!##SEE ALSO !! Online html documentation available at !! http://www.netlib.org/lapack/explore-html/ ! ===================================================================== subroutine dtrmv(uplo,trans,diag,n,a,lda,x,incx) implicit none ! ! -- Reference BLAS level2 routine (version 3.7.0) -- ! -- Reference BLAS is a software package provided by Univ. of Tennessee, -- ! -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- ! December 2016 ! ! .. Scalar Arguments .. integer,intent(in) :: incx,lda,n character,intent(in) :: diag,trans,uplo ! .. ! .. Array Arguments .. double precision,intent(in) :: a(lda,*) double precision,intent(inout) :: x(*) ! .. ! ! ===================================================================== ! ! .. Parameters .. double precision zero parameter (zero=0.0d+0) ! .. ! .. Local Scalars .. double precision temp integer i,info,ix,j,jx,kx logical nounit ! .. ! .. External Functions .. ! .. ! .. External Subroutines .. ! .. ! .. Intrinsic Functions .. intrinsic max ! .. ! ! Test the input parameters. ! info = 0 if (.not.lsame(uplo,'U') .and. .not.lsame(uplo,'L')) then info = 1 elseif (.not.lsame(trans,'N') .and. .not.lsame(trans,'T') .and. .not.lsame(trans,'C')) then info = 2 elseif (.not.lsame(diag,'U') .and. .not.lsame(diag,'N')) then info = 3 elseif (n.lt.0) then info = 4 elseif (lda.lt.max(1,n)) then info = 6 elseif (incx.eq.0) then info = 8 endif if (info.ne.0) then call xerbla('DTRMV ',info) return endif ! ! Quick return if possible. ! if (n.eq.0) return ! nounit = lsame(diag,'N') ! ! Set up the start point in X if the increment is not unity. This ! will be ( N - 1 )*INCX too small for descending loops. ! if (incx.le.0) then kx = 1 - (n-1)*incx elseif (incx.ne.1) then kx = 1 endif ! ! Start the operations. In this version the elements of A are ! accessed sequentially with one pass through A. ! if (lsame(trans,'N')) then ! ! Form x := A*x. ! if (lsame(uplo,'U')) then if (incx.eq.1) then do j = 1,n if (x(j).ne.zero) then temp = x(j) do i = 1,j - 1 x(i) = x(i) + temp*a(i,j) enddo if (nounit) x(j) = x(j)*a(j,j) endif enddo else jx = kx do j = 1,n if (x(jx).ne.zero) then temp = x(jx) ix = kx do i = 1,j - 1 x(ix) = x(ix) + temp*a(i,j) ix = ix + incx enddo if (nounit) x(jx) = x(jx)*a(j,j) endif jx = jx + incx enddo endif else if (incx.eq.1) then do j = n,1,-1 if (x(j).ne.zero) then temp = x(j) do i = n,j + 1,-1 x(i) = x(i) + temp*a(i,j) enddo if (nounit) x(j) = x(j)*a(j,j) endif enddo else kx = kx + (n-1)*incx jx = kx do j = n,1,-1 if (x(jx).ne.zero) then temp = x(jx) ix = kx do i = n,j + 1,-1 x(ix) = x(ix) + temp*a(i,j) ix = ix - incx enddo if (nounit) x(jx) = x(jx)*a(j,j) endif jx = jx - incx enddo endif endif else ! ! Form x := A**T*x. ! if (lsame(uplo,'U')) then if (incx.eq.1) then do j = n,1,-1 temp = x(j) if (nounit) temp = temp*a(j,j) do i = j - 1,1,-1 temp = temp + a(i,j)*x(i) enddo x(j) = temp enddo else jx = kx + (n-1)*incx do j = n,1,-1 temp = x(jx) ix = jx if (nounit) temp = temp*a(j,j) do i = j - 1,1,-1 ix = ix - incx temp = temp + a(i,j)*x(ix) enddo x(jx) = temp jx = jx - incx enddo endif else if (incx.eq.1) then do j = 1,n temp = x(j) if (nounit) temp = temp*a(j,j) do i = j + 1,n temp = temp + a(i,j)*x(i) enddo x(j) = temp enddo else jx = kx do j = 1,n temp = x(jx) ix = jx if (nounit) temp = temp*a(j,j) do i = j + 1,n ix = ix + incx temp = temp + a(i,j)*x(ix) enddo x(jx) = temp jx = jx + incx enddo endif endif endif ! end subroutine dtrmv !> !!##NAME !! dtrsm(3f) - [BLAS:DOUBLE_BLAS_LEVEL3] !! !!##SYNOPSIS !! !! subroutine dtrsm(side,uplo,transa,diag,m,n,alpha,a,lda,b,ldb) !! !! .. Scalar Arguments .. !! double precision,intent(in) :: alpha !! integer,intent(in) :: lda,ldb,m,n !! character,intent(in) :: diag,side,transa,uplo !! .. !! .. Array Arguments .. !! double precision,intent(in) :: a(lda,*) !! double precision,intent(inout) :: b(ldb,*) !! .. !! !!##DEFINITION !! !! 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**T. !! !! The matrix X is overwritten on B. !! !!##OPTIONS !! !! SIDE !! !! SIDE is 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. !! !! UPLO !! !! UPLO is 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. !! !! TRANSA !! !! TRANSA is 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**T. !! !! TRANSA = 'C' or 'c' op( A ) = A**T. !! !! DIAG !! !! DIAG is 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. !! !! M !! !! M is INTEGER !! On entry, M specifies the number of rows of B. M must be at !! least zero. !! !! N !! !! N is INTEGER !! On entry, N specifies the number of columns of B. N must be !! at least zero. !! !! ALPHA !! !! ALPHA is 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. !! !! A !! !! A is DOUBLE PRECISION array, dimension ( LDA, k ), !! !! where k is m when SIDE = 'L' or 'l' !! and k 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. !! !! LDA !! 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 ). !! !! B !! 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 !! On entry, LDB specifies the first dimension of B as declared !! in the calling (sub) program. LDB must be at least !! max( 1, m ). !! !!##AUTHORS !! !! + Univ. of Tennessee !! + Univ. of California Berkeley !! + Univ. of Colorado Denver !! + NAG Ltd. !! !! date:December 2016 !! !! FURTHER DETAILS !! !! 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. !! !!##SEE ALSO !! Online html documentation available at !! http://www.netlib.org/lapack/explore-html/ ! ===================================================================== subroutine dtrsm(side,uplo,transa,diag,m,n,alpha,a,lda,b,ldb) implicit none ! ! -- Reference BLAS level3 routine (version 3.7.0) -- ! -- Reference BLAS is a software package provided by Univ. of Tennessee, -- ! -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- ! December 2016 ! ! .. Scalar Arguments .. double precision,intent(in) :: alpha integer,intent(in) :: lda,ldb,m,n character,intent(in) :: diag,side,transa,uplo ! .. ! .. Array Arguments .. double precision,intent(in) :: a(lda,*) double precision,intent(inout) :: b(ldb,*) ! .. ! ! ===================================================================== ! ! .. External Functions .. ! .. ! .. External Subroutines .. ! .. ! .. Intrinsic Functions .. intrinsic max ! .. ! .. Local Scalars .. double precision temp integer i,info,j,k,nrowa logical lside,nounit,upper ! .. ! .. Parameters .. double precision one,zero parameter (one=1.0d+0,zero=0.0d+0) ! .. ! ! Test the input parameters. ! lside = lsame(side,'L') if (lside) then nrowa = m else nrowa = n endif nounit = lsame(diag,'N') upper = lsame(uplo,'U') ! info = 0 if ((.not.lside) .and. (.not.lsame(side,'R'))) then info = 1 elseif ((.not.upper) .and. (.not.lsame(uplo,'L'))) then info = 2 elseif ((.not.lsame(transa,'N')) .and. (.not.lsame(transa,'T')) .and. (.not.lsame(transa,'C'))) then info = 3 elseif ((.not.lsame(diag,'U')) .and. (.not.lsame(diag,'N'))) then info = 4 elseif (m.lt.0) then info = 5 elseif (n.lt.0) then info = 6 elseif (lda.lt.max(1,nrowa)) then info = 9 elseif (ldb.lt.max(1,m)) then info = 11 endif if (info.ne.0) then call xerbla('DTRSM ',info) return endif ! ! Quick return if possible. ! if (m.eq.0 .or. n.eq.0) return ! ! And when alpha.eq.zero. ! if (alpha.eq.zero) then b(1:m,1:n) = zero return endif ! ! Start the operations. ! if (lside) then if (lsame(transa,'N')) then ! ! Form B := alpha*inv( A )*B. ! if (upper) then do j = 1,n if (alpha.ne.one) then b(1:m,j) = alpha*b(1:m,j) endif do k = m,1,-1 if (b(k,j).ne.zero) then if (nounit) b(k,j) = b(k,j)/a(k,k) do i = 1,k - 1 b(i,j) = b(i,j) - b(k,j)*a(i,k) enddo endif enddo enddo else do j = 1,n if (alpha.ne.one) then b(1:m,j) = alpha*b(1:m,j) endif do k = 1,m if (b(k,j).ne.zero) then if (nounit) b(k,j) = b(k,j)/a(k,k) do i = k + 1,m b(i,j) = b(i,j) - b(k,j)*a(i,k) enddo endif enddo enddo endif else ! ! Form B := alpha*inv( A**T )*B. ! if (upper) then do j = 1,n do i = 1,m temp = alpha*b(i,j) do k = 1,i - 1 temp = temp - a(k,i)*b(k,j) enddo if (nounit) temp = temp/a(i,i) b(i,j) = temp enddo enddo else do j = 1,n do i = m,1,-1 temp = alpha*b(i,j) do k = i + 1,m temp = temp - a(k,i)*b(k,j) enddo if (nounit) temp = temp/a(i,i) b(i,j) = temp enddo enddo endif endif else if (lsame(transa,'N')) then ! ! Form B := alpha*B*inv( A ). ! if (upper) then do j = 1,n if (alpha.ne.one) then b(1:m,j) = alpha*b(1:m,j) endif do k = 1,j - 1 if (a(k,j).ne.zero) then b(1:m,j) = b(1:m,j) - a(k,j)*b(1:m,k) endif enddo if (nounit) then temp = one/a(j,j) b(1:m,j) = temp*b(1:m,j) endif enddo else do j = n,1,-1 if (alpha.ne.one) then b(1:m,j) = alpha*b(1:m,j) endif do k = j + 1,n if (a(k,j).ne.zero) then b(1:m,j) = b(1:m,j) - a(k,j)*b(1:m,k) endif enddo if (nounit) then temp = one/a(j,j) b(1:m,j) = temp*b(1:m,j) endif enddo endif else ! ! Form B := alpha*B*inv( A**T ). ! if (upper) then do k = n,1,-1 if (nounit) then temp = one/a(k,k) b(1:m,k) = temp*b(1:m,k) endif do j = 1,k - 1 if (a(j,k).ne.zero) then temp = a(j,k) b(1:m,j) = b(1:m,j) - temp*b(1:m,k) endif enddo if (alpha.ne.one) then b(1:m,k) = alpha*b(1:m,k) endif enddo else do k = 1,n if (nounit) then temp = one/a(k,k) b(1:m,k) = temp*b(1:m,k) endif do j = k + 1,n if (a(j,k).ne.zero) then temp = a(j,k) b(1:m,j) = b(1:m,j) - temp*b(1:m,k) endif enddo if (alpha.ne.one) then b(1:m,k) = alpha*b(1:m,k) endif enddo endif endif endif ! end subroutine dtrsm !> !!##NAME !! dtrsv(3f) - [BLAS:DOUBLE_BLAS_LEVEL1] !! !!##SYNOPSIS !! !! subroutine dtrsv(uplo,trans,diag,n,a,lda,x,incx) !! !! .. Scalar Arguments .. !! integer,intent(in) :: incx,lda,n !! character,intent(in) :: diag,trans,uplo !! .. !! .. Array Arguments .. !! double precision,intent(in) :: a(lda,*) !! double precision,intent(inout) :: x(*) !! .. !! !!##DEFINITION !! !! DTRSV solves one of the systems of equations !! !! A*x = b, or A**T*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. !! !!##OPTIONS !! !! UPLO !! !! UPLO is 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. !! !! TRANS !! !! TRANS is 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**T*x = b. !! !! TRANS = 'C' or 'c' A**T*x = b. !! !! DIAG !! !! DIAG is 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. !! !! N !! !! N is INTEGER !! On entry, N specifies the order of the matrix A. !! N must be at least zero. !! !! A !! !! A is DOUBLE PRECISION array, 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. !! !! LDA !! !! LDA is 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 ). !! !! X !! !! X is DOUBLE PRECISION array, 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 !! !! INCX is INTEGER !! On entry, INCX specifies the increment for the elements of !! X. INCX must not be zero. !! !! 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. !! !!##AUTHORS !! !! + Univ. of Tennessee !! + Univ. of California Berkeley !! + Univ. of Colorado Denver !! + NAG Ltd. !! !! date:December 2016 !! !!##SEE ALSO !! Online html documentation available at !! http://www.netlib.org/lapack/explore-html/ ! ===================================================================== subroutine dtrsv(uplo,trans,diag,n,a,lda,x,incx) implicit none ! ! -- Reference BLAS level1 routine (version 3.7.0) -- ! -- Reference BLAS is a software package provided by Univ. of Tennessee, -- ! -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- ! December 2016 ! ! .. Scalar Arguments .. integer,intent(in) :: incx,lda,n character,intent(in) :: diag,trans,uplo ! .. ! .. Array Arguments .. double precision,intent(in) :: a(lda,*) double precision,intent(inout) :: x(*) ! .. ! ! ===================================================================== ! ! .. Parameters .. double precision zero parameter (zero=0.0d+0) ! .. ! .. Local Scalars .. double precision temp integer i,info,ix,j,jx,kx logical nounit ! .. ! .. External Functions .. ! .. ! .. External Subroutines .. ! .. ! .. Intrinsic Functions .. intrinsic max ! .. ! ! Test the input parameters. ! info = 0 if (.not.lsame(uplo,'U') .and. .not.lsame(uplo,'L')) then info = 1 elseif (.not.lsame(trans,'N') .and. .not.lsame(trans,'T') .and. .not.lsame(trans,'C')) then info = 2 elseif (.not.lsame(diag,'U') .and. .not.lsame(diag,'N')) then info = 3 elseif (n.lt.0) then info = 4 elseif (lda.lt.max(1,n)) then info = 6 elseif (incx.eq.0) then info = 8 endif if (info.ne.0) then call xerbla('DTRSV ',info) return endif ! ! Quick return if possible. ! if (n.eq.0) return ! nounit = lsame(diag,'N') ! ! Set up the start point in X if the increment is not unity. This ! will be ( N - 1 )*INCX too small for descending loops. ! if (incx.le.0) then kx = 1 - (n-1)*incx elseif (incx.ne.1) then kx = 1 endif ! ! Start the operations. In this version the elements of A are ! accessed sequentially with one pass through A. ! if (lsame(trans,'N')) then ! ! Form x := inv( A )*x. ! if (lsame(uplo,'U')) then if (incx.eq.1) then do j = n,1,-1 if (x(j).ne.zero) then if (nounit) x(j) = x(j)/a(j,j) temp = x(j) do i = j - 1,1,-1 x(i) = x(i) - temp*a(i,j) enddo endif enddo else jx = kx + (n-1)*incx do j = n,1,-1 if (x(jx).ne.zero) then if (nounit) x(jx) = x(jx)/a(j,j) temp = x(jx) ix = jx do i = j - 1,1,-1 ix = ix - incx x(ix) = x(ix) - temp*a(i,j) enddo endif jx = jx - incx enddo endif else if (incx.eq.1) then do j = 1,n if (x(j).ne.zero) then if (nounit) x(j) = x(j)/a(j,j) temp = x(j) do i = j + 1,n x(i) = x(i) - temp*a(i,j) enddo endif enddo else jx = kx do j = 1,n if (x(jx).ne.zero) then if (nounit) x(jx) = x(jx)/a(j,j) temp = x(jx) ix = jx do i = j + 1,n ix = ix + incx x(ix) = x(ix) - temp*a(i,j) enddo endif jx = jx + incx enddo endif endif else ! ! Form x := inv( A**T )*x. ! if (lsame(uplo,'U')) then if (incx.eq.1) then do j = 1,n temp = x(j) do i = 1,j - 1 temp = temp - a(i,j)*x(i) enddo if (nounit) temp = temp/a(j,j) x(j) = temp enddo else jx = kx do j = 1,n temp = x(jx) ix = kx do i = 1,j - 1 temp = temp - a(i,j)*x(ix) ix = ix + incx enddo if (nounit) temp = temp/a(j,j) x(jx) = temp jx = jx + incx enddo endif else if (incx.eq.1) then do j = n,1,-1 temp = x(j) do i = n,j + 1,-1 temp = temp - a(i,j)*x(i) enddo if (nounit) temp = temp/a(j,j) x(j) = temp enddo else kx = kx + (n-1)*incx jx = kx do j = n,1,-1 temp = x(jx) ix = kx do i = n,j + 1,-1 temp = temp - a(i,j)*x(ix) ix = ix - incx enddo if (nounit) temp = temp/a(j,j) x(jx) = temp jx = jx - incx enddo endif endif endif end subroutine dtrsv !> !!##NAME !! dzasum(3f) - [BLAS:DOUBLE_BLAS_LEVEL1] !! !!##SYNOPSIS !! !! double precision function dzasum(n,zx,incx) !! !! .. Scalar Arguments .. !! integer,intent(in) :: incx,n !! .. !! .. Array Arguments .. !! complex(kind=real64),intent(inout) :: zx(*) !! .. !! !!##DEFINITION !! !! DZASUM takes the sum of the (|Re(.)| + |Im(.)|)'s of a complex vector and !! returns a double precision result. !! !!##OPTIONS !! !! N !! !! N is INTEGER !! number of elements in input vector(s) !! !! ZX !! !! ZX is complex(kind=real64) array, dimension ( 1 + ( N - 1 )*abs( INCX ) ) !! !! INCX !! !! INCX is INTEGER !! storage spacing between elements of ZX !! !!##AUTHORS !! !! + Univ. of Tennessee !! + Univ. of California Berkeley !! + Univ. of Colorado Denver !! + NAG Ltd. !! !! date:November 2017 !! !! FURTHER DETAILS !! !! jack dongarra, 3/11/78. !! modified 3/93 to return if incx .le. 0. !! modified 12/3/93, array(1) declarations changed to array(*) !! !!##SEE ALSO !! Online html documentation available at !! http://www.netlib.org/lapack/explore-html/ ! ===================================================================== double precision function dzasum(n,zx,incx) implicit none ! ! -- Reference BLAS level1 routine (version 3.8.0) -- ! -- Reference BLAS is a software package provided by Univ. of Tennessee, -- ! -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- ! November 2017 ! ! .. Scalar Arguments .. integer,intent(in) :: incx,n ! .. ! .. Array Arguments .. complex(kind=real64),intent(inout) :: zx(*) ! .. ! ! ===================================================================== ! ! .. Local Scalars .. double precision stemp integer i,nincx ! .. ! .. External Functions .. DOUBLE PRECISION DCABS1 ! .. dzasum = 0.0d0 stemp = 0.0d0 if (n.le.0 .or. incx.le.0) return if (incx.eq.1) then ! ! code for increment equal to 1 ! do i = 1,n stemp = stemp + dcabs1(zx(i)) enddo else ! ! code for increment not equal to 1 ! nincx = n*incx do i = 1,nincx,incx stemp = stemp + dcabs1(zx(i)) enddo endif dzasum = stemp end function dzasum !> !!##NAME !! dznrm2(3f) - [BLAS:SINGLE_BLAS_LEVEL1] !! !!##SYNOPSIS !! !! double precision function dznrm2(n,x,incx) !! !! .. Scalar Arguments .. !! integer,intent(in) :: incx, n !! .. !! !!##DEFINITION !! !! DZNRM2 returns the euclidean norm of a vector via the function !! name, so that !! !! DZNRM2 := sqrt( x**H*x ) !! !!##OPTIONS !! !! N !! number of elements in input vector(s) !! X !! array, dimension (N) complex vector with N elements !! INCX !! INCX is INTEGER, storage spacing between elements of X !! !! If INCX > 0, X(1+(i-1)*INCX) = x(i) for 1 <= i <= n !! If INCX < 0, X(1-(n-i)*INCX) = x(i) for 1 <= i <= n !! If INCX = 0, x isn't a vector so there is no need to call !! !! this subroutine. If you call it anyway, it will count x(1) !! in the vector norm N times. !! !!##AUTHORS !! !! + Edward Anderson, Lockheed Martin !! !! date:August 2016 !! !! \par Contributors: !! !! Weslley Pereira, University of Colorado Denver, USA !! !! FURTHER DETAILS !! !! Anderson E. (2017) !! Algorithm 978: Safe Scaling in the Level 1 BLAS !! ACM Trans Math Softw 44:1--28 !! https://doi.org/10.1145/3061665 !! !! Blue, James L. (1978) !! A Portable Fortran Program to Find the Euclidean Norm of a Vector !! ACM Trans Math Softw 4:15--23 !! https://doi.org/10.1145/355769.355771 !! !!##SEE ALSO !! Online html documentation available at !! http://www.netlib.org/lapack/explore-html/ ! ===================================================================== pure function dznrm2( n, x, incx ) integer, parameter :: wp = kind(1.d0) real(wp) :: dznrm2 ! ! -- Reference BLAS level1 routine (version 3.9.1) -- ! -- Reference BLAS is a software package provided by Univ. of Tennessee, -- ! -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- ! March 2021 ! ! .. Constants .. real(wp), parameter :: zero = 0.0_wp real(wp), parameter :: one = 1.0_wp real(wp), parameter :: maxn = huge(0.0_wp) ! .. ! .. Blue's scaling constants .. real(wp), parameter :: tsml = real(radix(0._wp), wp)**ceiling( (minexponent(0._wp) - 1) * 0.5_wp) real(wp), parameter :: tbig = real(radix(0._wp), wp)**floor( (maxexponent(0._wp) - digits(0._wp) + 1) * 0.5_wp) real(wp), parameter :: ssml = real(radix(0._wp), wp)**( - floor( (minexponent(0._wp) - 1) * 0.5_wp)) real(wp), parameter :: sbig = real(radix(0._wp), wp)**( - ceiling( (maxexponent(0._wp) - digits(0._wp) + 1) * 0.5_wp)) ! .. ! .. Scalar Arguments .. integer,intent(in) :: incx, n ! .. ! .. Array Arguments .. complex(wp),intent(in) :: x(*) ! .. ! .. Local Scalars .. integer :: i, ix logical :: notbig real(wp) :: abig, amed, asml, ax, scl, sumsq, ymax, ymin ! ! Quick return if possible ! dznrm2 = zero if( n <= 0 ) return ! scl = one sumsq = zero ! ! Compute the sum of squares in 3 accumulators: ! abig -- sums of squares scaled down to avoid overflow ! asml -- sums of squares scaled up to avoid underflow ! amed -- sums of squares that do not require scaling ! The thresholds and multipliers are ! tbig -- values bigger than this are scaled down by sbig ! tsml -- values smaller than this are scaled up by ssml ! notbig = .true. asml = zero amed = zero abig = zero ix = 1 if( incx < 0 ) ix = 1 - (n-1)*incx do i = 1, n ax = abs(real(x(ix))) if (ax > tbig) then abig = abig + (ax*sbig)**2 notbig = .false. elseif (ax < tsml) then if (notbig) asml = asml + (ax*ssml)**2 else amed = amed + ax**2 endif ax = abs(aimag(x(ix))) if (ax > tbig) then abig = abig + (ax*sbig)**2 notbig = .false. elseif (ax < tsml) then if (notbig) asml = asml + (ax*ssml)**2 else amed = amed + ax**2 endif ix = ix + incx enddo ! ! Combine abig and amed or amed and asml if more than one ! accumulator was used. ! if (abig > zero) then ! ! Combine abig and amed if abig > 0. ! if ( (amed > zero) .or. (amed > maxn) .or. (amed /= amed) ) then abig = abig + (amed*sbig)*sbig endif scl = one / sbig sumsq = abig elseif (asml > zero) then ! ! Combine amed and asml if asml > 0. ! if ( (amed > zero) .or. (amed > maxn) .or. (amed /= amed) ) then amed = sqrt(amed) asml = sqrt(asml) / ssml if (asml > amed) then ymin = amed ymax = asml else ymin = asml ymax = amed endif scl = one sumsq = ymax**2*( one + (ymin/ymax)**2 ) else scl = one / ssml sumsq = asml endif else ! ! Otherwise all values are mid-range ! scl = one sumsq = amed endif dznrm2 = scl*sqrt( sumsq ) end function dznrm2 !> !!##NAME !! icamax(3f) -- [BLAS:AUX_BLAS] Return index of maximum "absolute value" in CX. !! !!##SYNOPSIS !! !! integer function icamax(n,cx,incx) !! !! .. scalar arguments .. !! integer,intent(in) :: incx,n !! .. !! .. array arguments .. !! complex,intent(in) :: cx(*) !! .. !! !!##DEFINITION !! !! ICAMAX finds the index of the first element having maximum |Re(.)| + |Im(.)| !! !!##OPTIONS !! !! N !! !! N is INTEGER !! number of elements in input vector(s) !! !! CX !! !! CX is COMPLEX array, dimension ( 1 + ( N - 1 )*abs( INCX ) ) !! !! INCX !! !! INCX is INTEGER !! storage spacing between elements of CX !! !!##AUTHORS !! !! + Univ. of Tennessee !! + Univ. of California Berkeley !! + Univ. of Colorado Denver !! + NAG Ltd. !! !! date:November 2017 !! !! FURTHER DETAILS !! !! 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(*) !! !!##SEE ALSO !! Online html documentation available at !! http://www.netlib.org/lapack/explore-html/ ! ===================================================================== pure integer function icamax(n,cx,incx) implicit none ! ! -- Reference BLAS level1 routine (version 3.8.0) -- ! -- Reference BLAS is a software package provided by Univ. of Tennessee, -- ! -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- ! November 2017 ! ! .. Scalar Arguments .. integer,intent(in) :: incx,n ! .. ! .. Array Arguments .. complex,intent(in) :: cx(*) ! .. ! ===================================================================== ! .. Local Scalars .. real smax integer i,ix ! .. ! .. External Functions .. REAL SCABS1 ! .. icamax = 0 if (n.lt.1 .or. incx.le.0) return icamax = 1 if (n.eq.1) return if (incx.eq.1) then ! ! code for increment equal to 1 ! smax = scabs1(cx(1)) do i = 2,n if (scabs1(cx(i)).gt.smax) then icamax = i smax = scabs1(cx(i)) endif enddo else ! ! code for increment not equal to 1 ! ix = 1 smax = scabs1(cx(1)) ix = ix + incx do i = 2,n if (scabs1(cx(ix)).gt.smax) then icamax = i smax = scabs1(cx(ix)) endif ix = ix + incx enddo endif end function icamax !> !!##NAME !! idamax(3f) - [BLAS:AUX_BLAS] !! !!##SYNOPSIS !! !! integer function idamax(n,dx,incx) !! !! .. Scalar Arguments .. !! integer,intent(in) :: incx,n !! .. !! .. Array Arguments .. !! double precision,intent(in) :: dx(*) !! .. !! !!##DEFINITION !! !! IDAMAX finds the index of the first element having maximum absolute value. !! !!##OPTIONS !! !! N !! !! N is INTEGER !! number of elements in input vector(s) !! !! DX !! !! DX is DOUBLE PRECISION array, dimension ( 1 + ( N - 1 )*abs( INCX ) ) !! !! INCX !! !! INCX is INTEGER !! storage spacing between elements of DX !! !!##AUTHORS !! !! + Univ. of Tennessee !! + Univ. of California Berkeley !! + Univ. of Colorado Denver !! + NAG Ltd. !! !! date:November 2017 !! !! FURTHER DETAILS !! !! 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(*) !! !!##SEE ALSO !! Online html documentation available at !! http://www.netlib.org/lapack/explore-html/ ! ===================================================================== pure integer function idamax(n,dx,incx) implicit none ! ! -- Reference BLAS level1 routine (version 3.8.0) -- ! -- Reference BLAS is a software package provided by Univ. of Tennessee, -- ! -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- ! November 2017 ! ! .. Scalar Arguments .. integer,intent(in) :: incx,n ! .. ! .. Array Arguments .. double precision,intent(in) :: dx(*) ! .. ! ===================================================================== ! .. Local Scalars .. double precision dmax integer i,ix ! .. ! .. Intrinsic Functions .. intrinsic dabs ! .. idamax = 0 if (n.lt.1 .or. incx.le.0) return idamax = 1 if (n.eq.1) return if (incx.eq.1) then ! ! code for increment equal to 1 ! dmax = dabs(dx(1)) do i = 2,n if (dabs(dx(i)).gt.dmax) then idamax = i dmax = dabs(dx(i)) endif enddo else ! ! code for increment not equal to 1 ! ix = 1 dmax = dabs(dx(1)) ix = ix + incx do i = 2,n if (dabs(dx(ix)).gt.dmax) then idamax = i dmax = dabs(dx(ix)) endif ix = ix + incx enddo endif end function idamax !> !!##NAME !! isamax(3f) - [BLAS:AUX_BLAS] Return index of maximum absolute value in SX. !! !!##SYNOPSIS !! !! integer function isamax(n,sx,incx) !! !! .. Scalar Arguments .. !! integer,intent(in) :: incx,n !! .. !! .. Array Arguments .. !! real,intent(in) :: sx(*) !! .. !! !!##DEFINITION !! !! ISAMAX finds the index of the first element having maximum absolute value. !! !!##OPTIONS !! !! N !! !! N is INTEGER !! number of elements in input vector(s) !! !! SX !! !! SX is REAL array, dimension ( 1 + ( N - 1 )*abs( INCX ) ) !! !! INCX !! !! INCX is INTEGER !! storage spacing between elements of SX !! !!##AUTHORS !! !! + Univ. of Tennessee !! + Univ. of California Berkeley !! + Univ. of Colorado Denver !! + NAG Ltd. !! !! date:November 2017 !! !! FURTHER DETAILS !! !! 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(*) !! !!##SEE ALSO !! Online html documentation available at !! http://www.netlib.org/lapack/explore-html/ ! ===================================================================== integer function isamax(n,sx,incx) implicit none ! ! -- Reference BLAS level1 routine (version 3.8.0) -- ! -- Reference BLAS is a software package provided by Univ. of Tennessee, -- ! -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- ! November 2017 ! ! .. Scalar Arguments .. integer,intent(in) :: incx,n ! .. ! .. Array Arguments .. real,intent(in) :: sx(*) ! .. ! ===================================================================== ! .. Local Scalars .. real smax integer i,ix ! .. ! .. Intrinsic Functions .. intrinsic abs ! .. isamax = 0 if (n.lt.1 .or. incx.le.0) return isamax = 1 if (n.eq.1) return if (incx.eq.1) then ! ! code for increment equal to 1 ! smax = abs(sx(1)) do i = 2,n if (abs(sx(i)).gt.smax) then isamax = i smax = abs(sx(i)) endif enddo else ! ! code for increment not equal to 1 ! ix = 1 smax = abs(sx(1)) ix = ix + incx do i = 2,n if (abs(sx(ix)).gt.smax) then isamax = i smax = abs(sx(ix)) endif ix = ix + incx enddo endif end function isamax !> !!##NAME !! izamax(3f) - [BLAS:AUX_BLAS] !! !!##SYNOPSIS !! !! integer function izamax(n,zx,incx) !! !! .. Scalar Arguments .. !! integer,intent(in) :: incx,n !! .. !! .. Array Arguments .. !! complex(kind=real64),intent(in) :: zx(*) !! .. !! !!##DEFINITION !! !! IZAMAX finds the index of the first element having maximum |Re(.)| !! + |Im(.)| !! !!##OPTIONS !! !! N number of elements in input vector(s) !! ZX array, dimension ( 1 + ( N - 1 )*abs( INCX ) ) !! INCX storage spacing between elements of ZX !! !!##RETURNS !! IZAMAX index of the first element having maximum !! !!##AUTHORS !! !! + Univ. of Tennessee !! + Univ. of California Berkeley !! + Univ. of Colorado Denver !! + NAG Ltd. !! !! date:November 2017 !! !! FURTHER DETAILS !! !! jack dongarra, 1/15/85. !! modified 3/93 to return if incx .le. 0. !! modified 12/3/93, array(1) declarations changed to array(*) !! !!##SEE ALSO !! Online html documentation available at !! http://www.netlib.org/lapack/explore-html/ ! ===================================================================== pure integer function izamax(n,zx,incx) implicit none ! ! -- Reference BLAS level1 routine (version 3.8.0) -- ! -- Reference BLAS is a software package provided by Univ. of Tennessee, -- ! -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- ! November 2017 ! ! .. Scalar Arguments .. integer,intent(in) :: incx,n ! .. ! .. Array Arguments .. complex(kind=real64),intent(in) :: zx(*) ! .. ! ! ===================================================================== ! ! .. Local Scalars .. double precision dmax integer i,ix ! .. ! .. External Functions .. DOUBLE PRECISION DCABS1 ! .. izamax = 0 if (n.lt.1 .or. incx.le.0) return izamax = 1 if (n.eq.1) return if (incx.eq.1) then ! ! code for increment equal to 1 ! dmax = dcabs1(zx(1)) do i = 2,n if (dcabs1(zx(i)).gt.dmax) then izamax = i dmax = dcabs1(zx(i)) endif enddo else ! ! code for increment not equal to 1 ! ix = 1 dmax = dcabs1(zx(1)) ix = ix + incx do i = 2,n if (dcabs1(zx(ix)).gt.dmax) then izamax = i dmax = dcabs1(zx(ix)) endif ix = ix + incx enddo endif end function izamax !> !!##NAME !! lsame(3f) - [BLAS:AUX_BLAS] compare two letters ignoring case !! !!##SYNOPSIS !! !! logical function lsame(ca,cb) !! !! .. Scalar Arguments .. !! character(len=1),intent(in) :: ca,cb !! .. !! !!##DEFINITION !! !! LSAME returns .TRUE. if CA is the same letter as CB regardless of !! case. !! !!##OPTIONS !! !! CA !! !! CA is CHARACTER*1 !! !! CB !! !! CB is CHARACTER*1 !! CA and CB specify the single characters to be compared. !! !!##AUTHORS !! !! + Univ. of Tennessee !! + Univ. of California Berkeley !! + Univ. of Colorado Denver !! + NAG Ltd. !! !! date:December 2016 !! !!##SEE ALSO !! Online html documentation available at !! http://www.netlib.org/lapack/explore-html/ ! ===================================================================== pure logical function lsame(ca,cb) implicit none ! -- Reference BLAS level1 routine (version 3.1) -- ! -- Reference BLAS is a software package provided by Univ. of Tennessee, -- ! -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- ! December 2016 ! .. Scalar Arguments .. character(len=1),intent(in) :: ca,cb ! .. ! ===================================================================== ! .. Intrinsic Functions .. intrinsic iachar ! .. ! .. Local Scalars .. integer :: inta,intb ! .. ! Test if the characters are equal lsame = ca .eq. cb if (lsame) return ! Now test for equivalence after converting uppercase to lowercase ! if characters are alphameric inta = ichar(ca) intb = ichar(cb) if (inta.ge.97 .and. inta.le.122) inta = inta - 32 if (intb.ge.97 .and. intb.le.122) intb = intb - 32 lsame = inta .eq. intb end function lsame !> !!##NAME !! sasum(3f) - [BLAS:SINGLE_BLAS_LEVEL1] SASUM:=sum of absolute values of SX. !! !!##SYNOPSIS !! !! real function sasum(n,sx,incx) !! !! .. Scalar Arguments .. !! integer,intent(in) :: incx,n !! .. !! .. Array Arguments .. !! real,intent(in) :: sx(*) !! .. !! !!##DEFINITION !! !! SASUM takes the sum of the absolute values. !! uses unrolled loops for increment equal to one. !! !!##OPTIONS !! !! N !! !! N is INTEGER !! number of elements in input vector(s) !! !! SX !! !! SX is REAL array, dimension ( 1 + ( N - 1 )*abs( INCX ) ) !! !! INCX !! !! INCX is INTEGER !! storage spacing between elements of SX !! !!##AUTHORS !! !! + Univ. of Tennessee !! + Univ. of California Berkeley !! + Univ. of Colorado Denver !! + NAG Ltd. !! !! date:November 2017 !! !! FURTHER DETAILS !! !! 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(*) !! !!##SEE ALSO !! Online html documentation available at !! http://www.netlib.org/lapack/explore-html/ ! ===================================================================== pure real function sasum(n,sx,incx) implicit none ! ! -- Reference BLAS level1 routine (version 3.8.0) -- ! -- Reference BLAS is a software package provided by Univ. of Tennessee, -- ! -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- ! November 2017 ! ! .. Scalar Arguments .. integer,intent(in) :: incx,n ! .. ! .. Array Arguments .. real,intent(in) :: sx(*) ! .. ! ! ===================================================================== ! ! .. Local Scalars .. real stemp integer i,m,mp1,nincx ! .. ! .. Intrinsic Functions .. intrinsic abs,mod ! .. sasum = 0.0e0 stemp = 0.0e0 if (n.le.0 .or. incx.le.0) return if (incx.eq.1) then ! code for increment equal to 1 ! ! ! clean-up loop ! m = mod(n,6) if (m.ne.0) then do i = 1,m stemp = stemp + abs(sx(i)) enddo if (n.lt.6) then sasum = stemp return endif endif mp1 = m + 1 do i = mp1,n,6 stemp = stemp + abs(sx(i)) + abs(sx(i+1)) + abs(sx(i+2)) + abs(sx(i+3)) + abs(sx(i+4)) + abs(sx(i+5)) enddo else ! ! code for increment not equal to 1 ! nincx = n*incx do i = 1,nincx,incx stemp = stemp + abs(sx(i)) enddo endif sasum = stemp end function sasum !> !!##NAME !! saxpy(3f) - [BLAS:SINGLE_BLAS_LEVEL1] SY:=SY+SA*SX (constant times a vector plus a vector) !! !!##SYNOPSIS !! !! subroutine saxpy(n,sa,sx,incx,sy,incy) !! !! .. Scalar Arguments .. !! real,intent(in) :: sa !! integer,intent(in) :: incx,incy,n !! .. !! .. Array Arguments .. !! real,intent(in) :: sx(*) !! real,intent(inout) :: sy(*) !! .. !! !!##DEFINITION !! !! SAXPY constant times a vector plus a vector. !! uses unrolled loops for increments equal to one. !! !!##OPTIONS !! N !! number of elements in input vector(s) !! SA !! On entry, SA specifies the scalar alpha. !! SX !! SX is REAL array, dimension ( 1 + ( N - 1 )*abs( INCX ) ) !! INCX !! storage spacing between elements of SX !! SY !! SY is REAL array, dimension ( 1 + ( N - 1 )*abs( INCY ) ) !! INCY !! storage spacing between elements of SY !! !!##AUTHORS !! !! + Univ. of Tennessee !! + Univ. of California Berkeley !! + Univ. of Colorado Denver !! + NAG Ltd. !! !! date:November 2017 !! !! FURTHER DETAILS !! !! jack dongarra, linpack, 3/11/78. !! modified 12/3/93, array(1) declarations changed to array(*) !! !!##SEE ALSO !! Online html documentation available at !! http://www.netlib.org/lapack/explore-html/ ! ===================================================================== subroutine saxpy(n,sa,sx,incx,sy,incy) implicit none ! ! -- Reference BLAS level1 routine (version 3.8.0) -- ! -- Reference BLAS is a software package provided by Univ. of Tennessee, -- ! -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- ! November 2017 ! ! .. Scalar Arguments .. real,intent(in) :: sa integer,intent(in) :: incx,incy,n ! .. ! .. Array Arguments .. real,intent(in) :: sx(*) real,intent(inout) :: sy(*) ! .. ! ! ===================================================================== ! ! .. Local Scalars .. integer i,ix,iy,m,mp1 ! .. ! .. Intrinsic Functions .. intrinsic mod ! .. if (n.le.0) return if (sa.eq.0.0) return if (incx.eq.1 .and. incy.eq.1) then ! ! code for both increments equal to 1 ! ! ! clean-up loop ! m = mod(n,4) if (m.ne.0) then do i = 1,m sy(i) = sy(i) + sa*sx(i) enddo endif if (n.lt.4) return mp1 = m + 1 do i = mp1,n,4 sy(i) = sy(i) + sa*sx(i) sy(i+1) = sy(i+1) + sa*sx(i+1) sy(i+2) = sy(i+2) + sa*sx(i+2) sy(i+3) = sy(i+3) + sa*sx(i+3) enddo else ! ! code for unequal increments or equal increments ! not equal to 1 ! ix = 1 iy = 1 if (incx.lt.0) ix = (-n+1)*incx + 1 if (incy.lt.0) iy = (-n+1)*incy + 1 do i = 1,n sy(iy) = sy(iy) + sa*sx(ix) ix = ix + incx iy = iy + incy enddo endif end subroutine saxpy !> !!##NAME !! scabs1(3f) - [BLAS:SINGLE_BLAS_LEVEL1] !! !!##SYNOPSIS !! !! elemental real function scabs1(z) !! !! .. Scalar Arguments .. !! complex,intent(in) :: z !! .. !! !!##DEFINITION !! !! SCABS1 computes |Re(.)| + |Im(.)| of a complex number !! !!##OPTIONS !! !! Z !! !! Z is COMPLEX !! !!##AUTHORS !! !! + Univ. of Tennessee !! + Univ. of California Berkeley !! + Univ. of Colorado Denver !! + NAG Ltd. !! !! date:November 2017 !! !!##SEE ALSO !! Online html documentation available at !! http://www.netlib.org/lapack/explore-html/ ! ===================================================================== pure elemental real function scabs1(z) implicit none ! ! -- Reference BLAS level1 routine (version 3.8.0) -- ! -- Reference BLAS is a software package provided by Univ. of Tennessee, -- ! -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- ! November 2017 ! ! .. Scalar Arguments .. complex,intent(in) :: z ! .. ! ===================================================================== ! .. Intrinsic Functions .. intrinsic abs,aimag,real ! .. scabs1 = abs(real(z)) + abs(aimag(z)) end function scabs1 !> !!##NAME !! scasum(3f) - [BLAS:SINGLE_BLAS_LEVEL1] SCASUM:=SUM(I=1 to N) ABS(REAL(CX(I)))+ABS(AIMAG(CX(I))). !! !!##SYNOPSIS !! !! real function scasum(n,cx,incx) !! !! .. Scalar Arguments .. !! integer,intent(in) :: incx,n !! .. !! .. Array Arguments .. !! complex,intent(inout) :: cx(*) !! .. !! !!##DEFINITION !! !! SCASUM takes the sum of the (|Re(.)| + |Im(.)|)'s of a complex vector and !! returns a single precision result. !! !!##OPTIONS !! !! N !! !! N is INTEGER !! number of elements in input vector(s) !! !! CX !! !! CX is COMPLEX array, dimension ( 1 + ( N - 1 )*abs( INCX ) ) !! !! INCX !! !! INCX is INTEGER !! storage spacing between elements of SX !! !!##AUTHORS !! !! + Univ. of Tennessee !! + Univ. of California Berkeley !! + Univ. of Colorado Denver !! + NAG Ltd. !! !! date:November 2017 !! !! FURTHER DETAILS !! !! 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(*) !! !!##SEE ALSO !! Online html documentation available at !! http://www.netlib.org/lapack/explore-html/ ! ===================================================================== real function scasum(n,cx,incx) implicit none ! ! -- Reference BLAS level1 routine (version 3.8.0) -- ! -- Reference BLAS is a software package provided by Univ. of Tennessee, -- ! -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- ! November 2017 ! ! .. Scalar Arguments .. integer,intent(in) :: incx,n ! .. ! .. Array Arguments .. complex,intent(inout) :: cx(*) ! .. ! ===================================================================== ! .. Local Scalars .. real stemp integer i,nincx ! .. ! .. Intrinsic Functions .. intrinsic abs,aimag,real ! .. scasum = 0.0e0 stemp = 0.0e0 if (n.le.0 .or. incx.le.0) return if (incx.eq.1) then ! ! code for increment equal to 1 ! do i = 1,n stemp = stemp + abs(real(cx(i))) + abs(aimag(cx(i))) enddo else ! ! code for increment not equal to 1 ! nincx = n*incx do i = 1,nincx,incx stemp = stemp + abs(real(cx(i))) + abs(aimag(cx(i))) enddo endif scasum = stemp end function scasum !> !!##NAME !! scnrm2(3f) - [BLAS:SINGLE_BLAS_LEVEL1] SCNRM2:= square root of sum of magnitudes of entries of CX. !! !!##SYNOPSIS !! !! real function scnrm2(n,x,incx) !! !! .. !! .. Scalar Arguments .. !! integer,intent(in) :: incx, n !! .. !! .. Array Arguments .. !! complex(wp),intent(in) :: x(*) !! .. !! !!##DEFINITION !! !! SCNRM2 returns the euclidean norm of a vector via the function !! name, so that !! !! SCNRM2 := sqrt( x**H*x ) !! !!##OPTIONS !! !! N !! !! N is INTEGER !! number of elements in input vector(s) !! !! X !! !! X is COMPLEX array, dimension (N) !! complex vector with N elements !! !! INCX !! !! INCX is INTEGER, storage spacing between elements of X !! If INCX > 0, X(1+(i-1)*INCX) = x(i) for 1 <= i <= n !! If INCX < 0, X(1-(n-i)*INCX) = x(i) for 1 <= i <= n !! If INCX = 0, x isn't a vector so there is no need to call !! this subroutine. If you call it anyway, it will count x(1) !! in the vector norm N times. !! !!##AUTHORS !! !! + Edward Anderson, Lockheed Martin !! !! date:August 2016 !! !! \par Contributors: !! !! Weslley Pereira, University of Colorado Denver, USA !! !! FURTHER DETAILS !! !! Anderson E. (2017) !! Algorithm 978: Safe Scaling in the Level 1 BLAS !! ACM Trans Math Softw 44:1--28 !! https://doi.org/10.1145/3061665 !! !! Blue, James L. (1978) !! A Portable Fortran Program to Find the Euclidean Norm of a Vector !! ACM Trans Math Softw 4:15--23 !! https://doi.org/10.1145/355769.355771 !! !!##SEE ALSO !! Online html documentation available at !! http://www.netlib.org/lapack/explore-html/ ! ===================================================================== pure function scnrm2( n, x, incx ) integer, parameter :: wp = kind(1.e0) real(wp) :: scnrm2 ! ! -- Reference BLAS level1 routine (version 3.9.1) -- ! -- Reference BLAS is a software package provided by Univ. of Tennessee, -- ! -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- ! March 2021 ! ! .. Constants .. real(wp), parameter :: zero = 0.0_wp real(wp), parameter :: one = 1.0_wp real(wp), parameter :: maxn = huge(0.0_wp) ! .. ! .. Blue's scaling constants .. real(wp), parameter :: tsml = real(radix(0._wp), wp)**ceiling( (minexponent(0._wp) - 1) * 0.5_wp) real(wp), parameter :: tbig = real(radix(0._wp), wp)**floor( (maxexponent(0._wp) - digits(0._wp) + 1) * 0.5_wp) real(wp), parameter :: ssml = real(radix(0._wp), wp)**( - floor( (minexponent(0._wp) - 1) * 0.5_wp)) real(wp), parameter :: sbig = real(radix(0._wp), wp)**( - ceiling( (maxexponent(0._wp) - digits(0._wp) + 1) * 0.5_wp)) ! .. ! .. Scalar Arguments .. integer,intent(in) :: incx, n ! .. ! .. Array Arguments .. complex(wp),intent(in) :: x(*) ! .. ! .. Local Scalars .. integer :: i, ix logical :: notbig real(wp) :: abig, amed, asml, ax, scl, sumsq, ymax, ymin ! ! Quick return if possible ! scnrm2 = zero if( n <= 0 ) return ! scl = one sumsq = zero ! ! Compute the sum of squares in 3 accumulators: ! abig -- sums of squares scaled down to avoid overflow ! asml -- sums of squares scaled up to avoid underflow ! amed -- sums of squares that do not require scaling ! The thresholds and multipliers are ! tbig -- values bigger than this are scaled down by sbig ! tsml -- values smaller than this are scaled up by ssml ! notbig = .true. asml = zero amed = zero abig = zero ix = 1 if( incx < 0 ) ix = 1 - (n-1)*incx do i = 1, n ax = abs(real(x(ix))) if (ax > tbig) then abig = abig + (ax*sbig)**2 notbig = .false. elseif (ax < tsml) then if (notbig) asml = asml + (ax*ssml)**2 else amed = amed + ax**2 endif ax = abs(aimag(x(ix))) if (ax > tbig) then abig = abig + (ax*sbig)**2 notbig = .false. elseif (ax < tsml) then if (notbig) asml = asml + (ax*ssml)**2 else amed = amed + ax**2 endif ix = ix + incx enddo ! ! Combine abig and amed or amed and asml if more than one ! accumulator was used. ! if (abig > zero) then ! ! Combine abig and amed if abig > 0. ! if ( (amed > zero) .or. (amed > maxn) .or. (amed /= amed) ) then abig = abig + (amed*sbig)*sbig endif scl = one / sbig sumsq = abig elseif (asml > zero) then ! ! Combine amed and asml if asml > 0. ! if ( (amed > zero) .or. (amed > maxn) .or. (amed /= amed) ) then amed = sqrt(amed) asml = sqrt(asml) / ssml if (asml > amed) then ymin = amed ymax = asml else ymin = asml ymax = amed endif scl = one sumsq = ymax**2*( one + (ymin/ymax)**2 ) else scl = one / ssml sumsq = asml endif else ! ! Otherwise all values are mid-range ! scl = one sumsq = amed endif scnrm2 = scl*sqrt( sumsq ) end function scnrm2 !> !!##NAME !! scopy(3f) - [BLAS:SINGLE_BLAS_LEVEL1] SY:=SX !! !!##SYNOPSIS !! !! subroutine scopy(n,sx,incx,sy,incy) !! !! .. Scalar Arguments .. !! integer,intent(in) :: incx,incy,n !! .. !! .. Array Arguments .. !! real,intent(in) :: sx(*) !! real,intent(out) :: sy(*) !! .. !! !!##DEFINITION !! !! SCOPY copies a vector, x, to a vector, y. !! uses unrolled loops for increments equal to 1. !! !!##OPTIONS !! !! N !! !! N is INTEGER !! number of elements in input vector(s) !! !! SX !! !! SX is REAL array, dimension ( 1 + ( N - 1 )*abs( INCX ) ) !! !! INCX !! !! INCX is INTEGER !! storage spacing between elements of SX !! !! SY !! !! SY is REAL array, dimension ( 1 + ( N - 1 )*abs( INCY ) ) !! !! INCY !! !! INCY is INTEGER !! storage spacing between elements of SY !! !!##AUTHORS !! !! + Univ. of Tennessee !! + Univ. of California Berkeley !! + Univ. of Colorado Denver !! + NAG Ltd. !! !! date:November 2017 !! !! FURTHER DETAILS !! !! jack dongarra, linpack, 3/11/78. !! modified 12/3/93, array(1) declarations changed to array(*) !! !!##SEE ALSO !! Online html documentation available at !! http://www.netlib.org/lapack/explore-html/ ! ===================================================================== subroutine scopy(n,sx,incx,sy,incy) implicit none ! ! -- Reference BLAS level1 routine (version 3.8.0) -- ! -- Reference BLAS is a software package provided by Univ. of Tennessee, -- ! -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- ! November 2017 ! ! .. Scalar Arguments .. integer,intent(in) :: incx,incy,n ! .. ! .. Array Arguments .. real,intent(in) :: sx(*) real,intent(out) :: sy(*) ! .. ! ===================================================================== ! .. Local Scalars .. integer i,ix,iy,m,mp1 ! .. ! .. Intrinsic Functions .. intrinsic mod ! .. if (n.le.0) return if (incx.eq.1 .and. incy.eq.1) then ! ! code for both increments equal to 1 ! ! ! clean-up loop ! m = mod(n,7) if (m.ne.0) then do i = 1,m sy(i) = sx(i) enddo if (n.lt.7) return endif mp1 = m + 1 do i = mp1,n,7 sy(i) = sx(i) sy(i+1) = sx(i+1) sy(i+2) = sx(i+2) sy(i+3) = sx(i+3) sy(i+4) = sx(i+4) sy(i+5) = sx(i+5) sy(i+6) = sx(i+6) enddo else ! ! code for unequal increments or equal increments ! not equal to 1 ! ix = 1 iy = 1 if (incx.lt.0) ix = (-n+1)*incx + 1 if (incy.lt.0) iy = (-n+1)*incy + 1 do i = 1,n sy(iy) = sx(ix) ix = ix + incx iy = iy + incy enddo endif end subroutine scopy !> !!##NAME !! sdot(3f) - [BLAS:SINGLE_BLAS_LEVEL1] SDOT := SUM SX * SY (vector dot product) !! !!##SYNOPSIS !! !! real function sdot(n,sx,incx,sy,incy) !! !! .. Scalar Arguments .. !! integer,intent(in) :: incx,incy,n !! .. !! .. Array Arguments .. !! real,intent(in) :: sx(*),sy(*) !! .. !! !!##DEFINITION !! !! SDOT forms the dot product of two vectors. !! uses unrolled loops for increments equal to one. !! !!##OPTIONS !! !! N !! !! N is INTEGER !! number of elements in input vector(s) !! !! SX !! !! SX is REAL array, dimension ( 1 + ( N - 1 )*abs( INCX ) ) !! !! INCX !! !! INCX is INTEGER !! storage spacing between elements of SX !! !! SY !! !! SY is REAL array, dimension ( 1 + ( N - 1 )*abs( INCY ) ) !! !! INCY !! !! INCY is INTEGER !! storage spacing between elements of SY !! !!##AUTHORS !! !! + Univ. of Tennessee !! + Univ. of California Berkeley !! + Univ. of Colorado Denver !! + NAG Ltd. !! !! date:November 2017 !! !! FURTHER DETAILS !! !! jack dongarra, linpack, 3/11/78. !! modified 12/3/93, array(1) declarations changed to array(*) !! !!##SEE ALSO !! Online html documentation available at !! http://www.netlib.org/lapack/explore-html/ ! ===================================================================== pure real function sdot(n,sx,incx,sy,incy) implicit none ! ! -- Reference BLAS level1 routine (version 3.8.0) -- ! -- Reference BLAS is a software package provided by Univ. of Tennessee, -- ! -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- ! November 2017 ! ! .. Scalar Arguments .. integer,intent(in) :: incx,incy,n ! .. ! .. Array Arguments .. real,intent(in) :: sx(*),sy(*) ! .. ! ! ===================================================================== ! ! .. Local Scalars .. real stemp integer i,ix,iy,m,mp1 ! .. ! .. Intrinsic Functions .. intrinsic mod ! .. stemp = 0.0e0 sdot = 0.0e0 if (n.le.0) return if (incx.eq.1 .and. incy.eq.1) then ! ! code for both increments equal to 1 ! ! ! clean-up loop ! m = mod(n,5) if (m.ne.0) then do i = 1,m stemp = stemp + sx(i)*sy(i) enddo if (n.lt.5) then sdot=stemp return endif endif mp1 = m + 1 do i = mp1,n,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) enddo else ! ! code for unequal increments or equal increments ! not equal to 1 ! ix = 1 iy = 1 if (incx.lt.0) ix = (-n+1)*incx + 1 if (incy.lt.0) iy = (-n+1)*incy + 1 do i = 1,n stemp = stemp + sx(ix)*sy(iy) ix = ix + incx iy = iy + incy enddo endif sdot = stemp end function sdot !> !!##NAME !! sdsdot(3f) - [BLAS:SINGLE_BLAS_LEVEL1] Compute the inner !! product of two vectors with extended precision accumulation. !! SDSDOT := SUM SX * SY (accumulated double precision, returned single) !! !!##SYNOPSIS !! !! real function sdsdot(n,sb,sx,incx,sy,incy) !! !! .. Scalar Arguments .. !! real,intent(in) :: sb !! integer,intent(in) :: incx,incy,n !! .. !! .. Array Arguments .. !! real,intent(in) :: sx(*),sy(*) !! .. !! !!##DEFINITION !! !! Compute the inner product of two vectors with extended !! precision accumulation. !! !! Returns S.P. result with dot product accumulated in D.P. !! SDSDOT = SB + 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. !! !!##OPTIONS !! !! N !! !! N is INTEGER !! number of elements in input vector(s) !! !! SB !! !! SB is REAL !! single precision scalar to be added to inner product !! !! SX !! !! SX is REAL array, dimension ( 1 + ( N - 1 )*abs( INCX ) ) !! single precision vector with N elements !! !! INCX !! !! INCX is INTEGER !! storage spacing between elements of SX !! !! SY !! !! SY is REAL array, dimension ( 1 + ( N - 1 )*abs( INCX ) ) !! single precision vector with N elements !! !! INCY !! !! INCY is INTEGER !! storage spacing between elements of SY !! !!##AUTHORS !! !! + Lawson, C. L., (JPL), Hanson, R. J., (SNLA), !! + Kincaid, D. R., (U. of Texas), Krogh, F. T., (JPL) !! !! + Univ. of Tennessee !! + Univ. of California Berkeley !! + Univ. of Colorado Denver !! + NAG Ltd. !! !! date:November 2017 !! !! FURTHER DETAILS !! !! 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 !! 890531 Changed all specific intrinsics to generic. (WRB) !! 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 coding style !! !!##SEE ALSO !! Online html documentation available at !! http://www.netlib.org/lapack/explore-html/ ! ===================================================================== pure real function sdsdot(n,sb,sx,incx,sy,incy) implicit none ! ! -- Reference BLAS level1 routine (version 3.8.0) -- ! -- Reference BLAS is a software package provided by Univ. of Tennessee, -- ! -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- ! November 2017 ! ! .. Scalar Arguments .. real,intent(in) :: sb integer,intent(in) :: incx,incy,n ! .. ! .. Array Arguments .. real,intent(in) :: sx(*),sy(*) ! .. ! .. Local Scalars .. double precision dsdot integer i,kx,ky,ns ! .. ! .. Intrinsic Functions .. intrinsic dble ! .. dsdot = sb if (n.le.0) then sdsdot = real(dsdot) return endif if (incx.eq.incy .and. incx.gt.0) then ! ! Code for equal and positive increments. ! ns = n*incx do i = 1,ns,incx dsdot = dsdot + dble(sx(i))*dble(sy(i)) enddo else ! ! Code for unequal or nonpositive increments. ! kx = 1 ky = 1 if (incx.lt.0) kx = 1 + (1-n)*incx if (incy.lt.0) ky = 1 + (1-n)*incy do i = 1,n dsdot = dsdot + dble(sx(kx))*dble(sy(ky)) kx = kx + incx ky = ky + incy enddo endif sdsdot = real(dsdot) end function sdsdot !> !!##NAME !! sgbmv(3f) - [BLAS:SINGLE_BLAS_LEVEL2] !! SY:=alpha*A*SX+beta*SY, A a band matrix. !! !!##SYNOPSIS !! !! subroutine sgbmv(trans,m,n,kl,ku,alpha,a,lda,x,incx,beta,y,incy) !! !! .. Scalar Arguments .. !! real,intent(in) :: alpha,beta !! integer,intent(in) :: incx,incy,kl,ku,lda,m,n !! character(len=1),intent(in) :: trans !! .. !! .. Array Arguments .. !! real,intent(in) :: a(lda,*),x(*) !! real,intent(inout) :: y(*) !! .. !! !!##DEFINITION !! !! SGBMV performs one of the matrix-vector operations !! !! y := alpha*A*x + beta*y, or y := alpha*A**T*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. !! !!##OPTIONS !! !! TRANS !! !! TRANS is 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**T*x + beta*y. !! !! TRANS = 'C' or 'c' y := alpha*A**T*x + beta*y. !! !! M !! !! M is INTEGER !! On entry, M specifies the number of rows of the matrix A. !! M must be at least zero. !! !! N !! !! N is INTEGER !! On entry, N specifies the number of columns of the matrix A. !! N must be at least zero. !! !! KL !! !! KL is INTEGER !! On entry, KL specifies the number of sub-diagonals of the !! matrix A. KL must satisfy 0 .le. KL. !! !! KU !! !! KU is INTEGER !! On entry, KU specifies the number of super-diagonals of the !! matrix A. KU must satisfy 0 .le. KU. !! !! ALPHA !! !! ALPHA is REAL !! On entry, ALPHA specifies the scalar alpha. !! !! A !! !! A is REAL array, 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 !! !! LDA !! !! LDA is 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 ). !! !! X !! !! X is REAL array, 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. !! !! INCX !! !! INCX is INTEGER !! On entry, INCX specifies the increment for the elements of !! X. INCX must not be zero. !! !! BETA !! !! BETA is REAL !! On entry, BETA specifies the scalar beta. When BETA is !! supplied as zero then Y need not be set on input. !! !! Y !! !! Y is REAL array, 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 !! !! INCY is INTEGER !! On entry, INCY specifies the increment for the elements of !! Y. INCY must not be zero. !! !!##AUTHORS !! !! + Univ. of Tennessee !! + Univ. of California Berkeley !! + Univ. of Colorado Denver !! + NAG Ltd. !! !! date:December 2016 !! !! FURTHER DETAILS !! !! Level 2 Blas routine. !! The vector and matrix arguments are not referenced when N = 0, or M = 0 !! !! -- 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. !! !!##SEE ALSO !! Online html documentation available at !! http://www.netlib.org/lapack/explore-html/ ! ===================================================================== subroutine sgbmv(trans,m,n,kl,ku,alpha,a,lda,x,incx,beta,y,incy) implicit none ! ! -- Reference BLAS level2 routine (version 3.7.0) -- ! -- Reference BLAS is a software package provided by Univ. of Tennessee, -- ! -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- ! December 2016 ! ! .. Scalar Arguments .. real,intent(in) :: alpha,beta integer,intent(in) :: incx,incy,kl,ku,lda,m,n character(len=1),intent(in) :: trans ! .. ! .. Array Arguments .. real,intent(in) :: a(lda,*),x(*) real,intent(inout) :: y(*) ! .. ! ! ===================================================================== ! ! .. Parameters .. real one,zero parameter (one=1.0e+0,zero=0.0e+0) ! .. ! .. Local Scalars .. real temp integer i,info,ix,iy,j,jx,jy,k,kup1,kx,ky,lenx,leny ! .. ! .. External Functions .. LOGICAL LSAME ! .. ! .. External Subroutines .. EXTERNAL XERBLA ! .. ! .. Intrinsic Functions .. intrinsic max,min ! .. ! ! Test the input parameters. ! info = 0 if (.not.lsame(trans,'N') .and. .not.lsame(trans,'T') .and. .not.lsame(trans,'C')) then info = 1 elseif (m.lt.0) then info = 2 elseif (n.lt.0) then info = 3 elseif (kl.lt.0) then info = 4 elseif (ku.lt.0) then info = 5 elseif (lda.lt. (kl+ku+1)) then info = 8 elseif (incx.eq.0) then info = 10 elseif (incy.eq.0) then info = 13 endif if (info.ne.0) then call xerbla('SGBMV ',info) return endif ! ! Quick return if possible. ! if ((m.eq.0) .or. (n.eq.0) .or. ((alpha.eq.zero).and. (beta.eq.one))) return ! ! Set LENX and LENY, the lengths of the vectors x and y, and set ! up the start points in X and Y. ! if (lsame(trans,'N')) then lenx = n leny = m else lenx = m leny = n endif if (incx.gt.0) then kx = 1 else kx = 1 - (lenx-1)*incx endif if (incy.gt.0) then ky = 1 else ky = 1 - (leny-1)*incy endif ! ! 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.ne.one) then if (incy.eq.1) then if (beta.eq.zero) then y(1:leny) = zero else y(1:leny) = beta*y(1:leny) endif else iy = ky if (beta.eq.zero) then do i = 1,leny y(iy) = zero iy = iy + incy enddo else do i = 1,leny y(iy) = beta*y(iy) iy = iy + incy enddo endif endif endif if (alpha.eq.zero) return kup1 = ku + 1 if (lsame(trans,'N')) then ! ! Form y := alpha*A*x + y. ! jx = kx if (incy.eq.1) then do j = 1,n temp = alpha*x(jx) k = kup1 - j do i = max(1,j-ku),min(m,j+kl) y(i) = y(i) + temp*a(k+i,j) enddo jx = jx + incx enddo else do j = 1,n temp = alpha*x(jx) iy = ky k = kup1 - j do i = max(1,j-ku),min(m,j+kl) y(iy) = y(iy) + temp*a(k+i,j) iy = iy + incy enddo jx = jx + incx if (j.gt.ku) ky = ky + incy enddo endif else ! ! Form y := alpha*A**T*x + y. ! jy = ky if (incx.eq.1) then do j = 1,n temp = zero k = kup1 - j do i = max(1,j-ku),min(m,j+kl) temp = temp + a(k+i,j)*x(i) enddo y(jy) = y(jy) + alpha*temp jy = jy + incy enddo else do j = 1,n temp = zero ix = kx k = kup1 - j do i = max(1,j-ku),min(m,j+kl) temp = temp + a(k+i,j)*x(ix) ix = ix + incx enddo y(jy) = y(jy) + alpha*temp jy = jy + incy if (j.gt.ku) kx = kx + incx enddo endif endif end subroutine sgbmv !> !!##NAME !! sgemm(3f) - [BLAS:SINGLE_BLAS_LEVEL3] !! C:=alpha*A*B+beta*C, A, B, C rectangular. !! !!##SYNOPSIS !! !! subroutine sgemm(transa,transb,m,n,k,alpha,a,lda,b,ldb,beta,c,ldc) !! !! .. Scalar Arguments .. !! real,intent(in) :: alpha,beta !! integer,intent(in) :: k,lda,ldb,ldc,m,n !! character,intent(in) :: transa,transb !! .. !! .. Array Arguments .. !! real,intent(in) :: a(lda,*),b(ldb,*) !! real,intent(inout) :: c(ldc,*) !! .. !! !!##DEFINITION !! !! 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**T, !! !! 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. !! !!##OPTIONS !! !! TRANSA !! !! TRANSA is 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**T. !! !! TRANSA = 'C' or 'c', op( A ) = A**T. !! !! TRANSB !! !! TRANSB is 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**T. !! !! TRANSB = 'C' or 'c', op( B ) = B**T. !! !! M !! !! M is 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. !! !! N !! !! N is 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. !! !! K !! !! K is 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. !! !! ALPHA !! !! ALPHA is REAL !! On entry, ALPHA specifies the scalar alpha. !! !! A !! !! A is REAL array, 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. !! !! LDA !! !! LDA is 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 ). !! !! B !! !! B is REAL array, 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. !! !! LDB !! !! LDB is 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 ). !! !! BETA !! !! BETA is REAL !! On entry, BETA specifies the scalar beta. When BETA is !! supplied as zero then C need not be set on input. !! !! C !! !! C is REAL array, 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 !! !! LDC is 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 ). !! !!##AUTHORS !! !! + Univ. of Tennessee !! + Univ. of California Berkeley !! + Univ. of Colorado Denver !! + NAG Ltd. !! !! date:December 2016 !! !! FURTHER DETAILS !! !! 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. !! !!##SEE ALSO !! Online html documentation available at !! http://www.netlib.org/lapack/explore-html/ ! ===================================================================== subroutine sgemm(transa,transb,m,n,k,alpha,a,lda,b,ldb,beta,c,ldc) implicit none ! ! -- Reference BLAS level3 routine (version 3.7.0) -- ! -- Reference BLAS is a software package provided by Univ. of Tennessee, -- ! -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- ! December 2016 ! ! .. Scalar Arguments .. real,intent(in) :: alpha,beta integer,intent(in) :: k,lda,ldb,ldc,m,n character,intent(in) :: transa,transb ! .. ! .. Array Arguments .. real,intent(in) :: a(lda,*),b(ldb,*) real,intent(inout) :: c(ldc,*) ! .. ! ! ===================================================================== ! ! .. External Functions .. LOGICAL LSAME ! .. ! .. External Subroutines .. EXTERNAL XERBLA ! .. ! .. Intrinsic Functions .. intrinsic max ! .. ! .. Local Scalars .. real temp integer i,info,j,l,nrowa,nrowb logical nota,notb ! .. ! .. Parameters .. real one,zero parameter (one=1.0e+0,zero=0.0e+0) ! .. ! ! Set NOTA and NOTB as true if A and B respectively are not ! transposed and set NROWA and NROWB as the number of rows of A ! and B respectively. ! nota = lsame(transa,'N') notb = lsame(transb,'N') if (nota) then nrowa = m else nrowa = k endif if (notb) then nrowb = k else nrowb = n endif ! ! Test the input parameters. ! info = 0 if ((.not.nota) .and. (.not.lsame(transa,'C')) .and. (.not.lsame(transa,'T'))) then info = 1 elseif ((.not.notb) .and. (.not.lsame(transb,'C')) .and. (.not.lsame(transb,'T'))) then info = 2 elseif (m.lt.0) then info = 3 elseif (n.lt.0) then info = 4 elseif (k.lt.0) then info = 5 elseif (lda.lt.max(1,nrowa)) then info = 8 elseif (ldb.lt.max(1,nrowb)) then info = 10 elseif (ldc.lt.max(1,m)) then info = 13 endif if (info.ne.0) then call xerbla('SGEMM ',info) return endif ! ! Quick return if possible. ! if ((m.eq.0) .or. (n.eq.0) .or. (((alpha.eq.zero).or. (k.eq.0)).and. (beta.eq.one))) return ! ! And if alpha.eq.zero. ! if (alpha.eq.zero) then if (beta.eq.zero) then do j = 1,n c(1:m,j) = zero enddo else do j = 1,n c(1:m,j) = beta*c(1:m,j) enddo endif return endif ! ! Start the operations. ! if (notb) then if (nota) then ! ! Form C := alpha*A*B + beta*C. ! do j = 1,n if (beta.eq.zero) then c(1:m,j) = zero elseif (beta.ne.one) then c(1:m,j) = beta*c(1:m,j) endif do l = 1,k temp = alpha*b(l,j) c(1:m,j) = c(1:m,j) + temp*a(1:m,l) enddo enddo else ! ! Form C := alpha*A**T*B + beta*C ! do j = 1,n do i = 1,m temp = zero do l = 1,k temp = temp + a(l,i)*b(l,j) enddo if (beta.eq.zero) then c(i,j) = alpha*temp else c(i,j) = alpha*temp + beta*c(i,j) endif enddo enddo endif else if (nota) then ! ! Form C := alpha*A*B**T + beta*C ! do j = 1,n if (beta.eq.zero) then c(1:m,j) = zero elseif (beta.ne.one) then c(1:m,j) = beta*c(1:m,j) endif do l = 1,k temp = alpha*b(j,l) c(1:m,j) = c(1:m,j) + temp*a(1:m,l) enddo enddo else ! ! Form C := alpha*A**T*B**T + beta*C ! do j = 1,n do i = 1,m temp = zero do l = 1,k temp = temp + a(l,i)*b(j,l) enddo if (beta.eq.zero) then c(i,j) = alpha*temp else c(i,j) = alpha*temp + beta*c(i,j) endif enddo enddo endif endif ! end subroutine sgemm !> !!##NAME !! sgemv(3f) - [BLAS:SINGLE_BLAS_LEVEL2] !! SY:=alpha*A*SX+beta*SY, A a rectangular matrix. !! !!##SYNOPSIS !! !! subroutine sgemv(trans,m,n,alpha,a,lda,x,incx,beta,y,incy) !! !! .. Scalar Arguments .. !! real,intent(in) :: alpha,beta !! integer,intent(in) :: incx,incy,lda,m,n !! character,intent(in) :: trans !! .. !! .. Array Arguments .. !! real,intent(in) :: a(lda,*),x(*) !! real,intent(inout) :: y(*) !! .. !! !!##DEFINITION !! !! SGEMV performs one of the matrix-vector operations !! !! y := alpha*A*x + beta*y, or y := alpha*A**T*x + beta*y, !! !! where alpha and beta are scalars, x and y are vectors and A is an !! m by n matrix. !! !!##OPTIONS !! !! TRANS !! !! TRANS is 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**T*x + beta*y. !! !! TRANS = 'C' or 'c' y := alpha*A**T*x + beta*y. !! !! M !! !! M is INTEGER !! On entry, M specifies the number of rows of the matrix A. !! M must be at least zero. !! !! N !! !! N is INTEGER !! On entry, N specifies the number of columns of the matrix A. !! N must be at least zero. !! !! ALPHA !! !! ALPHA is REAL !! On entry, ALPHA specifies the scalar alpha. !! !! A !! !! A is REAL array, dimension ( LDA, N ) !! Before entry, the leading m by n part of the array A must !! contain the matrix of coefficients. !! !! LDA !! !! LDA is 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 ). !! !! X !! !! X is REAL array, 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. !! !! INCX !! !! INCX is INTEGER !! On entry, INCX specifies the increment for the elements of !! X. INCX must not be zero. !! !! BETA !! !! BETA is REAL !! On entry, BETA specifies the scalar beta. When BETA is !! supplied as zero then Y need not be set on input. !! !! Y !! !! Y is REAL array, 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 !! !! INCY is INTEGER !! On entry, INCY specifies the increment for the elements of !! Y. INCY must not be zero. !! !!##AUTHORS !! !! + Univ. of Tennessee !! + Univ. of California Berkeley !! + Univ. of Colorado Denver !! + NAG Ltd. !! !! date:December 2016 !! !! FURTHER DETAILS !! !! Level 2 Blas routine. !! The vector and matrix arguments are not referenced when N = 0, or M = 0 !! !! -- 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. !! !!##SEE ALSO !! Online html documentation available at !! http://www.netlib.org/lapack/explore-html/ ! ===================================================================== subroutine sgemv(trans,m,n,alpha,a,lda,x,incx,beta,y,incy) implicit none ! ! -- Reference BLAS level2 routine (version 3.7.0) -- ! -- Reference BLAS is a software package provided by Univ. of Tennessee, -- ! -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- ! December 2016 ! ! .. Scalar Arguments .. real,intent(in) :: alpha,beta integer,intent(in) :: incx,incy,lda,m,n character,intent(in) :: trans ! .. ! .. Array Arguments .. real,intent(in) :: a(lda,*),x(*) real,intent(inout) :: y(*) ! .. ! ! ===================================================================== ! ! .. Parameters .. real one,zero parameter (one=1.0e+0,zero=0.0e+0) ! .. ! .. Local Scalars .. real temp integer i,info,ix,iy,j,jx,jy,kx,ky,lenx,leny ! .. ! .. External Functions .. LOGICAL LSAME ! .. ! .. External Subroutines .. EXTERNAL XERBLA ! .. ! .. Intrinsic Functions .. intrinsic max ! .. ! ! Test the input parameters. ! info = 0 if (.not.lsame(trans,'N') .and. .not.lsame(trans,'T') .and. .not.lsame(trans,'C')) then info = 1 elseif (m.lt.0) then info = 2 elseif (n.lt.0) then info = 3 elseif (lda.lt.max(1,m)) then info = 6 elseif (incx.eq.0) then info = 8 elseif (incy.eq.0) then info = 11 endif if (info.ne.0) then call xerbla('SGEMV ',info) return endif ! ! Quick return if possible. ! if ((m.eq.0) .or. (n.eq.0) .or. ((alpha.eq.zero).and. (beta.eq.one))) return ! ! Set LENX and LENY, the lengths of the vectors x and y, and set ! up the start points in X and Y. ! if (lsame(trans,'N')) then lenx = n leny = m else lenx = m leny = n endif if (incx.gt.0) then kx = 1 else kx = 1 - (lenx-1)*incx endif if (incy.gt.0) then ky = 1 else ky = 1 - (leny-1)*incy endif ! ! Start the operations. In this version the elements of A are ! accessed sequentially with one pass through A. ! ! First form y := beta*y. ! if (beta.ne.one) then if (incy.eq.1) then if (beta.eq.zero) then y(1:leny) = zero else y(1:leny) = beta*y(1:leny) endif else iy = ky if (beta.eq.zero) then do i = 1,leny y(iy) = zero iy = iy + incy enddo else do i = 1,leny y(iy) = beta*y(iy) iy = iy + incy enddo endif endif endif if (alpha.eq.zero) return if (lsame(trans,'N')) then ! ! Form y := alpha*A*x + y. ! jx = kx if (incy.eq.1) then do j = 1,n temp = alpha*x(jx) do i = 1,m y(i) = y(i) + temp*a(i,j) enddo jx = jx + incx enddo else do j = 1,n temp = alpha*x(jx) iy = ky do i = 1,m y(iy) = y(iy) + temp*a(i,j) iy = iy + incy enddo jx = jx + incx enddo endif else ! ! Form y := alpha*A**T*x + y. ! jy = ky if (incx.eq.1) then do j = 1,n temp = zero do i = 1,m temp = temp + a(i,j)*x(i) enddo y(jy) = y(jy) + alpha*temp jy = jy + incy enddo else do j = 1,n temp = zero ix = kx do i = 1,m temp = temp + a(i,j)*x(ix) ix = ix + incx enddo y(jy) = y(jy) + alpha*temp jy = jy + incy enddo endif endif end subroutine sgemv !> !!##NAME !! sger(3f) - [BLAS:SINGLE_BLAS_LEVEL2] !! A:=A+alpha*SX*TRANSPOSE(SY), rank 1 update, A a rectangular matrix. !! !!##SYNOPSIS !! !! subroutine sger(m,n,alpha,x,incx,y,incy,a,lda) !! !! .. Scalar Arguments .. !! real,intent(in) :: alpha !! integer,intent(in) :: incx,incy,lda,m,n !! .. !! .. Array Arguments .. !! real,intent(in) :: x(*),y(*) !! real,intent(inout) :: a(lda,*) !! .. !! !!##DEFINITION !! !! SGER performs the rank 1 operation !! !! A := alpha*x*y**T + 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. !! !!##OPTIONS !! !! M !! !! M is INTEGER !! On entry, M specifies the number of rows of the matrix A. !! M must be at least zero. !! !! N !! !! N is INTEGER !! On entry, N specifies the number of columns of the matrix A. !! N must be at least zero. !! !! ALPHA !! !! ALPHA is REAL !! On entry, ALPHA specifies the scalar alpha. !! !! X !! !! X is REAL array, dimension at least !! ( 1 + ( m - 1 )*abs( INCX ) ). !! Before entry, the incremented array X must contain the m !! element vector x. !! !! INCX !! !! INCX is INTEGER !! On entry, INCX specifies the increment for the elements of !! X. INCX must not be zero. !! !! Y !! !! Y is REAL array, dimension at least !! ( 1 + ( n - 1 )*abs( INCY ) ). !! Before entry, the incremented array Y must contain the n !! element vector y. !! !! INCY !! !! INCY is INTEGER !! On entry, INCY specifies the increment for the elements of !! Y. INCY must not be zero. !! !! A !! !! A is REAL array, 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 !! !! LDA is 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 ). !! !!##AUTHORS !! !! + Univ. of Tennessee !! + Univ. of California Berkeley !! + Univ. of Colorado Denver !! + NAG Ltd. !! !! date:December 2016 !! !! FURTHER DETAILS !! !! 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. !! !!##SEE ALSO !! Online html documentation available at !! http://www.netlib.org/lapack/explore-html/ ! ===================================================================== subroutine sger(m,n,alpha,x,incx,y,incy,a,lda) implicit none ! ! -- Reference BLAS level2 routine (version 3.7.0) -- ! -- Reference BLAS is a software package provided by Univ. of Tennessee, -- ! -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- ! December 2016 ! ! .. Scalar Arguments .. real,intent(in) :: alpha integer,intent(in) :: incx,incy,lda,m,n ! .. ! .. Array Arguments .. real,intent(in) :: x(*),y(*) real,intent(inout) :: a(lda,*) ! .. ! ! ===================================================================== ! ! .. Parameters .. real zero parameter (zero=0.0e+0) ! .. ! .. Local Scalars .. real temp integer i,info,ix,j,jy,kx ! .. ! .. External Subroutines .. EXTERNAL XERBLA ! .. ! .. Intrinsic Functions .. intrinsic max ! .. ! ! Test the input parameters. ! info = 0 if (m.lt.0) then info = 1 elseif (n.lt.0) then info = 2 elseif (incx.eq.0) then info = 5 elseif (incy.eq.0) then info = 7 elseif (lda.lt.max(1,m)) then info = 9 endif if (info.ne.0) then call xerbla('SGER ',info) return endif ! ! Quick return if possible. ! if ((m.eq.0) .or. (n.eq.0) .or. (alpha.eq.zero)) return ! ! Start the operations. In this version the elements of A are ! accessed sequentially with one pass through A. ! if (incy.gt.0) then jy = 1 else jy = 1 - (n-1)*incy endif if (incx.eq.1) then do j = 1,n if (y(jy).ne.zero) then temp = alpha*y(jy) do i = 1,m a(i,j) = a(i,j) + x(i)*temp enddo endif jy = jy + incy enddo else if (incx.gt.0) then kx = 1 else kx = 1 - (m-1)*incx endif do j = 1,n if (y(jy).ne.zero) then temp = alpha*y(jy) ix = kx do i = 1,m a(i,j) = a(i,j) + x(ix)*temp ix = ix + incx enddo endif jy = jy + incy enddo endif end subroutine sger !> !!##NAME !! snrm2(3f) - [BLAS:SINGLE_BLAS_LEVEL1] !! SNRM2 := square root of sum of SX(I)**2 !! !!##SYNOPSIS !! !! real function snrm2(n,x,incx) !! !! .. Scalar Arguments .. !! integer,intent(in) :: incx, n !! .. !! .. Array Arguments .. !! real(wp),intent(in) :: x(*) !! .. !! !!##DEFINITION !! !! SNRM2 returns the euclidean norm of a vector via the function !! name, so that !! !! SNRM2 := sqrt( x'*x ). !! !!##OPTIONS !! !! N !! !! N is INTEGER !! number of elements in input vector(s) !! !! X !! !! X is REAL array, dimension ( 1 + ( N - 1 )*abs( INCX ) ) !! !! INCX !! !! INCX is INTEGER, storage spacing between elements of X !! If INCX > 0, X(1+(i-1)*INCX) = x(i) for 1 <= i <= n !! If INCX < 0, X(1-(n-i)*INCX) = x(i) for 1 <= i <= n !! If INCX = 0, x isn't a vector so there is no need to call !! this subroutine. If you call it anyway, it will count x(1) !! in the vector norm N times. !! !!##AUTHORS !! !! + Edward Anderson, Lockheed Martin !! !! date:August 2016 !! !! \par Contributors: !! !! Weslley Pereira, University of Colorado Denver, USA !! !! FURTHER DETAILS !! !! Anderson E. (2017) !! Algorithm 978: Safe Scaling in the Level 1 BLAS !! ACM Trans Math Softw 44:1--28 !! https://doi.org/10.1145/3061665 !! !! Blue, James L. (1978) !! A Portable Fortran Program to Find the Euclidean Norm of a Vector !! ACM Trans Math Softw 4:15--23 !! https://doi.org/10.1145/355769.355771 !! !!##SEE ALSO !! Online html documentation available at !! http://www.netlib.org/lapack/explore-html/ ! ===================================================================== function snrm2( n, x, incx ) integer, parameter :: wp = kind(1.e0) real(wp) :: snrm2 ! ! -- Reference BLAS level1 routine (version 3.9.1) -- ! -- Reference BLAS is a software package provided by Univ. of Tennessee, -- ! -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- ! March 2021 ! ! .. Constants .. real(wp), parameter :: zero = 0.0_wp real(wp), parameter :: one = 1.0_wp real(wp), parameter :: maxn = huge(0.0_wp) ! .. ! .. Blue's scaling constants .. real(wp), parameter :: tsml = real(radix(0._wp), wp)**ceiling( (minexponent(0._wp) - 1) * 0.5_wp) real(wp), parameter :: tbig = real(radix(0._wp), wp)**floor( (maxexponent(0._wp) - digits(0._wp) + 1) * 0.5_wp) real(wp), parameter :: ssml = real(radix(0._wp), wp)**( - floor( (minexponent(0._wp) - 1) * 0.5_wp)) real(wp), parameter :: sbig = real(radix(0._wp), wp)**( - ceiling( (maxexponent(0._wp) - digits(0._wp) + 1) * 0.5_wp)) ! .. ! .. Scalar Arguments .. integer,intent(in) :: incx, n ! .. ! .. Array Arguments .. real(wp),intent(in) :: x(*) ! .. ! .. Local Scalars .. integer :: i, ix logical :: notbig real(wp) :: abig, amed, asml, ax, scl, sumsq, ymax, ymin ! ! Quick return if possible ! snrm2 = zero if( n <= 0 ) return ! scl = one sumsq = zero ! ! Compute the sum of squares in 3 accumulators: ! abig -- sums of squares scaled down to avoid overflow ! asml -- sums of squares scaled up to avoid underflow ! amed -- sums of squares that do not require scaling ! The thresholds and multipliers are ! tbig -- values bigger than this are scaled down by sbig ! tsml -- values smaller than this are scaled up by ssml ! notbig = .true. asml = zero amed = zero abig = zero ix = 1 if( incx < 0 ) ix = 1 - (n-1)*incx do i = 1, n ax = abs(x(ix)) if (ax > tbig) then abig = abig + (ax*sbig)**2 notbig = .false. elseif (ax < tsml) then if (notbig) asml = asml + (ax*ssml)**2 else amed = amed + ax**2 endif ix = ix + incx enddo ! ! Combine abig and amed or amed and asml if more than one ! accumulator was used. ! if (abig > zero) then ! ! Combine abig and amed if abig > 0. ! if ( (amed > zero) .or. (amed > maxn) .or. (amed /= amed) ) then abig = abig + (amed*sbig)*sbig endif scl = one / sbig sumsq = abig elseif (asml > zero) then ! ! Combine amed and asml if asml > 0. ! if ( (amed > zero) .or. (amed > maxn) .or. (amed /= amed) ) then amed = sqrt(amed) asml = sqrt(asml) / ssml if (asml > amed) then ymin = amed ymax = asml else ymin = asml ymax = amed endif scl = one sumsq = ymax**2*( one + (ymin/ymax)**2 ) else scl = one / ssml sumsq = asml endif else ! ! Otherwise all values are mid-range ! scl = one sumsq = amed endif snrm2 = scl*sqrt( sumsq ) end function snrm2 !> !!##NAME !! srot(3f) - [BLAS:SINGLE_BLAS_LEVEL1] Apply Given's rotation. !! !!##SYNOPSIS !! !! subroutine srot(n,sx,incx,sy,incy,c,s) !! !! .. Scalar Arguments .. !! real,intent(in) :: c,s !! integer,intent(in) :: incx,incy,n !! .. !! .. Array Arguments .. !! real,intent(inout) :: sx(*),sy(*) !! .. !! !!##DEFINITION !! !! applies a plane rotation. !! !!##OPTIONS !! !! N !! !! N is INTEGER !! number of elements in input vector(s) !! !! SX !! !! SX is REAL array, dimension ( 1 + ( N - 1 )*abs( INCX ) ) !! !! INCX !! !! INCX is INTEGER !! storage spacing between elements of SX !! !! SY !! !! SY is REAL array, dimension ( 1 + ( N - 1 )*abs( INCY ) ) !! !! INCY !! !! INCY is INTEGER !! storage spacing between elements of SY !! !! C !! !! C is REAL !! !! S !! !! S is REAL !! !!##AUTHORS !! !! + Univ. of Tennessee !! + Univ. of California Berkeley !! + Univ. of Colorado Denver !! + NAG Ltd. !! !! date:November 2017 !! !! FURTHER DETAILS !! !! jack dongarra, linpack, 3/11/78. !! modified 12/3/93, array(1) declarations changed to array(*) !! !!##SEE ALSO !! Online html documentation available at !! http://www.netlib.org/lapack/explore-html/ ! ===================================================================== subroutine srot(n,sx,incx,sy,incy,c,s) implicit none ! ! -- Reference BLAS level1 routine (version 3.8.0) -- ! -- Reference BLAS is a software package provided by Univ. of Tennessee, -- ! -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- ! November 2017 ! ! .. Scalar Arguments .. real,intent(in) :: c,s integer,intent(in) :: incx,incy,n ! .. ! .. Array Arguments .. real,intent(inout) :: sx(*),sy(*) ! .. ! ! ===================================================================== ! ! .. Local Scalars .. real stemp integer i,ix,iy ! .. if (n.le.0) return if (incx.eq.1 .and. incy.eq.1) then ! ! code for both increments equal to 1 ! do i = 1,n stemp = c*sx(i) + s*sy(i) sy(i) = c*sy(i) - s*sx(i) sx(i) = stemp enddo else ! ! code for unequal increments or equal increments not equal ! to 1 ! ix = 1 iy = 1 if (incx.lt.0) ix = (-n+1)*incx + 1 if (incy.lt.0) iy = (-n+1)*incy + 1 do i = 1,n stemp = c*sx(ix) + s*sy(iy) sy(iy) = c*sy(iy) - s*sx(ix) sx(ix) = stemp ix = ix + incx iy = iy + incy enddo endif end subroutine srot !> !!##NAME !! srotg(3f) - [BLAS:SINGLE_BLAS_LEVEL1] Generate Given's rotation. !! !!##SYNOPSIS !! !! !! subroutine srotg( a, b, c, s ) !! !! .. Scalar Arguments .. !! real(wp),intent(inout) :: a, b !! real(wp),intent(out) :: c, s !! .. !! .. Local Scalars .. !! real(wp) :: anorm, bnorm, scl, sigma, r, z !! .. !! !!##DEFINITION !! SROTG constructs a plane rotation !! !! [ c s ] [ a ] = [ r ] !! [ -s c ] [ b ] [ 0 ] !! !! satisfying c**2 + s**2 = 1. !! !! The computation uses the formulas !! !! sigma = sgn(a) if |a| > |b| !! = sgn(b) if |b| >= |a| !! r = sigma*sqrt( a**2 + b**2 ) !! c = 1; s = 0 if r = 0 !! c = a/r; s = b/r if r != 0 !! !! The subroutine also computes !! !! z = s if |a| > |b|, !! = 1/c if |b| >= |a| and c != 0 !! = 1 if c = 0 !! !! This allows c and s to be reconstructed from z as follows: !! !! If z = 1, set c = 0, s = 1. !! If |z| < 1, set c = sqrt(1 - z**2) and s = z. !! If |z| > 1, set c = 1/z and s = sqrt( 1 - c**2). !! !!##OPTIONS !! !! A !! !! A is REAL !! On entry, the scalar a. !! On exit, the scalar r. !! !! B !! !! B is REAL !! On entry, the scalar b. !! On exit, the scalar z. !! !! C !! !! C is REAL !! The scalar c. !! !! S !! !! S is REAL !! The scalar s. !! !!##AUTHORS !! !! + Edward Anderson, Lockheed Martin !! !! \par Contributors: !! !! Weslley Pereira, University of Colorado Denver, USA !! !! FURTHER DETAILS !! !! Anderson E. (2017) !! Algorithm 978: Safe Scaling in the Level 1 BLAS !! ACM Trans Math Softw 44:1--28 !! https://doi.org/10.1145/3061665 !! !!##SEE ALSO !! Online html documentation available at !! http://www.netlib.org/lapack/explore-html/ ! ===================================================================== subroutine srotg( a, b, c, s ) integer, parameter :: wp = kind(1.e0) ! ! -- Reference BLAS level1 routine -- ! -- Reference BLAS is a software package provided by Univ. of Tennessee, -- ! -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- ! ! .. Constants .. real(wp), parameter :: zero = 0.0_wp real(wp), parameter :: one = 1.0_wp ! .. ! .. Scaling constants .. real(wp), parameter :: safmin = real(radix(0._wp),wp)**max( minexponent(0._wp)-1, 1-maxexponent(0._wp) ) real(wp), parameter :: safmax = real(radix(0._wp),wp)**max( 1-minexponent(0._wp), maxexponent(0._wp)-1 ) ! .. ! .. Scalar Arguments .. real(wp),intent(inout) :: a, b real(wp),intent(out) :: c, s ! .. ! .. Local Scalars .. real(wp) :: anorm, bnorm, scl, sigma, r, z ! .. ! .. Intrinsics intrinsic :: abs, sqrt, max, sign, min anorm = abs(a) bnorm = abs(b) if( bnorm == zero ) then c = one s = zero b = zero elseif ( anorm == zero ) then c = zero s = one a = b b = one else scl = min( safmax, max( safmin, anorm, bnorm ) ) if( anorm > bnorm ) then sigma = sign(one,a) else sigma = sign(one,b) endif r = sigma*( scl*sqrt((a/scl)**2 + (b/scl)**2) ) c = a/r s = b/r if( anorm > bnorm ) then z = s elseif ( c /= zero ) then z = one/c else z = one endif a = r b = z endif end subroutine !> !!##NAME !! srotm(3f) - [BLAS:SINGLE_BLAS_LEVEL1] Apply a modified Given's rotation. !! !!##SYNOPSIS !! !! subroutine srotm(n,sx,incx,sy,incy,sparam) !! !! .. Scalar Arguments .. !! integer,intent(in) :: incx,incy,n !! .. !! .. Array Arguments .. !! real,intent(in) :: sparam(5) !! real,intent(inout) :: sx(*),sy(*) !! .. !! !!##DEFINITION !! !! APPLY THE MODIFIED GIVENS TRANSFORMATION, H, TO THE 2 BY N MATRIX !! !! (SX**T) , WHERE **T INDICATES TRANSPOSE. THE ELEMENTS OF SX ARE IN !! (SX**T) !! !! SX(LX+I*INCX), I = 0 TO N-1, WHERE LX = 1 IF INCX .GE. 0, ELSE !! LX = (-INCX)*N, AND SIMILARLY FOR SY USING USING LY AND INCY. !! WITH SPARAM(1)=SFLAG, H HAS ONE OF THE FOLLOWING FORMS.. !! !! SFLAG=-1.E0 SFLAG=0.E0 SFLAG=1.E0 SFLAG=-2.E0 !! !! (SH11 SH12) (1.E0 SH12) (SH11 1.E0) (1.E0 0.E0) !! H=( ) ( ) ( ) ( ) !! (SH21 SH22), (SH21 1.E0), (-1.E0 SH22), (0.E0 1.E0). !! !! SEE SROTMG FOR A DESCRIPTION OF DATA STORAGE IN SPARAM. !! !!##OPTIONS !! !! N !! !! N is INTEGER !! number of elements in input vector(s) !! !! SX !! !! SX is REAL array, dimension ( 1 + ( N - 1 )*abs( INCX ) ) !! !! INCX !! !! INCX is INTEGER !! storage spacing between elements of SX !! !! SY !! !! SY is REAL array, dimension ( 1 + ( N - 1 )*abs( INCY ) ) !! !! INCY !! !! INCY is INTEGER !! storage spacing between elements of SY !! !! SPARAM !! !! SPARAM is REAL array, dimension (5) !! SPARAM(1)=SFLAG !! SPARAM(2)=SH11 !! SPARAM(3)=SH21 !! SPARAM(4)=SH12 !! SPARAM(5)=SH22 !! !!##AUTHORS !! !! + Univ. of Tennessee !! + Univ. of California Berkeley !! + Univ. of Colorado Denver !! + NAG Ltd. !! !! date:November 2017 !! !!##SEE ALSO !! Online html documentation available at !! http://www.netlib.org/lapack/explore-html/ ! ===================================================================== subroutine srotm(n,sx,incx,sy,incy,sparam) implicit none ! ! -- Reference BLAS level1 routine (version 3.8.0) -- ! -- Reference BLAS is a software package provided by Univ. of Tennessee, -- ! -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- ! November 2017 ! ! .. Scalar Arguments .. integer,intent(in) :: incx,incy,n ! .. ! .. Array Arguments .. real,intent(in) :: sparam(5) real,intent(inout) :: sx(*),sy(*) ! .. ! ! ===================================================================== ! ! .. Local Scalars .. real sflag,sh11,sh12,sh21,sh22,w,z real,parameter :: zero=0.0e0 real,parameter :: two=2.0e0 integer i,kx,ky,nsteps ! .. ! sflag = sparam(1) if (n.le.0 .or. (sflag+two.eq.zero)) return if (incx.eq.incy.and.incx.gt.0) then ! nsteps = n*incx if (sflag.lt.zero) then sh11 = sparam(2) sh12 = sparam(4) sh21 = sparam(3) sh22 = sparam(5) do i = 1,nsteps,incx w = sx(i) z = sy(i) sx(i) = w*sh11 + z*sh12 sy(i) = w*sh21 + z*sh22 enddo elseif (sflag.eq.zero) then sh12 = sparam(4) sh21 = sparam(3) do i = 1,nsteps,incx w = sx(i) z = sy(i) sx(i) = w + z*sh12 sy(i) = w*sh21 + z enddo else sh11 = sparam(2) sh22 = sparam(5) do i = 1,nsteps,incx w = sx(i) z = sy(i) sx(i) = w*sh11 + z sy(i) = -w + sh22*z enddo endif else kx = 1 ky = 1 if (incx.lt.0) kx = 1 + (1-n)*incx if (incy.lt.0) ky = 1 + (1-n)*incy ! if (sflag.lt.zero) then sh11 = sparam(2) sh12 = sparam(4) sh21 = sparam(3) sh22 = sparam(5) do i = 1,n w = sx(kx) z = sy(ky) sx(kx) = w*sh11 + z*sh12 sy(ky) = w*sh21 + z*sh22 kx = kx + incx ky = ky + incy enddo elseif (sflag.eq.zero) then sh12 = sparam(4) sh21 = sparam(3) do i = 1,n w = sx(kx) z = sy(ky) sx(kx) = w + z*sh12 sy(ky) = w*sh21 + z kx = kx + incx ky = ky + incy enddo else sh11 = sparam(2) sh22 = sparam(5) do i = 1,n w = sx(kx) z = sy(ky) sx(kx) = w*sh11 + z sy(ky) = -w + sh22*z kx = kx + incx ky = ky + incy enddo endif endif end subroutine srotm !> !!##NAME !! srotmg(3f) - [BLAS:SINGLE_BLAS_LEVEL1] Generate a modified Given's rotation. !! !!##SYNOPSIS !! !! subroutine srotmg(sd1,sd2,sx1,sy1,sparam) !! !! .. Scalar Arguments .. !! real,intent(inout) :: sd1,sd2,sx1 !! real,intent(in) :: sy1 !! .. !! .. Array Arguments .. !! real,intent(out) :: sparam(5) !! .. !! !!##DEFINITION !! !! Construct the modified Givens Transformation Matrix H which zeros !! the second component of the 2-vector !! !! (sqrt(sd1)*sx1,sqrt(sd2)*>sy2)**t. !! !! with sparam(1)=sflag, H has one of the following forms.. !! !! SFLAG=-1.E0 SFLAG=0.E0 SFLAG=1.E0 SFLAG=-2.E0 !! !! (SH11 SH12) (1.E0 SH12) (SH11 1.E0) (1.E0 0.E0) !! H=( ) ( ) ( ) ( ) !! (SH21 SH22), (SH21 1.E0), (-1.E0 SH22), (0.E0 1.E0). !! !! locations 2-4 of SPARAM contain SH11,SH21,SH12, and SH22 !! respectively. (values of 1.e0, -1.e0, or 0.e0 implied by the value !! of SPARAM(1) are not stored in SPARAM.) !! !! 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 !! SD1 and SD2. All actual scaling of data is done using GAM. !! !!##OPTIONS !! !! SD1 !! !! SD1 is REAL !! !! SD2 !! !! SD2 is REAL !! !! SX1 !! !! SX1 is REAL !! !! SY1 !! !! SY1 is REAL !! !! SPARAM !! !! SPARAM is REAL array, dimension (5) !! SPARAM(1)=SFLAG !! SPARAM(2)=SH11 !! SPARAM(3)=SH21 !! SPARAM(4)=SH12 !! SPARAM(5)=SH22 !! !!##AUTHORS !! !! + Univ. of Tennessee !! + Univ. of California Berkeley !! + Univ. of Colorado Denver !! + NAG Ltd. !! !! date:November 2017 !! !!##SEE ALSO !! Online html documentation available at !! http://www.netlib.org/lapack/explore-html/ ! ===================================================================== subroutine srotmg(sd1,sd2,sx1,sy1,sparam) implicit none ! ! -- Reference BLAS level1 routine (version 3.8.0) -- ! -- Reference BLAS is a software package provided by Univ. of Tennessee, -- ! -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- ! November 2017 ! ! .. Scalar Arguments .. real,intent(inout) :: sd1,sd2,sx1 real,intent(in) :: sy1 ! .. ! .. Array Arguments .. real,intent(out) :: sparam(5) ! .. ! ===================================================================== ! ! .. Local Scalars .. real sflag,sh11,sh12,sh21,sh22,sp1,sp2,sq1, sq2,stemp,su ! .. ! .. Intrinsic Functions .. intrinsic abs ! .. ! .. Data statements .. real,parameter :: zero=0.0e0 real,parameter :: one=1.0e0 real,parameter :: two=2.0e0 ! real,parameter :: gam=4096.e0 real,parameter :: gamsq=1.67772e7 real,parameter :: rgamsq=5.96046e-8 ! .. if (sd1.lt.zero) then ! GO ZERO-H-D-AND-SX1.. sflag = -one sh11 = zero sh12 = zero sh21 = zero sh22 = zero ! sd1 = zero sd2 = zero sx1 = zero else ! CASE-SD1-NONNEGATIVE sp2 = sd2*sy1 if (sp2.eq.zero) then sflag = -two sparam(1) = sflag return endif ! REGULAR-CASE.. sp1 = sd1*sx1 sq2 = sp2*sy1 sq1 = sp1*sx1 ! if (abs(sq1).gt.abs(sq2)) then sh21 = -sy1/sx1 sh12 = sp2/sp1 ! su = one - sh12*sh21 ! if (su.gt.zero) then sflag = zero sd1 = sd1/su sd2 = sd2/su sx1 = sx1*su else ! This code path if here for safety. We do not expect this ! condition to ever hold except in edge cases with rounding ! errors. See DOI: 10.1145/355841.355847 sflag = -one sh11 = zero sh12 = zero sh21 = zero sh22 = zero ! sd1 = zero sd2 = zero sx1 = zero endif else if (sq2.lt.zero) then ! GO ZERO-H-D-AND-SX1.. sflag = -one sh11 = zero sh12 = zero sh21 = zero sh22 = zero ! sd1 = zero sd2 = zero sx1 = zero else sflag = one sh11 = sp1/sp2 sh22 = sx1/sy1 su = one + sh11*sh22 stemp = sd2/su sd2 = sd1/su sd1 = stemp sx1 = sy1*su endif endif ! PROCEDURE..SCALE-CHECK if (sd1.ne.zero) then do while ((sd1.le.rgamsq) .or. (sd1.ge.gamsq)) if (sflag.eq.zero) then sh11 = one sh22 = one sflag = -one else sh21 = -one sh12 = one sflag = -one endif if (sd1.le.rgamsq) then sd1 = sd1*gam**2 sx1 = sx1/gam sh11 = sh11/gam sh12 = sh12/gam else sd1 = sd1/gam**2 sx1 = sx1*gam sh11 = sh11*gam sh12 = sh12*gam endif enddo endif if (sd2.ne.zero) then do while ( (abs(sd2).le.rgamsq) .or. (abs(sd2).ge.gamsq) ) if (sflag.eq.zero) then sh11 = one sh22 = one sflag = -one else sh21 = -one sh12 = one sflag = -one endif if (abs(sd2).le.rgamsq) then sd2 = sd2*gam**2 sh21 = sh21/gam sh22 = sh22/gam else sd2 = sd2/gam**2 sh21 = sh21*gam sh22 = sh22*gam endif enddo endif endif if (sflag.lt.zero) then sparam(2) = sh11 sparam(3) = sh21 sparam(4) = sh12 sparam(5) = sh22 elseif (sflag.eq.zero) then sparam(3) = sh21 sparam(4) = sh12 else sparam(2) = sh11 sparam(5) = sh22 endif sparam(1) = sflag end subroutine srotmg !> !!##NAME !! ssbmv(3f) - [BLAS:SINGLE_BLAS_LEVEL2] SY:=alpha*A*SX+beta*SY, A a symmetric band matrix. !! !!##SYNOPSIS !! !! subroutine ssbmv(uplo,n,k,alpha,a,lda,x,incx,beta,y,incy) !! !! .. Scalar Arguments .. !! real,intent(in) :: alpha,beta !! integer,intent(in) :: incx,incy,k,lda,n !! character,intent(in) :: uplo !! .. !! .. Array Arguments .. !! real,intent(in) :: a(lda,*),x(*) !! real,intent(inout) :: y(*) !! .. !! !!##DEFINITION !! !! SSBMV 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. !! !!##OPTIONS !! !! UPLO !! !! UPLO is 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. !! !! N !! !! N is INTEGER !! On entry, N specifies the order of the matrix A. !! N must be at least zero. !! !! K !! !! K is INTEGER !! On entry, K specifies the number of super-diagonals of the !! matrix A. K must satisfy 0 .le. K. !! !! ALPHA !! !! ALPHA is REAL !! On entry, ALPHA specifies the scalar alpha. !! !! A !! !! A is REAL array, 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 !! !! LDA !! !! LDA is INTEGER !! On entry, LDA specifies the first dimension of A as declared !! in the calling (sub) program. LDA must be at least !! ( k + 1 ). !! !! X !! !! X is REAL array, dimension at least !! ( 1 + ( n - 1 )*abs( INCX ) ). !! Before entry, the incremented array X must contain the !! vector x. !! !! INCX !! !! INCX is INTEGER !! On entry, INCX specifies the increment for the elements of !! X. INCX must not be zero. !! !! BETA !! !! BETA is REAL !! On entry, BETA specifies the scalar beta. !! !! Y !! !! Y is REAL array, 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 !! !! INCY is INTEGER !! On entry, INCY specifies the increment for the elements of !! Y. INCY must not be zero. !! !!##AUTHORS !! !! + Univ. of Tennessee !! + Univ. of California Berkeley !! + Univ. of Colorado Denver !! + NAG Ltd. !! !! date:December 2016 !! !! FURTHER DETAILS !! !! Level 2 Blas routine. !! The vector and matrix arguments are not referenced when N = 0, or M = 0 !! !! -- 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. !! !!##SEE ALSO !! Online html documentation available at !! http://www.netlib.org/lapack/explore-html/ ! ===================================================================== subroutine ssbmv(uplo,n,k,alpha,a,lda,x,incx,beta,y,incy) implicit none ! ! -- Reference BLAS level2 routine (version 3.7.0) -- ! -- Reference BLAS is a software package provided by Univ. of Tennessee, -- ! -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- ! December 2016 ! ! .. Scalar Arguments .. real,intent(in) :: alpha,beta integer,intent(in) :: incx,incy,k,lda,n character,intent(in) :: uplo ! .. ! .. Array Arguments .. real,intent(in) :: a(lda,*),x(*) real,intent(inout) :: y(*) ! .. ! ! ===================================================================== ! ! .. Parameters .. real one,zero parameter (one=1.0e+0,zero=0.0e+0) ! .. ! .. Local Scalars .. real temp1,temp2 integer i,info,ix,iy,j,jx,jy,kplus1,kx,ky,l ! .. ! .. External Functions .. LOGICAL LSAME ! .. ! .. External Subroutines .. EXTERNAL XERBLA ! .. ! .. Intrinsic Functions .. intrinsic max,min ! .. ! ! Test the input parameters. ! info = 0 if (.not.lsame(uplo,'U') .and. .not.lsame(uplo,'L')) then info = 1 elseif (n.lt.0) then info = 2 elseif (k.lt.0) then info = 3 elseif (lda.lt. (k+1)) then info = 6 elseif (incx.eq.0) then info = 8 elseif (incy.eq.0) then info = 11 endif if (info.ne.0) then call xerbla('SSBMV ',info) return endif ! ! Quick return if possible. ! if ((n.eq.0) .or. ((alpha.eq.zero).and. (beta.eq.one))) return ! ! Set up the start points in X and Y. ! if (incx.gt.0) then kx = 1 else kx = 1 - (n-1)*incx endif if (incy.gt.0) then ky = 1 else ky = 1 - (n-1)*incy endif ! ! 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.ne.one) then if (incy.eq.1) then if (beta.eq.zero) then y(1:n) = zero else y(1:n) = beta*y(1:n) endif else iy = ky if (beta.eq.zero) then do i = 1,n y(iy) = zero iy = iy + incy enddo else do i = 1,n y(iy) = beta*y(iy) iy = iy + incy enddo endif endif endif if (alpha.eq.zero) return if (lsame(uplo,'U')) then ! ! Form y when upper triangle of A is stored. ! kplus1 = k + 1 if ((incx.eq.1) .and. (incy.eq.1)) then do j = 1,n temp1 = alpha*x(j) temp2 = zero l = kplus1 - j do i = max(1,j-k),j - 1 y(i) = y(i) + temp1*a(l+i,j) temp2 = temp2 + a(l+i,j)*x(i) enddo y(j) = y(j) + temp1*a(kplus1,j) + alpha*temp2 enddo else jx = kx jy = ky do j = 1,n temp1 = alpha*x(jx) temp2 = zero ix = kx iy = ky l = kplus1 - j do i = max(1,j-k),j - 1 y(iy) = y(iy) + temp1*a(l+i,j) temp2 = temp2 + a(l+i,j)*x(ix) ix = ix + incx iy = iy + incy enddo y(jy) = y(jy) + temp1*a(kplus1,j) + alpha*temp2 jx = jx + incx jy = jy + incy if (j.gt.k) then kx = kx + incx ky = ky + incy endif enddo endif else ! ! Form y when lower triangle of A is stored. ! if ((incx.eq.1) .and. (incy.eq.1)) then do j = 1,n temp1 = alpha*x(j) temp2 = zero y(j) = y(j) + temp1*a(1,j) l = 1 - j do i = j + 1,min(n,j+k) y(i) = y(i) + temp1*a(l+i,j) temp2 = temp2 + a(l+i,j)*x(i) enddo y(j) = y(j) + alpha*temp2 enddo else jx = kx jy = ky do j = 1,n temp1 = alpha*x(jx) temp2 = zero y(jy) = y(jy) + temp1*a(1,j) l = 1 - j ix = jx iy = jy do i = j + 1,min(n,j+k) ix = ix + incx iy = iy + incy y(iy) = y(iy) + temp1*a(l+i,j) temp2 = temp2 + a(l+i,j)*x(ix) enddo y(jy) = y(jy) + alpha*temp2 jx = jx + incx jy = jy + incy enddo endif endif end subroutine ssbmv !> !!##NAME !! sscal(3f) - [BLAS:SINGLE_BLAS_LEVEL1] SX:=SA*SX. !! !!##SYNOPSIS !! !! subroutine sscal(n,sa,sx,incx) !! !! .. Scalar Arguments .. !! real,intent(in) :: sa !! integer,intent(in) :: incx,n !! .. !! .. Array Arguments .. !! real,intent(inout) :: sx(*) !! .. !! !!##DEFINITION !! !! SSCAL scales a vector by a constant. !! uses unrolled loops for increment equal to 1. !! !!##OPTIONS !! !! N !! !! N is INTEGER !! number of elements in input vector(s) !! !! SA !! !! SA is REAL !! On entry, SA specifies the scalar alpha. !! !! SX !! !! SX is REAL array, dimension ( 1 + ( N - 1 )*abs( INCX ) ) !! !! INCX !! !! INCX is INTEGER !! storage spacing between elements of SX !! !!##AUTHORS !! !! + Univ. of Tennessee !! + Univ. of California Berkeley !! + Univ. of Colorado Denver !! + NAG Ltd. !! !! date:November 2017 !! !! FURTHER DETAILS !! !! 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(*) !! !!##SEE ALSO !! Online html documentation available at !! http://www.netlib.org/lapack/explore-html/ ! ===================================================================== subroutine sscal(n,sa,sx,incx) implicit none ! ! -- Reference BLAS level1 routine (version 3.8.0) -- ! -- Reference BLAS is a software package provided by Univ. of Tennessee, -- ! -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- ! November 2017 ! ! .. Scalar Arguments .. real,intent(in) :: sa integer,intent(in) :: incx,n ! .. ! .. Array Arguments .. real,intent(inout) :: sx(*) ! .. ! ! ===================================================================== ! ! .. Local Scalars .. integer i,m,mp1,nincx ! .. ! .. Intrinsic Functions .. intrinsic mod ! .. if (n.le.0 .or. incx.le.0) return if (incx.eq.1) then ! ! code for increment equal to 1 ! ! ! clean-up loop ! m = mod(n,5) if (m.ne.0) then do i = 1,m sx(i) = sa*sx(i) enddo if (n.lt.5) return endif mp1 = m + 1 do i = mp1,n,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) enddo else ! ! code for increment not equal to 1 ! nincx = n*incx do i = 1,nincx,incx sx(i) = sa*sx(i) enddo endif end subroutine sscal !> !!##NAME !! sspmv(3f) - [BLAS:SINGLE_BLAS_LEVEL2] SY:=alpha*A*SX+beta*SY, A a packed symmetric matrix. !! !!##SYNOPSIS !! !! subroutine sspmv(uplo,n,alpha,ap,x,incx,beta,y,incy) !! !! .. Scalar Arguments .. !! real,intent(in) :: alpha,beta !! integer,intent(in) :: incx,incy,n !! character,intent(in) :: uplo !! .. !! .. Array Arguments .. !! real,intent(in) :: ap(*),x(*) !! real,intent(inout) :: y(*) !! .. !! !!##DEFINITION !! !! SSPMV 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. !! !!##OPTIONS !! !! UPLO !! !! UPLO is 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. !! !! N !! !! N is INTEGER !! On entry, N specifies the order of the matrix A. !! N must be at least zero. !! !! ALPHA !! !! ALPHA is REAL !! On entry, ALPHA specifies the scalar alpha. !! !! AP !! !! AP is REAL array, 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. !! !! X !! !! X is REAL array, dimension at least !! ( 1 + ( n - 1 )*abs( INCX ) ). !! Before entry, the incremented array X must contain the n !! element vector x. !! !! INCX !! !! INCX is INTEGER !! On entry, INCX specifies the increment for the elements of !! X. INCX must not be zero. !! !! BETA !! !! BETA is REAL !! On entry, BETA specifies the scalar beta. When BETA is !! supplied as zero then Y need not be set on input. !! !! Y !! !! Y is REAL array, 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 !! !! INCY is INTEGER !! On entry, INCY specifies the increment for the elements of !! Y. INCY must not be zero. !! !!##AUTHORS !! !! + Univ. of Tennessee !! + Univ. of California Berkeley !! + Univ. of Colorado Denver !! + NAG Ltd. !! !! date:December 2016 !! !! FURTHER DETAILS !! !! Level 2 Blas routine. !! The vector and matrix arguments are not referenced when N = 0, or M = 0 !! !! -- 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. !! !!##SEE ALSO !! Online html documentation available at !! http://www.netlib.org/lapack/explore-html/ ! ===================================================================== subroutine sspmv(uplo,n,alpha,ap,x,incx,beta,y,incy) implicit none ! ! -- Reference BLAS level2 routine (version 3.7.0) -- ! -- Reference BLAS is a software package provided by Univ. of Tennessee, -- ! -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- ! December 2016 ! ! .. Scalar Arguments .. real,intent(in) :: alpha,beta integer,intent(in) :: incx,incy,n character,intent(in) :: uplo ! .. ! .. Array Arguments .. real,intent(in) :: ap(*),x(*) real,intent(inout) :: y(*) ! .. ! ! ===================================================================== ! ! .. Parameters .. real one,zero parameter (one=1.0e+0,zero=0.0e+0) ! .. ! .. Local Scalars .. real temp1,temp2 integer i,info,ix,iy,j,jx,jy,k,kk,kx,ky ! .. ! .. External Functions .. LOGICAL LSAME ! .. ! .. External Subroutines .. EXTERNAL XERBLA ! .. ! ! Test the input parameters. ! info = 0 if (.not.lsame(uplo,'U') .and. .not.lsame(uplo,'L')) then info = 1 elseif (n.lt.0) then info = 2 elseif (incx.eq.0) then info = 6 elseif (incy.eq.0) then info = 9 endif if (info.ne.0) then call xerbla('SSPMV ',info) return endif ! ! Quick return if possible. ! if ((n.eq.0) .or. ((alpha.eq.zero).and. (beta.eq.one))) return ! ! Set up the start points in X and Y. ! if (incx.gt.0) then kx = 1 else kx = 1 - (n-1)*incx endif if (incy.gt.0) then ky = 1 else ky = 1 - (n-1)*incy endif ! ! 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.ne.one) then if (incy.eq.1) then if (beta.eq.zero) then y(1:n) = zero else y(1:n) = beta*y(1:n) endif else iy = ky if (beta.eq.zero) then do i = 1,n y(iy) = zero iy = iy + incy enddo else do i = 1,n y(iy) = beta*y(iy) iy = iy + incy enddo endif endif endif if (alpha.eq.zero) return kk = 1 if (lsame(uplo,'U')) then ! ! Form y when AP contains the upper triangle. ! if ((incx.eq.1) .and. (incy.eq.1)) then do j = 1,n temp1 = alpha*x(j) temp2 = zero k = kk do i = 1,j - 1 y(i) = y(i) + temp1*ap(k) temp2 = temp2 + ap(k)*x(i) k = k + 1 enddo y(j) = y(j) + temp1*ap(kk+j-1) + alpha*temp2 kk = kk + j enddo else jx = kx jy = ky do j = 1,n temp1 = alpha*x(jx) temp2 = zero ix = kx iy = ky do k = kk,kk + j - 2 y(iy) = y(iy) + temp1*ap(k) temp2 = temp2 + ap(k)*x(ix) ix = ix + incx iy = iy + incy enddo y(jy) = y(jy) + temp1*ap(kk+j-1) + alpha*temp2 jx = jx + incx jy = jy + incy kk = kk + j enddo endif else ! ! Form y when AP contains the lower triangle. ! if ((incx.eq.1) .and. (incy.eq.1)) then do j = 1,n temp1 = alpha*x(j) temp2 = zero y(j) = y(j) + temp1*ap(kk) k = kk + 1 do i = j + 1,n y(i) = y(i) + temp1*ap(k) temp2 = temp2 + ap(k)*x(i) k = k + 1 enddo y(j) = y(j) + alpha*temp2 kk = kk + (n-j+1) enddo else jx = kx jy = ky do j = 1,n temp1 = alpha*x(jx) temp2 = zero y(jy) = y(jy) + temp1*ap(kk) ix = jx iy = jy do k = kk + 1,kk + n - j ix = ix + incx iy = iy + incy y(iy) = y(iy) + temp1*ap(k) temp2 = temp2 + ap(k)*x(ix) enddo y(jy) = y(jy) + alpha*temp2 jx = jx + incx jy = jy + incy kk = kk + (n-j+1) enddo endif endif end subroutine sspmv !> !!##NAME !! sspr2(3f) - [BLAS:SINGLE_BLAS_LEVEL2] A:=A+alpha*SX*TRANSPOSE(SY)+alpha*SY*TRANSPOSE(SX), A packed symmetric. !! !!##SYNOPSIS !! !! subroutine sspr2(uplo,n,alpha,x,incx,y,incy,ap) !! !! .. Scalar Arguments .. !! real,intent(in) :: alpha !! integer,intent(in) :: incx,incy,n !! character,intent(in) :: uplo !! .. !! .. Array Arguments .. !! real,intent(in) :: x(*),y(*) !! real,intent(inout) :: ap(*) !! .. !! !!##DEFINITION !! !! SSPR2 performs the symmetric rank 2 operation !! !! A := alpha*x*y**T + alpha*y*x**T + 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. !! !!##OPTIONS !! !! UPLO !! !! UPLO is 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. !! !! N !! !! N is INTEGER !! On entry, N specifies the order of the matrix A. !! N must be at least zero. !! !! ALPHA !! !! ALPHA is REAL !! On entry, ALPHA specifies the scalar alpha. !! !! X !! !! X is REAL array, dimension at least !! ( 1 + ( n - 1 )*abs( INCX ) ). !! Before entry, the incremented array X must contain the n !! element vector x. !! !! INCX !! !! INCX is INTEGER !! On entry, INCX specifies the increment for the elements of !! X. INCX must not be zero. !! !! Y !! !! Y is REAL array, dimension at least !! ( 1 + ( n - 1 )*abs( INCY ) ). !! Before entry, the incremented array Y must contain the n !! element vector y. !! !! INCY !! !! INCY is INTEGER !! On entry, INCY specifies the increment for the elements of !! Y. INCY must not be zero. !! !! AP !! !! AP is REAL array, 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. !! !!##AUTHORS !! !! + Univ. of Tennessee !! + Univ. of California Berkeley !! + Univ. of Colorado Denver !! + NAG Ltd. !! !! date:December 2016 !! !! FURTHER DETAILS !! !! 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. !! !!##SEE ALSO !! Online html documentation available at !! http://www.netlib.org/lapack/explore-html/ ! ===================================================================== subroutine sspr2(uplo,n,alpha,x,incx,y,incy,ap) implicit none ! ! -- Reference BLAS level2 routine (version 3.7.0) -- ! -- Reference BLAS is a software package provided by Univ. of Tennessee, -- ! -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- ! December 2016 ! ! .. Scalar Arguments .. real,intent(in) :: alpha integer,intent(in) :: incx,incy,n character,intent(in) :: uplo ! .. ! .. Array Arguments .. real,intent(in) :: x(*),y(*) real,intent(inout) :: ap(*) ! .. ! ! ===================================================================== ! ! .. Parameters .. real zero parameter (zero=0.0e+0) ! .. ! .. Local Scalars .. real temp1,temp2 integer i,info,ix,iy,j,jx,jy,k,kk,kx,ky ! .. ! .. External Functions .. LOGICAL LSAME ! .. ! .. External Subroutines .. EXTERNAL XERBLA ! .. ! ! Test the input parameters. ! info = 0 if (.not.lsame(uplo,'U') .and. .not.lsame(uplo,'L')) then info = 1 elseif (n.lt.0) then info = 2 elseif (incx.eq.0) then info = 5 elseif (incy.eq.0) then info = 7 endif if (info.ne.0) then call xerbla('SSPR2 ',info) return endif ! ! Quick return if possible. ! if ((n.eq.0) .or. (alpha.eq.zero)) return ! ! Set up the start points in X and Y if the increments are not both ! unity. ! if ((incx.ne.1) .or. (incy.ne.1)) then if (incx.gt.0) then kx = 1 else kx = 1 - (n-1)*incx endif if (incy.gt.0) then ky = 1 else ky = 1 - (n-1)*incy endif jx = kx jy = ky endif ! ! 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')) then ! ! Form A when upper triangle is stored in AP. ! if ((incx.eq.1) .and. (incy.eq.1)) then do j = 1,n if ((x(j).ne.zero) .or. (y(j).ne.zero)) then temp1 = alpha*y(j) temp2 = alpha*x(j) k = kk do i = 1,j ap(k) = ap(k) + x(i)*temp1 + y(i)*temp2 k = k + 1 enddo endif kk = kk + j enddo else do j = 1,n if ((x(jx).ne.zero) .or. (y(jy).ne.zero)) then temp1 = alpha*y(jy) temp2 = alpha*x(jx) ix = kx iy = ky do k = kk,kk + j - 1 ap(k) = ap(k) + x(ix)*temp1 + y(iy)*temp2 ix = ix + incx iy = iy + incy enddo endif jx = jx + incx jy = jy + incy kk = kk + j enddo endif else ! ! Form A when lower triangle is stored in AP. ! if ((incx.eq.1) .and. (incy.eq.1)) then do j = 1,n if ((x(j).ne.zero) .or. (y(j).ne.zero)) then temp1 = alpha*y(j) temp2 = alpha*x(j) k = kk do i = j,n ap(k) = ap(k) + x(i)*temp1 + y(i)*temp2 k = k + 1 enddo endif kk = kk + n - j + 1 enddo else do j = 1,n if ((x(jx).ne.zero) .or. (y(jy).ne.zero)) then temp1 = alpha*y(jy) temp2 = alpha*x(jx) ix = jx iy = jy do k = kk,kk + n - j ap(k) = ap(k) + x(ix)*temp1 + y(iy)*temp2 ix = ix + incx iy = iy + incy enddo endif jx = jx + incx jy = jy + incy kk = kk + n - j + 1 enddo endif endif end subroutine sspr2 !> !!##NAME !! sspr(3f) - [BLAS:SINGLE_BLAS_LEVEL2] A:=A+alpha*SX*TRANSPOSE(SX), A a packed symmetric matrix. !! !!##SYNOPSIS !! !! subroutine sspr(uplo,n,alpha,x,incx,ap) !! !! .. Scalar Arguments .. !! real,intent(in) :: alpha !! integer,intent(in) :: incx,n !! character,intent(in) :: uplo !! .. !! .. Array Arguments .. !! real,intent(in) :: x(*) !! real,intent(inout) :: ap(*) !! .. !! !!##DEFINITION !! !! SSPR performs the symmetric rank 1 operation !! !! A := alpha*x*x**T + 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. !! !!##OPTIONS !! !! UPLO !! !! UPLO is 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. !! !! N !! !! N is INTEGER !! On entry, N specifies the order of the matrix A. !! N must be at least zero. !! !! ALPHA !! !! ALPHA is REAL !! On entry, ALPHA specifies the scalar alpha. !! !! X !! !! X is REAL array, dimension at least !! ( 1 + ( n - 1 )*abs( INCX ) ). !! Before entry, the incremented array X must contain the n !! element vector x. !! !! INCX !! !! INCX is INTEGER !! On entry, INCX specifies the increment for the elements of !! X. INCX must not be zero. !! !! AP !! !! AP is REAL array, 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. !! !!##AUTHORS !! !! + Univ. of Tennessee !! + Univ. of California Berkeley !! + Univ. of Colorado Denver !! + NAG Ltd. !! !! date:December 2016 !! !! FURTHER DETAILS !! !! 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. !! !!##SEE ALSO !! Online html documentation available at !! http://www.netlib.org/lapack/explore-html/ ! ===================================================================== subroutine sspr(uplo,n,alpha,x,incx,ap) implicit none ! ! -- Reference BLAS level2 routine (version 3.7.0) -- ! -- Reference BLAS is a software package provided by Univ. of Tennessee, -- ! -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- ! December 2016 ! ! .. Scalar Arguments .. real,intent(in) :: alpha integer,intent(in) :: incx,n character,intent(in) :: uplo ! .. ! .. Array Arguments .. real,intent(in) :: x(*) real,intent(inout) :: ap(*) ! .. ! ! ===================================================================== ! ! .. Parameters .. real zero parameter (zero=0.0e+0) ! .. ! .. Local Scalars .. real temp integer i,info,ix,j,jx,k,kk,kx ! .. ! .. External Functions .. LOGICAL LSAME ! .. ! .. External Subroutines .. EXTERNAL XERBLA ! .. ! ! Test the input parameters. ! info = 0 if (.not.lsame(uplo,'U') .and. .not.lsame(uplo,'L')) then info = 1 elseif (n.lt.0) then info = 2 elseif (incx.eq.0) then info = 5 endif if (info.ne.0) then call xerbla('SSPR ',info) return endif ! ! Quick return if possible. ! if ((n.eq.0) .or. (alpha.eq.zero)) return ! ! Set the start point in X if the increment is not unity. ! if (incx.le.0) then kx = 1 - (n-1)*incx elseif (incx.ne.1) then kx = 1 endif ! ! 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')) then ! ! Form A when upper triangle is stored in AP. ! if (incx.eq.1) then do j = 1,n if (x(j).ne.zero) then temp = alpha*x(j) k = kk do i = 1,j ap(k) = ap(k) + x(i)*temp k = k + 1 enddo endif kk = kk + j enddo else jx = kx do j = 1,n if (x(jx).ne.zero) then temp = alpha*x(jx) ix = kx do k = kk,kk + j - 1 ap(k) = ap(k) + x(ix)*temp ix = ix + incx enddo endif jx = jx + incx kk = kk + j enddo endif else ! ! Form A when lower triangle is stored in AP. ! if (incx.eq.1) then do j = 1,n if (x(j).ne.zero) then temp = alpha*x(j) k = kk do i = j,n ap(k) = ap(k) + x(i)*temp k = k + 1 enddo endif kk = kk + n - j + 1 enddo else jx = kx do j = 1,n if (x(jx).ne.zero) then temp = alpha*x(jx) ix = jx do k = kk,kk + n - j ap(k) = ap(k) + x(ix)*temp ix = ix + incx enddo endif jx = jx + incx kk = kk + n - j + 1 enddo endif endif end subroutine sspr !> !!##NAME !! sswap(3f) - [BLAS:SINGLE_BLAS_LEVEL1] Interchange vectors SX and SY. !! !!##SYNOPSIS !! !! subroutine sswap(n,sx,incx,sy,incy) !! !! .. Scalar Arguments .. !! integer,intent(in) :: incx,incy,n !! .. !! .. Array Arguments .. !! real,intent(inout) :: sx(*),sy(*) !! .. !! !!##DEFINITION !! !! SSWAP interchanges two vectors. !! uses unrolled loops for increments equal to 1. !! !!##OPTIONS !! !! N !! !! N is INTEGER !! number of elements in input vector(s) !! !! SX !! !! SX is REAL array, dimension ( 1 + ( N - 1 )*abs( INCX ) ) !! !! INCX !! !! INCX is INTEGER !! storage spacing between elements of SX !! !! SY !! !! SY is REAL array, dimension ( 1 + ( N - 1 )*abs( INCY ) ) !! !! INCY !! !! INCY is INTEGER !! storage spacing between elements of SY !! !!##AUTHORS !! !! + Univ. of Tennessee !! + Univ. of California Berkeley !! + Univ. of Colorado Denver !! + NAG Ltd. !! !! date:November 2017 !! !! FURTHER DETAILS !! !! jack dongarra, linpack, 3/11/78. !! modified 12/3/93, array(1) declarations changed to array(*) !! !!##SEE ALSO !! Online html documentation available at !! http://www.netlib.org/lapack/explore-html/ ! ===================================================================== subroutine sswap(n,sx,incx,sy,incy) implicit none ! ! -- Reference BLAS level1 routine (version 3.8.0) -- ! -- Reference BLAS is a software package provided by Univ. of Tennessee, -- ! -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- ! November 2017 ! ! .. Scalar Arguments .. integer,intent(in) :: incx,incy,n ! .. ! .. Array Arguments .. real,intent(inout) :: sx(*),sy(*) ! .. ! ! ===================================================================== ! ! .. Local Scalars .. real stemp integer i,ix,iy,m,mp1 ! .. ! .. Intrinsic Functions .. intrinsic mod ! .. if (n.le.0) return if (incx.eq.1 .and. incy.eq.1) then ! ! code for both increments equal to 1 ! ! ! clean-up loop ! m = mod(n,3) if (m.ne.0) then do i = 1,m stemp = sx(i) sx(i) = sy(i) sy(i) = stemp enddo if (n.lt.3) return endif mp1 = m + 1 do i = mp1,n,3 stemp = sx(i) sx(i) = sy(i) sy(i) = stemp stemp = sx(i+1) sx(i+1) = sy(i+1) sy(i+1) = stemp stemp = sx(i+2) sx(i+2) = sy(i+2) sy(i+2) = stemp enddo else ! ! code for unequal increments or equal increments not equal ! to 1 ! ix = 1 iy = 1 if (incx.lt.0) ix = (-n+1)*incx + 1 if (incy.lt.0) iy = (-n+1)*incy + 1 do i = 1,n stemp = sx(ix) sx(ix) = sy(iy) sy(iy) = stemp ix = ix + incx iy = iy + incy enddo endif end subroutine sswap !> !!##NAME !! ssymm(3f) - [BLAS:SINGLE_BLAS_LEVEL3] C:=alpha*A*B+beta*C, A symmetric, B, C rectangular. !! !!##SYNOPSIS !! !! subroutine ssymm(side,uplo,m,n,alpha,a,lda,b,ldb,beta,c,ldc) !! !! .. Scalar Arguments .. !! real,intent(in) :: alpha,beta !! integer,intent(in) :: lda,ldb,ldc,m,n !! character,intent(in) :: side,uplo !! .. !! .. Array Arguments .. !! real,intent(in) :: a(lda,*),b(ldb,*) !! real,intent(inout) :: c(ldc,*) !! .. !! !!##DEFINITION !! !! SSYMM 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. !! !!##OPTIONS !! !! SIDE !! !! SIDE is 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, !! !! UPLO !! !! UPLO is 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. !! !! M !! !! M is INTEGER !! On entry, M specifies the number of rows of the matrix C. !! M must be at least zero. !! !! N !! !! N is INTEGER !! On entry, N specifies the number of columns of the matrix C. !! N must be at least zero. !! !! ALPHA !! !! ALPHA is REAL !! On entry, ALPHA specifies the scalar alpha. !! !! A !! !! A is REAL array, 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. !! !! LDA !! !! LDA is 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 ). !! !! B !! !! B is REAL array, dimension ( LDB, N ) !! Before entry, the leading m by n part of the array B must !! contain the matrix B. !! !! LDB !! !! LDB is 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 ). !! !! BETA !! !! BETA is REAL !! On entry, BETA specifies the scalar beta. When BETA is !! supplied as zero then C need not be set on input. !! !! C !! !! C is REAL array, 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 !! !! LDC is 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 ). !! !!##AUTHORS !! !! + Univ. of Tennessee !! + Univ. of California Berkeley !! + Univ. of Colorado Denver !! + NAG Ltd. !! !! date:December 2016 !! !! FURTHER DETAILS !! !! 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. !! !!##SEE ALSO !! Online html documentation available at !! http://www.netlib.org/lapack/explore-html/ ! ===================================================================== subroutine ssymm(side,uplo,m,n,alpha,a,lda,b,ldb,beta,c,ldc) implicit none ! ! -- Reference BLAS level3 routine (version 3.7.0) -- ! -- Reference BLAS is a software package provided by Univ. of Tennessee, -- ! -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- ! December 2016 ! ! .. Scalar Arguments .. real,intent(in) :: alpha,beta integer,intent(in) :: lda,ldb,ldc,m,n character,intent(in) :: side,uplo ! .. ! .. Array Arguments .. real,intent(in) :: a(lda,*),b(ldb,*) real,intent(inout) :: c(ldc,*) ! .. ! ! ===================================================================== ! ! .. External Functions .. LOGICAL LSAME ! .. ! .. External Subroutines .. EXTERNAL XERBLA ! .. ! .. Intrinsic Functions .. intrinsic max ! .. ! .. Local Scalars .. real temp1,temp2 integer i,info,j,k,nrowa logical upper ! .. ! .. Parameters .. real,parameter :: one=1.0e+0,zero=0.0e+0 ! .. ! ! Set NROWA as the number of rows of A. ! if (lsame(side,'L')) then nrowa = m else nrowa = n endif upper = lsame(uplo,'U') ! ! Test the input parameters. ! info = 0 if ((.not.lsame(side,'L')) .and. (.not.lsame(side,'R'))) then info = 1 elseif ((.not.upper) .and. (.not.lsame(uplo,'L'))) then info = 2 elseif (m.lt.0) then info = 3 elseif (n.lt.0) then info = 4 elseif (lda.lt.max(1,nrowa)) then info = 7 elseif (ldb.lt.max(1,m)) then info = 9 elseif (ldc.lt.max(1,m)) then info = 12 endif if (info.ne.0) then call xerbla('SSYMM ',info) return endif ! ! Quick return if possible. ! if ((m.eq.0) .or. (n.eq.0) .or. ((alpha.eq.zero).and. (beta.eq.one))) return ! ! And when alpha.eq.zero. ! if (alpha.eq.zero) then if (beta.eq.zero) then c(1:m,1:n) = zero else c(1:m,1:n) = beta*c(1:m,1:n) endif return endif ! ! Start the operations. ! if (lsame(side,'L')) then ! ! Form C := alpha*A*B + beta*C. ! if (upper) then do j = 1,n do i = 1,m temp1 = alpha*b(i,j) temp2 = zero do k = 1,i - 1 c(k,j) = c(k,j) + temp1*a(k,i) temp2 = temp2 + b(k,j)*a(k,i) enddo if (beta.eq.zero) then c(i,j) = temp1*a(i,i) + alpha*temp2 else c(i,j) = beta*c(i,j) + temp1*a(i,i) + alpha*temp2 endif enddo enddo else do j = 1,n do i = m,1,-1 temp1 = alpha*b(i,j) temp2 = zero do k = i + 1,m c(k,j) = c(k,j) + temp1*a(k,i) temp2 = temp2 + b(k,j)*a(k,i) enddo if (beta.eq.zero) then c(i,j) = temp1*a(i,i) + alpha*temp2 else c(i,j) = beta*c(i,j) + temp1*a(i,i) + alpha*temp2 endif enddo enddo endif else ! ! Form C := alpha*B*A + beta*C. ! do j = 1,n temp1 = alpha*a(j,j) if (beta.eq.zero) then do i = 1,m c(i,j) = temp1*b(i,j) enddo else do i = 1,m c(i,j) = beta*c(i,j) + temp1*b(i,j) enddo endif do k = 1,j - 1 if (upper) then temp1 = alpha*a(k,j) else temp1 = alpha*a(j,k) endif do i = 1,m c(i,j) = c(i,j) + temp1*b(i,k) enddo enddo do k = j + 1,n if (upper) then temp1 = alpha*a(j,k) else temp1 = alpha*a(k,j) endif do i = 1,m c(i,j) = c(i,j) + temp1*b(i,k) enddo enddo enddo endif end subroutine ssymm !> !!##NAME !! ssymv(3f) - [BLAS:SINGLE_BLAS_LEVEL2] SY:=alpha*A*SX+beta*SY, A a symmetric matrix. !! !!##SYNOPSIS !! !! subroutine ssymv(uplo,n,alpha,a,lda,x,incx,beta,y,incy) !! !! .. Scalar Arguments .. !! real,intent(in) :: alpha,beta !! integer,intent(in) :: incx,incy,lda,n !! character,intent(in) :: uplo !! .. !! .. Array Arguments .. !! real,intent(in) :: a(lda,*),x(*) !! real,intent(inout) :: y(*) !! .. !! !!##DEFINITION !! !! SSYMV 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. !! !!##OPTIONS !! !! UPLO !! !! UPLO is 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. !! !! N !! !! N is INTEGER !! On entry, N specifies the order of the matrix A. !! N must be at least zero. !! !! ALPHA !! !! ALPHA is REAL !! On entry, ALPHA specifies the scalar alpha. !! !! A !! !! A is REAL array, 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. !! !! LDA !! !! LDA is 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 ). !! !! X !! !! X is REAL array, dimension at least !! ( 1 + ( n - 1 )*abs( INCX ) ). !! Before entry, the incremented array X must contain the n !! element vector x. !! !! INCX !! !! INCX is INTEGER !! On entry, INCX specifies the increment for the elements of !! X. INCX must not be zero. !! !! BETA !! !! BETA is REAL !! On entry, BETA specifies the scalar beta. When BETA is !! supplied as zero then Y need not be set on input. !! !! Y !! !! Y is REAL array, 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 !! !! INCY is INTEGER !! On entry, INCY specifies the increment for the elements of !! Y. INCY must not be zero. !! !!##AUTHORS !! !! + Univ. of Tennessee !! + Univ. of California Berkeley !! + Univ. of Colorado Denver !! + NAG Ltd. !! !! date:December 2016 !! !! FURTHER DETAILS !! !! Level 2 Blas routine. !! The vector and matrix arguments are not referenced when N = 0, or M = 0 !! !! -- 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. !! !!##SEE ALSO !! Online html documentation available at !! http://www.netlib.org/lapack/explore-html/ ! ===================================================================== subroutine ssymv(uplo,n,alpha,a,lda,x,incx,beta,y,incy) implicit none ! ! -- Reference BLAS level2 routine (version 3.7.0) -- ! -- Reference BLAS is a software package provided by Univ. of Tennessee, -- ! -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- ! December 2016 ! ! .. Scalar Arguments .. real,intent(in) :: alpha,beta integer,intent(in) :: incx,incy,lda,n character,intent(in) :: uplo ! .. ! .. Array Arguments .. real,intent(in) :: a(lda,*),x(*) real,intent(inout) :: y(*) ! .. ! ! ===================================================================== ! ! .. Parameters .. real one,zero parameter (one=1.0e+0,zero=0.0e+0) ! .. ! .. Local Scalars .. real temp1,temp2 integer i,info,ix,iy,j,jx,jy,kx,ky ! .. ! .. External Functions .. LOGICAL LSAME ! .. ! .. External Subroutines .. EXTERNAL XERBLA ! .. ! .. Intrinsic Functions .. intrinsic max ! .. ! ! Test the input parameters. ! info = 0 if (.not.lsame(uplo,'U') .and. .not.lsame(uplo,'L')) then info = 1 elseif (n.lt.0) then info = 2 elseif (lda.lt.max(1,n)) then info = 5 elseif (incx.eq.0) then info = 7 elseif (incy.eq.0) then info = 10 endif if (info.ne.0) then call xerbla('SSYMV ',info) return endif ! ! Quick return if possible. ! if ((n.eq.0) .or. ((alpha.eq.zero).and. (beta.eq.one))) return ! ! Set up the start points in X and Y. ! if (incx.gt.0) then kx = 1 else kx = 1 - (n-1)*incx endif if (incy.gt.0) then ky = 1 else ky = 1 - (n-1)*incy endif ! ! 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.ne.one) then if (incy.eq.1) then if (beta.eq.zero) then y(1:n) = zero else y(1:n) = beta*y(1:n) endif else iy = ky if (beta.eq.zero) then do i = 1,n y(iy) = zero iy = iy + incy enddo else do i = 1,n y(iy) = beta*y(iy) iy = iy + incy enddo endif endif endif if (alpha.eq.zero) return if (lsame(uplo,'U')) then ! ! Form y when A is stored in upper triangle. ! if ((incx.eq.1) .and. (incy.eq.1)) then do j = 1,n temp1 = alpha*x(j) temp2 = zero do i = 1,j - 1 y(i) = y(i) + temp1*a(i,j) temp2 = temp2 + a(i,j)*x(i) enddo y(j) = y(j) + temp1*a(j,j) + alpha*temp2 enddo else jx = kx jy = ky do j = 1,n temp1 = alpha*x(jx) temp2 = zero ix = kx iy = ky do i = 1,j - 1 y(iy) = y(iy) + temp1*a(i,j) temp2 = temp2 + a(i,j)*x(ix) ix = ix + incx iy = iy + incy enddo y(jy) = y(jy) + temp1*a(j,j) + alpha*temp2 jx = jx + incx jy = jy + incy enddo endif else ! ! Form y when A is stored in lower triangle. ! if ((incx.eq.1) .and. (incy.eq.1)) then do j = 1,n temp1 = alpha*x(j) temp2 = zero y(j) = y(j) + temp1*a(j,j) do i = j + 1,n y(i) = y(i) + temp1*a(i,j) temp2 = temp2 + a(i,j)*x(i) enddo y(j) = y(j) + alpha*temp2 enddo else jx = kx jy = ky do j = 1,n temp1 = alpha*x(jx) temp2 = zero y(jy) = y(jy) + temp1*a(j,j) ix = jx iy = jy do i = j + 1,n ix = ix + incx iy = iy + incy y(iy) = y(iy) + temp1*a(i,j) temp2 = temp2 + a(i,j)*x(ix) enddo y(jy) = y(jy) + alpha*temp2 jx = jx + incx jy = jy + incy enddo endif endif end subroutine ssymv !> !!##NAME !! ssyr2(3f) - [BLAS:SINGLE_BLAS_LEVEL2] A:=A+alpha*SX*TRANSPOSE(SY)+alpha*SY*TRANSPOSE(SX), A a symmetric !! !!##SYNOPSIS !! !! subroutine ssyr2(uplo,n,alpha,x,incx,y,incy,a,lda) !! !! .. Scalar Arguments .. !! real,intent(in) :: alpha !! integer,intent(in) :: incx,incy,lda,n !! character,intent(in) :: uplo !! .. !! .. Array Arguments .. !! real,intent(in) :: x(*),y(*) !! real,intent(inout) :: a(lda,*) !! .. !! !!##DEFINITION !! !! SSYR2 performs the symmetric rank 2 operation !! !! A := alpha*x*y**T + alpha*y*x**T + A, !! !! where alpha is a scalar, x and y are n element vectors and A is an n !! by n symmetric matrix. !! !!##OPTIONS !! !! UPLO !! !! UPLO is 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. !! !! N !! !! N is INTEGER !! On entry, N specifies the order of the matrix A. !! N must be at least zero. !! !! ALPHA !! !! ALPHA is REAL !! On entry, ALPHA specifies the scalar alpha. !! !! X !! !! X is REAL array, dimension at least !! ( 1 + ( n - 1 )*abs( INCX ) ). !! Before entry, the incremented array X must contain the n !! element vector x. !! !! INCX !! !! INCX is INTEGER !! On entry, INCX specifies the increment for the elements of !! X. INCX must not be zero. !! !! Y !! !! Y is REAL array, dimension at least !! ( 1 + ( n - 1 )*abs( INCY ) ). !! Before entry, the incremented array Y must contain the n !! element vector y. !! !! INCY !! !! INCY is INTEGER !! On entry, INCY specifies the increment for the elements of !! Y. INCY must not be zero. !! !! A !! !! A is REAL array, 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 !! !! LDA is 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 ). !! !!##AUTHORS !! !! + Univ. of Tennessee !! + Univ. of California Berkeley !! + Univ. of Colorado Denver !! + NAG Ltd. !! !! date:December 2016 !! !! FURTHER DETAILS !! !! 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. !! !!##SEE ALSO !! Online html documentation available at !! http://www.netlib.org/lapack/explore-html/ ! ===================================================================== subroutine ssyr2(uplo,n,alpha,x,incx,y,incy,a,lda) implicit none ! ! -- Reference BLAS level2 routine (version 3.7.0) -- ! -- Reference BLAS is a software package provided by Univ. of Tennessee, -- ! -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- ! December 2016 ! ! .. Scalar Arguments .. real,intent(in) :: alpha integer,intent(in) :: incx,incy,lda,n character,intent(in) :: uplo ! .. ! .. Array Arguments .. real,intent(in) :: x(*),y(*) real,intent(inout) :: a(lda,*) ! .. ! ! ===================================================================== ! ! .. Parameters .. real zero parameter (zero=0.0e+0) ! .. ! .. Local Scalars .. real temp1,temp2 integer i,info,ix,iy,j,jx,jy,kx,ky ! .. ! .. External Functions .. LOGICAL LSAME ! .. ! .. External Subroutines .. EXTERNAL XERBLA ! .. ! .. Intrinsic Functions .. intrinsic max ! .. ! ! Test the input parameters. ! info = 0 if (.not.lsame(uplo,'U') .and. .not.lsame(uplo,'L')) then info = 1 elseif (n.lt.0) then info = 2 elseif (incx.eq.0) then info = 5 elseif (incy.eq.0) then info = 7 elseif (lda.lt.max(1,n)) then info = 9 endif if (info.ne.0) then call xerbla('SSYR2 ',info) return endif ! ! Quick return if possible. ! if ((n.eq.0) .or. (alpha.eq.zero)) return ! ! Set up the start points in X and Y if the increments are not both ! unity. ! if ((incx.ne.1) .or. (incy.ne.1)) then if (incx.gt.0) then kx = 1 else kx = 1 - (n-1)*incx endif if (incy.gt.0) then ky = 1 else ky = 1 - (n-1)*incy endif jx = kx jy = ky endif ! ! 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')) then ! ! Form A when A is stored in the upper triangle. ! if ((incx.eq.1) .and. (incy.eq.1)) then do j = 1,n if ((x(j).ne.zero) .or. (y(j).ne.zero)) then temp1 = alpha*y(j) temp2 = alpha*x(j) do i = 1,j a(i,j) = a(i,j) + x(i)*temp1 + y(i)*temp2 enddo endif enddo else do j = 1,n if ((x(jx).ne.zero) .or. (y(jy).ne.zero)) then temp1 = alpha*y(jy) temp2 = alpha*x(jx) ix = kx iy = ky do i = 1,j a(i,j) = a(i,j) + x(ix)*temp1 + y(iy)*temp2 ix = ix + incx iy = iy + incy enddo endif jx = jx + incx jy = jy + incy enddo endif else ! ! Form A when A is stored in the lower triangle. ! if ((incx.eq.1) .and. (incy.eq.1)) then do j = 1,n if ((x(j).ne.zero) .or. (y(j).ne.zero)) then temp1 = alpha*y(j) temp2 = alpha*x(j) do i = j,n a(i,j) = a(i,j) + x(i)*temp1 + y(i)*temp2 enddo endif enddo else do j = 1,n if ((x(jx).ne.zero) .or. (y(jy).ne.zero)) then temp1 = alpha*y(jy) temp2 = alpha*x(jx) ix = jx iy = jy do i = j,n a(i,j) = a(i,j) + x(ix)*temp1 + y(iy)*temp2 ix = ix + incx iy = iy + incy enddo endif jx = jx + incx jy = jy + incy enddo endif endif end subroutine ssyr2 !> !!##NAME !! ssyr2k(3f) - [BLAS:SINGLE_BLAS_LEVEL3] C:=alpha*A*TRANSPOSE(B)+alpha*B*TRANSPOSE(A)+beta*C, C symmetric. !! !!##SYNOPSIS !! !! subroutine ssyr2k(uplo,trans,n,k,alpha,a,lda,b,ldb,beta,c,ldc) !! !! .. Scalar Arguments .. !! real,intent(in) :: alpha,beta !! integer,intent(in) :: k,lda,ldb,ldc,n !! character,intent(in) :: trans,uplo !! .. !! .. Array Arguments .. !! real,intent(in) :: a(lda,*),b(ldb,*) !! real,intent(inout) :: c(ldc,*) !! .. !! !!##DEFINITION !! !! SSYR2K performs one of the symmetric rank 2k operations !! !! C := alpha*A*B**T + alpha*B*A**T + beta*C, !! !! or !! !! C := alpha*A**T*B + alpha*B**T*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. !! !!##OPTIONS !! !! UPLO !! !! UPLO is 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. !! !! TRANS !! !! TRANS is CHARACTER*1 !! On entry, TRANS specifies the operation to be performed as !! follows: !! !! TRANS = 'N' or 'n' C := alpha*A*B**T + alpha*B*A**T + !! beta*C. !! !! TRANS = 'T' or 't' C := alpha*A**T*B + alpha*B**T*A + !! beta*C. !! !! TRANS = 'C' or 'c' C := alpha*A**T*B + alpha*B**T*A + !! beta*C. !! !! N !! !! N is INTEGER !! On entry, N specifies the order of the matrix C. N must be !! at least zero. !! !! K !! !! K is 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. !! !! ALPHA !! !! ALPHA is REAL !! On entry, ALPHA specifies the scalar alpha. !! !! A !! !! A is REAL array, 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. !! !! LDA !! !! LDA is 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 ). !! !! B !! !! B is REAL array, 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. !! !! LDB !! !! LDB is 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 ). !! !! BETA !! !! BETA is REAL !! On entry, BETA specifies the scalar beta. !! !! C !! !! C is REAL array, 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 !! !! LDC is 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 ). !! !!##AUTHORS !! !! + Univ. of Tennessee !! + Univ. of California Berkeley !! + Univ. of Colorado Denver !! + NAG Ltd. !! !! date:December 2016 !! !! FURTHER DETAILS !! !! 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. !! !!##SEE ALSO !! Online html documentation available at !! http://www.netlib.org/lapack/explore-html/ ! ===================================================================== subroutine ssyr2k(uplo,trans,n,k,alpha,a,lda,b,ldb,beta,c,ldc) implicit none ! ! -- Reference BLAS level3 routine (version 3.7.0) -- ! -- Reference BLAS is a software package provided by Univ. of Tennessee, -- ! -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- ! December 2016 ! ! .. Scalar Arguments .. real,intent(in) :: alpha,beta integer,intent(in) :: k,lda,ldb,ldc,n character,intent(in) :: trans,uplo ! .. ! .. Array Arguments .. real,intent(in) :: a(lda,*),b(ldb,*) real,intent(inout) :: c(ldc,*) ! .. ! ! ===================================================================== ! ! .. External Functions .. ! LOGICAL LSAME ! EXTERNAL LSAME ! .. ! .. External Subroutines .. ! EXTERNAL XERBLA ! .. ! .. Intrinsic Functions .. intrinsic max ! .. ! .. Local Scalars .. real temp1,temp2 integer i,info,j,l,nrowa logical upper ! .. ! .. Parameters .. real one,zero parameter (one=1.0e+0,zero=0.0e+0) ! .. ! ! Test the input parameters. ! if (lsame(trans,'N')) then nrowa = n else nrowa = k endif upper = lsame(uplo,'U') ! info = 0 if ((.not.upper) .and. (.not.lsame(uplo,'L'))) then info = 1 elseif ((.not.lsame(trans,'N')) .and. (.not.lsame(trans,'T')) .and. (.not.lsame(trans,'C'))) then info = 2 elseif (n.lt.0) then info = 3 elseif (k.lt.0) then info = 4 elseif (lda.lt.max(1,nrowa)) then info = 7 elseif (ldb.lt.max(1,nrowa)) then info = 9 elseif (ldc.lt.max(1,n)) then info = 12 endif if (info.ne.0) then call xerbla('SSYR2K',info) return endif ! ! Quick return if possible. ! if ((n.eq.0) .or. (((alpha.eq.zero).or. (k.eq.0)).and. (beta.eq.one))) return ! ! And when alpha.eq.zero. ! if (alpha.eq.zero) then if (upper) then if (beta.eq.zero) then do j = 1,n c(1:j,j) = zero enddo else do j = 1,n c(1:j,j) = beta*c(1:j,j) enddo endif else if (beta.eq.zero) then do j = 1,n c(j:n,j) = zero enddo else do j = 1,n c(j:n,j) = beta*c(j:n,j) enddo endif endif return endif ! ! Start the operations. ! if (lsame(trans,'N')) then ! ! Form C := alpha*A*B**T + alpha*B*A**T + C. ! if (upper) then do j = 1,n if (beta.eq.zero) then c(1:j,j) = zero elseif (beta.ne.one) then c(1:j,j) = beta*c(1:j,j) endif do l = 1,k if ((a(j,l).ne.zero) .or. (b(j,l).ne.zero)) then temp1 = alpha*b(j,l) temp2 = alpha*a(j,l) do i = 1,j c(i,j) = c(i,j) + a(i,l)*temp1 + b(i,l)*temp2 enddo endif enddo enddo else do j = 1,n if (beta.eq.zero) then c(j:n,j) = zero elseif (beta.ne.one) then c(j:n,j) = beta*c(j:n,j) endif do l = 1,k if ((a(j,l).ne.zero) .or. (b(j,l).ne.zero)) then temp1 = alpha*b(j,l) temp2 = alpha*a(j,l) c(j:n,j) = c(j:n,j) + a(j:n,l)*temp1 + b(j:n,l)*temp2 endif enddo enddo endif else ! ! Form C := alpha*A**T*B + alpha*B**T*A + C. ! if (upper) then do j = 1,n do i = 1,j temp1 = zero temp2 = zero do l = 1,k temp1 = temp1 + a(l,i)*b(l,j) temp2 = temp2 + b(l,i)*a(l,j) enddo if (beta.eq.zero) then c(i,j) = alpha*temp1 + alpha*temp2 else c(i,j) = beta*c(i,j) + alpha*temp1 + alpha*temp2 endif enddo enddo else do j = 1,n do i = j,n temp1 = zero temp2 = zero do l = 1,k temp1 = temp1 + a(l,i)*b(l,j) temp2 = temp2 + b(l,i)*a(l,j) enddo if (beta.eq.zero) then c(i,j) = alpha*temp1 + alpha*temp2 else c(i,j) = beta*c(i,j) + alpha*temp1 + alpha*temp2 endif enddo enddo endif endif end subroutine ssyr2k !> !!##NAME !! ssyr(3f) - [BLAS:SINGLE_BLAS_LEVEL2] A:=A+alpha*SX*TRANSPOSE(SX), A a symmetric matrix. !! !!##SYNOPSIS !! !! subroutine ssyr(uplo,n,alpha,x,incx,a,lda) !! !! .. Scalar Arguments .. !! real,intent(in) :: alpha !! integer,intent(in) :: incx,lda,n !! character,intent(in) :: uplo !! .. !! .. Array Arguments .. !! real,intent(in) :: x(*) !! real,intent(inout) :: a(lda,*) !! .. !! !!##DEFINITION !! !! SSYR performs the symmetric rank 1 operation !! !! A := alpha*x*x**T + A, !! !! where alpha is a real scalar, x is an n element vector and A is an !! n by n symmetric matrix. !! !!##OPTIONS !! !! UPLO !! !! UPLO is 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. !! !! N !! !! N is INTEGER !! On entry, N specifies the order of the matrix A. !! N must be at least zero. !! !! ALPHA !! !! ALPHA is REAL !! On entry, ALPHA specifies the scalar alpha. !! !! X !! !! X is REAL array, dimension at least !! ( 1 + ( n - 1 )*abs( INCX ) ). !! Before entry, the incremented array X must contain the n !! element vector x. !! !! INCX !! !! INCX is INTEGER !! On entry, INCX specifies the increment for the elements of !! X. INCX must not be zero. !! !! A !! !! A is REAL array, 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 !! !! LDA is 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 ). !! !!##AUTHORS !! !! + Univ. of Tennessee !! + Univ. of California Berkeley !! + Univ. of Colorado Denver !! + NAG Ltd. !! !! date:December 2016 !! !! FURTHER DETAILS !! !! 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. !! !!##SEE ALSO !! Online html documentation available at !! http://www.netlib.org/lapack/explore-html/ ! ===================================================================== subroutine ssyr(uplo,n,alpha,x,incx,a,lda) implicit none ! ! -- Reference BLAS level2 routine (version 3.7.0) -- ! -- Reference BLAS is a software package provided by Univ. of Tennessee, -- ! -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- ! December 2016 ! ! .. Scalar Arguments .. real,intent(in) :: alpha integer,intent(in) :: incx,lda,n character,intent(in) :: uplo ! .. ! .. Array Arguments .. real,intent(in) :: x(*) real,intent(inout) :: a(lda,*) ! .. ! ! ===================================================================== ! ! .. Parameters .. real zero parameter (zero=0.0e+0) ! .. ! .. Local Scalars .. real temp integer i,info,ix,j,jx,kx ! .. ! .. External Functions .. LOGICAL LSAME ! .. ! .. External Subroutines .. EXTERNAL XERBLA ! .. ! .. Intrinsic Functions .. intrinsic max ! .. ! ! Test the input parameters. ! info = 0 if (.not.lsame(uplo,'U') .and. .not.lsame(uplo,'L')) then info = 1 elseif (n.lt.0) then info = 2 elseif (incx.eq.0) then info = 5 elseif (lda.lt.max(1,n)) then info = 7 endif if (info.ne.0) then call xerbla('SSYR ',info) return endif ! ! Quick return if possible. ! if ((n.eq.0) .or. (alpha.eq.zero)) return ! ! Set the start point in X if the increment is not unity. ! if (incx.le.0) then kx = 1 - (n-1)*incx elseif (incx.ne.1) then kx = 1 endif ! ! 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')) then ! ! Form A when A is stored in upper triangle. ! if (incx.eq.1) then do j = 1,n if (x(j).ne.zero) then temp = alpha*x(j) a(1:j,j) = a(1:j,j) + x(1:j)*temp endif enddo else jx = kx do j = 1,n if (x(jx).ne.zero) then temp = alpha*x(jx) ix = kx do i = 1,j a(i,j) = a(i,j) + x(ix)*temp ix = ix + incx enddo endif jx = jx + incx enddo endif else ! ! Form A when A is stored in lower triangle. ! if (incx.eq.1) then do j = 1,n if (x(j).ne.zero) then temp = alpha*x(j) a(j:n,j) = a(j:n,j) + x(j:n)*temp endif enddo else jx = kx do j = 1,n if (x(jx).ne.zero) then temp = alpha*x(jx) ix = jx do i = j,n a(i,j) = a(i,j) + x(ix)*temp ix = ix + incx enddo endif jx = jx + incx enddo endif endif end subroutine ssyr !> !!##NAME !! ssyrk(3f) - [BLAS:SINGLE_BLAS_LEVEL3] C:=alpha*A*TRANSPOSE(A)+beta*C, C symmetric. !! !!##SYNOPSIS !! !! subroutine ssyrk(uplo,trans,n,k,alpha,a,lda,beta,c,ldc) !! !! .. Scalar Arguments .. !! real,intent(in) :: alpha,beta !! integer,intent(in) :: k,lda,ldc,n !! character,intent(in) :: trans,uplo !! .. !! .. Array Arguments .. !! real,intent(in) :: a(lda,*) !! real,intent(inout) :: c(ldc,*) !! .. !! !!##DEFINITION !! !! SSYRK performs one of the symmetric rank k operations !! !! C := alpha*A*A**T + beta*C, !! !! or !! !! C := alpha*A**T*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. !! !!##OPTIONS !! !! UPLO !! !! UPLO is 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. !! !! TRANS !! !! TRANS is CHARACTER*1 !! On entry, TRANS specifies the operation to be performed as !! follows: !! !! TRANS = 'N' or 'n' C := alpha*A*A**T + beta*C. !! !! TRANS = 'T' or 't' C := alpha*A**T*A + beta*C. !! !! TRANS = 'C' or 'c' C := alpha*A**T*A + beta*C. !! !! N !! !! N is INTEGER !! On entry, N specifies the order of the matrix C. N must be !! at least zero. !! !! K !! !! K is 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. !! !! ALPHA !! !! ALPHA is REAL !! On entry, ALPHA specifies the scalar alpha. !! !! A !! !! A is REAL array, 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. !! !! LDA !! !! LDA is 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 ). !! !! BETA !! !! BETA is REAL !! On entry, BETA specifies the scalar beta. !! !! C !! !! C is REAL array, 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 !! !! LDC is 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 ). !! !!##AUTHORS !! !! + Univ. of Tennessee !! + Univ. of California Berkeley !! + Univ. of Colorado Denver !! + NAG Ltd. !! !! date:December 2016 !! !! FURTHER DETAILS !! !! 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. !! !!##SEE ALSO !! Online html documentation available at !! http://www.netlib.org/lapack/explore-html/ ! ===================================================================== subroutine ssyrk(uplo,trans,n,k,alpha,a,lda,beta,c,ldc) implicit none ! ! -- Reference BLAS level3 routine (version 3.7.0) -- ! -- Reference BLAS is a software package provided by Univ. of Tennessee, -- ! -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- ! December 2016 ! ! .. Scalar Arguments .. real,intent(in) :: alpha,beta integer,intent(in) :: k,lda,ldc,n character,intent(in) :: trans,uplo ! .. ! .. Array Arguments .. real,intent(in) :: a(lda,*) real,intent(inout) :: c(ldc,*) ! .. ! ! ===================================================================== ! ! .. External Functions .. ! LOGICAL LSAME ! EXTERNAL LSAME ! .. ! .. External Subroutines .. ! EXTERNAL XERBLA ! .. ! .. Intrinsic Functions .. intrinsic max ! .. ! .. Local Scalars .. real temp integer i,info,j,l,nrowa logical upper ! .. ! .. Parameters .. real one,zero parameter (one=1.0e+0,zero=0.0e+0) ! .. ! ! Test the input parameters. ! if (lsame(trans,'N')) then nrowa = n else nrowa = k endif upper = lsame(uplo,'U') ! info = 0 if ((.not.upper) .and. (.not.lsame(uplo,'L'))) then info = 1 elseif ((.not.lsame(trans,'N')) .and. (.not.lsame(trans,'T')) .and. (.not.lsame(trans,'C'))) then info = 2 elseif (n.lt.0) then info = 3 elseif (k.lt.0) then info = 4 elseif (lda.lt.max(1,nrowa)) then info = 7 elseif (ldc.lt.max(1,n)) then info = 10 endif if (info.ne.0) then call xerbla('SSYRK ',info) return endif ! ! Quick return if possible. ! if ((n.eq.0) .or. (((alpha.eq.zero).or. (k.eq.0)).and. (beta.eq.one))) return ! ! And when alpha.eq.zero. ! if (alpha.eq.zero) then if (upper) then if (beta.eq.zero) then do j = 1,n c(1:j,j) = zero enddo else do j = 1,n c(1:j,j) = beta*c(1:j,j) enddo endif else if (beta.eq.zero) then do j = 1,n c(j:n,j) = zero enddo else do j = 1,n c(j:n,j) = beta*c(j:n,j) enddo endif endif return endif ! ! Start the operations. ! if (lsame(trans,'N')) then ! ! Form C := alpha*A*A**T + beta*C. ! if (upper) then do j = 1,n if (beta.eq.zero) then c(1:j,j) = zero elseif (beta.ne.one) then c(1:j,j) = beta*c(1:j,j) endif do l = 1,k if (a(j,l).ne.zero) then temp = alpha*a(j,l) c(1:j,j) = c(1:j,j) + temp*a(1:j,l) endif enddo enddo else do j = 1,n if (beta.eq.zero) then c(j:n,j) = zero elseif (beta.ne.one) then c(j:n,j) = beta*c(j:n,j) endif do l = 1,k if (a(j,l).ne.zero) then temp = alpha*a(j,l) do i = j,n c(i,j) = c(i,j) + temp*a(i,l) enddo endif enddo enddo endif else ! ! Form C := alpha*A**T*A + beta*C. ! if (upper) then do j = 1,n do i = 1,j temp = zero do l = 1,k temp = temp + a(l,i)*a(l,j) enddo if (beta.eq.zero) then c(i,j) = alpha*temp else c(i,j) = alpha*temp + beta*c(i,j) endif enddo enddo else do j = 1,n do i = j,n temp = zero do l = 1,k temp = temp + a(l,i)*a(l,j) enddo if (beta.eq.zero) then c(i,j) = alpha*temp else c(i,j) = alpha*temp + beta*c(i,j) endif enddo enddo endif endif end subroutine ssyrk !> !!##NAME !! stbmv(3f) - [BLAS:SINGLE_BLAS_LEVEL2] SX:=A*SX, A a triangular band matrix. !! !!##SYNOPSIS !! !! subroutine stbmv(uplo,trans,diag,n,k,a,lda,x,incx) !! !! .. Scalar Arguments .. !! integer,intent(in) :: incx,k,lda,n !! character,intent(in) :: diag,trans,uplo !! .. !! .. Array Arguments .. !! real,intent(in) :: a(lda,*) !! real,intent(inout) :: x(*) !! .. !! !!##DEFINITION !! !! STBMV performs one of the matrix-vector operations !! !! x := A*x, or x := A**T*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. !! !!##OPTIONS !! !! UPLO !! !! UPLO is 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. !! !! TRANS !! !! TRANS is 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**T*x. !! !! TRANS = 'C' or 'c' x := A**T*x. !! !! DIAG !! !! DIAG is 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. !! !! N !! !! N is INTEGER !! On entry, N specifies the order of the matrix A. !! N must be at least zero. !! !! K !! !! K is 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. !! !! A !! !! A is REAL array, 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. !! !! LDA !! !! LDA is INTEGER !! On entry, LDA specifies the first dimension of A as declared !! in the calling (sub) program. LDA must be at least !! ( k + 1 ). !! !! X !! !! X is REAL array, 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 !! transformed vector x. !! !! INCX !! !! INCX is INTEGER !! On entry, INCX specifies the increment for the elements of !! X. INCX must not be zero. !! !!##AUTHORS !! !! + Univ. of Tennessee !! + Univ. of California Berkeley !! + Univ. of Colorado Denver !! + NAG Ltd. !! !! date:December 2016 !! !! FURTHER DETAILS !! !! Level 2 Blas routine. !! The vector and matrix arguments are not referenced when N = 0, or M = 0 !! !! -- 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. !! !!##SEE ALSO !! Online html documentation available at !! http://www.netlib.org/lapack/explore-html/ ! ===================================================================== subroutine stbmv(uplo,trans,diag,n,k,a,lda,x,incx) implicit none ! ! -- Reference BLAS level2 routine (version 3.7.0) -- ! -- Reference BLAS is a software package provided by Univ. of Tennessee, -- ! -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- ! December 2016 ! ! .. Scalar Arguments .. integer,intent(in) :: incx,k,lda,n character,intent(in) :: diag,trans,uplo ! .. ! .. Array Arguments .. real,intent(in) :: a(lda,*) real,intent(inout) :: x(*) ! .. ! ! ===================================================================== ! ! .. Parameters .. real zero parameter (zero=0.0e+0) ! .. ! .. Local Scalars .. real temp integer i,info,ix,j,jx,kplus1,kx,l logical nounit ! .. ! .. External Functions .. ! LOGICAL LSAME ! EXTERNAL LSAME ! .. ! .. External Subroutines .. ! EXTERNAL XERBLA ! .. ! .. Intrinsic Functions .. intrinsic max,min ! .. ! ! Test the input parameters. ! info = 0 if (.not.lsame(uplo,'U') .and. .not.lsame(uplo,'L')) then info = 1 elseif (.not.lsame(trans,'N') .and. .not.lsame(trans,'T') .and. .not.lsame(trans,'C')) then info = 2 elseif (.not.lsame(diag,'U') .and. .not.lsame(diag,'N')) then info = 3 elseif (n.lt.0) then info = 4 elseif (k.lt.0) then info = 5 elseif (lda.lt. (k+1)) then info = 7 elseif (incx.eq.0) then info = 9 endif if (info.ne.0) then call xerbla('STBMV ',info) return endif ! ! Quick return if possible. ! if (n.eq.0) return ! nounit = lsame(diag,'N') ! ! Set up the start point in X if the increment is not unity. This ! will be ( N - 1 )*INCX too small for descending loops. ! if (incx.le.0) then kx = 1 - (n-1)*incx elseif (incx.ne.1) then kx = 1 endif ! ! Start the operations. In this version the elements of A are ! accessed sequentially with one pass through A. ! if (lsame(trans,'N')) then ! ! Form x := A*x. ! if (lsame(uplo,'U')) then kplus1 = k + 1 if (incx.eq.1) then do j = 1,n if (x(j).ne.zero) then temp = x(j) l = kplus1 - j do i = max(1,j-k),j - 1 x(i) = x(i) + temp*a(l+i,j) enddo if (nounit) x(j) = x(j)*a(kplus1,j) endif enddo else jx = kx do j = 1,n if (x(jx).ne.zero) then temp = x(jx) ix = kx l = kplus1 - j do i = max(1,j-k),j - 1 x(ix) = x(ix) + temp*a(l+i,j) ix = ix + incx enddo if (nounit) x(jx) = x(jx)*a(kplus1,j) endif jx = jx + incx if (j.gt.k) kx = kx + incx enddo endif else if (incx.eq.1) then do j = n,1,-1 if (x(j).ne.zero) then temp = x(j) l = 1 - j do i = min(n,j+k),j + 1,-1 x(i) = x(i) + temp*a(l+i,j) enddo if (nounit) x(j) = x(j)*a(1,j) endif enddo else kx = kx + (n-1)*incx jx = kx do j = n,1,-1 if (x(jx).ne.zero) then temp = x(jx) ix = kx l = 1 - j do i = min(n,j+k),j + 1,-1 x(ix) = x(ix) + temp*a(l+i,j) ix = ix - incx enddo if (nounit) x(jx) = x(jx)*a(1,j) endif jx = jx - incx if ((n-j).ge.k) kx = kx - incx enddo endif endif else ! ! Form x := A**T*x. ! if (lsame(uplo,'U')) then kplus1 = k + 1 if (incx.eq.1) then do j = n,1,-1 temp = x(j) l = kplus1 - j if (nounit) temp = temp*a(kplus1,j) do i = j - 1,max(1,j-k),-1 temp = temp + a(l+i,j)*x(i) enddo x(j) = temp enddo else kx = kx + (n-1)*incx jx = kx do j = n,1,-1 temp = x(jx) kx = kx - incx ix = kx l = kplus1 - j if (nounit) temp = temp*a(kplus1,j) do i = j - 1,max(1,j-k),-1 temp = temp + a(l+i,j)*x(ix) ix = ix - incx enddo x(jx) = temp jx = jx - incx enddo endif else if (incx.eq.1) then do j = 1,n temp = x(j) l = 1 - j if (nounit) temp = temp*a(1,j) do i = j + 1,min(n,j+k) temp = temp + a(l+i,j)*x(i) enddo x(j) = temp enddo else jx = kx do j = 1,n temp = x(jx) kx = kx + incx ix = kx l = 1 - j if (nounit) temp = temp*a(1,j) do i = j + 1,min(n,j+k) temp = temp + a(l+i,j)*x(ix) ix = ix + incx enddo x(jx) = temp jx = jx + incx enddo endif endif endif end subroutine stbmv !> !!##NAME !! stbsv(3f) - [BLAS:SINGLE_BLAS_LEVEL2] SX:=INVERSE(A)*SX, A a triangular band matrix. !! !!##SYNOPSIS !! !! subroutine stbsv(uplo,trans,diag,n,k,a,lda,x,incx) !! !! .. Scalar Arguments .. !! integer,intent(in) :: incx,k,lda,n !! character,intent(in) :: diag,trans,uplo !! .. !! .. Array Arguments .. !! real,intent(in) :: a(lda,*) !! real,intent(inout) :: x(*) !! .. !! !!##DEFINITION !! !! STBSV solves one of the systems of equations !! !! A*x = b, or A**T*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. !! !!##OPTIONS !! !! UPLO !! !! UPLO is 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. !! !! TRANS !! !! TRANS is 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**T*x = b. !! !! TRANS = 'C' or 'c' A**T*x = b. !! !! DIAG !! !! DIAG is 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. !! !! N !! !! N is INTEGER !! On entry, N specifies the order of the matrix A. !! N must be at least zero. !! !! K !! !! K is 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. !! !! A !! !! A is REAL array, 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. !! !! LDA !! !! LDA is INTEGER !! On entry, LDA specifies the first dimension of A as declared !! in the calling (sub) program. LDA must be at least !! ( k + 1 ). !! !! X !! !! X is REAL array, 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 !! !! INCX is INTEGER !! On entry, INCX specifies the increment for the elements of !! X. INCX must not be zero. !! !!##AUTHORS !! !! + Univ. of Tennessee !! + Univ. of California Berkeley !! + Univ. of Colorado Denver !! + NAG Ltd. !! !! date:December 2016 !! !! FURTHER DETAILS !! !! 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. !! !!##SEE ALSO !! Online html documentation available at !! http://www.netlib.org/lapack/explore-html/ ! ===================================================================== subroutine stbsv(uplo,trans,diag,n,k,a,lda,x,incx) implicit none ! ! -- Reference BLAS level2 routine (version 3.7.0) -- ! -- Reference BLAS is a software package provided by Univ. of Tennessee, -- ! -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- ! December 2016 ! ! .. Scalar Arguments .. integer,intent(in) :: incx,k,lda,n character,intent(in) :: diag,trans,uplo ! .. ! .. Array Arguments .. real,intent(in) :: a(lda,*) real,intent(inout) :: x(*) ! .. ! ! ===================================================================== ! ! .. Parameters .. real zero parameter (zero=0.0e+0) ! .. ! .. Local Scalars .. real temp integer i,info,ix,j,jx,kplus1,kx,l logical nounit ! .. ! .. External Functions .. ! LOGICAL LSAME ! EXTERNAL LSAME ! .. ! .. External Subroutines .. ! EXTERNAL XERBLA ! .. ! .. Intrinsic Functions .. intrinsic max,min ! .. ! ! Test the input parameters. ! info = 0 if (.not.lsame(uplo,'U') .and. .not.lsame(uplo,'L')) then info = 1 elseif (.not.lsame(trans,'N') .and. .not.lsame(trans,'T') .and. .not.lsame(trans,'C')) then info = 2 elseif (.not.lsame(diag,'U') .and. .not.lsame(diag,'N')) then info = 3 elseif (n.lt.0) then info = 4 elseif (k.lt.0) then info = 5 elseif (lda.lt. (k+1)) then info = 7 elseif (incx.eq.0) then info = 9 endif if (info.ne.0) then call xerbla('STBSV ',info) return endif ! ! Quick return if possible. ! if (n.eq.0) return ! nounit = lsame(diag,'N') ! ! Set up the start point in X if the increment is not unity. This ! will be ( N - 1 )*INCX too small for descending loops. ! if (incx.le.0) then kx = 1 - (n-1)*incx elseif (incx.ne.1) then kx = 1 endif ! ! Start the operations. In this version the elements of A are ! accessed by sequentially with one pass through A. ! if (lsame(trans,'N')) then ! ! Form x := inv( A )*x. ! if (lsame(uplo,'U')) then kplus1 = k + 1 if (incx.eq.1) then do j = n,1,-1 if (x(j).ne.zero) then l = kplus1 - j if (nounit) x(j) = x(j)/a(kplus1,j) temp = x(j) do i = j - 1,max(1,j-k),-1 x(i) = x(i) - temp*a(l+i,j) enddo endif enddo else kx = kx + (n-1)*incx jx = kx do j = n,1,-1 kx = kx - incx if (x(jx).ne.zero) then ix = kx l = kplus1 - j if (nounit) x(jx) = x(jx)/a(kplus1,j) temp = x(jx) do i = j - 1,max(1,j-k),-1 x(ix) = x(ix) - temp*a(l+i,j) ix = ix - incx enddo endif jx = jx - incx enddo endif else if (incx.eq.1) then do j = 1,n if (x(j).ne.zero) then l = 1 - j if (nounit) x(j) = x(j)/a(1,j) temp = x(j) do i = j + 1,min(n,j+k) x(i) = x(i) - temp*a(l+i,j) enddo endif enddo else jx = kx do j = 1,n kx = kx + incx if (x(jx).ne.zero) then ix = kx l = 1 - j if (nounit) x(jx) = x(jx)/a(1,j) temp = x(jx) do i = j + 1,min(n,j+k) x(ix) = x(ix) - temp*a(l+i,j) ix = ix + incx enddo endif jx = jx + incx enddo endif endif else ! ! Form x := inv( A**T)*x. ! if (lsame(uplo,'U')) then kplus1 = k + 1 if (incx.eq.1) then do j = 1,n temp = x(j) l = kplus1 - j do i = max(1,j-k),j - 1 temp = temp - a(l+i,j)*x(i) enddo if (nounit) temp = temp/a(kplus1,j) x(j) = temp enddo else jx = kx do j = 1,n temp = x(jx) ix = kx l = kplus1 - j do i = max(1,j-k),j - 1 temp = temp - a(l+i,j)*x(ix) ix = ix + incx enddo if (nounit) temp = temp/a(kplus1,j) x(jx) = temp jx = jx + incx if (j.gt.k) kx = kx + incx enddo endif else if (incx.eq.1) then do j = n,1,-1 temp = x(j) l = 1 - j do i = min(n,j+k),j + 1,-1 temp = temp - a(l+i,j)*x(i) enddo if (nounit) temp = temp/a(1,j) x(j) = temp enddo else kx = kx + (n-1)*incx jx = kx do j = n,1,-1 temp = x(jx) ix = kx l = 1 - j do i = min(n,j+k),j + 1,-1 temp = temp - a(l+i,j)*x(ix) ix = ix - incx enddo if (nounit) temp = temp/a(1,j) x(jx) = temp jx = jx - incx if ((n-j).ge.k) kx = kx - incx enddo endif endif endif end subroutine stbsv !> !!##NAME !! stpmv(3f) - [BLAS:SINGLE_BLAS_LEVEL2] SX:=A*SX, A a packed symmetric matrix. !! !!##SYNOPSIS !! !! subroutine stpmv(uplo,trans,diag,n,ap,x,incx) !! !! .. Scalar Arguments .. !! integer,intent(in) :: incx,n !! character,intent(in) :: diag,trans,uplo !! .. !! .. Array Arguments .. !! real,intent(in) :: ap(*) !! real,intent(inout) :: x(*) !! .. !! !!##DEFINITION !! !! STPMV performs one of the matrix-vector operations !! !! x := A*x, or x := A**T*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. !! !!##OPTIONS !! !! UPLO !! !! UPLO is 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. !! !! TRANS !! !! TRANS is 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**T*x. !! !! TRANS = 'C' or 'c' x := A**T*x. !! !! DIAG !! !! DIAG is 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. !! !! N !! !! N is INTEGER !! On entry, N specifies the order of the matrix A. !! N must be at least zero. !! !! AP !! !! AP is REAL array, 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. !! !! X !! !! X is REAL array, 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 !! transformed vector x. !! !! INCX !! !! INCX is INTEGER !! On entry, INCX specifies the increment for the elements of !! X. INCX must not be zero. !! !!##AUTHORS !! !! + Univ. of Tennessee !! + Univ. of California Berkeley !! + Univ. of Colorado Denver !! + NAG Ltd. !! !! date:December 2016 !! !! FURTHER DETAILS !! !! Level 2 Blas routine. !! The vector and matrix arguments are not referenced when N = 0, or M = 0 !! !! -- 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. !! !!##SEE ALSO !! Online html documentation available at !! http://www.netlib.org/lapack/explore-html/ ! ===================================================================== subroutine stpmv(uplo,trans,diag,n,ap,x,incx) implicit none ! ! -- Reference BLAS level2 routine (version 3.7.0) -- ! -- Reference BLAS is a software package provided by Univ. of Tennessee, -- ! -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- ! December 2016 ! ! .. Scalar Arguments .. integer,intent(in) :: incx,n character,intent(in) :: diag,trans,uplo ! .. ! .. Array Arguments .. real,intent(in) :: ap(*) real,intent(inout) :: x(*) ! .. ! ! ===================================================================== ! ! .. Parameters .. real,parameter :: zero=0.0e+0 ! .. ! .. Local Scalars .. real temp integer i,info,ix,j,jx,k,kk,kx logical nounit ! .. ! .. External Functions .. ! LOGICAL LSAME ! EXTERNAL LSAME ! .. ! .. External Subroutines .. ! EXTERNAL XERBLA ! .. ! ! Test the input parameters. ! info = 0 if (.not.lsame(uplo,'U') .and. .not.lsame(uplo,'L')) then info = 1 elseif (.not.lsame(trans,'N') .and. .not.lsame(trans,'T') .and. .not.lsame(trans,'C')) then info = 2 elseif (.not.lsame(diag,'U') .and. .not.lsame(diag,'N')) then info = 3 elseif (n.lt.0) then info = 4 elseif (incx.eq.0) then info = 7 endif if (info.ne.0) then call xerbla('STPMV ',info) return endif ! ! Quick return if possible. ! if (n.eq.0) return ! nounit = lsame(diag,'N') ! ! Set up the start point in X if the increment is not unity. This ! will be ( N - 1 )*INCX too small for descending loops. ! if (incx.le.0) then kx = 1 - (n-1)*incx elseif (incx.ne.1) then kx = 1 endif ! ! Start the operations. In this version the elements of AP are ! accessed sequentially with one pass through AP. ! if (lsame(trans,'N')) then ! ! Form x:= A*x. ! if (lsame(uplo,'U')) then kk = 1 if (incx.eq.1) then do j = 1,n if (x(j).ne.zero) then temp = x(j) k = kk do i = 1,j - 1 x(i) = x(i) + temp*ap(k) k = k + 1 enddo if (nounit) x(j) = x(j)*ap(kk+j-1) endif kk = kk + j enddo else jx = kx do j = 1,n if (x(jx).ne.zero) then temp = x(jx) ix = kx do k = kk,kk + j - 2 x(ix) = x(ix) + temp*ap(k) ix = ix + incx enddo if (nounit) x(jx) = x(jx)*ap(kk+j-1) endif jx = jx + incx kk = kk + j enddo endif else kk = (n* (n+1))/2 if (incx.eq.1) then do j = n,1,-1 if (x(j).ne.zero) then temp = x(j) k = kk do i = n,j + 1,-1 x(i) = x(i) + temp*ap(k) k = k - 1 enddo if (nounit) x(j) = x(j)*ap(kk-n+j) endif kk = kk - (n-j+1) enddo else kx = kx + (n-1)*incx jx = kx do j = n,1,-1 if (x(jx).ne.zero) then temp = x(jx) ix = kx do k = kk,kk - (n- (j+1)),-1 x(ix) = x(ix) + temp*ap(k) ix = ix - incx enddo if (nounit) x(jx) = x(jx)*ap(kk-n+j) endif jx = jx - incx kk = kk - (n-j+1) enddo endif endif else ! ! Form x := A**T*x. ! if (lsame(uplo,'U')) then kk = (n* (n+1))/2 if (incx.eq.1) then do j = n,1,-1 temp = x(j) if (nounit) temp = temp*ap(kk) k = kk - 1 do i = j - 1,1,-1 temp = temp + ap(k)*x(i) k = k - 1 enddo x(j) = temp kk = kk - j enddo else jx = kx + (n-1)*incx do j = n,1,-1 temp = x(jx) ix = jx if (nounit) temp = temp*ap(kk) do k = kk - 1,kk - j + 1,-1 ix = ix - incx temp = temp + ap(k)*x(ix) enddo x(jx) = temp jx = jx - incx kk = kk - j enddo endif else kk = 1 if (incx.eq.1) then do j = 1,n temp = x(j) if (nounit) temp = temp*ap(kk) k = kk + 1 do i = j + 1,n temp = temp + ap(k)*x(i) k = k + 1 enddo x(j) = temp kk = kk + (n-j+1) enddo else jx = kx do j = 1,n temp = x(jx) ix = jx if (nounit) temp = temp*ap(kk) do k = kk + 1,kk + n - j ix = ix + incx temp = temp + ap(k)*x(ix) enddo x(jx) = temp jx = jx + incx kk = kk + (n-j+1) enddo endif endif endif end subroutine stpmv !> !!##NAME !! stpsv(3f) - [BLAS:SINGLE_BLAS_LEVEL2] SX:=INVERSE(A)*SX, A a packed symmetric matrix. !! !!##SYNOPSIS !! !! subroutine stpsv(uplo,trans,diag,n,ap,x,incx) !! !! .. Scalar Arguments .. !! integer,intent(in) :: incx,n !! character,intent(in) :: diag,trans,uplo !! .. !! .. Array Arguments .. !! real,intent(in) :: ap(*) !! real,intent(inout) :: x(*) !! .. !! !!##DEFINITION !! !! STPSV solves one of the systems of equations !! !! A*x = b, or A**T*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. !! !!##OPTIONS !! !! UPLO !! !! UPLO is 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. !! !! TRANS !! !! TRANS is 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**T*x = b. !! !! TRANS = 'C' or 'c' A**T*x = b. !! !! DIAG !! !! DIAG is 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. !! !! N !! !! N is INTEGER !! On entry, N specifies the order of the matrix A. !! N must be at least zero. !! !! AP !! !! AP is REAL array, 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. !! !! X !! !! X is REAL array, 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 !! !! INCX is INTEGER !! On entry, INCX specifies the increment for the elements of !! X. INCX must not be zero. !! !!##AUTHORS !! !! + Univ. of Tennessee !! + Univ. of California Berkeley !! + Univ. of Colorado Denver !! + NAG Ltd. !! !! date:December 2016 !! !! FURTHER DETAILS !! !! 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. !! !!##SEE ALSO !! Online html documentation available at !! http://www.netlib.org/lapack/explore-html/ ! ===================================================================== subroutine stpsv(uplo,trans,diag,n,ap,x,incx) implicit none ! ! -- Reference BLAS level2 routine (version 3.7.0) -- ! -- Reference BLAS is a software package provided by Univ. of Tennessee, -- ! -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- ! December 2016 ! ! .. Scalar Arguments .. integer,intent(in) :: incx,n character,intent(in) :: diag,trans,uplo ! .. ! .. Array Arguments .. real,intent(in) :: ap(*) real,intent(inout) :: x(*) ! .. ! ! ===================================================================== ! ! .. Parameters .. real zero parameter (zero=0.0e+0) ! .. ! .. Local Scalars .. real temp integer i,info,ix,j,jx,k,kk,kx logical nounit ! .. ! .. External Functions .. ! LOGICAL LSAME ! EXTERNAL LSAME ! .. ! .. External Subroutines .. ! EXTERNAL XERBLA ! .. ! ! Test the input parameters. ! info = 0 if (.not.lsame(uplo,'U') .and. .not.lsame(uplo,'L')) then info = 1 elseif (.not.lsame(trans,'N') .and. .not.lsame(trans,'T') .and. .not.lsame(trans,'C')) then info = 2 elseif (.not.lsame(diag,'U') .and. .not.lsame(diag,'N')) then info = 3 elseif (n.lt.0) then info = 4 elseif (incx.eq.0) then info = 7 endif if (info.ne.0) then call xerbla('STPSV ',info) return endif ! ! Quick return if possible. ! if (n.eq.0) return ! nounit = lsame(diag,'N') ! ! Set up the start point in X if the increment is not unity. This ! will be ( N - 1 )*INCX too small for descending loops. ! if (incx.le.0) then kx = 1 - (n-1)*incx elseif (incx.ne.1) then kx = 1 endif ! ! Start the operations. In this version the elements of AP are ! accessed sequentially with one pass through AP. ! if (lsame(trans,'N')) then ! ! Form x := inv( A )*x. ! if (lsame(uplo,'U')) then kk = (n* (n+1))/2 if (incx.eq.1) then do j = n,1,-1 if (x(j).ne.zero) then if (nounit) x(j) = x(j)/ap(kk) temp = x(j) k = kk - 1 do i = j - 1,1,-1 x(i) = x(i) - temp*ap(k) k = k - 1 enddo endif kk = kk - j enddo else jx = kx + (n-1)*incx do j = n,1,-1 if (x(jx).ne.zero) then if (nounit) x(jx) = x(jx)/ap(kk) temp = x(jx) ix = jx do k = kk - 1,kk - j + 1,-1 ix = ix - incx x(ix) = x(ix) - temp*ap(k) enddo endif jx = jx - incx kk = kk - j enddo endif else kk = 1 if (incx.eq.1) then do j = 1,n if (x(j).ne.zero) then if (nounit) x(j) = x(j)/ap(kk) temp = x(j) k = kk + 1 do i = j + 1,n x(i) = x(i) - temp*ap(k) k = k + 1 enddo endif kk = kk + (n-j+1) enddo else jx = kx do j = 1,n if (x(jx).ne.zero) then if (nounit) x(jx) = x(jx)/ap(kk) temp = x(jx) ix = jx do k = kk + 1,kk + n - j ix = ix + incx x(ix) = x(ix) - temp*ap(k) enddo endif jx = jx + incx kk = kk + (n-j+1) enddo endif endif else ! ! Form x := inv( A**T )*x. ! if (lsame(uplo,'U')) then kk = 1 if (incx.eq.1) then do j = 1,n temp = x(j) k = kk do i = 1,j - 1 temp = temp - ap(k)*x(i) k = k + 1 enddo if (nounit) temp = temp/ap(kk+j-1) x(j) = temp kk = kk + j enddo else jx = kx do j = 1,n temp = x(jx) ix = kx do k = kk,kk + j - 2 temp = temp - ap(k)*x(ix) ix = ix + incx enddo if (nounit) temp = temp/ap(kk+j-1) x(jx) = temp jx = jx + incx kk = kk + j enddo endif else kk = (n* (n+1))/2 if (incx.eq.1) then do j = n,1,-1 temp = x(j) k = kk do i = n,j + 1,-1 temp = temp - ap(k)*x(i) k = k - 1 enddo if (nounit) temp = temp/ap(kk-n+j) x(j) = temp kk = kk - (n-j+1) enddo else kx = kx + (n-1)*incx jx = kx do j = n,1,-1 temp = x(jx) ix = kx do k = kk,kk - (n- (j+1)),-1 temp = temp - ap(k)*x(ix) ix = ix - incx enddo if (nounit) temp = temp/ap(kk-n+j) x(jx) = temp jx = jx - incx kk = kk - (n-j+1) enddo endif endif endif end subroutine stpsv !> !!##NAME !! strmm(3f) - [BLAS:SINGLE_BLAS_LEVEL3] B:=A*B or B:=B*A, A triangular, B rectangular. !! !!##SYNOPSIS !! !! subroutine strmm(side,uplo,transa,diag,m,n,alpha,a,lda,b,ldb) !! !! .. Scalar Arguments .. !! real,intent(in) :: alpha !! integer,intent(in) :: lda,ldb,m,n !! character,intent(in) :: diag,side,transa,uplo !! .. !! .. Array Arguments .. !! real,intent(in) :: a(lda,*) !! real,intent(inout) :: b(ldb,*) !! .. !! !!##DEFINITION !! !! STRMM 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**T. !! !!##OPTIONS !! !! SIDE !! !! SIDE is 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 ). !! !! UPLO !! !! UPLO is 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. !! !! TRANSA !! !! TRANSA is 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**T. !! !! TRANSA = 'C' or 'c' op( A ) = A**T. !! !! DIAG !! !! DIAG is 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. !! !! M !! !! M is INTEGER !! On entry, M specifies the number of rows of B. M must be at !! least zero. !! !! N !! !! N is INTEGER !! On entry, N specifies the number of columns of B. N must be !! at least zero. !! !! ALPHA !! !! ALPHA is 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. !! !! A !! !! A is REAL array, 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. !! !! LDA !! !! LDA is 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 ). !! !! B !! !! B is REAL array, 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 !! !! LDB is 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 ). !! !!##AUTHORS !! !! + Univ. of Tennessee !! + Univ. of California Berkeley !! + Univ. of Colorado Denver !! + NAG Ltd. !! !! date:December 2016 !! !! FURTHER DETAILS !! !! 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. !! !!##SEE ALSO !! Online html documentation available at !! http://www.netlib.org/lapack/explore-html/ ! ===================================================================== subroutine strmm(side,uplo,transa,diag,m,n,alpha,a,lda,b,ldb) implicit none ! ! -- Reference BLAS level3 routine (version 3.7.0) -- ! -- Reference BLAS is a software package provided by Univ. of Tennessee, -- ! -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- ! December 2016 ! ! .. Scalar Arguments .. real,intent(in) :: alpha integer,intent(in) :: lda,ldb,m,n character,intent(in) :: diag,side,transa,uplo ! .. ! .. Array Arguments .. real,intent(in) :: a(lda,*) real,intent(inout) :: b(ldb,*) ! .. ! ! ===================================================================== ! ! .. External Functions .. ! LOGICAL LSAME ! EXTERNAL LSAME ! .. ! .. External Subroutines .. ! EXTERNAL XERBLA ! .. ! .. Intrinsic Functions .. intrinsic max ! .. ! .. Local Scalars .. real temp integer i,info,j,k,nrowa logical lside,nounit,upper ! .. ! .. Parameters .. real one,zero parameter (one=1.0e+0,zero=0.0e+0) ! .. ! ! Test the input parameters. ! lside = lsame(side,'L') if (lside) then nrowa = m else nrowa = n endif nounit = lsame(diag,'N') upper = lsame(uplo,'U') ! info = 0 if ((.not.lside) .and. (.not.lsame(side,'R'))) then info = 1 elseif ((.not.upper) .and. (.not.lsame(uplo,'L'))) then info = 2 elseif ((.not.lsame(transa,'N')) .and. (.not.lsame(transa,'T')) .and. (.not.lsame(transa,'C'))) then info = 3 elseif ((.not.lsame(diag,'U')) .and. (.not.lsame(diag,'N'))) then info = 4 elseif (m.lt.0) then info = 5 elseif (n.lt.0) then info = 6 elseif (lda.lt.max(1,nrowa)) then info = 9 elseif (ldb.lt.max(1,m)) then info = 11 endif if (info.ne.0) then call xerbla('STRMM ',info) return endif ! ! Quick return if possible. ! if (m.eq.0 .or. n.eq.0) return ! ! And when alpha.eq.zero. ! if (alpha.eq.zero) then b(1:m,1:n) = zero return endif ! ! Start the operations. ! if (lside) then if (lsame(transa,'N')) then ! ! Form B := alpha*A*B. ! if (upper) then do j = 1,n do k = 1,m if (b(k,j).ne.zero) then temp = alpha*b(k,j) do i = 1,k - 1 b(i,j) = b(i,j) + temp*a(i,k) enddo if (nounit) temp = temp*a(k,k) b(k,j) = temp endif enddo enddo else do j = 1,n do k = m,1,-1 if (b(k,j).ne.zero) then temp = alpha*b(k,j) b(k,j) = temp if (nounit) b(k,j) = b(k,j)*a(k,k) do i = k + 1,m b(i,j) = b(i,j) + temp*a(i,k) enddo endif enddo enddo endif else ! ! Form B := alpha*A**T*B. ! if (upper) then do j = 1,n do i = m,1,-1 temp = b(i,j) if (nounit) temp = temp*a(i,i) do k = 1,i - 1 temp = temp + a(k,i)*b(k,j) enddo b(i,j) = alpha*temp enddo enddo else do j = 1,n do i = 1,m temp = b(i,j) if (nounit) temp = temp*a(i,i) do k = i + 1,m temp = temp + a(k,i)*b(k,j) enddo b(i,j) = alpha*temp enddo enddo endif endif else if (lsame(transa,'N')) then ! ! Form B := alpha*B*A. ! if (upper) then do j = n,1,-1 temp = alpha if (nounit) temp = temp*a(j,j) b(1:m,j) = temp*b(1:m,j) do k = 1,j - 1 if (a(k,j).ne.zero) then temp = alpha*a(k,j) b(1:m,j) = b(1:m,j) + temp*b(1:m,k) endif enddo enddo else do j = 1,n temp = alpha if (nounit) temp = temp*a(j,j) b(1:m,j) = temp*b(1:m,j) do k = j + 1,n if (a(k,j).ne.zero) then temp = alpha*a(k,j) b(1:m,j) = b(1:m,j) + temp*b(1:m,k) endif enddo enddo endif else ! ! Form B := alpha*B*A**T. ! if (upper) then do k = 1,n do j = 1,k - 1 if (a(j,k).ne.zero) then temp = alpha*a(j,k) b(1:m,j) = b(1:m,j) + temp*b(1:m,k) endif enddo temp = alpha if (nounit) temp = temp*a(k,k) if (temp.ne.one) then b(1:m,k) = temp*b(1:m,k) endif enddo else do k = n,1,-1 do j = k + 1,n if (a(j,k).ne.zero) then temp = alpha*a(j,k) b(1:m,j) = b(1:m,j) + temp*b(1:m,k) endif enddo temp = alpha if (nounit) temp = temp*a(k,k) if (temp.ne.one) then b(1:m,k) = temp*b(1:m,k) endif enddo endif endif endif end subroutine strmm !> !!##NAME !! strmv(3f) - [BLAS:SINGLE_BLAS_LEVEL2] SX:=A*SX, A a triangular matrix. !! !!##SYNOPSIS !! !! subroutine strmv(uplo,trans,diag,n,a,lda,x,incx) !! !! .. Scalar Arguments .. !! integer,intent(in) :: incx,lda,n !! character,intent(in) :: diag,trans,uplo !! .. !! .. Array Arguments .. !! real,intent(in) :: a(lda,*) !! real,intent(inout) :: x(*) !! .. !! !!##DEFINITION !! !! STRMV performs one of the matrix-vector operations !! !! x := A*x, or x := A**T*x, !! !! where x is an n element vector and A is an n by n unit, or non-unit, !! upper or lower triangular matrix. !! !!##OPTIONS !! !! UPLO !! !! UPLO is 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. !! !! TRANS !! !! TRANS is 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**T*x. !! !! TRANS = 'C' or 'c' x := A**T*x. !! !! DIAG !! !! DIAG is 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. !! !! N !! !! N is INTEGER !! On entry, N specifies the order of the matrix A. !! N must be at least zero. !! !! A !! !! A is REAL array, 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. !! !! LDA !! !! LDA is 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 ). !! !! X !! !! X is REAL array, 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 !! transformed vector x. !! !! INCX !! !! INCX is INTEGER !! On entry, INCX specifies the increment for the elements of !! X. INCX must not be zero. !! !!##AUTHORS !! !! + Univ. of Tennessee !! + Univ. of California Berkeley !! + Univ. of Colorado Denver !! + NAG Ltd. !! !! date:December 2016 !! !! FURTHER DETAILS !! !! Level 2 Blas routine. !! The vector and matrix arguments are not referenced when N = 0, or M = 0 !! !! -- 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. !! !!##SEE ALSO !! Online html documentation available at !! http://www.netlib.org/lapack/explore-html/ ! ===================================================================== subroutine strmv(uplo,trans,diag,n,a,lda,x,incx) implicit none ! ! -- Reference BLAS level2 routine (version 3.7.0) -- ! -- Reference BLAS is a software package provided by Univ. of Tennessee, -- ! -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- ! December 2016 ! ! .. Scalar Arguments .. integer,intent(in) :: incx,lda,n character,intent(in) :: diag,trans,uplo ! .. ! .. Array Arguments .. real,intent(in) :: a(lda,*) real,intent(inout) :: x(*) ! .. ! ! ===================================================================== ! ! .. Parameters .. real,parameter :: zero=0.0e+0 ! .. ! .. Local Scalars .. real temp integer i,info,ix,j,jx,kx logical nounit ! .. ! .. External Functions .. ! LOGICAL LSAME ! EXTERNAL LSAME ! .. ! .. External Subroutines .. ! EXTERNAL XERBLA ! .. ! .. Intrinsic Functions .. intrinsic max ! .. ! ! Test the input parameters. ! info = 0 if (.not.lsame(uplo,'U') .and. .not.lsame(uplo,'L')) then info = 1 elseif (.not.lsame(trans,'N') .and. .not.lsame(trans,'T') .and. .not.lsame(trans,'C')) then info = 2 elseif (.not.lsame(diag,'U') .and. .not.lsame(diag,'N')) then info = 3 elseif (n.lt.0) then info = 4 elseif (lda.lt.max(1,n)) then info = 6 elseif (incx.eq.0) then info = 8 endif if (info.ne.0) then call xerbla('STRMV ',info) return endif ! ! Quick return if possible. ! if (n.eq.0) return ! nounit = lsame(diag,'N') ! ! Set up the start point in X if the increment is not unity. This ! will be ( N - 1 )*INCX too small for descending loops. ! if (incx.le.0) then kx = 1 - (n-1)*incx elseif (incx.ne.1) then kx = 1 endif ! ! Start the operations. In this version the elements of A are ! accessed sequentially with one pass through A. ! if (lsame(trans,'N')) then ! ! Form x := A*x. ! if (lsame(uplo,'U')) then if (incx.eq.1) then do j = 1,n if (x(j).ne.zero) then temp = x(j) x(1:j-1) = x(1:j-1) + temp*a(1:j-1,j) if (nounit) x(j) = x(j)*a(j,j) endif enddo else jx = kx do j = 1,n if (x(jx).ne.zero) then temp = x(jx) ix = kx do i = 1,j - 1 x(ix) = x(ix) + temp*a(i,j) ix = ix + incx enddo if (nounit) x(jx) = x(jx)*a(j,j) endif jx = jx + incx enddo endif else if (incx.eq.1) then do j = n,1,-1 if (x(j).ne.zero) then temp = x(j) do i = n,j + 1,-1 x(i) = x(i) + temp*a(i,j) enddo if (nounit) x(j) = x(j)*a(j,j) endif enddo else kx = kx + (n-1)*incx jx = kx do j = n,1,-1 if (x(jx).ne.zero) then temp = x(jx) ix = kx do i = n,j + 1,-1 x(ix) = x(ix) + temp*a(i,j) ix = ix - incx enddo if (nounit) x(jx) = x(jx)*a(j,j) endif jx = jx - incx enddo endif endif else ! ! Form x := A**T*x. ! if (lsame(uplo,'U')) then if (incx.eq.1) then do j = n,1,-1 temp = x(j) if (nounit) temp = temp*a(j,j) do i = j - 1,1,-1 temp = temp + a(i,j)*x(i) enddo x(j) = temp enddo else jx = kx + (n-1)*incx do j = n,1,-1 temp = x(jx) ix = jx if (nounit) temp = temp*a(j,j) do i = j - 1,1,-1 ix = ix - incx temp = temp + a(i,j)*x(ix) enddo x(jx) = temp jx = jx - incx enddo endif else if (incx.eq.1) then do j = 1,n temp = x(j) if (nounit) temp = temp*a(j,j) do i = j + 1,n temp = temp + a(i,j)*x(i) enddo x(j) = temp enddo else jx = kx do j = 1,n temp = x(jx) ix = jx if (nounit) temp = temp*a(j,j) do i = j + 1,n ix = ix + incx temp = temp + a(i,j)*x(ix) enddo x(jx) = temp jx = jx + incx enddo endif endif endif end subroutine strmv !> !!##NAME !! strsm(3f) - [BLAS:SINGLE_BLAS_LEVEL3] B:=INVERSE(A)*C or B:=C*INVERSE(A), B, C rectangular, A triangular. !! !!##SYNOPSIS !! !! subroutine strsm(side,uplo,transa,diag,m,n,alpha,a,lda,b,ldb) !! !! .. Scalar Arguments .. !! real,intent(in) :: alpha !! integer,intent(in) :: lda,ldb,m,n !! character,intent(in) :: diag,side,transa,uplo !! .. !! .. Array Arguments .. !! real,intent(in) :: a(lda,*) !! real,intent(inout) :: b(ldb,*) !! .. !! !!##DEFINITION !! !! 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**T. !! !! The matrix X is overwritten on B. !! !!##OPTIONS !! !! SIDE !! !! SIDE is 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. !! !! UPLO !! !! UPLO is 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. !! !! TRANSA !! !! TRANSA is 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**T. !! !! TRANSA = 'C' or 'c' op( A ) = A**T. !! !! DIAG !! !! DIAG is 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. !! !! M !! !! M is INTEGER !! On entry, M specifies the number of rows of B. M must be at !! least zero. !! !! N !! !! N is INTEGER !! On entry, N specifies the number of columns of B. N must be !! at least zero. !! !! ALPHA !! !! ALPHA is 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. !! !! A !! !! A is REAL array, dimension ( LDA, k ), !! where k is m when SIDE = 'L' or 'l' !! and k 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. !! !! LDA !! !! LDA is 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 ). !! !! B !! !! B is REAL 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 !! !! LDB is 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 ). !! !!##AUTHORS !! !! + Univ. of Tennessee !! + Univ. of California Berkeley !! + Univ. of Colorado Denver !! + NAG Ltd. !! !! date:December 2016 !! !! FURTHER DETAILS !! !! 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. !! !!##SEE ALSO !! Online html documentation available at !! http://www.netlib.org/lapack/explore-html/ ! ===================================================================== subroutine strsm(side,uplo,transa,diag,m,n,alpha,a,lda,b,ldb) implicit none ! ! -- Reference BLAS level3 routine (version 3.7.0) -- ! -- Reference BLAS is a software package provided by Univ. of Tennessee, -- ! -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- ! December 2016 ! ! .. Scalar Arguments .. real,intent(in) :: alpha integer,intent(in) :: lda,ldb,m,n character,intent(in) :: diag,side,transa,uplo ! .. ! .. Array Arguments .. real,intent(in) :: a(lda,*) real,intent(inout) :: b(ldb,*) ! .. ! ! ===================================================================== ! ! .. External Functions .. ! LOGICAL LSAME ! EXTERNAL LSAME ! .. ! .. External Subroutines .. ! EXTERNAL XERBLA ! .. ! .. Intrinsic Functions .. intrinsic max ! .. ! .. Local Scalars .. real temp integer i,info,j,k,nrowa logical lside,nounit,upper ! .. ! .. Parameters .. real one,zero parameter (one=1.0e+0,zero=0.0e+0) ! .. ! ! Test the input parameters. ! lside = lsame(side,'L') if (lside) then nrowa = m else nrowa = n endif nounit = lsame(diag,'N') upper = lsame(uplo,'U') ! info = 0 if ((.not.lside) .and. (.not.lsame(side,'R'))) then info = 1 elseif ((.not.upper) .and. (.not.lsame(uplo,'L'))) then info = 2 elseif ((.not.lsame(transa,'N')) .and. (.not.lsame(transa,'T')) .and. (.not.lsame(transa,'C'))) then info = 3 elseif ((.not.lsame(diag,'U')) .and. (.not.lsame(diag,'N'))) then info = 4 elseif (m.lt.0) then info = 5 elseif (n.lt.0) then info = 6 elseif (lda.lt.max(1,nrowa)) then info = 9 elseif (ldb.lt.max(1,m)) then info = 11 endif if (info.ne.0) then call xerbla('STRSM ',info) return endif ! ! Quick return if possible. ! if (m.eq.0 .or. n.eq.0) return ! ! And when alpha.eq.zero. ! if (alpha.eq.zero) then do j = 1,n b(1:m,j) = zero enddo return endif ! ! Start the operations. ! if (lside) then if (lsame(transa,'N')) then ! ! Form B := alpha*inv( A )*B. ! if (upper) then do j = 1,n if (alpha.ne.one) then b(1:m,j) = alpha*b(1:m,j) endif do k = m,1,-1 if (b(k,j).ne.zero) then if (nounit) b(k,j) = b(k,j)/a(k,k) do i = 1,k - 1 b(i,j) = b(i,j) - b(k,j)*a(i,k) enddo endif enddo enddo else do j = 1,n if (alpha.ne.one) then b(1:m,j) = alpha*b(1:m,j) endif do k = 1,m if (b(k,j).ne.zero) then if (nounit) b(k,j) = b(k,j)/a(k,k) do i = k + 1,m b(i,j) = b(i,j) - b(k,j)*a(i,k) enddo endif enddo enddo endif else ! ! Form B := alpha*inv( A**T )*B. ! if (upper) then do j = 1,n do i = 1,m temp = alpha*b(i,j) do k = 1,i - 1 temp = temp - a(k,i)*b(k,j) enddo if (nounit) temp = temp/a(i,i) b(i,j) = temp enddo enddo else do j = 1,n do i = m,1,-1 temp = alpha*b(i,j) do k = i + 1,m temp = temp - a(k,i)*b(k,j) enddo if (nounit) temp = temp/a(i,i) b(i,j) = temp enddo enddo endif endif else if (lsame(transa,'N')) then ! ! Form B := alpha*B*inv( A ). ! if (upper) then do j = 1,n if (alpha.ne.one) then b(1:m,j) = alpha*b(1:m,j) endif do k = 1,j - 1 if (a(k,j).ne.zero) then b(1:m,j) = b(1:m,j) - a(k,j)*b(1:m,k) endif enddo if (nounit) then temp = one/a(j,j) b(1:m,j) = temp*b(1:m,j) endif enddo else do j = n,1,-1 if (alpha.ne.one) then b(1:m,j) = alpha*b(1:m,j) endif do k = j + 1,n if (a(k,j).ne.zero) then b(1:m,j) = b(1:m,j) - a(k,j)*b(1:m,k) endif enddo if (nounit) then temp = one/a(j,j) b(1:m,j) = temp*b(1:m,j) endif enddo endif else ! ! Form B := alpha*B*inv( A**T ). ! if (upper) then do k = n,1,-1 if (nounit) then temp = one/a(k,k) b(1:m,k) = temp*b(1:m,k) endif do j = 1,k - 1 if (a(j,k).ne.zero) then temp = a(j,k) b(1:m,j) = b(1:m,j) - temp*b(1:m,k) endif enddo if (alpha.ne.one) then b(1:m,k) = alpha*b(1:m,k) endif enddo else do k = 1,n if (nounit) then temp = one/a(k,k) b(1:m,k) = temp*b(1:m,k) endif do j = k + 1,n if (a(j,k).ne.zero) then temp = a(j,k) b(1:m,j) = b(1:m,j) - temp*b(1:m,k) endif enddo if (alpha.ne.one) then b(1:m,k) = alpha*b(1:m,k) endif enddo endif endif endif end subroutine strsm !> !!##NAME !! strsv(3f) - [BLAS:SINGLE_BLAS_LEVEL2] SX:=INVERSE(A)*SX, A a triangular matrix. !! !!##SYNOPSIS !! !! subroutine strsv(uplo,trans,diag,n,a,lda,x,incx) !! !! .. Scalar Arguments .. !! integer,intent(in) :: incx,lda,n !! character,intent(in) :: diag,trans,uplo !! .. !! .. Array Arguments .. !! real,intent(in) :: a(lda,*) !! real,intent(inout) :: x(*) !! .. !! !!##DEFINITION !! !! STRSV solves one of the systems of equations !! !! A*x = b, or A**T*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. !! !!##OPTIONS !! !! UPLO !! !! UPLO is 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. !! !! TRANS !! !! TRANS is 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**T*x = b. !! !! TRANS = 'C' or 'c' A**T*x = b. !! !! DIAG !! !! DIAG is 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. !! !! N !! !! N is INTEGER !! On entry, N specifies the order of the matrix A. !! N must be at least zero. !! !! A !! !! A is REAL array, 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. !! !! LDA !! !! LDA is 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 ). !! !! X !! !! X is REAL array, 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 !! !! INCX is INTEGER !! On entry, INCX specifies the increment for the elements of !! X. INCX must not be zero. !! !!##AUTHORS !! !! + Univ. of Tennessee !! + Univ. of California Berkeley !! + Univ. of Colorado Denver !! + NAG Ltd. !! !! date:December 2016 !! !! FURTHER DETAILS !! !! 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. !! !!##SEE ALSO !! Online html documentation available at !! http://www.netlib.org/lapack/explore-html/ ! ===================================================================== subroutine strsv(uplo,trans,diag,n,a,lda,x,incx) implicit none ! ! -- Reference BLAS level2 routine (version 3.7.0) -- ! -- Reference BLAS is a software package provided by Univ. of Tennessee, -- ! -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- ! December 2016 ! ! .. Scalar Arguments .. integer,intent(in) :: incx,lda,n character,intent(in) :: diag,trans,uplo ! .. ! .. Array Arguments .. real,intent(in) :: a(lda,*) real,intent(inout) :: x(*) ! .. ! ===================================================================== ! ! .. Parameters .. real zero parameter (zero=0.0e+0) ! .. ! .. Local Scalars .. real temp integer i,info,ix,j,jx,kx logical nounit ! .. ! .. External Functions .. ! LOGICAL LSAME ! EXTERNAL LSAME ! .. ! .. External Subroutines .. ! EXTERNAL XERBLA ! .. ! .. Intrinsic Functions .. intrinsic max ! .. ! ! Test the input parameters. ! info = 0 if (.not.lsame(uplo,'U') .and. .not.lsame(uplo,'L')) then info = 1 elseif (.not.lsame(trans,'N') .and. .not.lsame(trans,'T') .and. .not.lsame(trans,'C')) then info = 2 elseif (.not.lsame(diag,'U') .and. .not.lsame(diag,'N')) then info = 3 elseif (n.lt.0) then info = 4 elseif (lda.lt.max(1,n)) then info = 6 elseif (incx.eq.0) then info = 8 endif if (info.ne.0) then call xerbla('STRSV ',info) return endif ! ! Quick return if possible. ! if (n.eq.0) return ! nounit = lsame(diag,'N') ! ! Set up the start point in X if the increment is not unity. This ! will be ( N - 1 )*INCX too small for descending loops. ! if (incx.le.0) then kx = 1 - (n-1)*incx elseif (incx.ne.1) then kx = 1 endif ! ! Start the operations. In this version the elements of A are ! accessed sequentially with one pass through A. ! if (lsame(trans,'N')) then ! ! Form x := inv( A )*x. ! if (lsame(uplo,'U')) then if (incx.eq.1) then do j = n,1,-1 if (x(j).ne.zero) then if (nounit) x(j) = x(j)/a(j,j) temp = x(j) do i = j - 1,1,-1 x(i) = x(i) - temp*a(i,j) enddo endif enddo else jx = kx + (n-1)*incx do j = n,1,-1 if (x(jx).ne.zero) then if (nounit) x(jx) = x(jx)/a(j,j) temp = x(jx) ix = jx do i = j - 1,1,-1 ix = ix - incx x(ix) = x(ix) - temp*a(i,j) enddo endif jx = jx - incx enddo endif else if (incx.eq.1) then do j = 1,n if (x(j).ne.zero) then if (nounit) x(j) = x(j)/a(j,j) temp = x(j) do i = j + 1,n x(i) = x(i) - temp*a(i,j) enddo endif enddo else jx = kx do j = 1,n if (x(jx).ne.zero) then if (nounit) x(jx) = x(jx)/a(j,j) temp = x(jx) ix = jx do i = j + 1,n ix = ix + incx x(ix) = x(ix) - temp*a(i,j) enddo endif jx = jx + incx enddo endif endif else ! ! Form x := inv( A**T )*x. ! if (lsame(uplo,'U')) then if (incx.eq.1) then do j = 1,n temp = x(j) do i = 1,j - 1 temp = temp - a(i,j)*x(i) enddo if (nounit) temp = temp/a(j,j) x(j) = temp enddo else jx = kx do j = 1,n temp = x(jx) ix = kx do i = 1,j - 1 temp = temp - a(i,j)*x(ix) ix = ix + incx enddo if (nounit) temp = temp/a(j,j) x(jx) = temp jx = jx + incx enddo endif else if (incx.eq.1) then do j = n,1,-1 temp = x(j) do i = n,j + 1,-1 temp = temp - a(i,j)*x(i) enddo if (nounit) temp = temp/a(j,j) x(j) = temp enddo else kx = kx + (n-1)*incx jx = kx do j = n,1,-1 temp = x(jx) ix = kx do i = n,j + 1,-1 temp = temp - a(i,j)*x(ix) ix = ix - incx enddo if (nounit) temp = temp/a(j,j) x(jx) = temp jx = jx - incx enddo endif endif endif end subroutine strsv !> !!##NAME !! zaxpy(3f) - [BLAS:COMPLEX16_BLAS_LEVEL1] ZY := ZY+ZA*ZX !! complex constant times a complex vector plus a complex vector. !! !!##SYNOPSIS !! !! subroutine zaxpy(n,za,zx,incx,zy,incy) !! !! ! .. Scalar Arguments .. !! complex(kind=real64),intent(in) :: za !! integer,intent(in) :: incx,incy,n !! ! .. !! ! .. Array Arguments .. !! complex(kind=real64),intent(in) :: zx(*) !! complex(kind=real64),intent(inout) :: zy(*) !! ! .. !! !!##DEFINITION !! !! ZAXPY constant times a vector plus a vector. !! !! ZY := ZY+ZA*ZX !! !!##OPTIONS !! !! N number of elements in input vector(s) !! ZA On entry, ZA specifies the scalar alpha. !! ZX ZX is complex(kind=real64) array, dimension ( 1 + ( N - 1 )*abs( INCX ) ) !! INCX storage spacing between elements of ZX !! ZY ZY is complex(kind=real64) array, dimension ( 1 + ( N - 1 )*abs( INCY ) ) !! INCY storage spacing between elements of ZY !! !!##AUTHORS !! !! + Univ. of Tennessee !! + Univ. of California Berkeley !! + Univ. of Colorado Denver !! + NAG Ltd. !! !! date:November 2017 !! !! FURTHER DETAILS !! !! jack dongarra, 3/11/78. !! modified 12/3/93, array(1) declarations changed to array(*) !! !!##SEE ALSO !! Online html documentation available at !! http://www.netlib.org/lapack/explore-html/ ! ===================================================================== subroutine zaxpy(n,za,zx,incx,zy,incy) implicit none ! ! -- Reference BLAS level1 routine (version 3.8.0) -- ! -- Reference BLAS is a software package provided by Univ. of Tennessee, -- ! -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- ! November 2017 ! ! .. Scalar Arguments .. complex(kind=real64),intent(in) :: za integer,intent(in) :: incx,incy,n ! .. ! .. Array Arguments .. complex(kind=real64),intent(in) :: zx(*) complex(kind=real64),intent(inout) :: zy(*) ! .. ! ! ===================================================================== ! ! .. Local Scalars .. integer i,ix,iy ! .. ! .. External Functions .. ! double precision dcabs1 ! external dcabs1 ! .. if (n.le.0) return if (dcabs1(za).eq.0.0d0) return if (incx.eq.1 .and. incy.eq.1) then ! ! code for both increments equal to 1 ! do i = 1,n zy(i) = zy(i) + za*zx(i) enddo else ! ! code for unequal increments or equal increments ! not equal to 1 ! ix = 1 iy = 1 if (incx.lt.0) ix = (-n+1)*incx + 1 if (incy.lt.0) iy = (-n+1)*incy + 1 do i = 1,n zy(iy) = zy(iy) + za*zx(ix) ix = ix + incx iy = iy + incy enddo endif ! end subroutine zaxpy !> !!##NAME !! zcopy(3f) - [BLAS:COMPLEX16_BLAS_LEVEL1] !! !!##SYNOPSIS !! !! subroutine zcopy(n,zx,incx,zy,incy) !! !! .. Scalar Arguments .. !! integer,intent(in) :: incx,incy,n !! .. !! .. Array Arguments .. !! complex(kind=real64),intent(in) :: ZX(*) !! complex(kind=real64),intent(out) :: ZY(*) !! .. !! !!##DEFINITION !! !! ZCOPY copies a vector, x, to a vector, y. !! !!##OPTIONS !! !! N !! !! N is INTEGER !! number of elements in input vector(s) !! !! ZX !! !! ZX is complex(kind=real64) array, dimension ( 1 + ( N - 1 )*abs( INCX ) ) !! !! INCX !! !! INCX is INTEGER !! storage spacing between elements of ZX !! !! ZY !! !! ZY is complex(kind=real64) array, dimension ( 1 + ( N - 1 )*abs( INCY ) ) !! !! INCY !! !! INCY is INTEGER !! storage spacing between elements of ZY !! !!##AUTHORS !! !! + Univ. of Tennessee !! + Univ. of California Berkeley !! + Univ. of Colorado Denver !! + NAG Ltd. !! !! date:November 2017 !! !! FURTHER DETAILS !! !! jack dongarra, linpack, 4/11/78. !! modified 12/3/93, array(1) declarations changed to array(*) !! !!##SEE ALSO !! Online html documentation available at !! http://www.netlib.org/lapack/explore-html/ ! ===================================================================== subroutine zcopy(n,zx,incx,zy,incy) implicit none ! ! -- Reference BLAS level1 routine (version 3.8.0) -- ! -- Reference BLAS is a software package provided by Univ. of Tennessee, -- ! -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- ! November 2017 ! ! .. Scalar Arguments .. integer,intent(in) :: incx,incy,n ! .. ! .. Array Arguments .. complex(kind=real64),intent(in) :: zx(*) complex(kind=real64),intent(out) :: zy(*) ! .. ! ! ===================================================================== ! ! .. Local Scalars .. integer i,ix,iy ! .. if (n.le.0) return if (incx.eq.1 .and. incy.eq.1) then ! ! code for both increments equal to 1 ! do i = 1,n zy(i) = zx(i) enddo else ! ! code for unequal increments or equal increments ! not equal to 1 ! ix = 1 iy = 1 if (incx.lt.0) ix = (-n+1)*incx + 1 if (incy.lt.0) iy = (-n+1)*incy + 1 do i = 1,n zy(iy) = zx(ix) ix = ix + incx iy = iy + incy enddo endif end subroutine zcopy !> !!##NAME !! zdotc(3f) - [BLAS:COMPLEX16_BLAS_LEVEL1] !! !!##SYNOPSIS !! !! complex(kind=real64) function zdotc(n,zx,incx,zy,incy) !! !! .. Scalar Arguments .. !! integer,intent(in) :: incx,incy,n !! .. !! .. Array Arguments .. !! complex(kind=real64),intent(in) :: zx(*),zy(*) !! .. !! !!##DEFINITION !! !! ZDOTC forms the dot product of two complex vectors !! ZDOTC = X^H * Y !! !!##OPTIONS !! !! N !! !! N is INTEGER !! number of elements in input vector(s) !! !! ZX !! !! ZX is complex(kind=real64) array, dimension ( 1 + ( N - 1 )*abs( INCX ) ) !! !! INCX !! !! INCX is INTEGER !! storage spacing between elements of ZX !! !! ZY !! !! ZY is complex(kind=real64) array, dimension ( 1 + ( N - 1 )*abs( INCY ) ) !! !! INCY !! !! INCY is INTEGER !! storage spacing between elements of ZY !! !!##AUTHORS !! !! + Univ. of Tennessee !! + Univ. of California Berkeley !! + Univ. of Colorado Denver !! + NAG Ltd. !! !! date:November 2017 !! !! FURTHER DETAILS !! !! jack dongarra, 3/11/78. !! modified 12/3/93, array(1) declarations changed to array(*) !! !!##SEE ALSO !! Online html documentation available at !! http://www.netlib.org/lapack/explore-html/ ! ===================================================================== pure complex(kind=real64) function zdotc(n,zx,incx,zy,incy) implicit none ! ! -- Reference BLAS level1 routine (version 3.8.0) -- ! -- Reference BLAS is a software package provided by Univ. of Tennessee, -- ! -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- ! November 2017 ! ! .. Scalar Arguments .. integer,intent(in) :: incx,incy,n ! .. ! .. Array Arguments .. complex(kind=real64),intent(in) :: zx(*),zy(*) ! .. ! ! ===================================================================== ! ! .. Local Scalars .. complex(kind=real64) :: ztemp integer i,ix,iy ! .. ! .. Intrinsic Functions .. intrinsic dconjg ! .. ztemp = (0.0d0,0.0d0) zdotc = (0.0d0,0.0d0) if (n.le.0) return if (incx.eq.1 .and. incy.eq.1) then ! ! code for both increments equal to 1 ! do i = 1,n ztemp = ztemp + dconjg(zx(i))*zy(i) enddo else ! ! code for unequal increments or equal increments ! not equal to 1 ! ix = 1 iy = 1 if (incx.lt.0) ix = (-n+1)*incx + 1 if (incy.lt.0) iy = (-n+1)*incy + 1 do i = 1,n ztemp = ztemp + dconjg(zx(ix))*zy(iy) ix = ix + incx iy = iy + incy enddo endif zdotc = ztemp end function zdotc !> !!##NAME !! zdotu(3f) - [BLAS:COMPLEX16_BLAS_LEVEL1] !! !!##SYNOPSIS !! !! complex(kind=real64) function zdotu(n,zx,incx,zy,incy) !! !! .. Scalar Arguments .. !! integer,intent(in) :: incx,incy,n !! .. !! .. Array Arguments .. !! complex(kind=real64),intent(in) :: zx(*),zy(*) !! .. !! !!##DEFINITION !! !! ZDOTU forms the dot product of two complex vectors !! ZDOTU = X^T * Y !! !!##OPTIONS !! !! N !! !! N is INTEGER !! number of elements in input vector(s) !! !! ZX !! !! ZX is complex(kind=real64) array, dimension ( 1 + ( N - 1 )*abs( INCX ) ) !! !! INCX !! !! INCX is INTEGER !! storage spacing between elements of ZX !! !! ZY !! !! ZY is complex(kind=real64) array, dimension ( 1 + ( N - 1 )*abs( INCY ) ) !! !! INCY !! !! INCY is INTEGER !! storage spacing between elements of ZY !! !!##AUTHORS !! !! + Univ. of Tennessee !! + Univ. of California Berkeley !! + Univ. of Colorado Denver !! + NAG Ltd. !! !! date:November 2017 !! !! FURTHER DETAILS !! !! jack dongarra, 3/11/78. !! modified 12/3/93, array(1) declarations changed to array(*) !! !!##SEE ALSO !! Online html documentation available at !! http://www.netlib.org/lapack/explore-html/ ! ===================================================================== pure complex(kind=real64) function zdotu(n,zx,incx,zy,incy) implicit none ! ! -- Reference BLAS level1 routine (version 3.8.0) -- ! -- Reference BLAS is a software package provided by Univ. of Tennessee, -- ! -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- ! November 2017 ! ! .. Scalar Arguments .. integer,intent(in) :: incx,incy,n ! .. ! .. Array Arguments .. complex(kind=real64),intent(in) :: zx(*),zy(*) ! .. ! ! ===================================================================== ! ! .. Local Scalars .. complex(kind=real64) :: ztemp integer i,ix,iy ! .. ztemp = (0.0d0,0.0d0) zdotu = (0.0d0,0.0d0) if (n.le.0) return if (incx.eq.1 .and. incy.eq.1) then ! ! code for both increments equal to 1 ! do i = 1,n ztemp = ztemp + zx(i)*zy(i) enddo else ! ! code for unequal increments or equal increments ! not equal to 1 ! ix = 1 iy = 1 if (incx.lt.0) ix = (-n+1)*incx + 1 if (incy.lt.0) iy = (-n+1)*incy + 1 do i = 1,n ztemp = ztemp + zx(ix)*zy(iy) ix = ix + incx iy = iy + incy enddo endif zdotu = ztemp end function zdotu !> !!##NAME !! zdrot(3f) - [BLAS:COMPLEX16_BLAS_LEVEL1] !! !!##SYNOPSIS !! !! subroutine zdrot( n, zx, incx, zy, incy, c, s ) !! !! .. Scalar Arguments .. !! integer,intent(in) :: incx, incy, n !! double precision,intent(in) :: c, s !! .. !! .. Array Arguments .. !! complex(kind=real64),intent(inout) :: zx( * ), zy( * ) !! .. !! !!##DEFINITION !! !! Applies a plane rotation, where the cos and sin (c and s) are real !! and the vectors cx and cy are complex. !! jack dongarra, linpack, 3/11/78. !! !!##OPTIONS !! !! N !! !! N is INTEGER !! On entry, N specifies the order of the vectors cx and cy. !! N must be at least zero. !! !! ZX !! !! ZX is complex(kind=real64) array, dimension at least !! ( 1 + ( N - 1 )*abs( INCX ) ). !! Before entry, the incremented array ZX must contain the n !! element vector cx. On exit, ZX is overwritten by the updated !! vector cx. !! !! INCX !! !! INCX is INTEGER !! On entry, INCX specifies the increment for the elements of !! ZX. INCX must not be zero. !! !! ZY !! !! ZY is complex(kind=real64) array, dimension at least !! ( 1 + ( N - 1 )*abs( INCY ) ). !! Before entry, the incremented array ZY must contain the n !! element vector cy. On exit, ZY is overwritten by the updated !! vector cy. !! !! INCY !! !! INCY is INTEGER !! On entry, INCY specifies the increment for the elements of !! ZY. INCY must not be zero. !! !! C !! !! C is DOUBLE PRECISION !! On entry, C specifies the cosine, cos. !! !! S !! !! S is DOUBLE PRECISION !! On entry, S specifies the sine, sin. !! !!##AUTHORS !! !! + Univ. of Tennessee !! + Univ. of California Berkeley !! + Univ. of Colorado Denver !! + NAG Ltd. !! !! date:December 2016 !! !!##SEE ALSO !! Online html documentation available at !! http://www.netlib.org/lapack/explore-html/ ! ===================================================================== subroutine zdrot( n, zx, incx, zy, incy, c, s ) implicit none ! ! -- Reference BLAS level1 routine (version 3.7.0) -- ! -- Reference BLAS is a software package provided by Univ. of Tennessee, -- ! -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- ! December 2016 ! ! .. Scalar Arguments .. integer,intent(in) :: incx, incy, n double precision,intent(in) :: c, s ! .. ! .. Array Arguments .. complex(kind=real64),intent(inout) :: zx( * ), zy( * ) ! .. ! ! ===================================================================== ! ! .. Local Scalars .. integer i, ix, iy complex(kind=real64) :: ctemp ! .. ! .. Executable Statements .. ! if( n.le.0 ) return if( incx.eq.1 .and. incy.eq.1 ) then ! ! code for both increments equal to 1 ! do i = 1, n ctemp = c*zx( i ) + s*zy( i ) zy( i ) = c*zy( i ) - s*zx( i ) zx( i ) = ctemp enddo else ! ! code for unequal increments or equal increments not equal ! to 1 ! ix = 1 iy = 1 if( incx.lt.0 ) ix = ( -n+1 )*incx + 1 if( incy.lt.0 ) iy = ( -n+1 )*incy + 1 do i = 1, n ctemp = c*zx( ix ) + s*zy( iy ) zy( iy ) = c*zy( iy ) - s*zx( ix ) zx( ix ) = ctemp ix = ix + incx iy = iy + incy enddo endif end !> !!##NAME !! zdscal(3f) - [BLAS:COMPLEX16_BLAS_LEVEL1] !! !!##SYNOPSIS !! !! subroutine zdscal(n,da,zx,incx) !! !! .. Scalar Arguments .. !! double precision,intent(in) :: da !! integer,intent(in) :: incx,n !! .. !! .. Array Arguments .. !! complex(kind=real64),intent(inout) :: zx(*) !! .. !! !!##DEFINITION !! !! ZDSCAL scales a vector by a constant. !! !!##OPTIONS !! !! N !! !! N is INTEGER !! number of elements in input vector(s) !! !! DA !! !! DA is DOUBLE PRECISION !! On entry, DA specifies the scalar alpha. !! !! ZX !! !! ZX is complex(kind=real64) array, dimension ( 1 + ( N - 1 )*abs( INCX ) ) !! !! INCX !! !! INCX is INTEGER !! storage spacing between elements of ZX !! !!##AUTHORS !! !! + Univ. of Tennessee !! + Univ. of California Berkeley !! + Univ. of Colorado Denver !! + NAG Ltd. !! !! date:November 2017 !! !! FURTHER DETAILS !! !! jack dongarra, 3/11/78. !! modified 3/93 to return if incx .le. 0. !! modified 12/3/93, array(1) declarations changed to array(*) !! !!##SEE ALSO !! Online html documentation available at !! http://www.netlib.org/lapack/explore-html/ ! ===================================================================== subroutine zdscal(n,da,zx,incx) implicit none ! ! -- Reference BLAS level1 routine (version 3.8.0) -- ! -- Reference BLAS is a software package provided by Univ. of Tennessee, -- ! -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- ! November 2017 ! ! .. Scalar Arguments .. double precision,intent(in) :: da integer,intent(in) :: incx,n ! .. ! .. Array Arguments .. complex(kind=real64),intent(inout) :: zx(*) ! .. ! ! ===================================================================== ! ! .. Local Scalars .. integer i,nincx ! .. ! .. Intrinsic Functions .. intrinsic dcmplx ! .. if (n.le.0 .or. incx.le.0) return if (incx.eq.1) then ! ! code for increment equal to 1 ! do i = 1,n zx(i) = dcmplx(da,0.0d0)*zx(i) enddo else ! ! code for increment not equal to 1 ! nincx = n*incx do i = 1,nincx,incx zx(i) = dcmplx(da,0.0d0)*zx(i) enddo endif end subroutine zdscal !> !!##NAME !! zgbmv(3f) - [BLAS:COMPLEX_16_BLAS_LEVEL2] !! !!##SYNOPSIS !! !! subroutine zgbmv(trans,m,n,kl,ku,alpha,a,lda,x,incx,beta,y,incy) !! !! .. Scalar Arguments .. !! complex(kind=real64),intent(in) :: alpha,beta !! integer,intent(in) :: incx,incy,kl,ku,lda,m,n !! character,intent(in) :: trans !! .. !! .. Array Arguments .. !! complex(kind=real64),intent(in) :: a(lda,*),x(*) !! complex(kind=real64),intent(inout) :: y(*) !! .. !! !!##DEFINITION !! !! ZGBMV performs one of the matrix-vector operations !! !! y := alpha*A*x + beta*y, or y := alpha*A**T*x + beta*y, or !! !! y := alpha*A**H*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. !! !!##OPTIONS !! !! TRANS !! !! TRANS is 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**T*x + beta*y. !! !! TRANS = 'C' or 'c' y := alpha*A**H*x + beta*y. !! !! M !! !! M is INTEGER !! On entry, M specifies the number of rows of the matrix A. !! M must be at least zero. !! !! N !! !! N is INTEGER !! On entry, N specifies the number of columns of the matrix A. !! N must be at least zero. !! !! KL !! !! KL is INTEGER !! On entry, KL specifies the number of sub-diagonals of the !! matrix A. KL must satisfy 0 .le. KL. !! !! KU !! !! KU is INTEGER !! On entry, KU specifies the number of super-diagonals of the !! matrix A. KU must satisfy 0 .le. KU. !! !! ALPHA !! !! ALPHA is complex(kind=real64) !! On entry, ALPHA specifies the scalar alpha. !! !! A !! !! A is complex(kind=real64) array, 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 !! !! LDA !! !! LDA is 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 ). !! !! X !! !! X is complex(kind=real64) array, 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. !! !! INCX !! !! INCX is INTEGER !! On entry, INCX specifies the increment for the elements of !! X. INCX must not be zero. !! !! BETA !! !! BETA is complex(kind=real64) !! On entry, BETA specifies the scalar beta. When BETA is !! supplied as zero then Y need not be set on input. !! !! Y !! !! Y is complex(kind=real64) array, 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 !! !! INCY is INTEGER !! On entry, INCY specifies the increment for the elements of !! Y. INCY must not be zero. !! !!##AUTHORS !! !! + Univ. of Tennessee !! + Univ. of California Berkeley !! + Univ. of Colorado Denver !! + NAG Ltd. !! !! date:December 2016 !! !! FURTHER DETAILS !! !! Level 2 Blas routine. !! The vector and matrix arguments are not referenced when N = 0, or M = 0 !! !! -- 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. !! !!##SEE ALSO !! Online html documentation available at !! http://www.netlib.org/lapack/explore-html/ ! ===================================================================== subroutine zgbmv(trans,m,n,kl,ku,alpha,a,lda,x,incx,beta,y,incy) implicit none ! ! -- Reference BLAS level2 routine (version 3.7.0) -- ! -- Reference BLAS is a software package provided by Univ. of Tennessee, -- ! -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- ! December 2016 ! ! .. Scalar Arguments .. complex(kind=real64),intent(in) :: alpha,beta integer,intent(in) :: incx,incy,kl,ku,lda,m,n character,intent(in) :: trans ! .. ! .. Array Arguments .. complex(kind=real64),intent(in) :: a(lda,*),x(*) complex(kind=real64),intent(inout) :: y(*) ! .. ! ! ===================================================================== ! ! .. Parameters .. complex(kind=real64) :: one parameter (one= (1.0d+0,0.0d+0)) complex(kind=real64) :: zero parameter (zero= (0.0d+0,0.0d+0)) ! .. ! .. Local Scalars .. complex(kind=real64) :: temp integer i,info,ix,iy,j,jx,jy,k,kup1,kx,ky,lenx,leny logical noconj ! .. ! .. External Functions .. ! LOGICAL LSAME ! EXTERNAL LSAME ! .. ! .. External Subroutines .. ! EXTERNAL XERBLA ! .. ! .. Intrinsic Functions .. intrinsic dconjg,max,min ! .. ! ! Test the input parameters. ! info = 0 if (.not.lsame(trans,'N') .and. .not.lsame(trans,'T') .and. .not.lsame(trans,'C')) then info = 1 elseif (m.lt.0) then info = 2 elseif (n.lt.0) then info = 3 elseif (kl.lt.0) then info = 4 elseif (ku.lt.0) then info = 5 elseif (lda.lt. (kl+ku+1)) then info = 8 elseif (incx.eq.0) then info = 10 elseif (incy.eq.0) then info = 13 endif if (info.ne.0) then call xerbla('ZGBMV ',info) return endif ! ! Quick return if possible. ! if ((m.eq.0) .or. (n.eq.0) .or. ((alpha.eq.zero).and. (beta.eq.one))) return ! noconj = lsame(trans,'T') ! ! Set LENX and LENY, the lengths of the vectors x and y, and set ! up the start points in X and Y. ! if (lsame(trans,'N')) then lenx = n leny = m else lenx = m leny = n endif if (incx.gt.0) then kx = 1 else kx = 1 - (lenx-1)*incx endif if (incy.gt.0) then ky = 1 else ky = 1 - (leny-1)*incy endif ! ! 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.ne.one) then if (incy.eq.1) then if (beta.eq.zero) then y(1:leny) = zero else y(1:leny) = beta*y(1:leny) endif else iy = ky if (beta.eq.zero) then do i = 1,leny y(iy) = zero iy = iy + incy enddo else do i = 1,leny y(iy) = beta*y(iy) iy = iy + incy enddo endif endif endif if (alpha.eq.zero) return kup1 = ku + 1 if (lsame(trans,'N')) then ! ! Form y := alpha*A*x + y. ! jx = kx if (incy.eq.1) then do j = 1,n temp = alpha*x(jx) k = kup1 - j do i = max(1,j-ku),min(m,j+kl) y(i) = y(i) + temp*a(k+i,j) enddo jx = jx + incx enddo else do j = 1,n temp = alpha*x(jx) iy = ky k = kup1 - j do i = max(1,j-ku),min(m,j+kl) y(iy) = y(iy) + temp*a(k+i,j) iy = iy + incy enddo jx = jx + incx if (j.gt.ku) ky = ky + incy enddo endif else ! ! Form y := alpha*A**T*x + y or y := alpha*A**H*x + y. ! jy = ky if (incx.eq.1) then do j = 1,n temp = zero k = kup1 - j if (noconj) then do i = max(1,j-ku),min(m,j+kl) temp = temp + a(k+i,j)*x(i) enddo else do i = max(1,j-ku),min(m,j+kl) temp = temp + dconjg(a(k+i,j))*x(i) enddo endif y(jy) = y(jy) + alpha*temp jy = jy + incy enddo else do j = 1,n temp = zero ix = kx k = kup1 - j if (noconj) then do i = max(1,j-ku),min(m,j+kl) temp = temp + a(k+i,j)*x(ix) ix = ix + incx enddo else do i = max(1,j-ku),min(m,j+kl) temp = temp + dconjg(a(k+i,j))*x(ix) ix = ix + incx enddo endif y(jy) = y(jy) + alpha*temp jy = jy + incy if (j.gt.ku) kx = kx + incx enddo endif endif ! end subroutine zgbmv !> !!##NAME !! zgemm(3f) - [BLAS:COMPLEX16_BLAS_LEVEL3] !! !!##SYNOPSIS !! !! subroutine zgemm(transa,transb,m,n,k,alpha,a,lda,b,ldb,beta,c,ldc) !! !! .. Scalar Arguments .. !! complex(kind=real64),intent(in) :: alpha,beta !! integer,intent(in) :: k,lda,ldb,ldc,m,n !! character,intent(in) :: transa,transb !! .. !! .. Array Arguments .. !! complex(kind=real64),intent(in) :: a(lda,*),b(ldb,*) !! complex(kind=real64),intent(inout) :: c(ldc,*) !! .. !! !!##DEFINITION !! !! ZGEMM 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**T or op( X ) = X**H, !! !! 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. !! !!##OPTIONS !! !! TRANSA !! !! TRANSA is 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**T. !! !! TRANSA = 'C' or 'c', op( A ) = A**H. !! !! TRANSB !! !! TRANSB is 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**T. !! !! TRANSB = 'C' or 'c', op( B ) = B**H. !! !! M !! !! M is 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. !! !! N !! !! N is 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. !! !! K !! !! K is 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. !! !! ALPHA !! !! ALPHA is complex(kind=real64) !! On entry, ALPHA specifies the scalar alpha. !! !! A !! !! A is complex(kind=real64) array, 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. !! !! LDA !! !! LDA is 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 ). !! !! B !! !! B is complex(kind=real64) array, 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. !! !! LDB !! !! LDB is 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 ). !! !! BETA !! !! BETA is complex(kind=real64) !! On entry, BETA specifies the scalar beta. When BETA is !! supplied as zero then C need not be set on input. !! !! C !! !! C is complex(kind=real64) array, 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 !! !! LDC is 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 ). !! !!##AUTHORS !! !! + Univ. of Tennessee !! + Univ. of California Berkeley !! + Univ. of Colorado Denver !! + NAG Ltd. !! !! date:December 2016 !! !! FURTHER DETAILS !! !! 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. !! !!##SEE ALSO !! Online html documentation available at !! http://www.netlib.org/lapack/explore-html/ ! ===================================================================== subroutine zgemm(transa,transb,m,n,k,alpha,a,lda,b,ldb,beta,c,ldc) implicit none ! ! -- Reference BLAS level3 routine (version 3.7.0) -- ! -- Reference BLAS is a software package provided by Univ. of Tennessee, -- ! -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- ! December 2016 ! ! .. Scalar Arguments .. complex(kind=real64),intent(in) :: alpha,beta integer,intent(in) :: k,lda,ldb,ldc,m,n character,intent(in) :: transa,transb ! .. ! .. Array Arguments .. complex(kind=real64),intent(in) :: a(lda,*),b(ldb,*) complex(kind=real64),intent(inout) :: c(ldc,*) ! .. ! ! ===================================================================== ! ! .. External Functions .. ! LOGICAL LSAME ! EXTERNAL LSAME ! .. ! .. External Subroutines .. ! EXTERNAL XERBLA ! .. ! .. Intrinsic Functions .. intrinsic dconjg,max ! .. ! .. Local Scalars .. complex(kind=real64) :: temp integer i,info,j,l,nrowa,nrowb logical conja,conjb,nota,notb ! .. ! .. Parameters .. complex(kind=real64) :: one parameter (one= (1.0d+0,0.0d+0)) complex(kind=real64) :: zero parameter (zero= (0.0d+0,0.0d+0)) ! .. ! ! Set NOTA and NOTB as true if A and B respectively are not ! conjugated or transposed, set CONJA and CONJB as true if A and ! B respectively are to be transposed but not conjugated and set ! NROWA and NROWB as the number of rows of A and B respectively. ! nota = lsame(transa,'N') notb = lsame(transb,'N') conja = lsame(transa,'C') conjb = lsame(transb,'C') if (nota) then nrowa = m else nrowa = k endif if (notb) then nrowb = k else nrowb = n endif ! ! Test the input parameters. ! info = 0 if ((.not.nota) .and. (.not.conja) .and. (.not.lsame(transa,'T'))) then info = 1 elseif ((.not.notb) .and. (.not.conjb) .and. (.not.lsame(transb,'T'))) then info = 2 elseif (m.lt.0) then info = 3 elseif (n.lt.0) then info = 4 elseif (k.lt.0) then info = 5 elseif (lda.lt.max(1,nrowa)) then info = 8 elseif (ldb.lt.max(1,nrowb)) then info = 10 elseif (ldc.lt.max(1,m)) then info = 13 endif if (info.ne.0) then call xerbla('ZGEMM ',info) return endif ! ! Quick return if possible. ! if ((m.eq.0) .or. (n.eq.0) .or. (((alpha.eq.zero).or. (k.eq.0)).and. (beta.eq.one))) return ! ! And when alpha.eq.zero. ! if (alpha.eq.zero) then if (beta.eq.zero) then do j = 1,n c(1:m,j) = zero enddo else do j = 1,n c(1:m,j) = beta*c(1:m,j) enddo endif return endif ! ! Start the operations. ! if (notb) then if (nota) then ! ! Form C := alpha*A*B + beta*C. ! do j = 1,n if (beta.eq.zero) then c(1:m,j) = zero elseif (beta.ne.one) then c(1:m,j) = beta*c(1:m,j) endif do l = 1,k temp = alpha*b(l,j) c(1:m,j) = c(1:m,j) + temp*a(1:m,l) enddo enddo elseif (conja) then ! ! Form C := alpha*A**H*B + beta*C. ! do j = 1,n do i = 1,m temp = zero do l = 1,k temp = temp + dconjg(a(l,i))*b(l,j) enddo if (beta.eq.zero) then c(i,j) = alpha*temp else c(i,j) = alpha*temp + beta*c(i,j) endif enddo enddo else ! ! Form C := alpha*A**T*B + beta*C ! do j = 1,n do i = 1,m temp = zero do l = 1,k temp = temp + a(l,i)*b(l,j) enddo if (beta.eq.zero) then c(i,j) = alpha*temp else c(i,j) = alpha*temp + beta*c(i,j) endif enddo enddo endif elseif (nota) then if (conjb) then ! ! Form C := alpha*A*B**H + beta*C. ! do j = 1,n if (beta.eq.zero) then c(1:m,j) = zero elseif (beta.ne.one) then c(1:m,j) = beta*c(1:m,j) endif do l = 1,k temp = alpha*dconjg(b(j,l)) do i = 1,m c(i,j) = c(i,j) + temp*a(i,l) enddo enddo enddo else ! ! Form C := alpha*A*B**T + beta*C ! do j = 1,n if (beta.eq.zero) then c(1:m,j) = zero elseif (beta.ne.one) then c(1:m,j) = beta*c(1:m,j) endif do l = 1,k temp = alpha*b(j,l) c(1:m,j) = c(1:m,j) + temp*a(1:m,l) enddo enddo endif elseif (conja) then if (conjb) then ! ! Form C := alpha*A**H*B**H + beta*C. ! do j = 1,n do i = 1,m temp = zero do l = 1,k temp = temp + dconjg(a(l,i))*dconjg(b(j,l)) enddo if (beta.eq.zero) then c(i,j) = alpha*temp else c(i,j) = alpha*temp + beta*c(i,j) endif enddo enddo else ! ! Form C := alpha*A**H*B**T + beta*C ! do j = 1,n do i = 1,m temp = zero do l = 1,k temp = temp + dconjg(a(l,i))*b(j,l) enddo if (beta.eq.zero) then c(i,j) = alpha*temp else c(i,j) = alpha*temp + beta*c(i,j) endif enddo enddo endif else if (conjb) then ! ! Form C := alpha*A**T*B**H + beta*C ! do j = 1,n do i = 1,m temp = zero do l = 1,k temp = temp + a(l,i)*dconjg(b(j,l)) enddo if (beta.eq.zero) then c(i,j) = alpha*temp else c(i,j) = alpha*temp + beta*c(i,j) endif enddo enddo else ! ! Form C := alpha*A**T*B**T + beta*C ! do j = 1,n do i = 1,m temp = zero do l = 1,k temp = temp + a(l,i)*b(j,l) enddo if (beta.eq.zero) then c(i,j) = alpha*temp else c(i,j) = alpha*temp + beta*c(i,j) endif enddo enddo endif endif ! end subroutine zgemm !> !!##NAME !! zgemv(3f) - [BLAS:COMPLEX_16_BLAS_LEVEL2] !! !!##SYNOPSIS !! !! subroutine zgemv(trans,m,n,alpha,a,lda,x,incx,beta,y,incy) !! !! .. Scalar Arguments .. !! complex(kind=real64),intent(in) :: alpha,beta !! integer,intent(in) :: incx,incy,lda,m,n !! character,intent(in) :: trans !! .. !! .. Array Arguments .. !! complex(kind=real64),intent(in) :: a(lda,*),x(*) !! complex(kind=real64),intent(inout) :: y(*) !! .. !! !!##DEFINITION !! !! ZGEMV performs one of the matrix-vector operations !! !! y := alpha*A*x + beta*y, or y := alpha*A**T*x + beta*y, or !! !! y := alpha*A**H*x + beta*y, !! !! where alpha and beta are scalars, x and y are vectors and A is an !! m by n matrix. !! !!##OPTIONS !! !! TRANS !! !! TRANS is 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**T*x + beta*y. !! !! TRANS = 'C' or 'c' y := alpha*A**H*x + beta*y. !! !! M !! !! M is INTEGER !! On entry, M specifies the number of rows of the matrix A. !! M must be at least zero. !! !! N !! !! N is INTEGER !! On entry, N specifies the number of columns of the matrix A. !! N must be at least zero. !! !! ALPHA !! !! ALPHA is complex(kind=real64) !! On entry, ALPHA specifies the scalar alpha. !! !! A !! !! A is complex(kind=real64) array, dimension ( LDA, N ) !! Before entry, the leading m by n part of the array A must !! contain the matrix of coefficients. !! !! LDA !! !! LDA is 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 ). !! !! X !! !! X is complex(kind=real64) array, 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. !! !! INCX !! !! INCX is INTEGER !! On entry, INCX specifies the increment for the elements of !! X. INCX must not be zero. !! !! BETA !! !! BETA is complex(kind=real64) !! On entry, BETA specifies the scalar beta. When BETA is !! supplied as zero then Y need not be set on input. !! !! Y !! !! Y is complex(kind=real64) array, 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 !! !! INCY is INTEGER !! On entry, INCY specifies the increment for the elements of !! Y. INCY must not be zero. !! !!##AUTHORS !! !! + Univ. of Tennessee !! + Univ. of California Berkeley !! + Univ. of Colorado Denver !! + NAG Ltd. !! !! date:December 2016 !! !! FURTHER DETAILS !! !! Level 2 Blas routine. !! The vector and matrix arguments are not referenced when N = 0, or M = 0 !! !! -- 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. !! !!##SEE ALSO !! Online html documentation available at !! http://www.netlib.org/lapack/explore-html/ ! ===================================================================== subroutine zgemv(trans,m,n,alpha,a,lda,x,incx,beta,y,incy) implicit none ! ! -- Reference BLAS level2 routine (version 3.7.0) -- ! -- Reference BLAS is a software package provided by Univ. of Tennessee, -- ! -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- ! December 2016 ! ! .. Scalar Arguments .. complex(kind=real64),intent(in) :: alpha,beta integer,intent(in) :: incx,incy,lda,m,n character,intent(in) :: trans ! .. ! .. Array Arguments .. complex(kind=real64),intent(in) :: a(lda,*),x(*) complex(kind=real64),intent(inout) :: y(*) ! .. ! ! ===================================================================== ! ! .. Parameters .. complex(kind=real64) :: one parameter (one= (1.0d+0,0.0d+0)) complex(kind=real64) :: zero parameter (zero= (0.0d+0,0.0d+0)) ! .. ! .. Local Scalars .. complex(kind=real64) :: temp integer i,info,ix,iy,j,jx,jy,kx,ky,lenx,leny logical noconj ! .. ! .. External Functions .. ! LOGICAL LSAME ! EXTERNAL LSAME ! .. ! .. External Subroutines .. ! EXTERNAL XERBLA ! .. ! .. Intrinsic Functions .. intrinsic dconjg,max ! .. ! ! Test the input parameters. ! info = 0 if (.not.lsame(trans,'N') .and. .not.lsame(trans,'T') .and. .not.lsame(trans,'C')) then info = 1 elseif (m.lt.0) then info = 2 elseif (n.lt.0) then info = 3 elseif (lda.lt.max(1,m)) then info = 6 elseif (incx.eq.0) then info = 8 elseif (incy.eq.0) then info = 11 endif if (info.ne.0) then call xerbla('ZGEMV ',info) return endif ! ! Quick return if possible. ! if ((m.eq.0) .or. (n.eq.0) .or. ((alpha.eq.zero).and. (beta.eq.one))) return ! noconj = lsame(trans,'T') ! ! Set LENX and LENY, the lengths of the vectors x and y, and set ! up the start points in X and Y. ! if (lsame(trans,'N')) then lenx = n leny = m else lenx = m leny = n endif if (incx.gt.0) then kx = 1 else kx = 1 - (lenx-1)*incx endif if (incy.gt.0) then ky = 1 else ky = 1 - (leny-1)*incy endif ! ! Start the operations. In this version the elements of A are ! accessed sequentially with one pass through A. ! ! First form y := beta*y. ! if (beta.ne.one) then if (incy.eq.1) then if (beta.eq.zero) then do i = 1,leny y(i) = zero enddo else do i = 1,leny y(i) = beta*y(i) enddo endif else iy = ky if (beta.eq.zero) then do i = 1,leny y(iy) = zero iy = iy + incy enddo else do i = 1,leny y(iy) = beta*y(iy) iy = iy + incy enddo endif endif endif if (alpha.eq.zero) return if (lsame(trans,'N')) then ! ! Form y := alpha*A*x + y. ! jx = kx if (incy.eq.1) then do j = 1,n temp = alpha*x(jx) do i = 1,m y(i) = y(i) + temp*a(i,j) enddo jx = jx + incx enddo else do j = 1,n temp = alpha*x(jx) iy = ky do i = 1,m y(iy) = y(iy) + temp*a(i,j) iy = iy + incy enddo jx = jx + incx enddo endif else ! ! Form y := alpha*A**T*x + y or y := alpha*A**H*x + y. ! jy = ky if (incx.eq.1) then do j = 1,n temp = zero if (noconj) then do i = 1,m temp = temp + a(i,j)*x(i) enddo else do i = 1,m temp = temp + dconjg(a(i,j))*x(i) enddo endif y(jy) = y(jy) + alpha*temp jy = jy + incy enddo else do j = 1,n temp = zero ix = kx if (noconj) then do i = 1,m temp = temp + a(i,j)*x(ix) ix = ix + incx enddo else do i = 1,m temp = temp + dconjg(a(i,j))*x(ix) ix = ix + incx enddo endif y(jy) = y(jy) + alpha*temp jy = jy + incy enddo endif endif ! end subroutine zgemv !> !!##NAME !! zgerc(3f) - [BLAS:COMPLEX_16_BLAS_LEVEL2] !! !!##SYNOPSIS !! !! subroutine zgerc(m,n,alpha,x,incx,y,incy,a,lda) !! !! .. Scalar Arguments .. !! complex(kind=real64),intent(in) :: alpha !! integer,intent(in) :: incx,incy,lda,m,n !! .. !! .. Array Arguments .. !! complex(kind=real64),intent(in) :: x(*),y(*) !! complex(kind=real64),intent(inout) :: a(lda,*) !! .. !! !!##DEFINITION !! !! ZGERC performs the rank 1 operation !! !! A := alpha*x*y**H + 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. !! !!##OPTIONS !! !! M !! !! M is INTEGER !! On entry, M specifies the number of rows of the matrix A. !! M must be at least zero. !! !! N !! !! N is INTEGER !! On entry, N specifies the number of columns of the matrix A. !! N must be at least zero. !! !! ALPHA !! !! ALPHA is complex(kind=real64) !! On entry, ALPHA specifies the scalar alpha. !! !! X !! !! X is complex(kind=real64) array, dimension at least !! ( 1 + ( m - 1 )*abs( INCX ) ). !! Before entry, the incremented array X must contain the m !! element vector x. !! !! INCX !! !! INCX is INTEGER !! On entry, INCX specifies the increment for the elements of !! X. INCX must not be zero. !! !! Y !! !! Y is complex(kind=real64) array, dimension at least !! ( 1 + ( n - 1 )*abs( INCY ) ). !! Before entry, the incremented array Y must contain the n !! element vector y. !! !! INCY !! !! INCY is INTEGER !! On entry, INCY specifies the increment for the elements of !! Y. INCY must not be zero. !! !! A !! !! A is complex(kind=real64) array, 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 !! !! LDA is 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 ). !! !!##AUTHORS !! !! + Univ. of Tennessee !! + Univ. of California Berkeley !! + Univ. of Colorado Denver !! + NAG Ltd. !! !! date:December 2016 !! !! FURTHER DETAILS !! !! 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. !! !!##SEE ALSO !! Online html documentation available at !! http://www.netlib.org/lapack/explore-html/ ! ===================================================================== subroutine zgerc(m,n,alpha,x,incx,y,incy,a,lda) implicit none ! ! -- Reference BLAS level2 routine (version 3.7.0) -- ! -- Reference BLAS is a software package provided by Univ. of Tennessee, -- ! -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- ! December 2016 ! ! .. Scalar Arguments .. complex(kind=real64),intent(in) :: alpha integer,intent(in) :: incx,incy,lda,m,n ! .. ! .. Array Arguments .. complex(kind=real64),intent(in) :: x(*),y(*) complex(kind=real64),intent(inout) :: a(lda,*) ! .. ! ! ===================================================================== ! ! .. Parameters .. complex(kind=real64) :: zero parameter (zero= (0.0d+0,0.0d+0)) ! .. ! .. Local Scalars .. complex(kind=real64) :: temp integer i,info,ix,j,jy,kx ! .. ! .. External Subroutines .. ! EXTERNAL XERBLA ! .. ! .. Intrinsic Functions .. intrinsic dconjg,max ! .. ! ! Test the input parameters. ! info = 0 if (m.lt.0) then info = 1 elseif (n.lt.0) then info = 2 elseif (incx.eq.0) then info = 5 elseif (incy.eq.0) then info = 7 elseif (lda.lt.max(1,m)) then info = 9 endif if (info.ne.0) then call xerbla('ZGERC ',info) return endif ! ! Quick return if possible. ! if ((m.eq.0) .or. (n.eq.0) .or. (alpha.eq.zero)) return ! ! Start the operations. In this version the elements of A are ! accessed sequentially with one pass through A. ! if (incy.gt.0) then jy = 1 else jy = 1 - (n-1)*incy endif if (incx.eq.1) then do j = 1,n if (y(jy).ne.zero) then temp = alpha*dconjg(y(jy)) a(1:m,j) = a(1:m,j) + x(1:m)*temp endif jy = jy + incy enddo else if (incx.gt.0) then kx = 1 else kx = 1 - (m-1)*incx endif do j = 1,n if (y(jy).ne.zero) then temp = alpha*dconjg(y(jy)) ix = kx do i = 1,m a(i,j) = a(i,j) + x(ix)*temp ix = ix + incx enddo endif jy = jy + incy enddo endif end subroutine zgerc !> !!##NAME !! zgeru(3f) - [BLAS:COMPLEX_16_BLAS_LEVEL2] !! !!##SYNOPSIS !! !! subroutine zgeru(m,n,alpha,x,incx,y,incy,a,lda) !! !! .. Scalar Arguments .. !! complex(kind=real64),intent(in) :: alpha !! integer,intent(in) :: incx,incy,lda,m,n !! .. !! .. Array Arguments .. !! complex(kind=real64),intent(in) :: x(*),y(*) !! complex(kind=real64),intent(inout) :: a(lda,*) !! .. !! !!##DEFINITION !! !! ZGERU performs the rank 1 operation !! !! A := alpha*x*y**T + 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. !! !!##OPTIONS !! !! M On entry, M specifies the number of rows of the matrix A. !! M must be at least zero. !! !! N On entry, N specifies the number of columns of the matrix A. !! N must be at least zero. !! !! ALPHA On entry, ALPHA specifies the scalar alpha. !! !! X array, dimension at least !! !! ( 1 + ( m - 1 )*abs( INCX ) ). !! !! Before entry, the incremented array X must contain the m !! element vector x. !! !! INCX On entry, INCX specifies the increment for the elements of !! X. INCX must not be zero. !! !! Y array, dimension at least !! !! ( 1 + ( n - 1 )*abs( INCY ) ). !! !! Before entry, the incremented array Y must contain the n !! element vector y. !! !! INCY On entry, INCY specifies the increment for the elements of !! Y. INCY must not be zero. !! !! A array, 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 On entry, LDA specifies the first dimension of A as declared !! in the calling (sub) program. LDA must be at least !! max( 1, m ). !! !!##AUTHORS !! !! + Univ. of Tennessee !! + Univ. of California Berkeley !! + Univ. of Colorado Denver !! + NAG Ltd. !! !! date:December 2016 !! !! FURTHER DETAILS !! !! 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. !! !!##SEE ALSO !! Online html documentation available at !! http://www.netlib.org/lapack/explore-html/ ! ===================================================================== subroutine zgeru(m,n,alpha,x,incx,y,incy,a,lda) implicit none ! ! -- Reference BLAS level2 routine (version 3.7.0) -- ! -- Reference BLAS is a software package provided by Univ. of Tennessee, -- ! -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- ! December 2016 ! ! .. Scalar Arguments .. complex(kind=real64),intent(in) :: alpha integer,intent(in) :: incx,incy,lda,m,n ! .. ! .. Array Arguments .. complex(kind=real64),intent(in) :: x(*),y(*) complex(kind=real64),intent(inout) :: a(lda,*) ! .. ! ! ===================================================================== ! ! .. Parameters .. complex(kind=real64) :: zero parameter (zero= (0.0d+0,0.0d+0)) ! .. ! .. Local Scalars .. complex(kind=real64) :: temp integer i,info,ix,j,jy,kx ! .. ! .. External Subroutines .. ! EXTERNAL XERBLA ! .. ! .. Intrinsic Functions .. intrinsic max ! .. ! ! Test the input parameters. ! info = 0 if (m.lt.0) then info = 1 elseif (n.lt.0) then info = 2 elseif (incx.eq.0) then info = 5 elseif (incy.eq.0) then info = 7 elseif (lda.lt.max(1,m)) then info = 9 endif if (info.ne.0) then call xerbla('ZGERU ',info) return endif ! ! Quick return if possible. ! if ((m.eq.0) .or. (n.eq.0) .or. (alpha.eq.zero)) return ! ! Start the operations. In this version the elements of A are ! accessed sequentially with one pass through A. ! if (incy.gt.0) then jy = 1 else jy = 1 - (n-1)*incy endif if (incx.eq.1) then do j = 1,n if (y(jy).ne.zero) then temp = alpha*y(jy) do i = 1,m a(i,j) = a(i,j) + x(i)*temp enddo endif jy = jy + incy enddo else if (incx.gt.0) then kx = 1 else kx = 1 - (m-1)*incx endif do j = 1,n if (y(jy).ne.zero) then temp = alpha*y(jy) ix = kx do i = 1,m a(i,j) = a(i,j) + x(ix)*temp ix = ix + incx enddo endif jy = jy + incy enddo endif end subroutine zgeru !> !!##NAME !! zhbmv(3f) - [BLAS:COMPLEX_16_BLAS_LEVEL2] !! !!##SYNOPSIS !! !! subroutine zhbmv(uplo,n,k,alpha,a,lda,x,incx,beta,y,incy) !! !! .. Scalar Arguments .. !! complex(kind=real64),intent(in) :: alpha,beta !! integer,intent(in) :: incx,incy,k,lda,n !! character,intent(in) :: uplo !! .. !! .. Array Arguments .. !! complex(kind=real64),intent(in) :: a(lda,*),x(*) !! complex(kind=real64),intent(inout) :: y(*) !! .. !! !!##DEFINITION !! !! ZHBMV 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 hermitian band matrix, with k super-diagonals. !! !!##OPTIONS !! !! UPLO !! !! UPLO is 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. !! !! N !! !! N is INTEGER !! On entry, N specifies the order of the matrix A. !! N must be at least zero. !! !! K !! !! K is INTEGER !! On entry, K specifies the number of super-diagonals of the !! matrix A. K must satisfy 0 .le. K. !! !! ALPHA !! !! ALPHA is complex(kind=real64) !! On entry, ALPHA specifies the scalar alpha. !! !! A !! !! A is complex(kind=real64) array, 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 hermitian 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 hermitian 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 hermitian 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 hermitian 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 the imaginary parts of the diagonal elements need !! not be set and are assumed to be zero. !! !! LDA !! !! LDA is INTEGER !! On entry, LDA specifies the first dimension of A as declared !! in the calling (sub) program. LDA must be at least !! ( k + 1 ). !! !! X !! !! X is complex(kind=real64) array, dimension at least !! ( 1 + ( n - 1 )*abs( INCX ) ). !! Before entry, the incremented array X must contain the !! vector x. !! !! INCX !! !! INCX is INTEGER !! On entry, INCX specifies the increment for the elements of !! X. INCX must not be zero. !! !! BETA !! !! BETA is complex(kind=real64) !! On entry, BETA specifies the scalar beta. !! !! Y !! !! Y is complex(kind=real64) array, 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 !! !! INCY is INTEGER !! On entry, INCY specifies the increment for the elements of !! Y. INCY must not be zero. !! !!##AUTHORS !! !! + Univ. of Tennessee !! + Univ. of California Berkeley !! + Univ. of Colorado Denver !! + NAG Ltd. !! !! date:December 2016 !! !! FURTHER DETAILS !! !! Level 2 Blas routine. !! The vector and matrix arguments are not referenced when N = 0, or M = 0 !! !! -- 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. !! !!##SEE ALSO !! Online html documentation available at !! http://www.netlib.org/lapack/explore-html/ ! ===================================================================== subroutine zhbmv(uplo,n,k,alpha,a,lda,x,incx,beta,y,incy) implicit none ! ! -- Reference BLAS level2 routine (version 3.7.0) -- ! -- Reference BLAS is a software package provided by Univ. of Tennessee, -- ! -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- ! December 2016 ! ! .. Scalar Arguments .. complex(kind=real64),intent(in) :: alpha,beta integer,intent(in) :: incx,incy,k,lda,n character,intent(in) :: uplo ! .. ! .. Array Arguments .. complex(kind=real64),intent(in) :: a(lda,*),x(*) complex(kind=real64),intent(inout) :: y(*) ! .. ! ! ===================================================================== ! ! .. Parameters .. complex(kind=real64) :: one parameter (one= (1.0d+0,0.0d+0)) complex(kind=real64) :: zero parameter (zero= (0.0d+0,0.0d+0)) ! .. ! .. Local Scalars .. complex(kind=real64) :: temp1,temp2 integer i,info,ix,iy,j,jx,jy,kplus1,kx,ky,l ! .. ! .. External Functions .. ! LOGICAL LSAME ! EXTERNAL LSAME ! .. ! .. External Subroutines .. ! EXTERNAL XERBLA ! .. ! .. Intrinsic Functions .. intrinsic dble,dconjg,max,min ! .. ! ! Test the input parameters. ! info = 0 if (.not.lsame(uplo,'U') .and. .not.lsame(uplo,'L')) then info = 1 elseif (n.lt.0) then info = 2 elseif (k.lt.0) then info = 3 elseif (lda.lt. (k+1)) then info = 6 elseif (incx.eq.0) then info = 8 elseif (incy.eq.0) then info = 11 endif if (info.ne.0) then call xerbla('ZHBMV ',info) return endif ! ! Quick return if possible. ! if ((n.eq.0) .or. ((alpha.eq.zero).and. (beta.eq.one))) return ! ! Set up the start points in X and Y. ! if (incx.gt.0) then kx = 1 else kx = 1 - (n-1)*incx endif if (incy.gt.0) then ky = 1 else ky = 1 - (n-1)*incy endif ! ! 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.ne.one) then if (incy.eq.1) then if (beta.eq.zero) then y(1:n) = zero else y(1:n) = beta*y(1:n) endif else iy = ky if (beta.eq.zero) then do i = 1,n y(iy) = zero iy = iy + incy enddo else do i = 1,n y(iy) = beta*y(iy) iy = iy + incy enddo endif endif endif if (alpha.eq.zero) return if (lsame(uplo,'U')) then ! ! Form y when upper triangle of A is stored. ! kplus1 = k + 1 if ((incx.eq.1) .and. (incy.eq.1)) then do j = 1,n temp1 = alpha*x(j) temp2 = zero l = kplus1 - j do i = max(1,j-k),j - 1 y(i) = y(i) + temp1*a(l+i,j) temp2 = temp2 + dconjg(a(l+i,j))*x(i) enddo y(j) = y(j) + temp1*dble(a(kplus1,j)) + alpha*temp2 enddo else jx = kx jy = ky do j = 1,n temp1 = alpha*x(jx) temp2 = zero ix = kx iy = ky l = kplus1 - j do i = max(1,j-k),j - 1 y(iy) = y(iy) + temp1*a(l+i,j) temp2 = temp2 + dconjg(a(l+i,j))*x(ix) ix = ix + incx iy = iy + incy enddo y(jy) = y(jy) + temp1*dble(a(kplus1,j)) + alpha*temp2 jx = jx + incx jy = jy + incy if (j.gt.k) then kx = kx + incx ky = ky + incy endif enddo endif else ! ! Form y when lower triangle of A is stored. ! if ((incx.eq.1) .and. (incy.eq.1)) then do j = 1,n temp1 = alpha*x(j) temp2 = zero y(j) = y(j) + temp1*dble(a(1,j)) l = 1 - j do i = j + 1,min(n,j+k) y(i) = y(i) + temp1*a(l+i,j) temp2 = temp2 + dconjg(a(l+i,j))*x(i) enddo y(j) = y(j) + alpha*temp2 enddo else jx = kx jy = ky do j = 1,n temp1 = alpha*x(jx) temp2 = zero y(jy) = y(jy) + temp1*dble(a(1,j)) l = 1 - j ix = jx iy = jy do i = j + 1,min(n,j+k) ix = ix + incx iy = iy + incy y(iy) = y(iy) + temp1*a(l+i,j) temp2 = temp2 + dconjg(a(l+i,j))*x(ix) enddo y(jy) = y(jy) + alpha*temp2 jx = jx + incx jy = jy + incy enddo endif endif end subroutine zhbmv !> !!##NAME !! zhemm(3f) - [BLAS:COMPLEX16_BLAS_LEVEL3] !! !!##SYNOPSIS !! !! subroutine zhemm(side,uplo,m,n,alpha,a,lda,b,ldb,beta,c,ldc) !! !! .. Scalar Arguments .. !! complex(kind=real64),intent(in) :: alpha,beta !! integer,intent(in) :: lda,ldb,ldc,m,n !! character,intent(in) :: side,uplo !! .. !! .. Array Arguments .. !! complex(kind=real64),intent(in) :: a(lda,*),b(ldb,*) !! complex(kind=real64),intent(inout) :: c(ldc,*) !! .. !! !!##DEFINITION !! !! ZHEMM 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 an hermitian matrix and B and !! C are m by n matrices. !! !!##OPTIONS !! !! SIDE !! !! SIDE is CHARACTER*1 !! On entry, SIDE specifies whether the hermitian 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, !! !! UPLO !! !! UPLO is CHARACTER*1 !! On entry, UPLO specifies whether the upper or lower !! triangular part of the hermitian matrix A is to be !! referenced as follows: !! !! UPLO = 'U' or 'u' Only the upper triangular part of the !! hermitian matrix is to be referenced. !! !! UPLO = 'L' or 'l' Only the lower triangular part of the !! hermitian matrix is to be referenced. !! !! M !! !! M is INTEGER !! On entry, M specifies the number of rows of the matrix C. !! M must be at least zero. !! !! N !! !! N is INTEGER !! On entry, N specifies the number of columns of the matrix C. !! N must be at least zero. !! !! ALPHA !! !! ALPHA is complex(kind=real64) !! On entry, ALPHA specifies the scalar alpha. !! !! A !! !! A is complex(kind=real64) array, 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 hermitian 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 hermitian 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 hermitian !! 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 hermitian 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 hermitian 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 hermitian !! matrix and the strictly upper triangular part of A is not !! referenced. !! Note that the imaginary parts of the diagonal elements need !! not be set, they are assumed to be zero. !! !! LDA !! !! LDA is 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 ). !! !! B !! !! B is complex(kind=real64) array, dimension ( LDB, N ) !! Before entry, the leading m by n part of the array B must !! contain the matrix B. !! !! LDB !! !! LDB is 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 ). !! !! BETA !! !! BETA is complex(kind=real64) !! On entry, BETA specifies the scalar beta. When BETA is !! supplied as zero then C need not be set on input. !! !! C !! !! C is complex(kind=real64) array, 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 !! !! LDC is 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 ). !! !!##AUTHORS !! !! + Univ. of Tennessee !! + Univ. of California Berkeley !! + Univ. of Colorado Denver !! + NAG Ltd. !! !! date:December 2016 !! !! FURTHER DETAILS !! !! 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. !! !!##SEE ALSO !! Online html documentation available at !! http://www.netlib.org/lapack/explore-html/ ! ===================================================================== subroutine zhemm(side,uplo,m,n,alpha,a,lda,b,ldb,beta,c,ldc) implicit none ! ! -- Reference BLAS level3 routine (version 3.7.0) -- ! -- Reference BLAS is a software package provided by Univ. of Tennessee, -- ! -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- ! December 2016 ! ! .. Scalar Arguments .. complex(kind=real64),intent(in) :: alpha,beta integer,intent(in) :: lda,ldb,ldc,m,n character,intent(in) :: side,uplo ! .. ! .. Array Arguments .. complex(kind=real64),intent(in) :: a(lda,*),b(ldb,*) complex(kind=real64),intent(inout) :: c(ldc,*) ! .. ! ! ===================================================================== ! ! .. External Functions .. ! LOGICAL LSAME ! EXTERNAL LSAME ! .. ! .. External Subroutines .. ! EXTERNAL XERBLA ! .. ! .. Intrinsic Functions .. intrinsic dble,dconjg,max ! .. ! .. Local Scalars .. complex(kind=real64) :: temp1,temp2 integer i,info,j,k,nrowa logical upper ! .. ! .. Parameters .. complex(kind=real64) :: one parameter (one= (1.0d+0,0.0d+0)) complex(kind=real64) :: zero parameter (zero= (0.0d+0,0.0d+0)) ! .. ! ! Set NROWA as the number of rows of A. ! if (lsame(side,'L')) then nrowa = m else nrowa = n endif upper = lsame(uplo,'U') ! ! Test the input parameters. ! info = 0 if ((.not.lsame(side,'L')) .and. (.not.lsame(side,'R'))) then info = 1 elseif ((.not.upper) .and. (.not.lsame(uplo,'L'))) then info = 2 elseif (m.lt.0) then info = 3 elseif (n.lt.0) then info = 4 elseif (lda.lt.max(1,nrowa)) then info = 7 elseif (ldb.lt.max(1,m)) then info = 9 elseif (ldc.lt.max(1,m)) then info = 12 endif if (info.ne.0) then call xerbla('ZHEMM ',info) return endif ! ! Quick return if possible. ! if ((m.eq.0) .or. (n.eq.0) .or. ((alpha.eq.zero).and. (beta.eq.one))) return ! ! And when alpha.eq.zero. ! if (alpha.eq.zero) then if (beta.eq.zero) then c(1:m,1:n) = zero else c(1:m,1:n) = beta*c(1:m,1:n) endif return endif ! ! Start the operations. ! if (lsame(side,'L')) then ! ! Form C := alpha*A*B + beta*C. ! if (upper) then do j = 1,n do i = 1,m temp1 = alpha*b(i,j) temp2 = zero do k = 1,i - 1 c(k,j) = c(k,j) + temp1*a(k,i) temp2 = temp2 + b(k,j)*dconjg(a(k,i)) enddo if (beta.eq.zero) then c(i,j) = temp1*dble(a(i,i)) + alpha*temp2 else c(i,j) = beta*c(i,j) + temp1*dble(a(i,i)) + alpha*temp2 endif enddo enddo else do j = 1,n do i = m,1,-1 temp1 = alpha*b(i,j) temp2 = zero do k = i + 1,m c(k,j) = c(k,j) + temp1*a(k,i) temp2 = temp2 + b(k,j)*dconjg(a(k,i)) enddo if (beta.eq.zero) then c(i,j) = temp1*dble(a(i,i)) + alpha*temp2 else c(i,j) = beta*c(i,j) + temp1*dble(a(i,i)) + alpha*temp2 endif enddo enddo endif else ! ! Form C := alpha*B*A + beta*C. ! do j = 1,n temp1 = alpha*dble(a(j,j)) if (beta.eq.zero) then c(1:m,j) = temp1*b(1:m,j) else c(1:m,j) = beta*c(1:m,j) + temp1*b(1:m,j) endif do k = 1,j - 1 if (upper) then temp1 = alpha*a(k,j) else temp1 = alpha*dconjg(a(j,k)) endif c(1:m,j) = c(1:m,j) + temp1*b(1:m,k) enddo do k = j + 1,n if (upper) then temp1 = alpha*dconjg(a(j,k)) else temp1 = alpha*a(k,j) endif c(1:m,j) = c(1:m,j) + temp1*b(1:m,k) enddo enddo endif end subroutine zhemm !> !!##NAME !! zhemv(3f) - [BLAS:COMPLEX_16_BLAS_LEVEL2] !! !!##SYNOPSIS !! !! subroutine zhemv(uplo,n,alpha,a,lda,x,incx,beta,y,incy) !! !! .. Scalar Arguments .. !! complex(kind=real64),intent(in) :: alpha,beta !! integer,intent(in) :: incx,incy,lda,n !! character,intent(in) :: uplo !! .. !! .. Array Arguments .. !! complex(kind=real64),intent(in) :: a(lda,*),x(*) !! complex(kind=real64),intent(inout) :: y(*) !! .. !! !!##DEFINITION !! !! ZHEMV 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 hermitian matrix. !! !!##OPTIONS !! !! UPLO !! !! UPLO is 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. !! !! N !! !! N is INTEGER !! On entry, N specifies the order of the matrix A. !! N must be at least zero. !! !! ALPHA !! !! ALPHA is complex(kind=real64) !! On entry, ALPHA specifies the scalar alpha. !! !! A !! !! A is complex(kind=real64) array, 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 hermitian 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 hermitian matrix and the strictly !! upper triangular part of A is not referenced. !! Note that the imaginary parts of the diagonal elements need !! not be set and are assumed to be zero. !! !! LDA !! !! LDA is 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 ). !! !! X !! !! X is complex(kind=real64) array, dimension at least !! ( 1 + ( n - 1 )*abs( INCX ) ). !! Before entry, the incremented array X must contain the n !! element vector x. !! !! INCX !! !! INCX is INTEGER !! On entry, INCX specifies the increment for the elements of !! X. INCX must not be zero. !! !! BETA !! !! BETA is complex(kind=real64) !! On entry, BETA specifies the scalar beta. When BETA is !! supplied as zero then Y need not be set on input. !! !! Y !! !! Y is complex(kind=real64) array, 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 !! !! INCY is INTEGER !! On entry, INCY specifies the increment for the elements of !! Y. INCY must not be zero. !! !!##AUTHORS !! !! + Univ. of Tennessee !! + Univ. of California Berkeley !! + Univ. of Colorado Denver !! + NAG Ltd. !! !! date:December 2016 !! !! FURTHER DETAILS !! !! Level 2 Blas routine. !! The vector and matrix arguments are not referenced when N = 0, or M = 0 !! !! -- 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. !! !!##SEE ALSO !! Online html documentation available at !! http://www.netlib.org/lapack/explore-html/ ! ===================================================================== subroutine zhemv(uplo,n,alpha,a,lda,x,incx,beta,y,incy) implicit none ! ! -- Reference BLAS level2 routine (version 3.7.0) -- ! -- Reference BLAS is a software package provided by Univ. of Tennessee, -- ! -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- ! December 2016 ! ! .. Scalar Arguments .. complex(kind=real64),intent(in) :: alpha,beta integer,intent(in) :: incx,incy,lda,n character,intent(in) :: uplo ! .. ! .. Array Arguments .. complex(kind=real64),intent(in) :: a(lda,*),x(*) complex(kind=real64),intent(inout) :: y(*) ! .. ! ! ===================================================================== ! ! .. Parameters .. complex(kind=real64) :: one parameter (one= (1.0d+0,0.0d+0)) complex(kind=real64) :: zero parameter (zero= (0.0d+0,0.0d+0)) ! .. ! .. Local Scalars .. complex(kind=real64) :: temp1,temp2 integer i,info,ix,iy,j,jx,jy,kx,ky ! .. ! .. External Functions .. ! logical lsame ! external lsame ! .. ! .. External Subroutines .. ! external xerbla ! .. ! .. Intrinsic Functions .. intrinsic dble,dconjg,max ! .. ! ! Test the input parameters. ! info = 0 if (.not.lsame(uplo,'U') .and. .not.lsame(uplo,'L')) then info = 1 elseif (n.lt.0) then info = 2 elseif (lda.lt.max(1,n)) then info = 5 elseif (incx.eq.0) then info = 7 elseif (incy.eq.0) then info = 10 endif if (info.ne.0) then call xerbla('ZHEMV ',info) return endif ! ! Quick return if possible. ! if ((n.eq.0) .or. ((alpha.eq.zero).and. (beta.eq.one))) return ! ! Set up the start points in X and Y. ! if (incx.gt.0) then kx = 1 else kx = 1 - (n-1)*incx endif if (incy.gt.0) then ky = 1 else ky = 1 - (n-1)*incy endif ! ! 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.ne.one) then if (incy.eq.1) then if (beta.eq.zero) then y(1:n) = zero else y(1:n) = beta*y(1:n) endif else iy = ky if (beta.eq.zero) then do i = 1,n y(iy) = zero iy = iy + incy enddo else do i = 1,n y(iy) = beta*y(iy) iy = iy + incy enddo endif endif endif if (alpha.eq.zero) return if (lsame(uplo,'U')) then ! ! Form y when A is stored in upper triangle. ! if ((incx.eq.1) .and. (incy.eq.1)) then do j = 1,n temp1 = alpha*x(j) temp2 = zero do i = 1,j - 1 y(i) = y(i) + temp1*a(i,j) temp2 = temp2 + dconjg(a(i,j))*x(i) enddo y(j) = y(j) + temp1*dble(a(j,j)) + alpha*temp2 enddo else jx = kx jy = ky do j = 1,n temp1 = alpha*x(jx) temp2 = zero ix = kx iy = ky do i = 1,j - 1 y(iy) = y(iy) + temp1*a(i,j) temp2 = temp2 + dconjg(a(i,j))*x(ix) ix = ix + incx iy = iy + incy enddo y(jy) = y(jy) + temp1*dble(a(j,j)) + alpha*temp2 jx = jx + incx jy = jy + incy enddo endif else ! ! Form y when A is stored in lower triangle. ! if ((incx.eq.1) .and. (incy.eq.1)) then do j = 1,n temp1 = alpha*x(j) temp2 = zero y(j) = y(j) + temp1*dble(a(j,j)) do i = j + 1,n y(i) = y(i) + temp1*a(i,j) temp2 = temp2 + dconjg(a(i,j))*x(i) enddo y(j) = y(j) + alpha*temp2 enddo else jx = kx jy = ky do j = 1,n temp1 = alpha*x(jx) temp2 = zero y(jy) = y(jy) + temp1*dble(a(j,j)) ix = jx iy = jy do i = j + 1,n ix = ix + incx iy = iy + incy y(iy) = y(iy) + temp1*a(i,j) temp2 = temp2 + dconjg(a(i,j))*x(ix) enddo y(jy) = y(jy) + alpha*temp2 jx = jx + incx jy = jy + incy enddo endif endif end subroutine zhemv !> !!##NAME !! zher2(3f) - [BLAS:COMPLEX_16_BLAS_LEVEL2] !! !!##SYNOPSIS !! !! subroutine zher2(uplo,n,alpha,x,incx,y,incy,a,lda) !! !! .. Scalar Arguments .. !! complex(kind=real64),intent(in) :: alpha !! integer,intent(in) :: incx,incy,lda,n !! character,intent(in) :: uplo !! .. !! .. Array Arguments .. !! complex(kind=real64),intent(in) :: x(*),y(*) !! complex(kind=real64),intent(inout) :: a(lda,*) !! .. !! !!##DEFINITION !! !! ZHER2 performs the hermitian rank 2 operation !! !! A := alpha*x*y**H + conjg( alpha )*y*x**H + A, !! !! where alpha is a scalar, x and y are n element vectors and A is an n !! by n hermitian matrix. !! !!##OPTIONS !! !! UPLO !! !! UPLO is 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. !! !! N !! !! N is INTEGER !! On entry, N specifies the order of the matrix A. !! N must be at least zero. !! !! ALPHA !! !! ALPHA is complex(kind=real64) !! On entry, ALPHA specifies the scalar alpha. !! !! X !! !! X is complex(kind=real64) array, dimension at least !! ( 1 + ( n - 1 )*abs( INCX ) ). !! Before entry, the incremented array X must contain the n !! element vector x. !! !! INCX !! !! INCX is INTEGER !! On entry, INCX specifies the increment for the elements of !! X. INCX must not be zero. !! !! Y !! !! Y is complex(kind=real64) array, dimension at least !! ( 1 + ( n - 1 )*abs( INCY ) ). !! Before entry, the incremented array Y must contain the n !! element vector y. !! !! INCY !! !! INCY is INTEGER !! On entry, INCY specifies the increment for the elements of !! Y. INCY must not be zero. !! !! A !! !! A is complex(kind=real64) array, 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 hermitian 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 hermitian 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. !! Note that the imaginary parts of the diagonal elements need !! not be set, they are assumed to be zero, and on exit they !! are set to zero. !! !! LDA !! !! LDA is 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 ). !! !!##AUTHORS !! !! + Univ. of Tennessee !! + Univ. of California Berkeley !! + Univ. of Colorado Denver !! + NAG Ltd. !! !! date:December 2016 !! !! FURTHER DETAILS !! !! 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. !! !!##SEE ALSO !! Online html documentation available at !! http://www.netlib.org/lapack/explore-html/ ! ===================================================================== subroutine zher2(uplo,n,alpha,x,incx,y,incy,a,lda) implicit none ! ! -- Reference BLAS level2 routine (version 3.7.0) -- ! -- Reference BLAS is a software package provided by Univ. of Tennessee, -- ! -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- ! December 2016 ! ! .. Scalar Arguments .. complex(kind=real64),intent(in) :: alpha integer,intent(in) :: incx,incy,lda,n character,intent(in) :: uplo ! .. ! .. Array Arguments .. complex(kind=real64),intent(in) :: x(*),y(*) complex(kind=real64),intent(inout) :: a(lda,*) ! .. ! ! ===================================================================== ! ! .. Parameters .. complex(kind=real64) :: zero parameter (zero= (0.0d+0,0.0d+0)) ! .. ! .. Local Scalars .. complex(kind=real64) :: temp1,temp2 integer i,info,ix,iy,j,jx,jy,kx,ky ! .. ! .. External Functions .. ! LOGICAL LSAME ! EXTERNAL LSAME ! .. ! .. External Subroutines .. ! EXTERNAL XERBLA ! .. ! .. Intrinsic Functions .. intrinsic dble,dconjg,max ! .. ! ! Test the input parameters. ! info = 0 if (.not.lsame(uplo,'U') .and. .not.lsame(uplo,'L')) then info = 1 elseif (n.lt.0) then info = 2 elseif (incx.eq.0) then info = 5 elseif (incy.eq.0) then info = 7 elseif (lda.lt.max(1,n)) then info = 9 endif if (info.ne.0) then call xerbla('ZHER2 ',info) return endif ! ! Quick return if possible. ! if ((n.eq.0) .or. (alpha.eq.zero)) return ! ! Set up the start points in X and Y if the increments are not both ! unity. ! if ((incx.ne.1) .or. (incy.ne.1)) then if (incx.gt.0) then kx = 1 else kx = 1 - (n-1)*incx endif if (incy.gt.0) then ky = 1 else ky = 1 - (n-1)*incy endif jx = kx jy = ky endif ! ! 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')) then ! ! Form A when A is stored in the upper triangle. ! if ((incx.eq.1) .and. (incy.eq.1)) then do j = 1,n if ((x(j).ne.zero) .or. (y(j).ne.zero)) then temp1 = alpha*dconjg(y(j)) temp2 = dconjg(alpha*x(j)) a(1:j-1,j) = a(1:j-1,j) + x(1:j-1)*temp1 + y(1:j-1)*temp2 a(j,j) = dble(a(j,j)) + dble(x(j)*temp1+y(j)*temp2) else a(j,j) = dble(a(j,j)) endif enddo else do j = 1,n if ((x(jx).ne.zero) .or. (y(jy).ne.zero)) then temp1 = alpha*dconjg(y(jy)) temp2 = dconjg(alpha*x(jx)) ix = kx iy = ky do i = 1,j - 1 a(i,j) = a(i,j) + x(ix)*temp1 + y(iy)*temp2 ix = ix + incx iy = iy + incy enddo a(j,j) = dble(a(j,j)) + dble(x(jx)*temp1+y(jy)*temp2) else a(j,j) = dble(a(j,j)) endif jx = jx + incx jy = jy + incy enddo endif else ! ! Form A when A is stored in the lower triangle. ! if ((incx.eq.1) .and. (incy.eq.1)) then do j = 1,n if ((x(j).ne.zero) .or. (y(j).ne.zero)) then temp1 = alpha*dconjg(y(j)) temp2 = dconjg(alpha*x(j)) a(j,j) = dble(a(j,j)) + dble(x(j)*temp1+y(j)*temp2) do i = j + 1,n a(i,j) = a(i,j) + x(i)*temp1 + y(i)*temp2 enddo else a(j,j) = dble(a(j,j)) endif enddo else do j = 1,n if ((x(jx).ne.zero) .or. (y(jy).ne.zero)) then temp1 = alpha*dconjg(y(jy)) temp2 = dconjg(alpha*x(jx)) a(j,j) = dble(a(j,j)) + dble(x(jx)*temp1+y(jy)*temp2) ix = jx iy = jy do i = j + 1,n ix = ix + incx iy = iy + incy a(i,j) = a(i,j) + x(ix)*temp1 + y(iy)*temp2 enddo else a(j,j) = dble(a(j,j)) endif jx = jx + incx jy = jy + incy enddo endif endif end subroutine zher2 !> !!##NAME !! zher2k(3f) - [BLAS:COMPLEX16_BLAS_LEVEL3] !! !!##SYNOPSIS !! !! subroutine zher2k(uplo,trans,n,k,alpha,a,lda,b,ldb,beta,c,ldc) !! !! .. Scalar Arguments .. !! complex(kind=real64),intent(in) :: alpha !! double precision,intent(in) :: beta !! integer ,intent(in) ::k,lda,ldb,ldc,n !! character,intent(in) :: trans,uplo !! .. !! .. Array Arguments .. !! complex(kind=real64),intent(in) :: a(lda,*),b(ldb,*) !! complex(kind=real64),intent(inout) :: c(ldc,*) !! .. !! !!##DEFINITION !! !! ZHER2K performs one of the hermitian rank 2k operations !! !! C := alpha*A*B**H + conjg( alpha )*B*A**H + beta*C, !! !! or !! !! C := alpha*A**H*B + conjg( alpha )*B**H*A + beta*C, !! !! where alpha and beta are scalars with beta real, C is an n by n !! hermitian matrix and A and B are n by k matrices in the first case !! and k by n matrices in the second case. !! !!##OPTIONS !! !! UPLO !! !! UPLO is 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. !! !! TRANS !! !! TRANS is CHARACTER*1 !! On entry, TRANS specifies the operation to be performed as !! follows: !! !! TRANS = 'N' or 'n' C := alpha*A*B**H + !! conjg( alpha )*B*A**H + !! beta*C. !! !! TRANS = 'C' or 'c' C := alpha*A**H*B + !! conjg( alpha )*B**H*A + !! beta*C. !! !! N !! !! N is INTEGER !! On entry, N specifies the order of the matrix C. N must be !! at least zero. !! !! K !! !! K is 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 = 'C' or 'c', K specifies the number of rows of the !! matrices A and B. K must be at least zero. !! !! ALPHA !! !! ALPHA is complex(kind=real64) . !! On entry, ALPHA specifies the scalar alpha. !! !! A !! !! A is complex(kind=real64) array, 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. !! !! LDA !! !! LDA is 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 ). !! !! B !! !! B is complex(kind=real64) array, 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. !! !! LDB !! !! LDB is 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 !! !! BETA is DOUBLE PRECISION . !! On entry, BETA specifies the scalar beta. !! !! C !! !! C is complex(kind=real64) array, 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 hermitian 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 hermitian 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. !! Note that the imaginary parts of the diagonal elements need !! not be set, they are assumed to be zero, and on exit they !! are set to zero. !! !! LDC !! !! LDC is 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 ). !! !!##AUTHORS !! !! + Univ. of Tennessee !! + Univ. of California Berkeley !! + Univ. of Colorado Denver !! + NAG Ltd. !! !! date:December 2016 !! !! FURTHER DETAILS !! !! 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. !! !! -- Modified 8-Nov-93 to set C(J,J) to DBLE( C(J,J) ) when BETA = 1. !! Ed Anderson, Cray Research Inc. !! !!##SEE ALSO !! Online html documentation available at !! http://www.netlib.org/lapack/explore-html/ ! ===================================================================== subroutine zher2k(uplo,trans,n,k,alpha,a,lda,b,ldb,beta,c,ldc) implicit none ! ! -- Reference BLAS level3 routine (version 3.7.0) -- ! -- Reference BLAS is a software package provided by Univ. of Tennessee, -- ! -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- ! December 2016 ! ! .. Scalar Arguments .. complex(kind=real64),intent(in) :: alpha double precision,intent(in) :: beta integer ,intent(in) ::k,lda,ldb,ldc,n character,intent(in) :: trans,uplo ! .. ! .. Array Arguments .. complex(kind=real64),intent(in) :: a(lda,*),b(ldb,*) complex(kind=real64),intent(inout) :: c(ldc,*) ! .. ! ! ===================================================================== ! ! .. External Functions .. ! LOGICAL LSAME ! EXTERNAL LSAME ! .. ! .. External Subroutines .. ! EXTERNAL XERBLA ! .. ! .. Intrinsic Functions .. intrinsic dble,dconjg,max ! .. ! .. Local Scalars .. complex(kind=real64) :: temp1,temp2 integer i,info,j,l,nrowa logical upper ! .. ! .. Parameters .. double precision one parameter (one=1.0d+0) complex(kind=real64) :: zero parameter (zero= (0.0d+0,0.0d+0)) ! .. ! ! Test the input parameters. ! if (lsame(trans,'N')) then nrowa = n else nrowa = k endif upper = lsame(uplo,'U') ! info = 0 if ((.not.upper) .and. (.not.lsame(uplo,'L'))) then info = 1 elseif ((.not.lsame(trans,'N')) .and. (.not.lsame(trans,'C'))) then info = 2 elseif (n.lt.0) then info = 3 elseif (k.lt.0) then info = 4 elseif (lda.lt.max(1,nrowa)) then info = 7 elseif (ldb.lt.max(1,nrowa)) then info = 9 elseif (ldc.lt.max(1,n)) then info = 12 endif if (info.ne.0) then call xerbla('ZHER2K',info) return endif ! ! Quick return if possible. ! if ((n.eq.0) .or. (((alpha.eq.zero).or. (k.eq.0)).and. (beta.eq.one))) return ! ! And when alpha.eq.zero. ! if (alpha.eq.zero) then if (upper) then if (beta.eq.dble(zero)) then do j = 1,n c(1:j,j) = zero enddo else do j = 1,n c(1:j-1,j) = beta*c(1:j-1,j) c(j,j) = beta*dble(c(j,j)) enddo endif else if (beta.eq.dble(zero)) then do j = 1,n c(j:n,j) = zero enddo else do j = 1,n c(j,j) = beta*dble(c(j,j)) c(j+1:n,j) = beta*c(j+1:n,j) enddo endif endif return endif ! ! Start the operations. ! if (lsame(trans,'N')) then ! ! Form C := alpha*A*B**H + conjg( alpha )*B*A**H + ! C. ! if (upper) then do j = 1,n if (beta.eq.dble(zero)) then c(1:j,j) = zero elseif (beta.ne.one) then c(1:j-1,j) = beta*c(1:j-1,j) c(j,j) = beta*dble(c(j,j)) else c(j,j) = dble(c(j,j)) endif do l = 1,k if ((a(j,l).ne.zero) .or. (b(j,l).ne.zero)) then temp1 = alpha*dconjg(b(j,l)) temp2 = dconjg(alpha*a(j,l)) do i = 1,j - 1 c(i,j) = c(i,j) + a(i,l)*temp1 + b(i,l)*temp2 enddo c(j,j) = dble(c(j,j)) + dble(a(j,l)*temp1+b(j,l)*temp2) endif enddo enddo else do j = 1,n if (beta.eq.dble(zero)) then c(j:n,j) = zero elseif (beta.ne.one) then c(j+1:n,j) = beta*c(j+1:n,j) c(j,j) = beta*dble(c(j,j)) else c(j,j) = dble(c(j,j)) endif do l = 1,k if ((a(j,l).ne.zero) .or. (b(j,l).ne.zero)) then temp1 = alpha*dconjg(b(j,l)) temp2 = dconjg(alpha*a(j,l)) do i = j + 1,n c(i,j) = c(i,j) + a(i,l)*temp1 + b(i,l)*temp2 enddo c(j,j) = dble(c(j,j)) + dble(a(j,l)*temp1+b(j,l)*temp2) endif enddo enddo endif else ! ! Form C := alpha*A**H*B + conjg( alpha )*B**H*A + ! C. ! if (upper) then do j = 1,n do i = 1,j temp1 = zero temp2 = zero do l = 1,k temp1 = temp1 + dconjg(a(l,i))*b(l,j) temp2 = temp2 + dconjg(b(l,i))*a(l,j) enddo if (i.eq.j) then if (beta.eq.dble(zero)) then c(j,j) = dble(alpha*temp1+ dconjg(alpha)*temp2) else c(j,j) = beta*dble(c(j,j)) + dble(alpha*temp1+ dconjg(alpha)*temp2) endif else if (beta.eq.dble(zero)) then c(i,j) = alpha*temp1 + dconjg(alpha)*temp2 else c(i,j) = beta*c(i,j) + alpha*temp1 + dconjg(alpha)*temp2 endif endif enddo enddo else do j = 1,n do i = j,n temp1 = zero temp2 = zero do l = 1,k temp1 = temp1 + dconjg(a(l,i))*b(l,j) temp2 = temp2 + dconjg(b(l,i))*a(l,j) enddo if (i.eq.j) then if (beta.eq.dble(zero)) then c(j,j) = dble(alpha*temp1+ dconjg(alpha)*temp2) else c(j,j) = beta*dble(c(j,j)) + dble(alpha*temp1+ dconjg(alpha)*temp2) endif else if (beta.eq.dble(zero)) then c(i,j) = alpha*temp1 + dconjg(alpha)*temp2 else c(i,j) = beta*c(i,j) + alpha*temp1 + dconjg(alpha)*temp2 endif endif enddo enddo endif endif end subroutine zher2k !> !!##NAME !! zher(3f) - [BLAS:COMPLEX_16_BLAS_LEVEL2] !! !!##SYNOPSIS !! !! subroutine zher(uplo,n,alpha,x,incx,a,lda) !! !! .. Scalar Arguments .. !! double precision,intent(in) :: alpha !! integer ,intent(in) :: incx,lda,n !! character,intent(in) :: uplo !! .. !! .. Array Arguments .. !! complex(kind=real64),intent(in) :: x(*) !! complex(kind=real64),intent(inout) :: a(lda,*) !! .. !! !!##DEFINITION !! !! ZHER performs the hermitian rank 1 operation !! !! A := alpha*x*x**H + A, !! !! where alpha is a real scalar, x is an n element vector and A is an !! n by n hermitian matrix. !! !!##OPTIONS !! !! UPLO !! !! UPLO is 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. !! !! N !! !! N is INTEGER !! On entry, N specifies the order of the matrix A. !! N must be at least zero. !! !! ALPHA !! !! ALPHA is DOUBLE PRECISION. !! On entry, ALPHA specifies the scalar alpha. !! !! X !! !! X is complex(kind=real64) array, dimension at least !! ( 1 + ( n - 1 )*abs( INCX ) ). !! Before entry, the incremented array X must contain the n !! element vector x. !! !! INCX !! !! INCX is INTEGER !! On entry, INCX specifies the increment for the elements of !! X. INCX must not be zero. !! !! A !! !! A is complex(kind=real64) array, 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 hermitian 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 hermitian 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. !! Note that the imaginary parts of the diagonal elements need !! not be set, they are assumed to be zero, and on exit they !! are set to zero. !! !! LDA !! !! LDA is 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 ). !! !!##AUTHORS !! !! + Univ. of Tennessee !! + Univ. of California Berkeley !! + Univ. of Colorado Denver !! + NAG Ltd. !! !! date:December 2016 !! !! FURTHER DETAILS !! !! 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. !! !!##SEE ALSO !! Online html documentation available at !! http://www.netlib.org/lapack/explore-html/ ! ===================================================================== subroutine zher(uplo,n,alpha,x,incx,a,lda) implicit none ! ! -- Reference BLAS level2 routine (version 3.7.0) -- ! -- Reference BLAS is a software package provided by Univ. of Tennessee, -- ! -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- ! December 2016 ! ! .. Scalar Arguments .. double precision,intent(in) :: alpha integer ,intent(in) :: incx,lda,n character,intent(in) :: uplo ! .. ! .. Array Arguments .. complex(kind=real64),intent(in) :: x(*) complex(kind=real64),intent(inout) :: a(lda,*) ! .. ! ! ===================================================================== ! ! .. Parameters .. complex(kind=real64) :: zero parameter (zero= (0.0d+0,0.0d+0)) ! .. ! .. Local Scalars .. complex(kind=real64) :: temp integer i,info,ix,j,jx,kx ! .. ! .. External Functions .. ! LOGICAL LSAME ! EXTERNAL LSAME ! .. ! .. External Subroutines .. ! EXTERNAL XERBLA ! .. ! .. Intrinsic Functions .. intrinsic dble,dconjg,max ! .. ! ! Test the input parameters. ! info = 0 if (.not.lsame(uplo,'U') .and. .not.lsame(uplo,'L')) then info = 1 elseif (n.lt.0) then info = 2 elseif (incx.eq.0) then info = 5 elseif (lda.lt.max(1,n)) then info = 7 endif if (info.ne.0) then call xerbla('ZHER ',info) return endif ! ! Quick return if possible. ! if ((n.eq.0) .or. (alpha.eq.dble(zero))) return ! ! Set the start point in X if the increment is not unity. ! if (incx.le.0) then kx = 1 - (n-1)*incx elseif (incx.ne.1) then kx = 1 endif ! ! 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')) then ! ! Form A when A is stored in upper triangle. ! if (incx.eq.1) then do j = 1,n if (x(j).ne.zero) then temp = alpha*dconjg(x(j)) do i = 1,j - 1 a(i,j) = a(i,j) + x(i)*temp enddo a(j,j) = dble(a(j,j)) + dble(x(j)*temp) else a(j,j) = dble(a(j,j)) endif enddo else jx = kx do j = 1,n if (x(jx).ne.zero) then temp = alpha*dconjg(x(jx)) ix = kx do i = 1,j - 1 a(i,j) = a(i,j) + x(ix)*temp ix = ix + incx enddo a(j,j) = dble(a(j,j)) + dble(x(jx)*temp) else a(j,j) = dble(a(j,j)) endif jx = jx + incx enddo endif else ! ! Form A when A is stored in lower triangle. ! if (incx.eq.1) then do j = 1,n if (x(j).ne.zero) then temp = alpha*dconjg(x(j)) a(j,j) = dble(a(j,j)) + dble(temp*x(j)) do i = j + 1,n a(i,j) = a(i,j) + x(i)*temp enddo else a(j,j) = dble(a(j,j)) endif enddo else jx = kx do j = 1,n if (x(jx).ne.zero) then temp = alpha*dconjg(x(jx)) a(j,j) = dble(a(j,j)) + dble(temp*x(jx)) ix = jx do i = j + 1,n ix = ix + incx a(i,j) = a(i,j) + x(ix)*temp enddo else a(j,j) = dble(a(j,j)) endif jx = jx + incx enddo endif endif end subroutine zher !> !!##NAME !! zherk(3f) - [BLAS:COMPLEX16_BLAS_LEVEL3] !! !!##SYNOPSIS !! !! subroutine zherk(uplo,trans,n,k,alpha,a,lda,beta,c,ldc) !! !! .. Scalar Arguments .. !! double precision,intent(in) :: alpha,beta !! integer,intent(in) :: k,lda,ldc,n !! character,intent(in) :: trans,uplo !! .. !! .. Array Arguments .. !! complex(kind=real64),intent(in) :: a(lda,*) !! complex(kind=real64),intent(inout) :: c(ldc,*) !! .. !! !!##DEFINITION !! !! ZHERK performs one of the hermitian rank k operations !! !! C := alpha*A*A**H + beta*C, !! !! or !! !! C := alpha*A**H*A + beta*C, !! !! where alpha and beta are real scalars, C is an n by n hermitian !! matrix and A is an n by k matrix in the first case and a k by n !! matrix in the second case. !! !!##OPTIONS !! !! UPLO !! !! UPLO is 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. !! !! TRANS !! !! TRANS is CHARACTER*1 !! On entry, TRANS specifies the operation to be performed as !! follows: !! !! TRANS = 'N' or 'n' C := alpha*A*A**H + beta*C. !! !! TRANS = 'C' or 'c' C := alpha*A**H*A + beta*C. !! !! N !! !! N is INTEGER !! On entry, N specifies the order of the matrix C. N must be !! at least zero. !! !! K !! !! K is INTEGER !! On entry with TRANS = 'N' or 'n', K specifies the number !! of columns of the matrix A, and on entry with !! TRANS = 'C' or 'c', K specifies the number of rows of the !! matrix A. K must be at least zero. !! !! ALPHA !! !! ALPHA is DOUBLE PRECISION . !! On entry, ALPHA specifies the scalar alpha. !! !! A !! !! A is complex(kind=real64) array, 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. !! !! LDA !! !! LDA is 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 ). !! !! BETA !! !! BETA is DOUBLE PRECISION. !! On entry, BETA specifies the scalar beta. !! !! C !! !! C is complex(kind=real64) array, 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 hermitian 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 hermitian 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. !! Note that the imaginary parts of the diagonal elements need !! not be set, they are assumed to be zero, and on exit they !! are set to zero. !! !! LDC !! !! LDC is 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 ). !! !!##AUTHORS !! !! + Univ. of Tennessee !! + Univ. of California Berkeley !! + Univ. of Colorado Denver !! + NAG Ltd. !! !! date:December 2016 !! !! FURTHER DETAILS !! !! 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. !! !! -- Modified 8-Nov-93 to set C(J,J) to DBLE( C(J,J) ) when BETA = 1. !! Ed Anderson, Cray Research Inc. !! !!##SEE ALSO !! Online html documentation available at !! http://www.netlib.org/lapack/explore-html/ ! ===================================================================== subroutine zherk(uplo,trans,n,k,alpha,a,lda,beta,c,ldc) implicit none ! ! -- Reference BLAS level3 routine (version 3.7.0) -- ! -- Reference BLAS is a software package provided by Univ. of Tennessee, -- ! -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- ! December 2016 ! ! .. Scalar Arguments .. double precision,intent(in) :: alpha,beta integer,intent(in) :: k,lda,ldc,n character,intent(in) :: trans,uplo ! .. ! .. Array Arguments .. complex(kind=real64),intent(in) :: a(lda,*) complex(kind=real64),intent(inout) :: c(ldc,*) ! .. ! ! ===================================================================== ! ! .. External Functions .. ! LOGICAL LSAME ! EXTERNAL LSAME ! .. ! .. External Subroutines .. ! EXTERNAL XERBLA ! .. ! .. Intrinsic Functions .. intrinsic dble,dcmplx,dconjg,max ! .. ! .. Local Scalars .. complex(kind=real64) :: temp double precision rtemp integer i,info,j,l,nrowa logical upper ! .. ! .. Parameters .. double precision one,zero parameter (one=1.0d+0,zero=0.0d+0) ! .. ! ! Test the input parameters. ! if (lsame(trans,'N')) then nrowa = n else nrowa = k endif upper = lsame(uplo,'U') ! info = 0 if ((.not.upper) .and. (.not.lsame(uplo,'L'))) then info = 1 elseif ((.not.lsame(trans,'N')) .and. (.not.lsame(trans,'C'))) then info = 2 elseif (n.lt.0) then info = 3 elseif (k.lt.0) then info = 4 elseif (lda.lt.max(1,nrowa)) then info = 7 elseif (ldc.lt.max(1,n)) then info = 10 endif if (info.ne.0) then call xerbla('ZHERK ',info) return endif ! ! Quick return if possible. ! if ((n.eq.0) .or. (((alpha.eq.zero).or. (k.eq.0)).and. (beta.eq.one))) return ! ! And when alpha.eq.zero. ! if (alpha.eq.zero) then if (upper) then if (beta.eq.zero) then do j = 1,n c(1:j,j) = zero enddo else do j = 1,n do i = 1,j - 1 c(i,j) = beta*c(i,j) enddo c(j,j) = beta*dble(c(j,j)) enddo endif else if (beta.eq.zero) then do j = 1,n c(j:n,j) = zero enddo else do j = 1,n c(j,j) = beta*dble(c(j,j)) do i = j + 1,n c(i,j) = beta*c(i,j) enddo enddo endif endif return endif ! ! Start the operations. ! if (lsame(trans,'N')) then ! ! Form C := alpha*A*A**H + beta*C. ! if (upper) then do j = 1,n if (beta.eq.zero) then c(1:j,j) = zero elseif (beta.ne.one) then do i = 1,j - 1 c(i,j) = beta*c(i,j) enddo c(j,j) = beta*dble(c(j,j)) else c(j,j) = dble(c(j,j)) endif do l = 1,k if (a(j,l).ne.dcmplx(zero)) then temp = alpha*dconjg(a(j,l)) do i = 1,j - 1 c(i,j) = c(i,j) + temp*a(i,l) enddo c(j,j) = dble(c(j,j)) + dble(temp*a(i,l)) endif enddo enddo else do j = 1,n if (beta.eq.zero) then c(j:n,j) = zero elseif (beta.ne.one) then c(j,j) = beta*dble(c(j,j)) do i = j + 1,n c(i,j) = beta*c(i,j) enddo else c(j,j) = dble(c(j,j)) endif do l = 1,k if (a(j,l).ne.dcmplx(zero)) then temp = alpha*dconjg(a(j,l)) c(j,j) = dble(c(j,j)) + dble(temp*a(j,l)) do i = j + 1,n c(i,j) = c(i,j) + temp*a(i,l) enddo endif enddo enddo endif else ! ! Form C := alpha*A**H*A + beta*C. ! if (upper) then do j = 1,n do i = 1,j - 1 temp = zero do l = 1,k temp = temp + dconjg(a(l,i))*a(l,j) enddo if (beta.eq.zero) then c(i,j) = alpha*temp else c(i,j) = alpha*temp + beta*c(i,j) endif enddo rtemp = zero do l = 1,k rtemp = rtemp + dconjg(a(l,j))*a(l,j) enddo if (beta.eq.zero) then c(j,j) = alpha*rtemp else c(j,j) = alpha*rtemp + beta*dble(c(j,j)) endif enddo else do j = 1,n rtemp = zero do l = 1,k rtemp = rtemp + dconjg(a(l,j))*a(l,j) enddo if (beta.eq.zero) then c(j,j) = alpha*rtemp else c(j,j) = alpha*rtemp + beta*dble(c(j,j)) endif do i = j + 1,n temp = zero do l = 1,k temp = temp + dconjg(a(l,i))*a(l,j) enddo if (beta.eq.zero) then c(i,j) = alpha*temp else c(i,j) = alpha*temp + beta*c(i,j) endif enddo enddo endif endif end subroutine zherk !> !!##NAME !! zhpmv(3f) - [BLAS:COMPLEX_16_BLAS_LEVEL2] !! !!##SYNOPSIS !! !! subroutine zhpmv(uplo,n,alpha,ap,x,incx,beta,y,incy) !! !! .. Scalar Arguments .. !! complex(kind=real64),intent(in) :: alpha,beta !! integer,intent(in) :: incx,incy,n !! character,intent(in) :: uplo !! .. !! .. Array Arguments .. !! complex(kind=real64),intent(in) :: ap(*),x(*) !! complex(kind=real64),intent(inout) :: y(*) !! .. !! !!##DEFINITION !! !! ZHPMV 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 hermitian matrix, supplied in packed form. !! !!##OPTIONS !! !! UPLO !! !! UPLO is 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. !! !! N !! !! N is INTEGER !! On entry, N specifies the order of the matrix A. !! N must be at least zero. !! !! ALPHA !! !! ALPHA is complex(kind=real64) !! On entry, ALPHA specifies the scalar alpha. !! !! AP !! !! AP is complex(kind=real64) array, 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 hermitian 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 hermitian 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 the imaginary parts of the diagonal elements need !! not be set and are assumed to be zero. !! !! X !! !! X is complex(kind=real64) array, dimension at least !! ( 1 + ( n - 1 )*abs( INCX ) ). !! Before entry, the incremented array X must contain the n !! element vector x. !! !! INCX !! !! INCX is INTEGER !! On entry, INCX specifies the increment for the elements of !! X. INCX must not be zero. !! !! BETA !! !! BETA is complex(kind=real64) !! On entry, BETA specifies the scalar beta. When BETA is !! supplied as zero then Y need not be set on input. !! !! Y !! !! Y is complex(kind=real64) array, 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 !! !! INCY is INTEGER !! On entry, INCY specifies the increment for the elements of !! Y. INCY must not be zero. !! !!##AUTHORS !! !! + Univ. of Tennessee !! + Univ. of California Berkeley !! + Univ. of Colorado Denver !! + NAG Ltd. !! !! date:December 2016 !! !! FURTHER DETAILS !! !! Level 2 Blas routine. !! The vector and matrix arguments are not referenced when N = 0, or M = 0 !! !! -- 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. !! !!##SEE ALSO !! Online html documentation available at !! http://www.netlib.org/lapack/explore-html/ ! ===================================================================== subroutine zhpmv(uplo,n,alpha,ap,x,incx,beta,y,incy) implicit none ! ! -- Reference BLAS level2 routine (version 3.7.0) -- ! -- Reference BLAS is a software package provided by Univ. of Tennessee, -- ! -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- ! December 2016 ! ! .. Scalar Arguments .. complex(kind=real64),intent(in) :: alpha,beta integer,intent(in) :: incx,incy,n character,intent(in) :: uplo ! .. ! .. Array Arguments .. complex(kind=real64),intent(in) :: ap(*),x(*) complex(kind=real64),intent(inout) :: y(*) ! .. ! ! ===================================================================== ! ! .. Parameters .. complex(kind=real64) :: one parameter (one= (1.0d+0,0.0d+0)) complex(kind=real64) :: zero parameter (zero= (0.0d+0,0.0d+0)) ! .. ! .. Local Scalars .. complex(kind=real64) :: temp1,temp2 integer i,info,ix,iy,j,jx,jy,k,kk,kx,ky ! .. ! .. External Functions .. ! LOGICAL LSAME ! EXTERNAL LSAME ! .. ! .. External Subroutines .. ! EXTERNAL XERBLA ! .. ! .. Intrinsic Functions .. intrinsic dble,dconjg ! .. ! ! Test the input parameters. ! info = 0 if (.not.lsame(uplo,'U') .and. .not.lsame(uplo,'L')) then info = 1 elseif (n.lt.0) then info = 2 elseif (incx.eq.0) then info = 6 elseif (incy.eq.0) then info = 9 endif if (info.ne.0) then call xerbla('ZHPMV ',info) return endif ! ! Quick return if possible. ! if ((n.eq.0) .or. ((alpha.eq.zero).and. (beta.eq.one))) return ! ! Set up the start points in X and Y. ! if (incx.gt.0) then kx = 1 else kx = 1 - (n-1)*incx endif if (incy.gt.0) then ky = 1 else ky = 1 - (n-1)*incy endif ! ! 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.ne.one) then if (incy.eq.1) then if (beta.eq.zero) then y(1:n) = zero else y(1:n) = beta*y(1:n) endif else iy = ky if (beta.eq.zero) then do i = 1,n y(iy) = zero iy = iy + incy enddo else do i = 1,n y(iy) = beta*y(iy) iy = iy + incy enddo endif endif endif if (alpha.eq.zero) return kk = 1 if (lsame(uplo,'U')) then ! ! Form y when AP contains the upper triangle. ! if ((incx.eq.1) .and. (incy.eq.1)) then do j = 1,n temp1 = alpha*x(j) temp2 = zero k = kk do i = 1,j - 1 y(i) = y(i) + temp1*ap(k) temp2 = temp2 + dconjg(ap(k))*x(i) k = k + 1 enddo y(j) = y(j) + temp1*dble(ap(kk+j-1)) + alpha*temp2 kk = kk + j enddo else jx = kx jy = ky do j = 1,n temp1 = alpha*x(jx) temp2 = zero ix = kx iy = ky do k = kk,kk + j - 2 y(iy) = y(iy) + temp1*ap(k) temp2 = temp2 + dconjg(ap(k))*x(ix) ix = ix + incx iy = iy + incy enddo y(jy) = y(jy) + temp1*dble(ap(kk+j-1)) + alpha*temp2 jx = jx + incx jy = jy + incy kk = kk + j enddo endif else ! ! Form y when AP contains the lower triangle. ! if ((incx.eq.1) .and. (incy.eq.1)) then do j = 1,n temp1 = alpha*x(j) temp2 = zero y(j) = y(j) + temp1*dble(ap(kk)) k = kk + 1 do i = j + 1,n y(i) = y(i) + temp1*ap(k) temp2 = temp2 + dconjg(ap(k))*x(i) k = k + 1 enddo y(j) = y(j) + alpha*temp2 kk = kk + (n-j+1) enddo else jx = kx jy = ky do j = 1,n temp1 = alpha*x(jx) temp2 = zero y(jy) = y(jy) + temp1*dble(ap(kk)) ix = jx iy = jy do k = kk + 1,kk + n - j ix = ix + incx iy = iy + incy y(iy) = y(iy) + temp1*ap(k) temp2 = temp2 + dconjg(ap(k))*x(ix) enddo y(jy) = y(jy) + alpha*temp2 jx = jx + incx jy = jy + incy kk = kk + (n-j+1) enddo endif endif end subroutine zhpmv !> !!##NAME !! zhpr2(3f) - [BLAS:COMPLEX_16_BLAS_LEVEL2] !! !!##SYNOPSIS !! !! subroutine zhpr2(uplo,n,alpha,x,incx,y,incy,ap) !! !! .. Scalar Arguments .. !! complex(kind=real64),intent(in) :: alpha !! integer,intent(in) :: incx,incy,n !! character,intent(in) :: uplo !! .. !! .. Array Arguments .. !! complex(kind=real64),intent(in) :: x(*),y(*) !! complex(kind=real64),intent(inout) :: ap(*) !! .. !! !!##DEFINITION !! !! ZHPR2 performs the hermitian rank 2 operation !! !! A := alpha*x*y**H + conjg( alpha )*y*x**H + A, !! !! where alpha is a scalar, x and y are n element vectors and A is an !! n by n hermitian matrix, supplied in packed form. !! !!##OPTIONS !! !! UPLO !! !! UPLO is 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. !! !! N !! !! N is INTEGER !! On entry, N specifies the order of the matrix A. !! N must be at least zero. !! !! ALPHA !! !! ALPHA is complex(kind=real64) !! On entry, ALPHA specifies the scalar alpha. !! !! X !! !! X is complex(kind=real64) array, dimension at least !! ( 1 + ( n - 1 )*abs( INCX ) ). !! Before entry, the incremented array X must contain the n !! element vector x. !! !! INCX !! !! INCX is INTEGER !! On entry, INCX specifies the increment for the elements of !! X. INCX must not be zero. !! !! Y !! !! Y is complex(kind=real64) array, dimension at least !! ( 1 + ( n - 1 )*abs( INCY ) ). !! Before entry, the incremented array Y must contain the n !! element vector y. !! !! INCY !! !! INCY is INTEGER !! On entry, INCY specifies the increment for the elements of !! Y. INCY must not be zero. !! !! AP !! !! AP is complex(kind=real64) array, 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 hermitian 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 hermitian 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. !! Note that the imaginary parts of the diagonal elements need !! not be set, they are assumed to be zero, and on exit they !! are set to zero. !! !!##AUTHORS !! !! + Univ. of Tennessee !! + Univ. of California Berkeley !! + Univ. of Colorado Denver !! + NAG Ltd. !! !! date:December 2016 !! !! FURTHER DETAILS !! !! 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. !! !!##SEE ALSO !! Online html documentation available at !! http://www.netlib.org/lapack/explore-html/ ! ===================================================================== subroutine zhpr2(uplo,n,alpha,x,incx,y,incy,ap) implicit none ! ! -- Reference BLAS level2 routine (version 3.7.0) -- ! -- Reference BLAS is a software package provided by Univ. of Tennessee, -- ! -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- ! December 2016 ! ! .. Scalar Arguments .. complex(kind=real64),intent(in) :: alpha integer,intent(in) :: incx,incy,n character,intent(in) :: uplo ! .. ! .. Array Arguments .. complex(kind=real64),intent(in) :: x(*),y(*) complex(kind=real64),intent(inout) :: ap(*) ! .. ! ! ===================================================================== ! ! .. Parameters .. complex(kind=real64) :: zero parameter (zero= (0.0d+0,0.0d+0)) ! .. ! .. Local Scalars .. complex(kind=real64) :: temp1,temp2 integer i,info,ix,iy,j,jx,jy,k,kk,kx,ky ! .. ! .. External Functions .. ! LOGICAL LSAME ! EXTERNAL LSAME ! .. ! .. External Subroutines .. ! EXTERNAL XERBLA ! .. ! .. Intrinsic Functions .. intrinsic dble,dconjg ! .. ! ! Test the input parameters. ! info = 0 if (.not.lsame(uplo,'U') .and. .not.lsame(uplo,'L')) then info = 1 elseif (n.lt.0) then info = 2 elseif (incx.eq.0) then info = 5 elseif (incy.eq.0) then info = 7 endif if (info.ne.0) then call xerbla('ZHPR2 ',info) return endif ! ! Quick return if possible. ! if ((n.eq.0) .or. (alpha.eq.zero)) return ! ! Set up the start points in X and Y if the increments are not both ! unity. ! if ((incx.ne.1) .or. (incy.ne.1)) then if (incx.gt.0) then kx = 1 else kx = 1 - (n-1)*incx endif if (incy.gt.0) then ky = 1 else ky = 1 - (n-1)*incy endif jx = kx jy = ky endif ! ! 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')) then ! ! Form A when upper triangle is stored in AP. ! if ((incx.eq.1) .and. (incy.eq.1)) then do j = 1,n if ((x(j).ne.zero) .or. (y(j).ne.zero)) then temp1 = alpha*dconjg(y(j)) temp2 = dconjg(alpha*x(j)) k = kk do i = 1,j - 1 ap(k) = ap(k) + x(i)*temp1 + y(i)*temp2 k = k + 1 enddo ap(kk+j-1) = dble(ap(kk+j-1)) + dble(x(j)*temp1+y(j)*temp2) else ap(kk+j-1) = dble(ap(kk+j-1)) endif kk = kk + j enddo else do j = 1,n if ((x(jx).ne.zero) .or. (y(jy).ne.zero)) then temp1 = alpha*dconjg(y(jy)) temp2 = dconjg(alpha*x(jx)) ix = kx iy = ky do k = kk,kk + j - 2 ap(k) = ap(k) + x(ix)*temp1 + y(iy)*temp2 ix = ix + incx iy = iy + incy enddo ap(kk+j-1) = dble(ap(kk+j-1)) + dble(x(jx)*temp1+y(jy)*temp2) else ap(kk+j-1) = dble(ap(kk+j-1)) endif jx = jx + incx jy = jy + incy kk = kk + j enddo endif else ! ! Form A when lower triangle is stored in AP. ! if ((incx.eq.1) .and. (incy.eq.1)) then do j = 1,n if ((x(j).ne.zero) .or. (y(j).ne.zero)) then temp1 = alpha*dconjg(y(j)) temp2 = dconjg(alpha*x(j)) ap(kk) = dble(ap(kk)) + dble(x(j)*temp1+y(j)*temp2) k = kk + 1 do i = j + 1,n ap(k) = ap(k) + x(i)*temp1 + y(i)*temp2 k = k + 1 enddo else ap(kk) = dble(ap(kk)) endif kk = kk + n - j + 1 enddo else do j = 1,n if ((x(jx).ne.zero) .or. (y(jy).ne.zero)) then temp1 = alpha*dconjg(y(jy)) temp2 = dconjg(alpha*x(jx)) ap(kk) = dble(ap(kk)) + dble(x(jx)*temp1+y(jy)*temp2) ix = jx iy = jy do k = kk + 1,kk + n - j ix = ix + incx iy = iy + incy ap(k) = ap(k) + x(ix)*temp1 + y(iy)*temp2 enddo else ap(kk) = dble(ap(kk)) endif jx = jx + incx jy = jy + incy kk = kk + n - j + 1 enddo endif endif end subroutine zhpr2 !> !!##NAME !! zhpr(3f) - [BLAS:COMPLEX_16_BLAS_LEVEL2] !! !!##SYNOPSIS !! !! subroutine zhpr(uplo,n,alpha,x,incx,ap) !! !! .. Scalar Arguments .. !! double precision ,intent(in) :: alpha !! integer ,intent(in) :: incx,n !! character,intent(in) :: uplo !! .. !! .. Array Arguments .. !! complex(kind=real64),intent(in) :: x(*) !! complex(kind=real64),intent(inout) :: ap(*) !! .. !! !!##DEFINITION !! !! ZHPR performs the hermitian rank 1 operation !! !! A := alpha*x*x**H + A, !! !! where alpha is a real scalar, x is an n element vector and A is an !! n by n hermitian matrix, supplied in packed form. !! !!##OPTIONS !! !! UPLO !! !! UPLO is 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. !! !! N !! !! N is INTEGER !! On entry, N specifies the order of the matrix A. !! N must be at least zero. !! !! ALPHA !! !! ALPHA is DOUBLE PRECISION. !! On entry, ALPHA specifies the scalar alpha. !! !! X !! !! X is complex(kind=real64) array, dimension at least !! ( 1 + ( n - 1 )*abs( INCX ) ). !! Before entry, the incremented array X must contain the n !! element vector x. !! !! INCX !! !! INCX is INTEGER !! On entry, INCX specifies the increment for the elements of !! X. INCX must not be zero. !! !! AP !! !! AP is complex(kind=real64) array, 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 hermitian 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 hermitian 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. !! Note that the imaginary parts of the diagonal elements need !! not be set, they are assumed to be zero, and on exit they !! are set to zero. !! !!##AUTHORS !! !! + Univ. of Tennessee !! + Univ. of California Berkeley !! + Univ. of Colorado Denver !! + NAG Ltd. !! !! date:December 2016 !! !! FURTHER DETAILS !! !! 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. !! !!##SEE ALSO !! Online html documentation available at !! http://www.netlib.org/lapack/explore-html/ ! ===================================================================== subroutine zhpr(uplo,n,alpha,x,incx,ap) implicit none ! ! -- Reference BLAS level2 routine (version 3.7.0) -- ! -- Reference BLAS is a software package provided by Univ. of Tennessee, -- ! -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- ! December 2016 ! ! .. Scalar Arguments .. double precision ,intent(in) :: alpha integer ,intent(in) :: incx,n character,intent(in) :: uplo ! .. ! .. Array Arguments .. complex(kind=real64),intent(in) :: x(*) complex(kind=real64),intent(inout) :: ap(*) ! .. ! ! ===================================================================== ! ! .. Parameters .. complex(kind=real64) :: zero parameter (zero= (0.0d+0,0.0d+0)) ! .. ! .. Local Scalars .. complex(kind=real64) :: temp integer i,info,ix,j,jx,k,kk,kx ! .. ! .. External Functions .. ! LOGICAL LSAME ! EXTERNAL LSAME ! .. ! .. External Subroutines .. ! EXTERNAL XERBLA ! .. ! .. Intrinsic Functions .. intrinsic dble,dconjg ! .. ! ! Test the input parameters. ! info = 0 if (.not.lsame(uplo,'U') .and. .not.lsame(uplo,'L')) then info = 1 elseif (n.lt.0) then info = 2 elseif (incx.eq.0) then info = 5 endif if (info.ne.0) then call xerbla('ZHPR ',info) return endif ! ! Quick return if possible. ! if ((n.eq.0) .or. (alpha.eq.dble(zero))) return ! ! Set the start point in X if the increment is not unity. ! if (incx.le.0) then kx = 1 - (n-1)*incx elseif (incx.ne.1) then kx = 1 endif ! ! 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')) then ! ! Form A when upper triangle is stored in AP. ! if (incx.eq.1) then do j = 1,n if (x(j).ne.zero) then temp = alpha*dconjg(x(j)) k = kk do i = 1,j - 1 ap(k) = ap(k) + x(i)*temp k = k + 1 enddo ap(kk+j-1) = dble(ap(kk+j-1)) + dble(x(j)*temp) else ap(kk+j-1) = dble(ap(kk+j-1)) endif kk = kk + j enddo else jx = kx do j = 1,n if (x(jx).ne.zero) then temp = alpha*dconjg(x(jx)) ix = kx do k = kk,kk + j - 2 ap(k) = ap(k) + x(ix)*temp ix = ix + incx enddo ap(kk+j-1) = dble(ap(kk+j-1)) + dble(x(jx)*temp) else ap(kk+j-1) = dble(ap(kk+j-1)) endif jx = jx + incx kk = kk + j enddo endif else ! ! Form A when lower triangle is stored in AP. ! if (incx.eq.1) then do j = 1,n if (x(j).ne.zero) then temp = alpha*dconjg(x(j)) ap(kk) = dble(ap(kk)) + dble(temp*x(j)) k = kk + 1 do i = j + 1,n ap(k) = ap(k) + x(i)*temp k = k + 1 enddo else ap(kk) = dble(ap(kk)) endif kk = kk + n - j + 1 enddo else jx = kx do j = 1,n if (x(jx).ne.zero) then temp = alpha*dconjg(x(jx)) ap(kk) = dble(ap(kk)) + dble(temp*x(jx)) ix = jx do k = kk + 1,kk + n - j ix = ix + incx ap(k) = ap(k) + x(ix)*temp enddo else ap(kk) = dble(ap(kk)) endif jx = jx + incx kk = kk + n - j + 1 enddo endif endif end subroutine zhpr !> !!##NAME !! zrotg(3f) - [BLAS:COMPLEX16_BLAS_LEVEL1] constructs a plane rotation !! !!##SYNOPSIS !! !! subroutine zrotg( a, b, c, s ) !! !! .. Scalar Arguments .. !! real(wp),intent(out) :: c !! complex(wp),intent(in) :: b !! complex(wp),intent(out) :: s !! complex(wp),intent(inout) :: a !! .. !! !!##DEFINITION !! ZROTG constructs a plane rotation !! !! [ c s ] [ a ] = [ r ] !! [ -conjg(s) c ] [ b ] [ 0 ] !! !! where c is real, s ic complex, and c**2 + conjg(s)*s = 1. !! !! The computation uses the formulas !! !! |x| = sqrt( Re(x)**2 + Im(x)**2 ) !! sgn(x) = x / |x| if x /= 0 !! = 1 if x = 0 !! c = |a| / sqrt(|a|**2 + |b|**2) !! s = sgn(a) * conjg(b) / sqrt(|a|**2 + |b|**2) !! !! When a and b are real and r /= 0, the formulas simplify to !! !! r = sgn(a)*sqrt(|a|**2 + |b|**2) !! c = a / r !! s = b / r !! !! the same as in ZROTG when |a| > |b|. When |b| >= |a|, the !! sign of c and s will be different from those computed by ZROTG !! if the signs of a and b are not the same. !! !!##OPTIONS !! !! A !! !! A is DOUBLE COMPLEX !! On entry, the scalar a. !! On exit, the scalar r. !! !! B !! !! B is DOUBLE COMPLEX !! The scalar b. !! !! C !! !! C is DOUBLE PRECISION !! The scalar c. !! !! S !! !! S is DOUBLE PRECISION !! The scalar s. !! !!##AUTHORS !! !! + Edward Anderson, Lockheed Martin !! !! \par Contributors: !! !! Weslley Pereira, University of Colorado Denver, USA !! !! FURTHER DETAILS !! !! Anderson E. (2017) !! Algorithm 978: Safe Scaling in the Level 1 BLAS !! ACM Trans Math Softw 44:1--28 !! https://doi.org/10.1145/3061665 !! !!##SEE ALSO !! Online html documentation available at !! http://www.netlib.org/lapack/explore-html/ ! ===================================================================== subroutine zrotg( a, b, c, s ) integer, parameter :: wp = kind(1.d0) ! ! -- Reference BLAS level1 routine -- ! -- Reference BLAS is a software package provided by Univ. of Tennessee, -- ! -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- ! ! .. Constants .. real(wp), parameter :: zero = 0.0_wp real(wp), parameter :: one = 1.0_wp complex(wp), parameter :: czero = 0.0_wp ! .. ! .. Scaling constants .. real(wp), parameter :: safmin = real(radix(0._wp),wp)**max( minexponent(0._wp)-1, 1-maxexponent(0._wp) ) real(wp), parameter :: safmax = real(radix(0._wp),wp)**max( 1-minexponent(0._wp), maxexponent(0._wp)-1 ) real(wp), parameter :: rtmin = sqrt(real(radix(0._wp),wp)**max( minexponent(0._wp)-1, 1-maxexponent(0._wp) ) / epsilon(0._wp) ) real(wp), parameter :: rtmax = sqrt(real(radix(0._wp),wp)**max( 1-minexponent(0._wp), maxexponent(0._wp)-1 ) * epsilon(0._wp) ) ! .. ! .. Scalar Arguments .. real(wp),intent(out) :: c complex(wp),intent(in) :: b complex(wp),intent(out) :: s complex(wp),intent(inout) :: a ! .. ! .. Local Scalars .. real(wp) :: d, f1, f2, g1, g2, h2, p, u, uu, v, vv, w complex(wp) :: f, fs, g, gs, r, t ! .. ! .. Intrinsic Functions .. intrinsic :: abs, aimag, conjg, max, min, real, sqrt ! .. ! .. Statement Functions .. real(wp) :: abssq ! .. ! .. Statement Function definitions .. abssq( t ) = real( t )**2 + aimag( t )**2 ! .. ! .. Executable Statements .. ! f = a g = b if( g == czero ) then c = one s = czero r = f elseif ( f == czero ) then c = zero g1 = max( abs(real(g)), abs(aimag(g)) ) if( g1 > rtmin .and. g1 < rtmax ) then ! ! Use unscaled algorithm ! g2 = abssq( g ) d = sqrt( g2 ) s = conjg( g ) / d r = d else ! ! Use scaled algorithm ! u = min( safmax, max( safmin, g1 ) ) uu = one / u gs = g*uu g2 = abssq( gs ) d = sqrt( g2 ) s = conjg( gs ) / d r = d*u endif else f1 = max( abs(real(f)), abs(aimag(f)) ) g1 = max( abs(real(g)), abs(aimag(g)) ) if( f1 > rtmin .and. f1 < rtmax .and. & g1 > rtmin .and. g1 < rtmax ) then ! ! Use unscaled algorithm ! f2 = abssq( f ) g2 = abssq( g ) h2 = f2 + g2 if( f2 > rtmin .and. h2 < rtmax ) then d = sqrt( f2*h2 ) else d = sqrt( f2 )*sqrt( h2 ) endif p = 1 / d c = f2*p s = conjg( g )*( f*p ) r = f*( h2*p ) else ! ! Use scaled algorithm ! u = min( safmax, max( safmin, f1, g1 ) ) uu = one / u gs = g*uu g2 = abssq( gs ) if( f1*uu < rtmin ) then ! ! f is not well-scaled when scaled by g1. ! Use a different scaling for f. ! v = min( safmax, max( safmin, f1 ) ) vv = one / v w = v * uu fs = f*vv f2 = abssq( fs ) h2 = f2*w**2 + g2 else ! ! Otherwise use the same scaling for f and g. ! w = one fs = f*uu f2 = abssq( fs ) h2 = f2 + g2 endif if( f2 > rtmin .and. h2 < rtmax ) then d = sqrt( f2*h2 ) else d = sqrt( f2 )*sqrt( h2 ) endif p = 1 / d c = ( f2*p )*w s = conjg( gs )*( fs*p ) r = ( fs*( h2*p ) )*u endif endif a = r return end subroutine !> !!##NAME !! zscal(3f) - [BLAS:COMPLEX16_BLAS_LEVEL1] !! !!##SYNOPSIS !! !! subroutine zscal(n,za,zx,incx) !! !! .. Scalar Arguments .. !! complex(kind=real64),intent(in) :: za !! integer,intent(in) :: incx,n !! .. !! .. Array Arguments .. !! complex(kind=real64),intent(inout) :: zx(*) !! .. !! !!##DEFINITION !! !! ZSCAL scales a vector by a constant. !! !!##OPTIONS !! !! N !! !! N is INTEGER !! number of elements in input vector(s) !! !! ZA !! !! ZA is complex(kind=real64) !! On entry, ZA specifies the scalar alpha. !! !! ZX !! !! ZX is complex(kind=real64) array, dimension ( 1 + ( N - 1 )*abs( INCX ) ) !! !! INCX !! !! INCX is INTEGER !! storage spacing between elements of ZX !! !!##AUTHORS !! !! + Univ. of Tennessee !! + Univ. of California Berkeley !! + Univ. of Colorado Denver !! + NAG Ltd. !! !! date:November 2017 !! !! FURTHER DETAILS !! !! jack dongarra, 3/11/78. !! modified 3/93 to return if incx .le. 0. !! modified 12/3/93, array(1) declarations changed to array(*) !! !!##SEE ALSO !! Online html documentation available at !! http://www.netlib.org/lapack/explore-html/ ! ===================================================================== subroutine zscal(n,za,zx,incx) implicit none ! ! -- Reference BLAS level1 routine (version 3.8.0) -- ! -- Reference BLAS is a software package provided by Univ. of Tennessee, -- ! -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- ! November 2017 ! ! .. Scalar Arguments .. complex(kind=real64),intent(in) :: za integer,intent(in) :: incx,n ! .. ! .. Array Arguments .. complex(kind=real64),intent(inout) :: zx(*) ! .. ! ! ===================================================================== ! ! .. Local Scalars .. integer i,nincx ! .. if (n.le.0 .or. incx.le.0) return if (incx.eq.1) then ! ! code for increment equal to 1 ! do i = 1,n zx(i) = za*zx(i) enddo else ! ! code for increment not equal to 1 ! nincx = n*incx do i = 1,nincx,incx zx(i) = za*zx(i) enddo endif end subroutine zscal !> !!##NAME !! zswap(3f) - [BLAS:COMPLEX16_BLAS_LEVEL1] !! !!##SYNOPSIS !! !! subroutine zswap(n,zx,incx,zy,incy) !! !! .. Scalar Arguments .. !! integer,intent(in) :: incx,incy,n !! .. !! .. Array Arguments .. !! complex(kind=real64),intent(inout) :: zx(*),zy(*) !! .. !! !!##DEFINITION !! !! ZSWAP interchanges two vectors. !! !!##OPTIONS !! !! N !! !! N is INTEGER !! number of elements in input vector(s) !! !! ZX !! !! ZX is complex(kind=real64) array, dimension ( 1 + ( N - 1 )*abs( INCX ) ) !! !! INCX !! !! INCX is INTEGER !! storage spacing between elements of ZX !! !! ZY !! !! ZY is complex(kind=real64) array, dimension ( 1 + ( N - 1 )*abs( INCY ) ) !! !! INCY !! !! INCY is INTEGER !! storage spacing between elements of ZY !! !!##AUTHORS !! !! + Univ. of Tennessee !! + Univ. of California Berkeley !! + Univ. of Colorado Denver !! + NAG Ltd. !! !! date:November 2017 !! !! FURTHER DETAILS !! !! jack dongarra, 3/11/78. !! modified 12/3/93, array(1) declarations changed to array(*) !! !!##SEE ALSO !! Online html documentation available at !! http://www.netlib.org/lapack/explore-html/ ! ===================================================================== subroutine zswap(n,zx,incx,zy,incy) implicit none ! ! -- Reference BLAS level1 routine (version 3.8.0) -- ! -- Reference BLAS is a software package provided by Univ. of Tennessee, -- ! -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- ! November 2017 ! ! .. Scalar Arguments .. integer,intent(in) :: incx,incy,n ! .. ! .. Array Arguments .. complex(kind=real64),intent(inout) :: zx(*),zy(*) ! .. ! ! ===================================================================== ! ! .. Local Scalars .. complex(kind=real64) :: ztemp integer i,ix,iy ! .. if (n.le.0) return if (incx.eq.1 .and. incy.eq.1) then ! ! code for both increments equal to 1 do i = 1,n ztemp = zx(i) zx(i) = zy(i) zy(i) = ztemp enddo else ! ! code for unequal increments or equal increments not equal ! to 1 ! ix = 1 iy = 1 if (incx.lt.0) ix = (-n+1)*incx + 1 if (incy.lt.0) iy = (-n+1)*incy + 1 do i = 1,n ztemp = zx(ix) zx(ix) = zy(iy) zy(iy) = ztemp ix = ix + incx iy = iy + incy enddo endif end subroutine zswap !> !!##NAME !! zsymm(3f) - [BLAS:COMPLEX16_BLAS_LEVEL3] !! !!##SYNOPSIS !! !! subroutine zsymm(side,uplo,m,n,alpha,a,lda,b,ldb,beta,c,ldc) !! !! .. Scalar Arguments .. !! complex(kind=real64),intent(in) :: alpha,beta !! integer,intent(in) :: lda,ldb,ldc,m,n !! character,intent(in) :: side,uplo !! .. !! .. Array Arguments .. !! complex(kind=real64),intent(in) :: a(lda,*),b(ldb,*) !! complex(kind=real64),intent(inout) :: c(ldc,*) !! .. !! !!##DEFINITION !! !! ZSYMM 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. !! !!##OPTIONS !! !! SIDE !! !! SIDE is 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, !! !! UPLO !! !! UPLO is 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. !! !! M !! !! M is INTEGER !! On entry, M specifies the number of rows of the matrix C. !! M must be at least zero. !! !! N !! !! N is INTEGER !! On entry, N specifies the number of columns of the matrix C. !! N must be at least zero. !! !! ALPHA !! !! ALPHA is complex(kind=real64) !! On entry, ALPHA specifies the scalar alpha. !! !! A !! !! A is complex(kind=real64) array, 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. !! !! LDA !! !! LDA is 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 ). !! !! B !! !! B is complex(kind=real64) array, dimension ( LDB, N ) !! Before entry, the leading m by n part of the array B must !! contain the matrix B. !! !! LDB !! !! LDB is 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 ). !! !! BETA !! !! BETA is complex(kind=real64) !! On entry, BETA specifies the scalar beta. When BETA is !! supplied as zero then C need not be set on input. !! !! C !! !! C is complex(kind=real64) array, 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 !! !! LDC is 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 ). !! !!##AUTHORS !! !! + Univ. of Tennessee !! + Univ. of California Berkeley !! + Univ. of Colorado Denver !! + NAG Ltd. !! !! date:December 2016 !! !! FURTHER DETAILS !! !! 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. !! !!##SEE ALSO !! Online html documentation available at !! http://www.netlib.org/lapack/explore-html/ ! ===================================================================== subroutine zsymm(side,uplo,m,n,alpha,a,lda,b,ldb,beta,c,ldc) implicit none ! ! -- Reference BLAS level3 routine (version 3.7.0) -- ! -- Reference BLAS is a software package provided by Univ. of Tennessee, -- ! -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- ! December 2016 ! ! .. Scalar Arguments .. complex(kind=real64),intent(in) :: alpha,beta integer,intent(in) :: lda,ldb,ldc,m,n character,intent(in) :: side,uplo ! .. ! .. Array Arguments .. complex(kind=real64),intent(in) :: a(lda,*),b(ldb,*) complex(kind=real64),intent(inout) :: c(ldc,*) ! .. ! ===================================================================== ! ! .. External Functions .. ! LOGICAL LSAME ! EXTERNAL LSAME ! .. ! .. External Subroutines .. ! EXTERNAL XERBLA ! .. ! .. Intrinsic Functions .. intrinsic max ! .. ! .. Local Scalars .. complex(kind=real64) :: temp1,temp2 integer i,info,j,k,nrowa logical upper ! .. ! .. Parameters .. complex(kind=real64) :: one parameter (one= (1.0d+0,0.0d+0)) complex(kind=real64) :: zero parameter (zero= (0.0d+0,0.0d+0)) ! .. ! ! Set NROWA as the number of rows of A. ! if (lsame(side,'L')) then nrowa = m else nrowa = n endif upper = lsame(uplo,'U') ! ! Test the input parameters. ! info = 0 if ((.not.lsame(side,'L')) .and. (.not.lsame(side,'R'))) then info = 1 elseif ((.not.upper) .and. (.not.lsame(uplo,'L'))) then info = 2 elseif (m.lt.0) then info = 3 elseif (n.lt.0) then info = 4 elseif (lda.lt.max(1,nrowa)) then info = 7 elseif (ldb.lt.max(1,m)) then info = 9 elseif (ldc.lt.max(1,m)) then info = 12 endif if (info.ne.0) then call xerbla('ZSYMM ',info) return endif ! ! Quick return if possible. ! if ((m.eq.0) .or. (n.eq.0) .or. ((alpha.eq.zero).and. (beta.eq.one))) return ! ! And when alpha.eq.zero. ! if (alpha.eq.zero) then if (beta.eq.zero) then c(1:m,1:n) = zero else c(1:m,1:n) = beta*c(1:m,1:n) endif return endif ! ! Start the operations. ! if (lsame(side,'L')) then ! ! Form C := alpha*A*B + beta*C. ! if (upper) then do j = 1,n do i = 1,m temp1 = alpha*b(i,j) temp2 = zero do k = 1,i - 1 c(k,j) = c(k,j) + temp1*a(k,i) temp2 = temp2 + b(k,j)*a(k,i) enddo if (beta.eq.zero) then c(i,j) = temp1*a(i,i) + alpha*temp2 else c(i,j) = beta*c(i,j) + temp1*a(i,i) + alpha*temp2 endif enddo enddo else do j = 1,n do i = m,1,-1 temp1 = alpha*b(i,j) temp2 = zero do k = i + 1,m c(k,j) = c(k,j) + temp1*a(k,i) temp2 = temp2 + b(k,j)*a(k,i) enddo if (beta.eq.zero) then c(i,j) = temp1*a(i,i) + alpha*temp2 else c(i,j) = beta*c(i,j) + temp1*a(i,i) + alpha*temp2 endif enddo enddo endif else ! ! Form C := alpha*B*A + beta*C. ! do j = 1,n temp1 = alpha*a(j,j) if (beta.eq.zero) then c(1:m,j) = temp1*b(1:m,j) else c(1:m,j) = beta*c(1:m,j) + temp1*b(1:m,j) endif do k = 1,j - 1 if (upper) then temp1 = alpha*a(k,j) else temp1 = alpha*a(j,k) endif c(1:m,j) = c(1:m,j) + temp1*b(1:m,k) enddo do k = j + 1,n if (upper) then temp1 = alpha*a(j,k) else temp1 = alpha*a(k,j) endif c(1:m,j) = c(1:m,j) + temp1*b(1:m,k) enddo enddo endif end subroutine zsymm !> !!##NAME !! zsyr2k(3f) - [BLAS:COMPLEX16_BLAS_LEVEL3] !! !!##SYNOPSIS !! !! subroutine zsyr2k(uplo,trans,n,k,alpha,a,lda,b,ldb,beta,c,ldc) !! !! .. Scalar Arguments .. !! complex(kind=real64),intent(in) :: alpha,beta !! integer,intent(in) :: k,lda,ldb,ldc,n !! character,intent(in) :: trans,uplo !! .. !! .. Array Arguments .. !! complex(kind=real64),intent(in) :: a(lda,*),b(ldb,*) !! complex(kind=real64),intent(inout) :: c(ldc,*) !! .. !! !!##DEFINITION !! !! ZSYR2K performs one of the symmetric rank 2k operations !! !! C := alpha*A*B**T + alpha*B*A**T + beta*C, !! !! or !! !! C := alpha*A**T*B + alpha*B**T*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. !! !!##OPTIONS !! !! UPLO !! !! UPLO is 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. !! !! TRANS !! !! TRANS is CHARACTER*1 !! On entry, TRANS specifies the operation to be performed as !! follows: !! !! TRANS = 'N' or 'n' C := alpha*A*B**T + alpha*B*A**T + !! beta*C. !! !! TRANS = 'T' or 't' C := alpha*A**T*B + alpha*B**T*A + !! beta*C. !! !! N !! !! N is INTEGER !! On entry, N specifies the order of the matrix C. N must be !! at least zero. !! !! K !! !! K is 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', K specifies the number of rows of the !! matrices A and B. K must be at least zero. !! !! ALPHA !! !! ALPHA is complex(kind=real64) !! On entry, ALPHA specifies the scalar alpha. !! !! A !! !! A is complex(kind=real64) array, 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. !! !! LDA !! !! LDA is 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 ). !! !! B !! !! B is complex(kind=real64) array, 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. !! !! LDB !! !! LDB is 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 ). !! !! BETA !! !! BETA is complex(kind=real64) !! On entry, BETA specifies the scalar beta. !! !! C !! !! C is complex(kind=real64) array, 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 !! !! LDC is 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 ). !! !!##AUTHORS !! !! + Univ. of Tennessee !! + Univ. of California Berkeley !! + Univ. of Colorado Denver !! + NAG Ltd. !! !! date:December 2016 !! !! FURTHER DETAILS !! !! 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. !! !!##SEE ALSO !! Online html documentation available at !! http://www.netlib.org/lapack/explore-html/ ! ===================================================================== subroutine zsyr2k(uplo,trans,n,k,alpha,a,lda,b,ldb,beta,c,ldc) implicit none ! ! -- Reference BLAS level3 routine (version 3.7.0) -- ! -- Reference BLAS is a software package provided by Univ. of Tennessee, -- ! -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- ! December 2016 ! ! .. Scalar Arguments .. complex(kind=real64),intent(in) :: alpha,beta integer,intent(in) :: k,lda,ldb,ldc,n character,intent(in) :: trans,uplo ! .. ! .. Array Arguments .. complex(kind=real64),intent(in) :: a(lda,*),b(ldb,*) complex(kind=real64),intent(inout) :: c(ldc,*) ! .. ! ! ===================================================================== ! ! .. External Functions .. ! LOGICAL LSAME ! EXTERNAL LSAME ! .. ! .. External Subroutines .. ! EXTERNAL XERBLA ! .. ! .. Intrinsic Functions .. intrinsic max ! .. ! .. Local Scalars .. complex(kind=real64) :: temp1,temp2 integer i,info,j,l,nrowa logical upper ! .. ! .. Parameters .. complex(kind=real64) :: one parameter (one= (1.0d+0,0.0d+0)) complex(kind=real64) :: zero parameter (zero= (0.0d+0,0.0d+0)) ! .. ! ! Test the input parameters. ! if (lsame(trans,'N')) then nrowa = n else nrowa = k endif upper = lsame(uplo,'U') ! info = 0 if ((.not.upper) .and. (.not.lsame(uplo,'L'))) then info = 1 elseif ((.not.lsame(trans,'N')) .and. (.not.lsame(trans,'T'))) then info = 2 elseif (n.lt.0) then info = 3 elseif (k.lt.0) then info = 4 elseif (lda.lt.max(1,nrowa)) then info = 7 elseif (ldb.lt.max(1,nrowa)) then info = 9 elseif (ldc.lt.max(1,n)) then info = 12 endif if (info.ne.0) then call xerbla('ZSYR2K',info) return endif ! ! Quick return if possible. ! if ((n.eq.0) .or. (((alpha.eq.zero).or. (k.eq.0)).and. (beta.eq.one))) return ! ! And when alpha.eq.zero. ! if (alpha.eq.zero) then if (upper) then if (beta.eq.zero) then do j = 1,n c(1:j,j) = zero enddo else do j = 1,n c(1:j,j) = beta*c(1:j,j) enddo endif else if (beta.eq.zero) then do j = 1,n c(j:n,j) = zero enddo else do j = 1,n c(j:n,j) = beta*c(j:n,j) enddo endif endif return endif ! ! Start the operations. ! if (lsame(trans,'N')) then ! ! Form C := alpha*A*B**T + alpha*B*A**T + C. ! if (upper) then do j = 1,n if (beta.eq.zero) then c(1:j,j) = zero elseif (beta.ne.one) then c(1:j,j) = beta*c(1:j,j) endif do l = 1,k if ((a(j,l).ne.zero) .or. (b(j,l).ne.zero)) then temp1 = alpha*b(j,l) temp2 = alpha*a(j,l) c(1:j,j) = c(1:j,j) + a(1:j,l)*temp1 + b(1:j,l)*temp2 endif enddo enddo else do j = 1,n if (beta.eq.zero) then c(j:n,j) = zero elseif (beta.ne.one) then c(j:n,j) = beta*c(j:n,j) endif do l = 1,k if ((a(j,l).ne.zero) .or. (b(j,l).ne.zero)) then temp1 = alpha*b(j,l) temp2 = alpha*a(j,l) c(j:n,j) = c(j:n,j) + a(j:n,l)*temp1 + b(j:n,l)*temp2 endif enddo enddo endif else ! ! Form C := alpha*A**T*B + alpha*B**T*A + C. ! if (upper) then do j = 1,n do i = 1,j temp1 = zero temp2 = zero do l = 1,k temp1 = temp1 + a(l,i)*b(l,j) temp2 = temp2 + b(l,i)*a(l,j) enddo if (beta.eq.zero) then c(i,j) = alpha*temp1 + alpha*temp2 else c(i,j) = beta*c(i,j) + alpha*temp1 + alpha*temp2 endif enddo enddo else do j = 1,n do i = j,n temp1 = zero temp2 = zero do l = 1,k temp1 = temp1 + a(l,i)*b(l,j) temp2 = temp2 + b(l,i)*a(l,j) enddo if (beta.eq.zero) then c(i,j) = alpha*temp1 + alpha*temp2 else c(i,j) = beta*c(i,j) + alpha*temp1 + alpha*temp2 endif enddo enddo endif endif end subroutine zsyr2k !> !!##NAME !! zsyrk(3f) - [BLAS:COMPLEX16_BLAS_LEVEL3] !! !!##SYNOPSIS !! !! subroutine zsyrk(uplo,trans,n,k,alpha,a,lda,beta,c,ldc) !! !! .. Scalar Arguments .. !! complex(kind=real64),intent(inout) :: alpha,beta !! integer,intent(in) :: k,lda,ldc,n !! character,intent(in) :: trans,uplo !! .. !! .. Array Arguments .. !! complex(kind=real64),intent(in) :: a(lda,*) !! complex(kind=real64),intent(inout) :: c(ldc,*) !! .. !! !!##DEFINITION !! !! ZSYRK performs one of the symmetric rank k operations !! !! C := alpha*A*A**T + beta*C, !! !! or !! !! C := alpha*A**T*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. !! !!##OPTIONS !! !! UPLO !! !! UPLO is 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. !! !! TRANS !! !! TRANS is CHARACTER*1 !! On entry, TRANS specifies the operation to be performed as !! follows: !! !! TRANS = 'N' or 'n' C := alpha*A*A**T + beta*C. !! !! TRANS = 'T' or 't' C := alpha*A**T*A + beta*C. !! !! N !! !! N is INTEGER !! On entry, N specifies the order of the matrix C. N must be !! at least zero. !! !! K !! !! K is 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. !! !! ALPHA !! !! ALPHA is complex(kind=real64) !! On entry, ALPHA specifies the scalar alpha. !! !! A !! !! A is complex(kind=real64) array, 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. !! !! LDA !! !! LDA is 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 ). !! !! BETA !! !! BETA is complex(kind=real64) !! On entry, BETA specifies the scalar beta. !! !! C !! !! C is complex(kind=real64) array, 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 !! !! LDC is 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 ). !! !!##AUTHORS !! !! + Univ. of Tennessee !! + Univ. of California Berkeley !! + Univ. of Colorado Denver !! + NAG Ltd. !! !! date:December 2016 !! !! FURTHER DETAILS !! !! 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. !! !!##SEE ALSO !! Online html documentation available at !! http://www.netlib.org/lapack/explore-html/ ! ===================================================================== subroutine zsyrk(uplo,trans,n,k,alpha,a,lda,beta,c,ldc) implicit none ! ! -- Reference BLAS level3 routine (version 3.7.0) -- ! -- Reference BLAS is a software package provided by Univ. of Tennessee, -- ! -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- ! December 2016 ! ! .. Scalar Arguments .. complex(kind=real64),intent(inout) :: alpha,beta integer,intent(in) :: k,lda,ldc,n character,intent(in) :: trans,uplo ! .. ! .. Array Arguments .. complex(kind=real64),intent(in) :: a(lda,*) complex(kind=real64),intent(inout) :: c(ldc,*) ! .. ! ! ===================================================================== ! ! .. External Functions .. ! LOGICAL LSAME ! EXTERNAL LSAME ! .. ! .. External Subroutines .. ! EXTERNAL XERBLA ! .. ! .. Intrinsic Functions .. intrinsic max ! .. ! .. Local Scalars .. complex(kind=real64) :: temp integer i,info,j,l,nrowa logical upper ! .. ! .. Parameters .. complex(kind=real64) :: one parameter (one= (1.0d+0,0.0d+0)) complex(kind=real64) :: zero parameter (zero= (0.0d+0,0.0d+0)) ! .. ! ! Test the input parameters. ! if (lsame(trans,'N')) then nrowa = n else nrowa = k endif upper = lsame(uplo,'U') ! info = 0 if ((.not.upper) .and. (.not.lsame(uplo,'L'))) then info = 1 elseif ((.not.lsame(trans,'N')) .and. (.not.lsame(trans,'T'))) then info = 2 elseif (n.lt.0) then info = 3 elseif (k.lt.0) then info = 4 elseif (lda.lt.max(1,nrowa)) then info = 7 elseif (ldc.lt.max(1,n)) then info = 10 endif if (info.ne.0) then call xerbla('ZSYRK ',info) return endif ! ! Quick return if possible. ! if ((n.eq.0) .or. (((alpha.eq.zero).or. (k.eq.0)).and. (beta.eq.one))) return ! ! And when alpha.eq.zero. ! if (alpha.eq.zero) then if (upper) then if (beta.eq.zero) then do j = 1,n c(1:j,j) = zero enddo else do j = 1,n c(1:j,j) = beta*c(1:j,j) enddo endif else if (beta.eq.zero) then do j = 1,n c(j:n,j) = zero enddo else do j = 1,n c(j:n,j) = beta*c(j:n,j) enddo endif endif return endif ! ! Start the operations. ! if (lsame(trans,'N')) then ! ! Form C := alpha*A*A**T + beta*C. ! if (upper) then do j = 1,n if (beta.eq.zero) then c(1:j,j) = zero elseif (beta.ne.one) then c(1:j,j) = beta*c(1:j,j) endif do l = 1,k if (a(j,l).ne.zero) then temp = alpha*a(j,l) c(1:j,j) = c(1:j,j) + temp*a(1:j,l) endif enddo enddo else do j = 1,n if (beta.eq.zero) then c(j:n,j) = zero elseif (beta.ne.one) then c(j:n,j) = beta*c(j:n,j) endif do l = 1,k if (a(j,l).ne.zero) then temp = alpha*a(j,l) c(j:n,j) = c(j:n,j) + temp*a(j:n,l) endif enddo enddo endif else ! ! Form C := alpha*A**T*A + beta*C. ! if (upper) then do j = 1,n do i = 1,j temp = zero do l = 1,k temp = temp + a(l,i)*a(l,j) enddo if (beta.eq.zero) then c(i,j) = alpha*temp else c(i,j) = alpha*temp + beta*c(i,j) endif enddo enddo else do j = 1,n do i = j,n temp = zero do l = 1,k temp = temp + a(l,i)*a(l,j) enddo if (beta.eq.zero) then c(i,j) = alpha*temp else c(i,j) = alpha*temp + beta*c(i,j) endif enddo enddo endif endif end subroutine zsyrk !> !!##NAME !! ztbmv(3f) - [BLAS:COMPLEX_16_BLAS_LEVEL2] !! !!##SYNOPSIS !! !! subroutine ztbmv(uplo,trans,diag,n,k,a,lda,x,incx) !! !! .. Scalar Arguments .. !! integer,intent(in) :: incx,k,lda,n !! character,intent(in) :: diag,trans,uplo !! .. !! .. Array Arguments .. !! complex(kind=real64),intent(in) :: a(lda,*) !! complex(kind=real64),intent(inout) :: x(*) !! .. !! !!##DEFINITION !! !! ZTBMV performs one of the matrix-vector operations !! !! x := A*x, or x := A**T*x, or x := A**H*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. !! !!##OPTIONS !! !! UPLO !! !! UPLO is 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. !! !! TRANS !! !! TRANS is 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**T*x. !! !! TRANS = 'C' or 'c' x := A**H*x. !! !! DIAG !! !! DIAG is 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. !! !! N !! !! N is INTEGER !! On entry, N specifies the order of the matrix A. !! N must be at least zero. !! !! K !! !! K is 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. !! !! A !! !! A is complex(kind=real64) array, 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. !! !! LDA !! !! LDA is INTEGER !! On entry, LDA specifies the first dimension of A as declared !! in the calling (sub) program. LDA must be at least !! ( k + 1 ). !! !! X !! !! X is complex(kind=real64) array, 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 !! transformed vector x. !! !! INCX !! !! INCX is INTEGER !! On entry, INCX specifies the increment for the elements of !! X. INCX must not be zero. !! !!##AUTHORS !! !! + Univ. of Tennessee !! + Univ. of California Berkeley !! + Univ. of Colorado Denver !! + NAG Ltd. !! !! date:December 2016 !! !! FURTHER DETAILS !! !! Level 2 Blas routine. !! The vector and matrix arguments are not referenced when N = 0, or M = 0 !! !! -- 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. !! !!##SEE ALSO !! Online html documentation available at !! http://www.netlib.org/lapack/explore-html/ ! ===================================================================== subroutine ztbmv(uplo,trans,diag,n,k,a,lda,x,incx) implicit none ! ! -- Reference BLAS level2 routine (version 3.7.0) -- ! -- Reference BLAS is a software package provided by Univ. of Tennessee, -- ! -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- ! December 2016 ! ! .. Scalar Arguments .. integer,intent(in) :: incx,k,lda,n character,intent(in) :: diag,trans,uplo ! .. ! .. Array Arguments .. complex(kind=real64),intent(in) :: a(lda,*) complex(kind=real64),intent(inout) :: x(*) ! .. ! ! ===================================================================== ! ! .. Parameters .. complex(kind=real64) :: zero parameter (zero= (0.0d+0,0.0d+0)) ! .. ! .. Local Scalars .. complex(kind=real64) :: temp integer i,info,ix,j,jx,kplus1,kx,l logical noconj,nounit ! .. ! .. External Functions .. ! LOGICAL LSAME ! EXTERNAL LSAME ! .. ! .. External Subroutines .. ! EXTERNAL XERBLA ! .. ! .. Intrinsic Functions .. intrinsic dconjg,max,min ! .. ! ! Test the input parameters. ! info = 0 if (.not.lsame(uplo,'U') .and. .not.lsame(uplo,'L')) then info = 1 elseif (.not.lsame(trans,'N') .and. .not.lsame(trans,'T') .and. .not.lsame(trans,'C')) then info = 2 elseif (.not.lsame(diag,'U') .and. .not.lsame(diag,'N')) then info = 3 elseif (n.lt.0) then info = 4 elseif (k.lt.0) then info = 5 elseif (lda.lt. (k+1)) then info = 7 elseif (incx.eq.0) then info = 9 endif if (info.ne.0) then call xerbla('ZTBMV ',info) return endif ! ! Quick return if possible. ! if (n.eq.0) return ! noconj = lsame(trans,'T') nounit = lsame(diag,'N') ! ! Set up the start point in X if the increment is not unity. This ! will be ( N - 1 )*INCX too small for descending loops. ! if (incx.le.0) then kx = 1 - (n-1)*incx elseif (incx.ne.1) then kx = 1 endif ! ! Start the operations. In this version the elements of A are ! accessed sequentially with one pass through A. ! if (lsame(trans,'N')) then ! ! Form x := A*x. ! if (lsame(uplo,'U')) then kplus1 = k + 1 if (incx.eq.1) then do j = 1,n if (x(j).ne.zero) then temp = x(j) l = kplus1 - j do i = max(1,j-k),j - 1 x(i) = x(i) + temp*a(l+i,j) enddo if (nounit) x(j) = x(j)*a(kplus1,j) endif enddo else jx = kx do j = 1,n if (x(jx).ne.zero) then temp = x(jx) ix = kx l = kplus1 - j do i = max(1,j-k),j - 1 x(ix) = x(ix) + temp*a(l+i,j) ix = ix + incx enddo if (nounit) x(jx) = x(jx)*a(kplus1,j) endif jx = jx + incx if (j.gt.k) kx = kx + incx enddo endif else if (incx.eq.1) then do j = n,1,-1 if (x(j).ne.zero) then temp = x(j) l = 1 - j do i = min(n,j+k),j + 1,-1 x(i) = x(i) + temp*a(l+i,j) enddo if (nounit) x(j) = x(j)*a(1,j) endif enddo else kx = kx + (n-1)*incx jx = kx do j = n,1,-1 if (x(jx).ne.zero) then temp = x(jx) ix = kx l = 1 - j do i = min(n,j+k),j + 1,-1 x(ix) = x(ix) + temp*a(l+i,j) ix = ix - incx enddo if (nounit) x(jx) = x(jx)*a(1,j) endif jx = jx - incx if ((n-j).ge.k) kx = kx - incx enddo endif endif else ! ! Form x := A**T*x or x := A**H*x. ! if (lsame(uplo,'U')) then kplus1 = k + 1 if (incx.eq.1) then do j = n,1,-1 temp = x(j) l = kplus1 - j if (noconj) then if (nounit) temp = temp*a(kplus1,j) do i = j - 1,max(1,j-k),-1 temp = temp + a(l+i,j)*x(i) enddo else if (nounit) temp = temp*dconjg(a(kplus1,j)) do i = j - 1,max(1,j-k),-1 temp = temp + dconjg(a(l+i,j))*x(i) enddo endif x(j) = temp enddo else kx = kx + (n-1)*incx jx = kx do j = n,1,-1 temp = x(jx) kx = kx - incx ix = kx l = kplus1 - j if (noconj) then if (nounit) temp = temp*a(kplus1,j) do i = j - 1,max(1,j-k),-1 temp = temp + a(l+i,j)*x(ix) ix = ix - incx enddo else if (nounit) temp = temp*dconjg(a(kplus1,j)) do i = j - 1,max(1,j-k),-1 temp = temp + dconjg(a(l+i,j))*x(ix) ix = ix - incx enddo endif x(jx) = temp jx = jx - incx enddo endif else if (incx.eq.1) then do j = 1,n temp = x(j) l = 1 - j if (noconj) then if (nounit) temp = temp*a(1,j) do i = j + 1,min(n,j+k) temp = temp + a(l+i,j)*x(i) enddo else if (nounit) temp = temp*dconjg(a(1,j)) do i = j + 1,min(n,j+k) temp = temp + dconjg(a(l+i,j))*x(i) enddo endif x(j) = temp enddo else jx = kx do j = 1,n temp = x(jx) kx = kx + incx ix = kx l = 1 - j if (noconj) then if (nounit) temp = temp*a(1,j) do i = j + 1,min(n,j+k) temp = temp + a(l+i,j)*x(ix) ix = ix + incx enddo else if (nounit) temp = temp*dconjg(a(1,j)) do i = j + 1,min(n,j+k) temp = temp + dconjg(a(l+i,j))*x(ix) ix = ix + incx enddo endif x(jx) = temp jx = jx + incx enddo endif endif endif end subroutine ztbmv !> !!##NAME !! ztbsv(3f) - [BLAS:COMPLEX_16_BLAS_LEVEL2] !! !!##SYNOPSIS !! !! subroutine ztbsv(uplo,trans,diag,n,k,a,lda,x,incx) !! !! .. Scalar Arguments .. !! integer,intent(in) :: incx,k,lda,n !! character,intent(in) :: diag,trans,uplo !! .. !! .. Array Arguments .. !! complex(kind=real64),intent(in) :: a(lda,*) !! complex(kind=real64),intent(inout) :: x(*) !! .. !! !!##DEFINITION !! !! ZTBSV solves one of the systems of equations !! !! A*x = b, or A**T*x = b, or A**H*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. !! !!##OPTIONS !! !! UPLO !! !! UPLO is 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. !! !! TRANS !! !! TRANS is 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**T*x = b. !! !! TRANS = 'C' or 'c' A**H*x = b. !! !! DIAG !! !! DIAG is 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. !! !! N !! !! N is INTEGER !! On entry, N specifies the order of the matrix A. !! N must be at least zero. !! !! K !! !! K is 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. !! !! A !! !! A is complex(kind=real64) array, 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. !! !! LDA !! !! LDA is INTEGER !! On entry, LDA specifies the first dimension of A as declared !! in the calling (sub) program. LDA must be at least !! ( k + 1 ). !! !! X !! !! X is complex(kind=real64) array, 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 !! !! INCX is INTEGER !! On entry, INCX specifies the increment for the elements of !! X. INCX must not be zero. !! !!##AUTHORS !! !! + Univ. of Tennessee !! + Univ. of California Berkeley !! + Univ. of Colorado Denver !! + NAG Ltd. !! !! date:December 2016 !! !! FURTHER DETAILS !! !! 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. !! !!##SEE ALSO !! Online html documentation available at !! http://www.netlib.org/lapack/explore-html/ ! ===================================================================== subroutine ztbsv(uplo,trans,diag,n,k,a,lda,x,incx) implicit none ! ! -- Reference BLAS level2 routine (version 3.7.0) -- ! -- Reference BLAS is a software package provided by Univ. of Tennessee, -- ! -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- ! December 2016 ! ! .. Scalar Arguments .. integer,intent(in) :: incx,k,lda,n character,intent(in) :: diag,trans,uplo ! .. ! .. Array Arguments .. complex(kind=real64),intent(in) :: a(lda,*) complex(kind=real64),intent(inout) :: x(*) ! .. ! ! ===================================================================== ! ! .. Parameters .. complex(kind=real64) :: zero parameter (zero= (0.0d+0,0.0d+0)) ! .. ! .. Local Scalars .. complex(kind=real64) :: temp integer i,info,ix,j,jx,kplus1,kx,l logical noconj,nounit ! .. ! .. External Functions .. ! LOGICAL LSAME ! EXTERNAL LSAME ! .. ! .. External Subroutines .. ! EXTERNAL XERBLA ! .. ! .. Intrinsic Functions .. intrinsic dconjg,max,min ! .. ! ! Test the input parameters. ! info = 0 if (.not.lsame(uplo,'U') .and. .not.lsame(uplo,'L')) then info = 1 elseif (.not.lsame(trans,'N') .and. .not.lsame(trans,'T') .and. .not.lsame(trans,'C')) then info = 2 elseif (.not.lsame(diag,'U') .and. .not.lsame(diag,'N')) then info = 3 elseif (n.lt.0) then info = 4 elseif (k.lt.0) then info = 5 elseif (lda.lt. (k+1)) then info = 7 elseif (incx.eq.0) then info = 9 endif if (info.ne.0) then call xerbla('ZTBSV ',info) return endif ! ! Quick return if possible. ! if (n.eq.0) return ! noconj = lsame(trans,'T') nounit = lsame(diag,'N') ! ! Set up the start point in X if the increment is not unity. This ! will be ( N - 1 )*INCX too small for descending loops. ! if (incx.le.0) then kx = 1 - (n-1)*incx elseif (incx.ne.1) then kx = 1 endif ! ! Start the operations. In this version the elements of A are ! accessed by sequentially with one pass through A. ! if (lsame(trans,'N')) then ! ! Form x := inv( A )*x. ! if (lsame(uplo,'U')) then kplus1 = k + 1 if (incx.eq.1) then do j = n,1,-1 if (x(j).ne.zero) then l = kplus1 - j if (nounit) x(j) = x(j)/a(kplus1,j) temp = x(j) do i = j - 1,max(1,j-k),-1 x(i) = x(i) - temp*a(l+i,j) enddo endif enddo else kx = kx + (n-1)*incx jx = kx do j = n,1,-1 kx = kx - incx if (x(jx).ne.zero) then ix = kx l = kplus1 - j if (nounit) x(jx) = x(jx)/a(kplus1,j) temp = x(jx) do i = j - 1,max(1,j-k),-1 x(ix) = x(ix) - temp*a(l+i,j) ix = ix - incx enddo endif jx = jx - incx enddo endif else if (incx.eq.1) then do j = 1,n if (x(j).ne.zero) then l = 1 - j if (nounit) x(j) = x(j)/a(1,j) temp = x(j) do i = j + 1,min(n,j+k) x(i) = x(i) - temp*a(l+i,j) enddo endif enddo else jx = kx do j = 1,n kx = kx + incx if (x(jx).ne.zero) then ix = kx l = 1 - j if (nounit) x(jx) = x(jx)/a(1,j) temp = x(jx) do i = j + 1,min(n,j+k) x(ix) = x(ix) - temp*a(l+i,j) ix = ix + incx enddo endif jx = jx + incx enddo endif endif else ! ! Form x := inv( A**T )*x or x := inv( A**H )*x. ! if (lsame(uplo,'U')) then kplus1 = k + 1 if (incx.eq.1) then do j = 1,n temp = x(j) l = kplus1 - j if (noconj) then do i = max(1,j-k),j - 1 temp = temp - a(l+i,j)*x(i) enddo if (nounit) temp = temp/a(kplus1,j) else do i = max(1,j-k),j - 1 temp = temp - dconjg(a(l+i,j))*x(i) enddo if (nounit) temp = temp/dconjg(a(kplus1,j)) endif x(j) = temp enddo else jx = kx do j = 1,n temp = x(jx) ix = kx l = kplus1 - j if (noconj) then do i = max(1,j-k),j - 1 temp = temp - a(l+i,j)*x(ix) ix = ix + incx enddo if (nounit) temp = temp/a(kplus1,j) else do i = max(1,j-k),j - 1 temp = temp - dconjg(a(l+i,j))*x(ix) ix = ix + incx enddo if (nounit) temp = temp/dconjg(a(kplus1,j)) endif x(jx) = temp jx = jx + incx if (j.gt.k) kx = kx + incx enddo endif else if (incx.eq.1) then do j = n,1,-1 temp = x(j) l = 1 - j if (noconj) then do i = min(n,j+k),j + 1,-1 temp = temp - a(l+i,j)*x(i) enddo if (nounit) temp = temp/a(1,j) else do i = min(n,j+k),j + 1,-1 temp = temp - dconjg(a(l+i,j))*x(i) enddo if (nounit) temp = temp/dconjg(a(1,j)) endif x(j) = temp enddo else kx = kx + (n-1)*incx jx = kx do j = n,1,-1 temp = x(jx) ix = kx l = 1 - j if (noconj) then do i = min(n,j+k),j + 1,-1 temp = temp - a(l+i,j)*x(ix) ix = ix - incx enddo if (nounit) temp = temp/a(1,j) else do i = min(n,j+k),j + 1,-1 temp = temp - dconjg(a(l+i,j))*x(ix) ix = ix - incx enddo if (nounit) temp = temp/dconjg(a(1,j)) endif x(jx) = temp jx = jx - incx if ((n-j).ge.k) kx = kx - incx enddo endif endif endif end subroutine ztbsv !> !!##NAME !! ztpmv(3f) - [BLAS:COMPLEX_16_BLAS_LEVEL2] !! !!##SYNOPSIS !! !! subroutine ztpmv(uplo,trans,diag,n,ap,x,incx) !! !! .. Scalar Arguments .. !! integer,intent(in) :: incx,n !! character,intent(in) :: diag,trans,uplo !! .. !! .. Array Arguments .. !! complex(kind=real64),intent(in) :: ap(*) !! complex(kind=real64),intent(inout) :: x(*) !! .. !! !!##DEFINITION !! !! ZTPMV performs one of the matrix-vector operations !! !! x := A*x, or x := A**T*x, or x := A**H*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. !! !!##OPTIONS !! !! UPLO !! !! UPLO is 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. !! !! TRANS !! !! TRANS is 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**T*x. !! !! TRANS = 'C' or 'c' x := A**H*x. !! !! DIAG !! !! DIAG is 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. !! !! N !! !! N is INTEGER !! On entry, N specifies the order of the matrix A. !! N must be at least zero. !! !! AP !! !! AP is complex(kind=real64) array, 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. !! !! X !! !! X is complex(kind=real64) array, 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 !! transformed vector x. !! !! INCX !! !! INCX is INTEGER !! On entry, INCX specifies the increment for the elements of !! X. INCX must not be zero. !! !!##AUTHORS !! !! + Univ. of Tennessee !! + Univ. of California Berkeley !! + Univ. of Colorado Denver !! + NAG Ltd. !! !! date:December 2016 !! !! FURTHER DETAILS !! !! Level 2 Blas routine. !! The vector and matrix arguments are not referenced when N = 0, or M = 0 !! !! -- 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. !! !!##SEE ALSO !! Online html documentation available at !! http://www.netlib.org/lapack/explore-html/ ! ===================================================================== subroutine ztpmv(uplo,trans,diag,n,ap,x,incx) implicit none ! ! -- Reference BLAS level2 routine (version 3.7.0) -- ! -- Reference BLAS is a software package provided by Univ. of Tennessee, -- ! -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- ! December 2016 ! ! .. Scalar Arguments .. integer,intent(in) :: incx,n character,intent(in) :: diag,trans,uplo ! .. ! .. Array Arguments .. complex(kind=real64),intent(in) :: ap(*) complex(kind=real64),intent(inout) :: x(*) ! .. ! ! ===================================================================== ! ! .. Parameters .. complex(kind=real64) :: zero parameter (zero= (0.0d+0,0.0d+0)) ! .. ! .. Local Scalars .. complex(kind=real64) :: temp integer i,info,ix,j,jx,k,kk,kx logical noconj,nounit ! .. ! .. External Functions .. ! LOGICAL LSAME ! EXTERNAL LSAME ! .. ! .. External Subroutines .. ! EXTERNAL XERBLA ! .. ! .. Intrinsic Functions .. intrinsic dconjg ! .. ! ! Test the input parameters. ! info = 0 if (.not.lsame(uplo,'U') .and. .not.lsame(uplo,'L')) then info = 1 elseif (.not.lsame(trans,'N') .and. .not.lsame(trans,'T') .and. .not.lsame(trans,'C')) then info = 2 elseif (.not.lsame(diag,'U') .and. .not.lsame(diag,'N')) then info = 3 elseif (n.lt.0) then info = 4 elseif (incx.eq.0) then info = 7 endif if (info.ne.0) then call xerbla('ZTPMV ',info) return endif ! ! Quick return if possible. ! if (n.eq.0) return ! noconj = lsame(trans,'T') nounit = lsame(diag,'N') ! ! Set up the start point in X if the increment is not unity. This ! will be ( N - 1 )*INCX too small for descending loops. ! if (incx.le.0) then kx = 1 - (n-1)*incx elseif (incx.ne.1) then kx = 1 endif ! ! Start the operations. In this version the elements of AP are ! accessed sequentially with one pass through AP. ! if (lsame(trans,'N')) then ! ! Form x:= A*x. ! if (lsame(uplo,'U')) then kk = 1 if (incx.eq.1) then do j = 1,n if (x(j).ne.zero) then temp = x(j) k = kk do i = 1,j - 1 x(i) = x(i) + temp*ap(k) k = k + 1 enddo if (nounit) x(j) = x(j)*ap(kk+j-1) endif kk = kk + j enddo else jx = kx do j = 1,n if (x(jx).ne.zero) then temp = x(jx) ix = kx do k = kk,kk + j - 2 x(ix) = x(ix) + temp*ap(k) ix = ix + incx enddo if (nounit) x(jx) = x(jx)*ap(kk+j-1) endif jx = jx + incx kk = kk + j enddo endif else kk = (n* (n+1))/2 if (incx.eq.1) then do j = n,1,-1 if (x(j).ne.zero) then temp = x(j) k = kk do i = n,j + 1,-1 x(i) = x(i) + temp*ap(k) k = k - 1 enddo if (nounit) x(j) = x(j)*ap(kk-n+j) endif kk = kk - (n-j+1) enddo else kx = kx + (n-1)*incx jx = kx do j = n,1,-1 if (x(jx).ne.zero) then temp = x(jx) ix = kx do k = kk,kk - (n- (j+1)),-1 x(ix) = x(ix) + temp*ap(k) ix = ix - incx enddo if (nounit) x(jx) = x(jx)*ap(kk-n+j) endif jx = jx - incx kk = kk - (n-j+1) enddo endif endif else ! ! Form x := A**T*x or x := A**H*x. ! if (lsame(uplo,'U')) then kk = (n* (n+1))/2 if (incx.eq.1) then do j = n,1,-1 temp = x(j) k = kk - 1 if (noconj) then if (nounit) temp = temp*ap(kk) do i = j - 1,1,-1 temp = temp + ap(k)*x(i) k = k - 1 enddo else if (nounit) temp = temp*dconjg(ap(kk)) do i = j - 1,1,-1 temp = temp + dconjg(ap(k))*x(i) k = k - 1 enddo endif x(j) = temp kk = kk - j enddo else jx = kx + (n-1)*incx do j = n,1,-1 temp = x(jx) ix = jx if (noconj) then if (nounit) temp = temp*ap(kk) do k = kk - 1,kk - j + 1,-1 ix = ix - incx temp = temp + ap(k)*x(ix) enddo else if (nounit) temp = temp*dconjg(ap(kk)) do k = kk - 1,kk - j + 1,-1 ix = ix - incx temp = temp + dconjg(ap(k))*x(ix) enddo endif x(jx) = temp jx = jx - incx kk = kk - j enddo endif else kk = 1 if (incx.eq.1) then do j = 1,n temp = x(j) k = kk + 1 if (noconj) then if (nounit) temp = temp*ap(kk) do i = j + 1,n temp = temp + ap(k)*x(i) k = k + 1 enddo else if (nounit) temp = temp*dconjg(ap(kk)) do i = j + 1,n temp = temp + dconjg(ap(k))*x(i) k = k + 1 enddo endif x(j) = temp kk = kk + (n-j+1) enddo else jx = kx do j = 1,n temp = x(jx) ix = jx if (noconj) then if (nounit) temp = temp*ap(kk) do k = kk + 1,kk + n - j ix = ix + incx temp = temp + ap(k)*x(ix) enddo else if (nounit) temp = temp*dconjg(ap(kk)) do k = kk + 1,kk + n - j ix = ix + incx temp = temp + dconjg(ap(k))*x(ix) enddo endif x(jx) = temp jx = jx + incx kk = kk + (n-j+1) enddo endif endif endif end subroutine ztpmv !> !!##NAME !! ztpsv(3f) - [BLAS:COMPLEX_16_BLAS_LEVEL2] !! !!##SYNOPSIS !! !! subroutine ztpsv(uplo,trans,diag,n,ap,x,incx) !! !! .. Scalar Arguments .. !! integer,intent(in) :: incx,n !! character,intent(in) :: diag,trans,uplo !! .. !! .. Array Arguments .. !! complex(kind=real64),intent(in) :: ap(*) !! complex(kind=real64),intent(inout) :: x(*) !! .. !! !!##DEFINITION !! !! ZTPSV solves one of the systems of equations !! !! A*x = b, or A**T*x = b, or A**H*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. !! !!##OPTIONS !! !! UPLO !! !! UPLO is 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. !! !! TRANS !! !! TRANS is 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**T*x = b. !! !! TRANS = 'C' or 'c' A**H*x = b. !! !! DIAG !! !! DIAG is 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. !! !! N !! !! N is INTEGER !! On entry, N specifies the order of the matrix A. !! N must be at least zero. !! !! AP !! !! AP is complex(kind=real64) array, 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. !! !! X !! !! X is complex(kind=real64) array, 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 !! !! INCX is INTEGER !! On entry, INCX specifies the increment for the elements of !! X. INCX must not be zero. !! !!##AUTHORS !! !! + Univ. of Tennessee !! + Univ. of California Berkeley !! + Univ. of Colorado Denver !! + NAG Ltd. !! !! date:December 2016 !! !! FURTHER DETAILS !! !! 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. !! !!##SEE ALSO !! Online html documentation available at !! http://www.netlib.org/lapack/explore-html/ ! ===================================================================== subroutine ztpsv(uplo,trans,diag,n,ap,x,incx) implicit none ! ! -- Reference BLAS level2 routine (version 3.7.0) -- ! -- Reference BLAS is a software package provided by Univ. of Tennessee, -- ! -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- ! December 2016 ! ! .. Scalar Arguments .. integer,intent(in) :: incx,n character,intent(in) :: diag,trans,uplo ! .. ! .. Array Arguments .. complex(kind=real64),intent(in) :: ap(*) complex(kind=real64),intent(inout) :: x(*) ! .. ! ! ===================================================================== ! ! .. Parameters .. complex(kind=real64) :: zero parameter (zero= (0.0d+0,0.0d+0)) ! .. ! .. Local Scalars .. complex(kind=real64) :: temp integer i,info,ix,j,jx,k,kk,kx logical noconj,nounit ! .. ! .. External Functions .. ! LOGICAL LSAME ! EXTERNAL LSAME ! .. ! .. External Subroutines .. ! EXTERNAL XERBLA ! .. ! .. Intrinsic Functions .. intrinsic dconjg ! .. ! ! Test the input parameters. ! info = 0 if (.not.lsame(uplo,'U') .and. .not.lsame(uplo,'L')) then info = 1 elseif (.not.lsame(trans,'N') .and. .not.lsame(trans,'T') .and. .not.lsame(trans,'C')) then info = 2 elseif (.not.lsame(diag,'U') .and. .not.lsame(diag,'N')) then info = 3 elseif (n.lt.0) then info = 4 elseif (incx.eq.0) then info = 7 endif if (info.ne.0) then call xerbla('ZTPSV ',info) return endif ! ! Quick return if possible. ! if (n.eq.0) return ! noconj = lsame(trans,'T') nounit = lsame(diag,'N') ! ! Set up the start point in X if the increment is not unity. This ! will be ( N - 1 )*INCX too small for descending loops. ! if (incx.le.0) then kx = 1 - (n-1)*incx elseif (incx.ne.1) then kx = 1 endif ! ! Start the operations. In this version the elements of AP are ! accessed sequentially with one pass through AP. ! if (lsame(trans,'N')) then ! ! Form x := inv( A )*x. ! if (lsame(uplo,'U')) then kk = (n* (n+1))/2 if (incx.eq.1) then do j = n,1,-1 if (x(j).ne.zero) then if (nounit) x(j) = x(j)/ap(kk) temp = x(j) k = kk - 1 do i = j - 1,1,-1 x(i) = x(i) - temp*ap(k) k = k - 1 enddo endif kk = kk - j enddo else jx = kx + (n-1)*incx do j = n,1,-1 if (x(jx).ne.zero) then if (nounit) x(jx) = x(jx)/ap(kk) temp = x(jx) ix = jx do k = kk - 1,kk - j + 1,-1 ix = ix - incx x(ix) = x(ix) - temp*ap(k) enddo endif jx = jx - incx kk = kk - j enddo endif else kk = 1 if (incx.eq.1) then do j = 1,n if (x(j).ne.zero) then if (nounit) x(j) = x(j)/ap(kk) temp = x(j) k = kk + 1 do i = j + 1,n x(i) = x(i) - temp*ap(k) k = k + 1 enddo endif kk = kk + (n-j+1) enddo else jx = kx do j = 1,n if (x(jx).ne.zero) then if (nounit) x(jx) = x(jx)/ap(kk) temp = x(jx) ix = jx do k = kk + 1,kk + n - j ix = ix + incx x(ix) = x(ix) - temp*ap(k) enddo endif jx = jx + incx kk = kk + (n-j+1) enddo endif endif else ! ! Form x := inv( A**T )*x or x := inv( A**H )*x. ! if (lsame(uplo,'U')) then kk = 1 if (incx.eq.1) then do j = 1,n temp = x(j) k = kk if (noconj) then do i = 1,j - 1 temp = temp - ap(k)*x(i) k = k + 1 enddo if (nounit) temp = temp/ap(kk+j-1) else do i = 1,j - 1 temp = temp - dconjg(ap(k))*x(i) k = k + 1 enddo if (nounit) temp = temp/dconjg(ap(kk+j-1)) endif x(j) = temp kk = kk + j enddo else jx = kx do j = 1,n temp = x(jx) ix = kx if (noconj) then do k = kk,kk + j - 2 temp = temp - ap(k)*x(ix) ix = ix + incx enddo if (nounit) temp = temp/ap(kk+j-1) else do k = kk,kk + j - 2 temp = temp - dconjg(ap(k))*x(ix) ix = ix + incx enddo if (nounit) temp = temp/dconjg(ap(kk+j-1)) endif x(jx) = temp jx = jx + incx kk = kk + j enddo endif else kk = (n* (n+1))/2 if (incx.eq.1) then do j = n,1,-1 temp = x(j) k = kk if (noconj) then do i = n,j + 1,-1 temp = temp - ap(k)*x(i) k = k - 1 enddo if (nounit) temp = temp/ap(kk-n+j) else do i = n,j + 1,-1 temp = temp - dconjg(ap(k))*x(i) k = k - 1 enddo if (nounit) temp = temp/dconjg(ap(kk-n+j)) endif x(j) = temp kk = kk - (n-j+1) enddo else kx = kx + (n-1)*incx jx = kx do j = n,1,-1 temp = x(jx) ix = kx if (noconj) then do k = kk,kk - (n- (j+1)),-1 temp = temp - ap(k)*x(ix) ix = ix - incx enddo if (nounit) temp = temp/ap(kk-n+j) else do k = kk,kk - (n- (j+1)),-1 temp = temp - dconjg(ap(k))*x(ix) ix = ix - incx enddo if (nounit) temp = temp/dconjg(ap(kk-n+j)) endif x(jx) = temp jx = jx - incx kk = kk - (n-j+1) enddo endif endif endif end subroutine ztpsv !> !!##NAME !! ztrmm(3f) - [BLAS:COMPLEX16_BLAS_LEVEL3] !! !!##SYNOPSIS !! !! subroutine ztrmm(side,uplo,transa,diag,m,n,alpha,a,lda,b,ldb) !! !! .. Scalar Arguments .. !! complex(kind=real64),intent(in) :: alpha !! integer,intent(in) :: lda,ldb,m,n !! character,intent(in) :: diag,side,transa,uplo !! .. !! .. Array Arguments .. !! complex(kind=real64),intent(in) :: a(lda,*) !! complex(kind=real64),intent(inout) :: b(ldb,*) !! .. !! !!##DEFINITION !! !! ZTRMM 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**T or op( A ) = A**H. !! !!##OPTIONS !! !! SIDE !! !! SIDE is 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 ). !! !! UPLO !! !! UPLO is 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. !! !! TRANSA !! !! TRANSA is 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**T. !! !! TRANSA = 'C' or 'c' op( A ) = A**H. !! !! DIAG !! !! DIAG is 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. !! !! M !! !! M is INTEGER !! On entry, M specifies the number of rows of B. M must be at !! least zero. !! !! N !! !! N is INTEGER !! On entry, N specifies the number of columns of B. N must be !! at least zero. !! !! ALPHA !! !! ALPHA is complex(kind=real64) !! On entry, ALPHA specifies the scalar alpha. When alpha is !! zero then A is not referenced and B need not be set before !! entry. !! !! A !! !! A is complex(kind=real64) array, 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. !! !! LDA !! !! LDA is 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 ). !! !! B !! !! B is complex(kind=real64) array, 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 !! !! LDB is 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 ). !! !!##AUTHORS !! !! + Univ. of Tennessee !! + Univ. of California Berkeley !! + Univ. of Colorado Denver !! + NAG Ltd. !! !! date:December 2016 !! !! FURTHER DETAILS !! !! 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. !! !!##SEE ALSO !! Online html documentation available at !! http://www.netlib.org/lapack/explore-html/ ! ===================================================================== subroutine ztrmm(side,uplo,transa,diag,m,n,alpha,a,lda,b,ldb) implicit none ! ! -- Reference BLAS level3 routine (version 3.7.0) -- ! -- Reference BLAS is a software package provided by Univ. of Tennessee, -- ! -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- ! December 2016 ! ! .. Scalar Arguments .. complex(kind=real64),intent(in) :: alpha integer,intent(in) :: lda,ldb,m,n character,intent(in) :: diag,side,transa,uplo ! .. ! .. Array Arguments .. complex(kind=real64),intent(in) :: a(lda,*) complex(kind=real64),intent(inout) :: b(ldb,*) ! .. ! ! ===================================================================== ! ! .. External Functions .. ! LOGICAL LSAME ! EXTERNAL LSAME ! .. ! .. External Subroutines .. ! EXTERNAL XERBLA ! .. ! .. Intrinsic Functions .. intrinsic dconjg,max ! .. ! .. Local Scalars .. complex(kind=real64) :: temp integer i,info,j,k,nrowa logical lside,noconj,nounit,upper ! .. ! .. Parameters .. complex(kind=real64) :: one parameter (one= (1.0d+0,0.0d+0)) complex(kind=real64) :: zero parameter (zero= (0.0d+0,0.0d+0)) ! .. ! ! Test the input parameters. ! lside = lsame(side,'L') if (lside) then nrowa = m else nrowa = n endif noconj = lsame(transa,'T') nounit = lsame(diag,'N') upper = lsame(uplo,'U') ! info = 0 if ((.not.lside) .and. (.not.lsame(side,'R'))) then info = 1 elseif ((.not.upper) .and. (.not.lsame(uplo,'L'))) then info = 2 elseif ((.not.lsame(transa,'N')) .and. (.not.lsame(transa,'T')) .and. (.not.lsame(transa,'C'))) then info = 3 elseif ((.not.lsame(diag,'U')) .and. (.not.lsame(diag,'N'))) then info = 4 elseif (m.lt.0) then info = 5 elseif (n.lt.0) then info = 6 elseif (lda.lt.max(1,nrowa)) then info = 9 elseif (ldb.lt.max(1,m)) then info = 11 endif if (info.ne.0) then call xerbla('ZTRMM ',info) return endif ! ! Quick return if possible. ! if (m.eq.0 .or. n.eq.0) return ! ! And when alpha.eq.zero. ! if (alpha.eq.zero) then do j = 1,n do i = 1,m b(i,j) = zero enddo enddo return endif ! ! Start the operations. ! if (lside) then if (lsame(transa,'N')) then ! ! Form B := alpha*A*B. ! if (upper) then do j = 1,n do k = 1,m if (b(k,j).ne.zero) then temp = alpha*b(k,j) do i = 1,k - 1 b(i,j) = b(i,j) + temp*a(i,k) enddo if (nounit) temp = temp*a(k,k) b(k,j) = temp endif enddo enddo else do j = 1,n do k = m,1,-1 if (b(k,j).ne.zero) then temp = alpha*b(k,j) b(k,j) = temp if (nounit) b(k,j) = b(k,j)*a(k,k) do i = k + 1,m b(i,j) = b(i,j) + temp*a(i,k) enddo endif enddo enddo endif else ! ! Form B := alpha*A**T*B or B := alpha*A**H*B. ! if (upper) then do j = 1,n do i = m,1,-1 temp = b(i,j) if (noconj) then if (nounit) temp = temp*a(i,i) do k = 1,i - 1 temp = temp + a(k,i)*b(k,j) enddo else if (nounit) temp = temp*dconjg(a(i,i)) do k = 1,i - 1 temp = temp + dconjg(a(k,i))*b(k,j) enddo endif b(i,j) = alpha*temp enddo enddo else do j = 1,n do i = 1,m temp = b(i,j) if (noconj) then if (nounit) temp = temp*a(i,i) do k = i + 1,m temp = temp + a(k,i)*b(k,j) enddo else if (nounit) temp = temp*dconjg(a(i,i)) do k = i + 1,m temp = temp + dconjg(a(k,i))*b(k,j) enddo endif b(i,j) = alpha*temp enddo enddo endif endif else if (lsame(transa,'N')) then ! ! Form B := alpha*B*A. ! if (upper) then do j = n,1,-1 temp = alpha if (nounit) temp = temp*a(j,j) b(1:m,j) = temp*b(1:m,j) do k = 1,j - 1 if (a(k,j).ne.zero) then temp = alpha*a(k,j) b(1:m,j) = b(1:m,j) + temp*b(1:m,k) endif enddo enddo else do j = 1,n temp = alpha if (nounit) temp = temp*a(j,j) b(1:m,j) = temp*b(1:m,j) do k = j + 1,n if (a(k,j).ne.zero) then temp = alpha*a(k,j) b(1:m,j) = b(1:m,j) + temp*b(1:m,k) endif enddo enddo endif else ! ! Form B := alpha*B*A**T or B := alpha*B*A**H. ! if (upper) then do k = 1,n do j = 1,k - 1 if (a(j,k).ne.zero) then if (noconj) then temp = alpha*a(j,k) else temp = alpha*dconjg(a(j,k)) endif b(1:m,j) = b(1:m,j) + temp*b(1:m,k) endif enddo temp = alpha if (nounit) then if (noconj) then temp = temp*a(k,k) else temp = temp*dconjg(a(k,k)) endif endif if (temp.ne.one) then b(1:m,k) = temp*b(1:m,k) endif enddo else do k = n,1,-1 do j = k + 1,n if (a(j,k).ne.zero) then if (noconj) then temp = alpha*a(j,k) else temp = alpha*dconjg(a(j,k)) endif b(1:m,j) = b(1:m,j) + temp*b(1:m,k) endif enddo temp = alpha if (nounit) then if (noconj) then temp = temp*a(k,k) else temp = temp*dconjg(a(k,k)) endif endif if (temp.ne.one) then b(1:m,k) = temp*b(1:m,k) endif enddo endif endif endif end subroutine ztrmm !> !!##NAME !! ztrmv(3f) - [BLAS:COMPLEX_16_BLAS_LEVEL2] !! !!##SYNOPSIS !! !! subroutine ztrmv(uplo,trans,diag,n,a,lda,x,incx) !! !! .. Scalar Arguments .. !! integer,intent(in) :: incx,lda,n !! character,intent(in) :: diag,trans,uplo !! .. !! .. Array Arguments .. !! complex(kind=real64),intent(in) :: a(lda,*) !! complex(kind=real64),intent(inout) :: x(*) !! .. !! !!##DEFINITION !! !! ZTRMV performs one of the matrix-vector operations !! !! x := A*x, or x := A**T*x, or x := A**H*x, !! !! where x is an n element vector and A is an n by n unit, or non-unit, !! upper or lower triangular matrix. !! !!##OPTIONS !! !! UPLO !! !! UPLO is 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. !! !! TRANS !! !! TRANS is 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**T*x. !! !! TRANS = 'C' or 'c' x := A**H*x. !! !! DIAG !! !! DIAG is 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. !! !! N !! !! N is INTEGER !! On entry, N specifies the order of the matrix A. !! N must be at least zero. !! !! A !! !! A is complex(kind=real64) array, 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. !! !! LDA !! !! LDA is 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 ). !! !! X !! !! X is complex(kind=real64) array, 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 !! transformed vector x. !! !! INCX !! !! INCX is INTEGER !! On entry, INCX specifies the increment for the elements of !! X. INCX must not be zero. !! !!##AUTHORS !! !! + Univ. of Tennessee !! + Univ. of California Berkeley !! + Univ. of Colorado Denver !! + NAG Ltd. !! !! date:December 2016 !! !! FURTHER DETAILS !! !! Level 2 Blas routine. !! The vector and matrix arguments are not referenced when N = 0, or M = 0 !! !! -- 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. !! !!##SEE ALSO !! Online html documentation available at !! http://www.netlib.org/lapack/explore-html/ ! ===================================================================== subroutine ztrmv(uplo,trans,diag,n,a,lda,x,incx) implicit none ! ! -- Reference BLAS level2 routine (version 3.7.0) -- ! -- Reference BLAS is a software package provided by Univ. of Tennessee, -- ! -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- ! December 2016 ! ! .. Scalar Arguments .. integer,intent(in) :: incx,lda,n character,intent(in) :: diag,trans,uplo ! .. ! .. Array Arguments .. complex(kind=real64),intent(in) :: a(lda,*) complex(kind=real64),intent(inout) :: x(*) ! .. ! ===================================================================== ! ! .. Parameters .. complex(kind=real64) :: zero parameter (zero= (0.0d+0,0.0d+0)) ! .. ! .. Local Scalars .. complex(kind=real64) :: temp integer i,info,ix,j,jx,kx logical noconj,nounit ! .. ! .. External Functions .. ! LOGICAL LSAME ! EXTERNAL LSAME ! .. ! .. External Subroutines .. ! EXTERNAL XERBLA ! .. ! .. Intrinsic Functions .. intrinsic dconjg,max ! .. ! ! Test the input parameters. ! info = 0 if (.not.lsame(uplo,'U') .and. .not.lsame(uplo,'L')) then info = 1 elseif (.not.lsame(trans,'N') .and. .not.lsame(trans,'T') .and. .not.lsame(trans,'C')) then info = 2 elseif (.not.lsame(diag,'U') .and. .not.lsame(diag,'N')) then info = 3 elseif (n.lt.0) then info = 4 elseif (lda.lt.max(1,n)) then info = 6 elseif (incx.eq.0) then info = 8 endif if (info.ne.0) then call xerbla('ZTRMV ',info) return endif ! ! Quick return if possible. ! if (n.eq.0) return ! noconj = lsame(trans,'T') nounit = lsame(diag,'N') ! ! Set up the start point in X if the increment is not unity. This ! will be ( N - 1 )*INCX too small for descending loops. ! if (incx.le.0) then kx = 1 - (n-1)*incx elseif (incx.ne.1) then kx = 1 endif ! ! Start the operations. In this version the elements of A are ! accessed sequentially with one pass through A. ! if (lsame(trans,'N')) then ! ! Form x := A*x. ! if (lsame(uplo,'U')) then if (incx.eq.1) then do j = 1,n if (x(j).ne.zero) then temp = x(j) do i = 1,j - 1 x(i) = x(i) + temp*a(i,j) enddo if (nounit) x(j) = x(j)*a(j,j) endif enddo else jx = kx do j = 1,n if (x(jx).ne.zero) then temp = x(jx) ix = kx do i = 1,j - 1 x(ix) = x(ix) + temp*a(i,j) ix = ix + incx enddo if (nounit) x(jx) = x(jx)*a(j,j) endif jx = jx + incx enddo endif else if (incx.eq.1) then do j = n,1,-1 if (x(j).ne.zero) then temp = x(j) do i = n,j + 1,-1 x(i) = x(i) + temp*a(i,j) enddo if (nounit) x(j) = x(j)*a(j,j) endif enddo else kx = kx + (n-1)*incx jx = kx do j = n,1,-1 if (x(jx).ne.zero) then temp = x(jx) ix = kx do i = n,j + 1,-1 x(ix) = x(ix) + temp*a(i,j) ix = ix - incx enddo if (nounit) x(jx) = x(jx)*a(j,j) endif jx = jx - incx enddo endif endif else ! ! Form x := A**T*x or x := A**H*x. ! if (lsame(uplo,'U')) then if (incx.eq.1) then do j = n,1,-1 temp = x(j) if (noconj) then if (nounit) temp = temp*a(j,j) do i = j - 1,1,-1 temp = temp + a(i,j)*x(i) enddo else if (nounit) temp = temp*dconjg(a(j,j)) do i = j - 1,1,-1 temp = temp + dconjg(a(i,j))*x(i) enddo endif x(j) = temp enddo else jx = kx + (n-1)*incx do j = n,1,-1 temp = x(jx) ix = jx if (noconj) then if (nounit) temp = temp*a(j,j) do i = j - 1,1,-1 ix = ix - incx temp = temp + a(i,j)*x(ix) enddo else if (nounit) temp = temp*dconjg(a(j,j)) do i = j - 1,1,-1 ix = ix - incx temp = temp + dconjg(a(i,j))*x(ix) enddo endif x(jx) = temp jx = jx - incx enddo endif else if (incx.eq.1) then do j = 1,n temp = x(j) if (noconj) then if (nounit) temp = temp*a(j,j) do i = j + 1,n temp = temp + a(i,j)*x(i) enddo else if (nounit) temp = temp*dconjg(a(j,j)) do i = j + 1,n temp = temp + dconjg(a(i,j))*x(i) enddo endif x(j) = temp enddo else jx = kx do j = 1,n temp = x(jx) ix = jx if (noconj) then if (nounit) temp = temp*a(j,j) do i = j + 1,n ix = ix + incx temp = temp + a(i,j)*x(ix) enddo else if (nounit) temp = temp*dconjg(a(j,j)) do i = j + 1,n ix = ix + incx temp = temp + dconjg(a(i,j))*x(ix) enddo endif x(jx) = temp jx = jx + incx enddo endif endif endif end subroutine ztrmv !> !!##NAME !! ztrsm(3f) - [BLAS:COMPLEX_16_BLAS_LEVEL3] !! !!##SYNOPSIS !! !! subroutine ztrsm(side,uplo,transa,diag,m,n,alpha,a,lda,b,ldb) !! !! .. Scalar Arguments .. !! complex(kind=real64),intent(in) :: alpha !! integer,intent(in) :: lda,ldb,m,n !! character,intent(in) :: diag,side,transa,uplo !! .. !! .. Array Arguments .. !! complex(kind=real64),intent(in) :: a(lda,*) !! complex(kind=real64),intent(inout) :: b(ldb,*) !! .. !! !!##DEFINITION !! !! ZTRSM 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**T or op( A ) = A**H. !! !! The matrix X is overwritten on B. !! !!##OPTIONS !! !! SIDE !! !! SIDE is 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. !! !! UPLO !! !! UPLO is 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. !! !! TRANSA !! !! TRANSA is 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**T. !! !! TRANSA = 'C' or 'c' op( A ) = A**H. !! !! DIAG !! !! DIAG is 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. !! !! M !! !! M is INTEGER !! On entry, M specifies the number of rows of B. M must be at !! least zero. !! !! N !! !! N is INTEGER !! On entry, N specifies the number of columns of B. N must be !! at least zero. !! !! ALPHA !! !! ALPHA is complex(kind=real64) !! On entry, ALPHA specifies the scalar alpha. When alpha is !! zero then A is not referenced and B need not be set before !! entry. !! !! A !! !! A is complex(kind=real64) array, dimension ( LDA, k ), !! where k is m when SIDE = 'L' or 'l' !! and k 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. !! !! LDA !! !! LDA is 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 ). !! !! B !! !! B is complex(kind=real64) 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 !! !! LDB is 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 ). !! !!##AUTHORS !! !! + Univ. of Tennessee !! + Univ. of California Berkeley !! + Univ. of Colorado Denver !! + NAG Ltd. !! !! date:December 2016 !! !! FURTHER DETAILS !! !! 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. !! !!##SEE ALSO !! Online html documentation available at !! http://www.netlib.org/lapack/explore-html/ ! ===================================================================== subroutine ztrsm(side,uplo,transa,diag,m,n,alpha,a,lda,b,ldb) implicit none ! ! -- Reference BLAS level3 routine (version 3.7.0) -- ! -- Reference BLAS is a software package provided by Univ. of Tennessee, -- ! -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- ! December 2016 ! ! .. Scalar Arguments .. complex(kind=real64),intent(in) :: alpha integer,intent(in) :: lda,ldb,m,n character,intent(in) :: diag,side,transa,uplo ! .. ! .. Array Arguments .. complex(kind=real64),intent(in) :: a(lda,*) complex(kind=real64),intent(inout) :: b(ldb,*) ! .. ! ! ===================================================================== ! ! .. External Functions .. ! LOGICAL LSAME ! EXTERNAL LSAME ! .. ! .. External Subroutines .. ! EXTERNAL XERBLA ! .. ! .. Intrinsic Functions .. intrinsic dconjg,max ! .. ! .. Local Scalars .. complex(kind=real64) :: temp integer i,info,j,k,nrowa logical lside,noconj,nounit,upper ! .. ! .. Parameters .. complex(kind=real64) :: one parameter (one= (1.0d+0,0.0d+0)) complex(kind=real64) :: zero parameter (zero= (0.0d+0,0.0d+0)) ! .. ! ! Test the input parameters. ! lside = lsame(side,'L') if (lside) then nrowa = m else nrowa = n endif noconj = lsame(transa,'T') nounit = lsame(diag,'N') upper = lsame(uplo,'U') ! info = 0 if ((.not.lside) .and. (.not.lsame(side,'R'))) then info = 1 elseif ((.not.upper) .and. (.not.lsame(uplo,'L'))) then info = 2 elseif ((.not.lsame(transa,'N')) .and. (.not.lsame(transa,'T')) .and. (.not.lsame(transa,'C'))) then info = 3 elseif ((.not.lsame(diag,'U')) .and. (.not.lsame(diag,'N'))) then info = 4 elseif (m.lt.0) then info = 5 elseif (n.lt.0) then info = 6 elseif (lda.lt.max(1,nrowa)) then info = 9 elseif (ldb.lt.max(1,m)) then info = 11 endif if (info.ne.0) then call xerbla('ZTRSM ',info) return endif ! ! Quick return if possible. ! if (m.eq.0 .or. n.eq.0) return ! ! And when alpha.eq.zero. ! if (alpha.eq.zero) then do j = 1,n do i = 1,m b(i,j) = zero enddo enddo return endif ! ! Start the operations. ! if (lside) then if (lsame(transa,'N')) then ! ! Form B := alpha*inv( A )*B. ! if (upper) then do j = 1,n if (alpha.ne.one) then do i = 1,m b(i,j) = alpha*b(i,j) enddo endif do k = m,1,-1 if (b(k,j).ne.zero) then if (nounit) b(k,j) = b(k,j)/a(k,k) do i = 1,k - 1 b(i,j) = b(i,j) - b(k,j)*a(i,k) enddo endif enddo enddo else do j = 1,n if (alpha.ne.one) then do i = 1,m b(i,j) = alpha*b(i,j) enddo endif do k = 1,m if (b(k,j).ne.zero) then if (nounit) b(k,j) = b(k,j)/a(k,k) do i = k + 1,m b(i,j) = b(i,j) - b(k,j)*a(i,k) enddo endif enddo enddo endif else ! ! Form B := alpha*inv( A**T )*B ! or B := alpha*inv( A**H )*B. ! if (upper) then do j = 1,n do i = 1,m temp = alpha*b(i,j) if (noconj) then do k = 1,i - 1 temp = temp - a(k,i)*b(k,j) enddo if (nounit) temp = temp/a(i,i) else do k = 1,i - 1 temp = temp - dconjg(a(k,i))*b(k,j) enddo if (nounit) temp = temp/dconjg(a(i,i)) endif b(i,j) = temp enddo enddo else do j = 1,n do i = m,1,-1 temp = alpha*b(i,j) if (noconj) then do k = i + 1,m temp = temp - a(k,i)*b(k,j) enddo if (nounit) temp = temp/a(i,i) else do k = i + 1,m temp = temp - dconjg(a(k,i))*b(k,j) enddo if (nounit) temp = temp/dconjg(a(i,i)) endif b(i,j) = temp enddo enddo endif endif else if (lsame(transa,'N')) then ! ! Form B := alpha*B*inv( A ). ! if (upper) then do j = 1,n if (alpha.ne.one) then do i = 1,m b(i,j) = alpha*b(i,j) enddo endif do k = 1,j - 1 if (a(k,j).ne.zero) then do i = 1,m b(i,j) = b(i,j) - a(k,j)*b(i,k) enddo endif enddo if (nounit) then temp = one/a(j,j) do i = 1,m b(i,j) = temp*b(i,j) enddo endif enddo else do j = n,1,-1 if (alpha.ne.one) then do i = 1,m b(i,j) = alpha*b(i,j) enddo endif do k = j + 1,n if (a(k,j).ne.zero) then do i = 1,m b(i,j) = b(i,j) - a(k,j)*b(i,k) enddo endif enddo if (nounit) then temp = one/a(j,j) do i = 1,m b(i,j) = temp*b(i,j) enddo endif enddo endif else ! ! Form B := alpha*B*inv( A**T ) ! or B := alpha*B*inv( A**H ). ! if (upper) then do k = n,1,-1 if (nounit) then if (noconj) then temp = one/a(k,k) else temp = one/dconjg(a(k,k)) endif do i = 1,m b(i,k) = temp*b(i,k) enddo endif do j = 1,k - 1 if (a(j,k).ne.zero) then if (noconj) then temp = a(j,k) else temp = dconjg(a(j,k)) endif do i = 1,m b(i,j) = b(i,j) - temp*b(i,k) enddo endif enddo if (alpha.ne.one) then do i = 1,m b(i,k) = alpha*b(i,k) enddo endif enddo else do k = 1,n if (nounit) then if (noconj) then temp = one/a(k,k) else temp = one/dconjg(a(k,k)) endif do i = 1,m b(i,k) = temp*b(i,k) enddo endif do j = k + 1,n if (a(j,k).ne.zero) then if (noconj) then temp = a(j,k) else temp = dconjg(a(j,k)) endif do i = 1,m b(i,j) = b(i,j) - temp*b(i,k) enddo endif enddo if (alpha.ne.one) then do i = 1,m b(i,k) = alpha*b(i,k) enddo endif enddo endif endif endif end subroutine ztrsm !> !!##NAME !! ztrsv(3f) - [BLAS:COMPLEX16_BLAS_LEVEL2] !! !!##SYNOPSIS !! !! subroutine ztrsv(uplo,trans,diag,n,a,lda,x,incx) !! !! .. Scalar Arguments .. !! integer,intent(in) :: incx,lda,n !! character,intent(in) :: diag,trans,uplo !! .. !! .. Array Arguments .. !! complex(kind=real64),intent(in) :: a(lda,*) !! complex(kind=real64),intent(inout) :: x(*) !! .. !! !!##DEFINITION !! !! ZTRSV solves one of the systems of equations !! !! A*x = b, or A**T*x = b, or A**H*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. !! !!##OPTIONS !! !! UPLO !! !! UPLO is 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. !! !! TRANS !! On entry, TRANS specifies the equations to be solved as !! follows: !! !! TRANS = 'N' or 'n' A*x = b. !! !! TRANS = 'T' or 't' A**T*x = b. !! !! TRANS = 'C' or 'c' A**H*x = b. !! !! DIAG !! 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. !! !! N !! On entry, N specifies the order of the matrix A. !! N must be at least zero. !! !! A !! A is complex(kind=real64) array, 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. !! !! LDA !! !! LDA is 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 ). !! !! X !! !! X is complex(kind=real64) array, 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 !! !! INCX is INTEGER !! On entry, INCX specifies the increment for the elements of !! X. INCX must not be zero. !! !!##AUTHORS !! !! + Univ. of Tennessee !! + Univ. of California Berkeley !! + Univ. of Colorado Denver !! + NAG Ltd. !! !! date:December 2016 !! !! FURTHER DETAILS !! !! 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. !! !!##SEE ALSO !! Online html documentation available at !! http://www.netlib.org/lapack/explore-html/ ! ===================================================================== subroutine ztrsv(uplo,trans,diag,n,a,lda,x,incx) implicit none ! ! -- Reference BLAS level2 routine (version 3.7.0) -- ! -- Reference BLAS is a software package provided by Univ. of Tennessee, -- ! -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- ! December 2016 ! ! .. Scalar Arguments .. integer,intent(in) :: incx,lda,n character,intent(in) :: diag,trans,uplo ! .. ! .. Array Arguments .. complex(kind=real64),intent(in) :: a(lda,*) complex(kind=real64),intent(inout) :: x(*) ! .. ! ! ===================================================================== ! ! .. Parameters .. complex(kind=real64) :: zero parameter (zero= (0.0d+0,0.0d+0)) ! .. ! .. Local Scalars .. complex(kind=real64) :: temp integer i,info,ix,j,jx,kx logical noconj,nounit ! .. ! .. External Functions .. ! LOGICAL LSAME ! EXTERNAL LSAME ! .. ! .. External Subroutines .. ! EXTERNAL XERBLA ! .. ! .. Intrinsic Functions .. intrinsic dconjg,max ! .. ! ! Test the input parameters. ! info = 0 if (.not.lsame(uplo,'U') .and. .not.lsame(uplo,'L')) then info = 1 elseif (.not.lsame(trans,'N') .and. .not.lsame(trans,'T') .and. .not.lsame(trans,'C')) then info = 2 elseif (.not.lsame(diag,'U') .and. .not.lsame(diag,'N')) then info = 3 elseif (n.lt.0) then info = 4 elseif (lda.lt.max(1,n)) then info = 6 elseif (incx.eq.0) then info = 8 endif if (info.ne.0) then call xerbla('ZTRSV ',info) return endif ! ! Quick return if possible. ! if (n.eq.0) return ! noconj = lsame(trans,'T') nounit = lsame(diag,'N') ! ! Set up the start point in X if the increment is not unity. This ! will be ( N - 1 )*INCX too small for descending loops. ! if (incx.le.0) then kx = 1 - (n-1)*incx elseif (incx.ne.1) then kx = 1 endif ! ! Start the operations. In this version the elements of A are ! accessed sequentially with one pass through A. ! if (lsame(trans,'N')) then ! ! Form x := inv( A )*x. ! if (lsame(uplo,'U')) then if (incx.eq.1) then do j = n,1,-1 if (x(j).ne.zero) then if (nounit) x(j) = x(j)/a(j,j) temp = x(j) do i = j - 1,1,-1 x(i) = x(i) - temp*a(i,j) enddo endif enddo else jx = kx + (n-1)*incx do j = n,1,-1 if (x(jx).ne.zero) then if (nounit) x(jx) = x(jx)/a(j,j) temp = x(jx) ix = jx do i = j - 1,1,-1 ix = ix - incx x(ix) = x(ix) - temp*a(i,j) enddo endif jx = jx - incx enddo endif else if (incx.eq.1) then do j = 1,n if (x(j).ne.zero) then if (nounit) x(j) = x(j)/a(j,j) temp = x(j) do i = j + 1,n x(i) = x(i) - temp*a(i,j) enddo endif enddo else jx = kx do j = 1,n if (x(jx).ne.zero) then if (nounit) x(jx) = x(jx)/a(j,j) temp = x(jx) ix = jx do i = j + 1,n ix = ix + incx x(ix) = x(ix) - temp*a(i,j) enddo endif jx = jx + incx enddo endif endif else ! ! Form x := inv( A**T )*x or x := inv( A**H )*x. ! if (lsame(uplo,'U')) then if (incx.eq.1) then do j = 1,n temp = x(j) if (noconj) then do i = 1,j - 1 temp = temp - a(i,j)*x(i) enddo if (nounit) temp = temp/a(j,j) else do i = 1,j - 1 temp = temp - dconjg(a(i,j))*x(i) enddo if (nounit) temp = temp/dconjg(a(j,j)) endif x(j) = temp enddo else jx = kx do j = 1,n ix = kx temp = x(jx) if (noconj) then do i = 1,j - 1 temp = temp - a(i,j)*x(ix) ix = ix + incx enddo if (nounit) temp = temp/a(j,j) else do i = 1,j - 1 temp = temp - dconjg(a(i,j))*x(ix) ix = ix + incx enddo if (nounit) temp = temp/dconjg(a(j,j)) endif x(jx) = temp jx = jx + incx enddo endif else if (incx.eq.1) then do j = n,1,-1 temp = x(j) if (noconj) then do i = n,j + 1,-1 temp = temp - a(i,j)*x(i) enddo if (nounit) temp = temp/a(j,j) else do i = n,j + 1,-1 temp = temp - dconjg(a(i,j))*x(i) enddo if (nounit) temp = temp/dconjg(a(j,j)) endif x(j) = temp enddo else kx = kx + (n-1)*incx jx = kx do j = n,1,-1 ix = kx temp = x(jx) if (noconj) then do i = n,j + 1,-1 temp = temp - a(i,j)*x(ix) ix = ix - incx enddo if (nounit) temp = temp/a(j,j) else do i = n,j + 1,-1 temp = temp - dconjg(a(i,j))*x(ix) ix = ix - incx enddo if (nounit) temp = temp/dconjg(a(j,j)) endif x(jx) = temp jx = jx - incx enddo endif endif endif end subroutine ztrsv end module M_blas