ROMS
Loading...
Searching...
No Matches
Functions/Subroutines
mp_exchange_mod Module Reference

Functions/Subroutines

subroutine tile_neighbors (ng, nghost, ew_periodic, ns_periodic, grecvw, gsendw, wtile, wexchange, grecve, gsende, etile, eexchange, grecvs, gsends, stile, sexchange, grecvn, gsendn, ntile, nexchange)
 
subroutine mp_exchange2d (ng, tile, model, nvar, lbi, ubi, lbj, ubj, nghost, ew_periodic, ns_periodic, a, b, c, d)
 
subroutine mp_exchange2d_bry (ng, tile, model, nvar, boundary, lbij, ubij, nghost, ew_periodic, ns_periodic, a, b, c, d)
 
subroutine mp_exchange3d (ng, tile, model, nvar, lbi, ubi, lbj, ubj, lbk, ubk, nghost, ew_periodic, ns_periodic, a, b, c, d)
 
subroutine mp_exchange3d_bry (ng, tile, model, nvar, boundary, lbij, ubij, lbk, ubk, nghost, ew_periodic, ns_periodic, a, b, c, d)
 
subroutine mp_exchange4d (ng, tile, model, nvar, lbi, ubi, lbj, ubj, lbk, ubk, lbt, ubt, nghost, ew_periodic, ns_periodic, a, b, c)
 
subroutine ad_mp_exchange2d (ng, tile, model, nvar, lbi, ubi, lbj, ubj, nghost, ew_periodic, ns_periodic, ad_a, ad_b, ad_c, ad_d)
 
subroutine ad_mp_exchange2d_bry (ng, tile, model, nvar, boundary, lbij, ubij, nghost, ew_periodic, ns_periodic, ad_a, ad_b, ad_c, ad_d)
 
subroutine ad_mp_exchange3d (ng, tile, model, nvar, lbi, ubi, lbj, ubj, lbk, ubk, nghost, ew_periodic, ns_periodic, ad_a, ad_b, ad_c, ad_d)
 
subroutine ad_mp_exchange3d_bry (ng, tile, model, nvar, boundary, lbij, ubij, lbk, ubk, nghost, ew_periodic, ns_periodic, ad_a, ad_b, ad_c, ad_d)
 
subroutine ad_mp_exchange4d (ng, tile, model, nvar, lbi, ubi, lbj, ubj, lbk, ubk, lbt, ubt, nghost, ew_periodic, ns_periodic, ad_a, ad_b, ad_c)
 

Function/Subroutine Documentation

◆ ad_mp_exchange2d()

subroutine mp_exchange_mod::ad_mp_exchange2d ( integer, intent(in) ng,
integer, intent(in) tile,
integer, intent(in) model,
integer, intent(in) nvar,
integer, intent(in) lbi,
integer, intent(in) ubi,
integer, intent(in) lbj,
integer, intent(in) ubj,
integer, intent(in) nghost,
logical, intent(in) ew_periodic,
logical, intent(in) ns_periodic,
real(r8), dimension(lbi:,lbj:), intent(inout) ad_a,
real(r8), dimension(lbi:,lbj:), intent(inout), optional ad_b,
real(r8), dimension(lbi:,lbj:), intent(inout), optional ad_c,
real(r8), dimension(lbi:,lbj:), intent(inout), optional ad_d )

Definition at line 4054 of file mp_exchange.F.

4058!***********************************************************************
4059!
4060 USE mod_param
4061 USE mod_parallel
4062 USE mod_iounits
4063 USE mod_scalars
4064!
4065 implicit none
4066!
4067! Imported variable declarations.
4068!
4069 logical, intent(in) :: EW_periodic, NS_periodic
4070!
4071 integer, intent(in) :: ng, tile, model, Nvar
4072 integer, intent(in) :: LBi, UBi, LBj, UBj
4073 integer, intent(in) :: Nghost
4074!
4075# ifdef ASSUMED_SHAPE
4076 real(r8), intent(inout) :: ad_A(LBi:,LBj:)
4077
4078 real(r8), intent(inout), optional :: ad_B(LBi:,LBj:)
4079 real(r8), intent(inout), optional :: ad_C(LBi:,LBj:)
4080 real(r8), intent(inout), optional :: ad_D(LBi:,LBj:)
4081# else
4082 real(r8), intent(inout) :: ad_A(LBi:UBi,LBj:UBj)
4083
4084 real(r8), intent(inout), optional :: ad_B(LBi:UBi,LBj:UBj)
4085 real(r8), intent(inout), optional :: ad_C(LBi:UBi,LBj:UBj)
4086 real(r8), intent(inout), optional :: ad_D(LBi:UBi,LBj:UBj)
4087# endif
4088!
4089! Local variable declarations.
4090!
4091 logical :: Wexchange, Sexchange, Eexchange, Nexchange
4092!
4093 integer :: i, icS, icN, ioff, Imin, Imax, Ilen
4094 integer :: j, jcW, jcE, joff, Jmin, Jmax, Jlen
4095 integer :: m, mc, Ierror, Lstr, pp
4096 integer :: Wtile, GsendW, GrecvW, Wtag, Werror, Wrequest
4097 integer :: Stile, GsendS, GrecvS, Stag, Serror, Srequest
4098 integer :: Etile, GsendE, GrecvE, Etag, Eerror, Erequest
4099 integer :: Ntile, GsendN, GrecvN, Ntag, Nerror, Nrequest
4100 integer :: BufferSizeEW, EWsize, sizeW, sizeE
4101 integer :: BufferSizeNS, NSsize, sizeS, sizeN
4102
4103# ifdef MPI
4104 integer, dimension(MPI_STATUS_SIZE,4) :: status
4105# endif
4106!
4107 real(r8), dimension(Nvar*HaloSizeJ(ng)) :: sendW, sendE
4108 real(r8), dimension(Nvar*HaloSizeJ(ng)) :: recvW, recvE
4109
4110 real(r8), dimension(Nvar*HaloSizeI(ng)) :: sendS, sendN
4111 real(r8), dimension(Nvar*HaloSizeI(ng)) :: recvS, recvN
4112!
4113 character (len=MPI_MAX_ERROR_STRING) :: string
4114
4115 character (len=*), parameter :: MyFile = &
4116 & __FILE__//", ad_mp_exchange2d"
4117
4118# include "set_bounds.h"
4119
4120# ifdef PROFILE
4121!
4122!-----------------------------------------------------------------------
4123! Turn on time clocks.
4124!-----------------------------------------------------------------------
4125!
4126 CALL wclock_on (ng, model, 60, __line__, myfile)
4127# endif
4128!
4129!-----------------------------------------------------------------------
4130! Determine rank of tile neighbors and number of ghost-points to
4131! exchange.
4132!-----------------------------------------------------------------------
4133!
4134! Maximum automatic buffer memory size in bytes.
4135!
4136 bmemmax(ng)=max(bmemmax(ng), real((4*SIZE(sendw)+ &
4137 & 4*SIZE(sends))*kind(ad_a),r8))
4138!
4139 CALL tile_neighbors (ng, nghost, ew_periodic, ns_periodic, &
4140 & grecvw, gsendw, wtile, wexchange, &
4141 & grecve, gsende, etile, eexchange, &
4142 & grecvs, gsends, stile, sexchange, &
4143 & grecvn, gsendn, ntile, nexchange)
4144!
4145! Set communication tags.
4146!
4147 wtag=1
4148 stag=2
4149 etag=3
4150 ntag=4
4151!
4152! Determine range and length of the distributed tile boundary segments.
4153!
4154 imin=lbi
4155 imax=ubi
4156 jmin=lbj
4157 jmax=ubj
4158 ilen=imax-imin+1
4159 jlen=jmax-jmin+1
4160 IF (ew_periodic.or.ns_periodic) THEN
4161 pp=1
4162 ELSE
4163 pp=0
4164 END IF
4165 nssize=nvar*(nghost+pp)*ilen
4166 ewsize=nvar*(nghost+pp)*jlen
4167 buffersizens=nvar*halosizei(ng)
4168 buffersizeew=nvar*halosizej(ng)
4169 IF (SIZE(sende).lt.ewsize) THEN
4170 WRITE (stdout,10) 'EWsize = ', ewsize, SIZE(sende)
4171 10 FORMAT (/,' AD_MP_EXCHANGE2D - communication buffer too', &
4172 & ' small, ',a, 2i8)
4173 END IF
4174 IF (SIZE(sendn).lt.nssize) THEN
4175 WRITE (stdout,10) 'NSsize = ', nssize, SIZE(sendn)
4176 END IF
4177!
4178!-----------------------------------------------------------------------
4179! Adjoint of unpacking Northern and Southern segments.
4180!-----------------------------------------------------------------------
4181!
4182 IF (nexchange) THEN
4183 DO i=1,buffersizens
4184 recvn(i)=0.0_r8
4185 sendn(i)=0.0_r8
4186 END DO
4187 sizen=0
4188 DO m=1,grecvn
4189 mc=(m-1)*ilen
4190 j=jend+m
4191 DO i=imin,imax
4192 sizen=sizen+1
4193 icn=1+(i-imin)+mc
4194!^ A(i,j)=recvN(icN)
4195!^
4196 recvn(icn)=ad_a(i,j)
4197 ad_a(i,j)=0.0_r8
4198 END DO
4199 END DO
4200 IF (PRESENT(ad_b)) THEN
4201 ioff=icn
4202 DO m=1,grecvn
4203 mc=(m-1)*ilen
4204 j=jend+m
4205 DO i=imin,imax
4206 sizen=sizen+1
4207 icn=ioff+1+(i-imin)+mc
4208!^ B(i,j)=recvN(icN)
4209!^
4210 recvn(icn)=ad_b(i,j)
4211 ad_b(i,j)=0.0_r8
4212 END DO
4213 END DO
4214 END IF
4215 IF (PRESENT(ad_c)) THEN
4216 ioff=icn
4217 DO m=1,grecvn
4218 mc=(m-1)*ilen
4219 j=jend+m
4220 DO i=imin,imax
4221 sizen=sizen+1
4222 icn=ioff+1+(i-imin)+mc
4223!^ C(i,j)=recvN(icN)
4224!^
4225 recvn(icn)=ad_c(i,j)
4226 ad_c(i,j)=0.0_r8
4227 END DO
4228 END DO
4229 END IF
4230 IF (PRESENT(ad_d)) THEN
4231 ioff=icn
4232 DO m=1,grecvn
4233 mc=(m-1)*ilen
4234 j=jend+m
4235 DO i=imin,imax
4236 sizen=sizen+1
4237 icn=ioff+1+(i-imin)+mc
4238!^ D(i,j)=recvN(icN)
4239!^
4240 recvn(icn)=ad_d(i,j)
4241 ad_d(i,j)=0.0_r8
4242 END DO
4243 END DO
4244 END IF
4245 END IF
4246!
4247 IF (sexchange) THEN
4248 DO i=1,buffersizens
4249 recvs(i)=0.0_r8
4250 sends(i)=0.0_r8
4251 END DO
4252 sizes=0
4253 DO m=grecvs,1,-1
4254 mc=(grecvs-m)*ilen
4255 j=jstr-m
4256 DO i=imin,imax
4257 sizes=sizes+1
4258 ics=1+(i-imin)+mc
4259!^ A(i,j)=recvS(icS)
4260!^
4261 recvs(ics)=ad_a(i,j)
4262 ad_a(i,j)=0.0_r8
4263 END DO
4264 END DO
4265 IF (PRESENT(ad_b)) THEN
4266 ioff=ics
4267 DO m=grecvs,1,-1
4268 mc=(grecvs-m)*ilen
4269 j=jstr-m
4270 DO i=imin,imax
4271 sizes=sizes+1
4272 ics=ioff+1+(i-imin)+mc
4273!^ B(i,j)=recvS(icS)
4274!^
4275 recvs(ics)=ad_b(i,j)
4276 ad_b(i,j)=0.0_r8
4277 END DO
4278 END DO
4279 END IF
4280 IF (PRESENT(ad_c)) THEN
4281 ioff=ics
4282 DO m=grecvs,1,-1
4283 mc=(grecvs-m)*ilen
4284 j=jstr-m
4285 DO i=imin,imax
4286 sizes=sizes+1
4287 ics=ioff+1+(i-imin)+mc
4288!^ C(i,j)=recvS(icS)
4289!^
4290 recvs(ics)=ad_c(i,j)
4291 ad_c(i,j)=0.0_r8
4292 END DO
4293 END DO
4294 END IF
4295 IF (PRESENT(ad_d)) THEN
4296 ioff=ics
4297 DO m=grecvs,1,-1
4298 mc=(grecvs-m)*ilen
4299 j=jstr-m
4300 DO i=imin,imax
4301 sizes=sizes+1
4302 ics=ioff+1+(i-imin)+mc
4303!^ D(i,j)=recvS(icS)
4304!^
4305 recvs(ics)=ad_d(i,j)
4306 ad_d(i,j)=0.0_r8
4307 END DO
4308 END DO
4309 END IF
4310 END IF
4311!
4312!-----------------------------------------------------------------------
4313! Adjoint of send and receive Southern and Northern segments.
4314!-----------------------------------------------------------------------
4315!
4316# if defined MPI
4317 IF (sexchange) THEN
4318!^ CALL mpi_irecv (recvS, NSsize, MP_FLOAT, Stile, Ntag, &
4319!^ & OCN_COMM_WORLD, Srequest, Serror)
4320!^
4321 CALL mpi_irecv (sends, nssize, mp_float, stile, ntag, &
4322 & ocn_comm_world, srequest, serror)
4323 END IF
4324 IF (nexchange) THEN
4325!^ CALL mpi_irecv (recvN, NSsize, MP_FLOAT, Ntile, Stag, &
4326!^ & OCN_COMM_WORLD, Nrequest, Nerror)
4327!^
4328 CALL mpi_irecv (sendn, nssize, mp_float, ntile, stag, &
4329 & ocn_comm_world, nrequest, nerror)
4330 END IF
4331 IF (sexchange) THEN
4332!^ CALL mpi_send (sendS, sizeS, MP_FLOAT, Stile, Stag, &
4333!^ & OCN_COMM_WORLD, Serror)
4334!^
4335 CALL mpi_send (recvs, sizes, mp_float, stile, stag, &
4336 & ocn_comm_world, serror)
4337 END IF
4338 IF (nexchange) THEN
4339!^ CALL mpi_send (sendN, sizeN, MP_FLOAT, Ntile, Ntag, &
4340!^ & OCN_COMM_WORLD, Nerror)
4341!^
4342 CALL mpi_send (recvn, sizen, mp_float, ntile, ntag, &
4343 & ocn_comm_world, nerror)
4344 END IF
4345# endif
4346!
4347! Adjoint of packing tile boundary data including ghost-points.
4348!
4349 IF (sexchange) THEN
4350# ifdef MPI
4351 CALL mpi_wait (srequest, status(1,2), serror)
4352 IF (serror.ne.mpi_success) THEN
4353 CALL mpi_error_string (serror, string, lstr, ierror)
4354 lstr=len_trim(string)
4355 WRITE (stdout,20) 'MPI_SEND/MPI_IRECV (Southern Edge)', &
4356 & myrank, serror, string(1:lstr)
4357 20 FORMAT (/,' AD_MP_EXCHANGE2D - error during ',a,' call,', &
4358 & ' Node = ', i3.3,' Error = ',i3,/,18x,a)
4359 exit_flag=2
4360 RETURN
4361 END IF
4362# endif
4363 DO m=1,gsends
4364 mc=(m-1)*ilen
4365 j=jstr+m-1
4366 DO i=imin,imax
4367 ics=1+(i-imin)+mc
4368!^ sendS(icS)=A(i,j)
4369!^
4370 ad_a(i,j)=ad_a(i,j)+sends(ics)
4371 sends(ics)=0.0_r8
4372 END DO
4373 END DO
4374 IF (PRESENT(ad_b)) THEN
4375 ioff=ics
4376 DO m=1,gsends
4377 mc=(m-1)*ilen
4378 j=jstr+m-1
4379 DO i=imin,imax
4380 ics=ioff+1+(i-imin)+mc
4381!^ sendS(icS)=B(i,j)
4382!^
4383 ad_b(i,j)=ad_b(i,j)+sends(ics)
4384 sends(ics)=0.0_r8
4385 END DO
4386 END DO
4387 END IF
4388 IF (PRESENT(ad_c)) THEN
4389 ioff=ics
4390 DO m=1,gsends
4391 mc=(m-1)*ilen
4392 j=jstr+m-1
4393 DO i=imin,imax
4394 ics=ioff+1+(i-imin)+mc
4395!^ sendS(icS)=C(i,j)
4396!^
4397 ad_c(i,j)=ad_c(i,j)+sends(ics)
4398 sends(ics)=0.0_r8
4399 END DO
4400 END DO
4401 END IF
4402 IF (PRESENT(ad_d)) THEN
4403 ioff=ics
4404 DO m=1,gsends
4405 mc=(m-1)*ilen
4406 j=jstr+m-1
4407 DO i=imin,imax
4408 ics=ioff+1+(i-imin)+mc
4409!^ sendS(icS)=D(i,j)
4410!^
4411 ad_d(i,j)=ad_d(i,j)+sends(ics)
4412 sends(ics)=0.0_r8
4413 END DO
4414 END DO
4415 END IF
4416 END IF
4417!
4418 IF (nexchange) THEN
4419# ifdef MPI
4420 CALL mpi_wait (nrequest, status(1,4), nerror)
4421 IF (nerror.ne.mpi_success) THEN
4422 CALL mpi_error_string (nerror, string, lstr, ierror)
4423 lstr=len_trim(string)
4424 WRITE (stdout,20) 'MPI_SEND/MPI_IRECV (Northern Edge)', &
4425 & myrank, nerror, string(1:lstr)
4426 exit_flag=2
4427 RETURN
4428 END IF
4429# endif
4430 DO m=1,gsendn
4431 mc=(m-1)*ilen
4432 j=jend-gsendn+m
4433 DO i=imin,imax
4434 icn=1+(i-imin)+mc
4435!^ sendN(icN)=A(i,j)
4436!^
4437 ad_a(i,j)=ad_a(i,j)+sendn(icn)
4438 sendn(icn)=0.0_r8
4439 END DO
4440 END DO
4441 IF (PRESENT(ad_b)) THEN
4442 ioff=icn
4443 DO m=1,gsendn
4444 mc=(m-1)*ilen
4445 j=jend-gsendn+m
4446 DO i=imin,imax
4447 icn=ioff+1+(i-imin)+mc
4448!^ sendN(icN)=B(i,j)
4449!^
4450 ad_b(i,j)=ad_b(i,j)+sendn(icn)
4451 sendn(icn)=0.0_r8
4452 END DO
4453 END DO
4454 END IF
4455 IF (PRESENT(ad_c)) THEN
4456 ioff=icn
4457 DO m=1,gsendn
4458 mc=(m-1)*ilen
4459 j=jend-gsendn+m
4460 DO i=imin,imax
4461 icn=ioff+1+(i-imin)+mc
4462!^ sendN(icN)=C(i,Jend-GsendN+m)
4463!^
4464 ad_c(i,j)=ad_c(i,j)+sendn(icn)
4465 sendn(icn)=0.0_r8
4466 END DO
4467 END DO
4468 END IF
4469 IF (PRESENT(ad_d)) THEN
4470 ioff=icn
4471 DO m=1,gsendn
4472 mc=(m-1)*ilen
4473 j=jend-gsendn+m
4474 DO i=imin,imax
4475 icn=ioff+1+(i-imin)+mc
4476!^ sendN(icN)=D(i,j)
4477!^
4478 ad_d(i,j)=ad_d(i,j)+sendn(icn)
4479 sendn(icn)=0.0_r8
4480 END DO
4481 END DO
4482 END IF
4483 END IF
4484!
4485!-----------------------------------------------------------------------
4486! Adjoint of unpack Eastern and Western segments.
4487!-----------------------------------------------------------------------
4488!
4489 IF (eexchange) THEN
4490 DO i=1,buffersizeew
4491 recve(i)=0.0_r8
4492 sende(i)=0.0_r8
4493 END DO
4494 sizee=0
4495 DO m=1,grecve
4496 mc=(m-1)*jlen
4497 i=iend+m
4498 DO j=jmin,jmax
4499 sizee=sizee+1
4500 jce=1+(j-jmin)+mc
4501!^ A(i,j)=recvE(jcE)
4502!^
4503 recve(jce)=ad_a(i,j)
4504 ad_a(i,j)=0.0_r8
4505 ENDDO
4506 END DO
4507 IF (PRESENT(ad_b)) THEN
4508 joff=jce
4509 DO m=1,grecve
4510 mc=(m-1)*jlen
4511 i=iend+m
4512 DO j=jmin,jmax
4513 sizee=sizee+1
4514 jce=joff+1+(j-jmin)+mc
4515!^ B(i,j)=recvE(jcE)
4516!^
4517 recve(jce)=ad_b(i,j)
4518 ad_b(i,j)=0.0_r8
4519 END DO
4520 END DO
4521 END IF
4522 IF (PRESENT(ad_c)) THEN
4523 joff=jce
4524 DO m=1,grecve
4525 mc=(m-1)*jlen
4526 i=iend+m
4527 DO j=jmin,jmax
4528 sizee=sizee+1
4529 jce=joff+1+(j-jmin)+mc
4530!^ C(i,j)=recvE(jcE)
4531!^
4532 recve(jce)=ad_c(i,j)
4533 ad_c(i,j)=0.0_r8
4534 END DO
4535 END DO
4536 END IF
4537 IF (PRESENT(ad_d)) THEN
4538 joff=jce
4539 DO m=1,grecve
4540 mc=(m-1)*jlen
4541 i=iend+m
4542 DO j=jmin,jmax
4543 sizee=sizee+1
4544 jce=joff+1+(j-jmin)+mc
4545!^ D(i,j)=recvE(jcE)
4546!^
4547 recve(jce)=ad_d(i,j)
4548 ad_d(i,j)=0.0_r8
4549 END DO
4550 END DO
4551 END IF
4552 END IF
4553!
4554 IF (wexchange) THEN
4555 DO i=1,buffersizeew
4556 recvw(i)=0.0_r8
4557 sendw(i)=0.0_r8
4558 END DO
4559 sizew=0
4560 DO m=grecvw,1,-1
4561 mc=(grecvw-m)*jlen
4562 i=istr-m
4563 DO j=jmin,jmax
4564 sizew=sizew+1
4565 jcw=1+(j-jmin)+mc
4566!^ A(i,j)=recvW(jcW)
4567!^
4568 recvw(jcw)=ad_a(i,j)
4569 ad_a(i,j)=0.0_r8
4570 END DO
4571 END DO
4572 IF (PRESENT(ad_b)) THEN
4573 joff=jcw
4574 DO m=grecvw,1,-1
4575 mc=(grecvw-m)*jlen
4576 i=istr-m
4577 DO j=jmin,jmax
4578 sizew=sizew+1
4579 jcw=joff+1+(j-jmin)+mc
4580!^ B(i,j)=recvW(jcW)
4581!^
4582 recvw(jcw)=ad_b(i,j)
4583 ad_b(i,j)=0.0_r8
4584 END DO
4585 END DO
4586 END IF
4587 IF (PRESENT(ad_c)) THEN
4588 joff=jcw
4589 DO m=grecvw,1,-1
4590 mc=(grecvw-m)*jlen
4591 i=istr-m
4592 DO j=jmin,jmax
4593 sizew=sizew+1
4594 jcw=joff+1+(j-jmin)+mc
4595!^ C(i,j)=recvW(jcW)
4596!^
4597 recvw(jcw)=ad_c(i,j)
4598 ad_c(i,j)=0.0_r8
4599 END DO
4600 END DO
4601 END IF
4602 IF (PRESENT(ad_d)) THEN
4603 joff=jcw
4604 DO m=grecvw,1,-1
4605 mc=(grecvw-m)*jlen
4606 i=istr-m
4607 DO j=jmin,jmax
4608 sizew=sizew+1
4609 jcw=joff+1+(j-jmin)+mc
4610!^ D(i,j)=recvW(jcW)
4611!^
4612 recvw(jcw)=ad_d(i,j)
4613 ad_d(i,j)=0.0_r8
4614 END DO
4615 END DO
4616 END IF
4617 END IF
4618!
4619!-----------------------------------------------------------------------
4620! Send and receive Western and Eastern segments.
4621!-----------------------------------------------------------------------
4622!
4623# if defined MPI
4624 IF (wexchange) THEN
4625!^ CALL mpi_irecv (recvW, EWsize, MP_FLOAT, Wtile, Etag, &
4626!^ & OCN_COMM_WORLD, Wrequest, Werror)
4627!^
4628 CALL mpi_irecv (sendw, ewsize, mp_float, wtile, etag, &
4629 & ocn_comm_world, wrequest, werror)
4630 END IF
4631 IF (eexchange) THEN
4632!^ CALL mpi_irecv (recvE, EWsize, MP_FLOAT, Etile, Wtag, &
4633!^ & OCN_COMM_WORLD, Erequest, Eerror)
4634!^
4635 CALL mpi_irecv (sende, ewsize, mp_float, etile, wtag, &
4636 & ocn_comm_world, erequest, eerror)
4637 END IF
4638 IF (wexchange) THEN
4639!^ CALL mpi_send (sendW, sizeW, MP_FLOAT, Wtile, Wtag, &
4640!^ & OCN_COMM_WORLD, Werror)
4641!^
4642 CALL mpi_send (recvw, sizew, mp_float, wtile, wtag, &
4643 & ocn_comm_world, werror)
4644 END IF
4645 IF (eexchange) THEN
4646!^ CALL mpi_send (sendE, sizeE, MP_FLOAT, Etile, Etag, &
4647!^ & OCN_COMM_WORLD, Eerror)
4648!^
4649 CALL mpi_send (recve, sizee, mp_float, etile, etag, &
4650 & ocn_comm_world, eerror)
4651 END IF
4652# endif
4653!
4654! Adjoint of packing tile boundary data including ghost-points.
4655!
4656 IF (wexchange) THEN
4657# ifdef MPI
4658 CALL mpi_wait (wrequest, status(1,1), werror)
4659 IF (werror.ne.mpi_success) THEN
4660 CALL mpi_error_string (werror, string, lstr, ierror)
4661 lstr=len_trim(string)
4662 WRITE (stdout,20) 'MPI_SEND/MPI_IRECV (Western Edge)', &
4663 & myrank, werror, string(1:lstr)
4664 exit_flag=2
4665 RETURN
4666 END IF
4667# endif
4668 DO m=1,gsendw
4669 mc=(m-1)*jlen
4670 i=istr+m-1
4671 DO j=jmin,jmax
4672 jcw=1+(j-jmin)+mc
4673!^ sendW(jcW)=A(i,j)
4674!^
4675 ad_a(i,j)=ad_a(i,j)+sendw(jcw)
4676 sendw(jcw)=0.0_r8
4677 END DO
4678 END DO
4679 IF (PRESENT(ad_b)) THEN
4680 joff=jcw
4681 DO m=1,gsendw
4682 mc=(m-1)*jlen
4683 i=istr+m-1
4684 DO j=jmin,jmax
4685 jcw=joff+1+(j-jmin)+mc
4686!^ sendW(jcW)=B(i,j)
4687!^
4688 ad_b(i,j)=ad_b(i,j)+sendw(jcw)
4689 sendw(jcw)=0.0_r8
4690 END DO
4691 END DO
4692 END IF
4693 IF (PRESENT(ad_c)) THEN
4694 joff=jcw
4695 DO m=1,gsendw
4696 mc=(m-1)*jlen
4697 i=istr+m-1
4698 DO j=jmin,jmax
4699 jcw=joff+1+(j-jmin)+mc
4700!^ sendW(jcW)=C(i,j)
4701!^
4702 ad_c(i,j)=ad_c(i,j)+sendw(jcw)
4703 sendw(jcw)=0.0_r8
4704 END DO
4705 END DO
4706 END IF
4707 IF (PRESENT(ad_d)) THEN
4708 joff=jcw
4709 DO m=1,gsendw
4710 mc=(m-1)*jlen
4711 i=istr+m-1
4712 DO j=jmin,jmax
4713 jcw=joff+1+(j-jmin)+mc
4714!^ sendW(jcW)=D(i,j)
4715!^
4716 ad_d(i,j)=ad_d(i,j)+sendw(jcw)
4717 sendw(jcw)=0.0_r8
4718 END DO
4719 END DO
4720 END IF
4721 END IF
4722!
4723 IF (eexchange) THEN
4724# ifdef MPI
4725 CALL mpi_wait (erequest, status(1,3), eerror)
4726 IF (eerror.ne.mpi_success) THEN
4727 CALL mpi_error_string (eerror, string, lstr, ierror)
4728 lstr=len_trim(string)
4729 WRITE (stdout,20) 'MPI_SEND/MPI_IRECV (Eastern Edge)', &
4730 & myrank, eerror, string(1:lstr)
4731 exit_flag=2
4732 RETURN
4733 END IF
4734# endif
4735 DO m=1,gsende
4736 mc=(m-1)*jlen
4737 i=iend-gsende+m
4738 DO j=jmin,jmax
4739 jce=1+(j-jmin)+mc
4740!^ sendE(jcE)=A(i,j)
4741!^
4742 ad_a(i,j)=ad_a(i,j)+sende(jce)
4743 sende(jce)=0.0_r8
4744 END DO
4745 END DO
4746 IF (PRESENT(ad_b)) THEN
4747 joff=jce
4748 DO m=1,gsende
4749 mc=(m-1)*jlen
4750 i=iend-gsende+m
4751 DO j=jmin,jmax
4752 jce=joff+1+(j-jmin)+mc
4753!^ sendE(jcE)=B(i,j)
4754!^
4755 ad_b(i,j)=ad_b(i,j)+sende(jce)
4756 sende(jce)=0.0_r8
4757 END DO
4758 END DO
4759 END IF
4760 IF (PRESENT(ad_c)) THEN
4761 joff=jce
4762 DO m=1,gsende
4763 mc=(m-1)*jlen
4764 i=iend-gsende+m
4765 DO j=jmin,jmax
4766 jce=joff+1+(j-jmin)+mc
4767!^ sendE(jcE)=C(i,j)
4768!^
4769 ad_c(i,j)=ad_c(i,j)+sende(jce)
4770 sende(jce)=0.0_r8
4771 END DO
4772 END DO
4773 END IF
4774 IF (PRESENT(ad_d)) THEN
4775 joff=jce
4776 DO m=1,gsende
4777 mc=(m-1)*jlen
4778 i=iend-gsende+m
4779 DO j=jmin,jmax
4780 jce=joff+1+(j-jmin)+mc
4781!^ sendE(jcE)=D(i,j)
4782!^
4783 ad_d(i,j)=ad_d(i,j)+sende(jce)
4784 sende(jce)=0.0_r8
4785 END DO
4786 END DO
4787 END IF
4788 END IF
4789
4790# ifdef PROFILE
4791!
4792!-----------------------------------------------------------------------
4793! Turn off time clocks.
4794!-----------------------------------------------------------------------
4795!
4796 CALL wclock_off (ng, model, 60, __line__, myfile)
4797# endif
4798!
4799 RETURN
mod_iounits
Definition mod_iounits.F:2
mod_iounits::stdout
integer stdout
Definition mod_iounits.F:195
mod_parallel
Definition mod_parallel.F:2
mod_parallel::mp_float
integer, parameter mp_float
Definition mod_parallel.F:189
mod_parallel::myrank
integer myrank
Definition mod_parallel.F:157
mod_parallel::ocn_comm_world
integer ocn_comm_world
Definition mod_parallel.F:178
mod_param
Definition mod_param.F:2
mod_param::halosizei
integer, dimension(:), allocatable halosizei
Definition mod_param.F:696
mod_param::halosizej
integer, dimension(:), allocatable halosizej
Definition mod_param.F:697
mod_param::bmemmax
real(r8), dimension(:), allocatable bmemmax
Definition mod_param.F:132
mod_scalars
Definition mod_scalars.F:2
mod_scalars::exit_flag
integer exit_flag
Definition mod_scalars.F:559
wclock_off
recursive subroutine wclock_off(ng, model, region, line, routine)
Definition timers.F:148
wclock_on
recursive subroutine wclock_on(ng, model, region, line, routine)
Definition timers.F:3

References mod_param::bmemmax, mod_scalars::exit_flag, mod_param::halosizei, mod_param::halosizej, mod_parallel::mp_float, mod_parallel::myrank, mod_parallel::ocn_comm_world, mod_iounits::stdout, tile_neighbors(), wclock_off(), and wclock_on().

Referenced by ad_balance_mod::ad_balance_tile(), zeta_balance_mod::ad_biconj_tile(), ad_bulk_flux_mod::ad_bulk_flux_tile(), ad_conv_2d_mod::ad_conv_r2d_tile(), ad_conv_2d_mod::ad_conv_u2d_tile(), ad_conv_2d_mod::ad_conv_v2d_tile(), ad_convolution_mod::ad_convolution_tile(), ad_nesting_mod::ad_fine2coarse(), ad_htobs_mod::ad_htobs_tile(), ad_ini_fields_mod::ad_ini_fields_tile(), ad_ini_fields_mod::ad_ini_zeta_tile(), ad_ini_fields_mod::ad_out_fields_tile(), ad_ini_fields_mod::ad_out_zeta_tile(), ad_pack_tile(), ad_nesting_mod::ad_put_composite(), ad_nesting_mod::ad_put_refine2d(), ad_rho_eos_mod::ad_rho_eos_tile(), ad_set_depth_mod::ad_set_depth_tile(), ad_obc_volcons_mod::ad_set_duv_bc_tile(), ad_set_vbc_mod::ad_set_vbc_tile(), ad_set_zeta_mod::ad_set_zeta_tile(), ad_ini_fields_mod::ad_set_zeta_timeavg_tile(), ad_step2d_mod::ad_step2d_tile(), ad_step2d_mod::ad_step2d_tile(), ad_step2d_mod::ad_step2d_tile(), ad_step3d_uv_mod::ad_step3d_uv_tile(), ad_variability_mod::ad_variability_tile(), ad_wvelocity_mod::ad_wvelocity_tile(), zeta_balance_mod::biconj_tile(), and zeta_balance_mod::tl_biconj_tile().

Here is the call graph for this function:
Here is the caller graph for this function:

◆ ad_mp_exchange2d_bry()

subroutine mp_exchange_mod::ad_mp_exchange2d_bry ( integer, intent(in) ng,
integer, intent(in) tile,
integer, intent(in) model,
integer, intent(in) nvar,
integer, intent(in) boundary,
integer, intent(in) lbij,
integer, intent(in) ubij,
integer, intent(in) nghost,
logical, intent(in) ew_periodic,
logical, intent(in) ns_periodic,
real(r8), dimension(lbij:), intent(inout) ad_a,
real(r8), dimension(lbij:), intent(inout), optional ad_b,
real(r8), dimension(lbij:), intent(inout), optional ad_c,
real(r8), dimension(lbij:), intent(inout), optional ad_d )

Definition at line 4804 of file mp_exchange.F.

