fortran66のブログ

fortran について書きます。

Compaq のテキストより その２

MPI

昔学んだテキストが出てきたので、f90 で書き直してみたりしなかったりします。

http://h50146.www5.hp.com/solutions/hpc/stc/soft/mpi.html
MPIプログラミング入門
http://h50146.www5.hp.com/solutions/hpc/stc/soft/pdfs/mpi_training.pdf　（PDF直リン）

C:\program files\MPICH2\bin\mpiexec.exe -localonly 2 $(TargetPath) ****.exe

スレッド数は適宜調整のこと。

  • 例題 3-4d
PROGRAM mpi_3
USE mpi
IMPLICIT NONE
INTEGER, PARAMETER :: nprocs = 3, nmax = 12 / nprocs
INTEGER :: mstatus(MPI_STATUS_SIZE)
INTEGER :: n(0:nmax + 1), na(0:nmax + 1)
INTEGER :: i, isize, irank, ierr, iLF, iRT, ireq1, ireq2

CALL MPI_INIT(ierr)
CALL MPI_COMM_SIZE(MPI_COMM_WORLD, isize, ierr)
CALL MPI_COMM_RANK(MPI_COMM_WORLD, irank, ierr)
IF (isize /= nprocs) THEN
 CALL MPI_FINALIZE(ierr)
 STOP 
END IF
DO i = 1, nmax
 n(i) = irank * nmax + i
END DO

iLF = irank - 1
IF (irank == 0) iLF = MPI_PROC_NULL
iRT = irank + 1
IF (irank == isize - 1) iRT = MPI_PROC_NULL

CALL MPI_SENDRECV(n(nmax), 1, MPI_INTEGER, iRT, 1, &
                  n(0)    , 1, MPI_INTEGER, iLF, 1, &
                  MPI_COMM_WORLD, mstatus, ierr)

CALL MPI_SENDRECV(n(1)      , 1, MPI_INTEGER, iLF, 1, &
                  n(nmax + 1), 1, MPI_INTEGER, iRT, 1, &
                  MPI_COMM_WORLD, mstatus, ierr)

DO i = 1, nmax
 na(i) = n(i - 1) + n(i) + n(i + 1)
END DO

PRINT *, 'rank[', irank, '] : ', (na(i), i = 1, nmax)

IF (irank == 0) PAUSE

CALL MPI_FINALIZE(ierr)
STOP
END PROGRAM mpi_3

  • 例題 4-3a
PROGRAM test
USE mpi
IMPLICIT NONE
INTEGER :: mstatus(MPI_STATUS_SIZE)
INTEGER :: n(12) = 0
INTEGER :: i, isize, irank, ierr, inewvec

CALL MPI_INIT(ierr)
CALL MPI_COMM_RANK(MPI_COMM_WORLD, irank, ierr)
CALL MPI_COMM_SIZE(MPI_COMM_WORLD, isize, ierr)
IF (irank == 0) n = [ (i, i = 1, 12) ]

CALL MPI_TYPE_VECTOR(3, 2, 3, MPI_INTEGER, inewvec, ierr)
CALL MPI_TYPE_COMMIT(inewvec, ierr)

SELECT CASE(irank)
 CASE(0)

  CALL MPI_SEND(n(1), 1, inewvec, 1, 1, MPI_COMM_WORLD, ierr) 

 CASE(1)

  CALL MPI_RECV(n(2), 1, inewvec, 0, 1, MPI_COMM_WORLD, mstatus, ierr) 

 CASE DEFAULT
  STOP 'error'
END SELECT

PRINT '(a, i2, 2x, 12i3)', 'rank:', irank, n(:)

CALL MPI_TYPE_FREE(inewvec, ierr)
IF (irank == 0) PAUSE
CALL MPI_FINALIZE(ierr)
STOP
!------------------------------------
END PROGRAM test

  • 例題 4-3b
PROGRAM mpi4
USE mpi
IMPLICIT NONE
INTEGER, PARAMETER :: imax = 8, jmax = 8
INTEGER :: mstatus(MPI_STATUS_SIZE)
INTEGER :: i, j, ilen, jlen, n(imax, jmax) = 0
INTEGER :: isize, irank, ierr, isubmtx

CALL MPI_INIT(ierr)
CALL MPI_COMM_RANK(MPI_COMM_WORLD, irank, ierr)
CALL MPI_COMM_SIZE(MPI_COMM_WORLD, isize, ierr)

