Changeset 8811
 Timestamp:
 20171124T17:22:26+01:00 (6 years ago)
 Location:
 branches/2017/dev_r8126_ROBUST08_no_ghost/NEMOGCM/NEMO/OPA_SRC/LBC
 Files:

 1 added
 3 edited
Legend:
 Unmodified
 Added
 Removed

branches/2017/dev_r8126_ROBUST08_no_ghost/NEMOGCM/NEMO/OPA_SRC/LBC/lbclnk.F90
r8186 r8811 21 21 !! 22 22 !! lbc_lnk : generic interface for mpp_lnk_3d and mpp_lnk_2d routines defined in lib_mpp 23 !! lbc_lnk_e : generic interface for mpp_lnk_2d_e routine defined in lib_mpp24 23 !! lbc_bdy_lnk : generic interface for mpp_lnk_bdy_2d and mpp_lnk_bdy_3d routines defined in lib_mpp 25 24 !! … … 42 41 END INTERFACE 43 42 ! 44 INTERFACE lbc_lnk_e45 MODULE PROCEDURE mpp_lnk_2d_e46 END INTERFACE47 !48 43 INTERFACE lbc_lnk_icb 49 44 MODULE PROCEDURE mpp_lnk_2d_icb … … 52 47 PUBLIC lbc_lnk ! ocean/ice lateral boundary conditions 53 48 PUBLIC lbc_lnk_multi ! modified ocean/ice lateral boundary conditions 54 PUBLIC lbc_lnk_e ! extended ocean/ice lateral boundary conditions55 49 PUBLIC lbc_bdy_lnk ! ocean lateral BDY boundary conditions 56 50 PUBLIC lbc_lnk_icb ! iceberg lateral boundary conditions … … 95 89 END INTERFACE 96 90 ! 97 INTERFACE lbc_lnk_e98 MODULE PROCEDURE lbc_lnk_2d_e99 END INTERFACE100 !101 91 INTERFACE lbc_bdy_lnk 102 92 MODULE PROCEDURE lbc_bdy_lnk_2d, lbc_bdy_lnk_3d … … 104 94 ! 105 95 INTERFACE lbc_lnk_icb 106 MODULE PROCEDURE lbc_lnk_2d_ e96 MODULE PROCEDURE lbc_lnk_2d_icb 107 97 END INTERFACE 108 98 109 99 PUBLIC lbc_lnk ! ocean/ice lateral boundary conditions 110 PUBLIC lbc_lnk_e ! extended ocean/ice lateral boundary conditions111 100 PUBLIC lbc_lnk_multi ! modified ocean/ice lateral boundary conditions 112 101 PUBLIC lbc_bdy_lnk ! ocean lateral BDY boundary conditions … … 270 259 271 260 272 !!gm This routine should be remove with an optional halos size added in orgument of generic routines273 274 SUBROUTINE lbc_lnk_2d_ e( pt2d, cd_type, psgn, ki, kj )261 !!gm This routine should be removed with an optional halos size added in argument of generic routines 262 263 SUBROUTINE lbc_lnk_2d_icb( pt2d, cd_type, psgn, ki, kj ) 275 264 !! 276 265 REAL(wp), DIMENSION(:,:), INTENT(inout) :: pt2d ! 2D array on which the lbc is applied … … 280 269 !! 281 270 CALL lbc_lnk_2d( pt2d, cd_type, psgn ) 282 END SUBROUTINE lbc_lnk_2d_ e271 END SUBROUTINE lbc_lnk_2d_icb 283 272 !!gm end 284 273 
branches/2017/dev_r8126_ROBUST08_no_ghost/NEMOGCM/NEMO/OPA_SRC/LBC/lbcnfd.F90
r8196 r8811 27 27 MODULE PROCEDURE lbc_nfd_2d , lbc_nfd_3d , lbc_nfd_4d 28 28 MODULE PROCEDURE lbc_nfd_2d_ptr, lbc_nfd_3d_ptr, lbc_nfd_4d_ptr 29 MODULE PROCEDURE lbc_nfd_2d_ext 29 30 END INTERFACE 30 31 ! … … 84 85 # undef ROUTINE_NFD 85 86 # undef MULTI 87 # undef DIM_2d 88 ! 89 ! !== 2D array with extra haloes ==! 90 ! 91 # define DIM_2d 92 # define ROUTINE_NFD lbc_nfd_2d_ext 93 # include "lbc_nfd_ext_generic.h90" 94 # undef ROUTINE_NFD 86 95 # undef DIM_2d 87 96 ! … … 156 165 157 166 158 !!gm CAUTION HERE optional pr2dj not implemented in generic case159 !!gm furthermore, in the _org routine it is OK only for Tpoint pivot !!160 161 162 SUBROUTINE lbc_nfd_2d_org( pt2d, cd_nat, psgn, pr2dj )163 !!164 !! *** routine lbc_nfd_2d ***165 !!166 !! ** Purpose : 2D lateral boundary condition : North fold treatment167 !! without processor exchanges.168 !!169 !! ** Method :170 !!171 !! ** Action : pt2d with updated values along the north fold172 !!173 REAL(wp), DIMENSION(:,:), INTENT(inout) :: pt2d ! 2D array on which the boundary condition is applied174 CHARACTER(len=1) , INTENT(in ) :: cd_nat ! nature of pt2d gridpoint175 REAL(wp) , INTENT(in ) :: psgn ! sign used across north fold176 INTEGER , OPTIONAL , INTENT(in ) :: pr2dj ! number of additional halos177 !178 INTEGER :: ji, jl, ipr2dj179 INTEGER :: ijt, iju, ijpj, ijpjm1180 !!181 182 SELECT CASE ( jpni )183 CASE ( 1 ) ; ijpj = nlcj ! 1 proc only along the idirection184 CASE DEFAULT ; ijpj = 4 ! several proc along the idirection185 END SELECT186 !187 IF( PRESENT(pr2dj) ) THEN ! use of additional halos188 ipr2dj = pr2dj189 IF( jpni > 1 ) ijpj = ijpj + ipr2dj190 ELSE191 ipr2dj = 0192 ENDIF193 !194 ijpjm1 = ijpj1195 196 197 SELECT CASE ( npolj )198 !199 CASE ( 3, 4 ) ! * North fold Tpoint pivot200 !201 SELECT CASE ( cd_nat )202 !203 CASE ( 'T' , 'W' ) ! T , Wpoints204 DO jl = 0, ipr2dj205 DO ji = 2, jpiglo206 ijt=jpigloji+2207 pt2d(ji,ijpj+jl) = psgn * pt2d(ijt,ijpj2jl)208 END DO209 END DO210 pt2d(1,ijpj) = psgn * pt2d(3,ijpj2)211 DO ji = jpiglo/2+1, jpiglo212 ijt=jpigloji+2213 pt2d(ji,ijpj1) = psgn * pt2d(ijt,ijpj1)214 END DO215 CASE ( 'U' ) ! Upoint216 DO jl = 0, ipr2dj217 DO ji = 1, jpiglo1218 iju = jpigloji+1219 pt2d(ji,ijpj+jl) = psgn * pt2d(iju,ijpj2jl)220 END DO221 END DO222 pt2d( 1 ,ijpj ) = psgn * pt2d( 2 ,ijpj2)223 pt2d(jpiglo,ijpj ) = psgn * pt2d(jpiglo1,ijpj2)224 pt2d(1 ,ijpj1) = psgn * pt2d(jpiglo ,ijpj1)225 DO ji = jpiglo/2, jpiglo1226 iju = jpigloji+1227 pt2d(ji,ijpjm1) = psgn * pt2d(iju,ijpjm1)228 END DO229 CASE ( 'V' ) ! Vpoint230 DO jl = 1, ipr2dj231 DO ji = 2, jpiglo232 ijt = jpigloji+2233 pt2d(ji,ijpj+jl) = psgn * pt2d(ijt,ijpj3jl)234 END DO235 END DO236 pt2d( 1 ,ijpj) = psgn * pt2d( 3 ,ijpj3)237 CASE ( 'F' ) ! Fpoint238 DO jl = 1, ipr2dj239 DO ji = 1, jpiglo1240 iju = jpigloji+1241 pt2d(ji,ijpj+jl) = psgn * pt2d(iju,ijpj3jl)242 END DO243 END DO244 pt2d( 1 ,ijpj) = psgn * pt2d( 2 ,ijpj3)245 pt2d(jpiglo,ijpj) = psgn * pt2d(jpiglo1,ijpj3)246 pt2d(jpiglo,ijpj1) = psgn * pt2d(jpiglo1,ijpj2)247 pt2d( 1 ,ijpj1) = psgn * pt2d( 2 ,ijpj2)248 CASE ( 'I' ) ! ice UV point (Ipoint)249 DO jl = 0, ipr2dj250 pt2d(2,ijpj+jl) = psgn * pt2d(3,ijpj1+jl)251 DO ji = 3, jpiglo252 iju = jpiglo  ji + 3253 pt2d(ji,ijpj+jl) = psgn * pt2d(iju,ijpj1jl)254 END DO255 END DO256 END SELECT257 !258 CASE ( 5, 6 ) ! * North fold Fpoint pivot259 !260 SELECT CASE ( cd_nat )261 CASE ( 'T' , 'W' ) ! T, Wpoint262 DO jl = 0, ipr2dj263 DO ji = 1, jpiglo264 ijt = jpigloji+1265 pt2d(ji,ijpj+jl) = psgn * pt2d(ijt,ijpj1jl)266 END DO267 END DO268 CASE ( 'U' ) ! Upoint269 DO jl = 0, ipr2dj270 DO ji = 1, jpiglo1271 iju = jpigloji272 pt2d(ji,ijpj+jl) = psgn * pt2d(iju,ijpj1jl)273 END DO274 END DO275 pt2d(jpiglo,ijpj) = psgn * pt2d(1,ijpj1)276 CASE ( 'V' ) ! Vpoint277 DO jl = 0, ipr2dj278 DO ji = 1, jpiglo279 ijt = jpigloji+1280 pt2d(ji,ijpj+jl) = psgn * pt2d(ijt,ijpj2jl)281 END DO282 END DO283 DO ji = jpiglo/2+1, jpiglo284 ijt = jpigloji+1285 pt2d(ji,ijpjm1) = psgn * pt2d(ijt,ijpjm1)286 END DO287 CASE ( 'F' ) ! Fpoint288 DO jl = 0, ipr2dj289 DO ji = 1, jpiglo1290 iju = jpigloji291 pt2d(ji,ijpj+jl) = psgn * pt2d(iju,ijpj2jl)292 END DO293 END DO294 pt2d(jpiglo,ijpj) = psgn * pt2d(1,ijpj2)295 DO ji = jpiglo/2+1, jpiglo1296 iju = jpigloji297 pt2d(ji,ijpjm1) = psgn * pt2d(iju,ijpjm1)298 END DO299 CASE ( 'I' ) ! ice UV point (Ipoint)300 pt2d( 2 ,ijpj:ijpj+ipr2dj) = 0._wp301 DO jl = 0, ipr2dj302 DO ji = 2 , jpiglo1303 ijt = jpiglo  ji + 2304 pt2d(ji,ijpj+jl)= 0.5 * ( pt2d(ji,ijpj1jl) + psgn * pt2d(ijt,ijpj1jl) )305 END DO306 END DO307 END SELECT308 !309 CASE DEFAULT ! * closed : the code probably never go through310 !311 SELECT CASE ( cd_nat)312 CASE ( 'T' , 'U' , 'V' , 'W' ) ! T, U, V, Wpoints313 pt2d(:, 1:1ipr2dj ) = 0._wp314 pt2d(:,ijpj:ijpj+ipr2dj) = 0._wp315 CASE ( 'F' ) ! Fpoint316 pt2d(:,ijpj:ijpj+ipr2dj) = 0._wp317 CASE ( 'I' ) ! ice UV point318 pt2d(:, 1:1ipr2dj ) = 0._wp319 pt2d(:,ijpj:ijpj+ipr2dj) = 0._wp320 END SELECT321 !322 END SELECT323 !324 END SUBROUTINE lbc_nfd_2d_org325 326 167 !!====================================================================== 327 168 END MODULE lbcnfd 
branches/2017/dev_r8126_ROBUST08_no_ghost/NEMOGCM/NEMO/OPA_SRC/LBC/lib_mpp.F90
r8809 r8811 41 41 !! mynode : indentify the processor unit 42 42 !! mpp_lnk : interface (defined in lbclnk) for message passing of 2d or 3d arrays (mpp_lnk_2d, mpp_lnk_3d) 43 !! mpp_lnk_e : interface (defined in lbclnk) for message passing of 2d array with extra halo (mpp_lnk_2d_e)44 43 !! mpp_lnk_icb : interface for message passing of 2d arrays with extra halo for icebergs (mpp_lnk_2d_icb) 45 44 !! mpprecv : … … 55 54 !! mppstop : 56 55 !! mpp_ini_north : initialisation of north fold 57 !!gm !! mpp_lbc_north : north fold processors gathering 58 !! mpp_lbc_north_e : variant of mpp_lbc_north for extra outer halo 59 !! mpp_lbc_north_icb : variant of mpp_lbc_north for extra outer halo with icebergs 56 !! mpp_lbc_north_icb : alternative to mpp_nfd for extra outer halo with icebergs 60 57 !! 61 58 USE dom_oce ! ocean space and time domain … … 75 72 PUBLIC mpp_lnk_2d , mpp_lnk_3d , mpp_lnk_4d 76 73 PUBLIC mpp_lnk_2d_ptr, mpp_lnk_3d_ptr, mpp_lnk_4d_ptr 77 PUBLIC mpp_lnk_2d_e78 74 ! 79 75 !!gm this should be useless … … 84 80 PUBLIC ctl_stop, ctl_warn, get_unit, ctl_opn, ctl_nam 85 81 PUBLIC mynode, mppstop, mppsync, mpp_comm_free 86 PUBLIC mpp_ini_north , mpp_lbc_north_e87 !!gm PUBLIC mpp_ini_north, mpp_lbc_north, mpp_lbc_north_e 88 PUBLIC mpp_lbc_north_icb , mpp_lnk_2d_icb82 PUBLIC mpp_ini_north 83 PUBLIC mpp_lnk_2d_icb 84 PUBLIC mpp_lbc_north_icb 89 85 PUBLIC mpp_min, mpp_max, mpp_sum, mpp_minloc, mpp_maxloc 90 86 PUBLIC mpp_max_multiple 91 !!gm PUBLIC mpp_lnk_2d_992 !!gm PUBLIC mpp_lnk_sum_3d, mpp_lnk_sum_2d93 87 PUBLIC mppscatter, mppgather 94 88 PUBLIC mpp_ini_ice, mpp_ini_znl … … 112 106 & mppsum_realdd, mppsum_a_realdd 113 107 END INTERFACE 114 !!gm INTERFACE mpp_lbc_north115 !!gm MODULE PROCEDURE mpp_lbc_north_3d, mpp_lbc_north_2d116 !!gm END INTERFACE117 108 INTERFACE mpp_minloc 118 109 MODULE PROCEDURE mpp_minloc2d ,mpp_minloc3d … … 477 468 478 469 479 !! mpp_lnk_2d_e utilisé dans ICB480 481 482 470 !! mpp_lnk_sum_2d et 3D ====>>>>>> à virer du code !!!! 483 471 … … 485 473 !! 486 474 487 488 SUBROUTINE mpp_lnk_2d_e( pt2d, cd_type, psgn, jpri, jprj )489 !!490 !! *** routine mpp_lnk_2d_e ***491 !!492 !! ** Purpose : Message passing manadgement for 2d array (with halo)493 !!494 !! ** Method : Use mppsend and mpprecv function for passing mask495 !! between processors following neighboring subdomains.496 !! domain parameters497 !! nlci : first dimension of the local subdomain498 !! nlcj : second dimension of the local subdomain499 !! jpri : number of rows for extra outer halo500 !! jprj : number of columns for extra outer halo501 !! nbondi : mark for "eastwest local boundary"502 !! nbondj : mark for "northsouth local boundary"503 !! noea : number for local neighboring processors504 !! nowe : number for local neighboring processors505 !! noso : number for local neighboring processors506 !! nono : number for local neighboring processors507 !!508 !!509 INTEGER , INTENT(in ) :: jpri510 INTEGER , INTENT(in ) :: jprj511 REAL(wp), DIMENSION(1jpri:jpi+jpri,1jprj:jpj+jprj), INTENT(inout) :: pt2d ! 2D array with extra halo512 CHARACTER(len=1) , INTENT(in ) :: cd_type ! nature of ptab array gridpoints513 ! ! = T , U , V , F , W and I points514 REAL(wp) , INTENT(in ) :: psgn ! =1 the sign change across the515 !! ! north boundary, = 1. otherwise516 INTEGER :: jl ! dummy loop indices517 INTEGER :: imigr, iihom, ijhom ! temporary integers518 INTEGER :: ipreci, iprecj ! temporary integers519 INTEGER :: ml_req1, ml_req2, ml_err ! for key_mpi_isend520 INTEGER, DIMENSION(MPI_STATUS_SIZE) :: ml_stat ! for key_mpi_isend521 !!522 REAL(wp), DIMENSION(1jpri:jpi+jpri,nn_hls+jprj,2) :: r2dns523 REAL(wp), DIMENSION(1jpri:jpi+jpri,nn_hls+jprj,2) :: r2dsn524 REAL(wp), DIMENSION(1jprj:jpj+jprj,nn_hls+jpri,2) :: r2dwe525 REAL(wp), DIMENSION(1jprj:jpj+jprj,nn_hls+jpri,2) :: r2dew526 !!527 528 ipreci = nn_hls + jpri ! take into account outer extra 2D overlap area529 iprecj = nn_hls + jprj530 531 532 ! 1. standard boundary treatment (CAUTION: the order matters Here !!!! )533 ! 534 ! !== NorthSouth boundaries535 ! !* cyclic536 IF( nbondj == 2 .AND. jperio == 7 ) THEN537 pt2d(:, 1jprj: 1 ) = pt2d ( :, jpjm1jprj:jpjm1 )538 pt2d(:, jpj :jpj+jprj) = pt2d ( :, 2 :2+jprj)539 ELSE !* closed540 IF( .NOT. cd_type == 'F' ) pt2d(:, 1jprj : nn_hls ) = 0._wp ! south except at Fpoint541 pt2d(:,nlcjnn_hls+1:jpj+jprj) = 0._wp ! north542 ENDIF543 ! !== EastWest boundaries544 ! !* Cyclic eastwest545 IF( nbondi == 2 .AND. (nperio == 1 .OR. nperio == 4 .OR. nperio == 6) ) THEN546 pt2d(1jpri: 1 ,:) = pt2d(jpim1jpri: jpim1 ,:) ! east547 pt2d( jpi :jpi+jpri,:) = pt2d( 2 :2+jpri,:) ! west548 ELSE !* closed549 IF( .NOT. cd_type == 'F' ) pt2d( 1jpri :nn_hls ,:) = 0._wp ! south except at Fpoint550 pt2d(nlcinn_hls+1:jpi+jpri,:) = 0._wp ! north551 ENDIF552 !553 ! north fold treatment554 ! 555 IF( npolj /= 0 ) THEN556 !557 SELECT CASE ( jpni )558 !!gm ERROR CASE ( 1 ) ; CALL lbc_nfd ( pt2d(1:jpi,1:jpj+jprj), cd_type, psgn, pr2dj=jprj )559 CASE DEFAULT ; CALL mpp_lbc_north_e( pt2d , cd_type, psgn )560 END SELECT561 !562 ENDIF563 564 ! 2. East and west directions exchange565 ! 566 ! we play with the neigbours AND the row number because of the periodicity567 !568 SELECT CASE ( nbondi ) ! Read Dirichlet lateral conditions569 CASE ( 1, 0, 1 ) ! all exept 2 (i.e. close case)570 iihom = nlcinrecijpri571 DO jl = 1, ipreci572 r2dew(:,jl,1) = pt2d(nn_hls+jl,:)573 r2dwe(:,jl,1) = pt2d(iihom +jl,:)574 END DO575 END SELECT576 !577 ! ! Migrations578 imigr = ipreci * ( jpj + 2*jprj)579 !580 SELECT CASE ( nbondi )581 CASE ( 1 )582 CALL mppsend( 2, r2dwe(1jprj,1,1), imigr, noea, ml_req1 )583 CALL mpprecv( 1, r2dew(1jprj,1,2), imigr, noea )584 IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err)585 CASE ( 0 )586 CALL mppsend( 1, r2dew(1jprj,1,1), imigr, nowe, ml_req1 )587 CALL mppsend( 2, r2dwe(1jprj,1,1), imigr, noea, ml_req2 )588 CALL mpprecv( 1, r2dew(1jprj,1,2), imigr, noea )589 CALL mpprecv( 2, r2dwe(1jprj,1,2), imigr, nowe )590 IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err)591 IF(l_isend) CALL mpi_wait(ml_req2,ml_stat,ml_err)592 CASE ( 1 )593 CALL mppsend( 1, r2dew(1jprj,1,1), imigr, nowe, ml_req1 )594 CALL mpprecv( 2, r2dwe(1jprj,1,2), imigr, nowe )595 IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err)596 END SELECT597 !598 ! ! Write Dirichlet lateral conditions599 iihom = nlci  nn_hls600 !601 SELECT CASE ( nbondi )602 CASE ( 1 )603 DO jl = 1, ipreci604 pt2d(iihom+jl,:) = r2dew(:,jl,2)605 END DO606 CASE ( 0 )607 DO jl = 1, ipreci608 pt2d(jljpri,:) = r2dwe(:,jl,2)609 pt2d( iihom+jl,:) = r2dew(:,jl,2)610 END DO611 CASE ( 1 )612 DO jl = 1, ipreci613 pt2d(jljpri,:) = r2dwe(:,jl,2)614 END DO615 END SELECT616 617 ! 3. North and south directions618 ! 619 ! always closed : we play only with the neigbours620 !621 IF( nbondj /= 2 ) THEN ! Read Dirichlet lateral conditions622 ijhom = nlcjnrecjjprj623 DO jl = 1, iprecj624 r2dsn(:,jl,1) = pt2d(:,ijhom +jl)625 r2dns(:,jl,1) = pt2d(:,nn_hls+jl)626 END DO627 ENDIF628 !629 ! ! Migrations630 imigr = iprecj * ( jpi + 2*jpri )631 !632 SELECT CASE ( nbondj )633 CASE ( 1 )634 CALL mppsend( 4, r2dsn(1jpri,1,1), imigr, nono, ml_req1 )635 CALL mpprecv( 3, r2dns(1jpri,1,2), imigr, nono )636 IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err)637 CASE ( 0 )638 CALL mppsend( 3, r2dns(1jpri,1,1), imigr, noso, ml_req1 )639 CALL mppsend( 4, r2dsn(1jpri,1,1), imigr, nono, ml_req2 )640 CALL mpprecv( 3, r2dns(1jpri,1,2), imigr, nono )641 CALL mpprecv( 4, r2dsn(1jpri,1,2), imigr, noso )642 IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err)643 IF(l_isend) CALL mpi_wait(ml_req2,ml_stat,ml_err)644 CASE ( 1 )645 CALL mppsend( 3, r2dns(1jpri,1,1), imigr, noso, ml_req1 )646 CALL mpprecv( 4, r2dsn(1jpri,1,2), imigr, noso )647 IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err)648 END SELECT649 !650 ! ! Write Dirichlet lateral conditions651 ijhom = nlcj  nn_hls652 !653 SELECT CASE ( nbondj )654 CASE ( 1 )655 DO jl = 1, iprecj656 pt2d(:,ijhom+jl) = r2dns(:,jl,2)657 END DO658 CASE ( 0 )659 DO jl = 1, iprecj660 pt2d(:,jljprj) = r2dsn(:,jl,2)661 pt2d(:,ijhom+jl ) = r2dns(:,jl,2)662 END DO663 CASE ( 1 )664 DO jl = 1, iprecj665 pt2d(:,jljprj) = r2dsn(:,jl,2)666 END DO667 END SELECT668 !669 END SUBROUTINE mpp_lnk_2d_e670 475 671 476 … … 1443 1248 1444 1249 1445 SUBROUTINE mpp_lbc_north_e( pt2d, cd_type, psgn)1446 !!1447 !! *** routine mpp_lbc_north_2d ***1448 !!1449 !! ** Purpose : Ensure proper north fold horizontal bondary condition1450 !! in mpp configuration in case of jpn1 > 1 and for 2d1451 !! array with outer extra halo1452 !!1453 !! ** Method : North fold condition and mpp with more than one proc1454 !! in idirection require a specific treatment. We gather1455 !! the 4+2*jpr2dj northern lines of the global domain on 11456 !! processor and apply lbc northfold on this sub array.1457 !! Then we scatter the north fold array back to the processors.1458 !!1459 !!1460 REAL(wp), DIMENSION(1jpr2di:jpi+jpr2di,1jpr2dj:jpj+jpr2dj), INTENT(inout) :: pt2d ! 2D array with extra halo1461 CHARACTER(len=1) , INTENT(in ) :: cd_type ! nature of pt3d gridpoints1462 REAL(wp) , INTENT(in ) :: psgn ! sign used across the north fold1463 !1464 INTEGER :: ji, jj, jr1465 INTEGER :: ierr, itaille, ildi, ilei, iilb1466 INTEGER :: ijpj, ij, iproc1467 REAL(wp), DIMENSION(:,:) , ALLOCATABLE :: ztab_e, znorthloc_e1468 REAL(wp), DIMENSION(:,:,:), ALLOCATABLE :: znorthgloio_e1469 !!1470 !1471 ALLOCATE( ztab_e(jpiglo,4+2*jpr2dj), znorthloc_e(jpi,4+2*jpr2dj), znorthgloio_e(jpi,4+2*jpr2dj,jpni) )1472 !1473 ijpj=41474 ztab_e(:,:) = 0._wp1475 1476 ij = 01477 ! put in znorthloc_e the last 4 jlines of pt2d1478 DO jj = nlcj  ijpj + 1  jpr2dj, nlcj +jpr2dj1479 ij = ij + 11480 DO ji = 1, jpi1481 znorthloc_e(ji,ij) = pt2d(ji,jj)1482 END DO1483 END DO1484 !1485 itaille = jpi * ( ijpj + 2 * jpr2dj )1486 CALL MPI_ALLGATHER( znorthloc_e(1,1) , itaille, MPI_DOUBLE_PRECISION, &1487 & znorthgloio_e(1,1,1), itaille, MPI_DOUBLE_PRECISION, ncomm_north, ierr )1488 !1489 DO jr = 1, ndim_rank_north ! recover the global north array1490 iproc = nrank_north(jr) + 11491 ildi = nldit (iproc)1492 ilei = nleit (iproc)1493 iilb = nimppt(iproc)1494 DO jj = 1, ijpj+2*jpr2dj1495 DO ji = ildi, ilei1496 ztab_e(ji+iilb1,jj) = znorthgloio_e(ji,jj,jr)1497 END DO1498 END DO1499 END DO1500 1501 ! 2. NorthFold boundary conditions1502 ! 1503 !!gm ERROR CALL lbc_nfd( ztab_e(:,:), cd_type, psgn, pr2dj = jpr2dj )1504 1505 ij = jpr2dj1506 !! Scatter back to pt2d1507 DO jj = nlcj  ijpj + 1 , nlcj +jpr2dj1508 ij = ij +11509 DO ji= 1, nlci1510 pt2d(ji,jj) = ztab_e(ji+nimpp1,ij)1511 END DO1512 END DO1513 !1514 DEALLOCATE( ztab_e, znorthloc_e, znorthgloio_e )1515 !1516 END SUBROUTINE mpp_lbc_north_e1517 1518 1519 1250 SUBROUTINE mpi_init_opa( ldtxt, ksft, code ) 1520 1251 !! … … 1608 1339 1609 1340 1610 SUBROUTINE mpp_lbc_north_icb( pt2d, cd_type, psgn, pr2dj)1341 SUBROUTINE mpp_lbc_north_icb( pt2d, cd_type, psgn, ipr2dj) 1611 1342 !! 1612 1343 !! *** routine mpp_lbc_north_icb *** … … 1621 1352 !! processor and apply lbc northfold on this sub array. 1622 1353 !! Then we scatter the north fold array back to the processors. 1623 !! This version accounts for an extra halo with icebergs. 1354 !! This routine accounts for an extra halo with icebergs 1355 !! and assumes ghost rows and columns have been suppressed. 1624 1356 !! 1625 1357 !! … … 1629 1361 REAL(wp) , INTENT(in ) :: psgn ! = 1. the sign change across the 1630 1362 !! ! north fold, = 1. otherwise 1631 INTEGER , OPTIONAL , INTENT(in ) ::pr2dj1363 INTEGER , INTENT(in ) :: ipr2dj 1632 1364 ! 1633 1365 INTEGER :: ji, jj, jr 1634 1366 INTEGER :: ierr, itaille, ildi, ilei, iilb 1635 INTEGER :: i jpj, ij, iproc, ipr2dj1367 INTEGER :: ipj, ij, iproc 1636 1368 ! 1637 1369 REAL(wp), DIMENSION(:,:) , ALLOCATABLE :: ztab_e, znorthloc_e … … 1639 1371 !! 1640 1372 ! 1641 ijpj=4 1642 IF( PRESENT(pr2dj) ) THEN ! use of additional halos 1643 ipr2dj = pr2dj 1644 ELSE 1645 ipr2dj = 0 1646 ENDIF 1647 ALLOCATE( ztab_e(jpiglo,4+2*ipr2dj), znorthloc_e(jpi,4+2*ipr2dj), znorthgloio_e(jpi,4+2*ipr2dj,jpni) ) 1648 ! 1649 ztab_e(:,:) = 0._wp 1373 ipj=4 1374 ALLOCATE( ztab_e(jpiglo,4+2*ipr2dj), znorthloc_e(jpimax,4+2*ipr2dj), znorthgloio_e(jpimax,4+2*ipr2dj,jpni) ) 1375 ! 1376 ztab_e(:,:) = 0._wp 1377 znorthloc_e(:,:) = 0._wp 1650 1378 ! 1651 1379 ij = 0 1652 ! put in znorthloc_e the last 4 jlines of pt2d1653 DO jj = nlcj  ijpj + 1  ipr2dj, nlcj +ipr2dj1380 ! put the last 4+2*ipr2dj lines of pt2d into znorthloc_e 1381 DO jj = jpj  ipj + 1  ipr2dj, jpj +ipr2dj 1654 1382 ij = ij + 1 1655 DO ji = 1, jpi 1656 znorthloc_e(ji,ij)=pt2d(ji,jj) 1657 END DO 1383 znorthloc_e(1:jpi,ij)=pt2d(1:jpi,jj) 1658 1384 END DO 1659 1385 ! 1660 itaille = jpi * ( ijpj + 2 * ipr2dj )1386 itaille = jpimax * ( ipj + 2 * ipr2dj ) 1661 1387 CALL MPI_ALLGATHER( znorthloc_e(1,1) , itaille, MPI_DOUBLE_PRECISION, & 1662 1388 & znorthgloio_e(1,1,1), itaille, MPI_DOUBLE_PRECISION, ncomm_north, ierr ) … … 1667 1393 ilei = nleit (iproc) 1668 1394 iilb = nimppt(iproc) 1669 DO jj = 1, i jpj+2*ipr2dj1395 DO jj = 1, ipj+2*ipr2dj 1670 1396 DO ji = ildi, ilei 1671 1397 ztab_e(ji+iilb1,jj) = znorthgloio_e(ji,jj,jr) … … 1676 1402 ! 2. NorthFold boundary conditions 1677 1403 !  1678 !!gm ERROR CALL lbc_nfd( ztab_e(:,:), cd_type, psgn, pr2dj =ipr2dj )1404 CALL lbc_nfd( ztab_e(:,:), cd_type, psgn, ipr2dj ) 1679 1405 1680 1406 ij = ipr2dj 1681 1407 !! Scatter back to pt2d 1682 DO jj = nlcj  ijpj + 1 , nlcj +ipr2dj1408 DO jj = jpj  ipj + 1 , jpj +ipr2dj 1683 1409 ij = ij +1 1684 DO ji= 1, nlci1410 DO ji= 1, jpi 1685 1411 pt2d(ji,jj) = ztab_e(ji+nimpp1,ij) 1686 1412 END DO … … 1696 1422 !! *** routine mpp_lnk_2d_icb *** 1697 1423 !! 1698 !! ** Purpose : Message passing manadgement for 2d array (with extra halo and icebergs) 1424 !! ** Purpose : Message passing management for 2d array (with extra halo for icebergs) 1425 !! This routine receives a (1jpri:jpi+jpri,1jpri:jpj+jprj) 1426 !! array (usually (0:jpi+1, 0:jpj+1)) from lbc_lnk_icb calls. 1699 1427 !! 1700 1428 !! ** Method : Use mppsend and mpprecv function for passing mask 1701 1429 !! between processors following neighboring subdomains. 1702 1430 !! domain parameters 1703 !! nlci: first dimension of the local subdomain1704 !! nlcj: second dimension of the local subdomain1431 !! jpi : first dimension of the local subdomain 1432 !! jpj : second dimension of the local subdomain 1705 1433 !! jpri : number of rows for extra outer halo 1706 1434 !! jprj : number of columns for extra outer halo … … 1744 1472 ELSE !* closed 1745 1473 IF( .NOT. cd_type == 'F' ) pt2d( 1jpri :nn_hls ,:) = 0._wp ! south except at Fpoint 1746 pt2d( nlcinn_hls+1:jpi+jpri,:) = 0._wp ! north1474 pt2d(jpinn_hls+1:jpi+jpri,:) = 0._wp ! north 1747 1475 ENDIF 1748 1476 ! … … 1753 1481 ! 1754 1482 SELECT CASE ( jpni ) 1755 !!gm ERROR CASE ( 1 ) ; CALL lbc_nfd ( pt2d(1:jpi,1:jpj+jprj), cd_type, psgn, pr2dj=jprj )1756 CASE DEFAULT ; CALL mpp_lbc_north_icb( pt2d(1:jpi,1:jpj+jprj) , cd_type, psgn , pr2dj=jprj )1483 CASE ( 1 ) ; CALL lbc_nfd ( pt2d(1:jpi,1:jpj+jprj), cd_type, psgn, jprj ) 1484 CASE DEFAULT ; CALL mpp_lbc_north_icb( pt2d(1:jpi,1:jpj+jprj) , cd_type, psgn , jprj ) 1757 1485 END SELECT 1758 1486 ! … … 1765 1493 SELECT CASE ( nbondi ) ! Read Dirichlet lateral conditions 1766 1494 CASE ( 1, 0, 1 ) ! all exept 2 (i.e. close case) 1767 iihom = nlcinrecijpri1495 iihom = jpinrecijpri 1768 1496 DO jl = 1, ipreci 1769 1497 r2dew(:,jl,1) = pt2d(nn_hls+jl,:) … … 1794 1522 ! 1795 1523 ! ! Write Dirichlet lateral conditions 1796 iihom = nlci  nn_hls1524 iihom = jpi  nn_hls 1797 1525 ! 1798 1526 SELECT CASE ( nbondi ) … … 1818 1546 ! 1819 1547 IF( nbondj /= 2 ) THEN ! Read Dirichlet lateral conditions 1820 ijhom = nlcjnrecjjprj1548 ijhom = jpjnrecjjprj 1821 1549 DO jl = 1, iprecj 1822 1550 r2dsn(:,jl,1) = pt2d(:,ijhom +jl) … … 1847 1575 ! 1848 1576 ! ! Write Dirichlet lateral conditions 1849 ijhom = nlcj  nn_hls1577 ijhom = jpj  nn_hls 1850 1578 ! 1851 1579 SELECT CASE ( nbondj )
Note: See TracChangeset
for help on using the changeset viewer.