*** 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