4808!***********************************************************************
4809!
4810 USE mod_param
4811 USE mod_parallel
4812 USE mod_iounits
4813 USE mod_scalars
4814!
4815 implicit none
4816!
4817! Imported variable declarations.
4818!
4819 logical, intent(in) :: EW_periodic, NS_periodic
4820!
4821 integer, intent(in) :: ng, tile, model, Nvar, boundary
4822 integer, intent(in) :: LBij, UBij
4823 integer, intent(in) :: Nghost
4824!
4825# ifdef ASSUMED_SHAPE
4826 real(r8), intent(inout) :: ad_A(LBij:)
4827
4828 real(r8), intent(inout), optional :: ad_B(LBij:)
4829 real(r8), intent(inout), optional :: ad_C(LBij:)
4830 real(r8), intent(inout), optional :: ad_D(LBij:)
4831# else
4832 real(r8), intent(inout) :: ad_A(LBij:UBij)
4833
4834 real(r8), intent(inout), optional :: ad_B(LBij:UBij)
4835 real(r8), intent(inout), optional :: ad_C(LBij:UBij)
4836 real(r8), intent(inout), optional :: ad_D(LBij:UBij)
4837# endif
4838!
4839! Local variable declarations.
4840!
4841 logical :: Wexchange, Sexchange, Eexchange, Nexchange
4842!
4843 integer :: i, icS, icN
4844 integer :: j, jcW, jcE
4845 integer :: m, Ierror, Lstr, pp
4846 integer :: Wtile, GsendW, GrecvW, Wtag, Werror, Wrequest
4847 integer :: Stile, GsendS, GrecvS, Stag, Serror, Srequest
4848 integer :: Etile, GsendE, GrecvE, Etag, Eerror, Erequest
4849 integer :: Ntile, GsendN, GrecvN, Ntag, Nerror, Nrequest
4850 integer :: BufferSizeEW, EWsize, sizeW, sizeE
4851 integer :: BufferSizeNS, NSsize, sizeS, sizeN
4852
4853# ifdef MPI
4854 integer, dimension(MPI_STATUS_SIZE,4) :: status
4855# endif
4856!
4857 real(r8), dimension(Nvar*HaloBry(ng)) :: sendW, sendE
4858 real(r8), dimension(Nvar*HaloBry(ng)) :: recvW, recvE
4859
4860 real(r8), dimension(Nvar*HaloBry(ng)) :: sendS, sendN
4861 real(r8), dimension(Nvar*HaloBry(ng)) :: recvS, recvN
4862!
4863 character (len=MPI_MAX_ERROR_STRING) :: string
4864
4865 character (len=*), parameter :: MyFile = &
4866 & __FILE__//", ad_mp_exchange2d_bry"
4867
4868# include "set_bounds.h"
4869
4870# ifdef PROFILE
4871!
4872!-----------------------------------------------------------------------
4873! Turn on time clocks.
4874!-----------------------------------------------------------------------
4875!
4876 CALL wclock_on (ng, model, 63, __line__, myfile)
4877# endif
4878!
4879!-----------------------------------------------------------------------
4880! Determine rank of tile neighbors and number of ghost-points to
4881! exchange.
4882!-----------------------------------------------------------------------
4883!
4884! Maximum automatic buffer memory size in bytes.
4885!
4886 bmemmax(ng)=max(bmemmax(ng), real((4*SIZE(sendw)+ &
4887 & 4*SIZE(sends))*kind(ad_a),r8))
4888!
4889 CALL tile_neighbors (ng, nghost, ew_periodic, ns_periodic, &
4890 & grecvw, gsendw, wtile, wexchange, &
4891 & grecve, gsende, etile, eexchange, &
4892 & grecvs, gsends, stile, sexchange, &
4893 & grecvn, gsendn, ntile, nexchange)
4894!
4895! Adjust exchange swiches according to boundary edge to process.
4896!
4897 wexchange=wexchange.and.((boundary.eq.isouth).or. &
4898 & (boundary.eq.inorth))
4899 eexchange=eexchange.and.((boundary.eq.isouth).or. &
4900 & (boundary.eq.inorth))
4901 sexchange=sexchange.and.((boundary.eq.iwest).or. &
4902 & (boundary.eq.ieast))
4903 nexchange=nexchange.and.((boundary.eq.iwest).or. &
4904 & (boundary.eq.ieast))
4905!
4906! Set communication tags.
4907!
4908 wtag=1
4909 stag=2
4910 etag=3
4911 ntag=4
4912!
4913! Determine range and length of the distributed tile boundary segments.
4914!
4915 IF (ew_periodic.or.ns_periodic) THEN
4916 pp=1
4917 ELSE
4918 pp=0
4919 END IF
4920 nssize=nvar*(nghost+pp)
4921 ewsize=nvar*(nghost+pp)
4922 buffersizens=nvar*(nghost+pp)
4923 buffersizeew=nvar*(nghost+pp)
4924 IF (SIZE(sende).lt.ewsize) THEN
4925 WRITE (stdout,10) 'EWsize = ', ewsize, SIZE(sende)
4926 10 FORMAT (/,' AD_MP_EXCHANGE2D_BRY - communication buffer too', &
4927 & ' small, ',a, 2i8)
4928 END IF
4929 IF (SIZE(sendn).lt.nssize) THEN
4930 WRITE (stdout,10) 'NSsize = ', nssize, SIZE(sendn)
4931 END IF
4932!
4933!-----------------------------------------------------------------------
4934! Adjoint of unpacking Northern and Southern segments.
4935!-----------------------------------------------------------------------
4936!
4937 IF (nexchange) THEN
4938 DO i=1,buffersizens
4939 recvn(i)=0.0_r8
4940 sendn(i)=0.0_r8
4941 END DO
4942 icn=0
4943 sizen=0
4944 DO m=1,grecvn
4945 j=jend+m
4946 sizen=sizen+1
4947 icn=icn+1
4948!^ A(j)=recvN(icN)
4949!^
4950 recvn(icn)=ad_a(j)
4951 ad_a(j)=0.0_r8
4952 END DO
4953 IF (PRESENT(ad_b)) THEN
4954 DO m=1,grecvn
4955 j=jend+m
4956 sizen=sizen+1
4957 icn=icn+1
4958!^ B(j)=recvN(icN)
4959!^
4960 recvn(icn)=ad_b(j)
4961 ad_b(j)=0.0_r8
4962 END DO
4963 END IF
4964 IF (PRESENT(ad_c)) THEN
4965 DO m=1,grecvn
4966 j=jend+m
4967 sizen=sizen+1
4968 icn=icn+1
4969!^ C(j)=recvN(icN)
4970!^
4971 recvn(icn)=ad_c(j)
4972 ad_c(j)=0.0_r8
4973 END DO
4974 END IF
4975 IF (PRESENT(ad_d)) THEN
4976 DO m=1,grecvn
4977 j=jend+m
4978 sizen=sizen+1
4979 icn=icn+1
4980!^ D(j)=recvN(icN)
4981!^
4982 recvn(icn)=ad_d(j)
4983 ad_d(j)=0.0_r8
4984 END DO
4985 END IF
4986 END IF
4987!
4988 IF (sexchange) THEN
4989 DO i=1,buffersizens
4990 recvs(i)=0.0_r8
4991 sends(i)=0.0_r8
4992 END DO
4993 ics=0
4994 sizes=0
4995 DO m=grecvs,1,-1
4996 j=jstr-m
4997 sizes=sizes+1
4998 ics=ics+1
4999!^ A(j)=recvS(icS)
5000!^
5001 recvs(ics)=ad_a(j)
5002 ad_a(j)=0.0_r8
5003 END DO
5004 IF (PRESENT(ad_b)) THEN
5005 DO m=grecvs,1,-1
5006 j=jstr-m
5007 sizes=sizes+1
5008 ics=ics+1
5009!^ B(j)=recvS(icS)
5010!^
5011 recvs(ics)=ad_b(j)
5012 ad_b(j)=0.0_r8
5013 END DO
5014 END IF
5015 IF (PRESENT(ad_c)) THEN
5016 DO m=grecvs,1,-1
5017 j=jstr-m
5018 sizes=sizes+1
5019 ics=ics+1
5020!^ C(j)=recvS(icS)
5021!^
5022 recvs(ics)=ad_c(j)
5023 ad_c(j)=0.0_r8
5024 END DO
5025 END IF
5026 IF (PRESENT(ad_d)) THEN
5027 DO m=grecvs,1,-1
5028 j=jstr-m
5029 sizes=sizes+1
5030 ics=ics+1
5031!^ D(j)=recvS(icS)
5032!^
5033 recvs(ics)=ad_d(j)
5034 ad_d(j)=0.0_r8
5035 END DO
5036 END IF
5037 END IF
5038!
5039!-----------------------------------------------------------------------
5040! Adjoint of send and receive Southern and Northern segments.
5041!-----------------------------------------------------------------------
5042!
5043# if defined MPI
5044 IF (sexchange) THEN
5045!^ CALL mpi_irecv (recvS, NSsize, MP_FLOAT, Stile, Ntag, &
5046!^ & OCN_COMM_WORLD, Srequest, Serror)
5047!^
5048 CALL mpi_irecv (sends, nssize, mp_float, stile, ntag, &
5049 & ocn_comm_world, srequest, serror)
5050 END IF
5051 IF (nexchange) THEN
5052!^ CALL mpi_irecv (recvN, NSsize, MP_FLOAT, Ntile, Stag, &
5053!^ & OCN_COMM_WORLD, Nrequest, Nerror)
5054!^
5055 CALL mpi_irecv (sendn, nssize, mp_float, ntile, stag, &
5056 & ocn_comm_world, nrequest, nerror)
5057 END IF
5058 IF (sexchange) THEN
5059!^ CALL mpi_send (sendS, sizeS, MP_FLOAT, Stile, Stag, &
5060!^ & OCN_COMM_WORLD, Serror)
5061!^
5062 CALL mpi_send (recvs, sizes, mp_float, stile, stag, &
5063 & ocn_comm_world, serror)
5064 END IF
5065 IF (nexchange) THEN
5066!^ CALL mpi_send (sendN, sizeN, MP_FLOAT, Ntile, Ntag, &
5067!^ & OCN_COMM_WORLD, Nerror)
5068!^
5069 CALL mpi_send (recvn, sizen, mp_float, ntile, ntag, &
5070 & ocn_comm_world, nerror)
5071 END IF
5072# endif
5073!
5074! Adjoint of packing tile boundary data including ghost-points.
5075!
5076 IF (sexchange) THEN
5077# ifdef MPI
5078 CALL mpi_wait (srequest, status(1,2), serror)
5079 IF (serror.ne.mpi_success) THEN
5080 CALL mpi_error_string (serror, string, lstr, ierror)
5081 lstr=len_trim(string)
5082 WRITE (stdout,20) 'MPI_SEND/MPI_IRECV (Southern Edge)', &
5083 & myrank, serror, string(1:lstr)
5084 20 FORMAT (/,' AD_MP_EXCHANGE2D_BRY - error during ',a,' call,', &
5085 & ' Node = ', i3.3,' Error = ',i3,/,18x,a)
5086 exit_flag=2
5087 RETURN
5088 END IF
5089# endif
5090 ics=0
5091 DO m=1,gsends
5092 j=jstr+m-1
5093 ics=ics+1
5094!^ sendS(icS)=A(j)
5095!^
5096 ad_a(j)=ad_a(j)+sends(ics)
5097 sends(ics)=0.0_r8
5098 END DO
5099 IF (PRESENT(ad_b)) THEN
5100 DO m=1,gsends
5101 j=jstr+m-1
5102 ics=ics+1
5103!^ sendS(icS)=B(j)
5104!^
5105 ad_b(j)=ad_b(j)+sends(ics)
5106 sends(ics)=0.0_r8
5107 END DO
5108 END IF
5109 IF (PRESENT(ad_c)) THEN
5110 DO m=1,gsends
5111 j=jstr+m-1
5112 ics=ics+1
5113!^ sendS(icS)=C(j)
5114!^
5115 ad_c(j)=ad_c(j)+sends(ics)
5116 sends(ics)=0.0_r8
5117 END DO
5118 END IF
5119 IF (PRESENT(ad_d)) THEN
5120 DO m=1,gsends
5121 j=jstr+m-1
5122 ics=ics+1
5123!^ sendS(icS)=D(j)
5124!^
5125 ad_d(j)=ad_d(j)+sends(ics)
5126 sends(ics)=0.0_r8
5127 END DO
5128 END IF
5129 END IF
5130!
5131 IF (nexchange) THEN
5132# ifdef MPI
5133 CALL mpi_wait (nrequest, status(1,4), nerror)
5134 IF (nerror.ne.mpi_success) THEN
5135 CALL mpi_error_string (nerror, string, lstr, ierror)
5136 lstr=len_trim(string)
5137 WRITE (stdout,20) 'MPI_SEND/MPI_IRECV (Northern Edge)', &
5138 & myrank, nerror, string(1:lstr)
5139 exit_flag=2
5140 RETURN
5141 END IF
5142# endif
5143 icn=0
5144 DO m=1,gsendn
5145 j=jend-gsendn+m
5146 icn=icn+1
5147!^ sendN(icN)=A(j)
5148!^
5149 ad_a(j)=ad_a(j)+sendn(icn)
5150 sendn(icn)=0.0_r8
5151 END DO
5152 IF (PRESENT(ad_b)) THEN
5153 DO m=1,gsendn
5154 j=jend-gsendn+m
5155 icn=icn+1
5156!^ sendN(icN)=B(j)
5157!^
5158 ad_b(j)=ad_b(j)+sendn(icn)
5159 sendn(icn)=0.0_r8
5160 END DO
5161 END IF
5162 IF (PRESENT(ad_c)) THEN
5163 DO m=1,gsendn
5164 j=jend-gsendn+m
5165 icn=icn+1
5166!^ sendN(icN)=C(j)
5167!^
5168 ad_c(j)=ad_c(j)+sendn(icn)
5169 sendn(icn)=0.0_r8
5170 END DO
5171 END IF
5172 IF (PRESENT(ad_d)) THEN
5173 DO m=1,gsendn
5174 j=jend-gsendn+m
5175 icn=icn+1
5176!^ sendN(icN)=D(j)
5177!^
5178 ad_d(j)=ad_d(j)+sendn(icn)
5179 sendn(icn)=0.0_r8
5180 END DO
5181 END IF
5182 END IF
5183!
5184!-----------------------------------------------------------------------
5185! Adjoint of unpack Eastern and Western segments.
5186!-----------------------------------------------------------------------
5187!
5188 IF (eexchange) THEN
5189 DO i=1,buffersizeew
5190 recve(i)=0.0_r8
5191 sende(i)=0.0_r8
5192 END DO
5193 jce=0
5194 sizee=0
5195 DO m=1,grecve
5196 i=iend+m
5197 sizee=sizee+1
5198 jce=jce+1
5199!^ A(i)=recvE(jcE)
5200!^
5201 recve(jce)=ad_a(i)
5202 ad_a(i)=0.0_r8
5203 END DO
5204 IF (PRESENT(ad_b)) THEN
5205 DO m=1,grecve
5206 i=iend+m
5207 sizee=sizee+1
5208 jce=jce+1
5209!^ B(i)=recvE(jcE)
5210!^
5211 recve(jce)=ad_b(i)
5212 ad_b(i)=0.0_r8
5213 END DO
5214 END IF
5215 IF (PRESENT(ad_c)) THEN
5216 DO m=1,grecve
5217 i=iend+m
5218 sizee=sizee+1
5219 jce=jce+1
5220!^ C(i)=recvE(jcE)
5221!^
5222 recve(jce)=ad_c(i)
5223 ad_c(i)=0.0_r8
5224 END DO
5225 END IF
5226 IF (PRESENT(ad_d)) THEN
5227 DO m=1,grecve
5228 i=iend+m
5229 sizee=sizee+1
5230 jce=jce+1
5231!^ D(i)=recvE(jcE)
5232!^
5233 recve(jce)=ad_d(i)
5234 ad_d(i)=0.0_r8
5235 END DO
5236 END IF
5237 END IF
5238!
5239 IF (wexchange) THEN
5240 DO i=1,buffersizeew
5241 recvw(i)=0.0_r8
5242 sendw(i)=0.0_r8
5243 END DO
5244 jcw=0
5245 sizew=0
5246 DO m=grecvw,1,-1
5247 i=istr-m
5248 sizew=sizew+1
5249 jcw=jcw+1
5250!^ A(i)=recvW(jcW)
5251!^
5252 recvw(jcw)=ad_a(i)
5253 ad_a(i)=0.0_r8
5254 END DO
5255 IF (PRESENT(ad_b)) THEN
5256 DO m=grecvw,1,-1
5257 i=istr-m
5258 sizew=sizew+1
5259 jcw=jcw+1
5260!^ B(i)=recvW(jcW)
5261!^
5262 recvw(jcw)=ad_b(i)
5263 ad_b(i)=0.0_r8
5264 END DO
5265 END IF
5266 IF (PRESENT(ad_c)) THEN
5267 DO m=grecvw,1,-1
5268 i=istr-m
5269 sizew=sizew+1
5270 jcw=jcw+1
5271!^ C(i)=recvW(jcW)
5272!^
5273 recvw(jcw)=ad_c(i)
5274 ad_c(i)=0.0_r8
5275 END DO
5276 END IF
5277 IF (PRESENT(ad_d)) THEN
5278 DO m=grecvw,1,-1
5279 i=istr-m
5280 sizew=sizew+1
5281 jcw=jcw+1
5282!^ D(i)=recvW(jcW)
5283!^
5284 recvw(jcw)=ad_d(i)
5285 ad_d(i)=0.0_r8
5286 END DO
5287 END IF
5288 END IF
5289!
5290!-----------------------------------------------------------------------
5291! Send and receive Western and Eastern segments.
5292!-----------------------------------------------------------------------
5293!
5294# if defined MPI
5295 IF (wexchange) THEN
5296!^ CALL mpi_irecv (recvW, EWsize, MP_FLOAT, Wtile, Etag, &
5297!^ & OCN_COMM_WORLD, Wrequest, Werror)
5298!^
5299 CALL mpi_irecv (sendw, ewsize, mp_float, wtile, etag, &
5300 & ocn_comm_world, wrequest, werror)
5301 END IF
5302 IF (eexchange) THEN
5303!^ CALL mpi_irecv (recvE, EWsize, MP_FLOAT, Etile, Wtag, &
5304!^ & OCN_COMM_WORLD, Erequest, Eerror)
5305!^
5306 CALL mpi_irecv (sende, ewsize, mp_float, etile, wtag, &
5307 & ocn_comm_world, erequest, eerror)
5308 END IF
5309 IF (wexchange) THEN
5310!^ CALL mpi_send (sendW, sizeW, MP_FLOAT, Wtile, Wtag, &
5311!^ & OCN_COMM_WORLD, Werror)
5312!^
5313 CALL mpi_send (recvw, sizew, mp_float, wtile, wtag, &
5314 & ocn_comm_world, werror)
5315 END IF
5316 IF (eexchange) THEN
5317!^ CALL mpi_send (sendE, sizeE, MP_FLOAT, Etile, Etag, &
5318!^ & OCN_COMM_WORLD, Eerror)
5319!^
5320 CALL mpi_send (recve, sizee, mp_float, etile, etag, &
5321 & ocn_comm_world, eerror)
5322 END IF
5323# endif
5324!
5325! Adjoint of packing tile boundary data including ghost-points.
5326!
5327 IF (wexchange) THEN
5328# ifdef MPI
5329 CALL mpi_wait (wrequest, status(1,1), werror)
5330 IF (werror.ne.mpi_success) THEN
5331 CALL mpi_error_string (werror, string, lstr, ierror)
5332 lstr=len_trim(string)
5333 WRITE (stdout,20) 'MPI_SEND/MPI_IRECV (Western Edge)', &
5334 & myrank, werror, string(1:lstr)
5335 exit_flag=2
5336 RETURN
5337 END IF
5338# endif
5339 jcw=0
5340 DO m=1,gsendw
5341 i=istr+m-1
5342 jcw=jcw+1
5343!^ sendW(jcW)=A(i)
5344!^
5345 ad_a(i)=ad_a(i)+sendw(jcw)
5346 sendw(jcw)=0.0_r8
5347 END DO
5348 IF (PRESENT(ad_b)) THEN
5349 DO m=1,gsendw
5350 i=istr+m-1
5351 jcw=jcw+1
5352!^ sendW(jcW)=B(i)
5353!^
5354 ad_b(i)=ad_b(i)+sendw(jcw)
5355 sendw(jcw)=0.0_r8
5356 END DO
5357 END IF
5358 IF (PRESENT(ad_c)) THEN
5359 DO m=1,gsendw
5360 i=istr+m-1
5361 jcw=jcw+1
5362!^ sendW(jcW)=C(i)
5363!^
5364 ad_c(i)=ad_c(i)+sendw(jcw)
5365 sendw(jcw)=0.0_r8
5366 END DO
5367 END IF
5368 IF (PRESENT(ad_d)) THEN
5369 DO m=1,gsendw
5370 i=istr+m-1
5371 jcw=jcw+1
5372!^ sendW(jcW)=D(i)
5373!^
5374 ad_d(i)=ad_d(i)+sendw(jcw)
5375 sendw(jcw)=0.0_r8
5376 END DO
5377 END IF
5378 END IF
5379!
5380 IF (eexchange) THEN
5381# ifdef MPI
5382 CALL mpi_wait (erequest, status(1,3), eerror)
5383 IF (eerror.ne.mpi_success) THEN
5384 CALL mpi_error_string (eerror, string, lstr, ierror)
5385 lstr=len_trim(string)
5386 WRITE (stdout,20) 'MPI_SEND/MPI_IRECV (Eastern Edge)', &
5387 & myrank, eerror, string(1:lstr)
5388 exit_flag=2
5389 RETURN
5390 END IF
5391# endif
5392 jce=0
5393 DO m=1,gsende
5394 i=iend-gsende+m
5395 jce=jce+1
5396!^ sendE(jcE)=A(i)
5397!^
5398 ad_a(i)=ad_a(i)+sende(jce)
5399 sende(jce)=0.0_r8
5400 END DO
5401 IF (PRESENT(ad_b)) THEN
5402 DO m=1,gsende
5403 i=iend-gsende+m
5404 jce=jce+1
5405!^ sendE(jcE)=B(i)
5406!^
5407 ad_b(i)=ad_b(i)+sende(jce)
5408 sende(jce)=0.0_r8
5409 END DO
5410 END IF
5411 IF (PRESENT(ad_c)) THEN
5412 DO m=1,gsende
5413 i=iend-gsende+m
5414 jce=jce+1
5415!^ sendE(jcE)=C(i)
5416!^
5417 ad_c(i)=ad_c(i)+sende(jce)
5418 sende(jce)=0.0_r8
5419 END DO
5420 END IF
5421 IF (PRESENT(ad_d)) THEN
5422 DO m=1,gsende
5423 i=iend-gsende+m
5424 jce=jce+1
5425!^ sendE(jcE)=D(i)
5426!^
5427 ad_d(i)=ad_d(i)+sende(jce)
5428 sende(jce)=0.0_r8
5429 END DO
5430 END IF
5431 END IF
5432
5433# ifdef PROFILE
5434!
5435!-----------------------------------------------------------------------
5436! Turn off time clocks.
5437!-----------------------------------------------------------------------
5438!
5439 CALL wclock_off (ng, model, 63, __line__, myfile)
5440# endif
5441!
5442 RETURN
mod_scalars::iwest
integer, parameter iwest
Definition mod_scalars.F:1432
mod_scalars::isouth
integer, parameter isouth
Definition mod_scalars.F:1433
mod_scalars::ieast
integer, parameter ieast
Definition mod_scalars.F:1434
mod_scalars::inorth
integer, parameter inorth
Definition mod_scalars.F:1435

References mod_param::bmemmax, mod_scalars::exit_flag, mod_scalars::ieast, mod_scalars::inorth, mod_scalars::isouth, mod_scalars::iwest, mod_parallel::mp_float, mod_parallel::myrank, mod_parallel::ocn_comm_world, mod_iounits::stdout, tile_neighbors(), wclock_off(), and wclock_on().

Referenced by ad_conv_bry2d_mod::ad_conv_r2d_bry_tile(), ad_conv_bry2d_mod::ad_conv_u2d_bry_tile(), ad_conv_bry2d_mod::ad_conv_v2d_bry_tile(), ad_convolution_mod::ad_convolution_tile(), and ad_variability_mod::ad_variability_tile().

Here is the call graph for this function:
Here is the caller graph for this function:

◆ ad_mp_exchange3d()

subroutine mp_exchange_mod::ad_mp_exchange3d ( integer, intent(in) ng,
integer, intent(in) tile,
integer, intent(in) model,
integer, intent(in) nvar,
integer, intent(in) lbi,
integer, intent(in) ubi,
integer, intent(in) lbj,
integer, intent(in) ubj,
integer, intent(in) lbk,
integer, intent(in) ubk,
integer, intent(in) nghost,
logical, intent(in) ew_periodic,
logical, intent(in) ns_periodic,
real(r8), dimension(lbi:,lbj:,lbk:), intent(inout) ad_a,
real(r8), dimension(lbi:,lbj:,lbk:), intent(inout), optional ad_b,
real(r8), dimension(lbi:,lbj:,lbk:), intent(inout), optional ad_c,
real(r8), dimension(lbi:,lbj:,lbk:), intent(inout), optional ad_d )

Definition at line 5447 of file mp_exchange.F.

