[3479] | 1 | MODULE agrif_lim2_interp |
---|
| 2 | !!====================================================================== |
---|
| 3 | !! *** MODULE agrif_lim2_update *** |
---|
| 4 | !! Nesting module : update surface ocean boundary condition over ice |
---|
| 5 | !! from a child grif |
---|
| 6 | !! Sea-Ice model : LIM 2.0 Sea ice model time-stepping |
---|
| 7 | !!====================================================================== |
---|
| 8 | !! History : 2.0 ! 04-2008 (F. Dupont) initial version |
---|
| 9 | !! 3.4 ! 09-2012 (R. Benshila, C. Herbaut) update and EVP |
---|
| 10 | !!---------------------------------------------------------------------- |
---|
[6487] | 11 | #if defined key_agrif && defined key_lim2 |
---|
[3479] | 12 | !!---------------------------------------------------------------------- |
---|
| 13 | !! 'key_lim2' : LIM 2.0 sea-ice model |
---|
| 14 | !! 'key_agrif' : AGRIF library |
---|
| 15 | !!---------------------------------------------------------------------- |
---|
| 16 | !! agrif_interp_lim2 : update sea-ice model on boundaries or total |
---|
| 17 | !! sea-ice area |
---|
| 18 | !! agrif_rhg_lim2_load : interpolcation of ice velocities using Agrif |
---|
| 19 | !! agrif_rhg_lim2 : sub-interpolation of ice velocities for both |
---|
| 20 | !! splitting time and sea-ice time step |
---|
| 21 | !! agrif_interp_u_ice : atomic routine to interpolate u_ice |
---|
| 22 | !! agrif_interp_u_ice : atomic routine to interpolate v_ice |
---|
| 23 | !! agrif_trp_lim2_load : interpolcation of ice properties using Agrif |
---|
| 24 | !! agrif_trp_lim2 : sub-interpolation of ice properties for |
---|
| 25 | !! sea-ice time step |
---|
| 26 | !! agrif_interp_u_ice : atomic routine to interpolate ice properties |
---|
| 27 | !!---------------------------------------------------------------------- |
---|
| 28 | USE par_oce |
---|
| 29 | USE dom_oce |
---|
| 30 | USE sbc_oce |
---|
| 31 | USE ice_2 |
---|
| 32 | USE dom_ice_2 |
---|
| 33 | USE agrif_ice |
---|
| 34 | |
---|
| 35 | IMPLICIT NONE |
---|
| 36 | PRIVATE |
---|
| 37 | |
---|
| 38 | PUBLIC agrif_rhg_lim2_load, agrif_rhg_lim2 |
---|
| 39 | PUBLIC agrif_trp_lim2_load, agrif_trp_lim2 |
---|
| 40 | PUBLIC interp_u_ice, interp_v_ice |
---|
| 41 | PUBLIC interp_adv_ice |
---|
| 42 | |
---|
[6487] | 43 | REAL(wp), DIMENSION(:,:) , ALLOCATABLE, PRIVATE :: uice_agr, vice_agr |
---|
| 44 | REAL(wp), DIMENSION(:,:,:), ALLOCATABLE, PRIVATE :: tabice_agr |
---|
| 45 | |
---|
| 46 | |
---|
[3479] | 47 | !!---------------------------------------------------------------------- |
---|
| 48 | !! NEMO/NST 3.4 , NEMO Consortium (2012) |
---|
| 49 | !! $Id$ |
---|
| 50 | !! Software governed by the CeCILL licence (NEMOGCM/NEMO_CeCILL.txt) |
---|
| 51 | !!---------------------------------------------------------------------- |
---|
| 52 | |
---|
| 53 | CONTAINS |
---|
| 54 | |
---|
| 55 | # if defined key_lim2_vp |
---|
| 56 | SUBROUTINE agrif_rhg_lim2_load |
---|
| 57 | !!----------------------------------------------------------------------- |
---|
| 58 | !! *** ROUTINE agrif_rhg_lim2_load *** |
---|
| 59 | !! |
---|
| 60 | !! ** Method : need a special routine for dealing with exchanging data |
---|
| 61 | !! between the child and parent grid during ice step |
---|
| 62 | !! |
---|
| 63 | !!----------------------------------------------------------------------- |
---|
| 64 | ! |
---|
| 65 | IF (Agrif_Root()) RETURN |
---|
| 66 | |
---|
| 67 | Agrif_SpecialValue=0. |
---|
| 68 | Agrif_UseSpecialValue = .FALSE. |
---|
| 69 | u_ice_nst(:,:) = 0. |
---|
| 70 | v_ice_nst(:,:) = 0. |
---|
[6487] | 71 | CALL Agrif_Bc_variable( u_ice_id ,procname=interp_u_ice, calledweight=1. ) |
---|
| 72 | CALL Agrif_Bc_variable( v_ice_id ,procname=interp_v_ice, calledweight=1. ) |
---|
[3479] | 73 | Agrif_SpecialValue=0. |
---|
| 74 | Agrif_UseSpecialValue = .FALSE. |
---|
| 75 | ! |
---|
| 76 | END SUBROUTINE agrif_rhg_lim2_load |
---|
| 77 | |
---|
| 78 | |
---|
| 79 | SUBROUTINE agrif_rhg_lim2(pu_n,pv_n) |
---|
| 80 | !!----------------------------------------------------------------------- |
---|
| 81 | !! *** ROUTINE agrif_rhg_lim2 *** |
---|
| 82 | !! |
---|
| 83 | !! ** Method : we feel the boundaries with values stored above |
---|
| 84 | !!----------------------------------------------------------------------- |
---|
| 85 | REAL(wp), DIMENSION(jpi,0:jpj+1), INTENT(inout) :: pu_n, pv_n |
---|
| 86 | !! |
---|
| 87 | REAL(wp) :: zrhox, zrhoy |
---|
| 88 | INTEGER :: ji,jj |
---|
| 89 | !!----------------------------------------------------------------------- |
---|
| 90 | ! |
---|
| 91 | IF (Agrif_Root()) RETURN |
---|
| 92 | |
---|
| 93 | zrhox = Agrif_Rhox() |
---|
| 94 | zrhoy = Agrif_Rhoy() |
---|
| 95 | |
---|
| 96 | IF((nbondi == -1).OR.(nbondi == 2)) THEN |
---|
| 97 | DO jj=2,jpj |
---|
| 98 | pu_n(3,jj) = u_ice_nst(3,jj)/(zrhoy*e2f(2,jj-1))*tmu(3,jj) |
---|
| 99 | END DO |
---|
| 100 | DO jj=2,jpj |
---|
| 101 | pv_n(3,jj) = v_ice_nst(3,jj)/(zrhox*e1f(2,jj-1))*tmu(3,jj) |
---|
| 102 | END DO |
---|
| 103 | ENDIF |
---|
| 104 | |
---|
| 105 | IF((nbondi == 1).OR.(nbondi == 2)) THEN |
---|
| 106 | DO jj=2,jpj |
---|
| 107 | pu_n(nlci-1,jj) = u_ice_nst(nlci-1,jj)/(zrhoy*e2f(nlci-2,jj-1))*tmu(nlci-1,jj) |
---|
| 108 | END DO |
---|
| 109 | DO jj=2,jpj |
---|
| 110 | pv_n(nlci-1,jj) = v_ice_nst(nlci-1,jj)/(zrhox*e1f(nlci-2,jj-1))*tmu(nlci-1,jj) |
---|
| 111 | END DO |
---|
| 112 | ENDIF |
---|
| 113 | |
---|
| 114 | IF((nbondj == -1).OR.(nbondj == 2)) THEN |
---|
| 115 | DO ji=2,jpi |
---|
| 116 | pv_n(ji,3) = v_ice_nst(ji,3)/(zrhox*e1f(ji-1,2))*tmu(ji,3) |
---|
| 117 | END DO |
---|
| 118 | DO ji=2,jpi |
---|
| 119 | pu_n(ji,3) = u_ice_nst(ji,3)/(zrhoy*e2f(ji-1,2))*tmu(ji,3) |
---|
| 120 | END DO |
---|
| 121 | ENDIF |
---|
| 122 | |
---|
| 123 | IF((nbondj == 1).OR.(nbondj == 2)) THEN |
---|
| 124 | DO ji=2,jpi |
---|
| 125 | pv_n(ji,nlcj-1) = v_ice_nst(ji,nlcj-1)/(zrhox*e1f(ji-1,nlcj-2))*tmu(ji,nlcj-1) |
---|
| 126 | END DO |
---|
| 127 | DO ji=2,jpi |
---|
| 128 | pu_n(ji,nlcj-1) = u_ice_nst(ji,nlcj-1)/(zrhoy*e2f(ji-1,nlcj-2))*tmu(ji,nlcj-1) |
---|
| 129 | END DO |
---|
| 130 | ENDIF |
---|
| 131 | ! |
---|
| 132 | END SUBROUTINE agrif_rhg_lim2 |
---|
| 133 | |
---|
| 134 | #else |
---|
| 135 | SUBROUTINE agrif_rhg_lim2_load |
---|
| 136 | !!----------------------------------------------------------------------- |
---|
| 137 | !! *** ROUTINE agrif_rhg_lim2_load *** |
---|
| 138 | !! |
---|
| 139 | !! ** Method : need a special routine for dealing with exchanging data |
---|
| 140 | !! between the child and parent grid during ice step |
---|
| 141 | !! we interpolate and store the boundary if needed, ie if |
---|
| 142 | !! we are in inside a new parent ice time step |
---|
| 143 | !!----------------------------------------------------------------------- |
---|
| 144 | INTEGER :: ji,jj |
---|
| 145 | REAL(wp) :: zrhox, zrhoy |
---|
| 146 | !!----------------------------------------------------------------------- |
---|
| 147 | ! |
---|
| 148 | IF (Agrif_Root()) RETURN |
---|
| 149 | |
---|
| 150 | IF( lim_nbstep == 1. ) THEN |
---|
| 151 | ! |
---|
| 152 | ! switch old values by hand |
---|
| 153 | u_ice_oe(:,:,1) = u_ice_oe(:,:,2) |
---|
| 154 | v_ice_oe(:,:,1) = v_ice_oe(:,:,2) |
---|
| 155 | u_ice_sn(:,:,1) = u_ice_sn(:,:,2) |
---|
| 156 | v_ice_sn(:,:,1) = v_ice_sn(:,:,2) |
---|
| 157 | ! interpolation of boundaries (called weight prevents AGRIF interpolation) |
---|
| 158 | Agrif_SpecialValue=-9999. |
---|
| 159 | Agrif_UseSpecialValue = .TRUE. |
---|
[6487] | 160 | IF( .NOT. ALLOCATED(uice_agr) )THEN |
---|
| 161 | ALLOCATE(uice_agr(jpi,jpj), vice_agr(jpi,jpj)) |
---|
| 162 | ENDIF |
---|
| 163 | uice_agr = 0. |
---|
| 164 | vice_agr = 0. |
---|
| 165 | CALL Agrif_Bc_variable(u_ice_id,procname=interp_u_ice, calledweight=1.) |
---|
| 166 | CALL Agrif_Bc_variable(v_ice_id,procname=interp_v_ice, calledweight=1.) |
---|
[3479] | 167 | Agrif_SpecialValue=0. |
---|
| 168 | Agrif_UseSpecialValue = .FALSE. |
---|
| 169 | ! |
---|
| 170 | zrhox = agrif_rhox() ; zrhoy = agrif_rhoy() |
---|
[6487] | 171 | uice_agr(:,:) = uice_agr(:,:)/(zrhoy*e2u(:,:))*umask(:,:,1) |
---|
| 172 | vice_agr(:,:) = vice_agr(:,:)/(zrhox*e1v(:,:))*vmask(:,:,1) |
---|
[3479] | 173 | ! fill boundaries |
---|
| 174 | DO jj = 1, jpj |
---|
| 175 | DO ji = 1, 2 |
---|
[6487] | 176 | u_ice_oe(ji, jj,2) = uice_agr(ji ,jj) |
---|
| 177 | u_ice_oe(ji+2,jj,2) = uice_agr(nlci+ji-3,jj) |
---|
[3479] | 178 | END DO |
---|
| 179 | END DO |
---|
| 180 | DO jj = 1, jpj |
---|
[6487] | 181 | v_ice_oe(2,jj,2) = vice_agr(2 ,jj) |
---|
| 182 | v_ice_oe(4,jj,2) = vice_agr(nlci-1,jj) |
---|
[3479] | 183 | END DO |
---|
| 184 | DO ji = 1, jpi |
---|
[6487] | 185 | u_ice_sn(ji,2,2) = uice_agr(ji,2 ) |
---|
| 186 | u_ice_sn(ji,4,2) = uice_agr(ji,nlcj-1) |
---|
[3479] | 187 | END DO |
---|
| 188 | DO jj = 1, 2 |
---|
| 189 | DO ji = 1, jpi |
---|
[6487] | 190 | v_ice_sn(ji,jj ,2) = vice_agr(ji,jj ) |
---|
| 191 | v_ice_sn(ji,jj+2,2) = vice_agr(ji,nlcj+jj-3) |
---|
[3479] | 192 | END DO |
---|
| 193 | END DO |
---|
| 194 | ! |
---|
| 195 | ENDIF |
---|
| 196 | ! |
---|
| 197 | END SUBROUTINE agrif_rhg_lim2_load |
---|
| 198 | |
---|
| 199 | |
---|
| 200 | SUBROUTINE agrif_rhg_lim2( kiter, kitermax, cd_type) |
---|
| 201 | !!----------------------------------------------------------------------- |
---|
| 202 | !! *** ROUTINE agrif_rhg_lim2 *** |
---|
| 203 | !! |
---|
| 204 | !! ** Method : simple call to atomic routines using stored values to |
---|
| 205 | !! fill the boundaries depending of the position of the point and |
---|
| 206 | !! computing factor for time interpolation |
---|
| 207 | !!----------------------------------------------------------------------- |
---|
| 208 | INTEGER, INTENT(in) :: kiter, kitermax |
---|
| 209 | CHARACTER(len=1), INTENT( in ) :: cd_type |
---|
| 210 | !! |
---|
| 211 | REAL(wp) :: zalpha, zbeta |
---|
| 212 | !!----------------------------------------------------------------------- |
---|
| 213 | ! |
---|
| 214 | IF (Agrif_Root()) RETURN |
---|
| 215 | zalpha = REAL(lim_nbstep,wp) / (Agrif_Rhot()*Agrif_PArent(nn_fsbc)/REAL(nn_fsbc)) |
---|
| 216 | zbeta = REAL(kiter,wp) / kitermax |
---|
| 217 | zbeta = zalpha * zbeta |
---|
| 218 | SELECT CASE(cd_type) |
---|
| 219 | CASE('U') |
---|
| 220 | CALL ParcoursU( zbeta ) |
---|
| 221 | CASE('V') |
---|
| 222 | CALL ParcoursV( zbeta ) |
---|
| 223 | END SELECT |
---|
| 224 | ! |
---|
| 225 | END SUBROUTINE agrif_rhg_lim2 |
---|
| 226 | |
---|
| 227 | |
---|
| 228 | SUBROUTINE ParcoursU( pbeta ) |
---|
| 229 | !!----------------------------------------------------------------------- |
---|
| 230 | !! *** ROUTINE parcoursU *** |
---|
| 231 | !! |
---|
| 232 | !! ** Method : time and spatial interpolation for U-point using values |
---|
| 233 | !! interpolated from the coarse grid and inside dvalues |
---|
| 234 | !!----------------------------------------------------------------------- |
---|
| 235 | REAL(wp), INTENT(in) :: pbeta |
---|
| 236 | !! |
---|
| 237 | INTEGER :: ji, jj |
---|
| 238 | !!----------------------------------------------------------------------- |
---|
| 239 | ! |
---|
| 240 | IF((nbondi == -1).OR.(nbondi == 2)) THEN |
---|
| 241 | DO jj=1,jpj |
---|
| 242 | DO ji=1,2 |
---|
| 243 | u_ice(ji,jj) = (1-pbeta) * u_ice_oe(ji,jj,1) + pbeta * u_ice_oe(ji,jj,2) |
---|
| 244 | END DO |
---|
| 245 | END DO |
---|
| 246 | DO jj=1,jpj |
---|
| 247 | u_ice(2,jj) = 0.25*(u_ice(1,jj)+2.*u_ice(2,jj)+u_ice(3,jj)) |
---|
| 248 | u_ice(2,jj) = u_ice(2,jj) * umask(2,jj,1) |
---|
| 249 | END DO |
---|
| 250 | ENDIF |
---|
| 251 | |
---|
| 252 | IF((nbondi == 1).OR.(nbondi == 2)) THEN |
---|
| 253 | DO jj=1,jpj |
---|
| 254 | DO ji=1,2 |
---|
| 255 | u_ice(nlci+ji-3,jj) = (1-pbeta) * u_ice_oe(ji+2,jj,1) + pbeta * u_ice_oe(ji+2,jj,2) |
---|
| 256 | END DO |
---|
| 257 | END DO |
---|
| 258 | DO jj=1,jpj |
---|
| 259 | u_ice(nlci-2,jj) = 0.25*(u_ice(nlci-3,jj)+2.*u_ice(nlci-2,jj)+u_ice(nlci-1,jj)) |
---|
| 260 | u_ice(nlci-2,jj) = u_ice(nlci-2,jj) * umask(nlci-2,jj,1) |
---|
| 261 | END DO |
---|
| 262 | ENDIF |
---|
| 263 | |
---|
| 264 | IF((nbondj == -1).OR.(nbondj == 2)) THEN |
---|
| 265 | DO ji=1,jpi |
---|
| 266 | u_ice(ji,2) = (1-pbeta) * u_ice_sn(ji,2,1) + pbeta * u_ice_sn(ji,2,2) |
---|
| 267 | u_ice(ji,2) = u_ice(ji,2)*umask(ji,2,1) |
---|
| 268 | END DO |
---|
| 269 | ENDIF |
---|
| 270 | |
---|
| 271 | IF((nbondj == 1).OR.(nbondj == 2)) THEN |
---|
| 272 | DO ji=1,jpi |
---|
| 273 | u_ice(ji,nlcj-1) = (1-pbeta) * u_ice_sn(ji,4,1) + pbeta * u_ice_sn(ji,4,2) |
---|
| 274 | u_ice(ji,nlcj-1) = u_ice(ji,nlcj-1)*umask(ji,nlcj-1,1) |
---|
| 275 | END DO |
---|
| 276 | ENDIF |
---|
| 277 | ! |
---|
| 278 | END SUBROUTINE ParcoursU |
---|
| 279 | |
---|
| 280 | |
---|
| 281 | SUBROUTINE ParcoursV( pbeta ) |
---|
| 282 | !!----------------------------------------------------------------------- |
---|
| 283 | !! *** ROUTINE parcoursV *** |
---|
| 284 | !! |
---|
| 285 | !! ** Method : time and spatial interpolation for V-point using values |
---|
| 286 | !! interpolated from the coarse grid and inside dvalues |
---|
| 287 | !!----------------------------------------------------------------------- |
---|
| 288 | REAL(wp), INTENT(in) :: pbeta |
---|
| 289 | !! |
---|
| 290 | INTEGER :: ji, jj |
---|
| 291 | !!----------------------------------------------------------------------- |
---|
| 292 | ! |
---|
| 293 | IF((nbondi == -1).OR.(nbondi == 2)) THEN |
---|
| 294 | DO jj=1,jpj |
---|
| 295 | v_ice(2,jj) = (1-pbeta) * v_ice_oe(2,jj,1) + pbeta * v_ice_oe(2,jj,2) |
---|
| 296 | v_ice(2,jj) = v_ice(2,jj) * vmask(2,jj,1) |
---|
| 297 | END DO |
---|
| 298 | ENDIF |
---|
| 299 | |
---|
| 300 | IF((nbondi == 1).OR.(nbondi == 2)) THEN |
---|
| 301 | DO jj=1,jpj |
---|
| 302 | v_ice(nlci-1,jj) = (1-pbeta) * v_ice_oe(4,jj,1) + pbeta * v_ice_oe(4,jj,2) |
---|
| 303 | v_ice(nlci-1,jj) = v_ice(nlci-1,jj)*vmask(nlci-1,jj,1) |
---|
| 304 | END DO |
---|
| 305 | ENDIF |
---|
| 306 | |
---|
| 307 | IF((nbondj == -1).OR.(nbondj == 2)) THEN |
---|
| 308 | DO jj=1,2 |
---|
| 309 | DO ji=1,jpi |
---|
| 310 | v_ice(ji,jj) = (1-pbeta) * v_ice_sn(ji,jj,1) + pbeta * v_ice_sn(ji,jj,2) |
---|
| 311 | END DO |
---|
| 312 | END DO |
---|
| 313 | DO ji=1,jpi |
---|
| 314 | v_ice(ji,2)=0.25*(v_ice(ji,1)+2.*v_ice(ji,2)+v_ice(ji,3)) |
---|
| 315 | v_ice(ji,2)=v_ice(ji,2)*vmask(ji,2,1) |
---|
| 316 | END DO |
---|
| 317 | ENDIF |
---|
| 318 | |
---|
| 319 | IF((nbondj == 1).OR.(nbondj == 2)) THEN |
---|
| 320 | DO jj=1,2 |
---|
| 321 | DO ji=1,jpi |
---|
| 322 | v_ice(ji,nlcj+jj-3) = (1-pbeta) * v_ice_sn(ji,jj+2,1) + pbeta * v_ice_sn(ji,jj+2,2) |
---|
| 323 | END DO |
---|
| 324 | END DO |
---|
| 325 | DO ji=1,jpi |
---|
| 326 | v_ice(ji,nlcj-2)=0.25*(v_ice(ji,nlcj-3)+2.*v_ice(ji,nlcj-2)+v_ice(ji,nlcj-1)) |
---|
| 327 | v_ice(ji,nlcj-2) = v_ice(ji,nlcj-2) * vmask(ji,nlcj-2,1) |
---|
| 328 | END DO |
---|
| 329 | ENDIF |
---|
| 330 | ! |
---|
| 331 | END SUBROUTINE ParcoursV |
---|
| 332 | # endif |
---|
| 333 | SUBROUTINE agrif_trp_lim2_load |
---|
| 334 | !!----------------------------------------------------------------------- |
---|
| 335 | !! *** ROUTINE agrif_trp_lim2_load *** |
---|
| 336 | !! |
---|
| 337 | !! ** Method : need a special routine for dealing with exchanging data |
---|
| 338 | !! between the child and parent grid during ice step |
---|
| 339 | !! we interpolate and store the boundary if needed, ie if |
---|
| 340 | !! we are in inside a new parent ice time step |
---|
| 341 | !!----------------------------------------------------------------------- |
---|
| 342 | INTEGER :: ji,jj,jn |
---|
| 343 | !!----------------------------------------------------------------------- |
---|
| 344 | ! |
---|
| 345 | IF (Agrif_Root()) RETURN |
---|
| 346 | IF( lim_nbstep == 1. ) THEN |
---|
| 347 | ! |
---|
| 348 | ! switch old values |
---|
| 349 | adv_ice_oe(:,:,:,1) = adv_ice_oe(:,:,:,2) |
---|
| 350 | adv_ice_sn(:,:,:,1) = adv_ice_sn(:,:,:,2) |
---|
| 351 | ! interpolation of boundaries |
---|
[6487] | 352 | IF(.NOT.ALLOCATED(tabice_agr))THEN |
---|
| 353 | ALLOCATE(tabice_agr(jpi,jpj,7)) |
---|
| 354 | ENDIF |
---|
| 355 | tabice_agr(:,:,:) = 0. |
---|
[3479] | 356 | Agrif_SpecialValue=-9999. |
---|
| 357 | Agrif_UseSpecialValue = .TRUE. |
---|
[6487] | 358 | CALL Agrif_Bc_variable( adv_ice_id ,procname=interp_adv_ice,calledweight=1. ) |
---|
[3479] | 359 | Agrif_SpecialValue=0. |
---|
| 360 | Agrif_UseSpecialValue = .FALSE. |
---|
| 361 | ! |
---|
| 362 | ! fill boundaries |
---|
| 363 | DO jn =1,7 |
---|
| 364 | DO jj = 1, jpj |
---|
| 365 | DO ji=1,2 |
---|
[6487] | 366 | adv_ice_oe(ji ,jj,jn,2) = tabice_agr(ji ,jj,jn) |
---|
| 367 | adv_ice_oe(ji+2,jj,jn,2) = tabice_agr(nlci-2+ji,jj,jn) |
---|
[3479] | 368 | END DO |
---|
| 369 | END DO |
---|
| 370 | END DO |
---|
| 371 | |
---|
| 372 | Do jn =1,7 |
---|
| 373 | Do jj =1,2 |
---|
| 374 | DO ji = 1, jpi |
---|
[6487] | 375 | adv_ice_sn(ji,jj ,jn,2) = tabice_agr(ji,jj ,jn) |
---|
| 376 | adv_ice_sn(ji,jj+2,jn,2) = tabice_agr(ji,nlcj-2+jj,jn) |
---|
[3479] | 377 | END DO |
---|
| 378 | END DO |
---|
| 379 | END DO |
---|
| 380 | ! |
---|
| 381 | ENDIF |
---|
| 382 | ! |
---|
| 383 | END SUBROUTINE agrif_trp_lim2_load |
---|
| 384 | |
---|
| 385 | |
---|
| 386 | SUBROUTINE agrif_trp_lim2 |
---|
| 387 | !!----------------------------------------------------------------------- |
---|
| 388 | !! *** ROUTINE agrif_trp_lim2 *** |
---|
| 389 | !! |
---|
| 390 | !! ** Method : time coefficient and call to atomic routines |
---|
| 391 | !!----------------------------------------------------------------------- |
---|
| 392 | INTEGER :: ji,jj,jn |
---|
| 393 | REAL(wp) :: zalpha |
---|
| 394 | !!----------------------------------------------------------------------- |
---|
| 395 | ! |
---|
| 396 | IF (Agrif_Root()) RETURN |
---|
| 397 | |
---|
| 398 | zalpha = REAL(lim_nbstep,wp) / (Agrif_Rhot()*Agrif_PArent(nn_fsbc)/REAL(nn_fsbc)) |
---|
| 399 | ! |
---|
[6487] | 400 | tabice_agr(:,:,:) = 0.e0 |
---|
[3479] | 401 | DO jn =1,7 |
---|
| 402 | DO jj =1,2 |
---|
| 403 | DO ji = 1, jpi |
---|
[6487] | 404 | tabice_agr(ji,jj ,jn) = (1-zalpha)*adv_ice_sn(ji,jj ,jn,1) + zalpha*adv_ice_sn(ji,jj ,jn,2) |
---|
| 405 | tabice_agr(ji,nlcj-2+jj ,jn) = (1-zalpha)*adv_ice_sn(ji,jj+2,jn,1) + zalpha*adv_ice_sn(ji,jj+2,jn,2) |
---|
[3479] | 406 | END DO |
---|
| 407 | END DO |
---|
| 408 | END DO |
---|
| 409 | |
---|
| 410 | DO jn =1,7 |
---|
| 411 | DO jj = 1, jpj |
---|
| 412 | DO ji=1,2 |
---|
[6487] | 413 | tabice_agr(ji ,jj,jn) = (1-zalpha)*adv_ice_oe(ji ,jj,jn,1) + zalpha*adv_ice_oe(ji ,jj,jn,2) |
---|
| 414 | tabice_agr(nlci-2+ji,jj,jn) = (1-zalpha)*adv_ice_oe(ji+2,jj,jn,1) + zalpha*adv_ice_oe(ji+2,jj,jn,2) |
---|
[3479] | 415 | END DO |
---|
| 416 | END DO |
---|
| 417 | END DO |
---|
| 418 | ! |
---|
[6487] | 419 | CALL parcoursT( tabice_agr(:,:, 1), frld ) |
---|
| 420 | CALL parcoursT( tabice_agr(:,:, 2), hicif ) |
---|
| 421 | CALL parcoursT( tabice_agr(:,:, 3), hsnif ) |
---|
| 422 | CALL parcoursT( tabice_agr(:,:, 4), tbif(:,:,1) ) |
---|
| 423 | CALL parcoursT( tabice_agr(:,:, 5), tbif(:,:,2) ) |
---|
| 424 | CALL parcoursT( tabice_agr(:,:, 6), tbif(:,:,3) ) |
---|
| 425 | CALL parcoursT( tabice_agr(:,:, 7), qstoif ) |
---|
[3479] | 426 | ! |
---|
| 427 | END SUBROUTINE agrif_trp_lim2 |
---|
| 428 | |
---|
| 429 | |
---|
| 430 | SUBROUTINE parcoursT ( pinterp, pfinal ) |
---|
| 431 | !!----------------------------------------------------------------------- |
---|
| 432 | !! *** ROUTINE parcoursT *** |
---|
| 433 | !! |
---|
| 434 | !! ** Method : fill boundaries for T points |
---|
| 435 | !!----------------------------------------------------------------------- |
---|
| 436 | REAL(wp), DIMENSION(jpi,jpj), INTENT(in) :: pinterp |
---|
| 437 | REAL(wp), DIMENSION(jpi,jpj), INTENT(inout) :: pfinal |
---|
| 438 | !! |
---|
| 439 | REAL(wp) :: zbound, zvbord |
---|
| 440 | REAL(wp), DIMENSION(jpi,jpj) :: zui_u, zvi_v |
---|
| 441 | INTEGER :: ji, jj |
---|
| 442 | !!----------------------------------------------------------------------- |
---|
| 443 | ! |
---|
| 444 | zui_u = 0.e0 |
---|
| 445 | zvi_v = 0.e0 |
---|
| 446 | ! zvbord factor between 1 and 2 to take into account slip or no-slip boundary conditions. |
---|
| 447 | zbound=0. |
---|
| 448 | zvbord = 1.0 + ( 1.0 - zbound ) |
---|
| 449 | #if defined key_lim2_vp |
---|
| 450 | DO jj = 1, jpjm1 |
---|
| 451 | DO ji = 1, jpim1 |
---|
| 452 | zui_u(ji,jj) = ( u_ice(ji+1,jj ) + u_ice(ji+1,jj+1) ) / ( MAX( tmu(ji+1,jj ) + tmu(ji+1,jj+1), zvbord ) ) |
---|
| 453 | zvi_v(ji,jj) = ( v_ice(ji ,jj+1) + v_ice(ji+1,jj+1) ) / ( MAX( tmu(ji ,jj+1) + tmu(ji+1,jj+1), zvbord ) ) |
---|
| 454 | END DO |
---|
| 455 | END DO |
---|
| 456 | #else |
---|
| 457 | zui_u(:,:) = u_ice(:,:) |
---|
| 458 | zvi_v(:,:) = v_ice(:,:) |
---|
| 459 | #endif |
---|
| 460 | |
---|
| 461 | IF((nbondi == -1).OR.(nbondi == 2)) THEN |
---|
| 462 | DO jj=1,jpj |
---|
| 463 | ! IF (zui_u(2,jj).EQ.0.) THEN |
---|
| 464 | ! pfinal (2,jj) = pfinal (1,jj) * tms(2,jj) |
---|
| 465 | ! ELSE |
---|
| 466 | pfinal(2,jj) = 0.25* pinterp(1,jj) + 0.5 * pinterp(2,jj) + 0.25 *pfinal(3,jj) |
---|
| 467 | ! ENDIF |
---|
| 468 | END DO |
---|
| 469 | ENDIF |
---|
| 470 | |
---|
| 471 | IF((nbondj == -1).OR.(nbondj == 2)) THEN |
---|
| 472 | DO ji=1,jpi |
---|
| 473 | ! IF (zvi_v(ji,2).EQ.0.) THEN |
---|
| 474 | ! pfinal (ji,2) = pfinal (ji,1) * tms(ji,2) |
---|
| 475 | ! ELSE |
---|
| 476 | pfinal(ji,2) = 0.25* pinterp(ji,1) + 0.5 * pinterp(ji,2) + 0.25 *pfinal(ji,3) |
---|
| 477 | ! ENDIF |
---|
| 478 | END DO |
---|
| 479 | ENDIF |
---|
| 480 | |
---|
| 481 | |
---|
| 482 | IF((nbondi == 1).OR.(nbondi == 2)) THEN |
---|
| 483 | DO jj=1,jpj |
---|
| 484 | ! IF (zui_u(nlci-2,jj).EQ.0.) THEN |
---|
| 485 | ! pfinal(nlci-1,jj) = pfinal (nlci,jj) * tms(nlci-1,jj) |
---|
| 486 | ! ELSE |
---|
| 487 | pfinal(nlci-1,jj) = 0.25* pinterp(nlci,jj) + 0.5 * pinterp(nlci-1,jj) + 0.25 *pfinal(nlci-2,jj) |
---|
| 488 | ! ENDIF |
---|
| 489 | END DO |
---|
| 490 | ENDIF |
---|
| 491 | |
---|
| 492 | IF((nbondj == 1).OR.(nbondj == 2)) THEN |
---|
| 493 | DO ji=1,jpi |
---|
| 494 | ! IF (zvi_v(ji,nlcj-2).EQ.0.) THEN |
---|
| 495 | ! pfinal (ji,nlcj-1) = pfinal(ji,nlcj) * tms(ji,nlcj-1) |
---|
| 496 | ! ELSE |
---|
| 497 | pfinal(ji,nlcj-1) = 0.25* pinterp(ji,nlcj) + 0.5 * pinterp(ji,nlcj-1) + 0.25 *pfinal(ji,nlcj-2) |
---|
| 498 | ! ENDIF |
---|
| 499 | END DO |
---|
| 500 | ENDIF |
---|
| 501 | |
---|
| 502 | |
---|
| 503 | pfinal (:,:) = pfinal (:,:) * tms(:,:) |
---|
| 504 | ! |
---|
| 505 | END SUBROUTINE parcoursT |
---|
| 506 | |
---|
| 507 | |
---|
[6487] | 508 | SUBROUTINE interp_u_ice( tabres, i1, i2, j1, j2, before ) |
---|
[3479] | 509 | !!----------------------------------------------------------------------- |
---|
| 510 | !! *** ROUTINE interp_u_ice *** |
---|
| 511 | !!----------------------------------------------------------------------- |
---|
| 512 | INTEGER, INTENT(in) :: i1, i2, j1, j2 |
---|
| 513 | REAL(wp), DIMENSION(i1:i2,j1:j2), INTENT(inout) :: tabres |
---|
[6487] | 514 | LOGICAL, INTENT(in) :: before |
---|
[3479] | 515 | !! |
---|
| 516 | INTEGER :: ji,jj |
---|
| 517 | !!----------------------------------------------------------------------- |
---|
| 518 | ! |
---|
| 519 | #if defined key_lim2_vp |
---|
[6487] | 520 | IF( before ) THEN |
---|
| 521 | DO jj=MAX(j1,2),j2 |
---|
| 522 | DO ji=MAX(i1,2),i2 |
---|
| 523 | IF( tmu(ji,jj) == 0. ) THEN |
---|
| 524 | tabres(ji,jj) = -9999. |
---|
| 525 | ELSE |
---|
| 526 | tabres(ji,jj) = e2f(ji-1,jj-1) * u_ice(ji,jj) |
---|
| 527 | ENDIF |
---|
| 528 | END DO |
---|
[3479] | 529 | END DO |
---|
[6823] | 530 | ELSE |
---|
| 531 | DO jj=MAX(j1,2),j2 |
---|
| 532 | DO ji=MAX(i1,2),i2 |
---|
| 533 | uice_agr(ji,jj) = tabres(ji,jj) |
---|
| 534 | END DO |
---|
| 535 | END DO |
---|
[6487] | 536 | ENDIF |
---|
[3479] | 537 | #else |
---|
[6487] | 538 | IF( before ) THEN |
---|
| 539 | DO jj= j1, j2 |
---|
| 540 | DO ji= i1, i2 |
---|
| 541 | IF( umask(ji,jj,1) == 0. ) THEN |
---|
| 542 | tabres(ji,jj) = -9999. |
---|
| 543 | ELSE |
---|
| 544 | tabres(ji,jj) = e2u(ji,jj) * u_ice(ji,jj) |
---|
| 545 | ENDIF |
---|
| 546 | END DO |
---|
[3479] | 547 | END DO |
---|
[6823] | 548 | ELSE |
---|
| 549 | DO jj= j1, j2 |
---|
| 550 | DO ji= i1, i2 |
---|
| 551 | uice_agr(ji,jj) = tabres(ji,jj) |
---|
| 552 | END DO |
---|
| 553 | END DO |
---|
[6487] | 554 | ENDIF |
---|
[3479] | 555 | #endif |
---|
| 556 | END SUBROUTINE interp_u_ice |
---|
| 557 | |
---|
| 558 | |
---|
[6487] | 559 | SUBROUTINE interp_v_ice( tabres, i1, i2, j1, j2, before ) |
---|
[3479] | 560 | !!----------------------------------------------------------------------- |
---|
| 561 | !! *** ROUTINE interp_v_ice *** |
---|
| 562 | !!----------------------------------------------------------------------- |
---|
| 563 | INTEGER, INTENT(in) :: i1, i2, j1, j2 |
---|
| 564 | REAL(wp), DIMENSION(i1:i2,j1:j2), INTENT(inout) :: tabres |
---|
[6487] | 565 | LOGICAL, INTENT(in) :: before |
---|
[3479] | 566 | !! |
---|
| 567 | INTEGER :: ji, jj |
---|
| 568 | !!----------------------------------------------------------------------- |
---|
| 569 | ! |
---|
| 570 | #if defined key_lim2_vp |
---|
[6487] | 571 | IF( before ) THEN |
---|
| 572 | DO jj=MAX(j1,2),j2 |
---|
| 573 | DO ji=MAX(i1,2),i2 |
---|
| 574 | IF( tmu(ji,jj) == 0. ) THEN |
---|
| 575 | tabres(ji,jj) = -9999. |
---|
| 576 | ELSE |
---|
| 577 | tabres(ji,jj) = e1f(ji-1,jj-1) * v_ice(ji,jj) |
---|
| 578 | ENDIF |
---|
| 579 | END DO |
---|
[3479] | 580 | END DO |
---|
[6823] | 581 | ELSE |
---|
| 582 | DO jj=MAX(j1,2),j2 |
---|
| 583 | DO ji=MAX(i1,2),i2 |
---|
| 584 | vice_agr(ji,jj) = tabres(ji,jj) |
---|
| 585 | END DO |
---|
| 586 | END DO |
---|
[6487] | 587 | ENDIF |
---|
[3479] | 588 | #else |
---|
[6487] | 589 | IF( before ) THEN |
---|
| 590 | DO jj= j1 ,j2 |
---|
| 591 | DO ji = i1, i2 |
---|
| 592 | IF( vmask(ji,jj,1) == 0. ) THEN |
---|
| 593 | tabres(ji,jj) = -9999. |
---|
| 594 | ELSE |
---|
| 595 | tabres(ji,jj) = e1v(ji,jj) * v_ice(ji,jj) |
---|
| 596 | ENDIF |
---|
| 597 | END DO |
---|
| 598 | END DO |
---|
[6823] | 599 | ELSE |
---|
| 600 | DO jj= j1 ,j2 |
---|
| 601 | DO ji = i1, i2 |
---|
| 602 | vice_agr(ji,jj) = tabres(ji,jj) |
---|
| 603 | END DO |
---|
| 604 | END DO |
---|
[6487] | 605 | ENDIF |
---|
[3479] | 606 | #endif |
---|
| 607 | END SUBROUTINE interp_v_ice |
---|
| 608 | |
---|
| 609 | |
---|
[6823] | 610 | SUBROUTINE interp_adv_ice( tabres, i1, i2, j1, j2, k1, k2, before ) |
---|
[3479] | 611 | !!----------------------------------------------------------------------- |
---|
| 612 | !! *** ROUTINE interp_adv_ice *** |
---|
| 613 | !! |
---|
| 614 | !! ** Purpose : fill an array with ice variables |
---|
| 615 | !! to be advected |
---|
| 616 | !! put -9999 where no ice for correct extrapolation |
---|
| 617 | !!----------------------------------------------------------------------- |
---|
[6823] | 618 | INTEGER, INTENT(in) :: i1, i2, j1, j2, k1, k2 |
---|
| 619 | REAL(wp), DIMENSION(i1:i2,j1:j2,k1:k2), INTENT(inout) :: tabres |
---|
[6487] | 620 | LOGICAL, INTENT(in) :: before |
---|
[3479] | 621 | !! |
---|
| 622 | INTEGER :: ji, jj, jk |
---|
| 623 | !!----------------------------------------------------------------------- |
---|
| 624 | ! |
---|
[6487] | 625 | IF( before ) THEN |
---|
[6823] | 626 | DO jj=j1,j2 |
---|
| 627 | DO ji=i1,i2 |
---|
| 628 | IF( tms(ji,jj) == 0. ) THEN |
---|
| 629 | tabres(ji,jj,:) = -9999 |
---|
| 630 | ELSE |
---|
| 631 | tabres(ji,jj, 1) = frld (ji,jj) |
---|
| 632 | tabres(ji,jj, 2) = hicif (ji,jj) |
---|
| 633 | tabres(ji,jj, 3) = hsnif (ji,jj) |
---|
| 634 | tabres(ji,jj, 4) = tbif (ji,jj,1) |
---|
| 635 | tabres(ji,jj, 5) = tbif (ji,jj,2) |
---|
| 636 | tabres(ji,jj, 6) = tbif (ji,jj,3) |
---|
| 637 | tabres(ji,jj, 7) = qstoif(ji,jj) |
---|
| 638 | ENDIF |
---|
| 639 | END DO |
---|
| 640 | END DO |
---|
| 641 | ELSE |
---|
| 642 | DO jj=j1,j2 |
---|
| 643 | DO ji=i1,i2 |
---|
| 644 | DO jk=k1, k2 |
---|
| 645 | tabice_agr(ji,jj,jk) = tabres(ji,jj,jk) |
---|
| 646 | END DO |
---|
| 647 | END DO |
---|
| 648 | END DO |
---|
[6487] | 649 | ENDIF |
---|
[3479] | 650 | ! |
---|
| 651 | END SUBROUTINE interp_adv_ice |
---|
| 652 | |
---|
| 653 | #else |
---|
| 654 | CONTAINS |
---|
| 655 | SUBROUTINE agrif_lim2_interp_empty |
---|
| 656 | !!--------------------------------------------- |
---|
| 657 | !! *** ROUTINE agrif_lim2_interp_empty *** |
---|
| 658 | !!--------------------------------------------- |
---|
| 659 | WRITE(*,*) 'agrif_lim2_interp : You should not have seen this print! error?' |
---|
| 660 | END SUBROUTINE agrif_lim2_interp_empty |
---|
| 661 | #endif |
---|
| 662 | END MODULE agrif_lim2_interp |
---|