29 use ctlblk_mod,
only: num_procs, jend, iup, jsta, idn, mpi_comm_comp, im,&
31 jsta_2l, jend_2u,ileft,iright,ista_2l,iend_2u,ista,iend,jm,modelname
33 use iso_c_binding,
only: c_sizeof, c_float
37 real(kind=c_float),
intent(inout) :: a( ista_2l:iend_2u,jsta_2l:jend_2u )
38 real(kind=c_float),
allocatable :: coll(:), colr(:)
39 integer,
allocatable :: icoll(:), icolr(:)
40 integer status(MPI_STATUS_SIZE)
41 integer ierr, jstam1, jendp1,j
42 integer size,ubound,lbound
43 integer msglenl, msglenr
44 integer i,ii,jj, ibl,ibu,jbl,jbu,icc,jcc
49 logical,
parameter :: checkcoords = .false.
65 if ( num_procs <= 1 )
return
69 IF(modelname ==
'GFS')
then
70 if(ifirst .le. 0 .and. me .eq. 0) print *,
' CYCLIC BC APPLIED'
71 if(ileft .eq. mpi_proc_null) iwest=1
72 if(iright .eq. mpi_proc_null) ieast=1
73 if(ileft .eq. mpi_proc_null) ileft=me+(numx-1)
74 if(iright .eq. mpi_proc_null) iright=(me-numx) +1
77 jstam1 = max(jsta_2l,jsta-1)
81 call mpi_sendrecv(a(ista,jend),iend-ista+1,mpi_real4,iup,1, &
82 & a(ista,jstam1),iend-ista+1,mpi_real4,idn,1, &
83 & mpi_comm_comp,status,ierr)
86 print *,
' problem with first sendrecv in exch, ierr = ',ierr
91 if(ifirst .le. 0)
then
92 call mpi_sendrecv(
ibcoords(ista,jend),iend-ista+1,mpi_integer,iup,1, &
93 &
ibcoords(ista,jstam1),iend-ista+1,mpi_integer,idn,1, &
94 & mpi_comm_comp,status,ierr)
96 print *,
' problem with second sendrecv in exch, ierr = ',ierr
102 if(ii .ne. i .or. jj .ne. jstam1 ) print *,
' GWVX JEXCH CHECK FAIL ',ii,jj,
ibcoords(i,jstam1),i
111 if(iright .lt. 0) msglenr=1
112 if(ileft .lt. 0) msglenl=1
118 call mpi_barrier(mpi_comm_comp,ierr)
122 call mpi_sendrecv(coll(jsta),msglenl ,mpi_real4,ileft,1, &
123 & colr(jsta),msglenr ,mpi_real4,iright,1, &
124 & mpi_comm_comp,status,ierr)
126 if ( ierr /= 0 )
then
127 print *,
' problem with third sendrecv in exch, ierr = ',ierr
131 if(ifirst .le. 0)
then
132 call mpi_sendrecv(icoll(jsta),msglenl ,mpi_integer,ileft,1, &
133 & icolr(jsta),msglenr ,mpi_integer,iright,1, &
134 & mpi_comm_comp,status,ierr)
135 if ( ierr /= 0 )
then
136 print *,
' problem with fourth sendrecv in exch, ierr = ',ierr
141 if(iright .ge. 0)
then
145 if(ifirst .le. 0)
then
149 if( j .ne. jj .or. ii .ne. iend+1 .and. ii .ne. im .and. ii .ne. 1) &
150 write(*,921) j,iend+1,ii,jj,
ibcoords(iend+1,j),
'IEXCH COORD FAIL j,iend+1,ii,jj,ibcoord '
160 if ( ierr /= 0 )
then
161 print *,
' problem with fifth sendrecv in exch, ierr = ',ierr
164 jendp1 = min(jend+1,jend_2u)
174 call mpi_sendrecv(a(ista,jsta),iend-ista+1,mpi_real4,idn,1, &
175 & a(ista,jendp1),iend-ista+1,mpi_real4,iup,1, &
176 & mpi_comm_comp,status,ierr)
177 if ( ierr /= 0 )
then
178 print *,
' problem with sixth sendrecv in exch, ierr = ',ierr
182 if (checkcoords)
then
183 if (ifirst .le. 0)
then
184 call mpi_sendrecv(
ibcoords(ista,jsta),iend-ista+1,mpi_integer,idn,1, &
185 &
ibcoords(ista,jendp1),iend-ista+1,mpi_integer,iup,1, &
186 & mpi_comm_comp,status,ierr)
187 if ( ierr /= 0 )
then
188 print *,
' problem with seventh sendrecv in exch, ierr = ',ierr
196 call mpi_sendrecv(colr(jsta),msglenr ,mpi_real4,iright,1 , &
197 & coll(jsta),msglenl ,mpi_real4,ileft ,1, &
198 & mpi_comm_comp,status,ierr)
200 if ( ierr /= 0 )
then
201 print *,
' problem with eighth sendrecv in exch, ierr = ',ierr
205 if (ifirst .le. 0)
then
206 call mpi_sendrecv(icolr(jsta),msglenr ,mpi_integer,iright,1 , &
207 & icoll(jsta),msglenl ,mpi_integer,ileft ,1, &
208 & mpi_comm_comp,status,ierr)
209 if ( ierr /= 0 )
then
210 print *,
' problem with ninth sendrecv in exch, ierr = ',ierr
215 if(ileft .ge. 0)
then
219 if(ifirst .le. 0)
then
223 if( j .ne. jj .or. ii .ne. ista-1 .and. ii .ne. im .and. ii .ne. 1) &
224 write(*,921) j,ista-1,ii,jj,
ibcoords(ista-1,j),
'EXCH COORD FAIL j,ista-1,ii,jj,ibcoord '
233 if(ifirst .le. 0)
then
238 if(ii .ne. i .or. jj .ne. j)
write(*,151)
'INFAILED IJ ',i,j,
ibcoords(i,j),ibl,jbl,ibu,jbu
256 if(modelname ==
'GFS')
then
264 call mpi_sendrecv(a(iend,jbl ),1, mpi_real4,iright,1 , &
265 & a(ibl ,jbl ),1, mpi_real4,ileft ,1, &
266 & mpi_comm_comp,status,ierr)
267 if ( ierr /= 0 )
then
268 print *,
' problem with tenth sendrecv in exch, ierr = ',ierr
272 call mpi_sendrecv(a(iend,jbu ),1, mpi_real4,iright,1 , &
273 & a(ibl ,jbu ),1, mpi_real4,ileft ,1, &
274 & mpi_comm_comp,status,ierr)
276 if ( ierr /= 0 )
then
277 print *,
' problem with eleventh sendrecv in exch, ierr = ',ierr
281 call mpi_sendrecv(a(ista,jbl ),1, mpi_real4,ileft ,1, &
282 & a(ibu ,jbl ),1, mpi_real4,iright,1, &
283 & mpi_comm_comp,status,ierr)
285 if ( ierr /= 0 )
then
286 print *,
' problem with twelft sendrecv in exch, ierr = ',ierr
290 call mpi_sendrecv(a(ista,jbu ),1, mpi_real4,ileft ,1 , &
291 & a(ibu ,jbu ),1, mpi_real4,iright,1, &
292 & mpi_comm_comp,status,ierr)
294 if ( ierr /= 0 )
then
295 print *,
' problem with thirteenth sendrecv in exch, ierr = ',ierr
299 139
format(a20,5(i10,i6,i6,
'<>'))
302 if(ifirst .le. 0)
then
303 call mpi_sendrecv(
ibcoords(iend,jbl ),1 ,mpi_integer,iright,1 , &
304 &
ibcoords(ibl ,jbl ),1 ,mpi_integer,ileft ,1, &
305 & mpi_comm_comp,status,ierr)
307 call mpi_sendrecv(
ibcoords(iend,jbu ),1 ,mpi_integer,iright,1, &
308 &
ibcoords(ibl ,jbu ),1 ,mpi_integer,ileft ,1, &
309 & mpi_comm_comp,status,ierr)
310 call mpi_sendrecv(
ibcoords(ista,jbl ),1 ,mpi_integer,ileft ,1, &
311 &
ibcoords(ibu ,jbl ),1 ,mpi_integer,iright,1, &
312 & mpi_comm_comp,status,ierr)
313 call mpi_sendrecv(
ibcoords(ista,jbu ),1 ,mpi_integer,ileft ,1 , &
314 &
ibcoords(ibu ,jbu ),1 ,mpi_integer,iright,1, &
315 mpi_comm_comp,status,ierr)
324 if(ii .ne. icc .and. icc .ne. 0)
write(*,151)
' CORNER FAILI ilb ll ',icc,jcc,
ibcoords(icc,jcc),ii,jj
325 if( jj .ne. jcc)
write(*,151)
' CORNER FAILJ ilb ll ',icc,jcc,
ibcoords(icc,jcc),ii,jj
331 if(ii .ne. icc .and. icc .ne. im+1 )
write(*,151)
' CORNER FAILI ilb ul ',icc,jcc,
ibcoords(icc,jcc),ii,jj
332 if( jj .ne. jcc )
write(*,151)
' CORNER FAILJ ilb ul ',icc,jcc,
ibcoords(icc,jcc),ii,jj
338 if(ii .ne. icc .and. icc .ne. im+1)
write(*,151)
' CORNER FAILI ilb uu ',icc,jcc,
ibcoords(icc,jcc),ii,jj
339 if( jj .ne. jcc )
write(*,151)
' CORNER FAILJ ilb ul ',icc,jcc,
ibcoords(icc,jcc),ii,jj
345 if(ii .ne. icc .and. icc .ne. 0 )
write(*,151)
' CORNER FAILI ilb lu ',icc,jcc,
ibcoords(icc,jcc),ii,jj
346 if( jj .ne. jcc )
write(*,151)
' CORNER FAILJ ilb ul ',icc,jcc,
ibcoords(icc,jcc),ii,jj
365 if(ii .ne. i .or. jj .ne. j)
write(*,151)
'GWVX FAILED IJ ',i,j,
ibcoords(i,j),ibl,jbl,ibu,jbu
369 151
format(a70,10i10)
378 if(ii .ne. i .or. jj .ne. j)
write(*,151)
'GWVX FAILEDI JBU IJ ',i,j,
ibcoords(i,j),ibl,jbl,ibu,jbu
385 if(ii .ne. i .or. jj .ne. j)
write(*,151)
'GWVX FAILEDI JBL IJ ',i,j,
ibcoords(i,j),ibl,jbl,ibu,jbu
394 if(ii .ne. i .and. ii .ne. im .or. jj .ne. j)
write(*,151)
'GWVX FAILED IBL IJ ',ii,i,j,
ibcoords(i,j),ibl,jbl,ibu,jbu
401 if(ii .ne. i .and. ii .ne. 1 .or. jj .ne. j)
write(*,151)
'GWVX FAILED IBU ii i j ibcoords ibl,jbl,ibu,jbu',ii,i,j,
ibcoords(i,j),ibl,jbl,ibu,jbu
404 if(me .eq. 0)
write(*,*)
' IFIRST CHECK'
410 if ( ierr /= 0 )
then
411 print *,
' problem with second sendrecv in exch, ierr = ',ierr
414 call mpi_barrier(mpi_comm_comp,ierr)