Changeset 14623 for utils/tools/DOMAINcfg/src/mppini.F90
- Timestamp:
- 2021-03-21T19:40:22+01:00 (3 years ago)
- File:
-
- 1 edited
-
utils/tools/DOMAINcfg/src/mppini.F90 (modified) (52 diffs)
Legend:
- Unmodified
- Added
- Removed
-
utils/tools/DOMAINcfg/src/mppini.F90
r13204 r14623 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_partition: Calculate MPP domain decomposition 20 !! factorise : Calculate the factors of the no. of MPI processes 21 !! 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 22 21 !!---------------------------------------------------------------------- 23 22 USE dom_oce ! ocean space and time domain 23 ! USE bdy_oce ! open BounDarY 24 24 ! 25 USE lbcnfd , ONLY : isendto, nsndto , nfsloop, nfeloop! Setup of north fold exchanges25 USE lbcnfd , ONLY : isendto, nsndto ! Setup of north fold exchanges 26 26 USE lib_mpp ! distribued memory computing library 27 27 USE iom ! nemo I/O library … … 32 32 PRIVATE 33 33 34 PUBLIC mpp_init ! called by opa.F90 35 36 INTEGER :: numbot = -1 ! 'bottom_level' 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 37 41 38 42 !!---------------------------------------------------------------------- 39 43 !! NEMO/OCE 4.0 , NEMO Consortium (2018) 40 !! $Id: mppini.F90 1 0570 2019-01-24 15:14:49Z acc $44 !! $Id: mppini.F90 13305 2020-07-14 17:12:25Z acc $ 41 45 !! Software governed by the CeCILL license (see ./LICENSE) 42 46 !!---------------------------------------------------------------------- … … 58 62 !!---------------------------------------------------------------------- 59 63 ! 64 jpiglo = Ni0glo 65 jpjglo = Nj0glo 60 66 jpimax = jpiglo 61 67 jpjmax = jpjglo … … 63 69 jpj = jpjglo 64 70 jpk = jpkglo 65 jpim1 = jpi-1 ! inner domain indices 66 jpjm1 = jpj-1 ! " " 67 jpkm1 = MAX( 1, jpk-1 ) ! " " 71 jpim1 = jpi-1 ! inner domain indices 72 jpjm1 = jpj-1 ! " " 73 jpkm1 = MAX( 1, jpk-1 ) ! " " 74 ! 75 CALL init_doloop ! set start/end indices or do-loop depending on the halo width value (nn_hls) 76 ! 68 77 jpij = jpi*jpj 69 78 jpni = 1 70 79 jpnj = 1 71 80 jpnij = jpni*jpnj 72 nimpp = 1 ! 81 nn_hls = 1 82 nimpp = 1 73 83 njmpp = 1 74 nlci = jpi75 nlcj = jpj76 nldi = 177 nldj = 178 nlei = jpi79 nlej = jpj80 84 nbondi = 2 81 85 nbondj = 2 82 npolj = jperio 86 nidom = FLIO_DOM_NONE 87 npolj = 0 88 IF( jperio == 3 .OR. jperio == 4 ) npolj = 3 89 IF( jperio == 5 .OR. jperio == 6 ) npolj = 5 83 90 l_Iperio = jpni == 1 .AND. (jperio == 1 .OR. jperio == 4 .OR. jperio == 6 .OR. jperio == 7) 84 91 l_Jperio = jpnj == 1 .AND. (jperio == 2 .OR. jperio == 7) … … 95 102 CALL ctl_stop( 'mpp_init: equality jpni = jpnj = jpnij = 1 is not satisfied', & 96 103 & 'the domain is lay out for distributed memory computing!' ) 97 104 ! 98 105 #if defined key_agrif 99 IF (.not.agrif_root()) THEN 100 CALL agrif_nemo_init 101 ENDIF 106 CALL agrif_nemo_init() 102 107 103 108 IF( .NOT. Agrif_Root() ) THEN ! AGRIF children: specific setting (cf. agrif_user.F90) 104 109 print *,'nbcellsx = ',nbcellsx,nbghostcells_x 105 110 print *,'nbcellsy = ',nbcellsy,nbghostcells_y_s,nbghostcells_y_n 106 IF( jpiglo /= nbcellsx + 2 + 2*nbghostcells_x ) THEN111 IF( Ni0glo /= nbcellsx + 2 + 2*nbghostcells_x ) THEN 107 112 IF(lwp) THEN 108 113 WRITE(numout,*) 109 WRITE(numout,*) ' jpiglo should be: ', nbcellsx + 2 + 2*nbghostcells_x114 WRITE(numout,*) 'Ni0glo should be: ', nbcellsx + 2 + 2*nbghostcells_x 110 115 ENDIF 111 CALL ctl_stop( 'STOP', 'mpp_init: Agrif children requires jpiglo == nbcellsx + 2 + 2*nbghostcells_x' )116 CALL ctl_stop( 'STOP', 'mpp_init: Agrif children requires Ni0glo == nbcellsx + 2 + 2*nbghostcells_x' ) 112 117 ENDIF 113 IF( jpjglo /= nbcellsy + 2 + nbghostcells_y_s + nbghostcells_y_n ) THEN118 IF( Nj0glo /= nbcellsy + 2 + nbghostcells_y_s + nbghostcells_y_n ) THEN 114 119 IF(lwp) THEN 115 120 WRITE(numout,*) 116 WRITE(numout,*) ' jpjglo shoud be: ', nbcellsy + 2 + nbghostcells_y_s + nbghostcells_y_n121 WRITE(numout,*) 'Nj0glo shoud be: ', nbcellsy + 2 + nbghostcells_y_s + nbghostcells_y_n 117 122 ENDIF 118 123 CALL ctl_stop( 'STOP', & 119 'mpp_init: Agrif children requires jpjglo == nbcellsy + 2 + nbghostcells_y_s + nbghostcells_y_n' )124 'mpp_init: Agrif children requires Nj0glo == nbcellsy + 2 + nbghostcells_y_s + nbghostcells_y_n' ) 120 125 ENDIF 121 126 IF( ln_use_jattr ) CALL ctl_stop( 'STOP', 'mpp_init:Agrif children requires ln_use_jattr = .false. ' ) 122 127 ENDIF 123 128 #endif 124 !125 129 END SUBROUTINE mpp_init 126 130 … … 151 155 !! njmpp : latitudinal index 152 156 !! narea : number for local area 153 !! nlci : first dimension154 !! nlcj : second dimension155 157 !! nbondi : mark for "east-west local boundary" 156 158 !! nbondj : mark for "north-south local boundary" … … 163 165 INTEGER :: ji, jj, jn, jproc, jarea ! dummy loop indices 164 166 INTEGER :: inijmin 165 INTEGER :: i2add166 167 INTEGER :: inum ! local logical unit 167 INTEGER :: idir, ifreq , icont! local integers168 INTEGER :: idir, ifreq ! local integers 168 169 INTEGER :: ii, il1, ili, imil ! - - 169 170 INTEGER :: ij, il2, ilj, ijm1 ! - - … … 173 174 INTEGER :: ierr, ios ! 174 175 INTEGER :: inbi, inbj, iimax, ijmax, icnt1, icnt2 175 LOGICAL :: llbest 176 LOGICAL :: llbest, llauto 176 177 LOGICAL :: llwrtlay 178 LOGICAL :: ln_listonly 177 179 INTEGER, ALLOCATABLE, DIMENSION(:) :: iin, ii_nono, ii_noea ! 1D workspace 178 180 INTEGER, ALLOCATABLE, DIMENSION(:) :: ijn, ii_noso, ii_nowe ! - - 179 INTEGER, ALLOCATABLE, DIMENSION(:,:) :: iimppt, i lci, ibondi, ipproc ! 2D workspace180 INTEGER, ALLOCATABLE, DIMENSION(:,:) :: ijmppt, i lcj, ibondj, ipolj ! - -181 INTEGER, ALLOCATABLE, DIMENSION(:,:) :: i lei, ildi, iono, ioea ! - -182 INTEGER, ALLOCATABLE, DIMENSION(:,:) :: i lej, ildj, ioso, iowe ! - -181 INTEGER, ALLOCATABLE, DIMENSION(:,:) :: iimppt, ijpi, ibondi, ipproc ! 2D workspace 182 INTEGER, ALLOCATABLE, DIMENSION(:,:) :: ijmppt, ijpj, ibondj, ipolj ! - - 183 INTEGER, ALLOCATABLE, DIMENSION(:,:) :: iie0, iis0, iono, ioea ! - - 184 INTEGER, ALLOCATABLE, DIMENSION(:,:) :: ije0, ijs0, ioso, iowe ! - - 183 185 LOGICAL, ALLOCATABLE, DIMENSION(:,:) :: llisoce ! - - 184 !!---------------------------------------------------------------------- 185 186 llwrtlay = lwp 186 ! NAMELIST/nambdy/ ln_bdy, nb_bdy, ln_coords_file, cn_coords_file, & 187 ! & ln_mask_file, cn_mask_file, cn_dyn2d, nn_dyn2d_dta, & 188 ! & cn_dyn3d, nn_dyn3d_dta, cn_tra, nn_tra_dta, & 189 ! & ln_tra_dmp, ln_dyn3d_dmp, rn_time_dmp, rn_time_dmp_out, & 190 ! & cn_ice, nn_ice_dta, & 191 ! & ln_vol, nn_volctl, nn_rimwidth 192 NAMELIST/nammpp/ jpni, jpnj, nn_hls, ln_nnogather, ln_listonly 193 !!---------------------------------------------------------------------- 194 ! 195 llwrtlay = lwm .OR. sn_cfctl%l_layout 196 ! 197 ! 0. read namelists parameters 198 ! ----------------------------------- 199 ! 200 READ ( numnam_ref, nammpp, IOSTAT = ios, ERR = 901 ) 201 901 IF( ios /= 0 ) CALL ctl_nam ( ios , 'nammpp in reference namelist' ) 202 READ ( numnam_cfg, nammpp, IOSTAT = ios, ERR = 902 ) 203 902 IF( ios > 0 ) CALL ctl_nam ( ios , 'nammpp in configuration namelist' ) 204 ! 205 nn_hls = MAX(1, nn_hls) ! nn_hls must be > 0 206 IF(lwp) THEN 207 WRITE(numout,*) ' Namelist nammpp' 208 IF( jpni < 1 .OR. jpnj < 1 ) THEN 209 WRITE(numout,*) ' jpni and jpnj will be calculated automatically' 210 ELSE 211 WRITE(numout,*) ' processor grid extent in i jpni = ', jpni 212 WRITE(numout,*) ' processor grid extent in j jpnj = ', jpnj 213 ENDIF 214 WRITE(numout,*) ' avoid use of mpi_allgather at the north fold ln_nnogather = ', ln_nnogather 215 WRITE(numout,*) ' halo width (applies to both rows and columns) nn_hls = ', nn_hls 216 ENDIF 217 ! 218 IF(lwm) WRITE( numond, nammpp ) 219 ! 220 !!!------------------------------------ 221 !!! nn_hls shloud be read in nammpp 222 !!!------------------------------------ 223 jpiglo = Ni0glo + 2 * nn_hls 224 jpjglo = Nj0glo + 2 * nn_hls 225 ! 226 ! do we need to take into account bdy_msk? 227 ! READ ( numnam_ref, nambdy, IOSTAT = ios, ERR = 903) 228 !903 IF( ios /= 0 ) CALL ctl_nam ( ios , 'nambdy in reference namelist (mppini)' ) 229 ! READ ( numnam_cfg, nambdy, IOSTAT = ios, ERR = 904 ) 230 !904 IF( ios > 0 ) CALL ctl_nam ( ios , 'nambdy in configuration namelist (mppini)' ) 187 231 ! 188 232 IF( ln_read_cfg ) CALL iom_open( cn_domcfg, numbot ) 233 ! IF( ln_bdy .AND. ln_mask_file ) CALL iom_open( cn_mask_file, numbdy ) 234 ! 235 IF( ln_listonly ) CALL bestpartition( MAX(mppsize,jpni*jpnj), ldlist = .TRUE. ) ! must be done by all core 189 236 ! 190 237 ! 1. Dimension arrays for subdomains 191 238 ! ----------------------------------- 192 239 ! 193 ! If dimensions of processor grid weren't specified in the namelist file240 ! If dimensions of processors grid weren't specified in the namelist file 194 241 ! then we calculate them here now that we have our communicator size 242 IF(lwp) THEN 243 WRITE(numout,*) 'mpp_init:' 244 WRITE(numout,*) '~~~~~~~~ ' 245 WRITE(numout,*) 246 ENDIF 195 247 IF( jpni < 1 .OR. jpnj < 1 ) THEN 196 CALL mpp_init_bestpartition( mppsize, jpni, jpnj ) 248 CALL bestpartition( mppsize, jpni, jpnj ) ! best mpi decomposition for mppsize mpi processes 249 llauto = .TRUE. 197 250 llbest = .TRUE. 198 251 ELSE 199 CALL mpp_init_bestpartition( mppsize, inbi, inbj, icnt2 ) 200 CALL mpp_basic_decomposition( jpni, jpnj, jpimax, jpjmax ) 201 CALL mpp_basic_decomposition( inbi, inbj, iimax, ijmax ) 202 IF( iimax*ijmax < jpimax*jpjmax ) THEN 252 llauto = .FALSE. 253 CALL bestpartition( mppsize, inbi, inbj, icnt2 ) ! best mpi decomposition for mppsize mpi processes 254 ! largest subdomain size for mpi decoposition jpni*jpnj given in the namelist 255 CALL mpp_basesplit( jpiglo, jpjglo, nn_hls, jpni, jpnj, jpimax, jpjmax ) 256 ! largest subdomain size for mpi decoposition inbi*inbj given by bestpartition 257 CALL mpp_basesplit( jpiglo, jpjglo, nn_hls, inbi, inbj, iimax, ijmax ) 258 icnt1 = jpni*jpnj - mppsize ! number of land subdomains that should be removed to use mppsize mpi processes 259 IF(lwp) THEN 260 WRITE(numout,9000) ' The chosen domain decomposition ', jpni, ' x ', jpnj, ' with ', icnt1, ' land subdomains' 261 WRITE(numout,9002) ' - uses a total of ', mppsize,' mpi process' 262 WRITE(numout,9000) ' - has mpi subdomains with a maximum size of (jpi = ', jpimax, ', jpj = ', jpjmax, & 263 & ', jpi*jpj = ', jpimax*jpjmax, ')' 264 WRITE(numout,9000) ' The best domain decompostion ', inbi, ' x ', inbj, ' with ', icnt2, ' land subdomains' 265 WRITE(numout,9002) ' - uses a total of ', inbi*inbj-icnt2,' mpi process' 266 WRITE(numout,9000) ' - has mpi subdomains with a maximum size of (jpi = ', iimax, ', jpj = ', ijmax, & 267 & ', jpi*jpj = ', iimax* ijmax, ')' 268 ENDIF 269 IF( iimax*ijmax < jpimax*jpjmax ) THEN ! chosen subdomain size is larger that the best subdomain size 203 270 llbest = .FALSE. 204 icnt1 = jpni*jpnj - mppsize 205 WRITE(ctmp1,9000) ' The chosen domain decomposition ', jpni, ' x ', jpnj, ' with ', icnt1, ' land sub-domains' 206 WRITE(ctmp2,9000) ' has larger MPI subdomains (jpi = ', jpimax, ', jpj = ', jpjmax, ', jpi*jpj = ', jpimax*jpjmax, ')' 207 WRITE(ctmp3,9000) ' than the following domain decompostion ', inbi, ' x ', inbj, ' with ', icnt2, ' land sub-domains' 208 WRITE(ctmp4,9000) ' which MPI subdomains size is jpi = ', iimax, ', jpj = ', ijmax, ', jpi*jpj = ', iimax*ijmax, ' ' 209 CALL ctl_warn( 'mpp_init:', '~~~~~~~~ ', ctmp1, ctmp2, ctmp3, ctmp4, ' ', ' --- YOU ARE WASTING CPU... ---', ' ' ) 271 IF ( inbi*inbj-icnt2 < mppsize ) THEN 272 WRITE(ctmp1,*) ' ==> You could therefore have smaller mpi subdomains with less mpi processes' 273 ELSE 274 WRITE(ctmp1,*) ' ==> You could therefore have smaller mpi subdomains with the same number of mpi processes' 275 ENDIF 276 CALL ctl_warn( ' ', ctmp1, ' ', ' --- YOU ARE WASTING CPU... ---', ' ' ) 277 ELSE IF ( iimax*ijmax == jpimax*jpjmax .AND. (inbi*inbj-icnt2) < mppsize) THEN 278 llbest = .FALSE. 279 WRITE(ctmp1,*) ' ==> You could therefore have the same mpi subdomains size with less mpi processes' 280 CALL ctl_warn( ' ', ctmp1, ' ', ' --- YOU ARE WASTING CPU... ---', ' ' ) 210 281 ELSE 211 282 llbest = .TRUE. … … 215 286 ! look for land mpi subdomains... 216 287 ALLOCATE( llisoce(jpni,jpnj) ) 217 CALL mpp_i nit_isoce( jpni, jpnj,llisoce )288 CALL mpp_is_ocean( llisoce ) 218 289 inijmin = COUNT( llisoce ) ! number of oce subdomains 219 290 220 IF( mppsize < inijmin ) THEN 291 IF( mppsize < inijmin ) THEN ! too many oce subdomains: can happen only if jpni and jpnj are prescribed... 221 292 WRITE(ctmp1,9001) ' With this specified domain decomposition: jpni = ', jpni, ' jpnj = ', jpnj 222 293 WRITE(ctmp2,9002) ' we can eliminate only ', jpni*jpnj - inijmin, ' land mpi subdomains therefore ' 223 294 WRITE(ctmp3,9001) ' the number of ocean mpi subdomains (', inijmin,') exceed the number of MPI processes:', mppsize 224 295 WRITE(ctmp4,*) ' ==>>> There is the list of best domain decompositions you should use: ' 225 CALL ctl_stop( 'mpp_init:', '~~~~~~~~ ', ctmp1, ctmp2, ctmp3, ctmp4 ) 226 CALL mpp_init_bestpartition( mppsize, ldlist = .TRUE. ) ! must be done by all core 227 CALL ctl_stop( 'STOP' ) 228 ENDIF 229 230 IF( mppsize > jpni*jpnj ) THEN 231 WRITE(ctmp1,9003) ' The number of mpi processes: ', mppsize 232 WRITE(ctmp2,9003) ' exceeds the maximum number of subdomains (ocean+land) = ', jpni*jpnj 233 WRITE(ctmp3,9001) ' defined by the following domain decomposition: jpni = ', jpni, ' jpnj = ', jpnj 234 WRITE(ctmp4,*) ' ==>>> There is the list of best domain decompositions you should use: ' 235 CALL ctl_stop( 'mpp_init:', '~~~~~~~~ ', ctmp1, ctmp2, ctmp3, ctmp4 ) 236 CALL mpp_init_bestpartition( mppsize, ldlist = .TRUE. ) ! must be done by all core 237 CALL ctl_stop( 'STOP' ) 296 CALL ctl_stop( ctmp1, ctmp2, ctmp3, ' ', ctmp4, ' ' ) 297 CALL bestpartition( mppsize, ldlist = .TRUE. ) ! must be done by all core 298 ENDIF 299 300 IF( mppsize > jpni*jpnj ) THEN ! not enough mpi subdomains for the total number of mpi processes 301 IF(lwp) THEN 302 WRITE(numout,9003) ' The number of mpi processes: ', mppsize 303 WRITE(numout,9003) ' exceeds the maximum number of subdomains (ocean+land) = ', jpni*jpnj 304 WRITE(numout,9001) ' defined by the following domain decomposition: jpni = ', jpni, ' jpnj = ', jpnj 305 WRITE(numout, *) ' You should: ' 306 IF( llauto ) THEN 307 WRITE(numout,*) ' - either prescribe your domain decomposition with the namelist variables' 308 WRITE(numout,*) ' jpni and jpnj to match the number of mpi process you want to use, ' 309 WRITE(numout,*) ' even IF it not the best choice...' 310 WRITE(numout,*) ' - or keep the automatic and optimal domain decomposition by picking up one' 311 WRITE(numout,*) ' of the number of mpi process proposed in the list bellow' 312 ELSE 313 WRITE(numout,*) ' - either properly prescribe your domain decomposition with jpni and jpnj' 314 WRITE(numout,*) ' in order to be consistent with the number of mpi process you want to use' 315 WRITE(numout,*) ' even IF it not the best choice...' 316 WRITE(numout,*) ' - or use the automatic and optimal domain decomposition and pick up one of' 317 WRITE(numout,*) ' the domain decomposition proposed in the list bellow' 318 ENDIF 319 WRITE(numout,*) 320 ENDIF 321 CALL bestpartition( mppsize, ldlist = .TRUE. ) ! must be done by all core 238 322 ENDIF 239 323 … … 244 328 WRITE(ctmp3,9002) ' we suppressed ', jpni*jpnj - mppsize, ' land subdomains ' 245 329 WRITE(ctmp4,9002) ' BUT we had to keep ', mppsize - inijmin, ' land subdomains that are useless...' 246 CALL ctl_warn( 'mpp_init:', '~~~~~~~~ ',ctmp1, ctmp2, ctmp3, ctmp4, ' ', ' --- YOU ARE WASTING CPU... ---', ' ' )330 CALL ctl_warn( ctmp1, ctmp2, ctmp3, ctmp4, ' ', ' --- YOU ARE WASTING CPU... ---', ' ' ) 247 331 ELSE ! mppsize = inijmin 248 332 IF(lwp) THEN 249 IF(llbest) WRITE(numout,*) ' mpp_init: You use an optimal domaindecomposition'250 WRITE(numout,*) '~~~~~~~~ '333 IF(llbest) WRITE(numout,*) ' ==> you use the best mpi decomposition' 334 WRITE(numout,*) 251 335 WRITE(numout,9003) ' Number of mpi processes: ', mppsize 252 336 WRITE(numout,9003) ' Number of ocean subdomains = ', inijmin … … 260 344 9003 FORMAT (a, i5) 261 345 262 IF( numbot /= -1 ) CALL iom_close( numbot ) 263 264 ALLOCATE( nfiimpp(jpni,jpnj), nfipproc(jpni,jpnj), nfilcit(jpni,jpnj) , & 265 & nimppt(jpnij) , ibonit(jpnij) , nlcit(jpnij) , nlcjt(jpnij) , & 266 & njmppt(jpnij) , ibonjt(jpnij) , nldit(jpnij) , nldjt(jpnij) , & 267 & nleit(jpnij) , nlejt(jpnij) , & 346 ALLOCATE( nfimpp(jpni ) , nfproc(jpni ) , nfjpi(jpni ) , & 347 & nimppt(jpnij) , ibonit(jpnij) , jpiall(jpnij) , jpjall(jpnij) , & 348 & njmppt(jpnij) , ibonjt(jpnij) , nis0all(jpnij) , njs0all(jpnij) , & 349 & nie0all(jpnij) , nje0all(jpnij) , & 268 350 & iin(jpnij), ii_nono(jpnij), ii_noea(jpnij), & 269 351 & ijn(jpnij), ii_noso(jpnij), ii_nowe(jpnij), & 270 & iimppt(jpni,jpnj), i lci(jpni,jpnj), ibondi(jpni,jpnj), ipproc(jpni,jpnj), &271 & ijmppt(jpni,jpnj), i lcj(jpni,jpnj), ibondj(jpni,jpnj),ipolj(jpni,jpnj), &272 & ilei(jpni,jpnj), ildi(jpni,jpnj), iono(jpni,jpnj),ioea(jpni,jpnj), &273 & ilej(jpni,jpnj), ildj(jpni,jpnj), ioso(jpni,jpnj),iowe(jpni,jpnj), &352 & iimppt(jpni,jpnj), ijpi(jpni,jpnj), ibondi(jpni,jpnj), ipproc(jpni,jpnj), & 353 & ijmppt(jpni,jpnj), ijpj(jpni,jpnj), ibondj(jpni,jpnj), ipolj(jpni,jpnj), & 354 & iie0(jpni,jpnj), iis0(jpni,jpnj), iono(jpni,jpnj), ioea(jpni,jpnj), & 355 & ije0(jpni,jpnj), ijs0(jpni,jpnj), ioso(jpni,jpnj), iowe(jpni,jpnj), & 274 356 & STAT=ierr ) 275 357 CALL mpp_sum( 'mppini', ierr ) … … 277 359 278 360 #if defined key_agrif 361 CALL agrif_nemo_init() 279 362 IF( .NOT. Agrif_Root() ) THEN ! AGRIF children: specific setting (cf. agrif_user.F90) 280 CALL agrif_nemo_init 281 IF( jpiglo /= nbcellsx + 2 + 2*nbghostcells_x ) THEN 363 IF( Ni0glo /= nbcellsx + 2 + 2*nbghostcells_x ) THEN 282 364 IF(lwp) THEN 283 365 WRITE(numout,*) 284 WRITE(numout,*) ' jpiglo should be: ', nbcellsx + 2 + 2*nbghostcells_x366 WRITE(numout,*) 'Ni0glo should be: ', nbcellsx + 2 + 2*nbghostcells_x 285 367 ENDIF 286 CALL ctl_stop( 'STOP', 'mpp_init: Agrif children requires jpiglo == nbcellsx + 2 + 2*nbghostcells' )368 CALL ctl_stop( 'STOP', 'mpp_init: Agrif children requires Ni0glo == nbcellsx + 2 + 2*nbghostcells_x' ) 287 369 ENDIF 288 IF( jpjglo /= nbcellsy + 2 + nbghostcells_y_s + nbghostcells_y_n ) THEN370 IF( Nj0glo /= nbcellsy + 2 + nbghostcells_y_s + nbghostcells_y_n ) THEN 289 371 IF(lwp) THEN 290 372 WRITE(numout,*) 291 WRITE(numout,*) ' jpjglo shoud be: ', nbcellsy + 2 + nbghostcells_y_s + nbghostcells_y_n373 WRITE(numout,*) 'Nj0glo shoud be: ', nbcellsy + 2 + nbghostcells_y_s + nbghostcells_y_n 292 374 ENDIF 293 375 CALL ctl_stop( 'STOP', & 294 'mpp_init: Agrif children requires jpjglo == nbcellsy + 2 + nbghostcells_y_s + nbghostcells_y_n' )376 'mpp_init: Agrif children requires Nj0glo == nbcellsy + 2 + nbghostcells_y_s + nbghostcells_y_n' ) 295 377 ENDIF 296 378 IF( ln_use_jattr ) CALL ctl_stop( 'STOP', 'mpp_init:Agrif children requires ln_use_jattr = .false. ' ) … … 301 383 ! ----------------------------------- 302 384 ! 303 nreci = 2 * nn_hls 304 nrecj = 2 * nn_hls 305 CALL mpp_basic_decomposition( jpni, jpnj, jpimax, jpjmax, iimppt, ijmppt, ilci, ilcj ) 306 nfiimpp(:,:) = iimppt(:,:) 307 nfilcit(:,:) = ilci(:,:) 385 386 CALL mpp_basesplit( jpiglo, jpjglo, nn_hls, jpni, jpnj, jpimax, jpjmax, iimppt, ijmppt, ijpi, ijpj ) 387 CALL mpp_getnum( llisoce, ipproc, iin, ijn ) 388 ! 389 !DO jn = 1, jpni 390 ! jproc = ipproc(jn,jpnj) 391 ! ii = iin(jproc+1) 392 ! ij = ijn(jproc+1) 393 ! nfproc(jn) = jproc 394 ! nfimpp(jn) = iimppt(ii,ij) 395 ! nfjpi (jn) = ijpi(ii,ij) 396 !END DO 397 nfproc(:) = ipproc(:,jpnj) 398 nfimpp(:) = iimppt(:,jpnj) 399 nfjpi (:) = ijpi(:,jpnj) 308 400 ! 309 401 IF(lwp) THEN … … 314 406 WRITE(numout,*) ' jpni = ', jpni 315 407 WRITE(numout,*) ' jpnj = ', jpnj 408 WRITE(numout,*) ' jpnij = ', jpnij 316 409 WRITE(numout,*) 317 WRITE(numout,*) ' sum i lci(i,1) = ', sum(ilci(:,1)), ' jpiglo = ', jpiglo318 WRITE(numout,*) ' sum i lcj(1,j) = ', sum(ilcj(1,:)), ' jpjglo = ', jpjglo410 WRITE(numout,*) ' sum ijpi(i,1) = ', sum(ijpi(:,1)), ' jpiglo = ', jpiglo 411 WRITE(numout,*) ' sum ijpj(1,j) = ', sum(ijpj(1,:)), ' jpjglo = ', jpjglo 319 412 ENDIF 320 413 … … 331 424 ii = 1 + MOD(iarea0,jpni) 332 425 ij = 1 + iarea0/jpni 333 ili = i lci(ii,ij)334 ilj = i lcj(ii,ij)426 ili = ijpi(ii,ij) 427 ilj = ijpj(ii,ij) 335 428 ibondi(ii,ij) = 0 ! default: has e-w neighbours 336 429 IF( ii == 1 ) ibondi(ii,ij) = -1 ! first column, has only e neighbour … … 347 440 ioea(ii,ij) = iarea0 + 1 348 441 iono(ii,ij) = iarea0 + jpni 349 i ldi(ii,ij) = 1 + nn_hls350 i lei(ii,ij) = ili - nn_hls351 i ldj(ii,ij) = 1 + nn_hls352 i lej(ii,ij) = ilj - nn_hls442 iis0(ii,ij) = 1 + nn_hls 443 iie0(ii,ij) = ili - nn_hls 444 ijs0(ii,ij) = 1 + nn_hls 445 ije0(ii,ij) = ilj - nn_hls 353 446 354 447 ! East-West periodicity: change ibondi, ioea, iowe … … 388 481 ! ---------------------------- 389 482 ! 390 ! specify which subdomains are oce subdomains; other are land subdomains391 ipproc(:,:) = -1392 icont = -1393 DO jarea = 1, jpni*jpnj394 iarea0 = jarea - 1395 ii = 1 + MOD(iarea0,jpni)396 ij = 1 + iarea0/jpni397 IF( llisoce(ii,ij) ) THEN398 icont = icont + 1399 ipproc(ii,ij) = icont400 iin(icont+1) = ii401 ijn(icont+1) = ij402 ENDIF403 END DO404 ! if needed add some land subdomains to reach jpnij active subdomains405 i2add = jpnij - inijmin406 DO jarea = 1, jpni*jpnj407 iarea0 = jarea - 1408 ii = 1 + MOD(iarea0,jpni)409 ij = 1 + iarea0/jpni410 IF( .NOT. llisoce(ii,ij) .AND. i2add > 0 ) THEN411 icont = icont + 1412 ipproc(ii,ij) = icont413 iin(icont+1) = ii414 ijn(icont+1) = ij415 i2add = i2add - 1416 ENDIF417 END DO418 nfipproc(:,:) = ipproc(:,:)419 420 483 ! neighbour treatment: change ibondi, ibondj if next to a land zone 421 484 DO jarea = 1, jpni*jpnj … … 456 519 ENDIF 457 520 END DO 458 459 ! Update il[de][ij] according to modified ibond[ij]460 ! ----------------------461 DO jproc = 1, jpnij462 ii = iin(jproc)463 ij = ijn(jproc)464 IF( ibondi(ii,ij) == -1 .OR. ibondi(ii,ij) == 2 ) ildi(ii,ij) = 1465 IF( ibondi(ii,ij) == 1 .OR. ibondi(ii,ij) == 2 ) ilei(ii,ij) = ilci(ii,ij)466 IF( ibondj(ii,ij) == -1 .OR. ibondj(ii,ij) == 2 ) ildj(ii,ij) = 1467 IF( ibondj(ii,ij) == 1 .OR. ibondj(ii,ij) == 2 ) ilej(ii,ij) = ilcj(ii,ij)468 END DO469 521 470 522 ! 5. Subdomain print … … 479 531 DO jj = jpnj, 1, -1 480 532 WRITE(numout,9403) (' ',ji=il1,il2-1) 481 WRITE(numout,9402) jj, (i lci(ji,jj),ilcj(ji,jj),ji=il1,il2)533 WRITE(numout,9402) jj, (ijpi(ji,jj),ijpj(ji,jj),ji=il1,il2) 482 534 WRITE(numout,9404) (ipproc(ji,jj),ji=il1,il2) 483 535 WRITE(numout,9403) (' ',ji=il1,il2-1) … … 491 543 9401 FORMAT(' ' ,20(' ',i3,' ') ) 492 544 9402 FORMAT(' ',i3,' * ',20(i3,' x',i3,' * ') ) 493 9404 FORMAT(' * ' ,20(' ',i3,' * ') )545 9404 FORMAT(' * ' ,20(' ' ,i4,' * ') ) 494 546 ENDIF 495 547 … … 536 588 noea = ii_noea(narea) 537 589 nono = ii_nono(narea) 538 nlci = ilci(ii,ij)539 nldi = ildi(ii,ij)540 nlei = ilei(ii,ij)541 nlcj = ilcj(ii,ij)542 nldj = ildj(ii,ij)543 nlej = ilej(ii,ij)590 jpi = ijpi(ii,ij) 591 !!$ Nis0 = iis0(ii,ij) 592 !!$ Nie0 = iie0(ii,ij) 593 jpj = ijpj(ii,ij) 594 !!$ Njs0 = ijs0(ii,ij) 595 !!$ Nje0 = ije0(ii,ij) 544 596 nbondi = ibondi(ii,ij) 545 597 nbondj = ibondj(ii,ij) 546 598 nimpp = iimppt(ii,ij) 547 599 njmpp = ijmppt(ii,ij) 548 jpi = nlci 549 jpj = nlcj 550 jpk = jpkglo ! third dim 551 #if defined key_agrif 552 ! simple trick to use same vertical grid as parent but different number of levels: 553 ! Save maximum number of levels in jpkglo, then define all vertical grids with this number. 554 ! Suppress once vertical online interpolation is ok 555 !!$ IF(.NOT.Agrif_Root()) jpkglo = Agrif_Parent( jpkglo ) 556 #endif 557 jpim1 = jpi-1 ! inner domain indices 558 jpjm1 = jpj-1 ! " " 559 jpkm1 = MAX( 1, jpk-1 ) ! " " 560 jpij = jpi*jpj ! jpi x j 600 jpk = jpkglo ! third dim 601 ! 602 CALL init_doloop ! set start/end indices of do-loop, depending on the halo width value (nn_hls) 603 ! 604 jpim1 = jpi-1 ! inner domain indices 605 jpjm1 = jpj-1 ! " " 606 jpkm1 = MAX( 1, jpk-1 ) ! " " 607 jpij = jpi*jpj ! jpi x j 561 608 DO jproc = 1, jpnij 562 609 ii = iin(jproc) 563 610 ij = ijn(jproc) 564 nlcit(jproc) = ilci(ii,ij)565 n ldit(jproc) = ildi(ii,ij)566 n leit(jproc) = ilei(ii,ij)567 nlcjt(jproc) = ilcj(ii,ij)568 n ldjt(jproc) = ildj(ii,ij)569 n lejt(jproc) = ilej(ii,ij)611 jpiall (jproc) = ijpi(ii,ij) 612 nis0all(jproc) = iis0(ii,ij) 613 nie0all(jproc) = iie0(ii,ij) 614 jpjall (jproc) = ijpj(ii,ij) 615 njs0all(jproc) = ijs0(ii,ij) 616 nje0all(jproc) = ije0(ii,ij) 570 617 ibonit(jproc) = ibondi(ii,ij) 571 618 ibonjt(jproc) = ibondj(ii,ij) … … 581 628 WRITE(inum,'(6i8,a,3i8,a)') jpnij,jpimax,jpjmax,jpk,jpiglo,jpjglo,& 582 629 & ' ( local: ',narea,jpi,jpj,' )' 583 WRITE(inum,'(a)') 'nproc nlci nlcj nldi nldj nlei nlejnimp njmp nono noso nowe noea nbondi nbondj '630 WRITE(inum,'(a)') 'nproc jpi jpj Nis0 Njs0 Nie0 Nje0 nimp njmp nono noso nowe noea nbondi nbondj ' 584 631 585 632 DO jproc = 1, jpnij 586 WRITE(inum,'(13i5,2i7)') jproc-1, nlcit (jproc), nlcjt(jproc), &587 & n ldit (jproc), nldjt(jproc), &588 & n leit (jproc), nlejt(jproc), &633 WRITE(inum,'(13i5,2i7)') jproc-1, jpiall(jproc), jpjall(jproc), & 634 & nis0all(jproc), njs0all(jproc), & 635 & nie0all(jproc), nje0all(jproc), & 589 636 & nimppt (jproc), njmppt (jproc), & 590 637 & ii_nono(jproc), ii_noso(jproc), & … … 620 667 WRITE(numout,*) ' l_Iperio = ', l_Iperio 621 668 WRITE(numout,*) ' l_Jperio = ', l_Jperio 622 WRITE(numout,*) ' nlci = ', nlci623 WRITE(numout,*) ' nlcj = ', nlcj624 669 WRITE(numout,*) ' nimpp = ', nimpp 625 670 WRITE(numout,*) ' njmpp = ', njmpp 626 WRITE(numout,*) ' nreci = ', nreci627 WRITE(numout,*) ' nrecj = ', nrecj628 WRITE(numout,*) ' nn_hls = ', nn_hls629 671 ENDIF 630 672 … … 648 690 ENDIF 649 691 ! 650 IF( ln_nnogather ) THEN 651 CALL mpp_init_nfdcom ! northfold neighbour lists 692 CALL init_ioipsl ! Prepare NetCDF output file (if necessary) 693 ! 694 IF (( jperio >= 3 .AND. jperio <= 6 .AND. jpni > 1 ).AND.( ln_nnogather )) THEN 695 CALL init_nfdcom ! northfold neighbour lists 652 696 IF (llwrtlay) THEN 653 697 WRITE(inum,*) 654 698 WRITE(inum,*) 655 699 WRITE(inum,*) 'north fold exchanges with explicit point-to-point messaging :' 656 WRITE(inum,*) 'nfsloop : ', nfsloop657 WRITE(inum,*) 'nfeloop : ', nfeloop658 700 WRITE(inum,*) 'nsndto : ', nsndto 659 701 WRITE(inum,*) 'isendto : ', isendto … … 665 707 DEALLOCATE(iin, ijn, ii_nono, ii_noea, ii_noso, ii_nowe, & 666 708 & iimppt, ijmppt, ibondi, ibondj, ipproc, ipolj, & 667 & i lci, ilcj, ilei, ilej, ildi, ildj, &709 & ijpi, ijpj, iie0, ije0, iis0, ijs0, & 668 710 & iono, ioea, ioso, iowe, llisoce) 669 711 ! … … 671 713 672 714 673 SUBROUTINE mpp_bas ic_decomposition(knbi, knbj, kimax, kjmax, kimppt, kjmppt, klci, klcj)674 !!---------------------------------------------------------------------- 675 !! *** ROUTINE mpp_bas ic_decomposition***715 SUBROUTINE mpp_basesplit( kiglo, kjglo, khls, knbi, knbj, kimax, kjmax, kimppt, kjmppt, klci, klcj) 716 !!---------------------------------------------------------------------- 717 !! *** ROUTINE mpp_basesplit *** 676 718 !! 677 719 !! ** Purpose : Lay out the global domain over processors. … … 685 727 !! klcj : second dimension 686 728 !!---------------------------------------------------------------------- 729 INTEGER, INTENT(in ) :: kiglo, kjglo 730 INTEGER, INTENT(in ) :: khls 687 731 INTEGER, INTENT(in ) :: knbi, knbj 688 732 INTEGER, INTENT( out) :: kimax, kjmax … … 691 735 ! 692 736 INTEGER :: ji, jj 737 INTEGER :: i2hls 693 738 INTEGER :: iresti, irestj, irm, ijpjmin 694 INTEGER :: ireci, irecj695 !!----------------------------------------------------------------------739 !!---------------------------------------------------------------------- 740 i2hls = 2*khls 696 741 ! 697 742 #if defined key_nemocice_decomp 698 kimax = ( nx_global+2- 2*nn_hls + (knbi-1) ) / knbi + 2*nn_hls ! first dim.699 kjmax = ( ny_global+2- 2*nn_hls + (knbj-1) ) / knbj + 2*nn_hls ! second dim.743 kimax = ( nx_global+2-i2hls + (knbi-1) ) / knbi + i2hls ! first dim. 744 kjmax = ( ny_global+2-i2hls + (knbj-1) ) / knbj + i2hls ! second dim. 700 745 #else 701 kimax = ( jpiglo - 2*nn_hls + (knbi-1) ) / knbi + 2*nn_hls ! first dim.702 kjmax = ( jpjglo - 2*nn_hls + (knbj-1) ) / knbj + 2*nn_hls ! second dim.746 kimax = ( kiglo - i2hls + (knbi-1) ) / knbi + i2hls ! first dim. 747 kjmax = ( kjglo - i2hls + (knbj-1) ) / knbj + i2hls ! second dim. 703 748 #endif 704 749 IF( .NOT. PRESENT(kimppt) ) RETURN … … 707 752 ! ----------------------------------- 708 753 ! Computation of local domain sizes klci() klcj() 709 ! These dimensions depend on global sizes knbi,knbj and jpiglo,jpjglo754 ! These dimensions depend on global sizes knbi,knbj and kiglo,kjglo 710 755 ! The subdomains are squares lesser than or equal to the global 711 756 ! dimensions divided by the number of processors minus the overlap array. 712 757 ! 713 ireci = 2 * nn_hls 714 irecj = 2 * nn_hls 715 iresti = 1 + MOD( jpiglo - ireci -1 , knbi ) 716 irestj = 1 + MOD( jpjglo - irecj -1 , knbj ) 758 iresti = 1 + MOD( kiglo - i2hls - 1 , knbi ) 759 irestj = 1 + MOD( kjglo - i2hls - 1 , knbj ) 717 760 ! 718 761 ! Need to use kimax and kjmax here since jpi and jpj not yet defined 719 762 #if defined key_nemocice_decomp 720 763 ! Change padding to be consistent with CICE 721 klci(1:knbi-1 ,:) = kimax722 klci( knbi ,:) = jpiglo - (knbi - 1) * (kimax - nreci)723 klcj(: ,1:knbj-1) = kjmax724 klcj(: , knbj) = jpjglo - (knbj - 1) * (kjmax - nrecj)764 klci(1:knbi-1,: ) = kimax 765 klci( knbi ,: ) = kiglo - (knbi - 1) * (kimax - i2hls) 766 klcj(: ,1:knbj-1) = kjmax 767 klcj(: , knbj ) = kjglo - (knbj - 1) * (kjmax - i2hls) 725 768 #else 726 769 klci(1:iresti ,:) = kimax 727 770 klci(iresti+1:knbi ,:) = kimax-1 728 IF( MINVAL(klci) < 3) THEN729 WRITE(ctmp1,*) ' mpp_bas ic_decomposition: minimum value of jpi must be >= 3'771 IF( MINVAL(klci) < 2*i2hls ) THEN 772 WRITE(ctmp1,*) ' mpp_basesplit: minimum value of jpi must be >= ', 2*i2hls 730 773 WRITE(ctmp2,*) ' We have ', MINVAL(klci) 731 774 CALL ctl_stop( 'STOP', ctmp1, ctmp2 ) … … 733 776 IF( jperio == 3 .OR. jperio == 4 .OR. jperio == 5 .OR. jperio == 6 ) THEN 734 777 ! minimize the size of the last row to compensate for the north pole folding coast 735 IF( jperio == 3 .OR. jperio == 4 ) ijpjmin = 5 ! V and F folding involves line jpj-3 that must not be south boundary 736 IF( jperio == 5 .OR. jperio == 6 ) ijpjmin = 4 ! V and F folding involves line jpj-2 that must not be south boundary 737 irm = knbj - irestj ! total number of lines to be removed 738 klcj(:, knbj) = MAX( ijpjmin, kjmax-irm ) ! we must have jpj >= ijpjmin in the last row 739 irm = irm - ( kjmax - klcj(1,knbj) ) ! remaining number of lines to remove 740 irestj = knbj - 1 - irm 741 klcj(:, 1:irestj) = kjmax 778 IF( jperio == 3 .OR. jperio == 4 ) ijpjmin = 2+3*khls ! V and F folding must be outside of southern halos 779 IF( jperio == 5 .OR. jperio == 6 ) ijpjmin = 1+3*khls ! V and F folding must be outside of southern halos 780 irm = knbj - irestj ! total number of lines to be removed 781 klcj(:,knbj) = MAX( ijpjmin, kjmax-irm ) ! we must have jpj >= ijpjmin in the last row 782 irm = irm - ( kjmax - klcj(1,knbj) ) ! remaining number of lines to remove 783 irestj = knbj - 1 - irm 742 784 klcj(:, irestj+1:knbj-1) = kjmax-1 743 785 ELSE 744 ijpjmin = 3 745 klcj(:, 1:irestj) = kjmax 746 klcj(:, irestj+1:knbj) = kjmax-1 747 ENDIF 748 IF( MINVAL(klcj) < ijpjmin ) THEN 749 WRITE(ctmp1,*) ' mpp_basic_decomposition: minimum value of jpj must be >= ', ijpjmin 786 klcj(:, irestj+1:knbj ) = kjmax-1 787 ENDIF 788 klcj(:,1:irestj) = kjmax 789 IF( MINVAL(klcj) < 2*i2hls ) THEN 790 WRITE(ctmp1,*) ' mpp_basesplit: minimum value of jpj must be >= ', 2*i2hls 750 791 WRITE(ctmp2,*) ' We have ', MINVAL(klcj) 751 792 CALL ctl_stop( 'STOP', ctmp1, ctmp2 ) … … 761 802 DO jj = 1, knbj 762 803 DO ji = 2, knbi 763 kimppt(ji,jj) = kimppt(ji-1,jj) + klci(ji-1,jj) - i reci804 kimppt(ji,jj) = kimppt(ji-1,jj) + klci(ji-1,jj) - i2hls 764 805 END DO 765 806 END DO … … 769 810 DO jj = 2, knbj 770 811 DO ji = 1, knbi 771 kjmppt(ji,jj) = kjmppt(ji,jj-1) + klcj(ji,jj-1) - i recj812 kjmppt(ji,jj) = kjmppt(ji,jj-1) + klcj(ji,jj-1) - i2hls 772 813 END DO 773 814 END DO 774 815 ENDIF 775 816 776 END SUBROUTINE mpp_bas ic_decomposition777 778 779 SUBROUTINE mpp_init_bestpartition( knbij, knbi, knbj, knbcnt, ldlist )780 !!---------------------------------------------------------------------- 781 !! *** ROUTINE mpp_init_bestpartition ***817 END SUBROUTINE mpp_basesplit 818 819 820 SUBROUTINE bestpartition( knbij, knbi, knbj, knbcnt, ldlist ) 821 !!---------------------------------------------------------------------- 822 !! *** ROUTINE bestpartition *** 782 823 !! 783 824 !! ** Purpose : … … 794 835 INTEGER :: isziref, iszjref 795 836 INTEGER :: inbij, iszij 796 INTEGER :: inbimax, inbjmax, inbijmax 837 INTEGER :: inbimax, inbjmax, inbijmax, inbijold 797 838 INTEGER :: isz0, isz1 798 839 INTEGER, DIMENSION( :), ALLOCATABLE :: indexok … … 821 862 inbimax = 0 822 863 inbjmax = 0 823 isziref = jpiglo*jpjglo+1824 iszjref = jpiglo*jpjglo+1864 isziref = Ni0glo*Nj0glo+1 865 iszjref = Ni0glo*Nj0glo+1 825 866 ! 826 867 ! get the list of knbi that gives a smaller jpimax than knbi-1 … … 830 871 iszitst = ( nx_global+2-2*nn_hls + (ji-1) ) / ji + 2*nn_hls ! first dim. 831 872 #else 832 iszitst = ( jpiglo - 2*nn_hls + (ji-1) ) / ji + 2*nn_hls873 iszitst = ( Ni0glo + (ji-1) ) / ji 833 874 #endif 834 875 IF( iszitst < isziref ) THEN … … 841 882 iszjtst = ( ny_global+2-2*nn_hls + (ji-1) ) / ji + 2*nn_hls ! first dim. 842 883 #else 843 iszjtst = ( jpjglo - 2*nn_hls + (ji-1) ) / ji + 2*nn_hls884 iszjtst = ( Nj0glo + (ji-1) ) / ji 844 885 #endif 845 886 IF( iszjtst < iszjref ) THEN … … 881 922 iszij1(:) = iszi1(:) * iszj1(:) 882 923 883 ! if ther ris no land and no print884 IF( .NOT. llist .AND. numbot == -1 ) THEN924 ! if there is no land and no print 925 IF( .NOT. llist .AND. numbot == -1 .AND. numbdy == -1 ) THEN 885 926 ! get the smaller partition which gives the smallest subdomain size 886 927 ii = MINLOC(inbij1, mask = iszij1 == MINVAL(iszij1), dim = 1) … … 896 937 isz0 = 0 ! number of best partitions 897 938 inbij = 1 ! start with the min value of inbij1 => 1 898 iszij = jpiglo*jpjglo+1 ! default: larger than global domain939 iszij = Ni0glo*Nj0glo+1 ! default: larger than global domain 899 940 DO WHILE( inbij <= inbijmax ) ! if we did not reach the max of inbij1 900 941 ii = MINLOC(iszij1, mask = inbij1 == inbij, dim = 1) ! warning: send back the first occurence if multiple results … … 919 960 DEALLOCATE( indexok, inbi1, inbj1, iszi1, iszj1 ) 920 961 921 IF( llist ) THEN ! we print about 21 best partitions962 IF( llist ) THEN 922 963 IF(lwp) THEN 923 964 WRITE(numout,*) 924 WRITE(numout, 925 WRITE(numout, '(a,i5,a)') ' list of the best partitions around ', knbij, ' mpi processes'926 WRITE(numout, *) ' --------------------------------------', '-----', '--------------'965 WRITE(numout,*) ' For your information:' 966 WRITE(numout,*) ' list of the best partitions including land supression' 967 WRITE(numout,*) ' -----------------------------------------------------' 927 968 WRITE(numout,*) 928 969 END IF 929 iitarget = MINLOC( inbi0(:)*inbj0(:), mask = inbi0(:)*inbj0(:) >= knbij, dim = 1 ) 930 DO ji = MAX(1,iitarget-10), MIN(isz0,iitarget+10) 970 ji = isz0 ! initialization with the largest value 971 ALLOCATE( llisoce(inbi0(ji), inbj0(ji)) ) 972 CALL mpp_is_ocean( llisoce ) ! Warning: must be call by all cores (call mpp_sum) 973 inbijold = COUNT(llisoce) 974 DEALLOCATE( llisoce ) 975 DO ji =isz0-1,1,-1 931 976 ALLOCATE( llisoce(inbi0(ji), inbj0(ji)) ) 932 CALL mpp_i nit_isoce( inbi0(ji), inbj0(ji), llisoce )! Warning: must be call by all cores (call mpp_sum)977 CALL mpp_is_ocean( llisoce ) ! Warning: must be call by all cores (call mpp_sum) 933 978 inbij = COUNT(llisoce) 934 979 DEALLOCATE( llisoce ) 935 IF(lwp) WRITE(numout,'(a, i5, a, i5, a, i4, a, i4, a, i9, a, i5, a, i5, a)') & 936 & 'nb_cores ' , inbij,' oce + ', inbi0(ji)*inbj0(ji) - inbij & 937 & , ' land ( ', inbi0(ji),' x ', inbj0(ji), & 938 & ' ), nb_points ', iszi0(ji)*iszj0(ji),' ( ', iszi0(ji),' x ', iszj0(ji),' )' 980 IF(lwp .AND. inbij < inbijold) THEN 981 WRITE(numout,'(a, i6, a, i6, a, f4.1, a, i9, a, i6, a, i6, a)') & 982 & 'nb_cores oce: ', inbij, ', land domains excluded: ', inbi0(ji)*inbj0(ji) - inbij, & 983 & ' (', REAL(inbi0(ji)*inbj0(ji) - inbij,wp) / REAL(inbi0(ji)*inbj0(ji),wp) *100., & 984 & '%), largest oce domain: ', iszi0(ji)*iszj0(ji), ' ( ', iszi0(ji),' x ', iszj0(ji), ' )' 985 inbijold = inbij 986 END IF 939 987 END DO 940 988 DEALLOCATE( inbi0, inbj0, iszi0, iszj0 ) 941 RETURN 989 IF(lwp) THEN 990 WRITE(numout,*) 991 WRITE(numout,*) ' -----------------------------------------------------------' 992 ENDIF 993 CALL mppsync 994 CALL mppstop( ld_abort = .TRUE. ) 942 995 ENDIF 943 996 … … 948 1001 ii = ii -1 949 1002 ALLOCATE( llisoce(inbi0(ii), inbj0(ii)) ) 950 CALL mpp_i nit_isoce( inbi0(ii), inbj0(ii),llisoce ) ! must be done by all core1003 CALL mpp_is_ocean( llisoce ) ! must be done by all core 951 1004 inbij = COUNT(llisoce) 952 1005 DEALLOCATE( llisoce ) … … 957 1010 DEALLOCATE( inbi0, inbj0 ) 958 1011 ! 959 END SUBROUTINE mpp_init_bestpartition1012 END SUBROUTINE bestpartition 960 1013 961 1014 … … 966 1019 !! ** Purpose : the the proportion of land points in the surface land-sea mask 967 1020 !! 968 !! ** Method : read iproc strips (of length jpiglo) of the land-sea mask1021 !! ** Method : read iproc strips (of length Ni0glo) of the land-sea mask 969 1022 !!---------------------------------------------------------------------- 970 1023 REAL(wp), INTENT( out) :: propland ! proportion of land points in the global domain (between 0 and 1) … … 977 1030 !!---------------------------------------------------------------------- 978 1031 ! do nothing if there is no land-sea mask 979 IF( numbot == -1 ) THEN1032 IF( numbot == -1 .and. numbdy == -1 ) THEN 980 1033 propland = 0. 981 1034 RETURN … … 983 1036 984 1037 ! number of processes reading the bathymetry file 985 iproc = MINVAL( (/mppsize, jpjglo/2, 100/) ) ! read a least 2 lines, no more that 100 processes reading at the same time1038 iproc = MINVAL( (/mppsize, Nj0glo/2, 100/) ) ! read a least 2 lines, no more that 100 processes reading at the same time 986 1039 987 1040 ! we want to read iproc strips of the land-sea mask. -> pick up iproc processes every idiv processes starting at 1 … … 993 1046 IF( MOD( narea-1, idiv ) == 0 .AND. iarea < iproc ) THEN ! beware idiv can be = to 1 994 1047 ! 995 ijsz = jpjglo / iproc ! width of the stripe to read996 IF( iarea < MOD( jpjglo,iproc) ) ijsz = ijsz + 1997 ijstr = iarea*( jpjglo/iproc) + MIN(iarea, MOD(jpjglo,iproc)) + 1 ! starting j position of the reading998 ! 999 ALLOCATE( lloce( jpiglo, ijsz) ) ! allocate the strip1000 CALL mpp_init_readbot_strip( ijstr, ijsz, lloce )1048 ijsz = Nj0glo / iproc ! width of the stripe to read 1049 IF( iarea < MOD(Nj0glo,iproc) ) ijsz = ijsz + 1 1050 ijstr = iarea*(Nj0glo/iproc) + MIN(iarea, MOD(Nj0glo,iproc)) + 1 ! starting j position of the reading 1051 ! 1052 ALLOCATE( lloce(Ni0glo, ijsz) ) ! allocate the strip 1053 CALL readbot_strip( ijstr, ijsz, lloce ) 1001 1054 inboce = COUNT(lloce) ! number of ocean point in the stripe 1002 1055 DEALLOCATE(lloce) … … 1007 1060 CALL mpp_sum( 'mppini', inboce ) ! total number of ocean points over the global domain 1008 1061 ! 1009 propland = REAL( jpiglo*jpjglo - inboce, wp ) / REAL( jpiglo*jpjglo, wp )1062 propland = REAL( Ni0glo*Nj0glo - inboce, wp ) / REAL( Ni0glo*Nj0glo, wp ) 1010 1063 ! 1011 1064 END SUBROUTINE mpp_init_landprop 1012 1065 1013 1066 1014 SUBROUTINE mpp_init_isoce( knbi, knbj, ldisoce ) 1015 !!---------------------------------------------------------------------- 1016 !! *** ROUTINE mpp_init_nboce *** 1017 !! 1018 !! ** Purpose : check for a mpi domain decomposition knbi x knbj which 1019 !! subdomains contain at least 1 ocean point 1020 !! 1021 !! ** Method : read knbj strips (of length jpiglo) of the land-sea mask 1022 !!---------------------------------------------------------------------- 1023 INTEGER, INTENT(in ) :: knbi, knbj ! domain decomposition 1024 LOGICAL, DIMENSION(knbi,knbj), INTENT( out) :: ldisoce ! .true. if a sub domain constains 1 ocean point 1025 ! 1026 INTEGER, DIMENSION(knbi,knbj) :: inboce ! number oce oce pint in each mpi subdomain 1027 INTEGER, DIMENSION(knbi*knbj) :: inboce_1d 1067 SUBROUTINE mpp_is_ocean( ldisoce ) 1068 !!---------------------------------------------------------------------- 1069 !! *** ROUTINE mpp_is_ocean *** 1070 !! 1071 !! ** Purpose : Check for a mpi domain decomposition inbi x inbj which 1072 !! subdomains, including 1 halo (even if nn_hls>1), contain 1073 !! at least 1 ocean point. 1074 !! We must indeed ensure that each subdomain that is a neighbour 1075 !! of a land subdomain as only land points on its boundary 1076 !! (inside the inner subdomain) with the land subdomain. 1077 !! This is needed to get the proper bondary conditions on 1078 !! a subdomain with a closed boundary. 1079 !! 1080 !! ** Method : read inbj strips (of length Ni0glo) of the land-sea mask 1081 !!---------------------------------------------------------------------- 1082 LOGICAL, DIMENSION(:,:), INTENT( out) :: ldisoce ! .true. if a sub domain constains 1 ocean point 1083 ! 1028 1084 INTEGER :: idiv, iimax, ijmax, iarea 1085 INTEGER :: inbi, inbj, inx, iny, inry, isty 1029 1086 INTEGER :: ji, jn 1030 LOGICAL, ALLOCATABLE, DIMENSION(:,:) :: lloce ! lloce(i,j) = .true. if the point (i,j) is ocean 1031 INTEGER, ALLOCATABLE, DIMENSION(:,:) :: iimppt, ilci 1032 INTEGER, ALLOCATABLE, DIMENSION(:,:) :: ijmppt, ilcj 1087 INTEGER, ALLOCATABLE, DIMENSION(:,:) :: inboce ! number oce oce pint in each mpi subdomain 1088 INTEGER, ALLOCATABLE, DIMENSION(: ) :: inboce_1d 1089 INTEGER, ALLOCATABLE, DIMENSION(:,:) :: iimppt, ijpi 1090 INTEGER, ALLOCATABLE, DIMENSION(:,:) :: ijmppt, ijpj 1091 LOGICAL, ALLOCATABLE, DIMENSION(:,:) :: lloce ! lloce(i,j) = .true. if the point (i,j) is ocean 1033 1092 !!---------------------------------------------------------------------- 1034 1093 ! do nothing if there is no land-sea mask 1035 IF( numbot == -1 ) THEN1094 IF( numbot == -1 .AND. numbdy == -1 ) THEN 1036 1095 ldisoce(:,:) = .TRUE. 1037 1096 RETURN 1038 1097 ENDIF 1039 1040 ! we want to read knbj strips of the land-sea mask. -> pick up knbj processes every idiv processes starting at 1 1041 IF ( knbj == 1 ) THEN ; idiv = mppsize 1042 ELSE IF ( mppsize < knbj ) THEN ; idiv = 1 1043 ELSE ; idiv = ( mppsize - 1 ) / ( knbj - 1 ) 1044 ENDIF 1098 ! 1099 inbi = SIZE( ldisoce, dim = 1 ) 1100 inbj = SIZE( ldisoce, dim = 2 ) 1101 ! 1102 ! we want to read inbj strips of the land-sea mask. -> pick up inbj processes every idiv processes starting at 1 1103 IF ( inbj == 1 ) THEN ; idiv = mppsize 1104 ELSE IF ( mppsize < inbj ) THEN ; idiv = 1 1105 ELSE ; idiv = ( mppsize - 1 ) / ( inbj - 1 ) 1106 ENDIF 1107 ! 1108 ALLOCATE( inboce(inbi,inbj), inboce_1d(inbi*inbj) ) 1045 1109 inboce(:,:) = 0 ! default no ocean point found 1046 1047 DO jn = 0, ( knbj-1)/mppsize ! if mppsize < knbj : more strips than mpi processes (because of potential land domains)1048 ! 1049 iarea = (narea-1)/idiv + jn * mppsize ! involed process number (starting counting at 0)1050 IF( MOD( narea-1, idiv ) == 0 .AND. iarea < knbj ) THEN! beware idiv can be = to 11110 ! 1111 DO jn = 0, (inbj-1)/mppsize ! if mppsize < inbj : more strips than mpi processes (because of potential land domains) 1112 ! 1113 iarea = (narea-1)/idiv + jn * mppsize + 1 ! involed process number (starting counting at 1) 1114 IF( MOD( narea-1, idiv ) == 0 .AND. iarea <= inbj ) THEN ! beware idiv can be = to 1 1051 1115 ! 1052 ALLOCATE( iimppt( knbi,knbj), ijmppt(knbi,knbj), ilci(knbi,knbj), ilcj(knbi,knbj) )1053 CALL mpp_bas ic_decomposition( knbi, knbj, iimax, ijmax, iimppt, ijmppt, ilci, ilcj )1116 ALLOCATE( iimppt(inbi,inbj), ijmppt(inbi,inbj), ijpi(inbi,inbj), ijpj(inbi,inbj) ) 1117 CALL mpp_basesplit( Ni0glo, Nj0glo, 0, inbi, inbj, iimax, ijmax, iimppt, ijmppt, ijpi, ijpj ) 1054 1118 ! 1055 ALLOCATE( lloce(jpiglo, ilcj(1,iarea+1)) ) ! allocate the strip 1056 CALL mpp_init_readbot_strip( ijmppt(1,iarea+1), ilcj(1,iarea+1), lloce ) ! read the strip 1057 DO ji = 1, knbi 1058 inboce(ji,iarea+1) = COUNT( lloce(iimppt(ji,1):iimppt(ji,1)+ilci(ji,1)-1,:) ) ! number of ocean point in subdomain 1119 inx = Ni0glo + 2 ; iny = ijpj(1,iarea) + 2 ! strip size + 1 halo on each direction (even if nn_hls>1) 1120 ALLOCATE( lloce(inx, iny) ) ! allocate the strip 1121 inry = iny - COUNT( (/ iarea == 1, iarea == inbj /) ) ! number of point to read in y-direction 1122 isty = 1 + COUNT( (/ iarea == 1 /) ) ! read from the first or the second line? 1123 CALL readbot_strip( ijmppt(1,iarea) - 2 + isty, inry, lloce(2:inx-1, isty:inry+isty-1) ) ! read the strip 1124 ! 1125 IF( iarea == 1 ) THEN ! the first line was not read 1126 IF( jperio == 2 .OR. jperio == 7 ) THEN ! north-south periodocity 1127 CALL readbot_strip( Nj0glo, 1, lloce(2:inx-1, 1) ) ! read the last line -> first line of lloce 1128 ELSE 1129 lloce(2:inx-1, 1) = .FALSE. ! closed boundary 1130 ENDIF 1131 ENDIF 1132 IF( iarea == inbj ) THEN ! the last line was not read 1133 IF( jperio == 2 .OR. jperio == 7 ) THEN ! north-south periodocity 1134 CALL readbot_strip( 1, 1, lloce(2:inx-1,iny) ) ! read the first line -> last line of lloce 1135 ELSEIF( jperio == 3 .OR. jperio == 4 ) THEN ! north-pole folding T-pivot, T-point 1136 lloce(2,iny) = lloce(2,iny-2) ! here we have 1 halo (even if nn_hls>1) 1137 DO ji = 3,inx-1 1138 lloce(ji,iny ) = lloce(inx-ji+2,iny-2) ! ok, we have at least 3 lines 1139 END DO 1140 DO ji = inx/2+2,inx-1 1141 lloce(ji,iny-1) = lloce(inx-ji+2,iny-1) 1142 END DO 1143 ELSEIF( jperio == 5 .OR. jperio == 6 ) THEN ! north-pole folding F-pivot, T-point, 1 halo 1144 lloce(inx/2+1,iny-1) = lloce(inx/2,iny-1) ! here we have 1 halo (even if nn_hls>1) 1145 lloce(inx -1,iny-1) = lloce(2 ,iny-1) 1146 DO ji = 2,inx-1 1147 lloce(ji,iny) = lloce(inx-ji+1,iny-1) 1148 END DO 1149 ELSE ! closed boundary 1150 lloce(2:inx-1,iny) = .FALSE. 1151 ENDIF 1152 ENDIF 1153 ! ! first and last column were not read 1154 IF( jperio == 1 .OR. jperio == 4 .OR. jperio == 6 .OR. jperio == 7 ) THEN 1155 lloce(1,:) = lloce(inx-1,:) ; lloce(inx,:) = lloce(2,:) ! east-west periodocity 1156 ELSE 1157 lloce(1,:) = .FALSE. ; lloce(inx,:) = .FALSE. ! closed boundary 1158 ENDIF 1159 ! 1160 DO ji = 1, inbi 1161 inboce(ji,iarea) = COUNT( lloce(iimppt(ji,1):iimppt(ji,1)+ijpi(ji,1)+1,:) ) ! lloce as 2 points more than Ni0glo 1059 1162 END DO 1060 1163 ! 1061 1164 DEALLOCATE(lloce) 1062 DEALLOCATE(iimppt, ijmppt, i lci, ilcj)1165 DEALLOCATE(iimppt, ijmppt, ijpi, ijpj) 1063 1166 ! 1064 1167 ENDIF 1065 1168 END DO 1066 1169 1067 inboce_1d = RESHAPE(inboce, (/ knbi*knbj /))1170 inboce_1d = RESHAPE(inboce, (/ inbi*inbj /)) 1068 1171 CALL mpp_sum( 'mppini', inboce_1d ) 1069 inboce = RESHAPE(inboce_1d, (/ knbi, knbj/))1172 inboce = RESHAPE(inboce_1d, (/inbi, inbj/)) 1070 1173 ldisoce(:,:) = inboce(:,:) /= 0 1071 ! 1072 END SUBROUTINE mpp_init_isoce 1174 DEALLOCATE(inboce, inboce_1d) 1175 ! 1176 END SUBROUTINE mpp_is_ocean 1073 1177 1074 1178 1075 SUBROUTINE mpp_init_readbot_strip( kjstr, kjcnt, ldoce )1076 !!---------------------------------------------------------------------- 1077 !! *** ROUTINE mpp_init_readbot_strip ***1179 SUBROUTINE readbot_strip( kjstr, kjcnt, ldoce ) 1180 !!---------------------------------------------------------------------- 1181 !! *** ROUTINE readbot_strip *** 1078 1182 !! 1079 1183 !! ** Purpose : Read relevant bathymetric information in order to … … 1081 1185 !! of land domains, in an mpp computation. 1082 1186 !! 1083 !! ** Method : read stipe of size ( jpiglo,...)1084 !!---------------------------------------------------------------------- 1085 INTEGER , INTENT(in ) :: kjstr ! starting j position of the reading1086 INTEGER , INTENT(in ) :: kjcnt ! number of lines to read1087 LOGICAL, DIMENSION( jpiglo,kjcnt), INTENT( out) ::ldoce ! ldoce(i,j) = .true. if the point (i,j) is ocean1187 !! ** Method : read stipe of size (Ni0glo,...) 1188 !!---------------------------------------------------------------------- 1189 INTEGER , INTENT(in ) :: kjstr ! starting j position of the reading 1190 INTEGER , INTENT(in ) :: kjcnt ! number of lines to read 1191 LOGICAL, DIMENSION(Ni0glo,kjcnt), INTENT( out) :: ldoce ! ldoce(i,j) = .true. if the point (i,j) is ocean 1088 1192 ! 1089 1193 INTEGER :: inumsave ! local logical unit 1090 REAL(wp), DIMENSION( jpiglo,kjcnt) :: zbot1194 REAL(wp), DIMENSION(Ni0glo,kjcnt) :: zbot, zbdy 1091 1195 !!---------------------------------------------------------------------- 1092 1196 ! 1093 1197 inumsave = numout ; numout = numnul ! redirect all print to /dev/null 1094 1198 ! 1095 IF( numbot /= -1 ) THEN 1096 CALL iom_get( numbot, jpdom_unknown, 'bottom_level', zbot, kstart = (/1,kjstr/), kcount = (/ jpiglo, kjcnt/) )1199 IF( numbot /= -1 ) THEN 1200 CALL iom_get( numbot, jpdom_unknown, 'bottom_level', zbot, kstart = (/1,kjstr/), kcount = (/Ni0glo, kjcnt/) ) 1097 1201 ELSE 1098 zbot(:,:) = 1. ! put a non-null value 1099 ENDIF 1100 1101 ! 1102 ldoce(:,:) = zbot(:,:) > 0. 1202 zbot(:,:) = 1._wp ! put a non-null value 1203 ENDIF 1204 ! 1205 IF( numbdy /= -1 ) THEN ! Adjust with bdy_msk if it exists 1206 CALL iom_get ( numbdy, jpdom_unknown, 'bdy_msk', zbdy, kstart = (/1,kjstr/), kcount = (/Ni0glo, kjcnt/) ) 1207 zbot(:,:) = zbot(:,:) * zbdy(:,:) 1208 ENDIF 1209 ! 1210 ldoce(:,:) = zbot(:,:) > 0._wp 1103 1211 numout = inumsave 1104 1212 ! 1105 END SUBROUTINE mpp_init_readbot_strip 1106 1107 SUBROUTINE mpp_init_nfdcom 1108 !!---------------------------------------------------------------------- 1109 !! *** ROUTINE mpp_init_nfdcom *** 1213 END SUBROUTINE readbot_strip 1214 1215 1216 SUBROUTINE mpp_getnum( ldisoce, kproc, kipos, kjpos ) 1217 !!---------------------------------------------------------------------- 1218 !! *** ROUTINE mpp_getnum *** 1219 !! 1220 !! ** Purpose : give a number to each MPI subdomains (starting at 0) 1221 !! 1222 !! ** Method : start from bottom left. First skip land subdomain, and finally use them if needed 1223 !!---------------------------------------------------------------------- 1224 LOGICAL, DIMENSION(:,:), INTENT(in ) :: ldisoce ! F if land process 1225 INTEGER, DIMENSION(:,:), INTENT( out) :: kproc ! subdomain number (-1 if supressed, starting at 0) 1226 INTEGER, DIMENSION( :), INTENT( out) :: kipos ! i-position of the subdomain (from 1 to jpni) 1227 INTEGER, DIMENSION( :), INTENT( out) :: kjpos ! j-position of the subdomain (from 1 to jpnj) 1228 ! 1229 INTEGER :: ii, ij, jarea, iarea0 1230 INTEGER :: icont, i2add , ini, inj, inij 1231 !!---------------------------------------------------------------------- 1232 ! 1233 ini = SIZE(ldisoce, dim = 1) 1234 inj = SIZE(ldisoce, dim = 2) 1235 inij = SIZE(kipos) 1236 ! 1237 ! specify which subdomains are oce subdomains; other are land subdomains 1238 kproc(:,:) = -1 1239 icont = -1 1240 DO jarea = 1, ini*inj 1241 iarea0 = jarea - 1 1242 ii = 1 + MOD(iarea0,ini) 1243 ij = 1 + iarea0/ini 1244 IF( ldisoce(ii,ij) ) THEN 1245 icont = icont + 1 1246 kproc(ii,ij) = icont 1247 kipos(icont+1) = ii 1248 kjpos(icont+1) = ij 1249 ENDIF 1250 END DO 1251 ! if needed add some land subdomains to reach inij active subdomains 1252 i2add = inij - COUNT( ldisoce ) 1253 DO jarea = 1, ini*inj 1254 iarea0 = jarea - 1 1255 ii = 1 + MOD(iarea0,ini) 1256 ij = 1 + iarea0/ini 1257 IF( .NOT. ldisoce(ii,ij) .AND. i2add > 0 ) THEN 1258 icont = icont + 1 1259 kproc(ii,ij) = icont 1260 kipos(icont+1) = ii 1261 kjpos(icont+1) = ij 1262 i2add = i2add - 1 1263 ENDIF 1264 END DO 1265 ! 1266 END SUBROUTINE mpp_getnum 1267 1268 1269 SUBROUTINE init_ioipsl 1270 !!---------------------------------------------------------------------- 1271 !! *** ROUTINE init_ioipsl *** 1272 !! 1273 !! ** Purpose : 1274 !! 1275 !! ** Method : 1276 !! 1277 !! History : 1278 !! 9.0 ! 04-03 (G. Madec ) MPP-IOIPSL 1279 !! " " ! 08-12 (A. Coward) addition in case of jpni*jpnj < jpnij 1280 !!---------------------------------------------------------------------- 1281 INTEGER, DIMENSION(2) :: iglo, iloc, iabsf, iabsl, ihals, ihale, idid 1282 !!---------------------------------------------------------------------- 1283 1284 ! The domain is split only horizontally along i- or/and j- direction 1285 ! So we need at the most only 1D arrays with 2 elements. 1286 ! Set idompar values equivalent to the jpdom_local_noextra definition 1287 ! used in IOM. This works even if jpnij .ne. jpni*jpnj. 1288 iglo( :) = (/ Ni0glo, Nj0glo /) 1289 iloc( :) = (/ Ni_0 , Nj_0 /) 1290 iabsf(:) = (/ Nis0 , Njs0 /) + (/ nimpp, njmpp /) - 1 - nn_hls ! corresponds to mig0(Nis0) but mig0 is not yet defined! 1291 iabsl(:) = iabsf(:) + iloc(:) - 1 1292 ihals(:) = (/ 0 , 0 /) 1293 ihale(:) = (/ 0 , 0 /) 1294 idid( :) = (/ 1 , 2 /) 1295 1296 IF(lwp) THEN 1297 WRITE(numout,*) 1298 WRITE(numout,*) 'mpp init_ioipsl : iloc = ', iloc 1299 WRITE(numout,*) '~~~~~~~~~~~~~~~ iabsf = ', iabsf 1300 WRITE(numout,*) ' ihals = ', ihals 1301 WRITE(numout,*) ' ihale = ', ihale 1302 ENDIF 1303 ! 1304 CALL flio_dom_set ( jpnij, nproc, idid, iglo, iloc, iabsf, iabsl, ihals, ihale, 'BOX', nidom) 1305 ! 1306 END SUBROUTINE init_ioipsl 1307 1308 1309 SUBROUTINE init_nfdcom 1310 !!---------------------------------------------------------------------- 1311 !! *** ROUTINE init_nfdcom *** 1110 1312 !! ** Purpose : Setup for north fold exchanges with explicit 1111 1313 !! point-to-point messaging … … 1117 1319 !!---------------------------------------------------------------------- 1118 1320 INTEGER :: sxM, dxM, sxT, dxT, jn 1119 INTEGER :: njmppmax 1120 !!---------------------------------------------------------------------- 1121 ! 1122 njmppmax = MAXVAL( njmppt ) 1321 !!---------------------------------------------------------------------- 1123 1322 ! 1124 1323 !initializes the north-fold communication variables … … 1126 1325 nsndto = 0 1127 1326 ! 1128 IF ( njmpp == njmppmax) THEN ! if I am a process in the north1327 IF ( njmpp == MAXVAL( njmppt ) ) THEN ! if I am a process in the north 1129 1328 ! 1130 1329 !sxM is the first point (in the global domain) needed to compute the north-fold for the current process 1131 sxM = jpiglo - nimppt(narea) - nlcit(narea) + 11330 sxM = jpiglo - nimppt(narea) - jpiall(narea) + 1 1132 1331 !dxM is the last point (in the global domain) needed to compute the north-fold for the current process 1133 1332 dxM = jpiglo - nimppt(narea) + 2 … … 1138 1337 DO jn = 1, jpni 1139 1338 ! 1140 sxT = nfi impp(jn, jpnj)! sxT = 1st point (in the global domain) of the jn process1141 dxT = nfi impp(jn, jpnj) + nfilcit(jn, jpnj) - 1 ! dxT = last point (in the global domain) of the jn process1339 sxT = nfimpp(jn) ! sxT = 1st point (in the global domain) of the jn process 1340 dxT = nfimpp(jn) + nfjpi(jn) - 1 ! dxT = last point (in the global domain) of the jn process 1142 1341 ! 1143 1342 IF ( sxT < sxM .AND. sxM < dxT ) THEN … … 1153 1352 ! 1154 1353 END DO 1155 nfsloop = 11156 nfeloop = nlci1157 DO jn = 2,jpni-11158 IF( nfipproc(jn,jpnj) == (narea - 1) ) THEN1159 IF( nfipproc(jn-1,jpnj) == -1 ) nfsloop = nldi1160 IF( nfipproc(jn+1,jpnj) == -1 ) nfeloop = nlei1161 ENDIF1162 END DO1163 1354 ! 1164 1355 ENDIF 1165 1356 l_north_nogather = .TRUE. 1166 1357 ! 1167 END SUBROUTINE mpp_init_nfdcom 1168 1358 END SUBROUTINE init_nfdcom 1169 1359 1170 1360 #endif 1171 1361 1362 SUBROUTINE init_doloop 1363 !!---------------------------------------------------------------------- 1364 !! *** ROUTINE init_doloop *** 1365 !! 1366 !! ** Purpose : set the starting/ending indices of DO-loop 1367 !! These indices are used in do_loop_substitute.h90 1368 !!---------------------------------------------------------------------- 1369 ! 1370 Nis0 = 1+nn_hls ; Nis1 = Nis0-1 ; Nis2 = MAX( 1, Nis0-2) 1371 Njs0 = 1+nn_hls ; Njs1 = Njs0-1 ; Njs2 = MAX( 1, Njs0-2) 1372 ! 1373 Nie0 = jpi-nn_hls ; Nie1 = Nie0+1 ; Nie2 = MIN(jpi, Nie0+2) 1374 Nje0 = jpj-nn_hls ; Nje1 = Nje0+1 ; Nje2 = MIN(jpj, Nje0+2) 1375 ! 1376 IF( nn_hls == 1 ) THEN !* halo size of 1 1377 ! 1378 Nis1nxt2 = Nis0 ; Njs1nxt2 = Njs0 1379 Nie1nxt2 = Nie0 ; Nje1nxt2 = Nje0 1380 ! 1381 ELSE !* larger halo size... 1382 ! 1383 Nis1nxt2 = Nis1 ; Njs1nxt2 = Njs1 1384 Nie1nxt2 = Nie1 ; Nje1nxt2 = Nje1 1385 ! 1386 ENDIF 1387 ! 1388 Ni_0 = Nie0 - Nis0 + 1 1389 Nj_0 = Nje0 - Njs0 + 1 1390 Ni_1 = Nie1 - Nis1 + 1 1391 Nj_1 = Nje1 - Njs1 + 1 1392 Ni_2 = Nie2 - Nis2 + 1 1393 Nj_2 = Nje2 - Njs2 + 1 1394 ! 1395 END SUBROUTINE init_doloop 1396 1172 1397 !!====================================================================== 1173 1398 END MODULE mppini
Note: See TracChangeset
for help on using the changeset viewer.
