Changeset 7965 for branches/UKMO/dev_r5518_GO6_missing_STABLE_revs/NEMOGCM/NEMO/OPA_SRC/LBC/lib_mpp.F90
- Timestamp:
- 2017-04-25T13:18:30+02:00 (7 years ago)
- File:
-
- 1 edited
Legend:
- Unmodified
- Added
- Removed
-
branches/UKMO/dev_r5518_GO6_missing_STABLE_revs/NEMOGCM/NEMO/OPA_SRC/LBC/lib_mpp.F90
r6487 r7965 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.