5451!***********************************************************************
5452!
5453 USE mod_param
5454 USE mod_parallel
5455 USE mod_iounits
5456 USE mod_scalars
5457!
5458 implicit none
5459!
5460! Imported variable declarations.
5461!
5462 logical, intent(in) :: EW_periodic, NS_periodic
5463!
5464 integer, intent(in) :: ng, tile, model, Nvar
5465 integer, intent(in) :: LBi, UBi, LBj, UBj, LBk, UBk
5466 integer, intent(in) :: Nghost
5467!
5468# ifdef ASSUMED_SHAPE
5469 real(r8), intent(inout) :: ad_A(LBi:,LBj:,LBk:)
5470
5471 real(r8), intent(inout), optional :: ad_B(LBi:,LBj:,LBk:)
5472 real(r8), intent(inout), optional :: ad_C(LBi:,LBj:,LBk:)
5473 real(r8), intent(inout), optional :: ad_D(LBi:,LBj:,LBk:)
5474# else
5475 real(r8), intent(inout) :: ad_A(LBi:UBi,LBj:UBj,LBk:UBk)
5476
5477 real(r8), intent(inout), optional :: ad_B(LBi:UBi,LBj:UBj,LBk:UBk)
5478 real(r8), intent(inout), optional :: ad_C(LBi:UBi,LBj:UBj,LBk:UBk)
5479 real(r8), intent(inout), optional :: ad_D(LBi:UBi,LBj:UBj,LBk:UBk)
5480# endif
5481!
5482! Local variable declarations.
5483!
5484 logical :: Wexchange, Sexchange, Eexchange, Nexchange
5485!
5486 integer :: i, ikS, ikN, ioff, Imin, Imax, Ilen, IKlen
5487 integer :: j, jkW, jkE, joff, Jmin, Jmax, Jlen, JKlen
5488 integer :: k, kc, m, mc, Ierror, Klen, Lstr, pp
5489 integer :: Wtile, GsendW, GrecvW, Wtag, Werror, Wrequest
5490 integer :: Stile, GsendS, GrecvS, Stag, Serror, Srequest
5491 integer :: Etile, GsendE, GrecvE, Etag, Eerror, Erequest
5492 integer :: Ntile, GsendN, GrecvN, Ntag, Nerror, Nrequest
5493 integer :: BufferSizeEW, EWsize, sizeW, sizeE
5494 integer :: BufferSizeNS, NSsize, sizeS, sizeN
5495
5496# ifdef MPI
5497 integer, dimension(MPI_STATUS_SIZE,4) :: status
5498# endif
5499!
5500 real(r8), dimension(Nvar*HaloSizeJ(ng)* & & (UBk-LBk+1)) :: sendW, sendE
5501 real(r8), dimension(Nvar*HaloSizeI(ng)* & & (UBk-LBk+1)) :: sendS, sendN
5502
5503 real(r8), dimension(Nvar*HaloSizeJ(ng)* & & (UBk-LBk+1)) :: recvW, recvE
5504 real(r8), dimension(Nvar*HaloSizeI(ng)* & & (UBk-LBk+1)) :: recvS, recvN
5505!
5506 character (len=MPI_MAX_ERROR_STRING) :: string
5507
5508 character (len=*), parameter :: MyFile = &
5509 & __FILE__//", ad_mp_exchange3d"
5510
5511# include "set_bounds.h"
5512
5513# ifdef PROFILE
5514!
5515!-----------------------------------------------------------------------
5516! Turn on time clocks.
5517!-----------------------------------------------------------------------
5518!
5519 CALL wclock_on (ng, model, 61, __line__, myfile)
5520# endif
5521!
5522!-----------------------------------------------------------------------
5523! Determine rank of tile neighbors and number of ghost-points to
5524! exchange.
5525!-----------------------------------------------------------------------
5526!
5527! Maximum automatic buffer memory size in bytes.
5528!
5529 bmemmax(ng)=max(bmemmax(ng), real((4*SIZE(sendw)+ &
5530 & 4*SIZE(sends))*kind(ad_a),r8))
5531!
5532 CALL tile_neighbors (ng, nghost, ew_periodic, ns_periodic, &
5533 & grecvw, gsendw, wtile, wexchange, &
5534 & grecve, gsende, etile, eexchange, &
5535 & grecvs, gsends, stile, sexchange, &
5536 & grecvn, gsendn, ntile, nexchange)
5537!
5538! Set communication tags.
5539!
5540 wtag=1
5541 stag=2
5542 etag=3
5543 ntag=4
5544!
5545! Determine range and length of the distributed tile boundary segments.
5546!
5547 imin=lbi
5548 imax=ubi
5549 jmin=lbj
5550 jmax=ubj
5551 ilen=imax-imin+1
5552 jlen=jmax-jmin+1
5553 klen=ubk-lbk+1
5554 iklen=ilen*klen
5555 jklen=jlen*klen
5556 IF (ew_periodic.or.ns_periodic) THEN
5557 pp=1
5558 ELSE
5559 pp=0
5560 END IF
5561 nssize=nvar*(nghost+pp)*iklen
5562 ewsize=nvar*(nghost+pp)*jklen
5563 buffersizens=nvar*halosizei(ng)*klen
5564 buffersizeew=nvar*halosizej(ng)*klen
5565 IF (SIZE(sende).lt.ewsize) THEN
5566 WRITE (stdout,10) 'EWsize = ', ewsize, SIZE(sende)
5567 10 FORMAT (/,' AD_MP_EXCHANGE3D - communication buffer too', &
5568 & ' small, ',a, 2i8)
5569 END IF
5570 IF (SIZE(sendn).lt.nssize) THEN
5571 WRITE (stdout,10) 'NSsize = ', nssize, SIZE(sendn)
5572 END IF
5573!
5574!-----------------------------------------------------------------------
5575! Adjoint of unpacking Northern and Southern segments.
5576!-----------------------------------------------------------------------
5577!
5578 IF (nexchange) THEN
5579 DO i=1,buffersizens
5580 recvn(i)=0.0_r8
5581 sendn(i)=0.0_r8
5582 END DO
5583 sizen=0
5584 DO m=1,grecvn
5585 mc=(m-1)*iklen
5586 j=jend+m
5587 DO k=lbk,ubk
5588 kc=(k-lbk)*ilen+mc
5589 DO i=imin,imax
5590 sizen=sizen+1
5591 ikn=1+(i-imin)+kc
5592!^ A(i,j,k)=recvN(ikN)
5593!^
5594 recvn(ikn)=ad_a(i,j,k)
5595 ad_a(i,j,k)=0.0_r8
5596 END DO
5597 END DO
5598 END DO
5599 IF (PRESENT(ad_b)) THEN
5600 ioff=ikn
5601 DO m=1,grecvn
5602 mc=(m-1)*iklen
5603 j=jend+m
5604 DO k=lbk,ubk
5605 kc=(k-lbk)*ilen+mc
5606 DO i=imin,imax
5607 sizen=sizen+1
5608 ikn=ioff+1+(i-imin)+kc
5609!^ B(i,j,k)=recvN(ikN)
5610!^
5611 recvn(ikn)=ad_b(i,j,k)
5612 ad_b(i,j,k)=0.0_r8
5613 END DO
5614 END DO
5615 END DO
5616 END IF
5617 IF (PRESENT(ad_c)) THEN
5618 ioff=ikn
5619 DO m=1,grecvn
5620 mc=(m-1)*iklen
5621 j=jend+m
5622 DO k=lbk,ubk
5623 kc=(k-lbk)*ilen+mc
5624 DO i=imin,imax
5625 sizen=sizen+1
5626 ikn=ioff+1+(i-imin)+kc
5627!^ C(i,j,k)=recvN(ikN)
5628!^
5629 recvn(ikn)=ad_c(i,j,k)
5630 ad_c(i,j,k)=0.0_r8
5631 END DO
5632 END DO
5633 END DO
5634 END IF
5635 IF (PRESENT(ad_d)) THEN
5636 ioff=ikn
5637 DO m=1,grecvn
5638 mc=(m-1)*iklen
5639 j=jend+m
5640 DO k=lbk,ubk
5641 kc=(k-lbk)*ilen+mc
5642 DO i=imin,imax
5643 sizen=sizen+1
5644 ikn=ioff+1+(i-imin)+kc
5645!^ D(i,j,k)=recvN(ikN)
5646!^
5647 recvn(ikn)=ad_d(i,j,k)
5648 ad_d(i,j,k)=0.0_r8
5649 END DO
5650 END DO
5651 END DO
5652 END IF
5653 END IF
5654!
5655 IF (sexchange) THEN
5656 DO i=1,buffersizens
5657 recvs(i)=0.0_r8
5658 sends(i)=0.0_r8
5659 END DO
5660 sizes=0
5661 DO m=grecvs,1,-1
5662 mc=(grecvs-m)*iklen
5663 j=jstr-m
5664 DO k=lbk,ubk
5665 kc=(k-lbk)*ilen+mc
5666 DO i=imin,imax
5667 sizes=sizes+1
5668 iks=1+(i-imin)+kc
5669!^ A(i,j,k)=recvS(ikS)
5670!^
5671 recvs(iks)=ad_a(i,j,k)
5672 ad_a(i,j,k)=0.0_r8
5673 END DO
5674 END DO
5675 END DO
5676 IF (PRESENT(ad_b)) THEN
5677 ioff=iks
5678 DO m=grecvs,1,-1
5679 mc=(grecvs-m)*iklen
5680 j=jstr-m
5681 DO k=lbk,ubk
5682 kc=(k-lbk)*ilen+mc
5683 DO i=imin,imax
5684 sizes=sizes+1
5685 iks=ioff+1+(i-imin)+kc
5686!^ B(i,j,k)=recvS(ikS)
5687!^
5688 recvs(iks)=ad_b(i,j,k)
5689 ad_b(i,j,k)=0.0_r8
5690 END DO
5691 END DO
5692 END DO
5693 END IF
5694 IF (PRESENT(ad_c)) THEN
5695 ioff=iks
5696 DO m=grecvs,1,-1
5697 mc=(grecvs-m)*iklen
5698 j=jstr-m
5699 DO k=lbk,ubk
5700 kc=(k-lbk)*ilen+mc
5701 DO i=imin,imax
5702 sizes=sizes+1
5703 iks=ioff+1+(i-imin)+kc
5704!^ C(i,j,k)=recvS(ikS)
5705!^
5706 recvs(iks)=ad_c(i,j,k)
5707 ad_c(i,j,k)=0.0_r8
5708 END DO
5709 END DO
5710 END DO
5711 END IF
5712 IF (PRESENT(ad_d)) THEN
5713 ioff=iks
5714 DO m=grecvs,1,-1
5715 mc=(grecvs-m)*iklen
5716 j=jstr-m
5717 DO k=lbk,ubk
5718 kc=(k-lbk)*ilen+mc
5719 DO i=imin,imax
5720 sizes=sizes+1
5721 iks=ioff+1+(i-imin)+kc
5722!^ D(i,j,k)=recvS(ikS)
5723!^
5724 recvs(iks)=ad_d(i,j,k)
5725 ad_d(i,j,k)=0.0_r8
5726 END DO
5727 END DO
5728 END DO
5729 END IF
5730 END IF
5731!
5732!-----------------------------------------------------------------------
5733! Adjoint of send and receive Southern and Northern segments.
5734!-----------------------------------------------------------------------
5735!
5736# if defined MPI
5737 IF (sexchange) THEN
5738!^ CALL mpi_irecv (recvS, NSsize, MP_FLOAT, Stile, Ntag, &
5739!^ & OCN_COMM_WORLD, Srequest, Serror)
5740!^
5741 CALL mpi_irecv (sends, nssize, mp_float, stile, ntag, &
5742 & ocn_comm_world, srequest, serror)
5743 END IF
5744 IF (nexchange) THEN
5745!^ CALL mpi_irecv (recvN, NSsize, MP_FLOAT, Ntile, Stag, &
5746!^ & OCN_COMM_WORLD, Nrequest, Nerror)
5747!^
5748 CALL mpi_irecv (sendn, nssize, mp_float, ntile, stag, &
5749 & ocn_comm_world, nrequest, nerror)
5750 END IF
5751 IF (sexchange) THEN
5752!^ CALL mpi_send (sendS, sizeS, MP_FLOAT, Stile, Stag, &
5753!^ & OCN_COMM_WORLD, Serror)
5754!^
5755 CALL mpi_send (recvs, sizes, mp_float, stile, stag, &
5756 & ocn_comm_world, serror)
5757 END IF
5758 IF (nexchange) THEN
5759!^ CALL mpi_send (sendN, sizeN, MP_FLOAT, Ntile, Ntag, &
5760!^ & OCN_COMM_WORLD, Nerror)
5761!^
5762 CALL mpi_send (recvn, sizen, mp_float, ntile, ntag, &
5763 & ocn_comm_world, nerror)
5764 END IF
5765# endif
5766!
5767! Adjoint of packing tile boundary data including ghost-points.
5768!
5769 IF (sexchange) THEN
5770# ifdef MPI
5771 CALL mpi_wait (srequest, status(1,2), serror)
5772 IF (serror.ne.mpi_success) THEN
5773 CALL mpi_error_string (serror, string, lstr, ierror)
5774 lstr=len_trim(string)
5775 WRITE (stdout,20) 'MPI_SEND/MPI_IRECV (Southern Edge)', &
5776 & myrank, serror, string(1:lstr)
5777 20 FORMAT (/,' AD_MP_EXCHANGE3D - error during ',a,' call,', &
5778 & ' Node = ', i3.3,' Error = ',i3,/,18x,a)
5779 exit_flag=2
5780 RETURN
5781 END IF
5782# endif
5783 DO m=1,gsends
5784 mc=(m-1)*iklen
5785 j=jstr+m-1
5786 DO k=lbk,ubk
5787 kc=(k-lbk)*ilen+mc
5788 DO i=imin,imax
5789 iks=1+(i-imin)+kc
5790!^ sendS(ikS)=A(i,j,k)
5791!^
5792 ad_a(i,j,k)=ad_a(i,j,k)+sends(iks)
5793 sends(iks)=0.0_r8
5794 END DO
5795 END DO
5796 END DO
5797 IF (PRESENT(ad_b)) THEN
5798 ioff=iks
5799 DO m=1,gsends
5800 mc=(m-1)*iklen
5801 j=jstr+m-1
5802 DO k=lbk,ubk
5803 kc=(k-lbk)*ilen+mc
5804 DO i=imin,imax
5805 iks=ioff+1+(i-imin)+kc
5806!^ sendS(ikS)=B(i,j,k)
5807!^
5808 ad_b(i,j,k)=ad_b(i,j,k)+sends(iks)
5809 sends(iks)=0.0_r8
5810 END DO
5811 END DO
5812 END DO
5813 END IF
5814 IF (PRESENT(ad_c)) THEN
5815 ioff=iks
5816 DO m=1,gsends
5817 mc=(m-1)*iklen
5818 j=jstr+m-1
5819 DO k=lbk,ubk
5820 kc=(k-lbk)*ilen+mc
5821 DO i=imin,imax
5822 iks=ioff+1+(i-imin)+kc
5823!^ sendS(ikS)=C(i,j,k)
5824!^
5825 ad_c(i,j,k)=ad_c(i,j,k)+sends(iks)
5826 sends(iks)=0.0_r8
5827 END DO
5828 END DO
5829 END DO
5830 END IF
5831 IF (PRESENT(ad_d)) THEN
5832 ioff=iks
5833 DO m=1,gsends
5834 mc=(m-1)*iklen
5835 j=jstr+m-1
5836 DO k=lbk,ubk
5837 kc=(k-lbk)*ilen+mc
5838 DO i=imin,imax
5839 iks=ioff+1+(i-imin)+kc
5840!^ sendS(ikS)=D(i,j,k)
5841!^
5842 ad_d(i,j,k)=ad_d(i,j,k)+sends(iks)
5843 sends(iks)=0.0_r8
5844 END DO
5845 END DO
5846 END DO
5847 END IF
5848 END IF
5849!
5850 IF (nexchange) THEN
5851# ifdef MPI
5852 CALL mpi_wait (nrequest, status(1,4), nerror)
5853 IF (nerror.ne.mpi_success) THEN
5854 CALL mpi_error_string (nerror, string, lstr, ierror)
5855 lstr=len_trim(string)
5856 WRITE (stdout,20) 'MPI_SEND/MPI_IRECV (Northern Edge)', &
5857 & myrank, nerror, string(1:lstr)
5858 exit_flag=2
5859 RETURN
5860 END IF
5861# endif
5862 DO m=1,gsendn
5863 mc=(m-1)*iklen
5864 j=jend-gsendn+m
5865 DO k=lbk,ubk
5866 kc=(k-lbk)*ilen+mc
5867 DO i=imin,imax
5868 ikn=1+(i-imin)+kc
5869!^ sendN(ikN)=A(i,j,k)
5870!^
5871 ad_a(i,j,k)=ad_a(i,j,k)+sendn(ikn)
5872 sendn(ikn)=0.0_r8
5873 END DO
5874 END DO
5875 END DO
5876 IF (PRESENT(ad_b)) THEN
5877 ioff=ikn
5878 DO m=1,gsendn
5879 mc=(m-1)*iklen
5880 j=jend-gsendn+m
5881 DO k=lbk,ubk
5882 kc=(k-lbk)*ilen+mc
5883 DO i=imin,imax
5884 ikn=ioff+1+(i-imin)+kc
5885!^ sendN(ikN)=B(i,j,k)
5886!^
5887 ad_b(i,j,k)=ad_b(i,j,k)+sendn(ikn)
5888 sendn(ikn)=0.0_r8
5889 END DO
5890 END DO
5891 END DO
5892 END IF
5893 IF (PRESENT(ad_c)) THEN
5894 ioff=ikn
5895 DO m=1,gsendn
5896 mc=(m-1)*iklen
5897 j=jend-gsendn+m
5898 DO k=lbk,ubk
5899 kc=(k-lbk)*ilen+mc
5900 DO i=imin,imax
5901 ikn=ioff+1+(i-imin)+kc
5902!^ sendN(ikN)=C(i,j,k)
5903!^
5904 ad_c(i,j,k)=ad_c(i,j,k)+sendn(ikn)
5905 sendn(ikn)=0.0_r8
5906 END DO
5907 END DO
5908 END DO
5909 END IF
5910 IF (PRESENT(ad_d)) THEN
5911 ioff=ikn
5912 DO m=1,gsendn
5913 mc=(m-1)*iklen
5914 j=jend-gsendn+m
5915 DO k=lbk,ubk
5916 kc=(k-lbk)*ilen+mc
5917 DO i=imin,imax
5918 ikn=ioff+1+(i-imin)+kc
5919!^ sendN(ikN)=D(i,j,k)
5920!^
5921 ad_d(i,j,k)=ad_d(i,j,k)+sendn(ikn)
5922 sendn(ikn)=0.0_r8
5923 END DO
5924 END DO
5925 END DO
5926 END IF
5927 END IF
5928!
5929!-----------------------------------------------------------------------
5930! Adjoint of unpack Eastern and Western segments.
5931!-----------------------------------------------------------------------
5932!
5933 IF (eexchange) THEN
5934 DO i=1,buffersizeew
5935 recve(i)=0.0_r8
5936 sende(i)=0.0_r8
5937 END DO
5938 sizee=0
5939 DO m=1,grecve
5940 mc=(m-1)*jklen
5941 i=iend+m
5942 DO k=lbk,ubk
5943 kc=(k-lbk)*jlen+mc
5944 DO j=jmin,jmax
5945 sizee=sizee+1
5946 jke=1+(j-jmin)+kc
5947!^ A(i,j,k)=recvE(jkE)
5948!^
5949 recve(jke)=ad_a(i,j,k)
5950 ad_a(i,j,k)=0.0_r8
5951 END DO
5952 ENDDO
5953 END DO
5954 IF (PRESENT(ad_b)) THEN
5955 joff=jke
5956 DO m=1,grecve
5957 mc=(m-1)*jklen
5958 i=iend+m
5959 DO k=lbk,ubk
5960 kc=(k-lbk)*jlen+mc
5961 DO j=jmin,jmax
5962 sizee=sizee+1
5963 jke=joff+1+(j-jmin)+kc
5964!^ B(i,j,k)=recvE(jkE)
5965!^
5966 recve(jke)=ad_b(i,j,k)
5967 ad_b(i,j,k)=0.0_r8
5968 END DO
5969 END DO
5970 END DO
5971 END IF
5972 IF (PRESENT(ad_c)) THEN
5973 joff=jke
5974 DO m=1,grecve
5975 mc=(m-1)*jklen
5976 i=iend+m
5977 DO k=lbk,ubk
5978 kc=(k-lbk)*jlen+mc
5979 DO j=jmin,jmax
5980 sizee=sizee+1
5981 jke=joff+1+(j-jmin)+kc
5982!^ C(i,j,k)=recvE(jkE)
5983!^
5984 recve(jke)=ad_c(i,j,k)
5985 ad_c(i,j,k)=0.0_r8
5986 END DO
5987 END DO
5988 END DO
5989 END IF
5990 IF (PRESENT(ad_d)) THEN
5991 joff=jke
5992 DO m=1,grecve
5993 mc=(m-1)*jklen
5994 i=iend+m
5995 DO k=lbk,ubk
5996 kc=(k-lbk)*jlen+mc
5997 DO j=jmin,jmax
5998 sizee=sizee+1
5999 jke=joff+1+(j-jmin)+kc
6000!^ D(i,j,k)=recvE(jkE)
6001!^
6002 recve(jke)=ad_d(i,j,k)
6003 ad_d(i,j,k)=0.0_r8
6004 END DO
6005 END DO
6006 END DO
6007 END IF
6008 END IF
6009!
6010 IF (wexchange) THEN
6011 DO i=1,buffersizeew
6012 recvw(i)=0.0_r8
6013 sendw(i)=0.0_r8
6014 END DO
6015 sizew=0
6016 DO m=grecvw,1,-1
6017 mc=(grecvw-m)*jklen
6018 i=istr-m
6019 DO k=lbk,ubk
6020 kc=(k-lbk)*jlen+mc
6021 DO j=jmin,jmax
6022 sizew=sizew+1
6023 jkw=1+(j-jmin)+kc
6024!^ A(i,j,k)=recvW(jkW)
6025!^
6026 recvw(jkw)=ad_a(i,j,k)
6027 ad_a(i,j,k)=0.0_r8
6028 END DO
6029 END DO
6030 END DO
6031 IF (PRESENT(ad_b)) THEN
6032 joff=jkw
6033 DO m=grecvw,1,-1
6034 mc=(grecvw-m)*jklen
6035 i=istr-m
6036 DO k=lbk,ubk
6037 kc=(k-lbk)*jlen+mc
6038 DO j=jmin,jmax
6039 sizew=sizew+1
6040 jkw=joff+1+(j-jmin)+kc
6041!^ B(i,j,k)=recvW(jkW)
6042!^
6043 recvw(jkw)=ad_b(i,j,k)
6044 ad_b(i,j,k)=0.0_r8
6045 END DO
6046 END DO
6047 END DO
6048 END IF
6049 IF (PRESENT(ad_c)) THEN
6050 joff=jkw
6051 DO m=grecvw,1,-1
6052 mc=(grecvw-m)*jklen
6053 i=istr-m
6054 DO k=lbk,ubk
6055 kc=(k-lbk)*jlen+mc
6056 DO j=jmin,jmax
6057 sizew=sizew+1
6058 jkw=joff+1+(j-jmin)+kc
6059!^ C(i,j,k)=recvW(jkW)
6060!^
6061 recvw(jkw)=ad_c(i,j,k)
6062 ad_c(i,j,k)=0.0_r8
6063 END DO
6064 END DO
6065 END DO
6066 END IF
6067 IF (PRESENT(ad_d)) THEN
6068 joff=jkw
6069 DO m=grecvw,1,-1
6070 mc=(grecvw-m)*jklen
6071 i=istr-m
6072 DO k=lbk,ubk
6073 kc=(k-lbk)*jlen+mc
6074 DO j=jmin,jmax
6075 sizew=sizew+1
6076 jkw=joff+1+(j-jmin)+kc
6077!^ D(i,j,k)=recvW(jkW)
6078!^
6079 recvw(jkw)=ad_d(i,j,k)
6080 ad_d(i,j,k)=0.0_r8
6081 END DO
6082 END DO
6083 END DO
6084 END IF
6085 END IF
6086!
6087!-----------------------------------------------------------------------
6088! Send and receive Western and Eastern segments.
6089!-----------------------------------------------------------------------
6090!
6091# if defined MPI
6092 IF (wexchange) THEN
6093!^ CALL mpi_irecv (recvW, EWsize, MP_FLOAT, Wtile, Etag, &
6094!^ & OCN_COMM_WORLD, Wrequest, Werror)
6095!^
6096 CALL mpi_irecv (sendw, ewsize, mp_float, wtile, etag, &
6097 & ocn_comm_world, wrequest, werror)
6098 END IF
6099 IF (eexchange) THEN
6100!^ CALL mpi_irecv (recvE, EWsize, MP_FLOAT, Etile, Wtag, &
6101!^ & OCN_COMM_WORLD, Erequest, Eerror)
6102!^
6103 CALL mpi_irecv (sende, ewsize, mp_float, etile, wtag, &
6104 & ocn_comm_world, erequest, eerror)
6105 END IF
6106 IF (wexchange) THEN
6107!^ CALL mpi_send (sendW, sizeW, MP_FLOAT, Wtile, Wtag, &
6108!^ & OCN_COMM_WORLD, Werror)
6109!^
6110 CALL mpi_send (recvw, sizew, mp_float, wtile, wtag, &
6111 & ocn_comm_world, werror)
6112 END IF
6113 IF (eexchange) THEN
6114!^ CALL mpi_send (sendE, sizeE, MP_FLOAT, Etile, Etag, &
6115!^ & OCN_COMM_WORLD, Eerror)
6116!^
6117 CALL mpi_send (recve, sizee, mp_float, etile, etag, &
6118 & ocn_comm_world, eerror)
6119 END IF
6120# endif
6121!
6122! Adjoint of packing tile boundary data including ghost-points.
6123!
6124 IF (wexchange) THEN
6125# ifdef MPI
6126 CALL mpi_wait (wrequest, status(1,1), werror)
6127 IF (werror.ne.mpi_success) THEN
6128 CALL mpi_error_string (werror, string, lstr, ierror)
6129 lstr=len_trim(string)
6130 WRITE (stdout,20) 'MPI_SEND/MPI_IRECV (Western Edge)', &
6131 & myrank, werror, string(1:lstr)
6132 exit_flag=2
6133 RETURN
6134 END IF
6135# endif
6136 DO m=1,gsendw
6137 mc=(m-1)*jklen
6138 i=istr+m-1
6139 DO k=lbk,ubk
6140 kc=(k-lbk)*jlen+mc
6141 DO j=jmin,jmax
6142 jkw=1+(j-jmin)+kc
6143!^ sendW(jkW)=A(i,j,k)
6144!^
6145 ad_a(i,j,k)=ad_a(i,j,k)+sendw(jkw)
6146 sendw(jkw)=0.0_r8
6147 END DO
6148 END DO
6149 END DO
6150 IF (PRESENT(ad_b)) THEN
6151 joff=jkw
6152 DO m=1,gsendw
6153 mc=(m-1)*jklen
6154 i=istr+m-1
6155 DO k=lbk,ubk
6156 kc=(k-lbk)*jlen+mc
6157 DO j=jmin,jmax
6158 jkw=joff+1+(j-jmin)+kc
6159!^ sendW(jkW)=B(i,j,k)
6160!^
6161 ad_b(i,j,k)=ad_b(i,j,k)+sendw(jkw)
6162 sendw(jkw)=0.0_r8
6163 END DO
6164 END DO
6165 END DO
6166 END IF
6167 IF (PRESENT(ad_c)) THEN
6168 joff=jkw
6169 DO m=1,gsendw
6170 mc=(m-1)*jklen
6171 i=istr+m-1
6172 DO k=lbk,ubk
6173 kc=(k-lbk)*jlen+mc
6174 DO j=jmin,jmax
6175 jkw=joff+1+(j-jmin)+kc
6176!^ sendW(jkW)=C(i,j,k)
6177!^
6178 ad_c(i,j,k)=ad_c(i,j,k)+sendw(jkw)
6179 sendw(jkw)=0.0_r8
6180 END DO
6181 END DO
6182 END DO
6183 END IF
6184 IF (PRESENT(ad_d)) THEN
6185 joff=jkw
6186 DO m=1,gsendw
6187 mc=(m-1)*jklen
6188 i=istr+m-1
6189 DO k=lbk,ubk
6190 kc=(k-lbk)*jlen+mc
6191 DO j=jmin,jmax
6192 jkw=joff+1+(j-jmin)+kc
6193!^ sendW(jkW)=D(i,j,k)
6194!^
6195 ad_d(i,j,k)=ad_d(i,j,k)+sendw(jkw)
6196 sendw(jkw)=0.0_r8
6197 END DO
6198 END DO
6199 END DO
6200 END IF
6201 END IF
6202!
6203 IF (eexchange) THEN
6204# ifdef MPI
6205 CALL mpi_wait (erequest, status(1,3), eerror)
6206 IF (eerror.ne.mpi_success) THEN
6207 CALL mpi_error_string (eerror, string, lstr, ierror)
6208 lstr=len_trim(string)
6209 WRITE (stdout,20) 'MPI_SEND/MPI_IRECV (Eastern Edge)', &
6210 & myrank, eerror, string(1:lstr)
6211 exit_flag=2
6212 RETURN
6213 END IF
6214# endif
6215 DO m=1,gsende
6216 mc=(m-1)*jklen
6217 i=iend-gsende+m
6218 DO k=lbk,ubk
6219 kc=(k-lbk)*jlen+mc
6220 DO j=jmin,jmax
6221 jke=1+(j-jmin)+kc
6222!^ sendE(jkE)=A(i,j,k)
6223!^
6224 ad_a(i,j,k)=ad_a(i,j,k)+sende(jke)
6225 sende(jke)=0.0_r8
6226 END DO
6227 END DO
6228 END DO
6229 IF (PRESENT(ad_b)) THEN
6230 joff=jke
6231 DO m=1,gsende
6232 mc=(m-1)*jklen
6233 i=iend-gsende+m
6234 DO k=lbk,ubk
6235 kc=(k-lbk)*jlen+mc
6236 DO j=jmin,jmax
6237 jke=joff+1+(j-jmin)+kc
6238!^ sendE(jkE)=B(i,j,k)
6239!^
6240 ad_b(i,j,k)=ad_b(i,j,k)+sende(jke)
6241 sende(jke)=0.0_r8
6242 END DO
6243 END DO
6244 END DO
6245 END IF
6246 IF (PRESENT(ad_c)) THEN
6247 joff=jke
6248 DO m=1,gsende
6249 mc=(m-1)*jklen
6250 i=iend-gsende+m
6251 DO k=lbk,ubk
6252 kc=(k-lbk)*jlen+mc
6253 DO j=jmin,jmax
6254 jke=joff+1+(j-jmin)+kc
6255!^ sendE(jkE)=C(i,j,k)
6256!^
6257 ad_c(i,j,k)=ad_c(i,j,k)+sende(jke)
6258 sende(jke)=0.0_r8
6259 END DO
6260 END DO
6261 END DO
6262 END IF
6263 IF (PRESENT(ad_d)) THEN
6264 joff=jke
6265 DO m=1,gsende
6266 mc=(m-1)*jklen
6267 i=iend-gsende+m
6268 DO k=lbk,ubk
6269 kc=(k-lbk)*jlen+mc
6270 DO j=jmin,jmax
6271 jke=joff+1+(j-jmin)+kc
6272!^ sendE(jkE)=D(i,j,k)
6273!^
6274 ad_d(i,j,k)=ad_d(i,j,k)+sende(jke)
6275 sende(jke)=0.0_r8
6276 END DO
6277 END DO
6278 END DO
6279 END IF
6280 END IF
6281
6282# ifdef PROFILE
6283!
6284!-----------------------------------------------------------------------
6285! Turn off time clocks.
6286!-----------------------------------------------------------------------
6287!
6288 CALL wclock_off (ng, model, 61, __line__, myfile)
6289# endif
6290!
6291 RETURN
6292

References mod_param::bmemmax, mod_scalars::exit_flag, mod_param::halosizei, mod_param::halosizej, mod_parallel::mp_float, mod_parallel::myrank, mod_parallel::ocn_comm_world, mod_iounits::stdout, tile_neighbors(), wclock_off(), and wclock_on().

Referenced by ad_balance_mod::ad_balance_tile(), ad_conv_3d_mod::ad_conv_r3d_tile(), ad_conv_3d_mod::ad_conv_u3d_tile(), ad_conv_3d_mod::ad_conv_v3d_tile(), ad_convolution_mod::ad_convolution_tile(), ad_nesting_mod::ad_fine2coarse(), ad_htobs_mod::ad_htobs_tile(), ad_ini_fields_mod::ad_ini_fields_tile(), ad_omega_mod::ad_omega_tile(), ad_ini_fields_mod::ad_out_fields_tile(), ad_pack_tile(), ad_nesting_mod::ad_put_composite(), ad_nesting_mod::ad_put_refine3d(), ad_rho_eos_mod::ad_rho_eos_tile(), ad_set_depth_mod::ad_set_depth_tile(), ad_set_massflux_mod::ad_set_massflux_tile(), ad_step3d_t_mod::ad_step3d_t_tile(), ad_step3d_uv_mod::ad_step3d_uv_tile(), uv_var_change_mod::ad_uv_a2c_grid_tile(), uv_var_change_mod::ad_uv_c2a_grid_tile(), ad_variability_mod::ad_variability_tile(), and ad_wvelocity_mod::ad_wvelocity_tile().

Here is the call graph for this function:
Here is the caller graph for this function:

◆ ad_mp_exchange3d_bry()

subroutine mp_exchange_mod::ad_mp_exchange3d_bry ( integer, intent(in) ng,
integer, intent(in) tile,
integer, intent(in) model,
integer, intent(in) nvar,
integer, intent(in) boundary,
integer, intent(in) lbij,
integer, intent(in) ubij,
integer, intent(in) lbk,
integer, intent(in) ubk,
integer, intent(in) nghost,
logical, intent(in) ew_periodic,
logical, intent(in) ns_periodic,
real(r8), dimension(lbij:,lbk:), intent(inout) ad_a,
real(r8), dimension(lbij:,lbk:), intent(inout), optional ad_b,
real(r8), dimension(lbij:,lbk:), intent(inout), optional ad_c,
real(r8), dimension(lbij:,lbk:), intent(inout), optional ad_d )

Definition at line 6299 of file mp_exchange.F.

6303!***********************************************************************
6304!
6305 USE mod_param
6306 USE mod_parallel
6307 USE mod_iounits
6308 USE mod_scalars
6309!
6310 implicit none
6311!
6312! Imported variable declarations.
6313!
6314 logical, intent(in) :: EW_periodic, NS_periodic
6315!
6316 integer, intent(in) :: ng, tile, model, Nvar, boundary
6317 integer, intent(in) :: LBij, UBij, LBk, UBk
6318 integer, intent(in) :: Nghost
6319!
6320# ifdef ASSUMED_SHAPE
6321 real(r8), intent(inout) :: ad_A(LBij:,LBk:)
6322
6323 real(r8), intent(inout), optional :: ad_B(LBij:,LBk:)
6324 real(r8), intent(inout), optional :: ad_C(LBij:,LBk:)
6325 real(r8), intent(inout), optional :: ad_D(LBij:,LBk:)
6326# else
6327 real(r8), intent(inout) :: ad_A(LBij:UBij,LBk:UBk)
6328
6329 real(r8), intent(inout), optional :: ad_B(LBij:UBij,LBk:UBk)
6330 real(r8), intent(inout), optional :: ad_C(LBij:UBij,LBk:UBk)
6331 real(r8), intent(inout), optional :: ad_D(LBij:UBij,LBk:UBk)
6332# endif
6333!
6334! Local variable declarations.
6335!
6336 logical :: Wexchange, Sexchange, Eexchange, Nexchange
6337!
6338 integer :: i, ikS, ikN, ioff
6339 integer :: j, jkW, jkE, joff
6340 integer :: k, m, mc, Ierror, Klen, Lstr, pp
6341 integer :: Wtile, GsendW, GrecvW, Wtag, Werror, Wrequest
6342 integer :: Stile, GsendS, GrecvS, Stag, Serror, Srequest
6343 integer :: Etile, GsendE, GrecvE, Etag, Eerror, Erequest
6344 integer :: Ntile, GsendN, GrecvN, Ntag, Nerror, Nrequest
6345 integer :: BufferSizeEW, EWsize, sizeW, sizeE
6346 integer :: BufferSizeNS, NSsize, sizeS, sizeN
6347
6348# ifdef MPI
6349 integer, dimension(MPI_STATUS_SIZE,4) :: status
6350# endif
6351!
6352 real(r8), dimension(Nvar*HaloBry(ng)*(UBk-LBk+1)) :: sendW, sendE
6353 real(r8), dimension(Nvar*HaloBry(ng)*(UBk-LBk+1)) :: recvW, recvE
6354 real(r8), dimension(Nvar*HaloBry(ng)*(UBk-LBk+1)) :: sendS, sendN
6355 real(r8), dimension(Nvar*HaloBry(ng)*(UBk-LBk+1)) :: recvS, recvN
6356!
6357 character (len=MPI_MAX_ERROR_STRING) :: string
6358
6359 character (len=*), parameter :: MyFile = &
6360 & __FILE__//", ad_mp_exchange3d_bry"
6361
6362# include "set_bounds.h"
6363
6364# ifdef PROFILE
6365!
6366!-----------------------------------------------------------------------
6367! Turn on time clocks.
6368!-----------------------------------------------------------------------
6369!
6370 CALL wclock_on (ng, model, 63, __line__, myfile)
6371# endif
6372!
6373!-----------------------------------------------------------------------
6374! Determine rank of tile neighbors and number of ghost-points to
6375! exchange.
6376!-----------------------------------------------------------------------
6377!
6378! Maximum automatic buffer memory size in bytes.
6379!
6380 bmemmax(ng)=max(bmemmax(ng), real((4*SIZE(sendw)+ &
6381 & 4*SIZE(sends))*kind(ad_a),r8))
6382!
6383 CALL tile_neighbors (ng, nghost, ew_periodic, ns_periodic, &
6384 & grecvw, gsendw, wtile, wexchange, &
6385 & grecve, gsende, etile, eexchange, &
6386 & grecvs, gsends, stile, sexchange, &
6387 & grecvn, gsendn, ntile, nexchange)
6388!
6389! Adjust exchange swiches according to boundary edge to process.
6390!
6391 wexchange=wexchange.and.((boundary.eq.isouth).or. &
6392 & (boundary.eq.inorth))
6393 eexchange=eexchange.and.((boundary.eq.isouth).or. &
6394 & (boundary.eq.inorth))
6395 sexchange=sexchange.and.((boundary.eq.iwest).or. &
6396 & (boundary.eq.ieast))
6397 nexchange=nexchange.and.((boundary.eq.iwest).or. &
6398 & (boundary.eq.ieast))
6399!
6400! Set communication tags.
6401!
6402 wtag=1
6403 stag=2
6404 etag=3
6405 ntag=4
6406!
6407! Determine range and length of the distributed tile boundary segments.
6408!
6409 klen=ubk-lbk+1
6410 IF (ew_periodic.or.ns_periodic) THEN
6411 pp=1
6412 ELSE
6413 pp=0
6414 END IF
6415 nssize=nvar*(nghost+pp)*klen
6416 ewsize=nvar*(nghost+pp)*klen
6417 buffersizens=nvar*(nghost+pp)*klen
6418 buffersizeew=nvar*(nghost+pp)*klen
6419 IF (SIZE(sende).lt.ewsize) THEN
6420 WRITE (stdout,10) 'EWsize = ', ewsize, SIZE(sende)
6421 10 FORMAT (/,' AD_MP_EXCHANGE3D_BRY - communication buffer too', &
6422 & ' small, ',a, 2i8)
6423 END IF
6424 IF (SIZE(sendn).lt.nssize) THEN
6425 WRITE (stdout,10) 'NSsize = ', nssize, SIZE(sendn)
6426 END IF
6427!
6428!-----------------------------------------------------------------------
6429! Adjoint of unpacking Northern and Southern segments.
6430!-----------------------------------------------------------------------
6431!
6432 IF (nexchange) THEN
6433 DO i=1,buffersizens
6434 recvn(i)=0.0_r8
6435 sendn(i)=0.0_r8
6436 END DO
6437 sizen=0
6438 DO m=1,grecvn
6439 mc=(m-1)*klen
6440 j=jend+m
6441 DO k=lbk,ubk
6442 sizen=sizen+1
6443 ikn=1+(k-lbk)+mc
6444!^ A(j,k)=recvN(ikN)
6445!^
6446 recvn(ikn)=ad_a(j,k)
6447 ad_a(j,k)=0.0_r8
6448 END DO
6449 END DO
6450 IF (PRESENT(ad_b)) THEN
6451 ioff=ikn
6452 DO m=1,grecvn
6453 mc=(m-1)*klen
6454 j=jend+m
6455 DO k=lbk,ubk
6456 sizen=sizen+1
6457 ikn=ioff+1+(k-lbk)+mc
6458!^ B(j,k)=recvN(ikN)
6459!^
6460 recvn(ikn)=ad_b(j,k)
6461 ad_b(j,k)=0.0_r8
6462 END DO
6463 END DO
6464 END IF
6465 IF (PRESENT(ad_c)) THEN
6466 ioff=ikn
6467 DO m=1,grecvn
6468 mc=(m-1)*klen
6469 j=jend+m
6470 DO k=lbk,ubk
6471 sizen=sizen+1
6472 ikn=ioff+1+(k-lbk)+mc
6473!^ C(j,k)=recvN(ikN)
6474!^
6475 recvn(ikn)=ad_c(j,k)
6476 ad_c(j,k)=0.0_r8
6477 END DO
6478 END DO
6479 END IF
6480 IF (PRESENT(ad_d)) THEN
6481 ioff=ikn
6482 DO m=1,grecvn
6483 mc=(m-1)*klen
6484 j=jend+m
6485 DO k=lbk,ubk
6486 sizen=sizen+1
6487 ikn=ioff+1+(k-lbk)+mc
6488!^ D(j,k)=recvN(ikN)
6489!^
6490 recvn(ikn)=ad_d(j,k)
6491 ad_d(j,k)=0.0_r8
6492 END DO
6493 END DO
6494 END IF
6495 END IF
6496!
6497 IF (sexchange) THEN
6498 DO i=1,buffersizens
6499 recvs(i)=0.0_r8
6500 sends(i)=0.0_r8
6501 END DO
6502 sizes=0
6503 DO m=grecvs,1,-1
6504 mc=(grecvs-m)*klen
6505 j=jstr-m
6506 DO k=lbk,ubk
6507 sizes=sizes+1
6508 iks=1+(k-lbk)+mc
6509!^ A(j,k)=recvS(ikS)
6510!^
6511 recvs(iks)=ad_a(j,k)
6512 ad_a(j,k)=0.0_r8
6513 END DO
6514 END DO
6515 IF (PRESENT(ad_b)) THEN
6516 ioff=iks
6517 DO m=grecvs,1,-1
6518 mc=(grecvs-m)*klen
6519 j=jstr-m
6520 DO k=lbk,ubk
6521 sizes=sizes+1
6522 iks=ioff+1+(k-lbk)+mc
6523!^ B(j,k)=recvS(ikS)
6524!^
6525 recvs(iks)=ad_b(j,k)
6526 ad_b(j,k)=0.0_r8
6527 END DO
6528 END DO
6529 END IF
6530 IF (PRESENT(ad_c)) THEN
6531 ioff=iks
6532 DO m=grecvs,1,-1
6533 mc=(grecvs-m)*klen
6534 j=jstr-m
6535 DO k=lbk,ubk
6536 sizes=sizes+1
6537 iks=ioff+1+(k-lbk)+mc
6538!^ C(j,k)=recvS(ikS)
6539!^
6540 recvs(iks)=ad_c(j,k)
6541 ad_c(j,k)=0.0_r8
6542 END DO
6543 END DO
6544 END IF
6545 IF (PRESENT(ad_d)) THEN
6546 ioff=iks
6547 DO m=grecvs,1,-1
6548 mc=(grecvs-m)*klen
6549 j=jstr-m
6550 DO k=lbk,ubk
6551 sizes=sizes+1
6552 iks=ioff+1+(k-lbk)+mc
6553!^ D(j,k)=recvS(ikS)
6554!^
6555 recvs(iks)=ad_d(j,k)
6556 ad_d(j,k)=0.0_r8
6557 END DO
6558 END DO
6559 END IF
6560 END IF
6561!
6562!-----------------------------------------------------------------------
6563! Adjoint of send and receive Southern and Northern segments.
6564!-----------------------------------------------------------------------
6565!
6566# if defined MPI
6567 IF (sexchange) THEN
6568!^ CALL mpi_irecv (recvS, NSsize, MP_FLOAT, Stile, Ntag, &
6569!^ & OCN_COMM_WORLD, Srequest, Serror)
6570!^
6571 CALL mpi_irecv (sends, nssize, mp_float, stile, ntag, &
6572 & ocn_comm_world, srequest, serror)
6573 END IF
6574 IF (nexchange) THEN
6575!^ CALL mpi_irecv (recvN, NSsize, MP_FLOAT, Ntile, Stag, &
6576!^ & OCN_COMM_WORLD, Nrequest, Nerror)
6577!^
6578 CALL mpi_irecv (sendn, nssize, mp_float, ntile, stag, &
6579 & ocn_comm_world, nrequest, nerror)
6580 END IF
6581 IF (sexchange) THEN
6582!^ CALL mpi_send (sendS, sizeS, MP_FLOAT, Stile, Stag, &
6583!^ & OCN_COMM_WORLD, Serror)
6584!^
6585 CALL mpi_send (recvs, sizes, mp_float, stile, stag, &
6586 & ocn_comm_world, serror)
6587 END IF
6588 IF (nexchange) THEN
6589!^ CALL mpi_send (sendN, sizeN, MP_FLOAT, Ntile, Ntag, &
6590!^ & OCN_COMM_WORLD, Nerror)
6591!^
6592 CALL mpi_send (recvn, sizen, mp_float, ntile, ntag, &
6593 & ocn_comm_world, nerror)
6594 END IF
6595# endif
6596!
6597! Adjoint of packing tile boundary data including ghost-points.
6598!
6599 IF (sexchange) THEN
6600# ifdef MPI
6601 CALL mpi_wait (srequest, status(1,2), serror)
6602 IF (serror.ne.mpi_success) THEN
6603 CALL mpi_error_string (serror, string, lstr, ierror)
6604 lstr=len_trim(string)
6605 WRITE (stdout,20) 'MPI_SEND/MPI_IRECV (Southern Edge)', &
6606 & myrank, serror, string(1:lstr)
6607 20 FORMAT (/,' AD_MP_EXCHANGE3D_BRY - error during ',a,' call,', &
6608 & ' Node = ', i3.3,' Error = ',i3,/,18x,a)
6609 exit_flag=2
6610 RETURN
6611 END IF
6612# endif
6613 DO m=1,gsends
6614 mc=(m-1)*klen
6615 j=jstr+m-1
6616 DO k=lbk,ubk
6617 iks=1+(k-lbk)+mc
6618!^ sendS(ikS)=A(j,k)
6619!^
6620 ad_a(j,k)=ad_a(j,k)+sends(iks)
6621 sends(iks)=0.0_r8
6622 END DO
6623 END DO
6624 IF (PRESENT(ad_b)) THEN
6625 ioff=iks
6626 DO m=1,gsends
6627 mc=(m-1)*klen
6628 j=jstr+m-1
6629 DO k=lbk,ubk
6630 iks=ioff+1+(k-lbk)+mc
6631!^ sendS(ikS)=B(j,k)
6632!^
6633 ad_b(j,k)=ad_b(j,k)+sends(iks)
6634 sends(iks)=0.0_r8
6635 END DO
6636 END DO
6637 END IF
6638 IF (PRESENT(ad_c)) THEN
6639 ioff=iks
6640 DO m=1,gsends
6641 mc=(m-1)*klen
6642 j=jstr+m-1
6643 DO k=lbk,ubk
6644 iks=ioff+1+(k-lbk)+mc
6645!^ sendS(ikS)=C(j,k)
6646!^
6647 ad_c(j,k)=ad_c(j,k)+sends(iks)
6648 sends(iks)=0.0_r8
6649 END DO
6650 END DO
6651 END IF
6652 IF (PRESENT(ad_d)) THEN
6653 ioff=iks
6654 DO m=1,gsends
6655 mc=(m-1)*klen
6656 j=jstr+m-1
6657 DO k=lbk,ubk
6658 iks=ioff+1+(k-lbk)+mc
6659!^ sendS(ikS)=D(j,k)
6660!^
6661 ad_d(j,k)=ad_d(j,k)+sends(iks)
6662 sends(iks)=0.0_r8
6663 END DO
6664 END DO
6665 END IF
6666 END IF
6667!
6668 IF (nexchange) THEN
6669# ifdef MPI
6670 CALL mpi_wait (nrequest, status(1,4), nerror)
6671 IF (nerror.ne.mpi_success) THEN
6672 CALL mpi_error_string (nerror, string, lstr, ierror)
6673 lstr=len_trim(string)
6674 WRITE (stdout,20) 'MPI_SEND/MPI_IRECV (Northern Edge)', &
6675 & myrank, nerror, string(1:lstr)
6676 exit_flag=2
6677 RETURN
6678 END IF
6679# endif
6680 DO m=1,gsendn
6681 mc=(m-1)*klen
6682 j=jend-gsendn+m
6683 DO k=lbk,ubk
6684 ikn=1+(k-lbk)+mc
6685!^ sendN(ikN)=A(j,k)
6686!^
6687 ad_a(j,k)=ad_a(j,k)+sendn(ikn)
6688 sendn(ikn)=0.0_r8
6689 END DO
6690 END DO
6691 IF (PRESENT(ad_b)) THEN
6692 ioff=ikn
6693 DO m=1,gsendn
6694 mc=(m-1)*klen
6695 j=jend-gsendn+m
6696 DO k=lbk,ubk
6697 ikn=ioff+1+(k-lbk)+mc
6698!^ sendN(ikN)=B(j,k)
6699!^
6700 ad_b(j,k)=ad_b(j,k)+sendn(ikn)
6701 sendn(ikn)=0.0_r8
6702 END DO
6703 END DO
6704 END IF
6705 IF (PRESENT(ad_c)) THEN
6706 ioff=ikn
6707 DO m=1,gsendn
6708 mc=(m-1)*klen
6709 j=jend-gsendn+m
6710 DO k=lbk,ubk
6711 ikn=ioff+1+(k-lbk)+mc
6712!^ sendN(ikN)=C(j,k)
6713!^
6714 ad_c(j,k)=ad_c(j,k)+sendn(ikn)
6715 sendn(ikn)=0.0_r8
6716 END DO
6717 END DO
6718 END IF
6719 IF (PRESENT(ad_d)) THEN
6720 ioff=ikn
6721 DO m=1,gsendn
6722 mc=(m-1)*klen
6723 j=jend-gsendn+m
6724 DO k=lbk,ubk
6725 ikn=ioff+1+(k-lbk)+mc
6726!^ sendN(ikN)=D(j,k)
6727!^
6728 ad_d(j,k)=ad_d(j,k)+sendn(ikn)
6729 sendn(ikn)=0.0_r8
6730 END DO
6731 END DO
6732 END IF
6733 END IF
6734!
6735!-----------------------------------------------------------------------
6736! Adjoint of unpack Eastern and Western segments.
6737!-----------------------------------------------------------------------
6738!
6739 IF (eexchange) THEN
6740 DO i=1,buffersizeew
6741 recve(i)=0.0_r8
6742 sende(i)=0.0_r8
6743 END DO
6744 sizee=0
6745 DO m=1,grecve
6746 mc=(m-1)*klen
6747 i=iend+m
6748 DO k=lbk,ubk
6749 sizee=sizee+1
6750 jke=1+(k-lbk)+mc
6751!^ A(i,k)=recvE(jkE)
6752!^
6753 recve(jke)=ad_a(i,k)
6754 ad_a(i,k)=0.0_r8
6755 ENDDO
6756 END DO
6757 IF (PRESENT(ad_b)) THEN
6758 joff=jke
6759 DO m=1,grecve
6760 mc=(m-1)*klen
6761 i=iend+m
6762 DO k=lbk,ubk
6763 sizee=sizee+1
6764 jke=joff+1+(k-lbk)+mc
6765!^ B(i,k)=recvE(jkE)
6766!^
6767 recve(jke)=ad_b(i,k)
6768 ad_b(i,k)=0.0_r8
6769 END DO
6770 END DO
6771 END IF
6772 IF (PRESENT(ad_c)) THEN
6773 joff=jke
6774 DO m=1,grecve
6775 mc=(m-1)*klen
6776 i=iend+m
6777 DO k=lbk,ubk
6778 sizee=sizee+1
6779 jke=joff+1+(k-lbk)+mc
6780!^ C(i,k)=recvE(jkE)
6781!^
6782 recve(jke)=ad_c(i,k)
6783 ad_c(i,k)=0.0_r8
6784 END DO
6785 END DO
6786 END IF
6787 IF (PRESENT(ad_d)) THEN
6788 joff=jke
6789 DO m=1,grecve
6790 mc=(m-1)*klen
6791 i=iend+m
6792 DO k=lbk,ubk
6793 sizee=sizee+1
6794 jke=joff+1+(k-lbk)+mc
6795!^ D(i,k)=recvE(jkE)
6796!^
6797 recve(jke)=ad_d(i,k)
6798 ad_d(i,k)=0.0_r8
6799 END DO
6800 END DO
6801 END IF
6802 END IF
6803!
6804 IF (wexchange) THEN
6805 DO i=1,buffersizeew
6806 recvw(i)=0.0_r8
6807 sendw(i)=0.0_r8
6808 END DO
6809 sizew=0
6810 DO m=grecvw,1,-1
6811 mc=(grecvw-m)*klen
6812 i=istr-m
6813 DO k=lbk,ubk
6814 sizew=sizew+1
6815 jkw=1+(k-lbk)+mc
6816!^ A(i,k)=recvW(jkW)
6817!^
6818 recvw(jkw)=ad_a(i,k)
6819 ad_a(i,k)=0.0_r8
6820 END DO
6821 END DO
6822 IF (PRESENT(ad_b)) THEN
6823 joff=jkw
6824 DO m=grecvw,1,-1
6825 mc=(grecvw-m)*klen
6826 i=istr-m
6827 DO k=lbk,ubk
6828 sizew=sizew+1
6829 jkw=joff+1+(k-lbk)+mc
6830!^ B(i,k)=recvW(jkW)
6831!^
6832 recvw(jkw)=ad_b(i,k)
6833 ad_b(i,k)=0.0_r8
6834 END DO
6835 END DO
6836 END IF
6837 IF (PRESENT(ad_c)) THEN
6838 joff=jkw
6839 DO m=grecvw,1,-1
6840 mc=(grecvw-m)*klen
6841 i=istr-m
6842 DO k=lbk,ubk
6843 sizew=sizew+1
6844 jkw=joff+1+(k-lbk)+mc
6845!^ C(i,k)=recvW(jkW)
6846!^
6847 recvw(jkw)=ad_c(i,k)
6848 ad_c(i,k)=0.0_r8
6849 END DO
6850 END DO
6851 END IF
6852 IF (PRESENT(ad_d)) THEN
6853 joff=jkw
6854 DO m=grecvw,1,-1
6855 mc=(grecvw-m)*klen
6856 i=istr-m
6857 DO k=lbk,ubk
6858 sizew=sizew+1
6859 jkw=joff+1+(k-lbk)+mc
6860!^ D(i,k)=recvW(jkW)
6861!^
6862 recvw(jkw)=ad_d(i,k)
6863 ad_d(i,k)=0.0_r8
6864 END DO
6865 END DO
6866 END IF
6867 END IF
6868!
6869!-----------------------------------------------------------------------
6870! Send and receive Western and Eastern segments.
6871!-----------------------------------------------------------------------
6872!
6873# if defined MPI
6874 IF (wexchange) THEN
6875!^ CALL mpi_irecv (recvW, EWsize, MP_FLOAT, Wtile, Etag, &
6876!^ & OCN_COMM_WORLD, Wrequest, Werror)
6877!^
6878 CALL mpi_irecv (sendw, ewsize, mp_float, wtile, etag, &
6879 & ocn_comm_world, wrequest, werror)
6880 END IF
6881 IF (eexchange) THEN
6882!^ CALL mpi_irecv (recvE, EWsize, MP_FLOAT, Etile, Wtag, &
6883!^ & OCN_COMM_WORLD, Erequest, Eerror)
6884!^
6885 CALL mpi_irecv (sende, ewsize, mp_float, etile, wtag, &
6886 & ocn_comm_world, erequest, eerror)
6887 END IF
6888 IF (wexchange) THEN
6889!^ CALL mpi_send (sendW, sizeW, MP_FLOAT, Wtile, Wtag, &
6890!^ & OCN_COMM_WORLD, Werror)
6891!^
6892 CALL mpi_send (recvw, sizew, mp_float, wtile, wtag, &
6893 & ocn_comm_world, werror)
6894 END IF
6895 IF (eexchange) THEN
6896!^ CALL mpi_send (sendE, sizeE, MP_FLOAT, Etile, Etag, &
6897!^ & OCN_COMM_WORLD, Eerror)
6898!^
6899 CALL mpi_send (recve, sizee, mp_float, etile, etag, &
6900 & ocn_comm_world, eerror)
6901 END IF
6902# endif
6903!
6904! Adjoint of packing tile boundary data including ghost-points.
6905!
6906 IF (wexchange) THEN
6907# ifdef MPI
6908 CALL mpi_wait (wrequest, status(1,1), werror)
6909 IF (werror.ne.mpi_success) THEN
6910 CALL mpi_error_string (werror, string, lstr, ierror)
6911 lstr=len_trim(string)
6912 WRITE (stdout,20) 'MPI_SEND/MPI_IRECV (Western Edge)', &
6913 & myrank, werror, string(1:lstr)
6914 exit_flag=2
6915 RETURN
6916 END IF
6917# endif
6918 DO m=1,gsendw
6919 mc=(m-1)*klen
6920 i=istr+m-1
6921 DO k=lbk,ubk
6922 jkw=1+(k-lbk)+mc
6923!^ sendW(jkW)=A(i,k)
6924!^
6925 ad_a(i,k)=ad_a(i,k)+sendw(jkw)
6926 sendw(jkw)=0.0_r8
6927 END DO
6928 END DO
6929 IF (PRESENT(ad_b)) THEN
6930 joff=jkw
6931 DO m=1,gsendw
6932 mc=(m-1)*klen
6933 i=istr+m-1
6934 DO k=lbk,ubk
6935 jkw=joff+1+(k-lbk)+mc
6936!^ sendW(jkW)=B(i,k)
6937!^
6938 ad_b(i,k)=ad_b(i,k)+sendw(jkw)
6939 sendw(jkw)=0.0_r8
6940 END DO
6941 END DO
6942 END IF
6943 IF (PRESENT(ad_c)) THEN
6944 joff=jkw
6945 DO m=1,gsendw
6946 mc=(m-1)*klen
6947 i=istr+m-1
6948 DO k=lbk,ubk
6949 jkw=joff+1+(k-lbk)+mc
6950!^ sendW(jkW)=C(i,k)
6951!^
6952 ad_c(i,k)=ad_c(i,k)+sendw(jkw)
6953 sendw(jkw)=0.0_r8
6954 END DO
6955 END DO
6956 END IF
6957 IF (PRESENT(ad_d)) THEN
6958 joff=jkw
6959 DO m=1,gsendw
6960 mc=(m-1)*klen
6961 i=istr+m-1
6962 DO k=lbk,ubk
6963 jkw=joff+1+(k-lbk)+mc
6964!^ sendW(jkW)=D(i,k)
6965!^
6966 ad_d(i,k)=ad_d(i,k)+sendw(jkw)
6967 sendw(jkw)=0.0_r8
6968 END DO
6969 END DO
6970 END IF
6971 END IF
6972!
6973 IF (eexchange) THEN
6974# ifdef MPI
6975 CALL mpi_wait (erequest, status(1,3), eerror)
6976 IF (eerror.ne.mpi_success) THEN
6977 CALL mpi_error_string (eerror, string, lstr, ierror)
6978 lstr=len_trim(string)
6979 WRITE (stdout,20) 'MPI_SEND/MPI_IRECV (Eastern Edge)', &
6980 & myrank, eerror, string(1:lstr)
6981 exit_flag=2
6982 RETURN
6983 END IF
6984# endif
6985 DO m=1,gsende
6986 mc=(m-1)*klen
6987 i=iend-gsende+m
6988 DO k=lbk,ubk
6989 jke=1+(k-lbk)+mc
6990!^ sendE(jkE)=A(i,k)
6991!^
6992 ad_a(i,k)=ad_a(i,k)+sende(jke)
6993 sende(jke)=0.0_r8
6994 END DO
6995 END DO
6996 IF (PRESENT(ad_b)) THEN
6997 joff=jke
6998 DO m=1,gsende
6999 mc=(m-1)*klen
7000 i=iend-gsende+m
7001 DO k=lbk,ubk
7002 jke=joff+1+(k-lbk)+mc
7003!^ sendE(jkE)=B(i,k)
7004!^
7005 ad_b(i,k)=ad_b(i,k)+sende(jke)
7006 sende(jke)=0.0_r8
7007 END DO
7008 END DO
7009 END IF
7010 IF (PRESENT(ad_c)) THEN
7011 joff=jke
7012 DO m=1,gsende
7013 mc=(m-1)*klen
7014 i=iend-gsende+m
7015 DO k=lbk,ubk
7016 jke=joff+1+(k-lbk)+mc
7017!^ sendE(jkE)=C(i,k)
7018!^
7019 ad_c(i,k)=ad_c(i,k)+sende(jke)
7020 sende(jke)=0.0_r8
7021 END DO
7022 END DO
7023 END IF
7024 IF (PRESENT(ad_d)) THEN
7025 joff=jke
7026 DO m=1,gsende
7027 mc=(m-1)*klen
7028 i=iend-gsende+m
7029 DO k=lbk,ubk
7030 jke=joff+1+(k-lbk)+mc
7031!^ sendE(jkE)=D(i,k)
7032!^
7033 ad_d(i,k)=ad_d(i,k)+sende(jke)
7034 sende(jke)=0.0_r8
7035 END DO
7036 END DO
7037 END IF
7038 END IF
7039
7040# ifdef PROFILE
7041!
7042!-----------------------------------------------------------------------
7043! Turn off time clocks.
7044!-----------------------------------------------------------------------
7045!
7046 CALL wclock_off (ng, model, 63, __line__, myfile)
7047# endif
7048!
7049 RETURN

