Changeset 4021 for branches/2013/dev_r3948_CMCC_NorthFold_Opt
- Timestamp:
- 2013-09-10T15:40:28+02:00 (11 years ago)
- Location:
- branches/2013/dev_r3948_CMCC_NorthFold_Opt/NEMOGCM
- Files:
-
- 1 added
- 5 edited
Legend:
- Unmodified
- Added
- Removed
-
branches/2013/dev_r3948_CMCC_NorthFold_Opt/NEMOGCM/CONFIG/cfg.txt
r3905 r4021 9 9 ORCA2_OFF_PISCES OPA_SRC OFF_SRC TOP_SRC 10 10 ORCA2_LIM_PISCES OPA_SRC LIM_SRC_2 NST_SRC TOP_SRC 11 GYRE_TEST OPA_SRC -
branches/2013/dev_r3948_CMCC_NorthFold_Opt/NEMOGCM/NEMO/OPA_SRC/LBC/lbclnk.F90
r3768 r4021 283 283 END SUBROUTINE lbc_lnk_3d 284 284 285 SUBROUTINE lbc_bdy_lnk_3d( pt3d, cd_type, psgn, ib_bdy )286 !!---------------------------------------------------------------------287 !! *** ROUTINE lbc_bdy_lnk ***288 !!289 !! ** Purpose : wrapper rountine to 'lbc_lnk_3d'. This wrapper is used290 !! to maintain the same interface with regards to the mpp case291 !!292 !!----------------------------------------------------------------------293 CHARACTER(len=1) , INTENT(in ) :: cd_type ! nature of pt3d grid-points294 REAL(wp), DIMENSION(jpi,jpj,jpk), INTENT(inout) :: pt3d ! 3D array on which the lbc is applied295 REAL(wp) , INTENT(in ) :: psgn ! control of the sign296 INTEGER :: ib_bdy ! BDY boundary set297 !!298 CALL lbc_lnk_3d( pt3d, cd_type, psgn)299 300 END SUBROUTINE lbc_bdy_lnk_3d301 302 SUBROUTINE lbc_bdy_lnk_2d( pt2d, cd_type, psgn, ib_bdy )303 !!---------------------------------------------------------------------304 !! *** ROUTINE lbc_bdy_lnk ***305 !!306 !! ** Purpose : wrapper rountine to 'lbc_lnk_3d'. This wrapper is used307 !! to maintain the same interface with regards to the mpp case308 !!309 !!----------------------------------------------------------------------310 CHARACTER(len=1) , INTENT(in ) :: cd_type ! nature of pt3d grid-points311 REAL(wp), DIMENSION(jpi,jpj), INTENT(inout) :: pt2d ! 3D array on which the lbc is applied312 REAL(wp) , INTENT(in ) :: psgn ! control of the sign313 INTEGER :: ib_bdy ! BDY boundary set314 !!315 CALL lbc_lnk_2d( pt2d, cd_type, psgn)316 317 END SUBROUTINE lbc_bdy_lnk_2d318 319 285 SUBROUTINE lbc_lnk_2d( pt2d, cd_type, psgn, cd_mpp, pval ) 320 286 !!--------------------------------------------------------------------- … … 406 372 END SUBROUTINE lbc_lnk_2d 407 373 374 #endif 375 376 377 SUBROUTINE lbc_bdy_lnk_3d( pt3d, cd_type, psgn, ib_bdy ) 378 !!--------------------------------------------------------------------- 379 !! *** ROUTINE lbc_bdy_lnk *** 380 !! 381 !! ** Purpose : wrapper rountine to 'lbc_lnk_3d'. This wrapper is used 382 !! to maintain the same interface with regards to the mpp 383 !case 384 !! 385 !!---------------------------------------------------------------------- 386 CHARACTER(len=1) , INTENT(in ) :: cd_type ! nature of pt3d grid-points 387 REAL(wp), DIMENSION(jpi,jpj,jpk), INTENT(inout) :: pt3d ! 3D array on which the lbc is applied 388 REAL(wp) , INTENT(in ) :: psgn ! control of the sign 389 INTEGER :: ib_bdy ! BDY boundary set 390 !! 391 CALL lbc_lnk_3d( pt3d, cd_type, psgn) 392 393 END SUBROUTINE lbc_bdy_lnk_3d 394 395 SUBROUTINE lbc_bdy_lnk_2d( pt2d, cd_type, psgn, ib_bdy ) 396 !!--------------------------------------------------------------------- 397 !! *** ROUTINE lbc_bdy_lnk *** 398 !! 399 !! ** Purpose : wrapper rountine to 'lbc_lnk_3d'. This wrapper is used 400 !! to maintain the same interface with regards to the mpp 401 !case 402 !! 403 !!---------------------------------------------------------------------- 404 CHARACTER(len=1) , INTENT(in ) :: cd_type ! nature of pt3d grid-points 405 REAL(wp), DIMENSION(jpi,jpj), INTENT(inout) :: pt2d ! 3D array on which the lbc is applied 406 REAL(wp) , INTENT(in ) :: psgn ! control of the sign 407 INTEGER :: ib_bdy ! BDY boundary set 408 !! 409 CALL lbc_lnk_2d( pt2d, cd_type, psgn) 410 411 END SUBROUTINE lbc_bdy_lnk_2d 412 413 408 414 SUBROUTINE lbc_lnk_2d_e( pt2d, cd_type, psgn, jpri, jprj ) 409 415 !!--------------------------------------------------------------------- … … 430 436 END SUBROUTINE lbc_lnk_2d_e 431 437 432 # endif433 438 #endif 434 439 -
branches/2013/dev_r3948_CMCC_NorthFold_Opt/NEMOGCM/NEMO/OPA_SRC/LBC/lbcnfd.F90
r3294 r4021 5 5 !!====================================================================== 6 6 !! History : 3.2 ! 2009-03 (R. Benshila) Original code 7 !! 3.5 ! 2013-07 (I. Epicoco, S. Mocavero - CMCC) MPP optimization 7 8 !!---------------------------------------------------------------------- 8 9 … … 11 12 !! lbc_nfd_3d : lateral boundary condition: North fold treatment for a 3D arrays (lbc_nfd) 12 13 !! lbc_nfd_2d : lateral boundary condition: North fold treatment for a 2D arrays (lbc_nfd) 14 !! mpp_lbc_nfd_3d : North fold treatment for a 3D arrays optimized for MPP 15 !! mpp_lbc_nfd_2d : North fold treatment for a 2D arrays optimized for MPP 13 16 !!---------------------------------------------------------------------- 14 17 USE dom_oce ! ocean space and time domain … … 23 26 24 27 PUBLIC lbc_nfd ! north fold conditions 28 INTERFACE mpp_lbc_nfd 29 MODULE PROCEDURE mpp_lbc_nfd_3d, mpp_lbc_nfd_2d 30 END INTERFACE 31 32 PUBLIC mpp_lbc_nfd ! north fold conditions in parallel case 33 34 INTEGER, PUBLIC, PARAMETER :: jpmaxngh = 3 35 INTEGER, PUBLIC :: nsndto 36 INTEGER, PUBLIC, DIMENSION (jpmaxngh) :: isendto ! processes to which communicate 37 38 25 39 26 40 !!---------------------------------------------------------------------- … … 342 356 END SUBROUTINE lbc_nfd_2d 343 357 344 !!====================================================================== 358 359 SUBROUTINE mpp_lbc_nfd_3d( pt3dl, pt3dr, cd_type, psgn ) 360 !!---------------------------------------------------------------------- 361 !! *** routine mpp_lbc_nfd_3d *** 362 !! 363 !! ** Purpose : 3D lateral boundary condition : North fold treatment 364 !! without processor exchanges. 365 !! 366 !! ** Method : 367 !! 368 !! ** Action : pt3d with updated values along the north fold 369 !!---------------------------------------------------------------------- 370 CHARACTER(len=1) , INTENT(in ) :: cd_type ! define the nature of ptab array grid-points 371 ! ! = T , U , V , F , W points 372 REAL(wp) , INTENT(in ) :: psgn ! control of the sign change 373 ! ! = -1. , the sign is changed if north fold boundary 374 ! ! = 1. , the sign is kept if north fold boundary 375 REAL(wp), DIMENSION(:,:,:), INTENT(inout) :: pt3dl ! 3D array on which the boundary condition is applied 376 REAL(wp), DIMENSION(:,:,:), INTENT(in) :: pt3dr ! 3D array on which the boundary condition is applied 377 ! 378 INTEGER :: ji, jk 379 INTEGER :: ijt, iju, ijpj, ijpjm1, ijta, ijua, jia, startloop, endloop 380 !!---------------------------------------------------------------------- 381 382 SELECT CASE ( jpni ) 383 CASE ( 1 ) ; ijpj = nlcj ! 1 proc only along the i-direction 384 CASE DEFAULT ; ijpj = 4 ! several proc along the i-direction 385 END SELECT 386 ijpjm1 = ijpj-1 387 388 ! 389 SELECT CASE ( npolj ) 390 ! 391 CASE ( 3 , 4 ) ! * North fold T-point pivot 392 ! 393 SELECT CASE ( cd_type ) 394 CASE ( 'T' , 'W' ) ! T-, W-point 395 IF (narea .ne. (jpnij - jpni + 1)) THEN 396 startloop = 1 397 ELSE 398 startloop = 2 399 ENDIF 400 401 DO jk = 1, jpk 402 DO ji = startloop, nlci 403 ijt = jpiglo - ji - nimpp - nimppt(isendto(1)) + 4 404 pt3dl(ji,ijpj,jk) = psgn * pt3dr(ijt,ijpj-2,jk) 405 END DO 406 END DO 407 408 IF(nimpp .ge. (jpiglo/2+1)) THEN 409 startloop = 1 410 ELSEIF(((nimpp+nlci-1) .ge. (jpiglo/2+1)) .AND. (nimpp .lt. (jpiglo/2+1))) THEN 411 startloop = jpiglo/2+1 - nimpp + 1 412 ELSE 413 startloop = nlci + 1 414 ENDIF 415 IF(startloop .le. nlci) THEN 416 DO jk = 1, jpk 417 DO ji = startloop, nlci 418 ijt = jpiglo - ji - nimpp - nimppt(isendto(1)) + 4 419 jia = ji + nimpp - 1 420 ijta = jpiglo - jia + 2 421 IF((ijta .ge. (startloop + nimpp - 1)) .and. (ijta .lt. jia)) THEN 422 pt3dl(ji,ijpjm1,jk) = psgn * pt3dl(ijta-nimpp+1,ijpjm1,jk) 423 ELSE 424 pt3dl(ji,ijpjm1,jk) = psgn * pt3dr(ijt,ijpjm1,jk) 425 ENDIF 426 END DO 427 END DO 428 ENDIF 429 430 431 432 CASE ( 'U' ) ! U-point 433 IF (narea .ne. (jpnij)) THEN 434 endloop = nlci 435 ELSE 436 endloop = nlci - 1 437 ENDIF 438 DO jk = 1, jpk 439 DO ji = 1, endloop 440 iju = jpiglo - ji - nimpp - nimppt(isendto(1)) + 3 441 pt3dl(ji,ijpj,jk) = psgn * pt3dr(iju,ijpj-2,jk) 442 END DO 443 END DO 444 445 IF (narea .ne. (jpnij)) THEN 446 endloop = nlci 447 ELSE 448 endloop = nlci - 1 449 ENDIF 450 IF(nimpp .ge. (jpiglo/2)) THEN 451 startloop = 1 452 ELSEIF(((nimpp+nlci-1) .ge. (jpiglo/2)) .AND. (nimpp .lt. (jpiglo/2))) THEN 453 startloop = jpiglo/2 - nimpp + 1 454 ELSE 455 startloop = endloop + 1 456 ENDIF 457 IF (startloop .le. endloop) THEN 458 DO jk = 1, jpk 459 DO ji = startloop, endloop 460 iju = jpiglo - ji - nimpp - nimppt(isendto(1)) + 3 461 jia = ji + nimpp - 1 462 ijua = jpiglo - jia + 1 463 IF((ijua .ge. (startloop + nimpp - 1)) .and. (ijua .lt. jia)) THEN 464 pt3dl(ji,ijpjm1,jk) = psgn * pt3dl(ijua-nimpp+1,ijpjm1,jk) 465 ELSE 466 pt3dl(ji,ijpjm1,jk) = psgn * pt3dr(iju,ijpjm1,jk) 467 ENDIF 468 END DO 469 END DO 470 ENDIF 471 472 CASE ( 'V' ) ! V-point 473 IF (narea .ne. (jpnij - jpni + 1)) THEN 474 startloop = 1 475 ELSE 476 startloop = 2 477 ENDIF 478 DO jk = 1, jpk 479 DO ji = startloop, nlci 480 ijt = jpiglo - ji - nimpp - nimppt(isendto(1)) + 4 481 pt3dl(ji,ijpj-1,jk) = psgn * pt3dr(ijt,ijpj-2,jk) 482 pt3dl(ji,ijpj ,jk) = psgn * pt3dr(ijt,ijpj-3,jk) 483 END DO 484 END DO 485 CASE ( 'F' ) ! F-point 486 IF (narea .ne. (jpnij)) THEN 487 endloop = nlci 488 ELSE 489 endloop = nlci - 1 490 ENDIF 491 DO jk = 1, jpk 492 DO ji = 1, endloop 493 iju = jpiglo - ji - nimpp - nimppt(isendto(1)) + 3 494 pt3dl(ji,ijpj-1,jk) = psgn * pt3dr(iju,ijpj-2,jk) 495 pt3dl(ji,ijpj ,jk) = psgn * pt3dr(iju,ijpj-3,jk) 496 END DO 497 END DO 498 END SELECT 499 ! 500 501 CASE ( 5 , 6 ) ! * North fold F-point pivot 502 ! 503 SELECT CASE ( cd_type ) 504 CASE ( 'T' , 'W' ) ! T-, W-point 505 DO jk = 1, jpk 506 DO ji = 1, nlci 507 ijt = jpiglo - ji - nimpp - nimppt(isendto(1)) + 3 508 pt3dl(ji,ijpj,jk) = psgn * pt3dr(ijt,ijpj-1,jk) 509 END DO 510 END DO 511 512 CASE ( 'U' ) ! U-point 513 IF (narea .ne. (jpnij)) THEN 514 endloop = nlci 515 ELSE 516 endloop = nlci - 1 517 ENDIF 518 DO jk = 1, jpk 519 DO ji = 1, endloop 520 iju = jpiglo - ji - nimpp - nimppt(isendto(1)) + 2 521 pt3dl(ji,ijpj,jk) = psgn * pt3dr(iju,ijpj-1,jk) 522 END DO 523 END DO 524 525 CASE ( 'V' ) ! V-point 526 DO jk = 1, jpk 527 DO ji = 1, nlci 528 ijt = jpiglo - ji- nimpp - nimppt(isendto(1)) + 3 529 pt3dl(ji,ijpj,jk) = psgn * pt3dr(ijt,ijpj-2,jk) 530 END DO 531 END DO 532 533 IF(nimpp .ge. (jpiglo/2+1)) THEN 534 startloop = 1 535 ELSEIF(((nimpp+nlci-1) .ge. (jpiglo/2+1)) .AND. (nimpp .lt. (jpiglo/2+1))) THEN 536 startloop = jpiglo/2+1 - nimpp + 1 537 ELSE 538 startloop = nlci + 1 539 ENDIF 540 IF(startloop .le. nlci) THEN 541 DO jk = 1, jpk 542 DO ji = startloop, nlci 543 ijt = jpiglo - ji - nimpp - nimppt(isendto(1)) + 3 544 pt3dl(ji,ijpjm1,jk) = psgn * pt3dr(ijt,ijpjm1,jk) 545 END DO 546 END DO 547 ENDIF 548 549 CASE ( 'F' ) ! F-point 550 IF (narea .ne. (jpnij)) THEN 551 endloop = nlci 552 ELSE 553 endloop = nlci - 1 554 ENDIF 555 DO jk = 1, jpk 556 DO ji = 1, endloop 557 iju = jpiglo - ji - nimpp - nimppt(isendto(1)) + 2 558 pt3dl(ji,ijpj ,jk) = psgn * pt3dr(iju,ijpj-2,jk) 559 END DO 560 END DO 561 562 IF (narea .ne. (jpnij)) THEN 563 endloop = nlci 564 ELSE 565 endloop = nlci - 1 566 ENDIF 567 IF(nimpp .ge. (jpiglo/2+1)) THEN 568 startloop = 1 569 ELSEIF(((nimpp+nlci-1) .ge. (jpiglo/2+1)) .AND. (nimpp .lt. (jpiglo/2+1))) THEN 570 startloop = jpiglo/2+1 - nimpp + 1 571 ELSE 572 startloop = endloop + 1 573 ENDIF 574 IF (startloop .le. endloop) THEN 575 DO jk = 1, jpk 576 DO ji = startloop, endloop 577 iju = jpiglo - ji - nimpp - nimppt(isendto(1)) + 2 578 pt3dl(ji,ijpjm1,jk) = psgn * pt3dr(iju,ijpjm1,jk) 579 END DO 580 END DO 581 ENDIF 582 583 END SELECT 584 585 CASE DEFAULT ! * closed : the code probably never go through 586 ! 587 SELECT CASE ( cd_type) 588 CASE ( 'T' , 'U' , 'V' , 'W' ) ! T-, U-, V-, W-points 589 pt3dl(:, 1 ,jk) = 0.e0 590 pt3dl(:,ijpj,jk) = 0.e0 591 CASE ( 'F' ) ! F-point 592 pt3dl(:,ijpj,jk) = 0.e0 593 END SELECT 594 ! 595 END SELECT ! npolj 596 ! 597 ! 598 END SUBROUTINE mpp_lbc_nfd_3d 599 600 601 SUBROUTINE mpp_lbc_nfd_2d( pt2dl, pt2dr, cd_type, psgn ) 602 !!---------------------------------------------------------------------- 603 !! *** routine mpp_lbc_nfd_2d *** 604 !! 605 !! ** Purpose : 2D lateral boundary condition : North fold treatment 606 !! without processor exchanges. 607 !! 608 !! ** Method : 609 !! 610 !! ** Action : pt2d with updated values along the north fold 611 !!---------------------------------------------------------------------- 612 CHARACTER(len=1) , INTENT(in ) :: cd_type ! define the nature of ptab array grid-points 613 ! ! = T , U , V , F , W points 614 REAL(wp) , INTENT(in ) :: psgn ! control of the sign change 615 ! ! = -1. , the sign is changed if north fold boundary 616 ! ! = 1. , the sign is kept if north fold boundary 617 REAL(wp), DIMENSION(:,:), INTENT(inout) :: pt2dl ! 2D array on which the boundary condition is applied 618 REAL(wp), DIMENSION(:,:), INTENT(in) :: pt2dr ! 2D array on which the boundary condition is applied 619 ! 620 INTEGER :: ji 621 INTEGER :: ijt, iju, ijpj, ijpjm1, ijta, ijua, jia, startloop, endloop 622 !!---------------------------------------------------------------------- 623 624 SELECT CASE ( jpni ) 625 CASE ( 1 ) ; ijpj = nlcj ! 1 proc only along the i-direction 626 CASE DEFAULT ; ijpj = 4 ! several proc along the i-direction 627 END SELECT 628 ! 629 ijpjm1 = ijpj-1 630 631 632 SELECT CASE ( npolj ) 633 ! 634 CASE ( 3, 4 ) ! * North fold T-point pivot 635 ! 636 SELECT CASE ( cd_type ) 637 ! 638 CASE ( 'T' , 'W' ) ! T- , W-points 639 IF (narea .ne. (jpnij - jpni + 1)) THEN 640 startloop = 1 641 ELSE 642 startloop = 2 643 ENDIF 644 DO ji = startloop, nlci 645 ijt=jpiglo - ji - nimpp - nimppt(isendto(1)) + 4 646 pt2dl(ji,ijpj) = psgn * pt2dr(ijt,ijpjm1-1) 647 END DO 648 649 IF(nimpp .ge. (jpiglo/2+1)) THEN 650 startloop = 1 651 ELSEIF(((nimpp+nlci-1) .ge. (jpiglo/2+1)) .AND. (nimpp .lt. (jpiglo/2+1))) THEN 652 startloop = jpiglo/2+1 - nimpp + 1 653 ELSE 654 startloop = nlci + 1 655 ENDIF 656 DO ji = startloop, nlci 657 ijt=jpiglo - ji - nimpp - nimppt(isendto(1)) + 4 658 jia = ji + nimpp - 1 659 ijta = jpiglo - jia + 2 660 IF((ijta .ge. (startloop + nimpp - 1)) .and. (ijta .lt. jia)) THEN 661 pt2dl(ji,ijpjm1) = psgn * pt2dl(ijta-nimpp+1,ijpjm1) 662 ELSE 663 pt2dl(ji,ijpjm1) = psgn * pt2dr(ijt,ijpjm1) 664 ENDIF 665 END DO 666 667 CASE ( 'U' ) ! U-point 668 IF (narea .ne. (jpnij)) THEN 669 endloop = nlci 670 ELSE 671 endloop = nlci - 1 672 ENDIF 673 DO ji = 1, endloop 674 iju = jpiglo - ji - nimpp - nimppt(isendto(1)) + 3 675 pt2dl(ji,ijpj) = psgn * pt2dr(iju,ijpjm1-1) 676 END DO 677 678 IF (narea .ne. (jpnij)) THEN 679 endloop = nlci 680 ELSE 681 endloop = nlci - 1 682 ENDIF 683 IF(nimpp .ge. (jpiglo/2)) THEN 684 startloop = 1 685 ELSEIF(((nimpp+nlci-1) .ge. (jpiglo/2)) .AND. (nimpp .lt. (jpiglo/2))) THEN 686 startloop = jpiglo/2 - nimpp + 1 687 ELSE 688 startloop = endloop + 1 689 ENDIF 690 DO ji = startloop, endloop 691 iju = jpiglo - ji - nimpp - nimppt(isendto(1)) + 3 692 jia = ji + nimpp - 1 693 ijua = jpiglo - jia + 1 694 IF((ijua .ge. (startloop + nimpp - 1)) .and. (ijua .lt. jia)) THEN 695 pt2dl(ji,ijpjm1) = psgn * pt2dl(ijua-nimpp+1,ijpjm1) 696 ELSE 697 pt2dl(ji,ijpjm1) = psgn * pt2dr(iju,ijpjm1) 698 ENDIF 699 END DO 700 701 CASE ( 'V' ) ! V-point 702 IF (narea .ne. (jpnij - jpni + 1)) THEN 703 startloop = 1 704 ELSE 705 startloop = 2 706 ENDIF 707 DO ji = startloop, nlci 708 ijt=jpiglo - ji - nimpp - nimppt(isendto(1)) + 4 709 pt2dl(ji,ijpjm1) = psgn * pt2dr(ijt,ijpjm1-1) 710 pt2dl(ji,ijpj) = psgn * pt2dr(ijt,ijpjm1-2) 711 END DO 712 713 CASE ( 'F' ) ! F-point 714 IF (narea .ne. (jpnij)) THEN 715 endloop = nlci 716 ELSE 717 endloop = nlci - 1 718 ENDIF 719 DO ji = 1, endloop 720 iju = jpiglo - ji - nimpp - nimppt(isendto(1)) + 3 721 pt2dl(ji,ijpjm1) = psgn * pt2dr(iju,ijpjm1-1) 722 pt2dl(ji,ijpj) = psgn * pt2dr(iju,ijpjm1-2) 723 END DO 724 725 CASE ( 'I' ) ! ice U-V point (I-point) 726 IF (narea .ne. (jpnij - jpni + 1)) THEN 727 startloop = 1 728 ELSE 729 startloop = 3 730 pt2dl(2,ijpj) = psgn * pt2dr(3,ijpjm1) 731 ENDIF 732 DO ji = startloop, nlci 733 iju = jpiglo - ji - nimpp - nimppt(isendto(1)) + 5 734 pt2dl(ji,ijpj) = psgn * pt2dr(iju,ijpjm1) 735 END DO 736 737 CASE ( 'J' ) ! first ice U-V point 738 IF (narea .ne. (jpnij - jpni + 1)) THEN 739 startloop = 1 740 ELSE 741 startloop = 3 742 pt2dl(2,ijpj) = psgn * pt2dr(3,ijpjm1) 743 ENDIF 744 DO ji = startloop, nlci 745 iju = jpiglo - ji - nimpp - nimppt(isendto(1)) + 5 746 pt2dl(ji,ijpj) = psgn * pt2dr(iju,ijpjm1) 747 END DO 748 749 CASE ( 'K' ) ! second ice U-V point 750 IF (narea .ne. (jpnij - jpni + 1)) THEN 751 startloop = 1 752 ELSE 753 startloop = 3 754 pt2dl(2,ijpj) = psgn * pt2dr(3,ijpjm1) 755 ENDIF 756 DO ji = startloop, nlci 757 iju = jpiglo - ji - nimpp - nimppt(isendto(1)) + 5 758 pt2dl(ji,ijpj) = psgn * pt2dr(iju,ijpjm1) 759 END DO 760 761 END SELECT 762 ! 763 CASE ( 5, 6 ) ! * North fold F-point pivot 764 ! 765 SELECT CASE ( cd_type ) 766 CASE ( 'T' , 'W' ) ! T-, W-point 767 DO ji = 1, nlci 768 ijt = jpiglo - ji - nimpp - nimppt(isendto(1)) + 3 769 pt2dl(ji,ijpj) = psgn * pt2dr(ijt,ijpjm1) 770 END DO 771 772 CASE ( 'U' ) ! U-point 773 IF (narea .ne. (jpnij)) THEN 774 endloop = nlci 775 ELSE 776 endloop = nlci - 1 777 ENDIF 778 DO ji = 1, endloop 779 iju = jpiglo - ji - nimpp - nimppt(isendto(1)) + 2 780 pt2dl(ji,ijpj) = psgn * pt2dr(iju,ijpjm1) 781 END DO 782 783 CASE ( 'V' ) ! V-point 784 DO ji = 1, nlci 785 ijt = jpiglo - ji - nimpp - nimppt(isendto(1)) + 3 786 pt2dl(ji,ijpj) = psgn * pt2dr(ijt,ijpjm1-1) 787 END DO 788 IF(nimpp .ge. (jpiglo/2+1)) THEN 789 startloop = 1 790 ELSEIF(((nimpp+nlci-1) .ge. (jpiglo/2+1)) .AND. (nimpp .lt. (jpiglo/2+1))) THEN 791 startloop = jpiglo/2+1 - nimpp + 1 792 ELSE 793 startloop = nlci + 1 794 ENDIF 795 DO ji = startloop, nlci 796 ijt = jpiglo - ji - nimpp - nimppt(isendto(1)) + 3 797 pt2dl(ji,ijpjm1) = psgn * pt2dr(ijt,ijpjm1) 798 END DO 799 800 CASE ( 'F' ) ! F-point 801 IF (narea .ne. (jpnij)) THEN 802 endloop = nlci 803 ELSE 804 endloop = nlci - 1 805 ENDIF 806 DO ji = 1, endloop 807 iju = jpiglo - ji - nimpp - nimppt(isendto(1)) + 2 808 pt2dl(ji,ijpj) = psgn * pt2dr(iju,ijpjm1-1) 809 END DO 810 811 IF (narea .ne. (jpnij)) THEN 812 endloop = nlci 813 ELSE 814 endloop = nlci - 1 815 ENDIF 816 IF(nimpp .ge. (jpiglo/2+1)) THEN 817 startloop = 1 818 ELSEIF(((nimpp+nlci-1) .ge. (jpiglo/2+1)) .AND. (nimpp .lt. (jpiglo/2+1))) THEN 819 startloop = jpiglo/2+1 - nimpp + 1 820 ELSE 821 startloop = endloop + 1 822 ENDIF 823 824 DO ji = startloop, endloop 825 iju = jpiglo - ji - nimpp - nimppt(isendto(1)) + 2 826 pt2dl(ji,ijpjm1) = psgn * pt2dr(iju,ijpjm1) 827 END DO 828 829 CASE ( 'I' ) ! ice U-V point (I-point) 830 IF (narea .ne. (jpnij - jpni + 1)) THEN 831 startloop = 1 832 ELSE 833 startloop = 2 834 ENDIF 835 IF (narea .ne. jpnij) THEN 836 endloop = nlci 837 ELSE 838 endloop = nlci - 1 839 ENDIF 840 DO ji = startloop , endloop 841 ijt = jpiglo - ji - nimpp - nimppt(isendto(1)) + 4 842 pt2dl(ji,ijpj)= 0.5 * (pt2dr(ji,ijpjm1) + psgn * pt2dr(ijt,ijpjm1)) 843 END DO 844 845 CASE ( 'J' ) ! first ice U-V point 846 IF (narea .ne. (jpnij - jpni + 1)) THEN 847 startloop = 1 848 ELSE 849 startloop = 2 850 ENDIF 851 IF (narea .ne. jpnij) THEN 852 endloop = nlci 853 ELSE 854 endloop = nlci - 1 855 ENDIF 856 DO ji = startloop , endloop 857 ijt = jpiglo - ji - nimpp - nimppt(isendto(1)) + 4 858 pt2dl(ji,ijpj) = pt2dr(ji,ijpjm1) 859 END DO 860 861 CASE ( 'K' ) ! second ice U-V point 862 IF (narea .ne. (jpnij - jpni + 1)) THEN 863 startloop = 1 864 ELSE 865 startloop = 2 866 ENDIF 867 IF (narea .ne. jpnij) THEN 868 endloop = nlci 869 ELSE 870 endloop = nlci - 1 871 ENDIF 872 DO ji = startloop, endloop 873 ijt = jpiglo - ji - nimpp - nimppt(isendto(1)) + 4 874 pt2dl(ji,ijpj) = pt2dr(ijt,ijpjm1) 875 END DO 876 877 END SELECT 878 ! 879 CASE DEFAULT ! * closed : the code probably never go through 880 ! 881 SELECT CASE ( cd_type) 882 CASE ( 'T' , 'U' , 'V' , 'W' ) ! T-, U-, V-, W-points 883 pt2dl(:, 1 ) = 0.e0 884 pt2dl(:,ijpj) = 0.e0 885 CASE ( 'F' ) ! F-point 886 pt2dl(:,ijpj) = 0.e0 887 CASE ( 'I' ) ! ice U-V point 888 pt2dl(:, 1 ) = 0.e0 889 pt2dl(:,ijpj) = 0.e0 890 CASE ( 'J' ) ! first ice U-V point 891 pt2dl(:, 1 ) = 0.e0 892 pt2dl(:,ijpj) = 0.e0 893 CASE ( 'K' ) ! second ice U-V point 894 pt2dl(:, 1 ) = 0.e0 895 pt2dl(:,ijpj) = 0.e0 896 END SELECT 897 ! 898 END SELECT 899 ! 900 END SUBROUTINE mpp_lbc_nfd_2d 901 345 902 END MODULE lbcnfd -
branches/2013/dev_r3948_CMCC_NorthFold_Opt/NEMOGCM/NEMO/OPA_SRC/LBC/lib_mpp.F90
r3918 r4021 22 22 !! 'mpp_lnk_bdy_2d' and 'mpp_lnk_obc_2d' routines and update 23 23 !! the mppobc routine to optimize the BDY and OBC communications 24 !! 3.5 ! 2013 (S.Mocavero, I.Epicoco - CMCC) north fold optimizations 24 25 !!---------------------------------------------------------------------- 25 26 … … 165 166 REAL(wp), DIMENSION(:,:,:,:), ALLOCATABLE, SAVE :: xnorthgloio 166 167 REAL(wp), DIMENSION(:,:,:) , ALLOCATABLE, SAVE :: foldwk ! Workspace for message transfers avoiding mpi_allgather 168 REAL(wp), DIMENSION(:,:,:) , ALLOCATABLE, SAVE :: ztabl_3d 169 REAL(wp), DIMENSION(:,:,:) , ALLOCATABLE, SAVE :: ztabr_3d 167 170 168 171 ! Arrays used in mpp_lbc_north_2d() … … 170 173 REAL(wp), DIMENSION(:,:,:), ALLOCATABLE, SAVE :: xnorthgloio_2d 171 174 REAL(wp), DIMENSION(:,:) , ALLOCATABLE, SAVE :: foldwk_2d ! Workspace for message transfers avoiding mpi_allgather 175 REAL(wp), DIMENSION(:,:) , ALLOCATABLE, SAVE :: ztabl_2d 176 REAL(wp), DIMENSION(:,:) , ALLOCATABLE, SAVE :: ztabr_2d 172 177 173 178 ! Arrays used in mpp_lbc_north_e() … … 176 181 177 182 ! 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 neighbours179 INTEGER, PUBLIC, PARAMETER :: jptyps = 5 ! Number of different neighbour lists to be used for northfold exchanges180 INTEGER, PUBLIC, DIMENSION (jpmaxngh,jptyps) :: isendto181 INTEGER, PUBLIC, DIMENSION (jptyps) :: nsndto183 ! INTEGER, PUBLIC, PARAMETER :: jpmaxngh = 8 ! Assumed maximum number of active neighbours 184 ! INTEGER, PUBLIC, PARAMETER :: jptyps = 5 ! Number of different neighbour lists to be used for northfold exchanges 185 ! INTEGER, PUBLIC, DIMENSION (jpmaxngh,jptyps) :: isendto 186 ! INTEGER, PUBLIC, DIMENSION (jptyps) :: nsndto 182 187 LOGICAL, PUBLIC :: ln_nnogather = .FALSE. ! namelist control of northfold comms 183 188 LOGICAL, PUBLIC :: l_north_nogather = .FALSE. ! internal control of northfold comms … … 214 219 ! 215 220 & tab_e(jpiglo,4+2*jpr2dj) , xnorthloc_e(jpi,4+2*jpr2dj) , xnorthgloio_e(jpi,4+2*jpr2dj,jpni) , & 221 ! 222 & ztabl_3d(jpi,4,jpk), ztabr_3d(jpi*jpmaxngh, 4, jpk), ztabl_2d(jpi,4), ztabr_2d(jpi*jpmaxngh, 4), & 216 223 ! 217 224 & STAT=lib_mpp_alloc ) … … 2585 2592 CHARACTER(len=1) , INTENT(in ) :: cd_type ! nature of pt3d grid-points 2586 2593 ! ! = T , U , V , F or W gridpoints 2587 REAL(wp) , INTENT(in ) :: psgn ! = -1. the sign change across the north fold 2594 REAL(wp) , INTENT(in ) :: psgn ! = -1. the sign change across the north fold 2588 2595 !! ! = 1. , the sign is kept 2589 INTEGER :: ji, jj, jr 2596 INTEGER :: ji, jj, jr, jk 2590 2597 INTEGER :: ierr, itaille, ildi, ilei, iilb 2591 2598 INTEGER :: ijpj, ijpjm1, ij, iproc 2592 INTEGER, DIMENSION (jpmaxngh) :: ml_req_nf !for mpi_isend when avoiding mpi_allgather2599 INTEGER, DIMENSION (jpmaxngh) :: ml_req_nf !for mpi_isend when avoiding mpi_allgather 2593 2600 INTEGER :: ml_err ! for mpi_isend when avoiding mpi_allgather 2594 2601 INTEGER, DIMENSION(MPI_STATUS_SIZE) :: ml_stat ! for mpi_isend when avoiding mpi_allgather 2595 !!---------------------------------------------------------------------- 2596 ! 2602 INTEGER :: istatus(mpi_status_size) 2603 INTEGER :: iflag 2604 !!---------------------------------------------------------------------- 2605 ! 2606 2597 2607 ijpj = 4 2598 ityp = -12599 2608 ijpjm1 = 3 2600 tab_3d(:,:,:) = 0.e0 2601 ! 2602 DO jj = nlcj - ijpj +1, nlcj ! put in xnorthloc the last 4 jlines of pt3d 2603 ij = jj - nlcj + ijpj 2604 xnorthloc(:,ij,:) = pt3d(:,jj,:) 2609 ! 2610 DO jk = 1, jpk 2611 DO jj = nlcj - ijpj +1, nlcj ! put in xnorthloc the last 4 jlines of pt3d 2612 ij = jj - nlcj + ijpj 2613 xnorthloc(:,ij,jk) = pt3d(:,jj,jk) 2614 END DO 2605 2615 END DO 2606 2616 ! 2607 2617 ! ! Build in procs of ncomm_north the xnorthgloio 2608 2618 itaille = jpi * jpk * ijpj 2619 2620 2609 2621 IF ( l_north_nogather ) THEN 2610 2622 ! 2611 ! Avoid the use of mpi_allgather by exchanging only with the processes already identified 2623 ! Avoid the use of mpi_allgather by exchanging only with the processes already identified 2612 2624 ! (in nemo_northcomms) as being involved in this process' northern boundary exchange 2613 2625 ! 2614 DO jj = nlcj-ijpj+1, nlcj ! First put local values into the global array 2615 ij = jj - nlcj + ijpj 2616 DO ji = 1, nlci 2617 tab_3d(ji+nimpp-1,ij,:) = pt3d(ji,jj,:) 2618 END DO 2619 END DO 2620 2621 ! 2622 ! Set the exchange type in order to access the correct list of active neighbours 2623 ! 2624 SELECT CASE ( cd_type ) 2625 CASE ( 'T' , 'W' ) 2626 ityp = 1 2627 CASE ( 'U' ) 2628 ityp = 2 2629 CASE ( 'V' ) 2630 ityp = 3 2631 CASE ( 'F' ) 2632 ityp = 4 2633 CASE ( 'I' ) 2634 ityp = 5 2635 CASE DEFAULT 2636 ityp = -1 ! Set a default value for unsupported types which 2637 ! will cause a fallback to the mpi_allgather method 2638 END SELECT 2639 IF ( ityp .gt. 0 ) THEN 2640 2641 DO jr = 1,nsndto(ityp) 2642 CALL mppsend(5, xnorthloc, itaille, isendto(jr,ityp), ml_req_nf(jr) ) 2643 END DO 2644 DO jr = 1,nsndto(ityp) 2645 CALL mpprecv(5, foldwk, itaille, isendto(jr,ityp)) 2646 iproc = isendto(jr,ityp) + 1 2647 ildi = nldit (iproc) 2648 ilei = nleit (iproc) 2649 iilb = nimppt(iproc) 2650 DO jj = 1, ijpj 2651 DO ji = ildi, ilei 2652 tab_3d(ji+iilb-1,jj,:) = foldwk(ji,jj,:) 2653 END DO 2626 DO jk = 1, jpk 2627 DO jj = nlcj-ijpj+1, nlcj ! First put local values into the global array 2628 ij = jj - nlcj + ijpj 2629 DO ji = 1, nlci 2630 ztabl_3d(ji,ij,jk) = pt3d(ji,jj,jk) 2654 2631 END DO 2655 2632 END DO 2656 IF (l_isend) THEN 2657 DO jr = 1,nsndto(ityp) 2658 CALL mpi_wait(ml_req_nf(jr), ml_stat, ml_err) 2633 END DO 2634 2635 DO jr = 1,nsndto 2636 IF (isendto(jr) .ne. narea) CALL mppsend(5, xnorthloc, itaille, isendto(jr)-1, ml_req_nf(jr)) 2637 END DO 2638 DO jr = 1,nsndto 2639 iproc = isendto(jr) 2640 ildi = nldit (iproc) 2641 ilei = nleit (iproc) 2642 iilb = nimppt(isendto(jr)) - nimppt(isendto(1)) 2643 IF(isendto(jr) .ne. narea) THEN 2644 CALL mpprecv(5, foldwk, itaille, isendto(jr)-1) 2645 DO jk = 1, jpk 2646 DO jj = 1, ijpj 2647 DO ji = 1, ilei 2648 ztabr_3d(iilb+ji,jj,jk) = foldwk(ji,jj,jk) 2649 END DO 2650 END DO 2651 END DO 2652 ELSE 2653 DO jk = 1, jpk 2654 DO jj = 1, ijpj 2655 DO ji = 1, ilei 2656 ztabr_3d(iilb+ji,jj,jk) = pt3d(ji,nlcj-ijpj+jj,jk) 2657 END DO 2658 END DO 2659 END DO 2660 ENDIF 2661 END DO 2662 IF (l_isend) THEN 2663 DO jr = 1,nsndto 2664 IF (isendto(jr) .ne. narea) CALL mpi_wait(ml_req_nf(jr), ml_stat, ml_err) 2665 END DO 2666 ENDIF 2667 CALL mpp_lbc_nfd( ztabl_3d, ztabr_3d, cd_type, psgn ) ! North fold boundary condition 2668 ! 2669 DO jk=1, jpk 2670 DO jj = nlcj-ijpj+1, nlcj ! Scatter back to pt3d 2671 ij = jj - nlcj + ijpj 2672 DO ji= 1, nlci 2673 pt3d(ji,jj,jk) = ztabl_3d(ji,ij,jk) 2659 2674 END DO 2660 ENDIF 2661 2662 ENDIF 2663 2664 ENDIF 2665 2666 IF ( ityp .lt. 0 ) THEN 2675 END DO 2676 END DO 2677 ! 2678 2679 ELSE 2667 2680 CALL MPI_ALLGATHER( xnorthloc , itaille, MPI_DOUBLE_PRECISION, & 2668 2681 & xnorthgloio, itaille, MPI_DOUBLE_PRECISION, ncomm_north, ierr ) … … 2673 2686 ilei = nleit (iproc) 2674 2687 iilb = nimppt(iproc) 2675 DO jj = 1, ijpj 2676 DO ji = ildi, ilei 2677 tab_3d(ji+iilb-1,jj,:) = xnorthgloio(ji,jj,:,jr) 2688 DO jk=1, jpk 2689 DO jj = 1, ijpj 2690 DO ji = ildi, ilei 2691 tab_3d(ji+iilb-1,jj,jk) = xnorthgloio(ji,jj,jk,jr) 2692 END DO 2678 2693 END DO 2679 2694 END DO 2680 2695 END DO 2681 ENDIF 2682 ! 2683 ! The tab_3d array has been either: 2684 ! a. Fully populated by the mpi_allgather operation or 2685 ! b. Had the active points for this domain and northern neighbours populated 2686 ! by peer to peer exchanges 2687 ! Either way the array may be folded by lbc_nfd and the result for the span of 2688 ! this domain will be identical. 2689 ! 2690 CALL lbc_nfd( tab_3d, cd_type, psgn ) ! North fold boundary condition 2691 ! 2692 DO jj = nlcj-ijpj+1, nlcj ! Scatter back to pt3d 2693 ij = jj - nlcj + ijpj 2694 DO ji= 1, nlci 2695 pt3d(ji,jj,:) = tab_3d(ji+nimpp-1,ij,:) 2696 END DO 2697 END DO 2698 ! 2696 CALL lbc_nfd( tab_3d, cd_type, psgn ) ! North fold boundary condition 2697 ! 2698 DO jk=1, jpk 2699 DO jj = nlcj-ijpj+1, nlcj ! Scatter back to pt3d 2700 ij = jj - nlcj + ijpj 2701 DO ji= 1, nlci 2702 pt3d(ji,jj,jk) = tab_3d(ji+nimpp-1,ij,jk) 2703 END DO 2704 END DO 2705 END DO 2706 ! 2707 ENDIF 2708 2699 2709 END SUBROUTINE mpp_lbc_north_3d 2700 2710 … … 2714 2724 !! 2715 2725 !!---------------------------------------------------------------------- 2716 REAL(wp), DIMENSION(jpi,jpj), INTENT(inout) :: pt2d ! 3D array on which the b.c. is applied2717 CHARACTER(len=1) , INTENT(in ) :: cd_type ! nature of pt 3d grid-points2726 REAL(wp), DIMENSION(jpi,jpj), INTENT(inout) :: pt2d ! 2D array on which the b.c. is applied 2727 CHARACTER(len=1) , INTENT(in ) :: cd_type ! nature of pt2d grid-points 2718 2728 ! ! = T , U , V , F or W gridpoints 2719 REAL(wp) , INTENT(in ) :: psgn ! = -1. the sign change across the north fold 2729 REAL(wp) , INTENT(in ) :: psgn ! = -1. the sign change across the north fold 2720 2730 !! ! = 1. , the sign is kept 2721 2731 INTEGER :: ji, jj, jr 2722 2732 INTEGER :: ierr, itaille, ildi, ilei, iilb 2723 2733 INTEGER :: ijpj, ijpjm1, ij, iproc 2724 INTEGER, DIMENSION (jpmaxngh) :: ml_req_nf ! 2734 INTEGER, DIMENSION (jpmaxngh) :: ml_req_nf !for mpi_isend when avoiding mpi_allgather 2725 2735 INTEGER :: ml_err ! for mpi_isend when avoiding mpi_allgather 2726 2736 INTEGER, DIMENSION(MPI_STATUS_SIZE):: ml_stat ! for mpi_isend when avoiding mpi_allgather 2727 !!---------------------------------------------------------------------- 2728 ! 2737 INTEGER :: istatus(mpi_status_size) 2738 INTEGER :: iflag 2739 !!---------------------------------------------------------------------- 2740 ! 2741 2729 2742 ijpj = 4 2730 ityp = -12731 2743 ijpjm1 = 3 2732 tab_2d(:,:) = 0.e02733 2744 ! 2734 2745 DO jj = nlcj-ijpj+1, nlcj ! put in xnorthloc_2d the last 4 jlines of pt2d … … 2741 2752 IF ( l_north_nogather ) THEN 2742 2753 ! 2743 ! Avoid the use of mpi_allgather by exchanging only with the processes already identified 2754 ! Avoid the use of mpi_allgather by exchanging only with the processes already identified 2744 2755 ! (in nemo_northcomms) as being involved in this process' northern boundary exchange 2745 2756 ! … … 2747 2758 ij = jj - nlcj + ijpj 2748 2759 DO ji = 1, nlci 2749 tab_2d(ji+nimpp-1,ij) = pt2d(ji,jj)2760 ztabl_2d(ji,ij) = pt2d(ji,jj) 2750 2761 END DO 2751 2762 END DO 2752 2763 2753 ! 2754 ! Set the exchange type in order to access the correct list of active neighbours 2755 ! 2756 SELECT CASE ( cd_type ) 2757 CASE ( 'T' , 'W' ) 2758 ityp = 1 2759 CASE ( 'U' ) 2760 ityp = 2 2761 CASE ( 'V' ) 2762 ityp = 3 2763 CASE ( 'F' ) 2764 ityp = 4 2765 CASE ( 'I' ) 2766 ityp = 5 2767 CASE DEFAULT 2768 ityp = -1 ! Set a default value for unsupported types which 2769 ! will cause a fallback to the mpi_allgather method 2770 END SELECT 2771 2772 IF ( ityp .gt. 0 ) THEN 2773 2774 DO jr = 1,nsndto(ityp) 2775 CALL mppsend(5, xnorthloc_2d, itaille, isendto(jr,ityp), ml_req_nf(jr) ) 2764 DO jr = 1,nsndto 2765 IF (isendto(jr) .ne. narea) CALL mppsend(5, xnorthloc_2d, itaille, isendto(jr)-1, ml_req_nf(jr)) 2766 END DO 2767 DO jr = 1,nsndto 2768 iproc = isendto(jr) 2769 ildi = nldit (iproc) 2770 ilei = nleit (iproc) 2771 iilb = nimppt(isendto(jr)) - nimppt(isendto(1)) 2772 IF(isendto(jr) .ne. narea) THEN 2773 CALL mpprecv(5, foldwk_2d, itaille, isendto(jr)-1) 2774 DO jj = 1, ijpj 2775 DO ji = 1, ilei 2776 ztabr_2d(iilb+ji,jj) = foldwk_2d(ji,jj) 2777 END DO 2778 END DO 2779 ELSE 2780 DO jj = 1, ijpj 2781 DO ji = 1, ilei 2782 ztabr_2d(iilb+ji,jj) = pt2d(ji,nlcj-ijpj+jj) 2783 END DO 2784 END DO 2785 ENDIF 2786 END DO 2787 IF (l_isend) THEN 2788 DO jr = 1,nsndto 2789 IF (isendto(jr) .ne. narea) CALL mpi_wait(ml_req_nf(jr), ml_stat, ml_err) 2776 2790 END DO 2777 DO jr = 1,nsndto(ityp) 2778 CALL mpprecv(5, foldwk_2d, itaille, isendto(jr,ityp)) 2779 iproc = isendto(jr,ityp) + 1 2780 ildi = nldit (iproc) 2781 ilei = nleit (iproc) 2782 iilb = nimppt(iproc) 2783 DO jj = 1, ijpj 2784 DO ji = ildi, ilei 2785 tab_2d(ji+iilb-1,jj) = foldwk_2d(ji,jj) 2786 END DO 2787 END DO 2791 ENDIF 2792 CALL mpp_lbc_nfd( ztabl_2d, ztabr_2d, cd_type, psgn ) ! North fold boundary condition 2793 ! 2794 DO jj = nlcj-ijpj+1, nlcj ! Scatter back to pt2d 2795 ij = jj - nlcj + ijpj 2796 DO ji = 1, nlci 2797 pt2d(ji,jj) = ztabl_2d(ji,ij) 2788 2798 END DO 2789 IF (l_isend) THEN 2790 DO jr = 1,nsndto(ityp) 2791 CALL mpi_wait(ml_req_nf(jr), ml_stat, ml_err) 2792 END DO 2793 ENDIF 2794 2795 ENDIF 2796 2797 ENDIF 2798 2799 IF ( ityp .lt. 0 ) THEN 2799 END DO 2800 ! 2801 2802 ELSE 2800 2803 CALL MPI_ALLGATHER( xnorthloc_2d , itaille, MPI_DOUBLE_PRECISION, & 2801 2804 & xnorthgloio_2d, itaille, MPI_DOUBLE_PRECISION, ncomm_north, ierr ) … … 2812 2815 END DO 2813 2816 END DO 2814 ENDIF 2815 ! 2816 ! The tab array has been either: 2817 ! a. Fully populated by the mpi_allgather operation or 2818 ! b. Had the active points for this domain and northern neighbours populated 2819 ! by peer to peer exchanges 2820 ! Either way the array may be folded by lbc_nfd and the result for the span of 2821 ! this domain will be identical. 2822 ! 2823 CALL lbc_nfd( tab_2d, cd_type, psgn ) ! North fold boundary condition 2824 ! 2825 ! 2826 DO jj = nlcj-ijpj+1, nlcj ! Scatter back to pt2d 2827 ij = jj - nlcj + ijpj 2828 DO ji = 1, nlci 2829 pt2d(ji,jj) = tab_2d(ji+nimpp-1,ij) 2830 END DO 2831 END DO 2832 ! 2817 CALL lbc_nfd( tab_2d, cd_type, psgn ) ! North fold boundary condition 2818 ! 2819 DO jj = nlcj-ijpj+1, nlcj ! Scatter back to pt2d 2820 ij = jj - nlcj + ijpj 2821 DO ji = 1, nlci 2822 pt2d(ji,jj) = tab_2d(ji+nimpp-1,ij) 2823 END DO 2824 END DO 2825 ! 2826 ENDIF 2833 2827 END SUBROUTINE mpp_lbc_north_2d 2834 2828 … … 2860 2854 ! 2861 2855 ijpj=4 2862 tab_e(:,:) = 0.e02863 2856 2864 2857 ij=0 -
branches/2013/dev_r3948_CMCC_NorthFold_Opt/NEMOGCM/NEMO/OPA_SRC/nemogcm.F90
r3769 r4021 84 84 #endif 85 85 USE sbctide, ONLY: lk_tide 86 USE lbcnfd, ONLY: isendto, nsndto ! Setup of north fold exchanges 86 87 87 88 IMPLICIT NONE … … 683 684 !!====================================================================== 684 685 !! *** ROUTINE nemo_northcomms *** 685 !! nemo_northcomms : Setup for north fold exchanges with explicit peer to peer messaging 686 !! nemo_northcomms : Setup for north fold exchanges with explicit 687 !! point-to-point messaging 686 688 !!===================================================================== 687 689 !!---------------------------------------------------------------------- … … 690 692 !!---------------------------------------------------------------------- 691 693 !! 1.0 ! 2011-10 (A. C. Coward, NOCS & J. Donners, PRACE) 692 !!---------------------------------------------------------------------- 693 694 INTEGER :: ji, jj, jk, ij, jtyp ! dummy loop indices 695 INTEGER :: ijpj ! number of rows involved in north-fold exchange 696 INTEGER :: northcomms_alloc ! allocate return status 697 REAL(wp), ALLOCATABLE, DIMENSION ( :,: ) :: znnbrs ! workspace 698 LOGICAL, ALLOCATABLE, DIMENSION ( : ) :: lrankset ! workspace 699 700 IF(lwp) WRITE(numout,*) 701 IF(lwp) WRITE(numout,*) 'nemo_northcomms : Initialization of the northern neighbours lists' 702 IF(lwp) WRITE(numout,*) '~~~~~~~~~~' 703 704 !!---------------------------------------------------------------------- 705 ALLOCATE( znnbrs(jpi,jpj), stat = northcomms_alloc ) 706 ALLOCATE( lrankset(jpnij), stat = northcomms_alloc ) 707 IF( northcomms_alloc /= 0 ) THEN 708 WRITE(numout,cform_war) 709 WRITE(numout,*) 'northcomms_alloc : failed to allocate arrays' 710 CALL ctl_stop( 'STOP', 'nemo_northcomms : unable to allocate temporary arrays' ) 711 ENDIF 694 !! 2.0 ! 2013-06 Setup avoiding MPI communication (I. Epicoco, S. Mocavero, CMCC) 695 !!---------------------------------------------------------------------- 696 697 INTEGER :: sxM, dxM, sxT, dxT, jn 698 699 !initializes the north-fold communication variables 700 isendto(:) = 0 712 701 nsndto = 0 713 isendto = -1 714 ijpj = 4 715 ! 716 ! This routine has been called because ln_nnogather has been set true ( nammpp ) 717 ! However, these first few exchanges have to use the mpi_allgather method to 718 ! establish the neighbour lists to use in subsequent peer to peer exchanges. 719 ! Consequently, set l_north_nogather to be false here and set it true only after 720 ! the lists have been established. 721 ! 722 l_north_nogather = .FALSE. 723 ! 724 ! Exchange and store ranks on northern rows 725 726 DO jtyp = 1,4 727 728 lrankset = .FALSE. 729 znnbrs = narea 730 SELECT CASE (jtyp) 731 CASE(1) 732 CALL lbc_lnk( znnbrs, 'T', 1. ) ! Type 1: T,W-points 733 CASE(2) 734 CALL lbc_lnk( znnbrs, 'U', 1. ) ! Type 2: U-point 735 CASE(3) 736 CALL lbc_lnk( znnbrs, 'V', 1. ) ! Type 3: V-point 737 CASE(4) 738 CALL lbc_lnk( znnbrs, 'F', 1. ) ! Type 4: F-point 739 END SELECT 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 ENDIF 761 762 END DO 763 764 ! 765 ! Type 5: I-point 766 ! 767 ! ICE point exchanges may involve some averaging. The neighbours list is 768 ! built up using two exchanges to ensure that the whole stencil is covered. 769 ! lrankset should not be reset between these 'J' and 'K' point exchanges 770 771 jtyp = 5 772 lrankset = .FALSE. 773 znnbrs = narea 774 CALL lbc_lnk( znnbrs, 'J', 1. ) ! first ice U-V point 775 776 IF ( njmppt(narea) .EQ. MAXVAL( njmppt ) ) THEN 777 DO jj = nlcj-ijpj+1, nlcj 778 ij = jj - nlcj + ijpj 779 DO ji = 1,jpi 780 IF ( INT(znnbrs(ji,jj)) .NE. 0 .AND. INT(znnbrs(ji,jj)) .NE. narea ) & 781 & lrankset(INT(znnbrs(ji,jj))) = .true. 782 END DO 783 END DO 784 ENDIF 785 786 znnbrs = narea 787 CALL lbc_lnk( znnbrs, 'K', 1. ) ! second ice U-V point 788 789 IF ( njmppt(narea) .EQ. MAXVAL( njmppt )) THEN 790 DO jj = nlcj-ijpj+1, nlcj 791 ij = jj - nlcj + ijpj 792 DO ji = 1,jpi 793 IF ( INT(znnbrs(ji,jj)) .NE. 0 .AND. INT(znnbrs(ji,jj)) .NE. narea ) & 794 & lrankset( INT(znnbrs(ji,jj))) = .true. 795 END DO 796 END DO 797 798 DO jj = 1,jpnij 799 IF ( lrankset(jj) ) THEN 800 nsndto(jtyp) = nsndto(jtyp) + 1 801 IF ( nsndto(jtyp) .GT. jpmaxngh ) THEN 802 CALL ctl_stop( ' Too many neighbours in nemo_northcomms ', & 803 & ' jpmaxngh will need to be increased ') 804 ENDIF 805 isendto(nsndto(jtyp),jtyp) = jj-1 ! narea converted to MPI rank 806 ENDIF 807 END DO 808 ! 809 ! For northern row areas, set l_north_nogather so that all subsequent exchanges 810 ! can use peer to peer communications at the north fold 811 ! 812 l_north_nogather = .TRUE. 813 ! 814 ENDIF 815 DEALLOCATE( znnbrs ) 816 DEALLOCATE( lrankset ) 817 702 703 !if I am a process in the north 704 IF (narea .ge. jpnij - jpni +1) THEN 705 !sxM is the first point (in the global domain) needed to compute the 706 !north-fold for the current process 707 sxM = jpiglo - nimppt(narea) - nlcit(narea) + 1 708 !dxM is the last point (in the global domain) needed to compute the 709 !north-fold for the current process 710 dxM = jpiglo - nimppt(narea) + 2 711 712 !loop over the other north-fold processes to find the processes 713 !managing the points belonging to the sxT-dxT range 714 DO jn = jpnij - jpni +1, jpnij 715 !sxT is the first point (in the global domain) of the jn 716 !process 717 sxT = nimppt(jn) 718 !dxT is the last point (in the global domain) of the jn 719 !process 720 dxT = nimppt(jn) + nlcit(jn) - 1 721 IF ((sxM .gt. sxT) .AND. (sxM .lt. dxT)) THEN 722 nsndto = nsndto + 1 723 isendto(nsndto) = jn 724 ELSEIF ((sxM .le. sxT) .AND. (dxM .gt. dxT)) THEN 725 nsndto = nsndto + 1 726 isendto(nsndto) = jn 727 ELSEIF ((dxM .lt. dxT) .AND. (sxT .lt. dxM)) THEN 728 nsndto = nsndto + 1 729 isendto(nsndto) = jn 730 END IF 731 END DO 732 ENDIF 733 l_north_nogather = .TRUE. 818 734 END SUBROUTINE nemo_northcomms 819 735 #else
Note: See TracChangeset
for help on using the changeset viewer.