Changeset 5034 for branches/2014/dev_r4650_UKMO14.12_STAND_ALONE_OBSOPER/NEMOGCM/NEMO/OPA_SRC/LBC/lib_mpp.F90
- Timestamp:
- 2015-01-15T14:48:42+01:00 (9 years ago)
- File:
-
- 1 edited
Legend:
- Unmodified
- Added
- Removed
-
branches/2014/dev_r4650_UKMO14.12_STAND_ALONE_OBSOPER/NEMOGCM/NEMO/OPA_SRC/LBC/lib_mpp.F90
r4645 r5034 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 … … 2026 2029 ijpjm1 = 3 2027 2030 ! 2031 znorthloc(:,:,:) = 0 2028 2032 DO jk = 1, jpk 2029 2033 DO jj = nlcj - ijpj +1, nlcj ! put in xnorthloc the last 4 jlines of pt3d … … 2036 2040 itaille = jpi * jpk * ijpj 2037 2041 2038 2039 2042 IF ( l_north_nogather ) THEN 2040 2043 ! 2041 2044 ztabr(:,:,:) = 0 2045 ztabl(:,:,:) = 0 2046 2042 2047 DO jk = 1, jpk 2043 2048 DO jj = nlcj-ijpj+1, nlcj ! First put local values into the global array 2044 2049 ij = jj - nlcj + ijpj 2045 DO ji = 1, nlci2050 DO ji = nfsloop, nfeloop 2046 2051 ztabl(ji,ij,jk) = pt3d(ji,jj,jk) 2047 2052 END DO … … 2050 2055 2051 2056 DO jr = 1,nsndto 2052 IF (isendto(jr) .ne. narea) CALL mppsend( 5, znorthloc, itaille, isendto(jr)-1, ml_req_nf(jr) ) 2057 IF ((nfipproc(isendto(jr),jpnj) .ne. (narea-1)) .and. (nfipproc(isendto(jr),jpnj) .ne. -1)) THEN 2058 CALL mppsend( 5, znorthloc, itaille, nfipproc(isendto(jr),jpnj), ml_req_nf(jr) ) 2059 ENDIF 2053 2060 END DO 2054 2061 DO jr = 1,nsndto 2055 iproc = isendto(jr) 2056 ildi = nldit (iproc) 2057 ilei = nleit (iproc) 2058 iilb = nimppt(isendto(jr)) - nimppt(isendto(1)) 2059 IF(isendto(jr) .ne. narea) THEN 2060 CALL mpprecv(5, zfoldwk, itaille, isendto(jr)-1) 2062 iproc = nfipproc(isendto(jr),jpnj) 2063 IF(iproc .ne. -1) THEN 2064 ilei = nleit (iproc+1) 2065 ildi = nldit (iproc+1) 2066 iilb = nfiimpp(isendto(jr),jpnj) - nfiimpp(isendto(1),jpnj) 2067 ENDIF 2068 IF((iproc .ne. (narea-1)) .and. (iproc .ne. -1)) THEN 2069 CALL mpprecv(5, zfoldwk, itaille, iproc) 2061 2070 DO jk = 1, jpk 2062 2071 DO jj = 1, ijpj 2063 DO ji = 1, ilei2072 DO ji = ildi, ilei 2064 2073 ztabr(iilb+ji,jj,jk) = zfoldwk(ji,jj,jk) 2065 2074 END DO 2066 2075 END DO 2067 2076 END DO 2068 ELSE 2077 ELSE IF (iproc .eq. (narea-1)) THEN 2069 2078 DO jk = 1, jpk 2070 2079 DO jj = 1, ijpj 2071 DO ji = 1, ilei2080 DO ji = ildi, ilei 2072 2081 ztabr(iilb+ji,jj,jk) = pt3d(ji,nlcj-ijpj+jj,jk) 2073 2082 END DO … … 2078 2087 IF (l_isend) THEN 2079 2088 DO jr = 1,nsndto 2080 IF (isendto(jr) .ne. narea) CALL mpi_wait(ml_req_nf(jr), ml_stat, ml_err) 2089 IF ((nfipproc(isendto(jr),jpnj) .ne. (narea-1)) .and. (nfipproc(isendto(jr),jpnj) .ne. -1)) THEN 2090 CALL mpi_wait(ml_req_nf(jr), ml_stat, ml_err) 2091 ENDIF 2081 2092 END DO 2082 2093 ENDIF 2083 2094 CALL mpp_lbc_nfd( ztabl, ztabr, cd_type, psgn ) ! North fold boundary condition 2084 !2085 2095 DO jk = 1, jpk 2086 2096 DO jj = nlcj-ijpj+1, nlcj ! Scatter back to pt3d … … 2190 2200 ! 2191 2201 ztabr(:,:) = 0 2202 ztabl(:,:) = 0 2203 2192 2204 DO jj = nlcj-ijpj+1, nlcj ! First put local values into the global array 2193 2205 ij = jj - nlcj + ijpj 2194 DO ji = 1, nlci2206 DO ji = nfsloop, nfeloop 2195 2207 ztabl(ji,ij) = pt2d(ji,jj) 2196 2208 END DO … … 2198 2210 2199 2211 DO jr = 1,nsndto 2200 IF (isendto(jr) .ne. narea) CALL mppsend(5, znorthloc, itaille, isendto(jr)-1, ml_req_nf(jr)) 2212 IF ((nfipproc(isendto(jr),jpnj) .ne. (narea-1)) .and. (nfipproc(isendto(jr),jpnj) .ne. -1)) THEN 2213 CALL mppsend(5, znorthloc, itaille, nfipproc(isendto(jr),jpnj), ml_req_nf(jr)) 2214 ENDIF 2201 2215 END DO 2202 2216 DO jr = 1,nsndto 2203 iproc = isendto(jr) 2204 ildi = nldit (iproc) 2205 ilei = nleit (iproc) 2206 iilb = nimppt(isendto(jr)) - nimppt(isendto(1)) 2207 IF(isendto(jr) .ne. narea) THEN 2208 CALL mpprecv(5, zfoldwk, itaille, isendto(jr)-1) 2217 iproc = nfipproc(isendto(jr),jpnj) 2218 IF(iproc .ne. -1) THEN 2219 ilei = nleit (iproc+1) 2220 ildi = nldit (iproc+1) 2221 iilb = nfiimpp(isendto(jr),jpnj) - nfiimpp(isendto(1),jpnj) 2222 ENDIF 2223 IF((iproc .ne. (narea-1)) .and. (iproc .ne. -1)) THEN 2224 CALL mpprecv(5, zfoldwk, itaille, iproc) 2209 2225 DO jj = 1, ijpj 2210 DO ji = 1, ilei2226 DO ji = ildi, ilei 2211 2227 ztabr(iilb+ji,jj) = zfoldwk(ji,jj) 2212 2228 END DO 2213 2229 END DO 2214 ELSE 2230 ELSE IF (iproc .eq. (narea-1)) THEN 2215 2231 DO jj = 1, ijpj 2216 DO ji = 1, ilei2232 DO ji = ildi, ilei 2217 2233 ztabr(iilb+ji,jj) = pt2d(ji,nlcj-ijpj+jj) 2218 2234 END DO … … 2222 2238 IF (l_isend) THEN 2223 2239 DO jr = 1,nsndto 2224 IF (isendto(jr) .ne. narea) CALL mpi_wait(ml_req_nf(jr), ml_stat, ml_err) 2240 IF ((nfipproc(isendto(jr),jpnj) .ne. (narea-1)) .and. (nfipproc(isendto(jr),jpnj) .ne. -1)) THEN 2241 CALL mpi_wait(ml_req_nf(jr), ml_stat, ml_err) 2242 ENDIF 2225 2243 END DO 2226 2244 ENDIF … … 2878 2896 END SUBROUTINE DDPDD_MPI 2879 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 2880 3161 #else 2881 3162 !!----------------------------------------------------------------------
Note: See TracChangeset
for help on using the changeset viewer.