Changeset 3009 for branches/2011/dev_NOC_2011_MERGE/NEMOGCM
- Timestamp:
- 2011-10-27T13:35:36+02:00 (13 years ago)
- Location:
- branches/2011/dev_NOC_2011_MERGE/NEMOGCM
- Files:
-
- 6 edited
-
CONFIG/GYRE/EXP00/namelist (modified) (1 diff)
-
CONFIG/ORCA2_LIM/EXP00/namelist (modified) (1 diff)
-
CONFIG/ORCA2_OFF_PISCES/EXP00/namelist (modified) (1 diff)
-
NEMO/OPA_SRC/LBC/lbcnfd.F90 (modified) (3 diffs)
-
NEMO/OPA_SRC/LBC/lib_mpp.F90 (modified) (21 diffs)
-
NEMO/OPA_SRC/nemogcm.F90 (modified) (2 diffs)
Legend:
- Unmodified
- Added
- Removed
-
branches/2011/dev_NOC_2011_MERGE/NEMOGCM/CONFIG/GYRE/EXP00/namelist
r2986 r3009 697 697 ! buffer blocking send or immediate non-blocking sends, resp. 698 698 nn_buffer = 0 ! size in bytes of exported buffer ('B' case), 0 no exportation 699 ln_nnogather= .false. ! activate code to avoid mpi_allgather use at the northfold 699 700 jpni = 0 ! jpni number of processors following i (set automatically if < 1) 700 701 jpnj = 0 ! jpnj number of processors following j (set automatically if < 1) -
branches/2011/dev_NOC_2011_MERGE/NEMOGCM/CONFIG/ORCA2_LIM/EXP00/namelist
r2986 r3009 697 697 ! buffer blocking send or immediate non-blocking sends, resp. 698 698 nn_buffer = 0 ! size in bytes of exported buffer ('B' case), 0 no exportation 699 ln_nnogather= .false. ! activate code to avoid mpi_allgather use at the northfold 699 700 jpni = 0 ! jpni number of processors following i (set automatically if < 1) 700 701 jpnj = 0 ! jpnj number of processors following j (set automatically if < 1) -
branches/2011/dev_NOC_2011_MERGE/NEMOGCM/CONFIG/ORCA2_OFF_PISCES/EXP00/namelist
r2986 r3009 711 711 ! buffer blocking send or immediate non-blocking sends, resp. 712 712 nn_buffer = 0 ! size in bytes of exported buffer ('B' case), 0 no exportation 713 ln_nnogather= .false. ! activate code to avoid mpi_allgather use at the northfold 713 714 jpni = 0 ! jpni number of processors following i (set automatically if < 1) 714 715 jpnj = 0 ! jpnj number of processors following j (set automatically if < 1) -
branches/2011/dev_NOC_2011_MERGE/NEMOGCM/NEMO/OPA_SRC/LBC/lbcnfd.F90
r2715 r3009 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_NOC_2011_MERGE/NEMOGCM/NEMO/OPA_SRC/LBC/lib_mpp.F90
r2731 r3009 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_req_nf ! 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 ) 2226 ! 2227 ! ! 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) 2252 IF ( l_north_nogather ) THEN 2253 ! 2254 ! Avoid the use of mpi_allgather by exchanging only with the processes already identified 2255 ! (in nemo_northcomms) as being involved in this process' northern boundary exchange 2256 ! 2257 DO jj = nlcj-ijpj+1, nlcj ! First put local values into the global array 2258 ij = jj - nlcj + ijpj 2259 DO ji = 1, nlci 2260 ztab(ji+nimpp-1,ij,:) = pt3d(ji,jj,:) 2236 2261 END DO 2237 2262 END DO 2238 END DO 2263 2264 ! 2265 ! Set the exchange type in order to access the correct list of active neighbours 2266 ! 2267 SELECT CASE ( cd_type ) 2268 CASE ( 'T' , 'W' ) 2269 ityp = 1 2270 CASE ( 'U' ) 2271 ityp = 2 2272 CASE ( 'V' ) 2273 ityp = 3 2274 CASE ( 'F' ) 2275 ityp = 4 2276 CASE ( 'I' ) 2277 ityp = 5 2278 CASE DEFAULT 2279 ityp = -1 ! Set a default value for unsupported types which 2280 ! will cause a fallback to the mpi_allgather method 2281 END SELECT 2282 IF ( ityp .gt. 0 ) THEN 2283 2284 DO jr = 1,nsndto(ityp) 2285 CALL mppsend(5, znorthloc, itaille, isendto(jr,ityp), ml_req_nf(jr) ) 2286 END DO 2287 DO jr = 1,nsndto(ityp) 2288 CALL mpprecv(5, zfoldwk, itaille, isendto(jr,ityp)) 2289 iproc = isendto(jr,ityp) + 1 2290 ildi = nldit (iproc) 2291 ilei = nleit (iproc) 2292 iilb = nimppt(iproc) 2293 DO jj = 1, ijpj 2294 DO ji = ildi, ilei 2295 ztab(ji+iilb-1,jj,:) = zfoldwk(ji,jj,:) 2296 END DO 2297 END DO 2298 END DO 2299 IF (l_isend) THEN 2300 DO jr = 1,nsndto(ityp) 2301 CALL mpi_wait(ml_req_nf(jr), ml_stat, ml_err) 2302 END DO 2303 ENDIF 2304 2305 ENDIF 2306 2307 ENDIF 2308 2309 IF ( ityp .lt. 0 ) THEN 2310 CALL MPI_ALLGATHER( znorthloc , itaille, MPI_DOUBLE_PRECISION, & 2311 & znorthgloio, itaille, MPI_DOUBLE_PRECISION, ncomm_north, ierr ) 2312 ! 2313 DO jr = 1, ndim_rank_north ! recover the global north array 2314 iproc = nrank_north(jr) + 1 2315 ildi = nldit (iproc) 2316 ilei = nleit (iproc) 2317 iilb = nimppt(iproc) 2318 DO jj = 1, ijpj 2319 DO ji = ildi, ilei 2320 ztab(ji+iilb-1,jj,:) = znorthgloio(ji,jj,:,jr) 2321 END DO 2322 END DO 2323 END DO 2324 ENDIF 2325 ! 2326 ! The ztab array has been either: 2327 ! a. Fully populated by the mpi_allgather operation or 2328 ! b. Had the active points for this domain and northern neighbours populated 2329 ! by peer to peer exchanges 2330 ! Either way the array may be folded by lbc_nfd and the result for the span of 2331 ! this domain will be identical. 2239 2332 ! 2240 2333 CALL lbc_nfd( ztab, cd_type, psgn ) ! North fold boundary condition … … 2272 2365 INTEGER :: ierr, itaille, ildi, ilei, iilb 2273 2366 INTEGER :: ijpj, ijpjm1, ij, iproc 2367 INTEGER, DIMENSION (jpmaxngh) :: ml_req_nf ! for mpi_isend when avoiding mpi_allgather 2368 INTEGER :: ml_err ! for mpi_isend when avoiding mpi_allgather 2369 INTEGER, DIMENSION(MPI_STATUS_SIZE):: ml_stat ! for mpi_isend when avoiding mpi_allgather 2274 2370 !!---------------------------------------------------------------------- 2275 2371 ! 2276 2372 ijpj = 4 2373 ityp = -1 2277 2374 ijpjm1 = 3 2278 2375 ztab_2d(:,:) = 0.e0 … … 2285 2382 ! ! Build in procs of ncomm_north the znorthgloio_2d 2286 2383 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) 2384 IF ( l_north_nogather ) THEN 2385 ! 2386 ! Avoid the use of mpi_allgather by exchanging only with the processes already identified 2387 ! (in nemo_northcomms) as being involved in this process' northern boundary exchange 2388 ! 2389 DO jj = nlcj-ijpj+1, nlcj ! First put local values into the global array 2390 ij = jj - nlcj + ijpj 2391 DO ji = 1, nlci 2392 ztab_2d(ji+nimpp-1,ij) = pt2d(ji,jj) 2298 2393 END DO 2299 2394 END DO 2300 END DO 2395 2396 ! 2397 ! Set the exchange type in order to access the correct list of active neighbours 2398 ! 2399 SELECT CASE ( cd_type ) 2400 CASE ( 'T' , 'W' ) 2401 ityp = 1 2402 CASE ( 'U' ) 2403 ityp = 2 2404 CASE ( 'V' ) 2405 ityp = 3 2406 CASE ( 'F' ) 2407 ityp = 4 2408 CASE ( 'I' ) 2409 ityp = 5 2410 CASE DEFAULT 2411 ityp = -1 ! Set a default value for unsupported types which 2412 ! will cause a fallback to the mpi_allgather method 2413 END SELECT 2414 2415 IF ( ityp .gt. 0 ) THEN 2416 2417 DO jr = 1,nsndto(ityp) 2418 CALL mppsend(5, znorthloc_2d, itaille, isendto(jr,ityp), ml_req_nf(jr) ) 2419 END DO 2420 DO jr = 1,nsndto(ityp) 2421 CALL mpprecv(5, zfoldwk_2d, itaille, isendto(jr,ityp)) 2422 iproc = isendto(jr,ityp) + 1 2423 ildi = nldit (iproc) 2424 ilei = nleit (iproc) 2425 iilb = nimppt(iproc) 2426 DO jj = 1, ijpj 2427 DO ji = ildi, ilei 2428 ztab_2d(ji+iilb-1,jj) = zfoldwk_2d(ji,jj) 2429 END DO 2430 END DO 2431 END DO 2432 IF (l_isend) THEN 2433 DO jr = 1,nsndto(ityp) 2434 CALL mpi_wait(ml_req_nf(jr), ml_stat, ml_err) 2435 END DO 2436 ENDIF 2437 2438 ENDIF 2439 2440 ENDIF 2441 2442 IF ( ityp .lt. 0 ) THEN 2443 CALL MPI_ALLGATHER( znorthloc_2d , itaille, MPI_DOUBLE_PRECISION, & 2444 & znorthgloio_2d, itaille, MPI_DOUBLE_PRECISION, ncomm_north, ierr ) 2445 ! 2446 DO jr = 1, ndim_rank_north ! recover the global north array 2447 iproc = nrank_north(jr) + 1 2448 ildi = nldit (iproc) 2449 ilei = nleit (iproc) 2450 iilb = nimppt(iproc) 2451 DO jj = 1, ijpj 2452 DO ji = ildi, ilei 2453 ztab_2d(ji+iilb-1,jj) = znorthgloio_2d(ji,jj,jr) 2454 END DO 2455 END DO 2456 END DO 2457 ENDIF 2458 ! 2459 ! The ztab array has been either: 2460 ! a. Fully populated by the mpi_allgather operation or 2461 ! b. Had the active points for this domain and northern neighbours populated 2462 ! by peer to peer exchanges 2463 ! Either way the array may be folded by lbc_nfd and the result for the span of 2464 ! this domain will be identical. 2301 2465 ! 2302 2466 CALL lbc_nfd( ztab_2d, cd_type, psgn ) ! North fold boundary condition -
branches/2011/dev_NOC_2011_MERGE/NEMOGCM/NEMO/OPA_SRC/nemogcm.F90
r2986 r3009 293 293 CALL dom_init ! Domain 294 294 295 IF( ln_nnogather ) CALL nemo_northcomms ! Initialise the northfold neighbour lists (must be done after the masks are defined) 296 295 297 IF( ln_ctl ) CALL prt_ctl_init ! Print control 296 298 … … 622 624 END SUBROUTINE factorise 623 625 626 SUBROUTINE nemo_northcomms 627 !!====================================================================== 628 !! *** ROUTINE nemo_northcomms *** 629 !! nemo_northcomms : Setup for north fold exchanges with explicit peer to peer messaging 630 !!===================================================================== 631 !!---------------------------------------------------------------------- 632 !! 633 !! ** Purpose : Initialization of the northern neighbours lists. 634 !!---------------------------------------------------------------------- 635 !! 1.0 ! 2011-10 (A. C. Coward, NOCS & J. Donners, PRACE) 636 !!---------------------------------------------------------------------- 637 638 INTEGER :: ji, jj, jk, ij, jtyp ! dummy loop indices 639 INTEGER :: ijpj ! number of rows involved in north-fold exchange 640 INTEGER :: northcomms_alloc ! allocate return status 641 REAL(wp), ALLOCATABLE, DIMENSION ( :,: ) :: znnbrs ! workspace 642 LOGICAL, ALLOCATABLE, DIMENSION ( : ) :: lrankset ! workspace 643 644 IF(lwp) WRITE(numout,*) 645 IF(lwp) WRITE(numout,*) 'nemo_northcomms : Initialization of the northern neighbours lists' 646 IF(lwp) WRITE(numout,*) '~~~~~~~~~~' 647 648 !!---------------------------------------------------------------------- 649 ALLOCATE( znnbrs(jpi,jpj), stat = northcomms_alloc ) 650 ALLOCATE( lrankset(jpnij), stat = northcomms_alloc ) 651 IF( northcomms_alloc /= 0 ) THEN 652 WRITE(numout,cform_war) 653 WRITE(numout,*) 'northcomms_alloc : failed to allocate arrays' 654 CALL ctl_stop( 'STOP', 'nemo_northcomms : unable to allocate temporary arrays' ) 655 ENDIF 656 nsndto = 0 657 isendto = -1 658 ijpj = 4 659 ! 660 ! This routine has been called because ln_nnogather has been set true ( nammpp ) 661 ! However, these first few exchanges have to use the mpi_allgather method to 662 ! establish the neighbour lists to use in subsequent peer to peer exchanges. 663 ! Consequently, set l_north_nogather to be false here and set it true only after 664 ! the lists have been established. 665 ! 666 l_north_nogather = .FALSE. 667 ! 668 ! Exchange and store ranks on northern rows 669 670 DO jtyp = 1,4 671 672 lrankset = .FALSE. 673 znnbrs = narea 674 SELECT CASE (jtyp) 675 CASE(1) 676 CALL lbc_lnk( znnbrs, 'T', 1. ) ! Type 1: T,W-points 677 CASE(2) 678 CALL lbc_lnk( znnbrs, 'U', 1. ) ! Type 2: U-point 679 CASE(3) 680 CALL lbc_lnk( znnbrs, 'V', 1. ) ! Type 3: V-point 681 CASE(4) 682 CALL lbc_lnk( znnbrs, 'F', 1. ) ! Type 4: F-point 683 END SELECT 684 685 IF ( njmppt(narea) .EQ. MAXVAL( njmppt ) ) THEN 686 DO jj = nlcj-ijpj+1, nlcj 687 ij = jj - nlcj + ijpj 688 DO ji = 1,jpi 689 IF ( INT(znnbrs(ji,jj)) .NE. 0 .AND. INT(znnbrs(ji,jj)) .NE. narea ) & 690 & lrankset(INT(znnbrs(ji,jj))) = .true. 691 END DO 692 END DO 693 694 DO jj = 1,jpnij 695 IF ( lrankset(jj) ) THEN 696 nsndto(jtyp) = nsndto(jtyp) + 1 697 IF ( nsndto(jtyp) .GT. jpmaxngh ) THEN 698 CALL ctl_stop( ' Too many neighbours in nemo_northcomms ', & 699 & ' jpmaxngh will need to be increased ') 700 ENDIF 701 isendto(nsndto(jtyp),jtyp) = jj-1 ! narea converted to MPI rank 702 ENDIF 703 END DO 704 ENDIF 705 706 END DO 707 708 ! 709 ! Type 5: I-point 710 ! 711 ! ICE point exchanges may involve some averaging. The neighbours list is 712 ! built up using two exchanges to ensure that the whole stencil is covered. 713 ! lrankset should not be reset between these 'J' and 'K' point exchanges 714 715 jtyp = 5 716 lrankset = .FALSE. 717 znnbrs = narea 718 CALL lbc_lnk( znnbrs, 'J', 1. ) ! first ice U-V point 719 720 IF ( njmppt(narea) .EQ. MAXVAL( njmppt ) ) THEN 721 DO jj = nlcj-ijpj+1, nlcj 722 ij = jj - nlcj + ijpj 723 DO ji = 1,jpi 724 IF ( INT(znnbrs(ji,jj)) .NE. 0 .AND. INT(znnbrs(ji,jj)) .NE. narea ) & 725 & lrankset(INT(znnbrs(ji,jj))) = .true. 726 END DO 727 END DO 728 ENDIF 729 730 znnbrs = narea 731 CALL lbc_lnk( znnbrs, 'K', 1. ) ! second ice U-V point 732 733 IF ( njmppt(narea) .EQ. MAXVAL( njmppt )) THEN 734 DO jj = nlcj-ijpj+1, nlcj 735 ij = jj - nlcj + ijpj 736 DO ji = 1,jpi 737 IF ( INT(znnbrs(ji,jj)) .NE. 0 .AND. INT(znnbrs(ji,jj)) .NE. narea ) & 738 & lrankset( INT(znnbrs(ji,jj))) = .true. 739 END DO 740 END DO 741 742 DO jj = 1,jpnij 743 IF ( lrankset(jj) ) THEN 744 nsndto(jtyp) = nsndto(jtyp) + 1 745 IF ( nsndto(jtyp) .GT. jpmaxngh ) THEN 746 CALL ctl_stop( ' Too many neighbours in nemo_northcomms ', & 747 & ' jpmaxngh will need to be increased ') 748 ENDIF 749 isendto(nsndto(jtyp),jtyp) = jj-1 ! narea converted to MPI rank 750 ENDIF 751 END DO 752 ! 753 ! For northern row areas, set l_north_nogather so that all subsequent exchanges 754 ! can use peer to peer communications at the north fold 755 ! 756 l_north_nogather = .TRUE. 757 ! 758 ENDIF 759 DEALLOCATE( znnbrs ) 760 DEALLOCATE( lrankset ) 761 762 END SUBROUTINE nemo_northcomms 624 763 !!====================================================================== 625 764 END MODULE nemogcm
Note: See TracChangeset
for help on using the changeset viewer.
