*** empty log message ***
Alfredo Buttari
20 years ago
parent
1b90c52c5a
commit
9323d3a7f4
@ -0,0 +1,218 @@
|
|||||||
|
/*****************************************************************/
|
||||||
|
/* */
|
||||||
|
/* srcht.c : specialized insert/search for (key,val) integer */
|
||||||
|
/* pairs. Written by: Salvatore Filippone */
|
||||||
|
/* */
|
||||||
|
/* Last updated: Mar 09 2004 */
|
||||||
|
/* */
|
||||||
|
/* Uses: avltree */
|
||||||
|
/* */
|
||||||
|
/* Data types: */
|
||||||
|
/* */
|
||||||
|
/* KeyType: struct with two integer fields, key and val. */
|
||||||
|
/* */
|
||||||
|
/* */
|
||||||
|
/* User callable functions: */
|
||||||
|
/* */
|
||||||
|
/* void InitPairSearchTree(int *iret) */
|
||||||
|
/* Purpose: initialize a search structure; */
|
||||||
|
/* Function value: 0: OK */
|
||||||
|
/* -1: failure */
|
||||||
|
/* */
|
||||||
|
/* */
|
||||||
|
/* void SearchInsKeyVal(int *key, int *val, int *res, */
|
||||||
|
/* int *iret) */
|
||||||
|
/* Purpose: Search for a key, insert it if not present. */
|
||||||
|
/* */
|
||||||
|
/* Input: 1. key */
|
||||||
|
/* Key to be searched for. */
|
||||||
|
/* 2. val */
|
||||||
|
/* Value to form a (key,val) pair to be */
|
||||||
|
/* inserted if key not already present. */
|
||||||
|
/* Output: 3. res */
|
||||||
|
/* The val part of the pair with key; if the */
|
||||||
|
/* key was freshly inserted then res=val */
|
||||||
|
/* Function value: 0 Normal termination */
|
||||||
|
/* 1 Key was already present. */
|
||||||
|
/* -1 Invalid input pointer */
|
||||||
|
/* -3 Memory allocation failure */
|
||||||
|
/* */
|
||||||
|
/* */
|
||||||
|
/* void FreePairSearchTree() */
|
||||||
|
/* Purpose: free up tree data storage */
|
||||||
|
/* */
|
||||||
|
/* */
|
||||||
|
/*****************************************************************/
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
#include <stdlib.h>
|
||||||
|
#include <stdio.h>
|
||||||
|
#include <string.h>
|
||||||
|
#include "avltree.h"
|
||||||
|
|
||||||
|
#define POOLSIZE 4096
|
||||||
|
|
||||||
|
#ifdef Add_
|
||||||
|
#define InitPairSearchTree initpairsearchtree_
|
||||||
|
#define FreePairSearchTree freepairsearchtree_
|
||||||
|
#define SearchInsKeyVal searchinskeyval_
|
||||||
|
#endif
|
||||||
|
#ifdef AddDouble_
|
||||||
|
#define InitPairSearchTree initpairsearchtree_
|
||||||
|
#define FreePairSearchTree freepairsearchtree_
|
||||||
|
#define SearchInsKeyVal searchinskeyval_
|
||||||
|
#endif
|
||||||
|
#ifdef NoChange
|
||||||
|
#define InitPairSearchTree initpairsearchtree
|
||||||
|
#define FreePairSearchTree freepairsearchtree
|
||||||
|
#define SearchInsKeyVal searchinskeyval
|
||||||
|
#endif
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
typedef struct keypair *KeyPairPtr;
|
||||||
|
typedef struct keypair {
|
||||||
|
int key,val;
|
||||||
|
} KeyPair;
|
||||||
|
|
||||||
|
|
||||||
|
typedef struct pairvect *PairVectPtr;
|
||||||
|
typedef struct pairvect {
|
||||||
|
KeyPair pool[POOLSIZE];
|
||||||
|
int avail;
|
||||||
|
PairVectPtr previous, next;
|
||||||
|
} PairVect;
|
||||||
|
|
||||||
|
|
||||||
|
static int retval;
|
||||||
|
static PairVectPtr PairPoolRoot=NULL,PairPoolCrt=NULL;
|
||||||
|
static AVLTreePtr tree=NULL;
|
||||||
|
|
||||||
|
int CompareKeys(void *key1, void *key2)
|
||||||
|
{
|
||||||
|
if (((KeyPairPtr) key1)->key < ((KeyPairPtr) key2)->key){
|
||||||
|
return(-1);
|
||||||
|
} else if (((KeyPairPtr)key1)->key == ((KeyPairPtr)key2)->key){
|
||||||
|
return(0);
|
||||||
|
} else {
|
||||||
|
return(1);
|
||||||
|
}
|
||||||
|
}
|
||||||
|
|
||||||
|
void InitPairSearchTree(int *iret)
|
||||||
|
{
|
||||||
|
*iret = 0;
|
||||||
|
|
||||||
|
if ((tree = GetAVLTree())==NULL) {
|
||||||
|
*iret=-1; return;
|
||||||
|
}
|
||||||
|
if ((PairPoolRoot=(PairVectPtr)malloc(sizeof(PairVect)))==NULL) {
|
||||||
|
*iret=-3;
|
||||||
|
} else {
|
||||||
|
PairPoolRoot->avail=0;
|
||||||
|
PairPoolRoot->previous=PairPoolRoot->next=NULL;
|
||||||
|
PairPoolCrt=PairPoolRoot;
|
||||||
|
}
|
||||||
|
return;
|
||||||
|
}
|
||||||
|
|
||||||
|
|
||||||
|
void KeyUpdate( void *key1, void *key2)
|
||||||
|
{
|
||||||
|
retval=((KeyPairPtr) key2)->val;
|
||||||
|
}
|
||||||
|
|
||||||
|
|
||||||
|
void FreePairSearchTree()
|
||||||
|
{
|
||||||
|
PairVectPtr current,next;
|
||||||
|
|
||||||
|
AVLTreeFree(tree,NULL);
|
||||||
|
|
||||||
|
current=PairPoolRoot;
|
||||||
|
|
||||||
|
while (current != NULL) {
|
||||||
|
next=current->next;
|
||||||
|
free(current);
|
||||||
|
current=next;
|
||||||
|
}
|
||||||
|
free(tree);
|
||||||
|
tree = NULL;
|
||||||
|
return;
|
||||||
|
}
|
||||||
|
|
||||||
|
int AdvanceKeyPair(PairVectPtr current)
|
||||||
|
{
|
||||||
|
if (current!=NULL) {
|
||||||
|
current->avail +=1;
|
||||||
|
return(current->avail);
|
||||||
|
}
|
||||||
|
return(-1);
|
||||||
|
}
|
||||||
|
|
||||||
|
|
||||||
|
KeyPairPtr GetKeyPair(PairVectPtr *current)
|
||||||
|
{
|
||||||
|
PairVectPtr new, crt;
|
||||||
|
KeyPairPtr newnode;
|
||||||
|
|
||||||
|
crt=*current;
|
||||||
|
if (crt==NULL) {
|
||||||
|
return(NULL);
|
||||||
|
}
|
||||||
|
|
||||||
|
if (crt->avail<POOLSIZE) {
|
||||||
|
newnode=&(crt->pool[crt->avail]);
|
||||||
|
} else {
|
||||||
|
if ((new=(PairVectPtr)malloc(sizeof(PairVect)))==NULL) {
|
||||||
|
fprintf(stderr,"Memory allocation failure\n");
|
||||||
|
return(NULL);
|
||||||
|
}
|
||||||
|
memset(new,'\0',sizeof(PairVect));
|
||||||
|
newnode=&(new->pool[0]);
|
||||||
|
crt->next=new;
|
||||||
|
new->previous=crt;
|
||||||
|
new->next=NULL;
|
||||||
|
*current=new;
|
||||||
|
}
|
||||||
|
return(newnode);
|
||||||
|
}
|
||||||
|
|
||||||
|
|
||||||
|
/* */
|
||||||
|
/* void SearchInsKeyVal(int *key, int *val, int *res, */
|
||||||
|
/* int *iret) */
|
||||||
|
/* Purpose: Search for a key, insert it if not present. */
|
||||||
|
/* */
|
||||||
|
/* Input: 1. key */
|
||||||
|
/* Key to be searched for. */
|
||||||
|
/* 2. val */
|
||||||
|
/* Value to form a (key,val) pair to be */
|
||||||
|
/* inserted if key not already present. */
|
||||||
|
/* Output: 3. res */
|
||||||
|
/* The val part of the pair with key; if the */
|
||||||
|
/* key was freshly inserted then res=val */
|
||||||
|
/* Function value: 0 Normal termination */
|
||||||
|
/* -1 Invalid input pointer */
|
||||||
|
/* -3 Memory allocation failure */
|
||||||
|
/* */
|
||||||
|
|
||||||
|
void SearchInsKeyVal(int *key, int *val, int *res, int *iret)
|
||||||
|
{
|
||||||
|
KeyPairPtr node; int info;
|
||||||
|
|
||||||
|
node = GetKeyPair(&PairPoolCrt);
|
||||||
|
node->key = *key;
|
||||||
|
node->val = *val;
|
||||||
|
|
||||||
|
info = AVLTreeInsert(tree,node,CompareKeys,KeyUpdate);
|
||||||
|
*iret = info;
|
||||||
|
if (info==0) {
|
||||||
|
*res = node->val;
|
||||||
|
AdvanceKeyPair(PairPoolCrt);
|
||||||
|
} else if (info == 1) {
|
||||||
|
*res = retval;
|
||||||
|
}
|
||||||
|
return;
|
||||||
|
}
|
||||||
@ -0,0 +1,7 @@
|
|||||||
|
interface
|
||||||
|
!.....user passed subroutine.....
|
||||||
|
subroutine parts(glob_index,nrow,np,pv,nv)
|
||||||
|
integer, intent (in) :: glob_index,np,nrow
|
||||||
|
integer, intent (out) :: nv, pv(*)
|
||||||
|
end subroutine parts
|
||||||
|
end interface
|
||||||
@ -0,0 +1,400 @@
|
|||||||
|
! File: psb_check_mod.f90
|
||||||
|
|
||||||
|
module psb_check_mod
|
||||||
|
|
||||||
|
! interface
|
||||||
|
! module procedure psb_chkvect
|
||||||
|
! end interface
|
||||||
|
|
||||||
|
! interface
|
||||||
|
! module procedure psb_chkglobvect
|
||||||
|
! end interface
|
||||||
|
|
||||||
|
! interface
|
||||||
|
! module procedure psb_chkmat
|
||||||
|
! end interface
|
||||||
|
|
||||||
|
contains
|
||||||
|
! Subroutine: psb_chkvect
|
||||||
|
! psb_chkvect checks the validity of a descriptor vector desc_dec, the
|
||||||
|
! related global indexes ix, jx and the leading dimension lldx. It also
|
||||||
|
! eventually computes the starting local indexes (iix,jjx) corresponding
|
||||||
|
! to the submatrix starting globally at the entry pointed by (ix,jx).
|
||||||
|
! Finally, if an inconsistency is found among its parameters ix, jx,
|
||||||
|
! descdec and lldx, the routine returns an error code in info.
|
||||||
|
!
|
||||||
|
! Parameters:
|
||||||
|
! m - integer. The number of rows of the dense matrix X being operated on.
|
||||||
|
! n - integer. The number of columns of the dense matrix X being operated on.
|
||||||
|
! lldx - integer. The leading dimension of the local dense matrix X.
|
||||||
|
! ix - integer. X's global row index, which points to the beginning
|
||||||
|
! of the dense submatrix which is to be operated on.
|
||||||
|
! jx - integer. X's global column index, which points to the beginning
|
||||||
|
! of the dense submatrix which is to be operated on.
|
||||||
|
! desc_dec - integer,dimension(:). Is the matrix_data array.
|
||||||
|
! info - integer. Eventually returns an error code.
|
||||||
|
! iix - integer(optional). The local rows starting index of the submatrix.
|
||||||
|
! jjx - integer(optional). The local columns starting index of the submatrix.
|
||||||
|
subroutine psb_chkvect( m, n, lldx, ix, jx, desc_dec, info, iix, jjx)
|
||||||
|
|
||||||
|
use psb_const_mod
|
||||||
|
use psb_error_mod
|
||||||
|
implicit none
|
||||||
|
|
||||||
|
integer, intent(in) :: m,n,ix,jx,lldx
|
||||||
|
integer, intent(in) :: desc_dec(:)
|
||||||
|
integer, intent(out) :: info
|
||||||
|
integer, optional :: iix, jjx
|
||||||
|
|
||||||
|
! locals
|
||||||
|
integer :: err_act, int_err(5)
|
||||||
|
character(len=20) :: name, ch_err
|
||||||
|
|
||||||
|
info=0
|
||||||
|
name='psb_chkvect'
|
||||||
|
call psb_erractionsave(err_act)
|
||||||
|
|
||||||
|
|
||||||
|
if (m.lt.0) then
|
||||||
|
info=10
|
||||||
|
int_err(1) = 1
|
||||||
|
int_err(2) = m
|
||||||
|
else if (n.lt.0) then
|
||||||
|
info=10
|
||||||
|
int_err(1) = 3
|
||||||
|
int_err(2) = n
|
||||||
|
else if ((ix.lt.1) .and. (m.ne.0)) then
|
||||||
|
info=20
|
||||||
|
int_err(1) = 4
|
||||||
|
int_err(2) = ix
|
||||||
|
else if ((jx.lt.1) .and. (n.ne.0)) then
|
||||||
|
info=20
|
||||||
|
int_err(1) = 5
|
||||||
|
int_err(2) = jx
|
||||||
|
else if (desc_dec(psb_n_col_).lt.0) then
|
||||||
|
info=40
|
||||||
|
int_err(1) = 6
|
||||||
|
int_err(2) = psb_n_col_
|
||||||
|
int_err(3) = desc_dec(psb_n_col_)
|
||||||
|
else if (desc_dec(psb_n_row_).lt.0) then
|
||||||
|
info=40
|
||||||
|
int_err(1) = 6
|
||||||
|
int_err(2) = psb_n_row_
|
||||||
|
int_err(3) = desc_dec(psb_n_row_)
|
||||||
|
else if (lldx.lt.desc_dec(psb_n_col_)) then
|
||||||
|
info=50
|
||||||
|
int_err(1) = 3
|
||||||
|
int_err(2) = lldx
|
||||||
|
int_err(3) = 6
|
||||||
|
int_err(4) = psb_n_col_
|
||||||
|
int_err(5) = desc_dec(psb_n_col_)
|
||||||
|
else if (desc_dec(psb_n_).lt.m) then
|
||||||
|
info=60
|
||||||
|
int_err(1) = 1
|
||||||
|
int_err(2) = m
|
||||||
|
int_err(3) = 6
|
||||||
|
int_err(4) = psb_n_
|
||||||
|
int_err(5) = desc_dec(psb_n_)
|
||||||
|
else if (desc_dec(psb_n_).lt.ix) then
|
||||||
|
info=60
|
||||||
|
int_err(1) = 4
|
||||||
|
int_err(2) = ix
|
||||||
|
int_err(3) = 6
|
||||||
|
int_err(4) = psb_n_
|
||||||
|
int_err(5) = desc_dec(psb_n_)
|
||||||
|
else if (desc_dec(psb_m_).lt.jx) then
|
||||||
|
info=60
|
||||||
|
int_err(1) = 5
|
||||||
|
int_err(2) = jx
|
||||||
|
int_err(3) = 6
|
||||||
|
int_err(4) = psb_m_
|
||||||
|
int_err(5) = desc_dec(psb_m_)
|
||||||
|
else if (desc_dec(psb_n_).lt.(ix+m-1)) then
|
||||||
|
info=80
|
||||||
|
int_err(1) = 1
|
||||||
|
int_err(2) = m
|
||||||
|
int_err(3) = 4
|
||||||
|
int_err(4) = ix
|
||||||
|
end if
|
||||||
|
|
||||||
|
if (info.ne.0) then
|
||||||
|
call psb_errpush(info,name,i_err=int_err)
|
||||||
|
goto 9999
|
||||||
|
end if
|
||||||
|
|
||||||
|
! Compute local indices for submatrix starting
|
||||||
|
! at global indices ix and jx
|
||||||
|
if(present(iix)) iix=ix ! (for our applications iix=ix))
|
||||||
|
if(present(jjx)) iix=ix ! (for our applications jjx=jx))
|
||||||
|
|
||||||
|
call psb_erractionrestore(err_act)
|
||||||
|
return
|
||||||
|
|
||||||
|
9999 continue
|
||||||
|
call psb_erractionrestore(err_act)
|
||||||
|
|
||||||
|
if (err_act.eq.act_abort) then
|
||||||
|
call psb_error()
|
||||||
|
return
|
||||||
|
end if
|
||||||
|
return
|
||||||
|
|
||||||
|
end subroutine psb_chkvect
|
||||||
|
|
||||||
|
!
|
||||||
|
! Subroutine: psb_chkglobvect
|
||||||
|
! psb_chkglobvect checks the validity of a descriptor vector desc_dec, the
|
||||||
|
! related global indexes ix, jx and the leading dimension lldx.
|
||||||
|
! If an inconsistency is found among its parameters ix, jx,
|
||||||
|
! descdec and lldx, the routine returns an error code in info.
|
||||||
|
!
|
||||||
|
! Parameters:
|
||||||
|
! m - integer. The number of rows of the dense matrix X being operated on.
|
||||||
|
! n - integer. The number of columns of the dense matrix X being operated on.
|
||||||
|
! lldx - integer. The leading dimension of the local dense matrix X.
|
||||||
|
! ix - integer. X's global row index, which points to the beginning
|
||||||
|
! of the dense submatrix which is to be operated on.
|
||||||
|
! jx - integer. X's global column index, which points to the beginning
|
||||||
|
! of the dense submatrix which is to be operated on.
|
||||||
|
! desc_dec - integer,dimension(:). Is the matrix_data array.
|
||||||
|
! info - integer. Eventually returns an error code.
|
||||||
|
!
|
||||||
|
subroutine psb_chkglobvect( m, n, lldx, ix, jx, desc_dec, info)
|
||||||
|
|
||||||
|
use psb_const_mod
|
||||||
|
use psb_error_mod
|
||||||
|
implicit none
|
||||||
|
|
||||||
|
integer, intent(in) :: m,n,ix,jx,lldx
|
||||||
|
integer, intent(in) :: desc_dec(:)
|
||||||
|
integer, intent(out) :: info
|
||||||
|
|
||||||
|
! locals
|
||||||
|
integer :: err_act, int_err(5)
|
||||||
|
character(len=20) :: name, ch_err
|
||||||
|
|
||||||
|
info=0
|
||||||
|
name='psb_chkglobvect'
|
||||||
|
call psb_erractionsave(err_act)
|
||||||
|
|
||||||
|
|
||||||
|
if (m.lt.0) then
|
||||||
|
info=10
|
||||||
|
int_err(1) = 1
|
||||||
|
int_err(2) = m
|
||||||
|
else if (n.lt.0) then
|
||||||
|
info=10
|
||||||
|
int_err(1) = 3
|
||||||
|
int_err(2) = n
|
||||||
|
else if ((ix.lt.1) .and. (m.ne.0)) then
|
||||||
|
info=20
|
||||||
|
int_err(1) = 4
|
||||||
|
int_err(2) = ix
|
||||||
|
else if ((jx.lt.1) .and. (n.ne.0)) then
|
||||||
|
info=20
|
||||||
|
int_err(1) = 5
|
||||||
|
int_err(2) = jx
|
||||||
|
else if (desc_dec(psb_n_col_).lt.0) then
|
||||||
|
info=40
|
||||||
|
int_err(1) = 6
|
||||||
|
int_err(2) = psb_n_col_
|
||||||
|
int_err(3) = desc_dec(psb_n_col_)
|
||||||
|
else if (desc_dec(psb_n_row_).lt.0) then
|
||||||
|
info=40
|
||||||
|
int_err(1) = 6
|
||||||
|
int_err(2) = psb_n_row_
|
||||||
|
int_err(3) = desc_dec(psb_n_row_)
|
||||||
|
else if (lldx.lt.desc_dec(psb_m_)) then
|
||||||
|
info=50
|
||||||
|
int_err(1) = 3
|
||||||
|
int_err(2) = lldx
|
||||||
|
int_err(3) = 6
|
||||||
|
int_err(4) = psb_n_col_
|
||||||
|
int_err(5) = desc_dec(psb_n_col_)
|
||||||
|
else if (desc_dec(psb_n_).lt.m) then
|
||||||
|
info=60
|
||||||
|
int_err(1) = 1
|
||||||
|
int_err(2) = m
|
||||||
|
int_err(3) = 6
|
||||||
|
int_err(4) = psb_n_
|
||||||
|
int_err(5) = desc_dec(psb_n_)
|
||||||
|
else if (desc_dec(psb_n_).lt.ix) then
|
||||||
|
info=60
|
||||||
|
int_err(1) = 4
|
||||||
|
int_err(2) = ix
|
||||||
|
int_err(3) = 6
|
||||||
|
int_err(4) = psb_n_
|
||||||
|
int_err(5) = desc_dec(psb_n_)
|
||||||
|
else if (desc_dec(psb_m_).lt.jx) then
|
||||||
|
info=60
|
||||||
|
int_err(1) = 5
|
||||||
|
int_err(2) = jx
|
||||||
|
int_err(3) = 6
|
||||||
|
int_err(4) = psb_m_
|
||||||
|
int_err(5) = desc_dec(psb_m_)
|
||||||
|
else if (desc_dec(psb_n_).lt.(ix+m-1)) then
|
||||||
|
info=80
|
||||||
|
int_err(1) = 1
|
||||||
|
int_err(2) = m
|
||||||
|
int_err(3) = 4
|
||||||
|
int_err(4) = ix
|
||||||
|
end if
|
||||||
|
|
||||||
|
if (info.ne.0) then
|
||||||
|
call psb_errpush(info,name,i_err=int_err)
|
||||||
|
goto 9999
|
||||||
|
end if
|
||||||
|
|
||||||
|
call psb_erractionrestore(err_act)
|
||||||
|
return
|
||||||
|
|
||||||
|
9999 continue
|
||||||
|
call psb_erractionrestore(err_act)
|
||||||
|
|
||||||
|
if (err_act.eq.act_abort) then
|
||||||
|
call psb_error()
|
||||||
|
return
|
||||||
|
end if
|
||||||
|
return
|
||||||
|
|
||||||
|
end subroutine psb_chkglobvect
|
||||||
|
|
||||||
|
!
|
||||||
|
! Subroutine: psb_chkmat
|
||||||
|
! pbmatvect checks the validity of a descriptor vector DESCDEC, the
|
||||||
|
! related global indexes IA, JA. It also computes the starting local
|
||||||
|
! indexes (IIA,JJA) corresponding to the submatrix starting globally at
|
||||||
|
! the entry pointed by (IA,JA). Finally, if an inconsitency is found among
|
||||||
|
! its parameters ia, ja and desc_A, the routine returns an error code in
|
||||||
|
! info.
|
||||||
|
!
|
||||||
|
! Parameters:
|
||||||
|
! m - integer. The number of rows of the matrix being operated on.
|
||||||
|
! n - integer. The number of columns of the matrix being operated on.
|
||||||
|
! ia - integer. a's global row index, which points to the beginning
|
||||||
|
! of the submatrix which is to be operated on.
|
||||||
|
! ja - integer. a's global column index, which points to the beginning
|
||||||
|
! of the submatrix which is to be operated on.
|
||||||
|
! desc_dec - integer,dimension(:). Is the matrix_data array.
|
||||||
|
! info - integer. Eventually returns an error code.
|
||||||
|
! iia - integer(optional). The local rows starting index of the submatrix.
|
||||||
|
! jja - integer(optional). The local columns starting index of the submatrix.
|
||||||
|
!
|
||||||
|
subroutine psb_chkmat( m, n, ia, ja, desc_dec, info, iia, jja)
|
||||||
|
|
||||||
|
use psb_const_mod
|
||||||
|
use psb_error_mod
|
||||||
|
implicit none
|
||||||
|
|
||||||
|
integer, intent(in) :: m,n,ia,ja
|
||||||
|
integer, intent(in) :: desc_dec(:)
|
||||||
|
integer, intent(out) :: info
|
||||||
|
integer, optional :: iia, jja
|
||||||
|
|
||||||
|
! locals
|
||||||
|
integer :: err_act, int_err(5)
|
||||||
|
character(len=20) :: name, ch_err
|
||||||
|
|
||||||
|
info=0
|
||||||
|
name='psb_chkmat'
|
||||||
|
call psb_erractionsave(err_act)
|
||||||
|
|
||||||
|
if (m.lt.0) then
|
||||||
|
info=10
|
||||||
|
int_err(1) = 1
|
||||||
|
int_err(2) = m
|
||||||
|
else if (n.lt.0) then
|
||||||
|
info=10
|
||||||
|
int_err(1) = 3
|
||||||
|
int_err(2) = n
|
||||||
|
else if ((ia.lt.1) .and. (m.ne.0)) then
|
||||||
|
info=20
|
||||||
|
int_err(1) = 4
|
||||||
|
int_err(2) = ia
|
||||||
|
else if ((ja.lt.1) .and. (n.ne.0)) then
|
||||||
|
info=20
|
||||||
|
int_err(1) = 5
|
||||||
|
int_err(2) = ja
|
||||||
|
else if (desc_dec(psb_n_col_).lt.0) then
|
||||||
|
info=40
|
||||||
|
int_err(1) = 6
|
||||||
|
int_err(2) = psb_n_col_
|
||||||
|
int_err(3) = desc_dec(psb_n_col_)
|
||||||
|
else if (desc_dec(psb_n_row_).lt.0) then
|
||||||
|
info=40
|
||||||
|
int_err(1) = 6
|
||||||
|
int_err(2) = psb_n_row_
|
||||||
|
int_err(3) = desc_dec(psb_n_row_)
|
||||||
|
else if (desc_dec(psb_m_).lt.m) then
|
||||||
|
info=60
|
||||||
|
int_err(1) = 1
|
||||||
|
int_err(2) = m
|
||||||
|
int_err(3) = 5
|
||||||
|
int_err(4) = psb_m_
|
||||||
|
int_err(5) = desc_dec(psb_m_)
|
||||||
|
else if (desc_dec(psb_m_).lt.m) then
|
||||||
|
info=60
|
||||||
|
int_err(1) = 2
|
||||||
|
int_err(2) = n
|
||||||
|
int_err(3) = 5
|
||||||
|
int_err(4) = psb_m_
|
||||||
|
int_err(5) = desc_dec(psb_m_)
|
||||||
|
else if (desc_dec(psb_m_).lt.ia) then
|
||||||
|
info=60
|
||||||
|
int_err(1) = 3
|
||||||
|
int_err(2) = ia
|
||||||
|
int_err(3) = 5
|
||||||
|
int_err(4) = psb_m_
|
||||||
|
int_err(5) = desc_dec(psb_m_)
|
||||||
|
else if (desc_dec(psb_n_).lt.ja) then
|
||||||
|
info=60
|
||||||
|
int_err(1) = 4
|
||||||
|
int_err(2) = ja
|
||||||
|
int_err(3) = 5
|
||||||
|
int_err(4) = psb_n_
|
||||||
|
int_err(5) = desc_dec(psb_n_)
|
||||||
|
else if (desc_dec(psb_m_).lt.(ia+m-1)) then
|
||||||
|
info=80
|
||||||
|
int_err(1) = 1
|
||||||
|
int_err(2) = m
|
||||||
|
int_err(3) = 3
|
||||||
|
int_err(4) = ia
|
||||||
|
else if (desc_dec(psb_n_).lt.(ja+n-1)) then
|
||||||
|
info=80
|
||||||
|
int_err(1) = 2
|
||||||
|
int_err(2) = n
|
||||||
|
int_err(3) = 4
|
||||||
|
int_err(4) = ja
|
||||||
|
end if
|
||||||
|
|
||||||
|
if (info.ne.0) then
|
||||||
|
call psb_errpush(info,name,i_err=int_err)
|
||||||
|
goto 9999
|
||||||
|
end if
|
||||||
|
|
||||||
|
! Compute local indices for submatrix starting
|
||||||
|
! at global indices ix and jx
|
||||||
|
if(present(iia).and.present(jja)) then
|
||||||
|
if (desc_dec(psb_n_row_).gt.0) then
|
||||||
|
iia=1
|
||||||
|
jja=1
|
||||||
|
else
|
||||||
|
iia=desc_dec(psb_n_row_)+1
|
||||||
|
jja=desc_dec(psb_n_col_)+1
|
||||||
|
end if
|
||||||
|
end if
|
||||||
|
|
||||||
|
call psb_erractionrestore(err_act)
|
||||||
|
return
|
||||||
|
|
||||||
|
9999 continue
|
||||||
|
call psb_erractionrestore(err_act)
|
||||||
|
|
||||||
|
if (err_act.eq.act_abort) then
|
||||||
|
call psb_error()
|
||||||
|
return
|
||||||
|
end if
|
||||||
|
return
|
||||||
|
end subroutine psb_chkmat
|
||||||
|
|
||||||
|
end module psb_check_mod
|
||||||
@ -0,0 +1,53 @@
|
|||||||
|
SUBROUTINE DCOORWS(TRANS,M,N,DESCRA,A,IA1,IA2,
|
||||||
|
& INFOA,ROWSUM,IERROR)
|
||||||
|
IMPLICIT NONE
|
||||||
|
C .. Scalar Arguments ..
|
||||||
|
INTEGER M,N, IERROR
|
||||||
|
CHARACTER TRANS
|
||||||
|
C .. Array Arguments ..
|
||||||
|
INTEGER IA1(*),IA2(*),INFOA(*)
|
||||||
|
CHARACTER DESCRA*11
|
||||||
|
DOUBLE PRECISION A(*), ROWSUM(*)
|
||||||
|
C .. Local scalars ..
|
||||||
|
INTEGER I, J, NNZ, K
|
||||||
|
DOUBLE PRECISION SUM
|
||||||
|
logical lsame
|
||||||
|
external lsame
|
||||||
|
|
||||||
|
NNZ = INFOA(1)
|
||||||
|
IF (lsame(TRANS,'N')) THEN
|
||||||
|
DO I=1, M
|
||||||
|
ROWSUM(I) = 0.0D0
|
||||||
|
ENDDO
|
||||||
|
I = 1
|
||||||
|
J = I
|
||||||
|
DO WHILE (I.LE.NNZ)
|
||||||
|
|
||||||
|
DO WHILE ((IA1(J).EQ.IA1(I)).AND.
|
||||||
|
+ (J.LE.NNZ))
|
||||||
|
J = J+1
|
||||||
|
ENDDO
|
||||||
|
|
||||||
|
SUM = 0.0
|
||||||
|
DO K = I, J-1
|
||||||
|
SUM = SUM + ABS(A(K))
|
||||||
|
ENDDO
|
||||||
|
ROWSUM(IA1(I)) = ROWSUM(IA1(I)) + SUM
|
||||||
|
I = J
|
||||||
|
ENDDO
|
||||||
|
|
||||||
|
ELSE IF (lsame(TRANS,'T').OR.lsame(TRANS,'C')) THEN
|
||||||
|
DO J = 1, N
|
||||||
|
ROWSUM(J) = 0.0D0
|
||||||
|
ENDDO
|
||||||
|
DO I = 1, NNZ
|
||||||
|
ROWSUM(IA2(I)) = ROWSUM(IA2(I)) + ABS(A(I))
|
||||||
|
ENDDO
|
||||||
|
ELSE
|
||||||
|
ierror = -1
|
||||||
|
ENDIF
|
||||||
|
RETURN
|
||||||
|
END
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
@ -0,0 +1,34 @@
|
|||||||
|
SUBROUTINE DCSRRWS(TRANS,M,N,DESCRA,A,IA1,IA2,
|
||||||
|
& INFOA,ROWSUM,IERROR)
|
||||||
|
IMPLICIT NONE
|
||||||
|
C .. Scalar Arguments ..
|
||||||
|
INTEGER M,N, IERROR
|
||||||
|
CHARACTER TRANS
|
||||||
|
C .. Array Arguments ..
|
||||||
|
INTEGER IA1(*),IA2(*),INFOA(*)
|
||||||
|
CHARACTER DESCRA*11
|
||||||
|
DOUBLE PRECISION A(*), ROWSUM(*)
|
||||||
|
C .. Local scalars ..
|
||||||
|
INTEGER I, J
|
||||||
|
|
||||||
|
IF (TRANS.EQ.'N') THEN
|
||||||
|
DO I = 1, M
|
||||||
|
ROWSUM(I) = 0.0D0
|
||||||
|
DO J = IA2(I), IA2(I + 1) - 1
|
||||||
|
ROWSUM(I) = ROWSUM(I) + ABS(A(J))
|
||||||
|
ENDDO
|
||||||
|
ENDDO
|
||||||
|
ELSE IF ((TRANS.EQ.'T').OR.(TRANS.EQ.'C')) THEN
|
||||||
|
DO J = 1, N
|
||||||
|
ROWSUM(J) = 0.0D0
|
||||||
|
ENDDO
|
||||||
|
DO I = 1, M
|
||||||
|
DO J = IA2(I), IA2(I + 1) - 1
|
||||||
|
ROWSUM(IA1(J)) = ROWSUM(IA1(J)) + ABS(A(J))
|
||||||
|
ENDDO
|
||||||
|
ENDDO
|
||||||
|
ENDIF
|
||||||
|
END
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
@ -0,0 +1,50 @@
|
|||||||
|
subroutine dcopy(n,dx,incx,dy,incy)
|
||||||
|
c
|
||||||
|
c copies a vector, x, to a vector, y.
|
||||||
|
c uses unrolled loops for increments equal to one.
|
||||||
|
c jack dongarra, linpack, 3/11/78.
|
||||||
|
c modified 12/3/93, array(1) declarations changed to array(*)
|
||||||
|
c
|
||||||
|
double precision dx(*),dy(*)
|
||||||
|
integer i,incx,incy,ix,iy,m,mp1,n
|
||||||
|
c
|
||||||
|
if(n.le.0)return
|
||||||
|
if(incx.eq.1.and.incy.eq.1)go to 20
|
||||||
|
c
|
||||||
|
c code for unequal increments or equal increments
|
||||||
|
c not equal to 1
|
||||||
|
c
|
||||||
|
ix = 1
|
||||||
|
iy = 1
|
||||||
|
if(incx.lt.0)ix = (-n+1)*incx + 1
|
||||||
|
if(incy.lt.0)iy = (-n+1)*incy + 1
|
||||||
|
do 10 i = 1,n
|
||||||
|
dy(iy) = dx(ix)
|
||||||
|
ix = ix + incx
|
||||||
|
iy = iy + incy
|
||||||
|
10 continue
|
||||||
|
return
|
||||||
|
c
|
||||||
|
c code for both increments equal to 1
|
||||||
|
c
|
||||||
|
c
|
||||||
|
c clean-up loop
|
||||||
|
c
|
||||||
|
20 m = mod(n,7)
|
||||||
|
if( m .eq. 0 ) go to 40
|
||||||
|
do 30 i = 1,m
|
||||||
|
dy(i) = dx(i)
|
||||||
|
30 continue
|
||||||
|
if( n .lt. 7 ) return
|
||||||
|
40 mp1 = m + 1
|
||||||
|
do 50 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)
|
||||||
|
50 continue
|
||||||
|
return
|
||||||
|
end
|
||||||
@ -0,0 +1,153 @@
|
|||||||
|
C SUBROUTINE DCSRS(TRANS,M,N,FIDA,DESCRA,A,IA1,IA2, &
|
||||||
|
C & INFOA,ROWSUM,IERROR)
|
||||||
|
C Purpose
|
||||||
|
C =======
|
||||||
|
C
|
||||||
|
C Computing sum of absolute values for rows of distributed matrix
|
||||||
|
C ROWSUM(IX) = ASUM(A(IX, 1..N))
|
||||||
|
C IX = 1..M
|
||||||
|
C
|
||||||
|
C Parameters
|
||||||
|
C ==========
|
||||||
|
C
|
||||||
|
C TRANS - CHARACTER*1
|
||||||
|
C On entry TRANS specifies if the routine operates with matrix A
|
||||||
|
C or with the transpose of A as follows:
|
||||||
|
C TRANS = 'N' -> use matrix A
|
||||||
|
C TRANS = 'T' or 'C' -> use A' (transpose of matrix A)
|
||||||
|
C Unchanged on exit.
|
||||||
|
C
|
||||||
|
C M - INTEGER
|
||||||
|
C On entry: number of rows of matrix A (A') and
|
||||||
|
C number of rows of matrix C
|
||||||
|
C Unchanged on exit.
|
||||||
|
C
|
||||||
|
C N - INTEGER
|
||||||
|
C On entry: number of columns of matrix B
|
||||||
|
C and number of columns of matrix C.
|
||||||
|
C Unchanged on exit.
|
||||||
|
C
|
||||||
|
C FIDA - CHARACTER*5
|
||||||
|
C On entry FIDA defines the format of the input sparse matrix.
|
||||||
|
C Unchanged on exit.
|
||||||
|
C
|
||||||
|
C DESCRA - CHARACTER*1 array of DIMENSION (9)
|
||||||
|
C On entry DESCRA describes the characteristics of the input
|
||||||
|
C sparse matrix.
|
||||||
|
C Unchanged on exit.
|
||||||
|
C
|
||||||
|
C A - DOUBLE PRECISION array of DIMENSION (*)
|
||||||
|
C On entry A specifies the values of the input sparse
|
||||||
|
C matrix.
|
||||||
|
C Unchanged on exit.
|
||||||
|
C
|
||||||
|
C IA1 - INTEGER array of dimension (*)
|
||||||
|
C On entry IA1 holds integer information on input sparse
|
||||||
|
C matrix. Actual information will depend on data format used.
|
||||||
|
C Unchanged on exit.
|
||||||
|
C
|
||||||
|
C IA2 - INTEGER array of dimension (*)
|
||||||
|
C On entry IA2 holds integer information on input sparse
|
||||||
|
C matrix. Actual information will depend on data format used.
|
||||||
|
C Unchanged on exit.
|
||||||
|
C
|
||||||
|
C INFOA - INTEGER array of length 10.
|
||||||
|
C On entry can hold auxiliary information on input matrices
|
||||||
|
C formats or environment of subsequent calls.
|
||||||
|
C Might be changed on exit.
|
||||||
|
C
|
||||||
|
C IERROR - INTEGER
|
||||||
|
C On exit IERROR contains the value of error flag as follows:
|
||||||
|
C IERROR = 0 no error
|
||||||
|
C IERROR > 0 warning
|
||||||
|
C IERROR < 0 fatal error
|
||||||
|
C
|
||||||
|
C ROWSUM - DOUBLE PRECISION array of dimension (*)
|
||||||
|
C On exit this vector contains the sum of absolute values
|
||||||
|
C of elements of a row (AMAX of row array).
|
||||||
|
C It is required that it has dimension:
|
||||||
|
C ROWSUM(M) if the subroutine in called with the 'N' option
|
||||||
|
C ROWSUM(N) in other cases ('T' or 'C' options).
|
||||||
|
C
|
||||||
|
SUBROUTINE DCSRWS(TRANS,M,N,FIDA,DESCRA,A,IA1,IA2,
|
||||||
|
& INFOA,ROWSUM,IERROR)
|
||||||
|
IMPLICIT NONE
|
||||||
|
C .. Scalar Arguments ..
|
||||||
|
INTEGER M,N, IERROR
|
||||||
|
CHARACTER TRANS
|
||||||
|
C .. Array Arguments ..
|
||||||
|
INTEGER IA1(*),IA2(*),INFOA(*)
|
||||||
|
CHARACTER DESCRA*11, FIDA*5
|
||||||
|
DOUBLE PRECISION A(*), ROWSUM(*)
|
||||||
|
C .. Local Array..
|
||||||
|
INTEGER INT_VAL(5), ERR_ACT
|
||||||
|
DOUBLE PRECISION REAL_VAL(5)
|
||||||
|
CHARACTER*30 NAME,STRINGS(2)
|
||||||
|
C .. Parameters ..
|
||||||
|
DOUBLE PRECISION ZERO
|
||||||
|
INTEGER IONE
|
||||||
|
PARAMETER (ZERO=0.D0,IONE=1)
|
||||||
|
C .. Intrinsic Functions ..
|
||||||
|
INTRINSIC DBLE, IDINT
|
||||||
|
C .. Executable Statements ..
|
||||||
|
C
|
||||||
|
C Check for argument errors
|
||||||
|
C
|
||||||
|
IERROR = 0
|
||||||
|
NAME = 'DCSRWS\0'
|
||||||
|
IF (M.LT.0) THEN
|
||||||
|
IERROR = 10
|
||||||
|
INT_VAL(1) = 2
|
||||||
|
INT_VAL(2) = M
|
||||||
|
ELSE IF (N.LT.0) THEN
|
||||||
|
IERROR = 10
|
||||||
|
INT_VAL(1) = 3
|
||||||
|
INT_VAL(2) = N
|
||||||
|
ELSE IF (TRANS.NE.'T' .AND. TRANS.NE.'N' .AND. TRANS.NE.'C') THEN
|
||||||
|
IERROR = 40
|
||||||
|
INT_VAL(1) = 1
|
||||||
|
STRINGS(1) = TRANS//'\0'
|
||||||
|
ENDIF
|
||||||
|
|
||||||
|
C
|
||||||
|
C Error handling
|
||||||
|
C
|
||||||
|
IF(IERROR.NE.0) THEN
|
||||||
|
CALL FCPSB_ERRPUSH(IERROR,NAME,INT_VAL)
|
||||||
|
GOTO 9999
|
||||||
|
ENDIF
|
||||||
|
|
||||||
|
IF(M.LE.0 .OR. N.LE.0) THEN
|
||||||
|
GOTO 9999
|
||||||
|
ENDIF
|
||||||
|
|
||||||
|
IF (FIDA(1:3).EQ.'CSR') THEN
|
||||||
|
CALL DCSRRWS(TRANS,M,N,DESCRA,A,IA1,IA2,
|
||||||
|
+ INFOA,ROWSUM,IERROR)
|
||||||
|
ELSE IF (FIDA(1:3).EQ.'COO') THEN
|
||||||
|
CALL DCOORWS(TRANS,M,N,DESCRA,A,IA1,IA2,
|
||||||
|
+ INFOA,ROWSUM,IERROR)
|
||||||
|
ELSE IF (FIDA(1:3).EQ.'JAD') THEN
|
||||||
|
CALL DJDRWS(TRANS,M,N,DESCRA,A,IA1,IA2,
|
||||||
|
+ INFOA,ROWSUM,IERROR)
|
||||||
|
ELSE
|
||||||
|
C
|
||||||
|
C This data structure not yet considered
|
||||||
|
C
|
||||||
|
IERROR = 3010
|
||||||
|
strings(1) = fida//'\0'
|
||||||
|
ENDIF
|
||||||
|
|
||||||
|
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
|
||||||
@ -0,0 +1,60 @@
|
|||||||
|
DOUBLE PRECISION FUNCTION DNRM2 ( N, X, INCX )
|
||||||
|
* .. Scalar Arguments ..
|
||||||
|
INTEGER INCX, N
|
||||||
|
* .. Array Arguments ..
|
||||||
|
DOUBLE PRECISION X( * )
|
||||||
|
* ..
|
||||||
|
*
|
||||||
|
* DNRM2 returns the euclidean norm of a vector via the function
|
||||||
|
* name, so that
|
||||||
|
*
|
||||||
|
* DNRM2 := sqrt( x'*x )
|
||||||
|
*
|
||||||
|
*
|
||||||
|
*
|
||||||
|
* -- This version written on 25-October-1982.
|
||||||
|
* Modified on 14-October-1993 to inline the call to DLASSQ.
|
||||||
|
* Sven Hammarling, Nag Ltd.
|
||||||
|
*
|
||||||
|
*
|
||||||
|
* .. Parameters ..
|
||||||
|
DOUBLE PRECISION ONE , ZERO
|
||||||
|
PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 )
|
||||||
|
* .. Local Scalars ..
|
||||||
|
INTEGER IX
|
||||||
|
DOUBLE PRECISION ABSXI, NORM, SCALE, SSQ
|
||||||
|
* .. Intrinsic Functions ..
|
||||||
|
INTRINSIC ABS, SQRT
|
||||||
|
* ..
|
||||||
|
* .. Executable Statements ..
|
||||||
|
IF( N.LT.1 .OR. INCX.LT.1 )THEN
|
||||||
|
NORM = ZERO
|
||||||
|
ELSE IF( N.EQ.1 )THEN
|
||||||
|
NORM = ABS( X( 1 ) )
|
||||||
|
ELSE
|
||||||
|
SCALE = ZERO
|
||||||
|
SSQ = ONE
|
||||||
|
* The following loop is equivalent to this call to the LAPACK
|
||||||
|
* auxiliary routine:
|
||||||
|
* CALL DLASSQ( N, X, INCX, SCALE, SSQ )
|
||||||
|
*
|
||||||
|
DO 10, IX = 1, 1 + ( N - 1 )*INCX, INCX
|
||||||
|
IF( X( IX ).NE.ZERO )THEN
|
||||||
|
ABSXI = ABS( X( IX ) )
|
||||||
|
IF( SCALE.LT.ABSXI )THEN
|
||||||
|
SSQ = ONE + SSQ*( SCALE/ABSXI )**2
|
||||||
|
SCALE = ABSXI
|
||||||
|
ELSE
|
||||||
|
SSQ = SSQ + ( ABSXI/SCALE )**2
|
||||||
|
END IF
|
||||||
|
END IF
|
||||||
|
10 CONTINUE
|
||||||
|
NORM = SCALE * SQRT( SSQ )
|
||||||
|
END IF
|
||||||
|
*
|
||||||
|
DNRM2 = NORM
|
||||||
|
RETURN
|
||||||
|
*
|
||||||
|
* End of DNRM2.
|
||||||
|
*
|
||||||
|
END
|
||||||
@ -0,0 +1,43 @@
|
|||||||
|
subroutine dscal(n,da,dx,incx)
|
||||||
|
c
|
||||||
|
c scales a vector by a constant.
|
||||||
|
c uses unrolled loops for increment equal to one.
|
||||||
|
c jack dongarra, linpack, 3/11/78.
|
||||||
|
c modified 3/93 to return if incx .le. 0.
|
||||||
|
c modified 12/3/93, array(1) declarations changed to array(*)
|
||||||
|
c
|
||||||
|
double precision da,dx(*)
|
||||||
|
integer i,incx,m,mp1,n,nincx
|
||||||
|
c
|
||||||
|
if( n.le.0 .or. incx.le.0 )return
|
||||||
|
if(incx.eq.1)go to 20
|
||||||
|
c
|
||||||
|
c code for increment not equal to 1
|
||||||
|
c
|
||||||
|
nincx = n*incx
|
||||||
|
do 10 i = 1,nincx,incx
|
||||||
|
dx(i) = da*dx(i)
|
||||||
|
10 continue
|
||||||
|
return
|
||||||
|
c
|
||||||
|
c code for increment equal to 1
|
||||||
|
c
|
||||||
|
c
|
||||||
|
c clean-up loop
|
||||||
|
c
|
||||||
|
20 m = mod(n,5)
|
||||||
|
if( m .eq. 0 ) go to 40
|
||||||
|
do 30 i = 1,m
|
||||||
|
dx(i) = da*dx(i)
|
||||||
|
30 continue
|
||||||
|
if( n .lt. 5 ) return
|
||||||
|
40 mp1 = m + 1
|
||||||
|
do 50 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)
|
||||||
|
50 continue
|
||||||
|
return
|
||||||
|
end
|
||||||
@ -0,0 +1,39 @@
|
|||||||
|
integer function idamax(n,dx,incx)
|
||||||
|
c
|
||||||
|
c finds the index of element having max. absolute value.
|
||||||
|
c jack dongarra, linpack, 3/11/78.
|
||||||
|
c modified 3/93 to return if incx .le. 0.
|
||||||
|
c modified 12/3/93, array(1) declarations changed to array(*)
|
||||||
|
c
|
||||||
|
double precision dx(*),dmax
|
||||||
|
integer i,incx,ix,n
|
||||||
|
c
|
||||||
|
idamax = 0
|
||||||
|
if( n.lt.1 .or. incx.le.0 ) return
|
||||||
|
idamax = 1
|
||||||
|
if(n.eq.1)return
|
||||||
|
if(incx.eq.1)go to 20
|
||||||
|
c
|
||||||
|
c code for increment not equal to 1
|
||||||
|
c
|
||||||
|
ix = 1
|
||||||
|
dmax = dabs(dx(1))
|
||||||
|
ix = ix + incx
|
||||||
|
do 10 i = 2,n
|
||||||
|
if(dabs(dx(ix)).le.dmax) go to 5
|
||||||
|
idamax = i
|
||||||
|
dmax = dabs(dx(ix))
|
||||||
|
5 ix = ix + incx
|
||||||
|
10 continue
|
||||||
|
return
|
||||||
|
c
|
||||||
|
c code for increment equal to 1
|
||||||
|
c
|
||||||
|
20 dmax = dabs(dx(1))
|
||||||
|
do 30 i = 2,n
|
||||||
|
if(dabs(dx(i)).le.dmax) go to 30
|
||||||
|
idamax = i
|
||||||
|
dmax = dabs(dx(i))
|
||||||
|
30 continue
|
||||||
|
return
|
||||||
|
end
|
||||||
@ -0,0 +1,48 @@
|
|||||||
|
C ... Compute infinity norma for sparse matrix in CSR Format ...
|
||||||
|
SUBROUTINE DJADRWS(TRANS,M,N,NG,A,KA,JA,IA,
|
||||||
|
+ INFOA,ROWSUM,IERROR)
|
||||||
|
IMPLICIT NONE
|
||||||
|
INCLUDE 'psb_const.fh'
|
||||||
|
C .. Scalar Arguments ..
|
||||||
|
INTEGER M,N, IERROR, NG
|
||||||
|
CHARACTER TRANS
|
||||||
|
C .. Array Arguments ..
|
||||||
|
INTEGER KA(*),JA(*),IA(3,*),INFOA(*)
|
||||||
|
DOUBLE PRECISION A(*), rowsum(*)
|
||||||
|
C ... Local Scalars ..
|
||||||
|
DOUBLE PRECISION NRMI
|
||||||
|
INTEGER I, IR, K, IPG, NPG, IPX
|
||||||
|
|
||||||
|
NRMI = 0.0
|
||||||
|
IR = 0
|
||||||
|
DO IPG = 1, NG
|
||||||
|
K = IA(2,IPG)
|
||||||
|
NPG = JA(K+1)- JA(K)
|
||||||
|
|
||||||
|
C ... ...
|
||||||
|
DO I = 1, NPG
|
||||||
|
ROWSUM(IR+I) = 0.0
|
||||||
|
ENDDO
|
||||||
|
|
||||||
|
DO K = IA(2,IPG), IA(3,IPG)-1
|
||||||
|
IPX = 1
|
||||||
|
DO I = JA(K), JA(K+1) - 1
|
||||||
|
ROWSUM(IR+IPX) = ROWSUM(IR+IPX) + ABS(A(I))
|
||||||
|
IPX = IPX + 1
|
||||||
|
ENDDO
|
||||||
|
ENDDO
|
||||||
|
|
||||||
|
C ... CSR Representation ...
|
||||||
|
|
||||||
|
IPX = 1
|
||||||
|
DO K = IA(3,IPG), IA(2,IPG+1)-1
|
||||||
|
DO I = JA(K), JA(K+1) - 1
|
||||||
|
ROWSUM(IR+IPX) = ROWSUM(IR+IPX) + ABS(A(I))
|
||||||
|
ENDDO
|
||||||
|
IPX = IPX + 1
|
||||||
|
ENDDO
|
||||||
|
|
||||||
|
IR = IR + NPG
|
||||||
|
ENDDO
|
||||||
|
|
||||||
|
END
|
||||||
@ -0,0 +1,30 @@
|
|||||||
|
C ... Compute infinity norm for sparse matrix in CSR Format ...
|
||||||
|
SUBROUTINE DJDRWS(TRANS,M,N,DESCRA,A,JA,IA,
|
||||||
|
+ INFOA,ROWSUM,IERROR)
|
||||||
|
IMPLICIT NONE
|
||||||
|
C .. Scalar Arguments ..
|
||||||
|
INTEGER M,N, IERROR
|
||||||
|
CHARACTER TRANS
|
||||||
|
C .. Array Arguments ..
|
||||||
|
INTEGER JA(*),IA(*),INFOA(*)
|
||||||
|
CHARACTER DESCRA*11
|
||||||
|
DOUBLE PRECISION A(*), ROWSUM(*)
|
||||||
|
C .. Local scalars ..
|
||||||
|
INTEGER PNG, PIA, PJA
|
||||||
|
C .. External routines ..
|
||||||
|
DOUBLE PRECISION DJADNR
|
||||||
|
EXTERNAL DJADNR
|
||||||
|
|
||||||
|
IERROR = 0
|
||||||
|
PNG = IA(1)
|
||||||
|
PIA = IA(2)
|
||||||
|
PJA = IA(3)
|
||||||
|
|
||||||
|
IF (DESCRA(1:1).EQ.'G') THEN
|
||||||
|
CALL DJADRWS(TRANS,M,N,IA(PNG),
|
||||||
|
+ A,JA,IA(PJA),IA(PIA),
|
||||||
|
+ INFOA,ROWSUM,IERROR)
|
||||||
|
ELSE
|
||||||
|
IERROR = 3011
|
||||||
|
ENDIF
|
||||||
|
END
|
||||||
Loading…
Reference in New Issue