- Timestamp:
- 2021-02-12T09:57:09+01:00 (3 years ago)
- File:
-
- 1 edited
Legend:
- Unmodified
- Added
- Removed
-
NEMO/branches/2021/dev_r14383_PISCES_NEWDEV_PISCO/src/OCE/LBC/mppini.F90
r14275 r14448 69 69 jpi = jpiglo 70 70 jpj = jpjglo 71 jpk = jpkglo 72 jpim1 = jpi-1 ! inner domain indices 73 jpjm1 = jpj-1 ! " " 74 jpkm1 = MAX( 1, jpk-1 ) ! " " 71 jpk = MAX( 2, jpkglo ) 75 72 jpij = jpi*jpj 76 73 jpni = 1 … … 79 76 nimpp = 1 80 77 njmpp = 1 81 nbondi = 282 nbondj = 283 78 nidom = FLIO_DOM_NONE 84 npolj = 085 IF( jperio == 3 .OR. jperio == 4 ) npolj = 386 IF( jperio == 5 .OR. jperio == 6 ) npolj = 587 l_Iperio = jpni == 1 .AND. (jperio == 1 .OR. jperio == 4 .OR. jperio == 6 .OR. jperio == 7)88 l_Jperio = jpnj == 1 .AND. (jperio == 2 .OR. jperio == 7)89 79 ! 90 80 CALL init_doloop ! set start/end indices or do-loop depending on the halo width value (nn_hls) … … 95 85 WRITE(numout,*) '~~~~~~~~ ' 96 86 WRITE(numout,*) ' l_Iperio = ', l_Iperio, ' l_Jperio = ', l_Jperio 97 WRITE(numout,*) ' n polj = ', npolj , ' njmpp = ', njmpp87 WRITE(numout,*) ' njmpp = ', njmpp 98 88 ENDIF 99 89 ! … … 123 113 !! ** Method : Global domain is distributed in smaller local domains. 124 114 !! Periodic condition is a function of the local domain position 125 !! (global boundary or neighbouring domain) and of the global 126 !! periodic 127 !! Type : jperio global periodic condition 115 !! (global boundary or neighbouring domain) and of the global periodic 128 116 !! 129 117 !! ** Action : - set domain parameters … … 131 119 !! njmpp : latitudinal index 132 120 !! narea : number for local area 133 !! nbondi : mark for "east-west local boundary" 134 !! nbondj : mark for "north-south local boundary" 135 !! noea : number for local neighboring processor 136 !! nowe : number for local neighboring processor 137 !! noso : number for local neighboring processor 138 !! nono : number for local neighboring processor 139 !!---------------------------------------------------------------------- 140 INTEGER :: ji, jj, jn, jproc, jarea ! dummy loop indices 141 INTEGER :: inijmin 142 INTEGER :: inum ! local logical unit 143 INTEGER :: idir, ifreq ! local integers 144 INTEGER :: ii, il1, ili, imil ! - - 145 INTEGER :: ij, il2, ilj, ijm1 ! - - 146 INTEGER :: iino, ijno, iiso, ijso ! - - 147 INTEGER :: iiea, ijea, iiwe, ijwe ! - - 148 INTEGER :: iarea0 ! - - 149 INTEGER :: ierr, ios ! 150 INTEGER :: inbi, inbj, iimax, ijmax, icnt1, icnt2 121 !! mpinei : number of neighboring domains (starting at 0, -1 if no neighbourg) 122 !!---------------------------------------------------------------------- 123 INTEGER :: ji, jj, jn, jp, jh 124 INTEGER :: ii, ij, ii2, ij2 125 INTEGER :: inijmin ! number of oce subdomains 126 INTEGER :: inum, inum0 127 INTEGER :: ifreq, il1, imil, il2, ijm1 128 INTEGER :: ierr, ios 129 INTEGER :: inbi, inbj, iimax, ijmax, icnt1, icnt2 130 INTEGER, DIMENSION(16*n_hlsmax) :: ichanged 131 INTEGER, ALLOCATABLE, DIMENSION(: ) :: iin, ijn 132 INTEGER, ALLOCATABLE, DIMENSION(:,: ) :: iimppt, ijpi, ipproc 133 INTEGER, ALLOCATABLE, DIMENSION(:,: ) :: ijmppt, ijpj 134 INTEGER, ALLOCATABLE, DIMENSION(:,: ) :: impi 135 INTEGER, ALLOCATABLE, DIMENSION(:,:,:) :: inei 151 136 LOGICAL :: llbest, llauto 152 137 LOGICAL :: llwrtlay 138 LOGICAL :: llmpi_Iperio, llmpi_Jperio, llmpiNFold 153 139 LOGICAL :: ln_listonly 154 INTEGER, ALLOCATABLE, DIMENSION(:) :: iin, ii_nono, ii_noea ! 1D workspace 155 INTEGER, ALLOCATABLE, DIMENSION(:) :: ijn, ii_noso, ii_nowe ! - - 156 INTEGER, ALLOCATABLE, DIMENSION(:,:) :: iimppt, ijpi, ibondi, ipproc ! 2D workspace 157 INTEGER, ALLOCATABLE, DIMENSION(:,:) :: ijmppt, ijpj, ibondj, ipolj ! - - 158 INTEGER, ALLOCATABLE, DIMENSION(:,:) :: iie0, iis0, iono, ioea ! - - 159 INTEGER, ALLOCATABLE, DIMENSION(:,:) :: ije0, ijs0, ioso, iowe ! - - 160 LOGICAL, ALLOCATABLE, DIMENSION(:,:) :: llisoce ! - - 140 LOGICAL, ALLOCATABLE, DIMENSION(:,: ) :: llisOce ! is not land-domain only? 141 LOGICAL, ALLOCATABLE, DIMENSION(:,:,:) :: llnei ! are neighbourgs existing? 161 142 NAMELIST/nambdy/ ln_bdy, nb_bdy, ln_coords_file, cn_coords_file, & 162 143 & ln_mask_file, cn_mask_file, cn_dyn2d, nn_dyn2d_dta, & … … 165 146 & cn_ice, nn_ice_dta, & 166 147 & ln_vol, nn_volctl, nn_rimwidth 167 NAMELIST/nammpp/ jpni, jpnj, nn_hls, ln_nnogather, ln_listonly 148 NAMELIST/nammpp/ jpni, jpnj, nn_hls, ln_nnogather, ln_listonly, nn_comm 168 149 !!---------------------------------------------------------------------- 169 150 ! … … 193 174 IF(lwm) WRITE( numond, nammpp ) 194 175 ! 195 !!!------------------------------------196 !!! nn_hls shloud be read in nammpp197 !!!------------------------------------198 176 jpiglo = Ni0glo + 2 * nn_hls 199 177 jpjglo = Nj0glo + 2 * nn_hls … … 213 191 ! ----------------------------------- 214 192 ! 215 ! If dimensions of processors grid weren't specified in the namelist file193 ! If dimensions of MPI processes grid weren't specified in the namelist file 216 194 ! then we calculate them here now that we have our communicator size 217 195 IF(lwp) THEN … … 260 238 261 239 ! look for land mpi subdomains... 262 ALLOCATE( llis oce(jpni,jpnj) )263 CALL mpp_is_ocean( llis oce )264 inijmin = COUNT( llis oce ) ! number of oce subdomains240 ALLOCATE( llisOce(jpni,jpnj) ) 241 CALL mpp_is_ocean( llisOce ) 242 inijmin = COUNT( llisOce ) ! number of oce subdomains 265 243 266 244 IF( mppsize < inijmin ) THEN ! too many oce subdomains: can happen only if jpni and jpnj are prescribed... … … 319 297 9003 FORMAT (a, i5) 320 298 321 ALLOCATE( nfimpp(jpni ) , nfproc(jpni ) , nfjpi(jpni ) , & 322 & nimppt(jpnij) , ibonit(jpnij) , jpiall(jpnij) , jpjall(jpnij) , & 323 & njmppt(jpnij) , ibonjt(jpnij) , nis0all(jpnij) , njs0all(jpnij) , & 324 & nie0all(jpnij) , nje0all(jpnij) , & 325 & iin(jpnij), ii_nono(jpnij), ii_noea(jpnij), & 326 & ijn(jpnij), ii_noso(jpnij), ii_nowe(jpnij), & 327 & iimppt(jpni,jpnj), ijpi(jpni,jpnj), ibondi(jpni,jpnj), ipproc(jpni,jpnj), & 328 & ijmppt(jpni,jpnj), ijpj(jpni,jpnj), ibondj(jpni,jpnj), ipolj(jpni,jpnj), & 329 & iie0(jpni,jpnj), iis0(jpni,jpnj), iono(jpni,jpnj), ioea(jpni,jpnj), & 330 & ije0(jpni,jpnj), ijs0(jpni,jpnj), ioso(jpni,jpnj), iowe(jpni,jpnj), & 331 & STAT=ierr ) 299 ALLOCATE( nfimpp(jpni), nfproc(jpni), nfjpi(jpni), & 300 & iin(jpnij), ijn(jpnij), & 301 & iimppt(jpni,jpnj), ijmppt(jpni,jpnj), ijpi(jpni,jpnj), ijpj(jpni,jpnj), ipproc(jpni,jpnj), & 302 & inei(8,jpni,jpnj), llnei(8,jpni,jpnj), & 303 & impi(8,jpnij), & 304 & STAT=ierr ) 332 305 CALL mpp_sum( 'mppini', ierr ) 333 306 IF( ierr /= 0 ) CALL ctl_stop( 'STOP', 'mpp_init: unable to allocate standard ocean arrays' ) … … 343 316 ! 344 317 CALL mpp_basesplit( jpiglo, jpjglo, nn_hls, jpni, jpnj, jpimax, jpjmax, iimppt, ijmppt, ijpi, ijpj ) 345 CALL mpp_getnum( llisoce, ipproc, iin, ijn ) 346 ! 347 !DO jn = 1, jpni 348 ! jproc = ipproc(jn,jpnj) 349 ! ii = iin(jproc+1) 350 ! ij = ijn(jproc+1) 351 ! nfproc(jn) = jproc 352 ! nfimpp(jn) = iimppt(ii,ij) 353 ! nfjpi (jn) = ijpi(ii,ij) 354 !END DO 355 nfproc(:) = ipproc(:,jpnj) 356 nfimpp(:) = iimppt(:,jpnj) 357 nfjpi (:) = ijpi(:,jpnj) 318 CALL mpp_getnum( llisOce, ipproc, iin, ijn ) 319 ! 320 ii = iin(narea) 321 ij = ijn(narea) 322 jpi = ijpi(ii,ij) 323 jpj = ijpj(ii,ij) 324 jpk = MAX( 2, jpkglo ) 325 jpij = jpi*jpj 326 nimpp = iimppt(ii,ij) 327 njmpp = ijmppt(ii,ij) 328 ! 329 CALL init_doloop ! set start/end indices of do-loop, depending on the halo width value (nn_hls) 358 330 ! 359 331 IF(lwp) THEN … … 365 337 WRITE(numout,*) ' jpnj = ', jpnj 366 338 WRITE(numout,*) ' jpnij = ', jpnij 339 WRITE(numout,*) ' nimpp = ', nimpp 340 WRITE(numout,*) ' njmpp = ', njmpp 367 341 WRITE(numout,*) 368 342 WRITE(numout,*) ' sum ijpi(i,1) = ', sum(ijpi(:,1)), ' jpiglo = ', jpiglo 369 WRITE(numout,*) ' sum ijpj(1,j) = ', sum(ijpj(1,:)), ' jpjglo = ', jpjglo 370 ENDIF 371 372 ! 3. Subdomain description in the Regular Case 373 ! -------------------------------------------- 374 ! specific cases where there is no communication -> must do the periodicity by itself 375 ! Warning: because of potential land-area suppression, do not use nbond[ij] == 2 376 l_Iperio = jpni == 1 .AND. (jperio == 1 .OR. jperio == 4 .OR. jperio == 6 .OR. jperio == 7) 377 l_Jperio = jpnj == 1 .AND. (jperio == 2 .OR. jperio == 7) 378 379 DO jarea = 1, jpni*jpnj 380 ! 381 iarea0 = jarea - 1 382 ii = 1 + MOD(iarea0,jpni) 383 ij = 1 + iarea0/jpni 384 ili = ijpi(ii,ij) 385 ilj = ijpj(ii,ij) 386 ibondi(ii,ij) = 0 ! default: has e-w neighbours 387 IF( ii == 1 ) ibondi(ii,ij) = -1 ! first column, has only e neighbour 388 IF( ii == jpni ) ibondi(ii,ij) = 1 ! last column, has only w neighbour 389 IF( jpni == 1 ) ibondi(ii,ij) = 2 ! has no e-w neighbour 390 ibondj(ii,ij) = 0 ! default: has n-s neighbours 391 IF( ij == 1 ) ibondj(ii,ij) = -1 ! first row, has only n neighbour 392 IF( ij == jpnj ) ibondj(ii,ij) = 1 ! last row, has only s neighbour 393 IF( jpnj == 1 ) ibondj(ii,ij) = 2 ! has no n-s neighbour 394 395 ! Subdomain neighbors (get their zone number): default definition 396 ioso(ii,ij) = iarea0 - jpni 397 iowe(ii,ij) = iarea0 - 1 398 ioea(ii,ij) = iarea0 + 1 399 iono(ii,ij) = iarea0 + jpni 400 iis0(ii,ij) = 1 + nn_hls 401 iie0(ii,ij) = ili - nn_hls 402 ijs0(ii,ij) = 1 + nn_hls 403 ije0(ii,ij) = ilj - nn_hls 404 405 ! East-West periodicity: change ibondi, ioea, iowe 406 IF( jperio == 1 .OR. jperio == 4 .OR. jperio == 6 .OR. jperio == 7 ) THEN 407 IF( jpni /= 1 ) ibondi(ii,ij) = 0 ! redefine: all have e-w neighbours 408 IF( ii == 1 ) iowe(ii,ij) = iarea0 + (jpni-1) ! redefine: first column, address of w neighbour 409 IF( ii == jpni ) ioea(ii,ij) = iarea0 - (jpni-1) ! redefine: last column, address of e neighbour 410 ENDIF 411 412 ! Simple North-South periodicity: change ibondj, ioso, iono 413 IF( jperio == 2 .OR. jperio == 7 ) THEN 414 IF( jpnj /= 1 ) ibondj(ii,ij) = 0 ! redefine: all have n-s neighbours 415 IF( ij == 1 ) ioso(ii,ij) = iarea0 + jpni * (jpnj-1) ! redefine: first row, address of s neighbour 416 IF( ij == jpnj ) iono(ii,ij) = iarea0 - jpni * (jpnj-1) ! redefine: last row, address of n neighbour 417 ENDIF 418 419 ! North fold: define ipolj, change iono. Warning: we do not change ibondj... 420 ipolj(ii,ij) = 0 421 IF( jperio == 3 .OR. jperio == 4 ) THEN 422 ijm1 = jpni*(jpnj-1) 423 imil = ijm1+(jpni+1)/2 424 IF( jarea > ijm1 ) ipolj(ii,ij) = 3 425 IF( MOD(jpni,2) == 1 .AND. jarea == imil ) ipolj(ii,ij) = 4 426 IF( ipolj(ii,ij) == 3 ) iono(ii,ij) = jpni*jpnj-jarea+ijm1 ! MPI rank of northern neighbour 427 ENDIF 428 IF( jperio == 5 .OR. jperio == 6 ) THEN 429 ijm1 = jpni*(jpnj-1) 430 imil = ijm1+(jpni+1)/2 431 IF( jarea > ijm1) ipolj(ii,ij) = 5 432 IF( MOD(jpni,2) == 1 .AND. jarea == imil ) ipolj(ii,ij) = 6 433 IF( ipolj(ii,ij) == 5) iono(ii,ij) = jpni*jpnj-jarea+ijm1 ! MPI rank of northern neighbour 434 ENDIF 435 ! 436 END DO 437 438 ! 4. deal with land subdomains 439 ! ---------------------------- 440 ! 441 ! neighbour treatment: change ibondi, ibondj if next to a land zone 442 DO jarea = 1, jpni*jpnj 443 ii = 1 + MOD( jarea-1 , jpni ) 444 ij = 1 + (jarea-1) / jpni 445 ! land-only area with an active n neigbour 446 IF ( ipproc(ii,ij) == -1 .AND. 0 <= iono(ii,ij) .AND. iono(ii,ij) <= jpni*jpnj-1 ) THEN 447 iino = 1 + MOD( iono(ii,ij) , jpni ) ! ii index of this n neigbour 448 ijno = 1 + iono(ii,ij) / jpni ! ij index of this n neigbour 449 ! In case of north fold exchange: I am the n neigbour of my n neigbour!! (#1057) 450 ! --> for northern neighbours of northern row processors (in case of north-fold) 451 ! need to reverse the LOGICAL direction of communication 452 idir = 1 ! we are indeed the s neigbour of this n neigbour 453 IF( ij == jpnj .AND. ijno == jpnj ) idir = -1 ! both are on the last row, we are in fact the n neigbour 454 IF( ibondj(iino,ijno) == idir ) ibondj(iino,ijno) = 2 ! this n neigbour had only a s/n neigbour -> no more 455 IF( ibondj(iino,ijno) == 0 ) ibondj(iino,ijno) = -idir ! this n neigbour had both, n-s neighbours -> keep 1 456 ENDIF 457 ! land-only area with an active s neigbour 458 IF( ipproc(ii,ij) == -1 .AND. 0 <= ioso(ii,ij) .AND. ioso(ii,ij) <= jpni*jpnj-1 ) THEN 459 iiso = 1 + MOD( ioso(ii,ij) , jpni ) ! ii index of this s neigbour 460 ijso = 1 + ioso(ii,ij) / jpni ! ij index of this s neigbour 461 IF( ibondj(iiso,ijso) == -1 ) ibondj(iiso,ijso) = 2 ! this s neigbour had only a n neigbour -> no more neigbour 462 IF( ibondj(iiso,ijso) == 0 ) ibondj(iiso,ijso) = 1 ! this s neigbour had both, n-s neighbours -> keep s neigbour 463 ENDIF 464 ! land-only area with an active e neigbour 465 IF( ipproc(ii,ij) == -1 .AND. 0 <= ioea(ii,ij) .AND. ioea(ii,ij) <= jpni*jpnj-1 ) THEN 466 iiea = 1 + MOD( ioea(ii,ij) , jpni ) ! ii index of this e neigbour 467 ijea = 1 + ioea(ii,ij) / jpni ! ij index of this e neigbour 468 IF( ibondi(iiea,ijea) == 1 ) ibondi(iiea,ijea) = 2 ! this e neigbour had only a w neigbour -> no more neigbour 469 IF( ibondi(iiea,ijea) == 0 ) ibondi(iiea,ijea) = -1 ! this e neigbour had both, e-w neighbours -> keep e neigbour 470 ENDIF 471 ! land-only area with an active w neigbour 472 IF( ipproc(ii,ij) == -1 .AND. 0 <= iowe(ii,ij) .AND. iowe(ii,ij) <= jpni*jpnj-1) THEN 473 iiwe = 1 + MOD( iowe(ii,ij) , jpni ) ! ii index of this w neigbour 474 ijwe = 1 + iowe(ii,ij) / jpni ! ij index of this w neigbour 475 IF( ibondi(iiwe,ijwe) == -1 ) ibondi(iiwe,ijwe) = 2 ! this w neigbour had only a e neigbour -> no more neigbour 476 IF( ibondi(iiwe,ijwe) == 0 ) ibondi(iiwe,ijwe) = 1 ! this w neigbour had both, e-w neighbours -> keep w neigbour 477 ENDIF 478 END DO 479 480 ! 5. Subdomain print 481 ! ------------------ 482 IF(lwp) THEN 343 WRITE(numout,*) ' sum ijpj(1,j) = ', SUM(ijpj(1,:)), ' jpjglo = ', jpjglo 344 345 ! Subdomain grid print 483 346 ifreq = 4 484 347 il1 = 1 … … 503 366 9404 FORMAT(' * ' ,20(' ' ,i4,' * ') ) 504 367 ENDIF 505 506 ! just to save nono etc for all proc 507 ! warning ii*ij (zone) /= mpprank (processors)! 508 ! ioso = zone number, ii_noso = proc number 509 ii_noso(:) = -1 510 ii_nono(:) = -1 511 ii_noea(:) = -1 512 ii_nowe(:) = -1 513 DO jproc = 1, jpnij 514 ii = iin(jproc) 515 ij = ijn(jproc) 516 IF( 0 <= ioso(ii,ij) .AND. ioso(ii,ij) <= (jpni*jpnj-1) ) THEN 517 iiso = 1 + MOD( ioso(ii,ij) , jpni ) 518 ijso = 1 + ioso(ii,ij) / jpni 519 ii_noso(jproc) = ipproc(iiso,ijso) 520 ENDIF 521 IF( 0 <= iowe(ii,ij) .AND. iowe(ii,ij) <= (jpni*jpnj-1) ) THEN 522 iiwe = 1 + MOD( iowe(ii,ij) , jpni ) 523 ijwe = 1 + iowe(ii,ij) / jpni 524 ii_nowe(jproc) = ipproc(iiwe,ijwe) 525 ENDIF 526 IF( 0 <= ioea(ii,ij) .AND. ioea(ii,ij) <= (jpni*jpnj-1) ) THEN 527 iiea = 1 + MOD( ioea(ii,ij) , jpni ) 528 ijea = 1 + ioea(ii,ij) / jpni 529 ii_noea(jproc)= ipproc(iiea,ijea) 530 ENDIF 531 IF( 0 <= iono(ii,ij) .AND. iono(ii,ij) <= (jpni*jpnj-1) ) THEN 532 iino = 1 + MOD( iono(ii,ij) , jpni ) 533 ijno = 1 + iono(ii,ij) / jpni 534 ii_nono(jproc)= ipproc(iino,ijno) 535 ENDIF 536 END DO 537 538 ! 6. Change processor name 539 ! ------------------------ 540 ii = iin(narea) 541 ij = ijn(narea) 542 ! 543 jpi = ijpi(ii,ij) 544 !!$ Nis0 = iis0(ii,ij) 545 !!$ Nie0 = iie0(ii,ij) 546 jpj = ijpj(ii,ij) 547 !!$ Njs0 = ijs0(ii,ij) 548 !!$ Nje0 = ije0(ii,ij) 549 nbondi = ibondi(ii,ij) 550 nbondj = ibondj(ii,ij) 551 nimpp = iimppt(ii,ij) 552 njmpp = ijmppt(ii,ij) 553 jpk = jpkglo ! third dim 554 555 ! set default neighbours 556 noso = ii_noso(narea) 557 nowe = ii_nowe(narea) 558 noea = ii_noea(narea) 559 nono = ii_nono(narea) 560 561 nones = -1 562 nonws = -1 563 noses = -1 564 nosws = -1 565 566 noner = -1 567 nonwr = -1 568 noser = -1 569 noswr = -1 570 571 IF((nbondi .eq. -1) .or. (nbondi .eq. 0)) THEN ! east neighbour exists 572 IF(ibondj(iin(noea+1),ijn(noea+1)) .eq. 0) THEN 573 nones = ii_nono(noea+1) ! east neighbour has north and south neighbours 574 noses = ii_noso(noea+1) 575 ELSEIF(ibondj(iin(noea+1),ijn(noea+1)) .eq. -1) THEN 576 nones = ii_nono(noea+1) ! east neighbour has north neighbour 577 ELSEIF(ibondj(iin(noea+1),ijn(noea+1)) .eq. 1) THEN 578 noses = ii_noso(noea+1) ! east neighbour has south neighbour 579 END IF 580 END IF 581 IF((nbondi .eq. 1) .or. (nbondi .eq. 0)) THEN ! west neighbour exists 582 IF(ibondj(iin(nowe+1),ijn(nowe+1)) .eq. 0) THEN 583 nonws = ii_nono(nowe+1) ! west neighbour has north and south neighbours 584 nosws = ii_noso(nowe+1) 585 ELSEIF(ibondj(iin(nowe+1),ijn(nowe+1)) .eq. -1) THEN 586 nonws = ii_nono(nowe+1) ! west neighbour has north neighbour 587 ELSEIF(ibondj(iin(nowe+1),ijn(nowe+1)) .eq. 1) THEN 588 nosws = ii_noso(nowe+1) ! west neighbour has north neighbour 589 END IF 590 END IF 591 592 IF((nbondj .eq. -1) .or. (nbondj .eq. 0)) THEN ! north neighbour exists 593 IF(ibondi(iin(nono+1),ijn(nono+1)) .eq. 0) THEN 594 noner = ii_noea(nono+1) ! north neighbour has east and west neighbours 595 nonwr = ii_nowe(nono+1) 596 ELSEIF(ibondi(iin(nono+1),ijn(nono+1)) .eq. -1) THEN 597 noner = ii_noea(nono+1) ! north neighbour has east neighbour 598 ELSEIF(ibondi(iin(nono+1),ijn(nono+1)) .eq. 1) THEN 599 nonwr = ii_nowe(nono+1) ! north neighbour has west neighbour 600 END IF 601 END IF 602 IF((nbondj .eq. 1) .or. (nbondj .eq. 0)) THEN ! south neighbour exists 603 IF(ibondi(iin(noso+1),ijn(noso+1)) .eq. 0) THEN 604 noser = ii_noea(noso+1) ! south neighbour has east and west neighbours 605 noswr = ii_nowe(noso+1) 606 ELSEIF(ibondi(iin(noso+1),ijn(noso+1)) .eq. -1) THEN 607 noser = ii_noea(noso+1) ! south neighbour has east neighbour 608 ELSEIF(ibondi(iin(noso+1),ijn(noso+1)) .eq. 1) THEN 609 noswr = ii_nowe(noso+1) ! south neighbour has west neighbour 610 END IF 611 END IF 612 613 ! 614 CALL init_doloop ! set start/end indices of do-loop, depending on the halo width value (nn_hls) 615 ! 616 jpim1 = jpi-1 ! inner domain indices 617 jpjm1 = jpj-1 ! " " 618 jpkm1 = MAX( 1, jpk-1 ) ! " " 619 jpij = jpi*jpj ! jpi x j 620 DO jproc = 1, jpnij 621 ii = iin(jproc) 622 ij = ijn(jproc) 623 jpiall (jproc) = ijpi(ii,ij) 624 nis0all(jproc) = iis0(ii,ij) 625 nie0all(jproc) = iie0(ii,ij) 626 jpjall (jproc) = ijpj(ii,ij) 627 njs0all(jproc) = ijs0(ii,ij) 628 nje0all(jproc) = ije0(ii,ij) 629 ibonit(jproc) = ibondi(ii,ij) 630 ibonjt(jproc) = ibondj(ii,ij) 631 nimppt(jproc) = iimppt(ii,ij) 632 njmppt(jproc) = ijmppt(ii,ij) 633 END DO 634 368 ! 369 ! Store informations for the north pole folding communications 370 nfproc(:) = ipproc(:,jpnj) 371 nfimpp(:) = iimppt(:,jpnj) 372 nfjpi (:) = ijpi(:,jpnj) 373 ! 374 ! 3. Define Western, Eastern, Southern and Northern neighbors + corners in the subdomain grid reference 375 ! ------------------------------------------------------------------------------------------------------ 376 ! 377 ! note that North fold is has specific treatment for its MPI communications. 378 ! This must not be treated as a "usual" communication with a northern neighbor. 379 ! -> North fold processes have no Northern neighbor in the definition done bellow 380 ! 381 llmpi_Iperio = jpni > 1 .AND. l_Iperio ! do i-periodicity with an MPI communication? 382 llmpi_Jperio = jpnj > 1 .AND. l_Jperio ! do j-periodicity with an MPI communication? 383 ! 384 l_SelfPerio(1:2) = l_Iperio .AND. jpni == 1 ! west, east periodicity by itself 385 l_SelfPerio(3:4) = l_Jperio .AND. jpnj == 1 ! south, north periodicity by itself 386 l_SelfPerio(5:8) = l_SelfPerio(jpwe) .AND. l_SelfPerio(jpso) ! corners bi-periodicity by itself 387 ! 388 ! define neighbors mapping (1/2): default definition: ignore if neighbours are land-only subdomains or not 389 DO jj = 1, jpnj 390 DO ji = 1, jpni 391 ! 392 IF ( llisOce(ji,jj) ) THEN ! this subdomain has some ocean: it has neighbours 393 ! 394 inum0 = ji - 1 + ( jj - 1 ) * jpni ! index in the subdomains grid. start at 0 395 ! 396 ! Is there a neighbor? 397 llnei(jpwe,ji,jj) = ji > 1 .OR. llmpi_Iperio ! West nei exists if not the first column or llmpi_Iperio 398 llnei(jpea,ji,jj) = ji < jpni .OR. llmpi_Iperio ! East nei exists if not the last column or llmpi_Iperio 399 llnei(jpso,ji,jj) = jj > 1 .OR. llmpi_Jperio ! South nei exists if not the first line or llmpi_Jperio 400 llnei(jpno,ji,jj) = jj < jpnj .OR. llmpi_Jperio ! North nei exists if not the last line or llmpi_Jperio 401 llnei(jpsw,ji,jj) = llnei(jpwe,ji,jj) .AND. llnei(jpso,ji,jj) ! So-We nei exists if both South and West nei exist 402 llnei(jpse,ji,jj) = llnei(jpea,ji,jj) .AND. llnei(jpso,ji,jj) ! So-Ea nei exists if both South and East nei exist 403 llnei(jpnw,ji,jj) = llnei(jpwe,ji,jj) .AND. llnei(jpno,ji,jj) ! No-We nei exists if both North and West nei exist 404 llnei(jpne,ji,jj) = llnei(jpea,ji,jj) .AND. llnei(jpno,ji,jj) ! No-Ea nei exists if both North and East nei exist 405 ! 406 ! Which index (starting at 0) have neighbors in the subdomains grid? 407 IF( llnei(jpwe,ji,jj) ) inei(jpwe,ji,jj) = inum0 - 1 + jpni * COUNT( (/ ji == 1 /) ) 408 IF( llnei(jpea,ji,jj) ) inei(jpea,ji,jj) = inum0 + 1 - jpni * COUNT( (/ ji == jpni /) ) 409 IF( llnei(jpso,ji,jj) ) inei(jpso,ji,jj) = inum0 - jpni + jpni * jpnj * COUNT( (/ jj == 1 /) ) 410 IF( llnei(jpno,ji,jj) ) inei(jpno,ji,jj) = inum0 + jpni - jpni * jpnj * COUNT( (/ jj == jpnj /) ) 411 IF( llnei(jpsw,ji,jj) ) inei(jpsw,ji,jj) = inei(jpso,ji,jj) - 1 + jpni * COUNT( (/ ji == 1 /) ) 412 IF( llnei(jpse,ji,jj) ) inei(jpse,ji,jj) = inei(jpso,ji,jj) + 1 - jpni * COUNT( (/ ji == jpni /) ) 413 IF( llnei(jpnw,ji,jj) ) inei(jpnw,ji,jj) = inei(jpno,ji,jj) - 1 + jpni * COUNT( (/ ji == 1 /) ) 414 IF( llnei(jpne,ji,jj) ) inei(jpne,ji,jj) = inei(jpno,ji,jj) + 1 - jpni * COUNT( (/ ji == jpni /) ) 415 ! 416 ELSE ! land-only domain has no neighbour 417 llnei(:,ji,jj) = .FALSE. 418 ENDIF 419 ! 420 END DO 421 END DO 422 ! 423 ! define neighbors mapping (2/2): check if neighbours are not land-only subdomains 424 DO jj = 1, jpnj 425 DO ji = 1, jpni 426 DO jn = 1, 8 427 IF( llnei(jn,ji,jj) ) THEN ! if a neighbour is existing -> this should not be a land-only domain 428 ii = 1 + MOD( inei(jn,ji,jj) , jpni ) 429 ij = 1 + inei(jn,ji,jj) / jpni 430 llnei(jn,ji,jj) = llisOce( ii, ij ) 431 ENDIF 432 END DO 433 END DO 434 END DO 435 ! 436 ! update index of the neighbours in the subdomains grid 437 WHERE( .NOT. llnei ) inei = -1 438 ! 635 439 ! Save processor layout in ascii file 636 440 IF (llwrtlay) THEN 637 441 CALL ctl_opn( inum, 'layout.dat', 'REPLACE', 'FORMATTED', 'SEQUENTIAL', -1, numout, .FALSE., narea ) 638 WRITE(inum,'(a)') ' jpnij jpimax jpjmax jpk jpiglo jpjglo'//& 639 & ' ( local: narea jpi jpj )' 640 WRITE(inum,'(6i8,a,3i8,a)') jpnij,jpimax,jpjmax,jpk,jpiglo,jpjglo,& 641 & ' ( local: ',narea,jpi,jpj,' )' 642 WRITE(inum,'(a)') 'narea jpi jpj Nis0 Njs0 Nie0 Nje0 nimp njmp nono noso nowe noea nbondi nbondj ' 643 644 DO jproc = 1, jpnij 645 WRITE(inum,'(13i5,2i7)') jproc, jpiall(jproc), jpjall(jproc), & 646 & nis0all(jproc), njs0all(jproc), & 647 & nie0all(jproc), nje0all(jproc), & 648 & nimppt (jproc), njmppt (jproc), & 649 & ii_nono(jproc), ii_noso(jproc), & 650 & ii_nowe(jproc), ii_noea(jproc), & 651 & ibonit (jproc), ibonjt (jproc) 442 WRITE(inum,'(a)') ' jpnij jpimax jpjmax jpk jpiglo jpjglo ( local: narea jpi jpj )' 443 WRITE(inum,'(6i7,a,3i7,a)') jpnij,jpimax,jpjmax,jpk,jpiglo,jpjglo,' ( local: ',narea,jpi,jpj,' )' 444 WRITE(inum,*) 445 WRITE(inum, *) '------------------------------------' 446 WRITE(inum,'(a,i2)') ' Mapping of the default neighnourgs ' 447 WRITE(inum, *) '------------------------------------' 448 WRITE(inum,*) 449 WRITE(inum,'(a)') ' rank ii ij jpi jpj nimpp njmpp mpiwe mpiea mpiso mpino mpisw mpise mpinw mpine' 450 DO jp = 1, jpnij 451 ii = iin(jp) 452 ij = ijn(jp) 453 WRITE(inum,'(15i6)') jp-1, ii, ij, ijpi(ii,ij), ijpj(ii,ij), iimppt(ii,ij), ijmppt(ii,ij), inei(:,ii,ij) 652 454 END DO 653 END IF 654 655 ! ! north fold parameter 656 ! Defined npolj, either 0, 3 , 4 , 5 , 6 657 ! In this case the important thing is that npolj /= 0 658 ! Because if we go through these line it is because jpni >1 and thus 659 ! we must use lbcnorthmpp, which tests only npolj =0 or npolj /= 0 660 npolj = 0 661 ij = ijn(narea) 662 IF( jperio == 3 .OR. jperio == 4 ) THEN 663 IF( ij == jpnj ) npolj = 3 664 ENDIF 665 IF( jperio == 5 .OR. jperio == 6 ) THEN 666 IF( ij == jpnj ) npolj = 5 667 ENDIF 455 ENDIF 456 457 ! 458 ! 4. Define Western, Eastern, Southern and Northern neighbors + corners for each mpi process 459 ! ------------------------------------------------------------------------------------------ 460 ! 461 ! rewrite information from "subdomain grid" to mpi process list 462 ! Warning, for example: 463 ! position of the northern neighbor in the "subdomain grid" 464 ! position of the northern neighbor in the "mpi process list" 465 466 ! default definition: no neighbors 467 impi(:,:) = -1 ! (starting at 0, -1 if no neighbourg) 468 469 DO jp = 1, jpnij 470 ii = iin(jp) 471 ij = ijn(jp) 472 DO jn = 1, 8 473 IF( llnei(jn,ii,ij) ) THEN ! must be tested as some land-domain can be kept to fit mppsize 474 ii2 = 1 + MOD( inei(jn,ii,ij) , jpni ) 475 ij2 = 1 + inei(jn,ii,ij) / jpni 476 impi(jn,jp) = ipproc( ii2, ij2 ) 477 ENDIF 478 END DO 479 END DO 480 481 ! 482 ! 4. keep information for the local process 483 ! ----------------------------------------- 484 ! 485 ! set default neighbours 486 mpinei(:) = impi(:,narea) 487 DO jh = 1, n_hlsmax 488 mpiSnei(jh,:) = impi(:,narea) ! default definition 489 mpiRnei(jh,:) = impi(:,narea) 490 END DO 668 491 ! 669 492 IF(lwp) THEN 670 493 WRITE(numout,*) 671 494 WRITE(numout,*) ' resulting internal parameters : ' 672 WRITE(numout,*) ' narea = ', narea 673 WRITE(numout,*) ' nowe = ', nowe , ' noea = ', noea 674 WRITE(numout,*) ' nono = ', nono , ' noso = ', noso 675 WRITE(numout,*) ' nbondi = ', nbondi 676 WRITE(numout,*) ' nbondj = ', nbondj 677 WRITE(numout,*) ' npolj = ', npolj 678 WRITE(numout,*) ' l_Iperio = ', l_Iperio 679 WRITE(numout,*) ' l_Jperio = ', l_Jperio 680 WRITE(numout,*) ' nimpp = ', nimpp 681 WRITE(numout,*) ' njmpp = ', njmpp 682 ENDIF 683 495 WRITE(numout,*) ' narea = ', narea 496 WRITE(numout,*) ' mpi nei west = ', mpinei(jpwe) , ' mpi nei east = ', mpinei(jpea) 497 WRITE(numout,*) ' mpi nei south = ', mpinei(jpso) , ' mpi nei north = ', mpinei(jpno) 498 WRITE(numout,*) ' mpi nei so-we = ', mpinei(jpsw) , ' mpi nei so-ea = ', mpinei(jpse) 499 WRITE(numout,*) ' mpi nei no-we = ', mpinei(jpnw) , ' mpi nei no-ea = ', mpinei(jpne) 500 ENDIF 684 501 ! ! Prepare mpp north fold 685 IF( jperio >= 3 .AND. jperio <= 6 .AND. jpni > 1 ) THEN 502 ! 503 llmpiNFold = jpni > 1 .AND. l_NFold ! is the North fold done with an MPI communication? 504 l_IdoNFold = ijn(narea) == jpnj .AND. l_NFold ! is this process doing North fold? 505 ! 506 IF( llmpiNFold ) THEN 686 507 CALL mpp_ini_north 687 508 IF (lwp) THEN 688 509 WRITE(numout,*) 689 510 WRITE(numout,*) ' ==>>> North fold boundary prepared for jpni >1' 690 ! additional prints in layout.dat 691 ENDIF 692 IF (llwrtlay) THEN 511 ENDIF 512 IF (llwrtlay) THEN ! additional prints in layout.dat 693 513 WRITE(inum,*) 694 514 WRITE(inum,*) 695 WRITE(inum,*) ' number of subdomains located along the north fold : ', ndim_rank_north515 WRITE(inum,*) 'Number of subdomains located along the north fold : ', ndim_rank_north 696 516 WRITE(inum,*) 'Rank of the subdomains located along the north fold : ', ndim_rank_north 697 DO jp roc= 1, ndim_rank_north, 5698 WRITE(inum,*) nrank_north( jp roc:MINVAL( (/jproc+4,ndim_rank_north/) ) )517 DO jp = 1, ndim_rank_north, 5 518 WRITE(inum,*) nrank_north( jp:MINVAL( (/jp+4,ndim_rank_north/) ) ) 699 519 END DO 700 520 ENDIF 701 ENDIF 702 703 ! 704 CALL mpp_ini_nc ! Initialize communicator for neighbourhood collective communications 705 ! 706 CALL init_ioipsl ! Prepare NetCDF output file (if necessary) 707 ! 708 IF (( jperio >= 3 .AND. jperio <= 6 .AND. jpni > 1 ).AND.( ln_nnogather )) THEN 709 CALL init_nfdcom ! northfold neighbour lists 710 IF (llwrtlay) THEN 711 WRITE(inum,*) 712 WRITE(inum,*) 713 WRITE(inum,*) 'north fold exchanges with explicit point-to-point messaging :' 714 WRITE(inum,*) 'nsndto : ', nsndto 715 WRITE(inum,*) 'isendto : ', isendto 716 ENDIF 717 ENDIF 521 IF ( l_IdoNFold .AND. ln_nnogather ) THEN 522 CALL init_nfdcom ! northfold neighbour lists 523 IF (llwrtlay) THEN 524 WRITE(inum,*) 525 WRITE(inum,*) 'north fold exchanges with explicit point-to-point messaging :' 526 WRITE(inum,*) ' nsndto : ', nsndto 527 WRITE(inum,*) ' isendto : ', isendto(1:nsndto) 528 ENDIF 529 ENDIF 530 ENDIF 531 ! 532 CALL mpp_ini_nc(nn_hls) ! Initialize communicator for neighbourhood collective communications 533 DO jh = 1, n_hlsmax 534 mpi_nc_com4(jh) = mpi_nc_com4(nn_hls) ! default definition 535 mpi_nc_com8(jh) = mpi_nc_com8(nn_hls) 536 END DO 537 ! 538 CALL init_excl_landpt ! exclude exchanges which contain only land points 539 ! 540 ! Save processor layout changes in ascii file 541 DO jh = 1, n_hlsmax ! different halo size 542 DO ji = 1, 8 543 ichanged(16*(jh-1) +ji) = COUNT( mpinei(ji:ji) /= mpiSnei(jh,ji:ji) ) 544 ichanged(16*(jh-1)+8+ji) = COUNT( mpinei(ji:ji) /= mpiRnei(jh,ji:ji) ) 545 END DO 546 END DO 547 CALL mpp_sum( "mpp_init", ichanged ) ! must be called by all processes 548 IF (llwrtlay) THEN 549 WRITE(inum,*) 550 WRITE(inum, *) '----------------------------------------------------------------------' 551 WRITE(inum,'(a,i2)') ' Mapping of the neighnourgs once excluding comm with only land points ' 552 WRITE(inum, *) '----------------------------------------------------------------------' 553 DO jh = 1, n_hlsmax ! different halo size 554 WRITE(inum,*) 555 WRITE(inum,'(a,i2)') 'halo size: ', jh 556 WRITE(inum, *) '---------' 557 WRITE(inum,'(a)') ' rank ii ij mpiwe mpiea mpiso mpino mpisw mpise mpinw mpine' 558 WRITE(inum, '(11i6,a)') narea-1, iin(narea), ijn(narea), mpinei(:), ' <- Org' 559 WRITE(inum,'(18x,8i6,a,i1,a)') mpiSnei(jh,:), ' <- Send ', COUNT( mpinei(:) /= mpiSnei(jh,:) ), ' modif' 560 WRITE(inum,'(18x,8i6,a,i1,a)') mpiRnei(jh,:), ' <- Recv ', COUNT( mpinei(:) /= mpiRnei(jh,:) ), ' modif' 561 WRITE(inum,*) ' total changes among all mpi tasks:' 562 WRITE(inum,*) ' mpiwe mpiea mpiso mpino mpisw mpise mpinw mpine' 563 WRITE(inum,'(a,8i6)') ' Send: ', ichanged(jh*16-15:jh*16-8) 564 WRITE(inum,'(a,8i6)') ' Recv: ', ichanged(jh*16 -7:jh*16 ) 565 END DO 566 ENDIF 567 ! 568 CALL init_ioipsl ! Prepare NetCDF output file (if necessary) 718 569 ! 719 570 IF (llwrtlay) CLOSE(inum) 720 571 ! 721 DEALLOCATE(iin, ijn, ii_nono, ii_noea, ii_noso, ii_nowe, & 722 & iimppt, ijmppt, ibondi, ibondj, ipproc, ipolj, & 723 & ijpi, ijpj, iie0, ije0, iis0, ijs0, & 724 & iono, ioea, ioso, iowe, llisoce) 572 DEALLOCATE(iin, ijn, iimppt, ijmppt, ijpi, ijpj, ipproc, inei, llnei, impi, llisOce) 725 573 ! 726 574 END SUBROUTINE mpp_init … … 789 637 CALL ctl_stop( 'STOP', ctmp1, ctmp2 ) 790 638 ENDIF 791 IF( jperio == 3 .OR. jperio == 4 .OR. jperio == 5 .OR. jperio == 6) THEN639 IF( l_NFold ) THEN 792 640 ! minimize the size of the last row to compensate for the north pole folding coast 793 IF( jperio == 3 .OR. jperio == 4) ijpjmin = 2+3*khls ! V and F folding must be outside of southern halos794 IF( jperio == 5 .OR. jperio == 6) ijpjmin = 1+3*khls ! V and F folding must be outside of southern halos795 irm = knbj - irestj 796 klcj(:,knbj) = MAX( ijpjmin, kjmax-irm ) 797 irm = irm - ( kjmax - klcj(1,knbj) ) 641 IF( c_NFtype == 'T' ) ijpjmin = 2+3*khls ! V and F folding must be outside of southern halos 642 IF( c_NFtype == 'F' ) ijpjmin = 1+3*khls ! V and F folding must be outside of southern halos 643 irm = knbj - irestj ! total number of lines to be removed 644 klcj(:,knbj) = MAX( ijpjmin, kjmax-irm ) ! we must have jpj >= ijpjmin in the last row 645 irm = irm - ( kjmax - klcj(1,knbj) ) ! remaining number of lines to remove 798 646 irestj = knbj - 1 - irm 799 647 klcj(:, irestj+1:knbj-1) = kjmax-1 … … 860 708 LOGICAL :: llist 861 709 LOGICAL, DIMENSION(:,:), ALLOCATABLE :: llmsk2d ! max size of the subdomains along i,j 862 LOGICAL, DIMENSION(:,:), ALLOCATABLE :: llis oce ! - -710 LOGICAL, DIMENSION(:,:), ALLOCATABLE :: llisOce ! - - 863 711 REAL(wp):: zpropland 864 712 !!---------------------------------------------------------------------- … … 883 731 iszimin = 4*nn_hls ! minimum size of the MPI subdomain so halos are always adressing neighbor inner domain 884 732 iszjmin = 4*nn_hls 885 IF( jperio == 3 .OR. jperio == 4) iszjmin = MAX(iszjmin, 2+3*nn_hls) ! V and F folding must be outside of southern halos886 IF( jperio == 5 .OR. jperio == 6) iszjmin = MAX(iszjmin, 1+3*nn_hls) ! V and F folding must be outside of southern halos733 IF( c_NFtype == 'T' ) iszjmin = MAX(iszjmin, 2+3*nn_hls) ! V and F folding must be outside of southern halos 734 IF( c_NFtype == 'F' ) iszjmin = MAX(iszjmin, 1+3*nn_hls) ! V and F folding must be outside of southern halos 887 735 ! 888 736 ! get the list of knbi that gives a smaller jpimax than knbi-1 … … 933 781 iszi1(ii) = iszi0(ji) 934 782 iszj1(ii) = iszj0(jj) 935 END 783 ENDIF 936 784 END DO 937 785 END DO … … 989 837 WRITE(numout,*) ' -----------------------------------------------------' 990 838 WRITE(numout,*) 991 END 839 ENDIF 992 840 ji = isz0 ! initialization with the largest value 993 ALLOCATE( llis oce(inbi0(ji), inbj0(ji)) )994 CALL mpp_is_ocean( llis oce ) ! Warning: must be call by all cores (call mpp_sum)995 inbijold = COUNT(llis oce)996 DEALLOCATE( llis oce )841 ALLOCATE( llisOce(inbi0(ji), inbj0(ji)) ) 842 CALL mpp_is_ocean( llisOce ) ! Warning: must be call by all cores (call mpp_sum) 843 inbijold = COUNT(llisOce) 844 DEALLOCATE( llisOce ) 997 845 DO ji =isz0-1,1,-1 998 ALLOCATE( llis oce(inbi0(ji), inbj0(ji)) )999 CALL mpp_is_ocean( llis oce ) ! Warning: must be call by all cores (call mpp_sum)1000 inbij = COUNT(llis oce)1001 DEALLOCATE( llis oce )846 ALLOCATE( llisOce(inbi0(ji), inbj0(ji)) ) 847 CALL mpp_is_ocean( llisOce ) ! Warning: must be call by all cores (call mpp_sum) 848 inbij = COUNT(llisOce) 849 DEALLOCATE( llisOce ) 1002 850 IF(lwp .AND. inbij < inbijold) THEN 1003 851 WRITE(numout,'(a, i6, a, i6, a, f4.1, a, i9, a, i6, a, i6, a)') & … … 1006 854 & '%), largest oce domain: ', iszi0(ji)*iszj0(ji), ' ( ', iszi0(ji),' x ', iszj0(ji), ' )' 1007 855 inbijold = inbij 1008 END 856 ENDIF 1009 857 END DO 1010 858 DEALLOCATE( inbi0, inbj0, iszi0, iszj0 ) … … 1022 870 DO WHILE( inbij > knbij ) ! while the number of ocean subdomains exceed the number of procs 1023 871 ii = ii -1 1024 ALLOCATE( llis oce(inbi0(ii), inbj0(ii)) )1025 CALL mpp_is_ocean( llis oce ) ! must be done by all core1026 inbij = COUNT(llis oce)1027 DEALLOCATE( llis oce )872 ALLOCATE( llisOce(inbi0(ii), inbj0(ii)) ) 873 CALL mpp_is_ocean( llisOce ) ! must be done by all core 874 inbij = COUNT(llisOce) 875 DEALLOCATE( llisOce ) 1028 876 END DO 1029 877 knbi = inbi0(ii) … … 1073 921 ! 1074 922 ALLOCATE( lloce(Ni0glo, ijsz) ) ! allocate the strip 1075 CALL read bot_strip( ijstr, ijsz, lloce )923 CALL read_mask( 1, ijstr, Ni0glo, ijsz, lloce ) 1076 924 inboce = COUNT(lloce) ! number of ocean point in the stripe 1077 925 DEALLOCATE(lloce) … … 1087 935 1088 936 1089 SUBROUTINE mpp_is_ocean( ld isoce )937 SUBROUTINE mpp_is_ocean( ldIsOce ) 1090 938 !!---------------------------------------------------------------------- 1091 939 !! *** ROUTINE mpp_is_ocean *** … … 1095 943 !! at least 1 ocean point. 1096 944 !! We must indeed ensure that each subdomain that is a neighbour 1097 !! of a land subdomain 945 !! of a land subdomain, has only land points on its boundary 1098 946 !! (inside the inner subdomain) with the land subdomain. 1099 947 !! This is needed to get the proper bondary conditions on … … 1102 950 !! ** Method : read inbj strips (of length Ni0glo) of the land-sea mask 1103 951 !!---------------------------------------------------------------------- 1104 LOGICAL, DIMENSION(:,:), INTENT( out) :: ld isoce ! .true. if a sub domain constains 1 ocean point952 LOGICAL, DIMENSION(:,:), INTENT( out) :: ldIsOce ! .true. if a sub domain constains 1 ocean point 1105 953 ! 1106 954 INTEGER :: idiv, iimax, ijmax, iarea … … 1115 963 ! do nothing if there is no land-sea mask 1116 964 IF( numbot == -1 .AND. numbdy == -1 ) THEN 1117 ld isoce(:,:) = .TRUE.965 ldIsOce(:,:) = .TRUE. 1118 966 RETURN 1119 967 ENDIF 1120 968 ! 1121 inbi = SIZE( ld isoce, dim = 1 )1122 inbj = SIZE( ld isoce, dim = 2 )969 inbi = SIZE( ldIsOce, dim = 1 ) 970 inbj = SIZE( ldIsOce, dim = 2 ) 1123 971 ! 1124 972 ! we want to read inbj strips of the land-sea mask. -> pick up inbj processes every idiv processes starting at 1 … … 1143 991 inry = iny - COUNT( (/ iarea == 1, iarea == inbj /) ) ! number of point to read in y-direction 1144 992 isty = 1 + COUNT( (/ iarea == 1 /) ) ! read from the first or the second line? 1145 CALL read bot_strip( ijmppt(1,iarea) - 2 + isty, inry, lloce(2:inx-1, isty:inry+isty-1) ) ! read the strip993 CALL read_mask( 1, ijmppt(1,iarea) - 2 + isty, Ni0glo, inry, lloce(2:inx-1, isty:inry+isty-1) ) ! read the strip 1146 994 ! 1147 995 IF( iarea == 1 ) THEN ! the first line was not read 1148 IF( jperio == 2 .OR. jperio == 7 ) THEN! north-south periodocity1149 CALL read bot_strip( Nj0glo, 1, lloce(2:inx-1, 1) ) ! read the last line -> first line of lloce996 IF( l_Jperio ) THEN ! north-south periodocity 997 CALL read_mask( 1, Nj0glo, Ni0glo, 1, lloce(2:inx-1, 1) ) ! read the last line -> first line of lloce 1150 998 ELSE 1151 999 lloce(2:inx-1, 1) = .FALSE. ! closed boundary … … 1153 1001 ENDIF 1154 1002 IF( iarea == inbj ) THEN ! the last line was not read 1155 IF( jperio == 2 .OR. jperio == 7 ) THEN! north-south periodocity1156 CALL read bot_strip( 1, 1, lloce(2:inx-1,iny) )! read the first line -> last line of lloce1157 ELSEIF( jperio == 3 .OR. jperio == 4 ) THEN! north-pole folding T-pivot, T-point1003 IF( l_Jperio ) THEN ! north-south periodocity 1004 CALL read_mask( 1, 1, Ni0glo, 1, lloce(2:inx-1,iny) ) ! read the first line -> last line of lloce 1005 ELSEIF( c_NFtype == 'T' ) THEN ! north-pole folding T-pivot, T-point 1158 1006 lloce(2,iny) = lloce(2,iny-2) ! here we have 1 halo (even if nn_hls>1) 1159 1007 DO ji = 3,inx-1 … … 1163 1011 lloce(ji,iny-1) = lloce(inx-ji+2,iny-1) 1164 1012 END DO 1165 ELSEIF( jperio == 5 .OR. jperio == 6 ) THEN! north-pole folding F-pivot, T-point, 1 halo1013 ELSEIF( c_NFtype == 'F' ) THEN ! north-pole folding F-pivot, T-point, 1 halo 1166 1014 lloce(inx/2+1,iny-1) = lloce(inx/2,iny-1) ! here we have 1 halo (even if nn_hls>1) 1167 1015 lloce(inx -1,iny-1) = lloce(2 ,iny-1) … … 1174 1022 ENDIF 1175 1023 ! ! first and last column were not read 1176 IF( jperio == 1 .OR. jperio == 4 .OR. jperio == 6 .OR. jperio == 7) THEN1024 IF( l_Iperio ) THEN 1177 1025 lloce(1,:) = lloce(inx-1,:) ; lloce(inx,:) = lloce(2,:) ! east-west periodocity 1178 1026 ELSE … … 1193 1041 CALL mpp_sum( 'mppini', inboce_1d ) 1194 1042 inboce = RESHAPE(inboce_1d, (/inbi, inbj/)) 1195 ld isoce(:,:) = inboce(:,:) /= 01043 ldIsOce(:,:) = inboce(:,:) /= 0 1196 1044 DEALLOCATE(inboce, inboce_1d) 1197 1045 ! … … 1199 1047 1200 1048 1201 SUBROUTINE read bot_strip( kjstr, kjcnt, ldoce )1202 !!---------------------------------------------------------------------- 1203 !! *** ROUTINE read bot_strip***1049 SUBROUTINE read_mask( kistr, kjstr, kicnt, kjcnt, ldoce ) 1050 !!---------------------------------------------------------------------- 1051 !! *** ROUTINE read_mask *** 1204 1052 !! 1205 1053 !! ** Purpose : Read relevant bathymetric information in order to … … 1209 1057 !! ** Method : read stipe of size (Ni0glo,...) 1210 1058 !!---------------------------------------------------------------------- 1211 INTEGER , INTENT(in ) :: kjstr ! startingj position of the reading1212 INTEGER , INTENT(in ) :: kjcnt ! number of lines to read1213 LOGICAL, DIMENSION( Ni0glo,kjcnt), INTENT( out) :: ldoce! ldoce(i,j) = .true. if the point (i,j) is ocean1214 ! 1215 INTEGER :: inumsave! local logical unit1216 REAL(wp), DIMENSION( Ni0glo,kjcnt) :: zbot, zbdy1059 INTEGER , INTENT(in ) :: kistr, kjstr ! starting i and j position of the reading 1060 INTEGER , INTENT(in ) :: kicnt, kjcnt ! number of points to read in i and j directions 1061 LOGICAL, DIMENSION(kicnt,kjcnt), INTENT( out) :: ldoce ! ldoce(i,j) = .true. if the point (i,j) is ocean 1062 ! 1063 INTEGER :: inumsave ! local logical unit 1064 REAL(wp), DIMENSION(kicnt,kjcnt) :: zbot, zbdy 1217 1065 !!---------------------------------------------------------------------- 1218 1066 ! … … 1220 1068 ! 1221 1069 IF( numbot /= -1 ) THEN 1222 CALL iom_get( numbot, jpdom_unknown, 'bottom_level', zbot, kstart = (/ 1,kjstr/), kcount = (/Ni0glo, kjcnt/) )1070 CALL iom_get( numbot, jpdom_unknown, 'bottom_level', zbot, kstart = (/kistr,kjstr/), kcount = (/kicnt, kjcnt/) ) 1223 1071 ELSE 1224 1072 zbot(:,:) = 1._wp ! put a non-null value … … 1226 1074 ! 1227 1075 IF( numbdy /= -1 ) THEN ! Adjust with bdy_msk if it exists 1228 CALL iom_get ( numbdy, jpdom_unknown, 'bdy_msk', zbdy, kstart = (/ 1,kjstr/), kcount = (/Ni0glo, kjcnt/) )1076 CALL iom_get ( numbdy, jpdom_unknown, 'bdy_msk', zbdy, kstart = (/kistr,kjstr/), kcount = (/kicnt, kjcnt/) ) 1229 1077 zbot(:,:) = zbot(:,:) * zbdy(:,:) 1230 1078 ENDIF 1231 1079 ! 1232 ldoce(:,:) = zbot(:,:) > 0._wp1080 ldoce(:,:) = NINT(zbot(:,:)) > 0 1233 1081 numout = inumsave 1234 1082 ! 1235 END SUBROUTINE read bot_strip1236 1237 1238 SUBROUTINE mpp_getnum( ld isoce, kproc, kipos, kjpos )1083 END SUBROUTINE read_mask 1084 1085 1086 SUBROUTINE mpp_getnum( ldIsOce, kproc, kipos, kjpos ) 1239 1087 !!---------------------------------------------------------------------- 1240 1088 !! *** ROUTINE mpp_getnum *** … … 1244 1092 !! ** Method : start from bottom left. First skip land subdomain, and finally use them if needed 1245 1093 !!---------------------------------------------------------------------- 1246 LOGICAL, DIMENSION(:,:), INTENT(in ) :: ld isoce ! F if land process1247 INTEGER, DIMENSION(:,:), INTENT( out) :: kproc ! subdomain number (-1 if supressed, starting at 0)1094 LOGICAL, DIMENSION(:,:), INTENT(in ) :: ldIsOce ! F if land process 1095 INTEGER, DIMENSION(:,:), INTENT( out) :: kproc ! subdomain number (-1 if not existing, starting at 0) 1248 1096 INTEGER, DIMENSION( :), INTENT( out) :: kipos ! i-position of the subdomain (from 1 to jpni) 1249 1097 INTEGER, DIMENSION( :), INTENT( out) :: kjpos ! j-position of the subdomain (from 1 to jpnj) … … 1253 1101 !!---------------------------------------------------------------------- 1254 1102 ! 1255 ini = SIZE(ld isoce, dim = 1)1256 inj = SIZE(ld isoce, dim = 2)1103 ini = SIZE(ldIsOce, dim = 1) 1104 inj = SIZE(ldIsOce, dim = 2) 1257 1105 inij = SIZE(kipos) 1258 1106 ! … … 1264 1112 ii = 1 + MOD(iarea0,ini) 1265 1113 ij = 1 + iarea0/ini 1266 IF( ld isoce(ii,ij) ) THEN1114 IF( ldIsOce(ii,ij) ) THEN 1267 1115 icont = icont + 1 1268 1116 kproc(ii,ij) = icont … … 1272 1120 END DO 1273 1121 ! if needed add some land subdomains to reach inij active subdomains 1274 i2add = inij - COUNT( ld isoce )1122 i2add = inij - COUNT( ldIsOce ) 1275 1123 DO jarea = 1, ini*inj 1276 1124 iarea0 = jarea - 1 1277 1125 ii = 1 + MOD(iarea0,ini) 1278 1126 ij = 1 + iarea0/ini 1279 IF( .NOT. ld isoce(ii,ij) .AND. i2add > 0 ) THEN1127 IF( .NOT. ldIsOce(ii,ij) .AND. i2add > 0 ) THEN 1280 1128 icont = icont + 1 1281 1129 kproc(ii,ij) = icont … … 1287 1135 ! 1288 1136 END SUBROUTINE mpp_getnum 1137 1138 1139 SUBROUTINE init_excl_landpt 1140 !!---------------------------------------------------------------------- 1141 !! *** ROUTINE *** 1142 !! 1143 !! ** Purpose : exclude exchanges which contain only land points 1144 !! 1145 !! ** Method : if a send or receive buffer constains only land point we 1146 !! flag off the corresponding communication 1147 !! Warning: this selection depend on the halo size -> loop on halo size 1148 !! 1149 !!---------------------------------------------------------------------- 1150 INTEGER :: inumsave 1151 INTEGER :: jh 1152 INTEGER :: ipi, ipj 1153 INTEGER :: iiwe, iiea, iist, iisz 1154 INTEGER :: ijso, ijno, ijst, ijsz 1155 LOGICAL :: llsave 1156 REAL(wp), DIMENSION(:,:), ALLOCATABLE :: zmsk 1157 LOGICAL , DIMENSION(Ni_0,Nj_0,1) :: lloce 1158 !!---------------------------------------------------------------------- 1159 ! 1160 ! read the land-sea mask on the inner domain 1161 CALL read_mask( nimpp, njmpp, Ni_0, Nj_0, lloce(:,:,1) ) 1162 ! 1163 ! Here we look only at communications excluding the NP folding. 1164 ! As lbcnfd not validated if halo size /= nn_hls, we switch if off temporary... 1165 llsave = l_IdoNFold 1166 l_IdoNFold = .FALSE. 1167 ! 1168 DO jh = 1, n_hlsmax ! different halo size 1169 ! 1170 ipi = Ni_0 + 2*jh ! local domain size 1171 ipj = Nj_0 + 2*jh 1172 ! 1173 ALLOCATE( zmsk(ipi,ipj) ) 1174 zmsk(jh+1:jh+Ni_0,jh+1:jh+Nj_0) = REAL(COUNT(lloce, dim = 3), wp) ! define inner domain -> need REAL to use lbclnk 1175 CALL lbc_lnk('mppini', zmsk, 'T', 1._wp, khls = jh) ! fill halos 1176 ! 1177 iiwe = jh ; iiea = Ni_0 ! bottom-left corfer - 1 of the sent data 1178 ijso = jh ; ijno = Nj_0 1179 IF( nn_comm == 1 ) THEN 1180 iist = 0 ; iisz = ipi 1181 ijst = 0 ; ijsz = ipj 1182 ELSE 1183 iist = jh ; iisz = Ni_0 1184 ijst = jh ; ijsz = Nj_0 1185 ENDIF 1186 IF( nn_comm == 1 ) THEN ! SM: NOT WORKING FOR NEIGHBOURHOOD COLLECTIVE COMMUNICATIONS, I DON'T KNOW WHY... 1187 ! do not send if we send only land points 1188 IF( NINT(SUM( zmsk(iiwe+1:iiwe+jh ,ijst+1:ijst+ijsz) )) == 0 ) mpiSnei(jh,jpwe) = -1 1189 IF( NINT(SUM( zmsk(iiea+1:iiea+jh ,ijst+1:ijst+ijsz) )) == 0 ) mpiSnei(jh,jpea) = -1 1190 IF( NINT(SUM( zmsk(iist+1:iist+iisz,ijso+1:ijso+jh ) )) == 0 ) mpiSnei(jh,jpso) = -1 1191 IF( NINT(SUM( zmsk(iist+1:iist+iisz,ijno+1:ijno+jh ) )) == 0 ) mpiSnei(jh,jpno) = -1 1192 IF( NINT(SUM( zmsk(iiwe+1:iiwe+jh ,ijso+1:ijso+jh ) )) == 0 ) mpiSnei(jh,jpsw) = -1 1193 IF( NINT(SUM( zmsk(iiea+1:iiea+jh ,ijso+1:ijso+jh ) )) == 0 ) mpiSnei(jh,jpse) = -1 1194 IF( NINT(SUM( zmsk(iiwe+1:iiwe+jh ,ijno+1:ijno+jh ) )) == 0 ) mpiSnei(jh,jpnw) = -1 1195 IF( NINT(SUM( zmsk(iiea+1:iiea+jh ,ijno+1:ijno+jh ) )) == 0 ) mpiSnei(jh,jpne) = -1 1196 ! 1197 iiwe = iiwe-jh ; iiea = iiea+jh ! bottom-left corfer - 1 of the received data 1198 ijso = ijso-jh ; ijno = ijno+jh 1199 ! do not send if we send only land points 1200 IF( NINT(SUM( zmsk(iiwe+1:iiwe+jh ,ijst+1:ijst+ijsz) )) == 0 ) mpiRnei(jh,jpwe) = -1 1201 IF( NINT(SUM( zmsk(iiea+1:iiea+jh ,ijst+1:ijst+ijsz) )) == 0 ) mpiRnei(jh,jpea) = -1 1202 IF( NINT(SUM( zmsk(iist+1:iist+iisz,ijso+1:ijso+jh ) )) == 0 ) mpiRnei(jh,jpso) = -1 1203 IF( NINT(SUM( zmsk(iist+1:iist+iisz,ijno+1:ijno+jh ) )) == 0 ) mpiRnei(jh,jpno) = -1 1204 IF( NINT(SUM( zmsk(iiwe+1:iiwe+jh ,ijso+1:ijso+jh ) )) == 0 ) mpiRnei(jh,jpsw) = -1 1205 IF( NINT(SUM( zmsk(iiea+1:iiea+jh ,ijso+1:ijso+jh ) )) == 0 ) mpiRnei(jh,jpse) = -1 1206 IF( NINT(SUM( zmsk(iiwe+1:iiwe+jh ,ijno+1:ijno+jh ) )) == 0 ) mpiRnei(jh,jpnw) = -1 1207 IF( NINT(SUM( zmsk(iiea+1:iiea+jh ,ijno+1:ijno+jh ) )) == 0 ) mpiRnei(jh,jpne) = -1 1208 ENDIF 1209 ! 1210 ! Specific (and rare) problem in corner treatment because we do 1st West-East comm, next South-North comm 1211 IF( nn_comm == 1 ) THEN 1212 IF( mpiSnei(jh,jpwe) > -1 ) mpiSnei(jh, (/jpsw,jpnw/) ) = -1 ! SW and NW corners already sent through West nei 1213 IF( mpiSnei(jh,jpea) > -1 ) mpiSnei(jh, (/jpse,jpne/) ) = -1 ! SE and NE corners already sent through East nei 1214 IF( mpiRnei(jh,jpso) > -1 ) mpiRnei(jh, (/jpsw,jpse/) ) = -1 ! SW and SE corners will be received through South nei 1215 IF( mpiRnei(jh,jpno) > -1 ) mpiRnei(jh, (/jpnw,jpne/) ) = -1 ! NW and NE corners will be received through North nei 1216 ENDIF 1217 ! 1218 DEALLOCATE( zmsk ) 1219 ! 1220 CALL mpp_ini_nc(jh) ! Initialize/Update communicator for neighbourhood collective communications 1221 ! 1222 END DO 1223 l_IdoNFold = llsave 1224 1225 END SUBROUTINE init_excl_landpt 1289 1226 1290 1227 … … 1343 1280 !!---------------------------------------------------------------------- 1344 1281 ! 1345 !initializes the north-fold communication variables 1346 isendto(:) = 0 1347 nsndto = 0 1348 ! 1349 IF ( njmpp == MAXVAL( njmppt ) ) THEN ! if I am a process in the north 1282 !sxM is the first point (in the global domain) needed to compute the north-fold for the current process 1283 sxM = jpiglo - nimpp - jpi + 1 1284 !dxM is the last point (in the global domain) needed to compute the north-fold for the current process 1285 dxM = jpiglo - nimpp + 2 1286 ! 1287 ! loop over the other north-fold processes to find the processes 1288 ! managing the points belonging to the sxT-dxT range 1289 ! 1290 nsndto = 0 1291 DO jn = 1, jpni 1350 1292 ! 1351 !sxM is the first point (in the global domain) needed to compute the north-fold for the current process 1352 sxM = jpiglo - nimppt(narea) - jpiall(narea) + 1 1353 !dxM is the last point (in the global domain) needed to compute the north-fold for the current process 1354 dxM = jpiglo - nimppt(narea) + 2 1293 sxT = nfimpp(jn) ! sxT = 1st point (in the global domain) of the jn process 1294 dxT = nfimpp(jn) + nfjpi(jn) - 1 ! dxT = last point (in the global domain) of the jn process 1355 1295 ! 1356 ! loop over the other north-fold processes to find the processes 1357 ! managing the points belonging to the sxT-dxT range 1296 IF ( sxT < sxM .AND. sxM < dxT ) THEN 1297 nsndto = nsndto + 1 1298 isendto(nsndto) = jn 1299 ELSEIF( sxM <= sxT .AND. dxM >= dxT ) THEN 1300 nsndto = nsndto + 1 1301 isendto(nsndto) = jn 1302 ELSEIF( dxM < dxT .AND. sxT < dxM ) THEN 1303 nsndto = nsndto + 1 1304 isendto(nsndto) = jn 1305 ENDIF 1358 1306 ! 1359 DO jn = 1, jpni 1360 ! 1361 sxT = nfimpp(jn) ! sxT = 1st point (in the global domain) of the jn process 1362 dxT = nfimpp(jn) + nfjpi(jn) - 1 ! dxT = last point (in the global domain) of the jn process 1363 ! 1364 IF ( sxT < sxM .AND. sxM < dxT ) THEN 1365 nsndto = nsndto + 1 1366 isendto(nsndto) = jn 1367 ELSEIF( sxM <= sxT .AND. dxM >= dxT ) THEN 1368 nsndto = nsndto + 1 1369 isendto(nsndto) = jn 1370 ELSEIF( dxM < dxT .AND. sxT < dxM ) THEN 1371 nsndto = nsndto + 1 1372 isendto(nsndto) = jn 1373 ENDIF 1374 ! 1375 END DO 1376 ! 1377 ENDIF 1378 l_north_nogather = .TRUE. 1307 END DO 1379 1308 ! 1380 1309 END SUBROUTINE init_nfdcom … … 1389 1318 !!---------------------------------------------------------------------- 1390 1319 ! 1391 Nis0 = 1+nn_hls ; Nis1 = Nis0-1 ; Nis2 = MAX( 1, Nis0-2) 1392 Njs0 = 1+nn_hls ; Njs1 = Njs0-1 ; Njs2 = MAX( 1, Njs0-2) 1393 ! 1394 Nie0 = jpi-nn_hls ; Nie1 = Nie0+1 ; Nie2 = MIN(jpi, Nie0+2) 1395 Nje0 = jpj-nn_hls ; Nje1 = Nje0+1 ; Nje2 = MIN(jpj, Nje0+2) 1396 ! 1397 IF( nn_hls == 1 ) THEN !* halo size of 1 1398 ! 1399 Nis1nxt2 = Nis0 ; Njs1nxt2 = Njs0 1400 Nie1nxt2 = Nie0 ; Nje1nxt2 = Nje0 1401 ! 1402 ELSE !* larger halo size... 1403 ! 1404 Nis1nxt2 = Nis1 ; Njs1nxt2 = Njs1 1405 Nie1nxt2 = Nie1 ; Nje1nxt2 = Nje1 1406 ! 1407 ENDIF 1320 Nis0 = 1+nn_hls 1321 Njs0 = 1+nn_hls 1322 Nie0 = jpi-nn_hls 1323 Nje0 = jpj-nn_hls 1408 1324 ! 1409 1325 Ni_0 = Nie0 - Nis0 + 1 1410 1326 Nj_0 = Nje0 - Njs0 + 1 1411 Ni_1 = Nie1 - Nis1 + 1 1412 Nj_1 = Nje1 - Njs1 + 1 1413 Ni_2 = Nie2 - Nis2 + 1 1414 Nj_2 = Nje2 - Njs2 + 1 1327 ! 1328 ! old indices to be removed... 1329 jpim1 = jpi-1 ! inner domain indices 1330 jpjm1 = jpj-1 ! " " 1331 jpkm1 = jpk-1 ! " " 1415 1332 ! 1416 1333 END SUBROUTINE init_doloop
Note: See TracChangeset
for help on using the changeset viewer.
