代碼 | 程序員節，分享幾個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