minimal_model_comms_v3.f90

Go to the documentation of this file.

!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!    minimal_model_comms just sets up communicators for empire for
!    testing purposes
!
!The MIT License (MIT)
!
!Copyright (c) 2015 Philip A. Browne
!
!Permission is hereby granted, free of charge, to any person obtaining a copy
!of this software and associated documentation files (the "Software"), to deal
!in the Software without restriction, including without limitation the rights
!to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
!copies of the Software, and to permit persons to whom the Software is
!furnished to do so, subject to the following conditions:
!
!The above copyright notice and this permission notice shall be included in all
!copies or substantial portions of the Software.
!
!THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
!IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
!FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
!AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
!LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
!OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
!SOFTWARE.
!
!Email: p.browne@reading.ac.uk
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!

program minimal_model_comms_v3
  implicit none

  include 'mpif.h'
  integer :: mpi_err
  integer :: world_rank
  integer :: world_size
  integer, parameter :: mdl_num_proc=5
  integer :: mdl_mpi_comm
  integer :: temp_mdls_comm
  integer :: temp_mdls_rank
  integer :: mdl_rank
  integer :: da
  integer, parameter :: rk = kind(1.0d0)
  real(kind=rk), allocatable, dimension(:) :: state_vector
  integer :: state_dim
  integer :: i
  integer :: cpl_root
  integer :: particle_rank
  integer :: nda
  integer :: nens
  integer :: temp_mdls_size
  integer :: temp_cpl_comm
  integer :: first_ptcl
  integer :: final_ptcl
  integer :: cpl_mpi_comm
  integer :: null_mpi_comm
  integer :: tmp_colour_2
  integer :: tmp_cpl_comm2
  integer :: tmp_cpl_rank

  print*,'RUNNING MINIMAL_MODEL_COMMS_V3'

  call mpi_init(mpi_err)
  if(mpi_err .eq. 0) then    
     print*,'mpi_init successful'
  else
     print*,'mpi_init unsuccessful'
  end if


  call mpi_comm_rank(mpi_comm_world,world_rank,mpi_err)
  if(mpi_err .eq. 0) then    
     print*,'mpi_comm_rank successful'
     print*,'world_rank = ',world_rank
  else
     print*,'mpi_comm_rank unsuccessful'
  end if


  call mpi_comm_size(mpi_comm_world,world_size,mpi_err)
  if(mpi_err .eq. 0) then    
     print*,'mpi_comm_size successful'
     print*,'world_size = ',world_size
  else
     print*,'mpi_comm_size unsuccessful'
  end if


  cpl_root = world_size-1
  print*,'rank = ',world_rank,' on mpi_comm_world which has size ',world_size
  da = 0


  call mpi_allreduce(mdl_num_proc,i,1,mpi_integer,mpi_max&
       &,mpi_comm_world,mpi_err)
  if(mpi_err .eq. 0) then    
     print*,'mpi_allreduce successful'
     print*,'i = ',i
  else
     print*,'mpi_allreduce unsuccessful'
  end if
!!!==================================================!!!
!!!================ BRUCE LEE =======================!!!
!!!==================================================!!!


  call mpi_comm_split(mpi_comm_world,da,world_rank,temp_mdls_comm&
       &,mpi_err)
  if(mpi_err .eq. 0) then    
     print*,'mpi_comm_split successful: temp_mdls_comm created'
  else
     print*,'mpi_comm_split unsuccessful: temp_mdls_comm not created'
  end if

  call mpi_comm_size(temp_mdls_comm,temp_mdls_size,mpi_err)
  if(mpi_err .eq. 0) then    
     print*,'mpi_comm_size successful'
     print*,'temp_mdls_size = ',temp_mdls_size
  else
     print*,'mpi_comm_size unsuccessful'
  end if


  if(mod(temp_mdls_size,mdl_num_proc) .ne. 0) then
     print*,'MINIMAL MODEL LAUNCH ERROR.'
     print*,'MUST LAUNCH A MULTIPLE OF ',mdl_num_proc,' copies of the &
          &model'
     stop
  end if


  nda = (world_size-temp_mdls_size)/mdl_num_proc
  if(nda .lt. 1) then
     print*,'MINIMAL MODEL COMMS v3 ERROR: nda is less than 1.'
     print*,'Make sure you launch with a DA CODE'
     stop
  end if
  
