yowrankModule.F90

Go to the documentation of this file.

!PDLIB Software License
!
!Software, as understood herein, shall be broadly interpreted as being inclusive of algorithms,
!source code, object code, data bases and related documentation, all of which shall be furnished
!free of charge to the Licensee. Corrections, upgrades or enhancements may be furnished and, if
!furnished, shall also be furnished to the Licensee without charge. NOAA, however, is not
!required to develop or furnish such corrections, upgrades or enhancements.
!Roland & Partner software, whether that initially furnished or corrections or upgrades,
!are furnished "as is". Roland & Partner furnishes its software without any warranty
!whatsoever and is not responsible for any direct, indirect or consequential damages
!that may be incurred by the Licensee. Warranties of merchantability, fitness for any
!particular purpose, title, and non-infringement, are specifically negated.
!The Licensee is not required to develop any software related to the licensed software.
!However, in the event that the Licensee does so, the Licensee is required to offer same
!to Roland & Partner for inclusion under the instant licensing terms with Roland & Partner
!licensed software along with documentation regarding its principles, use and its advantages.
!This includes changes to the wave model proper including numerical and physical approaches
!to wave modeling, and boundary layer parameterizations embedded in the wave model
!A Licensee may reproduce sufficient software to satisfy its needs.
!All copies shall bear the name of the software with any version number
!as well as replicas of any applied copyright notice, trademark notice,
!other notices and credit lines. Additionally, if the copies have been modified,
!e.g. with deletions or additions, this shall be so stated and identified.
!All of Licensee's employees who have a need to use the software may have access
!to the software but only after reading the instant license and stating, in writing,
!that they have read and understood the license and have agreed to its terms.
!Licensee is responsible for employing reasonable efforts to assure
!that only those of its employees that should have access to the software, in fact, have access.
!The Licensee may use the software for any purpose relating to sea state prediction.
!No disclosure of any portion of the software, whether by means of a media or verbally,
!may be made to any third party by the Licensee or the Licensee's employees
!The Licensee is responsible for compliance with any applicable export or
!import control laws of the United States, the European Union and Germany.
!
!© 2009 Roland&Partner, Georgenstr.32, 64297 Germany. All rights reserved.
!PDLIB is a trademark of Roland & Partner. No unauthorized use without permission.
!
 
module yowrankmodule
  use yowerr
  implicit none
  private
  public :: initrankmodule, finalizerankmodule
 
  type, public :: t_rank
    integer :: np = 0
 
    integer :: npa = 0
 
    integer, allocatable :: iplg(:)
 
    integer:: istart = 0
  end type t_rank
 
  type(t_rank),public, allocatable :: rank(:)
  integer, public, allocatable :: ipgl_to_proc(:), ipgl_tot(:)
  integer, public, allocatable :: ipgl_npa(:)
 
