Changeset 8882 for branches/2017/dev_CNRS_2017/NEMOGCM/NEMO/NST_SRC
- Timestamp:
- 2017-12-01T18:44:09+01:00 (6 years ago)
- Location:
- branches/2017/dev_CNRS_2017/NEMOGCM/NEMO/NST_SRC
- Files:
-
- 2 deleted
- 11 edited
-
agrif_ice.F90 (modified) (2 diffs)
-
agrif_lim2_interp.F90 (deleted)
-
agrif_lim2_update.F90 (deleted)
-
agrif_lim3_interp.F90 (modified) (8 diffs)
-
agrif_lim3_update.F90 (modified) (12 diffs)
-
agrif_oce.F90 (modified) (1 diff)
-
agrif_opa_interp.F90 (modified) (32 diffs)
-
agrif_opa_sponge.F90 (modified) (19 diffs)
-
agrif_opa_update.F90 (modified) (20 diffs)
-
agrif_top_interp.F90 (modified) (7 diffs)
-
agrif_top_sponge.F90 (modified) (5 diffs)
-
agrif_top_update.F90 (modified) (3 diffs)
-
agrif_user.F90 (modified) (16 diffs)
Legend:
- Unmodified
- Added
- Removed
-
branches/2017/dev_CNRS_2017/NEMOGCM/NEMO/NST_SRC/agrif_ice.F90
r7646 r8882 7 7 !! 3.6 ! 2016-05 (C. Rousset) Add LIM3 compatibility 8 8 !!---------------------------------------------------------------------- 9 #if defined key_agrif && defined key_lim 29 #if defined key_agrif && defined key_lim3 10 10 !!---------------------------------------------------------------------- 11 11 !! 'key_agrif' AGRIF zoom 12 !!---------------------------------------------------------------------- 13 USE par_oce ! ocean parameters 14 15 IMPLICIT NONE 16 PRIVATE 17 18 PUBLIC agrif_ice_alloc ! routine called by nemo_init in nemogcm.F90 19 20 INTEGER, PUBLIC :: u_ice_id, v_ice_id, adv_ice_id 21 REAL(wp), PUBLIC :: lim_nbstep = 0. ! child time position in sea-ice model 22 #if defined key_lim2_vp 23 REAL(wp), PUBLIC, ALLOCATABLE, DIMENSION(:,:) :: u_ice_nst, v_ice_nst 24 #else 25 REAL(wp), PUBLIC, ALLOCATABLE, DIMENSION(:,:,:) :: u_ice_oe, u_ice_sn !: boundaries arrays 26 REAL(wp), PUBLIC, ALLOCATABLE, DIMENSION(:,:,:) :: v_ice_oe, v_ice_sn !: " " 27 #endif 28 REAL(wp), PUBLIC, ALLOCATABLE, DIMENSION(:,:,:,:) :: adv_ice_oe, adv_ice_sn !: " " 29 30 !!---------------------------------------------------------------------- 31 !! NEMO/NST 3.3.4 , NEMO Consortium (2012) 32 !! $Id$ 33 !! Software governed by the CeCILL licence (NEMOGCM/NEMO_CeCILL.txt) 34 !!---------------------------------------------------------------------- 35 36 CONTAINS 37 38 INTEGER FUNCTION agrif_ice_alloc() 39 !!---------------------------------------------------------------------- 40 !! *** FUNCTION agrif_ice_alloc *** 41 !!---------------------------------------------------------------------- 42 #if defined key_lim2_vp 43 ALLOCATE( u_ice_nst(jpi,jpj), v_ice_nst(jpi,jpj) , & 44 #else 45 ALLOCATE( u_ice_oe(4,jpj,2) , v_ice_oe(4,jpj,2) , & 46 & u_ice_sn(jpi,4,2) , v_ice_sn(jpi,4,2) , & 47 #endif 48 & adv_ice_oe (4,jpj,7,2) , adv_ice_sn (jpi,4,7,2) , & 49 & STAT = agrif_ice_alloc) 50 51 #if ! defined key_lim2_vp 52 u_ice_oe(:,:,:) = 0.e0 53 v_ice_oe(:,:,:) = 0.e0 54 u_ice_sn(:,:,:) = 0.e0 55 v_ice_sn(:,:,:) = 0.e0 56 #endif 57 adv_ice_oe (:,:,:,:) = 0.e0 58 adv_ice_sn (:,:,:,:) = 0.e0 59 ! 60 END FUNCTION agrif_ice_alloc 61 62 #elif defined key_agrif && defined key_lim3 63 !!---------------------------------------------------------------------- 64 !! 'key_agrif' AGRIF zoom 12 !! 'key_lim3' LIM3 sea-ice model 65 13 !!---------------------------------------------------------------------- 66 14 IMPLICIT NONE … … 71 19 72 20 !!---------------------------------------------------------------------- 73 !! NEMO/NST 3.6 , NEMO Consortium (2016)21 !! NEMO/NST 4.0 , NEMO Consortium (2017) 74 22 !! $Id$ 75 23 !! Software governed by the CeCILL licence (NEMOGCM/NEMO_CeCILL.txt) -
branches/2017/dev_CNRS_2017/NEMOGCM/NEMO/NST_SRC/agrif_lim3_interp.F90
r7761 r8882 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 ! clem2017: 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 -
branches/2017/dev_CNRS_2017/NEMOGCM/NEMO/NST_SRC/agrif_lim3_update.F90
r7761 r8882 31 31 PRIVATE 32 32 33 PUBLIC agrif_update_lim334 35 !!---------------------------------------------------------------------- 36 !! NEMO/NST 3.6 , LOCEAN-IPSL (2016)33 PUBLIC agrif_update_lim3 ! called by agrif_user.F90 34 35 !!---------------------------------------------------------------------- 36 !! NEMO/NST 4.0 , LOCEAN-IPSL (2017) 37 37 !! $Id: agrif_lim3_update.F90 6204 2016-01-04 13:47:06Z cetlod $ 38 38 !! Software governed by the CeCILL licence (modipsl/doc/NEMO_CeCILL.txt) 39 39 !!---------------------------------------------------------------------- 40 41 40 CONTAINS 42 41 … … 49 48 !!---------------------------------------------------------------------- 50 49 INTEGER, INTENT(in) :: kt 51 !!52 50 !!---------------------------------------------------------------------- 53 51 ! … … 56 54 IF( ( MOD( (kt-nit000)/nn_fsbc + 1, Agrif_irhot() * Agrif_Parent(nn_fsbc) / nn_fsbc ) /=0 ) .AND. (kt /= 0) ) RETURN ! do not update if nb of child time steps differ from time refinement 57 55 ! i.e. update only at the parent time step 56 IF( nn_ice == 0 ) RETURN ! clem2017: do not update if child domain does not have ice 57 ! 58 Agrif_SpecialValueFineGrid = -9999. 58 59 Agrif_UseSpecialValueInUpdate = .TRUE. 59 Agrif_SpecialValueFineGrid = -9999.60 60 # if defined TWO_WAY 61 61 IF( MOD(nbcline,nbclineupdate) == 0) THEN ! update the whole basin at each nbclineupdate (=nn_cln_update) baroclinic parent time steps … … 70 70 ENDIF 71 71 # endif 72 Agrif_SpecialValueFineGrid = 0. 72 73 Agrif_UseSpecialValueInUpdate = .FALSE. 73 74 ! … … 75 76 76 77 77 !!------------------78 !! Local subroutines79 !!------------------80 78 SUBROUTINE update_tra_ice( ptab, i1, i2, j1, j2, k1, k2, before ) 81 79 !!----------------------------------------------------------------------- … … 84 82 !! the properties per mass on the coarse grid 85 83 !!----------------------------------------------------------------------- 86 INTEGER , INTENT(in) ::i1, i2, j1, j2, k1, k287 REAL(wp), DIMENSION(i1:i2,j1:j2,k1:k2), INTENT(inout) :: ptab88 LOGICAL , INTENT(in) ::before89 !! 90 INTEGER :: j k, jl, jm84 INTEGER , INTENT(in ) :: i1, i2, j1, j2, k1, k2 85 REAL(wp), DIMENSION(i1:i2,j1:j2,k1:k2), INTENT(inout) :: ptab 86 LOGICAL , INTENT(in ) :: before 87 !! 88 INTEGER :: ji, jj, jk, jl, jm 91 89 !!----------------------------------------------------------------------- 92 90 ! it is ok not to multiply by e1*e2 since we conserve tracers here (same as in the ocean). … … 94 92 jm = 1 95 93 DO jl = 1, jpl 96 ptab(:,:,jm) = a_i (i1:i2,j1:j2,jl) ; jm = jm + 1 97 ptab(:,:,jm) = v_i (i1:i2,j1:j2,jl) ; jm = jm + 1 98 ptab(:,:,jm) = v_s (i1:i2,j1:j2,jl) ; jm = jm + 1 99 ptab(:,:,jm) = smv_i(i1:i2,j1:j2,jl) ; jm = jm + 1 100 ptab(:,:,jm) = oa_i (i1:i2,j1:j2,jl) ; jm = jm + 1 94 ptab(i1:i2,j1:j2,jm ) = a_i (i1:i2,j1:j2,jl) 95 ptab(i1:i2,j1:j2,jm+1) = v_i (i1:i2,j1:j2,jl) 96 ptab(i1:i2,j1:j2,jm+2) = v_s (i1:i2,j1:j2,jl) 97 ptab(i1:i2,j1:j2,jm+3) = sv_i(i1:i2,j1:j2,jl) 98 ptab(i1:i2,j1:j2,jm+4) = oa_i (i1:i2,j1:j2,jl) 99 jm = jm + 5 101 100 DO jk = 1, nlay_s 102 ptab( :,:,jm) = e_s(i1:i2,j1:j2,jk,jl) ;jm = jm + 1103 END DO101 ptab(i1:i2,j1:j2,jm) = e_s(i1:i2,j1:j2,jk,jl) ; jm = jm + 1 102 END DO 104 103 DO jk = 1, nlay_i 105 ptab( :,:,jm) = e_i(i1:i2,j1:j2,jk,jl) ;jm = jm + 1106 END DO107 END DO108 104 ptab(i1:i2,j1:j2,jm) = e_i(i1:i2,j1:j2,jk,jl) ; jm = jm + 1 105 END DO 106 END DO 107 ! 109 108 DO jk = k1, k2 110 WHERE( tmask(i1:i2,j1:j2,1) == 0. ) ptab(:,:,jk) = -9999.111 END DO112 109 WHERE( tmask(i1:i2,j1:j2,1) == 0. ) ptab(i1:i2,j1:j2,jk) = Agrif_SpecialValueFineGrid 110 END DO 111 ! 113 112 ELSE 113 ! 114 114 jm = 1 115 115 DO jl = 1, jpl 116 a_i (i1:i2,j1:j2,jl) = ptab(:,:,jm) * tmask(i1:i2,j1:j2,1) ; jm = jm + 1 117 v_i (i1:i2,j1:j2,jl) = ptab(:,:,jm) * tmask(i1:i2,j1:j2,1) ; jm = jm + 1 118 v_s (i1:i2,j1:j2,jl) = ptab(:,:,jm) * tmask(i1:i2,j1:j2,1) ; jm = jm + 1 119 smv_i(i1:i2,j1:j2,jl) = ptab(:,:,jm) * tmask(i1:i2,j1:j2,1) ; jm = jm + 1 120 oa_i (i1:i2,j1:j2,jl) = ptab(:,:,jm) * tmask(i1:i2,j1:j2,1) ; jm = jm + 1 116 ! 117 DO jj = j1, j2 118 DO ji = i1, i2 119 IF( ptab(ji,jj,jm) /= Agrif_SpecialValueFineGrid ) THEN 120 a_i (ji,jj,jl) = ptab(ji,jj,jm ) * tmask(ji,jj,1) 121 v_i (ji,jj,jl) = ptab(ji,jj,jm+1) * tmask(ji,jj,1) 122 v_s (ji,jj,jl) = ptab(ji,jj,jm+2) * tmask(ji,jj,1) 123 sv_i(ji,jj,jl) = ptab(ji,jj,jm+3) * tmask(ji,jj,1) 124 oa_i(ji,jj,jl) = ptab(ji,jj,jm+4) * tmask(ji,jj,1) 125 ENDIF 126 END DO 127 END DO 128 jm = jm + 5 129 ! 121 130 DO jk = 1, nlay_s 122 e_s(i1:i2,j1:j2,jk,jl) = ptab(:,:,jm) * tmask(i1:i2,j1:j2,1) ; jm = jm + 1 123 ENDDO 131 WHERE( ptab(i1:i2,j1:j2,jm) /= Agrif_SpecialValueFineGrid ) 132 e_s(i1:i2,j1:j2,jk,jl) = ptab(i1:i2,j1:j2,jm) * tmask(i1:i2,j1:j2,1) 133 ENDWHERE 134 jm = jm + 1 135 END DO 136 ! 124 137 DO jk = 1, nlay_i 125 e_i(i1:i2,j1:j2,jk,jl) = ptab(:,:,jm) * tmask(i1:i2,j1:j2,1) ; jm = jm + 1 126 ENDDO 127 ENDDO 128 138 WHERE( ptab(i1:i2,j1:j2,jm) /= Agrif_SpecialValueFineGrid ) 139 e_i(i1:i2,j1:j2,jk,jl) = ptab(i1:i2,j1:j2,jm) * tmask(i1:i2,j1:j2,1) 140 ENDWHERE 141 jm = jm + 1 142 END DO 143 ! 144 END DO 145 ! 129 146 ! integrated values 130 vt_i (i1:i2,j1:j2) = SUM( v_i(i1:i2,j1:j2,:), dim=3 )131 vt_s (i1:i2,j1:j2) = SUM( v_s(i1:i2,j1:j2,:), dim=3 )132 at_i (i1:i2,j1:j2) = SUM( a_i(i1:i2,j1:j2,:), dim=3 )147 vt_i (i1:i2,j1:j2) = SUM( v_i(i1:i2,j1:j2,:) , dim=3 ) 148 vt_s (i1:i2,j1:j2) = SUM( v_s(i1:i2,j1:j2,:) , dim=3 ) 149 at_i (i1:i2,j1:j2) = SUM( a_i(i1:i2,j1:j2,:) , dim=3 ) 133 150 et_s(i1:i2,j1:j2) = SUM( SUM( e_s(i1:i2,j1:j2,:,:), dim=4 ), dim=3 ) 134 151 et_i(i1:i2,j1:j2) = SUM( SUM( e_i(i1:i2,j1:j2,:,:), dim=4 ), dim=3 ) … … 144 161 !! ** Method : Update the fluxes and recover the properties (C-grid) 145 162 !!----------------------------------------------------------------------- 146 INTEGER , INTENT(in) ::i1, i2, j1, j2147 REAL(wp), DIMENSION(i1:i2,j1:j2), INTENT(inout) :: ptab148 LOGICAL , INTENT(in) ::before149 !! 150 REAL(wp) :: zrhoy163 INTEGER , INTENT(in ) :: i1, i2, j1, j2 164 REAL(wp), DIMENSION(i1:i2,j1:j2), INTENT(inout) :: ptab 165 LOGICAL , INTENT(in ) :: before 166 !! 167 REAL(wp) :: zrhoy ! local scalar 151 168 !!----------------------------------------------------------------------- 152 169 ! … … 154 171 zrhoy = Agrif_Rhoy() 155 172 ptab(:,:) = e2u(i1:i2,j1:j2) * u_ice(i1:i2,j1:j2) * zrhoy 156 WHERE( umask(i1:i2,j1:j2,1) == 0. ) ptab(:,:) = -9999.173 WHERE( umask(i1:i2,j1:j2,1) == 0._wp ) ptab(:,:) = Agrif_SpecialValueFineGrid 157 174 ELSE 158 u_ice(i1:i2,j1:j2) = ptab(:,:) / e2u(i1:i2,j1:j2) * umask(i1:i2,j1:j2,1) 175 WHERE( ptab(i1:i2,j1:j2) /= Agrif_SpecialValueFineGrid ) 176 u_ice(i1:i2,j1:j2) = ptab(i1:i2,j1:j2) / e2u(i1:i2,j1:j2) * umask(i1:i2,j1:j2,1) 177 ENDWHERE 159 178 ENDIF 160 179 ! … … 167 186 !! ** Method : Update the fluxes and recover the properties (C-grid) 168 187 !!----------------------------------------------------------------------- 169 INTEGER , INTENT(in) :: i1,i2,j1,j2170 REAL(wp), DIMENSION(i1:i2,j1:j2), INTENT(inout) ::ptab171 LOGICAL , INTENT(in) ::before172 !! 173 REAL(wp) :: zrhox188 INTEGER , INTENT(in ) :: i1, i2, j1, j2 189 REAL(wp), DIMENSION(i1:i2,j1:j2), INTENT(inout) :: ptab 190 LOGICAL , INTENT(in ) :: before 191 !! 192 REAL(wp) :: zrhox ! local scalar 174 193 !!----------------------------------------------------------------------- 175 194 ! … … 177 196 zrhox = Agrif_Rhox() 178 197 ptab(:,:) = e1v(i1:i2,j1:j2) * v_ice(i1:i2,j1:j2) * zrhox 179 WHERE( vmask(i1:i2,j1:j2,1) == 0. ) ptab(:,:) = -9999.198 WHERE( vmask(i1:i2,j1:j2,1) == 0._wp ) ptab(:,:) = Agrif_SpecialValueFineGrid 180 199 ELSE 181 v_ice(i1:i2,j1:j2) = ptab(:,:) / e1v(i1:i2,j1:j2) * vmask(i1:i2,j1:j2,1) 200 WHERE( ptab(i1:i2,j1:j2) /= Agrif_SpecialValueFineGrid ) 201 v_ice(i1:i2,j1:j2) = ptab(i1:i2,j1:j2) / e1v(i1:i2,j1:j2) * vmask(i1:i2,j1:j2,1) 202 ENDWHERE 182 203 ENDIF 183 204 ! … … 185 206 186 207 #else 208 !!---------------------------------------------------------------------- 209 !! Empty module no sea-ice 210 !!---------------------------------------------------------------------- 187 211 CONTAINS 188 212 SUBROUTINE agrif_lim3_update_empty 189 !!---------------------------------------------190 !! *** ROUTINE agrif_lim3_update_empty ***191 !!---------------------------------------------192 213 WRITE(*,*) 'agrif_lim3_update : You should not have seen this print! error?' 193 214 END SUBROUTINE agrif_lim3_update_empty 194 215 #endif 216 217 !!====================================================================== 195 218 END MODULE agrif_lim3_update -
branches/2017/dev_CNRS_2017/NEMOGCM/NEMO/NST_SRC/agrif_oce.F90
r5656 r8882 44 44 LOGICAL , PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: tabspongedone_u 45 45 LOGICAL , PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: tabspongedone_v 46 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, 47 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, 46 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: fsaht_spu, fsaht_spv !: sponge diffusivities 47 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: fsahm_spt, fsahm_spf !: sponge viscosities 48 48 49 ! Barotropic arrays used to store open boundary data during 50 ! time-splitting loop: 51 REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:) :: ubdy_w, vbdy_w, hbdy_w 52 REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:) :: ubdy_e, vbdy_e, hbdy_e 53 REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:) :: ubdy_n, vbdy_n, hbdy_n 54 REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:) :: ubdy_s, vbdy_s, hbdy_s 49 ! Barotropic arrays used to store open boundary data during time-splitting loop: 50 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:) :: ubdy_w, vbdy_w, hbdy_w 51 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:) :: ubdy_e, vbdy_e, hbdy_e 52 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:) :: ubdy_n, vbdy_n, hbdy_n 53 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:) :: ubdy_s, vbdy_s, hbdy_s 55 54 56 INTEGER :: tsn_id ! AGRIF profile for tracers interpolation and update 57 INTEGER :: un_interp_id, vn_interp_id ! AGRIF profiles for interpolations 58 INTEGER :: un_update_id, vn_update_id ! AGRIF profiles for udpates 59 INTEGER :: tsn_sponge_id, un_sponge_id, vn_sponge_id ! AGRIF profiles for sponge layers 55 56 INTEGER, PUBLIC :: tsn_id ! AGRIF profile for tracers interpolation and update 57 INTEGER, PUBLIC :: un_interp_id, vn_interp_id ! AGRIF profiles for interpolations 58 INTEGER, PUBLIC :: un_update_id, vn_update_id ! AGRIF profiles for udpates 59 INTEGER, PUBLIC :: tsn_sponge_id, un_sponge_id, vn_sponge_id ! AGRIF profiles for sponge layers 60 60 # if defined key_top 61 INTEGER :: trn_id, trn_sponge_id61 INTEGER, PUBLIC :: trn_id, trn_sponge_id 62 62 # endif 63 INTEGER :: unb_id, vnb_id, ub2b_interp_id, vb2b_interp_id 64 INTEGER :: ub2b_update_id, vb2b_update_id 65 INTEGER :: e3t_id, e1u_id, e2v_id, sshn_id 66 INTEGER :: scales_t_id 67 # if defined key_zdftke 68 INTEGER :: avt_id, avm_id, en_id 69 # endif 70 INTEGER :: umsk_id, vmsk_id 71 INTEGER :: kindic_agr 72 63 INTEGER, PUBLIC :: unb_id, vnb_id, ub2b_interp_id, vb2b_interp_id 64 INTEGER, PUBLIC :: ub2b_update_id, vb2b_update_id 65 INTEGER, PUBLIC :: e3t_id, e1u_id, e2v_id, sshn_id 66 INTEGER, PUBLIC :: scales_t_id 67 INTEGER, PUBLIC :: avt_id, avm_id, en_id ! TKE related identificators 68 INTEGER, PUBLIC :: umsk_id, vmsk_id 69 INTEGER, PUBLIC :: kindic_agr 70 73 71 !!---------------------------------------------------------------------- 74 !! NEMO/NST 3.3.1 , NEMO Consortium (2011)72 !! NEMO/NST 4.0 , NEMO Consortium (2017) 75 73 !! $Id$ 76 74 !! Software governed by the CeCILL licence (NEMOGCM/NEMO_CeCILL.txt) -
branches/2017/dev_CNRS_2017/NEMOGCM/NEMO/NST_SRC/agrif_opa_interp.F90
r7646 r8882 2 2 !!====================================================================== 3 3 !! *** MODULE agrif_opa_interp *** 4 !! AGRIF: interpolation package 4 !! AGRIF: interpolation package for the ocean dynamics (OPA) 5 5 !!====================================================================== 6 !! History : 2.0 ! 2002-06 (XXX) Original cade 7 !! - ! 2005-11 (XXX) 6 !! History : 2.0 ! 2002-06 (L. Debreu) Original cade 8 7 !! 3.2 ! 2009-04 (R. Benshila) 9 8 !! 3.6 ! 2014-09 (R. Benshila) … … 15 14 !! Agrif_tra : 16 15 !! Agrif_dyn : 16 !! Agrif_ssh : 17 !! Agrif_dyn_ts : 18 !! Agrif_dta_ts : 19 !! Agrif_ssh_ts : 20 !! Agrif_avm : 17 21 !! interpu : 18 22 !! interpv : … … 28 32 USE agrif_opa_sponge 29 33 USE lib_mpp 30 USE wrk_nemo31 34 32 35 IMPLICIT NONE … … 34 37 35 38 PUBLIC Agrif_tra, Agrif_dyn, Agrif_ssh, Agrif_dyn_ts, Agrif_ssh_ts, Agrif_dta_ts 36 PUBLIC interpun , interpvn37 PUBLIC interptsn, 38 PUBLIC interpunb, interpvnb , interpub2b, interpvb2b39 PUBLIC interpun , interpvn 40 PUBLIC interptsn, interpsshn 41 PUBLIC interpunb, interpvnb , interpub2b, interpvb2b 39 42 PUBLIC interpe3t, interpumsk, interpvmsk 40 # if defined key_zdftke 41 PUBLIC Agrif_tke, interpavm 42 # endif 43 PUBLIC Agrif_avm, interpavm 43 44 44 45 INTEGER :: bdy_tinterp = 0 … … 46 47 # include "vectopt_loop_substitute.h90" 47 48 !!---------------------------------------------------------------------- 48 !! NEMO/NST 3.7 , NEMO Consortium (2015)49 !! NEMO/NST 4.0 , NEMO Consortium (2017) 49 50 !! $Id$ 50 51 !! Software governed by the CeCILL licence (NEMOGCM/NEMO_CeCILL.txt) … … 77 78 INTEGER :: ji, jj, jk ! dummy loop indices 78 79 INTEGER :: j1, j2, i1, i2 79 REAL(wp), POINTER, DIMENSION(:,:) :: zub, zvb80 REAL(wp), DIMENSION(jpi,jpj) :: zub, zvb 80 81 !!---------------------------------------------------------------------- 81 82 ! 82 83 IF( Agrif_Root() ) RETURN 83 !84 CALL wrk_alloc( jpi,jpj, zub, zvb )85 84 ! 86 85 Agrif_SpecialValue = 0._wp … … 105 104 ! --------- 106 105 IF( .NOT.ln_dynspg_ts ) THEN ! Store transport 107 ua_b(2 ,:) = 0._wp106 ua_b(2:1+nbghostcells,:) = 0._wp 108 107 DO jk = 1, jpkm1 109 108 DO jj = 1, jpj 110 ua_b(2 ,jj) = ua_b(2,jj) + e3u_a(2,jj,jk) * ua(2,jj,jk)109 ua_b(2:1+nbghostcells,jj) = ua_b(2:1+nbghostcells,jj) + e3u_a(2:1+nbghostcells,jj,jk) * ua(2:1+nbghostcells,jj,jk) 111 110 END DO 112 111 END DO 113 112 DO jj = 1, jpj 114 ua_b(2,jj) = ua_b(2,jj) * r1_hu_a(2,jj) 115 END DO 116 ENDIF 117 ! 118 DO jk=1,jpkm1 ! Smooth 119 DO jj=j1,j2 120 ua(2,jj,jk) = 0.25_wp*(ua(1,jj,jk)+2._wp*ua(2,jj,jk)+ua(3,jj,jk)) 121 ua(2,jj,jk) = ua(2,jj,jk) * umask(2,jj,jk) 122 END DO 123 END DO 124 ! 125 zub(2,:) = 0._wp ! Correct transport 126 DO jk = 1, jpkm1 127 DO jj = 1, jpj 128 zub(2,jj) = zub(2,jj) + e3u_a(2,jj,jk) * ua(2,jj,jk) 129 END DO 130 END DO 131 DO jj=1,jpj 132 zub(2,jj) = zub(2,jj) * r1_hu_a(2,jj) 133 END DO 134 135 DO jk=1,jpkm1 136 DO jj=1,jpj 137 ua(2,jj,jk) = (ua(2,jj,jk)+ua_b(2,jj)-zub(2,jj))*umask(2,jj,jk) 138 END DO 139 END DO 140 141 ! Set tangential velocities to time splitting estimate 142 !----------------------------------------------------- 143 IF( ln_dynspg_ts ) THEN 144 zvb(2,:) = 0._wp 113 ua_b(2:1+nbghostcells,jj) = ua_b(2:1+nbghostcells,jj) * r1_hu_a(2:1+nbghostcells,jj) 114 END DO 115 ENDIF 116 ! 117 ! Smoothing if only 1 ghostcell 118 ! ----------------------------- 119 IF( nbghostcells == 1 ) THEN 120 DO jk=1,jpkm1 ! Smooth 121 DO jj=j1,j2 122 ua(2,jj,jk) = 0.25_wp*(ua(1,jj,jk)+2._wp*ua(2,jj,jk)+ua(3,jj,jk)) 123 ua(2,jj,jk) = ua(2,jj,jk) * umask(2,jj,jk) 124 END DO 125 END DO 126 ! 127 zub(2,:) = 0._wp ! Correct transport 145 128 DO jk = 1, jpkm1 146 129 DO jj = 1, jpj 147 zvb(2,jj) = zvb(2,jj) + e3v_a(2,jj,jk) * va(2,jj,jk) 148 END DO 149 END DO 150 DO jj = 1, jpj 151 zvb(2,jj) = zvb(2,jj) * r1_hv_a(2,jj) 152 END DO 130 zub(2,jj) = zub(2,jj) + e3u_a(2,jj,jk) * ua(2,jj,jk) 131 END DO 132 END DO 133 DO jj=1,jpj 134 zub(2,jj) = zub(2,jj) * r1_hu_a(2,jj) 135 END DO 136 153 137 DO jk = 1, jpkm1 154 138 DO jj = 1, jpj 155 va(2,jj,jk) = (va(2,jj,jk)+va_b(2,jj)-zvb(2,jj)) * vmask(2,jj,jk) 156 END DO 157 END DO 139 ua(2,jj,jk) = (ua(2,jj,jk)+ua_b(2,jj)-zub(2,jj))*umask(2,jj,jk) 140 END DO 141 END DO 142 143 IF( ln_dynspg_ts ) THEN ! Set tangential velocities to time splitting estimate 144 zvb(2,:) = 0._wp 145 DO jk = 1, jpkm1 146 DO jj = 1, jpj 147 zvb(2,jj) = zvb(2,jj) + e3v_a(2,jj,jk) * va(2,jj,jk) 148 END DO 149 END DO 150 DO jj = 1, jpj 151 zvb(2,jj) = zvb(2,jj) * r1_hv_a(2,jj) 152 END DO 153 DO jk = 1, jpkm1 154 DO jj = 1, jpj 155 va(2,jj,jk) = (va(2,jj,jk)+va_b(2,jj)-zvb(2,jj)) * vmask(2,jj,jk) 156 END DO 157 END DO 158 ENDIF 159 ! 158 160 ENDIF 159 161 ! 160 162 ! Mask domain edges: 161 163 !------------------- 162 DO jk = 1, jpkm1 163 DO jj = 1, jpj 164 ua(1,jj,jk) = 0._wp 165 va(1,jj,jk) = 0._wp 166 END DO 167 END DO 168 ! 169 ENDIF 170 164 ! DO jk = 1, jpkm1 165 ! DO jj = 1, jpj 166 ! ua(1,jj,jk) = 0._wp 167 ! va(1,jj,jk) = 0._wp 168 ! END DO 169 ! END DO 170 ! 171 ENDIF 172 173 ! --- East --- ! 171 174 IF( nbondi == 1 .OR. nbondi == 2 ) THEN 172 175 173 ! Smoothing174 ! ---------175 176 IF( .NOT.ln_dynspg_ts ) THEN ! Store transport 176 ua_b(nlci- 2,:) = 0._wp177 ua_b(nlci-nbghostcells-1:nlci-2,:) = 0._wp 177 178 DO jk=1,jpkm1 178 179 DO jj=1,jpj 179 ua_b(nlci-2,jj) = ua_b(nlci-2,jj) + e3u_a(nlci-2,jj,jk) * ua(nlci-2,jj,jk) 180 ua_b(nlci-nbghostcells-1:nlci-2,jj) = ua_b(nlci-nbghostcells-1:nlci-2,jj) + e3u_a(nlci-nbghostcells-1:nlci-2,jj,jk) & 181 & * ua(nlci-nbghostcells-1:nlci-2,jj,jk) 180 182 END DO 181 183 END DO 182 184 DO jj=1,jpj 183 ua_b(nlci-2,jj) = ua_b(nlci-2,jj) * r1_hu_a(nlci-2,jj) 184 END DO 185 ENDIF 186 187 DO jk = 1, jpkm1 ! Smooth 188 DO jj = j1, j2 189 ua(nlci-2,jj,jk) = 0.25_wp * umask(nlci-2,jj,jk) & 190 & * ( ua(nlci-3,jj,jk) + 2._wp*ua(nlci-2,jj,jk) + ua(nlci-1,jj,jk) ) 191 END DO 192 END DO 193 194 zub(nlci-2,:) = 0._wp ! Correct transport 195 DO jk = 1, jpkm1 196 DO jj = 1, jpj 197 zub(nlci-2,jj) = zub(nlci-2,jj) + e3u_a(nlci-2,jj,jk) * ua(nlci-2,jj,jk) 198 END DO 199 END DO 200 DO jj = 1, jpj 201 zub(nlci-2,jj) = zub(nlci-2,jj) * r1_hu_a(nlci-2,jj) 202 END DO 203 204 DO jk = 1, jpkm1 205 DO jj = 1, jpj 206 ua(nlci-2,jj,jk) = ( ua(nlci-2,jj,jk) + ua_b(nlci-2,jj) - zub(nlci-2,jj) ) * umask(nlci-2,jj,jk) 207 END DO 208 END DO 209 ! 210 ! Set tangential velocities to time splitting estimate 211 !----------------------------------------------------- 212 IF( ln_dynspg_ts ) THEN 213 zvb(nlci-1,:) = 0._wp 185 ua_b(nlci-nbghostcells-1:nlci-2,jj) = ua_b(nlci-nbghostcells-1:nlci-2,jj) * r1_hu_a(nlci-nbghostcells-1:nlci-2,jj) 186 END DO 187 ENDIF 188 ! 189 ! Smoothing if only 1 ghostcell 190 ! ----------------------------- 191 IF( nbghostcells == 1 ) THEN 192 DO jk = 1, jpkm1 ! Smooth 193 DO jj = j1, j2 194 ua(nlci-2,jj,jk) = 0.25_wp * umask(nlci-2,jj,jk) & 195 & * ( ua(nlci-3,jj,jk) + 2._wp*ua(nlci-2,jj,jk) + ua(nlci-1,jj,jk) ) 196 END DO 197 END DO 198 199 zub(nlci-2,:) = 0._wp ! Correct transport 214 200 DO jk = 1, jpkm1 215 201 DO jj = 1, jpj 216 zvb(nlci-1,jj) = zvb(nlci-1,jj) + e3v_a(nlci-1,jj,jk) * va(nlci-1,jj,jk) 217 END DO 218 END DO 219 DO jj=1,jpj 220 zvb(nlci-1,jj) = zvb(nlci-1,jj) * r1_hv_a(nlci-1,jj) 221 END DO 202 zub(nlci-2,jj) = zub(nlci-2,jj) + e3u_a(nlci-2,jj,jk) * ua(nlci-2,jj,jk) 203 END DO 204 END DO 205 DO jj = 1, jpj 206 zub(nlci-2,jj) = zub(nlci-2,jj) * r1_hu_a(nlci-2,jj) 207 END DO 208 222 209 DO jk = 1, jpkm1 223 210 DO jj = 1, jpj 224 va(nlci-1,jj,jk) = ( va(nlci-1,jj,jk) + va_b(nlci-1,jj) - zvb(nlci-1,jj) ) * vmask(nlci-1,jj,jk) 225 END DO 226 END DO 211 ua(nlci-2,jj,jk) = ( ua(nlci-2,jj,jk) + ua_b(nlci-2,jj) - zub(nlci-2,jj) ) * umask(nlci-2,jj,jk) 212 END DO 213 END DO 214 ! 215 IF( ln_dynspg_ts ) THEN ! Set tangential velocities to time splitting estimate 216 zvb(nlci-1,:) = 0._wp 217 DO jk = 1, jpkm1 218 DO jj = 1, jpj 219 zvb(nlci-1,jj) = zvb(nlci-1,jj) + e3v_a(nlci-1,jj,jk) * va(nlci-1,jj,jk) 220 END DO 221 END DO 222 DO jj=1,jpj 223 zvb(nlci-1,jj) = zvb(nlci-1,jj) * r1_hv_a(nlci-1,jj) 224 END DO 225 DO jk = 1, jpkm1 226 DO jj = 1, jpj 227 va(nlci-1,jj,jk) = ( va(nlci-1,jj,jk) + va_b(nlci-1,jj) - zvb(nlci-1,jj) ) * vmask(nlci-1,jj,jk) 228 END DO 229 END DO 230 ENDIF 231 ! 227 232 ENDIF 228 233 ! 229 234 ! Mask domain edges: 230 235 !------------------- 231 DO jk = 1, jpkm1 232 DO jj = 1, jpj 233 ua(nlci-1,jj,jk) = 0._wp 234 va(nlci ,jj,jk) = 0._wp 235 END DO 236 END DO 237 ! 238 ENDIF 239 236 ! DO jk = 1, jpkm1 237 ! DO jj = 1, jpj 238 ! ua(nlci-1,jj,jk) = 0._wp 239 ! va(nlci ,jj,jk) = 0._wp 240 ! END DO 241 ! END DO 242 ! 243 ENDIF 244 245 ! --- South --- ! 240 246 IF( nbondj == -1 .OR. nbondj == 2 ) THEN 241 247 242 ! Smoothing243 ! ---------244 248 IF( .NOT.ln_dynspg_ts ) THEN ! Store transport 245 va_b(:,2 ) = 0._wp249 va_b(:,2:nbghostcells+1) = 0._wp 246 250 DO jk = 1, jpkm1 247 251 DO ji = 1, jpi 248 va_b(ji,2 ) = va_b(ji,2) + e3v_a(ji,2,jk) * va(ji,2,jk)252 va_b(ji,2:nbghostcells+1) = va_b(ji,2:nbghostcells+1) + e3v_a(ji,2:nbghostcells+1,jk) * va(ji,2:nbghostcells+1,jk) 249 253 END DO 250 254 END DO 251 255 DO ji=1,jpi 252 va_b(ji,2) = va_b(ji,2) * r1_hv_a(ji,2) 253 END DO 254 ENDIF 255 ! 256 DO jk = 1, jpkm1 ! Smooth 257 DO ji = i1, i2 258 va(ji,2,jk) = 0.25_wp * vmask(ji,2,jk) & 259 & * ( va(ji,1,jk) + 2._wp*va(ji,2,jk) + va(ji,3,jk) ) 260 END DO 261 END DO 262 ! 263 zvb(:,2) = 0._wp ! Correct transport 264 DO jk=1,jpkm1 265 DO ji=1,jpi 266 zvb(ji,2) = zvb(ji,2) + e3v_a(ji,2,jk) * va(ji,2,jk) * vmask(ji,2,jk) 267 END DO 268 END DO 269 DO ji = 1, jpi 270 zvb(ji,2) = zvb(ji,2) * r1_hv_a(ji,2) 271 END DO 272 DO jk = 1, jpkm1 256 va_b(ji,2:nbghostcells+1) = va_b(ji,2:nbghostcells+1) * r1_hv_a(ji,2:nbghostcells+1) 257 END DO 258 ENDIF 259 ! 260 ! Smoothing if only 1 ghostcell 261 ! ----------------------------- 262 IF( nbghostcells == 1 ) THEN 263 DO jk = 1, jpkm1 ! Smooth 264 DO ji = i1, i2 265 va(ji,2,jk) = 0.25_wp * vmask(ji,2,jk) & 266 & * ( va(ji,1,jk) + 2._wp*va(ji,2,jk) + va(ji,3,jk) ) 267 END DO 268 END DO 269 ! 270 zvb(:,2) = 0._wp ! Correct transport 271 DO jk=1,jpkm1 272 DO ji=1,jpi 273 zvb(ji,2) = zvb(ji,2) + e3v_a(ji,2,jk) * va(ji,2,jk) * vmask(ji,2,jk) 274 END DO 275 END DO 273 276 DO ji = 1, jpi 274 va(ji,2,jk) = ( va(ji,2,jk) + va_b(ji,2) - zvb(ji,2) ) * vmask(ji,2,jk) 275 END DO 276 END DO 277 278 ! Set tangential velocities to time splitting estimate 279 !----------------------------------------------------- 280 IF( ln_dynspg_ts ) THEN 281 zub(:,2) = 0._wp 277 zvb(ji,2) = zvb(ji,2) * r1_hv_a(ji,2) 278 END DO 282 279 DO jk = 1, jpkm1 283 280 DO ji = 1, jpi 284 zub(ji,2) = zub(ji,2) + e3u_a(ji,2,jk) * ua(ji,2,jk) * umask(ji,2,jk) 285 END DO 286 END DO 287 DO ji = 1, jpi 288 zub(ji,2) = zub(ji,2) * r1_hu_a(ji,2) 289 END DO 290 281 va(ji,2,jk) = ( va(ji,2,jk) + va_b(ji,2) - zvb(ji,2) ) * vmask(ji,2,jk) 282 END DO 283 END DO 284 285 IF( ln_dynspg_ts ) THEN ! Set tangential velocities to time splitting estimate 286 zub(:,2) = 0._wp 287 DO jk = 1, jpkm1 288 DO ji = 1, jpi 289 zub(ji,2) = zub(ji,2) + e3u_a(ji,2,jk) * ua(ji,2,jk) * umask(ji,2,jk) 290 END DO 291 END DO 292 DO ji = 1, jpi 293 zub(ji,2) = zub(ji,2) * r1_hu_a(ji,2) 294 END DO 295 296 DO jk = 1, jpkm1 297 DO ji = 1, jpi 298 ua(ji,2,jk) = ( ua(ji,2,jk) + ua_b(ji,2) - zub(ji,2) ) * umask(ji,2,jk) 299 END DO 300 END DO 301 ENDIF 302 ! 303 ENDIF 304 ! 305 ! Mask domain edges: 306 !------------------- 307 ! DO jk = 1, jpkm1 308 ! DO ji = 1, jpi 309 ! ua(ji,1,jk) = 0._wp 310 ! va(ji,1,jk) = 0._wp 311 ! END DO 312 ! END DO 313 ! 314 ENDIF 315 316 ! --- North --- ! 317 IF( nbondj == 1 .OR. nbondj == 2 ) THEN 318 ! 319 IF( .NOT.ln_dynspg_ts ) THEN ! Store transport 320 va_b(:,nlcj-nbghostcells-1:nlcj-2) = 0._wp 291 321 DO jk = 1, jpkm1 292 322 DO ji = 1, jpi 293 ua(ji,2,jk) = ( ua(ji,2,jk) + ua_b(ji,2) - zub(ji,2) ) * umask(ji,2,jk) 294 END DO 295 END DO 296 ENDIF 297 323 va_b(ji,nlcj-nbghostcells-1:nlcj-2) = va_b(ji,nlcj-nbghostcells-1:nlcj-2) + e3v_a(ji,nlcj-nbghostcells-1:nlcj-2,jk) & 324 & * va(ji,nlcj-nbghostcells-1:nlcj-2,jk) 325 END DO 326 END DO 327 DO ji = 1, jpi 328 va_b(ji,nlcj-nbghostcells-1:nlcj-2) = va_b(ji,nlcj-nbghostcells-1:nlcj-2) * r1_hv_a(ji,nlcj-nbghostcells-1:nlcj-2) 329 END DO 330 ENDIF 331 ! 332 ! Smoothing if only 1 ghostcell 333 ! ----------------------------- 334 IF( nbghostcells == 1 ) THEN 335 DO jk = 1, jpkm1 ! Smooth 336 DO ji = i1, i2 337 va(ji,nlcj-2,jk) = 0.25_wp * vmask(ji,nlcj-2,jk) & 338 & * ( va(ji,nlcj-3,jk) + 2._wp * va(ji,nlcj-2,jk) + va(ji,nlcj-1,jk) ) 339 END DO 340 END DO 341 ! 342 zvb(:,nlcj-2) = 0._wp ! Correct transport 343 DO jk = 1, jpkm1 344 DO ji = 1, jpi 345 zvb(ji,nlcj-2) = zvb(ji,nlcj-2) + e3v_a(ji,nlcj-2,jk) * va(ji,nlcj-2,jk) * vmask(ji,nlcj-2,jk) 346 END DO 347 END DO 348 DO ji = 1, jpi 349 zvb(ji,nlcj-2) = zvb(ji,nlcj-2) * r1_hv_a(ji,nlcj-2) 350 END DO 351 DO jk = 1, jpkm1 352 DO ji = 1, jpi 353 va(ji,nlcj-2,jk) = ( va(ji,nlcj-2,jk) + va_b(ji,nlcj-2) - zvb(ji,nlcj-2) ) * vmask(ji,nlcj-2,jk) 354 END DO 355 END DO 356 ! 357 IF( ln_dynspg_ts ) THEN ! Set tangential velocities to time splitting estimate 358 zub(:,nlcj-1) = 0._wp 359 DO jk = 1, jpkm1 360 DO ji = 1, jpi 361 zub(ji,nlcj-1) = zub(ji,nlcj-1) + e3u_a(ji,nlcj-1,jk) * ua(ji,nlcj-1,jk) * umask(ji,nlcj-1,jk) 362 END DO 363 END DO 364 DO ji = 1, jpi 365 zub(ji,nlcj-1) = zub(ji,nlcj-1) * r1_hu_a(ji,nlcj-1) 366 END DO 367 ! 368 DO jk = 1, jpkm1 369 DO ji = 1, jpi 370 ua(ji,nlcj-1,jk) = ( ua(ji,nlcj-1,jk) + ua_b(ji,nlcj-1) - zub(ji,nlcj-1) ) * umask(ji,nlcj-1,jk) 371 END DO 372 END DO 373 ENDIF 374 ! 375 ENDIF 376 ! 298 377 ! Mask domain edges: 299 378 !------------------- 300 DO jk = 1, jpkm1 301 DO ji = 1, jpi 302 ua(ji,1,jk) = 0._wp 303 va(ji,1,jk) = 0._wp 304 END DO 305 END DO 306 307 ENDIF 308 309 IF( nbondj == 1 .OR. nbondj == 2 ) THEN 310 ! 311 ! Smoothing 312 ! --------- 313 IF( .NOT.ln_dynspg_ts ) THEN ! Store transport 314 va_b(:,nlcj-2) = 0._wp 315 DO jk = 1, jpkm1 316 DO ji = 1, jpi 317 va_b(ji,nlcj-2) = va_b(ji,nlcj-2) + e3v_a(ji,nlcj-2,jk) * va(ji,nlcj-2,jk) 318 END DO 319 END DO 320 DO ji = 1, jpi 321 va_b(ji,nlcj-2) = va_b(ji,nlcj-2) * r1_hv_a(ji,nlcj-2) 322 END DO 323 ENDIF 324 ! 325 DO jk = 1, jpkm1 ! Smooth 326 DO ji = i1, i2 327 va(ji,nlcj-2,jk) = 0.25_wp * vmask(ji,nlcj-2,jk) & 328 & * ( va(ji,nlcj-3,jk) + 2._wp * va(ji,nlcj-2,jk) + va(ji,nlcj-1,jk) ) 329 END DO 330 END DO 331 ! 332 zvb(:,nlcj-2) = 0._wp ! Correct transport 333 DO jk = 1, jpkm1 334 DO ji = 1, jpi 335 zvb(ji,nlcj-2) = zvb(ji,nlcj-2) + e3v_a(ji,nlcj-2,jk) * va(ji,nlcj-2,jk) * vmask(ji,nlcj-2,jk) 336 END DO 337 END DO 338 DO ji = 1, jpi 339 zvb(ji,nlcj-2) = zvb(ji,nlcj-2) * r1_hv_a(ji,nlcj-2) 340 END DO 341 DO jk = 1, jpkm1 342 DO ji = 1, jpi 343 va(ji,nlcj-2,jk) = ( va(ji,nlcj-2,jk) + va_b(ji,nlcj-2) - zvb(ji,nlcj-2) ) * vmask(ji,nlcj-2,jk) 344 END DO 345 END DO 346 ! 347 ! Set tangential velocities to time splitting estimate 348 !----------------------------------------------------- 349 IF( ln_dynspg_ts ) THEN 350 zub(:,nlcj-1) = 0._wp 351 DO jk = 1, jpkm1 352 DO ji = 1, jpi 353 zub(ji,nlcj-1) = zub(ji,nlcj-1) + e3u_a(ji,nlcj-1,jk) * ua(ji,nlcj-1,jk) * umask(ji,nlcj-1,jk) 354 END DO 355 END DO 356 DO ji = 1, jpi 357 zub(ji,nlcj-1) = zub(ji,nlcj-1) * r1_hu_a(ji,nlcj-1) 358 END DO 359 ! 360 DO jk = 1, jpkm1 361 DO ji = 1, jpi 362 ua(ji,nlcj-1,jk) = ( ua(ji,nlcj-1,jk) + ua_b(ji,nlcj-1) - zub(ji,nlcj-1) ) * umask(ji,nlcj-1,jk) 363 END DO 364 END DO 365 ENDIF 366 ! 367 ! Mask domain edges: 368 !------------------- 369 DO jk = 1, jpkm1 370 DO ji = 1, jpi 371 ua(ji,nlcj ,jk) = 0._wp 372 va(ji,nlcj-1,jk) = 0._wp 373 END DO 374 END DO 375 ! 376 ENDIF 377 ! 378 CALL wrk_dealloc( jpi,jpj, zub, zvb ) 379 ! DO jk = 1, jpkm1 380 ! DO ji = 1, jpi 381 ! ua(ji,nlcj ,jk) = 0._wp 382 ! va(ji,nlcj-1,jk) = 0._wp 383 ! END DO 384 ! END DO 385 ! 386 ENDIF 379 387 ! 380 388 END SUBROUTINE Agrif_dyn … … 385 393 !! *** ROUTINE Agrif_dyn_ts *** 386 394 !!---------------------------------------------------------------------- 387 !!388 395 INTEGER, INTENT(in) :: jn 389 396 !! … … 392 399 ! 393 400 IF( Agrif_Root() ) RETURN 394 ! 401 !! clem ghost 395 402 IF((nbondi == -1).OR.(nbondi == 2)) THEN 396 403 DO jj=1,jpj 397 va_e(2 ,jj) = vbdy_w(jj) * hvr_e(2,jj)404 va_e(2:nbghostcells+1,jj) = vbdy_w(jj) * hvr_e(2:nbghostcells+1,jj) 398 405 ! Specified fluxes: 399 ua_e(2 ,jj) = ubdy_w(jj) * hur_e(2,jj)400 ! Characteristics method :406 ua_e(2:nbghostcells+1,jj) = ubdy_w(jj) * hur_e(2:nbghostcells+1,jj) 407 ! Characteristics method (only if ghostcells=1): 401 408 !alt ua_e(2,jj) = 0.5_wp * ( ubdy_w(jj) * hur_e(2,jj) + ua_e(3,jj) & 402 409 !alt & - sqrt(grav * hur_e(2,jj)) * (sshn_e(3,jj) - hbdy_w(jj)) ) … … 406 413 IF((nbondi == 1).OR.(nbondi == 2)) THEN 407 414 DO jj=1,jpj 408 va_e(nlci- 1,jj) = vbdy_e(jj) * hvr_e(nlci-1,jj)415 va_e(nlci-nbghostcells:nlci-1,jj) = vbdy_e(jj) * hvr_e(nlci-nbghostcells:nlci-1,jj) 409 416 ! Specified fluxes: 410 ua_e(nlci- 2,jj) = ubdy_e(jj) * hur_e(nlci-2,jj)411 ! Characteristics method :417 ua_e(nlci-nbghostcells-1:nlci-2,jj) = ubdy_e(jj) * hur_e(nlci-nbghostcells-1:nlci-2,jj) 418 ! Characteristics method (only if ghostcells=1): 412 419 !alt ua_e(nlci-2,jj) = 0.5_wp * ( ubdy_e(jj) * hur_e(nlci-2,jj) + ua_e(nlci-3,jj) & 413 420 !alt & + sqrt(grav * hur_e(nlci-2,jj)) * (sshn_e(nlci-2,jj) - hbdy_e(jj)) ) … … 417 424 IF((nbondj == -1).OR.(nbondj == 2)) THEN 418 425 DO ji=1,jpi 419 ua_e(ji,2 ) = ubdy_s(ji) * hur_e(ji,2)426 ua_e(ji,2:nbghostcells+1) = ubdy_s(ji) * hur_e(ji,2:nbghostcells+1) 420 427 ! Specified fluxes: 421 va_e(ji,2 ) = vbdy_s(ji) * hvr_e(ji,2)422 ! Characteristics method :428 va_e(ji,2:nbghostcells+1) = vbdy_s(ji) * hvr_e(ji,2:nbghostcells+1) 429 ! Characteristics method (only if ghostcells=1): 423 430 !alt va_e(ji,2) = 0.5_wp * ( vbdy_s(ji) * hvr_e(ji,2) + va_e(ji,3) & 424 431 !alt & - sqrt(grav * hvr_e(ji,2)) * (sshn_e(ji,3) - hbdy_s(ji)) ) … … 428 435 IF((nbondj == 1).OR.(nbondj == 2)) THEN 429 436 DO ji=1,jpi 430 ua_e(ji,nlcj- 1) = ubdy_n(ji) * hur_e(ji,nlcj-1)437 ua_e(ji,nlcj-nbghostcells:nlcj-1) = ubdy_n(ji) * hur_e(ji,nlcj-nbghostcells:nlcj-1) 431 438 ! Specified fluxes: 432 va_e(ji,nlcj- 2) = vbdy_n(ji) * hvr_e(ji,nlcj-2)433 ! Characteristics method :439 va_e(ji,nlcj-nbghostcells-1:nlcj-2) = vbdy_n(ji) * hvr_e(ji,nlcj-nbghostcells-1:nlcj-2) 440 ! Characteristics method (only if ghostcells=1): 434 441 !alt va_e(ji,nlcj-2) = 0.5_wp * ( vbdy_n(ji) * hvr_e(ji,nlcj-2) + va_e(ji,nlcj-3) & 435 442 !alt & + sqrt(grav * hvr_e(ji,nlcj-2)) * (sshn_e(ji,nlcj-2) - hbdy_n(ji)) ) … … 444 451 !! *** ROUTINE Agrif_dta_ts *** 445 452 !!---------------------------------------------------------------------- 446 !!447 453 INTEGER, INTENT(in) :: kt 448 454 !! … … 476 482 ! 477 483 IF( ll_int_cons ) THEN ! Conservative interpolation 478 ! order smatters here !!!!!!484 ! order matters here !!!!!! 479 485 CALL Agrif_Bc_variable( ub2b_interp_id, calledweight=1._wp, procname=interpub2b ) ! Time integrated 480 486 CALL Agrif_Bc_variable( vb2b_interp_id, calledweight=1._wp, procname=interpvb2b ) … … 504 510 !!---------------------------------------------------------------------- 505 511 INTEGER, INTENT(in) :: kt 506 !! 512 ! 513 INTEGER :: ji, jj, indx 507 514 !!---------------------------------------------------------------------- 508 515 ! 509 516 IF( Agrif_Root() ) RETURN 510 ! 517 !! clem ghost 518 ! --- West --- ! 511 519 IF((nbondi == -1).OR.(nbondi == 2)) THEN 512 ssha(2,:)=ssha(3,:) 513 sshn(2,:)=sshn(3,:) 514 ENDIF 515 ! 520 indx = 1+nbghostcells 521 DO jj = 1, jpj 522 DO ji = 2, indx 523 ssha(ji,jj)=ssha(indx+1,jj) 524 sshn(ji,jj)=sshn(indx+1,jj) 525 ENDDO 526 ENDDO 527 ENDIF 528 ! 529 ! --- East --- ! 516 530 IF((nbondi == 1).OR.(nbondi == 2)) THEN 517 ssha(nlci-1,:)=ssha(nlci-2,:) 518 sshn(nlci-1,:)=sshn(nlci-2,:) 519 ENDIF 520 ! 531 indx = nlci-nbghostcells 532 DO jj = 1, jpj 533 DO ji = indx, nlci-1 534 ssha(ji,jj)=ssha(indx-1,jj) 535 sshn(ji,jj)=sshn(indx-1,jj) 536 ENDDO 537 ENDDO 538 ENDIF 539 ! 540 ! --- South --- ! 521 541 IF((nbondj == -1).OR.(nbondj == 2)) THEN 522 ssha(:,2)=ssha(:,3) 523 sshn(:,2)=sshn(:,3) 524 ENDIF 525 ! 542 indx = 1+nbghostcells 543 DO jj = 2, indx 544 DO ji = 1, jpi 545 ssha(ji,jj)=ssha(ji,indx+1) 546 sshn(ji,jj)=sshn(ji,indx+1) 547 ENDDO 548 ENDDO 549 ENDIF 550 ! 551 ! --- North --- ! 526 552 IF((nbondj == 1).OR.(nbondj == 2)) THEN 527 ssha(:,nlcj-1)=ssha(:,nlcj-2) 528 sshn(:,nlcj-1)=sshn(:,nlcj-2) 553 indx = nlcj-nbghostcells 554 DO jj = indx, nlcj-1 555 DO ji = 1, jpi 556 ssha(ji,jj)=ssha(ji,indx-1) 557 sshn(ji,jj)=sshn(ji,indx-1) 558 ENDDO 559 ENDDO 529 560 ENDIF 530 561 ! … … 538 569 INTEGER, INTENT(in) :: jn 539 570 !! 540 INTEGER :: ji, jj541 !!---------------------------------------------------------------------- 542 ! 571 INTEGER :: ji, jj 572 !!---------------------------------------------------------------------- 573 !! clem ghost (starting at i,j=1 is important I think otherwise you introduce a grad(ssh)/=0 at point 2) 543 574 IF((nbondi == -1).OR.(nbondi == 2)) THEN 544 575 DO jj = 1, jpj 545 ssha_e(2 ,jj) = hbdy_w(jj)576 ssha_e(2:nbghostcells+1,jj) = hbdy_w(jj) 546 577 END DO 547 578 ENDIF … … 549 580 IF((nbondi == 1).OR.(nbondi == 2)) THEN 550 581 DO jj = 1, jpj 551 ssha_e(nlci- 1,jj) = hbdy_e(jj)582 ssha_e(nlci-nbghostcells:nlci-1,jj) = hbdy_e(jj) 552 583 END DO 553 584 ENDIF … … 555 586 IF((nbondj == -1).OR.(nbondj == 2)) THEN 556 587 DO ji = 1, jpi 557 ssha_e(ji,2 ) = hbdy_s(ji)588 ssha_e(ji,2:nbghostcells+1) = hbdy_s(ji) 558 589 END DO 559 590 ENDIF … … 561 592 IF((nbondj == 1).OR.(nbondj == 2)) THEN 562 593 DO ji = 1, jpi 563 ssha_e(ji,nlcj- 1) = hbdy_n(ji)594 ssha_e(ji,nlcj-nbghostcells:nlcj-1) = hbdy_n(ji) 564 595 END DO 565 596 ENDIF … … 567 598 END SUBROUTINE Agrif_ssh_ts 568 599 569 # if defined key_zdftke 570 571 SUBROUTINE Agrif_tke 572 !!---------------------------------------------------------------------- 573 !! *** ROUTINE Agrif_tke *** 600 601 SUBROUTINE Agrif_avm 602 !!---------------------------------------------------------------------- 603 !! *** ROUTINE Agrif_avm *** 574 604 !!---------------------------------------------------------------------- 575 605 REAL(wp) :: zalpha 576 606 !!---------------------------------------------------------------------- 577 607 ! 578 zalpha = REAL( Agrif_NbStepint() + Agrif_IRhot() - 1, wp ) / REAL( Agrif_IRhot(), wp ) 579 IF( zalpha > 1. ) zalpha = 1. 580 ! 581 Agrif_SpecialValue = 0.e0 608 zalpha = 1._wp ! proper time interpolation impossible ==> use last available value from parent 609 ! 610 Agrif_SpecialValue = 0._wp 582 611 Agrif_UseSpecialValue = .TRUE. 583 612 ! 584 CALL Agrif_Bc_variable( avm_id ,calledweight=zalpha, procname=interpavm)613 CALL Agrif_Bc_variable( avm_id, calledweight=zalpha, procname=interpavm ) 585 614 ! 586 615 Agrif_UseSpecialValue = .FALSE. 587 616 ! 588 END SUBROUTINE Agrif_ tke617 END SUBROUTINE Agrif_avm 589 618 590 # endif591 619 592 620 SUBROUTINE interptsn( ptab, i1, i2, j1, j2, k1, k2, n1, n2, before, nb, ndir ) 593 621 !!---------------------------------------------------------------------- 594 !! *** ROUTINE interptsn ***622 !! *** ROUTINE interptsn *** 595 623 !!---------------------------------------------------------------------- 596 624 REAL(wp), DIMENSION(i1:i2,j1:j2,k1:k2,n1:n2), INTENT(inout) :: ptab … … 601 629 INTEGER :: ji, jj, jk, jn ! dummy loop indices 602 630 INTEGER :: imin, imax, jmin, jmax 603 REAL(wp) :: zrhox , zalpha1, zalpha2, zalpha3 604 REAL(wp) :: zalpha4, zalpha5, zalpha6, zalpha7 631 REAL(wp) :: zrhox, z1, z2, z3, z4, z5, z6, z7 605 632 LOGICAL :: western_side, eastern_side,northern_side,southern_side 606 633 !!---------------------------------------------------------------------- 607 634 ! 608 IF (before) THEN635 IF( before ) THEN 609 636 ptab(i1:i2,j1:j2,k1:k2,n1:n2) = tsn(i1:i2,j1:j2,k1:k2,n1:n2) 610 637 ELSE 611 638 ! 612 western_side = (nb == 1).AND.(ndir == 1) 613 eastern_side = (nb == 1).AND.(ndir == 2) 614 southern_side = (nb == 2).AND.(ndir == 1) 615 northern_side = (nb == 2).AND.(ndir == 2) 616 ! 617 zrhox = Agrif_Rhox() 618 ! 619 zalpha1 = ( zrhox - 1. ) * 0.5 620 zalpha2 = 1. - zalpha1 621 ! 622 zalpha3 = ( zrhox - 1. ) / ( zrhox + 1. ) 623 zalpha4 = 1. - zalpha3 624 ! 625 zalpha6 = 2. * ( zrhox - 1. ) / ( zrhox + 1. ) 626 zalpha7 = - ( zrhox - 1. ) / ( zrhox + 3. ) 627 zalpha5 = 1. - zalpha6 - zalpha7 628 ! 629 imin = i1 630 imax = i2 631 jmin = j1 632 jmax = j2 633 ! 634 ! Remove CORNERS 635 IF((nbondj == -1).OR.(nbondj == 2)) jmin = 3 636 IF((nbondj == +1).OR.(nbondj == 2)) jmax = nlcj-2 637 IF((nbondi == -1).OR.(nbondi == 2)) imin = 3 638 IF((nbondi == +1).OR.(nbondi == 2)) imax = nlci-2 639 ! 640 IF( eastern_side ) THEN 641 DO jn = 1, jpts 642 tsa(nlci,j1:j2,k1:k2,jn) = zalpha1 * ptab(nlci,j1:j2,k1:k2,jn) + zalpha2 * ptab(nlci-1,j1:j2,k1:k2,jn) 643 DO jk = 1, jpkm1 644 DO jj = jmin,jmax 645 IF( umask(nlci-2,jj,jk) == 0._wp ) THEN 646 tsa(nlci-1,jj,jk,jn) = tsa(nlci,jj,jk,jn) * tmask(nlci-1,jj,jk) 647 ELSE 648 tsa(nlci-1,jj,jk,jn)=(zalpha4*tsa(nlci,jj,jk,jn)+zalpha3*tsa(nlci-2,jj,jk,jn))*tmask(nlci-1,jj,jk) 649 IF( un(nlci-2,jj,jk) > 0._wp ) THEN 650 tsa(nlci-1,jj,jk,jn)=( zalpha6*tsa(nlci-2,jj,jk,jn)+zalpha5*tsa(nlci,jj,jk,jn) & 651 + zalpha7*tsa(nlci-3,jj,jk,jn) ) * tmask(nlci-1,jj,jk) 639 western_side = (nb == 1).AND.(ndir == 1) ; eastern_side = (nb == 1).AND.(ndir == 2) 640 southern_side = (nb == 2).AND.(ndir == 1) ; northern_side = (nb == 2).AND.(ndir == 2) 641 ! 642 IF( nbghostcells > 1 ) THEN ! no smoothing 643 tsa(i1:i2,j1:j2,k1:k2,n1:n2) = ptab(i1:i2,j1:j2,k1:k2,n1:n2) 644 ELSE ! smoothing 645 ! 646 zrhox = Agrif_Rhox() 647 z1 = ( zrhox - 1. ) * 0.5 648 z3 = ( zrhox - 1. ) / ( zrhox + 1. ) 649 z6 = 2. * ( zrhox - 1. ) / ( zrhox + 1. ) 650 z7 = - ( zrhox - 1. ) / ( zrhox + 3. ) 651 ! 652 z2 = 1. - z1 653 z4 = 1. - z3 654 z5 = 1. - z6 - z7 655 ! 656 imin = i1 ; imax = i2 657 jmin = j1 ; jmax = j2 658 ! 659 ! Remove CORNERS 660 IF((nbondj == -1).OR.(nbondj == 2)) jmin = 3 661 IF((nbondj == +1).OR.(nbondj == 2)) jmax = nlcj-2 662 IF((nbondi == -1).OR.(nbondi == 2)) imin = 3 663 IF((nbondi == +1).OR.(nbondi == 2)) imax = nlci-2 664 ! 665 IF( eastern_side ) THEN 666 DO jn = 1, jpts 667 tsa(nlci,j1:j2,k1:k2,jn) = z1 * ptab(nlci,j1:j2,k1:k2,jn) + z2 * ptab(nlci-1,j1:j2,k1:k2,jn) 668 DO jk = 1, jpkm1 669 DO jj = jmin,jmax 670 IF( umask(nlci-2,jj,jk) == 0._wp ) THEN 671 tsa(nlci-1,jj,jk,jn) = tsa(nlci,jj,jk,jn) * tmask(nlci-1,jj,jk) 672 ELSE 673 tsa(nlci-1,jj,jk,jn)=(z4*tsa(nlci,jj,jk,jn)+z3*tsa(nlci-2,jj,jk,jn))*tmask(nlci-1,jj,jk) 674 IF( un(nlci-2,jj,jk) > 0._wp ) THEN 675 tsa(nlci-1,jj,jk,jn)=( z6*tsa(nlci-2,jj,jk,jn)+z5*tsa(nlci,jj,jk,jn) & 676 + z7*tsa(nlci-3,jj,jk,jn) ) * tmask(nlci-1,jj,jk) 677 ENDIF 652 678 ENDIF 653 END IF679 END DO 654 680 END DO 655 END DO656 tsa(nlci,j1:j2,k1:k2,jn) = 0._wp657 END DO658 ENDIF659 !660 IF( northern_side ) THEN661 DO jn = 1, jpts662 tsa(i1:i2,nlcj,k1:k2,jn) = zalpha1 * ptab(i1:i2,nlcj,k1:k2,jn) + zalpha2 * ptab(i1:i2,nlcj-1,k1:k2,jn)663 DO jk = 1, jpkm1664 DO ji = imin,imax665 IF( vmask(ji,nlcj-2,jk) == 0._wp ) THEN666 tsa(ji,nlcj-1,jk,jn) = tsa(ji,nlcj,jk,jn) * tmask(ji,nlcj-1,jk)667 ELSE668 tsa(ji,nlcj-1,jk,jn)=(zalpha4*tsa(ji,nlcj,jk,jn)+zalpha3*tsa(ji,nlcj-2,jk,jn))*tmask(ji,nlcj-1,jk)669 IF (vn(ji,nlcj-2,jk) > 0._wp ) THEN670 tsa(ji,nlcj-1,jk,jn)=( zalpha6*tsa(ji,nlcj-2,jk,jn)+zalpha5*tsa(ji,nlcj,jk,jn) &671 + zalpha7*tsa(ji,nlcj-3,jk,jn) ) * tmask(ji,nlcj-1,jk)681 tsa(nlci,j1:j2,k1:k2,jn) = 0._wp 682 END DO 683 ENDIF 684 ! 685 IF( northern_side ) THEN 686 DO jn = 1, jpts 687 tsa(i1:i2,nlcj,k1:k2,jn) = z1 * ptab(i1:i2,nlcj,k1:k2,jn) + z2 * ptab(i1:i2,nlcj-1,k1:k2,jn) 688 DO jk = 1, jpkm1 689 DO ji = imin,imax 690 IF( vmask(ji,nlcj-2,jk) == 0._wp ) THEN 691 tsa(ji,nlcj-1,jk,jn) = tsa(ji,nlcj,jk,jn) * tmask(ji,nlcj-1,jk) 692 ELSE 693 tsa(ji,nlcj-1,jk,jn)=(z4*tsa(ji,nlcj,jk,jn)+z3*tsa(ji,nlcj-2,jk,jn))*tmask(ji,nlcj-1,jk) 694 IF (vn(ji,nlcj-2,jk) > 0._wp ) THEN 695 tsa(ji,nlcj-1,jk,jn)=( z6*tsa(ji,nlcj-2,jk,jn)+z5*tsa(ji,nlcj,jk,jn) & 696 + z7*tsa(ji,nlcj-3,jk,jn) ) * tmask(ji,nlcj-1,jk) 697 ENDIF 672 698 ENDIF 673 END IF699 END DO 674 700 END DO 675 END DO676 tsa(i1:i2,nlcj,k1:k2,jn) = 0._wp677 END DO678 ENDIF679 !680 IF( western_side ) THEN681 DO jn = 1, jpts682 tsa(1,j1:j2,k1:k2,jn) = zalpha1 * ptab(1,j1:j2,k1:k2,jn) + zalpha2 * ptab(2,j1:j2,k1:k2,jn)683 DO jk = 1, jpkm1684 DO jj = jmin,jmax685 IF( umask(2,jj,jk) == 0._wp ) THEN686 tsa(2,jj,jk,jn) = tsa(1,jj,jk,jn) * tmask(2,jj,jk)687 ELSE688 tsa(2,jj,jk,jn)=(zalpha4*tsa(1,jj,jk,jn)+zalpha3*tsa(3,jj,jk,jn))*tmask(2,jj,jk)689 IF( un(2,jj,jk) < 0._wp ) THEN690 tsa(2,jj,jk,jn)=(zalpha6*tsa(3,jj,jk,jn)+zalpha5*tsa(1,jj,jk,jn)+zalpha7*tsa(4,jj,jk,jn))*tmask(2,jj,jk)701 tsa(i1:i2,nlcj,k1:k2,jn) = 0._wp 702 END DO 703 ENDIF 704 ! 705 IF( western_side ) THEN 706 DO jn = 1, jpts 707 tsa(1,j1:j2,k1:k2,jn) = z1 * ptab(1,j1:j2,k1:k2,jn) + z2 * ptab(2,j1:j2,k1:k2,jn) 708 DO jk = 1, jpkm1 709 DO jj = jmin,jmax 710 IF( umask(2,jj,jk) == 0._wp ) THEN 711 tsa(2,jj,jk,jn) = tsa(1,jj,jk,jn) * tmask(2,jj,jk) 712 ELSE 713 tsa(2,jj,jk,jn)=(z4*tsa(1,jj,jk,jn)+z3*tsa(3,jj,jk,jn))*tmask(2,jj,jk) 714 IF( un(2,jj,jk) < 0._wp ) THEN 715 tsa(2,jj,jk,jn)=(z6*tsa(3,jj,jk,jn)+z5*tsa(1,jj,jk,jn)+z7*tsa(4,jj,jk,jn))*tmask(2,jj,jk) 716 ENDIF 691 717 ENDIF 692 END IF718 END DO 693 719 END DO 694 END DO695 tsa(1,j1:j2,k1:k2,jn) = 0._wp696 END DO697 ENDIF698 !699 IF( southern_side ) THEN700 DO jn = 1, jpts701 tsa(i1:i2,1,k1:k2,jn) = zalpha1 * ptab(i1:i2,1,k1:k2,jn) + zalpha2 * ptab(i1:i2,2,k1:k2,jn)702 DO jk = 1, jpk703 DO ji=imin,imax704 IF( vmask(ji,2,jk) == 0._wp ) THEN705 tsa(ji,2,jk,jn)=tsa(ji,1,jk,jn) * tmask(ji,2,jk)706 ELSE707 tsa(ji,2,jk,jn)=(zalpha4*tsa(ji,1,jk,jn)+zalpha3*tsa(ji,3,jk,jn))*tmask(ji,2,jk)708 IF( vn(ji,2,jk) < 0._wp ) THEN709 tsa(ji,2,jk,jn)=(zalpha6*tsa(ji,3,jk,jn)+zalpha5*tsa(ji,1,jk,jn)+zalpha7*tsa(ji,4,jk,jn))*tmask(ji,2,jk)720 tsa(1,j1:j2,k1:k2,jn) = 0._wp 721 END DO 722 ENDIF 723 ! 724 IF( southern_side ) THEN 725 DO jn = 1, jpts 726 tsa(i1:i2,1,k1:k2,jn) = z1 * ptab(i1:i2,1,k1:k2,jn) + z2 * ptab(i1:i2,2,k1:k2,jn) 727 DO jk = 1, jpk 728 DO ji=imin,imax 729 IF( vmask(ji,2,jk) == 0._wp ) THEN 730 tsa(ji,2,jk,jn)=tsa(ji,1,jk,jn) * tmask(ji,2,jk) 731 ELSE 732 tsa(ji,2,jk,jn)=(z4*tsa(ji,1,jk,jn)+z3*tsa(ji,3,jk,jn))*tmask(ji,2,jk) 733 IF( vn(ji,2,jk) < 0._wp ) THEN 734 tsa(ji,2,jk,jn)=(z6*tsa(ji,3,jk,jn)+z5*tsa(ji,1,jk,jn)+z7*tsa(ji,4,jk,jn))*tmask(ji,2,jk) 735 ENDIF 710 736 ENDIF 711 END IF737 END DO 712 738 END DO 713 END DO 714 tsa(i1:i2,1,k1:k2,jn) = 0._wp 715 END DO 716 ENDIF 717 ! 718 ! Treatment of corners 719 ! 720 ! East south 721 IF ((eastern_side).AND.((nbondj == -1).OR.(nbondj == 2))) THEN 722 tsa(nlci-1,2,:,:) = ptab(nlci-1,2,:,:) 723 ENDIF 724 ! East north 725 IF ((eastern_side).AND.((nbondj == 1).OR.(nbondj == 2))) THEN 726 tsa(nlci-1,nlcj-1,:,:) = ptab(nlci-1,nlcj-1,:,:) 727 ENDIF 728 ! West south 729 IF ((western_side).AND.((nbondj == -1).OR.(nbondj == 2))) THEN 730 tsa(2,2,:,:) = ptab(2,2,:,:) 731 ENDIF 732 ! West north 733 IF ((western_side).AND.((nbondj == 1).OR.(nbondj == 2))) THEN 734 tsa(2,nlcj-1,:,:) = ptab(2,nlcj-1,:,:) 735 ENDIF 736 ! 739 tsa(i1:i2,1,k1:k2,jn) = 0._wp 740 END DO 741 ENDIF 742 ! 743 ! Treatment of corners 744 IF ((eastern_side).AND.((nbondj == -1).OR.(nbondj == 2))) tsa(nlci-1,2,:,:) = ptab(nlci-1,2,:,:) ! East south 745 IF ((eastern_side).AND.((nbondj == 1).OR.(nbondj == 2))) tsa(nlci-1,nlcj-1,:,:) = ptab(nlci-1,nlcj-1,:,:) ! East north 746 IF ((western_side).AND.((nbondj == -1).OR.(nbondj == 2))) tsa(2,2,:,:) = ptab(2,2,:,:) ! West south 747 IF ((western_side).AND.((nbondj == 1).OR.(nbondj == 2))) tsa(2,nlcj-1,:,:) = ptab(2,nlcj-1,:,:) ! West north 748 ! 749 ENDIF 737 750 ENDIF 738 751 ! … … 759 772 southern_side = (nb == 2).AND.(ndir == 1) 760 773 northern_side = (nb == 2).AND.(ndir == 2) 761 IF(western_side) hbdy_w(j1:j2) = ptab(i1,j1:j2) * tmask(i1,j1:j2,1) 762 IF(eastern_side) hbdy_e(j1:j2) = ptab(i1,j1:j2) * tmask(i1,j1:j2,1) 763 IF(southern_side) hbdy_s(i1:i2) = ptab(i1:i2,j1) * tmask(i1:i2,j1,1) 774 !! clem ghost 775 IF(western_side) hbdy_w(j1:j2) = ptab(i2,j1:j2) * tmask(i2,j1:j2,1) 776 IF(eastern_side) hbdy_e(j1:j2) = ptab(i1,j1:j2) * tmask(i1,j1:j2,1) !clem previously i1 777 IF(southern_side) hbdy_s(i1:i2) = ptab(i1:i2,j2) * tmask(i1:i2,j2,1) !clem previously j1 764 778 IF(northern_side) hbdy_n(i1:i2) = ptab(i1:i2,j1) * tmask(i1:i2,j1,1) 765 779 ENDIF … … 770 784 SUBROUTINE interpun( ptab, i1, i2, j1, j2, k1, k2, before ) 771 785 !!---------------------------------------------------------------------- 772 !! *** ROUTINE interpun ***786 !! *** ROUTINE interpun *** 773 787 !!---------------------------------------------------------------------- 774 788 INTEGER , INTENT(in ) :: i1, i2, j1, j2, k1, k2 … … 798 812 SUBROUTINE interpvn( ptab, i1, i2, j1, j2, k1, k2, before ) 799 813 !!---------------------------------------------------------------------- 800 !! *** ROUTINE interpvn ***814 !! *** ROUTINE interpvn *** 801 815 !!---------------------------------------------------------------------- 802 816 INTEGER , INTENT(in ) :: i1, i2, j1, j2, k1, k2 … … 854 868 ELSEIF( bdy_tinterp == 2 ) THEN 855 869 ztcoeff = zrhot * ( zt1 * ( zt1 - 1._wp)**2._wp & 856 & - zt0 * ( zt0 - 1._wp)**2._wp ) 857 870 & - zt0 * ( zt0 - 1._wp)**2._wp ) 858 871 ELSE 859 872 ztcoeff = 1 860 873 ENDIF 861 ! 862 IF(western_side) THEN 863 ubdy_w(j1:j2) = ubdy_w(j1:j2) + ztcoeff * ptab(i1,j1:j2) 864 ENDIF 865 IF(eastern_side) THEN 866 ubdy_e(j1:j2) = ubdy_e(j1:j2) + ztcoeff * ptab(i1,j1:j2) 867 ENDIF 868 IF(southern_side) THEN 869 ubdy_s(i1:i2) = ubdy_s(i1:i2) + ztcoeff * ptab(i1:i2,j1) 870 ENDIF 871 IF(northern_side) THEN 872 ubdy_n(i1:i2) = ubdy_n(i1:i2) + ztcoeff * ptab(i1:i2,j1) 873 ENDIF 874 !! clem ghost 875 IF(western_side) ubdy_w(j1:j2) = ubdy_w(j1:j2) + ztcoeff * ptab(i2,j1:j2) 876 IF(eastern_side) ubdy_e(j1:j2) = ubdy_e(j1:j2) + ztcoeff * ptab(i1,j1:j2) !clem previously i1 877 IF(southern_side) ubdy_s(i1:i2) = ubdy_s(i1:i2) + ztcoeff * ptab(i1:i2,j2) !clem previously j1 878 IF(northern_side) ubdy_n(i1:i2) = ubdy_n(i1:i2) + ztcoeff * ptab(i1:i2,j1) 874 879 ! 875 880 IF( bdy_tinterp == 0 .OR. bdy_tinterp == 2) THEN 876 IF(western_side) THEN 877 ubdy_w(j1:j2) = ubdy_w(j1:j2) / (zrhoy*e2u(i1,j1:j2)) * umask(i1,j1:j2,1) 878 ENDIF 879 IF(eastern_side) THEN 880 ubdy_e(j1:j2) = ubdy_e(j1:j2) / (zrhoy*e2u(i1,j1:j2)) * umask(i1,j1:j2,1) 881 ENDIF 882 IF(southern_side) THEN 883 ubdy_s(i1:i2) = ubdy_s(i1:i2) / (zrhoy*e2u(i1:i2,j1)) * umask(i1:i2,j1,1) 884 ENDIF 885 IF(northern_side) THEN 886 ubdy_n(i1:i2) = ubdy_n(i1:i2) / (zrhoy*e2u(i1:i2,j1)) * umask(i1:i2,j1,1) 887 ENDIF 881 IF(western_side) ubdy_w(j1:j2) = ubdy_w(j1:j2) / (zrhoy*e2u(i2,j1:j2)) * umask(i2,j1:j2,1) 882 IF(eastern_side) ubdy_e(j1:j2) = ubdy_e(j1:j2) / (zrhoy*e2u(i1,j1:j2)) * umask(i1,j1:j2,1) 883 IF(southern_side) ubdy_s(i1:i2) = ubdy_s(i1:i2) / (zrhoy*e2u(i1:i2,j2)) * umask(i1:i2,j2,1) 884 IF(northern_side) ubdy_n(i1:i2) = ubdy_n(i1:i2) / (zrhoy*e2u(i1:i2,j1)) * umask(i1:i2,j1,1) 888 885 ENDIF 889 886 ENDIF … … 927 924 ztcoeff = 1 928 925 ENDIF 929 ! 930 IF(western_side) THEN 931 vbdy_w(j1:j2) = vbdy_w(j1:j2) + ztcoeff * ptab(i1,j1:j2) 932 ENDIF 933 IF(eastern_side) THEN 934 vbdy_e(j1:j2) = vbdy_e(j1:j2) + ztcoeff * ptab(i1,j1:j2) 935 ENDIF 936 IF(southern_side) THEN 937 vbdy_s(i1:i2) = vbdy_s(i1:i2) + ztcoeff * ptab(i1:i2,j1) 938 ENDIF 939 IF(northern_side) THEN 940 vbdy_n(i1:i2) = vbdy_n(i1:i2) + ztcoeff * ptab(i1:i2,j1) 941 ENDIF 926 !! clem ghost 927 IF(western_side) vbdy_w(j1:j2) = vbdy_w(j1:j2) + ztcoeff * ptab(i2,j1:j2) 928 IF(eastern_side) vbdy_e(j1:j2) = vbdy_e(j1:j2) + ztcoeff * ptab(i1,j1:j2) !clem previously i1 929 IF(southern_side) vbdy_s(i1:i2) = vbdy_s(i1:i2) + ztcoeff * ptab(i1:i2,j2) !clem previously j1 930 IF(northern_side) vbdy_n(i1:i2) = vbdy_n(i1:i2) + ztcoeff * ptab(i1:i2,j1) 942 931 ! 943 932 IF( bdy_tinterp == 0 .OR. bdy_tinterp == 2) THEN 944 IF(western_side) THEN 945 vbdy_w(j1:j2) = vbdy_w(j1:j2) / (zrhox*e1v(i1,j1:j2)) & 946 & * vmask(i1,j1:j2,1) 947 ENDIF 948 IF(eastern_side) THEN 949 vbdy_e(j1:j2) = vbdy_e(j1:j2) / (zrhox*e1v(i1,j1:j2)) & 950 & * vmask(i1,j1:j2,1) 951 ENDIF 952 IF(southern_side) THEN 953 vbdy_s(i1:i2) = vbdy_s(i1:i2) / (zrhox*e1v(i1:i2,j1)) & 954 & * vmask(i1:i2,j1,1) 955 ENDIF 956 IF(northern_side) THEN 957 vbdy_n(i1:i2) = vbdy_n(i1:i2) / (zrhox*e1v(i1:i2,j1)) & 958 & * vmask(i1:i2,j1,1) 959 ENDIF 933 IF(western_side) vbdy_w(j1:j2) = vbdy_w(j1:j2) / (zrhox*e1v(i2,j1:j2)) * vmask(i2,j1:j2,1) 934 IF(eastern_side) vbdy_e(j1:j2) = vbdy_e(j1:j2) / (zrhox*e1v(i1,j1:j2)) * vmask(i1,j1:j2,1) 935 IF(southern_side) vbdy_s(i1:i2) = vbdy_s(i1:i2) / (zrhox*e1v(i1:i2,j2)) * vmask(i1:i2,j2,1) 936 IF(northern_side) vbdy_n(i1:i2) = vbdy_n(i1:i2) / (zrhox*e1v(i1:i2,j1)) * vmask(i1:i2,j1,1) 960 937 ENDIF 961 938 ENDIF … … 991 968 zat = zrhot * ( zt1**2._wp * (-2._wp*zt1 + 3._wp) & 992 969 & - zt0**2._wp * (-2._wp*zt0 + 3._wp) ) 993 ! 994 IF(western_side ) ubdy_w(j1:j2) = zat * ptab(i 1,j1:j2)995 IF(eastern_side ) ubdy_e(j1:j2) = zat * ptab(i1,j1:j2) 996 IF(southern_side) ubdy_s(i1:i2) = zat * ptab(i1:i2,j 1)970 !! clem ghost 971 IF(western_side ) ubdy_w(j1:j2) = zat * ptab(i2,j1:j2) 972 IF(eastern_side ) ubdy_e(j1:j2) = zat * ptab(i1,j1:j2) !clem previously i1 973 IF(southern_side) ubdy_s(i1:i2) = zat * ptab(i1:i2,j2) !clem previously j1 997 974 IF(northern_side) ubdy_n(i1:i2) = zat * ptab(i1:i2,j1) 998 975 ENDIF … … 1030 1007 & - zt0**2._wp * (-2._wp*zt0 + 3._wp) ) 1031 1008 ! 1032 IF(western_side ) vbdy_w(j1:j2) = zat * ptab(i 1,j1:j2)1033 IF(eastern_side ) vbdy_e(j1:j2) = zat * ptab(i1,j1:j2) 1034 IF(southern_side) vbdy_s(i1:i2) = zat * ptab(i1:i2,j 1)1009 IF(western_side ) vbdy_w(j1:j2) = zat * ptab(i2,j1:j2) 1010 IF(eastern_side ) vbdy_e(j1:j2) = zat * ptab(i1,j1:j2) !clem previously i1 1011 IF(southern_side) vbdy_s(i1:i2) = zat * ptab(i1:i2,j2) !clem previously j1 1035 1012 IF(northern_side) vbdy_n(i1:i2) = zat * ptab(i1:i2,j1) 1036 1013 ENDIF … … 1050 1027 INTEGER :: ji, jj, jk 1051 1028 LOGICAL :: western_side, eastern_side, northern_side, southern_side 1052 REAL(wp) :: ztmpmsk1053 1029 !!---------------------------------------------------------------------- 1054 1030 ! … … 1060 1036 southern_side = (nb == 2).AND.(ndir == 1) 1061 1037 northern_side = (nb == 2).AND.(ndir == 2) 1062 1038 ! 1063 1039 DO jk = k1, k2 1064 1040 DO jj = j1, j2 1065 1041 DO ji = i1, i2 1066 ! Get velocity mask at boundary edge points:1067 IF( western_side ) ztmpmsk = umask(ji ,jj ,1)1068 IF( eastern_side ) ztmpmsk = umask(nlci-2,jj ,1)1069 IF( northern_side) ztmpmsk = vmask(ji ,nlcj-2,1)1070 IF( southern_side) ztmpmsk = vmask(ji ,2 ,1)1071 1042 ! 1072 IF( ABS( ptab(ji,jj,jk) - tmask(ji,jj,jk) * e3t_0(ji,jj,jk) ) *ztmpmsk> 1.D-2) THEN1043 IF( ABS( ptab(ji,jj,jk) - tmask(ji,jj,jk) * e3t_0(ji,jj,jk) ) > 1.D-2) THEN 1073 1044 IF (western_side) THEN 1074 1045 WRITE(numout,*) 'ERROR bathymetry merge at the western border ji,jj,jk ', ji+nimpp-1,jj+njmpp-1,jk … … 1175 1146 END SUBROUTINE interpvmsk 1176 1147 1177 # if defined key_zdftke1178 1148 1179 1149 SUBROUTINE interpavm( ptab, i1, i2, j1, j2, k1, k2, before ) … … 1186 1156 !!---------------------------------------------------------------------- 1187 1157 ! 1188 IF( before ) THEN 1189 ptab (i1:i2,j1:j2,k1:k2) = avm_k(i1:i2,j1:j2,k1:k2) 1190 ELSE 1191 avm_k(i1:i2,j1:j2,k1:k2) = ptab (i1:i2,j1:j2,k1:k2) 1158 IF( before ) THEN ; ptab (i1:i2,j1:j2,k1:k2) = avm_k(i1:i2,j1:j2,k1:k2) 1159 ELSE ; avm_k(i1:i2,j1:j2,k1:k2) = ptab (i1:i2,j1:j2,k1:k2) 1192 1160 ENDIF 1193 1161 ! 1194 1162 END SUBROUTINE interpavm 1195 1196 # endif /* key_zdftke */1197 1163 1198 1164 #else -
branches/2017/dev_CNRS_2017/NEMOGCM/NEMO/NST_SRC/agrif_opa_sponge.F90
r7646 r8882 3 3 MODULE agrif_opa_sponge 4 4 !!====================================================================== 5 !! *** MODULE agrif_opa_update***6 !! AGRIF :5 !! *** MODULE agrif_opa_interp *** 6 !! AGRIF: sponge package for the ocean dynamics (OPA) 7 7 !!====================================================================== 8 !! History : 8 !! History : 2.0 ! 2002-06 (XXX) Original cade 9 !! - ! 2005-11 (XXX) 10 !! 3.2 ! 2009-04 (R. Benshila) 11 !! 3.6 ! 2014-09 (R. Benshila) 9 12 !!---------------------------------------------------------------------- 10 13 #if defined key_agrif 14 !!---------------------------------------------------------------------- 15 !! 'key_agrif' AGRIF zoom 16 !!---------------------------------------------------------------------- 11 17 USE par_oce 12 18 USE oce 13 19 USE dom_oce 20 ! 14 21 USE in_out_manager 15 22 USE agrif_oce 16 USE wrk_nemo17 23 USE lbclnk ! ocean lateral boundary conditions (or mpp link) 18 24 … … 24 30 25 31 !!---------------------------------------------------------------------- 26 !! NEMO/NST 3.7 , NEMO Consortium (2015)32 !! NEMO/NST 4.0 , NEMO Consortium (2017) 27 33 !! $Id$ 28 34 !! Software governed by the CeCILL licence (NEMOGCM/NEMO_CeCILL.txt) … … 31 37 32 38 SUBROUTINE Agrif_Sponge_Tra 33 !!--------------------------------------------- 34 !! *** ROUTINE Agrif_Sponge_Tra ***35 !!--------------------------------------------- 36 REAL(wp) :: timecoeff37 !!--------------------------------------------- 39 !!---------------------------------------------------------------------- 40 !! *** ROUTINE Agrif_Sponge_Tra *** 41 !!---------------------------------------------------------------------- 42 REAL(wp) :: zcoef ! local scalar 43 !!---------------------------------------------------------------------- 38 44 ! 39 45 #if defined SPONGE 40 timecoeff = REAL(Agrif_NbStepint(),wp)/Agrif_rhot()41 46 zcoef = REAL( Agrif_NbStepint(), wp ) / Agrif_rhot() 47 ! 42 48 CALL Agrif_Sponge 43 Agrif_SpecialValue =0.49 Agrif_SpecialValue = 0._wp 44 50 Agrif_UseSpecialValue = .TRUE. 45 tabspongedone_tsn = .FALSE.46 47 CALL Agrif_Bc_Variable( tsn_sponge_id,calledweight=timecoeff,procname=interptsn_sponge)48 51 tabspongedone_tsn = .FALSE. 52 ! 53 CALL Agrif_Bc_Variable( tsn_sponge_id, calledweight=zcoef, procname=interptsn_sponge ) 54 ! 49 55 Agrif_UseSpecialValue = .FALSE. 50 56 #endif … … 54 60 55 61 SUBROUTINE Agrif_Sponge_dyn 56 !!--------------------------------------------- 57 !! *** ROUTINE Agrif_Sponge_dyn ***58 !!--------------------------------------------- 59 REAL(wp) :: timecoeff60 !!--------------------------------------------- 61 62 !!---------------------------------------------------------------------- 63 !! *** ROUTINE Agrif_Sponge_dyn *** 64 !!---------------------------------------------------------------------- 65 REAL(wp) :: zcoef ! local scalar 66 !!---------------------------------------------------------------------- 67 ! 62 68 #if defined SPONGE 63 timecoeff = REAL(Agrif_NbStepint(),wp)/Agrif_rhot()64 65 Agrif_SpecialValue =0.69 zcoef = REAL( Agrif_NbStepint(), wp ) / Agrif_rhot() 70 ! 71 Agrif_SpecialValue = 0._wp 66 72 Agrif_UseSpecialValue = ln_spc_dyn 67 73 ! 68 74 tabspongedone_u = .FALSE. 69 75 tabspongedone_v = .FALSE. 70 CALL Agrif_Bc_Variable( un_sponge_id,calledweight=timecoeff,procname=interpun_sponge)71 76 CALL Agrif_Bc_Variable( un_sponge_id, calledweight=zcoef, procname=interpun_sponge ) 77 ! 72 78 tabspongedone_u = .FALSE. 73 79 tabspongedone_v = .FALSE. 74 CALL Agrif_Bc_Variable( vn_sponge_id,calledweight=timecoeff,procname=interpvn_sponge)75 80 CALL Agrif_Bc_Variable( vn_sponge_id, calledweight=zcoef, procname=interpvn_sponge ) 81 ! 76 82 Agrif_UseSpecialValue = .FALSE. 77 83 #endif … … 81 87 82 88 SUBROUTINE Agrif_Sponge 83 !!--------------------------------------------- 84 !! *** ROUTINE Agrif_Sponge ***85 !!--------------------------------------------- 86 INTEGER :: ji,jj,jk87 INTEGER :: ispongearea, ilci, ilcj88 LOGICAL :: ll_spdone89 REAL(wp) :: z1spongearea, zramp90 REAL(wp), POINTER, DIMENSION(:,:) :: ztabramp91 89 !!---------------------------------------------------------------------- 90 !! *** ROUTINE Agrif_Sponge *** 91 !!---------------------------------------------------------------------- 92 INTEGER :: ji, jj, ind1, ind2 93 INTEGER :: ispongearea 94 REAL(wp) :: z1_spongearea 95 REAL(wp), DIMENSION(jpi,jpj) :: ztabramp 96 !!---------------------------------------------------------------------- 97 ! 92 98 #if defined SPONGE || defined SPONGE_TOP 93 ll_spdone=.TRUE.94 99 IF (( .NOT. spongedoneT ).OR.( .NOT. spongedoneU )) THEN 95 ! Define ramp from boundaries towards domain interior 96 ! at T-points 100 ! Define ramp from boundaries towards domain interior at T-points 97 101 ! Store it in ztabramp 98 ll_spdone=.FALSE.99 100 CALL wrk_alloc( jpi, jpj, ztabramp )101 102 102 103 ispongearea = 2 + nn_sponge_len * Agrif_irhox() 103 ilci = nlci - ispongearea 104 ilcj = nlcj - ispongearea 105 z1spongearea = 1._wp / REAL( ispongearea - 2 ) 106 104 z1_spongearea = 1._wp / REAL( ispongearea - 1 ) 105 107 106 ztabramp(:,:) = 0._wp 108 107 108 ! --- West --- ! 109 109 IF( (nbondi == -1) .OR. (nbondi == 2) ) THEN 110 ind1 = 1+nbghostcells 111 ind2 = 1+nbghostcells + (ispongearea-1) 110 112 DO jj = 1, jpj 111 IF ( umask(2,jj,1) == 1._wp ) THEN 112 DO ji = 2, ispongearea 113 ztabramp(ji,jj) = ( ispongearea-ji ) * z1spongearea 114 END DO 115 ENDIF 113 DO ji = ind1, ind2 114 ztabramp(ji,jj) = REAL( ind2 - ji ) * z1_spongearea * umask(ind1,jj,1) 115 END DO 116 116 ENDDO 117 117 ENDIF 118 118 119 ! --- East --- ! 119 120 IF( (nbondi == 1) .OR. (nbondi == 2) ) THEN 121 ind1 = nlci - (1+nbghostcells) - (ispongearea-1) 122 ind2 = nlci - (1+nbghostcells) 120 123 DO jj = 1, jpj 121 IF ( umask(nlci-2,jj,1) == 1._wp ) THEN 122 DO ji = ilci+1,nlci-1 123 zramp = (ji - (ilci+1) ) * z1spongearea 124 ztabramp(ji,jj) = MAX( ztabramp(ji,jj), zramp ) 125 ENDDO 126 ENDIF 124 DO ji = ind1, ind2 125 ztabramp(ji,jj) = MAX( ztabramp(ji,jj), REAL( ji - ind2 ) * z1_spongearea * umask(ind2-1,jj,1) ) 126 ENDDO 127 127 ENDDO 128 128 ENDIF 129 129 130 ! --- South --- ! 130 131 IF( (nbondj == -1) .OR. (nbondj == 2) ) THEN 131 DO ji = 1, jpi 132 IF ( vmask(ji,2,1) == 1._wp ) THEN 133 DO jj = 2, ispongearea 134 zramp = ( ispongearea-jj ) * z1spongearea 135 ztabramp(ji,jj) = MAX( ztabramp(ji,jj), zramp ) 136 END DO 137 ENDIF 132 ind1 = 1+nbghostcells 133 ind2 = 1+nbghostcells + (ispongearea-1) 134 DO jj = ind1, ind2 135 DO ji = 1, jpi 136 ztabramp(ji,jj) = MAX( ztabramp(ji,jj), REAL( ind2 - jj ) * z1_spongearea * vmask(ji,ind1,1) ) 137 END DO 138 138 ENDDO 139 139 ENDIF 140 140 141 ! --- North --- ! 141 142 IF( (nbondj == 1) .OR. (nbondj == 2) ) THEN 142 DO ji = 1, jpi 143 IF ( vmask(ji,nlcj-2,1) == 1._wp ) THEN 144 DO jj = ilcj+1,nlcj-1 145 zramp = (jj - (ilcj+1) ) * z1spongearea 146 ztabramp(ji,jj) = MAX( ztabramp(ji,jj), zramp ) 147 END DO 148 ENDIF 143 ind1 = nlcj - (1+nbghostcells) - (ispongearea-1) 144 ind2 = nlcj - (1+nbghostcells) 145 DO jj = ind1, ind2 146 DO ji = 1, jpi 147 ztabramp(ji,jj) = MAX( ztabramp(ji,jj), REAL( jj - ind2 ) * z1_spongearea * vmask(ji,ind2-1,1) ) 148 END DO 149 149 ENDDO 150 150 ENDIF … … 158 158 DO jj = 2, jpjm1 159 159 DO ji = 2, jpim1 ! vector opt. 160 fsaht_spu(ji,jj) = 0.5_wp * visc_tra * (ztabramp(ji,jj) + ztabramp(ji+1,jj )) 161 fsaht_spv(ji,jj) = 0.5_wp * visc_tra * (ztabramp(ji,jj) + ztabramp(ji ,jj+1)) 162 END DO 163 END DO 164 160 fsaht_spu(ji,jj) = 0.5_wp * visc_tra * ( ztabramp(ji,jj) + ztabramp(ji+1,jj ) ) 161 fsaht_spv(ji,jj) = 0.5_wp * visc_tra * ( ztabramp(ji,jj) + ztabramp(ji ,jj+1) ) 162 END DO 163 END DO 165 164 CALL lbc_lnk( fsaht_spu, 'U', 1. ) ! Lateral boundary conditions 166 165 CALL lbc_lnk( fsaht_spv, 'V', 1. ) 166 167 167 spongedoneT = .TRUE. 168 168 ENDIF … … 179 179 END DO 180 180 END DO 181 182 181 CALL lbc_lnk( fsahm_spt, 'T', 1. ) ! Lateral boundary conditions 183 182 CALL lbc_lnk( fsahm_spf, 'F', 1. ) 183 184 184 spongedoneU = .TRUE. 185 185 ENDIF 186 186 ! 187 IF (.NOT.ll_spdone) CALL wrk_dealloc( jpi, jpj, ztabramp )188 !189 187 #endif 190 188 ! … … 192 190 193 191 194 SUBROUTINE interptsn_sponge( tabres,i1,i2,j1,j2,k1,k2,n1,n2,before)195 !!--------------------------------------------- 196 !! *** ROUTINE interptsn_sponge ***197 !!--------------------------------------------- 198 INTEGER , INTENT(in) :: i1,i2,j1,j2,k1,k2,n1,n2199 REAL(wp), DIMENSION(i1:i2,j1:j2,k1:k2,n1:n2), INTENT(inout) :: tabres200 LOGICAL , INTENT(in) ::before192 SUBROUTINE interptsn_sponge( tabres, i1, i2, j1, j2, k1, k2, n1, n2, before ) 193 !!---------------------------------------------------------------------- 194 !! *** ROUTINE interptsn_sponge *** 195 !!---------------------------------------------------------------------- 196 INTEGER , INTENT(in ) :: i1, i2, j1, j2, k1, k2, n1, n2 197 REAL(wp), DIMENSION(i1:i2,j1:j2,k1:k2,n1:n2), INTENT(inout) :: tabres 198 LOGICAL , INTENT(in ) :: before 201 199 ! 202 200 INTEGER :: ji, jj, jk, jn ! dummy loop indices … … 205 203 REAL(wp), DIMENSION(i1:i2,j1:j2,k1:k2) :: ztu, ztv 206 204 REAL(wp), DIMENSION(i1:i2,j1:j2,k1:k2,n1:n2) ::tsbdiff 205 !!---------------------------------------------------------------------- 207 206 ! 208 207 IF( before ) THEN … … 241 240 zbtr = r1_e1e2t(ji,jj) / e3t_n(ji,jj,jk) 242 241 ! horizontal diffusive trends 243 ztsa = zbtr * ( ztu(ji,jj,jk) - ztu(ji-1,jj,jk) + ztv(ji,jj,jk) - ztv(ji 242 ztsa = zbtr * ( ztu(ji,jj,jk) - ztu(ji-1,jj,jk) + ztv(ji,jj,jk) - ztv(ji,jj-1,jk) ) 244 243 ! add it to the general tracer trends 245 244 tsa(ji,jj,jk,jn) = tsa(ji,jj,jk,jn) + ztsa … … 258 257 259 258 260 SUBROUTINE interpun_sponge(tabres,i1,i2,j1,j2,k1,k2, before) 261 !!--------------------------------------------- 262 !! *** ROUTINE interpun_sponge *** 263 !!--------------------------------------------- 264 INTEGER, INTENT(in) :: i1,i2,j1,j2,k1,k2 265 REAL(wp), DIMENSION(i1:i2,j1:j2,k1:k2), INTENT(inout) :: tabres 266 LOGICAL, INTENT(in) :: before 267 268 INTEGER :: ji,jj,jk 269 259 SUBROUTINE interpun_sponge( tabres, i1, i2, j1, j2, k1, k2, before ) 260 !!---------------------------------------------------------------------- 261 !! *** ROUTINE interpun_sponge *** 262 !!---------------------------------------------------------------------- 263 INTEGER , INTENT(in ) :: i1, i2, j1, j2, k1, k2 264 REAL(wp), DIMENSION(i1:i2,j1:j2,k1:k2), INTENT(inout) :: tabres 265 LOGICAL , INTENT(in ) :: before 266 !! 267 INTEGER :: ji, jj, jk 270 268 ! sponge parameters 269 INTEGER :: jmax 271 270 REAL(wp) :: ze2u, ze1v, zua, zva, zbtr 272 271 REAL(wp), DIMENSION(i1:i2,j1:j2,k1:k2) :: ubdiff 273 272 REAL(wp), DIMENSION(i1:i2,j1:j2,k1:k2) :: rotdiff, hdivdiff 274 INTEGER :: jmax 275 !!--------------------------------------------- 273 !!---------------------------------------------------------------------- 276 274 ! 277 275 IF( before ) THEN 278 276 tabres = un(i1:i2,j1:j2,:) 279 277 ELSE 280 ubdiff(i1:i2,j1:j2,:) = ( ub(i1:i2,j1:j2,:) - tabres(:,:,:))*umask(i1:i2,j1:j2,:)278 ubdiff(i1:i2,j1:j2,:) = ( ub(i1:i2,j1:j2,:) - tabres(:,:,:) )*umask(i1:i2,j1:j2,:) 281 279 ! 282 280 DO jk = 1, jpkm1 ! Horizontal slab … … 297 295 DO ji = i1,i2 ! vector opt. 298 296 zbtr = r1_e1e2f(ji,jj) * e3f_n(ji,jj,jk) * fsahm_spf(ji,jj) 299 rotdiff(ji,jj,jk) = (-e1u(ji,jj+1) * ubdiff(ji,jj+1,jk) & 300 +e1u(ji,jj ) * ubdiff(ji,jj ,jk) & 301 & ) * fmask(ji,jj,jk) * zbtr 297 rotdiff(ji,jj,jk) = ( -e1u(ji,jj+1) * ubdiff(ji,jj+1,jk) & 298 & +e1u(ji,jj ) * ubdiff(ji,jj ,jk) ) * fmask(ji,jj,jk) * zbtr 302 299 END DO 303 300 END DO … … 312 309 ze1v = hdivdiff(ji,jj,jk) 313 310 ! horizontal diffusive trends 314 zua = - ( ze2u - rotdiff (ji,jj-1,jk) ) / ( e2u(ji,jj) * e3u_n(ji,jj,jk) ) &315 + ( hdivdiff(ji+1,jj,jk) - ze1v ) /e1u(ji,jj)311 zua = - ( ze2u - rotdiff (ji,jj-1,jk) ) / ( e2u(ji,jj) * e3u_n(ji,jj,jk) ) & 312 + ( hdivdiff(ji+1,jj,jk) - ze1v ) * r1_e1u(ji,jj) 316 313 317 314 ! add it to the general momentum trends … … 327 324 328 325 jmax = j2-1 329 IF ((nbondj == 1).OR.(nbondj == 2)) jmax = MIN(jmax,nlcj- 3)326 IF ((nbondj == 1).OR.(nbondj == 2)) jmax = MIN(jmax,nlcj-nbghostcells-2) ! North 330 327 331 328 DO jj = j1+1, jmax … … 338 335 339 336 ! horizontal diffusive trends 340 zva = + ( ze2u - rotdiff (ji-1,jj,jk) ) / ( e1v(ji,jj) * e3v_n(ji,jj,jk) ) &341 + ( hdivdiff(ji,jj+1,jk) - ze1v ) /e2v(ji,jj)337 zva = + ( ze2u - rotdiff (ji-1,jj,jk) ) / ( e1v(ji,jj) * e3v_n(ji,jj,jk) ) & 338 + ( hdivdiff(ji,jj+1,jk) - ze1v ) * r1_e2v(ji,jj) 342 339 343 340 ! add it to the general momentum trends … … 356 353 357 354 358 SUBROUTINE interpvn_sponge(tabres,i1,i2,j1,j2,k1,k2, before,nb,ndir) 359 !!--------------------------------------------- 360 !! *** ROUTINE interpvn_sponge *** 361 !!--------------------------------------------- 362 INTEGER, INTENT(in) :: i1,i2,j1,j2,k1,k2 363 REAL(wp), DIMENSION(i1:i2,j1:j2,k1:k2), INTENT(inout) :: tabres 364 LOGICAL, INTENT(in) :: before 365 INTEGER, INTENT(in) :: nb , ndir 366 ! 367 INTEGER :: ji, jj, jk 368 REAL(wp) :: ze2u, ze1v, zua, zva, zbtr 369 REAL(wp), DIMENSION(i1:i2,j1:j2,k1:k2) :: vbdiff 370 REAL(wp), DIMENSION(i1:i2,j1:j2,k1:k2) :: rotdiff, hdivdiff 371 INTEGER :: imax 372 !!--------------------------------------------- 355 SUBROUTINE interpvn_sponge( tabres, i1, i2, j1, j2, k1, k2, before, nb, ndir ) 356 !!---------------------------------------------------------------------- 357 !! *** ROUTINE interpvn_sponge *** 358 !!---------------------------------------------------------------------- 359 INTEGER , INTENT(in ) :: i1, i2, j1, j2, k1, k2 360 REAL(wp), DIMENSION(i1:i2,j1:j2,k1:k2), INTENT(inout) :: tabres 361 LOGICAL , INTENT(in ) :: before 362 INTEGER , INTENT(in ) :: nb , ndir 363 ! 364 INTEGER :: ji, jj, jk 365 INTEGER :: imax 366 REAL(wp):: ze2u, ze1v, zua, zva, zbtr 367 REAL(wp), DIMENSION(i1:i2,j1:j2,k1:k2) :: vbdiff, rotdiff, hdivdiff 368 !!---------------------------------------------------------------------- 373 369 374 370 IF( before ) THEN … … 376 372 ELSE 377 373 ! 378 vbdiff(i1:i2,j1:j2,:) = ( vb(i1:i2,j1:j2,:) - tabres(:,:,:))*vmask(i1:i2,j1:j2,:)374 vbdiff(i1:i2,j1:j2,:) = ( vb(i1:i2,j1:j2,:) - tabres(:,:,:) ) * vmask(i1:i2,j1:j2,:) 379 375 ! 380 376 DO jk = 1, jpkm1 ! Horizontal slab … … 403 399 ! 404 400 405 imax = i2 -1406 IF ((nbondi == 1).OR.(nbondi == 2)) imax = MIN(imax,nlci- 3)401 imax = i2 - 1 402 IF ((nbondi == 1).OR.(nbondi == 2)) imax = MIN(imax,nlci-nbghostcells-2) ! East 407 403 408 404 DO jj = j1+1, j2 … … 437 433 438 434 #else 435 !!---------------------------------------------------------------------- 436 !! Empty module no AGRIF zoom 437 !!---------------------------------------------------------------------- 439 438 CONTAINS 440 439 SUBROUTINE agrif_opa_sponge_empty 441 !!---------------------------------------------442 !! *** ROUTINE agrif_OPA_sponge_empty ***443 !!---------------------------------------------444 440 WRITE(*,*) 'agrif_opa_sponge : You should not have seen this print! error?' 445 441 END SUBROUTINE agrif_opa_sponge_empty -
branches/2017/dev_CNRS_2017/NEMOGCM/NEMO/NST_SRC/agrif_opa_update.F90
r7646 r8882 3 3 4 4 MODULE agrif_opa_update 5 !!====================================================================== 6 !! *** MODULE agrif_opa_interp *** 7 !! AGRIF: update package for the ocean dynamics (OPA) 8 !!====================================================================== 9 !! History : 2.0 ! 2002-06 (L. Debreu) Original code 10 !! 3.2 ! 2009-04 (R. Benshila) 11 !! 3.6 ! 2014-09 (R. Benshila) 12 !!---------------------------------------------------------------------- 5 13 #if defined key_agrif 14 !!---------------------------------------------------------------------- 15 !! 'key_agrif' AGRIF zoom 16 !!---------------------------------------------------------------------- 6 17 USE par_oce 7 18 USE oce 8 19 USE dom_oce 20 USE zdf_oce ! vertical physics: ocean variables 9 21 USE agrif_oce 10 USE in_out_manager ! I/O manager 11 USE lib_mpp 12 USE wrk_nemo 13 USE zdf_oce ! vertical physics: ocean variables 22 ! 23 USE in_out_manager ! I/O manager 24 USE lib_mpp ! MPP library 14 25 15 26 IMPLICIT NONE 16 27 PRIVATE 17 28 18 PUBLIC Agrif_Update_Tra, Agrif_Update_Dyn,Update_Scales 19 # if defined key_zdftke 20 PUBLIC Agrif_Update_Tke 21 # endif 29 PUBLIC Agrif_Update_Tra, Agrif_Update_Dyn, Update_Scales 30 22 31 !!---------------------------------------------------------------------- 23 !! NEMO/NST 3.6 , NEMO Consortium (2010)32 !! NEMO/NST 4.0 , NEMO Consortium (2017) 24 33 !! $Id$ 25 34 !! Software governed by the CeCILL licence (NEMOGCM/NEMO_CeCILL.txt) … … 28 37 29 38 RECURSIVE SUBROUTINE Agrif_Update_Tra( ) 30 !!--------------------------------------------- 31 !! *** ROUTINE Agrif_Update_Tra ***32 !!--------------------------------------------- 39 !!---------------------------------------------------------------------- 40 !! *** ROUTINE Agrif_Update_Tra *** 41 !!---------------------------------------------------------------------- 33 42 ! 34 43 IF (Agrif_Root()) RETURN … … 38 47 39 48 Agrif_UseSpecialValueInUpdate = .TRUE. 40 Agrif_SpecialValueFineGrid = 0.49 Agrif_SpecialValueFineGrid = 0._wp 41 50 ! 42 51 IF (MOD(nbcline,nbclineupdate) == 0) THEN … … 68 77 69 78 RECURSIVE SUBROUTINE Agrif_Update_Dyn( ) 70 !!--------------------------------------------- 71 !! *** ROUTINE Agrif_Update_Dyn ***72 !!--------------------------------------------- 79 !!---------------------------------------------------------------------- 80 !! *** ROUTINE Agrif_Update_Dyn *** 81 !!---------------------------------------------------------------------- 73 82 ! 74 83 IF (Agrif_Root()) RETURN … … 106 115 # endif 107 116 108 IF ( ln_dynspg_ts .AND.ln_bt_fw ) THEN117 IF ( ln_dynspg_ts .AND. ln_bt_fw ) THEN 109 118 ! Update time integrated transports 110 119 IF (mod(nbcline,nbclineupdate) == 0) THEN … … 149 158 END SUBROUTINE Agrif_Update_Dyn 150 159 151 # if defined key_zdftke152 153 SUBROUTINE Agrif_Update_Tke( kt )154 !!---------------------------------------------155 !! *** ROUTINE Agrif_Update_Tke ***156 !!---------------------------------------------157 !!158 INTEGER, INTENT(in) :: kt159 !160 IF( ( Agrif_NbStepint() .NE. 0 ) .AND. (kt /= 0) ) RETURN161 # if defined TWO_WAY162 163 Agrif_UseSpecialValueInUpdate = .TRUE.164 Agrif_SpecialValueFineGrid = 0.165 166 CALL Agrif_Update_Variable( en_id, locupdate=(/0,0/), procname=updateEN )167 CALL Agrif_Update_Variable(avt_id, locupdate=(/0,0/), procname=updateAVT )168 CALL Agrif_Update_Variable(avm_id, locupdate=(/0,0/), procname=updateAVM )169 170 Agrif_UseSpecialValueInUpdate = .FALSE.171 172 # endif173 174 END SUBROUTINE Agrif_Update_Tke175 176 # endif /* key_zdftke */177 160 178 161 SUBROUTINE updateTS( tabres, i1, i2, j1, j2, k1, k2, n1, n2, before ) 179 !!--------------------------------------------- 162 !!---------------------------------------------------------------------- 180 163 !! *** ROUTINE updateT *** 181 !!--------------------------------------------- 182 INTEGER , INTENT(in) :: i1,i2,j1,j2,k1,k2,n1,n2183 REAL(wp),DIMENSION(i1:i2,j1:j2,k1:k2,n1:n2), INTENT(inout) :: tabres184 LOGICAL , INTENT(in) ::before185 ! !186 INTEGER :: ji, jj,jk,jn187 !!--------------------------------------------- 188 ! 189 IF (before) THEN190 DO jn = n1, n2191 DO jk =k1,k2192 DO jj =j1,j2193 DO ji =i1,i2164 !!---------------------------------------------------------------------- 165 INTEGER , INTENT(in ) :: i1, i2, j1, j2, k1, k2, n1, n2 166 REAL(wp),DIMENSION(i1:i2,j1:j2,k1:k2,n1:n2), INTENT(inout) :: tabres 167 LOGICAL , INTENT(in ) :: before 168 ! 169 INTEGER :: ji, jj, jk, jn 170 !!---------------------------------------------------------------------- 171 ! 172 IF( before ) THEN 173 DO jn = n1, n2 174 DO jk = k1, k2 175 DO jj = j1, j2 176 DO ji = i1, i2 194 177 tabres(ji,jj,jk,jn) = tsn(ji,jj,jk,jn) 195 178 END DO … … 201 184 ! Add asselin part 202 185 DO jn = n1,n2 203 DO jk =k1,k2204 DO jj =j1,j2205 DO ji =i1,i2206 IF( tabres(ji,jj,jk,jn) .NE. 0.) THEN186 DO jk = k1, k2 187 DO jj = j1, j2 188 DO ji = i1, i2 189 IF( tabres(ji,jj,jk,jn) /= 0._wp ) THEN 207 190 tsb(ji,jj,jk,jn) = tsb(ji,jj,jk,jn) & 208 & + atfp * ( tabres(ji,jj,jk,jn) & 209 & - tsn(ji,jj,jk,jn) ) * tmask(ji,jj,jk) 191 & + atfp * ( tabres(ji,jj,jk,jn) - tsn(ji,jj,jk,jn) ) * tmask(ji,jj,jk) 210 192 ENDIF 211 END DO212 END DO213 END DO214 END DO193 END DO 194 END DO 195 END DO 196 END DO 215 197 ENDIF 216 198 DO jn = n1,n2 … … 218 200 DO jj=j1,j2 219 201 DO ji=i1,i2 220 IF( tabres(ji,jj,jk,jn) .NE. 0.) THEN202 IF( tabres(ji,jj,jk,jn) /= 0._wp ) THEN 221 203 tsn(ji,jj,jk,jn) = tabres(ji,jj,jk,jn) * tmask(ji,jj,jk) 222 204 END IF … … 238 220 LOGICAL , INTENT(in ) :: before 239 221 ! 240 INTEGER 241 REAL(wp) 222 INTEGER :: ji, jj, jk 223 REAL(wp):: zrhoy 242 224 !!--------------------------------------------- 243 225 ! … … 268 250 269 251 SUBROUTINE updatev( tabres, i1, i2, j1, j2, k1, k2, before ) 270 !!--------------------------------------------- 271 !! *** ROUTINE updatev *** 272 !!--------------------------------------------- 273 INTEGER :: i1,i2,j1,j2,k1,k2 274 INTEGER :: ji,jj,jk 275 REAL(wp), DIMENSION(i1:i2,j1:j2,k1:k2) :: tabres 276 LOGICAL :: before 252 !!---------------------------------------------------------------------- 253 !! *** ROUTINE updatev *** 254 !!---------------------------------------------------------------------- 255 INTEGER , INTENT(in ) :: i1, i2, j1, j2, k1, k2 256 REAL(wp), DIMENSION(i1:i2,j1:j2,k1:k2), INTENT(inout) :: tabres 257 LOGICAL , INTENT(in ) :: before 277 258 !! 278 REAL(wp) :: zrhox 279 !!--------------------------------------------- 280 ! 281 IF (before) THEN 259 INTEGER :: ji, jj, jk 260 REAL(wp) :: zrhox 261 !!---------------------------------------------------------------------- 262 ! 263 IF( before ) THEN 282 264 zrhox = Agrif_Rhox() 283 DO jk =k1,k2284 DO jj =j1,j2285 DO ji =i1,i2265 DO jk = k1, k2 266 DO jj = j1, j2 267 DO ji = i1, i2 286 268 tabres(ji,jj,jk) = zrhox * e1v(ji,jj) * e3v_n(ji,jj,jk) * vn(ji,jj,jk) 287 269 END DO … … 289 271 END DO 290 272 ELSE 291 DO jk =k1,k2292 DO jj =j1,j2293 DO ji =i1,i2273 DO jk = k1, k2 274 DO jj = j1, j2 275 DO ji = i1, i2 294 276 tabres(ji,jj,jk) = tabres(ji,jj,jk) * r1_e1v(ji,jj) / e3v_n(ji,jj,jk) 295 277 ! 296 IF (.NOT.(lk_agrif_fstep.AND.(neuler==0))) THEN ! Add asselin part278 IF( .NOT.(lk_agrif_fstep.AND.(neuler==0)) ) THEN ! Add asselin part 297 279 vb(ji,jj,jk) = vb(ji,jj,jk) & 298 &+ atfp * ( tabres(ji,jj,jk) - vn(ji,jj,jk) ) * vmask(ji,jj,jk)280 & + atfp * ( tabres(ji,jj,jk) - vn(ji,jj,jk) ) * vmask(ji,jj,jk) 299 281 ENDIF 300 282 ! … … 309 291 310 292 SUBROUTINE updateu2d( tabres, i1, i2, j1, j2, before ) 293 !!---------------------------------------------------------------------- 294 !! *** ROUTINE updateu2d *** 295 !!---------------------------------------------------------------------- 296 INTEGER , INTENT(in ) :: i1, i2, j1, j2 297 REAL(wp), DIMENSION(i1:i2,j1:j2), INTENT(inout) :: tabres 298 LOGICAL , INTENT(in ) :: before 299 !! 300 INTEGER :: ji, jj, jk 301 REAL(wp):: zrhoy, zcorr 311 302 !!--------------------------------------------- 312 !! *** ROUTINE updateu2d *** 313 !!--------------------------------------------- 314 INTEGER, INTENT(in) :: i1, i2, j1, j2 315 REAL(wp), DIMENSION(i1:i2,j1:j2), INTENT(inout) :: tabres 316 LOGICAL, INTENT(in) :: before 317 !! 318 INTEGER :: ji, jj, jk 319 REAL(wp) :: zrhoy 320 REAL(wp) :: zcorr 321 !!--------------------------------------------- 322 ! 323 IF (before) THEN 303 ! 304 IF( before ) THEN 324 305 zrhoy = Agrif_Rhoy() 325 306 DO jj=j1,j2 … … 374 355 375 356 SUBROUTINE updatev2d( tabres, i1, i2, j1, j2, before ) 376 !!--------------------------------------------- 377 !! *** ROUTINE updatev2d ***378 !!--------------------------------------------- 379 INTEGER , INTENT(in) ::i1, i2, j1, j2380 REAL(wp), DIMENSION(i1:i2,j1:j2), INTENT(inout) :: tabres381 LOGICAL , INTENT(in) ::before382 ! !357 !!---------------------------------------------------------------------- 358 !! *** ROUTINE updatev2d *** 359 !!---------------------------------------------------------------------- 360 INTEGER , INTENT(in ) :: i1, i2, j1, j2 361 REAL(wp), DIMENSION(i1:i2,j1:j2), INTENT(inout) :: tabres 362 LOGICAL , INTENT(in ) :: before 363 ! 383 364 INTEGER :: ji, jj, jk 384 REAL(wp) :: zrhox 385 REAL(wp) :: zcorr 386 !!--------------------------------------------- 387 ! 388 IF (before) THEN 365 REAL(wp) :: zrhox, zcorr 366 !!---------------------------------------------------------------------- 367 ! 368 IF( before ) THEN 389 369 zrhox = Agrif_Rhox() 390 370 DO jj=j1,j2 … … 439 419 440 420 SUBROUTINE updateSSH( tabres, i1, i2, j1, j2, before ) 441 !!--------------------------------------------- 442 !! *** ROUTINE updateSSH ***443 !!--------------------------------------------- 444 INTEGER , INTENT(in) ::i1, i2, j1, j2445 REAL(wp), DIMENSION(i1:i2,j1:j2), INTENT(inout) :: tabres446 LOGICAL , INTENT(in) ::before421 !!---------------------------------------------------------------------- 422 !! *** ROUTINE updateSSH *** 423 !!---------------------------------------------------------------------- 424 INTEGER , INTENT(in ) :: i1, i2, j1, j2 425 REAL(wp), DIMENSION(i1:i2,j1:j2), INTENT(inout) :: tabres 426 LOGICAL , INTENT(in ) :: before 447 427 !! 448 428 INTEGER :: ji, jj 449 !!--------------------------------------------- 450 ! 451 IF (before) THEN429 !!---------------------------------------------------------------------- 430 ! 431 IF( before ) THEN 452 432 DO jj=j1,j2 453 433 DO ji=i1,i2 … … 478 458 479 459 SUBROUTINE updateub2b( tabres, i1, i2, j1, j2, before ) 480 !!--------------------------------------------- 481 !! *** ROUTINE updateub2b ***482 !!--------------------------------------------- 483 INTEGER , INTENT(in) ::i1, i2, j1, j2484 REAL(wp), DIMENSION(i1:i2,j1:j2), INTENT(inout) :: tabres485 LOGICAL , INTENT(in) ::before460 !!---------------------------------------------------------------------- 461 !! *** ROUTINE updateub2b *** 462 !!---------------------------------------------------------------------- 463 INTEGER , INTENT(in) :: i1, i2, j1, j2 464 REAL(wp), DIMENSION(i1:i2,j1:j2), INTENT(inout) :: tabres 465 LOGICAL , INTENT(in) :: before 486 466 !! 487 INTEGER :: ji, jj488 REAL(wp) ::zrhoy489 !!--------------------------------------------- 467 INTEGER :: ji, jj 468 REAL(wp):: zrhoy 469 !!---------------------------------------------------------------------- 490 470 ! 491 471 IF (before) THEN … … 509 489 510 490 SUBROUTINE updatevb2b( tabres, i1, i2, j1, j2, before ) 511 !!--------------------------------------------- 512 !! *** ROUTINE updatevb2b ***513 !!--------------------------------------------- 514 INTEGER , INTENT(in) ::i1, i2, j1, j2515 REAL(wp), DIMENSION(i1:i2,j1:j2), INTENT(inout) :: tabres516 LOGICAL , INTENT(in) ::before491 !!---------------------------------------------------------------------- 492 !! *** ROUTINE updatevb2b *** 493 !!---------------------------------------------------------------------- 494 INTEGER , INTENT(in ) :: i1, i2, j1, j2 495 REAL(wp), DIMENSION(i1:i2,j1:j2), INTENT(inout) :: tabres 496 LOGICAL , INTENT(in ) :: before 517 497 !! 518 INTEGER :: ji, jj519 REAL(wp) ::zrhox520 !!--------------------------------------------- 521 ! 522 IF (before) THEN498 INTEGER :: ji, jj 499 REAL(wp):: zrhox 500 !!---------------------------------------------------------------------- 501 ! 502 IF( before ) THEN 523 503 zrhox = Agrif_Rhox() 524 504 DO jj=j1,j2 … … 540 520 541 521 SUBROUTINE update_scales( tabres, i1, i2, j1, j2, k1, k2, n1,n2, before ) 542 ! currently not used 543 !!--------------------------------------------- 544 !! *** ROUTINE updateT *** 545 !!--------------------------------------------- 546 INTEGER, INTENT(in) :: i1,i2,j1,j2,k1,k2,n1,n2 547 REAL(wp),DIMENSION(i1:i2,j1:j2,k1:k2,n1:n2), INTENT(inout) :: tabres 548 LOGICAL, iNTENT(in) :: before 549 ! 522 ! 523 ! ====>>>>>>>>>> currently not used 524 ! 525 !!---------------------------------------------------------------------- 526 !! *** ROUTINE updateT *** 527 !!---------------------------------------------------------------------- 528 INTEGER , INTENT(in ) :: i1, i2, j1, j2, k1, k2, n1, n2 529 REAL(wp),DIMENSION(i1:i2,j1:j2,k1:k2,n1:n2), INTENT(inout) :: tabres 530 LOGICAL , INTENT(in ) :: before 531 !! 550 532 INTEGER :: ji,jj,jk 551 533 REAL(wp) :: ztemp 552 !!--------------------------------------------- 534 !!---------------------------------------------------------------------- 553 535 554 536 IF (before) THEN … … 587 569 END SUBROUTINE update_scales 588 570 589 # if defined key_zdftke590 571 591 572 SUBROUTINE updateEN( ptab, i1, i2, j1, j2, k1, k2, before ) 592 !!--------------------------------------------- 593 !! *** ROUTINE updateen ***594 !!--------------------------------------------- 595 INTEGER , INTENT(in) ::i1, i2, j1, j2, k1, k2596 REAL(wp), DIMENSION(i1:i2,j1:j2,k1:k2), INTENT(inout) :: ptab597 LOGICAL , INTENT(in) ::before598 !!--------------------------------------------- 599 ! 600 IF (before) THEN573 !!---------------------------------------------------------------------- 574 !! *** ROUTINE updateen *** 575 !!---------------------------------------------------------------------- 576 INTEGER , INTENT(in ) :: i1, i2, j1, j2, k1, k2 577 REAL(wp), DIMENSION(i1:i2,j1:j2,k1:k2), INTENT(inout) :: ptab 578 LOGICAL , INTENT(in ) :: before 579 !!---------------------------------------------------------------------- 580 ! 581 IF( before ) THEN 601 582 ptab (i1:i2,j1:j2,k1:k2) = en(i1:i2,j1:j2,k1:k2) 602 583 ELSE … … 608 589 609 590 SUBROUTINE updateAVT( ptab, i1, i2, j1, j2, k1, k2, before ) 610 !!--------------------------------------------- 611 !! *** ROUTINE updateavt *** 612 !!--------------------------------------------- 613 INTEGER, INTENT(in) :: i1, i2, j1, j2, k1, k2 614 REAL(wp), DIMENSION(i1:i2,j1:j2,k1:k2), INTENT(inout) :: ptab 615 LOGICAL, INTENT(in) :: before 616 !!--------------------------------------------- 617 ! 618 IF (before) THEN 619 ptab (i1:i2,j1:j2,k1:k2) = avt_k(i1:i2,j1:j2,k1:k2) 620 ELSE 621 avt_k(i1:i2,j1:j2,k1:k2) = ptab (i1:i2,j1:j2,k1:k2) 591 !!---------------------------------------------------------------------- 592 !! *** ROUTINE updateavt *** 593 !!---------------------------------------------------------------------- 594 INTEGER , INTENT(in ) :: i1, i2, j1, j2, k1, k2 595 REAL(wp), DIMENSION(i1:i2,j1:j2,k1:k2), INTENT(inout) :: ptab 596 LOGICAL , INTENT(in ) :: before 597 !!---------------------------------------------------------------------- 598 ! 599 IF( before ) THEN ; ptab (i1:i2,j1:j2,k1:k2) = avt_k(i1:i2,j1:j2,k1:k2) 600 ELSE ; avt_k(i1:i2,j1:j2,k1:k2) = ptab (i1:i2,j1:j2,k1:k2) 622 601 ENDIF 623 602 ! … … 628 607 !!--------------------------------------------- 629 608 !! *** ROUTINE updateavm *** 630 !!--------------------------------------------- 631 INTEGER, INTENT(in) :: i1, i2, j1, j2, k1, k2 632 REAL(wp), DIMENSION(i1:i2,j1:j2,k1:k2), INTENT(inout) :: ptab 633 LOGICAL, INTENT(in) :: before 634 !!--------------------------------------------- 635 ! 636 IF (before) THEN 637 ptab (i1:i2,j1:j2,k1:k2) = avm_k(i1:i2,j1:j2,k1:k2) 638 ELSE 639 avm_k(i1:i2,j1:j2,k1:k2) = ptab (i1:i2,j1:j2,k1:k2) 609 !!---------------------------------------------------------------------- 610 INTEGER , INTENT(in ) :: i1, i2, j1, j2, k1, k2 611 REAL(wp), DIMENSION(i1:i2,j1:j2,k1:k2), INTENT(inout) :: ptab 612 LOGICAL , INTENT(in ) :: before 613 !!---------------------------------------------------------------------- 614 ! 615 IF( before ) THEN ; ptab (i1:i2,j1:j2,k1:k2) = avm_k(i1:i2,j1:j2,k1:k2) 616 ELSE ; avm_k(i1:i2,j1:j2,k1:k2) = ptab (i1:i2,j1:j2,k1:k2) 640 617 ENDIF 641 618 ! 642 619 END SUBROUTINE updateAVM 643 620 644 # endif /* key_zdftke */645 646 621 #else 622 !!---------------------------------------------------------------------- 623 !! Empty module no AGRIF zoom 624 !!---------------------------------------------------------------------- 647 625 CONTAINS 648 626 SUBROUTINE agrif_opa_update_empty 649 !!---------------------------------------------650 !! *** ROUTINE agrif_opa_update_empty ***651 !!---------------------------------------------652 627 WRITE(*,*) 'agrif_opa_update : You should not have seen this print! error?' 653 628 END SUBROUTINE agrif_opa_update_empty 654 629 #endif 630 631 !!====================================================================== 655 632 END MODULE agrif_opa_update 656 633 -
branches/2017/dev_CNRS_2017/NEMOGCM/NEMO/NST_SRC/agrif_top_interp.F90
r6140 r8882 1 1 MODULE agrif_top_interp 2 !!====================================================================== 3 !! *** MODULE agrif_top_interp *** 4 !! AGRIF: interpolation package for TOP 5 !!====================================================================== 6 !! History : 2.0 ! ??? 7 !!---------------------------------------------------------------------- 2 8 #if defined key_agrif && defined key_top 9 !!---------------------------------------------------------------------- 10 !! 'key_agrif' AGRIF zoom 11 !! 'key_top' on-line tracers 12 !!---------------------------------------------------------------------- 3 13 USE par_oce 4 14 USE oce … … 8 18 USE par_trc 9 19 USE trc 10 USE lib_mpp11 USE wrk_nemo20 ! 21 USE lib_mpp ! MPP library 12 22 13 23 IMPLICIT NONE … … 16 26 PUBLIC Agrif_trc, interptrn 17 27 18 # include "vectopt_loop_substitute.h90"19 28 !!---------------------------------------------------------------------- 20 !! NEMO/NST 3.6 , NEMO Consortium (2010)29 !! NEMO/NST 4.0 , NEMO Consortium (2017) 21 30 !! $Id$ 22 31 !! Software governed by the CeCILL licence (NEMOGCM/NEMO_CeCILL.txt) … … 26 35 SUBROUTINE Agrif_trc 27 36 !!---------------------------------------------------------------------- 28 !! *** ROUTINE Agrif_trc ***37 !! *** ROUTINE Agrif_trc *** 29 38 !!---------------------------------------------------------------------- 30 39 ! 31 40 IF( Agrif_Root() ) RETURN 32 33 Agrif_SpecialValue = 0. e041 ! 42 Agrif_SpecialValue = 0._wp 34 43 Agrif_UseSpecialValue = .TRUE. 35 44 ! 36 45 CALL Agrif_Bc_variable( trn_id, procname=interptrn ) 37 46 Agrif_UseSpecialValue = .FALSE. … … 40 49 41 50 42 SUBROUTINE interptrn(ptab,i1,i2,j1,j2,k1,k2,n1,n2,before,nb,ndir) 43 !!--------------------------------------------- 44 !! *** ROUTINE interptrn *** 45 !!--------------------------------------------- 46 REAL(wp), DIMENSION(i1:i2,j1:j2,k1:k2,n1:n2), INTENT(inout) :: ptab 47 INTEGER, INTENT(in) :: i1,i2,j1,j2,k1,k2,n1,n2 48 LOGICAL, INTENT(in) :: before 49 INTEGER, INTENT(in) :: nb , ndir 51 SUBROUTINE interptrn( ptab, i1, i2, j1, j2, k1, k2, n1, n2, before, nb, ndir ) 52 !!---------------------------------------------------------------------- 53 !! *** ROUTINE interptrn *** 54 !!---------------------------------------------------------------------- 55 REAL(wp), DIMENSION(i1:i2,j1:j2,k1:k2,n1:n2), INTENT(inout) :: ptab 56 INTEGER , INTENT(in ) :: i1, i2, j1, j2, k1, k2, n1, n2 57 LOGICAL , INTENT(in ) :: before 58 INTEGER , INTENT(in ) :: nb , ndir 59 !! 60 INTEGER :: ji, jj, jk, jn ! dummy loop indices 61 INTEGER :: imin, imax, jmin, jmax 62 LOGICAL :: ll_west, ll_east, ll_north, ll_south 63 REAL(wp) :: zrhox, z1, z2, z3, z4, z5, z6, z7 64 !!---------------------------------------------------------------------- 50 65 ! 51 INTEGER :: ji, jj, jk, jn ! dummy loop indices 52 INTEGER :: imin, imax, jmin, jmax 53 REAL(wp) :: zrhox , zalpha1, zalpha2, zalpha3 54 REAL(wp) :: zalpha4, zalpha5, zalpha6, zalpha7 55 LOGICAL :: western_side, eastern_side,northern_side,southern_side 56 57 IF (before) THEN 66 IF( before ) THEN 58 67 ptab(i1:i2,j1:j2,k1:k2,n1:n2) = trn(i1:i2,j1:j2,k1:k2,n1:n2) 59 68 ELSE 60 69 ! 61 western_side = (nb == 1).AND.(ndir == 1) 62 eastern_side = (nb == 1).AND.(ndir == 2) 63 southern_side = (nb == 2).AND.(ndir == 1) 64 northern_side = (nb == 2).AND.(ndir == 2) 65 ! 66 zrhox = Agrif_Rhox() 67 ! 68 zalpha1 = ( zrhox - 1. ) * 0.5 69 zalpha2 = 1. - zalpha1 70 ! 71 zalpha3 = ( zrhox - 1. ) / ( zrhox + 1. ) 72 zalpha4 = 1. - zalpha3 73 ! 74 zalpha6 = 2. * ( zrhox - 1. ) / ( zrhox + 1. ) 75 zalpha7 = - ( zrhox - 1. ) / ( zrhox + 3. ) 76 zalpha5 = 1. - zalpha6 - zalpha7 77 ! 78 imin = i1 79 imax = i2 80 jmin = j1 81 jmax = j2 82 ! 83 ! Remove CORNERS 84 IF((nbondj == -1).OR.(nbondj == 2)) jmin = 3 85 IF((nbondj == +1).OR.(nbondj == 2)) jmax = nlcj-2 86 IF((nbondi == -1).OR.(nbondi == 2)) imin = 3 87 IF((nbondi == +1).OR.(nbondi == 2)) imax = nlci-2 88 ! 89 IF( eastern_side) THEN 90 DO jn = 1, jptra 91 tra(nlci,j1:j2,k1:k2,jn) = zalpha1 * ptab(nlci,j1:j2,k1:k2,jn) + zalpha2 * ptab(nlci-1,j1:j2,k1:k2,jn) 92 DO jk = 1, jpkm1 93 DO jj = jmin,jmax 94 IF( umask(nlci-2,jj,jk) == 0.e0 ) THEN 95 tra(nlci-1,jj,jk,jn) = tra(nlci,jj,jk,jn) * tmask(nlci-1,jj,jk) 96 ELSE 97 tra(nlci-1,jj,jk,jn)=(zalpha4*tra(nlci,jj,jk,jn)+zalpha3*tra(nlci-2,jj,jk,jn))*tmask(nlci-1,jj,jk) 98 IF( un(nlci-2,jj,jk) > 0.e0 ) THEN 99 tra(nlci-1,jj,jk,jn)=( zalpha6*tra(nlci-2,jj,jk,jn)+zalpha5*tra(nlci,jj,jk,jn) & 100 + zalpha7*tra(nlci-3,jj,jk,jn) ) * tmask(nlci-1,jj,jk) 70 IF( nbghostcells > 1 ) THEN ! no smoothing 71 tra(i1:i2,j1:j2,k1:k2,n1:n2) = ptab(i1:i2,j1:j2,k1:k2,n1:n2) 72 ELSE ! smoothing 73 ! 74 ll_west = (nb == 1).AND.(ndir == 1) ; ll_east = (nb == 1).AND.(ndir == 2) 75 ll_south = (nb == 2).AND.(ndir == 1) ; ll_north = (nb == 2).AND.(ndir == 2) 76 ! 77 zrhox = Agrif_Rhox() 78 z1 = ( zrhox - 1. ) * 0.5 79 z3 = ( zrhox - 1. ) / ( zrhox + 1. ) 80 z6 = 2. * ( zrhox - 1. ) / ( zrhox + 1. ) 81 z7 = - ( zrhox - 1. ) / ( zrhox + 3. ) 82 ! 83 z2 = 1. - z1 84 z4 = 1. - z3 85 z5 = 1. - z6 - z7 86 ! 87 imin = i1 ; imax = i2 88 jmin = j1 ; jmax = j2 89 ! 90 ! Remove CORNERS 91 IF((nbondj == -1).OR.(nbondj == 2)) jmin = 3 92 IF((nbondj == +1).OR.(nbondj == 2)) jmax = nlcj-2 93 IF((nbondi == -1).OR.(nbondi == 2)) imin = 3 94 IF((nbondi == +1).OR.(nbondi == 2)) imax = nlci-2 95 ! 96 IF( ll_east ) THEN !== eastern side ==! 97 DO jn = 1, jptra 98 tra(nlci,j1:j2,k1:k2,jn) = z1 * ptab(nlci,j1:j2,k1:k2,jn) + z2 * ptab(nlci-1,j1:j2,k1:k2,jn) 99 DO jk = 1, jpkm1 100 DO jj = jmin,jmax 101 IF( umask(nlci-2,jj,jk) == 0._wp ) THEN 102 tra(nlci-1,jj,jk,jn) = tra(nlci,jj,jk,jn) * tmask(nlci-1,jj,jk) 103 ELSE 104 tra(nlci-1,jj,jk,jn) = ( z4*tra(nlci,jj,jk,jn)+z3*tra(nlci-2,jj,jk,jn) ) * tmask(nlci-1,jj,jk) 105 IF( un(nlci-2,jj,jk) > 0._wp ) THEN 106 tra(nlci-1,jj,jk,jn) = ( z6*tra(nlci-2,jj,jk,jn)+z5*tra(nlci,jj,jk,jn) & 107 & +z7*tra(nlci-3,jj,jk,jn) ) * tmask(nlci-1,jj,jk) 108 ENDIF 101 109 ENDIF 102 ENDIF 110 END DO 111 END DO 112 ENDDO 113 ENDIF 114 ! 115 IF( ll_north ) THEN !== northern side ==! 116 DO jn = 1, jptra 117 tra(i1:i2,nlcj,k1:k2,jn) = z1 * ptab(i1:i2,nlcj,k1:k2,jn) + z2 * ptab(i1:i2,nlcj-1,k1:k2,jn) 118 DO jk = 1, jpkm1 119 DO ji = imin, imax 120 IF( vmask(ji,nlcj-2,jk) == 0._wp ) THEN 121 tra(ji,nlcj-1,jk,jn) = tra(ji,nlcj,jk,jn) * tmask(ji,nlcj-1,jk) 122 ELSE 123 tra(ji,nlcj-1,jk,jn) = ( z4*tra(ji,nlcj,jk,jn)+z3*tra(ji,nlcj-2,jk,jn) ) * tmask(ji,nlcj-1,jk) 124 IF (vn(ji,nlcj-2,jk) > 0._wp ) THEN 125 tra(ji,nlcj-1,jk,jn) = ( z6*tra(ji,nlcj-2,jk,jn)+z5*tra(ji,nlcj,jk,jn) & 126 & +z7*tra(ji,nlcj-3,jk,jn) ) * tmask(ji,nlcj-1,jk) 127 ENDIF 128 ENDIF 129 END DO 103 130 END DO 104 131 END DO 105 ENDDO 106 ENDIF 107 ! 108 IF( northern_side ) THEN 109 DO jn = 1, jptra 110 tra(i1:i2,nlcj,k1:k2,jn) = zalpha1 * ptab(i1:i2,nlcj,k1:k2,jn) + zalpha2 * ptab(i1:i2,nlcj-1,k1:k2,jn) 111 DO jk = 1, jpkm1 112 DO ji = imin,imax 113 IF( vmask(ji,nlcj-2,jk) == 0.e0 ) THEN 114 tra(ji,nlcj-1,jk,jn) = tra(ji,nlcj,jk,jn) * tmask(ji,nlcj-1,jk) 115 ELSE 116 tra(ji,nlcj-1,jk,jn)=(zalpha4*tra(ji,nlcj,jk,jn)+zalpha3*tra(ji,nlcj-2,jk,jn))*tmask(ji,nlcj-1,jk) 117 IF (vn(ji,nlcj-2,jk) > 0.e0 ) THEN 118 tra(ji,nlcj-1,jk,jn)=( zalpha6*tra(ji,nlcj-2,jk,jn)+zalpha5*tra(ji,nlcj,jk,jn) & 119 + zalpha7*tra(ji,nlcj-3,jk,jn) ) * tmask(ji,nlcj-1,jk) 132 ENDIF 133 ! 134 IF( ll_west ) THEN !== western side ==! 135 DO jn = 1, jptra 136 tra(1,j1:j2,k1:k2,jn) = z1 * ptab(1,j1:j2,k1:k2,jn) + z2 * ptab(2,j1:j2,k1:k2,jn) 137 DO jk = 1, jpkm1 138 DO jj = jmin,jmax 139 IF( umask(2,jj,jk) == 0._wp ) THEN 140 tra(2,jj,jk,jn) = tra(1,jj,jk,jn) * tmask(2,jj,jk) 141 ELSE 142 tra(2,jj,jk,jn) = ( z4*tra(1,jj,jk,jn)+z3*tra(3,jj,jk,jn) ) * tmask(2,jj,jk) 143 IF( un(2,jj,jk) < 0._wp ) THEN 144 tra(2,jj,jk,jn) = ( z6*tra(3,jj,jk,jn)+z5*tra(1,jj,jk,jn)+z7*tra(4,jj,jk,jn) ) * tmask(2,jj,jk) 145 ENDIF 120 146 ENDIF 121 END IF147 END DO 122 148 END DO 123 149 END DO 124 END DO125 ENDIF126 !127 IF( western_side) THEN128 DO jn = 1, jptra129 tra(1,j1:j2,k1:k2,jn) = zalpha1 * ptab(1,j1:j2,k1:k2,jn) + zalpha2 * ptab(2,j1:j2,k1:k2,jn)130 DO jk = 1, jpkm1131 DO jj = jmin,jmax132 IF( umask(2,jj,jk) == 0.e0 ) THEN133 tra(2,jj,jk,jn) = tra(1,jj,jk,jn) * tmask(2,jj,jk)134 ELSE135 tra(2,jj,jk,jn)=(zalpha4*tra(1,jj,jk,jn)+zalpha3*tra(3,jj,jk,jn))*tmask(2,jj,jk)136 IF( un(2,jj,jk) < 0.e0 ) THEN137 tra(2,jj,jk,jn)=(zalpha6*tra(3,jj,jk,jn)+zalpha5*tra(1,jj,jk,jn)+zalpha7*tra(4,jj,jk,jn))*tmask(2,jj,jk)150 ENDIF 151 ! 152 IF( ll_south ) THEN !== southern side ==! 153 DO jn = 1, jptra 154 tra(i1:i2,1,k1:k2,jn) = z1 * ptab(i1:i2,1,k1:k2,jn) + z2 * ptab(i1:i2,2,k1:k2,jn) 155 DO jk = 1, jpk 156 DO ji = imin, imax 157 IF( vmask(ji,2,jk) == 0._wp ) THEN 158 tra(ji,2,jk,jn) = tra(ji,1,jk,jn) * tmask(ji,2,jk) 159 ELSE 160 tra(ji,2,jk,jn) = ( z4*tra(ji,1,jk,jn)+z3*tra(ji,3,jk,jn) ) * tmask(ji,2,jk) 161 IF( vn(ji,2,jk) < 0._wp ) THEN 162 tra(ji,2,jk,jn) = ( z6*tra(ji,3,jk,jn)+z5*tra(ji,1,jk,jn)+z7*tra(ji,4,jk,jn) ) * tmask(ji,2,jk) 163 ENDIF 138 164 ENDIF 139 END IF165 END DO 140 166 END DO 141 167 END DO 142 END DO 168 ENDIF 169 ! 170 ! Treatment of corners 171 IF( ll_east .AND.((nbondj == -1).OR.(nbondj == 2)) ) tra(nlci-1, 2 ,:,:) = ptab(nlci-1, 2 ,:,:) ! East south 172 IF( ll_east .AND.((nbondj == 1).OR.(nbondj == 2)) ) tra(nlci-1,nlcj-1,:,:) = ptab(nlci-1,nlcj-1,:,:) ! East north 173 IF( ll_west .AND.((nbondj == -1).OR.(nbondj == 2)) ) tra( 2 , 2 ,:,:) = ptab( 2 , 2 ,:,:) ! West south 174 IF( ll_west .AND.((nbondj == 1).OR.(nbondj == 2)) ) tra( 2 ,nlcj-1,:,:) = ptab( 2 ,nlcj-1,:,:) ! West north 175 ! 143 176 ENDIF 144 !145 IF( southern_side ) THEN146 DO jn = 1, jptra147 tra(i1:i2,1,k1:k2,jn) = zalpha1 * ptab(i1:i2,1,k1:k2,jn) + zalpha2 * ptab(i1:i2,2,k1:k2,jn)148 DO jk=1,jpk149 DO ji=imin,imax150 IF( vmask(ji,2,jk) == 0.e0 ) THEN151 tra(ji,2,jk,jn)=tra(ji,1,jk,jn) * tmask(ji,2,jk)152 ELSE153 tra(ji,2,jk,jn)=(zalpha4*tra(ji,1,jk,jn)+zalpha3*tra(ji,3,jk,jn))*tmask(ji,2,jk)154 IF( vn(ji,2,jk) < 0.e0 ) THEN155 tra(ji,2,jk,jn)=(zalpha6*tra(ji,3,jk,jn)+zalpha5*tra(ji,1,jk,jn)+zalpha7*tra(ji,4,jk,jn))*tmask(ji,2,jk)156 ENDIF157 ENDIF158 END DO159 END DO160 ENDDO161 ENDIF162 !163 ! Treatment of corners164 !165 ! East south166 IF ((eastern_side).AND.((nbondj == -1).OR.(nbondj == 2))) THEN167 tra(nlci-1,2,:,:) = ptab(nlci-1,2,:,:)168 ENDIF169 ! East north170 IF ((eastern_side).AND.((nbondj == 1).OR.(nbondj == 2))) THEN171 tra(nlci-1,nlcj-1,:,:) = ptab(nlci-1,nlcj-1,:,:)172 ENDIF173 ! West south174 IF ((western_side).AND.((nbondj == -1).OR.(nbondj == 2))) THEN175 tra(2,2,:,:) = ptab(2,2,:,:)176 ENDIF177 ! West north178 IF ((western_side).AND.((nbondj == 1).OR.(nbondj == 2))) THEN179 tra(2,nlcj-1,:,:) = ptab(2,nlcj-1,:,:)180 ENDIF181 !182 177 ENDIF 183 178 ! … … 185 180 186 181 #else 182 !!---------------------------------------------------------------------- 183 !! Empty module no TOP AGRIF 184 !!---------------------------------------------------------------------- 187 185 CONTAINS 188 186 SUBROUTINE Agrif_TOP_Interp_empty … … 193 191 END SUBROUTINE Agrif_TOP_Interp_empty 194 192 #endif 193 194 !!====================================================================== 195 195 END MODULE agrif_top_interp -
branches/2017/dev_CNRS_2017/NEMOGCM/NEMO/NST_SRC/agrif_top_sponge.F90
r6140 r8882 4 4 !!====================================================================== 5 5 !! *** MODULE agrif_top_sponge *** 6 !! AGRIF : define in memory AGRIF variables for sea-ice6 !! AGRIF : sponge layer pakage for passive tracers (TOP) 7 7 !!====================================================================== 8 8 !! History : 2.0 ! 2006-08 (R. Benshila, L. Debreu) Original code 9 9 !!---------------------------------------------------------------------- 10 10 #if defined key_agrif && defined key_top 11 11 !!---------------------------------------------------------------------- 12 12 !! Agrif_Sponge_trc : 13 13 !! interptrn_sponge : 14 14 !!---------------------------------------------------------------------- 15 #if defined key_agrif && defined key_top16 15 USE par_oce 17 16 USE par_trc … … 24 23 USE in_out_manager 25 24 USE lib_mpp 26 USE wrk_nemo27 25 28 26 IMPLICIT NONE … … 32 30 33 31 !!---------------------------------------------------------------------- 34 !! NEMO/NST 3.7 , NEMO Consortium (2015)32 !! NEMO/NST 4.0 , NEMO Consortium (2017) 35 33 !! $Id$ 36 34 !! Software governed by the CeCILL licence (NEMOGCM/NEMO_CeCILL.txt) … … 42 40 !! *** ROUTINE Agrif_Sponge_Trc *** 43 41 !!---------------------------------------------------------------------- 44 REAL(wp) :: timecoeff42 REAL(wp) :: zcoef ! local scalar 45 43 !!---------------------------------------------------------------------- 46 44 ! 47 45 #if defined SPONGE_TOP 48 timecoeff = REAL( Agrif_NbStepint(), wp ) / Agrif_rhot()46 zcoef = REAL( Agrif_NbStepint(), wp ) / Agrif_rhot() 49 47 CALL Agrif_sponge 50 48 Agrif_SpecialValue = 0._wp 51 49 Agrif_UseSpecialValue = .TRUE. 52 50 tabspongedone_trn = .FALSE. 53 CALL Agrif_Bc_Variable( trn_sponge_id, calledweight= timecoeff, procname=interptrn_sponge )51 CALL Agrif_Bc_Variable( trn_sponge_id, calledweight=zcoef, procname=interptrn_sponge ) 54 52 Agrif_UseSpecialValue = .FALSE. 55 53 #endif … … 107 105 108 106 #else 109 107 !!---------------------------------------------------------------------- 108 !! Empty module no TOP AGRIF 109 !!---------------------------------------------------------------------- 110 110 CONTAINS 111 111 SUBROUTINE agrif_top_sponge_empty -
branches/2017/dev_CNRS_2017/NEMOGCM/NEMO/NST_SRC/agrif_top_update.F90
r6140 r8882 5 5 !!====================================================================== 6 6 !! *** MODULE agrif_top_update *** 7 !! AGRIF : 8 !! ----------------------------------------------------------------------7 !! AGRIF : update package for passive tracers (TOP) 8 !!====================================================================== 9 9 !! History : 10 10 !!---------------------------------------------------------------------- 11 12 11 #if defined key_agrif && defined key_top 12 !!---------------------------------------------------------------------- 13 !! 'key_agrif' AGRIF zoom 14 !! 'key_TOP' on-line tracers 15 !!---------------------------------------------------------------------- 13 16 USE par_oce 14 17 USE oce 18 USE dom_oce 19 USE agrif_oce 15 20 USE par_trc 16 21 USE trc 17 USE dom_oce18 USE agrif_oce19 USE wrk_nemo20 22 21 23 IMPLICIT NONE … … 27 29 28 30 !!---------------------------------------------------------------------- 29 !! NEMO/NST 3.7 , NEMO Consortium (2015)31 !! NEMO/NST 4.0 , NEMO Consortium (2017) 30 32 !! $Id$ 31 33 !! Software governed by the CeCILL licence (NEMOGCM/NEMO_CeCILL.txt) … … 112 114 113 115 #else 116 !!---------------------------------------------------------------------- 117 !! Empty module no TOP AGRIF 118 !!---------------------------------------------------------------------- 114 119 CONTAINS 115 120 SUBROUTINE agrif_top_update_empty 116 !!---------------------------------------------117 !! *** ROUTINE agrif_Top_update_empty ***118 !!---------------------------------------------119 121 WRITE(*,*) 'agrif_top_update : You should not have seen this print! error?' 120 122 END SUBROUTINE agrif_top_update_empty -
branches/2017/dev_CNRS_2017/NEMOGCM/NEMO/NST_SRC/agrif_user.F90
r7761 r8882 1 1 #if defined key_agrif 2 2 !!---------------------------------------------------------------------- 3 !! NEMO/NST 3.7 , NEMO Consortium (2016)3 !! NEMO/NST 4.0 , NEMO Consortium (2017) 4 4 !! $Id$ 5 5 !! Software governed by the CeCILL licence (NEMOGCM/NEMO_CeCILL.txt) … … 105 105 USE agrif_opa_interp 106 106 USE agrif_opa_sponge 107 ! !107 ! 108 108 IMPLICIT NONE 109 109 !!---------------------------------------------------------------------- … … 125 125 USE par_oce 126 126 USE oce 127 !! 128 IMPLICIT NONE 127 ! 128 IMPLICIT NONE 129 ! 130 INTEGER :: ind1, ind2, ind3 129 131 !!---------------------------------------------------------------------- 130 132 131 133 ! 1. Declaration of the type of variable which have to be interpolated 132 134 !--------------------------------------------------------------------- 133 CALL agrif_declare_variable((/1,2/),(/2,3/),(/'x','y'/),(/1,1/),(/nlci,nlcj/),e1u_id) 134 CALL agrif_declare_variable((/2,1/),(/3,2/),(/'x','y'/),(/1,1/),(/nlci,nlcj/),e2v_id) 135 ind1 = nbghostcells 136 ind2 = 1 + nbghostcells 137 ind3 = 2 + nbghostcells 138 CALL agrif_declare_variable((/1,2/),(/ind2,ind3/),(/'x','y'/),(/1,1/),(/nlci,nlcj/),e1u_id) 139 CALL agrif_declare_variable((/2,1/),(/ind3,ind2/),(/'x','y'/),(/1,1/),(/nlci,nlcj/),e2v_id) 135 140 136 141 ! 2. Type of interpolation 137 142 !------------------------- 138 CALL Agrif_Set_bcinterp( e1u_id,interp1=Agrif_linear,interp2=AGRIF_ppm)139 CALL Agrif_Set_bcinterp( e2v_id,interp1=AGRIF_ppm,interp2=Agrif_linear)143 CALL Agrif_Set_bcinterp( e1u_id, interp1=Agrif_linear, interp2=AGRIF_ppm ) 144 CALL Agrif_Set_bcinterp( e2v_id, interp1=AGRIF_ppm , interp2=Agrif_linear ) 140 145 141 146 ! 3. Location of interpolation 142 147 !----------------------------- 143 CALL Agrif_Set_bc(e1u_id,(/0, 0/))144 CALL Agrif_Set_bc(e2v_id,(/0, 0/))148 CALL Agrif_Set_bc(e1u_id,(/0,ind1-1/)) 149 CALL Agrif_Set_bc(e2v_id,(/0,ind1-1/)) 145 150 146 151 ! 5. Update type 147 152 !--------------- 148 CALL Agrif_Set_Updatetype( e1u_id,update1 = Agrif_Update_Copy, update2=Agrif_Update_Average)149 CALL Agrif_Set_Updatetype( e2v_id,update1 = Agrif_Update_Average, update2=Agrif_Update_Copy)153 CALL Agrif_Set_Updatetype( e1u_id, update1=Agrif_Update_Copy , update2=Agrif_Update_Average ) 154 CALL Agrif_Set_Updatetype( e2v_id, update1=Agrif_Update_Average, update2=Agrif_Update_Copy ) 150 155 151 156 ! High order updates 152 ! CALL Agrif_Set_Updatetype( e1u_id,update1 = Agrif_Update_Average, update2=Agrif_Update_Full_Weighting)153 ! CALL Agrif_Set_Updatetype( e2v_id,update1 = Agrif_Update_Full_Weighting, update2=Agrif_Update_Average)157 ! CALL Agrif_Set_Updatetype( e1u_id, update1=Agrif_Update_Average , update2=Agrif_Update_Full_Weighting ) 158 ! CALL Agrif_Set_Updatetype( e2v_id, update1=Agrif_Update_Full_Weighting, update2=Agrif_Update_Average ) 154 159 ! 155 160 END SUBROUTINE agrif_declare_var_dom … … 162 167 !! ** Purpose :: Declaration of variables to be interpolated 163 168 !!---------------------------------------------------------------------- 169 USE agrif_opa_update 170 USE agrif_opa_interp 171 USE agrif_opa_sponge 164 172 USE Agrif_Util 165 173 USE oce 166 174 USE dom_oce 175 USE zdf_oce 167 176 USE nemogcm 177 ! 168 178 USE lib_mpp 169 179 USE in_out_manager 170 USE agrif_opa_update 171 USE agrif_opa_interp 172 USE agrif_opa_sponge 173 !! 180 ! 174 181 IMPLICIT NONE 175 182 ! … … 184 191 ! 2. First interpolations of potentially non zero fields 185 192 !------------------------------------------------------- 186 Agrif_SpecialValue =0.193 Agrif_SpecialValue = 0._wp 187 194 Agrif_UseSpecialValue = .TRUE. 188 195 CALL Agrif_Bc_variable(tsn_id,calledweight=1.,procname=interptsn) … … 319 326 ENDIF 320 327 ! 321 # if defined key_zdftke322 CALL Agrif_Update_tke(0)323 # endif324 !325 328 Agrif_UseSpecialValueInUpdate = .FALSE. 326 329 nbcline = 0 … … 337 340 !!---------------------------------------------------------------------- 338 341 USE agrif_util 339 USE par_oce ! ONLY : jpts 342 USE agrif_oce 343 USE par_oce ! ocean parameters 344 USE zdf_oce ! vertical physics 340 345 USE oce 341 USE agrif_oce 342 !! 343 IMPLICIT NONE 346 ! 347 IMPLICIT NONE 348 ! 349 INTEGER :: ind1, ind2, ind3 344 350 !!---------------------------------------------------------------------- 345 351 346 352 ! 1. Declaration of the type of variable which have to be interpolated 347 353 !--------------------------------------------------------------------- 348 CALL agrif_declare_variable((/2,2,0,0/),(/3,3,0,0/),(/'x','y','N','N'/),(/1,1,1,1/),(/nlci,nlcj,jpk,jpts/),tsn_id) 349 CALL agrif_declare_variable((/2,2,0,0/),(/3,3,0,0/),(/'x','y','N','N'/),(/1,1,1,1/),(/nlci,nlcj,jpk,jpts/),tsn_sponge_id) 350 351 CALL agrif_declare_variable((/1,2,0/),(/2,3,0/),(/'x','y','N'/),(/1,1,1/),(/nlci,nlcj,jpk/),un_interp_id) 352 CALL agrif_declare_variable((/2,1,0/),(/3,2,0/),(/'x','y','N'/),(/1,1,1/),(/nlci,nlcj,jpk/),vn_interp_id) 353 CALL agrif_declare_variable((/1,2,0/),(/2,3,0/),(/'x','y','N'/),(/1,1,1/),(/nlci,nlcj,jpk/),un_update_id) 354 CALL agrif_declare_variable((/2,1,0/),(/3,2,0/),(/'x','y','N'/),(/1,1,1/),(/nlci,nlcj,jpk/),vn_update_id) 355 CALL agrif_declare_variable((/1,2,0/),(/2,3,0/),(/'x','y','N'/),(/1,1,1/),(/nlci,nlcj,jpk/),un_sponge_id) 356 CALL agrif_declare_variable((/2,1,0/),(/3,2,0/),(/'x','y','N'/),(/1,1,1/),(/nlci,nlcj,jpk/),vn_sponge_id) 357 358 CALL agrif_declare_variable((/2,2,0/),(/3,3,0/),(/'x','y','N'/),(/1,1,1/),(/nlci,nlcj,jpk/),e3t_id) 359 CALL agrif_declare_variable((/1,2,0/),(/2,3,0/),(/'x','y','N'/),(/1,1,1/),(/nlci,nlcj,jpk/),umsk_id) 360 CALL agrif_declare_variable((/2,1,0/),(/3,2,0/),(/'x','y','N'/),(/1,1,1/),(/nlci,nlcj,jpk/),vmsk_id) 361 362 CALL agrif_declare_variable((/2,2,0,0/),(/3,3,0,0/),(/'x','y','N','N'/),(/1,1,1,1/),(/nlci,nlcj,jpk,3/),scales_t_id) 363 364 CALL agrif_declare_variable((/1,2/),(/2,3/),(/'x','y'/),(/1,1/),(/nlci,nlcj/),unb_id) 365 CALL agrif_declare_variable((/2,1/),(/3,2/),(/'x','y'/),(/1,1/),(/nlci,nlcj/),vnb_id) 366 CALL agrif_declare_variable((/1,2/),(/2,3/),(/'x','y'/),(/1,1/),(/nlci,nlcj/),ub2b_interp_id) 367 CALL agrif_declare_variable((/2,1/),(/3,2/),(/'x','y'/),(/1,1/),(/nlci,nlcj/),vb2b_interp_id) 368 CALL agrif_declare_variable((/1,2/),(/2,3/),(/'x','y'/),(/1,1/),(/nlci,nlcj/),ub2b_update_id) 369 CALL agrif_declare_variable((/2,1/),(/3,2/),(/'x','y'/),(/1,1/),(/nlci,nlcj/),vb2b_update_id) 370 371 CALL agrif_declare_variable((/2,2/),(/3,3/),(/'x','y'/),(/1,1/),(/nlci,nlcj/),sshn_id) 372 373 # if defined key_zdftke 374 CALL agrif_declare_variable((/2,2,0/),(/3,3,0/),(/'x','y','N'/),(/1,1,1/),(/jpi,jpj,jpk/), en_id) 375 CALL agrif_declare_variable((/2,2,0/),(/3,3,0/),(/'x','y','N'/),(/1,1,1/),(/jpi,jpj,jpk/),avt_id) 376 CALL agrif_declare_variable((/2,2,0/),(/3,3,0/),(/'x','y','N'/),(/1,1,1/),(/jpi,jpj,jpk/),avm_id) 377 # endif 354 ind1 = nbghostcells 355 ind2 = 1 + nbghostcells 356 ind3 = 2 + nbghostcells 357 CALL agrif_declare_variable((/2,2,0,0/),(/ind3,ind3,0,0/),(/'x','y','N','N'/),(/1,1,1,1/),(/nlci,nlcj,jpk,jpts/),tsn_id) 358 CALL agrif_declare_variable((/2,2,0,0/),(/ind3,ind3,0,0/),(/'x','y','N','N'/),(/1,1,1,1/),(/nlci,nlcj,jpk,jpts/),tsn_sponge_id) 359 360 CALL agrif_declare_variable((/1,2,0/),(/ind2,ind3,0/),(/'x','y','N'/),(/1,1,1/),(/nlci,nlcj,jpk/),un_interp_id) 361 CALL agrif_declare_variable((/2,1,0/),(/ind3,ind2,0/),(/'x','y','N'/),(/1,1,1/),(/nlci,nlcj,jpk/),vn_interp_id) 362 CALL agrif_declare_variable((/1,2,0/),(/ind2,ind3,0/),(/'x','y','N'/),(/1,1,1/),(/nlci,nlcj,jpk/),un_update_id) 363 CALL agrif_declare_variable((/2,1,0/),(/ind3,ind2,0/),(/'x','y','N'/),(/1,1,1/),(/nlci,nlcj,jpk/),vn_update_id) 364 CALL agrif_declare_variable((/1,2,0/),(/ind2,ind3,0/),(/'x','y','N'/),(/1,1,1/),(/nlci,nlcj,jpk/),un_sponge_id) 365 CALL agrif_declare_variable((/2,1,0/),(/ind3,ind2,0/),(/'x','y','N'/),(/1,1,1/),(/nlci,nlcj,jpk/),vn_sponge_id) 366 367 CALL agrif_declare_variable((/2,2,0/),(/ind3,ind3,0/),(/'x','y','N'/),(/1,1,1/),(/nlci,nlcj,jpk/),e3t_id) 368 CALL agrif_declare_variable((/1,2,0/),(/ind2,ind3,0/),(/'x','y','N'/),(/1,1,1/),(/nlci,nlcj,jpk/),umsk_id) 369 CALL agrif_declare_variable((/2,1,0/),(/ind3,ind2,0/),(/'x','y','N'/),(/1,1,1/),(/nlci,nlcj,jpk/),vmsk_id) 370 371 CALL agrif_declare_variable((/2,2,0,0/),(/ind3,ind3,0,0/),(/'x','y','N','N'/),(/1,1,1,1/),(/nlci,nlcj,jpk,3/),scales_t_id) 372 373 CALL agrif_declare_variable((/1,2/),(/ind2,ind3/),(/'x','y'/),(/1,1/),(/nlci,nlcj/),unb_id) 374 CALL agrif_declare_variable((/2,1/),(/ind3,ind2/),(/'x','y'/),(/1,1/),(/nlci,nlcj/),vnb_id) 375 CALL agrif_declare_variable((/1,2/),(/ind2,ind3/),(/'x','y'/),(/1,1/),(/nlci,nlcj/),ub2b_interp_id) 376 CALL agrif_declare_variable((/2,1/),(/ind3,ind2/),(/'x','y'/),(/1,1/),(/nlci,nlcj/),vb2b_interp_id) 377 CALL agrif_declare_variable((/1,2/),(/ind2,ind3/),(/'x','y'/),(/1,1/),(/nlci,nlcj/),ub2b_update_id) 378 CALL agrif_declare_variable((/2,1/),(/ind3,ind2/),(/'x','y'/),(/1,1/),(/nlci,nlcj/),vb2b_update_id) 379 380 CALL agrif_declare_variable((/2,2/),(/ind3,ind3/),(/'x','y'/),(/1,1/),(/nlci,nlcj/),sshn_id) 381 382 IF( ln_zdftke ) THEN 383 CALL agrif_declare_variable((/2,2,0/),(/ind3,ind3,0/),(/'x','y','N'/),(/1,1,1/),(/jpi,jpj,jpk/), en_id) 384 CALL agrif_declare_variable((/2,2,0/),(/ind3,ind3,0/),(/'x','y','N'/),(/1,1,1/),(/jpi,jpj,jpk/),avt_id) 385 CALL agrif_declare_variable((/2,2,0/),(/ind3,ind3,0/),(/'x','y','N'/),(/1,1,1/),(/jpi,jpj,jpk/),avm_id) 386 ENDIF 378 387 379 388 ! 2. Type of interpolation … … 400 409 CALL Agrif_Set_bcinterp(vmsk_id,interp=AGRIF_constant) 401 410 402 # if defined key_zdftke 403 CALL Agrif_Set_bcinterp(avm_id ,interp=AGRIF_linear) 404 # endif 405 411 IF( ln_zdftke ) CALL Agrif_Set_bcinterp( avm_id, interp=AGRIF_linear ) 406 412 407 413 ! 3. Location of interpolation 408 414 !----------------------------- 409 CALL Agrif_Set_bc(tsn_id,(/0,1/)) 410 CALL Agrif_Set_bc(un_interp_id,(/0,1/)) 411 CALL Agrif_Set_bc(vn_interp_id,(/0,1/)) 412 413 ! CALL Agrif_Set_bc(tsn_sponge_id,(/-3*Agrif_irhox(),0/)) 414 ! CALL Agrif_Set_bc(un_sponge_id,(/-2*Agrif_irhox()-1,0/)) 415 ! CALL Agrif_Set_bc(vn_sponge_id,(/-2*Agrif_irhox()-1,0/)) 416 CALL Agrif_Set_bc(tsn_sponge_id,(/-nn_sponge_len*Agrif_irhox()-1,0/)) 417 CALL Agrif_Set_bc(un_sponge_id ,(/-nn_sponge_len*Agrif_irhox()-1,0/)) 418 CALL Agrif_Set_bc(vn_sponge_id ,(/-nn_sponge_len*Agrif_irhox()-1,0/)) 419 420 CALL Agrif_Set_bc(sshn_id,(/0,0/)) 421 CALL Agrif_Set_bc(unb_id ,(/0,0/)) 422 CALL Agrif_Set_bc(vnb_id ,(/0,0/)) 423 CALL Agrif_Set_bc(ub2b_interp_id,(/0,0/)) 424 CALL Agrif_Set_bc(vb2b_interp_id,(/0,0/)) 425 426 CALL Agrif_Set_bc(e3t_id,(/-2*Agrif_irhox()-1,0/)) ! if west and rhox=3: column 2 to 9 427 CALL Agrif_Set_bc(umsk_id,(/0,0/)) 428 CALL Agrif_Set_bc(vmsk_id,(/0,0/)) 429 430 # if defined key_zdftke 431 CALL Agrif_Set_bc(avm_id ,(/0,1/)) 432 # endif 415 CALL Agrif_Set_bc( tsn_id, (/0,ind1/) ) 416 CALL Agrif_Set_bc( un_interp_id, (/0,ind1/) ) 417 CALL Agrif_Set_bc( vn_interp_id, (/0,ind1/) ) 418 419 CALL Agrif_Set_bc( tsn_sponge_id, (/-nn_sponge_len*Agrif_irhox()-1,0/) ) ! if west and rhox=3 and sponge=2 and ghost=1: columns 2 to 9 420 CALL Agrif_Set_bc( un_sponge_id, (/-nn_sponge_len*Agrif_irhox()-1,0/) ) 421 CALL Agrif_Set_bc( vn_sponge_id, (/-nn_sponge_len*Agrif_irhox()-1,0/) ) 422 423 CALL Agrif_Set_bc( sshn_id, (/0,ind1-1/) ) 424 CALL Agrif_Set_bc( unb_id, (/0,ind1-1/) ) 425 CALL Agrif_Set_bc( vnb_id, (/0,ind1-1/) ) 426 CALL Agrif_Set_bc( ub2b_interp_id, (/0,ind1-1/) ) 427 CALL Agrif_Set_bc( vb2b_interp_id, (/0,ind1-1/) ) 428 429 CALL Agrif_Set_bc( e3t_id, (/-2*Agrif_irhox()-1,ind1-1/) ) ! if west and rhox=3 and ghost=1: column 2 to 9 430 CALL Agrif_Set_bc( umsk_id, (/0,ind1-1/) ) 431 CALL Agrif_Set_bc( vmsk_id, (/0,ind1-1/) ) 432 433 IF( ln_zdftke ) CALL Agrif_Set_bc( avm_id, (/0,ind1/) ) 433 434 434 435 ! 5. Update type … … 446 447 CALL Agrif_Set_Updatetype(vb2b_update_id,update1 = Agrif_Update_Average, update2 = Agrif_Update_Copy) 447 448 448 # if defined key_zdftke 449 CALL Agrif_Set_Updatetype( en_id, update = AGRIF_Update_Average)450 CALL Agrif_Set_Updatetype(avt_id, update = AGRIF_Update_Average)451 CALL Agrif_Set_Updatetype(avm_id, update = AGRIF_Update_Average)452 # endif 449 IF( ln_zdftke) THEN 450 CALL Agrif_Set_Updatetype( en_id, update = AGRIF_Update_Average) 451 CALL Agrif_Set_Updatetype(avt_id, update = AGRIF_Update_Average) 452 CALL Agrif_Set_Updatetype(avm_id, update = AGRIF_Update_Average) 453 ENDIF 453 454 454 455 ! High order updates … … 463 464 ! 464 465 END SUBROUTINE agrif_declare_var 465 466 # if defined key_lim2467 SUBROUTINE Agrif_InitValues_cont_lim2468 !!----------------------------------------------------------------------469 !! *** ROUTINE Agrif_InitValues_cont_lim2 ***470 !!471 !! ** Purpose :: Initialisation of variables to be interpolated for LIM2472 !!----------------------------------------------------------------------473 USE Agrif_Util474 USE ice_2475 USE agrif_ice476 USE in_out_manager477 USE agrif_lim2_update478 USE agrif_lim2_interp479 USE lib_mpp480 !!481 IMPLICIT NONE482 !!----------------------------------------------------------------------483 484 ! 1. Declaration of the type of variable which have to be interpolated485 !---------------------------------------------------------------------486 CALL agrif_declare_var_lim2487 488 ! 2. First interpolations of potentially non zero fields489 !-------------------------------------------------------490 Agrif_SpecialValue=-9999.491 Agrif_UseSpecialValue = .TRUE.492 ! Call Agrif_Bc_variable(zadv ,adv_ice_id ,calledweight=1.,procname=interp_adv_ice )493 ! Call Agrif_Bc_variable(zvel ,u_ice_id ,calledweight=1.,procname=interp_u_ice )494 ! Call Agrif_Bc_variable(zvel ,v_ice_id ,calledweight=1.,procname=interp_v_ice )495 Agrif_SpecialValue=0.496 Agrif_UseSpecialValue = .FALSE.497 498 ! 3. Some controls499 !-----------------500 501 # if ! defined key_lim2_vp502 lim_nbstep = 1.503 CALL agrif_rhg_lim2_load504 CALL agrif_trp_lim2_load505 lim_nbstep = 0.506 # endif507 !RB mandatory but why ???508 ! IF( nbclineupdate /= nn_fsbc .AND. nn_ice == 2 )THEN509 ! CALL ctl_warn ('With ice model on child grid, nbclineupdate is set to nn_fsbc')510 ! nbclineupdate = nn_fsbc511 ! ENDIF512 CALL Agrif_Update_lim2(0)513 !514 END SUBROUTINE Agrif_InitValues_cont_lim2515 516 517 SUBROUTINE agrif_declare_var_lim2518 !!----------------------------------------------------------------------519 !! *** ROUTINE agrif_declare_var_lim2 ***520 !!521 !! ** Purpose :: Declaration of variables to be interpolated for LIM2522 !!----------------------------------------------------------------------523 USE agrif_util524 USE ice_2525 !!526 IMPLICIT NONE527 !!----------------------------------------------------------------------528 529 ! 1. Declaration of the type of variable which have to be interpolated530 !---------------------------------------------------------------------531 CALL agrif_declare_variable((/2,2,0/),(/3,3,0/),(/'x','y','N'/),(/1,1,1/),(/jpi,jpj, 7/),adv_ice_id )532 # if defined key_lim2_vp533 CALL agrif_declare_variable((/1,1/),(/3,3/),(/'x','y'/),(/1,1/),(/jpi,jpj/),u_ice_id)534 CALL agrif_declare_variable((/1,1/),(/3,3/),(/'x','y'/),(/1,1/),(/jpi,jpj/),v_ice_id)535 # else536 CALL agrif_declare_variable((/1,2/),(/2,3/),(/'x','y'/),(/1,1/),(/jpi,jpj/),u_ice_id)537 CALL agrif_declare_variable((/2,1/),(/3,2/),(/'x','y'/),(/1,1/),(/jpi,jpj/),v_ice_id)538 # endif539 540 ! 2. Type of interpolation541 !-------------------------542 CALL Agrif_Set_bcinterp(adv_ice_id ,interp=AGRIF_linear)543 CALL Agrif_Set_bcinterp(u_ice_id,interp1=Agrif_linear,interp2=AGRIF_ppm)544 CALL Agrif_Set_bcinterp(v_ice_id,interp1=AGRIF_ppm,interp2=Agrif_linear)545 546 ! 3. Location of interpolation547 !-----------------------------548 CALL Agrif_Set_bc(adv_ice_id ,(/0,1/))549 CALL Agrif_Set_bc(u_ice_id,(/0,1/))550 CALL Agrif_Set_bc(v_ice_id,(/0,1/))551 552 ! 5. Update type553 !---------------554 CALL Agrif_Set_Updatetype(adv_ice_id , update = AGRIF_Update_Average)555 CALL Agrif_Set_Updatetype(u_ice_id,update1 = Agrif_Update_Copy, update2 = Agrif_Update_Average)556 CALL Agrif_Set_Updatetype(v_ice_id,update1 = Agrif_Update_Average, update2 = Agrif_Update_Copy)557 !558 END SUBROUTINE agrif_declare_var_lim2559 # endif560 466 561 467 #if defined key_lim3 … … 623 529 USE Agrif_Util 624 530 USE ice 625 626 IMPLICIT NONE 531 USE par_oce, ONLY : nbghostcells 532 ! 533 IMPLICIT NONE 534 ! 535 INTEGER :: ind1, ind2, ind3 627 536 !!---------------------------------------------------------------------- 628 537 ! … … 634 543 ! 2,2 = two ghost lines 635 544 !------------------------------------------------------------------------------------- 636 CALL agrif_declare_variable((/2,2,0/),(/3,3,0/),(/'x','y','N'/),(/1,1,1/),(/nlci,nlcj,jpl*(5+nlay_s+nlay_i)/),tra_ice_id ) 637 CALL agrif_declare_variable((/1,2/) ,(/2,3/),(/'x','y'/) ,(/1,1/) ,(/nlci,nlcj/) ,u_ice_id ) 638 CALL agrif_declare_variable((/2,1/) ,(/3,2/),(/'x','y'/) ,(/1,1/) ,(/nlci,nlcj/) ,v_ice_id ) 545 ind1 = nbghostcells 546 ind2 = 1 + nbghostcells 547 ind3 = 2 + nbghostcells 548 CALL agrif_declare_variable((/2,2,0/),(/ind3,ind3,0/),(/'x','y','N'/),(/1,1,1/),(/nlci,nlcj,jpl*(5+nlay_s+nlay_i)/),tra_ice_id ) 549 CALL agrif_declare_variable((/1,2/) ,(/ind2,ind3/) ,(/'x','y'/) ,(/1,1/) ,(/nlci,nlcj/) ,u_ice_id ) 550 CALL agrif_declare_variable((/2,1/) ,(/ind3,ind2/) ,(/'x','y'/) ,(/1,1/) ,(/nlci,nlcj/) ,v_ice_id ) 639 551 640 552 ! 2. Set interpolations (normal & tangent to the grid cell for velocities) … … 646 558 ! 3. Set location of interpolations 647 559 !---------------------------------- 648 CALL Agrif_Set_bc(tra_ice_id,(/0, 1/))649 CALL Agrif_Set_bc(u_ice_id ,(/0, 1/))650 CALL Agrif_Set_bc(v_ice_id ,(/0, 1/))560 CALL Agrif_Set_bc(tra_ice_id,(/0,ind1/)) 561 CALL Agrif_Set_bc(u_ice_id ,(/0,ind1/)) 562 CALL Agrif_Set_bc(v_ice_id ,(/0,ind1/)) 651 563 652 564 ! 4. Set update type in case 2 ways (child=>parent) (normal & tangent to the grid cell for velocities) … … 777 689 !! 778 690 IMPLICIT NONE 691 ! 692 INTEGER :: ind1, ind2, ind3 779 693 !!---------------------------------------------------------------------- 780 694 781 695 ! 1. Declaration of the type of variable which have to be interpolated 782 696 !--------------------------------------------------------------------- 783 CALL agrif_declare_variable((/2,2,0,0/),(/3,3,0,0/),(/'x','y','N','N'/),(/1,1,1,1/),(/nlci,nlcj,jpk,jptra/),trn_id) 784 CALL agrif_declare_variable((/2,2,0,0/),(/3,3,0,0/),(/'x','y','N','N'/),(/1,1,1,1/),(/nlci,nlcj,jpk,jptra/),trn_sponge_id) 697 ind1 = nbghostcells 698 ind2 = 1 + nbghostcells 699 ind3 = 2 + nbghostcells 700 CALL agrif_declare_variable((/2,2,0,0/),(/ind3,ind3,0,0/),(/'x','y','N','N'/),(/1,1,1,1/),(/nlci,nlcj,jpk,jptra/),trn_id) 701 CALL agrif_declare_variable((/2,2,0,0/),(/ind3,ind3,0,0/),(/'x','y','N','N'/),(/1,1,1,1/),(/nlci,nlcj,jpk,jptra/),trn_sponge_id) 785 702 786 703 ! 2. Type of interpolation … … 791 708 ! 3. Location of interpolation 792 709 !----------------------------- 793 CALL Agrif_Set_bc(trn_id,(/0,1/)) 794 ! CALL Agrif_Set_bc(trn_sponge_id,(/-3*Agrif_irhox(),0/)) 710 CALL Agrif_Set_bc(trn_id,(/0,ind1/)) 795 711 CALL Agrif_Set_bc(trn_sponge_id,(/-nn_sponge_len*Agrif_irhox()-1,0/)) 796 712 … … 868 784 ! 869 785 IF( agrif_oce_alloc() > 0 ) CALL ctl_warn('agrif agrif_oce_alloc: allocation of arrays failed') 870 # if defined key_lim2871 IF( agrif_ice_alloc() > 0 ) CALL ctl_stop('agrif agrif_ice_alloc: allocation of arrays failed') ! only for LIM2 (not LIM3)872 # endif873 786 ! 874 787 END SUBROUTINE agrif_nemo_init
Note: See TracChangeset
for help on using the changeset viewer.
