代码 | 程序员节，分享几个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