!!!==================================================!!!
!!!================ JEAN CLAUDE VAN DAMME ===========!!!
!!!==================================================!!!
  

  nens = temp_mdls_size/mdl_num_proc
  call mpi_comm_rank(temp_mdls_comm,temp_mdls_rank,mpi_err)
  if(mpi_err .eq. 0) then    
     print*,'mpi_comm_rank successful'
     print*,'temp_mdls_rank = ',temp_mdls_rank
  else
     print*,'mpi_comm_rank unsuccessful'
  end if


  particle_rank = temp_mdls_rank/mdl_num_proc

  call mpi_comm_split(temp_mdls_comm,particle_rank,temp_mdls_rank&
       &,mdl_mpi_comm,mpi_err)
  if(mpi_err .eq. 0) then    
     print*,'mpi_comm_split successful: mdl_mpi_comm created'
  else
     print*,'mpi_comm_split unsuccessful: mdl_mpi_comm not created'
  end if



  call mpi_comm_rank(mdl_mpi_comm,mdl_rank,mpi_err)
  if(mpi_err .eq. 0) then    
     print*,'mpi_comm_rank successful'
     print*,'mdl_rank = ',mdl_rank
  else
     print*,'mpi_comm_rank unsuccessful'
  end if

!!!==================================================!!!
!!!============== STEVEN SEGAL ======================!!!
!!!==================================================!!!



  cpl_root = nda*particle_rank/nens
  print*,'cpl_root = ',cpl_root

  if(cpl_root .lt. 0) then
     print*,'MINIMAL MODEL COMMS v3 ERROR: cpl_root is less than 0.'
     print*,'Make sure you launch with a DA CODE'
     stop
  end if

  call mpi_comm_split(mpi_comm_world,cpl_root,temp_mdls_rank,temp_cpl_comm,mpi_err)
  if(mpi_err .eq. 0) then    
     print*,'mpi_comm_split successful: temp_cpl_comm created'
  else
     print*,'mpi_comm_split unsuccessful: temp_cpl_comm not created'
  end if

!!!==================================================!!!   
!!!============== CHUCK NORRIS ======================!!!   
!!!==================================================!!!

  call mpi_comm_rank(temp_cpl_comm,tmp_cpl_rank,mpi_err)
  if(mpi_err .eq. 0) then
     print*,'mpi_comm_rank successful: tmp_cpl_rank = ',tmp_cpl_rank
  else
     print*,'mpl_comm_rank unsuccessful: tmp_cpl_rank not detected'
  end if

  tmp_colour_2 = mod(tmp_cpl_rank,mdl_num_proc)
  print*,'tmp_colour_2 = ',tmp_colour_2
  call mpi_comm_split(temp_cpl_comm,tmp_colour_2,tmp_cpl_rank&
       &,tmp_cpl_comm2,mpi_err)
  if(mpi_err .eq. 0) then
     print*,'mpi_comm_split successful: tmp_cpl_comm2 created'
  else
     print*,'mpi_comm_split unsuccessful: tmp_cpl_comm2 not created'
  end if

!!!==================================================!!!       
!!!=============== JACKIE CHAN ======================!!!   
!!!==================================================!!!


  first_ptcl = -((-cpl_root)*nens/nda)
  final_ptcl = -((-cpl_root-1)*nens/nda)-1

  first_ptcl = ceiling(real(cpl_root)*real(nens)/real(nda))
  final_ptcl = ceiling(real(cpl_root+1)*real(nens)/real(nda))-1


  print*,'range of particles = ',first_ptcl,final_ptcl



  do i = first_ptcl,final_ptcl
     print*,'i = ',i,' particle_rank = ',particle_rank
     if(i .eq. particle_rank) then
        call mpi_comm_split(tmp_cpl_comm2,1,temp_mdls_rank&
             &,cpl_mpi_comm,mpi_err)
        print*,'created cpl_mpi_comm',cpl_mpi_comm
     else
        print*,'doing null splitting'
        call mpi_comm_split(tmp_cpl_comm2,0,temp_mdls_rank&
             &,null_mpi_comm,mpi_err)
        print*,'created mpi_comm_null'
        call mpi_comm_free(null_mpi_comm,mpi_err)
        print*,'freed up null_mpi_comm'
     end if


  end do

  cpl_root = 1


!!!==================================================!!!
!!!=============== MICHELLE YEOH ====================!!!
!!!==================================================!!!
  
  !free up the temporary communicators
  call mpi_comm_free(temp_cpl_comm ,mpi_err)
  call mpi_comm_free(tmp_cpl_comm2,mpi_err)
    


  select case(mdl_rank)
  case(0)
     state_dim = 1
  case(1)
     state_dim = 3
  case(2)
     state_dim = 2
  case(3)
     state_dim = 5
  case(4)
     state_dim = 1
  case default
     print*,'it was at this point, model realised, he fucked up'
     stop
  end select
  allocate(state_vector(state_dim))




  state_vector = 10*mdl_rank + (/ (real(i,rk), i = 1,state_dim) /)

  print*,'state_vector = '
  print*,state_vector

  print*,'doing a send on cpl_mpi_comm'
  
  call mpi_send(state_dim,1,mpi_integer,cpl_root,1,cpl_mpi_comm,mpi_err)
  print*,'finished the send on cpl_mpi_comm'
!!!==================================================!!!
!!!=============== SCARLETT JOHANSSON ===============!!!
!!!==================================================!!!



  call mpi_finalize(mpi_err)
  print*,'MINIMAL_MODEL_COMMS_v3 finished nicely'
end program minimal_model_comms_v3