IF (irank == 0) THEN
 DO i = 1, imax
  DO j = 1, jmax
    n(i, j) = 100 * i + j
  END DO
 END DO
END IF

ilen = 4
jlen = 4
CALL MPI_TYPE_VECTOR(jlen, ilen, imax, MPI_INTEGER, isubmtx, ierr)
CALL MPI_TYPE_COMMIT(isubmtx, ierr)

SELECT CASE(irank)
 CASE(0)

   CALL MPI_SEND(n(1, 5), 1, isubmtx, 1, 1, MPI_COMM_WORLD, ierr) 

 CASE(1)

   CALL MPI_RECV(n(5, 1), 1, isubmtx, 0, 1, MPI_COMM_WORLD, mstatus, ierr) 

 CASE DEFAULT
  STOP 'error'
END SELECT

PRINT '(a, i2)', 'rank:', irank
PRINT '(8i4)', ((n(i, j), j = 1, 8), i = 1, 8)

CALL MPI_TYPE_FREE(isubmtx, ierr)

IF (irank == 0) PAUSE

CALL MPI_FINALIZE(ierr)
STOP
END PROGRAM mpi4

  • 4-4
PROGRAM mpi4
USE mpi
IMPLICIT NONE
INTEGER, PARAMETER :: mmax = 16, nmax = 16, mm = mmax / 4
INTEGER :: mstatus(MPI_STATUS_SIZE)
INTEGER :: i, j, ilen, jlen, n(0:mm + 1, 0:nmax + 1), m(0:mm + 1, 0:nmax + 1)
INTEGER :: iup, idw, isize, irank, ierr, inewvec

CALL MPI_INIT(ierr)
CALL MPI_COMM_RANK(MPI_COMM_WORLD, irank, ierr)
CALL MPI_COMM_SIZE(MPI_COMM_WORLD, isize, ierr)

 DO i = 1, nmax
  DO j = 1, mm
    n(j, i) = i + 100 * j !+ 1000 * irank 
  END DO
 END DO

CALL MPI_TYPE_VECTOR(nmax, 1, mm + 2, MPI_INTEGER, inewvec, ierr)
CALL MPI_TYPE_COMMIT(inewvec, ierr)

iup = irank - 1 
IF (irank == 0) iup = 3
idw = irank + 1
IF (irank == isize - 1) idw = 0

CALL MPI_SENDRECV(n(mm, 1), 1, inewvec, idw, 1, n(0     ,  1), 1, inewvec, iup, 1, MPI_COMM_WORLD, mstatus, ierr) 
CALL MPI_SENDRECV(n( 1, 1), 1, inewvec, iup, 1, n(mm + 1,  1), 1, inewvec, idw, 1, MPI_COMM_WORLD, mstatus, ierr) 


DO i = 1, mm
 n(i, 0       ) = n(i, nmax)
 n(i, nmax + 1) = n(i, i)
END DO

DO j = 1, nmax
 DO i = 1, mm 
  m(i, j) = n(i - 1, j) + n(i, j - 1) + n(i, j + 1) + n(i + 1, j)
 END DO
END DO

IF (irank == 2) THEN
 PRINT '(a, i2)', 'irank:', irank
 PRINT '(18i5)' , ((m(i, j), j = 0, nmax + 1), i = 0, mm + 1)
END IF

CALL MPI_TYPE_FREE(inewvec, ierr)

IF (irank == 0) PAUSE
CALL MPI_FINALIZE(ierr)
STOP
!------------------------------------
END PROGRAM mpi4


PROGRAM mpi4
USE mpi
IMPLICIT NONE
LOGICAL :: period(2)
INTEGER :: idivid(2), iud(2), ilr(2), idisp(2), narg, nainfo(3)
INTEGER :: i, isize, irank, ierr, iptbl
CHARACTER(16) :: argv

CALL MPI_INIT(ierr)
CALL MPI_COMM_RANK(MPI_COMM_WORLD, irank, ierr)
CALL MPI_COMM_SIZE(MPI_COMM_WORLD, isize, ierr)

narg = COMMAND_ARGUMENT_COUNT()
IF (narg == 3) THEN
 DO i = 1, narg
  CALL GET_COMMAND_ARGUMENT(i, argv)
  READ(argv, '(i)') nainfo(i)
 END DO 