References mod_param::bmemmax, mod_scalars::exit_flag, mod_scalars::ieast, mod_scalars::inorth, mod_scalars::isouth, mod_scalars::iwest, mod_parallel::mp_float, mod_parallel::myrank, mod_parallel::ocn_comm_world, mod_iounits::stdout, tile_neighbors(), wclock_off(), and wclock_on().

Referenced by ad_conv_bry3d_mod::ad_conv_r3d_bry_tile(), ad_conv_bry3d_mod::ad_conv_u3d_bry_tile(), ad_conv_bry3d_mod::ad_conv_v3d_bry_tile(), ad_convolution_mod::ad_convolution_tile(), ad_set_depth_mod::ad_set_depth_bry_tile(), and ad_variability_mod::ad_variability_tile().

Here is the call graph for this function:
Here is the caller graph for this function:

◆ ad_mp_exchange4d()

subroutine mp_exchange_mod::ad_mp_exchange4d ( integer, intent(in) ng,
integer, intent(in) tile,
integer, intent(in) model,
integer, intent(in) nvar,
integer, intent(in) lbi,
integer, intent(in) ubi,
integer, intent(in) lbj,
integer, intent(in) ubj,
integer, intent(in) lbk,
integer, intent(in) ubk,
integer, intent(in) lbt,
integer, intent(in) ubt,
integer, intent(in) nghost,
logical, intent(in) ew_periodic,
logical, intent(in) ns_periodic,
real(r8), dimension(lbi:,lbj:,lbk:,lbt:), intent(inout) ad_a,
real(r8), dimension(lbi:,lbj:,lbk:,lbt:), intent(inout), optional ad_b,
real(r8), dimension(lbi:,lbj:,lbk:,lbt:), intent(inout), optional ad_c )

Definition at line 7053 of file mp_exchange.F.

7058!***********************************************************************
7059!
7060 USE mod_param
7061 USE mod_parallel
7062 USE mod_iounits
7063 USE mod_scalars
7064!
7065 implicit none
7066!
7067! Imported variable declarations.
7068!
7069 logical, intent(in) :: EW_periodic, NS_periodic
7070!
7071 integer, intent(in) :: ng, tile, model, Nvar
7072 integer, intent(in) :: LBi, UBi, LBj, UBj, LBk, UBk, LBt, UBt
7073 integer, intent(in) :: Nghost
7074!
7075# ifdef ASSUMED_SHAPE
7076 real(r8), intent(inout) :: ad_A(LBi:,LBj:,LBk:,LBt:)
7077
7078 real(r8), intent(inout), optional :: ad_B(LBi:,LBj:,LBk:,LBt:)
7079 real(r8), intent(inout), optional :: ad_C(LBi:,LBj:,LBk:,LBt:)
7080# else
7081 real(r8), intent(inout) :: ad_A(LBi:UBi,LBj:UBj,LBk:UBk,LBt:UBt)
7082
7083 real(r8), intent(inout), optional :: &
7084 & ad_B(LBi:UBi,LBj:UBj,LBk:UBk,LBt:UBt)
7085 real(r8), intent(inout), optional :: &
7086 & ad_C(LBi:UBi,LBj:UBj,LBk:UBk,LBt:UBt)
7087# endif
7088!
7089! Local variable declarations.
7090!
7091 logical :: Wexchange, Sexchange, Eexchange, Nexchange
7092!
7093 integer :: i, ikS, ikN, ioff, Imin, Imax, Ilen, IKlen, IKTlen
7094 integer :: j, jkW, jkE, joff, Jmin, Jmax, Jlen, JKlen, JKTlen
7095 integer :: k, kc, m, mc, Ierror, Klen, Lstr, Tlen, pp
7096 integer :: l, lc
7097 integer :: Wtile, GsendW, GrecvW, Wtag, Werror, Wrequest
7098 integer :: Stile, GsendS, GrecvS, Stag, Serror, Srequest
7099 integer :: Etile, GsendE, GrecvE, Etag, Eerror, Erequest
7100 integer :: Ntile, GsendN, GrecvN, Ntag, Nerror, Nrequest
7101 integer :: BufferSizeEW, EWsize, sizeW, sizeE
7102 integer :: BufferSizeNS, NSsize, sizeS, sizeN
7103
7104# ifdef MPI
7105 integer, dimension(MPI_STATUS_SIZE,4) :: status
7106# endif
7107!
7108 real(r8), dimension(Nvar*HaloSizeJ(ng)*(UBk-LBk+1)* & & (UBt-LBt+1)) :: sendW, sendE
7109 real(r8), dimension(Nvar*HaloSizeI(ng)*(UBk-LBk+1)* & & (UBt-LBt+1)) :: sendS, sendN
7110
7111 real(r8), dimension(Nvar*HaloSizeJ(ng)*(UBk-LBk+1)* & & (UBt-LBt+1)) :: recvW, recvE
7112 real(r8), dimension(Nvar*HaloSizeI(ng)*(UBk-LBk+1)* & & (UBt-LBt+1)) :: recvS, recvN
7113!
7114 character (len=MPI_MAX_ERROR_STRING) :: string
7115
7116 character (len=*), parameter :: MyFile = &
7117 & __FILE__//", ad_mp_exchange4d"
7118
7119# include "set_bounds.h"
7120
7121# ifdef PROFILE
7122!
7123!-----------------------------------------------------------------------
7124! Turn on time clocks.
7125!-----------------------------------------------------------------------
7126!
7127 CALL wclock_on (ng, model, 62, __line__, myfile)
7128# endif
7129!
7130!-----------------------------------------------------------------------
7131! Determine rank of tile neighbors and number of ghost-points to
7132! exchange.
7133!-----------------------------------------------------------------------
7134!
7135! Maximum automatic buffer memory size in bytes.
7136!
7137 bmemmax(ng)=max(bmemmax(ng), real((4*SIZE(sendw)+ &
7138 & 4*SIZE(sends))*kind(ad_a),r8))
7139!
7140 CALL tile_neighbors (ng, nghost, ew_periodic, ns_periodic, &
7141 & grecvw, gsendw, wtile, wexchange, &
7142 & grecve, gsende, etile, eexchange, &
7143 & grecvs, gsends, stile, sexchange, &
7144 & grecvn, gsendn, ntile, nexchange)
7145!
7146! Set communication tags.
7147!
7148 wtag=1
7149 stag=2
7150 etag=3
7151 ntag=4
7152!
7153! Determine range and length of the distributed tile boundary segments.
7154!
7155 imin=lbi
7156 imax=ubi
7157 jmin=lbj
7158 jmax=ubj
7159 ilen=imax-imin+1
7160 jlen=jmax-jmin+1
7161 klen=ubk-lbk+1
7162 tlen=ubt-lbt+1
7163 iklen=ilen*klen
7164 jklen=jlen*klen
7165 iktlen=iklen*tlen
7166 jktlen=jklen*tlen
7167 IF (ew_periodic.or.ns_periodic) THEN
7168 pp=1
7169 ELSE
7170 pp=0
7171 END IF
7172 nssize=nvar*(nghost+pp)*iktlen
7173 ewsize=nvar*(nghost+pp)*jktlen
7174 buffersizens=nvar*halosizei(ng)*klen*tlen
7175 buffersizeew=nvar*halosizej(ng)*klen*tlen
7176 IF (SIZE(sende).lt.ewsize) THEN
7177 WRITE (stdout,10) 'EWsize = ', ewsize, SIZE(sende)
7178 10 FORMAT (/,' AD_MP_EXCHANGE4D - communication buffer too', &
7179 & ' small, ',a, 2i8)
7180 END IF
7181 IF (SIZE(sendn).lt.nssize) THEN
7182 WRITE (stdout,10) 'NSsize = ', nssize, SIZE(sendn)
7183 END IF
7184!
7185!-----------------------------------------------------------------------
7186! Adjoint of unpacking Northern and Southern segments.
7187!-----------------------------------------------------------------------
7188!
7189 IF (nexchange) THEN
7190 DO i=1,buffersizens
7191 recvn(i)=0.0_r8
7192 sendn(i)=0.0_r8
7193 END DO
7194 sizen=0
7195 DO m=1,grecvn
7196 mc=(m-1)*iktlen
7197 j=jend+m
7198 DO l=lbt,ubt
7199 lc=(l-lbt)*iklen+mc
7200 DO k=lbk,ubk
7201 kc=(k-lbk)*ilen+lc
7202 DO i=imin,imax
7203 sizen=sizen+1
7204 ikn=1+(i-imin)+kc
7205!^ A(i,j,k,l)=recvN(ikN)
7206!^
7207 recvn(ikn)=ad_a(i,j,k,l)
7208 ad_a(i,j,k,l)=0.0_r8
7209 END DO
7210 END DO
7211 END DO
7212 END DO
7213 IF (PRESENT(ad_b)) THEN
7214 ioff=ikn
7215 DO m=1,grecvn
7216 mc=(m-1)*iktlen
7217 j=jend+m
7218 DO l=lbt,ubt
7219 lc=(l-lbt)*iklen+mc
7220 DO k=lbk,ubk
7221 kc=(k-lbk)*ilen+lc
7222 DO i=imin,imax
7223 sizen=sizen+1
7224 ikn=ioff+1+(i-imin)+kc
7225!^ B(i,j,k,l)=recvN(ikN)
7226!^
7227 recvn(ikn)=ad_b(i,j,k,l)
7228 ad_b(i,j,k,l)=0.0_r8
7229 END DO
7230 END DO
7231 END DO
7232 END DO
7233 END IF
7234 IF (PRESENT(ad_c)) THEN
7235 ioff=ikn
7236 DO m=1,grecvn
7237 mc=(m-1)*iktlen
7238 j=jend+m
7239 DO l=lbt,ubt
7240 lc=(l-lbt)*iklen+mc
7241 DO k=lbk,ubk
7242 kc=(k-lbk)*ilen+lc
7243 DO i=imin,imax
7244 sizen=sizen+1
7245 ikn=ioff+1+(i-imin)+kc
7246!^ C(i,j,k,l)=recvN(ikN)
7247!^
7248 recvn(ikn)=ad_c(i,j,k,l)
7249 ad_c(i,j,k,l)=0.0_r8
7250 END DO
7251 END DO
7252 END DO
7253 END DO
7254 END IF
7255 END IF
7256!
7257 IF (sexchange) THEN
7258 DO i=1,buffersizens
7259 recvs(i)=0.0_r8
7260 sends(i)=0.0_r8
7261 END DO
7262 sizes=0
7263 DO m=grecvs,1,-1
7264 mc=(grecvs-m)*iktlen
7265 j=jstr-m
7266 DO l=lbt,ubt
7267 lc=(l-lbt)*iklen+mc
7268 DO k=lbk,ubk
7269 kc=(k-lbk)*ilen+lc
7270 DO i=imin,imax
7271 sizes=sizes+1
7272 iks=1+(i-imin)+kc
7273!^ A(i,j,k,l)=recvS(ikS)
7274!^
7275 recvs(iks)=ad_a(i,j,k,l)
7276 ad_a(i,j,k,l)=0.0_r8
7277 END DO
7278 END DO
7279 END DO
7280 END DO
7281 IF (PRESENT(ad_b)) THEN
7282 ioff=iks
7283 DO m=grecvs,1,-1
7284 mc=(grecvs-m)*iktlen
7285 j=jstr-m
7286 DO l=lbt,ubt
7287 lc=(l-lbt)*iklen+mc
7288 DO k=lbk,ubk
7289 kc=(k-lbk)*ilen+lc
7290 DO i=imin,imax
7291 sizes=sizes+1
7292 iks=ioff+1+(i-imin)+kc
7293!^ B(i,Jstr-m,k,l)=recvS(ikS)
7294!^
7295 recvs(iks)=ad_b(i,j,k,l)
7296 ad_b(i,j,k,l)=0.0_r8
7297 END DO
7298 END DO
7299 END DO
7300 END DO
7301 END IF
7302 IF (PRESENT(ad_c)) THEN
7303 ioff=iks
7304 DO m=grecvs,1,-1
7305 mc=(grecvs-m)*iktlen
7306 j=jstr-m
7307 DO l=lbt,ubt
7308 lc=(l-lbt)*iklen+mc
7309 DO k=lbk,ubk
7310 kc=(k-lbk)*ilen+lc
7311 DO i=imin,imax
7312 sizes=sizes+1
7313 iks=ioff+1+(i-imin)+kc
7314!^ C(i,Jstr-m,k,l)=recvS(ikS)
7315!^
7316 recvs(iks)=ad_c(i,j,k,l)
7317 ad_c(i,j,k,l)=0.0_r8
7318 END DO
7319 END DO
7320 END DO
7321 END DO
7322 END IF
7323 END IF
7324!
7325!-----------------------------------------------------------------------
7326! Adjoint of send and receive Southern and Northern segments.
7327!-----------------------------------------------------------------------
7328!
7329# if defined MPI
7330 IF (sexchange) THEN
7331!^ CALL mpi_irecv (recvS, NSsize, MP_FLOAT, Stile, Ntag, &
7332!^ & OCN_COMM_WORLD, Srequest, Serror)
7333!^
7334 CALL mpi_irecv (sends, nssize, mp_float, stile, ntag, &
7335 & ocn_comm_world, srequest, serror)
7336 END IF
7337 IF (nexchange) THEN
7338!^ CALL mpi_irecv (recvN, NSsize, MP_FLOAT, Ntile, Stag, &
7339!^ & OCN_COMM_WORLD, Nrequest, Nerror)
7340!^
7341 CALL mpi_irecv (sendn, nssize, mp_float, ntile, stag, &
7342 & ocn_comm_world, nrequest, nerror)
7343 END IF
7344 IF (sexchange) THEN
7345!^ CALL mpi_send (sendS, sizeS, MP_FLOAT, Stile, Stag, &
7346!^ & OCN_COMM_WORLD, Serror)
7347!^
7348 CALL mpi_send (recvs, sizes, mp_float, stile, stag, &
7349 & ocn_comm_world, serror)
7350 END IF
7351 IF (nexchange) THEN
7352!^ CALL mpi_send (sendN, sizeN, MP_FLOAT, Ntile, Ntag, &
7353!^ & OCN_COMM_WORLD, Nerror)
7354!^
7355 CALL mpi_send (recvn, sizen, mp_float, ntile, ntag, &
7356 & ocn_comm_world, nerror)
7357 END IF
7358# endif
7359!
7360! Adjoint of packing tile boundary data including ghost-points.
7361!
7362 IF (sexchange) THEN
7363# ifdef MPI
7364 CALL mpi_wait (srequest, status(1,2), serror)
7365 IF (serror.ne.mpi_success) THEN
7366 CALL mpi_error_string (serror, string, lstr, ierror)
7367 lstr=len_trim(string)
7368 WRITE (stdout,20) 'MPI_SEND/MPI_IRECV (Southern Edge)', &
7369 & myrank, serror, string(1:lstr)
7370 20 FORMAT (/,' AD_MP_EXCHANGE4D - error during ',a,' call,', &
7371 & ' Node = ', i3.3,' Error = ',i3,/,18x,a)
7372 exit_flag=2
7373 RETURN
7374 END IF
7375# endif
7376 DO m=1,gsends
7377 mc=(m-1)*iktlen
7378 j=jstr+m-1
7379 DO l=lbt,ubt
7380 lc=(l-lbt)*iklen+mc
7381 DO k=lbk,ubk
7382 kc=(k-lbk)*ilen+lc
7383 DO i=imin,imax
7384 iks=1+(i-imin)+kc
7385!^ sendS(ikS)=A(i,j,k,l)
7386!^
7387 ad_a(i,j,k,l)=ad_a(i,j,k,l)+sends(iks)
7388 sends(iks)=0.0_r8
7389 END DO
7390 END DO
7391 END DO
7392 END DO
7393 IF (PRESENT(ad_b)) THEN
7394 ioff=iks
7395 DO m=1,gsends
7396 mc=(m-1)*iktlen
7397 j=jstr+m-1
7398 DO l=lbt,ubt
7399 lc=(l-lbt)*iklen+mc
7400 DO k=lbk,ubk
7401 kc=(k-lbk)*ilen+lc
7402 DO i=imin,imax
7403 iks=ioff+1+(i-imin)+kc
7404!^ sendS(ikS)=B(i,j,k,l)
7405!^
7406 ad_b(i,j,k,l)=ad_b(i,j,k,l)+sends(iks)
7407 sends(iks)=0.0_r8
7408 END DO
7409 END DO
7410 END DO
7411 END DO
7412 END IF
7413 IF (PRESENT(ad_c)) THEN
7414 ioff=iks
7415 DO m=1,gsends
7416 mc=(m-1)*iktlen
7417 j=jstr+m-1
7418 DO l=lbt,ubt
7419 lc=(l-lbt)*iklen+mc
7420 DO k=lbk,ubk
7421 kc=(k-lbk)*ilen+lc
7422 DO i=imin,imax
7423 iks=ioff+1+(i-imin)+kc
7424!^ sendS(ikS)=C(i,j,k,l)
7425!^
7426 ad_c(i,j,k,l)=ad_c(i,j,k,l)+sends(iks)
7427 sends(iks)=0.0_r8
7428 END DO
7429 END DO
7430 END DO
7431 END DO
7432 END IF
7433 END IF
7434!
7435 IF (nexchange) THEN
7436# ifdef MPI
7437 CALL mpi_wait (nrequest, status(1,4), nerror)
7438 IF (nerror.ne.mpi_success) THEN
7439 CALL mpi_error_string (nerror, string, lstr, ierror)
7440 lstr=len_trim(string)
7441 WRITE (stdout,20) 'MPI_SEND/MPI_IRECV (Northern Edge)', &
7442 & myrank, nerror, string(1:lstr)
7443 exit_flag=2
7444 RETURN
7445 END IF
7446# endif
7447 DO m=1,gsendn
7448 mc=(m-1)*iktlen
7449 j=jend-gsendn+m
7450 DO l=lbt,ubt
7451 lc=(l-lbt)*iklen+mc
7452 DO k=lbk,ubk
7453 kc=(k-lbk)*ilen+lc
7454 DO i=imin,imax
7455 ikn=1+(i-imin)+kc
7456!^ sendN(ikN)=A(i,j,k,l)
7457!^
7458 ad_a(i,j,k,l)=ad_a(i,j,k,l)+sendn(ikn)
7459 sendn(ikn)=0.0_r8
7460 END DO
7461 END DO
7462 END DO
7463 END DO
7464 IF (PRESENT(ad_b)) THEN
7465 ioff=ikn
7466 DO m=1,gsendn
7467 mc=(m-1)*iklen
7468 j=jend-gsendn+m
7469 DO l=lbt,ubt
7470 lc=(l-lbt)*iklen+mc
7471 DO k=lbk,ubk
7472 kc=(k-lbk)*ilen+lc
7473 DO i=imin,imax
7474 ikn=ioff+1+(i-imin)+kc
7475!^ sendN(ikN)=B(i,j,k,l)
7476!^
7477 ad_b(i,j,k,l)=ad_b(i,j,k,l)+sendn(ikn)
7478 sendn(ikn)=0.0_r8
7479 END DO
7480 END DO
7481 END DO
7482 END DO
7483 END IF
7484 IF (PRESENT(ad_c)) THEN
7485 ioff=ikn
7486 DO m=1,gsendn
7487 mc=(m-1)*iklen
7488 j=jend-gsendn+m
7489 DO l=lbt,ubt
7490 lc=(l-lbt)*iklen+mc
7491 DO k=lbk,ubk
7492 kc=(k-lbk)*ilen+lc
7493 DO i=imin,imax
7494 ikn=ioff+1+(i-imin)+kc
7495!^ sendN(ikN)=C(i,j,k,l)
7496!^
7497 ad_c(i,j,k,l)=ad_c(i,j,k,l)+sendn(ikn)
7498 sendn(ikn)=0.0_r8
7499 END DO
7500 END DO
7501 END DO
7502 END DO
7503 END IF
7504 END IF
7505!
7506!-----------------------------------------------------------------------
7507! Adjoint of unpack Eastern and Western segments.
7508!-----------------------------------------------------------------------
7509!
7510 IF (eexchange) THEN
7511 DO i=1,buffersizeew
7512 recve(i)=0.0_r8
7513 sende(i)=0.0_r8
7514 END DO
7515 sizee=0
7516 DO m=1,grecve
7517 mc=(m-1)*jktlen
7518 i=iend+m
7519 DO l=lbt,ubt
7520 lc=(l-lbt)*jklen+mc
7521 DO k=lbk,ubk
7522 kc=(k-lbk)*jlen+lc
7523 DO j=jmin,jmax
7524 sizee=sizee+1
7525 jke=1+(j-jmin)+kc
7526!^ A(i,j,k,l)=recvE(jkE)
7527!^
7528 recve(jke)=ad_a(i,j,k,l)
7529 ad_a(i,j,k,l)=0.0_r8
7530 END DO
7531 END DO
7532 ENDDO
7533 END DO
7534 IF (PRESENT(ad_b)) THEN
7535 joff=jke
7536 DO m=1,grecve
7537 mc=(m-1)*jktlen
7538 i=iend+m
7539 DO l=lbt,ubt
7540 lc=(l-lbt)*jklen+mc
7541 DO k=lbk,ubk
7542 kc=(k-lbk)*jlen+lc
7543 DO j=jmin,jmax
7544 sizee=sizee+1
7545 jke=joff+1+(j-jmin)+kc
7546!^ B(i,j,k,l)=recvE(jkE)
7547!^
7548 recve(jke)=ad_b(i,j,k,l)
7549 ad_b(i,j,k,l)=0.0_r8
7550 END DO
7551 END DO
7552 END DO
7553 END DO
7554 END IF
7555 IF (PRESENT(ad_c)) THEN
7556 joff=jke
7557 DO m=1,grecve
7558 mc=(m-1)*jktlen
7559 i=iend+m
7560 DO l=lbt,ubt
7561 lc=(l-lbt)*jklen+mc
7562 DO k=lbk,ubk
7563 kc=(k-lbk)*jlen+lc
7564 DO j=jmin,jmax
7565 sizee=sizee+1
7566 jke=joff+1+(j-jmin)+kc
7567!^ C(i,j,k,l)=recvE(jkE)
7568!^
7569 recve(jke)=ad_c(i,j,k,l)
7570 ad_c(i,j,k,l)=0.0_r8
7571 END DO
7572 END DO
7573 END DO
7574 END DO
7575 END IF
7576 END IF
7577!
7578 IF (wexchange) THEN
7579 DO i=1,buffersizeew
7580 recvw(i)=0.0_r8
7581 sendw(i)=0.0_r8
7582 END DO
7583 sizew=0
7584 DO m=grecvw,1,-1
7585 mc=(grecvw-m)*jktlen
7586 i=istr-m
7587 DO l=lbt,ubt
7588 lc=(l-lbt)*jklen+mc
7589 DO k=lbk,ubk
7590 kc=(k-lbk)*jlen+lc
7591 DO j=jmin,jmax
7592 sizew=sizew+1
7593 jkw=1+(j-jmin)+kc
7594!^ A(i,j,k,l)=recvW(jkW)
7595!^
7596 recvw(jkw)=ad_a(i,j,k,l)
7597 ad_a(i,j,k,l)=0.0_r8
7598 END DO
7599 END DO
7600 END DO
7601 END DO
7602 IF (PRESENT(ad_b)) THEN
7603 joff=jkw
7604 DO m=grecvw,1,-1
7605 mc=(grecvw-m)*jktlen
7606 i=istr-m
7607 DO l=lbt,ubt
7608 lc=(l-lbt)*jklen+mc
7609 DO k=lbk,ubk
7610 kc=(k-lbk)*jlen+lc
7611 DO j=jmin,jmax
7612 sizew=sizew+1
7613 jkw=joff+1+(j-jmin)+kc
7614!^ B(i,j,k,l)=recvW(jkW)
7615!^
7616 recvw(jkw)=ad_b(i,j,k,l)
7617 ad_b(i,j,k,l)=0.0_r8
7618 END DO
7619 END DO
7620 END DO
7621 END DO
7622 END IF
7623 IF (PRESENT(ad_c)) THEN
7624 joff=jkw
7625 DO m=grecvw,1,-1
7626 mc=(grecvw-m)*jktlen
7627 i=istr-m
7628 DO l=lbt,ubt
7629 lc=(l-lbt)*jklen+mc
7630 DO k=lbk,ubk
7631 kc=(k-lbk)*jlen+lc
7632 DO j=jmin,jmax
7633 sizew=sizew+1
7634 jkw=joff+1+(j-jmin)+kc
7635!^ C(i,j,k,l)=recvW(jkW)
7636!^
7637 recvw(jkw)=ad_c(i,j,k,l)
7638 ad_c(i,j,k,l)=0.0_r8
7639 END DO
7640 END DO
7641 END DO
7642 END DO
7643 END IF
7644 END IF
7645!
7646!-----------------------------------------------------------------------
7647! Send and receive Western and Eastern segments.
7648!-----------------------------------------------------------------------
7649!
7650# if defined MPI
7651 IF (wexchange) THEN
7652!^ CALL mpi_irecv (recvW, EWsize, MP_FLOAT, Wtile, Etag, &
7653!^ & OCN_COMM_WORLD, Wrequest, Werror)
7654!^
7655 CALL mpi_irecv (sendw, ewsize, mp_float, wtile, etag, &
7656 & ocn_comm_world, wrequest, werror)
7657 END IF
7658 IF (eexchange) THEN
7659!^ CALL mpi_irecv (recvE, EWsize, MP_FLOAT, Etile, Wtag, &
7660!^ & OCN_COMM_WORLD, Erequest, Eerror)
7661!^
7662 CALL mpi_irecv (sende, ewsize, mp_float, etile, wtag, &
7663 & ocn_comm_world, erequest, eerror)
7664 END IF
7665 IF (wexchange) THEN
7666!^ CALL mpi_send (sendW, sizeW, MP_FLOAT, Wtile, Wtag, &
7667!^ & OCN_COMM_WORLD, Werror)
7668!^
7669 CALL mpi_send (recvw, sizew, mp_float, wtile, wtag, &
7670 & ocn_comm_world, werror)
7671 END IF
7672 IF (eexchange) THEN
7673!^ CALL mpi_send (sendE, sizeE, MP_FLOAT, Etile, Etag, &
7674!^ & OCN_COMM_WORLD, Eerror)
7675!^
7676 CALL mpi_send (recve, sizee, mp_float, etile, etag, &
7677 & ocn_comm_world, eerror)
7678 END IF
7679# endif
7680!
7681! Adjoint of packing tile boundary data including ghost-points.
7682!
7683 IF (wexchange) THEN
7684# ifdef MPI
7685 CALL mpi_wait (wrequest, status(1,1), werror)
7686 IF (werror.ne.mpi_success) THEN
7687 CALL mpi_error_string (werror, string, lstr, ierror)
7688 lstr=len_trim(string)
7689 WRITE (stdout,20) 'MPI_SEND/MPI_IRECV (Western Edge)', &
7690 & myrank, werror, string(1:lstr)
7691 exit_flag=2
7692 RETURN
7693 END IF
7694# endif
7695 DO m=1,gsendw
7696 mc=(m-1)*jktlen
7697 i=istr+m-1
7698 DO l=lbt,ubt
7699 lc=(l-lbt)*jklen+mc
7700 DO k=lbk,ubk
7701 kc=(k-lbk)*jlen+lc
7702 DO j=jmin,jmax
7703 jkw=1+(j-jmin)+kc
7704!^ sendW(jkW)=A(i,j,k,l)
7705!^
7706 ad_a(i,j,k,l)=ad_a(i,j,k,l)+sendw(jkw)
7707 sendw(jkw)=0.0_r8
7708 END DO
7709 END DO
7710 END DO
7711 END DO
7712 IF (PRESENT(ad_b)) THEN
7713 joff=jkw
7714 DO m=1,gsendw
7715 mc=(m-1)*jktlen
7716 i=istr+m-1
7717 DO l=lbt,ubt
7718 lc=(l-lbt)*jklen+mc
7719 DO k=lbk,ubk
7720 kc=(k-lbk)*jlen+lc
7721 DO j=jmin,jmax
7722 jkw=joff+1+(j-jmin)+kc
7723!^ sendW(jkW)=B(i,j,k,l)
7724!^
7725 ad_b(i,j,k,l)=ad_b(i,j,k,l)+sendw(jkw)
7726 sendw(jkw)=0.0_r8
7727 END DO
7728 END DO
7729 END DO
7730 END DO
7731 END IF
7732 IF (PRESENT(ad_c)) THEN
7733 joff=jkw
7734 DO m=1,gsendw
7735 mc=(m-1)*jktlen
7736 i=istr+m-1
7737 DO l=lbt,ubt
7738 lc=(l-lbt)*jklen+mc
7739 DO k=lbk,ubk
7740 kc=(k-lbk)*jlen+lc
7741 DO j=jmin,jmax
7742 jkw=joff+1+(j-jmin)+kc
7743!^ sendW(jkW)=C(i,j,k,l)
7744!^
7745 ad_c(i,j,k,l)=ad_c(i,j,k,l)+sendw(jkw)
7746 sendw(jkw)=0.0_r8
7747 END DO
7748 END DO
7749 END DO
7750 END DO
7751 END IF
7752 END IF
7753!
7754 IF (eexchange) THEN
7755# ifdef MPI
7756 CALL mpi_wait (erequest, status(1,3), eerror)
7757 IF (eerror.ne.mpi_success) THEN
7758 CALL mpi_error_string (eerror, string, lstr, ierror)
7759 lstr=len_trim(string)
7760 WRITE (stdout,20) 'MPI_SEND/MPI_IRECV (Eastern Edge)', &
7761 & myrank, eerror, string(1:lstr)
7762 exit_flag=2
7763 RETURN
7764 END IF
7765# endif
7766 DO m=1,gsende
7767 mc=(m-1)*jktlen
7768 i=iend-gsende+m
7769 DO l=lbt,ubt
7770 lc=(l-lbt)*jklen+mc
7771 DO k=lbk,ubk
7772 kc=(k-lbk)*jlen+lc
7773 DO j=jmin,jmax
7774 jke=1+(j-jmin)+kc
7775!^ sendE(jkE)=A(i,j,k,l)
7776!^
7777 ad_a(i,j,k,l)=ad_a(i,j,k,l)+sende(jke)
7778 sende(jke)=0.0_r8
7779 END DO
7780 END DO
7781 END DO
7782 END DO
7783 IF (PRESENT(ad_b)) THEN
7784 joff=jke
7785 DO m=1,gsende
7786 mc=(m-1)*jktlen
7787 i=iend-gsende+m
7788 DO l=lbt,ubt
7789 lc=(l-lbt)*jklen+mc
7790 DO k=lbk,ubk
7791 kc=(k-lbk)*jlen+lc
7792 DO j=jmin,jmax
7793 jke=joff+1+(j-jmin)+kc
7794!^ sendE(jkE)=B(i,j,k,l)
7795!^
7796 ad_b(i,j,k,l)=ad_b(i,j,k,l)+sende(jke)
7797 sende(jke)=0.0_r8
7798 END DO
7799 END DO
7800 END DO
7801 END DO
7802 END IF
7803 IF (PRESENT(ad_c)) THEN
7804 joff=jke
7805 DO m=1,gsende
7806 mc=(m-1)*jktlen
7807 i=iend-gsende+m
7808 DO l=lbt,ubt
7809 lc=(l-lbt)*jklen+mc
7810 DO k=lbk,ubk
7811 kc=(k-lbk)*jlen+lc
7812 DO j=jmin,jmax
7813 jke=joff+1+(j-jmin)+kc
7814!^ sendE(jkE)=C(i,j,k,l)
7815!^
7816 ad_c(i,j,k,l)=ad_c(i,j,k,l)+sende(jke)
7817 sende(jke)=0.0_r8
7818 END DO
7819 END DO
7820 END DO
7821 END DO
7822 END IF
7823 END IF
7824# ifdef PROFILE
7825!
7826!-----------------------------------------------------------------------
7827! Turn off time clocks.
7828!-----------------------------------------------------------------------
7829!
7830 CALL wclock_off (ng, model, 62, __line__, myfile)
7831# endif
7832!
7833 RETURN
7834

