代码 | 程序员节，分享几个MPI+Fortran小代码
学习 MPI 过程中，写的几个小代码，现在分享一下
因为原文章已消失，此教程排版十分工整，便于学习，因此手动搬家过来～
编译：
$ make SC=01_mpi_hello_world.f90
运行：
$ mpirun -n 4 ./a.out
Makefile
#!/usr/bin/bashFC = 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
版权声明：本文为qianjiashi原创文章，遵循 CC 4.0 BY-SA 版权协议，转载请附上原文出处链接和本声明。