Changeset 5579 for branches/2015/dev_r5546_CNRS19_HPC_scalability/NEMOGCM/NEMO/OPA_SRC/LBC/lib_mpp.F90
- Timestamp:
- 2015-07-09T18:07:16+02:00 (9 years ago)
- File:
-
- 1 edited
Legend:
- Unmodified
- Added
- Removed
-
branches/2015/dev_r5546_CNRS19_HPC_scalability/NEMOGCM/NEMO/OPA_SRC/LBC/lib_mpp.F90
r5429 r5579 62 62 USE lbcnfd ! north fold treatment 63 63 USE in_out_manager ! I/O manager 64 USE wrk_nemo ! work arrays 64 65 65 66 IMPLICIT NONE … … 70 71 PUBLIC mpp_ini_north, mpp_lbc_north, mpp_lbc_north_e 71 72 PUBLIC mpp_min, mpp_max, mpp_sum, mpp_minloc, mpp_maxloc 73 PUBLIC mpp_max_multiple 72 74 PUBLIC mpp_lnk_3d, mpp_lnk_3d_gather, mpp_lnk_2d, mpp_lnk_2d_e 73 PUBLIC mpp_lnk_2d_9 75 PUBLIC mpp_lnk_2d_9 , mpp_lnk_2d_multiple 74 76 PUBLIC mppscatter, mppgather 75 77 PUBLIC mpp_ini_ice, mpp_ini_znl … … 78 80 PUBLIC mpp_lnk_bdy_2d, mpp_lnk_bdy_3d 79 81 PUBLIC mpp_lbc_north_icb, mpp_lnk_2d_icb 82 PUBLIC mpprank 80 83 81 84 TYPE arrayptr 82 85 REAL , DIMENSION (:,:), POINTER :: pt2d 83 86 END TYPE arrayptr 87 PUBLIC arrayptr 84 88 85 89 !! * Interfaces … … 105 109 INTERFACE mpp_maxloc 106 110 MODULE PROCEDURE mpp_maxloc2d ,mpp_maxloc3d 111 END INTERFACE 112 113 INTERFACE mpp_max_multiple 114 MODULE PROCEDURE mppmax_real_multiple 107 115 END INTERFACE 108 116 … … 724 732 ! ----------------------- 725 733 ! 726 DO ii = 1 , num_fields727 734 !First Array 728 IF( npolj /= 0 .AND. .NOT. PRESENT(cd_mpp) ) THEN 729 ! 730 SELECT CASE ( jpni ) 731 CASE ( 1 ) ; CALL lbc_nfd ( pt2d_array(ii)%pt2d( : , : ), type_array(ii) , psgn_array(ii) ) ! only 1 northern proc, no mpp 732 CASE DEFAULT ; CALL mpp_lbc_north( pt2d_array(ii)%pt2d( : , : ), type_array(ii), psgn_array(ii) ) ! for all northern procs. 733 END SELECT 734 ! 735 ENDIF 736 ! 737 END DO 735 IF( npolj /= 0 .AND. .NOT. PRESENT(cd_mpp) ) THEN 736 ! 737 SELECT CASE ( jpni ) 738 CASE ( 1 ) ; 739 DO ii = 1 , num_fields 740 CALL lbc_nfd ( pt2d_array(ii)%pt2d( : , : ), type_array(ii) , psgn_array(ii) ) ! only 1 northern proc, no mpp 741 END DO 742 CASE DEFAULT ; CALL mpp_lbc_north_2d_multiple( pt2d_array, type_array, psgn_array, num_fields ) ! for all northern procs. 743 END SELECT 744 ! 745 ENDIF 746 ! 738 747 739 748 DEALLOCATE( zt2ns, zt2sn, zt2ew, zt2we ) … … 1681 1690 END SUBROUTINE mppmax_real 1682 1691 1692 SUBROUTINE mppmax_real_multiple( ptab, NUM , kcom ) 1693 !!---------------------------------------------------------------------- 1694 !! *** routine mppmax_real *** 1695 !! 1696 !! ** Purpose : Maximum 1697 !! 1698 !!---------------------------------------------------------------------- 1699 REAL(wp), DIMENSION(:) , INTENT(inout) :: ptab ! ??? 1700 INTEGER , INTENT(in ) :: NUM 1701 INTEGER , INTENT(in ), OPTIONAL :: kcom ! ??? 1702 !! 1703 INTEGER :: ierror, localcomm 1704 REAL(wp) , POINTER , DIMENSION(:) :: zwork 1705 !!---------------------------------------------------------------------- 1706 ! 1707 CALL wrk_alloc(NUM , zwork) 1708 localcomm = mpi_comm_opa 1709 IF( PRESENT(kcom) ) localcomm = kcom 1710 ! 1711 CALL mpi_allreduce( ptab, zwork, NUM, mpi_double_precision, mpi_max, localcomm, ierror ) 1712 ptab = zwork 1713 CALL wrk_dealloc(NUM , zwork) 1714 ! 1715 END SUBROUTINE mppmax_real_multiple 1716 1683 1717 1684 1718 SUBROUTINE mppmin_a_real( ptab, kdim, kcom ) … … 2575 2609 END SUBROUTINE mpp_lbc_north_2d 2576 2610 2611 SUBROUTINE mpp_lbc_north_2d_multiple( pt2d_array, cd_type, psgn, num_fields) 2612 !!--------------------------------------------------------------------- 2613 !! *** routine mpp_lbc_north_2d *** 2614 !! 2615 !! ** Purpose : Ensure proper north fold horizontal bondary condition 2616 !! in mpp configuration in case of jpn1 > 1 2617 !! (for multiple 2d arrays ) 2618 !! 2619 !! ** Method : North fold condition and mpp with more than one proc 2620 !! in i-direction require a specific treatment. We gather 2621 !! the 4 northern lines of the global domain on 1 processor 2622 !! and apply lbc north-fold on this sub array. Then we 2623 !! scatter the north fold array back to the processors. 2624 !! 2625 !!---------------------------------------------------------------------- 2626 INTEGER , INTENT (in ) :: num_fields ! number of variables contained in pt2d 2627 TYPE( arrayptr ), DIMENSION(:) :: pt2d_array 2628 CHARACTER(len=1), DIMENSION(:), INTENT(in ) :: cd_type ! nature of pt2d grid-points 2629 ! ! = T , U , V , F or W gridpoints 2630 REAL(wp), DIMENSION(:), INTENT(in ) :: psgn ! = -1. the sign change across the north fold 2631 !! ! = 1. , the sign is kept 2632 INTEGER :: ji, jj, jr, jk 2633 INTEGER :: ierr, itaille, ildi, ilei, iilb 2634 INTEGER :: ijpj, ijpjm1, ij, iproc 2635 INTEGER, DIMENSION (jpmaxngh) :: ml_req_nf !for mpi_isend when avoiding mpi_allgather 2636 INTEGER :: ml_err ! for mpi_isend when avoiding mpi_allgather 2637 INTEGER, DIMENSION(MPI_STATUS_SIZE):: ml_stat ! for mpi_isend when avoiding mpi_allgather 2638 ! ! Workspace for message transfers avoiding mpi_allgather 2639 REAL(wp), DIMENSION(:,:,:) , ALLOCATABLE :: ztab 2640 REAL(wp), DIMENSION(:,:,:) , ALLOCATABLE :: znorthloc, zfoldwk 2641 REAL(wp), DIMENSION(:,:,:,:), ALLOCATABLE :: znorthgloio 2642 REAL(wp), DIMENSION(:,:,:) , ALLOCATABLE :: ztabl, ztabr 2643 INTEGER :: istatus(mpi_status_size) 2644 INTEGER :: iflag 2645 !!---------------------------------------------------------------------- 2646 ! 2647 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 2648 ALLOCATE( ztabl(jpi,4,num_fields), ztabr(jpi*jpmaxngh, 4,num_fields) ) 2649 ! 2650 ijpj = 4 2651 ijpjm1 = 3 2652 ! 2653 2654 DO jk = 1, num_fields 2655 DO jj = nlcj-ijpj+1, nlcj ! put in znorthloc the last 4 jlines of pt2d (for every variable) 2656 ij = jj - nlcj + ijpj 2657 znorthloc(:,ij,jk) = pt2d_array(jk)%pt2d(:,jj) 2658 END DO 2659 END DO 2660 ! ! Build in procs of ncomm_north the znorthgloio 2661 itaille = jpi * ijpj 2662 2663 IF ( l_north_nogather ) THEN 2664 ! 2665 ! Avoid the use of mpi_allgather by exchanging only with the processes already identified 2666 ! (in nemo_northcomms) as being involved in this process' northern boundary exchange 2667 ! 2668 ztabr(:,:,:) = 0 2669 ztabl(:,:,:) = 0 2670 2671 DO jk = 1, num_fields 2672 DO jj = nlcj-ijpj+1, nlcj ! First put local values into the global array 2673 ij = jj - nlcj + ijpj 2674 DO ji = nfsloop, nfeloop 2675 ztabl(ji,ij,jk) = pt2d_array(jk)%pt2d(ji,jj) 2676 END DO 2677 END DO 2678 END DO 2679 2680 DO jr = 1,nsndto 2681 IF ((nfipproc(isendto(jr),jpnj) .ne. (narea-1)) .and. (nfipproc(isendto(jr),jpnj) .ne. -1)) THEN 2682 CALL mppsend(5, znorthloc, itaille*num_fields, nfipproc(isendto(jr),jpnj), ml_req_nf(jr)) ! Buffer expanded "num_fields" times 2683 ENDIF 2684 END DO 2685 DO jr = 1,nsndto 2686 iproc = nfipproc(isendto(jr),jpnj) 2687 IF(iproc .ne. -1) THEN 2688 ilei = nleit (iproc+1) 2689 ildi = nldit (iproc+1) 2690 iilb = nfiimpp(isendto(jr),jpnj) - nfiimpp(isendto(1),jpnj) 2691 ENDIF 2692 IF((iproc .ne. (narea-1)) .and. (iproc .ne. -1)) THEN 2693 CALL mpprecv(5, zfoldwk, itaille*num_fields, iproc) ! Buffer expanded "num_fields" times 2694 DO jk = 1 , num_fields 2695 DO jj = 1, ijpj 2696 DO ji = ildi, ilei 2697 ztabr(iilb+ji,jj,jk) = zfoldwk(ji,jj,jk) ! Modified to 3D 2698 END DO 2699 END DO 2700 END DO 2701 ELSE IF (iproc .eq. (narea-1)) THEN 2702 DO jk = 1, num_fields 2703 DO jj = 1, ijpj 2704 DO ji = ildi, ilei 2705 ztabr(iilb+ji,jj,jk) = pt2d_array(jk)%pt2d(ji,nlcj-ijpj+jj) ! Modified to 3D 2706 END DO 2707 END DO 2708 END DO 2709 ENDIF 2710 END DO 2711 IF (l_isend) THEN 2712 DO jr = 1,nsndto 2713 IF ((nfipproc(isendto(jr),jpnj) .ne. (narea-1)) .and. (nfipproc(isendto(jr),jpnj) .ne. -1)) THEN 2714 CALL mpi_wait(ml_req_nf(jr), ml_stat, ml_err) 2715 ENDIF 2716 END DO 2717 ENDIF 2718 ! 2719 DO ji = 1, num_fields ! Loop to manage 3D variables 2720 CALL mpp_lbc_nfd( ztabl(:,:,ji), ztabr(:,:,ji), cd_type(ji), psgn(ji) ) ! North fold boundary condition 2721 END DO 2722 ! 2723 DO jk = 1, num_fields 2724 DO jj = nlcj-ijpj+1, nlcj ! Scatter back to pt2d 2725 ij = jj - nlcj + ijpj 2726 DO ji = 1, nlci 2727 pt2d_array(jk)%pt2d(ji,jj) = ztabl(ji,ij,jk) ! Modified to 3D 2728 END DO 2729 END DO 2730 END DO 2731 2732 ! 2733 ELSE 2734 ! 2735 CALL MPI_ALLGATHER( znorthloc , itaille*num_fields, MPI_DOUBLE_PRECISION, & 2736 & znorthgloio, itaille*num_fields, MPI_DOUBLE_PRECISION, ncomm_north, ierr ) 2737 ! 2738 ztab(:,:,:) = 0.e0 2739 DO jk = 1, num_fields 2740 DO jr = 1, ndim_rank_north ! recover the global north array 2741 iproc = nrank_north(jr) + 1 2742 ildi = nldit (iproc) 2743 ilei = nleit (iproc) 2744 iilb = nimppt(iproc) 2745 DO jj = 1, ijpj 2746 DO ji = ildi, ilei 2747 ztab(ji+iilb-1,jj,jk) = znorthgloio(ji,jj,jk,jr) 2748 END DO 2749 END DO 2750 END DO 2751 END DO 2752 2753 DO ji = 1, num_fields 2754 CALL lbc_nfd( ztab(:,:,ji), cd_type(ji), psgn(ji) ) ! North fold boundary condition 2755 END DO 2756 ! 2757 DO jk = 1, num_fields 2758 DO jj = nlcj-ijpj+1, nlcj ! Scatter back to pt2d 2759 ij = jj - nlcj + ijpj 2760 DO ji = 1, nlci 2761 pt2d_array(jk)%pt2d(ji,jj) = ztab(ji+nimpp-1,ij,jk) 2762 END DO 2763 END DO 2764 END DO 2765 ! 2766 ! 2767 ENDIF 2768 DEALLOCATE( ztab, znorthloc, zfoldwk, znorthgloio ) 2769 DEALLOCATE( ztabl, ztabr ) 2770 ! 2771 END SUBROUTINE mpp_lbc_north_2d_multiple 2577 2772 2578 2773 SUBROUTINE mpp_lbc_north_e( pt2d, cd_type, psgn)
Note: See TracChangeset
for help on using the changeset viewer.
