Changeset 4990 for trunk/NEMOGCM/NEMO/OPA_SRC/LBC/lib_mpp.F90
- Timestamp:
- 2014-12-15T17:42:49+01:00 (9 years ago)
- File:
-
- 1 edited
Legend:
- Unmodified
- Added
- Removed
-
trunk/NEMOGCM/NEMO/OPA_SRC/LBC/lib_mpp.F90
r4765 r4990 42 42 !! mpp_lnk_3d_gather : Message passing manadgement for two 3D arrays 43 43 !! mpp_lnk_e : interface (defined in lbclnk) for message passing of 2d array with extra halo (mpp_lnk_2d_e) 44 !! mpp_lnk_icb : interface for message passing of 2d arrays with extra halo for icebergs (mpp_lnk_2d_icb) 44 45 !! mpprecv : 45 46 !! mppsend : SUBROUTINE mpp_ini_znl … … 56 57 !! mpp_lbc_north : north fold processors gathering 57 58 !! mpp_lbc_north_e : variant of mpp_lbc_north for extra outer halo 59 !! mpp_lbc_north_icb : variant of mpp_lbc_north for extra outer halo with icebergs 58 60 !!---------------------------------------------------------------------- 59 61 USE dom_oce ! ocean space and time domain … … 74 76 PUBLIC mppsend, mpprecv ! needed by TAM and ICB routines 75 77 PUBLIC mpp_lnk_bdy_2d, mpp_lnk_bdy_3d 78 PUBLIC mpp_lbc_north_icb, mpp_lnk_2d_icb 76 79 77 80 !! * Interfaces … … 2893 2896 END SUBROUTINE DDPDD_MPI 2894 2897 2898 SUBROUTINE mpp_lbc_north_icb( pt2d, cd_type, psgn, pr2dj) 2899 !!--------------------------------------------------------------------- 2900 !! *** routine mpp_lbc_north_icb *** 2901 !! 2902 !! ** Purpose : Ensure proper north fold horizontal bondary condition 2903 !! in mpp configuration in case of jpn1 > 1 and for 2d 2904 !! array with outer extra halo 2905 !! 2906 !! ** Method : North fold condition and mpp with more than one proc 2907 !! in i-direction require a specific treatment. We gather 2908 !! the 4+2*jpr2dj northern lines of the global domain on 1 2909 !! processor and apply lbc north-fold on this sub array. 2910 !! Then we scatter the north fold array back to the processors. 2911 !! This version accounts for an extra halo with icebergs. 2912 !! 2913 !!---------------------------------------------------------------------- 2914 REAL(wp), DIMENSION(:,:), INTENT(inout) :: pt2d ! 2D array with extra halo 2915 CHARACTER(len=1) , INTENT(in ) :: cd_type ! nature of pt3d grid-points 2916 ! ! = T , U , V , F or W -points 2917 REAL(wp) , INTENT(in ) :: psgn ! = -1. the sign change across the 2918 !! ! north fold, = 1. otherwise 2919 INTEGER, OPTIONAL , INTENT(in ) :: pr2dj 2920 INTEGER :: ji, jj, jr 2921 INTEGER :: ierr, itaille, ildi, ilei, iilb 2922 INTEGER :: ijpj, ij, iproc, ipr2dj 2923 ! 2924 REAL(wp), DIMENSION(:,:) , ALLOCATABLE :: ztab_e, znorthloc_e 2925 REAL(wp), DIMENSION(:,:,:), ALLOCATABLE :: znorthgloio_e 2926 2927 !!---------------------------------------------------------------------- 2928 ! 2929 ijpj=4 2930 IF( PRESENT(pr2dj) ) THEN ! use of additional halos 2931 ipr2dj = pr2dj 2932 ELSE 2933 ipr2dj = 0 2934 ENDIF 2935 ALLOCATE( ztab_e(jpiglo,4+2*ipr2dj), znorthloc_e(jpi,4+2*ipr2dj), znorthgloio_e(jpi,4+2*ipr2dj,jpni) ) 2936 2937 ! 2938 ztab_e(:,:) = 0.e0 2939 2940 ij=0 2941 ! put in znorthloc_e the last 4 jlines of pt2d 2942 DO jj = nlcj - ijpj + 1 - ipr2dj, nlcj +ipr2dj 2943 ij = ij + 1 2944 DO ji = 1, jpi 2945 znorthloc_e(ji,ij)=pt2d(ji,jj) 2946 END DO 2947 END DO 2948 ! 2949 itaille = jpi * ( ijpj + 2 * ipr2dj ) 2950 CALL MPI_ALLGATHER( znorthloc_e(1,1) , itaille, MPI_DOUBLE_PRECISION, & 2951 & znorthgloio_e(1,1,1), itaille, MPI_DOUBLE_PRECISION, ncomm_north, ierr ) 2952 ! 2953 DO jr = 1, ndim_rank_north ! recover the global north array 2954 iproc = nrank_north(jr) + 1 2955 ildi = nldit (iproc) 2956 ilei = nleit (iproc) 2957 iilb = nimppt(iproc) 2958 DO jj = 1, ijpj+2*ipr2dj 2959 DO ji = ildi, ilei 2960 ztab_e(ji+iilb-1,jj) = znorthgloio_e(ji,jj,jr) 2961 END DO 2962 END DO 2963 END DO 2964 2965 2966 ! 2. North-Fold boundary conditions 2967 ! ---------------------------------- 2968 CALL lbc_nfd( ztab_e(:,:), cd_type, psgn, pr2dj = ipr2dj ) 2969 2970 ij = ipr2dj 2971 !! Scatter back to pt2d 2972 DO jj = nlcj - ijpj + 1 , nlcj +ipr2dj 2973 ij = ij +1 2974 DO ji= 1, nlci 2975 pt2d(ji,jj) = ztab_e(ji+nimpp-1,ij) 2976 END DO 2977 END DO 2978 ! 2979 DEALLOCATE( ztab_e, znorthloc_e, znorthgloio_e ) 2980 ! 2981 END SUBROUTINE mpp_lbc_north_icb 2982 2983 SUBROUTINE mpp_lnk_2d_icb( pt2d, cd_type, psgn, jpri, jprj ) 2984 !!---------------------------------------------------------------------- 2985 !! *** routine mpp_lnk_2d_icb *** 2986 !! 2987 !! ** Purpose : Message passing manadgement for 2d array (with extra halo and icebergs) 2988 !! 2989 !! ** Method : Use mppsend and mpprecv function for passing mask 2990 !! between processors following neighboring subdomains. 2991 !! domain parameters 2992 !! nlci : first dimension of the local subdomain 2993 !! nlcj : second dimension of the local subdomain 2994 !! jpri : number of rows for extra outer halo 2995 !! jprj : number of columns for extra outer halo 2996 !! nbondi : mark for "east-west local boundary" 2997 !! nbondj : mark for "north-south local boundary" 2998 !! noea : number for local neighboring processors 2999 !! nowe : number for local neighboring processors 3000 !! noso : number for local neighboring processors 3001 !! nono : number for local neighboring processors 3002 !! 3003 !!---------------------------------------------------------------------- 3004 INTEGER , INTENT(in ) :: jpri 3005 INTEGER , INTENT(in ) :: jprj 3006 REAL(wp), DIMENSION(1-jpri:jpi+jpri,1-jprj:jpj+jprj), INTENT(inout) :: pt2d ! 2D array with extra halo 3007 CHARACTER(len=1) , INTENT(in ) :: cd_type ! nature of ptab array grid-points 3008 ! ! = T , U , V , F , W and I points 3009 REAL(wp) , INTENT(in ) :: psgn ! =-1 the sign change across the 3010 !! ! north boundary, = 1. otherwise 3011 INTEGER :: jl ! dummy loop indices 3012 INTEGER :: imigr, iihom, ijhom ! temporary integers 3013 INTEGER :: ipreci, iprecj ! temporary integers 3014 INTEGER :: ml_req1, ml_req2, ml_err ! for key_mpi_isend 3015 INTEGER, DIMENSION(MPI_STATUS_SIZE) :: ml_stat ! for key_mpi_isend 3016 !! 3017 REAL(wp), DIMENSION(1-jpri:jpi+jpri,jprecj+jprj,2) :: r2dns 3018 REAL(wp), DIMENSION(1-jpri:jpi+jpri,jprecj+jprj,2) :: r2dsn 3019 REAL(wp), DIMENSION(1-jprj:jpj+jprj,jpreci+jpri,2) :: r2dwe 3020 REAL(wp), DIMENSION(1-jprj:jpj+jprj,jpreci+jpri,2) :: r2dew 3021 !!---------------------------------------------------------------------- 3022 3023 ipreci = jpreci + jpri ! take into account outer extra 2D overlap area 3024 iprecj = jprecj + jprj 3025 3026 3027 ! 1. standard boundary treatment 3028 ! ------------------------------ 3029 ! Order matters Here !!!! 3030 ! 3031 ! ! East-West boundaries 3032 ! !* Cyclic east-west 3033 IF( nbondi == 2 .AND. (nperio == 1 .OR. nperio == 4 .OR. nperio == 6) ) THEN 3034 pt2d(1-jpri: 1 ,:) = pt2d(jpim1-jpri: jpim1 ,:) ! east 3035 pt2d( jpi :jpi+jpri,:) = pt2d( 2 :2+jpri,:) ! west 3036 ! 3037 ELSE !* closed 3038 IF( .NOT. cd_type == 'F' ) pt2d( 1-jpri :jpreci ,:) = 0.e0 ! south except at F-point 3039 pt2d(nlci-jpreci+1:jpi+jpri,:) = 0.e0 ! north 3040 ENDIF 3041 ! 3042 3043 ! north fold treatment 3044 ! ----------------------- 3045 IF( npolj /= 0 ) THEN 3046 ! 3047 SELECT CASE ( jpni ) 3048 CASE ( 1 ) ; CALL lbc_nfd ( pt2d(1:jpi,1:jpj+jprj), cd_type, psgn, pr2dj=jprj ) 3049 CASE DEFAULT ; CALL mpp_lbc_north_icb( pt2d(1:jpi,1:jpj+jprj) , cd_type, psgn , pr2dj=jprj ) 3050 END SELECT 3051 ! 3052 ENDIF 3053 3054 ! 2. East and west directions exchange 3055 ! ------------------------------------ 3056 ! we play with the neigbours AND the row number because of the periodicity 3057 ! 3058 SELECT CASE ( nbondi ) ! Read Dirichlet lateral conditions 3059 CASE ( -1, 0, 1 ) ! all exept 2 (i.e. close case) 3060 iihom = nlci-nreci-jpri 3061 DO jl = 1, ipreci 3062 r2dew(:,jl,1) = pt2d(jpreci+jl,:) 3063 r2dwe(:,jl,1) = pt2d(iihom +jl,:) 3064 END DO 3065 END SELECT 3066 ! 3067 ! ! Migrations 3068 imigr = ipreci * ( jpj + 2*jprj) 3069 ! 3070 SELECT CASE ( nbondi ) 3071 CASE ( -1 ) 3072 CALL mppsend( 2, r2dwe(1-jprj,1,1), imigr, noea, ml_req1 ) 3073 CALL mpprecv( 1, r2dew(1-jprj,1,2), imigr, noea ) 3074 IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err) 3075 CASE ( 0 ) 3076 CALL mppsend( 1, r2dew(1-jprj,1,1), imigr, nowe, ml_req1 ) 3077 CALL mppsend( 2, r2dwe(1-jprj,1,1), imigr, noea, ml_req2 ) 3078 CALL mpprecv( 1, r2dew(1-jprj,1,2), imigr, noea ) 3079 CALL mpprecv( 2, r2dwe(1-jprj,1,2), imigr, nowe ) 3080 IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err) 3081 IF(l_isend) CALL mpi_wait(ml_req2,ml_stat,ml_err) 3082 CASE ( 1 ) 3083 CALL mppsend( 1, r2dew(1-jprj,1,1), imigr, nowe, ml_req1 ) 3084 CALL mpprecv( 2, r2dwe(1-jprj,1,2), imigr, nowe ) 3085 IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err) 3086 END SELECT 3087 ! 3088 ! ! Write Dirichlet lateral conditions 3089 iihom = nlci - jpreci 3090 ! 3091 SELECT CASE ( nbondi ) 3092 CASE ( -1 ) 3093 DO jl = 1, ipreci 3094 pt2d(iihom+jl,:) = r2dew(:,jl,2) 3095 END DO 3096 CASE ( 0 ) 3097 DO jl = 1, ipreci 3098 pt2d(jl-jpri,:) = r2dwe(:,jl,2) 3099 pt2d( iihom+jl,:) = r2dew(:,jl,2) 3100 END DO 3101 CASE ( 1 ) 3102 DO jl = 1, ipreci 3103 pt2d(jl-jpri,:) = r2dwe(:,jl,2) 3104 END DO 3105 END SELECT 3106 3107 3108 ! 3. North and south directions 3109 ! ----------------------------- 3110 ! always closed : we play only with the neigbours 3111 ! 3112 IF( nbondj /= 2 ) THEN ! Read Dirichlet lateral conditions 3113 ijhom = nlcj-nrecj-jprj 3114 DO jl = 1, iprecj 3115 r2dsn(:,jl,1) = pt2d(:,ijhom +jl) 3116 r2dns(:,jl,1) = pt2d(:,jprecj+jl) 3117 END DO 3118 ENDIF 3119 ! 3120 ! ! Migrations 3121 imigr = iprecj * ( jpi + 2*jpri ) 3122 ! 3123 SELECT CASE ( nbondj ) 3124 CASE ( -1 ) 3125 CALL mppsend( 4, r2dsn(1-jpri,1,1), imigr, nono, ml_req1 ) 3126 CALL mpprecv( 3, r2dns(1-jpri,1,2), imigr, nono ) 3127 IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err) 3128 CASE ( 0 ) 3129 CALL mppsend( 3, r2dns(1-jpri,1,1), imigr, noso, ml_req1 ) 3130 CALL mppsend( 4, r2dsn(1-jpri,1,1), imigr, nono, ml_req2 ) 3131 CALL mpprecv( 3, r2dns(1-jpri,1,2), imigr, nono ) 3132 CALL mpprecv( 4, r2dsn(1-jpri,1,2), imigr, noso ) 3133 IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err) 3134 IF(l_isend) CALL mpi_wait(ml_req2,ml_stat,ml_err) 3135 CASE ( 1 ) 3136 CALL mppsend( 3, r2dns(1-jpri,1,1), imigr, noso, ml_req1 ) 3137 CALL mpprecv( 4, r2dsn(1-jpri,1,2), imigr, noso ) 3138 IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err) 3139 END SELECT 3140 ! 3141 ! ! Write Dirichlet lateral conditions 3142 ijhom = nlcj - jprecj 3143 ! 3144 SELECT CASE ( nbondj ) 3145 CASE ( -1 ) 3146 DO jl = 1, iprecj 3147 pt2d(:,ijhom+jl) = r2dns(:,jl,2) 3148 END DO 3149 CASE ( 0 ) 3150 DO jl = 1, iprecj 3151 pt2d(:,jl-jprj) = r2dsn(:,jl,2) 3152 pt2d(:,ijhom+jl ) = r2dns(:,jl,2) 3153 END DO 3154 CASE ( 1 ) 3155 DO jl = 1, iprecj 3156 pt2d(:,jl-jprj) = r2dsn(:,jl,2) 3157 END DO 3158 END SELECT 3159 3160 END SUBROUTINE mpp_lnk_2d_icb 2895 3161 #else 2896 3162 !!----------------------------------------------------------------------
Note: See TracChangeset
for help on using the changeset viewer.