├── helloworld ├── hw-coarray.f90 └── hw-mpi.f90 ├── broadcast ├── bcast-get-coarray.f90 ├── bcast-put-coarray.f90 └── bcast-mpi.f90 ├── neighbour ├── neighbour-coarray.f90 └── neighbour-mpi.f90 ├── vm ├── Vagrantfile ├── README.md └── install-sw.sh ├── Makefile ├── README.md ├── blockmatrixmult ├── blockmatrix-coarray.f90 └── blockmatrix-mpi.f90 └── diffusion ├── diffusion-coarray.f90 ├── diffusion-mpi.f90 └── diffusion-nonblocking-mpi.f90 /helloworld/hw-coarray.f90: -------------------------------------------------------------------------------- 1 | program CAFHelloworld 2 | 3 | print *, 'Hello, world, from image ', this_image(), & 4 | 'of ', num_images(), '!'! 5 | 6 | end program CAFHelloWorld 7 | -------------------------------------------------------------------------------- /broadcast/bcast-get-coarray.f90: -------------------------------------------------------------------------------- 1 | program broadcast2 2 | implicit none 3 | integer :: a[*] 4 | 5 | if (this_image() == 1) then 6 | print *, "Please enter a number." 7 | read *, a 8 | end if 9 | 10 | sync all 11 | 12 | a = a[1] 13 | 14 | print *, this_image(), ' has a = ', a 15 | end program broadcast2 16 | -------------------------------------------------------------------------------- /neighbour/neighbour-coarray.f90: -------------------------------------------------------------------------------- 1 | program coarray1 2 | implicit none 3 | integer :: me, right, i 4 | integer, dimension(3), codimension[*] :: a 5 | 6 | me = this_image() 7 | 8 | right = me + 1 9 | if (right > num_images()) right = 1 10 | 11 | a(:) = [ (me**i, i=1, 3) ] 12 | 13 | sync all 14 | 15 | print *, "Image ", me, " has a(2) = ", a(2)[me], "; neighbour has ", a(2)[right] 16 | end program coarray1 17 | -------------------------------------------------------------------------------- /broadcast/bcast-put-coarray.f90: -------------------------------------------------------------------------------- 1 | program broadcast 2 | implicit none 3 | integer :: a[*] 4 | integer :: i 5 | 6 | if (this_image() == 1) then 7 | print *, "Please enter a number." 8 | read *, a 9 | do i=1,num_images() 10 | a[i] = a 11 | end do 12 | end if 13 | 14 | sync all 15 | 16 | print *, this_image(), ' has a = ', a 17 | end program broadcast 18 | -------------------------------------------------------------------------------- /helloworld/hw-mpi.f90: -------------------------------------------------------------------------------- 1 | program MPIHelloworld 2 | use mpi 3 | implicit none 4 | integer :: ierr, rank, comsize 5 | 6 | call MPI_Init(ierr) 7 | call MPI_Comm_size(MPI_COMM_WORLD, comsize, ierr) 8 | call MPI_Comm_rank(MPI_COMM_WORLD, rank, ierr) 9 | 10 | 11 | print *, 'Hello, world, from image ', rank, & 12 | 'of ', comsize, '!' 13 | 14 | call MPI_Finalize(ierr) 15 | end program MPIHelloWorld 16 | -------------------------------------------------------------------------------- /broadcast/bcast-mpi.f90: -------------------------------------------------------------------------------- 1 | program broadcast 2 | use mpi 3 | implicit none 4 | integer :: a 5 | integer :: ierr, rank 6 | 7 | call MPI_Init(ierr) 8 | call MPI_Comm_rank(MPI_COMM_WORLD, rank, ierr) 9 | 10 | if (rank == 0) then 11 | print *, "Please enter a number." 12 | read *, a 13 | end if 14 | 15 | call MPI_Bcast(a, 1, MPI_INTEGER, 0, MPI_COMM_WORLD, ierr) 16 | 17 | print *, rank, ' has a = ', a 18 | call MPI_Finalize(ierr) 19 | end program broadcast 20 | -------------------------------------------------------------------------------- /vm/Vagrantfile: -------------------------------------------------------------------------------- 1 | # -*- mode: ruby -*- 2 | # vi: set ft=ruby : 3 | 4 | # Vagrantfile API/syntax version. Don't touch unless you know what you're doing! 5 | VAGRANTFILE_API_VERSION = "2" 6 | 7 | Vagrant.configure(VAGRANTFILE_API_VERSION) do |config| 8 | config.vm.box = "ubuntu/trusty64" 9 | 10 | config.vm.provision :shell, path: "install-sw.sh" 11 | 12 | config.vm.synced_folder ".", "/vagrant_dir" 13 | 14 | config.vm.provider "virtualbox" do |vb| 15 | vb.gui = false 16 | vb.name = "Coarray Fortran VM" 17 | vb.customize ["modifyvm", :id, "--memory", "2048" ] 18 | vb.cpus = 4 19 | end 20 | 21 | end 22 | -------------------------------------------------------------------------------- /Makefile: -------------------------------------------------------------------------------- 1 | MPI_DIR=/opt/mpich/3.1.4 2 | OPENCOARRAYS_DIR=/opt/opencoarrays/lib64 3 | 4 | ALLCOARRAYF90=$(wildcard */*-coarray.f90 ) 5 | ALLMPIF90=$(wildcard */*-mpi.f90 ) 6 | 7 | ALLCOARRAY=$(basename $(ALLCOARRAYF90)) 8 | ALLMPI=$(basename $(ALLMPIF90)) 9 | 10 | .PHONY: clean 11 | 12 | all: allcoarray allmpi 13 | 14 | allcoarray: $(ALLCOARRAY) 15 | 16 | allmpi: $(ALLMPI) 17 | 18 | %-coarray:%-coarray.f90 19 | ${MPI_DIR}/bin/mpifort $^ -fcoarray=lib -o $@ -L ${OPENCOARRAYS_DIR} -lcaf_mpi 20 | 21 | %-mpi:%-mpi.f90 22 | ${MPI_DIR}/bin/mpifort $^ -o $@ 23 | 24 | clean: 25 | -rm -f $(ALLCOARRAY) $(ALLMPI) 26 | -rm -f */*.o 27 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # Coarray Fortran Examples 2 | 3 | Simple Coarray Fortran examples for teaching. 4 | 5 | Using gfortran 5.1, mpich3, and the [OpenCoarrays](https://github.com/sourceryinstitute/opencoarrays) MPI 6 | backend, one compiles and runs these programs as follows: 7 | 8 | ``` 9 | mpifort diffusion/diffusion-coarray.f90 -fcoarray=lib -o diffusion/diffusion-coarray -L ${PATH_TO_OPENCOARRAY_LIB} -lcaf_mpi 10 | mpirun -np 8 diffusion/diffusion-coarray 11 | ``` 12 | 13 | A Makefile is provided which you can edit to include the relevant paths. 14 | 15 | If you don't have gcc 5.1 and opencoarrays installed, you can use the available vagrant VM; 16 | documentation for downloading the vagrant VM or building it can be found [in the vm directory](vm/README.md) 17 | -------------------------------------------------------------------------------- /neighbour/neighbour-mpi.f90: -------------------------------------------------------------------------------- 1 | program mpicoarray1 2 | use mpi 3 | implicit none 4 | integer :: me, nprocs, left, right, i, ierr 5 | integer, dimension(3) :: alocal, aneighbour 6 | 7 | call MPI_Init(ierr) 8 | call MPI_Comm_rank(MPI_COMM_WORLD, me, ierr) 9 | call MPI_Comm_size(MPI_COMM_WORLD, nprocs, ierr) 10 | 11 | right = me + 1 12 | left = me - 1 13 | if (right >= nprocs) right = 0 14 | if (left < 0) left = nprocs-1 15 | 16 | alocal = [ (me**i, i=1, 3) ] 17 | 18 | call MPI_Sendrecv( alocal, 3, MPI_INTEGER, left, 0, & 19 | aneighbour, 3, MPI_INTEGER, right , 0, & 20 | MPI_COMM_WORLD, MPI_STATUS_IGNORE, ierr) 21 | 22 | print *, "Image ", me, " has a(2) = ", alocal(2), "; neighbour has ", aneighbour(2) 23 | end program mpicoarray1 24 | -------------------------------------------------------------------------------- /vm/README.md: -------------------------------------------------------------------------------- 1 | # Vagrant VM instructions 2 | 3 | Hopefully this will be unnecessary in a month or so; but right now, packages for GCC 5.1 and OpenCoarrays 4 | aren't common. 5 | 6 | This is a vagrantfile for building or using a VM that has OpenCoarrays, GCC 5.1, and MPICH3 installed. 7 | OpenCoarrays, for simplicity, has been built with the less-performant MPI backend. 8 | 9 | To use this Virtual Machine, 10 | 11 | * Install [Vagrant](https://www.vagrantup.com) 12 | * Install [VirtualBox](https://www.virtualbox.org) 13 | * To build the VM yourself, 14 | * Type `vagrant up` in this directory and the base VM will install, as will the software 15 | * The gcc build can take about an hour. 16 | * Otherwise, in a seperate directory, 17 | * Type `vagrant init ljdursi/opencoarrayVM` 18 | * Type `vagrant up`; this will download and start the binary VM. 19 | * Once the VM is up and runnning, type `vagrant ssh` in that directory to log into the VM. 20 | * From there, you should be able to `cd coarray-examples` and type `make` to build the examples. 21 | * Then, _eg_, `mpirun -np 4 helloworld/hw-coarray` will run them. 22 | -------------------------------------------------------------------------------- /vm/install-sw.sh: -------------------------------------------------------------------------------- 1 | #!/bin/bash 2 | sudo apt-get update 3 | sudo apt-get install -y g++ 4 | sudo apt-get install -y libmpfr-dev libgmp-dev libmpc-dev 5 | sudo apt-get install -y git 6 | sudo apt-get install -y make 7 | 8 | mkdir tmp 9 | cd tmp 10 | ## 11 | ##GCC 12 | ## 13 | wget http://mirrors.concertpass.com/gcc/releases/gcc-5.1.0/gcc-5.1.0.tar.bz2 14 | tar -xjf gcc-5.1.0.tar.bz2 15 | rm -rf gcc-5.1.0.tar.bz2 16 | cd gcc-5.1.0 17 | ./configure --prefix=/opt/gcc/5.1 --enable-threads --enable-languages=c,c++,fortran --disable-multilib 18 | make -j 3 19 | sudo make install 20 | cd .. 21 | rm -rf gcc-5.1.0 22 | sudo apt-get remove -y g++ 23 | 24 | export PATH=/opt/gcc/5.1/bin:${PATH} 25 | export LD_LIBRARY_PATH=/opt/gcc/5.1/lib64:${LD_LIBRARY_PATH} 26 | ## 27 | ##MPICH3 28 | ## 29 | wget http://www.mpich.org/static/downloads/3.1.4/mpich-3.1.4.tar.gz 30 | tar -xzf mpich-3.1.4.tar.gz 31 | cd mpich-3.1.4 32 | FC=/opt/gcc/5.1/bin/gfortran F77=/opt/gcc/5.1/bin/gfortran CC=/opt/gcc/5.1/bin/gcc CXX=/opt/gcc/5.1/bin/g++ ./configure --prefix=/opt/mpich/3.1.4 --enable-fortran=f77,fc --enable-romio --enable-threads=runtime 33 | make -j 3 34 | sudo make install 35 | cd .. 36 | rm -rf mpich-3.1.4 mpich-3.1.4.tar.gz 37 | ## 38 | ## Open Coarrays 39 | ## 40 | cd .. 41 | git clone https://github.com/sourceryinstitute/opencoarrays.git 42 | cd opencoarrays 43 | FC=/opt/gcc/5.1/bin/gfortran GCC=/opt/gcc/5.1/bin/gcc MPFC=/opt/mpich/3.1.4/bin/mpifort MPICC=/opt/mpich/3.1.4/bin/mpicc make mpi 44 | sudo mkdir -p /opt/opencoarrays/lib64 45 | sudo cp mpi/libcaf_mpi.a /opt/opencoarrays/lib64 46 | 47 | cd 48 | 49 | rm -rf tmp 50 | 51 | echo 'export PATH=/opt/gcc/5.1/bin:/opt/mpich/3.1.4/bin:${PATH}' >> ~/.bashrc 52 | echo 'export LD_LIBRARY_PATH=/opt/gcc/5.1/lib64:/opt/mpich/3.1.4/lib:/opt/opencoarrays/lib64/:${LD_LIBRARY_PATH}' >> ~/.bashrc 53 | 54 | git clone https://github.com/ljdursi/coarray-examples.git 55 | -------------------------------------------------------------------------------- /blockmatrixmult/blockmatrix-coarray.f90: -------------------------------------------------------------------------------- 1 | program blockmatrix 2 | implicit none 3 | integer, dimension(:,:), codimension[:,:], allocatable :: a, b, c 4 | integer, dimension(:,:), allocatable :: bigmat 5 | integer :: numimgs 6 | integer :: nrows, ncols 7 | integer :: blockrows=5, blockcols=5 8 | integer :: myrow, mycol 9 | integer :: startrow, startcol 10 | integer :: i,j,k 11 | 12 | ! calculate block decomposition 13 | numimgs = num_images() 14 | call nearsquare(numimgs, nrows, ncols) 15 | if (nrows /= ncols) then 16 | print *,'Sorry, only works for square numbers of images right now.' 17 | stop 18 | endif 19 | allocate(a(blockrows,blockcols)[nrows,*]) 20 | allocate(b(blockcols,blockrows)[nrows,*]) 21 | allocate(c(blockrows,blockrows)[nrows,*]) 22 | 23 | ! where is this image in the decomposition? 24 | mycol = ceiling(this_image()*1./nrows) 25 | myrow = modulo(this_image(),nrows) 26 | if (myrow == 0) myrow=nrows 27 | 28 | ! initialize data 29 | startrow = (myrow-1)*blockrows+1 30 | startcol = (mycol-1)*blockcols+1 31 | do i=1,blockrows 32 | a(i,:) = startrow+i-1 33 | enddo 34 | do j=1,blockcols 35 | b(:,j) = startcol+j-1 36 | enddo 37 | 38 | ! do the multiplication 39 | sync all 40 | c = 0. 41 | do k=1,ncols 42 | c = c + matmul(a(:,:)[myrow,k],b(:,:)[k,mycol]) 43 | enddo 44 | sync all 45 | 46 | if (this_image() == 1) then 47 | allocate(bigmat(nrows*blockrows,ncols*blockcols)) 48 | bigmat = reshape( [((i,i=1,nrows*blockrows),j=1,ncols*blockcols)], & 49 | [nrows*blockrows, ncols*blockcols]) 50 | print *, 'Expected answer: ' 51 | bigmat = matmul(bigmat,transpose(bigmat)) 52 | do i=1,blockrows*nrows 53 | print '(50(I5,1X))',(bigmat(i,j),j=1,blockcols*ncols) 54 | enddo 55 | deallocate(bigmat) 56 | endif 57 | 58 | do k=1,num_images() 59 | if (this_image() == k) then 60 | print *, 'Image ', k, ' = ', myrow, ', ', mycol 61 | do i=1,blockrows 62 | print '(50(I5,1X))',(c(i,j),j=1,blockcols) 63 | enddo 64 | endif 65 | sync all 66 | enddo 67 | deallocate(a) 68 | deallocate(b) 69 | deallocate(c) 70 | 71 | contains 72 | subroutine nearsquare(n, a, b) 73 | implicit none 74 | integer, intent(in) :: n 75 | integer, intent(out) :: a, b 76 | 77 | do a=ceiling(sqrt(n*1.0)),1,-1 78 | b = n/a 79 | if (a*b == n) exit 80 | enddo 81 | end subroutine nearsquare 82 | 83 | end program blockmatrix 84 | -------------------------------------------------------------------------------- /blockmatrixmult/blockmatrix-mpi.f90: -------------------------------------------------------------------------------- 1 | program blockmatrix 2 | use mpi 3 | implicit none 4 | integer, dimension(:,:), allocatable :: a, b, c, aremote, bremote 5 | integer, dimension(:,:), allocatable :: bigmat 6 | integer :: rank, comsize, ierr 7 | integer :: nrows, ncols, dims(2)=0, coords(2) 8 | integer :: blockrows=5, blockcols=5 9 | integer :: myrow, mycol 10 | integer :: startrow, startcol 11 | integer :: i,j,k 12 | integer :: cartcomm, rowcomm, colcomm 13 | 14 | call MPI_Init(ierr) 15 | call MPI_Comm_size(MPI_COMM_WORLD, comsize, ierr) 16 | 17 | ! calculate block decomposition 18 | call MPI_Dims_create(comsize, 2, dims, ierr) 19 | nrows = dims(1) 20 | ncols = dims(2) 21 | if (nrows /= ncols) then 22 | print *,'Sorry, only works for square numbers of processes right now.' 23 | stop 24 | endif 25 | 26 | allocate(a(blockrows,blockcols)) 27 | allocate(b(blockcols,blockrows)) 28 | allocate(c(blockrows,blockrows)) 29 | allocate(aremote(blockrows,blockcols)) 30 | allocate(bremote(blockcols,blockrows)) 31 | 32 | call MPI_Cart_create(MPI_COMM_WORLD, 2, dims, [1,1], 1, cartcomm, ierr) 33 | call MPI_Comm_rank(cartcomm, rank, ierr) 34 | call MPI_Cart_coords(cartcomm, rank, 2, coords, ierr) 35 | mycol = coords(1)+1 36 | myrow = coords(2)+1 37 | 38 | ! create row, column communicators 39 | call MPI_Comm_split( cartcomm, myrow, mycol, rowcomm, ierr ) 40 | call MPI_Comm_split( cartcomm, mycol, myrow, colcomm, ierr ) 41 | 42 | ! initialize data 43 | startrow = (myrow-1)*blockrows+1 44 | startcol = (mycol-1)*blockcols+1 45 | do i=1,blockrows 46 | a(i,:) = startrow+i-1 47 | enddo 48 | do j=1,blockcols 49 | b(:,j) = startcol+j-1 50 | enddo 51 | 52 | ! do the multiplication 53 | c = 0. 54 | do k=0,ncols-1 55 | aremote = a 56 | bremote = b 57 | call MPI_Bcast(aremote, blockrows*blockcols, MPI_INTEGER, k, rowcomm, ierr) 58 | call MPI_Bcast(bremote, blockrows*blockcols, MPI_INTEGER, k, colcomm, ierr) 59 | c = c + matmul(aremote, bremote) 60 | enddo 61 | 62 | if (rank == 0) then 63 | allocate(bigmat(nrows*blockrows,ncols*blockcols)) 64 | bigmat = reshape( [((i,i=1,nrows*blockrows),j=1,ncols*blockcols)], & 65 | [nrows*blockrows, ncols*blockcols]) 66 | print *, 'Expected answer: ' 67 | bigmat = matmul(bigmat,transpose(bigmat)) 68 | do i=1,blockrows*nrows 69 | print '(50(I5,1X))',(bigmat(i,j),j=1,blockcols*ncols) 70 | enddo 71 | deallocate(bigmat) 72 | endif 73 | 74 | do k=0,comsize-1 75 | if (rank == k) then 76 | print *, 'Image ', k+1, ' = ', myrow, ', ', mycol 77 | do i=1,blockrows 78 | print '(50(I5,1X))',(c(i,j),j=1,blockcols) 79 | enddo 80 | endif 81 | call MPI_Barrier(MPI_COMM_WORLD,ierr) 82 | enddo 83 | deallocate(a) 84 | deallocate(b) 85 | deallocate(c) 86 | 87 | call MPI_Finalize(ierr) 88 | 89 | end program blockmatrix 90 | -------------------------------------------------------------------------------- /diffusion/diffusion-coarray.f90: -------------------------------------------------------------------------------- 1 | program diffuse 2 | implicit none 3 | ! 4 | ! simulation parameters 5 | ! 6 | integer, parameter :: totpoints=1000 7 | real, parameter :: xleft=-12., xright=+12. 8 | real, parameter :: kappa=1. 9 | integer, parameter :: nsteps=100000 10 | 11 | ! 12 | ! the calculated temperature, and the known correct 13 | ! solution from theory 14 | ! 15 | real, allocatable :: x(:) 16 | real, allocatable :: temperature(:,:)[:] 17 | real, allocatable :: theory(:) 18 | 19 | integer :: old=1, new=2 20 | integer :: step 21 | integer :: i 22 | real :: time 23 | real :: dt, dx 24 | real :: error 25 | 26 | integer :: unitno 27 | character(len=3) :: imgstr 28 | ! 29 | ! parameters of the original temperature distribution 30 | ! 31 | real, parameter :: ao=1., sigmao = 1. 32 | real :: a, sigma 33 | real :: fixedlefttemp, fixedrighttemp 34 | 35 | integer :: locnpoints, start 36 | integer :: left, right, nneighbours=0 37 | integer :: neighbours(2) 38 | real :: locxleft 39 | 40 | ! 41 | ! find local number of points and where we start in the 42 | ! global domain 43 | ! 44 | locnpoints = totpoints/num_images() 45 | start = locnpoints*(this_image()-1)+1 46 | if (this_image() == num_images()) then 47 | locnpoints = totpoints - locnpoints*(num_images()-1) 48 | endif 49 | left = this_image()-1 50 | right= this_image()+1 51 | if ( left >= 1 ) then 52 | nneighbours = nneighbours+1 53 | neighbours(nneighbours) = left 54 | endif 55 | if ( right <= num_images() ) then 56 | nneighbours = nneighbours+1 57 | neighbours(nneighbours) = right 58 | endif 59 | ! 60 | ! 61 | ! set parameters 62 | ! 63 | dx = (xright-xleft)/(totpoints-1) 64 | dt = dx**2 * kappa/10. 65 | 66 | locxleft = xleft + dx*(start-1) 67 | ! prefix for our files 68 | ! 69 | write(imgstr,'(I03)') this_image() 70 | 71 | ! 72 | ! allocate data, including ghost cells: old and new timestep 73 | ! theory doesn't need ghost cells, but we include it for simplicity 74 | ! 75 | allocate(temperature(locnpoints+2,2)[*]) 76 | allocate(theory(locnpoints+2)) 77 | allocate(x(locnpoints+2)) 78 | ! 79 | ! setup initial conditions 80 | ! 81 | time = 0. 82 | x = locxleft + [((i-1)*dx,i=1,locnpoints+2)] 83 | temperature(:,old) = ao*exp(-(x)**2 / (2.*sigmao**2)) 84 | theory= ao*exp(-(x)**2 / (2.*sigmao**2)) 85 | 86 | fixedlefttemp = ao*exp(-(xleft-dx)**2 / (2.*sigmao**2)) 87 | fixedrighttemp= ao*exp(-(xright+dx)**2 / (2.*sigmao**2)) 88 | 89 | open(newunit=unitno,file=trim(adjustl(imgstr))//'-ics.txt') 90 | do i=2,locnpoints+1 91 | write(unitno,'(3(F8.3,3X))'),x(i),temperature(i,old), theory(i) 92 | enddo 93 | close(unitno) 94 | 95 | ! 96 | ! evolve 97 | ! 98 | do step=1, nsteps 99 | ! 100 | ! boundary conditions: keep endpoint temperatures fixed. 101 | ! 102 | temperature(1,old) = fixedlefttemp 103 | temperature(locnpoints+2,old) = fixedrighttemp 104 | 105 | ! 106 | ! exchange boundary information 107 | ! 108 | sync images(neighbours(1:nneighbours)) 109 | if (this_image() /= 1) then 110 | temperature(1,old) = temperature(locnpoints+1,old)[left] 111 | endif 112 | if (this_image() /= num_images()) then 113 | temperature(locnpoints+2,old) = temperature(2,old)[right] 114 | endif 115 | 116 | ! 117 | ! update solution 118 | ! 119 | forall (i=2:locnpoints+1) 120 | temperature(i,new) = temperature(i,old) + & 121 | dt*kappa/(dx**2) * ( & 122 | temperature(i+1,old) - & 123 | 2*temperature(i, old) + & 124 | temperature(i-1,old) & 125 | ) 126 | end forall 127 | time = time + dt 128 | 129 | ! 130 | ! update correct solution 131 | ! 132 | sigma = sqrt(2.*kappa*time + sigmao**2) 133 | a = ao*sigmao/sigma 134 | theory = a*exp(-(x)**2 / (2.*sigma**2)) 135 | 136 | old = new 137 | new = new + 1 138 | if (new > 2) new = 1 139 | enddo 140 | 141 | open(newunit=unitno,file=trim(adjustl(imgstr))//'-output.txt') 142 | do i=2,locnpoints+1 143 | write(unitno,'(3(F8.3,3X))'),x(i),temperature(i,new), theory(i) 144 | enddo 145 | close(unitno) 146 | 147 | deallocate(temperature) 148 | deallocate(theory) 149 | deallocate(x) 150 | end program diffuse 151 | -------------------------------------------------------------------------------- /diffusion/diffusion-mpi.f90: -------------------------------------------------------------------------------- 1 | program diffuse 2 | use mpi 3 | implicit none 4 | 5 | ! 6 | ! simulation parameters 7 | ! 8 | integer, parameter :: totpoints=1000 9 | real, parameter :: xleft=-12., xright=+12. 10 | real, parameter :: kappa=1. 11 | integer, parameter :: nsteps=100000 12 | 13 | ! 14 | ! the calculated temperature, and the known correct 15 | ! solution from theory 16 | ! 17 | real, allocatable :: x(:) 18 | real, allocatable :: temperature(:,:) 19 | real, allocatable :: theory(:) 20 | 21 | integer :: old=1, new=2 22 | integer :: step 23 | integer :: i 24 | real :: time 25 | real :: dt, dx 26 | real :: error 27 | 28 | integer :: unitno 29 | character(len=3) :: imgstr 30 | ! 31 | ! parameters of the original temperature distribution 32 | ! 33 | real, parameter :: ao=1., sigmao = 1. 34 | real :: a, sigma 35 | real :: fixedlefttemp, fixedrighttemp 36 | 37 | ! 38 | ! mpi variables 39 | ! 40 | integer :: ierr, rank, comsize 41 | integer :: locnpoints, startn, endn 42 | real :: locxleft 43 | integer :: left, right 44 | integer :: lefttag=1, righttag=2 45 | integer, dimension(MPI_STATUS_SIZE) :: rstatus 46 | 47 | call MPI_Init(ierr) 48 | call MPI_Comm_size(MPI_COMM_WORLD,comsize,ierr) 49 | call MPI_Comm_rank(MPI_COMM_WORLD,rank,ierr) 50 | 51 | locnpoints = totpoints/comsize 52 | startn = rank*locnpoints+1 53 | endn = startn + locnpoints 54 | if (rank == comsize-1) endn=totpoints+1 55 | locnpoints = endn-startn 56 | 57 | left = rank-1 58 | if (left < 0) left = MPI_PROC_NULL 59 | right = rank+1 60 | if (right >= comsize) right = MPI_PROC_NULL 61 | ! 62 | ! set parameters 63 | ! 64 | dx = (xright-xleft)/(totpoints-1) 65 | dt = dx**2 * kappa/10. 66 | 67 | locxleft = xleft + dx*(startn-1) 68 | 69 | write(imgstr,'(I03)') rank+1 70 | ! 71 | ! allocate data, including ghost cells: old and new timestep 72 | ! theory doesn't need ghost cells, but we include it for simplicity 73 | ! 74 | allocate(temperature(locnpoints+2,2)) 75 | allocate(theory(locnpoints+2)) 76 | allocate(x(locnpoints+2)) 77 | ! 78 | ! setup initial conditions 79 | ! 80 | time = 0. 81 | x = locxleft + [((i-1)*dx,i=1,locnpoints+2)] 82 | temperature(:,old) = ao*exp(-(x)**2 / (2.*sigmao**2)) 83 | theory= ao*exp(-(x)**2 / (2.*sigmao**2)) 84 | 85 | fixedlefttemp = ao*exp(-(xleft-dx)**2 / (2.*sigmao**2)) 86 | fixedrighttemp= ao*exp(-(xright+dx)**2 / (2.*sigmao**2)) 87 | 88 | open(newunit=unitno,file=trim(adjustl(imgstr))//'-ics.txt') 89 | do i=2,locnpoints+1 90 | write(unitno,'(3(F8.3,3X))'),x(i),temperature(i,old), theory(i) 91 | enddo 92 | close(unitno) 93 | 94 | ! 95 | ! evolve 96 | ! 97 | do step=1, nsteps 98 | ! 99 | ! boundary conditions: keep endpoint temperatures fixed. 100 | ! 101 | temperature(1,old) = fixedlefttemp 102 | temperature(locnpoints+2,old) = fixedrighttemp 103 | 104 | ! 105 | ! exchange boundary information 106 | ! 107 | 108 | call MPI_Sendrecv(temperature(locnpoints+1,old), 1, MPI_REAL, right, righttag, & 109 | temperature(1,old), 1, MPI_REAL, left, righttag, MPI_COMM_WORLD, rstatus, ierr) 110 | 111 | call MPI_Sendrecv(temperature(2,old), 1, MPI_REAL, left, lefttag, & 112 | temperature(locnpoints+2,old), 1, MPI_REAL, right, lefttag, MPI_COMM_WORLD, rstatus, ierr) 113 | ! 114 | ! update solution 115 | ! 116 | forall (i=2:locnpoints+1) 117 | temperature(i,new) = temperature(i,old) + & 118 | dt*kappa/(dx**2) * ( & 119 | temperature(i+1,old) - & 120 | 2*temperature(i, old) + & 121 | temperature(i-1,old) & 122 | ) 123 | end forall 124 | time = time + dt 125 | 126 | ! 127 | ! update correct solution 128 | ! 129 | sigma = sqrt(2.*kappa*time + sigmao**2) 130 | a = ao*sigmao/sigma 131 | theory = a*exp(-(x)**2 / (2.*sigma**2)) 132 | 133 | old = new 134 | new = new + 1 135 | if (new > 2) new = 1 136 | enddo 137 | 138 | open(newunit=unitno,file=trim(adjustl(imgstr))//'-output.txt') 139 | do i=2,locnpoints+1 140 | write(unitno,'(3(F8.3,3X))'),x(i),temperature(i,new), theory(i) 141 | enddo 142 | close(unitno) 143 | 144 | deallocate(temperature) 145 | deallocate(theory) 146 | deallocate(x) 147 | call MPI_Finalize(ierr) 148 | end program diffuse 149 | -------------------------------------------------------------------------------- /diffusion/diffusion-nonblocking-mpi.f90: -------------------------------------------------------------------------------- 1 | program diffuse 2 | use mpi 3 | implicit none 4 | 5 | ! 6 | ! simulation parameters 7 | ! 8 | integer, parameter :: totpoints=1000 9 | real, parameter :: xleft=-12., xright=+12. 10 | real, parameter :: kappa=1. 11 | integer, parameter :: nsteps=100000 12 | 13 | ! 14 | ! the calculated temperature, and the known correct 15 | ! solution from theory 16 | ! 17 | real, allocatable :: x(:) 18 | real, allocatable :: temperature(:,:) 19 | real, allocatable :: theory(:) 20 | 21 | integer :: old=1, new=2 22 | integer :: step 23 | integer :: i 24 | real :: time 25 | real :: dt, dx 26 | real :: error 27 | 28 | integer :: unitno 29 | character(len=3) :: imgstr 30 | ! 31 | ! parameters of the original temperature distribution 32 | ! 33 | real, parameter :: ao=1., sigmao = 1. 34 | real :: a, sigma 35 | real :: fixedlefttemp, fixedrighttemp 36 | 37 | ! 38 | ! mpi variables 39 | ! 40 | integer :: ierr, rank, comsize 41 | integer :: locnpoints, startn, endn 42 | real :: locxleft 43 | integer :: left, right 44 | integer :: lefttag=1, righttag=2 45 | integer, dimension(MPI_STATUS_SIZE) :: statuses(4) 46 | integer :: requests(4) 47 | 48 | call MPI_Init(ierr) 49 | call MPI_Comm_size(MPI_COMM_WORLD,comsize,ierr) 50 | call MPI_Comm_rank(MPI_COMM_WORLD,rank,ierr) 51 | 52 | locnpoints = totpoints/comsize 53 | startn = rank*locnpoints+1 54 | endn = startn + locnpoints 55 | if (rank == comsize-1) endn=totpoints+1 56 | locnpoints = endn-startn 57 | 58 | left = rank-1 59 | if (left < 0) left = MPI_PROC_NULL 60 | right = rank+1 61 | if (right >= comsize) right = MPI_PROC_NULL 62 | ! 63 | ! set parameters 64 | ! 65 | dx = (xright-xleft)/(totpoints-1) 66 | dt = dx**2 * kappa/10. 67 | 68 | locxleft = xleft + dx*(startn-1) 69 | 70 | write(imgstr,'(I03)') rank+1 71 | ! 72 | ! allocate data, including ghost cells: old and new timestep 73 | ! theory doesn't need ghost cells, but we include it for simplicity 74 | ! 75 | allocate(temperature(locnpoints+2,2)) 76 | allocate(theory(locnpoints+2)) 77 | allocate(x(locnpoints+2)) 78 | ! 79 | ! setup initial conditions 80 | ! 81 | time = 0. 82 | x = locxleft + [((i-1)*dx,i=1,locnpoints+2)] 83 | temperature(:,old) = ao*exp(-(x)**2 / (2.*sigmao**2)) 84 | theory= ao*exp(-(x)**2 / (2.*sigmao**2)) 85 | 86 | fixedlefttemp = ao*exp(-(xleft-dx)**2 / (2.*sigmao**2)) 87 | fixedrighttemp= ao*exp(-(xright+dx)**2 / (2.*sigmao**2)) 88 | 89 | open(newunit=unitno,file=trim(adjustl(imgstr))//'-ics.txt') 90 | do i=2,locnpoints+1 91 | write(unitno,'(3(F8.3,3X))'),x(i),temperature(i,old), theory(i) 92 | enddo 93 | close(unitno) 94 | 95 | ! 96 | ! evolve 97 | ! 98 | do step=1, nsteps 99 | ! 100 | ! boundary conditions: keep endpoint temperatures fixed. 101 | ! 102 | temperature(1,old) = fixedlefttemp 103 | temperature(locnpoints+2,old) = fixedrighttemp 104 | 105 | ! 106 | ! begin exchange of boundary information 107 | ! 108 | 109 | call MPI_Isend(temperature(locnpoints+1,old), 1, MPI_REAL, & 110 | right, righttag, MPI_COMM_WORLD, requests(1), ierr) 111 | call MPI_Isend(temperature(2,old), 1, MPI_REAL, & 112 | left, lefttag, MPI_COMM_WORLD, requests(2), ierr) 113 | call MPI_Irecv(temperature(1,old), 1, MPI_REAL, & 114 | left, righttag, MPI_COMM_WORLD, requests(3), ierr) 115 | call MPI_Irecv(temperature(locnpoints+2,old), 1, MPI_REAL, & 116 | right, lefttag, MPI_COMM_WORLD, requests(4), ierr) 117 | 118 | ! 119 | ! update solution 120 | ! 121 | forall (i=3:locnpoints) 122 | temperature(i,new) = temperature(i,old) + & 123 | dt*kappa/(dx**2) * ( & 124 | temperature(i+1,old) - & 125 | 2*temperature(i, old) + & 126 | temperature(i-1,old) & 127 | ) 128 | end forall 129 | time = time + dt 130 | 131 | ! 132 | ! wait for communications to complete 133 | ! 134 | call MPI_Waitall(4, requests, statuses, ierr) 135 | ! 136 | ! update solution 137 | ! 138 | temperature(2,new) = temperature(2,old) + dt*kappa/(dx**2) * & 139 | ( temperature(1,old) - 2*temperature(2, old) + temperature(3,old) ) 140 | temperature(locnpoints+1,new) = temperature(locnpoints+1,old) + dt*kappa/(dx**2) * & 141 | ( temperature(locnpoints,old) - 2*temperature(locnpoints+1, old) + temperature(locnpoints+2,old) ) 142 | ! 143 | ! update correct solution 144 | ! 145 | sigma = sqrt(2.*kappa*time + sigmao**2) 146 | a = ao*sigmao/sigma 147 | theory = a*exp(-(x)**2 / (2.*sigma**2)) 148 | 149 | old = new 150 | new = new + 1 151 | if (new > 2) new = 1 152 | enddo 153 | 154 | open(newunit=unitno,file=trim(adjustl(imgstr))//'-output.txt') 155 | do i=2,locnpoints+1 156 | write(unitno,'(3(F8.3,3X))'),x(i),temperature(i,new), theory(i) 157 | enddo 158 | close(unitno) 159 | 160 | deallocate(temperature) 161 | deallocate(theory) 162 | deallocate(x) 163 | call MPI_Finalize(ierr) 164 | end program diffuse 165 | --------------------------------------------------------------------------------