C C Parallel Sparse BLAS v2.0 C (C) Copyright 2006 Salvatore Filippone University of Rome Tor Vergata C Alfredo Buttari University of Rome Tor Vergata C C Redistribution and use in source and binary forms, with or without C modification, are permitted provided that the following conditions C are met: C 1. Redistributions of source code must retain the above copyright C notice, this list of conditions and the following disclaimer. C 2. Redistributions in binary form must reproduce the above copyright C notice, this list of conditions, and the following disclaimer in the C documentation and/or other materials provided with the distribution. C 3. The name of the PSBLAS group or the names of its contributors may C not be used to endorse or promote products derived from this C software without specific written permission. C C THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS C ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED C TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR C PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS C BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR C CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF C SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS C INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN C CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) C ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE C POSSIBILITY OF SUCH DAMAGE. C C SUBROUTINE ZCSRSM(TRANST,M,N,UNITD,D,ALPHA,DESCRA,A,JA,IA, * B,LDB,BETA,C,LDC,WORK,LWORK) COMPLEX*16 ALPHA, BETA INTEGER LDB, LDC, LWORK, M, N CHARACTER UNITD, TRANST COMPLEX*16 A(*), B(LDB,*), C(LDC,*), D(*), WORK(*) INTEGER IA(*), JA(*) CHARACTER DESCRA*11 INTEGER I, K CHARACTER DIAG, UPLO C .. Local Arrays .. CHARACTER*20 NAME INTEGER INT_VAL(5),err_act NAME = 'DCSRSM\0' IERROR = 0 CALL FCPSB_ERRACTIONSAVE(ERR_ACT) int_Val(1)=0 UPLO = '?' IF (DESCRA(1:1).EQ.'T' .AND. DESCRA(2:2).EQ.'U') UPLO = 'U' IF (DESCRA(1:1).EQ.'T' .AND. DESCRA(2:2).EQ.'L') UPLO = 'L' IF (UPLO.EQ.'?') THEN int_val(1) = 7 IERROR=5 CALL FCPSB_ERRPUSH(IERROR,NAME,INT_VAL) GOTO 9999 END IF IF (DESCRA(3:3).EQ.'N') DIAG = 'N' IF (DESCRA(3:3).EQ.'U') DIAG = 'U' IF(UNITD.EQ.'B') THEN IERROR=5 int_val(1) = 4 CALL FCPSB_ERRPUSH(IERROR,NAME,INT_VAL) GOTO 9999 ENDIF IF (UNITD.EQ.'R') THEN DO 40 I = 1, N DO 20 K = 1, M B(K,I) = B(K,I)*D(K) 20 CONTINUE 40 CONTINUE END IF if ((alpha.ne.(1.d0,0.d0)) .or.(beta .ne.(0.0d0,0.d0))) then if (lwork .lt. m) then int_val(1) = 17 IERROR=5 CALL FCPSB_ERRPUSH(IERROR,NAME,INT_VAL) GOTO 9999 END IF DO I = 1, N CALL ZSRSV(UPLO,TRANST,DIAG,M,A,JA,IA,B(1,I),work) do k=1,m c(k,i) = beta*c(k,i) + alpha*work(k) enddo enddo else DO I = 1, N CALL ZSRSV(UPLO,TRANST,DIAG,M,A,JA,IA,B(1,I),c(1,i)) enddo endif IF (UNITD.EQ.'L') THEN DO 45 I = 1, N DO 25 K = 1, M C(K,I) = C(K,I)*D(K) 25 CONTINUE 45 CONTINUE END IF CALL FCPSB_ERRACTIONRESTORE(ERR_ACT) RETURN 9999 CONTINUE CALL FCPSB_ERRACTIONRESTORE(ERR_ACT) IF ( ERR_ACT .NE. 0 ) THEN CALL FCPSB_SERROR() RETURN ENDIF RETURN END