program test implicit none c*********************************************************************** c test c c This is the driver for the reordering. It reads in c a matrix in Harwell-Boeing Format and outputs a matrix c in Harwell-Boeing Format followed by some reordering c information. c c Reordered Matrix in Harwell Boeing c (Number of Blocks) c (First row in each block, in the pointer format) c c*********************************************************************** c*********************************************************************** c Parameters c max_order - the maximum order of the matrix c max_elems - the maximum number of elements in the matrix c*********************************************************************** integer max_order, max_elems, num_zero, offset, mode character cmode parameter (max_order=5010, max_elems=200000) c*********************************************************************** c Variables: c n - integer: the order of the matrix c nz - integer: the number of elements in the matrix c max_col - integer: the total number of elements in the col_ind array c max_row - integer: the total number of elements in the row_ind array c col_ptr - integer array (max_order+1): contains a pointer to the c first element in each column c value - d.p. array(max_elems): the value of each element in the c matrix c row_ind - integer array (2*max_elems): the row number for each element c in the matrix c col_ind - integer array (max_elems): the column number for each c element in the matrix c row_perm - integer(max_order): resulting row permutation c col_perm - integer(max_order): resulting column permutation c nblocks - integer: the number of blocks from by the reordering c block_ptr - integer(max_order+1): pointer to the first row in each c block, will contain an entry after the pointer to the last c block which points to the first entry in the border c iwork - integer array(max_elems,13): work array used c by the reordering c dwork - double precision array(max_elems): double precision c work space c iflag - integer: error return flag from the reordering c tarray - real array(2): array used for the timing values c*********************************************************************** character title*72, key*8, type*3, ptrfmt*16, 1 indfmt*16, valfmt*20, rhsfmt*20 integer totcrd, ptrcrd, indcrd, valcrd, rhscrd, 1 nrow, ncol, nrhs integer n , nz , max_col, max_row integer col_ptr(max_order+1) double precision value(max_elems) integer col_ind(max_elems), row_ind(2*max_elems) integer row_perm(max_order), col_perm(max_order) integer nblocks, block_ptr(max_order+1) integer iwork(max_elems*8) double precision dwork(max_elems) integer iunit, ounit, job, ifmt character guesol*2 integer iflag integer i, j real tarray1(2), tarray2(2), t1, etime c----------------------------------------------------------------------- c read in the matrix c----------------------------------------------------------------------- iunit = 5 nrhs = 0 job = 2 call readmt( max_order, max_elems, job, iunit, value, row_ind, 1 col_ptr, dwork(1), nrhs, guesol, nrow, ncol, nz, title, 2 key, type, iflag) if (iflag .ne. 0) then write(0,*) 'ERROR: error in matrix read in' goto 5000 endif if (nrow.ne.ncol) then write(0,*) 'ERROR: matrix is not square' iflag = 1 goto 5000 endif n = ncol c----------------------------------------------------------------------- c eliminate the zero elements. c----------------------------------------------------------------------- num_zero = 0 do i = 1, n offset = num_zero do j = col_ptr(i), col_ptr(i+1)-1 if(value(j).eq.0.0e0) then num_zero = num_zero + 1 elseif(num_zero.ne.0) then value(j-num_zero) = value(j) row_ind(j-num_zero) = row_ind(j) endif enddo col_ptr(i) = col_ptr(i) - offset enddo nz = nz - num_zero col_ptr(n+1) = nz+1 c----------------------------------------------------------------------- c Initialize the values for the reordering c----------------------------------------------------------------------- max_row = 2*max_elems max_col = max_elems call getarg(1, cmode) mode = ichar(cmode) - 48 c----------------------------------------------------------------------- c Call the reordering c----------------------------------------------------------------------- c if (mode .eq. 1) then t1 = etime( tarray1 ) call bmp6(n,nz,value,row_ind,col_ptr, 1 row_perm, col_perm, nblocks, block_ptr, iwork(nz+1), 2 dwork, iwork(1),iflag ) t1 = etime( tarray2 ) if (iflag.ne.0) goto 5000 c else if (mode .eq. 2) then c t1 = etime( tarray1 ) c call mp6(n,nz,value,row_ind,col_ptr, c 1 row_perm, col_perm, nblocks, block_ptr, iwork(nz+1), c 2 dwork, iwork(1),iflag ) c t1 = etime( tarray2 ) c if (iflag.ne.0) goto 5000 else if (mode .eq. 2) then t1 = etime( tarray1 ) call p6(n,nz,value,row_ind,col_ptr, 1 row_perm, col_perm, nblocks, block_ptr, iwork(nz+1), 2 dwork, iwork(1),iflag ) t1 = etime( tarray2 ) if (iflag.ne.0) goto 5000 else write(0,*) 'the mode is unknow' endif c----------------------------------------------------------------------- c Output the matrix (without right-hand-side c----------------------------------------------------------------------- guesol = ' ' ifmt = 12 job = 2 ounit = 6 call prtmt(nrow, ncol, value, row_ind, col_ptr, dwork, guesol, & title, key, type, ifmt, job, ounit) c c print out the block pointers and number of blocks. c write (ounit, *) (nblocks) write (ounit, *) (block_ptr(i),i=1,nblocks+1) c c print out the permutation vector if needed c C write (ounit, *) (row_perm(i),i=1,n) C write (ounit, *) (col_perm(i),i=1,n) c----------------------------------------------------------------------- c Output the error flag and the time c----------------------------------------------------------------------- write( 0, 2010) tarray2(1)-tarray1(1) 5000 write( 0, 2000) iflag 2000 format(' Error Flag =', 1x, i3) 2010 format(' Reorder User Etime =', 1x , f8.4 ) stop end