- Timestamp:
- 2021-01-19T13:07:35+01:00 (3 years ago)
- Location:
- NEMO/branches/2021/dev_r14312_MPI_Interface/src
- Files:
-
- 24 edited
Legend:
- Unmodified
- Added
- Removed
-
NEMO/branches/2021/dev_r14312_MPI_Interface/src/OCE/BDY/bdyini.F90
r13541 r14314 575 575 ! check if point has to be sent to a neighbour 576 576 ! W neighbour and on the inner left side 577 IF( ii == 2 . and. (nbondi == 0 .or. nbondi == 1) ) lsend_bdy(ib_bdy,igrd,1,ir) = .true.577 IF( ii == 2 .AND. mpinei(jpwe) > -1 ) lsend_bdy(ib_bdy,igrd,jpwe,ir) = .TRUE. 578 578 ! E neighbour and on the inner right side 579 IF( ii == jpi-1 . and. (nbondi == 0 .or. nbondi == -1) ) lsend_bdy(ib_bdy,igrd,2,ir) = .true.579 IF( ii == jpi-1 .AND. mpinei(jpea) > -1 ) lsend_bdy(ib_bdy,igrd,jpea,ir) = .TRUE. 580 580 ! S neighbour and on the inner down side 581 IF( ij == 2 . and. (nbondj == 0 .or. nbondj == 1) ) lsend_bdy(ib_bdy,igrd,3,ir) = .true.581 IF( ij == 2 .AND. mpinei(jpso) > -1 ) lsend_bdy(ib_bdy,igrd,jpso,ir) = .TRUE. 582 582 ! N neighbour and on the inner up side 583 IF( ij == jpj-1 . and. (nbondj == 0 .or. nbondj == -1) ) lsend_bdy(ib_bdy,igrd,4,ir) = .true.583 IF( ij == jpj-1 .AND. mpinei(jpno) > -1 ) lsend_bdy(ib_bdy,igrd,jpno,ir) = .TRUE. 584 584 ! 585 585 ! check if point has to be received from a neighbour 586 586 ! W neighbour and on the outter left side 587 IF( ii == 1 . and. (nbondi == 0 .or. nbondi == 1) ) lrecv_bdy(ib_bdy,igrd,1,ir) = .true.587 IF( ii == 1 .AND. mpinei(jpwe) > -1 ) lrecv_bdy(ib_bdy,igrd,jpwe,ir) = .TRUE. 588 588 ! E neighbour and on the outter right side 589 IF( ii == jpi . and. (nbondi == 0 .or. nbondi == -1) ) lrecv_bdy(ib_bdy,igrd,2,ir) = .true.589 IF( ii == jpi .AND. mpinei(jpea) > -1 ) lrecv_bdy(ib_bdy,igrd,jpea,ir) = .TRUE. 590 590 ! S neighbour and on the outter down side 591 IF( ij == 1 . and. (nbondj == 0 .or. nbondj == 1) ) lrecv_bdy(ib_bdy,igrd,3,ir) = .true.591 IF( ij == 1 .AND. mpinei(jpso) > -1 ) lrecv_bdy(ib_bdy,igrd,jpso,ir) = .TRUE. 592 592 ! N neighbour and on the outter up side 593 IF( ij == jpj . and. (nbondj == 0 .or. nbondj == -1) ) lrecv_bdy(ib_bdy,igrd,4,ir) = .true.593 IF( ij == jpj .AND. mpinei(jpno) > -1 ) lrecv_bdy(ib_bdy,igrd,jpno,ir) = .TRUE. 594 594 ! 595 595 END DO … … 739 739 ! <-- (o exterior) --> 740 740 ! (1) o|x OR (2) x|o 741 ! |___ ___| 742 IF( iibi == 0 .OR. ii1 == 0 .OR. ii2 == 0 .OR. ii3 == 0 ) lrecv_bdyint(ib_bdy,igrd,1,ir) = .true.743 IF( iibi == jpi+1 .OR. ii1 == jpi+1 .OR. ii2 == jpi+1 .OR. ii3 == jpi+1 ) lrecv_bdyint(ib_bdy,igrd,2,ir) = .true.744 IF( iibe == 0 ) lrecv_bdyext(ib_bdy,igrd,1,ir) = .true.745 IF( iibe == jpi+1 ) lrecv_bdyext(ib_bdy,igrd,2,ir) = .true.741 ! |___ ___| 742 IF( iibi==0 .OR. ii1==0 .OR. ii2==0 .OR. ii3==0 ) lrecv_bdyint(ib_bdy,igrd,jpwe,ir) = .TRUE. 743 IF( iibi==jpi+1 .OR. ii1==jpi+1 .OR. ii2==jpi+1 .OR. ii3==jpi+1 ) lrecv_bdyint(ib_bdy,igrd,jpea,ir) = .TRUE. 744 IF( iibe==0 ) lrecv_bdyext(ib_bdy,igrd,jpwe,ir) = .TRUE. 745 IF( iibe==jpi+1 ) lrecv_bdyext(ib_bdy,igrd,jpea,ir) = .TRUE. 746 746 ! Check if neighbour has its rim parallel to its mpi subdomain border and located next to its halo 747 747 ! :¨¨¨¨¨|¨¨--> | | <--¨¨|¨¨¨¨¨: 748 748 ! : | x:o | neighbour limited by ... would need o | o:x | : 749 749 ! :.....|_._:_____| (1) W neighbour E neighbour (2) |_____:_._|.....: 750 IF( ii == 2 .AND. ( nbondi == 1 .OR. nbondi == 0 ).AND. &751 & ( iibi == 3 .OR. ii1 == 3 .OR. ii2 == 3 .OR. ii3 == 3 ) ) lsend_bdyint(ib_bdy,igrd,1,ir)=.true.752 IF( ii == jpi-1 .AND. ( nbondi == -1 .OR. nbondi == 0 ).AND. &753 & ( iibi == jpi-2 .OR. ii1 == jpi-2 .OR. ii2 == jpi-2 .OR. ii3 == jpi-2) ) lsend_bdyint(ib_bdy,igrd,2,ir)=.true.754 IF( ii == 2 .AND. ( nbondi == 1 .OR. nbondi == 0 ) .AND. iibe == 3 ) lsend_bdyext(ib_bdy,igrd,1,ir)=.true.755 IF( ii == jpi-1 .AND. ( nbondi == -1 .OR. nbondi == 0 ) .AND. iibe == jpi-2 ) lsend_bdyext(ib_bdy,igrd,2,ir)=.true.750 IF( ii==2 .AND. mpinei(jpwe) > -1 .AND. & 751 & ( iibi==3 .OR. ii1==3 .OR. ii2==3 .OR. ii3==3 ) ) lsend_bdyint(ib_bdy,igrd,jpwe,ir) = .TRUE. 752 IF( ii==jpi-1 .AND. mpinei(jpea) > -1 .AND. & 753 & ( iibi==jpi-2 .OR. ii1==jpi-2 .OR. ii2==jpi-2 .OR. ii3==jpi-2) ) lsend_bdyint(ib_bdy,igrd,jpea,ir) = .TRUE. 754 IF( ii==2 .AND. mpinei(jpwe) > -1 .AND. iibe==3 ) lsend_bdyext(ib_bdy,igrd,jpwe,ir) = .TRUE. 755 IF( ii==jpi-1 .AND. mpinei(jpea) > -1 .AND. iibe==jpi-2 ) lsend_bdyext(ib_bdy,igrd,jpea,ir) = .TRUE. 756 756 ! 757 757 ! search neighbour in the north/south direction … … 760 760 ! | |___x___| OR | | x | 761 761 ! v o (4) | | 762 IF( ijbi == 0 .OR. ij1 == 0 .OR. ij2 == 0 .OR. ij3 == 0 ) lrecv_bdyint(ib_bdy,igrd,3,ir) = .true.763 IF( ijbi == jpj+1 .OR. ij1 == jpj+1 .OR. ij2 == jpj+1 .OR. ij3 == jpj+1 ) lrecv_bdyint(ib_bdy,igrd,4,ir) = .true.764 IF( ijbe == 0 ) lrecv_bdyext(ib_bdy,igrd,3,ir) = .true.765 IF( ijbe == jpj+1 ) lrecv_bdyext(ib_bdy,igrd,4,ir) = .true.762 IF( ijbi==0 .OR. ij1==0 .OR. ij2==0 .OR. ij3==0 ) lrecv_bdyint(ib_bdy,igrd,jpso,ir) = .TRUE. 763 IF( ijbi==jpj+1 .OR. ij1==jpj+1 .OR. ij2==jpj+1 .OR. ij3==jpj+1 ) lrecv_bdyint(ib_bdy,igrd,jpno,ir) = .TRUE. 764 IF( ijbe==0 ) lrecv_bdyext(ib_bdy,igrd,jpso,ir) = .TRUE. 765 IF( ijbe==jpj+1 ) lrecv_bdyext(ib_bdy,igrd,jpno,ir) = .TRUE. 766 766 ! Check if neighbour has its rim parallel to its mpi subdomain _________ border and next to its halo 767 767 ! ^ | o | : : 768 768 ! | |¨¨¨¨x¨¨¨¨| neighbour limited by ... would need o | |....x....| 769 769 ! :_________: (3) S neighbour N neighbour (4) v | o | 770 IF( ij == 2 .AND. ( nbondj == 1 .OR. nbondj == 0 ).AND. &771 & ( ijbi == 3 .OR. ij1 == 3 .OR. ij2 == 3 .OR. ij3 == 3 ) ) lsend_bdyint(ib_bdy,igrd,3,ir)=.true.772 IF( ij == jpj-1 .AND. ( nbondj == -1 .OR. nbondj == 0 ).AND. &773 & ( ijbi == jpj-2 .OR. ij1 == jpj-2 .OR. ij2 == jpj-2 .OR. ij3 == jpj-2) ) lsend_bdyint(ib_bdy,igrd,4,ir)=.true.774 IF( ij == 2 .AND. ( nbondj == 1 .OR. nbondj == 0 ) .AND. ijbe == 3 ) lsend_bdyext(ib_bdy,igrd,3,ir)=.true.775 IF( ij == jpj-1 .AND. ( nbondj == -1 .OR. nbondj == 0 ) .AND. ijbe == jpj-2 ) lsend_bdyext(ib_bdy,igrd,4,ir)=.true.770 IF( ij==2 .AND. mpinei(jpso) > -1 .AND. & 771 & ( ijbi==3 .OR. ij1==3 .OR. ij2==3 .OR. ij3==3 ) ) lsend_bdyint(ib_bdy,igrd,jpso,ir) = .TRUE. 772 IF( ij==jpj-1 .AND. mpinei(jpno) > -1 .AND. & 773 & ( ijbi==jpj-2 .OR. ij1==jpj-2 .OR. ij2==jpj-2 .OR. ij3==jpj-2) ) lsend_bdyint(ib_bdy,igrd,jpno,ir) = .TRUE. 774 IF( ij==2 .AND. mpinei(jpso) > -1 .AND. ijbe==3 ) lsend_bdyext(ib_bdy,igrd,jpso,ir) = .TRUE. 775 IF( ij==jpj-1 .AND. mpinei(jpno) > -1 .AND. ijbe==jpj-2 ) lsend_bdyext(ib_bdy,igrd,jpno,ir) = .TRUE. 776 776 END DO 777 777 END DO -
NEMO/branches/2021/dev_r14312_MPI_Interface/src/OCE/CRS/crs.F90
r13286 r14314 32 32 INTEGER :: jpi_crsm1, jpj_crsm1 !: loop indices 33 33 INTEGER :: jpiglo_crsm1, jpjglo_crsm1 !: loop indices 34 INTEGER :: nperio_full, nperio_crs !: jperio of parent and coarse grids35 INTEGER :: npolj_full, npolj_crs !: north fold mark34 !!$ INTEGER :: nperio_full, nperio_crs !: jperio of parent and coarse grids 35 !!$ INTEGER :: npolj_full, npolj_crs !: north fold mark 36 36 INTEGER :: jpiglo_full, jpjglo_full !: jpiglo / jpjglo 37 37 INTEGER :: npiglo, npjglo !: jpjglo … … 46 46 INTEGER :: nimpp_full, njmpp_full !: global position of point (1,1) of subdomain on parent grid 47 47 INTEGER :: nimpp_crs, njmpp_crs !: set to 1,1 for now . Valid only for monoproc 48 !cc 49 INTEGER :: noea_full, nowe_full !: index of the local neighboring processors in 50 INTEGER :: noso_full, nono_full !: east, west, south and north directions 51 INTEGER :: npne_full, npnw_full !: index of north east and north west processor 52 INTEGER :: npse_full, npsw_full !: index of south east and south west processor 53 INTEGER :: nbne_full, nbnw_full !: logical of north east & north west processor 54 INTEGER :: nbse_full, nbsw_full !: logical of south east & south west processor 55 INTEGER :: nidom_full !: ??? 56 INTEGER :: nproc_full !:number for local processor 57 INTEGER :: nbondi_full, nbondj_full !: mark of i- and j-direction local boundaries 58 INTEGER :: noea_crs, nowe_crs !: index of the local neighboring processors in 59 INTEGER :: noso_crs, nono_crs !: east, west, south and north directions 60 INTEGER :: npne_crs, npnw_crs !: index of north east and north west processor 61 INTEGER :: npse_crs, npsw_crs !: index of south east and south west processor 62 INTEGER :: nbne_crs, nbnw_crs !: logical of north east & north west processor 63 INTEGER :: nbse_crs, nbsw_crs !: logical of south east & south west processor 64 INTEGER :: nidom_crs !: ??? 65 INTEGER :: nproc_crs !:number for local processor 66 INTEGER :: nbondi_crs, nbondj_crs !: mark of i- and j-direction local boundaries 67 68 48 69 49 INTEGER, DIMENSION(:), ALLOCATABLE :: mis_crs, mie_crs, mis2_crs, mie2_crs ! starting and ending i-indices of parent subset 70 50 INTEGER, DIMENSION(:), ALLOCATABLE :: mjs_crs, mje_crs, mjs2_crs, mje2_crs ! starting and ending j-indices of parent subset … … 72 52 INTEGER, DIMENSION(:), ALLOCATABLE :: mi0_crs, mi1_crs, mj0_crs, mj1_crs 73 53 INTEGER :: mxbinctr, mybinctr ! central point in grid box 74 INTEGER, DIMENSION(:), ALLOCATABLE :: jpiall_crs, jpiall_full !: dimensions of every subdomain75 INTEGER, DIMENSION(:), ALLOCATABLE :: nis0all_crs, nis0all_full !: first, last indoor index for each i-domain76 INTEGER, DIMENSION(:), ALLOCATABLE :: nie0all_crs, nie0all_full !: first, last indoor index for each j-domain77 INTEGER, DIMENSION(:), ALLOCATABLE :: nimppt_crs, nimppt_full !: first, last indoor index for each j-domain78 INTEGER, DIMENSION(:), ALLOCATABLE :: jpjall_crs, jpjall_full !: dimensions of every subdomain79 INTEGER, DIMENSION(:), ALLOCATABLE :: njs0all_crs, njs0all_full !: first, last indoor index for each i-domain80 INTEGER, DIMENSION(:), ALLOCATABLE :: nje0all_crs, nje0all_full !: first, last indoor index for each j-domain81 INTEGER, DIMENSION(:), ALLOCATABLE :: njmppt_crs, njmppt_full !: first, last indoor index for each j-domain54 !!$ INTEGER, DIMENSION(:), ALLOCATABLE :: jpiall_crs, jpiall_full !: dimensions of every subdomain 55 !!$ INTEGER, DIMENSION(:), ALLOCATABLE :: nis0all_crs, nis0all_full !: first, last indoor index for each i-domain 56 !!$ INTEGER, DIMENSION(:), ALLOCATABLE :: nie0all_crs, nie0all_full !: first, last indoor index for each j-domain 57 !!$ INTEGER, DIMENSION(:), ALLOCATABLE :: nimppt_crs, nimppt_full !: first, last indoor index for each j-domain 58 !!$ INTEGER, DIMENSION(:), ALLOCATABLE :: jpjall_crs, jpjall_full !: dimensions of every subdomain 59 !!$ INTEGER, DIMENSION(:), ALLOCATABLE :: njs0all_crs, njs0all_full !: first, last indoor index for each i-domain 60 !!$ INTEGER, DIMENSION(:), ALLOCATABLE :: nje0all_crs, nje0all_full !: first, last indoor index for each j-domain 61 !!$ INTEGER, DIMENSION(:), ALLOCATABLE :: njmppt_crs, njmppt_full !: first, last indoor index for each j-domain 82 62 83 63 … … 231 211 & hmlp_crs(jpi_crs,jpj_crs) , hmlpt_crs(jpi_crs,jpj_crs) , STAT=ierr(14) ) 232 212 233 ALLOCATE( nimppt_crs (jpnij) , jpiall_crs (jpnij) , nis0all_crs (jpnij) , nie0all_crs (jpnij), &234 & nimppt_full(jpnij) , jpiall_full(jpnij) , nis0all_full(jpnij) , nie0all_full(jpnij), &235 njmppt_crs (jpnij) , jpjall_crs (jpnij) , njs0all_crs (jpnij) , nje0all_crs (jpnij), &236 & njmppt_full(jpnij) , jpjall_full(jpnij) , njs0all_full(jpnij) , nje0all_full(jpnij) , STAT=ierr(15) )213 !!$ ALLOCATE( nimppt_crs (jpnij) , jpiall_crs (jpnij) , nis0all_crs (jpnij) , nie0all_crs (jpnij), & 214 !!$ & nimppt_full(jpnij) , jpiall_full(jpnij) , nis0all_full(jpnij) , nie0all_full(jpnij), & 215 !!$ njmppt_crs (jpnij) , jpjall_crs (jpnij) , njs0all_crs (jpnij) , nje0all_crs (jpnij), & 216 !!$ & njmppt_full(jpnij) , jpjall_full(jpnij) , njs0all_full(jpnij) , nje0all_full(jpnij) , STAT=ierr(15) ) 237 217 238 218 crs_dom_alloc = MAXVAL(ierr) … … 269 249 jpim1 = jpim1_full 270 250 jpjm1 = jpjm1_full 271 jperio = nperio_full272 273 npolj = npolj_full251 !!$ jperio = nperio_full 252 253 !!$ npolj = npolj_full 274 254 jpiglo = jpiglo_full 275 255 jpjglo = jpjglo_full … … 284 264 njmpp = njmpp_full 285 265 286 jpiall (:) = jpiall_full (:)287 nis0all(:) = nis0all_full(:)288 nie0all(:) = nie0all_full(:)289 nimppt (:) = nimppt_full (:)290 jpjall (:) = jpjall_full (:)291 njs0all(:) = njs0all_full(:)292 nje0all(:) = nje0all_full(:)293 njmppt (:) = njmppt_full (:)266 !!$ jpiall (:) = jpiall_full (:) 267 !!$ nis0all(:) = nis0all_full(:) 268 !!$ nie0all(:) = nie0all_full(:) 269 !!$ nimppt (:) = nimppt_full (:) 270 !!$ jpjall (:) = jpjall_full (:) 271 !!$ njs0all(:) = njs0all_full(:) 272 !!$ nje0all(:) = nje0all_full(:) 273 !!$ njmppt (:) = njmppt_full (:) 294 274 295 275 END SUBROUTINE dom_grid_glo … … 308 288 jpim1 = jpi_crsm1 309 289 jpjm1 = jpj_crsm1 310 jperio = nperio_crs311 312 npolj = npolj_crs290 !!$ jperio = nperio_crs 291 292 !!$ npolj = npolj_crs 313 293 jpiglo = jpiglo_crs 314 294 jpjglo = jpjglo_crs … … 324 304 njmpp = njmpp_crs 325 305 326 jpiall (:) = jpiall_crs (:)327 nis0all(:) = nis0all_crs(:)328 nie0all(:) = nie0all_crs(:)329 nimppt (:) = nimppt_crs (:)330 jpjall (:) = jpjall_crs (:)331 njs0all(:) = njs0all_crs(:)332 nje0all(:) = nje0all_crs(:)333 njmppt (:) = njmppt_crs (:)306 !!$ jpiall (:) = jpiall_crs (:) 307 !!$ nis0all(:) = nis0all_crs(:) 308 !!$ nie0all(:) = nie0all_crs(:) 309 !!$ nimppt (:) = nimppt_crs (:) 310 !!$ jpjall (:) = jpjall_crs (:) 311 !!$ njs0all(:) = njs0all_crs(:) 312 !!$ nje0all(:) = nje0all_crs(:) 313 !!$ njmppt (:) = njmppt_crs (:) 334 314 ! 335 315 END SUBROUTINE dom_grid_crs -
NEMO/branches/2021/dev_r14312_MPI_Interface/src/OCE/CRS/crsdom.F90
r14275 r14314 1877 1877 1878 1878 1879 ! 1.a. Define global domain indices : take into account the interior domain only ( removes i/j=1 , i/j=jpiglo/jpjglo ) then add 2/3 grid points1880 jpiglo_crs = INT( (jpiglo - 2) / nn_factx ) + 21881 ! jpjglo_crs = INT( (jpjglo - 2) / nn_facty ) + 2 ! the -2 removes j=1, j=jpj1882 ! jpjglo_crs = INT( (jpjglo - 2) / nn_facty ) + 31883 jpjglo_crs = INT( (jpjglo - MOD(jpjglo, nn_facty)) / nn_facty ) + 31884 jpiglo_crsm1 = jpiglo_crs - 11885 jpjglo_crsm1 = jpjglo_crs - 11886 1887 jpi_crs = ( jpiglo_crs - 2 * nn_hls + (jpni-1) ) / jpni + 2 * nn_hls1888 jpj_crs = ( jpjglo_crsm1 - 2 * nn_hls + (jpnj-1) ) / jpnj + 2 * nn_hls1889 1890 IF( noso < 0 ) jpj_crs = jpj_crs + 1 ! add a local band on southern processors1891 1892 jpi_crsm1 = jpi_crs - 11893 jpj_crsm1 = jpj_crs - 11894 nperio_crs = jperio1895 npolj_crs = npolj1896 1897 ierr = crs_dom_alloc() ! allocate most coarse grid arrays1898 1899 ! 2.a Define processor domain1900 IF( .NOT. lk_mpp ) THEN1901 nimpp_crs = 11902 njmpp_crs = 11903 Nis0_crs = 11904 Njs0_crs = 11905 Nie0_crs = jpi_crs1906 Nje0_crs = jpj_crs1907 ELSE1908 ! Initialisation of most local variables -1909 nimpp_crs = 11910 njmpp_crs = 11911 Nis0_crs = 11912 Njs0_crs = 11913 Nie0_crs = jpi_crs1914 Nje0_crs = jpj_crs1915 1916 ! Calculs suivant une découpage en j1917 DO jn = 1, jpnij, jpni1918 IF( jn < ( jpnij - jpni + 1 ) ) THEN1919 nje0all_crs(jn) = AINT( REAL( ( jpjglo - (njmppt(jn ) - 1) ) / nn_facty, wp ) ) &1920 & - AINT( REAL( ( jpjglo - (njmppt(jn+jpni) - 1) ) / nn_facty, wp ) )1921 ELSE1922 nje0all_crs(jn) = AINT( REAL( nje0all(jn) / nn_facty, wp ) ) + 11923 ENDIF1924 IF( noso < 0 ) nje0all_crs(jn) = nje0all_crs(jn) + 11925 SELECT CASE( ibonjt(jn) )1926 CASE ( -1 )1927 IF( MOD( jpjglo - njmppt(jn), nn_facty) > 0 ) nje0all_crs(jn) = nje0all_crs(jn) + 11928 jpjall_crs (jn) = nje0all_crs(jn) + nn_hls1929 njs0all_crs(jn) = njs0all(jn)1930 1931 CASE ( 0 )1932 1933 njs0all_crs(jn) = njs0all(jn)1934 IF( njs0all(jn) == 1 ) nje0all_crs(jn) = nje0all_crs(jn) + 11935 nje0all_crs(jn) = nje0all_crs(jn) + nn_hls1936 jpjall_crs (jn) = nje0all_crs(jn) + nn_hls1937 1938 CASE ( 1, 2 )1939 1940 nje0all_crs(jn) = nje0all_crs(jn) + nn_hls1941 jpjall_crs (jn) = nje0all_crs(jn)1942 njs0all_crs(jn) = njs0all(jn)1943 1944 CASE DEFAULT1945 CALL ctl_stop( 'STOP', 'error from crs_dom_def, you should not be there (1) ...' )1946 END SELECT1947 IF( jpjall_crs(jn) > jpj_crs ) jpj_crs = jpj_crs + 11948 1949 IF(njs0all_crs(jn) == 1 ) THEN1950 njmppt_crs(jn) = 11951 ELSE1952 njmppt_crs(jn) = 2 + ANINT(REAL((njmppt(jn) + 1 - MOD( jpjglo , nn_facty )) / nn_facty, wp ) )1953 ENDIF1954 1955 DO jj = jn + 1, jn + jpni - 11956 nje0all_crs(jj) = nje0all_crs(jn)1957 jpjall_crs (jj) = jpjall_crs(jn)1958 njs0all_crs(jj) = njs0all_crs(jn)1959 njmppt_crs (jj) = njmppt_crs(jn)1960 ENDDO1961 ENDDO1962 Nje0_crs = nje0all_crs(narea)1963 jpj_crs = jpjall_crs (narea)1964 Njs0_crs = njs0all_crs(narea)1965 njmpp_crs = njmppt_crs (narea)1966 1967 ! Calcul suivant un decoupage en i1968 DO jn = 1, jpni1969 IF( jn == 1 ) THEN1970 nie0all_crs(jn) = AINT( REAL( ( nimppt(jn ) - 1 + jpiall(jn ) ) / nn_factx, wp) )1971 ELSE1972 nie0all_crs(jn) = AINT( REAL( ( nimppt(jn ) - 1 + jpiall(jn ) ) / nn_factx, wp) ) &1973 & - AINT( REAL( ( nimppt(jn-1) - 1 + jpiall(jn-1) ) / nn_factx, wp) )1974 ENDIF1975 1976 SELECT CASE( ibonit(jn) )1977 CASE ( -1 )1978 nie0all_crs(jn) = nie0all_crs(jn) + nn_hls1979 jpiall_crs (jn) = nie0all_crs(jn) + nn_hls1980 nis0all_crs(jn) = nis0all(jn)1981 1982 CASE ( 0 )1983 nie0all_crs(jn) = nie0all_crs(jn) + nn_hls1984 jpiall_crs (jn) = nie0all_crs(jn) + nn_hls1985 nis0all_crs(jn) = nis0all(jn)1986 1987 CASE ( 1, 2 )1988 IF( MOD( jpiglo - nimppt(jn), nn_factx) > 0 ) nie0all_crs(jn) = nie0all_crs(jn) + 11989 nie0all_crs(jn) = nie0all_crs(jn) + nn_hls1990 jpiall_crs (jn) = nie0all_crs(jn)1991 nis0all_crs(jn) = nis0all(jn)1992 1993 CASE DEFAULT1994 CALL ctl_stop( 'STOP', 'error from crs_dom_def, you should not be there (2) ...' )1995 END SELECT1996 1997 nimppt_crs(jn) = ANINT( REAL( (nimppt(jn) + 1 ) / nn_factx, wp ) ) + 11998 DO jj = jn + jpni , jpnij, jpni1999 nie0all_crs(jj) = nie0all_crs(jn)2000 jpiall_crs (jj) = jpiall_crs (jn)2001 nis0all_crs(jj) = nis0all_crs(jn)2002 nimppt_crs (jj) = nimppt_crs (jn)2003 ENDDO2004 ENDDO2005 2006 Nie0_crs = nie0all_crs(narea)2007 jpi_crs = jpiall_crs (narea)2008 Nis0_crs = nis0all_crs(narea)2009 nimpp_crs = nimppt_crs (narea)2010 2011 DO ji = 1, jpi_crs2012 mig_crs(ji) = ji + nimpp_crs - 12013 ENDDO2014 DO jj = 1, jpj_crs2015 mjg_crs(jj) = jj + njmpp_crs - 1!2016 ENDDO2017 2018 DO ji = 1, jpiglo_crs2019 mi0_crs(ji) = MAX( 1, MIN( ji - nimpp_crs + 1 , jpi_crs + 1 ) )2020 mi1_crs(ji) = MAX( 0, MIN( ji - nimpp_crs + 1 , jpi_crs ) )2021 ENDDO2022 2023 DO jj = 1, jpjglo_crs2024 mj0_crs(jj) = MAX( 1, MIN( jj - njmpp_crs + 1 , jpj_crs + 1 ) )2025 mj1_crs(jj) = MAX( 0, MIN( jj - njmpp_crs + 1 , jpj_crs ) )2026 ENDDO2027 2028 ENDIF2029 2030 ! Save the parent grid information2031 jpi_full = jpi2032 jpj_full = jpj2033 jpim1_full = jpim12034 jpjm1_full = jpjm12035 nperio_full = jperio2036 2037 npolj_full = npolj2038 jpiglo_full = jpiglo2039 jpjglo_full = jpjglo2040 2041 jpj_full = jpj2042 jpi_full = jpi2043 Nis0_full = Nis02044 Njs0_full = Njs02045 Nie0_full = Nie02046 Nje0_full = Nje02047 nimpp_full = nimpp2048 njmpp_full = njmpp2049 2050 jpiall_full (:) = jpiall (:)2051 nis0all_full(:) = nis0all(:)2052 nie0all_full(:) = nie0all(:)2053 nimppt_full (:) = nimppt (:)2054 jpjall_full (:) = jpjall (:)2055 njs0all_full(:) = njs0all(:)2056 nje0all_full(:) = nje0all(:)2057 njmppt_full (:) = njmppt (:)1879 !!$ ! 1.a. Define global domain indices : take into account the interior domain only ( removes i/j=1 , i/j=jpiglo/jpjglo ) then add 2/3 grid points 1880 !!$ jpiglo_crs = INT( (jpiglo - 2) / nn_factx ) + 2 1881 !!$ ! jpjglo_crs = INT( (jpjglo - 2) / nn_facty ) + 2 ! the -2 removes j=1, j=jpj 1882 !!$ ! jpjglo_crs = INT( (jpjglo - 2) / nn_facty ) + 3 1883 !!$ jpjglo_crs = INT( (jpjglo - MOD(jpjglo, nn_facty)) / nn_facty ) + 3 1884 !!$ jpiglo_crsm1 = jpiglo_crs - 1 1885 !!$ jpjglo_crsm1 = jpjglo_crs - 1 1886 !!$ 1887 !!$ jpi_crs = ( jpiglo_crs - 2 * nn_hls + (jpni-1) ) / jpni + 2 * nn_hls 1888 !!$ jpj_crs = ( jpjglo_crsm1 - 2 * nn_hls + (jpnj-1) ) / jpnj + 2 * nn_hls 1889 !!$ 1890 !!$ IF( noso < 0 ) jpj_crs = jpj_crs + 1 ! add a local band on southern processors 1891 !!$ 1892 !!$ jpi_crsm1 = jpi_crs - 1 1893 !!$ jpj_crsm1 = jpj_crs - 1 1894 !!$ nperio_crs = jperio 1895 !!$ npolj_crs = npolj 1896 !!$ 1897 !!$ ierr = crs_dom_alloc() ! allocate most coarse grid arrays 1898 !!$ 1899 !!$ ! 2.a Define processor domain 1900 !!$ IF( .NOT. lk_mpp ) THEN 1901 !!$ nimpp_crs = 1 1902 !!$ njmpp_crs = 1 1903 !!$ Nis0_crs = 1 1904 !!$ Njs0_crs = 1 1905 !!$ Nie0_crs = jpi_crs 1906 !!$ Nje0_crs = jpj_crs 1907 !!$ ELSE 1908 !!$ ! Initialisation of most local variables - 1909 !!$ nimpp_crs = 1 1910 !!$ njmpp_crs = 1 1911 !!$ Nis0_crs = 1 1912 !!$ Njs0_crs = 1 1913 !!$ Nie0_crs = jpi_crs 1914 !!$ Nje0_crs = jpj_crs 1915 !!$ 1916 !!$ ! Calculs suivant une découpage en j 1917 !!$ DO jn = 1, jpnij, jpni 1918 !!$ IF( jn < ( jpnij - jpni + 1 ) ) THEN 1919 !!$ nje0all_crs(jn) = AINT( REAL( ( jpjglo - (njmppt(jn ) - 1) ) / nn_facty, wp ) ) & 1920 !!$ & - AINT( REAL( ( jpjglo - (njmppt(jn+jpni) - 1) ) / nn_facty, wp ) ) 1921 !!$ ELSE 1922 !!$ nje0all_crs(jn) = AINT( REAL( nje0all(jn) / nn_facty, wp ) ) + 1 1923 !!$ ENDIF 1924 !!$ IF( noso < 0 ) nje0all_crs(jn) = nje0all_crs(jn) + 1 1925 !!$ SELECT CASE( ibonjt(jn) ) 1926 !!$ CASE ( -1 ) 1927 !!$ IF( MOD( jpjglo - njmppt(jn), nn_facty) > 0 ) nje0all_crs(jn) = nje0all_crs(jn) + 1 1928 !!$ jpjall_crs (jn) = nje0all_crs(jn) + nn_hls 1929 !!$ njs0all_crs(jn) = njs0all(jn) 1930 !!$ 1931 !!$ CASE ( 0 ) 1932 !!$ 1933 !!$ njs0all_crs(jn) = njs0all(jn) 1934 !!$ IF( njs0all(jn) == 1 ) nje0all_crs(jn) = nje0all_crs(jn) + 1 1935 !!$ nje0all_crs(jn) = nje0all_crs(jn) + nn_hls 1936 !!$ jpjall_crs (jn) = nje0all_crs(jn) + nn_hls 1937 !!$ 1938 !!$ CASE ( 1, 2 ) 1939 !!$ 1940 !!$ nje0all_crs(jn) = nje0all_crs(jn) + nn_hls 1941 !!$ jpjall_crs (jn) = nje0all_crs(jn) 1942 !!$ njs0all_crs(jn) = njs0all(jn) 1943 !!$ 1944 !!$ CASE DEFAULT 1945 !!$ CALL ctl_stop( 'STOP', 'error from crs_dom_def, you should not be there (1) ...' ) 1946 !!$ END SELECT 1947 !!$ IF( jpjall_crs(jn) > jpj_crs ) jpj_crs = jpj_crs + 1 1948 !!$ 1949 !!$ IF(njs0all_crs(jn) == 1 ) THEN 1950 !!$ njmppt_crs(jn) = 1 1951 !!$ ELSE 1952 !!$ njmppt_crs(jn) = 2 + ANINT(REAL((njmppt(jn) + 1 - MOD( jpjglo , nn_facty )) / nn_facty, wp ) ) 1953 !!$ ENDIF 1954 !!$ 1955 !!$ DO jj = jn + 1, jn + jpni - 1 1956 !!$ nje0all_crs(jj) = nje0all_crs(jn) 1957 !!$ jpjall_crs (jj) = jpjall_crs(jn) 1958 !!$ njs0all_crs(jj) = njs0all_crs(jn) 1959 !!$ njmppt_crs (jj) = njmppt_crs(jn) 1960 !!$ ENDDO 1961 !!$ ENDDO 1962 !!$ Nje0_crs = nje0all_crs(narea) 1963 !!$ jpj_crs = jpjall_crs (narea) 1964 !!$ Njs0_crs = njs0all_crs(narea) 1965 !!$ njmpp_crs = njmppt_crs (narea) 1966 !!$ 1967 !!$ ! Calcul suivant un decoupage en i 1968 !!$ DO jn = 1, jpni 1969 !!$ IF( jn == 1 ) THEN 1970 !!$ nie0all_crs(jn) = AINT( REAL( ( nimppt(jn ) - 1 + jpiall(jn ) ) / nn_factx, wp) ) 1971 !!$ ELSE 1972 !!$ nie0all_crs(jn) = AINT( REAL( ( nimppt(jn ) - 1 + jpiall(jn ) ) / nn_factx, wp) ) & 1973 !!$ & - AINT( REAL( ( nimppt(jn-1) - 1 + jpiall(jn-1) ) / nn_factx, wp) ) 1974 !!$ ENDIF 1975 !!$ 1976 !!$ SELECT CASE( ibonit(jn) ) 1977 !!$ CASE ( -1 ) 1978 !!$ nie0all_crs(jn) = nie0all_crs(jn) + nn_hls 1979 !!$ jpiall_crs (jn) = nie0all_crs(jn) + nn_hls 1980 !!$ nis0all_crs(jn) = nis0all(jn) 1981 !!$ 1982 !!$ CASE ( 0 ) 1983 !!$ nie0all_crs(jn) = nie0all_crs(jn) + nn_hls 1984 !!$ jpiall_crs (jn) = nie0all_crs(jn) + nn_hls 1985 !!$ nis0all_crs(jn) = nis0all(jn) 1986 !!$ 1987 !!$ CASE ( 1, 2 ) 1988 !!$ IF( MOD( jpiglo - nimppt(jn), nn_factx) > 0 ) nie0all_crs(jn) = nie0all_crs(jn) + 1 1989 !!$ nie0all_crs(jn) = nie0all_crs(jn) + nn_hls 1990 !!$ jpiall_crs (jn) = nie0all_crs(jn) 1991 !!$ nis0all_crs(jn) = nis0all(jn) 1992 !!$ 1993 !!$ CASE DEFAULT 1994 !!$ CALL ctl_stop( 'STOP', 'error from crs_dom_def, you should not be there (2) ...' ) 1995 !!$ END SELECT 1996 !!$ 1997 !!$ nimppt_crs(jn) = ANINT( REAL( (nimppt(jn) + 1 ) / nn_factx, wp ) ) + 1 1998 !!$ DO jj = jn + jpni , jpnij, jpni 1999 !!$ nie0all_crs(jj) = nie0all_crs(jn) 2000 !!$ jpiall_crs (jj) = jpiall_crs (jn) 2001 !!$ nis0all_crs(jj) = nis0all_crs(jn) 2002 !!$ nimppt_crs (jj) = nimppt_crs (jn) 2003 !!$ ENDDO 2004 !!$ ENDDO 2005 !!$ 2006 !!$ Nie0_crs = nie0all_crs(narea) 2007 !!$ jpi_crs = jpiall_crs (narea) 2008 !!$ Nis0_crs = nis0all_crs(narea) 2009 !!$ nimpp_crs = nimppt_crs (narea) 2010 !!$ 2011 !!$ DO ji = 1, jpi_crs 2012 !!$ mig_crs(ji) = ji + nimpp_crs - 1 2013 !!$ ENDDO 2014 !!$ DO jj = 1, jpj_crs 2015 !!$ mjg_crs(jj) = jj + njmpp_crs - 1! 2016 !!$ ENDDO 2017 !!$ 2018 !!$ DO ji = 1, jpiglo_crs 2019 !!$ mi0_crs(ji) = MAX( 1, MIN( ji - nimpp_crs + 1 , jpi_crs + 1 ) ) 2020 !!$ mi1_crs(ji) = MAX( 0, MIN( ji - nimpp_crs + 1 , jpi_crs ) ) 2021 !!$ ENDDO 2022 !!$ 2023 !!$ DO jj = 1, jpjglo_crs 2024 !!$ mj0_crs(jj) = MAX( 1, MIN( jj - njmpp_crs + 1 , jpj_crs + 1 ) ) 2025 !!$ mj1_crs(jj) = MAX( 0, MIN( jj - njmpp_crs + 1 , jpj_crs ) ) 2026 !!$ ENDDO 2027 !!$ 2028 !!$ ENDIF 2029 !!$ 2030 !!$ ! Save the parent grid information 2031 !!$ jpi_full = jpi 2032 !!$ jpj_full = jpj 2033 !!$ jpim1_full = jpim1 2034 !!$ jpjm1_full = jpjm1 2035 !!$ nperio_full = jperio 2036 !!$ 2037 !!$ npolj_full = npolj 2038 !!$ jpiglo_full = jpiglo 2039 !!$ jpjglo_full = jpjglo 2040 !!$ 2041 !!$ jpj_full = jpj 2042 !!$ jpi_full = jpi 2043 !!$ Nis0_full = Nis0 2044 !!$ Njs0_full = Njs0 2045 !!$ Nie0_full = Nie0 2046 !!$ Nje0_full = Nje0 2047 !!$ nimpp_full = nimpp 2048 !!$ njmpp_full = njmpp 2049 !!$ 2050 !!$ jpiall_full (:) = jpiall (:) 2051 !!$ nis0all_full(:) = nis0all(:) 2052 !!$ nie0all_full(:) = nie0all(:) 2053 !!$ nimppt_full (:) = nimppt (:) 2054 !!$ jpjall_full (:) = jpjall (:) 2055 !!$ njs0all_full(:) = njs0all(:) 2056 !!$ nje0all_full(:) = nje0all(:) 2057 !!$ njmppt_full (:) = njmppt (:) 2058 2058 2059 2059 CALL dom_grid_crs !swich de grille … … 2097 2097 IF ( nresty == 0 ) THEN 2098 2098 mybinctr = mybinctr - 1 2099 IF ( jperio == 3 .OR. jperio == 4 ) nperio_crs = jperio + 22100 IF ( jperio == 5 .OR. jperio == 6 ) nperio_crs = jperio - 22101 2102 IF ( npolj == 3 ) npolj_crs = 52103 IF ( npolj == 5 ) npolj_crs = 32099 !!$ IF ( jperio == 3 .OR. jperio == 4 ) nperio_crs = jperio + 2 2100 !!$ IF ( jperio == 5 .OR. jperio == 6 ) nperio_crs = jperio - 2 2101 !!$ 2102 !!$ IF ( npolj == 3 ) npolj_crs = 5 2103 !!$ IF ( npolj == 5 ) npolj_crs = 3 2104 2104 ENDIF 2105 2105 -
NEMO/branches/2021/dev_r14312_MPI_Interface/src/OCE/DOM/dom_oce.F90
r14275 r14314 73 73 ! ! = 7 bi-cyclic East-West AND North-South 74 74 LOGICAL, PUBLIC :: l_Iperio, l_Jperio ! should we explicitely take care I/J periodicity 75 LOGICAL, PUBLIC :: l_NFoldT, l_NFoldF 75 76 76 77 ! Tiling namelist … … 85 86 86 87 ! !: domain MPP decomposition parameters 87 INTEGER , PUBLIC :: nimpp, njmpp !: i- & j-indexes for mpp-subdomain left bottom 88 INTEGER , PUBLIC :: narea !: number for local area = MPI rank + 1 89 INTEGER , PUBLIC :: nbondi, nbondj !: mark of i- and j-direction local boundaries 90 INTEGER, ALLOCATABLE, PUBLIC :: nbondi_bdy(:) !: mark i-direction local boundaries for BDY open boundaries 91 INTEGER, ALLOCATABLE, PUBLIC :: nbondj_bdy(:) !: mark j-direction local boundaries for BDY open boundaries 92 INTEGER, ALLOCATABLE, PUBLIC :: nbondi_bdy_b(:) !: mark i-direction of neighbours local boundaries for BDY open boundaries 93 INTEGER, ALLOCATABLE, PUBLIC :: nbondj_bdy_b(:) !: mark j-direction of neighbours local boundaries for BDY open boundaries 94 95 INTEGER, PUBLIC :: npolj !: north fold mark (0, 3 or 4) 96 INTEGER, PUBLIC :: noea, nowe !: index of the local neighboring processors in 97 INTEGER, PUBLIC :: noso, nono !: east, west, south and north directions 98 INTEGER, PUBLIC :: nones, nonws !: north-east, north-west directions for sending 99 INTEGER, PUBLIC :: noses, nosws !: south-east, south-west directions for sending 100 INTEGER, PUBLIC :: noner, nonwr !: north-east, north-west directions for receiving 101 INTEGER, PUBLIC :: noser, noswr !: south-east, south-west directions for receiving 102 INTEGER, PUBLIC :: nidom !: ??? 88 INTEGER , PUBLIC :: nimpp, njmpp !: i- & j-indexes for mpp-subdomain left bottom 89 INTEGER , PUBLIC :: narea !: number for local area (starting at 1) = MPI rank + 1 90 INTEGER, PUBLIC :: nidom !: IOIPSL things... 103 91 104 92 INTEGER, PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:) :: mig !: local ==> global domain, including halos (jpiglo), i-index … … 110 98 INTEGER, PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:) :: mj0, mj1 !: global, including halos (jpjglo) ==> local domain j-index 111 99 ! !: (mj0=1 and mj1=0 if global index not in local domain) 112 INTEGER, PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:) :: nimppt, njmppt !: i-, j-indexes for each processor113 INTEGER, PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:) :: ibonit, ibonjt !: i-, j- processor neighbour existence114 INTEGER, PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:) :: jpiall, jpjall !: dimensions of all subdomain115 INTEGER, PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:) :: nis0all, njs0all !: first, last indoor index for all i-subdomain116 INTEGER, PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:) :: nie0all, nje0all !: first, last indoor index for all j-subdomain117 100 INTEGER, PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:) :: nfimpp, nfproc, nfjpi 118 101 -
NEMO/branches/2021/dev_r14312_MPI_Interface/src/OCE/ICB/icbini.F90
r14030 r14314 189 189 190 190 ! north fold 191 IF( npolj > 0) THEN191 IF( l_NFoldT .OR. l_NFoldF ) THEN 192 192 ! 193 193 ! icebergs in row nicbej+1 get passed across fold … … 235 235 WRITE(numicb,*) "j point" 236 236 WRITE(numicb,*) (INT(src_calving(ji,jj)), jj=1,jpj) 237 IF( npolj > 0) THEN237 IF( l_NFoldT .OR. l_NFoldF ) THEN 238 238 WRITE(numicb,*) 'north fold destination points ' 239 239 WRITE(numicb,*) nicbfldpts -
NEMO/branches/2021/dev_r14312_MPI_Interface/src/OCE/ICB/icblbc.F90
r14229 r14314 105 105 IF( l_Jperio) CALL ctl_stop(' north-south periodicity not implemented for icebergs') 106 106 ! north fold 107 IF( npolj /= 0) CALL icb_lbc_nfld()107 IF( l_NFoldT .OR. l_NFoldF ) CALL icb_lbc_nfld() 108 108 ! 109 109 END SUBROUTINE icb_lbc … … 179 179 ipe_W = -1 180 180 ipe_E = -1 181 IF( nbondi .EQ. 0 .OR. nbondi .EQ. 1) ipe_W = nowe182 IF( nbondi .EQ. -1 .OR. nbondi .EQ. 0) ipe_E = noea183 IF( nbondj .EQ. 0 .OR. nbondj .EQ. 1) ipe_S = noso184 IF( nbondj .EQ. -1 .OR. nbondj .EQ. 0) ipe_N = nono181 IF( mpinei(jpwe) >= 0 ) ipe_W = mpinei(jpwe) 182 IF( mpinei(jpea) >= 0 ) ipe_E = mpinei(jpea) 183 IF( mpinei(jpso) >= 0 ) ipe_S = mpinei(jpso) 184 IF( mpinei(jpno) >= 0 ) ipe_N = mpinei(jpno) 185 185 ! 186 186 ! at northern line of processors with north fold handle bergs differently 187 IF( npolj > 0 )ipe_N = -1187 IF( l_NFoldT .OR. l_NFoldF ) ipe_N = -1 188 188 189 189 ! if there's only one processor in x direction then don't let mpp try to handle periodicity … … 200 200 WRITE(numicb,*) 'processor nimpp : ', nimpp 201 201 WRITE(numicb,*) 'processor njmpp : ', njmpp 202 WRITE(numicb,*) 'processor nbondi: ', nbondi203 WRITE(numicb,*) 'processor nbondj: ', nbondj204 202 CALL flush( numicb ) 205 203 ENDIF … … 271 269 ! pattern here is copied from lib_mpp code 272 270 273 SELECT CASE ( nbondi ) 274 CASE( -1 ) 275 zwebergs(1) = ibergs_to_send_e 276 CALL mppsend( 12, zwebergs(1), 1, ipe_E, iml_req1) 277 CALL mpprecv( 11, zewbergs(2), 1, ipe_E ) 278 CALL mpi_wait( iml_req1, iml_stat, iml_err ) 279 ibergs_rcvd_from_e = INT( zewbergs(2) ) 280 CASE( 0 ) 281 zewbergs(1) = ibergs_to_send_w 282 zwebergs(1) = ibergs_to_send_e 283 CALL mppsend( 11, zewbergs(1), 1, ipe_W, iml_req2) 284 CALL mppsend( 12, zwebergs(1), 1, ipe_E, iml_req3) 285 CALL mpprecv( 11, zewbergs(2), 1, ipe_E ) 286 CALL mpprecv( 12, zwebergs(2), 1, ipe_W ) 287 CALL mpi_wait( iml_req2, iml_stat, iml_err ) 288 CALL mpi_wait( iml_req3, iml_stat, iml_err ) 289 ibergs_rcvd_from_e = INT( zewbergs(2) ) 290 ibergs_rcvd_from_w = INT( zwebergs(2) ) 291 CASE( 1 ) 292 zewbergs(1) = ibergs_to_send_w 293 CALL mppsend( 11, zewbergs(1), 1, ipe_W, iml_req4) 294 CALL mpprecv( 12, zwebergs(2), 1, ipe_W ) 295 CALL mpi_wait( iml_req4, iml_stat, iml_err ) 296 ibergs_rcvd_from_w = INT( zwebergs(2) ) 297 END SELECT 271 IF( mpinei(jpwe) >= 0 ) zewbergs(1) = ibergs_to_send_w 272 IF( mpinei(jpea) >= 0 ) zwebergs(1) = ibergs_to_send_e 273 IF( mpinei(jpwe) >= 0 ) CALL mppsend( 11, zewbergs(1), 1, ipe_W, iml_req2) 274 IF( mpinei(jpea) >= 0 ) CALL mppsend( 12, zwebergs(1), 1, ipe_E, iml_req3) 275 IF( mpinei(jpea) >= 0 ) CALL mpprecv( 11, zewbergs(2), 1, ipe_E ) 276 IF( mpinei(jpwe) >= 0 ) CALL mpprecv( 12, zwebergs(2), 1, ipe_W ) 277 IF( mpinei(jpwe) >= 0 ) CALL mpi_wait( iml_req2, iml_stat, iml_err ) 278 IF( mpinei(jpea) >= 0 ) CALL mpi_wait( iml_req3, iml_stat, iml_err ) 279 IF( mpinei(jpea) >= 0 ) ibergs_rcvd_from_e = INT( zewbergs(2) ) 280 IF( mpinei(jpwe) >= 0 ) ibergs_rcvd_from_w = INT( zwebergs(2) ) 281 298 282 IF( nn_verbose_level >= 3) THEN 299 283 WRITE(numicb,*) 'bergstep ',nktberg,' recv ew: ', ibergs_rcvd_from_w, ibergs_rcvd_from_e 300 284 CALL flush(numicb) 301 285 ENDIF 302 303 SELECT CASE ( nbondi ) 304 CASE( -1 ) 305 IF( ibergs_to_send_e > 0 ) CALL mppsend( 14, obuffer_e%data, ibergs_to_send_e*jp_buffer_width, ipe_E, iml_req1 ) 306 IF( ibergs_rcvd_from_e > 0 ) THEN 307 CALL icb_increase_ibuffer(ibuffer_e, ibergs_rcvd_from_e) 308 CALL mpprecv( 13, ibuffer_e%data, ibergs_rcvd_from_e*jp_buffer_width ) 309 ENDIF 310 IF( ibergs_to_send_e > 0 ) CALL mpi_wait( iml_req1, iml_stat, iml_err ) 311 DO i = 1, ibergs_rcvd_from_e 312 IF( nn_verbose_level >= 4 ) THEN 313 WRITE(numicb,*) 'bergstep ',nktberg,' unpacking berg ',INT(ibuffer_e%data(16,i)),' from east' 314 CALL flush( numicb ) 315 ENDIF 316 CALL icb_unpack_from_buffer(first_berg, ibuffer_e, i) 317 ENDDO 318 CASE( 0 ) 319 IF( ibergs_to_send_w > 0 ) CALL mppsend( 13, obuffer_w%data, ibergs_to_send_w*jp_buffer_width, ipe_W, iml_req2 ) 320 IF( ibergs_to_send_e > 0 ) CALL mppsend( 14, obuffer_e%data, ibergs_to_send_e*jp_buffer_width, ipe_E, iml_req3 ) 321 IF( ibergs_rcvd_from_e > 0 ) THEN 322 CALL icb_increase_ibuffer(ibuffer_e, ibergs_rcvd_from_e) 323 CALL mpprecv( 13, ibuffer_e%data, ibergs_rcvd_from_e*jp_buffer_width ) 324 ENDIF 325 IF( ibergs_rcvd_from_w > 0 ) THEN 326 CALL icb_increase_ibuffer(ibuffer_w, ibergs_rcvd_from_w) 327 CALL mpprecv( 14, ibuffer_w%data, ibergs_rcvd_from_w*jp_buffer_width ) 328 ENDIF 329 IF( ibergs_to_send_w > 0 ) CALL mpi_wait( iml_req2, iml_stat, iml_err ) 330 IF( ibergs_to_send_e > 0 ) CALL mpi_wait( iml_req3, iml_stat, iml_err ) 331 DO i = 1, ibergs_rcvd_from_e 332 IF( nn_verbose_level >= 4 ) THEN 333 WRITE(numicb,*) 'bergstep ',nktberg,' unpacking berg ',INT(ibuffer_e%data(16,i)),' from east' 334 CALL flush( numicb ) 335 ENDIF 336 CALL icb_unpack_from_buffer(first_berg, ibuffer_e, i) 337 END DO 338 DO i = 1, ibergs_rcvd_from_w 339 IF( nn_verbose_level >= 4 ) THEN 340 WRITE(numicb,*) 'bergstep ',nktberg,' unpacking berg ',INT(ibuffer_w%data(16,i)),' from west' 341 CALL flush( numicb ) 342 ENDIF 343 CALL icb_unpack_from_buffer(first_berg, ibuffer_w, i) 344 ENDDO 345 CASE( 1 ) 346 IF( ibergs_to_send_w > 0 ) CALL mppsend( 13, obuffer_w%data, ibergs_to_send_w*jp_buffer_width, ipe_W, iml_req4 ) 347 IF( ibergs_rcvd_from_w > 0 ) THEN 348 CALL icb_increase_ibuffer(ibuffer_w, ibergs_rcvd_from_w) 349 CALL mpprecv( 14, ibuffer_w%data, ibergs_rcvd_from_w*jp_buffer_width ) 350 ENDIF 351 IF( ibergs_to_send_w > 0 ) CALL mpi_wait( iml_req4, iml_stat, iml_err ) 352 DO i = 1, ibergs_rcvd_from_w 353 IF( nn_verbose_level >= 4 ) THEN 354 WRITE(numicb,*) 'bergstep ',nktberg,' unpacking berg ',INT(ibuffer_w%data(16,i)),' from west' 355 CALL flush( numicb ) 356 ENDIF 357 CALL icb_unpack_from_buffer(first_berg, ibuffer_w, i) 358 END DO 359 END SELECT 286 287 IF( ibergs_to_send_w > 0 ) CALL mppsend( 13, obuffer_w%DATA, ibergs_to_send_w*jp_buffer_width, ipe_W, iml_req2 ) 288 IF( ibergs_to_send_e > 0 ) CALL mppsend( 14, obuffer_e%DATA, ibergs_to_send_e*jp_buffer_width, ipe_E, iml_req3 ) 289 IF( ibergs_rcvd_from_e > 0 ) THEN 290 CALL icb_increase_ibuffer(ibuffer_e, ibergs_rcvd_from_e) 291 CALL mpprecv( 13, ibuffer_e%DATA, ibergs_rcvd_from_e*jp_buffer_width ) 292 ENDIF 293 IF( ibergs_rcvd_from_w > 0 ) THEN 294 CALL icb_increase_ibuffer(ibuffer_w, ibergs_rcvd_from_w) 295 CALL mpprecv( 14, ibuffer_w%DATA, ibergs_rcvd_from_w*jp_buffer_width ) 296 ENDIF 297 IF( ibergs_to_send_w > 0 ) CALL mpi_wait( iml_req2, iml_stat, iml_err ) 298 IF( ibergs_to_send_e > 0 ) CALL mpi_wait( iml_req3, iml_stat, iml_err ) 299 DO i = 1, ibergs_rcvd_from_e 300 IF( nn_verbose_level >= 4 ) THEN 301 WRITE(numicb,*) 'bergstep ',nktberg,' unpacking berg ',INT(ibuffer_e%DATA(16,i)),' from east' 302 CALL FLUSH( numicb ) 303 ENDIF 304 CALL icb_unpack_from_buffer(first_berg, ibuffer_e, i) 305 END DO 306 DO i = 1, ibergs_rcvd_from_w 307 IF( nn_verbose_level >= 4 ) THEN 308 WRITE(numicb,*) 'bergstep ',nktberg,' unpacking berg ',INT(ibuffer_w%DATA(16,i)),' from west' 309 CALL FLUSH( numicb ) 310 ENDIF 311 CALL icb_unpack_from_buffer(first_berg, ibuffer_w, i) 312 ENDDO 360 313 361 314 ! Find number of bergs that headed north/south … … 400 353 ! send bergs north 401 354 ! and receive bergs from south (ie ones sent north) 402 403 SELECT CASE ( nbondj ) 404 CASE( -1 ) 405 zsnbergs(1) = ibergs_to_send_n 406 CALL mppsend( 16, zsnbergs(1), 1, ipe_N, iml_req1) 407 CALL mpprecv( 15, znsbergs(2), 1, ipe_N ) 408 CALL mpi_wait( iml_req1, iml_stat, iml_err ) 409 ibergs_rcvd_from_n = INT( znsbergs(2) ) 410 CASE( 0 ) 411 znsbergs(1) = ibergs_to_send_s 412 zsnbergs(1) = ibergs_to_send_n 413 CALL mppsend( 15, znsbergs(1), 1, ipe_S, iml_req2) 414 CALL mppsend( 16, zsnbergs(1), 1, ipe_N, iml_req3) 415 CALL mpprecv( 15, znsbergs(2), 1, ipe_N ) 416 CALL mpprecv( 16, zsnbergs(2), 1, ipe_S ) 417 CALL mpi_wait( iml_req2, iml_stat, iml_err ) 418 CALL mpi_wait( iml_req3, iml_stat, iml_err ) 419 ibergs_rcvd_from_n = INT( znsbergs(2) ) 420 ibergs_rcvd_from_s = INT( zsnbergs(2) ) 421 CASE( 1 ) 422 znsbergs(1) = ibergs_to_send_s 423 CALL mppsend( 15, znsbergs(1), 1, ipe_S, iml_req4) 424 CALL mpprecv( 16, zsnbergs(2), 1, ipe_S ) 425 CALL mpi_wait( iml_req4, iml_stat, iml_err ) 426 ibergs_rcvd_from_s = INT( zsnbergs(2) ) 427 END SELECT 428 if( nn_verbose_level >= 3) then 429 write(numicb,*) 'bergstep ',nktberg,' recv ns: ', ibergs_rcvd_from_s, ibergs_rcvd_from_n 430 call flush(numicb) 431 endif 432 433 SELECT CASE ( nbondj ) 434 CASE( -1 ) 435 IF( ibergs_to_send_n > 0 ) CALL mppsend( 18, obuffer_n%data, ibergs_to_send_n*jp_buffer_width, ipe_N, iml_req1 ) 436 IF( ibergs_rcvd_from_n > 0 ) THEN 437 CALL icb_increase_ibuffer(ibuffer_n, ibergs_rcvd_from_n) 438 CALL mpprecv( 17, ibuffer_n%data, ibergs_rcvd_from_n*jp_buffer_width ) 439 ENDIF 440 IF( ibergs_to_send_n > 0 ) CALL mpi_wait( iml_req1, iml_stat, iml_err ) 441 DO i = 1, ibergs_rcvd_from_n 442 IF( nn_verbose_level >= 4 ) THEN 443 WRITE(numicb,*) 'bergstep ',nktberg,' unpacking berg ',INT(ibuffer_n%data(16,i)),' from north' 444 CALL flush( numicb ) 445 ENDIF 446 CALL icb_unpack_from_buffer(first_berg, ibuffer_n, i) 447 END DO 448 CASE( 0 ) 449 IF( ibergs_to_send_s > 0 ) CALL mppsend( 17, obuffer_s%data, ibergs_to_send_s*jp_buffer_width, ipe_S, iml_req2 ) 450 IF( ibergs_to_send_n > 0 ) CALL mppsend( 18, obuffer_n%data, ibergs_to_send_n*jp_buffer_width, ipe_N, iml_req3 ) 451 IF( ibergs_rcvd_from_n > 0 ) THEN 452 CALL icb_increase_ibuffer(ibuffer_n, ibergs_rcvd_from_n) 453 CALL mpprecv( 17, ibuffer_n%data, ibergs_rcvd_from_n*jp_buffer_width ) 454 ENDIF 455 IF( ibergs_rcvd_from_s > 0 ) THEN 456 CALL icb_increase_ibuffer(ibuffer_s, ibergs_rcvd_from_s) 457 CALL mpprecv( 18, ibuffer_s%data, ibergs_rcvd_from_s*jp_buffer_width ) 458 ENDIF 459 IF( ibergs_to_send_s > 0 ) CALL mpi_wait( iml_req2, iml_stat, iml_err ) 460 IF( ibergs_to_send_n > 0 ) CALL mpi_wait( iml_req3, iml_stat, iml_err ) 461 DO i = 1, ibergs_rcvd_from_n 462 IF( nn_verbose_level >= 4 ) THEN 463 WRITE(numicb,*) 'bergstep ',nktberg,' unpacking berg ',INT(ibuffer_n%data(16,i)),' from north' 464 CALL flush( numicb ) 465 ENDIF 466 CALL icb_unpack_from_buffer(first_berg, ibuffer_n, i) 467 END DO 468 DO i = 1, ibergs_rcvd_from_s 469 IF( nn_verbose_level >= 4 ) THEN 470 WRITE(numicb,*) 'bergstep ',nktberg,' unpacking berg ',INT(ibuffer_s%data(16,i)),' from south' 471 CALL flush( numicb ) 472 ENDIF 473 CALL icb_unpack_from_buffer(first_berg, ibuffer_s, i) 474 ENDDO 475 CASE( 1 ) 476 IF( ibergs_to_send_s > 0 ) CALL mppsend( 17, obuffer_s%data, ibergs_to_send_s*jp_buffer_width, ipe_S, iml_req4 ) 477 IF( ibergs_rcvd_from_s > 0 ) THEN 478 CALL icb_increase_ibuffer(ibuffer_s, ibergs_rcvd_from_s) 479 CALL mpprecv( 18, ibuffer_s%data, ibergs_rcvd_from_s*jp_buffer_width ) 480 ENDIF 481 IF( ibergs_to_send_s > 0 ) CALL mpi_wait( iml_req4, iml_stat, iml_err ) 482 DO i = 1, ibergs_rcvd_from_s 483 IF( nn_verbose_level >= 4 ) THEN 484 WRITE(numicb,*) 'bergstep ',nktberg,' unpacking berg ',INT(ibuffer_s%data(16,i)),' from south' 485 CALL flush( numicb ) 486 ENDIF 487 CALL icb_unpack_from_buffer(first_berg, ibuffer_s, i) 488 END DO 489 END SELECT 490 355 356 IF( mpinei(jpso) >= 0 ) znsbergs(1) = ibergs_to_send_s 357 IF( mpinei(jpno) >= 0 ) zsnbergs(1) = ibergs_to_send_n 358 IF( mpinei(jpso) >= 0 ) CALL mppsend( 15, znsbergs(1), 1, ipe_S, iml_req2) 359 IF( mpinei(jpno) >= 0 ) CALL mppsend( 16, zsnbergs(1), 1, ipe_N, iml_req3) 360 IF( mpinei(jpno) >= 0 ) CALL mpprecv( 15, znsbergs(2), 1, ipe_N ) 361 IF( mpinei(jpso) >= 0 ) CALL mpprecv( 16, zsnbergs(2), 1, ipe_S ) 362 IF( mpinei(jpso) >= 0 ) CALL mpi_wait( iml_req2, iml_stat, iml_err ) 363 IF( mpinei(jpno) >= 0 ) CALL mpi_wait( iml_req3, iml_stat, iml_err ) 364 IF( mpinei(jpno) >= 0 ) ibergs_rcvd_from_n = INT( znsbergs(2) ) 365 IF( mpinei(jpso) >= 0 ) ibergs_rcvd_from_s = INT( zsnbergs(2) ) 366 367 IF( nn_verbose_level >= 3) THEN 368 WRITE(numicb,*) 'bergstep ',nktberg,' recv ns: ', ibergs_rcvd_from_s, ibergs_rcvd_from_n 369 CALL FLUSH(numicb) 370 ENDIF 371 372 IF( ibergs_to_send_s > 0 ) CALL mppsend( 17, obuffer_s%DATA, ibergs_to_send_s*jp_buffer_width, ipe_S, iml_req2 ) 373 IF( ibergs_to_send_n > 0 ) CALL mppsend( 18, obuffer_n%DATA, ibergs_to_send_n*jp_buffer_width, ipe_N, iml_req3 ) 374 IF( ibergs_rcvd_from_n > 0 ) THEN 375 CALL icb_increase_ibuffer(ibuffer_n, ibergs_rcvd_from_n) 376 CALL mpprecv( 17, ibuffer_n%DATA, ibergs_rcvd_from_n*jp_buffer_width ) 377 ENDIF 378 IF( ibergs_rcvd_from_s > 0 ) THEN 379 CALL icb_increase_ibuffer(ibuffer_s, ibergs_rcvd_from_s) 380 CALL mpprecv( 18, ibuffer_s%DATA, ibergs_rcvd_from_s*jp_buffer_width ) 381 ENDIF 382 IF( ibergs_to_send_s > 0 ) CALL mpi_wait( iml_req2, iml_stat, iml_err ) 383 IF( ibergs_to_send_n > 0 ) CALL mpi_wait( iml_req3, iml_stat, iml_err ) 384 DO i = 1, ibergs_rcvd_from_n 385 IF( nn_verbose_level >= 4 ) THEN 386 WRITE(numicb,*) 'bergstep ',nktberg,' unpacking berg ',INT(ibuffer_n%DATA(16,i)),' from north' 387 CALL FLUSH( numicb ) 388 ENDIF 389 CALL icb_unpack_from_buffer(first_berg, ibuffer_n, i) 390 END DO 391 DO i = 1, ibergs_rcvd_from_s 392 IF( nn_verbose_level >= 4 ) THEN 393 WRITE(numicb,*) 'bergstep ',nktberg,' unpacking berg ',INT(ibuffer_s%DATA(16,i)),' from south' 394 CALL FLUSH( numicb ) 395 ENDIF 396 CALL icb_unpack_from_buffer(first_berg, ibuffer_s, i) 397 ENDDO 398 491 399 IF( nn_verbose_level > 0 ) THEN 492 400 ! compare the number of icebergs on this processor from the start to the end … … 527 435 ! deal with north fold if we necessary when there is more than one top row processor 528 436 ! note that for jpni=1 north fold has been dealt with above in call to icb_lbc 529 IF( npolj /= 0.AND. jpni > 1 ) CALL icb_lbc_mpp_nfld( )437 IF( ( l_NFoldT .OR. l_NFoldF ) .AND. jpni > 1 ) CALL icb_lbc_mpp_nfld( ) 530 438 531 439 IF( nn_verbose_level > 0 ) THEN -
NEMO/branches/2021/dev_r14312_MPI_Interface/src/OCE/LBC/lbc_lnk_multi_generic.h90
r13982 r14314 49 49 CHARACTER(len=1) , OPTIONAL , INTENT(in ) :: cdna2 , cdna3 , cdna4 , cdna5 , cdna6 , cdna7 , cdna8 , cdna9, & 50 50 & cdna10, cdna11, cdna12, cdna13, cdna14, cdna15, cdna16 51 REAL( wp), INTENT(in ) :: psgn1 ! sign used across the north fold52 REAL( wp), OPTIONAL , INTENT(in ) :: psgn2 , psgn3 , psgn4 , psgn5 , psgn6 , psgn7 , psgn8 , psgn9, &51 REAL(PRECISION) , INTENT(in ) :: psgn1 ! sign used across the north fold 52 REAL(PRECISION) , OPTIONAL , INTENT(in ) :: psgn2 , psgn3 , psgn4 , psgn5 , psgn6 , psgn7 , psgn8 , psgn9, & 53 53 & psgn10, psgn11, psgn12, psgn13, psgn14, psgn15, psgn16 54 54 INTEGER , OPTIONAL , INTENT(in ) :: kfillmode ! filling method for halo over land (default = constant) 55 REAL( wp), OPTIONAL , INTENT(in ) :: pfillval ! background value (used at closed boundaries)55 REAL(PRECISION) , OPTIONAL , INTENT(in ) :: pfillval ! background value (used at closed boundaries) 56 56 LOGICAL, DIMENSION(4), OPTIONAL , INTENT(in ) :: lsend, lrecv ! indicate how communications are to be carried out 57 57 LOGICAL , OPTIONAL , INTENT(in ) :: ncsten … … 60 60 PTR_TYPE , DIMENSION(16) :: ptab_ptr ! pointer array 61 61 CHARACTER(len=1) , DIMENSION(16) :: cdna_ptr ! nature of ptab_ptr grid-points 62 REAL( wp), DIMENSION(16) :: psgn_ptr ! sign used across the north fold boundary62 REAL(PRECISION) , DIMENSION(16) :: psgn_ptr ! sign used across the north fold boundary 63 63 !!--------------------------------------------------------------------- 64 64 ! … … 94 94 ARRAY_TYPE(:,:,:,:) , TARGET, INTENT(inout) :: ptab ! arrays on which the lbc is applied 95 95 CHARACTER(len=1) , INTENT(in ) :: cdna ! nature of pt2d array grid-points 96 REAL( wp), INTENT(in ) :: psgn ! sign used across the north fold boundary96 REAL(PRECISION) , INTENT(in ) :: psgn ! sign used across the north fold boundary 97 97 PTR_TYPE , DIMENSION(:), INTENT(inout) :: ptab_ptr ! array of pointers 98 98 CHARACTER(len=1), DIMENSION(:), INTENT(inout) :: cdna_ptr ! nature of pt2d_array array grid-points 99 REAL( wp), DIMENSION(:), INTENT(inout) :: psgn_ptr ! sign used across the north fold boundary99 REAL(PRECISION) , DIMENSION(:), INTENT(inout) :: psgn_ptr ! sign used across the north fold boundary 100 100 INTEGER , INTENT(inout) :: kfld ! number of elements that has been attributed 101 101 !!--------------------------------------------------------------------- -
NEMO/branches/2021/dev_r14312_MPI_Interface/src/OCE/LBC/lbc_lnk_nc_generic.h90
r14072 r14314 49 49 CHARACTER(len=1) , OPTIONAL , INTENT(in ) :: cdna2, cdna3, cdna4, cdna5, cdna6, cdna7, cdna8, cdna9, & 50 50 & cdna10, cdna11, cdna12, cdna13, cdna14, cdna15, cdna16 51 REAL( wp), INTENT(in ) :: psgn1 ! sign used across the north fold52 REAL( wp), OPTIONAL , INTENT(in ) :: psgn2, psgn3, psgn4, psgn5, psgn6, psgn7, psgn8, psgn9, &51 REAL(PRECISION) , INTENT(in ) :: psgn1 ! sign used across the north fold 52 REAL(PRECISION) , OPTIONAL , INTENT(in ) :: psgn2, psgn3, psgn4, psgn5, psgn6, psgn7, psgn8, psgn9, & 53 53 & psgn10, psgn11, psgn12, psgn13, psgn14, psgn15, psgn16 54 54 INTEGER , OPTIONAL , INTENT(in ) :: kfillmode ! filling method for halo over land (default = constant) 55 REAL( wp), OPTIONAL , INTENT(in ) :: pfillval ! background value (used at closed boundaries)55 REAL(PRECISION) , OPTIONAL , INTENT(in ) :: pfillval ! background value (used at closed boundaries) 56 56 LOGICAL, DIMENSION(4), OPTIONAL , INTENT(in ) :: lsend, lrecv ! indicate how communications are to be carried out 57 57 LOGICAL , OPTIONAL , INTENT(in ) :: ncsten … … 60 60 PTR_TYPE , DIMENSION(16) :: ptab_ptr ! pointer array 61 61 CHARACTER(len=1) , DIMENSION(16) :: cdna_ptr ! nature of ptab_ptr grid-points 62 REAL( wp), DIMENSION(16) :: psgn_ptr ! sign used across the north fold boundary62 REAL(PRECISION) , DIMENSION(16) :: psgn_ptr ! sign used across the north fold boundary 63 63 !!--------------------------------------------------------------------- 64 64 ! … … 94 94 ARRAY_TYPE(:,:,:,:) , TARGET, INTENT(inout) :: ptab ! arrays on which the lbc is applied 95 95 CHARACTER(len=1) , INTENT(in ) :: cdna ! nature of pt2d array grid-points 96 REAL( wp), INTENT(in ) :: psgn ! sign used across the north fold boundary96 REAL(PRECISION) , INTENT(in ) :: psgn ! sign used across the north fold boundary 97 97 PTR_TYPE , DIMENSION(:), INTENT(inout) :: ptab_ptr ! array of pointers 98 98 CHARACTER(len=1), DIMENSION(:), INTENT(inout) :: cdna_ptr ! nature of pt2d_array array grid-points 99 REAL( wp), DIMENSION(:), INTENT(inout) :: psgn_ptr ! sign used across the north fold boundary99 REAL(PRECISION) , DIMENSION(:), INTENT(inout) :: psgn_ptr ! sign used across the north fold boundary 100 100 INTEGER , INTENT(inout) :: kfld ! number of elements that has been attributed 101 101 !!--------------------------------------------------------------------- -
NEMO/branches/2021/dev_r14312_MPI_Interface/src/OCE/LBC/lbc_nfd_ext_generic.h90
r13286 r14314 21 21 ARRAY_TYPE(:,1-kextj:,:,:,:) ! array or pointer of arrays on which the boundary condition is applied 22 22 CHARACTER(len=1) , INTENT(in ) :: NAT_IN(:) ! nature of array grid-points 23 REAL( wp), INTENT(in ) :: SGN_IN(:) ! sign used across the north fold boundary23 REAL(PRECISION) , INTENT(in ) :: SGN_IN(:) ! sign used across the north fold boundary 24 24 ! 25 25 INTEGER :: ji, jj, jk, jl, jh, jf ! dummy loop indices … … 43 43 DO jf = 1, ipf ! Loop on the number of arrays to be treated 44 44 ! 45 SELECT CASE ( npolj ) 46 ! 47 CASE ( 3 , 4 ) ! * North fold T-point pivot 45 IF( l_NFoldT ) THEN ! * North fold T-point pivot 48 46 ! 49 47 SELECT CASE ( NAT_IN(jf) ) … … 96 94 END SELECT 97 95 ! 98 CASE ( 5 , 6 ) ! * North fold F-point pivot 96 ENDIF ! l_NFoldT 97 ! 98 IF( l_NFoldF ) THEN ! * North fold F-point pivot 99 99 ! 100 100 SELECT CASE ( NAT_IN(jf) ) … … 139 139 END SELECT 140 140 ! 141 CASE DEFAULT ! * closed : the code probably never go through 142 ! 143 SELECT CASE ( NAT_IN(jf) ) 144 CASE ( 'T' , 'U' , 'V' , 'W' ) ! T-, U-, V-, W-points 145 ARRAY_IN(:, 1:1-kextj ,:,:,jf) = 0._wp 146 ARRAY_IN(:,ipj:ipj+kextj,:,:,jf) = 0._wp 147 CASE ( 'F' ) ! F-point 148 ARRAY_IN(:,ipj:ipj+kextj,:,:,jf) = 0._wp 149 END SELECT 150 ! 151 END SELECT ! npolj 141 ENDIF ! l_NFoldF 152 142 ! 153 143 END DO -
NEMO/branches/2021/dev_r14312_MPI_Interface/src/OCE/LBC/lbc_nfd_generic.h90
r13286 r14314 80 80 ARRAY_TYPE(:,:,:,:,:) ! array or pointer of arrays on which the boundary condition is applied 81 81 CHARACTER(len=1) , INTENT(in ) :: NAT_IN(:) ! nature of array grid-points 82 REAL( wp), INTENT(in ) :: SGN_IN(:) ! sign used across the north fold boundary82 REAL(PRECISION) , INTENT(in ) :: SGN_IN(:) ! sign used across the north fold boundary 83 83 ! 84 84 INTEGER :: ji, jj, jk, jl, jf ! dummy loop indices … … 94 94 DO jf = 1, ipf ! Loop on the number of arrays to be treated 95 95 ! 96 SELECT CASE ( npolj ) 97 ! 98 CASE ( 3 , 4 ) ! * North fold T-point pivot 96 IF( l_NFoldT ) THEN ! * North fold T-point pivot 99 97 ! 100 98 SELECT CASE ( NAT_IN(jf) ) … … 263 261 END SELECT ! NAT_IN(jf) 264 262 ! 265 CASE ( 5 , 6 ) ! * North fold F-point pivot 263 ENDIF ! l_NFoldT 264 ! 265 IF( l_NFoldF ) THEN ! * North fold F-point pivot 266 266 ! 267 267 SELECT CASE ( NAT_IN(jf) ) … … 453 453 END SELECT ! NAT_IN(jf) 454 454 ! 455 END SELECT ! npolj455 ENDIF ! l_NFoldF 456 456 ! 457 457 END DO ! ipf -
NEMO/branches/2021/dev_r14312_MPI_Interface/src/OCE/LBC/lbc_nfd_nogather_generic.h90
r13286 r14314 85 85 ARRAY2_TYPE(:,:,:,:,:) 86 86 CHARACTER(len=1) , INTENT(in ) :: NAT_IN(:) ! nature of array grid-points 87 REAL( wp), INTENT(in ) :: SGN_IN(:) ! sign used across the north fold boundary87 REAL(PRECISION) , INTENT(in ) :: SGN_IN(:) ! sign used across the north fold boundary 88 88 INTEGER, OPTIONAL, INTENT(in ) :: kfld ! number of pt3d arrays 89 89 ! … … 109 109 DO jf = 1, ipf ! Loop over the number of arrays to be processed 110 110 ! 111 SELECT CASE ( npolj ) 112 ! 113 CASE ( 3, 4 ) ! * North fold T-point pivot 111 IF( l_NFoldT ) THEN ! * North fold T-point pivot 114 112 ! 115 113 SELECT CASE ( NAT_IN(jf) ) … … 305 303 ENDIF 306 304 ! 307 305 END SELECT 308 306 ! 309 CASE ( 5, 6 ) ! * North fold F-point pivot 307 ENDIF ! l_NFoldT 308 ! 309 IF( l_NFoldF ) THEN ! * North fold F-point pivot 310 310 ! 311 311 SELECT CASE ( NAT_IN(jf) ) … … 429 429 END SELECT 430 430 ! 431 CASE DEFAULT ! * closed : the code probably never go through 432 ! 433 WRITE(*,*) 'lbc_nfd_nogather_generic: You should not have seen this print! error?', npolj 434 ! 435 END SELECT ! npolj 431 ENDIF ! l_NFoldF 436 432 ! 437 433 END DO ! End jf loop -
NEMO/branches/2021/dev_r14312_MPI_Interface/src/OCE/LBC/lbclnk.F90
r14229 r14314 541 541 !! jpi : first dimension of the local subdomain 542 542 !! jpj : second dimension of the local subdomain 543 !! kexti : number of columns for extra outer halo 544 !! kextj : number of rows for extra outer halo 545 !! nbondi : mark for "east-west local boundary" 546 !! nbondj : mark for "north-south local boundary" 547 !! noea : number for local neighboring processors 548 !! nowe : number for local neighboring processors 549 !! noso : number for local neighboring processors 550 !! nono : number for local neighboring processors 543 !! mpinei : number of neighboring domains (starting at 0, -1 if no neighbourg) 551 544 !!---------------------------------------------------------------------- 552 545 -
NEMO/branches/2021/dev_r14312_MPI_Interface/src/OCE/LBC/lib_mpp.F90
r14275 r14314 130 130 INTEGER :: MPI_SUMDD 131 131 132 ! Neighbourgs informations 133 INTEGER, DIMENSION(8), PUBLIC :: mpinei !: 8-neighbourg MPI indexes (starting at 0, -1 if no neighbourg) 134 INTEGER, PARAMETER, PUBLIC :: jpwe = 1 !: WEst 135 INTEGER, PARAMETER, PUBLIC :: jpea = 2 !: EAst 136 INTEGER, PARAMETER, PUBLIC :: jpso = 3 !: SOuth 137 INTEGER, PARAMETER, PUBLIC :: jpno = 4 !: NOrth 138 INTEGER, PARAMETER, PUBLIC :: jpsw = 5 !: South-West 139 INTEGER, PARAMETER, PUBLIC :: jpse = 6 !: South-East 140 INTEGER, PARAMETER, PUBLIC :: jpnw = 7 !: North-West 141 INTEGER, PARAMETER, PUBLIC :: jpne = 8 !: North-East 142 143 LOGICAL, DIMENSION(8), PUBLIC :: l_SelfPerio ! should we explicitely take care of I/J periodicity 144 LOGICAL, PUBLIC :: l_IdoNFold 145 132 146 ! variables used for zonal integration 133 INTEGER, PUBLIC :: ncomm_znl !: communicator made by the processors on the same zonal average134 LOGICAL, PUBLIC :: l_znl_root !: True on the 'left'most processor on the same row135 INTEGER :: ngrp_znl !group ID for the znl processors136 INTEGER :: ndim_rank_znl !number of processors on the same zonal average147 INTEGER, PUBLIC :: ncomm_znl !: communicator made by the processors on the same zonal average 148 LOGICAL, PUBLIC :: l_znl_root !: True on the 'left'most processor on the same row 149 INTEGER :: ngrp_znl !: group ID for the znl processors 150 INTEGER :: ndim_rank_znl !: number of processors on the same zonal average 137 151 INTEGER, DIMENSION(:), ALLOCATABLE, SAVE :: nrank_znl ! dimension ndim_rank_znl, number of the procs into the same znl domain 138 152 139 153 ! variables used for MPI3 neighbourhood collectives 140 INTEGER, PUBLIC :: mpi_nc_com! MPI3 neighbourhood collectives communicator141 INTEGER, PUBLIC :: mpi_nc_all_com! MPI3 neighbourhood collectives communicator (with diagionals)154 INTEGER, PUBLIC :: mpi_nc_com4 ! MPI3 neighbourhood collectives communicator 155 INTEGER, PUBLIC :: mpi_nc_com8 ! MPI3 neighbourhood collectives communicator (with diagionals) 142 156 143 157 ! North fold condition in mpp_mpi with jpni > 1 (PUBLIC for TAM) … … 185 199 186 200 LOGICAL, PUBLIC :: ln_nnogather !: namelist control of northfold comms 187 LOGICAL, PUBLIC :: l_north_nogather = .FALSE. !: internal control of northfold comms188 201 189 202 !! * Substitutions … … 1071 1084 END SUBROUTINE mpp_ini_znl 1072 1085 1086 1073 1087 SUBROUTINE mpp_ini_nc 1074 1088 !!---------------------------------------------------------------------- … … 1082 1096 ! 1083 1097 !! ** output 1084 !! mpi_nc_com = MPI3 neighbourhood collectives communicator 1085 !! mpi_nc_all_com = MPI3 neighbourhood collectives communicator 1086 !! (with diagonals) 1087 !! 1088 !!---------------------------------------------------------------------- 1089 INTEGER, DIMENSION(:), ALLOCATABLE :: ineigh, ineighalls, ineighallr 1090 INTEGER :: ideg, idegalls, idegallr, icont, icont1 1098 !! mpi_nc_com4 = MPI3 neighbourhood collectives communicator 1099 !! mpi_nc_com8 = MPI3 neighbourhood collectives communicator (with diagonals) 1100 !!---------------------------------------------------------------------- 1101 INTEGER, DIMENSION(:), ALLOCATABLE :: inei4, inei8 1102 INTEGER :: icnt4, icnt8 1091 1103 INTEGER :: ierr 1092 1104 LOGICAL, PARAMETER :: ireord = .FALSE. 1093 1094 #if ! defined key_mpi_off 1095 1096 ideg = 0 1097 idegalls = 0 1098 idegallr = 0 1099 icont = 0 1100 icont1 = 0 1101 1102 IF (nbondi .eq. 1) THEN 1103 ideg = ideg + 1 1104 ELSEIF (nbondi .eq. -1) THEN 1105 ideg = ideg + 1 1106 ELSEIF (nbondi .eq. 0) THEN 1107 ideg = ideg + 2 1108 ENDIF 1109 1110 IF (nbondj .eq. 1) THEN 1111 ideg = ideg + 1 1112 ELSEIF (nbondj .eq. -1) THEN 1113 ideg = ideg + 1 1114 ELSEIF (nbondj .eq. 0) THEN 1115 ideg = ideg + 2 1116 ENDIF 1117 1118 idegalls = ideg 1119 idegallr = ideg 1120 1121 IF (nones .ne. -1) idegalls = idegalls + 1 1122 IF (nonws .ne. -1) idegalls = idegalls + 1 1123 IF (noses .ne. -1) idegalls = idegalls + 1 1124 IF (nosws .ne. -1) idegalls = idegalls + 1 1125 IF (noner .ne. -1) idegallr = idegallr + 1 1126 IF (nonwr .ne. -1) idegallr = idegallr + 1 1127 IF (noser .ne. -1) idegallr = idegallr + 1 1128 IF (noswr .ne. -1) idegallr = idegallr + 1 1129 1130 ALLOCATE(ineigh(ideg)) 1131 ALLOCATE(ineighalls(idegalls)) 1132 ALLOCATE(ineighallr(idegallr)) 1133 1134 IF (nbondi .eq. 1) THEN 1135 icont = icont + 1 1136 ineigh(icont) = nowe 1137 ineighalls(icont) = nowe 1138 ineighallr(icont) = nowe 1139 ELSEIF (nbondi .eq. -1) THEN 1140 icont = icont + 1 1141 ineigh(icont) = noea 1142 ineighalls(icont) = noea 1143 ineighallr(icont) = noea 1144 ELSEIF (nbondi .eq. 0) THEN 1145 icont = icont + 1 1146 ineigh(icont) = nowe 1147 ineighalls(icont) = nowe 1148 ineighallr(icont) = nowe 1149 icont = icont + 1 1150 ineigh(icont) = noea 1151 ineighalls(icont) = noea 1152 ineighallr(icont) = noea 1153 ENDIF 1154 1155 IF (nbondj .eq. 1) THEN 1156 icont = icont + 1 1157 ineigh(icont) = noso 1158 ineighalls(icont) = noso 1159 ineighallr(icont) = noso 1160 ELSEIF (nbondj .eq. -1) THEN 1161 icont = icont + 1 1162 ineigh(icont) = nono 1163 ineighalls(icont) = nono 1164 ineighallr(icont) = nono 1165 ELSEIF (nbondj .eq. 0) THEN 1166 icont = icont + 1 1167 ineigh(icont) = noso 1168 ineighalls(icont) = noso 1169 ineighallr(icont) = noso 1170 icont = icont + 1 1171 ineigh(icont) = nono 1172 ineighalls(icont) = nono 1173 ineighallr(icont) = nono 1174 ENDIF 1175 1176 icont1 = icont 1177 IF (nosws .ne. -1) THEN 1178 icont = icont + 1 1179 ineighalls(icont) = nosws 1180 ENDIF 1181 IF (noses .ne. -1) THEN 1182 icont = icont + 1 1183 ineighalls(icont) = noses 1184 ENDIF 1185 IF (nonws .ne. -1) THEN 1186 icont = icont + 1 1187 ineighalls(icont) = nonws 1188 ENDIF 1189 IF (nones .ne. -1) THEN 1190 icont = icont + 1 1191 ineighalls(icont) = nones 1192 ENDIF 1193 IF (noswr .ne. -1) THEN 1194 icont1 = icont1 + 1 1195 ineighallr(icont1) = noswr 1196 ENDIF 1197 IF (noser .ne. -1) THEN 1198 icont1 = icont1 + 1 1199 ineighallr(icont1) = noser 1200 ENDIF 1201 IF (nonwr .ne. -1) THEN 1202 icont1 = icont1 + 1 1203 ineighallr(icont1) = nonwr 1204 ENDIF 1205 IF (noner .ne. -1) THEN 1206 icont1 = icont1 + 1 1207 ineighallr(icont1) = noner 1208 ENDIF 1209 1210 CALL MPI_Dist_graph_create_adjacent(mpi_comm_oce, ideg, ineigh, MPI_UNWEIGHTED, ideg, ineigh, MPI_UNWEIGHTED, MPI_INFO_NULL, ireord, mpi_nc_com, ierr) 1211 CALL MPI_Dist_graph_create_adjacent(mpi_comm_oce, idegallr, ineighallr, MPI_UNWEIGHTED, idegalls, ineighalls, MPI_UNWEIGHTED, MPI_INFO_NULL, ireord, mpi_nc_all_com, ierr) 1212 1213 DEALLOCATE (ineigh) 1214 DEALLOCATE (ineighalls) 1215 DEALLOCATE (ineighallr) 1105 !!---------------------------------------------------------------------- 1106 #if ! defined key_mpi_off && ! defined key_mpi2 1107 1108 icnt4 = COUNT( mpinei(1:4) >= 0 ) 1109 icnt8 = COUNT( mpinei(1:8) >= 0 ) 1110 1111 ALLOCATE( inei4(icnt4), inei8(icnt8) ) ! ok if icnt4 or icnt8 = 0 1112 1113 inei4 = PACK( mpinei(1:4), mask = mpinei(1:4) >= 0 ) 1114 inei8 = PACK( mpinei(1:8), mask = mpinei(1:8) >= 0 ) 1115 1116 CALL MPI_Dist_graph_create_adjacent(mpi_comm_oce, icnt4, inei4, MPI_UNWEIGHTED, & 1117 & icnt4, inei4, MPI_UNWEIGHTED, MPI_INFO_NULL, ireord, mpi_nc_com4, ierr) 1118 CALL MPI_Dist_graph_create_adjacent(mpi_comm_oce, icnt8, inei8, MPI_UNWEIGHTED, & 1119 & icnt8, inei8, MPI_UNWEIGHTED, MPI_INFO_NULL, ireord, mpi_nc_com8, ierr) 1120 1121 DEALLOCATE (inei4, inei8) 1216 1122 #endif 1217 1123 END SUBROUTINE mpp_ini_nc 1218 1219 1124 1220 1125 … … 1232 1137 !! 1233 1138 !! ** output 1234 !! njmppmax = njmpp for northern procs1235 1139 !! ndim_rank_north = number of processors in the northern line 1236 1140 !! nrank_north (ndim_rank_north) = number of the northern procs. … … 1247 1151 ! 1248 1152 #if ! defined key_mpi_off 1249 njmppmax = MAXVAL( njmppt )1250 1153 ! 1251 1154 ! Look for how many procs on the northern boundary -
NEMO/branches/2021/dev_r14312_MPI_Interface/src/OCE/LBC/mpp_lbc_north_icb_generic.h90
r14229 r14314 31 31 CHARACTER(len=1) , INTENT(in ) :: cd_type ! nature of pt3d grid-points 32 32 ! ! = T , U , V , F or W -points 33 REAL( wp), INTENT(in ) :: psgn ! = -1. the sign change across the33 REAL(PRECISION) , INTENT(in ) :: psgn ! = -1. the sign change across the 34 34 !! ! north fold, = 1. otherwise 35 35 INTEGER , INTENT(in ) :: kextj ! Extra halo width at north fold -
NEMO/branches/2021/dev_r14312_MPI_Interface/src/OCE/LBC/mpp_lnk_generic.h90
r14072 r14314 80 80 CHARACTER(len=*) , INTENT(in ) :: cdname ! name of the calling subroutine 81 81 CHARACTER(len=1) , INTENT(in ) :: NAT_IN(:) ! nature of array grid-points 82 REAL( wp), INTENT(in ) :: SGN_IN(:) ! sign used across the north fold boundary82 REAL(PRECISION) , INTENT(in ) :: SGN_IN(:) ! sign used across the north fold boundary 83 83 INTEGER , OPTIONAL, INTENT(in ) :: kfillmode ! filling method for halo over land (default = constant) 84 REAL( wp),OPTIONAL, INTENT(in ) :: pfillval ! background value (used at closed boundaries)84 REAL(PRECISION), OPTIONAL, INTENT(in ) :: pfillval ! background value (used at closed boundaries) 85 85 LOGICAL, DIMENSION(4),OPTIONAL, INTENT(in ) :: lsend, lrecv ! communication with other 4 proc 86 86 LOGICAL, OPTIONAL, INTENT(in ) :: ncsten ! 5-point or 9-point stencil 87 87 ! 88 INTEGER :: ji, jj, jk, jl, jf ! dummy loop indices 89 INTEGER :: ipi, ipj, ipk, ipl, ipf ! dimension of the input array 90 INTEGER :: isize, ishift, ishift2 ! local integers 91 INTEGER :: ireq_we, ireq_ea, ireq_so, ireq_no ! mpi_request id 88 INTEGER :: ji, jj, jk, jl, jf, jn ! dummy loop indices 89 INTEGER :: ipk, ipl, ipf ! dimension of the input array 90 INTEGER :: ip0i, ip1i, im0i, im1i 91 INTEGER :: ip0j, ip1j, im0j, im1j 92 INTEGER :: ishti, ishtj, ishti2, ishtj2 92 93 INTEGER :: ierr 93 INTEGER :: ifill_we, ifill_ea, ifill_so, ifill_no 94 REAL(wp) :: zland 95 INTEGER , DIMENSION(MPI_STATUS_SIZE) :: istat ! for mpi_isend 96 REAL(PRECISION), DIMENSION(:,:,:,:,:), ALLOCATABLE :: zsnd_we, zrcv_we, zsnd_ea, zrcv_ea ! east -west & west - east halos 97 REAL(PRECISION), DIMENSION(:,:,:,:,:), ALLOCATABLE :: zsnd_so, zrcv_so, zsnd_no, zrcv_no ! north-south & south-north halos 98 LOGICAL :: llsend_we, llsend_ea, llsend_no, llsend_so ! communication send 99 LOGICAL :: llrecv_we, llrecv_ea, llrecv_no, llrecv_so ! communication receive 100 LOGICAL :: lldo_nfd ! do north pole folding 94 INTEGER :: idxs, idxr 95 INTEGER, DIMENSION(4) :: isizei, ishtsi, ishtri, ishtpi 96 INTEGER, DIMENSION(4) :: isizej, ishtsj, ishtrj, ishtpj 97 INTEGER, DIMENSION(4) :: ifill, iszall, ishts, ishtr 98 INTEGER, DIMENSION(4) :: ireq ! mpi_request id 99 REAL(PRECISION) :: zland 100 REAL(PRECISION), DIMENSION(:), ALLOCATABLE :: zsnd, zrcv ! halos arrays 101 LOGICAL, DIMENSION(4) :: llsend, llrecv 102 LOGICAL :: ll_IdoNFold 101 103 !!---------------------------------------------------------------------- 104 #if defined PRINT_CAUTION 105 ! 106 ! ================================================================================== ! 107 ! CAUTION: semi-column notation is often impossible because of the cpp preprocessing ! 108 ! ================================================================================== ! 109 ! 110 #endif 102 111 ! 103 112 #if defined key_mpi3 … … 108 117 # endif 109 118 #else 110 111 119 ! ----------------------------------------- ! 112 ! 0. local variables initialization !120 ! 1. local variables initialization ! 113 121 ! ----------------------------------------- ! 114 122 ! … … 119 127 IF( narea == 1 .AND. numcom == -1 ) CALL mpp_report( cdname, ipk, ipl, ipf, ld_lbc = .TRUE. ) 120 128 ! 121 IF ( PRESENT(lsend) .AND. PRESENT(lrecv) ) THEN 122 llsend_we = lsend(1) ; llsend_ea = lsend(2) ; llsend_so = lsend(3) ; llsend_no = lsend(4) 123 llrecv_we = lrecv(1) ; llrecv_ea = lrecv(2) ; llrecv_so = lrecv(3) ; llrecv_no = lrecv(4) 124 ELSE IF( PRESENT(lsend) .OR. PRESENT(lrecv) ) THEN 125 WRITE(ctmp1,*) ' E R R O R : Routine ', cdname, ' is calling lbc_lnk with only one of the two arguments lsend or lrecv' 126 WRITE(ctmp2,*) ' ========== ' 127 CALL ctl_stop( ' ', ctmp1, ctmp2, ' ' ) 128 ELSE ! send and receive with every neighbour 129 llsend_we = nbondi == 1 .OR. nbondi == 0 ! keep for compatibility, should be defined in mppini 130 llsend_ea = nbondi == -1 .OR. nbondi == 0 ! keep for compatibility, should be defined in mppini 131 llsend_so = nbondj == 1 .OR. nbondj == 0 ! keep for compatibility, should be defined in mppini 132 llsend_no = nbondj == -1 .OR. nbondj == 0 ! keep for compatibility, should be defined in mppini 133 llrecv_we = llsend_we ; llrecv_ea = llsend_ea ; llrecv_so = llsend_so ; llrecv_no = llsend_no 134 END IF 135 136 137 lldo_nfd = npolj /= 0 ! keep for compatibility, should be defined in mppini 138 129 ! take care of optional parameters 130 ! 139 131 zland = 0._wp ! land filling value: zero by default 140 132 IF( PRESENT( pfillval ) ) zland = pfillval ! set land value 133 ! 134 ! define llsend and llrecv: logicals which say if mpi-neibourgs for send or receive exist or not. 135 IF ( PRESENT(lsend) .AND. PRESENT(lrecv) ) THEN ! localy defined neighbourgs 136 llsend(1:4) = lsend(1:4) ; llrecv(1:4) = lrecv(1:4) 137 ELSE IF( PRESENT(lsend) .OR. PRESENT(lrecv) ) THEN 138 WRITE(ctmp1,*) ' Routine ', cdname, ' is calling lbc_lnk with only one of the two arguments lsend or lrecv' 139 CALL ctl_stop( 'STOP', ctmp1 ) 140 ELSE ! default neighbours 141 llsend(1:4) = mpinei(1:4) >= 0 142 llrecv(:) = llsend(:) 143 END IF 144 ! 145 ! define ifill: which method should be used to fill each parts (sides+corners) of the halos 146 ! default definition 147 DO jn = 1, 4 148 IF( llrecv(jn) ) THEN ; ifill(jn) = jpfillmpi ! with an mpi communication 149 ELSEIF( l_SelfPerio(jn) ) THEN ; ifill(jn) = jpfillperio ! with self-periodicity 150 ELSEIF( PRESENT(kfillmode) ) THEN ; ifill(jn) = kfillmode ! localy defined 151 ELSE ; ifill(jn) = jpfillcst ! constant value (zland) 152 END IF 153 END DO 154 ! north fold treatment 155 ll_IdoNFold = l_IdoNFold .AND. ifill(jpno) /= jpfillnothing 156 IF( ll_IdoNFold ) ifill( (/jpno/) ) = jpfillnothing ! we do north fold -> do nothing for northern halo 157 158 ! ! ________________________ 159 ip0i = 0 ! im0j = inner |__|__|__________|__|__| 160 ip1i = nn_hls ! im1j = inner - halo |__|__|__________|__|__| 161 im1i = Nie0-nn_hls ! | | | | | | 162 im0i = Nie0 ! | | | | | | 163 ip0j = 0 ! | | | | | | 164 ip1j = nn_hls ! |__|__|__________|__|__| 165 im1j = Nje0-nn_hls ! ip1j = halo |__|__|__________|__|__| 166 im0j = Nje0 ! ip0j = 0 |__|__|__________|__|__| 167 ! ! ip0i ip1i im1i im0i 168 ! 169 ! sides: west east south north 170 isizei(1:4) = (/ nn_hls, nn_hls, jpi, jpi /) ! i- count 171 isizej(1:4) = (/ jpj, jpj, nn_hls, nn_hls /) ! j- count 172 ishtsi(1:4) = (/ ip1i, im1i, ip0i, ip0i /) ! i- shift send data 173 ishtsj(1:4) = (/ ip0j, ip0j, ip1j, im1j /) ! j- shift send data 174 ishtri(1:4) = (/ ip0i, im0i, ip0i, ip0i /) ! i- shift received data location 175 ishtrj(1:4) = (/ ip0j, ip0j, ip0j, im0j /) ! j- shift received data location 176 ishtpi(1:4) = (/ im1i, ip1i, ip0i, ip0i /) ! i- shift data used for periodicity 177 ishtpj(1:4) = (/ ip0j, ip0j, im1j, ip1j /) ! j- shift data used for periodicity 178 ! 179 ! -------------------------------- ! 180 ! 2. Prepare MPI exchanges ! 181 ! -------------------------------- ! 182 ! 183 ireq(:) = MPI_REQUEST_NULL 184 iszall(:) = isizei(:) * isizej(:) * ipk * ipl * ipf 185 ishts(1) = 0 186 DO jn = 2,4 187 ishts(jn) = ishts(jn-1) + iszall(jn-1) * COUNT( (/llsend(jn-1)/) ) ! with _alltoallv: in units of sendtype 188 END DO 189 ishtr(1) = 0 190 DO jn = 2,4 191 ishtr(jn) = ishtr(jn-1) + iszall(jn-1) * COUNT( (/llrecv(jn-1)/) ) ! with _alltoallv: in units of sendtype 192 END DO 141 193 142 ! define the method we will use to fill the halos in each direction 143 IF( llrecv_we ) THEN ; ifill_we = jpfillmpi 144 ELSEIF( l_Iperio ) THEN ; ifill_we = jpfillperio 145 ELSEIF( PRESENT(kfillmode) ) THEN ; ifill_we = kfillmode 146 ELSE ; ifill_we = jpfillcst 147 END IF 148 ! 149 IF( llrecv_ea ) THEN ; ifill_ea = jpfillmpi 150 ELSEIF( l_Iperio ) THEN ; ifill_ea = jpfillperio 151 ELSEIF( PRESENT(kfillmode) ) THEN ; ifill_ea = kfillmode 152 ELSE ; ifill_ea = jpfillcst 153 END IF 154 ! 155 IF( llrecv_so ) THEN ; ifill_so = jpfillmpi 156 ELSEIF( l_Jperio ) THEN ; ifill_so = jpfillperio 157 ELSEIF( PRESENT(kfillmode) ) THEN ; ifill_so = kfillmode 158 ELSE ; ifill_so = jpfillcst 159 END IF 160 ! 161 IF( llrecv_no ) THEN ; ifill_no = jpfillmpi 162 ELSEIF( l_Jperio ) THEN ; ifill_no = jpfillperio 163 ELSEIF( PRESENT(kfillmode) ) THEN ; ifill_no = kfillmode 164 ELSE ; ifill_no = jpfillcst 165 END IF 166 ! 167 #if defined PRINT_CAUTION 168 ! 169 ! ================================================================================== ! 170 ! CAUTION: semi-column notation is often impossible because of the cpp preprocessing ! 171 ! ================================================================================== ! 172 ! 173 #endif 194 ! Allocate local temporary arrays to be sent/received. 195 ALLOCATE( zsnd( SUM(iszall, mask = llsend) ), zrcv( SUM(iszall, mask = llrecv) ) ) 174 196 ! 175 197 ! -------------------------------------------------- ! 176 ! 1. Do east and west MPI exchange if needed !198 ! 3. Do east and west MPI exchange if needed ! 177 199 ! -------------------------------------------------- ! 178 200 ! 179 ! Must exchange the whole column (from 1 to jpj) to get the corners if we have no south/north neighbourg 180 isize = nn_hls * jpj * ipk * ipl * ipf 181 ! 182 ! Allocate local temporary arrays to be sent/received. Fill arrays to be sent 183 IF( llsend_we ) ALLOCATE( zsnd_we(nn_hls,jpj,ipk,ipl,ipf) ) 184 IF( llsend_ea ) ALLOCATE( zsnd_ea(nn_hls,jpj,ipk,ipl,ipf) ) 185 IF( llrecv_we ) ALLOCATE( zrcv_we(nn_hls,jpj,ipk,ipl,ipf) ) 186 IF( llrecv_ea ) ALLOCATE( zrcv_ea(nn_hls,jpj,ipk,ipl,ipf) ) 187 ! 188 IF( llsend_we ) THEN ! copy western side of the inner mpi domain in local temporary array to be sent by MPI 189 ishift = nn_hls 190 DO jf = 1, ipf ; DO jl = 1, ipl ; DO jk = 1, ipk ; DO jj = 1, jpj ; DO ji = 1, nn_hls 191 zsnd_we(ji,jj,jk,jl,jf) = ARRAY_IN(ishift+ji,jj,jk,jl,jf) ! nn_hls + 1 -> 2*nn_hls 192 END DO ; END DO ; END DO ; END DO ; END DO 201 ! fill sending buffer with ARRAY_IN 202 idxs = 1 203 DO jn = 1, 2 204 IF( llsend(jn) ) THEN 205 ishti = ishtsi(jn) 206 ishtj = ishtsj(jn) 207 DO jf = 1, ipf ; DO jl = 1, ipl ; DO jk = 1, ipk ; DO jj = 1,isizej(jn) ; DO ji = 1,isizei(jn) 208 zsnd(idxs) = ARRAY_IN(ishti+ji,ishtj+jj,jk,jl,jf) 209 idxs = idxs + 1 210 END DO ; END DO ; END DO ; END DO ; END DO 211 END IF 212 END DO 213 ! 214 IF( ln_timing ) CALL tic_tac(.TRUE.) 215 ! 216 ! non-blocking send of the western/eastern side using local temporary arrays 217 jn = jpwe ; IF( llsend(jn) ) CALL SENDROUTINE( 1, zsnd(ishts(jn)+1), iszall(jn), mpinei(jn), ireq(jn) ) 218 jn = jpea ; IF( llsend(jn) ) CALL SENDROUTINE( 2, zsnd(ishts(jn)+1), iszall(jn), mpinei(jn), ireq(jn) ) 219 ! blocking receive of the western/eastern halo in local temporary arrays 220 jn = jpwe ; IF( llrecv(jn) ) CALL RECVROUTINE( 2, zrcv(ishtr(jn)+1), iszall(jn), mpinei(jn) ) 221 jn = jpea ; IF( llrecv(jn) ) CALL RECVROUTINE( 1, zrcv(ishtr(jn)+1), iszall(jn), mpinei(jn) ) 222 ! 223 IF( ln_timing ) CALL tic_tac(.FALSE.) 224 ! 225 ! ----------------------------------- ! 226 ! 4. Fill east and west halos ! 227 ! ----------------------------------- ! 228 ! 229 idxr = 1 230 DO jn = 1, 2 231 ishti = ishtri(jn) 232 ishtj = ishtrj(jn) 233 SELECT CASE ( ifill(jn) ) 234 CASE ( jpfillnothing ) ! no filling 235 CASE ( jpfillmpi ) ! fill with data received by MPI 236 DO jf = 1, ipf ; DO jl = 1, ipl ; DO jk = 1, ipk ; DO jj = 1,isizej(jn) ; DO ji = 1,isizei(jn) 237 ARRAY_IN(ishti+ji,ishtj+jj,jk,jl,jf) = zrcv(idxr) 238 idxr = idxr + 1 239 END DO ; END DO ; END DO ; END DO ; END DO 240 CASE ( jpfillperio ) ! use periodicity 241 ishti2 = ishtpi(jn) 242 ishtj2 = ishtpj(jn) 243 DO jf = 1, ipf ; DO jl = 1, ipl ; DO jk = 1, ipk ; DO jj = 1,isizej(jn) ; DO ji = 1,isizei(jn) 244 ARRAY_IN(ishti+ji,ishtj+jj,jk,jl,jf) = ARRAY_IN(ishti2+ji,ishtj2+jj,jk,jl,jf) 245 END DO ; END DO ; END DO ; END DO ; END DO 246 CASE ( jpfillcopy ) ! filling with inner domain values 247 ishti2 = ishtsi(jn) 248 ishtj2 = ishtsj(jn) 249 DO jf = 1, ipf ; DO jl = 1, ipl ; DO jk = 1, ipk ; DO jj = 1,isizej(jn) ; DO ji = 1,isizei(jn) 250 ARRAY_IN(ishti+ji,ishtj+jj,jk,jl,jf) = ARRAY_IN(ishti2+ji,ishtj2+jj,jk,jl,jf) 251 END DO ; END DO ; END DO ; END DO ; END DO 252 CASE ( jpfillcst ) ! filling with constant value 253 DO jf = 1, ipf ; DO jl = 1, ipl ; DO jk = 1, ipk ; DO jj = 1,isizej(jn) ; DO ji = 1,isizei(jn) 254 ARRAY_IN(ishti+ji,ishtj+jj,jk,jl,jf) = zland 255 END DO ; END DO ; END DO ; END DO ; END DO 256 END SELECT 257 END DO 258 ! 259 ! ------------------------------- ! 260 ! 5. north fold treatment ! 261 ! ------------------------------- ! 262 ! 263 ! do it before south directions so concerned processes can do it without waiting for the comm with the sourthern neighbor 264 ! 265 IF( ll_IdoNFold ) THEN 266 IF( jpni == 1 ) THEN ; CALL lbc_nfd( ptab, NAT_IN(:), SGN_IN(:) OPT_K(:) ) ! self NFold 267 ELSE ; CALL mpp_nfd( ptab, NAT_IN(:), SGN_IN(:), ifill(jpno), zland OPT_K(:) ) ! mpi NFold 268 ENDIF 193 269 ENDIF 194 270 ! 195 IF(llsend_ea ) THEN ! copy eastern side of the inner mpi domain in local temporary array to be sent by MPI 196 ishift = jpi - 2 * nn_hls 197 DO jf = 1, ipf ; DO jl = 1, ipl ; DO jk = 1, ipk ; DO jj = 1, jpj ; DO ji = 1, nn_hls 198 zsnd_ea(ji,jj,jk,jl,jf) = ARRAY_IN(ishift+ji,jj,jk,jl,jf) ! jpi - 2*nn_hls + 1 -> jpi - nn_hls 199 END DO ; END DO ; END DO ; END DO ; END DO 200 ENDIF 271 ! ---------------------------------------------------- ! 272 ! 6. Do north and south MPI exchange if needed ! 273 ! ---------------------------------------------------- ! 274 ! 275 DO jn = 3, 4 276 IF( llsend(jn) ) THEN 277 ishti = ishtsi(jn) 278 ishtj = ishtsj(jn) 279 DO jf = 1, ipf ; DO jl = 1, ipl ; DO jk = 1, ipk ; DO jj = 1,isizej(jn) ; DO ji = 1,isizei(jn) 280 zsnd(idxs) = ARRAY_IN(ishti+ji,ishtj+jj,jk,jl,jf) 281 idxs = idxs + 1 282 END DO ; END DO ; END DO ; END DO ; END DO 283 END IF 284 END DO 201 285 ! 202 286 IF( ln_timing ) CALL tic_tac(.TRUE.) 203 287 ! 204 288 ! non-blocking send of the western/eastern side using local temporary arrays 205 IF( llsend_we ) CALL SENDROUTINE( 1, zsnd_we(1,1,1,1,1), isize, nowe, ireq_we)206 IF( llsend_ea ) CALL SENDROUTINE( 2, zsnd_ea(1,1,1,1,1), isize, noea, ireq_ea)289 jn = jpso ; IF( llsend(jn) ) CALL SENDROUTINE( 3, zsnd(ishts(jn)+1), iszall(jn), mpinei(jn), ireq(jn) ) 290 jn = jpno ; IF( llsend(jn) ) CALL SENDROUTINE( 4, zsnd(ishts(jn)+1), iszall(jn), mpinei(jn), ireq(jn) ) 207 291 ! blocking receive of the western/eastern halo in local temporary arrays 208 IF( llrecv_we ) CALL RECVROUTINE( 2, zrcv_we(1,1,1,1,1), isize, nowe)209 IF( llrecv_ea ) CALL RECVROUTINE( 1, zrcv_ea(1,1,1,1,1), isize, noea)292 jn = jpso ; IF( llrecv(jn) ) CALL RECVROUTINE( 4, zrcv(ishtr(jn)+1), iszall(jn), mpinei(jn) ) 293 jn = jpno ; IF( llrecv(jn) ) CALL RECVROUTINE( 3, zrcv(ishtr(jn)+1), iszall(jn), mpinei(jn) ) 210 294 ! 211 295 IF( ln_timing ) CALL tic_tac(.FALSE.) 212 296 ! 213 ! 214 ! ----------------------------------- ! 215 ! 2. Fill east and west halos ! 216 ! ----------------------------------- ! 217 ! 218 ! 2.1 fill weastern halo 219 ! ---------------------- 220 ! ishift = 0 ! fill halo from ji = 1 to nn_hls 221 SELECT CASE ( ifill_we ) 222 CASE ( jpfillnothing ) ! no filling 223 CASE ( jpfillmpi ) ! use data received by MPI 224 DO jf = 1, ipf ; DO jl = 1, ipl ; DO jk = 1, ipk ; DO jj = 1, jpj ; DO ji = 1, nn_hls 225 ARRAY_IN(ji,jj,jk,jl,jf) = zrcv_we(ji,jj,jk,jl,jf) ! 1 -> nn_hls 226 END DO ; END DO ; END DO ; END DO ; END DO 227 CASE ( jpfillperio ) ! use east-weast periodicity 228 ishift2 = jpi - 2 * nn_hls 229 DO jf = 1, ipf ; DO jl = 1, ipl ; DO jk = 1, ipk ; DO jj = 1, jpj ; DO ji = 1, nn_hls 230 ARRAY_IN(ji,jj,jk,jl,jf) = ARRAY_IN(ishift2+ji,jj,jk,jl,jf) 231 END DO ; END DO ; END DO ; END DO ; END DO 232 CASE ( jpfillcopy ) ! filling with inner domain values 233 DO jf = 1, ipf ; DO jl = 1, ipl ; DO jk = 1, ipk ; DO jj = 1, jpj ; DO ji = 1, nn_hls 234 ARRAY_IN(ji,jj,jk,jl,jf) = ARRAY_IN(nn_hls+1,jj,jk,jl,jf) 235 END DO ; END DO ; END DO ; END DO ; END DO 236 CASE ( jpfillcst ) ! filling with constant value 237 DO jf = 1, ipf ; DO jl = 1, ipl ; DO jk = 1, ipk ; DO jj = 1, jpj ; DO ji = 1, nn_hls 238 ARRAY_IN(ji,jj,jk,jl,jf) = zland 239 END DO ; END DO ; END DO ; END DO ; END DO 240 END SELECT 241 ! 242 ! 2.2 fill eastern halo 243 ! --------------------- 244 ishift = jpi - nn_hls ! fill halo from ji = jpi-nn_hls+1 to jpi 245 SELECT CASE ( ifill_ea ) 246 CASE ( jpfillnothing ) ! no filling 247 CASE ( jpfillmpi ) ! use data received by MPI 248 DO jf = 1, ipf ; DO jl = 1, ipl ; DO jk = 1, ipk ; DO jj = 1, jpj ; DO ji = 1, nn_hls 249 ARRAY_IN(ishift+ji,jj,jk,jl,jf) = zrcv_ea(ji,jj,jk,jl,jf) ! jpi - nn_hls + 1 -> jpi 250 END DO ; END DO ; END DO ; END DO ; END DO 251 CASE ( jpfillperio ) ! use east-weast periodicity 252 ishift2 = nn_hls 253 DO jf = 1, ipf ; DO jl = 1, ipl ; DO jk = 1, ipk ; DO jj = 1, jpj ; DO ji = 1, nn_hls 254 ARRAY_IN(ishift+ji,jj,jk,jl,jf) = ARRAY_IN(ishift2+ji,jj,jk,jl,jf) 255 END DO ; END DO ; END DO ; END DO ; END DO 256 CASE ( jpfillcopy ) ! filling with inner domain values 257 DO jf = 1, ipf ; DO jl = 1, ipl ; DO jk = 1, ipk ; DO jj = 1, jpj ; DO ji = 1, nn_hls 258 ARRAY_IN(ishift+ji,jj,jk,jl,jf) = ARRAY_IN(ishift,jj,jk,jl,jf) 259 END DO ; END DO ; END DO ; END DO ; END DO 260 CASE ( jpfillcst ) ! filling with constant value 261 DO jf = 1, ipf ; DO jl = 1, ipl ; DO jk = 1, ipk ; DO jj = 1, jpj ; DO ji = 1, nn_hls 262 ARRAY_IN(ishift+ji,jj,jk,jl,jf) = zland 263 END DO ; END DO ; END DO ; END DO ; END DO 264 END SELECT 265 ! 266 ! ------------------------------- ! 267 ! 3. north fold treatment ! 268 ! ------------------------------- ! 269 ! 270 ! do it before south directions so concerned processes can do it without waiting for the comm with the sourthern neighbor 271 ! 272 IF( lldo_nfd .AND. ifill_no /= jpfillnothing ) THEN 273 ! 274 SELECT CASE ( jpni ) 275 CASE ( 1 ) ; CALL lbc_nfd( ptab, NAT_IN(:), SGN_IN(:) OPT_K(:) ) ! only 1 northern proc, no mpp 276 CASE DEFAULT ; CALL mpp_nfd( ptab, NAT_IN(:), SGN_IN(:), ifill_no, zland OPT_K(:) ) ! for all northern procs. 297 ! ------------------------------------- ! 298 ! 7. Fill south and north halos ! 299 ! ------------------------------------- ! 300 ! 301 DO jn = 3, 4 302 ishti = ishtri(jn) 303 ishtj = ishtrj(jn) 304 SELECT CASE ( ifill(jn) ) 305 CASE ( jpfillnothing ) ! no filling 306 CASE ( jpfillmpi ) ! fill with data received by MPI 307 DO jf = 1, ipf ; DO jl = 1, ipl ; DO jk = 1, ipk ; DO jj = 1,isizej(jn) ; DO ji = 1,isizei(jn) 308 ARRAY_IN(ishti+ji,ishtj+jj,jk,jl,jf) = zrcv(idxr) 309 idxr = idxr + 1 310 END DO ; END DO ; END DO ; END DO ; END DO 311 CASE ( jpfillperio ) ! use periodicity 312 ishti2 = ishtpi(jn) 313 ishtj2 = ishtpj(jn) 314 DO jf = 1, ipf ; DO jl = 1, ipl ; DO jk = 1, ipk ; DO jj = 1,isizej(jn) ; DO ji = 1,isizei(jn) 315 ARRAY_IN(ishti+ji,ishtj+jj,jk,jl,jf) = ARRAY_IN(ishti2+ji,ishtj2+jj,jk,jl,jf) 316 END DO ; END DO ; END DO ; END DO ; END DO 317 CASE ( jpfillcopy ) ! filling with inner domain values 318 ishti2 = ishtsi(jn) 319 ishtj2 = ishtsj(jn) 320 DO jf = 1, ipf ; DO jl = 1, ipl ; DO jk = 1, ipk ; DO jj = 1,isizej(jn) ; DO ji = 1,isizei(jn) 321 ARRAY_IN(ishti+ji,ishtj+jj,jk,jl,jf) = ARRAY_IN(ishti2+ji,ishtj2+jj,jk,jl,jf) 322 END DO ; END DO ; END DO ; END DO ; END DO 323 CASE ( jpfillcst ) ! filling with constant value 324 DO jf = 1, ipf ; DO jl = 1, ipl ; DO jk = 1, ipk ; DO jj = 1,isizej(jn) ; DO ji = 1,isizei(jn) 325 ARRAY_IN(ishti+ji,ishtj+jj,jk,jl,jf) = zland 326 END DO ; END DO ; END DO ; END DO ; END DO 277 327 END SELECT 278 ! 279 ifill_no = jpfillnothing ! force to do nothing for the northern halo as we just done the north pole folding 280 ! 281 ENDIF 282 ! 283 ! ---------------------------------------------------- ! 284 ! 4. Do north and south MPI exchange if needed ! 285 ! ---------------------------------------------------- ! 286 ! 287 IF( llsend_so ) ALLOCATE( zsnd_so(jpi,nn_hls,ipk,ipl,ipf) ) 288 IF( llsend_no ) ALLOCATE( zsnd_no(jpi,nn_hls,ipk,ipl,ipf) ) 289 IF( llrecv_so ) ALLOCATE( zrcv_so(jpi,nn_hls,ipk,ipl,ipf) ) 290 IF( llrecv_no ) ALLOCATE( zrcv_no(jpi,nn_hls,ipk,ipl,ipf) ) 291 ! 292 isize = jpi * nn_hls * ipk * ipl * ipf 293 294 ! allocate local temporary arrays to be sent/received. Fill arrays to be sent 295 IF( llsend_so ) THEN ! copy sourhern side of the inner mpi domain in local temporary array to be sent by MPI 296 ishift = nn_hls 297 DO jf = 1, ipf ; DO jl = 1, ipl ; DO jk = 1, ipk ; DO jj = 1, nn_hls ; DO ji = 1, jpi 298 zsnd_so(ji,jj,jk,jl,jf) = ARRAY_IN(ji,ishift+jj,jk,jl,jf) ! nn_hls+1 -> 2*nn_hls 299 END DO ; END DO ; END DO ; END DO ; END DO 300 ENDIF 301 ! 302 IF( llsend_no ) THEN ! copy eastern side of the inner mpi domain in local temporary array to be sent by MPI 303 ishift = jpj - 2 * nn_hls 304 DO jf = 1, ipf ; DO jl = 1, ipl ; DO jk = 1, ipk ; DO jj = 1, nn_hls ; DO ji = 1, jpi 305 zsnd_no(ji,jj,jk,jl,jf) = ARRAY_IN(ji,ishift+jj,jk,jl,jf) ! jpj-2*nn_hls+1 -> jpj-nn_hls 306 END DO ; END DO ; END DO ; END DO ; END DO 307 ENDIF 308 ! 309 IF( ln_timing ) CALL tic_tac(.TRUE.) 310 ! 311 ! non-blocking send of the southern/northern side 312 IF( llsend_so ) CALL SENDROUTINE( 3, zsnd_so(1,1,1,1,1), isize, noso, ireq_so ) 313 IF( llsend_no ) CALL SENDROUTINE( 4, zsnd_no(1,1,1,1,1), isize, nono, ireq_no ) 314 ! blocking receive of the southern/northern halo 315 IF( llrecv_so ) CALL RECVROUTINE( 4, zrcv_so(1,1,1,1,1), isize, noso ) 316 IF( llrecv_no ) CALL RECVROUTINE( 3, zrcv_no(1,1,1,1,1), isize, nono ) 317 ! 318 IF( ln_timing ) CALL tic_tac(.FALSE.) 319 ! 320 ! ------------------------------------- ! 321 ! 5. Fill south and north halos ! 322 ! ------------------------------------- ! 323 ! 324 ! 5.1 fill southern halo 325 ! ---------------------- 326 ! ishift = 0 ! fill halo from jj = 1 to nn_hls 327 SELECT CASE ( ifill_so ) 328 CASE ( jpfillnothing ) ! no filling 329 CASE ( jpfillmpi ) ! use data received by MPI 330 DO jf = 1, ipf ; DO jl = 1, ipl ; DO jk = 1, ipk ; DO jj = 1, nn_hls ; DO ji = 1, jpi 331 ARRAY_IN(ji,jj,jk,jl,jf) = zrcv_so(ji,jj,jk,jl,jf) ! 1 -> nn_hls 332 END DO ; END DO ; END DO ; END DO ; END DO 333 CASE ( jpfillperio ) ! use north-south periodicity 334 ishift2 = jpj - 2 * nn_hls 335 DO jf = 1, ipf ; DO jl = 1, ipl ; DO jk = 1, ipk ; DO jj = 1, nn_hls ; DO ji = 1, jpi 336 ARRAY_IN(ji,jj,jk,jl,jf) = ARRAY_IN(ji,ishift2+jj,jk,jl,jf) 337 END DO ; END DO ; END DO ; END DO ; END DO 338 CASE ( jpfillcopy ) ! filling with inner domain values 339 DO jf = 1, ipf ; DO jl = 1, ipl ; DO jk = 1, ipk ; DO jj = 1, nn_hls ; DO ji = 1, jpi 340 ARRAY_IN(ji,jj,jk,jl,jf) = ARRAY_IN(ji,nn_hls+1,jk,jl,jf) 341 END DO ; END DO ; END DO ; END DO ; END DO 342 CASE ( jpfillcst ) ! filling with constant value 343 DO jf = 1, ipf ; DO jl = 1, ipl ; DO jk = 1, ipk ; DO jj = 1, nn_hls ; DO ji = 1, jpi 344 ARRAY_IN(ji,jj,jk,jl,jf) = zland 345 END DO ; END DO ; END DO ; END DO ; END DO 346 END SELECT 347 ! 348 ! 5.2 fill northern halo 349 ! ---------------------- 350 ishift = jpj - nn_hls ! fill halo from jj = jpj-nn_hls+1 to jpj 351 SELECT CASE ( ifill_no ) 352 CASE ( jpfillnothing ) ! no filling 353 CASE ( jpfillmpi ) ! use data received by MPI 354 DO jf = 1, ipf ; DO jl = 1, ipl ; DO jk = 1, ipk ; DO jj = 1, nn_hls ; DO ji = 1, jpi 355 ARRAY_IN(ji,ishift+jj,jk,jl,jf) = zrcv_no(ji,jj,jk,jl,jf) ! jpj-nn_hls+1 -> jpj 356 END DO ; END DO ; END DO ; END DO ; END DO 357 CASE ( jpfillperio ) ! use north-south periodicity 358 ishift2 = nn_hls 359 DO jf = 1, ipf ; DO jl = 1, ipl ; DO jk = 1, ipk ; DO jj = 1, nn_hls ; DO ji = 1, jpi 360 ARRAY_IN(ji,ishift+jj,jk,jl,jf) = ARRAY_IN(ji,ishift2+jj,jk,jl,jf) 361 END DO ; END DO ; END DO ; END DO ; END DO 362 CASE ( jpfillcopy ) ! filling with inner domain values 363 DO jf = 1, ipf ; DO jl = 1, ipl ; DO jk = 1, ipk ; DO jj = 1, nn_hls ; DO ji = 1, jpi 364 ARRAY_IN(ji,ishift+jj,jk,jl,jf) = ARRAY_IN(ji,ishift,jk,jl,jf) 365 END DO ; END DO ; END DO ; END DO ; END DO 366 CASE ( jpfillcst ) ! filling with constant value 367 DO jf = 1, ipf ; DO jl = 1, ipl ; DO jk = 1, ipk ; DO jj = 1, nn_hls ; DO ji = 1, jpi 368 ARRAY_IN(ji,ishift+jj,jk,jl,jf) = zland 369 END DO ; END DO ; END DO ; END DO ; END DO 370 END SELECT 328 END DO 371 329 ! 372 330 ! -------------------------------------------- ! 373 ! 6. deallocate local temporary arrays !331 ! 8. deallocate local temporary arrays ! 374 332 ! -------------------------------------------- ! 375 333 ! 376 IF( llsend_we ) THEN 377 CALL mpi_wait(ireq_we, istat, ierr ) 378 DEALLOCATE( zsnd_we ) 379 ENDIF 380 IF( llsend_ea ) THEN 381 CALL mpi_wait(ireq_ea, istat, ierr ) 382 DEALLOCATE( zsnd_ea ) 383 ENDIF 384 IF( llsend_so ) THEN 385 CALL mpi_wait(ireq_so, istat, ierr ) 386 DEALLOCATE( zsnd_so ) 387 ENDIF 388 IF( llsend_no ) THEN 389 CALL mpi_wait(ireq_no, istat, ierr ) 390 DEALLOCATE( zsnd_no ) 391 ENDIF 392 ! 393 IF( llrecv_we ) DEALLOCATE( zrcv_we ) 394 IF( llrecv_ea ) DEALLOCATE( zrcv_ea ) 395 IF( llrecv_so ) DEALLOCATE( zrcv_so ) 396 IF( llrecv_no ) DEALLOCATE( zrcv_no ) 334 CALL mpi_waitall(4, ireq, MPI_STATUSES_IGNORE, ierr) 335 DEALLOCATE( zsnd, zrcv ) 397 336 ! 398 337 #endif -
NEMO/branches/2021/dev_r14312_MPI_Interface/src/OCE/LBC/mpp_lnk_icb_generic.h90
r13286 r14314 24 24 !! jpi : first dimension of the local subdomain 25 25 !! jpj : second dimension of the local subdomain 26 !! mpinei : number of neighboring domains (starting at 0, -1 if no neighbourg) 26 27 !! kexti : number of columns for extra outer halo 27 28 !! kextj : number of rows for extra outer halo 28 !! nbondi : mark for "east-west local boundary"29 !! nbondj : mark for "north-south local boundary"30 !! noea : number for local neighboring processors31 !! nowe : number for local neighboring processors32 !! noso : number for local neighboring processors33 !! nono : number for local neighboring processors34 29 !!---------------------------------------------------------------------- 35 30 CHARACTER(len=*) , INTENT(in ) :: cdname ! name of the calling subroutine 36 31 REAL(PRECISION), DIMENSION(1-kexti:jpi+kexti,1-kextj:jpj+kextj), INTENT(inout) :: pt2d ! 2D array with extra halo 37 32 CHARACTER(len=1) , INTENT(in ) :: cd_type ! nature of ptab array grid-points 38 REAL( wp), INTENT(in ) :: psgn ! sign used across the north fold33 REAL(PRECISION) , INTENT(in ) :: psgn ! sign used across the north fold 39 34 INTEGER , INTENT(in ) :: kexti ! extra i-halo width 40 35 INTEGER , INTENT(in ) :: kextj ! extra j-halo width … … 90 85 ! north fold treatment 91 86 ! ----------------------- 92 IF( npolj /= 0) THEN87 IF( l_NFoldT .OR. l_NFoldF ) THEN 93 88 ! 94 89 SELECT CASE ( jpni ) … … 103 98 ! we play with the neigbours AND the row number because of the periodicity 104 99 ! 105 SELECT CASE ( nbondi ) ! Read Dirichlet lateral conditions 106 CASE ( -1, 0, 1 ) ! all exept 2 (i.e. close case) 100 IF( mpinei(jpwe) >= 0 .OR. mpinei(jpea) >= 0 ) THEN ! Read Dirichlet lateral conditions: all exept 2 (i.e. close case) 107 101 iihom = jpi - (2 * nn_hls) -kexti 108 102 DO jl = 1, ipreci … … 110 104 r2dwe(:,jl,1) = pt2d(iihom +jl,:) 111 105 END DO 112 END SELECT106 ENDIF 113 107 ! 114 108 ! ! Migrations … … 120 114 IF( ln_timing ) CALL tic_tac(.TRUE.) 121 115 ! 122 SELECT CASE ( nbondi ) 123 CASE ( -1 ) 124 CALL SENDROUTINE( 2, r2dwe(1-kextj,1,1), imigr, noea, ml_req1 ) 125 CALL RECVROUTINE( 1, r2dew(1-kextj,1,2), imigr, noea ) 126 CALL mpi_wait(ml_req1,ml_stat,ml_err) 127 CASE ( 0 ) 128 CALL SENDROUTINE( 1, r2dew(1-kextj,1,1), imigr, nowe, ml_req1 ) 129 CALL SENDROUTINE( 2, r2dwe(1-kextj,1,1), imigr, noea, ml_req2 ) 130 CALL RECVROUTINE( 1, r2dew(1-kextj,1,2), imigr, noea ) 131 CALL RECVROUTINE( 2, r2dwe(1-kextj,1,2), imigr, nowe ) 132 CALL mpi_wait(ml_req1,ml_stat,ml_err) 133 CALL mpi_wait(ml_req2,ml_stat,ml_err) 134 CASE ( 1 ) 135 CALL SENDROUTINE( 1, r2dew(1-kextj,1,1), imigr, nowe, ml_req1 ) 136 CALL RECVROUTINE( 2, r2dwe(1-kextj,1,2), imigr, nowe ) 137 CALL mpi_wait(ml_req1,ml_stat,ml_err) 138 END SELECT 116 IF( mpinei(jpwe) >= 0 ) CALL SENDROUTINE( 1, r2dew(1-kextj,1,1), imigr, mpinei(jpwe), ml_req1 ) 117 IF( mpinei(jpea) >= 0 ) CALL SENDROUTINE( 2, r2dwe(1-kextj,1,1), imigr, mpinei(jpea), ml_req2 ) 118 IF( mpinei(jpwe) >= 0 ) CALL RECVROUTINE( 2, r2dwe(1-kextj,1,2), imigr, mpinei(jpwe) ) 119 IF( mpinei(jpea) >= 0 ) CALL RECVROUTINE( 1, r2dew(1-kextj,1,2), imigr, mpinei(jpea) ) 120 IF( mpinei(jpwe) >= 0 ) CALL mpi_wait(ml_req1,ml_stat,ml_err) 121 IF( mpinei(jpea) >= 0 ) CALL mpi_wait(ml_req2,ml_stat,ml_err) 139 122 ! 140 123 IF( ln_timing ) CALL tic_tac(.FALSE.) … … 142 125 ! ! Write Dirichlet lateral conditions 143 126 iihom = jpi - nn_hls 144 ! 145 SELECT CASE ( nbondi ) 146 CASE ( -1 ) 127 IF( mpinei(jpwe) >= 0 ) THEN 128 DO jl = 1, ipreci 129 pt2d(jl-kexti,:) = r2dwe(:,jl,2) 130 END DO 131 ENDIF 132 IF( mpinei(jpea) >= 0 ) THEN 147 133 DO jl = 1, ipreci 148 134 pt2d(iihom+jl,:) = r2dew(:,jl,2) 149 135 END DO 150 CASE ( 0 ) 151 DO jl = 1, ipreci 152 pt2d(jl-kexti,:) = r2dwe(:,jl,2) 153 pt2d(iihom+jl,:) = r2dew(:,jl,2) 154 END DO 155 CASE ( 1 ) 156 DO jl = 1, ipreci 157 pt2d(jl-kexti,:) = r2dwe(:,jl,2) 158 END DO 159 END SELECT 160 136 ENDIF 161 137 162 138 ! 3. North and south directions … … 164 140 ! always closed : we play only with the neigbours 165 141 ! 166 IF( nbondj /= 2 ) THEN ! Read Dirichlet lateral conditions142 IF( mpinei(jpso) >= 0 .OR. mpinei(jpno) >= 0 ) THEN ! Read Dirichlet lateral conditions: all exept 2 (i.e. close case) 167 143 ijhom = jpj - (2 * nn_hls) - kextj 168 144 DO jl = 1, iprecj … … 177 153 IF( ln_timing ) CALL tic_tac(.TRUE.) 178 154 ! 179 SELECT CASE ( nbondj ) 180 CASE ( -1 ) 181 CALL SENDROUTINE( 4, r2dsn(1-kexti,1,1), imigr, nono, ml_req1 ) 182 CALL RECVROUTINE( 3, r2dns(1-kexti,1,2), imigr, nono ) 183 CALL mpi_wait(ml_req1,ml_stat,ml_err) 184 CASE ( 0 ) 185 CALL SENDROUTINE( 3, r2dns(1-kexti,1,1), imigr, noso, ml_req1 ) 186 CALL SENDROUTINE( 4, r2dsn(1-kexti,1,1), imigr, nono, ml_req2 ) 187 CALL RECVROUTINE( 3, r2dns(1-kexti,1,2), imigr, nono ) 188 CALL RECVROUTINE( 4, r2dsn(1-kexti,1,2), imigr, noso ) 189 CALL mpi_wait(ml_req1,ml_stat,ml_err) 190 CALL mpi_wait(ml_req2,ml_stat,ml_err) 191 CASE ( 1 ) 192 CALL SENDROUTINE( 3, r2dns(1-kexti,1,1), imigr, noso, ml_req1 ) 193 CALL RECVROUTINE( 4, r2dsn(1-kexti,1,2), imigr, noso ) 194 CALL mpi_wait(ml_req1,ml_stat,ml_err) 195 END SELECT 155 IF( mpinei(jpso) >= 0 ) CALL SENDROUTINE( 3, r2dns(1-kexti,1,1), imigr, mpinei(jpso), ml_req1 ) 156 IF( mpinei(jpno) >= 0 ) CALL SENDROUTINE( 4, r2dsn(1-kexti,1,1), imigr, mpinei(jpno), ml_req2 ) 157 IF( mpinei(jpso) >= 0 ) CALL RECVROUTINE( 4, r2dsn(1-kexti,1,2), imigr, mpinei(jpso) ) 158 IF( mpinei(jpno) >= 0 ) CALL RECVROUTINE( 3, r2dns(1-kexti,1,2), imigr, mpinei(jpno) ) 159 IF( mpinei(jpso) >= 0 ) CALL mpi_wait(ml_req1,ml_stat,ml_err) 160 IF( mpinei(jpso) >= 0 ) CALL mpi_wait(ml_req2,ml_stat,ml_err) 196 161 ! 197 162 IF( ln_timing ) CALL tic_tac(.FALSE.) … … 200 165 ijhom = jpj - nn_hls 201 166 ! 202 SELECT CASE ( nbondj ) 203 CASE ( -1 ) 204 DO jl = 1, iprecj 205 pt2d(:,ijhom+jl) = r2dns(:,jl,2) 206 END DO 207 CASE ( 0 ) 208 DO jl = 1, iprecj 209 pt2d(:,jl-kextj) = r2dsn(:,jl,2) 210 pt2d(:,ijhom+jl) = r2dns(:,jl,2) 211 END DO 212 CASE ( 1 ) 167 IF( mpinei(jpso) >= 0 ) THEN 213 168 DO jl = 1, iprecj 214 169 pt2d(:,jl-kextj) = r2dsn(:,jl,2) 215 170 END DO 216 END SELECT 171 ENDIF 172 IF( mpinei(jpno) >= 0 ) THEN 173 DO jl = 1, iprecj 174 pt2d(:,ijhom+jl) = r2dns(:,jl,2) 175 END DO 176 ENDIF 217 177 ! 218 178 END SUBROUTINE ROUTINE_LNK -
NEMO/branches/2021/dev_r14312_MPI_Interface/src/OCE/LBC/mpp_nc_generic.h90
r14072 r14314 46 46 CHARACTER(len=*) , INTENT(in ) :: cdname ! name of the calling subroutine 47 47 CHARACTER(len=1) , INTENT(in ) :: NAT_IN(:) ! nature of array grid-points 48 REAL( wp), INTENT(in ) :: SGN_IN(:) ! sign used across the north fold boundary48 REAL(PRECISION) , INTENT(in ) :: SGN_IN(:) ! sign used across the north fold boundary 49 49 INTEGER , OPTIONAL, INTENT(in ) :: kfillmode ! filling method for halo over land (default = constant) 50 REAL( wp),OPTIONAL, INTENT(in ) :: pfillval ! background value (used at closed boundaries)50 REAL(PRECISION), OPTIONAL, INTENT(in ) :: pfillval ! background value (used at closed boundaries) 51 51 LOGICAL, DIMENSION(4),OPTIONAL, INTENT(in ) :: lsend, lrecv ! communication with other 4 proc 52 52 LOGICAL, OPTIONAL, INTENT(in ) :: ncsten ! 5-point or 9-point stencil 53 53 ! 54 INTEGER :: ji, jj, jk, jl, jf ! dummy loop indices 55 INTEGER :: ipi, ipj, ipk, ipl, ipf ! dimension of the input array 56 INTEGER :: ishift, ishift2, idx, icount, icount1 ! local integers 57 INTEGER :: idims, idimr, isizet, isizets, isizetr, izsnd, izrcv ! local integers 54 INTEGER :: ji, jj, jk, jl, jf, jn ! dummy loop indices 55 INTEGER :: ipk, ipl, ipf ! dimension of the input array 56 INTEGER :: ip0i, ip1i, im0i, im1i 57 INTEGER :: ip0j, ip1j, im0j, im1j 58 INTEGER :: ishti, ishtj, ishti2, ishtj2 59 INTEGER :: iszs, iszr 58 60 INTEGER :: ierr 59 INTEGER :: ifill_we, ifill_ea, ifill_so, ifill_no 60 INTEGER :: ifill_web, ifill_eab 61 REAL(wp) :: zland 62 INTEGER , DIMENSION(MPI_STATUS_SIZE) :: istate ! for mpi_isend 63 REAL(PRECISION), DIMENSION(:), ALLOCATABLE :: zsnd, zrcv ! halos arrays 64 INTEGER , DIMENSION(:), ALLOCATABLE :: isizes ! number of elements to be sent 65 INTEGER , DIMENSION(:), ALLOCATABLE :: isizer ! number of elements to be received 66 INTEGER , DIMENSION(:), ALLOCATABLE :: idatatys, idatatyr ! datatype of halos arrays 67 INTEGER (KIND=MPI_ADDRESS_KIND), DIMENSION (:), ALLOCATABLE :: idispls, idisplr ! displacement in halos arrays 68 LOGICAL :: llsend_we, llsend_ea, llsend_no, llsend_so ! communication send 69 LOGICAL :: llrecv_we, llrecv_ea, llrecv_no, llrecv_so ! communication receive 70 LOGICAL :: lldo_nfd ! do north pole folding 61 INTEGER :: idx 62 INTEGER :: impi_nc 63 INTEGER, DIMENSION(4) :: iwewe, issnn 64 INTEGER, DIMENSION(8) :: isizei, ishtsi, ishtri, ishtpi 65 INTEGER, DIMENSION(8) :: isizej, ishtsj, ishtrj, ishtpj 66 INTEGER, DIMENSION(8) :: ifill, iszall 67 INTEGER, DIMENSION(:), ALLOCATABLE :: icounts, icountr ! number of elements to be sent/received 68 INTEGER, DIMENSION(:), ALLOCATABLE :: idispls, idisplr ! displacement in halos arrays 69 LOGICAL, DIMENSION(8) :: llsend, llrecv 70 REAL(PRECISION) :: zland 71 REAL(PRECISION), DIMENSION(:), ALLOCATABLE :: zsnd, zrcv ! halos arrays 71 72 LOGICAL :: llncall ! default: 9-point stencil 72 73 LOGICAL :: ll_IdoNFold 73 74 !!---------------------------------------------------------------------- 75 #if defined PRINT_CAUTION 76 ! 77 ! ================================================================================== ! 78 ! CAUTION: semi-column notation is often impossible because of the cpp preprocessing ! 79 ! ================================================================================== ! 80 ! 81 #endif 74 82 ! 75 83 ! ----------------------------------------- ! 76 ! 0. local variables initialization !84 ! 1. local variables initialization ! 77 85 ! ----------------------------------------- ! 78 86 ! 79 llncall = .TRUE.80 87 ipk = K_SIZE(ptab) ! 3rd dimension 81 88 ipl = L_SIZE(ptab) ! 4th - … … 84 91 IF( narea == 1 .AND. numcom == -1 ) CALL mpp_report( cdname, ipk, ipl, ipf, ld_lbc = .TRUE. ) 85 92 ! 86 IF ( PRESENT(lsend) .AND. PRESENT(lrecv) ) THEN 87 llsend_we = lsend(1) ; llsend_ea = lsend(2) ; llsend_so = lsend(3) ; llsend_no = lsend(4) 88 llrecv_we = lrecv(1) ; llrecv_ea = lrecv(2) ; llrecv_so = lrecv(3) ; llrecv_no = lrecv(4) 89 ELSE IF( PRESENT(lsend) .OR. PRESENT(lrecv) ) THEN 90 WRITE(ctmp1,*) ' E R R O R : Routine ', cdname, ' is calling lbc_lnk with only one of the two arguments lsend or lrecv' 91 WRITE(ctmp2,*) ' ========== ' 92 CALL ctl_stop( ' ', ctmp1, ctmp2, ' ' ) 93 ELSE ! send and receive with every neighbour 94 llsend_we = nbondi == 1 .OR. nbondi == 0 ! keep for compatibility, should be defined in mppini 95 llsend_ea = nbondi == -1 .OR. nbondi == 0 ! keep for compatibility, should be defined in mppini 96 llsend_so = nbondj == 1 .OR. nbondj == 0 ! keep for compatibility, should be defined in mppini 97 llsend_no = nbondj == -1 .OR. nbondj == 0 ! keep for compatibility, should be defined in mppini 98 llrecv_we = llsend_we ; llrecv_ea = llsend_ea ; llrecv_so = llsend_so ; llrecv_no = llsend_no 99 END IF 100 101 lldo_nfd = npolj /= 0 ! keep for compatibility, should be defined in mppini 102 93 ! take care of optional parameters 94 ! 95 llncall = .TRUE. 96 IF( PRESENT(ncsten) ) llncall = ncsten 97 ! 98 impi_nc = mpi_nc_com4 99 IF(llncall) impi_nc = mpi_nc_com8 100 ! 103 101 zland = 0._wp ! land filling value: zero by default 104 102 IF( PRESENT( pfillval ) ) zland = pfillval ! set land value 105 106 107 ! define the method we will use to fill the halos in each direction 108 IF( llrecv_we ) THEN ; ifill_we = jpfillmpi 109 ELSEIF( l_Iperio ) THEN ; ifill_we = jpfillperio 110 ELSEIF( PRESENT(kfillmode) ) THEN ; ifill_we = kfillmode 111 ELSE ; ifill_we = jpfillcst 103 ! 104 ! define llsend and llrecv: logicals which say if mpi-neibourgs for send or receive exist or not. 105 IF ( PRESENT(lsend) .AND. PRESENT(lrecv) ) THEN ! localy defined neighbourgs 106 CALL ctl_stop( 'STOP', 'mpp_nc_generic+BDY not yet implemented') 107 !!$ ---> llsend(:) = lsend(:) ; llrecv(:) = lrecv(:) ??? 108 ELSE IF( PRESENT(lsend) .OR. PRESENT(lrecv) ) THEN 109 WRITE(ctmp1,*) ' Routine ', cdname, ' is calling lbc_lnk with only one of the two arguments lsend or lrecv' 110 CALL ctl_stop( 'STOP', ctmp1 ) 111 ELSE ! default neighbours 112 llsend(:) = mpinei(:) >= 0 113 IF( .NOT. llncall ) llsend(5:8) = .FALSE. ! exclude corners 114 llrecv(:) = llsend(:) 112 115 END IF 113 IF( l_Iperio ) THEN ; ifill_web = jpfillperio 114 ELSEIF( PRESENT(kfillmode) ) THEN ; ifill_web = kfillmode 115 ELSE ; ifill_web = jpfillcst 116 END IF 117 ! 118 IF( llrecv_ea ) THEN ; ifill_ea = jpfillmpi 119 ELSEIF( l_Iperio ) THEN ; ifill_ea = jpfillperio 120 ELSEIF( PRESENT(kfillmode) ) THEN ; ifill_ea = kfillmode 121 ELSE ; ifill_ea = jpfillcst 122 END IF 123 IF( l_Iperio ) THEN ; ifill_eab = jpfillperio 124 ELSEIF( PRESENT(kfillmode) ) THEN ; ifill_eab = kfillmode 125 ELSE ; ifill_eab = jpfillcst 126 END IF 127 ! 128 IF( llrecv_so ) THEN ; ifill_so = jpfillmpi 129 ELSEIF( l_Jperio ) THEN ; ifill_so = jpfillperio 130 ELSEIF( PRESENT(kfillmode) ) THEN ; ifill_so = kfillmode 131 ELSE ; ifill_so = jpfillcst 132 END IF 133 ! 134 IF( llrecv_no ) THEN ; ifill_no = jpfillmpi 135 ELSEIF( l_Jperio ) THEN ; ifill_no = jpfillperio 136 ELSEIF( PRESENT(kfillmode) ) THEN ; ifill_no = kfillmode 137 ELSE ; ifill_no = jpfillcst 138 END IF 139 ! 140 IF(PRESENT(ncsten)) llncall = ncsten 141 #if defined PRINT_CAUTION 142 ! 143 ! ================================================================================== ! 144 ! CAUTION: semi-column notation is often impossible because of the cpp preprocessing ! 145 ! ================================================================================== ! 146 ! 147 #endif 148 ! 149 ! -------------------------------------------------- ! 150 ! 1. Do west, east, south and north MPI exchange ! 151 ! -------------------------------------------------- ! 152 ! 153 ! Allocate local temporary arrays to be sent/received. Fill arrays to be sent 154 155 idims = 0 156 idimr = 0 157 izsnd = 0 158 izrcv = 0 159 160 IF(llsend_we) idims = idims + 1 161 IF(llsend_ea) idims = idims + 1 162 IF(llsend_so) idims = idims + 1 163 IF(llsend_no) idims = idims + 1 164 165 idimr = idims 166 167 IF(llncall) THEN 168 IF(noswr .ne. -1) idimr = idimr + 1 169 IF(noser .ne. -1) idimr = idimr + 1 170 IF(nonwr .ne. -1) idimr = idimr + 1 171 IF(noner .ne. -1) idimr = idimr + 1 116 ! 117 ! define ifill: which method should be used to fill each parts (sides+corners) of the halos 118 ! default definition 119 DO jn = 1, 8 120 IF( llrecv(jn) ) THEN ; ifill(jn) = jpfillmpi ! with an mpi communication 121 ELSEIF( l_SelfPerio(jn) ) THEN ; ifill(jn) = jpfillperio ! with self-periodicity 122 ELSEIF( PRESENT(kfillmode) ) THEN ; ifill(jn) = kfillmode ! localy defined 123 ELSE ; ifill(jn) = jpfillcst ! constant value (zland) 124 END IF 125 END DO 126 ! take care of "indirect self-periodicity" for the corners 127 DO jn = 5, 8 128 IF(.NOT.l_SelfPerio(jn) .AND. l_SelfPerio(jpwe)) ifill(jn) = jpfillnothing ! no bi-perio but ew-perio: do corners later 129 IF(.NOT.l_SelfPerio(jn) .AND. l_SelfPerio(jpso)) ifill(jn) = jpfillnothing ! no bi-perio but ns-perio: do corners later 130 END DO 131 ! north fold treatment 132 ll_IdoNFold = l_IdoNFold .AND. ifill(jpno) /= jpfillnothing 133 IF( ll_IdoNFold ) ifill( (/jpno,jpnw,jpne/) ) = jpfillnothing ! we do north fold -> do nothing for northern halos 172 134 173 IF(nosws .ne. -1) idims = idims + 1 174 IF(noses .ne. -1) idims = idims + 1 175 IF(nonws .ne. -1) idims = idims + 1 176 IF(nones .ne. -1) idims = idims + 1 177 END IF 178 179 IF(llsend_we) izsnd = izsnd + nn_hls * (jpj - 2*nn_hls) * ipk * ipl * ipf 180 IF(llsend_ea) izsnd = izsnd + nn_hls * (jpj - 2*nn_hls) * ipk * ipl * ipf 181 IF(llsend_so) izsnd = izsnd + (jpi - 2*nn_hls) * nn_hls * ipk * ipl * ipf 182 IF(llsend_no) izsnd = izsnd + (jpi - 2*nn_hls) * nn_hls * ipk * ipl * ipf 183 184 izrcv = izsnd 135 ! ! ________________________ 136 ip0i = 0 ! im0j = inner |__|________________|__| 137 ip1i = nn_hls ! im1j = inner - halo | |__|__________|__| | 138 im1i = Nie0-nn_hls ! | | | | | | 139 im0i = Nie0 ! | | | | | | 140 ip0j = 0 ! | | | | | | 141 ip1j = nn_hls ! | |__|__________|__| | 142 im1j = Nje0-nn_hls ! ip1j = halo |__|__|__________|__|__| 143 im0j = Nje0 ! ip0j = 0 |__|________________|__| 144 ! ! ip0i ip1i im1i im0i 145 ! 146 iwewe(:) = (/ jpwe,jpea,jpwe,jpea /) ; issnn(:) = (/ jpso,jpso,jpno,jpno /) 147 ! sides: west east south north ; corners: so-we, so-ea, no-we, no-ea 148 isizei(1:4) = (/ nn_hls, nn_hls, Ni_0, Ni_0 /) ; isizei(5:8) = nn_hls ! i- count 149 isizej(1:4) = (/ Nj_0, Nj_0, nn_hls, nn_hls /) ; isizej(5:8) = nn_hls ! j- count 150 ishtsi(1:4) = (/ ip1i, im1i, ip1i, ip1i /) ; ishtsi(5:8) = ishtsi( iwewe ) ! i- shift send data 151 ishtsj(1:4) = (/ ip1j, ip1j, ip1j, im1j /) ; ishtsj(5:8) = ishtsj( issnn ) ! j- shift send data 152 ishtri(1:4) = (/ ip0i, im0i, ip1i, ip1i /) ; ishtri(5:8) = ishtri( iwewe ) ! i- shift received data location 153 ishtrj(1:4) = (/ ip1j, ip1j, ip0j, im0j /) ; ishtrj(5:8) = ishtrj( issnn ) ! j- shift received data location 154 ishtpi(1:4) = (/ im1i, ip1i, ip1i, ip1i /) ; ishtpi(5:8) = ishtpi( iwewe ) ! i- shift data used for periodicity 155 ishtpj(1:4) = (/ ip1j, ip1j, im1j, ip1j /) ; ishtpj(5:8) = ishtpj( issnn ) ! j- shift data used for periodicity 156 ! 157 ! -------------------------------- ! 158 ! 2. Prepare MPI exchanges ! 159 ! -------------------------------- ! 160 ! 161 ! Allocate local temporary arrays to be sent/received. 162 iszs = COUNT( llsend ) 163 iszr = COUNT( llrecv ) 164 ALLOCATE( icounts(iszs), icountr(iszr), idispls(iszs), idisplr(iszr) ) ! ok if iszs = 0 or iszr = 0 165 iszall(:) = isizei(:) * isizej(:) * ipk * ipl * ipf 166 icounts(:) = PACK( iszall, mask = llsend ) ! ok if mask = .false. 167 icountr(:) = PACK( iszall, mask = llrecv ) 168 idispls(1) = 0 169 DO jn = 2,iszs 170 idispls(jn) = idispls(jn-1) + icounts(jn-1) ! with _alltoallv: in units of sendtype 171 END DO 172 idisplr(1) = 0 173 DO jn = 2,iszr 174 idisplr(jn) = idisplr(jn-1) + icountr(jn-1) ! with _alltoallv: in units of sendtype 175 END DO 185 176 186 IF(llncall) THEN 187 IF(noswr .ne. -1) izrcv = izrcv + nn_hls * nn_hls * ipk * ipl * ipf 188 IF(noser .ne. -1) izrcv = izrcv + nn_hls * nn_hls * ipk * ipl * ipf 189 IF(nonwr .ne. -1) izrcv = izrcv + nn_hls * nn_hls * ipk * ipl * ipf 190 IF(noner .ne. -1) izrcv = izrcv + nn_hls * nn_hls * ipk * ipl * ipf 191 192 IF(nosws .ne. -1) izsnd = izsnd + nn_hls * nn_hls * ipk * ipl * ipf 193 IF(noses .ne. -1) izsnd = izsnd + nn_hls * nn_hls * ipk * ipl * ipf 194 IF(nonws .ne. -1) izsnd = izsnd + nn_hls * nn_hls * ipk * ipl * ipf 195 IF(nones .ne. -1) izsnd = izsnd + nn_hls * nn_hls * ipk * ipl * ipf 196 END IF 197 198 ALLOCATE(zsnd(izsnd)) 199 ALLOCATE(zrcv(izrcv)) 200 ALLOCATE(isizes(idims)) 201 ALLOCATE(isizer(idimr)) 202 ALLOCATE(idatatys(idims)) 203 ALLOCATE(idatatyr(idimr)) 204 ALLOCATE(idispls(idims)) 205 ALLOCATE(idisplr(idimr)) 206 207 zrcv(:)=-1 208 zsnd(:)=-1 209 isizes(:) = 0 210 isizer(:) = 0 211 idispls(:) = 0 212 idisplr(:) = 0 213 isizet = 0 214 177 ALLOCATE( zsnd(SUM(icounts)), zrcv(SUM(icountr)) ) 178 179 ! fill sending buffer with ARRAY_IN 215 180 idx = 1 216 icount = 1 217 218 IF(llsend_we) THEN 219 DO jf = 1, ipf ; DO jl = 1, ipl ; DO jk = 1, ipk ; DO jj = nn_hls + 1, jpj - nn_hls ; DO ji = 1, nn_hls 220 zsnd(idx) = ARRAY_IN(nn_hls+ji,jj,jk,jl,jf) 221 idx = idx + 1 222 END DO ; END DO ; END DO ; END DO ; END DO 223 224 isizes(icount) = nn_hls * (jpj - 2*nn_hls) * ipk * ipl * ipf 225 IF(icount .gt. 1) isizet = isizet + isizes(icount - 1) 226 idispls(icount) = jpbyt*isizet 227 icount = icount + 1 228 END IF 229 230 IF(llsend_ea) THEN 231 ishift = jpi-2*nn_hls 232 233 DO jf = 1, ipf ; DO jl = 1, ipl ; DO jk = 1, ipk ; DO jj = nn_hls + 1, jpj - nn_hls ; DO ji = 1, nn_hls 234 zsnd(idx) = ARRAY_IN(ishift+ji,jj,jk,jl,jf) 235 idx = idx + 1 236 END DO ; END DO ; END DO ; END DO ; END DO 237 238 isizes(icount) = nn_hls * (jpj - 2*nn_hls) * ipk * ipl * ipf 239 IF(icount .gt. 1) isizet = isizet + isizes(icount - 1) 240 idispls(icount) = jpbyt*isizet 241 icount = icount + 1 242 END IF 243 244 IF(llsend_so) THEN 245 DO jf = 1, ipf ; DO jl = 1, ipl ; DO jk = 1, ipk ; DO jj = 1, nn_hls ; DO ji = nn_hls + 1, jpi - nn_hls 246 zsnd(idx) = ARRAY_IN(ji,nn_hls+jj,jk,jl,jf) 247 idx = idx + 1 248 END DO ; END DO ; END DO ; END DO ; END DO 249 250 isizes(icount) = (jpi - 2*nn_hls) * nn_hls * ipk * ipl * ipf 251 IF(icount .gt. 1) isizet = isizet + isizes(icount - 1) 252 idispls(icount) = jpbyt*isizet 253 icount = icount + 1 254 END IF 255 256 IF(llsend_no) THEN 257 ishift = jpj-2*nn_hls 258 259 DO jf = 1, ipf ; DO jl = 1, ipl ; DO jk = 1, ipk ; DO jj = 1, nn_hls ; DO ji = nn_hls + 1, jpi - nn_hls 260 zsnd(idx) = ARRAY_IN(ji,ishift+jj,jk,jl,jf) 261 idx = idx + 1 262 END DO ; END DO ; END DO ; END DO ; END DO 263 264 isizes(icount) = (jpi - 2*nn_hls) * nn_hls * ipk * ipl * ipf 265 IF(icount .gt. 1) isizet = isizet + isizes(icount - 1) 266 idispls(icount) = jpbyt*isizet 267 icount = icount + 1 268 END IF 269 270 isizer(:) = isizes(:) 271 idisplr(:) = idispls(:) 272 273 icount1 = icount 274 isizets = isizet 275 isizetr = isizet 276 277 IF(llncall) THEN 278 IF(noswr .ne. -1) THEN 279 isizer(icount1) = nn_hls * nn_hls * ipk * ipl * ipf 280 IF(icount1 .gt. 1) isizetr = isizetr + isizer(icount1 - 1) 281 idisplr(icount1) = jpbyt*isizetr 282 icount1 = icount1 + 1 181 DO jn = 1, 8 182 IF( llsend(jn) ) THEN 183 ishti = ishtsi(jn) 184 ishtj = ishtsj(jn) 185 DO jf = 1, ipf ; DO jl = 1, ipl ; DO jk = 1, ipk ; DO jj = 1,isizej(jn) ; DO ji = 1,isizei(jn) 186 zsnd(idx) = ARRAY_IN(ishti+ji,ishtj+jj,jk,jl,jf) 187 idx = idx + 1 188 END DO ; END DO ; END DO ; END DO ; END DO 283 189 END IF 284 IF(noser .ne. -1) THEN 285 isizer(icount1) = nn_hls * nn_hls * ipk * ipl * ipf 286 IF(icount1 .gt. 1) isizetr = isizetr + isizer(icount1 - 1) 287 idisplr(icount1) = jpbyt*isizetr 288 icount1 = icount1 + 1 289 END IF 290 IF(nonwr .ne. -1) THEN 291 isizer(icount1) = nn_hls * nn_hls * ipk * ipl * ipf 292 IF(icount1 .gt. 1) isizetr = isizetr + isizer(icount1 - 1) 293 idisplr(icount1) = jpbyt*isizetr 294 icount1 = icount1 + 1 295 END IF 296 IF(noner .ne. -1) THEN 297 isizer(icount1) = nn_hls * nn_hls * ipk * ipl * ipf 298 IF(icount1 .gt. 1) isizetr = isizetr + isizer(icount1 - 1) 299 idisplr(icount1) = jpbyt*isizetr 300 icount1 = icount1 + 1 301 END IF 302 303 IF(nosws .ne. -1) THEN 304 DO jf = 1, ipf ; DO jl = 1, ipl ; DO jk = 1, ipk ; DO jj = 1, nn_hls ; DO ji = 1, nn_hls 305 zsnd(idx) = ARRAY_IN(nn_hls+ji,nn_hls+jj,jk,jl,jf) 190 END DO 191 ! 192 ! ------------------------------------------------ ! 193 ! 3. Do all MPI exchanges in 1 unique call ! 194 ! ------------------------------------------------ ! 195 ! 196 IF( ln_timing ) CALL tic_tac(.TRUE.) 197 CALL mpi_neighbor_alltoallv (zsnd, icounts, idispls, MPI_TYPE, zrcv, icountr, idisplr, MPI_TYPE, impi_nc, ierr) 198 IF( ln_timing ) CALL tic_tac(.FALSE.) 199 ! 200 ! ------------------------- ! 201 ! 4. Fill all halos ! 202 ! ------------------------- ! 203 ! 204 idx = 1 205 DO jn = 1, 8 206 ishti = ishtri(jn) 207 ishtj = ishtrj(jn) 208 SELECT CASE ( ifill(jn) ) 209 CASE ( jpfillnothing ) ! no filling 210 CASE ( jpfillmpi ) ! fill with data received by MPI 211 DO jf = 1, ipf ; DO jl = 1, ipl ; DO jk = 1, ipk ; DO jj = 1,isizej(jn) ; DO ji = 1,isizei(jn) 212 ARRAY_IN(ishti+ji,ishtj+jj,jk,jl,jf) = zrcv(idx) 306 213 idx = idx + 1 307 214 END DO ; END DO ; END DO ; END DO ; END DO 308 309 isizes(icount) = nn_hls * nn_hls * ipk * ipl * ipf 310 IF(icount .gt. 1) isizets = isizets + isizes(icount - 1) 311 idispls(icount) = jpbyt*isizets 312 icount = icount + 1 313 END IF 314 IF(noses .ne. -1) THEN 315 ishift = jpi-2*nn_hls 316 DO jf = 1, ipf ; DO jl = 1, ipl ; DO jk = 1, ipk ; DO jj = 1, nn_hls ; DO ji = 1, nn_hls 317 zsnd(idx) = ARRAY_IN(ji+ishift,nn_hls+jj,jk,jl,jf) 318 idx = idx + 1 319 END DO ; END DO ; END DO ; END DO ; END DO 320 321 isizes(icount) = nn_hls * nn_hls * ipk * ipl * ipf 322 IF(icount .gt. 1) isizets = isizets + isizes(icount - 1) 323 idispls(icount) = jpbyt*isizets 324 icount = icount + 1 325 END IF 326 IF(nonws .ne. -1) THEN 327 ishift = jpj-2*nn_hls 328 DO jf = 1, ipf ; DO jl = 1, ipl ; DO jk = 1, ipk ; DO jj = 1, nn_hls ; DO ji = 1, nn_hls 329 zsnd(idx) = ARRAY_IN(nn_hls+ji,jj+ishift,jk,jl,jf) 330 idx = idx + 1 331 END DO ; END DO ; END DO ; END DO ; END DO 332 333 isizes(icount) = nn_hls * nn_hls * ipk * ipl * ipf 334 IF(icount .gt. 1) isizets = isizets + isizes(icount - 1) 335 idispls(icount) = jpbyt*isizets 336 icount = icount + 1 337 END IF 338 IF(nones .ne. -1) THEN 339 ishift = jpi-2*nn_hls 340 ishift2 = jpj-2*nn_hls 341 DO jf = 1, ipf ; DO jl = 1, ipl ; DO jk = 1, ipk ; DO jj = 1, nn_hls ; DO ji = 1, nn_hls 342 zsnd(idx) = ARRAY_IN(ji+ishift,jj+ishift2,jk,jl,jf) 343 idx = idx + 1 344 END DO ; END DO ; END DO ; END DO ; END DO 345 346 isizes(icount) = nn_hls * nn_hls * ipk * ipl * ipf 347 IF(icount .gt. 1) isizets = isizets + isizes(icount - 1) 348 idispls(icount) = jpbyt*isizets 349 icount = icount + 1 350 END IF 351 END IF 352 353 idatatys(:) = MPI_TYPE 354 idatatyr(:) = MPI_TYPE 355 356 IF(llncall) THEN 357 IF( ln_timing ) CALL tic_tac(.TRUE.) 358 CALL mpi_neighbor_alltoallw (zsnd, isizes, idispls, idatatys, zrcv, isizer, idisplr, idatatyr, mpi_nc_all_com, ierr) 359 IF( ln_timing ) CALL tic_tac(.FALSE.) 360 ELSE 361 IF( ln_timing ) CALL tic_tac(.TRUE.) 362 CALL mpi_neighbor_alltoallw (zsnd, isizes, idispls, idatatys, zrcv, isizer, idisplr, idatatyr, mpi_nc_com, ierr) 363 IF( ln_timing ) CALL tic_tac(.FALSE.) 364 END IF 365 366 ! --------------------------------------------------- ! 367 ! 2. Fill east and west north and south halos ! 368 ! --------------------------------------------------- ! 369 ! 370 !!! Patch to solve MPI3 bug when we have only two processes columns 371 IF(jpni .eq. 2) THEN 372 ! --------------------- 373 ! 2.2 fill eastern halo 374 ! --------------------- 375 idx = 1 376 ishift = jpi - nn_hls ! fill halo from ji = jpi-nn_hls+1 to jpi 377 SELECT CASE ( ifill_ea ) 378 CASE ( jpfillnothing ) ! no filling 379 CASE ( jpfillmpi ) ! use data received by MPI 380 DO jf = 1, ipf ; DO jl = 1, ipl ; DO jk = 1, ipk ; DO jj = nn_hls + 1, jpj - nn_hls ; DO ji = 1, nn_hls 381 ARRAY_IN(ishift+ji,jj,jk,jl,jf) = zrcv(idx) ! jpi - nn_hls + 1 -> jpi 382 idx = idx + 1 383 END DO ; END DO ; END DO ; END DO ; END DO 384 CASE ( jpfillperio ) ! use east-weast periodicity 385 ishift2 = nn_hls 386 DO jf = 1, ipf ; DO jl = 1, ipl ; DO jk = 1, ipk ; DO jj = 1, jpj ; DO ji = 1, nn_hls 387 ARRAY_IN(ishift+ji,jj,jk,jl,jf) = ARRAY_IN(ishift2+ji,jj,jk,jl,jf) 215 CASE ( jpfillperio ) ! use periodicity 216 ishti2 = ishtpi(jn) 217 ishtj2 = ishtpj(jn) 218 DO jf = 1, ipf ; DO jl = 1, ipl ; DO jk = 1, ipk ; DO jj = 1,isizej(jn) ; DO ji = 1,isizei(jn) 219 ARRAY_IN(ishti+ji,ishtj+jj,jk,jl,jf) = ARRAY_IN(ishti2+ji,ishtj2+jj,jk,jl,jf) 388 220 END DO ; END DO ; END DO ; END DO ; END DO 389 221 CASE ( jpfillcopy ) ! filling with inner domain values 390 DO jf = 1, ipf ; DO jl = 1, ipl ; DO jk = 1, ipk ; DO jj = 1, jpj ; DO ji = 1, nn_hls 391 ARRAY_IN(ishift+ji,jj,jk,jl,jf) = ARRAY_IN(ishift,jj,jk,jl,jf) 222 ishti2 = ishtsi(jn) 223 ishtj2 = ishtsj(jn) 224 DO jf = 1, ipf ; DO jl = 1, ipl ; DO jk = 1, ipk ; DO jj = 1,isizej(jn) ; DO ji = 1,isizei(jn) 225 ARRAY_IN(ishti+ji,ishtj+jj,jk,jl,jf) = ARRAY_IN(ishti2+ji,ishtj2+jj,jk,jl,jf) 392 226 END DO ; END DO ; END DO ; END DO ; END DO 393 227 CASE ( jpfillcst ) ! filling with constant value 394 DO jf = 1, ipf ; DO jl = 1, ipl ; DO jk = 1, ipk ; DO jj = 1, jpj ; DO ji = 1, nn_hls395 ARRAY_IN(ish ift+ji,jj,jk,jl,jf) = zland228 DO jf = 1, ipf ; DO jl = 1, ipl ; DO jk = 1, ipk ; DO jj = 1,isizej(jn) ; DO ji = 1,isizei(jn) 229 ARRAY_IN(ishti+ji,ishtj+jj,jk,jl,jf) = zland 396 230 END DO ; END DO ; END DO ; END DO ; END DO 397 231 END SELECT 398 ! ---------------------- 399 ! 2.1 fill weastern halo 400 ! ---------------------- 401 SELECT CASE ( ifill_we ) 402 CASE ( jpfillnothing ) ! no filling 403 CASE ( jpfillmpi ) ! use data received by MPI 404 DO jf = 1, ipf ; DO jl = 1, ipl ; DO jk = 1, ipk ; DO jj = nn_hls + 1, jpj - nn_hls ; DO ji = 1, nn_hls 405 ARRAY_IN(ji,jj,jk,jl,jf) = zrcv(idx) ! 1 -> nn_hls 406 idx = idx + 1 407 END DO; END DO ; END DO ; END DO ; END DO 408 CASE ( jpfillperio ) ! use east-weast periodicity 409 ishift2 = jpi - 2 * nn_hls 410 DO jf = 1, ipf ; DO jl = 1, ipl ; DO jk = 1, ipk ; DO jj = 1, jpj ; DO ji = 1, nn_hls 411 ARRAY_IN(ji,jj,jk,jl,jf) = ARRAY_IN(ishift2+ji,jj,jk,jl,jf) 412 END DO ; END DO ; END DO ; END DO ; END DO 413 CASE ( jpfillcopy ) ! filling with inner domain values 414 DO jf = 1, ipf ; DO jl = 1, ipl ; DO jk = 1, ipk ; DO jj = 1, jpj ; DO ji = 1, nn_hls 415 ARRAY_IN(ji,jj,jk,jl,jf) = ARRAY_IN(nn_hls+1,jj,jk,jl,jf) 416 END DO ; END DO ; END DO ; END DO ; END DO 417 CASE ( jpfillcst ) ! filling with constant value 418 DO jf = 1, ipf ; DO jl = 1, ipl ; DO jk = 1, ipk ; DO jj = 1, jpj ; DO ji = 1, nn_hls 419 ARRAY_IN(ji,jj,jk,jl,jf) = zland 420 END DO ; END DO ; END DO ; END DO ; END DO 421 END SELECT 422 423 ELSE 424 425 ! ---------------------- 426 ! 2.1 fill weastern halo 427 ! ---------------------- 428 idx = 1 429 SELECT CASE ( ifill_we ) 430 CASE ( jpfillnothing ) ! no filling 431 CASE ( jpfillmpi ) ! use data received by MPI 432 DO jf = 1, ipf ; DO jl = 1, ipl ; DO jk = 1, ipk ; DO jj = nn_hls + 1, jpj - nn_hls ; DO ji = 1, nn_hls 433 ARRAY_IN(ji,jj,jk,jl,jf) = zrcv(idx) ! 1 -> nn_hls 434 idx = idx + 1 435 END DO; END DO ; END DO ; END DO ; END DO 436 CASE ( jpfillperio ) ! use east-weast periodicity 437 ishift2 = jpi - 2 * nn_hls 438 DO jf = 1, ipf ; DO jl = 1, ipl ; DO jk = 1, ipk ; DO jj = 1, jpj ; DO ji = 1, nn_hls 439 ARRAY_IN(ji,jj,jk,jl,jf) = ARRAY_IN(ishift2+ji,jj,jk,jl,jf) 440 END DO ; END DO ; END DO ; END DO ; END DO 441 CASE ( jpfillcopy ) ! filling with inner domain values 442 DO jf = 1, ipf ; DO jl = 1, ipl ; DO jk = 1, ipk ; DO jj = 1, jpj ; DO ji = 1, nn_hls 443 ARRAY_IN(ji,jj,jk,jl,jf) = ARRAY_IN(nn_hls+1,jj,jk,jl,jf) 444 END DO ; END DO ; END DO ; END DO ; END DO 445 CASE ( jpfillcst ) ! filling with constant value 446 DO jf = 1, ipf ; DO jl = 1, ipl ; DO jk = 1, ipk ; DO jj = 1, jpj ; DO ji = 1, nn_hls 447 ARRAY_IN(ji,jj,jk,jl,jf) = zland 448 END DO ; END DO ; END DO ; END DO ; END DO 449 END SELECT 450 ! --------------------- 451 ! 2.2 fill eastern halo 452 ! --------------------- 453 ishift = jpi - nn_hls ! fill halo from ji = jpi-nn_hls+1 to jpi 454 SELECT CASE ( ifill_ea ) 455 CASE ( jpfillnothing ) ! no filling 456 CASE ( jpfillmpi ) ! use data received by MPI 457 DO jf = 1, ipf ; DO jl = 1, ipl ; DO jk = 1, ipk ; DO jj = nn_hls + 1, jpj - nn_hls ; DO ji = 1, nn_hls 458 ARRAY_IN(ishift+ji,jj,jk,jl,jf) = zrcv(idx) ! jpi - nn_hls + 1 -> jpi 459 idx = idx + 1 460 END DO ; END DO ; END DO ; END DO ; END DO 461 CASE ( jpfillperio ) ! use east-weast periodicity 462 ishift2 = nn_hls 463 DO jf = 1, ipf ; DO jl = 1, ipl ; DO jk = 1, ipk ; DO jj = 1, jpj ; DO ji = 1, nn_hls 464 ARRAY_IN(ishift+ji,jj,jk,jl,jf) = ARRAY_IN(ishift2+ji,jj,jk,jl,jf) 465 END DO ; END DO ; END DO ; END DO ; END DO 466 CASE ( jpfillcopy ) ! filling with inner domain values 467 DO jf = 1, ipf ; DO jl = 1, ipl ; DO jk = 1, ipk ; DO jj = 1, jpj ; DO ji = 1, nn_hls 468 ARRAY_IN(ishift+ji,jj,jk,jl,jf) = ARRAY_IN(ishift,jj,jk,jl,jf) 469 END DO ; END DO ; END DO ; END DO ; END DO 470 CASE ( jpfillcst ) ! filling with constant value 471 DO jf = 1, ipf ; DO jl = 1, ipl ; DO jk = 1, ipk ; DO jj = 1, jpj ; DO ji = 1, nn_hls 472 ARRAY_IN(ishift+ji,jj,jk,jl,jf) = zland 473 END DO ; END DO ; END DO ; END DO ; END DO 474 END SELECT 475 476 ENDIF 477 478 !!! Patch to solve MPI3 bug when we have only two processes rows 479 IF(jpnj .eq. 2) THEN 480 ! ---------------------- 481 ! 2.3 fill northern halo 482 ! ---------------------- 483 ishift = jpj - nn_hls ! fill halo from jj = jpj-nn_hls+1 to jpj 484 SELECT CASE ( ifill_no ) 485 CASE ( jpfillnothing ) ! no filling 486 CASE ( jpfillmpi ) ! use data received by MPI 487 DO jf = 1, ipf ; DO jl = 1, ipl ; DO jk = 1, ipk ; DO jj = 1, nn_hls ; DO ji = nn_hls + 1, jpi - nn_hls 488 ARRAY_IN(ji,ishift+jj,jk,jl,jf) = zrcv(idx) ! jpj-nn_hls+1 -> jpj 489 idx = idx + 1 490 END DO ; END DO ; END DO ; END DO ; END DO 491 IF(nonwr .eq. -1) THEN 492 ishift = jpj - nn_hls 493 SELECT CASE ( ifill_web ) 494 CASE ( jpfillperio ) 495 ishift2 = jpi - 2 * nn_hls 496 DO jf = 1, ipf ; DO jl = 1, ipl ; DO jk = 1, ipk ; DO jj = 1 + ishift, jpj ; DO ji = 1, nn_hls 497 ARRAY_IN(ji,jj,jk,jl,jf) = ARRAY_IN(ishift2+ji,jj,jk,jl,jf) 498 END DO ; END DO ; END DO ; END DO ; END DO 499 CASE ( jpfillcopy ) 500 DO jf = 1, ipf ; DO jl = 1, ipl ; DO jk = 1, ipk ; DO jj = 1 + ishift, jpj ; DO ji = 1, nn_hls 501 ARRAY_IN(ji,jj,jk,jl,jf) = ARRAY_IN(nn_hls+1,jj,jk,jl,jf) 502 END DO ; END DO ; END DO ; END DO ; END DO 503 504 CASE ( jpfillcst ) 505 DO jf = 1, ipf ; DO jl = 1, ipl ; DO jk = 1, ipk ; DO jj = 1 + ishift, jpj ; DO ji = 1, nn_hls 506 ARRAY_IN(ji,jj,jk,jl,jf) = zland 507 END DO ; END DO ; END DO ; END DO ; END DO 508 END SELECT 509 END IF 510 IF(noner .eq. -1) THEN 511 ishift = jpi - nn_hls 512 ishift2 = jpj - nn_hls 513 SELECT CASE ( ifill_eab ) 514 CASE ( jpfillperio ) 515 DO jf = 1, ipf ; DO jl = 1, ipl ; DO jk = 1, ipk ; DO jj = 1 + ishift2, jpj ; DO ji = 1, nn_hls 516 ARRAY_IN(ishift+ji,jj,jk,jl,jf) = ARRAY_IN(ji,jj,jk,jl,jf) 517 END DO ; END DO ; END DO ; END DO ; END DO 518 519 CASE ( jpfillcopy ) 520 DO jf = 1, ipf ; DO jl = 1, ipl ; DO jk = 1, ipk ; DO jj = 1 + ishift2, jpj ; DO ji = 1, nn_hls 521 ARRAY_IN(ishift+ji,jj,jk,jl,jf) = ARRAY_IN(ishift,jj,jk,jl,jf) 522 END DO ; END DO ; END DO ; END DO ; END DO 523 CASE ( jpfillcst ) 524 DO jf = 1, ipf ; DO jl = 1, ipl ; DO jk = 1, ipk ; DO jj = 1 + ishift2, jpj ; DO ji = 1, nn_hls 525 ARRAY_IN(ishift+ji,jj,jk,jl,jf) = zland 526 END DO ; END DO ; END DO ; END DO ; END DO 527 END SELECT 528 END IF 529 CASE ( jpfillperio ) ! use north-south periodicity 530 ishift2 = nn_hls 531 DO jf = 1, ipf ; DO jl = 1, ipl ; DO jk = 1, ipk ; DO jj = 1, nn_hls ; DO ji = 1, jpi 532 ARRAY_IN(ji,ishift+jj,jk,jl,jf) = ARRAY_IN(ji,ishift2+jj,jk,jl,jf) 533 END DO ; END DO ; END DO ; END DO ; END DO 534 CASE ( jpfillcopy ) ! filling with inner domain values 535 DO jf = 1, ipf ; DO jl = 1, ipl ; DO jk = 1, ipk ; DO jj = 1, nn_hls ; DO ji = 1, jpi 536 ARRAY_IN(ji,ishift+jj,jk,jl,jf) = ARRAY_IN(ji,ishift,jk,jl,jf) 537 END DO ; END DO ; END DO ; END DO ; END DO 538 CASE ( jpfillcst ) ! filling with constant value 539 DO jf = 1, ipf ; DO jl = 1, ipl ; DO jk = 1, ipk ; DO jj = 1, nn_hls ; DO ji = 1, jpi 540 ARRAY_IN(ji,ishift+jj,jk,jl,jf) = zland 541 END DO ; END DO ; END DO ; END DO ; END DO 542 END SELECT 543 544 ! ---------------------- 545 ! 2.4 fill southern halo 546 ! ---------------------- 547 SELECT CASE ( ifill_so ) 548 CASE ( jpfillnothing ) ! no filling 549 CASE ( jpfillmpi ) ! use data received by MPI 550 DO jf = 1, ipf ; DO jl = 1, ipl ; DO jk = 1, ipk ; DO jj = 1, nn_hls ; DO ji = nn_hls + 1, jpi - nn_hls 551 ARRAY_IN(ji,jj,jk,jl,jf) = zrcv(idx) ! 1 -> nn_hls 552 idx = idx + 1 553 END DO; END DO ; END DO ; END DO ; END DO 554 IF(noswr .eq. -1) THEN 555 SELECT CASE ( ifill_web ) 556 CASE ( jpfillperio ) 557 ishift2 = jpi - 2 * nn_hls 558 DO jf = 1, ipf ; DO jl = 1, ipl ; DO jk = 1, ipk ; DO jj = 1, nn_hls ; DO ji = 1, nn_hls 559 ARRAY_IN(ji,jj,jk,jl,jf) = ARRAY_IN(ishift2+ji,jj,jk,jl,jf) 560 END DO ; END DO ; END DO ; END DO ; END DO 561 CASE ( jpfillcopy ) 562 DO jf = 1, ipf ; DO jl = 1, ipl ; DO jk = 1, ipk ; DO jj = 1, nn_hls ; DO ji = 1, nn_hls 563 ARRAY_IN(ji,jj,jk,jl,jf) = ARRAY_IN(nn_hls+1,jj,jk,jl,jf) 564 END DO ; END DO ; END DO ; END DO ; END DO 565 566 CASE ( jpfillcst ) 567 DO jf = 1, ipf ; DO jl = 1, ipl ; DO jk = 1, ipk ; DO jj = 1, nn_hls ; DO ji = 1, nn_hls 568 ARRAY_IN(ji,jj,jk,jl,jf) = zland 569 END DO ; END DO ; END DO ; END DO ; END DO 570 END SELECT 571 END IF 572 IF(noser .eq. -1) THEN 573 ishift = jpi - nn_hls 574 SELECT CASE ( ifill_eab ) 575 CASE ( jpfillperio ) 576 DO jf = 1, ipf ; DO jl = 1, ipl ; DO jk = 1, ipk ; DO jj = 1, nn_hls ; DO ji = 1, nn_hls 577 ARRAY_IN(ishift+ji,jj,jk,jl,jf) = ARRAY_IN(ji+nn_hls,jj,jk,jl,jf) 578 END DO ; END DO ; END DO ; END DO ; END DO 579 580 CASE ( jpfillcopy ) 581 DO jf = 1, ipf ; DO jl = 1, ipl ; DO jk = 1, ipk ; DO jj = 1, nn_hls ; DO ji = 1, nn_hls 582 ARRAY_IN(ishift+ji,jj,jk,jl,jf) = ARRAY_IN(ishift,jj,jk,jl,jf) 583 END DO ; END DO ; END DO ; END DO ; END DO 584 CASE ( jpfillcst ) 585 DO jf = 1, ipf ; DO jl = 1, ipl ; DO jk = 1, ipk ; DO jj = 1, nn_hls ; DO ji = 1, nn_hls 586 ARRAY_IN(ishift+ji,jj,jk,jl,jf) = zland 587 END DO ; END DO ; END DO ; END DO ; END DO 588 END SELECT 589 END IF 590 CASE ( jpfillperio ) ! use north-south periodicity 591 ishift2 = jpj - 2 * nn_hls 592 DO jf = 1, ipf ; DO jl = 1, ipl ; DO jk = 1, ipk ; DO jj = 1, nn_hls ; DO ji = 1, jpi 593 ARRAY_IN(ji,jj,jk,jl,jf) = ARRAY_IN(ji,ishift2+jj,jk,jl,jf) 594 END DO ; END DO ; END DO ; END DO ; END DO 595 CASE ( jpfillcopy ) ! filling with inner domain values 596 DO jf = 1, ipf ; DO jl = 1, ipl ; DO jk = 1, ipk ; DO jj = 1, nn_hls ; DO ji = 1, jpi 597 ARRAY_IN(ji,jj,jk,jl,jf) = ARRAY_IN(ji,nn_hls+1,jk,jl,jf) 598 END DO ; END DO ; END DO ; END DO ; END DO 599 CASE ( jpfillcst ) ! filling with constant value 600 DO jf = 1, ipf ; DO jl = 1, ipl ; DO jk = 1, ipk ; DO jj = 1, nn_hls ; DO ji = 1, jpi 601 ARRAY_IN(ji,jj,jk,jl,jf) = zland 602 END DO ; END DO ; END DO ; END DO ; END DO 603 END SELECT 604 ELSE 605 ! ---------------------- 606 ! 2.3 fill southern halo 607 ! ---------------------- 608 SELECT CASE ( ifill_so ) 609 CASE ( jpfillnothing ) ! no filling 610 CASE ( jpfillmpi ) ! use data received by MPI 611 DO jf = 1, ipf ; DO jl = 1, ipl ; DO jk = 1, ipk ; DO jj = 1, nn_hls ; DO ji = nn_hls + 1, jpi - nn_hls 612 ARRAY_IN(ji,jj,jk,jl,jf) = zrcv(idx) ! 1 -> nn_hls 613 idx = idx + 1 614 END DO; END DO ; END DO ; END DO ; END DO 615 IF(noswr .eq. -1) THEN 616 SELECT CASE ( ifill_web ) 617 CASE ( jpfillperio ) 618 ishift2 = jpi - 2 * nn_hls 619 DO jf = 1, ipf ; DO jl = 1, ipl ; DO jk = 1, ipk ; DO jj = 1, nn_hls ; DO ji = 1, nn_hls 620 ARRAY_IN(ji,jj,jk,jl,jf) = ARRAY_IN(ishift2+ji,jj,jk,jl,jf) 621 END DO ; END DO ; END DO ; END DO ; END DO 622 CASE ( jpfillcopy ) 623 DO jf = 1, ipf ; DO jl = 1, ipl ; DO jk = 1, ipk ; DO jj = 1, nn_hls ; DO ji = 1, nn_hls 624 ARRAY_IN(ji,jj,jk,jl,jf) = ARRAY_IN(nn_hls+1,jj,jk,jl,jf) 625 END DO ; END DO ; END DO ; END DO ; END DO 626 627 CASE ( jpfillcst ) 628 DO jf = 1, ipf ; DO jl = 1, ipl ; DO jk = 1, ipk ; DO jj = 1, nn_hls ; DO ji = 1, nn_hls 629 ARRAY_IN(ji,jj,jk,jl,jf) = zland 630 END DO ; END DO ; END DO ; END DO ; END DO 631 END SELECT 632 END IF 633 IF(noser .eq. -1) THEN 634 ishift = jpi - nn_hls 635 SELECT CASE ( ifill_eab ) 636 CASE ( jpfillperio ) 637 DO jf = 1, ipf ; DO jl = 1, ipl ; DO jk = 1, ipk ; DO jj = 1, nn_hls ; DO ji = 1, nn_hls 638 ARRAY_IN(ishift+ji,jj,jk,jl,jf) = ARRAY_IN(ji+nn_hls,jj,jk,jl,jf) 639 END DO ; END DO ; END DO ; END DO ; END DO 640 641 CASE ( jpfillcopy ) 642 DO jf = 1, ipf ; DO jl = 1, ipl ; DO jk = 1, ipk ; DO jj = 1, nn_hls ; DO ji = 1, nn_hls 643 ARRAY_IN(ishift+ji,jj,jk,jl,jf) = ARRAY_IN(ishift,jj,jk,jl,jf) 644 END DO ; END DO ; END DO ; END DO ; END DO 645 CASE ( jpfillcst ) 646 DO jf = 1, ipf ; DO jl = 1, ipl ; DO jk = 1, ipk ; DO jj = 1, nn_hls ; DO ji = 1, nn_hls 647 ARRAY_IN(ishift+ji,jj,jk,jl,jf) = zland 648 END DO ; END DO ; END DO ; END DO ; END DO 649 END SELECT 650 END IF 651 CASE ( jpfillperio ) ! use north-south periodicity 652 ishift2 = jpj - 2 * nn_hls 653 DO jf = 1, ipf ; DO jl = 1, ipl ; DO jk = 1, ipk ; DO jj = 1, nn_hls ; DO ji = 1, jpi 654 ARRAY_IN(ji,jj,jk,jl,jf) = ARRAY_IN(ji,ishift2+jj,jk,jl,jf) 655 END DO ; END DO ; END DO ; END DO ; END DO 656 CASE ( jpfillcopy ) ! filling with inner domain values 657 DO jf = 1, ipf ; DO jl = 1, ipl ; DO jk = 1, ipk ; DO jj = 1, nn_hls ; DO ji = 1, jpi 658 ARRAY_IN(ji,jj,jk,jl,jf) = ARRAY_IN(ji,nn_hls+1,jk,jl,jf) 659 END DO ; END DO ; END DO ; END DO ; END DO 660 CASE ( jpfillcst ) ! filling with constant value 661 DO jf = 1, ipf ; DO jl = 1, ipl ; DO jk = 1, ipk ; DO jj = 1, nn_hls ; DO ji = 1, jpi 662 ARRAY_IN(ji,jj,jk,jl,jf) = zland 663 END DO ; END DO ; END DO ; END DO ; END DO 664 END SELECT 665 666 ! ---------------------- 667 ! 2.4 fill northern halo 668 ! ---------------------- 669 ishift = jpj - nn_hls ! fill halo from jj = jpj-nn_hls+1 to jpj 670 SELECT CASE ( ifill_no ) 671 CASE ( jpfillnothing ) ! no filling 672 CASE ( jpfillmpi ) ! use data received by MPI 673 DO jf = 1, ipf ; DO jl = 1, ipl ; DO jk = 1, ipk ; DO jj = 1, nn_hls ; DO ji = nn_hls + 1, jpi - nn_hls 674 ARRAY_IN(ji,ishift+jj,jk,jl,jf) = zrcv(idx) ! jpj-nn_hls+1 -> jpj 675 idx = idx + 1 676 END DO ; END DO ; END DO ; END DO ; END DO 677 IF(nonwr .eq. -1) THEN 678 ishift = jpj - nn_hls 679 SELECT CASE ( ifill_web ) 680 CASE ( jpfillperio ) 681 ishift2 = jpi - 2 * nn_hls 682 DO jf = 1, ipf ; DO jl = 1, ipl ; DO jk = 1, ipk ; DO jj = 1 + ishift, jpj ; DO ji = 1, nn_hls 683 ARRAY_IN(ji,jj,jk,jl,jf) = ARRAY_IN(ishift2+ji,jj,jk,jl,jf) 684 END DO ; END DO ; END DO ; END DO ; END DO 685 CASE ( jpfillcopy ) 686 DO jf = 1, ipf ; DO jl = 1, ipl ; DO jk = 1, ipk ; DO jj = 1 + ishift, jpj ; DO ji = 1, nn_hls 687 ARRAY_IN(ji,jj,jk,jl,jf) = ARRAY_IN(nn_hls+1,jj,jk,jl,jf) 688 END DO ; END DO ; END DO ; END DO ; END DO 689 690 CASE ( jpfillcst ) 691 DO jf = 1, ipf ; DO jl = 1, ipl ; DO jk = 1, ipk ; DO jj = 1 + ishift, jpj ; DO ji = 1, nn_hls 692 ARRAY_IN(ji,jj,jk,jl,jf) = zland 693 END DO ; END DO ; END DO ; END DO ; END DO 694 END SELECT 695 END IF 696 IF(noner .eq. -1) THEN 697 ishift = jpi - nn_hls 698 ishift2 = jpj - nn_hls 699 SELECT CASE ( ifill_eab ) 700 CASE ( jpfillperio ) 701 DO jf = 1, ipf ; DO jl = 1, ipl ; DO jk = 1, ipk ; DO jj = 1 + ishift2, jpj ; DO ji = 1, nn_hls 702 ARRAY_IN(ishift+ji,jj,jk,jl,jf) = ARRAY_IN(ji,jj,jk,jl,jf) 703 END DO ; END DO ; END DO ; END DO ; END DO 704 705 CASE ( jpfillcopy ) 706 DO jf = 1, ipf ; DO jl = 1, ipl ; DO jk = 1, ipk ; DO jj = 1 + ishift2, jpj ; DO ji = 1, nn_hls 707 ARRAY_IN(ishift+ji,jj,jk,jl,jf) = ARRAY_IN(ishift,jj,jk,jl,jf) 708 END DO ; END DO ; END DO ; END DO ; END DO 709 CASE ( jpfillcst ) 710 DO jf = 1, ipf ; DO jl = 1, ipl ; DO jk = 1, ipk ; DO jj = 1 + ishift2, jpj ; DO ji = 1, nn_hls 711 ARRAY_IN(ishift+ji,jj,jk,jl,jf) = zland 712 END DO ; END DO ; END DO ; END DO ; END DO 713 END SELECT 714 END IF 715 CASE ( jpfillperio ) ! use north-south periodicity 716 ishift2 = nn_hls 717 DO jf = 1, ipf ; DO jl = 1, ipl ; DO jk = 1, ipk ; DO jj = 1, nn_hls ; DO ji = 1, jpi 718 ARRAY_IN(ji,ishift+jj,jk,jl,jf) = ARRAY_IN(ji,ishift2+jj,jk,jl,jf) 719 END DO ; END DO ; END DO ; END DO ; END DO 720 CASE ( jpfillcopy ) ! filling with inner domain values 721 DO jf = 1, ipf ; DO jl = 1, ipl ; DO jk = 1, ipk ; DO jj = 1, nn_hls ; DO ji = 1, jpi 722 ARRAY_IN(ji,ishift+jj,jk,jl,jf) = ARRAY_IN(ji,ishift,jk,jl,jf) 723 END DO ; END DO ; END DO ; END DO ; END DO 724 CASE ( jpfillcst ) ! filling with constant value 725 DO jf = 1, ipf ; DO jl = 1, ipl ; DO jk = 1, ipk ; DO jj = 1, nn_hls ; DO ji = 1, jpi 726 ARRAY_IN(ji,ishift+jj,jk,jl,jf) = zland 727 END DO ; END DO ; END DO ; END DO ; END DO 728 END SELECT 729 ENDIF 730 731 IF(llncall) THEN 732 733 !!! Patch to solve MPI3 bug when we have only two processes columns 734 IF(jpni .eq. 2) THEN 735 !!! Patch to solve MPI3 bug when we have only two processes rows 736 IF(jpnj .eq. 2) THEN 737 ! --------------------------- 738 ! 2.5 fill east-nouthern halo 739 ! --------------------------- 740 IF(noner .ne. -1) THEN 741 ishift = jpi - nn_hls 742 ishift2 = jpj - nn_hls 743 DO jf = 1, ipf ; DO jl = 1, ipl ; DO jk = 1, ipk ; DO jj = 1, nn_hls ; DO ji = 1, nn_hls 744 ARRAY_IN(ji+ishift,jj+ishift2,jk,jl,jf) = zrcv(idx) 745 idx = idx + 1 746 END DO ; END DO ; END DO ; END DO ; END DO 747 END IF 748 ! --------------------------- 749 ! 2.6 fill west-nouthern halo 750 ! --------------------------- 751 IF(nonwr .ne. -1) THEN 752 ishift = jpj - nn_hls 753 DO jf = 1, ipf ; DO jl = 1, ipl ; DO jk = 1, ipk ; DO jj = 1, nn_hls ; DO ji = 1, nn_hls 754 ARRAY_IN(ji,jj+ishift,jk,jl,jf) = zrcv(idx) 755 idx = idx + 1 756 END DO ; END DO ; END DO ; END DO ; END DO 757 END IF 758 ! --------------------------- 759 ! 2.7 fill east-southern halo 760 ! --------------------------- 761 IF(noser .ne. -1) THEN 762 ishift = jpi - nn_hls 763 DO jf = 1, ipf ; DO jl = 1, ipl ; DO jk = 1, ipk ; DO jj = 1, nn_hls ; DO ji = 1, nn_hls 764 ARRAY_IN(ji+ishift,jj,jk,jl,jf) = zrcv(idx) 765 idx = idx + 1 766 END DO ; END DO ; END DO ; END DO ; END DO 767 END IF 768 ! --------------------------- 769 ! 2.8 fill west-southern halo 770 ! --------------------------- 771 IF(noswr .ne. -1) THEN 772 DO jf = 1, ipf ; DO jl = 1, ipl ; DO jk = 1, ipk ; DO jj = 1, nn_hls ; DO ji = 1, nn_hls 773 ARRAY_IN(ji,jj,jk,jl,jf) = zrcv(idx) 774 idx = idx + 1 775 END DO ; END DO ; END DO ; END DO ; END DO 776 END IF 777 778 ELSE 779 ! --------------------------- 780 ! 2.5 fill east-southern halo 781 ! --------------------------- 782 IF(noser .ne. -1) THEN 783 ishift = jpi - nn_hls 784 DO jf = 1, ipf ; DO jl = 1, ipl ; DO jk = 1, ipk ; DO jj = 1, nn_hls ; DO ji = 1, nn_hls 785 ARRAY_IN(ji+ishift,jj,jk,jl,jf) = zrcv(idx) 786 idx = idx + 1 787 END DO ; END DO ; END DO ; END DO ; END DO 788 END IF 789 ! --------------------------- 790 ! 2.6 fill west-southern halo 791 ! --------------------------- 792 IF(noswr .ne. -1) THEN 793 DO jf = 1, ipf ; DO jl = 1, ipl ; DO jk = 1, ipk ; DO jj = 1, nn_hls ; DO ji = 1, nn_hls 794 ARRAY_IN(ji,jj,jk,jl,jf) = zrcv(idx) 795 idx = idx + 1 796 END DO ; END DO ; END DO ; END DO ; END DO 797 END IF 798 ! --------------------------- 799 ! 2.7 fill east-nouthern halo 800 ! --------------------------- 801 IF(noner .ne. -1) THEN 802 ishift = jpi - nn_hls 803 ishift2 = jpj - nn_hls 804 DO jf = 1, ipf ; DO jl = 1, ipl ; DO jk = 1, ipk ; DO jj = 1, nn_hls ; DO ji = 1, nn_hls 805 ARRAY_IN(ji+ishift,jj+ishift2,jk,jl,jf) = zrcv(idx) 806 idx = idx + 1 807 END DO ; END DO ; END DO ; END DO ; END DO 808 END IF 809 ! --------------------------- 810 ! 2.8 fill west-nouthern halo 811 ! --------------------------- 812 IF(nonwr .ne. -1) THEN 813 ishift = jpj - nn_hls 814 DO jf = 1, ipf ; DO jl = 1, ipl ; DO jk = 1, ipk ; DO jj = 1, nn_hls ; DO ji = 1, nn_hls 815 ARRAY_IN(ji,jj+ishift,jk,jl,jf) = zrcv(idx) 816 idx = idx + 1 817 END DO ; END DO ; END DO ; END DO ; END DO 818 END IF 819 ENDIF 820 ELSE 821 !!! Patch to solve MPI3 bug when we have only two processes rows 822 IF(jpnj .eq. 2) THEN 823 ! --------------------------- 824 ! 2.5 fill west-nouthern halo 825 ! --------------------------- 826 IF(nonwr .ne. -1) THEN 827 ishift = jpj - nn_hls 828 DO jf = 1, ipf ; DO jl = 1, ipl ; DO jk = 1, ipk ; DO jj = 1, nn_hls ; DO ji = 1, nn_hls 829 ARRAY_IN(ji,jj+ishift,jk,jl,jf) = zrcv(idx) 830 idx = idx + 1 831 END DO ; END DO ; END DO ; END DO ; END DO 832 END IF 833 ! --------------------------- 834 ! 2.6 fill east-nouthern halo 835 ! --------------------------- 836 IF(noner .ne. -1) THEN 837 ishift = jpi - nn_hls 838 ishift2 = jpj - nn_hls 839 DO jf = 1, ipf ; DO jl = 1, ipl ; DO jk = 1, ipk ; DO jj = 1, nn_hls ; DO ji = 1, nn_hls 840 ARRAY_IN(ji+ishift,jj+ishift2,jk,jl,jf) = zrcv(idx) 841 idx = idx + 1 842 END DO ; END DO ; END DO ; END DO ; END DO 843 END IF 844 ! --------------------------- 845 ! 2.7 fill west-southern halo 846 ! --------------------------- 847 IF(noswr .ne. -1) THEN 848 DO jf = 1, ipf ; DO jl = 1, ipl ; DO jk = 1, ipk ; DO jj = 1, nn_hls ; DO ji = 1, nn_hls 849 ARRAY_IN(ji,jj,jk,jl,jf) = zrcv(idx) 850 idx = idx + 1 851 END DO ; END DO ; END DO ; END DO ; END DO 852 END IF 853 ! --------------------------- 854 ! 2.8 fill east-southern halo 855 ! --------------------------- 856 IF(noser .ne. -1) THEN 857 ishift = jpi - nn_hls 858 DO jf = 1, ipf ; DO jl = 1, ipl ; DO jk = 1, ipk ; DO jj = 1, nn_hls ; DO ji = 1, nn_hls 859 ARRAY_IN(ji+ishift,jj,jk,jl,jf) = zrcv(idx) 860 idx = idx + 1 861 END DO ; END DO ; END DO ; END DO ; END DO 862 END IF 863 864 ELSE 865 ! --------------------------- 866 ! 2.5 fill west-southern halo 867 ! --------------------------- 868 IF(noswr .ne. -1) THEN 869 DO jf = 1, ipf ; DO jl = 1, ipl ; DO jk = 1, ipk ; DO jj = 1, nn_hls ; DO ji = 1, nn_hls 870 ARRAY_IN(ji,jj,jk,jl,jf) = zrcv(idx) 871 idx = idx + 1 872 END DO ; END DO ; END DO ; END DO ; END DO 873 END IF 874 ! --------------------------- 875 ! 2.6 fill east-southern halo 876 ! --------------------------- 877 IF(noser .ne. -1) THEN 878 ishift = jpi - nn_hls 879 DO jf = 1, ipf ; DO jl = 1, ipl ; DO jk = 1, ipk ; DO jj = 1, nn_hls ; DO ji = 1, nn_hls 880 ARRAY_IN(ji+ishift,jj,jk,jl,jf) = zrcv(idx) 881 idx = idx + 1 882 END DO ; END DO ; END DO ; END DO ; END DO 883 END IF 884 ! --------------------------- 885 ! 2.7 fill west-nouthern halo 886 ! --------------------------- 887 IF(nonwr .ne. -1) THEN 888 ishift = jpj - nn_hls 889 DO jf = 1, ipf ; DO jl = 1, ipl ; DO jk = 1, ipk ; DO jj = 1, nn_hls ; DO ji = 1, nn_hls 890 ARRAY_IN(ji,jj+ishift,jk,jl,jf) = zrcv(idx) 891 idx = idx + 1 892 END DO ; END DO ; END DO ; END DO ; END DO 893 END IF 894 ! --------------------------- 895 ! 2.8 fill east-nouthern halo 896 ! --------------------------- 897 IF(noner .ne. -1) THEN 898 ishift = jpi - nn_hls 899 ishift2 = jpj - nn_hls 900 DO jf = 1, ipf ; DO jl = 1, ipl ; DO jk = 1, ipk ; DO jj = 1, nn_hls ; DO ji = 1, nn_hls 901 ARRAY_IN(ji+ishift,jj+ishift2,jk,jl,jf) = zrcv(idx) 902 idx = idx + 1 903 END DO ; END DO ; END DO ; END DO ; END DO 904 END IF 905 ENDIF 906 END IF 907 END IF 908 909 910 ! 911 ! -------------------------------------------- ! 912 ! 3. deallocate local temporary arrays ! 913 ! -------------------------------------------- ! 914 ! 915 DEALLOCATE( zsnd ) 916 DEALLOCATE( zrcv ) 917 DEALLOCATE(isizes) 918 DEALLOCATE(isizer) 919 DEALLOCATE(idatatys) 920 DEALLOCATE(idatatyr) 921 DEALLOCATE(idispls) 922 DEALLOCATE(idisplr) 232 END DO 233 234 DEALLOCATE( icounts, icountr, idispls, idisplr, zsnd, zrcv ) 235 236 ! potential "indirect self-periodicity" for the corners 237 DO jn = 5, 8 238 IF( .NOT. l_SelfPerio(jn) .AND. l_SelfPerio(jpwe) ) THEN ! no bi-perio but ew-perio: corners indirect definition 239 ishti = ishtri(jn) 240 ishtj = ishtrj(jn) 241 ishti2 = ishtpi(jn) ! use i- shift periodicity 242 ishtj2 = ishtrj(jn) ! use j- shift recv location: use ew-perio -> ok as filling of the south and north halos now done 243 DO jf = 1, ipf ; DO jl = 1, ipl ; DO jk = 1, ipk ; DO jj = 1,isizej(jn) ; DO ji = 1,isizei(jn) 244 ARRAY_IN(ishti+ji,ishtj+jj,jk,jl,jf) = ARRAY_IN(ishti2+ji,ishtj2+jj,jk,jl,jf) 245 END DO ; END DO ; END DO ; END DO ; END DO 246 ENDIF 247 IF( .NOT. l_SelfPerio(jn) .AND. l_SelfPerio(jpso) ) THEN ! no bi-perio but ns-perio: corners indirect definition 248 ishti = ishtri(jn) 249 ishtj = ishtrj(jn) 250 ishti2 = ishtri(jn) ! use i- shift recv location: use ns-perio -> ok as filling of the west and east halos now done 251 ishtj2 = ishtpj(jn) ! use j- shift periodicity 252 DO jf = 1, ipf ; DO jl = 1, ipl ; DO jk = 1, ipk ; DO jj = 1,isizej(jn) ; DO ji = 1,isizei(jn) 253 ARRAY_IN(ishti+ji,ishtj+jj,jk,jl,jf) = ARRAY_IN(ishti2+ji,ishtj2+jj,jk,jl,jf) 254 END DO ; END DO ; END DO ; END DO ; END DO 255 ENDIF 256 END DO 923 257 ! 924 258 ! ------------------------------- ! 925 ! 4. north fold treatment !259 ! 5. north fold treatment ! 926 260 ! ------------------------------- ! 927 261 ! 928 IF( lldo_nfd .AND. ifill_no /= jpfillnothing ) THEN 929 ! 930 SELECT CASE ( jpni ) 931 CASE ( 1 ) ; CALL lbc_nfd( ptab, NAT_IN(:), SGN_IN(:) OPT_K(:) ) ! only 1 northern proc, no mpp 932 CASE DEFAULT ; CALL mpp_nfd( ptab, NAT_IN(:), SGN_IN(:), ifill_no, zland OPT_K(:) ) ! for all northern procs. 933 END SELECT 934 ! 935 ifill_no = jpfillnothing ! force to do nothing for the northern halo as we just done the north pole folding 936 ! 262 IF( ll_IdoNFold ) THEN 263 IF( jpni == 1 ) THEN ; CALL lbc_nfd( ptab, NAT_IN(:), SGN_IN(:) OPT_K(:) ) ! self NFold 264 ELSE ; CALL mpp_nfd( ptab, NAT_IN(:), SGN_IN(:), ifill(jpno), zland OPT_K(:) ) ! mpi NFold 265 ENDIF 937 266 ENDIF 938 267 -
NEMO/branches/2021/dev_r14312_MPI_Interface/src/OCE/LBC/mpp_nfd_generic.h90
r14229 r14314 80 80 ARRAY_TYPE(:,:,:,:,:) ! array or pointer of arrays on which the boundary condition is applied 81 81 CHARACTER(len=1) , INTENT(in ) :: NAT_IN(:) ! nature of array grid-points 82 REAL( wp), INTENT(in ) :: SGN_IN(:) ! sign used across the north fold boundary82 REAL(PRECISION) , INTENT(in ) :: SGN_IN(:) ! sign used across the north fold boundary 83 83 INTEGER , INTENT(in ) :: kfillmode ! filling method for halo over land 84 REAL( wp), INTENT(in ) :: pfillval ! background value (used at closed boundaries)84 REAL(PRECISION) , INTENT(in ) :: pfillval ! background value (used at closed boundaries) 85 85 INTEGER, OPTIONAL, INTENT(in ) :: kfld ! number of pt3d arrays 86 86 ! … … 111 111 ipf = F_SIZE(ptab) ! 5th - use in "multi" case (array of pointers) 112 112 ! 113 IF( l _north_nogather ) THEN !== no allgather exchanges ==!113 IF( ln_nnogather ) THEN !== no allgather exchanges ==! 114 114 115 115 ! --- define number of exchanged lines --- … … 141 141 IF( ll_add_line ) THEN 142 142 DO jf = 1, ipf ! Loop over the number of arrays to be processed 143 ipj_s(jf) = nn_hls + COUNT( (/ npolj == 3 .OR. npolj == 4.OR. NAT_IN(jf) == 'V' .OR. NAT_IN(jf) == 'F' /) )143 ipj_s(jf) = nn_hls + COUNT( (/ l_NFoldT .OR. NAT_IN(jf) == 'V' .OR. NAT_IN(jf) == 'F' /) ) 144 144 END DO 145 145 ELSE … … 155 155 DO jf = 1, ipf ! Loop over the number of arrays to be processed 156 156 ! 157 SELECT CASE ( npolj ) 158 CASE ( 3, 4 ) ! * North fold T-point pivot 157 IF( l_NFoldT ) THEN ! * North fold T-point pivot 159 158 SELECT CASE ( NAT_IN(jf) ) 160 159 CASE ( 'T', 'W', 'U' ) ; i012 = 1 ! T-, U-, W-point 161 160 CASE ( 'V', 'F' ) ; i012 = 2 ! V-, F-point 162 161 END SELECT 163 CASE ( 5, 6 ) ! * North fold F-point pivot 162 ENDIF 163 IF( l_NFoldF ) THEN ! * North fold F-point pivot 164 164 SELECT CASE ( NAT_IN(jf) ) 165 165 CASE ( 'T', 'W', 'U' ) ; i012 = 0 ! T-, U-, W-point 166 166 CASE ( 'V', 'F' ) ; i012 = 1 ! V-, F-point 167 167 END SELECT 168 END SELECT168 ENDIF 169 169 ! 170 170 DO jj = 1, ipj_s(jf) -
NEMO/branches/2021/dev_r14312_MPI_Interface/src/OCE/LBC/mppini.F90
r14275 r14314 69 69 jpi = jpiglo 70 70 jpj = jpjglo 71 jpk = jpkglo 72 jpim1 = jpi-1 ! inner domain indices 73 jpjm1 = jpj-1 ! " " 74 jpkm1 = MAX( 1, jpk-1 ) ! " " 71 jpk = MAX( 2, jpkglo ) 75 72 jpij = jpi*jpj 76 73 jpni = 1 … … 79 76 nimpp = 1 80 77 njmpp = 1 81 nbondi = 282 nbondj = 283 78 nidom = FLIO_DOM_NONE 84 npolj = 085 IF( jperio == 3 .OR. jperio == 4 ) npolj = 386 IF( jperio == 5 .OR. jperio == 6 ) npolj = 587 l_Iperio = jpni == 1 .AND. (jperio == 1 .OR. jperio == 4 .OR. jperio == 6 .OR. jperio == 7)88 l_Jperio = jpnj == 1 .AND. (jperio == 2 .OR. jperio == 7)89 79 ! 90 80 CALL init_doloop ! set start/end indices or do-loop depending on the halo width value (nn_hls) … … 95 85 WRITE(numout,*) '~~~~~~~~ ' 96 86 WRITE(numout,*) ' l_Iperio = ', l_Iperio, ' l_Jperio = ', l_Jperio 97 WRITE(numout,*) ' n polj = ', npolj , ' njmpp = ', njmpp87 WRITE(numout,*) ' njmpp = ', njmpp 98 88 ENDIF 99 89 ! … … 131 121 !! njmpp : latitudinal index 132 122 !! narea : number for local area 133 !! nbondi : mark for "east-west local boundary" 134 !! nbondj : mark for "north-south local boundary" 135 !! noea : number for local neighboring processor 136 !! nowe : number for local neighboring processor 137 !! noso : number for local neighboring processor 138 !! nono : number for local neighboring processor 139 !!---------------------------------------------------------------------- 140 INTEGER :: ji, jj, jn, jproc, jarea ! dummy loop indices 141 INTEGER :: inijmin 142 INTEGER :: inum ! local logical unit 143 INTEGER :: idir, ifreq ! local integers 144 INTEGER :: ii, il1, ili, imil ! - - 145 INTEGER :: ij, il2, ilj, ijm1 ! - - 146 INTEGER :: iino, ijno, iiso, ijso ! - - 147 INTEGER :: iiea, ijea, iiwe, ijwe ! - - 148 INTEGER :: iarea0 ! - - 149 INTEGER :: ierr, ios ! 150 INTEGER :: inbi, inbj, iimax, ijmax, icnt1, icnt2 123 !! mpinei : number of neighboring domains (starting at 0, -1 if no neighbourg) 124 !!---------------------------------------------------------------------- 125 INTEGER :: ji, jj, jn, jp 126 INTEGER :: ii, ij, ii2, ij2 127 INTEGER :: inijmin ! number of oce subdomains 128 INTEGER :: inum, inum0 129 INTEGER :: ifreq, il1, imil, il2, ijm1 130 INTEGER :: ierr, ios 131 INTEGER :: inbi, inbj, iimax, ijmax, icnt1, icnt2 132 INTEGER, ALLOCATABLE, DIMENSION(: ) :: iin, ijn 133 INTEGER, ALLOCATABLE, DIMENSION(:,: ) :: iimppt, ijpi, ipproc 134 INTEGER, ALLOCATABLE, DIMENSION(:,: ) :: ijmppt, ijpj 135 INTEGER, ALLOCATABLE, DIMENSION(:,: ) :: impi 136 INTEGER, ALLOCATABLE, DIMENSION(:,:,:) :: inei 151 137 LOGICAL :: llbest, llauto 152 138 LOGICAL :: llwrtlay 139 LOGICAL :: llmpi_Iperio, llmpi_Jperio, llmpiNfold 153 140 LOGICAL :: ln_listonly 154 INTEGER, ALLOCATABLE, DIMENSION(:) :: iin, ii_nono, ii_noea ! 1D workspace 155 INTEGER, ALLOCATABLE, DIMENSION(:) :: ijn, ii_noso, ii_nowe ! - - 156 INTEGER, ALLOCATABLE, DIMENSION(:,:) :: iimppt, ijpi, ibondi, ipproc ! 2D workspace 157 INTEGER, ALLOCATABLE, DIMENSION(:,:) :: ijmppt, ijpj, ibondj, ipolj ! - - 158 INTEGER, ALLOCATABLE, DIMENSION(:,:) :: iie0, iis0, iono, ioea ! - - 159 INTEGER, ALLOCATABLE, DIMENSION(:,:) :: ije0, ijs0, ioso, iowe ! - - 160 LOGICAL, ALLOCATABLE, DIMENSION(:,:) :: llisoce ! - - 141 LOGICAL, ALLOCATABLE, DIMENSION(:,: ) :: llisOce ! is not land-domain only? 142 LOGICAL, ALLOCATABLE, DIMENSION(:,:,:) :: llnei ! are neighbourgs existing? 161 143 NAMELIST/nambdy/ ln_bdy, nb_bdy, ln_coords_file, cn_coords_file, & 162 144 & ln_mask_file, cn_mask_file, cn_dyn2d, nn_dyn2d_dta, & … … 193 175 IF(lwm) WRITE( numond, nammpp ) 194 176 ! 195 !!!------------------------------------196 !!! nn_hls shloud be read in nammpp197 !!!------------------------------------198 177 jpiglo = Ni0glo + 2 * nn_hls 199 178 jpjglo = Nj0glo + 2 * nn_hls … … 213 192 ! ----------------------------------- 214 193 ! 215 ! If dimensions of processors grid weren't specified in the namelist file194 ! If dimensions of MPI processes grid weren't specified in the namelist file 216 195 ! then we calculate them here now that we have our communicator size 217 196 IF(lwp) THEN … … 260 239 261 240 ! look for land mpi subdomains... 262 ALLOCATE( llis oce(jpni,jpnj) )263 CALL mpp_is_ocean( llis oce )264 inijmin = COUNT( llis oce ) ! number of oce subdomains241 ALLOCATE( llisOce(jpni,jpnj) ) 242 CALL mpp_is_ocean( llisOce ) 243 inijmin = COUNT( llisOce ) ! number of oce subdomains 265 244 266 245 IF( mppsize < inijmin ) THEN ! too many oce subdomains: can happen only if jpni and jpnj are prescribed... … … 319 298 9003 FORMAT (a, i5) 320 299 321 ALLOCATE( nfimpp(jpni ) , nfproc(jpni ) , nfjpi(jpni ) , & 322 & nimppt(jpnij) , ibonit(jpnij) , jpiall(jpnij) , jpjall(jpnij) , & 323 & njmppt(jpnij) , ibonjt(jpnij) , nis0all(jpnij) , njs0all(jpnij) , & 324 & nie0all(jpnij) , nje0all(jpnij) , & 325 & iin(jpnij), ii_nono(jpnij), ii_noea(jpnij), & 326 & ijn(jpnij), ii_noso(jpnij), ii_nowe(jpnij), & 327 & iimppt(jpni,jpnj), ijpi(jpni,jpnj), ibondi(jpni,jpnj), ipproc(jpni,jpnj), & 328 & ijmppt(jpni,jpnj), ijpj(jpni,jpnj), ibondj(jpni,jpnj), ipolj(jpni,jpnj), & 329 & iie0(jpni,jpnj), iis0(jpni,jpnj), iono(jpni,jpnj), ioea(jpni,jpnj), & 330 & ije0(jpni,jpnj), ijs0(jpni,jpnj), ioso(jpni,jpnj), iowe(jpni,jpnj), & 331 & STAT=ierr ) 300 ALLOCATE( nfimpp(jpni), nfproc(jpni), nfjpi(jpni), & 301 & iin(jpnij), ijn(jpnij), & 302 & iimppt(jpni,jpnj), ijmppt(jpni,jpnj), ijpi(jpni,jpnj), ijpj(jpni,jpnj), ipproc(jpni,jpnj), & 303 & inei(8,jpni,jpnj), llnei(8,jpni,jpnj), & 304 & impi(8,jpnij), & 305 & STAT=ierr ) 332 306 CALL mpp_sum( 'mppini', ierr ) 333 307 IF( ierr /= 0 ) CALL ctl_stop( 'STOP', 'mpp_init: unable to allocate standard ocean arrays' ) … … 343 317 ! 344 318 CALL mpp_basesplit( jpiglo, jpjglo, nn_hls, jpni, jpnj, jpimax, jpjmax, iimppt, ijmppt, ijpi, ijpj ) 345 CALL mpp_getnum( llisoce, ipproc, iin, ijn ) 346 ! 347 !DO jn = 1, jpni 348 ! jproc = ipproc(jn,jpnj) 349 ! ii = iin(jproc+1) 350 ! ij = ijn(jproc+1) 351 ! nfproc(jn) = jproc 352 ! nfimpp(jn) = iimppt(ii,ij) 353 ! nfjpi (jn) = ijpi(ii,ij) 354 !END DO 355 nfproc(:) = ipproc(:,jpnj) 356 nfimpp(:) = iimppt(:,jpnj) 357 nfjpi (:) = ijpi(:,jpnj) 319 CALL mpp_getnum( llisOce, ipproc, iin, ijn ) 320 ! 321 ii = iin(narea) 322 ij = ijn(narea) 323 jpi = ijpi(ii,ij) 324 jpj = ijpj(ii,ij) 325 jpk = MAX( 2, jpkglo ) 326 jpij = jpi*jpj 327 nimpp = iimppt(ii,ij) 328 njmpp = ijmppt(ii,ij) 329 ! 330 CALL init_doloop ! set start/end indices of do-loop, depending on the halo width value (nn_hls) 358 331 ! 359 332 IF(lwp) THEN … … 365 338 WRITE(numout,*) ' jpnj = ', jpnj 366 339 WRITE(numout,*) ' jpnij = ', jpnij 340 WRITE(numout,*) ' nimpp = ', nimpp 341 WRITE(numout,*) ' njmpp = ', njmpp 367 342 WRITE(numout,*) 368 343 WRITE(numout,*) ' sum ijpi(i,1) = ', sum(ijpi(:,1)), ' jpiglo = ', jpiglo 369 WRITE(numout,*) ' sum ijpj(1,j) = ', sum(ijpj(1,:)), ' jpjglo = ', jpjglo 370 ENDIF 371 372 ! 3. Subdomain description in the Regular Case 373 ! -------------------------------------------- 374 ! specific cases where there is no communication -> must do the periodicity by itself 375 ! Warning: because of potential land-area suppression, do not use nbond[ij] == 2 376 l_Iperio = jpni == 1 .AND. (jperio == 1 .OR. jperio == 4 .OR. jperio == 6 .OR. jperio == 7) 377 l_Jperio = jpnj == 1 .AND. (jperio == 2 .OR. jperio == 7) 378 379 DO jarea = 1, jpni*jpnj 380 ! 381 iarea0 = jarea - 1 382 ii = 1 + MOD(iarea0,jpni) 383 ij = 1 + iarea0/jpni 384 ili = ijpi(ii,ij) 385 ilj = ijpj(ii,ij) 386 ibondi(ii,ij) = 0 ! default: has e-w neighbours 387 IF( ii == 1 ) ibondi(ii,ij) = -1 ! first column, has only e neighbour 388 IF( ii == jpni ) ibondi(ii,ij) = 1 ! last column, has only w neighbour 389 IF( jpni == 1 ) ibondi(ii,ij) = 2 ! has no e-w neighbour 390 ibondj(ii,ij) = 0 ! default: has n-s neighbours 391 IF( ij == 1 ) ibondj(ii,ij) = -1 ! first row, has only n neighbour 392 IF( ij == jpnj ) ibondj(ii,ij) = 1 ! last row, has only s neighbour 393 IF( jpnj == 1 ) ibondj(ii,ij) = 2 ! has no n-s neighbour 394 395 ! Subdomain neighbors (get their zone number): default definition 396 ioso(ii,ij) = iarea0 - jpni 397 iowe(ii,ij) = iarea0 - 1 398 ioea(ii,ij) = iarea0 + 1 399 iono(ii,ij) = iarea0 + jpni 400 iis0(ii,ij) = 1 + nn_hls 401 iie0(ii,ij) = ili - nn_hls 402 ijs0(ii,ij) = 1 + nn_hls 403 ije0(ii,ij) = ilj - nn_hls 404 405 ! East-West periodicity: change ibondi, ioea, iowe 406 IF( jperio == 1 .OR. jperio == 4 .OR. jperio == 6 .OR. jperio == 7 ) THEN 407 IF( jpni /= 1 ) ibondi(ii,ij) = 0 ! redefine: all have e-w neighbours 408 IF( ii == 1 ) iowe(ii,ij) = iarea0 + (jpni-1) ! redefine: first column, address of w neighbour 409 IF( ii == jpni ) ioea(ii,ij) = iarea0 - (jpni-1) ! redefine: last column, address of e neighbour 410 ENDIF 411 412 ! Simple North-South periodicity: change ibondj, ioso, iono 413 IF( jperio == 2 .OR. jperio == 7 ) THEN 414 IF( jpnj /= 1 ) ibondj(ii,ij) = 0 ! redefine: all have n-s neighbours 415 IF( ij == 1 ) ioso(ii,ij) = iarea0 + jpni * (jpnj-1) ! redefine: first row, address of s neighbour 416 IF( ij == jpnj ) iono(ii,ij) = iarea0 - jpni * (jpnj-1) ! redefine: last row, address of n neighbour 417 ENDIF 418 419 ! North fold: define ipolj, change iono. Warning: we do not change ibondj... 420 ipolj(ii,ij) = 0 421 IF( jperio == 3 .OR. jperio == 4 ) THEN 422 ijm1 = jpni*(jpnj-1) 423 imil = ijm1+(jpni+1)/2 424 IF( jarea > ijm1 ) ipolj(ii,ij) = 3 425 IF( MOD(jpni,2) == 1 .AND. jarea == imil ) ipolj(ii,ij) = 4 426 IF( ipolj(ii,ij) == 3 ) iono(ii,ij) = jpni*jpnj-jarea+ijm1 ! MPI rank of northern neighbour 427 ENDIF 428 IF( jperio == 5 .OR. jperio == 6 ) THEN 429 ijm1 = jpni*(jpnj-1) 430 imil = ijm1+(jpni+1)/2 431 IF( jarea > ijm1) ipolj(ii,ij) = 5 432 IF( MOD(jpni,2) == 1 .AND. jarea == imil ) ipolj(ii,ij) = 6 433 IF( ipolj(ii,ij) == 5) iono(ii,ij) = jpni*jpnj-jarea+ijm1 ! MPI rank of northern neighbour 434 ENDIF 435 ! 436 END DO 437 438 ! 4. deal with land subdomains 439 ! ---------------------------- 440 ! 441 ! neighbour treatment: change ibondi, ibondj if next to a land zone 442 DO jarea = 1, jpni*jpnj 443 ii = 1 + MOD( jarea-1 , jpni ) 444 ij = 1 + (jarea-1) / jpni 445 ! land-only area with an active n neigbour 446 IF ( ipproc(ii,ij) == -1 .AND. 0 <= iono(ii,ij) .AND. iono(ii,ij) <= jpni*jpnj-1 ) THEN 447 iino = 1 + MOD( iono(ii,ij) , jpni ) ! ii index of this n neigbour 448 ijno = 1 + iono(ii,ij) / jpni ! ij index of this n neigbour 449 ! In case of north fold exchange: I am the n neigbour of my n neigbour!! (#1057) 450 ! --> for northern neighbours of northern row processors (in case of north-fold) 451 ! need to reverse the LOGICAL direction of communication 452 idir = 1 ! we are indeed the s neigbour of this n neigbour 453 IF( ij == jpnj .AND. ijno == jpnj ) idir = -1 ! both are on the last row, we are in fact the n neigbour 454 IF( ibondj(iino,ijno) == idir ) ibondj(iino,ijno) = 2 ! this n neigbour had only a s/n neigbour -> no more 455 IF( ibondj(iino,ijno) == 0 ) ibondj(iino,ijno) = -idir ! this n neigbour had both, n-s neighbours -> keep 1 456 ENDIF 457 ! land-only area with an active s neigbour 458 IF( ipproc(ii,ij) == -1 .AND. 0 <= ioso(ii,ij) .AND. ioso(ii,ij) <= jpni*jpnj-1 ) THEN 459 iiso = 1 + MOD( ioso(ii,ij) , jpni ) ! ii index of this s neigbour 460 ijso = 1 + ioso(ii,ij) / jpni ! ij index of this s neigbour 461 IF( ibondj(iiso,ijso) == -1 ) ibondj(iiso,ijso) = 2 ! this s neigbour had only a n neigbour -> no more neigbour 462 IF( ibondj(iiso,ijso) == 0 ) ibondj(iiso,ijso) = 1 ! this s neigbour had both, n-s neighbours -> keep s neigbour 463 ENDIF 464 ! land-only area with an active e neigbour 465 IF( ipproc(ii,ij) == -1 .AND. 0 <= ioea(ii,ij) .AND. ioea(ii,ij) <= jpni*jpnj-1 ) THEN 466 iiea = 1 + MOD( ioea(ii,ij) , jpni ) ! ii index of this e neigbour 467 ijea = 1 + ioea(ii,ij) / jpni ! ij index of this e neigbour 468 IF( ibondi(iiea,ijea) == 1 ) ibondi(iiea,ijea) = 2 ! this e neigbour had only a w neigbour -> no more neigbour 469 IF( ibondi(iiea,ijea) == 0 ) ibondi(iiea,ijea) = -1 ! this e neigbour had both, e-w neighbours -> keep e neigbour 470 ENDIF 471 ! land-only area with an active w neigbour 472 IF( ipproc(ii,ij) == -1 .AND. 0 <= iowe(ii,ij) .AND. iowe(ii,ij) <= jpni*jpnj-1) THEN 473 iiwe = 1 + MOD( iowe(ii,ij) , jpni ) ! ii index of this w neigbour 474 ijwe = 1 + iowe(ii,ij) / jpni ! ij index of this w neigbour 475 IF( ibondi(iiwe,ijwe) == -1 ) ibondi(iiwe,ijwe) = 2 ! this w neigbour had only a e neigbour -> no more neigbour 476 IF( ibondi(iiwe,ijwe) == 0 ) ibondi(iiwe,ijwe) = 1 ! this w neigbour had both, e-w neighbours -> keep w neigbour 477 ENDIF 478 END DO 479 480 ! 5. Subdomain print 481 ! ------------------ 482 IF(lwp) THEN 344 WRITE(numout,*) ' sum ijpj(1,j) = ', SUM(ijpj(1,:)), ' jpjglo = ', jpjglo 345 346 ! Subdomain grid print 483 347 ifreq = 4 484 348 il1 = 1 … … 503 367 9404 FORMAT(' * ' ,20(' ' ,i4,' * ') ) 504 368 ENDIF 505 506 ! just to save nono etc for all proc 507 ! warning ii*ij (zone) /= mpprank (processors)! 508 ! ioso = zone number, ii_noso = proc number 509 ii_noso(:) = -1 510 ii_nono(:) = -1 511 ii_noea(:) = -1 512 ii_nowe(:) = -1 513 DO jproc = 1, jpnij 514 ii = iin(jproc) 515 ij = ijn(jproc) 516 IF( 0 <= ioso(ii,ij) .AND. ioso(ii,ij) <= (jpni*jpnj-1) ) THEN 517 iiso = 1 + MOD( ioso(ii,ij) , jpni ) 518 ijso = 1 + ioso(ii,ij) / jpni 519 ii_noso(jproc) = ipproc(iiso,ijso) 520 ENDIF 521 IF( 0 <= iowe(ii,ij) .AND. iowe(ii,ij) <= (jpni*jpnj-1) ) THEN 522 iiwe = 1 + MOD( iowe(ii,ij) , jpni ) 523 ijwe = 1 + iowe(ii,ij) / jpni 524 ii_nowe(jproc) = ipproc(iiwe,ijwe) 525 ENDIF 526 IF( 0 <= ioea(ii,ij) .AND. ioea(ii,ij) <= (jpni*jpnj-1) ) THEN 527 iiea = 1 + MOD( ioea(ii,ij) , jpni ) 528 ijea = 1 + ioea(ii,ij) / jpni 529 ii_noea(jproc)= ipproc(iiea,ijea) 530 ENDIF 531 IF( 0 <= iono(ii,ij) .AND. iono(ii,ij) <= (jpni*jpnj-1) ) THEN 532 iino = 1 + MOD( iono(ii,ij) , jpni ) 533 ijno = 1 + iono(ii,ij) / jpni 534 ii_nono(jproc)= ipproc(iino,ijno) 535 ENDIF 369 ! 370 ! Store informations for the north pole folding communications 371 nfproc(:) = ipproc(:,jpnj) 372 nfimpp(:) = iimppt(:,jpnj) 373 nfjpi (:) = ijpi(:,jpnj) 374 ! 375 ! 3. Define Western, Eastern, Southern and Northern neighbors + corners in the subdomain grid reference 376 ! ------------------------------------------------------------------------------------------------------ 377 ! 378 ! note that North fold is has specific treatment for its MPI communications. 379 ! This must not be treated as a "usual" communication with a northern neighbor. 380 ! -> North fold processes have no Northern neighbor in the definition done bellow 381 ! 382 llmpi_Iperio = jpni > 1 .AND. l_Iperio ! do i-periodicity with an MPI communication? 383 llmpi_Jperio = jpnj > 1 .AND. l_Jperio ! do j-periodicity with an MPI communication? 384 ! 385 l_SelfPerio(1:2) = l_Iperio .AND. jpni == 1 ! west, east periodicity by itself 386 l_SelfPerio(3:4) = l_Jperio .AND. jpnj == 1 ! south, north periodicity by itself 387 l_SelfPerio(5:8) = l_SelfPerio(jpwe) .AND. l_SelfPerio(jpso) ! corners bi-periodicity by itself 388 ! 389 ! define neighbors mapping (1/2): default definition: ignore if neighbours are land-only subdomains or not 390 DO jj = 1, jpnj 391 DO ji = 1, jpni 392 ! 393 IF ( llisOce(ji,jj) ) THEN ! this subdomain has some ocean: it has neighbours 394 ! 395 inum0 = ji - 1 + ( jj - 1 ) * jpni ! index in the subdomains grid. start at 0 396 ! 397 ! Is there a neighbor? 398 llnei(jpwe,ji,jj) = ji > 1 .OR. llmpi_Iperio ! West nei exists if not the first column or llmpi_Iperio 399 llnei(jpea,ji,jj) = ji < jpni .OR. llmpi_Iperio ! East nei exists if not the last column or llmpi_Iperio 400 llnei(jpso,ji,jj) = jj > 1 .OR. llmpi_Jperio ! South nei exists if not the first line or llmpi_Jperio 401 llnei(jpno,ji,jj) = jj < jpnj .OR. llmpi_Jperio ! North nei exists if not the last line or llmpi_Jperio 402 llnei(jpsw,ji,jj) = llnei(jpwe,ji,jj) .AND. llnei(jpso,ji,jj) ! So-We nei exists if both South and West nei exist 403 llnei(jpse,ji,jj) = llnei(jpea,ji,jj) .AND. llnei(jpso,ji,jj) ! So-Ea nei exists if both South and East nei exist 404 llnei(jpnw,ji,jj) = llnei(jpwe,ji,jj) .AND. llnei(jpno,ji,jj) ! No-We nei exists if both North and West nei exist 405 llnei(jpne,ji,jj) = llnei(jpea,ji,jj) .AND. llnei(jpno,ji,jj) ! No-Ea nei exists if both North and East nei exist 406 ! 407 ! Which index (starting at 0) have neighbors in the subdomains grid? 408 IF( llnei(jpwe,ji,jj) ) inei(jpwe,ji,jj) = inum0 - 1 + jpni * COUNT( (/ ji == 1 /) ) 409 IF( llnei(jpea,ji,jj) ) inei(jpea,ji,jj) = inum0 + 1 - jpni * COUNT( (/ ji == jpni /) ) 410 IF( llnei(jpso,ji,jj) ) inei(jpso,ji,jj) = inum0 - jpni + jpni * jpnj * COUNT( (/ jj == 1 /) ) 411 IF( llnei(jpno,ji,jj) ) inei(jpno,ji,jj) = inum0 + jpni - jpni * jpnj * COUNT( (/ jj == jpnj /) ) 412 IF( llnei(jpsw,ji,jj) ) inei(jpsw,ji,jj) = inei(jpso,ji,jj) - 1 + jpni * COUNT( (/ ji == 1 /) ) 413 IF( llnei(jpse,ji,jj) ) inei(jpse,ji,jj) = inei(jpso,ji,jj) + 1 - jpni * COUNT( (/ ji == jpni /) ) 414 IF( llnei(jpnw,ji,jj) ) inei(jpnw,ji,jj) = inei(jpno,ji,jj) - 1 + jpni * COUNT( (/ ji == 1 /) ) 415 IF( llnei(jpne,ji,jj) ) inei(jpne,ji,jj) = inei(jpno,ji,jj) + 1 - jpni * COUNT( (/ ji == jpni /) ) 416 ! 417 ELSE ! land-only domain has no neighbour 418 llnei(:,ji,jj) = .FALSE. 419 ENDIF 420 ! 421 END DO 536 422 END DO 537 538 ! 6. Change processor name 539 ! ------------------------ 540 ii = iin(narea) 541 ij = ijn(narea) 542 ! 543 jpi = ijpi(ii,ij) 544 !!$ Nis0 = iis0(ii,ij) 545 !!$ Nie0 = iie0(ii,ij) 546 jpj = ijpj(ii,ij) 547 !!$ Njs0 = ijs0(ii,ij) 548 !!$ Nje0 = ije0(ii,ij) 549 nbondi = ibondi(ii,ij) 550 nbondj = ibondj(ii,ij) 551 nimpp = iimppt(ii,ij) 552 njmpp = ijmppt(ii,ij) 553 jpk = jpkglo ! third dim 554 555 ! set default neighbours 556 noso = ii_noso(narea) 557 nowe = ii_nowe(narea) 558 noea = ii_noea(narea) 559 nono = ii_nono(narea) 560 561 nones = -1 562 nonws = -1 563 noses = -1 564 nosws = -1 565 566 noner = -1 567 nonwr = -1 568 noser = -1 569 noswr = -1 570 571 IF((nbondi .eq. -1) .or. (nbondi .eq. 0)) THEN ! east neighbour exists 572 IF(ibondj(iin(noea+1),ijn(noea+1)) .eq. 0) THEN 573 nones = ii_nono(noea+1) ! east neighbour has north and south neighbours 574 noses = ii_noso(noea+1) 575 ELSEIF(ibondj(iin(noea+1),ijn(noea+1)) .eq. -1) THEN 576 nones = ii_nono(noea+1) ! east neighbour has north neighbour 577 ELSEIF(ibondj(iin(noea+1),ijn(noea+1)) .eq. 1) THEN 578 noses = ii_noso(noea+1) ! east neighbour has south neighbour 579 END IF 580 END IF 581 IF((nbondi .eq. 1) .or. (nbondi .eq. 0)) THEN ! west neighbour exists 582 IF(ibondj(iin(nowe+1),ijn(nowe+1)) .eq. 0) THEN 583 nonws = ii_nono(nowe+1) ! west neighbour has north and south neighbours 584 nosws = ii_noso(nowe+1) 585 ELSEIF(ibondj(iin(nowe+1),ijn(nowe+1)) .eq. -1) THEN 586 nonws = ii_nono(nowe+1) ! west neighbour has north neighbour 587 ELSEIF(ibondj(iin(nowe+1),ijn(nowe+1)) .eq. 1) THEN 588 nosws = ii_noso(nowe+1) ! west neighbour has north neighbour 589 END IF 590 END IF 591 592 IF((nbondj .eq. -1) .or. (nbondj .eq. 0)) THEN ! north neighbour exists 593 IF(ibondi(iin(nono+1),ijn(nono+1)) .eq. 0) THEN 594 noner = ii_noea(nono+1) ! north neighbour has east and west neighbours 595 nonwr = ii_nowe(nono+1) 596 ELSEIF(ibondi(iin(nono+1),ijn(nono+1)) .eq. -1) THEN 597 noner = ii_noea(nono+1) ! north neighbour has east neighbour 598 ELSEIF(ibondi(iin(nono+1),ijn(nono+1)) .eq. 1) THEN 599 nonwr = ii_nowe(nono+1) ! north neighbour has west neighbour 600 END IF 601 END IF 602 IF((nbondj .eq. 1) .or. (nbondj .eq. 0)) THEN ! south neighbour exists 603 IF(ibondi(iin(noso+1),ijn(noso+1)) .eq. 0) THEN 604 noser = ii_noea(noso+1) ! south neighbour has east and west neighbours 605 noswr = ii_nowe(noso+1) 606 ELSEIF(ibondi(iin(noso+1),ijn(noso+1)) .eq. -1) THEN 607 noser = ii_noea(noso+1) ! south neighbour has east neighbour 608 ELSEIF(ibondi(iin(noso+1),ijn(noso+1)) .eq. 1) THEN 609 noswr = ii_nowe(noso+1) ! south neighbour has west neighbour 610 END IF 611 END IF 612 613 ! 614 CALL init_doloop ! set start/end indices of do-loop, depending on the halo width value (nn_hls) 615 ! 616 jpim1 = jpi-1 ! inner domain indices 617 jpjm1 = jpj-1 ! " " 618 jpkm1 = MAX( 1, jpk-1 ) ! " " 619 jpij = jpi*jpj ! jpi x j 620 DO jproc = 1, jpnij 621 ii = iin(jproc) 622 ij = ijn(jproc) 623 jpiall (jproc) = ijpi(ii,ij) 624 nis0all(jproc) = iis0(ii,ij) 625 nie0all(jproc) = iie0(ii,ij) 626 jpjall (jproc) = ijpj(ii,ij) 627 njs0all(jproc) = ijs0(ii,ij) 628 nje0all(jproc) = ije0(ii,ij) 629 ibonit(jproc) = ibondi(ii,ij) 630 ibonjt(jproc) = ibondj(ii,ij) 631 nimppt(jproc) = iimppt(ii,ij) 632 njmppt(jproc) = ijmppt(ii,ij) 423 ! 424 ! define neighbors mapping (2/2): check if neighbours are not land-only subdomains 425 DO jj = 1, jpnj 426 DO ji = 1, jpni 427 DO jn = 1, 8 428 IF( llnei(jn,ji,jj) ) THEN ! if a neighbour is existing -> this should not be a land-only domain 429 ii = 1 + MOD( inei(jn,ji,jj) , jpni ) 430 ij = 1 + inei(jn,ji,jj) / jpni 431 llnei(jn,ji,jj) = llisOce( ii, ij ) 432 ENDIF 433 END DO 434 END DO 633 435 END DO 634 436 ! 437 ! update index of the neighbours in the subdomains grid 438 WHERE( .NOT. llnei ) inei = -1 439 ! 635 440 ! Save processor layout in ascii file 636 441 IF (llwrtlay) THEN 637 442 CALL ctl_opn( inum, 'layout.dat', 'REPLACE', 'FORMATTED', 'SEQUENTIAL', -1, numout, .FALSE., narea ) 638 WRITE(inum,'(a)') ' jpnij jpimax jpjmax jpk jpiglo jpjglo'//& 639 & ' ( local: narea jpi jpj )' 640 WRITE(inum,'(6i8,a,3i8,a)') jpnij,jpimax,jpjmax,jpk,jpiglo,jpjglo,& 641 & ' ( local: ',narea,jpi,jpj,' )' 642 WRITE(inum,'(a)') 'narea jpi jpj Nis0 Njs0 Nie0 Nje0 nimp njmp nono noso nowe noea nbondi nbondj ' 643 644 DO jproc = 1, jpnij 645 WRITE(inum,'(13i5,2i7)') jproc, jpiall(jproc), jpjall(jproc), & 646 & nis0all(jproc), njs0all(jproc), & 647 & nie0all(jproc), nje0all(jproc), & 648 & nimppt (jproc), njmppt (jproc), & 649 & ii_nono(jproc), ii_noso(jproc), & 650 & ii_nowe(jproc), ii_noea(jproc), & 651 & ibonit (jproc), ibonjt (jproc) 443 WRITE(inum,'(a)') ' jpnij jpimax jpjmax jpk jpiglo jpjglo ( local: narea jpi jpj )' 444 WRITE(inum,'(6i7,a,3i7,a)') jpnij,jpimax,jpjmax,jpk,jpiglo,jpjglo,' ( local: ',narea,jpi,jpj,' )' 445 WRITE(inum,'(a)') ' narea ii ij jpi jpj nimpp njmpp mpiwe mpiea mpiso mpino mpisw mpise mpinw mpine' 446 DO jp = 1, jpnij 447 ii = iin(jp) 448 ij = ijn(jp) 449 WRITE(inum,'(15i6)') jp, ii, ij, ijpi(ii,ij), ijpj(ii,ij), iimppt(ii,ij), ijmppt(ii,ij), inei(:,ii,ij) 652 450 END DO 653 451 END IF 654 452 655 ! ! north fold parameter 656 ! Defined npolj, either 0, 3 , 4 , 5 , 6 657 ! In this case the important thing is that npolj /= 0 658 ! Because if we go through these line it is because jpni >1 and thus 659 ! we must use lbcnorthmpp, which tests only npolj =0 or npolj /= 0 660 npolj = 0 661 ij = ijn(narea) 662 IF( jperio == 3 .OR. jperio == 4 ) THEN 663 IF( ij == jpnj ) npolj = 3 664 ENDIF 665 IF( jperio == 5 .OR. jperio == 6 ) THEN 666 IF( ij == jpnj ) npolj = 5 667 ENDIF 453 ! 454 ! 4. Define Western, Eastern, Southern and Northern neighbors + corners for each mpi process 455 ! ------------------------------------------------------------------------------------------ 456 ! 457 ! rewrite information from "subdomain grid" to mpi process list 458 ! Warning, for example: 459 ! position of the northern neighbor in the "subdomain grid" 460 ! position of the northern neighbor in the "mpi process list" 461 462 ! default definition: no neighbors 463 impi(:,:) = -1 ! (starting at 0, -1 if no neighbourg) 464 465 DO jp = 1, jpnij 466 ii = iin(jp) 467 ij = ijn(jp) 468 DO jn = 1, 8 469 IF( llnei(jn,ii,ij) ) THEN ! must be tested as some land-domain can be kept to fit mppsize 470 ii2 = 1 + MOD( inei(jn,ii,ij) , jpni ) 471 ij2 = 1 + inei(jn,ii,ij) / jpni 472 impi(jn,jp) = ipproc( ii2, ij2 ) 473 ENDIF 474 END DO 475 END DO 476 477 ! 478 ! 4. keep information for the local process 479 ! ----------------------------------------- 480 ! 481 ! set default neighbours 482 mpinei(:) = impi(:,narea) 668 483 ! 669 484 IF(lwp) THEN 670 485 WRITE(numout,*) 671 486 WRITE(numout,*) ' resulting internal parameters : ' 672 WRITE(numout,*) ' narea = ', narea 673 WRITE(numout,*) ' nowe = ', nowe , ' noea = ', noea 674 WRITE(numout,*) ' nono = ', nono , ' noso = ', noso 675 WRITE(numout,*) ' nbondi = ', nbondi 676 WRITE(numout,*) ' nbondj = ', nbondj 677 WRITE(numout,*) ' npolj = ', npolj 678 WRITE(numout,*) ' l_Iperio = ', l_Iperio 679 WRITE(numout,*) ' l_Jperio = ', l_Jperio 680 WRITE(numout,*) ' nimpp = ', nimpp 681 WRITE(numout,*) ' njmpp = ', njmpp 682 ENDIF 683 487 WRITE(numout,*) ' narea = ', narea 488 WRITE(numout,*) ' mpi nei west = ', mpinei(jpwe) , ' mpi nei east = ', mpinei(jpea) 489 WRITE(numout,*) ' mpi nei south = ', mpinei(jpso) , ' mpi nei north = ', mpinei(jpno) 490 WRITE(numout,*) ' mpi nei so-we = ', mpinei(jpsw) , ' mpi nei so-ea = ', mpinei(jpse) 491 WRITE(numout,*) ' mpi nei no-we = ', mpinei(jpnw) , ' mpi nei no-ea = ', mpinei(jpne) 492 ENDIF 493 ! 684 494 ! ! Prepare mpp north fold 685 IF( jperio >= 3 .AND. jperio <= 6 .AND. jpni > 1 ) THEN 495 ! 496 llmpiNfold = jpnj > 1 .AND. ( l_NFoldT .OR. l_NFoldF ) ! is the North fold done with an MPI communication? 497 l_IdoNFold = ijn(narea) == jpnj .AND. ( l_NFoldT .OR. l_NFoldF ) ! is this process doing North fold? 498 ! 499 IF( llmpiNfold ) THEN 686 500 CALL mpp_ini_north 687 501 IF (lwp) THEN 688 502 WRITE(numout,*) 689 503 WRITE(numout,*) ' ==>>> North fold boundary prepared for jpni >1' 690 ! additional prints in layout.dat 691 ENDIF 692 IF (llwrtlay) THEN 504 ENDIF 505 IF (llwrtlay) THEN ! additional prints in layout.dat 693 506 WRITE(inum,*) 694 507 WRITE(inum,*) 695 508 WRITE(inum,*) 'number of subdomains located along the north fold : ', ndim_rank_north 696 509 WRITE(inum,*) 'Rank of the subdomains located along the north fold : ', ndim_rank_north 697 DO jp roc= 1, ndim_rank_north, 5698 WRITE(inum,*) nrank_north( jp roc:MINVAL( (/jproc+4,ndim_rank_north/) ) )510 DO jp = 1, ndim_rank_north, 5 511 WRITE(inum,*) nrank_north( jp:MINVAL( (/jp+4,ndim_rank_north/) ) ) 699 512 END DO 700 513 ENDIF 701 ENDIF 702 514 IF ( l_IdoNFold .AND. ln_nnogather ) THEN 515 CALL init_nfdcom ! northfold neighbour lists 516 IF (llwrtlay) THEN 517 WRITE(inum,*) 518 WRITE(inum,*) 'north fold exchanges with explicit point-to-point messaging :' 519 WRITE(inum,*) ' nsndto : ', nsndto 520 WRITE(inum,*) ' isendto : ', isendto(1:nsndto) 521 ENDIF 522 ENDIF 523 ENDIF 703 524 ! 704 525 CALL mpp_ini_nc ! Initialize communicator for neighbourhood collective communications … … 706 527 CALL init_ioipsl ! Prepare NetCDF output file (if necessary) 707 528 ! 708 IF (( jperio >= 3 .AND. jperio <= 6 .AND. jpni > 1 ).AND.( ln_nnogather )) THEN709 CALL init_nfdcom ! northfold neighbour lists710 IF (llwrtlay) THEN711 WRITE(inum,*)712 WRITE(inum,*)713 WRITE(inum,*) 'north fold exchanges with explicit point-to-point messaging :'714 WRITE(inum,*) 'nsndto : ', nsndto715 WRITE(inum,*) 'isendto : ', isendto716 ENDIF717 ENDIF718 !719 529 IF (llwrtlay) CLOSE(inum) 720 530 ! 721 DEALLOCATE(iin, ijn, ii_nono, ii_noea, ii_noso, ii_nowe, & 722 & iimppt, ijmppt, ibondi, ibondj, ipproc, ipolj, & 723 & ijpi, ijpj, iie0, ije0, iis0, ijs0, & 724 & iono, ioea, ioso, iowe, llisoce) 531 DEALLOCATE(iin, ijn, iimppt, ijmppt, ijpi, ijpj, ipproc, inei, llnei, impi, llisOce) 725 532 ! 726 533 END SUBROUTINE mpp_init … … 860 667 LOGICAL :: llist 861 668 LOGICAL, DIMENSION(:,:), ALLOCATABLE :: llmsk2d ! max size of the subdomains along i,j 862 LOGICAL, DIMENSION(:,:), ALLOCATABLE :: llis oce ! - -669 LOGICAL, DIMENSION(:,:), ALLOCATABLE :: llisOce ! - - 863 670 REAL(wp):: zpropland 864 671 !!---------------------------------------------------------------------- … … 991 798 END IF 992 799 ji = isz0 ! initialization with the largest value 993 ALLOCATE( llis oce(inbi0(ji), inbj0(ji)) )994 CALL mpp_is_ocean( llis oce ) ! Warning: must be call by all cores (call mpp_sum)995 inbijold = COUNT(llis oce)996 DEALLOCATE( llis oce )800 ALLOCATE( llisOce(inbi0(ji), inbj0(ji)) ) 801 CALL mpp_is_ocean( llisOce ) ! Warning: must be call by all cores (call mpp_sum) 802 inbijold = COUNT(llisOce) 803 DEALLOCATE( llisOce ) 997 804 DO ji =isz0-1,1,-1 998 ALLOCATE( llis oce(inbi0(ji), inbj0(ji)) )999 CALL mpp_is_ocean( llis oce ) ! Warning: must be call by all cores (call mpp_sum)1000 inbij = COUNT(llis oce)1001 DEALLOCATE( llis oce )805 ALLOCATE( llisOce(inbi0(ji), inbj0(ji)) ) 806 CALL mpp_is_ocean( llisOce ) ! Warning: must be call by all cores (call mpp_sum) 807 inbij = COUNT(llisOce) 808 DEALLOCATE( llisOce ) 1002 809 IF(lwp .AND. inbij < inbijold) THEN 1003 810 WRITE(numout,'(a, i6, a, i6, a, f4.1, a, i9, a, i6, a, i6, a)') & … … 1022 829 DO WHILE( inbij > knbij ) ! while the number of ocean subdomains exceed the number of procs 1023 830 ii = ii -1 1024 ALLOCATE( llis oce(inbi0(ii), inbj0(ii)) )1025 CALL mpp_is_ocean( llis oce ) ! must be done by all core1026 inbij = COUNT(llis oce)1027 DEALLOCATE( llis oce )831 ALLOCATE( llisOce(inbi0(ii), inbj0(ii)) ) 832 CALL mpp_is_ocean( llisOce ) ! must be done by all core 833 inbij = COUNT(llisOce) 834 DEALLOCATE( llisOce ) 1028 835 END DO 1029 836 knbi = inbi0(ii) … … 1087 894 1088 895 1089 SUBROUTINE mpp_is_ocean( ld isoce )896 SUBROUTINE mpp_is_ocean( ldIsOce ) 1090 897 !!---------------------------------------------------------------------- 1091 898 !! *** ROUTINE mpp_is_ocean *** … … 1095 902 !! at least 1 ocean point. 1096 903 !! We must indeed ensure that each subdomain that is a neighbour 1097 !! of a land subdomain 904 !! of a land subdomain, has only land points on its boundary 1098 905 !! (inside the inner subdomain) with the land subdomain. 1099 906 !! This is needed to get the proper bondary conditions on … … 1102 909 !! ** Method : read inbj strips (of length Ni0glo) of the land-sea mask 1103 910 !!---------------------------------------------------------------------- 1104 LOGICAL, DIMENSION(:,:), INTENT( out) :: ld isoce ! .true. if a sub domain constains 1 ocean point911 LOGICAL, DIMENSION(:,:), INTENT( out) :: ldIsOce ! .true. if a sub domain constains 1 ocean point 1105 912 ! 1106 913 INTEGER :: idiv, iimax, ijmax, iarea … … 1115 922 ! do nothing if there is no land-sea mask 1116 923 IF( numbot == -1 .AND. numbdy == -1 ) THEN 1117 ld isoce(:,:) = .TRUE.924 ldIsOce(:,:) = .TRUE. 1118 925 RETURN 1119 926 ENDIF 1120 927 ! 1121 inbi = SIZE( ld isoce, dim = 1 )1122 inbj = SIZE( ld isoce, dim = 2 )928 inbi = SIZE( ldIsOce, dim = 1 ) 929 inbj = SIZE( ldIsOce, dim = 2 ) 1123 930 ! 1124 931 ! we want to read inbj strips of the land-sea mask. -> pick up inbj processes every idiv processes starting at 1 … … 1193 1000 CALL mpp_sum( 'mppini', inboce_1d ) 1194 1001 inboce = RESHAPE(inboce_1d, (/inbi, inbj/)) 1195 ld isoce(:,:) = inboce(:,:) /= 01002 ldIsOce(:,:) = inboce(:,:) /= 0 1196 1003 DEALLOCATE(inboce, inboce_1d) 1197 1004 ! … … 1236 1043 1237 1044 1238 SUBROUTINE mpp_getnum( ld isoce, kproc, kipos, kjpos )1045 SUBROUTINE mpp_getnum( ldIsOce, kproc, kipos, kjpos ) 1239 1046 !!---------------------------------------------------------------------- 1240 1047 !! *** ROUTINE mpp_getnum *** … … 1244 1051 !! ** Method : start from bottom left. First skip land subdomain, and finally use them if needed 1245 1052 !!---------------------------------------------------------------------- 1246 LOGICAL, DIMENSION(:,:), INTENT(in ) :: ld isoce ! F if land process1247 INTEGER, DIMENSION(:,:), INTENT( out) :: kproc ! subdomain number (-1 if supressed, starting at 0)1053 LOGICAL, DIMENSION(:,:), INTENT(in ) :: ldIsOce ! F if land process 1054 INTEGER, DIMENSION(:,:), INTENT( out) :: kproc ! subdomain number (-1 if not existing, starting at 0) 1248 1055 INTEGER, DIMENSION( :), INTENT( out) :: kipos ! i-position of the subdomain (from 1 to jpni) 1249 1056 INTEGER, DIMENSION( :), INTENT( out) :: kjpos ! j-position of the subdomain (from 1 to jpnj) … … 1253 1060 !!---------------------------------------------------------------------- 1254 1061 ! 1255 ini = SIZE(ld isoce, dim = 1)1256 inj = SIZE(ld isoce, dim = 2)1062 ini = SIZE(ldIsOce, dim = 1) 1063 inj = SIZE(ldIsOce, dim = 2) 1257 1064 inij = SIZE(kipos) 1258 1065 ! … … 1264 1071 ii = 1 + MOD(iarea0,ini) 1265 1072 ij = 1 + iarea0/ini 1266 IF( ld isoce(ii,ij) ) THEN1073 IF( ldIsOce(ii,ij) ) THEN 1267 1074 icont = icont + 1 1268 1075 kproc(ii,ij) = icont … … 1272 1079 END DO 1273 1080 ! if needed add some land subdomains to reach inij active subdomains 1274 i2add = inij - COUNT( ld isoce )1081 i2add = inij - COUNT( ldIsOce ) 1275 1082 DO jarea = 1, ini*inj 1276 1083 iarea0 = jarea - 1 1277 1084 ii = 1 + MOD(iarea0,ini) 1278 1085 ij = 1 + iarea0/ini 1279 IF( .NOT. ld isoce(ii,ij) .AND. i2add > 0 ) THEN1086 IF( .NOT. ldIsOce(ii,ij) .AND. i2add > 0 ) THEN 1280 1087 icont = icont + 1 1281 1088 kproc(ii,ij) = icont … … 1343 1150 !!---------------------------------------------------------------------- 1344 1151 ! 1345 !initializes the north-fold communication variables 1346 isendto(:) = 0 1347 nsndto = 0 1348 ! 1349 IF ( njmpp == MAXVAL( njmppt ) ) THEN ! if I am a process in the north 1152 !sxM is the first point (in the global domain) needed to compute the north-fold for the current process 1153 sxM = jpiglo - nimpp - jpi + 1 1154 !dxM is the last point (in the global domain) needed to compute the north-fold for the current process 1155 dxM = jpiglo - nimpp + 2 1156 ! 1157 ! loop over the other north-fold processes to find the processes 1158 ! managing the points belonging to the sxT-dxT range 1159 ! 1160 nsndto = 0 1161 DO jn = 1, jpni 1350 1162 ! 1351 !sxM is the first point (in the global domain) needed to compute the north-fold for the current process 1352 sxM = jpiglo - nimppt(narea) - jpiall(narea) + 1 1353 !dxM is the last point (in the global domain) needed to compute the north-fold for the current process 1354 dxM = jpiglo - nimppt(narea) + 2 1163 sxT = nfimpp(jn) ! sxT = 1st point (in the global domain) of the jn process 1164 dxT = nfimpp(jn) + nfjpi(jn) - 1 ! dxT = last point (in the global domain) of the jn process 1355 1165 ! 1356 ! loop over the other north-fold processes to find the processes 1357 ! managing the points belonging to the sxT-dxT range 1166 IF ( sxT < sxM .AND. sxM < dxT ) THEN 1167 nsndto = nsndto + 1 1168 isendto(nsndto) = jn 1169 ELSEIF( sxM <= sxT .AND. dxM >= dxT ) THEN 1170 nsndto = nsndto + 1 1171 isendto(nsndto) = jn 1172 ELSEIF( dxM < dxT .AND. sxT < dxM ) THEN 1173 nsndto = nsndto + 1 1174 isendto(nsndto) = jn 1175 ENDIF 1358 1176 ! 1359 DO jn = 1, jpni 1360 ! 1361 sxT = nfimpp(jn) ! sxT = 1st point (in the global domain) of the jn process 1362 dxT = nfimpp(jn) + nfjpi(jn) - 1 ! dxT = last point (in the global domain) of the jn process 1363 ! 1364 IF ( sxT < sxM .AND. sxM < dxT ) THEN 1365 nsndto = nsndto + 1 1366 isendto(nsndto) = jn 1367 ELSEIF( sxM <= sxT .AND. dxM >= dxT ) THEN 1368 nsndto = nsndto + 1 1369 isendto(nsndto) = jn 1370 ELSEIF( dxM < dxT .AND. sxT < dxM ) THEN 1371 nsndto = nsndto + 1 1372 isendto(nsndto) = jn 1373 ENDIF 1374 ! 1375 END DO 1376 ! 1377 ENDIF 1378 l_north_nogather = .TRUE. 1177 END DO 1379 1178 ! 1380 1179 END SUBROUTINE init_nfdcom … … 1394 1193 Nie0 = jpi-nn_hls ; Nie1 = Nie0+1 ; Nie2 = MIN(jpi, Nie0+2) 1395 1194 Nje0 = jpj-nn_hls ; Nje1 = Nje0+1 ; Nje2 = MIN(jpj, Nje0+2) 1396 !1397 IF( nn_hls == 1 ) THEN !* halo size of 11398 !1399 Nis1nxt2 = Nis0 ; Njs1nxt2 = Njs01400 Nie1nxt2 = Nie0 ; Nje1nxt2 = Nje01401 !1402 ELSE !* larger halo size...1403 !1404 Nis1nxt2 = Nis1 ; Njs1nxt2 = Njs11405 Nie1nxt2 = Nie1 ; Nje1nxt2 = Nje11406 !1407 ENDIF1408 1195 ! 1409 1196 Ni_0 = Nie0 - Nis0 + 1 … … 1414 1201 Nj_2 = Nje2 - Njs2 + 1 1415 1202 ! 1203 ! old indices to be removed... 1204 jpim1 = jpi-1 ! inner domain indices 1205 jpjm1 = jpj-1 ! " " 1206 jpkm1 = jpk-1 ! " " 1207 ! 1416 1208 END SUBROUTINE init_doloop 1417 1209 -
NEMO/branches/2021/dev_r14312_MPI_Interface/src/OCE/lib_fortran.F90
r13327 r14314 220 220 ! 221 221 DO_2D( nn_hls, nn_hls, nn_hls, nn_hls ) 222 IF( MOD(mig(ji), 3) == MOD(nn_hls, 3) .AND. & 222 IF( MOD(mig(ji), 3) == MOD(nn_hls, 3) .AND. & ! 1st bottom left corner always at (Nis0-1, Njs0-1) 223 223 & MOD(mjg(jj), 3) == MOD(nn_hls, 3) ) THEN ! bottom left corner of a 3x3 box 224 224 ji2 = MIN(mig(ji)+2, jpiglo) - nimpp + 1 ! right position of the box … … 230 230 END_2D 231 231 CALL lbc_lnk( 'lib_fortran', p2d, 'T', 1.0_wp ) 232 ! no need for 2nd exchange when nn_hls = 2 233 IF( nn_hls /= 2 ) THEN 234 IF( nbondi /= -1 ) THEN 235 IF( MOD(mig( 1), 3) == 1 ) p2d( 1,:) = p2d( 2,:) 236 IF( MOD(mig( 1), 3) == 2 ) p2d( 2,:) = p2d( 1,:) 237 ENDIF 238 IF( nbondi /= 1 ) THEN 232 ! no need for 2nd exchange when nn_hls > 1 233 IF( nn_hls == 1 ) THEN 234 IF( mpinei(jpwe) > -1 ) THEN ! 1st column was changed beacuse of an MPI communication during the previous call to lbc_lnk 235 IF( MOD(mig( 1), 3) == 1 ) & ! 1st box start at i=1 -> column 1 to 3 correctly computed locally 236 p2d( 1,:) = p2d( 2,:) ! previous lbc_lnk corrupted column 1 -> put it back using column 2 237 IF( MOD(mig( 1), 3) == 2 ) & ! 1st box start at i=3 -> column 1 and 2 correctly computed on west neighbourh 238 p2d( 2,:) = p2d( 1,:) ! previous lbc_lnk fix column 1 -> copy it to column 2 239 ENDIF 240 IF( mpinei(jpea) > -1 ) THEN 239 241 IF( MOD(mig(jpi-2), 3) == 1 ) p2d( jpi,:) = p2d(jpi-1,:) 240 242 IF( MOD(mig(jpi-2), 3) == 0 ) p2d(jpi-1,:) = p2d( jpi,:) 241 243 ENDIF 242 IF( nbondj /=-1 ) THEN244 IF( mpinei(jpso) > -1 ) THEN 243 245 IF( MOD(mjg( 1), 3) == 1 ) p2d(:, 1) = p2d(:, 2) 244 246 IF( MOD(mjg( 1), 3) == 2 ) p2d(:, 2) = p2d(:, 1) 245 247 ENDIF 246 IF( nbondj /=1 ) THEN248 IF( mpinei(jpno) > -1 ) THEN 247 249 IF( MOD(mjg(jpj-2), 3) == 1 ) p2d(:, jpj) = p2d(:,jpj-1) 248 250 IF( MOD(mjg(jpj-2), 3) == 0 ) p2d(:,jpj-1) = p2d(:, jpj) … … 274 276 ! 275 277 DO_2D( nn_hls, nn_hls, nn_hls, nn_hls ) 276 IF( MOD(mig(ji), 3) == MOD(nn_hls, 3) .AND. & 278 IF( MOD(mig(ji), 3) == MOD(nn_hls, 3) .AND. & ! 1st bottom left corner always at (Nis0-1, Njs0-1) 277 279 & MOD(mjg(jj), 3) == MOD(nn_hls, 3) ) THEN ! bottom left corner of a 3x3 box 278 280 ji2 = MIN(mig(ji)+2, jpiglo) - nimpp + 1 ! right position of the box … … 285 287 END DO 286 288 CALL lbc_lnk( 'lib_fortran', p3d, 'T', 1.0_wp ) 287 ! no need for 2nd exchange when nn_hls = 2 288 IF( nn_hls /= 2 ) THEN 289 IF( nbondi /= -1 ) THEN 290 IF( MOD(mig( 1), 3) == 1 ) p3d( 1,:,:) = p3d( 2,:,:) 291 IF( MOD(mig( 1), 3) == 2 ) p3d( 2,:,:) = p3d( 1,:,:) 292 ENDIF 293 IF( nbondi /= 1 ) THEN 289 ! no need for 2nd exchange when nn_hls > 1 290 IF( nn_hls == 1 ) THEN 291 IF( mpinei(jpwe) > -1 ) THEN ! 1st column was changed beacuse of an MPI communication during the previous call to lbc_lnk 292 IF( MOD(mig( 1), 3) == 1 ) & ! 1st box start at i=1 -> column 1 to 3 correctly computed locally 293 p3d( 1,:,:) = p3d( 2,:,:) ! previous lbc_lnk corrupted column 1 -> put it back using column 2 294 IF( MOD(mig( 1), 3) == 2 ) & ! 1st box start at i=3 -> column 1 and 2 correctly computed on west neighbourh 295 p3d( 2,:,:) = p3d( 1,:,:) ! previous lbc_lnk fix column 1 -> copy it to column 2 296 ENDIF 297 IF( mpinei(jpea) > -1 ) THEN 294 298 IF( MOD(mig(jpi-2), 3) == 1 ) p3d( jpi,:,:) = p3d(jpi-1,:,:) 295 299 IF( MOD(mig(jpi-2), 3) == 0 ) p3d(jpi-1,:,:) = p3d( jpi,:,:) 296 300 ENDIF 297 IF( nbondj /=-1 ) THEN301 IF( mpinei(jpso) > -1 ) THEN 298 302 IF( MOD(mjg( 1), 3) == 1 ) p3d(:, 1,:) = p3d(:, 2,:) 299 303 IF( MOD(mjg( 1), 3) == 2 ) p3d(:, 2,:) = p3d(:, 1,:) 300 304 ENDIF 301 IF( nbondj /=1 ) THEN305 IF( mpinei(jpno) > -1 ) THEN 302 306 IF( MOD(mjg(jpj-2), 3) == 1 ) p3d(:, jpj,:) = p3d(:,jpj-1,:) 303 307 IF( MOD(mjg(jpj-2), 3) == 0 ) p3d(:,jpj-1,:) = p3d(:, jpj,:) -
NEMO/branches/2021/dev_r14312_MPI_Interface/src/OCE/nemogcm.F90
r14239 r14314 382 382 CALL usr_def_nam( cn_cfg, nn_cfg, Ni0glo, Nj0glo, jpkglo, jperio ) 383 383 ENDIF 384 l_Iperio = jperio == 1 .OR. jperio == 4 .OR. jperio == 6 .OR. jperio == 7 ! i-periodicity? 385 l_Jperio = jperio == 2 .OR. jperio == 7 ! j-periodicity ? 386 l_NFoldT = jperio == 3 .OR. jperio == 4 ! 387 l_NFoldF = jperio == 5 .OR. jperio == 6 ! 384 388 ! 385 389 IF(lwm) WRITE( numond, namcfg ) -
NEMO/branches/2021/dev_r14312_MPI_Interface/src/OCE/par_kind.F90
r13226 r14314 10 10 IMPLICIT NONE 11 11 PRIVATE 12 13 INTEGER, PUBLIC, PARAMETER :: jpbyt = 8 !: real size for mpp communications14 INTEGER, PUBLIC, PARAMETER :: jpbytda = 4 !: real size in input data files 4 or 815 12 16 13 ! Number model from which the SELECTED_*_KIND are requested: -
NEMO/branches/2021/dev_r14312_MPI_Interface/src/OCE/par_oce.F90
r14072 r14314 92 92 ! halo with and starting/inding DO-loop indices 93 93 INTEGER, PUBLIC :: nn_hls !: halo width (applies to both rows and columns) 94 INTEGER, PUBLIC :: Nis0, Nis1, Nis 1nxt2, Nis2 !: start I-index (_0: without halo, _1 or _2: with 1 or 2 halos)95 INTEGER, PUBLIC :: Nie0, Nie1, Nie 1nxt2, Nie2 !: end I-index (_0: without halo, _1 or _2: with 1 or 2 halos)96 INTEGER, PUBLIC :: Njs0, Njs1, Njs 1nxt2, Njs2 !: start J-index (_0: without halo, _1 or _2: with 1 or 2 halos)97 INTEGER, PUBLIC :: Nje0, Nje1, Nje 1nxt2, Nje2 !: end J-index (_0: without halo, _1 or _2: with 1 or 2 halos)94 INTEGER, PUBLIC :: Nis0, Nis1, Nis2 !: start I-index (_0: without halo, _1 or _2: with 1 or 2 halos) 95 INTEGER, PUBLIC :: Nie0, Nie1, Nie2 !: end I-index (_0: without halo, _1 or _2: with 1 or 2 halos) 96 INTEGER, PUBLIC :: Njs0, Njs1, Njs2 !: start J-index (_0: without halo, _1 or _2: with 1 or 2 halos) 97 INTEGER, PUBLIC :: Nje0, Nje1, Nje2 !: end J-index (_0: without halo, _1 or _2: with 1 or 2 halos) 98 98 INTEGER, PUBLIC :: Ni_0, Nj_0, Ni_1, Nj_1, Ni_2, Nj_2 !: domain size (_0: without halo, _1 or _2: with 1 or 2 halos) 99 99 INTEGER, PUBLIC :: Ni0glo, Nj0glo -
NEMO/branches/2021/dev_r14312_MPI_Interface/src/TOP/oce_trc.F90
r13333 r14314 27 27 USE par_oce , ONLY : Nie1 => Nie1 !: 28 28 USE par_oce , ONLY : Nje1 => Nje1 !: 29 USE par_oce , ONLY : Nis1nxt2 => Nis1nxt2 !:30 USE par_oce , ONLY : Njs1nxt2 => Njs1nxt2 !:31 USE par_oce , ONLY : Nie1nxt2 => Nie1nxt2 !:32 USE par_oce , ONLY : Nje1nxt2 => Nje1nxt2 !:33 29 USE par_oce , ONLY : Nis2 => Nis2 !: 34 30 USE par_oce , ONLY : Njs2 => Njs2 !:
Note: See TracChangeset
for help on using the changeset viewer.