ELSE
 PRINT *, 'input error: COMMAND  rank i j'
 STOP
END IF 

idivid(1) = 4
idivid(2) = 4
period(1) = .FALSE.
period(2) = .FALSE.

CALL MPI_CART_CREATE(MPI_COMM_WORLD, 2, idivid, period, .FALSE., iptbl, ierr)

idisp(1) = nainfo(2)
idisp(2) = nainfo(3)

CALL MPI_CART_SHIFT(iptbl, 0, idisp(1), iud(1), iud(2), ierr)
CALL MPI_CART_SHIFT(iptbl, 1, idisp(2), ilr(1), ilr(2), ierr)

IF ( irank == nainfo(1) ) THEN
  PRINT '(3x, i3)', iud(1)
  PRINT '(3i3)', ilr(1), irank, ilr(2)
  PRINT '(3x, i3)', iud(2)
END IF

CALL MPI_COMM_FREE(iptbl, ierr)
IF (irank == 0) PAUSE
CALL MPI_FINALIZE(ierr)
STOP
END PROGRAM mpi4


PROGRAM mpi4
USE mpi
IMPLICIT NONE
INTEGER, PARAMETER :: mdiv = 3, ndiv = 4
INTEGER, PARAMETER :: mm = 12, nn = 16
INTEGER, PARAMETER :: mmax = mm / 3, nmax = nn / 4 
LOGICAL :: period(2)
INTEGER :: mstatus(MPI_STATUS_SIZE)
INTEGER :: idivid(2), iup, idw, ilf, irt
INTEGER :: ia(0:mmax + 1, 0:nmax + 1), ib(0:mmax + 1, 0:nmax + 1)
INTEGER :: i, j, isize, irank, ierr, inewvec, iptbl

CALL MPI_INIT(ierr)
CALL MPI_COMM_RANK(MPI_COMM_WORLD, irank, ierr)
CALL MPI_COMM_SIZE(MPI_COMM_WORLD, isize, ierr)

idivid(1) = mdiv
idivid(2) = ndiv
period(1) = .TRUE.
period(2) = .TRUE.

CALL MPI_CART_CREATE(MPI_COMM_WORLD, 2, idivid, period, .FALSE., iptbl, ierr)

CALL MPI_CART_SHIFT(iptbl, 0, 1, iup, idw, ierr)
CALL MPI_CART_SHIFT(iptbl, 1, 1, ilf, irt, ierr)

CALL MPI_TYPE_VECTOR(nmax, 1, nmax + 2, MPI_INTEGER, inewvec, ierr)
CALL MPI_TYPE_COMMIT(inewvec, ierr)

DO j = 1, nmax
 DO i = 1, mmax
  ia(i, j) = i + j * 100
 END DO
END DO 

CALL MPI_SENDRECV(ia(nmax,    1),    1, inewvec, idw, 1, ia(0       , 1),    1, inewvec, iup, 1, MPI_COMM_WORLD, mstatus, ierr)
CALL MPI_SENDRECV(ia(   1,    1),    1, inewvec, iup, 1, ia(nmax + 1, 1),    1, inewvec, idw, 1, MPI_COMM_WORLD, mstatus, ierr)
CALL MPI_SENDRECV(ia(   1, nmax), mmax, MPI_INTEGER, irt, 1, ia(1       , 0), mmax, MPI_INTEGER, ilf, 1, MPI_COMM_WORLD, mstatus, ierr)
CALL MPI_SENDRECV(ia(   1,    1), mmax, MPI_INTEGER, ilf, 1, ia(1, nmax + 1), mmax, MPI_INTEGER, irt, 1, MPI_COMM_WORLD, mstatus, ierr)

DO j = 1, nmax
 DO i = 1, mmax
  ib(i, j) = ia(i - 1, j) + ia(i, j - 1) + ia(i, j + 1) + ia(i + 1, j)
 END DO
END DO   

!IF ( irank == 0 ) THEN
!  PRINT '(6i4)', TRANSPOSE(ia)
!END IF

IF ( irank == 0 ) THEN
  PRINT '(6i4)', TRANSPOSE(ib)
END IF


CALL MPI_COMM_FREE(iptbl, ierr)
CALL MPI_TYPE_FREE(inewvec, ierr)
IF (irank == 0) PAUSE
CALL MPI_FINALIZE(ierr)
STOP
END PROGRAM mpi4