Changeset 2882
- Timestamp:
- 2011-09-30T17:57:57+02:00 (13 years ago)
- Location:
- branches/2011/dev_r2855_NOCS_mppsca/NEMOGCM
- Files:
-
- 6 edited
Legend:
- Unmodified
- Added
- Removed
-
branches/2011/dev_r2855_NOCS_mppsca/NEMOGCM/CONFIG/GYRE/EXP00/namelist
r2715 r2882 695 695 ! buffer blocking send or immediate non-blocking sends, resp. 696 696 nn_buffer = 0 ! size in bytes of exported buffer ('B' case), 0 no exportation 697 ln_nnogather= .false. ! activate code to avoid mpi_allgather use at the northfold 697 698 jpni = 0 ! jpni number of processors following i (set automatically if < 1) 698 699 jpnj = 0 ! jpnj number of processors following j (set automatically if < 1) -
branches/2011/dev_r2855_NOCS_mppsca/NEMOGCM/CONFIG/ORCA2_LIM/EXP00/namelist
r2715 r2882 695 695 ! buffer blocking send or immediate non-blocking sends, resp. 696 696 nn_buffer = 0 ! size in bytes of exported buffer ('B' case), 0 no exportation 697 ln_nnogather= .false. ! activate code to avoid mpi_allgather use at the northfold 697 698 jpni = 0 ! jpni number of processors following i (set automatically if < 1) 698 699 jpnj = 0 ! jpnj number of processors following j (set automatically if < 1) -
branches/2011/dev_r2855_NOCS_mppsca/NEMOGCM/CONFIG/ORCA2_OFF_PISCES/EXP00/namelist
r2715 r2882 709 709 ! buffer blocking send or immediate non-blocking sends, resp. 710 710 nn_buffer = 0 ! size in bytes of exported buffer ('B' case), 0 no exportation 711 ln_nnogather= .false. ! activate code to avoid mpi_allgather use at the northfold 711 712 jpni = 0 ! jpni number of processors following i (set automatically if < 1) 712 713 jpnj = 0 ! jpnj number of processors following j (set automatically if < 1) -
branches/2011/dev_r2855_NOCS_mppsca/NEMOGCM/NEMO/OPA_SRC/LBC/lbcnfd.F90
r2715 r2882 236 236 END DO 237 237 END DO 238 CASE ( 'J' ) ! first ice U-V point 239 DO jl =0, ipr2dj 240 pt2d(2,ijpj+jl) = psgn * pt2d(3,ijpj-1+jl) 241 DO ji = 3, jpiglo 242 iju = jpiglo - ji + 3 243 pt2d(ji,ijpj+jl) = psgn * pt2d(iju,ijpj-1-jl) 244 END DO 245 END DO 246 CASE ( 'K' ) ! second ice U-V point 247 DO jl =0, ipr2dj 248 pt2d(2,ijpj+jl) = psgn * pt2d(3,ijpj-1+jl) 249 DO ji = 3, jpiglo 250 iju = jpiglo - ji + 3 251 pt2d(ji,ijpj+jl) = psgn * pt2d(iju,ijpj-1-jl) 252 END DO 253 END DO 238 254 END SELECT 239 255 ! … … 285 301 END DO 286 302 END DO 303 CASE ( 'J' ) ! first ice U-V point 304 pt2d( 2 ,ijpj:ijpj+ipr2dj) = 0.e0 305 DO jl = 0, ipr2dj 306 DO ji = 2 , jpiglo-1 307 ijt = jpiglo - ji + 2 308 pt2d(ji,ijpj+jl)= pt2d(ji,ijpj-1-jl) 309 END DO 310 END DO 311 CASE ( 'K' ) ! second ice U-V point 312 pt2d( 2 ,ijpj:ijpj+ipr2dj) = 0.e0 313 DO jl = 0, ipr2dj 314 DO ji = 2 , jpiglo-1 315 ijt = jpiglo - ji + 2 316 pt2d(ji,ijpj+jl)= pt2d(ijt,ijpj-1-jl) 317 END DO 318 END DO 287 319 END SELECT 288 320 ! … … 298 330 pt2d(:, 1:1-ipr2dj ) = 0.e0 299 331 pt2d(:,ijpj:ijpj+ipr2dj) = 0.e0 332 CASE ( 'J' ) ! first ice U-V point 333 pt2d(:, 1:1-ipr2dj ) = 0.e0 334 pt2d(:,ijpj:ijpj+ipr2dj) = 0.e0 335 CASE ( 'K' ) ! second ice U-V point 336 pt2d(:, 1:1-ipr2dj ) = 0.e0 337 pt2d(:,ijpj:ijpj+ipr2dj) = 0.e0 300 338 END SELECT 301 339 ! -
branches/2011/dev_r2855_NOCS_mppsca/NEMOGCM/NEMO/OPA_SRC/LBC/lib_mpp.F90
r2731 r2882 164 164 REAL(wp), DIMENSION(:,:,:) , ALLOCATABLE, SAVE :: ztab, znorthloc 165 165 REAL(wp), DIMENSION(:,:,:,:), ALLOCATABLE, SAVE :: znorthgloio 166 REAL(wp), DIMENSION(:,:,:) , ALLOCATABLE, SAVE :: zfoldwk ! Workspace for message transfers avoiding mpi_allgather 166 167 167 168 ! Arrays used in mpp_lbc_north_2d() 168 169 REAL(wp), DIMENSION(:,:) , ALLOCATABLE, SAVE :: ztab_2d, znorthloc_2d 169 170 REAL(wp), DIMENSION(:,:,:), ALLOCATABLE, SAVE :: znorthgloio_2d 171 REAL(wp), DIMENSION(:,:) , ALLOCATABLE, SAVE :: zfoldwk_2d ! Workspace for message transfers avoiding mpi_allgather 170 172 171 173 ! Arrays used in mpp_lbc_north_e() … … 173 175 REAL(wp), DIMENSION(:,:,:), ALLOCATABLE, SAVE :: znorthgloio_e 174 176 177 ! North fold arrays used to minimise the use of allgather operations. Set in nemo_northcomms (nemogcm) so need to be public 178 INTEGER, PUBLIC, PARAMETER :: jpmaxngh = 8 ! Assumed maximum number of active neighbours 179 INTEGER, PUBLIC, PARAMETER :: jptyps = 5 ! Number of different neighbour lists to be used for northfold exchanges 180 INTEGER, PUBLIC, DIMENSION (jpmaxngh,jptyps) :: isendto 181 INTEGER, PUBLIC, DIMENSION (jptyps) :: nsndto 182 LOGICAL, PUBLIC :: ln_nnogather = .FALSE. ! namelist control of northfold comms 183 LOGICAL, PUBLIC :: l_north_nogather = .FALSE. ! internal control of northfold comms 184 INTEGER, PUBLIC :: ityp 175 185 !!---------------------------------------------------------------------- 176 186 !! NEMO/OPA 3.3 , NEMO Consortium (2010) … … 203 213 ! 204 214 & ztab(jpiglo,4,jpk) , znorthloc(jpi,4,jpk) , znorthgloio(jpi,4,jpk,jpni) , & 215 & zfoldwk(jpi,4,jpk) , & 205 216 ! 206 217 & ztab_2d(jpiglo,4) , znorthloc_2d(jpi,4) , znorthgloio_2d(jpi,4,jpni) , & 218 & zfoldwk_2d(jpi,4) , & 207 219 ! 208 220 & ztab_e(jpiglo,4+2*jpr2dj) , znorthloc_e(jpi,4+2*jpr2dj) , znorthgloio_e(jpi,4+2*jpr2dj,jpni) , & … … 232 244 LOGICAL :: mpi_was_called 233 245 ! 234 NAMELIST/nammpp/ cn_mpi_send, nn_buffer, jpni, jpnj, jpnij 246 NAMELIST/nammpp/ cn_mpi_send, nn_buffer, jpni, jpnj, jpnij, ln_nnogather 235 247 !!---------------------------------------------------------------------- 236 248 ! … … 269 281 WRITE(ldtxt(ii),*) ' number of local domains jpnij = ',jpnij; ii = ii +1 270 282 END IF 283 284 WRITE(ldtxt(ii),*) ' avoid use of mpi_allgather at the north fold ln_nnogather = ', ln_nnogather ; ii = ii + 1 271 285 272 286 CALL mpi_initialized ( mpi_was_called, code ) … … 441 455 CASE ( -1 ) 442 456 CALL mppsend( 2, t3we(1,1,1,1), imigr, noea, ml_req1 ) 443 CALL mpprecv( 1, t3ew(1,1,1,2), imigr )457 CALL mpprecv( 1, t3ew(1,1,1,2), imigr, noea ) 444 458 IF(l_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err) 445 459 CASE ( 0 ) 446 460 CALL mppsend( 1, t3ew(1,1,1,1), imigr, nowe, ml_req1 ) 447 461 CALL mppsend( 2, t3we(1,1,1,1), imigr, noea, ml_req2 ) 448 CALL mpprecv( 1, t3ew(1,1,1,2), imigr )449 CALL mpprecv( 2, t3we(1,1,1,2), imigr )462 CALL mpprecv( 1, t3ew(1,1,1,2), imigr, noea ) 463 CALL mpprecv( 2, t3we(1,1,1,2), imigr, nowe ) 450 464 IF(l_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err) 451 465 IF(l_isend) CALL mpi_wait(ml_req2, ml_stat, ml_err) 452 466 CASE ( 1 ) 453 467 CALL mppsend( 1, t3ew(1,1,1,1), imigr, nowe, ml_req1 ) 454 CALL mpprecv( 2, t3we(1,1,1,2), imigr )468 CALL mpprecv( 2, t3we(1,1,1,2), imigr, nowe ) 455 469 IF(l_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err) 456 470 END SELECT … … 494 508 CASE ( -1 ) 495 509 CALL mppsend( 4, t3sn(1,1,1,1), imigr, nono, ml_req1 ) 496 CALL mpprecv( 3, t3ns(1,1,1,2), imigr )510 CALL mpprecv( 3, t3ns(1,1,1,2), imigr, nono ) 497 511 IF(l_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err) 498 512 CASE ( 0 ) 499 513 CALL mppsend( 3, t3ns(1,1,1,1), imigr, noso, ml_req1 ) 500 514 CALL mppsend( 4, t3sn(1,1,1,1), imigr, nono, ml_req2 ) 501 CALL mpprecv( 3, t3ns(1,1,1,2), imigr )502 CALL mpprecv( 4, t3sn(1,1,1,2), imigr )515 CALL mpprecv( 3, t3ns(1,1,1,2), imigr, nono ) 516 CALL mpprecv( 4, t3sn(1,1,1,2), imigr, noso ) 503 517 IF(l_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err) 504 518 IF(l_isend) CALL mpi_wait(ml_req2, ml_stat, ml_err) 505 519 CASE ( 1 ) 506 520 CALL mppsend( 3, t3ns(1,1,1,1), imigr, noso, ml_req1 ) 507 CALL mpprecv( 4, t3sn(1,1,1,2), imigr )521 CALL mpprecv( 4, t3sn(1,1,1,2), imigr, noso ) 508 522 IF(l_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err) 509 523 END SELECT … … 635 649 CASE ( -1 ) 636 650 CALL mppsend( 2, t2we(1,1,1), imigr, noea, ml_req1 ) 637 CALL mpprecv( 1, t2ew(1,1,2), imigr )651 CALL mpprecv( 1, t2ew(1,1,2), imigr, noea ) 638 652 IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err) 639 653 CASE ( 0 ) 640 654 CALL mppsend( 1, t2ew(1,1,1), imigr, nowe, ml_req1 ) 641 655 CALL mppsend( 2, t2we(1,1,1), imigr, noea, ml_req2 ) 642 CALL mpprecv( 1, t2ew(1,1,2), imigr )643 CALL mpprecv( 2, t2we(1,1,2), imigr )656 CALL mpprecv( 1, t2ew(1,1,2), imigr, noea ) 657 CALL mpprecv( 2, t2we(1,1,2), imigr, nowe ) 644 658 IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err) 645 659 IF(l_isend) CALL mpi_wait(ml_req2,ml_stat,ml_err) 646 660 CASE ( 1 ) 647 661 CALL mppsend( 1, t2ew(1,1,1), imigr, nowe, ml_req1 ) 648 CALL mpprecv( 2, t2we(1,1,2), imigr )662 CALL mpprecv( 2, t2we(1,1,2), imigr, nowe ) 649 663 IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err) 650 664 END SELECT … … 688 702 CASE ( -1 ) 689 703 CALL mppsend( 4, t2sn(1,1,1), imigr, nono, ml_req1 ) 690 CALL mpprecv( 3, t2ns(1,1,2), imigr )704 CALL mpprecv( 3, t2ns(1,1,2), imigr, nono ) 691 705 IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err) 692 706 CASE ( 0 ) 693 707 CALL mppsend( 3, t2ns(1,1,1), imigr, noso, ml_req1 ) 694 708 CALL mppsend( 4, t2sn(1,1,1), imigr, nono, ml_req2 ) 695 CALL mpprecv( 3, t2ns(1,1,2), imigr )696 CALL mpprecv( 4, t2sn(1,1,2), imigr )709 CALL mpprecv( 3, t2ns(1,1,2), imigr, nono ) 710 CALL mpprecv( 4, t2sn(1,1,2), imigr, noso ) 697 711 IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err) 698 712 IF(l_isend) CALL mpi_wait(ml_req2,ml_stat,ml_err) 699 713 CASE ( 1 ) 700 714 CALL mppsend( 3, t2ns(1,1,1), imigr, noso, ml_req1 ) 701 CALL mpprecv( 4, t2sn(1,1,2), imigr )715 CALL mpprecv( 4, t2sn(1,1,2), imigr, noso ) 702 716 IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err) 703 717 END SELECT … … 816 830 CASE ( -1 ) 817 831 CALL mppsend( 2, t4we(1,1,1,1,1), imigr, noea, ml_req1 ) 818 CALL mpprecv( 1, t4ew(1,1,1,1,2), imigr )832 CALL mpprecv( 1, t4ew(1,1,1,1,2), imigr, noea ) 819 833 IF(l_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err) 820 834 CASE ( 0 ) 821 835 CALL mppsend( 1, t4ew(1,1,1,1,1), imigr, nowe, ml_req1 ) 822 836 CALL mppsend( 2, t4we(1,1,1,1,1), imigr, noea, ml_req2 ) 823 CALL mpprecv( 1, t4ew(1,1,1,1,2), imigr )824 CALL mpprecv( 2, t4we(1,1,1,1,2), imigr )837 CALL mpprecv( 1, t4ew(1,1,1,1,2), imigr, noea ) 838 CALL mpprecv( 2, t4we(1,1,1,1,2), imigr, nowe ) 825 839 IF(l_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err) 826 840 IF(l_isend) CALL mpi_wait(ml_req2, ml_stat, ml_err) 827 841 CASE ( 1 ) 828 842 CALL mppsend( 1, t4ew(1,1,1,1,1), imigr, nowe, ml_req1 ) 829 CALL mpprecv( 2, t4we(1,1,1,1,2), imigr )843 CALL mpprecv( 2, t4we(1,1,1,1,2), imigr, nowe ) 830 844 IF(l_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err) 831 845 END SELECT … … 875 889 CASE ( -1 ) 876 890 CALL mppsend( 4, t4sn(1,1,1,1,1), imigr, nono, ml_req1 ) 877 CALL mpprecv( 3, t4ns(1,1,1,1,2), imigr )891 CALL mpprecv( 3, t4ns(1,1,1,1,2), imigr, nono ) 878 892 IF(l_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err) 879 893 CASE ( 0 ) 880 894 CALL mppsend( 3, t4ns(1,1,1,1,1), imigr, noso, ml_req1 ) 881 895 CALL mppsend( 4, t4sn(1,1,1,1,1), imigr, nono, ml_req2 ) 882 CALL mpprecv( 3, t4ns(1,1,1,1,2), imigr )883 CALL mpprecv( 4, t4sn(1,1,1,1,2), imigr )896 CALL mpprecv( 3, t4ns(1,1,1,1,2), imigr, nono ) 897 CALL mpprecv( 4, t4sn(1,1,1,1,2), imigr, noso ) 884 898 IF(l_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err) 885 899 IF(l_isend) CALL mpi_wait(ml_req2, ml_stat, ml_err) 886 900 CASE ( 1 ) 887 901 CALL mppsend( 3, t4ns(1,1,1,1,1), imigr, noso, ml_req1 ) 888 CALL mpprecv( 4, t4sn(1,1,1,1,2), imigr )902 CALL mpprecv( 4, t4sn(1,1,1,1,2), imigr, noso ) 889 903 IF(l_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err) 890 904 END SELECT … … 1019 1033 CASE ( -1 ) 1020 1034 CALL mppsend( 2, tr2we(1-jpr2dj,1,1), imigr, noea, ml_req1 ) 1021 CALL mpprecv( 1, tr2ew(1-jpr2dj,1,2), imigr )1035 CALL mpprecv( 1, tr2ew(1-jpr2dj,1,2), imigr, noea ) 1022 1036 IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err) 1023 1037 CASE ( 0 ) 1024 1038 CALL mppsend( 1, tr2ew(1-jpr2dj,1,1), imigr, nowe, ml_req1 ) 1025 1039 CALL mppsend( 2, tr2we(1-jpr2dj,1,1), imigr, noea, ml_req2 ) 1026 CALL mpprecv( 1, tr2ew(1-jpr2dj,1,2), imigr )1027 CALL mpprecv( 2, tr2we(1-jpr2dj,1,2), imigr )1040 CALL mpprecv( 1, tr2ew(1-jpr2dj,1,2), imigr, noea ) 1041 CALL mpprecv( 2, tr2we(1-jpr2dj,1,2), imigr, nowe ) 1028 1042 IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err) 1029 1043 IF(l_isend) CALL mpi_wait(ml_req2,ml_stat,ml_err) 1030 1044 CASE ( 1 ) 1031 1045 CALL mppsend( 1, tr2ew(1-jpr2dj,1,1), imigr, nowe, ml_req1 ) 1032 CALL mpprecv( 2, tr2we(1-jpr2dj,1,2), imigr )1046 CALL mpprecv( 2, tr2we(1-jpr2dj,1,2), imigr, nowe ) 1033 1047 IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err) 1034 1048 END SELECT … … 1072 1086 CASE ( -1 ) 1073 1087 CALL mppsend( 4, tr2sn(1-jpr2di,1,1), imigr, nono, ml_req1 ) 1074 CALL mpprecv( 3, tr2ns(1-jpr2di,1,2), imigr )1088 CALL mpprecv( 3, tr2ns(1-jpr2di,1,2), imigr, nono ) 1075 1089 IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err) 1076 1090 CASE ( 0 ) 1077 1091 CALL mppsend( 3, tr2ns(1-jpr2di,1,1), imigr, noso, ml_req1 ) 1078 1092 CALL mppsend( 4, tr2sn(1-jpr2di,1,1), imigr, nono, ml_req2 ) 1079 CALL mpprecv( 3, tr2ns(1-jpr2di,1,2), imigr )1080 CALL mpprecv( 4, tr2sn(1-jpr2di,1,2), imigr )1093 CALL mpprecv( 3, tr2ns(1-jpr2di,1,2), imigr, nono ) 1094 CALL mpprecv( 4, tr2sn(1-jpr2di,1,2), imigr, noso ) 1081 1095 IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err) 1082 1096 IF(l_isend) CALL mpi_wait(ml_req2,ml_stat,ml_err) 1083 1097 CASE ( 1 ) 1084 1098 CALL mppsend( 3, tr2ns(1-jpr2di,1,1), imigr, noso, ml_req1 ) 1085 CALL mpprecv( 4, tr2sn(1-jpr2di,1,2), imigr )1099 CALL mpprecv( 4, tr2sn(1-jpr2di,1,2), imigr, noso ) 1086 1100 IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err) 1087 1101 END SELECT … … 1138 1152 1139 1153 1140 SUBROUTINE mpprecv( ktyp, pmess, kbytes )1154 SUBROUTINE mpprecv( ktyp, pmess, kbytes, ksource ) 1141 1155 !!---------------------------------------------------------------------- 1142 1156 !! *** routine mpprecv *** … … 1148 1162 INTEGER , INTENT(in ) :: kbytes ! suze of the array pmess 1149 1163 INTEGER , INTENT(in ) :: ktyp ! Tag of the recevied message 1164 INTEGER, OPTIONAL, INTENT(in) :: ksource ! source process number 1150 1165 !! 1151 1166 INTEGER :: istatus(mpi_status_size) 1152 1167 INTEGER :: iflag 1153 !!---------------------------------------------------------------------- 1154 ! 1155 CALL mpi_recv( pmess, kbytes, mpi_double_precision, mpi_any_source, ktyp, mpi_comm_opa, istatus, iflag ) 1168 INTEGER :: use_source 1169 !!---------------------------------------------------------------------- 1170 ! 1171 1172 ! If a specific process number has been passed to the receive call, 1173 ! use that one. Default is to use mpi_any_source 1174 use_source=mpi_any_source 1175 if(present(ksource)) then 1176 use_source=ksource 1177 end if 1178 1179 CALL mpi_recv( pmess, kbytes, mpi_double_precision, use_source, ktyp, mpi_comm_opa, istatus, iflag ) 1156 1180 ! 1157 1181 END SUBROUTINE mpprecv … … 1833 1857 IF( nbondi == -1 ) THEN 1834 1858 CALL mppsend( 2, t2we(1,1,1), imigr, noea, ml_req1 ) 1835 CALL mpprecv( 1, t2ew(1,1,2), imigr )1859 CALL mpprecv( 1, t2ew(1,1,2), imigr, noea ) 1836 1860 IF(l_isend) CALL mpi_wait( ml_req1, ml_stat, ml_err ) 1837 1861 ELSEIF( nbondi == 0 ) THEN 1838 1862 CALL mppsend( 1, t2ew(1,1,1), imigr, nowe, ml_req1 ) 1839 1863 CALL mppsend( 2, t2we(1,1,1), imigr, noea, ml_req2 ) 1840 CALL mpprecv( 1, t2ew(1,1,2), imigr )1841 CALL mpprecv( 2, t2we(1,1,2), imigr )1864 CALL mpprecv( 1, t2ew(1,1,2), imigr, noea ) 1865 CALL mpprecv( 2, t2we(1,1,2), imigr, nowe ) 1842 1866 IF(l_isend) CALL mpi_wait( ml_req1, ml_stat, ml_err ) 1843 1867 IF(l_isend) CALL mpi_wait( ml_req2, ml_stat, ml_err ) 1844 1868 ELSEIF( nbondi == 1 ) THEN 1845 1869 CALL mppsend( 1, t2ew(1,1,1), imigr, nowe, ml_req1 ) 1846 CALL mpprecv( 2, t2we(1,1,2), imigr )1870 CALL mpprecv( 2, t2we(1,1,2), imigr, nowe ) 1847 1871 IF(l_isend) CALL mpi_wait( ml_req1, ml_stat, ml_err ) 1848 1872 ENDIF … … 1879 1903 IF( nbondj == -1 ) THEN 1880 1904 CALL mppsend( 4, t2sn(1,1,1), imigr, nono, ml_req1 ) 1881 CALL mpprecv( 3, t2ns(1,1,2), imigr )1905 CALL mpprecv( 3, t2ns(1,1,2), imigr, nono ) 1882 1906 IF(l_isend) CALL mpi_wait( ml_req1, ml_stat, ml_err ) 1883 1907 ELSEIF( nbondj == 0 ) THEN 1884 1908 CALL mppsend( 3, t2ns(1,1,1), imigr, noso, ml_req1 ) 1885 1909 CALL mppsend( 4, t2sn(1,1,1), imigr, nono, ml_req2 ) 1886 CALL mpprecv( 3, t2ns(1,1,2), imigr )1887 CALL mpprecv( 4, t2sn(1,1,2), imigr )1910 CALL mpprecv( 3, t2ns(1,1,2), imigr, nono ) 1911 CALL mpprecv( 4, t2sn(1,1,2), imigr, noso ) 1888 1912 IF( l_isend ) CALL mpi_wait( ml_req1, ml_stat, ml_err ) 1889 1913 IF( l_isend ) CALL mpi_wait( ml_req2, ml_stat, ml_err ) 1890 1914 ELSEIF( nbondj == 1 ) THEN 1891 1915 CALL mppsend( 3, t2ns(1,1,1), imigr, noso, ml_req1 ) 1892 CALL mpprecv( 4, t2sn(1,1,2), imigr )1916 CALL mpprecv( 4, t2sn(1,1,2), imigr, noso) 1893 1917 IF( l_isend ) CALL mpi_wait( ml_req1, ml_stat, ml_err ) 1894 1918 ENDIF … … 2209 2233 INTEGER :: ierr, itaille, ildi, ilei, iilb 2210 2234 INTEGER :: ijpj, ijpjm1, ij, iproc 2235 INTEGER, DIMENSION (jpmaxngh) :: ml_req5 ! for mpi_isend when avoiding mpi_allgather 2236 INTEGER :: ml_err ! for mpi_isend when avoiding mpi_allgather 2237 INTEGER, DIMENSION(MPI_STATUS_SIZE) :: ml_stat ! for mpi_isend when avoiding mpi_allgather 2211 2238 !!---------------------------------------------------------------------- 2212 2239 ! 2213 2240 ijpj = 4 2241 ityp = -1 2214 2242 ijpjm1 = 3 2215 2243 ztab(:,:,:) = 0.e0 … … 2222 2250 ! ! Build in procs of ncomm_north the znorthgloio 2223 2251 itaille = jpi * jpk * ijpj 2224 CALL MPI_ALLGATHER( znorthloc , itaille, MPI_DOUBLE_PRECISION, & 2225 & znorthgloio, itaille, MPI_DOUBLE_PRECISION, ncomm_north, ierr ) 2252 IF ( l_north_nogather ) THEN 2253 ! 2254 ! Avoid the use of mpi_allgather by exchanging only with the processes already identified (in opa_northcomms) 2255 ! as being involved in this process' northern boundary exchange 2256 ! 2257 ! First put local values into the global arraay 2258 DO jj = nlcj-ijpj+1, nlcj 2259 ij = jj - nlcj + ijpj 2260 DO ji = 1, nlci 2261 ztab(ji+nimpp-1,ij,:) = pt3d(ji,jj,:) 2262 END DO 2263 END DO 2264 2265 ! 2266 ! Set the exchange type in order to access the correct list of active neighbours 2267 ! 2268 SELECT CASE ( cd_type ) 2269 CASE ( 'T' , 'W' ) 2270 ityp = 1 2271 CASE ( 'U' ) 2272 ityp = 2 2273 CASE ( 'V' ) 2274 ityp = 3 2275 CASE ( 'F' ) 2276 ityp = 4 2277 CASE ( 'I' ) 2278 ityp = 5 2279 CASE DEFAULT 2280 ! 2281 ! Set a default value for unsupported types which will cause a fallback to 2282 ! the mpi_allgather method 2283 ! 2284 ityp = -1 2285 END SELECT 2286 IF ( ityp .gt. 0 ) THEN 2287 2288 DO jr = 1,nsndto(ityp) 2289 CALL mppsend(5, znorthloc, itaille, isendto(jr,ityp), ml_req5(jr) ) 2290 END DO 2291 DO jr = 1,nsndto(ityp) 2292 CALL mpprecv(5, zfoldwk, itaille, isendto(jr,ityp)) 2293 iproc = isendto(jr,ityp) + 1 2294 ildi=nldit (iproc) 2295 ilei=nleit (iproc) 2296 iilb=nimppt(iproc) 2297 DO jj = 1, 4 2298 DO ji = ildi, ilei 2299 ztab(ji+iilb-1,jj,:) = zfoldwk(ji,jj,:) 2300 END DO 2301 END DO 2302 END DO 2303 IF(l_isend) THEN 2304 DO jr = 1,nsndto(ityp) 2305 CALL mpi_wait(ml_req5(jr), ml_stat, ml_err) 2306 END DO 2307 ENDIF 2308 2309 ENDIF 2310 2311 ENDIF 2312 2313 IF ( ityp .lt. 0 ) THEN 2314 CALL MPI_ALLGATHER( znorthloc , itaille, MPI_DOUBLE_PRECISION, & 2315 & znorthgloio, itaille, MPI_DOUBLE_PRECISION, ncomm_north, ierr ) 2226 2316 ! 2227 2317 ! ! recover the global north array 2228 DO jr = 1, ndim_rank_north 2229 iproc = nrank_north(jr) + 1 2230 ildi = nldit (iproc) 2231 ilei = nleit (iproc) 2232 iilb = nimppt(iproc) 2233 DO jj = 1, 4 2234 DO ji = ildi, ilei 2235 ztab(ji+iilb-1,jj,:) = znorthgloio(ji,jj,:,jr) 2318 DO jr = 1, ndim_rank_north 2319 iproc = nrank_north(jr) + 1 2320 ildi = nldit (iproc) 2321 ilei = nleit (iproc) 2322 iilb = nimppt(iproc) 2323 DO jj = 1, 4 2324 DO ji = ildi, ilei 2325 ztab(ji+iilb-1,jj,:) = znorthgloio(ji,jj,:,jr) 2326 END DO 2236 2327 END DO 2237 2328 END DO 2238 END DO 2329 ENDIF 2330 ! 2331 ! The ztab array has been either: 2332 ! a. Fully populated by the mpi_allgather operation or 2333 ! b. Had the active points for this domain and northern neighbours populated 2334 ! by peer to peer exchanges 2335 ! Either way the array may be folded by lbc_nfd and the result for the span of 2336 ! this domain will be identical. 2239 2337 ! 2240 2338 CALL lbc_nfd( ztab, cd_type, psgn ) ! North fold boundary condition … … 2272 2370 INTEGER :: ierr, itaille, ildi, ilei, iilb 2273 2371 INTEGER :: ijpj, ijpjm1, ij, iproc 2372 INTEGER, DIMENSION (jpmaxngh) :: ml_req5 ! for mpi_isend when avoiding mpi_allgather 2373 INTEGER :: ml_err ! for mpi_isend when avoiding mpi_allgather 2374 INTEGER, DIMENSION(MPI_STATUS_SIZE):: ml_stat ! for mpi_isend when avoiding mpi_allgather 2274 2375 !!---------------------------------------------------------------------- 2275 2376 ! 2276 2377 ijpj = 4 2378 ityp = -1 2277 2379 ijpjm1 = 3 2278 2380 ztab_2d(:,:) = 0.e0 … … 2285 2387 ! ! Build in procs of ncomm_north the znorthgloio_2d 2286 2388 itaille = jpi * ijpj 2287 CALL MPI_ALLGATHER( znorthloc_2d , itaille, MPI_DOUBLE_PRECISION, & 2288 & znorthgloio_2d, itaille, MPI_DOUBLE_PRECISION, ncomm_north, ierr ) 2289 ! 2290 DO jr = 1, ndim_rank_north ! recover the global north array 2291 iproc = nrank_north(jr) + 1 2292 ildi=nldit (iproc) 2293 ilei=nleit (iproc) 2294 iilb=nimppt(iproc) 2295 DO jj = 1, 4 2296 DO ji = ildi, ilei 2297 ztab_2d(ji+iilb-1,jj) = znorthgloio_2d(ji,jj,jr) 2389 IF ( l_north_nogather ) THEN 2390 ! 2391 ! Avoid the use of mpi_allgather by exchanging only with the processes already identified (in opa_northcomms) 2392 ! as being involved in this process' northern boundary exchange 2393 ! 2394 ! First put local values into the global array 2395 ! 2396 DO jj = nlcj-ijpj+1, nlcj 2397 ij = jj - nlcj + ijpj 2398 DO ji = 1, nlci 2399 ztab_2d(ji+nimpp-1,ij) = pt2d(ji,jj) 2400 END DO 2401 END DO 2402 2403 ! 2404 ! Set the exchange type in order to access the correct list of active neighbours 2405 ! 2406 SELECT CASE ( cd_type ) 2407 CASE ( 'T' , 'W' ) 2408 ityp = 1 2409 CASE ( 'U' ) 2410 ityp = 2 2411 CASE ( 'V' ) 2412 ityp = 3 2413 CASE ( 'F' ) 2414 ityp = 4 2415 CASE ( 'I' ) 2416 ityp = 5 2417 CASE DEFAULT 2418 ! 2419 ! Set a default value for unsupported types which will cause a fallback to 2420 ! the mpi_allgather method 2421 ! 2422 ityp = -1 2423 END SELECT 2424 2425 IF ( ityp .gt. 0 ) THEN 2426 2427 DO jr = 1,nsndto(ityp) 2428 CALL mppsend(5, znorthloc_2d, itaille, isendto(jr,ityp), ml_req5(jr) ) 2429 END DO 2430 DO jr = 1,nsndto(ityp) 2431 CALL mpprecv(5, zfoldwk_2d, itaille, isendto(jr,ityp)) 2432 iproc = isendto(jr,ityp) + 1 2433 ildi=nldit (iproc) 2434 ilei=nleit (iproc) 2435 iilb=nimppt(iproc) 2436 DO jj = 1, 4 2437 DO ji = ildi, ilei 2438 ztab_2d(ji+iilb-1,jj) = zfoldwk_2d(ji,jj) 2439 END DO 2298 2440 END DO 2299 END DO 2300 END DO 2441 END DO 2442 IF(l_isend) THEN 2443 DO jr = 1,nsndto(ityp) 2444 CALL mpi_wait(ml_req5(jr), ml_stat, ml_err) 2445 END DO 2446 ENDIF 2447 2448 ENDIF 2449 2450 ENDIF 2451 2452 IF ( ityp .lt. 0 ) THEN 2453 CALL MPI_ALLGATHER( znorthloc_2d , itaille, MPI_DOUBLE_PRECISION, & 2454 & znorthgloio_2d, itaille, MPI_DOUBLE_PRECISION, ncomm_north, ierr ) 2455 ! 2456 DO jr = 1, ndim_rank_north ! recover the global north array 2457 iproc = nrank_north(jr) + 1 2458 ildi=nldit (iproc) 2459 ilei=nleit (iproc) 2460 iilb=nimppt(iproc) 2461 DO jj = 1, 4 2462 DO ji = ildi, ilei 2463 ztab_2d(ji+iilb-1,jj) = znorthgloio_2d(ji,jj,jr) 2464 END DO 2465 END DO 2466 END DO 2467 ENDIF 2468 ! 2469 ! The ztab array has been either: 2470 ! a. Fully populated by the mpi_allgather operation or 2471 ! b. Had the active points for this domain and northern neighbours populated 2472 ! by peer to peer exchanges 2473 ! Either way the array may be folded by lbc_nfd and the result for the span of 2474 ! this domain will be identical. 2301 2475 ! 2302 2476 CALL lbc_nfd( ztab_2d, cd_type, psgn ) ! North fold boundary condition -
branches/2011/dev_r2855_NOCS_mppsca/NEMOGCM/NEMO/OPA_SRC/nemogcm.F90
r2715 r2882 291 291 CALL dom_cfg ! Domain configuration 292 292 CALL dom_init ! Domain 293 294 IF( ln_nnogather ) CALL nemo_northcomms ! Initialise the northfold neighbour lists (must be done after the masks are defined) 293 295 294 296 IF( ln_ctl ) CALL prt_ctl_init ! Print control … … 617 619 END SUBROUTINE factorise 618 620 621 SUBROUTINE nemo_northcomms 622 !!====================================================================== 623 !! *** ROUTINE nemo_northcomms *** 624 !! nemo_northcomms : Setup for north fold exchanges with explicit peer to peer messaging 625 !!===================================================================== 626 !!---------------------------------------------------------------------- 627 !! 628 !! ** Purpose : Initialization of the northern neighbours lists. 629 !!---------------------------------------------------------------------- 630 !! 1.0 ! 2011-10 (A. C. Coward, NOCS & J. Donners, PRACE) 631 !!---------------------------------------------------------------------- 632 633 INTEGER :: ji, jj, jk, ij, jtyp ! dummy loop indices 634 INTEGER :: ijpj ! number of rows involved in north-fold exchange 635 INTEGER :: northcomms_alloc ! allocate return status 636 REAL(wp), ALLOCATABLE, DIMENSION ( :,: ) :: znnbrs ! workspace 637 LOGICAL, ALLOCATABLE, DIMENSION ( : ) :: lrankset ! workspace 638 639 IF(lwp) WRITE(numout,*) 640 IF(lwp) WRITE(numout,*) 'nemo_northcomms : Initialization of the northern neighbours lists' 641 IF(lwp) WRITE(numout,*) '~~~~~~~~~~' 642 643 !!---------------------------------------------------------------------- 644 ALLOCATE( znnbrs(jpi,jpj), stat = northcomms_alloc ) 645 ALLOCATE( lrankset(jpnij), stat = northcomms_alloc ) 646 IF( northcomms_alloc /= 0 ) THEN 647 WRITE(numout,cform_war) 648 WRITE(numout,*) 'northcomms_alloc : failed to allocate arrays' 649 CALL ctl_stop( 'STOP', 'nemo_northcomms : unable to allocate temporary arrays' ) 650 ENDIF 651 nsndto = 0 652 isendto = -1 653 ijpj = 4 654 ! 655 ! This routine has been called because ln_nnogather has been set true ( nammpp ) 656 ! However, these first few exchanges have to use the mpi_allgather method to 657 ! establish the neighbour lists to use in subsequent peer to peer exchanges. 658 ! Consequently, set l_north_nogather to be false here and set it true only after 659 ! the lists have been established. 660 ! 661 l_north_nogather = .FALSE. 662 ! 663 ! Exchange and store ranks on northern rows 664 WRITE(numout,*) narea, njmppt(narea) , MAXVAL( njmppt ) ; FLUSH(numout) 665 666 DO jtyp = 1,4 667 668 lrankset = .FALSE. 669 znnbrs = narea 670 SELECT CASE (jtyp) 671 CASE(1) 672 ! 673 ! Type 1: T,W-points 674 ! 675 CALL lbc_lnk( znnbrs, 'T', 1. ) 676 CASE(2) 677 ! 678 ! Type 2: U-point 679 ! 680 CALL lbc_lnk( znnbrs, 'U', 1. ) 681 CASE(3) 682 ! 683 ! Type 3: V-point 684 ! 685 CALL lbc_lnk( znnbrs, 'V', 1. ) 686 CASE(4) 687 ! 688 ! Type 5: F-point 689 ! 690 CALL lbc_lnk( znnbrs, 'F', 1. ) 691 END SELECT 692 693 IF ( njmppt(narea) .eq. MAXVAL( njmppt )) THEN 694 do jj = nlcj-ijpj+1, nlcj 695 ij = jj - nlcj + ijpj 696 do ji = 1,jpi 697 if(int(znnbrs(ji,jj)) .ne. 0 .and. int(znnbrs(ji,jj)) .ne. narea ) & 698 & lrankset(int(znnbrs(ji,jj))) = .true. 699 end do 700 end do 701 702 do jj = 1,jpnij 703 IF (lrankset(jj)) THEN 704 nsndto(jtyp) = nsndto(jtyp) + 1 705 IF(nsndto(jtyp) .gt. jpmaxngh ) THEN 706 CALL ctl_stop( ' Too many neighbours in nemo_northcomms ', & 707 & ' jpmaxngh will need to be increased ') 708 ENDIF 709 isendto(nsndto(jtyp),jtyp) = jj-1 ! narea converted to MPI rank 710 ENDIF 711 end do 712 ENDIF 713 714 END DO 715 716 ! 717 ! Type 5: I-point 718 ! 719 ! ICE point exchanges may involve some averaging. The neighbours list is 720 ! built up using two exchanges to ensure that the whole stencil is covered. 721 ! lrankset should not be reset between these 'J' and 'K' point exchanges 722 723 jtyp = 5 724 lrankset = .FALSE. 725 znnbrs = narea 726 CALL lbc_lnk( znnbrs, 'J', 1. ) ! first ice U-V point 727 728 IF ( njmppt(narea) .eq. MAXVAL( njmppt )) THEN 729 do jj = nlcj-ijpj+1, nlcj 730 ij = jj - nlcj + ijpj 731 do ji = 1,jpi 732 if(int(znnbrs(ji,jj)) .ne. 0 .and. int(znnbrs(ji,jj)) .ne. narea ) & 733 & lrankset(int(znnbrs(ji,jj))) = .true. 734 end do 735 end do 736 ENDIF 737 738 znnbrs = narea 739 CALL lbc_lnk( znnbrs, 'K', 1. ) ! second ice U-V point 740 741 IF ( njmppt(narea) .eq. MAXVAL( njmppt )) THEN 742 do jj = nlcj-ijpj+1, nlcj 743 ij = jj - nlcj + ijpj 744 do ji = 1,jpi 745 if(int(znnbrs(ji,jj)) .ne. 0 .and. int(znnbrs(ji,jj)) .ne. narea ) & 746 & lrankset(int(znnbrs(ji,jj))) = .true. 747 end do 748 end do 749 750 do jj = 1,jpnij 751 IF (lrankset(jj)) THEN 752 nsndto(jtyp) = nsndto(jtyp) + 1 753 IF(nsndto(jtyp) .gt. jpmaxngh ) THEN 754 CALL ctl_stop( ' Too many neighbours in nemo_northcomms ', & 755 & ' jpmaxngh will need to be increased ') 756 ENDIF 757 isendto(nsndto(jtyp),jtyp) = jj-1 ! narea converted to MPI rank 758 ENDIF 759 end do 760 ! 761 ! For northern row areas, set l_north_nogather so that all subsequent exchanges can use 762 ! peer to peer communications at the north fold 763 ! 764 l_north_nogather = .TRUE. 765 ! 766 DO jtyp=1,5 767 write(numout,'(i4,a,2i4,a,8i5)') narea-1,' : ',jtyp,nsndto(jtyp),' ids ',(isendto(ij,jtyp),ij=1,nsndto(jtyp)) 768 END DO 769 CALL FLUSH(numout) 770 ENDIF 771 WRITE(numout,*) narea, ' l_north_nogather ',l_north_nogather; FLUSH(numout) 772 DEALLOCATE( znnbrs ) 773 DEALLOCATE( lrankset ) 774 775 END SUBROUTINE nemo_northcomms 619 776 !!====================================================================== 620 777 END MODULE nemogcm
Note: See TracChangeset
for help on using the changeset viewer.