References mod_param::bmemmax, mod_scalars::exit_flag, mod_param::halosizei, mod_param::halosizej, mod_parallel::mp_float, mod_parallel::myrank, mod_parallel::ocn_comm_world, mod_iounits::stdout, tile_neighbors(), wclock_off(), and wclock_on().

Referenced by ad_convolution_mod::ad_convolution_tile(), ad_nesting_mod::ad_correct_tracer_tile(), ad_nesting_mod::ad_fine2coarse(), ad_ini_fields_mod::ad_ini_fields_tile(), ad_ini_fields_mod::ad_out_fields_tile(), ad_pack_tile(), ad_pre_step3d_mod::ad_pre_step3d_tile(), ad_nesting_mod::ad_put_composite(), ad_nesting_mod::ad_put_refine3d(), ad_step3d_t_mod::ad_step3d_t_tile(), and ad_variability_mod::ad_variability_tile().

Here is the call graph for this function:
Here is the caller graph for this function:

◆ mp_exchange2d()

subroutine mp_exchange_mod::mp_exchange2d ( integer, intent(in) ng,
integer, intent(in) tile,
integer, intent(in) model,
integer, intent(in) nvar,
integer, intent(in) lbi,
integer, intent(in) ubi,
integer, intent(in) lbj,
integer, intent(in) ubj,
integer, intent(in) nghost,
logical, intent(in) ew_periodic,
logical, intent(in) ns_periodic,
real(r8), dimension(lbi:,lbj:), intent(inout) a,
real(r8), dimension(lbi:,lbj:), intent(inout), optional b,
real(r8), dimension(lbi:,lbj:), intent(inout), optional c,
real(r8), dimension(lbi:,lbj:), intent(inout), optional d )

Definition at line 290 of file mp_exchange.F.

294!***********************************************************************
295!
296 USE mod_param
297 USE mod_parallel
298 USE mod_iounits
299 USE mod_scalars
300!
301 implicit none
302!
303! Imported variable declarations.
304!
305 logical, intent(in) :: EW_periodic, NS_periodic
306!
307 integer, intent(in) :: ng, tile, model, Nvar
308 integer, intent(in) :: LBi, UBi, LBj, UBj
309 integer, intent(in) :: Nghost
310!
311# ifdef ASSUMED_SHAPE
312 real(r8), intent(inout) :: A(LBi:,LBj:)
313
314 real(r8), intent(inout), optional :: B(LBi:,LBj:)
315 real(r8), intent(inout), optional :: C(LBi:,LBj:)
316 real(r8), intent(inout), optional :: D(LBi:,LBj:)
317# else
318 real(r8), intent(inout) :: A(LBi:UBi,LBj:UBj)
319
320 real(r8), intent(inout), optional :: B(LBi:UBi,LBj:UBj)
321 real(r8), intent(inout), optional :: C(LBi:UBi,LBj:UBj)
322 real(r8), intent(inout), optional :: D(LBi:UBi,LBj:UBj)
323# endif
324!
325! Local variable declarations.
326!
327 logical :: Wexchange, Sexchange, Eexchange, Nexchange
328!
329 integer :: i, icS, icN, ioff, Imin, Imax, Ilen
330 integer :: j, jcW, jcE, joff, Jmin, Jmax, Jlen
331 integer :: m, mc, Ierror, Lstr, pp
332 integer :: Wtile, GsendW, GrecvW, Wtag, Werror, Wrequest
333 integer :: Stile, GsendS, GrecvS, Stag, Serror, Srequest
334 integer :: Etile, GsendE, GrecvE, Etag, Eerror, Erequest
335 integer :: Ntile, GsendN, GrecvN, Ntag, Nerror, Nrequest
336 integer :: EWsize, sizeW, sizeE
337 integer :: NSsize, sizeS, sizeN
338
339# ifdef MPI
340 integer, dimension(MPI_STATUS_SIZE,4) :: status
341# endif
342!
343 real(r8), dimension(Nvar*HaloSizeJ(ng)) :: sendW, sendE
344 real(r8), dimension(Nvar*HaloSizeJ(ng)) :: recvW, recvE
345
346 real(r8), dimension(Nvar*HaloSizeI(ng)) :: sendS, sendN
347 real(r8), dimension(Nvar*HaloSizeI(ng)) :: recvS, recvN
348!
349 character (len=MPI_MAX_ERROR_STRING) :: string
350
351 character (len=*), parameter :: MyFile = &
352 & __FILE__//", mp_exchange2d"
353
354# include "set_bounds.h"
355
356# ifdef PROFILE
357!
358!-----------------------------------------------------------------------
359! Turn on time clocks.
360!-----------------------------------------------------------------------
361!
362 CALL wclock_on (ng, model, 60, __line__, myfile)
363# endif
364!
365!-----------------------------------------------------------------------
366! Determine rank of tile neighbors and number of ghost-points to
367! exchange.
368!-----------------------------------------------------------------------
369!
370! Maximum automatic buffer memory size in bytes.
371!
372 bmemmax(ng)=max(bmemmax(ng), real((4*SIZE(sendw)+ &
373 & 4*SIZE(sends))*kind(a),r8))
374!
375 CALL tile_neighbors (ng, nghost, ew_periodic, ns_periodic, &
376 & grecvw, gsendw, wtile, wexchange, &
377 & grecve, gsende, etile, eexchange, &
378 & grecvs, gsends, stile, sexchange, &
379 & grecvn, gsendn, ntile, nexchange)
380!
381! Set communication tags.
382!
383 wtag=1
384 stag=2
385 etag=3
386 ntag=4
387!
388! Determine range and length of the distributed tile boundary segments.
389!
390 imin=lbi
391 imax=ubi
392 jmin=lbj
393 jmax=ubj
394 ilen=imax-imin+1
395 jlen=jmax-jmin+1
396 IF (ew_periodic.or.ns_periodic) THEN
397 pp=1
398 ELSE
399 pp=0
400 END IF
401 ewsize=nvar*(nghost+pp)*jlen
402 nssize=nvar*(nghost+pp)*ilen
403 IF (SIZE(sende).lt.ewsize) THEN
404 WRITE (stdout,10) 'EWsize = ', ewsize, SIZE(sende)
405 10 FORMAT (/,' MP_EXCHANGE2D - communication buffer too small, ', &
406 & a, 2i8)
407 END IF
408 IF (SIZE(sendn).lt.nssize) THEN
409 WRITE (stdout,10) 'NSsize = ', nssize, SIZE(sendn)
410 END IF
411!
412!-----------------------------------------------------------------------
413! Pack Western and Eastern tile boundary data including ghost-points.
414!-----------------------------------------------------------------------
415!
416 IF (wexchange) THEN
417 sizew=0
418 DO m=1,gsendw
419 mc=(m-1)*jlen
420 i=istr+m-1
421 DO j=jmin,jmax
422 sizew=sizew+1
423 jcw=1+(j-jmin)+mc
424 sendw(jcw)=a(i,j)
425 END DO
426 END DO
427 IF (PRESENT(b)) THEN
428 joff=jcw
429 DO m=1,gsendw
430 mc=(m-1)*jlen
431 i=istr+m-1
432 DO j=jmin,jmax
433 sizew=sizew+1
434 jcw=joff+1+(j-jmin)+mc
435 sendw(jcw)=b(i,j)
436 END DO
437 END DO
438 END IF
439 IF (PRESENT(c)) THEN
440 joff=jcw
441 DO m=1,gsendw
442 mc=(m-1)*jlen
443 i=istr+m-1
444 DO j=jmin,jmax
445 sizew=sizew+1
446 jcw=joff+1+(j-jmin)+mc
447 sendw(jcw)=c(i,j)
448 END DO
449 END DO
450 END IF
451 IF (PRESENT(d)) THEN
452 joff=jcw
453 DO m=1,gsendw
454 mc=(m-1)*jlen
455 i=istr+m-1
456 DO j=jmin,jmax
457 sizew=sizew+1
458 jcw=joff+1+(j-jmin)+mc
459 sendw(jcw)=d(i,j)
460 END DO
461 END DO
462 END IF
463 END IF
464!
465 IF (eexchange) THEN
466 sizee=0
467 DO m=1,gsende
468 mc=(m-1)*jlen
469 i=iend-gsende+m
470 DO j=jmin,jmax
471 sizee=sizee+1
472 jce=1+(j-jmin)+mc
473 sende(jce)=a(i,j)
474 END DO
475 END DO
476 IF (PRESENT(b)) THEN
477 joff=jce
478 DO m=1,gsende
479 mc=(m-1)*jlen
480 i=iend-gsende+m
481 DO j=jmin,jmax
482 sizee=sizee+1
483 jce=joff+1+(j-jmin)+mc
484 sende(jce)=b(i,j)
485 END DO
486 END DO
487 END IF
488 IF (PRESENT(c)) THEN
489 joff=jce
490 DO m=1,gsende
491 mc=(m-1)*jlen
492 i=iend-gsende+m
493 DO j=jmin,jmax
494 sizee=sizee+1
495 jce=joff+1+(j-jmin)+mc
496 sende(jce)=c(i,j)
497 END DO
498 END DO
499 END IF
500 IF (PRESENT(d)) THEN
501 joff=jce
502 DO m=1,gsende
503 mc=(m-1)*jlen
504 i=iend-gsende+m
505 DO j=jmin,jmax
506 sizee=sizee+1
507 jce=joff+1+(j-jmin)+mc
508 sende(jce)=d(i,j)
509 END DO
510 END DO
511 END IF
512 END IF
513!
514!-----------------------------------------------------------------------
515! Send and receive Western and Eastern segments.
516!-----------------------------------------------------------------------
517!
518# if defined MPI
519 IF (wexchange) THEN
520 CALL mpi_irecv (recvw, ewsize, mp_float, wtile, etag, &
521 & ocn_comm_world, wrequest, werror)
522 END IF
523 IF (eexchange) THEN
524 CALL mpi_irecv (recve, ewsize, mp_float, etile, wtag, &
525 & ocn_comm_world, erequest, eerror)
526 END IF
527 IF (wexchange) THEN
528 CALL mpi_send (sendw, sizew, mp_float, wtile, wtag, &
529 & ocn_comm_world, werror)
530 END IF
531 IF (eexchange) THEN
532 CALL mpi_send (sende, sizee, mp_float, etile, etag, &
533 & ocn_comm_world, eerror)
534 END IF
535# endif
536!
537!-----------------------------------------------------------------------
538! Unpack Western and Eastern segments.
539!-----------------------------------------------------------------------
540!
541 IF (wexchange) THEN
542# ifdef MPI
543 CALL mpi_wait (wrequest, status(1,1), werror)
544 IF (werror.ne.mpi_success) THEN
545 CALL mpi_error_string (werror, string, lstr, ierror)
546 lstr=len_trim(string)
547 WRITE (stdout,20) 'MPI_SEND/MPI_IRECV (Western Edge)', &
548 & myrank, werror, string(1:lstr)
549 20 FORMAT (/,' MP_EXCHANGE2D - error during ',a, &
550 & ' call, Node = ',i3.3,' Error = ',i3,/,15x,a)
551 exit_flag=2
552 RETURN
553 END IF
554# endif
555 DO m=grecvw,1,-1
556 mc=(grecvw-m)*jlen
557 i=istr-m
558 DO j=jmin,jmax
559 jcw=1+(j-jmin)+mc
560 a(i,j)=recvw(jcw)
561 END DO
562 END DO
563 IF (PRESENT(b)) THEN
564 joff=jcw
565 DO m=grecvw,1,-1
566 mc=(grecvw-m)*jlen
567 i=istr-m
568 DO j=jmin,jmax
569 jcw=joff+1+(j-jmin)+mc
570 b(i,j)=recvw(jcw)
571 END DO
572 END DO
573 END IF
574 IF (PRESENT(c)) THEN
575 joff=jcw
576 DO m=grecvw,1,-1
577 mc=(grecvw-m)*jlen
578 i=istr-m
579 DO j=jmin,jmax
580 jcw=joff+1+(j-jmin)+mc
581 c(i,j)=recvw(jcw)
582 END DO
583 END DO
584 END IF
585 IF (PRESENT(d)) THEN
586 joff=jcw
587 DO m=grecvw,1,-1
588 mc=(grecvw-m)*jlen
589 i=istr-m
590 DO j=jmin,jmax
591 jcw=joff+1+(j-jmin)+mc
592 d(i,j)=recvw(jcw)
593 END DO
594 END DO
595 END IF
596 END IF
597!
598 IF (eexchange) THEN
599# ifdef MPI
600 CALL mpi_wait (erequest, status(1,3), eerror)
601 IF (eerror.ne.mpi_success) THEN
602 CALL mpi_error_string (eerror, string, lstr, ierror)
603 lstr=len_trim(string)
604 WRITE (stdout,20) 'MPI_SEND/MPI_IRECV (Eastern Edge)', &
605 & myrank, eerror, string(1:lstr)
606 exit_flag=2
607 RETURN
608 END IF
609# endif
610 DO m=1,grecve
611 mc=(m-1)*jlen
612 i=iend+m
613 DO j=jmin,jmax
614 jce=1+(j-jmin)+mc
615 a(i,j)=recve(jce)
616 ENDDO
617 END DO
618 IF (PRESENT(b)) THEN
619 joff=jce
620 DO m=1,grecve
621 mc=(m-1)*jlen
622 i=iend+m
623 DO j=jmin,jmax
624 jce=joff+1+(j-jmin)+mc
625 b(i,j)=recve(jce)
626 ENDDO
627 END DO
628 END IF
629 IF (PRESENT(c)) THEN
630 joff=jce
631 DO m=1,grecve
632 mc=(m-1)*jlen
633 i=iend+m
634 DO j=jmin,jmax
635 jce=joff+1+(j-jmin)+mc
636 c(i,j)=recve(jce)
637 ENDDO
638 END DO
639 END IF
640 IF (PRESENT(d)) THEN
641 joff=jce
642 DO m=1,grecve
643 mc=(m-1)*jlen
644 i=iend+m
645 DO j=jmin,jmax
646 jce=joff+1+(j-jmin)+mc
647 d(i,j)=recve(jce)
648 ENDDO
649 END DO
650 END IF
651 END IF
652!
653!-----------------------------------------------------------------------
654! Pack Southern and Northern tile boundary data including ghost-points.
655!-----------------------------------------------------------------------
656!
657 IF (sexchange) THEN
658 sizes=0
659 DO m=1,gsends
660 mc=(m-1)*ilen
661 j=jstr+m-1
662 DO i=imin,imax
663 sizes=sizes+1
664 ics=1+(i-imin)+mc
665 sends(ics)=a(i,j)
666 END DO
667 END DO
668 IF (PRESENT(b)) THEN
669 ioff=ics
670 DO m=1,gsends
671 mc=(m-1)*ilen
672 j=jstr+m-1
673 DO i=imin,imax
674 sizes=sizes+1
675 ics=ioff+1+(i-imin)+mc
676 sends(ics)=b(i,j)
677 END DO
678 END DO
679 END IF
680 IF (PRESENT(c)) THEN
681 ioff=ics
682 DO m=1,gsends
683 mc=(m-1)*ilen
684 j=jstr+m-1
685 DO i=imin,imax
686 sizes=sizes+1
687 ics=ioff+1+(i-imin)+mc
688 sends(ics)=c(i,j)
689 END DO
690 END DO
691 END IF
692 IF (PRESENT(d)) THEN
693 ioff=ics
694 DO m=1,gsends
695 mc=(m-1)*ilen
696 j=jstr+m-1
697 DO i=imin,imax
698 sizes=sizes+1
699 ics=ioff+1+(i-imin)+mc
700 sends(ics)=d(i,j)
701 END DO
702 END DO
703 END IF
704 END IF
705!
706 IF (nexchange) THEN
707 sizen=0
708 DO m=1,gsendn
709 mc=(m-1)*ilen
710 j=jend-gsendn+m
711 DO i=imin,imax
712 sizen=sizen+1
713 icn=1+(i-imin)+mc
714 sendn(icn)=a(i,j)
715 END DO
716 END DO
717 IF (PRESENT(b)) THEN
718 ioff=icn
719 DO m=1,gsendn
720 mc=(m-1)*ilen
721 j=jend-gsendn+m
722 DO i=imin,imax
723 sizen=sizen+1
724 icn=ioff+1+(i-imin)+mc
725 sendn(icn)=b(i,j)
726 END DO
727 END DO
728 END IF
729 IF (PRESENT(c)) THEN
730 ioff=icn
731 DO m=1,gsendn
732 mc=(m-1)*ilen
733 j=jend-gsendn+m
734 DO i=imin,imax
735 sizen=sizen+1
736 icn=ioff+1+(i-imin)+mc
737 sendn(icn)=c(i,j)
738 END DO
739 END DO
740 END IF
741 IF (PRESENT(d)) THEN
742 ioff=icn
743 DO m=1,gsendn
744 mc=(m-1)*ilen
745 j=jend-gsendn+m
746 DO i=imin,imax
747 sizen=sizen+1
748 icn=ioff+1+(i-imin)+mc
749 sendn(icn)=d(i,j)
750 END DO
751 END DO
752 END IF
753 END IF
754!
755!-----------------------------------------------------------------------
756! Send and receive Southern and Northern segments.
757!-----------------------------------------------------------------------
758!
759# if defined MPI
760 IF (sexchange) THEN
761 CALL mpi_irecv (recvs, nssize, mp_float, stile, ntag, &
762 & ocn_comm_world, srequest, serror)
763 END IF
764 IF (nexchange) THEN
765 CALL mpi_irecv (recvn, nssize, mp_float, ntile, stag, &
766 & ocn_comm_world, nrequest, nerror)
767 END IF
768 IF (sexchange) THEN
769 CALL mpi_send (sends, sizes, mp_float, stile, stag, &
770 & ocn_comm_world, serror)
771 END IF
772 IF (nexchange) THEN
773 CALL mpi_send (sendn, sizen, mp_float, ntile, ntag, &
774 & ocn_comm_world, nerror)
775 END IF
776# endif
777!
778!-----------------------------------------------------------------------
779! Unpack Northern and Southern segments.
780!-----------------------------------------------------------------------
781!
782 IF (sexchange) THEN
783# ifdef MPI
784 CALL mpi_wait (srequest, status(1,2), serror)
785 IF (serror.ne.mpi_success) THEN
786 CALL mpi_error_string (serror, string, lstr, ierror)
787 lstr=len_trim(string)
788 WRITE (stdout,20) 'MPI_SEND/MPI_IRECV (Southern Edge)', &
789 & myrank, serror, string(1:lstr)
790 exit_flag=2
791 RETURN
792 END IF
793# endif
794 DO m=grecvs,1,-1
795 mc=(grecvs-m)*ilen
796 j=jstr-m
797 DO i=imin,imax
798 ics=1+(i-imin)+mc
799 a(i,j)=recvs(ics)
800 END DO
801 END DO
802 IF (PRESENT(b)) THEN
803 ioff=ics
804 DO m=grecvs,1,-1
805 mc=(grecvs-m)*ilen
806 j=jstr-m
807 DO i=imin,imax
808 ics=ioff+1+(i-imin)+mc
809 b(i,j)=recvs(ics)
810 END DO
811 END DO
812 END IF
813 IF (PRESENT(c)) THEN
814 ioff=ics
815 DO m=grecvs,1,-1
816 mc=(grecvs-m)*ilen
817 j=jstr-m
818 DO i=imin,imax
819 ics=ioff+1+(i-imin)+mc
820 c(i,j)=recvs(ics)
821 END DO
822 END DO
823 END IF
824 IF (PRESENT(d)) THEN
825 ioff=ics
826 DO m=grecvs,1,-1
827 mc=(grecvs-m)*ilen
828 j=jstr-m
829 DO i=imin,imax
830 ics=ioff+1+(i-imin)+mc
831 d(i,j)=recvs(ics)
832 END DO
833 END DO
834 END IF
835 END IF
836!
837 IF (nexchange) THEN
838# ifdef MPI
839 CALL mpi_wait (nrequest, status(1,4), nerror)
840 IF (nerror.ne.mpi_success) THEN
841 CALL mpi_error_string (nerror, string, lstr, ierror)
842 lstr=len_trim(string)
843 WRITE (stdout,20) 'MPI_SEND/MPI_IRECV (Northern Edge)', &
844 & myrank, nerror, string(1:lstr)
845 exit_flag=2
846 RETURN
847 END IF
848# endif
849 DO m=1,grecvn
850 mc=(m-1)*ilen
851 j=jend+m
852 DO i=imin,imax
853 icn=1+(i-imin)+mc
854 a(i,j)=recvn(icn)
855 END DO
856 END DO
857 IF (PRESENT(b)) THEN
858 ioff=icn
859 DO m=1,grecvn
860 mc=(m-1)*ilen
861 j=jend+m
862 DO i=imin,imax
863 icn=ioff+1+(i-imin)+mc
864 b(i,j)=recvn(icn)
865 END DO
866 END DO
867 END IF
868 IF (PRESENT(c)) THEN
869 ioff=icn
870 DO m=1,grecvn
871 mc=(m-1)*ilen
872 j=jend+m
873 DO i=imin,imax
874 icn=ioff+1+(i-imin)+mc
875 c(i,j)=recvn(icn)
876 END DO
877 END DO
878 END IF
879 IF (PRESENT(d)) THEN
880 ioff=icn
881 DO m=1,grecvn
882 mc=(m-1)*ilen
883 j=jend+m
884 DO i=imin,imax
885 icn=ioff+1+(i-imin)+mc
886 d(i,j)=recvn(icn)
887 END DO
888 END DO
889 END IF
890 END IF
891
892# ifdef PROFILE
893!
894!-----------------------------------------------------------------------
895! Turn off time clocks.
896!-----------------------------------------------------------------------
897!
898 CALL wclock_off (ng, model, 60, __line__, myfile)
899# endif
900!
901 RETURN

References mod_param::bmemmax, mod_scalars::exit_flag, mod_parallel::mp_float, mod_parallel::myrank, mod_parallel::ocn_comm_world, mod_iounits::stdout, tile_neighbors(), wclock_off(), and wclock_on().

Referenced by zeta_balance_mod::ad_biconj_tile(), ad_set_data_tile(), ad_step2d_mod::ad_step2d_tile(), ad_step2d_mod::ad_step2d_tile(), ad_step2d_mod::ad_step2d_tile(), analytical_mod::ana_cloud_tile(), analytical_mod::ana_dqdsst_tile(), analytical_mod::ana_drag_tile(), ana_grid_tile(), analytical_mod::ana_humid_tile(), analytical_mod::ana_m2clima_tile(), analytical_mod::ana_mask_tile(), analytical_mod::ana_nudgcoef_tile(), analytical_mod::ana_pair_tile(), analytical_mod::ana_rain_tile(), analytical_mod::ana_scope_tile(), analytical_mod::ana_smflux_tile(), analytical_mod::ana_sponge_tile(), analytical_mod::ana_srflux_tile(), analytical_mod::ana_ssh_tile(), analytical_mod::ana_sss_tile(), analytical_mod::ana_sst_tile(), analytical_mod::ana_stflux_tile(), analytical_mod::ana_tair_tile(), analytical_mod::ana_winds_tile(), analytical_mod::ana_wtype_tile(), analytical_mod::ana_wwave_tile(), zeta_balance_mod::balance_ref_tile(), zeta_balance_mod::biconj_tile(), bulk_flux_mod::bulk_flux_tile(), conv_2d_mod::conv_r2d_tile(), conv_2d_mod::conv_u2d_tile(), conv_2d_mod::conv_v2d_tile(), nesting_mod::fine2coarse(), get_grid_mod::get_grid_nf90(), get_grid_mod::get_grid_pio(), get_nudgcoef_mod::get_nudgcoef_nf90(), get_nudgcoef_mod::get_nudgcoef_pio(), get_state_mod::get_state_nf90(), get_state_mod::get_state_pio(), get_wetdry_mod::get_wetdry_nf90(), get_wetdry_mod::get_wetdry_pio(), ice_advect_mod::ice_advect_tile(), ice_thermo_mod::ice_thermo_tile(), ini_fields_mod::ini_fields_tile(), ini_hmixcoef_mod::ini_hmixcoef_tile(), ini_adjust_mod::ini_perturb_tile(), ini_fields_mod::ini_zeta_tile(), lmd_bkpp_tile(), lmd_skpp_tile(), bbl_mod::mb_bbl_tile(), metrics_mod::metrics_tile(), distribute_mod::mp_scatter2d(), normalization_mod::normalization_tile(), nesting_mod::put_composite(), nesting_mod::put_refine2d(), random_ic_mod::random_ic_tile(), normalization_mod::randomization_tile(), regrid_mod::regrid_nf90(), regrid_mod::regrid_pio(), rho_eos_mod::rho_eos_tile(), cmeps_roms_mod::roms_import(), esmf_roms_mod::roms_import(), cmeps_roms_mod::roms_rotate(), esmf_roms_mod::roms_rotate(), rp_set_depth_mod::rp_bath_tile(), rp_bulk_flux_mod::rp_bulk_flux_tile(), rp_ini_fields_mod::rp_ini_fields_tile(), rp_ini_fields_mod::rp_ini_zeta_tile(), rp_rho_eos_mod::rp_rho_eos_tile(), rp_set_data_tile(), rp_set_depth_mod::rp_set_depth_tile(), rp_obc_volcons_mod::rp_set_duv_bc_tile(), rp_set_vbc_mod::rp_set_vbc_tile(), rp_set_zeta_mod::rp_set_zeta_tile(), rp_ini_fields_mod::rp_set_zeta_timeavg_tile(), rp_step2d_mod::rp_step2d_tile(), rp_step2d_mod::rp_step2d_tile(), rp_step2d_mod::rp_step2d_tile(), rp_step3d_uv_mod::rp_step3d_uv_tile(), set_2dfld_mod::set_2dfld_tile(), set_2dfldr_mod::set_2dfldr_tile(), set_masks_mod::set_avg_masks(), set_avg_mod::set_avg_tile(), set_data_tile(), set_depth_mod::set_depth0_tile(), set_depth_mod::set_depth_tile(), set_diags_tile(), obc_volcons_mod::set_duv_bc_tile(), set_masks_mod::set_masks_tile(), set_tides_mod::set_tides_tile(), set_vbc_mod::set_vbc_tile(), set_zeta_mod::set_zeta_tile(), ini_fields_mod::set_zeta_timeavg_tile(), bbl_mod::sg_bbl_tile(), bbl_mod::ssw_bbl_tile(), step2d_mod::step2d_tile(), step2d_mod::step2d_tile(), step2d_mod::step2d_tile(), step3d_uv_mod::step3d_uv_tile(), tl_balance_mod::tl_balance_tile(), tl_set_depth_mod::tl_bath_tile(), zeta_balance_mod::tl_biconj_tile(), tl_bulk_flux_mod::tl_bulk_flux_tile(), tl_conv_2d_mod::tl_conv_r2d_tile(), tl_conv_2d_mod::tl_conv_u2d_tile(), tl_conv_2d_mod::tl_conv_v2d_tile(), tl_convolution_mod::tl_convolution_tile(), tl_nesting_mod::tl_fine2coarse(), tl_ini_fields_mod::tl_ini_fields_tile(), ini_adjust_mod::tl_ini_perturb_tile(), tl_ini_fields_mod::tl_ini_zeta_tile(), tl_nesting_mod::tl_put_composite(), tl_nesting_mod::tl_put_refine2d(), tl_rho_eos_mod::tl_rho_eos_tile(), tl_set_data_tile(), tl_set_depth_mod::tl_set_depth_tile(), tl_obc_volcons_mod::tl_set_duv_bc_tile(), tl_set_vbc_mod::tl_set_vbc_tile(), tl_set_zeta_mod::tl_set_zeta_tile(), tl_ini_fields_mod::tl_set_zeta_timeavg_tile(), tl_step2d_mod::tl_step2d_tile(), tl_step2d_mod::tl_step2d_tile(), tl_step2d_mod::tl_step2d_tile(), tl_step3d_uv_mod::tl_step3d_uv_tile(), tl_unpack_tile(), tl_variability_mod::tl_variability_tile(), uv_rotate_mod::uv_rotate2d(), vorticity_mod::vorticity_tile(), wetdry_mod::wetdry_avg_mask_tile(), wetdry_mod::wetdry_ini_tile(), wetdry_mod::wetdry_mask_tile(), wetdry_mod::wetdry_tile(), and wvelocity_mod::wvelocity_tile().

