高性能并行计算.doc

cannon.f ************************************************************************ ************************************************************************ subroutine cannon( a, lda, b, ldb, c, ldc, m, n, k, rowcomm, colcomm, w, iw ) implicit none include mpif.h integer lda, ldb, ldc, m, n, k, rowcomm, colcomm, iw(*) real a(lda, *), b(ldb, *), c(ldc, *), w(*) * integer lma, lka, lkb, lnb, lmc, lnc, ldw, ldw1 * integer nr, nc, rid, cid, ierr, res, arect, brect, nrb integer root, north, south, sta(mpi_status_size), i * call mpi_comm_size( colcomm, nr, ierr ) call mpi_comm_rank( colcomm, rid, ierr ) call mpi_comm_size( rowcomm, nc, ierr ) call mpi_comm_rank( rowcomm, cid, ierr ) * lma = m/nr res = mod( m, nr ) if ( rid .lt. res ) lma = lma + 1 * lka = k/nc res = mod( k, nc ) if ( cid .lt. res ) lka = lka + 1 * lkb = k/nr res = mod( k, nr ) if ( rid .lt. res ) lkb = lkb + 1 * lnc = n/nc res = mod( n, nc ) if ( cid .lt. res ) lnc = lnc + 1 lmc = lma lnb = lnc ldw = lma + 1 call mpi_allgather( lkb, 1, mpi_integer, iw, 1, mpi_integer, colcomm, ierr ) nrb = iw(1) ldw1 = ldb * if ( nr .ne. nc ) return * call mpirect( lda, lma, nrb, arect ) call mpi_type_commit( arect, ierr ) call mpirect( ldb, nrb, lnb, brect ) call mpi_type_commit( brect, ierr ) call wrapinita(a, lda, lma, lka, rid, cid, nr, nc) call wrapinitb(b, ldb, lkb, lnb, rid, cid, nr, nc) call zeroc( c, ldc, lmc, lnc ) * north = mod( nr+rid-1, nr ) south = mod( rid+1, nr ) root = 0 * do 100 i=0, nr-1 root = mod(rid + i, nr) call mcopy( a, lda, w, ldw, lma, lka ) call mpi_bcast( w, 1, arect, root, rowcomm, ierr ) k = root + 1 call sgemm(w, ldw, b, ldb, c, ldc, lma, iw(k), lnc) *