- Timestamp:
- 2017-12-13T15:58:53+01:00 (6 years ago)
- File:
-
- 1 edited
Legend:
- Unmodified
- Added
- Removed
-
branches/2017/dev_merge_2017/NEMOGCM/NEMO/NST_SRC/agrif_lim3_interp.F90
r7761 r9019 28 28 PRIVATE 29 29 30 PUBLIC agrif_interp_lim330 PUBLIC agrif_interp_lim3 ! called by agrif_user.F90 31 31 32 32 !!---------------------------------------------------------------------- … … 46 46 !! computing factor for time interpolation 47 47 !!----------------------------------------------------------------------- 48 CHARACTER(len=1), INTENT( in ) ::cd_type49 INTEGER , INTENT( in ), OPTIONAL ::kiter, kitermax50 !! 51 REAL(wp) :: zbeta52 !!----------------------------------------------------------------------- 53 ! 54 IF( Agrif_Root() ) RETURN55 ! 56 SELECT CASE( cd_type)48 CHARACTER(len=1), INTENT(in ) :: cd_type 49 INTEGER , INTENT(in ), OPTIONAL :: kiter, kitermax 50 !! 51 REAL(wp) :: zbeta ! local scalar 52 !!----------------------------------------------------------------------- 53 ! 54 IF( Agrif_Root() .OR. nn_ice==0 ) RETURN ! do not interpolate if inside Parent domain or if child domain does not have ice 55 ! 56 SELECT CASE( cd_type ) 57 57 CASE('U','V') 58 58 IF( PRESENT( kiter ) ) THEN ! interpolation at the child sub-time step (only for ice rheology) … … 66 66 END SELECT 67 67 ! 68 Agrif_SpecialValue =-9999.68 Agrif_SpecialValue = -9999. 69 69 Agrif_UseSpecialValue = .TRUE. 70 SELECT CASE(cd_type) 71 CASE('U') 72 CALL Agrif_Bc_variable( u_ice_id , procname=interp_u_ice , calledweight=zbeta ) 73 CASE('V') 74 CALL Agrif_Bc_variable( v_ice_id , procname=interp_v_ice , calledweight=zbeta ) 75 CASE('T') 76 CALL Agrif_Bc_variable( tra_ice_id, procname=interp_tra_ice, calledweight=zbeta ) 70 SELECT CASE( cd_type ) 71 CASE('U') ; CALL Agrif_Bc_variable( u_ice_id , procname=interp_u_ice , calledweight=zbeta ) 72 CASE('V') ; CALL Agrif_Bc_variable( v_ice_id , procname=interp_v_ice , calledweight=zbeta ) 73 CASE('T') ; CALL Agrif_Bc_variable( tra_ice_id, procname=interp_tra_ice, calledweight=zbeta ) 77 74 END SELECT 78 Agrif_SpecialValue =0.75 Agrif_SpecialValue = 0._wp 79 76 Agrif_UseSpecialValue = .FALSE. 80 77 ! 81 78 END SUBROUTINE agrif_interp_lim3 82 79 83 !!------------------ 84 !! Local subroutines 85 !!------------------ 80 86 81 SUBROUTINE interp_u_ice( ptab, i1, i2, j1, j2, before ) 87 82 !!----------------------------------------------------------------------- … … 89 84 !! 90 85 !! i1 i2 j1 j2 are the index of the boundaries parent(when before) and child (when after) 91 !! To solve issues when parent grid is "land" masked but not all the corresponding child grid points, 92 !! put -9999 WHERE the parent grid is masked. The child solution will be found in the 9(?) points around 93 !!----------------------------------------------------------------------- 94 INTEGER , INTENT(in) :: i1, i2, j1, j2 95 REAL(wp), DIMENSION(i1:i2,j1:j2), INTENT(inout) :: ptab 96 LOGICAL , INTENT(in) :: before 97 !! 98 REAL(wp) :: zrhoy 86 !! To solve issues when parent grid is "land" masked but not all the corresponding child 87 !! grid points, put Agrif_SpecialValue WHERE the parent grid is masked. 88 !! The child solution will be found in the 9(?) points around 89 !!----------------------------------------------------------------------- 90 INTEGER , INTENT(in ) :: i1, i2, j1, j2 91 REAL(wp), DIMENSION(i1:i2,j1:j2), INTENT(inout) :: ptab 92 LOGICAL , INTENT(in ) :: before 93 !! 94 REAL(wp) :: zrhoy ! local scalar 99 95 !!----------------------------------------------------------------------- 100 96 ! 101 97 IF( before ) THEN ! parent grid 102 98 ptab(:,:) = e2u(i1:i2,j1:j2) * u_ice_b(i1:i2,j1:j2) 103 WHERE( umask(i1:i2,j1:j2,1) == 0. ) ptab(:,:) = -9999.99 WHERE( umask(i1:i2,j1:j2,1) == 0. ) ptab(i1:i2,j1:j2) = Agrif_SpecialValue 104 100 ELSE ! child grid 105 101 zrhoy = Agrif_Rhoy() 106 u_ice(i1:i2,j1:j2) = ptab( :,:) / ( e2u(i1:i2,j1:j2) * zrhoy ) * umask(i1:i2,j1:j2,1)102 u_ice(i1:i2,j1:j2) = ptab(i1:i2,j1:j2) / ( e2u(i1:i2,j1:j2) * zrhoy ) * umask(i1:i2,j1:j2,1) 107 103 ENDIF 108 104 ! … … 115 111 !! 116 112 !! i1 i2 j1 j2 are the index of the boundaries parent(when before) and child (when after) 117 !! To solve issues when parent grid is "land" masked but not all the corresponding child grid points, 118 !! put -9999 WHERE the parent grid is masked. The child solution will be found in the 9(?) points around 113 !! To solve issues when parent grid is "land" masked but not all the corresponding child 114 !! grid points, put Agrif_SpecialValue WHERE the parent grid is masked. 115 !! The child solution will be found in the 9(?) points around 119 116 !!----------------------------------------------------------------------- 120 INTEGER , INTENT(in) ::i1, i2, j1, j2121 REAL(wp), DIMENSION(i1:i2,j1:j2), INTENT(inout) :: ptab122 LOGICAL , INTENT(in) ::before123 !! 124 REAL(wp) :: zrhox117 INTEGER , INTENT(in ) :: i1, i2, j1, j2 118 REAL(wp), DIMENSION(i1:i2,j1:j2), INTENT(inout) :: ptab 119 LOGICAL , INTENT(in ) :: before 120 !! 121 REAL(wp) :: zrhox ! local scalar 125 122 !!----------------------------------------------------------------------- 126 123 ! 127 124 IF( before ) THEN ! parent grid 128 125 ptab(:,:) = e1v(i1:i2,j1:j2) * v_ice_b(i1:i2,j1:j2) 129 WHERE( vmask(i1:i2,j1:j2,1) == 0. ) ptab(:,:) = -9999.126 WHERE( vmask(i1:i2,j1:j2,1) == 0. ) ptab(i1:i2,j1:j2) = Agrif_SpecialValue 130 127 ELSE ! child grid 131 128 zrhox = Agrif_Rhox() 132 v_ice(i1:i2,j1:j2) = ptab( :,:) / ( e1v(i1:i2,j1:j2) * zrhox ) * vmask(i1:i2,j1:j2,1)129 v_ice(i1:i2,j1:j2) = ptab(i1:i2,j1:j2) / ( e1v(i1:i2,j1:j2) * zrhox ) * vmask(i1:i2,j1:j2,1) 133 130 ENDIF 134 131 ! … … 141 138 !! 142 139 !! i1 i2 j1 j2 are the index of the boundaries parent(when before) and child (when after) 143 !! To solve issues when parent grid is "land" masked but not all the corresponding child grid points,144 !! put -9999 WHERE the parent grid is masked. The child solution will be found in the 9(?) points around145 !! -----------------------------------------------------------------------146 REAL(wp), DIMENSION(i1:i2,j1:j2,k1:k2), INTENT(inout) :: ptab147 INTEGER , INTENT(in) :: i1, i2, j1, j2, k1, k2148 LOGICAL , INTENT(in) :: before149 INTEGER , INTENT(in) :: nb, ndir150 !!151 REAL(wp), DIMENSION(:,:,:), ALLOCATABLE :: ztab140 !! To solve issues when parent grid is "land" masked but not all the corresponding child 141 !! grid points, put Agrif_SpecialValue WHERE the parent grid is masked. 142 !! The child solution will be found in the 9(?) points around 143 !!----------------------------------------------------------------------- 144 REAL(wp), DIMENSION(i1:i2,j1:j2,k1:k2), INTENT(inout) :: ptab 145 INTEGER , INTENT(in ) :: i1, i2, j1, j2, k1, k2 146 LOGICAL , INTENT(in ) :: before 147 INTEGER , INTENT(in ) :: nb, ndir 148 !! 152 149 INTEGER :: ji, jj, jk, jl, jm 153 150 INTEGER :: imin, imax, jmin, jmax 151 LOGICAL :: western_side, eastern_side, northern_side, southern_side 154 152 REAL(wp) :: zrhox, z1, z2, z3, z4, z5, z6, z7 155 LOGICAL :: western_side, eastern_side, northern_side, southern_side 156 157 !!----------------------------------------------------------------------- 158 ! tracers are not multiplied by grid cell here => before: * e12t ; after: * r1_e12t / rhox / rhoy 153 REAL(wp), DIMENSION(:,:,:), ALLOCATABLE :: ztab 154 !!----------------------------------------------------------------------- 155 ! tracers are not multiplied by grid cell here => before: * e1e2t ; after: * r1_e1e2t / rhox / rhoy 159 156 ! and it is ok since we conserve tracers (same as in the ocean). 160 ALLOCATE( ztab(SIZE(a_i _b,1),SIZE(a_i_b,2),SIZE(ptab,3)) )157 ALLOCATE( ztab(SIZE(a_i,1),SIZE(a_i,2),SIZE(ptab,3)) ) 161 158 162 159 IF( before ) THEN ! parent grid 163 160 jm = 1 164 161 DO jl = 1, jpl 165 ptab(i1:i2,j1:j2,jm) = a_i_b (i1:i2,j1:j2,jl) ; jm = jm + 1 166 ptab(i1:i2,j1:j2,jm) = v_i_b (i1:i2,j1:j2,jl) ; jm = jm + 1 167 ptab(i1:i2,j1:j2,jm) = v_s_b (i1:i2,j1:j2,jl) ; jm = jm + 1 168 ptab(i1:i2,j1:j2,jm) = smv_i_b(i1:i2,j1:j2,jl) ; jm = jm + 1 169 ptab(i1:i2,j1:j2,jm) = oa_i_b (i1:i2,j1:j2,jl) ; jm = jm + 1 162 ptab(i1:i2,j1:j2,jm ) = a_i_b (i1:i2,j1:j2,jl) 163 ptab(i1:i2,j1:j2,jm+1) = v_i_b (i1:i2,j1:j2,jl) 164 ptab(i1:i2,j1:j2,jm+2) = v_s_b (i1:i2,j1:j2,jl) 165 ptab(i1:i2,j1:j2,jm+3) = sv_i_b(i1:i2,j1:j2,jl) 166 ptab(i1:i2,j1:j2,jm+4) = oa_i_b(i1:i2,j1:j2,jl) 167 jm = jm + 5 170 168 DO jk = 1, nlay_s 171 ptab(i1:i2,j1:j2,jm) = e_s_b(i1:i2,j1:j2,jk,jl) ;jm = jm + 1172 END DO169 ptab(i1:i2,j1:j2,jm) = e_s_b(i1:i2,j1:j2,jk,jl) ; jm = jm + 1 170 END DO 173 171 DO jk = 1, nlay_i 174 ptab(i1:i2,j1:j2,jm) = e_i_b(i1:i2,j1:j2,jk,jl) ;jm = jm + 1175 END DO176 END DO172 ptab(i1:i2,j1:j2,jm) = e_i_b(i1:i2,j1:j2,jk,jl) ; jm = jm + 1 173 END DO 174 END DO 177 175 178 176 DO jk = k1, k2 179 WHERE( tmask(i1:i2,j1:j2,1) == 0. ) ptab(i1:i2,j1:j2,jk) = -9999. 180 ENDDO 177 WHERE( tmask(i1:i2,j1:j2,1) == 0._wp ) ptab(i1:i2,j1:j2,jk) = Agrif_SpecialValue 178 END DO 179 ! 180 ELSE ! child grid 181 ! 182 IF( nbghostcells > 1 ) THEN ! ==> The easiest interpolation is used 183 ! 184 jm = 1 185 DO jl = 1, jpl 186 ! 187 DO jj = j1, j2 188 DO ji = i1, i2 189 a_i (ji,jj,jl) = ptab(ji,jj,jm ) * tmask(ji,jj,1) 190 v_i (ji,jj,jl) = ptab(ji,jj,jm+1) * tmask(ji,jj,1) 191 v_s (ji,jj,jl) = ptab(ji,jj,jm+2) * tmask(ji,jj,1) 192 sv_i(ji,jj,jl) = ptab(ji,jj,jm+3) * tmask(ji,jj,1) 193 oa_i(ji,jj,jl) = ptab(ji,jj,jm+4) * tmask(ji,jj,1) 194 END DO 195 END DO 196 jm = jm + 5 197 ! 198 DO jk = 1, nlay_s 199 e_s(i1:i2,j1:j2,jk,jl) = ptab(:,:,jm) * tmask(i1:i2,j1:j2,1) 200 jm = jm + 1 201 END DO 202 ! 203 DO jk = 1, nlay_i 204 e_i(i1:i2,j1:j2,jk,jl) = ptab(:,:,jm) * tmask(i1:i2,j1:j2,1) 205 jm = jm + 1 206 END DO 207 ! 208 END DO 209 ! 210 ELSE ! ==> complex interpolation (only one ghost cell available) 211 !! Use a more complex interpolation since we mix solutions over a couple of grid points 212 !! it is advised to use it for fields modified by high order schemes (e.g. advection UM5...) 213 !! clem: for some reason (I don't know why), the following lines do not work 214 !! with mpp (or in realistic configurations?). It makes the model crash 215 ! I think there is an issue with Agrif_SpecialValue here (not taken into account properly) 216 ! record ztab 217 jm = 1 218 DO jl = 1, jpl 219 ztab(:,:,jm ) = a_i (:,:,jl) 220 ztab(:,:,jm+1) = v_i (:,:,jl) 221 ztab(:,:,jm+2) = v_s (:,:,jl) 222 ztab(:,:,jm+3) = sv_i(:,:,jl) 223 ztab(:,:,jm+4) = oa_i(:,:,jl) 224 jm = jm + 5 225 DO jk = 1, nlay_s 226 ztab(:,:,jm) = e_s(:,:,jk,jl) 227 jm = jm + 1 228 END DO 229 DO jk = 1, nlay_i 230 ztab(:,:,jm) = e_i(:,:,jk,jl) 231 jm = jm + 1 232 END DO 233 ! 234 END DO 235 ! 236 ! borders of the domain 237 western_side = (nb == 1).AND.(ndir == 1) ; eastern_side = (nb == 1).AND.(ndir == 2) 238 southern_side = (nb == 2).AND.(ndir == 1) ; northern_side = (nb == 2).AND.(ndir == 2) 239 ! 240 ! spatial smoothing 241 zrhox = Agrif_Rhox() 242 z1 = ( zrhox - 1. ) * 0.5 243 z3 = ( zrhox - 1. ) / ( zrhox + 1. ) 244 z6 = 2. * ( zrhox - 1. ) / ( zrhox + 1. ) 245 z7 = - ( zrhox - 1. ) / ( zrhox + 3. ) 246 z2 = 1. - z1 247 z4 = 1. - z3 248 z5 = 1. - z6 - z7 249 ! 250 ! Remove corners 251 imin = i1 ; imax = i2 ; jmin = j1 ; jmax = j2 252 IF( (nbondj == -1) .OR. (nbondj == 2) ) jmin = 3 253 IF( (nbondj == +1) .OR. (nbondj == 2) ) jmax = nlcj-2 254 IF( (nbondi == -1) .OR. (nbondi == 2) ) imin = 3 255 IF( (nbondi == +1) .OR. (nbondi == 2) ) imax = nlci-2 256 257 ! smoothed fields 258 IF( eastern_side ) THEN 259 ztab(nlci,j1:j2,:) = z1 * ptab(nlci,j1:j2,:) + z2 * ptab(nlci-1,j1:j2,:) 260 DO jj = jmin, jmax 261 rswitch = 0. 262 IF( u_ice(nlci-2,jj) > 0._wp ) rswitch = 1. 263 ztab(nlci-1,jj,:) = ( 1. - umask(nlci-2,jj,1) ) * ztab(nlci,jj,:) & 264 & + umask(nlci-2,jj,1) * & 265 & ( ( 1. - rswitch ) * ( z4 * ztab(nlci,jj,:) + z3 * ztab(nlci-2,jj,:) ) & 266 & + rswitch * ( z6 * ztab(nlci-2,jj,:) + z5 * ztab(nlci,jj,:) + z7 * ztab(nlci-3,jj,:) ) ) 267 ztab(nlci-1,jj,:) = ztab(nlci-1,jj,:) * tmask(nlci-1,jj,1) 268 END DO 269 ENDIF 270 ! 271 IF( northern_side ) THEN 272 ztab(i1:i2,nlcj,:) = z1 * ptab(i1:i2,nlcj,:) + z2 * ptab(i1:i2,nlcj-1,:) 273 DO ji = imin, imax 274 rswitch = 0. 275 IF( v_ice(ji,nlcj-2) > 0._wp ) rswitch = 1. 276 ztab(ji,nlcj-1,:) = ( 1. - vmask(ji,nlcj-2,1) ) * ztab(ji,nlcj,:) & 277 & + vmask(ji,nlcj-2,1) * & 278 & ( ( 1. - rswitch ) * ( z4 * ztab(ji,nlcj,:) + z3 * ztab(ji,nlcj-2,:) ) & 279 & + rswitch * ( z6 * ztab(ji,nlcj-2,:) + z5 * ztab(ji,nlcj,:) + z7 * ztab(ji,nlcj-3,:) ) ) 280 ztab(ji,nlcj-1,:) = ztab(ji,nlcj-1,:) * tmask(ji,nlcj-1,1) 281 END DO 282 END IF 283 ! 284 IF( western_side) THEN 285 ztab(1,j1:j2,:) = z1 * ptab(1,j1:j2,:) + z2 * ptab(2,j1:j2,:) 286 DO jj = jmin, jmax 287 rswitch = 0. 288 IF( u_ice(2,jj) < 0._wp ) rswitch = 1. 289 ztab(2,jj,:) = ( 1. - umask(2,jj,1) ) * ztab(1,jj,:) & 290 & + umask(2,jj,1) * & 291 & ( ( 1. - rswitch ) * ( z4 * ztab(1,jj,:) + z3 * ztab(3,jj,:) ) & 292 & + rswitch * ( z6 * ztab(3,jj,:) + z5 * ztab(1,jj,:) + z7 * ztab(4,jj,:) ) ) 293 ztab(2,jj,:) = ztab(2,jj,:) * tmask(2,jj,1) 294 END DO 295 ENDIF 296 ! 297 IF( southern_side ) THEN 298 ztab(i1:i2,1,:) = z1 * ptab(i1:i2,1,:) + z2 * ptab(i1:i2,2,:) 299 DO ji = imin, imax 300 rswitch = 0. 301 IF( v_ice(ji,2) < 0._wp ) rswitch = 1. 302 ztab(ji,2,:) = ( 1. - vmask(ji,2,1) ) * ztab(ji,1,:) & 303 & + vmask(ji,2,1) * & 304 & ( ( 1. - rswitch ) * ( z4 * ztab(ji,1,:) + z3 * ztab(ji,3,:) ) & 305 & + rswitch * ( z6 * ztab(ji,3,:) + z5 * ztab(ji,1,:) + z7 * ztab(ji,4,:) ) ) 306 ztab(ji,2,:) = ztab(ji,2,:) * tmask(ji,2,1) 307 END DO 308 END IF 309 ! 310 ! Treatment of corners 311 IF( (eastern_side) .AND. ((nbondj == -1).OR.(nbondj == 2)) ) ztab(nlci-1,2,:) = ptab(nlci-1,2,:) ! East south 312 IF( (eastern_side) .AND. ((nbondj == 1).OR.(nbondj == 2)) ) ztab(nlci-1,nlcj-1,:) = ptab(nlci-1,nlcj-1,:) ! East north 313 IF( (western_side) .AND. ((nbondj == -1).OR.(nbondj == 2)) ) ztab(2,2,:) = ptab(2,2,:) ! West south 314 IF( (western_side) .AND. ((nbondj == 1).OR.(nbondj == 2)) ) ztab(2,nlcj-1,:) = ptab(2,nlcj-1,:) ! West north 315 316 ! retrieve ice tracers 317 jm = 1 318 DO jl = 1, jpl 319 ! 320 DO jj = j1, j2 321 DO ji = i1, i2 322 a_i (ji,jj,jl) = ztab(ji,jj,jm ) * tmask(ji,jj,1) 323 v_i (ji,jj,jl) = ztab(ji,jj,jm+1) * tmask(ji,jj,1) 324 v_s (ji,jj,jl) = ztab(ji,jj,jm+2) * tmask(ji,jj,1) 325 sv_i(ji,jj,jl) = ztab(ji,jj,jm+3) * tmask(ji,jj,1) 326 oa_i (ji,jj,jl) = ztab(ji,jj,jm+4) * tmask(ji,jj,1) 327 END DO 328 END DO 329 jm = jm + 5 330 ! 331 DO jk = 1, nlay_s 332 e_s(i1:i2,j1:j2,jk,jl) = ztab(i1:i2,j1:j2,jm) * tmask(i1:i2,j1:j2,1) 333 jm = jm + 1 334 END DO 335 ! 336 DO jk = 1, nlay_i 337 e_i(i1:i2,j1:j2,jk,jl) = ztab(i1:i2,j1:j2,jm) * tmask(i1:i2,j1:j2,1) 338 jm = jm + 1 339 END DO 340 ! 341 END DO 342 343 ENDIF ! nbghostcells=1 181 344 182 ELSE ! child grid183 !! ==> The easiest interpolation is the following commented lines184 jm = 1185 DO jl = 1, jpl186 a_i (i1:i2,j1:j2,jl) = ptab(i1:i2,j1:j2,jm) * tmask(i1:i2,j1:j2,1) ; jm = jm + 1187 v_i (i1:i2,j1:j2,jl) = ptab(i1:i2,j1:j2,jm) * tmask(i1:i2,j1:j2,1) ; jm = jm + 1188 v_s (i1:i2,j1:j2,jl) = ptab(i1:i2,j1:j2,jm) * tmask(i1:i2,j1:j2,1) ; jm = jm + 1189 smv_i(i1:i2,j1:j2,jl) = ptab(i1:i2,j1:j2,jm) * tmask(i1:i2,j1:j2,1) ; jm = jm + 1190 oa_i (i1:i2,j1:j2,jl) = ptab(i1:i2,j1:j2,jm) * tmask(i1:i2,j1:j2,1) ; jm = jm + 1191 DO jk = 1, nlay_s192 e_s(i1:i2,j1:j2,jk,jl) = ptab(i1:i2,j1:j2,jm) * tmask(i1:i2,j1:j2,1) ; jm = jm + 1193 ENDDO194 DO jk = 1, nlay_i195 e_i(i1:i2,j1:j2,jk,jl) = ptab(i1:i2,j1:j2,jm) * tmask(i1:i2,j1:j2,1) ; jm = jm + 1196 ENDDO197 ENDDO198 199 !! ==> this is a more complex interpolation since we mix solutions over a couple of grid points200 !! it is advised to use it for fields modified by high order schemes (e.g. advection UM5...)201 !! clem: for some reason (I don't know why), the following lines do not work202 !! with mpp (or in realistic configurations?). It makes the model crash203 ! ! record ztab204 ! jm = 1205 ! DO jl = 1, jpl206 ! ztab(:,:,jm) = a_i (:,:,jl) ; jm = jm + 1207 ! ztab(:,:,jm) = v_i (:,:,jl) ; jm = jm + 1208 ! ztab(:,:,jm) = v_s (:,:,jl) ; jm = jm + 1209 ! ztab(:,:,jm) = smv_i(:,:,jl) ; jm = jm + 1210 ! ztab(:,:,jm) = oa_i (:,:,jl) ; jm = jm + 1211 ! DO jk = 1, nlay_s212 ! ztab(:,:,jm) = e_s(:,:,jk,jl) ; jm = jm + 1213 ! ENDDO214 ! DO jk = 1, nlay_i215 ! ztab(:,:,jm) = e_i(:,:,jk,jl) ; jm = jm + 1216 ! ENDDO217 ! ENDDO218 ! !219 ! ! borders of the domain220 ! western_side = (nb == 1).AND.(ndir == 1) ; eastern_side = (nb == 1).AND.(ndir == 2)221 ! southern_side = (nb == 2).AND.(ndir == 1) ; northern_side = (nb == 2).AND.(ndir == 2)222 ! !223 ! ! spatial smoothing224 ! zrhox = Agrif_Rhox()225 ! z1 = ( zrhox - 1. ) * 0.5226 ! z3 = ( zrhox - 1. ) / ( zrhox + 1. )227 ! z6 = 2. * ( zrhox - 1. ) / ( zrhox + 1. )228 ! z7 = - ( zrhox - 1. ) / ( zrhox + 3. )229 ! z2 = 1. - z1230 ! z4 = 1. - z3231 ! z5 = 1. - z6 - z7232 ! !233 ! ! Remove corners234 ! imin = i1 ; imax = i2 ; jmin = j1 ; jmax = j2235 ! IF( (nbondj == -1) .OR. (nbondj == 2) ) jmin = 3236 ! IF( (nbondj == +1) .OR. (nbondj == 2) ) jmax = nlcj-2237 ! IF( (nbondi == -1) .OR. (nbondi == 2) ) imin = 3238 ! IF( (nbondi == +1) .OR. (nbondi == 2) ) imax = nlci-2239 !240 ! ! smoothed fields241 ! IF( eastern_side ) THEN242 ! ztab(nlci,j1:j2,:) = z1 * ptab(nlci,j1:j2,:) + z2 * ptab(nlci-1,j1:j2,:)243 ! DO jj = jmin, jmax244 ! rswitch = 0.245 ! IF( u_ice(nlci-2,jj) > 0._wp ) rswitch = 1.246 ! ztab(nlci-1,jj,:) = ( 1. - umask(nlci-2,jj,1) ) * ztab(nlci,jj,:) &247 ! & + umask(nlci-2,jj,1) * &248 ! & ( ( 1. - rswitch ) * ( z4 * ztab(nlci,jj,:) + z3 * ztab(nlci-2,jj,:) ) &249 ! & + rswitch * ( z6 * ztab(nlci-2,jj,:) + z5 * ztab(nlci,jj,:) + z7 * ztab(nlci-3,jj,:) ) )250 ! ztab(nlci-1,jj,:) = ztab(nlci-1,jj,:) * tmask(nlci-1,jj,1)251 ! END DO252 ! ENDIF253 ! !254 ! IF( northern_side ) THEN255 ! ztab(i1:i2,nlcj,:) = z1 * ptab(i1:i2,nlcj,:) + z2 * ptab(i1:i2,nlcj-1,:)256 ! DO ji = imin, imax257 ! rswitch = 0.258 ! IF( v_ice(ji,nlcj-2) > 0._wp ) rswitch = 1.259 ! ztab(ji,nlcj-1,:) = ( 1. - vmask(ji,nlcj-2,1) ) * ztab(ji,nlcj,:) &260 ! & + vmask(ji,nlcj-2,1) * &261 ! & ( ( 1. - rswitch ) * ( z4 * ztab(ji,nlcj,:) + z3 * ztab(ji,nlcj-2,:) ) &262 ! & + rswitch * ( z6 * ztab(ji,nlcj-2,:) + z5 * ztab(ji,nlcj,:) + z7 * ztab(ji,nlcj-3,:) ) )263 ! ztab(ji,nlcj-1,:) = ztab(ji,nlcj-1,:) * tmask(ji,nlcj-1,1)264 ! END DO265 ! END IF266 ! !267 ! IF( western_side) THEN268 ! ztab(1,j1:j2,:) = z1 * ptab(1,j1:j2,:) + z2 * ptab(2,j1:j2,:)269 ! DO jj = jmin, jmax270 ! rswitch = 0.271 ! IF( u_ice(2,jj) < 0._wp ) rswitch = 1.272 ! ztab(2,jj,:) = ( 1. - umask(2,jj,1) ) * ztab(1,jj,:) &273 ! & + umask(2,jj,1) * &274 ! & ( ( 1. - rswitch ) * ( z4 * ztab(1,jj,:) + z3 * ztab(3,jj,:) ) &275 ! & + rswitch * ( z6 * ztab(3,jj,:) + z5 * ztab(1,jj,:) + z7 * ztab(4,jj,:) ) )276 ! ztab(2,jj,:) = ztab(2,jj,:) * tmask(2,jj,1)277 ! END DO278 ! ENDIF279 ! !280 ! IF( southern_side ) THEN281 ! ztab(i1:i2,1,:) = z1 * ptab(i1:i2,1,:) + z2 * ptab(i1:i2,2,:)282 ! DO ji = imin, imax283 ! rswitch = 0.284 ! IF( v_ice(ji,2) < 0._wp ) rswitch = 1.285 ! ztab(ji,2,:) = ( 1. - vmask(ji,2,1) ) * ztab(ji,1,:) &286 ! & + vmask(ji,2,1) * &287 ! & ( ( 1. - rswitch ) * ( z4 * ztab(ji,1,:) + z3 * ztab(ji,3,:) ) &288 ! & + rswitch * ( z6 * ztab(ji,3,:) + z5 * ztab(ji,1,:) + z7 * ztab(ji,4,:) ) )289 ! ztab(ji,2,:) = ztab(ji,2,:) * tmask(ji,2,1)290 ! END DO291 ! END IF292 ! !293 ! ! Treatment of corners294 ! IF( (eastern_side) .AND. ((nbondj == -1).OR.(nbondj == 2)) ) ztab(nlci-1,2,:) = ptab(nlci-1,2,:) ! East south295 ! IF( (eastern_side) .AND. ((nbondj == 1).OR.(nbondj == 2)) ) ztab(nlci-1,nlcj-1,:) = ptab(nlci-1,nlcj-1,:) ! East north296 ! IF( (western_side) .AND. ((nbondj == -1).OR.(nbondj == 2)) ) ztab(2,2,:) = ptab(2,2,:) ! West south297 ! IF( (western_side) .AND. ((nbondj == 1).OR.(nbondj == 2)) ) ztab(2,nlcj-1,:) = ptab(2,nlcj-1,:) ! West north298 !299 ! ! retrieve ice tracers300 ! jm = 1301 ! DO jl = 1, jpl302 ! a_i (i1:i2,j1:j2,jl) = ztab(i1:i2,j1:j2,jm) ; jm = jm + 1303 ! v_i (i1:i2,j1:j2,jl) = ztab(i1:i2,j1:j2,jm) ; jm = jm + 1304 ! v_s (i1:i2,j1:j2,jl) = ztab(i1:i2,j1:j2,jm) ; jm = jm + 1305 ! smv_i(i1:i2,j1:j2,jl) = ztab(i1:i2,j1:j2,jm) ; jm = jm + 1306 ! oa_i (i1:i2,j1:j2,jl) = ztab(i1:i2,j1:j2,jm) ; jm = jm + 1307 ! DO jk = 1, nlay_s308 ! e_s(i1:i2,j1:j2,jk,jl) = ztab(i1:i2,j1:j2,jm) ; jm = jm + 1309 ! ENDDO310 ! DO jk = 1, nlay_i311 ! e_i(i1:i2,j1:j2,jk,jl) = ztab(i1:i2,j1:j2,jm) ; jm = jm + 1312 ! ENDDO313 ! ENDDO314 315 345 ! integrated values 316 346 vt_i (i1:i2,j1:j2) = SUM( v_i(i1:i2,j1:j2,:), dim=3 ) … … 319 349 et_s(i1:i2,j1:j2) = SUM( SUM( e_s(i1:i2,j1:j2,:,:), dim=4 ), dim=3 ) 320 350 et_i(i1:i2,j1:j2) = SUM( SUM( e_i(i1:i2,j1:j2,:,:), dim=4 ), dim=3 ) 321 351 ! 322 352 ENDIF 323 353 … … 327 357 328 358 #else 359 !!---------------------------------------------------------------------- 360 !! Empty module no sea-ice 361 !!---------------------------------------------------------------------- 329 362 CONTAINS 330 363 SUBROUTINE agrif_lim3_interp_empty 331 !!---------------------------------------------332 !! *** ROUTINE agrif_lim3_interp_empty ***333 !!---------------------------------------------334 364 WRITE(*,*) 'agrif_lim3_interp : You should not have seen this print! error?' 335 365 END SUBROUTINE agrif_lim3_interp_empty 336 366 #endif 367 368 !!====================================================================== 337 369 END MODULE agrif_lim3_interp
Note: See TracChangeset
for help on using the changeset viewer.
