subroutine spacku ( packup, uplo, n, na, fulla ) **************************************************************************** * * * DATA PARALLEL BLAS based on MPL * * * * Version 1.0 1/9-92 , * * For MasPar MP-1 computers * * * * para//ab, University of Bergen, NORWAY * * * * These programs must be called using F90 style array syntax. * * Note that the F77 style calling sequence has been retained * * in this version for compatibility reasons, be aware that * * parameters related to the array dimensions and shape therefore may * * be redundant and without any influence. * * The calling sequence may be changed in a future version. * * Please report any BUGs, ideas for improvement or other * * comments to * * adm@parallab.uib.no * * * * Future versions may then reflect your suggestions. * * The most current version of this software is available * * from netlib@nac.no , send the message `send index from maspar' * * * * REVISIONS: * * * **************************************************************************** implicit none c integer n, na real, array(n,n) :: fulla real, array(na) :: packup character*1 uplo logical lsame external lsame c c local variables c integer i, j integer, array(n,n) :: nrow, ncol, whereis * * Set up the where array * cts do i = 1 , n cts ncol(:,i) = i cts nrow(i,:) = i cts enddo forall (i=1:n,j=1:n) ncol(i,j) = j forall (i=1:n,j=1:n) nrow(i,j) = i c if ( lsame (uplo, 'U') ) then whereis = ncol whereis = (whereis * (whereis-1)) / 2 whereis = whereis + nrow c c so if whereis is 4 by 4 then it now stores c c 1 2 4 7 c 2 3 5 8 c 3 4 6 9 c 4 5 7 10 c else whereis = n + 1 - ncol whereis = (n*(n-1)) / 2 - ((whereis*(whereis-1)) / 2) whereis = whereis + nrow c c so if whereis is 4 by 4 then it now stores c c 1 4 6 7 c 2 5 7 8 c 3 6 8 9 c 4 7 9 10 c endif c c c set up fulla by getting data from ap(whereis) c if ( lsame (uplo, 'U') ) then chu forall (i = 1:n, j=1:n, i .le. j) chu & packup(whereis(i,j)) = fulla(i,j) do j = 1 , n packup(whereis(1:j,j)) = fulla(1:j,j) enddo cts do j = 1 , n cts do i = 1 , j cts packup(whereis(i,j)) = fulla(i,j) cts enddo cts enddo chu else chu forall (i = 1:n, j=1:n, i .ge. j) chu & packup(whereis(i,j)) = fulla(i,j) do j = 1 , n packup(whereis(j:n,j)) = fulla(j:n,j) enddo cts do j = 1 , n cts do i = j , n cts packup(whereis(i,j)) = fulla(i,j) cts enddo cts enddo endif return end