Here is the call graph for this function:
Here is the caller graph for this function:

◆ mp_exchange2d_bry()

subroutine mp_exchange_mod::mp_exchange2d_bry ( integer, intent(in) ng,
integer, intent(in) tile,
integer, intent(in) model,
integer, intent(in) nvar,
integer, intent(in) boundary,
integer, intent(in) lbij,
integer, intent(in) ubij,
integer, intent(in) nghost,
logical, intent(in) ew_periodic,
logical, intent(in) ns_periodic,
real(r8), dimension(lbij:), intent(inout) a,
real(r8), dimension(lbij:), intent(inout), optional b,
real(r8), dimension(lbij:), intent(inout), optional c,
real(r8), dimension(lbij:), intent(inout), optional d )

Definition at line 1525 of file mp_exchange.F.

1529!***********************************************************************
1530!
1531 USE mod_param
1532 USE mod_parallel
1533 USE mod_iounits
1534 USE mod_scalars
1535!
1536 implicit none
1537!
1538! Imported variable declarations.
1539!
1540 logical, intent(in) :: EW_periodic, NS_periodic
1541!
1542 integer, intent(in) :: ng, tile, model, Nvar, boundary
1543 integer, intent(in) :: LBij, UBij
1544 integer, intent(in) :: Nghost
1545!
1546# ifdef ASSUMED_SHAPE
1547 real(r8), intent(inout) :: A(LBij:)
1548
1549 real(r8), intent(inout), optional :: B(LBij:)
1550 real(r8), intent(inout), optional :: C(LBij:)
1551 real(r8), intent(inout), optional :: D(LBij:)
1552# else
1553 real(r8), intent(inout) :: A(LBij:UBij)
1554
1555 real(r8), intent(inout), optional :: B(LBij:UBij)
1556 real(r8), intent(inout), optional :: C(LBij:UBij)
1557 real(r8), intent(inout), optional :: D(LBij:UBij)
1558# endif
1559!
1560! Local variable declarations.
1561!
1562 logical :: Wexchange, Sexchange, Eexchange, Nexchange
1563!
1564 integer :: i, icS, icN
1565 integer :: j, jcW, jcE
1566 integer :: m, Ierror, Lstr, pp
1567 integer :: Wtile, GsendW, GrecvW, Wtag, Werror, Wrequest
1568 integer :: Stile, GsendS, GrecvS, Stag, Serror, Srequest
1569 integer :: Etile, GsendE, GrecvE, Etag, Eerror, Erequest
1570 integer :: Ntile, GsendN, GrecvN, Ntag, Nerror, Nrequest
1571 integer :: EWsize, sizeW, sizeE
1572 integer :: NSsize, sizeS, sizeN
1573
1574# ifdef MPI
1575 integer, dimension(MPI_STATUS_SIZE,4) :: status
1576# endif
1577!
1578 real(r8), dimension(Nvar*HaloBry(ng)) :: sendW, sendE
1579 real(r8), dimension(Nvar*HaloBry(ng)) :: recvW, recvE
1580
1581 real(r8), dimension(Nvar*HaloBry(ng)) :: sendS, sendN
1582 real(r8), dimension(Nvar*HaloBry(ng)) :: recvS, recvN
1583!
1584 character (len=MPI_MAX_ERROR_STRING) :: string
1585
1586 character (len=*), parameter :: MyFile = &
1587 & __FILE__//", mp_exchange2d_bry"
1588
1589# include "set_bounds.h"
1590
1591# ifdef PROFILE
1592!
1593!-----------------------------------------------------------------------
1594! Turn on time clocks.
1595!-----------------------------------------------------------------------
1596!
1597 CALL wclock_on (ng, model, 63, __line__, myfile)
1598# endif
1599!
1600!-----------------------------------------------------------------------
1601! Determine rank of tile neighbors and number of ghost-points to
1602! exchange.
1603!-----------------------------------------------------------------------
1604!
1605! Maximum automatic buffer memory size in bytes.
1606!
1607 bmemmax(ng)=max(bmemmax(ng), real((4*SIZE(sendw)+ &
1608 & 4*SIZE(sends))*kind(a),r8))
1609!
1610 CALL tile_neighbors (ng, nghost, ew_periodic, ns_periodic, &
1611 & grecvw, gsendw, wtile, wexchange, &
1612 & grecve, gsende, etile, eexchange, &
1613 & grecvs, gsends, stile, sexchange, &
1614 & grecvn, gsendn, ntile, nexchange)
1615!
1616! Adjust exchange swiches according to boundary edge to process.
1617!
1618 wexchange=wexchange.and.((boundary.eq.isouth).or. &
1619 & (boundary.eq.inorth))
1620 eexchange=eexchange.and.((boundary.eq.isouth).or. &
1621 & (boundary.eq.inorth))
1622 sexchange=sexchange.and.((boundary.eq.iwest).or. &
1623 & (boundary.eq.ieast))
1624 nexchange=nexchange.and.((boundary.eq.iwest).or. &
1625 & (boundary.eq.ieast))
1626!
1627! Set communication tags.
1628!
1629 wtag=1
1630 stag=2
1631 etag=3
1632 ntag=4
1633!
1634! Determine range and length of the distributed tile boundary segments.
1635!
1636 IF (ew_periodic.or.ns_periodic) THEN
1637 pp=1
1638 ELSE
1639 pp=0
1640 END IF
1641 ewsize=nvar*(nghost+pp)
1642 nssize=nvar*(nghost+pp)
1643 IF (SIZE(sende).lt.ewsize) THEN
1644 WRITE (stdout,10) 'EWsize = ', ewsize, SIZE(sende)
1645 10 FORMAT (/,' MP_EXCHANGE2D_BRY - communication buffer too ', &
1646 & 'small, ',a, 2i8)
1647 END IF
1648 IF (SIZE(sendn).lt.nssize) THEN
1649 WRITE (stdout,10) 'NSsize = ', nssize, SIZE(sendn)
1650 END IF
1651!
1652!-----------------------------------------------------------------------
1653! Pack Western and Eastern tile boundary data including ghost-points.
1654!-----------------------------------------------------------------------
1655!
1656 IF (wexchange) THEN
1657 jcw=0
1658 sizew=0
1659 DO m=1,gsendw
1660 i=istr+m-1
1661 sizew=sizew+1
1662 jcw=jcw+1
1663 sendw(jcw)=a(i)
1664 END DO
1665 IF (PRESENT(b)) THEN
1666 DO m=1,gsendw
1667 i=istr+m-1
1668 sizew=sizew+1
1669 jcw=jcw+1
1670 sendw(jcw)=b(i)
1671 END DO
1672 END IF
1673 IF (PRESENT(c)) THEN
1674 DO m=1,gsendw
1675 i=istr+m-1
1676 sizew=sizew+1
1677 jcw=jcw+1
1678 sendw(jcw)=c(i)
1679 END DO
1680 END IF
1681 IF (PRESENT(d)) THEN
1682 DO m=1,gsendw
1683 i=istr+m-1
1684 sizew=sizew+1
1685 jcw=jcw+1
1686 sendw(jcw)=d(i)
1687 END DO
1688 END IF
1689 END IF
1690!
1691 IF (eexchange) THEN
1692 jce=0
1693 sizee=0
1694 DO m=1,gsende
1695 i=iend-gsende+m
1696 sizee=sizee+1
1697 jce=jce+1
1698 sende(jce)=a(i)
1699 END DO
1700 IF (PRESENT(b)) THEN
1701 DO m=1,gsende
1702 i=iend-gsende+m
1703 sizee=sizee+1
1704 jce=jce+1
1705 sende(jce)=b(i)
1706 END DO
1707 END IF
1708 IF (PRESENT(c)) THEN
1709 DO m=1,gsende
1710 i=iend-gsende+m
1711 sizee=sizee+1
1712 jce=jce+1
1713 sende(jce)=c(i)
1714 END DO
1715 END IF
1716 IF (PRESENT(d)) THEN
1717 DO m=1,gsende
1718 i=iend-gsende+m
1719 sizee=sizee+1
1720 jce=jce+1
1721 sende(jce)=d(i)
1722 END DO
1723 END IF
1724 END IF
1725!
1726!-----------------------------------------------------------------------
1727! Send and receive Western and Eastern segments.
1728!-----------------------------------------------------------------------
1729!
1730# if defined MPI
1731 IF (wexchange) THEN
1732 CALL mpi_irecv (recvw, ewsize, mp_float, wtile, etag, &
1733 & ocn_comm_world, wrequest, werror)
1734 END IF
1735 IF (eexchange) THEN
1736 CALL mpi_irecv (recve, ewsize, mp_float, etile, wtag, &
1737 & ocn_comm_world, erequest, eerror)
1738 END IF
1739 IF (wexchange) THEN
1740 CALL mpi_send (sendw, sizew, mp_float, wtile, wtag, &
1741 & ocn_comm_world, werror)
1742 END IF
1743 IF (eexchange) THEN
1744 CALL mpi_send (sende, sizee, mp_float, etile, etag, &
1745 & ocn_comm_world, eerror)
1746 END IF
1747# endif
1748!
1749!-----------------------------------------------------------------------
1750! Unpack Western and Eastern segments.
1751!-----------------------------------------------------------------------
1752!
1753 IF (wexchange) THEN
1754# ifdef MPI
1755 CALL mpi_wait (wrequest, status(1,1), werror)
1756 IF (werror.ne.mpi_success) THEN
1757 CALL mpi_error_string (werror, string, lstr, ierror)
1758 lstr=len_trim(string)
1759 WRITE (stdout,20) 'MPI_SEND/MPI_IRECV (Western Edge)', &
1760 & myrank, werror, string(1:lstr)
1761 20 FORMAT (/,' MP_EXCHANGE2D_BRY - error during ',a, &
1762 & ' call, Node = ',i3.3,' Error = ',i3,/,15x,a)
1763 exit_flag=2
1764 RETURN
1765 END IF
1766# endif
1767 jcw=0
1768 DO m=grecvw,1,-1
1769 i=istr-m
1770 jcw=jcw+1
1771 a(i)=recvw(jcw)
1772 END DO
1773 IF (PRESENT(b)) THEN
1774 DO m=grecvw,1,-1
1775 i=istr-m
1776 jcw=jcw+1
1777 b(i)=recvw(jcw)
1778 END DO
1779 END IF
1780 IF (PRESENT(c)) THEN
1781 DO m=grecvw,1,-1
1782 i=istr-m
1783 jcw=jcw+1
1784 c(i)=recvw(jcw)
1785 END DO
1786 END IF
1787 IF (PRESENT(d)) THEN
1788 DO m=grecvw,1,-1
1789 i=istr-m
1790 jcw=jcw+1
1791 d(i)=recvw(jcw)
1792 END DO
1793 END IF
1794 END IF
1795!
1796 IF (eexchange) THEN
1797# ifdef MPI
1798 CALL mpi_wait (erequest, status(1,3), eerror)
1799 IF (eerror.ne.mpi_success) THEN
1800 CALL mpi_error_string (eerror, string, lstr, ierror)
1801 lstr=len_trim(string)
1802 WRITE (stdout,20) 'MPI_SEND/MPI_IRECV (Eastern Edge)', &
1803 & myrank, eerror, string(1:lstr)
1804 exit_flag=2
1805 RETURN
1806 END IF
1807# endif
1808 jce=0
1809 DO m=1,grecve
1810 i=iend+m
1811 jce=jce+1
1812 a(i)=recve(jce)
1813 END DO
1814 IF (PRESENT(b)) THEN
1815 DO m=1,grecve
1816 i=iend+m
1817 jce=jce+1
1818 b(i)=recve(jce)
1819 END DO
1820 END IF
1821 IF (PRESENT(c)) THEN
1822 DO m=1,grecve
1823 i=iend+m
1824 jce=jce+1
1825 c(i)=recve(jce)
1826 END DO
1827 END IF
1828 IF (PRESENT(d)) THEN
1829 DO m=1,grecve
1830 i=iend+m
1831 jce=jce+1
1832 d(i)=recve(jce)
1833 END DO
1834 END IF
1835 END IF
1836!
1837!-----------------------------------------------------------------------
1838! Pack Southern and Northern tile boundary data including ghost-points.
1839!-----------------------------------------------------------------------
1840!
1841 IF (sexchange) THEN
1842 ics=0
1843 sizes=0
1844 DO m=1,gsends
1845 j=jstr+m-1
1846 sizes=sizes+1
1847 ics=ics+1
1848 sends(ics)=a(j)
1849 END DO
1850 IF (PRESENT(b)) THEN
1851 DO m=1,gsends
1852 j=jstr+m-1
1853 sizes=sizes+1
1854 ics=ics+1
1855 sends(ics)=b(j)
1856 END DO
1857 END IF
1858 IF (PRESENT(c)) THEN
1859 DO m=1,gsends
1860 j=jstr+m-1
1861 sizes=sizes+1
1862 ics=ics+1
1863 sends(ics)=c(j)
1864 END DO
1865 END IF
1866 IF (PRESENT(d)) THEN
1867 DO m=1,gsends
1868 j=jstr+m-1
1869 sizes=sizes+1
1870 ics=ics+1
1871 sends(ics)=d(j)
1872 END DO
1873 END IF
1874 END IF
1875!
1876 IF (nexchange) THEN
1877 icn=0
1878 sizen=0
1879 DO m=1,gsendn
1880 j=jend-gsendn+m
1881 sizen=sizen+1
1882 icn=icn+1
1883 sendn(icn)=a(j)
1884 END DO
1885 IF (PRESENT(b)) THEN
1886 DO m=1,gsendn
1887 j=jend-gsendn+m
1888 sizen=sizen+1
1889 icn=icn+1
1890 sendn(icn)=b(j)
1891 END DO
1892 END IF
1893 IF (PRESENT(c)) THEN
1894 DO m=1,gsendn
1895 j=jend-gsendn+m
1896 sizen=sizen+1
1897 icn=icn+1
1898 sendn(icn)=c(j)
1899 END DO
1900 END IF
1901 IF (PRESENT(d)) THEN
1902 DO m=1,gsendn
1903 j=jend-gsendn+m
1904 sizen=sizen+1
1905 icn=icn+1
1906 sendn(icn)=d(j)
1907 END DO
1908 END IF
1909 END IF
1910!
1911!-----------------------------------------------------------------------
1912! Send and receive Southern and Northern segments.
1913!-----------------------------------------------------------------------
1914!
1915# if defined MPI
1916 IF (sexchange) THEN
1917 CALL mpi_irecv (recvs, nssize, mp_float, stile, ntag, &
1918 & ocn_comm_world, srequest, serror)
1919 END IF
1920 IF (nexchange) THEN
1921 CALL mpi_irecv (recvn, nssize, mp_float, ntile, stag, &
1922 & ocn_comm_world, nrequest, nerror)
1923 END IF
1924 IF (sexchange) THEN
1925 CALL mpi_send (sends, sizes, mp_float, stile, stag, &
1926 & ocn_comm_world, serror)
1927 END IF
1928 IF (nexchange) THEN
1929 CALL mpi_send (sendn, sizen, mp_float, ntile, ntag, &
1930 & ocn_comm_world, nerror)
1931 END IF
1932# endif
1933!
1934!-----------------------------------------------------------------------
1935! Unpack Northern and Southern segments.
1936!-----------------------------------------------------------------------
1937!
1938 IF (sexchange) THEN
1939# ifdef MPI
1940 CALL mpi_wait (srequest, status(1,2), serror)
1941 IF (serror.ne.mpi_success) THEN
1942 CALL mpi_error_string (serror, string, lstr, ierror)
1943 lstr=len_trim(string)
1944 WRITE (stdout,20) 'MPI_SEND/MPI_IRECV (Southern Edge)', &
1945 & myrank, serror, string(1:lstr)
1946 exit_flag=2
1947 RETURN
1948 END IF
1949# endif
1950 ics=0
1951 DO m=grecvs,1,-1
1952 j=jstr-m
1953 ics=ics+1
1954 a(j)=recvs(ics)
1955 END DO
1956 IF (PRESENT(b)) THEN
1957 DO m=grecvs,1,-1
1958 j=jstr-m
1959 ics=ics+1
1960 b(j)=recvs(ics)
1961 END DO
1962 END IF
1963 IF (PRESENT(c)) THEN
1964 DO m=grecvs,1,-1
1965 j=jstr-m
1966 ics=ics+1
1967 c(j)=recvs(ics)
1968 END DO
1969 END IF
1970 IF (PRESENT(d)) THEN
1971 DO m=grecvs,1,-1
1972 j=jstr-m
1973 ics=ics+1
1974 d(j)=recvs(ics)
1975 END DO
1976 END IF
1977 END IF
1978!
1979 IF (nexchange) THEN
1980# ifdef MPI
1981 CALL mpi_wait (nrequest, status(1,4), nerror)
1982 IF (nerror.ne.mpi_success) THEN
1983 CALL mpi_error_string (nerror, string, lstr, ierror)
1984 lstr=len_trim(string)
1985 WRITE (stdout,20) 'MPI_SEND/MPI_IRECV (Northern Edge)', &
1986 & myrank, nerror, string(1:lstr)
1987 exit_flag=2
1988 RETURN
1989 END IF
1990# endif
1991 icn=0
1992 DO m=1,grecvn
1993 j=jend+m
1994 icn=icn+1
1995 a(j)=recvn(icn)
1996 END DO
1997 IF (PRESENT(b)) THEN
1998 DO m=1,grecvn
1999 j=jend+m
2000 icn=icn+1
2001 b(j)=recvn(icn)
2002 END DO
2003 END IF
2004 IF (PRESENT(c)) THEN
2005 DO m=1,grecvn
2006 j=jend+m
2007 icn=icn+1
2008 c(j)=recvn(icn)
2009 END DO
2010 END IF
2011 IF (PRESENT(d)) THEN
2012 DO m=1,grecvn
2013 j=jend+m
2014 icn=icn+1
2015 d(j)=recvn(icn)
2016 END DO
2017 END IF
2018 END IF
2019
2020# ifdef PROFILE
2021!
2022!-----------------------------------------------------------------------
2023! Turn off time clocks.
2024!-----------------------------------------------------------------------
2025!
2026 CALL wclock_off (ng, model, 63, __line__, myfile)
2027# endif
2028!
2029 RETURN

References mod_param::bmemmax, mod_scalars::exit_flag, mod_scalars::ieast, mod_scalars::inorth, mod_scalars::isouth, mod_scalars::iwest, mod_parallel::mp_float, mod_parallel::myrank, mod_parallel::ocn_comm_world, mod_iounits::stdout, tile_neighbors(), wclock_off(), and wclock_on().

Referenced by conv_bry2d_mod::conv_r2d_bry_tile(), conv_bry2d_mod::conv_u2d_bry_tile(), conv_bry2d_mod::conv_v2d_bry_tile(), random_ic_mod::random_ic_tile(), tl_conv_bry2d_mod::tl_conv_r2d_bry_tile(), tl_conv_bry2d_mod::tl_conv_u2d_bry_tile(), tl_conv_bry2d_mod::tl_conv_v2d_bry_tile(), tl_convolution_mod::tl_convolution_tile(), tl_variability_mod::tl_variability_tile(), and white_noise_mod::white_noise2d_bry().

Here is the call graph for this function:
Here is the caller graph for this function:

◆ mp_exchange3d()

subroutine mp_exchange_mod::mp_exchange3d ( integer, intent(in) ng,
integer, intent(in) tile,
integer, intent(in) model,
integer, intent(in) nvar,
integer, intent(in) lbi,
integer, intent(in) ubi,
integer, intent(in) lbj,
integer, intent(in) ubj,
integer, intent(in) lbk,
integer, intent(in) ubk,
integer, intent(in) nghost,
logical, intent(in) ew_periodic,
logical, intent(in) ns_periodic,
real(r8), dimension(lbi:,lbj:,lbk:), intent(inout) a,
real(r8), dimension(lbi:,lbj:,lbk:), intent(inout), optional b,
real(r8), dimension(lbi:,lbj:,lbk:), intent(inout), optional c,
real(r8), dimension(lbi:,lbj:,lbk:), intent(inout), optional d )

Definition at line 2033 of file mp_exchange.F.

2037!***********************************************************************
2038!
2039 USE mod_param
2040 USE mod_parallel
2041 USE mod_iounits
2042 USE mod_scalars
2043!
2044 implicit none
2045!
2046! Imported variable declarations.
2047!
2048 logical, intent(in) :: EW_periodic, NS_periodic
2049!
2050 integer, intent(in) :: ng, tile, model, Nvar
2051 integer, intent(in) :: LBi, UBi, LBj, UBj, LBk, UBk
2052 integer, intent(in) :: Nghost
2053
2054# ifdef ASSUMED_SHAPE
2055 real(r8), intent(inout) :: A(LBi:,LBj:,LBk:)
2056
2057 real(r8), intent(inout), optional :: B(LBi:,LBj:,LBk:)
2058 real(r8), intent(inout), optional :: C(LBi:,LBj:,LBk:)
2059 real(r8), intent(inout), optional :: D(LBi:,LBj:,LBk:)
2060# else
2061 real(r8), intent(inout) :: A(LBi:UBi,LBj:UBj,LBk:UBk)
2062
2063 real(r8), intent(inout), optional :: B(LBi:UBi,LBj:UBj,LBk:UBk)
2064 real(r8), intent(inout), optional :: C(LBi:UBi,LBj:UBj,LBk:UBk)
2065 real(r8), intent(inout), optional :: D(LBi:UBi,LBj:UBj,LBk:UBk)
2066# endif
2067!
2068! Local variable declarations.
2069!
2070 logical :: Wexchange, Sexchange, Eexchange, Nexchange
2071!
2072 integer :: i, ikS, ikN, ioff, Imin, Imax, Ilen, IKlen
2073 integer :: j, jkW, jkE, joff, Jmin, Jmax, Jlen, JKlen
2074 integer :: k, kc, m, mc, Ierror, Klen, Lstr, pp
2075 integer :: Wtile, GsendW, GrecvW, Wtag, Werror, Wrequest
2076 integer :: Stile, GsendS, GrecvS, Stag, Serror, Srequest
2077 integer :: Etile, GsendE, GrecvE, Etag, Eerror, Erequest
2078 integer :: Ntile, GsendN, GrecvN, Ntag, Nerror, Nrequest
2079 integer :: EWsize, sizeW, sizeE
2080 integer :: NSsize, sizeS, sizeN
2081
2082# ifdef MPI
2083 integer, dimension(MPI_STATUS_SIZE,4) :: status
2084# endif
2085!
2086 real(r8), dimension(Nvar*HaloSizeJ(ng)* & & (UBk-LBk+1)) :: sendW, sendE
2087 real(r8), dimension(Nvar*HaloSizeJ(ng)* & & (UBk-LBk+1)) :: recvW, recvE
2088
2089 real(r8), dimension(Nvar*HaloSizeI(ng)* & & (UBk-LBk+1)) :: sendS, sendN
2090 real(r8), dimension(Nvar*HaloSizeI(ng)* & & (UBk-LBk+1)) :: recvS, recvN
2091!
2092 character (len=MPI_MAX_ERROR_STRING) :: string
2093
2094 character (len=*), parameter :: MyFile = &
2095 & __FILE__//", mp_exchange3d"
2096
2097# include "set_bounds.h"
2098
2099# ifdef PROFILE
2100!
2101!-----------------------------------------------------------------------
2102! Turn on time clocks.
2103!-----------------------------------------------------------------------
2104!
2105 CALL wclock_on (ng, model, 61, __line__, myfile)
2106# endif
2107!
2108!-----------------------------------------------------------------------
2109! Determine rank of tile neighbors and number of ghost-points to
2110! exchange.
2111!-----------------------------------------------------------------------
2112!
2113! Maximum automatic buffer memory size in bytes.
2114!
2115 bmemmax(ng)=max(bmemmax(ng), real((4*SIZE(sendw)+ &
2116 & 4*SIZE(sends))*kind(a),r8))
2117!
2118 CALL tile_neighbors (ng, nghost, ew_periodic, ns_periodic, &
2119 & grecvw, gsendw, wtile, wexchange, &
2120 & grecve, gsende, etile, eexchange, &
2121 & grecvs, gsends, stile, sexchange, &
2122 & grecvn, gsendn, ntile, nexchange)
2123!
2124! Set communication tags.
2125!
2126 wtag=1
2127 stag=2
2128 etag=3
2129 ntag=4
2130!
2131! Determine range and length of the distributed tile boundary segments.
2132!
2133 imin=lbi
2134 imax=ubi
2135 jmin=lbj
2136 jmax=ubj
2137 ilen=imax-imin+1
2138 jlen=jmax-jmin+1
2139 klen=ubk-lbk+1
2140 iklen=ilen*klen
2141 jklen=jlen*klen
2142 IF (ew_periodic.or.ns_periodic) THEN
2143 pp=1
2144 ELSE
2145 pp=0
2146 END IF
2147 ewsize=nvar*(nghost+pp)*jklen
2148 nssize=nvar*(nghost+pp)*iklen
2149 IF (SIZE(sende).lt.ewsize) THEN
2150 WRITE (stdout,10) 'EWsize = ', ewsize, SIZE(sende)
2151 10 FORMAT (/,' MP_EXCHANGE3D - communication buffer too small, ', &
2152 & a, 2i8)
2153 END IF
2154 IF (SIZE(sendn).lt.nssize) THEN
2155 WRITE (stdout,10) 'NSsize = ', nssize, SIZE(sendn)
2156 END IF
2157!
2158!-----------------------------------------------------------------------
2159! Pack Western and Eastern tile boundary data including ghost-points.
2160!-----------------------------------------------------------------------
2161!
2162 IF (wexchange) THEN
2163 sizew=0
2164 DO m=1,gsendw
2165 mc=(m-1)*jklen
2166 i=istr+m-1
2167 DO k=lbk,ubk
2168 kc=(k-lbk)*jlen+mc
2169 DO j=jmin,jmax
2170 sizew=sizew+1
2171 jkw=1+(j-jmin)+kc
2172 sendw(jkw)=a(i,j,k)
2173 END DO
2174 END DO
2175 END DO
2176 IF (PRESENT(b)) THEN
2177 joff=jkw
2178 DO m=1,gsendw
2179 mc=(m-1)*jklen
2180 i=istr+m-1
2181 DO k=lbk,ubk
2182 kc=(k-lbk)*jlen+mc
2183 DO j=jmin,jmax
2184 sizew=sizew+1
2185 jkw=joff+1+(j-jmin)+kc
2186 sendw(jkw)=b(i,j,k)
2187 END DO
2188 END DO
2189 END DO
2190 END IF
2191 IF (PRESENT(c)) THEN
2192 joff=jkw
2193 DO m=1,gsendw
2194 mc=(m-1)*jklen
2195 i=istr+m-1
2196 DO k=lbk,ubk
2197 kc=(k-lbk)*jlen+mc
2198 DO j=jmin,jmax
2199 sizew=sizew+1
2200 jkw=joff+1+(j-jmin)+kc
2201 sendw(jkw)=c(i,j,k)
2202 END DO
2203 END DO
2204 END DO
2205 END IF
2206 IF (PRESENT(d)) THEN
2207 joff=jkw
2208 DO m=1,gsendw
2209 mc=(m-1)*jklen
2210 i=istr+m-1
2211 DO k=lbk,ubk
2212 kc=(k-lbk)*jlen+mc
2213 DO j=jmin,jmax
2214 sizew=sizew+1
2215 jkw=joff+1+(j-jmin)+kc
2216 sendw(jkw)=d(i,j,k)
2217 END DO
2218 END DO
2219 END DO
2220 END IF
2221 END IF
2222!
2223 IF (eexchange) THEN
2224 sizee=0
2225 DO m=1,gsende
2226 mc=(m-1)*jklen
2227 i=iend-gsende+m
2228 DO k=lbk,ubk
2229 kc=(k-lbk)*jlen+mc
2230 DO j=jmin,jmax
2231 sizee=sizee+1
2232 jke=1+(j-jmin)+kc
2233 sende(jke)=a(i,j,k)
2234 END DO
2235 END DO
2236 END DO
2237 IF (PRESENT(b)) THEN
2238 joff=jke
2239 DO m=1,gsende
2240 mc=(m-1)*jklen
2241 i=iend-gsende+m
2242 DO k=lbk,ubk
2243 kc=(k-lbk)*jlen+mc
2244 DO j=jmin,jmax
2245 sizee=sizee+1
2246 jke=joff+1+(j-jmin)+kc
2247 sende(jke)=b(i,j,k)
2248 END DO
2249 END DO
2250 END DO
2251 END IF
2252 IF (PRESENT(c)) THEN
2253 joff=jke
2254 DO m=1,gsende
2255 mc=(m-1)*jklen
2256 i=iend-gsende+m
2257 DO k=lbk,ubk
2258 kc=(k-lbk)*jlen+mc
2259 DO j=jmin,jmax
2260 sizee=sizee+1
2261 jke=joff+1+(j-jmin)+kc
2262 sende(jke)=c(i,j,k)
2263 END DO
2264 END DO
2265 END DO
2266 END IF
2267 IF (PRESENT(d)) THEN
2268 joff=jke
2269 DO m=1,gsende
2270 mc=(m-1)*jklen
2271 i=iend-gsende+m
2272 DO k=lbk,ubk
2273 kc=(k-lbk)*jlen+mc
2274 DO j=jmin,jmax
2275 sizee=sizee+1
2276 jke=joff+1+(j-jmin)+kc
2277 sende(jke)=d(i,j,k)
2278 END DO
2279 END DO
2280 END DO
2281 END IF
2282 END IF
2283!
2284!-----------------------------------------------------------------------
2285! Send and receive Western and Eastern segments.
2286!-----------------------------------------------------------------------
2287!
2288# if defined MPI
2289 IF (wexchange) THEN
2290 CALL mpi_irecv (recvw, ewsize, mp_float, wtile, etag, &
2291 & ocn_comm_world, wrequest, werror)
2292 END IF
2293 IF (eexchange) THEN
2294 CALL mpi_irecv (recve, ewsize, mp_float, etile, wtag, &
2295 & ocn_comm_world, erequest, eerror)
2296 END IF
2297 IF (wexchange) THEN
2298 CALL mpi_send (sendw, sizew, mp_float, wtile, wtag, &
2299 & ocn_comm_world, werror)
2300 END IF
2301 IF (eexchange) THEN
2302 CALL mpi_send (sende, sizee, mp_float, etile, etag, &
2303 & ocn_comm_world, eerror)
2304 END IF
2305# endif
2306!
2307!-----------------------------------------------------------------------
2308! Unpack Eastern and Western segments.
2309!-----------------------------------------------------------------------
2310!
2311 IF (wexchange) THEN
2312# ifdef MPI
2313 CALL mpi_wait (wrequest, status(1,1), werror)
2314 IF (werror.ne.mpi_success) THEN
2315 CALL mpi_error_string (werror, string, lstr, ierror)
2316 lstr=len_trim(string)
2317 WRITE (stdout,20) 'MPI_SEND/MPI_IRECV (Western Edge)', &
2318 & myrank, werror, string(1:lstr)
2319 exit_flag=2
2320 RETURN
2321 END IF
2322# endif
2323 DO m=grecvw,1,-1
2324 mc=(grecvw-m)*jklen
2325 i=istr-m
2326 DO k=lbk,ubk
2327 kc=(k-lbk)*jlen+mc
2328 DO j=jmin,jmax
2329 jkw=1+(j-jmin)+kc
2330 a(i,j,k)=recvw(jkw)
2331 END DO
2332 END DO
2333 END DO
2334 IF (PRESENT(b)) THEN
2335 joff=jkw
2336 DO m=grecvw,1,-1
2337 mc=(grecvw-m)*jklen
2338 i=istr-m
2339 DO k=lbk,ubk
2340 kc=(k-lbk)*jlen+mc
2341 DO j=jmin,jmax
2342 jkw=joff+1+(j-jmin)+kc
2343 b(i,j,k)=recvw(jkw)
2344 END DO
2345 END DO
2346 END DO
2347 END IF
2348 IF (PRESENT(c)) THEN
2349 joff=jkw
2350 DO m=grecvw,1,-1
2351 mc=(grecvw-m)*jklen
2352 i=istr-m
2353 DO k=lbk,ubk
2354 kc=(k-lbk)*jlen+mc
2355 DO j=jmin,jmax
2356 jkw=joff+1+(j-jmin)+kc
2357 c(i,j,k)=recvw(jkw)
2358 END DO
2359 END DO
2360 END DO
2361 END IF
2362 IF (PRESENT(d)) THEN
2363 joff=jkw
2364 DO m=grecvw,1,-1
2365 mc=(grecvw-m)*jklen
2366 i=istr-m
2367 DO k=lbk,ubk
2368 kc=(k-lbk)*jlen+mc
2369 DO j=jmin,jmax
2370 jkw=joff+1+(j-jmin)+kc
2371 d(i,j,k)=recvw(jkw)
2372 END DO
2373 END DO
2374 END DO
2375 END IF
2376 END IF
2377!
2378 IF (eexchange) THEN
2379# ifdef MPI
2380 CALL mpi_wait (erequest, status(1,3), eerror)
2381 IF (eerror.ne.mpi_success) THEN
2382 CALL mpi_error_string (eerror, string, lstr, ierror)
2383 lstr=len_trim(string)
2384 WRITE (stdout,20) 'MPI_SEND/MPI_IRECV (Eastern Edge)', &
2385 & myrank, eerror, string(1:lstr)
2386 20 FORMAT (/,' MP_EXCHANGE3D - error during ',a, &
2387 & ' call, Node = ',i3.3,' Error = ',i3,/,15x,a)
2388 exit_flag=2
2389 RETURN
2390 END IF
2391# endif
2392 DO m=1,grecve
2393 mc=(m-1)*jklen
2394 i=iend+m
2395 DO k=lbk,ubk
2396 kc=(k-lbk)*jlen+mc
2397 DO j=jmin,jmax
2398 jke=1+(j-jmin)+kc
2399 a(i,j,k)=recve(jke)
2400 END DO
2401 ENDDO
2402 END DO
2403 IF (PRESENT(b)) THEN
2404 joff=jke
2405 DO m=1,grecve
2406 mc=(m-1)*jklen
2407 i=iend+m
2408 DO k=lbk,ubk
2409 kc=(k-lbk)*jlen+mc
2410 DO j=jmin,jmax
2411 jke=joff+1+(j-jmin)+kc
2412 b(i,j,k)=recve(jke)
2413 END DO
2414 ENDDO
2415 END DO
2416 END IF
2417 IF (PRESENT(c)) THEN
2418 joff=jke
2419 DO m=1,grecve
2420 mc=(m-1)*jklen
2421 i=iend+m
2422 DO k=lbk,ubk
2423 kc=(k-lbk)*jlen+mc
2424 DO j=jmin,jmax
2425 jke=joff+1+(j-jmin)+kc
2426 c(i,j,k)=recve(jke)
2427 END DO
2428 ENDDO
2429 END DO
2430 END IF
2431 IF (PRESENT(d)) THEN
2432 joff=jke
2433 DO m=1,grecve
2434 mc=(m-1)*jklen
2435 i=iend+m
2436 DO k=lbk,ubk
2437 kc=(k-lbk)*jlen+mc
2438 DO j=jmin,jmax
2439 jke=joff+1+(j-jmin)+kc
2440 d(i,j,k)=recve(jke)
2441 END DO
2442 ENDDO
2443 END DO
2444 END IF
2445 END IF
2446!
2447!-----------------------------------------------------------------------
2448! Pack Southern and Northern tile boundary data including ghost-points.
2449!-----------------------------------------------------------------------
2450!
2451 IF (sexchange) THEN
2452 sizes=0
2453 DO m=1,gsends
2454 mc=(m-1)*iklen
2455 j=jstr+m-1
2456 DO k=lbk,ubk
2457 kc=(k-lbk)*ilen+mc
2458 DO i=imin,imax
2459 sizes=sizes+1
2460 iks=1+(i-imin)+kc
2461 sends(iks)=a(i,j,k)
2462 END DO
2463 END DO
2464 END DO
2465 IF (PRESENT(b)) THEN
2466 ioff=iks
2467 DO m=1,gsends
2468 mc=(m-1)*iklen
2469 j=jstr+m-1
2470 DO k=lbk,ubk
2471 kc=(k-lbk)*ilen+mc
2472 DO i=imin,imax
2473 sizes=sizes+1
2474 iks=ioff+1+(i-imin)+kc
2475 sends(iks)=b(i,j,k)
2476 END DO
2477 END DO
2478 END DO
2479 END IF
2480 IF (PRESENT(c)) THEN
2481 ioff=iks
2482 DO m=1,gsends
2483 mc=(m-1)*iklen
2484 j=jstr+m-1
2485 DO k=lbk,ubk
2486 kc=(k-lbk)*ilen+mc
2487 DO i=imin,imax
2488 sizes=sizes+1
2489 iks=ioff+1+(i-imin)+kc
2490 sends(iks)=c(i,j,k)
2491 END DO
2492 END DO
2493 END DO
2494 END IF
2495 IF (PRESENT(d)) THEN
2496 ioff=iks
2497 DO m=1,gsends
2498 mc=(m-1)*iklen
2499 j=jstr+m-1
2500 DO k=lbk,ubk
2501 kc=(k-lbk)*ilen+mc
2502 DO i=imin,imax
2503 sizes=sizes+1
2504 iks=ioff+1+(i-imin)+kc
2505 sends(iks)=d(i,j,k)
2506 END DO
2507 END DO
2508 END DO
2509 END IF
2510 END IF
2511!
2512 IF (nexchange) THEN
2513 sizen=0
2514 DO m=1,gsendn
2515 mc=(m-1)*iklen
2516 j=jend-gsendn+m
2517 DO k=lbk,ubk
2518 kc=(k-lbk)*ilen+mc
2519 DO i=imin,imax
2520 sizen=sizen+1
2521 ikn=1+(i-imin)+kc
2522 sendn(ikn)=a(i,j,k)
2523 END DO
2524 END DO
2525 END DO
2526 IF (PRESENT(b)) THEN
2527 ioff=ikn
2528 DO m=1,gsendn
2529 mc=(m-1)*iklen
2530 j=jend-gsendn+m
2531 DO k=lbk,ubk
2532 kc=(k-lbk)*ilen+mc
2533 DO i=imin,imax
2534 sizen=sizen+1
2535 ikn=ioff+1+(i-imin)+kc
2536 sendn(ikn)=b(i,j,k)
2537 END DO
2538 END DO
2539 END DO
2540 END IF
2541 IF (PRESENT(c)) THEN
2542 ioff=ikn
2543 DO m=1,gsendn
2544 mc=(m-1)*iklen
2545 j=jend-gsendn+m
2546 DO k=lbk,ubk
2547 kc=(k-lbk)*ilen+mc
2548 DO i=imin,imax
2549 sizen=sizen+1
2550 ikn=ioff+1+(i-imin)+kc
2551 sendn(ikn)=c(i,j,k)
2552 END DO
2553 END DO
2554 END DO
2555 END IF
2556 IF (PRESENT(d)) THEN
2557 ioff=ikn
2558 DO m=1,gsendn
2559 mc=(m-1)*iklen
2560 j=jend-gsendn+m
2561 DO k=lbk,ubk
2562 kc=(k-lbk)*ilen+mc
2563 DO i=imin,imax
2564 sizen=sizen+1
2565 ikn=ioff+1+(i-imin)+kc
2566 sendn(ikn)=d(i,j,k)
2567 END DO
2568 END DO
2569 END DO
2570 END IF
2571 END IF
2572!
2573!-----------------------------------------------------------------------
2574! Send and receive Southern and Northern segments.
2575!-----------------------------------------------------------------------
2576!
2577# if defined MPI
2578 IF (sexchange) THEN
2579 CALL mpi_irecv (recvs, nssize, mp_float, stile, ntag, &
2580 & ocn_comm_world, srequest, serror)
2581 END IF
2582 IF (nexchange) THEN
2583 CALL mpi_irecv (recvn, nssize, mp_float, ntile, stag, &
2584 & ocn_comm_world, nrequest, nerror)
2585 END IF
2586 IF (sexchange) THEN
2587 CALL mpi_send (sends, sizes, mp_float, stile, stag, &
2588 & ocn_comm_world, serror)
2589 END IF
2590 IF (nexchange) THEN
2591 CALL mpi_send (sendn, sizen, mp_float, ntile, ntag, &
2592 & ocn_comm_world, nerror)
2593 END IF
2594# endif
2595!
2596!-----------------------------------------------------------------------
2597! Unpack Northern and Southern segments.
2598!-----------------------------------------------------------------------
2599!
2600 IF (sexchange) THEN
2601# ifdef MPI
2602 CALL mpi_wait (srequest, status(1,2), serror)
2603 IF (serror.ne.mpi_success) THEN
2604 CALL mpi_error_string (serror, string, lstr, ierror)
2605 lstr=len_trim(string)
2606 WRITE (stdout,20) 'MPI_SEND/MPI_IRECV (Southern Edge)', &
2607 & myrank, serror, string(1:lstr)
2608 exit_flag=2
2609 RETURN
2610 END IF
2611# endif
2612 DO m=grecvs,1,-1
2613 mc=(grecvs-m)*iklen
2614 j=jstr-m
2615 DO k=lbk,ubk
2616 kc=(k-lbk)*ilen+mc
2617 DO i=imin,imax
2618 iks=1+(i-imin)+kc
2619 a(i,j,k)=recvs(iks)
2620 END DO
2621 END DO
2622 END DO
2623 IF (PRESENT(b)) THEN
2624 ioff=iks
2625 DO m=grecvs,1,-1
2626 mc=(grecvs-m)*iklen
2627 j=jstr-m
2628 DO k=lbk,ubk
2629 kc=(k-lbk)*ilen+mc
2630 DO i=imin,imax
2631 iks=ioff+1+(i-imin)+kc
2632 b(i,j,k)=recvs(iks)
2633 END DO
2634 END DO
2635 END DO
2636 END IF
2637 IF (PRESENT(c)) THEN
2638 ioff=iks
2639 DO m=grecvs,1,-1
2640 mc=(grecvs-m)*iklen
2641 j=jstr-m
2642 DO k=lbk,ubk
2643 kc=(k-lbk)*ilen+mc
2644 DO i=imin,imax
2645 iks=ioff+1+(i-imin)+kc
2646 c(i,j,k)=recvs(iks)
2647 END DO
2648 END DO
2649 END DO
2650 END IF
2651 IF (PRESENT(d)) THEN
2652 ioff=iks
2653 DO m=grecvs,1,-1
2654 mc=(grecvs-m)*iklen
2655 j=jstr-m
2656 DO k=lbk,ubk
2657 kc=(k-lbk)*ilen+mc
2658 DO i=imin,imax
2659 iks=ioff+1+(i-imin)+kc
2660 d(i,j,k)=recvs(iks)
2661 END DO
2662 END DO
2663 END DO
2664 END IF
2665 END IF
2666!
2667 IF (nexchange) THEN
2668# ifdef MPI
2669 CALL mpi_wait (nrequest, status(1,4), nerror)
2670 IF (nerror.ne.mpi_success) THEN
2671 CALL mpi_error_string (nerror, string, lstr, ierror)
2672 lstr=len_trim(string)
2673 WRITE (stdout,20) 'MPI_SEND/MPI_IRECV (Northern Edge)', &
2674 & myrank, nerror, string(1:lstr)
2675 exit_flag=2
2676 RETURN
2677 END IF
2678# endif
2679 DO m=1,grecvn
2680 mc=(m-1)*iklen
2681 j=jend+m
2682 DO k=lbk,ubk
2683 kc=(k-lbk)*ilen+mc
2684 DO i=imin,imax
2685 ikn=1+(i-imin)+kc
2686 a(i,j,k)=recvn(ikn)
2687 END DO
2688 END DO
2689 END DO
2690 IF (PRESENT(b)) THEN
2691 ioff=ikn
2692 DO m=1,grecvn
2693 mc=(m-1)*iklen
2694 j=jend+m
2695 DO k=lbk,ubk
2696 kc=(k-lbk)*ilen+mc
2697 DO i=imin,imax
2698 ikn=ioff+1+(i-imin)+kc
2699 b(i,j,k)=recvn(ikn)
2700 END DO
2701 END DO
2702 END DO
2703 END IF
2704 IF (PRESENT(c)) THEN
2705 ioff=ikn
2706 DO m=1,grecvn
2707 mc=(m-1)*iklen
2708 j=jend+m
2709 DO k=lbk,ubk
2710 kc=(k-lbk)*ilen+mc
2711 DO i=imin,imax
2712 ikn=ioff+1+(i-imin)+kc
2713 c(i,j,k)=recvn(ikn)
2714 END DO
2715 END DO
2716 END DO
2717 END IF
2718 IF (PRESENT(d)) THEN
2719 ioff=ikn
2720 DO m=1,grecvn
2721 mc=(m-1)*iklen
2722 j=jend+m
2723 DO k=lbk,ubk
2724 kc=(k-lbk)*ilen+mc
2725 DO i=imin,imax
2726 ikn=ioff+1+(i-imin)+kc
2727 d(i,j,k)=recvn(ikn)
2728 END DO
2729 END DO
2730 END DO
2731 END IF
2732 END IF
2733
2734# ifdef PROFILE
2735!
2736!-----------------------------------------------------------------------
2737! Turn off time clocks.
2738!-----------------------------------------------------------------------
2739!
2740 CALL wclock_off (ng, model, 61, __line__, myfile)
2741# endif
2742!
2743 RETURN
2744

