- Timestamp:
- 2020-11-27T17:26:33+01:00 (3 years ago)
- Location:
- NEMO/branches/2020/tickets_icb_1900
- Files:
-
- 2 edited
Legend:
- Unmodified
- Added
- Removed
-
NEMO/branches/2020/tickets_icb_1900
- Property svn:externals
-
NEMO/branches/2020/tickets_icb_1900/src/OCE/LBC/mppini.F90
r13216 r13899 8 8 !! 8.0 ! 1998-05 (M. Imbard, J. Escobar, L. Colombet ) SHMEM and MPI versions 9 9 !! NEMO 1.0 ! 2004-01 (G. Madec, J.M Molines) F90 : free form , north fold jpni > 1 10 !! 3.4 ! 2011-10 (A. C. Coward, NOCS & J. Donners, PRACE) add mpp_init_nfdcom11 !! 3. ! 2013-06 (I. Epicoco, S. Mocavero, CMCC) mpp_init_nfdcom: setup avoiding MPI communication10 !! 3.4 ! 2011-10 (A. C. Coward, NOCS & J. Donners, PRACE) add init_nfdcom 11 !! 3. ! 2013-06 (I. Epicoco, S. Mocavero, CMCC) init_nfdcom: setup avoiding MPI communication 12 12 !! 4.0 ! 2016-06 (G. Madec) use domain configuration file instead of bathymetry file 13 13 !! 4.0 ! 2017-06 (J.M. Molines, T. Lovato) merge of mppini and mppini_2 … … 15 15 16 16 !!---------------------------------------------------------------------- 17 !! mpp_init : Lay out the global domain over processors with/without land processor elimination 18 !! mpp_init_mask : Read global bathymetric information to facilitate land suppression 19 !! mpp_init_ioipsl : IOIPSL initialization in mpp 20 !! mpp_init_partition: Calculate MPP domain decomposition 21 !! factorise : Calculate the factors of the no. of MPI processes 22 !! mpp_init_nfdcom : Setup for north fold exchanges with explicit point-to-point messaging 17 !! mpp_init : Lay out the global domain over processors with/without land processor elimination 18 !! init_ioipsl: IOIPSL initialization in mpp 19 !! init_nfdcom: Setup for north fold exchanges with explicit point-to-point messaging 20 !! init_doloop: set the starting/ending indices of DO-loop used in do_loop_substitute 23 21 !!---------------------------------------------------------------------- 24 22 USE dom_oce ! ocean space and time domain 25 23 USE bdy_oce ! open BounDarY 26 24 ! 27 USE lbcnfd , ONLY : isendto, nsndto , nfsloop, nfeloop! Setup of north fold exchanges25 USE lbcnfd , ONLY : isendto, nsndto ! Setup of north fold exchanges 28 26 USE lib_mpp ! distribued memory computing library 29 27 USE iom ! nemo I/O library … … 34 32 PRIVATE 35 33 36 PUBLIC mpp_init ! called by opa.F90 37 38 INTEGER :: numbot = -1 ! 'bottom_level' local logical unit 39 INTEGER :: numbdy = -1 ! 'bdy_msk' local logical unit 34 PUBLIC mpp_init ! called by nemogcm.F90 35 PUBLIC mpp_getnum ! called by prtctl 36 PUBLIC mpp_basesplit ! called by prtctl 37 PUBLIC mpp_is_ocean ! called by prtctl 38 39 INTEGER :: numbot = -1 ! 'bottom_level' local logical unit 40 INTEGER :: numbdy = -1 ! 'bdy_msk' local logical unit 40 41 41 42 !!---------------------------------------------------------------------- … … 61 62 !!---------------------------------------------------------------------- 62 63 ! 64 nn_hls = 1 65 jpiglo = Ni0glo + 2 * nn_hls 66 jpjglo = Nj0glo + 2 * nn_hls 63 67 jpimax = jpiglo 64 68 jpjmax = jpjglo … … 66 70 jpj = jpjglo 67 71 jpk = jpkglo 68 jpim1 = jpi-1 69 jpjm1 = jpj-1 70 jpkm1 = MAX( 1, jpk-1 ) 72 jpim1 = jpi-1 ! inner domain indices 73 jpjm1 = jpj-1 ! " " 74 jpkm1 = MAX( 1, jpk-1 ) ! " " 71 75 jpij = jpi*jpj 72 76 jpni = 1 73 77 jpnj = 1 74 78 jpnij = jpni*jpnj 75 nimpp = 1 !79 nimpp = 1 76 80 njmpp = 1 77 nlci = jpi78 nlcj = jpj79 nldi = 180 nldj = 181 nlei = jpi82 nlej = jpj83 81 nbondi = 2 84 82 nbondj = 2 … … 90 88 l_Jperio = jpnj == 1 .AND. (jperio == 2 .OR. jperio == 7) 91 89 ! 90 CALL init_doloop ! set start/end indices or do-loop depending on the halo width value (nn_hls) 91 ! 92 92 IF(lwp) THEN 93 93 WRITE(numout,*) … … 98 98 ENDIF 99 99 ! 100 IF( jpni /= 1 .OR. jpnj /= 1 .OR. jpnij /= 1 ) &101 CALL ctl_stop( 'mpp_init: equality jpni = jpnj = jpnij = 1 is not satisfied', &102 & 'the domain is lay out for distributed memory computing!' )103 !104 100 #if defined key_agrif 105 101 IF (.NOT.agrif_root()) THEN … … 135 131 !! njmpp : latitudinal index 136 132 !! narea : number for local area 137 !! nlci : first dimension138 !! nlcj : second dimension139 133 !! nbondi : mark for "east-west local boundary" 140 134 !! nbondj : mark for "north-south local boundary" … … 147 141 INTEGER :: ji, jj, jn, jproc, jarea ! dummy loop indices 148 142 INTEGER :: inijmin 149 INTEGER :: i2add150 143 INTEGER :: inum ! local logical unit 151 INTEGER :: idir, ifreq , icont! local integers144 INTEGER :: idir, ifreq ! local integers 152 145 INTEGER :: ii, il1, ili, imil ! - - 153 146 INTEGER :: ij, il2, ilj, ijm1 ! - - … … 162 155 INTEGER, ALLOCATABLE, DIMENSION(:) :: iin, ii_nono, ii_noea ! 1D workspace 163 156 INTEGER, ALLOCATABLE, DIMENSION(:) :: ijn, ii_noso, ii_nowe ! - - 164 INTEGER, ALLOCATABLE, DIMENSION(:,:) :: iimppt, i lci, ibondi, ipproc ! 2D workspace165 INTEGER, ALLOCATABLE, DIMENSION(:,:) :: ijmppt, i lcj, ibondj, ipolj ! - -166 INTEGER, ALLOCATABLE, DIMENSION(:,:) :: i lei, ildi, iono, ioea ! - -167 INTEGER, ALLOCATABLE, DIMENSION(:,:) :: i lej, ildj, ioso, iowe ! - -157 INTEGER, ALLOCATABLE, DIMENSION(:,:) :: iimppt, ijpi, ibondi, ipproc ! 2D workspace 158 INTEGER, ALLOCATABLE, DIMENSION(:,:) :: ijmppt, ijpj, ibondj, ipolj ! - - 159 INTEGER, ALLOCATABLE, DIMENSION(:,:) :: iie0, iis0, iono, ioea ! - - 160 INTEGER, ALLOCATABLE, DIMENSION(:,:) :: ije0, ijs0, ioso, iowe ! - - 168 161 LOGICAL, ALLOCATABLE, DIMENSION(:,:) :: llisoce ! - - 169 162 NAMELIST/nambdy/ ln_bdy, nb_bdy, ln_coords_file, cn_coords_file, & … … 173 166 & cn_ice, nn_ice_dta, & 174 167 & ln_vol, nn_volctl, nn_rimwidth 175 NAMELIST/nammpp/ jpni, jpnj, ln_nnogather, ln_listonly168 NAMELIST/nammpp/ jpni, jpnj, nn_hls, ln_nnogather, ln_listonly 176 169 !!---------------------------------------------------------------------- 177 170 ! … … 186 179 902 IF( ios > 0 ) CALL ctl_nam ( ios , 'nammpp in configuration namelist' ) 187 180 ! 181 nn_hls = MAX(1, nn_hls) ! nn_hls must be > 0 188 182 IF(lwp) THEN 189 183 WRITE(numout,*) ' Namelist nammpp' … … 195 189 ENDIF 196 190 WRITE(numout,*) ' avoid use of mpi_allgather at the north fold ln_nnogather = ', ln_nnogather 191 WRITE(numout,*) ' halo width (applies to both rows and columns) nn_hls = ', nn_hls 197 192 ENDIF 198 193 ! 199 194 IF(lwm) WRITE( numond, nammpp ) 200 195 ! 196 !!!------------------------------------ 197 !!! nn_hls shloud be read in nammpp 198 !!!------------------------------------ 199 jpiglo = Ni0glo + 2 * nn_hls 200 jpjglo = Nj0glo + 2 * nn_hls 201 ! 201 202 ! do we need to take into account bdy_msk? 202 203 READ ( numnam_ref, nambdy, IOSTAT = ios, ERR = 903) … … 208 209 IF( ln_bdy .AND. ln_mask_file ) CALL iom_open( cn_mask_file, numbdy ) 209 210 ! 210 IF( ln_listonly ) CALL mpp_init_bestpartition( MAX(mppsize,jpni*jpnj), ldlist = .TRUE. ) ! must be done by all core211 IF( ln_listonly ) CALL bestpartition( MAX(mppsize,jpni*jpnj), ldlist = .TRUE. ) ! must be done by all core 211 212 ! 212 213 ! 1. Dimension arrays for subdomains 213 214 ! ----------------------------------- 214 215 ! 215 ! If dimensions of processor grid weren't specified in the namelist file216 ! If dimensions of processors grid weren't specified in the namelist file 216 217 ! then we calculate them here now that we have our communicator size 217 218 IF(lwp) THEN … … 221 222 ENDIF 222 223 IF( jpni < 1 .OR. jpnj < 1 ) THEN 223 CALL mpp_init_bestpartition( mppsize, jpni, jpnj ) ! best mpi decomposition for mppsize mpi processes224 CALL bestpartition( mppsize, jpni, jpnj ) ! best mpi decomposition for mppsize mpi processes 224 225 llauto = .TRUE. 225 226 llbest = .TRUE. 226 227 ELSE 227 228 llauto = .FALSE. 228 CALL mpp_init_bestpartition( mppsize, inbi, inbj, icnt2 ) ! best mpi decomposition for mppsize mpi processes229 CALL bestpartition( mppsize, inbi, inbj, icnt2 ) ! best mpi decomposition for mppsize mpi processes 229 230 ! largest subdomain size for mpi decoposition jpni*jpnj given in the namelist 230 CALL mpp_bas ic_decomposition(jpni, jpnj, jpimax, jpjmax )231 ! largest subdomain size for mpi decoposition inbi*inbj given by mpp_init_bestpartition232 CALL mpp_bas ic_decomposition(inbi, inbj, iimax, ijmax )231 CALL mpp_basesplit( jpiglo, jpjglo, nn_hls, jpni, jpnj, jpimax, jpjmax ) 232 ! largest subdomain size for mpi decoposition inbi*inbj given by bestpartition 233 CALL mpp_basesplit( jpiglo, jpjglo, nn_hls, inbi, inbj, iimax, ijmax ) 233 234 icnt1 = jpni*jpnj - mppsize ! number of land subdomains that should be removed to use mppsize mpi processes 234 235 IF(lwp) THEN … … 261 262 ! look for land mpi subdomains... 262 263 ALLOCATE( llisoce(jpni,jpnj) ) 263 CALL mpp_i nit_isoce( jpni, jpnj,llisoce )264 CALL mpp_is_ocean( llisoce ) 264 265 inijmin = COUNT( llisoce ) ! number of oce subdomains 265 266 … … 270 271 WRITE(ctmp4,*) ' ==>>> There is the list of best domain decompositions you should use: ' 271 272 CALL ctl_stop( ctmp1, ctmp2, ctmp3, ' ', ctmp4, ' ' ) 272 CALL mpp_init_bestpartition( mppsize, ldlist = .TRUE. ) ! must be done by all core273 CALL bestpartition( mppsize, ldlist = .TRUE. ) ! must be done by all core 273 274 ENDIF 274 275 … … 294 295 WRITE(numout,*) 295 296 ENDIF 296 CALL mpp_init_bestpartition( mppsize, ldlist = .TRUE. ) ! must be done by all core297 CALL bestpartition( mppsize, ldlist = .TRUE. ) ! must be done by all core 297 298 ENDIF 298 299 … … 319 320 9003 FORMAT (a, i5) 320 321 321 IF( numbot /= -1 ) CALL iom_close( numbot ) 322 IF( numbdy /= -1 ) CALL iom_close( numbdy ) 323 324 ALLOCATE( nfiimpp(jpni,jpnj), nfipproc(jpni,jpnj), nfilcit(jpni,jpnj) , & 325 & nimppt(jpnij) , ibonit(jpnij) , nlcit(jpnij) , nlcjt(jpnij) , & 326 & njmppt(jpnij) , ibonjt(jpnij) , nldit(jpnij) , nldjt(jpnij) , & 327 & nleit(jpnij) , nlejt(jpnij) , & 322 ALLOCATE( nfimpp(jpni ) , nfproc(jpni ) , nfjpi(jpni ) , & 323 & nimppt(jpnij) , ibonit(jpnij) , jpiall(jpnij) , jpjall(jpnij) , & 324 & njmppt(jpnij) , ibonjt(jpnij) , nis0all(jpnij) , njs0all(jpnij) , & 325 & nie0all(jpnij) , nje0all(jpnij) , & 328 326 & iin(jpnij), ii_nono(jpnij), ii_noea(jpnij), & 329 327 & ijn(jpnij), ii_noso(jpnij), ii_nowe(jpnij), & 330 & iimppt(jpni,jpnj), i lci(jpni,jpnj), ibondi(jpni,jpnj), ipproc(jpni,jpnj), &331 & ijmppt(jpni,jpnj), i lcj(jpni,jpnj), ibondj(jpni,jpnj),ipolj(jpni,jpnj), &332 & ilei(jpni,jpnj), ildi(jpni,jpnj), iono(jpni,jpnj),ioea(jpni,jpnj), &333 & ilej(jpni,jpnj), ildj(jpni,jpnj), ioso(jpni,jpnj),iowe(jpni,jpnj), &328 & iimppt(jpni,jpnj), ijpi(jpni,jpnj), ibondi(jpni,jpnj), ipproc(jpni,jpnj), & 329 & ijmppt(jpni,jpnj), ijpj(jpni,jpnj), ibondj(jpni,jpnj), ipolj(jpni,jpnj), & 330 & iie0(jpni,jpnj), iis0(jpni,jpnj), iono(jpni,jpnj), ioea(jpni,jpnj), & 331 & ije0(jpni,jpnj), ijs0(jpni,jpnj), ioso(jpni,jpnj), iowe(jpni,jpnj), & 334 332 & STAT=ierr ) 335 333 CALL mpp_sum( 'mppini', ierr ) … … 345 343 ! ----------------------------------- 346 344 ! 347 nreci = 2 * nn_hls 348 nrecj = 2 * nn_hls 349 CALL mpp_basic_decomposition( jpni, jpnj, jpimax, jpjmax, iimppt, ijmppt, ilci, ilcj ) 350 nfiimpp(:,:) = iimppt(:,:) 351 nfilcit(:,:) = ilci(:,:) 345 CALL mpp_basesplit( jpiglo, jpjglo, nn_hls, jpni, jpnj, jpimax, jpjmax, iimppt, ijmppt, ijpi, ijpj ) 346 CALL mpp_getnum( llisoce, ipproc, iin, ijn ) 347 ! 348 !DO jn = 1, jpni 349 ! jproc = ipproc(jn,jpnj) 350 ! ii = iin(jproc+1) 351 ! ij = ijn(jproc+1) 352 ! nfproc(jn) = jproc 353 ! nfimpp(jn) = iimppt(ii,ij) 354 ! nfjpi (jn) = ijpi(ii,ij) 355 !END DO 356 nfproc(:) = ipproc(:,jpnj) 357 nfimpp(:) = iimppt(:,jpnj) 358 nfjpi (:) = ijpi(:,jpnj) 352 359 ! 353 360 IF(lwp) THEN … … 358 365 WRITE(numout,*) ' jpni = ', jpni 359 366 WRITE(numout,*) ' jpnj = ', jpnj 367 WRITE(numout,*) ' jpnij = ', jpnij 360 368 WRITE(numout,*) 361 WRITE(numout,*) ' sum i lci(i,1) = ', sum(ilci(:,1)), ' jpiglo = ', jpiglo362 WRITE(numout,*) ' sum i lcj(1,j) = ', sum(ilcj(1,:)), ' jpjglo = ', jpjglo369 WRITE(numout,*) ' sum ijpi(i,1) = ', sum(ijpi(:,1)), ' jpiglo = ', jpiglo 370 WRITE(numout,*) ' sum ijpj(1,j) = ', sum(ijpj(1,:)), ' jpjglo = ', jpjglo 363 371 ENDIF 364 372 … … 375 383 ii = 1 + MOD(iarea0,jpni) 376 384 ij = 1 + iarea0/jpni 377 ili = i lci(ii,ij)378 ilj = i lcj(ii,ij)385 ili = ijpi(ii,ij) 386 ilj = ijpj(ii,ij) 379 387 ibondi(ii,ij) = 0 ! default: has e-w neighbours 380 388 IF( ii == 1 ) ibondi(ii,ij) = -1 ! first column, has only e neighbour … … 391 399 ioea(ii,ij) = iarea0 + 1 392 400 iono(ii,ij) = iarea0 + jpni 393 i ldi(ii,ij) = 1 + nn_hls394 i lei(ii,ij) = ili - nn_hls395 i ldj(ii,ij) = 1 + nn_hls396 i lej(ii,ij) = ilj - nn_hls401 iis0(ii,ij) = 1 + nn_hls 402 iie0(ii,ij) = ili - nn_hls 403 ijs0(ii,ij) = 1 + nn_hls 404 ije0(ii,ij) = ilj - nn_hls 397 405 398 406 ! East-West periodicity: change ibondi, ioea, iowe … … 432 440 ! ---------------------------- 433 441 ! 434 ! specify which subdomains are oce subdomains; other are land subdomains435 ipproc(:,:) = -1436 icont = -1437 DO jarea = 1, jpni*jpnj438 iarea0 = jarea - 1439 ii = 1 + MOD(iarea0,jpni)440 ij = 1 + iarea0/jpni441 IF( llisoce(ii,ij) ) THEN442 icont = icont + 1443 ipproc(ii,ij) = icont444 iin(icont+1) = ii445 ijn(icont+1) = ij446 ENDIF447 END DO448 ! if needed add some land subdomains to reach jpnij active subdomains449 i2add = jpnij - inijmin450 DO jarea = 1, jpni*jpnj451 iarea0 = jarea - 1452 ii = 1 + MOD(iarea0,jpni)453 ij = 1 + iarea0/jpni454 IF( .NOT. llisoce(ii,ij) .AND. i2add > 0 ) THEN455 icont = icont + 1456 ipproc(ii,ij) = icont457 iin(icont+1) = ii458 ijn(icont+1) = ij459 i2add = i2add - 1460 ENDIF461 END DO462 nfipproc(:,:) = ipproc(:,:)463 464 442 ! neighbour treatment: change ibondi, ibondj if next to a land zone 465 443 DO jarea = 1, jpni*jpnj … … 500 478 ENDIF 501 479 END DO 502 503 ! Update il[de][ij] according to modified ibond[ij]504 ! ----------------------505 DO jproc = 1, jpnij506 ii = iin(jproc)507 ij = ijn(jproc)508 IF( ibondi(ii,ij) == -1 .OR. ibondi(ii,ij) == 2 ) ildi(ii,ij) = 1509 IF( ibondi(ii,ij) == 1 .OR. ibondi(ii,ij) == 2 ) ilei(ii,ij) = ilci(ii,ij)510 IF( ibondj(ii,ij) == -1 .OR. ibondj(ii,ij) == 2 ) ildj(ii,ij) = 1511 IF( ibondj(ii,ij) == 1 .OR. ibondj(ii,ij) == 2 ) ilej(ii,ij) = ilcj(ii,ij)512 END DO513 480 514 481 ! 5. Subdomain print … … 523 490 DO jj = jpnj, 1, -1 524 491 WRITE(numout,9403) (' ',ji=il1,il2-1) 525 WRITE(numout,9402) jj, (i lci(ji,jj),ilcj(ji,jj),ji=il1,il2)492 WRITE(numout,9402) jj, (ijpi(ji,jj),ijpj(ji,jj),ji=il1,il2) 526 493 WRITE(numout,9404) (ipproc(ji,jj),ji=il1,il2) 527 494 WRITE(numout,9403) (' ',ji=il1,il2-1) … … 580 547 noea = ii_noea(narea) 581 548 nono = ii_nono(narea) 582 nlci = ilci(ii,ij)583 nldi = ildi(ii,ij)584 nlei = ilei(ii,ij)585 nlcj = ilcj(ii,ij)586 nldj = ildj(ii,ij)587 nlej = ilej(ii,ij)549 jpi = ijpi(ii,ij) 550 !!$ Nis0 = iis0(ii,ij) 551 !!$ Nie0 = iie0(ii,ij) 552 jpj = ijpj(ii,ij) 553 !!$ Njs0 = ijs0(ii,ij) 554 !!$ Nje0 = ije0(ii,ij) 588 555 nbondi = ibondi(ii,ij) 589 556 nbondj = ibondj(ii,ij) 590 557 nimpp = iimppt(ii,ij) 591 558 njmpp = ijmppt(ii,ij) 592 jpi = nlci 593 jpj = nlcj 594 jpk = jpkglo ! third dim 595 #if defined key_agrif 596 ! simple trick to use same vertical grid as parent but different number of levels: 597 ! Save maximum number of levels in jpkglo, then define all vertical grids with this number. 598 ! Suppress once vertical online interpolation is ok 599 !!$ IF(.NOT.Agrif_Root()) jpkglo = Agrif_Parent( jpkglo ) 600 #endif 601 jpim1 = jpi-1 ! inner domain indices 602 jpjm1 = jpj-1 ! " " 603 jpkm1 = MAX( 1, jpk-1 ) ! " " 604 jpij = jpi*jpj ! jpi x j 559 jpk = jpkglo ! third dim 560 ! 561 CALL init_doloop ! set start/end indices of do-loop, depending on the halo width value (nn_hls) 562 ! 563 jpim1 = jpi-1 ! inner domain indices 564 jpjm1 = jpj-1 ! " " 565 jpkm1 = MAX( 1, jpk-1 ) ! " " 566 jpij = jpi*jpj ! jpi x j 605 567 DO jproc = 1, jpnij 606 568 ii = iin(jproc) 607 569 ij = ijn(jproc) 608 nlcit(jproc) = ilci(ii,ij)609 n ldit(jproc) = ildi(ii,ij)610 n leit(jproc) = ilei(ii,ij)611 nlcjt(jproc) = ilcj(ii,ij)612 n ldjt(jproc) = ildj(ii,ij)613 n lejt(jproc) = ilej(ii,ij)570 jpiall (jproc) = ijpi(ii,ij) 571 nis0all(jproc) = iis0(ii,ij) 572 nie0all(jproc) = iie0(ii,ij) 573 jpjall (jproc) = ijpj(ii,ij) 574 njs0all(jproc) = ijs0(ii,ij) 575 nje0all(jproc) = ije0(ii,ij) 614 576 ibonit(jproc) = ibondi(ii,ij) 615 577 ibonjt(jproc) = ibondj(ii,ij) … … 625 587 WRITE(inum,'(6i8,a,3i8,a)') jpnij,jpimax,jpjmax,jpk,jpiglo,jpjglo,& 626 588 & ' ( local: ',narea,jpi,jpj,' )' 627 WRITE(inum,'(a)') 'nproc nlci nlcj nldi nldj nlei nlejnimp njmp nono noso nowe noea nbondi nbondj '589 WRITE(inum,'(a)') 'nproc jpi jpj Nis0 Njs0 Nie0 Nje0 nimp njmp nono noso nowe noea nbondi nbondj ' 628 590 629 591 DO jproc = 1, jpnij 630 WRITE(inum,'(13i5,2i7)') jproc-1, nlcit (jproc), nlcjt(jproc), &631 & n ldit (jproc), nldjt(jproc), &632 & n leit (jproc), nlejt(jproc), &592 WRITE(inum,'(13i5,2i7)') jproc-1, jpiall(jproc), jpjall(jproc), & 593 & nis0all(jproc), njs0all(jproc), & 594 & nie0all(jproc), nje0all(jproc), & 633 595 & nimppt (jproc), njmppt (jproc), & 634 596 & ii_nono(jproc), ii_noso(jproc), & … … 664 626 WRITE(numout,*) ' l_Iperio = ', l_Iperio 665 627 WRITE(numout,*) ' l_Jperio = ', l_Jperio 666 WRITE(numout,*) ' nlci = ', nlci667 WRITE(numout,*) ' nlcj = ', nlcj668 628 WRITE(numout,*) ' nimpp = ', nimpp 669 629 WRITE(numout,*) ' njmpp = ', njmpp 670 WRITE(numout,*) ' nreci = ', nreci671 WRITE(numout,*) ' nrecj = ', nrecj672 WRITE(numout,*) ' nn_hls = ', nn_hls673 630 ENDIF 674 631 … … 692 649 ENDIF 693 650 ! 694 CALL mpp_init_ioipsl ! Prepare NetCDF output file (if necessary)651 CALL init_ioipsl ! Prepare NetCDF output file (if necessary) 695 652 ! 696 653 IF (( jperio >= 3 .AND. jperio <= 6 .AND. jpni > 1 ).AND.( ln_nnogather )) THEN 697 CALL mpp_init_nfdcom ! northfold neighbour lists654 CALL init_nfdcom ! northfold neighbour lists 698 655 IF (llwrtlay) THEN 699 656 WRITE(inum,*) 700 657 WRITE(inum,*) 701 658 WRITE(inum,*) 'north fold exchanges with explicit point-to-point messaging :' 702 WRITE(inum,*) 'nfsloop : ', nfsloop703 WRITE(inum,*) 'nfeloop : ', nfeloop704 659 WRITE(inum,*) 'nsndto : ', nsndto 705 660 WRITE(inum,*) 'isendto : ', isendto … … 711 666 DEALLOCATE(iin, ijn, ii_nono, ii_noea, ii_noso, ii_nowe, & 712 667 & iimppt, ijmppt, ibondi, ibondj, ipproc, ipolj, & 713 & i lci, ilcj, ilei, ilej, ildi, ildj, &668 & ijpi, ijpj, iie0, ije0, iis0, ijs0, & 714 669 & iono, ioea, ioso, iowe, llisoce) 715 670 ! 716 671 END SUBROUTINE mpp_init 717 672 718 719 SUBROUTINE mpp_basic_decomposition( knbi, knbj, kimax, kjmax, kimppt, kjmppt, klci, klcj) 720 !!---------------------------------------------------------------------- 721 !! *** ROUTINE mpp_basic_decomposition *** 673 #endif 674 675 SUBROUTINE mpp_basesplit( kiglo, kjglo, khls, knbi, knbj, kimax, kjmax, kimppt, kjmppt, klci, klcj) 676 !!---------------------------------------------------------------------- 677 !! *** ROUTINE mpp_basesplit *** 722 678 !! 723 679 !! ** Purpose : Lay out the global domain over processors. … … 731 687 !! klcj : second dimension 732 688 !!---------------------------------------------------------------------- 689 INTEGER, INTENT(in ) :: kiglo, kjglo 690 INTEGER, INTENT(in ) :: khls 733 691 INTEGER, INTENT(in ) :: knbi, knbj 734 692 INTEGER, INTENT( out) :: kimax, kjmax … … 737 695 ! 738 696 INTEGER :: ji, jj 697 INTEGER :: i2hls 739 698 INTEGER :: iresti, irestj, irm, ijpjmin 740 INTEGER :: ireci, irecj741 !!----------------------------------------------------------------------699 !!---------------------------------------------------------------------- 700 i2hls = 2*khls 742 701 ! 743 702 #if defined key_nemocice_decomp 744 kimax = ( nx_global+2- 2*nn_hls + (knbi-1) ) / knbi + 2*nn_hls ! first dim.745 kjmax = ( ny_global+2- 2*nn_hls + (knbj-1) ) / knbj + 2*nn_hls ! second dim.703 kimax = ( nx_global+2-i2hls + (knbi-1) ) / knbi + i2hls ! first dim. 704 kjmax = ( ny_global+2-i2hls + (knbj-1) ) / knbj + i2hls ! second dim. 746 705 #else 747 kimax = ( jpiglo - 2*nn_hls + (knbi-1) ) / knbi + 2*nn_hls ! first dim.748 kjmax = ( jpjglo - 2*nn_hls + (knbj-1) ) / knbj + 2*nn_hls ! second dim.706 kimax = ( kiglo - i2hls + (knbi-1) ) / knbi + i2hls ! first dim. 707 kjmax = ( kjglo - i2hls + (knbj-1) ) / knbj + i2hls ! second dim. 749 708 #endif 750 709 IF( .NOT. PRESENT(kimppt) ) RETURN … … 753 712 ! ----------------------------------- 754 713 ! Computation of local domain sizes klci() klcj() 755 ! These dimensions depend on global sizes knbi,knbj and jpiglo,jpjglo714 ! These dimensions depend on global sizes knbi,knbj and kiglo,kjglo 756 715 ! The subdomains are squares lesser than or equal to the global 757 716 ! dimensions divided by the number of processors minus the overlap array. 758 717 ! 759 ireci = 2 * nn_hls 760 irecj = 2 * nn_hls 761 iresti = 1 + MOD( jpiglo - ireci -1 , knbi ) 762 irestj = 1 + MOD( jpjglo - irecj -1 , knbj ) 718 iresti = 1 + MOD( kiglo - i2hls - 1 , knbi ) 719 irestj = 1 + MOD( kjglo - i2hls - 1 , knbj ) 763 720 ! 764 721 ! Need to use kimax and kjmax here since jpi and jpj not yet defined 765 722 #if defined key_nemocice_decomp 766 723 ! Change padding to be consistent with CICE 767 klci(1:knbi-1 ,:) = kimax768 klci( knbi ,:) = jpiglo - (knbi - 1) * (kimax - nreci)769 klcj(: ,1:knbj-1) = kjmax770 klcj(: , knbj) = jpjglo - (knbj - 1) * (kjmax - nrecj)724 klci(1:knbi-1,: ) = kimax 725 klci( knbi ,: ) = kiglo - (knbi - 1) * (kimax - i2hls) 726 klcj(: ,1:knbj-1) = kjmax 727 klcj(: , knbj ) = kjglo - (knbj - 1) * (kjmax - i2hls) 771 728 #else 772 729 klci(1:iresti ,:) = kimax 773 730 klci(iresti+1:knbi ,:) = kimax-1 774 IF( MINVAL(klci) < 3) THEN775 WRITE(ctmp1,*) ' mpp_bas ic_decomposition: minimum value of jpi must be >= 3'731 IF( MINVAL(klci) < 2*i2hls ) THEN 732 WRITE(ctmp1,*) ' mpp_basesplit: minimum value of jpi must be >= ', 2*i2hls 776 733 WRITE(ctmp2,*) ' We have ', MINVAL(klci) 777 734 CALL ctl_stop( 'STOP', ctmp1, ctmp2 ) … … 779 736 IF( jperio == 3 .OR. jperio == 4 .OR. jperio == 5 .OR. jperio == 6 ) THEN 780 737 ! minimize the size of the last row to compensate for the north pole folding coast 781 IF( jperio == 3 .OR. jperio == 4 ) ijpjmin = 5 ! V and F folding involves line jpj-3 that must not be south boundary 782 IF( jperio == 5 .OR. jperio == 6 ) ijpjmin = 4 ! V and F folding involves line jpj-2 that must not be south boundary 783 irm = knbj - irestj ! total number of lines to be removed 784 klcj(:, knbj) = MAX( ijpjmin, kjmax-irm ) ! we must have jpj >= ijpjmin in the last row 785 irm = irm - ( kjmax - klcj(1,knbj) ) ! remaining number of lines to remove 786 irestj = knbj - 1 - irm 787 klcj(:, 1:irestj) = kjmax 738 IF( jperio == 3 .OR. jperio == 4 ) ijpjmin = 2+3*khls ! V and F folding must be outside of southern halos 739 IF( jperio == 5 .OR. jperio == 6 ) ijpjmin = 1+3*khls ! V and F folding must be outside of southern halos 740 irm = knbj - irestj ! total number of lines to be removed 741 klcj(:,knbj) = MAX( ijpjmin, kjmax-irm ) ! we must have jpj >= ijpjmin in the last row 742 irm = irm - ( kjmax - klcj(1,knbj) ) ! remaining number of lines to remove 743 irestj = knbj - 1 - irm 788 744 klcj(:, irestj+1:knbj-1) = kjmax-1 789 745 ELSE 790 ijpjmin = 3 791 klcj(:, 1:irestj) = kjmax 792 klcj(:, irestj+1:knbj) = kjmax-1 793 ENDIF 794 IF( MINVAL(klcj) < ijpjmin ) THEN 795 WRITE(ctmp1,*) ' mpp_basic_decomposition: minimum value of jpj must be >= ', ijpjmin 746 klcj(:, irestj+1:knbj ) = kjmax-1 747 ENDIF 748 klcj(:,1:irestj) = kjmax 749 IF( MINVAL(klcj) < 2*i2hls ) THEN 750 WRITE(ctmp1,*) ' mpp_basesplit: minimum value of jpj must be >= ', 2*i2hls 796 751 WRITE(ctmp2,*) ' We have ', MINVAL(klcj) 797 752 CALL ctl_stop( 'STOP', ctmp1, ctmp2 ) … … 807 762 DO jj = 1, knbj 808 763 DO ji = 2, knbi 809 kimppt(ji,jj) = kimppt(ji-1,jj) + klci(ji-1,jj) - i reci764 kimppt(ji,jj) = kimppt(ji-1,jj) + klci(ji-1,jj) - i2hls 810 765 END DO 811 766 END DO … … 815 770 DO jj = 2, knbj 816 771 DO ji = 1, knbi 817 kjmppt(ji,jj) = kjmppt(ji,jj-1) + klcj(ji,jj-1) - i recj772 kjmppt(ji,jj) = kjmppt(ji,jj-1) + klcj(ji,jj-1) - i2hls 818 773 END DO 819 774 END DO 820 775 ENDIF 821 776 822 END SUBROUTINE mpp_bas ic_decomposition823 824 825 SUBROUTINE mpp_init_bestpartition( knbij, knbi, knbj, knbcnt, ldlist )826 !!---------------------------------------------------------------------- 827 !! *** ROUTINE mpp_init_bestpartition ***777 END SUBROUTINE mpp_basesplit 778 779 780 SUBROUTINE bestpartition( knbij, knbi, knbj, knbcnt, ldlist ) 781 !!---------------------------------------------------------------------- 782 !! *** ROUTINE bestpartition *** 828 783 !! 829 784 !! ** Purpose : … … 831 786 !! ** Method : 832 787 !!---------------------------------------------------------------------- 833 INTEGER, INTENT(in ) :: knbij ! total number if subdomains(knbi*knbj)788 INTEGER, INTENT(in ) :: knbij ! total number of subdomains (knbi*knbj) 834 789 INTEGER, OPTIONAL, INTENT( out) :: knbi, knbj ! number if subdomains along i and j (knbi and knbj) 835 790 INTEGER, OPTIONAL, INTENT( out) :: knbcnt ! number of land subdomains … … 839 794 INTEGER :: iszitst, iszjtst 840 795 INTEGER :: isziref, iszjref 796 INTEGER :: iszimin, iszjmin 841 797 INTEGER :: inbij, iszij 842 798 INTEGER :: inbimax, inbjmax, inbijmax, inbijold … … 867 823 inbimax = 0 868 824 inbjmax = 0 869 isziref = jpiglo*jpjglo+1 825 isziref = jpiglo*jpjglo+1 ! define a value that is larger than the largest possible 870 826 iszjref = jpiglo*jpjglo+1 827 ! 828 iszimin = 4*nn_hls ! minimum size of the MPI subdomain so halos are always adressing neighbor inner domain 829 iszjmin = 4*nn_hls 830 IF( jperio == 3 .OR. jperio == 4 ) iszjmin = MAX(iszjmin, 2+3*nn_hls) ! V and F folding must be outside of southern halos 831 IF( jperio == 5 .OR. jperio == 6 ) iszjmin = MAX(iszjmin, 1+3*nn_hls) ! V and F folding must be outside of southern halos 871 832 ! 872 833 ! get the list of knbi that gives a smaller jpimax than knbi-1 … … 876 837 iszitst = ( nx_global+2-2*nn_hls + (ji-1) ) / ji + 2*nn_hls ! first dim. 877 838 #else 878 iszitst = ( jpiglo - 2*nn_hls + (ji-1) ) / ji + 2*nn_hls839 iszitst = ( Ni0glo + (ji-1) ) / ji + 2*nn_hls ! max subdomain i-size 879 840 #endif 880 IF( iszitst < isziref ) THEN841 IF( iszitst < isziref .AND. iszitst >= iszimin ) THEN 881 842 isziref = iszitst 882 843 inbimax = inbimax + 1 … … 887 848 iszjtst = ( ny_global+2-2*nn_hls + (ji-1) ) / ji + 2*nn_hls ! first dim. 888 849 #else 889 iszjtst = ( jpjglo - 2*nn_hls + (ji-1) ) / ji + 2*nn_hls850 iszjtst = ( Nj0glo + (ji-1) ) / ji + 2*nn_hls ! max subdomain j-size 890 851 #endif 891 IF( iszjtst < iszjref ) THEN852 IF( iszjtst < iszjref .AND. iszjtst >= iszjmin ) THEN 892 853 iszjref = iszjtst 893 854 inbjmax = inbjmax + 1 … … 927 888 iszij1(:) = iszi1(:) * iszj1(:) 928 889 929 ! if ther ris no land and no print890 ! if there is no land and no print 930 891 IF( .NOT. llist .AND. numbot == -1 .AND. numbdy == -1 ) THEN 931 892 ! get the smaller partition which gives the smallest subdomain size … … 946 907 ii = MINLOC(iszij1, mask = inbij1 == inbij, dim = 1) ! warning: send back the first occurence if multiple results 947 908 IF ( iszij1(ii) < iszij ) THEN 909 ii = MINLOC( iszi1+iszj1, mask = iszij1 == iszij1(ii) .AND. inbij1 == inbij, dim = 1) ! select the smaller perimeter if multiple min 948 910 isz0 = isz0 + 1 949 911 indexok(isz0) = ii … … 975 937 ji = isz0 ! initialization with the largest value 976 938 ALLOCATE( llisoce(inbi0(ji), inbj0(ji)) ) 977 CALL mpp_i nit_isoce( inbi0(ji), inbj0(ji), llisoce )! Warning: must be call by all cores (call mpp_sum)939 CALL mpp_is_ocean( llisoce ) ! Warning: must be call by all cores (call mpp_sum) 978 940 inbijold = COUNT(llisoce) 979 941 DEALLOCATE( llisoce ) 980 942 DO ji =isz0-1,1,-1 981 943 ALLOCATE( llisoce(inbi0(ji), inbj0(ji)) ) 982 CALL mpp_i nit_isoce( inbi0(ji), inbj0(ji), llisoce )! Warning: must be call by all cores (call mpp_sum)944 CALL mpp_is_ocean( llisoce ) ! Warning: must be call by all cores (call mpp_sum) 983 945 inbij = COUNT(llisoce) 984 946 DEALLOCATE( llisoce ) … … 1006 968 ii = ii -1 1007 969 ALLOCATE( llisoce(inbi0(ii), inbj0(ii)) ) 1008 CALL mpp_i nit_isoce( inbi0(ii), inbj0(ii),llisoce ) ! must be done by all core970 CALL mpp_is_ocean( llisoce ) ! must be done by all core 1009 971 inbij = COUNT(llisoce) 1010 972 DEALLOCATE( llisoce ) … … 1015 977 DEALLOCATE( inbi0, inbj0 ) 1016 978 ! 1017 END SUBROUTINE mpp_init_bestpartition979 END SUBROUTINE bestpartition 1018 980 1019 981 … … 1024 986 !! ** Purpose : the the proportion of land points in the surface land-sea mask 1025 987 !! 1026 !! ** Method : read iproc strips (of length jpiglo) of the land-sea mask988 !! ** Method : read iproc strips (of length Ni0glo) of the land-sea mask 1027 989 !!---------------------------------------------------------------------- 1028 990 REAL(wp), INTENT( out) :: propland ! proportion of land points in the global domain (between 0 and 1) … … 1041 1003 1042 1004 ! number of processes reading the bathymetry file 1043 iproc = MINVAL( (/mppsize, jpjglo/2, 100/) ) ! read a least 2 lines, no more that 100 processes reading at the same time1005 iproc = MINVAL( (/mppsize, Nj0glo/2, 100/) ) ! read a least 2 lines, no more that 100 processes reading at the same time 1044 1006 1045 1007 ! we want to read iproc strips of the land-sea mask. -> pick up iproc processes every idiv processes starting at 1 … … 1051 1013 IF( MOD( narea-1, idiv ) == 0 .AND. iarea < iproc ) THEN ! beware idiv can be = to 1 1052 1014 ! 1053 ijsz = jpjglo / iproc ! width of the stripe to read1054 IF( iarea < MOD( jpjglo,iproc) ) ijsz = ijsz + 11055 ijstr = iarea*( jpjglo/iproc) + MIN(iarea, MOD(jpjglo,iproc)) + 1 ! starting j position of the reading1015 ijsz = Nj0glo / iproc ! width of the stripe to read 1016 IF( iarea < MOD(Nj0glo,iproc) ) ijsz = ijsz + 1 1017 ijstr = iarea*(Nj0glo/iproc) + MIN(iarea, MOD(Nj0glo,iproc)) + 1 ! starting j position of the reading 1056 1018 ! 1057 ALLOCATE( lloce( jpiglo, ijsz) ) ! allocate the strip1058 CALL mpp_init_readbot_strip( ijstr, ijsz, lloce )1019 ALLOCATE( lloce(Ni0glo, ijsz) ) ! allocate the strip 1020 CALL readbot_strip( ijstr, ijsz, lloce ) 1059 1021 inboce = COUNT(lloce) ! number of ocean point in the stripe 1060 1022 DEALLOCATE(lloce) … … 1065 1027 CALL mpp_sum( 'mppini', inboce ) ! total number of ocean points over the global domain 1066 1028 ! 1067 propland = REAL( jpiglo*jpjglo - inboce, wp ) / REAL( jpiglo*jpjglo, wp )1029 propland = REAL( Ni0glo*Nj0glo - inboce, wp ) / REAL( Ni0glo*Nj0glo, wp ) 1068 1030 ! 1069 1031 END SUBROUTINE mpp_init_landprop 1070 1032 1071 1033 1072 SUBROUTINE mpp_init_isoce( knbi, knbj, ldisoce ) 1073 !!---------------------------------------------------------------------- 1074 !! *** ROUTINE mpp_init_nboce *** 1075 !! 1076 !! ** Purpose : check for a mpi domain decomposition knbi x knbj which 1077 !! subdomains contain at least 1 ocean point 1078 !! 1079 !! ** Method : read knbj strips (of length jpiglo) of the land-sea mask 1080 !!---------------------------------------------------------------------- 1081 INTEGER, INTENT(in ) :: knbi, knbj ! domain decomposition 1082 LOGICAL, DIMENSION(knbi,knbj), INTENT( out) :: ldisoce ! .true. if a sub domain constains 1 ocean point 1083 ! 1084 INTEGER, DIMENSION(knbi,knbj) :: inboce ! number oce oce pint in each mpi subdomain 1085 INTEGER, DIMENSION(knbi*knbj) :: inboce_1d 1034 SUBROUTINE mpp_is_ocean( ldisoce ) 1035 !!---------------------------------------------------------------------- 1036 !! *** ROUTINE mpp_is_ocean *** 1037 !! 1038 !! ** Purpose : Check for a mpi domain decomposition inbi x inbj which 1039 !! subdomains, including 1 halo (even if nn_hls>1), contain 1040 !! at least 1 ocean point. 1041 !! We must indeed ensure that each subdomain that is a neighbour 1042 !! of a land subdomain as only land points on its boundary 1043 !! (inside the inner subdomain) with the land subdomain. 1044 !! This is needed to get the proper bondary conditions on 1045 !! a subdomain with a closed boundary. 1046 !! 1047 !! ** Method : read inbj strips (of length Ni0glo) of the land-sea mask 1048 !!---------------------------------------------------------------------- 1049 LOGICAL, DIMENSION(:,:), INTENT( out) :: ldisoce ! .true. if a sub domain constains 1 ocean point 1050 ! 1086 1051 INTEGER :: idiv, iimax, ijmax, iarea 1052 INTEGER :: inbi, inbj, inx, iny, inry, isty 1087 1053 INTEGER :: ji, jn 1088 LOGICAL, ALLOCATABLE, DIMENSION(:,:) :: lloce ! lloce(i,j) = .true. if the point (i,j) is ocean 1089 INTEGER, ALLOCATABLE, DIMENSION(:,:) :: iimppt, ilci 1090 INTEGER, ALLOCATABLE, DIMENSION(:,:) :: ijmppt, ilcj 1054 INTEGER, ALLOCATABLE, DIMENSION(:,:) :: inboce ! number oce oce pint in each mpi subdomain 1055 INTEGER, ALLOCATABLE, DIMENSION(: ) :: inboce_1d 1056 INTEGER, ALLOCATABLE, DIMENSION(:,:) :: iimppt, ijpi 1057 INTEGER, ALLOCATABLE, DIMENSION(:,:) :: ijmppt, ijpj 1058 LOGICAL, ALLOCATABLE, DIMENSION(:,:) :: lloce ! lloce(i,j) = .true. if the point (i,j) is ocean 1091 1059 !!---------------------------------------------------------------------- 1092 1060 ! do nothing if there is no land-sea mask … … 1095 1063 RETURN 1096 1064 ENDIF 1097 1098 ! we want to read knbj strips of the land-sea mask. -> pick up knbj processes every idiv processes starting at 1 1099 IF ( knbj == 1 ) THEN ; idiv = mppsize 1100 ELSE IF ( mppsize < knbj ) THEN ; idiv = 1 1101 ELSE ; idiv = ( mppsize - 1 ) / ( knbj - 1 ) 1102 ENDIF 1065 ! 1066 inbi = SIZE( ldisoce, dim = 1 ) 1067 inbj = SIZE( ldisoce, dim = 2 ) 1068 ! 1069 ! we want to read inbj strips of the land-sea mask. -> pick up inbj processes every idiv processes starting at 1 1070 IF ( inbj == 1 ) THEN ; idiv = mppsize 1071 ELSE IF ( mppsize < inbj ) THEN ; idiv = 1 1072 ELSE ; idiv = ( mppsize - 1 ) / ( inbj - 1 ) 1073 ENDIF 1074 ! 1075 ALLOCATE( inboce(inbi,inbj), inboce_1d(inbi*inbj) ) 1103 1076 inboce(:,:) = 0 ! default no ocean point found 1104 1105 DO jn = 0, ( knbj-1)/mppsize ! if mppsize < knbj : more strips than mpi processes (because of potential land domains)1077 ! 1078 DO jn = 0, (inbj-1)/mppsize ! if mppsize < inbj : more strips than mpi processes (because of potential land domains) 1106 1079 ! 1107 iarea = (narea-1)/idiv + jn * mppsize ! involed process number (starting counting at 0)1108 IF( MOD( narea-1, idiv ) == 0 .AND. iarea < knbj ) THEN! beware idiv can be = to 11080 iarea = (narea-1)/idiv + jn * mppsize + 1 ! involed process number (starting counting at 1) 1081 IF( MOD( narea-1, idiv ) == 0 .AND. iarea <= inbj ) THEN ! beware idiv can be = to 1 1109 1082 ! 1110 ALLOCATE( iimppt( knbi,knbj), ijmppt(knbi,knbj), ilci(knbi,knbj), ilcj(knbi,knbj) )1111 CALL mpp_bas ic_decomposition( knbi, knbj, iimax, ijmax, iimppt, ijmppt, ilci, ilcj )1083 ALLOCATE( iimppt(inbi,inbj), ijmppt(inbi,inbj), ijpi(inbi,inbj), ijpj(inbi,inbj) ) 1084 CALL mpp_basesplit( Ni0glo, Nj0glo, 0, inbi, inbj, iimax, ijmax, iimppt, ijmppt, ijpi, ijpj ) 1112 1085 ! 1113 ALLOCATE( lloce(jpiglo, ilcj(1,iarea+1)) ) ! allocate the strip 1114 CALL mpp_init_readbot_strip( ijmppt(1,iarea+1), ilcj(1,iarea+1), lloce ) ! read the strip 1115 DO ji = 1, knbi 1116 inboce(ji,iarea+1) = COUNT( lloce(iimppt(ji,1):iimppt(ji,1)+ilci(ji,1)-1,:) ) ! number of ocean point in subdomain 1086 inx = Ni0glo + 2 ; iny = ijpj(1,iarea) + 2 ! strip size + 1 halo on each direction (even if nn_hls>1) 1087 ALLOCATE( lloce(inx, iny) ) ! allocate the strip 1088 inry = iny - COUNT( (/ iarea == 1, iarea == inbj /) ) ! number of point to read in y-direction 1089 isty = 1 + COUNT( (/ iarea == 1 /) ) ! read from the first or the second line? 1090 CALL readbot_strip( ijmppt(1,iarea) - 2 + isty, inry, lloce(2:inx-1, isty:inry+isty-1) ) ! read the strip 1091 ! 1092 IF( iarea == 1 ) THEN ! the first line was not read 1093 IF( jperio == 2 .OR. jperio == 7 ) THEN ! north-south periodocity 1094 CALL readbot_strip( Nj0glo, 1, lloce(2:inx-1, 1) ) ! read the last line -> first line of lloce 1095 ELSE 1096 lloce(2:inx-1, 1) = .FALSE. ! closed boundary 1097 ENDIF 1098 ENDIF 1099 IF( iarea == inbj ) THEN ! the last line was not read 1100 IF( jperio == 2 .OR. jperio == 7 ) THEN ! north-south periodocity 1101 CALL readbot_strip( 1, 1, lloce(2:inx-1,iny) ) ! read the first line -> last line of lloce 1102 ELSEIF( jperio == 3 .OR. jperio == 4 ) THEN ! north-pole folding T-pivot, T-point 1103 lloce(2,iny) = lloce(2,iny-2) ! here we have 1 halo (even if nn_hls>1) 1104 DO ji = 3,inx-1 1105 lloce(ji,iny ) = lloce(inx-ji+2,iny-2) ! ok, we have at least 3 lines 1106 END DO 1107 DO ji = inx/2+2,inx-1 1108 lloce(ji,iny-1) = lloce(inx-ji+2,iny-1) 1109 END DO 1110 ELSEIF( jperio == 5 .OR. jperio == 6 ) THEN ! north-pole folding F-pivot, T-point, 1 halo 1111 lloce(inx/2+1,iny-1) = lloce(inx/2,iny-1) ! here we have 1 halo (even if nn_hls>1) 1112 lloce(inx -1,iny-1) = lloce(2 ,iny-1) 1113 DO ji = 2,inx-1 1114 lloce(ji,iny) = lloce(inx-ji+1,iny-1) 1115 END DO 1116 ELSE ! closed boundary 1117 lloce(2:inx-1,iny) = .FALSE. 1118 ENDIF 1119 ENDIF 1120 ! ! first and last column were not read 1121 IF( jperio == 1 .OR. jperio == 4 .OR. jperio == 6 .OR. jperio == 7 ) THEN 1122 lloce(1,:) = lloce(inx-1,:) ; lloce(inx,:) = lloce(2,:) ! east-west periodocity 1123 ELSE 1124 lloce(1,:) = .FALSE. ; lloce(inx,:) = .FALSE. ! closed boundary 1125 ENDIF 1126 ! 1127 DO ji = 1, inbi 1128 inboce(ji,iarea) = COUNT( lloce(iimppt(ji,1):iimppt(ji,1)+ijpi(ji,1)+1,:) ) ! lloce as 2 points more than Ni0glo 1117 1129 END DO 1118 1130 ! 1119 1131 DEALLOCATE(lloce) 1120 DEALLOCATE(iimppt, ijmppt, i lci, ilcj)1132 DEALLOCATE(iimppt, ijmppt, ijpi, ijpj) 1121 1133 ! 1122 1134 ENDIF 1123 1135 END DO 1124 1136 1125 inboce_1d = RESHAPE(inboce, (/ knbi*knbj /))1137 inboce_1d = RESHAPE(inboce, (/ inbi*inbj /)) 1126 1138 CALL mpp_sum( 'mppini', inboce_1d ) 1127 inboce = RESHAPE(inboce_1d, (/ knbi, knbj/))1139 inboce = RESHAPE(inboce_1d, (/inbi, inbj/)) 1128 1140 ldisoce(:,:) = inboce(:,:) /= 0 1129 ! 1130 END SUBROUTINE mpp_init_isoce 1141 DEALLOCATE(inboce, inboce_1d) 1142 ! 1143 END SUBROUTINE mpp_is_ocean 1131 1144 1132 1145 1133 SUBROUTINE mpp_init_readbot_strip( kjstr, kjcnt, ldoce )1134 !!---------------------------------------------------------------------- 1135 !! *** ROUTINE mpp_init_readbot_strip ***1146 SUBROUTINE readbot_strip( kjstr, kjcnt, ldoce ) 1147 !!---------------------------------------------------------------------- 1148 !! *** ROUTINE readbot_strip *** 1136 1149 !! 1137 1150 !! ** Purpose : Read relevant bathymetric information in order to … … 1139 1152 !! of land domains, in an mpp computation. 1140 1153 !! 1141 !! ** Method : read stipe of size ( jpiglo,...)1142 !!---------------------------------------------------------------------- 1143 INTEGER , INTENT(in ) :: kjstr ! starting j position of the reading1144 INTEGER , INTENT(in ) :: kjcnt ! number of lines to read1145 LOGICAL, DIMENSION( jpiglo,kjcnt), INTENT( out) ::ldoce ! ldoce(i,j) = .true. if the point (i,j) is ocean1154 !! ** Method : read stipe of size (Ni0glo,...) 1155 !!---------------------------------------------------------------------- 1156 INTEGER , INTENT(in ) :: kjstr ! starting j position of the reading 1157 INTEGER , INTENT(in ) :: kjcnt ! number of lines to read 1158 LOGICAL, DIMENSION(Ni0glo,kjcnt), INTENT( out) :: ldoce ! ldoce(i,j) = .true. if the point (i,j) is ocean 1146 1159 ! 1147 1160 INTEGER :: inumsave ! local logical unit 1148 REAL(wp), DIMENSION( jpiglo,kjcnt) :: zbot, zbdy1161 REAL(wp), DIMENSION(Ni0glo,kjcnt) :: zbot, zbdy 1149 1162 !!---------------------------------------------------------------------- 1150 1163 ! 1151 1164 inumsave = numout ; numout = numnul ! redirect all print to /dev/null 1152 1165 ! 1153 IF( numbot /= -1 ) THEN 1154 CALL iom_get( numbot, jpdom_unknown, 'bottom_level', zbot, kstart = (/1,kjstr/), kcount = (/ jpiglo, kjcnt/) )1166 IF( numbot /= -1 ) THEN 1167 CALL iom_get( numbot, jpdom_unknown, 'bottom_level', zbot, kstart = (/1,kjstr/), kcount = (/Ni0glo, kjcnt/) ) 1155 1168 ELSE 1156 zbot(:,:) = 1. 1157 ENDIF 1158 1159 IF( numbdy /= -1 ) THEN! Adjust with bdy_msk if it exists1160 CALL iom_get ( numbdy, jpdom_unknown, 'bdy_msk', zbdy, kstart = (/1,kjstr/), kcount = (/jpiglo, kjcnt/) )1169 zbot(:,:) = 1._wp ! put a non-null value 1170 ENDIF 1171 ! 1172 IF( numbdy /= -1 ) THEN ! Adjust with bdy_msk if it exists 1173 CALL iom_get ( numbdy, jpdom_unknown, 'bdy_msk', zbdy, kstart = (/1,kjstr/), kcount = (/Ni0glo, kjcnt/) ) 1161 1174 zbot(:,:) = zbot(:,:) * zbdy(:,:) 1162 1175 ENDIF 1163 1176 ! 1164 ldoce(:,:) = zbot(:,:) > 0. 1177 ldoce(:,:) = zbot(:,:) > 0._wp 1165 1178 numout = inumsave 1166 1179 ! 1167 END SUBROUTINE mpp_init_readbot_strip 1168 1169 1170 SUBROUTINE mpp_init_ioipsl 1171 !!---------------------------------------------------------------------- 1172 !! *** ROUTINE mpp_init_ioipsl *** 1180 END SUBROUTINE readbot_strip 1181 1182 1183 SUBROUTINE mpp_getnum( ldisoce, kproc, kipos, kjpos ) 1184 !!---------------------------------------------------------------------- 1185 !! *** ROUTINE mpp_getnum *** 1186 !! 1187 !! ** Purpose : give a number to each MPI subdomains (starting at 0) 1188 !! 1189 !! ** Method : start from bottom left. First skip land subdomain, and finally use them if needed 1190 !!---------------------------------------------------------------------- 1191 LOGICAL, DIMENSION(:,:), INTENT(in ) :: ldisoce ! F if land process 1192 INTEGER, DIMENSION(:,:), INTENT( out) :: kproc ! subdomain number (-1 if supressed, starting at 0) 1193 INTEGER, DIMENSION( :), INTENT( out) :: kipos ! i-position of the subdomain (from 1 to jpni) 1194 INTEGER, DIMENSION( :), INTENT( out) :: kjpos ! j-position of the subdomain (from 1 to jpnj) 1195 ! 1196 INTEGER :: ii, ij, jarea, iarea0 1197 INTEGER :: icont, i2add , ini, inj, inij 1198 !!---------------------------------------------------------------------- 1199 ! 1200 ini = SIZE(ldisoce, dim = 1) 1201 inj = SIZE(ldisoce, dim = 2) 1202 inij = SIZE(kipos) 1203 ! 1204 ! specify which subdomains are oce subdomains; other are land subdomains 1205 kproc(:,:) = -1 1206 icont = -1 1207 DO jarea = 1, ini*inj 1208 iarea0 = jarea - 1 1209 ii = 1 + MOD(iarea0,ini) 1210 ij = 1 + iarea0/ini 1211 IF( ldisoce(ii,ij) ) THEN 1212 icont = icont + 1 1213 kproc(ii,ij) = icont 1214 kipos(icont+1) = ii 1215 kjpos(icont+1) = ij 1216 ENDIF 1217 END DO 1218 ! if needed add some land subdomains to reach inij active subdomains 1219 i2add = inij - COUNT( ldisoce ) 1220 DO jarea = 1, ini*inj 1221 iarea0 = jarea - 1 1222 ii = 1 + MOD(iarea0,ini) 1223 ij = 1 + iarea0/ini 1224 IF( .NOT. ldisoce(ii,ij) .AND. i2add > 0 ) THEN 1225 icont = icont + 1 1226 kproc(ii,ij) = icont 1227 kipos(icont+1) = ii 1228 kjpos(icont+1) = ij 1229 i2add = i2add - 1 1230 ENDIF 1231 END DO 1232 ! 1233 END SUBROUTINE mpp_getnum 1234 1235 1236 SUBROUTINE init_ioipsl 1237 !!---------------------------------------------------------------------- 1238 !! *** ROUTINE init_ioipsl *** 1173 1239 !! 1174 1240 !! ** Purpose : … … 1187 1253 ! Set idompar values equivalent to the jpdom_local_noextra definition 1188 1254 ! used in IOM. This works even if jpnij .ne. jpni*jpnj. 1189 iglo(1) = jpiglo 1190 iglo(2) = jpjglo 1191 iloc(1) = nlci 1192 iloc(2) = nlcj 1193 iabsf(1) = nimppt(narea) 1194 iabsf(2) = njmppt(narea) 1255 iglo( :) = (/ Ni0glo, Nj0glo /) 1256 iloc( :) = (/ Ni_0 , Nj_0 /) 1257 iabsf(:) = (/ Nis0 , Njs0 /) + (/ nimpp, njmpp /) - 1 - nn_hls ! corresponds to mig0(Nis0) but mig0 is not yet defined! 1195 1258 iabsl(:) = iabsf(:) + iloc(:) - 1 1196 ihals(1) = nldi - 1 1197 ihals(2) = nldj - 1 1198 ihale(1) = nlci - nlei 1199 ihale(2) = nlcj - nlej 1200 idid(1) = 1 1201 idid(2) = 2 1259 ihals(:) = (/ 0 , 0 /) 1260 ihale(:) = (/ 0 , 0 /) 1261 idid( :) = (/ 1 , 2 /) 1202 1262 1203 1263 IF(lwp) THEN 1204 1264 WRITE(numout,*) 1205 WRITE(numout,*) 'mpp _init_ioipsl : iloc = ', iloc (1), iloc (2)1206 WRITE(numout,*) '~~~~~~~~~~~~~~~ iabsf = ', iabsf (1), iabsf(2)1207 WRITE(numout,*) ' ihals = ', ihals (1), ihals(2)1208 WRITE(numout,*) ' ihale = ', ihale (1), ihale(2)1265 WRITE(numout,*) 'mpp init_ioipsl : iloc = ', iloc 1266 WRITE(numout,*) '~~~~~~~~~~~~~~~ iabsf = ', iabsf 1267 WRITE(numout,*) ' ihals = ', ihals 1268 WRITE(numout,*) ' ihale = ', ihale 1209 1269 ENDIF 1210 1270 ! 1211 1271 CALL flio_dom_set ( jpnij, nproc, idid, iglo, iloc, iabsf, iabsl, ihals, ihale, 'BOX', nidom) 1212 1272 ! 1213 END SUBROUTINE mpp_init_ioipsl1214 1215 1216 SUBROUTINE mpp_init_nfdcom1217 !!---------------------------------------------------------------------- 1218 !! *** ROUTINE mpp_init_nfdcom ***1273 END SUBROUTINE init_ioipsl 1274 1275 1276 SUBROUTINE init_nfdcom 1277 !!---------------------------------------------------------------------- 1278 !! *** ROUTINE init_nfdcom *** 1219 1279 !! ** Purpose : Setup for north fold exchanges with explicit 1220 1280 !! point-to-point messaging … … 1226 1286 !!---------------------------------------------------------------------- 1227 1287 INTEGER :: sxM, dxM, sxT, dxT, jn 1228 INTEGER :: njmppmax 1229 !!---------------------------------------------------------------------- 1230 ! 1231 njmppmax = MAXVAL( njmppt ) 1288 !!---------------------------------------------------------------------- 1232 1289 ! 1233 1290 !initializes the north-fold communication variables … … 1235 1292 nsndto = 0 1236 1293 ! 1237 IF ( njmpp == njmppmax) THEN ! if I am a process in the north1294 IF ( njmpp == MAXVAL( njmppt ) ) THEN ! if I am a process in the north 1238 1295 ! 1239 1296 !sxM is the first point (in the global domain) needed to compute the north-fold for the current process 1240 sxM = jpiglo - nimppt(narea) - nlcit(narea) + 11297 sxM = jpiglo - nimppt(narea) - jpiall(narea) + 1 1241 1298 !dxM is the last point (in the global domain) needed to compute the north-fold for the current process 1242 1299 dxM = jpiglo - nimppt(narea) + 2 … … 1247 1304 DO jn = 1, jpni 1248 1305 ! 1249 sxT = nfi impp(jn, jpnj)! sxT = 1st point (in the global domain) of the jn process1250 dxT = nfi impp(jn, jpnj) + nfilcit(jn, jpnj) - 1 ! dxT = last point (in the global domain) of the jn process1306 sxT = nfimpp(jn) ! sxT = 1st point (in the global domain) of the jn process 1307 dxT = nfimpp(jn) + nfjpi(jn) - 1 ! dxT = last point (in the global domain) of the jn process 1251 1308 ! 1252 1309 IF ( sxT < sxM .AND. sxM < dxT ) THEN … … 1262 1319 ! 1263 1320 END DO 1264 nfsloop = 11265 nfeloop = nlci1266 DO jn = 2,jpni-11267 IF( nfipproc(jn,jpnj) == (narea - 1) ) THEN1268 IF( nfipproc(jn-1,jpnj) == -1 ) nfsloop = nldi1269 IF( nfipproc(jn+1,jpnj) == -1 ) nfeloop = nlei1270 ENDIF1271 END DO1272 1321 ! 1273 1322 ENDIF 1274 1323 l_north_nogather = .TRUE. 1275 1324 ! 1276 END SUBROUTINE mpp_init_nfdcom 1277 1278 1279 #endif 1280 1325 END SUBROUTINE init_nfdcom 1326 1327 1328 SUBROUTINE init_doloop 1329 !!---------------------------------------------------------------------- 1330 !! *** ROUTINE init_doloop *** 1331 !! 1332 !! ** Purpose : set the starting/ending indices of DO-loop 1333 !! These indices are used in do_loop_substitute.h90 1334 !!---------------------------------------------------------------------- 1335 ! 1336 Nis0 = 1+nn_hls ; Nis1 = Nis0-1 ; Nis2 = MAX( 1, Nis0-2) 1337 Njs0 = 1+nn_hls ; Njs1 = Njs0-1 ; Njs2 = MAX( 1, Njs0-2) 1338 ! 1339 Nie0 = jpi-nn_hls ; Nie1 = Nie0+1 ; Nie2 = MIN(jpi, Nie0+2) 1340 Nje0 = jpj-nn_hls ; Nje1 = Nje0+1 ; Nje2 = MIN(jpj, Nje0+2) 1341 ! 1342 IF( nn_hls == 1 ) THEN !* halo size of 1 1343 ! 1344 Nis1nxt2 = Nis0 ; Njs1nxt2 = Njs0 1345 Nie1nxt2 = Nie0 ; Nje1nxt2 = Nje0 1346 ! 1347 ELSE !* larger halo size... 1348 ! 1349 Nis1nxt2 = Nis1 ; Njs1nxt2 = Njs1 1350 Nie1nxt2 = Nie1 ; Nje1nxt2 = Nje1 1351 ! 1352 ENDIF 1353 ! 1354 Ni_0 = Nie0 - Nis0 + 1 1355 Nj_0 = Nje0 - Njs0 + 1 1356 Ni_1 = Nie1 - Nis1 + 1 1357 Nj_1 = Nje1 - Njs1 + 1 1358 Ni_2 = Nie2 - Nis2 + 1 1359 Nj_2 = Nje2 - Njs2 + 1 1360 ! 1361 END SUBROUTINE init_doloop 1362 1281 1363 !!====================================================================== 1282 1364 END MODULE mppini
Note: See TracChangeset
for help on using the changeset viewer.