Changeset 7278 for branches/2016/dev_CNRS_2016/NEMOGCM/NEMO
- Timestamp:
- 2016-11-21T10:38:43+01:00 (8 years ago)
- Location:
- branches/2016/dev_CNRS_2016/NEMOGCM/NEMO
- Files:
-
- 46 edited
Legend:
- Unmodified
- Added
- Removed
-
branches/2016/dev_CNRS_2016/NEMOGCM/NEMO/LIM_SRC_3/ice.F90
r6403 r7278 234 234 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: u_oce, v_oce !: surface ocean velocity used in ice dynamics 235 235 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: ahiu , ahiv !: hor. diffusivity coeff. at U- and V-points [m2/s] 236 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: pahu , pahv !: ice hor. eddy diffusivity coef. at U- and V-points237 236 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: ust2s, hicol !: friction velocity, ice collection thickness accreted in leads 238 237 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: strp1, strp2 !: strength at previous time steps … … 253 252 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: fhld !: heat flux from the lead used for bottom melting 254 253 255 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: wfx_snw !: snow-ocean mass exchange over 1 time step [kg/m2]256 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: wfx_spr !: snow precipitation on ice over 1 time step [kg/m2]257 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: wfx_sub !: snow sublimation over 1 time step [kg/m2]258 259 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: wfx_ice !: ice-ocean mass exchange over 1 time step [kg/m2]260 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: wfx_sni !: snow ice growth component of wfx_ice [kg/m2]261 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: wfx_opw !: lateral ice growth component of wfx_ice [kg/m2]262 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: wfx_bog !: bottom ice growth component of wfx_ice [kg/m2]263 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: wfx_dyn !: dynamical ice growth component of wfx_ice [kg /m2]264 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: wfx_bom !: bottom melt component of wfx_ice [kg/m2]265 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: wfx_sum !: surface melt component of wfx_ice [kg/m2]266 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: wfx_res !: residual component of wfx_ice [kg/m2]267 268 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: afx_tot !: ice concentration tendency (total) [s-1]254 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: wfx_snw !: snow-ocean mass exchange [kg.m-2.s-1] 255 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: wfx_spr !: snow precipitation on ice [kg.m-2.s-1] 256 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: wfx_sub !: snow/ice sublimation [kg.m-2.s-1] 257 258 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: wfx_ice !: ice-ocean mass exchange [kg.m-2.s-1] 259 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: wfx_sni !: snow ice growth component of wfx_ice [kg.m-2.s-1] 260 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: wfx_opw !: lateral ice growth component of wfx_ice [kg.m-2.s-1] 261 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: wfx_bog !: bottom ice growth component of wfx_ice [kg.m-2.s-1] 262 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: wfx_dyn !: dynamical ice growth component of wfx_ice [kg.m-2.s-1] 263 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: wfx_bom !: bottom melt component of wfx_ice [kg.m-2.s-1] 264 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: wfx_sum !: surface melt component of wfx_ice [kg.m-2.s-1] 265 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: wfx_res !: residual component of wfx_ice [kg.m-2.s-1] 266 267 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: afx_tot !: ice concentration tendency (total) [s-1] 269 268 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: afx_thd !: ice concentration tendency (thermodynamics) [s-1] 270 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: afx_dyn !: ice concentration tendency (dynamics) [s-1]269 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: afx_dyn !: ice concentration tendency (dynamics) [s-1] 271 270 272 271 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: sfx_bog !: salt flux due to ice growth/melt [PSU/m2/s] … … 279 278 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: sfx_res !: residual salt flux due to correction of ice thickness [PSU/m2/s] 280 279 281 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: hfx_bog !: total heat flux causing bottom ice growth 282 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: hfx_bom !: total heat flux causing bottom ice melt 283 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: hfx_sum !: total heat flux causing surface ice melt 284 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: hfx_opw !: total heat flux causing open water ice formation 285 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: hfx_dif !: total heat flux causing Temp change in the ice 286 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: hfx_snw !: heat flux for snow melt 287 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: hfx_err !: heat flux error after heat diffusion 288 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: hfx_err_dif !: heat flux remaining due to change in non-solar flux 289 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: hfx_err_rem !: heat flux error after heat remapping 290 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: hfx_in !: heat flux available for thermo transformations 291 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: hfx_out !: heat flux remaining at the end of thermo transformations 292 280 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: sfx_sub !: salt flux due to ice sublimation 281 282 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: hfx_bog !: total heat flux causing bottom ice growth [W.m-2] 283 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: hfx_bom !: total heat flux causing bottom ice melt [W.m-2] 284 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: hfx_sum !: total heat flux causing surface ice melt [W.m-2] 285 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: hfx_opw !: total heat flux causing open water ice formation [W.m-2] 286 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: hfx_dif !: total heat flux causing Temp change in the ice [W.m-2] 287 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: hfx_snw !: heat flux for snow melt [W.m-2] 288 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: hfx_err !: heat flux error after heat diffusion [W.m-2] 289 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: hfx_err_dif !: heat flux remaining due to change in non-solar flux [W.m-2] 290 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: hfx_err_rem !: heat flux error after heat remapping [W.m-2] 291 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: hfx_in !: heat flux available for thermo transformations [W.m-2] 292 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: hfx_out !: heat flux remaining at the end of thermo transformations [W.m-2] 293 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: wfx_err_sub !: mass flux error after sublimation [kg.m-2.s-1] 294 293 295 ! heat flux associated with ice-atmosphere mass exchange 294 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: hfx_sub !: heat flux for sublimation 295 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: hfx_spr !: heat flux of the snow precipitation 296 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: hfx_sub !: heat flux for sublimation [W.m-2] 297 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: hfx_spr !: heat flux of the snow precipitation [W.m-2] 296 298 297 299 ! heat flux associated with ice-ocean mass exchange 298 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: hfx_thd !: ice-ocean heat flux from thermo processes (limthd_dh) 299 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: hfx_dyn !: ice-ocean heat flux from mecanical processes (limitd_me) 300 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: hfx_res !: residual heat flux due to correction of ice thickness 301 302 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: ftr_ice !: transmitted solar radiation under ice 300 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: hfx_thd !: ice-ocean heat flux from thermo processes (limthd_dh) [W.m-2] 301 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: hfx_dyn !: ice-ocean heat flux from mecanical processes (limitd_me) [W.m-2] 302 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: hfx_res !: residual heat flux due to correction of ice thickness [W.m-2] 303 304 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: ftr_ice !: transmitted solar radiation under ice 305 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: pahu3D , pahv3D 303 306 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: rn_amax_2d !: maximum ice concentration 2d array 304 307 … … 370 373 !!-------------------------------------------------------------------------- 371 374 ! !!: ** Namelist namicerun read in sbc_lim_init ** 372 INTEGER , PUBLIC :: jpl !: number of ice categories373 INTEGER , PUBLIC :: nlay_i !: number of ice layers374 INTEGER , PUBLIC :: nlay_s !: number of snow layers375 CHARACTER(len=32) , PUBLIC :: cn_icerst_in !: suffix of ice restart name (input)375 INTEGER , PUBLIC :: jpl !: number of ice categories 376 INTEGER , PUBLIC :: nlay_i !: number of ice layers 377 INTEGER , PUBLIC :: nlay_s !: number of snow layers 378 CHARACTER(len=32) , PUBLIC :: cn_icerst_in !: suffix of ice restart name (input) 376 379 CHARACTER(len=256), PUBLIC :: cn_icerst_indir !: ice restart input directory 377 CHARACTER(len=32) , PUBLIC :: cn_icerst_out !: suffix of ice restart name (output)380 CHARACTER(len=32) , PUBLIC :: cn_icerst_out !: suffix of ice restart name (output) 378 381 CHARACTER(len=256), PUBLIC :: cn_icerst_outdir!: ice restart output directory 379 LOGICAL , PUBLIC :: ln_limdyn !: flag for ice dynamics (T) or not (F)380 LOGICAL , PUBLIC :: ln_icectl !: flag for sea-ice points output (T) or not (F)381 REAL(wp) , PUBLIC :: rn_amax_n !: maximum ice concentration Northern hemisphere382 REAL(wp) , PUBLIC :: rn_amax_s !: maximum ice concentration Southern hemisphere383 INTEGER , PUBLIC :: iiceprt !: debug i-point384 INTEGER , PUBLIC :: jiceprt !: debug j-point382 LOGICAL , PUBLIC :: ln_limdyn !: flag for ice dynamics (T) or not (F) 383 LOGICAL , PUBLIC :: ln_icectl !: flag for sea-ice points output (T) or not (F) 384 REAL(wp) , PUBLIC :: rn_amax_n !: maximum ice concentration Northern hemisphere 385 REAL(wp) , PUBLIC :: rn_amax_s !: maximum ice concentration Southern hemisphere 386 INTEGER , PUBLIC :: iiceprt !: debug i-point 387 INTEGER , PUBLIC :: jiceprt !: debug j-point 385 388 ! 386 389 !!-------------------------------------------------------------------------- … … 426 429 ALLOCATE( u_oce (jpi,jpj) , v_oce (jpi,jpj) , & 427 430 & ahiu (jpi,jpj) , ahiv (jpi,jpj) , & 428 & pahu (jpi,jpj) , pahv (jpi,jpj) , &429 431 & ust2s (jpi,jpj) , hicol (jpi,jpj) , & 430 432 & strp1 (jpi,jpj) , strp2 (jpi,jpj) , strength (jpi,jpj) , & … … 439 441 & wfx_res(jpi,jpj) , wfx_sni(jpi,jpj) , wfx_opw(jpi,jpj) , wfx_spr(jpi,jpj) , & 440 442 & afx_tot(jpi,jpj) , afx_thd(jpi,jpj), afx_dyn(jpi,jpj) , & 441 & fhtur (jpi,jpj) , ftr_ice(jpi,jpj,jpl), qlead (jpi,jpj) ,&442 & rn_amax_2d (jpi,jpj),&443 & sfx_res(jpi,jpj) , sfx_bri(jpi,jpj) , sfx_dyn(jpi,jpj) , &443 & fhtur (jpi,jpj) , ftr_ice(jpi,jpj,jpl), pahu3D(jpi,jpj,jpl+1), pahv3D(jpi,jpj,jpl+1), & 444 & rn_amax_2d (jpi,jpj) , qlead (jpi,jpj) , & 445 & sfx_res(jpi,jpj) , sfx_bri(jpi,jpj) , sfx_dyn(jpi,jpj) , sfx_sub(jpi,jpj), & 444 446 & sfx_bog(jpi,jpj) , sfx_bom(jpi,jpj) , sfx_sum(jpi,jpj) , sfx_sni(jpi,jpj) , sfx_opw(jpi,jpj) , & 445 447 & hfx_res(jpi,jpj) , hfx_snw(jpi,jpj) , hfx_sub(jpi,jpj) , hfx_err(jpi,jpj) , & 446 & hfx_err_dif(jpi,jpj) , hfx_err_rem(jpi,jpj) , 448 & hfx_err_dif(jpi,jpj) , hfx_err_rem(jpi,jpj) , wfx_err_sub(jpi,jpj) , & 447 449 & hfx_in (jpi,jpj) , hfx_out(jpi,jpj) , fhld(jpi,jpj) , & 448 450 & hfx_sum(jpi,jpj) , hfx_bom(jpi,jpj) , hfx_bog(jpi,jpj) , hfx_dif(jpi,jpj) , hfx_opw(jpi,jpj) , & … … 511 513 !!====================================================================== 512 514 END MODULE ice 515 -
branches/2016/dev_CNRS_2016/NEMOGCM/NEMO/LIM_SRC_3/limcons.F90
r6403 r7278 24 24 USE lib_fortran ! Fortran utilities (allows no signed zero when 'key_nosignedzero' defined) 25 25 USE sbc_oce , ONLY : sfx ! Surface boundary condition: ocean fields 26 26 USE sbc_ice , ONLY : qevap_ice 27 27 28 IMPLICIT NONE 28 29 PRIVATE … … 184 185 ! salt flux 185 186 zfs_b = glob_sum( ( sfx_bri(:,:) + sfx_bog(:,:) + sfx_bom(:,:) + sfx_sum(:,:) + sfx_sni(:,:) + & 186 & sfx_opw(:,:) + sfx_res(:,:) + sfx_dyn(:,:) 187 & sfx_opw(:,:) + sfx_res(:,:) + sfx_dyn(:,:) + sfx_sub(:,:) & 187 188 & ) * e1e2t(:,:) * tmask(:,:,1) * zconv ) 188 189 … … 209 210 ! salt flux 210 211 zfs = glob_sum( ( sfx_bri(:,:) + sfx_bog(:,:) + sfx_bom(:,:) + sfx_sum(:,:) + sfx_sni(:,:) + & 211 & sfx_opw(:,:) + sfx_res(:,:) + sfx_dyn(:,:) 212 & sfx_opw(:,:) + sfx_res(:,:) + sfx_dyn(:,:) + sfx_sub(:,:) & 212 213 & ) * e1e2t(:,:) * tmask(:,:,1) * zconv ) - zfs_b 213 214 … … 287 288 #if ! defined key_bdy 288 289 ! heat flux 289 zhfx = glob_sum( ( hfx_in - hfx_out - diag_heat - diag_trp_ei - diag_trp_es - hfx_sub ) * e1e2t * tmask(:,:,1) * zconv ) 290 zhfx = glob_sum( ( hfx_in - hfx_out - diag_heat - diag_trp_ei - diag_trp_es - SUM( qevap_ice * a_i_b, dim=3 ) ) & 291 & * e1e2t * tmask(:,:,1) * zconv ) 290 292 ! salt flux 291 293 zsfx = glob_sum( ( sfx + diag_smvi ) * e1e2t * tmask(:,:,1) * zconv ) * rday -
branches/2016/dev_CNRS_2016/NEMOGCM/NEMO/LIM_SRC_3/limdiahsb.F90
r5836 r7278 56 56 real(wp) :: zbg_ivo, zbg_svo, zbg_are, zbg_sal ,zbg_tem ,zbg_ihc ,zbg_shc 57 57 real(wp) :: zbg_sfx, zbg_sfx_bri, zbg_sfx_bog, zbg_sfx_bom, zbg_sfx_sum, zbg_sfx_sni, & 58 & zbg_sfx_opw, zbg_sfx_res, zbg_sfx_dyn 58 & zbg_sfx_opw, zbg_sfx_res, zbg_sfx_dyn, zbg_sfx_sub 59 59 real(wp) :: zbg_vfx, zbg_vfx_bog, zbg_vfx_opw, zbg_vfx_sni, zbg_vfx_dyn 60 60 real(wp) :: zbg_vfx_bom, zbg_vfx_sum, zbg_vfx_res, zbg_vfx_spr, zbg_vfx_snw, zbg_vfx_sub … … 111 111 zbg_sfx_bom = ztmp * glob_sum( sfx_bom(:,:) * e1e2t(:,:) * tmask(:,:,1) ) 112 112 zbg_sfx_sum = ztmp * glob_sum( sfx_sum(:,:) * e1e2t(:,:) * tmask(:,:,1) ) 113 zbg_sfx_sub = ztmp * glob_sum( sfx_sub(:,:) * e1e2t(:,:) * tmask(:,:,1) ) 113 114 114 115 ! Heat budget 115 zbg_ihc = glob_sum( et_i(:,:) * e1e2t(:,:) ) * 1.e-20! ice heat content [1.e20 J]116 zbg_shc = glob_sum( et_s(:,:) * e1e2t(:,:) ) * 1.e-20! snow heat content [1.e20 J]116 zbg_ihc = glob_sum( et_i(:,:) * e1e2t(:,:) * 1.e-20 ) ! ice heat content [1.e20 J] 117 zbg_shc = glob_sum( et_s(:,:) * e1e2t(:,:) * 1.e-20 ) ! snow heat content [1.e20 J] 117 118 zbg_hfx_dhc = glob_sum( diag_heat(:,:) * e1e2t(:,:) * tmask(:,:,1) ) ! [in W] 118 119 zbg_hfx_spr = glob_sum( hfx_spr(:,:) * e1e2t(:,:) * tmask(:,:,1) ) ! [in W] … … 189 190 CALL iom_put( 'ibgsfxbom' , zbg_sfx_bom ) ! salt flux bottom melt - 190 191 CALL iom_put( 'ibgsfxsum' , zbg_sfx_sum ) ! salt flux surface melt - 192 CALL iom_put( 'ibgsfxsub' , zbg_sfx_sub ) ! salt flux sublimation - 191 193 192 194 CALL iom_put( 'ibghfxdhc' , zbg_hfx_dhc ) ! Heat content variation in snow and ice [W] -
branches/2016/dev_CNRS_2016/NEMOGCM/NEMO/LIM_SRC_3/limhdf.F90
r5836 r7278 7 7 !! - ! 2001-05 (G. Madec, R. Hordoir) opa norm 8 8 !! 1.0 ! 2002-08 (C. Ethe) F90, free form 9 !! 3.0 ! 2015-08 (O. Tintó and M. Castrillo) added lim_hdf (multiple) 9 10 !!---------------------------------------------------------------------- 10 11 #if defined key_lim3 … … 27 28 PRIVATE 28 29 29 PUBLIC lim_hdf 30 PUBLIC lim_hdf ! called by lim_trp 30 31 PUBLIC lim_hdf_init ! called by sbc_lim_init 31 32 … … 43 44 CONTAINS 44 45 45 SUBROUTINE lim_hdf( ptab )46 SUBROUTINE lim_hdf( ptab , ihdf_vars , jpl , nlay_i ) 46 47 !!------------------------------------------------------------------- 47 48 !! *** ROUTINE lim_hdf *** … … 54 55 !! ** Action : update ptab with the diffusive contribution 55 56 !!------------------------------------------------------------------- 56 REAL(wp), DIMENSION(jpi,jpj), INTENT( inout ) :: ptab ! Field on which the diffusion is applied 57 ! 58 INTEGER :: ji, jj ! dummy loop indices 57 INTEGER :: jpl, nlay_i, isize, ihdf_vars 58 REAL(wp), DIMENSION(:,:,:), INTENT( inout ),TARGET :: ptab ! Field on which the diffusion is applied 59 ! 60 INTEGER :: ji, jj, jk, jl , jm ! dummy loop indices 59 61 INTEGER :: iter, ierr ! local integers 60 REAL(wp) :: zrlxint, zconv ! local scalars 61 REAL(wp), POINTER, DIMENSION(:,:) :: zrlx, zflu, zflv, zdiv0, zdiv, ztab0 62 REAL(wp) :: zrlxint ! local scalars 63 REAL(wp), POINTER , DIMENSION ( : ) :: zconv ! local scalars 64 REAL(wp), POINTER , DIMENSION(:,:,:) :: zrlx,zdiv0, ztab0 65 REAL(wp), POINTER , DIMENSION(:,:) :: zflu, zflv, zdiv 62 66 CHARACTER(lc) :: charout ! local character 63 67 REAL(wp), PARAMETER :: zrelax = 0.5_wp ! relaxation constant for iterative procedure … … 65 69 INTEGER , PARAMETER :: its = 100 ! Maximum number of iteration 66 70 !!------------------------------------------------------------------- 71 TYPE(arrayptr) , ALLOCATABLE, DIMENSION(:) :: pt2d_array, zrlx_array 72 CHARACTER(len=1) , ALLOCATABLE, DIMENSION(:) :: type_array ! define the nature of ptab array grid-points 73 ! ! = T , U , V , F , W and I points 74 REAL(wp) , ALLOCATABLE, DIMENSION(:) :: psgn_array ! =-1 the sign change across the north fold boundary 75 76 !!--------------------------------------------------------------------- 77 78 ! !== Initialisation ==! 79 ! +1 open water diffusion 80 isize = jpl*(ihdf_vars+nlay_i)+1 81 ALLOCATE( zconv (isize) ) 82 ALLOCATE( pt2d_array(isize) , zrlx_array(isize) ) 83 ALLOCATE( type_array(isize) ) 84 ALLOCATE( psgn_array(isize) ) 67 85 68 CALL wrk_alloc( jpi, jpj, zrlx, zflu, zflv, zdiv0, zdiv, ztab0 ) 69 70 ! !== Initialisation ==! 86 CALL wrk_alloc( jpi, jpj, isize, zrlx, zdiv0, ztab0 ) 87 CALL wrk_alloc( jpi, jpj, zflu, zflv, zdiv ) 88 89 DO jk= 1 , isize 90 pt2d_array(jk)%pt2d=>ptab(:,:,jk) 91 zrlx_array(jk)%pt2d=>zrlx(:,:,jk) 92 type_array(jk)='T' 93 psgn_array(jk)=1. 94 END DO 95 71 96 ! 72 97 IF( linit ) THEN ! Metric coefficient (compute at the first call and saved in efact) … … 74 99 IF( lk_mpp ) CALL mpp_sum( ierr ) 75 100 IF( ierr /= 0 ) CALL ctl_stop( 'STOP', 'lim_hdf : unable to allocate arrays' ) 76 DO jj = 2, jpjm1 101 DO jj = 2, jpjm1 77 102 DO ji = fs_2 , fs_jpim1 ! vector opt. 78 103 efact(ji,jj) = ( e2u(ji,jj) + e2u(ji-1,jj) + e1v(ji,jj) + e1v(ji,jj-1) ) * r1_e1e2t(ji,jj) … … 83 108 ! ! Time integration parameters 84 109 ! 85 ztab0(:, : ) = ptab(:,:) ! Arrays initialization 86 zdiv0(:, 1 ) = 0._wp 87 zdiv0(:,jpj) = 0._wp 88 zflu (jpi,:) = 0._wp 89 zflv (jpi,:) = 0._wp 90 zdiv0(1, :) = 0._wp 91 zdiv0(jpi,:) = 0._wp 110 zflu (jpi,: ) = 0._wp 111 zflv (jpi,: ) = 0._wp 112 113 DO jk=1 , isize 114 ztab0(:, : , jk ) = ptab(:,:,jk) ! Arrays initialization 115 zdiv0(:, 1 , jk ) = 0._wp 116 zdiv0(:,jpj, jk ) = 0._wp 117 zdiv0(1, :, jk ) = 0._wp 118 zdiv0(jpi,:, jk ) = 0._wp 119 END DO 92 120 93 121 zconv = 1._wp !== horizontal diffusion using a Crant-Nicholson scheme ==! 94 122 iter = 0 95 123 ! 96 DO WHILE( zconv> ( 2._wp * 1.e-04 ) .AND. iter <= its ) ! Sub-time step loop124 DO WHILE( MAXVAL(zconv(:)) > ( 2._wp * 1.e-04 ) .AND. iter <= its ) ! Sub-time step loop 97 125 ! 98 126 iter = iter + 1 ! incrementation of the sub-time step number 99 127 ! 128 DO jk = 1 , isize 129 jl = (jk-1) /( ihdf_vars+nlay_i)+1 130 IF (zconv(jk) > ( 2._wp * 1.e-04 )) THEN 131 DO jj = 1, jpjm1 ! diffusive fluxes in U- and V- direction 132 DO ji = 1 , fs_jpim1 ! vector opt. 133 zflu(ji,jj) = pahu3D(ji,jj,jl) * e2u(ji,jj) * r1_e1u(ji,jj) * ( ptab(ji+1,jj,jk) - ptab(ji,jj,jk) ) 134 zflv(ji,jj) = pahv3D(ji,jj,jl) * e1v(ji,jj) * r1_e2v(ji,jj) * ( ptab(ji,jj+1,jk) - ptab(ji,jj,jk) ) 135 END DO 136 END DO 137 ! 138 DO jj= 2, jpjm1 ! diffusive trend : divergence of the fluxes 139 DO ji = fs_2 , fs_jpim1 ! vector opt. 140 zdiv(ji,jj) = ( zflu(ji,jj) - zflu(ji-1,jj) + zflv(ji,jj) - zflv(ji,jj-1) ) * r1_e1e2t(ji,jj) 141 END DO 142 END DO 143 ! 144 IF( iter == 1 ) zdiv0(:,:,jk) = zdiv(:,:) ! save the 1st evaluation of the diffusive trend in zdiv0 145 ! 146 DO jj = 2, jpjm1 ! iterative evaluation 147 DO ji = fs_2 , fs_jpim1 ! vector opt. 148 zrlxint = ( ztab0(ji,jj,jk) & 149 & + rdt_ice * ( zalfa * ( zdiv(ji,jj) + efact(ji,jj) * ptab(ji,jj,jk) ) & 150 & + ( 1.0 - zalfa ) * zdiv0(ji,jj,jk) ) & 151 & ) / ( 1.0 + zalfa * rdt_ice * efact(ji,jj) ) 152 zrlx(ji,jj,jk) = ptab(ji,jj,jk) + zrelax * ( zrlxint - ptab(ji,jj,jk) ) 153 END DO 154 END DO 155 END IF 156 157 END DO 158 159 CALL lbc_lnk_multi( zrlx_array, type_array , psgn_array , isize ) ! Multiple interchange of all the variables 160 ! 161 IF ( MOD( iter-1 , nn_convfrq ) == 0 ) THEN !Convergence test every nn_convfrq iterations (perf. optimization ) 162 DO jk=1,isize 163 zconv(jk) = 0._wp ! convergence test 164 DO jj = 2, jpjm1 165 DO ji = fs_2, fs_jpim1 166 zconv(jk) = MAX( zconv(jk), ABS( zrlx(ji,jj,jk) - ptab(ji,jj,jk) ) ) 167 END DO 168 END DO 169 END DO 170 IF( lk_mpp ) CALL mpp_max_multiple( zconv , isize ) ! max over the global domain for all the variables 171 ENDIF 172 ! 173 DO jk=1,isize 174 ptab(:,:,jk) = zrlx(:,:,jk) 175 END DO 176 ! 177 END DO ! end of sub-time step loop 178 179 ! ----------------------- 180 !!! final step (clem) !!! 181 DO jk = 1, isize 182 jl = (jk-1) /( ihdf_vars+nlay_i)+1 100 183 DO jj = 1, jpjm1 ! diffusive fluxes in U- and V- direction 101 184 DO ji = 1 , fs_jpim1 ! vector opt. 102 zflu(ji,jj) = pahu (ji,jj) * e2u(ji,jj) * r1_e1u(ji,jj) * ( ptab(ji+1,jj) - ptab(ji,jj) )103 zflv(ji,jj) = pahv (ji,jj) * e1v(ji,jj) * r1_e2v(ji,jj) * ( ptab(ji,jj+1) - ptab(ji,jj) )185 zflu(ji,jj) = pahu3D(ji,jj,jl) * e2u(ji,jj) * r1_e1u(ji,jj) * ( ptab(ji+1,jj,jk) - ptab(ji,jj,jk) ) 186 zflv(ji,jj) = pahv3D(ji,jj,jl) * e1v(ji,jj) * r1_e2v(ji,jj) * ( ptab(ji,jj+1,jk) - ptab(ji,jj,jk) ) 104 187 END DO 105 188 END DO … … 108 191 DO ji = fs_2 , fs_jpim1 ! vector opt. 109 192 zdiv(ji,jj) = ( zflu(ji,jj) - zflu(ji-1,jj) + zflv(ji,jj) - zflv(ji,jj-1) ) * r1_e1e2t(ji,jj) 110 END DO 111 END DO 112 ! 113 IF( iter == 1 ) zdiv0(:,:) = zdiv(:,:) ! save the 1st evaluation of the diffusive trend in zdiv0 114 ! 115 DO jj = 2, jpjm1 ! iterative evaluation 116 DO ji = fs_2 , fs_jpim1 ! vector opt. 117 zrlxint = ( ztab0(ji,jj) & 118 & + rdt_ice * ( zalfa * ( zdiv(ji,jj) + efact(ji,jj) * ptab(ji,jj) ) & 119 & + ( 1.0 - zalfa ) * zdiv0(ji,jj) ) & 120 & ) / ( 1.0 + zalfa * rdt_ice * efact(ji,jj) ) 121 zrlx(ji,jj) = ptab(ji,jj) + zrelax * ( zrlxint - ptab(ji,jj) ) 122 END DO 123 END DO 124 CALL lbc_lnk( zrlx, 'T', 1. ) ! lateral boundary condition 125 ! 126 IF ( MOD( iter, nn_convfrq ) == 0 ) THEN ! convergence test every nn_convfrq iterations (perf. optimization) 127 zconv = 0._wp 128 DO jj = 2, jpjm1 129 DO ji = fs_2, fs_jpim1 130 zconv = MAX( zconv, ABS( zrlx(ji,jj) - ptab(ji,jj) ) ) 131 END DO 132 END DO 133 IF( lk_mpp ) CALL mpp_max( zconv ) ! max over the global domain 134 ENDIF 135 ! 136 ptab(:,:) = zrlx(:,:) 137 ! 138 END DO ! end of sub-time step loop 139 140 ! ----------------------- 141 !!! final step (clem) !!! 142 DO jj = 1, jpjm1 ! diffusive fluxes in U- and V- direction 143 DO ji = 1 , fs_jpim1 ! vector opt. 144 zflu(ji,jj) = pahu(ji,jj) * e2u(ji,jj) * r1_e1u(ji,jj) * ( ptab(ji+1,jj) - ptab(ji,jj) ) 145 zflv(ji,jj) = pahv(ji,jj) * e1v(ji,jj) * r1_e2v(ji,jj) * ( ptab(ji,jj+1) - ptab(ji,jj) ) 193 ptab(ji,jj,jk) = ztab0(ji,jj,jk) + 0.5 * ( zdiv(ji,jj) + zdiv0(ji,jj,jk) ) 194 END DO 146 195 END DO 147 196 END DO 148 ! 149 DO jj= 2, jpjm1 ! diffusive trend : divergence of the fluxes 150 DO ji = fs_2 , fs_jpim1 ! vector opt. 151 zdiv(ji,jj) = ( zflu(ji,jj) - zflu(ji-1,jj) + zflv(ji,jj) - zflv(ji,jj-1) ) * r1_e1e2t(ji,jj) 152 ptab(ji,jj) = ztab0(ji,jj) + 0.5 * ( zdiv(ji,jj) + zdiv0(ji,jj) ) 153 END DO 154 END DO 155 CALL lbc_lnk( ptab, 'T', 1. ) ! lateral boundary condition 197 198 CALL lbc_lnk_multi( pt2d_array, type_array , psgn_array , isize ) ! Multiple interchange of all the variables 199 156 200 !!! final step (clem) !!! 157 201 ! ----------------------- 158 202 159 203 IF(ln_ctl) THEN 160 zrlx(:,:) = ptab(:,:) - ztab0(:,:) 161 WRITE(charout,FMT="(' lim_hdf : zconv =',D23.16, ' iter =',I4,2X)") zconv, iter 162 CALL prt_ctl( tab2d_1=zrlx, clinfo1=charout ) 163 ENDIF 164 ! 165 CALL wrk_dealloc( jpi, jpj, zrlx, zflu, zflv, zdiv0, zdiv, ztab0 ) 204 DO jk = 1 , isize 205 zrlx(:,:,jk) = ptab(:,:,jk) - ztab0(:,:,jk) 206 WRITE(charout,FMT="(' lim_hdf : zconv =',D23.16, ' iter =',I4,2X)") zconv, iter 207 CALL prt_ctl( tab2d_1=zrlx(:,:,jk), clinfo1=charout ) 208 END DO 209 ENDIF 210 ! 211 CALL wrk_dealloc( jpi, jpj, isize, zrlx, zdiv0, ztab0 ) 212 CALL wrk_dealloc( jpi, jpj, zflu, zflv, zdiv ) 213 214 DEALLOCATE( zconv ) 215 DEALLOCATE( pt2d_array , zrlx_array ) 216 DEALLOCATE( type_array ) 217 DEALLOCATE( psgn_array ) 166 218 ! 167 219 END SUBROUTINE lim_hdf 220 168 221 169 222 … … 179 232 !!------------------------------------------------------------------- 180 233 INTEGER :: ios ! Local integer output status for namelist read 181 NAMELIST/namicehdf/ nn_convfrq 234 NAMELIST/namicehdf/ nn_convfrq 182 235 !!------------------------------------------------------------------- 183 236 ! … … 212 265 !!====================================================================== 213 266 END MODULE limhdf 267 -
branches/2016/dev_CNRS_2016/NEMOGCM/NEMO/LIM_SRC_3/limistate.F90
r7277 r7278 24 24 USE par_oce ! ocean parameters 25 25 USE dom_ice ! sea-ice domain 26 USE limvar ! lim_var_salprof 26 27 USE in_out_manager ! I/O manager 27 28 USE lib_mpp ! MPP library … … 277 278 ztest_1 = 1 278 279 ELSE 279 !this write is useful280 IF(lwp) WRITE(numout,*) ' * TEST1 AREA NOT CONSERVED *** zA_cons = ', zA_cons,' zat_i_ini = ',zat_i_ini(ji,jj)281 280 ztest_1 = 0 282 281 ENDIF … … 289 288 ztest_2 = 1 290 289 ELSE 291 !this write is useful292 IF(lwp) WRITE(numout,*) ' * TEST2 VOLUME NOT CONSERVED *** zV_cons = ', zV_cons, &293 ' zvt_i_ini = ', zvt_i_ini(ji,jj)294 290 ztest_2 = 0 295 291 ENDIF … … 299 295 ztest_3 = 1 300 296 ELSE 301 ! this write is useful302 IF(lwp) WRITE(numout,*) ' * TEST 3 THICKNESS OF THE LAST CATEGORY OUT OF BOUNDS *** zh_i_ini(ji,jj,i_fill) = ', &303 zh_i_ini(ji,jj,i_fill), ' hi_max(jpl-1) = ', hi_max(i_fill-1)304 IF(lwp) WRITE(numout,*) ' ji,jj,i_fill ',ji,jj,i_fill305 IF(lwp) WRITE(numout,*) 'zht_i_ini ',zht_i_ini(ji,jj)306 297 ztest_3 = 0 307 298 ENDIF … … 311 302 DO jl = 1, jpl 312 303 IF ( za_i_ini(ji,jj,jl) .LT. 0._wp ) THEN 313 ! this write is useful314 IF(lwp) WRITE(numout,*) ' * TEST 4 POSITIVITY NOT OK FOR CAT ', jl, ' WITH A = ', za_i_ini(ji,jj,jl)315 304 ztest_4 = 0 316 305 ENDIF … … 379 368 END DO 380 369 370 ! for constant salinity in time 371 IF( nn_icesal == 1 .OR. nn_icesal == 3 ) THEN 372 CALL lim_var_salprof 373 smv_i = sm_i * v_i 374 ENDIF 375 381 376 ! Snow temperature and heat content 382 377 DO jk = 1, nlay_s -
branches/2016/dev_CNRS_2016/NEMOGCM/NEMO/LIM_SRC_3/limitd_me.F90
r5836 r7278 45 45 REAL(wp), ALLOCATABLE, DIMENSION(:,:) :: asum ! sum of total ice and open water area 46 46 REAL(wp), ALLOCATABLE, DIMENSION(:,:) :: aksum ! ratio of area removed to area ridged 47 REAL(wp), ALLOCATABLE, DIMENSION(:,:,:) :: athorn ! participation function; fraction of ridging/ 48 ! ! closing associated w/ category n 47 REAL(wp), ALLOCATABLE, DIMENSION(:,:,:) :: athorn ! participation function; fraction of ridging/closing associated w/ category n 49 48 REAL(wp), ALLOCATABLE, DIMENSION(:,:,:) :: hrmin ! minimum ridge thickness 50 49 REAL(wp), ALLOCATABLE, DIMENSION(:,:,:) :: hrmax ! maximum ridge thickness 51 50 REAL(wp), ALLOCATABLE, DIMENSION(:,:,:) :: hraft ! thickness of rafted ice 52 REAL(wp), ALLOCATABLE, DIMENSION(:,:,:) :: krdg ! mean ridge thickness/thickness of ridging ice51 REAL(wp), ALLOCATABLE, DIMENSION(:,:,:) :: krdg ! thickness of ridging ice / mean ridge thickness 53 52 REAL(wp), ALLOCATABLE, DIMENSION(:,:,:) :: aridge ! participating ice ridging 54 53 REAL(wp), ALLOCATABLE, DIMENSION(:,:,:) :: araft ! participating ice rafting 55 54 56 55 REAL(wp), PARAMETER :: krdgmin = 1.1_wp ! min ridge thickness multiplier 57 REAL(wp), PARAMETER :: kraft = 2.0_wp ! rafting multipliyer 58 REAL(wp), PARAMETER :: kamax = 1.0_wp ! max of ice area authorized (clem: scheme is not stable if kamax <= 0.99) 56 REAL(wp), PARAMETER :: kraft = 0.5_wp ! rafting multipliyer 59 57 60 58 REAL(wp) :: Cp ! 61 59 ! 62 !-----------------------------------------------------------------------63 ! Ridging diagnostic arrays for history files64 !-----------------------------------------------------------------------65 REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:) :: dardg1dt ! rate of fractional area loss by ridging ice (1/s)66 REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:) :: dardg2dt ! rate of fractional area gain by new ridges (1/s)67 REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:) :: dvirdgdt ! rate of ice volume ridged (m/s)68 REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:) :: opening ! rate of opening due to divergence/shear (1/s)69 60 ! 70 61 !!---------------------------------------------------------------------- … … 83 74 & asum (jpi,jpj) , athorn(jpi,jpj,0:jpl) , & 84 75 & aksum(jpi,jpj) , & 85 !86 76 & hrmin(jpi,jpj,jpl) , hraft(jpi,jpj,jpl) , aridge(jpi,jpj,jpl) , & 87 & hrmax(jpi,jpj,jpl) , krdg (jpi,jpj,jpl) , araft (jpi,jpj,jpl) , & 88 ! 89 !* Ridging diagnostic arrays for history files 90 & dardg1dt(jpi,jpj) , dardg2dt(jpi,jpj) , & 91 & dvirdgdt(jpi,jpj) , opening(jpi,jpj) , STAT=lim_itd_me_alloc ) 77 & hrmax(jpi,jpj,jpl) , krdg (jpi,jpj,jpl) , araft (jpi,jpj,jpl) , STAT=lim_itd_me_alloc ) 92 78 ! 93 79 IF( lim_itd_me_alloc /= 0 ) CALL ctl_warn( 'lim_itd_me_alloc: failed to allocate arrays' ) … … 132 118 REAL(wp), POINTER, DIMENSION(:,:) :: opning ! rate of opening due to divergence/shear 133 119 REAL(wp), POINTER, DIMENSION(:,:) :: closing_gross ! rate at which area removed, not counting area of new ridges 134 REAL(wp), POINTER, DIMENSION(:,:) :: msnow_mlt ! mass of snow added to ocean (kg m-2)135 REAL(wp), POINTER, DIMENSION(:,:) :: esnow_mlt ! energy needed to melt snow in ocean (J m-2)136 REAL(wp), POINTER, DIMENSION(:,:) :: vt_i_init, vt_i_final ! ice volume summed over categories137 120 ! 138 121 INTEGER, PARAMETER :: nitermax = 20 … … 142 125 IF( nn_timing == 1 ) CALL timing_start('limitd_me') 143 126 144 CALL wrk_alloc( jpi,jpj, closing_net, divu_adv, opning, closing_gross , msnow_mlt, esnow_mlt, vt_i_init, vt_i_final)127 CALL wrk_alloc( jpi,jpj, closing_net, divu_adv, opning, closing_gross ) 145 128 146 129 IF(ln_ctl) THEN … … 154 137 IF( ln_limdiahsb ) CALL lim_cons_hsm(0, 'limitd_me', zvi_b, zsmv_b, zei_b, zfw_b, zfs_b, zft_b) 155 138 156 CALL lim_var_zapsmall157 CALL lim_var_glo2eqv ! equivalent variables, requested for rafting158 159 139 !-----------------------------------------------------------------------------! 160 140 ! 1) Thickness categories boundaries, ice / o.w. concentrations, init_ons … … 164 144 CALL lim_itd_me_ridgeprep ! prepare ridging 165 145 ! 166 IF( con_i) CALL lim_column_sum( jpl, v_i, vt_i_init ) ! conservation check167 146 168 147 DO jj = 1, jpj ! Initialize arrays. 169 148 DO ji = 1, jpi 170 msnow_mlt(ji,jj) = 0._wp171 esnow_mlt(ji,jj) = 0._wp172 dardg1dt (ji,jj) = 0._wp173 dardg2dt (ji,jj) = 0._wp174 dvirdgdt (ji,jj) = 0._wp175 opening (ji,jj) = 0._wp176 149 177 150 !-----------------------------------------------------------------------------! … … 204 177 ! If divu_adv < 0, make sure the closing rate is large enough 205 178 ! to give asum = 1.0 after ridging. 206 207 divu_adv(ji,jj) = ( kamax- asum(ji,jj) ) * r1_rdtice ! asum found in ridgeprep179 180 divu_adv(ji,jj) = ( 1._wp - asum(ji,jj) ) * r1_rdtice ! asum found in ridgeprep 208 181 209 182 IF( divu_adv(ji,jj) < 0._wp ) closing_net(ji,jj) = MAX( closing_net(ji,jj), -divu_adv(ji,jj) ) … … 224 197 DO WHILE ( iterate_ridging > 0 .AND. niter < nitermax ) 225 198 199 ! 3.2 closing_gross 200 !-----------------------------------------------------------------------------! 201 ! Based on the ITD of ridging and ridged ice, convert the net 202 ! closing rate to a gross closing rate. 203 ! NOTE: 0 < aksum <= 1 204 closing_gross(:,:) = closing_net(:,:) / aksum(:,:) 205 206 ! correction to closing rate and opening if closing rate is excessive 207 !--------------------------------------------------------------------- 208 ! Reduce the closing rate if more than 100% of the open water 209 ! would be removed. Reduce the opening rate proportionately. 226 210 DO jj = 1, jpj 227 211 DO ji = 1, jpi 228 229 ! 3.2 closing_gross 230 !-----------------------------------------------------------------------------! 231 ! Based on the ITD of ridging and ridged ice, convert the net 232 ! closing rate to a gross closing rate. 233 ! NOTE: 0 < aksum <= 1 234 closing_gross(ji,jj) = closing_net(ji,jj) / aksum(ji,jj) 235 236 ! correction to closing rate and opening if closing rate is excessive 237 !--------------------------------------------------------------------- 238 ! Reduce the closing rate if more than 100% of the open water 239 ! would be removed. Reduce the opening rate proportionately. 240 za = athorn(ji,jj,0) * closing_gross(ji,jj) * rdt_ice 241 IF( za > epsi20 ) THEN 242 zfac = MIN( 1._wp, ato_i(ji,jj) / za ) 243 closing_gross(ji,jj) = closing_gross(ji,jj) * zfac 244 opning (ji,jj) = opning (ji,jj) * zfac 212 za = ( opning(ji,jj) - athorn(ji,jj,0) * closing_gross(ji,jj) ) * rdt_ice 213 IF( za < 0._wp .AND. za > - ato_i(ji,jj) ) THEN ! would lead to negative ato_i 214 zfac = - ato_i(ji,jj) / za 215 opning(ji,jj) = athorn(ji,jj,0) * closing_gross(ji,jj) - ato_i(ji,jj) * r1_rdtice 216 ELSEIF( za > 0._wp .AND. za > ( asum(ji,jj) - ato_i(ji,jj) ) ) THEN ! would lead to ato_i > asum 217 zfac = ( asum(ji,jj) - ato_i(ji,jj) ) / za 218 opning(ji,jj) = athorn(ji,jj,0) * closing_gross(ji,jj) + ( asum(ji,jj) - ato_i(ji,jj) ) * r1_rdtice 245 219 ENDIF 246 247 220 END DO 248 221 END DO … … 256 229 DO ji = 1, jpi 257 230 za = athorn(ji,jj,jl) * closing_gross(ji,jj) * rdt_ice 258 IF( za > epsi20) THEN259 zfac = MIN( 1._wp, a_i(ji,jj,jl) / za )231 IF( za > a_i(ji,jj,jl) ) THEN 232 zfac = a_i(ji,jj,jl) / za 260 233 closing_gross(ji,jj) = closing_gross(ji,jj) * zfac 261 opning (ji,jj) = opning (ji,jj) * zfac262 234 ENDIF 263 235 END DO … … 268 240 !-----------------------------------------------------------------------------! 269 241 270 CALL lim_itd_me_ridgeshift( opning, closing_gross, msnow_mlt, esnow_mlt ) 271 242 CALL lim_itd_me_ridgeshift( opning, closing_gross ) 243 244 272 245 ! 3.4 Compute total area of ice plus open water after ridging. 273 246 !-----------------------------------------------------------------------------! 274 247 ! This is in general not equal to one because of divergence during transport 275 asum(:,:) = ato_i(:,:) 276 DO jl = 1, jpl 277 asum(:,:) = asum(:,:) + a_i(:,:,jl) 278 END DO 248 asum(:,:) = ato_i(:,:) + SUM( a_i, dim=3 ) 279 249 280 250 ! 3.5 Do we keep on iterating ??? … … 284 254 285 255 iterate_ridging = 0 286 287 256 DO jj = 1, jpj 288 257 DO ji = 1, jpi 289 IF (ABS(asum(ji,jj) - kamax ) < epsi10) THEN258 IF( ABS( asum(ji,jj) - 1._wp ) < epsi10 ) THEN 290 259 closing_net(ji,jj) = 0._wp 291 260 opning (ji,jj) = 0._wp 292 261 ELSE 293 262 iterate_ridging = 1 294 divu_adv (ji,jj) = ( kamax- asum(ji,jj) ) * r1_rdtice263 divu_adv (ji,jj) = ( 1._wp - asum(ji,jj) ) * r1_rdtice 295 264 closing_net(ji,jj) = MAX( 0._wp, -divu_adv(ji,jj) ) 296 265 opning (ji,jj) = MAX( 0._wp, divu_adv(ji,jj) ) … … 309 278 310 279 IF( iterate_ridging == 1 ) THEN 280 CALL lim_itd_me_ridgeprep 311 281 IF( niter > nitermax ) THEN 312 282 WRITE(numout,*) ' ALERTE : non-converging ridging scheme ' 313 283 WRITE(numout,*) ' niter, iterate_ridging ', niter, iterate_ridging 314 284 ENDIF 315 CALL lim_itd_me_ridgeprep316 285 ENDIF 317 286 318 287 END DO !! on the do while over iter 319 320 !-----------------------------------------------------------------------------!321 ! 4) Ridging diagnostics322 !-----------------------------------------------------------------------------!323 ! Convert ridging rate diagnostics to correct units.324 ! Update fresh water and heat fluxes due to snow melt.325 DO jj = 1, jpj326 DO ji = 1, jpi327 328 dardg1dt(ji,jj) = dardg1dt(ji,jj) * r1_rdtice329 dardg2dt(ji,jj) = dardg2dt(ji,jj) * r1_rdtice330 dvirdgdt(ji,jj) = dvirdgdt(ji,jj) * r1_rdtice331 opening (ji,jj) = opening (ji,jj) * r1_rdtice332 333 !-----------------------------------------------------------------------------!334 ! 5) Heat, salt and freshwater fluxes335 !-----------------------------------------------------------------------------!336 wfx_snw(ji,jj) = wfx_snw(ji,jj) + msnow_mlt(ji,jj) * r1_rdtice ! fresh water source for ocean337 hfx_dyn(ji,jj) = hfx_dyn(ji,jj) + esnow_mlt(ji,jj) * r1_rdtice ! heat sink for ocean (<0, W.m-2)338 339 END DO340 END DO341 342 ! Check if there is a ridging error343 IF( lwp ) THEN344 DO jj = 1, jpj345 DO ji = 1, jpi346 IF( ABS( asum(ji,jj) - kamax) > epsi10 ) THEN ! there is a bug347 WRITE(numout,*) ' '348 WRITE(numout,*) ' ALERTE : Ridging error: total area = ', asum(ji,jj)349 WRITE(numout,*) ' limitd_me '350 WRITE(numout,*) ' POINT : ', ji, jj351 WRITE(numout,*) ' jpl, a_i, athorn '352 WRITE(numout,*) 0, ato_i(ji,jj), athorn(ji,jj,0)353 DO jl = 1, jpl354 WRITE(numout,*) jl, a_i(ji,jj,jl), athorn(ji,jj,jl)355 END DO356 ENDIF357 END DO358 END DO359 END IF360 361 ! Conservation check362 IF ( con_i ) THEN363 CALL lim_column_sum (jpl, v_i, vt_i_final)364 fieldid = ' v_i : limitd_me '365 CALL lim_cons_check (vt_i_init, vt_i_final, 1.0e-6, fieldid)366 ENDIF367 288 368 289 CALL lim_var_agg( 1 ) … … 377 298 CALL prt_ctl_info(' - Cell values : ') 378 299 CALL prt_ctl_info(' ~~~~~~~~~~~~~ ') 379 CALL prt_ctl(tab2d_1=e1e2t , clinfo1=' lim_itd_me : cell area :')300 CALL prt_ctl(tab2d_1=e1e2t , clinfo1=' lim_itd_me : cell area :') 380 301 CALL prt_ctl(tab2d_1=at_i , clinfo1=' lim_itd_me : at_i :') 381 302 CALL prt_ctl(tab2d_1=vt_i , clinfo1=' lim_itd_me : vt_i :') … … 410 331 ENDIF ! ln_limdyn=.true. 411 332 ! 412 CALL wrk_dealloc( jpi, jpj, closing_net, divu_adv, opning, closing_gross , msnow_mlt, esnow_mlt, vt_i_init, vt_i_final)333 CALL wrk_dealloc( jpi, jpj, closing_net, divu_adv, opning, closing_gross ) 413 334 ! 414 335 IF( nn_timing == 1 ) CALL timing_stop('limitd_me') 415 336 END SUBROUTINE lim_itd_me 416 337 338 SUBROUTINE lim_itd_me_ridgeprep 339 !!---------------------------------------------------------------------! 340 !! *** ROUTINE lim_itd_me_ridgeprep *** 341 !! 342 !! ** Purpose : preparation for ridging and strength calculations 343 !! 344 !! ** Method : Compute the thickness distribution of the ice and open water 345 !! participating in ridging and of the resulting ridges. 346 !!---------------------------------------------------------------------! 347 INTEGER :: ji,jj, jl ! dummy loop indices 348 REAL(wp) :: Gstari, astari, hrmean, zdummy ! local scalar 349 REAL(wp), POINTER, DIMENSION(:,:,:) :: Gsum ! Gsum(n) = sum of areas in categories 0 to n 350 !------------------------------------------------------------------------------! 351 352 CALL wrk_alloc( jpi,jpj,jpl+2, Gsum, kkstart = -1 ) 353 354 Gstari = 1.0/rn_gstar 355 astari = 1.0/rn_astar 356 aksum(:,:) = 0.0 357 athorn(:,:,:) = 0.0 358 aridge(:,:,:) = 0.0 359 araft (:,:,:) = 0.0 360 361 ! Zero out categories with very small areas 362 CALL lim_var_zapsmall 363 364 ! Ice thickness needed for rafting 365 DO jl = 1, jpl 366 DO jj = 1, jpj 367 DO ji = 1, jpi 368 rswitch = MAX( 0._wp , SIGN( 1._wp, a_i(ji,jj,jl) - epsi20 ) ) 369 ht_i(ji,jj,jl) = v_i (ji,jj,jl) / MAX( a_i(ji,jj,jl) , epsi20 ) * rswitch 370 END DO 371 END DO 372 END DO 373 374 !------------------------------------------------------------------------------! 375 ! 1) Participation function 376 !------------------------------------------------------------------------------! 377 378 ! Compute total area of ice plus open water. 379 ! This is in general not equal to one because of divergence during transport 380 asum(:,:) = ato_i(:,:) + SUM( a_i, dim=3 ) 381 382 ! Compute cumulative thickness distribution function 383 ! Compute the cumulative thickness distribution function Gsum, 384 ! where Gsum(n) is the fractional area in categories 0 to n. 385 ! initial value (in h = 0) equals open water area 386 Gsum(:,:,-1) = 0._wp 387 Gsum(:,:,0 ) = ato_i(:,:) 388 ! for each value of h, you have to add ice concentration then 389 DO jl = 1, jpl 390 Gsum(:,:,jl) = Gsum(:,:,jl-1) + a_i(:,:,jl) 391 END DO 392 393 ! Normalize the cumulative distribution to 1 394 DO jl = 0, jpl 395 Gsum(:,:,jl) = Gsum(:,:,jl) / asum(:,:) 396 END DO 397 398 ! 1.3 Compute participation function a(h) = b(h).g(h) (athorn) 399 !-------------------------------------------------------------------------------------------------- 400 ! Compute the participation function athorn; this is analogous to 401 ! a(h) = b(h)g(h) as defined in Thorndike et al. (1975). 402 ! area lost from category n due to ridging/closing 403 ! athorn(n) = total area lost due to ridging/closing 404 ! assume b(h) = (2/Gstar) * (1 - G(h)/Gstar). 405 ! 406 ! The expressions for athorn are found by integrating b(h)g(h) between 407 ! the category boundaries. 408 ! athorn is always >= 0 and SUM(athorn(0:jpl))=1 409 !----------------------------------------------------------------- 410 411 IF( nn_partfun == 0 ) THEN !--- Linear formulation (Thorndike et al., 1975) 412 DO jl = 0, jpl 413 DO jj = 1, jpj 414 DO ji = 1, jpi 415 IF ( Gsum(ji,jj,jl) < rn_gstar ) THEN 416 athorn(ji,jj,jl) = Gstari * ( Gsum(ji,jj,jl) - Gsum(ji,jj,jl-1) ) * & 417 & ( 2._wp - ( Gsum(ji,jj,jl-1) + Gsum(ji,jj,jl) ) * Gstari ) 418 ELSEIF( Gsum(ji,jj,jl-1) < rn_gstar ) THEN 419 athorn(ji,jj,jl) = Gstari * ( rn_gstar - Gsum(ji,jj,jl-1) ) * & 420 & ( 2._wp - ( Gsum(ji,jj,jl-1) + rn_gstar ) * Gstari ) 421 ELSE 422 athorn(ji,jj,jl) = 0._wp 423 ENDIF 424 END DO 425 END DO 426 END DO 427 428 ELSE !--- Exponential, more stable formulation (Lipscomb et al, 2007) 429 ! 430 zdummy = 1._wp / ( 1._wp - EXP(-astari) ) ! precompute exponential terms using Gsum as a work array 431 DO jl = -1, jpl 432 Gsum(:,:,jl) = EXP( -Gsum(:,:,jl) * astari ) * zdummy 433 END DO 434 DO jl = 0, jpl 435 athorn(:,:,jl) = Gsum(:,:,jl-1) - Gsum(:,:,jl) 436 END DO 437 ! 438 ENDIF 439 440 IF( ln_rafting ) THEN ! Ridging and rafting ice participation functions 441 ! 442 DO jl = 1, jpl 443 DO jj = 1, jpj 444 DO ji = 1, jpi 445 zdummy = TANH ( rn_craft * ( ht_i(ji,jj,jl) - rn_hraft ) ) 446 aridge(ji,jj,jl) = ( 1._wp + zdummy ) * 0.5_wp * athorn(ji,jj,jl) 447 araft (ji,jj,jl) = ( 1._wp - zdummy ) * 0.5_wp * athorn(ji,jj,jl) 448 END DO 449 END DO 450 END DO 451 452 ELSE 453 ! 454 DO jl = 1, jpl 455 aridge(:,:,jl) = athorn(:,:,jl) 456 END DO 457 ! 458 ENDIF 459 460 !----------------------------------------------------------------- 461 ! 2) Transfer function 462 !----------------------------------------------------------------- 463 ! Compute max and min ridged ice thickness for each ridging category. 464 ! Assume ridged ice is uniformly distributed between hrmin and hrmax. 465 ! 466 ! This parameterization is a modified version of Hibler (1980). 467 ! The mean ridging thickness, hrmean, is proportional to hi^(0.5) 468 ! and for very thick ridging ice must be >= krdgmin*hi 469 ! 470 ! The minimum ridging thickness, hrmin, is equal to 2*hi 471 ! (i.e., rafting) and for very thick ridging ice is 472 ! constrained by hrmin <= (hrmean + hi)/2. 473 ! 474 ! The maximum ridging thickness, hrmax, is determined by 475 ! hrmean and hrmin. 476 ! 477 ! These modifications have the effect of reducing the ice strength 478 ! (relative to the Hibler formulation) when very thick ice is 479 ! ridging. 480 ! 481 ! aksum = net area removed/ total area removed 482 ! where total area removed = area of ice that ridges 483 ! net area removed = total area removed - area of new ridges 484 !----------------------------------------------------------------- 485 486 aksum(:,:) = athorn(:,:,0) 487 ! Transfer function 488 DO jl = 1, jpl !all categories have a specific transfer function 489 DO jj = 1, jpj 490 DO ji = 1, jpi 491 492 IF( athorn(ji,jj,jl) > 0._wp ) THEN 493 hrmean = MAX( SQRT( rn_hstar * ht_i(ji,jj,jl) ), ht_i(ji,jj,jl) * krdgmin ) 494 hrmin(ji,jj,jl) = MIN( 2._wp * ht_i(ji,jj,jl), 0.5_wp * ( hrmean + ht_i(ji,jj,jl) ) ) 495 hrmax(ji,jj,jl) = 2._wp * hrmean - hrmin(ji,jj,jl) 496 hraft(ji,jj,jl) = ht_i(ji,jj,jl) / kraft 497 krdg(ji,jj,jl) = ht_i(ji,jj,jl) / MAX( hrmean, epsi20 ) 498 499 ! Normalization factor : aksum, ensures mass conservation 500 aksum(ji,jj) = aksum(ji,jj) + aridge(ji,jj,jl) * ( 1._wp - krdg(ji,jj,jl) ) & 501 & + araft (ji,jj,jl) * ( 1._wp - kraft ) 502 503 ELSE 504 hrmin(ji,jj,jl) = 0._wp 505 hrmax(ji,jj,jl) = 0._wp 506 hraft(ji,jj,jl) = 0._wp 507 krdg (ji,jj,jl) = 1._wp 508 ENDIF 509 510 END DO 511 END DO 512 END DO 513 ! 514 CALL wrk_dealloc( jpi,jpj,jpl+2, Gsum, kkstart = -1 ) 515 ! 516 END SUBROUTINE lim_itd_me_ridgeprep 517 518 519 SUBROUTINE lim_itd_me_ridgeshift( opning, closing_gross ) 520 !!---------------------------------------------------------------------- 521 !! *** ROUTINE lim_itd_me_icestrength *** 522 !! 523 !! ** Purpose : shift ridging ice among thickness categories of ice thickness 524 !! 525 !! ** Method : Remove area, volume, and energy from each ridging category 526 !! and add to thicker ice categories. 527 !!---------------------------------------------------------------------- 528 REAL(wp), DIMENSION(jpi,jpj), INTENT(in ) :: opning ! rate of opening due to divergence/shear 529 REAL(wp), DIMENSION(jpi,jpj), INTENT(in ) :: closing_gross ! rate at which area removed, excluding area of new ridges 530 ! 531 CHARACTER (len=80) :: fieldid ! field identifier 532 ! 533 INTEGER :: ji, jj, jl, jl1, jl2, jk ! dummy loop indices 534 INTEGER :: ij ! horizontal index, combines i and j loops 535 INTEGER :: icells ! number of cells with a_i > puny 536 REAL(wp) :: hL, hR, farea ! left and right limits of integration 537 538 INTEGER , POINTER, DIMENSION(:) :: indxi, indxj ! compressed indices 539 REAL(wp), POINTER, DIMENSION(:) :: zswitch, fvol ! new ridge volume going to n2 540 541 REAL(wp), POINTER, DIMENSION(:) :: afrac ! fraction of category area ridged 542 REAL(wp), POINTER, DIMENSION(:) :: ardg1 , ardg2 ! area of ice ridged & new ridges 543 REAL(wp), POINTER, DIMENSION(:) :: vsrdg , esrdg ! snow volume & energy of ridging ice 544 REAL(wp), POINTER, DIMENSION(:) :: dhr , dhr2 ! hrmax - hrmin & hrmax^2 - hrmin^2 545 546 REAL(wp), POINTER, DIMENSION(:) :: vrdg1 ! volume of ice ridged 547 REAL(wp), POINTER, DIMENSION(:) :: vrdg2 ! volume of new ridges 548 REAL(wp), POINTER, DIMENSION(:) :: vsw ! volume of seawater trapped into ridges 549 REAL(wp), POINTER, DIMENSION(:) :: srdg1 ! sal*volume of ice ridged 550 REAL(wp), POINTER, DIMENSION(:) :: srdg2 ! sal*volume of new ridges 551 REAL(wp), POINTER, DIMENSION(:) :: smsw ! sal*volume of water trapped into ridges 552 REAL(wp), POINTER, DIMENSION(:) :: oirdg1, oirdg2 ! ice age of ice ridged 553 554 REAL(wp), POINTER, DIMENSION(:) :: afrft ! fraction of category area rafted 555 REAL(wp), POINTER, DIMENSION(:) :: arft1 , arft2 ! area of ice rafted and new rafted zone 556 REAL(wp), POINTER, DIMENSION(:) :: virft , vsrft ! ice & snow volume of rafting ice 557 REAL(wp), POINTER, DIMENSION(:) :: esrft , smrft ! snow energy & salinity of rafting ice 558 REAL(wp), POINTER, DIMENSION(:) :: oirft1, oirft2 ! ice age of ice rafted 559 560 REAL(wp), POINTER, DIMENSION(:,:) :: eirft ! ice energy of rafting ice 561 REAL(wp), POINTER, DIMENSION(:,:) :: erdg1 ! enth*volume of ice ridged 562 REAL(wp), POINTER, DIMENSION(:,:) :: erdg2 ! enth*volume of new ridges 563 REAL(wp), POINTER, DIMENSION(:,:) :: ersw ! enth of water trapped into ridges 564 !!---------------------------------------------------------------------- 565 566 CALL wrk_alloc( jpij, indxi, indxj ) 567 CALL wrk_alloc( jpij, zswitch, fvol ) 568 CALL wrk_alloc( jpij, afrac, ardg1, ardg2, vsrdg, esrdg, dhr, dhr2 ) 569 CALL wrk_alloc( jpij, vrdg1, vrdg2, vsw , srdg1, srdg2, smsw, oirdg1, oirdg2 ) 570 CALL wrk_alloc( jpij, afrft, arft1, arft2, virft, vsrft, esrft, smrft, oirft1, oirft2 ) 571 CALL wrk_alloc( jpij,nlay_i, eirft, erdg1, erdg2, ersw ) 572 573 !------------------------------------------------------------------------------- 574 ! 1) Compute change in open water area due to closing and opening. 575 !------------------------------------------------------------------------------- 576 DO jj = 1, jpj 577 DO ji = 1, jpi 578 ato_i(ji,jj) = MAX( 0._wp, ato_i(ji,jj) + & 579 & ( opning(ji,jj) - athorn(ji,jj,0) * closing_gross(ji,jj) ) * rdt_ice ) 580 END DO 581 END DO 582 583 !----------------------------------------------------------------- 584 ! 3) Pump everything from ice which is being ridged / rafted 585 !----------------------------------------------------------------- 586 ! Compute the area, volume, and energy of ice ridging in each 587 ! category, along with the area of the resulting ridge. 588 589 DO jl1 = 1, jpl !jl1 describes the ridging category 590 591 !------------------------------------------------ 592 ! 3.1) Identify grid cells with nonzero ridging 593 !------------------------------------------------ 594 icells = 0 595 DO jj = 1, jpj 596 DO ji = 1, jpi 597 IF( athorn(ji,jj,jl1) > 0._wp .AND. closing_gross(ji,jj) > 0._wp ) THEN 598 icells = icells + 1 599 indxi(icells) = ji 600 indxj(icells) = jj 601 ENDIF 602 END DO 603 END DO 604 605 DO ij = 1, icells 606 ji = indxi(ij) ; jj = indxj(ij) 607 608 !-------------------------------------------------------------------- 609 ! 3.2) Compute area of ridging ice (ardg1) and of new ridge (ardg2) 610 !-------------------------------------------------------------------- 611 ardg1(ij) = aridge(ji,jj,jl1) * closing_gross(ji,jj) * rdt_ice 612 arft1(ij) = araft (ji,jj,jl1) * closing_gross(ji,jj) * rdt_ice 613 614 !--------------------------------------------------------------- 615 ! 3.3) Compute ridging /rafting fractions, make sure afrac <=1 616 !--------------------------------------------------------------- 617 afrac(ij) = ardg1(ij) / a_i(ji,jj,jl1) !ridging 618 afrft(ij) = arft1(ij) / a_i(ji,jj,jl1) !rafting 619 ardg2(ij) = ardg1(ij) * krdg(ji,jj,jl1) 620 arft2(ij) = arft1(ij) * kraft 621 622 !-------------------------------------------------------------------------- 623 ! 3.4) Subtract area, volume, and energy from ridging 624 ! / rafting category n1. 625 !-------------------------------------------------------------------------- 626 vrdg1(ij) = v_i(ji,jj,jl1) * afrac(ij) 627 vrdg2(ij) = vrdg1(ij) * ( 1. + rn_por_rdg ) 628 vsw (ij) = vrdg1(ij) * rn_por_rdg 629 630 vsrdg (ij) = v_s (ji,jj, jl1) * afrac(ij) 631 esrdg (ij) = e_s (ji,jj,1,jl1) * afrac(ij) 632 srdg1 (ij) = smv_i(ji,jj, jl1) * afrac(ij) 633 oirdg1(ij) = oa_i (ji,jj, jl1) * afrac(ij) 634 oirdg2(ij) = oa_i (ji,jj, jl1) * afrac(ij) * krdg(ji,jj,jl1) 635 636 ! rafting volumes, heat contents ... 637 virft (ij) = v_i (ji,jj, jl1) * afrft(ij) 638 vsrft (ij) = v_s (ji,jj, jl1) * afrft(ij) 639 esrft (ij) = e_s (ji,jj,1,jl1) * afrft(ij) 640 smrft (ij) = smv_i(ji,jj, jl1) * afrft(ij) 641 oirft1(ij) = oa_i (ji,jj, jl1) * afrft(ij) 642 oirft2(ij) = oa_i (ji,jj, jl1) * afrft(ij) * kraft 643 644 !----------------------------------------------------------------- 645 ! 3.5) Compute properties of new ridges 646 !----------------------------------------------------------------- 647 smsw(ij) = vsw(ij) * sss_m(ji,jj) ! salt content of seawater frozen in voids 648 srdg2(ij) = srdg1(ij) + smsw(ij) ! salt content of new ridge 649 650 sfx_dyn(ji,jj) = sfx_dyn(ji,jj) - smsw(ij) * rhoic * r1_rdtice 651 wfx_dyn(ji,jj) = wfx_dyn(ji,jj) - vsw (ij) * rhoic * r1_rdtice ! increase in ice volume due to seawater frozen in voids 652 653 ! virtual salt flux to keep salinity constant 654 IF( nn_icesal == 1 .OR. nn_icesal == 3 ) THEN 655 srdg2(ij) = srdg2(ij) - vsw(ij) * ( sss_m(ji,jj) - sm_i(ji,jj,jl1) ) ! ridge salinity = sm_i 656 sfx_bri(ji,jj) = sfx_bri(ji,jj) + sss_m(ji,jj) * vsw(ij) * rhoic * r1_rdtice & ! put back sss_m into the ocean 657 & - sm_i(ji,jj,jl1) * vsw(ij) * rhoic * r1_rdtice ! and get sm_i from the ocean 658 ENDIF 659 660 !------------------------------------------ 661 ! 3.7 Put the snow somewhere in the ocean 662 !------------------------------------------ 663 ! Place part of the snow lost by ridging into the ocean. 664 ! Note that esrdg > 0; the ocean must cool to melt snow. 665 ! If the ocean temp = Tf already, new ice must grow. 666 ! During the next time step, thermo_rates will determine whether 667 ! the ocean cools or new ice grows. 668 wfx_snw(ji,jj) = wfx_snw(ji,jj) + ( rhosn * vsrdg(ij) * ( 1._wp - rn_fsnowrdg ) & 669 & + rhosn * vsrft(ij) * ( 1._wp - rn_fsnowrft ) ) * r1_rdtice ! fresh water source for ocean 670 671 hfx_dyn(ji,jj) = hfx_dyn(ji,jj) + ( - esrdg(ij) * ( 1._wp - rn_fsnowrdg ) & 672 & - esrft(ij) * ( 1._wp - rn_fsnowrft ) ) * r1_rdtice ! heat sink for ocean (<0, W.m-2) 673 674 !----------------------------------------------------------------- 675 ! 3.8 Compute quantities used to apportion ice among categories 676 ! in the n2 loop below 677 !----------------------------------------------------------------- 678 dhr (ij) = 1._wp / ( hrmax(ji,jj,jl1) - hrmin(ji,jj,jl1) ) 679 dhr2(ij) = 1._wp / ( hrmax(ji,jj,jl1) * hrmax(ji,jj,jl1) - hrmin(ji,jj,jl1) * hrmin(ji,jj,jl1) ) 680 681 682 ! update jl1 (removing ridged/rafted area) 683 a_i (ji,jj, jl1) = a_i (ji,jj, jl1) - ardg1 (ij) - arft1 (ij) 684 v_i (ji,jj, jl1) = v_i (ji,jj, jl1) - vrdg1 (ij) - virft (ij) 685 v_s (ji,jj, jl1) = v_s (ji,jj, jl1) - vsrdg (ij) - vsrft (ij) 686 e_s (ji,jj,1,jl1) = e_s (ji,jj,1,jl1) - esrdg (ij) - esrft (ij) 687 smv_i(ji,jj, jl1) = smv_i(ji,jj, jl1) - srdg1 (ij) - smrft (ij) 688 oa_i (ji,jj, jl1) = oa_i (ji,jj, jl1) - oirdg1(ij) - oirft1(ij) 689 690 END DO 691 692 !-------------------------------------------------------------------- 693 ! 3.9 Compute ridging ice enthalpy, remove it from ridging ice and 694 ! compute ridged ice enthalpy 695 !-------------------------------------------------------------------- 696 DO jk = 1, nlay_i 697 DO ij = 1, icells 698 ji = indxi(ij) ; jj = indxj(ij) 699 ! heat content of ridged ice 700 erdg1(ij,jk) = e_i(ji,jj,jk,jl1) * afrac(ij) 701 eirft(ij,jk) = e_i(ji,jj,jk,jl1) * afrft(ij) 702 703 ! enthalpy of the trapped seawater (J/m2, >0) 704 ! clem: if sst>0, then ersw <0 (is that possible?) 705 ersw(ij,jk) = - rhoic * vsw(ij) * rcp * sst_m(ji,jj) * r1_nlay_i 706 707 ! heat flux to the ocean 708 hfx_dyn(ji,jj) = hfx_dyn(ji,jj) + ersw(ij,jk) * r1_rdtice ! > 0 [W.m-2] ocean->ice flux 709 710 ! it is added to sea ice because the sign convention is the opposite of the sign convention for the ocean 711 erdg2(ij,jk) = erdg1(ij,jk) + ersw(ij,jk) 712 713 ! update jl1 714 e_i (ji,jj,jk,jl1) = e_i(ji,jj,jk,jl1) - erdg1(ij,jk) - eirft(ij,jk) 715 716 END DO 717 END DO 718 719 !------------------------------------------------------------------------------- 720 ! 4) Add area, volume, and energy of new ridge to each category jl2 721 !------------------------------------------------------------------------------- 722 DO jl2 = 1, jpl 723 ! over categories to which ridged/rafted ice is transferred 724 DO ij = 1, icells 725 ji = indxi(ij) ; jj = indxj(ij) 726 727 ! Compute the fraction of ridged ice area and volume going to thickness category jl2. 728 IF( hrmin(ji,jj,jl1) <= hi_max(jl2) .AND. hrmax(ji,jj,jl1) > hi_max(jl2-1) ) THEN 729 hL = MAX( hrmin(ji,jj,jl1), hi_max(jl2-1) ) 730 hR = MIN( hrmax(ji,jj,jl1), hi_max(jl2) ) 731 farea = ( hR - hL ) * dhr(ij) 732 fvol(ij) = ( hR * hR - hL * hL ) * dhr2(ij) 733 ELSE 734 farea = 0._wp 735 fvol(ij) = 0._wp 736 ENDIF 737 738 ! Compute the fraction of rafted ice area and volume going to thickness category jl2 739 IF( hraft(ji,jj,jl1) <= hi_max(jl2) .AND. hraft(ji,jj,jl1) > hi_max(jl2-1) ) THEN 740 zswitch(ij) = 1._wp 741 ELSE 742 zswitch(ij) = 0._wp 743 ENDIF 744 745 a_i (ji,jj ,jl2) = a_i (ji,jj ,jl2) + ( ardg2 (ij) * farea + arft2 (ij) * zswitch(ij) ) 746 oa_i (ji,jj ,jl2) = oa_i (ji,jj ,jl2) + ( oirdg2(ij) * farea + oirft2(ij) * zswitch(ij) ) 747 v_i (ji,jj ,jl2) = v_i (ji,jj ,jl2) + ( vrdg2 (ij) * fvol(ij) + virft (ij) * zswitch(ij) ) 748 smv_i(ji,jj ,jl2) = smv_i(ji,jj ,jl2) + ( srdg2 (ij) * fvol(ij) + smrft (ij) * zswitch(ij) ) 749 v_s (ji,jj ,jl2) = v_s (ji,jj ,jl2) + ( vsrdg (ij) * rn_fsnowrdg * fvol(ij) + & 750 & vsrft (ij) * rn_fsnowrft * zswitch(ij) ) 751 e_s (ji,jj,1,jl2) = e_s (ji,jj,1,jl2) + ( esrdg (ij) * rn_fsnowrdg * fvol(ij) + & 752 & esrft (ij) * rn_fsnowrft * zswitch(ij) ) 753 754 END DO 755 756 ! Transfer ice energy to category jl2 by ridging 757 DO jk = 1, nlay_i 758 DO ij = 1, icells 759 ji = indxi(ij) ; jj = indxj(ij) 760 e_i(ji,jj,jk,jl2) = e_i(ji,jj,jk,jl2) + erdg2(ij,jk) * fvol(ij) + eirft(ij,jk) * zswitch(ij) 761 END DO 762 END DO 763 ! 764 END DO ! jl2 765 766 END DO ! jl1 (deforming categories) 767 768 ! 769 CALL wrk_dealloc( jpij, indxi, indxj ) 770 CALL wrk_dealloc( jpij, zswitch, fvol ) 771 CALL wrk_dealloc( jpij, afrac, ardg1, ardg2, vsrdg, esrdg, dhr, dhr2 ) 772 CALL wrk_dealloc( jpij, vrdg1, vrdg2, vsw , srdg1, srdg2, smsw, oirdg1, oirdg2 ) 773 CALL wrk_dealloc( jpij, afrft, arft1, arft2, virft, vsrft, esrft, smrft, oirft1, oirft2 ) 774 CALL wrk_dealloc( jpij,nlay_i, eirft, erdg1, erdg2, ersw ) 775 ! 776 END SUBROUTINE lim_itd_me_ridgeshift 417 777 418 778 SUBROUTINE lim_itd_me_icestrength( kstrngth ) … … 434 794 INTEGER :: ksmooth ! smoothing the resistance to deformation 435 795 INTEGER :: numts_rm ! number of time steps for the P smoothing 436 REAL(wp) :: z hi, zp, z1_3! local scalars796 REAL(wp) :: zp, z1_3 ! local scalars 437 797 REAL(wp), POINTER, DIMENSION(:,:) :: zworka ! temporary array used here 438 798 !!---------------------------------------------------------------------- … … 459 819 DO ji = 1, jpi 460 820 ! 461 IF( a_i(ji,jj,jl) > epsi10 .AND. athorn(ji,jj,jl) > 0._wp ) THEN 462 zhi = v_i(ji,jj,jl) / a_i(ji,jj,jl) 821 IF( athorn(ji,jj,jl) > 0._wp ) THEN 463 822 !---------------------------- 464 823 ! PE loss from deforming ice 465 824 !---------------------------- 466 strength(ji,jj) = strength(ji,jj) - athorn(ji,jj,jl) * zhi * zhi825 strength(ji,jj) = strength(ji,jj) - athorn(ji,jj,jl) * ht_i(ji,jj,jl) * ht_i(ji,jj,jl) 467 826 468 827 !-------------------------- 469 828 ! PE gain from rafting ice 470 829 !-------------------------- 471 strength(ji,jj) = strength(ji,jj) + 2._wp * araft(ji,jj,jl) * zhi * zhi830 strength(ji,jj) = strength(ji,jj) + 2._wp * araft(ji,jj,jl) * ht_i(ji,jj,jl) * ht_i(ji,jj,jl) 472 831 473 832 !---------------------------- 474 833 ! PE gain from ridging ice 475 834 !---------------------------- 476 strength(ji,jj) = strength(ji,jj) + aridge(ji,jj,jl) / krdg(ji,jj,jl) & 477 * z1_3 * ( hrmax(ji,jj,jl)**2 + hrmin(ji,jj,jl)**2 + hrmax(ji,jj,jl) * hrmin(ji,jj,jl) ) 835 strength(ji,jj) = strength(ji,jj) + aridge(ji,jj,jl) * krdg(ji,jj,jl) * z1_3 * & 836 & ( hrmax(ji,jj,jl) * hrmax(ji,jj,jl) + & 837 & hrmin(ji,jj,jl) * hrmin(ji,jj,jl) + & 838 & hrmax(ji,jj,jl) * hrmin(ji,jj,jl) ) 478 839 !!(a**3-b**3)/(a-b) = a*a+ab+b*b 479 840 ENDIF … … 497 858 ! 498 859 ENDIF ! kstrngth 499 500 860 ! 501 861 !------------------------------------------------------------------------------! … … 503 863 !------------------------------------------------------------------------------! 504 864 ! CAN BE REMOVED 505 !506 865 IF( ln_icestr_bvf ) THEN 507 508 866 DO jj = 1, jpj 509 867 DO ji = 1, jpi … … 511 869 END DO 512 870 END DO 513 514 871 ENDIF 515 516 872 ! 517 873 !------------------------------------------------------------------------------! … … 558 914 IF ( ksmooth == 2 ) THEN 559 915 560 561 916 CALL lbc_lnk( strength, 'T', 1. ) 562 917 … … 565 920 IF ( ( asum(ji,jj) - ato_i(ji,jj) ) > 0._wp) THEN 566 921 numts_rm = 1 ! number of time steps for the running mean 567 IF ( strp1(ji,jj) > 0. 0) numts_rm = numts_rm + 1568 IF ( strp2(ji,jj) > 0. 0) numts_rm = numts_rm + 1922 IF ( strp1(ji,jj) > 0._wp ) numts_rm = numts_rm + 1 923 IF ( strp2(ji,jj) > 0._wp ) numts_rm = numts_rm + 1 569 924 zp = ( strength(ji,jj) + strp1(ji,jj) + strp2(ji,jj) ) / numts_rm 570 925 strp2(ji,jj) = strp1(ji,jj) … … 583 938 ! 584 939 END SUBROUTINE lim_itd_me_icestrength 585 586 587 SUBROUTINE lim_itd_me_ridgeprep588 !!---------------------------------------------------------------------!589 !! *** ROUTINE lim_itd_me_ridgeprep ***590 !!591 !! ** Purpose : preparation for ridging and strength calculations592 !!593 !! ** Method : Compute the thickness distribution of the ice and open water594 !! participating in ridging and of the resulting ridges.595 !!---------------------------------------------------------------------!596 INTEGER :: ji,jj, jl ! dummy loop indices597 REAL(wp) :: Gstari, astari, zhi, hrmean, zdummy ! local scalar598 REAL(wp), POINTER, DIMENSION(:,:) :: zworka ! temporary array used here599 REAL(wp), POINTER, DIMENSION(:,:,:) :: Gsum ! Gsum(n) = sum of areas in categories 0 to n600 !------------------------------------------------------------------------------!601 602 CALL wrk_alloc( jpi,jpj, zworka )603 CALL wrk_alloc( jpi,jpj,jpl+2, Gsum, kkstart = -1 )604 605 Gstari = 1.0/rn_gstar606 astari = 1.0/rn_astar607 aksum(:,:) = 0.0608 athorn(:,:,:) = 0.0609 aridge(:,:,:) = 0.0610 araft (:,:,:) = 0.0611 hrmin(:,:,:) = 0.0612 hrmax(:,:,:) = 0.0613 hraft(:,:,:) = 0.0614 krdg (:,:,:) = 1.0615 616 ! ! Zero out categories with very small areas617 CALL lim_var_zapsmall618 619 !------------------------------------------------------------------------------!620 ! 1) Participation function621 !------------------------------------------------------------------------------!622 623 ! Compute total area of ice plus open water.624 ! This is in general not equal to one because of divergence during transport625 asum(:,:) = ato_i(:,:)626 DO jl = 1, jpl627 asum(:,:) = asum(:,:) + a_i(:,:,jl)628 END DO629 630 ! Compute cumulative thickness distribution function631 ! Compute the cumulative thickness distribution function Gsum,632 ! where Gsum(n) is the fractional area in categories 0 to n.633 ! initial value (in h = 0) equals open water area634 635 Gsum(:,:,-1) = 0._wp636 Gsum(:,:,0 ) = ato_i(:,:)637 638 ! for each value of h, you have to add ice concentration then639 DO jl = 1, jpl640 Gsum(:,:,jl) = Gsum(:,:,jl-1) + a_i(:,:,jl)641 END DO642 643 ! Normalize the cumulative distribution to 1644 zworka(:,:) = 1._wp / Gsum(:,:,jpl)645 DO jl = 0, jpl646 Gsum(:,:,jl) = Gsum(:,:,jl) * zworka(:,:)647 END DO648 649 ! 1.3 Compute participation function a(h) = b(h).g(h) (athorn)650 !--------------------------------------------------------------------------------------------------651 ! Compute the participation function athorn; this is analogous to652 ! a(h) = b(h)g(h) as defined in Thorndike et al. (1975).653 ! area lost from category n due to ridging/closing654 ! athorn(n) = total area lost due to ridging/closing655 ! assume b(h) = (2/Gstar) * (1 - G(h)/Gstar).656 !657 ! The expressions for athorn are found by integrating b(h)g(h) between658 ! the category boundaries.659 !-----------------------------------------------------------------660 661 IF( nn_partfun == 0 ) THEN !--- Linear formulation (Thorndike et al., 1975)662 DO jl = 0, jpl663 DO jj = 1, jpj664 DO ji = 1, jpi665 IF( Gsum(ji,jj,jl) < rn_gstar) THEN666 athorn(ji,jj,jl) = Gstari * ( Gsum(ji,jj,jl) - Gsum(ji,jj,jl-1) ) * &667 & ( 2.0 - (Gsum(ji,jj,jl-1) + Gsum(ji,jj,jl) ) * Gstari )668 ELSEIF (Gsum(ji,jj,jl-1) < rn_gstar) THEN669 athorn(ji,jj,jl) = Gstari * ( rn_gstar - Gsum(ji,jj,jl-1) ) * &670 & ( 2.0 - ( Gsum(ji,jj,jl-1) + rn_gstar ) * Gstari )671 ELSE672 athorn(ji,jj,jl) = 0.0673 ENDIF674 END DO675 END DO676 END DO677 678 ELSE !--- Exponential, more stable formulation (Lipscomb et al, 2007)679 !680 zdummy = 1._wp / ( 1._wp - EXP(-astari) ) ! precompute exponential terms using Gsum as a work array681 DO jl = -1, jpl682 Gsum(:,:,jl) = EXP( -Gsum(:,:,jl) * astari ) * zdummy683 END DO684 DO jl = 0, jpl685 athorn(:,:,jl) = Gsum(:,:,jl-1) - Gsum(:,:,jl)686 END DO687 !688 ENDIF689 690 IF( ln_rafting ) THEN ! Ridging and rafting ice participation functions691 !692 DO jl = 1, jpl693 DO jj = 1, jpj694 DO ji = 1, jpi695 IF ( athorn(ji,jj,jl) > 0._wp ) THEN696 !!gm TANH( -X ) = - TANH( X ) so can be computed only 1 time....697 aridge(ji,jj,jl) = ( TANH ( rn_craft * ( ht_i(ji,jj,jl) - rn_hraft ) ) + 1.0 ) * 0.5 * athorn(ji,jj,jl)698 araft (ji,jj,jl) = ( TANH ( -rn_craft * ( ht_i(ji,jj,jl) - rn_hraft ) ) + 1.0 ) * 0.5 * athorn(ji,jj,jl)699 IF ( araft(ji,jj,jl) < epsi06 ) araft(ji,jj,jl) = 0._wp700 aridge(ji,jj,jl) = MAX( athorn(ji,jj,jl) - araft(ji,jj,jl), 0.0 )701 ENDIF702 END DO703 END DO704 END DO705 706 ELSE707 !708 DO jl = 1, jpl709 aridge(:,:,jl) = athorn(:,:,jl)710 END DO711 !712 ENDIF713 714 IF( ln_rafting ) THEN715 716 IF( MAXVAL(aridge + araft - athorn(:,:,1:jpl)) > epsi10 .AND. lwp ) THEN717 DO jl = 1, jpl718 DO jj = 1, jpj719 DO ji = 1, jpi720 IF ( aridge(ji,jj,jl) + araft(ji,jj,jl) - athorn(ji,jj,jl) > epsi10 ) THEN721 WRITE(numout,*) ' ALERTE 96 : wrong participation function ... '722 WRITE(numout,*) ' ji, jj, jl : ', ji, jj, jl723 WRITE(numout,*) ' lat, lon : ', gphit(ji,jj), glamt(ji,jj)724 WRITE(numout,*) ' aridge : ', aridge(ji,jj,1:jpl)725 WRITE(numout,*) ' araft : ', araft(ji,jj,1:jpl)726 WRITE(numout,*) ' athorn : ', athorn(ji,jj,1:jpl)727 ENDIF728 END DO729 END DO730 END DO731 ENDIF732 733 ENDIF734 735 !-----------------------------------------------------------------736 ! 2) Transfer function737 !-----------------------------------------------------------------738 ! Compute max and min ridged ice thickness for each ridging category.739 ! Assume ridged ice is uniformly distributed between hrmin and hrmax.740 !741 ! This parameterization is a modified version of Hibler (1980).742 ! The mean ridging thickness, hrmean, is proportional to hi^(0.5)743 ! and for very thick ridging ice must be >= krdgmin*hi744 !745 ! The minimum ridging thickness, hrmin, is equal to 2*hi746 ! (i.e., rafting) and for very thick ridging ice is747 ! constrained by hrmin <= (hrmean + hi)/2.748 !749 ! The maximum ridging thickness, hrmax, is determined by750 ! hrmean and hrmin.751 !752 ! These modifications have the effect of reducing the ice strength753 ! (relative to the Hibler formulation) when very thick ice is754 ! ridging.755 !756 ! aksum = net area removed/ total area removed757 ! where total area removed = area of ice that ridges758 ! net area removed = total area removed - area of new ridges759 !-----------------------------------------------------------------760 761 ! Transfer function762 DO jl = 1, jpl !all categories have a specific transfer function763 DO jj = 1, jpj764 DO ji = 1, jpi765 766 IF (a_i(ji,jj,jl) > epsi10 .AND. athorn(ji,jj,jl) > 0.0 ) THEN767 zhi = v_i(ji,jj,jl) / a_i(ji,jj,jl)768 hrmean = MAX(SQRT(rn_hstar*zhi), zhi*krdgmin)769 hrmin(ji,jj,jl) = MIN(2.0*zhi, 0.5*(hrmean + zhi))770 hrmax(ji,jj,jl) = 2.0*hrmean - hrmin(ji,jj,jl)771 hraft(ji,jj,jl) = kraft*zhi772 krdg(ji,jj,jl) = hrmean / zhi773 ELSE774 hraft(ji,jj,jl) = 0.0775 hrmin(ji,jj,jl) = 0.0776 hrmax(ji,jj,jl) = 0.0777 krdg (ji,jj,jl) = 1.0778 ENDIF779 780 END DO781 END DO782 END DO783 784 ! Normalization factor : aksum, ensures mass conservation785 aksum(:,:) = athorn(:,:,0)786 DO jl = 1, jpl787 aksum(:,:) = aksum(:,:) + aridge(:,:,jl) * ( 1._wp - 1._wp / krdg(:,:,jl) ) &788 & + araft (:,:,jl) * ( 1._wp - 1._wp / kraft )789 END DO790 !791 CALL wrk_dealloc( jpi,jpj, zworka )792 CALL wrk_dealloc( jpi,jpj,jpl+2, Gsum, kkstart = -1 )793 !794 END SUBROUTINE lim_itd_me_ridgeprep795 796 797 SUBROUTINE lim_itd_me_ridgeshift( opning, closing_gross, msnow_mlt, esnow_mlt )798 !!----------------------------------------------------------------------799 !! *** ROUTINE lim_itd_me_icestrength ***800 !!801 !! ** Purpose : shift ridging ice among thickness categories of ice thickness802 !!803 !! ** Method : Remove area, volume, and energy from each ridging category804 !! and add to thicker ice categories.805 !!----------------------------------------------------------------------806 REAL(wp), DIMENSION(jpi,jpj), INTENT(in ) :: opning ! rate of opening due to divergence/shear807 REAL(wp), DIMENSION(jpi,jpj), INTENT(in ) :: closing_gross ! rate at which area removed, excluding area of new ridges808 REAL(wp), DIMENSION(jpi,jpj), INTENT(inout) :: msnow_mlt ! mass of snow added to ocean (kg m-2)809 REAL(wp), DIMENSION(jpi,jpj), INTENT(inout) :: esnow_mlt ! energy needed to melt snow in ocean (J m-2)810 !811 CHARACTER (len=80) :: fieldid ! field identifier812 LOGICAL, PARAMETER :: l_conservation_check = .true. ! if true, check conservation (useful for debugging)813 !814 INTEGER :: ji, jj, jl, jl1, jl2, jk ! dummy loop indices815 INTEGER :: ij ! horizontal index, combines i and j loops816 INTEGER :: icells ! number of cells with aicen > puny817 REAL(wp) :: hL, hR, farea, ztmelts ! left and right limits of integration818 819 INTEGER , POINTER, DIMENSION(:) :: indxi, indxj ! compressed indices820 821 REAL(wp), POINTER, DIMENSION(:,:) :: vice_init, vice_final ! ice volume summed over categories822 REAL(wp), POINTER, DIMENSION(:,:) :: eice_init, eice_final ! ice energy summed over layers823 824 REAL(wp), POINTER, DIMENSION(:,:,:) :: aicen_init, vicen_init ! ice area & volume before ridging825 REAL(wp), POINTER, DIMENSION(:,:,:) :: vsnwn_init, esnwn_init ! snow volume & energy before ridging826 REAL(wp), POINTER, DIMENSION(:,:,:) :: smv_i_init, oa_i_init ! ice salinity & age before ridging827 828 REAL(wp), POINTER, DIMENSION(:,:,:,:) :: eicen_init ! ice energy before ridging829 830 REAL(wp), POINTER, DIMENSION(:,:) :: afrac , fvol ! fraction of category area ridged & new ridge volume going to n2831 REAL(wp), POINTER, DIMENSION(:,:) :: ardg1 , ardg2 ! area of ice ridged & new ridges832 REAL(wp), POINTER, DIMENSION(:,:) :: vsrdg , esrdg ! snow volume & energy of ridging ice833 REAL(wp), POINTER, DIMENSION(:,:) :: dhr , dhr2 ! hrmax - hrmin & hrmax^2 - hrmin^2834 835 REAL(wp), POINTER, DIMENSION(:,:) :: vrdg1 ! volume of ice ridged836 REAL(wp), POINTER, DIMENSION(:,:) :: vrdg2 ! volume of new ridges837 REAL(wp), POINTER, DIMENSION(:,:) :: vsw ! volume of seawater trapped into ridges838 REAL(wp), POINTER, DIMENSION(:,:) :: srdg1 ! sal*volume of ice ridged839 REAL(wp), POINTER, DIMENSION(:,:) :: srdg2 ! sal*volume of new ridges840 REAL(wp), POINTER, DIMENSION(:,:) :: smsw ! sal*volume of water trapped into ridges841 REAL(wp), POINTER, DIMENSION(:,:) :: oirdg1, oirdg2 ! ice age of ice ridged842 843 REAL(wp), POINTER, DIMENSION(:,:) :: afrft ! fraction of category area rafted844 REAL(wp), POINTER, DIMENSION(:,:) :: arft1 , arft2 ! area of ice rafted and new rafted zone845 REAL(wp), POINTER, DIMENSION(:,:) :: virft , vsrft ! ice & snow volume of rafting ice846 REAL(wp), POINTER, DIMENSION(:,:) :: esrft , smrft ! snow energy & salinity of rafting ice847 REAL(wp), POINTER, DIMENSION(:,:) :: oirft1, oirft2 ! ice age of ice rafted848 849 REAL(wp), POINTER, DIMENSION(:,:,:) :: eirft ! ice energy of rafting ice850 REAL(wp), POINTER, DIMENSION(:,:,:) :: erdg1 ! enth*volume of ice ridged851 REAL(wp), POINTER, DIMENSION(:,:,:) :: erdg2 ! enth*volume of new ridges852 REAL(wp), POINTER, DIMENSION(:,:,:) :: ersw ! enth of water trapped into ridges853 !!----------------------------------------------------------------------854 855 CALL wrk_alloc( (jpi+1)*(jpj+1), indxi, indxj )856 CALL wrk_alloc( jpi, jpj, vice_init, vice_final, eice_init, eice_final )857 CALL wrk_alloc( jpi, jpj, afrac, fvol , ardg1, ardg2, vsrdg, esrdg, dhr, dhr2 )858 CALL wrk_alloc( jpi, jpj, vrdg1, vrdg2, vsw , srdg1, srdg2, smsw, oirdg1, oirdg2 )859 CALL wrk_alloc( jpi, jpj, afrft, arft1, arft2, virft, vsrft, esrft, smrft, oirft1, oirft2 )860 CALL wrk_alloc( jpi, jpj, jpl, aicen_init, vicen_init, vsnwn_init, esnwn_init, smv_i_init, oa_i_init )861 CALL wrk_alloc( jpi, jpj, nlay_i, eirft, erdg1, erdg2, ersw )862 CALL wrk_alloc( jpi, jpj, nlay_i, jpl, eicen_init )863 864 ! Conservation check865 eice_init(:,:) = 0._wp866 867 IF( con_i ) THEN868 CALL lim_column_sum (jpl, v_i, vice_init )869 CALL lim_column_sum_energy (jpl, nlay_i, e_i, eice_init )870 DO ji = mi0(iiceprt), mi1(iiceprt)871 DO jj = mj0(jiceprt), mj1(jiceprt)872 WRITE(numout,*) ' vice_init : ', vice_init(ji,jj)873 WRITE(numout,*) ' eice_init : ', eice_init(ji,jj)874 END DO875 END DO876 ENDIF877 878 !-------------------------------------------------------------------------------879 ! 1) Compute change in open water area due to closing and opening.880 !-------------------------------------------------------------------------------881 DO jj = 1, jpj882 DO ji = 1, jpi883 ato_i(ji,jj) = ato_i(ji,jj) - athorn(ji,jj,0) * closing_gross(ji,jj) * rdt_ice &884 & + opning(ji,jj) * rdt_ice885 IF ( ato_i(ji,jj) < -epsi10 ) THEN ! there is a bug886 IF(lwp) WRITE(numout,*) 'Ridging error: ato_i < 0 -- ato_i : ',ato_i(ji,jj)887 ELSEIF( ato_i(ji,jj) < 0._wp ) THEN ! roundoff error888 ato_i(ji,jj) = 0._wp889 ENDIF890 END DO891 END DO892 893 !-----------------------------------------------------------------894 ! 2) Save initial state variables895 !-----------------------------------------------------------------896 aicen_init(:,:,:) = a_i (:,:,:)897 vicen_init(:,:,:) = v_i (:,:,:)898 vsnwn_init(:,:,:) = v_s (:,:,:)899 smv_i_init(:,:,:) = smv_i(:,:,:)900 esnwn_init(:,:,:) = e_s (:,:,1,:)901 eicen_init(:,:,:,:) = e_i (:,:,:,:)902 oa_i_init (:,:,:) = oa_i (:,:,:)903 904 !905 !-----------------------------------------------------------------906 ! 3) Pump everything from ice which is being ridged / rafted907 !-----------------------------------------------------------------908 ! Compute the area, volume, and energy of ice ridging in each909 ! category, along with the area of the resulting ridge.910 911 DO jl1 = 1, jpl !jl1 describes the ridging category912 913 !------------------------------------------------914 ! 3.1) Identify grid cells with nonzero ridging915 !------------------------------------------------916 917 icells = 0918 DO jj = 1, jpj919 DO ji = 1, jpi920 IF( aicen_init(ji,jj,jl1) > epsi10 .AND. athorn(ji,jj,jl1) > 0._wp &921 & .AND. closing_gross(ji,jj) > 0._wp ) THEN922 icells = icells + 1923 indxi(icells) = ji924 indxj(icells) = jj925 ENDIF926 END DO927 END DO928 929 DO ij = 1, icells930 ji = indxi(ij)931 jj = indxj(ij)932 933 !--------------------------------------------------------------------934 ! 3.2) Compute area of ridging ice (ardg1) and of new ridge (ardg2)935 !--------------------------------------------------------------------936 937 ardg1(ji,jj) = aridge(ji,jj,jl1)*closing_gross(ji,jj)*rdt_ice938 arft1(ji,jj) = araft (ji,jj,jl1)*closing_gross(ji,jj)*rdt_ice939 ardg2(ji,jj) = ardg1(ji,jj) / krdg(ji,jj,jl1)940 arft2(ji,jj) = arft1(ji,jj) / kraft941 942 !---------------------------------------------------------------943 ! 3.3) Compute ridging /rafting fractions, make sure afrac <=1944 !---------------------------------------------------------------945 946 afrac(ji,jj) = ardg1(ji,jj) / aicen_init(ji,jj,jl1) !ridging947 afrft(ji,jj) = arft1(ji,jj) / aicen_init(ji,jj,jl1) !rafting948 949 IF( afrac(ji,jj) > kamax + epsi10 ) THEN ! there is a bug950 IF(lwp) WRITE(numout,*) ' ardg > a_i -- ardg, aicen_init : ', ardg1(ji,jj), aicen_init(ji,jj,jl1)951 ELSEIF( afrac(ji,jj) > kamax ) THEN ! roundoff error952 afrac(ji,jj) = kamax953 ENDIF954 955 IF( afrft(ji,jj) > kamax + epsi10 ) THEN ! there is a bug956 IF(lwp) WRITE(numout,*) ' arft > a_i -- arft, aicen_init : ', arft1(ji,jj), aicen_init(ji,jj,jl1)957 ELSEIF( afrft(ji,jj) > kamax) THEN ! roundoff error958 afrft(ji,jj) = kamax959 ENDIF960 961 !--------------------------------------------------------------------------962 ! 3.4) Subtract area, volume, and energy from ridging963 ! / rafting category n1.964 !--------------------------------------------------------------------------965 vrdg1(ji,jj) = vicen_init(ji,jj,jl1) * afrac(ji,jj)966 vrdg2(ji,jj) = vrdg1(ji,jj) * ( 1. + rn_por_rdg )967 vsw (ji,jj) = vrdg1(ji,jj) * rn_por_rdg968 969 vsrdg (ji,jj) = vsnwn_init(ji,jj,jl1) * afrac(ji,jj)970 esrdg (ji,jj) = esnwn_init(ji,jj,jl1) * afrac(ji,jj)971 srdg1 (ji,jj) = smv_i_init(ji,jj,jl1) * afrac(ji,jj)972 oirdg1(ji,jj) = oa_i_init (ji,jj,jl1) * afrac(ji,jj)973 oirdg2(ji,jj) = oa_i_init (ji,jj,jl1) * afrac(ji,jj) / krdg(ji,jj,jl1)974 975 ! rafting volumes, heat contents ...976 virft (ji,jj) = vicen_init(ji,jj,jl1) * afrft(ji,jj)977 vsrft (ji,jj) = vsnwn_init(ji,jj,jl1) * afrft(ji,jj)978 esrft (ji,jj) = esnwn_init(ji,jj,jl1) * afrft(ji,jj)979 smrft (ji,jj) = smv_i_init(ji,jj,jl1) * afrft(ji,jj)980 oirft1(ji,jj) = oa_i_init (ji,jj,jl1) * afrft(ji,jj)981 oirft2(ji,jj) = oa_i_init (ji,jj,jl1) * afrft(ji,jj) / kraft982 983 ! substract everything984 a_i(ji,jj,jl1) = a_i(ji,jj,jl1) - ardg1 (ji,jj) - arft1 (ji,jj)985 v_i(ji,jj,jl1) = v_i(ji,jj,jl1) - vrdg1 (ji,jj) - virft (ji,jj)986 v_s(ji,jj,jl1) = v_s(ji,jj,jl1) - vsrdg (ji,jj) - vsrft (ji,jj)987 e_s(ji,jj,1,jl1) = e_s(ji,jj,1,jl1) - esrdg (ji,jj) - esrft (ji,jj)988 smv_i(ji,jj,jl1) = smv_i(ji,jj,jl1) - srdg1 (ji,jj) - smrft (ji,jj)989 oa_i(ji,jj,jl1) = oa_i(ji,jj,jl1) - oirdg1(ji,jj) - oirft1(ji,jj)990 991 !-----------------------------------------------------------------992 ! 3.5) Compute properties of new ridges993 !-----------------------------------------------------------------994 !---------995 ! Salinity996 !---------997 smsw(ji,jj) = vsw(ji,jj) * sss_m(ji,jj) ! salt content of seawater frozen in voids !! MV HC2014998 srdg2(ji,jj) = srdg1(ji,jj) + smsw(ji,jj) ! salt content of new ridge999 1000 !srdg2(ji,jj) = MIN( rn_simax * vrdg2(ji,jj) , zsrdg2 ) ! impose a maximum salinity1001 1002 sfx_dyn(ji,jj) = sfx_dyn(ji,jj) - smsw(ji,jj) * rhoic * r1_rdtice1003 wfx_dyn(ji,jj) = wfx_dyn(ji,jj) - vsw (ji,jj) * rhoic * r1_rdtice ! increase in ice volume du to seawater frozen in voids1004 1005 !------------------------------------1006 ! 3.6 Increment ridging diagnostics1007 !------------------------------------1008 1009 ! jl1 looping 1-jpl1010 ! ij looping 1-icells1011 1012 dardg1dt (ji,jj) = dardg1dt(ji,jj) + ardg1(ji,jj) + arft1(ji,jj)1013 dardg2dt (ji,jj) = dardg2dt(ji,jj) + ardg2(ji,jj) + arft2(ji,jj)1014 opening (ji,jj) = opening (ji,jj) + opning(ji,jj) * rdt_ice1015 1016 IF( con_i ) vice_init(ji,jj) = vice_init(ji,jj) + vrdg2(ji,jj) - vrdg1(ji,jj)1017 1018 !------------------------------------------1019 ! 3.7 Put the snow somewhere in the ocean1020 !------------------------------------------1021 ! Place part of the snow lost by ridging into the ocean.1022 ! Note that esnow_mlt < 0; the ocean must cool to melt snow.1023 ! If the ocean temp = Tf already, new ice must grow.1024 ! During the next time step, thermo_rates will determine whether1025 ! the ocean cools or new ice grows.1026 ! jl1 looping 1-jpl1027 ! ij looping 1-icells1028 1029 msnow_mlt(ji,jj) = msnow_mlt(ji,jj) + rhosn*vsrdg(ji,jj)*(1.0-rn_fsnowrdg) & ! rafting included1030 & + rhosn*vsrft(ji,jj)*(1.0-rn_fsnowrft)1031 1032 ! in J/m2 (same as e_s)1033 esnow_mlt(ji,jj) = esnow_mlt(ji,jj) - esrdg(ji,jj)*(1.0-rn_fsnowrdg) & !rafting included1034 & - esrft(ji,jj)*(1.0-rn_fsnowrft)1035 1036 !-----------------------------------------------------------------1037 ! 3.8 Compute quantities used to apportion ice among categories1038 ! in the n2 loop below1039 !-----------------------------------------------------------------1040 1041 ! jl1 looping 1-jpl1042 ! ij looping 1-icells1043 1044 dhr (ji,jj) = hrmax(ji,jj,jl1) - hrmin(ji,jj,jl1)1045 dhr2(ji,jj) = hrmax(ji,jj,jl1) * hrmax(ji,jj,jl1) - hrmin(ji,jj,jl1) * hrmin(ji,jj,jl1)1046 1047 END DO1048 1049 !--------------------------------------------------------------------1050 ! 3.9 Compute ridging ice enthalpy, remove it from ridging ice and1051 ! compute ridged ice enthalpy1052 !--------------------------------------------------------------------1053 DO jk = 1, nlay_i1054 DO ij = 1, icells1055 ji = indxi(ij)1056 jj = indxj(ij)1057 ! heat content of ridged ice1058 erdg1(ji,jj,jk) = eicen_init(ji,jj,jk,jl1) * afrac(ji,jj)1059 eirft(ji,jj,jk) = eicen_init(ji,jj,jk,jl1) * afrft(ji,jj)1060 e_i (ji,jj,jk,jl1) = e_i(ji,jj,jk,jl1) - erdg1(ji,jj,jk) - eirft(ji,jj,jk)1061 1062 1063 ! enthalpy of the trapped seawater (J/m2, >0)1064 ! clem: if sst>0, then ersw <0 (is that possible?)1065 ersw(ji,jj,jk) = - rhoic * vsw(ji,jj) * rcp * sst_m(ji,jj) * r1_nlay_i1066 1067 ! heat flux to the ocean1068 hfx_dyn(ji,jj) = hfx_dyn(ji,jj) + ersw(ji,jj,jk) * r1_rdtice ! > 0 [W.m-2] ocean->ice flux1069 1070 ! it is added to sea ice because the sign convention is the opposite of the sign convention for the ocean1071 erdg2(ji,jj,jk) = erdg1(ji,jj,jk) + ersw(ji,jj,jk)1072 1073 END DO1074 END DO1075 1076 1077 IF( con_i ) THEN1078 DO jk = 1, nlay_i1079 DO ij = 1, icells1080 ji = indxi(ij)1081 jj = indxj(ij)1082 eice_init(ji,jj) = eice_init(ji,jj) + erdg2(ji,jj,jk) - erdg1(ji,jj,jk)1083 END DO1084 END DO1085 ENDIF1086 1087 !-------------------------------------------------------------------------------1088 ! 4) Add area, volume, and energy of new ridge to each category jl21089 !-------------------------------------------------------------------------------1090 ! jl1 looping 1-jpl1091 DO jl2 = 1, jpl1092 ! over categories to which ridged ice is transferred1093 DO ij = 1, icells1094 ji = indxi(ij)1095 jj = indxj(ij)1096 1097 ! Compute the fraction of ridged ice area and volume going to1098 ! thickness category jl2.1099 ! Transfer area, volume, and energy accordingly.1100 1101 IF( hrmin(ji,jj,jl1) >= hi_max(jl2) .OR. hrmax(ji,jj,jl1) <= hi_max(jl2-1) ) THEN1102 hL = 0._wp1103 hR = 0._wp1104 ELSE1105 hL = MAX( hrmin(ji,jj,jl1), hi_max(jl2-1) )1106 hR = MIN( hrmax(ji,jj,jl1), hi_max(jl2) )1107 ENDIF1108 1109 ! fraction of ridged ice area and volume going to n21110 farea = ( hR - hL ) / dhr(ji,jj)1111 fvol(ji,jj) = ( hR*hR - hL*hL ) / dhr2(ji,jj)1112 1113 a_i (ji,jj ,jl2) = a_i (ji,jj ,jl2) + ardg2 (ji,jj) * farea1114 v_i (ji,jj ,jl2) = v_i (ji,jj ,jl2) + vrdg2 (ji,jj) * fvol(ji,jj)1115 v_s (ji,jj ,jl2) = v_s (ji,jj ,jl2) + vsrdg (ji,jj) * fvol(ji,jj) * rn_fsnowrdg1116 e_s (ji,jj,1,jl2) = e_s (ji,jj,1,jl2) + esrdg (ji,jj) * fvol(ji,jj) * rn_fsnowrdg1117 smv_i(ji,jj ,jl2) = smv_i(ji,jj ,jl2) + srdg2 (ji,jj) * fvol(ji,jj)1118 oa_i (ji,jj ,jl2) = oa_i (ji,jj ,jl2) + oirdg2(ji,jj) * farea1119 1120 END DO1121 1122 ! Transfer ice energy to category jl2 by ridging1123 DO jk = 1, nlay_i1124 DO ij = 1, icells1125 ji = indxi(ij)1126 jj = indxj(ij)1127 e_i(ji,jj,jk,jl2) = e_i(ji,jj,jk,jl2) + fvol(ji,jj) * erdg2(ji,jj,jk)1128 END DO1129 END DO1130 !1131 END DO ! jl2 (new ridges)1132 1133 DO jl2 = 1, jpl1134 1135 DO ij = 1, icells1136 ji = indxi(ij)1137 jj = indxj(ij)1138 ! Compute the fraction of rafted ice area and volume going to1139 ! thickness category jl2, transfer area, volume, and energy accordingly.1140 !1141 IF( hraft(ji,jj,jl1) <= hi_max(jl2) .AND. hraft(ji,jj,jl1) > hi_max(jl2-1) ) THEN1142 a_i (ji,jj ,jl2) = a_i (ji,jj ,jl2) + arft2 (ji,jj)1143 v_i (ji,jj ,jl2) = v_i (ji,jj ,jl2) + virft (ji,jj)1144 v_s (ji,jj ,jl2) = v_s (ji,jj ,jl2) + vsrft (ji,jj) * rn_fsnowrft1145 e_s (ji,jj,1,jl2) = e_s (ji,jj,1,jl2) + esrft (ji,jj) * rn_fsnowrft1146 smv_i(ji,jj ,jl2) = smv_i(ji,jj ,jl2) + smrft (ji,jj)1147 oa_i (ji,jj ,jl2) = oa_i (ji,jj ,jl2) + oirft2(ji,jj)1148 ENDIF1149 !1150 END DO1151 1152 ! Transfer rafted ice energy to category jl21153 DO jk = 1, nlay_i1154 DO ij = 1, icells1155 ji = indxi(ij)1156 jj = indxj(ij)1157 IF( hraft(ji,jj,jl1) <= hi_max(jl2) .AND. hraft(ji,jj,jl1) > hi_max(jl2-1) ) THEN1158 e_i(ji,jj,jk,jl2) = e_i(ji,jj,jk,jl2) + eirft(ji,jj,jk)1159 ENDIF1160 END DO1161 END DO1162 1163 END DO1164 1165 END DO ! jl1 (deforming categories)1166 1167 ! Conservation check1168 IF ( con_i ) THEN1169 CALL lim_column_sum (jpl, v_i, vice_final)1170 fieldid = ' v_i : limitd_me '1171 CALL lim_cons_check (vice_init, vice_final, 1.0e-6, fieldid)1172 1173 CALL lim_column_sum_energy (jpl, nlay_i, e_i, eice_final )1174 fieldid = ' e_i : limitd_me '1175 CALL lim_cons_check (eice_init, eice_final, 1.0e-2, fieldid)1176 1177 DO ji = mi0(iiceprt), mi1(iiceprt)1178 DO jj = mj0(jiceprt), mj1(jiceprt)1179 WRITE(numout,*) ' vice_init : ', vice_init (ji,jj)1180 WRITE(numout,*) ' vice_final : ', vice_final(ji,jj)1181 WRITE(numout,*) ' eice_init : ', eice_init (ji,jj)1182 WRITE(numout,*) ' eice_final : ', eice_final(ji,jj)1183 END DO1184 END DO1185 ENDIF1186 !1187 CALL wrk_dealloc( (jpi+1)*(jpj+1), indxi, indxj )1188 CALL wrk_dealloc( jpi, jpj, vice_init, vice_final, eice_init, eice_final )1189 CALL wrk_dealloc( jpi, jpj, afrac, fvol , ardg1, ardg2, vsrdg, esrdg, dhr, dhr2 )1190 CALL wrk_dealloc( jpi, jpj, vrdg1, vrdg2, vsw , srdg1, srdg2, smsw, oirdg1, oirdg2 )1191 CALL wrk_dealloc( jpi, jpj, afrft, arft1, arft2, virft, vsrft, esrft, smrft, oirft1, oirft2 )1192 CALL wrk_dealloc( jpi, jpj, jpl, aicen_init, vicen_init, vsnwn_init, esnwn_init, smv_i_init, oa_i_init )1193 CALL wrk_dealloc( jpi, jpj, nlay_i, eirft, erdg1, erdg2, ersw )1194 CALL wrk_dealloc( jpi, jpj, nlay_i, jpl, eicen_init )1195 !1196 END SUBROUTINE lim_itd_me_ridgeshift1197 940 1198 941 SUBROUTINE lim_itd_me_init -
branches/2016/dev_CNRS_2016/NEMOGCM/NEMO/LIM_SRC_3/limrhg.F90
r7277 r7278 159 159 CALL wrk_alloc( jpi,jpj, u_oce2, u_ice2, v_oce1 , v_ice1 , zmask ) 160 160 CALL wrk_alloc( jpi,jpj, zf1 , zu_ice, zf2 , zv_ice , zdt , zds ) 161 CALL wrk_alloc( jpi,jpj, z dt , zds , zs1 , zs2 , zs12 , zresr , zpice )161 CALL wrk_alloc( jpi,jpj, zs1 , zs2 , zs12 , zresr , zpice ) 162 162 163 163 #if defined key_lim2 && ! defined key_lim2_vp … … 690 690 CALL wrk_dealloc( jpi,jpj, u_oce2, u_ice2, v_oce1 , v_ice1 , zmask ) 691 691 CALL wrk_dealloc( jpi,jpj, zf1 , zu_ice, zf2 , zv_ice , zdt , zds ) 692 CALL wrk_dealloc( jpi,jpj, z dt , zds , zs1 , zs2 , zs12 , zresr , zpice )692 CALL wrk_dealloc( jpi,jpj, zs1 , zs2 , zs12 , zresr , zpice ) 693 693 694 694 END SUBROUTINE lim_rhg -
branches/2016/dev_CNRS_2016/NEMOGCM/NEMO/LIM_SRC_3/limsbc.F90
r7277 r7278 107 107 REAL(wp) :: zqsr ! New solar flux received by the ocean 108 108 REAL(wp), POINTER, DIMENSION(:,:,:) :: zalb_cs, zalb_os ! 3D workspace 109 REAL(wp), POINTER, DIMENSION(:,:) :: zalb ! 2D workspace 109 110 !!--------------------------------------------------------------------- 110 111 ! 111 112 ! make calls for heat fluxes before it is modified 113 ! pfrld is the lead fraction at the previous time step (actually between TRP and THD) 112 114 IF( iom_use('qsr_oce') ) CALL iom_put( "qsr_oce" , qsr_oce(:,:) * pfrld(:,:) ) ! solar flux at ocean surface 113 115 IF( iom_use('qns_oce') ) CALL iom_put( "qns_oce" , qns_oce(:,:) * pfrld(:,:) + qemp_oce(:,:) ) ! non-solar flux at ocean surface … … 118 120 IF( iom_use('qt_ice' ) ) CALL iom_put( "qt_ice" , SUM( ( qns_ice(:,:,:) + qsr_ice(:,:,:) ) & 119 121 & * a_i_b(:,:,:), dim=3 ) + qemp_ice(:,:) ) 120 IF( iom_use('qemp_oce' ) ) CALL iom_put( "qemp_oce" , qemp_oce(:,:) ) 121 IF( iom_use('qemp_ice' ) ) CALL iom_put( "qemp_ice" , qemp_ice(:,:) ) 122 123 ! pfrld is the lead fraction at the previous time step (actually between TRP and THD) 122 IF( iom_use('qemp_oce') ) CALL iom_put( "qemp_oce" , qemp_oce(:,:) ) 123 IF( iom_use('qemp_ice') ) CALL iom_put( "qemp_ice" , qemp_ice(:,:) ) 124 IF( iom_use('emp_oce' ) ) CALL iom_put( "emp_oce" , emp_oce(:,:) ) ! emp over ocean (taking into account the snow blown away from the ice) 125 IF( iom_use('emp_ice' ) ) CALL iom_put( "emp_ice" , emp_ice(:,:) ) ! emp over ice (taking into account the snow blown away from the ice) 126 127 ! albedo output 128 CALL wrk_alloc( jpi,jpj, zalb ) 129 130 zalb(:,:) = 0._wp 131 WHERE ( SUM( a_i_b, dim=3 ) <= epsi06 ) ; zalb(:,:) = 0.066_wp 132 ELSEWHERE ; zalb(:,:) = SUM( alb_ice * a_i_b, dim=3 ) / SUM( a_i_b, dim=3 ) 133 END WHERE 134 IF( iom_use('alb_ice' ) ) CALL iom_put( "alb_ice" , zalb(:,:) ) ! ice albedo output 135 136 zalb(:,:) = SUM( alb_ice * a_i_b, dim=3 ) + 0.066_wp * ( 1._wp - SUM( a_i_b, dim=3 ) ) 137 IF( iom_use('albedo' ) ) CALL iom_put( "albedo" , zalb(:,:) ) ! ice albedo output 138 139 CALL wrk_dealloc( jpi,jpj, zalb ) 140 124 141 DO jj = 1, jpj 125 142 DO ji = 1, jpi … … 140 157 hfx_out(ji,jj) = hfx_out(ji,jj) + zqmass + zqsr 141 158 142 ! Add the residual from heat diffusion equation (W.m-2) 143 !------------------------------------------------------- 144 hfx_out(ji,jj) = hfx_out(ji,jj) + hfx_err_dif(ji,jj) 159 ! Add the residual from heat diffusion equation and sublimation (W.m-2) 160 !---------------------------------------------------------------------- 161 hfx_out(ji,jj) = hfx_out(ji,jj) + hfx_err_dif(ji,jj) + & 162 & ( hfx_sub(ji,jj) - SUM( qevap_ice(ji,jj,:) * a_i_b(ji,jj,:) ) ) 145 163 146 164 ! New qsr and qns used to compute the oceanic heat flux at the next time step 147 !--------------------------------------------------- 165 !---------------------------------------------------------------------------- 148 166 qsr(ji,jj) = zqsr 149 167 qns(ji,jj) = hfx_out(ji,jj) - zqsr … … 165 183 166 184 ! mass flux at the ocean/ice interface 167 fmmflx(ji,jj) = - ( wfx_ice(ji,jj) + wfx_snw(ji,jj) ) * r1_rdtice ! F/M mass flux save at least for biogeochemical model 168 emp(ji,jj) = emp_oce(ji,jj) - wfx_ice(ji,jj) - wfx_snw(ji,jj) ! mass flux + F/M mass flux (always ice/ocean mass exchange) 169 185 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 186 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) 170 187 END DO 171 188 END DO … … 175 192 !------------------------------------------! 176 193 sfx(:,:) = sfx_bog(:,:) + sfx_bom(:,:) + sfx_sum(:,:) + sfx_sni(:,:) + sfx_opw(:,:) & 177 & + sfx_res(:,:) + sfx_dyn(:,:) + sfx_bri(:,:) 194 & + sfx_res(:,:) + sfx_dyn(:,:) + sfx_bri(:,:) + sfx_sub(:,:) 178 195 179 196 !-------------------------------------------------------------! -
branches/2016/dev_CNRS_2016/NEMOGCM/NEMO/LIM_SRC_3/limthd.F90
r6140 r7278 440 440 ! 441 441 DO ji = kideb, kiut 442 zdh_mel = MIN( 0._wp, dh_i_surf(ji) + dh_i_bott(ji) + dh_snowice(ji) )442 zdh_mel = MIN( 0._wp, dh_i_surf(ji) + dh_i_bott(ji) + dh_snowice(ji) + dh_i_sub(ji) ) 443 443 IF( zdh_mel < 0._wp .AND. a_i_1d(ji) > 0._wp ) THEN 444 444 zvi = a_i_1d(ji) * ht_i_1d(ji) … … 495 495 ! 496 496 CALL tab_2d_1d( nbpb, qprec_ice_1d(1:nbpb), qprec_ice(:,:) , jpi, jpj, npb(1:nbpb) ) 497 CALL tab_2d_1d( nbpb, qevap_ice_1d(1:nbpb), qevap_ice(:,:,jl) , jpi, jpj, npb(1:nbpb) ) 497 498 CALL tab_2d_1d( nbpb, qsr_ice_1d (1:nbpb), qsr_ice(:,:,jl) , jpi, jpj, npb(1:nbpb) ) 498 499 CALL tab_2d_1d( nbpb, fr1_i0_1d (1:nbpb), fr1_i0 , jpi, jpj, npb(1:nbpb) ) … … 524 525 CALL tab_2d_1d( nbpb, sfx_bri_1d (1:nbpb), sfx_bri , jpi, jpj, npb(1:nbpb) ) 525 526 CALL tab_2d_1d( nbpb, sfx_res_1d (1:nbpb), sfx_res , jpi, jpj, npb(1:nbpb) ) 527 CALL tab_2d_1d( nbpb, sfx_sub_1d (1:nbpb), sfx_sub , jpi, jpj,npb(1:nbpb) ) 526 528 ! 527 529 CALL tab_2d_1d( nbpb, hfx_thd_1d (1:nbpb), hfx_thd , jpi, jpj, npb(1:nbpb) ) … … 574 576 CALL tab_1d_2d( nbpb, sfx_res , npb, sfx_res_1d(1:nbpb) , jpi, jpj ) 575 577 CALL tab_1d_2d( nbpb, sfx_bri , npb, sfx_bri_1d(1:nbpb) , jpi, jpj ) 578 CALL tab_1d_2d( nbpb, sfx_sub , npb, sfx_sub_1d(1:nbpb) , jpi, jpj ) 576 579 ! 577 580 CALL tab_1d_2d( nbpb, hfx_thd , npb, hfx_thd_1d(1:nbpb) , jpi, jpj ) -
branches/2016/dev_CNRS_2016/NEMOGCM/NEMO/LIM_SRC_3/limthd_dh.F90
r5487 r7278 74 74 75 75 REAL(wp) :: ztmelts ! local scalar 76 REAL(wp) :: z fdum76 REAL(wp) :: zdum 77 77 REAL(wp) :: zfracs ! fractionation coefficient for bottom salt entrapment 78 78 REAL(wp) :: zs_snic ! snow-ice salinity … … 95 95 REAL(wp), POINTER, DIMENSION(:) :: zq_rema ! remaining heat at the end of the routine (J.m-2) 96 96 REAL(wp), POINTER, DIMENSION(:) :: zf_tt ! Heat budget to determine melting or freezing(W.m-2) 97 REAL(wp), POINTER, DIMENSION(:) :: zevap_rema ! remaining mass flux from sublimation (kg.m-2) 97 98 98 99 REAL(wp), POINTER, DIMENSION(:) :: zdh_s_mel ! snow melt … … 105 106 106 107 REAL(wp), POINTER, DIMENSION(:) :: zqh_i ! total ice heat content (J.m-2) 107 REAL(wp), POINTER, DIMENSION(:) :: zqh_s ! total snow heat content (J.m-2)108 REAL(wp), POINTER, DIMENSION(:) :: zq_s ! total snow enthalpy (J.m-3)109 108 REAL(wp), POINTER, DIMENSION(:) :: zsnw ! distribution of snow after wind blowing 110 109 … … 118 117 ! Discriminate between varying salinity (nn_icesal=2) and prescribed cases (other values) 119 118 SELECT CASE( nn_icesal ) ! varying salinity or not 120 CASE( 1, 3 , 4) ; zswitch_sal = 0 ! prescribed salinity profile121 CASE( 2 ) 119 CASE( 1, 3 ) ; zswitch_sal = 0 ! prescribed salinity profile 120 CASE( 2 ) ; zswitch_sal = 1 ! varying salinity profile 122 121 END SELECT 123 122 124 CALL wrk_alloc( jpij, zqprec, zq_su, zq_bo, zf_tt, zq_rema, zsnw )125 CALL wrk_alloc( jpij, zdh_s_mel, zdh_s_pre, zdh_s_sub, zqh_i , zqh_s, zq_s)123 CALL wrk_alloc( jpij, zqprec, zq_su, zq_bo, zf_tt, zq_rema, zsnw, zevap_rema ) 124 CALL wrk_alloc( jpij, zdh_s_mel, zdh_s_pre, zdh_s_sub, zqh_i ) 126 125 CALL wrk_alloc( jpij, nlay_i, zdeltah, zh_i ) 127 126 CALL wrk_alloc( jpij, nlay_i, icount ) 128 127 129 dh_i_surf (:) = 0._wp ; dh_i_bott (:) = 0._wp ; dh_snowice(:) = 0._wp 128 dh_i_surf (:) = 0._wp ; dh_i_bott (:) = 0._wp ; dh_snowice(:) = 0._wp ; dh_i_sub(:) = 0._wp 130 129 dsm_i_se_1d(:) = 0._wp ; dsm_i_si_1d(:) = 0._wp 131 130 132 131 zqprec (:) = 0._wp ; zq_su (:) = 0._wp ; zq_bo (:) = 0._wp ; zf_tt(:) = 0._wp 133 zq_rema (:) = 0._wp ; zsnw (:) = 0._wp 132 zq_rema (:) = 0._wp ; zsnw (:) = 0._wp ; zevap_rema(:) = 0._wp ; 134 133 zdh_s_mel(:) = 0._wp ; zdh_s_pre(:) = 0._wp ; zdh_s_sub(:) = 0._wp ; zqh_i(:) = 0._wp 135 zqh_s (:) = 0._wp ; zq_s (:) = 0._wp136 134 137 135 zdeltah(:,:) = 0._wp ; zh_i(:,:) = 0._wp … … 159 157 ! 160 158 DO ji = kideb, kiut 161 z fdum= qns_ice_1d(ji) + ( 1._wp - i0(ji) ) * qsr_ice_1d(ji) - fc_su(ji)159 zdum = qns_ice_1d(ji) + ( 1._wp - i0(ji) ) * qsr_ice_1d(ji) - fc_su(ji) 162 160 zf_tt(ji) = fc_bo_i(ji) + fhtur_1d(ji) + fhld_1d(ji) 163 161 164 zq_su (ji) = MAX( 0._wp, z fdum* rdt_ice ) * MAX( 0._wp , SIGN( 1._wp, t_su_1d(ji) - rt0 ) )162 zq_su (ji) = MAX( 0._wp, zdum * rdt_ice ) * MAX( 0._wp , SIGN( 1._wp, t_su_1d(ji) - rt0 ) ) 165 163 zq_bo (ji) = MAX( 0._wp, zf_tt(ji) * rdt_ice ) 166 164 END DO … … 187 185 ! 2) Computing layer thicknesses and enthalpies. ! 188 186 !------------------------------------------------------------! 189 !190 DO jk = 1, nlay_s191 DO ji = kideb, kiut192 zqh_s(ji) = zqh_s(ji) + q_s_1d(ji,jk) * ht_s_1d(ji) * r1_nlay_s193 END DO194 END DO195 187 ! 196 188 DO jk = 1, nlay_i … … 275 267 END DO 276 268 277 !---------------------- 278 ! 3.2 S now sublimation279 !---------------------- 269 !------------------------------ 270 ! 3.2 Sublimation (part1: snow) 271 !------------------------------ 280 272 ! qla_ice is always >=0 (upwards), heat goes to the atmosphere, therefore snow sublimates 281 273 ! clem comment: not counted in mass/heat exchange in limsbc since this is an exchange with atm. (not ocean) 282 ! clem comment: ice should also sublimate283 274 zdeltah(:,:) = 0._wp 284 ! coupled mode: sublimation is set to 0 (evap_ice = 0) until further notice 285 ! forced mode: snow thickness change due to sublimation 286 DO ji = kideb, kiut 287 zdh_s_sub(ji) = MAX( - ht_s_1d(ji) , - evap_ice_1d(ji) * r1_rhosn * rdt_ice ) 288 ! Heat flux by sublimation [W.m-2], < 0 289 ! sublimate first snow that had fallen, then pre-existing snow 275 DO ji = kideb, kiut 276 zdh_s_sub(ji) = MAX( - ht_s_1d(ji) , - evap_ice_1d(ji) * r1_rhosn * rdt_ice ) 277 ! remaining evap in kg.m-2 (used for ice melting later on) 278 zevap_rema(ji) = evap_ice_1d(ji) * rdt_ice + zdh_s_sub(ji) * rhosn 279 ! Heat flux by sublimation [W.m-2], < 0 (sublimate first snow that had fallen, then pre-existing snow) 290 280 zdeltah(ji,1) = MAX( zdh_s_sub(ji), - zdh_s_pre(ji) ) 291 281 hfx_sub_1d(ji) = hfx_sub_1d(ji) + ( zdeltah(ji,1) * zqprec(ji) + ( zdh_s_sub(ji) - zdeltah(ji,1) ) * q_s_1d(ji,1) & … … 309 299 !------------------------------------------- 310 300 ! new temp and enthalpy of the snow (remaining snow precip + remaining pre-existing snow) 311 zq_s(:) = 0._wp312 301 DO jk = 1, nlay_s 313 302 DO ji = kideb,kiut 314 rswitch = MAX( 0._wp , SIGN( 1._wp, ht_s_1d(ji) - epsi20 ) ) 315 q_s_1d(ji,jk) = rswitch / MAX( ht_s_1d(ji), epsi20 ) * & 316 & ( ( zdh_s_pre(ji) ) * zqprec(ji) + & 317 & ( ht_s_1d(ji) - zdh_s_pre(ji) ) * rhosn * ( cpic * ( rt0 - t_s_1d(ji,jk) ) + lfus ) ) 318 zq_s(ji) = zq_s(ji) + q_s_1d(ji,jk) 303 rswitch = MAX( 0._wp , SIGN( 1._wp, ht_s_1d(ji) - epsi20 ) ) 304 q_s_1d(ji,jk) = rswitch / MAX( ht_s_1d(ji), epsi20 ) * & 305 & ( ( zdh_s_pre(ji) ) * zqprec(ji) + & 306 & ( ht_s_1d(ji) - zdh_s_pre(ji) ) * rhosn * ( cpic * ( rt0 - t_s_1d(ji,jk) ) + lfus ) ) 319 307 END DO 320 308 END DO … … 370 358 zQm = zfmdt * zEw ! Energy of the melt water sent to the ocean [J/m2, <0] 371 359 372 ! Contribution to salt flux (clem: using sm_i_1d and not s_i_1d(jk) is ok)360 ! Contribution to salt flux >0 (clem: using sm_i_1d and not s_i_1d(jk) is ok) 373 361 sfx_sum_1d(ji) = sfx_sum_1d(ji) - rhoic * a_i_1d(ji) * zdeltah(ji,jk) * sm_i_1d(ji) * r1_rdtice 374 362 … … 383 371 384 372 END IF 373 ! ---------------------- 374 ! Sublimation part2: ice 375 ! ---------------------- 376 zdum = MAX( - ( zh_i(ji,jk) + zdeltah(ji,jk) ) , - zevap_rema(ji) * r1_rhoic ) 377 zdeltah(ji,jk) = zdeltah(ji,jk) + zdum 378 dh_i_sub(ji) = dh_i_sub(ji) + zdum 379 ! Salt flux > 0 (clem2016: flux is sent to the ocean for simplicity but salt should remain in the ice except if all ice is melted. 380 ! It must be corrected at some point) 381 sfx_sub_1d(ji) = sfx_sub_1d(ji) - rhoic * a_i_1d(ji) * zdum * sm_i_1d(ji) * r1_rdtice 382 ! Heat flux [W.m-2], < 0 383 hfx_sub_1d(ji) = hfx_sub_1d(ji) + zdum * q_i_1d(ji,jk) * a_i_1d(ji) * r1_rdtice 384 ! Mass flux > 0 385 wfx_sub_1d(ji) = wfx_sub_1d(ji) - rhoic * a_i_1d(ji) * zdum * r1_rdtice 386 ! update remaining mass flux 387 zevap_rema(ji) = zevap_rema(ji) + zdum * rhoic 388 385 389 ! record which layers have disappeared (for bottom melting) 386 390 ! => icount=0 : no layer has vanished … … 389 393 icount(ji,jk) = NINT( rswitch ) 390 394 zh_i(ji,jk) = MAX( 0._wp , zh_i(ji,jk) + zdeltah(ji,jk) ) 391 395 392 396 ! update heat content (J.m-2) and layer thickness 393 397 qh_i_old(ji,jk) = qh_i_old(ji,jk) + zdeltah(ji,jk) * q_i_1d(ji,jk) … … 397 401 ! update ice thickness 398 402 DO ji = kideb, kiut 399 ht_i_1d(ji) = MAX( 0._wp , ht_i_1d(ji) + dh_i_surf(ji) ) 403 ht_i_1d(ji) = MAX( 0._wp , ht_i_1d(ji) + dh_i_surf(ji) + dh_i_sub(ji) ) 404 END DO 405 406 ! remaining "potential" evap is sent to ocean 407 DO ji = kideb, kiut 408 ii = MOD( npb(ji) - 1, jpi ) + 1 ; ij = ( npb(ji) - 1 ) / jpi + 1 409 wfx_err_sub(ii,ij) = wfx_err_sub(ii,ij) - zevap_rema(ji) * a_i_1d(ji) * r1_rdtice ! <=0 (net evap for the ocean in kg.m-2.s-1) 400 410 END DO 401 411 … … 653 663 sfx_sni_1d(ji) = sfx_sni_1d(ji) + sss_m(ii,ij) * a_i_1d(ji) * zfmdt * r1_rdtice 654 664 665 ! virtual salt flux to keep salinity constant 666 IF( nn_icesal == 1 .OR. nn_icesal == 3 ) THEN 667 sfx_bri_1d(ji) = sfx_bri_1d(ji) - sss_m(ii,ij) * a_i_1d(ji) * zfmdt * r1_rdtice & ! put back sss_m into the ocean 668 & - sm_i_1d(ji) * a_i_1d(ji) * dh_snowice(ji) * rhoic * r1_rdtice ! and get sm_i from the ocean 669 ENDIF 670 655 671 ! Contribution to mass flux 656 672 ! All snow is thrown in the ocean, and seawater is taken to replace the volume … … 686 702 WHERE( ht_i_1d == 0._wp ) a_i_1d = 0._wp 687 703 688 CALL wrk_dealloc( jpij, zqprec, zq_su, zq_bo, zf_tt, zq_rema, zsnw )689 CALL wrk_dealloc( jpij, zdh_s_mel, zdh_s_pre, zdh_s_sub, zqh_i , zqh_s, zq_s)704 CALL wrk_dealloc( jpij, zqprec, zq_su, zq_bo, zf_tt, zq_rema, zsnw, zevap_rema ) 705 CALL wrk_dealloc( jpij, zdh_s_mel, zdh_s_pre, zdh_s_sub, zqh_i ) 690 706 CALL wrk_dealloc( jpij, nlay_i, zdeltah, zh_i ) 691 707 CALL wrk_dealloc( jpij, nlay_i, icount ) -
branches/2016/dev_CNRS_2016/NEMOGCM/NEMO/LIM_SRC_3/limthd_lac.F90
r6403 r7278 75 75 INTEGER :: ii, ij, iter ! - - 76 76 REAL(wp) :: ztmelts, zdv, zfrazb, zweight, zde ! local scalars 77 REAL(wp) :: zgamafr, zvfrx, zvgx, ztaux, ztwogp, zf , zhicol_new! - -77 REAL(wp) :: zgamafr, zvfrx, zvgx, ztaux, ztwogp, zf ! - - 78 78 REAL(wp) :: ztenagm, zvfry, zvgy, ztauy, zvrel2, zfp, zsqcd , zhicrit ! - - 79 LOGICAL :: iterate_frazil ! iterate frazil ice collection thickness80 79 CHARACTER (len = 15) :: fieldid 81 80 … … 108 107 REAL(wp), POINTER, DIMENSION(:,:) :: zsmv_i_1d ! 1-D version of smv_i 109 108 110 REAL(wp), POINTER, DIMENSION(:,:,:) :: ze_i_1d 111 112 REAL(wp), POINTER, DIMENSION(:,:) :: zvrel 113 114 REAL(wp) :: zcai = 1.4e-3_wp 109 REAL(wp), POINTER, DIMENSION(:,:,:) :: ze_i_1d !: 1-D version of e_i 110 111 REAL(wp), POINTER, DIMENSION(:,:) :: zvrel ! relative ice / frazil velocity 112 113 REAL(wp) :: zcai = 1.4e-3_wp ! ice-air drag (clem: should be dependent on coupling/forcing used) 115 114 !!-----------------------------------------------------------------------! 116 115 … … 143 142 !------------------------------------------------------------------------------! 144 143 ! hicol is the thickness of new ice formed in open water 145 ! hicol can be either prescribed (frazswi = 0) 146 ! or computed (frazswi = 1) 144 ! hicol can be either prescribed (frazswi = 0) or computed (frazswi = 1) 147 145 ! Frazil ice forms in open water, is transported by wind 148 146 ! accumulates at the edge of the consolidated ice edge … … 155 153 zvrel(:,:) = 0._wp 156 154 157 ! Default new ice thickness 158 hicol(:,:) = rn_hnewice 155 ! Default new ice thickness 156 WHERE( qlead(:,:) < 0._wp ) ; hicol = rn_hnewice 157 ELSEWHERE ; hicol = 0._wp 158 END WHERE 159 159 160 160 IF( ln_frazil ) THEN … … 182 182 & + vtau_ice(ji ,jj ) * vmask(ji ,jj ,1) ) * 0.5_wp 183 183 ! Square root of wind stress 184 ztenagm = SQRT( SQRT( ztaux **2 + ztauy**2) )184 ztenagm = SQRT( SQRT( ztaux * ztaux + ztauy * ztauy ) ) 185 185 186 186 !--------------------- … … 205 205 zvrel2 = MAX( ( zvfrx - zvgx ) * ( zvfrx - zvgx ) & 206 206 & + ( zvfry - zvgy ) * ( zvfry - zvgy ) , 0.15 * 0.15 ) 207 zvrel(ji,jj) 207 zvrel(ji,jj) = SQRT( zvrel2 ) 208 208 209 209 !--------------------- 210 210 ! Iterative procedure 211 211 !--------------------- 212 hicol(ji,jj) = zhicrit + 0.1 213 hicol(ji,jj) = zhicrit + hicol(ji,jj) & 214 & / ( hicol(ji,jj) * hicol(ji,jj) - zhicrit * zhicrit ) * ztwogp * zvrel2 215 216 !!gm better coding: above: hicol(ji,jj) * hicol(ji,jj) = (zhicrit + 0.1)*(zhicrit + 0.1) 217 !!gm = zhicrit**2 + 0.2*zhicrit +0.01 218 !!gm therefore the 2 lines with hicol can be replaced by 1 line: 219 !!gm hicol(ji,jj) = zhicrit + (zhicrit + 0.1) / ( 0.2 * zhicrit + 0.01 ) * ztwogp * zvrel2 220 !!gm further more (zhicrit + 0.1)/(0.2 * zhicrit + 0.01 )*ztwogp can be computed one for all outside the DO loop 212 hicol(ji,jj) = zhicrit + ( zhicrit + 0.1 ) & 213 & / ( ( zhicrit + 0.1 ) * ( zhicrit + 0.1 ) - zhicrit * zhicrit ) * ztwogp * zvrel2 221 214 222 215 iter = 1 223 iterate_frazil = .true. 224 225 DO WHILE ( iter < 100 .AND. iterate_frazil ) 226 zf = ( hicol(ji,jj) - zhicrit ) * ( hicol(ji,jj)**2 - zhicrit**2 ) & 227 - hicol(ji,jj) * zhicrit * ztwogp * zvrel2 228 zfp = ( hicol(ji,jj) - zhicrit ) * ( 3.0*hicol(ji,jj) + zhicrit ) & 229 - zhicrit * ztwogp * zvrel2 230 zhicol_new = hicol(ji,jj) - zf/zfp 231 hicol(ji,jj) = zhicol_new 232 216 DO WHILE ( iter < 20 ) 217 zf = ( hicol(ji,jj) - zhicrit ) * ( hicol(ji,jj) * hicol(ji,jj) - zhicrit * zhicrit ) - & 218 & hicol(ji,jj) * zhicrit * ztwogp * zvrel2 219 zfp = ( hicol(ji,jj) - zhicrit ) * ( 3.0 * hicol(ji,jj) + zhicrit ) - zhicrit * ztwogp * zvrel2 220 221 hicol(ji,jj) = hicol(ji,jj) - zf/zfp 233 222 iter = iter + 1 234 235 END DO ! do while 223 END DO 236 224 237 225 ENDIF ! end of selection of pixels where ice forms 238 226 239 END DO ! loop on ji ends240 END DO ! loop on jj ends241 !242 CALL lbc_lnk( zvrel(:,:), 'T', 1. )243 CALL lbc_lnk( hicol(:,:), 'T', 1. )227 END DO 228 END DO 229 ! 230 CALL lbc_lnk( zvrel(:,:), 'T', 1. ) 231 CALL lbc_lnk( hicol(:,:), 'T', 1. ) 244 232 245 233 ENDIF ! End of computation of frazil ice collection thickness … … 282 270 ! Move from 2-D to 1-D vectors 283 271 !------------------------------ 284 ! If ocean gains heat do nothing 285 ! 0therwise compute new ice formation 272 ! If ocean gains heat do nothing. Otherwise compute new ice formation 286 273 287 274 IF ( nbpac > 0 ) THEN … … 317 304 zv_b(1:nbpac,:) = zv_i_1d(1:nbpac,:) 318 305 za_b(1:nbpac,:) = za_i_1d(1:nbpac,:) 306 319 307 !---------------------- 320 308 ! Thickness of new ice 321 309 !---------------------- 322 DO ji = 1, nbpac 323 zh_newice(ji) = rn_hnewice 324 END DO 325 IF( ln_frazil ) zh_newice(1:nbpac) = hicol_1d(1:nbpac) 310 zh_newice(1:nbpac) = hicol_1d(1:nbpac) 326 311 327 312 !---------------------- … … 347 332 DO ji = 1, nbpac 348 333 ztmelts = - tmut * zs_newice(ji) + rt0 ! Melting point (K) 349 ze_newice(ji) = rhoic * ( cpic * ( ztmelts - t_bo_1d(ji) ) &334 ze_newice(ji) = rhoic * ( cpic * ( ztmelts - t_bo_1d(ji) ) & 350 335 & + lfus * ( 1.0 - ( ztmelts - rt0 ) / MIN( t_bo_1d(ji) - rt0, -epsi10 ) ) & 351 336 & - rcp * ( ztmelts - rt0 ) ) … … 385 370 ! salt flux 386 371 sfx_opw_1d(ji) = sfx_opw_1d(ji) - zv_newice(ji) * rhoic * zs_newice(ji) * r1_rdtice 387 372 END DO 373 374 zv_frazb(:) = 0._wp 375 IF( ln_frazil ) THEN 388 376 ! A fraction zfrazb of frazil ice is accreted at the ice bottom 389 rswitch = 1._wp - MAX( 0._wp, SIGN( 1._wp , - zat_i_1d(ji) ) ) 390 zfrazb = rswitch * ( TANH ( rn_Cfrazb * ( zvrel_1d(ji) - rn_vfrazb ) ) + 1.0 ) * 0.5 * rn_maxfrazb 391 zv_frazb(ji) = zfrazb * zv_newice(ji) 392 zv_newice(ji) = ( 1.0 - zfrazb ) * zv_newice(ji) 393 END DO 394 377 DO ji = 1, nbpac 378 rswitch = 1._wp - MAX( 0._wp, SIGN( 1._wp , - zat_i_1d(ji) ) ) 379 zfrazb = rswitch * ( TANH( rn_Cfrazb * ( zvrel_1d(ji) - rn_vfrazb ) ) + 1.0 ) * 0.5 * rn_maxfrazb 380 zv_frazb(ji) = zfrazb * zv_newice(ji) 381 zv_newice(ji) = ( 1.0 - zfrazb ) * zv_newice(ji) 382 END DO 383 END IF 384 395 385 !----------------- 396 386 ! Area of new ice … … 444 434 jl = jcat(ji) 445 435 rswitch = MAX( 0._wp, SIGN( 1._wp , zv_i_1d(ji,jl) - epsi20 ) ) 446 ze_i_1d(ji,jk,jl) = zswinew(ji) * ze_newice(ji) + 436 ze_i_1d(ji,jk,jl) = zswinew(ji) * ze_newice(ji) + & 447 437 & ( 1.0 - zswinew(ji) ) * ( ze_newice(ji) * zv_newice(ji) + ze_i_1d(ji,jk,jl) * zv_b(ji,jl) ) & 448 438 & * rswitch / MAX( zv_i_1d(ji,jl), epsi20 ) -
branches/2016/dev_CNRS_2016/NEMOGCM/NEMO/LIM_SRC_3/limthd_sal.F90
r5123 r7278 62 62 END DO 63 63 64 !------------------------------------------------------------------------------| 65 ! 1) Constant salinity, constant in time | 66 !------------------------------------------------------------------------------| 67 !!gm comment: if nn_icesal = 1 s_i_new, s_i_1d and sm_i_1d can be set to rn_icesal one for all in the initialisation phase !! 68 !!gm ===>>> simplification of almost all test on nn_icesal value 69 IF( nn_icesal == 1 ) THEN 70 s_i_1d (kideb:kiut,1:nlay_i) = rn_icesal 71 sm_i_1d(kideb:kiut) = rn_icesal 72 s_i_new(kideb:kiut) = rn_icesal 73 ENDIF 64 !--------------------------------------------------------------------| 65 ! 1) salinity constant in time | 66 !--------------------------------------------------------------------| 67 ! do nothing 74 68 75 !---------------------------------------------------------------------- --------|76 ! Module 2 : Constant salinity varying in time|77 !---------------------------------------------------------------------- --------|69 !----------------------------------------------------------------------| 70 ! 2) salinity varying in time | 71 !----------------------------------------------------------------------| 78 72 IF( nn_icesal == 2 ) THEN 79 73 … … 113 107 114 108 !------------------------------------------------------------------------------| 115 ! Module 3 : Profile of salinity, constant in time|109 ! 3) vertical profile of salinity, constant in time | 116 110 !------------------------------------------------------------------------------| 117 111 IF( nn_icesal == 3 ) CALL lim_var_salprof1d( kideb, kiut ) -
branches/2016/dev_CNRS_2016/NEMOGCM/NEMO/LIM_SRC_3/limtrp.F90
r6403 r7278 63 63 INTEGER, INTENT(in) :: kt ! number of iteration 64 64 ! 65 INTEGER :: ji, jj, jk, j l, jt ! dummy loop indices65 INTEGER :: ji, jj, jk, jm , jl, jt ! dummy loop indices 66 66 INTEGER :: initad ! number of sub-timestep for the advection 67 67 REAL(wp) :: zcfl , zusnit ! - - … … 75 75 REAL(wp), POINTER, DIMENSION(:,:,:) :: zhimax ! old ice thickness 76 76 REAL(wp), POINTER, DIMENSION(:,:) :: zatold, zeiold, zesold ! old concentration, enthalpies 77 REAL(wp), POINTER, DIMENSION(:,:,:) :: zhdfptab 77 78 REAL(wp) :: zdv, zvi, zvs, zsmv, zes, zei 78 79 REAL(wp) :: zvi_b, zsmv_b, zei_b, zfs_b, zfw_b, zft_b 80 !!--------------------------------------------------------------------- 81 INTEGER :: ihdf_vars = 6 !!Number of variables in which we apply horizontal diffusion 82 !! inside limtrp for each ice category , not counting the 83 !! variables corresponding to ice_layers 79 84 !!--------------------------------------------------------------------- 80 85 IF( nn_timing == 1 ) CALL timing_start('limtrp') … … 85 90 CALL wrk_alloc( jpi,jpj,nlay_i,jpl, z0ei ) 86 91 CALL wrk_alloc( jpi,jpj,jpl, zhimax, zviold, zvsold, zsmvold ) 92 CALL wrk_alloc( jpi,jpj,jpl*(ihdf_vars + nlay_i)+1,zhdfptab) 87 93 88 94 IF( numit == nstart .AND. lwp ) THEN … … 170 176 z0oi (:,:,jl) = oa_i (:,:, jl) * e1e2t(:,:) ! Age content 171 177 z0es (:,:,jl) = e_s (:,:,1,jl) * e1e2t(:,:) ! Snow heat content 172 178 DO jk = 1, nlay_i 173 179 z0ei (:,:,jk,jl) = e_i (:,:,jk,jl) * e1e2t(:,:) ! Ice heat content 174 180 END DO … … 284 290 ! Diffusion of Ice fields 285 291 !------------------------------------------------------------------------------! 286 292 !------------------------------------ 293 ! Diffusion of other ice variables 294 !------------------------------------ 295 jm=1 296 DO jl = 1, jpl 297 ! ! Masked eddy diffusivity coefficient at ocean U- and V-points 298 ! DO jj = 1, jpjm1 ! NB: has not to be defined on jpj line and jpi row 299 ! DO ji = 1 , fs_jpim1 ! vector opt. 300 ! pahu(ji,jj) = ( 1._wp - MAX( 0._wp, SIGN( 1._wp, -a_i(ji ,jj,jl) ) ) ) & 301 ! & * ( 1._wp - MAX( 0._wp, SIGN( 1._wp, -a_i(ji+1,jj,jl) ) ) ) * ahiu(ji,jj) 302 ! pahv(ji,jj) = ( 1._wp - MAX( 0._wp, SIGN( 1._wp, -a_i(ji,jj ,jl) ) ) ) & 303 ! & * ( 1._wp - MAX( 0._wp, SIGN( 1._wp,- a_i(ji,jj+1,jl) ) ) ) * ahiv(ji,jj) 304 ! END DO 305 ! END DO 306 DO jj = 1, jpjm1 ! NB: has not to be defined on jpj line and jpi row 307 DO ji = 1 , fs_jpim1 ! vector opt. 308 pahu3D(ji,jj,jl) = ( 1._wp - MAX( 0._wp, SIGN( 1._wp, -a_i(ji ,jj, jl ) ) ) ) & 309 & * ( 1._wp - MAX( 0._wp, SIGN( 1._wp, -a_i(ji+1,jj, jl ) ) ) ) * ahiu(ji,jj) 310 pahv3D(ji,jj,jl) = ( 1._wp - MAX( 0._wp, SIGN( 1._wp, -a_i(ji, jj, jl ) ) ) ) & 311 & * ( 1._wp - MAX( 0._wp, SIGN( 1._wp,- a_i(ji, jj+1,jl ) ) ) ) * ahiv(ji,jj) 312 END DO 313 END DO 314 315 zhdfptab(:,:,jm)= a_i (:,:, jl); jm = jm + 1 316 zhdfptab(:,:,jm)= v_i (:,:, jl); jm = jm + 1 317 zhdfptab(:,:,jm)= v_s (:,:, jl); jm = jm + 1 318 zhdfptab(:,:,jm)= smv_i(:,:, jl); jm = jm + 1 319 zhdfptab(:,:,jm)= oa_i (:,:, jl); jm = jm + 1 320 zhdfptab(:,:,jm)= e_s (:,:,1,jl); jm = jm + 1 321 ! Sample of adding more variables to apply lim_hdf using lim_hdf optimization--- 322 ! zhdfptab(:,:,jm) = variable_1 (:,:,1,jl); jm = jm + 1 323 ! zhdfptab(:,:,jm) = variable_2 (:,:,1,jl); jm = jm + 1 324 ! 325 ! and in this example the parameter ihdf_vars musb be changed to 8 (necessary for allocation) 326 !---------------------------------------------------------------------------------------- 327 DO jk = 1, nlay_i 328 zhdfptab(:,:,jm)=e_i(:,:,jk,jl); jm= jm+1 329 END DO 330 END DO 287 331 ! 288 332 !-------------------------------- … … 290 334 !-------------------------------- 291 335 ! ! Masked eddy diffusivity coefficient at ocean U- and V-points 336 !DO jj = 1, jpjm1 ! NB: has not to be defined on jpj line and jpi row 337 ! DO ji = 1 , fs_jpim1 ! vector opt. 338 ! pahu(ji,jj) = ( 1._wp - MAX( 0._wp, SIGN( 1._wp, -at_i(ji ,jj) ) ) ) & 339 ! & * ( 1._wp - MAX( 0._wp, SIGN( 1._wp, -at_i(ji+1,jj) ) ) ) * ahiu(ji,jj) 340 ! pahv(ji,jj) = ( 1._wp - MAX( 0._wp, SIGN( 1._wp, -at_i(ji,jj ) ) ) ) & 341 ! & * ( 1._wp - MAX( 0._wp, SIGN( 1._wp,- at_i(ji,jj+1) ) ) ) * ahiv(ji,jj) 342 ! END DO 343 !END DO 344 292 345 DO jj = 1, jpjm1 ! NB: has not to be defined on jpj line and jpi row 293 346 DO ji = 1 , fs_jpim1 ! vector opt. 294 pahu (ji,jj) = ( 1._wp - MAX( 0._wp, SIGN( 1._wp, -at_i(ji ,jj) ) ) ) &295 & * ( 1._wp - MAX( 0._wp, SIGN( 1._wp, -at_i(ji+1,jj) ) ) ) * ahiu(ji,jj)296 pahv (ji,jj) = ( 1._wp - MAX( 0._wp, SIGN( 1._wp, -at_i(ji,jj ) ) ) ) &297 & * ( 1._wp - MAX( 0._wp, SIGN( 1._wp,- at_i(ji,jj+1) ) ) ) * ahiv(ji,jj)347 pahu3D(ji,jj,jpl+1) = ( 1._wp - MAX( 0._wp, SIGN( 1._wp, -at_i(ji ,jj) ) ) ) & 348 & * ( 1._wp - MAX( 0._wp, SIGN( 1._wp, -at_i(ji+1,jj) ) ) ) * ahiu(ji,jj) 349 pahv3D(ji,jj,jpl+1) = ( 1._wp - MAX( 0._wp, SIGN( 1._wp, -at_i(ji,jj ) ) ) ) & 350 & * ( 1._wp - MAX( 0._wp, SIGN( 1._wp,- at_i(ji,jj+1) ) ) ) * ahiv(ji,jj) 298 351 END DO 299 352 END DO 300 353 ! 301 CALL lim_hdf( ato_i (:,:) ) 302 303 !------------------------------------ 304 ! Diffusion of other ice variables 305 !------------------------------------ 306 DO jl = 1, jpl 307 ! ! Masked eddy diffusivity coefficient at ocean U- and V-points 308 DO jj = 1, jpjm1 ! NB: has not to be defined on jpj line and jpi row 309 DO ji = 1 , fs_jpim1 ! vector opt. 310 pahu(ji,jj) = ( 1._wp - MAX( 0._wp, SIGN( 1._wp, -a_i(ji ,jj,jl) ) ) ) & 311 & * ( 1._wp - MAX( 0._wp, SIGN( 1._wp, -a_i(ji+1,jj,jl) ) ) ) * ahiu(ji,jj) 312 pahv(ji,jj) = ( 1._wp - MAX( 0._wp, SIGN( 1._wp, -a_i(ji,jj ,jl) ) ) ) & 313 & * ( 1._wp - MAX( 0._wp, SIGN( 1._wp,- a_i(ji,jj+1,jl) ) ) ) * ahiv(ji,jj) 314 END DO 315 END DO 316 317 CALL lim_hdf( v_i (:,:, jl) ) 318 CALL lim_hdf( v_s (:,:, jl) ) 319 CALL lim_hdf( smv_i(:,:, jl) ) 320 CALL lim_hdf( oa_i (:,:, jl) ) 321 CALL lim_hdf( a_i (:,:, jl) ) 322 CALL lim_hdf( e_s (:,:,1,jl) ) 354 zhdfptab(:,:,jm)= ato_i (:,:); 355 CALL lim_hdf( zhdfptab, ihdf_vars, jpl, nlay_i) 356 357 jm=1 358 DO jl = 1, jpl 359 a_i (:,:, jl) = zhdfptab(:,:,jm); jm = jm + 1 360 v_i (:,:, jl) = zhdfptab(:,:,jm); jm = jm + 1 361 v_s (:,:, jl) = zhdfptab(:,:,jm); jm = jm + 1 362 smv_i(:,:, jl) = zhdfptab(:,:,jm); jm = jm + 1 363 oa_i (:,:, jl) = zhdfptab(:,:,jm); jm = jm + 1 364 e_s (:,:,1,jl) = zhdfptab(:,:,jm); jm = jm + 1 365 ! Sample of adding more variables to apply lim_hdf--------- 366 ! variable_1 (:,:,1,jl) = zhdfptab(:,:, jm ) ; jm + 1 367 ! variable_2 (:,:,1,jl) = zhdfptab(:,:, jm ) ; jm + 1 368 !----------------------------------------------------------- 323 369 DO jk = 1, nlay_i 324 CALL lim_hdf( e_i(:,:,jk,jl) ) 325 END DO 326 END DO 370 e_i(:,:,jk,jl) = zhdfptab(:,:,jm);jm= jm + 1 371 END DO 372 END DO 373 374 ato_i (:,:) = zhdfptab(:,:,jm) 327 375 328 376 !------------------------------------------------------------------------------! … … 464 512 CALL wrk_dealloc( jpi,jpj,nlay_i,jpl, z0ei ) 465 513 CALL wrk_dealloc( jpi,jpj,jpl, zviold, zvsold, zhimax, zsmvold ) 514 CALL wrk_dealloc( jpi,jpj,jpl*(ihdf_vars+nlay_i)+1,zhdfptab) 466 515 ! 467 516 IF( nn_timing == 1 ) CALL timing_stop('limtrp') … … 479 528 !!====================================================================== 480 529 END MODULE limtrp 530 -
branches/2016/dev_CNRS_2016/NEMOGCM/NEMO/LIM_SRC_3/limvar.F90
r5202 r7278 163 163 rswitch = MAX( 0._wp , SIGN( 1._wp, a_i(ji,jj,jl) - epsi20 ) ) !0 if no ice and 1 if yes 164 164 ht_i(ji,jj,jl) = v_i (ji,jj,jl) / MAX( a_i(ji,jj,jl) , epsi20 ) * rswitch 165 END DO 166 END DO 167 END DO 168 ! Force the upper limit of ht_i to always be < hi_max (99 m). 169 DO jj = 1, jpj 170 DO ji = 1, jpi 171 rswitch = MAX( 0._wp , SIGN( 1._wp, ht_i(ji,jj,jpl) - epsi20 ) ) 172 ht_i(ji,jj,jpl) = MIN( ht_i(ji,jj,jpl) , hi_max(jpl) ) 173 a_i (ji,jj,jpl) = v_i(ji,jj,jpl) / MAX( ht_i(ji,jj,jpl) , epsi20 ) * rswitch 174 END DO 175 END DO 176 177 DO jl = 1, jpl 178 DO jj = 1, jpj 179 DO ji = 1, jpi 180 rswitch = MAX( 0._wp , SIGN( 1._wp, a_i(ji,jj,jl) - epsi20 ) ) !0 if no ice and 1 if yes 165 181 ht_s(ji,jj,jl) = v_s (ji,jj,jl) / MAX( a_i(ji,jj,jl) , epsi20 ) * rswitch 166 182 o_i(ji,jj,jl) = oa_i(ji,jj,jl) / MAX( a_i(ji,jj,jl) , epsi20 ) * rswitch … … 168 184 END DO 169 185 END DO 170 186 171 187 IF( nn_icesal == 2 )THEN 172 188 DO jl = 1, jpl … … 298 314 ! Vertically constant, constant in time 299 315 !--------------------------------------- 300 IF( nn_icesal == 1 ) s_i(:,:,:,:) = rn_icesal 316 IF( nn_icesal == 1 ) THEN 317 s_i (:,:,:,:) = rn_icesal 318 sm_i(:,:,:) = rn_icesal 319 ENDIF 301 320 302 321 !----------------------------------- -
branches/2016/dev_CNRS_2016/NEMOGCM/NEMO/LIM_SRC_3/limwri.F90
r6140 r7278 154 154 ENDIF 155 155 156 IF ( iom_use( "icecolf" ) ) THEN 157 DO jj = 1, jpj 158 DO ji = 1, jpi 159 rswitch = MAX( 0._wp , SIGN( 1._wp , at_i(ji,jj) ) ) 160 z2d(ji,jj) = hicol(ji,jj) * rswitch 161 END DO 162 END DO 163 CALL iom_put( "icecolf" , z2d ) ! frazil ice collection thickness 164 ENDIF 165 156 IF ( iom_use( "icecolf" ) ) CALL iom_put( "icecolf", hicol ) ! frazil ice collection thickness 157 166 158 CALL iom_put( "isst" , sst_m ) ! sea surface temperature 167 159 CALL iom_put( "isss" , sss_m ) ! sea surface salinity … … 187 179 CALL iom_put( "destrp" , diag_trp_es ) ! advected snw enthalpy (W/m2) 188 180 189 CALL iom_put( "sfxbog" , sfx_bog * rday ) ! salt flux from b rines190 CALL iom_put( "sfxbom" , sfx_bom * rday ) ! salt flux from b rines191 CALL iom_put( "sfxsum" , sfx_sum * rday ) ! salt flux from brines192 CALL iom_put( "sfxsni" , sfx_sni * rday ) ! salt flux from brines193 CALL iom_put( "sfxopw" , sfx_opw * rday ) ! salt flux from brines181 CALL iom_put( "sfxbog" , sfx_bog * rday ) ! salt flux from bottom growth 182 CALL iom_put( "sfxbom" , sfx_bom * rday ) ! salt flux from bottom melt 183 CALL iom_put( "sfxsum" , sfx_sum * rday ) ! salt flux from surface melt 184 CALL iom_put( "sfxsni" , sfx_sni * rday ) ! salt flux from snow ice formation 185 CALL iom_put( "sfxopw" , sfx_opw * rday ) ! salt flux from open water formation 194 186 CALL iom_put( "sfxdyn" , sfx_dyn * rday ) ! salt flux from ridging rafting 195 CALL iom_put( "sfxres" , sfx_res * rday ) ! salt flux from limupdate (resultant)187 CALL iom_put( "sfxres" , sfx_res * rday ) ! salt flux from residual 196 188 CALL iom_put( "sfxbri" , sfx_bri * rday ) ! salt flux from brines 189 CALL iom_put( "sfxsub" , sfx_sub * rday ) ! salt flux from sublimation 197 190 CALL iom_put( "sfx" , sfx * rday ) ! total salt flux 198 191 … … 233 226 CALL iom_put ('hfxspr' , hfx_spr(:,:) ) ! Heat content of snow precip 234 227 228 IF ( iom_use( "vfxthin" ) ) THEN ! ice production for open water + thin ice (<20cm) => comparable to observations 229 DO jj = 1, jpj 230 DO ji = 1, jpi 231 z2d(ji,jj) = vt_i(ji,jj) / MAX( at_i(ji,jj), epsi06 ) * zswi(ji,jj) ! mean ice thickness 232 END DO 233 END DO 234 WHERE( z2d(:,:) < 0.2 .AND. z2d(:,:) > 0. ) ; z2da = wfx_bog 235 ELSEWHERE ; z2da = 0._wp 236 END WHERE 237 CALL iom_put( "vfxthin", ( wfx_opw + z2da ) * ztmp ) 238 ENDIF 239 235 240 !-------------------------------- 236 241 ! Output values for each category -
branches/2016/dev_CNRS_2016/NEMOGCM/NEMO/LIM_SRC_3/thd_ice.F90
r7277 r7278 49 49 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:) :: qns_ice_1d 50 50 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:) :: t_bo_1d 51 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:) :: rn_amax_1d 51 52 52 53 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:) :: hfx_sum_1d … … 55 56 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:) :: hfx_dif_1d 56 57 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:) :: hfx_opw_1d 57 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:) :: rn_amax_1d58 58 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:) :: hfx_snw_1d 59 59 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:) :: hfx_err_1d … … 88 88 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:) :: sfx_res_1d 89 89 90 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:) :: sfx_sub_1d 91 90 92 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:) :: sprecip_1d !: <==> the 2D sprecip 91 93 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:) :: frld_1d !: <==> the 2D frld … … 96 98 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:) :: evap_ice_1d !: <==> the 2D evap_ice 97 99 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:) :: qprec_ice_1d !: <==> the 2D qprec_ice 100 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:) :: qevap_ice_1d !: <==> the 3D qevap_ice 98 101 ! ! to reintegrate longwave flux inside the ice thermodynamics 99 102 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:) :: i0 !: fraction of radiation transmitted to the ice … … 112 115 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:) :: dh_s_tot !: Snow accretion/ablation [m] 113 116 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:) :: dh_i_surf !: Ice surface accretion/ablation [m] 117 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:) :: dh_i_sub !: Ice surface sublimation [m] 114 118 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:) :: dh_i_bott !: Ice bottom accretion/ablation [m] 115 119 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:) :: dh_snowice !: Snow ice formation [m of ice] … … 159 163 & wfx_sum_1d(jpij) , wfx_sni_1d (jpij) , wfx_opw_1d (jpij) , wfx_res_1d(jpij) , & 160 164 & dqns_ice_1d(jpij) , evap_ice_1d (jpij), & 161 & qprec_ice_1d(jpij), i0 (jpij) ,&165 & qprec_ice_1d(jpij), qevap_ice_1d(jpij), i0 (jpij) , & 162 166 & sfx_bri_1d (jpij) , sfx_bog_1d (jpij) , sfx_bom_1d (jpij) , sfx_sum_1d (jpij), & 163 & sfx_sni_1d (jpij) , sfx_opw_1d (jpij) , sfx_res_1d (jpij) , 167 & sfx_sni_1d (jpij) , sfx_opw_1d (jpij) , sfx_res_1d (jpij) , sfx_sub_1d (jpij), & 164 168 & dsm_i_fl_1d(jpij) , dsm_i_gd_1d(jpij) , dsm_i_se_1d(jpij) , & 165 169 & dsm_i_si_1d(jpij) , hicol_1d (jpij) , STAT=ierr(2) ) … … 167 171 ALLOCATE( t_su_1d (jpij) , a_i_1d (jpij) , ht_i_1d (jpij) , & 168 172 & ht_s_1d (jpij) , fc_su (jpij) , fc_bo_i (jpij) , & 169 & dh_s_tot (jpij) , dh_i_surf(jpij) , dh_i_ bott(jpij) , &170 & dh_ snowice(jpij) , sm_i_1d (jpij) , s_i_new (jpij) , &171 & t_s_1d(jpij,nlay_s) , t_i_1d(jpij,nlay_i) , s_i_1d(jpij,nlay_i) , &172 & q_i_1d(jpij,nlay_i+1) , q_s_1d(jpij,nlay_s) , &173 & dh_s_tot (jpij) , dh_i_surf(jpij) , dh_i_sub (jpij) , & 174 & dh_i_bott (jpij) ,dh_snowice(jpij) , sm_i_1d (jpij) , s_i_new (jpij) , & 175 & t_s_1d(jpij,nlay_s) , t_i_1d(jpij,nlay_i) , s_i_1d(jpij,nlay_i) , & 176 & q_i_1d(jpij,nlay_i+1) , q_s_1d(jpij,nlay_s) , & 173 177 & qh_i_old(jpij,0:nlay_i+1), h_i_old(jpij,0:nlay_i+1) , STAT=ierr(3)) 174 178 ! -
branches/2016/dev_CNRS_2016/NEMOGCM/NEMO/OPA_SRC/DIA/diaar5.F90
r6140 r7278 212 212 REAL(wp) :: zztmp 213 213 REAL(wp), POINTER, DIMENSION(:,:,:,:) :: zsaldta ! Jan/Dec levitus salinity 214 ! reading initial file215 LOGICAL :: ln_tsd_init !: T & S data flag216 LOGICAL :: ln_tsd_tradmp !: internal damping toward input data flag217 CHARACTER(len=100) :: cn_dir218 TYPE(FLD_N) :: sn_tem,sn_sal219 INTEGER :: ios=0220 221 NAMELIST/namtsd/ ln_tsd_init,ln_tsd_tradmp,cn_dir,sn_tem,sn_sal222 !223 224 REWIND( numnam_ref ) ! Namelist namtsd in reference namelist :225 READ ( numnam_ref, namtsd, IOSTAT = ios, ERR = 901)226 901 IF( ios /= 0 ) CALL ctl_nam ( ios , ' namtsd in reference namelist for dia_ar5', lwp )227 REWIND( numnam_cfg ) ! Namelist namtsd in configuration namelist : Parameters of the run228 READ ( numnam_cfg, namtsd, IOSTAT = ios, ERR = 902 )229 902 IF( ios /= 0 ) CALL ctl_nam ( ios , ' namtsd in configuration namelist for dia_ar5', lwp )230 IF(lwm) WRITE ( numond, namtsd )231 214 ! 232 215 !!---------------------------------------------------------------------- … … 250 233 IF( lk_mpp ) CALL mpp_sum( vol0 ) 251 234 252 CALL iom_open ( TRIM( cn_dir )//TRIM(sn_sal%clname), inum ) 253 CALL iom_get ( inum, jpdom_data, TRIM(sn_sal%clvar), zsaldta(:,:,:,1), 1 ) 254 CALL iom_get ( inum, jpdom_data, TRIM(sn_sal%clvar), zsaldta(:,:,:,2), 12 ) 235 236 CALL iom_open ( 'sali_ref_clim_monthly', inum ) 237 CALL iom_get ( inum, jpdom_data, 'vosaline' , zsaldta(:,:,:,1), 1 ) 238 CALL iom_get ( inum, jpdom_data, 'vosaline' , zsaldta(:,:,:,2), 12 ) 255 239 CALL iom_close( inum ) 240 256 241 sn0(:,:,:) = 0.5_wp * ( zsaldta(:,:,:,1) + zsaldta(:,:,:,2) ) 257 242 sn0(:,:,:) = sn0(:,:,:) * tmask(:,:,:) -
branches/2016/dev_CNRS_2016/NEMOGCM/NEMO/OPA_SRC/DIU/cool_skin.F90
r6075 r7278 17 17 USE in_out_manager 18 18 USE sbc_oce 19 USE lib_mpp 19 20 USE lbclnk ! ocean lateral boundary conditions (or mpp link) 20 21 -
branches/2016/dev_CNRS_2016/NEMOGCM/NEMO/OPA_SRC/DOM/domwri.F90
r7277 r7278 196 196 CALL dom_stiff( zprt ) 197 197 CALL iom_rstput( 0, 0, inum, 'stiffness', zprt ) ! ! Max. grid stiffness ratio 198 198 ENDIF 199 199 ! 200 200 ! ! ============================ -
branches/2016/dev_CNRS_2016/NEMOGCM/NEMO/OPA_SRC/IOM/iom.F90
r7277 r7278 114 114 CASE (30) ; CALL xios_set_context_attr(TRIM(clname), calendar_type= "D360") 115 115 END SELECT 116 WRITE(cldate,"(i4.4,'-',i2.2,'-',i2.2,' 00:00:00')") nyear,nmonth,nday116 WRITE(cldate,"(i4.4,'-',i2.2,'-',i2.2,' ',i2.2,':',i2.2,':00')") nyear,nmonth,nday,nhour,nminute 117 117 CALL xios_set_context_attr(TRIM(clname), start_date=cldate ) 118 118 -
branches/2016/dev_CNRS_2016/NEMOGCM/NEMO/OPA_SRC/LBC/lbclnk.F90
r6140 r7278 9 9 !! 3.5 ! 2012 (S.Mocavero, I. Epicoco) optimization of BDY comm. via lbc_bdy_lnk and lbc_obc_lnk 10 10 !! 3.4 ! 2012-12 (R. Bourdalle-Badie, G. Reffray) add a C1D case 11 !! 3.6 ! 2015-06 (O. Tintó and M. Castrillo) add lbc_lnk_multi 11 12 !!---------------------------------------------------------------------- 12 13 #if defined key_mpp_mpi … … 22 23 23 24 INTERFACE lbc_lnk_multi 24 MODULE PROCEDURE mpp_lnk_2d_9 25 MODULE PROCEDURE mpp_lnk_2d_9, mpp_lnk_2d_multiple 25 26 END INTERFACE 26 27 ! … … 29 30 END INTERFACE 30 31 ! 31 !JMM interface not defined if not key_mpp_mpi : likely do not compile without this CPP key !!!!32 32 INTERFACE lbc_sum 33 33 MODULE PROCEDURE mpp_lnk_sum_3d, mpp_lnk_sum_2d 34 34 END INTERFACE 35 35 ! 36 36 INTERFACE lbc_bdy_lnk 37 37 MODULE PROCEDURE mpp_lnk_bdy_2d, mpp_lnk_bdy_3d … … 83 83 ! 84 84 INTERFACE lbc_sum 85 MODULE PROCEDURE mpp_lnk_sum_3d, mpp_lnk_sum_2d85 MODULE PROCEDURE lbc_lnk_sum_3d, lbc_lnk_sum_2d 86 86 END INTERFACE 87 87 … … 90 90 END INTERFACE 91 91 ! 92 INTERFACE lbc_lnk_multi 93 MODULE PROCEDURE lbc_lnk_2d_9, lbc_lnk_2d_multiple 94 END INTERFACE 95 92 96 INTERFACE lbc_bdy_lnk 93 97 MODULE PROCEDURE lbc_bdy_lnk_2d, lbc_bdy_lnk_3d … … 97 101 MODULE PROCEDURE lbc_lnk_2d_e 98 102 END INTERFACE 103 104 TYPE arrayptr 105 REAL , DIMENSION (:,:), POINTER :: pt2d 106 END TYPE arrayptr 107 PUBLIC arrayptr 99 108 100 109 PUBLIC lbc_lnk ! ocean/ice lateral boundary conditions 110 PUBLIC lbc_sum ! ocean/ice lateral boundary conditions (sum of the overlap region) 101 111 PUBLIC lbc_lnk_e ! 112 PUBLIC lbc_lnk_multi ! modified ocean lateral boundary conditions 102 113 PUBLIC lbc_bdy_lnk ! ocean lateral BDY boundary conditions 103 114 PUBLIC lbc_lnk_icb ! … … 181 192 ! 182 193 END SUBROUTINE lbc_lnk_2d 194 195 SUBROUTINE lbc_lnk_2d_multiple( pt2d_array , type_array , psgn_array , num_fields ) 196 !! 197 INTEGER :: num_fields 198 TYPE( arrayptr ), DIMENSION(:) :: pt2d_array 199 CHARACTER(len=1), DIMENSION(:), INTENT(in ) :: type_array ! define the nature of ptab array grid-points 200 ! ! = T , U , V , F , W and I points 201 REAL(wp) , DIMENSION(:), INTENT(in ) :: psgn_array ! =-1 the sign change across the north fold boundary 202 ! ! = 1. , the sign is kept 203 ! 204 INTEGER :: ii !!MULTI SEND DUMMY LOOP INDICES 205 ! 206 DO ii = 1, num_fields 207 CALL lbc_lnk_2d( pt2d_array(ii)%pt2d, type_array(ii), psgn_array(ii) ) 208 END DO 209 ! 210 END SUBROUTINE lbc_lnk_2d_multiple 211 212 SUBROUTINE lbc_lnk_2d_9( pt2dA, cd_typeA, psgnA, pt2dB, cd_typeB, psgnB, pt2dC, cd_typeC, psgnC & 213 & , pt2dD, cd_typeD, psgnD, pt2dE, cd_typeE, psgnE, pt2dF, cd_typeF, psgnF & 214 & , pt2dG, cd_typeG, psgnG, pt2dH, cd_typeH, psgnH, pt2dI, cd_typeI, psgnI, cd_mpp, pval) 215 !!--------------------------------------------------------------------- 216 ! Second 2D array on which the boundary condition is applied 217 REAL(wp), DIMENSION(jpi,jpj), TARGET , INTENT(inout) :: pt2dA 218 REAL(wp), DIMENSION(jpi,jpj), TARGET, OPTIONAL, INTENT(inout) :: pt2dB , pt2dC , pt2dD , pt2dE 219 REAL(wp), DIMENSION(jpi,jpj), TARGET, OPTIONAL, INTENT(inout) :: pt2dF , pt2dG , pt2dH , pt2dI 220 ! define the nature of ptab array grid-points 221 CHARACTER(len=1) , INTENT(in ) :: cd_typeA 222 CHARACTER(len=1) , OPTIONAL, INTENT(in ) :: cd_typeB , cd_typeC , cd_typeD , cd_typeE 223 CHARACTER(len=1) , OPTIONAL, INTENT(in ) :: cd_typeF , cd_typeG , cd_typeH , cd_typeI 224 ! =-1 the sign change across the north fold boundary 225 REAL(wp) , INTENT(in ) :: psgnA 226 REAL(wp) , OPTIONAL, INTENT(in ) :: psgnB , psgnC , psgnD , psgnE 227 REAL(wp) , OPTIONAL, INTENT(in ) :: psgnF , psgnG , psgnH , psgnI 228 CHARACTER(len=3) , OPTIONAL, INTENT(in ) :: cd_mpp ! fill the overlap area only 229 REAL(wp) , OPTIONAL, INTENT(in ) :: pval ! background value (used at closed boundaries) 230 !! 231 !!--------------------------------------------------------------------- 232 233 !!The first array 234 CALL lbc_lnk( pt2dA, cd_typeA, psgnA ) 235 236 !! Look if more arrays to process 237 IF(PRESENT (psgnB) )CALL lbc_lnk( pt2dA, cd_typeA, psgnA ) 238 IF(PRESENT (psgnC) )CALL lbc_lnk( pt2dC, cd_typeC, psgnC ) 239 IF(PRESENT (psgnD) )CALL lbc_lnk( pt2dD, cd_typeD, psgnD ) 240 IF(PRESENT (psgnE) )CALL lbc_lnk( pt2dE, cd_typeE, psgnE ) 241 IF(PRESENT (psgnF) )CALL lbc_lnk( pt2dF, cd_typeF, psgnF ) 242 IF(PRESENT (psgnG) )CALL lbc_lnk( pt2dG, cd_typeG, psgnG ) 243 IF(PRESENT (psgnH) )CALL lbc_lnk( pt2dH, cd_typeH, psgnH ) 244 IF(PRESENT (psgnI) )CALL lbc_lnk( pt2dI, cd_typeI, psgnI ) 245 246 END SUBROUTINE lbc_lnk_2d_9 247 248 249 250 183 251 184 252 #else … … 379 447 ! 380 448 END SUBROUTINE lbc_lnk_2d 449 450 SUBROUTINE lbc_lnk_2d_multiple( pt2d_array , type_array , psgn_array , num_fields ) 451 !! 452 INTEGER :: num_fields 453 TYPE( arrayptr ), DIMENSION(:) :: pt2d_array 454 CHARACTER(len=1), DIMENSION(:), INTENT(in ) :: type_array ! define the nature of ptab array grid-points 455 ! ! = T , U , V , F , W and I points 456 REAL(wp) , DIMENSION(:), INTENT(in ) :: psgn_array ! =-1 the sign change across the north fold boundary 457 ! ! = 1. , the sign is kept 458 ! 459 INTEGER :: ii !!MULTI SEND DUMMY LOOP INDICES 460 ! 461 DO ii = 1, num_fields 462 CALL lbc_lnk_2d( pt2d_array(ii)%pt2d, type_array(ii), psgn_array(ii) ) 463 END DO 464 ! 465 END SUBROUTINE lbc_lnk_2d_multiple 466 467 SUBROUTINE lbc_lnk_2d_9( pt2dA, cd_typeA, psgnA, pt2dB, cd_typeB, psgnB, pt2dC, cd_typeC, psgnC & 468 & , pt2dD, cd_typeD, psgnD, pt2dE, cd_typeE, psgnE, pt2dF, cd_typeF, psgnF & 469 & , pt2dG, cd_typeG, psgnG, pt2dH, cd_typeH, psgnH, pt2dI, cd_typeI, psgnI, cd_mpp, pval) 470 !!--------------------------------------------------------------------- 471 ! Second 2D array on which the boundary condition is applied 472 REAL(wp), DIMENSION(jpi,jpj), TARGET , INTENT(inout) :: pt2dA 473 REAL(wp), DIMENSION(jpi,jpj), TARGET, OPTIONAL, INTENT(inout) :: pt2dB , pt2dC , pt2dD , pt2dE 474 REAL(wp), DIMENSION(jpi,jpj), TARGET, OPTIONAL, INTENT(inout) :: pt2dF , pt2dG , pt2dH , pt2dI 475 ! define the nature of ptab array grid-points 476 CHARACTER(len=1) , INTENT(in ) :: cd_typeA 477 CHARACTER(len=1) , OPTIONAL, INTENT(in ) :: cd_typeB , cd_typeC , cd_typeD , cd_typeE 478 CHARACTER(len=1) , OPTIONAL, INTENT(in ) :: cd_typeF , cd_typeG , cd_typeH , cd_typeI 479 ! =-1 the sign change across the north fold boundary 480 REAL(wp) , INTENT(in ) :: psgnA 481 REAL(wp) , OPTIONAL, INTENT(in ) :: psgnB , psgnC , psgnD , psgnE 482 REAL(wp) , OPTIONAL, INTENT(in ) :: psgnF , psgnG , psgnH , psgnI 483 CHARACTER(len=3) , OPTIONAL, INTENT(in ) :: cd_mpp ! fill the overlap area only 484 REAL(wp) , OPTIONAL, INTENT(in ) :: pval ! background value (used at closed boundaries) 485 !! 486 !!--------------------------------------------------------------------- 487 488 !!The first array 489 CALL lbc_lnk( pt2dA, cd_typeA, psgnA ) 490 491 !! Look if more arrays to process 492 IF(PRESENT (psgnB) )CALL lbc_lnk( pt2dA, cd_typeA, psgnA ) 493 IF(PRESENT (psgnC) )CALL lbc_lnk( pt2dC, cd_typeC, psgnC ) 494 IF(PRESENT (psgnD) )CALL lbc_lnk( pt2dD, cd_typeD, psgnD ) 495 IF(PRESENT (psgnE) )CALL lbc_lnk( pt2dE, cd_typeE, psgnE ) 496 IF(PRESENT (psgnF) )CALL lbc_lnk( pt2dF, cd_typeF, psgnF ) 497 IF(PRESENT (psgnG) )CALL lbc_lnk( pt2dG, cd_typeG, psgnG ) 498 IF(PRESENT (psgnH) )CALL lbc_lnk( pt2dH, cd_typeH, psgnH ) 499 IF(PRESENT (psgnI) )CALL lbc_lnk( pt2dI, cd_typeI, psgnI ) 500 501 END SUBROUTINE lbc_lnk_2d_9 502 503 SUBROUTINE lbc_lnk_sum_2d( pt2d, cd_type, psgn, cd_mpp, pval ) 504 !!--------------------------------------------------------------------- 505 !! *** ROUTINE lbc_lnk_sum_2d *** 506 !! 507 !! ** Purpose : set lateral boundary conditions on a 2D array (non mpp case) 508 !! 509 !! ** Comments: compute the sum of the common cell (overlap region) for the ice sheet/ocean 510 !! coupling if conservation option activated. As no ice shelf are present along 511 !! this line, nothing is done along the north fold. 512 !!---------------------------------------------------------------------- 513 CHARACTER(len=1) , INTENT(in ) :: cd_type ! nature of pt3d grid-points 514 REAL(wp), DIMENSION(jpi,jpj), INTENT(inout) :: pt2d ! 2D array on which the lbc is applied 515 REAL(wp) , INTENT(in ) :: psgn ! control of the sign 516 CHARACTER(len=3) , INTENT(in ), OPTIONAL :: cd_mpp ! MPP only (here do nothing) 517 REAL(wp) , INTENT(in ), OPTIONAL :: pval ! background value (for closed boundaries) 518 !! 519 REAL(wp) :: zland 520 !!---------------------------------------------------------------------- 521 522 IF( PRESENT( pval ) ) THEN ; zland = pval ! set land value (zero by default) 523 ELSE ; zland = 0._wp 524 ENDIF 525 526 IF (PRESENT(cd_mpp)) THEN 527 ! only fill the overlap area and extra allows 528 ! this is in mpp case. In this module, just do nothing 529 ELSE 530 ! ! East-West boundaries 531 ! ! ==================== 532 SELECT CASE ( nperio ) 533 ! 534 CASE ( 1 , 4 , 6 ) !** cyclic east-west 535 pt2d(jpim1,:) = pt2d(jpim1,:) + pt2d( 1 ,:) 536 pt2d( 2 ,:) = pt2d( 2 ,:) + pt2d(jpi,:) 537 pt2d( 1 ,:) = 0.0_wp ! all points 538 pt2d(jpi,:) = 0.0_wp 539 ! 540 CASE DEFAULT !** East closed -- West closed 541 SELECT CASE ( cd_type ) 542 CASE ( 'T' , 'U' , 'V' , 'W' ) ! T-, U-, V-, W-points 543 pt2d( 1 ,:) = zland 544 pt2d(jpi,:) = zland 545 CASE ( 'F' ) ! F-point 546 pt2d(jpi,:) = zland 547 END SELECT 548 ! 549 END SELECT 550 ! ! North-South boundaries 551 ! ! ====================== 552 ! Nothing to do for the north fold, there is no ice shelf along this line. 553 ! 554 END IF 555 556 END SUBROUTINE 557 558 SUBROUTINE lbc_lnk_sum_3d( pt3d, cd_type, psgn, cd_mpp, pval ) 559 !!--------------------------------------------------------------------- 560 !! *** ROUTINE lbc_lnk_sum_3d *** 561 !! 562 !! ** Purpose : set lateral boundary conditions on a 3D array (non mpp case) 563 !! 564 !! ** Comments: compute the sum of the common cell (overlap region) for the ice sheet/ocean 565 !! coupling if conservation option activated. As no ice shelf are present along 566 !! this line, nothing is done along the north fold. 567 !!---------------------------------------------------------------------- 568 CHARACTER(len=1) , INTENT(in ) :: cd_type ! nature of pt3d grid-points 569 REAL(wp), DIMENSION(jpi,jpj,jpk), INTENT(inout) :: pt3d ! 3D array on which the lbc is applied 570 REAL(wp) , INTENT(in ) :: psgn ! control of the sign 571 CHARACTER(len=3) , INTENT(in ), OPTIONAL :: cd_mpp ! MPP only (here do nothing) 572 REAL(wp) , INTENT(in ), OPTIONAL :: pval ! background value (for closed boundaries) 573 !! 574 REAL(wp) :: zland 575 !!---------------------------------------------------------------------- 576 577 IF( PRESENT( pval ) ) THEN ; zland = pval ! set land value (zero by default) 578 ELSE ; zland = 0._wp 579 ENDIF 580 581 582 IF( PRESENT( cd_mpp ) ) THEN 583 ! only fill the overlap area and extra allows 584 ! this is in mpp case. In this module, just do nothing 585 ELSE 586 ! ! East-West boundaries 587 ! ! ====================== 588 SELECT CASE ( nperio ) 589 ! 590 CASE ( 1 , 4 , 6 ) !** cyclic east-west 591 pt3d(jpim1,:,:) = pt3d(jpim1,:,:) + pt3d( 1 ,:,:) 592 pt3d( 2 ,:,:) = pt3d( 2 ,:,:) + pt3d(jpi,:,:) 593 pt3d( 1 ,:,:) = 0.0_wp ! all points 594 pt3d(jpi,:,:) = 0.0_wp 595 ! 596 CASE DEFAULT !** East closed -- West closed 597 SELECT CASE ( cd_type ) 598 CASE ( 'T' , 'U' , 'V' , 'W' ) ! T-, U-, V-, W-points 599 pt3d( 1 ,:,:) = zland 600 pt3d(jpi,:,:) = zland 601 CASE ( 'F' ) ! F-point 602 pt3d(jpi,:,:) = zland 603 END SELECT 604 ! 605 END SELECT 606 ! ! North-South boundaries 607 ! ! ====================== 608 ! Nothing to do for the north fold, there is no ice shelf along this line. 609 ! 610 END IF 611 END SUBROUTINE 612 381 613 382 614 #endif … … 448 680 !!====================================================================== 449 681 END MODULE lbclnk 682 -
branches/2016/dev_CNRS_2016/NEMOGCM/NEMO/OPA_SRC/LBC/lib_mpp.F90
r6140 r7278 24 24 !! 3.5 ! 2013 ( C. Ethe, G. Madec ) message passing arrays as local variables 25 25 !! 3.5 ! 2013 (S.Mocavero, I.Epicoco - CMCC) north fold optimizations 26 !! 3.6 ! 2015 (O. Tintó and M. Castrillo - BSC) Added 'mpp_lnk_2d_multiple', 'mpp_lbc_north_2d_multiple', 'mpp_max_multiple' 26 27 !!---------------------------------------------------------------------- 27 28 … … 62 63 USE lbcnfd ! north fold treatment 63 64 USE in_out_manager ! I/O manager 65 USE wrk_nemo ! work arrays 64 66 65 67 IMPLICIT NONE … … 70 72 PUBLIC mpp_ini_north, mpp_lbc_north, mpp_lbc_north_e 71 73 PUBLIC mpp_min, mpp_max, mpp_sum, mpp_minloc, mpp_maxloc 74 PUBLIC mpp_max_multiple 72 75 PUBLIC mpp_lnk_3d, mpp_lnk_3d_gather, mpp_lnk_2d, mpp_lnk_2d_e 73 PUBLIC mpp_lnk_2d_9 76 PUBLIC mpp_lnk_2d_9 , mpp_lnk_2d_multiple 74 77 PUBLIC mpp_lnk_sum_3d, mpp_lnk_sum_2d 75 78 PUBLIC mppscatter, mppgather … … 79 82 PUBLIC mpp_lnk_bdy_2d, mpp_lnk_bdy_3d 80 83 PUBLIC mpp_lbc_north_icb, mpp_lnk_2d_icb 84 PUBLIC mpprank 81 85 82 86 TYPE arrayptr 83 87 REAL , DIMENSION (:,:), POINTER :: pt2d 84 88 END TYPE arrayptr 89 PUBLIC arrayptr 85 90 86 91 !! * Interfaces … … 106 111 INTERFACE mpp_maxloc 107 112 MODULE PROCEDURE mpp_maxloc2d ,mpp_maxloc3d 113 END INTERFACE 114 115 INTERFACE mpp_max_multiple 116 MODULE PROCEDURE mppmax_real_multiple 108 117 END INTERFACE 109 118 … … 726 735 ! ----------------------- 727 736 ! 728 DO ii = 1 , num_fields729 737 !First Array 730 IF( npolj /= 0 .AND. .NOT. PRESENT(cd_mpp) ) THEN 731 ! 732 SELECT CASE ( jpni ) 733 CASE ( 1 ) ; CALL lbc_nfd ( pt2d_array(ii)%pt2d( : , : ), type_array(ii) , psgn_array(ii) ) ! only 1 northern proc, no mpp 734 CASE DEFAULT ; CALL mpp_lbc_north( pt2d_array(ii)%pt2d( : , : ), type_array(ii), psgn_array(ii) ) ! for all northern procs. 735 END SELECT 736 ! 737 ENDIF 738 ! 739 END DO 738 IF( npolj /= 0 .AND. .NOT. PRESENT(cd_mpp) ) THEN 739 ! 740 SELECT CASE ( jpni ) 741 CASE ( 1 ) ; 742 DO ii = 1 , num_fields 743 CALL lbc_nfd ( pt2d_array(ii)%pt2d( : , : ), type_array(ii) , psgn_array(ii) ) ! only 1 northern proc, no mpp 744 END DO 745 CASE DEFAULT ; CALL mpp_lbc_north_2d_multiple( pt2d_array, type_array, psgn_array, num_fields ) ! for all northern procs. 746 END SELECT 747 ! 748 ENDIF 749 ! 740 750 ! 741 751 DEALLOCATE( zt2ns, zt2sn, zt2ew, zt2we ) … … 2019 2029 END SUBROUTINE mppmax_real 2020 2030 2031 SUBROUTINE mppmax_real_multiple( ptab, NUM , kcom ) 2032 !!---------------------------------------------------------------------- 2033 !! *** routine mppmax_real *** 2034 !! 2035 !! ** Purpose : Maximum 2036 !! 2037 !!---------------------------------------------------------------------- 2038 REAL(wp), DIMENSION(:) , INTENT(inout) :: ptab ! ??? 2039 INTEGER , INTENT(in ) :: NUM 2040 INTEGER , INTENT(in ), OPTIONAL :: kcom ! ??? 2041 !! 2042 INTEGER :: ierror, localcomm 2043 REAL(wp) , POINTER , DIMENSION(:) :: zwork 2044 !!---------------------------------------------------------------------- 2045 ! 2046 CALL wrk_alloc(NUM , zwork) 2047 localcomm = mpi_comm_opa 2048 IF( PRESENT(kcom) ) localcomm = kcom 2049 ! 2050 CALL mpi_allreduce( ptab, zwork, NUM, mpi_double_precision, mpi_max, localcomm, ierror ) 2051 ptab = zwork 2052 CALL wrk_dealloc(NUM , zwork) 2053 ! 2054 END SUBROUTINE mppmax_real_multiple 2055 2021 2056 2022 2057 SUBROUTINE mppmin_a_real( ptab, kdim, kcom ) … … 2912 2947 END SUBROUTINE mpp_lbc_north_2d 2913 2948 2949 SUBROUTINE mpp_lbc_north_2d_multiple( pt2d_array, cd_type, psgn, num_fields) 2950 !!--------------------------------------------------------------------- 2951 !! *** routine mpp_lbc_north_2d *** 2952 !! 2953 !! ** Purpose : Ensure proper north fold horizontal bondary condition 2954 !! in mpp configuration in case of jpn1 > 1 2955 !! (for multiple 2d arrays ) 2956 !! 2957 !! ** Method : North fold condition and mpp with more than one proc 2958 !! in i-direction require a specific treatment. We gather 2959 !! the 4 northern lines of the global domain on 1 processor 2960 !! and apply lbc north-fold on this sub array. Then we 2961 !! scatter the north fold array back to the processors. 2962 !! 2963 !!---------------------------------------------------------------------- 2964 INTEGER , INTENT (in ) :: num_fields ! number of variables contained in pt2d 2965 TYPE( arrayptr ), DIMENSION(:) :: pt2d_array 2966 CHARACTER(len=1), DIMENSION(:), INTENT(in ) :: cd_type ! nature of pt2d grid-points 2967 ! ! = T , U , V , F or W gridpoints 2968 REAL(wp), DIMENSION(:), INTENT(in ) :: psgn ! = -1. the sign change across the north fold 2969 !! ! = 1. , the sign is kept 2970 INTEGER :: ji, jj, jr, jk 2971 INTEGER :: ierr, itaille, ildi, ilei, iilb 2972 INTEGER :: ijpj, ijpjm1, ij, iproc 2973 INTEGER, DIMENSION (jpmaxngh) :: ml_req_nf !for mpi_isend when avoiding mpi_allgather 2974 INTEGER :: ml_err ! for mpi_isend when avoiding mpi_allgather 2975 INTEGER, DIMENSION(MPI_STATUS_SIZE):: ml_stat ! for mpi_isend when avoiding mpi_allgather 2976 ! ! Workspace for message transfers avoiding mpi_allgather 2977 REAL(wp), DIMENSION(:,:,:) , ALLOCATABLE :: ztab 2978 REAL(wp), DIMENSION(:,:,:) , ALLOCATABLE :: znorthloc, zfoldwk 2979 REAL(wp), DIMENSION(:,:,:,:), ALLOCATABLE :: znorthgloio 2980 REAL(wp), DIMENSION(:,:,:) , ALLOCATABLE :: ztabl, ztabr 2981 INTEGER :: istatus(mpi_status_size) 2982 INTEGER :: iflag 2983 !!---------------------------------------------------------------------- 2984 ! 2985 ALLOCATE( ztab(jpiglo,4,num_fields), znorthloc(jpi,4,num_fields), zfoldwk(jpi,4,num_fields), znorthgloio(jpi,4,num_fields,jpni) ) ! expanded to 3 dimensions 2986 ALLOCATE( ztabl(jpi,4,num_fields), ztabr(jpi*jpmaxngh, 4,num_fields) ) 2987 ! 2988 ijpj = 4 2989 ijpjm1 = 3 2990 ! 2991 2992 DO jk = 1, num_fields 2993 DO jj = nlcj-ijpj+1, nlcj ! put in znorthloc the last 4 jlines of pt2d (for every variable) 2994 ij = jj - nlcj + ijpj 2995 znorthloc(:,ij,jk) = pt2d_array(jk)%pt2d(:,jj) 2996 END DO 2997 END DO 2998 ! ! Build in procs of ncomm_north the znorthgloio 2999 itaille = jpi * ijpj 3000 3001 IF ( l_north_nogather ) THEN 3002 ! 3003 ! Avoid the use of mpi_allgather by exchanging only with the processes already identified 3004 ! (in nemo_northcomms) as being involved in this process' northern boundary exchange 3005 ! 3006 ztabr(:,:,:) = 0 3007 ztabl(:,:,:) = 0 3008 3009 DO jk = 1, num_fields 3010 DO jj = nlcj-ijpj+1, nlcj ! First put local values into the global array 3011 ij = jj - nlcj + ijpj 3012 DO ji = nfsloop, nfeloop 3013 ztabl(ji,ij,jk) = pt2d_array(jk)%pt2d(ji,jj) 3014 END DO 3015 END DO 3016 END DO 3017 3018 DO jr = 1,nsndto 3019 IF ((nfipproc(isendto(jr),jpnj) .ne. (narea-1)) .and. (nfipproc(isendto(jr),jpnj) .ne. -1)) THEN 3020 CALL mppsend(5, znorthloc, itaille*num_fields, nfipproc(isendto(jr),jpnj), ml_req_nf(jr)) ! Buffer expanded "num_fields" times 3021 ENDIF 3022 END DO 3023 DO jr = 1,nsndto 3024 iproc = nfipproc(isendto(jr),jpnj) 3025 IF(iproc .ne. -1) THEN 3026 ilei = nleit (iproc+1) 3027 ildi = nldit (iproc+1) 3028 iilb = nfiimpp(isendto(jr),jpnj) - nfiimpp(isendto(1),jpnj) 3029 ENDIF 3030 IF((iproc .ne. (narea-1)) .and. (iproc .ne. -1)) THEN 3031 CALL mpprecv(5, zfoldwk, itaille*num_fields, iproc) ! Buffer expanded "num_fields" times 3032 DO jk = 1 , num_fields 3033 DO jj = 1, ijpj 3034 DO ji = ildi, ilei 3035 ztabr(iilb+ji,jj,jk) = zfoldwk(ji,jj,jk) ! Modified to 3D 3036 END DO 3037 END DO 3038 END DO 3039 ELSE IF (iproc .eq. (narea-1)) THEN 3040 DO jk = 1, num_fields 3041 DO jj = 1, ijpj 3042 DO ji = ildi, ilei 3043 ztabr(iilb+ji,jj,jk) = pt2d_array(jk)%pt2d(ji,nlcj-ijpj+jj) ! Modified to 3D 3044 END DO 3045 END DO 3046 END DO 3047 ENDIF 3048 END DO 3049 IF (l_isend) THEN 3050 DO jr = 1,nsndto 3051 IF ((nfipproc(isendto(jr),jpnj) .ne. (narea-1)) .and. (nfipproc(isendto(jr),jpnj) .ne. -1)) THEN 3052 CALL mpi_wait(ml_req_nf(jr), ml_stat, ml_err) 3053 ENDIF 3054 END DO 3055 ENDIF 3056 ! 3057 DO ji = 1, num_fields ! Loop to manage 3D variables 3058 CALL mpp_lbc_nfd( ztabl(:,:,ji), ztabr(:,:,ji), cd_type(ji), psgn(ji) ) ! North fold boundary condition 3059 END DO 3060 ! 3061 DO jk = 1, num_fields 3062 DO jj = nlcj-ijpj+1, nlcj ! Scatter back to pt2d 3063 ij = jj - nlcj + ijpj 3064 DO ji = 1, nlci 3065 pt2d_array(jk)%pt2d(ji,jj) = ztabl(ji,ij,jk) ! Modified to 3D 3066 END DO 3067 END DO 3068 END DO 3069 3070 ! 3071 ELSE 3072 ! 3073 CALL MPI_ALLGATHER( znorthloc , itaille*num_fields, MPI_DOUBLE_PRECISION, & 3074 & znorthgloio, itaille*num_fields, MPI_DOUBLE_PRECISION, ncomm_north, ierr ) 3075 ! 3076 ztab(:,:,:) = 0.e0 3077 DO jk = 1, num_fields 3078 DO jr = 1, ndim_rank_north ! recover the global north array 3079 iproc = nrank_north(jr) + 1 3080 ildi = nldit (iproc) 3081 ilei = nleit (iproc) 3082 iilb = nimppt(iproc) 3083 DO jj = 1, ijpj 3084 DO ji = ildi, ilei 3085 ztab(ji+iilb-1,jj,jk) = znorthgloio(ji,jj,jk,jr) 3086 END DO 3087 END DO 3088 END DO 3089 END DO 3090 3091 DO ji = 1, num_fields 3092 CALL lbc_nfd( ztab(:,:,ji), cd_type(ji), psgn(ji) ) ! North fold boundary condition 3093 END DO 3094 ! 3095 DO jk = 1, num_fields 3096 DO jj = nlcj-ijpj+1, nlcj ! Scatter back to pt2d 3097 ij = jj - nlcj + ijpj 3098 DO ji = 1, nlci 3099 pt2d_array(jk)%pt2d(ji,jj) = ztab(ji+nimpp-1,ij,jk) 3100 END DO 3101 END DO 3102 END DO 3103 ! 3104 ! 3105 ENDIF 3106 DEALLOCATE( ztab, znorthloc, zfoldwk, znorthgloio ) 3107 DEALLOCATE( ztabl, ztabr ) 3108 ! 3109 END SUBROUTINE mpp_lbc_north_2d_multiple 2914 3110 2915 3111 SUBROUTINE mpp_lbc_north_e( pt2d, cd_type, psgn) -
branches/2016/dev_CNRS_2016/NEMOGCM/NEMO/OPA_SRC/LBC/mppini.F90
r6140 r7278 198 198 199 199 #endif 200 IF(lwp) THEN201 WRITE(numout,*)202 WRITE(numout,*) ' defines mpp subdomains'203 WRITE(numout,*) ' ----------------------'204 WRITE(numout,*) ' iresti=',iresti,' irestj=',irestj205 WRITE(numout,*) ' jpni =',jpni ,' jpnj =',jpnj206 ifreq = 4207 il1 = 1208 DO jn = 1, (jpni-1)/ifreq+1209 il2 = MIN( jpni, il1+ifreq-1 )210 WRITE(numout,*)211 WRITE(numout,9200) ('***',ji = il1,il2-1)212 DO jj = jpnj, 1, -1213 WRITE(numout,9203) (' ',ji = il1,il2-1)214 WRITE(numout,9202) jj, ( ilcit(ji,jj),ilcjt(ji,jj),ji = il1,il2 )215 WRITE(numout,9203) (' ',ji = il1,il2-1)216 WRITE(numout,9200) ('***',ji = il1,il2-1)217 END DO218 WRITE(numout,9201) (ji,ji = il1,il2)219 il1 = il1+ifreq220 END DO221 9200 FORMAT(' ***',20('*************',a3))222 9203 FORMAT(' * ',20(' * ',a3))223 9201 FORMAT(' ',20(' ',i3,' '))224 9202 FORMAT(' ',i3,' * ',20(i3,' x',i3,' * '))225 ENDIF226 227 zidom = nreci228 DO ji = 1, jpni229 zidom = zidom + ilcit(ji,1) - nreci230 END DO231 IF(lwp) WRITE(numout,*)232 IF(lwp) WRITE(numout,*)' sum ilcit(i,1) = ', zidom, ' jpiglo = ', jpiglo233 234 zjdom = nrecj235 DO jj = 1, jpnj236 zjdom = zjdom + ilcjt(1,jj) - nrecj237 END DO238 IF(lwp) WRITE(numout,*)' sum ilcit(1,j) = ', zjdom, ' jpjglo = ', jpjglo239 IF(lwp) WRITE(numout,*)240 241 200 242 201 ! 2. Index arrays for subdomains … … 301 260 nlejt(jn) = nlej 302 261 END DO 303 304 305 ! 4. From global to local 262 263 ! 4. Subdomain print 264 ! ------------------ 265 266 IF(lwp) WRITE(numout,*) 267 IF(lwp) WRITE(numout,*) ' mpp_init: defines mpp subdomains' 268 IF(lwp) WRITE(numout,*) ' ~~~~~~ ----------------------' 269 IF(lwp) WRITE(numout,*) 270 IF(lwp) WRITE(numout,*) 'iresti=',iresti,' irestj=',irestj 271 IF(lwp) WRITE(numout,*) 272 IF(lwp) WRITE(numout,*) 'jpni=',jpni,' jpnj=',jpnj 273 zidom = nreci 274 DO ji = 1, jpni 275 zidom = zidom + ilcit(ji,1) - nreci 276 END DO 277 IF(lwp) WRITE(numout,*) 278 IF(lwp) WRITE(numout,*)' sum ilcit(i,1)=', zidom, ' jpiglo=', jpiglo 279 280 zjdom = nrecj 281 DO jj = 1, jpnj 282 zjdom = zjdom + ilcjt(1,jj) - nrecj 283 END DO 284 IF(lwp) WRITE(numout,*)' sum ilcit(1,j)=', zjdom, ' jpjglo=', jpjglo 285 IF(lwp) WRITE(numout,*) 286 287 IF(lwp) THEN 288 ifreq = 4 289 il1 = 1 290 DO jn = 1, (jpni-1)/ifreq+1 291 il2 = MIN( jpni, il1+ifreq-1 ) 292 WRITE(numout,*) 293 WRITE(numout,9200) ('***',ji = il1,il2-1) 294 DO jj = jpnj, 1, -1 295 WRITE(numout,9203) (' ',ji = il1,il2-1) 296 WRITE(numout,9202) jj, ( ilcit(ji,jj),ilcjt(ji,jj),ji = il1,il2 ) 297 WRITE(numout,9204) (nfipproc(ji,jj),ji=il1,il2) 298 WRITE(numout,9203) (' ',ji = il1,il2-1) 299 WRITE(numout,9200) ('***',ji = il1,il2-1) 300 END DO 301 WRITE(numout,9201) (ji,ji = il1,il2) 302 il1 = il1+ifreq 303 END DO 304 9200 FORMAT(' ***',20('*************',a3)) 305 9203 FORMAT(' * ',20(' * ',a3)) 306 9201 FORMAT(' ',20(' ',i3,' ')) 307 9202 FORMAT(' ',i3,' * ',20(i3,' x',i3,' * ')) 308 9204 FORMAT(' * ',20(' ',i3,' * ')) 309 ENDIF 310 311 ! 5. From global to local 306 312 ! ----------------------- 307 313 … … 310 316 311 317 312 ! 5. Subdomain neighbours318 ! 6. Subdomain neighbours 313 319 ! ---------------------- 314 320 … … 433 439 WRITE(numout,*) ' nimpp = ', nimpp 434 440 WRITE(numout,*) ' njmpp = ', njmpp 435 WRITE(numout,*) ' nbse = ', nbse , ' npse = ', npse 436 WRITE(numout,*) ' nbsw = ', nbsw , ' npsw = ', npsw 437 WRITE(numout,*) ' nbne = ', nbne , ' npne = ', npne 438 WRITE(numout,*) ' nbnw = ', nbnw , ' npnw = ', npnw 441 WRITE(numout,*) ' nreci = ', nreci , ' npse = ', npse 442 WRITE(numout,*) ' nrecj = ', nrecj , ' npsw = ', npsw 443 WRITE(numout,*) ' jpreci = ', jpreci , ' npne = ', npne 444 WRITE(numout,*) ' jprecj = ', jprecj , ' npnw = ', npnw 445 WRITE(numout,*) 439 446 ENDIF 440 447 … … 443 450 ! Prepare mpp north fold 444 451 445 IF (jperio >= 3 .AND. jperio <= 6 .AND. jpni > 1 ) THEN452 IF( jperio >= 3 .AND. jperio <= 6 .AND. jpni > 1 ) THEN 446 453 CALL mpp_ini_north 447 END IF 454 IF(lwp) WRITE(numout,*) ' mpp_init : North fold boundary prepared for jpni >1' 455 ENDIF 448 456 449 457 ! Prepare NetCDF output file (if necessary) -
branches/2016/dev_CNRS_2016/NEMOGCM/NEMO/OPA_SRC/LBC/mppini_2.h90
r7277 r7278 276 276 ENDIF 277 277 278 ! Check wet points over the entire domain to preserve the MPI communication stencil 278 279 isurf = 0 279 DO jj = 1 +jprecj, ilj-jprecj280 DO ji = 1 +jpreci, ili-jpreci280 DO jj = 1, ilj 281 DO ji = 1, ili 281 282 IF( imask(ji+iimppt(ii,ij)-1, jj+ijmppt(ii,ij)-1) == 1) isurf = isurf+1 282 283 END DO 283 284 END DO 285 284 286 IF(isurf /= 0) THEN 285 287 icont = icont + 1 … … 291 293 292 294 nfipproc(:,:) = ipproc(:,:) 293 294 295 295 296 ! Control … … 399 400 ii = iin(narea) 400 401 ij = ijn(narea) 402 403 ! set default neighbours 404 noso = ioso(ii,ij) 405 nowe = iowe(ii,ij) 406 noea = ioea(ii,ij) 407 nono = iono(ii,ij) 408 npse = iose(ii,ij) 409 npsw = iosw(ii,ij) 410 npne = ione(ii,ij) 411 npnw = ionw(ii,ij) 412 413 ! check neighbours location 401 414 IF( ioso(ii,ij) >= 0 .AND. ioso(ii,ij) <= (jpni*jpnj-1) ) THEN 402 415 iiso = 1 + MOD(ioso(ii,ij),jpni) … … 469 482 IF (lwp) THEN 470 483 CALL ctl_opn( inum, 'layout.dat', 'REPLACE', 'FORMATTED', 'SEQUENTIAL', -1, numout, .FALSE., narea ) 484 WRITE(inum,'(a)') ' jpnij jpi jpj jpk jpiglo jpjglo' 471 485 WRITE(inum,'(6i8)') jpnij,jpi,jpj,jpk,jpiglo,jpjglo 472 486 WRITE(inum,'(a)') 'NAREA nlci nlcj nldi nldj nlei nlej nimpp njmpp' … … 481 495 END IF 482 496 483 IF( nperio == 1 .AND.jpni /= 1 ) CALL ctl_stop( ' mpp_init2: error on cyclicity' )484 485 ! Prepare mpp north fold486 487 IF( jperio >= 3 .AND. jperio <= 6 .AND. jpni > 1 ) THEN488 CALL mpp_ini_north489 IF(lwp) WRITE(numout,*) ' mpp_init2 : North fold boundary prepared for jpni >1'490 ENDIF491 492 497 ! Defined npolj, either 0, 3 , 4 , 5 , 6 493 498 ! In this case the important thing is that npolj /= 0 … … 506 511 ENDIF 507 512 513 ! Periodicity : no corner if nbondi = 2 and nperio != 1 514 515 IF(lwp) THEN 516 WRITE(numout,*) ' nproc = ', nproc 517 WRITE(numout,*) ' nowe = ', nowe , ' noea = ', noea 518 WRITE(numout,*) ' nono = ', nono , ' noso = ', noso 519 WRITE(numout,*) ' nbondi = ', nbondi 520 WRITE(numout,*) ' nbondj = ', nbondj 521 WRITE(numout,*) ' npolj = ', npolj 522 WRITE(numout,*) ' nperio = ', nperio 523 WRITE(numout,*) ' nlci = ', nlci 524 WRITE(numout,*) ' nlcj = ', nlcj 525 WRITE(numout,*) ' nimpp = ', nimpp 526 WRITE(numout,*) ' njmpp = ', njmpp 527 WRITE(numout,*) ' nreci = ', nreci , ' npse = ', npse 528 WRITE(numout,*) ' nrecj = ', nrecj , ' npsw = ', npsw 529 WRITE(numout,*) ' jpreci = ', jpreci , ' npne = ', npne 530 WRITE(numout,*) ' jprecj = ', jprecj , ' npnw = ', npnw 531 WRITE(numout,*) 532 ENDIF 533 534 IF( nperio == 1 .AND. jpni /= 1 ) CALL ctl_stop( ' mpp_init2: error on cyclicity' ) 535 536 ! Prepare mpp north fold 537 538 IF( jperio >= 3 .AND. jperio <= 6 .AND. jpni > 1 ) THEN 539 CALL mpp_ini_north 540 IF(lwp) WRITE(numout,*) ' mpp_init2 : North fold boundary prepared for jpni >1' 541 ENDIF 542 508 543 ! Prepare NetCDF output file (if necessary) 509 544 CALL mpp_init_ioipsl 510 545 511 ! Periodicity : no corner if nbondi = 2 and nperio != 1512 513 IF(lwp) THEN514 WRITE(numout,*) ' nproc= ',nproc515 WRITE(numout,*) ' nowe= ',nowe516 WRITE(numout,*) ' noea= ',noea517 WRITE(numout,*) ' nono= ',nono518 WRITE(numout,*) ' noso= ',noso519 WRITE(numout,*) ' nbondi= ',nbondi520 WRITE(numout,*) ' nbondj= ',nbondj521 WRITE(numout,*) ' npolj= ',npolj522 WRITE(numout,*) ' nperio= ',nperio523 WRITE(numout,*) ' nlci= ',nlci524 WRITE(numout,*) ' nlcj= ',nlcj525 WRITE(numout,*) ' nimpp= ',nimpp526 WRITE(numout,*) ' njmpp= ',njmpp527 WRITE(numout,*) ' nbse= ',nbse,' npse= ',npse528 WRITE(numout,*) ' nbsw= ',nbsw,' npsw= ',npsw529 WRITE(numout,*) ' nbne= ',nbne,' npne= ',npne530 WRITE(numout,*) ' nbnw= ',nbnw,' npnw= ',npnw531 ENDIF532 546 533 547 END SUBROUTINE mpp_init2 -
branches/2016/dev_CNRS_2016/NEMOGCM/NEMO/OPA_SRC/SBC/albedo.F90
r4624 r7278 9 9 !! - ! 2001-06 (M. Vancoppenolle) LIM 3.0 10 10 !! - ! 2006-08 (G. Madec) cleaning for surface module 11 !! 3.6 ! 2016-01 (C. Rousset) new parameterization for sea ice albedo 11 12 !!---------------------------------------------------------------------- 12 13 … … 29 30 30 31 INTEGER :: albd_init = 0 !: control flag for initialization 31 REAL(wp) :: zzero = 0.e0 ! constant values32 REAL(wp) :: zone = 1.e0 ! " "33 34 REAL(wp) :: c1 = 0.05 ! constants values35 REAL(wp) :: c2 = 0.10 !" "36 REAL(wp) :: r mue = 0.40 ! cosine of local solar altitude37 32 33 REAL(wp) :: rmue = 0.40 ! cosine of local solar altitude 34 REAL(wp) :: ralb_oce = 0.066 ! ocean or lead albedo (Pegau and Paulson, Ann. Glac. 2001) 35 REAL(wp) :: c1 = 0.05 ! snow thickness (only for nn_ice_alb=0) 36 REAL(wp) :: c2 = 0.10 ! " " 37 REAL(wp) :: rcloud = 0.06 ! cloud effect on albedo (only-for nn_ice_alb=0) 38 38 39 ! !!* namelist namsbc_alb 39 REAL(wp) :: rn_cloud ! cloudiness effect on snow or ice albedo (Grenfell & Perovich, 1984) 40 #if defined key_lim3 41 REAL(wp) :: rn_albice ! albedo of melting ice in the arctic and antarctic (Shine & Hendersson-Sellers) 42 #else 43 REAL(wp) :: rn_albice ! albedo of melting ice in the arctic and antarctic (Shine & Hendersson-Sellers) 44 #endif 45 REAL(wp) :: rn_alphd ! coefficients for linear interpolation used to compute 46 REAL(wp) :: rn_alphdi ! albedo between two extremes values (Pyane, 1972) 47 REAL(wp) :: rn_alphc ! 40 INTEGER :: nn_ice_alb 41 REAL(wp) :: rn_albice 48 42 49 43 !!---------------------------------------------------------------------- … … 59 53 !! 60 54 !! ** Purpose : Computation of the albedo of the snow/ice system 61 !! as well as the ocean one62 55 !! 63 !! ** Method : - Computation of the albedo of snow or ice (choose the 64 !! rignt one by a large number of tests 65 !! - Computation of the albedo of the ocean 66 !! 67 !! References : Shine and Hendersson-Sellers 1985, JGR, 90(D1), 2243-2250. 56 !! ** Method : Two schemes are available (from namelist parameter nn_ice_alb) 57 !! 0: the scheme is that of Shine & Henderson-Sellers (JGR 1985) for clear-skies 58 !! 1: the scheme is "home made" (for cloudy skies) and based on Brandt et al. (J. Climate 2005) 59 !! and Grenfell & Perovich (JGR 2004) 60 !! Description of scheme 1: 61 !! 1) Albedo dependency on ice thickness follows the findings from Brandt et al (2005) 62 !! which are an update of Allison et al. (JGR 1993) ; Brandt et al. 1999 63 !! 0-5cm : linear function of ice thickness 64 !! 5-150cm: log function of ice thickness 65 !! > 150cm: constant 66 !! 2) Albedo dependency on snow thickness follows the findings from Grenfell & Perovich (2004) 67 !! i.e. it increases as -EXP(-snw_thick/0.02) during freezing and -EXP(-snw_thick/0.03) during melting 68 !! 3) Albedo dependency on clouds is speculated from measurements of Grenfell and Perovich (2004) 69 !! i.e. cloudy-clear albedo depend on cloudy albedo following a 2d order polynomial law 70 !! 4) The needed 4 parameters are: dry and melting snow, freezing ice and bare puddled ice 71 !! 72 !! ** Note : The parameterization from Shine & Henderson-Sellers presents several misconstructions: 73 !! 1) ice albedo when ice thick. tends to 0 is different than ocean albedo 74 !! 2) for small ice thick. covered with some snow (<3cm?), albedo is larger 75 !! under melting conditions than under freezing conditions 76 !! 3) the evolution of ice albedo as a function of ice thickness shows 77 !! 3 sharp inflexion points (at 5cm, 100cm and 150cm) that look highly unrealistic 78 !! 79 !! References : Shine & Henderson-Sellers 1985, JGR, 90(D1), 2243-2250. 80 !! Brandt et al. 2005, J. Climate, vol 18 81 !! Grenfell & Perovich 2004, JGR, vol 109 68 82 !!---------------------------------------------------------------------- 69 83 REAL(wp), INTENT(in ), DIMENSION(:,:,:) :: pt_ice ! ice surface temperature (Kelvin) … … 73 87 REAL(wp), INTENT( out), DIMENSION(:,:,:) :: pa_ice_os ! albedo of ice under overcast sky 74 88 !! 75 INTEGER :: ji, jj, jl ! dummy loop indices 76 INTEGER :: ijpl ! number of ice categories (3rd dim of ice input arrays) 77 REAL(wp) :: zalbpsnm ! albedo of ice under clear sky when snow is melting 78 REAL(wp) :: zalbpsnf ! albedo of ice under clear sky when snow is freezing 79 REAL(wp) :: zalbpsn ! albedo of snow/ice system when ice is coverd by snow 80 REAL(wp) :: zalbpic ! albedo of snow/ice system when ice is free of snow 81 REAL(wp) :: zithsn ! = 1 for hsn >= 0 ( ice is cov. by snow ) ; = 0 otherwise (ice is free of snow) 82 REAL(wp) :: zitmlsn ! = 1 freezinz snow (pt_ice >=rt0_snow) ; = 0 melting snow (pt_ice<rt0_snow) 83 REAL(wp) :: zihsc1 ! = 1 hsn <= c1 ; = 0 hsn > c1 84 REAL(wp) :: zihsc2 ! = 1 hsn >= c2 ; = 0 hsn < c2 85 !! 86 REAL(wp), POINTER, DIMENSION(:,:,:) :: zalbfz ! = rn_alphdi for freezing ice ; = rn_albice for melting ice 87 REAL(wp), POINTER, DIMENSION(:,:,:) :: zficeth ! function of ice thickness 89 INTEGER :: ji, jj, jl ! dummy loop indices 90 INTEGER :: ijpl ! number of ice categories (3rd dim of ice input arrays) 91 REAL(wp) :: ralb_im, ralb_sf, ralb_sm, ralb_if 92 REAL(wp) :: zswitch, z1_c1, z1_c2 93 REAL(wp) :: zalb_sm, zalb_sf, zalb_st ! albedo of snow melting, freezing, total 94 REAL(wp), POINTER, DIMENSION(:,:,:) :: zalb, zalb_it ! intermediate variable & albedo of ice (snow free) 88 95 !!--------------------------------------------------------------------- 89 96 90 97 ijpl = SIZE( pt_ice, 3 ) ! number of ice categories 91 92 CALL wrk_alloc( jpi,jpj,ijpl, zalb fz, zficeth)98 99 CALL wrk_alloc( jpi,jpj,ijpl, zalb, zalb_it ) 93 100 94 101 IF( albd_init == 0 ) CALL albedo_init ! initialization 95 102 96 !--------------------------- 97 ! Computation of zficeth 98 !--------------------------- 99 ! ice free of snow and melts 100 WHERE ( ph_snw == 0._wp .AND. pt_ice >= rt0_ice ) ; zalbfz(:,:,:) = rn_albice 101 ELSE WHERE ; zalbfz(:,:,:) = rn_alphdi 102 END WHERE 103 104 WHERE ( 1.5 < ph_ice ) ; zficeth = zalbfz 105 ELSE WHERE( 1.0 < ph_ice .AND. ph_ice <= 1.5 ) ; zficeth = 0.472 + 2.0 * ( zalbfz - 0.472 ) * ( ph_ice - 1.0 ) 106 ELSE WHERE( 0.05 < ph_ice .AND. ph_ice <= 1.0 ) ; zficeth = 0.2467 + 0.7049 * ph_ice & 107 & - 0.8608 * ph_ice * ph_ice & 108 & + 0.3812 * ph_ice * ph_ice * ph_ice 109 ELSE WHERE ; zficeth = 0.1 + 3.6 * ph_ice 110 END WHERE 111 112 !!gm old code 113 ! DO jl = 1, ijpl 114 ! DO jj = 1, jpj 115 ! DO ji = 1, jpi 116 ! IF( ph_ice(ji,jj,jl) > 1.5 ) THEN 117 ! zficeth(ji,jj,jl) = zalbfz(ji,jj,jl) 118 ! ELSEIF( ph_ice(ji,jj,jl) > 1.0 .AND. ph_ice(ji,jj,jl) <= 1.5 ) THEN 119 ! zficeth(ji,jj,jl) = 0.472 + 2.0 * ( zalbfz(ji,jj,jl) - 0.472 ) * ( ph_ice(ji,jj,jl) - 1.0 ) 120 ! ELSEIF( ph_ice(ji,jj,jl) > 0.05 .AND. ph_ice(ji,jj,jl) <= 1.0 ) THEN 121 ! zficeth(ji,jj,jl) = 0.2467 + 0.7049 * ph_ice(ji,jj,jl) & 122 ! & - 0.8608 * ph_ice(ji,jj,jl) * ph_ice(ji,jj,jl) & 123 ! & + 0.3812 * ph_ice(ji,jj,jl) * ph_ice(ji,jj,jl) * ph_ice (ji,jj,jl) 124 ! ELSE 125 ! zficeth(ji,jj,jl) = 0.1 + 3.6 * ph_ice(ji,jj,jl) 126 ! ENDIF 127 ! END DO 128 ! END DO 129 ! END DO 130 !!gm end old code 131 132 !----------------------------------------------- 133 ! Computation of the snow/ice albedo system 134 !-------------------------- --------------------- 135 136 ! Albedo of snow-ice for clear sky. 137 !----------------------------------------------- 138 DO jl = 1, ijpl 139 DO jj = 1, jpj 140 DO ji = 1, jpi 141 ! Case of ice covered by snow. 142 ! ! freezing snow 143 zihsc1 = 1.0 - MAX( zzero , SIGN( zone , - ( ph_snw(ji,jj,jl) - c1 ) ) ) 144 zalbpsnf = ( 1.0 - zihsc1 ) * ( zficeth(ji,jj,jl) & 145 & + ph_snw(ji,jj,jl) * ( rn_alphd - zficeth(ji,jj,jl) ) / c1 ) & 146 & + zihsc1 * rn_alphd 147 ! ! melting snow 148 zihsc2 = MAX( zzero , SIGN( zone , ph_snw(ji,jj,jl) - c2 ) ) 149 zalbpsnm = ( 1.0 - zihsc2 ) * ( rn_albice + ph_snw(ji,jj,jl) * ( rn_alphc - rn_albice ) / c2 ) & 150 & + zihsc2 * rn_alphc 151 ! 152 zitmlsn = MAX( zzero , SIGN( zone , pt_ice(ji,jj,jl) - rt0_snow ) ) 153 zalbpsn = zitmlsn * zalbpsnm + ( 1.0 - zitmlsn ) * zalbpsnf 154 155 ! Case of ice free of snow. 156 zalbpic = zficeth(ji,jj,jl) 157 158 ! albedo of the system 159 zithsn = 1.0 - MAX( zzero , SIGN( zone , - ph_snw(ji,jj,jl) ) ) 160 pa_ice_cs(ji,jj,jl) = zithsn * zalbpsn + ( 1.0 - zithsn ) * zalbpic 103 104 SELECT CASE ( nn_ice_alb ) 105 106 !------------------------------------------ 107 ! Shine and Henderson-Sellers (1985) 108 !------------------------------------------ 109 CASE( 0 ) 110 111 ralb_sf = 0.80 ! dry snow 112 ralb_sm = 0.65 ! melting snow 113 ralb_if = 0.72 ! bare frozen ice 114 ralb_im = rn_albice ! bare puddled ice 115 116 ! Computation of ice albedo (free of snow) 117 WHERE ( ph_snw == 0._wp .AND. pt_ice >= rt0_ice ) ; zalb(:,:,:) = ralb_im 118 ELSE WHERE ; zalb(:,:,:) = ralb_if 119 END WHERE 120 121 WHERE ( 1.5 < ph_ice ) ; zalb_it = zalb 122 ELSE WHERE( 1.0 < ph_ice .AND. ph_ice <= 1.5 ) ; zalb_it = 0.472 + 2.0 * ( zalb - 0.472 ) * ( ph_ice - 1.0 ) 123 ELSE WHERE( 0.05 < ph_ice .AND. ph_ice <= 1.0 ) ; zalb_it = 0.2467 + 0.7049 * ph_ice & 124 & - 0.8608 * ph_ice * ph_ice & 125 & + 0.3812 * ph_ice * ph_ice * ph_ice 126 ELSE WHERE ; zalb_it = 0.1 + 3.6 * ph_ice 127 END WHERE 128 129 DO jl = 1, ijpl 130 DO jj = 1, jpj 131 DO ji = 1, jpi 132 ! freezing snow 133 ! no effect of underlying ice layer IF snow thickness > c1. Albedo does not depend on snow thick if > c2 134 ! ! freezing snow 135 zswitch = 1._wp - MAX( 0._wp , SIGN( 1._wp , - ( ph_snw(ji,jj,jl) - c1 ) ) ) 136 zalb_sf = ( 1._wp - zswitch ) * ( zalb_it(ji,jj,jl) & 137 & + ph_snw(ji,jj,jl) * ( ralb_sf - zalb_it(ji,jj,jl) ) / c1 ) & 138 & + zswitch * ralb_sf 139 140 ! melting snow 141 ! no effect of underlying ice layer. Albedo does not depend on snow thick IF > c2 142 zswitch = MAX( 0._wp , SIGN( 1._wp , ph_snw(ji,jj,jl) - c2 ) ) 143 zalb_sm = ( 1._wp - zswitch ) * ( ralb_im + ph_snw(ji,jj,jl) * ( ralb_sm - ralb_im ) / c2 ) & 144 & + zswitch * ralb_sm 145 ! 146 ! snow albedo 147 zswitch = MAX( 0._wp , SIGN( 1._wp , pt_ice(ji,jj,jl) - rt0_snow ) ) 148 zalb_st = zswitch * zalb_sm + ( 1._wp - zswitch ) * zalb_sf 149 150 ! Ice/snow albedo 151 zswitch = 1._wp - MAX( 0._wp , SIGN( 1._wp , - ph_snw(ji,jj,jl) ) ) 152 pa_ice_cs(ji,jj,jl) = zswitch * zalb_st + ( 1._wp - zswitch ) * zalb_it(ji,jj,jl) 153 ! 154 END DO 161 155 END DO 162 156 END DO 163 END DO 164 165 ! Albedo of snow-ice for overcast sky. 166 !---------------------------------------------- 167 pa_ice_os(:,:,:) = pa_ice_cs(:,:,:) + rn_cloud ! Oberhuber correction 168 ! 169 CALL wrk_dealloc( jpi,jpj,ijpl, zalbfz, zficeth ) 157 158 pa_ice_os(:,:,:) = pa_ice_cs(:,:,:) + rcloud ! Oberhuber correction for overcast sky 159 160 !------------------------------------------ 161 ! New parameterization (2016) 162 !------------------------------------------ 163 CASE( 1 ) 164 165 ralb_im = rn_albice ! bare puddled ice 166 ! compilation of values from literature 167 ralb_sf = 0.85 ! dry snow 168 ralb_sm = 0.75 ! melting snow 169 ralb_if = 0.60 ! bare frozen ice 170 ! Perovich et al 2002 (Sheba) => the only dataset for which all types of ice/snow were retrieved 171 ! ralb_sf = 0.85 ! dry snow 172 ! ralb_sm = 0.72 ! melting snow 173 ! ralb_if = 0.65 ! bare frozen ice 174 ! Brandt et al 2005 (East Antarctica) 175 ! ralb_sf = 0.87 ! dry snow 176 ! ralb_sm = 0.82 ! melting snow 177 ! ralb_if = 0.54 ! bare frozen ice 178 ! 179 ! Computation of ice albedo (free of snow) 180 z1_c1 = 1. / ( LOG(1.5) - LOG(0.05) ) 181 z1_c2 = 1. / 0.05 182 WHERE ( ph_snw == 0._wp .AND. pt_ice >= rt0_ice ) ; zalb = ralb_im 183 ELSE WHERE ; zalb = ralb_if 184 END WHERE 185 186 WHERE ( 1.5 < ph_ice ) ; zalb_it = zalb 187 ELSE WHERE( 0.05 < ph_ice .AND. ph_ice <= 1.5 ) ; zalb_it = zalb + ( 0.18 - zalb ) * z1_c1 * & 188 & ( LOG(1.5) - LOG(ph_ice) ) 189 ELSE WHERE ; zalb_it = ralb_oce + ( 0.18 - ralb_oce ) * z1_c2 * ph_ice 190 END WHERE 191 192 z1_c1 = 1. / 0.02 193 z1_c2 = 1. / 0.03 194 ! Computation of the snow/ice albedo 195 DO jl = 1, ijpl 196 DO jj = 1, jpj 197 DO ji = 1, jpi 198 zalb_sf = ralb_sf - ( ralb_sf - zalb_it(ji,jj,jl)) * EXP( - ph_snw(ji,jj,jl) * z1_c1 ); 199 zalb_sm = ralb_sm - ( ralb_sm - zalb_it(ji,jj,jl)) * EXP( - ph_snw(ji,jj,jl) * z1_c2 ); 200 201 ! snow albedo 202 zswitch = MAX( 0._wp , SIGN( 1._wp , pt_ice(ji,jj,jl) - rt0_snow ) ) 203 zalb_st = zswitch * zalb_sm + ( 1._wp - zswitch ) * zalb_sf 204 205 ! Ice/snow albedo 206 zswitch = MAX( 0._wp , SIGN( 1._wp , - ph_snw(ji,jj,jl) ) ) 207 pa_ice_os(ji,jj,jl) = ( 1._wp - zswitch ) * zalb_st + zswitch * zalb_it(ji,jj,jl) 208 209 END DO 210 END DO 211 END DO 212 ! Effect of the clouds (2d order polynomial) 213 pa_ice_cs = pa_ice_os - ( - 0.1010 * pa_ice_os * pa_ice_os + 0.1933 * pa_ice_os - 0.0148 ); 214 215 END SELECT 216 217 CALL wrk_dealloc( jpi,jpj,ijpl, zalb, zalb_it ) 170 218 ! 171 219 END SUBROUTINE albedo_ice … … 181 229 REAL(wp), DIMENSION(:,:), INTENT(out) :: pa_oce_cs ! albedo of ocean under clear sky 182 230 !! 183 REAL(wp) :: zcoef ! local scalar184 !!---------------------------------------------------------------------- 185 ! 186 zcoef = 0.05 / ( 1.1 * rmue**1.4 + 0.15 ) ! Parameterization of Briegled and Ramanathan, 1982187 pa_oce_cs(:,:) = zcoef 188 pa_oce_os(:,:) = 0.06! Parameterization of Kondratyev, 1969 and Payne, 1972231 REAL(wp) :: zcoef 232 !!---------------------------------------------------------------------- 233 ! 234 zcoef = 0.05 / ( 1.1 * rmue**1.4 + 0.15 ) ! Parameterization of Briegled and Ramanathan, 1982 235 pa_oce_cs(:,:) = zcoef 236 pa_oce_os(:,:) = 0.06 ! Parameterization of Kondratyev, 1969 and Payne, 1972 189 237 ! 190 238 END SUBROUTINE albedo_oce … … 200 248 !!---------------------------------------------------------------------- 201 249 INTEGER :: ios ! Local integer output status for namelist read 202 NAMELIST/namsbc_alb/ rn_cloud, rn_albice, rn_alphd, rn_alphdi, rn_alphc250 NAMELIST/namsbc_alb/ nn_ice_alb, rn_albice 203 251 !!---------------------------------------------------------------------- 204 252 ! … … 219 267 WRITE(numout,*) '~~~~~~~' 220 268 WRITE(numout,*) ' Namelist namsbc_alb : albedo ' 221 WRITE(numout,*) ' correction for snow and ice albedo rn_cloud = ', rn_cloud 222 WRITE(numout,*) ' albedo of melting ice in the arctic and antarctic rn_albice = ', rn_albice 223 WRITE(numout,*) ' coefficients for linear rn_alphd = ', rn_alphd 224 WRITE(numout,*) ' interpolation used to compute albedo rn_alphdi = ', rn_alphdi 225 WRITE(numout,*) ' between two extremes values (Pyane, 1972) rn_alphc = ', rn_alphc 269 WRITE(numout,*) ' choose the albedo parameterization nn_ice_alb = ', nn_ice_alb 270 WRITE(numout,*) ' albedo of bare puddled ice rn_albice = ', rn_albice 226 271 ENDIF 227 272 ! -
branches/2016/dev_CNRS_2016/NEMOGCM/NEMO/OPA_SRC/SBC/sbc_ice.F90
r5407 r7278 80 80 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: qemp_oce !: heat flux of precip and evap over ocean [W/m2] 81 81 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: qemp_ice !: heat flux of precip and evap over ice [W/m2] 82 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: qprec_ice !: heat flux of precip over ice [J/m3] 82 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: qevap_ice !: heat flux of evap over ice [W/m2] 83 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: qprec_ice !: enthalpy of precip over ice [J/m3] 83 84 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: emp_oce !: evap - precip over ocean [kg/m2/s] 84 85 #endif … … 144 145 #endif 145 146 #if defined key_lim3 146 & evap_ice(jpi,jpj,jpl) , devap_ice(jpi,jpj,jpl) , qprec_ice(jpi,jpj) , &147 & qemp_ice(jpi,jpj) , qe mp_oce(jpi,jpj) ,&148 & qns_oce (jpi,jpj) , qsr_oce (jpi,jpj) , emp_oce (jpi,jpj) ,&147 & evap_ice(jpi,jpj,jpl) , devap_ice(jpi,jpj,jpl) , qprec_ice(jpi,jpj) , & 148 & qemp_ice(jpi,jpj) , qevap_ice(jpi,jpj,jpl) , qemp_oce (jpi,jpj) , & 149 & qns_oce (jpi,jpj) , qsr_oce (jpi,jpj) , emp_oce (jpi,jpj) , & 149 150 #endif 150 151 & emp_ice(jpi,jpj) , STAT= ierr(1) ) -
branches/2016/dev_CNRS_2016/NEMOGCM/NEMO/OPA_SRC/SBC/sbcblk_clio.F90
r7277 r7278 668 668 qprec_ice(:,:) = rhosn * ( ( MIN( sf(jp_tair)%fnow(:,:,1), rt0_snow ) - rt0 ) * cpic * tmask(:,:,1) - lfus ) 669 669 670 ! --- heat content of evap over ice in W/m2 (to be used in 1D-thermo) --- ! 671 DO jl = 1, jpl 672 qevap_ice(:,:,jl) = 0._wp ! should be -evap_ice(:,:,jl)*( ( Tice - rt0 ) * cpic * tmask(:,:,1) - lfus ) 673 ! but then qemp_ice should also include sublimation 674 END DO 675 670 676 CALL wrk_dealloc( jpi,jpj, zevap, zsnw ) 671 677 #endif -
branches/2016/dev_CNRS_2016/NEMOGCM/NEMO/OPA_SRC/SBC/sbcblk_core.F90
r7277 r7278 612 612 ! --- evaporation --- ! 613 613 z1_lsub = 1._wp / Lsub 614 evap_ice (:,:,:) = qla_ice (:,:,:) * z1_lsub! sublimation615 devap_ice(:,:,:) = dqla_ice(:,:,:) * z1_lsub616 zevap (:,:) = emp(:,:) + tprecip(:,:)! evaporation over ocean614 evap_ice (:,:,:) = rn_efac * qla_ice (:,:,:) * z1_lsub ! sublimation 615 devap_ice(:,:,:) = rn_efac * dqla_ice(:,:,:) * z1_lsub ! d(sublimation)/dT 616 zevap (:,:) = rn_efac * ( emp(:,:) + tprecip(:,:) ) ! evaporation over ocean 617 617 618 618 ! --- evaporation minus precipitation --- ! … … 637 637 ! --- heat content of precip over ice in J/m3 (to be used in 1D-thermo) --- ! 638 638 qprec_ice(:,:) = rhosn * ( ( MIN( sf(jp_tair)%fnow(:,:,1), rt0_snow ) - rt0 ) * cpic * tmask(:,:,1) - lfus ) 639 640 ! --- heat content of evap over ice in W/m2 (to be used in 1D-thermo) --- ! 641 DO jl = 1, jpl 642 qevap_ice(:,:,jl) = 0._wp ! should be -evap_ice(:,:,jl)*( ( Tice - rt0 ) * cpic * tmask(:,:,1) ) 643 ! But we do not have Tice => consider it at 0°C => evap=0 644 END DO 639 645 640 646 CALL wrk_dealloc( jpi,jpj, zevap, zsnw ) -
branches/2016/dev_CNRS_2016/NEMOGCM/NEMO/OPA_SRC/SBC/sbccpl.F90
r7277 r7278 1006 1006 IF( srcv(jpr_toce)%laction ) THEN ! received by sas in case of opa <-> sas coupling 1007 1007 sst_m(:,:) = frcv(jpr_toce)%z3(:,:,1) 1008 IF( srcv(jpr_soce)%laction .AND. l n_useCT ) THEN ! make sure that sst_m is the potential temperature1008 IF( srcv(jpr_soce)%laction .AND. l_useCT ) THEN ! make sure that sst_m is the potential temperature 1009 1009 sst_m(:,:) = eos_pt_from_ct( sst_m(:,:), sss_m(:,:) ) 1010 1010 ENDIF … … 1370 1370 ! 1371 1371 INTEGER :: jl ! dummy loop index 1372 REAL(wp), POINTER, DIMENSION(:,: ) :: zcptn, ztmp, zicefr, zmsk 1373 REAL(wp), POINTER, DIMENSION(:,: ) :: zemp_tot, zemp_ice, z sprecip, ztprecip, zqns_tot, zqsr_tot1374 REAL(wp), POINTER, DIMENSION(:,: ,:) :: zqns_ice, zqsr_ice, zdqns_ice1375 REAL(wp), POINTER, DIMENSION(:,: ) :: zevap, zsnw, zqns_oce, zqsr_oce, zqprec_ice, zqemp_oce ! for LIM31372 REAL(wp), POINTER, DIMENSION(:,: ) :: zcptn, ztmp, zicefr, zmsk, zsnw 1373 REAL(wp), POINTER, DIMENSION(:,: ) :: zemp_tot, zemp_ice, zemp_oce, ztprecip, zsprecip, zevap, zevap_ice, zdevap_ice 1374 REAL(wp), POINTER, DIMENSION(:,: ) :: zqns_tot, zqns_oce, zqsr_tot, zqsr_oce, zqprec_ice, zqemp_oce, zqemp_ice 1375 REAL(wp), POINTER, DIMENSION(:,:,:) :: zqns_ice, zqsr_ice, zdqns_ice, zqevap_ice 1376 1376 !!---------------------------------------------------------------------- 1377 1377 ! 1378 1378 IF( nn_timing == 1 ) CALL timing_start('sbc_cpl_ice_flx') 1379 1379 ! 1380 CALL wrk_alloc( jpi,jpj, zcptn, ztmp, zicefr, zmsk, zemp_tot, zemp_ice, zsprecip, ztprecip, zqns_tot, zqsr_tot ) 1381 CALL wrk_alloc( jpi,jpj,jpl, zqns_ice, zqsr_ice, zdqns_ice ) 1380 CALL wrk_alloc( jpi,jpj, zcptn, ztmp, zicefr, zmsk, zsnw ) 1381 CALL wrk_alloc( jpi,jpj, zemp_tot, zemp_ice, zemp_oce, ztprecip, zsprecip, zevap, zevap_ice, zdevap_ice ) 1382 CALL wrk_alloc( jpi,jpj, zqns_tot, zqns_oce, zqsr_tot, zqsr_oce, zqprec_ice, zqemp_oce, zqemp_ice ) 1383 CALL wrk_alloc( jpi,jpj,jpl, zqns_ice, zqsr_ice, zdqns_ice, zqevap_ice ) 1382 1384 1383 1385 IF( ln_mixcpl ) zmsk(:,:) = 1. - xcplmask(:,:,0) … … 1414 1416 ztprecip(:,:) = frcv(jpr_semp)%z3(:,:,1) - frcv(jpr_sbpr)%z3(:,:,1) + zsprecip(:,:) 1415 1417 END SELECT 1416 1417 IF( iom_use('subl_ai_cea') ) & 1418 CALL iom_put( 'subl_ai_cea', frcv(jpr_ievp)%z3(:,:,1) * zicefr(:,:) ) ! Sublimation over sea-ice (cell average) 1419 ! 1420 ! ! runoffs and calving (put in emp_tot) 1418 #if defined key_lim3 1419 ! zsnw = snow percentage over ice after wind blowing 1420 zsnw(:,:) = 0._wp 1421 CALL lim_thd_snwblow( p_frld, zsnw ) 1422 1423 ! --- evaporation (used later in sbccpl) --- ! 1424 zevap(:,:) = zemp_tot(:,:) + ztprecip(:,:) 1425 1426 ! --- evaporation over ice (kg/m2/s) --- ! 1427 zevap_ice(:,:) = frcv(jpr_ievp)%z3(:,:,1) 1428 ! since the sensitivity of evap to temperature (devap/dT) is not prescribed by the atmosphere, we set it to 0 1429 ! therefore, sublimation is not redistributed over the ice categories in case no subgrid scale fluxes are provided by atm. 1430 zdevap_ice(:,:) = 0._wp 1431 1432 ! --- evaporation minus precipitation corrected for the effect of wind blowing on snow --- ! 1433 zemp_oce(:,:) = zemp_tot(:,:) - zemp_ice(:,:) - zsprecip * (1._wp - zsnw) 1434 zemp_ice(:,:) = zemp_ice(:,:) + zsprecip * (1._wp - zsnw) 1435 1436 ! --- runoffs (included in emp later on) --- ! 1437 IF( srcv(jpr_rnf)%laction ) rnf(:,:) = frcv(jpr_rnf)%z3(:,:,1) 1438 1439 ! --- calving (put in emp_tot and emp_oce) --- ! 1440 IF( srcv(jpr_cal)%laction ) THEN 1441 zemp_tot(:,:) = zemp_tot(:,:) - frcv(jpr_cal)%z3(:,:,1) 1442 zemp_oce(:,:) = zemp_oce(:,:) - frcv(jpr_cal)%z3(:,:,1) 1443 CALL iom_put( 'calving_cea', frcv(jpr_cal)%z3(:,:,1) ) 1444 ENDIF 1445 1446 IF( ln_mixcpl ) THEN 1447 emp_tot(:,:) = emp_tot(:,:) * xcplmask(:,:,0) + zemp_tot(:,:) * zmsk(:,:) 1448 emp_ice(:,:) = emp_ice(:,:) * xcplmask(:,:,0) + zemp_ice(:,:) * zmsk(:,:) 1449 emp_oce(:,:) = emp_oce(:,:) * xcplmask(:,:,0) + zemp_oce(:,:) * zmsk(:,:) 1450 sprecip(:,:) = sprecip(:,:) * xcplmask(:,:,0) + zsprecip(:,:) * zmsk(:,:) 1451 tprecip(:,:) = tprecip(:,:) * xcplmask(:,:,0) + ztprecip(:,:) * zmsk(:,:) 1452 DO jl=1,jpl 1453 evap_ice (:,:,jl) = evap_ice (:,:,jl) * xcplmask(:,:,0) + zevap_ice (:,:) * zmsk(:,:) 1454 devap_ice(:,:,jl) = devap_ice(:,:,jl) * xcplmask(:,:,0) + zdevap_ice(:,:) * zmsk(:,:) 1455 ENDDO 1456 ELSE 1457 emp_tot(:,:) = zemp_tot(:,:) 1458 emp_ice(:,:) = zemp_ice(:,:) 1459 emp_oce(:,:) = zemp_oce(:,:) 1460 sprecip(:,:) = zsprecip(:,:) 1461 tprecip(:,:) = ztprecip(:,:) 1462 DO jl=1,jpl 1463 evap_ice (:,:,jl) = zevap_ice (:,:) 1464 devap_ice(:,:,jl) = zdevap_ice(:,:) 1465 ENDDO 1466 ENDIF 1467 1468 IF( iom_use('subl_ai_cea') ) CALL iom_put( 'subl_ai_cea', zevap_ice(:,:) * zicefr(:,:) ) ! Sublimation over sea-ice (cell average) 1469 CALL iom_put( 'snowpre' , sprecip ) ! Snow 1470 IF( iom_use('snow_ao_cea') ) CALL iom_put( 'snow_ao_cea', sprecip(:,:) * ( 1._wp - zsnw ) ) ! Snow over ice-free ocean (cell average) 1471 IF( iom_use('snow_ai_cea') ) CALL iom_put( 'snow_ai_cea', sprecip(:,:) * zsnw ) ! Snow over sea-ice (cell average) 1472 #else 1473 ! Sublimation over sea-ice (cell average) 1474 IF( iom_use('subl_ai_cea') ) CALL iom_put( 'subl_ai_cea', frcv(jpr_ievp)%z3(:,:,1) * zicefr(:,:) ) 1475 ! runoffs and calving (put in emp_tot) 1421 1476 IF( srcv(jpr_rnf)%laction ) rnf(:,:) = frcv(jpr_rnf)%z3(:,:,1) 1422 1477 IF( srcv(jpr_cal)%laction ) THEN … … 1442 1497 IF( iom_use('snow_ai_cea') ) & 1443 1498 CALL iom_put( 'snow_ai_cea', sprecip(:,:) * zicefr(:,:) ) ! Snow over sea-ice (cell average) 1499 #endif 1444 1500 1445 1501 ! ! ========================= ! … … 1497 1553 IF( iom_use('hflx_snow_cea') ) CALL iom_put( 'hflx_snow_cea', ztmp + sprecip(:,:) * zcptn(:,:) ) ! heat flux from snow (cell average) 1498 1554 1499 #if defined key_lim3 1500 CALL wrk_alloc( jpi,jpj, zevap, zsnw, zqns_oce, zqprec_ice, zqemp_oce ) 1501 1502 ! --- evaporation --- ! 1503 ! clem: evap_ice is set to 0 for LIM3 since we still do not know what to do with sublimation 1504 ! the problem is: the atm. imposes both mass evaporation and heat removed from the snow/ice 1505 ! but it is incoherent WITH the ice model 1506 DO jl=1,jpl 1507 evap_ice(:,:,jl) = 0._wp ! should be: frcv(jpr_ievp)%z3(:,:,1) 1508 ENDDO 1509 zevap(:,:) = zemp_tot(:,:) + ztprecip(:,:) ! evaporation over ocean 1510 1511 ! --- evaporation minus precipitation --- ! 1512 emp_oce(:,:) = emp_tot(:,:) - emp_ice(:,:) 1513 1555 #if defined key_lim3 1514 1556 ! --- non solar flux over ocean --- ! 1515 1557 ! note: p_frld cannot be = 0 since we limit the ice concentration to amax … … 1517 1559 WHERE( p_frld /= 0._wp ) zqns_oce(:,:) = ( zqns_tot(:,:) - SUM( a_i * zqns_ice, dim=3 ) ) / p_frld(:,:) 1518 1560 1519 ! --- heat flux associated with emp --- ! 1520 zsnw(:,:) = 0._wp 1521 CALL lim_thd_snwblow( p_frld, zsnw ) ! snow distribution over ice after wind blowing 1561 ! --- heat flux associated with emp (W/m2) --- ! 1522 1562 zqemp_oce(:,:) = - zevap(:,:) * p_frld(:,:) * zcptn(:,:) & ! evap 1523 1563 & + ( ztprecip(:,:) - zsprecip(:,:) ) * zcptn(:,:) & ! liquid precip 1524 1564 & + zsprecip(:,:) * ( 1._wp - zsnw ) * ( zcptn(:,:) - lfus ) ! solid precip over ocean 1525 qemp_ice(:,:) = - frcv(jpr_ievp)%z3(:,:,1) * zicefr(:,:) * zcptn(:,:) & ! ice evap 1526 & + zsprecip(:,:) * zsnw * ( zcptn(:,:) - lfus ) ! solid precip over ice 1527 1565 ! zqemp_ice(:,:) = - frcv(jpr_ievp)%z3(:,:,1) * zicefr(:,:) * zcptn(:,:) & ! ice evap 1566 ! & + zsprecip(:,:) * zsnw * ( zcptn(:,:) - lfus ) ! solid precip over ice 1567 zqemp_ice(:,:) = zsprecip(:,:) * zsnw * ( zcptn(:,:) - lfus ) ! solid precip over ice (only) 1568 ! qevap_ice=0 since we consider Tice=0°C 1569 1528 1570 ! --- heat content of precip over ice in J/m3 (to be used in 1D-thermo) --- ! 1529 1571 zqprec_ice(:,:) = rhosn * ( zcptn(:,:) - lfus ) 1530 1572 1531 ! --- total non solar flux --- ! 1532 zqns_tot(:,:) = zqns_tot(:,:) + qemp_ice(:,:) + zqemp_oce(:,:) 1573 ! --- heat content of evap over ice in W/m2 (to be used in 1D-thermo) --- ! 1574 DO jl = 1, jpl 1575 zqevap_ice(:,:,jl) = 0._wp ! should be -evap * ( ( Tice - rt0 ) * cpic ) but we do not have Tice, so we consider Tice=0°C 1576 END DO 1577 1578 ! --- total non solar flux (including evap/precip) --- ! 1579 zqns_tot(:,:) = zqns_tot(:,:) + zqemp_ice(:,:) + zqemp_oce(:,:) 1533 1580 1534 1581 ! --- in case both coupled/forced are active, we must mix values --- ! … … 1537 1584 qns_oce(:,:) = qns_oce(:,:) * xcplmask(:,:,0) + zqns_oce(:,:)* zmsk(:,:) 1538 1585 DO jl=1,jpl 1539 qns_ice(:,:,jl) = qns_ice(:,:,jl) * xcplmask(:,:,0) + zqns_ice(:,:,jl)* zmsk(:,:) 1586 qns_ice (:,:,jl) = qns_ice (:,:,jl) * xcplmask(:,:,0) + zqns_ice (:,:,jl)* zmsk(:,:) 1587 qevap_ice(:,:,jl) = qevap_ice(:,:,jl) * xcplmask(:,:,0) + zqevap_ice(:,:,jl)* zmsk(:,:) 1540 1588 ENDDO 1541 1589 qprec_ice(:,:) = qprec_ice(:,:) * xcplmask(:,:,0) + zqprec_ice(:,:)* zmsk(:,:) 1542 1590 qemp_oce (:,:) = qemp_oce(:,:) * xcplmask(:,:,0) + zqemp_oce(:,:)* zmsk(:,:) 1543 !!clem evap_ice(:,:) = evap_ice(:,:) * xcplmask(:,:,0)1591 qemp_ice (:,:) = qemp_ice(:,:) * xcplmask(:,:,0) + zqemp_ice(:,:)* zmsk(:,:) 1544 1592 ELSE 1545 1593 qns_tot (:,: ) = zqns_tot (:,: ) 1546 1594 qns_oce (:,: ) = zqns_oce (:,: ) 1547 1595 qns_ice (:,:,:) = zqns_ice (:,:,:) 1548 q prec_ice(:,:) = zqprec_ice(:,:)1549 q emp_oce (:,:) = zqemp_oce (:,:)1550 ENDIF1551 1552 CALL wrk_dealloc( jpi,jpj, zevap, zsnw, zqns_oce, zqprec_ice, zqemp_oce )1596 qevap_ice(:,:,:) = zqevap_ice(:,:,:) 1597 qprec_ice(:,: ) = zqprec_ice(:,: ) 1598 qemp_oce (:,: ) = zqemp_oce (:,: ) 1599 qemp_ice (:,: ) = zqemp_ice (:,: ) 1600 ENDIF 1553 1601 #else 1554 !1555 1602 ! clem: this formulation is certainly wrong... but better than it was before... 1556 1603 zqns_tot(:,:) = zqns_tot(:,:) & ! zqns_tot update over free ocean with: … … 1619 1666 1620 1667 #if defined key_lim3 1621 CALL wrk_alloc( jpi,jpj, zqsr_oce )1622 1668 ! --- solar flux over ocean --- ! 1623 1669 ! note: p_frld cannot be = 0 since we limit the ice concentration to amax … … 1627 1673 IF( ln_mixcpl ) THEN ; qsr_oce(:,:) = qsr_oce(:,:) * xcplmask(:,:,0) + zqsr_oce(:,:)* zmsk(:,:) 1628 1674 ELSE ; qsr_oce(:,:) = zqsr_oce(:,:) ; ENDIF 1629 1630 CALL wrk_dealloc( jpi,jpj, zqsr_oce )1631 1675 #endif 1632 1676 … … 1679 1723 fr2_i0(:,:) = ( 0.82 * ( 1.0 - cldf_ice ) + 0.65 * cldf_ice ) 1680 1724 1681 CALL wrk_dealloc( jpi,jpj, zcptn, ztmp, zicefr, zmsk, zemp_tot, zemp_ice, zsprecip, ztprecip, zqns_tot, zqsr_tot ) 1682 CALL wrk_dealloc( jpi,jpj,jpl, zqns_ice, zqsr_ice, zdqns_ice ) 1725 CALL wrk_dealloc( jpi,jpj, zcptn, ztmp, zicefr, zmsk, zsnw ) 1726 CALL wrk_dealloc( jpi,jpj, zemp_tot, zemp_ice, zemp_oce, ztprecip, zsprecip, zevap, zevap_ice, zdevap_ice ) 1727 CALL wrk_dealloc( jpi,jpj, zqns_tot, zqns_oce, zqsr_tot, zqsr_oce, zqprec_ice, zqemp_oce, zqemp_ice ) 1728 CALL wrk_dealloc( jpi,jpj,jpl, zqns_ice, zqsr_ice, zdqns_ice, zqevap_ice ) 1683 1729 ! 1684 1730 IF( nn_timing == 1 ) CALL timing_stop('sbc_cpl_ice_flx') … … 1719 1765 1720 1766 IF ( nn_components == jp_iam_opa ) THEN 1721 ztmp1(:,:) = tsn(:,:,1,jp_tem) ! send temperature as it is (potential or conservative) -> use of l n_useCT on the received part1767 ztmp1(:,:) = tsn(:,:,1,jp_tem) ! send temperature as it is (potential or conservative) -> use of l_useCT on the received part 1722 1768 ELSE 1723 1769 ! we must send the surface potential temperature 1724 IF( l n_useCT ) THEN ; ztmp1(:,:) = eos_pt_from_ct( tsn(:,:,1,jp_tem), tsn(:,:,1,jp_sal) )1770 IF( l_useCT ) THEN ; ztmp1(:,:) = eos_pt_from_ct( tsn(:,:,1,jp_tem), tsn(:,:,1,jp_sal) ) 1725 1771 ELSE ; ztmp1(:,:) = tsn(:,:,1,jp_tem) 1726 1772 ENDIF -
branches/2016/dev_CNRS_2016/NEMOGCM/NEMO/OPA_SRC/SBC/sbcice_lim.F90
r6403 r7278 106 106 INTEGER :: jl ! dummy loop index 107 107 REAL(wp), POINTER, DIMENSION(:,:,:) :: zalb_os, zalb_cs ! ice albedo under overcast/clear sky 108 REAL(wp), POINTER, DIMENSION(:,:,:) :: zalb_ice ! mean ice albedo (for coupled)109 108 REAL(wp), POINTER, DIMENSION(:,: ) :: zutau_ice, zvtau_ice 110 109 !!---------------------------------------------------------------------- … … 193 192 ! fr1_i0 , fr2_i0 : 1sr & 2nd fraction of qsr penetration in ice [%] 194 193 !---------------------------------------------------------------------------------------- 195 CALL wrk_alloc( jpi,jpj,jpl, zalb_os, zalb_cs , zalb_ice)194 CALL wrk_alloc( jpi,jpj,jpl, zalb_os, zalb_cs ) 196 195 CALL albedo_ice( t_su, ht_i, ht_s, zalb_cs, zalb_os ) ! cloud-sky and overcast-sky ice albedos 197 196 … … 199 198 CASE( jp_clio ) ! CLIO bulk formulation 200 199 ! In CLIO the cloud fraction is read in the climatology and the all-sky albedo 201 ! ( zalb_ice) is computed within the bulk routine202 CALL blk_ice_clio_flx( t_su, zalb_cs, zalb_os, zalb_ice )203 IF( ln_mixcpl ) CALL sbc_cpl_ice_flx( p_frld=pfrld, palbi= zalb_ice, psst=sst_m, pist=t_su )204 IF( nn_limflx /= 2 ) CALL ice_lim_flx( t_su, zalb_ice, qns_ice, qsr_ice, dqns_ice, evap_ice, devap_ice, nn_limflx )200 ! (alb_ice) is computed within the bulk routine 201 CALL blk_ice_clio_flx( t_su, zalb_cs, zalb_os, alb_ice ) 202 IF( ln_mixcpl ) CALL sbc_cpl_ice_flx( p_frld=pfrld, palbi=alb_ice, psst=sst_m, pist=t_su ) 203 IF( nn_limflx /= 2 ) CALL ice_lim_flx( t_su, alb_ice, qns_ice, qsr_ice, dqns_ice, evap_ice, devap_ice, nn_limflx ) 205 204 CASE( jp_core ) ! CORE bulk formulation 206 205 ! albedo depends on cloud fraction because of non-linear spectral effects 207 zalb_ice(:,:,:) = ( 1. - cldf_ice ) * zalb_cs(:,:,:) + cldf_ice * zalb_os(:,:,:)208 CALL blk_ice_core_flx( t_su, zalb_ice )209 IF( ln_mixcpl ) CALL sbc_cpl_ice_flx( p_frld=pfrld, palbi= zalb_ice, psst=sst_m, pist=t_su )210 IF( nn_limflx /= 2 ) CALL ice_lim_flx( t_su, zalb_ice, qns_ice, qsr_ice, dqns_ice, evap_ice, devap_ice, nn_limflx )206 alb_ice(:,:,:) = ( 1. - cldf_ice ) * zalb_cs(:,:,:) + cldf_ice * zalb_os(:,:,:) 207 CALL blk_ice_core_flx( t_su, alb_ice ) 208 IF( ln_mixcpl ) CALL sbc_cpl_ice_flx( p_frld=pfrld, palbi=alb_ice, psst=sst_m, pist=t_su ) 209 IF( nn_limflx /= 2 ) CALL ice_lim_flx( t_su, alb_ice, qns_ice, qsr_ice, dqns_ice, evap_ice, devap_ice, nn_limflx ) 211 210 CASE ( jp_purecpl ) 212 211 ! albedo depends on cloud fraction because of non-linear spectral effects 213 zalb_ice(:,:,:) = ( 1. - cldf_ice ) * zalb_cs(:,:,:) + cldf_ice * zalb_os(:,:,:) 214 CALL sbc_cpl_ice_flx( p_frld=pfrld, palbi=zalb_ice, psst=sst_m, pist=t_su ) 215 ! clem: evap_ice is forced to 0 in coupled mode for now 216 ! but it needs to be changed (along with modif in limthd_dh) once heat flux from evap will be avail. from atm. models 217 evap_ice (:,:,:) = 0._wp ; devap_ice (:,:,:) = 0._wp 218 IF( nn_limflx == 2 ) CALL ice_lim_flx( t_su, zalb_ice, qns_ice, qsr_ice, dqns_ice, evap_ice, devap_ice, nn_limflx ) 212 alb_ice(:,:,:) = ( 1. - cldf_ice ) * zalb_cs(:,:,:) + cldf_ice * zalb_os(:,:,:) 213 CALL sbc_cpl_ice_flx( p_frld=pfrld, palbi=alb_ice, psst=sst_m, pist=t_su ) 214 IF( nn_limflx == 2 ) CALL ice_lim_flx( t_su, alb_ice, qns_ice, qsr_ice, dqns_ice, evap_ice, devap_ice, nn_limflx ) 219 215 END SELECT 220 CALL wrk_dealloc( jpi,jpj,jpl, zalb_os, zalb_cs , zalb_ice)216 CALL wrk_dealloc( jpi,jpj,jpl, zalb_os, zalb_cs ) 221 217 222 218 !----------------------------! … … 577 573 sfx_bog(:,:) = 0._wp ; sfx_dyn(:,:) = 0._wp 578 574 sfx_bom(:,:) = 0._wp ; sfx_sum(:,:) = 0._wp 579 sfx_res(:,:) = 0._wp 575 sfx_res(:,:) = 0._wp ; sfx_sub(:,:) = 0._wp 580 576 ! 581 577 wfx_snw(:,:) = 0._wp ; wfx_ice(:,:) = 0._wp … … 593 589 hfx_spr(:,:) = 0._wp ; hfx_dif(:,:) = 0._wp 594 590 hfx_err(:,:) = 0._wp ; hfx_err_rem(:,:) = 0._wp 595 hfx_err_dif(:,:) = 0._wp ; 591 hfx_err_dif(:,:) = 0._wp 592 wfx_err_sub(:,:) = 0._wp 596 593 ! 597 594 afx_tot(:,:) = 0._wp ; -
branches/2016/dev_CNRS_2016/NEMOGCM/NEMO/OPA_SRC/SBC/sbcmod.F90
r7277 r7278 323 323 emp_b (:,:) = emp (:,:) 324 324 sfx_b (:,:) = sfx (:,:) 325 IF ( ln_rnf ) THEN 326 rnf_b (:,: ) = rnf (:,: ) 327 rnf_tsc_b(:,:,:) = rnf_tsc(:,:,:) 328 ENDIF 325 329 ENDIF 326 330 ! ! ---------------------------------------- ! -
branches/2016/dev_CNRS_2016/NEMOGCM/NEMO/OPA_SRC/SBC/sbcrnf.F90
r7277 r7278 109 109 ! 110 110 CALL wrk_alloc( jpi,jpj, ztfrz) 111 112 ! ! ---------------------------------------- ! 113 IF( kt /= nit000 ) THEN ! Swap of forcing fields ! 114 ! ! ---------------------------------------- ! 115 rnf_b (:,: ) = rnf (:,: ) ! Swap the ocean forcing fields except at nit000 116 rnf_tsc_b(:,:,:) = rnf_tsc(:,:,:) ! where before fields are set at the end of the routine 117 ! 118 ENDIF 119 111 ! 120 112 ! !-------------------! 121 113 ! ! Update runoff ! -
branches/2016/dev_CNRS_2016/NEMOGCM/NEMO/OPA_SRC/SBC/sbcssm.F90
r7277 r7278 70 70 ssu_m(:,:) = ub(:,:,1) 71 71 ssv_m(:,:) = vb(:,:,1) 72 IF( l n_useCT ) THEN ; sst_m(:,:) = eos_pt_from_ct( zts(:,:,jp_tem), zts(:,:,jp_sal) )72 IF( l_useCT ) THEN ; sst_m(:,:) = eos_pt_from_ct( zts(:,:,jp_tem), zts(:,:,jp_sal) ) 73 73 ELSE ; sst_m(:,:) = zts(:,:,jp_tem) 74 74 ENDIF … … 92 92 ssu_m(:,:) = zcoef * ub(:,:,1) 93 93 ssv_m(:,:) = zcoef * vb(:,:,1) 94 IF( l n_useCT ) THEN ; sst_m(:,:) = zcoef * eos_pt_from_ct( zts(:,:,jp_tem), zts(:,:,jp_sal) )94 IF( l_useCT ) THEN ; sst_m(:,:) = zcoef * eos_pt_from_ct( zts(:,:,jp_tem), zts(:,:,jp_sal) ) 95 95 ELSE ; sst_m(:,:) = zcoef * zts(:,:,jp_tem) 96 96 ENDIF … … 120 120 ssu_m(:,:) = ssu_m(:,:) + ub(:,:,1) 121 121 ssv_m(:,:) = ssv_m(:,:) + vb(:,:,1) 122 IF( l n_useCT ) THEN ; sst_m(:,:) = sst_m(:,:) + eos_pt_from_ct( zts(:,:,jp_tem), zts(:,:,jp_sal) )122 IF( l_useCT ) THEN ; sst_m(:,:) = sst_m(:,:) + eos_pt_from_ct( zts(:,:,jp_tem), zts(:,:,jp_sal) ) 123 123 ELSE ; sst_m(:,:) = sst_m(:,:) + zts(:,:,jp_tem) 124 124 ENDIF … … 241 241 ssu_m(:,:) = ub(:,:,1) 242 242 ssv_m(:,:) = vb(:,:,1) 243 IF( l n_useCT ) THEN ; sst_m(:,:) = eos_pt_from_ct( tsn(:,:,1,jp_tem), tsn(:,:,1,jp_sal) )243 IF( l_useCT ) THEN ; sst_m(:,:) = eos_pt_from_ct( tsn(:,:,1,jp_tem), tsn(:,:,1,jp_sal) ) 244 244 ELSE ; sst_m(:,:) = tsn(:,:,1,jp_tem) 245 245 ENDIF -
branches/2016/dev_CNRS_2016/NEMOGCM/NEMO/OPA_SRC/TRA/eosbn2.F90
r7277 r7278 75 75 76 76 ! !!** Namelist nameos ** 77 INTEGER , PUBLIC :: nn_eos ! = 0/1/2 type of eq. of state and Brunt-Vaisala frequ. 78 LOGICAL , PUBLIC :: ln_useCT ! determine if eos_pt_from_ct is used to compute sst_m 77 LOGICAL , PUBLIC :: ln_TEOS10 ! determine if eos_pt_from_ct is used to compute sst_m 78 LOGICAL , PUBLIC :: ln_EOS80 ! determine if eos_pt_from_ct is used to compute sst_m 79 LOGICAL , PUBLIC :: ln_SEOS ! determine if eos_pt_from_ct is used to compute sst_m 80 81 ! Parameters 82 LOGICAL , PUBLIC :: l_useCT ! =T in ln_TEOS10=T (i.e. use eos_pt_from_ct to compute sst_m), =F otherwise 83 INTEGER , PUBLIC :: neos ! Identifier for equation of state used 84 85 INTEGER , PARAMETER :: np_teos10 = -1 ! parameter for using TEOS10 86 INTEGER , PARAMETER :: np_eos80 = 0 ! parameter for using EOS80 87 INTEGER , PARAMETER :: np_seos = 1 ! parameter for using Simplified Equation of state 79 88 80 89 ! !!! simplified eos coefficients (default value: Vallis 2006) … … 184 193 !! ** Purpose : Compute the in situ density (ratio rho/rau0) from 185 194 !! potential temperature and salinity using an equation of state 186 !! defined through the namelist parameter nn_eos.195 !! selected in the nameos namelist 187 196 !! 188 197 !! ** Method : prd(t,s,z) = ( rho(t,s,z) - rau0 ) / rau0 … … 194 203 !! rau0 reference density kg/m^3 195 204 !! 196 !! nn_eos = -1: polynomial TEOS-10 equation of state is used for rho(t,s,z).205 !! ln_teos10 : polynomial TEOS-10 equation of state is used for rho(t,s,z). 197 206 !! Check value: rho = 1028.21993233072 kg/m^3 for z=3000 dbar, ct=3 Celsius, sa=35.5 g/kg 198 207 !! 199 !! nn_eos =0 : polynomial EOS-80 equation of state is used for rho(t,s,z).208 !! ln_eos80 : polynomial EOS-80 equation of state is used for rho(t,s,z). 200 209 !! Check value: rho = 1028.35011066567 kg/m^3 for z=3000 dbar, pt=3 Celsius, sp=35.5 psu 201 210 !! 202 !! nn_eos = 1: simplified equation of state211 !! ln_seos : simplified equation of state 203 212 !! prd(t,s,z) = ( -a0*(1+lambda/2*(T-T0)+mu*z+nu*(S-S0))*(T-T0) + b0*(S-S0) ) / rau0 204 213 !! linear case function of T only: rn_alpha<>0, other coefficients = 0 … … 224 233 IF( nn_timing == 1 ) CALL timing_start('eos-insitu') 225 234 ! 226 SELECT CASE( n n_eos )227 ! 228 CASE( -1,0 ) !== polynomial TEOS-10 / EOS-80 ==!235 SELECT CASE( neos ) 236 ! 237 CASE( np_teos10, np_eos80 ) !== polynomial TEOS-10 / EOS-80 ==! 229 238 ! 230 239 DO jk = 1, jpkm1 … … 266 275 END DO 267 276 ! 268 CASE( 1) !== simplified EOS ==!277 CASE( np_seos ) !== simplified EOS ==! 269 278 ! 270 279 DO jk = 1, jpkm1 … … 300 309 !! ** Purpose : Compute the in situ density (ratio rho/rau0) and the 301 310 !! potential volumic mass (Kg/m3) from potential temperature and 302 !! salinity fields using an equation of state defined throughthe303 !! namelist parameter nn_eos.311 !! salinity fields using an equation of state selected in the 312 !! namelist. 304 313 !! 305 314 !! ** Action : - prd , the in situ density (no units) … … 322 331 IF( nn_timing == 1 ) CALL timing_start('eos-pot') 323 332 ! 324 SELECT CASE ( n n_eos )325 ! 326 CASE( -1,0 ) !== polynomial TEOS-10 / EOS-80 ==!333 SELECT CASE ( neos ) 334 ! 335 CASE( np_teos10, np_eos80 ) !== polynomial TEOS-10 / EOS-80 ==! 327 336 ! 328 337 ! Stochastic equation of state … … 430 439 ENDIF 431 440 432 CASE( 1) !== simplified EOS ==!441 CASE( np_seos ) !== simplified EOS ==! 433 442 ! 434 443 DO jk = 1, jpkm1 … … 467 476 !! ** Purpose : Compute the in situ density (ratio rho/rau0) from 468 477 !! potential temperature and salinity using an equation of state 469 !! defined through the namelist parameter nn_eos. * 2D field case478 !! selected in the nameos namelist. * 2D field case 470 479 !! 471 480 !! ** Action : - prd , the in situ density (no units) (unmasked) … … 486 495 prd(:,:) = 0._wp 487 496 ! 488 SELECT CASE( n n_eos )489 ! 490 CASE( -1,0 ) !== polynomial TEOS-10 / EOS-80 ==!497 SELECT CASE( neos ) 498 ! 499 CASE( np_teos10, np_eos80 ) !== polynomial TEOS-10 / EOS-80 ==! 491 500 ! 492 501 DO jj = 1, jpjm1 … … 527 536 CALL lbc_lnk( prd, 'T', 1. ) ! Lateral boundary conditions 528 537 ! 529 CASE( 1) !== simplified EOS ==!538 CASE( np_seos ) !== simplified EOS ==! 530 539 ! 531 540 DO jj = 1, jpjm1 … … 576 585 IF( nn_timing == 1 ) CALL timing_start('rab_3d') 577 586 ! 578 SELECT CASE ( n n_eos )579 ! 580 CASE( -1,0 ) !== polynomial TEOS-10 / EOS-80 ==!587 SELECT CASE ( neos ) 588 ! 589 CASE( np_teos10, np_eos80 ) !== polynomial TEOS-10 / EOS-80 ==! 581 590 ! 582 591 DO jk = 1, jpkm1 … … 635 644 END DO 636 645 ! 637 CASE( 1) !== simplified EOS ==!646 CASE( np_seos ) !== simplified EOS ==! 638 647 ! 639 648 DO jk = 1, jpkm1 … … 657 666 CASE DEFAULT 658 667 IF(lwp) WRITE(numout,cform_err) 659 IF(lwp) WRITE(numout,*) ' bad flag value for n n_eos = ', nn_eos668 IF(lwp) WRITE(numout,*) ' bad flag value for neos = ', neos 660 669 nstop = nstop + 1 661 670 ! … … 668 677 ! 669 678 END SUBROUTINE rab_3d 679 670 680 671 681 SUBROUTINE rab_2d( pts, pdep, pab ) … … 690 700 pab(:,:,:) = 0._wp 691 701 ! 692 SELECT CASE ( n n_eos )693 ! 694 CASE( -1,0 ) !== polynomial TEOS-10 / EOS-80 ==!702 SELECT CASE ( neos ) 703 ! 704 CASE( np_teos10, np_eos80 ) !== polynomial TEOS-10 / EOS-80 ==! 695 705 ! 696 706 DO jj = 1, jpjm1 … … 750 760 CALL lbc_lnk( pab(:,:,jp_sal), 'T', 1. ) 751 761 ! 752 CASE( 1) !== simplified EOS ==!762 CASE( np_seos ) !== simplified EOS ==! 753 763 ! 754 764 DO jj = 1, jpjm1 … … 773 783 CASE DEFAULT 774 784 IF(lwp) WRITE(numout,cform_err) 775 IF(lwp) WRITE(numout,*) ' bad flag value for n n_eos = ', nn_eos785 IF(lwp) WRITE(numout,*) ' bad flag value for neos = ', neos 776 786 nstop = nstop + 1 777 787 ! … … 806 816 pab(:) = 0._wp 807 817 ! 808 SELECT CASE ( n n_eos )809 ! 810 CASE( -1, 0 )!== polynomial TEOS-10 / EOS-80 ==!818 SELECT CASE ( neos ) 819 ! 820 CASE( np_teos10, np_eos80 ) !== polynomial TEOS-10 / EOS-80 ==! 811 821 ! 812 822 ! … … 859 869 ! 860 870 ! 861 CASE( 1) !== simplified EOS ==!871 CASE( np_seos ) !== simplified EOS ==! 862 872 ! 863 873 zt = pts(jp_tem) - 10._wp ! pot. temperature anomaly (t-T0) 864 874 zs = pts(jp_sal) - 35._wp ! abs. salinity anomaly (s-S0) 865 zh = pdep 875 zh = pdep ! depth at the partial step level 866 876 ! 867 877 zn = rn_a0 * ( 1._wp + rn_lambda1*zt + rn_mu1*zh ) + rn_nu*zs … … 873 883 CASE DEFAULT 874 884 IF(lwp) WRITE(numout,cform_err) 875 IF(lwp) WRITE(numout,*) ' bad flag value for n n_eos = ', nn_eos885 IF(lwp) WRITE(numout,*) ' bad flag value for neos = ', neos 876 886 nstop = nstop + 1 877 887 ! … … 1005 1015 REAL(wp), DIMENSION(jpi,jpj), INTENT(out ) :: ptf ! freezing temperature [Celsius] 1006 1016 ! 1007 INTEGER :: ji, jj ! dummy loop indices 1008 REAL(wp) :: zt, zs ! local scalars 1009 !!---------------------------------------------------------------------- 1010 ! 1011 SELECT CASE ( nn_eos ) 1012 ! 1013 CASE ( -1, 1 ) !== CT,SA (TEOS-10 formulation) ==! 1014 ! 1017 INTEGER :: ji, jj ! dummy loop indices 1018 REAL(wp) :: zt, zs, z1_S0 ! local scalars 1019 !!---------------------------------------------------------------------- 1020 ! 1021 SELECT CASE ( neos ) 1022 ! 1023 CASE ( np_teos10, np_seos ) !== CT,SA (TEOS-10 and S-EOS formulations) ==! 1024 ! 1025 z1_S0 = 1._wp / 35.16504_wp 1015 1026 DO jj = 1, jpj 1016 1027 DO ji = 1, jpi 1017 zs= SQRT( ABS( psal(ji,jj) ) * r1_S0 ) ! square root salinity1028 zs= SQRT( ABS( psal(ji,jj) ) * z1_S0 ) ! square root salinity 1018 1029 ptf(ji,jj) = ((((1.46873e-03_wp*zs-9.64972e-03_wp)*zs+2.28348e-02_wp)*zs & 1019 1030 & - 3.12775e-02_wp)*zs+2.07679e-02_wp)*zs-5.87701e-02_wp … … 1024 1035 IF( PRESENT( pdep ) ) ptf(:,:) = ptf(:,:) - 7.53e-4 * pdep(:,:) 1025 1036 ! 1026 CASE ( 0 )!== PT,SP (UNESCO formulation) ==!1037 CASE ( np_eos80 ) !== PT,SP (UNESCO formulation) ==! 1027 1038 ! 1028 1039 ptf(:,:) = ( - 0.0575_wp + 1.710523e-3_wp * SQRT( psal(:,:) ) & … … 1033 1044 CASE DEFAULT 1034 1045 IF(lwp) WRITE(numout,cform_err) 1035 IF(lwp) WRITE(numout,*) ' bad flag value for n n_eos = ', nn_eos1046 IF(lwp) WRITE(numout,*) ' bad flag value for neos = ', neos 1036 1047 nstop = nstop + 1 1037 1048 ! … … 1039 1050 ! 1040 1051 END SUBROUTINE eos_fzp_2d 1052 1041 1053 1042 1054 SUBROUTINE eos_fzp_0d( psal, ptf, pdep ) … … 1059 1071 !!---------------------------------------------------------------------- 1060 1072 ! 1061 SELECT CASE ( n n_eos )1062 ! 1063 CASE ( -1, 1 ) !== CT,SA (TEOS-10 formulation) ==!1064 ! 1065 zs = SQRT( ABS( psal ) * r1_S0) ! square root salinity1073 SELECT CASE ( neos ) 1074 ! 1075 CASE ( np_teos10, np_seos ) !== CT,SA (TEOS-10 and S-EOS formulations) ==! 1076 ! 1077 zs = SQRT( ABS( psal ) / 35.16504_wp ) ! square root salinity 1066 1078 ptf = ((((1.46873e-03_wp*zs-9.64972e-03_wp)*zs+2.28348e-02_wp)*zs & 1067 1079 & - 3.12775e-02_wp)*zs+2.07679e-02_wp)*zs-5.87701e-02_wp … … 1070 1082 IF( PRESENT( pdep ) ) ptf = ptf - 7.53e-4 * pdep 1071 1083 ! 1072 CASE ( 0 )!== PT,SP (UNESCO formulation) ==!1084 CASE ( np_eos80 ) !== PT,SP (UNESCO formulation) ==! 1073 1085 ! 1074 1086 ptf = ( - 0.0575_wp + 1.710523e-3_wp * SQRT( psal ) & … … 1079 1091 CASE DEFAULT 1080 1092 IF(lwp) WRITE(numout,cform_err) 1081 IF(lwp) WRITE(numout,*) ' bad flag value for n n_eos = ', nn_eos1093 IF(lwp) WRITE(numout,*) ' bad flag value for neos = ', neos 1082 1094 nstop = nstop + 1 1083 1095 ! … … 1118 1130 IF( nn_timing == 1 ) CALL timing_start('eos_pen') 1119 1131 ! 1120 SELECT CASE ( n n_eos )1121 ! 1122 CASE( -1,0 ) !== polynomial TEOS-10 / EOS-80 ==!1132 SELECT CASE ( neos ) 1133 ! 1134 CASE( np_teos10, np_eos80 ) !== polynomial TEOS-10 / EOS-80 ==! 1123 1135 ! 1124 1136 DO jk = 1, jpkm1 … … 1183 1195 END DO 1184 1196 ! 1185 CASE( 1) !== Vallis (2006) simplified EOS ==!1197 CASE( np_seos ) !== Vallis (2006) simplified EOS ==! 1186 1198 ! 1187 1199 DO jk = 1, jpkm1 … … 1205 1217 CASE DEFAULT 1206 1218 IF(lwp) WRITE(numout,cform_err) 1207 IF(lwp) WRITE(numout,*) ' bad flag value for n n_eos = ', nn_eos1219 IF(lwp) WRITE(numout,*) ' bad flag value for neos = ', neos 1208 1220 nstop = nstop + 1 1209 1221 ! … … 1224 1236 !!---------------------------------------------------------------------- 1225 1237 INTEGER :: ios ! local integer 1226 !! 1227 NAMELIST/nameos/ nn_eos, ln_useCT, rn_a0, rn_b0, rn_lambda1, rn_mu1, & 1238 INTEGER :: ioptio ! local integer 1239 !! 1240 NAMELIST/nameos/ ln_TEOS10, ln_EOS80, ln_SEOS, rn_a0, rn_b0, rn_lambda1, rn_mu1, & 1228 1241 & rn_lambda2, rn_mu2, rn_nu 1229 1242 !!---------------------------------------------------------------------- … … 1245 1258 WRITE(numout,*) 'eos_init : equation of state' 1246 1259 WRITE(numout,*) '~~~~~~~~' 1247 WRITE(numout,*) ' Namelist nameos : set eos parameters' 1248 WRITE(numout,*) ' flag for eq. of state and N^2 nn_eos = ', nn_eos 1249 IF( ln_useCT ) THEN 1250 WRITE(numout,*) ' model uses Conservative Temperature' 1251 WRITE(numout,*) ' Important: model must be initialized with CT and SA fields' 1252 ELSE 1253 WRITE(numout,*) ' model does not use Conservative Temperature' 1254 ENDIF 1260 WRITE(numout,*) ' Namelist nameos : Chosen the Equation Of Seawater (EOS)' 1261 WRITE(numout,*) ' TEOS-10 : rho=F(Conservative Temperature, Absolute Salinity, depth) ln_TEOS10 = ', ln_TEOS10 1262 WRITE(numout,*) ' EOS-80 : rho=F(Potential Temperature, Practical Salinity, depth) ln_EOS80 = ', ln_EOS80 1263 WRITE(numout,*) ' S-EOS : rho=F(Conservative Temperature, Absolute Salinity, depth) ln_SEOS = ', ln_SEOS 1255 1264 ENDIF 1256 ! 1257 SELECT CASE( nn_eos ) ! check option 1258 ! 1259 CASE( -1 ) !== polynomial TEOS-10 ==! 1265 1266 ! Check options for equation of state & set neos based on logical flags 1267 ioptio = 0 1268 IF( ln_TEOS10 ) THEN ; ioptio = ioptio+1 ; neos = np_teos10 ; ENDIF 1269 IF( ln_EOS80 ) THEN ; ioptio = ioptio+1 ; neos = np_eos80 ; ENDIF 1270 IF( ln_SEOS ) THEN ; ioptio = ioptio+1 ; neos = np_seos ; ENDIF 1271 IF( ioptio /= 1 ) CALL ctl_stop("Exactly one equation of state option must be selected") 1272 ! 1273 SELECT CASE( neos ) ! check option 1274 ! 1275 CASE( np_teos10 ) !== polynomial TEOS-10 ==! 1260 1276 IF(lwp) WRITE(numout,*) 1261 1277 IF(lwp) WRITE(numout,*) ' use of TEOS-10 equation of state (cons. temp. and abs. salinity)' 1278 ! 1279 l_useCT = .TRUE. ! model temperature is Conservative temperature 1262 1280 ! 1263 1281 rdeltaS = 32._wp … … 1446 1464 BPE002 = 1.7269476440e-04_wp 1447 1465 ! 1448 CASE( 0 ) !== polynomial EOS-80 formulation ==!1466 CASE( np_eos80 ) !== polynomial EOS-80 formulation ==! 1449 1467 ! 1450 1468 IF(lwp) WRITE(numout,*) 1451 1469 IF(lwp) WRITE(numout,*) ' use of EOS-80 equation of state (pot. temp. and pract. salinity)' 1452 1470 ! 1471 l_useCT = .FALSE. ! model temperature is Potential temperature 1453 1472 rdeltaS = 20._wp 1454 1473 r1_S0 = 1._wp/40._wp … … 1636 1655 BPE002 = 5.3661089288e-04_wp 1637 1656 ! 1638 CASE( 1) !== Simplified EOS ==!1657 CASE( np_seos ) !== Simplified EOS ==! 1639 1658 IF(lwp) THEN 1640 1659 WRITE(numout,*) … … 1651 1670 WRITE(numout,*) ' Caution: rn_beta0=0 incompatible with ddm parameterization ' 1652 1671 ENDIF 1653 ! 1654 CASE DEFAULT !== ERROR in nn_eos ==! 1655 WRITE(ctmp1,*) ' bad flag value for nn_eos = ', nn_eos 1672 l_useCT = .TRUE. ! Use conservative temperature 1673 ! 1674 CASE DEFAULT !== ERROR in neos ==! 1675 WRITE(ctmp1,*) ' bad flag value for neos = ', neos, '. You should never see this error' 1656 1676 CALL ctl_stop( ctmp1 ) 1657 1677 ! … … 1662 1682 r1_rcp = 1._wp / rcp 1663 1683 r1_rau0_rcp = 1._wp / rau0_rcp 1684 ! 1685 IF(lwp) THEN 1686 IF( l_useCT ) THEN 1687 WRITE(numout,*) ' model uses Conservative Temperature' 1688 WRITE(numout,*) ' Important: model must be initialized with CT and SA fields' 1689 ELSE 1690 WRITE(numout,*) ' model does not use Conservative Temperature' 1691 ENDIF 1692 ENDIF 1664 1693 ! 1665 1694 IF(lwp) WRITE(numout,*) -
branches/2016/dev_CNRS_2016/NEMOGCM/NEMO/OPA_SRC/TRA/trasbc.F90
r6140 r7278 111 111 ELSE ! No restart or restart not found: Euler forward time stepping 112 112 zfact = 1._wp 113 sbc_tsc(:,:,:) = 0._wp 113 114 sbc_tsc_b(:,:,:) = 0._wp 114 115 ENDIF … … 207 208 END DO 208 209 ENDIF 210 211 IF( iom_use('rnf_x_sst') ) CALL iom_put( "rnf_x_sst", rnf*tsn(:,:,1,jp_tem) ) ! runoff term on sst 212 IF( iom_use('rnf_x_sss') ) CALL iom_put( "rnf_x_sss", rnf*tsn(:,:,1,jp_sal) ) ! runoff term on sss 213 209 214 ! 210 215 !---------------------------------------- -
branches/2016/dev_CNRS_2016/NEMOGCM/NEMO/OPA_SRC/ZDF/zdfddm.F90
r6140 r7278 174 174 & + 0.15 * zrau(ji,jj) * zmskd2(ji,jj) ) 175 175 ! add to the eddy viscosity coef. previously computed 176 # if defined key_zdftmx_new 177 ! key_zdftmx_new: New internal wave-driven param: use avs value computed by zdftmx 178 avs (ji,jj,jk) = avs(ji,jj,jk) + zavfs + zavds 179 # else 176 180 avs (ji,jj,jk) = avt(ji,jj,jk) + zavfs + zavds 181 # endif 177 182 avt (ji,jj,jk) = avt(ji,jj,jk) + zavft + zavdt 178 183 avm (ji,jj,jk) = avm(ji,jj,jk) + MAX( zavft + zavdt, zavfs + zavds ) -
branches/2016/dev_CNRS_2016/NEMOGCM/NEMO/OPA_SRC/ZDF/zdfric.F90
r6140 r7278 31 31 USE lib_fortran ! Fortran utilities (allows no signed zero when 'key_nosignedzero' defined) 32 32 33 USE eosbn2, ONLY : n n_eos33 USE eosbn2, ONLY : neos 34 34 35 35 IMPLICIT NONE … … 175 175 ! Compute Ekman depth from wind stress forcing. 176 176 ! ------------------------------------------------------- 177 zflageos = ( 0.5 + SIGN( 0.5, n n_eos - 1. ) ) * rau0177 zflageos = ( 0.5 + SIGN( 0.5, neos - 1. ) ) * rau0 178 178 DO jj = 2, jpjm1 179 179 DO ji = fs_2, fs_jpim1 -
branches/2016/dev_CNRS_2016/NEMOGCM/NEMO/OPA_SRC/ZDF/zdftke.F90
r6140 r7278 323 323 zwlc = zind * rn_lc * zus * SIN( rpi * gdepw_n(ji,jj,jk) / zhlc(ji,jj) ) 324 324 ! ! TKE Langmuir circulation source term 325 en(ji,jj,jk) = en(ji,jj,jk) + rdt * (1._wp - fr_i(ji,jj) ) * ( zwlc * zwlc * zwlc ) / zhlc(ji,jj) * wmask(ji,jj,jk) * tmask(ji,jj,1) 325 en(ji,jj,jk) = en(ji,jj,jk) + rdt * (1._wp - fr_i(ji,jj) ) * ( zwlc * zwlc * zwlc ) & 326 & / zhlc(ji,jj) * wmask(ji,jj,jk) * tmask(ji,jj,1) 326 327 END DO 327 328 END DO … … 375 376 DO ji = fs_2, fs_jpim1 ! vector opt. 376 377 zcof = zfact1 * tmask(ji,jj,jk) 378 # if defined key_zdftmx_new 379 ! key_zdftmx_new: New internal wave-driven param: set a minimum value for Kz on TKE (ensure numerical stability) 380 zzd_up = zcof * MAX( avm(ji,jj,jk+1) + avm(ji,jj,jk), 2.e-5_wp ) & ! upper diagonal 381 & / ( e3t_n(ji,jj,jk ) * e3w_n(ji,jj,jk ) ) 382 zzd_lw = zcof * MAX( avm(ji,jj,jk) + avm(ji,jj,jk-1), 2.e-5_wp ) & ! lower diagonal 383 & / ( e3t_n(ji,jj,jk-1) * e3w_n(ji,jj,jk ) ) 384 # else 377 385 zzd_up = zcof * ( avm (ji,jj,jk+1) + avm (ji,jj,jk ) ) & ! upper diagonal 378 386 & / ( e3t_n(ji,jj,jk ) * e3w_n(ji,jj,jk ) ) 379 387 zzd_lw = zcof * ( avm (ji,jj,jk ) + avm (ji,jj,jk-1) ) & ! lower diagonal 380 388 & / ( e3t_n(ji,jj,jk-1) * e3w_n(ji,jj,jk ) ) 389 # endif 381 390 ! ! shear prod. at w-point weightened by mask 382 391 zesh2 = ( z3du(ji-1,jj,jk) + z3du(ji,jj,jk) ) / MAX( 1._wp , umask(ji-1,jj,jk) + umask(ji,jj,jk) ) & … … 732 741 ! 733 742 ri_cri = 2._wp / ( 2._wp + rn_ediss / rn_ediff ) ! resulting critical Richardson number 743 # if defined key_zdftmx_new 744 ! key_zdftmx_new: New internal wave-driven param: specified value of rn_emin & rmxl_min are used 745 rn_emin = 1.e-10_wp 746 rmxl_min = 1.e-03_wp 747 IF(lwp) THEN ! Control print 748 WRITE(numout,*) 749 WRITE(numout,*) 'zdf_tke_init : New tidal mixing case: force rn_emin = 1.e-10 and rmxl_min = 1.e-3 ' 750 WRITE(numout,*) '~~~~~~~~~~~~' 751 ENDIF 752 # else 734 753 rmxl_min = 1.e-6_wp / ( rn_ediff * SQRT( rn_emin ) ) ! resulting minimum length to recover molecular viscosity 754 # endif 735 755 ! 736 756 IF(lwp) THEN !* Control print -
branches/2016/dev_CNRS_2016/NEMOGCM/NEMO/OPA_SRC/ZDF/zdftmx.F90
r6140 r7278 541 541 END SUBROUTINE zdf_tmx_init 542 542 543 #elif defined key_zdftmx_new 544 !!---------------------------------------------------------------------- 545 !! 'key_zdftmx_new' Internal wave-driven vertical mixing 546 !!---------------------------------------------------------------------- 547 !! zdf_tmx : global momentum & tracer Kz with wave induced Kz 548 !! zdf_tmx_init : global momentum & tracer Kz with wave induced Kz 549 !!---------------------------------------------------------------------- 550 USE oce ! ocean dynamics and tracers variables 551 USE dom_oce ! ocean space and time domain variables 552 USE zdf_oce ! ocean vertical physics variables 553 USE zdfddm ! ocean vertical physics: double diffusive mixing 554 USE lbclnk ! ocean lateral boundary conditions (or mpp link) 555 USE eosbn2 ! ocean equation of state 556 USE phycst ! physical constants 557 USE prtctl ! Print control 558 USE in_out_manager ! I/O manager 559 USE iom ! I/O Manager 560 USE lib_mpp ! MPP library 561 USE wrk_nemo ! work arrays 562 USE timing ! Timing 563 USE lib_fortran ! Fortran utilities (allows no signed zero when 'key_nosignedzero' defined) 564 565 IMPLICIT NONE 566 PRIVATE 567 568 PUBLIC zdf_tmx ! called in step module 569 PUBLIC zdf_tmx_init ! called in nemogcm module 570 PUBLIC zdf_tmx_alloc ! called in nemogcm module 571 572 LOGICAL, PUBLIC, PARAMETER :: lk_zdftmx = .TRUE. !: wave-driven mixing flag 573 574 ! !!* Namelist namzdf_tmx : internal wave-driven mixing * 575 INTEGER :: nn_zpyc ! pycnocline-intensified mixing energy proportional to N (=1) or N^2 (=2) 576 LOGICAL :: ln_mevar ! variable (=T) or constant (=F) mixing efficiency 577 LOGICAL :: ln_tsdiff ! account for differential T/S wave-driven mixing (=T) or not (=F) 578 579 REAL(wp) :: r1_6 = 1._wp / 6._wp 580 581 REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:) :: ebot_tmx ! power available from high-mode wave breaking (W/m2) 582 REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:) :: epyc_tmx ! power available from low-mode, pycnocline-intensified wave breaking (W/m2) 583 REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:) :: ecri_tmx ! power available from low-mode, critical slope wave breaking (W/m2) 584 REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:) :: hbot_tmx ! WKB decay scale for high-mode energy dissipation (m) 585 REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:) :: hcri_tmx ! decay scale for low-mode critical slope dissipation (m) 586 REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: emix_tmx ! local energy density available for mixing (W/kg) 587 REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: bflx_tmx ! buoyancy flux Kz * N^2 (W/kg) 588 REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:) :: pcmap_tmx ! vertically integrated buoyancy flux (W/m2) 589 REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: zav_ratio ! S/T diffusivity ratio (only for ln_tsdiff=T) 590 REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: zav_wave ! Internal wave-induced diffusivity 591 592 !! * Substitutions 593 # include "zdfddm_substitute.h90" 594 # include "vectopt_loop_substitute.h90" 595 !!---------------------------------------------------------------------- 596 !! NEMO/OPA 4.0 , NEMO Consortium (2016) 597 !! $Id$ 598 !! Software governed by the CeCILL licence (NEMOGCM/NEMO_CeCILL.txt) 599 !!---------------------------------------------------------------------- 600 CONTAINS 601 602 INTEGER FUNCTION zdf_tmx_alloc() 603 !!---------------------------------------------------------------------- 604 !! *** FUNCTION zdf_tmx_alloc *** 605 !!---------------------------------------------------------------------- 606 ALLOCATE( ebot_tmx(jpi,jpj), epyc_tmx(jpi,jpj), ecri_tmx(jpi,jpj) , & 607 & hbot_tmx(jpi,jpj), hcri_tmx(jpi,jpj), emix_tmx(jpi,jpj,jpk), & 608 & bflx_tmx(jpi,jpj,jpk), pcmap_tmx(jpi,jpj), zav_ratio(jpi,jpj,jpk), & 609 & zav_wave(jpi,jpj,jpk), STAT=zdf_tmx_alloc ) 610 ! 611 IF( lk_mpp ) CALL mpp_sum ( zdf_tmx_alloc ) 612 IF( zdf_tmx_alloc /= 0 ) CALL ctl_warn('zdf_tmx_alloc: failed to allocate arrays') 613 END FUNCTION zdf_tmx_alloc 614 615 616 SUBROUTINE zdf_tmx( kt ) 617 !!---------------------------------------------------------------------- 618 !! *** ROUTINE zdf_tmx *** 619 !! 620 !! ** Purpose : add to the vertical mixing coefficients the effect of 621 !! breaking internal waves. 622 !! 623 !! ** Method : - internal wave-driven vertical mixing is given by: 624 !! Kz_wave = min( 100 cm2/s, f( Reb = emix_tmx /( Nu * N^2 ) ) 625 !! where emix_tmx is the 3D space distribution of the wave-breaking 626 !! energy and Nu the molecular kinematic viscosity. 627 !! The function f(Reb) is linear (constant mixing efficiency) 628 !! if the namelist parameter ln_mevar = F and nonlinear if ln_mevar = T. 629 !! 630 !! - Compute emix_tmx, the 3D power density that allows to compute 631 !! Reb and therefrom the wave-induced vertical diffusivity. 632 !! This is divided into three components: 633 !! 1. Bottom-intensified low-mode dissipation at critical slopes 634 !! emix_tmx(z) = ( ecri_tmx / rau0 ) * EXP( -(H-z)/hcri_tmx ) 635 !! / ( 1. - EXP( - H/hcri_tmx ) ) * hcri_tmx 636 !! where hcri_tmx is the characteristic length scale of the bottom 637 !! intensification, ecri_tmx a map of available power, and H the ocean depth. 638 !! 2. Pycnocline-intensified low-mode dissipation 639 !! emix_tmx(z) = ( epyc_tmx / rau0 ) * ( sqrt(rn2(z))^nn_zpyc ) 640 !! / SUM( sqrt(rn2(z))^nn_zpyc * e3w(z) ) 641 !! where epyc_tmx is a map of available power, and nn_zpyc 642 !! is the chosen stratification-dependence of the internal wave 643 !! energy dissipation. 644 !! 3. WKB-height dependent high mode dissipation 645 !! emix_tmx(z) = ( ebot_tmx / rau0 ) * rn2(z) * EXP(-z_wkb(z)/hbot_tmx) 646 !! / SUM( rn2(z) * EXP(-z_wkb(z)/hbot_tmx) * e3w(z) ) 647 !! where hbot_tmx is the characteristic length scale of the WKB bottom 648 !! intensification, ebot_tmx is a map of available power, and z_wkb is the 649 !! WKB-stretched height above bottom defined as 650 !! z_wkb(z) = H * SUM( sqrt(rn2(z'>=z)) * e3w(z'>=z) ) 651 !! / SUM( sqrt(rn2(z')) * e3w(z') ) 652 !! 653 !! - update the model vertical eddy viscosity and diffusivity: 654 !! avt = avt + av_wave 655 !! avm = avm + av_wave 656 !! avmu = avmu + mi(av_wave) 657 !! avmv = avmv + mj(av_wave) 658 !! 659 !! - if namelist parameter ln_tsdiff = T, account for differential mixing: 660 !! avs = avt + av_wave * diffusivity_ratio(Reb) 661 !! 662 !! ** Action : - Define emix_tmx used to compute internal wave-induced mixing 663 !! - avt, avs, avm, avmu, avmv increased by internal wave-driven mixing 664 !! 665 !! References : de Lavergne et al. 2015, JPO; 2016, in prep. 666 !!---------------------------------------------------------------------- 667 INTEGER, INTENT(in) :: kt ! ocean time-step 668 ! 669 INTEGER :: ji, jj, jk ! dummy loop indices 670 REAL(wp) :: ztpc ! scalar workspace 671 REAL(wp), DIMENSION(:,:) , POINTER :: zfact ! Used for vertical structure 672 REAL(wp), DIMENSION(:,:) , POINTER :: zhdep ! Ocean depth 673 REAL(wp), DIMENSION(:,:,:), POINTER :: zwkb ! WKB-stretched height above bottom 674 REAL(wp), DIMENSION(:,:,:), POINTER :: zweight ! Weight for high mode vertical distribution 675 REAL(wp), DIMENSION(:,:,:), POINTER :: znu_t ! Molecular kinematic viscosity (T grid) 676 REAL(wp), DIMENSION(:,:,:), POINTER :: znu_w ! Molecular kinematic viscosity (W grid) 677 REAL(wp), DIMENSION(:,:,:), POINTER :: zReb ! Turbulence intensity parameter 678 !!---------------------------------------------------------------------- 679 ! 680 IF( nn_timing == 1 ) CALL timing_start('zdf_tmx') 681 ! 682 CALL wrk_alloc( jpi,jpj, zfact, zhdep ) 683 CALL wrk_alloc( jpi,jpj,jpk, zwkb, zweight, znu_t, znu_w, zReb ) 684 685 ! ! ----------------------------- ! 686 ! ! Internal wave-driven mixing ! (compute zav_wave) 687 ! ! ----------------------------- ! 688 ! 689 ! !* Critical slope mixing: distribute energy over the time-varying ocean depth, 690 ! using an exponential decay from the seafloor. 691 DO jj = 1, jpj ! part independent of the level 692 DO ji = 1, jpi 693 zhdep(ji,jj) = gdepw_0(ji,jj,mbkt(ji,jj)+1) ! depth of the ocean 694 zfact(ji,jj) = rau0 * ( 1._wp - EXP( -zhdep(ji,jj) / hcri_tmx(ji,jj) ) ) 695 IF( zfact(ji,jj) /= 0 ) zfact(ji,jj) = ecri_tmx(ji,jj) / zfact(ji,jj) 696 END DO 697 END DO 698 699 DO jk = 2, jpkm1 ! complete with the level-dependent part 700 emix_tmx(:,:,jk) = zfact(:,:) * ( EXP( ( gde3w_n(:,:,jk ) - zhdep(:,:) ) / hcri_tmx(:,:) ) & 701 & - EXP( ( gde3w_n(:,:,jk-1) - zhdep(:,:) ) / hcri_tmx(:,:) ) ) * wmask(:,:,jk) & 702 & / ( gde3w_n(:,:,jk) - gde3w_n(:,:,jk-1) ) 703 END DO 704 705 ! !* Pycnocline-intensified mixing: distribute energy over the time-varying 706 ! !* ocean depth as proportional to sqrt(rn2)^nn_zpyc 707 708 SELECT CASE ( nn_zpyc ) 709 710 CASE ( 1 ) ! Dissipation scales as N (recommended) 711 712 zfact(:,:) = 0._wp 713 DO jk = 2, jpkm1 ! part independent of the level 714 zfact(:,:) = zfact(:,:) + e3w_n(:,:,jk) * SQRT( MAX( 0._wp, rn2(:,:,jk) ) ) * wmask(:,:,jk) 715 END DO 716 717 DO jj = 1, jpj 718 DO ji = 1, jpi 719 IF( zfact(ji,jj) /= 0 ) zfact(ji,jj) = epyc_tmx(ji,jj) / ( rau0 * zfact(ji,jj) ) 720 END DO 721 END DO 722 723 DO jk = 2, jpkm1 ! complete with the level-dependent part 724 emix_tmx(:,:,jk) = emix_tmx(:,:,jk) + zfact(:,:) * SQRT( MAX( 0._wp, rn2(:,:,jk) ) ) * wmask(:,:,jk) 725 END DO 726 727 CASE ( 2 ) ! Dissipation scales as N^2 728 729 zfact(:,:) = 0._wp 730 DO jk = 2, jpkm1 ! part independent of the level 731 zfact(:,:) = zfact(:,:) + e3w_n(:,:,jk) * MAX( 0._wp, rn2(:,:,jk) ) * wmask(:,:,jk) 732 END DO 733 734 DO jj= 1, jpj 735 DO ji = 1, jpi 736 IF( zfact(ji,jj) /= 0 ) zfact(ji,jj) = epyc_tmx(ji,jj) / ( rau0 * zfact(ji,jj) ) 737 END DO 738 END DO 739 740 DO jk = 2, jpkm1 ! complete with the level-dependent part 741 emix_tmx(:,:,jk) = emix_tmx(:,:,jk) + zfact(:,:) * MAX( 0._wp, rn2(:,:,jk) ) * wmask(:,:,jk) 742 END DO 743 744 END SELECT 745 746 ! !* WKB-height dependent mixing: distribute energy over the time-varying 747 ! !* ocean depth as proportional to rn2 * exp(-z_wkb/rn_hbot) 748 749 zwkb(:,:,:) = 0._wp 750 zfact(:,:) = 0._wp 751 DO jk = 2, jpkm1 752 zfact(:,:) = zfact(:,:) + e3w_n(:,:,jk) * SQRT( MAX( 0._wp, rn2(:,:,jk) ) ) * wmask(:,:,jk) 753 zwkb(:,:,jk) = zfact(:,:) 754 END DO 755 756 DO jk = 2, jpkm1 757 DO jj = 1, jpj 758 DO ji = 1, jpi 759 IF( zfact(ji,jj) /= 0 ) zwkb(ji,jj,jk) = zhdep(ji,jj) * ( zfact(ji,jj) - zwkb(ji,jj,jk) ) & 760 & * tmask(ji,jj,jk) / zfact(ji,jj) 761 END DO 762 END DO 763 END DO 764 zwkb(:,:,1) = zhdep(:,:) * tmask(:,:,1) 765 766 zweight(:,:,:) = 0._wp 767 DO jk = 2, jpkm1 768 zweight(:,:,jk) = MAX( 0._wp, rn2(:,:,jk) ) * hbot_tmx(:,:) * wmask(:,:,jk) & 769 & * ( EXP( -zwkb(:,:,jk) / hbot_tmx(:,:) ) - EXP( -zwkb(:,:,jk-1) / hbot_tmx(:,:) ) ) 770 END DO 771 772 zfact(:,:) = 0._wp 773 DO jk = 2, jpkm1 ! part independent of the level 774 zfact(:,:) = zfact(:,:) + zweight(:,:,jk) 775 END DO 776 777 DO jj = 1, jpj 778 DO ji = 1, jpi 779 IF( zfact(ji,jj) /= 0 ) zfact(ji,jj) = ebot_tmx(ji,jj) / ( rau0 * zfact(ji,jj) ) 780 END DO 781 END DO 782 783 DO jk = 2, jpkm1 ! complete with the level-dependent part 784 emix_tmx(:,:,jk) = emix_tmx(:,:,jk) + zweight(:,:,jk) * zfact(:,:) * wmask(:,:,jk) & 785 & / ( gde3w_n(:,:,jk) - gde3w_n(:,:,jk-1) ) 786 END DO 787 788 789 ! Calculate molecular kinematic viscosity 790 znu_t(:,:,:) = 1.e-4_wp * ( 17.91_wp - 0.53810_wp * tsn(:,:,:,jp_tem) + 0.00694_wp * tsn(:,:,:,jp_tem) * tsn(:,:,:,jp_tem) & 791 & + 0.02305_wp * tsn(:,:,:,jp_sal) ) * tmask(:,:,:) * r1_rau0 792 DO jk = 2, jpkm1 793 znu_w(:,:,jk) = 0.5_wp * ( znu_t(:,:,jk-1) + znu_t(:,:,jk) ) * wmask(:,:,jk) 794 END DO 795 796 ! Calculate turbulence intensity parameter Reb 797 DO jk = 2, jpkm1 798 zReb(:,:,jk) = emix_tmx(:,:,jk) / MAX( 1.e-20_wp, znu_w(:,:,jk) * rn2(:,:,jk) ) 799 END DO 800 801 ! Define internal wave-induced diffusivity 802 DO jk = 2, jpkm1 803 zav_wave(:,:,jk) = znu_w(:,:,jk) * zReb(:,:,jk) * r1_6 ! This corresponds to a constant mixing efficiency of 1/6 804 END DO 805 806 IF( ln_mevar ) THEN ! Variable mixing efficiency case : modify zav_wave in the 807 DO jk = 2, jpkm1 ! energetic (Reb > 480) and buoyancy-controlled (Reb <10.224 ) regimes 808 DO jj = 1, jpj 809 DO ji = 1, jpi 810 IF( zReb(ji,jj,jk) > 480.00_wp ) THEN 811 zav_wave(ji,jj,jk) = 3.6515_wp * znu_w(ji,jj,jk) * SQRT( zReb(ji,jj,jk) ) 812 ELSEIF( zReb(ji,jj,jk) < 10.224_wp ) THEN 813 zav_wave(ji,jj,jk) = 0.052125_wp * znu_w(ji,jj,jk) * zReb(ji,jj,jk) * SQRT( zReb(ji,jj,jk) ) 814 ENDIF 815 END DO 816 END DO 817 END DO 818 ENDIF 819 820 DO jk = 2, jpkm1 ! Bound diffusivity by molecular value and 100 cm2/s 821 zav_wave(:,:,jk) = MIN( MAX( 1.4e-7_wp, zav_wave(:,:,jk) ), 1.e-2_wp ) * wmask(:,:,jk) 822 END DO 823 824 IF( kt == nit000 ) THEN !* Control print at first time-step: diagnose the energy consumed by zav_wave 825 ztpc = 0._wp 826 DO jk = 2, jpkm1 827 DO jj = 1, jpj 828 DO ji = 1, jpi 829 ztpc = ztpc + e3w_n(ji,jj,jk) * e1e2t(ji,jj) & 830 & * MAX( 0._wp, rn2(ji,jj,jk) ) * zav_wave(ji,jj,jk) * wmask(ji,jj,jk) * tmask_i(ji,jj) 831 END DO 832 END DO 833 END DO 834 IF( lk_mpp ) CALL mpp_sum( ztpc ) 835 ztpc = rau0 * ztpc ! Global integral of rauo * Kz * N^2 = power contributing to mixing 836 837 IF(lwp) THEN 838 WRITE(numout,*) 839 WRITE(numout,*) 'zdf_tmx : Internal wave-driven mixing (tmx)' 840 WRITE(numout,*) '~~~~~~~ ' 841 WRITE(numout,*) 842 WRITE(numout,*) ' Total power consumption by av_wave: ztpc = ', ztpc * 1.e-12_wp, 'TW' 843 ENDIF 844 ENDIF 845 846 ! ! ----------------------- ! 847 ! ! Update mixing coefs ! 848 ! ! ----------------------- ! 849 ! 850 IF( ln_tsdiff ) THEN !* Option for differential mixing of salinity and temperature 851 DO jk = 2, jpkm1 ! Calculate S/T diffusivity ratio as a function of Reb 852 DO jj = 1, jpj 853 DO ji = 1, jpi 854 zav_ratio(ji,jj,jk) = ( 0.505_wp + 0.495_wp * & 855 & TANH( 0.92_wp * ( LOG10( MAX( 1.e-20_wp, zReb(ji,jj,jk) * 5._wp * r1_6 ) ) - 0.60_wp ) ) & 856 & ) * wmask(ji,jj,jk) 857 END DO 858 END DO 859 END DO 860 CALL iom_put( "av_ratio", zav_ratio ) 861 DO jk = 2, jpkm1 !* update momentum & tracer diffusivity with wave-driven mixing 862 fsavs(:,:,jk) = avt(:,:,jk) + zav_wave(:,:,jk) * zav_ratio(:,:,jk) 863 avt (:,:,jk) = avt(:,:,jk) + zav_wave(:,:,jk) 864 avm (:,:,jk) = avm(:,:,jk) + zav_wave(:,:,jk) 865 END DO 866 ! 867 ELSE !* update momentum & tracer diffusivity with wave-driven mixing 868 DO jk = 2, jpkm1 869 fsavs(:,:,jk) = avt(:,:,jk) + zav_wave(:,:,jk) 870 avt (:,:,jk) = avt(:,:,jk) + zav_wave(:,:,jk) 871 avm (:,:,jk) = avm(:,:,jk) + zav_wave(:,:,jk) 872 END DO 873 ENDIF 874 875 DO jk = 2, jpkm1 !* update momentum diffusivity at wu and wv points 876 DO jj = 2, jpjm1 877 DO ji = fs_2, fs_jpim1 ! vector opt. 878 avmu(ji,jj,jk) = avmu(ji,jj,jk) + 0.5_wp * ( zav_wave(ji,jj,jk) + zav_wave(ji+1,jj ,jk) ) * wumask(ji,jj,jk) 879 avmv(ji,jj,jk) = avmv(ji,jj,jk) + 0.5_wp * ( zav_wave(ji,jj,jk) + zav_wave(ji ,jj+1,jk) ) * wvmask(ji,jj,jk) 880 END DO 881 END DO 882 END DO 883 CALL lbc_lnk( avmu, 'U', 1. ) ; CALL lbc_lnk( avmv, 'V', 1. ) ! lateral boundary condition 884 885 ! !* output internal wave-driven mixing coefficient 886 CALL iom_put( "av_wave", zav_wave ) 887 !* output useful diagnostics: N^2, Kz * N^2 (bflx_tmx), 888 ! vertical integral of rau0 * Kz * N^2 (pcmap_tmx), energy density (emix_tmx) 889 IF( iom_use("bflx_tmx") .OR. iom_use("pcmap_tmx") ) THEN 890 bflx_tmx(:,:,:) = MAX( 0._wp, rn2(:,:,:) ) * zav_wave(:,:,:) 891 pcmap_tmx(:,:) = 0._wp 892 DO jk = 2, jpkm1 893 pcmap_tmx(:,:) = pcmap_tmx(:,:) + e3w_n(:,:,jk) * bflx_tmx(:,:,jk) * wmask(:,:,jk) 894 END DO 895 pcmap_tmx(:,:) = rau0 * pcmap_tmx(:,:) 896 CALL iom_put( "bflx_tmx", bflx_tmx ) 897 CALL iom_put( "pcmap_tmx", pcmap_tmx ) 898 ENDIF 899 CALL iom_put( "bn2", rn2 ) 900 CALL iom_put( "emix_tmx", emix_tmx ) 901 902 CALL wrk_dealloc( jpi,jpj, zfact, zhdep ) 903 CALL wrk_dealloc( jpi,jpj,jpk, zwkb, zweight, znu_t, znu_w, zReb ) 904 905 IF(ln_ctl) CALL prt_ctl(tab3d_1=zav_wave , clinfo1=' tmx - av_wave: ', tab3d_2=avt, clinfo2=' avt: ', ovlap=1, kdim=jpk) 906 ! 907 IF( nn_timing == 1 ) CALL timing_stop('zdf_tmx') 908 ! 909 END SUBROUTINE zdf_tmx 910 911 912 SUBROUTINE zdf_tmx_init 913 !!---------------------------------------------------------------------- 914 !! *** ROUTINE zdf_tmx_init *** 915 !! 916 !! ** Purpose : Initialization of the wave-driven vertical mixing, reading 917 !! of input power maps and decay length scales in netcdf files. 918 !! 919 !! ** Method : - Read the namzdf_tmx namelist and check the parameters 920 !! 921 !! - Read the input data in NetCDF files : 922 !! power available from high-mode wave breaking (mixing_power_bot.nc) 923 !! power available from pycnocline-intensified wave-breaking (mixing_power_pyc.nc) 924 !! power available from critical slope wave-breaking (mixing_power_cri.nc) 925 !! WKB decay scale for high-mode wave-breaking (decay_scale_bot.nc) 926 !! decay scale for critical slope wave-breaking (decay_scale_cri.nc) 927 !! 928 !! ** input : - Namlist namzdf_tmx 929 !! - NetCDF files : mixing_power_bot.nc, mixing_power_pyc.nc, mixing_power_cri.nc, 930 !! decay_scale_bot.nc decay_scale_cri.nc 931 !! 932 !! ** Action : - Increase by 1 the nstop flag is setting problem encounter 933 !! - Define ebot_tmx, epyc_tmx, ecri_tmx, hbot_tmx, hcri_tmx 934 !! 935 !! References : de Lavergne et al. 2015, JPO; 2016, in prep. 936 !! 937 !!---------------------------------------------------------------------- 938 INTEGER :: ji, jj, jk ! dummy loop indices 939 INTEGER :: inum ! local integer 940 INTEGER :: ios 941 REAL(wp) :: zbot, zpyc, zcri ! local scalars 942 !! 943 NAMELIST/namzdf_tmx_new/ nn_zpyc, ln_mevar, ln_tsdiff 944 !!---------------------------------------------------------------------- 945 ! 946 IF( nn_timing == 1 ) CALL timing_start('zdf_tmx_init') 947 ! 948 REWIND( numnam_ref ) ! Namelist namzdf_tmx in reference namelist : Wave-driven mixing 949 READ ( numnam_ref, namzdf_tmx_new, IOSTAT = ios, ERR = 901) 950 901 IF( ios /= 0 ) CALL ctl_nam ( ios , 'namzdf_tmx in reference namelist', lwp ) 951 ! 952 REWIND( numnam_cfg ) ! Namelist namzdf_tmx in configuration namelist : Wave-driven mixing 953 READ ( numnam_cfg, namzdf_tmx_new, IOSTAT = ios, ERR = 902 ) 954 902 IF( ios /= 0 ) CALL ctl_nam ( ios , 'namzdf_tmx in configuration namelist', lwp ) 955 IF(lwm) WRITE ( numond, namzdf_tmx_new ) 956 ! 957 IF(lwp) THEN ! Control print 958 WRITE(numout,*) 959 WRITE(numout,*) 'zdf_tmx_init : internal wave-driven mixing' 960 WRITE(numout,*) '~~~~~~~~~~~~' 961 WRITE(numout,*) ' Namelist namzdf_tmx_new : set wave-driven mixing parameters' 962 WRITE(numout,*) ' Pycnocline-intensified diss. scales as N (=1) or N^2 (=2) = ', nn_zpyc 963 WRITE(numout,*) ' Variable (T) or constant (F) mixing efficiency = ', ln_mevar 964 WRITE(numout,*) ' Differential internal wave-driven mixing (T) or not (F) = ', ln_tsdiff 965 ENDIF 966 967 ! The new wave-driven mixing parameterization elevates avt and avm in the interior, and 968 ! ensures that avt remains larger than its molecular value (=1.4e-7). Therefore, avtb should 969 ! be set here to a very small value, and avmb to its (uniform) molecular value (=1.4e-6). 970 avmb(:) = 1.4e-6_wp ! viscous molecular value 971 avtb(:) = 1.e-10_wp ! very small diffusive minimum (background avt is specified in zdf_tmx) 972 avtb_2d(:,:) = 1.e0_wp ! uniform 973 IF(lwp) THEN ! Control print 974 WRITE(numout,*) 975 WRITE(numout,*) ' Force the background value applied to avm & avt in TKE to be everywhere ', & 976 & 'the viscous molecular value & a very small diffusive value, resp.' 977 ENDIF 978 979 IF( .NOT.lk_zdfddm ) CALL ctl_stop( 'STOP', 'zdf_tmx_init_new : key_zdftmx_new requires key_zdfddm' ) 980 981 ! ! allocate tmx arrays 982 IF( zdf_tmx_alloc() /= 0 ) CALL ctl_stop( 'STOP', 'zdf_tmx_init : unable to allocate tmx arrays' ) 983 ! 984 ! ! read necessary fields 985 CALL iom_open('mixing_power_bot',inum) ! energy flux for high-mode wave breaking [W/m2] 986 CALL iom_get (inum, jpdom_data, 'field', ebot_tmx, 1 ) 987 CALL iom_close(inum) 988 ! 989 CALL iom_open('mixing_power_pyc',inum) ! energy flux for pynocline-intensified wave breaking [W/m2] 990 CALL iom_get (inum, jpdom_data, 'field', epyc_tmx, 1 ) 991 CALL iom_close(inum) 992 ! 993 CALL iom_open('mixing_power_cri',inum) ! energy flux for critical slope wave breaking [W/m2] 994 CALL iom_get (inum, jpdom_data, 'field', ecri_tmx, 1 ) 995 CALL iom_close(inum) 996 ! 997 CALL iom_open('decay_scale_bot',inum) ! spatially variable decay scale for high-mode wave breaking [m] 998 CALL iom_get (inum, jpdom_data, 'field', hbot_tmx, 1 ) 999 CALL iom_close(inum) 1000 ! 1001 CALL iom_open('decay_scale_cri',inum) ! spatially variable decay scale for critical slope wave breaking [m] 1002 CALL iom_get (inum, jpdom_data, 'field', hcri_tmx, 1 ) 1003 CALL iom_close(inum) 1004 1005 ebot_tmx(:,:) = ebot_tmx(:,:) * ssmask(:,:) 1006 epyc_tmx(:,:) = epyc_tmx(:,:) * ssmask(:,:) 1007 ecri_tmx(:,:) = ecri_tmx(:,:) * ssmask(:,:) 1008 1009 ! Set once for all to zero the first and last vertical levels of appropriate variables 1010 emix_tmx (:,:, 1 ) = 0._wp 1011 emix_tmx (:,:,jpk) = 0._wp 1012 zav_ratio(:,:, 1 ) = 0._wp 1013 zav_ratio(:,:,jpk) = 0._wp 1014 zav_wave (:,:, 1 ) = 0._wp 1015 zav_wave (:,:,jpk) = 0._wp 1016 1017 zbot = glob_sum( e1e2t(:,:) * ebot_tmx(:,:) ) 1018 zpyc = glob_sum( e1e2t(:,:) * epyc_tmx(:,:) ) 1019 zcri = glob_sum( e1e2t(:,:) * ecri_tmx(:,:) ) 1020 IF(lwp) THEN 1021 WRITE(numout,*) ' High-mode wave-breaking energy: ', zbot * 1.e-12_wp, 'TW' 1022 WRITE(numout,*) ' Pycnocline-intensifed wave-breaking energy: ', zpyc * 1.e-12_wp, 'TW' 1023 WRITE(numout,*) ' Critical slope wave-breaking energy: ', zcri * 1.e-12_wp, 'TW' 1024 ENDIF 1025 ! 1026 IF( nn_timing == 1 ) CALL timing_stop('zdf_tmx_init') 1027 ! 1028 END SUBROUTINE zdf_tmx_init 1029 543 1030 #else 544 1031 !!---------------------------------------------------------------------- -
branches/2016/dev_CNRS_2016/NEMOGCM/NEMO/OPA_SRC/step.F90
r7277 r7278 112 112 ! Update stochastic parameters and random T/S fluctuations 113 113 !>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>> 114 CALL sto_par( kstp ) ! Stochastic parameters 114 IF( ln_sto_eos ) CALL sto_par( kstp ) ! Stochastic parameters 115 IF( ln_sto_eos ) CALL sto_pts( tsn ) ! Random T/S fluctuations 115 116 116 117 !>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>> … … 154 155 ! 155 156 IF( l_ldfslp ) THEN ! slope of lateral mixing 156 !!gm : why this here ????157 IF(ln_sto_eos ) CALL sto_pts( tsn ) ! Random T/S fluctuations158 !!gm159 157 CALL eos( tsb, rhd, gdept_0(:,:,:) ) ! before in situ density 160 158 … … 183 181 IF(.NOT.ln_linssh ) CALL dom_vvl_sf_nxt( kstp ) ! after vertical scale factors 184 182 CALL wzv ( kstp ) ! now cross-level velocity 185 !!gm : why also here ????186 IF( ln_sto_eos ) CALL sto_pts( tsn ) ! Random T/S fluctuations187 !!gm188 183 CALL eos ( tsn, rhd, rhop, gdept_n(:,:,:) ) ! now in situ density for hpg computation 189 184 … … 305 300 !!jc: That would be better, but see comment above 306 301 !! 307 IF( lrst_oce ) CALL rst_write ( kstp ) ! write output ocean restart file 302 IF( lrst_oce ) CALL rst_write ( kstp ) ! write output ocean restart file 303 IF( ln_sto_eos ) CALL sto_rst_write( kstp ) ! write restart file for stochastic parameters 308 304 309 305 #if defined key_agrif -
branches/2016/dev_CNRS_2016/NEMOGCM/NEMO/TOP_SRC/PISCES/P4Z/p4zopt.F90
r6140 r7278 74 74 REAL(wp) :: zchl 75 75 REAL(wp) :: zc0 , zc1 , zc2, zc3, z1_dep 76 REAL(wp), POINTER, DIMENSION(:,: ) :: zdepmoy, zetmp1, zetmp2, zetmp3, zetmp4, zqsr100 76 REAL(wp), POINTER, DIMENSION(:,: ) :: zdepmoy, zetmp1, zetmp2, zetmp3, zetmp4 77 REAL(wp), POINTER, DIMENSION(:,: ) :: zqsr100, zqsr_corr 77 78 REAL(wp), POINTER, DIMENSION(:,:,:) :: zpar, ze0, ze1, ze2, ze3 78 79 !!--------------------------------------------------------------------- … … 81 82 ! 82 83 ! Allocate temporary workspace 83 CALL wrk_alloc( jpi, jpj, zqsr100, zdepmoy, zetmp1, zetmp2, zetmp3, zetmp4 ) 84 CALL wrk_alloc( jpi, jpj, jpk, zpar, ze0, ze1, ze2, ze3 ) 84 CALL wrk_alloc( jpi, jpj, zdepmoy, zetmp1, zetmp2, zetmp3, zetmp4 ) 85 CALL wrk_alloc( jpi, jpj, zqsr100, zqsr_corr ) 86 CALL wrk_alloc( jpi, jpj, jpk, zpar , ze0, ze1, ze2, ze3 ) 85 87 86 88 IF( knt == 1 .AND. ln_varpar ) CALL p4z_opt_sbc( kt ) … … 108 110 ! ! -------------------------------------- 109 111 IF( l_trcdm2dc ) THEN ! diurnal cycle 110 ! 1% of qsr to compute euphotic layer 111 zqsr100(:,:) = 0.01 * qsr_mean(:,:) ! daily mean qsr 112 ! 113 CALL p4z_opt_par( kt, qsr_mean, ze1, ze2, ze3 ) 112 ! ! 1% of qsr to compute euphotic layer 113 zqsr100(:,:) = 0.01 * qsr_mean(:,:) ! daily mean qsr 114 ! 115 zqsr_corr(:,:) = qsr_mean(:,:) / ( 1. - fr_i(:,:) + rtrn ) 116 ! 117 CALL p4z_opt_par( kt, zqsr_corr, ze1, ze2, ze3 ) 114 118 ! 115 119 DO jk = 1, nksrp … … 119 123 END DO 120 124 ! 121 CALL p4z_opt_par( kt, qsr, ze1, ze2, ze3 ) 125 zqsr_corr(:,:) = qsr(:,:) / ( 1. - fr_i(:,:) + rtrn ) 126 ! 127 CALL p4z_opt_par( kt, zqsr_corr, ze1, ze2, ze3 ) 122 128 ! 123 129 DO jk = 1, nksrp … … 126 132 ! 127 133 ELSE 128 ! 1% of qsr to compute euphotic layer 129 zqsr100(:,:) = 0.01 * qsr(:,:) 130 ! 131 CALL p4z_opt_par( kt, qsr, ze1, ze2, ze3 ) 134 ! ! 1% of qsr to compute euphotic layer 135 zqsr100(:,:) = 0.01 * qsr(:,:) ! daily mean qsr 136 ! 137 zqsr_corr(:,:) = qsr(:,:) / ( 1. - fr_i(:,:) + rtrn ) 138 ! 139 CALL p4z_opt_par( kt, zqsr_corr, ze1, ze2, ze3 ) 132 140 ! 133 141 DO jk = 1, nksrp … … 218 226 ENDIF 219 227 ! 220 CALL wrk_dealloc( jpi, jpj, zqsr100, zdepmoy, zetmp1, zetmp2, zetmp3, zetmp4 ) 221 CALL wrk_dealloc( jpi, jpj, jpk, zpar, ze0, ze1, ze2, ze3 ) 228 CALL wrk_dealloc( jpi, jpj, zdepmoy, zetmp1, zetmp2, zetmp3, zetmp4 ) 229 CALL wrk_dealloc( jpi, jpj, zqsr100, zqsr_corr ) 230 CALL wrk_dealloc( jpi, jpj, jpk, zpar , ze0, ze1, ze2, ze3 ) 222 231 ! 223 232 IF( nn_timing == 1 ) CALL timing_stop('p4z_opt') -
branches/2016/dev_CNRS_2016/NEMOGCM/NEMO/TOP_SRC/PISCES/P4Z/p4zprod.F90
r6140 r7278 133 133 zval = MAX( 1., zstrn(ji,jj) ) 134 134 zval = 1.5 * zval / ( 12. + zval ) 135 zprbio(ji,jj,jk) = prmax(ji,jj,jk) * zval 135 zprbio(ji,jj,jk) = prmax(ji,jj,jk) * zval * ( 1. - fr_i(ji,jj) ) 136 136 zprdia(ji,jj,jk) = zprbio(ji,jj,jk) 137 137 ENDIF -
branches/2016/dev_CNRS_2016/NEMOGCM/NEMO/TOP_SRC/PISCES/P4Z/p4zsms.F90
r7277 r7278 131 131 ! 132 132 CALL p4z_bio( kt, jnt ) ! Biology 133 CALL p4z_sed( kt, jnt ) ! Sedimentation134 133 CALL p4z_lys( kt, jnt ) ! Compute CaCO3 saturation 134 CALL p4z_sed( kt, jnt ) ! Surface and Bottom boundary conditions 135 135 CALL p4z_flx( kt, jnt ) ! Compute surface fluxes 136 136 ! -
branches/2016/dev_CNRS_2016/NEMOGCM/NEMO/TOP_SRC/TRP/trcdmp.F90
r7277 r7278 38 38 REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: restotr ! restoring coeff. on tracers (s-1) 39 39 40 INTEGER, PARAMETER :: npncts = 5! number of closed sea40 INTEGER, PARAMETER :: npncts = 8 ! number of closed sea 41 41 INTEGER, DIMENSION(npncts) :: nctsi1, nctsj1 ! south-west closed sea limits (i,j) 42 42 INTEGER, DIMENSION(npncts) :: nctsi2, nctsj2 ! north-east closed sea limits (i,j) … … 104 104 ! 105 105 jl = n_trc_index(jn) 106 CALL trc_dta( kt, sf_trcdta(jl) ) ! read tracer data at nit000 107 ztrcdta(:,:,:) = sf_trcdta(jl)%fnow(:,:,:) * tmask(:,:,:) * rf_trfac(jl) 106 CALL trc_dta( kt, sf_trcdta(jl), rf_trfac(jl), ztrcdta ) ! read tracer data at nit000 108 107 ! 109 108 SELECT CASE ( nn_zdmp_tr ) … … 181 180 !!---------------------------------------------------------------------- 182 181 ! 183 IF( nn_timing == 1 ) CALL timing_start('trc_dmp_ini t')182 IF( nn_timing == 1 ) CALL timing_start('trc_dmp_ini') 184 183 ! 185 184 REWIND( numnat_ref ) ! Namelist namtrc_dmp in reference namelist : Passive tracers newtonian damping … … 200 199 WRITE(numout,*) ' Restoration coeff file cn_resto_tr = ', cn_resto_tr 201 200 ENDIF 201 ! ! Allocate arrays 202 IF( trc_dmp_alloc() /= 0 ) CALL ctl_stop( 'STOP', 'trc_dmp_ini: unable to allocate arrays' ) 202 203 ! 203 204 SELECT CASE ( nn_zdmp_tr ) … … 238 239 !! nctsi2(), nctsj2() : north-east Closed sea limits (i,j) 239 240 !!---------------------------------------------------------------------- 240 INTEGER, INTENT( in ) :: kt ! ocean time-step index 241 ! 242 INTEGER :: ji , jj, jk, jn, jl, jc ! dummy loop indicesa 243 INTEGER :: isrow ! local index 244 !!---------------------------------------------------------------------- 245 ! 241 INTEGER, INTENT( in ) :: kt ! ocean time-step index 242 ! 243 INTEGER :: ji , jj, jk, jn, jl, jc ! dummy loop indicesa 244 INTEGER :: isrow ! local index 245 REAL(wp), POINTER, DIMENSION(:,:,:) :: ztrcdta ! 3D workspace 246 247 !!---------------------------------------------------------------------- 248 246 249 IF( kt == nit000 ) THEN 247 250 ! initial values … … 261 264 ! 262 265 ! Caspian Sea 263 nctsi1(1) = 332 ; nctsj1(1) = 243 - isrow 264 nctsi2(1) = 344 ; nctsj2(1) = 275 - isrow 266 nctsi1(1) = 333 ; nctsj1(1) = 243 - isrow 267 nctsi2(1) = 342 ; nctsj2(1) = 274 - isrow 268 ! ! Lake Superior 269 nctsi1(2) = 198 ; nctsj1(2) = 258 - isrow 270 nctsi2(2) = 204 ; nctsj2(2) = 262 - isrow 271 ! ! Lake Michigan 272 nctsi1(3) = 201 ; nctsj1(3) = 250 - isrow 273 nctsi2(3) = 203 ; nctsj2(3) = 256 - isrow 274 ! ! Lake Huron 275 nctsi1(4) = 204 ; nctsj1(4) = 252 - isrow 276 nctsi2(4) = 209 ; nctsj2(4) = 256 - isrow 277 ! ! Lake Erie 278 nctsi1(5) = 206 ; nctsj1(5) = 249 - isrow 279 nctsi2(5) = 209 ; nctsj2(5) = 251 - isrow 280 ! ! Lake Ontario 281 nctsi1(6) = 210 ; nctsj1(6) = 252 - isrow 282 nctsi2(6) = 212 ; nctsj2(6) = 252 - isrow 283 ! ! Victoria Lake 284 nctsi1(7) = 321 ; nctsj1(7) = 180 - isrow 285 nctsi2(7) = 322 ; nctsj2(7) = 189 - isrow 286 ! ! Baltic Sea 287 nctsi1(8) = 297 ; nctsj1(8) = 270 - isrow 288 nctsi2(8) = 308 ; nctsj2(8) = 293 - isrow 265 289 ! 266 290 ! ! ======================= … … 331 355 IF(lwp) WRITE(numout,*) 332 356 ! 357 CALL wrk_alloc( jpi, jpj, jpk, ztrcdta ) ! Memory allocation 358 ! 333 359 DO jn = 1, jptra 334 360 IF( ln_trc_ini(jn) ) THEN ! update passive tracers arrays with input data read from file 335 361 jl = n_trc_index(jn) 336 CALL trc_dta( kt, sf_trcdta(jl) ) ! read tracer data at nit000362 CALL trc_dta( kt, sf_trcdta(jl), rf_trfac(jl), ztrcdta ) ! read tracer data at nit000 337 363 DO jc = 1, npncts 338 364 DO jk = 1, jpkm1 339 365 DO jj = nctsj1(jc), nctsj2(jc) 340 366 DO ji = nctsi1(jc), nctsi2(jc) 341 trn(ji,jj,jk,jn) = sf_trcdta(jl)%fnow(ji,jj,jk) * tmask(ji,jj,jk) * rf_trfac(jl)367 trn(ji,jj,jk,jn) = ztrcdta(ji,jj,jk) 342 368 trb(ji,jj,jk,jn) = trn(ji,jj,jk,jn) 343 369 ENDDO … … 347 373 ENDIF 348 374 ENDDO 349 !375 CALL wrk_dealloc( jpi, jpj, jpk, ztrcdta ) 350 376 ENDIF 351 377 ! 352 378 END SUBROUTINE trc_dmp_clo 353 379 380 354 381 #else 355 382 !!---------------------------------------------------------------------- -
branches/2016/dev_CNRS_2016/NEMOGCM/NEMO/TOP_SRC/trcdta.F90
r6309 r7278 123 123 ENDIF 124 124 WRITE(numout,*) ' ' 125 WRITE(numout,'(a, i 3,3a,e11.3)') ' Read IC file for tracer number :', &125 WRITE(numout,'(a, i4,3a,e11.3)') ' Read IC file for tracer number :', & 126 126 & jn, ', name : ', TRIM(clndta), ', Multiplicative Scaling factor : ', zfact 127 127 ENDIF … … 159 159 160 160 161 SUBROUTINE trc_dta( kt, sf_ dta)161 SUBROUTINE trc_dta( kt, sf_trcdta, ptrfac, ptrc) 162 162 !!---------------------------------------------------------------------- 163 163 !! *** ROUTINE trc_dta *** … … 169 169 !! - ln_trcdmp=F: deallocates the data structure as they are not used 170 170 !! 171 !! ** Action : sf_dta passive tracer data on medl mesh and interpolated at time-step kt 172 !!---------------------------------------------------------------------- 173 INTEGER , INTENT(in ) :: kt ! ocean time-step 174 TYPE(FLD), DIMENSION(1) , INTENT(inout) :: sf_dta ! array of information on the field to read 171 !! ** Action : sf_trcdta passive tracer data on medl mesh and interpolated at time-step kt 172 !!---------------------------------------------------------------------- 173 INTEGER , INTENT(in ) :: kt ! ocean time-step 174 TYPE(FLD), DIMENSION(1) , INTENT(inout) :: sf_trcdta ! array of information on the field to read 175 REAL(wp) , INTENT(in ) :: ptrfac ! multiplication factor 176 REAL(wp), DIMENSION(jpi,jpj,jpk), OPTIONAL , INTENT(out ) :: ptrc 175 177 ! 176 178 INTEGER :: ji, jj, jk, jl, jkk, ik ! dummy loop indices 177 179 REAL(wp):: zl, zi 178 180 REAL(wp), DIMENSION(jpk) :: ztp ! 1D workspace 181 REAL(wp), POINTER, DIMENSION(:,:,:) :: ztrcdta ! 3D workspace 179 182 CHARACTER(len=100) :: clndta 180 183 !!---------------------------------------------------------------------- … … 184 187 IF( nb_trcdta > 0 ) THEN 185 188 ! 186 CALL fld_read( kt, 1, sf_dta ) !== read data at kt time step ==! 189 CALL wrk_alloc( jpi, jpj, jpk, ztrcdta ) ! Memory allocation 190 ! 191 CALL fld_read( kt, 1, sf_trcdta ) !== read data at kt time step ==! 192 ztrcdta(:,:,:) = sf_trcdta(1)%fnow(:,:,:) * tmask(:,:,:) ! Mask 187 193 ! 188 194 IF( ln_sco ) THEN !== s- or mixed s-zps-coordinate ==! … … 192 198 WRITE(numout,*) 'trc_dta: interpolates passive tracer data onto the s- or mixed s-z-coordinate mesh' 193 199 ENDIF 194 ! 195 DO jj = 1, jpj ! vertical interpolation of T & S 196 DO ji = 1, jpi 197 DO jk = 1, jpk ! determines the intepolated T-S profiles at each (i,j) points 198 zl = gdept_n(ji,jj,jk) 199 IF( zl < gdept_1d(1 ) ) THEN ! above the first level of data 200 ztp(jk) = sf_dta(1)%fnow(ji,jj,1) 201 ELSEIF( zl > gdept_1d(jpk) ) THEN ! below the last level of data 202 ztp(jk) = sf_dta(1)%fnow(ji,jj,jpkm1) 203 ELSE ! inbetween : vertical interpolation between jkk & jkk+1 204 DO jkk = 1, jpkm1 ! when gdept(jkk) < zl < gdept(jkk+1) 205 IF( (zl-gdept_1d(jkk)) * (zl-gdept_1d(jkk+1)) <= 0._wp ) THEN 206 zi = ( zl - gdept_1d(jkk) ) / (gdept_1d(jkk+1)-gdept_1d(jkk)) 207 ztp(jk) = sf_dta(1)%fnow(ji,jj,jkk) + ( sf_dta(1)%fnow(ji,jj,jkk+1) - & 208 sf_dta(1)%fnow(ji,jj,jkk) ) * zi 209 ENDIF 210 END DO 211 ENDIF 212 END DO 213 DO jk = 1, jpkm1 214 sf_dta(1)%fnow(ji,jj,jk) = ztp(jk) * tmask(ji,jj,jk) ! mask required for mixed zps-s-coord 215 END DO 216 sf_dta(1)%fnow(ji,jj,jpk) = 0._wp 200 DO jj = 1, jpj ! vertical interpolation of T & S 201 DO ji = 1, jpi 202 DO jk = 1, jpk ! determines the intepolated T-S profiles at each (i,j) points 203 zl = gdept_n(ji,jj,jk) 204 IF( zl < gdept_1d(1 ) ) THEN ! above the first level of data 205 ztp(jk) = ztrcdta(ji,jj,1) 206 ELSEIF( zl > gdept_1d(jpk) ) THEN ! below the last level of data 207 ztp(jk) = ztrcdta(ji,jj,jpkm1) 208 ELSE ! inbetween : vertical interpolation between jkk & jkk+1 209 DO jkk = 1, jpkm1 ! when gdept(jkk) < zl < gdept(jkk+1) 210 IF( (zl-gdept_1d(jkk)) * (zl-gdept_1d(jkk+1)) <= 0._wp ) THEN 211 zi = ( zl - gdept_1d(jkk) ) / (gdept_1d(jkk+1)-gdept_1d(jkk)) 212 ztp(jk) = ztrcdta(ji,jj,jkk) + ( ztrcdta(ji,jj,jkk+1) - & 213 ztrcdta(ji,jj,jkk) ) * zi 214 ENDIF 215 END DO 216 ENDIF 217 217 END DO 218 END DO 218 DO jk = 1, jpkm1 219 ztrcdta(ji,jj,jk) = ztp(jk) * tmask(ji,jj,jk) ! mask required for mixed zps-s-coord 220 END DO 221 ztrcdta(ji,jj,jpk) = 0._wp 222 END DO 223 END DO 219 224 ! 220 225 ELSE !== z- or zps- coordinate ==! 221 ! 222 sf_dta(1)%fnow(:,:,:) = sf_dta(1)%fnow(:,:,:) * tmask(:,:,:) ! Mask 223 ! 224 IF( ln_zps ) THEN ! zps-coordinate (partial steps) interpolation at the last ocean level 225 DO jj = 1, jpj 226 DO ji = 1, jpi 227 ik = mbkt(ji,jj) 228 IF( ik > 1 ) THEN 229 zl = ( gdept_1d(ik) - gdept_n(ji,jj,ik) ) / ( gdept_1d(ik) - gdept_1d(ik-1) ) 230 sf_dta(1)%fnow(ji,jj,ik) = (1.-zl) * sf_dta(1)%fnow(ji,jj,ik) + zl * sf_dta(1)%fnow(ji,jj,ik-1) 231 ENDIF 232 END DO 226 ! 227 IF( ln_zps ) THEN ! zps-coordinate (partial steps) interpolation at the last ocean level 228 DO jj = 1, jpj 229 DO ji = 1, jpi 230 ik = mbkt(ji,jj) 231 IF( ik > 1 ) THEN 232 zl = ( gdept_1d(ik) - gdept_n(ji,jj,ik) ) / ( gdept_1d(ik) - gdept_1d(ik-1) ) 233 ztrcdta(ji,jj,ik) = (1.-zl) * ztrcdta(ji,jj,ik) + zl * ztrcdta(ji,jj,ik-1) 234 ENDIF 235 ik = mikt(ji,jj) 236 IF( ik > 1 ) THEN 237 zl = ( gdept_n(ji,jj,ik) - gdept_1d(ik) ) / ( gdept_1d(ik+1) - gdept_1d(ik) ) 238 ztrcdta(ji,jj,ik) = (1.-zl) * ztrcdta(ji,jj,ik) + zl * ztrcdta(ji,jj,ik+1) 239 ENDIF 233 240 END DO 234 ENDIF 241 END DO 242 ENDIF 235 243 ! 236 244 ENDIF 237 245 ! 246 ! Add multiplicative factor 247 ztrcdta(:,:,:) = ztrcdta(:,:,:) * ptrfac 248 ! 249 ! Data structure for trc_ini (and BFMv5.1 coupling) 250 IF( .NOT. PRESENT(ptrc) ) sf_trcdta(1)%fnow(:,:,:) = ztrcdta(:,:,:) 251 ! 252 ! Data structure for trc_dmp 253 IF( PRESENT(ptrc) ) ptrc(:,:,:) = ztrcdta(:,:,:) 254 ! 255 CALL wrk_dealloc( jpi, jpj, jpk, ztrcdta ) 256 ! 238 257 ENDIF 239 258 ! … … 241 260 ! 242 261 END SUBROUTINE trc_dta 243 262 244 263 #else 245 264 !!---------------------------------------------------------------------- … … 247 266 !!---------------------------------------------------------------------- 248 267 CONTAINS 249 SUBROUTINE trc_dta( kt, sf_ dta, zrf_trfac) ! Empty routine268 SUBROUTINE trc_dta( kt, sf_trcdta, ptrfac, ptrc) ! Empty routine 250 269 WRITE(*,*) 'trc_dta: You should not have seen this print! error?', kt 251 270 END SUBROUTINE trc_dta -
branches/2016/dev_CNRS_2016/NEMOGCM/NEMO/TOP_SRC/trcini.F90
r6309 r7278 203 203 USE trcdta ! initialisation from files 204 204 ! 205 INTEGER :: jk, jn, jl! dummy loop indices205 INTEGER :: jn, jl ! dummy loop indices 206 206 !!---------------------------------------------------------------------- 207 207 ! … … 220 220 IF( ln_trcdta .AND. nb_trcdta > 0 ) THEN ! Initialisation of tracer from a file that may also be used for damping 221 221 ! 222 DO jn = 1, jptra222 DO jn = 1, jptra 223 223 IF( ln_trc_ini(jn) ) THEN ! update passive tracers arrays with input data read from file 224 224 jl = n_trc_index(jn) 225 CALL trc_dta( nit000, sf_trcdta(jl) ) ! read tracer data at nit000226 trn(:,:,:,jn) = sf_trcdta(jl)%fnow(:,:,:) * tmask(:,:,:) * rf_trfac(jl)225 CALL trc_dta( nit000, sf_trcdta(jl), rf_trfac(jl) ) ! read tracer data at nit000 226 trn(:,:,:,jn) = sf_trcdta(jl)%fnow(:,:,:) 227 227 ! 228 228 IF( .NOT.ln_trcdmp .AND. .NOT.ln_trcdmp_clo ) THEN !== deallocate data structure ==!
Note: See TracChangeset
for help on using the changeset viewer.