Changeset 13469
- Timestamp:
- 2020-09-15T12:49:18+02:00 (4 years ago)
- Location:
- NEMO/branches/2020/temporary_r4_trunk
- Files:
-
- 32 edited
Legend:
- Unmodified
- Added
- Removed
-
NEMO/branches/2020/temporary_r4_trunk/src/ICE/icealb.F90
r13466 r13469 122 122 ! 123 123 DO jl = 1, jpl 124 DO jj = 1, jpj 125 DO ji = 1, jpi 126 ! 127 !---------------------------------------------! 128 !--- Specific snow, ice and pond fractions ---! 129 !---------------------------------------------! 130 zafrac_snw = za_s_fra(ji,jj,jl) 131 IF( ld_pnd_alb ) THEN 132 zafrac_pnd = MIN( pafrac_pnd(ji,jj,jl), 1._wp - zafrac_snw ) ! make sure (a_ip_eff + a_s_fra) <= 1 133 ELSE 134 zafrac_pnd = 0._wp 135 ENDIF 136 zafrac_ice = MAX( 0._wp, 1._wp - zafrac_pnd - zafrac_snw ) ! max for roundoff errors 137 ! 138 !---------------! 139 !--- Albedos ---! 140 !---------------! 141 ! !--- Bare ice albedo (for hi > 150cm) 142 IF( ld_pnd_alb ) THEN 143 zalb_ice = rn_alb_idry 144 ELSE 145 IF( ph_snw(ji,jj,jl) == 0._wp .AND. pt_su(ji,jj,jl) >= rt0 ) THEN ; zalb_ice = rn_alb_imlt 146 ELSE ; zalb_ice = rn_alb_idry ; ENDIF 147 ENDIF 148 ! !--- Bare ice albedo (for hi < 150cm) 149 IF( 0.05 < ph_ice(ji,jj,jl) .AND. ph_ice(ji,jj,jl) <= 1.5 ) THEN ! 5cm < hi < 150cm 150 zalb_ice = zalb_ice + ( 0.18 - zalb_ice ) * z1_c1 * ( LOG(1.5) - LOG(ph_ice(ji,jj,jl)) ) 151 ELSEIF( ph_ice(ji,jj,jl) <= 0.05 ) THEN ! 0cm < hi < 5cm 152 zalb_ice = rn_alb_oce + ( 0.18 - rn_alb_oce ) * z1_c2 * ph_ice(ji,jj,jl) 153 ENDIF 154 ! 155 ! !--- Snow-covered ice albedo (freezing, melting cases) 156 IF( pt_su(ji,jj,jl) < rt0 ) THEN 157 zalb_snw = rn_alb_sdry - ( rn_alb_sdry - zalb_ice ) * EXP( - ph_snw(ji,jj,jl) * z1_c3 ) 158 ELSE 159 zalb_snw = rn_alb_smlt - ( rn_alb_smlt - zalb_ice ) * EXP( - ph_snw(ji,jj,jl) * z1_c4 ) 160 ENDIF 161 ! !--- Ponded ice albedo 162 zalb_pnd = rn_alb_dpnd - ( rn_alb_dpnd - zalb_ice ) * EXP( - ph_pnd(ji,jj,jl) * z1_href_pnd ) 163 ! 164 ! !--- Surface albedo is weighted mean of snow, ponds and bare ice contributions 165 zalb_os = ( zafrac_snw * zalb_snw + zafrac_pnd * zalb_pnd + zafrac_ice * zalb_ice ) * tmask(ji,jj,1) 166 ! 167 zalb_cs = zalb_os - ( - 0.1010 * zalb_os * zalb_os & 168 & + 0.1933 * zalb_os - 0.0148 ) * tmask(ji,jj,1) 169 ! 170 ! albedo depends on cloud fraction because of non-linear spectral effects 171 palb_ice(ji,jj,jl) = ( 1._wp - pcloud_fra(ji,jj) ) * zalb_cs + pcloud_fra(ji,jj) * zalb_os 172 173 END DO 174 END DO 124 DO_2D_11_11 125 ! 126 !---------------------------------------------! 127 !--- Specific snow, ice and pond fractions ---! 128 !---------------------------------------------! 129 zafrac_snw = za_s_fra(ji,jj,jl) 130 IF( ld_pnd_alb ) THEN 131 zafrac_pnd = MIN( pafrac_pnd(ji,jj,jl), 1._wp - zafrac_snw ) ! make sure (a_ip_eff + a_s_fra) <= 1 132 ELSE 133 zafrac_pnd = 0._wp 134 ENDIF 135 zafrac_ice = MAX( 0._wp, 1._wp - zafrac_pnd - zafrac_snw ) ! max for roundoff errors 136 ! 137 !---------------! 138 !--- Albedos ---! 139 !---------------! 140 ! !--- Bare ice albedo (for hi > 150cm) 141 IF( ld_pnd_alb ) THEN 142 zalb_ice = rn_alb_idry 143 ELSE 144 IF( ph_snw(ji,jj,jl) == 0._wp .AND. pt_su(ji,jj,jl) >= rt0 ) THEN ; zalb_ice = rn_alb_imlt 145 ELSE ; zalb_ice = rn_alb_idry ; ENDIF 146 ENDIF 147 ! !--- Bare ice albedo (for hi < 150cm) 148 IF( 0.05 < ph_ice(ji,jj,jl) .AND. ph_ice(ji,jj,jl) <= 1.5 ) THEN ! 5cm < hi < 150cm 149 zalb_ice = zalb_ice + ( 0.18 - zalb_ice ) * z1_c1 * ( LOG(1.5) - LOG(ph_ice(ji,jj,jl)) ) 150 ELSEIF( ph_ice(ji,jj,jl) <= 0.05 ) THEN ! 0cm < hi < 5cm 151 zalb_ice = rn_alb_oce + ( 0.18 - rn_alb_oce ) * z1_c2 * ph_ice(ji,jj,jl) 152 ENDIF 153 ! 154 ! !--- Snow-covered ice albedo (freezing, melting cases) 155 IF( pt_su(ji,jj,jl) < rt0 ) THEN 156 zalb_snw = rn_alb_sdry - ( rn_alb_sdry - zalb_ice ) * EXP( - ph_snw(ji,jj,jl) * z1_c3 ) 157 ELSE 158 zalb_snw = rn_alb_smlt - ( rn_alb_smlt - zalb_ice ) * EXP( - ph_snw(ji,jj,jl) * z1_c4 ) 159 ENDIF 160 ! !--- Ponded ice albedo 161 zalb_pnd = rn_alb_dpnd - ( rn_alb_dpnd - zalb_ice ) * EXP( - ph_pnd(ji,jj,jl) * z1_href_pnd ) 162 ! 163 ! !--- Surface albedo is weighted mean of snow, ponds and bare ice contributions 164 zalb_os = ( zafrac_snw * zalb_snw + zafrac_pnd * zalb_pnd + zafrac_ice * zalb_ice ) * tmask(ji,jj,1) 165 ! 166 zalb_cs = zalb_os - ( - 0.1010 * zalb_os * zalb_os & 167 & + 0.1933 * zalb_os - 0.0148 ) * tmask(ji,jj,1) 168 ! 169 ! albedo depends on cloud fraction because of non-linear spectral effects 170 palb_ice(ji,jj,jl) = ( 1._wp - pcloud_fra(ji,jj) ) * zalb_cs + pcloud_fra(ji,jj) * zalb_os 171 172 END_2D 175 173 END DO 176 174 ! -
NEMO/branches/2020/temporary_r4_trunk/src/ICE/icecor.F90
r13466 r13469 92 92 zzc = rhoi * r1_rdtice 93 93 DO jl = 1, jpl 94 DO jj = 1, jpj 95 DO ji = 1, jpi 96 zsal = sv_i(ji,jj,jl) 97 sv_i(ji,jj,jl) = MIN( MAX( rn_simin*v_i(ji,jj,jl) , sv_i(ji,jj,jl) ) , rn_simax*v_i(ji,jj,jl) ) 98 sfx_res(ji,jj) = sfx_res(ji,jj) - ( sv_i(ji,jj,jl) - zsal ) * zzc ! associated salt flux 99 END DO 100 END DO 94 DO_2D_11_11 95 zsal = sv_i(ji,jj,jl) 96 sv_i(ji,jj,jl) = MIN( MAX( rn_simin*v_i(ji,jj,jl) , sv_i(ji,jj,jl) ) , rn_simax*v_i(ji,jj,jl) ) 97 sfx_res(ji,jj) = sfx_res(ji,jj) - ( sv_i(ji,jj,jl) - zsal ) * zzc ! associated salt flux 98 END_2D 101 99 END DO 102 100 ENDIF … … 107 105 ! !----------------------------------------------------- 108 106 IF( kn == 2 ) THEN ! Ice drift case: Corrections to avoid wrong values ! 109 DO jj = 2, jpjm1 !----------------------------------------------------- 110 DO ji = 2, jpim1 111 IF ( at_i(ji,jj) == 0._wp ) THEN ! what to do if there is no ice 112 IF ( at_i(ji+1,jj) == 0._wp ) u_ice(ji ,jj) = 0._wp ! right side 113 IF ( at_i(ji-1,jj) == 0._wp ) u_ice(ji-1,jj) = 0._wp ! left side 114 IF ( at_i(ji,jj+1) == 0._wp ) v_ice(ji,jj ) = 0._wp ! upper side 115 IF ( at_i(ji,jj-1) == 0._wp ) v_ice(ji,jj-1) = 0._wp ! bottom side 116 ENDIF 117 END DO 118 END DO 107 DO_2D_00_00 108 IF ( at_i(ji,jj) == 0._wp ) THEN ! what to do if there is no ice 109 IF ( at_i(ji+1,jj) == 0._wp ) u_ice(ji ,jj) = 0._wp ! right side 110 IF ( at_i(ji-1,jj) == 0._wp ) u_ice(ji-1,jj) = 0._wp ! left side 111 IF ( at_i(ji,jj+1) == 0._wp ) v_ice(ji,jj ) = 0._wp ! upper side 112 IF ( at_i(ji,jj-1) == 0._wp ) v_ice(ji,jj-1) = 0._wp ! bottom side 113 ENDIF 114 END_2D 119 115 CALL lbc_lnk_multi( 'icecor', u_ice, 'U', -1., v_ice, 'V', -1. ) 120 116 ENDIF -
NEMO/branches/2020/temporary_r4_trunk/src/ICE/icectl.F90
r13466 r13469 366 366 cl_alname(ialert_id) = ' Very high salinity ' ! name of the alert 367 367 DO jl = 1, jpl 368 DO jj = 1, jpj 369 DO ji = 1, jpi 370 IF( v_i(ji,jj,jl) > epsi10 ) THEN 371 IF( sv_i(ji,jj,jl) / v_i(ji,jj,jl) > rn_simax ) THEN 372 WRITE(numout,*) ' ALERTE : Very high salinity ',sv_i(ji,jj,jl)/v_i(ji,jj,jl) 373 WRITE(numout,*) ' at i,j,l = ',ji,jj,jl 374 inb_alp(ialert_id) = inb_alp(ialert_id) + 1 375 ENDIF 368 DO_2D_11_11 369 IF( v_i(ji,jj,jl) > epsi10 ) THEN 370 IF( sv_i(ji,jj,jl) / v_i(ji,jj,jl) > rn_simax ) THEN 371 WRITE(numout,*) ' ALERTE : Very high salinity ',sv_i(ji,jj,jl)/v_i(ji,jj,jl) 372 WRITE(numout,*) ' at i,j,l = ',ji,jj,jl 373 inb_alp(ialert_id) = inb_alp(ialert_id) + 1 376 374 ENDIF 377 END DO378 END DO375 ENDIF 376 END_2D 379 377 END DO 380 378 … … 383 381 cl_alname(ialert_id) = ' Very low salinity ' ! name of the alert 384 382 DO jl = 1, jpl 385 DO jj = 1, jpj 386 DO ji = 1, jpi 387 IF( v_i(ji,jj,jl) > epsi10 ) THEN 388 IF( sv_i(ji,jj,jl) / v_i(ji,jj,jl) < rn_simin ) THEN 389 WRITE(numout,*) ' ALERTE : Very low salinity ',sv_i(ji,jj,jl),v_i(ji,jj,jl) 390 WRITE(numout,*) ' at i,j,l = ',ji,jj,jl 391 inb_alp(ialert_id) = inb_alp(ialert_id) + 1 392 ENDIF 383 DO_2D_11_11 384 IF( v_i(ji,jj,jl) > epsi10 ) THEN 385 IF( sv_i(ji,jj,jl) / v_i(ji,jj,jl) < rn_simin ) THEN 386 WRITE(numout,*) ' ALERTE : Very low salinity ',sv_i(ji,jj,jl),v_i(ji,jj,jl) 387 WRITE(numout,*) ' at i,j,l = ',ji,jj,jl 388 inb_alp(ialert_id) = inb_alp(ialert_id) + 1 393 389 ENDIF 394 END DO395 END DO390 ENDIF 391 END_2D 396 392 END DO 397 393 … … 400 396 cl_alname(ialert_id) = ' Very cold ice ' ! name of the alert 401 397 DO jl = 1, jpl 402 DO jk = 1, nlay_i 403 DO jj = 1, jpj 404 DO ji = 1, jpi 405 ztmelts = -rTmlt * sz_i(ji,jj,jk,jl) + rt0 406 IF( t_i(ji,jj,jk,jl) < -50.+rt0 .AND. v_i(ji,jj,jl) > epsi10 ) THEN 407 WRITE(numout,*) ' ALERTE : Very cold ice ',(t_i(ji,jj,jk,jl)-rt0) 408 WRITE(numout,*) ' at i,j,k,l = ',ji,jj,jk,jl 409 inb_alp(ialert_id) = inb_alp(ialert_id) + 1 410 ENDIF 411 END DO 412 END DO 413 END DO 398 DO_3D_11_11( 1, nlay_i ) 399 ztmelts = -rTmlt * sz_i(ji,jj,jk,jl) + rt0 400 IF( t_i(ji,jj,jk,jl) < -50.+rt0 .AND. v_i(ji,jj,jl) > epsi10 ) THEN 401 WRITE(numout,*) ' ALERTE : Very cold ice ',(t_i(ji,jj,jk,jl)-rt0) 402 WRITE(numout,*) ' at i,j,k,l = ',ji,jj,jk,jl 403 inb_alp(ialert_id) = inb_alp(ialert_id) + 1 404 ENDIF 405 END_3D 414 406 END DO 415 407 … … 418 410 cl_alname(ialert_id) = ' Very warm ice ' ! name of the alert 419 411 DO jl = 1, jpl 420 DO jk = 1, nlay_i 421 DO jj = 1, jpj 422 DO ji = 1, jpi 423 ztmelts = -rTmlt * sz_i(ji,jj,jk,jl) + rt0 424 IF( t_i(ji,jj,jk,jl) > ztmelts .AND. v_i(ji,jj,jl) > epsi10 ) THEN 425 WRITE(numout,*) ' ALERTE : Very warm ice',(t_i(ji,jj,jk,jl)-rt0) 426 WRITE(numout,*) ' at i,j,k,l = ',ji,jj,jk,jl 427 inb_alp(ialert_id) = inb_alp(ialert_id) + 1 428 ENDIF 429 END DO 430 END DO 431 END DO 412 DO_3D_11_11( 1, nlay_i ) 413 ztmelts = -rTmlt * sz_i(ji,jj,jk,jl) + rt0 414 IF( t_i(ji,jj,jk,jl) > ztmelts .AND. v_i(ji,jj,jl) > epsi10 ) THEN 415 WRITE(numout,*) ' ALERTE : Very warm ice',(t_i(ji,jj,jk,jl)-rt0) 416 WRITE(numout,*) ' at i,j,k,l = ',ji,jj,jk,jl 417 inb_alp(ialert_id) = inb_alp(ialert_id) + 1 418 ENDIF 419 END_3D 432 420 END DO 433 421 … … 436 424 cl_alname(ialert_id) = ' Very thick ice ' ! name of the alert 437 425 jl = jpl 438 DO jj = 1, jpj 439 DO ji = 1, jpi 440 IF( h_i(ji,jj,jl) > 50._wp ) THEN 441 WRITE(numout,*) ' ALERTE : Very thick ice ',h_i(ji,jj,jl) 442 WRITE(numout,*) ' at i,j,l = ',ji,jj,jl 443 inb_alp(ialert_id) = inb_alp(ialert_id) + 1 444 ENDIF 445 END DO 446 END DO 426 DO_2D_11_11 427 IF( h_i(ji,jj,jl) > 50._wp ) THEN 428 WRITE(numout,*) ' ALERTE : Very thick ice ',h_i(ji,jj,jl) 429 WRITE(numout,*) ' at i,j,l = ',ji,jj,jl 430 inb_alp(ialert_id) = inb_alp(ialert_id) + 1 431 ENDIF 432 END_2D 447 433 448 434 ! Alerte if very thin ice … … 450 436 cl_alname(ialert_id) = ' Very thin ice ' ! name of the alert 451 437 jl = 1 452 DO jj = 1, jpj 453 DO ji = 1, jpi 454 IF( h_i(ji,jj,jl) < rn_himin ) THEN 455 WRITE(numout,*) ' ALERTE : Very thin ice ',h_i(ji,jj,jl) 456 WRITE(numout,*) ' at i,j,l = ',ji,jj,jl 457 inb_alp(ialert_id) = inb_alp(ialert_id) + 1 458 ENDIF 459 END DO 460 END DO 438 DO_2D_11_11 439 IF( h_i(ji,jj,jl) < rn_himin ) THEN 440 WRITE(numout,*) ' ALERTE : Very thin ice ',h_i(ji,jj,jl) 441 WRITE(numout,*) ' at i,j,l = ',ji,jj,jl 442 inb_alp(ialert_id) = inb_alp(ialert_id) + 1 443 ENDIF 444 END_2D 461 445 462 446 ! Alert if very fast ice 463 447 ialert_id = ialert_id + 1 ! reference number of this alert 464 448 cl_alname(ialert_id) = ' Very fast ice ' ! name of the alert 465 DO jj = 1, jpj 466 DO ji = 1, jpi 467 IF( MAX( ABS( u_ice(ji,jj) ), ABS( v_ice(ji,jj) ) ) > 2. ) THEN 468 WRITE(numout,*) ' ALERTE : Very fast ice ',MAX( ABS( u_ice(ji,jj) ), ABS( v_ice(ji,jj) ) ) 469 WRITE(numout,*) ' at i,j = ',ji,jj 470 inb_alp(ialert_id) = inb_alp(ialert_id) + 1 471 ENDIF 472 END DO 473 END DO 449 DO_2D_11_11 450 IF( MAX( ABS( u_ice(ji,jj) ), ABS( v_ice(ji,jj) ) ) > 2. ) THEN 451 WRITE(numout,*) ' ALERTE : Very fast ice ',MAX( ABS( u_ice(ji,jj) ), ABS( v_ice(ji,jj) ) ) 452 WRITE(numout,*) ' at i,j = ',ji,jj 453 inb_alp(ialert_id) = inb_alp(ialert_id) + 1 454 ENDIF 455 END_2D 474 456 475 457 ! Alert if there is ice on continents 476 458 ialert_id = ialert_id + 1 ! reference number of this alert 477 459 cl_alname(ialert_id) = ' Ice on continents ' ! name of the alert 478 DO jj = 1, jpj 479 DO ji = 1, jpi 480 IF( tmask(ji,jj,1) == 0._wp .AND. ( at_i(ji,jj) > 0._wp .OR. vt_i(ji,jj) > 0._wp ) ) THEN 481 WRITE(numout,*) ' ALERTE : Ice on continents ',at_i(ji,jj),vt_i(ji,jj) 482 WRITE(numout,*) ' at i,j = ',ji,jj 483 inb_alp(ialert_id) = inb_alp(ialert_id) + 1 484 ENDIF 485 END DO 486 END DO 460 DO_2D_11_11 461 IF( tmask(ji,jj,1) == 0._wp .AND. ( at_i(ji,jj) > 0._wp .OR. vt_i(ji,jj) > 0._wp ) ) THEN 462 WRITE(numout,*) ' ALERTE : Ice on continents ',at_i(ji,jj),vt_i(ji,jj) 463 WRITE(numout,*) ' at i,j = ',ji,jj 464 inb_alp(ialert_id) = inb_alp(ialert_id) + 1 465 ENDIF 466 END_2D 487 467 488 468 ! Alert if incompatible ice concentration and volume 489 469 ialert_id = ialert_id + 1 ! reference number of this alert 490 470 cl_alname(ialert_id) = ' Incompatible ice conc and vol ' ! name of the alert 491 DO jj = 1, jpj 492 DO ji = 1, jpi 493 IF( ( vt_i(ji,jj) == 0._wp .AND. at_i(ji,jj) > 0._wp ) .OR. & 494 & ( vt_i(ji,jj) > 0._wp .AND. at_i(ji,jj) == 0._wp ) ) THEN 495 WRITE(numout,*) ' ALERTE : Incompatible ice conc and vol ',at_i(ji,jj),vt_i(ji,jj) 496 WRITE(numout,*) ' at i,j = ',ji,jj 497 inb_alp(ialert_id) = inb_alp(ialert_id) + 1 498 ENDIF 499 END DO 500 END DO 471 DO_2D_11_11 472 IF( ( vt_i(ji,jj) == 0._wp .AND. at_i(ji,jj) > 0._wp ) .OR. & 473 & ( vt_i(ji,jj) > 0._wp .AND. at_i(ji,jj) == 0._wp ) ) THEN 474 WRITE(numout,*) ' ALERTE : Incompatible ice conc and vol ',at_i(ji,jj),vt_i(ji,jj) 475 WRITE(numout,*) ' at i,j = ',ji,jj 476 inb_alp(ialert_id) = inb_alp(ialert_id) + 1 477 ENDIF 478 END_2D 501 479 502 480 ! sum of the alerts on all processors -
NEMO/branches/2020/temporary_r4_trunk/src/ICE/icedyn.F90
r13466 r13469 127 127 ! CFL = 0.5 at a distance from the bound of 1/6 of the basin length 128 128 ! Then for dx = 2m and dt = 1s => rn_uice = u (1/6th) = 1m/s 129 DO jj = 1, jpj 130 DO ji = 1, jpi 131 zcoefu = ( REAL(jpiglo+1)*0.5 - REAL(ji+nimpp-1) ) / ( REAL(jpiglo+1)*0.5 - 1. ) 132 zcoefv = ( REAL(jpjglo+1)*0.5 - REAL(jj+njmpp-1) ) / ( REAL(jpjglo+1)*0.5 - 1. ) 133 u_ice(ji,jj) = rn_uice * 1.5 * SIGN( 1., zcoefu ) * ABS( zcoefu ) * umask(ji,jj,1) 134 v_ice(ji,jj) = rn_vice * 1.5 * SIGN( 1., zcoefv ) * ABS( zcoefv ) * vmask(ji,jj,1) 135 END DO 136 END DO 129 DO_2D_11_11 130 zcoefu = ( REAL(jpiglo+1)*0.5 - REAL(ji+nimpp-1) ) / ( REAL(jpiglo+1)*0.5 - 1. ) 131 zcoefv = ( REAL(jpjglo+1)*0.5 - REAL(jj+njmpp-1) ) / ( REAL(jpjglo+1)*0.5 - 1. ) 132 u_ice(ji,jj) = rn_uice * 1.5 * SIGN( 1., zcoefu ) * ABS( zcoefu ) * umask(ji,jj,1) 133 v_ice(ji,jj) = rn_vice * 1.5 * SIGN( 1., zcoefv ) * ABS( zcoefv ) * vmask(ji,jj,1) 134 END_2D 137 135 ! --- 138 136 CALL ice_dyn_adv ( kt ) ! -- advection of ice … … 158 156 159 157 ALLOCATE( zdivu_i(jpi,jpj) ) 160 DO jj = 2, jpjm1 161 DO ji = 2, jpim1 162 zdivu_i(ji,jj) = ( e2u(ji,jj) * u_ice(ji,jj) - e2u(ji-1,jj) * u_ice(ji-1,jj) & 163 & + e1v(ji,jj) * v_ice(ji,jj) - e1v(ji,jj-1) * v_ice(ji,jj-1) ) * r1_e1e2t(ji,jj) 164 END DO 165 END DO 158 DO_2D_00_00 159 zdivu_i(ji,jj) = ( e2u(ji,jj) * u_ice(ji,jj) - e2u(ji-1,jj) * u_ice(ji-1,jj) & 160 & + e1v(ji,jj) * v_ice(ji,jj) - e1v(ji,jj-1) * v_ice(ji,jj-1) ) * r1_e1e2t(ji,jj) 161 END_2D 166 162 CALL lbc_lnk( 'icedyn', zdivu_i, 'T', 1. ) 167 163 ! output -
NEMO/branches/2020/temporary_r4_trunk/src/ICE/icedyn_adv_pra.F90
r13466 r13469 110 110 END WHERE 111 111 DO jl = 1, jpl 112 DO jj = 2, jpjm1 113 DO ji = fs_2, fs_jpim1 114 zhip_max(ji,jj,jl) = MAX( epsi20, ph_ip(ji,jj,jl), ph_ip(ji+1,jj ,jl), ph_ip(ji ,jj+1,jl), & 115 & ph_ip(ji-1,jj ,jl), ph_ip(ji ,jj-1,jl), & 116 & ph_ip(ji+1,jj+1,jl), ph_ip(ji-1,jj-1,jl), & 117 & ph_ip(ji+1,jj-1,jl), ph_ip(ji-1,jj+1,jl) ) 118 zhi_max (ji,jj,jl) = MAX( epsi20, ph_i (ji,jj,jl), ph_i (ji+1,jj ,jl), ph_i (ji ,jj+1,jl), & 119 & ph_i (ji-1,jj ,jl), ph_i (ji ,jj-1,jl), & 120 & ph_i (ji+1,jj+1,jl), ph_i (ji-1,jj-1,jl), & 121 & ph_i (ji+1,jj-1,jl), ph_i (ji-1,jj+1,jl) ) 122 zhs_max (ji,jj,jl) = MAX( epsi20, ph_s (ji,jj,jl), ph_s (ji+1,jj ,jl), ph_s (ji ,jj+1,jl), & 123 & ph_s (ji-1,jj ,jl), ph_s (ji ,jj-1,jl), & 124 & ph_s (ji+1,jj+1,jl), ph_s (ji-1,jj-1,jl), & 125 & ph_s (ji+1,jj-1,jl), ph_s (ji-1,jj+1,jl) ) 126 zsi_max (ji,jj,jl) = MAX( epsi20, zs_i (ji,jj,jl), zs_i (ji+1,jj ,jl), zs_i (ji ,jj+1,jl), & 127 & zs_i (ji-1,jj ,jl), zs_i (ji ,jj-1,jl), & 128 & zs_i (ji+1,jj+1,jl), zs_i (ji-1,jj-1,jl), & 129 & zs_i (ji+1,jj-1,jl), zs_i (ji-1,jj+1,jl) ) 130 END DO 131 END DO 112 DO_2D_00_00 113 zhip_max(ji,jj,jl) = MAX( epsi20, ph_ip(ji,jj,jl), ph_ip(ji+1,jj ,jl), ph_ip(ji ,jj+1,jl), & 114 & ph_ip(ji-1,jj ,jl), ph_ip(ji ,jj-1,jl), & 115 & ph_ip(ji+1,jj+1,jl), ph_ip(ji-1,jj-1,jl), & 116 & ph_ip(ji+1,jj-1,jl), ph_ip(ji-1,jj+1,jl) ) 117 zhi_max (ji,jj,jl) = MAX( epsi20, ph_i (ji,jj,jl), ph_i (ji+1,jj ,jl), ph_i (ji ,jj+1,jl), & 118 & ph_i (ji-1,jj ,jl), ph_i (ji ,jj-1,jl), & 119 & ph_i (ji+1,jj+1,jl), ph_i (ji-1,jj-1,jl), & 120 & ph_i (ji+1,jj-1,jl), ph_i (ji-1,jj+1,jl) ) 121 zhs_max (ji,jj,jl) = MAX( epsi20, ph_s (ji,jj,jl), ph_s (ji+1,jj ,jl), ph_s (ji ,jj+1,jl), & 122 & ph_s (ji-1,jj ,jl), ph_s (ji ,jj-1,jl), & 123 & ph_s (ji+1,jj+1,jl), ph_s (ji-1,jj-1,jl), & 124 & ph_s (ji+1,jj-1,jl), ph_s (ji-1,jj+1,jl) ) 125 zsi_max (ji,jj,jl) = MAX( epsi20, zs_i (ji,jj,jl), zs_i (ji+1,jj ,jl), zs_i (ji ,jj+1,jl), & 126 & zs_i (ji-1,jj ,jl), zs_i (ji ,jj-1,jl), & 127 & zs_i (ji+1,jj+1,jl), zs_i (ji-1,jj-1,jl), & 128 & zs_i (ji+1,jj-1,jl), zs_i (ji-1,jj+1,jl) ) 129 END_2D 132 130 END DO 133 131 CALL lbc_lnk_multi( 'icedyn_adv_pra', zhi_max, 'T', 1., zhs_max, 'T', 1., zhip_max, 'T', 1., zsi_max, 'T', 1. ) … … 145 143 END DO 146 144 DO jl = 1, jpl 147 DO jk = 1, nlay_i 148 DO jj = 2, jpjm1 149 DO ji = fs_2, fs_jpim1 150 zei_max(ji,jj,jk,jl) = MAX( epsi20, ze_i(ji,jj,jk,jl), ze_i(ji+1,jj ,jk,jl), ze_i(ji ,jj+1,jk,jl), & 151 & ze_i(ji-1,jj ,jk,jl), ze_i(ji ,jj-1,jk,jl), & 152 & ze_i(ji+1,jj+1,jk,jl), ze_i(ji-1,jj-1,jk,jl), & 153 & ze_i(ji+1,jj-1,jk,jl), ze_i(ji-1,jj+1,jk,jl) ) 154 END DO 155 END DO 156 END DO 145 DO_3D_00_00( 1, nlay_i ) 146 zei_max(ji,jj,jk,jl) = MAX( epsi20, ze_i(ji,jj,jk,jl), ze_i(ji+1,jj ,jk,jl), ze_i(ji ,jj+1,jk,jl), & 147 & ze_i(ji-1,jj ,jk,jl), ze_i(ji ,jj-1,jk,jl), & 148 & ze_i(ji+1,jj+1,jk,jl), ze_i(ji-1,jj-1,jk,jl), & 149 & ze_i(ji+1,jj-1,jk,jl), ze_i(ji-1,jj+1,jk,jl) ) 150 END_3D 157 151 END DO 158 152 DO jl = 1, jpl 159 DO jk = 1, nlay_s 160 DO jj = 2, jpjm1 161 DO ji = fs_2, fs_jpim1 162 zes_max(ji,jj,jk,jl) = MAX( epsi20, ze_s(ji,jj,jk,jl), ze_s(ji+1,jj ,jk,jl), ze_s(ji ,jj+1,jk,jl), & 163 & ze_s(ji-1,jj ,jk,jl), ze_s(ji ,jj-1,jk,jl), & 164 & ze_s(ji+1,jj+1,jk,jl), ze_s(ji-1,jj-1,jk,jl), & 165 & ze_s(ji+1,jj-1,jk,jl), ze_s(ji-1,jj+1,jk,jl) ) 166 END DO 167 END DO 168 END DO 153 DO_3D_00_00( 1, nlay_s ) 154 zes_max(ji,jj,jk,jl) = MAX( epsi20, ze_s(ji,jj,jk,jl), ze_s(ji+1,jj ,jk,jl), ze_s(ji ,jj+1,jk,jl), & 155 & ze_s(ji-1,jj ,jk,jl), ze_s(ji ,jj-1,jk,jl), & 156 & ze_s(ji+1,jj+1,jk,jl), ze_s(ji-1,jj-1,jk,jl), & 157 & ze_s(ji+1,jj-1,jk,jl), ze_s(ji-1,jj+1,jk,jl) ) 158 END_3D 169 159 END DO 170 160 CALL lbc_lnk( 'icedyn_adv_pra', zei_max, 'T', 1. ) … … 317 307 ! derive open water from ice concentration 318 308 zati2(:,:) = SUM( pa_i(:,:,:), dim=3 ) 319 DO jj = 2, jpjm1 320 DO ji = fs_2, fs_jpim1 321 pato_i(ji,jj) = pato_i(ji,jj) - ( zati2(ji,jj) - zati1(ji,jj) ) & !--- open water 322 & - ( zudy(ji,jj) - zudy(ji-1,jj) + zvdx(ji,jj) - zvdx(ji,jj-1) ) * r1_e1e2t(ji,jj) * zdt 323 END DO 324 END DO 309 DO_2D_00_00 310 pato_i(ji,jj) = pato_i(ji,jj) - ( zati2(ji,jj) - zati1(ji,jj) ) & !--- open water 311 & - ( zudy(ji,jj) - zudy(ji-1,jj) + zvdx(ji,jj) - zvdx(ji,jj-1) ) * r1_e1e2t(ji,jj) * zdt 312 END_2D 325 313 CALL lbc_lnk( 'icedyn_adv_pra', pato_i, 'T', 1. ) 326 314 ! … … 375 363 ! 376 364 ! Limitation of moments. 377 DO jj = 2, jpjm1 378 DO ji = 1, jpi 379 ! Initialize volumes of boxes (=area if adv_x first called, =psm otherwise) 380 psm (ji,jj,jl) = MAX( pcrh * e1e2t(ji,jj) + ( 1.0 - pcrh ) * psm(ji,jj,jl) , epsi20 ) 381 ! 382 zslpmax = MAX( 0._wp, ps0(ji,jj,jl) ) 383 zs1max = 1.5 * zslpmax 384 zs1new = MIN( zs1max, MAX( -zs1max, psx(ji,jj,jl) ) ) 385 zs2new = MIN( 2.0 * zslpmax - 0.3334 * ABS( zs1new ), & 386 & MAX( ABS( zs1new ) - zslpmax, psxx(ji,jj,jl) ) ) 387 rswitch = ( 1.0 - MAX( 0._wp, SIGN( 1._wp, -zslpmax) ) ) * tmask(ji,jj,1) ! Case of empty boxes & Apply mask 388 389 ps0 (ji,jj,jl) = zslpmax 390 psx (ji,jj,jl) = zs1new * rswitch 391 psxx(ji,jj,jl) = zs2new * rswitch 392 psy (ji,jj,jl) = psy (ji,jj,jl) * rswitch 393 psyy(ji,jj,jl) = psyy(ji,jj,jl) * rswitch 394 psxy(ji,jj,jl) = MIN( zslpmax, MAX( -zslpmax, psxy(ji,jj,jl) ) ) * rswitch 395 END DO 396 END DO 365 DO_2D_00_11 366 ! Initialize volumes of boxes (=area if adv_x first called, =psm otherwise) 367 psm (ji,jj,jl) = MAX( pcrh * e1e2t(ji,jj) + ( 1.0 - pcrh ) * psm(ji,jj,jl) , epsi20 ) 368 ! 369 zslpmax = MAX( 0._wp, ps0(ji,jj,jl) ) 370 zs1max = 1.5 * zslpmax 371 zs1new = MIN( zs1max, MAX( -zs1max, psx(ji,jj,jl) ) ) 372 zs2new = MIN( 2.0 * zslpmax - 0.3334 * ABS( zs1new ), & 373 & MAX( ABS( zs1new ) - zslpmax, psxx(ji,jj,jl) ) ) 374 rswitch = ( 1.0 - MAX( 0._wp, SIGN( 1._wp, -zslpmax) ) ) * tmask(ji,jj,1) ! Case of empty boxes & Apply mask 375 376 ps0 (ji,jj,jl) = zslpmax 377 psx (ji,jj,jl) = zs1new * rswitch 378 psxx(ji,jj,jl) = zs2new * rswitch 379 psy (ji,jj,jl) = psy (ji,jj,jl) * rswitch 380 psyy(ji,jj,jl) = psyy(ji,jj,jl) * rswitch 381 psxy(ji,jj,jl) = MIN( zslpmax, MAX( -zslpmax, psxy(ji,jj,jl) ) ) * rswitch 382 END_2D 397 383 398 384 ! Calculate fluxes and moments between boxes i<-->i+1 399 DO jj = 2, jpjm1 ! Flux from i to i+1 WHEN u GT 0 400 DO ji = 1, jpi 401 zbet(ji,jj) = MAX( 0._wp, SIGN( 1._wp, put(ji,jj) ) ) 402 zalf = MAX( 0._wp, put(ji,jj) ) * pdt / psm(ji,jj,jl) 403 zalfq = zalf * zalf 404 zalf1 = 1.0 - zalf 405 zalf1q = zalf1 * zalf1 406 ! 407 zfm (ji,jj) = zalf * psm (ji,jj,jl) 408 zf0 (ji,jj) = zalf * ( ps0 (ji,jj,jl) + zalf1 * ( psx(ji,jj,jl) + (zalf1 - zalf) * psxx(ji,jj,jl) ) ) 409 zfx (ji,jj) = zalfq * ( psx (ji,jj,jl) + 3.0 * zalf1 * psxx(ji,jj,jl) ) 410 zfxx(ji,jj) = zalf * psxx(ji,jj,jl) * zalfq 411 zfy (ji,jj) = zalf * ( psy (ji,jj,jl) + zalf1 * psxy(ji,jj,jl) ) 412 zfxy(ji,jj) = zalfq * psxy(ji,jj,jl) 413 zfyy(ji,jj) = zalf * psyy(ji,jj,jl) 414 415 ! Readjust moments remaining in the box. 416 psm (ji,jj,jl) = psm (ji,jj,jl) - zfm(ji,jj) 417 ps0 (ji,jj,jl) = ps0 (ji,jj,jl) - zf0(ji,jj) 418 psx (ji,jj,jl) = zalf1q * ( psx(ji,jj,jl) - 3.0 * zalf * psxx(ji,jj,jl) ) 419 psxx(ji,jj,jl) = zalf1 * zalf1q * psxx(ji,jj,jl) 420 psy (ji,jj,jl) = psy (ji,jj,jl) - zfy(ji,jj) 421 psyy(ji,jj,jl) = psyy(ji,jj,jl) - zfyy(ji,jj) 422 psxy(ji,jj,jl) = zalf1q * psxy(ji,jj,jl) 423 END DO 424 END DO 425 426 DO jj = 2, jpjm1 ! Flux from i+1 to i when u LT 0. 427 DO ji = 1, fs_jpim1 428 zalf = MAX( 0._wp, -put(ji,jj) ) * pdt / psm(ji+1,jj,jl) 429 zalg (ji,jj) = zalf 430 zalfq = zalf * zalf 431 zalf1 = 1.0 - zalf 432 zalg1 (ji,jj) = zalf1 433 zalf1q = zalf1 * zalf1 434 zalg1q(ji,jj) = zalf1q 435 ! 436 zfm (ji,jj) = zfm (ji,jj) + zalf * psm (ji+1,jj,jl) 437 zf0 (ji,jj) = zf0 (ji,jj) + zalf * ( ps0 (ji+1,jj,jl) & 438 & - zalf1 * ( psx(ji+1,jj,jl) - (zalf1 - zalf ) * psxx(ji+1,jj,jl) ) ) 439 zfx (ji,jj) = zfx (ji,jj) + zalfq * ( psx (ji+1,jj,jl) - 3.0 * zalf1 * psxx(ji+1,jj,jl) ) 440 zfxx (ji,jj) = zfxx(ji,jj) + zalf * psxx(ji+1,jj,jl) * zalfq 441 zfy (ji,jj) = zfy (ji,jj) + zalf * ( psy (ji+1,jj,jl) - zalf1 * psxy(ji+1,jj,jl) ) 442 zfxy (ji,jj) = zfxy(ji,jj) + zalfq * psxy(ji+1,jj,jl) 443 zfyy (ji,jj) = zfyy(ji,jj) + zalf * psyy(ji+1,jj,jl) 444 END DO 445 END DO 446 447 DO jj = 2, jpjm1 ! Readjust moments remaining in the box. 448 DO ji = fs_2, fs_jpim1 449 zbt = zbet(ji-1,jj) 450 zbt1 = 1.0 - zbet(ji-1,jj) 451 ! 452 psm (ji,jj,jl) = zbt * psm(ji,jj,jl) + zbt1 * ( psm(ji,jj,jl) - zfm(ji-1,jj) ) 453 ps0 (ji,jj,jl) = zbt * ps0(ji,jj,jl) + zbt1 * ( ps0(ji,jj,jl) - zf0(ji-1,jj) ) 454 psx (ji,jj,jl) = zalg1q(ji-1,jj) * ( psx(ji,jj,jl) + 3.0 * zalg(ji-1,jj) * psxx(ji,jj,jl) ) 455 psxx(ji,jj,jl) = zalg1 (ji-1,jj) * zalg1q(ji-1,jj) * psxx(ji,jj,jl) 456 psy (ji,jj,jl) = zbt * psy (ji,jj,jl) + zbt1 * ( psy (ji,jj,jl) - zfy (ji-1,jj) ) 457 psyy(ji,jj,jl) = zbt * psyy(ji,jj,jl) + zbt1 * ( psyy(ji,jj,jl) - zfyy(ji-1,jj) ) 458 psxy(ji,jj,jl) = zalg1q(ji-1,jj) * psxy(ji,jj,jl) 459 END DO 460 END DO 385 DO_2D_00_11 386 zbet(ji,jj) = MAX( 0._wp, SIGN( 1._wp, put(ji,jj) ) ) 387 zalf = MAX( 0._wp, put(ji,jj) ) * pdt / psm(ji,jj,jl) 388 zalfq = zalf * zalf 389 zalf1 = 1.0 - zalf 390 zalf1q = zalf1 * zalf1 391 ! 392 zfm (ji,jj) = zalf * psm (ji,jj,jl) 393 zf0 (ji,jj) = zalf * ( ps0 (ji,jj,jl) + zalf1 * ( psx(ji,jj,jl) + (zalf1 - zalf) * psxx(ji,jj,jl) ) ) 394 zfx (ji,jj) = zalfq * ( psx (ji,jj,jl) + 3.0 * zalf1 * psxx(ji,jj,jl) ) 395 zfxx(ji,jj) = zalf * psxx(ji,jj,jl) * zalfq 396 zfy (ji,jj) = zalf * ( psy (ji,jj,jl) + zalf1 * psxy(ji,jj,jl) ) 397 zfxy(ji,jj) = zalfq * psxy(ji,jj,jl) 398 zfyy(ji,jj) = zalf * psyy(ji,jj,jl) 399 400 ! Readjust moments remaining in the box. 401 psm (ji,jj,jl) = psm (ji,jj,jl) - zfm(ji,jj) 402 ps0 (ji,jj,jl) = ps0 (ji,jj,jl) - zf0(ji,jj) 403 psx (ji,jj,jl) = zalf1q * ( psx(ji,jj,jl) - 3.0 * zalf * psxx(ji,jj,jl) ) 404 psxx(ji,jj,jl) = zalf1 * zalf1q * psxx(ji,jj,jl) 405 psy (ji,jj,jl) = psy (ji,jj,jl) - zfy(ji,jj) 406 psyy(ji,jj,jl) = psyy(ji,jj,jl) - zfyy(ji,jj) 407 psxy(ji,jj,jl) = zalf1q * psxy(ji,jj,jl) 408 END_2D 409 410 DO_2D_00_10 411 zalf = MAX( 0._wp, -put(ji,jj) ) * pdt / psm(ji+1,jj,jl) 412 zalg (ji,jj) = zalf 413 zalfq = zalf * zalf 414 zalf1 = 1.0 - zalf 415 zalg1 (ji,jj) = zalf1 416 zalf1q = zalf1 * zalf1 417 zalg1q(ji,jj) = zalf1q 418 ! 419 zfm (ji,jj) = zfm (ji,jj) + zalf * psm (ji+1,jj,jl) 420 zf0 (ji,jj) = zf0 (ji,jj) + zalf * ( ps0 (ji+1,jj,jl) & 421 & - zalf1 * ( psx(ji+1,jj,jl) - (zalf1 - zalf ) * psxx(ji+1,jj,jl) ) ) 422 zfx (ji,jj) = zfx (ji,jj) + zalfq * ( psx (ji+1,jj,jl) - 3.0 * zalf1 * psxx(ji+1,jj,jl) ) 423 zfxx (ji,jj) = zfxx(ji,jj) + zalf * psxx(ji+1,jj,jl) * zalfq 424 zfy (ji,jj) = zfy (ji,jj) + zalf * ( psy (ji+1,jj,jl) - zalf1 * psxy(ji+1,jj,jl) ) 425 zfxy (ji,jj) = zfxy(ji,jj) + zalfq * psxy(ji+1,jj,jl) 426 zfyy (ji,jj) = zfyy(ji,jj) + zalf * psyy(ji+1,jj,jl) 427 END_2D 428 429 DO_2D_00_00 430 zbt = zbet(ji-1,jj) 431 zbt1 = 1.0 - zbet(ji-1,jj) 432 ! 433 psm (ji,jj,jl) = zbt * psm(ji,jj,jl) + zbt1 * ( psm(ji,jj,jl) - zfm(ji-1,jj) ) 434 ps0 (ji,jj,jl) = zbt * ps0(ji,jj,jl) + zbt1 * ( ps0(ji,jj,jl) - zf0(ji-1,jj) ) 435 psx (ji,jj,jl) = zalg1q(ji-1,jj) * ( psx(ji,jj,jl) + 3.0 * zalg(ji-1,jj) * psxx(ji,jj,jl) ) 436 psxx(ji,jj,jl) = zalg1 (ji-1,jj) * zalg1q(ji-1,jj) * psxx(ji,jj,jl) 437 psy (ji,jj,jl) = zbt * psy (ji,jj,jl) + zbt1 * ( psy (ji,jj,jl) - zfy (ji-1,jj) ) 438 psyy(ji,jj,jl) = zbt * psyy(ji,jj,jl) + zbt1 * ( psyy(ji,jj,jl) - zfyy(ji-1,jj) ) 439 psxy(ji,jj,jl) = zalg1q(ji-1,jj) * psxy(ji,jj,jl) 440 END_2D 461 441 462 442 ! Put the temporary moments into appropriate neighboring boxes. 463 DO jj = 2, jpjm1 ! Flux from i to i+1 IF u GT 0. 464 DO ji = fs_2, fs_jpim1 465 zbt = zbet(ji-1,jj) 466 zbt1 = 1.0 - zbet(ji-1,jj) 467 psm(ji,jj,jl) = zbt * ( psm(ji,jj,jl) + zfm(ji-1,jj) ) + zbt1 * psm(ji,jj,jl) 468 zalf = zbt * zfm(ji-1,jj) / psm(ji,jj,jl) 469 zalf1 = 1.0 - zalf 470 ztemp = zalf * ps0(ji,jj,jl) - zalf1 * zf0(ji-1,jj) 471 ! 472 ps0 (ji,jj,jl) = zbt * ( ps0(ji,jj,jl) + zf0(ji-1,jj) ) + zbt1 * ps0(ji,jj,jl) 473 psx (ji,jj,jl) = zbt * ( zalf * zfx(ji-1,jj) + zalf1 * psx(ji,jj,jl) + 3.0 * ztemp ) + zbt1 * psx(ji,jj,jl) 474 psxx(ji,jj,jl) = zbt * ( zalf * zalf * zfxx(ji-1,jj) + zalf1 * zalf1 * psxx(ji,jj,jl) & 475 & + 5.0 * ( zalf * zalf1 * ( psx (ji,jj,jl) - zfx(ji-1,jj) ) - ( zalf1 - zalf ) * ztemp ) ) & 476 & + zbt1 * psxx(ji,jj,jl) 477 psxy(ji,jj,jl) = zbt * ( zalf * zfxy(ji-1,jj) + zalf1 * psxy(ji,jj,jl) & 478 & + 3.0 * (- zalf1*zfy(ji-1,jj) + zalf * psy(ji,jj,jl) ) ) & 479 & + zbt1 * psxy(ji,jj,jl) 480 psy (ji,jj,jl) = zbt * ( psy (ji,jj,jl) + zfy (ji-1,jj) ) + zbt1 * psy (ji,jj,jl) 481 psyy(ji,jj,jl) = zbt * ( psyy(ji,jj,jl) + zfyy(ji-1,jj) ) + zbt1 * psyy(ji,jj,jl) 482 END DO 483 END DO 484 485 DO jj = 2, jpjm1 ! Flux from i+1 to i IF u LT 0. 486 DO ji = fs_2, fs_jpim1 487 zbt = zbet(ji,jj) 488 zbt1 = 1.0 - zbet(ji,jj) 489 psm(ji,jj,jl) = zbt * psm(ji,jj,jl) + zbt1 * ( psm(ji,jj,jl) + zfm(ji,jj) ) 490 zalf = zbt1 * zfm(ji,jj) / psm(ji,jj,jl) 491 zalf1 = 1.0 - zalf 492 ztemp = - zalf * ps0(ji,jj,jl) + zalf1 * zf0(ji,jj) 493 ! 494 ps0 (ji,jj,jl) = zbt * ps0 (ji,jj,jl) + zbt1 * ( ps0(ji,jj,jl) + zf0(ji,jj) ) 495 psx (ji,jj,jl) = zbt * psx (ji,jj,jl) + zbt1 * ( zalf * zfx(ji,jj) + zalf1 * psx(ji,jj,jl) + 3.0 * ztemp ) 496 psxx(ji,jj,jl) = zbt * psxx(ji,jj,jl) + zbt1 * ( zalf * zalf * zfxx(ji,jj) + zalf1 * zalf1 * psxx(ji,jj,jl) & 497 & + 5.0 * ( zalf * zalf1 * ( - psx(ji,jj,jl) + zfx(ji,jj) ) & 498 & + ( zalf1 - zalf ) * ztemp ) ) 499 psxy(ji,jj,jl) = zbt * psxy(ji,jj,jl) + zbt1 * ( zalf * zfxy(ji,jj) + zalf1 * psxy(ji,jj,jl) & 500 & + 3.0 * ( zalf1 * zfy(ji,jj) - zalf * psy(ji,jj,jl) ) ) 501 psy (ji,jj,jl) = zbt * psy (ji,jj,jl) + zbt1 * ( psy (ji,jj,jl) + zfy (ji,jj) ) 502 psyy(ji,jj,jl) = zbt * psyy(ji,jj,jl) + zbt1 * ( psyy(ji,jj,jl) + zfyy(ji,jj) ) 503 END DO 504 END DO 443 DO_2D_00_00 444 zbt = zbet(ji-1,jj) 445 zbt1 = 1.0 - zbet(ji-1,jj) 446 psm(ji,jj,jl) = zbt * ( psm(ji,jj,jl) + zfm(ji-1,jj) ) + zbt1 * psm(ji,jj,jl) 447 zalf = zbt * zfm(ji-1,jj) / psm(ji,jj,jl) 448 zalf1 = 1.0 - zalf 449 ztemp = zalf * ps0(ji,jj,jl) - zalf1 * zf0(ji-1,jj) 450 ! 451 ps0 (ji,jj,jl) = zbt * ( ps0(ji,jj,jl) + zf0(ji-1,jj) ) + zbt1 * ps0(ji,jj,jl) 452 psx (ji,jj,jl) = zbt * ( zalf * zfx(ji-1,jj) + zalf1 * psx(ji,jj,jl) + 3.0 * ztemp ) + zbt1 * psx(ji,jj,jl) 453 psxx(ji,jj,jl) = zbt * ( zalf * zalf * zfxx(ji-1,jj) + zalf1 * zalf1 * psxx(ji,jj,jl) & 454 & + 5.0 * ( zalf * zalf1 * ( psx (ji,jj,jl) - zfx(ji-1,jj) ) - ( zalf1 - zalf ) * ztemp ) ) & 455 & + zbt1 * psxx(ji,jj,jl) 456 psxy(ji,jj,jl) = zbt * ( zalf * zfxy(ji-1,jj) + zalf1 * psxy(ji,jj,jl) & 457 & + 3.0 * (- zalf1*zfy(ji-1,jj) + zalf * psy(ji,jj,jl) ) ) & 458 & + zbt1 * psxy(ji,jj,jl) 459 psy (ji,jj,jl) = zbt * ( psy (ji,jj,jl) + zfy (ji-1,jj) ) + zbt1 * psy (ji,jj,jl) 460 psyy(ji,jj,jl) = zbt * ( psyy(ji,jj,jl) + zfyy(ji-1,jj) ) + zbt1 * psyy(ji,jj,jl) 461 END_2D 462 463 DO_2D_00_00 464 zbt = zbet(ji,jj) 465 zbt1 = 1.0 - zbet(ji,jj) 466 psm(ji,jj,jl) = zbt * psm(ji,jj,jl) + zbt1 * ( psm(ji,jj,jl) + zfm(ji,jj) ) 467 zalf = zbt1 * zfm(ji,jj) / psm(ji,jj,jl) 468 zalf1 = 1.0 - zalf 469 ztemp = - zalf * ps0(ji,jj,jl) + zalf1 * zf0(ji,jj) 470 ! 471 ps0 (ji,jj,jl) = zbt * ps0 (ji,jj,jl) + zbt1 * ( ps0(ji,jj,jl) + zf0(ji,jj) ) 472 psx (ji,jj,jl) = zbt * psx (ji,jj,jl) + zbt1 * ( zalf * zfx(ji,jj) + zalf1 * psx(ji,jj,jl) + 3.0 * ztemp ) 473 psxx(ji,jj,jl) = zbt * psxx(ji,jj,jl) + zbt1 * ( zalf * zalf * zfxx(ji,jj) + zalf1 * zalf1 * psxx(ji,jj,jl) & 474 & + 5.0 * ( zalf * zalf1 * ( - psx(ji,jj,jl) + zfx(ji,jj) ) & 475 & + ( zalf1 - zalf ) * ztemp ) ) 476 psxy(ji,jj,jl) = zbt * psxy(ji,jj,jl) + zbt1 * ( zalf * zfxy(ji,jj) + zalf1 * psxy(ji,jj,jl) & 477 & + 3.0 * ( zalf1 * zfy(ji,jj) - zalf * psy(ji,jj,jl) ) ) 478 psy (ji,jj,jl) = zbt * psy (ji,jj,jl) + zbt1 * ( psy (ji,jj,jl) + zfy (ji,jj) ) 479 psyy(ji,jj,jl) = zbt * psyy(ji,jj,jl) + zbt1 * ( psyy(ji,jj,jl) + zfyy(ji,jj) ) 480 END_2D 505 481 506 482 END DO … … 544 520 ! 545 521 ! Limitation of moments. 546 DO jj = 1, jpj 547 DO ji = fs_2, fs_jpim1 548 ! Initialize volumes of boxes (=area if adv_x first called, =psm otherwise) 549 psm(ji,jj,jl) = MAX( pcrh * e1e2t(ji,jj) + ( 1.0 - pcrh ) * psm(ji,jj,jl) , epsi20 ) 550 ! 551 zslpmax = MAX( 0._wp, ps0(ji,jj,jl) ) 552 zs1max = 1.5 * zslpmax 553 zs1new = MIN( zs1max, MAX( -zs1max, psy(ji,jj,jl) ) ) 554 zs2new = MIN( ( 2.0 * zslpmax - 0.3334 * ABS( zs1new ) ), & 555 & MAX( ABS( zs1new )-zslpmax, psyy(ji,jj,jl) ) ) 556 rswitch = ( 1.0 - MAX( 0._wp, SIGN( 1._wp, -zslpmax) ) ) * tmask(ji,jj,1) ! Case of empty boxes & Apply mask 557 ! 558 ps0 (ji,jj,jl) = zslpmax 559 psx (ji,jj,jl) = psx (ji,jj,jl) * rswitch 560 psxx(ji,jj,jl) = psxx(ji,jj,jl) * rswitch 561 psy (ji,jj,jl) = zs1new * rswitch 562 psyy(ji,jj,jl) = zs2new * rswitch 563 psxy(ji,jj,jl) = MIN( zslpmax, MAX( -zslpmax, psxy(ji,jj,jl) ) ) * rswitch 564 END DO 565 END DO 522 DO_2D_11_00 523 ! Initialize volumes of boxes (=area if adv_x first called, =psm otherwise) 524 psm(ji,jj,jl) = MAX( pcrh * e1e2t(ji,jj) + ( 1.0 - pcrh ) * psm(ji,jj,jl) , epsi20 ) 525 ! 526 zslpmax = MAX( 0._wp, ps0(ji,jj,jl) ) 527 zs1max = 1.5 * zslpmax 528 zs1new = MIN( zs1max, MAX( -zs1max, psy(ji,jj,jl) ) ) 529 zs2new = MIN( ( 2.0 * zslpmax - 0.3334 * ABS( zs1new ) ), & 530 & MAX( ABS( zs1new )-zslpmax, psyy(ji,jj,jl) ) ) 531 rswitch = ( 1.0 - MAX( 0._wp, SIGN( 1._wp, -zslpmax) ) ) * tmask(ji,jj,1) ! Case of empty boxes & Apply mask 532 ! 533 ps0 (ji,jj,jl) = zslpmax 534 psx (ji,jj,jl) = psx (ji,jj,jl) * rswitch 535 psxx(ji,jj,jl) = psxx(ji,jj,jl) * rswitch 536 psy (ji,jj,jl) = zs1new * rswitch 537 psyy(ji,jj,jl) = zs2new * rswitch 538 psxy(ji,jj,jl) = MIN( zslpmax, MAX( -zslpmax, psxy(ji,jj,jl) ) ) * rswitch 539 END_2D 566 540 567 541 ! Calculate fluxes and moments between boxes j<-->j+1 568 DO jj = 1, jpj ! Flux from j to j+1 WHEN v GT 0 569 DO ji = fs_2, fs_jpim1 570 zbet(ji,jj) = MAX( 0._wp, SIGN( 1._wp, pvt(ji,jj) ) ) 571 zalf = MAX( 0._wp, pvt(ji,jj) ) * pdt / psm(ji,jj,jl) 572 zalfq = zalf * zalf 573 zalf1 = 1.0 - zalf 574 zalf1q = zalf1 * zalf1 575 ! 576 zfm (ji,jj) = zalf * psm(ji,jj,jl) 577 zf0 (ji,jj) = zalf * ( ps0(ji,jj,jl) + zalf1 * ( psy(ji,jj,jl) + (zalf1-zalf) * psyy(ji,jj,jl) ) ) 578 zfy (ji,jj) = zalfq *( psy(ji,jj,jl) + 3.0*zalf1*psyy(ji,jj,jl) ) 579 zfyy(ji,jj) = zalf * zalfq * psyy(ji,jj,jl) 580 zfx (ji,jj) = zalf * ( psx(ji,jj,jl) + zalf1 * psxy(ji,jj,jl) ) 581 zfxy(ji,jj) = zalfq * psxy(ji,jj,jl) 582 zfxx(ji,jj) = zalf * psxx(ji,jj,jl) 583 ! 584 ! Readjust moments remaining in the box. 585 psm (ji,jj,jl) = psm (ji,jj,jl) - zfm(ji,jj) 586 ps0 (ji,jj,jl) = ps0 (ji,jj,jl) - zf0(ji,jj) 587 psy (ji,jj,jl) = zalf1q * ( psy(ji,jj,jl) -3.0 * zalf * psyy(ji,jj,jl) ) 588 psyy(ji,jj,jl) = zalf1 * zalf1q * psyy(ji,jj,jl) 589 psx (ji,jj,jl) = psx (ji,jj,jl) - zfx(ji,jj) 590 psxx(ji,jj,jl) = psxx(ji,jj,jl) - zfxx(ji,jj) 591 psxy(ji,jj,jl) = zalf1q * psxy(ji,jj,jl) 592 END DO 593 END DO 594 ! 595 DO jj = 1, jpjm1 ! Flux from j+1 to j when v LT 0. 596 DO ji = fs_2, fs_jpim1 597 zalf = MAX( 0._wp, -pvt(ji,jj) ) * pdt / psm(ji,jj+1,jl) 598 zalg (ji,jj) = zalf 599 zalfq = zalf * zalf 600 zalf1 = 1.0 - zalf 601 zalg1 (ji,jj) = zalf1 602 zalf1q = zalf1 * zalf1 603 zalg1q(ji,jj) = zalf1q 604 ! 605 zfm (ji,jj) = zfm (ji,jj) + zalf * psm (ji,jj+1,jl) 606 zf0 (ji,jj) = zf0 (ji,jj) + zalf * ( ps0 (ji,jj+1,jl) & 607 & - zalf1 * (psy(ji,jj+1,jl) - (zalf1 - zalf ) * psyy(ji,jj+1,jl) ) ) 608 zfy (ji,jj) = zfy (ji,jj) + zalfq * ( psy (ji,jj+1,jl) - 3.0 * zalf1 * psyy(ji,jj+1,jl) ) 609 zfyy (ji,jj) = zfyy(ji,jj) + zalf * psyy(ji,jj+1,jl) * zalfq 610 zfx (ji,jj) = zfx (ji,jj) + zalf * ( psx (ji,jj+1,jl) - zalf1 * psxy(ji,jj+1,jl) ) 611 zfxy (ji,jj) = zfxy(ji,jj) + zalfq * psxy(ji,jj+1,jl) 612 zfxx (ji,jj) = zfxx(ji,jj) + zalf * psxx(ji,jj+1,jl) 613 END DO 614 END DO 542 DO_2D_11_00 543 zbet(ji,jj) = MAX( 0._wp, SIGN( 1._wp, pvt(ji,jj) ) ) 544 zalf = MAX( 0._wp, pvt(ji,jj) ) * pdt / psm(ji,jj,jl) 545 zalfq = zalf * zalf 546 zalf1 = 1.0 - zalf 547 zalf1q = zalf1 * zalf1 548 ! 549 zfm (ji,jj) = zalf * psm(ji,jj,jl) 550 zf0 (ji,jj) = zalf * ( ps0(ji,jj,jl) + zalf1 * ( psy(ji,jj,jl) + (zalf1-zalf) * psyy(ji,jj,jl) ) ) 551 zfy (ji,jj) = zalfq *( psy(ji,jj,jl) + 3.0*zalf1*psyy(ji,jj,jl) ) 552 zfyy(ji,jj) = zalf * zalfq * psyy(ji,jj,jl) 553 zfx (ji,jj) = zalf * ( psx(ji,jj,jl) + zalf1 * psxy(ji,jj,jl) ) 554 zfxy(ji,jj) = zalfq * psxy(ji,jj,jl) 555 zfxx(ji,jj) = zalf * psxx(ji,jj,jl) 556 ! 557 ! Readjust moments remaining in the box. 558 psm (ji,jj,jl) = psm (ji,jj,jl) - zfm(ji,jj) 559 ps0 (ji,jj,jl) = ps0 (ji,jj,jl) - zf0(ji,jj) 560 psy (ji,jj,jl) = zalf1q * ( psy(ji,jj,jl) -3.0 * zalf * psyy(ji,jj,jl) ) 561 psyy(ji,jj,jl) = zalf1 * zalf1q * psyy(ji,jj,jl) 562 psx (ji,jj,jl) = psx (ji,jj,jl) - zfx(ji,jj) 563 psxx(ji,jj,jl) = psxx(ji,jj,jl) - zfxx(ji,jj) 564 psxy(ji,jj,jl) = zalf1q * psxy(ji,jj,jl) 565 END_2D 566 ! 567 DO_2D_10_00 568 zalf = MAX( 0._wp, -pvt(ji,jj) ) * pdt / psm(ji,jj+1,jl) 569 zalg (ji,jj) = zalf 570 zalfq = zalf * zalf 571 zalf1 = 1.0 - zalf 572 zalg1 (ji,jj) = zalf1 573 zalf1q = zalf1 * zalf1 574 zalg1q(ji,jj) = zalf1q 575 ! 576 zfm (ji,jj) = zfm (ji,jj) + zalf * psm (ji,jj+1,jl) 577 zf0 (ji,jj) = zf0 (ji,jj) + zalf * ( ps0 (ji,jj+1,jl) & 578 & - zalf1 * (psy(ji,jj+1,jl) - (zalf1 - zalf ) * psyy(ji,jj+1,jl) ) ) 579 zfy (ji,jj) = zfy (ji,jj) + zalfq * ( psy (ji,jj+1,jl) - 3.0 * zalf1 * psyy(ji,jj+1,jl) ) 580 zfyy (ji,jj) = zfyy(ji,jj) + zalf * psyy(ji,jj+1,jl) * zalfq 581 zfx (ji,jj) = zfx (ji,jj) + zalf * ( psx (ji,jj+1,jl) - zalf1 * psxy(ji,jj+1,jl) ) 582 zfxy (ji,jj) = zfxy(ji,jj) + zalfq * psxy(ji,jj+1,jl) 583 zfxx (ji,jj) = zfxx(ji,jj) + zalf * psxx(ji,jj+1,jl) 584 END_2D 615 585 616 586 ! Readjust moments remaining in the box. 617 DO jj = 2, jpjm1 618 DO ji = fs_2, fs_jpim1 619 zbt = zbet(ji,jj-1) 620 zbt1 = ( 1.0 - zbet(ji,jj-1) ) 621 ! 622 psm (ji,jj,jl) = zbt * psm(ji,jj,jl) + zbt1 * ( psm(ji,jj,jl) - zfm(ji,jj-1) ) 623 ps0 (ji,jj,jl) = zbt * ps0(ji,jj,jl) + zbt1 * ( ps0(ji,jj,jl) - zf0(ji,jj-1) ) 624 psy (ji,jj,jl) = zalg1q(ji,jj-1) * ( psy(ji,jj,jl) + 3.0 * zalg(ji,jj-1) * psyy(ji,jj,jl) ) 625 psyy(ji,jj,jl) = zalg1 (ji,jj-1) * zalg1q(ji,jj-1) * psyy(ji,jj,jl) 626 psx (ji,jj,jl) = zbt * psx (ji,jj,jl) + zbt1 * ( psx (ji,jj,jl) - zfx (ji,jj-1) ) 627 psxx(ji,jj,jl) = zbt * psxx(ji,jj,jl) + zbt1 * ( psxx(ji,jj,jl) - zfxx(ji,jj-1) ) 628 psxy(ji,jj,jl) = zalg1q(ji,jj-1) * psxy(ji,jj,jl) 629 END DO 630 END DO 587 DO_2D_00_00 588 zbt = zbet(ji,jj-1) 589 zbt1 = ( 1.0 - zbet(ji,jj-1) ) 590 ! 591 psm (ji,jj,jl) = zbt * psm(ji,jj,jl) + zbt1 * ( psm(ji,jj,jl) - zfm(ji,jj-1) ) 592 ps0 (ji,jj,jl) = zbt * ps0(ji,jj,jl) + zbt1 * ( ps0(ji,jj,jl) - zf0(ji,jj-1) ) 593 psy (ji,jj,jl) = zalg1q(ji,jj-1) * ( psy(ji,jj,jl) + 3.0 * zalg(ji,jj-1) * psyy(ji,jj,jl) ) 594 psyy(ji,jj,jl) = zalg1 (ji,jj-1) * zalg1q(ji,jj-1) * psyy(ji,jj,jl) 595 psx (ji,jj,jl) = zbt * psx (ji,jj,jl) + zbt1 * ( psx (ji,jj,jl) - zfx (ji,jj-1) ) 596 psxx(ji,jj,jl) = zbt * psxx(ji,jj,jl) + zbt1 * ( psxx(ji,jj,jl) - zfxx(ji,jj-1) ) 597 psxy(ji,jj,jl) = zalg1q(ji,jj-1) * psxy(ji,jj,jl) 598 END_2D 631 599 632 600 ! Put the temporary moments into appropriate neighboring boxes. 633 DO jj = 2, jpjm1 ! Flux from j to j+1 IF v GT 0. 634 DO ji = fs_2, fs_jpim1 635 zbt = zbet(ji,jj-1) 636 zbt1 = 1.0 - zbet(ji,jj-1) 637 psm(ji,jj,jl) = zbt * ( psm(ji,jj,jl) + zfm(ji,jj-1) ) + zbt1 * psm(ji,jj,jl) 638 zalf = zbt * zfm(ji,jj-1) / psm(ji,jj,jl) 639 zalf1 = 1.0 - zalf 640 ztemp = zalf * ps0(ji,jj,jl) - zalf1 * zf0(ji,jj-1) 641 ! 642 ps0(ji,jj,jl) = zbt * ( ps0(ji,jj,jl) + zf0(ji,jj-1) ) + zbt1 * ps0(ji,jj,jl) 643 psy(ji,jj,jl) = zbt * ( zalf * zfy(ji,jj-1) + zalf1 * psy(ji,jj,jl) + 3.0 * ztemp ) & 644 & + zbt1 * psy(ji,jj,jl) 645 psyy(ji,jj,jl) = zbt * ( zalf * zalf * zfyy(ji,jj-1) + zalf1 * zalf1 * psyy(ji,jj,jl) & 646 & + 5.0 * ( zalf * zalf1 * ( psy(ji,jj,jl) - zfy(ji,jj-1) ) - ( zalf1 - zalf ) * ztemp ) ) & 647 & + zbt1 * psyy(ji,jj,jl) 648 psxy(ji,jj,jl) = zbt * ( zalf * zfxy(ji,jj-1) + zalf1 * psxy(ji,jj,jl) & 649 & + 3.0 * (- zalf1 * zfx(ji,jj-1) + zalf * psx(ji,jj,jl) ) ) & 650 & + zbt1 * psxy(ji,jj,jl) 651 psx (ji,jj,jl) = zbt * ( psx (ji,jj,jl) + zfx (ji,jj-1) ) + zbt1 * psx (ji,jj,jl) 652 psxx(ji,jj,jl) = zbt * ( psxx(ji,jj,jl) + zfxx(ji,jj-1) ) + zbt1 * psxx(ji,jj,jl) 653 END DO 654 END DO 655 656 DO jj = 2, jpjm1 ! Flux from j+1 to j IF v LT 0. 657 DO ji = fs_2, fs_jpim1 658 zbt = zbet(ji,jj) 659 zbt1 = 1.0 - zbet(ji,jj) 660 psm(ji,jj,jl) = zbt * psm(ji,jj,jl) + zbt1 * ( psm(ji,jj,jl) + zfm(ji,jj) ) 661 zalf = zbt1 * zfm(ji,jj) / psm(ji,jj,jl) 662 zalf1 = 1.0 - zalf 663 ztemp = - zalf * ps0(ji,jj,jl) + zalf1 * zf0(ji,jj) 664 ! 665 ps0 (ji,jj,jl) = zbt * ps0 (ji,jj,jl) + zbt1 * ( ps0(ji,jj,jl) + zf0(ji,jj) ) 666 psy (ji,jj,jl) = zbt * psy (ji,jj,jl) + zbt1 * ( zalf * zfy(ji,jj) + zalf1 * psy(ji,jj,jl) + 3.0 * ztemp ) 667 psyy(ji,jj,jl) = zbt * psyy(ji,jj,jl) + zbt1 * ( zalf * zalf * zfyy(ji,jj) + zalf1 * zalf1 * psyy(ji,jj,jl) & 668 & + 5.0 * ( zalf * zalf1 * ( - psy(ji,jj,jl) + zfy(ji,jj) ) & 669 & + ( zalf1 - zalf ) * ztemp ) ) 670 psxy(ji,jj,jl) = zbt * psxy(ji,jj,jl) + zbt1 * ( zalf * zfxy(ji,jj) + zalf1 * psxy(ji,jj,jl) & 671 & + 3.0 * ( zalf1 * zfx(ji,jj) - zalf * psx(ji,jj,jl) ) ) 672 psx (ji,jj,jl) = zbt * psx (ji,jj,jl) + zbt1 * ( psx (ji,jj,jl) + zfx (ji,jj) ) 673 psxx(ji,jj,jl) = zbt * psxx(ji,jj,jl) + zbt1 * ( psxx(ji,jj,jl) + zfxx(ji,jj) ) 674 END DO 675 END DO 601 DO_2D_00_00 602 zbt = zbet(ji,jj-1) 603 zbt1 = 1.0 - zbet(ji,jj-1) 604 psm(ji,jj,jl) = zbt * ( psm(ji,jj,jl) + zfm(ji,jj-1) ) + zbt1 * psm(ji,jj,jl) 605 zalf = zbt * zfm(ji,jj-1) / psm(ji,jj,jl) 606 zalf1 = 1.0 - zalf 607 ztemp = zalf * ps0(ji,jj,jl) - zalf1 * zf0(ji,jj-1) 608 ! 609 ps0(ji,jj,jl) = zbt * ( ps0(ji,jj,jl) + zf0(ji,jj-1) ) + zbt1 * ps0(ji,jj,jl) 610 psy(ji,jj,jl) = zbt * ( zalf * zfy(ji,jj-1) + zalf1 * psy(ji,jj,jl) + 3.0 * ztemp ) & 611 & + zbt1 * psy(ji,jj,jl) 612 psyy(ji,jj,jl) = zbt * ( zalf * zalf * zfyy(ji,jj-1) + zalf1 * zalf1 * psyy(ji,jj,jl) & 613 & + 5.0 * ( zalf * zalf1 * ( psy(ji,jj,jl) - zfy(ji,jj-1) ) - ( zalf1 - zalf ) * ztemp ) ) & 614 & + zbt1 * psyy(ji,jj,jl) 615 psxy(ji,jj,jl) = zbt * ( zalf * zfxy(ji,jj-1) + zalf1 * psxy(ji,jj,jl) & 616 & + 3.0 * (- zalf1 * zfx(ji,jj-1) + zalf * psx(ji,jj,jl) ) ) & 617 & + zbt1 * psxy(ji,jj,jl) 618 psx (ji,jj,jl) = zbt * ( psx (ji,jj,jl) + zfx (ji,jj-1) ) + zbt1 * psx (ji,jj,jl) 619 psxx(ji,jj,jl) = zbt * ( psxx(ji,jj,jl) + zfxx(ji,jj-1) ) + zbt1 * psxx(ji,jj,jl) 620 END_2D 621 622 DO_2D_00_00 623 zbt = zbet(ji,jj) 624 zbt1 = 1.0 - zbet(ji,jj) 625 psm(ji,jj,jl) = zbt * psm(ji,jj,jl) + zbt1 * ( psm(ji,jj,jl) + zfm(ji,jj) ) 626 zalf = zbt1 * zfm(ji,jj) / psm(ji,jj,jl) 627 zalf1 = 1.0 - zalf 628 ztemp = - zalf * ps0(ji,jj,jl) + zalf1 * zf0(ji,jj) 629 ! 630 ps0 (ji,jj,jl) = zbt * ps0 (ji,jj,jl) + zbt1 * ( ps0(ji,jj,jl) + zf0(ji,jj) ) 631 psy (ji,jj,jl) = zbt * psy (ji,jj,jl) + zbt1 * ( zalf * zfy(ji,jj) + zalf1 * psy(ji,jj,jl) + 3.0 * ztemp ) 632 psyy(ji,jj,jl) = zbt * psyy(ji,jj,jl) + zbt1 * ( zalf * zalf * zfyy(ji,jj) + zalf1 * zalf1 * psyy(ji,jj,jl) & 633 & + 5.0 * ( zalf * zalf1 * ( - psy(ji,jj,jl) + zfy(ji,jj) ) & 634 & + ( zalf1 - zalf ) * ztemp ) ) 635 psxy(ji,jj,jl) = zbt * psxy(ji,jj,jl) + zbt1 * ( zalf * zfxy(ji,jj) + zalf1 * psxy(ji,jj,jl) & 636 & + 3.0 * ( zalf1 * zfx(ji,jj) - zalf * psx(ji,jj,jl) ) ) 637 psx (ji,jj,jl) = zbt * psx (ji,jj,jl) + zbt1 * ( psx (ji,jj,jl) + zfx (ji,jj) ) 638 psxx(ji,jj,jl) = zbt * psxx(ji,jj,jl) + zbt1 * ( psxx(ji,jj,jl) + zfxx(ji,jj) ) 639 END_2D 676 640 677 641 END DO … … 715 679 ! 716 680 DO jl = 1, jpl 717 DO jj = 1, jpj 718 DO ji = 1, jpi 719 IF ( pv_i(ji,jj,jl) > 0._wp ) THEN 681 DO_2D_11_11 682 IF ( pv_i(ji,jj,jl) > 0._wp ) THEN 683 ! 684 ! ! -- check h_ip -- ! 685 ! if h_ip is larger than the surrounding 9 pts => reduce h_ip and increase a_ip 686 IF( ln_pnd_LEV .AND. pv_ip(ji,jj,jl) > 0._wp ) THEN 687 zhip = pv_ip(ji,jj,jl) / MAX( epsi20, pa_ip(ji,jj,jl) ) 688 IF( zhip > phip_max(ji,jj,jl) .AND. pa_ip(ji,jj,jl) < 0.15 ) THEN 689 pa_ip(ji,jj,jl) = pv_ip(ji,jj,jl) / phip_max(ji,jj,jl) 690 ENDIF 691 ENDIF 692 ! 693 ! ! -- check h_i -- ! 694 ! if h_i is larger than the surrounding 9 pts => reduce h_i and increase a_i 695 zhi = pv_i(ji,jj,jl) / pa_i(ji,jj,jl) 696 IF( zhi > phi_max(ji,jj,jl) .AND. pa_i(ji,jj,jl) < 0.15 ) THEN 697 pa_i(ji,jj,jl) = pv_i(ji,jj,jl) / MIN( phi_max(ji,jj,jl), hi_max(jpl) ) !-- bound h_i to hi_max (99 m) 698 ENDIF 699 ! 700 ! ! -- check h_s -- ! 701 ! if h_s is larger than the surrounding 9 pts => put the snow excess in the ocean 702 zhs = pv_s(ji,jj,jl) / pa_i(ji,jj,jl) 703 IF( pv_s(ji,jj,jl) > 0._wp .AND. zhs > phs_max(ji,jj,jl) .AND. pa_i(ji,jj,jl) < 0.15 ) THEN 704 zfra = phs_max(ji,jj,jl) / MAX( zhs, epsi20 ) 720 705 ! 721 ! ! -- check h_ip -- ! 722 ! if h_ip is larger than the surrounding 9 pts => reduce h_ip and increase a_ip 723 IF( ln_pnd_LEV .AND. pv_ip(ji,jj,jl) > 0._wp ) THEN 724 zhip = pv_ip(ji,jj,jl) / MAX( epsi20, pa_ip(ji,jj,jl) ) 725 IF( zhip > phip_max(ji,jj,jl) .AND. pa_ip(ji,jj,jl) < 0.15 ) THEN 726 pa_ip(ji,jj,jl) = pv_ip(ji,jj,jl) / phip_max(ji,jj,jl) 727 ENDIF 728 ENDIF 706 wfx_res(ji,jj) = wfx_res(ji,jj) + ( pv_s(ji,jj,jl) - pa_i(ji,jj,jl) * phs_max(ji,jj,jl) ) * rhos * z1_dt 707 hfx_res(ji,jj) = hfx_res(ji,jj) - SUM( pe_s(ji,jj,1:nlay_s,jl) ) * ( 1._wp - zfra ) * z1_dt ! W.m-2 <0 729 708 ! 730 ! ! -- check h_i -- ! 731 ! if h_i is larger than the surrounding 9 pts => reduce h_i and increase a_i 732 zhi = pv_i(ji,jj,jl) / pa_i(ji,jj,jl) 733 IF( zhi > phi_max(ji,jj,jl) .AND. pa_i(ji,jj,jl) < 0.15 ) THEN 734 pa_i(ji,jj,jl) = pv_i(ji,jj,jl) / MIN( phi_max(ji,jj,jl), hi_max(jpl) ) !-- bound h_i to hi_max (99 m) 735 ENDIF 736 ! 737 ! ! -- check h_s -- ! 738 ! if h_s is larger than the surrounding 9 pts => put the snow excess in the ocean 739 zhs = pv_s(ji,jj,jl) / pa_i(ji,jj,jl) 740 IF( pv_s(ji,jj,jl) > 0._wp .AND. zhs > phs_max(ji,jj,jl) .AND. pa_i(ji,jj,jl) < 0.15 ) THEN 741 zfra = phs_max(ji,jj,jl) / MAX( zhs, epsi20 ) 742 ! 743 wfx_res(ji,jj) = wfx_res(ji,jj) + ( pv_s(ji,jj,jl) - pa_i(ji,jj,jl) * phs_max(ji,jj,jl) ) * rhos * z1_dt 744 hfx_res(ji,jj) = hfx_res(ji,jj) - SUM( pe_s(ji,jj,1:nlay_s,jl) ) * ( 1._wp - zfra ) * z1_dt ! W.m-2 <0 745 ! 746 pe_s(ji,jj,1:nlay_s,jl) = pe_s(ji,jj,1:nlay_s,jl) * zfra 747 pv_s(ji,jj,jl) = pa_i(ji,jj,jl) * phs_max(ji,jj,jl) 748 ENDIF 749 ! 750 ! ! -- check s_i -- ! 751 ! if s_i is larger than the surrounding 9 pts => put salt excess in the ocean 752 zsi = psv_i(ji,jj,jl) / pv_i(ji,jj,jl) 753 IF( zsi > psi_max(ji,jj,jl) .AND. pa_i(ji,jj,jl) < 0.15 ) THEN 754 zfra = psi_max(ji,jj,jl) / zsi 755 sfx_res(ji,jj) = sfx_res(ji,jj) + psv_i(ji,jj,jl) * ( 1._wp - zfra ) * rhoi * z1_dt 756 psv_i(ji,jj,jl) = psv_i(ji,jj,jl) * zfra 757 ENDIF 758 ! 759 ENDIF 760 END DO 761 END DO 709 pe_s(ji,jj,1:nlay_s,jl) = pe_s(ji,jj,1:nlay_s,jl) * zfra 710 pv_s(ji,jj,jl) = pa_i(ji,jj,jl) * phs_max(ji,jj,jl) 711 ENDIF 712 ! 713 ! ! -- check s_i -- ! 714 ! if s_i is larger than the surrounding 9 pts => put salt excess in the ocean 715 zsi = psv_i(ji,jj,jl) / pv_i(ji,jj,jl) 716 IF( zsi > psi_max(ji,jj,jl) .AND. pa_i(ji,jj,jl) < 0.15 ) THEN 717 zfra = psi_max(ji,jj,jl) / zsi 718 sfx_res(ji,jj) = sfx_res(ji,jj) + psv_i(ji,jj,jl) * ( 1._wp - zfra ) * rhoi * z1_dt 719 psv_i(ji,jj,jl) = psv_i(ji,jj,jl) * zfra 720 ENDIF 721 ! 722 ENDIF 723 END_2D 762 724 END DO 763 725 ! 764 726 ! ! -- check e_i/v_i -- ! 765 727 DO jl = 1, jpl 766 DO jk = 1, nlay_i 767 DO jj = 1, jpj 768 DO ji = 1, jpi 769 IF ( pv_i(ji,jj,jl) > 0._wp ) THEN 770 ! if e_i/v_i is larger than the surrounding 9 pts => put the heat excess in the ocean 771 zei = pe_i(ji,jj,jk,jl) / pv_i(ji,jj,jl) 772 IF( zei > pei_max(ji,jj,jk,jl) .AND. pa_i(ji,jj,jl) < 0.15 ) THEN 773 zfra = pei_max(ji,jj,jk,jl) / zei 774 hfx_res(ji,jj) = hfx_res(ji,jj) - pe_i(ji,jj,jk,jl) * ( 1._wp - zfra ) * z1_dt ! W.m-2 <0 775 pe_i(ji,jj,jk,jl) = pe_i(ji,jj,jk,jl) * zfra 776 ENDIF 777 ENDIF 778 END DO 779 END DO 780 END DO 728 DO_3D_11_11( 1, nlay_i ) 729 IF ( pv_i(ji,jj,jl) > 0._wp ) THEN 730 ! if e_i/v_i is larger than the surrounding 9 pts => put the heat excess in the ocean 731 zei = pe_i(ji,jj,jk,jl) / pv_i(ji,jj,jl) 732 IF( zei > pei_max(ji,jj,jk,jl) .AND. pa_i(ji,jj,jl) < 0.15 ) THEN 733 zfra = pei_max(ji,jj,jk,jl) / zei 734 hfx_res(ji,jj) = hfx_res(ji,jj) - pe_i(ji,jj,jk,jl) * ( 1._wp - zfra ) * z1_dt ! W.m-2 <0 735 pe_i(ji,jj,jk,jl) = pe_i(ji,jj,jk,jl) * zfra 736 ENDIF 737 ENDIF 738 END_3D 781 739 END DO 782 740 ! ! -- check e_s/v_s -- ! 783 741 DO jl = 1, jpl 784 DO jk = 1, nlay_s 785 DO jj = 1, jpj 786 DO ji = 1, jpi 787 IF ( pv_s(ji,jj,jl) > 0._wp ) THEN 788 ! if e_s/v_s is larger than the surrounding 9 pts => put the heat excess in the ocean 789 zes = pe_s(ji,jj,jk,jl) / pv_s(ji,jj,jl) 790 IF( zes > pes_max(ji,jj,jk,jl) .AND. pa_i(ji,jj,jl) < 0.15 ) THEN 791 zfra = pes_max(ji,jj,jk,jl) / zes 792 hfx_res(ji,jj) = hfx_res(ji,jj) - pe_s(ji,jj,jk,jl) * ( 1._wp - zfra ) * z1_dt ! W.m-2 <0 793 pe_s(ji,jj,jk,jl) = pe_s(ji,jj,jk,jl) * zfra 794 ENDIF 795 ENDIF 796 END DO 797 END DO 798 END DO 742 DO_3D_11_11( 1, nlay_s ) 743 IF ( pv_s(ji,jj,jl) > 0._wp ) THEN 744 ! if e_s/v_s is larger than the surrounding 9 pts => put the heat excess in the ocean 745 zes = pe_s(ji,jj,jk,jl) / pv_s(ji,jj,jl) 746 IF( zes > pes_max(ji,jj,jk,jl) .AND. pa_i(ji,jj,jl) < 0.15 ) THEN 747 zfra = pes_max(ji,jj,jk,jl) / zes 748 hfx_res(ji,jj) = hfx_res(ji,jj) - pe_s(ji,jj,jk,jl) * ( 1._wp - zfra ) * z1_dt ! W.m-2 <0 749 pe_s(ji,jj,jk,jl) = pe_s(ji,jj,jk,jl) * zfra 750 ENDIF 751 ENDIF 752 END_3D 799 753 END DO 800 754 ! … … 829 783 ! -- check snow load -- ! 830 784 DO jl = 1, jpl 831 DO jj = 1, jpj 832 DO ji = 1, jpi 833 IF ( pv_i(ji,jj,jl) > 0._wp ) THEN 834 ! 835 zvs_excess = MAX( 0._wp, pv_s(ji,jj,jl) - pv_i(ji,jj,jl) * (rau0-rhoi) * r1_rhos ) 836 ! 837 IF( zvs_excess > 0._wp ) THEN ! snow-ice interface deplets below the ocean surface 838 ! put snow excess in the ocean 839 zfra = ( pv_s(ji,jj,jl) - zvs_excess ) / MAX( pv_s(ji,jj,jl), epsi20 ) 840 wfx_res(ji,jj) = wfx_res(ji,jj) + zvs_excess * rhos * z1_dt 841 hfx_res(ji,jj) = hfx_res(ji,jj) - SUM( pe_s(ji,jj,1:nlay_s,jl) ) * ( 1._wp - zfra ) * z1_dt ! W.m-2 <0 842 ! correct snow volume and heat content 843 pe_s(ji,jj,1:nlay_s,jl) = pe_s(ji,jj,1:nlay_s,jl) * zfra 844 pv_s(ji,jj,jl) = pv_s(ji,jj,jl) - zvs_excess 845 ENDIF 846 ! 847 ENDIF 848 END DO 849 END DO 785 DO_2D_11_11 786 IF ( pv_i(ji,jj,jl) > 0._wp ) THEN 787 ! 788 zvs_excess = MAX( 0._wp, pv_s(ji,jj,jl) - pv_i(ji,jj,jl) * (rau0-rhoi) * r1_rhos ) 789 ! 790 IF( zvs_excess > 0._wp ) THEN ! snow-ice interface deplets below the ocean surface 791 ! put snow excess in the ocean 792 zfra = ( pv_s(ji,jj,jl) - zvs_excess ) / MAX( pv_s(ji,jj,jl), epsi20 ) 793 wfx_res(ji,jj) = wfx_res(ji,jj) + zvs_excess * rhos * z1_dt 794 hfx_res(ji,jj) = hfx_res(ji,jj) - SUM( pe_s(ji,jj,1:nlay_s,jl) ) * ( 1._wp - zfra ) * z1_dt ! W.m-2 <0 795 ! correct snow volume and heat content 796 pe_s(ji,jj,1:nlay_s,jl) = pe_s(ji,jj,1:nlay_s,jl) * zfra 797 pv_s(ji,jj,jl) = pv_s(ji,jj,jl) - zvs_excess 798 ENDIF 799 ! 800 ENDIF 801 END_2D 850 802 END DO 851 803 ! -
NEMO/branches/2020/temporary_r4_trunk/src/ICE/icedyn_adv_umx.F90
r13466 r13469 114 114 END WHERE 115 115 DO jl = 1, jpl 116 DO jj = 2, jpjm1 117 DO ji = fs_2, fs_jpim1 118 zhip_max(ji,jj,jl) = MAX( epsi20, ph_ip(ji,jj,jl), ph_ip(ji+1,jj ,jl), ph_ip(ji ,jj+1,jl), & 119 & ph_ip(ji-1,jj ,jl), ph_ip(ji ,jj-1,jl), & 120 & ph_ip(ji+1,jj+1,jl), ph_ip(ji-1,jj-1,jl), & 121 & ph_ip(ji+1,jj-1,jl), ph_ip(ji-1,jj+1,jl) ) 122 zhi_max (ji,jj,jl) = MAX( epsi20, ph_i (ji,jj,jl), ph_i (ji+1,jj ,jl), ph_i (ji ,jj+1,jl), & 123 & ph_i (ji-1,jj ,jl), ph_i (ji ,jj-1,jl), & 124 & ph_i (ji+1,jj+1,jl), ph_i (ji-1,jj-1,jl), & 125 & ph_i (ji+1,jj-1,jl), ph_i (ji-1,jj+1,jl) ) 126 zhs_max (ji,jj,jl) = MAX( epsi20, ph_s (ji,jj,jl), ph_s (ji+1,jj ,jl), ph_s (ji ,jj+1,jl), & 127 & ph_s (ji-1,jj ,jl), ph_s (ji ,jj-1,jl), & 128 & ph_s (ji+1,jj+1,jl), ph_s (ji-1,jj-1,jl), & 129 & ph_s (ji+1,jj-1,jl), ph_s (ji-1,jj+1,jl) ) 130 zsi_max (ji,jj,jl) = MAX( epsi20, zs_i (ji,jj,jl), zs_i (ji+1,jj ,jl), zs_i (ji ,jj+1,jl), & 131 & zs_i (ji-1,jj ,jl), zs_i (ji ,jj-1,jl), & 132 & zs_i (ji+1,jj+1,jl), zs_i (ji-1,jj-1,jl), & 133 & zs_i (ji+1,jj-1,jl), zs_i (ji-1,jj+1,jl) ) 134 END DO 135 END DO 116 DO_2D_00_00 117 zhip_max(ji,jj,jl) = MAX( epsi20, ph_ip(ji,jj,jl), ph_ip(ji+1,jj ,jl), ph_ip(ji ,jj+1,jl), & 118 & ph_ip(ji-1,jj ,jl), ph_ip(ji ,jj-1,jl), & 119 & ph_ip(ji+1,jj+1,jl), ph_ip(ji-1,jj-1,jl), & 120 & ph_ip(ji+1,jj-1,jl), ph_ip(ji-1,jj+1,jl) ) 121 zhi_max (ji,jj,jl) = MAX( epsi20, ph_i (ji,jj,jl), ph_i (ji+1,jj ,jl), ph_i (ji ,jj+1,jl), & 122 & ph_i (ji-1,jj ,jl), ph_i (ji ,jj-1,jl), & 123 & ph_i (ji+1,jj+1,jl), ph_i (ji-1,jj-1,jl), & 124 & ph_i (ji+1,jj-1,jl), ph_i (ji-1,jj+1,jl) ) 125 zhs_max (ji,jj,jl) = MAX( epsi20, ph_s (ji,jj,jl), ph_s (ji+1,jj ,jl), ph_s (ji ,jj+1,jl), & 126 & ph_s (ji-1,jj ,jl), ph_s (ji ,jj-1,jl), & 127 & ph_s (ji+1,jj+1,jl), ph_s (ji-1,jj-1,jl), & 128 & ph_s (ji+1,jj-1,jl), ph_s (ji-1,jj+1,jl) ) 129 zsi_max (ji,jj,jl) = MAX( epsi20, zs_i (ji,jj,jl), zs_i (ji+1,jj ,jl), zs_i (ji ,jj+1,jl), & 130 & zs_i (ji-1,jj ,jl), zs_i (ji ,jj-1,jl), & 131 & zs_i (ji+1,jj+1,jl), zs_i (ji-1,jj-1,jl), & 132 & zs_i (ji+1,jj-1,jl), zs_i (ji-1,jj+1,jl) ) 133 END_2D 136 134 END DO 137 135 CALL lbc_lnk_multi( 'icedyn_adv_umx', zhi_max, 'T', 1., zhs_max, 'T', 1., zhip_max, 'T', 1., zsi_max, 'T', 1. ) … … 149 147 END DO 150 148 DO jl = 1, jpl 151 DO jk = 1, nlay_i 152 DO jj = 2, jpjm1 153 DO ji = fs_2, fs_jpim1 154 zei_max(ji,jj,jk,jl) = MAX( epsi20, ze_i(ji,jj,jk,jl), ze_i(ji+1,jj ,jk,jl), ze_i(ji ,jj+1,jk,jl), & 155 & ze_i(ji-1,jj ,jk,jl), ze_i(ji ,jj-1,jk,jl), & 156 & ze_i(ji+1,jj+1,jk,jl), ze_i(ji-1,jj-1,jk,jl), & 157 & ze_i(ji+1,jj-1,jk,jl), ze_i(ji-1,jj+1,jk,jl) ) 158 END DO 159 END DO 160 END DO 161 END DO 162 DO jl = 1, jpl 163 DO jk = 1, nlay_s 164 DO jj = 2, jpjm1 165 DO ji = fs_2, fs_jpim1 166 zes_max(ji,jj,jk,jl) = MAX( epsi20, ze_s(ji,jj,jk,jl), ze_s(ji+1,jj ,jk,jl), ze_s(ji ,jj+1,jk,jl), & 167 & ze_s(ji-1,jj ,jk,jl), ze_s(ji ,jj-1,jk,jl), & 168 & ze_s(ji+1,jj+1,jk,jl), ze_s(ji-1,jj-1,jk,jl), & 169 & ze_s(ji+1,jj-1,jk,jl), ze_s(ji-1,jj+1,jk,jl) ) 170 END DO 171 END DO 172 END DO 149 DO_3D_00_00( 1, nlay_i ) 150 zei_max(ji,jj,jk,jl) = MAX( epsi20, ze_i(ji,jj,jk,jl), ze_i(ji+1,jj ,jk,jl), ze_i(ji ,jj+1,jk,jl), & 151 & ze_i(ji-1,jj ,jk,jl), ze_i(ji ,jj-1,jk,jl), & 152 & ze_i(ji+1,jj+1,jk,jl), ze_i(ji-1,jj-1,jk,jl), & 153 & ze_i(ji+1,jj-1,jk,jl), ze_i(ji-1,jj+1,jk,jl) ) 154 END_3D 155 END DO 156 DO jl = 1, jpl 157 DO_3D_00_00( 1, nlay_s ) 158 zes_max(ji,jj,jk,jl) = MAX( epsi20, ze_s(ji,jj,jk,jl), ze_s(ji+1,jj ,jk,jl), ze_s(ji ,jj+1,jk,jl), & 159 & ze_s(ji-1,jj ,jk,jl), ze_s(ji ,jj-1,jk,jl), & 160 & ze_s(ji+1,jj+1,jk,jl), ze_s(ji-1,jj-1,jk,jl), & 161 & ze_s(ji+1,jj-1,jk,jl), ze_s(ji-1,jj+1,jk,jl) ) 162 END_3D 173 163 END DO 174 164 CALL lbc_lnk( 'icedyn_adv_pra', zei_max, 'T', 1. ) … … 201 191 ! 202 192 ! --- define velocity for advection: u*grad(H) --- ! 203 DO jj = 2, jpjm1 204 DO ji = fs_2, fs_jpim1 205 IF ( pu_ice(ji,jj) * pu_ice(ji-1,jj) <= 0._wp ) THEN ; zcu_box(ji,jj) = 0._wp 206 ELSEIF( pu_ice(ji,jj) > 0._wp ) THEN ; zcu_box(ji,jj) = pu_ice(ji-1,jj) 207 ELSE ; zcu_box(ji,jj) = pu_ice(ji ,jj) 208 ENDIF 209 210 IF ( pv_ice(ji,jj) * pv_ice(ji,jj-1) <= 0._wp ) THEN ; zcv_box(ji,jj) = 0._wp 211 ELSEIF( pv_ice(ji,jj) > 0._wp ) THEN ; zcv_box(ji,jj) = pv_ice(ji,jj-1) 212 ELSE ; zcv_box(ji,jj) = pv_ice(ji,jj ) 213 ENDIF 214 END DO 215 END DO 193 DO_2D_00_00 194 IF ( pu_ice(ji,jj) * pu_ice(ji-1,jj) <= 0._wp ) THEN ; zcu_box(ji,jj) = 0._wp 195 ELSEIF( pu_ice(ji,jj) > 0._wp ) THEN ; zcu_box(ji,jj) = pu_ice(ji-1,jj) 196 ELSE ; zcu_box(ji,jj) = pu_ice(ji ,jj) 197 ENDIF 198 199 IF ( pv_ice(ji,jj) * pv_ice(ji,jj-1) <= 0._wp ) THEN ; zcv_box(ji,jj) = 0._wp 200 ELSEIF( pv_ice(ji,jj) > 0._wp ) THEN ; zcv_box(ji,jj) = pv_ice(ji,jj-1) 201 ELSE ; zcv_box(ji,jj) = pv_ice(ji,jj ) 202 ENDIF 203 END_2D 216 204 217 205 !---------------! … … 236 224 IF( .NOT. ALLOCATED(jmsk_small) ) ALLOCATE( jmsk_small(jpi,jpj,jpl) ) 237 225 DO jl = 1, jpl 238 DO jj = 1, jpjm1 239 DO ji = 1, jpim1 240 zvi_cen = 0.5_wp * ( pv_i(ji+1,jj,jl) + pv_i(ji,jj,jl) ) 241 IF( zvi_cen < epsi06) THEN ; imsk_small(ji,jj,jl) = 0 242 ELSE ; imsk_small(ji,jj,jl) = 1 ; ENDIF 243 zvi_cen = 0.5_wp * ( pv_i(ji,jj+1,jl) + pv_i(ji,jj,jl) ) 244 IF( zvi_cen < epsi06) THEN ; jmsk_small(ji,jj,jl) = 0 245 ELSE ; jmsk_small(ji,jj,jl) = 1 ; ENDIF 246 END DO 247 END DO 226 DO_2D_10_10 227 zvi_cen = 0.5_wp * ( pv_i(ji+1,jj,jl) + pv_i(ji,jj,jl) ) 228 IF( zvi_cen < epsi06) THEN ; imsk_small(ji,jj,jl) = 0 229 ELSE ; imsk_small(ji,jj,jl) = 1 ; ENDIF 230 zvi_cen = 0.5_wp * ( pv_i(ji,jj+1,jl) + pv_i(ji,jj,jl) ) 231 IF( zvi_cen < epsi06) THEN ; jmsk_small(ji,jj,jl) = 0 232 ELSE ; jmsk_small(ji,jj,jl) = 1 ; ENDIF 233 END_2D 248 234 END DO 249 235 ENDIF … … 394 380 !== Open water area ==! 395 381 zati2(:,:) = SUM( pa_i(:,:,:), dim=3 ) 396 DO jj = 2, jpjm1 397 DO ji = fs_2, fs_jpim1 398 pato_i(ji,jj) = pato_i(ji,jj) - ( zati2(ji,jj) - zati1(ji,jj) ) & 399 & - ( zudy(ji,jj) - zudy(ji-1,jj) + zvdx(ji,jj) - zvdx(ji,jj-1) ) * r1_e1e2t(ji,jj) * zdt 400 END DO 401 END DO 382 DO_2D_00_00 383 pato_i(ji,jj) = pato_i(ji,jj) - ( zati2(ji,jj) - zati1(ji,jj) ) & 384 & - ( zudy(ji,jj) - zudy(ji-1,jj) + zvdx(ji,jj) - zvdx(ji,jj-1) ) * r1_e1e2t(ji,jj) * zdt 385 END_2D 402 386 CALL lbc_lnk( 'icedyn_adv_umx', pato_i, 'T', 1. ) 403 387 ! … … 506 490 IF( pamsk == 0._wp ) THEN 507 491 DO jl = 1, jpl 508 DO jj = 1, jpjm1 509 DO ji = 1, fs_jpim1 510 IF( ABS( pu(ji,jj) ) > epsi10 ) THEN 511 zfu_ho (ji,jj,jl) = zfu_ho (ji,jj,jl) * puc (ji,jj,jl) / pu(ji,jj) 512 zfu_ups(ji,jj,jl) = zfu_ups(ji,jj,jl) * pua_ups(ji,jj,jl) / pu(ji,jj) 513 ELSE 514 zfu_ho (ji,jj,jl) = 0._wp 515 zfu_ups(ji,jj,jl) = 0._wp 516 ENDIF 517 ! 518 IF( ABS( pv(ji,jj) ) > epsi10 ) THEN 519 zfv_ho (ji,jj,jl) = zfv_ho (ji,jj,jl) * pvc (ji,jj,jl) / pv(ji,jj) 520 zfv_ups(ji,jj,jl) = zfv_ups(ji,jj,jl) * pva_ups(ji,jj,jl) / pv(ji,jj) 521 ELSE 522 zfv_ho (ji,jj,jl) = 0._wp 523 zfv_ups(ji,jj,jl) = 0._wp 524 ENDIF 525 END DO 526 END DO 492 DO_2D_10_10 493 IF( ABS( pu(ji,jj) ) > epsi10 ) THEN 494 zfu_ho (ji,jj,jl) = zfu_ho (ji,jj,jl) * puc (ji,jj,jl) / pu(ji,jj) 495 zfu_ups(ji,jj,jl) = zfu_ups(ji,jj,jl) * pua_ups(ji,jj,jl) / pu(ji,jj) 496 ELSE 497 zfu_ho (ji,jj,jl) = 0._wp 498 zfu_ups(ji,jj,jl) = 0._wp 499 ENDIF 500 ! 501 IF( ABS( pv(ji,jj) ) > epsi10 ) THEN 502 zfv_ho (ji,jj,jl) = zfv_ho (ji,jj,jl) * pvc (ji,jj,jl) / pv(ji,jj) 503 zfv_ups(ji,jj,jl) = zfv_ups(ji,jj,jl) * pva_ups(ji,jj,jl) / pv(ji,jj) 504 ELSE 505 zfv_ho (ji,jj,jl) = 0._wp 506 zfv_ups(ji,jj,jl) = 0._wp 507 ENDIF 508 END_2D 527 509 END DO 528 510 … … 530 512 ! thus we calculate the upstream solution and apply a limiter again 531 513 DO jl = 1, jpl 532 DO jj = 2, jpjm1 533 DO ji = fs_2, fs_jpim1 534 ztra = - ( zfu_ups(ji,jj,jl) - zfu_ups(ji-1,jj,jl) + zfv_ups(ji,jj,jl) - zfv_ups(ji,jj-1,jl) ) 535 ! 536 zt_ups(ji,jj,jl) = ( ptc(ji,jj,jl) + ztra * r1_e1e2t(ji,jj) * pdt ) * tmask(ji,jj,1) 537 END DO 538 END DO 514 DO_2D_00_00 515 ztra = - ( zfu_ups(ji,jj,jl) - zfu_ups(ji-1,jj,jl) + zfv_ups(ji,jj,jl) - zfv_ups(ji,jj-1,jl) ) 516 ! 517 zt_ups(ji,jj,jl) = ( ptc(ji,jj,jl) + ztra * r1_e1e2t(ji,jj) * pdt ) * tmask(ji,jj,1) 518 END_2D 539 519 END DO 540 520 CALL lbc_lnk( 'icedyn_adv_umx', zt_ups, 'T', 1. ) … … 553 533 IF( PRESENT( pua_ho ) ) THEN 554 534 DO jl = 1, jpl 555 DO jj = 1, jpjm1 556 DO ji = 1, fs_jpim1 557 pua_ho (ji,jj,jl) = zfu_ho (ji,jj,jl) ; pva_ho (ji,jj,jl) = zfv_ho (ji,jj,jl) 558 pua_ups(ji,jj,jl) = zfu_ups(ji,jj,jl) ; pva_ups(ji,jj,jl) = zfv_ups(ji,jj,jl) 559 END DO 560 END DO 535 DO_2D_10_10 536 pua_ho (ji,jj,jl) = zfu_ho (ji,jj,jl) ; pva_ho (ji,jj,jl) = zfv_ho (ji,jj,jl) 537 pua_ups(ji,jj,jl) = zfu_ups(ji,jj,jl) ; pva_ups(ji,jj,jl) = zfv_ups(ji,jj,jl) 538 END_2D 561 539 END DO 562 540 ENDIF … … 565 543 ! --------------------------------- 566 544 DO jl = 1, jpl 567 DO jj = 2, jpjm1 568 DO ji = fs_2, fs_jpim1 569 ztra = - ( zfu_ho(ji,jj,jl) - zfu_ho(ji-1,jj,jl) + zfv_ho(ji,jj,jl) - zfv_ho(ji,jj-1,jl) ) 570 ! 571 ptc(ji,jj,jl) = ( ptc(ji,jj,jl) + ztra * r1_e1e2t(ji,jj) * pdt ) * tmask(ji,jj,1) 572 END DO 573 END DO 545 DO_2D_00_00 546 ztra = - ( zfu_ho(ji,jj,jl) - zfu_ho(ji-1,jj,jl) + zfv_ho(ji,jj,jl) - zfv_ho(ji,jj-1,jl) ) 547 ! 548 ptc(ji,jj,jl) = ( ptc(ji,jj,jl) + ztra * r1_e1e2t(ji,jj) * pdt ) * tmask(ji,jj,1) 549 END_2D 574 550 END DO 575 551 CALL lbc_lnk( 'icedyn_adv_umx', ptc, 'T', 1. ) … … 601 577 ! 602 578 DO jl = 1, jpl 603 DO jj = 1, jpjm1 604 DO ji = 1, fs_jpim1 579 DO_2D_10_10 580 pfu_ups(ji,jj,jl) = MAX( pu(ji,jj), 0._wp ) * pt(ji,jj,jl) + MIN( pu(ji,jj), 0._wp ) * pt(ji+1,jj,jl) 581 pfv_ups(ji,jj,jl) = MAX( pv(ji,jj), 0._wp ) * pt(ji,jj,jl) + MIN( pv(ji,jj), 0._wp ) * pt(ji,jj+1,jl) 582 END_2D 583 END DO 584 ! 585 ELSE !** alternate directions **! 586 ! 587 IF( MOD( (kt - 1) / nn_fsbc , 2 ) == MOD( (jt - 1) , 2 ) ) THEN !== odd ice time step: adv_x then adv_y ==! 588 ! 589 DO jl = 1, jpl !-- flux in x-direction 590 DO_2D_10_10 605 591 pfu_ups(ji,jj,jl) = MAX( pu(ji,jj), 0._wp ) * pt(ji,jj,jl) + MIN( pu(ji,jj), 0._wp ) * pt(ji+1,jj,jl) 592 END_2D 593 END DO 594 ! 595 DO jl = 1, jpl !-- first guess of tracer from u-flux 596 DO_2D_00_00 597 ztra = - ( pfu_ups(ji,jj,jl) - pfu_ups(ji-1,jj,jl) ) & 598 & + ( pu (ji,jj ) - pu (ji-1,jj ) ) * pt(ji,jj,jl) * (1.-pamsk) 599 ! 600 zpt(ji,jj,jl) = ( pt(ji,jj,jl) + ztra * pdt * r1_e1e2t(ji,jj) ) * tmask(ji,jj,1) 601 END_2D 602 END DO 603 CALL lbc_lnk( 'icedyn_adv_umx', zpt, 'T', 1. ) 604 ! 605 DO jl = 1, jpl !-- flux in y-direction 606 DO_2D_10_10 607 pfv_ups(ji,jj,jl) = MAX( pv(ji,jj), 0._wp ) * zpt(ji,jj,jl) + MIN( pv(ji,jj), 0._wp ) * zpt(ji,jj+1,jl) 608 END_2D 609 END DO 610 ! 611 ELSE !== even ice time step: adv_y then adv_x ==! 612 ! 613 DO jl = 1, jpl !-- flux in y-direction 614 DO_2D_10_10 606 615 pfv_ups(ji,jj,jl) = MAX( pv(ji,jj), 0._wp ) * pt(ji,jj,jl) + MIN( pv(ji,jj), 0._wp ) * pt(ji,jj+1,jl) 607 END DO 608 END DO 609 END DO 610 ! 611 ELSE !** alternate directions **! 612 ! 613 IF( MOD( (kt - 1) / nn_fsbc , 2 ) == MOD( (jt - 1) , 2 ) ) THEN !== odd ice time step: adv_x then adv_y ==! 616 END_2D 617 END DO 618 ! 619 DO jl = 1, jpl !-- first guess of tracer from v-flux 620 DO_2D_00_00 621 ztra = - ( pfv_ups(ji,jj,jl) - pfv_ups(ji,jj-1,jl) ) & 622 & + ( pv (ji,jj ) - pv (ji,jj-1 ) ) * pt(ji,jj,jl) * (1.-pamsk) 623 ! 624 zpt(ji,jj,jl) = ( pt(ji,jj,jl) + ztra * pdt * r1_e1e2t(ji,jj) ) * tmask(ji,jj,1) 625 END_2D 626 END DO 627 CALL lbc_lnk( 'icedyn_adv_umx', zpt, 'T', 1. ) 614 628 ! 615 629 DO jl = 1, jpl !-- flux in x-direction 616 DO jj = 1, jpjm1 617 DO ji = 1, fs_jpim1 618 pfu_ups(ji,jj,jl) = MAX( pu(ji,jj), 0._wp ) * pt(ji,jj,jl) + MIN( pu(ji,jj), 0._wp ) * pt(ji+1,jj,jl) 619 END DO 620 END DO 621 END DO 622 ! 623 DO jl = 1, jpl !-- first guess of tracer from u-flux 624 DO jj = 2, jpjm1 625 DO ji = fs_2, fs_jpim1 626 ztra = - ( pfu_ups(ji,jj,jl) - pfu_ups(ji-1,jj,jl) ) & 627 & + ( pu (ji,jj ) - pu (ji-1,jj ) ) * pt(ji,jj,jl) * (1.-pamsk) 628 ! 629 zpt(ji,jj,jl) = ( pt(ji,jj,jl) + ztra * pdt * r1_e1e2t(ji,jj) ) * tmask(ji,jj,1) 630 END DO 631 END DO 632 END DO 633 CALL lbc_lnk( 'icedyn_adv_umx', zpt, 'T', 1. ) 634 ! 635 DO jl = 1, jpl !-- flux in y-direction 636 DO jj = 1, jpjm1 637 DO ji = 1, fs_jpim1 638 pfv_ups(ji,jj,jl) = MAX( pv(ji,jj), 0._wp ) * zpt(ji,jj,jl) + MIN( pv(ji,jj), 0._wp ) * zpt(ji,jj+1,jl) 639 END DO 640 END DO 641 END DO 642 ! 643 ELSE !== even ice time step: adv_y then adv_x ==! 644 ! 645 DO jl = 1, jpl !-- flux in y-direction 646 DO jj = 1, jpjm1 647 DO ji = 1, fs_jpim1 648 pfv_ups(ji,jj,jl) = MAX( pv(ji,jj), 0._wp ) * pt(ji,jj,jl) + MIN( pv(ji,jj), 0._wp ) * pt(ji,jj+1,jl) 649 END DO 650 END DO 651 END DO 652 ! 653 DO jl = 1, jpl !-- first guess of tracer from v-flux 654 DO jj = 2, jpjm1 655 DO ji = fs_2, fs_jpim1 656 ztra = - ( pfv_ups(ji,jj,jl) - pfv_ups(ji,jj-1,jl) ) & 657 & + ( pv (ji,jj ) - pv (ji,jj-1 ) ) * pt(ji,jj,jl) * (1.-pamsk) 658 ! 659 zpt(ji,jj,jl) = ( pt(ji,jj,jl) + ztra * pdt * r1_e1e2t(ji,jj) ) * tmask(ji,jj,1) 660 END DO 661 END DO 662 END DO 663 CALL lbc_lnk( 'icedyn_adv_umx', zpt, 'T', 1. ) 664 ! 665 DO jl = 1, jpl !-- flux in x-direction 666 DO jj = 1, jpjm1 667 DO ji = 1, fs_jpim1 668 pfu_ups(ji,jj,jl) = MAX( pu(ji,jj), 0._wp ) * zpt(ji,jj,jl) + MIN( pu(ji,jj), 0._wp ) * zpt(ji+1,jj,jl) 669 END DO 670 END DO 630 DO_2D_10_10 631 pfu_ups(ji,jj,jl) = MAX( pu(ji,jj), 0._wp ) * zpt(ji,jj,jl) + MIN( pu(ji,jj), 0._wp ) * zpt(ji+1,jj,jl) 632 END_2D 671 633 END DO 672 634 ! … … 676 638 ! 677 639 DO jl = 1, jpl !-- after tracer with upstream scheme 678 DO jj = 2, jpjm1 679 DO ji = fs_2, fs_jpim1 680 ztra = - ( pfu_ups(ji,jj,jl) - pfu_ups(ji-1,jj ,jl) & 681 & + pfv_ups(ji,jj,jl) - pfv_ups(ji ,jj-1,jl) ) & 682 & + ( pu (ji,jj ) - pu (ji-1,jj ) & 683 & + pv (ji,jj ) - pv (ji ,jj-1 ) ) * pt(ji,jj,jl) * (1.-pamsk) 684 ! 685 pt_ups(ji,jj,jl) = ( pt(ji,jj,jl) + ztra * pdt * r1_e1e2t(ji,jj) ) * tmask(ji,jj,1) 686 END DO 687 END DO 640 DO_2D_00_00 641 ztra = - ( pfu_ups(ji,jj,jl) - pfu_ups(ji-1,jj ,jl) & 642 & + pfv_ups(ji,jj,jl) - pfv_ups(ji ,jj-1,jl) ) & 643 & + ( pu (ji,jj ) - pu (ji-1,jj ) & 644 & + pv (ji,jj ) - pv (ji ,jj-1 ) ) * pt(ji,jj,jl) * (1.-pamsk) 645 ! 646 pt_ups(ji,jj,jl) = ( pt(ji,jj,jl) + ztra * pdt * r1_e1e2t(ji,jj) ) * tmask(ji,jj,1) 647 END_2D 688 648 END DO 689 649 CALL lbc_lnk( 'icedyn_adv_umx', pt_ups, 'T', 1. ) … … 717 677 ! 718 678 DO jl = 1, jpl 719 DO jj = 1, jpjm1 720 DO ji = 1, fs_jpim1 721 pfu_ho(ji,jj,jl) = 0.5_wp * pu(ji,jj) * ( pt(ji,jj,jl) + pt(ji+1,jj ,jl) ) 722 pfv_ho(ji,jj,jl) = 0.5_wp * pv(ji,jj) * ( pt(ji,jj,jl) + pt(ji ,jj+1,jl) ) 723 END DO 724 END DO 679 DO_2D_10_10 680 pfu_ho(ji,jj,jl) = 0.5_wp * pu(ji,jj) * ( pt(ji,jj,jl) + pt(ji+1,jj ,jl) ) 681 pfv_ho(ji,jj,jl) = 0.5_wp * pv(ji,jj) * ( pt(ji,jj,jl) + pt(ji ,jj+1,jl) ) 682 END_2D 725 683 END DO 726 684 ! … … 737 695 ! 738 696 DO jl = 1, jpl !-- flux in x-direction 739 DO jj = 1, jpjm1 740 DO ji = 1, fs_jpim1 741 pfu_ho(ji,jj,jl) = 0.5_wp * pu(ji,jj) * ( pt(ji,jj,jl) + pt(ji+1,jj,jl) ) 742 END DO 743 END DO 697 DO_2D_10_10 698 pfu_ho(ji,jj,jl) = 0.5_wp * pu(ji,jj) * ( pt(ji,jj,jl) + pt(ji+1,jj,jl) ) 699 END_2D 744 700 END DO 745 701 IF( np_limiter == 2 .OR. np_limiter == 3 ) CALL limiter_x( pdt, pu, pt, pfu_ups, pfu_ho ) 746 702 747 703 DO jl = 1, jpl !-- first guess of tracer from u-flux 748 DO jj = 2, jpjm1 749 DO ji = fs_2, fs_jpim1 750 ztra = - ( pfu_ho(ji,jj,jl) - pfu_ho(ji-1,jj,jl) ) & 751 & + ( pu (ji,jj ) - pu (ji-1,jj ) ) * pt(ji,jj,jl) * (1.-pamsk) 752 ! 753 zpt(ji,jj,jl) = ( pt(ji,jj,jl) + ztra * pdt * r1_e1e2t(ji,jj) ) * tmask(ji,jj,1) 754 END DO 755 END DO 704 DO_2D_00_00 705 ztra = - ( pfu_ho(ji,jj,jl) - pfu_ho(ji-1,jj,jl) ) & 706 & + ( pu (ji,jj ) - pu (ji-1,jj ) ) * pt(ji,jj,jl) * (1.-pamsk) 707 ! 708 zpt(ji,jj,jl) = ( pt(ji,jj,jl) + ztra * pdt * r1_e1e2t(ji,jj) ) * tmask(ji,jj,1) 709 END_2D 756 710 END DO 757 711 CALL lbc_lnk( 'icedyn_adv_umx', zpt, 'T', 1. ) 758 712 759 713 DO jl = 1, jpl !-- flux in y-direction 760 DO jj = 1, jpjm1 761 DO ji = 1, fs_jpim1 762 pfv_ho(ji,jj,jl) = 0.5_wp * pv(ji,jj) * ( zpt(ji,jj,jl) + zpt(ji,jj+1,jl) ) 763 END DO 764 END DO 714 DO_2D_10_10 715 pfv_ho(ji,jj,jl) = 0.5_wp * pv(ji,jj) * ( zpt(ji,jj,jl) + zpt(ji,jj+1,jl) ) 716 END_2D 765 717 END DO 766 718 IF( np_limiter == 2 .OR. np_limiter == 3 ) CALL limiter_y( pdt, pv, pt, pfv_ups, pfv_ho ) … … 769 721 ! 770 722 DO jl = 1, jpl !-- flux in y-direction 771 DO jj = 1, jpjm1 772 DO ji = 1, fs_jpim1 773 pfv_ho(ji,jj,jl) = 0.5_wp * pv(ji,jj) * ( pt(ji,jj,jl) + pt(ji,jj+1,jl) ) 774 END DO 775 END DO 723 DO_2D_10_10 724 pfv_ho(ji,jj,jl) = 0.5_wp * pv(ji,jj) * ( pt(ji,jj,jl) + pt(ji,jj+1,jl) ) 725 END_2D 776 726 END DO 777 727 IF( np_limiter == 2 .OR. np_limiter == 3 ) CALL limiter_y( pdt, pv, pt, pfv_ups, pfv_ho ) 778 728 ! 779 729 DO jl = 1, jpl !-- first guess of tracer from v-flux 780 DO jj = 2, jpjm1 781 DO ji = fs_2, fs_jpim1 782 ztra = - ( pfv_ho(ji,jj,jl) - pfv_ho(ji,jj-1,jl) ) & 783 & + ( pv (ji,jj ) - pv (ji,jj-1 ) ) * pt(ji,jj,jl) * (1.-pamsk) 784 ! 785 zpt(ji,jj,jl) = ( pt(ji,jj,jl) + ztra * pdt * r1_e1e2t(ji,jj) ) * tmask(ji,jj,1) 786 END DO 787 END DO 730 DO_2D_00_00 731 ztra = - ( pfv_ho(ji,jj,jl) - pfv_ho(ji,jj-1,jl) ) & 732 & + ( pv (ji,jj ) - pv (ji,jj-1 ) ) * pt(ji,jj,jl) * (1.-pamsk) 733 ! 734 zpt(ji,jj,jl) = ( pt(ji,jj,jl) + ztra * pdt * r1_e1e2t(ji,jj) ) * tmask(ji,jj,1) 735 END_2D 788 736 END DO 789 737 CALL lbc_lnk( 'icedyn_adv_umx', zpt, 'T', 1. ) 790 738 ! 791 739 DO jl = 1, jpl !-- flux in x-direction 792 DO jj = 1, jpjm1 793 DO ji = 1, fs_jpim1 794 pfu_ho(ji,jj,jl) = 0.5_wp * pu(ji,jj) * ( zpt(ji,jj,jl) + zpt(ji+1,jj,jl) ) 795 END DO 796 END DO 740 DO_2D_10_10 741 pfu_ho(ji,jj,jl) = 0.5_wp * pu(ji,jj) * ( zpt(ji,jj,jl) + zpt(ji+1,jj,jl) ) 742 END_2D 797 743 END DO 798 744 IF( np_limiter == 2 .OR. np_limiter == 3 ) CALL limiter_x( pdt, pu, pt, pfu_ups, pfu_ho ) … … 840 786 ! !-- advective form update in zpt --! 841 787 DO jl = 1, jpl 842 DO jj = 2, jpjm1 843 DO ji = fs_2, fs_jpim1 844 zpt(ji,jj,jl) = ( pt(ji,jj,jl) - ( pubox(ji,jj ) * ( zt_u(ji,jj,jl) - zt_u(ji-1,jj,jl) ) * r1_e1t (ji,jj) & 845 & + pt (ji,jj,jl) * ( pu (ji,jj ) - pu (ji-1,jj ) ) * r1_e1e2t(ji,jj) & 846 & * pamsk & 847 & ) * pdt ) * tmask(ji,jj,1) 848 END DO 849 END DO 788 DO_2D_00_00 789 zpt(ji,jj,jl) = ( pt(ji,jj,jl) - ( pubox(ji,jj ) * ( zt_u(ji,jj,jl) - zt_u(ji-1,jj,jl) ) * r1_e1t (ji,jj) & 790 & + pt (ji,jj,jl) * ( pu (ji,jj ) - pu (ji-1,jj ) ) * r1_e1e2t(ji,jj) & 791 & * pamsk & 792 & ) * pdt ) * tmask(ji,jj,1) 793 END_2D 850 794 END DO 851 795 CALL lbc_lnk( 'icedyn_adv_umx', zpt, 'T', 1. ) … … 869 813 ! !-- advective form update in zpt --! 870 814 DO jl = 1, jpl 871 DO jj = 2, jpjm1 872 DO ji = fs_2, fs_jpim1 873 zpt(ji,jj,jl) = ( pt(ji,jj,jl) - ( pvbox(ji,jj ) * ( zt_v(ji,jj,jl) - zt_v(ji,jj-1,jl) ) * r1_e2t (ji,jj) & 874 & + pt (ji,jj,jl) * ( pv (ji,jj ) - pv (ji,jj-1 ) ) * r1_e1e2t(ji,jj) & 875 & * pamsk & 876 & ) * pdt ) * tmask(ji,jj,1) 877 END DO 878 END DO 815 DO_2D_00_00 816 zpt(ji,jj,jl) = ( pt(ji,jj,jl) - ( pvbox(ji,jj ) * ( zt_v(ji,jj,jl) - zt_v(ji,jj-1,jl) ) * r1_e2t (ji,jj) & 817 & + pt (ji,jj,jl) * ( pv (ji,jj ) - pv (ji,jj-1 ) ) * r1_e1e2t(ji,jj) & 818 & * pamsk & 819 & ) * pdt ) * tmask(ji,jj,1) 820 END_2D 879 821 END DO 880 822 CALL lbc_lnk( 'icedyn_adv_umx', zpt, 'T', 1. ) … … 953 895 ! 954 896 DO jl = 1, jpl 955 DO jj = 1, jpjm1 956 DO ji = 1, fs_jpim1 ! vector opt. 957 pt_u(ji,jj,jl) = 0.5_wp * umask(ji,jj,1) * ( pt(ji+1,jj,jl) + pt(ji,jj,jl) & 958 & - SIGN( 1._wp, pu(ji,jj) ) * ( pt(ji+1,jj,jl) - pt(ji,jj,jl) ) ) 959 END DO 960 END DO 897 DO_2D_10_10 898 pt_u(ji,jj,jl) = 0.5_wp * umask(ji,jj,1) * ( pt(ji+1,jj,jl) + pt(ji,jj,jl) & 899 & - SIGN( 1._wp, pu(ji,jj) ) * ( pt(ji+1,jj,jl) - pt(ji,jj,jl) ) ) 900 END_2D 961 901 END DO 962 902 ! … … 964 904 ! 965 905 DO jl = 1, jpl 966 DO jj = 1, jpjm1 967 DO ji = 1, fs_jpim1 ! vector opt. 968 zcu = pu(ji,jj) * r1_e2u(ji,jj) * pdt * r1_e1u(ji,jj) 969 pt_u(ji,jj,jl) = 0.5_wp * umask(ji,jj,1) * ( pt(ji+1,jj,jl) + pt(ji,jj,jl) & 970 & - zcu * ( pt(ji+1,jj,jl) - pt(ji,jj,jl) ) ) 971 END DO 972 END DO 906 DO_2D_10_10 907 zcu = pu(ji,jj) * r1_e2u(ji,jj) * pdt * r1_e1u(ji,jj) 908 pt_u(ji,jj,jl) = 0.5_wp * umask(ji,jj,1) * ( pt(ji+1,jj,jl) + pt(ji,jj,jl) & 909 & - zcu * ( pt(ji+1,jj,jl) - pt(ji,jj,jl) ) ) 910 END_2D 973 911 END DO 974 912 ! … … 976 914 ! 977 915 DO jl = 1, jpl 978 DO jj = 1, jpjm1 979 DO ji = 1, fs_jpim1 ! vector opt. 980 zcu = pu(ji,jj) * r1_e2u(ji,jj) * pdt * r1_e1u(ji,jj) 981 zdx2 = e1u(ji,jj) * e1u(ji,jj) 916 DO_2D_10_10 917 zcu = pu(ji,jj) * r1_e2u(ji,jj) * pdt * r1_e1u(ji,jj) 918 zdx2 = e1u(ji,jj) * e1u(ji,jj) 982 919 !!rachid zdx2 = e1u(ji,jj) * e1t(ji,jj) 983 pt_u(ji,jj,jl) = 0.5_wp * umask(ji,jj,1) * ( ( pt (ji+1,jj,jl) + pt (ji,jj,jl) & 984 & - zcu * ( pt (ji+1,jj,jl) - pt (ji,jj,jl) ) ) & 985 & + z1_6 * zdx2 * ( zcu*zcu - 1._wp ) * ( ztu2(ji+1,jj,jl) + ztu2(ji,jj,jl) & 986 & - SIGN( 1._wp, zcu ) * ( ztu2(ji+1,jj,jl) - ztu2(ji,jj,jl) ) ) ) 987 END DO 988 END DO 920 pt_u(ji,jj,jl) = 0.5_wp * umask(ji,jj,1) * ( ( pt (ji+1,jj,jl) + pt (ji,jj,jl) & 921 & - zcu * ( pt (ji+1,jj,jl) - pt (ji,jj,jl) ) ) & 922 & + z1_6 * zdx2 * ( zcu*zcu - 1._wp ) * ( ztu2(ji+1,jj,jl) + ztu2(ji,jj,jl) & 923 & - SIGN( 1._wp, zcu ) * ( ztu2(ji+1,jj,jl) - ztu2(ji,jj,jl) ) ) ) 924 END_2D 989 925 END DO 990 926 ! … … 992 928 ! 993 929 DO jl = 1, jpl 994 DO jj = 1, jpjm1 995 DO ji = 1, fs_jpim1 ! vector opt. 996 zcu = pu(ji,jj) * r1_e2u(ji,jj) * pdt * r1_e1u(ji,jj) 997 zdx2 = e1u(ji,jj) * e1u(ji,jj) 930 DO_2D_10_10 931 zcu = pu(ji,jj) * r1_e2u(ji,jj) * pdt * r1_e1u(ji,jj) 932 zdx2 = e1u(ji,jj) * e1u(ji,jj) 998 933 !!rachid zdx2 = e1u(ji,jj) * e1t(ji,jj) 999 pt_u(ji,jj,jl) = 0.5_wp * umask(ji,jj,1) * ( ( pt (ji+1,jj,jl) + pt (ji,jj,jl) & 1000 & - zcu * ( pt (ji+1,jj,jl) - pt (ji,jj,jl) ) ) & 1001 & + z1_6 * zdx2 * ( zcu*zcu - 1._wp ) * ( ztu2(ji+1,jj,jl) + ztu2(ji,jj,jl) & 1002 & - 0.5_wp * zcu * ( ztu2(ji+1,jj,jl) - ztu2(ji,jj,jl) ) ) ) 1003 END DO 1004 END DO 934 pt_u(ji,jj,jl) = 0.5_wp * umask(ji,jj,1) * ( ( pt (ji+1,jj,jl) + pt (ji,jj,jl) & 935 & - zcu * ( pt (ji+1,jj,jl) - pt (ji,jj,jl) ) ) & 936 & + z1_6 * zdx2 * ( zcu*zcu - 1._wp ) * ( ztu2(ji+1,jj,jl) + ztu2(ji,jj,jl) & 937 & - 0.5_wp * zcu * ( ztu2(ji+1,jj,jl) - ztu2(ji,jj,jl) ) ) ) 938 END_2D 1005 939 END DO 1006 940 ! … … 1008 942 ! 1009 943 DO jl = 1, jpl 1010 DO jj = 1, jpjm1 1011 DO ji = 1, fs_jpim1 ! vector opt. 1012 zcu = pu(ji,jj) * r1_e2u(ji,jj) * pdt * r1_e1u(ji,jj) 1013 zdx2 = e1u(ji,jj) * e1u(ji,jj) 944 DO_2D_10_10 945 zcu = pu(ji,jj) * r1_e2u(ji,jj) * pdt * r1_e1u(ji,jj) 946 zdx2 = e1u(ji,jj) * e1u(ji,jj) 1014 947 !!rachid zdx2 = e1u(ji,jj) * e1t(ji,jj) 1015 zdx4 = zdx2 * zdx2 1016 pt_u(ji,jj,jl) = 0.5_wp * umask(ji,jj,1) * ( ( pt (ji+1,jj,jl) + pt (ji,jj,jl) & 1017 & - zcu * ( pt (ji+1,jj,jl) - pt (ji,jj,jl) ) ) & 1018 & + z1_6 * zdx2 * ( zcu*zcu - 1._wp ) * ( ztu2(ji+1,jj,jl) + ztu2(ji,jj,jl) & 1019 & - 0.5_wp * zcu * ( ztu2(ji+1,jj,jl) - ztu2(ji,jj,jl) ) ) & 1020 & + z1_120 * zdx4 * ( zcu*zcu - 1._wp ) * ( zcu*zcu - 4._wp ) * ( ztu4(ji+1,jj,jl) + ztu4(ji,jj,jl) & 1021 & - SIGN( 1._wp, zcu ) * ( ztu4(ji+1,jj,jl) - ztu4(ji,jj,jl) ) ) ) 1022 END DO 1023 END DO 948 zdx4 = zdx2 * zdx2 949 pt_u(ji,jj,jl) = 0.5_wp * umask(ji,jj,1) * ( ( pt (ji+1,jj,jl) + pt (ji,jj,jl) & 950 & - zcu * ( pt (ji+1,jj,jl) - pt (ji,jj,jl) ) ) & 951 & + z1_6 * zdx2 * ( zcu*zcu - 1._wp ) * ( ztu2(ji+1,jj,jl) + ztu2(ji,jj,jl) & 952 & - 0.5_wp * zcu * ( ztu2(ji+1,jj,jl) - ztu2(ji,jj,jl) ) ) & 953 & + z1_120 * zdx4 * ( zcu*zcu - 1._wp ) * ( zcu*zcu - 4._wp ) * ( ztu4(ji+1,jj,jl) + ztu4(ji,jj,jl) & 954 & - SIGN( 1._wp, zcu ) * ( ztu4(ji+1,jj,jl) - ztu4(ji,jj,jl) ) ) ) 955 END_2D 1024 956 END DO 1025 957 ! … … 1031 963 IF( ll_neg ) THEN 1032 964 DO jl = 1, jpl 1033 DO jj = 1, jpjm1 1034 DO ji = 1, fs_jpim1 1035 IF( pt_u(ji,jj,jl) < 0._wp .OR. ( imsk_small(ji,jj,jl) == 0 .AND. pamsk == 0. ) ) THEN 1036 pt_u(ji,jj,jl) = 0.5_wp * umask(ji,jj,1) * ( pt(ji+1,jj,jl) + pt(ji,jj,jl) & 1037 & - SIGN( 1._wp, pu(ji,jj) ) * ( pt(ji+1,jj,jl) - pt(ji,jj,jl) ) ) 1038 ENDIF 1039 END DO 1040 END DO 965 DO_2D_10_10 966 IF( pt_u(ji,jj,jl) < 0._wp .OR. ( imsk_small(ji,jj,jl) == 0 .AND. pamsk == 0. ) ) THEN 967 pt_u(ji,jj,jl) = 0.5_wp * umask(ji,jj,1) * ( pt(ji+1,jj,jl) + pt(ji,jj,jl) & 968 & - SIGN( 1._wp, pu(ji,jj) ) * ( pt(ji+1,jj,jl) - pt(ji,jj,jl) ) ) 969 ENDIF 970 END_2D 1041 971 END DO 1042 972 ENDIF 1043 973 ! !-- High order flux in i-direction --! 1044 974 DO jl = 1, jpl 1045 DO jj = 1, jpjm1 1046 DO ji = 1, fs_jpim1 ! vector opt. 1047 pfu_ho(ji,jj,jl) = pu(ji,jj) * pt_u(ji,jj,jl) 1048 END DO 1049 END DO 975 DO_2D_10_10 976 pfu_ho(ji,jj,jl) = pu(ji,jj) * pt_u(ji,jj,jl) 977 END_2D 1050 978 END DO 1051 979 ! … … 1078 1006 ! !-- Laplacian in j-direction --! 1079 1007 DO jl = 1, jpl 1080 DO jj = 1, jpjm1 ! First derivative (gradient) 1081 DO ji = fs_2, fs_jpim1 1082 ztv1(ji,jj,jl) = ( pt(ji,jj+1,jl) - pt(ji,jj,jl) ) * r1_e2v(ji,jj) * vmask(ji,jj,1) 1083 END DO 1084 END DO 1085 DO jj = 2, jpjm1 ! Second derivative (Laplacian) 1086 DO ji = fs_2, fs_jpim1 1087 ztv2(ji,jj,jl) = ( ztv1(ji,jj,jl) - ztv1(ji,jj-1,jl) ) * r1_e2t(ji,jj) 1088 END DO 1089 END DO 1008 DO_2D_10_00 1009 ztv1(ji,jj,jl) = ( pt(ji,jj+1,jl) - pt(ji,jj,jl) ) * r1_e2v(ji,jj) * vmask(ji,jj,1) 1010 END_2D 1011 DO_2D_00_00 1012 ztv2(ji,jj,jl) = ( ztv1(ji,jj,jl) - ztv1(ji,jj-1,jl) ) * r1_e2t(ji,jj) 1013 END_2D 1090 1014 END DO 1091 1015 CALL lbc_lnk( 'icedyn_adv_umx', ztv2, 'T', 1. ) … … 1093 1017 ! !-- BiLaplacian in j-direction --! 1094 1018 DO jl = 1, jpl 1095 DO jj = 1, jpjm1 ! First derivative 1096 DO ji = fs_2, fs_jpim1 1097 ztv3(ji,jj,jl) = ( ztv2(ji,jj+1,jl) - ztv2(ji,jj,jl) ) * r1_e2v(ji,jj) * vmask(ji,jj,1) 1098 END DO 1099 END DO 1100 DO jj = 2, jpjm1 ! Second derivative 1101 DO ji = fs_2, fs_jpim1 1102 ztv4(ji,jj,jl) = ( ztv3(ji,jj,jl) - ztv3(ji,jj-1,jl) ) * r1_e2t(ji,jj) 1103 END DO 1104 END DO 1019 DO_2D_10_00 1020 ztv3(ji,jj,jl) = ( ztv2(ji,jj+1,jl) - ztv2(ji,jj,jl) ) * r1_e2v(ji,jj) * vmask(ji,jj,1) 1021 END_2D 1022 DO_2D_00_00 1023 ztv4(ji,jj,jl) = ( ztv3(ji,jj,jl) - ztv3(ji,jj-1,jl) ) * r1_e2t(ji,jj) 1024 END_2D 1105 1025 END DO 1106 1026 CALL lbc_lnk( 'icedyn_adv_umx', ztv4, 'T', 1. ) … … 1111 1031 CASE( 1 ) !== 1st order central TIM ==! (Eq. 21) 1112 1032 DO jl = 1, jpl 1113 DO jj = 1, jpjm1 1114 DO ji = 1, fs_jpim1 1115 pt_v(ji,jj,jl) = 0.5_wp * vmask(ji,jj,1) * ( pt(ji,jj+1,jl) + pt(ji,jj,jl) & 1116 & - SIGN( 1._wp, pv(ji,jj) ) * ( pt(ji,jj+1,jl) - pt(ji,jj,jl) ) ) 1117 END DO 1118 END DO 1033 DO_2D_10_10 1034 pt_v(ji,jj,jl) = 0.5_wp * vmask(ji,jj,1) * ( pt(ji,jj+1,jl) + pt(ji,jj,jl) & 1035 & - SIGN( 1._wp, pv(ji,jj) ) * ( pt(ji,jj+1,jl) - pt(ji,jj,jl) ) ) 1036 END_2D 1119 1037 END DO 1120 1038 ! 1121 1039 CASE( 2 ) !== 2nd order central TIM ==! (Eq. 23) 1122 1040 DO jl = 1, jpl 1123 DO jj = 1, jpjm1 1124 DO ji = 1, fs_jpim1 1125 zcv = pv(ji,jj) * r1_e1v(ji,jj) * pdt * r1_e2v(ji,jj) 1126 pt_v(ji,jj,jl) = 0.5_wp * vmask(ji,jj,1) * ( pt(ji,jj+1,jl) + pt(ji,jj,jl) & 1127 & - zcv * ( pt(ji,jj+1,jl) - pt(ji,jj,jl) ) ) 1128 END DO 1129 END DO 1041 DO_2D_10_10 1042 zcv = pv(ji,jj) * r1_e1v(ji,jj) * pdt * r1_e2v(ji,jj) 1043 pt_v(ji,jj,jl) = 0.5_wp * vmask(ji,jj,1) * ( pt(ji,jj+1,jl) + pt(ji,jj,jl) & 1044 & - zcv * ( pt(ji,jj+1,jl) - pt(ji,jj,jl) ) ) 1045 END_2D 1130 1046 END DO 1131 1047 ! 1132 1048 CASE( 3 ) !== 3rd order central TIM ==! (Eq. 24) 1133 1049 DO jl = 1, jpl 1134 DO jj = 1, jpjm1 1135 DO ji = 1, fs_jpim1 1136 zcv = pv(ji,jj) * r1_e1v(ji,jj) * pdt * r1_e2v(ji,jj) 1137 zdy2 = e2v(ji,jj) * e2v(ji,jj) 1050 DO_2D_10_10 1051 zcv = pv(ji,jj) * r1_e1v(ji,jj) * pdt * r1_e2v(ji,jj) 1052 zdy2 = e2v(ji,jj) * e2v(ji,jj) 1138 1053 !!rachid zdy2 = e2v(ji,jj) * e2t(ji,jj) 1139 pt_v(ji,jj,jl) = 0.5_wp * vmask(ji,jj,1) * ( ( pt (ji,jj+1,jl) + pt (ji,jj,jl) & 1140 & - zcv * ( pt (ji,jj+1,jl) - pt (ji,jj,jl) ) ) & 1141 & + z1_6 * zdy2 * ( zcv*zcv - 1._wp ) * ( ztv2(ji,jj+1,jl) + ztv2(ji,jj,jl) & 1142 & - SIGN( 1._wp, zcv ) * ( ztv2(ji,jj+1,jl) - ztv2(ji,jj,jl) ) ) ) 1143 END DO 1144 END DO 1054 pt_v(ji,jj,jl) = 0.5_wp * vmask(ji,jj,1) * ( ( pt (ji,jj+1,jl) + pt (ji,jj,jl) & 1055 & - zcv * ( pt (ji,jj+1,jl) - pt (ji,jj,jl) ) ) & 1056 & + z1_6 * zdy2 * ( zcv*zcv - 1._wp ) * ( ztv2(ji,jj+1,jl) + ztv2(ji,jj,jl) & 1057 & - SIGN( 1._wp, zcv ) * ( ztv2(ji,jj+1,jl) - ztv2(ji,jj,jl) ) ) ) 1058 END_2D 1145 1059 END DO 1146 1060 ! 1147 1061 CASE( 4 ) !== 4th order central TIM ==! (Eq. 27) 1148 1062 DO jl = 1, jpl 1149 DO jj = 1, jpjm1 1150 DO ji = 1, fs_jpim1 1151 zcv = pv(ji,jj) * r1_e1v(ji,jj) * pdt * r1_e2v(ji,jj) 1152 zdy2 = e2v(ji,jj) * e2v(ji,jj) 1063 DO_2D_10_10 1064 zcv = pv(ji,jj) * r1_e1v(ji,jj) * pdt * r1_e2v(ji,jj) 1065 zdy2 = e2v(ji,jj) * e2v(ji,jj) 1153 1066 !!rachid zdy2 = e2v(ji,jj) * e2t(ji,jj) 1154 pt_v(ji,jj,jl) = 0.5_wp * vmask(ji,jj,1) * ( ( pt (ji,jj+1,jl) + pt (ji,jj,jl) & 1155 & - zcv * ( pt (ji,jj+1,jl) - pt (ji,jj,jl) ) ) & 1156 & + z1_6 * zdy2 * ( zcv*zcv - 1._wp ) * ( ztv2(ji,jj+1,jl) + ztv2(ji,jj,jl) & 1157 & - 0.5_wp * zcv * ( ztv2(ji,jj+1,jl) - ztv2(ji,jj,jl) ) ) ) 1158 END DO 1159 END DO 1067 pt_v(ji,jj,jl) = 0.5_wp * vmask(ji,jj,1) * ( ( pt (ji,jj+1,jl) + pt (ji,jj,jl) & 1068 & - zcv * ( pt (ji,jj+1,jl) - pt (ji,jj,jl) ) ) & 1069 & + z1_6 * zdy2 * ( zcv*zcv - 1._wp ) * ( ztv2(ji,jj+1,jl) + ztv2(ji,jj,jl) & 1070 & - 0.5_wp * zcv * ( ztv2(ji,jj+1,jl) - ztv2(ji,jj,jl) ) ) ) 1071 END_2D 1160 1072 END DO 1161 1073 ! 1162 1074 CASE( 5 ) !== 5th order central TIM ==! (Eq. 29) 1163 1075 DO jl = 1, jpl 1164 DO jj = 1, jpjm1 1165 DO ji = 1, fs_jpim1 1166 zcv = pv(ji,jj) * r1_e1v(ji,jj) * pdt * r1_e2v(ji,jj) 1167 zdy2 = e2v(ji,jj) * e2v(ji,jj) 1076 DO_2D_10_10 1077 zcv = pv(ji,jj) * r1_e1v(ji,jj) * pdt * r1_e2v(ji,jj) 1078 zdy2 = e2v(ji,jj) * e2v(ji,jj) 1168 1079 !!rachid zdy2 = e2v(ji,jj) * e2t(ji,jj) 1169 zdy4 = zdy2 * zdy2 1170 pt_v(ji,jj,jl) = 0.5_wp * vmask(ji,jj,1) * ( ( pt (ji,jj+1,jl) + pt (ji,jj,jl) & 1171 & - zcv * ( pt (ji,jj+1,jl) - pt (ji,jj,jl) ) ) & 1172 & + z1_6 * zdy2 * ( zcv*zcv - 1._wp ) * ( ztv2(ji,jj+1,jl) + ztv2(ji,jj,jl) & 1173 & - 0.5_wp * zcv * ( ztv2(ji,jj+1,jl) - ztv2(ji,jj,jl) ) ) & 1174 & + z1_120 * zdy4 * ( zcv*zcv - 1._wp ) * ( zcv*zcv - 4._wp ) * ( ztv4(ji,jj+1,jl) + ztv4(ji,jj,jl) & 1175 & - SIGN( 1._wp, zcv ) * ( ztv4(ji,jj+1,jl) - ztv4(ji,jj,jl) ) ) ) 1176 END DO 1177 END DO 1080 zdy4 = zdy2 * zdy2 1081 pt_v(ji,jj,jl) = 0.5_wp * vmask(ji,jj,1) * ( ( pt (ji,jj+1,jl) + pt (ji,jj,jl) & 1082 & - zcv * ( pt (ji,jj+1,jl) - pt (ji,jj,jl) ) ) & 1083 & + z1_6 * zdy2 * ( zcv*zcv - 1._wp ) * ( ztv2(ji,jj+1,jl) + ztv2(ji,jj,jl) & 1084 & - 0.5_wp * zcv * ( ztv2(ji,jj+1,jl) - ztv2(ji,jj,jl) ) ) & 1085 & + z1_120 * zdy4 * ( zcv*zcv - 1._wp ) * ( zcv*zcv - 4._wp ) * ( ztv4(ji,jj+1,jl) + ztv4(ji,jj,jl) & 1086 & - SIGN( 1._wp, zcv ) * ( ztv4(ji,jj+1,jl) - ztv4(ji,jj,jl) ) ) ) 1087 END_2D 1178 1088 END DO 1179 1089 ! … … 1185 1095 IF( ll_neg ) THEN 1186 1096 DO jl = 1, jpl 1187 DO jj = 1, jpjm1 1188 DO ji = 1, fs_jpim1 1189 IF( pt_v(ji,jj,jl) < 0._wp .OR. ( jmsk_small(ji,jj,jl) == 0 .AND. pamsk == 0. ) ) THEN 1190 pt_v(ji,jj,jl) = 0.5_wp * vmask(ji,jj,1) * ( ( pt(ji,jj+1,jl) + pt(ji,jj,jl) ) & 1191 & - SIGN( 1._wp, pv(ji,jj) ) * ( pt(ji,jj+1,jl) - pt(ji,jj,jl) ) ) 1192 ENDIF 1193 END DO 1194 END DO 1097 DO_2D_10_10 1098 IF( pt_v(ji,jj,jl) < 0._wp .OR. ( jmsk_small(ji,jj,jl) == 0 .AND. pamsk == 0. ) ) THEN 1099 pt_v(ji,jj,jl) = 0.5_wp * vmask(ji,jj,1) * ( ( pt(ji,jj+1,jl) + pt(ji,jj,jl) ) & 1100 & - SIGN( 1._wp, pv(ji,jj) ) * ( pt(ji,jj+1,jl) - pt(ji,jj,jl) ) ) 1101 ENDIF 1102 END_2D 1195 1103 END DO 1196 1104 ENDIF 1197 1105 ! !-- High order flux in j-direction --! 1198 1106 DO jl = 1, jpl 1199 DO jj = 1, jpjm1 1200 DO ji = 1, fs_jpim1 ! vector opt. 1201 pfv_ho(ji,jj,jl) = pv(ji,jj) * pt_v(ji,jj,jl) 1202 END DO 1203 END DO 1107 DO_2D_10_10 1108 pfv_ho(ji,jj,jl) = pv(ji,jj) * pt_v(ji,jj,jl) 1109 END_2D 1204 1110 END DO 1205 1111 ! … … 1235 1141 ! -------------------------------------------------- 1236 1142 DO jl = 1, jpl 1237 DO jj = 1, jpjm1 1238 DO ji = 1, fs_jpim1 ! vector opt. 1239 pfu_ho(ji,jj,jl) = pfu_ho(ji,jj,jl) - pfu_ups(ji,jj,jl) 1240 pfv_ho(ji,jj,jl) = pfv_ho(ji,jj,jl) - pfv_ups(ji,jj,jl) 1241 END DO 1242 END DO 1143 DO_2D_10_10 1144 pfu_ho(ji,jj,jl) = pfu_ho(ji,jj,jl) - pfu_ups(ji,jj,jl) 1145 pfv_ho(ji,jj,jl) = pfv_ho(ji,jj,jl) - pfv_ups(ji,jj,jl) 1146 END_2D 1243 1147 END DO 1244 1148 … … 1254 1158 1255 1159 DO jl = 1, jpl 1256 DO jj = 2, jpjm1 1257 DO ji = fs_2, fs_jpim1 1258 zti_ups(ji,jj,jl)= pt_ups(ji+1,jj ,jl) 1259 ztj_ups(ji,jj,jl)= pt_ups(ji ,jj+1,jl) 1260 END DO 1261 END DO 1160 DO_2D_00_00 1161 zti_ups(ji,jj,jl)= pt_ups(ji+1,jj ,jl) 1162 ztj_ups(ji,jj,jl)= pt_ups(ji ,jj+1,jl) 1163 END_2D 1262 1164 END DO 1263 1165 CALL lbc_lnk_multi( 'icedyn_adv_umx', zti_ups, 'T', 1., ztj_ups, 'T', 1. ) 1264 1166 1265 1167 DO jl = 1, jpl 1266 DO jj = 2, jpjm1 1267 DO ji = fs_2, fs_jpim1 1268 IF ( pfu_ho(ji,jj,jl) * ( pt_ups(ji+1,jj ,jl) - pt_ups(ji,jj,jl) ) <= 0._wp .AND. & 1269 & pfv_ho(ji,jj,jl) * ( pt_ups(ji ,jj+1,jl) - pt_ups(ji,jj,jl) ) <= 0._wp ) THEN 1270 ! 1271 IF( pfu_ho(ji,jj,jl) * ( zti_ups(ji+1,jj ,jl) - zti_ups(ji,jj,jl) ) <= 0._wp .AND. & 1272 & pfv_ho(ji,jj,jl) * ( ztj_ups(ji ,jj+1,jl) - ztj_ups(ji,jj,jl) ) <= 0._wp ) THEN 1273 pfu_ho(ji,jj,jl)=0._wp 1274 pfv_ho(ji,jj,jl)=0._wp 1275 ENDIF 1276 ! 1277 IF( pfu_ho(ji,jj,jl) * ( pt_ups(ji,jj,jl) - pt_ups(ji-1,jj ,jl) ) <= 0._wp .AND. & 1278 & pfv_ho(ji,jj,jl) * ( pt_ups(ji,jj,jl) - pt_ups(ji ,jj-1,jl) ) <= 0._wp ) THEN 1279 pfu_ho(ji,jj,jl)=0._wp 1280 pfv_ho(ji,jj,jl)=0._wp 1281 ENDIF 1282 ! 1168 DO_2D_00_00 1169 IF ( pfu_ho(ji,jj,jl) * ( pt_ups(ji+1,jj ,jl) - pt_ups(ji,jj,jl) ) <= 0._wp .AND. & 1170 & pfv_ho(ji,jj,jl) * ( pt_ups(ji ,jj+1,jl) - pt_ups(ji,jj,jl) ) <= 0._wp ) THEN 1171 ! 1172 IF( pfu_ho(ji,jj,jl) * ( zti_ups(ji+1,jj ,jl) - zti_ups(ji,jj,jl) ) <= 0._wp .AND. & 1173 & pfv_ho(ji,jj,jl) * ( ztj_ups(ji ,jj+1,jl) - ztj_ups(ji,jj,jl) ) <= 0._wp ) THEN 1174 pfu_ho(ji,jj,jl)=0._wp 1175 pfv_ho(ji,jj,jl)=0._wp 1283 1176 ENDIF 1284 END DO 1285 END DO 1177 ! 1178 IF( pfu_ho(ji,jj,jl) * ( pt_ups(ji,jj,jl) - pt_ups(ji-1,jj ,jl) ) <= 0._wp .AND. & 1179 & pfv_ho(ji,jj,jl) * ( pt_ups(ji,jj,jl) - pt_ups(ji ,jj-1,jl) ) <= 0._wp ) THEN 1180 pfu_ho(ji,jj,jl)=0._wp 1181 pfv_ho(ji,jj,jl)=0._wp 1182 ENDIF 1183 ! 1184 ENDIF 1185 END_2D 1286 1186 END DO 1287 1187 CALL lbc_lnk_multi( 'icedyn_adv_umx', pfu_ho, 'U', -1., pfv_ho, 'V', -1. ) ! lateral boundary cond. … … 1295 1195 DO jl = 1, jpl 1296 1196 1297 DO jj = 1, jpj 1298 DO ji = 1, jpi 1299 IF ( pt(ji,jj,jl) <= 0._wp .AND. pt_ups(ji,jj,jl) <= 0._wp ) THEN 1300 zbup(ji,jj) = -zbig 1301 zbdo(ji,jj) = zbig 1302 ELSEIF( pt(ji,jj,jl) <= 0._wp .AND. pt_ups(ji,jj,jl) > 0._wp ) THEN 1303 zbup(ji,jj) = pt_ups(ji,jj,jl) 1304 zbdo(ji,jj) = pt_ups(ji,jj,jl) 1305 ELSEIF( pt(ji,jj,jl) > 0._wp .AND. pt_ups(ji,jj,jl) <= 0._wp ) THEN 1306 zbup(ji,jj) = pt(ji,jj,jl) 1307 zbdo(ji,jj) = pt(ji,jj,jl) 1308 ELSE 1309 zbup(ji,jj) = MAX( pt(ji,jj,jl) , pt_ups(ji,jj,jl) ) 1310 zbdo(ji,jj) = MIN( pt(ji,jj,jl) , pt_ups(ji,jj,jl) ) 1311 ENDIF 1312 END DO 1313 END DO 1314 1315 DO jj = 2, jpjm1 1316 DO ji = fs_2, fs_jpim1 ! vector opt. 1317 ! 1318 zup = MAX( zbup(ji,jj), zbup(ji-1,jj), zbup(ji+1,jj), zbup(ji,jj-1), zbup(ji,jj+1) ) ! search max/min in neighbourhood 1319 zdo = MIN( zbdo(ji,jj), zbdo(ji-1,jj), zbdo(ji+1,jj), zbdo(ji,jj-1), zbdo(ji,jj+1) ) 1320 ! 1321 zpos = MAX( 0._wp, pfu_ho(ji-1,jj ,jl) ) - MIN( 0._wp, pfu_ho(ji ,jj ,jl) ) & ! positive/negative part of the flux 1322 & + MAX( 0._wp, pfv_ho(ji ,jj-1,jl) ) - MIN( 0._wp, pfv_ho(ji ,jj ,jl) ) 1323 zneg = MAX( 0._wp, pfu_ho(ji ,jj ,jl) ) - MIN( 0._wp, pfu_ho(ji-1,jj ,jl) ) & 1324 & + MAX( 0._wp, pfv_ho(ji ,jj ,jl) ) - MIN( 0._wp, pfv_ho(ji ,jj-1,jl) ) 1325 ! 1326 zpos = zpos - (pt(ji,jj,jl) * MIN( 0., pu(ji,jj) - pu(ji-1,jj) ) + pt(ji,jj,jl) * MIN( 0., pv(ji,jj) - pv(ji,jj-1) ) & 1327 & ) * ( 1. - pamsk ) 1328 zneg = zneg + (pt(ji,jj,jl) * MAX( 0., pu(ji,jj) - pu(ji-1,jj) ) + pt(ji,jj,jl) * MAX( 0., pv(ji,jj) - pv(ji,jj-1) ) & 1329 & ) * ( 1. - pamsk ) 1330 ! 1331 ! ! up & down beta terms 1332 ! clem: zbetup and zbetdo must be 0 for zpos>1.e-10 & zneg>1.e-10 (do not put 0 instead of 1.e-10 !!!) 1333 IF( zpos > epsi10 ) THEN ; zbetup(ji,jj,jl) = MAX( 0._wp, zup - pt_ups(ji,jj,jl) ) / zpos * e1e2t(ji,jj) * z1_dt 1334 ELSE ; zbetup(ji,jj,jl) = 0._wp ! zbig 1335 ENDIF 1336 ! 1337 IF( zneg > epsi10 ) THEN ; zbetdo(ji,jj,jl) = MAX( 0._wp, pt_ups(ji,jj,jl) - zdo ) / zneg * e1e2t(ji,jj) * z1_dt 1338 ELSE ; zbetdo(ji,jj,jl) = 0._wp ! zbig 1339 ENDIF 1340 ! 1341 ! if all the points are outside ice cover 1342 IF( zup == -zbig ) zbetup(ji,jj,jl) = 0._wp ! zbig 1343 IF( zdo == zbig ) zbetdo(ji,jj,jl) = 0._wp ! zbig 1344 ! 1345 END DO 1346 END DO 1197 DO_2D_11_11 1198 IF ( pt(ji,jj,jl) <= 0._wp .AND. pt_ups(ji,jj,jl) <= 0._wp ) THEN 1199 zbup(ji,jj) = -zbig 1200 zbdo(ji,jj) = zbig 1201 ELSEIF( pt(ji,jj,jl) <= 0._wp .AND. pt_ups(ji,jj,jl) > 0._wp ) THEN 1202 zbup(ji,jj) = pt_ups(ji,jj,jl) 1203 zbdo(ji,jj) = pt_ups(ji,jj,jl) 1204 ELSEIF( pt(ji,jj,jl) > 0._wp .AND. pt_ups(ji,jj,jl) <= 0._wp ) THEN 1205 zbup(ji,jj) = pt(ji,jj,jl) 1206 zbdo(ji,jj) = pt(ji,jj,jl) 1207 ELSE 1208 zbup(ji,jj) = MAX( pt(ji,jj,jl) , pt_ups(ji,jj,jl) ) 1209 zbdo(ji,jj) = MIN( pt(ji,jj,jl) , pt_ups(ji,jj,jl) ) 1210 ENDIF 1211 END_2D 1212 1213 DO_2D_00_00 1214 ! 1215 zup = MAX( zbup(ji,jj), zbup(ji-1,jj), zbup(ji+1,jj), zbup(ji,jj-1), zbup(ji,jj+1) ) ! search max/min in neighbourhood 1216 zdo = MIN( zbdo(ji,jj), zbdo(ji-1,jj), zbdo(ji+1,jj), zbdo(ji,jj-1), zbdo(ji,jj+1) ) 1217 ! 1218 zpos = MAX( 0._wp, pfu_ho(ji-1,jj ,jl) ) - MIN( 0._wp, pfu_ho(ji ,jj ,jl) ) & ! positive/negative part of the flux 1219 & + MAX( 0._wp, pfv_ho(ji ,jj-1,jl) ) - MIN( 0._wp, pfv_ho(ji ,jj ,jl) ) 1220 zneg = MAX( 0._wp, pfu_ho(ji ,jj ,jl) ) - MIN( 0._wp, pfu_ho(ji-1,jj ,jl) ) & 1221 & + MAX( 0._wp, pfv_ho(ji ,jj ,jl) ) - MIN( 0._wp, pfv_ho(ji ,jj-1,jl) ) 1222 ! 1223 zpos = zpos - (pt(ji,jj,jl) * MIN( 0., pu(ji,jj) - pu(ji-1,jj) ) + pt(ji,jj,jl) * MIN( 0., pv(ji,jj) - pv(ji,jj-1) ) & 1224 & ) * ( 1. - pamsk ) 1225 zneg = zneg + (pt(ji,jj,jl) * MAX( 0., pu(ji,jj) - pu(ji-1,jj) ) + pt(ji,jj,jl) * MAX( 0., pv(ji,jj) - pv(ji,jj-1) ) & 1226 & ) * ( 1. - pamsk ) 1227 ! 1228 ! ! up & down beta terms 1229 ! clem: zbetup and zbetdo must be 0 for zpos>1.e-10 & zneg>1.e-10 (do not put 0 instead of 1.e-10 !!!) 1230 IF( zpos > epsi10 ) THEN ; zbetup(ji,jj,jl) = MAX( 0._wp, zup - pt_ups(ji,jj,jl) ) / zpos * e1e2t(ji,jj) * z1_dt 1231 ELSE ; zbetup(ji,jj,jl) = 0._wp ! zbig 1232 ENDIF 1233 ! 1234 IF( zneg > epsi10 ) THEN ; zbetdo(ji,jj,jl) = MAX( 0._wp, pt_ups(ji,jj,jl) - zdo ) / zneg * e1e2t(ji,jj) * z1_dt 1235 ELSE ; zbetdo(ji,jj,jl) = 0._wp ! zbig 1236 ENDIF 1237 ! 1238 ! if all the points are outside ice cover 1239 IF( zup == -zbig ) zbetup(ji,jj,jl) = 0._wp ! zbig 1240 IF( zdo == zbig ) zbetdo(ji,jj,jl) = 0._wp ! zbig 1241 ! 1242 END_2D 1347 1243 END DO 1348 1244 CALL lbc_lnk_multi( 'icedyn_adv_umx', zbetup, 'T', 1., zbetdo, 'T', 1. ) ! lateral boundary cond. (unchanged sign) … … 1352 1248 ! --------------------------------- 1353 1249 DO jl = 1, jpl 1354 DO jj = 1, jpjm1 1355 DO ji = 1, fs_jpim1 ! vector opt. 1356 zau = MIN( 1._wp , zbetdo(ji,jj,jl) , zbetup(ji+1,jj,jl) ) 1357 zbu = MIN( 1._wp , zbetup(ji,jj,jl) , zbetdo(ji+1,jj,jl) ) 1358 zcu = 0.5_wp + SIGN( 0.5_wp , pfu_ho(ji,jj,jl) ) 1359 ! 1360 zcoef = ( zcu * zau + ( 1._wp - zcu ) * zbu ) 1361 ! 1362 pfu_ho(ji,jj,jl) = pfu_ho(ji,jj,jl) * zcoef + pfu_ups(ji,jj,jl) 1363 ! 1364 END DO 1365 END DO 1366 1367 DO jj = 1, jpjm1 1368 DO ji = 1, fs_jpim1 ! vector opt. 1369 zav = MIN( 1._wp , zbetdo(ji,jj,jl) , zbetup(ji,jj+1,jl) ) 1370 zbv = MIN( 1._wp , zbetup(ji,jj,jl) , zbetdo(ji,jj+1,jl) ) 1371 zcv = 0.5_wp + SIGN( 0.5_wp , pfv_ho(ji,jj,jl) ) 1372 ! 1373 zcoef = ( zcv * zav + ( 1._wp - zcv ) * zbv ) 1374 ! 1375 pfv_ho(ji,jj,jl) = pfv_ho(ji,jj,jl) * zcoef + pfv_ups(ji,jj,jl) 1376 ! 1377 END DO 1378 END DO 1250 DO_2D_10_10 1251 zau = MIN( 1._wp , zbetdo(ji,jj,jl) , zbetup(ji+1,jj,jl) ) 1252 zbu = MIN( 1._wp , zbetup(ji,jj,jl) , zbetdo(ji+1,jj,jl) ) 1253 zcu = 0.5_wp + SIGN( 0.5_wp , pfu_ho(ji,jj,jl) ) 1254 ! 1255 zcoef = ( zcu * zau + ( 1._wp - zcu ) * zbu ) 1256 ! 1257 pfu_ho(ji,jj,jl) = pfu_ho(ji,jj,jl) * zcoef + pfu_ups(ji,jj,jl) 1258 ! 1259 END_2D 1260 1261 DO_2D_10_10 1262 zav = MIN( 1._wp , zbetdo(ji,jj,jl) , zbetup(ji,jj+1,jl) ) 1263 zbv = MIN( 1._wp , zbetup(ji,jj,jl) , zbetdo(ji,jj+1,jl) ) 1264 zcv = 0.5_wp + SIGN( 0.5_wp , pfv_ho(ji,jj,jl) ) 1265 ! 1266 zcoef = ( zcv * zav + ( 1._wp - zcv ) * zbv ) 1267 ! 1268 pfv_ho(ji,jj,jl) = pfv_ho(ji,jj,jl) * zcoef + pfv_ups(ji,jj,jl) 1269 ! 1270 END_2D 1379 1271 1380 1272 END DO … … 1401 1293 ! 1402 1294 DO jl = 1, jpl 1403 DO jj = 2, jpjm1 1404 DO ji = fs_2, fs_jpim1 ! vector opt. 1405 zslpx(ji,jj,jl) = ( pt(ji+1,jj,jl) - pt(ji,jj,jl) ) * umask(ji,jj,1) 1406 END DO 1407 END DO 1295 DO_2D_00_00 1296 zslpx(ji,jj,jl) = ( pt(ji+1,jj,jl) - pt(ji,jj,jl) ) * umask(ji,jj,1) 1297 END_2D 1408 1298 END DO 1409 1299 CALL lbc_lnk( 'icedyn_adv_umx', zslpx, 'U', -1.) ! lateral boundary cond. 1410 1300 1411 1301 DO jl = 1, jpl 1412 DO jj = 2, jpjm1 1413 DO ji = fs_2, fs_jpim1 ! vector opt. 1414 uCFL = pdt * ABS( pu(ji,jj) ) * r1_e1e2t(ji,jj) 1415 1416 Rjm = zslpx(ji-1,jj,jl) 1417 Rj = zslpx(ji ,jj,jl) 1418 Rjp = zslpx(ji+1,jj,jl) 1419 1420 IF( np_limiter == 3 ) THEN 1421 1422 IF( pu(ji,jj) > 0. ) THEN ; Rr = Rjm 1423 ELSE ; Rr = Rjp 1302 DO_2D_00_00 1303 uCFL = pdt * ABS( pu(ji,jj) ) * r1_e1e2t(ji,jj) 1304 1305 Rjm = zslpx(ji-1,jj,jl) 1306 Rj = zslpx(ji ,jj,jl) 1307 Rjp = zslpx(ji+1,jj,jl) 1308 1309 IF( np_limiter == 3 ) THEN 1310 1311 IF( pu(ji,jj) > 0. ) THEN ; Rr = Rjm 1312 ELSE ; Rr = Rjp 1313 ENDIF 1314 1315 zh3 = pfu_ho(ji,jj,jl) - pfu_ups(ji,jj,jl) 1316 IF( Rj > 0. ) THEN 1317 zlimiter = MAX( 0., MIN( zh3, MAX(-Rr * 0.5 * ABS(pu(ji,jj)), & 1318 & MIN( 2. * Rr * 0.5 * ABS(pu(ji,jj)), zh3, 1.5 * Rj * 0.5 * ABS(pu(ji,jj)) ) ) ) ) 1319 ELSE 1320 zlimiter = -MAX( 0., MIN(-zh3, MAX( Rr * 0.5 * ABS(pu(ji,jj)), & 1321 & MIN(-2. * Rr * 0.5 * ABS(pu(ji,jj)), -zh3, -1.5 * Rj * 0.5 * ABS(pu(ji,jj)) ) ) ) ) 1322 ENDIF 1323 pfu_ho(ji,jj,jl) = pfu_ups(ji,jj,jl) + zlimiter 1324 1325 ELSEIF( np_limiter == 2 ) THEN 1326 IF( Rj /= 0. ) THEN 1327 IF( pu(ji,jj) > 0. ) THEN ; Cr = Rjm / Rj 1328 ELSE ; Cr = Rjp / Rj 1424 1329 ENDIF 1425 1426 zh3 = pfu_ho(ji,jj,jl) - pfu_ups(ji,jj,jl) 1427 IF( Rj > 0. ) THEN 1428 zlimiter = MAX( 0., MIN( zh3, MAX(-Rr * 0.5 * ABS(pu(ji,jj)), & 1429 & MIN( 2. * Rr * 0.5 * ABS(pu(ji,jj)), zh3, 1.5 * Rj * 0.5 * ABS(pu(ji,jj)) ) ) ) ) 1430 ELSE 1431 zlimiter = -MAX( 0., MIN(-zh3, MAX( Rr * 0.5 * ABS(pu(ji,jj)), & 1432 & MIN(-2. * Rr * 0.5 * ABS(pu(ji,jj)), -zh3, -1.5 * Rj * 0.5 * ABS(pu(ji,jj)) ) ) ) ) 1433 ENDIF 1434 pfu_ho(ji,jj,jl) = pfu_ups(ji,jj,jl) + zlimiter 1435 1436 ELSEIF( np_limiter == 2 ) THEN 1437 IF( Rj /= 0. ) THEN 1438 IF( pu(ji,jj) > 0. ) THEN ; Cr = Rjm / Rj 1439 ELSE ; Cr = Rjp / Rj 1440 ENDIF 1441 ELSE 1442 Cr = 0. 1443 ENDIF 1444 1445 ! -- superbee -- 1446 zpsi = MAX( 0., MAX( MIN(1.,2.*Cr), MIN(2.,Cr) ) ) 1447 ! -- van albada 2 -- 1448 !!zpsi = 2.*Cr / (Cr*Cr+1.) 1449 ! -- sweby (with beta=1) -- 1450 !!zpsi = MAX( 0., MAX( MIN(1.,1.*Cr), MIN(1.,Cr) ) ) 1451 ! -- van Leer -- 1452 !!zpsi = ( Cr + ABS(Cr) ) / ( 1. + ABS(Cr) ) 1453 ! -- ospre -- 1454 !!zpsi = 1.5 * ( Cr*Cr + Cr ) / ( Cr*Cr + Cr + 1. ) 1455 ! -- koren -- 1456 !!zpsi = MAX( 0., MIN( 2.*Cr, MIN( (1.+2*Cr)/3., 2. ) ) ) 1457 ! -- charm -- 1458 !IF( Cr > 0. ) THEN ; zpsi = Cr * (3.*Cr + 1.) / ( (Cr + 1.) * (Cr + 1.) ) 1459 !ELSE ; zpsi = 0. 1460 !ENDIF 1461 ! -- van albada 1 -- 1462 !!zpsi = (Cr*Cr + Cr) / (Cr*Cr +1) 1463 ! -- smart -- 1464 !!zpsi = MAX( 0., MIN( 2.*Cr, MIN( 0.25+0.75*Cr, 4. ) ) ) 1465 ! -- umist -- 1466 !!zpsi = MAX( 0., MIN( 2.*Cr, MIN( 0.25+0.75*Cr, MIN(0.75+0.25*Cr, 2. ) ) ) ) 1467 1468 ! high order flux corrected by the limiter 1469 pfu_ho(ji,jj,jl) = pfu_ho(ji,jj,jl) - ABS( pu(ji,jj) ) * ( (1.-zpsi) + uCFL*zpsi ) * Rj * 0.5 1470 1330 ELSE 1331 Cr = 0. 1471 1332 ENDIF 1472 END DO 1473 END DO 1333 1334 ! -- superbee -- 1335 zpsi = MAX( 0., MAX( MIN(1.,2.*Cr), MIN(2.,Cr) ) ) 1336 ! -- van albada 2 -- 1337 !!zpsi = 2.*Cr / (Cr*Cr+1.) 1338 ! -- sweby (with beta=1) -- 1339 !!zpsi = MAX( 0., MAX( MIN(1.,1.*Cr), MIN(1.,Cr) ) ) 1340 ! -- van Leer -- 1341 !!zpsi = ( Cr + ABS(Cr) ) / ( 1. + ABS(Cr) ) 1342 ! -- ospre -- 1343 !!zpsi = 1.5 * ( Cr*Cr + Cr ) / ( Cr*Cr + Cr + 1. ) 1344 ! -- koren -- 1345 !!zpsi = MAX( 0., MIN( 2.*Cr, MIN( (1.+2*Cr)/3., 2. ) ) ) 1346 ! -- charm -- 1347 !IF( Cr > 0. ) THEN ; zpsi = Cr * (3.*Cr + 1.) / ( (Cr + 1.) * (Cr + 1.) ) 1348 !ELSE ; zpsi = 0. 1349 !ENDIF 1350 ! -- van albada 1 -- 1351 !!zpsi = (Cr*Cr + Cr) / (Cr*Cr +1) 1352 ! -- smart -- 1353 !!zpsi = MAX( 0., MIN( 2.*Cr, MIN( 0.25+0.75*Cr, 4. ) ) ) 1354 ! -- umist -- 1355 !!zpsi = MAX( 0., MIN( 2.*Cr, MIN( 0.25+0.75*Cr, MIN(0.75+0.25*Cr, 2. ) ) ) ) 1356 1357 ! high order flux corrected by the limiter 1358 pfu_ho(ji,jj,jl) = pfu_ho(ji,jj,jl) - ABS( pu(ji,jj) ) * ( (1.-zpsi) + uCFL*zpsi ) * Rj * 0.5 1359 1360 ENDIF 1361 END_2D 1474 1362 END DO 1475 1363 CALL lbc_lnk( 'icedyn_adv_umx', pfu_ho, 'U', -1.) ! lateral boundary cond. … … 1496 1384 ! 1497 1385 DO jl = 1, jpl 1498 DO jj = 2, jpjm1 1499 DO ji = fs_2, fs_jpim1 ! vector opt. 1500 zslpy(ji,jj,jl) = ( pt(ji,jj+1,jl) - pt(ji,jj,jl) ) * vmask(ji,jj,1) 1501 END DO 1502 END DO 1386 DO_2D_00_00 1387 zslpy(ji,jj,jl) = ( pt(ji,jj+1,jl) - pt(ji,jj,jl) ) * vmask(ji,jj,1) 1388 END_2D 1503 1389 END DO 1504 1390 CALL lbc_lnk( 'icedyn_adv_umx', zslpy, 'V', -1.) ! lateral boundary cond. 1505 1391 1506 1392 DO jl = 1, jpl 1507 DO jj = 2, jpjm1 1508 DO ji = fs_2, fs_jpim1 ! vector opt. 1509 vCFL = pdt * ABS( pv(ji,jj) ) * r1_e1e2t(ji,jj) 1510 1511 Rjm = zslpy(ji,jj-1,jl) 1512 Rj = zslpy(ji,jj ,jl) 1513 Rjp = zslpy(ji,jj+1,jl) 1514 1515 IF( np_limiter == 3 ) THEN 1516 1517 IF( pv(ji,jj) > 0. ) THEN ; Rr = Rjm 1518 ELSE ; Rr = Rjp 1393 DO_2D_00_00 1394 vCFL = pdt * ABS( pv(ji,jj) ) * r1_e1e2t(ji,jj) 1395 1396 Rjm = zslpy(ji,jj-1,jl) 1397 Rj = zslpy(ji,jj ,jl) 1398 Rjp = zslpy(ji,jj+1,jl) 1399 1400 IF( np_limiter == 3 ) THEN 1401 1402 IF( pv(ji,jj) > 0. ) THEN ; Rr = Rjm 1403 ELSE ; Rr = Rjp 1404 ENDIF 1405 1406 zh3 = pfv_ho(ji,jj,jl) - pfv_ups(ji,jj,jl) 1407 IF( Rj > 0. ) THEN 1408 zlimiter = MAX( 0., MIN( zh3, MAX(-Rr * 0.5 * ABS(pv(ji,jj)), & 1409 & MIN( 2. * Rr * 0.5 * ABS(pv(ji,jj)), zh3, 1.5 * Rj * 0.5 * ABS(pv(ji,jj)) ) ) ) ) 1410 ELSE 1411 zlimiter = -MAX( 0., MIN(-zh3, MAX( Rr * 0.5 * ABS(pv(ji,jj)), & 1412 & MIN(-2. * Rr * 0.5 * ABS(pv(ji,jj)), -zh3, -1.5 * Rj * 0.5 * ABS(pv(ji,jj)) ) ) ) ) 1413 ENDIF 1414 pfv_ho(ji,jj,jl) = pfv_ups(ji,jj,jl) + zlimiter 1415 1416 ELSEIF( np_limiter == 2 ) THEN 1417 1418 IF( Rj /= 0. ) THEN 1419 IF( pv(ji,jj) > 0. ) THEN ; Cr = Rjm / Rj 1420 ELSE ; Cr = Rjp / Rj 1519 1421 ENDIF 1520 1521 zh3 = pfv_ho(ji,jj,jl) - pfv_ups(ji,jj,jl) 1522 IF( Rj > 0. ) THEN 1523 zlimiter = MAX( 0., MIN( zh3, MAX(-Rr * 0.5 * ABS(pv(ji,jj)), & 1524 & MIN( 2. * Rr * 0.5 * ABS(pv(ji,jj)), zh3, 1.5 * Rj * 0.5 * ABS(pv(ji,jj)) ) ) ) ) 1525 ELSE 1526 zlimiter = -MAX( 0., MIN(-zh3, MAX( Rr * 0.5 * ABS(pv(ji,jj)), & 1527 & MIN(-2. * Rr * 0.5 * ABS(pv(ji,jj)), -zh3, -1.5 * Rj * 0.5 * ABS(pv(ji,jj)) ) ) ) ) 1528 ENDIF 1529 pfv_ho(ji,jj,jl) = pfv_ups(ji,jj,jl) + zlimiter 1530 1531 ELSEIF( np_limiter == 2 ) THEN 1532 1533 IF( Rj /= 0. ) THEN 1534 IF( pv(ji,jj) > 0. ) THEN ; Cr = Rjm / Rj 1535 ELSE ; Cr = Rjp / Rj 1536 ENDIF 1537 ELSE 1538 Cr = 0. 1539 ENDIF 1540 1541 ! -- superbee -- 1542 zpsi = MAX( 0., MAX( MIN(1.,2.*Cr), MIN(2.,Cr) ) ) 1543 ! -- van albada 2 -- 1544 !!zpsi = 2.*Cr / (Cr*Cr+1.) 1545 ! -- sweby (with beta=1) -- 1546 !!zpsi = MAX( 0., MAX( MIN(1.,1.*Cr), MIN(1.,Cr) ) ) 1547 ! -- van Leer -- 1548 !!zpsi = ( Cr + ABS(Cr) ) / ( 1. + ABS(Cr) ) 1549 ! -- ospre -- 1550 !!zpsi = 1.5 * ( Cr*Cr + Cr ) / ( Cr*Cr + Cr + 1. ) 1551 ! -- koren -- 1552 !!zpsi = MAX( 0., MIN( 2.*Cr, MIN( (1.+2*Cr)/3., 2. ) ) ) 1553 ! -- charm -- 1554 !IF( Cr > 0. ) THEN ; zpsi = Cr * (3.*Cr + 1.) / ( (Cr + 1.) * (Cr + 1.) ) 1555 !ELSE ; zpsi = 0. 1556 !ENDIF 1557 ! -- van albada 1 -- 1558 !!zpsi = (Cr*Cr + Cr) / (Cr*Cr +1) 1559 ! -- smart -- 1560 !!zpsi = MAX( 0., MIN( 2.*Cr, MIN( 0.25+0.75*Cr, 4. ) ) ) 1561 ! -- umist -- 1562 !!zpsi = MAX( 0., MIN( 2.*Cr, MIN( 0.25+0.75*Cr, MIN(0.75+0.25*Cr, 2. ) ) ) ) 1563 1564 ! high order flux corrected by the limiter 1565 pfv_ho(ji,jj,jl) = pfv_ho(ji,jj,jl) - ABS( pv(ji,jj) ) * ( (1.-zpsi) + vCFL*zpsi ) * Rj * 0.5 1566 1422 ELSE 1423 Cr = 0. 1567 1424 ENDIF 1568 END DO 1569 END DO 1425 1426 ! -- superbee -- 1427 zpsi = MAX( 0., MAX( MIN(1.,2.*Cr), MIN(2.,Cr) ) ) 1428 ! -- van albada 2 -- 1429 !!zpsi = 2.*Cr / (Cr*Cr+1.) 1430 ! -- sweby (with beta=1) -- 1431 !!zpsi = MAX( 0., MAX( MIN(1.,1.*Cr), MIN(1.,Cr) ) ) 1432 ! -- van Leer -- 1433 !!zpsi = ( Cr + ABS(Cr) ) / ( 1. + ABS(Cr) ) 1434 ! -- ospre -- 1435 !!zpsi = 1.5 * ( Cr*Cr + Cr ) / ( Cr*Cr + Cr + 1. ) 1436 ! -- koren -- 1437 !!zpsi = MAX( 0., MIN( 2.*Cr, MIN( (1.+2*Cr)/3., 2. ) ) ) 1438 ! -- charm -- 1439 !IF( Cr > 0. ) THEN ; zpsi = Cr * (3.*Cr + 1.) / ( (Cr + 1.) * (Cr + 1.) ) 1440 !ELSE ; zpsi = 0. 1441 !ENDIF 1442 ! -- van albada 1 -- 1443 !!zpsi = (Cr*Cr + Cr) / (Cr*Cr +1) 1444 ! -- smart -- 1445 !!zpsi = MAX( 0., MIN( 2.*Cr, MIN( 0.25+0.75*Cr, 4. ) ) ) 1446 ! -- umist -- 1447 !!zpsi = MAX( 0., MIN( 2.*Cr, MIN( 0.25+0.75*Cr, MIN(0.75+0.25*Cr, 2. ) ) ) ) 1448 1449 ! high order flux corrected by the limiter 1450 pfv_ho(ji,jj,jl) = pfv_ho(ji,jj,jl) - ABS( pv(ji,jj) ) * ( (1.-zpsi) + vCFL*zpsi ) * Rj * 0.5 1451 1452 ENDIF 1453 END_2D 1570 1454 END DO 1571 1455 CALL lbc_lnk( 'icedyn_adv_umx', pfv_ho, 'V', -1.) ! lateral boundary cond. … … 1604 1488 ! 1605 1489 DO jl = 1, jpl 1606 DO jj = 1, jpj 1607 DO ji = 1, jpi 1608 IF ( pv_i(ji,jj,jl) > 0._wp ) THEN 1490 DO_2D_11_11 1491 IF ( pv_i(ji,jj,jl) > 0._wp ) THEN 1492 ! 1493 ! ! -- check h_ip -- ! 1494 ! if h_ip is larger than the surrounding 9 pts => reduce h_ip and increase a_ip 1495 IF( ln_pnd_LEV .AND. pv_ip(ji,jj,jl) > 0._wp ) THEN 1496 zhip = pv_ip(ji,jj,jl) / MAX( epsi20, pa_ip(ji,jj,jl) ) 1497 IF( zhip > phip_max(ji,jj,jl) .AND. pa_ip(ji,jj,jl) < 0.15 ) THEN 1498 pa_ip(ji,jj,jl) = pv_ip(ji,jj,jl) / phip_max(ji,jj,jl) 1499 ENDIF 1500 ENDIF 1501 ! 1502 ! ! -- check h_i -- ! 1503 ! if h_i is larger than the surrounding 9 pts => reduce h_i and increase a_i 1504 zhi = pv_i(ji,jj,jl) / pa_i(ji,jj,jl) 1505 IF( zhi > phi_max(ji,jj,jl) .AND. pa_i(ji,jj,jl) < 0.15 ) THEN 1506 pa_i(ji,jj,jl) = pv_i(ji,jj,jl) / MIN( phi_max(ji,jj,jl), hi_max(jpl) ) !-- bound h_i to hi_max (99 m) 1507 ENDIF 1508 ! 1509 ! ! -- check h_s -- ! 1510 ! if h_s is larger than the surrounding 9 pts => put the snow excess in the ocean 1511 zhs = pv_s(ji,jj,jl) / pa_i(ji,jj,jl) 1512 IF( pv_s(ji,jj,jl) > 0._wp .AND. zhs > phs_max(ji,jj,jl) .AND. pa_i(ji,jj,jl) < 0.15 ) THEN 1513 zfra = phs_max(ji,jj,jl) / MAX( zhs, epsi20 ) 1609 1514 ! 1610 ! ! -- check h_ip -- ! 1611 ! if h_ip is larger than the surrounding 9 pts => reduce h_ip and increase a_ip 1612 IF( ln_pnd_LEV .AND. pv_ip(ji,jj,jl) > 0._wp ) THEN 1613 zhip = pv_ip(ji,jj,jl) / MAX( epsi20, pa_ip(ji,jj,jl) ) 1614 IF( zhip > phip_max(ji,jj,jl) .AND. pa_ip(ji,jj,jl) < 0.15 ) THEN 1615 pa_ip(ji,jj,jl) = pv_ip(ji,jj,jl) / phip_max(ji,jj,jl) 1616 ENDIF 1617 ENDIF 1515 wfx_res(ji,jj) = wfx_res(ji,jj) + ( pv_s(ji,jj,jl) - pa_i(ji,jj,jl) * phs_max(ji,jj,jl) ) * rhos * z1_dt 1516 hfx_res(ji,jj) = hfx_res(ji,jj) - SUM( pe_s(ji,jj,1:nlay_s,jl) ) * ( 1._wp - zfra ) * z1_dt ! W.m-2 <0 1618 1517 ! 1619 ! ! -- check h_i -- ! 1620 ! if h_i is larger than the surrounding 9 pts => reduce h_i and increase a_i 1621 zhi = pv_i(ji,jj,jl) / pa_i(ji,jj,jl) 1622 IF( zhi > phi_max(ji,jj,jl) .AND. pa_i(ji,jj,jl) < 0.15 ) THEN 1623 pa_i(ji,jj,jl) = pv_i(ji,jj,jl) / MIN( phi_max(ji,jj,jl), hi_max(jpl) ) !-- bound h_i to hi_max (99 m) 1624 ENDIF 1625 ! 1626 ! ! -- check h_s -- ! 1627 ! if h_s is larger than the surrounding 9 pts => put the snow excess in the ocean 1628 zhs = pv_s(ji,jj,jl) / pa_i(ji,jj,jl) 1629 IF( pv_s(ji,jj,jl) > 0._wp .AND. zhs > phs_max(ji,jj,jl) .AND. pa_i(ji,jj,jl) < 0.15 ) THEN 1630 zfra = phs_max(ji,jj,jl) / MAX( zhs, epsi20 ) 1631 ! 1632 wfx_res(ji,jj) = wfx_res(ji,jj) + ( pv_s(ji,jj,jl) - pa_i(ji,jj,jl) * phs_max(ji,jj,jl) ) * rhos * z1_dt 1633 hfx_res(ji,jj) = hfx_res(ji,jj) - SUM( pe_s(ji,jj,1:nlay_s,jl) ) * ( 1._wp - zfra ) * z1_dt ! W.m-2 <0 1634 ! 1635 pe_s(ji,jj,1:nlay_s,jl) = pe_s(ji,jj,1:nlay_s,jl) * zfra 1636 pv_s(ji,jj,jl) = pa_i(ji,jj,jl) * phs_max(ji,jj,jl) 1637 ENDIF 1638 ! 1639 ! ! -- check s_i -- ! 1640 ! if s_i is larger than the surrounding 9 pts => put salt excess in the ocean 1641 zsi = psv_i(ji,jj,jl) / pv_i(ji,jj,jl) 1642 IF( zsi > psi_max(ji,jj,jl) .AND. pa_i(ji,jj,jl) < 0.15 ) THEN 1643 zfra = psi_max(ji,jj,jl) / zsi 1644 sfx_res(ji,jj) = sfx_res(ji,jj) + psv_i(ji,jj,jl) * ( 1._wp - zfra ) * rhoi * z1_dt 1645 psv_i(ji,jj,jl) = psv_i(ji,jj,jl) * zfra 1646 ENDIF 1647 ! 1518 pe_s(ji,jj,1:nlay_s,jl) = pe_s(ji,jj,1:nlay_s,jl) * zfra 1519 pv_s(ji,jj,jl) = pa_i(ji,jj,jl) * phs_max(ji,jj,jl) 1520 ENDIF 1521 ! 1522 ! ! -- check s_i -- ! 1523 ! if s_i is larger than the surrounding 9 pts => put salt excess in the ocean 1524 zsi = psv_i(ji,jj,jl) / pv_i(ji,jj,jl) 1525 IF( zsi > psi_max(ji,jj,jl) .AND. pa_i(ji,jj,jl) < 0.15 ) THEN 1526 zfra = psi_max(ji,jj,jl) / zsi 1527 sfx_res(ji,jj) = sfx_res(ji,jj) + psv_i(ji,jj,jl) * ( 1._wp - zfra ) * rhoi * z1_dt 1528 psv_i(ji,jj,jl) = psv_i(ji,jj,jl) * zfra 1648 1529 ENDIF 1649 END DO 1650 END DO 1530 ! 1531 ENDIF 1532 END_2D 1651 1533 END DO 1652 1534 ! 1653 1535 ! ! -- check e_i/v_i -- ! 1654 1536 DO jl = 1, jpl 1655 DO jk = 1, nlay_i 1656 DO jj = 1, jpj 1657 DO ji = 1, jpi 1658 IF ( pv_i(ji,jj,jl) > 0._wp ) THEN 1659 ! if e_i/v_i is larger than the surrounding 9 pts => put the heat excess in the ocean 1660 zei = pe_i(ji,jj,jk,jl) / pv_i(ji,jj,jl) 1661 IF( zei > pei_max(ji,jj,jk,jl) .AND. pa_i(ji,jj,jl) < 0.15 ) THEN 1662 zfra = pei_max(ji,jj,jk,jl) / zei 1663 hfx_res(ji,jj) = hfx_res(ji,jj) - pe_i(ji,jj,jk,jl) * ( 1._wp - zfra ) * z1_dt ! W.m-2 <0 1664 pe_i(ji,jj,jk,jl) = pe_i(ji,jj,jk,jl) * zfra 1665 ENDIF 1666 ENDIF 1667 END DO 1668 END DO 1669 END DO 1537 DO_3D_11_11( 1, nlay_i ) 1538 IF ( pv_i(ji,jj,jl) > 0._wp ) THEN 1539 ! if e_i/v_i is larger than the surrounding 9 pts => put the heat excess in the ocean 1540 zei = pe_i(ji,jj,jk,jl) / pv_i(ji,jj,jl) 1541 IF( zei > pei_max(ji,jj,jk,jl) .AND. pa_i(ji,jj,jl) < 0.15 ) THEN 1542 zfra = pei_max(ji,jj,jk,jl) / zei 1543 hfx_res(ji,jj) = hfx_res(ji,jj) - pe_i(ji,jj,jk,jl) * ( 1._wp - zfra ) * z1_dt ! W.m-2 <0 1544 pe_i(ji,jj,jk,jl) = pe_i(ji,jj,jk,jl) * zfra 1545 ENDIF 1546 ENDIF 1547 END_3D 1670 1548 END DO 1671 1549 ! ! -- check e_s/v_s -- ! 1672 1550 DO jl = 1, jpl 1673 DO jk = 1, nlay_s 1674 DO jj = 1, jpj 1675 DO ji = 1, jpi 1676 IF ( pv_s(ji,jj,jl) > 0._wp ) THEN 1677 ! if e_s/v_s is larger than the surrounding 9 pts => put the heat excess in the ocean 1678 zes = pe_s(ji,jj,jk,jl) / pv_s(ji,jj,jl) 1679 IF( zes > pes_max(ji,jj,jk,jl) .AND. pa_i(ji,jj,jl) < 0.15 ) THEN 1680 zfra = pes_max(ji,jj,jk,jl) / zes 1681 hfx_res(ji,jj) = hfx_res(ji,jj) - pe_s(ji,jj,jk,jl) * ( 1._wp - zfra ) * z1_dt ! W.m-2 <0 1682 pe_s(ji,jj,jk,jl) = pe_s(ji,jj,jk,jl) * zfra 1683 ENDIF 1684 ENDIF 1685 END DO 1686 END DO 1687 END DO 1551 DO_3D_11_11( 1, nlay_s ) 1552 IF ( pv_s(ji,jj,jl) > 0._wp ) THEN 1553 ! if e_s/v_s is larger than the surrounding 9 pts => put the heat excess in the ocean 1554 zes = pe_s(ji,jj,jk,jl) / pv_s(ji,jj,jl) 1555 IF( zes > pes_max(ji,jj,jk,jl) .AND. pa_i(ji,jj,jl) < 0.15 ) THEN 1556 zfra = pes_max(ji,jj,jk,jl) / zes 1557 hfx_res(ji,jj) = hfx_res(ji,jj) - pe_s(ji,jj,jk,jl) * ( 1._wp - zfra ) * z1_dt ! W.m-2 <0 1558 pe_s(ji,jj,jk,jl) = pe_s(ji,jj,jk,jl) * zfra 1559 ENDIF 1560 ENDIF 1561 END_3D 1688 1562 END DO 1689 1563 ! … … 1718 1592 ! -- check snow load -- ! 1719 1593 DO jl = 1, jpl 1720 DO jj = 1, jpj 1721 DO ji = 1, jpi 1722 IF ( pv_i(ji,jj,jl) > 0._wp ) THEN 1723 ! 1724 zvs_excess = MAX( 0._wp, pv_s(ji,jj,jl) - pv_i(ji,jj,jl) * (rau0-rhoi) * r1_rhos ) 1725 ! 1726 IF( zvs_excess > 0._wp ) THEN ! snow-ice interface deplets below the ocean surface 1727 ! put snow excess in the ocean 1728 zfra = ( pv_s(ji,jj,jl) - zvs_excess ) / MAX( pv_s(ji,jj,jl), epsi20 ) 1729 wfx_res(ji,jj) = wfx_res(ji,jj) + zvs_excess * rhos * z1_dt 1730 hfx_res(ji,jj) = hfx_res(ji,jj) - SUM( pe_s(ji,jj,1:nlay_s,jl) ) * ( 1._wp - zfra ) * z1_dt ! W.m-2 <0 1731 ! correct snow volume and heat content 1732 pe_s(ji,jj,1:nlay_s,jl) = pe_s(ji,jj,1:nlay_s,jl) * zfra 1733 pv_s(ji,jj,jl) = pv_s(ji,jj,jl) - zvs_excess 1734 ENDIF 1735 ! 1594 DO_2D_11_11 1595 IF ( pv_i(ji,jj,jl) > 0._wp ) THEN 1596 ! 1597 zvs_excess = MAX( 0._wp, pv_s(ji,jj,jl) - pv_i(ji,jj,jl) * (rau0-rhoi) * r1_rhos ) 1598 ! 1599 IF( zvs_excess > 0._wp ) THEN ! snow-ice interface deplets below the ocean surface 1600 ! put snow excess in the ocean 1601 zfra = ( pv_s(ji,jj,jl) - zvs_excess ) / MAX( pv_s(ji,jj,jl), epsi20 ) 1602 wfx_res(ji,jj) = wfx_res(ji,jj) + zvs_excess * rhos * z1_dt 1603 hfx_res(ji,jj) = hfx_res(ji,jj) - SUM( pe_s(ji,jj,1:nlay_s,jl) ) * ( 1._wp - zfra ) * z1_dt ! W.m-2 <0 1604 ! correct snow volume and heat content 1605 pe_s(ji,jj,1:nlay_s,jl) = pe_s(ji,jj,1:nlay_s,jl) * zfra 1606 pv_s(ji,jj,jl) = pv_s(ji,jj,jl) - zvs_excess 1736 1607 ENDIF 1737 END DO 1738 END DO 1608 ! 1609 ENDIF 1610 END_2D 1739 1611 END DO 1740 1612 ! -
NEMO/branches/2020/temporary_r4_trunk/src/ICE/icedyn_rdgrft.F90
r13466 r13469 159 159 npti = 0 ; nptidx(:) = 0 160 160 ipti = 0 ; iptidx(:) = 0 161 DO jj = 1, jpj 162 DO ji = 1, jpi 163 IF ( at_i(ji,jj) > epsi10 ) THEN 164 npti = npti + 1 165 nptidx( npti ) = (jj - 1) * jpi + ji 166 ENDIF 167 END DO 168 END DO 161 DO_2D_11_11 162 IF ( at_i(ji,jj) > epsi10 ) THEN 163 npti = npti + 1 164 nptidx( npti ) = (jj - 1) * jpi + ji 165 ENDIF 166 END_2D 169 167 170 168 !-------------------------------------------------------- … … 777 775 ! !--------------------------------------------------! 778 776 CASE( 1 ) !--- Spatial smoothing 779 DO jj = 2, jpjm1 780 DO ji = 2, jpim1 781 IF ( SUM( a_i(ji,jj,:) ) > 0._wp ) THEN 782 zworka(ji,jj) = ( 4.0 * strength(ji,jj) & 783 & + strength(ji-1,jj) * tmask(ji-1,jj,1) + strength(ji+1,jj) * tmask(ji+1,jj,1) & 784 & + strength(ji,jj-1) * tmask(ji,jj-1,1) + strength(ji,jj+1) * tmask(ji,jj+1,1) & 785 & ) / ( 4.0 + tmask(ji-1,jj,1) + tmask(ji+1,jj,1) + tmask(ji,jj-1,1) + tmask(ji,jj+1,1) ) 786 ELSE 787 zworka(ji,jj) = 0._wp 788 ENDIF 789 END DO 790 END DO 777 DO_2D_00_00 778 IF ( SUM( a_i(ji,jj,:) ) > 0._wp ) THEN 779 zworka(ji,jj) = ( 4.0 * strength(ji,jj) & 780 & + strength(ji-1,jj) * tmask(ji-1,jj,1) + strength(ji+1,jj) * tmask(ji+1,jj,1) & 781 & + strength(ji,jj-1) * tmask(ji,jj-1,1) + strength(ji,jj+1) * tmask(ji,jj+1,1) & 782 & ) / ( 4.0 + tmask(ji-1,jj,1) + tmask(ji+1,jj,1) + tmask(ji,jj-1,1) + tmask(ji,jj+1,1) ) 783 ELSE 784 zworka(ji,jj) = 0._wp 785 ENDIF 786 END_2D 791 787 792 DO jj = 2, jpjm1 793 DO ji = 2, jpim1 794 strength(ji,jj) = zworka(ji,jj) 795 END DO 796 END DO 788 DO_2D_00_00 789 strength(ji,jj) = zworka(ji,jj) 790 END_2D 797 791 CALL lbc_lnk( 'icedyn_rdgrft', strength, 'T', 1. ) 798 792 ! … … 803 797 ENDIF 804 798 ! 805 DO jj = 2, jpjm1 806 DO ji = 2, jpim1 807 IF ( SUM( a_i(ji,jj,:) ) > 0._wp ) THEN 808 itframe = 1 ! number of time steps for the running mean 809 IF ( zstrp1(ji,jj) > 0._wp ) itframe = itframe + 1 810 IF ( zstrp2(ji,jj) > 0._wp ) itframe = itframe + 1 811 zp = ( strength(ji,jj) + zstrp1(ji,jj) + zstrp2(ji,jj) ) / itframe 812 zstrp2 (ji,jj) = zstrp1 (ji,jj) 813 zstrp1 (ji,jj) = strength(ji,jj) 814 strength(ji,jj) = zp 815 ENDIF 816 END DO 817 END DO 799 DO_2D_00_00 800 IF ( SUM( a_i(ji,jj,:) ) > 0._wp ) THEN 801 itframe = 1 ! number of time steps for the running mean 802 IF ( zstrp1(ji,jj) > 0._wp ) itframe = itframe + 1 803 IF ( zstrp2(ji,jj) > 0._wp ) itframe = itframe + 1 804 zp = ( strength(ji,jj) + zstrp1(ji,jj) + zstrp2(ji,jj) ) / itframe 805 zstrp2 (ji,jj) = zstrp1 (ji,jj) 806 zstrp1 (ji,jj) = strength(ji,jj) 807 strength(ji,jj) = zp 808 ENDIF 809 END_2D 818 810 CALL lbc_lnk( 'icedyn_rdgrft', strength, 'T', 1. ) 819 811 ! -
NEMO/branches/2020/temporary_r4_trunk/src/ICE/icedyn_rhg_evp.F90
r13467 r13469 182 182 ! for diagnostics and convergence tests 183 183 ALLOCATE( zmsk00(jpi,jpj), zmsk15(jpi,jpj) ) 184 DO jj = 1, jpj 185 DO ji = 1, jpi 186 zmsk00(ji,jj) = MAX( 0._wp , SIGN( 1._wp , at_i(ji,jj) - epsi06 ) ) ! 1 if ice , 0 if no ice 187 zmsk15(ji,jj) = MAX( 0._wp , SIGN( 1._wp , at_i(ji,jj) - 0.15_wp ) ) ! 1 if 15% ice, 0 if less 188 END DO 189 END DO 184 DO_2D_11_11 185 zmsk00(ji,jj) = MAX( 0._wp , SIGN( 1._wp , at_i(ji,jj) - epsi06 ) ) ! 1 if ice , 0 if no ice 186 zmsk15(ji,jj) = MAX( 0._wp , SIGN( 1._wp , at_i(ji,jj) - 0.15_wp ) ) ! 1 if 15% ice, 0 if less 187 END_2D 190 188 ! 191 189 !!gm for Clem: OPTIMIZATION: I think zfmask can be computed one for all at the initialization.... … … 194 192 !------------------------------------------------------------------------------! 195 193 ! ocean/land mask 196 DO jj = 1, jpjm1 197 DO ji = 1, jpim1 ! NO vector opt. 198 zfmask(ji,jj) = tmask(ji,jj,1) * tmask(ji+1,jj,1) * tmask(ji,jj+1,1) * tmask(ji+1,jj+1,1) 199 END DO 200 END DO 194 DO_2D_10_10 195 zfmask(ji,jj) = tmask(ji,jj,1) * tmask(ji+1,jj,1) * tmask(ji,jj+1,1) * tmask(ji+1,jj+1,1) 196 END_2D 201 197 CALL lbc_lnk( 'icedyn_rhg_evp', zfmask, 'F', 1._wp ) 202 198 203 199 ! Lateral boundary conditions on velocity (modify zfmask) 204 DO jj = 2, jpjm1 205 DO ji = fs_2, fs_jpim1 ! vector opt. 206 IF( zfmask(ji,jj) == 0._wp ) THEN 207 zfmask(ji,jj) = rn_ishlat * MIN( 1._wp , MAX( umask(ji,jj,1), umask(ji,jj+1,1), & 208 & vmask(ji,jj,1), vmask(ji+1,jj,1) ) ) 209 ENDIF 210 END DO 211 END DO 200 DO_2D_00_00 201 IF( zfmask(ji,jj) == 0._wp ) THEN 202 zfmask(ji,jj) = rn_ishlat * MIN( 1._wp , MAX( umask(ji,jj,1), umask(ji,jj+1,1), & 203 & vmask(ji,jj,1), vmask(ji+1,jj,1) ) ) 204 ENDIF 205 END_2D 212 206 DO jj = 2, jpjm1 213 207 IF( zfmask(1,jj) == 0._wp ) THEN … … 272 266 zsshdyn(:,:) = ice_var_sshdyn( ssh_m, snwice_mass, snwice_mass_b) 273 267 274 DO jj = 2, jpjm1 275 DO ji = fs_2, fs_jpim1 276 277 ! ice fraction at U-V points 278 zaU(ji,jj) = 0.5_wp * ( at_i(ji,jj) * e1e2t(ji,jj) + at_i(ji+1,jj) * e1e2t(ji+1,jj) ) * r1_e1e2u(ji,jj) * umask(ji,jj,1) 279 zaV(ji,jj) = 0.5_wp * ( at_i(ji,jj) * e1e2t(ji,jj) + at_i(ji,jj+1) * e1e2t(ji,jj+1) ) * r1_e1e2v(ji,jj) * vmask(ji,jj,1) 280 281 ! Ice/snow mass at U-V points 282 zm1 = ( rhos * vt_s(ji ,jj ) + rhoi * vt_i(ji ,jj ) ) 283 zm2 = ( rhos * vt_s(ji+1,jj ) + rhoi * vt_i(ji+1,jj ) ) 284 zm3 = ( rhos * vt_s(ji ,jj+1) + rhoi * vt_i(ji ,jj+1) ) 285 zmassU = 0.5_wp * ( zm1 * e1e2t(ji,jj) + zm2 * e1e2t(ji+1,jj) ) * r1_e1e2u(ji,jj) * umask(ji,jj,1) 286 zmassV = 0.5_wp * ( zm1 * e1e2t(ji,jj) + zm3 * e1e2t(ji,jj+1) ) * r1_e1e2v(ji,jj) * vmask(ji,jj,1) 287 288 ! Ocean currents at U-V points 289 v_oceU(ji,jj) = 0.25_wp * ( v_oce(ji,jj) + v_oce(ji,jj-1) + v_oce(ji+1,jj) + v_oce(ji+1,jj-1) ) * umask(ji,jj,1) 290 u_oceV(ji,jj) = 0.25_wp * ( u_oce(ji,jj) + u_oce(ji-1,jj) + u_oce(ji,jj+1) + u_oce(ji-1,jj+1) ) * vmask(ji,jj,1) 291 292 ! Coriolis at T points (m*f) 293 zmf(ji,jj) = zm1 * ff_t(ji,jj) 294 295 ! dt/m at T points (for alpha and beta coefficients) 296 zdt_m(ji,jj) = zdtevp / MAX( zm1, zmmin ) 297 298 ! m/dt 299 zmU_t(ji,jj) = zmassU * z1_dtevp 300 zmV_t(ji,jj) = zmassV * z1_dtevp 301 302 ! Drag ice-atm. 303 ztaux_ai(ji,jj) = zaU(ji,jj) * utau_ice(ji,jj) 304 ztauy_ai(ji,jj) = zaV(ji,jj) * vtau_ice(ji,jj) 305 306 ! Surface pressure gradient (- m*g*GRAD(ssh)) at U-V points 307 zspgU(ji,jj) = - zmassU * grav * ( zsshdyn(ji+1,jj) - zsshdyn(ji,jj) ) * r1_e1u(ji,jj) 308 zspgV(ji,jj) = - zmassV * grav * ( zsshdyn(ji,jj+1) - zsshdyn(ji,jj) ) * r1_e2v(ji,jj) 309 310 ! masks 311 zmsk00x(ji,jj) = 1._wp - MAX( 0._wp, SIGN( 1._wp, -zmassU ) ) ! 0 if no ice 312 zmsk00y(ji,jj) = 1._wp - MAX( 0._wp, SIGN( 1._wp, -zmassV ) ) ! 0 if no ice 313 314 ! switches 315 IF( zmassU <= zmmin .AND. zaU(ji,jj) <= zamin ) THEN ; zmsk01x(ji,jj) = 0._wp 316 ELSE ; zmsk01x(ji,jj) = 1._wp ; ENDIF 317 IF( zmassV <= zmmin .AND. zaV(ji,jj) <= zamin ) THEN ; zmsk01y(ji,jj) = 0._wp 318 ELSE ; zmsk01y(ji,jj) = 1._wp ; ENDIF 319 320 END DO 321 END DO 268 DO_2D_00_00 269 270 ! ice fraction at U-V points 271 zaU(ji,jj) = 0.5_wp * ( at_i(ji,jj) * e1e2t(ji,jj) + at_i(ji+1,jj) * e1e2t(ji+1,jj) ) * r1_e1e2u(ji,jj) * umask(ji,jj,1) 272 zaV(ji,jj) = 0.5_wp * ( at_i(ji,jj) * e1e2t(ji,jj) + at_i(ji,jj+1) * e1e2t(ji,jj+1) ) * r1_e1e2v(ji,jj) * vmask(ji,jj,1) 273 274 ! Ice/snow mass at U-V points 275 zm1 = ( rhos * vt_s(ji ,jj ) + rhoi * vt_i(ji ,jj ) ) 276 zm2 = ( rhos * vt_s(ji+1,jj ) + rhoi * vt_i(ji+1,jj ) ) 277 zm3 = ( rhos * vt_s(ji ,jj+1) + rhoi * vt_i(ji ,jj+1) ) 278 zmassU = 0.5_wp * ( zm1 * e1e2t(ji,jj) + zm2 * e1e2t(ji+1,jj) ) * r1_e1e2u(ji,jj) * umask(ji,jj,1) 279 zmassV = 0.5_wp * ( zm1 * e1e2t(ji,jj) + zm3 * e1e2t(ji,jj+1) ) * r1_e1e2v(ji,jj) * vmask(ji,jj,1) 280 281 ! Ocean currents at U-V points 282 v_oceU(ji,jj) = 0.25_wp * ( v_oce(ji,jj) + v_oce(ji,jj-1) + v_oce(ji+1,jj) + v_oce(ji+1,jj-1) ) * umask(ji,jj,1) 283 u_oceV(ji,jj) = 0.25_wp * ( u_oce(ji,jj) + u_oce(ji-1,jj) + u_oce(ji,jj+1) + u_oce(ji-1,jj+1) ) * vmask(ji,jj,1) 284 285 ! Coriolis at T points (m*f) 286 zmf(ji,jj) = zm1 * ff_t(ji,jj) 287 288 ! dt/m at T points (for alpha and beta coefficients) 289 zdt_m(ji,jj) = zdtevp / MAX( zm1, zmmin ) 290 291 ! m/dt 292 zmU_t(ji,jj) = zmassU * z1_dtevp 293 zmV_t(ji,jj) = zmassV * z1_dtevp 294 295 ! Drag ice-atm. 296 ztaux_ai(ji,jj) = zaU(ji,jj) * utau_ice(ji,jj) 297 ztauy_ai(ji,jj) = zaV(ji,jj) * vtau_ice(ji,jj) 298 299 ! Surface pressure gradient (- m*g*GRAD(ssh)) at U-V points 300 zspgU(ji,jj) = - zmassU * grav * ( zsshdyn(ji+1,jj) - zsshdyn(ji,jj) ) * r1_e1u(ji,jj) 301 zspgV(ji,jj) = - zmassV * grav * ( zsshdyn(ji,jj+1) - zsshdyn(ji,jj) ) * r1_e2v(ji,jj) 302 303 ! masks 304 zmsk00x(ji,jj) = 1._wp - MAX( 0._wp, SIGN( 1._wp, -zmassU ) ) ! 0 if no ice 305 zmsk00y(ji,jj) = 1._wp - MAX( 0._wp, SIGN( 1._wp, -zmassV ) ) ! 0 if no ice 306 307 ! switches 308 IF( zmassU <= zmmin .AND. zaU(ji,jj) <= zamin ) THEN ; zmsk01x(ji,jj) = 0._wp 309 ELSE ; zmsk01x(ji,jj) = 1._wp ; ENDIF 310 IF( zmassV <= zmmin .AND. zaV(ji,jj) <= zamin ) THEN ; zmsk01y(ji,jj) = 0._wp 311 ELSE ; zmsk01y(ji,jj) = 1._wp ; ENDIF 312 313 END_2D 322 314 CALL lbc_lnk_multi( 'icedyn_rhg_evp', zmf, 'T', 1., zdt_m, 'T', 1. ) 323 315 ! … … 325 317 ! 326 318 IF( ln_landfast_L16 ) THEN !-- Lemieux 2016 327 DO jj = 2, jpjm1 328 DO ji = fs_2, fs_jpim1 329 ! ice thickness at U-V points 330 zvU = 0.5_wp * ( vt_i(ji,jj) * e1e2t(ji,jj) + vt_i(ji+1,jj) * e1e2t(ji+1,jj) ) * r1_e1e2u(ji,jj) * umask(ji,jj,1) 331 zvV = 0.5_wp * ( vt_i(ji,jj) * e1e2t(ji,jj) + vt_i(ji,jj+1) * e1e2t(ji,jj+1) ) * r1_e1e2v(ji,jj) * vmask(ji,jj,1) 332 ! ice-bottom stress at U points 333 zvCr = zaU(ji,jj) * rn_lf_depfra * hu_n(ji,jj) 334 ztaux_base(ji,jj) = - rn_lf_bfr * MAX( 0._wp, zvU - zvCr ) * EXP( -rn_crhg * ( 1._wp - zaU(ji,jj) ) ) 335 ! ice-bottom stress at V points 336 zvCr = zaV(ji,jj) * rn_lf_depfra * hv_n(ji,jj) 337 ztauy_base(ji,jj) = - rn_lf_bfr * MAX( 0._wp, zvV - zvCr ) * EXP( -rn_crhg * ( 1._wp - zaV(ji,jj) ) ) 338 ! ice_bottom stress at T points 339 zvCr = at_i(ji,jj) * rn_lf_depfra * ht_n(ji,jj) 340 tau_icebfr(ji,jj) = - rn_lf_bfr * MAX( 0._wp, vt_i(ji,jj) - zvCr ) * EXP( -rn_crhg * ( 1._wp - at_i(ji,jj) ) ) 341 END DO 342 END DO 319 DO_2D_00_00 320 ! ice thickness at U-V points 321 zvU = 0.5_wp * ( vt_i(ji,jj) * e1e2t(ji,jj) + vt_i(ji+1,jj) * e1e2t(ji+1,jj) ) * r1_e1e2u(ji,jj) * umask(ji,jj,1) 322 zvV = 0.5_wp * ( vt_i(ji,jj) * e1e2t(ji,jj) + vt_i(ji,jj+1) * e1e2t(ji,jj+1) ) * r1_e1e2v(ji,jj) * vmask(ji,jj,1) 323 ! ice-bottom stress at U points 324 zvCr = zaU(ji,jj) * rn_lf_depfra * hu_n(ji,jj) 325 ztaux_base(ji,jj) = - rn_lf_bfr * MAX( 0._wp, zvU - zvCr ) * EXP( -rn_crhg * ( 1._wp - zaU(ji,jj) ) ) 326 ! ice-bottom stress at V points 327 zvCr = zaV(ji,jj) * rn_lf_depfra * hv_n(ji,jj) 328 ztauy_base(ji,jj) = - rn_lf_bfr * MAX( 0._wp, zvV - zvCr ) * EXP( -rn_crhg * ( 1._wp - zaV(ji,jj) ) ) 329 ! ice_bottom stress at T points 330 zvCr = at_i(ji,jj) * rn_lf_depfra * ht_n(ji,jj) 331 tau_icebfr(ji,jj) = - rn_lf_bfr * MAX( 0._wp, vt_i(ji,jj) - zvCr ) * EXP( -rn_crhg * ( 1._wp - at_i(ji,jj) ) ) 332 END_2D 343 333 CALL lbc_lnk( 'icedyn_rhg_evp', tau_icebfr(:,:), 'T', 1. ) 344 334 ! 345 335 ELSE !-- no landfast 346 DO jj = 2, jpjm1 347 DO ji = fs_2, fs_jpim1 348 ztaux_base(ji,jj) = 0._wp 349 ztauy_base(ji,jj) = 0._wp 350 END DO 351 END DO 336 DO_2D_00_00 337 ztaux_base(ji,jj) = 0._wp 338 ztauy_base(ji,jj) = 0._wp 339 END_2D 352 340 ENDIF 353 341 … … 363 351 ! convergence test 364 352 IF( nn_rhg_chkcvg == 1 .OR. nn_rhg_chkcvg == 2 ) THEN 365 DO jj = 1, jpj 366 DO ji = 1, jpi 367 zu_ice(ji,jj) = u_ice(ji,jj) * umask(ji,jj,1) ! velocity at previous time step 368 zv_ice(ji,jj) = v_ice(ji,jj) * vmask(ji,jj,1) 369 END DO 370 END DO 353 DO_2D_11_11 354 zu_ice(ji,jj) = u_ice(ji,jj) * umask(ji,jj,1) ! velocity at previous time step 355 zv_ice(ji,jj) = v_ice(ji,jj) * vmask(ji,jj,1) 356 END_2D 371 357 ENDIF 372 358 373 359 ! --- divergence, tension & shear (Appendix B of Hunke & Dukowicz, 2002) --- ! 374 DO jj = 1, jpjm1 ! loops start at 1 since there is no boundary condition (lbc_lnk) at i=1 and j=1 for F points 375 DO ji = 1, jpim1 376 377 ! shear at F points 378 zds(ji,jj) = ( ( u_ice(ji,jj+1) * r1_e1u(ji,jj+1) - u_ice(ji,jj) * r1_e1u(ji,jj) ) * e1f(ji,jj) * e1f(ji,jj) & 379 & + ( v_ice(ji+1,jj) * r1_e2v(ji+1,jj) - v_ice(ji,jj) * r1_e2v(ji,jj) ) * e2f(ji,jj) * e2f(ji,jj) & 380 & ) * r1_e1e2f(ji,jj) * zfmask(ji,jj) 381 382 END DO 383 END DO 360 DO_2D_10_10 361 362 ! shear at F points 363 zds(ji,jj) = ( ( u_ice(ji,jj+1) * r1_e1u(ji,jj+1) - u_ice(ji,jj) * r1_e1u(ji,jj) ) * e1f(ji,jj) * e1f(ji,jj) & 364 & + ( v_ice(ji+1,jj) * r1_e2v(ji+1,jj) - v_ice(ji,jj) * r1_e2v(ji,jj) ) * e2f(ji,jj) * e2f(ji,jj) & 365 & ) * r1_e1e2f(ji,jj) * zfmask(ji,jj) 366 367 END_2D 384 368 CALL lbc_lnk( 'icedyn_rhg_evp', zds, 'F', 1. ) 385 369 386 DO jj = 2, jpj ! loop to jpi,jpj to avoid making a communication for zs1,zs2,zs12 387 DO ji = 2, jpi ! no vector loop 388 389 ! shear**2 at T points (doc eq. A16) 390 zds2 = ( zds(ji,jj ) * zds(ji,jj ) * e1e2f(ji,jj ) + zds(ji-1,jj ) * zds(ji-1,jj ) * e1e2f(ji-1,jj ) & 391 & + zds(ji,jj-1) * zds(ji,jj-1) * e1e2f(ji,jj-1) + zds(ji-1,jj-1) * zds(ji-1,jj-1) * e1e2f(ji-1,jj-1) & 392 & ) * 0.25_wp * r1_e1e2t(ji,jj) 393 394 ! divergence at T points 395 zdiv = ( e2u(ji,jj) * u_ice(ji,jj) - e2u(ji-1,jj) * u_ice(ji-1,jj) & 396 & + e1v(ji,jj) * v_ice(ji,jj) - e1v(ji,jj-1) * v_ice(ji,jj-1) & 397 & ) * r1_e1e2t(ji,jj) 398 zdiv2 = zdiv * zdiv 399 400 ! tension at T points 401 zdt = ( ( u_ice(ji,jj) * r1_e2u(ji,jj) - u_ice(ji-1,jj) * r1_e2u(ji-1,jj) ) * e2t(ji,jj) * e2t(ji,jj) & 402 & - ( v_ice(ji,jj) * r1_e1v(ji,jj) - v_ice(ji,jj-1) * r1_e1v(ji,jj-1) ) * e1t(ji,jj) * e1t(ji,jj) & 403 & ) * r1_e1e2t(ji,jj) 404 zdt2 = zdt * zdt 405 406 ! delta at T points 407 zdelta = SQRT( zdiv2 + ( zdt2 + zds2 ) * z1_ecc2 ) 408 409 ! P/delta at T points 410 zp_delt(ji,jj) = strength(ji,jj) / ( zdelta + rn_creepl ) 411 412 ! alpha for aEVP 413 ! gamma = 0.5*P/(delta+creepl) * (c*pi)**2/Area * dt/m 414 ! alpha = beta = sqrt(4*gamma) 415 IF( ln_aEVP ) THEN 416 zalph1 = MAX( 50._wp, rpi * SQRT( 0.5_wp * zp_delt(ji,jj) * r1_e1e2t(ji,jj) * zdt_m(ji,jj) ) ) 417 z1_alph1 = 1._wp / ( zalph1 + 1._wp ) 418 zalph2 = zalph1 419 z1_alph2 = z1_alph1 420 ! explicit: 421 ! z1_alph1 = 1._wp / zalph1 422 ! z1_alph2 = 1._wp / zalph1 423 ! zalph1 = zalph1 - 1._wp 424 ! zalph2 = zalph1 425 ENDIF 426 427 ! stress at T points (zkt/=0 if landfast) 428 zs1(ji,jj) = ( zs1(ji,jj) * zalph1 + zp_delt(ji,jj) * ( zdiv * (1._wp + zkt) - zdelta * (1._wp - zkt) ) ) * z1_alph1 429 zs2(ji,jj) = ( zs2(ji,jj) * zalph2 + zp_delt(ji,jj) * ( zdt * z1_ecc2 * (1._wp + zkt) ) ) * z1_alph2 430 431 END DO 432 END DO 370 DO_2D_01_01 371 372 ! shear**2 at T points (doc eq. A16) 373 zds2 = ( zds(ji,jj ) * zds(ji,jj ) * e1e2f(ji,jj ) + zds(ji-1,jj ) * zds(ji-1,jj ) * e1e2f(ji-1,jj ) & 374 & + zds(ji,jj-1) * zds(ji,jj-1) * e1e2f(ji,jj-1) + zds(ji-1,jj-1) * zds(ji-1,jj-1) * e1e2f(ji-1,jj-1) & 375 & ) * 0.25_wp * r1_e1e2t(ji,jj) 376 377 ! divergence at T points 378 zdiv = ( e2u(ji,jj) * u_ice(ji,jj) - e2u(ji-1,jj) * u_ice(ji-1,jj) & 379 & + e1v(ji,jj) * v_ice(ji,jj) - e1v(ji,jj-1) * v_ice(ji,jj-1) & 380 & ) * r1_e1e2t(ji,jj) 381 zdiv2 = zdiv * zdiv 382 383 ! tension at T points 384 zdt = ( ( u_ice(ji,jj) * r1_e2u(ji,jj) - u_ice(ji-1,jj) * r1_e2u(ji-1,jj) ) * e2t(ji,jj) * e2t(ji,jj) & 385 & - ( v_ice(ji,jj) * r1_e1v(ji,jj) - v_ice(ji,jj-1) * r1_e1v(ji,jj-1) ) * e1t(ji,jj) * e1t(ji,jj) & 386 & ) * r1_e1e2t(ji,jj) 387 zdt2 = zdt * zdt 388 389 ! delta at T points 390 zdelta = SQRT( zdiv2 + ( zdt2 + zds2 ) * z1_ecc2 ) 391 392 ! P/delta at T points 393 zp_delt(ji,jj) = strength(ji,jj) / ( zdelta + rn_creepl ) 394 395 ! alpha for aEVP 396 ! gamma = 0.5*P/(delta+creepl) * (c*pi)**2/Area * dt/m 397 ! alpha = beta = sqrt(4*gamma) 398 IF( ln_aEVP ) THEN 399 zalph1 = MAX( 50._wp, rpi * SQRT( 0.5_wp * zp_delt(ji,jj) * r1_e1e2t(ji,jj) * zdt_m(ji,jj) ) ) 400 z1_alph1 = 1._wp / ( zalph1 + 1._wp ) 401 zalph2 = zalph1 402 z1_alph2 = z1_alph1 403 ! explicit: 404 ! z1_alph1 = 1._wp / zalph1 405 ! z1_alph2 = 1._wp / zalph1 406 ! zalph1 = zalph1 - 1._wp 407 ! zalph2 = zalph1 408 ENDIF 409 410 ! stress at T points (zkt/=0 if landfast) 411 zs1(ji,jj) = ( zs1(ji,jj) * zalph1 + zp_delt(ji,jj) * ( zdiv * (1._wp + zkt) - zdelta * (1._wp - zkt) ) ) * z1_alph1 412 zs2(ji,jj) = ( zs2(ji,jj) * zalph2 + zp_delt(ji,jj) * ( zdt * z1_ecc2 * (1._wp + zkt) ) ) * z1_alph2 413 414 END_2D 433 415 CALL lbc_lnk( 'icedyn_rhg_evp', zp_delt, 'T', 1. ) 434 416 435 417 ! Save beta at T-points for further computations 436 418 IF( ln_aEVP ) THEN 437 DO jj = 1, jpj 438 DO ji = 1, jpi 439 zbeta(ji,jj) = MAX( 50._wp, rpi * SQRT( 0.5_wp * zp_delt(ji,jj) * r1_e1e2t(ji,jj) * zdt_m(ji,jj) ) ) 440 END DO 441 END DO 419 DO_2D_11_11 420 zbeta(ji,jj) = MAX( 50._wp, rpi * SQRT( 0.5_wp * zp_delt(ji,jj) * r1_e1e2t(ji,jj) * zdt_m(ji,jj) ) ) 421 END_2D 442 422 ENDIF 443 423 444 DO jj = 1, jpjm1 445 DO ji = 1, jpim1 446 447 ! alpha for aEVP 448 IF( ln_aEVP ) THEN 449 zalph2 = MAX( zbeta(ji,jj), zbeta(ji+1,jj), zbeta(ji,jj+1), zbeta(ji+1,jj+1) ) 450 z1_alph2 = 1._wp / ( zalph2 + 1._wp ) 451 ! explicit: 452 ! z1_alph2 = 1._wp / zalph2 453 ! zalph2 = zalph2 - 1._wp 454 ENDIF 455 456 ! P/delta at F points 457 zp_delf = 0.25_wp * ( zp_delt(ji,jj) + zp_delt(ji+1,jj) + zp_delt(ji,jj+1) + zp_delt(ji+1,jj+1) ) 458 459 ! stress at F points (zkt/=0 if landfast) 460 zs12(ji,jj)= ( zs12(ji,jj) * zalph2 + zp_delf * ( zds(ji,jj) * z1_ecc2 * (1._wp + zkt) ) * 0.5_wp ) * z1_alph2 461 462 END DO 463 END DO 424 DO_2D_10_10 425 426 ! alpha for aEVP 427 IF( ln_aEVP ) THEN 428 zalph2 = MAX( zbeta(ji,jj), zbeta(ji+1,jj), zbeta(ji,jj+1), zbeta(ji+1,jj+1) ) 429 z1_alph2 = 1._wp / ( zalph2 + 1._wp ) 430 ! explicit: 431 ! z1_alph2 = 1._wp / zalph2 432 ! zalph2 = zalph2 - 1._wp 433 ENDIF 434 435 ! P/delta at F points 436 zp_delf = 0.25_wp * ( zp_delt(ji,jj) + zp_delt(ji+1,jj) + zp_delt(ji,jj+1) + zp_delt(ji+1,jj+1) ) 437 438 ! stress at F points (zkt/=0 if landfast) 439 zs12(ji,jj)= ( zs12(ji,jj) * zalph2 + zp_delf * ( zds(ji,jj) * z1_ecc2 * (1._wp + zkt) ) * 0.5_wp ) * z1_alph2 440 441 END_2D 464 442 465 443 ! --- Ice internal stresses (Appendix C of Hunke and Dukowicz, 2002) --- ! 466 DO jj = 2, jpjm1 467 DO ji = fs_2, fs_jpim1 468 ! !--- U points 469 zfU(ji,jj) = 0.5_wp * ( ( zs1(ji+1,jj) - zs1(ji,jj) ) * e2u(ji,jj) & 470 & + ( zs2(ji+1,jj) * e2t(ji+1,jj) * e2t(ji+1,jj) - zs2(ji,jj) * e2t(ji,jj) * e2t(ji,jj) & 471 & ) * r1_e2u(ji,jj) & 472 & + ( zs12(ji,jj) * e1f(ji,jj) * e1f(ji,jj) - zs12(ji,jj-1) * e1f(ji,jj-1) * e1f(ji,jj-1) & 473 & ) * 2._wp * r1_e1u(ji,jj) & 474 & ) * r1_e1e2u(ji,jj) 475 ! 476 ! !--- V points 477 zfV(ji,jj) = 0.5_wp * ( ( zs1(ji,jj+1) - zs1(ji,jj) ) * e1v(ji,jj) & 478 & - ( zs2(ji,jj+1) * e1t(ji,jj+1) * e1t(ji,jj+1) - zs2(ji,jj) * e1t(ji,jj) * e1t(ji,jj) & 479 & ) * r1_e1v(ji,jj) & 480 & + ( zs12(ji,jj) * e2f(ji,jj) * e2f(ji,jj) - zs12(ji-1,jj) * e2f(ji-1,jj) * e2f(ji-1,jj) & 481 & ) * 2._wp * r1_e2v(ji,jj) & 482 & ) * r1_e1e2v(ji,jj) 483 ! 484 ! !--- ice currents at U-V point 485 v_iceU(ji,jj) = 0.25_wp * ( v_ice(ji,jj) + v_ice(ji,jj-1) + v_ice(ji+1,jj) + v_ice(ji+1,jj-1) ) * umask(ji,jj,1) 486 u_iceV(ji,jj) = 0.25_wp * ( u_ice(ji,jj) + u_ice(ji-1,jj) + u_ice(ji,jj+1) + u_ice(ji-1,jj+1) ) * vmask(ji,jj,1) 487 ! 488 END DO 489 END DO 444 DO_2D_00_00 445 ! !--- U points 446 zfU(ji,jj) = 0.5_wp * ( ( zs1(ji+1,jj) - zs1(ji,jj) ) * e2u(ji,jj) & 447 & + ( zs2(ji+1,jj) * e2t(ji+1,jj) * e2t(ji+1,jj) - zs2(ji,jj) * e2t(ji,jj) * e2t(ji,jj) & 448 & ) * r1_e2u(ji,jj) & 449 & + ( zs12(ji,jj) * e1f(ji,jj) * e1f(ji,jj) - zs12(ji,jj-1) * e1f(ji,jj-1) * e1f(ji,jj-1) & 450 & ) * 2._wp * r1_e1u(ji,jj) & 451 & ) * r1_e1e2u(ji,jj) 452 ! 453 ! !--- V points 454 zfV(ji,jj) = 0.5_wp * ( ( zs1(ji,jj+1) - zs1(ji,jj) ) * e1v(ji,jj) & 455 & - ( zs2(ji,jj+1) * e1t(ji,jj+1) * e1t(ji,jj+1) - zs2(ji,jj) * e1t(ji,jj) * e1t(ji,jj) & 456 & ) * r1_e1v(ji,jj) & 457 & + ( zs12(ji,jj) * e2f(ji,jj) * e2f(ji,jj) - zs12(ji-1,jj) * e2f(ji-1,jj) * e2f(ji-1,jj) & 458 & ) * 2._wp * r1_e2v(ji,jj) & 459 & ) * r1_e1e2v(ji,jj) 460 ! 461 ! !--- ice currents at U-V point 462 v_iceU(ji,jj) = 0.25_wp * ( v_ice(ji,jj) + v_ice(ji,jj-1) + v_ice(ji+1,jj) + v_ice(ji+1,jj-1) ) * umask(ji,jj,1) 463 u_iceV(ji,jj) = 0.25_wp * ( u_ice(ji,jj) + u_ice(ji-1,jj) + u_ice(ji,jj+1) + u_ice(ji-1,jj+1) ) * vmask(ji,jj,1) 464 ! 465 END_2D 490 466 ! 491 467 ! --- Computation of ice velocity --- ! … … 494 470 IF( MOD(jter,2) == 0 ) THEN ! even iterations 495 471 ! 496 DO jj = 2, jpjm1 497 DO ji = fs_2, fs_jpim1 498 ! !--- tau_io/(v_oce - v_ice) 499 zTauO = zaV(ji,jj) * zrhoco * SQRT( ( v_ice (ji,jj) - v_oce (ji,jj) ) * ( v_ice (ji,jj) - v_oce (ji,jj) ) & 500 & + ( u_iceV(ji,jj) - u_oceV(ji,jj) ) * ( u_iceV(ji,jj) - u_oceV(ji,jj) ) ) 501 ! !--- Ocean-to-Ice stress 502 ztauy_oi(ji,jj) = zTauO * ( v_oce(ji,jj) - v_ice(ji,jj) ) 503 ! 504 ! !--- tau_bottom/v_ice 505 zvel = 5.e-05_wp + SQRT( v_ice(ji,jj) * v_ice(ji,jj) + u_iceV(ji,jj) * u_iceV(ji,jj) ) 506 zTauB = ztauy_base(ji,jj) / zvel 507 ! !--- OceanBottom-to-Ice stress 508 ztauy_bi(ji,jj) = zTauB * v_ice(ji,jj) 509 ! 510 ! !--- Coriolis at V-points (energy conserving formulation) 511 zCorV(ji,jj) = - 0.25_wp * r1_e2v(ji,jj) * & 512 & ( zmf(ji,jj ) * ( e2u(ji,jj ) * u_ice(ji,jj ) + e2u(ji-1,jj ) * u_ice(ji-1,jj ) ) & 513 & + zmf(ji,jj+1) * ( e2u(ji,jj+1) * u_ice(ji,jj+1) + e2u(ji-1,jj+1) * u_ice(ji-1,jj+1) ) ) 514 ! 515 ! !--- Sum of external forces (explicit solution) = F + tau_ia + Coriolis + spg + tau_io 516 zRHS = zfV(ji,jj) + ztauy_ai(ji,jj) + zCorV(ji,jj) + zspgV(ji,jj) + ztauy_oi(ji,jj) 517 ! 518 ! !--- landfast switch => 0 = static friction : TauB > RHS & sign(TauB) /= sign(RHS) 519 ! 1 = sliding friction : TauB < RHS 520 rswitch = 1._wp - MIN( 1._wp, ABS( SIGN( 1._wp, zRHS + ztauy_base(ji,jj) ) - SIGN( 1._wp, zRHS ) ) ) 521 ! 522 IF( ln_aEVP ) THEN !--- ice velocity using aEVP (Kimmritz et al 2016 & 2017) 523 zbetav = MAX( zbeta(ji,jj), zbeta(ji,jj+1) ) 524 v_ice(ji,jj) = ( ( rswitch * ( zmV_t(ji,jj) * ( zbetav * v_ice(ji,jj) + v_ice_b(ji,jj) ) & ! previous velocity 525 & + zRHS + zTauO * v_ice(ji,jj) & ! F + tau_ia + Coriolis + spg + tau_io(only ocean part) 526 & ) / MAX( zepsi, zmV_t(ji,jj) * ( zbetav + 1._wp ) + zTauO - zTauB ) & ! m/dt + tau_io(only ice part) + landfast 527 & + ( 1._wp - rswitch ) * ( v_ice_b(ji,jj) & 528 & + v_ice (ji,jj) * MAX( 0._wp, zbetav - zdtevp * rn_lf_relax ) & ! static friction => slow decrease to v=0 529 & ) / ( zbetav + 1._wp ) & 530 & ) * zmsk01y(ji,jj) + v_oce(ji,jj) * 0.01_wp * ( 1._wp - zmsk01y(ji,jj) ) & ! v_ice = v_oce/100 if mass < zmmin & conc < zamin 531 & ) * zmsk00y(ji,jj) 532 ELSE !--- ice velocity using EVP implicit formulation (cf Madec doc & Bouillon 2009) 533 v_ice(ji,jj) = ( ( rswitch * ( zmV_t(ji,jj) * v_ice(ji,jj) & ! previous velocity 534 & + zRHS + zTauO * v_ice(ji,jj) & ! F + tau_ia + Coriolis + spg + tau_io(only ocean part) 535 & ) / MAX( zepsi, zmV_t(ji,jj) + zTauO - zTauB ) & ! m/dt + tau_io(only ice part) + landfast 536 & + ( 1._wp - rswitch ) * v_ice(ji,jj) * MAX( 0._wp, 1._wp - zdtevp * rn_lf_relax ) & ! static friction => slow decrease to v=0 537 & ) * zmsk01y(ji,jj) + v_oce(ji,jj) * 0.01_wp * ( 1._wp - zmsk01y(ji,jj) ) & ! v_ice = v_oce/100 if mass < zmmin & conc < zamin 538 & ) * zmsk00y(ji,jj) 539 ENDIF 540 END DO 541 END DO 472 DO_2D_00_00 473 ! !--- tau_io/(v_oce - v_ice) 474 zTauO = zaV(ji,jj) * zrhoco * SQRT( ( v_ice (ji,jj) - v_oce (ji,jj) ) * ( v_ice (ji,jj) - v_oce (ji,jj) ) & 475 & + ( u_iceV(ji,jj) - u_oceV(ji,jj) ) * ( u_iceV(ji,jj) - u_oceV(ji,jj) ) ) 476 ! !--- Ocean-to-Ice stress 477 ztauy_oi(ji,jj) = zTauO * ( v_oce(ji,jj) - v_ice(ji,jj) ) 478 ! 479 ! !--- tau_bottom/v_ice 480 zvel = 5.e-05_wp + SQRT( v_ice(ji,jj) * v_ice(ji,jj) + u_iceV(ji,jj) * u_iceV(ji,jj) ) 481 zTauB = ztauy_base(ji,jj) / zvel 482 ! !--- OceanBottom-to-Ice stress 483 ztauy_bi(ji,jj) = zTauB * v_ice(ji,jj) 484 ! 485 ! !--- Coriolis at V-points (energy conserving formulation) 486 zCorV(ji,jj) = - 0.25_wp * r1_e2v(ji,jj) * & 487 & ( zmf(ji,jj ) * ( e2u(ji,jj ) * u_ice(ji,jj ) + e2u(ji-1,jj ) * u_ice(ji-1,jj ) ) & 488 & + zmf(ji,jj+1) * ( e2u(ji,jj+1) * u_ice(ji,jj+1) + e2u(ji-1,jj+1) * u_ice(ji-1,jj+1) ) ) 489 ! 490 ! !--- Sum of external forces (explicit solution) = F + tau_ia + Coriolis + spg + tau_io 491 zRHS = zfV(ji,jj) + ztauy_ai(ji,jj) + zCorV(ji,jj) + zspgV(ji,jj) + ztauy_oi(ji,jj) 492 ! 493 ! !--- landfast switch => 0 = static friction : TauB > RHS & sign(TauB) /= sign(RHS) 494 ! 1 = sliding friction : TauB < RHS 495 rswitch = 1._wp - MIN( 1._wp, ABS( SIGN( 1._wp, zRHS + ztauy_base(ji,jj) ) - SIGN( 1._wp, zRHS ) ) ) 496 ! 497 IF( ln_aEVP ) THEN !--- ice velocity using aEVP (Kimmritz et al 2016 & 2017) 498 zbetav = MAX( zbeta(ji,jj), zbeta(ji,jj+1) ) 499 v_ice(ji,jj) = ( ( rswitch * ( zmV_t(ji,jj) * ( zbetav * v_ice(ji,jj) + v_ice_b(ji,jj) ) & ! previous velocity 500 & + zRHS + zTauO * v_ice(ji,jj) & ! F + tau_ia + Coriolis + spg + tau_io(only ocean part) 501 & ) / MAX( zepsi, zmV_t(ji,jj) * ( zbetav + 1._wp ) + zTauO - zTauB ) & ! m/dt + tau_io(only ice part) + landfast 502 & + ( 1._wp - rswitch ) * ( v_ice_b(ji,jj) & 503 & + v_ice (ji,jj) * MAX( 0._wp, zbetav - zdtevp * rn_lf_relax ) & ! static friction => slow decrease to v=0 504 & ) / ( zbetav + 1._wp ) & 505 & ) * zmsk01y(ji,jj) + v_oce(ji,jj) * 0.01_wp * ( 1._wp - zmsk01y(ji,jj) ) & ! v_ice = v_oce/100 if mass < zmmin & conc < zamin 506 & ) * zmsk00y(ji,jj) 507 ELSE !--- ice velocity using EVP implicit formulation (cf Madec doc & Bouillon 2009) 508 v_ice(ji,jj) = ( ( rswitch * ( zmV_t(ji,jj) * v_ice(ji,jj) & ! previous velocity 509 & + zRHS + zTauO * v_ice(ji,jj) & ! F + tau_ia + Coriolis + spg + tau_io(only ocean part) 510 & ) / MAX( zepsi, zmV_t(ji,jj) + zTauO - zTauB ) & ! m/dt + tau_io(only ice part) + landfast 511 & + ( 1._wp - rswitch ) * v_ice(ji,jj) * MAX( 0._wp, 1._wp - zdtevp * rn_lf_relax ) & ! static friction => slow decrease to v=0 512 & ) * zmsk01y(ji,jj) + v_oce(ji,jj) * 0.01_wp * ( 1._wp - zmsk01y(ji,jj) ) & ! v_ice = v_oce/100 if mass < zmmin & conc < zamin 513 & ) * zmsk00y(ji,jj) 514 ENDIF 515 END_2D 542 516 CALL lbc_lnk( 'icedyn_rhg_evp', v_ice, 'V', -1. ) 543 517 ! … … 548 522 IF( ln_bdy ) CALL bdy_ice_dyn( 'V' ) 549 523 ! 550 DO jj = 2, jpjm1 551 DO ji = fs_2, fs_jpim1 552 ! !--- tau_io/(u_oce - u_ice) 553 zTauO = zaU(ji,jj) * zrhoco * SQRT( ( u_ice (ji,jj) - u_oce (ji,jj) ) * ( u_ice (ji,jj) - u_oce (ji,jj) ) & 554 & + ( v_iceU(ji,jj) - v_oceU(ji,jj) ) * ( v_iceU(ji,jj) - v_oceU(ji,jj) ) ) 555 ! !--- Ocean-to-Ice stress 556 ztaux_oi(ji,jj) = zTauO * ( u_oce(ji,jj) - u_ice(ji,jj) ) 557 ! 558 ! !--- tau_bottom/u_ice 559 zvel = 5.e-05_wp + SQRT( v_iceU(ji,jj) * v_iceU(ji,jj) + u_ice(ji,jj) * u_ice(ji,jj) ) 560 zTauB = ztaux_base(ji,jj) / zvel 561 ! !--- OceanBottom-to-Ice stress 562 ztaux_bi(ji,jj) = zTauB * u_ice(ji,jj) 563 ! 564 ! !--- Coriolis at U-points (energy conserving formulation) 565 zCorU(ji,jj) = 0.25_wp * r1_e1u(ji,jj) * & 566 & ( zmf(ji ,jj) * ( e1v(ji ,jj) * v_ice(ji ,jj) + e1v(ji ,jj-1) * v_ice(ji ,jj-1) ) & 567 & + zmf(ji+1,jj) * ( e1v(ji+1,jj) * v_ice(ji+1,jj) + e1v(ji+1,jj-1) * v_ice(ji+1,jj-1) ) ) 568 ! 569 ! !--- Sum of external forces (explicit solution) = F + tau_ia + Coriolis + spg + tau_io 570 zRHS = zfU(ji,jj) + ztaux_ai(ji,jj) + zCorU(ji,jj) + zspgU(ji,jj) + ztaux_oi(ji,jj) 571 ! 572 ! !--- landfast switch => 0 = static friction : TauB > RHS & sign(TauB) /= sign(RHS) 573 ! 1 = sliding friction : TauB < RHS 574 rswitch = 1._wp - MIN( 1._wp, ABS( SIGN( 1._wp, zRHS + ztaux_base(ji,jj) ) - SIGN( 1._wp, zRHS ) ) ) 575 ! 576 IF( ln_aEVP ) THEN !--- ice velocity using aEVP (Kimmritz et al 2016 & 2017) 577 zbetau = MAX( zbeta(ji,jj), zbeta(ji+1,jj) ) 578 u_ice(ji,jj) = ( ( rswitch * ( zmU_t(ji,jj) * ( zbetau * u_ice(ji,jj) + u_ice_b(ji,jj) ) & ! previous velocity 579 & + zRHS + zTauO * u_ice(ji,jj) & ! F + tau_ia + Coriolis + spg + tau_io(only ocean part) 580 & ) / MAX( zepsi, zmU_t(ji,jj) * ( zbetau + 1._wp ) + zTauO - zTauB ) & ! m/dt + tau_io(only ice part) + landfast 581 & + ( 1._wp - rswitch ) * ( u_ice_b(ji,jj) & 582 & + u_ice (ji,jj) * MAX( 0._wp, zbetau - zdtevp * rn_lf_relax ) & ! static friction => slow decrease to v=0 583 & ) / ( zbetau + 1._wp ) & 584 & ) * zmsk01x(ji,jj) + u_oce(ji,jj) * 0.01_wp * ( 1._wp - zmsk01x(ji,jj) ) & ! v_ice = v_oce/100 if mass < zmmin & conc < zamin 585 & ) * zmsk00x(ji,jj) 586 ELSE !--- ice velocity using EVP implicit formulation (cf Madec doc & Bouillon 2009) 587 u_ice(ji,jj) = ( ( rswitch * ( zmU_t(ji,jj) * u_ice(ji,jj) & ! previous velocity 588 & + zRHS + zTauO * u_ice(ji,jj) & ! F + tau_ia + Coriolis + spg + tau_io(only ocean part) 589 & ) / MAX( zepsi, zmU_t(ji,jj) + zTauO - zTauB ) & ! m/dt + tau_io(only ice part) + landfast 590 & + ( 1._wp - rswitch ) * u_ice(ji,jj) * MAX( 0._wp, 1._wp - zdtevp * rn_lf_relax ) & ! static friction => slow decrease to v=0 591 & ) * zmsk01x(ji,jj) + u_oce(ji,jj) * 0.01_wp * ( 1._wp - zmsk01x(ji,jj) ) & ! v_ice = v_oce/100 if mass < zmmin & conc < zamin 592 & ) * zmsk00x(ji,jj) 593 ENDIF 594 END DO 595 END DO 524 DO_2D_00_00 525 ! !--- tau_io/(u_oce - u_ice) 526 zTauO = zaU(ji,jj) * zrhoco * SQRT( ( u_ice (ji,jj) - u_oce (ji,jj) ) * ( u_ice (ji,jj) - u_oce (ji,jj) ) & 527 & + ( v_iceU(ji,jj) - v_oceU(ji,jj) ) * ( v_iceU(ji,jj) - v_oceU(ji,jj) ) ) 528 ! !--- Ocean-to-Ice stress 529 ztaux_oi(ji,jj) = zTauO * ( u_oce(ji,jj) - u_ice(ji,jj) ) 530 ! 531 ! !--- tau_bottom/u_ice 532 zvel = 5.e-05_wp + SQRT( v_iceU(ji,jj) * v_iceU(ji,jj) + u_ice(ji,jj) * u_ice(ji,jj) ) 533 zTauB = ztaux_base(ji,jj) / zvel 534 ! !--- OceanBottom-to-Ice stress 535 ztaux_bi(ji,jj) = zTauB * u_ice(ji,jj) 536 ! 537 ! !--- Coriolis at U-points (energy conserving formulation) 538 zCorU(ji,jj) = 0.25_wp * r1_e1u(ji,jj) * & 539 & ( zmf(ji ,jj) * ( e1v(ji ,jj) * v_ice(ji ,jj) + e1v(ji ,jj-1) * v_ice(ji ,jj-1) ) & 540 & + zmf(ji+1,jj) * ( e1v(ji+1,jj) * v_ice(ji+1,jj) + e1v(ji+1,jj-1) * v_ice(ji+1,jj-1) ) ) 541 ! 542 ! !--- Sum of external forces (explicit solution) = F + tau_ia + Coriolis + spg + tau_io 543 zRHS = zfU(ji,jj) + ztaux_ai(ji,jj) + zCorU(ji,jj) + zspgU(ji,jj) + ztaux_oi(ji,jj) 544 ! 545 ! !--- landfast switch => 0 = static friction : TauB > RHS & sign(TauB) /= sign(RHS) 546 ! 1 = sliding friction : TauB < RHS 547 rswitch = 1._wp - MIN( 1._wp, ABS( SIGN( 1._wp, zRHS + ztaux_base(ji,jj) ) - SIGN( 1._wp, zRHS ) ) ) 548 ! 549 IF( ln_aEVP ) THEN !--- ice velocity using aEVP (Kimmritz et al 2016 & 2017) 550 zbetau = MAX( zbeta(ji,jj), zbeta(ji+1,jj) ) 551 u_ice(ji,jj) = ( ( rswitch * ( zmU_t(ji,jj) * ( zbetau * u_ice(ji,jj) + u_ice_b(ji,jj) ) & ! previous velocity 552 & + zRHS + zTauO * u_ice(ji,jj) & ! F + tau_ia + Coriolis + spg + tau_io(only ocean part) 553 & ) / MAX( zepsi, zmU_t(ji,jj) * ( zbetau + 1._wp ) + zTauO - zTauB ) & ! m/dt + tau_io(only ice part) + landfast 554 & + ( 1._wp - rswitch ) * ( u_ice_b(ji,jj) & 555 & + u_ice (ji,jj) * MAX( 0._wp, zbetau - zdtevp * rn_lf_relax ) & ! static friction => slow decrease to v=0 556 & ) / ( zbetau + 1._wp ) & 557 & ) * zmsk01x(ji,jj) + u_oce(ji,jj) * 0.01_wp * ( 1._wp - zmsk01x(ji,jj) ) & ! v_ice = v_oce/100 if mass < zmmin & conc < zamin 558 & ) * zmsk00x(ji,jj) 559 ELSE !--- ice velocity using EVP implicit formulation (cf Madec doc & Bouillon 2009) 560 u_ice(ji,jj) = ( ( rswitch * ( zmU_t(ji,jj) * u_ice(ji,jj) & ! previous velocity 561 & + zRHS + zTauO * u_ice(ji,jj) & ! F + tau_ia + Coriolis + spg + tau_io(only ocean part) 562 & ) / MAX( zepsi, zmU_t(ji,jj) + zTauO - zTauB ) & ! m/dt + tau_io(only ice part) + landfast 563 & + ( 1._wp - rswitch ) * u_ice(ji,jj) * MAX( 0._wp, 1._wp - zdtevp * rn_lf_relax ) & ! static friction => slow decrease to v=0 564 & ) * zmsk01x(ji,jj) + u_oce(ji,jj) * 0.01_wp * ( 1._wp - zmsk01x(ji,jj) ) & ! v_ice = v_oce/100 if mass < zmmin & conc < zamin 565 & ) * zmsk00x(ji,jj) 566 ENDIF 567 END_2D 596 568 CALL lbc_lnk( 'icedyn_rhg_evp', u_ice, 'U', -1. ) 597 569 ! … … 604 576 ELSE ! odd iterations 605 577 ! 606 DO jj = 2, jpjm1 607 DO ji = fs_2, fs_jpim1 608 ! !--- tau_io/(u_oce - u_ice) 609 zTauO = zaU(ji,jj) * zrhoco * SQRT( ( u_ice (ji,jj) - u_oce (ji,jj) ) * ( u_ice (ji,jj) - u_oce (ji,jj) ) & 610 & + ( v_iceU(ji,jj) - v_oceU(ji,jj) ) * ( v_iceU(ji,jj) - v_oceU(ji,jj) ) ) 611 ! !--- Ocean-to-Ice stress 612 ztaux_oi(ji,jj) = zTauO * ( u_oce(ji,jj) - u_ice(ji,jj) ) 613 ! 614 ! !--- tau_bottom/u_ice 615 zvel = 5.e-05_wp + SQRT( v_iceU(ji,jj) * v_iceU(ji,jj) + u_ice(ji,jj) * u_ice(ji,jj) ) 616 zTauB = ztaux_base(ji,jj) / zvel 617 ! !--- OceanBottom-to-Ice stress 618 ztaux_bi(ji,jj) = zTauB * u_ice(ji,jj) 619 ! 620 ! !--- Coriolis at U-points (energy conserving formulation) 621 zCorU(ji,jj) = 0.25_wp * r1_e1u(ji,jj) * & 622 & ( zmf(ji ,jj) * ( e1v(ji ,jj) * v_ice(ji ,jj) + e1v(ji ,jj-1) * v_ice(ji ,jj-1) ) & 623 & + zmf(ji+1,jj) * ( e1v(ji+1,jj) * v_ice(ji+1,jj) + e1v(ji+1,jj-1) * v_ice(ji+1,jj-1) ) ) 624 ! 625 ! !--- Sum of external forces (explicit solution) = F + tau_ia + Coriolis + spg + tau_io 626 zRHS = zfU(ji,jj) + ztaux_ai(ji,jj) + zCorU(ji,jj) + zspgU(ji,jj) + ztaux_oi(ji,jj) 627 ! 628 ! !--- landfast switch => 0 = static friction : TauB > RHS & sign(TauB) /= sign(RHS) 629 ! 1 = sliding friction : TauB < RHS 630 rswitch = 1._wp - MIN( 1._wp, ABS( SIGN( 1._wp, zRHS + ztaux_base(ji,jj) ) - SIGN( 1._wp, zRHS ) ) ) 631 ! 632 IF( ln_aEVP ) THEN !--- ice velocity using aEVP (Kimmritz et al 2016 & 2017) 633 zbetau = MAX( zbeta(ji,jj), zbeta(ji+1,jj) ) 634 u_ice(ji,jj) = ( ( rswitch * ( zmU_t(ji,jj) * ( zbetau * u_ice(ji,jj) + u_ice_b(ji,jj) ) & ! previous velocity 635 & + zRHS + zTauO * u_ice(ji,jj) & ! F + tau_ia + Coriolis + spg + tau_io(only ocean part) 636 & ) / MAX( zepsi, zmU_t(ji,jj) * ( zbetau + 1._wp ) + zTauO - zTauB ) & ! m/dt + tau_io(only ice part) + landfast 637 & + ( 1._wp - rswitch ) * ( u_ice_b(ji,jj) & 638 & + u_ice (ji,jj) * MAX( 0._wp, zbetau - zdtevp * rn_lf_relax ) & ! static friction => slow decrease to v=0 639 & ) / ( zbetau + 1._wp ) & 640 & ) * zmsk01x(ji,jj) + u_oce(ji,jj) * 0.01_wp * ( 1._wp - zmsk01x(ji,jj) ) & ! v_ice = v_oce/100 if mass < zmmin & conc < zamin 641 & ) * zmsk00x(ji,jj) 642 ELSE !--- ice velocity using EVP implicit formulation (cf Madec doc & Bouillon 2009) 643 u_ice(ji,jj) = ( ( rswitch * ( zmU_t(ji,jj) * u_ice(ji,jj) & ! previous velocity 644 & + zRHS + zTauO * u_ice(ji,jj) & ! F + tau_ia + Coriolis + spg + tau_io(only ocean part) 645 & ) / MAX( zepsi, zmU_t(ji,jj) + zTauO - zTauB ) & ! m/dt + tau_io(only ice part) + landfast 646 & + ( 1._wp - rswitch ) * u_ice(ji,jj) * MAX( 0._wp, 1._wp - zdtevp * rn_lf_relax ) & ! static friction => slow decrease to v=0 647 & ) * zmsk01x(ji,jj) + u_oce(ji,jj) * 0.01_wp * ( 1._wp - zmsk01x(ji,jj) ) & ! v_ice = v_oce/100 if mass < zmmin & conc < zamin 648 & ) * zmsk00x(ji,jj) 649 ENDIF 650 END DO 651 END DO 578 DO_2D_00_00 579 ! !--- tau_io/(u_oce - u_ice) 580 zTauO = zaU(ji,jj) * zrhoco * SQRT( ( u_ice (ji,jj) - u_oce (ji,jj) ) * ( u_ice (ji,jj) - u_oce (ji,jj) ) & 581 & + ( v_iceU(ji,jj) - v_oceU(ji,jj) ) * ( v_iceU(ji,jj) - v_oceU(ji,jj) ) ) 582 ! !--- Ocean-to-Ice stress 583 ztaux_oi(ji,jj) = zTauO * ( u_oce(ji,jj) - u_ice(ji,jj) ) 584 ! 585 ! !--- tau_bottom/u_ice 586 zvel = 5.e-05_wp + SQRT( v_iceU(ji,jj) * v_iceU(ji,jj) + u_ice(ji,jj) * u_ice(ji,jj) ) 587 zTauB = ztaux_base(ji,jj) / zvel 588 ! !--- OceanBottom-to-Ice stress 589 ztaux_bi(ji,jj) = zTauB * u_ice(ji,jj) 590 ! 591 ! !--- Coriolis at U-points (energy conserving formulation) 592 zCorU(ji,jj) = 0.25_wp * r1_e1u(ji,jj) * & 593 & ( zmf(ji ,jj) * ( e1v(ji ,jj) * v_ice(ji ,jj) + e1v(ji ,jj-1) * v_ice(ji ,jj-1) ) & 594 & + zmf(ji+1,jj) * ( e1v(ji+1,jj) * v_ice(ji+1,jj) + e1v(ji+1,jj-1) * v_ice(ji+1,jj-1) ) ) 595 ! 596 ! !--- Sum of external forces (explicit solution) = F + tau_ia + Coriolis + spg + tau_io 597 zRHS = zfU(ji,jj) + ztaux_ai(ji,jj) + zCorU(ji,jj) + zspgU(ji,jj) + ztaux_oi(ji,jj) 598 ! 599 ! !--- landfast switch => 0 = static friction : TauB > RHS & sign(TauB) /= sign(RHS) 600 ! 1 = sliding friction : TauB < RHS 601 rswitch = 1._wp - MIN( 1._wp, ABS( SIGN( 1._wp, zRHS + ztaux_base(ji,jj) ) - SIGN( 1._wp, zRHS ) ) ) 602 ! 603 IF( ln_aEVP ) THEN !--- ice velocity using aEVP (Kimmritz et al 2016 & 2017) 604 zbetau = MAX( zbeta(ji,jj), zbeta(ji+1,jj) ) 605 u_ice(ji,jj) = ( ( rswitch * ( zmU_t(ji,jj) * ( zbetau * u_ice(ji,jj) + u_ice_b(ji,jj) ) & ! previous velocity 606 & + zRHS + zTauO * u_ice(ji,jj) & ! F + tau_ia + Coriolis + spg + tau_io(only ocean part) 607 & ) / MAX( zepsi, zmU_t(ji,jj) * ( zbetau + 1._wp ) + zTauO - zTauB ) & ! m/dt + tau_io(only ice part) + landfast 608 & + ( 1._wp - rswitch ) * ( u_ice_b(ji,jj) & 609 & + u_ice (ji,jj) * MAX( 0._wp, zbetau - zdtevp * rn_lf_relax ) & ! static friction => slow decrease to v=0 610 & ) / ( zbetau + 1._wp ) & 611 & ) * zmsk01x(ji,jj) + u_oce(ji,jj) * 0.01_wp * ( 1._wp - zmsk01x(ji,jj) ) & ! v_ice = v_oce/100 if mass < zmmin & conc < zamin 612 & ) * zmsk00x(ji,jj) 613 ELSE !--- ice velocity using EVP implicit formulation (cf Madec doc & Bouillon 2009) 614 u_ice(ji,jj) = ( ( rswitch * ( zmU_t(ji,jj) * u_ice(ji,jj) & ! previous velocity 615 & + zRHS + zTauO * u_ice(ji,jj) & ! F + tau_ia + Coriolis + spg + tau_io(only ocean part) 616 & ) / MAX( zepsi, zmU_t(ji,jj) + zTauO - zTauB ) & ! m/dt + tau_io(only ice part) + landfast 617 & + ( 1._wp - rswitch ) * u_ice(ji,jj) * MAX( 0._wp, 1._wp - zdtevp * rn_lf_relax ) & ! static friction => slow decrease to v=0 618 & ) * zmsk01x(ji,jj) + u_oce(ji,jj) * 0.01_wp * ( 1._wp - zmsk01x(ji,jj) ) & ! v_ice = v_oce/100 if mass < zmmin & conc < zamin 619 & ) * zmsk00x(ji,jj) 620 ENDIF 621 END_2D 652 622 CALL lbc_lnk( 'icedyn_rhg_evp', u_ice, 'U', -1. ) 653 623 ! … … 658 628 IF( ln_bdy ) CALL bdy_ice_dyn( 'U' ) 659 629 ! 660 DO jj = 2, jpjm1 661 DO ji = fs_2, fs_jpim1 662 ! !--- tau_io/(v_oce - v_ice) 663 zTauO = zaV(ji,jj) * zrhoco * SQRT( ( v_ice (ji,jj) - v_oce (ji,jj) ) * ( v_ice (ji,jj) - v_oce (ji,jj) ) & 664 & + ( u_iceV(ji,jj) - u_oceV(ji,jj) ) * ( u_iceV(ji,jj) - u_oceV(ji,jj) ) ) 665 ! !--- Ocean-to-Ice stress 666 ztauy_oi(ji,jj) = zTauO * ( v_oce(ji,jj) - v_ice(ji,jj) ) 667 ! 668 ! !--- tau_bottom/v_ice 669 zvel = 5.e-05_wp + SQRT( v_ice(ji,jj) * v_ice(ji,jj) + u_iceV(ji,jj) * u_iceV(ji,jj) ) 670 zTauB = ztauy_base(ji,jj) / zvel 671 ! !--- OceanBottom-to-Ice stress 672 ztauy_bi(ji,jj) = zTauB * v_ice(ji,jj) 673 ! 674 ! !--- Coriolis at v-points (energy conserving formulation) 675 zCorV(ji,jj) = - 0.25_wp * r1_e2v(ji,jj) * & 676 & ( zmf(ji,jj ) * ( e2u(ji,jj ) * u_ice(ji,jj ) + e2u(ji-1,jj ) * u_ice(ji-1,jj ) ) & 677 & + zmf(ji,jj+1) * ( e2u(ji,jj+1) * u_ice(ji,jj+1) + e2u(ji-1,jj+1) * u_ice(ji-1,jj+1) ) ) 678 ! 679 ! !--- Sum of external forces (explicit solution) = F + tau_ia + Coriolis + spg + tau_io 680 zRHS = zfV(ji,jj) + ztauy_ai(ji,jj) + zCorV(ji,jj) + zspgV(ji,jj) + ztauy_oi(ji,jj) 681 ! 682 ! !--- landfast switch => 0 = static friction : TauB > RHS & sign(TauB) /= sign(RHS) 683 ! 1 = sliding friction : TauB < RHS 684 rswitch = 1._wp - MIN( 1._wp, ABS( SIGN( 1._wp, zRHS + ztauy_base(ji,jj) ) - SIGN( 1._wp, zRHS ) ) ) 685 ! 686 IF( ln_aEVP ) THEN !--- ice velocity using aEVP (Kimmritz et al 2016 & 2017) 687 zbetav = MAX( zbeta(ji,jj), zbeta(ji,jj+1) ) 688 v_ice(ji,jj) = ( ( rswitch * ( zmV_t(ji,jj) * ( zbetav * v_ice(ji,jj) + v_ice_b(ji,jj) ) & ! previous velocity 689 & + zRHS + zTauO * v_ice(ji,jj) & ! F + tau_ia + Coriolis + spg + tau_io(only ocean part) 690 & ) / MAX( zepsi, zmV_t(ji,jj) * ( zbetav + 1._wp ) + zTauO - zTauB ) & ! m/dt + tau_io(only ice part) + landfast 691 & + ( 1._wp - rswitch ) * ( v_ice_b(ji,jj) & 692 & + v_ice (ji,jj) * MAX( 0._wp, zbetav - zdtevp * rn_lf_relax ) & ! static friction => slow decrease to v=0 693 & ) / ( zbetav + 1._wp ) & 694 & ) * zmsk01y(ji,jj) + v_oce(ji,jj) * 0.01_wp * ( 1._wp - zmsk01y(ji,jj) ) & ! v_ice = v_oce/100 if mass < zmmin & conc < zamin 695 & ) * zmsk00y(ji,jj) 696 ELSE !--- ice velocity using EVP implicit formulation (cf Madec doc & Bouillon 2009) 697 v_ice(ji,jj) = ( ( rswitch * ( zmV_t(ji,jj) * v_ice(ji,jj) & ! previous velocity 698 & + zRHS + zTauO * v_ice(ji,jj) & ! F + tau_ia + Coriolis + spg + tau_io(only ocean part) 699 & ) / MAX( zepsi, zmV_t(ji,jj) + zTauO - zTauB ) & ! m/dt + tau_io(only ice part) + landfast 700 & + ( 1._wp - rswitch ) * v_ice(ji,jj) * MAX( 0._wp, 1._wp - zdtevp * rn_lf_relax ) & ! static friction => slow decrease to v=0 701 & ) * zmsk01y(ji,jj) + v_oce(ji,jj) * 0.01_wp * ( 1._wp - zmsk01y(ji,jj) ) & ! v_ice = v_oce/100 if mass < zmmin & conc < zamin 702 & ) * zmsk00y(ji,jj) 703 ENDIF 704 END DO 705 END DO 630 DO_2D_00_00 631 ! !--- tau_io/(v_oce - v_ice) 632 zTauO = zaV(ji,jj) * zrhoco * SQRT( ( v_ice (ji,jj) - v_oce (ji,jj) ) * ( v_ice (ji,jj) - v_oce (ji,jj) ) & 633 & + ( u_iceV(ji,jj) - u_oceV(ji,jj) ) * ( u_iceV(ji,jj) - u_oceV(ji,jj) ) ) 634 ! !--- Ocean-to-Ice stress 635 ztauy_oi(ji,jj) = zTauO * ( v_oce(ji,jj) - v_ice(ji,jj) ) 636 ! 637 ! !--- tau_bottom/v_ice 638 zvel = 5.e-05_wp + SQRT( v_ice(ji,jj) * v_ice(ji,jj) + u_iceV(ji,jj) * u_iceV(ji,jj) ) 639 zTauB = ztauy_base(ji,jj) / zvel 640 ! !--- OceanBottom-to-Ice stress 641 ztauy_bi(ji,jj) = zTauB * v_ice(ji,jj) 642 ! 643 ! !--- Coriolis at v-points (energy conserving formulation) 644 zCorV(ji,jj) = - 0.25_wp * r1_e2v(ji,jj) * & 645 & ( zmf(ji,jj ) * ( e2u(ji,jj ) * u_ice(ji,jj ) + e2u(ji-1,jj ) * u_ice(ji-1,jj ) ) & 646 & + zmf(ji,jj+1) * ( e2u(ji,jj+1) * u_ice(ji,jj+1) + e2u(ji-1,jj+1) * u_ice(ji-1,jj+1) ) ) 647 ! 648 ! !--- Sum of external forces (explicit solution) = F + tau_ia + Coriolis + spg + tau_io 649 zRHS = zfV(ji,jj) + ztauy_ai(ji,jj) + zCorV(ji,jj) + zspgV(ji,jj) + ztauy_oi(ji,jj) 650 ! 651 ! !--- landfast switch => 0 = static friction : TauB > RHS & sign(TauB) /= sign(RHS) 652 ! 1 = sliding friction : TauB < RHS 653 rswitch = 1._wp - MIN( 1._wp, ABS( SIGN( 1._wp, zRHS + ztauy_base(ji,jj) ) - SIGN( 1._wp, zRHS ) ) ) 654 ! 655 IF( ln_aEVP ) THEN !--- ice velocity using aEVP (Kimmritz et al 2016 & 2017) 656 zbetav = MAX( zbeta(ji,jj), zbeta(ji,jj+1) ) 657 v_ice(ji,jj) = ( ( rswitch * ( zmV_t(ji,jj) * ( zbetav * v_ice(ji,jj) + v_ice_b(ji,jj) ) & ! previous velocity 658 & + zRHS + zTauO * v_ice(ji,jj) & ! F + tau_ia + Coriolis + spg + tau_io(only ocean part) 659 & ) / MAX( zepsi, zmV_t(ji,jj) * ( zbetav + 1._wp ) + zTauO - zTauB ) & ! m/dt + tau_io(only ice part) + landfast 660 & + ( 1._wp - rswitch ) * ( v_ice_b(ji,jj) & 661 & + v_ice (ji,jj) * MAX( 0._wp, zbetav - zdtevp * rn_lf_relax ) & ! static friction => slow decrease to v=0 662 & ) / ( zbetav + 1._wp ) & 663 & ) * zmsk01y(ji,jj) + v_oce(ji,jj) * 0.01_wp * ( 1._wp - zmsk01y(ji,jj) ) & ! v_ice = v_oce/100 if mass < zmmin & conc < zamin 664 & ) * zmsk00y(ji,jj) 665 ELSE !--- ice velocity using EVP implicit formulation (cf Madec doc & Bouillon 2009) 666 v_ice(ji,jj) = ( ( rswitch * ( zmV_t(ji,jj) * v_ice(ji,jj) & ! previous velocity 667 & + zRHS + zTauO * v_ice(ji,jj) & ! F + tau_ia + Coriolis + spg + tau_io(only ocean part) 668 & ) / MAX( zepsi, zmV_t(ji,jj) + zTauO - zTauB ) & ! m/dt + tau_io(only ice part) + landfast 669 & + ( 1._wp - rswitch ) * v_ice(ji,jj) * MAX( 0._wp, 1._wp - zdtevp * rn_lf_relax ) & ! static friction => slow decrease to v=0 670 & ) * zmsk01y(ji,jj) + v_oce(ji,jj) * 0.01_wp * ( 1._wp - zmsk01y(ji,jj) ) & ! v_ice = v_oce/100 if mass < zmmin & conc < zamin 671 & ) * zmsk00y(ji,jj) 672 ENDIF 673 END_2D 706 674 CALL lbc_lnk( 'icedyn_rhg_evp', v_ice, 'V', -1. ) 707 675 ! … … 725 693 ! 4) Recompute delta, shear and div (inputs for mechanical redistribution) 726 694 !------------------------------------------------------------------------------! 727 DO jj = 1, jpjm1 728 DO ji = 1, jpim1 729 730 ! shear at F points 731 zds(ji,jj) = ( ( u_ice(ji,jj+1) * r1_e1u(ji,jj+1) - u_ice(ji,jj) * r1_e1u(ji,jj) ) * e1f(ji,jj) * e1f(ji,jj) & 732 & + ( v_ice(ji+1,jj) * r1_e2v(ji+1,jj) - v_ice(ji,jj) * r1_e2v(ji,jj) ) * e2f(ji,jj) * e2f(ji,jj) & 733 & ) * r1_e1e2f(ji,jj) * zfmask(ji,jj) 734 735 END DO 736 END DO 695 DO_2D_10_10 696 697 ! shear at F points 698 zds(ji,jj) = ( ( u_ice(ji,jj+1) * r1_e1u(ji,jj+1) - u_ice(ji,jj) * r1_e1u(ji,jj) ) * e1f(ji,jj) * e1f(ji,jj) & 699 & + ( v_ice(ji+1,jj) * r1_e2v(ji+1,jj) - v_ice(ji,jj) * r1_e2v(ji,jj) ) * e2f(ji,jj) * e2f(ji,jj) & 700 & ) * r1_e1e2f(ji,jj) * zfmask(ji,jj) 701 702 END_2D 737 703 738 DO jj = 2, jpjm1 739 DO ji = 2, jpim1 ! no vector loop 740 741 ! tension**2 at T points 742 zdt = ( ( u_ice(ji,jj) * r1_e2u(ji,jj) - u_ice(ji-1,jj) * r1_e2u(ji-1,jj) ) * e2t(ji,jj) * e2t(ji,jj) & 743 & - ( v_ice(ji,jj) * r1_e1v(ji,jj) - v_ice(ji,jj-1) * r1_e1v(ji,jj-1) ) * e1t(ji,jj) * e1t(ji,jj) & 744 & ) * r1_e1e2t(ji,jj) 745 zdt2 = zdt * zdt 746 747 ! shear**2 at T points (doc eq. A16) 748 zds2 = ( zds(ji,jj ) * zds(ji,jj ) * e1e2f(ji,jj ) + zds(ji-1,jj ) * zds(ji-1,jj ) * e1e2f(ji-1,jj ) & 749 & + zds(ji,jj-1) * zds(ji,jj-1) * e1e2f(ji,jj-1) + zds(ji-1,jj-1) * zds(ji-1,jj-1) * e1e2f(ji-1,jj-1) & 750 & ) * 0.25_wp * r1_e1e2t(ji,jj) 751 752 ! shear at T points 753 pshear_i(ji,jj) = SQRT( zdt2 + zds2 ) 754 755 ! divergence at T points 756 pdivu_i(ji,jj) = ( e2u(ji,jj) * u_ice(ji,jj) - e2u(ji-1,jj) * u_ice(ji-1,jj) & 757 & + e1v(ji,jj) * v_ice(ji,jj) - e1v(ji,jj-1) * v_ice(ji,jj-1) & 758 & ) * r1_e1e2t(ji,jj) 759 760 ! delta at T points 761 zdelta = SQRT( pdivu_i(ji,jj) * pdivu_i(ji,jj) + ( zdt2 + zds2 ) * z1_ecc2 ) 762 rswitch = 1._wp - MAX( 0._wp, SIGN( 1._wp, -zdelta ) ) ! 0 if delta=0 763 pdelta_i(ji,jj) = zdelta + rn_creepl * rswitch 764 765 END DO 766 END DO 704 DO_2D_00_00 705 706 ! tension**2 at T points 707 zdt = ( ( u_ice(ji,jj) * r1_e2u(ji,jj) - u_ice(ji-1,jj) * r1_e2u(ji-1,jj) ) * e2t(ji,jj) * e2t(ji,jj) & 708 & - ( v_ice(ji,jj) * r1_e1v(ji,jj) - v_ice(ji,jj-1) * r1_e1v(ji,jj-1) ) * e1t(ji,jj) * e1t(ji,jj) & 709 & ) * r1_e1e2t(ji,jj) 710 zdt2 = zdt * zdt 711 712 ! shear**2 at T points (doc eq. A16) 713 zds2 = ( zds(ji,jj ) * zds(ji,jj ) * e1e2f(ji,jj ) + zds(ji-1,jj ) * zds(ji-1,jj ) * e1e2f(ji-1,jj ) & 714 & + zds(ji,jj-1) * zds(ji,jj-1) * e1e2f(ji,jj-1) + zds(ji-1,jj-1) * zds(ji-1,jj-1) * e1e2f(ji-1,jj-1) & 715 & ) * 0.25_wp * r1_e1e2t(ji,jj) 716 717 ! shear at T points 718 pshear_i(ji,jj) = SQRT( zdt2 + zds2 ) 719 720 ! divergence at T points 721 pdivu_i(ji,jj) = ( e2u(ji,jj) * u_ice(ji,jj) - e2u(ji-1,jj) * u_ice(ji-1,jj) & 722 & + e1v(ji,jj) * v_ice(ji,jj) - e1v(ji,jj-1) * v_ice(ji,jj-1) & 723 & ) * r1_e1e2t(ji,jj) 724 725 ! delta at T points 726 zdelta = SQRT( pdivu_i(ji,jj) * pdivu_i(ji,jj) + ( zdt2 + zds2 ) * z1_ecc2 ) 727 rswitch = 1._wp - MAX( 0._wp, SIGN( 1._wp, -zdelta ) ) ! 0 if delta=0 728 pdelta_i(ji,jj) = zdelta + rn_creepl * rswitch 729 730 END_2D 767 731 CALL lbc_lnk_multi( 'icedyn_rhg_evp', pshear_i, 'T', 1., pdivu_i, 'T', 1., pdelta_i, 'T', 1. ) 768 732 … … 802 766 ALLOCATE( zsig1(jpi,jpj) , zsig2(jpi,jpj) , zsig3(jpi,jpj) ) 803 767 ! 804 DO jj = 2, jpjm1 805 DO ji = 2, jpim1 806 zdum1 = ( zmsk00(ji-1,jj) * pstress12_i(ji-1,jj) + zmsk00(ji ,jj-1) * pstress12_i(ji ,jj-1) + & ! stress12_i at T-point 807 & zmsk00(ji ,jj) * pstress12_i(ji ,jj) + zmsk00(ji-1,jj-1) * pstress12_i(ji-1,jj-1) ) & 808 & / MAX( 1._wp, zmsk00(ji-1,jj) + zmsk00(ji,jj-1) + zmsk00(ji,jj) + zmsk00(ji-1,jj-1) ) 809 810 zshear = SQRT( pstress2_i(ji,jj) * pstress2_i(ji,jj) + 4._wp * zdum1 * zdum1 ) ! shear stress 811 812 zdum2 = zmsk00(ji,jj) / MAX( 1._wp, strength(ji,jj) ) 768 DO_2D_00_00 769 zdum1 = ( zmsk00(ji-1,jj) * pstress12_i(ji-1,jj) + zmsk00(ji ,jj-1) * pstress12_i(ji ,jj-1) + & ! stress12_i at T-point 770 & zmsk00(ji ,jj) * pstress12_i(ji ,jj) + zmsk00(ji-1,jj-1) * pstress12_i(ji-1,jj-1) ) & 771 & / MAX( 1._wp, zmsk00(ji-1,jj) + zmsk00(ji,jj-1) + zmsk00(ji,jj) + zmsk00(ji-1,jj-1) ) 772 773 zshear = SQRT( pstress2_i(ji,jj) * pstress2_i(ji,jj) + 4._wp * zdum1 * zdum1 ) ! shear stress 774 775 zdum2 = zmsk00(ji,jj) / MAX( 1._wp, strength(ji,jj) ) 813 776 814 777 !! zsig1(ji,jj) = 0.5_wp * zdum2 * ( pstress1_i(ji,jj) + zshear ) ! principal stress (y-direction, see Hunke & Dukowicz 2002) … … 816 779 !! zsig3(ji,jj) = zdum2**2 * ( ( pstress1_i(ji,jj) + strength(ji,jj) )**2 + ( rn_ecc * zshear )**2 ) ! quadratic relation linking compressive stress to shear stress 817 780 !! ! (scheme converges if this value is ~1, see Bouillon et al 2009 (eq. 11)) 818 zsig1(ji,jj) = 0.5_wp * zdum2 * ( pstress1_i(ji,jj) ) ! compressive stress, see Bouillon et al. 2015 819 zsig2(ji,jj) = 0.5_wp * zdum2 * ( zshear ) ! shear stress 820 zsig3(ji,jj) = zdum2**2 * ( ( pstress1_i(ji,jj) + strength(ji,jj) )**2 + ( rn_ecc * zshear )**2 ) 821 END DO 822 END DO 781 zsig1(ji,jj) = 0.5_wp * zdum2 * ( pstress1_i(ji,jj) ) ! compressive stress, see Bouillon et al. 2015 782 zsig2(ji,jj) = 0.5_wp * zdum2 * ( zshear ) ! shear stress 783 zsig3(ji,jj) = zdum2**2 * ( ( pstress1_i(ji,jj) + strength(ji,jj) )**2 + ( rn_ecc * zshear )**2 ) 784 END_2D 823 785 CALL lbc_lnk_multi( 'icedyn_rhg_evp', zsig1, 'T', 1., zsig2, 'T', 1., zsig3, 'T', 1. ) 824 786 ! … … 855 817 & zdiag_xmtrp_snw(jpi,jpj) , zdiag_ymtrp_snw(jpi,jpj) , zdiag_xatrp(jpi,jpj) , zdiag_yatrp(jpi,jpj) ) 856 818 ! 857 DO jj = 2, jpjm1 858 DO ji = 2, jpim1 859 ! 2D ice mass, snow mass, area transport arrays (X, Y) 860 zfac_x = 0.5 * u_ice(ji,jj) * e2u(ji,jj) * zmsk00(ji,jj) 861 zfac_y = 0.5 * v_ice(ji,jj) * e1v(ji,jj) * zmsk00(ji,jj) 862 863 zdiag_xmtrp_ice(ji,jj) = rhoi * zfac_x * ( vt_i(ji+1,jj) + vt_i(ji,jj) ) ! ice mass transport, X-component 864 zdiag_ymtrp_ice(ji,jj) = rhoi * zfac_y * ( vt_i(ji,jj+1) + vt_i(ji,jj) ) ! '' Y- '' 865 866 zdiag_xmtrp_snw(ji,jj) = rhos * zfac_x * ( vt_s(ji+1,jj) + vt_s(ji,jj) ) ! snow mass transport, X-component 867 zdiag_ymtrp_snw(ji,jj) = rhos * zfac_y * ( vt_s(ji,jj+1) + vt_s(ji,jj) ) ! '' Y- '' 868 869 zdiag_xatrp(ji,jj) = zfac_x * ( at_i(ji+1,jj) + at_i(ji,jj) ) ! area transport, X-component 870 zdiag_yatrp(ji,jj) = zfac_y * ( at_i(ji,jj+1) + at_i(ji,jj) ) ! '' Y- '' 871 872 END DO 873 END DO 819 DO_2D_00_00 820 ! 2D ice mass, snow mass, area transport arrays (X, Y) 821 zfac_x = 0.5 * u_ice(ji,jj) * e2u(ji,jj) * zmsk00(ji,jj) 822 zfac_y = 0.5 * v_ice(ji,jj) * e1v(ji,jj) * zmsk00(ji,jj) 823 824 zdiag_xmtrp_ice(ji,jj) = rhoi * zfac_x * ( vt_i(ji+1,jj) + vt_i(ji,jj) ) ! ice mass transport, X-component 825 zdiag_ymtrp_ice(ji,jj) = rhoi * zfac_y * ( vt_i(ji,jj+1) + vt_i(ji,jj) ) ! '' Y- '' 826 827 zdiag_xmtrp_snw(ji,jj) = rhos * zfac_x * ( vt_s(ji+1,jj) + vt_s(ji,jj) ) ! snow mass transport, X-component 828 zdiag_ymtrp_snw(ji,jj) = rhos * zfac_y * ( vt_s(ji,jj+1) + vt_s(ji,jj) ) ! '' Y- '' 829 830 zdiag_xatrp(ji,jj) = zfac_x * ( at_i(ji+1,jj) + at_i(ji,jj) ) ! area transport, X-component 831 zdiag_yatrp(ji,jj) = zfac_y * ( at_i(ji,jj+1) + at_i(ji,jj) ) ! '' Y- '' 832 833 END_2D 874 834 875 835 CALL lbc_lnk_multi( 'icedyn_rhg_evp', zdiag_xmtrp_ice, 'U', -1., zdiag_ymtrp_ice, 'V', -1., & … … 957 917 zresm = 0._wp 958 918 ELSE 959 DO jj = 1, jpj 960 DO ji = 1, jpi 961 zres(ji,jj) = MAX( ABS( pu(ji,jj) - pub(ji,jj) ) * umask(ji,jj,1), & 962 & ABS( pv(ji,jj) - pvb(ji,jj) ) * vmask(ji,jj,1) ) * zmsk15(ji,jj) 963 END DO 964 END DO 919 DO_2D_11_11 920 zres(ji,jj) = MAX( ABS( pu(ji,jj) - pub(ji,jj) ) * umask(ji,jj,1), & 921 & ABS( pv(ji,jj) - pvb(ji,jj) ) * vmask(ji,jj,1) ) * zmsk15(ji,jj) 922 END_2D 965 923 zresm = MAXVAL( zres ) 966 924 CALL mpp_max( 'icedyn_rhg_evp', zresm ) ! max over the global domain -
NEMO/branches/2020/temporary_r4_trunk/src/ICE/iceistate.F90
r13466 r13469 287 287 ! select ice covered grid points 288 288 npti = 0 ; nptidx(:) = 0 289 DO jj = 1, jpj 290 DO ji = 1, jpi 291 IF ( zht_i_ini(ji,jj) > 0._wp ) THEN 292 npti = npti + 1 293 nptidx(npti) = (jj - 1) * jpi + ji 294 ENDIF 295 END DO 296 END DO 289 DO_2D_11_11 290 IF ( zht_i_ini(ji,jj) > 0._wp ) THEN 291 npti = npti + 1 292 nptidx(npti) = (jj - 1) * jpi + ji 293 ENDIF 294 END_2D 297 295 298 296 ! move to 1D arrays: (jpi,jpj) -> (jpi*jpj) … … 344 342 CALL ice_var_salprof ! for sz_i 345 343 DO jl = 1, jpl 346 DO jj = 1, jpj 347 DO ji = 1, jpi 348 v_i (ji,jj,jl) = h_i(ji,jj,jl) * a_i(ji,jj,jl) 349 v_s (ji,jj,jl) = h_s(ji,jj,jl) * a_i(ji,jj,jl) 350 sv_i(ji,jj,jl) = MIN( MAX( rn_simin , s_i(ji,jj,jl) ) , rn_simax ) * v_i(ji,jj,jl) 351 END DO 352 END DO 344 DO_2D_11_11 345 v_i (ji,jj,jl) = h_i(ji,jj,jl) * a_i(ji,jj,jl) 346 v_s (ji,jj,jl) = h_s(ji,jj,jl) * a_i(ji,jj,jl) 347 sv_i(ji,jj,jl) = MIN( MAX( rn_simin , s_i(ji,jj,jl) ) , rn_simax ) * v_i(ji,jj,jl) 348 END_2D 353 349 END DO 354 350 ! 355 351 DO jl = 1, jpl 356 DO jk = 1, nlay_s 357 DO jj = 1, jpj 358 DO ji = 1, jpi 359 t_s(ji,jj,jk,jl) = zts_3d(ji,jj,jl) 360 e_s(ji,jj,jk,jl) = zswitch(ji,jj) * v_s(ji,jj,jl) * r1_nlay_s * & 361 & rhos * ( rcpi * ( rt0 - t_s(ji,jj,jk,jl) ) + rLfus ) 362 END DO 363 END DO 364 END DO 352 DO_3D_11_11( 1, nlay_s ) 353 t_s(ji,jj,jk,jl) = zts_3d(ji,jj,jl) 354 e_s(ji,jj,jk,jl) = zswitch(ji,jj) * v_s(ji,jj,jl) * r1_nlay_s * & 355 & rhos * ( rcpi * ( rt0 - t_s(ji,jj,jk,jl) ) + rLfus ) 356 END_3D 365 357 END DO 366 358 ! 367 359 DO jl = 1, jpl 368 DO jk = 1, nlay_i 369 DO jj = 1, jpj 370 DO ji = 1, jpi 371 t_i (ji,jj,jk,jl) = zti_3d(ji,jj,jl) 372 ztmelts = - rTmlt * sz_i(ji,jj,jk,jl) + rt0 ! melting temperature in K 373 e_i(ji,jj,jk,jl) = zswitch(ji,jj) * v_i(ji,jj,jl) * r1_nlay_i * & 374 & rhoi * ( rcpi * ( ztmelts - t_i(ji,jj,jk,jl) ) + & 375 & rLfus * ( 1._wp - (ztmelts-rt0) / MIN( (t_i(ji,jj,jk,jl)-rt0), -epsi20 ) ) & 376 & - rcp * ( ztmelts - rt0 ) ) 377 END DO 378 END DO 379 END DO 360 DO_3D_11_11( 1, nlay_i ) 361 t_i (ji,jj,jk,jl) = zti_3d(ji,jj,jl) 362 ztmelts = - rTmlt * sz_i(ji,jj,jk,jl) + rt0 ! melting temperature in K 363 e_i(ji,jj,jk,jl) = zswitch(ji,jj) * v_i(ji,jj,jl) * r1_nlay_i * & 364 & rhoi * ( rcpi * ( ztmelts - t_i(ji,jj,jk,jl) ) + & 365 & rLfus * ( 1._wp - (ztmelts-rt0) / MIN( (t_i(ji,jj,jk,jl)-rt0), -epsi20 ) ) & 366 & - rcp * ( ztmelts - rt0 ) ) 367 END_3D 380 368 END DO 381 369 -
NEMO/branches/2020/temporary_r4_trunk/src/ICE/iceitd.F90
r13466 r13469 97 97 ! 98 98 npti = 0 ; nptidx(:) = 0 99 DO jj = 1, jpj 100 DO ji = 1, jpi 101 IF ( at_i(ji,jj) > epsi10 ) THEN 102 npti = npti + 1 103 nptidx( npti ) = (jj - 1) * jpi + ji 104 ENDIF 105 END DO 106 END DO 99 DO_2D_11_11 100 IF ( at_i(ji,jj) > epsi10 ) THEN 101 npti = npti + 1 102 nptidx( npti ) = (jj - 1) * jpi + ji 103 ENDIF 104 END_2D 107 105 108 106 !----------------------------------------------------------------------------------------------- … … 606 604 ! !--------------------------------------- 607 605 npti = 0 ; nptidx(:) = 0 608 DO jj = 1, jpj 609 DO ji = 1, jpi 610 IF( a_i(ji,jj,jl) > 0._wp .AND. v_i(ji,jj,jl) > (a_i(ji,jj,jl) * hi_max(jl)) ) THEN 611 npti = npti + 1 612 nptidx( npti ) = (jj - 1) * jpi + ji 613 ENDIF 614 END DO 615 END DO 606 DO_2D_11_11 607 IF( a_i(ji,jj,jl) > 0._wp .AND. v_i(ji,jj,jl) > (a_i(ji,jj,jl) * hi_max(jl)) ) THEN 608 npti = npti + 1 609 nptidx( npti ) = (jj - 1) * jpi + ji 610 ENDIF 611 END_2D 616 612 ! 617 613 !!clem CALL tab_2d_1d( npti, nptidx(1:npti), h_i_1d(1:npti), h_i(:,:,jl) ) … … 647 643 ! !----------------------------------------- 648 644 npti = 0 ; nptidx(:) = 0 649 DO jj = 1, jpj 650 DO ji = 1, jpi 651 IF( a_i(ji,jj,jl+1) > 0._wp .AND. v_i(ji,jj,jl+1) <= (a_i(ji,jj,jl+1) * hi_max(jl)) ) THEN 652 npti = npti + 1 653 nptidx( npti ) = (jj - 1) * jpi + ji 654 ENDIF 655 END DO 656 END DO 645 DO_2D_11_11 646 IF( a_i(ji,jj,jl+1) > 0._wp .AND. v_i(ji,jj,jl+1) <= (a_i(ji,jj,jl+1) * hi_max(jl)) ) THEN 647 npti = npti + 1 648 nptidx( npti ) = (jj - 1) * jpi + ji 649 ENDIF 650 END_2D 657 651 ! 658 652 CALL tab_2d_1d( npti, nptidx(1:npti), a_i_1d(1:npti), a_i(:,:,jl+1) ) ! jl+1 is ok -
NEMO/branches/2020/temporary_r4_trunk/src/ICE/icesbc.F90
r13466 r13469 77 77 IF( ln_mixcpl) THEN ! Case of a mixed Bulk/Coupled formulation 78 78 CALL sbc_cpl_ice_tau( zutau_ice , zvtau_ice ) 79 DO jj = 2, jpjm1 80 DO ji = 2, jpim1 81 utau_ice(ji,jj) = utau_ice(ji,jj) * xcplmask(ji,jj,0) + zutau_ice(ji,jj) * ( 1. - xcplmask(ji,jj,0) ) 82 vtau_ice(ji,jj) = vtau_ice(ji,jj) * xcplmask(ji,jj,0) + zvtau_ice(ji,jj) * ( 1. - xcplmask(ji,jj,0) ) 83 END DO 84 END DO 79 DO_2D_00_00 80 utau_ice(ji,jj) = utau_ice(ji,jj) * xcplmask(ji,jj,0) + zutau_ice(ji,jj) * ( 1. - xcplmask(ji,jj,0) ) 81 vtau_ice(ji,jj) = vtau_ice(ji,jj) * xcplmask(ji,jj,0) + zvtau_ice(ji,jj) * ( 1. - xcplmask(ji,jj,0) ) 82 END_2D 85 83 CALL lbc_lnk_multi( 'icesbc', utau_ice, 'U', -1., vtau_ice, 'V', -1. ) 86 84 ENDIF -
NEMO/branches/2020/temporary_r4_trunk/src/ICE/icestp.F90
r13467 r13469 209 209 ! --- Ocean time step --- ! 210 210 !-------------------------! 211 IF( ln_icedyn ) CALL ice_update_tau( kt, u b(:,:,1), vb(:,:,1) ) ! -- update surface ocean stresses211 IF( ln_icedyn ) CALL ice_update_tau( kt, uu(:,:,1,Nnn), vv(:,:,1,Nnn) ) ! -- update surface ocean stresses 212 212 !!gm remark, the ocean-ice stress is not saved in ice diag call above ..... find a solution!!! 213 213 ! -
NEMO/branches/2020/temporary_r4_trunk/src/ICE/icethd.F90
r13466 r13469 120 120 zu_io(:,:) = u_ice(:,:) - ssu_m(:,:) 121 121 zv_io(:,:) = v_ice(:,:) - ssv_m(:,:) 122 DO jj = 2, jpjm1 123 DO ji = fs_2, fs_jpim1 124 zfric(ji,jj) = rn_cio * ( 0.5_wp * & 125 & ( zu_io(ji,jj) * zu_io(ji,jj) + zu_io(ji-1,jj) * zu_io(ji-1,jj) & 126 & + zv_io(ji,jj) * zv_io(ji,jj) + zv_io(ji,jj-1) * zv_io(ji,jj-1) ) ) * tmask(ji,jj,1) 127 END DO 128 END DO 122 DO_2D_00_00 123 zfric(ji,jj) = rn_cio * ( 0.5_wp * & 124 & ( zu_io(ji,jj) * zu_io(ji,jj) + zu_io(ji-1,jj) * zu_io(ji-1,jj) & 125 & + zv_io(ji,jj) * zv_io(ji,jj) + zv_io(ji,jj-1) * zv_io(ji,jj-1) ) ) * tmask(ji,jj,1) 126 END_2D 129 127 ELSE ! if no ice dynamics => transmit directly the atmospheric stress to the ocean 130 DO jj = 2, jpjm1 131 DO ji = fs_2, fs_jpim1 132 zfric(ji,jj) = r1_rau0 * SQRT( 0.5_wp * & 133 & ( utau(ji,jj) * utau(ji,jj) + utau(ji-1,jj) * utau(ji-1,jj) & 134 & + vtau(ji,jj) * vtau(ji,jj) + vtau(ji,jj-1) * vtau(ji,jj-1) ) ) * tmask(ji,jj,1) 135 END DO 136 END DO 128 DO_2D_00_00 129 zfric(ji,jj) = r1_rau0 * SQRT( 0.5_wp * & 130 & ( utau(ji,jj) * utau(ji,jj) + utau(ji-1,jj) * utau(ji-1,jj) & 131 & + vtau(ji,jj) * vtau(ji,jj) + vtau(ji,jj-1) * vtau(ji,jj-1) ) ) * tmask(ji,jj,1) 132 END_2D 137 133 ENDIF 138 134 CALL lbc_lnk( 'icethd', zfric, 'T', 1. ) … … 141 137 ! Partial computation of forcing for the thermodynamic sea ice model 142 138 !--------------------------------------------------------------------! 143 DO jj = 1, jpj 144 DO ji = 1, jpi 145 rswitch = tmask(ji,jj,1) * MAX( 0._wp , SIGN( 1._wp , at_i(ji,jj) - epsi10 ) ) ! 0 if no ice 146 ! 147 ! ! solar irradiance transmission at the mixed layer bottom and used in the lead heat budget 148 ! ! practically no "direct lateral ablation" 149 ! 150 ! ! net downward heat flux from the ice to the ocean, expressed as a function of ocean 151 ! ! temperature and turbulent mixing (McPhee, 1992) 152 ! 153 ! --- Energy received in the lead from atm-oce exchanges, zqld is defined everywhere (J.m-2) --- ! 154 zqld = tmask(ji,jj,1) * rdt_ice * & 155 & ( ( 1._wp - at_i_b(ji,jj) ) * qsr_oce(ji,jj) * frq_m(ji,jj) + & 156 & ( 1._wp - at_i_b(ji,jj) ) * qns_oce(ji,jj) + qemp_oce(ji,jj) ) 157 158 ! --- Energy needed to bring ocean surface layer until its freezing (mostly<0 but >0 if supercooling, J.m-2) --- ! 159 zqfr = rau0 * rcp * e3t_m(ji,jj) * ( t_bo(ji,jj) - ( sst_m(ji,jj) + rt0 ) ) * tmask(ji,jj,1) ! both < 0 (t_bo < sst) and > 0 (t_bo > sst) 160 zqfr_neg = MIN( zqfr , 0._wp ) ! only < 0 161 162 ! --- Sensible ocean-to-ice heat flux (mostly>0 but <0 if supercooling, W/m2) 163 zfric_u = MAX( SQRT( zfric(ji,jj) ), zfric_umin ) 164 qsb_ice_bot(ji,jj) = rswitch * rau0 * rcp * zch * zfric_u * ( ( sst_m(ji,jj) + rt0 ) - t_bo(ji,jj) ) ! W.m-2 165 166 qsb_ice_bot(ji,jj) = rswitch * MIN( qsb_ice_bot(ji,jj), - zqfr_neg * r1_rdtice / MAX( at_i(ji,jj), epsi10 ) ) 167 ! upper bound for qsb_ice_bot: the heat retrieved from the ocean must be smaller than the heat necessary to reach 168 ! the freezing point, so that we do not have SST < T_freeze 169 ! This implies: - ( qsb_ice_bot(ji,jj) * at_i(ji,jj) * rtdice ) - zqfr >= 0 170 171 !-- Energy Budget of the leads (J.m-2), source of ice growth in open water. Must be < 0 to form ice 172 qlead(ji,jj) = MIN( 0._wp , zqld - ( qsb_ice_bot(ji,jj) * at_i(ji,jj) * rdt_ice ) - zqfr ) 173 174 ! If there is ice and leads are warming => transfer energy from the lead budget and use it for bottom melting 175 ! If the grid cell is fully covered by ice (no leads) => transfer energy from the lead budget to the ice bottom budget 176 IF( ( zqld >= 0._wp .AND. at_i(ji,jj) > 0._wp ) .OR. at_i(ji,jj) >= (1._wp - epsi10) ) THEN 177 IF( ln_leadhfx ) THEN ; fhld(ji,jj) = rswitch * zqld * r1_rdtice / MAX( at_i(ji,jj), epsi10 ) ! divided by at_i since this is (re)multiplied by a_i in icethd_dh.F90 178 ELSE ; fhld(ji,jj) = 0._wp 179 ENDIF 180 qlead(ji,jj) = 0._wp 181 ELSE 182 fhld (ji,jj) = 0._wp 139 DO_2D_11_11 140 rswitch = tmask(ji,jj,1) * MAX( 0._wp , SIGN( 1._wp , at_i(ji,jj) - epsi10 ) ) ! 0 if no ice 141 ! 142 ! ! solar irradiance transmission at the mixed layer bottom and used in the lead heat budget 143 ! ! practically no "direct lateral ablation" 144 ! 145 ! ! net downward heat flux from the ice to the ocean, expressed as a function of ocean 146 ! ! temperature and turbulent mixing (McPhee, 1992) 147 ! 148 ! --- Energy received in the lead from atm-oce exchanges, zqld is defined everywhere (J.m-2) --- ! 149 zqld = tmask(ji,jj,1) * rdt_ice * & 150 & ( ( 1._wp - at_i_b(ji,jj) ) * qsr_oce(ji,jj) * frq_m(ji,jj) + & 151 & ( 1._wp - at_i_b(ji,jj) ) * qns_oce(ji,jj) + qemp_oce(ji,jj) ) 152 153 ! --- Energy needed to bring ocean surface layer until its freezing (mostly<0 but >0 if supercooling, J.m-2) --- ! 154 zqfr = rau0 * rcp * e3t_m(ji,jj) * ( t_bo(ji,jj) - ( sst_m(ji,jj) + rt0 ) ) * tmask(ji,jj,1) ! both < 0 (t_bo < sst) and > 0 (t_bo > sst) 155 zqfr_neg = MIN( zqfr , 0._wp ) ! only < 0 156 157 ! --- Sensible ocean-to-ice heat flux (mostly>0 but <0 if supercooling, W/m2) 158 zfric_u = MAX( SQRT( zfric(ji,jj) ), zfric_umin ) 159 qsb_ice_bot(ji,jj) = rswitch * rau0 * rcp * zch * zfric_u * ( ( sst_m(ji,jj) + rt0 ) - t_bo(ji,jj) ) ! W.m-2 160 161 qsb_ice_bot(ji,jj) = rswitch * MIN( qsb_ice_bot(ji,jj), - zqfr_neg * r1_rdtice / MAX( at_i(ji,jj), epsi10 ) ) 162 ! upper bound for qsb_ice_bot: the heat retrieved from the ocean must be smaller than the heat necessary to reach 163 ! the freezing point, so that we do not have SST < T_freeze 164 ! This implies: - ( qsb_ice_bot(ji,jj) * at_i(ji,jj) * rtdice ) - zqfr >= 0 165 166 !-- Energy Budget of the leads (J.m-2), source of ice growth in open water. Must be < 0 to form ice 167 qlead(ji,jj) = MIN( 0._wp , zqld - ( qsb_ice_bot(ji,jj) * at_i(ji,jj) * rdt_ice ) - zqfr ) 168 169 ! If there is ice and leads are warming => transfer energy from the lead budget and use it for bottom melting 170 ! If the grid cell is fully covered by ice (no leads) => transfer energy from the lead budget to the ice bottom budget 171 IF( ( zqld >= 0._wp .AND. at_i(ji,jj) > 0._wp ) .OR. at_i(ji,jj) >= (1._wp - epsi10) ) THEN 172 IF( ln_leadhfx ) THEN ; fhld(ji,jj) = rswitch * zqld * r1_rdtice / MAX( at_i(ji,jj), epsi10 ) ! divided by at_i since this is (re)multiplied by a_i in icethd_dh.F90 173 ELSE ; fhld(ji,jj) = 0._wp 183 174 ENDIF 184 ! 185 ! Net heat flux on top of the ice-ocean [W.m-2] 186 ! --------------------------------------------- 187 qt_atm_oi(ji,jj) = qns_tot(ji,jj) + qsr_tot(ji,jj) 188 END DO 189 END DO 175 qlead(ji,jj) = 0._wp 176 ELSE 177 fhld (ji,jj) = 0._wp 178 ENDIF 179 ! 180 ! Net heat flux on top of the ice-ocean [W.m-2] 181 ! --------------------------------------------- 182 qt_atm_oi(ji,jj) = qns_tot(ji,jj) + qsr_tot(ji,jj) 183 END_2D 190 184 191 185 ! In case we bypass open-water ice formation … … 215 209 ! select ice covered grid points 216 210 npti = 0 ; nptidx(:) = 0 217 DO jj = 1, jpj 218 DO ji = 1, jpi 219 IF ( a_i(ji,jj,jl) > epsi10 ) THEN 220 npti = npti + 1 221 nptidx(npti) = (jj - 1) * jpi + ji 222 ENDIF 223 END DO 224 END DO 211 DO_2D_11_11 212 IF ( a_i(ji,jj,jl) > epsi10 ) THEN 213 npti = npti + 1 214 nptidx(npti) = (jj - 1) * jpi + ji 215 ENDIF 216 END_2D 225 217 226 218 IF( npti > 0 ) THEN ! If there is no ice, do nothing. -
NEMO/branches/2020/temporary_r4_trunk/src/ICE/iceupdate.F90
r13466 r13469 114 114 ENDIF 115 115 116 DO jj = 1, jpj 117 DO ji = 1, jpi 118 119 ! Solar heat flux reaching the ocean = zqsr (W.m-2) 120 !--------------------------------------------------- 121 zqsr = qsr_tot(ji,jj) - SUM( a_i_b(ji,jj,:) * ( qsr_ice(ji,jj,:) - qtr_ice_bot(ji,jj,:) ) ) 122 123 ! Total heat flux reaching the ocean = qt_oce_ai (W.m-2) 124 !--------------------------------------------------- 125 zqmass = hfx_thd(ji,jj) + hfx_dyn(ji,jj) + hfx_res(ji,jj) ! heat flux from snow is 0 (T=0 degC) 126 qt_oce_ai(ji,jj) = qt_oce_ai(ji,jj) + zqmass + zqsr 127 128 ! Add the residual from heat diffusion equation and sublimation (W.m-2) 129 !---------------------------------------------------------------------- 130 qt_oce_ai(ji,jj) = qt_oce_ai(ji,jj) + hfx_err_dif(ji,jj) + & 131 & ( hfx_sub(ji,jj) - SUM( qevap_ice(ji,jj,:) * a_i_b(ji,jj,:) ) ) 132 133 ! New qsr and qns used to compute the oceanic heat flux at the next time step 134 !---------------------------------------------------------------------------- 135 qsr(ji,jj) = zqsr 136 qns(ji,jj) = qt_oce_ai(ji,jj) - zqsr 137 138 ! Mass flux at the atm. surface 139 !----------------------------------- 140 wfx_sub(ji,jj) = wfx_snw_sub(ji,jj) + wfx_ice_sub(ji,jj) 141 142 ! Mass flux at the ocean surface 143 !------------------------------------ 144 ! case of realistic freshwater flux (Tartinville et al., 2001) (presently ACTIVATED) 145 ! ------------------------------------------------------------------------------------- 146 ! The idea of this approach is that the system that we consider is the ICE-OCEAN system 147 ! Thus FW flux = External ( E-P+snow melt) 148 ! Salt flux = Exchanges in the ice-ocean system then converted into FW 149 ! Associated to Ice formation AND Ice melting 150 ! Even if i see Ice melting as a FW and SALT flux 151 ! 152 ! mass flux from ice/ocean 153 wfx_ice(ji,jj) = wfx_bog(ji,jj) + wfx_bom(ji,jj) + wfx_sum(ji,jj) + wfx_sni(ji,jj) & 154 & + wfx_opw(ji,jj) + wfx_dyn(ji,jj) + wfx_res(ji,jj) + wfx_lam(ji,jj) + wfx_pnd(ji,jj) 155 156 ! add the snow melt water to snow mass flux to the ocean 157 wfx_snw(ji,jj) = wfx_snw_sni(ji,jj) + wfx_snw_dyn(ji,jj) + wfx_snw_sum(ji,jj) 158 159 ! mass flux at the ocean/ice interface 160 fmmflx(ji,jj) = - ( wfx_ice(ji,jj) + wfx_snw(ji,jj) + wfx_err_sub(ji,jj) ) ! F/M mass flux save at least for biogeochemical model 161 emp(ji,jj) = emp_oce(ji,jj) - wfx_ice(ji,jj) - wfx_snw(ji,jj) - wfx_err_sub(ji,jj) ! mass flux + F/M mass flux (always ice/ocean mass exchange) 162 163 164 ! Salt flux at the ocean surface 165 !------------------------------------------ 166 sfx(ji,jj) = sfx_bog(ji,jj) + sfx_bom(ji,jj) + sfx_sum(ji,jj) + sfx_sni(ji,jj) + sfx_opw(ji,jj) & 167 & + sfx_res(ji,jj) + sfx_dyn(ji,jj) + sfx_bri(ji,jj) + sfx_sub(ji,jj) + sfx_lam(ji,jj) 168 169 ! Mass of snow and ice per unit area 170 !---------------------------------------- 171 snwice_mass_b(ji,jj) = snwice_mass(ji,jj) ! save mass from the previous ice time step 172 ! ! new mass per unit area 173 snwice_mass (ji,jj) = tmask(ji,jj,1) * ( rhos * vt_s(ji,jj) + rhoi * vt_i(ji,jj) ) 174 ! ! time evolution of snow+ice mass 175 snwice_fmass (ji,jj) = ( snwice_mass(ji,jj) - snwice_mass_b(ji,jj) ) * r1_rdtice 176 177 END DO 178 END DO 116 DO_2D_11_11 117 118 ! Solar heat flux reaching the ocean = zqsr (W.m-2) 119 !--------------------------------------------------- 120 zqsr = qsr_tot(ji,jj) - SUM( a_i_b(ji,jj,:) * ( qsr_ice(ji,jj,:) - qtr_ice_bot(ji,jj,:) ) ) 121 122 ! Total heat flux reaching the ocean = qt_oce_ai (W.m-2) 123 !--------------------------------------------------- 124 zqmass = hfx_thd(ji,jj) + hfx_dyn(ji,jj) + hfx_res(ji,jj) ! heat flux from snow is 0 (T=0 degC) 125 qt_oce_ai(ji,jj) = qt_oce_ai(ji,jj) + zqmass + zqsr 126 127 ! Add the residual from heat diffusion equation and sublimation (W.m-2) 128 !---------------------------------------------------------------------- 129 qt_oce_ai(ji,jj) = qt_oce_ai(ji,jj) + hfx_err_dif(ji,jj) + & 130 & ( hfx_sub(ji,jj) - SUM( qevap_ice(ji,jj,:) * a_i_b(ji,jj,:) ) ) 131 132 ! New qsr and qns used to compute the oceanic heat flux at the next time step 133 !---------------------------------------------------------------------------- 134 qsr(ji,jj) = zqsr 135 qns(ji,jj) = qt_oce_ai(ji,jj) - zqsr 136 137 ! Mass flux at the atm. surface 138 !----------------------------------- 139 wfx_sub(ji,jj) = wfx_snw_sub(ji,jj) + wfx_ice_sub(ji,jj) 140 141 ! Mass flux at the ocean surface 142 !------------------------------------ 143 ! case of realistic freshwater flux (Tartinville et al., 2001) (presently ACTIVATED) 144 ! ------------------------------------------------------------------------------------- 145 ! The idea of this approach is that the system that we consider is the ICE-OCEAN system 146 ! Thus FW flux = External ( E-P+snow melt) 147 ! Salt flux = Exchanges in the ice-ocean system then converted into FW 148 ! Associated to Ice formation AND Ice melting 149 ! Even if i see Ice melting as a FW and SALT flux 150 ! 151 ! mass flux from ice/ocean 152 wfx_ice(ji,jj) = wfx_bog(ji,jj) + wfx_bom(ji,jj) + wfx_sum(ji,jj) + wfx_sni(ji,jj) & 153 & + wfx_opw(ji,jj) + wfx_dyn(ji,jj) + wfx_res(ji,jj) + wfx_lam(ji,jj) + wfx_pnd(ji,jj) 154 155 ! add the snow melt water to snow mass flux to the ocean 156 wfx_snw(ji,jj) = wfx_snw_sni(ji,jj) + wfx_snw_dyn(ji,jj) + wfx_snw_sum(ji,jj) 157 158 ! mass flux at the ocean/ice interface 159 fmmflx(ji,jj) = - ( wfx_ice(ji,jj) + wfx_snw(ji,jj) + wfx_err_sub(ji,jj) ) ! F/M mass flux save at least for biogeochemical model 160 emp(ji,jj) = emp_oce(ji,jj) - wfx_ice(ji,jj) - wfx_snw(ji,jj) - wfx_err_sub(ji,jj) ! mass flux + F/M mass flux (always ice/ocean mass exchange) 161 162 163 ! Salt flux at the ocean surface 164 !------------------------------------------ 165 sfx(ji,jj) = sfx_bog(ji,jj) + sfx_bom(ji,jj) + sfx_sum(ji,jj) + sfx_sni(ji,jj) + sfx_opw(ji,jj) & 166 & + sfx_res(ji,jj) + sfx_dyn(ji,jj) + sfx_bri(ji,jj) + sfx_sub(ji,jj) + sfx_lam(ji,jj) 167 168 ! Mass of snow and ice per unit area 169 !---------------------------------------- 170 snwice_mass_b(ji,jj) = snwice_mass(ji,jj) ! save mass from the previous ice time step 171 ! ! new mass per unit area 172 snwice_mass (ji,jj) = tmask(ji,jj,1) * ( rhos * vt_s(ji,jj) + rhoi * vt_i(ji,jj) ) 173 ! ! time evolution of snow+ice mass 174 snwice_fmass (ji,jj) = ( snwice_mass(ji,jj) - snwice_mass_b(ji,jj) ) * r1_rdtice 175 176 END_2D 179 177 180 178 ! Storing the transmitted variables … … 335 333 ! 336 334 IF( MOD( kt-1, nn_fsbc ) == 0 ) THEN !== Ice time-step only ==! (i.e. surface module time-step) 337 DO jj = 2, jpjm1 !* update the modulus of stress at ocean surface (T-point) 338 DO ji = fs_2, fs_jpim1 339 ! ! 2*(U_ice-U_oce) at T-point 340 zu_t = u_ice(ji,jj) + u_ice(ji-1,jj) - u_oce(ji,jj) - u_oce(ji-1,jj) 341 zv_t = v_ice(ji,jj) + v_ice(ji,jj-1) - v_oce(ji,jj) - v_oce(ji,jj-1) 342 ! ! |U_ice-U_oce|^2 343 zmodt = 0.25_wp * ( zu_t * zu_t + zv_t * zv_t ) 344 ! ! update the ocean stress modulus 345 taum(ji,jj) = ( 1._wp - at_i(ji,jj) ) * taum(ji,jj) + at_i(ji,jj) * zrhoco * zmodt 346 tmod_io(ji,jj) = zrhoco * SQRT( zmodt ) ! rhoco * |U_ice-U_oce| at T-point 347 END DO 348 END DO 335 DO_2D_00_00 336 ! ! 2*(U_ice-U_oce) at T-point 337 zu_t = u_ice(ji,jj) + u_ice(ji-1,jj) - u_oce(ji,jj) - u_oce(ji-1,jj) 338 zv_t = v_ice(ji,jj) + v_ice(ji,jj-1) - v_oce(ji,jj) - v_oce(ji,jj-1) 339 ! ! |U_ice-U_oce|^2 340 zmodt = 0.25_wp * ( zu_t * zu_t + zv_t * zv_t ) 341 ! ! update the ocean stress modulus 342 taum(ji,jj) = ( 1._wp - at_i(ji,jj) ) * taum(ji,jj) + at_i(ji,jj) * zrhoco * zmodt 343 tmod_io(ji,jj) = zrhoco * SQRT( zmodt ) ! rhoco * |U_ice-U_oce| at T-point 344 END_2D 349 345 CALL lbc_lnk_multi( 'iceupdate', taum, 'T', 1., tmod_io, 'T', 1. ) 350 346 ! … … 363 359 ENDIF 364 360 ! 365 DO jj = 2, jpjm1 !* update the stress WITHOUT an ice-ocean rotation angle 366 DO ji = fs_2, fs_jpim1 ! Vect. Opt. 367 ! ice area at u and v-points 368 zat_u = ( at_i(ji,jj) * tmask(ji,jj,1) + at_i (ji+1,jj ) * tmask(ji+1,jj ,1) ) & 369 & / MAX( 1.0_wp , tmask(ji,jj,1) + tmask(ji+1,jj ,1) ) 370 zat_v = ( at_i(ji,jj) * tmask(ji,jj,1) + at_i (ji ,jj+1 ) * tmask(ji ,jj+1,1) ) & 371 & / MAX( 1.0_wp , tmask(ji,jj,1) + tmask(ji ,jj+1,1) ) 372 ! ! linearized quadratic drag formulation 373 zutau_ice = 0.5_wp * ( tmod_io(ji,jj) + tmod_io(ji+1,jj) ) * ( u_ice(ji,jj) - zflagi * pu_oce(ji,jj) ) 374 zvtau_ice = 0.5_wp * ( tmod_io(ji,jj) + tmod_io(ji,jj+1) ) * ( v_ice(ji,jj) - zflagi * pv_oce(ji,jj) ) 375 ! ! stresses at the ocean surface 376 utau(ji,jj) = ( 1._wp - zat_u ) * utau_oce(ji,jj) + zat_u * zutau_ice 377 vtau(ji,jj) = ( 1._wp - zat_v ) * vtau_oce(ji,jj) + zat_v * zvtau_ice 378 END DO 379 END DO 361 DO_2D_00_00 362 ! ice area at u and v-points 363 zat_u = ( at_i(ji,jj) * tmask(ji,jj,1) + at_i (ji+1,jj ) * tmask(ji+1,jj ,1) ) & 364 & / MAX( 1.0_wp , tmask(ji,jj,1) + tmask(ji+1,jj ,1) ) 365 zat_v = ( at_i(ji,jj) * tmask(ji,jj,1) + at_i (ji ,jj+1 ) * tmask(ji ,jj+1,1) ) & 366 & / MAX( 1.0_wp , tmask(ji,jj,1) + tmask(ji ,jj+1,1) ) 367 ! ! linearized quadratic drag formulation 368 zutau_ice = 0.5_wp * ( tmod_io(ji,jj) + tmod_io(ji+1,jj) ) * ( u_ice(ji,jj) - zflagi * pu_oce(ji,jj) ) 369 zvtau_ice = 0.5_wp * ( tmod_io(ji,jj) + tmod_io(ji,jj+1) ) * ( v_ice(ji,jj) - zflagi * pv_oce(ji,jj) ) 370 ! ! stresses at the ocean surface 371 utau(ji,jj) = ( 1._wp - zat_u ) * utau_oce(ji,jj) + zat_u * zutau_ice 372 vtau(ji,jj) = ( 1._wp - zat_v ) * vtau_oce(ji,jj) + zat_v * zvtau_ice 373 END_2D 380 374 CALL lbc_lnk_multi( 'iceupdate', utau, 'U', -1., vtau, 'V', -1. ) ! lateral boundary condition 381 375 ! -
NEMO/branches/2020/temporary_r4_trunk/src/ICE/icevar.F90
r13466 r13469 263 263 zlay_i = REAL( nlay_i , wp ) ! number of layers 264 264 DO jl = 1, jpl 265 DO jk = 1, nlay_i 266 DO jj = 1, jpj 267 DO ji = 1, jpi 268 IF ( v_i(ji,jj,jl) > epsi20 ) THEN !--- icy area 269 ! 270 ze_i = e_i (ji,jj,jk,jl) * z1_v_i(ji,jj,jl) * zlay_i ! Energy of melting e(S,T) [J.m-3] 271 ztmelts = - sz_i(ji,jj,jk,jl) * rTmlt ! Ice layer melt temperature [C] 272 ! Conversion q(S,T) -> T (second order equation) 273 zbbb = ( rcp - rcpi ) * ztmelts + ze_i * r1_rhoi - rLfus 274 zccc = SQRT( MAX( zbbb * zbbb - 4._wp * rcpi * rLfus * ztmelts , 0._wp) ) 275 t_i(ji,jj,jk,jl) = MAX( -100._wp , MIN( -( zbbb + zccc ) * 0.5_wp * r1_rcpi , ztmelts ) ) + rt0 ! [K] with bounds: -100 < t_i < ztmelts 276 ! 277 ELSE !--- no ice 278 t_i(ji,jj,jk,jl) = rt0 279 ENDIF 280 END DO 281 END DO 282 END DO 265 DO_3D_11_11( 1, nlay_i ) 266 IF ( v_i(ji,jj,jl) > epsi20 ) THEN !--- icy area 267 ! 268 ze_i = e_i (ji,jj,jk,jl) * z1_v_i(ji,jj,jl) * zlay_i ! Energy of melting e(S,T) [J.m-3] 269 ztmelts = - sz_i(ji,jj,jk,jl) * rTmlt ! Ice layer melt temperature [C] 270 ! Conversion q(S,T) -> T (second order equation) 271 zbbb = ( rcp - rcpi ) * ztmelts + ze_i * r1_rhoi - rLfus 272 zccc = SQRT( MAX( zbbb * zbbb - 4._wp * rcpi * rLfus * ztmelts , 0._wp) ) 273 t_i(ji,jj,jk,jl) = MAX( -100._wp , MIN( -( zbbb + zccc ) * 0.5_wp * r1_rcpi , ztmelts ) ) + rt0 ! [K] with bounds: -100 < t_i < ztmelts 274 ! 275 ELSE !--- no ice 276 t_i(ji,jj,jk,jl) = rt0 277 ENDIF 278 END_3D 283 279 END DO 284 280 … … 372 368 z1_dS = 1._wp / ( zsi1 - zsi0 ) 373 369 DO jl = 1, jpl 374 DO jj = 1, jpj 375 DO ji = 1, jpi 376 zalpha(ji,jj,jl) = MAX( 0._wp , MIN( ( zsi1 - s_i(ji,jj,jl) ) * z1_dS , 1._wp ) ) 377 ! ! force a constant profile when SSS too low (Baltic Sea) 378 IF( 2._wp * s_i(ji,jj,jl) >= sss_m(ji,jj) ) zalpha(ji,jj,jl) = 0._wp 379 END DO 380 END DO 370 DO_2D_11_11 371 zalpha(ji,jj,jl) = MAX( 0._wp , MIN( ( zsi1 - s_i(ji,jj,jl) ) * z1_dS , 1._wp ) ) 372 ! ! force a constant profile when SSS too low (Baltic Sea) 373 IF( 2._wp * s_i(ji,jj,jl) >= sss_m(ji,jj) ) zalpha(ji,jj,jl) = 0._wp 374 END_2D 381 375 END DO 382 376 ! 383 377 ! Computation of the profile 384 378 DO jl = 1, jpl 385 DO jk = 1, nlay_i 386 DO jj = 1, jpj 387 DO ji = 1, jpi 388 ! ! linear profile with 0 surface value 389 zs0 = z_slope_s(ji,jj,jl) * ( REAL(jk,wp) - 0.5_wp ) * h_i(ji,jj,jl) * r1_nlay_i 390 zs = zalpha(ji,jj,jl) * zs0 + ( 1._wp - zalpha(ji,jj,jl) ) * s_i(ji,jj,jl) ! weighting the profile 391 sz_i(ji,jj,jk,jl) = MIN( rn_simax, MAX( zs, rn_simin ) ) 392 END DO 393 END DO 394 END DO 379 DO_3D_11_11( 1, nlay_i ) 380 ! ! linear profile with 0 surface value 381 zs0 = z_slope_s(ji,jj,jl) * ( REAL(jk,wp) - 0.5_wp ) * h_i(ji,jj,jl) * r1_nlay_i 382 zs = zalpha(ji,jj,jl) * zs0 + ( 1._wp - zalpha(ji,jj,jl) ) * s_i(ji,jj,jl) ! weighting the profile 383 sz_i(ji,jj,jk,jl) = MIN( rn_simax, MAX( zs, rn_simin ) ) 384 END_3D 395 385 END DO 396 386 ! … … 517 507 ! Zap ice energy and use ocean heat to melt ice 518 508 !----------------------------------------------------------------- 519 DO jk = 1, nlay_i 520 DO jj = 1 , jpj 521 DO ji = 1 , jpi 522 ! update exchanges with ocean 523 hfx_res(ji,jj) = hfx_res(ji,jj) - (1._wp - zswitch(ji,jj) ) * e_i(ji,jj,jk,jl) * r1_rdtice ! W.m-2 <0 524 e_i(ji,jj,jk,jl) = e_i(ji,jj,jk,jl) * zswitch(ji,jj) 525 t_i(ji,jj,jk,jl) = t_i(ji,jj,jk,jl) * zswitch(ji,jj) + rt0 * ( 1._wp - zswitch(ji,jj) ) 526 END DO 527 END DO 528 END DO 529 ! 530 DO jk = 1, nlay_s 531 DO jj = 1 , jpj 532 DO ji = 1 , jpi 533 ! update exchanges with ocean 534 hfx_res(ji,jj) = hfx_res(ji,jj) - (1._wp - zswitch(ji,jj) ) * e_s(ji,jj,jk,jl) * r1_rdtice ! W.m-2 <0 535 e_s(ji,jj,jk,jl) = e_s(ji,jj,jk,jl) * zswitch(ji,jj) 536 t_s(ji,jj,jk,jl) = t_s(ji,jj,jk,jl) * zswitch(ji,jj) + rt0 * ( 1._wp - zswitch(ji,jj) ) 537 END DO 538 END DO 539 END DO 509 DO_3D_11_11( 1, nlay_i ) 510 ! update exchanges with ocean 511 hfx_res(ji,jj) = hfx_res(ji,jj) - (1._wp - zswitch(ji,jj) ) * e_i(ji,jj,jk,jl) * r1_rdtice ! W.m-2 <0 512 e_i(ji,jj,jk,jl) = e_i(ji,jj,jk,jl) * zswitch(ji,jj) 513 t_i(ji,jj,jk,jl) = t_i(ji,jj,jk,jl) * zswitch(ji,jj) + rt0 * ( 1._wp - zswitch(ji,jj) ) 514 END_3D 515 ! 516 DO_3D_11_11( 1, nlay_s ) 517 ! update exchanges with ocean 518 hfx_res(ji,jj) = hfx_res(ji,jj) - (1._wp - zswitch(ji,jj) ) * e_s(ji,jj,jk,jl) * r1_rdtice ! W.m-2 <0 519 e_s(ji,jj,jk,jl) = e_s(ji,jj,jk,jl) * zswitch(ji,jj) 520 t_s(ji,jj,jk,jl) = t_s(ji,jj,jk,jl) * zswitch(ji,jj) + rt0 * ( 1._wp - zswitch(ji,jj) ) 521 END_3D 540 522 ! 541 523 !----------------------------------------------------------------- 542 524 ! zap ice and snow volume, add water and salt to ocean 543 525 !----------------------------------------------------------------- 544 DO jj = 1 , jpj 545 DO ji = 1 , jpi 546 ! update exchanges with ocean 547 sfx_res(ji,jj) = sfx_res(ji,jj) + (1._wp - zswitch(ji,jj) ) * sv_i(ji,jj,jl) * rhoi * r1_rdtice 548 wfx_res(ji,jj) = wfx_res(ji,jj) + (1._wp - zswitch(ji,jj) ) * v_i (ji,jj,jl) * rhoi * r1_rdtice 549 wfx_res(ji,jj) = wfx_res(ji,jj) + (1._wp - zswitch(ji,jj) ) * v_s (ji,jj,jl) * rhos * r1_rdtice 550 ! 551 a_i (ji,jj,jl) = a_i (ji,jj,jl) * zswitch(ji,jj) 552 v_i (ji,jj,jl) = v_i (ji,jj,jl) * zswitch(ji,jj) 553 v_s (ji,jj,jl) = v_s (ji,jj,jl) * zswitch(ji,jj) 554 t_su (ji,jj,jl) = t_su(ji,jj,jl) * zswitch(ji,jj) + t_bo(ji,jj) * ( 1._wp - zswitch(ji,jj) ) 555 oa_i (ji,jj,jl) = oa_i(ji,jj,jl) * zswitch(ji,jj) 556 sv_i (ji,jj,jl) = sv_i(ji,jj,jl) * zswitch(ji,jj) 557 ! 558 h_i (ji,jj,jl) = h_i (ji,jj,jl) * zswitch(ji,jj) 559 h_s (ji,jj,jl) = h_s (ji,jj,jl) * zswitch(ji,jj) 560 ! 561 a_ip (ji,jj,jl) = a_ip (ji,jj,jl) * zswitch(ji,jj) 562 v_ip (ji,jj,jl) = v_ip (ji,jj,jl) * zswitch(ji,jj) 563 v_il (ji,jj,jl) = v_il (ji,jj,jl) * zswitch(ji,jj) 564 ! 565 END DO 566 END DO 526 DO_2D_11_11 527 ! update exchanges with ocean 528 sfx_res(ji,jj) = sfx_res(ji,jj) + (1._wp - zswitch(ji,jj) ) * sv_i(ji,jj,jl) * rhoi * r1_rdtice 529 wfx_res(ji,jj) = wfx_res(ji,jj) + (1._wp - zswitch(ji,jj) ) * v_i (ji,jj,jl) * rhoi * r1_rdtice 530 wfx_res(ji,jj) = wfx_res(ji,jj) + (1._wp - zswitch(ji,jj) ) * v_s (ji,jj,jl) * rhos * r1_rdtice 531 ! 532 a_i (ji,jj,jl) = a_i (ji,jj,jl) * zswitch(ji,jj) 533 v_i (ji,jj,jl) = v_i (ji,jj,jl) * zswitch(ji,jj) 534 v_s (ji,jj,jl) = v_s (ji,jj,jl) * zswitch(ji,jj) 535 t_su (ji,jj,jl) = t_su(ji,jj,jl) * zswitch(ji,jj) + t_bo(ji,jj) * ( 1._wp - zswitch(ji,jj) ) 536 oa_i (ji,jj,jl) = oa_i(ji,jj,jl) * zswitch(ji,jj) 537 sv_i (ji,jj,jl) = sv_i(ji,jj,jl) * zswitch(ji,jj) 538 ! 539 h_i (ji,jj,jl) = h_i (ji,jj,jl) * zswitch(ji,jj) 540 h_s (ji,jj,jl) = h_s (ji,jj,jl) * zswitch(ji,jj) 541 ! 542 a_ip (ji,jj,jl) = a_ip (ji,jj,jl) * zswitch(ji,jj) 543 v_ip (ji,jj,jl) = v_ip (ji,jj,jl) * zswitch(ji,jj) 544 v_il (ji,jj,jl) = v_il (ji,jj,jl) * zswitch(ji,jj) 545 ! 546 END_2D 567 547 ! 568 548 END DO … … 617 597 ! zap ice energy and send it to the ocean 618 598 !---------------------------------------- 619 DO jk = 1, nlay_i 620 DO jj = 1 , jpj 621 DO ji = 1 , jpi 622 IF( pe_i(ji,jj,jk,jl) < 0._wp .OR. pa_i(ji,jj,jl) <= 0._wp ) THEN 623 hfx_res(ji,jj) = hfx_res(ji,jj) - pe_i(ji,jj,jk,jl) * z1_dt ! W.m-2 >0 624 pe_i(ji,jj,jk,jl) = 0._wp 625 ENDIF 626 END DO 627 END DO 628 END DO 629 ! 630 DO jk = 1, nlay_s 631 DO jj = 1 , jpj 632 DO ji = 1 , jpi 633 IF( pe_s(ji,jj,jk,jl) < 0._wp .OR. pa_i(ji,jj,jl) <= 0._wp ) THEN 634 hfx_res(ji,jj) = hfx_res(ji,jj) - pe_s(ji,jj,jk,jl) * z1_dt ! W.m-2 <0 635 pe_s(ji,jj,jk,jl) = 0._wp 636 ENDIF 637 END DO 638 END DO 639 END DO 599 DO_3D_11_11( 1, nlay_i ) 600 IF( pe_i(ji,jj,jk,jl) < 0._wp .OR. pa_i(ji,jj,jl) <= 0._wp ) THEN 601 hfx_res(ji,jj) = hfx_res(ji,jj) - pe_i(ji,jj,jk,jl) * z1_dt ! W.m-2 >0 602 pe_i(ji,jj,jk,jl) = 0._wp 603 ENDIF 604 END_3D 605 ! 606 DO_3D_11_11( 1, nlay_s ) 607 IF( pe_s(ji,jj,jk,jl) < 0._wp .OR. pa_i(ji,jj,jl) <= 0._wp ) THEN 608 hfx_res(ji,jj) = hfx_res(ji,jj) - pe_s(ji,jj,jk,jl) * z1_dt ! W.m-2 <0 609 pe_s(ji,jj,jk,jl) = 0._wp 610 ENDIF 611 END_3D 640 612 ! 641 613 !----------------------------------------------------- 642 614 ! zap ice and snow volume, add water and salt to ocean 643 615 !----------------------------------------------------- 644 DO jj = 1 , jpj 645 DO ji = 1 , jpi 646 IF( pv_i(ji,jj,jl) < 0._wp .OR. pa_i(ji,jj,jl) <= 0._wp ) THEN 647 wfx_res(ji,jj) = wfx_res(ji,jj) + pv_i (ji,jj,jl) * rhoi * z1_dt 648 pv_i (ji,jj,jl) = 0._wp 649 ENDIF 650 IF( pv_s(ji,jj,jl) < 0._wp .OR. pa_i(ji,jj,jl) <= 0._wp ) THEN 651 wfx_res(ji,jj) = wfx_res(ji,jj) + pv_s (ji,jj,jl) * rhos * z1_dt 652 pv_s (ji,jj,jl) = 0._wp 653 ENDIF 654 IF( psv_i(ji,jj,jl) < 0._wp .OR. pa_i(ji,jj,jl) <= 0._wp .OR. pv_i(ji,jj,jl) <= 0._wp ) THEN 655 sfx_res(ji,jj) = sfx_res(ji,jj) + psv_i(ji,jj,jl) * rhoi * z1_dt 656 psv_i (ji,jj,jl) = 0._wp 657 ENDIF 658 END DO 659 END DO 616 DO_2D_11_11 617 IF( pv_i(ji,jj,jl) < 0._wp .OR. pa_i(ji,jj,jl) <= 0._wp ) THEN 618 wfx_res(ji,jj) = wfx_res(ji,jj) + pv_i (ji,jj,jl) * rhoi * z1_dt 619 pv_i (ji,jj,jl) = 0._wp 620 ENDIF 621 IF( pv_s(ji,jj,jl) < 0._wp .OR. pa_i(ji,jj,jl) <= 0._wp ) THEN 622 wfx_res(ji,jj) = wfx_res(ji,jj) + pv_s (ji,jj,jl) * rhos * z1_dt 623 pv_s (ji,jj,jl) = 0._wp 624 ENDIF 625 IF( psv_i(ji,jj,jl) < 0._wp .OR. pa_i(ji,jj,jl) <= 0._wp .OR. pv_i(ji,jj,jl) <= 0._wp ) THEN 626 sfx_res(ji,jj) = sfx_res(ji,jj) + psv_i(ji,jj,jl) * rhoi * z1_dt 627 psv_i (ji,jj,jl) = 0._wp 628 ENDIF 629 END_2D 660 630 ! 661 631 END DO -
NEMO/branches/2020/temporary_r4_trunk/src/ICE/icewri.F90
r13466 r13469 69 69 70 70 ! tresholds for outputs 71 DO jj = 1, jpj 72 DO ji = 1, jpi 73 zmsk00(ji,jj) = MAX( 0._wp , SIGN( 1._wp , at_i(ji,jj) - epsi06 ) ) ! 1 if ice , 0 if no ice 74 zmsk05(ji,jj) = MAX( 0._wp , SIGN( 1._wp , at_i(ji,jj) - 0.05_wp ) ) ! 1 if 5% ice , 0 if less 75 zmsk15(ji,jj) = MAX( 0._wp , SIGN( 1._wp , at_i(ji,jj) - 0.15_wp ) ) ! 1 if 15% ice, 0 if less 76 zmsksn(ji,jj) = MAX( 0._wp , SIGN( 1._wp , vt_s(ji,jj) - epsi06 ) ) ! 1 if snow , 0 if no snow 77 END DO 78 END DO 71 DO_2D_11_11 72 zmsk00(ji,jj) = MAX( 0._wp , SIGN( 1._wp , at_i(ji,jj) - epsi06 ) ) ! 1 if ice , 0 if no ice 73 zmsk05(ji,jj) = MAX( 0._wp , SIGN( 1._wp , at_i(ji,jj) - 0.05_wp ) ) ! 1 if 5% ice , 0 if less 74 zmsk15(ji,jj) = MAX( 0._wp , SIGN( 1._wp , at_i(ji,jj) - 0.15_wp ) ) ! 1 if 15% ice, 0 if less 75 zmsksn(ji,jj) = MAX( 0._wp , SIGN( 1._wp , vt_s(ji,jj) - epsi06 ) ) ! 1 if snow , 0 if no snow 76 END_2D 79 77 DO jl = 1, jpl 80 DO jj = 1, jpj 81 DO ji = 1, jpi 82 zmsk00l(ji,jj,jl) = MAX( 0._wp , SIGN( 1._wp , a_i(ji,jj,jl) - epsi06 ) ) 83 zmsksnl(ji,jj,jl) = MAX( 0._wp , SIGN( 1._wp , v_s(ji,jj,jl) - epsi06 ) ) 84 END DO 85 END DO 78 DO_2D_11_11 79 zmsk00l(ji,jj,jl) = MAX( 0._wp , SIGN( 1._wp , a_i(ji,jj,jl) - epsi06 ) ) 80 zmsksnl(ji,jj,jl) = MAX( 0._wp , SIGN( 1._wp , v_s(ji,jj,jl) - epsi06 ) ) 81 END_2D 86 82 END DO 87 83 … … 134 130 ! 135 131 IF( iom_use('icevel') .OR. iom_use('fasticepres') ) THEN ! module of ice velocity 136 DO jj = 2 , jpjm1 137 DO ji = 2 , jpim1 138 z2da = u_ice(ji,jj) + u_ice(ji-1,jj) 139 z2db = v_ice(ji,jj) + v_ice(ji,jj-1) 140 z2d(ji,jj) = 0.5_wp * SQRT( z2da * z2da + z2db * z2db ) 141 END DO 142 END DO 132 DO_2D_00_00 133 z2da = u_ice(ji,jj) + u_ice(ji-1,jj) 134 z2db = v_ice(ji,jj) + v_ice(ji,jj-1) 135 z2d(ji,jj) = 0.5_wp * SQRT( z2da * z2da + z2db * z2db ) 136 END_2D 143 137 CALL lbc_lnk( 'icewri', z2d, 'T', 1. ) 144 138 CALL iom_put( 'icevel', z2d ) -
NEMO/branches/2020/temporary_r4_trunk/src/OCE/BDY/bdydta.F90
r13466 r13469 145 145 ii = idx_bdy(jbdy)%nbi(ib,igrd) 146 146 ij = idx_bdy(jbdy)%nbj(ib,igrd) 147 dta_bdy(jbdy)%u3d(ib,ik) = ( u n(ii,ij,ik) - un_b(ii,ij) ) * umask(ii,ij,ik)147 dta_bdy(jbdy)%u3d(ib,ik) = ( uu(ii,ij,ik,Nii) - un_b(ii,ij) ) * umask(ii,ij,ik) 148 148 END DO 149 149 END DO … … 153 153 ii = idx_bdy(jbdy)%nbi(ib,igrd) 154 154 ij = idx_bdy(jbdy)%nbj(ib,igrd) 155 dta_bdy(jbdy)%v3d(ib,ik) = ( v n(ii,ij,ik) - vn_b(ii,ij) ) * vmask(ii,ij,ik)155 dta_bdy(jbdy)%v3d(ib,ik) = ( vv(ii,ij,ik,Nii) - vn_b(ii,ij) ) * vmask(ii,ij,ik) 156 156 END DO 157 157 END DO -
NEMO/branches/2020/temporary_r4_trunk/src/OCE/DOM/domain.F90
r13466 r13469 140 140 ! Read in masks to define closed seas and lakes 141 141 ! 142 DO jj = 1, jpj ! depth of the iceshelves 143 DO ji = 1, jpi 144 ik = mikt(ji,jj) 145 risfdep(ji,jj) = gdepw_0(ji,jj,ik) 146 END DO 147 END DO 142 DO_2D_11_11 143 ik = mikt(ji,jj) 144 risfdep(ji,jj) = gdepw_0(ji,jj,ik) 145 END_2D 148 146 ! 149 147 ht_0(:,:) = 0._wp ! Reference ocean thickness -
NEMO/branches/2020/temporary_r4_trunk/src/OCE/DYN/dynspg_ts.F90
r13466 r13469 253 253 IF( ln_wd_il ) THEN ! W/D : limiter applied to spgspg 254 254 CALL wad_spg( sshn, zcpx, zcpy ) ! Calculating W/D gravity filters, zcpx and zcpy 255 DO jj = 2, jpjm1 256 DO ji = 2, jpim1 ! SPG with the application of W/D gravity filters 257 zu_trd(ji,jj) = zu_trd(ji,jj) - grav * ( sshn(ji+1,jj ) - sshn(ji ,jj ) ) & 258 & * r1_e1u(ji,jj) * zcpx(ji,jj) * wdrampu(ji,jj) !jth 259 zv_trd(ji,jj) = zv_trd(ji,jj) - grav * ( sshn(ji ,jj+1) - sshn(ji ,jj ) ) & 260 & * r1_e2v(ji,jj) * zcpy(ji,jj) * wdrampv(ji,jj) !jth 261 END DO 262 END DO 255 DO_2D_00_00 256 zu_trd(ji,jj) = zu_trd(ji,jj) - grav * ( sshn(ji+1,jj ) - sshn(ji ,jj ) ) & 257 & * r1_e1u(ji,jj) * zcpx(ji,jj) * wdrampu(ji,jj) !jth 258 zv_trd(ji,jj) = zv_trd(ji,jj) - grav * ( sshn(ji ,jj+1) - sshn(ji ,jj ) ) & 259 & * r1_e2v(ji,jj) * zcpy(ji,jj) * wdrampv(ji,jj) !jth 260 END_2D 263 261 ELSE ! now suface pressure gradient 264 DO jj = 2, jpjm1 265 DO ji = fs_2, fs_jpim1 ! vector opt. 266 zu_trd(ji,jj) = zu_trd(ji,jj) - grav * ( sshn(ji+1,jj ) - sshn(ji ,jj ) ) * r1_e1u(ji,jj) 267 zv_trd(ji,jj) = zv_trd(ji,jj) - grav * ( sshn(ji ,jj+1) - sshn(ji ,jj ) ) * r1_e2v(ji,jj) 268 END DO 269 END DO 270 ENDIF 271 ! 272 ENDIF 273 ! 274 DO jj = 2, jpjm1 ! Remove coriolis term (and possibly spg) from barotropic trend 275 DO ji = fs_2, fs_jpim1 276 zu_frc(ji,jj) = zu_frc(ji,jj) - zu_trd(ji,jj) * ssumask(ji,jj) 277 zv_frc(ji,jj) = zv_frc(ji,jj) - zv_trd(ji,jj) * ssvmask(ji,jj) 278 END DO 279 END DO 262 DO_2D_00_00 263 zu_trd(ji,jj) = zu_trd(ji,jj) - grav * ( sshn(ji+1,jj ) - sshn(ji ,jj ) ) * r1_e1u(ji,jj) 264 zv_trd(ji,jj) = zv_trd(ji,jj) - grav * ( sshn(ji ,jj+1) - sshn(ji ,jj ) ) * r1_e2v(ji,jj) 265 END_2D 266 ENDIF 267 ! 268 ENDIF 269 ! 270 DO_2D_00_00 271 zu_frc(ji,jj) = zu_frc(ji,jj) - zu_trd(ji,jj) * ssumask(ji,jj) 272 zv_frc(ji,jj) = zv_frc(ji,jj) - zv_trd(ji,jj) * ssvmask(ji,jj) 273 END_2D 280 274 ! 281 275 ! != Add bottom stress contribution from baroclinic velocities =! … … 287 281 IF( ln_apr_dyn ) THEN 288 282 IF( ln_bt_fw ) THEN ! FORWARD integration: use kt+1/2 pressure (NOW+1/2) 289 DO jj = 2, jpjm1 290 DO ji = fs_2, fs_jpim1 ! vector opt. 291 zu_frc(ji,jj) = zu_frc(ji,jj) + grav * ( ssh_ib (ji+1,jj ) - ssh_ib (ji,jj) ) * r1_e1u(ji,jj) 292 zv_frc(ji,jj) = zv_frc(ji,jj) + grav * ( ssh_ib (ji ,jj+1) - ssh_ib (ji,jj) ) * r1_e2v(ji,jj) 293 END DO 294 END DO 283 DO_2D_00_00 284 zu_frc(ji,jj) = zu_frc(ji,jj) + grav * ( ssh_ib (ji+1,jj ) - ssh_ib (ji,jj) ) * r1_e1u(ji,jj) 285 zv_frc(ji,jj) = zv_frc(ji,jj) + grav * ( ssh_ib (ji ,jj+1) - ssh_ib (ji,jj) ) * r1_e2v(ji,jj) 286 END_2D 295 287 ELSE ! CENTRED integration: use kt-1/2 + kt+1/2 pressure (NOW) 296 288 zztmp = grav * r1_2 297 DO jj = 2, jpjm1 298 DO ji = fs_2, fs_jpim1 ! vector opt. 299 zu_frc(ji,jj) = zu_frc(ji,jj) + zztmp * ( ssh_ib (ji+1,jj ) - ssh_ib (ji,jj) & 300 & + ssh_ibb(ji+1,jj ) - ssh_ibb(ji,jj) ) * r1_e1u(ji,jj) 301 zv_frc(ji,jj) = zv_frc(ji,jj) + zztmp * ( ssh_ib (ji ,jj+1) - ssh_ib (ji,jj) & 302 & + ssh_ibb(ji ,jj+1) - ssh_ibb(ji,jj) ) * r1_e2v(ji,jj) 303 END DO 304 END DO 289 DO_2D_00_00 290 zu_frc(ji,jj) = zu_frc(ji,jj) + zztmp * ( ssh_ib (ji+1,jj ) - ssh_ib (ji,jj) & 291 & + ssh_ibb(ji+1,jj ) - ssh_ibb(ji,jj) ) * r1_e1u(ji,jj) 292 zv_frc(ji,jj) = zv_frc(ji,jj) + zztmp * ( ssh_ib (ji ,jj+1) - ssh_ib (ji,jj) & 293 & + ssh_ibb(ji ,jj+1) - ssh_ibb(ji,jj) ) * r1_e2v(ji,jj) 294 END_2D 305 295 ENDIF 306 296 ENDIF … … 309 299 ! ! ---------------------------------- ! 310 300 IF( ln_bt_fw ) THEN ! Add wind forcing 311 DO jj = 2, jpjm1 312 DO ji = fs_2, fs_jpim1 ! vector opt. 313 zu_frc(ji,jj) = zu_frc(ji,jj) + r1_rau0 * utau(ji,jj) * r1_hu_n(ji,jj) 314 zv_frc(ji,jj) = zv_frc(ji,jj) + r1_rau0 * vtau(ji,jj) * r1_hv_n(ji,jj) 315 END DO 316 END DO 301 DO_2D_00_00 302 zu_frc(ji,jj) = zu_frc(ji,jj) + r1_rau0 * utau(ji,jj) * r1_hu_n(ji,jj) 303 zv_frc(ji,jj) = zv_frc(ji,jj) + r1_rau0 * vtau(ji,jj) * r1_hv_n(ji,jj) 304 END_2D 317 305 ELSE 318 306 zztmp = r1_rau0 * r1_2 319 DO jj = 2, jpjm1 320 DO ji = fs_2, fs_jpim1 ! vector opt. 321 zu_frc(ji,jj) = zu_frc(ji,jj) + zztmp * ( utau_b(ji,jj) + utau(ji,jj) ) * r1_hu_n(ji,jj) 322 zv_frc(ji,jj) = zv_frc(ji,jj) + zztmp * ( vtau_b(ji,jj) + vtau(ji,jj) ) * r1_hv_n(ji,jj) 323 END DO 324 END DO 307 DO_2D_00_00 308 zu_frc(ji,jj) = zu_frc(ji,jj) + zztmp * ( utau_b(ji,jj) + utau(ji,jj) ) * r1_hu_n(ji,jj) 309 zv_frc(ji,jj) = zv_frc(ji,jj) + zztmp * ( vtau_b(ji,jj) + vtau(ji,jj) ) * r1_hv_n(ji,jj) 310 END_2D 325 311 ENDIF 326 312 ! … … 457 443 ! 458 444 ! ! ocean u- and v-depth at mid-step (separate DO-loops remove the need of a lbc_lnk) 459 DO jj = 1, jpj 460 DO ji = 1, jpim1 ! not jpi-column 461 zhup2_e(ji,jj) = hu_0(ji,jj) + r1_2 * r1_e1e2u(ji,jj) & 462 & * ( e1e2t(ji ,jj) * zsshp2_e(ji ,jj) & 463 & + e1e2t(ji+1,jj) * zsshp2_e(ji+1,jj) ) * ssumask(ji,jj) 464 END DO 465 END DO 466 DO jj = 1, jpjm1 ! not jpj-row 467 DO ji = 1, jpi 468 zhvp2_e(ji,jj) = hv_0(ji,jj) + r1_2 * r1_e1e2v(ji,jj) & 469 & * ( e1e2t(ji,jj ) * zsshp2_e(ji,jj ) & 470 & + e1e2t(ji,jj+1) * zsshp2_e(ji,jj+1) ) * ssvmask(ji,jj) 471 END DO 472 END DO 445 DO_2D_11_10 446 zhup2_e(ji,jj) = hu_0(ji,jj) + r1_2 * r1_e1e2u(ji,jj) & 447 & * ( e1e2t(ji ,jj) * zsshp2_e(ji ,jj) & 448 & + e1e2t(ji+1,jj) * zsshp2_e(ji+1,jj) ) * ssumask(ji,jj) 449 END_2D 450 DO_2D_10_11 451 zhvp2_e(ji,jj) = hv_0(ji,jj) + r1_2 * r1_e1e2v(ji,jj) & 452 & * ( e1e2t(ji,jj ) * zsshp2_e(ji,jj ) & 453 & + e1e2t(ji,jj+1) * zsshp2_e(ji,jj+1) ) * ssvmask(ji,jj) 454 END_2D 473 455 ! 474 456 ENDIF … … 526 508 !-- ssh = ssh - delta_t' * [ frc + div( flux ) ] --! 527 509 !-------------------------------------------------------------------------! 528 DO jj = 2, jpjm1 ! INNER domain 529 DO ji = 2, jpim1 530 zhdiv = ( zhU(ji,jj) - zhU(ji-1,jj) + zhV(ji,jj) - zhV(ji,jj-1) ) * r1_e1e2t(ji,jj) 531 ssha_e(ji,jj) = ( sshn_e(ji,jj) - rdtbt * ( zssh_frc(ji,jj) + zhdiv ) ) * ssmask(ji,jj) 532 END DO 533 END DO 510 DO_2D_00_00 511 zhdiv = ( zhU(ji,jj) - zhU(ji-1,jj) + zhV(ji,jj) - zhV(ji,jj-1) ) * r1_e1e2t(ji,jj) 512 ssha_e(ji,jj) = ( sshn_e(ji,jj) - rdtbt * ( zssh_frc(ji,jj) + zhdiv ) ) * ssmask(ji,jj) 513 END_2D 534 514 ! 535 515 CALL lbc_lnk_multi( 'dynspg_ts', ssha_e, 'T', 1._wp, zhU, 'U', -1._wp, zhV, 'V', -1._wp ) … … 553 533 ! Sea Surface Height at u-,v-points (vvl case only) 554 534 IF( .NOT.ln_linssh ) THEN 555 DO jj = 2, jpjm1 ! INNER domain, will be extended to whole domain later 556 DO ji = 2, jpim1 ! NO Vector Opt. 557 zsshu_a(ji,jj) = r1_2 * ssumask(ji,jj) * r1_e1e2u(ji,jj) & 558 & * ( e1e2t(ji ,jj ) * ssha_e(ji ,jj ) & 559 & + e1e2t(ji+1,jj ) * ssha_e(ji+1,jj ) ) 560 zsshv_a(ji,jj) = r1_2 * ssvmask(ji,jj) * r1_e1e2v(ji,jj) & 561 & * ( e1e2t(ji ,jj ) * ssha_e(ji ,jj ) & 562 & + e1e2t(ji ,jj+1) * ssha_e(ji ,jj+1) ) 563 END DO 564 END DO 535 DO_2D_00_00 536 zsshu_a(ji,jj) = r1_2 * ssumask(ji,jj) * r1_e1e2u(ji,jj) & 537 & * ( e1e2t(ji ,jj ) * ssha_e(ji ,jj ) & 538 & + e1e2t(ji+1,jj ) * ssha_e(ji+1,jj ) ) 539 zsshv_a(ji,jj) = r1_2 * ssvmask(ji,jj) * r1_e1e2v(ji,jj) & 540 & * ( e1e2t(ji ,jj ) * ssha_e(ji ,jj ) & 541 & + e1e2t(ji ,jj+1) * ssha_e(ji ,jj+1) ) 542 END_2D 565 543 ENDIF 566 544 ! … … 575 553 ! ! Surface pressure gradient 576 554 zldg = ( 1._wp - rn_scal_load ) * grav ! local factor 577 DO jj = 2, jpjm1 578 DO ji = 2, jpim1 579 zu_spg(ji,jj) = - zldg * ( zsshp2_e(ji+1,jj) - zsshp2_e(ji,jj) ) * r1_e1u(ji,jj) 580 zv_spg(ji,jj) = - zldg * ( zsshp2_e(ji,jj+1) - zsshp2_e(ji,jj) ) * r1_e2v(ji,jj) 581 END DO 582 END DO 555 DO_2D_00_00 556 zu_spg(ji,jj) = - zldg * ( zsshp2_e(ji+1,jj) - zsshp2_e(ji,jj) ) * r1_e1u(ji,jj) 557 zv_spg(ji,jj) = - zldg * ( zsshp2_e(ji,jj+1) - zsshp2_e(ji,jj) ) * r1_e2v(ji,jj) 558 END_2D 583 559 IF( ln_wd_il ) THEN ! W/D : gravity filters applied on pressure gradient 584 560 CALL wad_spg( zsshp2_e, zcpx, zcpy ) ! Calculating W/D gravity filters … … 595 571 ! Add tidal astronomical forcing if defined 596 572 IF ( ln_tide .AND. ln_tide_pot ) THEN 597 DO jj = 2, jpjm1 598 DO ji = fs_2, fs_jpim1 ! vector opt. 599 zu_trd(ji,jj) = zu_trd(ji,jj) + grav * ( pot_astro(ji+1,jj) - pot_astro(ji,jj) ) * r1_e1u(ji,jj) 600 zv_trd(ji,jj) = zv_trd(ji,jj) + grav * ( pot_astro(ji,jj+1) - pot_astro(ji,jj) ) * r1_e2v(ji,jj) 601 END DO 602 END DO 573 DO_2D_00_00 574 zu_trd(ji,jj) = zu_trd(ji,jj) + grav * ( pot_astro(ji+1,jj) - pot_astro(ji,jj) ) * r1_e1u(ji,jj) 575 zv_trd(ji,jj) = zv_trd(ji,jj) + grav * ( pot_astro(ji,jj+1) - pot_astro(ji,jj) ) * r1_e2v(ji,jj) 576 END_2D 603 577 ENDIF 604 578 ! … … 606 580 !jth do implicitly instead 607 581 IF ( .NOT. ll_wd ) THEN ! Revert to explicit for bit comparison tests in non wad runs 608 DO jj = 2, jpjm1 609 DO ji = fs_2, fs_jpim1 ! vector opt. 610 zu_trd(ji,jj) = zu_trd(ji,jj) + zCdU_u(ji,jj) * un_e(ji,jj) * hur_e(ji,jj) 611 zv_trd(ji,jj) = zv_trd(ji,jj) + zCdU_v(ji,jj) * vn_e(ji,jj) * hvr_e(ji,jj) 612 END DO 613 END DO 582 DO_2D_00_00 583 zu_trd(ji,jj) = zu_trd(ji,jj) + zCdU_u(ji,jj) * un_e(ji,jj) * hur_e(ji,jj) 584 zv_trd(ji,jj) = zv_trd(ji,jj) + zCdU_v(ji,jj) * vn_e(ji,jj) * hvr_e(ji,jj) 585 END_2D 614 586 ENDIF 615 587 ! … … 626 598 !------------------------------------------------------------------------------------------------------------------------! 627 599 IF( ln_dynadv_vec .OR. ln_linssh ) THEN !* Vector form 628 DO jj = 2, jpjm1 629 DO ji = fs_2, fs_jpim1 ! vector opt. 630 ua_e(ji,jj) = ( un_e(ji,jj) & 631 & + rdtbt * ( zu_spg(ji,jj) & 632 & + zu_trd(ji,jj) & 633 & + zu_frc(ji,jj) ) & 634 & ) * ssumask(ji,jj) 635 636 va_e(ji,jj) = ( vn_e(ji,jj) & 637 & + rdtbt * ( zv_spg(ji,jj) & 638 & + zv_trd(ji,jj) & 639 & + zv_frc(ji,jj) ) & 640 & ) * ssvmask(ji,jj) 641 END DO 642 END DO 600 DO_2D_00_00 601 ua_e(ji,jj) = ( un_e(ji,jj) & 602 & + rdtbt * ( zu_spg(ji,jj) & 603 & + zu_trd(ji,jj) & 604 & + zu_frc(ji,jj) ) & 605 & ) * ssumask(ji,jj) 606 607 va_e(ji,jj) = ( vn_e(ji,jj) & 608 & + rdtbt * ( zv_spg(ji,jj) & 609 & + zv_trd(ji,jj) & 610 & + zv_frc(ji,jj) ) & 611 & ) * ssvmask(ji,jj) 612 END_2D 643 613 ! 644 614 ELSE !* Flux form 645 DO jj = 2, jpjm1 646 DO ji = 2, jpim1 647 ! ! hu_e, hv_e hold depth at jn, zhup2_e, zhvp2_e hold extrapolated depth at jn+1/2 648 ! ! backward interpolated depth used in spg terms at jn+1/2 649 zhu_bck = hu_0(ji,jj) + r1_2*r1_e1e2u(ji,jj) * ( e1e2t(ji ,jj) * zsshp2_e(ji ,jj) & 650 & + e1e2t(ji+1,jj) * zsshp2_e(ji+1,jj) ) * ssumask(ji,jj) 651 zhv_bck = hv_0(ji,jj) + r1_2*r1_e1e2v(ji,jj) * ( e1e2t(ji,jj ) * zsshp2_e(ji,jj ) & 652 & + e1e2t(ji,jj+1) * zsshp2_e(ji,jj+1) ) * ssvmask(ji,jj) 653 ! ! inverse depth at jn+1 654 z1_hu = ssumask(ji,jj) / ( hu_0(ji,jj) + zsshu_a(ji,jj) + 1._wp - ssumask(ji,jj) ) 655 z1_hv = ssvmask(ji,jj) / ( hv_0(ji,jj) + zsshv_a(ji,jj) + 1._wp - ssvmask(ji,jj) ) 656 ! 657 ua_e(ji,jj) = ( hu_e (ji,jj) * un_e (ji,jj) & 658 & + rdtbt * ( zhu_bck * zu_spg (ji,jj) & ! 659 & + zhup2_e(ji,jj) * zu_trd (ji,jj) & ! 660 & + hu_n (ji,jj) * zu_frc (ji,jj) ) ) * z1_hu 661 ! 662 va_e(ji,jj) = ( hv_e (ji,jj) * vn_e (ji,jj) & 663 & + rdtbt * ( zhv_bck * zv_spg (ji,jj) & ! 664 & + zhvp2_e(ji,jj) * zv_trd (ji,jj) & ! 665 & + hv_n (ji,jj) * zv_frc (ji,jj) ) ) * z1_hv 666 END DO 667 END DO 615 DO_2D_00_00 616 ! ! hu_e, hv_e hold depth at jn, zhup2_e, zhvp2_e hold extrapolated depth at jn+1/2 617 ! ! backward interpolated depth used in spg terms at jn+1/2 618 zhu_bck = hu_0(ji,jj) + r1_2*r1_e1e2u(ji,jj) * ( e1e2t(ji ,jj) * zsshp2_e(ji ,jj) & 619 & + e1e2t(ji+1,jj) * zsshp2_e(ji+1,jj) ) * ssumask(ji,jj) 620 zhv_bck = hv_0(ji,jj) + r1_2*r1_e1e2v(ji,jj) * ( e1e2t(ji,jj ) * zsshp2_e(ji,jj ) & 621 & + e1e2t(ji,jj+1) * zsshp2_e(ji,jj+1) ) * ssvmask(ji,jj) 622 ! ! inverse depth at jn+1 623 z1_hu = ssumask(ji,jj) / ( hu_0(ji,jj) + zsshu_a(ji,jj) + 1._wp - ssumask(ji,jj) ) 624 z1_hv = ssvmask(ji,jj) / ( hv_0(ji,jj) + zsshv_a(ji,jj) + 1._wp - ssvmask(ji,jj) ) 625 ! 626 ua_e(ji,jj) = ( hu_e (ji,jj) * un_e (ji,jj) & 627 & + rdtbt * ( zhu_bck * zu_spg (ji,jj) & ! 628 & + zhup2_e(ji,jj) * zu_trd (ji,jj) & ! 629 & + hu_n (ji,jj) * zu_frc (ji,jj) ) ) * z1_hu 630 ! 631 va_e(ji,jj) = ( hv_e (ji,jj) * vn_e (ji,jj) & 632 & + rdtbt * ( zhv_bck * zv_spg (ji,jj) & ! 633 & + zhvp2_e(ji,jj) * zv_trd (ji,jj) & ! 634 & + hv_n (ji,jj) * zv_frc (ji,jj) ) ) * z1_hv 635 END_2D 668 636 ENDIF 669 637 !jth implicit bottom friction: 670 638 IF ( ll_wd ) THEN ! revert to explicit for bit comparison tests in non wad runs 671 DO jj = 2, jpjm1 672 DO ji = fs_2, fs_jpim1 ! vector opt. 673 ua_e(ji,jj) = ua_e(ji,jj) /(1.0 - rdtbt * zCdU_u(ji,jj) * hur_e(ji,jj)) 674 va_e(ji,jj) = va_e(ji,jj) /(1.0 - rdtbt * zCdU_v(ji,jj) * hvr_e(ji,jj)) 675 END DO 676 END DO 639 DO_2D_00_00 640 ua_e(ji,jj) = ua_e(ji,jj) /(1.0 - rdtbt * zCdU_u(ji,jj) * hur_e(ji,jj)) 641 va_e(ji,jj) = va_e(ji,jj) /(1.0 - rdtbt * zCdU_v(ji,jj) * hvr_e(ji,jj)) 642 END_2D 677 643 ENDIF 678 644 … … 737 703 IF (ln_bt_fw) THEN 738 704 IF( .NOT.( kt == nit000 .AND. neuler==0 ) ) THEN 739 DO jj = 1, jpj 740 DO ji = 1, jpi 741 zun_save = un_adv(ji,jj) 742 zvn_save = vn_adv(ji,jj) 743 ! ! apply the previously computed correction 744 un_adv(ji,jj) = r1_2 * ( ub2_b(ji,jj) + zun_save - atfp * un_bf(ji,jj) ) 745 vn_adv(ji,jj) = r1_2 * ( vb2_b(ji,jj) + zvn_save - atfp * vn_bf(ji,jj) ) 746 ! ! Update corrective fluxes for next time step 747 un_bf(ji,jj) = atfp * un_bf(ji,jj) + ( zun_save - ub2_b(ji,jj) ) 748 vn_bf(ji,jj) = atfp * vn_bf(ji,jj) + ( zvn_save - vb2_b(ji,jj) ) 749 ! ! Save integrated transport for next computation 750 ub2_b(ji,jj) = zun_save 751 vb2_b(ji,jj) = zvn_save 752 END DO 753 END DO 705 DO_2D_11_11 706 zun_save = un_adv(ji,jj) 707 zvn_save = vn_adv(ji,jj) 708 ! ! apply the previously computed correction 709 un_adv(ji,jj) = r1_2 * ( ub2_b(ji,jj) + zun_save - atfp * un_bf(ji,jj) ) 710 vn_adv(ji,jj) = r1_2 * ( vb2_b(ji,jj) + zvn_save - atfp * vn_bf(ji,jj) ) 711 ! ! Update corrective fluxes for next time step 712 un_bf(ji,jj) = atfp * un_bf(ji,jj) + ( zun_save - ub2_b(ji,jj) ) 713 vn_bf(ji,jj) = atfp * vn_bf(ji,jj) + ( zvn_save - vb2_b(ji,jj) ) 714 ! ! Save integrated transport for next computation 715 ub2_b(ji,jj) = zun_save 716 vb2_b(ji,jj) = zvn_save 717 END_2D 754 718 ELSE 755 719 un_bf(:,:) = 0._wp ! corrective fluxes for next time step set to zero … … 770 734 ELSE 771 735 ! At this stage, ssha has been corrected: compute new depths at velocity points 772 DO jj = 1, jpjm1 773 DO ji = 1, jpim1 ! NO Vector Opt. 774 zsshu_a(ji,jj) = r1_2 * ssumask(ji,jj) * r1_e1e2u(ji,jj) & 775 & * ( e1e2t(ji ,jj) * ssha(ji ,jj) & 776 & + e1e2t(ji+1,jj) * ssha(ji+1,jj) ) 777 zsshv_a(ji,jj) = r1_2 * ssvmask(ji,jj) * r1_e1e2v(ji,jj) & 778 & * ( e1e2t(ji,jj ) * ssha(ji,jj ) & 779 & + e1e2t(ji,jj+1) * ssha(ji,jj+1) ) 780 END DO 781 END DO 736 DO_2D_10_10 737 zsshu_a(ji,jj) = r1_2 * ssumask(ji,jj) * r1_e1e2u(ji,jj) & 738 & * ( e1e2t(ji ,jj) * ssha(ji ,jj) & 739 & + e1e2t(ji+1,jj) * ssha(ji+1,jj) ) 740 zsshv_a(ji,jj) = r1_2 * ssvmask(ji,jj) * r1_e1e2v(ji,jj) & 741 & * ( e1e2t(ji,jj ) * ssha(ji,jj ) & 742 & + e1e2t(ji,jj+1) * ssha(ji,jj+1) ) 743 END_2D 782 744 CALL lbc_lnk_multi( 'dynspg_ts', zsshu_a, 'U', 1._wp, zsshv_a, 'V', 1._wp ) ! Boundary conditions 783 745 ! … … 794 756 ! Correct velocities so that the barotropic velocity equals (un_adv, vn_adv) (in all cases) 795 757 DO jk = 1, jpkm1 796 u n(:,:,jk) = ( un(:,:,jk) + un_adv(:,:)*r1_hu_n(:,:) - un_b(:,:) ) * umask(:,:,jk)797 v n(:,:,jk) = ( vn(:,:,jk) + vn_adv(:,:)*r1_hv_n(:,:) - vn_b(:,:) ) * vmask(:,:,jk)758 uu(:,:,jk,Nii) = ( uu(:,:,jk,Nii) + un_adv(:,:)*r1_hu_n(:,:) - un_b(:,:) ) * umask(:,:,jk) 759 vv(:,:,jk,Nii) = ( vv(:,:,jk,Nii) + vn_adv(:,:)*r1_hv_n(:,:) - vn_b(:,:) ) * vmask(:,:,jk) 798 760 END DO 799 761 … … 802 764 CALL lbc_lnk_multi( 'dynspg_ts', zuwdav2, 'U', 1._wp, zvwdav2, 'V', 1._wp) 803 765 DO jk = 1, jpkm1 804 u n(:,:,jk) = ( un_adv(:,:)*r1_hu_n(:,:) &805 & + zuwdav2(:,:)*(u n(:,:,jk) - un_adv(:,:)*r1_hu_n(:,:)) ) * umask(:,:,jk)806 v n(:,:,jk) = ( vn_adv(:,:)*r1_hv_n(:,:) &807 & + zvwdav2(:,:)*(v n(:,:,jk) - vn_adv(:,:)*r1_hv_n(:,:)) ) * vmask(:,:,jk)766 uu(:,:,jk,Nii) = ( un_adv(:,:)*r1_hu_n(:,:) & 767 & + zuwdav2(:,:)*(uu(:,:,jk,Nii) - un_adv(:,:)*r1_hu_n(:,:)) ) * umask(:,:,jk) 768 vv(:,:,jk,Nii) = ( vn_adv(:,:)*r1_hv_n(:,:) & 769 & + zvwdav2(:,:)*(vv(:,:,jk,Nii) - vn_adv(:,:)*r1_hv_n(:,:)) ) * vmask(:,:,jk) 808 770 END DO 809 771 END IF … … 1007 969 ! Max courant number for ext. grav. waves 1008 970 ! 1009 DO jj = 1, jpj 1010 DO ji =1, jpi 1011 zxr2 = r1_e1t(ji,jj) * r1_e1t(ji,jj) 1012 zyr2 = r1_e2t(ji,jj) * r1_e2t(ji,jj) 1013 zcu(ji,jj) = SQRT( grav * MAX(ht_0(ji,jj),0._wp) * (zxr2 + zyr2) ) 1014 END DO 1015 END DO 971 DO_2D_11_11 972 zxr2 = r1_e1t(ji,jj) * r1_e1t(ji,jj) 973 zyr2 = r1_e2t(ji,jj) * r1_e2t(ji,jj) 974 zcu(ji,jj) = SQRT( grav * MAX(ht_0(ji,jj),0._wp) * (zxr2 + zyr2) ) 975 END_2D 1016 976 ! 1017 977 zcmax = MAXVAL( zcu(:,:) ) … … 1133 1093 SELECT CASE( nn_een_e3f ) !* ff_f/e3 at F-point 1134 1094 CASE ( 0 ) ! original formulation (masked averaging of e3t divided by 4) 1135 DO jj = 1, jpjm1 1136 DO ji = 1, jpim1 1137 zwz(ji,jj) = ( ht_n(ji ,jj+1) + ht_n(ji+1,jj+1) + & 1138 & ht_n(ji ,jj ) + ht_n(ji+1,jj ) ) * 0.25_wp 1139 IF( zwz(ji,jj) /= 0._wp ) zwz(ji,jj) = ff_f(ji,jj) / zwz(ji,jj) 1140 END DO 1141 END DO 1095 DO_2D_10_10 1096 zwz(ji,jj) = ( ht_n(ji ,jj+1) + ht_n(ji+1,jj+1) + & 1097 & ht_n(ji ,jj ) + ht_n(ji+1,jj ) ) * 0.25_wp 1098 IF( zwz(ji,jj) /= 0._wp ) zwz(ji,jj) = ff_f(ji,jj) / zwz(ji,jj) 1099 END_2D 1142 1100 CASE ( 1 ) ! new formulation (masked averaging of e3t divided by the sum of mask) 1143 DO jj = 1, jpjm1 1144 DO ji = 1, jpim1 1145 zwz(ji,jj) = ( ht_n (ji ,jj+1) + ht_n (ji+1,jj+1) & 1146 & + ht_n (ji ,jj ) + ht_n (ji+1,jj ) ) & 1147 & / ( MAX( 1._wp, ssmask(ji ,jj+1) + ssmask(ji+1,jj+1) & 1148 & + ssmask(ji ,jj ) + ssmask(ji+1,jj ) ) ) 1149 IF( zwz(ji,jj) /= 0._wp ) zwz(ji,jj) = ff_f(ji,jj) / zwz(ji,jj) 1150 END DO 1151 END DO 1101 DO_2D_10_10 1102 zwz(ji,jj) = ( ht_n (ji ,jj+1) + ht_n (ji+1,jj+1) & 1103 & + ht_n (ji ,jj ) + ht_n (ji+1,jj ) ) & 1104 & / ( MAX( 1._wp, ssmask(ji ,jj+1) + ssmask(ji+1,jj+1) & 1105 & + ssmask(ji ,jj ) + ssmask(ji+1,jj ) ) ) 1106 IF( zwz(ji,jj) /= 0._wp ) zwz(ji,jj) = ff_f(ji,jj) / zwz(ji,jj) 1107 END_2D 1152 1108 END SELECT 1153 1109 CALL lbc_lnk( 'dynspg_ts', zwz, 'F', 1._wp ) 1154 1110 ! 1155 1111 ftne(1,:) = 0._wp ; ftnw(1,:) = 0._wp ; ftse(1,:) = 0._wp ; ftsw(1,:) = 0._wp 1156 DO jj = 2, jpj 1157 DO ji = 2, jpi 1158 ftne(ji,jj) = zwz(ji-1,jj ) + zwz(ji ,jj ) + zwz(ji ,jj-1) 1159 ftnw(ji,jj) = zwz(ji-1,jj-1) + zwz(ji-1,jj ) + zwz(ji ,jj ) 1160 ftse(ji,jj) = zwz(ji ,jj ) + zwz(ji ,jj-1) + zwz(ji-1,jj-1) 1161 ftsw(ji,jj) = zwz(ji ,jj-1) + zwz(ji-1,jj-1) + zwz(ji-1,jj ) 1162 END DO 1163 END DO 1112 DO_2D_01_01 1113 ftne(ji,jj) = zwz(ji-1,jj ) + zwz(ji ,jj ) + zwz(ji ,jj-1) 1114 ftnw(ji,jj) = zwz(ji-1,jj-1) + zwz(ji-1,jj ) + zwz(ji ,jj ) 1115 ftse(ji,jj) = zwz(ji ,jj ) + zwz(ji ,jj-1) + zwz(ji-1,jj-1) 1116 ftsw(ji,jj) = zwz(ji ,jj-1) + zwz(ji-1,jj-1) + zwz(ji-1,jj ) 1117 END_2D 1164 1118 ! 1165 1119 CASE( np_EET ) != EEN scheme using e3t (energy conserving scheme) 1166 1120 ftne(1,:) = 0._wp ; ftnw(1,:) = 0._wp ; ftse(1,:) = 0._wp ; ftsw(1,:) = 0._wp 1167 DO jj = 2, jpj 1168 DO ji = 2, jpi 1169 z1_ht = ssmask(ji,jj) / ( ht_n(ji,jj) + 1._wp - ssmask(ji,jj) ) 1170 ftne(ji,jj) = ( ff_f(ji-1,jj ) + ff_f(ji ,jj ) + ff_f(ji ,jj-1) ) * z1_ht 1171 ftnw(ji,jj) = ( ff_f(ji-1,jj-1) + ff_f(ji-1,jj ) + ff_f(ji ,jj ) ) * z1_ht 1172 ftse(ji,jj) = ( ff_f(ji ,jj ) + ff_f(ji ,jj-1) + ff_f(ji-1,jj-1) ) * z1_ht 1173 ftsw(ji,jj) = ( ff_f(ji ,jj-1) + ff_f(ji-1,jj-1) + ff_f(ji-1,jj ) ) * z1_ht 1174 END DO 1175 END DO 1121 DO_2D_01_01 1122 z1_ht = ssmask(ji,jj) / ( ht_n(ji,jj) + 1._wp - ssmask(ji,jj) ) 1123 ftne(ji,jj) = ( ff_f(ji-1,jj ) + ff_f(ji ,jj ) + ff_f(ji ,jj-1) ) * z1_ht 1124 ftnw(ji,jj) = ( ff_f(ji-1,jj-1) + ff_f(ji-1,jj ) + ff_f(ji ,jj ) ) * z1_ht 1125 ftse(ji,jj) = ( ff_f(ji ,jj ) + ff_f(ji ,jj-1) + ff_f(ji-1,jj-1) ) * z1_ht 1126 ftsw(ji,jj) = ( ff_f(ji ,jj-1) + ff_f(ji-1,jj-1) + ff_f(ji-1,jj ) ) * z1_ht 1127 END_2D 1176 1128 ! 1177 1129 CASE( np_ENE, np_ENS , np_MIX ) != all other schemes (ENE, ENS, MIX) except ENT ! … … 1200 1152 ! 1201 1153 !zhf(:,:) = hbatf(:,:) 1202 DO jj = 1, jpjm1 1203 DO ji = 1, jpim1 1204 zhf(ji,jj) = ( ht_0 (ji,jj ) + ht_0 (ji+1,jj ) & 1205 & + ht_0 (ji,jj+1) + ht_0 (ji+1,jj+1) ) & 1206 & / MAX( ssmask(ji,jj ) + ssmask(ji+1,jj ) & 1207 & + ssmask(ji,jj+1) + ssmask(ji+1,jj+1) , 1._wp ) 1208 END DO 1209 END DO 1154 DO_2D_10_10 1155 zhf(ji,jj) = ( ht_0 (ji,jj ) + ht_0 (ji+1,jj ) & 1156 & + ht_0 (ji,jj+1) + ht_0 (ji+1,jj+1) ) & 1157 & / MAX( ssmask(ji,jj ) + ssmask(ji+1,jj ) & 1158 & + ssmask(ji,jj+1) + ssmask(ji+1,jj+1) , 1._wp ) 1159 END_2D 1210 1160 ENDIF 1211 1161 ! … … 1221 1171 CALL lbc_lnk( 'dynspg_ts', zhf, 'F', 1._wp ) 1222 1172 ! JC: TBC. hf should be greater than 0 1223 DO jj = 1, jpj 1224 DO ji = 1, jpi 1225 IF( zhf(ji,jj) /= 0._wp ) zwz(ji,jj) = 1._wp / zhf(ji,jj) 1226 END DO 1227 END DO 1173 DO_2D_11_11 1174 IF( zhf(ji,jj) /= 0._wp ) zwz(ji,jj) = 1._wp / zhf(ji,jj) 1175 END_2D 1228 1176 zwz(:,:) = ff_f(:,:) * zwz(:,:) 1229 1177 END SELECT … … 1246 1194 SELECT CASE( nvor_scheme ) 1247 1195 CASE( np_ENT ) ! enstrophy conserving scheme (f-point) 1248 DO jj = 2, jpjm1 1249 DO ji = 2, jpim1 1250 z1_hu = ssumask(ji,jj) / ( hu_n(ji,jj) + 1._wp - ssumask(ji,jj) ) 1251 z1_hv = ssvmask(ji,jj) / ( hv_n(ji,jj) + 1._wp - ssvmask(ji,jj) ) 1252 zu_trd(ji,jj) = + r1_4 * r1_e1e2u(ji,jj) * z1_hu & 1253 & * ( e1e2t(ji+1,jj)*ht_n(ji+1,jj)*ff_t(ji+1,jj) * ( vn_b(ji+1,jj) + vn_b(ji+1,jj-1) ) & 1254 & + e1e2t(ji ,jj)*ht_n(ji ,jj)*ff_t(ji ,jj) * ( vn_b(ji ,jj) + vn_b(ji ,jj-1) ) ) 1255 ! 1256 zv_trd(ji,jj) = - r1_4 * r1_e1e2v(ji,jj) * z1_hv & 1257 & * ( e1e2t(ji,jj+1)*ht_n(ji,jj+1)*ff_t(ji,jj+1) * ( un_b(ji,jj+1) + un_b(ji-1,jj+1) ) & 1258 & + e1e2t(ji,jj )*ht_n(ji,jj )*ff_t(ji,jj ) * ( un_b(ji,jj ) + un_b(ji-1,jj ) ) ) 1259 END DO 1260 END DO 1196 DO_2D_00_00 1197 z1_hu = ssumask(ji,jj) / ( hu_n(ji,jj) + 1._wp - ssumask(ji,jj) ) 1198 z1_hv = ssvmask(ji,jj) / ( hv_n(ji,jj) + 1._wp - ssvmask(ji,jj) ) 1199 zu_trd(ji,jj) = + r1_4 * r1_e1e2u(ji,jj) * z1_hu & 1200 & * ( e1e2t(ji+1,jj)*ht_n(ji+1,jj)*ff_t(ji+1,jj) * ( vn_b(ji+1,jj) + vn_b(ji+1,jj-1) ) & 1201 & + e1e2t(ji ,jj)*ht_n(ji ,jj)*ff_t(ji ,jj) * ( vn_b(ji ,jj) + vn_b(ji ,jj-1) ) ) 1202 ! 1203 zv_trd(ji,jj) = - r1_4 * r1_e1e2v(ji,jj) * z1_hv & 1204 & * ( e1e2t(ji,jj+1)*ht_n(ji,jj+1)*ff_t(ji,jj+1) * ( un_b(ji,jj+1) + un_b(ji-1,jj+1) ) & 1205 & + e1e2t(ji,jj )*ht_n(ji,jj )*ff_t(ji,jj ) * ( un_b(ji,jj ) + un_b(ji-1,jj ) ) ) 1206 END_2D 1261 1207 ! 1262 1208 CASE( np_ENE , np_MIX ) ! energy conserving scheme (t-point) ENE or MIX 1263 DO jj = 2, jpjm1 1264 DO ji = fs_2, fs_jpim1 ! vector opt. 1265 zy1 = ( zhV(ji,jj-1) + zhV(ji+1,jj-1) ) * r1_e1u(ji,jj) 1266 zy2 = ( zhV(ji,jj ) + zhV(ji+1,jj ) ) * r1_e1u(ji,jj) 1267 zx1 = ( zhU(ji-1,jj) + zhU(ji-1,jj+1) ) * r1_e2v(ji,jj) 1268 zx2 = ( zhU(ji ,jj) + zhU(ji ,jj+1) ) * r1_e2v(ji,jj) 1269 ! energy conserving formulation for planetary vorticity term 1270 zu_trd(ji,jj) = r1_4 * ( zwz(ji ,jj-1) * zy1 + zwz(ji,jj) * zy2 ) 1271 zv_trd(ji,jj) = - r1_4 * ( zwz(ji-1,jj ) * zx1 + zwz(ji,jj) * zx2 ) 1272 END DO 1273 END DO 1209 DO_2D_00_00 1210 zy1 = ( zhV(ji,jj-1) + zhV(ji+1,jj-1) ) * r1_e1u(ji,jj) 1211 zy2 = ( zhV(ji,jj ) + zhV(ji+1,jj ) ) * r1_e1u(ji,jj) 1212 zx1 = ( zhU(ji-1,jj) + zhU(ji-1,jj+1) ) * r1_e2v(ji,jj) 1213 zx2 = ( zhU(ji ,jj) + zhU(ji ,jj+1) ) * r1_e2v(ji,jj) 1214 ! energy conserving formulation for planetary vorticity term 1215 zu_trd(ji,jj) = r1_4 * ( zwz(ji ,jj-1) * zy1 + zwz(ji,jj) * zy2 ) 1216 zv_trd(ji,jj) = - r1_4 * ( zwz(ji-1,jj ) * zx1 + zwz(ji,jj) * zx2 ) 1217 END_2D 1274 1218 ! 1275 1219 CASE( np_ENS ) ! enstrophy conserving scheme (f-point) 1276 DO jj = 2, jpjm1 1277 DO ji = fs_2, fs_jpim1 ! vector opt. 1278 zy1 = r1_8 * ( zhV(ji ,jj-1) + zhV(ji+1,jj-1) & 1279 & + zhV(ji ,jj ) + zhV(ji+1,jj ) ) * r1_e1u(ji,jj) 1280 zx1 = - r1_8 * ( zhU(ji-1,jj ) + zhU(ji-1,jj+1) & 1281 & + zhU(ji ,jj ) + zhU(ji ,jj+1) ) * r1_e2v(ji,jj) 1282 zu_trd(ji,jj) = zy1 * ( zwz(ji ,jj-1) + zwz(ji,jj) ) 1283 zv_trd(ji,jj) = zx1 * ( zwz(ji-1,jj ) + zwz(ji,jj) ) 1284 END DO 1285 END DO 1220 DO_2D_00_00 1221 zy1 = r1_8 * ( zhV(ji ,jj-1) + zhV(ji+1,jj-1) & 1222 & + zhV(ji ,jj ) + zhV(ji+1,jj ) ) * r1_e1u(ji,jj) 1223 zx1 = - r1_8 * ( zhU(ji-1,jj ) + zhU(ji-1,jj+1) & 1224 & + zhU(ji ,jj ) + zhU(ji ,jj+1) ) * r1_e2v(ji,jj) 1225 zu_trd(ji,jj) = zy1 * ( zwz(ji ,jj-1) + zwz(ji,jj) ) 1226 zv_trd(ji,jj) = zx1 * ( zwz(ji-1,jj ) + zwz(ji,jj) ) 1227 END_2D 1286 1228 ! 1287 1229 CASE( np_EET , np_EEN ) ! energy & enstrophy scheme (using e3t or e3f) 1288 DO jj = 2, jpjm1 1289 DO ji = fs_2, fs_jpim1 ! vector opt. 1290 zu_trd(ji,jj) = + r1_12 * r1_e1u(ji,jj) * ( ftne(ji,jj ) * zhV(ji ,jj ) & 1291 & + ftnw(ji+1,jj) * zhV(ji+1,jj ) & 1292 & + ftse(ji,jj ) * zhV(ji ,jj-1) & 1293 & + ftsw(ji+1,jj) * zhV(ji+1,jj-1) ) 1294 zv_trd(ji,jj) = - r1_12 * r1_e2v(ji,jj) * ( ftsw(ji,jj+1) * zhU(ji-1,jj+1) & 1295 & + ftse(ji,jj+1) * zhU(ji ,jj+1) & 1296 & + ftnw(ji,jj ) * zhU(ji-1,jj ) & 1297 & + ftne(ji,jj ) * zhU(ji ,jj ) ) 1298 END DO 1299 END DO 1230 DO_2D_00_00 1231 zu_trd(ji,jj) = + r1_12 * r1_e1u(ji,jj) * ( ftne(ji,jj ) * zhV(ji ,jj ) & 1232 & + ftnw(ji+1,jj) * zhV(ji+1,jj ) & 1233 & + ftse(ji,jj ) * zhV(ji ,jj-1) & 1234 & + ftsw(ji+1,jj) * zhV(ji+1,jj-1) ) 1235 zv_trd(ji,jj) = - r1_12 * r1_e2v(ji,jj) * ( ftsw(ji,jj+1) * zhU(ji-1,jj+1) & 1236 & + ftse(ji,jj+1) * zhU(ji ,jj+1) & 1237 & + ftnw(ji,jj ) * zhU(ji-1,jj ) & 1238 & + ftne(ji,jj ) * zhU(ji ,jj ) ) 1239 END_2D 1300 1240 ! 1301 1241 END SELECT … … 1322 1262 ! 1323 1263 IF( ln_wd_dl_rmp ) THEN 1324 DO jj = 1, jpj 1325 DO ji = 1, jpi 1326 IF ( pssh(ji,jj) + ht_0(ji,jj) > 2._wp * rn_wdmin1 ) THEN 1327 ! IF ( pssh(ji,jj) + ht_0(ji,jj) > rn_wdmin2 ) THEN 1328 ptmsk(ji,jj) = 1._wp 1329 ELSEIF( pssh(ji,jj) + ht_0(ji,jj) > rn_wdmin1 ) THEN 1330 ptmsk(ji,jj) = TANH( 50._wp*( ( pssh(ji,jj) + ht_0(ji,jj) - rn_wdmin1 )*r_rn_wdmin1) ) 1331 ELSE 1332 ptmsk(ji,jj) = 0._wp 1333 ENDIF 1334 END DO 1335 END DO 1264 DO_2D_11_11 1265 IF ( pssh(ji,jj) + ht_0(ji,jj) > 2._wp * rn_wdmin1 ) THEN 1266 ! IF ( pssh(ji,jj) + ht_0(ji,jj) > rn_wdmin2 ) THEN 1267 ptmsk(ji,jj) = 1._wp 1268 ELSEIF( pssh(ji,jj) + ht_0(ji,jj) > rn_wdmin1 ) THEN 1269 ptmsk(ji,jj) = TANH( 50._wp*( ( pssh(ji,jj) + ht_0(ji,jj) - rn_wdmin1 )*r_rn_wdmin1) ) 1270 ELSE 1271 ptmsk(ji,jj) = 0._wp 1272 ENDIF 1273 END_2D 1336 1274 ELSE 1337 DO jj = 1, jpj 1338 DO ji = 1, jpi 1339 IF ( pssh(ji,jj) + ht_0(ji,jj) > rn_wdmin1 ) THEN ; ptmsk(ji,jj) = 1._wp 1340 ELSE ; ptmsk(ji,jj) = 0._wp 1341 ENDIF 1342 END DO 1343 END DO 1275 DO_2D_11_11 1276 IF ( pssh(ji,jj) + ht_0(ji,jj) > rn_wdmin1 ) THEN ; ptmsk(ji,jj) = 1._wp 1277 ELSE ; ptmsk(ji,jj) = 0._wp 1278 ENDIF 1279 END_2D 1344 1280 ENDIF 1345 1281 ! … … 1365 1301 !!---------------------------------------------------------------------- 1366 1302 ! 1367 DO jj = 1, jpj 1368 DO ji = 1, jpim1 ! not jpi-column 1369 IF ( phU(ji,jj) > 0._wp ) THEN ; pUmsk(ji,jj) = pTmsk(ji ,jj) 1370 ELSE ; pUmsk(ji,jj) = pTmsk(ji+1,jj) 1371 ENDIF 1372 phU(ji,jj) = pUmsk(ji,jj)*phU(ji,jj) 1373 pu (ji,jj) = pUmsk(ji,jj)*pu (ji,jj) 1374 END DO 1375 END DO 1376 ! 1377 DO jj = 1, jpjm1 ! not jpj-row 1378 DO ji = 1, jpi 1379 IF ( phV(ji,jj) > 0._wp ) THEN ; pVmsk(ji,jj) = pTmsk(ji,jj ) 1380 ELSE ; pVmsk(ji,jj) = pTmsk(ji,jj+1) 1381 ENDIF 1382 phV(ji,jj) = pVmsk(ji,jj)*phV(ji,jj) 1383 pv (ji,jj) = pVmsk(ji,jj)*pv (ji,jj) 1384 END DO 1385 END DO 1303 DO_2D_11_10 1304 IF ( phU(ji,jj) > 0._wp ) THEN ; pUmsk(ji,jj) = pTmsk(ji ,jj) 1305 ELSE ; pUmsk(ji,jj) = pTmsk(ji+1,jj) 1306 ENDIF 1307 phU(ji,jj) = pUmsk(ji,jj)*phU(ji,jj) 1308 pu (ji,jj) = pUmsk(ji,jj)*pu (ji,jj) 1309 END_2D 1310 ! 1311 DO_2D_10_11 1312 IF ( phV(ji,jj) > 0._wp ) THEN ; pVmsk(ji,jj) = pTmsk(ji,jj ) 1313 ELSE ; pVmsk(ji,jj) = pTmsk(ji,jj+1) 1314 ENDIF 1315 phV(ji,jj) = pVmsk(ji,jj)*phV(ji,jj) 1316 pv (ji,jj) = pVmsk(ji,jj)*pv (ji,jj) 1317 END_2D 1386 1318 ! 1387 1319 END SUBROUTINE wad_Umsk … … 1399 1331 REAL(wp), DIMENSION(jpi,jpj), INTENT(inout) :: zcpx, zcpy 1400 1332 !!---------------------------------------------------------------------- 1401 DO jj = 2, jpjm1 1402 DO ji = 2, jpim1 1403 ll_tmp1 = MIN( sshn(ji,jj) , sshn(ji+1,jj) ) > & 1404 & MAX( -ht_0(ji,jj) , -ht_0(ji+1,jj) ) .AND. & 1405 & MAX( sshn(ji,jj) + ht_0(ji,jj) , sshn(ji+1,jj) + ht_0(ji+1,jj) ) & 1406 & > rn_wdmin1 + rn_wdmin2 1407 ll_tmp2 = ( ABS( sshn(ji+1,jj) - sshn(ji ,jj)) > 1.E-12 ).AND.( & 1408 & MAX( sshn(ji,jj) , sshn(ji+1,jj) ) > & 1409 & MAX( -ht_0(ji,jj) , -ht_0(ji+1,jj) ) + rn_wdmin1 + rn_wdmin2 ) 1410 IF(ll_tmp1) THEN 1411 zcpx(ji,jj) = 1.0_wp 1412 ELSEIF(ll_tmp2) THEN 1413 ! no worries about sshn(ji+1,jj) - sshn(ji ,jj) = 0, it won't happen ! here 1414 zcpx(ji,jj) = ABS( (sshn(ji+1,jj) + ht_0(ji+1,jj) - sshn(ji,jj) - ht_0(ji,jj)) & 1415 & / (sshn(ji+1,jj) - sshn(ji ,jj)) ) 1416 zcpx(ji,jj) = max(min( zcpx(ji,jj) , 1.0_wp),0.0_wp) 1417 ELSE 1418 zcpx(ji,jj) = 0._wp 1419 ENDIF 1420 ! 1421 ll_tmp1 = MIN( sshn(ji,jj) , sshn(ji,jj+1) ) > & 1422 & MAX( -ht_0(ji,jj) , -ht_0(ji,jj+1) ) .AND. & 1423 & MAX( sshn(ji,jj) + ht_0(ji,jj) , sshn(ji,jj+1) + ht_0(ji,jj+1) ) & 1424 & > rn_wdmin1 + rn_wdmin2 1425 ll_tmp2 = ( ABS( sshn(ji,jj) - sshn(ji,jj+1)) > 1.E-12 ).AND.( & 1426 & MAX( sshn(ji,jj) , sshn(ji,jj+1) ) > & 1427 & MAX( -ht_0(ji,jj) , -ht_0(ji,jj+1) ) + rn_wdmin1 + rn_wdmin2 ) 1428 1429 IF(ll_tmp1) THEN 1430 zcpy(ji,jj) = 1.0_wp 1431 ELSE IF(ll_tmp2) THEN 1432 ! no worries about sshn(ji,jj+1) - sshn(ji,jj ) = 0, it won't happen ! here 1433 zcpy(ji,jj) = ABS( (sshn(ji,jj+1) + ht_0(ji,jj+1) - sshn(ji,jj) - ht_0(ji,jj)) & 1434 & / (sshn(ji,jj+1) - sshn(ji,jj )) ) 1435 zcpy(ji,jj) = MAX( 0._wp , MIN( zcpy(ji,jj) , 1.0_wp ) ) 1436 ELSE 1437 zcpy(ji,jj) = 0._wp 1438 ENDIF 1439 END DO 1440 END DO 1333 DO_2D_00_00 1334 ll_tmp1 = MIN( sshn(ji,jj) , sshn(ji+1,jj) ) > & 1335 & MAX( -ht_0(ji,jj) , -ht_0(ji+1,jj) ) .AND. & 1336 & MAX( sshn(ji,jj) + ht_0(ji,jj) , sshn(ji+1,jj) + ht_0(ji+1,jj) ) & 1337 & > rn_wdmin1 + rn_wdmin2 1338 ll_tmp2 = ( ABS( sshn(ji+1,jj) - sshn(ji ,jj)) > 1.E-12 ).AND.( & 1339 & MAX( sshn(ji,jj) , sshn(ji+1,jj) ) > & 1340 & MAX( -ht_0(ji,jj) , -ht_0(ji+1,jj) ) + rn_wdmin1 + rn_wdmin2 ) 1341 IF(ll_tmp1) THEN 1342 zcpx(ji,jj) = 1.0_wp 1343 ELSEIF(ll_tmp2) THEN 1344 ! no worries about sshn(ji+1,jj) - sshn(ji ,jj) = 0, it won't happen ! here 1345 zcpx(ji,jj) = ABS( (sshn(ji+1,jj) + ht_0(ji+1,jj) - sshn(ji,jj) - ht_0(ji,jj)) & 1346 & / (sshn(ji+1,jj) - sshn(ji ,jj)) ) 1347 zcpx(ji,jj) = max(min( zcpx(ji,jj) , 1.0_wp),0.0_wp) 1348 ELSE 1349 zcpx(ji,jj) = 0._wp 1350 ENDIF 1351 ! 1352 ll_tmp1 = MIN( sshn(ji,jj) , sshn(ji,jj+1) ) > & 1353 & MAX( -ht_0(ji,jj) , -ht_0(ji,jj+1) ) .AND. & 1354 & MAX( sshn(ji,jj) + ht_0(ji,jj) , sshn(ji,jj+1) + ht_0(ji,jj+1) ) & 1355 & > rn_wdmin1 + rn_wdmin2 1356 ll_tmp2 = ( ABS( sshn(ji,jj) - sshn(ji,jj+1)) > 1.E-12 ).AND.( & 1357 & MAX( sshn(ji,jj) , sshn(ji,jj+1) ) > & 1358 & MAX( -ht_0(ji,jj) , -ht_0(ji,jj+1) ) + rn_wdmin1 + rn_wdmin2 ) 1359 1360 IF(ll_tmp1) THEN 1361 zcpy(ji,jj) = 1.0_wp 1362 ELSE IF(ll_tmp2) THEN 1363 ! no worries about sshn(ji,jj+1) - sshn(ji,jj ) = 0, it won't happen ! here 1364 zcpy(ji,jj) = ABS( (sshn(ji,jj+1) + ht_0(ji,jj+1) - sshn(ji,jj) - ht_0(ji,jj)) & 1365 & / (sshn(ji,jj+1) - sshn(ji,jj )) ) 1366 zcpy(ji,jj) = MAX( 0._wp , MIN( zcpy(ji,jj) , 1.0_wp ) ) 1367 ELSE 1368 zcpy(ji,jj) = 0._wp 1369 ENDIF 1370 END_2D 1441 1371 1442 1372 END SUBROUTINE wad_spg … … 1467 1397 IF( ln_isfcav.OR.ln_drgice_imp ) THEN ! top+bottom friction (ocean cavities) 1468 1398 1469 DO jj = 2, jpjm1 1470 DO ji = 2, jpim1 ! INNER domain 1471 pCdU_u(ji,jj) = r1_2*( rCdU_bot(ji+1,jj)+rCdU_bot(ji,jj) + rCdU_top(ji+1,jj)+rCdU_top(ji,jj) ) 1472 pCdU_v(ji,jj) = r1_2*( rCdU_bot(ji,jj+1)+rCdU_bot(ji,jj) + rCdU_top(ji,jj+1)+rCdU_top(ji,jj) ) 1473 END DO 1474 END DO 1399 DO_2D_00_00 1400 pCdU_u(ji,jj) = r1_2*( rCdU_bot(ji+1,jj)+rCdU_bot(ji,jj) + rCdU_top(ji+1,jj)+rCdU_top(ji,jj) ) 1401 pCdU_v(ji,jj) = r1_2*( rCdU_bot(ji,jj+1)+rCdU_bot(ji,jj) + rCdU_top(ji,jj+1)+rCdU_top(ji,jj) ) 1402 END_2D 1475 1403 ELSE ! bottom friction only 1476 DO jj = 2, jpjm1 1477 DO ji = 2, jpim1 ! INNER domain 1478 pCdU_u(ji,jj) = r1_2*( rCdU_bot(ji+1,jj)+rCdU_bot(ji,jj) ) 1479 pCdU_v(ji,jj) = r1_2*( rCdU_bot(ji,jj+1)+rCdU_bot(ji,jj) ) 1480 END DO 1481 END DO 1404 DO_2D_00_00 1405 pCdU_u(ji,jj) = r1_2*( rCdU_bot(ji+1,jj)+rCdU_bot(ji,jj) ) 1406 pCdU_v(ji,jj) = r1_2*( rCdU_bot(ji,jj+1)+rCdU_bot(ji,jj) ) 1407 END_2D 1482 1408 ENDIF 1483 1409 ! … … 1486 1412 IF( ln_bt_fw ) THEN ! FORWARD integration: use NOW bottom baroclinic velocities 1487 1413 1488 DO jj = 2, jpjm1 1489 DO ji = 2, jpim1 ! INNER domain 1490 ikbu = mbku(ji,jj) 1491 ikbv = mbkv(ji,jj) 1492 zu_i(ji,jj) = un(ji,jj,ikbu) - un_b(ji,jj) 1493 zv_i(ji,jj) = vn(ji,jj,ikbv) - vn_b(ji,jj) 1494 END DO 1495 END DO 1414 DO_2D_00_00 1415 ikbu = mbku(ji,jj) 1416 ikbv = mbkv(ji,jj) 1417 zu_i(ji,jj) = uu(ji,jj,ikbu,Nii) - un_b(ji,jj) 1418 zv_i(ji,jj) = vv(ji,jj,ikbv,Nii) - vn_b(ji,jj) 1419 END_2D 1496 1420 ELSE ! CENTRED integration: use BEFORE bottom baroclinic velocities 1497 1421 1498 DO jj = 2, jpjm1 1499 DO ji = 2, jpim1 ! INNER domain 1500 ikbu = mbku(ji,jj) 1501 ikbv = mbkv(ji,jj) 1502 zu_i(ji,jj) = ub(ji,jj,ikbu) - ub_b(ji,jj) 1503 zv_i(ji,jj) = vb(ji,jj,ikbv) - vb_b(ji,jj) 1504 END DO 1505 END DO 1422 DO_2D_00_00 1423 ikbu = mbku(ji,jj) 1424 ikbv = mbkv(ji,jj) 1425 zu_i(ji,jj) = uu(ji,jj,ikbu,Nnn) - ub_b(ji,jj) 1426 zv_i(ji,jj) = vv(ji,jj,ikbv,Nnn) - vb_b(ji,jj) 1427 END_2D 1506 1428 ENDIF 1507 1429 ! 1508 1430 IF( ln_wd_il ) THEN ! W/D : use the "clipped" bottom friction !!gm explain WHY, please ! 1509 1431 zztmp = -1._wp / rdtbt 1510 DO jj = 2, jpjm1 1511 DO ji = 2, jpim1 ! INNER domain 1512 pu_RHSi(ji,jj) = pu_RHSi(ji,jj) + zu_i(ji,jj) * wdrampu(ji,jj) * MAX( & 1513 & r1_hu_n(ji,jj) * r1_2*( rCdU_bot(ji+1,jj)+rCdU_bot(ji,jj) ) , zztmp ) 1514 pv_RHSi(ji,jj) = pv_RHSi(ji,jj) + zv_i(ji,jj) * wdrampv(ji,jj) * MAX( & 1515 & r1_hv_n(ji,jj) * r1_2*( rCdU_bot(ji,jj+1)+rCdU_bot(ji,jj) ) , zztmp ) 1516 END DO 1517 END DO 1432 DO_2D_00_00 1433 pu_RHSi(ji,jj) = pu_RHSi(ji,jj) + zu_i(ji,jj) * wdrampu(ji,jj) * MAX( & 1434 & r1_hu_n(ji,jj) * r1_2*( rCdU_bot(ji+1,jj)+rCdU_bot(ji,jj) ) , zztmp ) 1435 pv_RHSi(ji,jj) = pv_RHSi(ji,jj) + zv_i(ji,jj) * wdrampv(ji,jj) * MAX( & 1436 & r1_hv_n(ji,jj) * r1_2*( rCdU_bot(ji,jj+1)+rCdU_bot(ji,jj) ) , zztmp ) 1437 END_2D 1518 1438 ELSE ! use "unclipped" drag (even if explicit friction is used in 3D calculation) 1519 1439 1520 DO jj = 2, jpjm1 1521 DO ji = 2, jpim1 ! INNER domain 1522 pu_RHSi(ji,jj) = pu_RHSi(ji,jj) + r1_hu_n(ji,jj) * r1_2*( rCdU_bot(ji+1,jj)+rCdU_bot(ji,jj) ) * zu_i(ji,jj) 1523 pv_RHSi(ji,jj) = pv_RHSi(ji,jj) + r1_hv_n(ji,jj) * r1_2*( rCdU_bot(ji,jj+1)+rCdU_bot(ji,jj) ) * zv_i(ji,jj) 1524 END DO 1525 END DO 1440 DO_2D_00_00 1441 pu_RHSi(ji,jj) = pu_RHSi(ji,jj) + r1_hu_n(ji,jj) * r1_2*( rCdU_bot(ji+1,jj)+rCdU_bot(ji,jj) ) * zu_i(ji,jj) 1442 pv_RHSi(ji,jj) = pv_RHSi(ji,jj) + r1_hv_n(ji,jj) * r1_2*( rCdU_bot(ji,jj+1)+rCdU_bot(ji,jj) ) * zv_i(ji,jj) 1443 END_2D 1526 1444 END IF 1527 1445 ! … … 1532 1450 IF( ln_bt_fw ) THEN ! FORWARD integration: use NOW top baroclinic velocity 1533 1451 1534 DO jj = 2, jpjm1 1535 DO ji = 2, jpim1 ! INNER domain 1536 iktu = miku(ji,jj) 1537 iktv = mikv(ji,jj) 1538 zu_i(ji,jj) = un(ji,jj,iktu) - un_b(ji,jj) 1539 zv_i(ji,jj) = vn(ji,jj,iktv) - vn_b(ji,jj) 1540 END DO 1541 END DO 1452 DO_2D_00_00 1453 iktu = miku(ji,jj) 1454 iktv = mikv(ji,jj) 1455 zu_i(ji,jj) = uu(ji,jj,iktu,Nii) - un_b(ji,jj) 1456 zv_i(ji,jj) = vv(ji,jj,iktv,Nii) - vn_b(ji,jj) 1457 END_2D 1542 1458 ELSE ! CENTRED integration: use BEFORE top baroclinic velocity 1543 1459 1544 DO jj = 2, jpjm1 1545 DO ji = 2, jpim1 ! INNER domain 1546 iktu = miku(ji,jj) 1547 iktv = mikv(ji,jj) 1548 zu_i(ji,jj) = ub(ji,jj,iktu) - ub_b(ji,jj) 1549 zv_i(ji,jj) = vb(ji,jj,iktv) - vb_b(ji,jj) 1550 END DO 1551 END DO 1460 DO_2D_00_00 1461 iktu = miku(ji,jj) 1462 iktv = mikv(ji,jj) 1463 zu_i(ji,jj) = uu(ji,jj,iktu,Nnn) - ub_b(ji,jj) 1464 zv_i(ji,jj) = vv(ji,jj,iktv,Nnn) - vb_b(ji,jj) 1465 END_2D 1552 1466 ENDIF 1553 1467 ! 1554 1468 ! ! use "unclipped" top drag (even if explicit friction is used in 3D calculation) 1555 1469 1556 DO jj = 2, jpjm1 1557 DO ji = 2, jpim1 ! INNER domain 1558 pu_RHSi(ji,jj) = pu_RHSi(ji,jj) + r1_hu_n(ji,jj) * r1_2*( rCdU_top(ji+1,jj)+rCdU_top(ji,jj) ) * zu_i(ji,jj) 1559 pv_RHSi(ji,jj) = pv_RHSi(ji,jj) + r1_hv_n(ji,jj) * r1_2*( rCdU_top(ji,jj+1)+rCdU_top(ji,jj) ) * zv_i(ji,jj) 1560 END DO 1561 END DO 1470 DO_2D_00_00 1471 pu_RHSi(ji,jj) = pu_RHSi(ji,jj) + r1_hu_n(ji,jj) * r1_2*( rCdU_top(ji+1,jj)+rCdU_top(ji,jj) ) * zu_i(ji,jj) 1472 pv_RHSi(ji,jj) = pv_RHSi(ji,jj) + r1_hv_n(ji,jj) * r1_2*( rCdU_top(ji,jj+1)+rCdU_top(ji,jj) ) * zv_i(ji,jj) 1473 END_2D 1562 1474 ! 1563 1475 ENDIF -
NEMO/branches/2020/temporary_r4_trunk/src/OCE/DYN/dynzdf.F90
r13466 r13469 110 110 IF( ln_dynadv_vec .OR. ln_linssh ) THEN ! applied on velocity 111 111 DO jk = 1, jpkm1 112 ua(:,:,jk) = ( u b(:,:,jk) + r2dt * ua(:,:,jk) ) * umask(:,:,jk)113 va(:,:,jk) = ( v b(:,:,jk) + r2dt * va(:,:,jk) ) * vmask(:,:,jk)112 ua(:,:,jk) = ( uu(:,:,jk,Nnn) + r2dt * ua(:,:,jk) ) * umask(:,:,jk) 113 va(:,:,jk) = ( vv(:,:,jk,Nnn) + r2dt * va(:,:,jk) ) * vmask(:,:,jk) 114 114 END DO 115 115 ELSE ! applied on thickness weighted velocity 116 116 DO jk = 1, jpkm1 117 ua(:,:,jk) = ( e3u_b(:,:,jk) * u b(:,:,jk) &117 ua(:,:,jk) = ( e3u_b(:,:,jk) * uu(:,:,jk,Nnn) & 118 118 & + r2dt * e3u_n(:,:,jk) * ua(:,:,jk) ) / e3u_a(:,:,jk) * umask(:,:,jk) 119 va(:,:,jk) = ( e3v_b(:,:,jk) * v b(:,:,jk) &119 va(:,:,jk) = ( e3v_b(:,:,jk) * vv(:,:,jk,Nnn) & 120 120 & + r2dt * e3v_n(:,:,jk) * va(:,:,jk) ) / e3v_a(:,:,jk) * vmask(:,:,jk) 121 121 END DO … … 131 131 va(:,:,jk) = ( va(:,:,jk) - va_b(:,:) ) * vmask(:,:,jk) 132 132 END DO 133 DO jj = 2, jpjm1 ! Add bottom/top stress due to barotropic component only 134 DO ji = fs_2, fs_jpim1 ! vector opt. 135 iku = mbku(ji,jj) ! ocean bottom level at u- and v-points 136 ikv = mbkv(ji,jj) ! (deepest ocean u- and v-points) 133 DO_2D_00_00 134 iku = mbku(ji,jj) ! ocean bottom level at u- and v-points 135 ikv = mbkv(ji,jj) ! (deepest ocean u- and v-points) 136 ze3ua = ( 1._wp - r_vvl ) * e3u_n(ji,jj,iku) + r_vvl * e3u_a(ji,jj,iku) 137 ze3va = ( 1._wp - r_vvl ) * e3v_n(ji,jj,ikv) + r_vvl * e3v_a(ji,jj,ikv) 138 ua(ji,jj,iku) = ua(ji,jj,iku) + r2dt * 0.5*( rCdU_bot(ji+1,jj)+rCdU_bot(ji,jj) ) * ua_b(ji,jj) / ze3ua 139 va(ji,jj,ikv) = va(ji,jj,ikv) + r2dt * 0.5*( rCdU_bot(ji,jj+1)+rCdU_bot(ji,jj) ) * va_b(ji,jj) / ze3va 140 END_2D 141 IF( ln_isfcav.OR.ln_drgice_imp ) THEN ! Ocean cavities (ISF) 142 DO_2D_00_00 143 iku = miku(ji,jj) ! top ocean level at u- and v-points 144 ikv = mikv(ji,jj) ! (first wet ocean u- and v-points) 137 145 ze3ua = ( 1._wp - r_vvl ) * e3u_n(ji,jj,iku) + r_vvl * e3u_a(ji,jj,iku) 138 146 ze3va = ( 1._wp - r_vvl ) * e3v_n(ji,jj,ikv) + r_vvl * e3v_a(ji,jj,ikv) 139 ua(ji,jj,iku) = ua(ji,jj,iku) + r2dt * 0.5*( rCdU_bot(ji+1,jj)+rCdU_bot(ji,jj) ) * ua_b(ji,jj) / ze3ua 140 va(ji,jj,ikv) = va(ji,jj,ikv) + r2dt * 0.5*( rCdU_bot(ji,jj+1)+rCdU_bot(ji,jj) ) * va_b(ji,jj) / ze3va 141 END DO 142 END DO 143 IF( ln_isfcav.OR.ln_drgice_imp ) THEN ! Ocean cavities (ISF) 144 DO jj = 2, jpjm1 145 DO ji = fs_2, fs_jpim1 ! vector opt. 146 iku = miku(ji,jj) ! top ocean level at u- and v-points 147 ikv = mikv(ji,jj) ! (first wet ocean u- and v-points) 148 ze3ua = ( 1._wp - r_vvl ) * e3u_n(ji,jj,iku) + r_vvl * e3u_a(ji,jj,iku) 149 ze3va = ( 1._wp - r_vvl ) * e3v_n(ji,jj,ikv) + r_vvl * e3v_a(ji,jj,ikv) 150 ua(ji,jj,iku) = ua(ji,jj,iku) + r2dt * 0.5*( rCdU_top(ji+1,jj)+rCdU_top(ji,jj) ) * ua_b(ji,jj) / ze3ua 151 va(ji,jj,ikv) = va(ji,jj,ikv) + r2dt * 0.5*( rCdU_top(ji,jj+1)+rCdU_top(ji,jj) ) * va_b(ji,jj) / ze3va 152 END DO 153 END DO 147 ua(ji,jj,iku) = ua(ji,jj,iku) + r2dt * 0.5*( rCdU_top(ji+1,jj)+rCdU_top(ji,jj) ) * ua_b(ji,jj) / ze3ua 148 va(ji,jj,ikv) = va(ji,jj,ikv) + r2dt * 0.5*( rCdU_top(ji,jj+1)+rCdU_top(ji,jj) ) * va_b(ji,jj) / ze3va 149 END_2D 154 150 END IF 155 151 ENDIF … … 162 158 SELECT CASE( nldf_dyn ) 163 159 CASE( np_lap_i ) ! rotated lateral mixing: add its vertical mixing (akzu) 164 DO jk = 1, jpkm1 165 DO jj = 2, jpjm1 166 DO ji = fs_2, fs_jpim1 ! vector opt. 167 ze3ua = ( 1._wp - r_vvl ) * e3u_n(ji,jj,jk) + r_vvl * e3u_a(ji,jj,jk) ! after scale factor at U-point 168 zzwi = - zdt * ( avm(ji+1,jj,jk ) + avm(ji,jj,jk ) + akzu(ji,jj,jk ) ) & 169 & / ( ze3ua * e3uw_n(ji,jj,jk ) ) * wumask(ji,jj,jk ) 170 zzws = - zdt * ( avm(ji+1,jj,jk+1) + avm(ji,jj,jk+1) + akzu(ji,jj,jk+1) ) & 171 & / ( ze3ua * e3uw_n(ji,jj,jk+1) ) * wumask(ji,jj,jk+1) 172 zWui = ( wi(ji,jj,jk ) + wi(ji+1,jj,jk ) ) / ze3ua 173 zWus = ( wi(ji,jj,jk+1) + wi(ji+1,jj,jk+1) ) / ze3ua 174 zwi(ji,jj,jk) = zzwi + zdt * MIN( zWui, 0._wp ) 175 zws(ji,jj,jk) = zzws - zdt * MAX( zWus, 0._wp ) 176 zwd(ji,jj,jk) = 1._wp - zzwi - zzws + zdt * ( MAX( zWui, 0._wp ) - MIN( zWus, 0._wp ) ) 177 END DO 178 END DO 179 END DO 160 DO_3D_00_00( 1, jpkm1 ) 161 ze3ua = ( 1._wp - r_vvl ) * e3u_n(ji,jj,jk) + r_vvl * e3u_a(ji,jj,jk) ! after scale factor at U-point 162 zzwi = - zdt * ( avm(ji+1,jj,jk ) + avm(ji,jj,jk ) + akzu(ji,jj,jk ) ) & 163 & / ( ze3ua * e3uw_n(ji,jj,jk ) ) * wumask(ji,jj,jk ) 164 zzws = - zdt * ( avm(ji+1,jj,jk+1) + avm(ji,jj,jk+1) + akzu(ji,jj,jk+1) ) & 165 & / ( ze3ua * e3uw_n(ji,jj,jk+1) ) * wumask(ji,jj,jk+1) 166 zWui = ( wi(ji,jj,jk ) + wi(ji+1,jj,jk ) ) / ze3ua 167 zWus = ( wi(ji,jj,jk+1) + wi(ji+1,jj,jk+1) ) / ze3ua 168 zwi(ji,jj,jk) = zzwi + zdt * MIN( zWui, 0._wp ) 169 zws(ji,jj,jk) = zzws - zdt * MAX( zWus, 0._wp ) 170 zwd(ji,jj,jk) = 1._wp - zzwi - zzws + zdt * ( MAX( zWui, 0._wp ) - MIN( zWus, 0._wp ) ) 171 END_3D 180 172 CASE DEFAULT ! iso-level lateral mixing 181 DO jk = 1, jpkm1 182 DO jj = 2, jpjm1 183 DO ji = fs_2, fs_jpim1 ! vector opt. 184 ze3ua = ( 1._wp - r_vvl ) * e3u_n(ji,jj,jk) + r_vvl * e3u_a(ji,jj,jk) ! after scale factor at U-point 185 zzwi = - zdt * ( avm(ji+1,jj,jk ) + avm(ji,jj,jk ) ) / ( ze3ua * e3uw_n(ji,jj,jk ) ) * wumask(ji,jj,jk ) 186 zzws = - zdt * ( avm(ji+1,jj,jk+1) + avm(ji,jj,jk+1) ) / ( ze3ua * e3uw_n(ji,jj,jk+1) ) * wumask(ji,jj,jk+1) 187 zWui = ( wi(ji,jj,jk ) + wi(ji+1,jj,jk ) ) / ze3ua 188 zWus = ( wi(ji,jj,jk+1) + wi(ji+1,jj,jk+1) ) / ze3ua 189 zwi(ji,jj,jk) = zzwi + zdt * MIN( zWui, 0._wp ) 190 zws(ji,jj,jk) = zzws - zdt * MAX( zWus, 0._wp ) 191 zwd(ji,jj,jk) = 1._wp - zzwi - zzws + zdt * ( MAX( zWui, 0._wp ) - MIN( zWus, 0._wp ) ) 192 END DO 193 END DO 194 END DO 173 DO_3D_00_00( 1, jpkm1 ) 174 ze3ua = ( 1._wp - r_vvl ) * e3u_n(ji,jj,jk) + r_vvl * e3u_a(ji,jj,jk) ! after scale factor at U-point 175 zzwi = - zdt * ( avm(ji+1,jj,jk ) + avm(ji,jj,jk ) ) / ( ze3ua * e3uw_n(ji,jj,jk ) ) * wumask(ji,jj,jk ) 176 zzws = - zdt * ( avm(ji+1,jj,jk+1) + avm(ji,jj,jk+1) ) / ( ze3ua * e3uw_n(ji,jj,jk+1) ) * wumask(ji,jj,jk+1) 177 zWui = ( wi(ji,jj,jk ) + wi(ji+1,jj,jk ) ) / ze3ua 178 zWus = ( wi(ji,jj,jk+1) + wi(ji+1,jj,jk+1) ) / ze3ua 179 zwi(ji,jj,jk) = zzwi + zdt * MIN( zWui, 0._wp ) 180 zws(ji,jj,jk) = zzws - zdt * MAX( zWus, 0._wp ) 181 zwd(ji,jj,jk) = 1._wp - zzwi - zzws + zdt * ( MAX( zWui, 0._wp ) - MIN( zWus, 0._wp ) ) 182 END_3D 195 183 END SELECT 196 DO jj = 2, jpjm1 !* Surface boundary conditions 197 DO ji = fs_2, fs_jpim1 ! vector opt. 198 zwi(ji,jj,1) = 0._wp 199 ze3ua = ( 1._wp - r_vvl ) * e3u_n(ji,jj,1) + r_vvl * e3u_a(ji,jj,1) 200 zzws = - zdt * ( avm(ji+1,jj,2) + avm(ji ,jj,2) ) / ( ze3ua * e3uw_n(ji,jj,2) ) * wumask(ji,jj,2) 201 zWus = ( wi(ji ,jj,2) + wi(ji+1,jj,2) ) / ze3ua 202 zws(ji,jj,1 ) = zzws - zdt * MAX( zWus, 0._wp ) 203 zwd(ji,jj,1 ) = 1._wp - zzws - zdt * ( MIN( zWus, 0._wp ) ) 204 END DO 205 END DO 184 DO_2D_00_00 185 zwi(ji,jj,1) = 0._wp 186 ze3ua = ( 1._wp - r_vvl ) * e3u_n(ji,jj,1) + r_vvl * e3u_a(ji,jj,1) 187 zzws = - zdt * ( avm(ji+1,jj,2) + avm(ji ,jj,2) ) / ( ze3ua * e3uw_n(ji,jj,2) ) * wumask(ji,jj,2) 188 zWus = ( wi(ji ,jj,2) + wi(ji+1,jj,2) ) / ze3ua 189 zws(ji,jj,1 ) = zzws - zdt * MAX( zWus, 0._wp ) 190 zwd(ji,jj,1 ) = 1._wp - zzws - zdt * ( MIN( zWus, 0._wp ) ) 191 END_2D 206 192 ELSE 207 193 SELECT CASE( nldf_dyn ) 208 194 CASE( np_lap_i ) ! rotated lateral mixing: add its vertical mixing (akzu) 209 DO jk = 1, jpkm1 210 DO jj = 2, jpjm1 211 DO ji = fs_2, fs_jpim1 ! vector opt. 212 ze3ua = ( 1._wp - r_vvl ) * e3u_n(ji,jj,jk) + r_vvl * e3u_a(ji,jj,jk) ! after scale factor at U-point 213 zzwi = - zdt * ( avm(ji+1,jj,jk ) + avm(ji,jj,jk ) + akzu(ji,jj,jk ) ) & 214 & / ( ze3ua * e3uw_n(ji,jj,jk ) ) * wumask(ji,jj,jk ) 215 zzws = - zdt * ( avm(ji+1,jj,jk+1) + avm(ji,jj,jk+1) + akzu(ji,jj,jk+1) ) & 216 & / ( ze3ua * e3uw_n(ji,jj,jk+1) ) * wumask(ji,jj,jk+1) 217 zwi(ji,jj,jk) = zzwi 218 zws(ji,jj,jk) = zzws 219 zwd(ji,jj,jk) = 1._wp - zzwi - zzws 220 END DO 221 END DO 222 END DO 195 DO_3D_00_00( 1, jpkm1 ) 196 ze3ua = ( 1._wp - r_vvl ) * e3u_n(ji,jj,jk) + r_vvl * e3u_a(ji,jj,jk) ! after scale factor at U-point 197 zzwi = - zdt * ( avm(ji+1,jj,jk ) + avm(ji,jj,jk ) + akzu(ji,jj,jk ) ) & 198 & / ( ze3ua * e3uw_n(ji,jj,jk ) ) * wumask(ji,jj,jk ) 199 zzws = - zdt * ( avm(ji+1,jj,jk+1) + avm(ji,jj,jk+1) + akzu(ji,jj,jk+1) ) & 200 & / ( ze3ua * e3uw_n(ji,jj,jk+1) ) * wumask(ji,jj,jk+1) 201 zwi(ji,jj,jk) = zzwi 202 zws(ji,jj,jk) = zzws 203 zwd(ji,jj,jk) = 1._wp - zzwi - zzws 204 END_3D 223 205 CASE DEFAULT ! iso-level lateral mixing 224 DO jk = 1, jpkm1 225 DO jj = 2, jpjm1 226 DO ji = fs_2, fs_jpim1 ! vector opt. 227 ze3ua = ( 1._wp - r_vvl ) * e3u_n(ji,jj,jk) + r_vvl * e3u_a(ji,jj,jk) ! after scale factor at U-point 228 zzwi = - zdt * ( avm(ji+1,jj,jk ) + avm(ji,jj,jk ) ) / ( ze3ua * e3uw_n(ji,jj,jk ) ) * wumask(ji,jj,jk ) 229 zzws = - zdt * ( avm(ji+1,jj,jk+1) + avm(ji,jj,jk+1) ) / ( ze3ua * e3uw_n(ji,jj,jk+1) ) * wumask(ji,jj,jk+1) 230 zwi(ji,jj,jk) = zzwi 231 zws(ji,jj,jk) = zzws 232 zwd(ji,jj,jk) = 1._wp - zzwi - zzws 233 END DO 234 END DO 235 END DO 206 DO_3D_00_00( 1, jpkm1 ) 207 ze3ua = ( 1._wp - r_vvl ) * e3u_n(ji,jj,jk) + r_vvl * e3u_a(ji,jj,jk) ! after scale factor at U-point 208 zzwi = - zdt * ( avm(ji+1,jj,jk ) + avm(ji,jj,jk ) ) / ( ze3ua * e3uw_n(ji,jj,jk ) ) * wumask(ji,jj,jk ) 209 zzws = - zdt * ( avm(ji+1,jj,jk+1) + avm(ji,jj,jk+1) ) / ( ze3ua * e3uw_n(ji,jj,jk+1) ) * wumask(ji,jj,jk+1) 210 zwi(ji,jj,jk) = zzwi 211 zws(ji,jj,jk) = zzws 212 zwd(ji,jj,jk) = 1._wp - zzwi - zzws 213 END_3D 236 214 END SELECT 237 DO jj = 2, jpjm1 !* Surface boundary conditions 238 DO ji = fs_2, fs_jpim1 ! vector opt. 239 zwi(ji,jj,1) = 0._wp 240 zwd(ji,jj,1) = 1._wp - zws(ji,jj,1) 241 END DO 242 END DO 215 DO_2D_00_00 216 zwi(ji,jj,1) = 0._wp 217 zwd(ji,jj,1) = 1._wp - zws(ji,jj,1) 218 END_2D 243 219 ENDIF 244 220 ! … … 251 227 ! 252 228 IF ( ln_drgimp ) THEN ! implicit bottom friction 253 DO jj = 2, jpjm1 254 DO ji = 2, jpim1 255 iku = mbku(ji,jj) ! ocean bottom level at u- and v-points 229 DO_2D_00_00 230 iku = mbku(ji,jj) ! ocean bottom level at u- and v-points 231 ze3ua = ( 1._wp - r_vvl ) * e3u_n(ji,jj,iku) + r_vvl * e3u_a(ji,jj,iku) ! after scale factor at T-point 232 zwd(ji,jj,iku) = zwd(ji,jj,iku) - r2dt * 0.5*( rCdU_bot(ji+1,jj)+rCdU_bot(ji,jj) ) / ze3ua 233 END_2D 234 IF ( ln_isfcav.OR.ln_drgice_imp ) THEN ! top friction (always implicit) 235 DO_2D_00_00 236 !!gm top Cd is masked (=0 outside cavities) no need of test on mik>=2 ==>> it has been suppressed 237 iku = miku(ji,jj) ! ocean top level at u- and v-points 256 238 ze3ua = ( 1._wp - r_vvl ) * e3u_n(ji,jj,iku) + r_vvl * e3u_a(ji,jj,iku) ! after scale factor at T-point 257 zwd(ji,jj,iku) = zwd(ji,jj,iku) - r2dt * 0.5*( rCdU_bot(ji+1,jj)+rCdU_bot(ji,jj) ) / ze3ua 258 END DO 259 END DO 260 IF ( ln_isfcav.OR.ln_drgice_imp ) THEN ! top friction (always implicit) 261 DO jj = 2, jpjm1 262 DO ji = 2, jpim1 263 !!gm top Cd is masked (=0 outside cavities) no need of test on mik>=2 ==>> it has been suppressed 264 iku = miku(ji,jj) ! ocean top level at u- and v-points 265 ze3ua = ( 1._wp - r_vvl ) * e3u_n(ji,jj,iku) + r_vvl * e3u_a(ji,jj,iku) ! after scale factor at T-point 266 zwd(ji,jj,iku) = zwd(ji,jj,iku) - r2dt * 0.5*( rCdU_top(ji+1,jj)+rCdU_top(ji,jj) ) / ze3ua 267 END DO 268 END DO 239 zwd(ji,jj,iku) = zwd(ji,jj,iku) - r2dt * 0.5*( rCdU_top(ji+1,jj)+rCdU_top(ji,jj) ) / ze3ua 240 END_2D 269 241 END IF 270 242 ENDIF … … 285 257 !----------------------------------------------------------------------- 286 258 ! 287 DO jk = 2, jpkm1 !== First recurrence : Dk = Dk - Lk * Uk-1 / Dk-1 (increasing k) == 288 DO jj = 2, jpjm1 289 DO ji = fs_2, fs_jpim1 ! vector opt. 290 zwd(ji,jj,jk) = zwd(ji,jj,jk) - zwi(ji,jj,jk) * zws(ji,jj,jk-1) / zwd(ji,jj,jk-1) 291 END DO 292 END DO 293 END DO 294 ! 295 DO jj = 2, jpjm1 !== second recurrence: SOLk = RHSk - Lk / Dk-1 Lk-1 ==! 296 DO ji = fs_2, fs_jpim1 ! vector opt. 297 ze3ua = ( 1._wp - r_vvl ) * e3u_n(ji,jj,1) + r_vvl * e3u_a(ji,jj,1) 298 ua(ji,jj,1) = ua(ji,jj,1) + r2dt * 0.5_wp * ( utau_b(ji,jj) + utau(ji,jj) ) & 299 & / ( ze3ua * rau0 ) * umask(ji,jj,1) 300 END DO 301 END DO 302 DO jk = 2, jpkm1 303 DO jj = 2, jpjm1 304 DO ji = fs_2, fs_jpim1 305 ua(ji,jj,jk) = ua(ji,jj,jk) - zwi(ji,jj,jk) / zwd(ji,jj,jk-1) * ua(ji,jj,jk-1) 306 END DO 307 END DO 308 END DO 309 ! 310 DO jj = 2, jpjm1 !== thrid recurrence : SOLk = ( Lk - Uk * Ek+1 ) / Dk ==! 311 DO ji = fs_2, fs_jpim1 ! vector opt. 312 ua(ji,jj,jpkm1) = ua(ji,jj,jpkm1) / zwd(ji,jj,jpkm1) 313 END DO 314 END DO 315 DO jk = jpk-2, 1, -1 316 DO jj = 2, jpjm1 317 DO ji = fs_2, fs_jpim1 318 ua(ji,jj,jk) = ( ua(ji,jj,jk) - zws(ji,jj,jk) * ua(ji,jj,jk+1) ) / zwd(ji,jj,jk) 319 END DO 320 END DO 321 END DO 259 DO_3D_00_00( 2, jpkm1 ) 260 zwd(ji,jj,jk) = zwd(ji,jj,jk) - zwi(ji,jj,jk) * zws(ji,jj,jk-1) / zwd(ji,jj,jk-1) 261 END_3D 262 ! 263 DO_2D_00_00 264 ze3ua = ( 1._wp - r_vvl ) * e3u_n(ji,jj,1) + r_vvl * e3u_a(ji,jj,1) 265 ua(ji,jj,1) = ua(ji,jj,1) + r2dt * 0.5_wp * ( utau_b(ji,jj) + utau(ji,jj) ) & 266 & / ( ze3ua * rau0 ) * umask(ji,jj,1) 267 END_2D 268 DO_3D_00_00( 2, jpkm1 ) 269 ua(ji,jj,jk) = ua(ji,jj,jk) - zwi(ji,jj,jk) / zwd(ji,jj,jk-1) * ua(ji,jj,jk-1) 270 END_3D 271 ! 272 DO_2D_00_00 273 ua(ji,jj,jpkm1) = ua(ji,jj,jpkm1) / zwd(ji,jj,jpkm1) 274 END_2D 275 DO_3D_00_00( jpk-2, 1, -1 ) 276 ua(ji,jj,jk) = ( ua(ji,jj,jk) - zws(ji,jj,jk) * ua(ji,jj,jk+1) ) / zwd(ji,jj,jk) 277 END_3D 322 278 ! 323 279 ! !== Vertical diffusion on v ==! … … 328 284 SELECT CASE( nldf_dyn ) 329 285 CASE( np_lap_i ) ! rotated lateral mixing: add its vertical mixing (akzv) 330 DO jk = 1, jpkm1 331 DO jj = 2, jpjm1 332 DO ji = fs_2, fs_jpim1 ! vector opt. 333 ze3va = ( 1._wp - r_vvl ) * e3v_n(ji,jj,jk) + r_vvl * e3v_a(ji,jj,jk) ! after scale factor at V-point 334 zzwi = - zdt * ( avm(ji,jj+1,jk ) + avm(ji,jj,jk ) + akzv(ji,jj,jk ) ) & 335 & / ( ze3va * e3vw_n(ji,jj,jk ) ) * wvmask(ji,jj,jk ) 336 zzws = - zdt * ( avm(ji,jj+1,jk+1) + avm(ji,jj,jk+1) + akzv(ji,jj,jk+1) ) & 337 & / ( ze3va * e3vw_n(ji,jj,jk+1) ) * wvmask(ji,jj,jk+1) 338 zWvi = ( wi(ji,jj,jk ) + wi(ji,jj+1,jk ) ) / ze3va 339 zWvs = ( wi(ji,jj,jk+1) + wi(ji,jj+1,jk+1) ) / ze3va 340 zwi(ji,jj,jk) = zzwi + zdt * MIN( zWvi, 0._wp ) 341 zws(ji,jj,jk) = zzws - zdt * MAX( zWvs, 0._wp ) 342 zwd(ji,jj,jk) = 1._wp - zzwi - zzws - zdt * ( - MAX( zWvi, 0._wp ) + MIN( zWvs, 0._wp ) ) 343 END DO 344 END DO 345 END DO 286 DO_3D_00_00( 1, jpkm1 ) 287 ze3va = ( 1._wp - r_vvl ) * e3v_n(ji,jj,jk) + r_vvl * e3v_a(ji,jj,jk) ! after scale factor at V-point 288 zzwi = - zdt * ( avm(ji,jj+1,jk ) + avm(ji,jj,jk ) + akzv(ji,jj,jk ) ) & 289 & / ( ze3va * e3vw_n(ji,jj,jk ) ) * wvmask(ji,jj,jk ) 290 zzws = - zdt * ( avm(ji,jj+1,jk+1) + avm(ji,jj,jk+1) + akzv(ji,jj,jk+1) ) & 291 & / ( ze3va * e3vw_n(ji,jj,jk+1) ) * wvmask(ji,jj,jk+1) 292 zWvi = ( wi(ji,jj,jk ) + wi(ji,jj+1,jk ) ) / ze3va 293 zWvs = ( wi(ji,jj,jk+1) + wi(ji,jj+1,jk+1) ) / ze3va 294 zwi(ji,jj,jk) = zzwi + zdt * MIN( zWvi, 0._wp ) 295 zws(ji,jj,jk) = zzws - zdt * MAX( zWvs, 0._wp ) 296 zwd(ji,jj,jk) = 1._wp - zzwi - zzws - zdt * ( - MAX( zWvi, 0._wp ) + MIN( zWvs, 0._wp ) ) 297 END_3D 346 298 CASE DEFAULT ! iso-level lateral mixing 347 DO jk = 1, jpkm1 348 DO jj = 2, jpjm1 349 DO ji = fs_2, fs_jpim1 ! vector opt. 350 ze3va = ( 1._wp - r_vvl ) * e3v_n(ji,jj,jk) + r_vvl * e3v_a(ji,jj,jk) ! after scale factor at V-point 351 zzwi = - zdt * ( avm(ji,jj+1,jk ) + avm(ji,jj,jk ) ) / ( ze3va * e3vw_n(ji,jj,jk ) ) * wvmask(ji,jj,jk ) 352 zzws = - zdt * ( avm(ji,jj+1,jk+1) + avm(ji,jj,jk+1) ) / ( ze3va * e3vw_n(ji,jj,jk+1) ) * wvmask(ji,jj,jk+1) 353 zWvi = ( wi(ji,jj,jk ) + wi(ji,jj+1,jk ) ) / ze3va 354 zWvs = ( wi(ji,jj,jk+1) + wi(ji,jj+1,jk+1) ) / ze3va 355 zwi(ji,jj,jk) = zzwi + zdt * MIN( zWvi, 0._wp ) 356 zws(ji,jj,jk) = zzws - zdt * MAX( zWvs, 0._wp ) 357 zwd(ji,jj,jk) = 1._wp - zzwi - zzws - zdt * ( - MAX( zWvi, 0._wp ) + MIN( zWvs, 0._wp ) ) 358 END DO 359 END DO 360 END DO 299 DO_3D_00_00( 1, jpkm1 ) 300 ze3va = ( 1._wp - r_vvl ) * e3v_n(ji,jj,jk) + r_vvl * e3v_a(ji,jj,jk) ! after scale factor at V-point 301 zzwi = - zdt * ( avm(ji,jj+1,jk ) + avm(ji,jj,jk ) ) / ( ze3va * e3vw_n(ji,jj,jk ) ) * wvmask(ji,jj,jk ) 302 zzws = - zdt * ( avm(ji,jj+1,jk+1) + avm(ji,jj,jk+1) ) / ( ze3va * e3vw_n(ji,jj,jk+1) ) * wvmask(ji,jj,jk+1) 303 zWvi = ( wi(ji,jj,jk ) + wi(ji,jj+1,jk ) ) / ze3va 304 zWvs = ( wi(ji,jj,jk+1) + wi(ji,jj+1,jk+1) ) / ze3va 305 zwi(ji,jj,jk) = zzwi + zdt * MIN( zWvi, 0._wp ) 306 zws(ji,jj,jk) = zzws - zdt * MAX( zWvs, 0._wp ) 307 zwd(ji,jj,jk) = 1._wp - zzwi - zzws - zdt * ( - MAX( zWvi, 0._wp ) + MIN( zWvs, 0._wp ) ) 308 END_3D 361 309 END SELECT 362 DO jj = 2, jpjm1 !* Surface boundary conditions 363 DO ji = fs_2, fs_jpim1 ! vector opt. 364 zwi(ji,jj,1) = 0._wp 365 ze3va = ( 1._wp - r_vvl ) * e3v_n(ji,jj,1) + r_vvl * e3v_a(ji,jj,1) 366 zzws = - zdt * ( avm(ji,jj+1,2) + avm(ji,jj,2) ) / ( ze3va * e3vw_n(ji,jj,2) ) * wvmask(ji,jj,2) 367 zWvs = ( wi(ji,jj ,2) + wi(ji,jj+1,2) ) / ze3va 368 zws(ji,jj,1 ) = zzws - zdt * MAX( zWvs, 0._wp ) 369 zwd(ji,jj,1 ) = 1._wp - zzws - zdt * ( MIN( zWvs, 0._wp ) ) 370 END DO 371 END DO 310 DO_2D_00_00 311 zwi(ji,jj,1) = 0._wp 312 ze3va = ( 1._wp - r_vvl ) * e3v_n(ji,jj,1) + r_vvl * e3v_a(ji,jj,1) 313 zzws = - zdt * ( avm(ji,jj+1,2) + avm(ji,jj,2) ) / ( ze3va * e3vw_n(ji,jj,2) ) * wvmask(ji,jj,2) 314 zWvs = ( wi(ji,jj ,2) + wi(ji,jj+1,2) ) / ze3va 315 zws(ji,jj,1 ) = zzws - zdt * MAX( zWvs, 0._wp ) 316 zwd(ji,jj,1 ) = 1._wp - zzws - zdt * ( MIN( zWvs, 0._wp ) ) 317 END_2D 372 318 ELSE 373 319 SELECT CASE( nldf_dyn ) 374 320 CASE( np_lap_i ) ! rotated lateral mixing: add its vertical mixing (akzu) 375 DO jk = 1, jpkm1 376 DO jj = 2, jpjm1 377 DO ji = fs_2, fs_jpim1 ! vector opt. 378 ze3va = ( 1._wp - r_vvl ) * e3v_n(ji,jj,jk) + r_vvl * e3v_a(ji,jj,jk) ! after scale factor at V-point 379 zzwi = - zdt * ( avm(ji,jj+1,jk ) + avm(ji,jj,jk ) + akzv(ji,jj,jk ) ) & 380 & / ( ze3va * e3vw_n(ji,jj,jk ) ) * wvmask(ji,jj,jk ) 381 zzws = - zdt * ( avm(ji,jj+1,jk+1) + avm(ji,jj,jk+1) + akzv(ji,jj,jk+1) ) & 382 & / ( ze3va * e3vw_n(ji,jj,jk+1) ) * wvmask(ji,jj,jk+1) 383 zwi(ji,jj,jk) = zzwi 384 zws(ji,jj,jk) = zzws 385 zwd(ji,jj,jk) = 1._wp - zzwi - zzws 386 END DO 387 END DO 388 END DO 321 DO_3D_00_00( 1, jpkm1 ) 322 ze3va = ( 1._wp - r_vvl ) * e3v_n(ji,jj,jk) + r_vvl * e3v_a(ji,jj,jk) ! after scale factor at V-point 323 zzwi = - zdt * ( avm(ji,jj+1,jk ) + avm(ji,jj,jk ) + akzv(ji,jj,jk ) ) & 324 & / ( ze3va * e3vw_n(ji,jj,jk ) ) * wvmask(ji,jj,jk ) 325 zzws = - zdt * ( avm(ji,jj+1,jk+1) + avm(ji,jj,jk+1) + akzv(ji,jj,jk+1) ) & 326 & / ( ze3va * e3vw_n(ji,jj,jk+1) ) * wvmask(ji,jj,jk+1) 327 zwi(ji,jj,jk) = zzwi 328 zws(ji,jj,jk) = zzws 329 zwd(ji,jj,jk) = 1._wp - zzwi - zzws 330 END_3D 389 331 CASE DEFAULT ! iso-level lateral mixing 390 DO jk = 1, jpkm1 391 DO jj = 2, jpjm1 392 DO ji = fs_2, fs_jpim1 ! vector opt. 393 ze3va = ( 1._wp - r_vvl ) * e3v_n(ji,jj,jk) + r_vvl * e3v_a(ji,jj,jk) ! after scale factor at V-point 394 zzwi = - zdt * ( avm(ji,jj+1,jk ) + avm(ji,jj,jk ) ) / ( ze3va * e3vw_n(ji,jj,jk ) ) * wvmask(ji,jj,jk ) 395 zzws = - zdt * ( avm(ji,jj+1,jk+1) + avm(ji,jj,jk+1) ) / ( ze3va * e3vw_n(ji,jj,jk+1) ) * wvmask(ji,jj,jk+1) 396 zwi(ji,jj,jk) = zzwi 397 zws(ji,jj,jk) = zzws 398 zwd(ji,jj,jk) = 1._wp - zzwi - zzws 399 END DO 400 END DO 401 END DO 332 DO_3D_00_00( 1, jpkm1 ) 333 ze3va = ( 1._wp - r_vvl ) * e3v_n(ji,jj,jk) + r_vvl * e3v_a(ji,jj,jk) ! after scale factor at V-point 334 zzwi = - zdt * ( avm(ji,jj+1,jk ) + avm(ji,jj,jk ) ) / ( ze3va * e3vw_n(ji,jj,jk ) ) * wvmask(ji,jj,jk ) 335 zzws = - zdt * ( avm(ji,jj+1,jk+1) + avm(ji,jj,jk+1) ) / ( ze3va * e3vw_n(ji,jj,jk+1) ) * wvmask(ji,jj,jk+1) 336 zwi(ji,jj,jk) = zzwi 337 zws(ji,jj,jk) = zzws 338 zwd(ji,jj,jk) = 1._wp - zzwi - zzws 339 END_3D 402 340 END SELECT 403 DO jj = 2, jpjm1 !* Surface boundary conditions 404 DO ji = fs_2, fs_jpim1 ! vector opt. 405 zwi(ji,jj,1) = 0._wp 406 zwd(ji,jj,1) = 1._wp - zws(ji,jj,1) 407 END DO 408 END DO 341 DO_2D_00_00 342 zwi(ji,jj,1) = 0._wp 343 zwd(ji,jj,1) = 1._wp - zws(ji,jj,1) 344 END_2D 409 345 ENDIF 410 346 ! … … 416 352 ! 417 353 IF( ln_drgimp ) THEN 418 DO jj = 2, jpjm1 419 DO ji = 2, jpim1 420 ikv = mbkv(ji,jj) ! (deepest ocean u- and v-points) 354 DO_2D_00_00 355 ikv = mbkv(ji,jj) ! (deepest ocean u- and v-points) 356 ze3va = ( 1._wp - r_vvl ) * e3v_n(ji,jj,ikv) + r_vvl * e3v_a(ji,jj,ikv) ! after scale factor at T-point 357 zwd(ji,jj,ikv) = zwd(ji,jj,ikv) - r2dt * 0.5*( rCdU_bot(ji,jj+1)+rCdU_bot(ji,jj) ) / ze3va 358 END_2D 359 IF ( ln_isfcav.OR.ln_drgice_imp ) THEN 360 DO_2D_00_00 361 ikv = mikv(ji,jj) ! (first wet ocean u- and v-points) 421 362 ze3va = ( 1._wp - r_vvl ) * e3v_n(ji,jj,ikv) + r_vvl * e3v_a(ji,jj,ikv) ! after scale factor at T-point 422 zwd(ji,jj,ikv) = zwd(ji,jj,ikv) - r2dt * 0.5*( rCdU_bot(ji,jj+1)+rCdU_bot(ji,jj) ) / ze3va 423 END DO 424 END DO 425 IF ( ln_isfcav.OR.ln_drgice_imp ) THEN 426 DO jj = 2, jpjm1 427 DO ji = 2, jpim1 428 ikv = mikv(ji,jj) ! (first wet ocean u- and v-points) 429 ze3va = ( 1._wp - r_vvl ) * e3v_n(ji,jj,ikv) + r_vvl * e3v_a(ji,jj,ikv) ! after scale factor at T-point 430 zwd(ji,jj,ikv) = zwd(ji,jj,ikv) - r2dt * 0.5*( rCdU_top(ji,jj+1)+rCdU_top(ji,jj) ) / ze3va 431 END DO 432 END DO 363 zwd(ji,jj,ikv) = zwd(ji,jj,ikv) - r2dt * 0.5*( rCdU_top(ji,jj+1)+rCdU_top(ji,jj) ) / ze3va 364 END_2D 433 365 ENDIF 434 366 ENDIF … … 449 381 !----------------------------------------------------------------------- 450 382 ! 451 DO jk = 2, jpkm1 !== First recurrence : Dk = Dk - Lk * Uk-1 / Dk-1 (increasing k) == 452 DO jj = 2, jpjm1 453 DO ji = fs_2, fs_jpim1 ! vector opt. 454 zwd(ji,jj,jk) = zwd(ji,jj,jk) - zwi(ji,jj,jk) * zws(ji,jj,jk-1) / zwd(ji,jj,jk-1) 455 END DO 456 END DO 457 END DO 458 ! 459 DO jj = 2, jpjm1 !== second recurrence: SOLk = RHSk - Lk / Dk-1 Lk-1 ==! 460 DO ji = fs_2, fs_jpim1 ! vector opt. 461 ze3va = ( 1._wp - r_vvl ) * e3v_n(ji,jj,1) + r_vvl * e3v_a(ji,jj,1) 462 va(ji,jj,1) = va(ji,jj,1) + r2dt * 0.5_wp * ( vtau_b(ji,jj) + vtau(ji,jj) ) & 463 & / ( ze3va * rau0 ) * vmask(ji,jj,1) 464 END DO 465 END DO 466 DO jk = 2, jpkm1 467 DO jj = 2, jpjm1 468 DO ji = fs_2, fs_jpim1 ! vector opt. 469 va(ji,jj,jk) = va(ji,jj,jk) - zwi(ji,jj,jk) / zwd(ji,jj,jk-1) * va(ji,jj,jk-1) 470 END DO 471 END DO 472 END DO 473 ! 474 DO jj = 2, jpjm1 !== third recurrence : SOLk = ( Lk - Uk * SOLk+1 ) / Dk ==! 475 DO ji = fs_2, fs_jpim1 ! vector opt. 476 va(ji,jj,jpkm1) = va(ji,jj,jpkm1) / zwd(ji,jj,jpkm1) 477 END DO 478 END DO 479 DO jk = jpk-2, 1, -1 480 DO jj = 2, jpjm1 481 DO ji = fs_2, fs_jpim1 482 va(ji,jj,jk) = ( va(ji,jj,jk) - zws(ji,jj,jk) * va(ji,jj,jk+1) ) / zwd(ji,jj,jk) 483 END DO 484 END DO 485 END DO 383 DO_3D_00_00( 2, jpkm1 ) 384 zwd(ji,jj,jk) = zwd(ji,jj,jk) - zwi(ji,jj,jk) * zws(ji,jj,jk-1) / zwd(ji,jj,jk-1) 385 END_3D 386 ! 387 DO_2D_00_00 388 ze3va = ( 1._wp - r_vvl ) * e3v_n(ji,jj,1) + r_vvl * e3v_a(ji,jj,1) 389 va(ji,jj,1) = va(ji,jj,1) + r2dt * 0.5_wp * ( vtau_b(ji,jj) + vtau(ji,jj) ) & 390 & / ( ze3va * rau0 ) * vmask(ji,jj,1) 391 END_2D 392 DO_3D_00_00( 2, jpkm1 ) 393 va(ji,jj,jk) = va(ji,jj,jk) - zwi(ji,jj,jk) / zwd(ji,jj,jk-1) * va(ji,jj,jk-1) 394 END_3D 395 ! 396 DO_2D_00_00 397 va(ji,jj,jpkm1) = va(ji,jj,jpkm1) / zwd(ji,jj,jpkm1) 398 END_2D 399 DO_3D_00_00( jpk-2, 1, -1 ) 400 va(ji,jj,jk) = ( va(ji,jj,jk) - zws(ji,jj,jk) * va(ji,jj,jk+1) ) / zwd(ji,jj,jk) 401 END_3D 486 402 ! 487 403 IF( l_trddyn ) THEN ! save the vertical diffusive trends for further diagnostics 488 ztrdu(:,:,:) = ( ua(:,:,:) - u b(:,:,:) ) / r2dt - ztrdu(:,:,:)489 ztrdv(:,:,:) = ( va(:,:,:) - v b(:,:,:) ) / r2dt - ztrdv(:,:,:)404 ztrdu(:,:,:) = ( ua(:,:,:) - uu(:,:,:,Nnn) ) / r2dt - ztrdu(:,:,:) 405 ztrdv(:,:,:) = ( va(:,:,:) - vv(:,:,:,Nnn) ) / r2dt - ztrdv(:,:,:) 490 406 CALL trd_dyn( ztrdu, ztrdv, jpdyn_zdf, kt ) 491 407 DEALLOCATE( ztrdu, ztrdv ) -
NEMO/branches/2020/temporary_r4_trunk/src/OCE/SBC/sbc_oce.F90
r13466 r13469 209 209 !!--------------------------------------------------------------------- 210 210 zcoef = 0.5 / ( zrhoa * zcdrag ) 211 DO jj = 2, jpjm1 212 DO ji = fs_2, fs_jpim1 ! vect. opt. 213 ztx = utau(ji-1,jj ) + utau(ji,jj) 214 zty = vtau(ji ,jj-1) + vtau(ji,jj) 215 ztau = SQRT( ztx * ztx + zty * zty ) 216 wndm(ji,jj) = SQRT ( ztau * zcoef ) * tmask(ji,jj,1) 217 END DO 218 END DO 211 DO_2D_00_00 212 ztx = utau(ji-1,jj ) + utau(ji,jj) 213 zty = vtau(ji ,jj-1) + vtau(ji,jj) 214 ztau = SQRT( ztx * ztx + zty * zty ) 215 wndm(ji,jj) = SQRT ( ztau * zcoef ) * tmask(ji,jj,1) 216 END_2D 219 217 CALL lbc_lnk( 'sbc_oce', wndm(:,:) , 'T', 1. ) 220 218 ! -
NEMO/branches/2020/temporary_r4_trunk/src/OCE/SBC/sbcblk.F90
r13467 r13469 408 408 #if defined key_cyclone 409 409 CALL wnd_cyc( kt, zwnd_i, zwnd_j ) ! add analytical tropical cyclone (Vincent et al. JGR 2012) 410 DO jj = 2, jpjm1 411 DO ji = fs_2, fs_jpim1 ! vect. opt. 412 sf(jp_wndi)%fnow(ji,jj,1) = sf(jp_wndi)%fnow(ji,jj,1) + zwnd_i(ji,jj) 413 sf(jp_wndj)%fnow(ji,jj,1) = sf(jp_wndj)%fnow(ji,jj,1) + zwnd_j(ji,jj) 414 END DO 415 END DO 410 DO_2D_00_00 411 sf(jp_wndi)%fnow(ji,jj,1) = sf(jp_wndi)%fnow(ji,jj,1) + zwnd_i(ji,jj) 412 sf(jp_wndj)%fnow(ji,jj,1) = sf(jp_wndj)%fnow(ji,jj,1) + zwnd_j(ji,jj) 413 END_2D 416 414 #endif 417 DO jj = 2, jpjm1 418 DO ji = fs_2, fs_jpim1 ! vect. opt. 419 zwnd_i(ji,jj) = ( sf(jp_wndi)%fnow(ji,jj,1) - rn_vfac * 0.5 * ( pu(ji-1,jj ) + pu(ji,jj) ) ) 420 zwnd_j(ji,jj) = ( sf(jp_wndj)%fnow(ji,jj,1) - rn_vfac * 0.5 * ( pv(ji ,jj-1) + pv(ji,jj) ) ) 421 END DO 422 END DO 415 DO_2D_00_00 416 zwnd_i(ji,jj) = ( sf(jp_wndi)%fnow(ji,jj,1) - rn_vfac * 0.5 * ( pu(ji-1,jj ) + pu(ji,jj) ) ) 417 zwnd_j(ji,jj) = ( sf(jp_wndj)%fnow(ji,jj,1) - rn_vfac * 0.5 * ( pv(ji ,jj-1) + pv(ji,jj) ) ) 418 END_2D 423 419 CALL lbc_lnk_multi( 'sbcblk', zwnd_i, 'T', -1., zwnd_j, 'T', -1. ) 424 420 ! ... scalar wind ( = | U10m - U_oce | ) at T-point (masked) … … 474 470 !! CALL iom_put( "Ch_oce", Ch_atm) ! output value of pure ocean-atm. transfer coef. 475 471 476 DO jj = 1, jpj ! tau module, i and j component 477 DO ji = 1, jpi 478 zztmp = zrhoa(ji,jj) * zU_zu(ji,jj) * Cd_atm(ji,jj) ! using bulk wind speed 479 taum (ji,jj) = zztmp * wndm (ji,jj) 480 zwnd_i(ji,jj) = zztmp * zwnd_i(ji,jj) 481 zwnd_j(ji,jj) = zztmp * zwnd_j(ji,jj) 482 END DO 483 END DO 472 DO_2D_11_11 473 zztmp = zrhoa(ji,jj) * zU_zu(ji,jj) * Cd_atm(ji,jj) ! using bulk wind speed 474 taum (ji,jj) = zztmp * wndm (ji,jj) 475 zwnd_i(ji,jj) = zztmp * zwnd_i(ji,jj) 476 zwnd_j(ji,jj) = zztmp * zwnd_j(ji,jj) 477 END_2D 484 478 485 479 ! ! add the HF tau contribution to the wind stress module … … 491 485 ! Note the use of 0.5*(2-umask) in order to unmask the stress along coastlines 492 486 ! Note the use of MAX(tmask(i,j),tmask(i+1,j) is to mask tau over ice shelves 493 DO jj = 1, jpjm1 494 DO ji = 1, fs_jpim1 495 utau(ji,jj) = 0.5 * ( 2. - umask(ji,jj,1) ) * ( zwnd_i(ji,jj) + zwnd_i(ji+1,jj ) ) & 496 & * MAX(tmask(ji,jj,1),tmask(ji+1,jj,1)) 497 vtau(ji,jj) = 0.5 * ( 2. - vmask(ji,jj,1) ) * ( zwnd_j(ji,jj) + zwnd_j(ji ,jj+1) ) & 498 & * MAX(tmask(ji,jj,1),tmask(ji,jj+1,1)) 499 END DO 500 END DO 487 DO_2D_10_10 488 utau(ji,jj) = 0.5 * ( 2. - umask(ji,jj,1) ) * ( zwnd_i(ji,jj) + zwnd_i(ji+1,jj ) ) & 489 & * MAX(tmask(ji,jj,1),tmask(ji+1,jj,1)) 490 vtau(ji,jj) = 0.5 * ( 2. - vmask(ji,jj,1) ) * ( zwnd_j(ji,jj) + zwnd_j(ji ,jj+1) ) & 491 & * MAX(tmask(ji,jj,1),tmask(ji,jj+1,1)) 492 END_2D 501 493 CALL lbc_lnk_multi( 'sbcblk', utau, 'U', -1., vtau, 'V', -1. ) 502 494 … … 633 625 !!---------------------------------------------------------------------------------- 634 626 ! 635 DO jj = 1, jpj 636 DO ji = 1, jpi 627 DO_2D_11_11 628 ! 629 ztmp = rt0 / ptak(ji,jj) 630 ! 631 ! Vapour pressure at saturation [hPa] : WMO, (Goff, 1957) 632 ze_sat = 10.**( 10.79574*(1. - ztmp) - 5.028*LOG10(ptak(ji,jj)/rt0) & 633 & + 1.50475*10.**(-4)*(1. - 10.**(-8.2969*(ptak(ji,jj)/rt0 - 1.)) ) & 634 & + 0.42873*10.**(-3)*(10.**(4.76955*(1. - ztmp)) - 1.) + 0.78614 ) 637 635 ! 638 ztmp = rt0 / ptak(ji,jj) 639 ! 640 ! Vapour pressure at saturation [hPa] : WMO, (Goff, 1957) 641 ze_sat = 10.**( 10.79574*(1. - ztmp) - 5.028*LOG10(ptak(ji,jj)/rt0) & 642 & + 1.50475*10.**(-4)*(1. - 10.**(-8.2969*(ptak(ji,jj)/rt0 - 1.)) ) & 643 & + 0.42873*10.**(-3)*(10.**(4.76955*(1. - ztmp)) - 1.) + 0.78614 ) 644 ! 645 q_sat(ji,jj) = reps0 * ze_sat/( 0.01_wp*pslp(ji,jj) - (1._wp - reps0)*ze_sat ) ! 0.01 because SLP is in [Pa] 646 ! 647 END DO 648 END DO 636 q_sat(ji,jj) = reps0 * ze_sat/( 0.01_wp*pslp(ji,jj) - (1._wp - reps0)*ze_sat ) ! 0.01 because SLP is in [Pa] 637 ! 638 END_2D 649 639 ! 650 640 END FUNCTION q_sat … … 669 659 !!---------------------------------------------------------------------------------- 670 660 ! 671 DO jj = 1, jpj 672 DO ji = 1, jpi 673 zrv = pqa(ji,jj) / (1. - pqa(ji,jj)) 674 ziRT = 1. / (R_dry*ptak(ji,jj)) ! 1/RT 675 gamma_moist(ji,jj) = grav * ( 1. + rLevap*zrv*ziRT ) / ( Cp_dry + rLevap*rLevap*zrv*reps0*ziRT/ptak(ji,jj) ) 676 END DO 677 END DO 661 DO_2D_11_11 662 zrv = pqa(ji,jj) / (1. - pqa(ji,jj)) 663 ziRT = 1. / (R_dry*ptak(ji,jj)) ! 1/RT 664 gamma_moist(ji,jj) = grav * ( 1. + rLevap*zrv*ziRT ) / ( Cp_dry + rLevap*rLevap*zrv*reps0*ziRT/ptak(ji,jj) ) 665 END_2D 678 666 ! 679 667 END FUNCTION gamma_moist … … 735 723 ! ------------------------------------------------------------ ! 736 724 ! C-grid ice dynamics : U & V-points (same as ocean) 737 DO jj = 2, jpjm1 738 DO ji = fs_2, fs_jpim1 ! vect. opt. 739 zwndi_t = ( sf(jp_wndi)%fnow(ji,jj,1) - rn_vfac * 0.5 * ( u_ice(ji-1,jj ) + u_ice(ji,jj) ) ) 740 zwndj_t = ( sf(jp_wndj)%fnow(ji,jj,1) - rn_vfac * 0.5 * ( v_ice(ji ,jj-1) + v_ice(ji,jj) ) ) 741 wndm_ice(ji,jj) = SQRT( zwndi_t * zwndi_t + zwndj_t * zwndj_t ) * tmask(ji,jj,1) 742 END DO 743 END DO 725 DO_2D_00_00 726 zwndi_t = ( sf(jp_wndi)%fnow(ji,jj,1) - rn_vfac * 0.5 * ( u_ice(ji-1,jj ) + u_ice(ji,jj) ) ) 727 zwndj_t = ( sf(jp_wndj)%fnow(ji,jj,1) - rn_vfac * 0.5 * ( v_ice(ji ,jj-1) + v_ice(ji,jj) ) ) 728 wndm_ice(ji,jj) = SQRT( zwndi_t * zwndi_t + zwndj_t * zwndj_t ) * tmask(ji,jj,1) 729 END_2D 744 730 CALL lbc_lnk( 'sbcblk', wndm_ice, 'T', 1. ) 745 731 ! … … 763 749 ! ------------------------------------------------------------ ! 764 750 zztmp1 = rn_vfac * 0.5_wp 765 DO jj = 2, jpj ! at T point 766 DO ji = 2, jpi 767 zztmp2 = zrhoa(ji,jj) * Cd_atm(ji,jj) * wndm_ice(ji,jj) 768 utau_ice(ji,jj) = zztmp2 * ( sf(jp_wndi)%fnow(ji,jj,1) - zztmp1 * ( u_ice(ji-1,jj ) + u_ice(ji,jj) ) ) 769 vtau_ice(ji,jj) = zztmp2 * ( sf(jp_wndj)%fnow(ji,jj,1) - zztmp1 * ( v_ice(ji ,jj-1) + v_ice(ji,jj) ) ) 770 END DO 771 END DO 772 ! 773 DO jj = 2, jpjm1 ! U & V-points (same as ocean). 774 DO ji = fs_2, fs_jpim1 ! vect. opt. 775 ! take care of the land-sea mask to avoid "pollution" of coastal stress. p[uv]taui used in frazil and rheology 776 zztmp1 = 0.5_wp * ( 2. - umask(ji,jj,1) ) * MAX( tmask(ji,jj,1),tmask(ji+1,jj ,1) ) 777 zztmp2 = 0.5_wp * ( 2. - vmask(ji,jj,1) ) * MAX( tmask(ji,jj,1),tmask(ji ,jj+1,1) ) 778 utau_ice(ji,jj) = zztmp1 * ( utau_ice(ji,jj) + utau_ice(ji+1,jj ) ) 779 vtau_ice(ji,jj) = zztmp2 * ( vtau_ice(ji,jj) + vtau_ice(ji ,jj+1) ) 780 END DO 781 END DO 751 DO_2D_01_01 752 zztmp2 = zrhoa(ji,jj) * Cd_atm(ji,jj) * wndm_ice(ji,jj) 753 utau_ice(ji,jj) = zztmp2 * ( sf(jp_wndi)%fnow(ji,jj,1) - zztmp1 * ( u_ice(ji-1,jj ) + u_ice(ji,jj) ) ) 754 vtau_ice(ji,jj) = zztmp2 * ( sf(jp_wndj)%fnow(ji,jj,1) - zztmp1 * ( v_ice(ji ,jj-1) + v_ice(ji,jj) ) ) 755 END_2D 756 ! 757 DO_2D_00_00 758 ! take care of the land-sea mask to avoid "pollution" of coastal stress. p[uv]taui used in frazil and rheology 759 zztmp1 = 0.5_wp * ( 2. - umask(ji,jj,1) ) * MAX( tmask(ji,jj,1),tmask(ji+1,jj ,1) ) 760 zztmp2 = 0.5_wp * ( 2. - vmask(ji,jj,1) ) * MAX( tmask(ji,jj,1),tmask(ji ,jj+1,1) ) 761 utau_ice(ji,jj) = zztmp1 * ( utau_ice(ji,jj) + utau_ice(ji+1,jj ) ) 762 vtau_ice(ji,jj) = zztmp2 * ( vtau_ice(ji,jj) + vtau_ice(ji ,jj+1) ) 763 END_2D 782 764 CALL lbc_lnk_multi( 'sbcblk', utau_ice, 'U', -1., vtau_ice, 'V', -1. ) 783 765 ! … … 1025 1007 ! 1026 1008 DO jl = 1, jpl 1027 DO jj = 1 , jpj 1028 DO ji = 1, jpi 1029 zhe = ( rn_cnd_s * phi(ji,jj,jl) + rcnd_i * phs(ji,jj,jl) ) * zfac ! Effective thickness 1030 IF( zhe >= zfac2 ) zgfac(ji,jj,jl) = MIN( 2._wp, 0.5_wp * ( 1._wp + LOG( zhe * zfac3 ) ) ) ! Enhanced conduction factor 1031 END DO 1032 END DO 1009 DO_2D_11_11 1010 zhe = ( rn_cnd_s * phi(ji,jj,jl) + rcnd_i * phs(ji,jj,jl) ) * zfac ! Effective thickness 1011 IF( zhe >= zfac2 ) zgfac(ji,jj,jl) = MIN( 2._wp, 0.5_wp * ( 1._wp + LOG( zhe * zfac3 ) ) ) ! Enhanced conduction factor 1012 END_2D 1033 1013 END DO 1034 1014 ! … … 1042 1022 ! 1043 1023 DO jl = 1, jpl 1044 DO jj = 1 , jpj 1045 DO ji = 1, jpi 1046 ! 1047 zkeff_h = zfac * zgfac(ji,jj,jl) / & ! Effective conductivity of the snow-ice system divided by thickness 1048 & ( rcnd_i * phs(ji,jj,jl) + rn_cnd_s * MAX( 0.01, phi(ji,jj,jl) ) ) 1049 ztsu = ptsu(ji,jj,jl) ! Store current iteration temperature 1050 ztsu0 = ptsu(ji,jj,jl) ! Store initial surface temperature 1051 zqa0 = qsr_ice(ji,jj,jl) - qtr_ice_top(ji,jj,jl) + qns_ice(ji,jj,jl) ! Net initial atmospheric heat flux 1052 ! 1053 DO iter = 1, nit ! --- Iterative loop 1054 zqc = zkeff_h * ( ztsu - ptb(ji,jj) ) ! Conduction heat flux through snow-ice system (>0 downwards) 1055 zqnet = zqa0 + dqns_ice(ji,jj,jl) * ( ztsu - ptsu(ji,jj,jl) ) - zqc ! Surface energy budget 1056 ztsu = ztsu - zqnet / ( dqns_ice(ji,jj,jl) - zkeff_h ) ! Temperature update 1057 END DO 1058 ! 1059 ptsu (ji,jj,jl) = MIN( rt0, ztsu ) 1060 qcn_ice(ji,jj,jl) = zkeff_h * ( ptsu(ji,jj,jl) - ptb(ji,jj) ) 1061 qns_ice(ji,jj,jl) = qns_ice(ji,jj,jl) + dqns_ice(ji,jj,jl) * ( ptsu(ji,jj,jl) - ztsu0 ) 1062 qml_ice(ji,jj,jl) = ( qsr_ice(ji,jj,jl) - qtr_ice_top(ji,jj,jl) + qns_ice(ji,jj,jl) - qcn_ice(ji,jj,jl) ) & 1063 & * MAX( 0._wp , SIGN( 1._wp, ptsu(ji,jj,jl) - rt0 ) ) 1064 1065 ! --- Diagnose the heat loss due to changing non-solar flux (as in icethd_zdf_bl99) --- ! 1066 hfx_err_dif(ji,jj) = hfx_err_dif(ji,jj) - ( dqns_ice(ji,jj,jl) * ( ptsu(ji,jj,jl) - ztsu0 ) ) * a_i_b(ji,jj,jl) 1067 1024 DO_2D_11_11 1025 ! 1026 zkeff_h = zfac * zgfac(ji,jj,jl) / & ! Effective conductivity of the snow-ice system divided by thickness 1027 & ( rcnd_i * phs(ji,jj,jl) + rn_cnd_s * MAX( 0.01, phi(ji,jj,jl) ) ) 1028 ztsu = ptsu(ji,jj,jl) ! Store current iteration temperature 1029 ztsu0 = ptsu(ji,jj,jl) ! Store initial surface temperature 1030 zqa0 = qsr_ice(ji,jj,jl) - qtr_ice_top(ji,jj,jl) + qns_ice(ji,jj,jl) ! Net initial atmospheric heat flux 1031 ! 1032 DO iter = 1, nit ! --- Iterative loop 1033 zqc = zkeff_h * ( ztsu - ptb(ji,jj) ) ! Conduction heat flux through snow-ice system (>0 downwards) 1034 zqnet = zqa0 + dqns_ice(ji,jj,jl) * ( ztsu - ptsu(ji,jj,jl) ) - zqc ! Surface energy budget 1035 ztsu = ztsu - zqnet / ( dqns_ice(ji,jj,jl) - zkeff_h ) ! Temperature update 1068 1036 END DO 1069 END DO 1037 ! 1038 ptsu (ji,jj,jl) = MIN( rt0, ztsu ) 1039 qcn_ice(ji,jj,jl) = zkeff_h * ( ptsu(ji,jj,jl) - ptb(ji,jj) ) 1040 qns_ice(ji,jj,jl) = qns_ice(ji,jj,jl) + dqns_ice(ji,jj,jl) * ( ptsu(ji,jj,jl) - ztsu0 ) 1041 qml_ice(ji,jj,jl) = ( qsr_ice(ji,jj,jl) - qtr_ice_top(ji,jj,jl) + qns_ice(ji,jj,jl) - qcn_ice(ji,jj,jl) ) & 1042 & * MAX( 0._wp , SIGN( 1._wp, ptsu(ji,jj,jl) - rt0 ) ) 1043 1044 ! --- Diagnose the heat loss due to changing non-solar flux (as in icethd_zdf_bl99) --- ! 1045 hfx_err_dif(ji,jj) = hfx_err_dif(ji,jj) - ( dqns_ice(ji,jj,jl) * ( ptsu(ji,jj,jl) - ztsu0 ) ) * a_i_b(ji,jj,jl) 1046 1047 END_2D 1070 1048 ! 1071 1049 END DO … … 1195 1173 zqi_sat(:,:) = 0.98_wp * q_sat( ztm_su(:,:), sf(jp_slp)%fnow(:,:,1) ) ! saturation humidity over ice [kg/kg] 1196 1174 ! 1197 DO jj = 2, jpjm1 ! reduced loop is necessary for reproducibility 1198 DO ji = fs_2, fs_jpim1 1199 ! Virtual potential temperature [K] 1200 zthetav_os = zst(ji,jj) * ( 1._wp + rctv0 * zqo_sat(ji,jj) ) ! over ocean 1201 zthetav_is = ztm_su(ji,jj) * ( 1._wp + rctv0 * zqi_sat(ji,jj) ) ! ocean ice 1202 zthetav_zu = t_zu (ji,jj) * ( 1._wp + rctv0 * q_zu(ji,jj) ) ! at zu 1203 1204 ! Bulk Richardson Number (could use Ri_bulk function from aerobulk instead) 1205 zrib_o = grav / zthetav_os * ( zthetav_zu - zthetav_os ) * rn_zu / MAX( 0.5, wndm(ji,jj) )**2 ! over ocean 1206 zrib_i = grav / zthetav_is * ( zthetav_zu - zthetav_is ) * rn_zu / MAX( 0.5, wndm_ice(ji,jj) )**2 ! over ice 1207 1208 ! Momentum and Heat Neutral Transfert Coefficients 1209 zCdn_form_ice = zCdn_form_tmp * at_i_b(ji,jj) * ( 1._wp - at_i_b(ji,jj) )**zbeta ! Eq. 40 1210 zChn_form_ice = zCdn_form_ice / ( 1._wp + ( LOG( z1_alphaf ) / vkarmn ) * SQRT( zCdn_form_ice ) ) ! Eq. 53 1211 1212 ! Momentum and Heat Stability functions (possibility to use psi_m_ecmwf instead) 1213 z0w = rn_zu * EXP( -1._wp * vkarmn / SQRT( Cdn_oce(ji,jj) ) ) ! over water 1214 z0i = z0_skin_ice ! over ice (cf Lupkes email for details) 1215 IF( zrib_o <= 0._wp ) THEN 1216 zfmw = 1._wp - zam * zrib_o / ( 1._wp + 3._wp * zc2 * Cdn_oce(ji,jj) * SQRT( -zrib_o * ( rn_zu / z0w + 1._wp ) ) ) ! Eq. 10 1217 zfhw = ( 1._wp + ( zbetah * ( zthetav_os - zthetav_zu )**r1_3 / ( Chn_oce(ji,jj) * MAX(0.01, wndm(ji,jj)) ) & ! Eq. 26 1218 & )**zgamma )**z1_gamma 1219 ELSE 1220 zfmw = 1._wp / ( 1._wp + zam * zrib_o / SQRT( 1._wp + zrib_o ) ) ! Eq. 12 1221 zfhw = 1._wp / ( 1._wp + zah * zrib_o / SQRT( 1._wp + zrib_o ) ) ! Eq. 28 1222 ENDIF 1223 1224 IF( zrib_i <= 0._wp ) THEN 1225 zfmi = 1._wp - zam * zrib_i / (1._wp + 3._wp * zc2 * zCdn_ice * SQRT( -zrib_i * ( rn_zu / z0i + 1._wp))) ! Eq. 9 1226 zfhi = 1._wp - zah * zrib_i / (1._wp + 3._wp * zc2 * zCdn_ice * SQRT( -zrib_i * ( rn_zu / z0i + 1._wp))) ! Eq. 25 1227 ELSE 1228 zfmi = 1._wp / ( 1._wp + zam * zrib_i / SQRT( 1._wp + zrib_i ) ) ! Eq. 11 1229 zfhi = 1._wp / ( 1._wp + zah * zrib_i / SQRT( 1._wp + zrib_i ) ) ! Eq. 27 1230 ENDIF 1231 1232 ! Momentum Transfert Coefficients (Eq. 38) 1233 Cd(ji,jj) = zCdn_skin_ice * zfmi + & 1234 & zCdn_form_ice * ( zfmi * at_i_b(ji,jj) + zfmw * ( 1._wp - at_i_b(ji,jj) ) ) / MAX( 1.e-06, at_i_b(ji,jj) ) 1235 1236 ! Heat Transfert Coefficients (Eq. 49) 1237 Ch(ji,jj) = zChn_skin_ice * zfhi + & 1238 & zChn_form_ice * ( zfhi * at_i_b(ji,jj) + zfhw * ( 1._wp - at_i_b(ji,jj) ) ) / MAX( 1.e-06, at_i_b(ji,jj) ) 1239 ! 1240 END DO 1241 END DO 1175 DO_2D_00_00 1176 ! Virtual potential temperature [K] 1177 zthetav_os = zst(ji,jj) * ( 1._wp + rctv0 * zqo_sat(ji,jj) ) ! over ocean 1178 zthetav_is = ztm_su(ji,jj) * ( 1._wp + rctv0 * zqi_sat(ji,jj) ) ! ocean ice 1179 zthetav_zu = t_zu (ji,jj) * ( 1._wp + rctv0 * q_zu(ji,jj) ) ! at zu 1180 1181 ! Bulk Richardson Number (could use Ri_bulk function from aerobulk instead) 1182 zrib_o = grav / zthetav_os * ( zthetav_zu - zthetav_os ) * rn_zu / MAX( 0.5, wndm(ji,jj) )**2 ! over ocean 1183 zrib_i = grav / zthetav_is * ( zthetav_zu - zthetav_is ) * rn_zu / MAX( 0.5, wndm_ice(ji,jj) )**2 ! over ice 1184 1185 ! Momentum and Heat Neutral Transfert Coefficients 1186 zCdn_form_ice = zCdn_form_tmp * at_i_b(ji,jj) * ( 1._wp - at_i_b(ji,jj) )**zbeta ! Eq. 40 1187 zChn_form_ice = zCdn_form_ice / ( 1._wp + ( LOG( z1_alphaf ) / vkarmn ) * SQRT( zCdn_form_ice ) ) ! Eq. 53 1188 1189 ! Momentum and Heat Stability functions (possibility to use psi_m_ecmwf instead) 1190 z0w = rn_zu * EXP( -1._wp * vkarmn / SQRT( Cdn_oce(ji,jj) ) ) ! over water 1191 z0i = z0_skin_ice ! over ice (cf Lupkes email for details) 1192 IF( zrib_o <= 0._wp ) THEN 1193 zfmw = 1._wp - zam * zrib_o / ( 1._wp + 3._wp * zc2 * Cdn_oce(ji,jj) * SQRT( -zrib_o * ( rn_zu / z0w + 1._wp ) ) ) ! Eq. 10 1194 zfhw = ( 1._wp + ( zbetah * ( zthetav_os - zthetav_zu )**r1_3 / ( Chn_oce(ji,jj) * MAX(0.01, wndm(ji,jj)) ) & ! Eq. 26 1195 & )**zgamma )**z1_gamma 1196 ELSE 1197 zfmw = 1._wp / ( 1._wp + zam * zrib_o / SQRT( 1._wp + zrib_o ) ) ! Eq. 12 1198 zfhw = 1._wp / ( 1._wp + zah * zrib_o / SQRT( 1._wp + zrib_o ) ) ! Eq. 28 1199 ENDIF 1200 1201 IF( zrib_i <= 0._wp ) THEN 1202 zfmi = 1._wp - zam * zrib_i / (1._wp + 3._wp * zc2 * zCdn_ice * SQRT( -zrib_i * ( rn_zu / z0i + 1._wp))) ! Eq. 9 1203 zfhi = 1._wp - zah * zrib_i / (1._wp + 3._wp * zc2 * zCdn_ice * SQRT( -zrib_i * ( rn_zu / z0i + 1._wp))) ! Eq. 25 1204 ELSE 1205 zfmi = 1._wp / ( 1._wp + zam * zrib_i / SQRT( 1._wp + zrib_i ) ) ! Eq. 11 1206 zfhi = 1._wp / ( 1._wp + zah * zrib_i / SQRT( 1._wp + zrib_i ) ) ! Eq. 27 1207 ENDIF 1208 1209 ! Momentum Transfert Coefficients (Eq. 38) 1210 Cd(ji,jj) = zCdn_skin_ice * zfmi + & 1211 & zCdn_form_ice * ( zfmi * at_i_b(ji,jj) + zfmw * ( 1._wp - at_i_b(ji,jj) ) ) / MAX( 1.e-06, at_i_b(ji,jj) ) 1212 1213 ! Heat Transfert Coefficients (Eq. 49) 1214 Ch(ji,jj) = zChn_skin_ice * zfhi + & 1215 & zChn_form_ice * ( zfhi * at_i_b(ji,jj) + zfhw * ( 1._wp - at_i_b(ji,jj) ) ) / MAX( 1.e-06, at_i_b(ji,jj) ) 1216 ! 1217 END_2D 1242 1218 CALL lbc_lnk_multi( 'sbcblk', Cd, 'T', 1., Ch, 'T', 1. ) 1243 1219 ! -
NEMO/branches/2020/temporary_r4_trunk/src/OCE/SBC/sbcblk_algo_ncar.F90
r13466 r13469 214 214 !!---------------------------------------------------------------------------------- 215 215 ! 216 DO jj = 1, jpj 217 DO ji = 1, jpi 218 ! 219 zw = pw10(ji,jj) 220 zw6 = zw*zw*zw 221 zw6 = zw6*zw6 222 ! 223 ! When wind speed > 33 m/s => Cyclone conditions => special treatment 224 zgt33 = 0.5_wp + SIGN( 0.5_wp, (zw - 33._wp) ) ! If pw10 < 33. => 0, else => 1 225 ! 226 CD_N10_NCAR(ji,jj) = 1.e-3_wp * ( & 227 & (1._wp - zgt33)*( 2.7_wp/zw + 0.142_wp + zw/13.09_wp - 3.14807E-10_wp*zw6) & ! wind < 33 m/s 228 & + zgt33 * 2.34_wp ) ! wind >= 33 m/s 229 ! 230 CD_N10_NCAR(ji,jj) = MAX( CD_N10_NCAR(ji,jj), 0.1E-3_wp ) 231 ! 232 END DO 233 END DO 216 DO_2D_11_11 217 ! 218 zw = pw10(ji,jj) 219 zw6 = zw*zw*zw 220 zw6 = zw6*zw6 221 ! 222 ! When wind speed > 33 m/s => Cyclone conditions => special treatment 223 zgt33 = 0.5_wp + SIGN( 0.5_wp, (zw - 33._wp) ) ! If pw10 < 33. => 0, else => 1 224 ! 225 CD_N10_NCAR(ji,jj) = 1.e-3_wp * ( & 226 & (1._wp - zgt33)*( 2.7_wp/zw + 0.142_wp + zw/13.09_wp - 3.14807E-10_wp*zw6) & ! wind < 33 m/s 227 & + zgt33 * 2.34_wp ) ! wind >= 33 m/s 228 ! 229 CD_N10_NCAR(ji,jj) = MAX( CD_N10_NCAR(ji,jj), 0.1E-3_wp ) 230 ! 231 END_2D 234 232 ! 235 233 END FUNCTION CD_N10_NCAR … … 281 279 REAL(wp) :: zzeta, zx2, zx, zpsi_unst, zpsi_stab, zstab ! local scalars 282 280 !!---------------------------------------------------------------------------------- 283 DO jj = 1, jpj 284 DO ji = 1, jpi 285 286 zzeta = pzeta(ji,jj) 287 ! 288 zx2 = SQRT( ABS(1._wp - 16._wp*zzeta) ) ! (1 - 16z)^0.5 289 zx2 = MAX( zx2 , 1._wp ) 290 zx = SQRT(zx2) ! (1 - 16z)^0.25 291 zpsi_unst = 2._wp*LOG( (1._wp + zx )*0.5_wp ) & 292 & + LOG( (1._wp + zx2)*0.5_wp ) & 293 & - 2._wp*ATAN(zx) + rpi*0.5_wp 294 ! 295 zpsi_stab = -5._wp*zzeta 296 ! 297 zstab = 0.5_wp + SIGN(0.5_wp, zzeta) ! zzeta > 0 => zstab = 1 298 ! 299 psi_m_ncar(ji,jj) = zstab * zpsi_stab & ! (zzeta > 0) Stable 300 & + (1._wp - zstab) * zpsi_unst ! (zzeta < 0) Unstable 301 ! 302 END DO 303 END DO 281 DO_2D_11_11 282 283 zzeta = pzeta(ji,jj) 284 ! 285 zx2 = SQRT( ABS(1._wp - 16._wp*zzeta) ) ! (1 - 16z)^0.5 286 zx2 = MAX( zx2 , 1._wp ) 287 zx = SQRT(zx2) ! (1 - 16z)^0.25 288 zpsi_unst = 2._wp*LOG( (1._wp + zx )*0.5_wp ) & 289 & + LOG( (1._wp + zx2)*0.5_wp ) & 290 & - 2._wp*ATAN(zx) + rpi*0.5_wp 291 ! 292 zpsi_stab = -5._wp*zzeta 293 ! 294 zstab = 0.5_wp + SIGN(0.5_wp, zzeta) ! zzeta > 0 => zstab = 1 295 ! 296 psi_m_ncar(ji,jj) = zstab * zpsi_stab & ! (zzeta > 0) Stable 297 & + (1._wp - zstab) * zpsi_unst ! (zzeta < 0) Unstable 298 ! 299 END_2D 304 300 END FUNCTION psi_m_ncar 305 301 … … 322 318 !!---------------------------------------------------------------------------------- 323 319 ! 324 DO jj = 1, jpj 325 DO ji = 1, jpi 326 ! 327 zzeta = pzeta(ji,jj) 328 ! 329 zx2 = SQRT( ABS(1._wp - 16._wp*zzeta) ) ! (1 -16z)^0.5 330 zx2 = MAX( zx2 , 1._wp ) 331 zpsi_unst = 2._wp*LOG( 0.5_wp*(1._wp + zx2) ) 332 ! 333 zpsi_stab = -5._wp*zzeta 334 ! 335 zstab = 0.5_wp + SIGN(0.5_wp, zzeta) ! zzeta > 0 => zstab = 1 336 ! 337 psi_h_ncar(ji,jj) = zstab * zpsi_stab & ! (zzeta > 0) Stable 338 & + (1._wp - zstab) * zpsi_unst ! (zzeta < 0) Unstable 339 ! 340 END DO 341 END DO 320 DO_2D_11_11 321 ! 322 zzeta = pzeta(ji,jj) 323 ! 324 zx2 = SQRT( ABS(1._wp - 16._wp*zzeta) ) ! (1 -16z)^0.5 325 zx2 = MAX( zx2 , 1._wp ) 326 zpsi_unst = 2._wp*LOG( 0.5_wp*(1._wp + zx2) ) 327 ! 328 zpsi_stab = -5._wp*zzeta 329 ! 330 zstab = 0.5_wp + SIGN(0.5_wp, zzeta) ! zzeta > 0 => zstab = 1 331 ! 332 psi_h_ncar(ji,jj) = zstab * zpsi_stab & ! (zzeta > 0) Stable 333 & + (1._wp - zstab) * zpsi_unst ! (zzeta < 0) Unstable 334 ! 335 END_2D 342 336 END FUNCTION psi_h_ncar 343 337 … … 382 376 !!------------------------------------------------------------------- 383 377 ! 384 DO jj = 1, jpj 385 DO ji = 1, jpi 386 ! 387 zqa = (1._wp + rctv0*pqa(ji,jj)) 388 ! 389 ! The main concern is to know whether, the vertical turbulent flux of virtual temperature, < u' theta_v' > is estimated with: 390 ! a/ -u* [ theta* (1 + 0.61 q) + 0.61 theta q* ] => this is the one that seems correct! chose this one! 391 ! or 392 ! b/ -u* [ theta* + 0.61 theta q* ] 393 ! 394 One_on_L(ji,jj) = grav*vkarmn*( pts(ji,jj)*zqa + rctv0*ptha(ji,jj)*pqs(ji,jj) ) & 395 & / MAX( pus(ji,jj)*pus(ji,jj)*ptha(ji,jj)*zqa , 1.E-9_wp ) 396 ! 397 END DO 398 END DO 378 DO_2D_11_11 379 ! 380 zqa = (1._wp + rctv0*pqa(ji,jj)) 381 ! 382 ! The main concern is to know whether, the vertical turbulent flux of virtual temperature, < u' theta_v' > is estimated with: 383 ! a/ -u* [ theta* (1 + 0.61 q) + 0.61 theta q* ] => this is the one that seems correct! chose this one! 384 ! or 385 ! b/ -u* [ theta* + 0.61 theta q* ] 386 ! 387 One_on_L(ji,jj) = grav*vkarmn*( pts(ji,jj)*zqa + rctv0*ptha(ji,jj)*pqs(ji,jj) ) & 388 & / MAX( pus(ji,jj)*pus(ji,jj)*ptha(ji,jj)*zqa , 1.E-9_wp ) 389 ! 390 END_2D 399 391 ! 400 392 One_on_L = SIGN( MIN(ABS(One_on_L),200._wp), One_on_L ) ! (prevent FPE from stupid values over masked regions...) -
NEMO/branches/2020/temporary_r4_trunk/src/OCE/SBC/sbccpl.F90
r13467 r13469 1193 1193 ! 1194 1194 IF( srcv(jpr_otx1)%clgrid == 'T' ) THEN 1195 DO jj = 2, jpjm1 ! T ==> (U,V) 1196 DO ji = fs_2, fs_jpim1 ! vector opt. 1197 frcv(jpr_otx1)%z3(ji,jj,1) = 0.5 * ( frcv(jpr_otx1)%z3(ji+1,jj ,1) + frcv(jpr_otx1)%z3(ji,jj,1) ) 1198 frcv(jpr_oty1)%z3(ji,jj,1) = 0.5 * ( frcv(jpr_oty1)%z3(ji ,jj+1,1) + frcv(jpr_oty1)%z3(ji,jj,1) ) 1199 END DO 1200 END DO 1195 DO_2D_00_00 1196 frcv(jpr_otx1)%z3(ji,jj,1) = 0.5 * ( frcv(jpr_otx1)%z3(ji+1,jj ,1) + frcv(jpr_otx1)%z3(ji,jj,1) ) 1197 frcv(jpr_oty1)%z3(ji,jj,1) = 0.5 * ( frcv(jpr_oty1)%z3(ji ,jj+1,1) + frcv(jpr_oty1)%z3(ji,jj,1) ) 1198 END_2D 1201 1199 CALL lbc_lnk_multi( 'sbccpl', frcv(jpr_otx1)%z3(:,:,1), 'U', -1., frcv(jpr_oty1)%z3(:,:,1), 'V', -1. ) 1202 1200 ENDIF … … 1219 1217 ! => need to be done only when otx1 was changed 1220 1218 IF( llnewtx ) THEN 1221 DO jj = 2, jpjm1 1222 DO ji = fs_2, fs_jpim1 ! vect. opt. 1223 zzx = frcv(jpr_otx1)%z3(ji-1,jj ,1) + frcv(jpr_otx1)%z3(ji,jj,1) 1224 zzy = frcv(jpr_oty1)%z3(ji ,jj-1,1) + frcv(jpr_oty1)%z3(ji,jj,1) 1225 frcv(jpr_taum)%z3(ji,jj,1) = 0.5 * SQRT( zzx * zzx + zzy * zzy ) 1226 END DO 1227 END DO 1219 DO_2D_00_00 1220 zzx = frcv(jpr_otx1)%z3(ji-1,jj ,1) + frcv(jpr_otx1)%z3(ji,jj,1) 1221 zzy = frcv(jpr_oty1)%z3(ji ,jj-1,1) + frcv(jpr_oty1)%z3(ji,jj,1) 1222 frcv(jpr_taum)%z3(ji,jj,1) = 0.5 * SQRT( zzx * zzx + zzy * zzy ) 1223 END_2D 1228 1224 CALL lbc_lnk( 'sbccpl', frcv(jpr_taum)%z3(:,:,1), 'T', 1. ) 1229 1225 llnewtau = .TRUE. … … 1246 1242 IF( llnewtau ) THEN 1247 1243 zcoef = 1. / ( zrhoa * zcdrag ) 1248 DO jj = 1, jpj 1249 DO ji = 1, jpi 1250 frcv(jpr_w10m)%z3(ji,jj,1) = SQRT( frcv(jpr_taum)%z3(ji,jj,1) * zcoef ) 1251 END DO 1252 END DO 1244 DO_2D_11_11 1245 frcv(jpr_w10m)%z3(ji,jj,1) = SQRT( frcv(jpr_taum)%z3(ji,jj,1) * zcoef ) 1246 END_2D 1253 1247 ENDIF 1254 1248 ENDIF … … 1389 1383 IF( srcv(jpr_ocx1)%laction ) THEN ! received by sas in case of opa <-> sas coupling 1390 1384 ssu_m(:,:) = frcv(jpr_ocx1)%z3(:,:,1) 1391 u b (:,:,1) = ssu_m(:,:) ! will be used in icestp in the call of ice_forcing_tau1392 u n (:,:,1) = ssu_m(:,:) ! will be used in sbc_cpl_snd if atmosphere coupling1385 uu (:,:,1,Nnn) = ssu_m(:,:) ! will be used in icestp in the call of ice_forcing_tau 1386 uu (:,:,1,Nii) = ssu_m(:,:) ! will be used in sbc_cpl_snd if atmosphere coupling 1393 1387 CALL iom_put( 'ssu_m', ssu_m ) 1394 1388 ENDIF 1395 1389 IF( srcv(jpr_ocy1)%laction ) THEN 1396 1390 ssv_m(:,:) = frcv(jpr_ocy1)%z3(:,:,1) 1397 v b (:,:,1) = ssv_m(:,:) ! will be used in icestp in the call of ice_forcing_tau1398 v n (:,:,1) = ssv_m(:,:) ! will be used in sbc_cpl_snd if atmosphere coupling1391 vv (:,:,1,Nnn) = ssv_m(:,:) ! will be used in icestp in the call of ice_forcing_tau 1392 vv (:,:,1,Nii) = ssv_m(:,:) ! will be used in sbc_cpl_snd if atmosphere coupling 1399 1393 CALL iom_put( 'ssv_m', ssv_m ) 1400 1394 ENDIF … … 1586 1580 p_tauj(:,:) = frcv(jpr_ity1)%z3(:,:,1) 1587 1581 CASE( 'T' ) 1588 DO jj = 2, jpjm1 ! T ==> (U,V) 1589 DO ji = fs_2, fs_jpim1 ! vector opt. 1590 ! take care of the land-sea mask to avoid "pollution" of coastal stress. p[uv]taui used in frazil and rheology 1591 zztmp1 = 0.5_wp * ( 2. - umask(ji,jj,1) ) * MAX( tmask(ji,jj,1),tmask(ji+1,jj ,1) ) 1592 zztmp2 = 0.5_wp * ( 2. - vmask(ji,jj,1) ) * MAX( tmask(ji,jj,1),tmask(ji ,jj+1,1) ) 1593 p_taui(ji,jj) = zztmp1 * ( frcv(jpr_itx1)%z3(ji+1,jj ,1) + frcv(jpr_itx1)%z3(ji,jj,1) ) 1594 p_tauj(ji,jj) = zztmp2 * ( frcv(jpr_ity1)%z3(ji ,jj+1,1) + frcv(jpr_ity1)%z3(ji,jj,1) ) 1595 END DO 1596 END DO 1582 DO_2D_00_00 1583 ! take care of the land-sea mask to avoid "pollution" of coastal stress. p[uv]taui used in frazil and rheology 1584 zztmp1 = 0.5_wp * ( 2. - umask(ji,jj,1) ) * MAX( tmask(ji,jj,1),tmask(ji+1,jj ,1) ) 1585 zztmp2 = 0.5_wp * ( 2. - vmask(ji,jj,1) ) * MAX( tmask(ji,jj,1),tmask(ji ,jj+1,1) ) 1586 p_taui(ji,jj) = zztmp1 * ( frcv(jpr_itx1)%z3(ji+1,jj ,1) + frcv(jpr_itx1)%z3(ji,jj,1) ) 1587 p_tauj(ji,jj) = zztmp2 * ( frcv(jpr_ity1)%z3(ji ,jj+1,1) + frcv(jpr_ity1)%z3(ji,jj,1) ) 1588 END_2D 1597 1589 CALL lbc_lnk_multi( 'sbccpl', p_taui, 'U', -1., p_tauj, 'V', -1. ) 1598 1590 END SELECT … … 2466 2458 ! i i+1 (for I) 2467 2459 IF( nn_components == jp_iam_opa ) THEN 2468 zotx1(:,:) = u n(:,:,1)2469 zoty1(:,:) = v n(:,:,1)2460 zotx1(:,:) = uu(:,:,1,Nii) 2461 zoty1(:,:) = vv(:,:,1,Nii) 2470 2462 ELSE 2471 2463 SELECT CASE( TRIM( sn_snd_crt%cldes ) ) 2472 2464 CASE( 'oce only' ) ! C-grid ==> T 2473 DO jj = 2, jpjm1 2474 DO ji = fs_2, fs_jpim1 ! vector opt. 2475 zotx1(ji,jj) = 0.5 * ( un(ji,jj,1) + un(ji-1,jj ,1) ) 2476 zoty1(ji,jj) = 0.5 * ( vn(ji,jj,1) + vn(ji ,jj-1,1) ) 2477 END DO 2478 END DO 2465 DO_2D_00_00 2466 zotx1(ji,jj) = 0.5 * ( uu(ji,jj,1,Nii) + uu(ji-1,jj ,1,Nii) ) 2467 zoty1(ji,jj) = 0.5 * ( vv(ji,jj,1,Nii) + vv(ji ,jj-1,1,Nii) ) 2468 END_2D 2479 2469 CASE( 'weighted oce and ice' ) ! Ocean and Ice on C-grid ==> T 2480 DO jj = 2, jpjm1 2481 DO ji = fs_2, fs_jpim1 ! vector opt. 2482 zotx1(ji,jj) = 0.5 * ( un (ji,jj,1) + un (ji-1,jj ,1) ) * zfr_l(ji,jj) 2483 zoty1(ji,jj) = 0.5 * ( vn (ji,jj,1) + vn (ji ,jj-1,1) ) * zfr_l(ji,jj) 2484 zitx1(ji,jj) = 0.5 * ( u_ice(ji,jj ) + u_ice(ji-1,jj ) ) * fr_i(ji,jj) 2485 zity1(ji,jj) = 0.5 * ( v_ice(ji,jj ) + v_ice(ji ,jj-1 ) ) * fr_i(ji,jj) 2486 END DO 2487 END DO 2470 DO_2D_00_00 2471 zotx1(ji,jj) = 0.5 * ( uu (ji,jj,1,Nii) + uu (ji-1,jj ,1,Nii) ) * zfr_l(ji,jj) 2472 zoty1(ji,jj) = 0.5 * ( vv (ji,jj,1,Nii) + vv (ji ,jj-1,1,Nii) ) * zfr_l(ji,jj) 2473 zitx1(ji,jj) = 0.5 * ( u_ice(ji,jj ) + u_ice(ji-1,jj ) ) * fr_i(ji,jj) 2474 zity1(ji,jj) = 0.5 * ( v_ice(ji,jj ) + v_ice(ji ,jj-1 ) ) * fr_i(ji,jj) 2475 END_2D 2488 2476 CALL lbc_lnk_multi( 'sbccpl', zitx1, 'T', -1., zity1, 'T', -1. ) 2489 2477 CASE( 'mixed oce-ice' ) ! Ocean and Ice on C-grid ==> T 2490 DO jj = 2, jpjm1 2491 DO ji = fs_2, fs_jpim1 ! vector opt. 2492 zotx1(ji,jj) = 0.5 * ( un (ji,jj,1) + un (ji-1,jj ,1) ) * zfr_l(ji,jj) & 2493 & + 0.5 * ( u_ice(ji,jj ) + u_ice(ji-1,jj ) ) * fr_i(ji,jj) 2494 zoty1(ji,jj) = 0.5 * ( vn (ji,jj,1) + vn (ji ,jj-1,1) ) * zfr_l(ji,jj) & 2495 & + 0.5 * ( v_ice(ji,jj ) + v_ice(ji ,jj-1 ) ) * fr_i(ji,jj) 2496 END DO 2497 END DO 2478 DO_2D_00_00 2479 zotx1(ji,jj) = 0.5 * ( uu (ji,jj,1,Nii) + uu (ji-1,jj ,1,Nii) ) * zfr_l(ji,jj) & 2480 & + 0.5 * ( u_ice(ji,jj ) + u_ice(ji-1,jj ) ) * fr_i(ji,jj) 2481 zoty1(ji,jj) = 0.5 * ( vv (ji,jj,1,Nii) + vv (ji ,jj-1,1,Nii) ) * zfr_l(ji,jj) & 2482 & + 0.5 * ( v_ice(ji,jj ) + v_ice(ji ,jj-1 ) ) * fr_i(ji,jj) 2483 END_2D 2498 2484 END SELECT 2499 2485 CALL lbc_lnk_multi( 'sbccpl', zotx1, ssnd(jps_ocx1)%clgrid, -1., zoty1, ssnd(jps_ocy1)%clgrid, -1. ) … … 2554 2540 SELECT CASE( TRIM( sn_snd_crtw%cldes ) ) 2555 2541 CASE( 'oce only' ) ! C-grid ==> T 2556 DO jj = 2, jpjm1 2557 DO ji = fs_2, fs_jpim1 ! vector opt. 2558 zotx1(ji,jj) = 0.5 * ( un(ji,jj,1) + un(ji-1,jj ,1) ) 2559 zoty1(ji,jj) = 0.5 * ( vn(ji,jj,1) + vn(ji , jj-1,1) ) 2560 END DO 2561 END DO 2542 DO_2D_00_00 2543 zotx1(ji,jj) = 0.5 * ( uu(ji,jj,1,Nii) + uu(ji-1,jj ,1,Nii) ) 2544 zoty1(ji,jj) = 0.5 * ( vv(ji,jj,1,Nii) + vv(ji , jj-1,1,Nii) ) 2545 END_2D 2562 2546 CASE( 'weighted oce and ice' ) ! Ocean and Ice on C-grid ==> T 2563 DO jj = 2, jpjm1 2564 DO ji = fs_2, fs_jpim1 ! vector opt. 2565 zotx1(ji,jj) = 0.5 * ( un (ji,jj,1) + un (ji-1,jj ,1) ) * zfr_l(ji,jj) 2566 zoty1(ji,jj) = 0.5 * ( vn (ji,jj,1) + vn (ji ,jj-1,1) ) * zfr_l(ji,jj) 2567 zitx1(ji,jj) = 0.5 * ( u_ice(ji,jj ) + u_ice(ji-1,jj ) ) * fr_i(ji,jj) 2568 zity1(ji,jj) = 0.5 * ( v_ice(ji,jj ) + v_ice(ji ,jj-1 ) ) * fr_i(ji,jj) 2569 END DO 2570 END DO 2547 DO_2D_00_00 2548 zotx1(ji,jj) = 0.5 * ( uu (ji,jj,1,Nii) + uu (ji-1,jj ,1,Nii) ) * zfr_l(ji,jj) 2549 zoty1(ji,jj) = 0.5 * ( vv (ji,jj,1,Nii) + vv (ji ,jj-1,1,Nii) ) * zfr_l(ji,jj) 2550 zitx1(ji,jj) = 0.5 * ( u_ice(ji,jj ) + u_ice(ji-1,jj ) ) * fr_i(ji,jj) 2551 zity1(ji,jj) = 0.5 * ( v_ice(ji,jj ) + v_ice(ji ,jj-1 ) ) * fr_i(ji,jj) 2552 END_2D 2571 2553 CALL lbc_lnk_multi( 'sbccpl', zitx1, 'T', -1., zity1, 'T', -1. ) 2572 2554 CASE( 'mixed oce-ice' ) ! Ocean and Ice on C-grid ==> T 2573 DO jj = 2, jpjm1 2574 DO ji = fs_2, fs_jpim1 ! vector opt. 2575 zotx1(ji,jj) = 0.5 * ( un (ji,jj,1) + un (ji-1,jj ,1) ) * zfr_l(ji,jj) & 2576 & + 0.5 * ( u_ice(ji,jj ) + u_ice(ji-1,jj ) ) * fr_i(ji,jj) 2577 zoty1(ji,jj) = 0.5 * ( vn (ji,jj,1) + vn (ji ,jj-1,1) ) * zfr_l(ji,jj) & 2578 & + 0.5 * ( v_ice(ji,jj ) + v_ice(ji ,jj-1 ) ) * fr_i(ji,jj) 2579 END DO 2580 END DO 2555 DO_2D_00_00 2556 zotx1(ji,jj) = 0.5 * ( uu (ji,jj,1,Nii) + uu (ji-1,jj ,1,Nii) ) * zfr_l(ji,jj) & 2557 & + 0.5 * ( u_ice(ji,jj ) + u_ice(ji-1,jj ) ) * fr_i(ji,jj) 2558 zoty1(ji,jj) = 0.5 * ( vv (ji,jj,1,Nii) + vv (ji ,jj-1,1,Nii) ) * zfr_l(ji,jj) & 2559 & + 0.5 * ( v_ice(ji,jj ) + v_ice(ji ,jj-1 ) ) * fr_i(ji,jj) 2560 END_2D 2581 2561 END SELECT 2582 2562 CALL lbc_lnk_multi( 'sbccpl', zotx1, ssnd(jps_ocxw)%clgrid, -1., zoty1, ssnd(jps_ocyw)%clgrid, -1. ) -
NEMO/branches/2020/temporary_r4_trunk/src/OCE/ZDF/zdfdrg.F90
r13466 r13469 115 115 ! 116 116 IF( l_log_not_linssh ) THEN !== "log layer" ==! compute Cd and -Cd*|U| 117 DO jj = 2, jpjm1 118 DO ji = 2, jpim1 119 imk = k_mk(ji,jj) ! ocean bottom level at t-points 120 zut = un(ji,jj,imk) + un(ji-1,jj,imk) ! 2 x velocity at t-point 121 zvt = vn(ji,jj,imk) + vn(ji,jj-1,imk) 122 zzz = 0.5_wp * e3t_n(ji,jj,imk) ! altitude below/above (top/bottom) the boundary 123 ! 117 DO_2D_00_00 118 imk = k_mk(ji,jj) ! ocean bottom level at t-points 119 zut = uu(ji,jj,imk,Nii) + uu(ji-1,jj,imk,Nii) ! 2 x velocity at t-point 120 zvt = vv(ji,jj,imk,Nii) + vv(ji,jj-1,imk,Nii) 121 zzz = 0.5_wp * e3t_n(ji,jj,imk) ! altitude below/above (top/bottom) the boundary 122 ! 124 123 !!JC: possible WAD implementation should modify line below if layers vanish 125 zcd = ( vkarmn / LOG( zzz / pz0 ) )**2 126 zcd = pCd0(ji,jj) * MIN( MAX( pCdmin , zcd ) , pCdmax ) ! here pCd0 = mask*boost 127 pCdU(ji,jj) = - zcd * SQRT( 0.25 * ( zut*zut + zvt*zvt ) + pke0 ) 128 END DO 129 END DO 124 zcd = ( vkarmn / LOG( zzz / pz0 ) )**2 125 zcd = pCd0(ji,jj) * MIN( MAX( pCdmin , zcd ) , pCdmax ) ! here pCd0 = mask*boost 126 pCdU(ji,jj) = - zcd * SQRT( 0.25 * ( zut*zut + zvt*zvt ) + pke0 ) 127 END_2D 130 128 ELSE !== standard Cd ==! 131 DO jj = 2, jpjm1 132 DO ji = 2, jpim1 133 imk = k_mk(ji,jj) ! ocean bottom level at t-points 134 zut = un(ji,jj,imk) + un(ji-1,jj,imk) ! 2 x velocity at t-point 135 zvt = vn(ji,jj,imk) + vn(ji,jj-1,imk) 136 ! ! here pCd0 = mask*boost * drag 137 pCdU(ji,jj) = - pCd0(ji,jj) * SQRT( 0.25 * ( zut*zut + zvt*zvt ) + pke0 ) 138 END DO 139 END DO 129 DO_2D_00_00 130 imk = k_mk(ji,jj) ! ocean bottom level at t-points 131 zut = uu(ji,jj,imk,Nii) + uu(ji-1,jj,imk,Nii) ! 2 x velocity at t-point 132 zvt = vv(ji,jj,imk,Nii) + vv(ji,jj-1,imk,Nii) 133 ! ! here pCd0 = mask*boost * drag 134 pCdU(ji,jj) = - pCd0(ji,jj) * SQRT( 0.25 * ( zut*zut + zvt*zvt ) + pke0 ) 135 END_2D 140 136 ENDIF 141 137 ! … … 177 173 ENDIF 178 174 179 DO jj = 2, jpjm1 180 DO ji = 2, jpim1 181 ikbu = mbku(ji,jj) ! deepest wet ocean u- & v-levels 182 ikbv = mbkv(ji,jj) 175 DO_2D_00_00 176 ikbu = mbku(ji,jj) ! deepest wet ocean u- & v-levels 177 ikbv = mbkv(ji,jj) 178 ! 179 ! Apply stability criteria on absolute value : abs(bfr/e3) < 1/(2dt) => bfr/e3 > -1/(2dt) 180 zCdu = 0.5*( rCdU_bot(ji+1,jj)+rCdU_bot(ji,jj) ) / e3u_n(ji,jj,ikbu) 181 zCdv = 0.5*( rCdU_bot(ji,jj+1)+rCdU_bot(ji,jj) ) / e3v_n(ji,jj,ikbv) 182 ! 183 pua(ji,jj,ikbu) = pua(ji,jj,ikbu) + MAX( zCdu , zm1_2dt ) * pub(ji,jj,ikbu) 184 pva(ji,jj,ikbv) = pva(ji,jj,ikbv) + MAX( zCdv , zm1_2dt ) * pvb(ji,jj,ikbv) 185 END_2D 186 ! 187 IF( ln_isfcav ) THEN ! ocean cavities 188 DO_2D_00_00 189 ikbu = miku(ji,jj) ! first wet ocean u- & v-levels 190 ikbv = mikv(ji,jj) 183 191 ! 184 192 ! Apply stability criteria on absolute value : abs(bfr/e3) < 1/(2dt) => bfr/e3 > -1/(2dt) 185 zCdu = 0.5*( rCdU_ bot(ji+1,jj)+rCdU_bot(ji,jj) ) / e3u_n(ji,jj,ikbu)186 zCdv = 0.5*( rCdU_ bot(ji,jj+1)+rCdU_bot(ji,jj) ) / e3v_n(ji,jj,ikbv)193 zCdu = 0.5*( rCdU_top(ji+1,jj)+rCdU_top(ji,jj) ) / e3u_n(ji,jj,ikbu) ! NB: Cdtop masked 194 zCdv = 0.5*( rCdU_top(ji,jj+1)+rCdU_top(ji,jj) ) / e3v_n(ji,jj,ikbv) 187 195 ! 188 196 pua(ji,jj,ikbu) = pua(ji,jj,ikbu) + MAX( zCdu , zm1_2dt ) * pub(ji,jj,ikbu) 189 197 pva(ji,jj,ikbv) = pva(ji,jj,ikbv) + MAX( zCdv , zm1_2dt ) * pvb(ji,jj,ikbv) 190 END DO 191 END DO 192 ! 193 IF( ln_isfcav ) THEN ! ocean cavities 194 DO jj = 2, jpjm1 195 DO ji = 2, jpim1 196 ikbu = miku(ji,jj) ! first wet ocean u- & v-levels 197 ikbv = mikv(ji,jj) 198 ! 199 ! Apply stability criteria on absolute value : abs(bfr/e3) < 1/(2dt) => bfr/e3 > -1/(2dt) 200 zCdu = 0.5*( rCdU_top(ji+1,jj)+rCdU_top(ji,jj) ) / e3u_n(ji,jj,ikbu) ! NB: Cdtop masked 201 zCdv = 0.5*( rCdU_top(ji,jj+1)+rCdU_top(ji,jj) ) / e3v_n(ji,jj,ikbv) 202 ! 203 pua(ji,jj,ikbu) = pua(ji,jj,ikbu) + MAX( zCdu , zm1_2dt ) * pub(ji,jj,ikbu) 204 pva(ji,jj,ikbv) = pva(ji,jj,ikbv) + MAX( zCdv , zm1_2dt ) * pvb(ji,jj,ikbv) 205 END DO 206 END DO 198 END_2D 207 199 ENDIF 208 200 ! … … 442 434 l_log_not_linssh = .FALSE. !- don't update Cd at each time step 443 435 ! 444 DO jj = 1, jpj ! pCd0 = mask (and boosted) logarithmic drag coef. 445 DO ji = 1, jpi 446 zzz = 0.5_wp * e3t_0(ji,jj,k_mk(ji,jj)) 447 zcd = ( vkarmn / LOG( zzz / rn_z0 ) )**2 448 pCd0(ji,jj) = zmsk_boost(ji,jj) * MIN( MAX( rn_Cd0 , zcd ) , rn_Cdmax ) ! rn_Cd0 < Cd0 < rn_Cdmax 449 END DO 450 END DO 436 DO_2D_11_11 437 zzz = 0.5_wp * e3t_0(ji,jj,k_mk(ji,jj)) 438 zcd = ( vkarmn / LOG( zzz / rn_z0 ) )**2 439 pCd0(ji,jj) = zmsk_boost(ji,jj) * MIN( MAX( rn_Cd0 , zcd ) , rn_Cdmax ) ! rn_Cd0 < Cd0 < rn_Cdmax 440 END_2D 451 441 ELSE !* Cd updated at each time-step ==> pCd0 = mask * boost 452 442 IF(lwp) WRITE(numout,*) -
NEMO/branches/2020/temporary_r4_trunk/src/OCE/ZDF/zdfgls.F90
r13466 r13469 177 177 178 178 ! Compute surface, top and bottom friction at T-points 179 DO jj = 2, jpjm1 !== surface ocean friction 180 DO ji = fs_2, fs_jpim1 ! vector opt. 181 ustar2_surf(ji,jj) = r1_rau0 * taum(ji,jj) * tmask(ji,jj,1) 182 END DO 183 END DO 179 DO_2D_00_00 180 ustar2_surf(ji,jj) = r1_rau0 * taum(ji,jj) * tmask(ji,jj,1) 181 END_2D 184 182 ! 185 183 !!gm Rq we may add here r_ke0(_top/_bot) ? ==>> think about that... 186 184 ! 187 185 IF( .NOT.ln_drg_OFF ) THEN !== top/bottom friction (explicit before friction) 188 DO jj = 2, jpjm1 ! bottom friction 189 DO ji = fs_2, fs_jpim1 ! vector opt. 190 zmsku = ( 2._wp - umask(ji-1,jj,mbkt(ji,jj)) * umask(ji,jj,mbkt(ji,jj)) ) 191 zmskv = ( 2._wp - vmask(ji,jj-1,mbkt(ji,jj)) * vmask(ji,jj,mbkt(ji,jj)) ) ! (CAUTION: CdU<0) 192 ustar2_bot(ji,jj) = - rCdU_bot(ji,jj) * SQRT( ( zmsku*( ub(ji,jj,mbkt(ji,jj))+ub(ji-1,jj,mbkt(ji,jj)) ) )**2 & 193 & + ( zmskv*( vb(ji,jj,mbkt(ji,jj))+vb(ji,jj-1,mbkt(ji,jj)) ) )**2 ) 194 END DO 195 END DO 186 DO_2D_00_00 187 zmsku = ( 2._wp - umask(ji-1,jj,mbkt(ji,jj)) * umask(ji,jj,mbkt(ji,jj)) ) 188 zmskv = ( 2._wp - vmask(ji,jj-1,mbkt(ji,jj)) * vmask(ji,jj,mbkt(ji,jj)) ) ! (CAUTION: CdU<0) 189 ustar2_bot(ji,jj) = - rCdU_bot(ji,jj) * SQRT( ( zmsku*( uu(ji,jj,mbkt(ji,jj),Nnn)+uu(ji-1,jj,mbkt(ji,jj),Nnn) ) )**2 & 190 & + ( zmskv*( vv(ji,jj,mbkt(ji,jj),Nnn)+vv(ji,jj-1,mbkt(ji,jj),Nnn) ) )**2 ) 191 END_2D 196 192 IF( ln_isfcav ) THEN !top friction 197 DO jj = 2, jpjm1 198 DO ji = fs_2, fs_jpim1 ! vector opt. 199 zmsku = ( 2._wp - umask(ji-1,jj,mikt(ji,jj)) * umask(ji,jj,mikt(ji,jj)) ) 200 zmskv = ( 2._wp - vmask(ji,jj-1,mikt(ji,jj)) * vmask(ji,jj,mikt(ji,jj)) ) ! (CAUTION: CdU<0) 201 ustar2_top(ji,jj) = - rCdU_top(ji,jj) * SQRT( ( zmsku*( ub(ji,jj,mikt(ji,jj))+ub(ji-1,jj,mikt(ji,jj)) ) )**2 & 202 & + ( zmskv*( vb(ji,jj,mikt(ji,jj))+vb(ji,jj-1,mikt(ji,jj)) ) )**2 ) 203 END DO 204 END DO 193 DO_2D_00_00 194 zmsku = ( 2._wp - umask(ji-1,jj,mikt(ji,jj)) * umask(ji,jj,mikt(ji,jj)) ) 195 zmskv = ( 2._wp - vmask(ji,jj-1,mikt(ji,jj)) * vmask(ji,jj,mikt(ji,jj)) ) ! (CAUTION: CdU<0) 196 ustar2_top(ji,jj) = - rCdU_top(ji,jj) * SQRT( ( zmsku*( uu(ji,jj,mikt(ji,jj),Nnn)+uu(ji-1,jj,mikt(ji,jj),Nnn) ) )**2 & 197 & + ( zmskv*( vv(ji,jj,mikt(ji,jj),Nnn)+vv(ji,jj-1,mikt(ji,jj),Nnn) ) )**2 ) 198 END_2D 205 199 ENDIF 206 200 ENDIF … … 224 218 zhsro(:,:) = ( (1._wp-zice_fra(:,:)) * zhsro(:,:) + zice_fra(:,:) * rn_hsri )*tmask(:,:,1) + (1._wp - tmask(:,:,1))*rn_hsro 225 219 ! 226 DO jk = 2, jpkm1 !== Compute dissipation rate ==! 227 DO jj = 1, jpjm1 228 DO ji = 1, jpim1 229 eps(ji,jj,jk) = rc03 * en(ji,jj,jk) * SQRT( en(ji,jj,jk) ) / hmxl_n(ji,jj,jk) 230 END DO 231 END DO 232 END DO 220 DO_3D_10_10( 2, jpkm1 ) 221 eps(ji,jj,jk) = rc03 * en(ji,jj,jk) * SQRT( en(ji,jj,jk) ) / hmxl_n(ji,jj,jk) 222 END_3D 233 223 234 224 ! Save tke at before time step … … 237 227 238 228 IF( nn_clos == 0 ) THEN ! Mellor-Yamada 239 DO jk = 2, jpkm1 240 DO jj = 2, jpjm1 241 DO ji = fs_2, fs_jpim1 ! vector opt. 242 zup = hmxl_n(ji,jj,jk) * gdepw_n(ji,jj,mbkt(ji,jj)+1) 243 zdown = vkarmn * gdepw_n(ji,jj,jk) * ( -gdepw_n(ji,jj,jk) + gdepw_n(ji,jj,mbkt(ji,jj)+1) ) 244 zcoef = ( zup / MAX( zdown, rsmall ) ) 245 zwall (ji,jj,jk) = ( 1._wp + re2 * zcoef*zcoef ) * tmask(ji,jj,jk) 246 END DO 247 END DO 248 END DO 229 DO_3D_00_00( 2, jpkm1 ) 230 zup = hmxl_n(ji,jj,jk) * gdepw_n(ji,jj,mbkt(ji,jj)+1) 231 zdown = vkarmn * gdepw_n(ji,jj,jk) * ( -gdepw_n(ji,jj,jk) + gdepw_n(ji,jj,mbkt(ji,jj)+1) ) 232 zcoef = ( zup / MAX( zdown, rsmall ) ) 233 zwall (ji,jj,jk) = ( 1._wp + re2 * zcoef*zcoef ) * tmask(ji,jj,jk) 234 END_3D 249 235 ENDIF 250 236 … … 262 248 ! Warning : after this step, en : right hand side of the matrix 263 249 264 DO jk = 2, jpkm1 265 DO jj = 2, jpjm1 266 DO ji = 2, jpim1 267 ! 268 buoy = - p_avt(ji,jj,jk) * rn2(ji,jj,jk) ! stratif. destruction 269 ! 270 diss = eps(ji,jj,jk) ! dissipation 271 ! 272 zdir = 0.5_wp + SIGN( 0.5_wp, p_sh2(ji,jj,jk) + buoy ) ! zdir =1(=0) if shear(ji,jj,jk)+buoy >0(<0) 273 ! 274 zesh2 = zdir*(p_sh2(ji,jj,jk)+buoy)+(1._wp-zdir)*p_sh2(ji,jj,jk) ! production term 275 zdiss = zdir*(diss/en(ji,jj,jk)) +(1._wp-zdir)*(diss-buoy)/en(ji,jj,jk) ! dissipation term 250 DO_3D_00_00( 2, jpkm1 ) 251 ! 252 buoy = - p_avt(ji,jj,jk) * rn2(ji,jj,jk) ! stratif. destruction 253 ! 254 diss = eps(ji,jj,jk) ! dissipation 255 ! 256 zdir = 0.5_wp + SIGN( 0.5_wp, p_sh2(ji,jj,jk) + buoy ) ! zdir =1(=0) if shear(ji,jj,jk)+buoy >0(<0) 257 ! 258 zesh2 = zdir*(p_sh2(ji,jj,jk)+buoy)+(1._wp-zdir)*p_sh2(ji,jj,jk) ! production term 259 zdiss = zdir*(diss/en(ji,jj,jk)) +(1._wp-zdir)*(diss-buoy)/en(ji,jj,jk) ! dissipation term 276 260 !!gm better coding, identical results 277 261 ! zesh2 = p_sh2(ji,jj,jk) + zdir*buoy ! production term 278 262 ! zdiss = ( diss - (1._wp-zdir)*buoy ) / en(ji,jj,jk) ! dissipation term 279 263 !!gm 280 ! 281 ! Compute a wall function from 1. to rsc_psi*zwall/rsc_psi0 282 ! Note that as long that Dirichlet boundary conditions are NOT set at the first and last levels (GOTM style) 283 ! there is no need to set a boundary condition for zwall_psi at the top and bottom boundaries. 284 ! Otherwise, this should be rsc_psi/rsc_psi0 285 IF( ln_sigpsi ) THEN 286 zsigpsi = MIN( 1._wp, zesh2 / eps(ji,jj,jk) ) ! 0. <= zsigpsi <= 1. 287 zwall_psi(ji,jj,jk) = rsc_psi / & 288 & ( zsigpsi * rsc_psi + (1._wp-zsigpsi) * rsc_psi0 / MAX( zwall(ji,jj,jk), 1._wp ) ) 289 ELSE 290 zwall_psi(ji,jj,jk) = 1._wp 291 ENDIF 292 ! 293 ! building the matrix 294 zcof = rfact_tke * tmask(ji,jj,jk) 295 ! ! lower diagonal, in fact not used for jk = 2 (see surface conditions) 296 zd_lw(ji,jj,jk) = zcof * ( p_avm(ji,jj,jk ) + p_avm(ji,jj,jk-1) ) / ( e3t_n(ji,jj,jk-1) * e3w_n(ji,jj,jk) ) 297 ! ! upper diagonal, in fact not used for jk = ibotm1 (see bottom conditions) 298 zd_up(ji,jj,jk) = zcof * ( p_avm(ji,jj,jk+1) + p_avm(ji,jj,jk ) ) / ( e3t_n(ji,jj,jk ) * e3w_n(ji,jj,jk) ) 299 ! ! diagonal 300 zdiag(ji,jj,jk) = 1._wp - zd_lw(ji,jj,jk) - zd_up(ji,jj,jk) + rdt * zdiss * wmask(ji,jj,jk) 301 ! ! right hand side in en 302 en(ji,jj,jk) = en(ji,jj,jk) + rdt * zesh2 * wmask(ji,jj,jk) 303 END DO 304 END DO 305 END DO 264 ! 265 ! Compute a wall function from 1. to rsc_psi*zwall/rsc_psi0 266 ! Note that as long that Dirichlet boundary conditions are NOT set at the first and last levels (GOTM style) 267 ! there is no need to set a boundary condition for zwall_psi at the top and bottom boundaries. 268 ! Otherwise, this should be rsc_psi/rsc_psi0 269 IF( ln_sigpsi ) THEN 270 zsigpsi = MIN( 1._wp, zesh2 / eps(ji,jj,jk) ) ! 0. <= zsigpsi <= 1. 271 zwall_psi(ji,jj,jk) = rsc_psi / & 272 & ( zsigpsi * rsc_psi + (1._wp-zsigpsi) * rsc_psi0 / MAX( zwall(ji,jj,jk), 1._wp ) ) 273 ELSE 274 zwall_psi(ji,jj,jk) = 1._wp 275 ENDIF 276 ! 277 ! building the matrix 278 zcof = rfact_tke * tmask(ji,jj,jk) 279 ! ! lower diagonal, in fact not used for jk = 2 (see surface conditions) 280 zd_lw(ji,jj,jk) = zcof * ( p_avm(ji,jj,jk ) + p_avm(ji,jj,jk-1) ) / ( e3t_n(ji,jj,jk-1) * e3w_n(ji,jj,jk) ) 281 ! ! upper diagonal, in fact not used for jk = ibotm1 (see bottom conditions) 282 zd_up(ji,jj,jk) = zcof * ( p_avm(ji,jj,jk+1) + p_avm(ji,jj,jk ) ) / ( e3t_n(ji,jj,jk ) * e3w_n(ji,jj,jk) ) 283 ! ! diagonal 284 zdiag(ji,jj,jk) = 1._wp - zd_lw(ji,jj,jk) - zd_up(ji,jj,jk) + rdt * zdiss * wmask(ji,jj,jk) 285 ! ! right hand side in en 286 en(ji,jj,jk) = en(ji,jj,jk) + rdt * zesh2 * wmask(ji,jj,jk) 287 END_3D 306 288 ! 307 289 zdiag(:,:,jpk) = 1._wp … … 360 342 ! ! en(ibot) = u*^2 / Co2 and hmxl_n(ibot) = rn_lmin 361 343 ! ! Balance between the production and the dissipation terms 362 DO jj = 2, jpjm1 363 DO ji = fs_2, fs_jpim1 ! vector opt. 344 DO_2D_00_00 364 345 !!gm This means that bottom and ocean w-level above have a specified "en" value. Sure ???? 365 346 !! With thick deep ocean level thickness, this may be quite large, no ??? 366 347 !! in particular in ocean cavities where top stratification can be large... 367 ibot = mbkt(ji,jj) + 1 ! k bottom level of w-point 368 ibotm1 = mbkt(ji,jj) ! k-1 bottom level of w-point but >=1 348 ibot = mbkt(ji,jj) + 1 ! k bottom level of w-point 349 ibotm1 = mbkt(ji,jj) ! k-1 bottom level of w-point but >=1 350 ! 351 z_en = MAX( rc02r * ustar2_bot(ji,jj), rn_emin ) 352 ! 353 ! Dirichlet condition applied at: 354 ! Bottom level (ibot) & Just above it (ibotm1) 355 zd_lw(ji,jj,ibot) = 0._wp ; zd_lw(ji,jj,ibotm1) = 0._wp 356 zd_up(ji,jj,ibot) = 0._wp ; zd_up(ji,jj,ibotm1) = 0._wp 357 zdiag(ji,jj,ibot) = 1._wp ; zdiag(ji,jj,ibotm1) = 1._wp 358 en (ji,jj,ibot) = z_en ; en (ji,jj,ibotm1) = z_en 359 END_2D 360 ! 361 IF( ln_isfcav) THEN ! top boundary (ocean cavity) 362 DO_2D_00_00 363 itop = mikt(ji,jj) ! k top w-point 364 itopp1 = mikt(ji,jj) + 1 ! k+1 1st w-point below the top one 365 ! ! mask at the ocean surface points 366 z_en = MAX( rc02r * ustar2_top(ji,jj), rn_emin ) * ( 1._wp - tmask(ji,jj,1) ) 369 367 ! 370 z_en = MAX( rc02r * ustar2_bot(ji,jj), rn_emin ) 371 ! 368 !!gm TO BE VERIFIED !!! 372 369 ! Dirichlet condition applied at: 373 ! Bottom level (ibot) & Just above it (ibotm1) 374 zd_lw(ji,jj,ibot) = 0._wp ; zd_lw(ji,jj,ibotm1) = 0._wp 375 zd_up(ji,jj,ibot) = 0._wp ; zd_up(ji,jj,ibotm1) = 0._wp 376 zdiag(ji,jj,ibot) = 1._wp ; zdiag(ji,jj,ibotm1) = 1._wp 377 en (ji,jj,ibot) = z_en ; en (ji,jj,ibotm1) = z_en 378 END DO 379 END DO 380 ! 381 IF( ln_isfcav) THEN ! top boundary (ocean cavity) 382 DO jj = 2, jpjm1 383 DO ji = fs_2, fs_jpim1 ! vector opt. 384 itop = mikt(ji,jj) ! k top w-point 385 itopp1 = mikt(ji,jj) + 1 ! k+1 1st w-point below the top one 386 ! ! mask at the ocean surface points 387 z_en = MAX( rc02r * ustar2_top(ji,jj), rn_emin ) * ( 1._wp - tmask(ji,jj,1) ) 388 ! 389 !!gm TO BE VERIFIED !!! 390 ! Dirichlet condition applied at: 391 ! top level (itop) & Just below it (itopp1) 392 zd_lw(ji,jj,itop) = 0._wp ; zd_lw(ji,jj,itopp1) = 0._wp 393 zd_up(ji,jj,itop) = 0._wp ; zd_up(ji,jj,itopp1) = 0._wp 394 zdiag(ji,jj,itop) = 1._wp ; zdiag(ji,jj,itopp1) = 1._wp 395 en (ji,jj,itop) = z_en ; en (ji,jj,itopp1) = z_en 396 END DO 397 END DO 370 ! top level (itop) & Just below it (itopp1) 371 zd_lw(ji,jj,itop) = 0._wp ; zd_lw(ji,jj,itopp1) = 0._wp 372 zd_up(ji,jj,itop) = 0._wp ; zd_up(ji,jj,itopp1) = 0._wp 373 zdiag(ji,jj,itop) = 1._wp ; zdiag(ji,jj,itopp1) = 1._wp 374 en (ji,jj,itop) = z_en ; en (ji,jj,itopp1) = z_en 375 END_2D 398 376 ENDIF 399 377 ! 400 378 CASE ( 1 ) ! Neumman boundary condition 401 379 ! 402 DO jj = 2, jpjm1 403 DO ji = fs_2, fs_jpim1 ! vector opt. 404 ibot = mbkt(ji,jj) + 1 ! k bottom level of w-point 405 ibotm1 = mbkt(ji,jj) ! k-1 bottom level of w-point but >=1 406 ! 407 z_en = MAX( rc02r * ustar2_bot(ji,jj), rn_emin ) 380 DO_2D_00_00 381 ibot = mbkt(ji,jj) + 1 ! k bottom level of w-point 382 ibotm1 = mbkt(ji,jj) ! k-1 bottom level of w-point but >=1 383 ! 384 z_en = MAX( rc02r * ustar2_bot(ji,jj), rn_emin ) 385 ! 386 ! Bottom level Dirichlet condition: 387 ! Bottom level (ibot) & Just above it (ibotm1) 388 ! Dirichlet ! Neumann 389 zd_lw(ji,jj,ibot) = 0._wp ! ! Remove zd_up from zdiag 390 zdiag(ji,jj,ibot) = 1._wp ; zdiag(ji,jj,ibotm1) = zdiag(ji,jj,ibotm1) + zd_up(ji,jj,ibotm1) 391 zd_up(ji,jj,ibot) = 0._wp ; zd_up(ji,jj,ibotm1) = 0._wp 392 END_2D 393 IF( ln_isfcav) THEN ! top boundary (ocean cavity) 394 DO_2D_00_00 395 itop = mikt(ji,jj) ! k top w-point 396 itopp1 = mikt(ji,jj) + 1 ! k+1 1st w-point below the top one 397 ! ! mask at the ocean surface points 398 z_en = MAX( rc02r * ustar2_top(ji,jj), rn_emin ) * ( 1._wp - tmask(ji,jj,1) ) 408 399 ! 409 400 ! Bottom level Dirichlet condition: 410 401 ! Bottom level (ibot) & Just above it (ibotm1) 411 402 ! Dirichlet ! Neumann 412 zd_lw(ji,jj,ibot) = 0._wp ! ! Remove zd_up from zdiag 413 zdiag(ji,jj,ibot) = 1._wp ; zdiag(ji,jj,ibotm1) = zdiag(ji,jj,ibotm1) + zd_up(ji,jj,ibotm1) 414 zd_up(ji,jj,ibot) = 0._wp ; zd_up(ji,jj,ibotm1) = 0._wp 415 END DO 416 END DO 417 IF( ln_isfcav) THEN ! top boundary (ocean cavity) 418 DO jj = 2, jpjm1 419 DO ji = fs_2, fs_jpim1 ! vector opt. 420 itop = mikt(ji,jj) ! k top w-point 421 itopp1 = mikt(ji,jj) + 1 ! k+1 1st w-point below the top one 422 ! ! mask at the ocean surface points 423 z_en = MAX( rc02r * ustar2_top(ji,jj), rn_emin ) * ( 1._wp - tmask(ji,jj,1) ) 424 ! 425 ! Bottom level Dirichlet condition: 426 ! Bottom level (ibot) & Just above it (ibotm1) 427 ! Dirichlet ! Neumann 428 zd_lw(ji,jj,itop) = 0._wp ! ! Remove zd_up from zdiag 429 zdiag(ji,jj,itop) = 1._wp ; zdiag(ji,jj,itopp1) = zdiag(ji,jj,itopp1) + zd_up(ji,jj,itopp1) 430 zd_up(ji,jj,itop) = 0._wp ; zd_up(ji,jj,itopp1) = 0._wp 431 END DO 432 END DO 403 zd_lw(ji,jj,itop) = 0._wp ! ! Remove zd_up from zdiag 404 zdiag(ji,jj,itop) = 1._wp ; zdiag(ji,jj,itopp1) = zdiag(ji,jj,itopp1) + zd_up(ji,jj,itopp1) 405 zd_up(ji,jj,itop) = 0._wp ; zd_up(ji,jj,itopp1) = 0._wp 406 END_2D 433 407 ENDIF 434 408 ! … … 438 412 ! ---------------------------------------------------------- 439 413 ! 440 DO jk = 2, jpkm1 ! First recurrence : Dk = Dk - Lk * Uk-1 / Dk-1 441 DO jj = 2, jpjm1 442 DO ji = fs_2, fs_jpim1 ! vector opt. 443 zdiag(ji,jj,jk) = zdiag(ji,jj,jk) - zd_lw(ji,jj,jk) * zd_up(ji,jj,jk-1) / zdiag(ji,jj,jk-1) 444 END DO 445 END DO 446 END DO 447 DO jk = 2, jpk ! Second recurrence : Lk = RHSk - Lk / Dk-1 * Lk-1 448 DO jj = 2, jpjm1 449 DO ji = fs_2, fs_jpim1 ! vector opt. 450 zd_lw(ji,jj,jk) = en(ji,jj,jk) - zd_lw(ji,jj,jk) / zdiag(ji,jj,jk-1) * zd_lw(ji,jj,jk-1) 451 END DO 452 END DO 453 END DO 454 DO jk = jpk-1, 2, -1 ! thrid recurrence : Ek = ( Lk - Uk * Ek+1 ) / Dk 455 DO jj = 2, jpjm1 456 DO ji = fs_2, fs_jpim1 ! vector opt. 457 en(ji,jj,jk) = ( zd_lw(ji,jj,jk) - zd_up(ji,jj,jk) * en(ji,jj,jk+1) ) / zdiag(ji,jj,jk) 458 END DO 459 END DO 460 END DO 414 DO_3D_00_00( 2, jpkm1 ) 415 zdiag(ji,jj,jk) = zdiag(ji,jj,jk) - zd_lw(ji,jj,jk) * zd_up(ji,jj,jk-1) / zdiag(ji,jj,jk-1) 416 END_3D 417 DO_3D_00_00( 2, jpk ) 418 zd_lw(ji,jj,jk) = en(ji,jj,jk) - zd_lw(ji,jj,jk) / zdiag(ji,jj,jk-1) * zd_lw(ji,jj,jk-1) 419 END_3D 420 DO_3D_00_00( jpk-1, 2, -1 ) 421 en(ji,jj,jk) = ( zd_lw(ji,jj,jk) - zd_up(ji,jj,jk) * en(ji,jj,jk+1) ) / zdiag(ji,jj,jk) 422 END_3D 461 423 ! ! set the minimum value of tke 462 424 en(:,:,:) = MAX( en(:,:,:), rn_emin ) … … 471 433 ! 472 434 CASE( 0 ) ! k-kl (Mellor-Yamada) 473 DO jk = 2, jpkm1 474 DO jj = 2, jpjm1 475 DO ji = fs_2, fs_jpim1 ! vector opt. 476 psi(ji,jj,jk) = eb(ji,jj,jk) * hmxl_b(ji,jj,jk) 477 END DO 478 END DO 479 END DO 435 DO_3D_00_00( 2, jpkm1 ) 436 psi(ji,jj,jk) = eb(ji,jj,jk) * hmxl_b(ji,jj,jk) 437 END_3D 480 438 ! 481 439 CASE( 1 ) ! k-eps 482 DO jk = 2, jpkm1 483 DO jj = 2, jpjm1 484 DO ji = fs_2, fs_jpim1 ! vector opt. 485 psi(ji,jj,jk) = eps(ji,jj,jk) 486 END DO 487 END DO 488 END DO 440 DO_3D_00_00( 2, jpkm1 ) 441 psi(ji,jj,jk) = eps(ji,jj,jk) 442 END_3D 489 443 ! 490 444 CASE( 2 ) ! k-w 491 DO jk = 2, jpkm1 492 DO jj = 2, jpjm1 493 DO ji = fs_2, fs_jpim1 ! vector opt. 494 psi(ji,jj,jk) = SQRT( eb(ji,jj,jk) ) / ( rc0 * hmxl_b(ji,jj,jk) ) 495 END DO 496 END DO 497 END DO 445 DO_3D_00_00( 2, jpkm1 ) 446 psi(ji,jj,jk) = SQRT( eb(ji,jj,jk) ) / ( rc0 * hmxl_b(ji,jj,jk) ) 447 END_3D 498 448 ! 499 449 CASE( 3 ) ! generic 500 DO jk = 2, jpkm1 501 DO jj = 2, jpjm1 502 DO ji = fs_2, fs_jpim1 ! vector opt. 503 psi(ji,jj,jk) = rc02 * eb(ji,jj,jk) * hmxl_b(ji,jj,jk)**rnn 504 END DO 505 END DO 506 END DO 450 DO_3D_00_00( 2, jpkm1 ) 451 psi(ji,jj,jk) = rc02 * eb(ji,jj,jk) * hmxl_b(ji,jj,jk)**rnn 452 END_3D 507 453 ! 508 454 END SELECT … … 515 461 ! Warning : after this step, en : right hand side of the matrix 516 462 517 DO jk = 2, jpkm1 518 DO jj = 2, jpjm1 519 DO ji = fs_2, fs_jpim1 ! vector opt. 520 ! 521 ! psi / k 522 zratio = psi(ji,jj,jk) / eb(ji,jj,jk) 523 ! 524 ! psi3+ : stable : B=-KhN²<0 => N²>0 if rn2>0 zdir = 1 (stable) otherwise zdir = 0 (unstable) 525 zdir = 0.5_wp + SIGN( 0.5_wp, rn2(ji,jj,jk) ) 526 ! 527 rpsi3 = zdir * rpsi3m + ( 1._wp - zdir ) * rpsi3p 528 ! 529 ! shear prod. - stratif. destruction 530 prod = rpsi1 * zratio * p_sh2(ji,jj,jk) 531 ! 532 ! stratif. destruction 533 buoy = rpsi3 * zratio * (- p_avt(ji,jj,jk) * rn2(ji,jj,jk) ) 534 ! 535 ! shear prod. - stratif. destruction 536 diss = rpsi2 * zratio * zwall(ji,jj,jk) * eps(ji,jj,jk) 537 ! 538 zdir = 0.5_wp + SIGN( 0.5_wp, prod + buoy ) ! zdir =1(=0) if shear(ji,jj,jk)+buoy >0(<0) 539 ! 540 zesh2 = zdir * ( prod + buoy ) + (1._wp - zdir ) * prod ! production term 541 zdiss = zdir * ( diss / psi(ji,jj,jk) ) + (1._wp - zdir ) * (diss-buoy) / psi(ji,jj,jk) ! dissipation term 542 ! 543 ! building the matrix 544 zcof = rfact_psi * zwall_psi(ji,jj,jk) * tmask(ji,jj,jk) 545 ! ! lower diagonal 546 zd_lw(ji,jj,jk) = zcof * ( p_avm(ji,jj,jk ) + p_avm(ji,jj,jk-1) ) / ( e3t_n(ji,jj,jk-1) * e3w_n(ji,jj,jk) ) 547 ! ! upper diagonal 548 zd_up(ji,jj,jk) = zcof * ( p_avm(ji,jj,jk+1) + p_avm(ji,jj,jk ) ) / ( e3t_n(ji,jj,jk ) * e3w_n(ji,jj,jk) ) 549 ! ! diagonal 550 zdiag(ji,jj,jk) = 1._wp - zd_lw(ji,jj,jk) - zd_up(ji,jj,jk) + rdt * zdiss * wmask(ji,jj,jk) 551 ! ! right hand side in psi 552 psi(ji,jj,jk) = psi(ji,jj,jk) + rdt * zesh2 * wmask(ji,jj,jk) 553 END DO 554 END DO 555 END DO 463 DO_3D_00_00( 2, jpkm1 ) 464 ! 465 ! psi / k 466 zratio = psi(ji,jj,jk) / eb(ji,jj,jk) 467 ! 468 ! psi3+ : stable : B=-KhN²<0 => N²>0 if rn2>0 zdir = 1 (stable) otherwise zdir = 0 (unstable) 469 zdir = 0.5_wp + SIGN( 0.5_wp, rn2(ji,jj,jk) ) 470 ! 471 rpsi3 = zdir * rpsi3m + ( 1._wp - zdir ) * rpsi3p 472 ! 473 ! shear prod. - stratif. destruction 474 prod = rpsi1 * zratio * p_sh2(ji,jj,jk) 475 ! 476 ! stratif. destruction 477 buoy = rpsi3 * zratio * (- p_avt(ji,jj,jk) * rn2(ji,jj,jk) ) 478 ! 479 ! shear prod. - stratif. destruction 480 diss = rpsi2 * zratio * zwall(ji,jj,jk) * eps(ji,jj,jk) 481 ! 482 zdir = 0.5_wp + SIGN( 0.5_wp, prod + buoy ) ! zdir =1(=0) if shear(ji,jj,jk)+buoy >0(<0) 483 ! 484 zesh2 = zdir * ( prod + buoy ) + (1._wp - zdir ) * prod ! production term 485 zdiss = zdir * ( diss / psi(ji,jj,jk) ) + (1._wp - zdir ) * (diss-buoy) / psi(ji,jj,jk) ! dissipation term 486 ! 487 ! building the matrix 488 zcof = rfact_psi * zwall_psi(ji,jj,jk) * tmask(ji,jj,jk) 489 ! ! lower diagonal 490 zd_lw(ji,jj,jk) = zcof * ( p_avm(ji,jj,jk ) + p_avm(ji,jj,jk-1) ) / ( e3t_n(ji,jj,jk-1) * e3w_n(ji,jj,jk) ) 491 ! ! upper diagonal 492 zd_up(ji,jj,jk) = zcof * ( p_avm(ji,jj,jk+1) + p_avm(ji,jj,jk ) ) / ( e3t_n(ji,jj,jk ) * e3w_n(ji,jj,jk) ) 493 ! ! diagonal 494 zdiag(ji,jj,jk) = 1._wp - zd_lw(ji,jj,jk) - zd_up(ji,jj,jk) + rdt * zdiss * wmask(ji,jj,jk) 495 ! ! right hand side in psi 496 psi(ji,jj,jk) = psi(ji,jj,jk) + rdt * zesh2 * wmask(ji,jj,jk) 497 END_3D 556 498 ! 557 499 zdiag(:,:,jpk) = 1._wp … … 615 557 ! ! en(ibot) = u*^2 / Co2 and hmxl_n(ibot) = vkarmn * r_z0_bot 616 558 ! ! Balance between the production and the dissipation terms 617 DO jj = 2, jpjm1 618 DO ji = fs_2, fs_jpim1 ! vector opt. 619 ibot = mbkt(ji,jj) + 1 ! k bottom level of w-point 620 ibotm1 = mbkt(ji,jj) ! k-1 bottom level of w-point but >=1 621 zdep(ji,jj) = vkarmn * r_z0_bot 622 psi (ji,jj,ibot) = rc0**rpp * en(ji,jj,ibot)**rmm * zdep(ji,jj)**rnn 623 zd_lw(ji,jj,ibot) = 0._wp 624 zd_up(ji,jj,ibot) = 0._wp 625 zdiag(ji,jj,ibot) = 1._wp 626 ! 627 ! Just above last level, Dirichlet condition again (GOTM like) 628 zdep(ji,jj) = vkarmn * ( r_z0_bot + e3t_n(ji,jj,ibotm1) ) 629 psi (ji,jj,ibotm1) = rc0**rpp * en(ji,jj,ibot )**rmm * zdep(ji,jj)**rnn 630 zd_lw(ji,jj,ibotm1) = 0._wp 631 zd_up(ji,jj,ibotm1) = 0._wp 632 zdiag(ji,jj,ibotm1) = 1._wp 633 END DO 634 END DO 559 DO_2D_00_00 560 ibot = mbkt(ji,jj) + 1 ! k bottom level of w-point 561 ibotm1 = mbkt(ji,jj) ! k-1 bottom level of w-point but >=1 562 zdep(ji,jj) = vkarmn * r_z0_bot 563 psi (ji,jj,ibot) = rc0**rpp * en(ji,jj,ibot)**rmm * zdep(ji,jj)**rnn 564 zd_lw(ji,jj,ibot) = 0._wp 565 zd_up(ji,jj,ibot) = 0._wp 566 zdiag(ji,jj,ibot) = 1._wp 567 ! 568 ! Just above last level, Dirichlet condition again (GOTM like) 569 zdep(ji,jj) = vkarmn * ( r_z0_bot + e3t_n(ji,jj,ibotm1) ) 570 psi (ji,jj,ibotm1) = rc0**rpp * en(ji,jj,ibot )**rmm * zdep(ji,jj)**rnn 571 zd_lw(ji,jj,ibotm1) = 0._wp 572 zd_up(ji,jj,ibotm1) = 0._wp 573 zdiag(ji,jj,ibotm1) = 1._wp 574 END_2D 635 575 ! 636 576 CASE ( 1 ) ! Neumman boundary condition 637 577 ! 638 DO jj = 2, jpjm1 639 DO ji = fs_2, fs_jpim1 ! vector opt. 640 ibot = mbkt(ji,jj) + 1 ! k bottom level of w-point 641 ibotm1 = mbkt(ji,jj) ! k-1 bottom level of w-point but >=1 642 ! 643 ! Bottom level Dirichlet condition: 644 zdep(ji,jj) = vkarmn * r_z0_bot 645 psi (ji,jj,ibot) = rc0**rpp * en(ji,jj,ibot)**rmm * zdep(ji,jj)**rnn 646 ! 647 zd_lw(ji,jj,ibot) = 0._wp 648 zd_up(ji,jj,ibot) = 0._wp 649 zdiag(ji,jj,ibot) = 1._wp 650 ! 651 ! Just above last level: Neumann condition with flux injection 652 zdiag(ji,jj,ibotm1) = zdiag(ji,jj,ibotm1) + zd_up(ji,jj,ibotm1) ! Remove zd_up from zdiag 653 zd_up(ji,jj,ibotm1) = 0. 654 ! 655 ! Set psi vertical flux at the bottom: 656 zdep(ji,jj) = r_z0_bot + 0.5_wp*e3t_n(ji,jj,ibotm1) 657 zflxb = rsbc_psi2 * ( p_avm(ji,jj,ibot) + p_avm(ji,jj,ibotm1) ) & 658 & * (0.5_wp*(en(ji,jj,ibot)+en(ji,jj,ibotm1)))**rmm * zdep(ji,jj)**(rnn-1._wp) 659 psi(ji,jj,ibotm1) = psi(ji,jj,ibotm1) + zflxb / e3w_n(ji,jj,ibotm1) 660 END DO 661 END DO 578 DO_2D_00_00 579 ibot = mbkt(ji,jj) + 1 ! k bottom level of w-point 580 ibotm1 = mbkt(ji,jj) ! k-1 bottom level of w-point but >=1 581 ! 582 ! Bottom level Dirichlet condition: 583 zdep(ji,jj) = vkarmn * r_z0_bot 584 psi (ji,jj,ibot) = rc0**rpp * en(ji,jj,ibot)**rmm * zdep(ji,jj)**rnn 585 ! 586 zd_lw(ji,jj,ibot) = 0._wp 587 zd_up(ji,jj,ibot) = 0._wp 588 zdiag(ji,jj,ibot) = 1._wp 589 ! 590 ! Just above last level: Neumann condition with flux injection 591 zdiag(ji,jj,ibotm1) = zdiag(ji,jj,ibotm1) + zd_up(ji,jj,ibotm1) ! Remove zd_up from zdiag 592 zd_up(ji,jj,ibotm1) = 0. 593 ! 594 ! Set psi vertical flux at the bottom: 595 zdep(ji,jj) = r_z0_bot + 0.5_wp*e3t_n(ji,jj,ibotm1) 596 zflxb = rsbc_psi2 * ( p_avm(ji,jj,ibot) + p_avm(ji,jj,ibotm1) ) & 597 & * (0.5_wp*(en(ji,jj,ibot)+en(ji,jj,ibotm1)))**rmm * zdep(ji,jj)**(rnn-1._wp) 598 psi(ji,jj,ibotm1) = psi(ji,jj,ibotm1) + zflxb / e3w_n(ji,jj,ibotm1) 599 END_2D 662 600 ! 663 601 END SELECT … … 666 604 ! ---------------- 667 605 ! 668 DO jk = 2, jpkm1 ! First recurrence : Dk = Dk - Lk * Uk-1 / Dk-1 669 DO jj = 2, jpjm1 670 DO ji = fs_2, fs_jpim1 ! vector opt. 671 zdiag(ji,jj,jk) = zdiag(ji,jj,jk) - zd_lw(ji,jj,jk) * zd_up(ji,jj,jk-1) / zdiag(ji,jj,jk-1) 672 END DO 673 END DO 674 END DO 675 DO jk = 2, jpk ! Second recurrence : Lk = RHSk - Lk / Dk-1 * Lk-1 676 DO jj = 2, jpjm1 677 DO ji = fs_2, fs_jpim1 ! vector opt. 678 zd_lw(ji,jj,jk) = psi(ji,jj,jk) - zd_lw(ji,jj,jk) / zdiag(ji,jj,jk-1) * zd_lw(ji,jj,jk-1) 679 END DO 680 END DO 681 END DO 682 DO jk = jpk-1, 2, -1 ! Third recurrence : Ek = ( Lk - Uk * Ek+1 ) / Dk 683 DO jj = 2, jpjm1 684 DO ji = fs_2, fs_jpim1 ! vector opt. 685 psi(ji,jj,jk) = ( zd_lw(ji,jj,jk) - zd_up(ji,jj,jk) * psi(ji,jj,jk+1) ) / zdiag(ji,jj,jk) 686 END DO 687 END DO 688 END DO 606 DO_3D_00_00( 2, jpkm1 ) 607 zdiag(ji,jj,jk) = zdiag(ji,jj,jk) - zd_lw(ji,jj,jk) * zd_up(ji,jj,jk-1) / zdiag(ji,jj,jk-1) 608 END_3D 609 DO_3D_00_00( 2, jpk ) 610 zd_lw(ji,jj,jk) = psi(ji,jj,jk) - zd_lw(ji,jj,jk) / zdiag(ji,jj,jk-1) * zd_lw(ji,jj,jk-1) 611 END_3D 612 DO_3D_00_00( jpk-1, 2, -1 ) 613 psi(ji,jj,jk) = ( zd_lw(ji,jj,jk) - zd_up(ji,jj,jk) * psi(ji,jj,jk+1) ) / zdiag(ji,jj,jk) 614 END_3D 689 615 690 616 ! Set dissipation … … 694 620 ! 695 621 CASE( 0 ) ! k-kl (Mellor-Yamada) 696 DO jk = 1, jpkm1 697 DO jj = 2, jpjm1 698 DO ji = fs_2, fs_jpim1 ! vector opt. 699 eps(ji,jj,jk) = rc03 * en(ji,jj,jk) * en(ji,jj,jk) * SQRT( en(ji,jj,jk) ) / MAX( psi(ji,jj,jk), rn_epsmin) 700 END DO 701 END DO 702 END DO 622 DO_3D_00_00( 1, jpkm1 ) 623 eps(ji,jj,jk) = rc03 * en(ji,jj,jk) * en(ji,jj,jk) * SQRT( en(ji,jj,jk) ) / MAX( psi(ji,jj,jk), rn_epsmin) 624 END_3D 703 625 ! 704 626 CASE( 1 ) ! k-eps 705 DO jk = 1, jpkm1 706 DO jj = 2, jpjm1 707 DO ji = fs_2, fs_jpim1 ! vector opt. 708 eps(ji,jj,jk) = psi(ji,jj,jk) 709 END DO 710 END DO 711 END DO 627 DO_3D_00_00( 1, jpkm1 ) 628 eps(ji,jj,jk) = psi(ji,jj,jk) 629 END_3D 712 630 ! 713 631 CASE( 2 ) ! k-w 714 DO jk = 1, jpkm1 715 DO jj = 2, jpjm1 716 DO ji = fs_2, fs_jpim1 ! vector opt. 717 eps(ji,jj,jk) = rc04 * en(ji,jj,jk) * psi(ji,jj,jk) 718 END DO 719 END DO 720 END DO 632 DO_3D_00_00( 1, jpkm1 ) 633 eps(ji,jj,jk) = rc04 * en(ji,jj,jk) * psi(ji,jj,jk) 634 END_3D 721 635 ! 722 636 CASE( 3 ) ! generic … … 724 638 zex1 = ( 1.5_wp + rmm/rnn ) 725 639 zex2 = -1._wp / rnn 726 DO jk = 1, jpkm1 727 DO jj = 2, jpjm1 728 DO ji = fs_2, fs_jpim1 ! vector opt. 729 eps(ji,jj,jk) = zcoef * en(ji,jj,jk)**zex1 * psi(ji,jj,jk)**zex2 730 END DO 731 END DO 732 END DO 640 DO_3D_00_00( 1, jpkm1 ) 641 eps(ji,jj,jk) = zcoef * en(ji,jj,jk)**zex1 * psi(ji,jj,jk)**zex2 642 END_3D 733 643 ! 734 644 END SELECT … … 736 646 ! Limit dissipation rate under stable stratification 737 647 ! -------------------------------------------------- 738 DO jk = 1, jpkm1 ! Note that this set boundary conditions on hmxl_n at the same time 739 DO jj = 2, jpjm1 740 DO ji = fs_2, fs_jpim1 ! vector opt. 741 ! limitation 742 eps (ji,jj,jk) = MAX( eps(ji,jj,jk), rn_epsmin ) 743 hmxl_n(ji,jj,jk) = rc03 * en(ji,jj,jk) * SQRT( en(ji,jj,jk) ) / eps(ji,jj,jk) 744 ! Galperin criterium (NOTE : Not required if the proper value of C3 in stable cases is calculated) 745 zrn2 = MAX( rn2(ji,jj,jk), rsmall ) 746 IF( ln_length_lim ) hmxl_n(ji,jj,jk) = MIN( rn_clim_galp * SQRT( 2._wp * en(ji,jj,jk) / zrn2 ), hmxl_n(ji,jj,jk) ) 747 END DO 748 END DO 749 END DO 648 DO_3D_00_00( 1, jpkm1 ) 649 ! limitation 650 eps (ji,jj,jk) = MAX( eps(ji,jj,jk), rn_epsmin ) 651 hmxl_n(ji,jj,jk) = rc03 * en(ji,jj,jk) * SQRT( en(ji,jj,jk) ) / eps(ji,jj,jk) 652 ! Galperin criterium (NOTE : Not required if the proper value of C3 in stable cases is calculated) 653 zrn2 = MAX( rn2(ji,jj,jk), rsmall ) 654 IF( ln_length_lim ) hmxl_n(ji,jj,jk) = MIN( rn_clim_galp * SQRT( 2._wp * en(ji,jj,jk) / zrn2 ), hmxl_n(ji,jj,jk) ) 655 END_3D 750 656 751 657 ! … … 756 662 ! 757 663 CASE ( 0 , 1 ) ! Galperin or Kantha-Clayson stability functions 758 DO jk = 2, jpkm1 759 DO jj = 2, jpjm1 760 DO ji = fs_2, fs_jpim1 ! vector opt. 761 ! zcof = l²/q² 762 zcof = hmxl_b(ji,jj,jk) * hmxl_b(ji,jj,jk) / ( 2._wp*eb(ji,jj,jk) ) 763 ! Gh = -N²l²/q² 764 gh = - rn2(ji,jj,jk) * zcof 765 gh = MIN( gh, rgh0 ) 766 gh = MAX( gh, rghmin ) 767 ! Stability functions from Kantha and Clayson (if C2=C3=0 => Galperin) 768 sh = ra2*( 1._wp-6._wp*ra1/rb1 ) / ( 1.-3.*ra2*gh*(6.*ra1+rb2*( 1._wp-rc3 ) ) ) 769 sm = ( rb1**(-1._wp/3._wp) + ( 18._wp*ra1*ra1 + 9._wp*ra1*ra2*(1._wp-rc2) )*sh*gh ) / (1._wp-9._wp*ra1*ra2*gh) 770 ! 771 ! Store stability function in zstt and zstm 772 zstt(ji,jj,jk) = rc_diff * sh * tmask(ji,jj,jk) 773 zstm(ji,jj,jk) = rc_diff * sm * tmask(ji,jj,jk) 774 END DO 775 END DO 776 END DO 664 DO_3D_00_00( 2, jpkm1 ) 665 ! zcof = l²/q² 666 zcof = hmxl_b(ji,jj,jk) * hmxl_b(ji,jj,jk) / ( 2._wp*eb(ji,jj,jk) ) 667 ! Gh = -N²l²/q² 668 gh = - rn2(ji,jj,jk) * zcof 669 gh = MIN( gh, rgh0 ) 670 gh = MAX( gh, rghmin ) 671 ! Stability functions from Kantha and Clayson (if C2=C3=0 => Galperin) 672 sh = ra2*( 1._wp-6._wp*ra1/rb1 ) / ( 1.-3.*ra2*gh*(6.*ra1+rb2*( 1._wp-rc3 ) ) ) 673 sm = ( rb1**(-1._wp/3._wp) + ( 18._wp*ra1*ra1 + 9._wp*ra1*ra2*(1._wp-rc2) )*sh*gh ) / (1._wp-9._wp*ra1*ra2*gh) 674 ! 675 ! Store stability function in zstt and zstm 676 zstt(ji,jj,jk) = rc_diff * sh * tmask(ji,jj,jk) 677 zstm(ji,jj,jk) = rc_diff * sm * tmask(ji,jj,jk) 678 END_3D 777 679 ! 778 680 CASE ( 2, 3 ) ! Canuto stability functions 779 DO jk = 2, jpkm1 780 DO jj = 2, jpjm1 781 DO ji = fs_2, fs_jpim1 ! vector opt. 782 ! zcof = l²/q² 783 zcof = hmxl_b(ji,jj,jk)*hmxl_b(ji,jj,jk) / ( 2._wp * eb(ji,jj,jk) ) 784 ! Gh = -N²l²/q² 785 gh = - rn2(ji,jj,jk) * zcof 786 gh = MIN( gh, rgh0 ) 787 gh = MAX( gh, rghmin ) 788 gh = gh * rf6 789 ! Gm = M²l²/q² Shear number 790 shr = p_sh2(ji,jj,jk) / MAX( p_avm(ji,jj,jk), rsmall ) 791 gm = MAX( shr * zcof , 1.e-10 ) 792 gm = gm * rf6 793 gm = MIN ( (rd0 - rd1*gh + rd3*gh*gh) / (rd2-rd4*gh) , gm ) 794 ! Stability functions from Canuto 795 rcff = rd0 - rd1*gh +rd2*gm + rd3*gh*gh - rd4*gh*gm + rd5*gm*gm 796 sm = (rs0 - rs1*gh + rs2*gm) / rcff 797 sh = (rs4 - rs5*gh + rs6*gm) / rcff 798 ! 799 ! Store stability function in zstt and zstm 800 zstt(ji,jj,jk) = rc_diff * sh * tmask(ji,jj,jk) 801 zstm(ji,jj,jk) = rc_diff * sm * tmask(ji,jj,jk) 802 END DO 803 END DO 804 END DO 681 DO_3D_00_00( 2, jpkm1 ) 682 ! zcof = l²/q² 683 zcof = hmxl_b(ji,jj,jk)*hmxl_b(ji,jj,jk) / ( 2._wp * eb(ji,jj,jk) ) 684 ! Gh = -N²l²/q² 685 gh = - rn2(ji,jj,jk) * zcof 686 gh = MIN( gh, rgh0 ) 687 gh = MAX( gh, rghmin ) 688 gh = gh * rf6 689 ! Gm = M²l²/q² Shear number 690 shr = p_sh2(ji,jj,jk) / MAX( p_avm(ji,jj,jk), rsmall ) 691 gm = MAX( shr * zcof , 1.e-10 ) 692 gm = gm * rf6 693 gm = MIN ( (rd0 - rd1*gh + rd3*gh*gh) / (rd2-rd4*gh) , gm ) 694 ! Stability functions from Canuto 695 rcff = rd0 - rd1*gh +rd2*gm + rd3*gh*gh - rd4*gh*gm + rd5*gm*gm 696 sm = (rs0 - rs1*gh + rs2*gm) / rcff 697 sh = (rs4 - rs5*gh + rs6*gm) / rcff 698 ! 699 ! Store stability function in zstt and zstm 700 zstt(ji,jj,jk) = rc_diff * sh * tmask(ji,jj,jk) 701 zstm(ji,jj,jk) = rc_diff * sm * tmask(ji,jj,jk) 702 END_3D 805 703 ! 806 704 END SELECT … … 813 711 ! default value, in case jpk > mbkt(ji,jj)+1. Not needed but avoid a bug when looking for undefined values (-fpe0) 814 712 zstm(:,:,jpk) = 0. 815 DO jj = 2, jpjm1 ! update bottom with good values 816 DO ji = fs_2, fs_jpim1 ! vector opt. 817 zstm(ji,jj,mbkt(ji,jj)+1) = zstm(ji,jj,mbkt(ji,jj)) 818 END DO 819 END DO 713 DO_2D_00_00 714 zstm(ji,jj,mbkt(ji,jj)+1) = zstm(ji,jj,mbkt(ji,jj)) 715 END_2D 820 716 821 717 zstt(:,:, 1) = wmask(:,:, 1) ! default value not needed but avoid a bug when looking for undefined values (-fpe0) … … 830 726 ! later overwritten by surface/bottom boundaries conditions, so we don't really care of p_avm(:,:1) and p_avm(:,:jpk) 831 727 ! for zd_lw and zd_up but they have to be defined to avoid a bug when looking for undefined values (-fpe0) 832 DO jk = 1, jpk 833 DO jj = 2, jpjm1 834 DO ji = fs_2, fs_jpim1 ! vector opt. 835 zsqen = SQRT( 2._wp * en(ji,jj,jk) ) * hmxl_n(ji,jj,jk) 836 zavt = zsqen * zstt(ji,jj,jk) 837 zavm = zsqen * zstm(ji,jj,jk) 838 p_avt(ji,jj,jk) = MAX( zavt, avtb(jk) ) * wmask(ji,jj,jk) ! apply mask for zdfmxl routine 839 p_avm(ji,jj,jk) = MAX( zavm, avmb(jk) ) ! Note that avm is not masked at the surface and the bottom 840 END DO 841 END DO 842 END DO 728 DO_3D_00_00( 1, jpk ) 729 zsqen = SQRT( 2._wp * en(ji,jj,jk) ) * hmxl_n(ji,jj,jk) 730 zavt = zsqen * zstt(ji,jj,jk) 731 zavm = zsqen * zstm(ji,jj,jk) 732 p_avt(ji,jj,jk) = MAX( zavt, avtb(jk) ) * wmask(ji,jj,jk) ! apply mask for zdfmxl routine 733 p_avm(ji,jj,jk) = MAX( zavm, avmb(jk) ) ! Note that avm is not masked at the surface and the bottom 734 END_3D 843 735 p_avt(:,:,1) = 0._wp 844 736 ! -
NEMO/branches/2020/temporary_r4_trunk/src/OCE/ZDF/zdftke.F90
r13466 r13469 231 231 ! !<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<< 232 232 ! 233 DO jj = 2, jpjm1 ! en(1) = rn_ebb taum / rau0 (min value rn_emin0) 234 DO ji = fs_2, fs_jpim1 ! vector opt. 233 DO_2D_00_00 235 234 !! clem: this should be the right formulation but it makes the model unstable unless drags are calculated implicitly 236 235 !! one way around would be to increase zbbirau 237 236 !! en(ji,jj,1) = MAX( rn_emin0, ( ( 1._wp - fr_i(ji,jj) ) * zbbrau + & 238 237 !! & fr_i(ji,jj) * zbbirau ) * taum(ji,jj) ) * tmask(ji,jj,1) 239 en(ji,jj,1) = MAX( rn_emin0, zbbrau * taum(ji,jj) ) * tmask(ji,jj,1) 240 END DO 241 END DO 238 en(ji,jj,1) = MAX( rn_emin0, zbbrau * taum(ji,jj) ) * tmask(ji,jj,1) 239 END_2D 242 240 ! 243 241 ! !<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<< … … 251 249 IF( .NOT.ln_drg_OFF ) THEN !== friction used as top/bottom boundary condition on TKE 252 250 ! 253 DO jj = 2, jpjm1 ! bottom friction 254 DO ji = fs_2, fs_jpim1 ! vector opt. 255 zmsku = ( 2. - umask(ji-1,jj,mbkt(ji,jj)) * umask(ji,jj,mbkt(ji,jj)) ) 256 zmskv = ( 2. - vmask(ji,jj-1,mbkt(ji,jj)) * vmask(ji,jj,mbkt(ji,jj)) ) 257 ! ! where 0.001875 = (rn_ebb0/rau0) * 0.5 = 3.75*0.5/1000. (CAUTION CdU<0) 258 zebot = - 0.001875_wp * rCdU_bot(ji,jj) * SQRT( ( zmsku*( ub(ji,jj,mbkt(ji,jj))+ub(ji-1,jj,mbkt(ji,jj)) ) )**2 & 259 & + ( zmskv*( vb(ji,jj,mbkt(ji,jj))+vb(ji,jj-1,mbkt(ji,jj)) ) )**2 ) 260 en(ji,jj,mbkt(ji,jj)+1) = MAX( zebot, rn_emin ) * ssmask(ji,jj) 261 END DO 262 END DO 251 DO_2D_00_00 252 zmsku = ( 2. - umask(ji-1,jj,mbkt(ji,jj)) * umask(ji,jj,mbkt(ji,jj)) ) 253 zmskv = ( 2. - vmask(ji,jj-1,mbkt(ji,jj)) * vmask(ji,jj,mbkt(ji,jj)) ) 254 ! ! where 0.001875 = (rn_ebb0/rau0) * 0.5 = 3.75*0.5/1000. (CAUTION CdU<0) 255 zebot = - 0.001875_wp * rCdU_bot(ji,jj) * SQRT( ( zmsku*( uu(ji,jj,mbkt(ji,jj),Nnn)+uu(ji-1,jj,mbkt(ji,jj),Nnn) ) )**2 & 256 & + ( zmskv*( vv(ji,jj,mbkt(ji,jj),Nnn)+vv(ji,jj-1,mbkt(ji,jj),Nnn) ) )**2 ) 257 en(ji,jj,mbkt(ji,jj)+1) = MAX( zebot, rn_emin ) * ssmask(ji,jj) 258 END_2D 263 259 IF( ln_isfcav ) THEN ! top friction 264 DO jj = 2, jpjm1 265 DO ji = fs_2, fs_jpim1 ! vector opt. 266 zmsku = ( 2. - umask(ji-1,jj,mikt(ji,jj)) * umask(ji,jj,mikt(ji,jj)) ) 267 zmskv = ( 2. - vmask(ji,jj-1,mikt(ji,jj)) * vmask(ji,jj,mikt(ji,jj)) ) 268 ! ! where 0.001875 = (rn_ebb0/rau0) * 0.5 = 3.75*0.5/1000. (CAUTION CdU<0) 269 zetop = - 0.001875_wp * rCdU_top(ji,jj) * SQRT( ( zmsku*( ub(ji,jj,mikt(ji,jj))+ub(ji-1,jj,mikt(ji,jj)) ) )**2 & 270 & + ( zmskv*( vb(ji,jj,mikt(ji,jj))+vb(ji,jj-1,mikt(ji,jj)) ) )**2 ) 271 en(ji,jj,mikt(ji,jj)) = en(ji,jj,1) * tmask(ji,jj,1) & 272 & + MAX( zetop, rn_emin ) * (1._wp - tmask(ji,jj,1)) * ssmask(ji,jj) 273 END DO 274 END DO 260 DO_2D_00_00 261 zmsku = ( 2. - umask(ji-1,jj,mikt(ji,jj)) * umask(ji,jj,mikt(ji,jj)) ) 262 zmskv = ( 2. - vmask(ji,jj-1,mikt(ji,jj)) * vmask(ji,jj,mikt(ji,jj)) ) 263 ! ! where 0.001875 = (rn_ebb0/rau0) * 0.5 = 3.75*0.5/1000. (CAUTION CdU<0) 264 zetop = - 0.001875_wp * rCdU_top(ji,jj) * SQRT( ( zmsku*( uu(ji,jj,mikt(ji,jj),Nnn)+uu(ji-1,jj,mikt(ji,jj),Nnn) ) )**2 & 265 & + ( zmskv*( vv(ji,jj,mikt(ji,jj),Nnn)+vv(ji,jj-1,mikt(ji,jj),Nnn) ) )**2 ) 266 en(ji,jj,mikt(ji,jj)) = en(ji,jj,1) * tmask(ji,jj,1) & 267 & + MAX( zetop, rn_emin ) * (1._wp - tmask(ji,jj,1)) * ssmask(ji,jj) 268 END_2D 275 269 ENDIF 276 270 ! … … 289 283 zcof = 0.5 * 0.016 * 0.016 / ( zrhoa * zcdrag ) 290 284 imlc(:,:) = mbkt(:,:) + 1 ! Initialization to the number of w ocean point (=2 over land) 291 DO jk = jpkm1, 2, -1 292 DO jj = 1, jpj ! Last w-level at which zpelc>=0.5*us*us 293 DO ji = 1, jpi ! with us=0.016*wind(starting from jpk-1) 294 zus = zcof * taum(ji,jj) 295 IF( zpelc(ji,jj,jk) > zus ) imlc(ji,jj) = jk 296 END DO 297 END DO 298 END DO 285 DO_3D_11_11( jpkm1, 2, -1 ) 286 zus = zcof * taum(ji,jj) 287 IF( zpelc(ji,jj,jk) > zus ) imlc(ji,jj) = jk 288 END_3D 299 289 ! ! finite LC depth 300 DO jj = 1, jpj 301 DO ji = 1, jpi 302 zhlc(ji,jj) = pdepw(ji,jj,imlc(ji,jj)) 303 END DO 304 END DO 290 DO_2D_11_11 291 zhlc(ji,jj) = pdepw(ji,jj,imlc(ji,jj)) 292 END_2D 305 293 zcof = 0.016 / SQRT( zrhoa * zcdrag ) 306 DO jj = 2, jpjm1 307 DO ji = fs_2, fs_jpim1 ! vector opt. 308 zus = zcof * SQRT( taum(ji,jj) ) ! Stokes drift 309 zus3(ji,jj) = MAX( 0._wp, 1._wp - zice_fra(ji,jj) ) * zus * zus * zus * tmask(ji,jj,1) ! zus > 0. ok 310 END DO 311 END DO 312 DO jk = 2, jpkm1 !* TKE Langmuir circulation source term added to en 313 DO jj = 2, jpjm1 314 DO ji = fs_2, fs_jpim1 ! vector opt. 315 IF ( zus3(ji,jj) /= 0._wp ) THEN 316 ! vertical velocity due to LC 317 IF ( pdepw(ji,jj,jk) - zhlc(ji,jj) < 0 .AND. wmask(ji,jj,jk) /= 0. ) THEN 318 ! ! vertical velocity due to LC 319 zwlc = rn_lc * SIN( rpi * pdepw(ji,jj,jk) / zhlc(ji,jj) ) 320 ! ! TKE Langmuir circulation source term 321 en(ji,jj,jk) = en(ji,jj,jk) + rdt * zus3(ji,jj) * ( zwlc * zwlc * zwlc ) / zhlc(ji,jj) 322 ENDIF 323 ENDIF 324 END DO 325 END DO 326 END DO 294 DO_2D_00_00 295 zus = zcof * SQRT( taum(ji,jj) ) ! Stokes drift 296 zus3(ji,jj) = MAX( 0._wp, 1._wp - zice_fra(ji,jj) ) * zus * zus * zus * tmask(ji,jj,1) ! zus > 0. ok 297 END_2D 298 DO_3D_00_00( 2, jpkm1 ) 299 IF ( zus3(ji,jj) /= 0._wp ) THEN 300 ! vertical velocity due to LC 301 IF ( pdepw(ji,jj,jk) - zhlc(ji,jj) < 0 .AND. wmask(ji,jj,jk) /= 0. ) THEN 302 ! ! vertical velocity due to LC 303 zwlc = rn_lc * SIN( rpi * pdepw(ji,jj,jk) / zhlc(ji,jj) ) 304 ! ! TKE Langmuir circulation source term 305 en(ji,jj,jk) = en(ji,jj,jk) + rdt * zus3(ji,jj) * ( zwlc * zwlc * zwlc ) / zhlc(ji,jj) 306 ENDIF 307 ENDIF 308 END_3D 327 309 ! 328 310 ENDIF … … 336 318 ! 337 319 IF( nn_pdl == 1 ) THEN !* Prandtl number = F( Ri ) 338 DO jk = 2, jpkm1 339 DO jj = 2, jpjm1 340 DO ji = 2, jpim1 341 ! ! local Richardson number 342 zri = MAX( rn2b(ji,jj,jk), 0._wp ) * p_avm(ji,jj,jk) / ( p_sh2(ji,jj,jk) + rn_bshear ) 343 ! ! inverse of Prandtl number 344 apdlr(ji,jj,jk) = MAX( 0.1_wp, ri_cri / MAX( ri_cri , zri ) ) 345 END DO 346 END DO 347 END DO 320 DO_3D_00_00( 2, jpkm1 ) 321 ! ! local Richardson number 322 zri = MAX( rn2b(ji,jj,jk), 0._wp ) * p_avm(ji,jj,jk) / ( p_sh2(ji,jj,jk) + rn_bshear ) 323 ! ! inverse of Prandtl number 324 apdlr(ji,jj,jk) = MAX( 0.1_wp, ri_cri / MAX( ri_cri , zri ) ) 325 END_3D 348 326 ENDIF 349 327 ! 350 DO jk = 2, jpkm1 !* Matrix and right hand side in en 351 DO jj = 2, jpjm1 352 DO ji = fs_2, fs_jpim1 ! vector opt. 353 zcof = zfact1 * tmask(ji,jj,jk) 354 ! ! A minimum of 2.e-5 m2/s is imposed on TKE vertical 355 ! ! eddy coefficient (ensure numerical stability) 356 zzd_up = zcof * MAX( p_avm(ji,jj,jk+1) + p_avm(ji,jj,jk ) , 2.e-5_wp ) & ! upper diagonal 357 & / ( p_e3t(ji,jj,jk ) * p_e3w(ji,jj,jk ) ) 358 zzd_lw = zcof * MAX( p_avm(ji,jj,jk ) + p_avm(ji,jj,jk-1) , 2.e-5_wp ) & ! lower diagonal 359 & / ( p_e3t(ji,jj,jk-1) * p_e3w(ji,jj,jk ) ) 360 ! 361 zd_up(ji,jj,jk) = zzd_up ! Matrix (zdiag, zd_up, zd_lw) 362 zd_lw(ji,jj,jk) = zzd_lw 363 zdiag(ji,jj,jk) = 1._wp - zzd_lw - zzd_up + zfact2 * dissl(ji,jj,jk) * wmask(ji,jj,jk) 364 ! 365 ! ! right hand side in en 366 en(ji,jj,jk) = en(ji,jj,jk) + rdt * ( p_sh2(ji,jj,jk) & ! shear 367 & - p_avt(ji,jj,jk) * rn2(ji,jj,jk) & ! stratification 368 & + zfact3 * dissl(ji,jj,jk) * en(ji,jj,jk) & ! dissipation 369 & ) * wmask(ji,jj,jk) 370 END DO 371 END DO 372 END DO 328 DO_3D_00_00( 2, jpkm1 ) 329 zcof = zfact1 * tmask(ji,jj,jk) 330 ! ! A minimum of 2.e-5 m2/s is imposed on TKE vertical 331 ! ! eddy coefficient (ensure numerical stability) 332 zzd_up = zcof * MAX( p_avm(ji,jj,jk+1) + p_avm(ji,jj,jk ) , 2.e-5_wp ) & ! upper diagonal 333 & / ( p_e3t(ji,jj,jk ) * p_e3w(ji,jj,jk ) ) 334 zzd_lw = zcof * MAX( p_avm(ji,jj,jk ) + p_avm(ji,jj,jk-1) , 2.e-5_wp ) & ! lower diagonal 335 & / ( p_e3t(ji,jj,jk-1) * p_e3w(ji,jj,jk ) ) 336 ! 337 zd_up(ji,jj,jk) = zzd_up ! Matrix (zdiag, zd_up, zd_lw) 338 zd_lw(ji,jj,jk) = zzd_lw 339 zdiag(ji,jj,jk) = 1._wp - zzd_lw - zzd_up + zfact2 * dissl(ji,jj,jk) * wmask(ji,jj,jk) 340 ! 341 ! ! right hand side in en 342 en(ji,jj,jk) = en(ji,jj,jk) + rdt * ( p_sh2(ji,jj,jk) & ! shear 343 & - p_avt(ji,jj,jk) * rn2(ji,jj,jk) & ! stratification 344 & + zfact3 * dissl(ji,jj,jk) * en(ji,jj,jk) & ! dissipation 345 & ) * wmask(ji,jj,jk) 346 END_3D 373 347 ! !* Matrix inversion from level 2 (tke prescribed at level 1) 374 DO jk = 3, jpkm1 ! First recurrence : Dk = Dk - Lk * Uk-1 / Dk-1 375 DO jj = 2, jpjm1 376 DO ji = fs_2, fs_jpim1 ! vector opt. 377 zdiag(ji,jj,jk) = zdiag(ji,jj,jk) - zd_lw(ji,jj,jk) * zd_up(ji,jj,jk-1) / zdiag(ji,jj,jk-1) 378 END DO 379 END DO 380 END DO 381 DO jj = 2, jpjm1 ! Second recurrence : Lk = RHSk - Lk / Dk-1 * Lk-1 382 DO ji = fs_2, fs_jpim1 ! vector opt. 383 zd_lw(ji,jj,2) = en(ji,jj,2) - zd_lw(ji,jj,2) * en(ji,jj,1) ! Surface boudary conditions on tke 384 END DO 385 END DO 386 DO jk = 3, jpkm1 387 DO jj = 2, jpjm1 388 DO ji = fs_2, fs_jpim1 ! vector opt. 389 zd_lw(ji,jj,jk) = en(ji,jj,jk) - zd_lw(ji,jj,jk) / zdiag(ji,jj,jk-1) *zd_lw(ji,jj,jk-1) 390 END DO 391 END DO 392 END DO 393 DO jj = 2, jpjm1 ! thrid recurrence : Ek = ( Lk - Uk * Ek+1 ) / Dk 394 DO ji = fs_2, fs_jpim1 ! vector opt. 395 en(ji,jj,jpkm1) = zd_lw(ji,jj,jpkm1) / zdiag(ji,jj,jpkm1) 396 END DO 397 END DO 398 DO jk = jpk-2, 2, -1 399 DO jj = 2, jpjm1 400 DO ji = fs_2, fs_jpim1 ! vector opt. 401 en(ji,jj,jk) = ( zd_lw(ji,jj,jk) - zd_up(ji,jj,jk) * en(ji,jj,jk+1) ) / zdiag(ji,jj,jk) 402 END DO 403 END DO 404 END DO 405 DO jk = 2, jpkm1 ! set the minimum value of tke 406 DO jj = 2, jpjm1 407 DO ji = fs_2, fs_jpim1 ! vector opt. 408 en(ji,jj,jk) = MAX( en(ji,jj,jk), rn_emin ) * wmask(ji,jj,jk) 409 END DO 410 END DO 411 END DO 348 DO_3D_00_00( 3, jpkm1 ) 349 zdiag(ji,jj,jk) = zdiag(ji,jj,jk) - zd_lw(ji,jj,jk) * zd_up(ji,jj,jk-1) / zdiag(ji,jj,jk-1) 350 END_3D 351 DO_2D_00_00 352 zd_lw(ji,jj,2) = en(ji,jj,2) - zd_lw(ji,jj,2) * en(ji,jj,1) ! Surface boudary conditions on tke 353 END_2D 354 DO_3D_00_00( 3, jpkm1 ) 355 zd_lw(ji,jj,jk) = en(ji,jj,jk) - zd_lw(ji,jj,jk) / zdiag(ji,jj,jk-1) *zd_lw(ji,jj,jk-1) 356 END_3D 357 DO_2D_00_00 358 en(ji,jj,jpkm1) = zd_lw(ji,jj,jpkm1) / zdiag(ji,jj,jpkm1) 359 END_2D 360 DO_3D_00_00( jpk-2, 2, -1 ) 361 en(ji,jj,jk) = ( zd_lw(ji,jj,jk) - zd_up(ji,jj,jk) * en(ji,jj,jk+1) ) / zdiag(ji,jj,jk) 362 END_3D 363 DO_3D_00_00( 2, jpkm1 ) 364 en(ji,jj,jk) = MAX( en(ji,jj,jk), rn_emin ) * wmask(ji,jj,jk) 365 END_3D 412 366 ! 413 367 ! !<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<< … … 419 373 420 374 IF( nn_etau == 1 ) THEN !* penetration below the mixed layer (rn_efr fraction) 421 DO jk = 2, jpkm1 ! nn_eice=0 : ON below sea-ice ; nn_eice>0 : partly OFF 422 DO jj = 2, jpjm1 423 DO ji = fs_2, fs_jpim1 ! vector opt. 424 en(ji,jj,jk) = en(ji,jj,jk) + rn_efr * en(ji,jj,1) * EXP( -pdepw(ji,jj,jk) / htau(ji,jj) ) & 425 & * MAX( 0._wp, 1._wp - zice_fra(ji,jj) ) * wmask(ji,jj,jk) * tmask(ji,jj,1) 426 END DO 427 END DO 428 END DO 375 DO_3D_00_00( 2, jpkm1 ) 376 en(ji,jj,jk) = en(ji,jj,jk) + rn_efr * en(ji,jj,1) * EXP( -pdepw(ji,jj,jk) / htau(ji,jj) ) & 377 & * MAX( 0._wp, 1._wp - zice_fra(ji,jj) ) * wmask(ji,jj,jk) * tmask(ji,jj,1) 378 END_3D 429 379 ELSEIF( nn_etau == 2 ) THEN !* act only at the base of the mixed layer (jk=nmln) (rn_efr fraction) 430 DO jj = 2, jpjm1 431 DO ji = fs_2, fs_jpim1 ! vector opt. 432 jk = nmln(ji,jj) 433 en(ji,jj,jk) = en(ji,jj,jk) + rn_efr * en(ji,jj,1) * EXP( -pdepw(ji,jj,jk) / htau(ji,jj) ) & 434 & * MAX( 0._wp, 1._wp - zice_fra(ji,jj) ) * wmask(ji,jj,jk) * tmask(ji,jj,1) 435 END DO 436 END DO 380 DO_2D_00_00 381 jk = nmln(ji,jj) 382 en(ji,jj,jk) = en(ji,jj,jk) + rn_efr * en(ji,jj,1) * EXP( -pdepw(ji,jj,jk) / htau(ji,jj) ) & 383 & * MAX( 0._wp, 1._wp - zice_fra(ji,jj) ) * wmask(ji,jj,jk) * tmask(ji,jj,1) 384 END_2D 437 385 ELSEIF( nn_etau == 3 ) THEN !* penetration belox the mixed layer (HF variability) 438 DO jk = 2, jpkm1 439 DO jj = 2, jpjm1 440 DO ji = fs_2, fs_jpim1 ! vector opt. 441 ztx2 = utau(ji-1,jj ) + utau(ji,jj) 442 zty2 = vtau(ji ,jj-1) + vtau(ji,jj) 443 ztau = 0.5_wp * SQRT( ztx2 * ztx2 + zty2 * zty2 ) * tmask(ji,jj,1) ! module of the mean stress 444 zdif = taum(ji,jj) - ztau ! mean of modulus - modulus of the mean 445 zdif = rhftau_scl * MAX( 0._wp, zdif + rhftau_add ) ! apply some modifications... 446 en(ji,jj,jk) = en(ji,jj,jk) + zbbrau * zdif * EXP( -pdepw(ji,jj,jk) / htau(ji,jj) ) & 447 & * MAX( 0._wp, 1._wp - zice_fra(ji,jj) ) * wmask(ji,jj,jk) * tmask(ji,jj,1) 448 END DO 449 END DO 450 END DO 386 DO_3D_00_00( 2, jpkm1 ) 387 ztx2 = utau(ji-1,jj ) + utau(ji,jj) 388 zty2 = vtau(ji ,jj-1) + vtau(ji,jj) 389 ztau = 0.5_wp * SQRT( ztx2 * ztx2 + zty2 * zty2 ) * tmask(ji,jj,1) ! module of the mean stress 390 zdif = taum(ji,jj) - ztau ! mean of modulus - modulus of the mean 391 zdif = rhftau_scl * MAX( 0._wp, zdif + rhftau_add ) ! apply some modifications... 392 en(ji,jj,jk) = en(ji,jj,jk) + zbbrau * zdif * EXP( -pdepw(ji,jj,jk) / htau(ji,jj) ) & 393 & * MAX( 0._wp, 1._wp - zice_fra(ji,jj) ) * wmask(ji,jj,jk) * tmask(ji,jj,1) 394 END_3D 451 395 ENDIF 452 396 ! … … 515 459 zraug = vkarmn * 2.e5_wp / ( rau0 * grav ) 516 460 #if ! defined key_si3 && ! defined key_cice 517 DO jj = 2, jpjm1 ! No sea-ice 518 DO ji = fs_2, fs_jpim1 519 zmxlm(ji,jj,1) = zraug * taum(ji,jj) * tmask(ji,jj,1) 520 END DO 521 END DO 461 DO_2D_00_00 462 zmxlm(ji,jj,1) = zraug * taum(ji,jj) * tmask(ji,jj,1) 463 END_2D 522 464 #else 523 465 … … 525 467 ! 526 468 CASE( 0 ) ! No scaling under sea-ice 527 DO jj = 2, jpjm1 528 DO ji = fs_2, fs_jpim1 529 zmxlm(ji,jj,1) = zraug * taum(ji,jj) * tmask(ji,jj,1) 530 END DO 531 END DO 469 DO_2D_00_00 470 zmxlm(ji,jj,1) = zraug * taum(ji,jj) * tmask(ji,jj,1) 471 END_2D 532 472 ! 533 473 CASE( 1 ) ! scaling with constant sea-ice thickness 534 DO jj = 2, jpjm1 535 DO ji = fs_2, fs_jpim1 536 zmxlm(ji,jj,1) = ( ( 1._wp - fr_i(ji,jj) ) * zraug * taum(ji,jj) + & 537 & fr_i(ji,jj) * rn_mxlice ) * tmask(ji,jj,1) 538 END DO 539 END DO 474 DO_2D_00_00 475 zmxlm(ji,jj,1) = ( ( 1._wp - fr_i(ji,jj) ) * zraug * taum(ji,jj) + & 476 & fr_i(ji,jj) * rn_mxlice ) * tmask(ji,jj,1) 477 END_2D 540 478 ! 541 479 CASE( 2 ) ! scaling with mean sea-ice thickness 542 DO jj = 2, jpjm1 543 DO ji = fs_2, fs_jpim1 480 DO_2D_00_00 544 481 #if defined key_si3 545 546 482 zmxlm(ji,jj,1) = ( ( 1._wp - fr_i(ji,jj) ) * zraug * taum(ji,jj) + & 483 & fr_i(ji,jj) * hm_i(ji,jj) * 2._wp ) * tmask(ji,jj,1) 547 484 #elif defined key_cice 548 549 550 485 zmaxice = MAXVAL( h_i(ji,jj,:) ) 486 zmxlm(ji,jj,1) = ( ( 1._wp - fr_i(ji,jj) ) * zraug * taum(ji,jj) + & 487 & fr_i(ji,jj) * zmaxice ) * tmask(ji,jj,1) 551 488 #endif 552 END DO 553 END DO 489 END_2D 554 490 ! 555 491 CASE( 3 ) ! scaling with max sea-ice thickness 556 DO jj = 2, jpjm1 557 DO ji = fs_2, fs_jpim1 558 zmaxice = MAXVAL( h_i(ji,jj,:) ) 559 zmxlm(ji,jj,1) = ( ( 1._wp - fr_i(ji,jj) ) * zraug * taum(ji,jj) + & 560 & fr_i(ji,jj) * zmaxice ) * tmask(ji,jj,1) 561 END DO 562 END DO 492 DO_2D_00_00 493 zmaxice = MAXVAL( h_i(ji,jj,:) ) 494 zmxlm(ji,jj,1) = ( ( 1._wp - fr_i(ji,jj) ) * zraug * taum(ji,jj) + & 495 & fr_i(ji,jj) * zmaxice ) * tmask(ji,jj,1) 496 END_2D 563 497 ! 564 498 END SELECT 565 499 #endif 566 500 ! 567 DO jj = 2, jpjm1 568 DO ji = fs_2, fs_jpim1 569 zmxlm(ji,jj,1) = MAX( rn_mxl0, zmxlm(ji,jj,1) ) 570 END DO 571 END DO 501 DO_2D_00_00 502 zmxlm(ji,jj,1) = MAX( rn_mxl0, zmxlm(ji,jj,1) ) 503 END_2D 572 504 ! 573 505 ELSE … … 575 507 ENDIF 576 508 ! 577 DO jk = 2, jpkm1 ! interior value : l=sqrt(2*e/n^2) 578 DO jj = 2, jpjm1 579 DO ji = fs_2, fs_jpim1 ! vector opt. 580 zrn2 = MAX( rn2(ji,jj,jk), rsmall ) 581 zmxlm(ji,jj,jk) = MAX( rmxl_min, SQRT( 2._wp * en(ji,jj,jk) / zrn2 ) ) 582 END DO 583 END DO 584 END DO 509 DO_3D_00_00( 2, jpkm1 ) 510 zrn2 = MAX( rn2(ji,jj,jk), rsmall ) 511 zmxlm(ji,jj,jk) = MAX( rmxl_min, SQRT( 2._wp * en(ji,jj,jk) / zrn2 ) ) 512 END_3D 585 513 ! 586 514 ! !* Physical limits for the mixing length … … 594 522 ! where wmask = 0 set zmxlm == p_e3w 595 523 CASE ( 0 ) ! bounded by the distance to surface and bottom 596 DO jk = 2, jpkm1 597 DO jj = 2, jpjm1 598 DO ji = fs_2, fs_jpim1 ! vector opt. 599 zemxl = MIN( pdepw(ji,jj,jk) - pdepw(ji,jj,mikt(ji,jj)), zmxlm(ji,jj,jk), & 600 & pdepw(ji,jj,mbkt(ji,jj)+1) - pdepw(ji,jj,jk) ) 601 ! wmask prevent zmxlm = 0 if jk = mikt(ji,jj) 602 zmxlm(ji,jj,jk) = zemxl * wmask(ji,jj,jk) + MIN( zmxlm(ji,jj,jk) , p_e3w(ji,jj,jk) ) * (1 - wmask(ji,jj,jk)) 603 zmxld(ji,jj,jk) = zemxl * wmask(ji,jj,jk) + MIN( zmxlm(ji,jj,jk) , p_e3w(ji,jj,jk) ) * (1 - wmask(ji,jj,jk)) 604 END DO 605 END DO 606 END DO 524 DO_3D_00_00( 2, jpkm1 ) 525 zemxl = MIN( pdepw(ji,jj,jk) - pdepw(ji,jj,mikt(ji,jj)), zmxlm(ji,jj,jk), & 526 & pdepw(ji,jj,mbkt(ji,jj)+1) - pdepw(ji,jj,jk) ) 527 ! wmask prevent zmxlm = 0 if jk = mikt(ji,jj) 528 zmxlm(ji,jj,jk) = zemxl * wmask(ji,jj,jk) + MIN( zmxlm(ji,jj,jk) , p_e3w(ji,jj,jk) ) * (1 - wmask(ji,jj,jk)) 529 zmxld(ji,jj,jk) = zemxl * wmask(ji,jj,jk) + MIN( zmxlm(ji,jj,jk) , p_e3w(ji,jj,jk) ) * (1 - wmask(ji,jj,jk)) 530 END_3D 607 531 ! 608 532 CASE ( 1 ) ! bounded by the vertical scale factor 609 DO jk = 2, jpkm1 610 DO jj = 2, jpjm1 611 DO ji = fs_2, fs_jpim1 ! vector opt. 612 zemxl = MIN( p_e3w(ji,jj,jk), zmxlm(ji,jj,jk) ) 613 zmxlm(ji,jj,jk) = zemxl 614 zmxld(ji,jj,jk) = zemxl 615 END DO 616 END DO 617 END DO 533 DO_3D_00_00( 2, jpkm1 ) 534 zemxl = MIN( p_e3w(ji,jj,jk), zmxlm(ji,jj,jk) ) 535 zmxlm(ji,jj,jk) = zemxl 536 zmxld(ji,jj,jk) = zemxl 537 END_3D 618 538 ! 619 539 CASE ( 2 ) ! |dk[xml]| bounded by e3t : 620 DO jk = 2, jpkm1 ! from the surface to the bottom : 621 DO jj = 2, jpjm1 622 DO ji = fs_2, fs_jpim1 ! vector opt. 623 zmxlm(ji,jj,jk) = MIN( zmxlm(ji,jj,jk-1) + p_e3t(ji,jj,jk-1), zmxlm(ji,jj,jk) ) 624 END DO 625 END DO 626 END DO 627 DO jk = jpkm1, 2, -1 ! from the bottom to the surface : 628 DO jj = 2, jpjm1 629 DO ji = fs_2, fs_jpim1 ! vector opt. 630 zemxl = MIN( zmxlm(ji,jj,jk+1) + p_e3t(ji,jj,jk+1), zmxlm(ji,jj,jk) ) 631 zmxlm(ji,jj,jk) = zemxl 632 zmxld(ji,jj,jk) = zemxl 633 END DO 634 END DO 635 END DO 540 DO_3D_00_00( 2, jpkm1 ) 541 zmxlm(ji,jj,jk) = MIN( zmxlm(ji,jj,jk-1) + p_e3t(ji,jj,jk-1), zmxlm(ji,jj,jk) ) 542 END_3D 543 DO_3D_00_00( jpkm1, 2, -1 ) 544 zemxl = MIN( zmxlm(ji,jj,jk+1) + p_e3t(ji,jj,jk+1), zmxlm(ji,jj,jk) ) 545 zmxlm(ji,jj,jk) = zemxl 546 zmxld(ji,jj,jk) = zemxl 547 END_3D 636 548 ! 637 549 CASE ( 3 ) ! lup and ldown, |dk[xml]| bounded by e3t : 638 DO jk = 2, jpkm1 ! from the surface to the bottom : lup 639 DO jj = 2, jpjm1 640 DO ji = fs_2, fs_jpim1 ! vector opt. 641 zmxld(ji,jj,jk) = MIN( zmxld(ji,jj,jk-1) + p_e3t(ji,jj,jk-1), zmxlm(ji,jj,jk) ) 642 END DO 643 END DO 644 END DO 645 DO jk = jpkm1, 2, -1 ! from the bottom to the surface : ldown 646 DO jj = 2, jpjm1 647 DO ji = fs_2, fs_jpim1 ! vector opt. 648 zmxlm(ji,jj,jk) = MIN( zmxlm(ji,jj,jk+1) + p_e3t(ji,jj,jk+1), zmxlm(ji,jj,jk) ) 649 END DO 650 END DO 651 END DO 652 DO jk = 2, jpkm1 653 DO jj = 2, jpjm1 654 DO ji = fs_2, fs_jpim1 ! vector opt. 655 zemlm = MIN ( zmxld(ji,jj,jk), zmxlm(ji,jj,jk) ) 656 zemlp = SQRT( zmxld(ji,jj,jk) * zmxlm(ji,jj,jk) ) 657 zmxlm(ji,jj,jk) = zemlm 658 zmxld(ji,jj,jk) = zemlp 659 END DO 660 END DO 661 END DO 550 DO_3D_00_00( 2, jpkm1 ) 551 zmxld(ji,jj,jk) = MIN( zmxld(ji,jj,jk-1) + p_e3t(ji,jj,jk-1), zmxlm(ji,jj,jk) ) 552 END_3D 553 DO_3D_00_00( jpkm1, 2, -1 ) 554 zmxlm(ji,jj,jk) = MIN( zmxlm(ji,jj,jk+1) + p_e3t(ji,jj,jk+1), zmxlm(ji,jj,jk) ) 555 END_3D 556 DO_3D_00_00( 2, jpkm1 ) 557 zemlm = MIN ( zmxld(ji,jj,jk), zmxlm(ji,jj,jk) ) 558 zemlp = SQRT( zmxld(ji,jj,jk) * zmxlm(ji,jj,jk) ) 559 zmxlm(ji,jj,jk) = zemlm 560 zmxld(ji,jj,jk) = zemlp 561 END_3D 662 562 ! 663 563 END SELECT … … 666 566 ! ! Vertical eddy viscosity and diffusivity (avm and avt) 667 567 ! !<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<< 668 DO jk = 1, jpkm1 !* vertical eddy viscosity & diffivity at w-points 669 DO jj = 2, jpjm1 670 DO ji = fs_2, fs_jpim1 ! vector opt. 671 zsqen = SQRT( en(ji,jj,jk) ) 672 zav = rn_ediff * zmxlm(ji,jj,jk) * zsqen 673 p_avm(ji,jj,jk) = MAX( zav, avmb(jk) ) * wmask(ji,jj,jk) 674 p_avt(ji,jj,jk) = MAX( zav, avtb_2d(ji,jj) * avtb(jk) ) * wmask(ji,jj,jk) 675 dissl(ji,jj,jk) = zsqen / zmxld(ji,jj,jk) 676 END DO 677 END DO 678 END DO 568 DO_3D_00_00( 1, jpkm1 ) 569 zsqen = SQRT( en(ji,jj,jk) ) 570 zav = rn_ediff * zmxlm(ji,jj,jk) * zsqen 571 p_avm(ji,jj,jk) = MAX( zav, avmb(jk) ) * wmask(ji,jj,jk) 572 p_avt(ji,jj,jk) = MAX( zav, avtb_2d(ji,jj) * avtb(jk) ) * wmask(ji,jj,jk) 573 dissl(ji,jj,jk) = zsqen / zmxld(ji,jj,jk) 574 END_3D 679 575 ! 680 576 ! 681 577 IF( nn_pdl == 1 ) THEN !* Prandtl number case: update avt 682 DO jk = 2, jpkm1 683 DO jj = 2, jpjm1 684 DO ji = fs_2, fs_jpim1 ! vector opt. 685 p_avt(ji,jj,jk) = MAX( apdlr(ji,jj,jk) * p_avt(ji,jj,jk), avtb_2d(ji,jj) * avtb(jk) ) * wmask(ji,jj,jk) 686 END DO 687 END DO 688 END DO 578 DO_3D_00_00( 2, jpkm1 ) 579 p_avt(ji,jj,jk) = MAX( apdlr(ji,jj,jk) * p_avt(ji,jj,jk), avtb_2d(ji,jj) * avtb(jk) ) * wmask(ji,jj,jk) 580 END_3D 689 581 ENDIF 690 582 ! -
NEMO/branches/2020/temporary_r4_trunk/src/TOP/PISCES/P4Z/p4zfechem.F90
r13466 r13469 89 89 ! Chemistry is supposed to be fast enough to be at equilibrium 90 90 ! ------------------------------------------------------------ 91 DO jk = 1, jpkm1 92 DO jj = 1, jpj 93 DO ji = 1, jpi 94 zTL1(ji,jj,jk) = ztotlig(ji,jj,jk) 95 zkeq = fekeq(ji,jj,jk) 96 zfesatur = zTL1(ji,jj,jk) * 1E-9 97 ztfe = trb(ji,jj,jk,jpfer) 98 ! Fe' is the root of a 2nd order polynom 99 zFe3 (ji,jj,jk) = ( -( 1. + zfesatur * zkeq - zkeq * ztfe ) & 100 & + SQRT( ( 1. + zfesatur * zkeq - zkeq * ztfe )**2 & 101 & + 4. * ztfe * zkeq) ) / ( 2. * zkeq ) 102 zFe3 (ji,jj,jk) = zFe3(ji,jj,jk) * 1E9 103 zFeL1(ji,jj,jk) = MAX( 0., trb(ji,jj,jk,jpfer) * 1E9 - zFe3(ji,jj,jk) ) 104 END DO 105 END DO 106 END DO 91 DO_3D_11_11( 1, jpkm1 ) 92 zTL1(ji,jj,jk) = ztotlig(ji,jj,jk) 93 zkeq = fekeq(ji,jj,jk) 94 zfesatur = zTL1(ji,jj,jk) * 1E-9 95 ztfe = trb(ji,jj,jk,jpfer) 96 ! Fe' is the root of a 2nd order polynom 97 zFe3 (ji,jj,jk) = ( -( 1. + zfesatur * zkeq - zkeq * ztfe ) & 98 & + SQRT( ( 1. + zfesatur * zkeq - zkeq * ztfe )**2 & 99 & + 4. * ztfe * zkeq) ) / ( 2. * zkeq ) 100 zFe3 (ji,jj,jk) = zFe3(ji,jj,jk) * 1E9 101 zFeL1(ji,jj,jk) = MAX( 0., trb(ji,jj,jk,jpfer) * 1E9 - zFe3(ji,jj,jk) ) 102 END_3D 107 103 ! 108 104 109 105 zdust = 0. ! if no dust available 110 DO jk = 1, jpkm1 111 DO jj = 1, jpj 112 DO ji = 1, jpi 113 ! Scavenging rate of iron. This scavenging rate depends on the load of particles of sea water. 114 ! This parameterization assumes a simple second order kinetics (k[Particles][Fe]). 115 ! Scavenging onto dust is also included as evidenced from the DUNE experiments. 116 ! -------------------------------------------------------------------------------------- 117 zhplus = max( rtrn, hi(ji,jj,jk) ) 118 fe3sol = fesol(ji,jj,jk,1) * ( zhplus**3 + fesol(ji,jj,jk,2) * zhplus**2 & 119 & + fesol(ji,jj,jk,3) * zhplus + fesol(ji,jj,jk,4) & 120 & + fesol(ji,jj,jk,5) / zhplus ) 121 ! 122 zfeequi = zFe3(ji,jj,jk) * 1E-9 123 zfecoll = 0.5 * zFeL1(ji,jj,jk) * 1E-9 124 ! precipitation of Fe3+, creation of nanoparticles 125 precip(ji,jj,jk) = MAX( 0., ( zFe3(ji,jj,jk) * 1E-9 - fe3sol ) ) * kfep * xstep 126 ! 127 ztrc = ( trb(ji,jj,jk,jppoc) + trb(ji,jj,jk,jpgoc) + trb(ji,jj,jk,jpcal) + trb(ji,jj,jk,jpgsi) ) * 1.e6 128 IF( ln_dust ) zdust = dust(ji,jj) / ( wdust / rday ) * tmask(ji,jj,jk) & 129 & * EXP( -gdept_n(ji,jj,jk) / 540. ) 130 IF (ln_ligand) THEN 131 zxlam = xlam1 * MAX( 1.E-3, EXP(-2 * etot(ji,jj,jk) / 10. ) * (1. - EXP(-2 * trb(ji,jj,jk,jpoxy) / 100.E-6 ) )) 132 ELSE 133 zxlam = xlam1 * 1.0 134 ENDIF 135 zlam1b = 3.e-5 + xlamdust * zdust + zxlam * ztrc 136 zscave = zfeequi * zlam1b * xstep 137 138 ! Compute the different ratios for scavenging of iron 139 ! to later allocate scavenged iron to the different organic pools 140 ! --------------------------------------------------------- 141 zdenom1 = zxlam * trb(ji,jj,jk,jppoc) / zlam1b 142 zdenom2 = zxlam * trb(ji,jj,jk,jpgoc) / zlam1b 143 144 ! Increased scavenging for very high iron concentrations found near the coasts 145 ! due to increased lithogenic particles and let say it is unknown processes (precipitation, ...) 146 ! ----------------------------------------------------------- 147 zlamfac = MAX( 0.e0, ( gphit(ji,jj) + 55.) / 30. ) 148 zlamfac = MIN( 1. , zlamfac ) 149 zdep = MIN( 1., 1000. / gdept_n(ji,jj,jk) ) 150 zcoag = 1E-4 * ( 1. - zlamfac ) * zdep * xstep * trb(ji,jj,jk,jpfer) 151 152 ! Compute the coagulation of colloidal iron. This parameterization 153 ! could be thought as an equivalent of colloidal pumping. 154 ! It requires certainly some more work as it is very poorly constrained. 155 ! ---------------------------------------------------------------- 156 zlam1a = ( 0.369 * 0.3 * trb(ji,jj,jk,jpdoc) + 102.4 * trb(ji,jj,jk,jppoc) ) * xdiss(ji,jj,jk) & 157 & + ( 114. * 0.3 * trb(ji,jj,jk,jpdoc) ) 158 zaggdfea = zlam1a * xstep * zfecoll 159 ! 160 zlam1b = 3.53E3 * trb(ji,jj,jk,jpgoc) * xdiss(ji,jj,jk) 161 zaggdfeb = zlam1b * xstep * zfecoll 162 ! 163 tra(ji,jj,jk,jpfer) = tra(ji,jj,jk,jpfer) - zscave - zaggdfea - zaggdfeb & 164 & - zcoag - precip(ji,jj,jk) 165 tra(ji,jj,jk,jpsfe) = tra(ji,jj,jk,jpsfe) + zscave * zdenom1 + zaggdfea 166 tra(ji,jj,jk,jpbfe) = tra(ji,jj,jk,jpbfe) + zscave * zdenom2 + zaggdfeb 167 zscav3d(ji,jj,jk) = zscave 168 zcoll3d(ji,jj,jk) = zaggdfea + zaggdfeb 169 ! 170 END DO 171 END DO 172 END DO 106 DO_3D_11_11( 1, jpkm1 ) 107 ! Scavenging rate of iron. This scavenging rate depends on the load of particles of sea water. 108 ! This parameterization assumes a simple second order kinetics (k[Particles][Fe]). 109 ! Scavenging onto dust is also included as evidenced from the DUNE experiments. 110 ! -------------------------------------------------------------------------------------- 111 zhplus = max( rtrn, hi(ji,jj,jk) ) 112 fe3sol = fesol(ji,jj,jk,1) * ( zhplus**3 + fesol(ji,jj,jk,2) * zhplus**2 & 113 & + fesol(ji,jj,jk,3) * zhplus + fesol(ji,jj,jk,4) & 114 & + fesol(ji,jj,jk,5) / zhplus ) 115 ! 116 zfeequi = zFe3(ji,jj,jk) * 1E-9 117 zfecoll = 0.5 * zFeL1(ji,jj,jk) * 1E-9 118 ! precipitation of Fe3+, creation of nanoparticles 119 precip(ji,jj,jk) = MAX( 0., ( zFe3(ji,jj,jk) * 1E-9 - fe3sol ) ) * kfep * xstep 120 ! 121 ztrc = ( trb(ji,jj,jk,jppoc) + trb(ji,jj,jk,jpgoc) + trb(ji,jj,jk,jpcal) + trb(ji,jj,jk,jpgsi) ) * 1.e6 122 IF( ln_dust ) zdust = dust(ji,jj) / ( wdust / rday ) * tmask(ji,jj,jk) & 123 & * EXP( -gdept_n(ji,jj,jk) / 540. ) 124 IF (ln_ligand) THEN 125 zxlam = xlam1 * MAX( 1.E-3, EXP(-2 * etot(ji,jj,jk) / 10. ) * (1. - EXP(-2 * trb(ji,jj,jk,jpoxy) / 100.E-6 ) )) 126 ELSE 127 zxlam = xlam1 * 1.0 128 ENDIF 129 zlam1b = 3.e-5 + xlamdust * zdust + zxlam * ztrc 130 zscave = zfeequi * zlam1b * xstep 131 132 ! Compute the different ratios for scavenging of iron 133 ! to later allocate scavenged iron to the different organic pools 134 ! --------------------------------------------------------- 135 zdenom1 = zxlam * trb(ji,jj,jk,jppoc) / zlam1b 136 zdenom2 = zxlam * trb(ji,jj,jk,jpgoc) / zlam1b 137 138 ! Increased scavenging for very high iron concentrations found near the coasts 139 ! due to increased lithogenic particles and let say it is unknown processes (precipitation, ...) 140 ! ----------------------------------------------------------- 141 zlamfac = MAX( 0.e0, ( gphit(ji,jj) + 55.) / 30. ) 142 zlamfac = MIN( 1. , zlamfac ) 143 zdep = MIN( 1., 1000. / gdept_n(ji,jj,jk) ) 144 zcoag = 1E-4 * ( 1. - zlamfac ) * zdep * xstep * trb(ji,jj,jk,jpfer) 145 146 ! Compute the coagulation of colloidal iron. This parameterization 147 ! could be thought as an equivalent of colloidal pumping. 148 ! It requires certainly some more work as it is very poorly constrained. 149 ! ---------------------------------------------------------------- 150 zlam1a = ( 0.369 * 0.3 * trb(ji,jj,jk,jpdoc) + 102.4 * trb(ji,jj,jk,jppoc) ) * xdiss(ji,jj,jk) & 151 & + ( 114. * 0.3 * trb(ji,jj,jk,jpdoc) ) 152 zaggdfea = zlam1a * xstep * zfecoll 153 ! 154 zlam1b = 3.53E3 * trb(ji,jj,jk,jpgoc) * xdiss(ji,jj,jk) 155 zaggdfeb = zlam1b * xstep * zfecoll 156 ! 157 tra(ji,jj,jk,jpfer) = tra(ji,jj,jk,jpfer) - zscave - zaggdfea - zaggdfeb & 158 & - zcoag - precip(ji,jj,jk) 159 tra(ji,jj,jk,jpsfe) = tra(ji,jj,jk,jpsfe) + zscave * zdenom1 + zaggdfea 160 tra(ji,jj,jk,jpbfe) = tra(ji,jj,jk,jpbfe) + zscave * zdenom2 + zaggdfeb 161 zscav3d(ji,jj,jk) = zscave 162 zcoll3d(ji,jj,jk) = zaggdfea + zaggdfeb 163 ! 164 END_3D 173 165 ! 174 166 ! Define the bioavailable fraction of iron … … 178 170 IF( ln_ligand ) THEN 179 171 ! 180 DO jk = 1, jpkm1 181 DO jj = 1, jpj 182 DO ji = 1, jpi 183 zlam1a = ( 0.369 * 0.3 * trb(ji,jj,jk,jpdoc) + 102.4 * trb(ji,jj,jk,jppoc) ) * xdiss(ji,jj,jk) & 184 & + ( 114. * 0.3 * trb(ji,jj,jk,jpdoc) ) 185 ! 186 zlam1b = 3.53E3 * trb(ji,jj,jk,jpgoc) * xdiss(ji,jj,jk) 187 zligco = 0.5 * trn(ji,jj,jk,jplgw) 188 zaggliga = zlam1a * xstep * zligco 189 zaggligb = zlam1b * xstep * zligco 190 tra(ji,jj,jk,jplgw) = tra(ji,jj,jk,jplgw) - zaggliga - zaggligb 191 zlcoll3d(ji,jj,jk) = zaggliga + zaggligb 192 END DO 193 END DO 194 END DO 172 DO_3D_11_11( 1, jpkm1 ) 173 zlam1a = ( 0.369 * 0.3 * trb(ji,jj,jk,jpdoc) + 102.4 * trb(ji,jj,jk,jppoc) ) * xdiss(ji,jj,jk) & 174 & + ( 114. * 0.3 * trb(ji,jj,jk,jpdoc) ) 175 ! 176 zlam1b = 3.53E3 * trb(ji,jj,jk,jpgoc) * xdiss(ji,jj,jk) 177 zligco = 0.5 * trn(ji,jj,jk,jplgw) 178 zaggliga = zlam1a * xstep * zligco 179 zaggligb = zlam1b * xstep * zligco 180 tra(ji,jj,jk,jplgw) = tra(ji,jj,jk,jplgw) - zaggliga - zaggligb 181 zlcoll3d(ji,jj,jk) = zaggliga + zaggligb 182 END_3D 195 183 ! 196 184 plig(:,:,:) = MAX( 0., ( ( zFeL1(:,:,:) * 1E-9 ) / ( trb(:,:,:,jpfer) +rtrn ) ) ) -
NEMO/branches/2020/temporary_r4_trunk/src/TOP/PISCES/P4Z/p4zsbc.F90
r13466 r13469 126 126 CALL fld_read( kt, 1, sf_river ) 127 127 IF( ln_p4z ) THEN 128 DO jj = 1, jpj 129 DO ji = 1, jpi 130 zcoef = ryyss * e1e2t(ji,jj) * h_rnf(ji,jj) 131 rivalk(ji,jj) = sf_river(jr_dic)%fnow(ji,jj,1) & 132 & * 1.E3 / ( 12. * zcoef + rtrn ) 133 rivdic(ji,jj) = sf_river(jr_dic)%fnow(ji,jj,1) & 134 & * 1.E3 / ( 12. * zcoef + rtrn ) 135 rivdin(ji,jj) = sf_river(jr_din)%fnow(ji,jj,1) & 136 & * 1.E3 / rno3 / ( 14. * zcoef + rtrn ) 137 rivdip(ji,jj) = sf_river(jr_dip)%fnow(ji,jj,1) & 138 & * 1.E3 / po4r / ( 31. * zcoef + rtrn ) 139 rivdsi(ji,jj) = sf_river(jr_dsi)%fnow(ji,jj,1) & 140 & * 1.E3 / ( 28.1 * zcoef + rtrn ) 141 rivdoc(ji,jj) = sf_river(jr_doc)%fnow(ji,jj,1) & 142 & * 1.E3 / ( 12. * zcoef + rtrn ) 143 END DO 144 END DO 128 DO_2D_11_11 129 zcoef = ryyss * e1e2t(ji,jj) * h_rnf(ji,jj) 130 rivalk(ji,jj) = sf_river(jr_dic)%fnow(ji,jj,1) & 131 & * 1.E3 / ( 12. * zcoef + rtrn ) 132 rivdic(ji,jj) = sf_river(jr_dic)%fnow(ji,jj,1) & 133 & * 1.E3 / ( 12. * zcoef + rtrn ) 134 rivdin(ji,jj) = sf_river(jr_din)%fnow(ji,jj,1) & 135 & * 1.E3 / rno3 / ( 14. * zcoef + rtrn ) 136 rivdip(ji,jj) = sf_river(jr_dip)%fnow(ji,jj,1) & 137 & * 1.E3 / po4r / ( 31. * zcoef + rtrn ) 138 rivdsi(ji,jj) = sf_river(jr_dsi)%fnow(ji,jj,1) & 139 & * 1.E3 / ( 28.1 * zcoef + rtrn ) 140 rivdoc(ji,jj) = sf_river(jr_doc)%fnow(ji,jj,1) & 141 & * 1.E3 / ( 12. * zcoef + rtrn ) 142 END_2D 145 143 ELSE ! ln_p5z 146 DO jj = 1, jpj 147 DO ji = 1, jpi 148 zcoef = ryyss * e1e2t(ji,jj) * h_rnf(ji,jj) 149 rivalk(ji,jj) = sf_river(jr_dic)%fnow(ji,jj,1) & 150 & * 1.E3 / ( 12. * zcoef + rtrn ) 151 rivdic(ji,jj) = ( sf_river(jr_dic)%fnow(ji,jj,1) ) & 152 & * 1.E3 / ( 12. * zcoef + rtrn ) * tmask(ji,jj,1) 153 rivdin(ji,jj) = ( sf_river(jr_din)%fnow(ji,jj,1) ) & 154 & * 1.E3 / rno3 / ( 14. * zcoef + rtrn ) * tmask(ji,jj,1) 155 rivdip(ji,jj) = ( sf_river(jr_dip)%fnow(ji,jj,1) ) & 156 & * 1.E3 / po4r / ( 31. * zcoef + rtrn ) * tmask(ji,jj,1) 157 rivdon(ji,jj) = ( sf_river(jr_don)%fnow(ji,jj,1) ) & 158 & * 1.E3 / rno3 / ( 14. * zcoef + rtrn ) * tmask(ji,jj,1) 159 rivdop(ji,jj) = ( sf_river(jr_dop)%fnow(ji,jj,1) ) & 160 & * 1.E3 / po4r / ( 31. * zcoef + rtrn ) * tmask(ji,jj,1) 161 rivdsi(ji,jj) = sf_river(jr_dsi)%fnow(ji,jj,1) & 162 & * 1.E3 / ( 28.1 * zcoef + rtrn ) 163 rivdoc(ji,jj) = sf_river(jr_doc)%fnow(ji,jj,1) & 164 & * 1.E3 / ( 12. * zcoef + rtrn ) 165 END DO 166 END DO 144 DO_2D_11_11 145 zcoef = ryyss * e1e2t(ji,jj) * h_rnf(ji,jj) 146 rivalk(ji,jj) = sf_river(jr_dic)%fnow(ji,jj,1) & 147 & * 1.E3 / ( 12. * zcoef + rtrn ) 148 rivdic(ji,jj) = ( sf_river(jr_dic)%fnow(ji,jj,1) ) & 149 & * 1.E3 / ( 12. * zcoef + rtrn ) * tmask(ji,jj,1) 150 rivdin(ji,jj) = ( sf_river(jr_din)%fnow(ji,jj,1) ) & 151 & * 1.E3 / rno3 / ( 14. * zcoef + rtrn ) * tmask(ji,jj,1) 152 rivdip(ji,jj) = ( sf_river(jr_dip)%fnow(ji,jj,1) ) & 153 & * 1.E3 / po4r / ( 31. * zcoef + rtrn ) * tmask(ji,jj,1) 154 rivdon(ji,jj) = ( sf_river(jr_don)%fnow(ji,jj,1) ) & 155 & * 1.E3 / rno3 / ( 14. * zcoef + rtrn ) * tmask(ji,jj,1) 156 rivdop(ji,jj) = ( sf_river(jr_dop)%fnow(ji,jj,1) ) & 157 & * 1.E3 / po4r / ( 31. * zcoef + rtrn ) * tmask(ji,jj,1) 158 rivdsi(ji,jj) = sf_river(jr_dsi)%fnow(ji,jj,1) & 159 & * 1.E3 / ( 28.1 * zcoef + rtrn ) 160 rivdoc(ji,jj) = sf_river(jr_doc)%fnow(ji,jj,1) & 161 & * 1.E3 / ( 12. * zcoef + rtrn ) 162 END_2D 167 163 ENDIF 168 164 ENDIF … … 411 407 IF(lwp) WRITE(numout,*) 412 408 IF(lwp) WRITE(numout,*) ' Level corresponding to 50m depth ', ik50,' ', gdept_1d(ik50+1) 413 DO jk = 1, ik50 414 DO jj = 2, jpjm1 415 DO ji = fs_2, fs_jpim1 416 ze3t = e3t_0(ji,jj,jk) 417 zsurfc = e1u(ji,jj) * ( 1. - umask(ji ,jj ,jk) ) & 418 + e1u(ji,jj) * ( 1. - umask(ji-1,jj ,jk) ) & 419 + e2v(ji,jj) * ( 1. - vmask(ji ,jj ,jk) ) & 420 + e2v(ji,jj) * ( 1. - vmask(ji ,jj-1,jk) ) 421 zsurfp = zsurfc * ze3t / e1e2t(ji,jj) 422 ! estimation of the coastal slope : 5 km off the coast 423 ze3t2 = ze3t * ze3t 424 zcslp = SQRT( ( distcoast*distcoast + ze3t2 ) / ze3t2 ) 425 ! 426 zcmask(ji,jj,jk) = zcmask(ji,jj,jk) + zcslp * zsurfp 427 END DO 428 END DO 429 END DO 409 DO_3D_00_00( 1, ik50 ) 410 ze3t = e3t_0(ji,jj,jk) 411 zsurfc = e1u(ji,jj) * ( 1. - umask(ji ,jj ,jk) ) & 412 + e1u(ji,jj) * ( 1. - umask(ji-1,jj ,jk) ) & 413 + e2v(ji,jj) * ( 1. - vmask(ji ,jj ,jk) ) & 414 + e2v(ji,jj) * ( 1. - vmask(ji ,jj-1,jk) ) 415 zsurfp = zsurfc * ze3t / e1e2t(ji,jj) 416 ! estimation of the coastal slope : 5 km off the coast 417 ze3t2 = ze3t * ze3t 418 zcslp = SQRT( ( distcoast*distcoast + ze3t2 ) / ze3t2 ) 419 ! 420 zcmask(ji,jj,jk) = zcmask(ji,jj,jk) + zcslp * zsurfp 421 END_3D 430 422 ! 431 423 CALL lbc_lnk( 'p4zsbc', zcmask , 'T', 1. ) ! lateral boundary conditions on cmask (sign unchanged) 432 424 ! 433 DO jk = 1, jpk 434 DO jj = 1, jpj 435 DO ji = 1, jpi 436 zexpide = MIN( 8.,( gdept_n(ji,jj,jk) / 500. )**(-1.5) ) 437 zdenitide = -0.9543 + 0.7662 * LOG( zexpide ) - 0.235 * LOG( zexpide )**2 438 zcmask(ji,jj,jk) = zcmask(ji,jj,jk) * MIN( 1., EXP( zdenitide ) / 0.5 ) 439 END DO 440 END DO 441 END DO 425 DO_3D_11_11( 1, jpk ) 426 zexpide = MIN( 8.,( gdept_n(ji,jj,jk) / 500. )**(-1.5) ) 427 zdenitide = -0.9543 + 0.7662 * LOG( zexpide ) - 0.235 * LOG( zexpide )**2 428 zcmask(ji,jj,jk) = zcmask(ji,jj,jk) * MIN( 1., EXP( zdenitide ) / 0.5 ) 429 END_3D 442 430 ! Coastal supply of iron 443 431 ! ------------------------- -
NEMO/branches/2020/temporary_r4_trunk/src/TOP/PISCES/P4Z/p4zsms.F90
r13467 r13469 127 127 xnegtr(:,:,:) = 1.e0 128 128 DO jn = jp_pcs0, jp_pcs1 129 DO jk = 1, jpk 130 DO jj = 1, jpj 131 DO ji = 1, jpi 132 IF( ( trb(ji,jj,jk,jn) + tra(ji,jj,jk,jn) ) < 0.e0 ) THEN 133 ztra = ABS( trb(ji,jj,jk,jn) ) / ( ABS( tra(ji,jj,jk,jn) ) + rtrn ) 134 xnegtr(ji,jj,jk) = MIN( xnegtr(ji,jj,jk), ztra ) 135 ENDIF 136 END DO 137 END DO 138 END DO 129 DO_3D_11_11( 1, jpk ) 130 IF( ( trb(ji,jj,jk,jn) + tra(ji,jj,jk,jn) ) < 0.e0 ) THEN 131 ztra = ABS( trb(ji,jj,jk,jn) ) / ( ABS( tra(ji,jj,jk,jn) ) + rtrn ) 132 xnegtr(ji,jj,jk) = MIN( xnegtr(ji,jj,jk), ztra ) 133 ENDIF 134 END_3D 139 135 END DO 140 136 ! ! where at least 1 tracer concentration becomes negative -
NEMO/branches/2020/temporary_r4_trunk/tests/CANAL/MY_SRC/diawri.F90
r13466 r13469 150 150 CALL iom_put( "sst", tsn(:,:,1,jp_tem) ) ! surface temperature 151 151 IF ( iom_use("sbt") ) THEN 152 DO jj = 1, jpj 153 DO ji = 1, jpi 154 ikbot = mbkt(ji,jj) 155 z2d(ji,jj) = tsn(ji,jj,ikbot,jp_tem) 156 END DO 157 END DO 152 DO_2D_11_11 153 ikbot = mbkt(ji,jj) 154 z2d(ji,jj) = tsn(ji,jj,ikbot,jp_tem) 155 END_2D 158 156 CALL iom_put( "sbt", z2d ) ! bottom temperature 159 157 ENDIF … … 162 160 CALL iom_put( "sss", tsn(:,:,1,jp_sal) ) ! surface salinity 163 161 IF ( iom_use("sbs") ) THEN 164 DO jj = 1, jpj 165 DO ji = 1, jpi 166 ikbot = mbkt(ji,jj) 167 z2d(ji,jj) = tsn(ji,jj,ikbot,jp_sal) 168 END DO 169 END DO 162 DO_2D_11_11 163 ikbot = mbkt(ji,jj) 164 z2d(ji,jj) = tsn(ji,jj,ikbot,jp_sal) 165 END_2D 170 166 CALL iom_put( "sbs", z2d ) ! bottom salinity 171 167 ENDIF … … 174 170 zztmp = rau0 * 0.25 175 171 z2d(:,:) = 0._wp 176 DO jj = 2, jpjm1 177 DO ji = fs_2, fs_jpim1 ! vector opt. 178 zztmp2 = ( ( rCdU_bot(ji+1,jj)+rCdU_bot(ji ,jj) ) * un(ji ,jj,mbku(ji ,jj)) )**2 & 179 & + ( ( rCdU_bot(ji ,jj)+rCdU_bot(ji-1,jj) ) * un(ji-1,jj,mbku(ji-1,jj)) )**2 & 180 & + ( ( rCdU_bot(ji,jj+1)+rCdU_bot(ji,jj ) ) * vn(ji,jj ,mbkv(ji,jj )) )**2 & 181 & + ( ( rCdU_bot(ji,jj )+rCdU_bot(ji,jj-1) ) * vn(ji,jj-1,mbkv(ji,jj-1)) )**2 182 z2d(ji,jj) = zztmp * SQRT( zztmp2 ) * tmask(ji,jj,1) 183 ! 184 END DO 185 END DO 172 DO_2D_00_00 173 zztmp2 = ( ( rCdU_bot(ji+1,jj)+rCdU_bot(ji ,jj) ) * uu(ji ,jj,mbku(ji ,jj),Nii) )**2 & 174 & + ( ( rCdU_bot(ji ,jj)+rCdU_bot(ji-1,jj) ) * uu(ji-1,jj,mbku(ji-1,jj),Nii) )**2 & 175 & + ( ( rCdU_bot(ji,jj+1)+rCdU_bot(ji,jj ) ) * vv(ji,jj ,mbkv(ji,jj ),Nii) )**2 & 176 & + ( ( rCdU_bot(ji,jj )+rCdU_bot(ji,jj-1) ) * vv(ji,jj-1,mbkv(ji,jj-1),Nii) )**2 177 z2d(ji,jj) = zztmp * SQRT( zztmp2 ) * tmask(ji,jj,1) 178 ! 179 END_2D 186 180 CALL lbc_lnk( 'diawri', z2d, 'T', 1. ) 187 181 CALL iom_put( "taubot", z2d ) 188 182 ENDIF 189 183 190 CALL iom_put( "uoce", u n(:,:,:) ) ! 3D i-current191 CALL iom_put( "ssu", u n(:,:,1) ) ! surface i-current184 CALL iom_put( "uoce", uu(:,:,:,Nii) ) ! 3D i-current 185 CALL iom_put( "ssu", uu(:,:,1,Nii) ) ! surface i-current 192 186 IF ( iom_use("sbu") ) THEN 193 DO jj = 1, jpj 194 DO ji = 1, jpi 195 ikbot = mbku(ji,jj) 196 z2d(ji,jj) = un(ji,jj,ikbot) 197 END DO 198 END DO 187 DO_2D_11_11 188 ikbot = mbku(ji,jj) 189 z2d(ji,jj) = uu(ji,jj,ikbot,Nii) 190 END_2D 199 191 CALL iom_put( "sbu", z2d ) ! bottom i-current 200 192 ENDIF 201 193 202 CALL iom_put( "voce", v n(:,:,:) ) ! 3D j-current203 CALL iom_put( "ssv", v n(:,:,1) ) ! surface j-current194 CALL iom_put( "voce", vv(:,:,:,Nii) ) ! 3D j-current 195 CALL iom_put( "ssv", vv(:,:,1,Nii) ) ! surface j-current 204 196 IF ( iom_use("sbv") ) THEN 205 DO jj = 1, jpj 206 DO ji = 1, jpi 207 ikbot = mbkv(ji,jj) 208 z2d(ji,jj) = vn(ji,jj,ikbot) 209 END DO 210 END DO 197 DO_2D_11_11 198 ikbot = mbkv(ji,jj) 199 z2d(ji,jj) = vv(ji,jj,ikbot,Nii) 200 END_2D 211 201 CALL iom_put( "sbv", z2d ) ! bottom j-current 212 202 ENDIF … … 217 207 z2d(:,:) = rau0 * e1e2t(:,:) 218 208 DO jk = 1, jpk 219 z3d(:,:,jk) = w n(:,:,jk) * z2d(:,:)209 z3d(:,:,jk) = ww(:,:,jk,Nii) * z2d(:,:) 220 210 END DO 221 211 CALL iom_put( "w_masstr" , z3d ) … … 232 222 IF ( iom_use("socegrad") .OR. iom_use("socegrad2") ) THEN 233 223 z3d(:,:,jpk) = 0. 234 DO jk = 1, jpkm1 235 DO jj = 2, jpjm1 ! sal gradient 236 DO ji = fs_2, fs_jpim1 ! vector opt. 237 zztmp = tsn(ji,jj,jk,jp_sal) 238 zztmpx = ( tsn(ji+1,jj,jk,jp_sal) - zztmp ) * r1_e1u(ji,jj) + ( zztmp - tsn(ji-1,jj ,jk,jp_sal) ) * r1_e1u(ji-1,jj) 239 zztmpy = ( tsn(ji,jj+1,jk,jp_sal) - zztmp ) * r1_e2v(ji,jj) + ( zztmp - tsn(ji ,jj-1,jk,jp_sal) ) * r1_e2v(ji,jj-1) 240 z3d(ji,jj,jk) = 0.25 * ( zztmpx * zztmpx + zztmpy * zztmpy ) & 241 & * umask(ji,jj,jk) * umask(ji-1,jj,jk) * vmask(ji,jj,jk) * umask(ji,jj-1,jk) 242 END DO 243 END DO 244 END DO 224 DO_3D_00_00( 1, jpkm1 ) 225 zztmp = tsn(ji,jj,jk,jp_sal) 226 zztmpx = ( tsn(ji+1,jj,jk,jp_sal) - zztmp ) * r1_e1u(ji,jj) + ( zztmp - tsn(ji-1,jj ,jk,jp_sal) ) * r1_e1u(ji-1,jj) 227 zztmpy = ( tsn(ji,jj+1,jk,jp_sal) - zztmp ) * r1_e2v(ji,jj) + ( zztmp - tsn(ji ,jj-1,jk,jp_sal) ) * r1_e2v(ji,jj-1) 228 z3d(ji,jj,jk) = 0.25 * ( zztmpx * zztmpx + zztmpy * zztmpy ) & 229 & * umask(ji,jj,jk) * umask(ji-1,jj,jk) * vmask(ji,jj,jk) * umask(ji,jj-1,jk) 230 END_3D 245 231 CALL lbc_lnk( 'diawri', z3d, 'T', 1. ) 246 232 CALL iom_put( "socegrad2", z3d ) ! square of module of sal gradient … … 250 236 251 237 IF ( iom_use("sstgrad") .OR. iom_use("sstgrad2") ) THEN 252 DO jj = 2, jpjm1 ! sst gradient 253 DO ji = fs_2, fs_jpim1 ! vector opt. 254 zztmp = tsn(ji,jj,1,jp_tem) 255 zztmpx = ( tsn(ji+1,jj,1,jp_tem) - zztmp ) * r1_e1u(ji,jj) + ( zztmp - tsn(ji-1,jj ,1,jp_tem) ) * r1_e1u(ji-1,jj) 256 zztmpy = ( tsn(ji,jj+1,1,jp_tem) - zztmp ) * r1_e2v(ji,jj) + ( zztmp - tsn(ji ,jj-1,1,jp_tem) ) * r1_e2v(ji,jj-1) 257 z2d(ji,jj) = 0.25 * ( zztmpx * zztmpx + zztmpy * zztmpy ) & 258 & * umask(ji,jj,1) * umask(ji-1,jj,1) * vmask(ji,jj,1) * umask(ji,jj-1,1) 259 END DO 260 END DO 238 DO_2D_00_00 239 zztmp = tsn(ji,jj,1,jp_tem) 240 zztmpx = ( tsn(ji+1,jj,1,jp_tem) - zztmp ) * r1_e1u(ji,jj) + ( zztmp - tsn(ji-1,jj ,1,jp_tem) ) * r1_e1u(ji-1,jj) 241 zztmpy = ( tsn(ji,jj+1,1,jp_tem) - zztmp ) * r1_e2v(ji,jj) + ( zztmp - tsn(ji ,jj-1,1,jp_tem) ) * r1_e2v(ji,jj-1) 242 z2d(ji,jj) = 0.25 * ( zztmpx * zztmpx + zztmpy * zztmpy ) & 243 & * umask(ji,jj,1) * umask(ji-1,jj,1) * vmask(ji,jj,1) * umask(ji,jj-1,1) 244 END_2D 261 245 CALL lbc_lnk( 'diawri', z2d, 'T', 1. ) 262 246 CALL iom_put( "sstgrad2", z2d ) ! square of module of sst gradient … … 268 252 IF( iom_use("heatc") ) THEN 269 253 z2d(:,:) = 0._wp 270 DO jk = 1, jpkm1 271 DO jj = 1, jpj 272 DO ji = 1, jpi 273 z2d(ji,jj) = z2d(ji,jj) + e3t_n(ji,jj,jk) * tsn(ji,jj,jk,jp_tem) * tmask(ji,jj,jk) 274 END DO 275 END DO 276 END DO 254 DO_3D_11_11( 1, jpkm1 ) 255 z2d(ji,jj) = z2d(ji,jj) + e3t_n(ji,jj,jk) * tsn(ji,jj,jk,jp_tem) * tmask(ji,jj,jk) 256 END_3D 277 257 CALL iom_put( "heatc", rau0_rcp * z2d ) ! vertically integrated heat content (J/m2) 278 258 ENDIF … … 280 260 IF( iom_use("saltc") ) THEN 281 261 z2d(:,:) = 0._wp 282 DO jk = 1, jpkm1 283 DO jj = 1, jpj 284 DO ji = 1, jpi 285 z2d(ji,jj) = z2d(ji,jj) + e3t_n(ji,jj,jk) * tsn(ji,jj,jk,jp_sal) * tmask(ji,jj,jk) 286 END DO 287 END DO 288 END DO 262 DO_3D_11_11( 1, jpkm1 ) 263 z2d(ji,jj) = z2d(ji,jj) + e3t_n(ji,jj,jk) * tsn(ji,jj,jk,jp_sal) * tmask(ji,jj,jk) 264 END_3D 289 265 CALL iom_put( "saltc", rau0 * z2d ) ! vertically integrated salt content (PSU*kg/m2) 290 266 ENDIF … … 292 268 IF( iom_use("salt2c") ) THEN 293 269 z2d(:,:) = 0._wp 294 DO jk = 1, jpkm1 295 DO jj = 1, jpj 296 DO ji = 1, jpi 297 z2d(ji,jj) = z2d(ji,jj) + e3t_n(ji,jj,jk) * tsn(ji,jj,jk,jp_sal) * tsn(ji,jj,jk,jp_sal) * tmask(ji,jj,jk) 298 END DO 299 END DO 300 END DO 270 DO_3D_11_11( 1, jpkm1 ) 271 z2d(ji,jj) = z2d(ji,jj) + e3t_n(ji,jj,jk) * tsn(ji,jj,jk,jp_sal) * tsn(ji,jj,jk,jp_sal) * tmask(ji,jj,jk) 272 END_3D 301 273 CALL iom_put( "salt2c", rau0 * z2d ) ! vertically integrated squared salt content (PSU*kg/m2) 302 274 ENDIF … … 304 276 IF ( iom_use("eken") .OR. iom_use("eken_int") ) THEN 305 277 z3d(:,:,jpk) = 0._wp 306 DO jk = 1, jpkm1 307 DO jj = 2, jpjm1 308 DO ji = 2, jpim1 309 zztmpx = 0.5 * ( un(ji-1,jj ,jk) + un(ji,jj,jk) ) 310 zztmpy = 0.5 * ( vn(ji ,jj-1,jk) + vn(ji,jj,jk) ) 311 z3d(ji,jj,jk) = 0.5 * ( zztmpx*zztmpx + zztmpy*zztmpy ) 312 END DO 313 END DO 314 END DO 278 DO_3D_00_00( 1, jpkm1 ) 279 zztmpx = 0.5 * ( uu(ji-1,jj ,jk,Nii) + uu(ji,jj,jk,Nii) ) 280 zztmpy = 0.5 * ( vv(ji ,jj-1,jk,Nii) + vv(ji,jj,jk,Nii) ) 281 z3d(ji,jj,jk) = 0.5 * ( zztmpx*zztmpx + zztmpy*zztmpy ) 282 END_3D 315 283 CALL lbc_lnk( 'diawri', z3d, 'T', 1. ) 316 284 CALL iom_put( "eken", z3d ) ! kinetic energy 317 285 318 286 z2d(:,:) = 0._wp 319 DO jk = 1, jpkm1 320 DO jj = 1, jpj 321 DO ji = 1, jpi 322 z2d(ji,jj) = z2d(ji,jj) + e3t_n(ji,jj,jk) * z3d(ji,jj,jk) * e1e2t(ji,jj) * tmask(ji,jj,jk) 323 END DO 324 END DO 325 END DO 287 DO_3D_11_11( 1, jpkm1 ) 288 z2d(ji,jj) = z2d(ji,jj) + e3t_n(ji,jj,jk) * z3d(ji,jj,jk) * e1e2t(ji,jj) * tmask(ji,jj,jk) 289 END_3D 326 290 CALL iom_put( "eken_int", z2d ) ! vertically integrated kinetic energy 327 291 ENDIF … … 332 296 333 297 z3d(:,:,jpk) = 0._wp 334 DO jk = 1, jpkm1 335 DO jj = 1, jpjm1 336 DO ji = 1, fs_jpim1 ! vector opt. 337 z3d(ji,jj,jk) = ( e2v(ji+1,jj ) * vn(ji+1,jj ,jk) - e2v(ji,jj) * vn(ji,jj,jk) & 338 & - e1u(ji ,jj+1) * un(ji ,jj+1,jk) + e1u(ji,jj) * un(ji,jj,jk) ) * r1_e1e2f(ji,jj) 339 END DO 340 END DO 341 END DO 298 DO_3D_10_10( 1, jpkm1 ) 299 z3d(ji,jj,jk) = ( e2v(ji+1,jj ) * vv(ji+1,jj ,jk,Nii) - e2v(ji,jj) * vv(ji,jj,jk,Nii) & 300 & - e1u(ji ,jj+1) * uu(ji ,jj+1,jk,Nii) + e1u(ji,jj) * uu(ji,jj,jk,Nii) ) * r1_e1e2f(ji,jj) 301 END_3D 342 302 CALL lbc_lnk( 'diawri', z3d, 'F', 1. ) 343 303 CALL iom_put( "relvor", z3d ) ! relative vorticity 344 304 345 DO jk = 1, jpkm1 346 DO jj = 1, jpj 347 DO ji = 1, jpi 348 z3d(ji,jj,jk) = ff_f(ji,jj) + z3d(ji,jj,jk) 349 END DO 350 END DO 351 END DO 305 DO_3D_11_11( 1, jpkm1 ) 306 z3d(ji,jj,jk) = ff_f(ji,jj) + z3d(ji,jj,jk) 307 END_3D 352 308 CALL iom_put( "absvor", z3d ) ! absolute vorticity 353 309 354 DO jk = 1, jpkm1 355 DO jj = 1, jpjm1 356 DO ji = 1, fs_jpim1 ! vector opt. 357 ze3 = ( e3t_n(ji,jj+1,jk)*tmask(ji,jj+1,jk) + e3t_n(ji+1,jj+1,jk)*tmask(ji+1,jj+1,jk) & 358 & + e3t_n(ji,jj ,jk)*tmask(ji,jj ,jk) + e3t_n(ji+1,jj ,jk)*tmask(ji+1,jj ,jk) ) 359 IF( ze3 /= 0._wp ) THEN ; ze3 = 4._wp / ze3 360 ELSE ; ze3 = 0._wp 361 ENDIF 362 z3d(ji,jj,jk) = ze3 * z3d(ji,jj,jk) 363 END DO 364 END DO 365 END DO 310 DO_3D_10_10( 1, jpkm1 ) 311 ze3 = ( e3t_n(ji,jj+1,jk)*tmask(ji,jj+1,jk) + e3t_n(ji+1,jj+1,jk)*tmask(ji+1,jj+1,jk) & 312 & + e3t_n(ji,jj ,jk)*tmask(ji,jj ,jk) + e3t_n(ji+1,jj ,jk)*tmask(ji+1,jj ,jk) ) 313 IF( ze3 /= 0._wp ) THEN ; ze3 = 4._wp / ze3 314 ELSE ; ze3 = 0._wp 315 ENDIF 316 z3d(ji,jj,jk) = ze3 * z3d(ji,jj,jk) 317 END_3D 366 318 CALL lbc_lnk( 'diawri', z3d, 'F', 1. ) 367 319 CALL iom_put( "potvor", z3d ) ! potential vorticity … … 374 326 z2d(:,:) = 0.e0 375 327 DO jk = 1, jpkm1 376 z3d(:,:,jk) = rau0 * u n(:,:,jk) * e2u(:,:) * e3u_n(:,:,jk) * umask(:,:,jk)328 z3d(:,:,jk) = rau0 * uu(:,:,jk,Nii) * e2u(:,:) * e3u_n(:,:,jk) * umask(:,:,jk) 377 329 z2d(:,:) = z2d(:,:) + z3d(:,:,jk) 378 330 END DO … … 383 335 IF( iom_use("u_heattr") ) THEN 384 336 z2d(:,:) = 0._wp 385 DO jk = 1, jpkm1 386 DO jj = 2, jpjm1 387 DO ji = fs_2, fs_jpim1 ! vector opt. 388 z2d(ji,jj) = z2d(ji,jj) + z3d(ji,jj,jk) * ( tsn(ji,jj,jk,jp_tem) + tsn(ji+1,jj,jk,jp_tem) ) 389 END DO 390 END DO 391 END DO 337 DO_3D_00_00( 1, jpkm1 ) 338 z2d(ji,jj) = z2d(ji,jj) + z3d(ji,jj,jk) * ( tsn(ji,jj,jk,jp_tem) + tsn(ji+1,jj,jk,jp_tem) ) 339 END_3D 392 340 CALL lbc_lnk( 'diawri', z2d, 'U', -1. ) 393 341 CALL iom_put( "u_heattr", 0.5*rcp * z2d ) ! heat transport in i-direction … … 396 344 IF( iom_use("u_salttr") ) THEN 397 345 z2d(:,:) = 0.e0 398 DO jk = 1, jpkm1 399 DO jj = 2, jpjm1 400 DO ji = fs_2, fs_jpim1 ! vector opt. 401 z2d(ji,jj) = z2d(ji,jj) + z3d(ji,jj,jk) * ( tsn(ji,jj,jk,jp_sal) + tsn(ji+1,jj,jk,jp_sal) ) 402 END DO 403 END DO 404 END DO 346 DO_3D_00_00( 1, jpkm1 ) 347 z2d(ji,jj) = z2d(ji,jj) + z3d(ji,jj,jk) * ( tsn(ji,jj,jk,jp_sal) + tsn(ji+1,jj,jk,jp_sal) ) 348 END_3D 405 349 CALL lbc_lnk( 'diawri', z2d, 'U', -1. ) 406 350 CALL iom_put( "u_salttr", 0.5 * z2d ) ! heat transport in i-direction … … 411 355 z3d(:,:,jpk) = 0.e0 412 356 DO jk = 1, jpkm1 413 z3d(:,:,jk) = rau0 * v n(:,:,jk) * e1v(:,:) * e3v_n(:,:,jk) * vmask(:,:,jk)357 z3d(:,:,jk) = rau0 * vv(:,:,jk,Nii) * e1v(:,:) * e3v_n(:,:,jk) * vmask(:,:,jk) 414 358 END DO 415 359 CALL iom_put( "v_masstr", z3d ) ! mass transport in j-direction … … 418 362 IF( iom_use("v_heattr") ) THEN 419 363 z2d(:,:) = 0.e0 420 DO jk = 1, jpkm1 421 DO jj = 2, jpjm1 422 DO ji = fs_2, fs_jpim1 ! vector opt. 423 z2d(ji,jj) = z2d(ji,jj) + z3d(ji,jj,jk) * ( tsn(ji,jj,jk,jp_tem) + tsn(ji,jj+1,jk,jp_tem) ) 424 END DO 425 END DO 426 END DO 364 DO_3D_00_00( 1, jpkm1 ) 365 z2d(ji,jj) = z2d(ji,jj) + z3d(ji,jj,jk) * ( tsn(ji,jj,jk,jp_tem) + tsn(ji,jj+1,jk,jp_tem) ) 366 END_3D 427 367 CALL lbc_lnk( 'diawri', z2d, 'V', -1. ) 428 368 CALL iom_put( "v_heattr", 0.5*rcp * z2d ) ! heat transport in j-direction … … 431 371 IF( iom_use("v_salttr") ) THEN 432 372 z2d(:,:) = 0._wp 433 DO jk = 1, jpkm1 434 DO jj = 2, jpjm1 435 DO ji = fs_2, fs_jpim1 ! vector opt. 436 z2d(ji,jj) = z2d(ji,jj) + z3d(ji,jj,jk) * ( tsn(ji,jj,jk,jp_sal) + tsn(ji,jj+1,jk,jp_sal) ) 437 END DO 438 END DO 439 END DO 373 DO_3D_00_00( 1, jpkm1 ) 374 z2d(ji,jj) = z2d(ji,jj) + z3d(ji,jj,jk) * ( tsn(ji,jj,jk,jp_sal) + tsn(ji,jj+1,jk,jp_sal) ) 375 END_3D 440 376 CALL lbc_lnk( 'diawri', z2d, 'V', -1. ) 441 377 CALL iom_put( "v_salttr", 0.5 * z2d ) ! heat transport in j-direction … … 444 380 IF( iom_use("tosmint") ) THEN 445 381 z2d(:,:) = 0._wp 446 DO jk = 1, jpkm1 447 DO jj = 2, jpjm1 448 DO ji = fs_2, fs_jpim1 ! vector opt. 449 z2d(ji,jj) = z2d(ji,jj) + e3t_n(ji,jj,jk) * tsn(ji,jj,jk,jp_tem) 450 END DO 451 END DO 452 END DO 382 DO_3D_00_00( 1, jpkm1 ) 383 z2d(ji,jj) = z2d(ji,jj) + e3t_n(ji,jj,jk) * tsn(ji,jj,jk,jp_tem) 384 END_3D 453 385 CALL lbc_lnk( 'diawri', z2d, 'T', -1. ) 454 386 CALL iom_put( "tosmint", rau0 * z2d ) ! Vertical integral of temperature … … 456 388 IF( iom_use("somint") ) THEN 457 389 z2d(:,:)=0._wp 458 DO jk = 1, jpkm1 459 DO jj = 2, jpjm1 460 DO ji = fs_2, fs_jpim1 ! vector opt. 461 z2d(ji,jj) = z2d(ji,jj) + e3t_n(ji,jj,jk) * tsn(ji,jj,jk,jp_sal) 462 END DO 463 END DO 464 END DO 390 DO_3D_00_00( 1, jpkm1 ) 391 z2d(ji,jj) = z2d(ji,jj) + e3t_n(ji,jj,jk) * tsn(ji,jj,jk,jp_sal) 392 END_3D 465 393 CALL lbc_lnk( 'diawri', z2d, 'T', -1. ) 466 394 CALL iom_put( "somint", rau0 * z2d ) ! Vertical integral of salinity -
NEMO/branches/2020/temporary_r4_trunk/tests/CANAL/MY_SRC/usrdef_istate.F90
r13466 r13469 184 184 pssh(:,1) = - ff_t(:,1) / grav * pu(:,1,1) * e2t(:,1) 185 185 DO jl=1, jpnj 186 DO jj=nldj, nlej 187 DO ji=nldi, nlei 188 pssh(ji,jj) = pssh(ji,jj-1) - ff_t(ji,jj) / grav * pu(ji,jj,1) * e2t(ji,jj) 189 END DO 190 END DO 186 DO_2D_nldj1_nldi1 187 pssh(ji,jj) = pssh(ji,jj-1) - ff_t(ji,jj) / grav * pu(ji,jj,1) * e2t(ji,jj) 188 END_2D 191 189 CALL lbc_lnk( 'usrdef_istate', pssh, 'T', 1. ) 192 190 END DO … … 203 201 CASE(4) ! geostrophic zonal pulse 204 202 205 DO jj=1, jpj 206 DO ji=1, jpi 207 IF ( ABS(glamt(ji,jj)) <= zjetx ) THEN 208 zdu = rn_uzonal 209 ELSEIF ( ABS(glamt(ji,jj)) <= zjetx + 100. ) THEN 210 zdu = rn_uzonal * ( ( zjetx-ABS(glamt(ji,jj)) )/100. + 1. ) 211 ELSE 212 zdu = 0. 213 END IF 214 IF ( ABS(gphit(ji,jj)) <= zjety ) THEN 215 pssh(ji,jj) = - ff_t(ji,jj) * zdu * gphit(ji,jj) * 1.e3 / grav 216 pu(ji,jj,:) = zdu 217 pts(ji,jj,:,jp_sal) = zdu / rn_uzonal + 1. 218 ELSE 219 pssh(ji,jj) = - ff_t(ji,jj) * zdu * SIGN(zjety,gphit(ji,jj)) * 1.e3 / grav 220 pu(ji,jj,:) = 0. 221 pts(ji,jj,:,jp_sal) = 1. 222 END IF 223 END DO 224 END DO 203 DO_2D_11_11 204 IF ( ABS(glamt(ji,jj)) <= zjetx ) THEN 205 zdu = rn_uzonal 206 ELSEIF ( ABS(glamt(ji,jj)) <= zjetx + 100. ) THEN 207 zdu = rn_uzonal * ( ( zjetx-ABS(glamt(ji,jj)) )/100. + 1. ) 208 ELSE 209 zdu = 0. 210 END IF 211 IF ( ABS(gphit(ji,jj)) <= zjety ) THEN 212 pssh(ji,jj) = - ff_t(ji,jj) * zdu * gphit(ji,jj) * 1.e3 / grav 213 pu(ji,jj,:) = zdu 214 pts(ji,jj,:,jp_sal) = zdu / rn_uzonal + 1. 215 ELSE 216 pssh(ji,jj) = - ff_t(ji,jj) * zdu * SIGN(zjety,gphit(ji,jj)) * 1.e3 / grav 217 pu(ji,jj,:) = 0. 218 pts(ji,jj,:,jp_sal) = 1. 219 END IF 220 END_2D 225 221 226 222 ! temperature: … … 240 236 zP0 = rau0 * zf0 * zumax * zlambda * SQRT(EXP(1._wp)/2._wp) 241 237 ! 242 DO jj=1, jpj 243 DO ji=1, jpi 244 zx = glamt(ji,jj) * 1.e3 245 zy = gphit(ji,jj) * 1.e3 246 ! Surface pressure: P(x,y,z) = F(z) * Psurf(x,y) 247 zpsurf = zP0 * EXP(-(zx**2+zy**2)*zr_lambda2) - rau0 * ff_t(ji,jj) * rn_uzonal * zy 248 ! Sea level: 249 pssh(ji,jj) = 0. 250 DO jl=1,5 251 zdt = pssh(ji,jj) 252 zdzF = (1._wp - EXP(zdt-zH)) / (zH - 1._wp + EXP(-zH)) ! F'(z) 253 zrho1 = rau0 * (1._wp + zn2*zdt/grav) - zdzF * zpsurf / grav ! -1/g Dz(P) = -1/g * F'(z) * Psurf(x,y) 254 pssh(ji,jj) = zpsurf / (zrho1*grav) * ptmask(ji,jj,1) ! ssh = Psurf / (Rho*g) 255 END DO 256 ! temperature: 257 DO jk=1,jpk 258 zdt = pdept(ji,jj,jk) 259 zrho1 = rau0 * (1._wp + zn2*zdt/grav) 260 IF (zdt < zH) THEN 261 zdzF = (1._wp-EXP(zdt-zH)) / (zH-1._wp + EXP(-zH)) ! F'(z) 262 zrho1 = zrho1 - zdzF * zpsurf / grav ! -1/g Dz(P) = -1/g * F'(z) * Psurf(x,y) 263 ENDIF 264 ! pts(ji,jj,jk,jp_tem) = (20._wp + (rau0-zrho1) / 0.28_wp) * ptmask(ji,jj,jk) 265 pts(ji,jj,jk,jp_tem) = (10._wp + (rau0-zrho1) / 0.28_wp) * ptmask(ji,jj,jk) 266 END DO 238 DO_2D_11_11 239 zx = glamt(ji,jj) * 1.e3 240 zy = gphit(ji,jj) * 1.e3 241 ! Surface pressure: P(x,y,z) = F(z) * Psurf(x,y) 242 zpsurf = zP0 * EXP(-(zx**2+zy**2)*zr_lambda2) - rau0 * ff_t(ji,jj) * rn_uzonal * zy 243 ! Sea level: 244 pssh(ji,jj) = 0. 245 DO jl=1,5 246 zdt = pssh(ji,jj) 247 zdzF = (1._wp - EXP(zdt-zH)) / (zH - 1._wp + EXP(-zH)) ! F'(z) 248 zrho1 = rau0 * (1._wp + zn2*zdt/grav) - zdzF * zpsurf / grav ! -1/g Dz(P) = -1/g * F'(z) * Psurf(x,y) 249 pssh(ji,jj) = zpsurf / (zrho1*grav) * ptmask(ji,jj,1) ! ssh = Psurf / (Rho*g) 267 250 END DO 268 END DO 251 ! temperature: 252 DO jk=1,jpk 253 zdt = pdept(ji,jj,jk) 254 zrho1 = rau0 * (1._wp + zn2*zdt/grav) 255 IF (zdt < zH) THEN 256 zdzF = (1._wp-EXP(zdt-zH)) / (zH-1._wp + EXP(-zH)) ! F'(z) 257 zrho1 = zrho1 - zdzF * zpsurf / grav ! -1/g Dz(P) = -1/g * F'(z) * Psurf(x,y) 258 ENDIF 259 ! pts(ji,jj,jk,jp_tem) = (20._wp + (rau0-zrho1) / 0.28_wp) * ptmask(ji,jj,jk) 260 pts(ji,jj,jk,jp_tem) = (10._wp + (rau0-zrho1) / 0.28_wp) * ptmask(ji,jj,jk) 261 END DO 262 END_2D 269 263 ! 270 264 ! salinity: … … 273 267 ! velocities: 274 268 za = 2._wp * zP0 / zlambda**2 275 DO jj = 2, jpjm1 276 DO ji = 2, jpim1 277 zx = glamu(ji,jj) * 1.e3 278 zy = gphiu(ji,jj) * 1.e3 279 DO jk=1, jpk 280 zdu = 0.5_wp * (pdept(ji,jj,jk) + pdept(ji+1,jj,jk)) 281 IF (zdu < zH) THEN 282 zf = (zH-1._wp-zdu+EXP(zdu-zH)) / (zH-1._wp+EXP(-zH)) 283 zdyPs = - za * zy * EXP(-(zx**2+zy**2)*zr_lambda2) - rau0 * ff_t(ji,jj) * rn_uzonal 284 pu(ji,jj,jk) = - zf / ( rau0 * ff_t(ji,jj) ) * zdyPs * ptmask(ji,jj,jk) * ptmask(ji+1,jj,jk) 285 ELSE 286 pu(ji,jj,jk) = 0._wp 287 ENDIF 288 END DO 269 DO_2D_00_00 270 zx = glamu(ji,jj) * 1.e3 271 zy = gphiu(ji,jj) * 1.e3 272 DO jk=1, jpk 273 zdu = 0.5_wp * (pdept(ji,jj,jk) + pdept(ji+1,jj,jk)) 274 IF (zdu < zH) THEN 275 zf = (zH-1._wp-zdu+EXP(zdu-zH)) / (zH-1._wp+EXP(-zH)) 276 zdyPs = - za * zy * EXP(-(zx**2+zy**2)*zr_lambda2) - rau0 * ff_t(ji,jj) * rn_uzonal 277 pu(ji,jj,jk) = - zf / ( rau0 * ff_t(ji,jj) ) * zdyPs * ptmask(ji,jj,jk) * ptmask(ji+1,jj,jk) 278 ELSE 279 pu(ji,jj,jk) = 0._wp 280 ENDIF 289 281 END DO 290 END DO 291 ! 292 DO jj = 2, jpjm1 293 DO ji = 2, jpim1 294 zx = glamv(ji,jj) * 1.e3 295 zy = gphiv(ji,jj) * 1.e3 296 DO jk=1, jpk 297 zdv = 0.5_wp * (pdept(ji,jj,jk) + pdept(ji,jj+1,jk)) 298 IF (zdv < zH) THEN 299 zf = (zH-1._wp-zdv+EXP(zdv-zH)) / (zH-1._wp+EXP(-zH)) 300 zdxPs = - za * zx * EXP(-(zx**2+zy**2)*zr_lambda2) 301 pv(ji,jj,jk) = zf / ( rau0 * ff_f(ji,jj) ) * zdxPs * ptmask(ji,jj,jk) * ptmask(ji,jj+1,jk) 302 ELSE 303 pv(ji,jj,jk) = 0._wp 304 ENDIF 305 END DO 282 END_2D 283 ! 284 DO_2D_00_00 285 zx = glamv(ji,jj) * 1.e3 286 zy = gphiv(ji,jj) * 1.e3 287 DO jk=1, jpk 288 zdv = 0.5_wp * (pdept(ji,jj,jk) + pdept(ji,jj+1,jk)) 289 IF (zdv < zH) THEN 290 zf = (zH-1._wp-zdv+EXP(zdv-zH)) / (zH-1._wp+EXP(-zH)) 291 zdxPs = - za * zx * EXP(-(zx**2+zy**2)*zr_lambda2) 292 pv(ji,jj,jk) = zf / ( rau0 * ff_f(ji,jj) ) * zdxPs * ptmask(ji,jj,jk) * ptmask(ji,jj+1,jk) 293 ELSE 294 pv(ji,jj,jk) = 0._wp 295 ENDIF 306 296 END DO 307 END DO297 END_2D 308 298 ! 309 299 CALL lbc_lnk_multi( 'usrdef_istate', pu, 'U', -1., pv, 'V', -1. )
Note: See TracChangeset
for help on using the changeset viewer.