References mod_param::bmemmax, mod_scalars::exit_flag, mod_parallel::mp_float, mod_parallel::myrank, mod_parallel::ocn_comm_world, mod_iounits::stdout, tile_neighbors(), wclock_off(), and wclock_on().

Referenced by ad_omega_mod::ad_omega_tile(), ad_set_data_tile(), ad_step3d_t_mod::ad_step3d_t_tile(), analytical_mod::ana_m3clima_tile(), analytical_mod::ana_nudgcoef_tile(), analytical_mod::ana_respiration_tile(), analytical_mod::ana_specir_tile(), analytical_mod::ana_sponge_tile(), analytical_mod::ana_vmix_tile(), bvf_mix_mod::bvf_mix_tile(), conv_3d_mod::conv_r3d_tile(), conv_3d_mod::conv_u3d_tile(), conv_3d_mod::conv_v3d_tile(), nesting_mod::fine2coarse(), get_nudgcoef_mod::get_nudgcoef_nf90(), get_nudgcoef_mod::get_nudgcoef_pio(), get_state_mod::get_state_nf90(), get_state_mod::get_state_pio(), gls_corstep_mod::gls_corstep_tile(), gls_prestep_mod::gls_prestep_tile(), ini_fields_mod::ini_fields_tile(), ini_hmixcoef_mod::ini_hmixcoef_tile(), ini_adjust_mod::ini_perturb_tile(), lmd_vmix_mod::lmd_finish_tile(), distribute_mod::mp_scatter3d(), my25_corstep_mod::my25_corstep_tile(), my25_prestep_mod::my25_prestep_tile(), normalization_mod::normalization_tile(), omega_mod::omega_tile(), nesting_mod::put_composite(), nesting_mod::put_refine3d(), random_ic_mod::random_ic_tile(), normalization_mod::randomization_tile(), set_massflux_mod::reset_massflux_tile(), rho_eos_mod::rho_eos_tile(), rp_ini_fields_mod::rp_ini_fields_tile(), rp_omega_mod::rp_omega_tile(), rp_rho_eos_mod::rp_rho_eos_tile(), rp_set_data_tile(), rp_set_depth_mod::rp_set_depth_tile(), rp_set_massflux_mod::rp_set_massflux_tile(), rp_step3d_t_mod::rp_step3d_t_tile(), rp_step3d_uv_mod::rp_step3d_uv_tile(), omega_mod::scale_omega(), sed_bed_mod::sed_bed_tile(), sed_bedload_tile(), sed_surface_mod::sed_surface_tile(), set_3dfld_mod::set_3dfld_tile(), set_3dfldr_mod::set_3dfldr_tile(), set_avg_mod::set_avg_tile(), set_data_tile(), set_depth_mod::set_depth0_tile(), set_depth_mod::set_depth_tile(), set_diags_tile(), set_massflux_mod::set_massflux_tile(), step3d_t_mod::step3d_t_tile(), step3d_uv_mod::step3d_uv_tile(), tl_balance_mod::tl_balance_tile(), tl_conv_3d_mod::tl_conv_r3d_tile(), tl_conv_3d_mod::tl_conv_u3d_tile(), tl_conv_3d_mod::tl_conv_v3d_tile(), tl_convolution_mod::tl_convolution_tile(), tl_nesting_mod::tl_fine2coarse(), tl_ini_fields_mod::tl_ini_fields_tile(), ini_adjust_mod::tl_ini_perturb_tile(), tl_omega_mod::tl_omega_tile(), tl_nesting_mod::tl_put_composite(), tl_nesting_mod::tl_put_refine3d(), tl_rho_eos_mod::tl_rho_eos_tile(), tl_set_data_tile(), tl_set_depth_mod::tl_set_depth_tile(), tl_set_massflux_mod::tl_set_massflux_tile(), tl_step3d_t_mod::tl_step3d_t_tile(), tl_step3d_uv_mod::tl_step3d_uv_tile(), tl_unpack_tile(), uv_var_change_mod::tl_uv_a2c_grid_tile(), uv_var_change_mod::tl_uv_c2a_grid_tile(), tl_variability_mod::tl_variability_tile(), uv_var_change_mod::uv_a2c_grid_tile(), uv_var_change_mod::uv_c2a_grid_tile(), uv_rotate_mod::uv_rotate3d(), vorticity_mod::vorticity_tile(), and wvelocity_mod::wvelocity_tile().

Here is the call graph for this function:
Here is the caller graph for this function:

◆ mp_exchange3d_bry()

subroutine mp_exchange_mod::mp_exchange3d_bry ( integer, intent(in) ng,
integer, intent(in) tile,
integer, intent(in) model,
integer, intent(in) nvar,
integer, intent(in) boundary,
integer, intent(in) lbij,
integer, intent(in) ubij,
integer, intent(in) lbk,
integer, intent(in) ubk,
integer, intent(in) nghost,
logical, intent(in) ew_periodic,
logical, intent(in) ns_periodic,
real(r8), dimension(lbij:,lbk:), intent(inout) a,
real(r8), dimension(lbij:,lbk:), intent(inout), optional b,
real(r8), dimension(lbij:,lbk:), intent(inout), optional c,
real(r8), dimension(lbij:,lbk:), intent(inout), optional d )

Definition at line 2752 of file mp_exchange.F.

2756!***********************************************************************
2757!
2758 USE mod_param
2759 USE mod_parallel
2760 USE mod_iounits
2761 USE mod_scalars
2762!
2763 implicit none
2764!
2765! Imported variable declarations.
2766!
2767 logical, intent(in) :: EW_periodic, NS_periodic
2768!
2769 integer, intent(in) :: ng, tile, model, Nvar, boundary
2770 integer, intent(in) :: LBij, UBij, LBk, UBk
2771 integer, intent(in) :: Nghost
2772!
2773# ifdef ASSUMED_SHAPE
2774 real(r8), intent(inout) :: A(LBij:,LBk:)
2775
2776 real(r8), intent(inout), optional :: B(LBij:,LBk:)
2777 real(r8), intent(inout), optional :: C(LBij:,LBk:)
2778 real(r8), intent(inout), optional :: D(LBij:,LBk:)
2779# else
2780 real(r8), intent(inout) :: A(LBij:UBij,LBk:UBk)
2781
2782 real(r8), intent(inout), optional :: B(LBij:UBij,LBk:UBk)
2783 real(r8), intent(inout), optional :: C(LBij:UBij,LBk:UBk)
2784 real(r8), intent(inout), optional :: D(LBij:UBij,LBk:UBk)
2785# endif
2786!
2787! Local variable declarations.
2788!
2789 logical :: Wexchange, Sexchange, Eexchange, Nexchange
2790!
2791 integer :: i, ikS, ikN, ioff
2792 integer :: j, jkW, jkE, joff
2793 integer :: k, m, mc, Ierror, Klen, Lstr, pp
2794 integer :: Wtile, GsendW, GrecvW, Wtag, Werror, Wrequest
2795 integer :: Stile, GsendS, GrecvS, Stag, Serror, Srequest
2796 integer :: Etile, GsendE, GrecvE, Etag, Eerror, Erequest
2797 integer :: Ntile, GsendN, GrecvN, Ntag, Nerror, Nrequest
2798 integer :: EWsize, sizeW, sizeE
2799 integer :: NSsize, sizeS, sizeN
2800
2801# ifdef MPI
2802 integer, dimension(MPI_STATUS_SIZE,4) :: status
2803# endif
2804!
2805 real(r8), dimension(Nvar*HaloBry(ng)*(UBk-LBk+1)) :: sendW, sendE
2806 real(r8), dimension(Nvar*HaloBry(ng)*(UBk-LBk+1)) :: recvW, recvE
2807 real(r8), dimension(Nvar*HaloBry(ng)*(UBk-LBk+1)) :: sendS, sendN
2808 real(r8), dimension(Nvar*HaloBry(ng)*(UBk-LBk+1)) :: recvS, recvN
2809!
2810 character (len=MPI_MAX_ERROR_STRING) :: string
2811
2812 character (len=*), parameter :: MyFile = &
2813 & __FILE__//", mp_exchange3d_bry"
2814
2815# include "set_bounds.h"
2816
2817# ifdef PROFILE
2818!
2819!-----------------------------------------------------------------------
2820! Turn on time clocks.
2821!-----------------------------------------------------------------------
2822!
2823 CALL wclock_on (ng, model, 63, __line__, myfile)
2824# endif
2825!
2826!-----------------------------------------------------------------------
2827! Determine rank of tile neighbors and number of ghost-points to
2828! exchange.
2829!-----------------------------------------------------------------------
2830!
2831! Maximum automatic buffer memory size in bytes.
2832!
2833 bmemmax(ng)=max(bmemmax(ng), real((4*SIZE(sendw)+ &
2834 & 4*SIZE(sends))*kind(a),r8))
2835!
2836 CALL tile_neighbors (ng, nghost, ew_periodic, ns_periodic, &
2837 & grecvw, gsendw, wtile, wexchange, &
2838 & grecve, gsende, etile, eexchange, &
2839 & grecvs, gsends, stile, sexchange, &
2840 & grecvn, gsendn, ntile, nexchange)
2841!
2842! Adjust exchange swiches according to boundary edge to process.
2843!
2844 wexchange=wexchange.and.((boundary.eq.isouth).or. &
2845 & (boundary.eq.inorth))
2846 eexchange=eexchange.and.((boundary.eq.isouth).or. &
2847 & (boundary.eq.inorth))
2848 sexchange=sexchange.and.((boundary.eq.iwest).or. &
2849 & (boundary.eq.ieast))
2850 nexchange=nexchange.and.((boundary.eq.iwest).or. &
2851 & (boundary.eq.ieast))
2852!
2853! Set communication tags.
2854!
2855 wtag=1
2856 stag=2
2857 etag=3
2858 ntag=4
2859!
2860! Determine range and length of the distributed tile boundary segments.
2861!
2862 klen=ubk-lbk+1
2863 IF (ew_periodic.or.ns_periodic) THEN
2864 pp=1
2865 ELSE
2866 pp=0
2867 END IF
2868 ewsize=nvar*(nghost+pp)*klen
2869 nssize=nvar*(nghost+pp)*klen
2870 IF (SIZE(sende).lt.ewsize) THEN
2871 WRITE (stdout,10) 'EWsize = ', ewsize, SIZE(sende)
2872 10 FORMAT (/,' MP_EXCHANGE3D_BRY - communication buffer too ', &
2873 & 'small, ', a, 2i8)
2874 END IF
2875 IF (SIZE(sendn).lt.nssize) THEN
2876 WRITE (stdout,10) 'NSsize = ', nssize, SIZE(sendn)
2877 END IF
2878!
2879!-----------------------------------------------------------------------
2880! Pack Western and Eastern tile boundary data including ghost-points.
2881!-----------------------------------------------------------------------
2882!
2883 IF (wexchange) THEN
2884 sizew=0
2885 DO m=1,gsendw
2886 mc=(m-1)*klen
2887 i=istr+m-1
2888 DO k=lbk,ubk
2889 sizew=sizew+1
2890 jkw=1+(k-lbk)+mc
2891 sendw(jkw)=a(i,k)
2892 END DO
2893 END DO
2894 IF (PRESENT(b)) THEN
2895 joff=jkw
2896 DO m=1,gsendw
2897 mc=(m-1)*klen
2898 i=istr+m-1
2899 DO k=lbk,ubk
2900 sizew=sizew+1
2901 jkw=joff+1+(k-lbk)+mc
2902 sendw(jkw)=b(i,k)
2903 END DO
2904 END DO
2905 END IF
2906 IF (PRESENT(c)) THEN
2907 joff=jkw
2908 DO m=1,gsendw
2909 mc=(m-1)*klen
2910 i=istr+m-1
2911 DO k=lbk,ubk
2912 sizew=sizew+1
2913 jkw=joff+1+(k-lbk)+mc
2914 sendw(jkw)=c(i,k)
2915 END DO
2916 END DO
2917 END IF
2918 IF (PRESENT(d)) THEN
2919 joff=jkw
2920 DO m=1,gsendw
2921 mc=(m-1)*klen
2922 i=istr+m-1
2923 DO k=lbk,ubk
2924 sizew=sizew+1
2925 jkw=joff+1+(k-lbk)+mc
2926 sendw(jkw)=d(i,k)
2927 END DO
2928 END DO
2929 END IF
2930 END IF
2931!
2932 IF (eexchange) THEN
2933 sizee=0
2934 DO m=1,gsende
2935 mc=(m-1)*klen
2936 i=iend-gsende+m
2937 DO k=lbk,ubk
2938 sizee=sizee+1
2939 jke=1+(k-lbk)+mc
2940 sende(jke)=a(i,k)
2941 END DO
2942 END DO
2943 IF (PRESENT(b)) THEN
2944 joff=jke
2945 DO m=1,gsende
2946 mc=(m-1)*klen
2947 i=iend-gsende+m
2948 DO k=lbk,ubk
2949 sizee=sizee+1
2950 jke=joff+1+(k-lbk)+mc
2951 sende(jke)=b(i,k)
2952 END DO
2953 END DO
2954 END IF
2955 IF (PRESENT(c)) THEN
2956 joff=jke
2957 DO m=1,gsende
2958 mc=(m-1)*klen
2959 i=iend-gsende+m
2960 DO k=lbk,ubk
2961 sizee=sizee+1
2962 jke=joff+1+(k-lbk)+mc
2963 sende(jke)=c(i,k)
2964 END DO
2965 END DO
2966 END IF
2967 IF (PRESENT(d)) THEN
2968 joff=jke
2969 DO m=1,gsende
2970 mc=(m-1)*klen
2971 i=iend-gsende+m
2972 DO k=lbk,ubk
2973 sizee=sizee+1
2974 jke=joff+1+(k-lbk)+mc
2975 sende(jke)=d(i,k)
2976 END DO
2977 END DO
2978 END IF
2979 END IF
2980!
2981!-----------------------------------------------------------------------
2982! Send and receive Western and Eastern segments.
2983!-----------------------------------------------------------------------
2984!
2985# if defined MPI
2986 IF (wexchange) THEN
2987 CALL mpi_irecv (recvw, ewsize, mp_float, wtile, etag, &
2988 & ocn_comm_world, wrequest, werror)
2989 END IF
2990 IF (eexchange) THEN
2991 CALL mpi_irecv (recve, ewsize, mp_float, etile, wtag, &
2992 & ocn_comm_world, erequest, eerror)
2993 END IF
2994 IF (wexchange) THEN
2995 CALL mpi_send (sendw, sizew, mp_float, wtile, wtag, &
2996 & ocn_comm_world, werror)
2997 END IF
2998 IF (eexchange) THEN
2999 CALL mpi_send (sende, sizee, mp_float, etile, etag, &
3000 & ocn_comm_world, eerror)
3001 END IF
3002# endif
3003!
3004!-----------------------------------------------------------------------
3005! Unpack Eastern and Western segments.
3006!-----------------------------------------------------------------------
3007!
3008 IF (wexchange) THEN
3009# ifdef MPI
3010 CALL mpi_wait (wrequest, status(1,1), werror)
3011 IF (werror.ne.mpi_success) THEN
3012 CALL mpi_error_string (werror, string, lstr, ierror)
3013 lstr=len_trim(string)
3014 WRITE (stdout,20) 'MPI_SEND/MPI_IRECV (Western Edge)', &
3015 & myrank, werror, string(1:lstr)
3016 exit_flag=2
3017 RETURN
3018 END IF
3019# endif
3020 DO m=grecvw,1,-1
3021 mc=(grecvw-m)*klen
3022 i=istr-m
3023 DO k=lbk,ubk
3024 jkw=1+(k-lbk)+mc
3025 a(i,k)=recvw(jkw)
3026 END DO
3027 END DO
3028 IF (PRESENT(b)) THEN
3029 joff=jkw
3030 DO m=grecvw,1,-1
3031 mc=(grecvw-m)*klen
3032 i=istr-m
3033 DO k=lbk,ubk
3034 jkw=joff+1+(k-lbk)+mc
3035 b(i,k)=recvw(jkw)
3036 END DO
3037 END DO
3038 END IF
3039 IF (PRESENT(c)) THEN
3040 joff=jkw
3041 DO m=grecvw,1,-1
3042 mc=(grecvw-m)*klen
3043 i=istr-m
3044 DO k=lbk,ubk
3045 jkw=joff+1+(k-lbk)+mc
3046 c(i,k)=recvw(jkw)
3047 END DO
3048 END DO
3049 END IF
3050 IF (PRESENT(d)) THEN
3051 joff=jkw
3052 DO m=grecvw,1,-1
3053 mc=(grecvw-m)*klen
3054 i=istr-m
3055 DO k=lbk,ubk
3056 jkw=joff+1+(k-lbk)+mc
3057 d(i,k)=recvw(jkw)
3058 END DO
3059 END DO
3060 END IF
3061 END IF
3062!
3063 IF (eexchange) THEN
3064# ifdef MPI
3065 CALL mpi_wait (erequest, status(1,3), eerror)
3066 IF (eerror.ne.mpi_success) THEN
3067 CALL mpi_error_string (eerror, string, lstr, ierror)
3068 lstr=len_trim(string)
3069 WRITE (stdout,20) 'MPI_SEND/MPI_IRECV (Eastern Edge)', &
3070 & myrank, eerror, string(1:lstr)
3071 20 FORMAT (/,' MP_EXCHANGE3D_BRY - error during ',a, &
3072 & ' call, Node = ',i3.3,' Error = ',i3,/,15x,a)
3073 exit_flag=2
3074 RETURN
3075 END IF
3076# endif
3077 DO m=1,grecve
3078 mc=(m-1)*klen
3079 i=iend+m
3080 DO k=lbk,ubk
3081 jke=1+(k-lbk)+mc
3082 a(i,k)=recve(jke)
3083 END DO
3084 END DO
3085 IF (PRESENT(b)) THEN
3086 joff=jke
3087 DO m=1,grecve
3088 mc=(m-1)*klen
3089 i=iend+m
3090 DO k=lbk,ubk
3091 jke=joff+1+(k-lbk)+mc
3092 b(i,k)=recve(jke)
3093 END DO
3094 END DO
3095 END IF
3096 IF (PRESENT(c)) THEN
3097 joff=jke
3098 DO m=1,grecve
3099 mc=(m-1)*klen
3100 i=iend+m
3101 DO k=lbk,ubk
3102 jke=joff+1+(k-lbk)+mc
3103 c(i,k)=recve(jke)
3104 END DO
3105 END DO
3106 END IF
3107 IF (PRESENT(d)) THEN
3108 joff=jke
3109 DO m=1,grecve
3110 mc=(m-1)*klen
3111 i=iend+m
3112 DO k=lbk,ubk
3113 jke=joff+1+(k-lbk)+mc
3114 d(i,k)=recve(jke)
3115 END DO
3116 END DO
3117 END IF
3118 END IF
3119!
3120!-----------------------------------------------------------------------
3121! Pack Southern and Northern tile boundary data including ghost-points.
3122!-----------------------------------------------------------------------
3123!
3124 IF (sexchange) THEN
3125 sizes=0
3126 DO m=1,gsends
3127 mc=(m-1)*klen
3128 j=jstr+m-1
3129 DO k=lbk,ubk
3130 sizes=sizes+1
3131 iks=1+(k-lbk)+mc
3132 sends(iks)=a(j,k)
3133 END DO
3134 END DO
3135 IF (PRESENT(b)) THEN
3136 ioff=iks
3137 DO m=1,gsends
3138 mc=(m-1)*klen
3139 j=jstr+m-1
3140 DO k=lbk,ubk
3141 sizes=sizes+1
3142 iks=ioff+1+(k-lbk)+mc
3143 sends(iks)=b(j,k)
3144 END DO
3145 END DO
3146 END IF
3147 IF (PRESENT(c)) THEN
3148 ioff=iks
3149 DO m=1,gsends
3150 mc=(m-1)*klen
3151 j=jstr+m-1
3152 DO k=lbk,ubk
3153 sizes=sizes+1
3154 iks=ioff+1+(k-lbk)+mc
3155 sends(iks)=c(j,k)
3156 END DO
3157 END DO
3158 END IF
3159 IF (PRESENT(d)) THEN
3160 ioff=iks
3161 DO m=1,gsends
3162 mc=(m-1)*klen
3163 j=jstr+m-1
3164 DO k=lbk,ubk
3165 sizes=sizes+1
3166 iks=ioff+1+(k-lbk)+mc
3167 sends(iks)=d(j,k)
3168 END DO
3169 END DO
3170 END IF
3171 END IF
3172!
3173 IF (nexchange) THEN
3174 sizen=0
3175 DO m=1,gsendn
3176 mc=(m-1)*klen
3177 j=jend-gsendn+m
3178 DO k=lbk,ubk
3179 sizen=sizen+1
3180 ikn=1+(k-lbk)+mc
3181 sendn(ikn)=a(j,k)
3182 END DO
3183 END DO
3184 IF (PRESENT(b)) THEN
3185 ioff=ikn
3186 DO m=1,gsendn
3187 mc=(m-1)*klen
3188 j=jend-gsendn+m
3189 DO k=lbk,ubk
3190 sizen=sizen+1
3191 ikn=ioff+1+(k-lbk)+mc
3192 sendn(ikn)=b(j,k)
3193 END DO
3194 END DO
3195 END IF
3196 IF (PRESENT(c)) THEN
3197 ioff=ikn
3198 DO m=1,gsendn
3199 mc=(m-1)*klen
3200 j=jend-gsendn+m
3201 DO k=lbk,ubk
3202 sizen=sizen+1
3203 ikn=ioff+1+(k-lbk)+mc
3204 sendn(ikn)=c(j,k)
3205 END DO
3206 END DO
3207 END IF
3208 IF (PRESENT(d)) THEN
3209 ioff=ikn
3210 DO m=1,gsendn
3211 mc=(m-1)*klen
3212 j=jend-gsendn+m
3213 DO k=lbk,ubk
3214 sizen=sizen+1
3215 ikn=ioff+1+(k-lbk)+mc
3216 sendn(ikn)=d(j,k)
3217 END DO
3218 END DO
3219 END IF
3220 END IF
3221!
3222!-----------------------------------------------------------------------
3223! Send and receive Southern and Northern segments.
3224!-----------------------------------------------------------------------
3225!
3226# if defined MPI
3227 IF (sexchange) THEN
3228 CALL mpi_irecv (recvs, nssize, mp_float, stile, ntag, &
3229 & ocn_comm_world, srequest, serror)
3230 END IF
3231 IF (nexchange) THEN
3232 CALL mpi_irecv (recvn, nssize, mp_float, ntile, stag, &
3233 & ocn_comm_world, nrequest, nerror)
3234 END IF
3235 IF (sexchange) THEN
3236 CALL mpi_send (sends, sizes, mp_float, stile, stag, &
3237 & ocn_comm_world, serror)
3238 END IF
3239 IF (nexchange) THEN
3240 CALL mpi_send (sendn, sizen, mp_float, ntile, ntag, &
3241 & ocn_comm_world, nerror)
3242 END IF
3243# endif
3244!
3245!-----------------------------------------------------------------------
3246! Unpack Northern and Southern segments.
3247!-----------------------------------------------------------------------
3248!
3249 IF (sexchange) THEN
3250# ifdef MPI
3251 CALL mpi_wait (srequest, status(1,2), serror)
3252 IF (serror.ne.mpi_success) THEN
3253 CALL mpi_error_string (serror, string, lstr, ierror)
3254 lstr=len_trim(string)
3255 WRITE (stdout,20) 'MPI_SEND/MPI_IRECV (Southern Edge)', &
3256 & myrank, serror, string(1:lstr)
3257 exit_flag=2
3258 RETURN
3259 END IF
3260# endif
3261 DO m=grecvs,1,-1
3262 mc=(grecvs-m)*klen
3263 j=jstr-m
3264 DO k=lbk,ubk
3265 iks=1+(k-lbk)+mc
3266 a(j,k)=recvs(iks)
3267 END DO
3268 END DO
3269 IF (PRESENT(b)) THEN
3270 ioff=iks
3271 DO m=grecvs,1,-1
3272 mc=(grecvs-m)*klen
3273 j=jstr-m
3274 DO k=lbk,ubk
3275 iks=ioff+1+(k-lbk)+mc
3276 b(j,k)=recvs(iks)
3277 END DO
3278 END DO
3279 END IF
3280 IF (PRESENT(c)) THEN
3281 ioff=iks
3282 DO m=grecvs,1,-1
3283 mc=(grecvs-m)*klen
3284 j=jstr-m
3285 DO k=lbk,ubk
3286 iks=ioff+1+(k-lbk)+mc
3287 c(j,k)=recvs(iks)
3288 END DO
3289 END DO
3290 END IF
3291 IF (PRESENT(d)) THEN
3292 ioff=iks
3293 DO m=grecvs,1,-1
3294 mc=(grecvs-m)*klen
3295 j=jstr-m
3296 DO k=lbk,ubk
3297 iks=ioff+1+(k-lbk)+mc
3298 d(j,k)=recvs(iks)
3299 END DO
3300 END DO
3301 END IF
3302 END IF
3303!
3304 IF (nexchange) THEN
3305# ifdef MPI
3306 CALL mpi_wait (nrequest, status(1,4), nerror)
3307 IF (nerror.ne.mpi_success) THEN
3308 CALL mpi_error_string (nerror, string, lstr, ierror)
3309 lstr=len_trim(string)
3310 WRITE (stdout,20) 'MPI_SEND/MPI_IRECV (Northern Edge)', &
3311 & myrank, nerror, string(1:lstr)
3312 exit_flag=2
3313 RETURN
3314 END IF
3315# endif
3316 DO m=1,grecvn
3317 mc=(m-1)*klen
3318 j=jend+m
3319 DO k=lbk,ubk
3320 ikn=1+(k-lbk)+mc
3321 a(j,k)=recvn(ikn)
3322 END DO
3323 END DO
3324 IF (PRESENT(b)) THEN
3325 ioff=ikn
3326 DO m=1,grecvn
3327 mc=(m-1)*klen
3328 j=jend+m
3329 DO k=lbk,ubk
3330 ikn=ioff+1+(k-lbk)+mc
3331 b(j,k)=recvn(ikn)
3332 END DO
3333 END DO
3334 END IF
3335 IF (PRESENT(c)) THEN
3336 ioff=ikn
3337 DO m=1,grecvn
3338 mc=(m-1)*klen
3339 j=jend+m
3340 DO k=lbk,ubk
3341 ikn=ioff+1+(k-lbk)+mc
3342 c(j,k)=recvn(ikn)
3343 END DO
3344 END DO
3345 END IF
3346 IF (PRESENT(d)) THEN
3347 ioff=ikn
3348 DO m=1,grecvn
3349 mc=(m-1)*klen
3350 j=jend+m
3351 DO k=lbk,ubk
3352 ikn=ioff+1+(k-lbk)+mc
3353 d(j,k)=recvn(ikn)
3354 END DO
3355 END DO
3356 END IF
3357 END IF
3358
3359# ifdef PROFILE
3360!
3361!-----------------------------------------------------------------------
3362! Turn off time clocks.
3363!-----------------------------------------------------------------------
3364!
3365 CALL wclock_off (ng, model, 63, __line__, myfile)
3366# endif
3367!
3368 RETURN