contains
 
  subroutine initrankmodule()
    use yowdatapool, only: ntasks, myrank
    implicit none
    integer :: stat
 
    if(allocated(rank)) deallocate(rank)
    allocate(rank(ntasks), stat=stat)
    if(stat/=0) CALL abort('rank allocation failure')
 
    call exchangeiplg()
    call calcistart()
  end subroutine initrankmodule
 
  subroutine exchangeiplg()
    use yownodepool, only: np, npa, iplg, np_global
    use yowdatapool, only: ntasks, myrank, comm, itype
    use mpi
    implicit none
    integer :: i, ierr, stat
    integer :: sendRqst(nTasks), recvRqst(nTasks)
    integer :: recvStat(MPI_STATUS_SIZE, nTasks), sendStat(MPI_STATUS_SIZE, nTasks)
    integer IPglob, J, istat
 
    ! step1 exchange np
    ! step2 exchange npa
    ! step3 allocate rank%iplg
    ! step4 exchange iplg
 
    ! step1 exchange np
    ! post receives
    do i=1, ntasks
      if(i /= myrank+1) then
        call mpi_irecv(rank(i)%np, 1, itype, i-1, &
             42, comm, recvrqst(i), ierr)
        if(ierr/=mpi_success) then
          CALL parallel_abort("MPI_IRecv", ierr)
        endif
      else
        recvrqst(i) = mpi_request_null
      endif
    end do
 
    ! post sends
    do i=1, ntasks
      if(i /= myrank+1) then
        call mpi_isend(np, 1, itype, i-1, &
             42, comm, sendrqst(i), ierr)
        if(ierr/=mpi_success) then
          CALL parallel_abort("MPI_ISend", ierr)
        endif
      else
        sendrqst(i) = mpi_request_null
      endif
    end do
 
    rank(myrank+1)%np = np
 
    ! Wait for completion
    call mpi_waitall(ntasks, recvrqst, recvstat,ierr)
    if(ierr/=mpi_success) CALL parallel_abort("waitall", ierr)
    call mpi_waitall(ntasks, sendrqst, sendstat,ierr)
    if(ierr/=mpi_success) CALL parallel_abort("waitall", ierr)
 
    ! step2 exchange npa
    ! post receives
    do i=1, ntasks
      if(i /= myrank+1) then
        call mpi_irecv(rank(i)%npa, 1, itype, i-1, &
             42, comm, recvrqst(i), ierr)
        if(ierr/=mpi_success) then
          CALL parallel_abort("MPI_IRecv", ierr)
        endif
      else
        recvrqst(i) = mpi_request_null
      endif
    end do
 
    ! post sends
    do i=1, ntasks
      if(i /= myrank+1) then
        call mpi_isend(npa, 1, itype, i-1, &
             42, comm, sendrqst(i), ierr)
        if(ierr/=mpi_success) then
          CALL parallel_abort("MPI_ISend", ierr)
        endif
      else
        sendrqst(i) = mpi_request_null
      endif
    end do
 
    rank(myrank+1)%npa = npa
 
    ! Wait for completion
    call mpi_waitall(ntasks, recvrqst, recvstat,ierr)
    if(ierr/=mpi_success) CALL parallel_abort("waitall", ierr)
    call mpi_waitall(ntasks, sendrqst, sendstat,ierr)
    if(ierr/=mpi_success) CALL parallel_abort("waitall", ierr)
 
    ! step3 allocal rank%iplg
    do i=1, ntasks
      if(allocated(rank(i)%iplg)) deallocate(rank(i)%iplg)
      allocate(rank(i)%iplg(rank(i)%npa), stat=stat)
      if(stat/=0) CALL abort('rank%iplg allocation failure')
      rank(i)%iplg = 0
    end do
 
    ! step4 exchange iplg
    ! post receives
    do i=1, ntasks
      if(i /= myrank+1) then
        call mpi_irecv(rank(i)%iplg, rank(i)%npa, itype, i-1, &
             42, comm, recvrqst(i), ierr)
        if(ierr/=mpi_success) then
          CALL parallel_abort("MPI_IRecv", ierr)
        endif
      else
        recvrqst(i) = mpi_request_null
      endif
    end do
 
    ! post sends
    do i=1, ntasks
      if(i /= myrank+1) then
        call mpi_isend(iplg, npa, itype, i-1, &
             42, comm, sendrqst(i), ierr)
        if(ierr/=mpi_success) then
          CALL parallel_abort("MPI_ISend", ierr)
        endif
      else
        sendrqst(i) = mpi_request_null
      endif
    end do
 
    rank(myrank+1)%iplg = iplg
 
    ! Wait for completion
    call mpi_waitall(ntasks, recvrqst, recvstat,ierr)
    if(ierr/=mpi_success) CALL parallel_abort("waitall", ierr)
    call mpi_waitall(ntasks, sendrqst, sendstat,ierr)
    if(ierr/=mpi_success) CALL parallel_abort("waitall", ierr)
 
    allocate(ipgl_to_proc(np_global), ipgl_tot(np_global), stat=istat)
    if(istat /= 0) CALL parallel_abort("allocatation error", 1)
    do i=1,ntasks
      DO j=1,rank(i)%np
        ipglob=rank(i)%iplg(j)
        ipgl_to_proc(ipglob)=i
        ipgl_tot(ipglob)=j
      END DO
    END DO
    allocate(ipgl_npa(np_global), stat=istat)
    if(istat /= 0) CALL parallel_abort("allocatation error b", 1)
    ipgl_npa=0
    DO j=1,rank(myrank+1)%npa
      ipglob=rank(myrank+1)%iplg(j)
      ipgl_npa(ipglob)=j
    END DO
  end subroutine exchangeiplg
 
  subroutine calcistart()
    use yowdatapool, only: ntasks, myrank
    implicit none
    integer :: ir
 
    rank(1)%IStart = 1
    do ir=2, ntasks
      rank(ir)%IStart = rank(ir-1)%IStart + rank(ir-1)%np
    end do
  end subroutine calcistart
 
  subroutine finalizerankmodule()
    implicit none
    integer :: i
 
    if(allocated(rank)) then
      do i=1, size(rank)
        if(allocated(rank(i)%iplg)) deallocate(rank(i)%iplg)
      end do
      deallocate(rank)
    endif
  end subroutine finalizerankmodule
end module yowrankmodule