| Class | sltt_extarr |
| In: |
sltt/sltt_extarr.F90
|
| Subroutine : | |
| y_ExtLatS(jexmin:jexmax) : | real(DP), intent(in ) |
| y_ExtLatN(jexmin:jexmax) : | real(DP), intent(in ) |
| x_SinLonS(0:imax-1) : | real(DP), intent(in ) |
| x_CosLonS(0:imax-1) : | real(DP), intent(in ) |
| x_SinLonN(0:imax-1) : | real(DP), intent(in ) |
| x_CosLonN(0:imax-1) : | real(DP), intent(in ) |
| xyzf_QMix(0:imax-1, 1:jmax, 1:kmax, 1:ncmax) : | real(DP), intent(in ) |
| xyz_U(0:imax-1, 1:jmax, 1:kmax) : | real(DP), intent(in ) |
| xyz_V(0:imax-1, 1:jmax, 1:kmax) : | real(DP), intent(in ) |
| xyzf_ExtDQMixDLatS(iexmin:iexmax, jexmin:jexmax, 1:kmax, 1:ncmax) : | real(DP), intent(in ) |
| xyzf_ExtDQMixDLatN(iexmin:iexmax, jexmin:jexmax, 1:kmax, 1:ncmax) : | real(DP), intent(in ) |
| xyzf_ExtQMixS(iexmin:iexmax, jexmin:jexmax, 1:kmax, 1:ncmax) : | real(DP), intent(out) |
| xyzf_ExtQMixN(iexmin:iexmax, jexmin:jexmax, 1:kmax, 1:ncmax) : | real(DP), intent(out) |
| xyz_ExtUS(iexmin:iexmax, jexmin:jexmax, 1:kmax) : | real(DP), intent(out) |
| xyz_ExtUN(iexmin:iexmax, jexmin:jexmax, 1:kmax) : | real(DP), intent(out) |
| xyz_ExtVS(iexmin:iexmax, jexmin:jexmax, 1:kmax) : | real(DP), intent(out) |
| xyz_ExtVN(iexmin:iexmax, jexmin:jexmax, 1:kmax) : | real(DP), intent(out) |
subroutine SLTTExtArrExt( y_ExtLatS, y_ExtLatN, x_SinLonS, x_CosLonS, x_SinLonN, x_CosLonN, xyzf_QMix, xyz_U, xyz_V, xyzf_ExtDQMixDLatS, xyzf_ExtDQMixDLatN, xyzf_ExtQMixS, xyzf_ExtQMixN, xyz_ExtUS, xyz_ExtUN, xyz_ExtVS, xyz_ExtVN )
! メッセージ出力
! Message output
!
use dc_message, only: MessageNotify
use mpi_wrapper, only : nprocs, myrank, MPIWrapperISend, MPIWrapperIRecv, MPIWrapperWait
use sltt_const , only : iexmin, iexmax, jexmin, jexmax, jmaxh
!!$ use sltt_lagint, only : SLTTIrrHerIntQui1DNonUni
real(DP), intent(in ) :: y_ExtLatS(jexmin:jexmax)
real(DP), intent(in ) :: y_ExtLatN(jexmin:jexmax)
real(DP), intent(in ) :: x_SinLonS(0:imax-1)
real(DP), intent(in ) :: x_CosLonS(0:imax-1)
real(DP), intent(in ) :: x_SinLonN(0:imax-1)
real(DP), intent(in ) :: x_CosLonN(0:imax-1)
real(DP), intent(in ) :: xyzf_QMix(0:imax-1, 1:jmax, 1:kmax, 1:ncmax)
real(DP), intent(in ) :: xyz_U (0:imax-1, 1:jmax, 1:kmax)
real(DP), intent(in ) :: xyz_V (0:imax-1, 1:jmax, 1:kmax)
real(DP), intent(in ) :: xyzf_ExtDQMixDLatS(iexmin:iexmax, jexmin:jexmax, 1:kmax, 1:ncmax)
real(DP), intent(in ) :: xyzf_ExtDQMixDLatN(iexmin:iexmax, jexmin:jexmax, 1:kmax, 1:ncmax)
real(DP), intent(out) :: xyzf_ExtQMixS(iexmin:iexmax, jexmin:jexmax, 1:kmax, 1:ncmax)
real(DP), intent(out) :: xyzf_ExtQMixN(iexmin:iexmax, jexmin:jexmax, 1:kmax, 1:ncmax)
real(DP), intent(out) :: xyz_ExtUS (iexmin:iexmax, jexmin:jexmax, 1:kmax)
real(DP), intent(out) :: xyz_ExtUN (iexmin:iexmax, jexmin:jexmax, 1:kmax)
real(DP), intent(out) :: xyz_ExtVS (iexmin:iexmax, jexmin:jexmax, 1:kmax)
real(DP), intent(out) :: xyz_ExtVN (iexmin:iexmax, jexmin:jexmax, 1:kmax)
!
! local variables
!
real(DP) :: xzfy_SdRecvBuf(0:imax-1,1:kmax,1:ncmax+2,jexmin_min:jexmax_max)
real(DP) :: xzfy_NdRecvBuf(0:imax-1,1:kmax,1:ncmax+2,jexmin_min:jexmax_max)
real(DP) :: xzfy_dSendBuf (0:imax-1,1:kmax,1:ncmax+2,1 :jmax )
integer :: ya_ExtSiReq (jexmin_min:jexmax_max, 0:nprocs-1)
integer :: ya_ExtNiReq (jexmin_min:jexmax_max, 0:nprocs-1)
logical :: ya_ExtSMPIFlag(jexmin_min:jexmax_max, 0:nprocs-1)
logical :: ya_ExtNMPiFlag(jexmin_min:jexmax_max, 0:nprocs-1)
integer :: idep
integer :: idest
integer :: irank
integer :: jlocal
integer :: itag
integer :: i
integer :: j
integer :: k
integer :: n
integer :: ii
! 初期化確認
! Initialization check
!
if ( .not. sltt_extarr_inited ) then
call MessageNotify( 'E', module_name, 'This module has not been initialized.' )
end if
do j = 1, jmax
xzfy_dSendBuf(:,:,1:ncmax ,j) = xyzf_QMix(:,j,:,:)
xzfy_dSendBuf(:,:, ncmax+1,j) = xyz_U(:,j,:)
xzfy_dSendBuf(:,:, ncmax+2,j) = xyz_V(:,j,:)
end do
do n = 0, nprocs-1
if ( n == myrank ) then
!
! Receive
!
do j = a_jexmin(n), a_jexmax(n)
! South array, mpi receive request
irank = ya_ExtRankOrgDataS (j,n)
jlocal = ya_ExtJLocalIndexOrgDataS(j,n)
if ( irank == n ) then
xzfy_SdRecvBuf(:,:,1:ncmax ,j) = xyzf_QMix(:,jlocal,:,:)
xzfy_SdRecvBuf(:,:, ncmax+1,j) = xyz_U(:,jlocal,:)
xzfy_SdRecvBuf(:,:, ncmax+2,j) = xyz_V(:,jlocal,:)
ya_ExtSMPIFlag(j,n) = .false.
else
itag = MkSendRecvDestTag( n, j, 'S' )
idep = irank
call MPIWrapperIRecv( idep, imax, kmax, ncmax+2, xzfy_SdRecvBuf(:,:,:,j), ya_ExtSiReq(j,n), itag )
ya_ExtSMPIFlag(j,n) = .true.
end if
! North array, mpi receive request
irank = ya_ExtRankOrgDataN (j,n)
jlocal = ya_ExtJLocalIndexOrgDataN(j,n)
if ( irank == n ) then
xzfy_NdRecvBuf(:,:,1:ncmax ,j) = xyzf_QMix(:,jlocal,:,:)
xzfy_NdRecvBuf(:,:, ncmax+1,j) = xyz_U(:,jlocal,:)
xzfy_NdRecvBuf(:,:, ncmax+2,j) = xyz_V(:,jlocal,:)
ya_ExtNMPIFlag(j,n) = .false.
else
itag = MkSendRecvDestTag( n, j, 'N' )
idep = irank
call MPIWrapperIRecv( idep, imax, kmax, ncmax+2, xzfy_NdRecvBuf(:,:,:,j), ya_ExtNiReq(j,n), itag )
ya_ExtNMPIFlag(j,n) = .true.
end if
end do
else
!
! Send
!
do j = a_jexmin(n), a_jexmax(n)
! South array, mpi send request
irank = ya_ExtRankOrgDataS (j,n)
jlocal = ya_ExtJLocalIndexOrgDataS(j,n)
if ( irank == myrank ) then
itag = MkSendRecvDestTag( n, j, 'S' )
idest = n
call MPIWrapperISend( idest, imax, kmax, ncmax+2, xzfy_dSendBuf(:,:,:,jlocal), ya_ExtSiReq(j,n), itag )
ya_ExtSMPIFlag(j,n) = .true.
else
ya_ExtSMPIFlag(j,n) = .false.
end if
! North array, mpi send request
irank = ya_ExtRankOrgDataN (j,n)
jlocal = ya_ExtJLocalIndexOrgDataN(j,n)
if ( irank == myrank ) then
itag = MkSendRecvDestTag( n, j, 'N' )
idest = n
call MPIWrapperISend( idest, imax, kmax, ncmax+2, xzfy_dSendBuf(:,:,:,jlocal), ya_ExtNiReq(j,n), itag )
ya_ExtNMPIFlag(j,n) = .true.
else
ya_ExtNMPIFlag(j,n) = .false.
end if
end do
end if
end do
do n = 0, nprocs-1
do j = a_jexmin(n), a_jexmax(n)
! South array
if ( ya_ExtSMPIFlag(j,n) ) call MPIWrapperWait( ya_ExtSiReq(j,n) )
! North array
if ( ya_ExtNMPIFlag(j,n) ) call MPIWrapperWait( ya_ExtNiReq(j,n) )
end do
end do
do j = jexmin, jexmax
if ( ya_ExtFlagCrossPoleOrgDataS(j,myrank) ) then
do i = 0, imax/2-1
ii = i + imax/2
xyzf_ExtQMixS(ii,j,:,:) = xzfy_SdRecvBuf(i,:,1:ncmax ,j)
xyz_ExtUS (ii,j,:) = - xzfy_SdRecvBuf(i,:, ncmax+1,j)
xyz_ExtVS (ii,j,:) = - xzfy_SdRecvBuf(i,:, ncmax+2,j)
end do
do i = imax/2, imax-1
ii = i - imax/2
xyzf_ExtQMixS(ii,j,:,:) = xzfy_SdRecvBuf(i,:,1:ncmax ,j)
xyz_ExtUS (ii,j,:) = - xzfy_SdRecvBuf(i,:, ncmax+1,j)
xyz_ExtVS (ii,j,:) = - xzfy_SdRecvBuf(i,:, ncmax+2,j)
end do
else
xyzf_ExtQMixS(0:imax-1,j,:,:) = xzfy_SdRecvBuf(:,:,1:ncmax ,j)
xyz_ExtUS (0:imax-1,j,:) = xzfy_SdRecvBuf(:,:, ncmax+1,j)
xyz_ExtVS (0:imax-1,j,:) = xzfy_SdRecvBuf(:,:, ncmax+2,j)
end if
if ( ya_ExtFlagCrossPoleOrgDataN(j,myrank) ) then
do i = 0, imax/2-1
ii = i + imax/2
xyzf_ExtQMixN(ii,j,:,:) = xzfy_NdRecvBuf(i,:,1:ncmax ,j)
xyz_ExtUN (ii,j,:) = - xzfy_NdRecvBuf(i,:, ncmax+1,j)
xyz_ExtVN (ii,j,:) = - xzfy_NdRecvBuf(i,:, ncmax+2,j)
end do
do i = imax/2, imax-1
ii = i - imax/2
xyzf_ExtQMixN(ii,j,:,:) = xzfy_NdRecvBuf(i,:,1:ncmax ,j)
xyz_ExtUN (ii,j,:) = - xzfy_NdRecvBuf(i,:, ncmax+1,j)
xyz_ExtVN (ii,j,:) = - xzfy_NdRecvBuf(i,:, ncmax+2,j)
end do
else
xyzf_ExtQMixN(0:imax-1,j,:,:) = xzfy_NdRecvBuf(:,:,1:ncmax ,j)
xyz_ExtUN (0:imax-1,j,:) = xzfy_NdRecvBuf(:,:, ncmax+1,j)
xyz_ExtVN (0:imax-1,j,:) = xzfy_NdRecvBuf(:,:, ncmax+2,j)
end if
end do
!===========================================
! set values at longitudinal edge
!-------------------------------------------
#if defined(AXISYMMETRY) || defined(AXISYMMETRY_SJPACK)
do n = 1, ncmax
do k = 1, kmax
do j = jexmin, jexmax
do i = iexmin, 0-1
xyzf_ExtQMixS(i,j,k,n) = xyzf_ExtQMixS(0,j,k,n)
xyzf_ExtQMixN(i,j,k,n) = xyzf_ExtQMixN(0,j,k,n)
end do
do i = imax-1+1, iexmax
xyzf_ExtQMixS(i,j,k,n) = xyzf_ExtQMixS(0,j,k,n)
xyzf_ExtQMixN(i,j,k,n) = xyzf_ExtQMixN(0,j,k,n)
end do
end do
end do
end do
do k = 1, kmax
do j = jexmin, jexmax
do i = iexmin, 0-1
xyz_ExtUS(i,j,k) = xyz_ExtUS(0,j,k)
xyz_ExtUN(i,j,k) = xyz_ExtUN(0,j,k)
xyz_ExtVS(i,j,k) = xyz_ExtVS(0,j,k)
xyz_ExtVN(i,j,k) = xyz_ExtVN(0,j,k)
end do
do i = imax-1+1, iexmax
xyz_ExtUS(i,j,k) = xyz_ExtUS(0,j,k)
xyz_ExtUN(i,j,k) = xyz_ExtUN(0,j,k)
xyz_ExtVS(i,j,k) = xyz_ExtVS(0,j,k)
xyz_ExtVN(i,j,k) = xyz_ExtVN(0,j,k)
end do
end do
end do
#else
do n = 1, ncmax
do k = 1, kmax
do j = jexmin, jexmax
do i = iexmin, 0-1
xyzf_ExtQMixS(i,j,k,n) = xyzf_ExtQMixS(imax+i,j,k,n)
xyzf_ExtQMixN(i,j,k,n) = xyzf_ExtQMixN(imax+i,j,k,n)
end do
do i = imax-1+1, iexmax
xyzf_ExtQMixS(i,j,k,n) = xyzf_ExtQMixS(i-imax,j,k,n)
xyzf_ExtQMixN(i,j,k,n) = xyzf_ExtQMixN(i-imax,j,k,n)
end do
end do
end do
end do
do k = 1, kmax
do j = jexmin, jexmax
do i = iexmin, 0-1
xyz_ExtUS(i,j,k) = xyz_ExtUS(imax+i,j,k)
xyz_ExtUN(i,j,k) = xyz_ExtUN(imax+i,j,k)
xyz_ExtVS(i,j,k) = xyz_ExtVS(imax+i,j,k)
xyz_ExtVN(i,j,k) = xyz_ExtVN(imax+i,j,k)
end do
do i = imax-1+1, iexmax
xyz_ExtUS(i,j,k) = xyz_ExtUS(i-imax,j,k)
xyz_ExtUN(i,j,k) = xyz_ExtUN(i-imax,j,k)
xyz_ExtVS(i,j,k) = xyz_ExtVS(i-imax,j,k)
xyz_ExtVN(i,j,k) = xyz_ExtVN(i-imax,j,k)
end do
end do
end do
#endif
end subroutine SLTTExtArrExt
| Subroutine : | |||
| x_SinLonS(0:imax-1) : | real(DP), intent(in ) | ||
| x_CosLonS(0:imax-1) : | real(DP), intent(in ) | ||
| x_SinLonN(0:imax-1) : | real(DP), intent(in ) | ||
| x_CosLonN(0:imax-1) : | real(DP), intent(in ) | ||
| xyzf_QMix(0:imax-1, 1:jmax, 1:kmax, 1:ncmax) : | real(DP), intent(in ) | ||
| PM : | real(DP), intent(in )
| ||
| xyzf_ExtQMixS(iexmin:iexmax, jexmin:jexmax, 1:kmax, 1:ncmax) : | real(DP), intent(out) | ||
| xyzf_ExtQMixN(iexmin:iexmax, jexmin:jexmax, 1:kmax, 1:ncmax) : | real(DP), intent(out) |
subroutine SLTTExtArrExt2( x_SinLonS, x_CosLonS, x_SinLonN, x_CosLonN, xyzf_QMix, PM, xyzf_ExtQMixS, xyzf_ExtQMixN )
! メッセージ出力
! Message output
!
use dc_message, only: MessageNotify
use mpi_wrapper, only : nprocs, myrank, MPIWrapperISend, MPIWrapperIRecv, MPIWrapperWait
use sltt_const , only : iexmin, iexmax, jexmin, jexmax
real(DP), intent(in ) :: x_SinLonS(0:imax-1)
real(DP), intent(in ) :: x_CosLonS(0:imax-1)
real(DP), intent(in ) :: x_SinLonN(0:imax-1)
real(DP), intent(in ) :: x_CosLonN(0:imax-1)
real(DP), intent(in ) :: xyzf_QMix(0:imax-1, 1:jmax, 1:kmax, 1:ncmax)
real(DP), intent(in ) :: PM ! 配列拡張する際、極ごえ後に符号が変わる場合は -1.0を与える。そうでない場合は1.0を与える。
real(DP), intent(out) :: xyzf_ExtQMixS(iexmin:iexmax, jexmin:jexmax, 1:kmax, 1:ncmax)
real(DP), intent(out) :: xyzf_ExtQMixN(iexmin:iexmax, jexmin:jexmax, 1:kmax, 1:ncmax)
!
! local variables
!
real(DP) :: xzfy_SdRecvBuf(0:imax-1,1:kmax,1:ncmax,jexmin_min:jexmax_max)
real(DP) :: xzfy_NdRecvBuf(0:imax-1,1:kmax,1:ncmax,jexmin_min:jexmax_max)
real(DP) :: xzfy_dSendBuf (0:imax-1,1:kmax,1:ncmax,1 :jmax )
integer :: ya_ExtSiReq (jexmin_min:jexmax_max, 0:nprocs-1)
integer :: ya_ExtNiReq (jexmin_min:jexmax_max, 0:nprocs-1)
logical :: ya_ExtSMPIFlag(jexmin_min:jexmax_max, 0:nprocs-1)
logical :: ya_ExtNMPiFlag(jexmin_min:jexmax_max, 0:nprocs-1)
integer :: idep
integer :: idest
integer :: irank
integer :: jlocal
integer :: itag
integer :: i
integer :: j
integer :: k
integer :: n
integer :: ii
! 初期化確認
! Initialization check
!
if ( .not. sltt_extarr_inited ) then
call MessageNotify( 'E', module_name, 'This module has not been initialized.' )
end if
do j = 1, jmax
xzfy_dSendBuf(:,:,:,j) = xyzf_QMix(:,j,:,:)
end do
do n = 0, nprocs-1
if ( n == myrank ) then
!
! Receive
!
do j = a_jexmin(n), a_jexmax(n)
! South array, mpi receive request
irank = ya_ExtRankOrgDataS (j,n)
jlocal = ya_ExtJLocalIndexOrgDataS(j,n)
if ( irank == n ) then
xzfy_SdRecvBuf(:,:,:,j) = xyzf_QMix(:,jlocal,:,:)
ya_ExtSMPIFlag(j,n) = .false.
else
itag = MkSendRecvDestTag( n, j, 'S' )
idep = irank
call MPIWrapperIRecv( idep, imax, kmax, ncmax, xzfy_SdRecvBuf(:,:,:,j), ya_ExtSiReq(j,n), itag )
ya_ExtSMPIFlag(j,n) = .true.
end if
! North array, mpi receive request
irank = ya_ExtRankOrgDataN (j,n)
jlocal = ya_ExtJLocalIndexOrgDataN(j,n)
if ( irank == n ) then
xzfy_NdRecvBuf(:,:,:,j) = xyzf_QMix(:,jlocal,:,:)
ya_ExtNMPIFlag(j,n) = .false.
else
itag = MkSendRecvDestTag( n, j, 'N' )
idep = irank
call MPIWrapperIRecv( idep, imax, kmax, ncmax, xzfy_NdRecvBuf(:,:,:,j), ya_ExtNiReq(j,n), itag )
ya_ExtNMPIFlag(j,n) = .true.
end if
end do
else
!
! Send
!
do j = a_jexmin(n), a_jexmax(n)
! South array, mpi send request
irank = ya_ExtRankOrgDataS (j,n)
jlocal = ya_ExtJLocalIndexOrgDataS(j,n)
if ( irank == myrank ) then
itag = MkSendRecvDestTag( n, j, 'S' )
idest = n
call MPIWrapperISend( idest, imax, kmax, ncmax, xzfy_dSendBuf(:,:,:,jlocal), ya_ExtSiReq(j,n), itag )
ya_ExtSMPIFlag(j,n) = .true.
else
ya_ExtSMPIFlag(j,n) = .false.
end if
! North array, mpi send request
irank = ya_ExtRankOrgDataN (j,n)
jlocal = ya_ExtJLocalIndexOrgDataN(j,n)
if ( irank == myrank ) then
itag = MkSendRecvDestTag( n, j, 'N' )
idest = n
call MPIWrapperISend( idest, imax, kmax, ncmax, xzfy_dSendBuf(:,:,:,jlocal), ya_ExtNiReq(j,n), itag )
ya_ExtNMPIFlag(j,n) = .true.
else
ya_ExtNMPIFlag(j,n) = .false.
end if
end do
end if
end do
do n = 0, nprocs-1
do j = a_jexmin(n), a_jexmax(n)
! South array
if ( ya_ExtSMPIFlag(j,n) ) call MPIWrapperWait( ya_ExtSiReq(j,n) )
! North array
if ( ya_ExtNMPIFlag(j,n) ) call MPIWrapperWait( ya_ExtNiReq(j,n) )
end do
end do
do j = jexmin, jexmax
if ( ya_ExtFlagCrossPoleOrgDataS(j,myrank) ) then
do i = 0, imax/2-1
ii = i + imax/2
xyzf_ExtQMixS(ii,j,:,:) = PM * xzfy_SdRecvBuf(i,:,:,j)
end do
do i = imax/2, imax-1
ii = i - imax/2
xyzf_ExtQMixS(ii,j,:,:) = PM * xzfy_SdRecvBuf(i,:,:,j)
end do
else
xyzf_ExtQMixS(0:imax-1,j,:,:) = xzfy_SdRecvBuf(:,:,:,j)
end if
if ( ya_ExtFlagCrossPoleOrgDataN(j,myrank) ) then
do i = 0, imax/2-1
ii = i + imax/2
xyzf_ExtQMixN(ii,j,:,:) = PM * xzfy_NdRecvBuf(i,:,:,j)
end do
do i = imax/2, imax-1
ii = i - imax/2
xyzf_ExtQMixN(ii,j,:,:) = PM * xzfy_NdRecvBuf(i,:,:,j)
end do
else
xyzf_ExtQMixN(0:imax-1,j,:,:) = xzfy_NdRecvBuf(:,:,:,j)
end if
end do
!===========================================
! set values at longitudinal edge
!-------------------------------------------
#if defined(AXISYMMETRY) || defined(AXISYMMETRY_SJPACK)
do n = 1, ncmax
do k = 1, kmax
do j = jexmin, jexmax
do i = iexmin, 0-1
xyzf_ExtQMixS(i,j,k,n) = xyzf_ExtQMixS(0,j,k,n)
xyzf_ExtQMixN(i,j,k,n) = xyzf_ExtQMixN(0,j,k,n)
end do
do i = imax-1+1, iexmax
xyzf_ExtQMixS(i,j,k,n) = xyzf_ExtQMixS(0,j,k,n)
xyzf_ExtQMixN(i,j,k,n) = xyzf_ExtQMixN(0,j,k,n)
end do
end do
end do
end do
#else
do n = 1, ncmax
do k = 1, kmax
do j = jexmin, jexmax
do i = iexmin, 0-1
xyzf_ExtQMixS(i,j,k,n) = xyzf_ExtQMixS(imax+i,j,k,n)
xyzf_ExtQMixN(i,j,k,n) = xyzf_ExtQMixN(imax+i,j,k,n)
end do
do i = imax-1+1, iexmax
xyzf_ExtQMixS(i,j,k,n) = xyzf_ExtQMixS(i-imax,j,k,n)
xyzf_ExtQMixN(i,j,k,n) = xyzf_ExtQMixN(i-imax,j,k,n)
end do
end do
end do
end do
#endif
end subroutine SLTTExtArrExt2
| Subroutine : | |
| x_LonS( 0:imax-1 ) : | real(DP), intent(in ) |
| y_LatS( 1:jmax/2 ) : | real(DP), intent(in ) |
| x_LonN( 0:imax-1 ) : | real(DP), intent(in ) |
| y_LatN( 1:jmax/2 ) : | real(DP), intent(in ) |
| x_ExtLonS(iexmin:iexmax) : | real(DP), intent(out) |
| y_ExtLatS(jexmin:jexmax) : | real(DP), intent(out) |
| x_ExtLonN(iexmin:iexmax) : | real(DP), intent(out) |
| y_ExtLatN(jexmin:jexmax) : | real(DP), intent(out) |
subroutine SLTTExtArrInit( x_LonS, y_LatS, x_LonN, y_LatN, x_ExtLonS, y_ExtLatS, x_ExtLonN, y_ExtLatN )
! メッセージ出力
! Message output
!
use dc_message, only: MessageNotify
!
! MPI
!
use mpi_wrapper , only : myrank, nprocs, MPIWrapperISend, MPIWrapperIRecv, MPIWrapperWait
use constants0, only : PI
use axesset , only : y_Lat
use sltt_const, only : PIx2, PIH, iexmin, iexmax, jexmin, jexmax, jmaxh, jexglobalmin, jexglobalmax
real(DP), intent(in ) :: x_LonS ( 0:imax-1 )
real(DP), intent(in ) :: y_LatS ( 1:jmax/2 )
real(DP), intent(in ) :: x_LonN ( 0:imax-1 )
real(DP), intent(in ) :: y_LatN ( 1:jmax/2 )
real(DP), intent(out) :: x_ExtLonS(iexmin:iexmax)
real(DP), intent(out) :: y_ExtLatS(jexmin:jexmax)
real(DP), intent(out) :: x_ExtLonN(iexmin:iexmax)
real(DP), intent(out) :: y_ExtLatN(jexmin:jexmax)
!
! local variables
!
integer :: idest
integer :: idep
! y_LatGlobal(jj) : latitude of jj-th component
! : (latitudinal global array)
! y_RankGlobal(jj) : rank of jj-th component
! : (latitudinal global array)
! y_JLocalIndexGlobal(jj) : j index for each rank array of jj-th component
! : (latitudinal global array)
real(DP) :: y_LatGlobal (1:jmax_global)
integer :: y_RankGlobal (1:jmax_global)
integer :: y_JLocalIndexGlobal(1:jmax_global)
real(DP) :: y_ExtLatGlobal (jexglobalmin:jexglobalmax)
integer :: y_ExtRankGlobal (jexglobalmin:jexglobalmax)
integer :: y_ExtJLocalIndexGlobal (jexglobalmin:jexglobalmax)
logical :: y_ExtFlagCrossPoleGlobal(jexglobalmin:jexglobalmax)
integer, allocatable :: ya_ExtSiReq (:,:)
integer, allocatable :: ya_ExtNiReq (:,:)
logical, allocatable :: ya_ExtSMPIFlag(:,:)
logical, allocatable :: ya_ExtNMPiFlag(:,:)
real(DP), allocatable :: aa_SdRecvBuf(:,:)
real(DP), allocatable :: aa_NdRecvBuf(:,:)
real(DP) :: aa_dSendBuf (1,1:jmax)
integer :: irank
integer :: jlocal
integer :: itag
integer :: j1
integer :: i
integer :: j
integer :: n
if ( sltt_extarr_inited ) return
#if defined(AXISYMMETRY) || defined(AXISYMMETRY_SJPACK)
do i = iexmin, 0-1
x_ExtLonS(i) = x_LonS(0) - ( PIx2 * dble(-i) - x_LonS(0) )
end do
do i = 0, imax-1
x_ExtLonS(i) = x_LonS(i)
end do
x_ExtLonS(imax-1+1) = PIx2
do i = imax-1+1+1, iexmax
x_ExtLonS(i) = PIx2 + ( PIx2 * dble(i-(imax-1+1)) - x_LonS(0) )
end do
!
do i = iexmin, 0-1
x_ExtLonN(i) = x_LonN(0) - ( PIx2 * dble(-i) - x_LonN(0) )
end do
do i = 0, imax-1
x_ExtLonN(i) = x_LonN(i)
end do
x_ExtLonN(imax-1+1) = PIx2
do i = imax-1+1+1, iexmax
x_ExtLonN(i) = PIx2 + ( PIx2 * dble(i-(imax-1+1)) - x_LonN(0) )
end do
#else
do i = iexmin, 0-1
x_ExtLonS(i) = x_LonS(0) - ( x_LonS(-i) - x_LonS(0) )
end do
do i = 0, imax-1
x_ExtLonS(i) = x_LonS(i)
end do
x_ExtLonS(imax-1+1) = PIx2
do i = imax-1+1+1, iexmax
x_ExtLonS(i) = PIx2 + ( x_LonS(i-(imax-1+1)) - x_LonS(0) )
end do
!
do i = iexmin, 0-1
x_ExtLonN(i) = x_LonN(0) - ( x_LonN(-i) - x_LonN(0) )
end do
do i = 0, imax-1
x_ExtLonN(i) = x_LonN(i)
end do
x_ExtLonN(imax-1+1) = PIx2
do i = imax-1+1+1, iexmax
x_ExtLonN(i) = PIx2 + ( x_LonN(i-(imax-1+1)) - x_LonN(0) )
end do
#endif
!====================================================================
! Set y_LatGlobal, y_RankGlobal, y_JLocalIndexGlobal.
call SLTTExtArrPrepGlobalArray( y_LatGlobal, y_RankGlobal, y_JLocalIndexGlobal )
do j = jexglobalmin, 1-1
y_ExtLatGlobal (j) = -PIH - ( y_LatGlobal(1-j) - ( -PIH ) )
y_ExtRankGlobal (j) = y_RankGlobal (1-j)
y_ExtJLocalIndexGlobal (j) = y_JLocalIndexGlobal(1-j)
y_ExtFlagCrossPoleGlobal(j) = .true.
end do
do j = 1, jmax_global
y_ExtLatGlobal (j) = y_LatGlobal (j)
y_ExtRankGlobal (j) = y_RankGlobal (j)
y_ExtJLocalIndexGlobal (j) = y_JLocalIndexGlobal(j)
y_ExtFlagCrossPoleGlobal(j) = .false.
end do
do j = jmax_global+1, jexglobalmax
y_ExtLatGlobal (j) = PIH + ( PIH - y_LatGlobal(jmax_global-(j-(jmax_global+1))) )
y_ExtRankGlobal (j) = y_RankGlobal (jmax_global-(j-(jmax_global+1)))
y_ExtJLocalIndexGlobal (j) = y_JLocalIndexGlobal(jmax_global-(j-(jmax_global+1)))
y_ExtFlagCrossPoleGlobal(j) = .true.
end do
allocate( ya_ExtLatS (jexmin_min:jexmax_max, 0:nprocs-1) )
allocate( ya_ExtLatN (jexmin_min:jexmax_max, 0:nprocs-1) )
allocate( ya_ExtRankOrgDataS (jexmin_min:jexmax_max, 0:nprocs-1) )
allocate( ya_ExtRankOrgDataN (jexmin_min:jexmax_max, 0:nprocs-1) )
allocate( ya_ExtJLocalIndexOrgDataS (jexmin_min:jexmax_max, 0:nprocs-1) )
allocate( ya_ExtJLocalIndexOrgDataN (jexmin_min:jexmax_max, 0:nprocs-1) )
allocate( ya_ExtFlagCrossPoleOrgDataS(jexmin_min:jexmax_max, 0:nprocs-1) )
allocate( ya_ExtFlagCrossPoleOrgDataN(jexmin_min:jexmax_max, 0:nprocs-1) )
! rank, (local) j index, and flag for cross pole for original data transfered to rank n
do n = 0, nprocs-1
! j1: global j index for (local) j = 1 at rank n (first index of south array)
j1 = FindGlobalJIndex( y_RankGlobal, y_JLocalIndexGlobal, n, 1 )
do j = a_jexmin(n), a_jexmax(n)
ya_ExtLatS (j,n) = y_ExtLatGlobal (j1+j-1)
ya_ExtRankOrgDataS (j,n) = y_ExtRankGlobal (j1+j-1)
ya_ExtJLocalIndexOrgDataS (j,n) = y_ExtJLocalIndexGlobal (j1+j-1)
ya_ExtFlagCrossPoleOrgDataS(j,n) = y_ExtFlagCrossPoleGlobal(j1+j-1)
end do
! j1: global j index for (local) j = 1 at rank n (first index of north array)
j1 = FindGlobalJIndex( y_RankGlobal, y_JLocalIndexGlobal, n, a_jmaxs(n)+1 )
do j = a_jexmin(n), a_jexmax(n)
ya_ExtLatN (j,n) = y_ExtLatGlobal (j1+j-1)
ya_ExtRankOrgDataN (j,n) = y_ExtRankGlobal (j1+j-1)
ya_ExtJLocalIndexOrgDataN (j,n) = y_ExtJLocalIndexGlobal (j1+j-1)
ya_ExtFlagCrossPoleOrgDataN(j,n) = y_ExtFlagCrossPoleGlobal(j1+j-1)
end do
end do
allocate( aa_SdRecvBuf(1,jexmin_min:jexmax_max) )
allocate( aa_NdRecvBuf(1,jexmin_min:jexmax_max) )
allocate( ya_ExtSiReq (jexmin_min:jexmax_max, 0:nprocs-1) )
allocate( ya_ExtNiReq (jexmin_min:jexmax_max, 0:nprocs-1) )
allocate( ya_ExtSMPIFlag(jexmin_min:jexmax_max, 0:nprocs-1) )
allocate( ya_ExtNMPiFlag(jexmin_min:jexmax_max, 0:nprocs-1) )
!
! Test transfer of data (latitude)
! Transfered data for test are y_ExtLatS and y_ExtLatN.
! But, those data will be overwritten after the test transfer.
!
aa_dSendBuf(1,:) = y_Lat
do n = 0, nprocs-1
if ( n == myrank ) then
!
! Receive
!
do j = a_jexmin(n), a_jexmax(n)
! South array, mpi receive request
irank = ya_ExtRankOrgDataS (j,n)
jlocal = ya_ExtJLocalIndexOrgDataS(j,n)
if ( irank == n ) then
aa_SdRecvBuf(:,j) = y_Lat(jlocal)
ya_ExtSMPIFlag(j,n) = .false.
else
itag = MkSendRecvDestTag( n, j, 'S' )
idep = irank
call MPIWrapperIRecv( idep, 1, aa_SdRecvBuf(:,j), ya_ExtSiReq(j,n), itag )
ya_ExtSMPIFlag(j,n) = .true.
end if
! North array, mpi receive request
irank = ya_ExtRankOrgDataN (j,n)
jlocal = ya_ExtJLocalIndexOrgDataN(j,n)
if ( irank == n ) then
aa_NdRecvBuf(:,j) = y_Lat(jlocal)
ya_ExtNMPIFlag(j,n) = .false.
else
itag = MkSendRecvDestTag( n, j, 'N' )
idep = irank
call MPIWrapperIRecv( idep, 1, aa_NdRecvBuf(:,j), ya_ExtNiReq(j,n), itag )
ya_ExtNMPIFlag(j,n) = .true.
end if
end do
else
!
! Send
!
do j = a_jexmin(n), a_jexmax(n)
! South array, mpi send request
irank = ya_ExtRankOrgDataS (j,n)
jlocal = ya_ExtJLocalIndexOrgDataS(j,n)
if ( irank == myrank ) then
itag = MkSendRecvDestTag( n, j, 'S' )
idest = n
call MPIWrapperISend( idest, 1, aa_dSendBuf(:,jlocal), ya_ExtSiReq(j,n), itag )
ya_ExtSMPIFlag(j,n) = .true.
else
ya_ExtSMPIFlag(j,n) = .false.
end if
! North array, mpi send request
irank = ya_ExtRankOrgDataN (j,n)
jlocal = ya_ExtJLocalIndexOrgDataN(j,n)
if ( irank == myrank ) then
itag = MkSendRecvDestTag( n, j, 'N' )
idest = n
call MPIWrapperISend( idest, 1, aa_dSendBuf(:,jlocal), ya_ExtNiReq(j,n), itag )
ya_ExtNMPIFlag(j,n) = .true.
else
ya_ExtNMPIFlag(j,n) = .false.
end if
end do
end if
end do
do n = 0, nprocs-1
do j = a_jexmin(n), a_jexmax(n)
! South array
if ( ya_ExtSMPIFlag(j,n) ) call MPIWrapperWait( ya_ExtSiReq(j,n) )
! North array
if ( ya_ExtNMPIFlag(j,n) ) call MPIWrapperWait( ya_ExtNiReq(j,n) )
end do
end do
y_ExtLatS = aa_SdRecvBuf(1,jexmin:jexmax)
y_ExtLatN = aa_NdRecvBuf(1,jexmin:jexmax)
deallocate( aa_SdRecvBuf )
deallocate( aa_NdRecvBuf )
deallocate( ya_ExtSiReq )
deallocate( ya_ExtNiReq )
deallocate( ya_ExtSMPIFlag )
deallocate( ya_ExtNMPiFlag )
! Checking transfer
!
! global j index for j = 1 at local (southern edge of south array)
j1 = FindGlobalJIndex( y_RankGlobal, y_JLocalIndexGlobal, myrank, 1 )
do j = jexmin, jexmax
if ( .not. ya_ExtFlagCrossPoleOrgDataS(j,myrank) ) then
if ( y_ExtLatS(j) /= y_ExtLatGlobal(j1+j-1) ) then
call MessageNotify( 'E', module_name, 'Rank = %d, y_ExtLatS(%d) = %f is not same as y_ExtLatGlobal(%d) = %f.', i = (/myrank, j, j1+j-1/), d = (/y_ExtLatS(j), y_ExtLatGlobal(j1+j-1)/) )
end if
end if
end do
! global j index for j = 1 at local (southern edge of north array)
j1 = FindGlobalJIndex( y_RankGlobal, y_JLocalIndexGlobal, myrank, jmaxh+1 )
do j = jexmin, jexmax
if ( .not. ya_ExtFlagCrossPoleOrgDataN(j,myrank) ) then
if ( y_ExtLatN(j) /= y_ExtLatGlobal(j1+j-1) ) then
call MessageNotify( 'E', module_name, 'Rank = %d, y_ExtLatN(%d) = %f is not same as y_ExtLatGlobal(%d) = %f.', i = (/myrank, j, j1+j-1/), d = (/y_ExtLatN(j), y_ExtLatGlobal(j1+j-1)/) )
end if
end if
end do
! global j index for j = 1 at local (southern edge of south array)
j1 = FindGlobalJIndex( y_RankGlobal, y_JLocalIndexGlobal, myrank, 1 )
do j = jexmin, jexmax
y_ExtLatS(j) = y_ExtLatGlobal(j1+j-1)
end do
! global j index for j = 1 at local (southern edge of north array)
j1 = FindGlobalJIndex( y_RankGlobal, y_JLocalIndexGlobal, myrank, jmaxh+1 )
do j = jexmin, jexmax
y_ExtLatN(j) = y_ExtLatGlobal(j1+j-1)
end do
sltt_extarr_inited = .true.
end subroutine SLTTExtArrInit
| Function : | |
| j : | integer |
| y_RankGlobal(1:jmax_global) : | integer, intent(in) |
| y_JLocalIndexGlobal(1:jmax_global) : | integer, intent(in) |
| irank : | integer, intent(in) |
| jindex : | integer, intent(in) |
function FindGlobalJIndex( y_RankGlobal, y_JLocalIndexGlobal, irank, jindex ) result( j )
! メッセージ出力
! Message output
!
use dc_message, only: MessageNotify
integer, intent(in) :: y_RankGlobal (1:jmax_global)
integer, intent(in) :: y_JLocalIndexGlobal(1:jmax_global)
integer, intent(in) :: irank
integer, intent(in) :: jindex
integer :: j
search_j: do j = 1, jmax_global
if ( ( y_RankGlobal(j) == irank ) .and. ( y_JLocalIndexGlobal(j) == jindex ) ) exit search_j
end do search_j
if ( j > jmax_global ) then
call MessageNotify( 'E', module_name, 'Cannot find proper j.' )
end if
end function FindGlobalJIndex
| Function : | |
| itag : | integer |
| irank : | integer , intent(in) |
| jlocalindex : | integer , intent(in) |
| hemisphere : | character(*), intent(in) |
function MkSendRecvDestTag( irank, jlocalindex, hemisphere ) result( itag )
! irank : rank at destination
! jlocalindex : j index at destination
! メッセージ出力
! Message output
!
use dc_message, only: MessageNotify
!
! MPI
!
use mpi_wrapper, only : nprocs
integer , intent(in) :: irank
integer , intent(in) :: jlocalindex
character(*), intent(in) :: hemisphere
integer :: itag
integer :: ioffset
ioffset = jmax_max * nprocs
select case( hemisphere )
case ( 'S' )
itag = jmax_max * ( + irank ) + jlocalindex
case ( 'N' )
itag = jmax_max * ( nprocs + irank ) + jlocalindex
case default
call MessageNotify( 'E', module_name, 'Unexpected value of hemisphere.' )
end select
itag = itag + ioffset
if ( itag < 0 ) then
write( 6, * ) 'tag is negative:', itag, irank, jlocalindex, trim( hemisphere )
end if
end function MkSendRecvDestTag
| Subroutine : | |
| y_LatGlobal(1:jmax_global) : | real(DP), intent(out) |
| y_RankGlobal(1:jmax_global) : | integer , intent(out) |
| y_JLocalIndexGlobal(1:jmax_global) : | integer , intent(out) |
subroutine SLTTExtArrPrepGlobalArray( y_LatGlobal, y_RankGlobal, y_JLocalIndexGlobal )
! メッセージ出力
! Message output
!
use dc_message, only: MessageNotify
!
! MPI
!
use mpi_wrapper, only : nprocs, myrank, MPIWrapperISend, MPIWrapperIRecv, MPIWrapperWait
use axesset , only : y_Lat
use sltt_const, only : jexmin, jexmax
real(DP), intent(out) :: y_LatGlobal (1:jmax_global)
integer , intent(out) :: y_RankGlobal (1:jmax_global)
integer , intent(out) :: y_JLocalIndexGlobal(1:jmax_global)
!
! local variables
!
real(DP) :: a_dSendBuf (1:jmax)
real(DP), allocatable :: aa_dRecvBuf(:,:)
integer :: a_iReqSend (0:nprocs-1)
integer :: a_iReqRecv (0:nprocs-1)
integer :: idep
integer :: idest
integer :: j
integer :: jglobal
integer :: l
integer :: n
allocate( a_jmax (0:nprocs-1) )
allocate( a_jmaxs(0:nprocs-1) )
allocate( a_jmaxn(0:nprocs-1) )
allocate( a_jexmin(0:nprocs-1) )
allocate( a_jexmax(0:nprocs-1) )
! share jmax
call SLTTExtShareiScalar( jmax, a_jmax )
! share jexmin
call SLTTExtShareiScalar( jexmin, a_jexmin )
! share jexmax
call SLTTExtShareiScalar( jexmax, a_jexmax )
jmax_max = 1
do n = 0, nprocs-1
jmax_max = max( jmax_max, a_jmax(n) )
end do
a_jmaxs = a_jmax / 2
a_jmaxn = a_jmax / 2
jexmin_min = 1
do n = 0, nprocs-1
jexmin_min = min( jexmin_min, a_jexmin(n) )
end do
jexmax_max = 1
do n = 0, nprocs-1
jexmax_max = max( jexmax_max, a_jexmax(n) )
end do
!----------
allocate( aa_dRecvBuf(1:jmax_max, 0:nprocs-1) )
a_dSendBuf = y_Lat
do n = 0, nprocs-1
if ( n == myrank ) cycle
idest = n
call MPIWrapperISend( idest, jmax, a_dSendBuf, a_IReqSend(n) )
end do
do n = 0, nprocs-1
if ( n == myrank ) cycle
idep = n
call MPIWrapperIRecv( idep, a_jmax(n), aa_dRecvBuf(1:a_jmax(n), n), a_IReqRecv(n) )
end do
n = myrank
aa_dRecvBuf(1:jmax, n) = a_dSendBuf
do n = 0, nprocs-1
if ( n == myrank ) cycle
call MPIWrapperWait( a_IReqSend(n) )
call MPIWrapperWait( a_IReqRecv(n) )
end do
!
jglobal = 0
do n = nprocs-1, 0, -1
do j = 1, a_jmaxs(n)
jglobal = jglobal + 1
y_LatGlobal (jglobal) = aa_dRecvBuf(j,n)
y_RankGlobal (jglobal) = n
y_JLocalIndexGlobal(jglobal) = j
end do
end do
do n = 0, nprocs-1
do j = a_jmaxs(n)+1, a_jmax(n)
jglobal = jglobal + 1
y_LatGlobal (jglobal) = aa_dRecvBuf(j,n)
y_RankGlobal (jglobal) = n
y_JLocalIndexGlobal(jglobal) = j
end do
end do
deallocate( aa_dRecvBuf )
end subroutine SLTTExtArrPrepGlobalArray
| Subroutine : | |
| iVal : | integer , intent(in ) |
| a_iVal(0:nprocs-1) : | integer , intent(out) |
subroutine SLTTExtShareiScalar( iVal, a_iVal )
! メッセージ出力
! Message output
!
use dc_message, only: MessageNotify
!
! MPI
!
use mpi_wrapper, only : nprocs, myrank, MPIWrapperISend, MPIWrapperIRecv, MPIWrapperWait
integer , intent(in ) :: iVal
integer , intent(out) :: a_iVal(0:nprocs-1)
!
! local variables
!
integer :: a_iSendBuf (1)
integer :: aa_iRecvBuf(1,0:nprocs-1)
integer :: a_iReqSend (0:nprocs-1)
integer :: a_iReqRecv (0:nprocs-1)
integer :: idep
integer :: idest
integer :: n
a_iSendBuf = iVal
do n = 0, nprocs-1
if ( n == myrank ) then
aa_iRecvBuf(:,n) = a_iSendBuf
else
idest = n
call MPIWrapperISend( idest, 1, a_iSendBuf , a_iReqSend(n) )
idep = n
call MPIWrapperIRecv( idep, 1, aa_iRecvBuf(:,n), a_iReqRecv(n) )
end if
end do
do n = 0, nprocs-1
if ( n == myrank ) cycle
call MPIWrapperWait( a_iReqSend(n) )
call MPIWrapperWait( a_iReqRecv(n) )
end do
!
a_iVal = aa_iRecvBuf(1,:)
end subroutine SLTTExtShareiScalar
| Variable : | |||
| sltt_extarr_inited = .false. : | logical, save
|
| Variable : | |
| ya_ExtFlagCrossPoleOrgDataN(:,:) : | logical , save, allocatable |
| Variable : | |
| ya_ExtFlagCrossPoleOrgDataS(:,:) : | logical , save, allocatable |