References mod_param::bmemmax, mod_scalars::exit_flag, mod_scalars::ieast, mod_scalars::inorth, mod_scalars::isouth, mod_scalars::iwest, mod_parallel::mp_float, mod_parallel::myrank, mod_parallel::ocn_comm_world, mod_iounits::stdout, tile_neighbors(), wclock_off(), and wclock_on().

Referenced by conv_3d_bry_mod::conv_r3d_bry_tile(), conv_3d_bry_mod::conv_u3d_bry_tile(), conv_3d_bry_mod::conv_v3d_bry_tile(), random_ic_mod::random_ic_tile(), rp_set_depth_mod::rp_set_depth_bry_tile(), set_depth_mod::set_depth_bry_tile(), tl_conv_bry3d_mod::tl_conv_r3d_bry_tile(), tl_conv_bry3d_mod::tl_conv_u3d_bry_tile(), tl_conv_bry3d_mod::tl_conv_v3d_bry_tile(), tl_convolution_mod::tl_convolution_tile(), tl_set_depth_mod::tl_set_depth_bry_tile(), tl_variability_mod::tl_variability_tile(), and white_noise_mod::white_noise3d_bry().

Here is the call graph for this function:
Here is the caller graph for this function:

◆ mp_exchange4d()

subroutine mp_exchange_mod::mp_exchange4d ( integer, intent(in) ng,
integer, intent(in) tile,
integer, intent(in) model,
integer, intent(in) nvar,
integer, intent(in) lbi,
integer, intent(in) ubi,
integer, intent(in) lbj,
integer, intent(in) ubj,
integer, intent(in) lbk,
integer, intent(in) ubk,
integer, intent(in) lbt,
integer, intent(in) ubt,
integer, intent(in) nghost,
logical, intent(in) ew_periodic,
logical, intent(in) ns_periodic,
real(r8), dimension(lbi:,lbj:,lbk:,lbt:), intent(inout) a,
real(r8), dimension(lbi:,lbj:,lbk:,lbt:), intent(inout), optional b,
real(r8), dimension(lbi:,lbj:,lbk:,lbt:), intent(inout), optional c )

Definition at line 3373 of file mp_exchange.F.

3377!***********************************************************************
3378!
3379 USE mod_param
3380 USE mod_parallel
3381 USE mod_iounits
3382 USE mod_scalars
3383!
3384 implicit none
3385!
3386! Imported variable declarations.
3387!
3388 logical, intent(in) :: EW_periodic, NS_periodic
3389!
3390 integer, intent(in) :: ng, tile, model, Nvar
3391 integer, intent(in) :: LBi, UBi, LBj, UBj, LBk, UBk, LBt, UBt
3392 integer, intent(in) :: Nghost
3393!
3394# ifdef ASSUMED_SHAPE
3395 real(r8), intent(inout) :: A(LBi:,LBj:,LBk:,LBt:)
3396
3397 real(r8), intent(inout), optional :: B(LBi:,LBj:,LBk:,LBt:)
3398 real(r8), intent(inout), optional :: C(LBi:,LBj:,LBk:,LBt:)
3399
3400# else
3401 real(r8), intent(inout) :: A(LBi:UBi,LBj:UBj,LBk:UBk,LBt:UBt)
3402
3403 real(r8), intent(inout), optional :: &
3404 & B(LBi:UBi,LBj:UBj,LBk:UBk,LBt:UBt)
3405 real(r8), intent(inout), optional :: &
3406 & C(LBi:UBi,LBj:UBj,LBk:UBk,LBt:UBt)
3407# endif
3408!
3409! Local variable declarations.
3410!
3411 logical :: Wexchange, Sexchange, Eexchange, Nexchange
3412!
3413 integer :: i, ikS, ikN, ioff, Imin, Imax, Ilen, IKlen, IKTlen
3414 integer :: j, jkW, jkE, joff, Jmin, Jmax, Jlen, JKlen, JKTlen
3415 integer :: k, kc, m, mc, Ierror, Klen, Lstr, Tlen, pp
3416 integer :: l, lc
3417 integer :: Wtile, GsendW, GrecvW, Wtag, Werror, Wrequest
3418 integer :: Stile, GsendS, GrecvS, Stag, Serror, Srequest
3419 integer :: Etile, GsendE, GrecvE, Etag, Eerror, Erequest
3420 integer :: Ntile, GsendN, GrecvN, Ntag, Nerror, Nrequest
3421 integer :: EWsize, sizeW, sizeE
3422 integer :: NSsize, sizeS, sizeN
3423
3424# ifdef MPI
3425 integer, dimension(MPI_STATUS_SIZE,4) :: status
3426# endif
3427!
3428 real(r8), dimension(Nvar*HaloSizeJ(ng)* & & (UBk-LBk+1)*(UBt-LBt+1)) :: sendW, sendE
3429 real(r8), dimension(Nvar*HaloSizeJ(ng)* & & (UBk-LBk+1)*(UBt-LBt+1)) :: recvW, recvE
3430
3431 real(r8), dimension(Nvar*HaloSizeI(ng)* & & (UBk-LBk+1)*(UBt-LBt+1)) :: sendS, sendN
3432 real(r8), dimension(Nvar*HaloSizeI(ng)* & & (UBk-LBk+1)*(UBt-LBt+1)) :: recvS, recvN
3433!
3434 character (len=MPI_MAX_ERROR_STRING) :: string
3435
3436 character (len=*), parameter :: MyFile = &
3437 & __FILE__//", mp_exchange4d"
3438
3439# include "set_bounds.h"
3440
3441# ifdef PROFILE
3442!
3443!-----------------------------------------------------------------------
3444! Turn on time clocks.
3445!-----------------------------------------------------------------------
3446!
3447 CALL wclock_on (ng, model, 62, __line__, myfile)
3448# endif
3449!
3450!-----------------------------------------------------------------------
3451! Determine rank of tile neighbors and number of ghost-points to
3452! exchange.
3453!-----------------------------------------------------------------------
3454!
3455! Maximum automatic buffer memory size in bytes.
3456!
3457 bmemmax(ng)=max(bmemmax(ng), real((4*SIZE(sendw)+ &
3458 & 4*SIZE(sends))*kind(a),r8))
3459!
3460 CALL tile_neighbors (ng, nghost, ew_periodic, ns_periodic, &
3461 & grecvw, gsendw, wtile, wexchange, &
3462 & grecve, gsende, etile, eexchange, &
3463 & grecvs, gsends, stile, sexchange, &
3464 & grecvn, gsendn, ntile, nexchange)
3465!
3466! Set communication tags.
3467!
3468 wtag=1
3469 stag=2
3470 etag=3
3471 ntag=4
3472!
3473! Determine range and length of the distributed tile boundary segments.
3474!
3475 imin=lbi
3476 imax=ubi
3477 jmin=lbj
3478 jmax=ubj
3479 ilen=imax-imin+1
3480 jlen=jmax-jmin+1
3481 klen=ubk-lbk+1
3482 tlen=ubt-lbt+1
3483 iklen=ilen*klen
3484 jklen=jlen*klen
3485 iktlen=iklen*tlen
3486 jktlen=jklen*tlen
3487 IF (ew_periodic.or.ns_periodic) THEN
3488 pp=1
3489 ELSE
3490 pp=0
3491 END IF
3492 ewsize=nvar*(nghost+pp)*jktlen
3493 nssize=nvar*(nghost+pp)*iktlen
3494 IF (SIZE(sende).lt.ewsize) THEN
3495 WRITE (stdout,10) 'EWsize = ', ewsize, SIZE(sende)
3496 10 FORMAT (/,' MP_EXCHANGE4D - communication buffer too small, ', &
3497 & a, 2i8)
3498 END IF
3499 IF (SIZE(sendn).lt.nssize) THEN
3500 WRITE (stdout,10) 'NSsize = ', nssize, SIZE(sendn)
3501 END IF
3502!
3503!-----------------------------------------------------------------------
3504! Pack Western and Eastern tile boundary data including ghost-points.
3505!-----------------------------------------------------------------------
3506!
3507 IF (wexchange) THEN
3508 sizew=0
3509 DO m=1,gsendw
3510 mc=(m-1)*jktlen
3511 i=istr+m-1
3512 DO l=lbt,ubt
3513 lc=(l-lbt)*jklen+mc
3514 DO k=lbk,ubk
3515 kc=(k-lbk)*jlen+lc
3516 DO j=jmin,jmax
3517 sizew=sizew+1
3518 jkw=1+(j-jmin)+kc
3519 sendw(jkw)=a(i,j,k,l)
3520 END DO
3521 END DO
3522 END DO
3523 END DO
3524 IF (PRESENT(b)) THEN
3525 joff=jkw
3526 DO m=1,gsendw
3527 mc=(m-1)*jktlen
3528 i=istr+m-1
3529 DO l=lbt,ubt
3530 lc=(l-lbt)*jklen+mc
3531 DO k=lbk,ubk
3532 kc=(k-lbk)*jlen+lc
3533 DO j=jmin,jmax
3534 sizew=sizew+1
3535 jkw=joff+1+(j-jmin)+kc
3536 sendw(jkw)=b(i,j,k,l)
3537 END DO
3538 END DO
3539 END DO
3540 END DO
3541 END IF
3542 IF (PRESENT(c)) THEN
3543 joff=jkw
3544 DO m=1,gsendw
3545 mc=(m-1)*jktlen
3546 i=istr+m-1
3547 DO l=lbt,ubt
3548 lc=(l-lbt)*jklen+mc
3549 DO k=lbk,ubk
3550 kc=(k-lbk)*jlen+lc
3551 DO j=jmin,jmax
3552 sizew=sizew+1
3553 jkw=joff+1+(j-jmin)+kc
3554 sendw(jkw)=c(i,j,k,l)
3555 END DO
3556 END DO
3557 END DO
3558 END DO
3559 END IF
3560 END IF
3561!
3562 IF (eexchange) THEN
3563 sizee=0
3564 DO m=1,gsende
3565 mc=(m-1)*jktlen
3566 i=iend-gsende+m
3567 DO l=lbt,ubt
3568 lc=(l-lbt)*jklen+mc
3569 DO k=lbk,ubk
3570 kc=(k-lbk)*jlen+lc
3571 DO j=jmin,jmax
3572 sizee=sizee+1
3573 jke=1+(j-jmin)+kc
3574 sende(jke)=a(i,j,k,l)
3575 END DO
3576 END DO
3577 END DO
3578 END DO
3579 IF (PRESENT(b)) THEN
3580 joff=jke
3581 DO m=1,gsende
3582 mc=(m-1)*jktlen
3583 i=iend-gsende+m
3584 DO l=lbt,ubt
3585 lc=(l-lbt)*jklen+mc
3586 DO k=lbk,ubk
3587 kc=(k-lbk)*jlen+lc
3588 DO j=jmin,jmax
3589 sizee=sizee+1
3590 jke=joff+1+(j-jmin)+kc
3591 sende(jke)=b(i,j,k,l)
3592 END DO
3593 END DO
3594 END DO
3595 END DO
3596 END IF
3597 IF (PRESENT(c)) THEN
3598 joff=jke
3599 DO m=1,gsende
3600 mc=(m-1)*jktlen
3601 i=iend-gsende+m
3602 DO l=lbt,ubt
3603 lc=(l-lbt)*jklen+mc
3604 DO k=lbk,ubk
3605 kc=(k-lbk)*jlen+lc
3606 DO j=jmin,jmax
3607 sizee=sizee+1
3608 jke=joff+1+(j-jmin)+kc
3609 sende(jke)=c(i,j,k,l)
3610 END DO
3611 END DO
3612 END DO
3613 END DO
3614 END IF
3615 END IF
3616!
3617!-----------------------------------------------------------------------
3618! Send and receive Western and Eastern segments.
3619!-----------------------------------------------------------------------
3620!
3621# if defined MPI
3622 IF (wexchange) THEN
3623 CALL mpi_irecv (recvw, ewsize, mp_float, wtile, etag, &
3624 & ocn_comm_world, wrequest, werror)
3625 END IF
3626 IF (eexchange) THEN
3627 CALL mpi_irecv (recve, ewsize, mp_float, etile, wtag, &
3628 & ocn_comm_world, erequest, eerror)
3629 END IF
3630 IF (wexchange) THEN
3631 CALL mpi_send (sendw, sizew, mp_float, wtile, wtag, &
3632 & ocn_comm_world, werror)
3633 END IF
3634 IF (eexchange) THEN
3635 CALL mpi_send (sende, sizee, mp_float, etile, etag, &
3636 & ocn_comm_world, eerror)
3637 END IF
3638# endif
3639!
3640!-----------------------------------------------------------------------
3641! Unpack Eastern and Western segments.
3642!-----------------------------------------------------------------------
3643!
3644 IF (wexchange) THEN
3645# ifdef MPI
3646 CALL mpi_wait (wrequest, status(1,1), werror)
3647 IF (werror.ne.mpi_success) THEN
3648 CALL mpi_error_string (werror, string, lstr, ierror)
3649 lstr=len_trim(string)
3650 WRITE (stdout,20) 'MPI_SEND/MPI_IRECV (Western Edge)', &
3651 & myrank, werror, string(1:lstr)
3652 20 FORMAT (/,' MP_EXCHANGE4D - error during ',a, &
3653 & ' call, Node = ',i3.3,' Error = ',i3,/,15x,a)
3654 exit_flag=2
3655 RETURN
3656 END IF
3657# endif
3658 DO m=grecvw,1,-1
3659 mc=(grecvw-m)*jktlen
3660 i=istr-m
3661 DO l=lbt,ubt
3662 lc=(l-lbt)*jklen+mc
3663 DO k=lbk,ubk
3664 kc=(k-lbk)*jlen+lc
3665 DO j=jmin,jmax
3666 jkw=1+(j-jmin)+kc
3667 a(i,j,k,l)=recvw(jkw)
3668 END DO
3669 END DO
3670 END DO
3671 END DO
3672 IF (PRESENT(b)) THEN
3673 joff=jkw
3674 DO m=grecvw,1,-1
3675 mc=(grecvw-m)*jktlen
3676 i=istr-m
3677 DO l=lbt,ubt
3678 lc=(l-lbt)*jklen+mc
3679 DO k=lbk,ubk
3680 kc=(k-lbk)*jlen+lc
3681 DO j=jmin,jmax
3682 jkw=joff+1+(j-jmin)+kc
3683 b(i,j,k,l)=recvw(jkw)
3684 END DO
3685 END DO
3686 END DO
3687 END DO
3688 END IF
3689 IF (PRESENT(c)) THEN
3690 joff=jkw
3691 DO m=grecvw,1,-1
3692 mc=(grecvw-m)*jktlen
3693 i=istr-m
3694 DO l=lbt,ubt
3695 lc=(l-lbt)*jklen+mc
3696 DO k=lbk,ubk
3697 kc=(k-lbk)*jlen+lc
3698 DO j=jmin,jmax
3699 jkw=joff+1+(j-jmin)+kc
3700 c(i,j,k,l)=recvw(jkw)
3701 END DO
3702 END DO
3703 END DO
3704 END DO
3705 END IF
3706 END IF
3707!
3708 IF (eexchange) THEN
3709# ifdef MPI
3710 CALL mpi_wait (erequest, status(1,3), eerror)
3711 IF (eerror.ne.mpi_success) THEN
3712 CALL mpi_error_string (eerror, string, lstr, ierror)
3713 lstr=len_trim(string)
3714 WRITE (stdout,20) 'MPI_SEND/MPI_IRECV (Eastern Edge)', &
3715 & myrank, eerror, string(1:lstr)
3716 exit_flag=2
3717 RETURN
3718 END IF
3719# endif
3720 DO m=1,grecve
3721 mc=(m-1)*jktlen
3722 i=iend+m
3723 DO l=lbt,ubt
3724 lc=(l-lbt)*jklen+mc
3725 DO k=lbk,ubk
3726 kc=(k-lbk)*jlen+lc
3727 DO j=jmin,jmax
3728 jke=1+(j-jmin)+kc
3729 a(i,j,k,l)=recve(jke)
3730 END DO
3731 END DO
3732 ENDDO
3733 END DO
3734 IF (PRESENT(b)) THEN
3735 joff=jke
3736 DO m=1,grecve
3737 mc=(m-1)*jktlen
3738 i=iend+m
3739 DO l=lbt,ubt
3740 lc=(l-lbt)*jklen+mc
3741 DO k=lbk,ubk
3742 kc=(k-lbk)*jlen+lc
3743 DO j=jmin,jmax
3744 jke=joff+1+(j-jmin)+kc
3745 b(i,j,k,l)=recve(jke)
3746 END DO
3747 END DO
3748 ENDDO
3749 END DO
3750 END IF
3751 IF (PRESENT(c)) THEN
3752 joff=jke
3753 DO m=1,grecve
3754 mc=(m-1)*jktlen
3755 i=iend+m
3756 DO l=lbt,ubt
3757 lc=(l-lbt)*jklen+mc
3758 DO k=lbk,ubk
3759 kc=(k-lbk)*jlen+lc
3760 DO j=jmin,jmax
3761 jke=joff+1+(j-jmin)+kc
3762 c(i,j,k,l)=recve(jke)
3763 END DO
3764 END DO
3765 ENDDO
3766 END DO
3767 END IF
3768 END IF
3769!
3770!-----------------------------------------------------------------------
3771! Pack Southern and Northern tile boundary data including ghost-points.
3772!-----------------------------------------------------------------------
3773!
3774 IF (sexchange) THEN
3775 sizes=0
3776 DO m=1,gsends
3777 mc=(m-1)*iktlen
3778 j=jstr+m-1
3779 DO l=lbt,ubt
3780 lc=(l-lbt)*iklen+mc
3781 DO k=lbk,ubk
3782 kc=(k-lbk)*ilen+lc
3783 DO i=imin,imax
3784 sizes=sizes+1
3785 iks=1+(i-imin)+kc
3786 sends(iks)=a(i,j,k,l)
3787 END DO
3788 END DO
3789 END DO
3790 END DO
3791 IF (PRESENT(b)) THEN
3792 ioff=iks
3793 DO m=1,gsends
3794 mc=(m-1)*iktlen
3795 j=jstr+m-1
3796 DO l=lbt,ubt
3797 lc=(l-lbt)*iklen+mc
3798 DO k=lbk,ubk
3799 kc=(k-lbk)*ilen+lc
3800 DO i=imin,imax
3801 sizes=sizes+1
3802 iks=ioff+1+(i-imin)+kc
3803 sends(iks)=b(i,j,k,l)
3804 END DO
3805 END DO
3806 END DO
3807 END DO
3808 END IF
3809 IF (PRESENT(c)) THEN
3810 ioff=iks
3811 DO m=1,gsends
3812 mc=(m-1)*iktlen
3813 j=jstr+m-1
3814 DO l=lbt,ubt
3815 lc=(l-lbt)*iklen+mc
3816 DO k=lbk,ubk
3817 kc=(k-lbk)*ilen+lc
3818 DO i=imin,imax
3819 sizes=sizes+1
3820 iks=ioff+1+(i-imin)+kc
3821 sends(iks)=c(i,j,k,l)
3822 END DO
3823 END DO
3824 END DO
3825 END DO
3826 END IF
3827 END IF
3828!
3829 IF (nexchange) THEN
3830 sizen=0
3831 DO m=1,gsendn
3832 mc=(m-1)*iktlen
3833 j=jend-gsendn+m
3834 DO l=lbt,ubt
3835 lc=(l-lbt)*iklen+mc
3836 DO k=lbk,ubk
3837 kc=(k-lbk)*ilen+lc
3838 DO i=imin,imax
3839 sizen=sizen+1
3840 ikn=1+(i-imin)+kc
3841 sendn(ikn)=a(i,j,k,l)
3842 END DO
3843 END DO
3844 END DO
3845 END DO
3846 IF (PRESENT(b)) THEN
3847 ioff=ikn
3848 DO m=1,gsendn
3849 mc=(m-1)*iktlen
3850 j=jend-gsendn+m
3851 DO l=lbt,ubt
3852 lc=(l-lbt)*iklen+mc
3853 DO k=lbk,ubk
3854 kc=(k-lbk)*ilen+lc
3855 DO i=imin,imax
3856 sizen=sizen+1
3857 ikn=ioff+1+(i-imin)+kc
3858 sendn(ikn)=b(i,j,k,l)
3859 END DO
3860 END DO
3861 END DO
3862 END DO
3863 END IF
3864 IF (PRESENT(c)) THEN
3865 ioff=ikn
3866 DO m=1,gsendn
3867 mc=(m-1)*iktlen
3868 j=jend-gsendn+m
3869 DO l=lbt,ubt
3870 lc=(l-lbt)*iklen+mc
3871 DO k=lbk,ubk
3872 kc=(k-lbk)*ilen+lc
3873 DO i=imin,imax
3874 sizen=sizen+1
3875 ikn=ioff+1+(i-imin)+kc
3876 sendn(ikn)=c(i,j,k,l)
3877 END DO
3878 END DO
3879 END DO
3880 END DO
3881 END IF
3882 END IF
3883!
3884!-----------------------------------------------------------------------
3885! Send and receive Southern and Northern segments.
3886!-----------------------------------------------------------------------
3887!
3888# if defined MPI
3889 IF (sexchange) THEN
3890 CALL mpi_irecv (recvs, nssize, mp_float, stile, ntag, &
3891 & ocn_comm_world, srequest, serror)
3892 END IF
3893 IF (nexchange) THEN
3894 CALL mpi_irecv (recvn, nssize, mp_float, ntile, stag, &
3895 & ocn_comm_world, nrequest, nerror)
3896 END IF
3897 IF (sexchange) THEN
3898 CALL mpi_send (sends, sizes, mp_float, stile, stag, &
3899 & ocn_comm_world, serror)
3900 END IF
3901 IF (nexchange) THEN
3902 CALL mpi_send (sendn, sizen, mp_float, ntile, ntag, &
3903 & ocn_comm_world, nerror)
3904 END IF
3905# endif
3906!
3907!-----------------------------------------------------------------------
3908! Unpack Northern and Southern segments.
3909!-----------------------------------------------------------------------
3910!
3911 IF (sexchange) THEN
3912# ifdef MPI
3913 CALL mpi_wait (srequest, status(1,2), serror)
3914 IF (serror.ne.mpi_success) THEN
3915 CALL mpi_error_string (serror, string, lstr, ierror)
3916 lstr=len_trim(string)
3917 WRITE (stdout,20) 'MPI_SEND/MPI_IRECV (Southern Edge)', &
3918 & myrank, serror, string(1:lstr)
3919 exit_flag=2
3920 RETURN
3921 END IF
3922# endif
3923 DO m=grecvs,1,-1
3924 mc=(grecvs-m)*iktlen
3925 j=jstr-m
3926 DO l=lbt,ubt
3927 lc=(l-lbt)*iklen+mc
3928 DO k=lbk,ubk
3929 kc=(k-lbk)*ilen+lc
3930 DO i=imin,imax
3931 iks=1+(i-imin)+kc
3932 a(i,j,k,l)=recvs(iks)
3933 END DO
3934 END DO
3935 END DO
3936 END DO
3937 IF (PRESENT(b)) THEN
3938 ioff=iks
3939 DO m=grecvs,1,-1
3940 mc=(grecvs-m)*iktlen
3941 j=jstr-m
3942 DO l=lbt,ubt
3943 lc=(l-lbt)*iklen+mc
3944 DO k=lbk,ubk
3945 kc=(k-lbk)*ilen+lc
3946 DO i=imin,imax
3947 iks=ioff+1+(i-imin)+kc
3948 b(i,j,k,l)=recvs(iks)
3949 END DO
3950 END DO
3951 END DO
3952 END DO
3953 END IF
3954 IF (PRESENT(c)) THEN
3955 ioff=iks
3956 DO m=grecvs,1,-1
3957 mc=(grecvs-m)*iktlen
3958 j=jstr-m
3959 DO l=lbt,ubt
3960 lc=(l-lbt)*iklen+mc
3961 DO k=lbk,ubk
3962 kc=(k-lbk)*ilen+lc
3963 DO i=imin,imax
3964 iks=ioff+1+(i-imin)+kc
3965 c(i,j,k,l)=recvs(iks)
3966 END DO
3967 END DO
3968 END DO
3969 END DO
3970 END IF
3971 END IF
3972!
3973 IF (nexchange) THEN
3974# ifdef MPI
3975 CALL mpi_wait (nrequest, status(1,4), nerror)
3976 IF (nerror.ne.mpi_success) THEN
3977 CALL mpi_error_string (nerror, string, lstr, ierror)
3978 lstr=len_trim(string)
3979 WRITE (stdout,20) 'MPI_SEND/MPI_IRECV (Northern Edge)', &
3980 & myrank, nerror, string(1:lstr)
3981 exit_flag=2
3982 RETURN
3983 END IF
3984# endif
3985 DO m=1,grecvn
3986 mc=(m-1)*iktlen
3987 j=jend+m
3988 DO l=lbt,ubt
3989 lc=(l-lbt)*iklen+mc
3990 DO k=lbk,ubk
3991 kc=(k-lbk)*ilen+lc
3992 DO i=imin,imax
3993 ikn=1+(i-imin)+kc
3994 a(i,j,k,l)=recvn(ikn)
3995 END DO
3996 END DO
3997 END DO
3998 END DO
3999 IF (PRESENT(b)) THEN
4000 ioff=ikn
4001 DO m=1,grecvn
4002 mc=(m-1)*iktlen
4003 j=jend+m
4004 DO l=lbt,ubt
4005 lc=(l-lbt)*iklen+mc
4006 DO k=lbk,ubk
4007 kc=(k-lbk)*ilen+lc
4008 DO i=imin,imax
4009 ikn=ioff+1+(i-imin)+kc
4010 b(i,j,k,l)=recvn(ikn)
4011 END DO
4012 END DO
4013 END DO
4014 END DO
4015 END IF
4016 IF (PRESENT(c)) THEN
4017 ioff=ikn
4018 DO m=1,grecvn
4019 mc=(m-1)*iktlen
4020 j=jend+m
4021 DO l=lbt,ubt
4022 lc=(l-lbt)*iklen+mc
4023 DO k=lbk,ubk
4024 kc=(k-lbk)*ilen+lc
4025 DO i=imin,imax
4026 ikn=ioff+1+(i-imin)+kc
4027 c(i,j,k,l)=recvn(ikn)
4028 END DO
4029 END DO
4030 END DO
4031 END DO
4032 END IF
4033 END IF
4034
4035# ifdef PROFILE
4036!
4037!-----------------------------------------------------------------------
4038! Turn off time clocks.
4039!-----------------------------------------------------------------------
4040!
4041 CALL wclock_off (ng, model, 62, __line__, myfile)
4042# endif
4043!
4044 RETURN
4045

References mod_param::bmemmax, mod_scalars::exit_flag, mod_parallel::mp_float, mod_parallel::myrank, mod_parallel::ocn_comm_world, mod_iounits::stdout, tile_neighbors(), wclock_off(), and wclock_on().

Referenced by analytical_mod::ana_nudgcoef_tile(), analytical_mod::ana_tclima_tile(), analytical_mod::ana_vmix_tile(), bvf_mix_mod::bvf_mix_tile(), nesting_mod::correct_tracer_tile(), nesting_mod::fine2coarse(), get_nudgcoef_mod::get_nudgcoef_nf90(), get_nudgcoef_mod::get_nudgcoef_pio(), gls_corstep_mod::gls_corstep_tile(), ini_fields_mod::ini_fields_tile(), ini_adjust_mod::ini_perturb_tile(), lmd_vmix_mod::lmd_finish_tile(), my25_corstep_mod::my25_corstep_tile(), pre_step3d_mod::pre_step3d_tile(), nesting_mod::put_composite(), nesting_mod::put_refine3d(), random_ic_mod::random_ic_tile(), rp_ini_fields_mod::rp_ini_fields_tile(), rp_pre_step3d_mod::rp_pre_step3d_tile(), rp_step3d_t_mod::rp_step3d_t_tile(), sed_bed_mod::sed_bed_tile(), sed_bedload_tile(), sed_surface_mod::sed_surface_tile(), set_diags_tile(), step3d_t_mod::step3d_t_tile(), tl_convolution_mod::tl_convolution_tile(), tl_nesting_mod::tl_correct_tracer_tile(), tl_nesting_mod::tl_fine2coarse(), tl_ini_fields_mod::tl_ini_fields_tile(), ini_adjust_mod::tl_ini_perturb_tile(), tl_pre_step3d_mod::tl_pre_step3d_tile(), tl_nesting_mod::tl_put_composite(), tl_nesting_mod::tl_put_refine3d(), tl_step3d_t_mod::tl_step3d_t_tile(), tl_unpack_tile(), and tl_variability_mod::tl_variability_tile().

Here is the call graph for this function:
Here is the caller graph for this function:

◆ tile_neighbors()

subroutine mp_exchange_mod::tile_neighbors ( integer, intent(in) ng,
integer, intent(in) nghost,
logical, intent(in) ew_periodic,
logical, intent(in) ns_periodic,
integer, intent(out) grecvw,
integer, intent(out) gsendw,
integer, intent(out) wtile,
logical, intent(out) wexchange,
integer, intent(out) grecve,
integer, intent(out) gsende,
integer, intent(out) etile,
logical, intent(out) eexchange,
integer, intent(out) grecvs,
integer, intent(out) gsends,
integer, intent(out) stile,
logical, intent(out) sexchange,
integer, intent(out) grecvn,
integer, intent(out) gsendn,
integer, intent(out) ntile,
logical, intent(out) nexchange )

Definition at line 73 of file mp_exchange.F.

78!***********************************************************************
79!
80 USE mod_param
81 USE mod_parallel
82!
83 implicit none
84!
85! Imported variable declarations.
86!
87 logical, intent(in) :: EW_periodic, NS_periodic
88
89 integer, intent(in) :: ng, Nghost
90
91 logical, intent(out) :: Wexchange, Eexchange
92 logical, intent(out) :: Sexchange, Nexchange
93
94 integer, intent(out) :: GrecvW, GsendW, Wtile
95 integer, intent(out) :: GrecvE, GsendE, Etile
96 integer, intent(out) :: GrecvS, GsendS, Stile
97 integer, intent(out) :: GrecvN, GsendN, Ntile
98!
99! Local variable declarations.
100!
101 integer :: i, j
102 integer :: MyRankI, MyRankJ, Null_Value, rank
103
104 integer, dimension(-1:NtileI(ng),-1:NtileJ(ng)) :: table
105!
106!-----------------------------------------------------------------------
107! Set tile partition table for looking up adjacent processes.
108!-----------------------------------------------------------------------
109!
110! Notice that a null value is used in places that data transmition is
111! not required.
112!
113# if defined MPI
114 null_value=mpi_proc_null
115# else
116 null_value=-1
117# endif
118 DO j=-1,ntilej(ng)
119 DO i=-1,ntilei(ng)
120 table(i,j)=null_value
121 END DO
122 END DO
123 rank=0
124 DO j=0,ntilej(ng)-1
125 DO i=0,ntilei(ng)-1
126 table(i,j)=rank
127 IF (myrank.eq.rank) THEN
128 myranki=i
129 myrankj=j
130 END IF
131 rank=rank+1
132 END DO
133 END DO
134!
135!-----------------------------------------------------------------------
136! Determine the rank of Western and Eastern tiles. Then, determine
137! the number of ghost-points to send and receive in the West- and
138! East-directions.
139!-----------------------------------------------------------------------
140!
141! This logic only works for two and three ghost points. The number of
142! ghost-points changes when periodic boundary condition are activated.
143! The periodicity is as follows:
144!
145! If two ghost-points:
146!
147! Lm-2 Lm-1 Lm Lm+1 Lm+2
148! -2 -1 0 1 2
149!
150! If three ghost-points:
151!
152! Lm-2 Lm-1 Lm Lm+1 Lm+2 Lm+3
153! -2 -1 0 1 2 3
154!
155 IF (ew_periodic) THEN
156 IF ((table(myranki-1,myrankj).eq.null_value).and. &
157 & (ntilei(ng).gt.1)) THEN
158 wtile=table(ntilei(ng)-1,myrankj)
159 etile=table(myranki+1,myrankj)
160 gsendw=nghost
161 gsende=nghost
162 IF (nghostpoints.eq.3) THEN
163 grecvw=nghost
164 ELSE
165 grecvw=nghost+1
166 END IF
167 grecve=nghost
168 ELSE IF ((table(myranki+1,myrankj).eq.null_value).and. &
169 & (ntilei(ng).gt.1)) THEN
170 wtile=table(myranki-1,myrankj)
171 etile=table(0,myrankj)
172 gsendw=nghost
173 IF (nghostpoints.eq.3) THEN
174 gsende=nghost
175 ELSE
176 gsende=nghost+1
177 END IF
178 grecvw=nghost
179 grecve=nghost
180 ELSE
181 wtile=table(myranki-1,myrankj)
182 etile=table(myranki+1,myrankj)
183 gsendw=nghost
184 gsende=nghost
185 grecvw=nghost
186 grecve=nghost
187 END IF
188 ELSE
189 wtile=table(myranki-1,myrankj)
190 etile=table(myranki+1,myrankj)
191 gsendw=nghost
192 gsende=nghost
193 grecvw=nghost
194 grecve=nghost
195 END IF
196!
197! Determine exchange switches.
198!
199 IF (wtile.eq.null_value) THEN
200 wexchange=.false.
201 ELSE
202 wexchange=.true.
203 END IF
204 IF (etile.eq.null_value) THEN
205 eexchange=.false.
206 ELSE
207 eexchange=.true.
208 END IF
209!
210!-----------------------------------------------------------------------
211! Determine the rank of Southern and Northern tiles. Then, determine
212! the number of ghost-points to send and receive in the South- and
213! North-directions.
214!-----------------------------------------------------------------------
215!
216! This logic only works for two and three ghost-points. The number of
217! ghost-points changes when periodic boundary condition are activated.
218! The periodicity is as follows:
219!
220! If two ghost-points:
221!
222! Mm-2 Mm-1 Mm Mm+1 Mm+2
223! -2 -1 0 1 2
224!
225! If three ghost-points:
226!
227! Mm-2 Mm-1 Mm Mm+1 Mm+2 Mm+3
228! -2 -1 0 1 2 3
229!
230 IF (ns_periodic) THEN
231 IF ((table(myranki,myrankj-1).eq.null_value).and. &
232 & (ntilej(ng).gt.1)) THEN
233 stile=table(myranki,ntilej(ng)-1)
234 ntile=table(myranki,myrankj+1)
235 gsends=nghost
236 gsendn=nghost
237 IF (nghostpoints.eq.3) THEN
238 grecvs=nghost
239 ELSE
240 grecvs=nghost+1
241 END IF
242 grecvn=nghost
243 ELSE IF ((table(myranki,myrankj+1).eq.null_value).and. &
244 & (ntilej(ng).gt.1)) then
245 stile=table(myranki,myrankj-1)
246 ntile=table(myranki,0)
247 gsends=nghost
248 IF (nghostpoints.eq.3) THEN
249 gsendn=nghost
250 ELSE
251 gsendn=nghost+1
252 END IF
253 grecvs=nghost
254 grecvn=nghost
255 ELSE
256 stile=table(myranki,myrankj-1)
257 ntile=table(myranki,myrankj+1)
258 gsends=nghost
259 gsendn=nghost
260 grecvs=nghost
261 grecvn=nghost
262 END IF
263 ELSE
264 stile=table(myranki,myrankj-1)
265 ntile=table(myranki,myrankj+1)
266 gsends=nghost
267 gsendn=nghost
268 grecvs=nghost
269 grecvn=nghost
270 END IF
271!
272! Determine exchange switches.
273!
274 IF (stile.eq.null_value) THEN
275 sexchange=.false.
276 ELSE
277 sexchange=.true.
278 END IF
279 IF (ntile.eq.null_value) THEN
280 nexchange=.false.
281 ELSE
282 nexchange=.true.
283 END IF
284
285 RETURN
mod_param::nghostpoints
integer nghostpoints
Definition mod_param.F:710
mod_param::ntilei
integer, dimension(:), allocatable ntilei
Definition mod_param.F:677
mod_param::ntilej
integer, dimension(:), allocatable ntilej
Definition mod_param.F:678

References mod_parallel::myrank, mod_param::nghostpoints, mod_param::ntilei, and mod_param::ntilej.

Referenced by ad_mp_exchange2d(), ad_mp_exchange2d_bry(), ad_mp_exchange3d(), ad_mp_exchange3d_bry(), ad_mp_exchange4d(), mp_exchange2d(), mp_exchange2d_bry(), mp_exchange3d(), mp_exchange3d_bry(), and mp_exchange4d().

Here is the caller graph for this function: