0 写在前面
学习 MPI 过程中，写的几个小代码，现在分享一下
1 编译和运行
编译：
$ make SC=01_mpi_hello_world.f90
运行：
$ mpirun -n 4 ./a.out
Makefile
#!/usr/bin/bash
FC = mpifort
FF = -g -O0 -fbacktrace
#FF = -O2
SC =
all:
$(FC) $(FF) -o a.out $(SC)
clean:
rm -rf a.out
代码1
! 简单的 MPI 并行程序 Fortran 实现示例
!
! -- by Jackdaw
! -- QQ 群 Fortran Coder(2338021)
! -- 2018 10 24
!
! 第一个 MPI+Fortran 并行程序
!
program main
use mpi
implicit none
character(len=mpi_max_processor_name) :: p_name
integer :: myid, numProcs, nameLen, ierr
call mpi_init( ierr ) ! 完成 MPI程序 的初始化工作
! |
! + ---- 返回代码，与 mpi_success 相等时表示成功（out）
call mpi_comm_rank( mpi_comm_world, myid, ierr ) ! 获取当前进程标识号
! | | |
! | | + ---- 返回代码（out）
! | + ---------- 返回当前进程标识号（out）
! + ----------------------- 通信域（in）
call mpi_comm_size( mpi_comm_world, numProcs, ierr ) ! 获取通信域包含的进程数
! | | |
! | | + ---- 返回代码（out）
! | + -------------- 返回通信域内进程数（out）
! + --------------------------- 通信域（in）
call mpi_get_processor_name( p_name, nameLen, ierr ) ! 获取运行当前进程的机器名
! | | |
! | | + ---- 返回代码（out）
! | + ------------ 返回机器名长度（out）
! + -------------------- 返回机器名（out）
write(*,*) "Hello World! Processor ",myid," of ",numProcs," on ",p_name(1:nameLen)
call mpi_finalize( ierr ) ! 完成 MPI程序 的结束工作
end program
代码2
! 简单的 MPI 并行程序 Fortran 实现示例
!
! -- by Jackdaw
! -- QQ 群 Fortran Coder(2338021)
! -- 2018 10 24
!
! 演示简单的消息发送与接收
!
program main
use mpi
implicit none
integer :: myid, numProcs, nameLen, ierr
integer :: istat( mpi_status_size )
integer :: iid
character(19) :: message
call mpi_init( ierr ) ! 完成 MPI程序 的初始化工作
call mpi_comm_rank( mpi_comm_world, myid, ierr ) ! 获取当前进程标识号
call mpi_comm_size( mpi_comm_world, numProcs, ierr ) ! 获取通信域包含的进程数
if( myid .eq. 0 ) then
message = "Hello, Processor "
do iid = 1, numProcs -1
write(message(18:19),"(I2)") iid
call mpi_send( message, len(message), mpi_character, iid, 666, mpi_comm_world, ierr ) ! 消息发送
! | | | | | | |
! | | | | | | + ---- 返回代码（out）
! | | | | | + --------------- 通信域（in）
! | | | | + -------------------------- 消息标志，用于区分发送到同一进程的消息（in）
! | | | + ------------------------------- 目的进程标识号（in）
! | | + ---------------------------------------- 消息类型（in）
! | + ------------------------------------------------------ 消息数量（in）
! + ------------------------------------------------------------------- 发送缓冲区（in）
end do
else
call mpi_recv( message, len(message), mpi_character, 0, 666, mpi_comm_world, istat, ierr ) ! 消息接收
! | | | | | | | |
! | | | | | | | + ---- 返回代码（out）
! | | | | | | + ----------- 返回状态（out），包含发送进程标识号、消息标志、发送操作的错误代码
! | | | | | + ---------------------- 通信域（in）
! | | | | + --------------------------------- 消息标志（in）
! | | | + ------------------------------------- 源进程标识号（in）
! | | + ---------------------------------------------- 消息类型（in）
! | + ------------------------------------------------------------- 消息数量（in）
! + ------------------------------------------------------------------------ 接收缓冲区（in）
write(*,*) "Processor ",myid," received """,message,""" from Processor 0."
end if
call mpi_finalize( ierr ) ! 完成 MPI程序 的结束工作
end program
代码3
! 简单的 MPI 并行程序 Fortran 实现示例
!
! -- by Jackdaw
! -- QQ 群 Fortran Coder(2338021)
! -- 2018 10 24
!
! 用 MPI 实现计时功能
!
program main
use mpi
implicit none
integer :: myid, numProcs, nameLen, ierr
real(8) :: startTime, endTime, tick
call mpi_init( ierr ) ! 完成 MPI程序 的初始化工作
call mpi_comm_rank( mpi_comm_world, myid, ierr ) ! 获取当前进程标识号
call mpi_comm_size( mpi_comm_world, numProcs, ierr ) ! 获取通信域包含的进程数
startTime = mpi_wtime() ! 获取当前时间
call sleep(2)
endTime = mpi_wtime() ! 获取当前时间
tick = mpi_wtick() ! 获取一个始终周期时间
write(*,"(a,f15.10,a)") 'It took ',endTime - startTime, ' s'
write(*,"(a,f15.10,a)") 'Time accuracy: ',tick , ' s'
call mpi_finalize( ierr ) ! 完成 MPI程序 的结束工作
end program main
代码4
! 简单的 MPI 并行程序 Fortran 实现示例
!
! -- by Jackdaw
! -- QQ 群 Fortran Coder(2338021)
! -- 2018 10 24
!
! 获取 MPI 主/次版本号
!
program main
use mpi
implicit none
character(len=mpi_max_processor_name) :: p_name
integer :: version, subversion, nameLen, ierr
call mpi_init( ierr ) ! 完成 MPI程序 的初始化工作
call mpi_get_processor_name( p_name, nameLen, ierr ) ! 获取运行当前进程的机器名
call mpi_get_version( version, subversion, ierr ) ! 获取 MPI 版本号
! | | |
! | | +---- 返回代码（out）
! | + ------------ 主版本号（out）
! + ----------------------- 次版本号（out）
write(*,"(2a,2(a,i1))") "Host name: ",p_name(1:nameLen),&
", MPI version: ",version,'.',subversion
call mpi_finalize( ierr ) ! 完成 MPI程序 的结束工作
end program
代码5
! 简单的 MPI 并行程序 Fortran 实现示例
!
! -- by Jackdaw
! -- QQ 群 Fortran Coder(2338021)
! -- 2018 10 24
!
! 演示 mpi_initialized 和 mpi_abort(主动退出)
!
program main
use mpi
implicit none
character(len=mpi_max_processor_name) :: p_name
logical :: init_flag
integer :: myid, numProcs, ierr
integer,parameter :: masterNode = 0
call mpi_initialized( init_flag, ierr ) ! 判断mpi_init是否被调用，唯一一个可以在mpi_init之前调用的子程序
! | |
! | + ---- 返回代码（out）
! + ------------- mpi_init 是否已执行标志（out）
if ( .not.init_flag ) then
write(*,*) "The subroutine mpi_init() has not been executed."
end if
call mpi_init( ierr ) ! 完成 MPI程序 的初始化工作
call mpi_comm_rank( mpi_comm_world, myid, ierr ) ! 获取当前进程标识号
call mpi_comm_size( mpi_comm_world, numProcs, ierr ) ! 获取通信域包含的进程数
if( myid .eq. masterNode ) then
write(*,*) "myid = ",myid," is masternode. Abort!"
call sleep(1)
call mpi_abort( mpi_comm_world, 99, ierr ) ! 使通信域中所有进程退出，并返回给调用环境一个错误码
! | | |
! | | + ---- 返回代码（out）
! | + --------- 错误码（in）
! + -------------------- 通信域（in）
else
write(*,*) "myid = ",myid," is not masternode. Barrier!"
call mpi_barrier( mpi_comm_world, ierr ) ! 同步进程
! | |
! | + ---- 返回代码（out）
! + ------------------ 通信域（in）
end if
call mpi_finalize( ierr ) ! 完成 MPI程序 的结束工作
end program
代码6
! 简单的 MPI 并行程序 Fortran 实现示例
!
! -- by Jackdaw
! -- QQ 群 Fortran Coder(2338021)
! -- 2018 10 24
!
! MPI 实现数据接力传送
!
program main
use mpi
implicit none
integer :: myid, numProcs, nameLen, ierr
integer :: istat( mpi_status_size )
integer :: var
call mpi_init( ierr ) ! 完成 MPI程序 的初始化工作
call mpi_comm_rank( mpi_comm_world, myid, ierr ) ! 获取当前进程标识号
call mpi_comm_size( mpi_comm_world, numProcs, ierr ) ! 获取通信域包含的进程数
do while( var .ge. 0 )
if( myid .eq. 0 ) then
write(*,"(a)" ) "Please input new value:"
read(*,*) var
write(*,"(a,i3,a,i8,a)" ) "proc ",myid," read <-<- (",var," )"
if( numProcs .gt. 1 ) then
call mpi_send( var, 1, mpi_integer, myid+1, 0, mpi_comm_world, ierr ) ! 消息发送
write(*,"(a,i3,a,i8,a,i8)" ) "proc ",myid," send (",var," ) ->-> proc ",myid+1
end if
else
call mpi_recv( var, 1, mpi_integer, myid-1, 0, mpi_comm_world, istat, ierr ) ! 消息接收
write(*,"(a,i3,a,i8,a,i8)" ) "proc ",myid," recive (",var," ) <-<- proc ",myid-1
if( myid .lt. numProcs-1 ) then
write(*,"(a,i3,a,i8,a,i8)" ) "proc ",myid," send (",var," ) ->-> proc ",myid+1
call mpi_send( var, 1, mpi_integer, myid+1, 0, mpi_comm_world, ierr ) ! 消息发送
end if
end if
call mpi_barrier( mpi_comm_world, ierr )
end do
call mpi_finalize( ierr ) ! 完成 MPI程序 的结束工作
end program main
代码7
! 简单的 MPI 并行程序 Fortran 实现示例
!
! -- by Jackdaw
! -- QQ 群 Fortran Coder(2338021)
! -- 2018 10 24
!
! 任意进程间相互问候
!
program main
use mpi
implicit none
integer :: myid, numProcs, nameLen, ierr
character(len=mpi_max_processor_name) :: p_name
call mpi_init( ierr ) ! 完成 MPI程序 的初始化工作
call mpi_comm_rank( mpi_comm_world, myid, ierr ) ! 获取当前进程标识号
call mpi_comm_size( mpi_comm_world, numProcs, ierr ) ! 获取通信域包含的进程数
if( numProcs .lt. 2 ) then
write(*,*) "System requires at least 2 processors."
call mpi_abort( mpi_comm_world, 1, ierr )
end if
call mpi_get_processor_name( p_name, nameLen, ierr ) ! 获取运行当前进程的机器名
write(*,*) "Processor ",myid," is alive on ",p_name(1:nameLen),"."
call sleep(1)
call mpi_barrier( mpi_comm_world, ierr )
call hello()
call mpi_finalize( ierr ) ! 完成 MPI程序 的结束工作
end program main
! ##############################################################################
!
! 任意两个进程间交换信息，问候信息由发送进程标识和接收进程标识组成
!
! ##############################################################################
subroutine hello()
use mpi
implicit none
integer :: nproc, me, type = 1
integer :: buffer(2), node
integer :: istat( mpi_status_size ), ierr
call mpi_comm_rank( mpi_comm_world, me, ierr )
call mpi_comm_size( mpi_comm_world, nproc, ierr )
if( me .eq. 0 ) then
write(*,*) "Hello test from all to all."
end if
do node = 0, nproc-1
if( node .ne. me ) then
buffer(1) = me
buffer(2) = node
! 首先将问候信息发出
call mpi_send( buffer, 2, mpi_integer, node, type, mpi_comm_world, ierr ) ! 消息发送
! 然后接收被问候进程对自己发送的问候信息
call mpi_recv( buffer, 2, mpi_integer, node, type, mpi_comm_world, istat, ierr ) ! 消息接收
if( buffer(1) .ne. node .or. buffer(2) .ne. me ) then
write(*,*) "Hello: ",buffer(1)," = ",node," or ",buffer(2)," = ",me
write(*,*) "Mismatch on hello processors; node = ",node
end if
write(*,*) "Hello from ",me," to ",node,"."
end if
end do
end subroutine
代码8
! 简单的 MPI 并行程序 Fortran 实现示例
!
! -- by Jackdaw
! -- QQ 群 Fortran Coder(2338021)
! -- 2018 10 24
!
! 任意源和任意标志的使用
!
program main
use mpi
implicit none
integer :: myid, numProcs, ierr
integer :: istat( mpi_status_size )
integer :: i,var
call mpi_init( ierr ) ! 完成 MPI程序 的初始化工作
call mpi_comm_rank( mpi_comm_world, myid, ierr ) ! 获取当前进程标识号
call mpi_comm_size( mpi_comm_world, numProcs, ierr ) ! 获取通信域包含的进程数
if( myid .eq. 0 ) then
do i = 1, 10
call mpi_recv( var, 1, mpi_integer, mpi_any_source, mpi_any_tag, mpi_comm_world, istat, ierr ) ! 消息接收
write(*,*) "Msg = ",var," from ",istat(mpi_source)," with tag ",istat(mpi_tag)
end do
else
do i = 1, 10
var = myid + i
call mpi_send( var, 1, mpi_integer, 0, i, mpi_comm_world, ierr ) ! 消息发送
end do
end if
call mpi_finalize( ierr ) ! 完成 MPI程序 的结束工作
end program main
网友评论