28 use ctlblk_mod,
only: num_procs, jend, iup, jsta, idn, mpi_comm_comp, im,&
30 jsta_2l, jend_2u,ileft,iright,ista_2l,iend_2u,ista,iend,jm,modelname
36 real,
intent(inout) :: a ( ista_2l:iend_2u,jsta_2l:jend_2u )
37 real,
allocatable :: coll(:), colr(:)
38 integer,
allocatable :: icoll(:), icolr(:)
39 integer status(MPI_STATUS_SIZE)
40 integer ierr, jstam1, jendp1,j
41 integer size,ubound,lbound
42 integer msglenl, msglenr
43 integer i,ii,jj, ibl,ibu,jbl,jbu,icc,jcc
47 logical,
parameter :: checkcoords = .false.
63 if ( num_procs <= 1 )
return
67 IF(modelname ==
'GFS')
then
68 if(ifirst .le. 0 .and. me .eq. 0) print *,
' CYCLIC BC APPLIED'
69 if(ileft .eq. mpi_proc_null) iwest=1
70 if(iright .eq. mpi_proc_null) ieast=1
71 if(ileft .eq. mpi_proc_null) ileft=me+(numx-1)
72 if(iright .eq. mpi_proc_null) iright=(me-numx) +1
75 jstam1 = max(jsta_2l,jsta-1)
79 call mpi_sendrecv(a(ista,jend),iend-ista+1,mpi_real,iup,1, &
80 & a(ista,jstam1),iend-ista+1,mpi_real,idn,1, &
81 & mpi_comm_comp,status,ierr)
84 print *,
' problem with first sendrecv in exch, ierr = ',ierr
89 if(ifirst .le. 0)
then
90 call mpi_sendrecv(
ibcoords(ista,jend),iend-ista+1,mpi_integer,iup,1, &
91 &
ibcoords(ista,jstam1),iend-ista+1,mpi_integer,idn,1, &
92 & mpi_comm_comp,status,ierr)
94 print *,
' problem with second sendrecv in exch, ierr = ',ierr
100 if(ii .ne. i .or. jj .ne. jstam1 ) print *,
' GWVX JEXCH CHECK FAIL ',ii,jj,
ibcoords(i,jstam1),i
109 if(iright .lt. 0) msglenr=1
110 if(ileft .lt. 0) msglenl=1
116 call mpi_barrier(mpi_comm_comp,ierr)
120 call mpi_sendrecv(coll(jsta),msglenl ,mpi_real,ileft,1, &
121 & colr(jsta),msglenr ,mpi_real,iright,1, &
122 & mpi_comm_comp,status,ierr)
124 if ( ierr /= 0 )
then
125 print *,
' problem with third sendrecv in exch, ierr = ',ierr
129 if(ifirst .le. 0)
then
130 call mpi_sendrecv(icoll(jsta),msglenl ,mpi_integer,ileft,1, &
131 & icolr(jsta),msglenr ,mpi_integer,iright,1, &
132 & mpi_comm_comp,status,ierr)
133 if ( ierr /= 0 )
then
134 print *,
' problem with fourth sendrecv in exch, ierr = ',ierr
139 if(iright .ge. 0)
then
143 if(ifirst .le. 0)
then
147 if( j .ne. jj .or. ii .ne. iend+1 .and. ii .ne. im .and. ii .ne. 1) &
148 write(*,921) j,iend+1,ii,jj,
ibcoords(iend+1,j),
'IEXCH COORD FAIL j,iend+1,ii,jj,ibcoord '
158 if ( ierr /= 0 )
then
159 print *,
' problem with fifth sendrecv in exch, ierr = ',ierr
162 jendp1 = min(jend+1,jend_2u)
172 call mpi_sendrecv(a(ista,jsta),iend-ista+1,mpi_real,idn,1, &
173 & a(ista,jendp1),iend-ista+1,mpi_real,iup,1, &
174 & mpi_comm_comp,status,ierr)
175 if ( ierr /= 0 )
then
176 print *,
' problem with sixth sendrecv in exch, ierr = ',ierr
180 if (checkcoords)
then
181 if (ifirst .le. 0)
then
182 call mpi_sendrecv(
ibcoords(ista,jsta),iend-ista+1,mpi_integer,idn,1, &
183 &
ibcoords(ista,jendp1),iend-ista+1,mpi_integer,iup,1, &
184 & mpi_comm_comp,status,ierr)
185 if ( ierr /= 0 )
then
186 print *,
' problem with seventh sendrecv in exch, ierr = ',ierr
194 call mpi_sendrecv(colr(jsta),msglenr ,mpi_real,iright,1 , &
195 & coll(jsta),msglenl ,mpi_real,ileft ,1, &
196 & mpi_comm_comp,status,ierr)
198 if ( ierr /= 0 )
then
199 print *,
' problem with eighth sendrecv in exch, ierr = ',ierr
203 if (ifirst .le. 0)
then
204 call mpi_sendrecv(icolr(jsta),msglenr ,mpi_integer,iright,1 , &
205 & icoll(jsta),msglenl ,mpi_integer,ileft ,1, &
206 & mpi_comm_comp,status,ierr)
207 if ( ierr /= 0 )
then
208 print *,
' problem with ninth sendrecv in exch, ierr = ',ierr
213 if(ileft .ge. 0)
then
217 if(ifirst .le. 0)
then
221 if( j .ne. jj .or. ii .ne. ista-1 .and. ii .ne. im .and. ii .ne. 1) &
222 write(*,921) j,ista-1,ii,jj,
ibcoords(ista-1,j),
'EXCH COORD FAIL j,ista-1,ii,jj,ibcoord '
231 if(ifirst .le. 0)
then
236 if(ii .ne. i .or. jj .ne. j)
write(*,151)
'INFAILED IJ ',i,j,
ibcoords(i,j),ibl,jbl,ibu,jbu
254 if(modelname ==
'GFS')
then
262 call mpi_sendrecv(a(iend,jbl ),1, mpi_real,iright,1 , &
263 & a(ibl ,jbl ),1, mpi_real,ileft ,1, &
264 & mpi_comm_comp,status,ierr)
265 if ( ierr /= 0 )
then
266 print *,
' problem with tenth sendrecv in exch, ierr = ',ierr
270 call mpi_sendrecv(a(iend,jbu ),1, mpi_real,iright,1 , &
271 & a(ibl ,jbu ),1, mpi_real,ileft ,1, &
272 & mpi_comm_comp,status,ierr)
274 if ( ierr /= 0 )
then
275 print *,
' problem with eleventh sendrecv in exch, ierr = ',ierr
279 call mpi_sendrecv(a(ista,jbl ),1, mpi_real,ileft ,1, &
280 & a(ibu ,jbl ),1, mpi_real,iright,1, &
281 & mpi_comm_comp,status,ierr)
283 if ( ierr /= 0 )
then
284 print *,
' problem with twelft sendrecv in exch, ierr = ',ierr
288 call mpi_sendrecv(a(ista,jbu ),1, mpi_real,ileft ,1 , &
289 & a(ibu ,jbu ),1, mpi_real,iright,1, &
290 & mpi_comm_comp,status,ierr)
292 if ( ierr /= 0 )
then
293 print *,
' problem with thirteenth sendrecv in exch, ierr = ',ierr
297 139
format(a20,5(i10,i6,i6,
'<>'))
300 if(ifirst .le. 0)
then
301 call mpi_sendrecv(
ibcoords(iend,jbl ),1 ,mpi_integer,iright,1 , &
302 &
ibcoords(ibl ,jbl ),1 ,mpi_integer,ileft ,1, &
303 & mpi_comm_comp,status,ierr)
305 call mpi_sendrecv(
ibcoords(iend,jbu ),1 ,mpi_integer,iright,1, &
306 &
ibcoords(ibl ,jbu ),1 ,mpi_integer,ileft ,1, &
307 & mpi_comm_comp,status,ierr)
308 call mpi_sendrecv(
ibcoords(ista,jbl ),1 ,mpi_integer,ileft ,1, &
309 &
ibcoords(ibu ,jbl ),1 ,mpi_integer,iright,1, &
310 & mpi_comm_comp,status,ierr)
311 call mpi_sendrecv(
ibcoords(ista,jbu ),1 ,mpi_integer,ileft ,1 , &
312 &
ibcoords(ibu ,jbu ),1 ,mpi_integer,iright,1, &
313 mpi_comm_comp,status,ierr)
322 if(ii .ne. icc .and. icc .ne. 0)
write(*,151)
' CORNER FAILI ilb ll ',icc,jcc,
ibcoords(icc,jcc),ii,jj
323 if( jj .ne. jcc)
write(*,151)
' CORNER FAILJ ilb ll ',icc,jcc,
ibcoords(icc,jcc),ii,jj
329 if(ii .ne. icc .and. icc .ne. im+1 )
write(*,151)
' CORNER FAILI ilb ul ',icc,jcc,
ibcoords(icc,jcc),ii,jj
330 if( jj .ne. jcc )
write(*,151)
' CORNER FAILJ ilb ul ',icc,jcc,
ibcoords(icc,jcc),ii,jj
336 if(ii .ne. icc .and. icc .ne. im+1)
write(*,151)
' CORNER FAILI ilb uu ',icc,jcc,
ibcoords(icc,jcc),ii,jj
337 if( jj .ne. jcc )
write(*,151)
' CORNER FAILJ ilb ul ',icc,jcc,
ibcoords(icc,jcc),ii,jj
343 if(ii .ne. icc .and. icc .ne. 0 )
write(*,151)
' CORNER FAILI ilb lu ',icc,jcc,
ibcoords(icc,jcc),ii,jj
344 if( jj .ne. jcc )
write(*,151)
' CORNER FAILJ ilb ul ',icc,jcc,
ibcoords(icc,jcc),ii,jj
363 if(ii .ne. i .or. jj .ne. j)
write(*,151)
'GWVX FAILED IJ ',i,j,
ibcoords(i,j),ibl,jbl,ibu,jbu
367 151
format(a70,10i10)
376 if(ii .ne. i .or. jj .ne. j)
write(*,151)
'GWVX FAILEDI JBU IJ ',i,j,
ibcoords(i,j),ibl,jbl,ibu,jbu
383 if(ii .ne. i .or. jj .ne. j)
write(*,151)
'GWVX FAILEDI JBL IJ ',i,j,
ibcoords(i,j),ibl,jbl,ibu,jbu
392 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
399 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
402 if(me .eq. 0)
write(*,*)
' IFIRST CHECK'
408 if ( ierr /= 0 )
then
409 print *,
' problem with second sendrecv in exch, ierr = ',ierr
412 call mpi_barrier(mpi_comm_comp,ierr)