- Timestamp:
- 2017-05-02T13:29:51+02:00 (7 years ago)
- Location:
- branches/UKMO/dev_r5518_GO6_package/NEMOGCM/NEMO/OPA_SRC/LBC
- Files:
-
- 2 edited
Legend:
- Unmodified
- Added
- Removed
-
branches/UKMO/dev_r5518_GO6_package/NEMOGCM/NEMO/OPA_SRC/LBC/lbclnk.F90
r6486 r7993 11 11 !! the BDY/OBC communications 12 12 !! 3.4 ! 2012-12 (R. Bourdalle-Badie and G. Reffray) add a C1D case 13 !! 3.6 ! 2015-06 (O. Tintó and M. Castrillo) add lbc_lnk_multi 13 14 !!---------------------------------------------------------------------- 14 15 #if defined key_mpp_mpi … … 24 25 25 26 INTERFACE lbc_lnk_multi 26 MODULE PROCEDURE mpp_lnk_2d_9 27 MODULE PROCEDURE mpp_lnk_2d_9, mpp_lnk_2d_multiple 27 28 END INTERFACE 28 29 … … 80 81 END INTERFACE 81 82 83 INTERFACE lbc_lnk_multi 84 MODULE PROCEDURE lbc_lnk_2d_9, lbc_lnk_2d_multiple 85 END INTERFACE 86 82 87 INTERFACE lbc_bdy_lnk 83 88 MODULE PROCEDURE lbc_bdy_lnk_2d, lbc_bdy_lnk_3d … … 87 92 MODULE PROCEDURE lbc_lnk_2d_e 88 93 END INTERFACE 94 95 TYPE arrayptr 96 REAL , DIMENSION (:,:), POINTER :: pt2d 97 END TYPE arrayptr 98 PUBLIC arrayptr 89 99 90 100 PUBLIC lbc_lnk ! ocean/ice lateral boundary conditions 91 101 PUBLIC lbc_lnk_e 102 PUBLIC lbc_lnk_multi ! modified ocean lateral boundary conditions 92 103 PUBLIC lbc_bdy_lnk ! ocean lateral BDY boundary conditions 93 104 PUBLIC lbc_lnk_icb … … 171 182 ! 172 183 END SUBROUTINE lbc_lnk_2d 184 185 SUBROUTINE lbc_lnk_2d_multiple( pt2d_array , type_array , psgn_array , num_fields ) 186 !! 187 INTEGER :: num_fields 188 TYPE( arrayptr ), DIMENSION(:) :: pt2d_array 189 CHARACTER(len=1), DIMENSION(:), INTENT(in ) :: type_array ! define the nature of ptab array grid-points 190 ! ! = T , U , V , F , W and I points 191 REAL(wp) , DIMENSION(:), INTENT(in ) :: psgn_array ! =-1 the sign change across the north fold boundary 192 ! ! = 1. , the sign is kept 193 ! 194 INTEGER :: ii !!MULTI SEND DUMMY LOOP INDICES 195 ! 196 DO ii = 1, num_fields 197 CALL lbc_lnk_2d( pt2d_array(ii)%pt2d, type_array(ii), psgn_array(ii) ) 198 END DO 199 ! 200 END SUBROUTINE lbc_lnk_2d_multiple 201 202 SUBROUTINE lbc_lnk_2d_9( pt2dA, cd_typeA, psgnA, pt2dB, cd_typeB, psgnB, pt2dC, cd_typeC, psgnC & 203 & , pt2dD, cd_typeD, psgnD, pt2dE, cd_typeE, psgnE, pt2dF, cd_typeF, psgnF & 204 & , pt2dG, cd_typeG, psgnG, pt2dH, cd_typeH, psgnH, pt2dI, cd_typeI, psgnI, cd_mpp, pval) 205 !!--------------------------------------------------------------------- 206 ! Second 2D array on which the boundary condition is applied 207 REAL(wp), DIMENSION(jpi,jpj), TARGET , INTENT(inout) :: pt2dA 208 REAL(wp), DIMENSION(jpi,jpj), TARGET, OPTIONAL, INTENT(inout) :: pt2dB , pt2dC , pt2dD , pt2dE 209 REAL(wp), DIMENSION(jpi,jpj), TARGET, OPTIONAL, INTENT(inout) :: pt2dF , pt2dG , pt2dH , pt2dI 210 ! define the nature of ptab array grid-points 211 CHARACTER(len=1) , INTENT(in ) :: cd_typeA 212 CHARACTER(len=1) , OPTIONAL, INTENT(in ) :: cd_typeB , cd_typeC , cd_typeD , cd_typeE 213 CHARACTER(len=1) , OPTIONAL, INTENT(in ) :: cd_typeF , cd_typeG , cd_typeH , cd_typeI 214 ! =-1 the sign change across the north fold boundary 215 REAL(wp) , INTENT(in ) :: psgnA 216 REAL(wp) , OPTIONAL, INTENT(in ) :: psgnB , psgnC , psgnD , psgnE 217 REAL(wp) , OPTIONAL, INTENT(in ) :: psgnF , psgnG , psgnH , psgnI 218 CHARACTER(len=3) , OPTIONAL, INTENT(in ) :: cd_mpp ! fill the overlap area only 219 REAL(wp) , OPTIONAL, INTENT(in ) :: pval ! background value (used at closed boundaries) 220 !! 221 !!--------------------------------------------------------------------- 222 223 !!The first array 224 CALL lbc_lnk( pt2dA, cd_typeA, psgnA ) 225 226 !! Look if more arrays to process 227 IF(PRESENT (psgnB) )CALL lbc_lnk( pt2dA, cd_typeA, psgnA ) 228 IF(PRESENT (psgnC) )CALL lbc_lnk( pt2dC, cd_typeC, psgnC ) 229 IF(PRESENT (psgnD) )CALL lbc_lnk( pt2dD, cd_typeD, psgnD ) 230 IF(PRESENT (psgnE) )CALL lbc_lnk( pt2dE, cd_typeE, psgnE ) 231 IF(PRESENT (psgnF) )CALL lbc_lnk( pt2dF, cd_typeF, psgnF ) 232 IF(PRESENT (psgnG) )CALL lbc_lnk( pt2dG, cd_typeG, psgnG ) 233 IF(PRESENT (psgnH) )CALL lbc_lnk( pt2dH, cd_typeH, psgnH ) 234 IF(PRESENT (psgnI) )CALL lbc_lnk( pt2dI, cd_typeI, psgnI ) 235 236 END SUBROUTINE lbc_lnk_2d_9 237 238 239 240 173 241 174 242 #else … … 372 440 ! 373 441 END SUBROUTINE lbc_lnk_2d 442 443 SUBROUTINE lbc_lnk_2d_multiple( pt2d_array , type_array , psgn_array , num_fields ) 444 !! 445 INTEGER :: num_fields 446 TYPE( arrayptr ), DIMENSION(:) :: pt2d_array 447 CHARACTER(len=1), DIMENSION(:), INTENT(in ) :: type_array ! define the nature of ptab array grid-points 448 ! ! = T , U , V , F , W and I points 449 REAL(wp) , DIMENSION(:), INTENT(in ) :: psgn_array ! =-1 the sign change across the north fold boundary 450 ! ! = 1. , the sign is kept 451 ! 452 INTEGER :: ii !!MULTI SEND DUMMY LOOP INDICES 453 ! 454 DO ii = 1, num_fields 455 CALL lbc_lnk_2d( pt2d_array(ii)%pt2d, type_array(ii), psgn_array(ii) ) 456 END DO 457 ! 458 END SUBROUTINE lbc_lnk_2d_multiple 459 460 SUBROUTINE lbc_lnk_2d_9( pt2dA, cd_typeA, psgnA, pt2dB, cd_typeB, psgnB, pt2dC, cd_typeC, psgnC & 461 & , pt2dD, cd_typeD, psgnD, pt2dE, cd_typeE, psgnE, pt2dF, cd_typeF, psgnF & 462 & , pt2dG, cd_typeG, psgnG, pt2dH, cd_typeH, psgnH, pt2dI, cd_typeI, psgnI, cd_mpp, pval) 463 !!--------------------------------------------------------------------- 464 ! Second 2D array on which the boundary condition is applied 465 REAL(wp), DIMENSION(jpi,jpj), TARGET , INTENT(inout) :: pt2dA 466 REAL(wp), DIMENSION(jpi,jpj), TARGET, OPTIONAL, INTENT(inout) :: pt2dB , pt2dC , pt2dD , pt2dE 467 REAL(wp), DIMENSION(jpi,jpj), TARGET, OPTIONAL, INTENT(inout) :: pt2dF , pt2dG , pt2dH , pt2dI 468 ! define the nature of ptab array grid-points 469 CHARACTER(len=1) , INTENT(in ) :: cd_typeA 470 CHARACTER(len=1) , OPTIONAL, INTENT(in ) :: cd_typeB , cd_typeC , cd_typeD , cd_typeE 471 CHARACTER(len=1) , OPTIONAL, INTENT(in ) :: cd_typeF , cd_typeG , cd_typeH , cd_typeI 472 ! =-1 the sign change across the north fold boundary 473 REAL(wp) , INTENT(in ) :: psgnA 474 REAL(wp) , OPTIONAL, INTENT(in ) :: psgnB , psgnC , psgnD , psgnE 475 REAL(wp) , OPTIONAL, INTENT(in ) :: psgnF , psgnG , psgnH , psgnI 476 CHARACTER(len=3) , OPTIONAL, INTENT(in ) :: cd_mpp ! fill the overlap area only 477 REAL(wp) , OPTIONAL, INTENT(in ) :: pval ! background value (used at closed boundaries) 478 !! 479 !!--------------------------------------------------------------------- 480 481 !!The first array 482 CALL lbc_lnk( pt2dA, cd_typeA, psgnA ) 483 484 !! Look if more arrays to process 485 IF(PRESENT (psgnB) )CALL lbc_lnk( pt2dA, cd_typeA, psgnA ) 486 IF(PRESENT (psgnC) )CALL lbc_lnk( pt2dC, cd_typeC, psgnC ) 487 IF(PRESENT (psgnD) )CALL lbc_lnk( pt2dD, cd_typeD, psgnD ) 488 IF(PRESENT (psgnE) )CALL lbc_lnk( pt2dE, cd_typeE, psgnE ) 489 IF(PRESENT (psgnF) )CALL lbc_lnk( pt2dF, cd_typeF, psgnF ) 490 IF(PRESENT (psgnG) )CALL lbc_lnk( pt2dG, cd_typeG, psgnG ) 491 IF(PRESENT (psgnH) )CALL lbc_lnk( pt2dH, cd_typeH, psgnH ) 492 IF(PRESENT (psgnI) )CALL lbc_lnk( pt2dI, cd_typeI, psgnI ) 493 494 END SUBROUTINE lbc_lnk_2d_9 495 374 496 375 497 #endif … … 441 563 !!====================================================================== 442 564 END MODULE lbclnk 565 -
branches/UKMO/dev_r5518_GO6_package/NEMOGCM/NEMO/OPA_SRC/LBC/lib_mpp.F90
r6487 r7993 24 24 !! 3.5 ! 2013 ( C. Ethe, G. Madec ) message passing arrays as local variables 25 25 !! 3.5 ! 2013 (S.Mocavero, I.Epicoco - CMCC) north fold optimizations 26 !! 3.6 ! 2015 (O. Tintó and M. Castrillo - BSC) Added 'mpp_lnk_2d_multiple', 'mpp_lbc_north_2d_multiple', 'mpp_max_multiple' 26 27 !!---------------------------------------------------------------------- 27 28 … … 62 63 USE lbcnfd ! north fold treatment 63 64 USE in_out_manager ! I/O manager 65 USE wrk_nemo ! work arrays 64 66 65 67 IMPLICIT NONE … … 70 72 PUBLIC mpp_ini_north, mpp_lbc_north, mpp_lbc_north_e 71 73 PUBLIC mpp_min, mpp_max, mpp_sum, mpp_minloc, mpp_maxloc 74 PUBLIC mpp_max_multiple 72 75 PUBLIC mpp_lnk_3d, mpp_lnk_3d_gather, mpp_lnk_2d, mpp_lnk_2d_e 73 PUBLIC mpp_lnk_2d_9 76 PUBLIC mpp_lnk_2d_9 , mpp_lnk_2d_multiple 74 77 PUBLIC mppscatter, mppgather 75 78 PUBLIC mpp_ini_ice, mpp_ini_znl … … 78 81 PUBLIC mpp_lnk_bdy_2d, mpp_lnk_bdy_3d 79 82 PUBLIC mpp_lbc_north_icb, mpp_lnk_2d_icb 83 PUBLIC mpprank 80 84 81 85 TYPE arrayptr 82 86 REAL , DIMENSION (:,:), POINTER :: pt2d 83 87 END TYPE arrayptr 88 PUBLIC arrayptr 84 89 85 90 !! * Interfaces … … 105 110 INTERFACE mpp_maxloc 106 111 MODULE PROCEDURE mpp_maxloc2d ,mpp_maxloc3d 112 END INTERFACE 113 114 INTERFACE mpp_max_multiple 115 MODULE PROCEDURE mppmax_real_multiple 107 116 END INTERFACE 108 117 … … 732 741 ! ----------------------- 733 742 ! 734 DO ii = 1 , num_fields735 743 !First Array 736 IF( npolj /= 0 .AND. .NOT. PRESENT(cd_mpp) ) THEN 737 ! 738 SELECT CASE ( jpni ) 739 CASE ( 1 ) ; CALL lbc_nfd ( pt2d_array(ii)%pt2d( : , : ), type_array(ii) , psgn_array(ii) ) ! only 1 northern proc, no mpp 740 CASE DEFAULT ; CALL mpp_lbc_north( pt2d_array(ii)%pt2d( : , : ), type_array(ii), psgn_array(ii) ) ! for all northern procs. 741 END SELECT 742 ! 743 ENDIF 744 ! 745 END DO 744 IF( npolj /= 0 .AND. .NOT. PRESENT(cd_mpp) ) THEN 745 ! 746 SELECT CASE ( jpni ) 747 CASE ( 1 ) ; 748 DO ii = 1 , num_fields 749 CALL lbc_nfd ( pt2d_array(ii)%pt2d( : , : ), type_array(ii) , psgn_array(ii) ) ! only 1 northern proc, no mpp 750 END DO 751 CASE DEFAULT ; CALL mpp_lbc_north_2d_multiple( pt2d_array, type_array, psgn_array, num_fields ) ! for all northern procs. 752 END SELECT 753 ! 754 ENDIF 755 ! 746 756 747 757 DEALLOCATE( zt2ns, zt2sn, zt2ew, zt2we ) … … 1689 1699 END SUBROUTINE mppmax_real 1690 1700 1701 SUBROUTINE mppmax_real_multiple( ptab, NUM , kcom ) 1702 !!---------------------------------------------------------------------- 1703 !! *** routine mppmax_real *** 1704 !! 1705 !! ** Purpose : Maximum 1706 !! 1707 !!---------------------------------------------------------------------- 1708 REAL(wp), DIMENSION(:) , INTENT(inout) :: ptab ! ??? 1709 INTEGER , INTENT(in ) :: NUM 1710 INTEGER , INTENT(in ), OPTIONAL :: kcom ! ??? 1711 !! 1712 INTEGER :: ierror, localcomm 1713 REAL(wp) , POINTER , DIMENSION(:) :: zwork 1714 !!---------------------------------------------------------------------- 1715 ! 1716 CALL wrk_alloc(NUM , zwork) 1717 localcomm = mpi_comm_opa 1718 IF( PRESENT(kcom) ) localcomm = kcom 1719 ! 1720 CALL mpi_allreduce( ptab, zwork, NUM, mpi_double_precision, mpi_max, localcomm, ierror ) 1721 ptab = zwork 1722 CALL wrk_dealloc(NUM , zwork) 1723 ! 1724 END SUBROUTINE mppmax_real_multiple 1725 1691 1726 1692 1727 SUBROUTINE mppmin_a_real( ptab, kdim, kcom ) … … 2583 2618 END SUBROUTINE mpp_lbc_north_2d 2584 2619 2620 SUBROUTINE mpp_lbc_north_2d_multiple( pt2d_array, cd_type, psgn, num_fields) 2621 !!--------------------------------------------------------------------- 2622 !! *** routine mpp_lbc_north_2d *** 2623 !! 2624 !! ** Purpose : Ensure proper north fold horizontal bondary condition 2625 !! in mpp configuration in case of jpn1 > 1 2626 !! (for multiple 2d arrays ) 2627 !! 2628 !! ** Method : North fold condition and mpp with more than one proc 2629 !! in i-direction require a specific treatment. We gather 2630 !! the 4 northern lines of the global domain on 1 processor 2631 !! and apply lbc north-fold on this sub array. Then we 2632 !! scatter the north fold array back to the processors. 2633 !! 2634 !!---------------------------------------------------------------------- 2635 INTEGER , INTENT (in ) :: num_fields ! number of variables contained in pt2d 2636 TYPE( arrayptr ), DIMENSION(:) :: pt2d_array 2637 CHARACTER(len=1), DIMENSION(:), INTENT(in ) :: cd_type ! nature of pt2d grid-points 2638 ! ! = T , U , V , F or W gridpoints 2639 REAL(wp), DIMENSION(:), INTENT(in ) :: psgn ! = -1. the sign change across the north fold 2640 !! ! = 1. , the sign is kept 2641 INTEGER :: ji, jj, jr, jk 2642 INTEGER :: ierr, itaille, ildi, ilei, iilb 2643 INTEGER :: ijpj, ijpjm1, ij, iproc 2644 INTEGER, DIMENSION (jpmaxngh) :: ml_req_nf !for mpi_isend when avoiding mpi_allgather 2645 INTEGER :: ml_err ! for mpi_isend when avoiding mpi_allgather 2646 INTEGER, DIMENSION(MPI_STATUS_SIZE):: ml_stat ! for mpi_isend when avoiding mpi_allgather 2647 ! ! Workspace for message transfers avoiding mpi_allgather 2648 REAL(wp), DIMENSION(:,:,:) , ALLOCATABLE :: ztab 2649 REAL(wp), DIMENSION(:,:,:) , ALLOCATABLE :: znorthloc, zfoldwk 2650 REAL(wp), DIMENSION(:,:,:,:), ALLOCATABLE :: znorthgloio 2651 REAL(wp), DIMENSION(:,:,:) , ALLOCATABLE :: ztabl, ztabr 2652 INTEGER :: istatus(mpi_status_size) 2653 INTEGER :: iflag 2654 !!---------------------------------------------------------------------- 2655 ! 2656 ALLOCATE( ztab(jpiglo,4,num_fields), znorthloc(jpi,4,num_fields), zfoldwk(jpi,4,num_fields), znorthgloio(jpi,4,num_fields,jpni) ) ! expanded to 3 dimensions 2657 ALLOCATE( ztabl(jpi,4,num_fields), ztabr(jpi*jpmaxngh, 4,num_fields) ) 2658 ! 2659 ijpj = 4 2660 ijpjm1 = 3 2661 ! 2662 2663 DO jk = 1, num_fields 2664 DO jj = nlcj-ijpj+1, nlcj ! put in znorthloc the last 4 jlines of pt2d (for every variable) 2665 ij = jj - nlcj + ijpj 2666 znorthloc(:,ij,jk) = pt2d_array(jk)%pt2d(:,jj) 2667 END DO 2668 END DO 2669 ! ! Build in procs of ncomm_north the znorthgloio 2670 itaille = jpi * ijpj 2671 2672 IF ( l_north_nogather ) THEN 2673 ! 2674 ! Avoid the use of mpi_allgather by exchanging only with the processes already identified 2675 ! (in nemo_northcomms) as being involved in this process' northern boundary exchange 2676 ! 2677 ztabr(:,:,:) = 0 2678 ztabl(:,:,:) = 0 2679 2680 DO jk = 1, num_fields 2681 DO jj = nlcj-ijpj+1, nlcj ! First put local values into the global array 2682 ij = jj - nlcj + ijpj 2683 DO ji = nfsloop, nfeloop 2684 ztabl(ji,ij,jk) = pt2d_array(jk)%pt2d(ji,jj) 2685 END DO 2686 END DO 2687 END DO 2688 2689 DO jr = 1,nsndto 2690 IF ((nfipproc(isendto(jr),jpnj) .ne. (narea-1)) .and. (nfipproc(isendto(jr),jpnj) .ne. -1)) THEN 2691 CALL mppsend(5, znorthloc, itaille*num_fields, nfipproc(isendto(jr),jpnj), ml_req_nf(jr)) ! Buffer expanded "num_fields" times 2692 ENDIF 2693 END DO 2694 DO jr = 1,nsndto 2695 iproc = nfipproc(isendto(jr),jpnj) 2696 IF(iproc .ne. -1) THEN 2697 ilei = nleit (iproc+1) 2698 ildi = nldit (iproc+1) 2699 iilb = nfiimpp(isendto(jr),jpnj) - nfiimpp(isendto(1),jpnj) 2700 ENDIF 2701 IF((iproc .ne. (narea-1)) .and. (iproc .ne. -1)) THEN 2702 CALL mpprecv(5, zfoldwk, itaille*num_fields, iproc) ! Buffer expanded "num_fields" times 2703 DO jk = 1 , num_fields 2704 DO jj = 1, ijpj 2705 DO ji = ildi, ilei 2706 ztabr(iilb+ji,jj,jk) = zfoldwk(ji,jj,jk) ! Modified to 3D 2707 END DO 2708 END DO 2709 END DO 2710 ELSE IF (iproc .eq. (narea-1)) THEN 2711 DO jk = 1, num_fields 2712 DO jj = 1, ijpj 2713 DO ji = ildi, ilei 2714 ztabr(iilb+ji,jj,jk) = pt2d_array(jk)%pt2d(ji,nlcj-ijpj+jj) ! Modified to 3D 2715 END DO 2716 END DO 2717 END DO 2718 ENDIF 2719 END DO 2720 IF (l_isend) THEN 2721 DO jr = 1,nsndto 2722 IF ((nfipproc(isendto(jr),jpnj) .ne. (narea-1)) .and. (nfipproc(isendto(jr),jpnj) .ne. -1)) THEN 2723 CALL mpi_wait(ml_req_nf(jr), ml_stat, ml_err) 2724 ENDIF 2725 END DO 2726 ENDIF 2727 ! 2728 DO ji = 1, num_fields ! Loop to manage 3D variables 2729 CALL mpp_lbc_nfd( ztabl(:,:,ji), ztabr(:,:,ji), cd_type(ji), psgn(ji) ) ! North fold boundary condition 2730 END DO 2731 ! 2732 DO jk = 1, num_fields 2733 DO jj = nlcj-ijpj+1, nlcj ! Scatter back to pt2d 2734 ij = jj - nlcj + ijpj 2735 DO ji = 1, nlci 2736 pt2d_array(jk)%pt2d(ji,jj) = ztabl(ji,ij,jk) ! Modified to 3D 2737 END DO 2738 END DO 2739 END DO 2740 2741 ! 2742 ELSE 2743 ! 2744 CALL MPI_ALLGATHER( znorthloc , itaille*num_fields, MPI_DOUBLE_PRECISION, & 2745 & znorthgloio, itaille*num_fields, MPI_DOUBLE_PRECISION, ncomm_north, ierr ) 2746 ! 2747 ztab(:,:,:) = 0.e0 2748 DO jk = 1, num_fields 2749 DO jr = 1, ndim_rank_north ! recover the global north array 2750 iproc = nrank_north(jr) + 1 2751 ildi = nldit (iproc) 2752 ilei = nleit (iproc) 2753 iilb = nimppt(iproc) 2754 DO jj = 1, ijpj 2755 DO ji = ildi, ilei 2756 ztab(ji+iilb-1,jj,jk) = znorthgloio(ji,jj,jk,jr) 2757 END DO 2758 END DO 2759 END DO 2760 END DO 2761 2762 DO ji = 1, num_fields 2763 CALL lbc_nfd( ztab(:,:,ji), cd_type(ji), psgn(ji) ) ! North fold boundary condition 2764 END DO 2765 ! 2766 DO jk = 1, num_fields 2767 DO jj = nlcj-ijpj+1, nlcj ! Scatter back to pt2d 2768 ij = jj - nlcj + ijpj 2769 DO ji = 1, nlci 2770 pt2d_array(jk)%pt2d(ji,jj) = ztab(ji+nimpp-1,ij,jk) 2771 END DO 2772 END DO 2773 END DO 2774 ! 2775 ! 2776 ENDIF 2777 DEALLOCATE( ztab, znorthloc, zfoldwk, znorthgloio ) 2778 DEALLOCATE( ztabl, ztabr ) 2779 ! 2780 END SUBROUTINE mpp_lbc_north_2d_multiple 2585 2781 2586 2782 SUBROUTINE mpp_lbc_north_e( pt2d, cd_type, psgn)
Note: See TracChangeset
for help on using the changeset viewer.