!-------------------------------------- LICENCE BEGIN ------------------------------------
!Environment Canada - Atmospheric Science and Technology License/Disclaimer,
! version 3; Last Modified: May 7, 2008.
!This is free but copyrighted software; you can use/redistribute/modify it under the terms
!of the Environment Canada - Atmospheric Science and Technology License/Disclaimer
!version 3 or (at your option) any later version that should be found at:
!http://collaboration.cmc.ec.gc.ca/science/rpn.comm/license.html
!
!This software is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY;
!without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
!See the above mentioned License/Disclaimer for more details.
!You should have received a copy of the License/Disclaimer along with this software;
!if not, you can write to: EC-RPN COMM Group, 2121 TransCanada, suite 500, Dorval (Quebec),
!CANADA, H9P 1J3; or send e-mail to service.rpn@ec.gc.ca
!-------------------------------------- LICENCE END --------------------------------------
***s/r Out_sblock - sets up global indices for each block
*
#include "model_macros_f.h"
*
subroutine out_sblock(F_numpe_perb,F_nblocx,F_nblocy,F_myblocx,F_myblocy, 1
$ F_mycol,F_myrow,F_hx,F_hy,F_ni,F_nj, F_blocme, F_mybloc,
$ F_gindx,F_numproc,F_myproc,F_ixg,F_grtyp_S,F_unit_S,
$ F_deet, F_dateo, F_etik_S, F_ndigits,F_runstrt_S,
$ F_endstepno, F_flipit_L, F_debug_L)
*
implicit none
*
character*12 F_etik_S
character*16 F_runstrt_S
character*1 F_grtyp_S,F_unit_S
integer F_numpe_perb,F_nblocx,F_nblocy,F_myblocx,F_myblocy,
$ F_myrow,F_mycol, F_mybloc,
$ F_blocme,F_numproc,F_myproc, F_dateo,F_deet,F_endstepno
integer F_gindx(6,F_numproc),F_ni,F_nj,F_ixg(4),F_hx,F_hy
integer F_ndigits
logical F_flipit_L, F_debug_L
*author
* M. Desgagne - V. Lee
*
*revision
* v3_20 - Desgagne/Lee - initial MPI version
*
*object
* See above
*
*arguments
* None
*
*implicits
#include "out.cdk"
*
integer i, j, err
integer ijdeb(2), ijfin(2), tag, blocid, status
logical west_L,east_L,north_L,south_L
data tag / 44 /
*
*----------------------------------------------------------------------
*
Out_unf = 0
Out_hx = F_hx
Out_hy = F_hy
Out_flipit_L = F_flipit_L
Out_debug_L = F_debug_L
Out_gridtyp_S = F_grtyp_S
Out_unit_S = F_unit_S
Out_etiket_S = F_etik_S
Out_etik_S = F_etik_S
Out_ndigits = F_ndigits
Out_runstrt_S = F_runstrt_S
Out_endstepno = F_endstepno
Out_typvar_S = 'P'
Out_deet = F_deet
Out_dateo = F_dateo
Out_ixg(1) = F_ixg(1)
Out_ixg(2) = F_ixg(2)
Out_ixg(3) = F_ixg(3)
Out_ixg(4) = F_ixg(4)
Out_myprocni = F_ni
Out_myprocnj = F_nj
Out_myrow = F_myrow
Out_mycol = F_mycol
Out_numpe_perb = F_numpe_perb
*
Out_nblocx = F_nblocx
Out_nblocy = F_nblocy
Out_mybloc = F_mybloc
Out_myblocx= F_myblocx
Out_myblocy= F_myblocy
Out_blocme = F_blocme
Out_myproc = F_myproc
Out_myproci0 = F_gindx(1,F_myproc+1)
Out_myprocj0 = F_gindx(3,F_myproc+1)
* Setup for global indices for Block topology
if (Out_blocme.eq.(Out_numpe_perb-1)) then
ijfin(1) = F_gindx(2,F_myproc+1)
ijfin(2) = F_gindx(4,F_myproc+1)
do blocid=0,Out_numpe_perb-2
call RPN_COMM_send ( ijfin, 2, 'MPI_INTEGER', blocid,
$ tag, 'BLOC', err )
end do
endif
if (Out_blocme.ne.(Out_numpe_perb-1)) then
call RPN_COMM_recv ( ijfin, 2, 'MPI_INTEGER', (Out_numpe_perb-1),
$ tag, 'BLOC', status, err )
endif
Out_blocin = ijfin(1)
Out_blocjn = ijfin(2)
*
if (Out_blocme.eq.0) then
ijdeb(1) = F_gindx(1,F_myproc+1)
ijdeb(2) = F_gindx(3,F_myproc+1)
do blocid=1,Out_numpe_perb-1
call RPN_COMM_send ( ijdeb, 2, 'MPI_INTEGER', blocid,
$ tag, 'BLOC', err )
end do
endif
if (Out_blocme.ne.0) then
call RPN_COMM_recv ( ijdeb, 2, 'MPI_INTEGER', 0,
$ tag, 'BLOC', status, err )
endif
Out_bloci0 = ijdeb(1)
Out_blocj0 = ijdeb(2)
Out_blocni = Out_blocin - Out_bloci0 + 1
Out_blocnj = Out_blocjn - Out_blocj0 + 1
*
Out_blocwest = 0
Out_bloceast = 0
Out_blocsouth = 0
Out_blocnorth = 0
west_L = Out_myblocx .eq. 0
south_L = Out_myblocy .eq. 0
east_L = Out_myblocx .eq. Out_nblocx-1
north_L = Out_myblocy .eq. Out_nblocy-1
if (west_L ) Out_blocwest = 1
if (east_L ) Out_bloceast = 1
if (south_L) Out_blocsouth = 1
if (north_L) Out_blocnorth = 1
*
*----------------------------------------------------------------------
return
end