module blas3 implicit none private integer,parameter:: skind = kind(1.e0), dkind = kind(1.d0) ! ones real(skind),parameter:: s_one = real(1,kind=skind) real(dkind),parameter:: d_one = real(1,kind=dkind) complex(skind),parameter:: c_one = cmplx(1,kind=skind) complex(dkind),parameter:: z_one = cmplx(1,kind=dkind) ! zeros real(skind),parameter:: s_zero = real(0,kind=skind) real(dkind),parameter:: d_zero = real(0,kind=dkind) complex(skind),parameter:: c_zero = cmplx(0,kind=skind) complex(dkind),parameter:: z_zero = cmplx(0,kind=dkind) character,parameter:: blas_trans = "T" character,parameter:: blas_no_trans = "N" character,parameter:: blas_conj_trans = "H" character,parameter:: blas_lower = "L" character,parameter:: blas_upper = "U" character,parameter:: blas_unit_diag = "U" character,parameter:: blas_non_unit_diag = "N" character,parameter:: blas_left_side = "L" character,parameter:: blas_right_side = "R" public blas_trans, blas_no_trans, blas_conj_trans public blas_lower, blas_upper public blas_unit_diag, blas_non_unit_diag public blas_left_side, blas_right_side ! sizeof is a less common extension, so provide sizes manually integer,parameter:: s_size = 4 integer,parameter:: d_size = 8 integer,parameter:: c_size = 2*s_size integer,parameter:: z_size = 2*d_size ! this is safe version interface GEMM module procedure sGEMV_95 module procedure dGEMV_95 module procedure cGEMV_95 module procedure zGEMV_95 end interface public GEMM interface SYMM module procedure sSYMV_95 module procedure dSYMV_95 end interface public SYMM interface HEMM module procedure cHEMV_95 module procedure zHEMV_95 end interface public HEMM interface TRMM module procedure sTRMV_95 module procedure dTRMV_95 module procedure cTRMV_95 module procedure zTRMV_95 end interface public TRMM interface TRSM module procedure sTRSV_95 module procedure dTRSV_95 module procedure cTRSV_95 module procedure zTRSV_95 end interface public TRSM interface GEMM module procedure sGER_95 module procedure dGER_95 end interface ! GEMM already public interface GEMM module procedure cGERUC_95 module procedure zGERUC_95 end interface ! GEMM already public interface SYRK module procedure sSYR_95 module procedure dSYR_95 end interface public SYRK interface HERK module procedure cHER_95 module procedure zHER_95 end interface public HERK interface SYR2K module procedure sSYR2_95 module procedure dSYR2_95 end interface public SYR2K interface HER2K module procedure cHER2_95 module procedure zHER2_95 end interface public HER2K interface GEMM module procedure sGEMM_95 module procedure dGEMM_95 module procedure cGEMM_95 module procedure zGEMM_95 end interface ! GEMM already public interface SYMM module procedure sSYMM_95 module procedure dSYMM_95 module procedure cSYMM_95 module procedure zSYMM_95 end interface ! SYMM already public interface HEMM module procedure cHEMM_95 module procedure zHEMM_95 end interface ! HEMM already public interface TRMM module procedure sTRMM_95 module procedure dTRMM_95 module procedure cTRMM_95 module procedure zTRMM_95 end interface ! TRMM already public interface TRSM module procedure sTRSM_95 module procedure dTRSM_95 module procedure cTRSM_95 module procedure zTRSM_95 end interface ! TRSM already public interface SYRK module procedure sSYRK_95 module procedure dSYRK_95 end interface ! SYRK already public interface HERK module procedure cHERK_95 module procedure zHERK_95 end interface ! HERK already public interface SYR2K module procedure sSYR2K_95 module procedure dSYR2K_95 end interface ! SYR2K already public interface HER2K module procedure cHER2K_95 module procedure zHER2K_95 end interface ! HER2K already public external:: sblas3_gescal external:: dblas3_gescal external:: cblas3_gescal external:: zblas3_gescal external:: sblas3_syscal external:: dblas3_syscal external:: cblas3_syscal external:: zblas3_syscal contains subroutine smatext(mat,ppmat,ldmat,wwmat) real(skind),target:: mat(:,:) real(skind),pointer:: ppmat,wwmat(:,:) integer,intent(out):: ldmat if (size(mat,1) > 1) then if (loc(mat(2,1)) - loc(mat(1,1)) /= s_size) goto 1 end if ldmat = 1 if (size(mat,2) > 1) ldmat = (loc(mat(1,2)) - loc(mat(1,1))) / s_size if (ldmat < 0) goto 1 ppmat => mat(1,1) return 1 continue allocate(wwmat(size(mat,1),size(mat,2))) ppmat => wwmat(1,1) ldmat = size(mat,1) end subroutine subroutine dmatext(mat,ppmat,ldmat,wwmat) real(dkind),target:: mat(:,:) real(dkind),pointer:: ppmat,wwmat(:,:) integer,intent(out):: ldmat if (size(mat,1) > 1) then if (loc(mat(2,1)) - loc(mat(1,1)) /= d_size) goto 1 end if ldmat = 1 if (size(mat,2) > 1) ldmat = (loc(mat(1,2)) - loc(mat(1,1))) / d_size if (ldmat < 0) goto 1 ppmat => mat(1,1) return 1 continue allocate(wwmat(size(mat,1),size(mat,2))) ppmat => wwmat(1,1) ldmat = size(mat,1) end subroutine subroutine cmatext(mat,ppmat,ldmat,wwmat) complex(skind),target:: mat(:,:) complex(skind),pointer:: ppmat,wwmat(:,:) integer,intent(out):: ldmat if (size(mat,1) > 1) then if (loc(mat(2,1)) - loc(mat(1,1)) /= c_size) goto 1 end if ldmat = 1 if (size(mat,2) > 1) ldmat = (loc(mat(1,2)) - loc(mat(1,1))) / c_size if (ldmat < 0) goto 1 ppmat => mat(1,1) return 1 continue allocate(wwmat(size(mat,1),size(mat,2))) ppmat => wwmat(1,1) ldmat = size(mat,1) end subroutine subroutine zmatext(mat,ppmat,ldmat,wwmat) complex(dkind),target:: mat(:,:) complex(dkind),pointer:: ppmat,wwmat(:,:) integer,intent(out):: ldmat if (size(mat,1) > 1) then if (loc(mat(2,1)) - loc(mat(1,1)) /= z_size) goto 1 end if ldmat = 1 if (size(mat,2) > 1) ldmat = (loc(mat(1,2)) - loc(mat(1,1))) / z_size if (ldmat < 0) goto 1 ppmat => mat(1,1) return 1 continue allocate(wwmat(size(mat,1),size(mat,2))) ppmat => wwmat(1,1) ldmat = size(mat,1) end subroutine !================================================================================ ! LEVEL 2 BLAS routines !================================================================================ !======================================== ! GEMV implementation subroutine sGEMV_95(a,b,c,transa,alpha,beta) real(skind),dimension(:,:),intent(in),target:: a real(skind),pointer:: ppa,wwa(:,:) integer:: lda real(skind),dimension(:),intent(in):: b integer:: incb real(skind),dimension(:),intent(inout):: c integer:: incc real(skind),intent(in),optional:: alpha real(skind):: valpha real(skind),intent(in),optional:: beta real(skind):: vbeta character,intent(in),optional:: transa character:: vtransa integer:: m integer:: n n = size(a,2) if (n == 0) return m = size(a,1) if (m == 0) return vtransa = blas_no_trans if (present(transa)) vtransa = transa vbeta = s_zero if (present(beta)) vbeta = beta valpha = s_one if (present(alpha)) valpha = alpha incc = 1 if (size(c) > 1) incc = (loc(c(2)) - loc(c(1)))/s_size incb = 1 if (size(b) > 1) incb = (loc(b(2)) - loc(b(1)))/s_size ! end init call smatext(a,ppa,lda,wwa) if (.not.associated(ppa,a(1,1))) wwa = a ! end copy call sGEMV(vtransa,m,n,valpha,& ppa,lda,b(1),incb,vbeta,c(1),incc) if (.not.associated(ppa,a(1,1))) then deallocate(wwa) end if ! end uncopy end subroutine subroutine dGEMV_95(a,b,c,transa,alpha,beta) real(dkind),dimension(:,:),intent(in),target:: a real(dkind),pointer:: ppa,wwa(:,:) integer:: lda real(dkind),dimension(:),intent(in):: b integer:: incb real(dkind),dimension(:),intent(inout):: c integer:: incc real(dkind),intent(in),optional:: alpha real(dkind):: valpha real(dkind),intent(in),optional:: beta real(dkind):: vbeta character,intent(in),optional:: transa character:: vtransa integer:: m integer:: n n = size(a,2) if (n == 0) return m = size(a,1) if (m == 0) return vtransa = blas_no_trans if (present(transa)) vtransa = transa vbeta = d_zero if (present(beta)) vbeta = beta valpha = d_one if (present(alpha)) valpha = alpha incc = 1 if (size(c) > 1) incc = (loc(c(2)) - loc(c(1)))/d_size incb = 1 if (size(b) > 1) incb = (loc(b(2)) - loc(b(1)))/d_size ! end init call dmatext(a,ppa,lda,wwa) if (.not.associated(ppa,a(1,1))) wwa = a ! end copy call dGEMV(vtransa,m,n,valpha,& ppa,lda,b(1),incb,vbeta,c(1),incc) if (.not.associated(ppa,a(1,1))) then deallocate(wwa) end if ! end uncopy end subroutine subroutine cGEMV_95(a,b,c,transa,alpha,beta) complex(skind),dimension(:,:),intent(in),target:: a complex(skind),pointer:: ppa,wwa(:,:) integer:: lda complex(skind),dimension(:),intent(in):: b integer:: incb complex(skind),dimension(:),intent(inout):: c integer:: incc complex(skind),intent(in),optional:: alpha complex(skind):: valpha complex(skind),intent(in),optional:: beta complex(skind):: vbeta character,intent(in),optional:: transa character:: vtransa integer:: m integer:: n n = size(a,2) if (n == 0) return m = size(a,1) if (m == 0) return vtransa = blas_no_trans if (present(transa)) vtransa = transa vbeta = c_zero if (present(beta)) vbeta = beta valpha = c_one if (present(alpha)) valpha = alpha incc = 1 if (size(c) > 1) incc = (loc(c(2)) - loc(c(1)))/c_size incb = 1 if (size(b) > 1) incb = (loc(b(2)) - loc(b(1)))/c_size ! end init call cmatext(a,ppa,lda,wwa) if (.not.associated(ppa,a(1,1))) wwa = a ! end copy call cGEMV(vtransa,m,n,valpha,& ppa,lda,b(1),incb,vbeta,c(1),incc) if (.not.associated(ppa,a(1,1))) then deallocate(wwa) end if ! end uncopy end subroutine subroutine zGEMV_95(a,b,c,transa,alpha,beta) complex(dkind),dimension(:,:),intent(in),target:: a complex(dkind),pointer:: ppa,wwa(:,:) integer:: lda complex(dkind),dimension(:),intent(in):: b integer:: incb complex(dkind),dimension(:),intent(inout):: c integer:: incc complex(dkind),intent(in),optional:: alpha complex(dkind):: valpha complex(dkind),intent(in),optional:: beta complex(dkind):: vbeta character,intent(in),optional:: transa character:: vtransa integer:: m integer:: n n = size(a,2) if (n == 0) return m = size(a,1) if (m == 0) return vtransa = blas_no_trans if (present(transa)) vtransa = transa vbeta = z_zero if (present(beta)) vbeta = beta valpha = z_one if (present(alpha)) valpha = alpha incc = 1 if (size(c) > 1) incc = (loc(c(2)) - loc(c(1)))/z_size incb = 1 if (size(b) > 1) incb = (loc(b(2)) - loc(b(1)))/z_size ! end init call zmatext(a,ppa,lda,wwa) if (.not.associated(ppa,a(1,1))) wwa = a ! end copy call zGEMV(vtransa,m,n,valpha,& ppa,lda,b(1),incb,vbeta,c(1),incc) if (.not.associated(ppa,a(1,1))) then deallocate(wwa) end if ! end uncopy end subroutine !======================================== ! SYMV implementation subroutine sSYMV_95(a,b,c,uplo,alpha,beta) real(skind),dimension(:,:),intent(in),target:: a real(skind),pointer:: ppa,wwa(:,:) integer:: lda real(skind),dimension(:),intent(in):: b integer:: incb real(skind),dimension(:),intent(inout):: c integer:: incc real(skind),intent(in),optional:: alpha real(skind):: valpha real(skind),intent(in),optional:: beta real(skind):: vbeta character,intent(in),optional:: uplo character:: vuplo integer:: n n = size(a,1) if (n == 0) return vuplo = blas_upper if (present(uplo)) vuplo = uplo vbeta = s_zero if (present(beta)) vbeta = beta valpha = s_one if (present(alpha)) valpha = alpha incc = 1 if (size(c) > 1) incc = (loc(c(2)) - loc(c(1)))/s_size incb = 1 if (size(b) > 1) incb = (loc(b(2)) - loc(b(1)))/s_size ! end init call smatext(a,ppa,lda,wwa) if (.not.associated(ppa,a(1,1))) wwa = a ! end copy call sSYMV(vuplo,n,valpha,& ppa,lda,b(1),incb,vbeta,c(1),incc) if (.not.associated(ppa,a(1,1))) then deallocate(wwa) end if ! end uncopy end subroutine subroutine dSYMV_95(a,b,c,uplo,alpha,beta) real(dkind),dimension(:,:),intent(in),target:: a real(dkind),pointer:: ppa,wwa(:,:) integer:: lda real(dkind),dimension(:),intent(in):: b integer:: incb real(dkind),dimension(:),intent(inout):: c integer:: incc real(dkind),intent(in),optional:: alpha real(dkind):: valpha real(dkind),intent(in),optional:: beta real(dkind):: vbeta character,intent(in),optional:: uplo character:: vuplo integer:: n n = size(a,1) if (n == 0) return vuplo = blas_upper if (present(uplo)) vuplo = uplo vbeta = d_zero if (present(beta)) vbeta = beta valpha = d_one if (present(alpha)) valpha = alpha incc = 1 if (size(c) > 1) incc = (loc(c(2)) - loc(c(1)))/d_size incb = 1 if (size(b) > 1) incb = (loc(b(2)) - loc(b(1)))/d_size ! end init call dmatext(a,ppa,lda,wwa) if (.not.associated(ppa,a(1,1))) wwa = a ! end copy call dSYMV(vuplo,n,valpha,& ppa,lda,b(1),incb,vbeta,c(1),incc) if (.not.associated(ppa,a(1,1))) then deallocate(wwa) end if ! end uncopy end subroutine !======================================== ! HEMV implementation subroutine cHEMV_95(a,b,c,uplo,alpha,beta) complex(skind),dimension(:,:),intent(in),target:: a complex(skind),pointer:: ppa,wwa(:,:) integer:: lda complex(skind),dimension(:),intent(in):: b integer:: incb complex(skind),dimension(:),intent(inout):: c integer:: incc complex(skind),intent(in),optional:: alpha complex(skind):: valpha complex(skind),intent(in),optional:: beta complex(skind):: vbeta character,intent(in),optional:: uplo character:: vuplo integer:: n n = size(a,1) if (n == 0) return vuplo = blas_upper if (present(uplo)) vuplo = uplo vbeta = c_zero if (present(beta)) vbeta = beta valpha = c_one if (present(alpha)) valpha = alpha incc = 1 if (size(c) > 1) incc = (loc(c(2)) - loc(c(1)))/c_size incb = 1 if (size(b) > 1) incb = (loc(b(2)) - loc(b(1)))/c_size ! end init call cmatext(a,ppa,lda,wwa) if (.not.associated(ppa,a(1,1))) wwa = a ! end copy call cHEMV(vuplo,n,valpha,& ppa,lda,b(1),incb,vbeta,c(1),incc) if (.not.associated(ppa,a(1,1))) then deallocate(wwa) end if ! end uncopy end subroutine subroutine zHEMV_95(a,b,c,uplo,alpha,beta) complex(dkind),dimension(:,:),intent(in),target:: a complex(dkind),pointer:: ppa,wwa(:,:) integer:: lda complex(dkind),dimension(:),intent(in):: b integer:: incb complex(dkind),dimension(:),intent(inout):: c integer:: incc complex(dkind),intent(in),optional:: alpha complex(dkind):: valpha complex(dkind),intent(in),optional:: beta complex(dkind):: vbeta character,intent(in),optional:: uplo character:: vuplo integer:: n n = size(a,1) if (n == 0) return vuplo = blas_upper if (present(uplo)) vuplo = uplo vbeta = z_zero if (present(beta)) vbeta = beta valpha = z_one if (present(alpha)) valpha = alpha incc = 1 if (size(c) > 1) incc = (loc(c(2)) - loc(c(1)))/z_size incb = 1 if (size(b) > 1) incb = (loc(b(2)) - loc(b(1)))/z_size ! end init call zmatext(a,ppa,lda,wwa) if (.not.associated(ppa,a(1,1))) wwa = a ! end copy call zHEMV(vuplo,n,valpha,& ppa,lda,b(1),incb,vbeta,c(1),incc) if (.not.associated(ppa,a(1,1))) then deallocate(wwa) end if ! end uncopy end subroutine !======================================== ! TRMV implementation subroutine sTRMV_95(t,b,side,uplo,transt,diag,alpha) real(skind),dimension(:,:),intent(in),target:: t real(skind),pointer:: ppt,wwt(:,:) integer:: ldt real(skind),dimension(:),intent(inout):: b integer:: incb character,intent(in),optional:: side character:: vside character,intent(in),optional:: uplo character:: vuplo character,intent(in),optional:: transt character:: vtranst character,intent(in),optional:: diag character:: vdiag real(skind),intent(in),optional:: alpha real(skind):: valpha integer:: n n = size(t,1) if (n == 0) return valpha = s_one if (present(alpha)) valpha = alpha vdiag = blas_non_unit_diag if (present(diag)) vdiag = diag vtranst = blas_no_trans if (present(transt)) vtranst = transt vuplo = blas_upper if (present(uplo)) vuplo = uplo vside = blas_left_side if (present(side)) vside = side incb = 1 if (size(b) > 1) incb = (loc(b(2)) - loc(b(1)))/s_size ! end init if (valpha == s_zero) then b = s_zero return end if call smatext(t,ppt,ldt,wwt) if (.not.associated(ppt,t(1,1))) wwt = t ! end copy call sTRMV(vuplo,vtranst,vdiag,n,ppt,ldt,b(1),incb) call sSCAL(n,valpha,b(1),incb) if (.not.associated(ppt,t(1,1))) then deallocate(wwt) end if ! end uncopy end subroutine subroutine dTRMV_95(t,b,side,uplo,transt,diag,alpha) real(dkind),dimension(:,:),intent(in),target:: t real(dkind),pointer:: ppt,wwt(:,:) integer:: ldt real(dkind),dimension(:),intent(inout):: b integer:: incb character,intent(in),optional:: side character:: vside character,intent(in),optional:: uplo character:: vuplo character,intent(in),optional:: transt character:: vtranst character,intent(in),optional:: diag character:: vdiag real(dkind),intent(in),optional:: alpha real(dkind):: valpha integer:: n n = size(t,1) if (n == 0) return valpha = d_one if (present(alpha)) valpha = alpha vdiag = blas_non_unit_diag if (present(diag)) vdiag = diag vtranst = blas_no_trans if (present(transt)) vtranst = transt vuplo = blas_upper if (present(uplo)) vuplo = uplo vside = blas_left_side if (present(side)) vside = side incb = 1 if (size(b) > 1) incb = (loc(b(2)) - loc(b(1)))/d_size ! end init if (valpha == d_zero) then b = d_zero return end if call dmatext(t,ppt,ldt,wwt) if (.not.associated(ppt,t(1,1))) wwt = t ! end copy call dTRMV(vuplo,vtranst,vdiag,n,ppt,ldt,b(1),incb) call dSCAL(n,valpha,b(1),incb) if (.not.associated(ppt,t(1,1))) then deallocate(wwt) end if ! end uncopy end subroutine subroutine cTRMV_95(t,b,side,uplo,transt,diag,alpha) complex(skind),dimension(:,:),intent(in),target:: t complex(skind),pointer:: ppt,wwt(:,:) integer:: ldt complex(skind),dimension(:),intent(inout):: b integer:: incb character,intent(in),optional:: side character:: vside character,intent(in),optional:: uplo character:: vuplo character,intent(in),optional:: transt character:: vtranst character,intent(in),optional:: diag character:: vdiag complex(skind),intent(in),optional:: alpha complex(skind):: valpha integer:: n n = size(t,1) if (n == 0) return valpha = c_one if (present(alpha)) valpha = alpha vdiag = blas_non_unit_diag if (present(diag)) vdiag = diag vtranst = blas_no_trans if (present(transt)) vtranst = transt vuplo = blas_upper if (present(uplo)) vuplo = uplo vside = blas_left_side if (present(side)) vside = side incb = 1 if (size(b) > 1) incb = (loc(b(2)) - loc(b(1)))/c_size ! end init if (valpha == c_zero) then b = c_zero return end if call cmatext(t,ppt,ldt,wwt) if (.not.associated(ppt,t(1,1))) wwt = t ! end copy call cTRMV(vuplo,vtranst,vdiag,n,ppt,ldt,b(1),incb) call cSCAL(n,valpha,b(1),incb) if (.not.associated(ppt,t(1,1))) then deallocate(wwt) end if ! end uncopy end subroutine subroutine zTRMV_95(t,b,side,uplo,transt,diag,alpha) complex(dkind),dimension(:,:),intent(in),target:: t complex(dkind),pointer:: ppt,wwt(:,:) integer:: ldt complex(dkind),dimension(:),intent(inout):: b integer:: incb character,intent(in),optional:: side character:: vside character,intent(in),optional:: uplo character:: vuplo character,intent(in),optional:: transt character:: vtranst character,intent(in),optional:: diag character:: vdiag complex(dkind),intent(in),optional:: alpha complex(dkind):: valpha integer:: n n = size(t,1) if (n == 0) return valpha = z_one if (present(alpha)) valpha = alpha vdiag = blas_non_unit_diag if (present(diag)) vdiag = diag vtranst = blas_no_trans if (present(transt)) vtranst = transt vuplo = blas_upper if (present(uplo)) vuplo = uplo vside = blas_left_side if (present(side)) vside = side incb = 1 if (size(b) > 1) incb = (loc(b(2)) - loc(b(1)))/z_size ! end init if (valpha == z_zero) then b = z_zero return end if call zmatext(t,ppt,ldt,wwt) if (.not.associated(ppt,t(1,1))) wwt = t ! end copy call zTRMV(vuplo,vtranst,vdiag,n,ppt,ldt,b(1),incb) call zSCAL(n,valpha,b(1),incb) if (.not.associated(ppt,t(1,1))) then deallocate(wwt) end if ! end uncopy end subroutine !======================================== ! TRSV implementation subroutine sTRSV_95(t,b,side,uplo,transt,diag,alpha) real(skind),dimension(:,:),intent(in),target:: t real(skind),pointer:: ppt,wwt(:,:) integer:: ldt real(skind),dimension(:),intent(inout):: b integer:: incb character,intent(in),optional:: side character:: vside character,intent(in),optional:: uplo character:: vuplo character,intent(in),optional:: transt character:: vtranst character,intent(in),optional:: diag character:: vdiag real(skind),intent(in),optional:: alpha real(skind):: valpha integer:: n n = size(t,1) if (n == 0) return valpha = s_one if (present(alpha)) valpha = alpha vdiag = blas_non_unit_diag if (present(diag)) vdiag = diag vtranst = blas_no_trans if (present(transt)) vtranst = transt vuplo = blas_upper if (present(uplo)) vuplo = uplo vside = blas_left_side if (present(side)) vside = side incb = 1 if (size(b) > 1) incb = (loc(b(2)) - loc(b(1)))/s_size ! end init if (valpha == s_zero) then b = s_zero return end if call smatext(t,ppt,ldt,wwt) if (.not.associated(ppt,t(1,1))) wwt = t ! end copy call sTRSV(vuplo,vtranst,vdiag,n,ppt,ldt,b(1),incb) call sSCAL(n,valpha,b(1),incb) if (.not.associated(ppt,t(1,1))) then deallocate(wwt) end if ! end uncopy end subroutine subroutine dTRSV_95(t,b,side,uplo,transt,diag,alpha) real(dkind),dimension(:,:),intent(in),target:: t real(dkind),pointer:: ppt,wwt(:,:) integer:: ldt real(dkind),dimension(:),intent(inout):: b integer:: incb character,intent(in),optional:: side character:: vside character,intent(in),optional:: uplo character:: vuplo character,intent(in),optional:: transt character:: vtranst character,intent(in),optional:: diag character:: vdiag real(dkind),intent(in),optional:: alpha real(dkind):: valpha integer:: n n = size(t,1) if (n == 0) return valpha = d_one if (present(alpha)) valpha = alpha vdiag = blas_non_unit_diag if (present(diag)) vdiag = diag vtranst = blas_no_trans if (present(transt)) vtranst = transt vuplo = blas_upper if (present(uplo)) vuplo = uplo vside = blas_left_side if (present(side)) vside = side incb = 1 if (size(b) > 1) incb = (loc(b(2)) - loc(b(1)))/d_size ! end init if (valpha == d_zero) then b = d_zero return end if call dmatext(t,ppt,ldt,wwt) if (.not.associated(ppt,t(1,1))) wwt = t ! end copy call dTRSV(vuplo,vtranst,vdiag,n,ppt,ldt,b(1),incb) call dSCAL(n,valpha,b(1),incb) if (.not.associated(ppt,t(1,1))) then deallocate(wwt) end if ! end uncopy end subroutine subroutine cTRSV_95(t,b,side,uplo,transt,diag,alpha) complex(skind),dimension(:,:),intent(in),target:: t complex(skind),pointer:: ppt,wwt(:,:) integer:: ldt complex(skind),dimension(:),intent(inout):: b integer:: incb character,intent(in),optional:: side character:: vside character,intent(in),optional:: uplo character:: vuplo character,intent(in),optional:: transt character:: vtranst character,intent(in),optional:: diag character:: vdiag complex(skind),intent(in),optional:: alpha complex(skind):: valpha integer:: n n = size(t,1) if (n == 0) return valpha = c_one if (present(alpha)) valpha = alpha vdiag = blas_non_unit_diag if (present(diag)) vdiag = diag vtranst = blas_no_trans if (present(transt)) vtranst = transt vuplo = blas_upper if (present(uplo)) vuplo = uplo vside = blas_left_side if (present(side)) vside = side incb = 1 if (size(b) > 1) incb = (loc(b(2)) - loc(b(1)))/c_size ! end init if (valpha == c_zero) then b = c_zero return end if call cmatext(t,ppt,ldt,wwt) if (.not.associated(ppt,t(1,1))) wwt = t ! end copy call cTRSV(vuplo,vtranst,vdiag,n,ppt,ldt,b(1),incb) call cSCAL(n,valpha,b(1),incb) if (.not.associated(ppt,t(1,1))) then deallocate(wwt) end if ! end uncopy end subroutine subroutine zTRSV_95(t,b,side,uplo,transt,diag,alpha) complex(dkind),dimension(:,:),intent(in),target:: t complex(dkind),pointer:: ppt,wwt(:,:) integer:: ldt complex(dkind),dimension(:),intent(inout):: b integer:: incb character,intent(in),optional:: side character:: vside character,intent(in),optional:: uplo character:: vuplo character,intent(in),optional:: transt character:: vtranst character,intent(in),optional:: diag character:: vdiag complex(dkind),intent(in),optional:: alpha complex(dkind):: valpha integer:: n n = size(t,1) if (n == 0) return valpha = z_one if (present(alpha)) valpha = alpha vdiag = blas_non_unit_diag if (present(diag)) vdiag = diag vtranst = blas_no_trans if (present(transt)) vtranst = transt vuplo = blas_upper if (present(uplo)) vuplo = uplo vside = blas_left_side if (present(side)) vside = side incb = 1 if (size(b) > 1) incb = (loc(b(2)) - loc(b(1)))/z_size ! end init if (valpha == z_zero) then b = z_zero return end if call zmatext(t,ppt,ldt,wwt) if (.not.associated(ppt,t(1,1))) wwt = t ! end copy call zTRSV(vuplo,vtranst,vdiag,n,ppt,ldt,b(1),incb) call zSCAL(n,valpha,b(1),incb) if (.not.associated(ppt,t(1,1))) then deallocate(wwt) end if ! end uncopy end subroutine !======================================== ! GER implementation subroutine sGER_95(a,b,c,alpha,beta) real(skind),dimension(:),intent(in):: a integer:: inca real(skind),dimension(:),intent(in):: b integer:: incb real(skind),dimension(:,:),intent(inout),target:: c real(skind),pointer:: ppc,wwc(:,:) integer:: ldc real(skind),intent(in),optional:: alpha real(skind):: valpha real(skind),intent(in),optional:: beta real(skind):: vbeta integer:: m integer:: n integer:: j n = size(c,2) if (n == 0) return m = size(c,1) if (m == 0) return vbeta = s_zero if (present(beta)) vbeta = beta valpha = s_one if (present(alpha)) valpha = alpha incb = 1 if (size(b) > 1) incb = (loc(b(2)) - loc(b(1)))/s_size inca = 1 if (size(a) > 1) inca = (loc(a(2)) - loc(a(1)))/s_size ! end init call smatext(c,ppc,ldc,wwc) if (.not.associated(ppc,c(1,1))) wwc = c ! end copy call sgescal(m,n,ppc,ldc,vbeta) call sGER(m,n,valpha,a(1),inca,b(1),incb,ppc,ldc) if (.not.associated(ppc,c(1,1))) then c = wwc deallocate(wwc) end if ! end uncopy end subroutine subroutine dGER_95(a,b,c,alpha,beta) real(dkind),dimension(:),intent(in):: a integer:: inca real(dkind),dimension(:),intent(in):: b integer:: incb real(dkind),dimension(:,:),intent(inout),target:: c real(dkind),pointer:: ppc,wwc(:,:) integer:: ldc real(dkind),intent(in),optional:: alpha real(dkind):: valpha real(dkind),intent(in),optional:: beta real(dkind):: vbeta integer:: m integer:: n integer:: j n = size(c,2) if (n == 0) return m = size(c,1) if (m == 0) return vbeta = d_zero if (present(beta)) vbeta = beta valpha = d_one if (present(alpha)) valpha = alpha incb = 1 if (size(b) > 1) incb = (loc(b(2)) - loc(b(1)))/d_size inca = 1 if (size(a) > 1) inca = (loc(a(2)) - loc(a(1)))/d_size ! end init call dmatext(c,ppc,ldc,wwc) if (.not.associated(ppc,c(1,1))) wwc = c ! end copy call dgescal(m,n,ppc,ldc,vbeta) call dGER(m,n,valpha,a(1),inca,b(1),incb,ppc,ldc) if (.not.associated(ppc,c(1,1))) then c = wwc deallocate(wwc) end if ! end uncopy end subroutine subroutine cGERUC_95(a,b,c,transb,alpha,beta) complex(skind),dimension(:),intent(in):: a integer:: inca complex(skind),dimension(:),intent(in):: b integer:: incb complex(skind),dimension(:,:),intent(inout),target:: c complex(skind),pointer:: ppc,wwc(:,:) integer:: ldc character,intent(in),optional:: transb character:: vtransb complex(skind),intent(in),optional:: alpha complex(skind):: valpha complex(skind),intent(in),optional:: beta complex(skind):: vbeta integer:: m integer:: n integer:: j n = size(c,2) if (n == 0) return m = size(c,1) if (m == 0) return vbeta = c_zero if (present(beta)) vbeta = beta valpha = c_one if (present(alpha)) valpha = alpha vtransb = blas_trans if (present(transb)) vtransb = transb incb = 1 if (size(b) > 1) incb = (loc(b(2)) - loc(b(1)))/c_size inca = 1 if (size(a) > 1) inca = (loc(a(2)) - loc(a(1)))/c_size ! end init call cmatext(c,ppc,ldc,wwc) if (.not.associated(ppc,c(1,1))) wwc = c ! end copy call cgescal(m,n,ppc,ldc,vbeta) if (vtransb == blas_conj_trans) then call cGERC(m,n,valpha,a(1),inca,b(1),incb,ppc,ldc) else call cGERU(m,n,valpha,a(1),inca,b(1),incb,ppc,ldc) end if if (.not.associated(ppc,c(1,1))) then c = wwc deallocate(wwc) end if ! end uncopy end subroutine subroutine zGERUC_95(a,b,c,transb,alpha,beta) complex(dkind),dimension(:),intent(in):: a integer:: inca complex(dkind),dimension(:),intent(in):: b integer:: incb complex(dkind),dimension(:,:),intent(inout),target:: c complex(dkind),pointer:: ppc,wwc(:,:) integer:: ldc character,intent(in),optional:: transb character:: vtransb complex(dkind),intent(in),optional:: alpha complex(dkind):: valpha complex(dkind),intent(in),optional:: beta complex(dkind):: vbeta integer:: m integer:: n integer:: j n = size(c,2) if (n == 0) return m = size(c,1) if (m == 0) return vbeta = z_zero if (present(beta)) vbeta = beta valpha = z_one if (present(alpha)) valpha = alpha vtransb = blas_trans if (present(transb)) vtransb = transb incb = 1 if (size(b) > 1) incb = (loc(b(2)) - loc(b(1)))/z_size inca = 1 if (size(a) > 1) inca = (loc(a(2)) - loc(a(1)))/z_size ! end init call zmatext(c,ppc,ldc,wwc) if (.not.associated(ppc,c(1,1))) wwc = c ! end copy call zgescal(m,n,ppc,ldc,vbeta) if (vtransb == blas_conj_trans) then call zGERC(m,n,valpha,a(1),inca,b(1),incb,ppc,ldc) else call zGERU(m,n,valpha,a(1),inca,b(1),incb,ppc,ldc) end if if (.not.associated(ppc,c(1,1))) then c = wwc deallocate(wwc) end if ! end uncopy end subroutine !======================================== ! SYR implementation subroutine sSYR_95(a,c,uplo,alpha,beta) real(skind),dimension(:),intent(in):: a integer:: inca real(skind),dimension(:,:),intent(inout),target:: c real(skind),pointer:: ppc,wwc(:,:) integer:: ldc character,intent(in),optional:: uplo character:: vuplo real(skind),intent(in),optional:: alpha real(skind):: valpha real(skind),intent(in),optional:: beta real(skind):: vbeta integer:: n integer:: j n = size(c,1) if (n == 0) return vbeta = s_zero if (present(beta)) vbeta = beta valpha = s_one if (present(alpha)) valpha = alpha vuplo = blas_upper if (present(uplo)) vuplo = uplo inca = 1 if (size(a) > 1) inca = (loc(a(2)) - loc(a(1)))/s_size ! end init call smatext(c,ppc,ldc,wwc) if (.not.associated(ppc,c(1,1))) wwc = c ! end copy call ssyscal(n,ppc,ldc,vbeta,vuplo) call sSYR(vuplo,n,valpha,a(1),inca,ppc,ldc) if (.not.associated(ppc,c(1,1))) then c = wwc deallocate(wwc) end if ! end uncopy end subroutine subroutine dSYR_95(a,c,uplo,alpha,beta) real(dkind),dimension(:),intent(in):: a integer:: inca real(dkind),dimension(:,:),intent(inout),target:: c real(dkind),pointer:: ppc,wwc(:,:) integer:: ldc character,intent(in),optional:: uplo character:: vuplo real(dkind),intent(in),optional:: alpha real(dkind):: valpha real(dkind),intent(in),optional:: beta real(dkind):: vbeta integer:: n integer:: j n = size(c,1) if (n == 0) return vbeta = d_zero if (present(beta)) vbeta = beta valpha = d_one if (present(alpha)) valpha = alpha vuplo = blas_upper if (present(uplo)) vuplo = uplo inca = 1 if (size(a) > 1) inca = (loc(a(2)) - loc(a(1)))/d_size ! end init call dmatext(c,ppc,ldc,wwc) if (.not.associated(ppc,c(1,1))) wwc = c ! end copy call dsyscal(n,ppc,ldc,vbeta,vuplo) call dSYR(vuplo,n,valpha,a(1),inca,ppc,ldc) if (.not.associated(ppc,c(1,1))) then c = wwc deallocate(wwc) end if ! end uncopy end subroutine !======================================== ! HER implementation subroutine cHER_95(a,c,uplo,alpha,beta) complex(skind),dimension(:),intent(in):: a integer:: inca complex(skind),dimension(:,:),intent(inout),target:: c complex(skind),pointer:: ppc,wwc(:,:) integer:: ldc character,intent(in),optional:: uplo character:: vuplo complex(skind),intent(in),optional:: alpha complex(skind):: valpha complex(skind),intent(in),optional:: beta complex(skind):: vbeta integer:: n integer:: j n = size(c,1) if (n == 0) return vbeta = c_zero if (present(beta)) vbeta = beta valpha = c_one if (present(alpha)) valpha = alpha vuplo = blas_upper if (present(uplo)) vuplo = uplo inca = 1 if (size(a) > 1) inca = (loc(a(2)) - loc(a(1)))/c_size ! end init call cmatext(c,ppc,ldc,wwc) if (.not.associated(ppc,c(1,1))) wwc = c ! end copy call csyscal(n,ppc,ldc,vbeta,vuplo) call cHER(vuplo,n,valpha,a(1),inca,ppc,ldc) if (.not.associated(ppc,c(1,1))) then c = wwc deallocate(wwc) end if ! end uncopy end subroutine subroutine zHER_95(a,c,uplo,alpha,beta) complex(dkind),dimension(:),intent(in):: a integer:: inca complex(dkind),dimension(:,:),intent(inout),target:: c complex(dkind),pointer:: ppc,wwc(:,:) integer:: ldc character,intent(in),optional:: uplo character:: vuplo complex(dkind),intent(in),optional:: alpha complex(dkind):: valpha complex(dkind),intent(in),optional:: beta complex(dkind):: vbeta integer:: n integer:: j n = size(c,1) if (n == 0) return vbeta = z_zero if (present(beta)) vbeta = beta valpha = z_one if (present(alpha)) valpha = alpha vuplo = blas_upper if (present(uplo)) vuplo = uplo inca = 1 if (size(a) > 1) inca = (loc(a(2)) - loc(a(1)))/z_size ! end init call zmatext(c,ppc,ldc,wwc) if (.not.associated(ppc,c(1,1))) wwc = c ! end copy call zsyscal(n,ppc,ldc,vbeta,vuplo) call zHER(vuplo,n,valpha,a(1),inca,ppc,ldc) if (.not.associated(ppc,c(1,1))) then c = wwc deallocate(wwc) end if ! end uncopy end subroutine !======================================== ! SYR2 implementation subroutine sSYR2_95(a,b,c,uplo,alpha,beta) real(skind),dimension(:),intent(in):: a integer:: inca real(skind),dimension(:),intent(in):: b integer:: incb real(skind),dimension(:,:),intent(inout),target:: c real(skind),pointer:: ppc,wwc(:,:) integer:: ldc character,intent(in),optional:: uplo character:: vuplo real(skind),intent(in),optional:: alpha real(skind):: valpha real(skind),intent(in),optional:: beta real(skind):: vbeta integer:: n integer:: j n = size(c,1) if (n == 0) return vbeta = s_zero if (present(beta)) vbeta = beta valpha = s_one if (present(alpha)) valpha = alpha vuplo = blas_upper if (present(uplo)) vuplo = uplo incb = 1 if (size(b) > 1) incb = (loc(b(2)) - loc(b(1)))/s_size inca = 1 if (size(a) > 1) inca = (loc(a(2)) - loc(a(1)))/s_size ! end init call smatext(c,ppc,ldc,wwc) if (.not.associated(ppc,c(1,1))) wwc = c ! end copy call ssyscal(n,ppc,ldc,vbeta,vuplo) call sSYR2(vuplo,n,valpha,a(1),inca,b(1),incb,ppc,ldc) if (.not.associated(ppc,c(1,1))) then c = wwc deallocate(wwc) end if ! end uncopy end subroutine subroutine dSYR2_95(a,b,c,uplo,alpha,beta) real(dkind),dimension(:),intent(in):: a integer:: inca real(dkind),dimension(:),intent(in):: b integer:: incb real(dkind),dimension(:,:),intent(inout),target:: c real(dkind),pointer:: ppc,wwc(:,:) integer:: ldc character,intent(in),optional:: uplo character:: vuplo real(dkind),intent(in),optional:: alpha real(dkind):: valpha real(dkind),intent(in),optional:: beta real(dkind):: vbeta integer:: n integer:: j n = size(c,1) if (n == 0) return vbeta = d_zero if (present(beta)) vbeta = beta valpha = d_one if (present(alpha)) valpha = alpha vuplo = blas_upper if (present(uplo)) vuplo = uplo incb = 1 if (size(b) > 1) incb = (loc(b(2)) - loc(b(1)))/d_size inca = 1 if (size(a) > 1) inca = (loc(a(2)) - loc(a(1)))/d_size ! end init call dmatext(c,ppc,ldc,wwc) if (.not.associated(ppc,c(1,1))) wwc = c ! end copy call dsyscal(n,ppc,ldc,vbeta,vuplo) call dSYR2(vuplo,n,valpha,a(1),inca,b(1),incb,ppc,ldc) if (.not.associated(ppc,c(1,1))) then c = wwc deallocate(wwc) end if ! end uncopy end subroutine !======================================== ! HER2 implementation subroutine cHER2_95(a,b,c,uplo,alpha,beta) complex(skind),dimension(:),intent(in):: a integer:: inca complex(skind),dimension(:),intent(in):: b integer:: incb complex(skind),dimension(:,:),intent(inout),target:: c complex(skind),pointer:: ppc,wwc(:,:) integer:: ldc character,intent(in),optional:: uplo character:: vuplo complex(skind),intent(in),optional:: alpha complex(skind):: valpha complex(skind),intent(in),optional:: beta complex(skind):: vbeta integer:: n integer:: j n = size(c,1) if (n == 0) return vbeta = c_zero if (present(beta)) vbeta = beta valpha = c_one if (present(alpha)) valpha = alpha vuplo = blas_upper if (present(uplo)) vuplo = uplo incb = 1 if (size(b) > 1) incb = (loc(b(2)) - loc(b(1)))/c_size inca = 1 if (size(a) > 1) inca = (loc(a(2)) - loc(a(1)))/c_size ! end init call cmatext(c,ppc,ldc,wwc) if (.not.associated(ppc,c(1,1))) wwc = c ! end copy call csyscal(n,ppc,ldc,vbeta,vuplo) call cHER2(vuplo,n,valpha,a(1),inca,b(1),incb,ppc,ldc) if (.not.associated(ppc,c(1,1))) then c = wwc deallocate(wwc) end if ! end uncopy end subroutine subroutine zHER2_95(a,b,c,uplo,alpha,beta) complex(dkind),dimension(:),intent(in):: a integer:: inca complex(dkind),dimension(:),intent(in):: b integer:: incb complex(dkind),dimension(:,:),intent(inout),target:: c complex(dkind),pointer:: ppc,wwc(:,:) integer:: ldc character,intent(in),optional:: uplo character:: vuplo complex(dkind),intent(in),optional:: alpha complex(dkind):: valpha complex(dkind),intent(in),optional:: beta complex(dkind):: vbeta integer:: n integer:: j n = size(c,1) if (n == 0) return vbeta = z_zero if (present(beta)) vbeta = beta valpha = z_one if (present(alpha)) valpha = alpha vuplo = blas_upper if (present(uplo)) vuplo = uplo incb = 1 if (size(b) > 1) incb = (loc(b(2)) - loc(b(1)))/z_size inca = 1 if (size(a) > 1) inca = (loc(a(2)) - loc(a(1)))/z_size ! end init call zmatext(c,ppc,ldc,wwc) if (.not.associated(ppc,c(1,1))) wwc = c ! end copy call zsyscal(n,ppc,ldc,vbeta,vuplo) call zHER2(vuplo,n,valpha,a(1),inca,b(1),incb,ppc,ldc) if (.not.associated(ppc,c(1,1))) then c = wwc deallocate(wwc) end if ! end uncopy end subroutine !================================================================================ ! LEVEL 3 BLAS routines !================================================================================ !======================================== ! GEMM implementation subroutine sGEMM_95(a,b,c,transa,transb,alpha,beta) real(skind),dimension(:,:),intent(in),target:: a real(skind),pointer:: ppa,wwa(:,:) integer:: lda real(skind),dimension(:,:),intent(in),target:: b real(skind),pointer:: ppb,wwb(:,:) integer:: ldb real(skind),dimension(:,:),intent(inout),target:: c real(skind),pointer:: ppc,wwc(:,:) integer:: ldc character,intent(in),optional:: transa character:: vtransa character,intent(in),optional:: transb character:: vtransb real(skind),intent(in),optional:: alpha real(skind):: valpha real(skind),intent(in),optional:: beta real(skind):: vbeta integer:: m integer:: n integer:: k n = size(c,2) if (n == 0) return m = size(c,1) if (m == 0) return vbeta = s_zero if (present(beta)) vbeta = beta valpha = s_one if (present(alpha)) valpha = alpha vtransb = blas_no_trans if (present(transb)) vtransb = transb vtransa = blas_no_trans if (present(transa)) vtransa = transa ! end init k = merge(size(a,1),size(a,2),vtransa == blas_no_trans) if (k == 0) return call smatext(c,ppc,ldc,wwc) if (.not.associated(ppc,c(1,1))) wwc = c call smatext(b,ppb,ldb,wwb) if (.not.associated(ppb,b(1,1))) wwb = b call smatext(a,ppa,lda,wwa) if (.not.associated(ppa,a(1,1))) wwa = a ! end copy call sGEMM(vtransa,vtransb,m,n,k,valpha,ppa,lda,ppb,ldb,vbeta,ppc,ldc) if (.not.associated(ppc,c(1,1))) then c = wwc deallocate(wwc) end if if (.not.associated(ppb,b(1,1))) then deallocate(wwb) end if if (.not.associated(ppa,a(1,1))) then deallocate(wwa) end if ! end uncopy end subroutine subroutine dGEMM_95(a,b,c,transa,transb,alpha,beta) real(dkind),dimension(:,:),intent(in),target:: a real(dkind),pointer:: ppa,wwa(:,:) integer:: lda real(dkind),dimension(:,:),intent(in),target:: b real(dkind),pointer:: ppb,wwb(:,:) integer:: ldb real(dkind),dimension(:,:),intent(inout),target:: c real(dkind),pointer:: ppc,wwc(:,:) integer:: ldc character,intent(in),optional:: transa character:: vtransa character,intent(in),optional:: transb character:: vtransb real(dkind),intent(in),optional:: alpha real(dkind):: valpha real(dkind),intent(in),optional:: beta real(dkind):: vbeta integer:: m integer:: n integer:: k n = size(c,2) if (n == 0) return m = size(c,1) if (m == 0) return vbeta = d_zero if (present(beta)) vbeta = beta valpha = d_one if (present(alpha)) valpha = alpha vtransb = blas_no_trans if (present(transb)) vtransb = transb vtransa = blas_no_trans if (present(transa)) vtransa = transa ! end init k = merge(size(a,1),size(a,2),vtransa == blas_no_trans) if (k == 0) return call dmatext(c,ppc,ldc,wwc) if (.not.associated(ppc,c(1,1))) wwc = c call dmatext(b,ppb,ldb,wwb) if (.not.associated(ppb,b(1,1))) wwb = b call dmatext(a,ppa,lda,wwa) if (.not.associated(ppa,a(1,1))) wwa = a ! end copy call dGEMM(vtransa,vtransb,m,n,k,valpha,ppa,lda,ppb,ldb,vbeta,ppc,ldc) if (.not.associated(ppc,c(1,1))) then c = wwc deallocate(wwc) end if if (.not.associated(ppb,b(1,1))) then deallocate(wwb) end if if (.not.associated(ppa,a(1,1))) then deallocate(wwa) end if ! end uncopy end subroutine subroutine cGEMM_95(a,b,c,transa,transb,alpha,beta) complex(skind),dimension(:,:),intent(in),target:: a complex(skind),pointer:: ppa,wwa(:,:) integer:: lda complex(skind),dimension(:,:),intent(in),target:: b complex(skind),pointer:: ppb,wwb(:,:) integer:: ldb complex(skind),dimension(:,:),intent(inout),target:: c complex(skind),pointer:: ppc,wwc(:,:) integer:: ldc character,intent(in),optional:: transa character:: vtransa character,intent(in),optional:: transb character:: vtransb complex(skind),intent(in),optional:: alpha complex(skind):: valpha complex(skind),intent(in),optional:: beta complex(skind):: vbeta integer:: m integer:: n integer:: k n = size(c,2) if (n == 0) return m = size(c,1) if (m == 0) return vbeta = c_zero if (present(beta)) vbeta = beta valpha = c_one if (present(alpha)) valpha = alpha vtransb = blas_no_trans if (present(transb)) vtransb = transb vtransa = blas_no_trans if (present(transa)) vtransa = transa ! end init k = merge(size(a,1),size(a,2),vtransa == blas_no_trans) if (k == 0) return call cmatext(c,ppc,ldc,wwc) if (.not.associated(ppc,c(1,1))) wwc = c call cmatext(b,ppb,ldb,wwb) if (.not.associated(ppb,b(1,1))) wwb = b call cmatext(a,ppa,lda,wwa) if (.not.associated(ppa,a(1,1))) wwa = a ! end copy call cGEMM(vtransa,vtransb,m,n,k,valpha,ppa,lda,ppb,ldb,vbeta,ppc,ldc) if (.not.associated(ppc,c(1,1))) then c = wwc deallocate(wwc) end if if (.not.associated(ppb,b(1,1))) then deallocate(wwb) end if if (.not.associated(ppa,a(1,1))) then deallocate(wwa) end if ! end uncopy end subroutine subroutine zGEMM_95(a,b,c,transa,transb,alpha,beta) complex(dkind),dimension(:,:),intent(in),target:: a complex(dkind),pointer:: ppa,wwa(:,:) integer:: lda complex(dkind),dimension(:,:),intent(in),target:: b complex(dkind),pointer:: ppb,wwb(:,:) integer:: ldb complex(dkind),dimension(:,:),intent(inout),target:: c complex(dkind),pointer:: ppc,wwc(:,:) integer:: ldc character,intent(in),optional:: transa character:: vtransa character,intent(in),optional:: transb character:: vtransb complex(dkind),intent(in),optional:: alpha complex(dkind):: valpha complex(dkind),intent(in),optional:: beta complex(dkind):: vbeta integer:: m integer:: n integer:: k n = size(c,2) if (n == 0) return m = size(c,1) if (m == 0) return vbeta = z_zero if (present(beta)) vbeta = beta valpha = z_one if (present(alpha)) valpha = alpha vtransb = blas_no_trans if (present(transb)) vtransb = transb vtransa = blas_no_trans if (present(transa)) vtransa = transa ! end init k = merge(size(a,1),size(a,2),vtransa == blas_no_trans) if (k == 0) return call zmatext(c,ppc,ldc,wwc) if (.not.associated(ppc,c(1,1))) wwc = c call zmatext(b,ppb,ldb,wwb) if (.not.associated(ppb,b(1,1))) wwb = b call zmatext(a,ppa,lda,wwa) if (.not.associated(ppa,a(1,1))) wwa = a ! end copy call zGEMM(vtransa,vtransb,m,n,k,valpha,ppa,lda,ppb,ldb,vbeta,ppc,ldc) if (.not.associated(ppc,c(1,1))) then c = wwc deallocate(wwc) end if if (.not.associated(ppb,b(1,1))) then deallocate(wwb) end if if (.not.associated(ppa,a(1,1))) then deallocate(wwa) end if ! end uncopy end subroutine !======================================== ! SYMM implementation subroutine sSYMM_95(a,b,c,side,uplo,alpha,beta) real(skind),dimension(:,:),intent(in),target:: a real(skind),pointer:: ppa,wwa(:,:) integer:: lda real(skind),dimension(:,:),intent(in),target:: b real(skind),pointer:: ppb,wwb(:,:) integer:: ldb real(skind),dimension(:,:),intent(inout),target:: c real(skind),pointer:: ppc,wwc(:,:) integer:: ldc real(skind),intent(in),optional:: alpha real(skind):: valpha real(skind),intent(in),optional:: beta real(skind):: vbeta character,intent(in),optional:: side character:: vside character,intent(in),optional:: uplo character:: vuplo integer:: m integer:: n n = size(c,2) if (n == 0) return m = size(c,1) if (m == 0) return vuplo = blas_upper if (present(uplo)) vuplo = uplo vside = blas_left_side if (present(side)) vside = side vbeta = s_zero if (present(beta)) vbeta = beta valpha = s_one if (present(alpha)) valpha = alpha ! end init call smatext(c,ppc,ldc,wwc) if (.not.associated(ppc,c(1,1))) wwc = c call smatext(b,ppb,ldb,wwb) if (.not.associated(ppb,b(1,1))) wwb = b call smatext(a,ppa,lda,wwa) if (.not.associated(ppa,a(1,1))) wwa = a ! end copy call sSYMM(vside,vuplo,m,n,valpha,ppa,lda,ppb,ldb,vbeta,ppc,ldc) if (.not.associated(ppc,c(1,1))) then c = wwc deallocate(wwc) end if if (.not.associated(ppb,b(1,1))) then deallocate(wwb) end if if (.not.associated(ppa,a(1,1))) then deallocate(wwa) end if ! end uncopy end subroutine subroutine dSYMM_95(a,b,c,side,uplo,alpha,beta) real(dkind),dimension(:,:),intent(in),target:: a real(dkind),pointer:: ppa,wwa(:,:) integer:: lda real(dkind),dimension(:,:),intent(in),target:: b real(dkind),pointer:: ppb,wwb(:,:) integer:: ldb real(dkind),dimension(:,:),intent(inout),target:: c real(dkind),pointer:: ppc,wwc(:,:) integer:: ldc real(dkind),intent(in),optional:: alpha real(dkind):: valpha real(dkind),intent(in),optional:: beta real(dkind):: vbeta character,intent(in),optional:: side character:: vside character,intent(in),optional:: uplo character:: vuplo integer:: m integer:: n n = size(c,2) if (n == 0) return m = size(c,1) if (m == 0) return vuplo = blas_upper if (present(uplo)) vuplo = uplo vside = blas_left_side if (present(side)) vside = side vbeta = d_zero if (present(beta)) vbeta = beta valpha = d_one if (present(alpha)) valpha = alpha ! end init call dmatext(c,ppc,ldc,wwc) if (.not.associated(ppc,c(1,1))) wwc = c call dmatext(b,ppb,ldb,wwb) if (.not.associated(ppb,b(1,1))) wwb = b call dmatext(a,ppa,lda,wwa) if (.not.associated(ppa,a(1,1))) wwa = a ! end copy call dSYMM(vside,vuplo,m,n,valpha,ppa,lda,ppb,ldb,vbeta,ppc,ldc) if (.not.associated(ppc,c(1,1))) then c = wwc deallocate(wwc) end if if (.not.associated(ppb,b(1,1))) then deallocate(wwb) end if if (.not.associated(ppa,a(1,1))) then deallocate(wwa) end if ! end uncopy end subroutine subroutine cSYMM_95(a,b,c,side,uplo,alpha,beta) complex(skind),dimension(:,:),intent(in),target:: a complex(skind),pointer:: ppa,wwa(:,:) integer:: lda complex(skind),dimension(:,:),intent(in),target:: b complex(skind),pointer:: ppb,wwb(:,:) integer:: ldb complex(skind),dimension(:,:),intent(inout),target:: c complex(skind),pointer:: ppc,wwc(:,:) integer:: ldc complex(skind),intent(in),optional:: alpha complex(skind):: valpha complex(skind),intent(in),optional:: beta complex(skind):: vbeta character,intent(in),optional:: side character:: vside character,intent(in),optional:: uplo character:: vuplo integer:: m integer:: n n = size(c,2) if (n == 0) return m = size(c,1) if (m == 0) return vuplo = blas_upper if (present(uplo)) vuplo = uplo vside = blas_left_side if (present(side)) vside = side vbeta = c_zero if (present(beta)) vbeta = beta valpha = c_one if (present(alpha)) valpha = alpha ! end init call cmatext(c,ppc,ldc,wwc) if (.not.associated(ppc,c(1,1))) wwc = c call cmatext(b,ppb,ldb,wwb) if (.not.associated(ppb,b(1,1))) wwb = b call cmatext(a,ppa,lda,wwa) if (.not.associated(ppa,a(1,1))) wwa = a ! end copy call cSYMM(vside,vuplo,m,n,valpha,ppa,lda,ppb,ldb,vbeta,ppc,ldc) if (.not.associated(ppc,c(1,1))) then c = wwc deallocate(wwc) end if if (.not.associated(ppb,b(1,1))) then deallocate(wwb) end if if (.not.associated(ppa,a(1,1))) then deallocate(wwa) end if ! end uncopy end subroutine subroutine zSYMM_95(a,b,c,side,uplo,alpha,beta) complex(dkind),dimension(:,:),intent(in),target:: a complex(dkind),pointer:: ppa,wwa(:,:) integer:: lda complex(dkind),dimension(:,:),intent(in),target:: b complex(dkind),pointer:: ppb,wwb(:,:) integer:: ldb complex(dkind),dimension(:,:),intent(inout),target:: c complex(dkind),pointer:: ppc,wwc(:,:) integer:: ldc complex(dkind),intent(in),optional:: alpha complex(dkind):: valpha complex(dkind),intent(in),optional:: beta complex(dkind):: vbeta character,intent(in),optional:: side character:: vside character,intent(in),optional:: uplo character:: vuplo integer:: m integer:: n n = size(c,2) if (n == 0) return m = size(c,1) if (m == 0) return vuplo = blas_upper if (present(uplo)) vuplo = uplo vside = blas_left_side if (present(side)) vside = side vbeta = z_zero if (present(beta)) vbeta = beta valpha = z_one if (present(alpha)) valpha = alpha ! end init call zmatext(c,ppc,ldc,wwc) if (.not.associated(ppc,c(1,1))) wwc = c call zmatext(b,ppb,ldb,wwb) if (.not.associated(ppb,b(1,1))) wwb = b call zmatext(a,ppa,lda,wwa) if (.not.associated(ppa,a(1,1))) wwa = a ! end copy call zSYMM(vside,vuplo,m,n,valpha,ppa,lda,ppb,ldb,vbeta,ppc,ldc) if (.not.associated(ppc,c(1,1))) then c = wwc deallocate(wwc) end if if (.not.associated(ppb,b(1,1))) then deallocate(wwb) end if if (.not.associated(ppa,a(1,1))) then deallocate(wwa) end if ! end uncopy end subroutine !======================================== ! HEMM implementation subroutine cHEMM_95(a,b,c,side,uplo,alpha,beta) complex(skind),dimension(:,:),intent(in),target:: a complex(skind),pointer:: ppa,wwa(:,:) integer:: lda complex(skind),dimension(:,:),intent(in),target:: b complex(skind),pointer:: ppb,wwb(:,:) integer:: ldb complex(skind),dimension(:,:),intent(inout),target:: c complex(skind),pointer:: ppc,wwc(:,:) integer:: ldc complex(skind),intent(in),optional:: alpha complex(skind):: valpha complex(skind),intent(in),optional:: beta complex(skind):: vbeta character,intent(in),optional:: side character:: vside character,intent(in),optional:: uplo character:: vuplo integer:: m integer:: n n = size(c,2) if (n == 0) return m = size(c,1) if (m == 0) return vuplo = blas_upper if (present(uplo)) vuplo = uplo vside = blas_left_side if (present(side)) vside = side vbeta = c_zero if (present(beta)) vbeta = beta valpha = c_one if (present(alpha)) valpha = alpha ! end init call cmatext(c,ppc,ldc,wwc) if (.not.associated(ppc,c(1,1))) wwc = c call cmatext(b,ppb,ldb,wwb) if (.not.associated(ppb,b(1,1))) wwb = b call cmatext(a,ppa,lda,wwa) if (.not.associated(ppa,a(1,1))) wwa = a ! end copy call cHEMM(vside,vuplo,m,n,valpha,& ppa,lda,ppb,ldb,vbeta,ppc,ldc) if (.not.associated(ppc,c(1,1))) then c = wwc deallocate(wwc) end if if (.not.associated(ppb,b(1,1))) then deallocate(wwb) end if if (.not.associated(ppa,a(1,1))) then deallocate(wwa) end if ! end uncopy end subroutine subroutine zHEMM_95(a,b,c,side,uplo,alpha,beta) complex(dkind),dimension(:,:),intent(in),target:: a complex(dkind),pointer:: ppa,wwa(:,:) integer:: lda complex(dkind),dimension(:,:),intent(in),target:: b complex(dkind),pointer:: ppb,wwb(:,:) integer:: ldb complex(dkind),dimension(:,:),intent(inout),target:: c complex(dkind),pointer:: ppc,wwc(:,:) integer:: ldc complex(dkind),intent(in),optional:: alpha complex(dkind):: valpha complex(dkind),intent(in),optional:: beta complex(dkind):: vbeta character,intent(in),optional:: side character:: vside character,intent(in),optional:: uplo character:: vuplo integer:: m integer:: n n = size(c,2) if (n == 0) return m = size(c,1) if (m == 0) return vuplo = blas_upper if (present(uplo)) vuplo = uplo vside = blas_left_side if (present(side)) vside = side vbeta = z_zero if (present(beta)) vbeta = beta valpha = z_one if (present(alpha)) valpha = alpha ! end init call zmatext(c,ppc,ldc,wwc) if (.not.associated(ppc,c(1,1))) wwc = c call zmatext(b,ppb,ldb,wwb) if (.not.associated(ppb,b(1,1))) wwb = b call zmatext(a,ppa,lda,wwa) if (.not.associated(ppa,a(1,1))) wwa = a ! end copy call zHEMM(vside,vuplo,m,n,valpha,& ppa,lda,ppb,ldb,vbeta,ppc,ldc) if (.not.associated(ppc,c(1,1))) then c = wwc deallocate(wwc) end if if (.not.associated(ppb,b(1,1))) then deallocate(wwb) end if if (.not.associated(ppa,a(1,1))) then deallocate(wwa) end if ! end uncopy end subroutine !======================================== ! TRMM implementation subroutine sTRMM_95(t,b,side,uplo,transt,diag,alpha) real(skind),dimension(:,:),intent(in),target:: t real(skind),pointer:: ppt,wwt(:,:) integer:: ldt real(skind),dimension(:,:),intent(inout),target:: b real(skind),pointer:: ppb,wwb(:,:) integer:: ldb real(skind),intent(in),optional:: alpha real(skind):: valpha character,intent(in),optional:: side character:: vside character,intent(in),optional:: uplo character:: vuplo character,intent(in),optional:: transt character:: vtranst character,intent(in),optional:: diag character:: vdiag integer:: m integer:: n n = size(b,2) if (n == 0) return m = size(b,1) if (m == 0) return vdiag = blas_non_unit_diag if (present(diag)) vdiag = diag vtranst = blas_no_trans if (present(transt)) vtranst = transt vuplo = blas_upper if (present(uplo)) vuplo = uplo vside = blas_left_side if (present(side)) vside = side valpha = s_one if (present(alpha)) valpha = alpha ! end init call smatext(b,ppb,ldb,wwb) if (.not.associated(ppb,b(1,1))) wwb = b call smatext(t,ppt,ldt,wwt) if (.not.associated(ppt,t(1,1))) wwt = t ! end copy call sTRMM(vside,vuplo,vtranst,vdiag,m,n,valpha,ppt,ldt,ppb,ldb) if (.not.associated(ppb,b(1,1))) then b = wwb deallocate(wwb) end if if (.not.associated(ppt,t(1,1))) then deallocate(wwt) end if ! end uncopy end subroutine subroutine dTRMM_95(t,b,side,uplo,transt,diag,alpha) real(dkind),dimension(:,:),intent(in),target:: t real(dkind),pointer:: ppt,wwt(:,:) integer:: ldt real(dkind),dimension(:,:),intent(inout),target:: b real(dkind),pointer:: ppb,wwb(:,:) integer:: ldb real(dkind),intent(in),optional:: alpha real(dkind):: valpha character,intent(in),optional:: side character:: vside character,intent(in),optional:: uplo character:: vuplo character,intent(in),optional:: transt character:: vtranst character,intent(in),optional:: diag character:: vdiag integer:: m integer:: n n = size(b,2) if (n == 0) return m = size(b,1) if (m == 0) return vdiag = blas_non_unit_diag if (present(diag)) vdiag = diag vtranst = blas_no_trans if (present(transt)) vtranst = transt vuplo = blas_upper if (present(uplo)) vuplo = uplo vside = blas_left_side if (present(side)) vside = side valpha = d_one if (present(alpha)) valpha = alpha ! end init call dmatext(b,ppb,ldb,wwb) if (.not.associated(ppb,b(1,1))) wwb = b call dmatext(t,ppt,ldt,wwt) if (.not.associated(ppt,t(1,1))) wwt = t ! end copy call dTRMM(vside,vuplo,vtranst,vdiag,m,n,valpha,ppt,ldt,ppb,ldb) if (.not.associated(ppb,b(1,1))) then b = wwb deallocate(wwb) end if if (.not.associated(ppt,t(1,1))) then deallocate(wwt) end if ! end uncopy end subroutine subroutine cTRMM_95(t,b,side,uplo,transt,diag,alpha) complex(skind),dimension(:,:),intent(in),target:: t complex(skind),pointer:: ppt,wwt(:,:) integer:: ldt complex(skind),dimension(:,:),intent(inout),target:: b complex(skind),pointer:: ppb,wwb(:,:) integer:: ldb complex(skind),intent(in),optional:: alpha complex(skind):: valpha character,intent(in),optional:: side character:: vside character,intent(in),optional:: uplo character:: vuplo character,intent(in),optional:: transt character:: vtranst character,intent(in),optional:: diag character:: vdiag integer:: m integer:: n n = size(b,2) if (n == 0) return m = size(b,1) if (m == 0) return vdiag = blas_non_unit_diag if (present(diag)) vdiag = diag vtranst = blas_no_trans if (present(transt)) vtranst = transt vuplo = blas_upper if (present(uplo)) vuplo = uplo vside = blas_left_side if (present(side)) vside = side valpha = c_one if (present(alpha)) valpha = alpha ! end init call cmatext(b,ppb,ldb,wwb) if (.not.associated(ppb,b(1,1))) wwb = b call cmatext(t,ppt,ldt,wwt) if (.not.associated(ppt,t(1,1))) wwt = t ! end copy call cTRMM(vside,vuplo,vtranst,vdiag,m,n,valpha,ppt,ldt,ppb,ldb) if (.not.associated(ppb,b(1,1))) then b = wwb deallocate(wwb) end if if (.not.associated(ppt,t(1,1))) then deallocate(wwt) end if ! end uncopy end subroutine subroutine zTRMM_95(t,b,side,uplo,transt,diag,alpha) complex(dkind),dimension(:,:),intent(in),target:: t complex(dkind),pointer:: ppt,wwt(:,:) integer:: ldt complex(dkind),dimension(:,:),intent(inout),target:: b complex(dkind),pointer:: ppb,wwb(:,:) integer:: ldb complex(dkind),intent(in),optional:: alpha complex(dkind):: valpha character,intent(in),optional:: side character:: vside character,intent(in),optional:: uplo character:: vuplo character,intent(in),optional:: transt character:: vtranst character,intent(in),optional:: diag character:: vdiag integer:: m integer:: n n = size(b,2) if (n == 0) return m = size(b,1) if (m == 0) return vdiag = blas_non_unit_diag if (present(diag)) vdiag = diag vtranst = blas_no_trans if (present(transt)) vtranst = transt vuplo = blas_upper if (present(uplo)) vuplo = uplo vside = blas_left_side if (present(side)) vside = side valpha = z_one if (present(alpha)) valpha = alpha ! end init call zmatext(b,ppb,ldb,wwb) if (.not.associated(ppb,b(1,1))) wwb = b call zmatext(t,ppt,ldt,wwt) if (.not.associated(ppt,t(1,1))) wwt = t ! end copy call zTRMM(vside,vuplo,vtranst,vdiag,m,n,valpha,ppt,ldt,ppb,ldb) if (.not.associated(ppb,b(1,1))) then b = wwb deallocate(wwb) end if if (.not.associated(ppt,t(1,1))) then deallocate(wwt) end if ! end uncopy end subroutine !======================================== ! TRSM implementation subroutine sTRSM_95(t,b,side,uplo,transt,diag,alpha) real(skind),dimension(:,:),intent(in),target:: t real(skind),pointer:: ppt,wwt(:,:) integer:: ldt real(skind),dimension(:,:),intent(inout),target:: b real(skind),pointer:: ppb,wwb(:,:) integer:: ldb real(skind),intent(in),optional:: alpha real(skind):: valpha character,intent(in),optional:: side character:: vside character,intent(in),optional:: uplo character:: vuplo character,intent(in),optional:: transt character:: vtranst character,intent(in),optional:: diag character:: vdiag integer:: m integer:: n n = size(b,2) if (n == 0) return m = size(b,1) if (m == 0) return vdiag = blas_non_unit_diag if (present(diag)) vdiag = diag vtranst = blas_no_trans if (present(transt)) vtranst = transt vuplo = blas_upper if (present(uplo)) vuplo = uplo vside = blas_left_side if (present(side)) vside = side valpha = s_one if (present(alpha)) valpha = alpha ! end init call smatext(b,ppb,ldb,wwb) if (.not.associated(ppb,b(1,1))) wwb = b call smatext(t,ppt,ldt,wwt) if (.not.associated(ppt,t(1,1))) wwt = t ! end copy call sTRSM(vside,vuplo,vtranst,vdiag,m,n,valpha,ppt,ldt,ppb,ldb) if (.not.associated(ppb,b(1,1))) then b = wwb deallocate(wwb) end if if (.not.associated(ppt,t(1,1))) then deallocate(wwt) end if ! end uncopy end subroutine subroutine dTRSM_95(t,b,side,uplo,transt,diag,alpha) real(dkind),dimension(:,:),intent(in),target:: t real(dkind),pointer:: ppt,wwt(:,:) integer:: ldt real(dkind),dimension(:,:),intent(inout),target:: b real(dkind),pointer:: ppb,wwb(:,:) integer:: ldb real(dkind),intent(in),optional:: alpha real(dkind):: valpha character,intent(in),optional:: side character:: vside character,intent(in),optional:: uplo character:: vuplo character,intent(in),optional:: transt character:: vtranst character,intent(in),optional:: diag character:: vdiag integer:: m integer:: n n = size(b,2) if (n == 0) return m = size(b,1) if (m == 0) return vdiag = blas_non_unit_diag if (present(diag)) vdiag = diag vtranst = blas_no_trans if (present(transt)) vtranst = transt vuplo = blas_upper if (present(uplo)) vuplo = uplo vside = blas_left_side if (present(side)) vside = side valpha = d_one if (present(alpha)) valpha = alpha ! end init call dmatext(b,ppb,ldb,wwb) if (.not.associated(ppb,b(1,1))) wwb = b call dmatext(t,ppt,ldt,wwt) if (.not.associated(ppt,t(1,1))) wwt = t ! end copy call dTRSM(vside,vuplo,vtranst,vdiag,m,n,valpha,ppt,ldt,ppb,ldb) if (.not.associated(ppb,b(1,1))) then b = wwb deallocate(wwb) end if if (.not.associated(ppt,t(1,1))) then deallocate(wwt) end if ! end uncopy end subroutine subroutine cTRSM_95(t,b,side,uplo,transt,diag,alpha) complex(skind),dimension(:,:),intent(in),target:: t complex(skind),pointer:: ppt,wwt(:,:) integer:: ldt complex(skind),dimension(:,:),intent(inout),target:: b complex(skind),pointer:: ppb,wwb(:,:) integer:: ldb complex(skind),intent(in),optional:: alpha complex(skind):: valpha character,intent(in),optional:: side character:: vside character,intent(in),optional:: uplo character:: vuplo character,intent(in),optional:: transt character:: vtranst character,intent(in),optional:: diag character:: vdiag integer:: m integer:: n n = size(b,2) if (n == 0) return m = size(b,1) if (m == 0) return vdiag = blas_non_unit_diag if (present(diag)) vdiag = diag vtranst = blas_no_trans if (present(transt)) vtranst = transt vuplo = blas_upper if (present(uplo)) vuplo = uplo vside = blas_left_side if (present(side)) vside = side valpha = c_one if (present(alpha)) valpha = alpha ! end init call cmatext(b,ppb,ldb,wwb) if (.not.associated(ppb,b(1,1))) wwb = b call cmatext(t,ppt,ldt,wwt) if (.not.associated(ppt,t(1,1))) wwt = t ! end copy call cTRSM(vside,vuplo,vtranst,vdiag,m,n,valpha,ppt,ldt,ppb,ldb) if (.not.associated(ppb,b(1,1))) then b = wwb deallocate(wwb) end if if (.not.associated(ppt,t(1,1))) then deallocate(wwt) end if ! end uncopy end subroutine subroutine zTRSM_95(t,b,side,uplo,transt,diag,alpha) complex(dkind),dimension(:,:),intent(in),target:: t complex(dkind),pointer:: ppt,wwt(:,:) integer:: ldt complex(dkind),dimension(:,:),intent(inout),target:: b complex(dkind),pointer:: ppb,wwb(:,:) integer:: ldb complex(dkind),intent(in),optional:: alpha complex(dkind):: valpha character,intent(in),optional:: side character:: vside character,intent(in),optional:: uplo character:: vuplo character,intent(in),optional:: transt character:: vtranst character,intent(in),optional:: diag character:: vdiag integer:: m integer:: n n = size(b,2) if (n == 0) return m = size(b,1) if (m == 0) return vdiag = blas_non_unit_diag if (present(diag)) vdiag = diag vtranst = blas_no_trans if (present(transt)) vtranst = transt vuplo = blas_upper if (present(uplo)) vuplo = uplo vside = blas_left_side if (present(side)) vside = side valpha = z_one if (present(alpha)) valpha = alpha ! end init call zmatext(b,ppb,ldb,wwb) if (.not.associated(ppb,b(1,1))) wwb = b call zmatext(t,ppt,ldt,wwt) if (.not.associated(ppt,t(1,1))) wwt = t ! end copy call zTRSM(vside,vuplo,vtranst,vdiag,m,n,valpha,ppt,ldt,ppb,ldb) if (.not.associated(ppb,b(1,1))) then b = wwb deallocate(wwb) end if if (.not.associated(ppt,t(1,1))) then deallocate(wwt) end if ! end uncopy end subroutine !======================================== ! SYRK implementation subroutine sSYRK_95(a,c,uplo,trans,alpha,beta) real(skind),dimension(:,:),intent(in),target:: a real(skind),pointer:: ppa,wwa(:,:) integer:: lda real(skind),dimension(:,:),intent(in),target:: c real(skind),pointer:: ppc,wwc(:,:) integer:: ldc real(skind),intent(in),optional:: alpha real(skind):: valpha real(skind),intent(in),optional:: beta real(skind):: vbeta character,intent(in),optional:: uplo character:: vuplo character,intent(in),optional:: trans character:: vtrans integer:: n integer:: k n = size(c,1) if (n == 0) return vtrans = blas_no_trans if (present(trans)) vtrans = trans vuplo = blas_upper if (present(uplo)) vuplo = uplo vbeta = s_zero if (present(beta)) vbeta = beta valpha = s_one if (present(alpha)) valpha = alpha ! end init k = merge(size(a,2),size(a,1),vtrans == blas_no_trans) if (k == 0) return call smatext(c,ppc,ldc,wwc) if (.not.associated(ppc,c(1,1))) wwc = c call smatext(a,ppa,lda,wwa) if (.not.associated(ppa,a(1,1))) wwa = a ! end copy call sSYRK(vuplo,vtrans,n,k,valpha,ppa,lda,vbeta,ppc,ldc) if (.not.associated(ppc,c(1,1))) then deallocate(wwc) end if if (.not.associated(ppa,a(1,1))) then deallocate(wwa) end if ! end uncopy end subroutine subroutine dSYRK_95(a,c,uplo,trans,alpha,beta) real(dkind),dimension(:,:),intent(in),target:: a real(dkind),pointer:: ppa,wwa(:,:) integer:: lda real(dkind),dimension(:,:),intent(in),target:: c real(dkind),pointer:: ppc,wwc(:,:) integer:: ldc real(dkind),intent(in),optional:: alpha real(dkind):: valpha real(dkind),intent(in),optional:: beta real(dkind):: vbeta character,intent(in),optional:: uplo character:: vuplo character,intent(in),optional:: trans character:: vtrans integer:: n integer:: k n = size(c,1) if (n == 0) return vtrans = blas_no_trans if (present(trans)) vtrans = trans vuplo = blas_upper if (present(uplo)) vuplo = uplo vbeta = d_zero if (present(beta)) vbeta = beta valpha = d_one if (present(alpha)) valpha = alpha ! end init k = merge(size(a,2),size(a,1),vtrans == blas_no_trans) if (k == 0) return call dmatext(c,ppc,ldc,wwc) if (.not.associated(ppc,c(1,1))) wwc = c call dmatext(a,ppa,lda,wwa) if (.not.associated(ppa,a(1,1))) wwa = a ! end copy call dSYRK(vuplo,vtrans,n,k,valpha,ppa,lda,vbeta,ppc,ldc) if (.not.associated(ppc,c(1,1))) then deallocate(wwc) end if if (.not.associated(ppa,a(1,1))) then deallocate(wwa) end if ! end uncopy end subroutine subroutine cSYRK_95(a,c,uplo,trans,alpha,beta) complex(skind),dimension(:,:),intent(in),target:: a complex(skind),pointer:: ppa,wwa(:,:) integer:: lda complex(skind),dimension(:,:),intent(in),target:: c complex(skind),pointer:: ppc,wwc(:,:) integer:: ldc complex(skind),intent(in),optional:: alpha complex(skind):: valpha complex(skind),intent(in),optional:: beta complex(skind):: vbeta character,intent(in),optional:: uplo character:: vuplo character,intent(in),optional:: trans character:: vtrans integer:: n integer:: k n = size(c,1) if (n == 0) return vtrans = blas_no_trans if (present(trans)) vtrans = trans vuplo = blas_upper if (present(uplo)) vuplo = uplo vbeta = c_zero if (present(beta)) vbeta = beta valpha = c_one if (present(alpha)) valpha = alpha ! end init k = merge(size(a,2),size(a,1),vtrans == blas_no_trans) if (k == 0) return call cmatext(c,ppc,ldc,wwc) if (.not.associated(ppc,c(1,1))) wwc = c call cmatext(a,ppa,lda,wwa) if (.not.associated(ppa,a(1,1))) wwa = a ! end copy call cSYRK(vuplo,vtrans,n,k,valpha,ppa,lda,vbeta,ppc,ldc) if (.not.associated(ppc,c(1,1))) then deallocate(wwc) end if if (.not.associated(ppa,a(1,1))) then deallocate(wwa) end if ! end uncopy end subroutine subroutine zSYRK_95(a,c,uplo,trans,alpha,beta) complex(dkind),dimension(:,:),intent(in),target:: a complex(dkind),pointer:: ppa,wwa(:,:) integer:: lda complex(dkind),dimension(:,:),intent(in),target:: c complex(dkind),pointer:: ppc,wwc(:,:) integer:: ldc complex(dkind),intent(in),optional:: alpha complex(dkind):: valpha complex(dkind),intent(in),optional:: beta complex(dkind):: vbeta character,intent(in),optional:: uplo character:: vuplo character,intent(in),optional:: trans character:: vtrans integer:: n integer:: k n = size(c,1) if (n == 0) return vtrans = blas_no_trans if (present(trans)) vtrans = trans vuplo = blas_upper if (present(uplo)) vuplo = uplo vbeta = z_zero if (present(beta)) vbeta = beta valpha = z_one if (present(alpha)) valpha = alpha ! end init k = merge(size(a,2),size(a,1),vtrans == blas_no_trans) if (k == 0) return call zmatext(c,ppc,ldc,wwc) if (.not.associated(ppc,c(1,1))) wwc = c call zmatext(a,ppa,lda,wwa) if (.not.associated(ppa,a(1,1))) wwa = a ! end copy call zSYRK(vuplo,vtrans,n,k,valpha,ppa,lda,vbeta,ppc,ldc) if (.not.associated(ppc,c(1,1))) then deallocate(wwc) end if if (.not.associated(ppa,a(1,1))) then deallocate(wwa) end if ! end uncopy end subroutine !======================================== ! HERK implementation subroutine cHERK_95(a,c,uplo,trans,alpha,beta) complex(skind),dimension(:,:),intent(in),target:: a complex(skind),pointer:: ppa,wwa(:,:) integer:: lda complex(skind),dimension(:,:),intent(in),target:: c complex(skind),pointer:: ppc,wwc(:,:) integer:: ldc complex(skind),intent(in),optional:: alpha complex(skind):: valpha complex(skind),intent(in),optional:: beta complex(skind):: vbeta character,intent(in),optional:: uplo character:: vuplo character,intent(in),optional:: trans character:: vtrans integer:: n integer:: k n = size(c,1) if (n == 0) return vtrans = blas_no_trans if (present(trans)) vtrans = trans vuplo = blas_upper if (present(uplo)) vuplo = uplo vbeta = c_zero if (present(beta)) vbeta = beta valpha = c_one if (present(alpha)) valpha = alpha ! end init k = merge(size(a,2),size(a,1),vtrans == blas_no_trans) if (k == 0) return call cmatext(c,ppc,ldc,wwc) if (.not.associated(ppc,c(1,1))) wwc = c call cmatext(a,ppa,lda,wwa) if (.not.associated(ppa,a(1,1))) wwa = a ! end copy call cHERK(vuplo,vtrans,n,k,valpha,ppa,lda,vbeta,ppc,ldc) if (.not.associated(ppc,c(1,1))) then deallocate(wwc) end if if (.not.associated(ppa,a(1,1))) then deallocate(wwa) end if ! end uncopy end subroutine subroutine zHERK_95(a,c,uplo,trans,alpha,beta) complex(dkind),dimension(:,:),intent(in),target:: a complex(dkind),pointer:: ppa,wwa(:,:) integer:: lda complex(dkind),dimension(:,:),intent(in),target:: c complex(dkind),pointer:: ppc,wwc(:,:) integer:: ldc complex(dkind),intent(in),optional:: alpha complex(dkind):: valpha complex(dkind),intent(in),optional:: beta complex(dkind):: vbeta character,intent(in),optional:: uplo character:: vuplo character,intent(in),optional:: trans character:: vtrans integer:: n integer:: k n = size(c,1) if (n == 0) return vtrans = blas_no_trans if (present(trans)) vtrans = trans vuplo = blas_upper if (present(uplo)) vuplo = uplo vbeta = z_zero if (present(beta)) vbeta = beta valpha = z_one if (present(alpha)) valpha = alpha ! end init k = merge(size(a,2),size(a,1),vtrans == blas_no_trans) if (k == 0) return call zmatext(c,ppc,ldc,wwc) if (.not.associated(ppc,c(1,1))) wwc = c call zmatext(a,ppa,lda,wwa) if (.not.associated(ppa,a(1,1))) wwa = a ! end copy call zHERK(vuplo,vtrans,n,k,valpha,ppa,lda,vbeta,ppc,ldc) if (.not.associated(ppc,c(1,1))) then deallocate(wwc) end if if (.not.associated(ppa,a(1,1))) then deallocate(wwa) end if ! end uncopy end subroutine !======================================== ! SYR2K implementation subroutine sSYR2K_95(a,b,c,uplo,trans,alpha,beta) real(skind),dimension(:,:),intent(in),target:: a real(skind),pointer:: ppa,wwa(:,:) integer:: lda real(skind),dimension(:,:),intent(in),target:: b real(skind),pointer:: ppb,wwb(:,:) integer:: ldb real(skind),dimension(:,:),intent(inout),target:: c real(skind),pointer:: ppc,wwc(:,:) integer:: ldc real(skind),intent(in),optional:: alpha real(skind):: valpha real(skind),intent(in),optional:: beta real(skind):: vbeta character,intent(in),optional:: uplo character:: vuplo character,intent(in),optional:: trans character:: vtrans integer:: n integer:: k n = size(c,1) if (n == 0) return vtrans = blas_no_trans if (present(trans)) vtrans = trans vuplo = blas_upper if (present(uplo)) vuplo = uplo vbeta = s_zero if (present(beta)) vbeta = beta valpha = s_one if (present(alpha)) valpha = alpha ! end init k = merge(size(a,2),size(a,1),vtrans == blas_no_trans) if (k == 0) return call smatext(c,ppc,ldc,wwc) if (.not.associated(ppc,c(1,1))) wwc = c call smatext(b,ppb,ldb,wwb) if (.not.associated(ppb,b(1,1))) wwb = b call smatext(a,ppa,lda,wwa) if (.not.associated(ppa,a(1,1))) wwa = a ! end copy call sSYR2K(vuplo,vtrans,n,k,valpha,ppa,lda,ppb,ldb,vbeta,ppc,ldc) if (.not.associated(ppc,c(1,1))) then c = wwc deallocate(wwc) end if if (.not.associated(ppb,b(1,1))) then deallocate(wwb) end if if (.not.associated(ppa,a(1,1))) then deallocate(wwa) end if ! end uncopy end subroutine subroutine dSYR2K_95(a,b,c,uplo,trans,alpha,beta) real(dkind),dimension(:,:),intent(in),target:: a real(dkind),pointer:: ppa,wwa(:,:) integer:: lda real(dkind),dimension(:,:),intent(in),target:: b real(dkind),pointer:: ppb,wwb(:,:) integer:: ldb real(dkind),dimension(:,:),intent(inout),target:: c real(dkind),pointer:: ppc,wwc(:,:) integer:: ldc real(dkind),intent(in),optional:: alpha real(dkind):: valpha real(dkind),intent(in),optional:: beta real(dkind):: vbeta character,intent(in),optional:: uplo character:: vuplo character,intent(in),optional:: trans character:: vtrans integer:: n integer:: k n = size(c,1) if (n == 0) return vtrans = blas_no_trans if (present(trans)) vtrans = trans vuplo = blas_upper if (present(uplo)) vuplo = uplo vbeta = d_zero if (present(beta)) vbeta = beta valpha = d_one if (present(alpha)) valpha = alpha ! end init k = merge(size(a,2),size(a,1),vtrans == blas_no_trans) if (k == 0) return call dmatext(c,ppc,ldc,wwc) if (.not.associated(ppc,c(1,1))) wwc = c call dmatext(b,ppb,ldb,wwb) if (.not.associated(ppb,b(1,1))) wwb = b call dmatext(a,ppa,lda,wwa) if (.not.associated(ppa,a(1,1))) wwa = a ! end copy call dSYR2K(vuplo,vtrans,n,k,valpha,ppa,lda,ppb,ldb,vbeta,ppc,ldc) if (.not.associated(ppc,c(1,1))) then c = wwc deallocate(wwc) end if if (.not.associated(ppb,b(1,1))) then deallocate(wwb) end if if (.not.associated(ppa,a(1,1))) then deallocate(wwa) end if ! end uncopy end subroutine subroutine cSYR2K_95(a,b,c,uplo,trans,alpha,beta) complex(skind),dimension(:,:),intent(in),target:: a complex(skind),pointer:: ppa,wwa(:,:) integer:: lda complex(skind),dimension(:,:),intent(in),target:: b complex(skind),pointer:: ppb,wwb(:,:) integer:: ldb complex(skind),dimension(:,:),intent(inout),target:: c complex(skind),pointer:: ppc,wwc(:,:) integer:: ldc complex(skind),intent(in),optional:: alpha complex(skind):: valpha complex(skind),intent(in),optional:: beta complex(skind):: vbeta character,intent(in),optional:: uplo character:: vuplo character,intent(in),optional:: trans character:: vtrans integer:: n integer:: k n = size(c,1) if (n == 0) return vtrans = blas_no_trans if (present(trans)) vtrans = trans vuplo = blas_upper if (present(uplo)) vuplo = uplo vbeta = c_zero if (present(beta)) vbeta = beta valpha = c_one if (present(alpha)) valpha = alpha ! end init k = merge(size(a,2),size(a,1),vtrans == blas_no_trans) if (k == 0) return call cmatext(c,ppc,ldc,wwc) if (.not.associated(ppc,c(1,1))) wwc = c call cmatext(b,ppb,ldb,wwb) if (.not.associated(ppb,b(1,1))) wwb = b call cmatext(a,ppa,lda,wwa) if (.not.associated(ppa,a(1,1))) wwa = a ! end copy call cSYR2K(vuplo,vtrans,n,k,valpha,ppa,lda,ppb,ldb,vbeta,ppc,ldc) if (.not.associated(ppc,c(1,1))) then c = wwc deallocate(wwc) end if if (.not.associated(ppb,b(1,1))) then deallocate(wwb) end if if (.not.associated(ppa,a(1,1))) then deallocate(wwa) end if ! end uncopy end subroutine subroutine zSYR2K_95(a,b,c,uplo,trans,alpha,beta) complex(dkind),dimension(:,:),intent(in),target:: a complex(dkind),pointer:: ppa,wwa(:,:) integer:: lda complex(dkind),dimension(:,:),intent(in),target:: b complex(dkind),pointer:: ppb,wwb(:,:) integer:: ldb complex(dkind),dimension(:,:),intent(inout),target:: c complex(dkind),pointer:: ppc,wwc(:,:) integer:: ldc complex(dkind),intent(in),optional:: alpha complex(dkind):: valpha complex(dkind),intent(in),optional:: beta complex(dkind):: vbeta character,intent(in),optional:: uplo character:: vuplo character,intent(in),optional:: trans character:: vtrans integer:: n integer:: k n = size(c,1) if (n == 0) return vtrans = blas_no_trans if (present(trans)) vtrans = trans vuplo = blas_upper if (present(uplo)) vuplo = uplo vbeta = z_zero if (present(beta)) vbeta = beta valpha = z_one if (present(alpha)) valpha = alpha ! end init k = merge(size(a,2),size(a,1),vtrans == blas_no_trans) if (k == 0) return call zmatext(c,ppc,ldc,wwc) if (.not.associated(ppc,c(1,1))) wwc = c call zmatext(b,ppb,ldb,wwb) if (.not.associated(ppb,b(1,1))) wwb = b call zmatext(a,ppa,lda,wwa) if (.not.associated(ppa,a(1,1))) wwa = a ! end copy call zSYR2K(vuplo,vtrans,n,k,valpha,ppa,lda,ppb,ldb,vbeta,ppc,ldc) if (.not.associated(ppc,c(1,1))) then c = wwc deallocate(wwc) end if if (.not.associated(ppb,b(1,1))) then deallocate(wwb) end if if (.not.associated(ppa,a(1,1))) then deallocate(wwa) end if ! end uncopy end subroutine !======================================== ! HER2K implementation subroutine cHER2K_95(a,b,c,uplo,trans,alpha,beta) complex(skind),dimension(:,:),intent(in),target:: a complex(skind),pointer:: ppa,wwa(:,:) integer:: lda complex(skind),dimension(:,:),intent(in),target:: b complex(skind),pointer:: ppb,wwb(:,:) integer:: ldb complex(skind),dimension(:,:),intent(inout),target:: c complex(skind),pointer:: ppc,wwc(:,:) integer:: ldc complex(skind),intent(in),optional:: alpha complex(skind):: valpha complex(skind),intent(in),optional:: beta complex(skind):: vbeta character,intent(in),optional:: uplo character:: vuplo character,intent(in),optional:: trans character:: vtrans integer:: n integer:: k n = size(c,1) if (n == 0) return vtrans = blas_no_trans if (present(trans)) vtrans = trans vuplo = blas_upper if (present(uplo)) vuplo = uplo vbeta = c_zero if (present(beta)) vbeta = beta valpha = c_one if (present(alpha)) valpha = alpha ! end init k = merge(size(a,2),size(a,1),vtrans == blas_no_trans) if (k == 0) return call cmatext(c,ppc,ldc,wwc) if (.not.associated(ppc,c(1,1))) wwc = c call cmatext(b,ppb,ldb,wwb) if (.not.associated(ppb,b(1,1))) wwb = b call cmatext(a,ppa,lda,wwa) if (.not.associated(ppa,a(1,1))) wwa = a ! end copy call cHER2K(vuplo,vtrans,n,k,valpha,ppa,lda,ppb,ldb,vbeta,ppc,ldc) if (.not.associated(ppc,c(1,1))) then c = wwc deallocate(wwc) end if if (.not.associated(ppb,b(1,1))) then deallocate(wwb) end if if (.not.associated(ppa,a(1,1))) then deallocate(wwa) end if ! end uncopy end subroutine subroutine zHER2K_95(a,b,c,uplo,trans,alpha,beta) complex(dkind),dimension(:,:),intent(in),target:: a complex(dkind),pointer:: ppa,wwa(:,:) integer:: lda complex(dkind),dimension(:,:),intent(in),target:: b complex(dkind),pointer:: ppb,wwb(:,:) integer:: ldb complex(dkind),dimension(:,:),intent(inout),target:: c complex(dkind),pointer:: ppc,wwc(:,:) integer:: ldc complex(dkind),intent(in),optional:: alpha complex(dkind):: valpha complex(dkind),intent(in),optional:: beta complex(dkind):: vbeta character,intent(in),optional:: uplo character:: vuplo character,intent(in),optional:: trans character:: vtrans integer:: n integer:: k n = size(c,1) if (n == 0) return vtrans = blas_no_trans if (present(trans)) vtrans = trans vuplo = blas_upper if (present(uplo)) vuplo = uplo vbeta = z_zero if (present(beta)) vbeta = beta valpha = z_one if (present(alpha)) valpha = alpha ! end init k = merge(size(a,2),size(a,1),vtrans == blas_no_trans) if (k == 0) return call zmatext(c,ppc,ldc,wwc) if (.not.associated(ppc,c(1,1))) wwc = c call zmatext(b,ppb,ldb,wwb) if (.not.associated(ppb,b(1,1))) wwb = b call zmatext(a,ppa,lda,wwa) if (.not.associated(ppa,a(1,1))) wwa = a ! end copy call zHER2K(vuplo,vtrans,n,k,valpha,ppa,lda,ppb,ldb,vbeta,ppc,ldc) if (.not.associated(ppc,c(1,1))) then c = wwc deallocate(wwc) end if if (.not.associated(ppb,b(1,1))) then deallocate(wwb) end if if (.not.associated(ppa,a(1,1))) then deallocate(wwa) end if ! end uncopy end subroutine end module blas3 ! matrix scaling routines written in F77 BLAS style, for extending the functionality ! of level 2 rank 1/2 update procedures by an optional beta argument. ! These have to be external, otherwise the interface checking would not allow us ! to call them in the way we need. subroutine sblas3_gescal(m,n,a,lda,beta) integer,parameter:: skind = kind(1.e0), dkind = kind(1.d0) ! ones real(skind),parameter:: s_one = real(1,kind=skind) real(dkind),parameter:: d_one = real(1,kind=dkind) complex(skind),parameter:: c_one = cmplx(1,kind=skind) complex(dkind),parameter:: z_one = cmplx(1,kind=dkind) ! zeros real(skind),parameter:: s_zero = real(0,kind=skind) real(dkind),parameter:: d_zero = real(0,kind=dkind) complex(skind),parameter:: c_zero = cmplx(0,kind=skind) complex(dkind),parameter:: z_zero = cmplx(0,kind=dkind) integer,intent(in):: m,n,lda real(skind):: a(lda,*),beta integer:: j if (beta == s_zero) then a(1:m,1:n) = s_zero else if (beta /= s_one) then do j=1,n call sscal(m,beta,a(1,j),1) end do end if end subroutine subroutine dblas3_gescal(m,n,a,lda,beta) integer,parameter:: skind = kind(1.e0), dkind = kind(1.d0) ! ones real(skind),parameter:: s_one = real(1,kind=skind) real(dkind),parameter:: d_one = real(1,kind=dkind) complex(skind),parameter:: c_one = cmplx(1,kind=skind) complex(dkind),parameter:: z_one = cmplx(1,kind=dkind) ! zeros real(skind),parameter:: s_zero = real(0,kind=skind) real(dkind),parameter:: d_zero = real(0,kind=dkind) complex(skind),parameter:: c_zero = cmplx(0,kind=skind) complex(dkind),parameter:: z_zero = cmplx(0,kind=dkind) integer,intent(in):: m,n,lda real(dkind):: a(lda,*),beta integer:: j if (beta == d_zero) then a(1:m,1:n) = d_zero else if (beta /= d_one) then do j=1,n call dscal(m,beta,a(1,j),1) end do end if end subroutine subroutine cblas3_gescal(m,n,a,lda,beta) integer,parameter:: skind = kind(1.e0), dkind = kind(1.d0) ! ones real(skind),parameter:: s_one = real(1,kind=skind) real(dkind),parameter:: d_one = real(1,kind=dkind) complex(skind),parameter:: c_one = cmplx(1,kind=skind) complex(dkind),parameter:: z_one = cmplx(1,kind=dkind) ! zeros real(skind),parameter:: s_zero = real(0,kind=skind) real(dkind),parameter:: d_zero = real(0,kind=dkind) complex(skind),parameter:: c_zero = cmplx(0,kind=skind) complex(dkind),parameter:: z_zero = cmplx(0,kind=dkind) integer,intent(in):: m,n,lda complex(skind):: a(lda,*),beta integer:: j if (beta == c_zero) then a(1:m,1:n) = c_zero else if (beta /= c_one) then do j=1,n call cscal(m,beta,a(1,j),1) end do end if end subroutine subroutine zblas3_gescal(m,n,a,lda,beta) integer,parameter:: skind = kind(1.e0), dkind = kind(1.d0) ! ones real(skind),parameter:: s_one = real(1,kind=skind) real(dkind),parameter:: d_one = real(1,kind=dkind) complex(skind),parameter:: c_one = cmplx(1,kind=skind) complex(dkind),parameter:: z_one = cmplx(1,kind=dkind) ! zeros real(skind),parameter:: s_zero = real(0,kind=skind) real(dkind),parameter:: d_zero = real(0,kind=dkind) complex(skind),parameter:: c_zero = cmplx(0,kind=skind) complex(dkind),parameter:: z_zero = cmplx(0,kind=dkind) integer,intent(in):: m,n,lda complex(dkind):: a(lda,*),beta integer:: j if (beta == z_zero) then a(1:m,1:n) = z_zero else if (beta /= z_one) then do j=1,n call zscal(m,beta,a(1,j),1) end do end if end subroutine subroutine sblas3_syscal(m,n,a,lda,beta,uplo) integer,parameter:: skind = kind(1.e0), dkind = kind(1.d0) ! ones real(skind),parameter:: s_one = real(1,kind=skind) real(dkind),parameter:: d_one = real(1,kind=dkind) complex(skind),parameter:: c_one = cmplx(1,kind=skind) complex(dkind),parameter:: z_one = cmplx(1,kind=dkind) ! zeros real(skind),parameter:: s_zero = real(0,kind=skind) real(dkind),parameter:: d_zero = real(0,kind=dkind) complex(skind),parameter:: c_zero = cmplx(0,kind=skind) complex(dkind),parameter:: z_zero = cmplx(0,kind=dkind) integer,intent(in):: m,n,lda real(skind):: a(lda,*),beta character,intent(in):: uplo integer:: j if (uplo == "U") then if (beta == s_zero) then do j=1,n a(1:j,j) = s_zero end do else if (beta /= s_one) then do j=1,n call sscal(j,beta,a(1,j),1) end do end if else if (beta == s_zero) then do j=1,n a(j:m,j) = s_zero end do else if (beta /= s_one) then do j=1,n call sscal(m+j-1,beta,a(j,j),1) end do end if end if end subroutine subroutine dblas3_syscal(m,n,a,lda,beta,uplo) integer,parameter:: skind = kind(1.e0), dkind = kind(1.d0) ! ones real(skind),parameter:: s_one = real(1,kind=skind) real(dkind),parameter:: d_one = real(1,kind=dkind) complex(skind),parameter:: c_one = cmplx(1,kind=skind) complex(dkind),parameter:: z_one = cmplx(1,kind=dkind) ! zeros real(skind),parameter:: s_zero = real(0,kind=skind) real(dkind),parameter:: d_zero = real(0,kind=dkind) complex(skind),parameter:: c_zero = cmplx(0,kind=skind) complex(dkind),parameter:: z_zero = cmplx(0,kind=dkind) integer,intent(in):: m,n,lda real(dkind):: a(lda,*),beta character,intent(in):: uplo integer:: j if (uplo == "U") then if (beta == d_zero) then do j=1,n a(1:j,j) = d_zero end do else if (beta /= d_one) then do j=1,n call dscal(j,beta,a(1,j),1) end do end if else if (beta == d_zero) then do j=1,n a(j:m,j) = d_zero end do else if (beta /= d_one) then do j=1,n call dscal(m+j-1,beta,a(j,j),1) end do end if end if end subroutine subroutine cblas3_syscal(m,n,a,lda,beta,uplo) integer,parameter:: skind = kind(1.e0), dkind = kind(1.d0) ! ones real(skind),parameter:: s_one = real(1,kind=skind) real(dkind),parameter:: d_one = real(1,kind=dkind) complex(skind),parameter:: c_one = cmplx(1,kind=skind) complex(dkind),parameter:: z_one = cmplx(1,kind=dkind) ! zeros real(skind),parameter:: s_zero = real(0,kind=skind) real(dkind),parameter:: d_zero = real(0,kind=dkind) complex(skind),parameter:: c_zero = cmplx(0,kind=skind) complex(dkind),parameter:: z_zero = cmplx(0,kind=dkind) integer,intent(in):: m,n,lda complex(skind):: a(lda,*),beta character,intent(in):: uplo integer:: j if (uplo == "U") then if (beta == c_zero) then do j=1,n a(1:j,j) = c_zero end do else if (beta /= c_one) then do j=1,n call cscal(j,beta,a(1,j),1) end do end if else if (beta == c_zero) then do j=1,n a(j:m,j) = c_zero end do else if (beta /= c_one) then do j=1,n call cscal(m+j-1,beta,a(j,j),1) end do end if end if end subroutine subroutine zblas3_syscal(m,n,a,lda,beta,uplo) integer,parameter:: skind = kind(1.e0), dkind = kind(1.d0) ! ones real(skind),parameter:: s_one = real(1,kind=skind) real(dkind),parameter:: d_one = real(1,kind=dkind) complex(skind),parameter:: c_one = cmplx(1,kind=skind) complex(dkind),parameter:: z_one = cmplx(1,kind=dkind) ! zeros real(skind),parameter:: s_zero = real(0,kind=skind) real(dkind),parameter:: d_zero = real(0,kind=dkind) complex(skind),parameter:: c_zero = cmplx(0,kind=skind) complex(dkind),parameter:: z_zero = cmplx(0,kind=dkind) integer,intent(in):: m,n,lda complex(dkind):: a(lda,*),beta character,intent(in):: uplo integer:: j if (uplo == "U") then if (beta == z_zero) then do j=1,n a(1:j,j) = z_zero end do else if (beta /= z_one) then do j=1,n call zscal(j,beta,a(1,j),1) end do end if else if (beta == z_zero) then do j=1,n a(j:m,j) = z_zero end do else if (beta /= z_one) then do j=1,n call zscal(m+j-1,beta,a(j,j),1) end do end if end if end subroutine