- Timestamp:
- 2015-07-21T10:55:28+02:00 (9 years ago)
- Location:
- branches/2014/dev_r4621_NOC4_BDY_VERT_INTERP/NEMOGCM/NEMO/OPA_SRC
- Files:
-
- 155 edited
- 1 copied
Legend:
- Unmodified
- Added
- Removed
-
branches/2014/dev_r4621_NOC4_BDY_VERT_INTERP/NEMOGCM/NEMO/OPA_SRC/ASM/asmbkg.F90
- Property svn:keywords set to Id
r5038 r5620 57 57 !!---------------------------------------------------------------------- 58 58 !! NEMO/OPA 3.3 , NEMO Consortium (2010) 59 !! $Id :$59 !! $Id$ 60 60 !! Software governed by the CeCILL licence (NEMOGCM/NEMO_CeCILL.txt) 61 61 !!---------------------------------------------------------------------- -
branches/2014/dev_r4621_NOC4_BDY_VERT_INTERP/NEMOGCM/NEMO/OPA_SRC/ASM/asminc.F90
r5038 r5620 658 658 659 659 DO jk = 1, jpkm1 660 fzptnz(:,:,jk) = eos_fzp( tsn(:,:,jk,jp_sal), fsdept(:,:,jk) )660 CALL eos_fzp( tsn(:,:,jk,jp_sal), fzptnz(:,:,jk), fsdept(:,:,jk) ) 661 661 END DO 662 662 … … 746 746 747 747 748 IF( ln_zps .AND. .NOT. lk_c1d ) & 749 & CALL zps_hde( nit000, jpts, tsb, gtsu, gtsv, & ! Partial steps: before horizontal gradient 750 & rhd, gru , grv, aru, arv, gzu, gzv, ge3ru, ge3rv, & ! 751 & gtui, gtvi, grui, grvi, arui, arvi, gzui, gzvi, ge3rui, ge3rvi ) ! of t, s, rd at the last ocean level 748 IF( ln_zps .AND. .NOT. lk_c1d .AND. .NOT. ln_isfcav) & 749 & CALL zps_hde ( kt, jpts, tsb, gtsu, gtsv, & ! Partial steps: before horizontal gradient 750 & rhd, gru , grv ) ! of t, s, rd at the last ocean level 751 IF( ln_zps .AND. .NOT. lk_c1d .AND. ln_isfcav) & 752 & CALL zps_hde_isf( nit000, jpts, tsb, gtsu, gtsv, & ! Partial steps for top cell (ISF) 753 & rhd, gru , grv , aru , arv , gzu , gzv , ge3ru , ge3rv , & 754 & gtui, gtvi, grui, grvi, arui, arvi, gzui, gzvi, ge3rui, ge3rvi ) ! of t, s, rd at the last ocean level 752 755 753 756 #if defined key_zdfkpp -
branches/2014/dev_r4621_NOC4_BDY_VERT_INTERP/NEMOGCM/NEMO/OPA_SRC/BDY/bdy_oce.F90
r4792 r5620 49 49 LOGICAL :: ll_tem 50 50 LOGICAL :: ll_sal 51 LOGICAL :: ll_fvl 51 52 REAL(wp), POINTER, DIMENSION(:) :: ssh 52 53 REAL(wp), POINTER, DIMENSION(:) :: u2d … … 130 131 REAL(wp), ALLOCATABLE, DIMENSION(:,:,:), TARGET :: dta_global !: workspace for reading in global data arrays (unstr. bdy) 131 132 REAL(wp), ALLOCATABLE, DIMENSION(:,:,:), TARGET :: dta_global_z !: workspace for reading in global depth arrays (unstr. bdy) 133 REAL(wp), ALLOCATABLE, DIMENSION(:,:,:), TARGET :: dta_global_dz !: workspace for reading in global depth arrays (unstr. bdy) 132 134 REAL(wp), ALLOCATABLE, DIMENSION(:,:,:), TARGET :: dta_global2 !: workspace for reading in global data arrays (struct. bdy) 133 135 REAL(wp), ALLOCATABLE, DIMENSION(:,:,:), TARGET :: dta_global2_z !: workspace for reading in global depth arrays (struct. bdy) 136 REAL(wp), ALLOCATABLE, DIMENSION(:,:,:), TARGET :: dta_global2_dz !: workspace for reading in global depth arrays (struct. bdy) 134 137 !$AGRIF_DO_NOT_TREAT 135 138 TYPE(OBC_INDEX), DIMENSION(jp_bdy), TARGET :: idx_bdy !: bdy indices (local process) -
branches/2014/dev_r4621_NOC4_BDY_VERT_INTERP/NEMOGCM/NEMO/OPA_SRC/BDY/bdydta.F90
r4792 r5620 33 33 USE ice_2 34 34 #elif defined key_lim3 35 USE par_ice36 35 USE ice 37 USE lim cat_1D! redistribute ice input into categories36 USE limvar ! redistribute ice input into categories 38 37 #endif 39 38 USE sbcapr … … 275 274 276 275 jend = jstart + dta%nread(2) - 1 277 CALL fld_read( kt=kt, kn_fsbc=1, sd=bf(jstart:jend), map=nbmap_ptr(jstart:jend), & 278 & kit=jit, kt_offset=time_offset ) 276 IF( ln_full_vel_array(ib_bdy) ) THEN 277 CALL fld_read( kt=kt, kn_fsbc=1, sd=bf(jstart:jend), map=nbmap_ptr(jstart:jend), & 278 & kit=jit, kt_offset=time_offset , jpk_bdy=nb_jpk_bdy, fvl=ln_full_vel_array(ib_bdy) ) 279 ELSE 280 CALL fld_read( kt=kt, kn_fsbc=1, sd=bf(jstart:jend), map=nbmap_ptr(jstart:jend), & 281 & kit=jit, kt_offset=time_offset ) 282 ENDIF 279 283 280 284 ! If full velocities in boundary data then extract barotropic velocities from 3D fields … … 341 345 jend = jstart + dta%nread(1) - 1 342 346 CALL fld_read( kt=kt, kn_fsbc=1, sd=bf(jstart:jend), & 343 & map=nbmap_ptr(jstart:jend), kt_offset=time_offset, jpk_bdy=nb_jpk_bdy )347 & map=nbmap_ptr(jstart:jend), kt_offset=time_offset, jpk_bdy=nb_jpk_bdy, fvl=ln_full_vel_array(ib_bdy) ) 344 348 ENDIF 345 349 ! If full velocities in boundary data then split into barotropic and baroclinic data … … 380 384 #if defined key_lim3 381 385 IF( .NOT. ll_bdylim3 .AND. cn_ice_lim(ib_bdy) /= 'none' .AND. nn_ice_lim_dta(ib_bdy) == 1 ) THEN ! bdy ice input (case input is lim2 type) 382 CALL lim_ cat_1D( bf(jfld_hti)%fnow(:,1,1), bf(jfld_hts)%fnow(:,1,1), bf(jfld_ai)%fnow(:,1,1), &386 CALL lim_var_itd ( bf(jfld_hti)%fnow(:,1,1), bf(jfld_hts)%fnow(:,1,1), bf(jfld_ai)%fnow(:,1,1), & 383 387 & dta_bdy(ib_bdy)%ht_i, dta_bdy(ib_bdy)%ht_s, dta_bdy(ib_bdy)%a_i ) 384 388 ENDIF … … 536 540 cn_dir_array(ib_bdy) = cn_dir 537 541 ln_full_vel_array(ib_bdy) = ln_full_vel 542 !dta%ll_fvl = ln_full_vel ! jdha need this in fldread routine to work out what type of correction to apply to interpolated bdy data (maybe we replace all instances of ln_full_vel_array with this rather than duplicate) 538 543 539 544 nblen => idx_bdy(ib_bdy)%nblen … … 734 739 IF( blf_i(jfld)%ln_tint ) ALLOCATE( bf(jfld)%fdta(ilen1(jfld),1,ilen3(jfld),2) ) 735 740 nbmap_ptr(jfld)%ptr => idx_bdy(ibdy(jfld))%nbmap(:,igrid(jfld)) 741 nbmap_ptr(jfld)%ll_unstruc = ln_coords_file(ibdy(jfld)) 736 742 ENDDO 737 743 -
branches/2014/dev_r4621_NOC4_BDY_VERT_INTERP/NEMOGCM/NEMO/OPA_SRC/BDY/bdydyn2d.F90
- Property svn:keywords set to Id
r5038 r5620 36 36 !!---------------------------------------------------------------------- 37 37 !! NEMO/OPA 3.3 , NEMO Consortium (2010) 38 !! $Id : bdydyn.F90 2528 2010-12-27 17:33:53Z rblod$38 !! $Id$ 39 39 !! Software governed by the CeCILL licence (NEMOGCM/NEMO_CeCILL.txt) 40 40 !!---------------------------------------------------------------------- -
branches/2014/dev_r4621_NOC4_BDY_VERT_INTERP/NEMOGCM/NEMO/OPA_SRC/BDY/bdydyn3d.F90
- Property svn:keywords set to Id
r4354 r5620 33 33 !!---------------------------------------------------------------------- 34 34 !! NEMO/OPA 3.3 , NEMO Consortium (2010) 35 !! $Id : bdydyn.F90 2528 2010-12-27 17:33:53Z rblod$35 !! $Id$ 36 36 !! Software governed by the CeCILL licence (NEMOGCM/NEMO_CeCILL.txt) 37 37 !!---------------------------------------------------------------------- -
branches/2014/dev_r4621_NOC4_BDY_VERT_INTERP/NEMOGCM/NEMO/OPA_SRC/BDY/bdyice_lim.F90
- Property svn:keywords set to Id
r5038 r5620 26 26 USE dom_ice_2 ! sea-ice domain 27 27 #elif defined key_lim3 28 USE par_ice29 28 USE ice ! LIM_3 ice variables 30 29 USE dom_ice ! sea-ice domain 30 USE limvar 31 31 #endif 32 32 USE par_oce ! ocean parameters … … 42 42 PRIVATE 43 43 44 PUBLIC bdy_ice_lim ! routine called in sbcmod44 PUBLIC bdy_ice_lim ! routine called in sbcmod 45 45 PUBLIC bdy_ice_lim_dyn ! routine called in limrhg 46 46 47 47 !!---------------------------------------------------------------------- 48 48 !! NEMO/OPA 3.3 , NEMO Consortium (2010) 49 !! $Id : bdyice.F90 2715 2011-03-30 15:58:35Z rblod$49 !! $Id$ 50 50 !! Software governed by the CeCILL licence (NEMOGCM/NEMO_CeCILL.txt) 51 51 !!---------------------------------------------------------------------- … … 60 60 !!---------------------------------------------------------------------- 61 61 INTEGER, INTENT( in ) :: kt ! Main time step counter 62 !!63 62 INTEGER :: ib_bdy ! Loop index 63 64 #if defined key_lim3 65 CALL lim_var_glo2eqv 66 #endif 67 64 68 DO ib_bdy=1, nb_bdy 65 69 … … 72 76 CALL ctl_stop( 'bdy_ice_lim : unrecognised option for open boundaries for ice fields' ) 73 77 END SELECT 74 ENDDO 78 79 END DO 80 81 #if defined key_lim3 82 CALL lim_var_zapsmall 83 CALL lim_var_agg(1) 84 #endif 75 85 76 86 END SUBROUTINE bdy_ice_lim … … 89 99 TYPE(OBC_DATA), INTENT(in) :: dta ! OBC external data 90 100 INTEGER, INTENT(in) :: kt ! main time-step counter 91 INTEGER, INTENT(in) :: ib_bdy ! BDY set index !!101 INTEGER, INTENT(in) :: ib_bdy ! BDY set index 92 102 93 103 INTEGER :: jpbound ! 0 = incoming ice … … 169 179 jpbound = 0; ii = ji; ij = jj; 170 180 171 IF ( u_ice(ji+1,jj ) < 0. .AND. umask(ji-1,jj ,1) == 0. ) jpbound = 1; ii = ji+1; ij = jj 172 IF ( u_ice(ji-1,jj ) > 0. .AND. umask(ji+1,jj ,1) == 0. ) jpbound = 1; ii = ji-1; ij = jj 173 IF ( v_ice(ji ,jj+1) < 0. .AND. vmask(ji ,jj-1,1) == 0. ) jpbound = 1; ii = ji ; ij = jj+1 174 IF ( v_ice(ji ,jj-1) > 0. .AND. vmask(ji ,jj+1,1) == 0. ) jpbound = 1; ii = ji ; ij = jj-1 175 176 rswitch = 1.0 - MAX( 0.0_wp , SIGN ( 1.0_wp , - at_i(ii,ij) + 0.01 ) ) ! 0 if no ice 181 IF( u_ice(ji+1,jj ) < 0. .AND. umask(ji-1,jj ,1) == 0. ) jpbound = 1; ii = ji+1; ij = jj 182 IF( u_ice(ji-1,jj ) > 0. .AND. umask(ji+1,jj ,1) == 0. ) jpbound = 1; ii = ji-1; ij = jj 183 IF( v_ice(ji ,jj+1) < 0. .AND. vmask(ji ,jj-1,1) == 0. ) jpbound = 1; ii = ji ; ij = jj+1 184 IF( v_ice(ji ,jj-1) > 0. .AND. vmask(ji ,jj+1,1) == 0. ) jpbound = 1; ii = ji ; ij = jj-1 185 186 IF( nn_ice_lim_dta(ib_bdy) == 0 ) jpbound = 0; ii = ji; ij = jj ! case ice boundaries = initial conditions 187 ! do not make state variables dependent on velocity 188 189 190 rswitch = MAX( 0.0_wp , SIGN ( 1.0_wp , at_i(ii,ij) - 0.01 ) ) ! 0 if no ice 177 191 178 192 ! concentration and thickness … … 190 204 191 205 ! Ice salinity, age, temperature 192 <<<<<<< .working 193 sm_i(ji,jj,jl) = zinda * rn_ice_sal(ib_bdy) + ( 1.0 - zinda ) * s_i_min 194 o_i(ji,jj,jl) = zinda * rn_ice_age(ib_bdy) + ( 1.0 - zinda ) 195 t_su(ji,jj,jl) = zinda * rn_ice_tem(ib_bdy) + ( 1.0 - zinda ) * rn_ice_tem(ib_bdy) 196 ======= 197 sm_i(ji,jj,jl) = rswitch * rn_ice_sal(ib_bdy) + ( 1.0 - rswitch ) * s_i_min 198 o_i(ji,jj,jl) = rswitch * rn_ice_age(ib_bdy) + ( 1.0 - rswitch ) 206 sm_i(ji,jj,jl) = rswitch * rn_ice_sal(ib_bdy) + ( 1.0 - rswitch ) * rn_simin 207 oa_i(ji,jj,jl) = rswitch * rn_ice_age(ib_bdy) * a_i(ji,jj,jl) 199 208 t_su(ji,jj,jl) = rswitch * rn_ice_tem(ib_bdy) + ( 1.0 - rswitch ) * rn_ice_tem(ib_bdy) 200 >>>>>>> .merge-right.r5035201 209 DO jk = 1, nlay_s 202 <<<<<<< .working 203 t_s(ji,jj,jk,jl) = zinda * rn_ice_tem(ib_bdy) + ( 1.0 - zinda ) * rtt 204 ======= 205 t_s(ji,jj,jk,jl) = rswitch * rn_ice_tem(ib_bdy) + ( 1.0 - rswitch ) * rtt 206 >>>>>>> .merge-right.r5035 210 t_s(ji,jj,jk,jl) = rswitch * rn_ice_tem(ib_bdy) + ( 1.0 - rswitch ) * rt0 207 211 END DO 208 212 DO jk = 1, nlay_i 209 <<<<<<< .working 210 t_i(ji,jj,jk,jl) = zinda * rn_ice_tem(ib_bdy) + ( 1.0 - zinda ) * rtt 211 s_i(ji,jj,jk,jl) = zinda * rn_ice_sal(ib_bdy) + ( 1.0 - zinda ) * s_i_min 212 ======= 213 t_i(ji,jj,jk,jl) = rswitch * rn_ice_tem(ib_bdy) + ( 1.0 - rswitch ) * rtt 214 s_i(ji,jj,jk,jl) = rswitch * rn_ice_sal(ib_bdy) + ( 1.0 - rswitch ) * s_i_min 215 >>>>>>> .merge-right.r5035 213 t_i(ji,jj,jk,jl) = rswitch * rn_ice_tem(ib_bdy) + ( 1.0 - rswitch ) * rt0 214 s_i(ji,jj,jk,jl) = rswitch * rn_ice_sal(ib_bdy) + ( 1.0 - rswitch ) * rn_simin 216 215 END DO 217 216 … … 219 218 220 219 ! Ice salinity, age, temperature 221 sm_i(ji,jj,jl) = rswitch * sm_i(ii,ij,jl) + ( 1.0 - rswitch ) * s_i_min222 o _i(ji,jj,jl) = rswitch * o_i(ii,ij,jl) + ( 1.0 - rswitch)223 t_su(ji,jj,jl) = rswitch * t_su(ii,ij,jl) + ( 1.0 - rswitch ) * rt t220 sm_i(ji,jj,jl) = rswitch * sm_i(ii,ij,jl) + ( 1.0 - rswitch ) * rn_simin 221 oa_i(ji,jj,jl) = rswitch * oa_i(ii,ij,jl) 222 t_su(ji,jj,jl) = rswitch * t_su(ii,ij,jl) + ( 1.0 - rswitch ) * rt0 224 223 DO jk = 1, nlay_s 225 t_s(ji,jj,jk,jl) = rswitch * t_s(ii,ij,jk,jl) + ( 1.0 - rswitch ) * rt t224 t_s(ji,jj,jk,jl) = rswitch * t_s(ii,ij,jk,jl) + ( 1.0 - rswitch ) * rt0 226 225 END DO 227 226 DO jk = 1, nlay_i 228 t_i(ji,jj,jk,jl) = rswitch * t_i(ii,ij,jk,jl) + ( 1.0 - rswitch ) * rt t229 s_i(ji,jj,jk,jl) = rswitch * s_i(ii,ij,jk,jl) + ( 1.0 - rswitch ) * s_i_min227 t_i(ji,jj,jk,jl) = rswitch * t_i(ii,ij,jk,jl) + ( 1.0 - rswitch ) * rt0 228 s_i(ji,jj,jk,jl) = rswitch * s_i(ii,ij,jk,jl) + ( 1.0 - rswitch ) * rn_simin 230 229 END DO 231 230 … … 233 232 234 233 ! if salinity is constant, then overwrite rn_ice_sal 235 IF( n um_sal == 1 ) THEN236 sm_i(ji,jj,jl) = bulk_sal237 s_i (ji,jj,:,jl) = bulk_sal234 IF( nn_icesal == 1 ) THEN 235 sm_i(ji,jj,jl) = rn_icesal 236 s_i (ji,jj,:,jl) = rn_icesal 238 237 ENDIF 239 238 240 239 ! contents 241 240 smv_i(ji,jj,jl) = MIN( sm_i(ji,jj,jl) , sss_m(ji,jj) ) * v_i(ji,jj,jl) 242 oa_i(ji,jj,jl) = o_i(ji,jj,jl) * a_i(ji,jj,jl)243 241 DO jk = 1, nlay_s 244 242 ! Snow energy of melting 245 e_s(ji,jj,jk,jl) = rswitch * rhosn * ( cpic * ( rtt - t_s(ji,jj,jk,jl) ) + lfus ) 246 ! Change dimensions 247 e_s(ji,jj,jk,jl) = e_s(ji,jj,jk,jl) / unit_fac 248 ! Multiply by volume, so that heat content in 10^9 Joules 249 e_s(ji,jj,jk,jl) = e_s(ji,jj,jk,jl) * area(ji,jj) * v_s(ji,jj,jl) / nlay_s 243 e_s(ji,jj,jk,jl) = rswitch * rhosn * ( cpic * ( rt0 - t_s(ji,jj,jk,jl) ) + lfus ) 244 ! Multiply by volume, so that heat content in J/m2 245 e_s(ji,jj,jk,jl) = e_s(ji,jj,jk,jl) * v_s(ji,jj,jl) * r1_nlay_s 250 246 END DO 251 247 DO jk = 1, nlay_i 252 ztmelts = - tmut * s_i(ji,jj,jk,jl) + rt t!Melting temperature in K248 ztmelts = - tmut * s_i(ji,jj,jk,jl) + rt0 !Melting temperature in K 253 249 ! heat content per unit volume 254 250 e_i(ji,jj,jk,jl) = rswitch * rhoic * & 255 251 ( cpic * ( ztmelts - t_i(ji,jj,jk,jl) ) & 256 + lfus * ( 1.0 - (ztmelts-rtt) / MIN((t_i(ji,jj,jk,jl)-rtt),-epsi20) ) & 257 - rcp * ( ztmelts - rtt ) ) 258 ! Correct dimensions to avoid big values 259 e_i(ji,jj,jk,jl) = e_i(ji,jj,jk,jl) / unit_fac 260 ! Mutliply by ice volume, and divide by number of layers to get heat content in 10^9 J 261 e_i(ji,jj,jk,jl) = e_i(ji,jj,jk,jl) * area(ji,jj) * a_i(ji,jj,jl) * ht_i(ji,jj,jl) / nlay_i 252 + lfus * ( 1.0 - (ztmelts-rt0) / MIN((t_i(ji,jj,jk,jl)-rt0),-epsi20) ) & 253 - rcp * ( ztmelts - rt0 ) ) 254 ! Mutliply by ice volume, and divide by number of layers to get heat content in J/m2 255 e_i(ji,jj,jk,jl) = e_i(ji,jj,jk,jl) * a_i(ji,jj,jl) * ht_i(ji,jj,jl) * r1_nlay_i 262 256 END DO 263 257 264 265 END DO !jb 258 END DO 266 259 267 CALL lbc_bdy_lnk( a_i(:,:,jl), 'T', 1., ib_bdy ) ! lateral boundary conditions260 CALL lbc_bdy_lnk( a_i(:,:,jl), 'T', 1., ib_bdy ) 268 261 CALL lbc_bdy_lnk( ht_i(:,:,jl), 'T', 1., ib_bdy ) 269 262 CALL lbc_bdy_lnk( ht_s(:,:,jl), 'T', 1., ib_bdy ) … … 274 267 CALL lbc_bdy_lnk( sm_i(:,:,jl), 'T', 1., ib_bdy ) 275 268 CALL lbc_bdy_lnk( oa_i(:,:,jl), 'T', 1., ib_bdy ) 276 CALL lbc_bdy_lnk( o_i(:,:,jl), 'T', 1., ib_bdy )277 269 CALL lbc_bdy_lnk( t_su(:,:,jl), 'T', 1., ib_bdy ) 278 270 DO jk = 1, nlay_s … … 306 298 !! 307 299 CHARACTER(len=1), INTENT(in) :: cd_type ! nature of velocity grid-points 308 INTEGER :: jb, jgrd ! dummy loop indices300 INTEGER :: jb, jgrd ! dummy loop indices 309 301 INTEGER :: ji, jj ! local scalar 310 INTEGER :: ib_bdy ! Loop index302 INTEGER :: ib_bdy ! Loop index 311 303 REAL(wp) :: zmsk1, zmsk2, zflag 312 304 !!------------------------------------------------------------------------------ … … 324 316 CASE('frs') 325 317 326 318 IF( nn_ice_lim_dta(ib_bdy) == 0 ) CYCLE ! case ice boundaries = initial conditions 319 ! do not change ice velocity (it is only computed by rheology) 320 327 321 SELECT CASE ( cd_type ) 328 322 329 323 CASE ( 'U' ) 330 324 … … 341 335 342 336 ! u_ice = u_ice of the adjacent grid point except if this grid point is ice-free (then u_ice = u_oce) 343 u_ice (ji,jj) = u_ice(ji+1,jj) * 0.5 * ABS( zflag + 1._wp ) * zmsk1 + &344 & u_ice(ji-1,jj) * 0.5 * ABS( zflag - 1._wp ) * zmsk2 + &337 u_ice (ji,jj) = u_ice(ji+1,jj) * 0.5_wp * ABS( zflag + 1._wp ) * zmsk1 + & 338 & u_ice(ji-1,jj) * 0.5_wp * ABS( zflag - 1._wp ) * zmsk2 + & 345 339 & u_oce(ji ,jj) * ( 1._wp - MIN( 1._wp, zmsk1 + zmsk2 ) ) 346 340 ELSE ! everywhere else … … 349 343 ENDIF 350 344 ! mask ice velocities 351 rswitch = 1.0 - MAX( 0.0_wp , SIGN ( 1.0_wp , - at_i(ji,jj) + 0.01) ) ! 0 if no ice345 rswitch = MAX( 0.0_wp , SIGN ( 1.0_wp , at_i(ji,jj) - 0.01_wp ) ) ! 0 if no ice 352 346 u_ice(ji,jj) = rswitch * u_ice(ji,jj) 353 347 354 348 ENDDO 355 349 356 350 CALL lbc_bdy_lnk( u_ice(:,:), 'U', -1., ib_bdy ) 357 351 … … 370 364 371 365 ! u_ice = u_ice of the adjacent grid point except if this grid point is ice-free (then u_ice = u_oce) 372 v_ice (ji,jj) = v_ice(ji,jj+1) * 0.5 * ABS( zflag + 1._wp ) * zmsk1 + &373 & v_ice(ji,jj-1) * 0.5 * ABS( zflag - 1._wp ) * zmsk2 + &366 v_ice (ji,jj) = v_ice(ji,jj+1) * 0.5_wp * ABS( zflag + 1._wp ) * zmsk1 + & 367 & v_ice(ji,jj-1) * 0.5_wp * ABS( zflag - 1._wp ) * zmsk2 + & 374 368 & v_oce(ji,jj ) * ( 1._wp - MIN( 1._wp, zmsk1 + zmsk2 ) ) 375 369 ELSE ! everywhere else … … 378 372 ENDIF 379 373 ! mask ice velocities 380 rswitch = 1.0 - MAX( 0.0_wp , SIGN ( 1.0_wp , - at_i(ji,jj) +0.01 ) ) ! 0 if no ice374 rswitch = MAX( 0.0_wp , SIGN ( 1.0_wp , at_i(ji,jj) - 0.01 ) ) ! 0 if no ice 381 375 v_ice(ji,jj) = rswitch * v_ice(ji,jj) 382 376 … … 384 378 385 379 CALL lbc_bdy_lnk( v_ice(:,:), 'V', -1., ib_bdy ) 386 380 387 381 END SELECT 388 382 -
branches/2014/dev_r4621_NOC4_BDY_VERT_INTERP/NEMOGCM/NEMO/OPA_SRC/BDY/bdyini.F90
r5038 r5620 155 155 ENDIF 156 156 IF(lwp) WRITE(numout,*) 157 157 158 158 IF(lwp) WRITE(numout,*) 'Boundary conditions for barotropic solution: ' 159 159 SELECT CASE( cn_dyn2d(ib_bdy) ) -
branches/2014/dev_r4621_NOC4_BDY_VERT_INTERP/NEMOGCM/NEMO/OPA_SRC/BDY/bdylib.F90
- Property svn:keywords set to Id
r4292 r5620 29 29 !!---------------------------------------------------------------------- 30 30 !! NEMO/OPA 3.3 , NEMO Consortium (2010) 31 !! $Id : bdydyn.F90 2528 2010-12-27 17:33:53Z rblod$31 !! $Id$ 32 32 !! Software governed by the CeCILL licence (NEMOGCM/NEMO_CeCILL.txt) 33 33 !!---------------------------------------------------------------------- -
branches/2014/dev_r4621_NOC4_BDY_VERT_INTERP/NEMOGCM/NEMO/OPA_SRC/BDY/bdytides.F90
r4792 r5620 32 32 USE tideini 33 33 ! USE tide_mod ! Useless ?? 34 USE fldread , ONLY: fld_map34 USE fldread 35 35 USE dynspg_oce, ONLY: lk_dynspg_ts 36 36 … … 88 88 !! 89 89 TYPE(TIDES_DATA), POINTER :: td !: local short cut 90 TYPE(MAP_POINTER), DIMENSION(jpbgrd) :: ibmap_ptr !: array of pointers to nbmap 90 91 !! 91 92 NAMELIST/nambdy_tide/filtide, ln_bdytide_2ddta, ln_bdytide_conj … … 125 126 IF(lwp) WRITE(numout,*) ' Number of tidal components to read: ', nb_harmo 126 127 IF(lwp) THEN 127 WRITE(numout,*) ' Tidal c pt name - Phase speed (deg/hr)'128 WRITE(numout,*) ' Tidal components: ' 128 129 DO itide = 1, nb_harmo 129 WRITE(numout,*) ' ', Wave(ntide(itide))%cname_tide, omega_tide(itide)130 WRITE(numout,*) ' ', Wave(ntide(itide))%cname_tide 130 131 END DO 131 132 ENDIF … … 220 221 ! 221 222 ALLOCATE( dta_read( MAXVAL(ilen0(1:3)), 1, 1 ) ) 223 ! 224 ! Set map structure 225 ibmap_ptr(1)%ptr => idx_bdy(ib_bdy)%nbmap(:,1) 226 ibmap_ptr(1)%ll_unstruc = ln_coords_file(ib_bdy) 227 ibmap_ptr(2)%ptr => idx_bdy(ib_bdy)%nbmap(:,2) 228 ibmap_ptr(2)%ll_unstruc = ln_coords_file(ib_bdy) 229 ibmap_ptr(3)%ptr => idx_bdy(ib_bdy)%nbmap(:,3) 230 ibmap_ptr(3)%ll_unstruc = ln_coords_file(ib_bdy) 222 231 223 232 ! Open files and read in tidal forcing data … … 228 237 clfile = TRIM(filtide)//TRIM(Wave(ntide(itide))%cname_tide)//'_grid_T.nc' 229 238 CALL iom_open( clfile, inum ) 230 CALL fld_map( inum, 'z1' , dta_read(1:ilen0(1),1:1,1:1) , 1, idx_bdy(ib_bdy)%nbmap(:,1) )239 CALL fld_map( inum, 'z1' , dta_read(1:ilen0(1),1:1,1:1) , 1, ibmap_ptr(1) ) 231 240 td%ssh0(:,itide,1) = dta_read(1:ilen0(1),1,1) 232 CALL fld_map( inum, 'z2' , dta_read(1:ilen0(1),1:1,1:1) , 1, idx_bdy(ib_bdy)%nbmap(:,1) )241 CALL fld_map( inum, 'z2' , dta_read(1:ilen0(1),1:1,1:1) , 1, ibmap_ptr(1) ) 233 242 td%ssh0(:,itide,2) = dta_read(1:ilen0(1),1,1) 234 243 CALL iom_close( inum ) … … 236 245 clfile = TRIM(filtide)//TRIM(Wave(ntide(itide))%cname_tide)//'_grid_U.nc' 237 246 CALL iom_open( clfile, inum ) 238 CALL fld_map( inum, 'u1' , dta_read(1:ilen0(2),1:1,1:1) , 1, i dx_bdy(ib_bdy)%nbmap(:,2) )247 CALL fld_map( inum, 'u1' , dta_read(1:ilen0(2),1:1,1:1) , 1, ibmap_ptr(2) ) 239 248 td%u0(:,itide,1) = dta_read(1:ilen0(2),1,1) 240 CALL fld_map( inum, 'u2' , dta_read(1:ilen0(2),1:1,1:1) , 1, i dx_bdy(ib_bdy)%nbmap(:,2) )249 CALL fld_map( inum, 'u2' , dta_read(1:ilen0(2),1:1,1:1) , 1, ibmap_ptr(2) ) 241 250 td%u0(:,itide,2) = dta_read(1:ilen0(2),1,1) 242 251 CALL iom_close( inum ) … … 244 253 clfile = TRIM(filtide)//TRIM(Wave(ntide(itide))%cname_tide)//'_grid_V.nc' 245 254 CALL iom_open( clfile, inum ) 246 CALL fld_map( inum, 'v1' , dta_read(1:ilen0(3),1:1,1:1) , 1, i dx_bdy(ib_bdy)%nbmap(:,3) )255 CALL fld_map( inum, 'v1' , dta_read(1:ilen0(3),1:1,1:1) , 1, ibmap_ptr(3) ) 247 256 td%v0(:,itide,1) = dta_read(1:ilen0(3),1,1) 248 CALL fld_map( inum, 'v2' , dta_read(1:ilen0(3),1:1,1:1) , 1, i dx_bdy(ib_bdy)%nbmap(:,3) )257 CALL fld_map( inum, 'v2' , dta_read(1:ilen0(3),1:1,1:1) , 1, ibmap_ptr(3) ) 249 258 td%v0(:,itide,2) = dta_read(1:ilen0(3),1,1) 250 259 CALL iom_close( inum ) -
branches/2014/dev_r4621_NOC4_BDY_VERT_INTERP/NEMOGCM/NEMO/OPA_SRC/C1D/c1d.F90
- Property svn:keywords set to Id
r4792 r5620 31 31 !!---------------------------------------------------------------------- 32 32 !! NEMO/C1D 3.3 , NEMO Consortium (2010) 33 !! $Id : c1d.F90 2382 2010-11-13 13:08:12Z gm$33 !! $Id$ 34 34 !! Software governed by the CeCILL licence (NEMOGCM/NEMO_CeCILL.txt) 35 35 !!====================================================================== -
branches/2014/dev_r4621_NOC4_BDY_VERT_INTERP/NEMOGCM/NEMO/OPA_SRC/C1D/domc1d.F90
- Property svn:keywords set to Id
r4792 r5620 26 26 !!---------------------------------------------------------------------- 27 27 !! NEMO/OPA 3.3 , NEMO Consortium (2010) 28 !! $Id : domc1d.F90 3851 2013-04-30 10:30:51Z hadcv$28 !! $Id$ 29 29 !! Software governed by the CeCILL licence (NEMOGCM/NEMO_CeCILL.txt) 30 30 !!---------------------------------------------------------------------- -
branches/2014/dev_r4621_NOC4_BDY_VERT_INTERP/NEMOGCM/NEMO/OPA_SRC/C1D/dtauvd.F90
- Property svn:keywords set to Id
r4792 r5620 35 35 !!---------------------------------------------------------------------- 36 36 !! NEMO/OPA 3.3 , NEMO Consortium (2010) 37 !! $Id : dtauvd.F90 2392 2010-11-15 21:20:05Z gm$37 !! $Id$ 38 38 !! Software governed by the CeCILL licence (NEMOGCM/NEMO_CeCILL.txt) 39 39 !!---------------------------------------------------------------------- -
branches/2014/dev_r4621_NOC4_BDY_VERT_INTERP/NEMOGCM/NEMO/OPA_SRC/C1D/dyncor_c1d.F90
- Property svn:keywords set to Id
r2409 r5620 30 30 !!---------------------------------------------------------------------- 31 31 !! NEMO/C1D 3.3 , NEMO Consortium (2010) 32 !! $Id : dyncor_c1d.F90 2382 2010-11-13 13:08:12Z gm$32 !! $Id$ 33 33 !! Software governed by the CeCILL licence (NEMOGCM/NEMO_CeCILL.txt) 34 34 !!---------------------------------------------------------------------- -
branches/2014/dev_r4621_NOC4_BDY_VERT_INTERP/NEMOGCM/NEMO/OPA_SRC/C1D/dyndmp.F90
- Property svn:keywords set to Id
r5038 r5620 3 3 !! *** MODULE dyndmp *** 4 4 !! Ocean dynamics: internal restoring trend on momentum (U and V current) 5 !! This should only be used for C1D case in current form 5 6 !!====================================================================== 6 7 !! History : 3.5 ! 2013-08 (D. Calvert) Original code 8 !! 3.6 ! 2014-08 (T. Graham) Modified to use netcdf file of 9 !! restoration coefficients supplied to tradmp 7 10 !!---------------------------------------------------------------------- 8 11 … … 25 28 USE wrk_nemo ! Memory allocation 26 29 USE timing ! Timing 30 USE iom ! I/O manager 27 31 28 32 IMPLICIT NONE … … 43 47 !!---------------------------------------------------------------------- 44 48 !! NEMO/OPA 3.3 , NEMO Consortium (2010) 45 !! $Id : dyndmp.F90 3294 2012-01-28 16:44:18Z rblod$49 !! $Id$ 46 50 !! Software governed by the CeCILL licence (NEMOGCM/NEMO_CeCILL.txt) 47 51 !!---------------------------------------------------------------------- … … 73 77 NAMELIST/namc1d_dyndmp/ ln_dyndmp 74 78 INTEGER :: ios 79 INTEGER :: imask 75 80 !!---------------------------------------------------------------------- 76 81 … … 91 96 WRITE(numout,*) ' add a damping term or not ln_dyndmp = ', ln_dyndmp 92 97 WRITE(numout,*) ' Namelist namtra_dmp : Set damping parameters' 93 WRITE(numout,*) ' horizontal damping option nn_hdmp = ', nn_hdmp 94 WRITE(numout,*) ' mixed layer damping option nn_zdmp = ', nn_zdmp, '(non-C1D zoom: forced to 0)' 95 WRITE(numout,*) ' surface time scale (days) rn_surf = ', rn_surf 96 WRITE(numout,*) ' bottom time scale (days) rn_bot = ', rn_bot 97 WRITE(numout,*) ' depth of transition (meters) rn_dep = ', rn_dep 98 WRITE(numout,*) ' create a damping.coeff file nn_file = ', nn_file 98 WRITE(numout,*) ' Apply relaxation or not ln_tradmp = ', ln_tradmp 99 WRITE(numout,*) ' mixed layer damping option nn_zdmp = ', nn_zdmp 100 WRITE(numout,*) ' Damping file name cn_resto = ', cn_resto 99 101 WRITE(numout,*) 100 102 ENDIF … … 104 106 IF( dyn_dmp_alloc() /= 0 ) CALL ctl_stop( 'STOP', 'dyn_dmp_init: unable to allocate arrays' ) 105 107 ! 106 #if ! defined key_c1d107 SELECT CASE ( nn_hdmp ) !== control print of horizontal option ==!108 CASE ( -1 ) ; IF(lwp) WRITE(numout,*) ' momentum damping in the Med & Red seas only'109 CASE ( 1:90 ) ; IF(lwp) WRITE(numout,*) ' momentum damping poleward of', nn_hdmp, ' degrees'110 CASE DEFAULT111 WRITE(ctmp1,*) ' bad flag value for nn_hdmp = ', nn_hdmp112 CALL ctl_stop(ctmp1)113 END SELECT114 !115 #endif116 108 SELECT CASE ( nn_zdmp ) !== control print of vertical option ==! 117 109 CASE ( 0 ) ; IF(lwp) WRITE(numout,*) ' momentum damping throughout the water column' … … 130 122 utrdmp(:,:,:) = 0._wp ! internal damping trends 131 123 vtrdmp(:,:,:) = 0._wp 132 ! !== Damping coefficients calculation: ==! 133 ! !== use tradmp.F90 subroutines dtacof, dtacof_zoom and cofdis ==! 134 ! !!! NOTE: these need to be altered for use in this module if 135 ! !!! they are to be used outside the C1D context 136 ! !!! (use of U,V grid variables) 137 IF( lzoom .AND. .NOT. lk_c1d ) THEN ; CALL dtacof_zoom( resto_uv ) 138 ELSE ; CALL dtacof( nn_hdmp, rn_surf, rn_bot, rn_dep, nn_file, 'DYN', resto_uv ) 139 ENDIF 140 ! 124 ! 125 !Read in mask from file 126 CALL iom_open ( cn_resto, imask) 127 CALL iom_get ( imask, jpdom_autoglo, 'resto', resto) 128 CALL iom_close( imask ) 141 129 ENDIF 142 130 ! -
branches/2014/dev_r4621_NOC4_BDY_VERT_INTERP/NEMOGCM/NEMO/OPA_SRC/C1D/dynnxt_c1d.F90
- Property svn:keywords set to Id
r2409 r5620 25 25 !!---------------------------------------------------------------------- 26 26 !! NEMO/C1D 3.3 , NEMO Consortium (2010) 27 !! $Id : dynnxt_c1d.F90 2382 2010-11-13 13:08:12Z gm$27 !! $Id$ 28 28 !! Software governed by the CeCILL licence (NEMOGCM/NEMO_CeCILL.txt) 29 29 !!---------------------------------------------------------------------- -
branches/2014/dev_r4621_NOC4_BDY_VERT_INTERP/NEMOGCM/NEMO/OPA_SRC/C1D/step_c1d.F90
- Property svn:keywords set to Id
r5038 r5620 32 32 !!---------------------------------------------------------------------- 33 33 !! NEMO/C1D 3.3 , NEMO Consortium (2010) 34 !! $Id : step_c1d.F90 2382 2010-11-13 13:08:12Z gm$34 !! $Id$ 35 35 !! Software governed by the CeCILL licence (NEMOGCM/NEMO_CeCILL.txt) 36 36 !!---------------------------------------------------------------------- … … 72 72 ! Ocean physics update (ua, va, ta, sa used as workspace) 73 73 !<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<< 74 CALL eos_rab( tsb, rab_b ) ! before local thermal/haline expension ratio at T-points 75 CALL eos_rab( tsn, rab_n ) ! now local thermal/haline expension ratio at T-points 74 76 CALL bn2( tsb, rab_b, rn2b ) ! before Brunt-Vaisala frequency 75 77 CALL bn2( tsn, rab_n, rn2 ) ! now Brunt-Vaisala frequency … … 132 134 CALL tra_nxt( kstp ) ! tracer fields at next time step 133 135 136 137 134 138 !>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>> 135 139 ! Dynamics (ta, sa used as workspace) … … 150 154 IF( lrst_oce ) CALL rst_write( kstp ) ! write output ocean restart file 151 155 ! 156 #if defined key_iomput 157 IF( kstp == nitend .OR. indic < 0 ) CALL xios_context_finalize() ! needed for XIOS 158 ! 159 #endif 152 160 END SUBROUTINE stp_c1d 153 161 -
branches/2014/dev_r4621_NOC4_BDY_VERT_INTERP/NEMOGCM/NEMO/OPA_SRC/CRS/crs.F90
- Property svn:keywords set to Id
r4064 r5620 164 164 165 165 166 !! $Id$ 166 167 CONTAINS 167 168 -
branches/2014/dev_r4621_NOC4_BDY_VERT_INTERP/NEMOGCM/NEMO/OPA_SRC/CRS/crsdom.F90
- Property svn:keywords set to Id
r4314 r5620 57 57 # include "domzgr_substitute.h90" 58 58 59 !! $Id$ 59 60 CONTAINS 60 61 … … 1882 1883 CALL crs_lbc_lnk( p_surf_crs_msk, cd_type, 1.0, pval=1.0 ) 1883 1884 1884 CALL wrk_dealloc( jpi, jpj, jpk, zsurf , zsurfmsk)1885 CALL wrk_dealloc( jpi, jpj, jpk, zsurfmsk, zsurf ) 1885 1886 1886 1887 END SUBROUTINE crs_dom_sfc … … 2274 2275 ENDDO 2275 2276 2276 CALL wrk_alloc( jpi_crs, jpj_crs, zmbk )2277 2278 2277 zmbk(:,:) = 0.0 2279 2278 zmbk(:,:) = REAL( mbathy_crs(:,:), wp ) ; CALL crs_lbc_lnk(zmbk,'T',1.0) ; mbathy_crs(:,:) = INT( zmbk(:,:) ) -
branches/2014/dev_r4621_NOC4_BDY_VERT_INTERP/NEMOGCM/NEMO/OPA_SRC/CRS/crsdomwri.F90
- Property svn:keywords set to Id
r4294 r5620 33 33 PUBLIC crs_dom_wri ! routine called by crsini.F90 34 34 35 !! $Id$ 35 36 CONTAINS 36 37 -
branches/2014/dev_r4621_NOC4_BDY_VERT_INTERP/NEMOGCM/NEMO/OPA_SRC/CRS/crsfld.F90
- Property svn:keywords set to Id
r4149 r5620 38 38 !!---------------------------------------------------------------------- 39 39 !! NEMO/OPA 3.3 , NEMO Consortium (2010) 40 !! $Id 40 !! $Id$ 41 41 !! Software governed by the CeCILL licence (NEMOGCM/NEMO_CeCILL.txt) 42 42 !!---------------------------------------------------------------------- -
branches/2014/dev_r4621_NOC4_BDY_VERT_INTERP/NEMOGCM/NEMO/OPA_SRC/CRS/crsini.F90
- Property svn:keywords set to Id
r4792 r5620 29 29 # include "domzgr_substitute.h90" 30 30 31 !! $Id$ 31 32 CONTAINS 32 33 -
branches/2014/dev_r4621_NOC4_BDY_VERT_INTERP/NEMOGCM/NEMO/OPA_SRC/CRS/crslbclnk.F90
- Property svn:keywords set to Id
r4015 r5620 22 22 PUBLIC crs_lbc_lnk 23 23 24 !! $Id$ 24 25 CONTAINS 25 26 -
branches/2014/dev_r4621_NOC4_BDY_VERT_INTERP/NEMOGCM/NEMO/OPA_SRC/DIA/diaar5.F90
r5038 r5620 21 21 USE timing ! preformance summary 22 22 USE wrk_nemo ! working arrays 23 USE fldread ! type FLD_N 24 USE phycst ! physical constant 25 USE in_out_manager ! I/O manager 23 26 24 27 IMPLICIT NONE … … 83 86 CALL wrk_alloc( jpi , jpj , jpk , jpts , ztsn ) 84 87 85 CALL iom_put( 'cellthc', fse3t(:,:,:) )86 87 88 zarea_ssh(:,:) = area(:,:) * sshn(:,:) 88 89 … … 105 106 END DO 106 107 IF( .NOT.lk_vvl ) THEN 107 DO ji=1,jpi 108 DO jj=1,jpj 109 zbotpres(ji,jj) = zbotpres(ji,jj) + sshn(ji,jj) * zrhd(ji,jj,mikt(ji,jj)) + riceload(ji,jj) 110 END DO 111 END DO 108 IF ( ln_isfcav ) THEN 109 DO ji=1,jpi 110 DO jj=1,jpj 111 zbotpres(ji,jj) = zbotpres(ji,jj) + sshn(ji,jj) * zrhd(ji,jj,mikt(ji,jj)) + riceload(ji,jj) 112 END DO 113 END DO 114 ELSE 115 zbotpres(:,:) = zbotpres(:,:) + sshn(:,:) * zrhd(:,:,1) 116 END IF 112 117 END IF 113 118 ! … … 127 132 END DO 128 133 IF( .NOT.lk_vvl ) THEN 129 DO ji=1,jpi 130 DO jj=1,jpj 131 zbotpres(ji,jj) = zbotpres(ji,jj) + sshn(ji,jj) * zrhd(ji,jj,mikt(ji,jj)) + riceload(ji,jj) 132 END DO 133 END DO 134 IF ( ln_isfcav ) THEN 135 DO ji=1,jpi 136 DO jj=1,jpj 137 zbotpres(ji,jj) = zbotpres(ji,jj) + sshn(ji,jj) * zrhd(ji,jj,mikt(ji,jj)) + riceload(ji,jj) 138 END DO 139 END DO 140 ELSE 141 zbotpres(:,:) = zbotpres(:,:) + sshn(:,:) * zrhd(:,:,1) 142 END IF 134 143 END IF 135 144 ! … … 157 166 END DO 158 167 IF( .NOT.lk_vvl ) THEN 159 DO ji=1,jpi 160 DO jj=1,jpj 161 ztemp = ztemp + zarea_ssh(ji,jj) * tsn(ji,jj,mikt(ji,jj),jp_tem) 162 zsal = zsal + zarea_ssh(ji,jj) * tsn(ji,jj,mikt(ji,jj),jp_sal) 163 END DO 164 END DO 168 IF ( ln_isfcav ) THEN 169 DO ji=1,jpi 170 DO jj=1,jpj 171 ztemp = ztemp + zarea_ssh(ji,jj) * tsn(ji,jj,mikt(ji,jj),jp_tem) 172 zsal = zsal + zarea_ssh(ji,jj) * tsn(ji,jj,mikt(ji,jj),jp_sal) 173 END DO 174 END DO 175 ELSE 176 ztemp = ztemp + SUM( zarea_ssh(:,:) * tsn(:,:,1,jp_tem) ) 177 zsal = zsal + SUM( zarea_ssh(:,:) * tsn(:,:,1,jp_sal) ) 178 END IF 165 179 ENDIF 166 180 IF( lk_mpp ) THEN … … 197 211 REAL(wp) :: zztmp 198 212 REAL(wp), POINTER, DIMENSION(:,:,:,:) :: zsaldta ! Jan/Dec levitus salinity 213 ! reading initial file 214 LOGICAL :: ln_tsd_init !: T & S data flag 215 LOGICAL :: ln_tsd_tradmp !: internal damping toward input data flag 216 CHARACTER(len=100) :: cn_dir 217 TYPE(FLD_N) :: sn_tem,sn_sal 218 INTEGER :: ios=0 219 220 NAMELIST/namtsd/ ln_tsd_init,ln_tsd_tradmp,cn_dir,sn_tem,sn_sal 221 ! 222 223 REWIND( numnam_ref ) ! Namelist namtsd in reference namelist : 224 READ ( numnam_ref, namtsd, IOSTAT = ios, ERR = 901) 225 901 IF( ios /= 0 ) CALL ctl_nam ( ios , ' namtsd in reference namelist for dia_ar5', lwp ) 226 REWIND( numnam_cfg ) ! Namelist namtsd in configuration namelist : Parameters of the run 227 READ ( numnam_cfg, namtsd, IOSTAT = ios, ERR = 902 ) 228 902 IF( ios /= 0 ) CALL ctl_nam ( ios , ' namtsd in configuration namelist for dia_ar5', lwp ) 229 IF(lwm) WRITE ( numond, namtsd ) 230 ! 199 231 !!---------------------------------------------------------------------- 200 232 ! … … 216 248 END DO 217 249 IF( lk_mpp ) CALL mpp_sum( vol0 ) 218 219 CALL iom_open ( 'data_1m_salinity_nomask', inum )220 CALL iom_get ( inum, jpdom_data, 'vosaline', zsaldta(:,:,:,1), 1 )221 CALL iom_get ( inum, jpdom_data, 'vosaline', zsaldta(:,:,:,2), 12 )250 251 CALL iom_open ( TRIM( cn_dir )//TRIM(sn_sal%clname), inum ) 252 CALL iom_get ( inum, jpdom_data, TRIM(sn_sal%clvar), zsaldta(:,:,:,1), 1 ) 253 CALL iom_get ( inum, jpdom_data, TRIM(sn_sal%clvar), zsaldta(:,:,:,2), 12 ) 222 254 CALL iom_close( inum ) 223 255 sn0(:,:,:) = 0.5_wp * ( zsaldta(:,:,:,1) + zsaldta(:,:,:,2) ) -
branches/2014/dev_r4621_NOC4_BDY_VERT_INTERP/NEMOGCM/NEMO/OPA_SRC/DIA/diadct.F90
- Property svn:keywords set to Id
r4792 r5620 42 42 #endif 43 43 #if defined key_lim3 44 USE par_ice45 44 USE ice 46 45 #endif … … 113 112 REAL(wp), ALLOCATABLE, DIMENSION(:,:,:) :: transports_2d 114 113 114 !! $Id$ 115 115 CONTAINS 116 116 … … 176 176 177 177 !open output file 178 IF( lw p) THEN178 IF( lwm ) THEN 179 179 CALL ctl_opn( numdct_vol, 'volume_transport', 'NEW', 'FORMATTED', 'SEQUENTIAL', -1, numout, .FALSE. ) 180 180 CALL ctl_opn( numdct_heat, 'heat_transport' , 'NEW', 'FORMATTED', 'SEQUENTIAL', -1, numout, .FALSE. ) … … 283 283 DO jsec=1,nb_sec 284 284 285 IF( lw p)CALL dia_dct_wri(kt,jsec,secs(jsec))285 IF( lwm )CALL dia_dct_wri(kt,jsec,secs(jsec)) 286 286 287 287 !nullify transports values after writing … … 1298 1298 LOGICAL, PUBLIC, PARAMETER :: lk_diadct = .FALSE. !: diamht flag 1299 1299 PUBLIC 1300 !! $Id$ 1300 1301 CONTAINS 1301 1302 -
branches/2014/dev_r4621_NOC4_BDY_VERT_INTERP/NEMOGCM/NEMO/OPA_SRC/DIA/diafwb.F90
r5038 r5620 51 51 INTEGER, INTENT( in ) :: kt ! ocean time-step index 52 52 !! 53 INTEGER :: inum ! temporary logical unit 54 INTEGER :: ji, jj, jk, jt ! dummy loop indices 55 INTEGER :: ii0, ii1, ij0, ij1 56 REAL(wp) :: zarea, zvol, zwei 57 REAL(wp) :: ztemi(4), ztemo(4), zsali(4), zsalo(4), zflxi(4), zflxo(4) 58 REAL(wp) :: zt, zs, zu 59 REAL(wp) :: zsm0, zfwfnew 53 INTEGER :: inum ! temporary logical unit 54 INTEGER :: ji, jj, jk, jt ! dummy loop indices 55 INTEGER :: ii0, ii1, ij0, ij1 56 INTEGER :: isrow ! index for ORCA1 starting row 57 REAL(wp) :: zarea, zvol, zwei 58 REAL(wp) :: ztemi(4), ztemo(4), zsali(4), zsalo(4), zflxi(4), zflxo(4) 59 REAL(wp) :: zt, zs, zu 60 REAL(wp) :: zsm0, zfwfnew 60 61 IF( cp_cfg == "orca" .AND. jp_cfg == 1 .OR. jp_cfg == 2 .OR. jp_cfg == 4 ) THEN 61 62 !!---------------------------------------------------------------------- … … 165 166 CASE ( 1 ) ! ORCA_R1 configurations 166 167 ! ! ======================= 167 ii0 = 283 ; ii1 = 283 168 ij0 = 200 ; ij1 = 200 168 ! This dirty section will be suppressed by simplification process: 169 ! all this will come back in input files 170 ! Currently these hard-wired indices relate to configuration with 171 ! extend grid (jpjglo=332) 172 isrow = 332 - jpjglo 173 ! 174 ii0 = 283 ; ii1 = 283 175 ij0 = 241 - isrow ; ij1 = 241 - isrow 169 176 ! ! ======================= 170 177 CASE DEFAULT ! ORCA R05 or R025 … … 212 219 CASE ( 1 ) ! ORCA_R1 configurations 213 220 ! ! ======================= 214 ii0 = 282 ; ii1 = 282 215 ij0 = 200 ; ij1 = 200 221 ! This dirty section will be suppressed by simplification process: 222 ! all this will come back in input files 223 ! Currently these hard-wired indices relate to configuration with 224 ! extend grid (jpjglo=332) 225 isrow = 332 - jpjglo 226 ii0 = 282 ; ii1 = 282 227 ij0 = 240 - isrow ; ij1 = 240 - isrow 216 228 ! ! ======================= 217 229 CASE DEFAULT ! ORCA R05 or R025 … … 259 271 CASE ( 1 ) ! ORCA_R1 configurations 260 272 ! ! ======================= 261 ii0 = 331 ; ii1 = 331 262 ij0 = 176 ; ij1 = 176 273 ! This dirty section will be suppressed by simplification process: 274 ! all this will come back in input files 275 ! Currently these hard-wired indices relate to configuration with 276 ! extend grid (jpjglo=332) 277 isrow = 332 - jpjglo 278 ii0 = 331 ; ii1 = 331 279 ij0 = 215 - isrow ; ij1 = 215 - isrow 263 280 ! ! ======================= 264 281 CASE DEFAULT ! ORCA R05 or R025 … … 306 323 CASE ( 1 ) ! ORCA_R1 configurations 307 324 ! ! ======================= 308 ii0 = 297 ; ii1 = 297 309 ij0 = 230 ; ij1 = 230 325 ! This dirty section will be suppressed by simplification process: 326 ! all this will come back in input files 327 ! Currently these hard-wired indices relate to configuration with 328 ! extend grid (jpjglo=332) 329 isrow = 332 - jpjglo 330 ii0 = 297 ; ii1 = 297 331 ij0 = 269 - isrow ; ij1 = 269 - isrow 310 332 ! ! ======================= 311 333 CASE DEFAULT ! ORCA R05 or R025 -
branches/2014/dev_r4621_NOC4_BDY_VERT_INTERP/NEMOGCM/NEMO/OPA_SRC/DIA/diaharm.F90
- Property svn:keywords set to Id
r5038 r5620 60 60 !!---------------------------------------------------------------------- 61 61 !! NEMO/OPA 3.5 , NEMO Consortium (2013) 62 !! $Id :$62 !! $Id$ 63 63 !! Software governed by the CeCILL licence (NEMOGCM/NEMO_CeCILL.txt) 64 64 !!---------------------------------------------------------------------- … … 196 196 DO ji = 1,jpi 197 197 ! Elevation 198 ana_temp(ji,jj,nhc,1) = ana_temp(ji,jj,nhc,1) + ztemp*sshn(ji,jj) *tmask_i(ji,jj) 199 #if defined key_dynspg_ts 200 ana_temp(ji,jj,nhc,2) = ana_temp(ji,jj,nhc,2) + ztemp*un_b(ji,jj)*hur(ji,jj)*umask_i(ji,jj) 201 ana_temp(ji,jj,nhc,3) = ana_temp(ji,jj,nhc,3) + ztemp*vn_b(ji,jj)*hvr(ji,jj)*vmask_i(ji,jj) 202 #endif 198 ana_temp(ji,jj,nhc,1) = ana_temp(ji,jj,nhc,1) + ztemp*sshn(ji,jj)*tmask_i(ji,jj) 199 ana_temp(ji,jj,nhc,2) = ana_temp(ji,jj,nhc,2) + ztemp*un_b(ji,jj)*umask_i(ji,jj) 200 ana_temp(ji,jj,nhc,3) = ana_temp(ji,jj,nhc,3) + ztemp*vn_b(ji,jj)*vmask_i(ji,jj) 203 201 END DO 204 202 END DO -
branches/2014/dev_r4621_NOC4_BDY_VERT_INTERP/NEMOGCM/NEMO/OPA_SRC/DIA/diahsb.F90
r5038 r5620 96 96 z_frc_trd_t = glob_sum( sbc_tsc(:,:,jp_tem) * surf(:,:) ) ! heat fluxes 97 97 z_frc_trd_s = glob_sum( sbc_tsc(:,:,jp_sal) * surf(:,:) ) ! salt fluxes 98 ! Add runoff heat & salt input98 ! Add runoff heat & salt input 99 99 IF( ln_rnf ) z_frc_trd_t = z_frc_trd_t + glob_sum( rnf_tsc(:,:,jp_tem) * surf(:,:) ) 100 100 IF( ln_rnf_sal) z_frc_trd_s = z_frc_trd_s + glob_sum( rnf_tsc(:,:,jp_sal) * surf(:,:) ) 101 ! Add geothermal ice shelf101 ! Add ice shelf heat & salt input 102 102 IF( nn_isf .GE. 1 ) THEN 103 103 z_frc_trd_t = z_frc_trd_t & … … 112 112 ! 113 113 IF( .NOT. lk_vvl ) THEN 114 z2d0=0.0_wp ; z2d1=0.0_wp 115 DO ji=1,jpi 116 DO jj=1,jpj 117 z2d0(ji,jj) = surf(ji,jj) * wn(ji,jj,mikt(ji,jj)) * tsb(ji,jj,mikt(ji,jj),jp_tem) 118 z2d1(ji,jj) = surf(ji,jj) * wn(ji,jj,mikt(ji,jj)) * tsb(ji,jj,mikt(ji,jj),jp_sal) 114 IF ( ln_isfcav ) THEN 115 DO ji=1,jpi 116 DO jj=1,jpj 117 z2d0(ji,jj) = surf(ji,jj) * wn(ji,jj,mikt(ji,jj)) * tsb(ji,jj,mikt(ji,jj),jp_tem) 118 z2d1(ji,jj) = surf(ji,jj) * wn(ji,jj,mikt(ji,jj)) * tsb(ji,jj,mikt(ji,jj),jp_sal) 119 ENDDO 119 120 ENDDO 120 ENDDO 121 ELSE 122 z2d0(:,:) = surf(:,:) * wn(:,:,1) * tsb(:,:,1,jp_tem) 123 z2d1(:,:) = surf(:,:) * wn(:,:,1) * tsb(:,:,1,jp_sal) 124 END IF 121 125 z_wn_trd_t = - glob_sum( z2d0 ) 122 126 z_wn_trd_s = - glob_sum( z2d1 ) … … 144 148 ! heat & salt content variation (associated with ssh) 145 149 IF( .NOT. lk_vvl ) THEN 146 z2d0 = 0._wp ; z2d1 = 0._wp 147 DO ji = 1, jpi 148 DO jj = 1, jpj 149 z2d0(ji,jj) = surf(ji,jj) * ( tsn(ji,jj,mikt(ji,jj),jp_tem) * sshn(ji,jj) - ssh_hc_loc_ini(ji,jj) ) 150 z2d1(ji,jj) = surf(ji,jj) * ( tsn(ji,jj,mikt(ji,jj),jp_sal) * sshn(ji,jj) - ssh_sc_loc_ini(ji,jj) ) 150 IF ( ln_isfcav ) THEN 151 DO ji = 1, jpi 152 DO jj = 1, jpj 153 z2d0(ji,jj) = surf(ji,jj) * ( tsn(ji,jj,mikt(ji,jj),jp_tem) * sshn(ji,jj) - ssh_hc_loc_ini(ji,jj) ) 154 z2d1(ji,jj) = surf(ji,jj) * ( tsn(ji,jj,mikt(ji,jj),jp_sal) * sshn(ji,jj) - ssh_sc_loc_ini(ji,jj) ) 155 END DO 151 156 END DO 152 END DO 157 ELSE 158 z2d0(:,:) = surf(:,:) * ( tsn(:,:,1,jp_tem) * sshn(:,:) - ssh_hc_loc_ini(:,:) ) 159 z2d1(:,:) = surf(:,:) * ( tsn(:,:,1,jp_sal) * sshn(:,:) - ssh_sc_loc_ini(:,:) ) 160 END IF 153 161 z_ssh_hc = glob_sum( z2d0 ) 154 162 z_ssh_sc = glob_sum( z2d1 ) … … 277 285 frc_s = 0._wp ! salt content - - - - 278 286 IF( .NOT. lk_vvl ) THEN 279 DO ji=1,jpi 280 DO jj=1,jpj 281 ssh_hc_loc_ini(ji,jj) = tsn(ji,jj,mikt(ji,jj),jp_tem) * sshn(ji,jj) ! initial heat content in ssh 282 ssh_sc_loc_ini(ji,jj) = tsn(ji,jj,mikt(ji,jj),jp_sal) * sshn(ji,jj) ! initial salt content in ssh 287 IF ( ln_isfcav ) THEN 288 DO ji=1,jpi 289 DO jj=1,jpj 290 ssh_hc_loc_ini(ji,jj) = tsn(ji,jj,mikt(ji,jj),jp_tem) * sshn(ji,jj) ! initial heat content in ssh 291 ssh_sc_loc_ini(ji,jj) = tsn(ji,jj,mikt(ji,jj),jp_sal) * sshn(ji,jj) ! initial salt content in ssh 292 ENDDO 283 293 ENDDO 284 ENDDO 294 ELSE 295 ssh_hc_loc_ini(:,:) = tsn(:,:,1,jp_tem) * sshn(:,:) ! initial heat content in ssh 296 ssh_sc_loc_ini(:,:) = tsn(:,:,1,jp_sal) * sshn(:,:) ! initial salt content in ssh 297 END IF 285 298 frc_wn_t = 0._wp ! initial heat content misfit due to free surface 286 299 frc_wn_s = 0._wp ! initial salt content misfit due to free surface -
branches/2014/dev_r4621_NOC4_BDY_VERT_INTERP/NEMOGCM/NEMO/OPA_SRC/DIA/diahth.F90
r4292 r5620 245 245 CALL iom_put( "mldr10_3", zrho10_3 ) ! MLD delta rho(10m) = 0.03 246 246 CALL iom_put( "pycndep" , zpycn ) ! MLD delta rho equi. delta T(10m) = 0.2 247 CALL iom_put( "BLT" , ztm2 - zpycn ) ! Barrier Layer Thickness248 247 CALL iom_put( "tinv" , ztinv ) ! max. temp. inv. (t10 ref) 249 248 CALL iom_put( "depti" , zdepinv ) ! depth of max. temp. inv. (t10 ref) -
branches/2014/dev_r4621_NOC4_BDY_VERT_INTERP/NEMOGCM/NEMO/OPA_SRC/DIA/diaptr.F90
r5038 r5620 8 8 !! 3.2 ! 2010-03 (O. Marti, S. Flavoni) Add fields 9 9 !! 3.3 ! 2010-10 (G. Madec) dynamical allocation 10 !! 3.6 ! 2014-12 (C. Ethe) use of IOM 10 11 !!---------------------------------------------------------------------- 11 12 … … 13 14 !! dia_ptr : Poleward Transport Diagnostics module 14 15 !! dia_ptr_init : Initialization, namelist read 15 !! dia_ptr_wri : Output of poleward fluxes 16 !! ptr_vjk : "zonal" sum computation of a "meridional" flux array 17 !! ptr_tjk : "zonal" mean computation of a tracer field 18 !! ptr_vj : "zonal" and vertical sum computation of a "meridional" flux array 19 !! (Generic interface to ptr_vj_3d, ptr_vj_2d) 16 !! ptr_sjk : "zonal" mean computation of a field - tracer or flux array 17 !! ptr_sj : "zonal" and vertical sum computation of a "meridional" flux array 18 !! (Generic interface to ptr_sj_3d, ptr_sj_2d) 20 19 !!---------------------------------------------------------------------- 21 20 USE oce ! ocean dynamics and active tracers 22 21 USE dom_oce ! ocean space and time domain 23 22 USE phycst ! physical constants 24 USE ldftra_oce ! ocean active tracers: lateral physics 25 USE dianam ! 23 ! 26 24 USE iom ! IOM library 27 USE ioipsl ! IO-IPSL library28 25 USE in_out_manager ! I/O manager 29 26 USE lib_mpp ! MPP library 30 USE lbclnk ! lateral boundary condition - processor exchanges31 27 USE timing ! preformance summary 32 USE wrk_nemo ! working arrays33 28 34 29 IMPLICIT NONE 35 30 PRIVATE 36 31 37 INTERFACE ptr_ vj38 MODULE PROCEDURE ptr_ vj_3d, ptr_vj_2d32 INTERFACE ptr_sj 33 MODULE PROCEDURE ptr_sj_3d, ptr_sj_2d 39 34 END INTERFACE 40 35 41 PUBLIC dia_ptr_init ! call in opa module 36 PUBLIC ptr_sj ! call by tra_ldf & tra_adv routines 37 PUBLIC ptr_sjk ! 38 PUBLIC dia_ptr_init ! call in step module 42 39 PUBLIC dia_ptr ! call in step module 43 PUBLIC ptr_vj ! call by tra_ldf & tra_adv routines44 PUBLIC ptr_vjk ! call by tra_ldf & tra_adv routines45 40 46 41 ! !!** namelist namptr ** 47 LOGICAL , PUBLIC :: ln_diaptr !: Poleward transport flag (T) or not (F) 48 LOGICAL , PUBLIC :: ln_subbas !: Atlantic/Pacific/Indian basins calculation 49 LOGICAL , PUBLIC :: ln_diaznl !: Add zonal means and meridional stream functions 50 LOGICAL , PUBLIC :: ln_ptrcomp !: Add decomposition : overturning (and gyre, soon ...) 51 INTEGER , PUBLIC :: nn_fptr !: frequency of ptr computation [time step] 52 INTEGER , PUBLIC :: nn_fwri !: frequency of ptr outputs [time step] 53 54 REAL(wp), ALLOCATABLE, SAVE, PUBLIC, DIMENSION(:) :: htr_adv, htr_ldf, htr_ove !: Heat TRansports (adv, diff, overturn.) 55 REAL(wp), ALLOCATABLE, SAVE, PUBLIC, DIMENSION(:) :: str_adv, str_ldf, str_ove !: Salt TRansports (adv, diff, overturn.) 42 REAL(wp), ALLOCATABLE, SAVE, PUBLIC, DIMENSION(:) :: htr_adv, htr_ldf !: Heat TRansports (adv, diff, overturn.) 43 REAL(wp), ALLOCATABLE, SAVE, PUBLIC, DIMENSION(:) :: str_adv, str_ldf !: Salt TRansports (adv, diff, overturn.) 56 44 57 REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: btmsk ! T-point basin interior masks 58 REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:) :: btm30 ! mask out Southern Ocean (=0 south of 30°S) 59 REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:) :: htr , str ! adv heat and salt transports (approx) 60 REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: tn_jk, sn_jk , v_msf ! i-mean T and S, j-Stream-Function 61 REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: sjk , r1_sjk ! i-mean i-k-surface and its inverse 62 REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:) :: htr_eiv, str_eiv ! bolus adv heat ans salt transports ('key_diaeiv') 63 REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: v_msf_eiv ! bolus j-streamfuction ('key_diaeiv') 64 65 66 INTEGER :: niter ! 67 INTEGER :: nidom_ptr ! 68 INTEGER :: numptr ! logical unit for Poleward TRansports 69 INTEGER :: nptr ! = 1 (ln_subbas=F) or = 5 (glo, atl, pac, ind, ipc) (ln_subbas=T) 45 46 LOGICAL, PUBLIC :: ln_diaptr ! Poleward transport flag (T) or not (F) 47 LOGICAL, PUBLIC :: ln_subbas ! Atlantic/Pacific/Indian basins calculation 48 INTEGER :: nptr ! = 1 (l_subbas=F) or = 5 (glo, atl, pac, ind, ipc) (l_subbas=T) 70 49 71 50 REAL(wp) :: rc_sv = 1.e-6_wp ! conversion from m3/s to Sverdrup … … 73 52 REAL(wp) :: rc_ggram = 1.e-6_wp ! conversion from g to Pg 74 53 75 REAL(wp), TARGET, DIMENSION(:), ALLOCATABLE, SAVE :: p_fval1d 76 REAL(wp), TARGET, DIMENSION(:,:), ALLOCATABLE, SAVE :: p_fval2d 77 78 !! Integer, 1D workspace arrays. Not common enough to be implemented in 79 !! wrk_nemo module. 80 INTEGER, ALLOCATABLE, SAVE, DIMENSION(:) :: ndex , ndex_atl , ndex_pac , ndex_ind , ndex_ipc 81 INTEGER, ALLOCATABLE, SAVE, DIMENSION(:) :: ndex_atl_30 , ndex_pac_30 , ndex_ind_30 , ndex_ipc_30 82 INTEGER, ALLOCATABLE, SAVE, DIMENSION(:) :: ndex_h, ndex_h_atl_30, ndex_h_pac_30, ndex_h_ind_30, ndex_h_ipc_30 54 CHARACTER(len=3), ALLOCATABLE, SAVE, DIMENSION(:) :: clsubb 55 REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: btmsk ! T-point basin interior masks 56 REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:) :: btm30 ! mask out Southern Ocean (=0 south of 30°S) 57 58 REAL(wp), TARGET, ALLOCATABLE, SAVE, DIMENSION(:) :: p_fval1d 59 REAL(wp), TARGET, ALLOCATABLE, SAVE, DIMENSION(:,:) :: p_fval2d 60 83 61 84 62 !! * Substitutions … … 92 70 CONTAINS 93 71 94 FUNCTION dia_ptr_alloc() 95 !!---------------------------------------------------------------------- 96 !! *** ROUTINE dia_ptr_alloc *** 97 !!---------------------------------------------------------------------- 98 INTEGER :: dia_ptr_alloc ! return value 99 INTEGER, DIMENSION(6) :: ierr 100 !!---------------------------------------------------------------------- 101 ierr(:) = 0 102 ! 103 ALLOCATE( btmsk(jpi,jpj,nptr) , & 104 & htr_adv(jpj) , str_adv(jpj) , & 105 & htr_ldf(jpj) , str_ldf(jpj) , & 106 & htr_ove(jpj) , str_ove(jpj), & 107 & htr(jpj,nptr) , str(jpj,nptr) , & 108 & tn_jk(jpj,jpk,nptr) , sn_jk (jpj,jpk,nptr) , v_msf(jpj,jpk,nptr) , & 109 & sjk (jpj,jpk,nptr) , r1_sjk(jpj,jpk,nptr) , STAT=ierr(1) ) 110 ! 111 #if defined key_diaeiv 112 ALLOCATE( htr_eiv(jpj,nptr) , str_eiv(jpj,nptr) , & 113 & v_msf_eiv(jpj,jpk,nptr) , STAT=ierr(2) ) 114 #endif 115 ALLOCATE( p_fval1d(jpj), p_fval2d(jpj,jpk), Stat=ierr(3)) 116 ! 117 ALLOCATE(ndex(jpj*jpk), ndex_atl(jpj*jpk), ndex_pac(jpj*jpk), & 118 & ndex_ind(jpj*jpk), ndex_ipc(jpj*jpk), & 119 & ndex_atl_30(jpj*jpk), ndex_pac_30(jpj*jpk), Stat=ierr(4)) 120 121 ALLOCATE(ndex_ind_30(jpj*jpk), ndex_ipc_30(jpj*jpk), & 122 & ndex_h(jpj), ndex_h_atl_30(jpj), ndex_h_pac_30(jpj), & 123 & ndex_h_ind_30(jpj), ndex_h_ipc_30(jpj), Stat=ierr(5) ) 124 ! 125 ALLOCATE( btm30(jpi,jpj) , STAT=ierr(6) ) 126 ! 127 dia_ptr_alloc = MAXVAL( ierr ) 128 IF(lk_mpp) CALL mpp_sum( dia_ptr_alloc ) 129 ! 130 END FUNCTION dia_ptr_alloc 131 132 133 FUNCTION ptr_vj_3d( pva ) RESULT ( p_fval ) 134 !!---------------------------------------------------------------------- 135 !! *** ROUTINE ptr_vj_3d *** 136 !! 137 !! ** Purpose : i-k sum computation of a j-flux array 138 !! 139 !! ** Method : - i-k sum of pva using the interior 2D vmask (vmask_i). 140 !! pva is supposed to be a masked flux (i.e. * vmask*e1v*e3v) 141 !! 142 !! ** Action : - p_fval: i-k-mean poleward flux of pva 143 !!---------------------------------------------------------------------- 144 REAL(wp) , INTENT(in), DIMENSION(jpi,jpj,jpk) :: pva ! mask flux array at V-point 145 !! 146 INTEGER :: ji, jj, jk ! dummy loop arguments 147 INTEGER :: ijpj ! ??? 148 REAL(wp), POINTER, DIMENSION(:) :: p_fval ! function value 149 !!-------------------------------------------------------------------- 150 ! 151 p_fval => p_fval1d 152 153 ijpj = jpj 154 p_fval(:) = 0._wp 155 DO jk = 1, jpkm1 156 DO jj = 2, jpjm1 157 DO ji = fs_2, fs_jpim1 ! Vector opt. 158 p_fval(jj) = p_fval(jj) + pva(ji,jj,jk) * tmask_i(ji,jj) 159 END DO 160 END DO 161 END DO 162 #if defined key_mpp_mpi 163 IF(lk_mpp) CALL mpp_sum( p_fval, ijpj, ncomm_znl) 164 #endif 165 ! 166 END FUNCTION ptr_vj_3d 167 168 169 FUNCTION ptr_vj_2d( pva ) RESULT ( p_fval ) 170 !!---------------------------------------------------------------------- 171 !! *** ROUTINE ptr_vj_2d *** 172 !! 173 !! ** Purpose : "zonal" and vertical sum computation of a i-flux array 174 !! 175 !! ** Method : - i-k sum of pva using the interior 2D vmask (vmask_i). 176 !! pva is supposed to be a masked flux (i.e. * vmask*e1v*e3v) 177 !! 178 !! ** Action : - p_fval: i-k-mean poleward flux of pva 179 !!---------------------------------------------------------------------- 180 IMPLICIT none 181 REAL(wp) , INTENT(in), DIMENSION(jpi,jpj) :: pva ! mask flux array at V-point 182 !! 183 INTEGER :: ji,jj ! dummy loop arguments 184 INTEGER :: ijpj ! ??? 185 REAL(wp), POINTER, DIMENSION(:) :: p_fval ! function value 186 !!-------------------------------------------------------------------- 187 ! 188 p_fval => p_fval1d 189 190 ijpj = jpj 191 p_fval(:) = 0._wp 192 DO jj = 2, jpjm1 193 DO ji = nldi, nlei ! No vector optimisation here. Better use a mask ? 194 p_fval(jj) = p_fval(jj) + pva(ji,jj) * tmask_i(ji,jj) 195 END DO 196 END DO 197 #if defined key_mpp_mpi 198 CALL mpp_sum( p_fval, ijpj, ncomm_znl ) 199 #endif 200 ! 201 END FUNCTION ptr_vj_2d 202 203 204 FUNCTION ptr_vjk( pva, pmsk ) RESULT ( p_fval ) 205 !!---------------------------------------------------------------------- 206 !! *** ROUTINE ptr_vjk *** 207 !! 208 !! ** Purpose : i-sum computation of a j-velocity array 209 !! 210 !! ** Method : - i-sum of pva using the interior 2D vmask (vmask_i). 211 !! pva is supposed to be a masked flux (i.e. * vmask) 212 !! 213 !! ** Action : - p_fval: i-mean poleward flux of pva 214 !!---------------------------------------------------------------------- 215 !! 216 IMPLICIT none 217 REAL(wp) , INTENT(in), DIMENSION(jpi,jpj,jpk) :: pva ! mask flux array at V-point 218 REAL(wp) , INTENT(in), DIMENSION(jpi,jpj) , OPTIONAL :: pmsk ! Optional 2D basin mask 219 !! 220 INTEGER :: ji, jj, jk ! dummy loop arguments 221 REAL(wp), POINTER, DIMENSION(:,:) :: p_fval ! return function value 222 #if defined key_mpp_mpi 223 INTEGER, DIMENSION(1) :: ish 224 INTEGER, DIMENSION(2) :: ish2 225 INTEGER :: ijpjjpk 226 #endif 227 #if defined key_mpp_mpi 228 REAL(wp), POINTER, DIMENSION(:) :: zwork ! mask flux array at V-point 229 #endif 230 !!-------------------------------------------------------------------- 231 ! 232 #if defined key_mpp_mpi 233 ijpjjpk = jpj*jpk 234 CALL wrk_alloc( jpj*jpk, zwork ) 235 #endif 236 237 p_fval => p_fval2d 238 239 p_fval(:,:) = 0._wp 240 ! 241 IF( PRESENT( pmsk ) ) THEN 242 DO jk = 1, jpkm1 243 DO jj = 2, jpjm1 244 !!gm here, use of tmask_i ==> no need of loop over nldi, nlei.... 245 DO ji = nldi, nlei ! No vector optimisation here. Better use a mask ? 246 p_fval(jj,jk) = p_fval(jj,jk) + pva(ji,jj,jk) * e1v(ji,jj) * fse3v(ji,jj,jk) * pmsk(ji,jj) 72 SUBROUTINE dia_ptr( pvtr ) 73 !!---------------------------------------------------------------------- 74 !! *** ROUTINE dia_ptr *** 75 !!---------------------------------------------------------------------- 76 REAL(wp), DIMENSION(jpi,jpj,jpk), INTENT(in), OPTIONAL :: pvtr ! j-effective transport 77 ! 78 INTEGER :: ji, jj, jk, jn ! dummy loop indices 79 REAL(wp) :: zv, zsfc ! local scalar 80 REAL(wp), DIMENSION(jpi,jpj) :: z2d ! 2D workspace 81 REAL(wp), DIMENSION(jpi,jpj,jpk) :: z3d ! 3D workspace 82 REAL(wp), DIMENSION(jpi,jpj,jpk) :: zmask ! 3D workspace 83 REAL(wp), DIMENSION(jpi,jpj,jpk,jpts) :: zts ! 3D workspace 84 CHARACTER( len = 10 ) :: cl1 85 !!---------------------------------------------------------------------- 86 ! 87 IF( nn_timing == 1 ) CALL timing_start('dia_ptr') 88 89 ! 90 IF( PRESENT( pvtr ) ) THEN 91 IF( iom_use("zomsfglo") ) THEN ! effective MSF 92 z3d(1,:,:) = ptr_sjk( pvtr(:,:,:) ) ! zonal cumulative effective transport 93 DO jk = 2, jpkm1 94 z3d(1,:,jk) = z3d(1,:,jk-1) + z3d(1,:,jk) ! effective j-Stream-Function (MSF) 95 END DO 96 DO ji = 1, jpi 97 z3d(ji,:,:) = z3d(1,:,:) 98 ENDDO 99 cl1 = TRIM('zomsf'//clsubb(1) ) 100 CALL iom_put( cl1, z3d * rc_sv ) 101 DO jn = 2, nptr ! by sub-basins 102 z3d(1,:,:) = ptr_sjk( pvtr(:,:,:), btmsk(:,:,jn)*btm30(:,:) ) 103 DO jk = 2, jpkm1 104 z3d(1,:,jk) = z3d(1,:,jk-1) + z3d(1,:,jk) ! effective j-Stream-Function (MSF) 247 105 END DO 248 END DO 249 END DO 250 ELSE 251 DO jk = 1, jpkm1 252 DO jj = 2, jpjm1 253 DO ji = nldi, nlei ! No vector optimisation here. Better use a mask ? 254 p_fval(jj,jk) = p_fval(jj,jk) + pva(ji,jj,jk) * e1v(ji,jj) * fse3v(ji,jj,jk) * tmask_i(ji,jj) 255 END DO 256 END DO 257 END DO 258 END IF 259 ! 260 #if defined key_mpp_mpi 261 ijpjjpk = jpj*jpk 262 ish(1) = ijpjjpk ; ish2(1) = jpj ; ish2(2) = jpk 263 zwork(1:ijpjjpk) = RESHAPE( p_fval, ish ) 264 CALL mpp_sum( zwork, ijpjjpk, ncomm_znl ) 265 p_fval(:,:) = RESHAPE( zwork, ish2 ) 266 #endif 267 ! 268 #if defined key_mpp_mpi 269 CALL wrk_dealloc( jpj*jpk, zwork ) 270 #endif 271 ! 272 END FUNCTION ptr_vjk 273 274 275 FUNCTION ptr_tjk( pta, pmsk ) RESULT ( p_fval ) 276 !!---------------------------------------------------------------------- 277 !! *** ROUTINE ptr_tjk *** 278 !! 279 !! ** Purpose : i-sum computation of e1t*e3t * a tracer field 280 !! 281 !! ** Method : - i-sum of mj(pta) using tmask 282 !! 283 !! ** Action : - p_fval: i-sum of e1t*e3t*pta 284 !!---------------------------------------------------------------------- 285 !! 286 REAL(wp) , INTENT(in), DIMENSION(jpi,jpj,jpk) :: pta ! tracer flux array at T-point 287 REAL(wp) , INTENT(in), DIMENSION(jpi,jpj) :: pmsk ! Optional 2D basin mask 288 !! 289 INTEGER :: ji, jj, jk ! dummy loop arguments 290 REAL(wp), POINTER, DIMENSION(:,:) :: p_fval ! return function value 291 #if defined key_mpp_mpi 292 INTEGER, DIMENSION(1) :: ish 293 INTEGER, DIMENSION(2) :: ish2 294 INTEGER :: ijpjjpk 295 #endif 296 #if defined key_mpp_mpi 297 REAL(wp), POINTER, DIMENSION(:) :: zwork ! mask flux array at V-point 298 #endif 299 !!-------------------------------------------------------------------- 300 ! 301 #if defined key_mpp_mpi 302 ijpjjpk = jpj*jpk 303 CALL wrk_alloc( jpj*jpk, zwork ) 304 #endif 305 306 p_fval => p_fval2d 307 308 p_fval(:,:) = 0._wp 309 DO jk = 1, jpkm1 310 DO jj = 2, jpjm1 311 DO ji = nldi, nlei ! No vector optimisation here. Better use a mask ? 312 p_fval(jj,jk) = p_fval(jj,jk) + pta(ji,jj,jk) * e1t(ji,jj) * fse3t(ji,jj,jk) * pmsk(ji,jj) 313 END DO 314 END DO 315 END DO 316 #if defined key_mpp_mpi 317 ijpjjpk = jpj*jpk 318 ish(1) = jpj*jpk ; ish2(1) = jpj ; ish2(2) = jpk 319 zwork(1:ijpjjpk)= RESHAPE( p_fval, ish ) 320 CALL mpp_sum( zwork, ijpjjpk, ncomm_znl ) 321 p_fval(:,:)= RESHAPE( zwork, ish2 ) 322 #endif 323 ! 324 #if defined key_mpp_mpi 325 CALL wrk_dealloc( jpj*jpk, zwork ) 326 #endif 327 ! 328 END FUNCTION ptr_tjk 329 330 331 SUBROUTINE dia_ptr( kt ) 332 !!---------------------------------------------------------------------- 333 !! *** ROUTINE dia_ptr *** 334 !!---------------------------------------------------------------------- 335 USE oce, vt => ua ! use ua as workspace 336 USE oce, vs => va ! use va as workspace 337 IMPLICIT none 338 !! 339 INTEGER, INTENT(in) :: kt ! ocean time step index 340 ! 341 INTEGER :: ji, jj, jk, jn ! dummy loop indices 342 REAL(wp) :: zv ! local scalar 343 !!---------------------------------------------------------------------- 344 ! 345 IF( nn_timing == 1 ) CALL timing_start('dia_ptr') 346 ! 347 IF( kt == nit000 .OR. MOD( kt, nn_fptr ) == 0 ) THEN 348 ! 349 IF( MOD( kt, nn_fptr ) == 0 ) THEN 350 ! 351 IF( ln_diaznl ) THEN ! i-mean temperature and salinity 352 DO jn = 1, nptr 353 tn_jk(:,:,jn) = ptr_tjk( tsn(:,:,:,jp_tem), btmsk(:,:,jn) ) * r1_sjk(:,:,jn) 354 sn_jk(:,:,jn) = ptr_tjk( tsn(:,:,:,jp_sal), btmsk(:,:,jn) ) * r1_sjk(:,:,jn) 355 END DO 356 ENDIF 357 ! 358 ! ! horizontal integral and vertical dz 359 ! ! eulerian velocity 360 v_msf(:,:,1) = ptr_vjk( vn(:,:,:) ) 361 DO jn = 2, nptr 362 v_msf(:,:,jn) = ptr_vjk( vn(:,:,:), btmsk(:,:,jn)*btm30(:,:) ) 363 END DO 364 #if defined key_diaeiv 365 DO jn = 1, nptr ! bolus velocity 366 v_msf_eiv(:,:,jn) = ptr_vjk( v_eiv(:,:,:), btmsk(:,:,jn) ) ! here no btm30 for MSFeiv 367 END DO 368 ! ! add bolus stream-function to the eulerian one 369 v_msf(:,:,:) = v_msf(:,:,:) + v_msf_eiv(:,:,:) 370 #endif 371 ! 372 ! ! Transports 373 ! ! local heat & salt transports at T-points ( tsn*mj[vn+v_eiv] ) 374 vt(:,:,jpk) = 0._wp ; vs(:,:,jpk) = 0._wp 375 DO jk= 1, jpkm1 376 DO jj = 2, jpj 106 DO ji = 1, jpi 107 z3d(ji,:,:) = z3d(1,:,:) 108 ENDDO 109 cl1 = TRIM('zomsf'//clsubb(jn) ) 110 CALL iom_put( cl1, z3d * rc_sv ) 111 END DO 112 ENDIF 113 ! 114 ELSE 115 ! 116 IF( iom_use("zotemglo") ) THEN ! i-mean i-k-surface 117 DO jk = 1, jpkm1 118 DO jj = 1, jpj 377 119 DO ji = 1, jpi 378 #if defined key_diaeiv 379 zv = ( vn(ji,jj,jk) + vn(ji,jj-1,jk) + v_eiv(ji,jj,jk) + v_eiv(ji,jj-1,jk) ) * 0.5_wp 380 #else 381 zv = ( vn(ji,jj,jk) + vn(ji,jj-1,jk) ) * 0.5_wp 382 #endif 383 vt(ji,jj,jk) = zv * tsn(ji,jj,jk,jp_tem) 384 vs(ji,jj,jk) = zv * tsn(ji,jj,jk,jp_sal) 385 END DO 386 END DO 387 END DO 388 !!gm useless as overlap areas are not used in ptr_vjk 389 CALL lbc_lnk( vs, 'V', -1. ) ; CALL lbc_lnk( vt, 'V', -1. ) 390 !!gm 391 ! ! heat & salt advective transports (approximation) 392 htr(:,1) = SUM( ptr_vjk( vt(:,:,:) ) , 2 ) * rc_pwatt ! SUM over jk + conversion 393 str(:,1) = SUM( ptr_vjk( vs(:,:,:) ) , 2 ) * rc_ggram 394 DO jn = 2, nptr 395 htr(:,jn) = SUM( ptr_vjk( vt(:,:,:), btmsk(:,:,jn)*btm30(:,:) ) , 2 ) * rc_pwatt ! mask Southern Ocean 396 str(:,jn) = SUM( ptr_vjk( vs(:,:,:), btmsk(:,:,jn)*btm30(:,:) ) , 2 ) * rc_ggram ! mask Southern Ocean 397 END DO 398 399 IF( ln_ptrcomp ) THEN ! overturning transport 400 htr_ove(:) = SUM( v_msf(:,:,1) * tn_jk(:,:,1), 2 ) * rc_pwatt ! SUM over jk + conversion 401 str_ove(:) = SUM( v_msf(:,:,1) * sn_jk(:,:,1), 2 ) * rc_ggram 402 END IF 403 ! ! Advective and diffusive transport 404 htr_adv(:) = htr_adv(:) * rc_pwatt ! these are computed in tra_adv... and tra_ldf... routines 405 htr_ldf(:) = htr_ldf(:) * rc_pwatt ! here just the conversion in PW and Gg 406 str_adv(:) = str_adv(:) * rc_ggram 407 str_ldf(:) = str_ldf(:) * rc_ggram 408 409 #if defined key_diaeiv 410 DO jn = 1, nptr ! Bolus component 411 htr_eiv(:,jn) = SUM( v_msf_eiv(:,:,jn) * tn_jk(:,:,jn), 2 ) * rc_pwatt ! SUM over jk 412 str_eiv(:,jn) = SUM( v_msf_eiv(:,:,jn) * sn_jk(:,:,jn), 2 ) * rc_ggram ! SUM over jk 413 END DO 414 #endif 415 ! ! "Meridional" Stream-Function 120 zsfc = e1t(ji,jj) * fse3t(ji,jj,jk) 121 zmask(ji,jj,jk) = tmask(ji,jj,jk) * zsfc 122 zts(ji,jj,jk,jp_tem) = tsn(ji,jj,jk,jp_tem) * zsfc 123 zts(ji,jj,jk,jp_sal) = tsn(ji,jj,jk,jp_sal) * zsfc 124 ENDDO 125 ENDDO 126 ENDDO 416 127 DO jn = 1, nptr 417 DO jk = 2, jpk 418 v_msf (:,jk,jn) = v_msf (:,jk-1,jn) + v_msf (:,jk,jn) ! Eulerian j-Stream-Function 419 #if defined key_diaeiv 420 v_msf_eiv(:,jk,jn) = v_msf_eiv(:,jk-1,jn) + v_msf_eiv(:,jk,jn) ! Bolus j-Stream-Function 421 422 #endif 423 END DO 424 END DO 425 v_msf (:,:,:) = v_msf (:,:,:) * rc_sv ! converte in Sverdrups 426 #if defined key_diaeiv 427 v_msf_eiv(:,:,:) = v_msf_eiv(:,:,:) * rc_sv 428 #endif 429 ENDIF 430 ! 431 CALL dia_ptr_wri( kt ) ! outputs 128 zmask(1,:,:) = ptr_sjk( zmask(:,:,:), btmsk(:,:,jn) ) 129 cl1 = TRIM('zosrf'//clsubb(jn) ) 130 CALL iom_put( cl1, zmask ) 131 ! 132 z3d(1,:,:) = ptr_sjk( zts(:,:,:,jp_tem), btmsk(:,:,jn) ) & 133 & / MAX( zmask(1,:,:), 10.e-15 ) 134 DO ji = 1, jpi 135 z3d(ji,:,:) = z3d(1,:,:) 136 ENDDO 137 cl1 = TRIM('zotem'//clsubb(jn) ) 138 CALL iom_put( cl1, z3d ) 139 ! 140 z3d(1,:,:) = ptr_sjk( zts(:,:,:,jp_sal), btmsk(:,:,jn) ) & 141 & / MAX( zmask(1,:,:), 10.e-15 ) 142 DO ji = 1, jpi 143 z3d(ji,:,:) = z3d(1,:,:) 144 ENDDO 145 cl1 = TRIM('zosal'//clsubb(jn) ) 146 CALL iom_put( cl1, z3d ) 147 END DO 148 ENDIF 149 ! 150 ! ! Advective and diffusive heat and salt transport 151 IF( iom_use("sophtadv") .OR. iom_use("sopstadv") ) THEN 152 z2d(1,:) = htr_adv(:) * rc_pwatt ! (conversion in PW) 153 DO ji = 1, jpi 154 z2d(ji,:) = z2d(1,:) 155 ENDDO 156 cl1 = 'sophtadv' 157 CALL iom_put( TRIM(cl1), z2d ) 158 z2d(1,:) = str_adv(:) * rc_ggram ! (conversion in Gg) 159 DO ji = 1, jpi 160 z2d(ji,:) = z2d(1,:) 161 ENDDO 162 cl1 = 'sopstadv' 163 CALL iom_put( TRIM(cl1), z2d ) 164 ENDIF 165 ! 166 IF( iom_use("sophtldf") .OR. iom_use("sopstldf") ) THEN 167 z2d(1,:) = htr_ldf(:) * rc_pwatt ! (conversion in PW) 168 DO ji = 1, jpi 169 z2d(ji,:) = z2d(1,:) 170 ENDDO 171 cl1 = 'sophtldf' 172 CALL iom_put( TRIM(cl1), z2d ) 173 z2d(1,:) = str_ldf(:) * rc_ggram ! (conversion in Gg) 174 DO ji = 1, jpi 175 z2d(ji,:) = z2d(1,:) 176 ENDDO 177 cl1 = 'sopstldf' 178 CALL iom_put( TRIM(cl1), z2d ) 179 ENDIF 432 180 ! 433 181 ENDIF 434 !435 #if defined key_mpp_mpi436 IF( kt == nitend .AND. l_znl_root ) CALL histclo( numptr ) ! Close the file437 #else438 IF( kt == nitend ) CALL histclo( numptr ) ! Close the file439 #endif440 182 ! 441 183 IF( nn_timing == 1 ) CALL timing_stop('dia_ptr') … … 450 192 !! ** Purpose : Initialization, namelist read 451 193 !!---------------------------------------------------------------------- 452 INTEGER :: jn ! dummy loop indices 453 INTEGER :: inum, ierr ! local integers 454 INTEGER :: ios ! Local integer output status for namelist read 455 #if defined key_mpp_mpi 456 INTEGER, DIMENSION(1) :: iglo, iloc, iabsf, iabsl, ihals, ihale, idid 457 #endif 458 !! 459 NAMELIST/namptr/ ln_diaptr, ln_diaznl, ln_subbas, ln_ptrcomp, nn_fptr, nn_fwri 194 INTEGER :: jn ! local integers 195 INTEGER :: inum, ierr ! local integers 196 INTEGER :: ios ! Local integer output status for namelist read 197 !! 198 NAMELIST/namptr/ ln_diaptr, ln_subbas 460 199 !!---------------------------------------------------------------------- 461 200 … … 475 214 WRITE(numout,*) ' Namelist namptr : set ptr parameters' 476 215 WRITE(numout,*) ' Poleward heat & salt transport (T) or not (F) ln_diaptr = ', ln_diaptr 477 WRITE(numout,*) ' Overturning heat & salt transport ln_ptrcomp = ', ln_ptrcomp478 WRITE(numout,*) ' T & S zonal mean and meridional stream function ln_diaznl = ', ln_diaznl479 216 WRITE(numout,*) ' Global (F) or glo/Atl/Pac/Ind/Indo-Pac basins ln_subbas = ', ln_subbas 480 WRITE(numout,*) ' Frequency of computation nn_fptr = ', nn_fptr481 WRITE(numout,*) ' Frequency of outputs nn_fwri = ', nn_fwri482 217 ENDIF 483 484 IF( ln_diaptr) THEN 485 486 IF( nn_timing == 1 ) CALL timing_start('dia_ptr_init') 487 488 IF( ln_subbas ) THEN ; nptr = 5 ! Global, Atlantic, Pacific, Indian, Indo-Pacific 489 ELSE ; nptr = 1 ! Global only 218 219 IF( ln_diaptr ) THEN 220 ! 221 IF( ln_subbas ) THEN 222 nptr = 5 ! Global, Atlantic, Pacific, Indian, Indo-Pacific 223 ALLOCATE( clsubb(nptr) ) 224 clsubb(1) = 'glo' ; clsubb(2) = 'atl' ; clsubb(3) = 'pac' ; clsubb(4) = 'ind' ; clsubb(5) = 'ipc' 225 ELSE 226 nptr = 1 ! Global only 227 ALLOCATE( clsubb(nptr) ) 228 clsubb(1) = 'glo' 490 229 ENDIF 491 230 … … 493 232 IF( dia_ptr_alloc() /= 0 ) CALL ctl_stop( 'STOP', 'dia_ptr_init : unable to allocate arrays' ) 494 233 495 rc_pwatt = rc_pwatt * rau0 *rcp ! conversion from K.s-1 to PetaWatt234 rc_pwatt = rc_pwatt * rau0_rcp ! conversion from K.s-1 to PetaWatt 496 235 497 236 IF( lk_mpp ) CALL mpp_ini_znl( numout ) ! Define MPI communicator for zonal sum 498 237 499 238 IF( ln_subbas ) THEN ! load sub-basin mask 500 CALL iom_open( 'subbasins', inum )239 CALL iom_open( 'subbasins', inum, ldstop = .FALSE. ) 501 240 CALL iom_get( inum, jpdom_data, 'atlmsk', btmsk(:,:,2) ) ! Atlantic basin 502 241 CALL iom_get( inum, jpdom_data, 'pacmsk', btmsk(:,:,3) ) ! Pacific basin … … 508 247 END WHERE 509 248 ENDIF 249 510 250 btmsk(:,:,1) = tmask_i(:,:) ! global ocean 511 251 … … 513 253 btmsk(:,:,jn) = btmsk(:,:,jn) * tmask_i(:,:) ! interior domain only 514 254 END DO 515 516 IF( lk_vvl ) CALL ctl_stop( 'diaptr: error in vvl case as constant i-mean surface is used' ) 517 518 ! ! i-sum of e1v*e3v surface and its inverse 519 DO jn = 1, nptr 520 sjk(:,:,jn) = ptr_tjk( tmask(:,:,:), btmsk(:,:,jn) ) 521 r1_sjk(:,:,jn) = 0._wp 522 WHERE( sjk(:,:,jn) /= 0._wp ) r1_sjk(:,:,jn) = 1._wp / sjk(:,:,jn) 523 END DO 524 525 ! Initialise arrays to zero because diatpr is called before they are first calculated 526 ! Note that this means diagnostics will not be exactly correct when model run is restarted. 527 htr_adv(:) = 0._wp ; str_adv(:) = 0._wp ; htr_ldf(:) = 0._wp ; str_ldf(:) = 0._wp 528 529 #if defined key_mpp_mpi 530 iglo (1) = jpjglo ! MPP case using MPI ('key_mpp_mpi') 531 iloc (1) = nlcj 532 iabsf(1) = njmppt(narea) 533 iabsl(:) = iabsf(:) + iloc(:) - 1 534 ihals(1) = nldj - 1 535 ihale(1) = nlcj - nlej 536 idid (1) = 2 537 CALL flio_dom_set( jpnj, nproc/jpni, idid, iglo, iloc, iabsf, iabsl, ihals, ihale, 'BOX', nidom_ptr ) 538 #else 539 nidom_ptr = FLIO_DOM_NONE 540 #endif 541 IF( nn_timing == 1 ) CALL timing_stop('dia_ptr_init') 542 ! 255 256 ! Initialise arrays to zero because diatpr is called before they are first calculated 257 ! Note that this means diagnostics will not be exactly correct when model run is restarted. 258 htr_adv(:) = 0._wp ; str_adv(:) = 0._wp 259 htr_ldf(:) = 0._wp ; str_ldf(:) = 0._wp 260 ! 543 261 ENDIF 544 262 ! … … 546 264 547 265 548 SUBROUTINE dia_ptr_wri( kt ) 549 !!--------------------------------------------------------------------- 550 !! *** ROUTINE dia_ptr_wri *** 551 !! 552 !! ** Purpose : output of poleward fluxes 553 !! 554 !! ** Method : NetCDF file 555 !!---------------------------------------------------------------------- 556 !! 557 INTEGER, INTENT(in) :: kt ! ocean time-step index 558 !! 559 INTEGER, SAVE :: nhoridz, ndepidzt, ndepidzw 560 INTEGER, SAVE :: ndim , ndim_atl , ndim_pac , ndim_ind , ndim_ipc 561 INTEGER, SAVE :: ndim_atl_30 , ndim_pac_30 , ndim_ind_30 , ndim_ipc_30 562 INTEGER, SAVE :: ndim_h, ndim_h_atl_30, ndim_h_pac_30, ndim_h_ind_30, ndim_h_ipc_30 563 !! 564 CHARACTER (len=40) :: clhstnam, clop, clop_once, cl_comment ! temporary names 565 INTEGER :: iline, it, itmod, ji, jj, jk ! 566 #if defined key_iomput 567 INTEGER :: inum ! temporary logical unit 266 FUNCTION dia_ptr_alloc() 267 !!---------------------------------------------------------------------- 268 !! *** ROUTINE dia_ptr_alloc *** 269 !!---------------------------------------------------------------------- 270 INTEGER :: dia_ptr_alloc ! return value 271 INTEGER, DIMENSION(3) :: ierr 272 !!---------------------------------------------------------------------- 273 ierr(:) = 0 274 ! 275 ALLOCATE( btmsk(jpi,jpj,nptr) , & 276 & htr_adv(jpj) , str_adv(jpj) , & 277 & htr_ldf(jpj) , str_ldf(jpj) , STAT=ierr(1) ) 278 ! 279 ALLOCATE( p_fval1d(jpj), p_fval2d(jpj,jpk), Stat=ierr(2)) 280 ! 281 ALLOCATE( btm30(jpi,jpj), STAT=ierr(3) ) 282 283 ! 284 dia_ptr_alloc = MAXVAL( ierr ) 285 IF(lk_mpp) CALL mpp_sum( dia_ptr_alloc ) 286 ! 287 END FUNCTION dia_ptr_alloc 288 289 290 FUNCTION ptr_sj_3d( pva, pmsk ) RESULT ( p_fval ) 291 !!---------------------------------------------------------------------- 292 !! *** ROUTINE ptr_sj_3d *** 293 !! 294 !! ** Purpose : i-k sum computation of a j-flux array 295 !! 296 !! ** Method : - i-k sum of pva using the interior 2D vmask (vmask_i). 297 !! pva is supposed to be a masked flux (i.e. * vmask*e1v*e3v) 298 !! 299 !! ** Action : - p_fval: i-k-mean poleward flux of pva 300 !!---------------------------------------------------------------------- 301 REAL(wp), INTENT(in), DIMENSION(jpi,jpj,jpk) :: pva ! mask flux array at V-point 302 REAL(wp), INTENT(in), DIMENSION(jpi,jpj), OPTIONAL :: pmsk ! Optional 2D basin mask 303 ! 304 INTEGER :: ji, jj, jk ! dummy loop arguments 305 INTEGER :: ijpj ! ??? 306 REAL(wp), POINTER, DIMENSION(:) :: p_fval ! function value 307 !!-------------------------------------------------------------------- 308 ! 309 p_fval => p_fval1d 310 311 ijpj = jpj 312 p_fval(:) = 0._wp 313 IF( PRESENT( pmsk ) ) THEN 314 DO jk = 1, jpkm1 315 DO jj = 2, jpjm1 316 DO ji = fs_2, fs_jpim1 ! Vector opt. 317 p_fval(jj) = p_fval(jj) + pva(ji,jj,jk) * tmask_i(ji,jj) * pmsk(ji,jj) 318 END DO 319 END DO 320 END DO 321 ELSE 322 DO jk = 1, jpkm1 323 DO jj = 2, jpjm1 324 DO ji = fs_2, fs_jpim1 ! Vector opt. 325 p_fval(jj) = p_fval(jj) + pva(ji,jj,jk) * tmask_i(ji,jj) 326 END DO 327 END DO 328 END DO 329 ENDIF 330 #if defined key_mpp_mpi 331 IF(lk_mpp) CALL mpp_sum( p_fval, ijpj, ncomm_znl) 568 332 #endif 569 REAL(wp) :: zsto, zout, zdt, zjulian ! temporary scalars 570 !! 571 REAL(wp), POINTER, DIMENSION(:) :: zphi, zfoo ! 1D workspace 572 REAL(wp), POINTER, DIMENSION(:,:) :: z_1 ! 2D workspace 573 !!-------------------------------------------------------------------- 574 ! 575 CALL wrk_alloc( jpj , zphi , zfoo ) 576 CALL wrk_alloc( jpj , jpk , z_1 ) 577 578 ! define time axis 579 it = kt / nn_fptr 580 itmod = kt - nit000 + 1 581 582 ! Initialization 583 ! -------------- 584 IF( kt == nit000 ) THEN 585 niter = ( nit000 - 1 ) / nn_fptr 586 zdt = rdt 587 IF( nacc == 1 ) zdt = rdtmin 588 ! 589 IF(lwp) THEN 590 WRITE(numout,*) 591 WRITE(numout,*) 'dia_ptr_wri : poleward transport and msf writing: initialization , niter = ', niter 592 WRITE(numout,*) '~~~~~~~~~~~~' 593 ENDIF 594 595 ! Reference latitude (used in plots) 596 ! ------------------ 597 ! ! ======================= 598 IF( cp_cfg == "orca" ) THEN ! ORCA configurations 599 ! ! ======================= 600 IF( jp_cfg == 05 ) iline = 192 ! i-line that passes near the North Pole 601 IF( jp_cfg == 025 ) iline = 384 ! i-line that passes near the North Pole 602 IF( jp_cfg == 1 ) iline = 96 ! i-line that passes near the North Pole 603 IF( jp_cfg == 2 ) iline = 48 ! i-line that passes near the North Pole 604 IF( jp_cfg == 4 ) iline = 24 ! i-line that passes near the North Pole 605 zphi(1:jpj) = 0._wp 606 DO ji = mi0(iline), mi1(iline) 607 zphi(1:jpj) = gphiv(ji,:) ! if iline is in the local domain 608 ! Correct highest latitude for some configurations - will work if domain is parallelized in J ? 609 IF( jp_cfg == 05 ) THEN 610 DO jj = mj0(jpjdta), mj1(jpjdta) 611 zphi( jj ) = zphi(mj0(jpjdta-1)) + ( zphi(mj0(jpjdta-1))-zphi(mj0(jpjdta-2)) ) * 0.5_wp 612 zphi( jj ) = MIN( zphi(jj), 90._wp ) 613 END DO 614 END IF 615 IF( jp_cfg == 1 .OR. jp_cfg == 2 .OR. jp_cfg == 4 ) THEN 616 DO jj = mj0(jpjdta-1), mj1(jpjdta-1) 617 zphi( jj ) = 88.5_wp 618 END DO 619 DO jj = mj0(jpjdta ), mj1(jpjdta ) 620 zphi( jj ) = 89.5_wp 621 END DO 622 END IF 623 END DO 624 ! provide the correct zphi to all local domains 333 ! 334 END FUNCTION ptr_sj_3d 335 336 337 FUNCTION ptr_sj_2d( pva, pmsk ) RESULT ( p_fval ) 338 !!---------------------------------------------------------------------- 339 !! *** ROUTINE ptr_sj_2d *** 340 !! 341 !! ** Purpose : "zonal" and vertical sum computation of a i-flux array 342 !! 343 !! ** Method : - i-k sum of pva using the interior 2D vmask (vmask_i). 344 !! pva is supposed to be a masked flux (i.e. * vmask*e1v*e3v) 345 !! 346 !! ** Action : - p_fval: i-k-mean poleward flux of pva 347 !!---------------------------------------------------------------------- 348 REAL(wp) , INTENT(in), DIMENSION(jpi,jpj) :: pva ! mask flux array at V-point 349 REAL(wp) , INTENT(in), DIMENSION(jpi,jpj), OPTIONAL :: pmsk ! Optional 2D basin mask 350 ! 351 INTEGER :: ji,jj ! dummy loop arguments 352 INTEGER :: ijpj ! ??? 353 REAL(wp), POINTER, DIMENSION(:) :: p_fval ! function value 354 !!-------------------------------------------------------------------- 355 ! 356 p_fval => p_fval1d 357 358 ijpj = jpj 359 p_fval(:) = 0._wp 360 IF( PRESENT( pmsk ) ) THEN 361 DO jj = 2, jpjm1 362 DO ji = nldi, nlei ! No vector optimisation here. Better use a mask ? 363 p_fval(jj) = p_fval(jj) + pva(ji,jj) * tmask_i(ji,jj) * pmsk(ji,jj) 364 END DO 365 END DO 366 ELSE 367 DO jj = 2, jpjm1 368 DO ji = nldi, nlei ! No vector optimisation here. Better use a mask ? 369 p_fval(jj) = p_fval(jj) + pva(ji,jj) * tmask_i(ji,jj) 370 END DO 371 END DO 372 ENDIF 625 373 #if defined key_mpp_mpi 626 CALL mpp_sum( zphi, jpj, ncomm_znl )374 CALL mpp_sum( p_fval, ijpj, ncomm_znl ) 627 375 #endif 628 ! ! ======================= 629 ELSE ! OTHER configurations 630 ! ! ======================= 631 zphi(1:jpj) = gphiv(1,:) ! assume lat/lon coordinate, select the first i-line 632 ! 633 ENDIF 634 ! 635 ! Work only on westmost processor (will not work if mppini2 is used) 376 ! 377 END FUNCTION ptr_sj_2d 378 379 380 FUNCTION ptr_sjk( pta, pmsk ) RESULT ( p_fval ) 381 !!---------------------------------------------------------------------- 382 !! *** ROUTINE ptr_sjk *** 383 !! 384 !! ** Purpose : i-sum computation of an array 385 !! 386 !! ** Method : - i-sum of pva using the interior 2D vmask (vmask_i). 387 !! 388 !! ** Action : - p_fval: i-mean poleward flux of pva 389 !!---------------------------------------------------------------------- 390 !! 391 IMPLICIT none 392 REAL(wp) , INTENT(in), DIMENSION(jpi,jpj,jpk) :: pta ! mask flux array at V-point 393 REAL(wp) , INTENT(in), DIMENSION(jpi,jpj) , OPTIONAL :: pmsk ! Optional 2D basin mask 394 !! 395 INTEGER :: ji, jj, jk ! dummy loop arguments 396 REAL(wp), POINTER, DIMENSION(:,:) :: p_fval ! return function value 636 397 #if defined key_mpp_mpi 637 IF( l_znl_root ) THEN 398 INTEGER, DIMENSION(1) :: ish 399 INTEGER, DIMENSION(2) :: ish2 400 INTEGER :: ijpjjpk 401 REAL(wp), DIMENSION(jpj*jpk) :: zwork ! mask flux array at V-point 638 402 #endif 639 ! 640 ! OPEN netcdf file 641 ! ---------------- 642 ! Define frequency of output and means 643 zsto = nn_fptr * zdt 644 IF( ln_mskland ) THEN ! put 1.e+20 on land (very expensive!!) 645 clop = "ave(only(x))" 646 clop_once = "once(only(x))" 647 ELSE ! no use of the mask value (require less cpu time) 648 clop = "ave(x)" 649 clop_once = "once" 650 ENDIF 651 652 zout = nn_fwri * zdt 653 zfoo(1:jpj) = 0._wp 654 655 CALL ymds2ju( nyear, nmonth, nday, rdt, zjulian ) ! Compute julian date from starting date of the run 656 zjulian = zjulian - adatrj ! set calendar origin to the beginning of the experiment 657 658 #if defined key_iomput 659 ! Requested by IPSL people, use by their postpro... 660 IF(lwp) THEN 661 CALL dia_nam( clhstnam, nn_fwri,' ' ) 662 CALL ctl_opn( inum, 'date.file', 'REPLACE', 'FORMATTED', 'SEQUENTIAL', -1, numout, lwp, narea ) 663 WRITE(inum,*) clhstnam 664 CLOSE(inum) 665 ENDIF 403 !!-------------------------------------------------------------------- 404 ! 405 p_fval => p_fval2d 406 407 p_fval(:,:) = 0._wp 408 ! 409 IF( PRESENT( pmsk ) ) THEN 410 DO jk = 1, jpkm1 411 DO jj = 2, jpjm1 412 !!gm here, use of tmask_i ==> no need of loop over nldi, nlei.... 413 DO ji = nldi, nlei ! No vector optimisation here. Better use a mask ? 414 p_fval(jj,jk) = p_fval(jj,jk) + pta(ji,jj,jk) * pmsk(ji,jj) 415 END DO 416 END DO 417 END DO 418 ELSE 419 DO jk = 1, jpkm1 420 DO jj = 2, jpjm1 421 DO ji = nldi, nlei ! No vector optimisation here. Better use a mask ? 422 p_fval(jj,jk) = p_fval(jj,jk) + pta(ji,jj,jk) * tmask_i(ji,jj) 423 END DO 424 END DO 425 END DO 426 END IF 427 ! 428 #if defined key_mpp_mpi 429 ijpjjpk = jpj*jpk 430 ish(1) = ijpjjpk ; ish2(1) = jpj ; ish2(2) = jpk 431 zwork(1:ijpjjpk) = RESHAPE( p_fval, ish ) 432 CALL mpp_sum( zwork, ijpjjpk, ncomm_znl ) 433 p_fval(:,:) = RESHAPE( zwork, ish2 ) 666 434 #endif 667 668 CALL dia_nam( clhstnam, nn_fwri, 'diaptr' ) 669 IF(lwp)WRITE( numout,*)" Name of diaptr NETCDF file : ", clhstnam 670 671 ! Horizontal grid : zphi() 672 CALL histbeg(clhstnam, 1, zfoo, jpj, zphi, & 673 1, 1, 1, jpj, niter, zjulian, zdt*nn_fptr, nhoridz, numptr, domain_id=nidom_ptr) 674 ! Vertical grids : gdept_1d, gdepw_1d 675 CALL histvert( numptr, "deptht", "Vertical T levels", & 676 & "m", jpk, gdept_1d, ndepidzt, "down" ) 677 CALL histvert( numptr, "depthw", "Vertical W levels", & 678 & "m", jpk, gdepw_1d, ndepidzw, "down" ) 679 ! 680 CALL wheneq ( jpj*jpk, MIN(sjk(:,:,1), 1._wp), 1, 1., ndex , ndim ) ! Lat-Depth 681 CALL wheneq ( jpj , MIN(sjk(:,1,1), 1._wp), 1, 1., ndex_h, ndim_h ) ! Lat 682 683 IF( ln_subbas ) THEN 684 z_1(:,1) = 1._wp 685 WHERE ( gphit(jpi/2,:) < -30._wp ) z_1(:,1) = 0._wp 686 DO jk = 2, jpk 687 z_1(:,jk) = z_1(:,1) 688 END DO 689 ! ! Atlantic (jn=2) 690 CALL wheneq ( jpj*jpk, MIN(sjk(:,:,2) , 1._wp), 1, 1., ndex_atl , ndim_atl ) ! Lat-Depth 691 CALL wheneq ( jpj*jpk, MIN(sjk(:,:,2)*z_1(:,:), 1._wp), 1, 1., ndex_atl_30 , ndim_atl_30 ) ! Lat-Depth 692 CALL wheneq ( jpj , MIN(sjk(:,1,2)*z_1(:,1), 1._wp), 1, 1., ndex_h_atl_30, ndim_h_atl_30 ) ! Lat 693 ! ! Pacific (jn=3) 694 CALL wheneq ( jpj*jpk, MIN(sjk(:,:,3) , 1._wp), 1, 1., ndex_pac , ndim_pac ) ! Lat-Depth 695 CALL wheneq ( jpj*jpk, MIN(sjk(:,:,3)*z_1(:,:), 1._wp), 1, 1., ndex_pac_30 , ndim_pac_30 ) ! Lat-Depth 696 CALL wheneq ( jpj , MIN(sjk(:,1,3)*z_1(:,1), 1._wp), 1, 1., ndex_h_pac_30, ndim_h_pac_30 ) ! Lat 697 ! ! Indian (jn=4) 698 CALL wheneq ( jpj*jpk, MIN(sjk(:,:,4) , 1._wp), 1, 1., ndex_ind , ndim_ind ) ! Lat-Depth 699 CALL wheneq ( jpj*jpk, MIN(sjk(:,:,4)*z_1(:,:), 1._wp), 1, 1., ndex_ind_30 , ndim_ind_30 ) ! Lat-Depth 700 CALL wheneq ( jpj , MIN(sjk(:,1,4)*z_1(:,1), 1._wp), 1, 1., ndex_h_ind_30, ndim_h_ind_30 ) ! Lat 701 ! ! Indo-Pacific (jn=5) 702 CALL wheneq ( jpj*jpk, MIN(sjk(:,:,5) , 1._wp), 1, 1., ndex_ipc , ndim_ipc ) ! Lat-Depth 703 CALL wheneq ( jpj*jpk, MIN(sjk(:,:,5)*z_1(:,:), 1._wp), 1, 1., ndex_ipc_30 , ndim_ipc_30 ) ! Lat-Depth 704 CALL wheneq ( jpj , MIN(sjk(:,1,5)*z_1(:,1), 1._wp), 1, 1., ndex_h_ipc_30, ndim_h_ipc_30 ) ! Lat 705 ENDIF 706 ! 707 #if defined key_diaeiv 708 cl_comment = ' (Bolus part included)' 709 #else 710 cl_comment = ' ' 711 #endif 712 IF( ln_diaznl ) THEN ! Zonal mean T and S 713 CALL histdef( numptr, "zotemglo", "Zonal Mean Temperature","C" , & 714 1, jpj, nhoridz, jpk, 1, jpk, ndepidzt, 32, clop, zsto, zout ) 715 CALL histdef( numptr, "zosalglo", "Zonal Mean Salinity","PSU" , & 716 1, jpj, nhoridz, jpk, 1, jpk, ndepidzt, 32, clop, zsto, zout ) 717 718 CALL histdef( numptr, "zosrfglo", "Zonal Mean Surface","m^2" , & 719 1, jpj, nhoridz, jpk, 1, jpk, ndepidzt, 32, clop_once, zsto, zout ) 720 ! 721 IF (ln_subbas) THEN 722 CALL histdef( numptr, "zotematl", "Zonal Mean Temperature: Atlantic","C" , & 723 1, jpj, nhoridz, jpk, 1, jpk, ndepidzt, 32, clop, zsto, zout ) 724 CALL histdef( numptr, "zosalatl", "Zonal Mean Salinity: Atlantic","PSU" , & 725 1, jpj, nhoridz, jpk, 1, jpk, ndepidzt, 32, clop, zsto, zout ) 726 CALL histdef( numptr, "zosrfatl", "Zonal Mean Surface: Atlantic","m^2" , & 727 1, jpj, nhoridz, jpk, 1, jpk, ndepidzt, 32, clop_once, zsto, zout ) 728 729 CALL histdef( numptr, "zotempac", "Zonal Mean Temperature: Pacific","C" , & 730 1, jpj, nhoridz, jpk, 1, jpk, ndepidzt, 32, clop, zsto, zout ) 731 CALL histdef( numptr, "zosalpac", "Zonal Mean Salinity: Pacific","PSU" , & 732 1, jpj, nhoridz, jpk, 1, jpk, ndepidzt, 32, clop, zsto, zout ) 733 CALL histdef( numptr, "zosrfpac", "Zonal Mean Surface: Pacific","m^2" , & 734 1, jpj, nhoridz, jpk, 1, jpk, ndepidzt, 32, clop_once, zsto, zout ) 735 736 CALL histdef( numptr, "zotemind", "Zonal Mean Temperature: Indian","C" , & 737 1, jpj, nhoridz, jpk, 1, jpk, ndepidzt, 32, clop, zsto, zout ) 738 CALL histdef( numptr, "zosalind", "Zonal Mean Salinity: Indian","PSU" , & 739 1, jpj, nhoridz, jpk, 1, jpk, ndepidzt, 32, clop, zsto, zout ) 740 CALL histdef( numptr, "zosrfind", "Zonal Mean Surface: Indian","m^2" , & 741 1, jpj, nhoridz, jpk, 1, jpk, ndepidzt, 32, clop_once, zsto, zout ) 742 743 CALL histdef( numptr, "zotemipc", "Zonal Mean Temperature: Pacific+Indian","C" , & 744 1, jpj, nhoridz, jpk, 1, jpk, ndepidzt, 32, clop, zsto, zout ) 745 CALL histdef( numptr, "zosalipc", "Zonal Mean Salinity: Pacific+Indian","PSU" , & 746 1, jpj, nhoridz, jpk, 1, jpk, ndepidzt, 32, clop, zsto, zout ) 747 CALL histdef( numptr, "zosrfipc", "Zonal Mean Surface: Pacific+Indian","m^2" , & 748 1, jpj, nhoridz, jpk, 1, jpk, ndepidzt, 32, clop_once, zsto, zout ) 749 ENDIF 750 ENDIF 751 ! 752 ! Meridional Stream-Function (Eulerian and Bolus) 753 CALL histdef( numptr, "zomsfglo", "Meridional Stream-Function: Global"//TRIM(cl_comment),"Sv" , & 754 1, jpj, nhoridz, jpk, 1, jpk, ndepidzw, 32, clop, zsto, zout ) 755 IF( ln_subbas .AND. ln_diaznl ) THEN 756 CALL histdef( numptr, "zomsfatl", "Meridional Stream-Function: Atlantic"//TRIM(cl_comment),"Sv" , & 757 1, jpj, nhoridz, jpk, 1, jpk, ndepidzw, 32, clop, zsto, zout ) 758 CALL histdef( numptr, "zomsfpac", "Meridional Stream-Function: Pacific"//TRIM(cl_comment),"Sv" , & 759 1, jpj, nhoridz, jpk, 1, jpk, ndepidzw, 32, clop, zsto, zout ) 760 CALL histdef( numptr, "zomsfind", "Meridional Stream-Function: Indian"//TRIM(cl_comment),"Sv" , & 761 1, jpj, nhoridz, jpk, 1, jpk, ndepidzw, 32, clop, zsto, zout ) 762 CALL histdef( numptr, "zomsfipc", "Meridional Stream-Function: Indo-Pacific"//TRIM(cl_comment),"Sv" ,& 763 1, jpj, nhoridz, jpk, 1, jpk, ndepidzw, 32, clop, zsto, zout ) 764 ENDIF 765 ! 766 ! Heat transport 767 CALL histdef( numptr, "sophtadv", "Advective Heat Transport" , & 768 "PW", 1, jpj, nhoridz, 1, 1, 1, -99, 32, clop, zsto, zout ) 769 CALL histdef( numptr, "sophtldf", "Diffusive Heat Transport" , & 770 "PW",1, jpj, nhoridz, 1, 1, 1, -99, 32, clop, zsto, zout ) 771 IF ( ln_ptrcomp ) THEN 772 CALL histdef( numptr, "sophtove", "Overturning Heat Transport" , & 773 "PW",1, jpj, nhoridz, 1, 1, 1, -99, 32, clop, zsto, zout ) 774 END IF 775 IF( ln_subbas ) THEN 776 CALL histdef( numptr, "sohtatl", "Heat Transport Atlantic"//TRIM(cl_comment), & 777 "PW", 1, jpj, nhoridz, 1, 1, 1, -99, 32, clop, zsto, zout ) 778 CALL histdef( numptr, "sohtpac", "Heat Transport Pacific"//TRIM(cl_comment) , & 779 "PW", 1, jpj, nhoridz, 1, 1, 1, -99, 32, clop, zsto, zout ) 780 CALL histdef( numptr, "sohtind", "Heat Transport Indian"//TRIM(cl_comment) , & 781 "PW", 1, jpj, nhoridz, 1, 1, 1, -99, 32, clop, zsto, zout ) 782 CALL histdef( numptr, "sohtipc", "Heat Transport Pacific+Indian"//TRIM(cl_comment), & 783 "PW", 1, jpj, nhoridz, 1, 1, 1, -99, 32, clop, zsto, zout ) 784 ENDIF 785 ! 786 ! Salt transport 787 CALL histdef( numptr, "sopstadv", "Advective Salt Transport" , & 788 "Giga g/s", 1, jpj, nhoridz, 1, 1, 1, -99, 32, clop, zsto, zout ) 789 CALL histdef( numptr, "sopstldf", "Diffusive Salt Transport" , & 790 "Giga g/s", 1, jpj, nhoridz, 1, 1, 1, -99, 32, clop, zsto, zout ) 791 IF ( ln_ptrcomp ) THEN 792 CALL histdef( numptr, "sopstove", "Overturning Salt Transport" , & 793 "Giga g/s", 1, jpj, nhoridz, 1, 1, 1, -99, 32, clop, zsto, zout ) 794 END IF 795 #if defined key_diaeiv 796 ! Eddy induced velocity 797 CALL histdef( numptr, "zomsfeiv", "Bolus Meridional Stream-Function: global", & 798 "Sv" , 1, jpj, nhoridz, jpk, 1, jpk, ndepidzw, 32, clop, zsto, zout ) 799 CALL histdef( numptr, "sophteiv", "Bolus Advective Heat Transport", & 800 "PW" , 1, jpj, nhoridz, 1, 1, 1, -99, 32, clop, zsto, zout ) 801 CALL histdef( numptr, "sopsteiv", "Bolus Advective Salt Transport", & 802 "Giga g/s", 1, jpj, nhoridz, 1, 1, 1, -99, 32, clop, zsto, zout ) 803 #endif 804 IF( ln_subbas ) THEN 805 CALL histdef( numptr, "sostatl", "Salt Transport Atlantic"//TRIM(cl_comment) , & 806 "Giga g/s", 1, jpj, nhoridz, 1, 1, 1, -99, 32, clop, zsto, zout ) 807 CALL histdef( numptr, "sostpac", "Salt Transport Pacific"//TRIM(cl_comment) , & 808 "Giga g/s", 1, jpj, nhoridz, 1, 1, 1, -99, 32, clop, zsto, zout ) 809 CALL histdef( numptr, "sostind", "Salt Transport Indian"//TRIM(cl_comment) , & 810 "Giga g/s", 1, jpj, nhoridz, 1, 1, 1, -99, 32, clop, zsto, zout ) 811 CALL histdef( numptr, "sostipc", "Salt Transport Pacific+Indian"//TRIM(cl_comment), & 812 "Giga g/s", 1, jpj, nhoridz, 1, 1, 1, -99, 32, clop, zsto, zout ) 813 ENDIF 814 ! 815 CALL histend( numptr ) 816 ! 817 END IF 818 #if defined key_mpp_mpi 819 END IF 820 #endif 821 822 #if defined key_mpp_mpi 823 IF( MOD( itmod, nn_fptr ) == 0 .AND. l_znl_root ) THEN 824 #else 825 IF( MOD( itmod, nn_fptr ) == 0 ) THEN 826 #endif 827 niter = niter + 1 828 829 IF( ln_diaznl ) THEN 830 CALL histwrite( numptr, "zosrfglo", niter, sjk (:,:,1) , ndim, ndex ) 831 CALL histwrite( numptr, "zotemglo", niter, tn_jk(:,:,1) , ndim, ndex ) 832 CALL histwrite( numptr, "zosalglo", niter, sn_jk(:,:,1) , ndim, ndex ) 833 834 IF (ln_subbas) THEN 835 CALL histwrite( numptr, "zosrfatl", niter, sjk(:,:,2), ndim_atl, ndex_atl ) 836 CALL histwrite( numptr, "zosrfpac", niter, sjk(:,:,3), ndim_pac, ndex_pac ) 837 CALL histwrite( numptr, "zosrfind", niter, sjk(:,:,4), ndim_ind, ndex_ind ) 838 CALL histwrite( numptr, "zosrfipc", niter, sjk(:,:,5), ndim_ipc, ndex_ipc ) 839 840 CALL histwrite( numptr, "zotematl", niter, tn_jk(:,:,2) , ndim_atl, ndex_atl ) 841 CALL histwrite( numptr, "zosalatl", niter, sn_jk(:,:,2) , ndim_atl, ndex_atl ) 842 CALL histwrite( numptr, "zotempac", niter, tn_jk(:,:,3) , ndim_pac, ndex_pac ) 843 CALL histwrite( numptr, "zosalpac", niter, sn_jk(:,:,3) , ndim_pac, ndex_pac ) 844 CALL histwrite( numptr, "zotemind", niter, tn_jk(:,:,4) , ndim_ind, ndex_ind ) 845 CALL histwrite( numptr, "zosalind", niter, sn_jk(:,:,4) , ndim_ind, ndex_ind ) 846 CALL histwrite( numptr, "zotemipc", niter, tn_jk(:,:,5) , ndim_ipc, ndex_ipc ) 847 CALL histwrite( numptr, "zosalipc", niter, sn_jk(:,:,5) , ndim_ipc, ndex_ipc ) 848 END IF 849 ENDIF 850 851 ! overturning outputs: 852 CALL histwrite( numptr, "zomsfglo", niter, v_msf(:,:,1), ndim, ndex ) 853 IF( ln_subbas .AND. ln_diaznl ) THEN 854 CALL histwrite( numptr, "zomsfatl", niter, v_msf(:,:,2) , ndim_atl_30, ndex_atl_30 ) 855 CALL histwrite( numptr, "zomsfpac", niter, v_msf(:,:,3) , ndim_pac_30, ndex_pac_30 ) 856 CALL histwrite( numptr, "zomsfind", niter, v_msf(:,:,4) , ndim_ind_30, ndex_ind_30 ) 857 CALL histwrite( numptr, "zomsfipc", niter, v_msf(:,:,5) , ndim_ipc_30, ndex_ipc_30 ) 858 ENDIF 859 #if defined key_diaeiv 860 CALL histwrite( numptr, "zomsfeiv", niter, v_msf_eiv(:,:,1), ndim , ndex ) 861 #endif 862 863 ! heat transport outputs: 864 IF( ln_subbas ) THEN 865 CALL histwrite( numptr, "sohtatl", niter, htr(:,2) , ndim_h_atl_30, ndex_h_atl_30 ) 866 CALL histwrite( numptr, "sohtpac", niter, htr(:,3) , ndim_h_pac_30, ndex_h_pac_30 ) 867 CALL histwrite( numptr, "sohtind", niter, htr(:,4) , ndim_h_ind_30, ndex_h_ind_30 ) 868 CALL histwrite( numptr, "sohtipc", niter, htr(:,5) , ndim_h_ipc_30, ndex_h_ipc_30 ) 869 CALL histwrite( numptr, "sostatl", niter, str(:,2) , ndim_h_atl_30, ndex_h_atl_30 ) 870 CALL histwrite( numptr, "sostpac", niter, str(:,3) , ndim_h_pac_30, ndex_h_pac_30 ) 871 CALL histwrite( numptr, "sostind", niter, str(:,4) , ndim_h_ind_30, ndex_h_ind_30 ) 872 CALL histwrite( numptr, "sostipc", niter, str(:,5) , ndim_h_ipc_30, ndex_h_ipc_30 ) 873 ENDIF 874 875 CALL histwrite( numptr, "sophtadv", niter, htr_adv , ndim_h, ndex_h ) 876 CALL histwrite( numptr, "sophtldf", niter, htr_ldf , ndim_h, ndex_h ) 877 CALL histwrite( numptr, "sopstadv", niter, str_adv , ndim_h, ndex_h ) 878 CALL histwrite( numptr, "sopstldf", niter, str_ldf , ndim_h, ndex_h ) 879 IF( ln_ptrcomp ) THEN 880 CALL histwrite( numptr, "sopstove", niter, str_ove(:) , ndim_h, ndex_h ) 881 CALL histwrite( numptr, "sophtove", niter, htr_ove(:) , ndim_h, ndex_h ) 882 ENDIF 883 #if defined key_diaeiv 884 CALL histwrite( numptr, "sophteiv", niter, htr_eiv(:,1) , ndim_h, ndex_h ) 885 CALL histwrite( numptr, "sopsteiv", niter, str_eiv(:,1) , ndim_h, ndex_h ) 886 #endif 887 ! 888 ENDIF 889 ! 890 CALL wrk_dealloc( jpj , zphi , zfoo ) 891 CALL wrk_dealloc( jpj , jpk, z_1 ) 892 ! 893 END SUBROUTINE dia_ptr_wri 435 ! 436 END FUNCTION ptr_sjk 437 894 438 895 439 !!====================================================================== -
branches/2014/dev_r4621_NOC4_BDY_VERT_INTERP/NEMOGCM/NEMO/OPA_SRC/DIA/diawri.F90
r5038 r5620 44 44 USE in_out_manager ! I/O manager 45 45 USE diadimg ! dimg direct access file format output 46 <<<<<<< .working47 USE diaar5, ONLY : lk_diaar548 =======49 >>>>>>> .merge-right.r503550 46 USE iom 51 47 USE ioipsl 48 USE dynspg_oce, ONLY: un_adv, vn_adv ! barotropic velocities 49 52 50 #if defined key_lim2 53 51 USE limwri_2 … … 82 80 !!---------------------------------------------------------------------- 83 81 !! NEMO/OPA 3.3 , NEMO Consortium (2010) 84 !! $Id 82 !! $Id$ 85 83 !! Software governed by the CeCILL licence (NEMOGCM/NEMO_CeCILL.txt) 86 84 !!---------------------------------------------------------------------- … … 129 127 !! 130 128 INTEGER :: ji, jj, jk ! dummy loop indices 129 INTEGER :: jkbot ! 131 130 REAL(wp) :: zztmp, zztmpx, zztmpy ! 132 131 !! 133 <<<<<<< .working134 132 REAL(wp), POINTER, DIMENSION(:,:) :: z2d ! 2D workspace 135 REAL(wp), POINTER, DIMENSION(:,:) :: z2ds ! 2D workspace136 =======137 REAL(wp), POINTER, DIMENSION(:,:) :: z2d ! 2D workspace138 >>>>>>> .merge-right.r5035139 133 REAL(wp), POINTER, DIMENSION(:,:,:) :: z3d ! 3D workspace 140 134 !!---------------------------------------------------------------------- … … 142 136 IF( nn_timing == 1 ) CALL timing_start('dia_wri') 143 137 ! 144 CALL wrk_alloc( jpi , jpj , z2d , z2ds)138 CALL wrk_alloc( jpi , jpj , z2d ) 145 139 CALL wrk_alloc( jpi , jpj, jpk , z3d ) 146 140 ! … … 151 145 ENDIF 152 146 153 IF( lk_vvl ) THEN 154 z3d(:,:,:) = tsn(:,:,:,jp_tem) * fse3t_n(:,:,:) 155 CALL iom_put( "toce" , z3d ) ! heat content 147 IF( .NOT.lk_vvl ) THEN 148 CALL iom_put( "e3t" , fse3t_n(:,:,:) ) 149 CALL iom_put( "e3u" , fse3u_n(:,:,:) ) 150 CALL iom_put( "e3v" , fse3v_n(:,:,:) ) 151 CALL iom_put( "e3w" , fse3w_n(:,:,:) ) 152 ENDIF 153 154 CALL iom_put( "ssh" , sshn ) ! sea surface height 155 if( iom_use('ssh2') ) CALL iom_put( "ssh2", sshn(:,:) * sshn(:,:) ) ! square of sea surface height 156 157 CALL iom_put( "toce", tsn(:,:,:,jp_tem) ) ! 3D temperature 158 CALL iom_put( "sst", tsn(:,:,1,jp_tem) ) ! surface temperature 159 IF ( iom_use("sbt") ) THEN 156 160 DO jj = 1, jpj 157 161 DO ji = 1, jpi 158 z2d(ji,jj) = tsn(ji,jj,mikt(ji,jj),jp_tem) * fse3t_n(ji,jj,mikt(ji,jj)) 159 END DO 160 END DO 161 CALL iom_put( "sst" , z2d(:,:) ) ! sea surface heat content 162 jkbot = mbkt(ji,jj) 163 z2d(ji,jj) = tsn(ji,jj,jkbot,jp_tem) 164 END DO 165 END DO 166 CALL iom_put( "sbt", z2d ) ! bottom temperature 167 ENDIF 168 169 CALL iom_put( "soce", tsn(:,:,:,jp_sal) ) ! 3D salinity 170 CALL iom_put( "sss", tsn(:,:,1,jp_sal) ) ! surface salinity 171 IF ( iom_use("sbs") ) THEN 162 172 DO jj = 1, jpj 163 173 DO ji = 1, jpi 164 z2d(ji,jj) = tsn(ji,jj,mikt(ji,jj),jp_tem)**2 * fse3t_n(ji,jj,mikt(ji,jj)) 165 END DO 166 END DO 167 CALL iom_put( "sst2" , z2d(:,:) ) ! sea surface content of squared temperature 168 z3d(:,:,:) = tsn(:,:,:,jp_sal) * fse3t_n(:,:,:) 169 CALL iom_put( "soce" , z3d ) ! salinity content 174 jkbot = mbkt(ji,jj) 175 z2d(ji,jj) = tsn(ji,jj,jkbot,jp_sal) 176 END DO 177 END DO 178 CALL iom_put( "sbs", z2d ) ! bottom salinity 179 ENDIF 180 181 IF ( iom_use("taubot") ) THEN ! bottom stress 182 z2d(:,:) = 0._wp 183 DO jj = 2, jpjm1 184 DO ji = fs_2, fs_jpim1 ! vector opt. 185 zztmpx = ( bfrua(ji ,jj) * un(ji ,jj,mbku(ji ,jj)) & 186 & + bfrua(ji-1,jj) * un(ji-1,jj,mbku(ji-1,jj)) ) 187 zztmpy = ( bfrva(ji, jj) * vn(ji,jj ,mbkv(ji,jj )) & 188 & + bfrva(ji,jj-1) * vn(ji,jj-1,mbkv(ji,jj-1)) ) 189 z2d(ji,jj) = rau0 * SQRT( zztmpx * zztmpx + zztmpy * zztmpy ) * tmask(ji,jj,1) 190 ! 191 ENDDO 192 ENDDO 193 CALL lbc_lnk( z2d, 'T', 1. ) 194 CALL iom_put( "taubot", z2d ) 195 ENDIF 196 197 CALL iom_put( "uoce", un(:,:,:) ) ! 3D i-current 198 CALL iom_put( "ssu", un(:,:,1) ) ! surface i-current 199 IF ( iom_use("sbu") ) THEN 170 200 DO jj = 1, jpj 171 201 DO ji = 1, jpi 172 z2d(ji,jj) = tsn(ji,jj,mikt(ji,jj),jp_sal) * fse3t_n(ji,jj,mikt(ji,jj)) 173 END DO 174 END DO 175 CALL iom_put( "sss" , z2d(:,:) ) ! sea surface salinity content 202 jkbot = mbku(ji,jj) 203 z2d(ji,jj) = un(ji,jj,jkbot) 204 END DO 205 END DO 206 CALL iom_put( "sbu", z2d ) ! bottom i-current 207 ENDIF 208 #if defined key_dynspg_ts 209 CALL iom_put( "ubar", un_adv(:,:) ) ! barotropic i-current 210 #else 211 CALL iom_put( "ubar", un_b(:,:) ) ! barotropic i-current 212 #endif 213 214 CALL iom_put( "voce", vn(:,:,:) ) ! 3D j-current 215 CALL iom_put( "ssv", vn(:,:,1) ) ! surface j-current 216 IF ( iom_use("sbv") ) THEN 176 217 DO jj = 1, jpj 177 218 DO ji = 1, jpi 178 z2d(ji,jj) = tsn(ji,jj,mikt(ji,jj),jp_sal)**2 * fse3t_n(ji,jj,mikt(ji,jj)) 179 END DO 180 END DO 181 CALL iom_put( "sss2" , z2d(:,:) ) ! sea surface content of squared salinity 182 ELSE 183 CALL iom_put( "toce" , tsn(:,:,:,jp_tem) ) ! temperature 184 IF ( iom_use("sst") ) THEN 185 DO jj = 1, jpj 186 DO ji = 1, jpi 187 z2d(ji,jj) = tsn(ji,jj,mikt(ji,jj),jp_tem) 188 END DO 189 END DO 190 CALL iom_put( "sst" , z2d(:,:) ) ! sea surface temperature 191 ENDIF 192 IF ( iom_use("sst2") ) CALL iom_put( "sst2" , z2d(:,:) * z2d(:,:) ) ! square of sea surface temperature 193 CALL iom_put( "soce" , tsn(:,:,:,jp_sal) ) ! salinity 194 IF ( iom_use("sss") ) THEN 195 DO jj = 1, jpj 196 DO ji = 1, jpi 197 z2d(ji,jj) = tsn(ji,jj,mikt(ji,jj),jp_sal) 198 END DO 199 END DO 200 CALL iom_put( "sss" , z2d(:,:) ) ! sea surface salinity 201 ENDIF 202 CALL iom_put( "sss2" , z2d(:,:) * z2d(:,:) ) ! square of sea surface salinity 203 END IF 204 IF( lk_vvl .AND. (.NOT. ln_dynadv_vec) ) THEN 205 CALL iom_put( "uoce" , umask(:,:,:) * un(:,:,:) * fse3u_n(:,:,:) ) ! i-transport 206 CALL iom_put( "voce" , vmask(:,:,:) * vn(:,:,:) * fse3v_n(:,:,:) ) ! j-transport 207 ELSE 208 CALL iom_put( "uoce" , umask(:,:,:) * un(:,:,:) ) ! i-current 209 CALL iom_put( "voce" , vmask(:,:,:) * vn(:,:,:) ) ! j-current 210 IF ( iom_use("ssu") ) THEN 211 DO jj = 1, jpj 212 DO ji = 1, jpi 213 z2d(ji,jj) = un(ji,jj,miku(ji,jj)) 214 END DO 215 END DO 216 CALL iom_put( "ssu" , z2d ) ! i-current 217 ENDIF 218 IF ( iom_use("ssv") ) THEN 219 DO jj = 1, jpj 220 DO ji = 1, jpi 221 z2d(ji,jj) = vn(ji,jj,mikv(ji,jj)) 222 END DO 223 END DO 224 CALL iom_put( "ssv" , z2d ) ! j-current 225 ENDIF 226 ENDIF 227 CALL iom_put( "avt" , avt ) ! T vert. eddy diff. coef. 228 CALL iom_put( "avm" , avmu ) ! T vert. eddy visc. coef. 229 IF( lk_zdfddm ) THEN 230 CALL iom_put( "avs" , fsavs(:,:,:) ) ! S vert. eddy diff. coef. 231 ENDIF 232 233 IF ( iom_use("sstgrad2") .OR. iom_use("sstgrad2") ) THEN 219 jkbot = mbkv(ji,jj) 220 z2d(ji,jj) = vn(ji,jj,jkbot) 221 END DO 222 END DO 223 CALL iom_put( "sbv", z2d ) ! bottom j-current 224 ENDIF 225 #if defined key_dynspg_ts 226 CALL iom_put( "vbar", vn_adv(:,:) ) ! barotropic j-current 227 #else 228 CALL iom_put( "vbar", vn_b(:,:) ) ! barotropic j-current 229 #endif 230 231 CALL iom_put( "woce", wn ) ! vertical velocity 232 IF( iom_use('w_masstr') .OR. iom_use('w_masstr2') ) THEN ! vertical mass transport & its square value 233 ! Caution: in the VVL case, it only correponds to the baroclinic mass transport. 234 z2d(:,:) = rau0 * e12t(:,:) 235 DO jk = 1, jpk 236 z3d(:,:,jk) = wn(:,:,jk) * z2d(:,:) 237 END DO 238 CALL iom_put( "w_masstr" , z3d ) 239 IF( iom_use('w_masstr2') ) CALL iom_put( "w_masstr2", z3d(:,:,:) * z3d(:,:,:) ) 240 ENDIF 241 242 CALL iom_put( "avt" , avt ) ! T vert. eddy diff. coef. 243 CALL iom_put( "avm" , avmu ) ! T vert. eddy visc. coef. 244 CALL iom_put( "avs" , fsavs(:,:,:) ) ! S vert. eddy diff. coef. (useful only with key_zdfddm) 245 246 IF ( iom_use("sstgrad") .OR. iom_use("sstgrad2") ) THEN 234 247 DO jj = 2, jpjm1 ! sst gradient 235 248 DO ji = fs_2, fs_jpim1 ! vector opt. … … 243 256 CALL lbc_lnk( z2d, 'T', 1. ) 244 257 CALL iom_put( "sstgrad2", z2d ) ! square of module of sst gradient 245 !CDIR NOVERRCHK<246 258 z2d(:,:) = SQRT( z2d(:,:) ) 247 259 CALL iom_put( "sstgrad" , z2d ) ! module of sst gradient … … 252 264 z2d(:,:) = 0._wp 253 265 DO jk = 1, jpkm1 254 DO jj = 2, jpjm1255 DO ji = fs_2, fs_jpim1 ! vector opt.266 DO jj = 1, jpj 267 DO ji = 1, jpi 256 268 z2d(ji,jj) = z2d(ji,jj) + fse3t(ji,jj,jk) * tsn(ji,jj,jk,jp_tem) * tmask(ji,jj,jk) 257 269 END DO 258 270 END DO 259 271 END DO 260 CALL lbc_lnk( z2d, 'T', 1. )261 272 CALL iom_put( "heatc", (rau0 * rcp) * z2d ) ! vertically integrated heat content (J/m2) 262 273 ENDIF 263 274 264 <<<<<<< .working265 ! clem: heat and salt content266 z2d(:,:) = 0._wp267 z2ds(:,:) = 0._wp268 DO jk = 1, jpkm1269 DO jj = 2, jpjm1270 DO ji = fs_2, fs_jpim1 ! vector opt.271 z2d(ji,jj) = z2d(ji,jj) + rau0 * rcp * fse3t(ji,jj,jk) * tsn(ji,jj,jk,jp_tem) * tmask(ji,jj,jk)272 z2ds(ji,jj) = z2ds(ji,jj) + rau0 * fse3t(ji,jj,jk) * tsn(ji,jj,jk,jp_sal) * tmask(ji,jj,jk)273 END DO274 END DO275 END DO276 CALL lbc_lnk( z2d, 'T', 1. )277 CALL lbc_lnk( z2ds, 'T', 1. )278 CALL iom_put( "heatc", z2d ) ! vertically integrated heat content (J/m2)279 CALL iom_put( "saltc", z2ds ) ! vertically integrated salt content (PSU*kg/m2)280 281 282 IF( lk_diaar5 ) THEN283 =======284 275 IF( iom_use("saltc") ) THEN 285 276 z2d(:,:) = 0._wp 286 277 DO jk = 1, jpkm1 287 DO jj = 2, jpjm1288 DO ji = fs_2, fs_jpim1 ! vector opt.278 DO jj = 1, jpj 279 DO ji = 1, jpi 289 280 z2d(ji,jj) = z2d(ji,jj) + fse3t(ji,jj,jk) * tsn(ji,jj,jk,jp_sal) * tmask(ji,jj,jk) 290 281 END DO 291 282 END DO 292 283 END DO 293 CALL lbc_lnk( z2d, 'T', 1. )294 284 CALL iom_put( "saltc", rau0 * z2d ) ! vertically integrated salt content (PSU*kg/m2) 295 285 ENDIF … … 319 309 320 310 IF( iom_use("u_masstr") .OR. iom_use("u_heattr") .OR. iom_use("u_salttr") ) THEN 321 >>>>>>> .merge-right.r5035322 311 z3d(:,:,jpk) = 0.e0 323 312 DO jk = 1, jpkm1 … … 325 314 END DO 326 315 CALL iom_put( "u_masstr", z3d ) ! mass transport in i-direction 327 <<<<<<< .working328 329 zztmp = 0.5 * rcp330 =======331 316 ENDIF 332 317 333 318 IF( iom_use("u_heattr") ) THEN 334 >>>>>>> .merge-right.r5035335 319 z2d(:,:) = 0.e0 336 z2ds(:,:) = 0.e0337 320 DO jk = 1, jpkm1 338 321 DO jj = 2, jpjm1 339 322 DO ji = fs_2, fs_jpim1 ! vector opt. 340 323 z2d(ji,jj) = z2d(ji,jj) + z3d(ji,jj,jk) * ( tsn(ji,jj,jk,jp_tem) + tsn(ji+1,jj,jk,jp_tem) ) 341 z2ds(ji,jj) = z2ds(ji,jj) + z3d(ji,jj,jk) * 0.5_wp * ( tsn(ji,jj,jk,jp_sal) + tsn(ji+1,jj,jk,jp_sal) )342 324 END DO 343 325 END DO 344 326 END DO 345 327 CALL lbc_lnk( z2d, 'U', -1. ) 346 <<<<<<< .working347 CALL lbc_lnk( z2ds, 'U', -1. )348 CALL iom_put( "u_heattr", z2d ) ! heat transport in i-direction349 =======350 328 CALL iom_put( "u_heattr", (0.5 * rcp) * z2d ) ! heat transport in i-direction 351 329 ENDIF … … 353 331 IF( iom_use("u_salttr") ) THEN 354 332 z2d(:,:) = 0.e0 355 >>>>>>> .merge-right.r5035356 CALL iom_put( "u_salttr", z2ds ) ! salt transport in i-direction357 358 z3d(:,:,jpk) = 0.e0359 333 DO jk = 1, jpkm1 360 <<<<<<< .working361 z3d(:,:,jk) = rau0 * vn(:,:,jk) * e1v(:,:) * fse3v(:,:,jk) * vmask(:,:,jk)362 =======363 334 DO jj = 2, jpjm1 364 335 DO ji = fs_2, fs_jpim1 ! vector opt. … … 366 337 END DO 367 338 END DO 368 >>>>>>> .merge-right.r5035369 339 END DO 370 340 CALL lbc_lnk( z2d, 'U', -1. ) … … 379 349 END DO 380 350 CALL iom_put( "v_masstr", z3d ) ! mass transport in j-direction 381 <<<<<<< .working382 383 =======384 351 ENDIF 385 352 386 353 IF( iom_use("v_heattr") ) THEN 387 >>>>>>> .merge-right.r5035388 354 z2d(:,:) = 0.e0 389 z2ds(:,:) = 0.e0390 355 DO jk = 1, jpkm1 391 356 DO jj = 2, jpjm1 392 357 DO ji = fs_2, fs_jpim1 ! vector opt. 393 358 z2d(ji,jj) = z2d(ji,jj) + z3d(ji,jj,jk) * ( tsn(ji,jj,jk,jp_tem) + tsn(ji,jj+1,jk,jp_tem) ) 394 z2ds(ji,jj) = z2ds(ji,jj) + z3d(ji,jj,jk) * 0.5_wp * ( tsn(ji,jj,jk,jp_sal) + tsn(ji,jj+1,jk,jp_sal) )395 359 END DO 396 360 END DO 397 361 END DO 398 362 CALL lbc_lnk( z2d, 'V', -1. ) 399 <<<<<<< .working400 CALL lbc_lnk( z2ds, 'V', -1. )401 CALL iom_put( "v_heattr", z2d ) ! heat transport in j-direction402 CALL iom_put( "v_salttr", z2ds ) ! salt transport in j-direction403 =======404 363 CALL iom_put( "v_heattr", (0.5 * rcp) * z2d ) ! heat transport in j-direction 405 >>>>>>> .merge-right.r5035406 364 ENDIF 407 365 … … 419 377 ENDIF 420 378 ! 421 CALL wrk_dealloc( jpi , jpj , z2d , z2ds)379 CALL wrk_dealloc( jpi , jpj , z2d ) 422 380 CALL wrk_dealloc( jpi , jpj, jpk , z3d ) 423 381 ! … … 480 438 zdt = rdt 481 439 IF( nacc == 1 ) zdt = rdtmin 482 IF( ln_mskland ) THEN ; clop = "only(x)" ! put 1.e+20 on land (very expensive!!) 483 ELSE ; clop = "x" ! no use of the mask value (require less cpu time) 484 ENDIF 440 clop = "x" ! no use of the mask value (require less cpu time and otherwise the model crashes) 485 441 #if defined key_diainstant 486 442 zsto = nwrite * zdt … … 682 638 ENDIF 683 639 684 IF( .NOT. l k_cpl ) THEN640 IF( .NOT. ln_cpl ) THEN 685 641 CALL histdef( nid_T, "sohefldp", "Surface Heat Flux: Damping" , "W/m2" , & ! qrp 686 642 & jpi, jpj, nh_T, 1 , 1, 1 , -99 , 32, clop, zsto, zout ) … … 691 647 ENDIF 692 648 693 IF( l k_cpl .AND. nn_ice <= 1 ) THEN649 IF( ln_cpl .AND. nn_ice <= 1 ) THEN 694 650 CALL histdef( nid_T, "sohefldp", "Surface Heat Flux: Damping" , "W/m2" , & ! qrp 695 651 & jpi, jpj, nh_T, 1 , 1, 1 , -99 , 32, clop, zsto, zout ) … … 714 670 #endif 715 671 716 IF( l k_cpl .AND. nn_ice == 2 ) THEN672 IF( ln_cpl .AND. nn_ice == 2 ) THEN 717 673 CALL histdef( nid_T,"soicetem" , "Ice Surface Temperature" , "K" , & ! tn_ice 718 674 & jpi, jpj, nh_T, 1 , 1, 1 , -99 , 32, clop, zsto, zout ) … … 869 825 ENDIF 870 826 871 IF( .NOT. l k_cpl ) THEN827 IF( .NOT. ln_cpl ) THEN 872 828 CALL histwrite( nid_T, "sohefldp", it, qrp , ndim_hT, ndex_hT ) ! heat flux damping 873 829 CALL histwrite( nid_T, "sowafldp", it, erp , ndim_hT, ndex_hT ) ! freshwater flux damping … … 875 831 CALL histwrite( nid_T, "sosafldp", it, zw2d , ndim_hT, ndex_hT ) ! salt flux damping 876 832 ENDIF 877 IF( l k_cpl .AND. nn_ice <= 1 ) THEN833 IF( ln_cpl .AND. nn_ice <= 1 ) THEN 878 834 CALL histwrite( nid_T, "sohefldp", it, qrp , ndim_hT, ndex_hT ) ! heat flux damping 879 835 CALL histwrite( nid_T, "sowafldp", it, erp , ndim_hT, ndex_hT ) ! freshwater flux damping … … 891 847 #endif 892 848 893 IF( l k_cpl .AND. nn_ice == 2 ) THEN849 IF( ln_cpl .AND. nn_ice == 2 ) THEN 894 850 CALL histwrite( nid_T, "soicetem", it, tn_ice(:,:,1) , ndim_hT, ndex_hT ) ! surf. ice temperature 895 851 CALL histwrite( nid_T, "soicealb", it, alb_ice(:,:,1), ndim_hT, ndex_hT ) ! ice albedo -
branches/2014/dev_r4621_NOC4_BDY_VERT_INTERP/NEMOGCM/NEMO/OPA_SRC/DOM/closea.F90
r4162 r5620 72 72 !!---------------------------------------------------------------------- 73 73 INTEGER :: jc ! dummy loop indices 74 INTEGER :: isrow ! local index 74 75 !!---------------------------------------------------------------------- 75 76 … … 91 92 CASE ( 1 ) ! ORCA_R1 configuration 92 93 ! ! ======================= 94 ! This dirty section will be suppressed by simplification process: 95 ! all this will come back in input files 96 ! Currently these hard-wired indices relate to configuration with 97 ! extend grid (jpjglo=332) 98 isrow = 332 - jpjglo 99 ! 93 100 ncsnr(1) = 1 ; ncstt(1) = 0 ! Caspian Sea 94 ncsi1(1) = 332 ; ncsj1(1) = 2 0395 ncsi2(1) = 344 ; ncsj2(1) = 2 35101 ncsi1(1) = 332 ; ncsj1(1) = 243 - isrow 102 ncsi2(1) = 344 ; ncsj2(1) = 275 - isrow 96 103 ncsir(1,1) = 1 ; ncsjr(1,1) = 1 97 104 ! -
branches/2014/dev_r4621_NOC4_BDY_VERT_INTERP/NEMOGCM/NEMO/OPA_SRC/DOM/daymod.F90
r5038 r5620 73 73 !!---------------------------------------------------------------------- 74 74 ! 75 ! max number of seconds between each restart 76 IF( REAL( nitend - nit000 + 1 ) * rdt > REAL( HUGE( nsec1jan000 ) ) ) THEN 77 CALL ctl_stop( 'The number of seconds between each restart exceeds the integer 4 max value: 2^31-1. ', & 78 & 'You must do a restart at higher frequency (or remove this stop and recompile the code in I8)' ) 79 ENDIF 75 80 ! all calendar staff is based on the fact that MOD( rday, rdttra(1) ) == 0 76 81 IF( MOD( rday , rdttra(1) ) /= 0. ) CALL ctl_stop( 'the time step must devide the number of second of in a day' ) … … 238 243 nday_year = 1 239 244 nsec_year = ndt05 240 IF( nsec1jan000 >= 2 * (2**30 - nsecd * nyear_len(1) / 2 ) ) THEN ! test integer 4 max value241 CALL ctl_stop( 'The number of seconds between Jan. 1st 00h of nit000 year and Jan. 1st 00h ', &242 & 'of the current year is exceeding the INTEGER 4 max VALUE: 2^31-1 -> 68.09 years in seconds', &243 & 'You must do a restart at higher frequency (or remove this STOP and recompile everything in I8)' )244 ENDIF245 245 nsec1jan000 = nsec1jan000 + nsecd * nyear_len(1) 246 246 IF( nleapy == 1 ) CALL day_mth -
branches/2014/dev_r4621_NOC4_BDY_VERT_INTERP/NEMOGCM/NEMO/OPA_SRC/DOM/dom_oce.F90
r5038 r5620 162 162 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: gphit, gphiu !: latitude of t-, u-, v- and f-points (degre) 163 163 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: gphiv, gphif !: 164 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, TARGET, DIMENSION(:,:) :: e1t, e2t !: horizontal scale factorsat t-point (m)165 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, TARGET, DIMENSION(:,:) :: e1u, e2u !: horizontal scale factorsat u-point (m)166 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, TARGET, DIMENSION(:,:) :: e1v, e2v !: horizontal scale factorsat v-point (m)167 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, TARGET, DIMENSION(:,:) :: e1f, e2f !: horizontal scale factorsat f-point (m)164 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, TARGET, DIMENSION(:,:) :: e1t, e2t, r1_e1t, r1_e2t !: horizontal scale factors and inverse at t-point (m) 165 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, TARGET, DIMENSION(:,:) :: e1u, e2u, r1_e1u, r1_e2u !: horizontal scale factors and inverse at u-point (m) 166 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, TARGET, DIMENSION(:,:) :: e1v, e2v, r1_e1v, r1_e2v !: horizontal scale factors and inverse at v-point (m) 167 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, TARGET, DIMENSION(:,:) :: e1f, e2f, r1_e1f, r1_e2f !: horizontal scale factors and inverse at f-point (m) 168 168 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: e1e2t !: surface at t-point (m2) 169 169 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: ff !: coriolis factor (2.*omega*sin(yphi) ) (s-1) … … 262 262 263 263 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:), TARGET :: tmask, umask, vmask, fmask !: land/ocean mask at T-, U-, V- and F-pts 264 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:), TARGET :: wmask, wumask, wvmask !: land/ocean mask at WT-, WU- and WV-pts 264 265 265 266 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:) :: tpol, fpol !: north fold mask (jperio= 3 or 4) … … 332 333 INTEGER FUNCTION dom_oce_alloc() 333 334 !!---------------------------------------------------------------------- 334 INTEGER, DIMENSION(1 1) :: ierr335 INTEGER, DIMENSION(12) :: ierr 335 336 !!---------------------------------------------------------------------- 336 337 ierr(:) = 0 … … 345 346 & tpol(jpiglo) , fpol(jpiglo) , STAT=ierr(2) ) 346 347 ! 347 ALLOCATE( glamt(jpi,jpj) , gphit(jpi,jpj) , e1t(jpi,jpj) , e2t(jpi,jpj) , & 348 & glamu(jpi,jpj) , gphiu(jpi,jpj) , e1u(jpi,jpj) , e2u(jpi,jpj) , & 349 & glamv(jpi,jpj) , gphiv(jpi,jpj) , e1v(jpi,jpj) , e2v(jpi,jpj) , e1e2t(jpi,jpj) , & 350 & glamf(jpi,jpj) , gphif(jpi,jpj) , e1f(jpi,jpj) , e2f(jpi,jpj) , ff (jpi,jpj) , STAT=ierr(3) ) 348 ALLOCATE( glamt(jpi,jpj) , gphit(jpi,jpj) , e1t(jpi,jpj) , e2t(jpi,jpj) , r1_e1t(jpi,jpj) , r1_e2t(jpi,jpj) , & 349 & glamu(jpi,jpj) , gphiu(jpi,jpj) , e1u(jpi,jpj) , e2u(jpi,jpj) , r1_e1u(jpi,jpj) , r1_e2u(jpi,jpj) , & 350 & glamv(jpi,jpj) , gphiv(jpi,jpj) , e1v(jpi,jpj) , e2v(jpi,jpj) , r1_e1v(jpi,jpj) , r1_e2v(jpi,jpj) , & 351 & glamf(jpi,jpj) , gphif(jpi,jpj) , e1f(jpi,jpj) , e2f(jpi,jpj) , r1_e1f(jpi,jpj) , r1_e2f(jpi,jpj) , & 352 & e1e2t(jpi,jpj) , ff (jpi,jpj) , STAT=ierr(3) ) 351 353 ! 352 354 ALLOCATE( gdep3w_0(jpi,jpj,jpk) , e3v_0(jpi,jpj,jpk) , e3f_0 (jpi,jpj,jpk) , & … … 400 402 & vmask(jpi,jpj,jpk) , fmask(jpi,jpj,jpk), STAT=ierr(11) ) 401 403 404 ALLOCATE( wmask(jpi,jpj,jpk) , wumask(jpi,jpj,jpk), wvmask(jpi,jpj,jpk) , STAT=ierr(12) ) 405 402 406 #if defined key_noslip_accurate 403 ALLOCATE( npcoa(4,jpk), nicoa(2*(jpi+jpj),4,jpk), njcoa(2*(jpi+jpj),4,jpk), STAT=ierr(1 1) )407 ALLOCATE( npcoa(4,jpk), nicoa(2*(jpi+jpj),4,jpk), njcoa(2*(jpi+jpj),4,jpk), STAT=ierr(12) ) 404 408 #endif 405 409 ! -
branches/2014/dev_r4621_NOC4_BDY_VERT_INTERP/NEMOGCM/NEMO/OPA_SRC/DOM/domain.F90
r5038 r5620 135 135 !!---------------------------------------------------------------------- 136 136 USE ioipsl 137 NAMELIST/namrun/ nn_no , cn_exp , cn_ocerst_in, cn_ocerst_out, ln_rstart , nn_rstctl, & 137 NAMELIST/namrun/ cn_ocerst_indir, cn_ocerst_outdir, nn_stocklist, ln_rst_list, & 138 & nn_no , cn_exp , cn_ocerst_in, cn_ocerst_out, ln_rstart , nn_rstctl, & 138 139 & nn_it000, nn_itend , nn_date0 , nn_leapy , nn_istate , nn_stock , & 139 & nn_write, ln_dimgnnn, ln_mskland , ln_c lobber, nn_chunksz, nn_euler140 & nn_write, ln_dimgnnn, ln_mskland , ln_cfmeta , ln_clobber, nn_chunksz, nn_euler 140 141 NAMELIST/namdom/ nn_bathy, rn_bathy , rn_e3zps_min, rn_e3zps_rat, nn_msh, rn_hmin, & 141 142 & nn_acc , rn_atfp , rn_rdt , rn_rdtmin , & … … 169 170 WRITE(numout,*) ' experiment name for output cn_exp = ', cn_exp 170 171 WRITE(numout,*) ' file prefix restart input cn_ocerst_in= ', cn_ocerst_in 172 WRITE(numout,*) ' restart input directory cn_ocerst_indir= ', cn_ocerst_indir 171 173 WRITE(numout,*) ' file prefix restart output cn_ocerst_out= ', cn_ocerst_out 174 WRITE(numout,*) ' restart output directory cn_ocerst_outdir= ', cn_ocerst_outdir 172 175 WRITE(numout,*) ' restart logical ln_rstart = ', ln_rstart 173 176 WRITE(numout,*) ' start with forward time step nn_euler = ', nn_euler … … 178 181 WRITE(numout,*) ' leap year calendar (0/1) nn_leapy = ', nn_leapy 179 182 WRITE(numout,*) ' initial state output nn_istate = ', nn_istate 180 WRITE(numout,*) ' frequency of restart file nn_stock = ', nn_stock 183 IF( ln_rst_list ) THEN 184 WRITE(numout,*) ' list of restart dump times nn_stocklist =', nn_stocklist 185 ELSE 186 WRITE(numout,*) ' frequency of restart file nn_stock = ', nn_stock 187 ENDIF 181 188 WRITE(numout,*) ' frequency of output file nn_write = ', nn_write 182 189 WRITE(numout,*) ' multi file dimgout ln_dimgnnn = ', ln_dimgnnn 183 190 WRITE(numout,*) ' mask land points ln_mskland = ', ln_mskland 191 WRITE(numout,*) ' additional CF standard metadata ln_cfmeta = ', ln_cfmeta 184 192 WRITE(numout,*) ' overwrite an existing file ln_clobber = ', ln_clobber 185 193 WRITE(numout,*) ' NetCDF chunksize (bytes) nn_chunksz = ', nn_chunksz … … 195 203 ninist = nn_istate 196 204 nstock = nn_stock 205 nstocklist = nn_stocklist 197 206 nwrite = nn_write 198 207 neuler = nn_euler 199 IF ( neuler == 1 .AND. .NOT. ln_rstart ) THEN208 IF ( neuler == 1 .AND. .NOT. ln_rstart ) THEN 200 209 WRITE(ctmp1,*) 'ln_rstart =.FALSE., nn_euler is forced to 0 ' 201 210 CALL ctl_warn( ctmp1 ) -
branches/2014/dev_r4621_NOC4_BDY_VERT_INTERP/NEMOGCM/NEMO/OPA_SRC/DOM/domhgr.F90
r5038 r5620 105 105 REAL(wp) :: zlam1, zcos_alpha, zim1 , zjm1 , ze1, ze1deg 106 106 REAL(wp) :: zphi1, zsin_alpha, zim05, zjm05 107 INTEGER :: isrow ! index for ORCA1 starting row 108 107 109 !!---------------------------------------------------------------------- 108 110 ! … … 159 161 IF( cp_cfg == "orca" .AND. jp_cfg == 1 ) THEN ! ORCA R1 configuration 160 162 ! ! ===================== 161 162 ii0 = 281 ; ii1 = 282 ! Gibraltar Strait (e2u = 20 km) 163 ij0 = 200 ; ij1 = 200 ; e2u( mi0(ii0):mi1(ii1) , mj0(ij0):mj1(ij1) ) = 20.e3 163 ! This dirty section will be suppressed by simplification process: all this will come back in input files 164 ! Currently these hard-wired indices relate to configuration with 165 ! extend grid (jpjglo=332) 166 ! which had a grid-size of 362x292. 167 ! 168 isrow = 332 - jpjglo 169 ! 170 ii0 = 282 ; ii1 = 283 ! Gibraltar Strait (e2u = 20 km) 171 ij0 = 241 - isrow ; ij1 = 241 - isrow ; e2u( mi0(ii0):mi1(ii1) , mj0(ij0):mj1(ij1) ) = 20.e3 164 172 IF(lwp) WRITE(numout,*) 165 173 IF(lwp) WRITE(numout,*) ' orca_r1: Gibraltar : e2u reduced to 20 km' 166 174 167 ii0 = 314 ; ii1 = 315 ! Bhosporus Strait (e2u = 10 km)168 ij0 = 2 08 ; ij1 = 208; e2u( mi0(ii0):mi1(ii1) , mj0(ij0):mj1(ij1) ) = 10.e3175 ii0 = 314 ; ii1 = 315 ! Bhosporus Strait (e2u = 10 km) 176 ij0 = 248 - isrow ; ij1 = 248 - isrow ; e2u( mi0(ii0):mi1(ii1) , mj0(ij0):mj1(ij1) ) = 10.e3 169 177 IF(lwp) WRITE(numout,*) 170 178 IF(lwp) WRITE(numout,*) ' orca_r1: Bhosporus : e2u reduced to 10 km' 171 179 172 ii0 = 44 ; ii1 = 44 ! Lombok Strait (e1v = 13 km)173 ij0 = 1 24 ; ij1 = 125; e1v( mi0(ii0):mi1(ii1) , mj0(ij0):mj1(ij1) ) = 13.e3180 ii0 = 44 ; ii1 = 44 ! Lombok Strait (e1v = 13 km) 181 ij0 = 164 - isrow ; ij1 = 165 - isrow ; e1v( mi0(ii0):mi1(ii1) , mj0(ij0):mj1(ij1) ) = 13.e3 174 182 IF(lwp) WRITE(numout,*) 175 183 IF(lwp) WRITE(numout,*) ' orca_r1: Lombok : e1v reduced to 10 km' 176 184 177 ii0 = 48 ; ii1 = 48 ! Sumba Strait (e1v = 8 km) [closed from bathy_11 on]178 ij0 = 1 24 ; ij1 = 125; e1v( mi0(ii0):mi1(ii1) , mj0(ij0):mj1(ij1) ) = 8.e3185 ii0 = 48 ; ii1 = 48 ! Sumba Strait (e1v = 8 km) [closed from bathy_11 on] 186 ij0 = 164 - isrow ; ij1 = 165 - isrow ; e1v( mi0(ii0):mi1(ii1) , mj0(ij0):mj1(ij1) ) = 8.e3 179 187 IF(lwp) WRITE(numout,*) 180 188 IF(lwp) WRITE(numout,*) ' orca_r1: Sumba : e1v reduced to 8 km' 181 189 182 ii0 = 53 ; ii1 = 53 ! Ombai Strait (e1v = 13 km)183 ij0 = 1 24 ; ij1 = 125; e1v( mi0(ii0):mi1(ii1) , mj0(ij0):mj1(ij1) ) = 13.e3190 ii0 = 53 ; ii1 = 53 ! Ombai Strait (e1v = 13 km) 191 ij0 = 164 - isrow ; ij1 = 165 - isrow ; e1v( mi0(ii0):mi1(ii1) , mj0(ij0):mj1(ij1) ) = 13.e3 184 192 IF(lwp) WRITE(numout,*) 185 193 IF(lwp) WRITE(numout,*) ' orca_r1: Ombai : e1v reduced to 13 km' 186 194 187 ii0 = 56 ; ii1 = 56 ! Timor Passage (e1v = 20 km)188 ij0 = 1 24 ; ij1 = 125; e1v( mi0(ii0):mi1(ii1) , mj0(ij0):mj1(ij1) ) = 20.e3195 ii0 = 56 ; ii1 = 56 ! Timor Passage (e1v = 20 km) 196 ij0 = 164 - isrow ; ij1 = 145 - isrow ; e1v( mi0(ii0):mi1(ii1) , mj0(ij0):mj1(ij1) ) = 20.e3 189 197 IF(lwp) WRITE(numout,*) 190 198 IF(lwp) WRITE(numout,*) ' orca_r1: Timor Passage : e1v reduced to 20 km' 191 199 192 ii0 = 55 ; ii1 = 55 ! West Halmahera Strait (e1v = 30 km)193 ij0 = 1 41 ; ij1 = 142; e1v( mi0(ii0):mi1(ii1) , mj0(ij0):mj1(ij1) ) = 30.e3200 ii0 = 55 ; ii1 = 55 ! West Halmahera Strait (e1v = 30 km) 201 ij0 = 181 - isrow ; ij1 = 182 - isrow ; e1v( mi0(ii0):mi1(ii1) , mj0(ij0):mj1(ij1) ) = 30.e3 194 202 IF(lwp) WRITE(numout,*) 195 203 IF(lwp) WRITE(numout,*) ' orca_r1: W Halmahera : e1v reduced to 30 km' 196 204 197 ii0 = 58 ; ii1 = 58 ! East Halmahera Strait (e1v = 50 km)198 ij0 = 1 41 ; ij1 = 142; e1v( mi0(ii0):mi1(ii1) , mj0(ij0):mj1(ij1) ) = 50.e3205 ii0 = 58 ; ii1 = 58 ! East Halmahera Strait (e1v = 50 km) 206 ij0 = 181 - isrow ; ij1 = 182 - isrow ; e1v( mi0(ii0):mi1(ii1) , mj0(ij0):mj1(ij1) ) = 50.e3 199 207 IF(lwp) WRITE(numout,*) 200 208 IF(lwp) WRITE(numout,*) ' orca_r1: E Halmahera : e1v reduced to 50 km' 201 202 !203 204 !205 !206 209 ! 207 210 ! … … 471 474 re2u_e1u(:,:) = e2u(:,:) / e1u(:,:) 472 475 re1v_e2v(:,:) = e1v(:,:) / e2v(:,:) 476 r1_e1t (:,:) = 1._wp / e1t(:,:) 477 r1_e1u (:,:) = 1._wp / e1u(:,:) 478 r1_e1v (:,:) = 1._wp / e1v(:,:) 479 r1_e1f (:,:) = 1._wp / e1f(:,:) 480 r1_e2t (:,:) = 1._wp / e2t(:,:) 481 r1_e2u (:,:) = 1._wp / e2u(:,:) 482 r1_e2v (:,:) = 1._wp / e2v(:,:) 483 r1_e2f (:,:) = 1._wp / e2f(:,:) 473 484 474 485 ! Control printing : Grid informations (if not restart) … … 616 627 CALL iom_open( 'coordinates', inum ) 617 628 618 CALL iom_get( inum, jpdom_data, 'glamt', glamt )619 CALL iom_get( inum, jpdom_data, 'glamu', glamu )620 CALL iom_get( inum, jpdom_data, 'glamv', glamv )621 CALL iom_get( inum, jpdom_data, 'glamf', glamf )622 623 CALL iom_get( inum, jpdom_data, 'gphit', gphit )624 CALL iom_get( inum, jpdom_data, 'gphiu', gphiu )625 CALL iom_get( inum, jpdom_data, 'gphiv', gphiv )626 CALL iom_get( inum, jpdom_data, 'gphif', gphif )627 628 CALL iom_get( inum, jpdom_data, 'e1t', e1t )629 CALL iom_get( inum, jpdom_data, 'e1u', e1u )630 CALL iom_get( inum, jpdom_data, 'e1v', e1v )631 CALL iom_get( inum, jpdom_data, 'e1f', e1f )632 633 CALL iom_get( inum, jpdom_data, 'e2t', e2t )634 CALL iom_get( inum, jpdom_data, 'e2u', e2u )635 CALL iom_get( inum, jpdom_data, 'e2v', e2v )636 CALL iom_get( inum, jpdom_data, 'e2f', e2f )629 CALL iom_get( inum, jpdom_data, 'glamt', glamt, lrowattr=ln_use_jattr ) 630 CALL iom_get( inum, jpdom_data, 'glamu', glamu, lrowattr=ln_use_jattr ) 631 CALL iom_get( inum, jpdom_data, 'glamv', glamv, lrowattr=ln_use_jattr ) 632 CALL iom_get( inum, jpdom_data, 'glamf', glamf, lrowattr=ln_use_jattr ) 633 634 CALL iom_get( inum, jpdom_data, 'gphit', gphit, lrowattr=ln_use_jattr ) 635 CALL iom_get( inum, jpdom_data, 'gphiu', gphiu, lrowattr=ln_use_jattr ) 636 CALL iom_get( inum, jpdom_data, 'gphiv', gphiv, lrowattr=ln_use_jattr ) 637 CALL iom_get( inum, jpdom_data, 'gphif', gphif, lrowattr=ln_use_jattr ) 638 639 CALL iom_get( inum, jpdom_data, 'e1t', e1t, lrowattr=ln_use_jattr ) 640 CALL iom_get( inum, jpdom_data, 'e1u', e1u, lrowattr=ln_use_jattr ) 641 CALL iom_get( inum, jpdom_data, 'e1v', e1v, lrowattr=ln_use_jattr ) 642 CALL iom_get( inum, jpdom_data, 'e1f', e1f, lrowattr=ln_use_jattr ) 643 644 CALL iom_get( inum, jpdom_data, 'e2t', e2t, lrowattr=ln_use_jattr ) 645 CALL iom_get( inum, jpdom_data, 'e2u', e2u, lrowattr=ln_use_jattr ) 646 CALL iom_get( inum, jpdom_data, 'e2v', e2v, lrowattr=ln_use_jattr ) 647 CALL iom_get( inum, jpdom_data, 'e2f', e2f, lrowattr=ln_use_jattr ) 637 648 638 649 CALL iom_close( inum ) -
branches/2014/dev_r4621_NOC4_BDY_VERT_INTERP/NEMOGCM/NEMO/OPA_SRC/DOM/dommsk.F90
r5038 r5620 134 134 INTEGER :: ijf, ijl, ij0, ij1 ! - - 135 135 INTEGER :: ios 136 INTEGER :: isrow ! index for ORCA1 starting row 136 137 INTEGER , POINTER, DIMENSION(:,:) :: imsk 137 138 REAL(wp), POINTER, DIMENSION(:,:) :: zwf … … 281 282 CALL lbc_lnk( fmask_i, 'F', 1._wp ) 282 283 284 ! 3. Ocean/land mask at wu-, wv- and w points 285 !---------------------------------------------- 286 wmask (:,:,1) = tmask(:,:,1) ! ???????? 287 wumask(:,:,1) = umask(:,:,1) ! ???????? 288 wvmask(:,:,1) = vmask(:,:,1) ! ???????? 289 DO jk=2,jpk 290 wmask (:,:,jk)=tmask(:,:,jk) * tmask(:,:,jk-1) 291 wumask(:,:,jk)=umask(:,:,jk) * umask(:,:,jk-1) 292 wvmask(:,:,jk)=vmask(:,:,jk) * vmask(:,:,jk-1) 293 END DO 283 294 284 295 ! 4. ocean/land mask for the elliptic equation … … 391 402 IF( cp_cfg == "orca" .AND. jp_cfg == 1 ) THEN ! ORCA R1 configuration 392 403 ! ! Increased lateral friction near of some straits 404 ! This dirty section will be suppressed by simplification process: 405 ! all this will come back in input files 406 ! Currently these hard-wired indices relate to configuration with 407 ! extend grid (jpjglo=332) 408 ! 409 isrow = 332 - jpjglo 410 ! 393 411 IF(lwp) WRITE(numout,*) 394 412 IF(lwp) WRITE(numout,*) ' orca_r1: increase friction near the following straits : ' 395 413 IF(lwp) WRITE(numout,*) ' Gibraltar ' 396 ii0 = 28 3 ; ii1 = 284! Gibraltar Strait397 ij0 = 2 00 ; ij1 = 200 ; fmask( mi0(ii0):mi1(ii1) , mj0(ij0):mj1(ij1), 1:jpk ) =2._wp414 ii0 = 282 ; ii1 = 283 ! Gibraltar Strait 415 ij0 = 241 - isrow ; ij1 = 241 - isrow ; fmask( mi0(ii0):mi1(ii1),mj0(ij0):mj1(ij1),1:jpk ) = 2._wp 398 416 399 417 IF(lwp) WRITE(numout,*) ' Bhosporus ' 400 ii0 = 314 ; ii1 = 315 ! Bhosporus Strait401 ij0 = 2 08 ; ij1 = 208 ; fmask( mi0(ii0):mi1(ii1) , mj0(ij0):mj1(ij1), 1:jpk ) =2._wp418 ii0 = 314 ; ii1 = 315 ! Bhosporus Strait 419 ij0 = 248 - isrow ; ij1 = 248 - isrow ; fmask( mi0(ii0):mi1(ii1),mj0(ij0):mj1(ij1),1:jpk ) = 2._wp 402 420 403 421 IF(lwp) WRITE(numout,*) ' Makassar (Top) ' 404 ii0 = 48 ; ii1 = 48 ! Makassar Strait (Top)405 ij0 = 1 49 ; ij1 = 150 ; fmask( mi0(ii0):mi1(ii1) , mj0(ij0):mj1(ij1), 1:jpk ) =3._wp422 ii0 = 48 ; ii1 = 48 ! Makassar Strait (Top) 423 ij0 = 189 - isrow ; ij1 = 190 - isrow ; fmask( mi0(ii0):mi1(ii1),mj0(ij0):mj1(ij1),1:jpk ) = 3._wp 406 424 407 425 IF(lwp) WRITE(numout,*) ' Lombok ' 408 ii0 = 44 ; ii1 = 44 ! Lombok Strait409 ij0 = 1 24 ; ij1 = 125 ; fmask( mi0(ii0):mi1(ii1) , mj0(ij0):mj1(ij1), 1:jpk ) =2._wp426 ii0 = 44 ; ii1 = 44 ! Lombok Strait 427 ij0 = 164 - isrow ; ij1 = 165 - isrow ; fmask( mi0(ii0):mi1(ii1),mj0(ij0):mj1(ij1),1:jpk ) = 2._wp 410 428 411 429 IF(lwp) WRITE(numout,*) ' Ombai ' 412 ii0 = 53 ; ii1 = 53 ! Ombai Strait413 ij0 = 1 24 ; ij1 = 125 ; fmask( mi0(ii0):mi1(ii1) , mj0(ij0):mj1(ij1),1:jpk ) = 2._wp430 ii0 = 53 ; ii1 = 53 ! Ombai Strait 431 ij0 = 164 - isrow ; ij1 = 165 - isrow ; fmask( mi0(ii0):mi1(ii1),mj0(ij0):mj1(ij1),1:jpk ) = 2._wp 414 432 415 433 IF(lwp) WRITE(numout,*) ' Timor Passage ' 416 ii0 = 56 ; ii1 = 56 ! Timor Passage417 ij0 = 1 24 ; ij1 = 125 ; fmask( mi0(ii0):mi1(ii1) , mj0(ij0):mj1(ij1),1:jpk ) = 2._wp434 ii0 = 56 ; ii1 = 56 ! Timor Passage 435 ij0 = 164 - isrow ; ij1 = 165 - isrow ; fmask( mi0(ii0):mi1(ii1),mj0(ij0):mj1(ij1),1:jpk ) = 2._wp 418 436 419 437 IF(lwp) WRITE(numout,*) ' West Halmahera ' 420 ii0 = 58 ; ii1 = 58 ! West Halmahera Strait421 ij0 = 1 41 ; ij1 = 142 ; fmask( mi0(ii0):mi1(ii1) , mj0(ij0):mj1(ij1),1:jpk ) = 3._wp438 ii0 = 58 ; ii1 = 58 ! West Halmahera Strait 439 ij0 = 181 - isrow ; ij1 = 182 - isrow ; fmask( mi0(ii0):mi1(ii1),mj0(ij0):mj1(ij1),1:jpk ) = 3._wp 422 440 423 441 IF(lwp) WRITE(numout,*) ' East Halmahera ' 424 ii0 = 55 ; ii1 = 55 ! East Halmahera Strait425 ij0 = 1 41 ; ij1 = 142 ; fmask( mi0(ii0):mi1(ii1) , mj0(ij0):mj1(ij1),1:jpk ) = 3._wp442 ii0 = 55 ; ii1 = 55 ! East Halmahera Strait 443 ij0 = 181 - isrow ; ij1 = 182 - isrow ; fmask( mi0(ii0):mi1(ii1),mj0(ij0):mj1(ij1),1:jpk ) = 3._wp 426 444 ! 427 445 ENDIF -
branches/2014/dev_r4621_NOC4_BDY_VERT_INTERP/NEMOGCM/NEMO/OPA_SRC/DOM/domvvl.F90
r5038 r5620 8 8 !! 3.3 ! 2011-10 (M. Leclair) totally rewrote domvvl: 9 9 !! vvl option includes z_star and z_tilde coordinates 10 !! 3.6 ! 2014-11 (P. Mathiot) add ice shelf capability 10 11 !!---------------------------------------------------------------------- 11 12 !! 'key_vvl' variable volume … … 125 126 INTEGER :: ji,jj,jk 126 127 INTEGER :: ii0, ii1, ij0, ij1 128 REAL(wp):: zcoef 127 129 !!---------------------------------------------------------------------- 128 130 IF( nn_timing == 1 ) CALL timing_start('dom_vvl_init') … … 164 166 ! t- and w- points depth 165 167 ! ---------------------- 168 ! set the isf depth as it is in the initial step 166 169 fsdept_n(:,:,1) = 0.5_wp * fse3w_n(:,:,1) 167 170 fsdepw_n(:,:,1) = 0.0_wp … … 169 172 fsdept_b(:,:,1) = 0.5_wp * fse3w_b(:,:,1) 170 173 fsdepw_b(:,:,1) = 0.0_wp 171 DO jj = 1,jpj 172 DO ji = 1,jpi 173 DO jk = 2,mikt(ji,jj)-1 174 fsdept_n(ji,jj,jk) = gdept_0(ji,jj,jk) 175 fsdepw_n(ji,jj,jk) = gdepw_0(ji,jj,jk) 176 fsde3w_n(ji,jj,jk) = gdept_0(ji,jj,jk) - sshn(ji,jj) 177 fsdept_b(ji,jj,jk) = gdept_0(ji,jj,jk) 178 fsdepw_b(ji,jj,jk) = gdepw_0(ji,jj,jk) 179 END DO 180 IF (mikt(ji,jj) .GT. 1) THEN 181 jk = mikt(ji,jj) 182 fsdept_n(ji,jj,jk) = gdepw_0(ji,jj,jk) + 0.5_wp * fse3w_n(ji,jj,jk) 183 fsdepw_n(ji,jj,jk) = gdepw_0(ji,jj,jk) 184 fsde3w_n(ji,jj,jk) = fsdept_n(ji,jj,jk ) - sshn (ji,jj) 185 fsdept_b(ji,jj,jk) = gdepw_0(ji,jj,jk) + 0.5_wp * fse3w_b(ji,jj,jk) 186 fsdepw_b(ji,jj,jk) = gdepw_0(ji,jj,jk) 187 END IF 188 DO jk = mikt(ji,jj)+1, jpk 189 fsdept_n(ji,jj,jk) = fsdept_n(ji,jj,jk-1) + fse3w_n(ji,jj,jk) 174 175 DO jk = 2, jpk 176 DO jj = 1,jpj 177 DO ji = 1,jpi 178 ! zcoef = (tmask(ji,jj,jk) - wmask(ji,jj,jk)) ! 0 everywhere tmask = wmask, ie everywhere expect at jk = mikt 179 ! 1 everywhere from mbkt to mikt + 1 or 1 (if no isf) 180 ! 0.5 where jk = mikt 181 zcoef = (tmask(ji,jj,jk) - wmask(ji,jj,jk)) 190 182 fsdepw_n(ji,jj,jk) = fsdepw_n(ji,jj,jk-1) + fse3t_n(ji,jj,jk-1) 191 fsde3w_n(ji,jj,jk) = fsdept_n(ji,jj,jk ) - sshn (ji,jj) 192 fsdept_b(ji,jj,jk) = fsdept_b(ji,jj,jk-1) + fse3w_b(ji,jj,jk) 183 fsdept_n(ji,jj,jk) = zcoef * ( fsdepw_n(ji,jj,jk ) + 0.5 * fse3w_n(ji,jj,jk)) & 184 & + (1-zcoef) * ( fsdept_n(ji,jj,jk-1) + fse3w_n(ji,jj,jk)) 185 fsde3w_n(ji,jj,jk) = fsdept_n(ji,jj,jk) - sshn(ji,jj) 193 186 fsdepw_b(ji,jj,jk) = fsdepw_b(ji,jj,jk-1) + fse3t_b(ji,jj,jk-1) 187 fsdept_b(ji,jj,jk) = zcoef * ( fsdepw_b(ji,jj,jk ) + 0.5 * fse3w_b(ji,jj,jk)) & 188 & + (1-zcoef) * ( fsdept_b(ji,jj,jk-1) + fse3w_b(ji,jj,jk)) 194 189 END DO 195 190 END DO … … 588 583 INTEGER, INTENT( in ) :: kt ! time step 589 584 !! * Local declarations 590 REAL(wp), POINTER, DIMENSION(:,:,:) :: z_e3t_def591 585 INTEGER :: ji,jj,jk ! dummy loop indices 586 REAL(wp) :: zcoef 592 587 !!---------------------------------------------------------------------- 593 588 594 589 IF( nn_timing == 1 ) CALL timing_start('dom_vvl_sf_swp') 595 !596 CALL wrk_alloc( jpi, jpj, jpk, z_e3t_def )597 590 ! 598 591 IF( kt == nit000 ) THEN … … 638 631 ! t- and w- points depth 639 632 ! ---------------------- 633 ! set the isf depth as it is in the initial step 640 634 fsdept_n(:,:,1) = 0.5_wp * fse3w_n(:,:,1) 641 635 fsdepw_n(:,:,1) = 0.0_wp 642 636 fsde3w_n(:,:,1) = fsdept_n(:,:,1) - sshn(:,:) 643 DO jj = 1,jpj 644 DO ji = 1,jpi 645 DO jk = 2,mikt(ji,jj)-1 646 fsdept_n(ji,jj,jk) = gdept_0(ji,jj,jk) 647 fsdepw_n(ji,jj,jk) = gdepw_0(ji,jj,jk) 648 fsde3w_n(ji,jj,jk) = gdept_0(ji,jj,jk) - sshn(ji,jj) 649 END DO 650 IF (mikt(ji,jj) .GT. 1) THEN 651 jk = mikt(ji,jj) 652 fsdept_n(ji,jj,jk) = gdepw_0(ji,jj,jk) + 0.5_wp * fse3w_n(ji,jj,jk) 653 fsdepw_n(ji,jj,jk) = gdepw_0(ji,jj,jk) 654 fsde3w_n(ji,jj,jk) = fsdept_n(ji,jj,jk ) - sshn (ji,jj) 655 END IF 656 DO jk = mikt(ji,jj)+1, jpk 657 fsdept_n(ji,jj,jk) = fsdept_n(ji,jj,jk-1) + fse3w_n(ji,jj,jk) 637 638 DO jk = 2, jpk 639 DO jj = 1,jpj 640 DO ji = 1,jpi 641 ! zcoef = (tmask(ji,jj,jk) - wmask(ji,jj,jk)) ! 0 everywhere tmask = wmask, ie everywhere expect at jk = mikt 642 ! 1 for jk = mikt 643 zcoef = (tmask(ji,jj,jk) - wmask(ji,jj,jk)) 658 644 fsdepw_n(ji,jj,jk) = fsdepw_n(ji,jj,jk-1) + fse3t_n(ji,jj,jk-1) 659 fsde3w_n(ji,jj,jk) = fsdept_n(ji,jj,jk ) - sshn (ji,jj) 645 fsdept_n(ji,jj,jk) = zcoef * ( fsdepw_n(ji,jj,jk ) + 0.5 * fse3w_n(ji,jj,jk)) & 646 & + (1-zcoef) * ( fsdept_n(ji,jj,jk-1) + fse3w_n(ji,jj,jk)) 647 fsde3w_n(ji,jj,jk) = fsdept_n(ji,jj,jk) - sshn(ji,jj) 660 648 END DO 661 649 END DO 662 650 END DO 651 663 652 ! Local depth and Inverse of the local depth of the water column at u- and v- points 664 653 ! ---------------------------------------------------------------------------------- … … 679 668 ! Write outputs 680 669 ! ============= 681 z_e3t_def(:,:,:) = ( ( fse3t_n(:,:,:) - e3t_0(:,:,:) ) / e3t_0(:,:,:) * 100 * tmask(:,:,:) ) ** 2 682 CALL iom_put( "cellthc" , fse3t_n (:,:,:) ) 670 CALL iom_put( "e3t" , fse3t_n (:,:,:) ) 671 CALL iom_put( "e3u" , fse3u_n (:,:,:) ) 672 CALL iom_put( "e3v" , fse3v_n (:,:,:) ) 673 CALL iom_put( "e3w" , fse3w_n (:,:,:) ) 683 674 CALL iom_put( "tpt_dep" , fsde3w_n (:,:,:) ) 684 CALL iom_put( "e3tdef" , z_e3t_def(:,:,:) ) 675 IF( iom_use("e3tdef") ) & 676 CALL iom_put( "e3tdef" , ( ( fse3t_n(:,:,:) - e3t_0(:,:,:) ) / e3t_0(:,:,:) * 100 * tmask(:,:,:) ) ** 2 ) 685 677 686 678 ! write restart file 687 679 ! ================== 688 680 IF( lrst_oce ) CALL dom_vvl_rst( kt, 'WRITE' ) 689 !690 CALL wrk_dealloc( jpi, jpj, jpk, z_e3t_def )691 681 ! 692 682 IF( nn_timing == 1 ) CALL timing_stop('dom_vvl_sf_swp') … … 1049 1039 INTEGER :: ji, jj, jk ! dummy loop indices 1050 1040 INTEGER :: ij0, ij1, ii0, ii1 ! dummy loop indices 1041 INTEGER :: isrow ! index for ORCA1 starting row 1051 1042 !! acc 1052 1043 !! Hmm with the time splitting these "fixes" seem to do more harm than good. Temporarily disabled for … … 1132 1123 IF( cp_cfg == "orca" .AND. jp_cfg == 1 ) THEN ! ORCA R1 configuration 1133 1124 ! ! ===================== 1134 ! 1135 ii0 = 281 ; ii1 = 282 ! Gibraltar Strait (e2u was modified) 1136 ij0 = 200 ; ij1 = 200 1125 ! This dirty section will be suppressed by simplification process: 1126 ! all this will come back in input files 1127 ! Currently these hard-wired indices relate to configuration with 1128 ! extend grid (jpjglo=332) 1129 ! which had a grid-size of 362x292. 1130 isrow = 332 - jpjglo 1131 ! 1132 ii0 = 282 ; ii1 = 283 ! Gibraltar Strait (e2u was modified) 1133 ij0 = 241 - isrow ; ij1 = 241 - isrow 1137 1134 DO jk = 1, jpkm1 1138 1135 DO jj = mj0(ij0), mj1(ij1) … … 1154 1151 END DO 1155 1152 ! 1156 ii0 = 314 ; ii1 = 315 ! Bhosporus Strait (e2u was modified)1157 ij0 = 2 08 ; ij1 = 2081153 ii0 = 314 ; ii1 = 315 ! Bhosporus Strait (e2u was modified) 1154 ij0 = 248 - isrow ; ij1 = 248 - isrow 1158 1155 DO jk = 1, jpkm1 1159 1156 DO jj = mj0(ij0), mj1(ij1) … … 1175 1172 END DO 1176 1173 ! 1177 ii0 = 44 ; ii1 = 44 ! Lombok Strait (e1v was modified)1178 ij0 = 1 24 ; ij1 = 1251174 ii0 = 44 ; ii1 = 44 ! Lombok Strait (e1v was modified) 1175 ij0 = 164 - isrow ; ij1 = 165 - isrow 1179 1176 DO jk = 1, jpkm1 1180 1177 DO jj = mj0(ij0), mj1(ij1) … … 1191 1188 END DO 1192 1189 ! 1193 ii0 = 48 ; ii1 = 48 ! Sumba Strait (e1v was modified) [closed from bathy_11 on]1194 ij0 = 1 24 ; ij1 = 1251190 ii0 = 48 ; ii1 = 48 ! Sumba Strait (e1v was modified) [closed from bathy_11 on] 1191 ij0 = 164 - isrow ; ij1 = 165 - isrow 1195 1192 DO jk = 1, jpkm1 1196 1193 DO jj = mj0(ij0), mj1(ij1) … … 1207 1204 END DO 1208 1205 ! 1209 ii0 = 53 ; ii1 = 53 ! Ombai Strait (e1v was modified)1210 ij0 = 1 24 ; ij1 = 1251206 ii0 = 53 ; ii1 = 53 ! Ombai Strait (e1v was modified) 1207 ij0 = 164 - isrow ; ij1 = 165 - isrow 1211 1208 DO jk = 1, jpkm1 1212 1209 DO jj = mj0(ij0), mj1(ij1) … … 1223 1220 END DO 1224 1221 ! 1225 ii0 = 56 ; ii1 = 56 ! Timor Passage (e1v was modified)1226 ij0 = 1 24 ; ij1 = 1251222 ii0 = 56 ; ii1 = 56 ! Timor Passage (e1v was modified) 1223 ij0 = 164 - isrow ; ij1 = 165 - isrow 1227 1224 DO jk = 1, jpkm1 1228 1225 DO jj = mj0(ij0), mj1(ij1) … … 1239 1236 END DO 1240 1237 ! 1241 ii0 = 55 ; ii1 = 55 ! West Halmahera Strait (e1v was modified)1242 ij0 = 1 41 ; ij1 = 1421238 ii0 = 55 ; ii1 = 55 ! West Halmahera Strait (e1v was modified) 1239 ij0 = 181 - isrow ; ij1 = 182 - isrow 1243 1240 DO jk = 1, jpkm1 1244 1241 DO jj = mj0(ij0), mj1(ij1) … … 1255 1252 END DO 1256 1253 ! 1257 ii0 = 58 ; ii1 = 58 ! East Halmahera Strait (e1v was modified)1258 ij0 = 1 41 ; ij1 = 1421254 ii0 = 58 ; ii1 = 58 ! East Halmahera Strait (e1v was modified) 1255 ij0 = 181 - isrow ; ij1 = 182 - isrow 1259 1256 DO jk = 1, jpkm1 1260 1257 DO jj = mj0(ij0), mj1(ij1) -
branches/2014/dev_r4621_NOC4_BDY_VERT_INTERP/NEMOGCM/NEMO/OPA_SRC/DOM/domwri.F90
r5038 r5620 215 215 CALL iom_rstput( 0, 0, inum4, 'gdept_1d' , gdept_1d ) ! ! stretched system 216 216 CALL iom_rstput( 0, 0, inum4, 'gdepw_1d' , gdepw_1d ) 217 CALL iom_rstput( 0, 0, inum4, 'gdept_0', gdept_0, ktype = jp_r4 ) 218 CALL iom_rstput( 0, 0, inum4, 'gdepw_0', gdepw_0, ktype = jp_r4 ) 217 219 ENDIF 218 220 -
branches/2014/dev_r4621_NOC4_BDY_VERT_INTERP/NEMOGCM/NEMO/OPA_SRC/DOM/domzgr.F90
r5038 r5620 17 17 !! 3.4 ! 2012-08 (J. Siddorn) added Siddorn and Furner stretching function 18 18 !! 3.4 ! 2012-12 (R. Bourdalle-Badie and G. Reffray) modify C1D case 19 !! 3.6 ! 2014-11 (P. Mathiot and C. Harris) add ice shelf capabilitye 19 20 !!---------------------------------------------------------------------- 20 21 … … 35 36 USE oce ! ocean variables 36 37 USE dom_oce ! ocean domain 37 USE sbc_oce ! surface variable (isf)38 38 USE closea ! closed seas 39 39 USE c1d ! 1D vertical configuration … … 298 298 ENDIF 299 299 300 IF ( ln_isfcav ) THEN 300 301 ! need to be like this to compute the pressure gradient with ISF. If not, level beneath the ISF are not aligned (sum(e3t) /= depth) 301 302 ! define e3t_0 and e3w_0 as the differences between gdept and gdepw respectively 302 DO jk = 1, jpkm1 303 e3t_1d(jk) = gdepw_1d(jk+1)-gdepw_1d(jk) 304 END DO 305 e3t_1d(jpk) = e3t_1d(jpk-1) ! we don't care because this level is masked in NEMO 306 307 DO jk = 2, jpk 308 e3w_1d(jk) = gdept_1d(jk) - gdept_1d(jk-1) 309 END DO 310 e3w_1d(1 ) = 2._wp * (gdept_1d(1) - gdepw_1d(1)) 303 DO jk = 1, jpkm1 304 e3t_1d(jk) = gdepw_1d(jk+1)-gdepw_1d(jk) 305 END DO 306 e3t_1d(jpk) = e3t_1d(jpk-1) ! we don't care because this level is masked in NEMO 307 308 DO jk = 2, jpk 309 e3w_1d(jk) = gdept_1d(jk) - gdept_1d(jk-1) 310 END DO 311 e3w_1d(1 ) = 2._wp * (gdept_1d(1) - gdepw_1d(1)) 312 END IF 311 313 312 314 !!gm BUG in s-coordinate this does not work! … … 365 367 INTEGER :: ji, jj, jl, jk ! dummy loop indices 366 368 INTEGER :: inum ! temporary logical unit 369 INTEGER :: ierror ! error flag 367 370 INTEGER :: ii_bump, ij_bump, ih ! bump center position 368 371 INTEGER :: ii0, ii1, ij0, ij1, ik ! local indices 369 372 REAL(wp) :: r_bump , h_bump , h_oce ! bump characteristics 370 373 REAL(wp) :: zi, zj, zh, zhmin ! local scalars 371 INTEGER , POINTER, DIMENSION(:,:) :: idta ! global domain integer data372 REAL(wp), POINTER, DIMENSION(:,:) :: zdta ! global domain scalar data374 INTEGER , ALLOCATABLE, DIMENSION(:,:) :: idta ! global domain integer data 375 REAL(wp), ALLOCATABLE, DIMENSION(:,:) :: zdta ! global domain scalar data 373 376 !!---------------------------------------------------------------------- 374 377 ! 375 378 IF( nn_timing == 1 ) CALL timing_start('zgr_bat') 376 !377 CALL wrk_alloc( jpidta, jpjdta, idta )378 CALL wrk_alloc( jpidta, jpjdta, zdta )379 379 ! 380 380 IF(lwp) WRITE(numout,*) … … 385 385 ! ! ================== ! 386 386 ! ! global domain level and meter bathymetry (idta,zdta) 387 ! 388 ALLOCATE( idta(jpidta,jpjdta), STAT=ierror ) 389 IF( ierror > 0 ) CALL ctl_stop( 'STOP', 'zgr_bat: unable to allocate idta array' ) 390 ALLOCATE( zdta(jpidta,jpjdta), STAT=ierror ) 391 IF( ierror > 0 ) CALL ctl_stop( 'STOP', 'zgr_bat: unable to allocate zdta array' ) 387 392 ! 388 393 IF( ntopo == 0 ) THEN ! flat basin … … 468 473 misfdep(:,:)=1 469 474 ! 470 ! (ISF) TODO build ice draft netcdf file for isomip and build the corresponding part of code 471 IF( cp_cfg == "isomip" ) THEN 472 ! 473 risfdep(:,:)=200.e0 474 misfdep(:,:)=1 475 ij0 = 1 ; ij1 = 40 476 DO jj = mj0(ij0), mj1(ij1) 477 risfdep(:,jj)=700.0_wp-(gphit(:,jj)+80.0_wp)*125.0_wp 478 END DO 479 WHERE( bathy(:,:) <= 0._wp ) risfdep(:,:) = 0._wp 480 ! 481 ELSEIF ( cp_cfg == "isomip2" ) THEN 482 ! 483 risfdep(:,:)=0.e0 484 misfdep(:,:)=1 485 ij0 = 1 ; ij1 = 40 486 DO jj = mj0(ij0), mj1(ij1) 487 risfdep(:,jj)=700.0_wp-(gphit(:,jj)+80.0_wp)*125.0_wp 488 END DO 489 WHERE( bathy(:,:) <= 0._wp ) risfdep(:,:) = 0._wp 490 END IF 475 DEALLOCATE( idta, zdta ) 491 476 ! 492 477 ! ! ================ ! … … 529 514 IF( ln_zps .OR. ln_sco ) THEN ! zps or sco : read meter bathymetry 530 515 CALL iom_open ( 'bathy_meter.nc', inum ) 531 CALL iom_get ( inum, jpdom_data, 'Bathymetry', bathy ) 516 IF ( ln_isfcav ) THEN 517 CALL iom_get ( inum, jpdom_data, 'Bathymetry_isf', bathy, lrowattr=.false. ) 518 ELSE 519 CALL iom_get ( inum, jpdom_data, 'Bathymetry' , bathy, lrowattr=ln_use_jattr ) 520 END IF 532 521 CALL iom_close( inum ) 533 ! 522 ! 534 523 risfdep(:,:)=0._wp 535 524 misfdep(:,:)=1 … … 579 568 IF ( .not. ln_sco ) THEN !== set a minimum depth ==! 580 569 ! patch to avoid case bathy = ice shelf draft and bathy between 0 and zhmin 581 WHERE (bathy == risfdep) 582 bathy = 0.0_wp ; risfdep = 0.0_wp 583 END WHERE 570 IF ( ln_isfcav ) THEN 571 WHERE (bathy == risfdep) 572 bathy = 0.0_wp ; risfdep = 0.0_wp 573 END WHERE 574 END IF 584 575 ! end patch 585 576 IF( rn_hmin < 0._wp ) THEN ; ik = - INT( rn_hmin ) ! from a nb of level … … 592 583 IF(lwp) write(numout,*) 'Minimum ocean depth: ', zhmin, ' minimum number of ocean levels : ', ik 593 584 ENDIF 594 !595 CALL wrk_dealloc( jpidta, jpjdta, idta )596 CALL wrk_dealloc( jpidta, jpjdta, zdta )597 585 ! 598 586 IF( nn_timing == 1 ) CALL timing_stop('zgr_bat') … … 959 947 !!---------------------------------------------------------------------- 960 948 !! 949 INTEGER :: ji, jj, jk ! dummy loop indices 950 INTEGER :: ik, it, ikb, ikt ! temporary integers 951 LOGICAL :: ll_print ! Allow control print for debugging 952 REAL(wp) :: ze3tp , ze3wp ! Last ocean level thickness at T- and W-points 953 REAL(wp) :: zdepwp, zdepth ! Ajusted ocean depth to avoid too small e3t 954 REAL(wp) :: zmax ! Maximum depth 955 REAL(wp) :: zdiff ! temporary scalar 956 REAL(wp) :: zrefdep ! temporary scalar 957 REAL(wp), POINTER, DIMENSION(:,:,:) :: zprt 958 !!--------------------------------------------------------------------- 959 ! 960 IF( nn_timing == 1 ) CALL timing_start('zgr_zps') 961 ! 962 CALL wrk_alloc( jpi, jpj, jpk, zprt ) 963 ! 964 IF(lwp) WRITE(numout,*) 965 IF(lwp) WRITE(numout,*) ' zgr_zps : z-coordinate with partial steps' 966 IF(lwp) WRITE(numout,*) ' ~~~~~~~ ' 967 IF(lwp) WRITE(numout,*) ' mbathy is recomputed : bathy_level file is NOT used' 968 969 ll_print = .FALSE. ! Local variable for debugging 970 971 IF(lwp .AND. ll_print) THEN ! control print of the ocean depth 972 WRITE(numout,*) 973 WRITE(numout,*) 'dom_zgr_zps: bathy (in hundred of meters)' 974 CALL prihre( bathy, jpi, jpj, 1,jpi, 1, 1, jpj, 1, 1.e-2, numout ) 975 ENDIF 976 977 978 ! bathymetry in level (from bathy_meter) 979 ! =================== 980 zmax = gdepw_1d(jpk) + e3t_1d(jpk) ! maximum depth (i.e. the last ocean level thickness <= 2*e3t_1d(jpkm1) ) 981 bathy(:,:) = MIN( zmax , bathy(:,:) ) ! bounded value of bathy (min already set at the end of zgr_bat) 982 WHERE( bathy(:,:) == 0._wp ) ; mbathy(:,:) = 0 ! land : set mbathy to 0 983 ELSE WHERE ; mbathy(:,:) = jpkm1 ! ocean : initialize mbathy to the max ocean level 984 END WHERE 985 986 ! Compute mbathy for ocean points (i.e. the number of ocean levels) 987 ! find the number of ocean levels such that the last level thickness 988 ! is larger than the minimum of e3zps_min and e3zps_rat * e3t_1d (where 989 ! e3t_1d is the reference level thickness 990 DO jk = jpkm1, 1, -1 991 zdepth = gdepw_1d(jk) + MIN( e3zps_min, e3t_1d(jk)*e3zps_rat ) 992 WHERE( 0._wp < bathy(:,:) .AND. bathy(:,:) <= zdepth ) mbathy(:,:) = jk-1 993 END DO 994 995 IF ( ln_isfcav ) CALL zgr_isf 996 997 ! Scale factors and depth at T- and W-points 998 DO jk = 1, jpk ! intitialization to the reference z-coordinate 999 gdept_0(:,:,jk) = gdept_1d(jk) 1000 gdepw_0(:,:,jk) = gdepw_1d(jk) 1001 e3t_0 (:,:,jk) = e3t_1d (jk) 1002 e3w_0 (:,:,jk) = e3w_1d (jk) 1003 END DO 1004 ! 1005 DO jj = 1, jpj 1006 DO ji = 1, jpi 1007 ik = mbathy(ji,jj) 1008 IF( ik > 0 ) THEN ! ocean point only 1009 ! max ocean level case 1010 IF( ik == jpkm1 ) THEN 1011 zdepwp = bathy(ji,jj) 1012 ze3tp = bathy(ji,jj) - gdepw_1d(ik) 1013 ze3wp = 0.5_wp * e3w_1d(ik) * ( 1._wp + ( ze3tp/e3t_1d(ik) ) ) 1014 e3t_0(ji,jj,ik ) = ze3tp 1015 e3t_0(ji,jj,ik+1) = ze3tp 1016 e3w_0(ji,jj,ik ) = ze3wp 1017 e3w_0(ji,jj,ik+1) = ze3tp 1018 gdepw_0(ji,jj,ik+1) = zdepwp 1019 gdept_0(ji,jj,ik ) = gdept_1d(ik-1) + ze3wp 1020 gdept_0(ji,jj,ik+1) = gdept_0(ji,jj,ik) + ze3tp 1021 ! 1022 ELSE ! standard case 1023 IF( bathy(ji,jj) <= gdepw_1d(ik+1) ) THEN ; gdepw_0(ji,jj,ik+1) = bathy(ji,jj) 1024 ELSE ; gdepw_0(ji,jj,ik+1) = gdepw_1d(ik+1) 1025 ENDIF 1026 !gm Bug? check the gdepw_1d 1027 ! ... on ik 1028 gdept_0(ji,jj,ik) = gdepw_1d(ik) + ( gdepw_0(ji,jj,ik+1) - gdepw_1d(ik) ) & 1029 & * ((gdept_1d( ik ) - gdepw_1d(ik) ) & 1030 & / ( gdepw_1d( ik+1) - gdepw_1d(ik) )) 1031 e3t_0 (ji,jj,ik) = e3t_1d (ik) * ( gdepw_0 (ji,jj,ik+1) - gdepw_1d(ik) ) & 1032 & / ( gdepw_1d( ik+1) - gdepw_1d(ik) ) 1033 e3w_0(ji,jj,ik) = 0.5_wp * ( gdepw_0(ji,jj,ik+1) + gdepw_1d(ik+1) - 2._wp * gdepw_1d(ik) ) & 1034 & * ( e3w_1d(ik) / ( gdepw_1d(ik+1) - gdepw_1d(ik) ) ) 1035 ! ... on ik+1 1036 e3w_0 (ji,jj,ik+1) = e3t_0 (ji,jj,ik) 1037 e3t_0 (ji,jj,ik+1) = e3t_0 (ji,jj,ik) 1038 gdept_0(ji,jj,ik+1) = gdept_0(ji,jj,ik) + e3t_0(ji,jj,ik) 1039 ENDIF 1040 ENDIF 1041 END DO 1042 END DO 1043 ! 1044 it = 0 1045 DO jj = 1, jpj 1046 DO ji = 1, jpi 1047 ik = mbathy(ji,jj) 1048 IF( ik > 0 ) THEN ! ocean point only 1049 e3tp (ji,jj) = e3t_0(ji,jj,ik) 1050 e3wp (ji,jj) = e3w_0(ji,jj,ik) 1051 ! test 1052 zdiff= gdepw_0(ji,jj,ik+1) - gdept_0(ji,jj,ik ) 1053 IF( zdiff <= 0._wp .AND. lwp ) THEN 1054 it = it + 1 1055 WRITE(numout,*) ' it = ', it, ' ik = ', ik, ' (i,j) = ', ji, jj 1056 WRITE(numout,*) ' bathy = ', bathy(ji,jj) 1057 WRITE(numout,*) ' gdept_0 = ', gdept_0(ji,jj,ik), ' gdepw_0 = ', gdepw_0(ji,jj,ik+1), ' zdiff = ', zdiff 1058 WRITE(numout,*) ' e3tp = ', e3t_0 (ji,jj,ik), ' e3wp = ', e3w_0 (ji,jj,ik ) 1059 ENDIF 1060 ENDIF 1061 END DO 1062 END DO 1063 ! 1064 IF ( ln_isfcav ) THEN 1065 ! (ISF) Definition of e3t, u, v, w for ISF case 1066 DO jj = 1, jpj 1067 DO ji = 1, jpi 1068 ik = misfdep(ji,jj) 1069 IF( ik > 1 ) THEN ! ice shelf point only 1070 IF( risfdep(ji,jj) < gdepw_1d(ik) ) risfdep(ji,jj)= gdepw_1d(ik) 1071 gdepw_0(ji,jj,ik) = risfdep(ji,jj) 1072 !gm Bug? check the gdepw_0 1073 ! ... on ik 1074 gdept_0(ji,jj,ik) = gdepw_1d(ik+1) - ( gdepw_1d(ik+1) - gdepw_0(ji,jj,ik) ) & 1075 & * ( gdepw_1d(ik+1) - gdept_1d(ik) ) & 1076 & / ( gdepw_1d(ik+1) - gdepw_1d(ik) ) 1077 e3t_0 (ji,jj,ik ) = gdepw_1d(ik+1) - gdepw_0(ji,jj,ik) 1078 e3w_0 (ji,jj,ik+1) = gdept_1d(ik+1) - gdept_0(ji,jj,ik) 1079 1080 IF( ik + 1 == mbathy(ji,jj) ) THEN ! ice shelf point only (2 cell water column) 1081 e3w_0 (ji,jj,ik+1) = gdept_0(ji,jj,ik+1) - gdept_0(ji,jj,ik) 1082 ENDIF 1083 ! ... on ik / ik-1 1084 e3w_0 (ji,jj,ik ) = 2._wp * (gdept_0(ji,jj,ik) - gdepw_0(ji,jj,ik)) 1085 e3t_0 (ji,jj,ik-1) = gdepw_0(ji,jj,ik) - gdepw_1d(ik-1) 1086 ! The next line isn't required and doesn't affect results - included for consistency with bathymetry code 1087 gdept_0(ji,jj,ik-1) = gdept_1d(ik-1) 1088 ENDIF 1089 END DO 1090 END DO 1091 ! 1092 it = 0 1093 DO jj = 1, jpj 1094 DO ji = 1, jpi 1095 ik = misfdep(ji,jj) 1096 IF( ik > 1 ) THEN ! ice shelf point only 1097 e3tp (ji,jj) = e3t_0(ji,jj,ik ) 1098 e3wp (ji,jj) = e3w_0(ji,jj,ik+1 ) 1099 ! test 1100 zdiff= gdept_0(ji,jj,ik) - gdepw_0(ji,jj,ik ) 1101 IF( zdiff <= 0. .AND. lwp ) THEN 1102 it = it + 1 1103 WRITE(numout,*) ' it = ', it, ' ik = ', ik, ' (i,j) = ', ji, jj 1104 WRITE(numout,*) ' risfdep = ', risfdep(ji,jj) 1105 WRITE(numout,*) ' gdept = ', gdept_0(ji,jj,ik), ' gdepw = ', gdepw_0(ji,jj,ik+1), ' zdiff = ', zdiff 1106 WRITE(numout,*) ' e3tp = ', e3tp(ji,jj), ' e3wp = ', e3wp(ji,jj) 1107 ENDIF 1108 ENDIF 1109 END DO 1110 END DO 1111 END IF 1112 ! END (ISF) 1113 1114 ! Scale factors and depth at U-, V-, UW and VW-points 1115 DO jk = 1, jpk ! initialisation to z-scale factors 1116 e3u_0 (:,:,jk) = e3t_1d(jk) 1117 e3v_0 (:,:,jk) = e3t_1d(jk) 1118 e3uw_0(:,:,jk) = e3w_1d(jk) 1119 e3vw_0(:,:,jk) = e3w_1d(jk) 1120 END DO 1121 DO jk = 1,jpk ! Computed as the minimum of neighbooring scale factors 1122 DO jj = 1, jpjm1 1123 DO ji = 1, fs_jpim1 ! vector opt. 1124 e3u_0 (ji,jj,jk) = MIN( e3t_0(ji,jj,jk), e3t_0(ji+1,jj,jk) ) 1125 e3v_0 (ji,jj,jk) = MIN( e3t_0(ji,jj,jk), e3t_0(ji,jj+1,jk) ) 1126 e3uw_0(ji,jj,jk) = MIN( e3w_0(ji,jj,jk), e3w_0(ji+1,jj,jk) ) 1127 e3vw_0(ji,jj,jk) = MIN( e3w_0(ji,jj,jk), e3w_0(ji,jj+1,jk) ) 1128 END DO 1129 END DO 1130 END DO 1131 IF ( ln_isfcav ) THEN 1132 ! (ISF) define e3uw (adapted for 2 cells in the water column) 1133 DO jj = 2, jpjm1 1134 DO ji = 2, fs_jpim1 ! vector opt. 1135 ikb = MAX(mbathy (ji,jj),mbathy (ji+1,jj)) 1136 ikt = MAX(misfdep(ji,jj),misfdep(ji+1,jj)) 1137 IF (ikb == ikt+1) e3uw_0(ji,jj,ikb) = MIN( gdept_0(ji,jj,ikb ), gdept_0(ji+1,jj ,ikb ) ) & 1138 & - MAX( gdept_0(ji,jj,ikb-1), gdept_0(ji+1,jj ,ikb-1) ) 1139 ikb = MAX(mbathy (ji,jj),mbathy (ji,jj+1)) 1140 ikt = MAX(misfdep(ji,jj),misfdep(ji,jj+1)) 1141 IF (ikb == ikt+1) e3vw_0(ji,jj,ikb) = MIN( gdept_0(ji,jj,ikb ), gdept_0(ji ,jj+1,ikb ) ) & 1142 & - MAX( gdept_0(ji,jj,ikb-1), gdept_0(ji ,jj+1,ikb-1) ) 1143 END DO 1144 END DO 1145 END IF 1146 1147 CALL lbc_lnk( e3u_0 , 'U', 1._wp ) ; CALL lbc_lnk( e3uw_0, 'U', 1._wp ) ! lateral boundary conditions 1148 CALL lbc_lnk( e3v_0 , 'V', 1._wp ) ; CALL lbc_lnk( e3vw_0, 'V', 1._wp ) 1149 ! 1150 DO jk = 1, jpk ! set to z-scale factor if zero (i.e. along closed boundaries) 1151 WHERE( e3u_0 (:,:,jk) == 0._wp ) e3u_0 (:,:,jk) = e3t_1d(jk) 1152 WHERE( e3v_0 (:,:,jk) == 0._wp ) e3v_0 (:,:,jk) = e3t_1d(jk) 1153 WHERE( e3uw_0(:,:,jk) == 0._wp ) e3uw_0(:,:,jk) = e3w_1d(jk) 1154 WHERE( e3vw_0(:,:,jk) == 0._wp ) e3vw_0(:,:,jk) = e3w_1d(jk) 1155 END DO 1156 1157 ! Scale factor at F-point 1158 DO jk = 1, jpk ! initialisation to z-scale factors 1159 e3f_0(:,:,jk) = e3t_1d(jk) 1160 END DO 1161 DO jk = 1, jpk ! Computed as the minimum of neighbooring V-scale factors 1162 DO jj = 1, jpjm1 1163 DO ji = 1, fs_jpim1 ! vector opt. 1164 e3f_0(ji,jj,jk) = MIN( e3v_0(ji,jj,jk), e3v_0(ji+1,jj,jk) ) 1165 END DO 1166 END DO 1167 END DO 1168 CALL lbc_lnk( e3f_0, 'F', 1._wp ) ! Lateral boundary conditions 1169 ! 1170 DO jk = 1, jpk ! set to z-scale factor if zero (i.e. along closed boundaries) 1171 WHERE( e3f_0(:,:,jk) == 0._wp ) e3f_0(:,:,jk) = e3t_1d(jk) 1172 END DO 1173 !!gm bug ? : must be a do loop with mj0,mj1 1174 ! 1175 e3t_0(:,mj0(1),:) = e3t_0(:,mj0(2),:) ! we duplicate factor scales for jj = 1 and jj = 2 1176 e3w_0(:,mj0(1),:) = e3w_0(:,mj0(2),:) 1177 e3u_0(:,mj0(1),:) = e3u_0(:,mj0(2),:) 1178 e3v_0(:,mj0(1),:) = e3v_0(:,mj0(2),:) 1179 e3f_0(:,mj0(1),:) = e3f_0(:,mj0(2),:) 1180 1181 ! Control of the sign 1182 IF( MINVAL( e3t_0 (:,:,:) ) <= 0._wp ) CALL ctl_stop( ' zgr_zps : e r r o r e3t_0 <= 0' ) 1183 IF( MINVAL( e3w_0 (:,:,:) ) <= 0._wp ) CALL ctl_stop( ' zgr_zps : e r r o r e3w_0 <= 0' ) 1184 IF( MINVAL( gdept_0(:,:,:) ) < 0._wp ) CALL ctl_stop( ' zgr_zps : e r r o r gdept_0 < 0' ) 1185 IF( MINVAL( gdepw_0(:,:,:) ) < 0._wp ) CALL ctl_stop( ' zgr_zps : e r r o r gdepw_0 < 0' ) 1186 1187 ! Compute gdep3w_0 (vertical sum of e3w) 1188 IF ( ln_isfcav ) THEN ! if cavity 1189 WHERE (misfdep == 0) misfdep = 1 1190 DO jj = 1,jpj 1191 DO ji = 1,jpi 1192 gdep3w_0(ji,jj,1) = 0.5_wp * e3w_0(ji,jj,1) 1193 DO jk = 2, misfdep(ji,jj) 1194 gdep3w_0(ji,jj,jk) = gdep3w_0(ji,jj,jk-1) + e3w_0(ji,jj,jk) 1195 END DO 1196 IF (misfdep(ji,jj) .GE. 2) gdep3w_0(ji,jj,misfdep(ji,jj)) = risfdep(ji,jj) + 0.5_wp * e3w_0(ji,jj,misfdep(ji,jj)) 1197 DO jk = misfdep(ji,jj) + 1, jpk 1198 gdep3w_0(ji,jj,jk) = gdep3w_0(ji,jj,jk-1) + e3w_0(ji,jj,jk) 1199 END DO 1200 END DO 1201 END DO 1202 ELSE ! no cavity 1203 gdep3w_0(:,:,1) = 0.5_wp * e3w_0(:,:,1) 1204 DO jk = 2, jpk 1205 gdep3w_0(:,:,jk) = gdep3w_0(:,:,jk-1) + e3w_0(:,:,jk) 1206 END DO 1207 END IF 1208 ! ! ================= ! 1209 IF(lwp .AND. ll_print) THEN ! Control print ! 1210 ! ! ================= ! 1211 DO jj = 1,jpj 1212 DO ji = 1, jpi 1213 ik = MAX( mbathy(ji,jj), 1 ) 1214 zprt(ji,jj,1) = e3t_0 (ji,jj,ik) 1215 zprt(ji,jj,2) = e3w_0 (ji,jj,ik) 1216 zprt(ji,jj,3) = e3u_0 (ji,jj,ik) 1217 zprt(ji,jj,4) = e3v_0 (ji,jj,ik) 1218 zprt(ji,jj,5) = e3f_0 (ji,jj,ik) 1219 zprt(ji,jj,6) = gdep3w_0(ji,jj,ik) 1220 END DO 1221 END DO 1222 WRITE(numout,*) 1223 WRITE(numout,*) 'domzgr e3t(mbathy)' ; CALL prihre(zprt(:,:,1),jpi,jpj,1,jpi,1,1,jpj,1,1.e-3,numout) 1224 WRITE(numout,*) 1225 WRITE(numout,*) 'domzgr e3w(mbathy)' ; CALL prihre(zprt(:,:,2),jpi,jpj,1,jpi,1,1,jpj,1,1.e-3,numout) 1226 WRITE(numout,*) 1227 WRITE(numout,*) 'domzgr e3u(mbathy)' ; CALL prihre(zprt(:,:,3),jpi,jpj,1,jpi,1,1,jpj,1,1.e-3,numout) 1228 WRITE(numout,*) 1229 WRITE(numout,*) 'domzgr e3v(mbathy)' ; CALL prihre(zprt(:,:,4),jpi,jpj,1,jpi,1,1,jpj,1,1.e-3,numout) 1230 WRITE(numout,*) 1231 WRITE(numout,*) 'domzgr e3f(mbathy)' ; CALL prihre(zprt(:,:,5),jpi,jpj,1,jpi,1,1,jpj,1,1.e-3,numout) 1232 WRITE(numout,*) 1233 WRITE(numout,*) 'domzgr gdep3w(mbathy)' ; CALL prihre(zprt(:,:,6),jpi,jpj,1,jpi,1,1,jpj,1,1.e-3,numout) 1234 ENDIF 1235 ! 1236 CALL wrk_dealloc( jpi, jpj, jpk, zprt ) 1237 ! 1238 IF( nn_timing == 1 ) CALL timing_stop('zgr_zps') 1239 ! 1240 END SUBROUTINE zgr_zps 1241 1242 SUBROUTINE zgr_isf 1243 !!---------------------------------------------------------------------- 1244 !! *** ROUTINE zgr_isf *** 1245 !! 1246 !! ** Purpose : check the bathymetry in levels 1247 !! 1248 !! ** Method : THe water column have to contained at least 2 cells 1249 !! Bathymetry and isfdraft are modified (dig/close) to respect 1250 !! this criterion. 1251 !! 1252 !! 1253 !! ** Action : - test compatibility between isfdraft and bathy 1254 !! - bathy and isfdraft are modified 1255 !!---------------------------------------------------------------------- 1256 !! 961 1257 INTEGER :: ji, jj, jk, jl ! dummy loop indices 962 1258 INTEGER :: ik, it ! temporary integers … … 969 1265 REAL(wp) :: zdiff ! temporary scalar 970 1266 REAL(wp) :: zrefdep ! temporary scalar 971 REAL(wp) :: zbathydiff, zrisfdepdiff 972 REAL(wp), POINTER, DIMENSION(:,:) :: zrisfdep, zbathy, zmask ! 3D workspace (ISH) 973 INTEGER , POINTER, DIMENSION(:,:) :: zmbathy, zmisfdep ! 3D workspace (ISH) 974 REAL(wp), POINTER, DIMENSION(:,:,:) :: zprt 1267 REAL(wp) :: zbathydiff, zrisfdepdiff ! isf temporary scalar 1268 REAL(wp), POINTER, DIMENSION(:,:) :: zrisfdep, zbathy, zmask ! 2D workspace (ISH) 1269 INTEGER , POINTER, DIMENSION(:,:) :: zmbathy, zmisfdep ! 2D workspace (ISH) 975 1270 !!--------------------------------------------------------------------- 976 1271 ! 977 IF( nn_timing == 1 ) CALL timing_start('zgr_zps') 978 ! 979 CALL wrk_alloc( jpi, jpj, jpk, zprt ) 1272 IF( nn_timing == 1 ) CALL timing_start('zgr_isf') 1273 ! 980 1274 CALL wrk_alloc( jpi, jpj, zbathy, zmask, zrisfdep) 981 CALL wrk_alloc( jpi, jpj, zmbathy, zmisfdep) 982 ! 983 IF(lwp) WRITE(numout,*) 984 IF(lwp) WRITE(numout,*) ' zgr_zps : z-coordinate with partial steps' 985 IF(lwp) WRITE(numout,*) ' ~~~~~~~ ' 986 IF(lwp) WRITE(numout,*) ' mbathy is recomputed : bathy_level file is NOT used' 987 988 ll_print = .FALSE. ! Local variable for debugging 989 990 IF(lwp .AND. ll_print) THEN ! control print of the ocean depth 991 WRITE(numout,*) 992 WRITE(numout,*) 'dom_zgr_zps: bathy (in hundred of meters)' 993 CALL prihre( bathy, jpi, jpj, 1,jpi, 1, 1, jpj, 1, 1.e-2, numout ) 994 ENDIF 995 996 ! bathymetry in level (from bathy_meter) 997 ! =================== 998 zmax = gdepw_1d(jpk) + e3t_1d(jpk) ! maximum depth (i.e. the last ocean level thickness <= 2*e3t_1d(jpkm1) ) 999 bathy(:,:) = MIN( zmax , bathy(:,:) ) ! bounded value of bathy (min already set at the end of zgr_bat) 1000 WHERE( bathy(:,:) == 0._wp ) ; mbathy(:,:) = 0 ! land : set mbathy to 0 1001 ELSE WHERE ; mbathy(:,:) = jpkm1 ! ocean : initialize mbathy to the max ocean level 1002 END WHERE 1003 1004 ! Compute mbathy for ocean points (i.e. the number of ocean levels) 1005 ! find the number of ocean levels such that the last level thickness 1006 ! is larger than the minimum of e3zps_min and e3zps_rat * e3t_1d (where 1007 ! e3t_1d is the reference level thickness 1008 DO jk = jpkm1, 1, -1 1009 zdepth = gdepw_1d(jk) + MIN( e3zps_min, e3t_1d(jk)*e3zps_rat ) 1010 WHERE( 0._wp < bathy(:,:) .AND. bathy(:,:) <= zdepth ) mbathy(:,:) = jk-1 1011 END DO 1275 CALL wrk_alloc( jpi, jpj, zmisfdep, zmbathy ) 1276 1277 1012 1278 ! (ISF) compute misfdep 1013 1279 WHERE( risfdep(:,:) == 0._wp .AND. bathy(:,:) .NE. 0) ; misfdep(:,:) = 1 ! open water : set misfdep to 1 … … 1053 1319 misfdep(jpi,:) = misfdep( 2 ,:) 1054 1320 ENDIF 1055 1321 1056 1322 IF( nperio == 1 .OR. nperio == 4 .OR. nperio == 6 ) THEN 1057 1323 mbathy( 1 ,:) = mbathy(jpim1,:) ! local domain is cyclic east-west 1058 1324 mbathy(jpi,:) = mbathy( 2 ,:) 1059 1325 ENDIF 1060 1326 1061 1327 ! split last cell if possible (only where water column is 2 cell or less) 1062 1328 DO jk = jpkm1, 1, -1 … … 1076 1342 END WHERE 1077 1343 END DO 1078 1344 1079 1345 1080 1346 ! Case where bathy and risfdep compatible but not the level variable mbathy/misfdep because of partial cell condition … … 1252 1518 1253 1519 ! remove single point "bay" on isf coast line in the ice shelf draft' 1254 DO jk = 1, jpk1520 DO jk = 2, jpk 1255 1521 WHERE (misfdep==0) misfdep=jpk 1256 1522 zmask=0 … … 1357 1623 IF( zmbathy(ji,jj) .LT. misfdep(ji ,jj+1) ) ibtestjp1 = 0 1358 1624 ibtest=MAX(ibtestim1, ibtestip1, ibtestjm1, ibtestjp1) 1359 IF( ibtest == 0 ) THEN1625 IF( ibtest == 0 .AND. misfdep(ji,jj) .GE. 2) THEN 1360 1626 mbathy(ji,jj) = 0 ; bathy(ji,jj) = 0.0_wp ; misfdep(ji,jj) = 0 ; risfdep(ji,jj) = 0.0_wp ; 1361 1627 END IF … … 1473 1739 ENDIF 1474 1740 1475 ! Scale factors and depth at T- and W-points1476 DO jk = 1, jpk ! intitialization to the reference z-coordinate1477 gdept_0(:,:,jk) = gdept_1d(jk)1478 gdepw_0(:,:,jk) = gdepw_1d(jk)1479 e3t_0 (:,:,jk) = e3t_1d (jk)1480 e3w_0 (:,:,jk) = e3w_1d (jk)1481 END DO1482 !1483 DO jj = 1, jpj1484 DO ji = 1, jpi1485 ik = mbathy(ji,jj)1486 IF( ik > 0 ) THEN ! ocean point only1487 ! max ocean level case1488 IF( ik == jpkm1 ) THEN1489 zdepwp = bathy(ji,jj)1490 ze3tp = bathy(ji,jj) - gdepw_1d(ik)1491 ze3wp = 0.5_wp * e3w_1d(ik) * ( 1._wp + ( ze3tp/e3t_1d(ik) ) )1492 e3t_0(ji,jj,ik ) = ze3tp1493 e3t_0(ji,jj,ik+1) = ze3tp1494 e3w_0(ji,jj,ik ) = ze3wp1495 e3w_0(ji,jj,ik+1) = ze3tp1496 gdepw_0(ji,jj,ik+1) = zdepwp1497 gdept_0(ji,jj,ik ) = gdept_1d(ik-1) + ze3wp1498 gdept_0(ji,jj,ik+1) = gdept_0(ji,jj,ik) + ze3tp1499 !1500 ELSE ! standard case1501 IF( bathy(ji,jj) <= gdepw_1d(ik+1) ) THEN ; gdepw_0(ji,jj,ik+1) = bathy(ji,jj)1502 ELSE ; gdepw_0(ji,jj,ik+1) = gdepw_1d(ik+1)1503 ENDIF1504 !gm Bug? check the gdepw_1d1505 ! ... on ik1506 gdept_0(ji,jj,ik) = gdepw_1d(ik) + ( gdepw_0(ji,jj,ik+1) - gdepw_1d(ik) ) &1507 & * ((gdept_1d( ik ) - gdepw_1d(ik) ) &1508 & / ( gdepw_1d( ik+1) - gdepw_1d(ik) ))1509 e3t_0(ji,jj,ik) = e3t_1d (ik) * ( gdepw_0 (ji,jj,ik+1) - gdepw_1d(ik) ) &1510 & / ( gdepw_1d( ik+1) - gdepw_1d(ik) )1511 e3w_0(ji,jj,ik) = 0.5_wp * ( gdepw_0(ji,jj,ik+1) + gdepw_1d(ik+1) - 2._wp * gdepw_1d(ik) ) &1512 & * ( e3w_1d(ik) / ( gdepw_1d(ik+1) - gdepw_1d(ik) ) )1513 ! ... on ik+11514 e3w_0 (ji,jj,ik+1) = e3t_0 (ji,jj,ik)1515 e3t_0 (ji,jj,ik+1) = e3t_0 (ji,jj,ik)1516 gdept_0(ji,jj,ik+1) = gdept_0(ji,jj,ik) + e3t_0(ji,jj,ik)1517 ENDIF1518 ENDIF1519 END DO1520 END DO1521 !1522 it = 01523 DO jj = 1, jpj1524 DO ji = 1, jpi1525 ik = mbathy(ji,jj)1526 IF( ik > 0 ) THEN ! ocean point only1527 e3tp (ji,jj) = e3t_0(ji,jj,ik)1528 e3wp (ji,jj) = e3w_0(ji,jj,ik)1529 ! test1530 zdiff= gdepw_0(ji,jj,ik+1) - gdept_0(ji,jj,ik )1531 IF( zdiff <= 0._wp .AND. lwp ) THEN1532 it = it + 11533 WRITE(numout,*) ' it = ', it, ' ik = ', ik, ' (i,j) = ', ji, jj1534 WRITE(numout,*) ' bathy = ', bathy(ji,jj)1535 WRITE(numout,*) ' gdept_0 = ', gdept_0(ji,jj,ik), ' gdepw_0 = ', gdepw_0(ji,jj,ik+1), ' zdiff = ', zdiff1536 WRITE(numout,*) ' e3tp = ', e3t_0 (ji,jj,ik), ' e3wp = ', e3w_0 (ji,jj,ik )1537 ENDIF1538 ENDIF1539 END DO1540 END DO1541 !1542 ! (ISF) Definition of e3t, u, v, w for ISF case1543 DO jj = 1, jpj1544 DO ji = 1, jpi1545 ik = misfdep(ji,jj)1546 IF( ik > 1 ) THEN ! ice shelf point only1547 IF( risfdep(ji,jj) < gdepw_1d(ik) ) risfdep(ji,jj)= gdepw_1d(ik)1548 gdepw_0(ji,jj,ik) = risfdep(ji,jj)1549 !gm Bug? check the gdepw_01550 ! ... on ik1551 gdept_0(ji,jj,ik) = gdepw_1d(ik+1) - ( gdepw_1d(ik+1) - gdepw_0(ji,jj,ik) ) &1552 & * ( gdepw_1d(ik+1) - gdept_1d(ik) ) &1553 & / ( gdepw_1d(ik+1) - gdepw_1d(ik) )1554 e3t_0 (ji,jj,ik ) = gdepw_1d(ik+1) - gdepw_0(ji,jj,ik)1555 e3w_0 (ji,jj,ik+1) = gdept_1d(ik+1) - gdept_0(ji,jj,ik)1556 1557 IF( ik + 1 == mbathy(ji,jj) ) THEN ! ice shelf point only (2 cell water column)1558 e3w_0 (ji,jj,ik+1) = gdept_0(ji,jj,ik+1) - gdept_0(ji,jj,ik)1559 ENDIF1560 ! ... on ik / ik-11561 e3w_0 (ji,jj,ik ) = 2._wp * (gdept_0(ji,jj,ik) - gdepw_0(ji,jj,ik))1562 e3t_0 (ji,jj,ik-1) = gdepw_0(ji,jj,ik) - gdepw_1d(ik-1)1563 ! The next line isn't required and doesn't affect results - included for consistency with bathymetry code1564 gdept_0(ji,jj,ik-1) = gdept_1d(ik-1)1565 ENDIF1566 END DO1567 END DO1568 !1569 it = 01570 DO jj = 1, jpj1571 DO ji = 1, jpi1572 ik = misfdep(ji,jj)1573 IF( ik > 1 ) THEN ! ice shelf point only1574 e3tp (ji,jj) = e3t_0(ji,jj,ik )1575 e3wp (ji,jj) = e3w_0(ji,jj,ik+1 )1576 ! test1577 zdiff= gdept_0(ji,jj,ik) - gdepw_0(ji,jj,ik )1578 IF( zdiff <= 0. .AND. lwp ) THEN1579 it = it + 11580 WRITE(numout,*) ' it = ', it, ' ik = ', ik, ' (i,j) = ', ji, jj1581 WRITE(numout,*) ' risfdep = ', risfdep(ji,jj)1582 WRITE(numout,*) ' gdept = ', gdept_0(ji,jj,ik), ' gdepw = ', gdepw_0(ji,jj,ik+1), ' zdiff = ', zdiff1583 WRITE(numout,*) ' e3tp = ', e3tp(ji,jj), ' e3wp = ', e3wp(ji,jj)1584 ENDIF1585 ENDIF1586 END DO1587 END DO1588 ! END (ISF)1589 1590 ! Scale factors and depth at U-, V-, UW and VW-points1591 DO jk = 1, jpk ! initialisation to z-scale factors1592 e3u_0 (:,:,jk) = e3t_1d(jk)1593 e3v_0 (:,:,jk) = e3t_1d(jk)1594 e3uw_0(:,:,jk) = e3w_1d(jk)1595 e3vw_0(:,:,jk) = e3w_1d(jk)1596 END DO1597 DO jk = 1,jpk ! Computed as the minimum of neighbooring scale factors1598 DO jj = 1, jpjm11599 DO ji = 1, fs_jpim1 ! vector opt.1600 e3u_0 (ji,jj,jk) = MIN( e3t_0(ji,jj,jk), e3t_0(ji+1,jj,jk) )1601 e3v_0 (ji,jj,jk) = MIN( e3t_0(ji,jj,jk), e3t_0(ji,jj+1,jk) )1602 e3uw_0(ji,jj,jk) = MIN( e3w_0(ji,jj,jk), e3w_0(ji+1,jj,jk) )1603 e3vw_0(ji,jj,jk) = MIN( e3w_0(ji,jj,jk), e3w_0(ji,jj+1,jk) )1604 END DO1605 END DO1606 END DO1607 ! (ISF) define e3uw1608 DO jk = 2,jpk1609 DO jj = 1, jpjm11610 DO ji = 1, fs_jpim1 ! vector opt.1611 e3uw_0(ji,jj,jk) = MIN( gdept_0(ji,jj,jk), gdept_0(ji+1,jj ,jk) ) &1612 & - MAX( gdept_0(ji,jj,jk-1), gdept_0(ji+1,jj ,jk-1) )1613 e3vw_0(ji,jj,jk) = MIN( gdept_0(ji,jj,jk), gdept_0(ji ,jj+1,jk) ) &1614 & - MAX( gdept_0(ji,jj,jk-1), gdept_0(ji ,jj+1,jk-1) )1615 END DO1616 END DO1617 END DO1618 !End (ISF)1619 1620 CALL lbc_lnk( e3u_0 , 'U', 1._wp ) ; CALL lbc_lnk( e3uw_0, 'U', 1._wp ) ! lateral boundary conditions1621 CALL lbc_lnk( e3v_0 , 'V', 1._wp ) ; CALL lbc_lnk( e3vw_0, 'V', 1._wp )1622 !1623 DO jk = 1, jpk ! set to z-scale factor if zero (i.e. along closed boundaries)1624 WHERE( e3u_0 (:,:,jk) == 0._wp ) e3u_0 (:,:,jk) = e3t_1d(jk)1625 WHERE( e3v_0 (:,:,jk) == 0._wp ) e3v_0 (:,:,jk) = e3t_1d(jk)1626 WHERE( e3uw_0(:,:,jk) == 0._wp ) e3uw_0(:,:,jk) = e3w_1d(jk)1627 WHERE( e3vw_0(:,:,jk) == 0._wp ) e3vw_0(:,:,jk) = e3w_1d(jk)1628 END DO1629 1630 ! Scale factor at F-point1631 DO jk = 1, jpk ! initialisation to z-scale factors1632 e3f_0(:,:,jk) = e3t_1d(jk)1633 END DO1634 DO jk = 1, jpk ! Computed as the minimum of neighbooring V-scale factors1635 DO jj = 1, jpjm11636 DO ji = 1, fs_jpim1 ! vector opt.1637 e3f_0(ji,jj,jk) = MIN( e3v_0(ji,jj,jk), e3v_0(ji+1,jj,jk) )1638 END DO1639 END DO1640 END DO1641 CALL lbc_lnk( e3f_0, 'F', 1._wp ) ! Lateral boundary conditions1642 !1643 DO jk = 1, jpk ! set to z-scale factor if zero (i.e. along closed boundaries)1644 WHERE( e3f_0(:,:,jk) == 0._wp ) e3f_0(:,:,jk) = e3t_1d(jk)1645 END DO1646 !!gm bug ? : must be a do loop with mj0,mj11647 !1648 e3t_0(:,mj0(1),:) = e3t_0(:,mj0(2),:) ! we duplicate factor scales for jj = 1 and jj = 21649 e3w_0(:,mj0(1),:) = e3w_0(:,mj0(2),:)1650 e3u_0(:,mj0(1),:) = e3u_0(:,mj0(2),:)1651 e3v_0(:,mj0(1),:) = e3v_0(:,mj0(2),:)1652 e3f_0(:,mj0(1),:) = e3f_0(:,mj0(2),:)1653 1654 ! Control of the sign1655 IF( MINVAL( e3t_0 (:,:,:) ) <= 0._wp ) CALL ctl_stop( ' zgr_zps : e r r o r e3t_0 <= 0' )1656 IF( MINVAL( e3w_0 (:,:,:) ) <= 0._wp ) CALL ctl_stop( ' zgr_zps : e r r o r e3w_0 <= 0' )1657 IF( MINVAL( gdept_0(:,:,:) ) < 0._wp ) CALL ctl_stop( ' zgr_zps : e r r o r gdept_0 < 0' )1658 IF( MINVAL( gdepw_0(:,:,:) ) < 0._wp ) CALL ctl_stop( ' zgr_zps : e r r o r gdepw_0 < 0' )1659 1660 ! Compute gdep3w_0 (vertical sum of e3w)1661 WHERE (misfdep == 0) misfdep = 11662 DO jj = 1,jpj1663 DO ji = 1,jpi1664 gdep3w_0(ji,jj,1) = 0.5_wp * e3w_0(ji,jj,1)1665 DO jk = 2, misfdep(ji,jj)1666 gdep3w_0(ji,jj,jk) = gdep3w_0(ji,jj,jk-1) + e3w_0(ji,jj,jk)1667 END DO1668 IF (misfdep(ji,jj) .GE. 2) gdep3w_0(ji,jj,misfdep(ji,jj)) = risfdep(ji,jj) + 0.5_wp * e3w_0(ji,jj,misfdep(ji,jj))1669 DO jk = misfdep(ji,jj) + 1, jpk1670 gdep3w_0(ji,jj,jk) = gdep3w_0(ji,jj,jk-1) + e3w_0(ji,jj,jk)1671 END DO1672 END DO1673 END DO1674 ! ! ================= !1675 IF(lwp .AND. ll_print) THEN ! Control print !1676 ! ! ================= !1677 DO jj = 1,jpj1678 DO ji = 1, jpi1679 ik = MAX( mbathy(ji,jj), 1 )1680 zprt(ji,jj,1) = e3t_0 (ji,jj,ik)1681 zprt(ji,jj,2) = e3w_0 (ji,jj,ik)1682 zprt(ji,jj,3) = e3u_0 (ji,jj,ik)1683 zprt(ji,jj,4) = e3v_0 (ji,jj,ik)1684 zprt(ji,jj,5) = e3f_0 (ji,jj,ik)1685 zprt(ji,jj,6) = gdep3w_0(ji,jj,ik)1686 END DO1687 END DO1688 WRITE(numout,*)1689 WRITE(numout,*) 'domzgr e3t(mbathy)' ; CALL prihre(zprt(:,:,1),jpi,jpj,1,jpi,1,1,jpj,1,1.e-3,numout)1690 WRITE(numout,*)1691 WRITE(numout,*) 'domzgr e3w(mbathy)' ; CALL prihre(zprt(:,:,2),jpi,jpj,1,jpi,1,1,jpj,1,1.e-3,numout)1692 WRITE(numout,*)1693 WRITE(numout,*) 'domzgr e3u(mbathy)' ; CALL prihre(zprt(:,:,3),jpi,jpj,1,jpi,1,1,jpj,1,1.e-3,numout)1694 WRITE(numout,*)1695 WRITE(numout,*) 'domzgr e3v(mbathy)' ; CALL prihre(zprt(:,:,4),jpi,jpj,1,jpi,1,1,jpj,1,1.e-3,numout)1696 WRITE(numout,*)1697 WRITE(numout,*) 'domzgr e3f(mbathy)' ; CALL prihre(zprt(:,:,5),jpi,jpj,1,jpi,1,1,jpj,1,1.e-3,numout)1698 WRITE(numout,*)1699 WRITE(numout,*) 'domzgr gdep3w(mbathy)' ; CALL prihre(zprt(:,:,6),jpi,jpj,1,jpi,1,1,jpj,1,1.e-3,numout)1700 ENDIF1701 !1702 CALL wrk_dealloc( jpi, jpj, jpk, zprt )1703 1741 CALL wrk_dealloc( jpi, jpj, zmask, zbathy, zrisfdep ) 1704 1742 CALL wrk_dealloc( jpi, jpj, zmisfdep, zmbathy ) 1705 ! 1706 IF( nn_timing == 1 ) CALL timing_stop('zgr_ zps')1707 !1708 END SUBROUTINE zgr_zps1743 1744 IF( nn_timing == 1 ) CALL timing_stop('zgr_isf') 1745 1746 END SUBROUTINE 1709 1747 1710 1748 SUBROUTINE zgr_sco -
branches/2014/dev_r4621_NOC4_BDY_VERT_INTERP/NEMOGCM/NEMO/OPA_SRC/DOM/dtatsd.F90
- Property svn:keywords set to Id
r5038 r5620 39 39 !!---------------------------------------------------------------------- 40 40 !! NEMO/OPA 3.3 , NEMO Consortium (2010) 41 !! $Id : dtatem.F90 2392 2010-11-15 21:20:05Z gm$41 !! $Id$ 42 42 !! Software governed by the CeCILL licence (NEMOGCM/NEMO_CeCILL.txt) 43 43 !!---------------------------------------------------------------------- -
branches/2014/dev_r4621_NOC4_BDY_VERT_INTERP/NEMOGCM/NEMO/OPA_SRC/DOM/istate.F90
r5038 r5620 69 69 !! ** Purpose : Initialization of the dynamics and tracer fields. 70 70 !!---------------------------------------------------------------------- 71 ! - ML - needed for initialization of e3t_b 72 INTEGER :: ji,jj,jk ! dummy loop indices 73 REAL(wp), POINTER, DIMENSION(:,:,:,:) :: zuvd ! U & V data workspace 71 INTEGER :: ji, jj, jk ! dummy loop indices 72 REAL(wp), POINTER, DIMENSION(:,:,:,:) :: zuvd ! U & V data workspace 74 73 !!---------------------------------------------------------------------- 75 74 ! … … 84 83 IF( lk_c1d ) CALL dta_uvd_init ! Initialization of U & V input data 85 84 86 rhd (:,:,: ) = 0._wp 87 rhop (:,:,: ) = 0._wp 88 rn2 (:,:,: ) = 0._wp 89 tsa (:,:,:,:) = 0._wp 90 rab_b(:,:,:,:) = 0._wp 91 rab_n(:,:,:,:) = 0._wp 85 rhd (:,:,: ) = 0._wp ; rhop (:,:,: ) = 0._wp ! set one for all to 0 at level jpk 86 rn2b (:,:,: ) = 0._wp ; rn2 (:,:,: ) = 0._wp ! set one for all to 0 at levels 1 and jpk 87 tsa (:,:,:,:) = 0._wp ! set one for all to 0 at level jpk 88 rab_b(:,:,:,:) = 0._wp ; rab_n(:,:,:,:) = 0._wp ! set one for all to 0 at level jpk 92 89 93 90 IF( ln_rstart ) THEN ! Restart from a file … … 113 110 ELSEIF( cp_cfg == 'gyre' ) THEN 114 111 CALL istate_gyre ! GYRE configuration : start from pre-defined T-S fields 115 ELSEIF( cp_cfg == 'isomip' .OR. cp_cfg == 'isomip2') THEN116 IF(lwp) WRITE(numout,*) 'Initialization of T+S for ISOMIP domain'117 tsn(:,:,:,jp_tem)=-1.9*tmask(:,:,:) ! ISOMIP configuration : start from constant T+S fields118 tsn(:,:,:,jp_sal)=34.4*tmask(:,:,:)119 tsb(:,:,:,:)=tsn(:,:,:,:)120 112 ELSE ! Initial T-S, U-V fields read in files 121 113 IF ( ln_tsd_init ) THEN ! read 3D T and S data at nit000 … … 137 129 CALL eos( tsb, rhd, rhop, gdept_0(:,:,:) ) ! before potential and in situ densities 138 130 #if ! defined key_c1d 139 IF( ln_zps ) CALL zps_hde( nit000, jpts, tsb, gtsu, gtsv, & ! Partial steps: before horizontal gradient 140 & rhd, gru , grv, aru, arv, gzu, gzv, ge3ru, ge3rv, & ! 141 & gtui, gtvi, grui, grvi, arui, arvi, gzui, gzvi, ge3rui, ge3rvi ) ! of t, s, rd at the last ocean level 131 IF( ln_zps .AND. .NOT. ln_isfcav) & 132 & CALL zps_hde ( nit000, jpts, tsb, gtsu, gtsv, & ! Partial steps: before horizontal gradient 133 & rhd, gru , grv ) ! of t, s, rd at the last ocean level 134 IF( ln_zps .AND. ln_isfcav) & 135 & CALL zps_hde_isf( nit000, jpts, tsb, gtsu, gtsv, & ! Partial steps for top cell (ISF) 136 & rhd, gru , grv , aru , arv , gzu , gzv , ge3ru , ge3rv , & 137 & gtui, gtvi, grui, grvi, arui, arvi, gzui, gzvi, ge3rui, ge3rvi ) ! of t, s, rd at the last ocean level 142 138 #endif 143 139 ! -
branches/2014/dev_r4621_NOC4_BDY_VERT_INTERP/NEMOGCM/NEMO/OPA_SRC/DOM/phycst.F90
r5038 r5620 41 41 REAL(wp), PUBLIC :: rt0 = 273.15_wp !: freezing point of fresh water [Kelvin] 42 42 #if defined key_lim3 43 REAL(wp), PUBLIC :: rt0_snow = 273.1 6_wp !: melting point of snow [Kelvin]44 REAL(wp), PUBLIC :: rt0_ice = 273.1 6_wp !: melting point of ice [Kelvin]43 REAL(wp), PUBLIC :: rt0_snow = 273.15_wp !: melting point of snow [Kelvin] 44 REAL(wp), PUBLIC :: rt0_ice = 273.15_wp !: melting point of ice [Kelvin] 45 45 #else 46 46 REAL(wp), PUBLIC :: rt0_snow = 273.15_wp !: melting point of snow [Kelvin] … … 51 51 REAL(wp), PUBLIC :: rcp !: ocean specific heat [J/Kelvin] 52 52 REAL(wp), PUBLIC :: r1_rcp !: = 1. / rcp [Kelvin/J] 53 REAL(wp), PUBLIC :: rau0_rcp !: = rau0 * rcp 53 54 REAL(wp), PUBLIC :: r1_rau0_rcp !: = 1. / ( rau0 * rcp ) 54 55 … … 82 83 REAL(wp), PUBLIC :: xlic = 300.33e+6_wp !: volumetric latent heat fusion of ice [J/m3] 83 84 REAL(wp), PUBLIC :: xsn = 2.8e+6_wp !: volumetric latent heat of sublimation of snow [J/m3] 85 #endif 86 #if defined key_lim3 87 REAL(wp), PUBLIC :: r1_rhoic !: 1 / rhoic 88 REAL(wp), PUBLIC :: r1_rhosn !: 1 / rhosn 84 89 #endif 85 90 !!---------------------------------------------------------------------- … … 166 171 lfus = xlsn / rhosn ! latent heat of fusion of fresh ice 167 172 #endif 168 173 #if defined key_lim3 174 r1_rhoic = 1._wp / rhoic 175 r1_rhosn = 1._wp / rhosn 176 #endif 169 177 IF(lwp) THEN 170 178 WRITE(numout,*) -
branches/2014/dev_r4621_NOC4_BDY_VERT_INTERP/NEMOGCM/NEMO/OPA_SRC/DYN/divcur.F90
r5038 r5620 17 17 !! 3.3 ! 2010-09 (D.Storkey and E.O'Dea) bug fixes for BDY module 18 18 !! - ! 2010-10 (R. Furner, G. Madec) runoff and cla added directly here 19 !! 3.6 ! 2014-11 (P. Mathiot) isf added directly here 19 20 !!---------------------------------------------------------------------- 20 21 … … 97 98 ! 98 99 CALL wrk_alloc( jpi , jpj+2, zwu ) 99 CALL wrk_alloc( jpi+4, jpj , zwv, k jstart = -1 )100 CALL wrk_alloc( jpi+4, jpj , zwv, kistart = -1 ) 100 101 ! 101 102 IF( kt == nit000 ) THEN … … 236 237 ! 237 238 CALL wrk_dealloc( jpi , jpj+2, zwu ) 238 CALL wrk_dealloc( jpi+4, jpj , zwv, k jstart = -1 )239 CALL wrk_dealloc( jpi+4, jpj , zwv, kistart = -1 ) 239 240 ! 240 241 IF( nn_timing == 1 ) CALL timing_stop('div_cur') -
branches/2014/dev_r4621_NOC4_BDY_VERT_INTERP/NEMOGCM/NEMO/OPA_SRC/DYN/dynadv.F90
r5038 r5620 5 5 !!============================================================================== 6 6 !! History : 1.0 ! 2006-11 (G. Madec) Original code 7 !! 3.3 ! 2010-10 (C. Ethe, G. Madec) reorganisation of initialisation phase 7 !! 3.3 ! 2010-10 (C. Ethe, G. Madec) reorganisation of initialisation phase 8 !! 3.6 ! 2015-05 (N. Ducousso, G. Madec) add Hollingsworth scheme as an option 8 9 !!---------------------------------------------------------------------- 9 10 … … 17 18 USE dynkeg ! kinetic energy gradient (dyn_keg routine) 18 19 USE dynzad ! vertical advection (dyn_zad routine) 20 ! 19 21 USE in_out_manager ! I/O manager 20 22 USE lib_mpp ! MPP library … … 25 27 26 28 PUBLIC dyn_adv ! routine called by step module 27 PUBLIC dyn_adv_init ! routine called by opa module29 PUBLIC dyn_adv_init ! routine called by opa module 28 30 31 ! !* namdyn_adv namelist * 29 32 LOGICAL, PUBLIC :: ln_dynadv_vec !: vector form flag 33 INTEGER, PUBLIC :: nn_dynkeg !: scheme of kinetic energy gradient: =0 C2 ; =1 Hollingsworth 30 34 LOGICAL, PUBLIC :: ln_dynadv_cen2 !: flux form - 2nd order centered scheme flag 31 35 LOGICAL, PUBLIC :: ln_dynadv_ubs !: flux form - 3rd order UBS scheme flag … … 38 42 # include "vectopt_loop_substitute.h90" 39 43 !!---------------------------------------------------------------------- 40 !! NEMO/OPA 3. 3 , NEMO Consortium (2010)44 !! NEMO/OPA 3.6 , NEMO Consortium (2015) 41 45 !! $Id$ 42 46 !! Software governed by the CeCILL licence (NEMOGCM/NEMO_CeCILL.txt) … … 63 67 SELECT CASE ( nadv ) ! compute advection trend and add it to general trend 64 68 CASE ( 0 ) 65 CALL dyn_keg ( kt ) ! vector form : horizontal gradient of kinetic energy66 CALL dyn_zad ( kt ) ! vector form : vertical advection69 CALL dyn_keg ( kt, nn_dynkeg ) ! vector form : horizontal gradient of kinetic energy 70 CALL dyn_zad ( kt ) ! vector form : vertical advection 67 71 CASE ( 1 ) 68 CALL dyn_keg ( kt ) ! vector form : horizontal gradient of kinetic energy69 CALL dyn_zad_zts ( kt ) ! vector form : vertical advection with sub-timestepping72 CALL dyn_keg ( kt, nn_dynkeg ) ! vector form : horizontal gradient of kinetic energy 73 CALL dyn_zad_zts ( kt ) ! vector form : vertical advection with sub-timestepping 70 74 CASE ( 2 ) 71 CALL dyn_adv_cen2( kt ) ! 2nd order centered scheme75 CALL dyn_adv_cen2( kt ) ! 2nd order centered scheme 72 76 CASE ( 3 ) 73 CALL dyn_adv_ubs ( kt ) ! 3rd order UBS scheme77 CALL dyn_adv_ubs ( kt ) ! 3rd order UBS scheme 74 78 ! 75 CASE (-1 ) ! esopa: test all possibility with control print76 CALL dyn_keg ( kt )79 CASE (-1 ) ! esopa: test all possibility with control print 80 CALL dyn_keg ( kt, nn_dynkeg ) 77 81 CALL dyn_zad ( kt ) 78 82 CALL dyn_adv_cen2( kt ) … … 92 96 !! momentum advection formulation & scheme and set nadv 93 97 !!---------------------------------------------------------------------- 94 INTEGER :: ioptio 95 INTEGER :: ios ! Local integer output status for namelist read 96 !! 97 NAMELIST/namdyn_adv/ ln_dynadv_vec, ln_dynadv_cen2 , ln_dynadv_ubs, ln_dynzad_zts 98 INTEGER :: ioptio, ios ! Local integer 99 ! 100 NAMELIST/namdyn_adv/ ln_dynadv_vec, nn_dynkeg, ln_dynadv_cen2 , ln_dynadv_ubs, ln_dynzad_zts 98 101 !!---------------------------------------------------------------------- 99 102 ! 100 103 REWIND( numnam_ref ) ! Namelist namdyn_adv in reference namelist : Momentum advection scheme 101 104 READ ( numnam_ref, namdyn_adv, IOSTAT = ios, ERR = 901) … … 112 115 WRITE(numout,*) '~~~~~~~~~~~' 113 116 WRITE(numout,*) ' Namelist namdyn_adv : chose a advection formulation & scheme for momentum' 114 WRITE(numout,*) ' Vector/flux form (T/F) ln_dynadv_vec = ', ln_dynadv_vec 115 WRITE(numout,*) ' 2nd order centred advection scheme ln_dynadv_cen2 = ', ln_dynadv_cen2 116 WRITE(numout,*) ' 3rd order UBS advection scheme ln_dynadv_ubs = ', ln_dynadv_ubs 117 WRITE(numout,*) ' Sub timestepping of vertical advection ln_dynzad_zts = ', ln_dynzad_zts 117 WRITE(numout,*) ' Vector/flux form (T/F) ln_dynadv_vec = ', ln_dynadv_vec 118 WRITE(numout,*) ' = 0 standard scheme ; =1 Hollingsworth scheme nn_dynkeg = ', nn_dynkeg 119 WRITE(numout,*) ' 2nd order centred advection scheme ln_dynadv_cen2 = ', ln_dynadv_cen2 120 WRITE(numout,*) ' 3rd order UBS advection scheme ln_dynadv_ubs = ', ln_dynadv_ubs 121 WRITE(numout,*) ' Sub timestepping of vertical advection ln_dynzad_zts = ', ln_dynzad_zts 118 122 ENDIF 119 123 … … 126 130 IF( ioptio /= 1 ) CALL ctl_stop( 'Choose ONE advection scheme in namelist namdyn_adv' ) 127 131 IF( ln_dynzad_zts .AND. .NOT. ln_dynadv_vec ) & 128 CALL ctl_stop( 'Sub timestepping of vertical advection requires vector form; set ln_dynadv_vec = .TRUE.' ) 132 CALL ctl_stop( 'Sub timestepping of vertical advection requires vector form; set ln_dynadv_vec = .TRUE.' ) 133 IF( nn_dynkeg /= nkeg_C2 .AND. nn_dynkeg /= nkeg_HW ) & 134 CALL ctl_stop( 'KEG scheme wrong value of nn_dynkeg' ) 129 135 130 136 ! ! Set nadv … … 137 143 IF(lwp) THEN ! Print the choice 138 144 WRITE(numout,*) 139 IF( nadv == 0 ) WRITE(numout,*) ' vector form : keg + zad + vor is used' 145 IF( nadv == 0 ) WRITE(numout,*) ' vector form : keg + zad + vor is used' 140 146 IF( nadv == 1 ) WRITE(numout,*) ' vector form : keg + zad_zts + vor is used' 147 IF( nadv == 0 .OR. nadv == 1 ) THEN 148 IF( nn_dynkeg == nkeg_C2 ) WRITE(numout,*) 'with Centered standard keg scheme' 149 IF( nn_dynkeg == nkeg_HW ) WRITE(numout,*) 'with Hollingsworth keg scheme' 150 ENDIF 141 151 IF( nadv == 2 ) WRITE(numout,*) ' flux form : 2nd order scheme is used' 142 152 IF( nadv == 3 ) WRITE(numout,*) ' flux form : UBS scheme is used' -
branches/2014/dev_r4621_NOC4_BDY_VERT_INTERP/NEMOGCM/NEMO/OPA_SRC/DYN/dynadv_ubs.F90
r5038 r5620 116 116 DO jj = 2, jpjm1 ! laplacian 117 117 DO ji = fs_2, fs_jpim1 ! vector opt. 118 zlu_uu(ji,jj,jk,1) = ( ub (ji+1,jj,jk)-2.*ub (ji,jj,jk)+ub (ji-1,jj,jk) ) * umask(ji,jj,jk) 119 zlv_vv(ji,jj,jk,1) = ( vb (ji,jj+1,jk)-2.*vb (ji,jj,jk)+vb (ji,jj-1,jk) ) * vmask(ji,jj,jk) 120 zlu_uv(ji,jj,jk,1) = ( ub (ji,jj+1,jk)-2.*ub (ji,jj,jk)+ub (ji,jj-1,jk) ) * umask(ji,jj,jk) 121 zlv_vu(ji,jj,jk,1) = ( vb (ji+1,jj,jk)-2.*vb (ji,jj,jk)+vb (ji-1,jj,jk) ) * vmask(ji,jj,jk) 122 ! 123 zlu_uu(ji,jj,jk,2) = ( zfu(ji+1,jj,jk)-2.*zfu(ji,jj,jk)+zfu(ji-1,jj,jk) ) * umask(ji,jj,jk) 124 zlv_vv(ji,jj,jk,2) = ( zfv(ji,jj+1,jk)-2.*zfv(ji,jj,jk)+zfv(ji,jj-1,jk) ) * vmask(ji,jj,jk) 125 zlu_uv(ji,jj,jk,2) = ( zfu(ji,jj+1,jk)-2.*zfu(ji,jj,jk)+zfu(ji,jj-1,jk) ) * umask(ji,jj,jk) 126 zlv_vu(ji,jj,jk,2) = ( zfv(ji+1,jj,jk)-2.*zfv(ji,jj,jk)+zfv(ji-1,jj,jk) ) * vmask(ji,jj,jk) 127 END DO 128 END DO 129 END DO 130 !!gm BUG !!! just below this should be +1 in all the communications 131 ! CALL lbc_lnk( zlu_uu(:,:,:,1), 'U', -1.) ; CALL lbc_lnk( zlu_uv(:,:,:,1), 'U', -1.) 132 ! CALL lbc_lnk( zlu_uu(:,:,:,2), 'U', -1.) ; CALL lbc_lnk( zlu_uv(:,:,:,2), 'U', -1.) 133 ! CALL lbc_lnk( zlv_vv(:,:,:,1), 'V', -1.) ; CALL lbc_lnk( zlv_vu(:,:,:,1), 'V', -1.) 134 ! CALL lbc_lnk( zlv_vv(:,:,:,2), 'V', -1.) ; CALL lbc_lnk( zlv_vu(:,:,:,2), 'V', -1.) 135 ! 136 !!gm corrected: 118 ! 119 zlu_uu(ji,jj,jk,1) = ( ub (ji+1,jj ,jk) - 2.*ub (ji,jj,jk) + ub (ji-1,jj ,jk) ) * umask(ji,jj,jk) 120 zlv_vv(ji,jj,jk,1) = ( vb (ji ,jj+1,jk) - 2.*vb (ji,jj,jk) + vb (ji ,jj-1,jk) ) * vmask(ji,jj,jk) 121 zlu_uv(ji,jj,jk,1) = ( ub (ji ,jj+1,jk) - ub (ji ,jj ,jk) ) * fmask(ji ,jj ,jk) & 122 & - ( ub (ji ,jj ,jk) - ub (ji ,jj-1,jk) ) * fmask(ji ,jj-1,jk) 123 zlv_vu(ji,jj,jk,1) = ( vb (ji+1,jj ,jk) - vb (ji ,jj ,jk) ) * fmask(ji ,jj ,jk) & 124 & - ( vb (ji ,jj ,jk) - vb (ji-1,jj ,jk) ) * fmask(ji-1,jj ,jk) 125 ! 126 zlu_uu(ji,jj,jk,2) = ( zfu(ji+1,jj ,jk) - 2.*zfu(ji,jj,jk) + zfu(ji-1,jj ,jk) ) * umask(ji,jj,jk) 127 zlv_vv(ji,jj,jk,2) = ( zfv(ji ,jj+1,jk) - 2.*zfv(ji,jj,jk) + zfv(ji ,jj-1,jk) ) * vmask(ji,jj,jk) 128 zlu_uv(ji,jj,jk,2) = ( zfu(ji ,jj+1,jk) - zfu(ji ,jj ,jk) ) * fmask(ji ,jj ,jk) & 129 & - ( zfu(ji ,jj ,jk) - zfu(ji ,jj-1,jk) ) * fmask(ji ,jj-1,jk) 130 zlv_vu(ji,jj,jk,2) = ( zfv(ji+1,jj ,jk) - zfv(ji ,jj ,jk) ) * fmask(ji ,jj ,jk) & 131 & - ( zfv(ji ,jj ,jk) - zfv(ji-1,jj ,jk) ) * fmask(ji-1,jj ,jk) 132 END DO 133 END DO 134 END DO 137 135 CALL lbc_lnk( zlu_uu(:,:,:,1), 'U', 1. ) ; CALL lbc_lnk( zlu_uv(:,:,:,1), 'U', 1. ) 138 136 CALL lbc_lnk( zlu_uu(:,:,:,2), 'U', 1. ) ; CALL lbc_lnk( zlu_uv(:,:,:,2), 'U', 1. ) 139 137 CALL lbc_lnk( zlv_vv(:,:,:,1), 'V', 1. ) ; CALL lbc_lnk( zlv_vu(:,:,:,1), 'V', 1. ) 140 138 CALL lbc_lnk( zlv_vv(:,:,:,2), 'V', 1. ) ; CALL lbc_lnk( zlv_vu(:,:,:,2), 'V', 1. ) 141 !!gm end142 139 143 140 ! ! ====================== ! -
branches/2014/dev_r4621_NOC4_BDY_VERT_INTERP/NEMOGCM/NEMO/OPA_SRC/DYN/dynbfr.F90
r5038 r5620 80 80 ua(ji,jj,ikbu) = ua(ji,jj,ikbu) + MAX( bfrua(ji,jj) / fse3u(ji,jj,ikbu) , zm1_2dt ) * ub(ji,jj,ikbu) 81 81 va(ji,jj,ikbv) = va(ji,jj,ikbv) + MAX( bfrva(ji,jj) / fse3v(ji,jj,ikbv) , zm1_2dt ) * vb(ji,jj,ikbv) 82 83 ! (ISF) stability criteria for top friction84 ikbu = miku(ji,jj) ! first wet ocean u- & v-levels85 ikbv = mikv(ji,jj)86 !87 ! Apply stability criteria on absolute value : abs(bfr/e3) < 1/(2dt) => bfr/e3 > -1/(2dt)88 ua(ji,jj,ikbu) = ua(ji,jj,ikbu) + MAX( tfrua(ji,jj) / fse3u(ji,jj,ikbu) , zm1_2dt ) * ub(ji,jj,ikbu) &89 & * (1.-umask(ji,jj,1))90 va(ji,jj,ikbv) = va(ji,jj,ikbv) + MAX( tfrva(ji,jj) / fse3v(ji,jj,ikbv) , zm1_2dt ) * vb(ji,jj,ikbv) &91 & * (1.-vmask(ji,jj,1))92 ! (ISF)93 94 82 END DO 95 83 END DO 84 85 IF ( ln_isfcav ) THEN 86 DO jj = 2, jpjm1 87 DO ji = 2, jpim1 88 ! (ISF) stability criteria for top friction 89 ikbu = miku(ji,jj) ! first wet ocean u- & v-levels 90 ikbv = mikv(ji,jj) 91 ! 92 ! Apply stability criteria on absolute value : abs(bfr/e3) < 1/(2dt) => bfr/e3 > -1/(2dt) 93 ua(ji,jj,ikbu) = ua(ji,jj,ikbu) + MAX( tfrua(ji,jj) / fse3u(ji,jj,ikbu) , zm1_2dt ) * ub(ji,jj,ikbu) & 94 & * (1.-umask(ji,jj,1)) 95 va(ji,jj,ikbv) = va(ji,jj,ikbv) + MAX( tfrva(ji,jj) / fse3v(ji,jj,ikbv) , zm1_2dt ) * vb(ji,jj,ikbv) & 96 & * (1.-vmask(ji,jj,1)) 97 ! (ISF) 98 END DO 99 END DO 100 END IF 96 101 97 102 ! -
branches/2014/dev_r4621_NOC4_BDY_VERT_INTERP/NEMOGCM/NEMO/OPA_SRC/DYN/dynhpg.F90
r5038 r5620 16 16 !! 3.4 ! 2011-11 (H. Liu) hpg_prj: Original code for s-coordinates 17 17 !! ! (A. Coward) suppression of hel, wdj and rot options 18 !! 3.6 ! 2014-11 (P. Mathiot) hpg_isf: original code for ice shelf cavity 18 19 !!---------------------------------------------------------------------- 19 20 … … 25 26 !! hpg_zps : z-coordinate plus partial steps (interpolation) 26 27 !! hpg_sco : s-coordinate (standard jacobian formulation) 28 !! hpg_isf : s-coordinate (sco formulation) adapted to ice shelf 27 29 !! hpg_djc : s-coordinate (Density Jacobian with Cubic polynomial) 28 30 !! hpg_prj : s-coordinate (Pressure Jacobian with Cubic polynomial) … … 55 57 LOGICAL , PUBLIC :: ln_hpg_djc !: s-coordinate (Density Jacobian with Cubic polynomial) 56 58 LOGICAL , PUBLIC :: ln_hpg_prj !: s-coordinate (Pressure Jacobian scheme) 59 LOGICAL , PUBLIC :: ln_hpg_isf !: s-coordinate similar to sco modify for isf 57 60 LOGICAL , PUBLIC :: ln_dynhpg_imp !: semi-implicite hpg flag 58 61 … … 97 100 CASE ( 3 ) ; CALL hpg_djc ( kt ) ! s-coordinate (Density Jacobian with Cubic polynomial) 98 101 CASE ( 4 ) ; CALL hpg_prj ( kt ) ! s-coordinate (Pressure Jacobian scheme) 102 CASE ( 5 ) ; CALL hpg_isf ( kt ) ! s-coordinate similar to sco modify for ice shelf 99 103 END SELECT 100 104 ! … … 128 132 !! 129 133 NAMELIST/namdyn_hpg/ ln_hpg_zco, ln_hpg_zps, ln_hpg_sco, & 130 & ln_hpg_djc, ln_hpg_prj, ln_ dynhpg_imp134 & ln_hpg_djc, ln_hpg_prj, ln_hpg_isf, ln_dynhpg_imp 131 135 !!---------------------------------------------------------------------- 132 136 ! … … 148 152 WRITE(numout,*) ' z-coord. - partial steps (interpolation) ln_hpg_zps = ', ln_hpg_zps 149 153 WRITE(numout,*) ' s-coord. (standard jacobian formulation) ln_hpg_sco = ', ln_hpg_sco 154 WRITE(numout,*) ' s-coord. (standard jacobian formulation) for isf ln_hpg_isf = ', ln_hpg_isf 150 155 WRITE(numout,*) ' s-coord. (Density Jacobian: Cubic polynomial) ln_hpg_djc = ', ln_hpg_djc 151 156 WRITE(numout,*) ' s-coord. (Pressure Jacobian: Cubic polynomial) ln_hpg_prj = ', ln_hpg_prj … … 158 163 & either ln_hpg_sco or ln_hpg_prj instead') 159 164 ! 160 IF( lk_vvl .AND. .NOT. (ln_hpg_sco.OR.ln_hpg_prj ) ) &165 IF( lk_vvl .AND. .NOT. (ln_hpg_sco.OR.ln_hpg_prj.OR.ln_hpg_isf) ) & 161 166 & CALL ctl_stop('dyn_hpg_init : variable volume key_vvl requires:& 162 167 & the standard jacobian formulation hpg_sco or & 163 168 & the pressure jacobian formulation hpg_prj') 169 170 IF( ln_hpg_isf .AND. .NOT. ln_isfcav ) & 171 & CALL ctl_stop( ' hpg_isf not available if ln_isfcav = false ' ) 172 IF( .NOT. ln_hpg_isf .AND. ln_isfcav ) & 173 & CALL ctl_stop( 'Only hpg_isf has been corrected to work with ice shelf cavity.' ) 164 174 ! 165 175 ! ! Set nhpg from ln_hpg_... flags … … 169 179 IF( ln_hpg_djc ) nhpg = 3 170 180 IF( ln_hpg_prj ) nhpg = 4 181 IF( ln_hpg_isf ) nhpg = 5 171 182 ! 172 183 ! ! Consistency check … … 177 188 IF( ln_hpg_djc ) ioptio = ioptio + 1 178 189 IF( ln_hpg_prj ) ioptio = ioptio + 1 190 IF( ln_hpg_isf ) ioptio = ioptio + 1 179 191 IF( ioptio /= 1 ) CALL ctl_stop( 'NO or several hydrostatic pressure gradient options used' ) 180 IF( (ln_hpg_zco .OR. ln_hpg_zps .OR. ln_hpg_djc .OR. ln_hpg_prj ) .AND. nn_isf .NE. 0 ) & 181 & CALL ctl_stop( 'Only hpg_sco has been corrected to work with ice shelf cavity.' ) 192 ! 193 ! initialisation of ice load 194 riceload(:,:)=0.0 182 195 ! 183 196 END SUBROUTINE dyn_hpg_init … … 345 358 END SUBROUTINE hpg_zps 346 359 347 348 360 SUBROUTINE hpg_sco( kt ) 349 361 !!--------------------------------------------------------------------- … … 366 378 INTEGER, INTENT(in) :: kt ! ocean time-step index 367 379 !! 380 INTEGER :: ji, jj, jk ! dummy loop indices 381 REAL(wp) :: zcoef0, zuap, zvap, znad ! temporary scalars 382 REAL(wp), POINTER, DIMENSION(:,:,:) :: zhpi, zhpj 383 !!---------------------------------------------------------------------- 384 ! 385 CALL wrk_alloc( jpi,jpj,jpk, zhpi, zhpj ) 386 ! 387 IF( kt == nit000 ) THEN 388 IF(lwp) WRITE(numout,*) 389 IF(lwp) WRITE(numout,*) 'dyn:hpg_sco : hydrostatic pressure gradient trend' 390 IF(lwp) WRITE(numout,*) '~~~~~~~~~~~ s-coordinate case, OPA original scheme used' 391 ENDIF 392 393 ! Local constant initialization 394 zcoef0 = - grav * 0.5_wp 395 ! To use density and not density anomaly 396 IF ( lk_vvl ) THEN ; znad = 1._wp ! Variable volume 397 ELSE ; znad = 0._wp ! Fixed volume 398 ENDIF 399 400 ! Surface value 401 DO jj = 2, jpjm1 402 DO ji = fs_2, fs_jpim1 ! vector opt. 403 ! hydrostatic pressure gradient along s-surfaces 404 zhpi(ji,jj,1) = zcoef0 / e1u(ji,jj) * ( fse3w(ji+1,jj ,1) * ( znad + rhd(ji+1,jj ,1) ) & 405 & - fse3w(ji ,jj ,1) * ( znad + rhd(ji ,jj ,1) ) ) 406 zhpj(ji,jj,1) = zcoef0 / e2v(ji,jj) * ( fse3w(ji ,jj+1,1) * ( znad + rhd(ji ,jj+1,1) ) & 407 & - fse3w(ji ,jj ,1) * ( znad + rhd(ji ,jj ,1) ) ) 408 ! s-coordinate pressure gradient correction 409 zuap = -zcoef0 * ( rhd (ji+1,jj,1) + rhd (ji,jj,1) + 2._wp * znad ) & 410 & * ( fsde3w(ji+1,jj,1) - fsde3w(ji,jj,1) ) / e1u(ji,jj) 411 zvap = -zcoef0 * ( rhd (ji,jj+1,1) + rhd (ji,jj,1) + 2._wp * znad ) & 412 & * ( fsde3w(ji,jj+1,1) - fsde3w(ji,jj,1) ) / e2v(ji,jj) 413 ! add to the general momentum trend 414 ua(ji,jj,1) = ua(ji,jj,1) + zhpi(ji,jj,1) + zuap 415 va(ji,jj,1) = va(ji,jj,1) + zhpj(ji,jj,1) + zvap 416 END DO 417 END DO 418 419 ! interior value (2=<jk=<jpkm1) 420 DO jk = 2, jpkm1 421 DO jj = 2, jpjm1 422 DO ji = fs_2, fs_jpim1 ! vector opt. 423 ! hydrostatic pressure gradient along s-surfaces 424 zhpi(ji,jj,jk) = zhpi(ji,jj,jk-1) + zcoef0 / e1u(ji,jj) & 425 & * ( fse3w(ji+1,jj,jk) * ( rhd(ji+1,jj,jk) + rhd(ji+1,jj,jk-1) + 2*znad ) & 426 & - fse3w(ji ,jj,jk) * ( rhd(ji ,jj,jk) + rhd(ji ,jj,jk-1) + 2*znad ) ) 427 zhpj(ji,jj,jk) = zhpj(ji,jj,jk-1) + zcoef0 / e2v(ji,jj) & 428 & * ( fse3w(ji,jj+1,jk) * ( rhd(ji,jj+1,jk) + rhd(ji,jj+1,jk-1) + 2*znad ) & 429 & - fse3w(ji,jj ,jk) * ( rhd(ji,jj, jk) + rhd(ji,jj ,jk-1) + 2*znad ) ) 430 ! s-coordinate pressure gradient correction 431 zuap = -zcoef0 * ( rhd (ji+1,jj ,jk) + rhd (ji,jj,jk) + 2._wp * znad ) & 432 & * ( fsde3w(ji+1,jj ,jk) - fsde3w(ji,jj,jk) ) / e1u(ji,jj) 433 zvap = -zcoef0 * ( rhd (ji ,jj+1,jk) + rhd (ji,jj,jk) + 2._wp * znad ) & 434 & * ( fsde3w(ji ,jj+1,jk) - fsde3w(ji,jj,jk) ) / e2v(ji,jj) 435 ! add to the general momentum trend 436 ua(ji,jj,jk) = ua(ji,jj,jk) + zhpi(ji,jj,jk) + zuap 437 va(ji,jj,jk) = va(ji,jj,jk) + zhpj(ji,jj,jk) + zvap 438 END DO 439 END DO 440 END DO 441 ! 442 CALL wrk_dealloc( jpi,jpj,jpk, zhpi, zhpj ) 443 ! 444 END SUBROUTINE hpg_sco 445 446 SUBROUTINE hpg_isf( kt ) 447 !!--------------------------------------------------------------------- 448 !! *** ROUTINE hpg_sco *** 449 !! 450 !! ** Method : s-coordinate case. Jacobian scheme. 451 !! The now hydrostatic pressure gradient at a given level, jk, 452 !! is computed by taking the vertical integral of the in-situ 453 !! density gradient along the model level from the suface to that 454 !! level. s-coordinates (ln_sco): a corrective term is added 455 !! to the horizontal pressure gradient : 456 !! zhpi = grav ..... + 1/e1u mi(rhd) di[ grav dep3w ] 457 !! zhpj = grav ..... + 1/e2v mj(rhd) dj[ grav dep3w ] 458 !! add it to the general momentum trend (ua,va). 459 !! ua = ua - 1/e1u * zhpi 460 !! va = va - 1/e2v * zhpj 461 !! iceload is added and partial cell case are added to the top and bottom 462 !! 463 !! ** Action : - Update (ua,va) with the now hydrastatic pressure trend 464 !!---------------------------------------------------------------------- 465 INTEGER, INTENT(in) :: kt ! ocean time-step index 466 !! 368 467 INTEGER :: ji, jj, jk, iku, ikv, ikt, iktp1i, iktp1j ! dummy loop indices 369 468 REAL(wp) :: zcoef0, zuap, zvap, znad, ze3wu, ze3wv, zuapint, zvapint, zhpjint, zhpiint, zdzwt, zdzwtjp1, zdzwtip1 ! temporary scalars … … 379 478 IF( kt == nit000 ) THEN 380 479 IF(lwp) WRITE(numout,*) 381 IF(lwp) WRITE(numout,*) 'dyn:hpg_ sco : hydrostatic pressure gradient trend'480 IF(lwp) WRITE(numout,*) 'dyn:hpg_isf : hydrostatic pressure gradient trend for ice shelf' 382 481 IF(lwp) WRITE(numout,*) '~~~~~~~~~~~ s-coordinate case, OPA original scheme used' 383 482 ENDIF … … 565 664 !================================================================================== 566 665 567 # if defined key_vectopt_loop568 jj = 1569 DO ji = jpi+2, jpij-jpi-1 ! vector opt. (forced unrolling)570 # else571 666 DO jj = 2, jpjm1 572 667 DO ji = 2, jpim1 573 # endif574 668 iku = mbku(ji,jj) 575 669 ikv = mbkv(ji,jj) … … 598 692 va(ji,jj,ikv) = va(ji,jj,ikv) + zhpj(ji,jj,ikv) + zvap 599 693 END IF 600 # if ! defined key_vectopt_loop 601 END DO 602 # endif 694 END DO 603 695 END DO 604 696 … … 610 702 CALL wrk_dealloc( jpi,jpj, ze3w, zp, zrhdtop_isf, zrhdtop_oce, ziceload, zdept, zpshpi, zpshpj) 611 703 ! 612 END SUBROUTINE hpg_ sco704 END SUBROUTINE hpg_isf 613 705 614 706 … … 864 956 REAL(wp), POINTER, DIMENSION(:,:,:) :: zdept, zrhh 865 957 REAL(wp), POINTER, DIMENSION(:,:,:) :: zhpi, zu, zv, fsp, xsp, asp, bsp, csp, dsp 958 REAL(wp), POINTER, DIMENSION(:,:) :: zsshu_n, zsshv_n 866 959 !!---------------------------------------------------------------------- 867 960 ! 868 961 CALL wrk_alloc( jpi,jpj,jpk, zhpi, zu, zv, fsp, xsp, asp, bsp, csp, dsp ) 869 962 CALL wrk_alloc( jpi,jpj,jpk, zdept, zrhh ) 963 CALL wrk_alloc( jpi,jpj, zsshu_n, zsshv_n ) 870 964 ! 871 965 IF( kt == nit000 ) THEN … … 948 1042 949 1043 ! Z coordinate of U(ji,jj,1:jpkm1) and V(ji,jj,1:jpkm1) 1044 1045 ! Prepare zsshu_n and zsshv_n 950 1046 DO jj = 2, jpjm1 951 1047 DO ji = 2, jpim1 952 zu(ji,jj,1) = - ( fse3u(ji,jj,1) - sshn(ji,jj) * znad) ! probable bug: changed from sshu_n for ztilde compilation 953 zv(ji,jj,1) = - ( fse3v(ji,jj,1) - sshn(ji,jj) * znad) ! probable bug: changed from sshv_n for ztilde compilation 1048 zsshu_n(ji,jj) = (e12u(ji,jj) * sshn(ji,jj) + e12u(ji+1, jj) * sshn(ji+1,jj)) * & 1049 & r1_e12u(ji,jj) * umask(ji,jj,1) * 0.5_wp 1050 zsshv_n(ji,jj) = (e12v(ji,jj) * sshn(ji,jj) + e12v(ji+1, jj) * sshn(ji,jj+1)) * & 1051 & r1_e12v(ji,jj) * vmask(ji,jj,1) * 0.5_wp 1052 END DO 1053 END DO 1054 1055 DO jj = 2, jpjm1 1056 DO ji = 2, jpim1 1057 zu(ji,jj,1) = - ( fse3u(ji,jj,1) - zsshu_n(ji,jj) * znad) 1058 zv(ji,jj,1) = - ( fse3v(ji,jj,1) - zsshv_n(ji,jj) * znad) 954 1059 END DO 955 1060 END DO … … 1113 1218 CALL wrk_dealloc( jpi,jpj,jpk, zhpi, zu, zv, fsp, xsp, asp, bsp, csp, dsp ) 1114 1219 CALL wrk_dealloc( jpi,jpj,jpk, zdept, zrhh ) 1220 CALL wrk_dealloc( jpi,jpj, zsshu_n, zsshv_n ) 1115 1221 ! 1116 1222 END SUBROUTINE hpg_prj -
branches/2014/dev_r4621_NOC4_BDY_VERT_INTERP/NEMOGCM/NEMO/OPA_SRC/DYN/dynkeg.F90
r5038 r5620 4 4 !! Ocean dynamics: kinetic energy gradient trend 5 5 !!====================================================================== 6 !! History : 1.0 ! 87-09 (P. Andrich, m.-a. Foujols) Original code 7 !! 7.0 ! 97-05 (G. Madec) Split dynber into dynkeg and dynhpg 8 !! 9.0 ! 02-07 (G. Madec) F90: Free form and module 6 !! History : 1.0 ! 1987-09 (P. Andrich, M.-A. Foujols) Original code 7 !! 7.0 ! 1997-05 (G. Madec) Split dynber into dynkeg and dynhpg 8 !! NEMO 1.0 ! 2002-07 (G. Madec) F90: Free form and module 9 !! 3.6 ! 2015-05 (N. Ducousso, G. Madec) add Hollingsworth scheme as an option 9 10 !!---------------------------------------------------------------------- 10 11 … … 18 19 ! 19 20 USE in_out_manager ! I/O manager 21 USE lbclnk ! ocean lateral boundary conditions (or mpp link) 20 22 USE lib_mpp ! MPP library 21 23 USE prtctl ! Print control … … 28 30 PUBLIC dyn_keg ! routine called by step module 29 31 32 INTEGER, PARAMETER, PUBLIC :: nkeg_C2 = 0 !: 2nd order centered scheme (standard scheme) 33 INTEGER, PARAMETER, PUBLIC :: nkeg_HW = 1 !: Hollingsworth et al., QJRMS, 1983 34 ! 35 REAL(wp) :: r1_48 = 1._wp / 48._wp !: =1/(4*2*6) 36 30 37 !! * Substitutions 31 38 # include "vectopt_loop_substitute.h90" 32 39 !!---------------------------------------------------------------------- 33 !! NEMO/OPA 3. 3 , NEMO Consortium (2010)40 !! NEMO/OPA 3.6 , NEMO Consortium (2015) 34 41 !! $Id$ 35 42 !! Software governed by the CeCILL licence (NEMOGCM/NEMO_CeCILL.txt) … … 37 44 CONTAINS 38 45 39 SUBROUTINE dyn_keg( kt )46 SUBROUTINE dyn_keg( kt, kscheme ) 40 47 !!---------------------------------------------------------------------- 41 48 !! *** ROUTINE dyn_keg *** … … 45 52 !! general momentum trend. 46 53 !! 47 !! ** Method : Compute the now horizontal kinetic energy 54 !! ** Method : * kscheme = nkeg_C2 : 2nd order centered scheme that 55 !! conserve kinetic energy. Compute the now horizontal kinetic energy 48 56 !! zhke = 1/2 [ mi-1( un^2 ) + mj-1( vn^2 ) ] 57 !! * kscheme = nkeg_HW : Hollingsworth correction following 58 !! Arakawa (2001). The now horizontal kinetic energy is given by: 59 !! zhke = 1/6 [ mi-1( 2 * un^2 + ((un(j+1)+un(j-1))/2)^2 ) 60 !! + mj-1( 2 * vn^2 + ((vn(i+1)+vn(i-1))/2)^2 ) ] 61 !! 49 62 !! Take its horizontal gradient and add it to the general momentum 50 63 !! trend (ua,va). … … 54 67 !! ** Action : - Update the (ua, va) with the hor. ke gradient trend 55 68 !! - send this trends to trd_dyn (l_trddyn=T) for post-processing 69 !! 70 !! ** References : Arakawa, A., International Geophysics 2001. 71 !! Hollingsworth et al., Quart. J. Roy. Meteor. Soc., 1983. 56 72 !!---------------------------------------------------------------------- 57 INTEGER, INTENT( in ) :: kt ! ocean time-step index 73 INTEGER, INTENT( in ) :: kt ! ocean time-step index 74 INTEGER, INTENT( in ) :: kscheme ! =0/1 type of KEG scheme 58 75 ! 59 76 INTEGER :: ji, jj, jk ! dummy loop indices … … 63 80 !!---------------------------------------------------------------------- 64 81 ! 65 IF( nn_timing == 1 ) CALL timing_start('dyn_keg')82 IF( nn_timing == 1 ) CALL timing_start('dyn_keg') 66 83 ! 67 CALL wrk_alloc( jpi, jpj, jpk,zhke )84 CALL wrk_alloc( jpi,jpj,jpk, zhke ) 68 85 ! 69 86 IF( kt == nit000 ) THEN 70 87 IF(lwp) WRITE(numout,*) 71 IF(lwp) WRITE(numout,*) 'dyn_keg : kinetic energy gradient trend '88 IF(lwp) WRITE(numout,*) 'dyn_keg : kinetic energy gradient trend, scheme number=', kscheme 72 89 IF(lwp) WRITE(numout,*) '~~~~~~~' 73 90 ENDIF 74 91 75 92 IF( l_trddyn ) THEN ! Save ua and va trends 76 CALL wrk_alloc( jpi,jpj,jpk, ztrdu, ztrdv )93 CALL wrk_alloc( jpi,jpj,jpk, ztrdu, ztrdv ) 77 94 ztrdu(:,:,:) = ua(:,:,:) 78 95 ztrdv(:,:,:) = va(:,:,:) 79 96 ENDIF 80 97 81 ! ! =============== 82 DO jk = 1, jpkm1 ! Horizontal slab 83 ! ! =============== 84 DO jj = 2, jpj ! Horizontal kinetic energy at T-point 85 DO ji = fs_2, jpi ! vector opt. 86 zu = 0.25 * ( un(ji-1,jj ,jk) * un(ji-1,jj ,jk) & 87 & + un(ji ,jj ,jk) * un(ji ,jj ,jk) ) 88 zv = 0.25 * ( vn(ji ,jj-1,jk) * vn(ji ,jj-1,jk) & 89 & + vn(ji ,jj ,jk) * vn(ji ,jj ,jk) ) 90 zhke(ji,jj,jk) = zv + zu 91 !!gm simplier coding ==>> ~ faster 92 ! don't forget to suppress local zu zv scalars 93 ! zhke(ji,jj,jk) = 0.25 * ( un(ji-1,jj ,jk) * un(ji-1,jj ,jk) & 94 ! & + un(ji ,jj ,jk) * un(ji ,jj ,jk) & 95 ! & + vn(ji ,jj-1,jk) * vn(ji ,jj-1,jk) & 96 ! & + vn(ji ,jj ,jk) * vn(ji ,jj ,jk) ) 97 !!gm end <<== 98 END DO 99 END DO 100 DO jj = 2, jpjm1 ! add the gradient of kinetic energy to the general momentum trends 98 zhke(:,:,jpk) = 0._wp 99 100 SELECT CASE ( kscheme ) !== Horizontal kinetic energy at T-point ==! 101 ! 102 CASE ( nkeg_C2 ) !-- Standard scheme --! 103 DO jk = 1, jpkm1 104 DO jj = 2, jpj 105 DO ji = fs_2, jpi ! vector opt. 106 zu = un(ji-1,jj ,jk) * un(ji-1,jj ,jk) & 107 & + un(ji ,jj ,jk) * un(ji ,jj ,jk) 108 zv = vn(ji ,jj-1,jk) * vn(ji ,jj-1,jk) & 109 & + vn(ji ,jj ,jk) * vn(ji ,jj ,jk) 110 zhke(ji,jj,jk) = 0.25_wp * ( zv + zu ) 111 END DO 112 END DO 113 END DO 114 ! 115 CASE ( nkeg_HW ) !-- Hollingsworth scheme --! 116 DO jk = 1, jpkm1 117 DO jj = 2, jpjm1 118 DO ji = fs_2, jpim1 ! vector opt. 119 zu = 8._wp * ( un(ji-1,jj ,jk) * un(ji-1,jj ,jk) & 120 & + un(ji ,jj ,jk) * un(ji ,jj ,jk) ) & 121 & + ( un(ji-1,jj-1,jk) + un(ji-1,jj+1,jk) ) * ( un(ji-1,jj-1,jk) + un(ji-1,jj+1,jk) ) & 122 & + ( un(ji ,jj-1,jk) + un(ji ,jj+1,jk) ) * ( un(ji ,jj-1,jk) + un(ji ,jj+1,jk) ) 123 ! 124 zv = 8._wp * ( vn(ji ,jj-1,jk) * vn(ji ,jj-1,jk) & 125 & + vn(ji ,jj ,jk) * vn(ji ,jj ,jk) ) & 126 & + ( vn(ji-1,jj-1,jk) + vn(ji+1,jj-1,jk) ) * ( vn(ji-1,jj-1,jk) + vn(ji+1,jj-1,jk) ) & 127 & + ( vn(ji-1,jj ,jk) + vn(ji+1,jj ,jk) ) * ( vn(ji-1,jj ,jk) + vn(ji+1,jj ,jk) ) 128 zhke(ji,jj,jk) = r1_48 * ( zv + zu ) 129 END DO 130 END DO 131 END DO 132 CALL lbc_lnk( zhke, 'T', 1. ) 133 ! 134 END SELECT 135 ! 136 DO jk = 1, jpkm1 !== grad( KE ) added to the general momentum trends ==! 137 DO jj = 2, jpjm1 101 138 DO ji = fs_2, fs_jpim1 ! vector opt. 102 139 ua(ji,jj,jk) = ua(ji,jj,jk) - ( zhke(ji+1,jj ,jk) - zhke(ji,jj,jk) ) / e1u(ji,jj) … … 104 141 END DO 105 142 END DO 106 !!gm idea to be tested ==>> is it faster on scalar computers ? 107 ! DO jj = 2, jpjm1 ! add the gradient of kinetic energy to the general momentum trends 108 ! DO ji = fs_2, fs_jpim1 ! vector opt. 109 ! ua(ji,jj,jk) = ua(ji,jj,jk) - 0.25 * ( + un(ji+1,jj ,jk) * un(ji+1,jj ,jk) & 110 ! & + vn(ji+1,jj-1,jk) * vn(ji+1,jj-1,jk) & 111 ! & + vn(ji+1,jj ,jk) * vn(ji+1,jj ,jk) & 112 ! ! 113 ! & - un(ji-1,jj ,jk) * un(ji-1,jj ,jk) & 114 ! & - vn(ji ,jj-1,jk) * vn(ji ,jj-1,jk) & 115 ! & - vn(ji ,jj ,jk) * vn(ji ,jj ,jk) ) / e1u(ji,jj) 116 ! ! 117 ! va(ji,jj,jk) = va(ji,jj,jk) - 0.25 * ( un(ji-1,jj+1,jk) * un(ji-1,jj+1,jk) & 118 ! & + un(ji ,jj+1,jk) * un(ji ,jj+1,jk) & 119 ! & + vn(ji ,jj+1,jk) * vn(ji ,jj+1,jk) & 120 ! ! 121 ! & - un(ji-1,jj ,jk) * un(ji-1,jj ,jk) & 122 ! & - un(ji ,jj ,jk) * un(ji ,jj ,jk) & 123 ! & - vn(ji ,jj ,jk) * vn(ji ,jj ,jk) ) / e2v(ji,jj) 124 ! END DO 125 ! END DO 126 !!gm en idea <<== 127 ! ! =============== 128 END DO ! End of slab 129 ! ! =============== 130 131 IF( l_trddyn ) THEN ! save the Kinetic Energy trends for diagnostic 143 END DO 144 ! 145 IF( l_trddyn ) THEN ! save the Kinetic Energy trends for diagnostic 132 146 ztrdu(:,:,:) = ua(:,:,:) - ztrdu(:,:,:) 133 147 ztrdv(:,:,:) = va(:,:,:) - ztrdv(:,:,:) 134 148 CALL trd_dyn( ztrdu, ztrdv, jpdyn_keg, kt ) 135 CALL wrk_dealloc( jpi,jpj,jpk, ztrdu, ztrdv )149 CALL wrk_dealloc( jpi,jpj,jpk, ztrdu, ztrdv ) 136 150 ENDIF 137 151 ! … … 139 153 & tab3d_2=va, clinfo2= ' Va: ', mask2=vmask, clinfo3='dyn' ) 140 154 ! 141 CALL wrk_dealloc( jpi, jpj, jpk,zhke )155 CALL wrk_dealloc( jpi,jpj,jpk, zhke ) 142 156 ! 143 IF( nn_timing == 1 ) CALL timing_stop('dyn_keg')157 IF( nn_timing == 1 ) CALL timing_stop('dyn_keg') 144 158 ! 145 159 END SUBROUTINE dyn_keg -
branches/2014/dev_r4621_NOC4_BDY_VERT_INTERP/NEMOGCM/NEMO/OPA_SRC/DYN/dynnept.F90
- Property svn:keywords set to Id
r4792 r5620 69 69 !!---------------------------------------------------------------------- 70 70 71 !! $Id$ 71 72 CONTAINS 72 73 -
branches/2014/dev_r4621_NOC4_BDY_VERT_INTERP/NEMOGCM/NEMO/OPA_SRC/DYN/dynnxt.F90
r5038 r5620 266 266 ! Add volume filter correction: compatibility with tracer advection scheme 267 267 ! => time filter + conservation correction (only at the first level) 268 fse3t_b(:,:,1) = fse3t_b(:,:,1) - atfp * rdt * r1_rau0 * ( emp_b(:,:) - emp(:,:) ) * tmask(:,:,1)269 !268 fse3t_b(:,:,1) = fse3t_b(:,:,1) - atfp * rdt * r1_rau0 * ( emp_b(:,:) - emp(:,:) & 269 & -rnf_b(:,:) + rnf(:,:) ) * tmask(:,:,1) 270 270 ENDIF 271 271 ! -
branches/2014/dev_r4621_NOC4_BDY_VERT_INTERP/NEMOGCM/NEMO/OPA_SRC/DYN/dynspg.F90
r5038 r5620 250 250 IF( ( ioptio > 1 .AND. .NOT. lk_esopa ) .OR. ( ioptio == 0 .AND. .NOT. lk_c1d ) ) & 251 251 & CALL ctl_stop( ' Choose only one surface pressure gradient scheme with a key cpp' ) 252 IF( ( lk_dynspg_ts .OR. lk_dynspg_exp ) .AND. nn_isf .NE. 0) &252 IF( ( lk_dynspg_ts .OR. lk_dynspg_exp ) .AND. ln_isfcav ) & 253 253 & CALL ctl_stop( ' dynspg_ts and dynspg_exp not tested with ice shelf cavity ' ) 254 254 ! -
branches/2014/dev_r4621_NOC4_BDY_VERT_INTERP/NEMOGCM/NEMO/OPA_SRC/DYN/dynspg_ts.F90
r5038 r5620 22 22 USE dom_oce ! ocean space and time domain 23 23 USE sbc_oce ! surface boundary condition: ocean 24 USE sbcisf ! ice shelf variable (fwfisf) 24 25 USE dynspg_oce ! surface pressure gradient variables 25 26 USE phycst ! physical constants … … 78 79 !!---------------------------------------------------------------------- 79 80 !! NEMO/OPA 3.5 , NEMO Consortium (2013) 80 !! $Id : dynspg_ts.F9081 !! $Id$ 81 82 !! Software governed by the CeCILL licence (NEMOGCM/NEMO_CeCILL.txt) 82 83 !!---------------------------------------------------------------------- … … 453 454 ! ! Surface net water flux and rivers 454 455 IF (ln_bt_fw) THEN 455 zssh_frc(:,:) = zraur * ( emp(:,:) - rnf(:,:) )456 zssh_frc(:,:) = zraur * ( emp(:,:) - rnf(:,:) + rdivisf * fwfisf(:,:) ) 456 457 ELSE 457 zssh_frc(:,:) = zraur * z1_2 * (emp(:,:) + emp_b(:,:) - rnf(:,:) - rnf_b(:,:)) 458 zssh_frc(:,:) = zraur * z1_2 * ( emp(:,:) + emp_b(:,:) - rnf(:,:) - rnf_b(:,:) & 459 & + rdivisf * ( fwfisf(:,:) + fwfisf_b(:,:) ) ) 458 460 ENDIF 459 461 #if defined key_asminc 460 462 ! ! Include the IAU weighted SSH increment 461 463 IF( lk_asminc .AND. ln_sshinc .AND. ln_asmiau ) THEN 462 zssh_frc(:,:) = zssh_frc(:,:) +ssh_iau(:,:)464 zssh_frc(:,:) = zssh_frc(:,:) - ssh_iau(:,:) 463 465 ENDIF 464 466 #endif … … 555 557 END DO 556 558 END DO 557 CALL lbc_lnk ( zwx, 'U', 1._wp ) ; CALL lbc_lnk(zwy, 'V', 1._wp )559 CALL lbc_lnk_multi( zwx, 'U', 1._wp, zwy, 'V', 1._wp ) 558 560 ! 559 561 zhup2_e (:,:) = hu_0(:,:) + zwx(:,:) ! Ocean depth at U- and V-points … … 633 635 END DO 634 636 END DO 635 CALL lbc_lnk ( zsshu_a, 'U', 1._wp ) ; CALL lbc_lnk(zsshv_a, 'V', 1._wp )637 CALL lbc_lnk_multi( zsshu_a, 'U', 1._wp, zsshv_a, 'V', 1._wp ) 636 638 ENDIF 637 639 ! … … 801 803 ! ! ----------------------- 802 804 ! 803 CALL lbc_lnk( ua_e , 'U', -1._wp ) ! local domain boundaries 804 CALL lbc_lnk( va_e , 'V', -1._wp ) 805 CALL lbc_lnk_multi( ua_e, 'U', -1._wp, va_e , 'V', -1._wp ) 805 806 806 807 #if defined key_bdy … … 857 858 END DO 858 859 END DO 859 CALL lbc_lnk ( zsshu_a, 'U', 1._wp ) ; CALL lbc_lnk(zsshv_a, 'V', 1._wp ) ! Boundary conditions860 CALL lbc_lnk_multi( zsshu_a, 'U', 1._wp, zsshv_a, 'V', 1._wp ) ! Boundary conditions 860 861 ENDIF 861 862 ! -
branches/2014/dev_r4621_NOC4_BDY_VERT_INTERP/NEMOGCM/NEMO/OPA_SRC/DYN/dynzad.F90
r5038 r5620 95 95 END DO 96 96 END DO 97 DO jj = 2, jpjm1 ! Surface and bottom values set to zero 98 DO ji = fs_2, fs_jpim1 ! vector opt. 99 zwuw(ji,jj, 1:miku(ji,jj) ) = 0._wp 100 zwvw(ji,jj, 1:mikv(ji,jj) ) = 0._wp 101 zwuw(ji,jj,jpk) = 0._wp 102 zwvw(ji,jj,jpk) = 0._wp 103 END DO 104 END DO 97 ! 98 ! Surface and bottom advective fluxes set to zero 99 IF ( ln_isfcav ) THEN 100 DO jj = 2, jpjm1 101 DO ji = fs_2, fs_jpim1 ! vector opt. 102 zwuw(ji,jj, 1:miku(ji,jj) ) = 0._wp 103 zwvw(ji,jj, 1:mikv(ji,jj) ) = 0._wp 104 zwuw(ji,jj,jpk) = 0._wp 105 zwvw(ji,jj,jpk) = 0._wp 106 END DO 107 END DO 108 ELSE 109 DO jj = 2, jpjm1 110 DO ji = fs_2, fs_jpim1 ! vector opt. 111 zwuw(ji,jj, 1 ) = 0._wp 112 zwvw(ji,jj, 1 ) = 0._wp 113 zwuw(ji,jj,jpk) = 0._wp 114 zwvw(ji,jj,jpk) = 0._wp 115 END DO 116 END DO 117 END IF 105 118 106 119 DO jk = 1, jpkm1 ! Vertical momentum advection at u- and v-points … … 196 209 END DO 197 210 END DO 198 199 DO jj = 2, jpjm1 ! Surface and bottom advective fluxes set to zero 211 ! 212 ! Surface and bottom advective fluxes set to zero 213 DO jj = 2, jpjm1 200 214 DO ji = fs_2, fs_jpim1 ! vector opt. 201 zwuw(ji,jj, 1 :miku(ji,jj)) = 0._wp202 zwvw(ji,jj, 1 :mikv(ji,jj)) = 0._wp215 zwuw(ji,jj, 1 ) = 0._wp 216 zwvw(ji,jj, 1 ) = 0._wp 203 217 zwuw(ji,jj,jpk) = 0._wp 204 218 zwvw(ji,jj,jpk) = 0._wp … … 228 242 DO jj = 2, jpjm1 ! vertical momentum advection at w-point 229 243 DO ji = fs_2, fs_jpim1 ! vector opt. 230 zwuw(ji,jj,jk) = ( zww(ji+1,jj ,jk) + zww(ji,jj,jk) ) * ( zus(ji,jj,jk-1,jtn)-zus(ji,jj,jk,jtn) ) 231 zwvw(ji,jj,jk) = ( zww(ji ,jj+1,jk) + zww(ji,jj,jk) ) * ( zvs(ji,jj,jk-1,jtn)-zvs(ji,jj,jk,jtn) ) 244 zwuw(ji,jj,jk) = ( zww(ji+1,jj ,jk) + zww(ji,jj,jk) ) * ( zus(ji,jj,jk-1,jtn)-zus(ji,jj,jk,jtn) ) !* wumask(ji,jj,jk) 245 zwvw(ji,jj,jk) = ( zww(ji ,jj+1,jk) + zww(ji,jj,jk) ) * ( zvs(ji,jj,jk-1,jtn)-zvs(ji,jj,jk,jtn) ) !* wvmask(ji,jj,jk) 232 246 END DO 233 247 END DO -
branches/2014/dev_r4621_NOC4_BDY_VERT_INTERP/NEMOGCM/NEMO/OPA_SRC/DYN/dynzdf_imp.F90
r5038 r5620 105 105 avmu(ji,jj,ikbu+1) = -bfrua(ji,jj) * fse3uw(ji,jj,ikbu+1) 106 106 avmv(ji,jj,ikbv+1) = -bfrva(ji,jj) * fse3vw(ji,jj,ikbv+1) 107 ikbu = miku(ji,jj) ! ocean top level at u- and v-points 108 ikbv = mikv(ji,jj) ! (first wet ocean u- and v-points) 109 IF (ikbu .GE. 2) avmu(ji,jj,ikbu) = -tfrua(ji,jj) * fse3uw(ji,jj,ikbu) 110 IF (ikbv .GE. 2) avmv(ji,jj,ikbv) = -tfrva(ji,jj) * fse3vw(ji,jj,ikbv) 111 END DO 112 END DO 107 END DO 108 END DO 109 IF ( ln_isfcav ) THEN 110 DO jj = 2, jpjm1 111 DO ji = 2, jpim1 112 ikbu = miku(ji,jj) ! ocean top level at u- and v-points 113 ikbv = mikv(ji,jj) ! (first wet ocean u- and v-points) 114 IF (ikbu .GE. 2) avmu(ji,jj,ikbu) = -tfrua(ji,jj) * fse3uw(ji,jj,ikbu) 115 IF (ikbv .GE. 2) avmv(ji,jj,ikbv) = -tfrva(ji,jj) * fse3vw(ji,jj,ikbv) 116 END DO 117 END DO 118 END IF 113 119 ENDIF 114 120 … … 145 151 ua(ji,jj,ikbu) = ua(ji,jj,ikbu) + p2dt * bfrua(ji,jj) * ua_b(ji,jj) / ze3ua 146 152 va(ji,jj,ikbv) = va(ji,jj,ikbv) + p2dt * bfrva(ji,jj) * va_b(ji,jj) / ze3va 147 ikbu = miku(ji,jj) ! top ocean level at u- and v-points 148 ikbv = mikv(ji,jj) ! (first wet ocean u- and v-points) 149 ze3ua = ( 1._wp - r_vvl ) * fse3u_n(ji,jj,ikbu) + r_vvl * fse3u_a(ji,jj,ikbu) 150 ze3va = ( 1._wp - r_vvl ) * fse3v_n(ji,jj,ikbv) + r_vvl * fse3v_a(ji,jj,ikbv) 151 ua(ji,jj,ikbu) = ua(ji,jj,ikbu) + p2dt * tfrua(ji,jj) * ua_b(ji,jj) / ze3ua 152 va(ji,jj,ikbv) = va(ji,jj,ikbv) + p2dt * tfrva(ji,jj) * va_b(ji,jj) / ze3va 153 END DO 154 END DO 153 END DO 154 END DO 155 IF ( ln_isfcav ) THEN 156 DO jj = 2, jpjm1 157 DO ji = fs_2, fs_jpim1 ! vector opt. 158 ikbu = miku(ji,jj) ! top ocean level at u- and v-points 159 ikbv = mikv(ji,jj) ! (first wet ocean u- and v-points) 160 ze3ua = ( 1._wp - r_vvl ) * fse3u_n(ji,jj,ikbu) + r_vvl * fse3u_a(ji,jj,ikbu) 161 ze3va = ( 1._wp - r_vvl ) * fse3v_n(ji,jj,ikbv) + r_vvl * fse3v_a(ji,jj,ikbv) 162 ua(ji,jj,ikbu) = ua(ji,jj,ikbu) + p2dt * tfrua(ji,jj) * ua_b(ji,jj) / ze3ua 163 va(ji,jj,ikbv) = va(ji,jj,ikbv) + p2dt * tfrva(ji,jj) * va_b(ji,jj) / ze3va 164 END DO 165 END DO 166 END IF 155 167 ENDIF 156 168 #endif … … 167 179 ze3ua = ( 1._wp - r_vvl ) * fse3u_n(ji,jj,jk) + r_vvl * fse3u_a(ji,jj,jk) ! after scale factor at T-point 168 180 zcoef = - p2dt / ze3ua 169 zzwi = zcoef * avmu (ji,jj,jk ) / fse3uw(ji,jj,jk )170 zwi(ji,jj,jk) = zzwi * umask(ji,jj,jk)171 zzws = zcoef * avmu (ji,jj,jk+1) / fse3uw(ji,jj,jk+1)172 zws(ji,jj,jk) = zzws * umask(ji,jj,jk+1)173 zwd(ji,jj,jk) = 1._wp - z wi(ji,jj,jk)- zzws181 zzwi = zcoef * avmu (ji,jj,jk ) / fse3uw(ji,jj,jk ) 182 zwi(ji,jj,jk) = zzwi * wumask(ji,jj,jk ) 183 zzws = zcoef * avmu (ji,jj,jk+1) / fse3uw(ji,jj,jk+1) 184 zws(ji,jj,jk) = zzws * wumask(ji,jj,jk+1) 185 zwd(ji,jj,jk) = 1._wp - zzwi - zzws 174 186 END DO 175 187 END DO … … 198 210 ! 199 211 !== First recurrence : Dk = Dk - Lk * Uk-1 / Dk-1 (increasing k) == 200 DO j j = 2, jpjm1201 DO j i = fs_2, fs_jpim1 ! vector opt.202 DO j k = miku(ji,jj)+1, jpkm1212 DO jk = 2, jpkm1 213 DO jj = 2, jpjm1 214 DO ji = fs_2, fs_jpim1 ! vector opt. 203 215 zwd(ji,jj,jk) = zwd(ji,jj,jk) - zwi(ji,jj,jk) * zws(ji,jj,jk-1) / zwd(ji,jj,jk-1) 204 216 END DO … … 208 220 DO jj = 2, jpjm1 !== second recurrence: SOLk = RHSk - Lk / Dk-1 Lk-1 == 209 221 DO ji = fs_2, fs_jpim1 ! vector opt. 210 ze3ua = ( 1._wp - r_vvl ) * fse3u_n(ji,jj,miku(ji,jj)) + r_vvl * fse3u_a(ji,jj,miku(ji,jj))211 222 #if defined key_dynspg_ts 212 ua(ji,jj,miku(ji,jj)) = ua(ji,jj,miku(ji,jj)) + p2dt * 0.5_wp * ( utau_b(ji,jj) + utau(ji,jj) ) & 213 & / ( ze3ua * rau0 ) 223 ze3ua = ( 1._wp - r_vvl ) * fse3u_n(ji,jj,1) + r_vvl * fse3u_a(ji,jj,1) 224 ua(ji,jj,1) = ua(ji,jj,1) + p2dt * 0.5_wp * ( utau_b(ji,jj) + utau(ji,jj) ) & 225 & / ( ze3ua * rau0 ) * umask(ji,jj,1) 214 226 #else 215 ua(ji,jj,miku(ji,jj)) = ub(ji,jj,miku(ji,jj)) & 216 & + p2dt *(ua(ji,jj,miku(ji,jj)) + 0.5_wp * ( utau_b(ji,jj) + utau(ji,jj) ) & 217 & / ( fse3u(ji,jj,miku(ji,jj)) * rau0 ) ) 218 #endif 219 DO jk = miku(ji,jj)+1, jpkm1 227 ua(ji,jj,1) = ub(ji,jj,1) & 228 & + p2dt *(ua(ji,jj,1) + 0.5_wp * ( utau_b(ji,jj) + utau(ji,jj) ) & 229 & / ( fse3u(ji,jj,1) * rau0 ) * umask(ji,jj,1) ) 230 #endif 231 END DO 232 END DO 233 DO jk = 2, jpkm1 234 DO jj = 2, jpjm1 235 DO ji = fs_2, fs_jpim1 220 236 #if defined key_dynspg_ts 221 237 zrhs = ua(ji,jj,jk) ! zrhs=right hand side … … 231 247 DO ji = fs_2, fs_jpim1 ! vector opt. 232 248 ua(ji,jj,jpkm1) = ua(ji,jj,jpkm1) / zwd(ji,jj,jpkm1) 233 DO jk = jpk-2, miku(ji,jj), -1 249 END DO 250 END DO 251 DO jk = jpk-2, 1, -1 252 DO jj = 2, jpjm1 253 DO ji = fs_2, fs_jpim1 234 254 ua(ji,jj,jk) = ( ua(ji,jj,jk) - zws(ji,jj,jk) * ua(ji,jj,jk+1) ) / zwd(ji,jj,jk) 235 255 END DO … … 260 280 zcoef = - p2dt / ze3va 261 281 zzwi = zcoef * avmv (ji,jj,jk ) / fse3vw(ji,jj,jk ) 262 zwi(ji,jj,jk) = zzwi * vmask(ji,jj,jk)282 zwi(ji,jj,jk) = zzwi * wvmask(ji,jj,jk) 263 283 zzws = zcoef * avmv (ji,jj,jk+1) / fse3vw(ji,jj,jk+1) 264 zws(ji,jj,jk) = zzws * vmask(ji,jj,jk+1)265 zwd(ji,jj,jk) = 1._wp - z wi(ji,jj,jk)- zzws284 zws(ji,jj,jk) = zzws * wvmask(ji,jj,jk+1) 285 zwd(ji,jj,jk) = 1._wp - zzwi - zzws 266 286 END DO 267 287 END DO … … 290 310 ! 291 311 !== First recurrence : Dk = Dk - Lk * Uk-1 / Dk-1 (increasing k) == 292 DO j j = 2, jpjm1293 DO j i = fs_2, fs_jpim1 ! vector opt.294 DO j k = mikv(ji,jj)+1, jpkm1312 DO jk = 2, jpkm1 313 DO jj = 2, jpjm1 314 DO ji = fs_2, fs_jpim1 ! vector opt. 295 315 zwd(ji,jj,jk) = zwd(ji,jj,jk) - zwi(ji,jj,jk) * zws(ji,jj,jk-1) / zwd(ji,jj,jk-1) 296 316 END DO … … 300 320 DO jj = 2, jpjm1 !== second recurrence: SOLk = RHSk - Lk / Dk-1 Lk-1 == 301 321 DO ji = fs_2, fs_jpim1 ! vector opt. 302 ze3va = ( 1._wp - r_vvl ) * fse3v_n(ji,jj,mikv(ji,jj)) + r_vvl * fse3v_a(ji,jj,mikv(ji,jj))303 322 #if defined key_dynspg_ts 304 va(ji,jj,mikv(ji,jj)) = va(ji,jj,mikv(ji,jj)) + p2dt * 0.5_wp * ( vtau_b(ji,jj) + vtau(ji,jj) ) & 323 ze3va = ( 1._wp - r_vvl ) * fse3v_n(ji,jj,1) + r_vvl * fse3v_a(ji,jj,1) 324 va(ji,jj,1) = va(ji,jj,1) + p2dt * 0.5_wp * ( vtau_b(ji,jj) + vtau(ji,jj) ) & 305 325 & / ( ze3va * rau0 ) 306 326 #else 307 va(ji,jj,mikv(ji,jj)) = vb(ji,jj,mikv(ji,jj)) & 308 & + p2dt *(va(ji,jj,mikv(ji,jj)) + 0.5_wp * ( vtau_b(ji,jj) + vtau(ji,jj) ) & 309 & / ( fse3v(ji,jj,mikv(ji,jj)) * rau0 ) ) 310 #endif 311 DO jk = mikv(ji,jj)+1, jpkm1 327 va(ji,jj,1) = vb(ji,jj,1) & 328 & + p2dt *(va(ji,jj,1) + 0.5_wp * ( vtau_b(ji,jj) + vtau(ji,jj) ) & 329 & / ( fse3v(ji,jj,1) * rau0 ) ) 330 #endif 331 END DO 332 END DO 333 DO jk = 2, jpkm1 334 DO jj = 2, jpjm1 335 DO ji = fs_2, fs_jpim1 ! vector opt. 312 336 #if defined key_dynspg_ts 313 337 zrhs = va(ji,jj,jk) ! zrhs=right hand side … … 323 347 DO ji = fs_2, fs_jpim1 ! vector opt. 324 348 va(ji,jj,jpkm1) = va(ji,jj,jpkm1) / zwd(ji,jj,jpkm1) 325 DO jk = jpk-2, mikv(ji,jj), -1 349 END DO 350 END DO 351 DO jk = jpk-2, 1, -1 352 DO jj = 2, jpjm1 353 DO ji = fs_2, fs_jpim1 326 354 va(ji,jj,jk) = ( va(ji,jj,jk) - zws(ji,jj,jk) * va(ji,jj,jk+1) ) / zwd(ji,jj,jk) 327 355 END DO … … 349 377 avmu(ji,jj,ikbu+1) = 0.e0 350 378 avmv(ji,jj,ikbv+1) = 0.e0 351 ikbu = miku(ji,jj) ! ocean top level at u- and v-points352 ikbv = mikv(ji,jj) ! (first wet ocean u- and v-points)353 IF (ikbu > 1) avmu(ji,jj,ikbu) = 0.e0354 IF (ikbv > 1) avmv(ji,jj,ikbv) = 0.e0355 379 END DO 356 380 END DO 381 IF (ln_isfcav) THEN 382 DO jj = 2, jpjm1 383 DO ji = 2, jpim1 384 ikbu = miku(ji,jj) ! ocean top level at u- and v-points 385 ikbv = mikv(ji,jj) ! (first wet ocean u- and v-points) 386 IF (ikbu > 1) avmu(ji,jj,ikbu) = 0.e0 387 IF (ikbv > 1) avmv(ji,jj,ikbv) = 0.e0 388 END DO 389 END DO 390 END IF 357 391 ENDIF 358 392 ! -
branches/2014/dev_r4621_NOC4_BDY_VERT_INTERP/NEMOGCM/NEMO/OPA_SRC/DYN/sshwzv.F90
r5038 r5620 21 21 USE domvvl ! Variable volume 22 22 USE divcur ! hor. divergence and curl (div & cur routines) 23 USE iom ! I/O library24 23 USE restart ! only for lrst_oce 25 24 USE in_out_manager ! I/O manager … … 31 30 USE bdy_par 32 31 USE bdydyn2d ! bdy_ssh routine 33 USE iom34 32 #if defined key_agrif 35 33 USE agrif_opa_update … … 137 135 ! ! outputs ! 138 136 ! !------------------------------! 139 CALL iom_put( "ssh" , sshn ) ! sea surface height140 if( iom_use('ssh2') ) CALL iom_put( "ssh2", sshn(:,:) * sshn(:,:) ) ! square of sea surface height141 137 ! 142 138 IF(ln_ctl) CALL prt_ctl( tab2d_1=ssha, clinfo1=' ssha - : ', mask1=tmask, ovlap=1 ) … … 228 224 #endif 229 225 ! 230 ! !------------------------------!231 ! ! outputs !232 ! !------------------------------!233 CALL iom_put( "woce", wn ) ! vertical velocity234 IF( iom_use('w_masstr') .OR. iom_use('w_masstr2') ) THEN ! vertical mass transport & its square value235 CALL wrk_alloc( jpi, jpj, z2d )236 CALL wrk_alloc( jpi, jpj, jpk, z3d )237 ! Caution: in the VVL case, it only correponds to the baroclinic mass transport.238 z2d(:,:) = rau0 * e12t(:,:)239 DO jk = 1, jpk240 z3d(:,:,jk) = wn(:,:,jk) * z2d(:,:)241 END DO242 CALL iom_put( "w_masstr" , z3d )243 IF( iom_use('w_masstr2') ) CALL iom_put( "w_masstr2", z3d(:,:,:) * z3d(:,:,:) )244 CALL wrk_dealloc( jpi, jpj, z2d )245 CALL wrk_dealloc( jpi, jpj, jpk, z3d )246 ENDIF247 !248 226 IF( nn_timing == 1 ) CALL timing_stop('wzv') 249 227 … … 290 268 ELSE !** Leap-Frog time-stepping: Asselin filter + swap 291 269 sshb(:,:) = sshn(:,:) + atfp * ( sshb(:,:) - 2 * sshn(:,:) + ssha(:,:) ) ! before <-- now filtered 292 IF( lk_vvl ) sshb(:,:) = sshb(:,:) - atfp * rdt / rau0 * ( emp_b(:,:) - emp(:,:) ) * ssmask(:,:)270 IF( lk_vvl ) sshb(:,:) = sshb(:,:) - atfp * rdt / rau0 * ( emp_b(:,:) - emp(:,:) - rnf_b(:,:) + rnf(:,:) ) * ssmask(:,:) 293 271 sshn(:,:) = ssha(:,:) ! now <-- after 294 272 ENDIF -
branches/2014/dev_r4621_NOC4_BDY_VERT_INTERP/NEMOGCM/NEMO/OPA_SRC/FLO/florst.F90
- Property svn:keywords set to Id
r3294 r5620 36 36 !!---------------------------------------------------------------------- 37 37 !! NEMO/OPA 3.2 , LODYC-IPSL (2009) 38 !! $ Header:38 !! $Id$ 39 39 !! This software is governed by the CeCILL licence see modipsl/doc/NEMO_CeCILL.txt 40 40 !!---------------------------------------------------------------------- -
branches/2014/dev_r4621_NOC4_BDY_VERT_INTERP/NEMOGCM/NEMO/OPA_SRC/FLO/flowri.F90
r3294 r5620 50 50 !!---------------------------------------------------------------------- 51 51 !! NEMO/OPA 3.2 , LODYC-IPSL (2009) 52 !! $ Header:52 !! $Id$ 53 53 !! This software is governed by the CeCILL licence see modipsl/doc/NEMO_CeCILL.txt 54 54 !!---------------------------------------------------------------------- -
branches/2014/dev_r4621_NOC4_BDY_VERT_INTERP/NEMOGCM/NEMO/OPA_SRC/ICB/icb_oce.F90
- Property svn:keywords set to Id
r5038 r5620 146 146 !!---------------------------------------------------------------------- 147 147 !! NEMO/OPA 3.3 , NEMO Consortium (2011) 148 !! $Id : sbc_oce.F90 3340 2012-04-02 11:05:35Z sga$148 !! $Id$ 149 149 !! Software governed by the CeCILL licence (NEMOGCM/NEMO_CeCILL.txt) 150 150 !!---------------------------------------------------------------------- -
branches/2014/dev_r4621_NOC4_BDY_VERT_INTERP/NEMOGCM/NEMO/OPA_SRC/ICB/icbclv.F90
- Property svn:keywords set to Id
r3821 r5620 33 33 !!---------------------------------------------------------------------- 34 34 !! NEMO/OPA 3.3 , NEMO Consortium (2011) 35 !! $Id :$35 !! $Id$ 36 36 !! Software governed by the CeCILL licence (NEMOGCM/NEMO_CeCILL.txt) 37 37 !!---------------------------------------------------------------------- -
branches/2014/dev_r4621_NOC4_BDY_VERT_INTERP/NEMOGCM/NEMO/OPA_SRC/ICB/icbdia.F90
- Property svn:keywords set to Id
r3614 r5620 76 76 !!---------------------------------------------------------------------- 77 77 !! NEMO/OPA 3.3 , NEMO Consortium (2011) 78 !! $Id :$78 !! $Id$ 79 79 !! Software governed by the CeCILL licence (NEMOGCM/NEMO_CeCILL.txt) 80 80 !!---------------------------------------------------------------------- -
branches/2014/dev_r4621_NOC4_BDY_VERT_INTERP/NEMOGCM/NEMO/OPA_SRC/ICB/icbdyn.F90
- Property svn:keywords set to Id
r5038 r5620 28 28 !!---------------------------------------------------------------------- 29 29 !! NEMO/OPA 3.3 , NEMO Consortium (2011) 30 !! $Id :$30 !! $Id$ 31 31 !! Software governed by the CeCILL licence (NEMOGCM/NEMO_CeCILL.txt) 32 32 !!---------------------------------------------------------------------- -
branches/2014/dev_r4621_NOC4_BDY_VERT_INTERP/NEMOGCM/NEMO/OPA_SRC/ICB/icbini.F90
- Property svn:keywords set to Id
r5038 r5620 41 41 !!---------------------------------------------------------------------- 42 42 !! NEMO/OPA 3.3 , NEMO Consortium (2011) 43 !! $Id :$43 !! $Id$ 44 44 !! Software governed by the CeCILL licence (NEMOGCM/NEMO_CeCILL.txt) 45 45 !!---------------------------------------------------------------------- -
branches/2014/dev_r4621_NOC4_BDY_VERT_INTERP/NEMOGCM/NEMO/OPA_SRC/ICB/icblbc.F90
- Property svn:keywords set to Id
r5038 r5620 67 67 !!---------------------------------------------------------------------- 68 68 !! NEMO/OPA 3.3 , NEMO Consortium (2011) 69 !! $Id :$69 !! $Id$ 70 70 !! Software governed by the CeCILL licence (NEMOGCM/NEMO_CeCILL.txt) 71 71 !!---------------------------------------------------------------------- -
branches/2014/dev_r4621_NOC4_BDY_VERT_INTERP/NEMOGCM/NEMO/OPA_SRC/ICB/icbrst.F90
- Property svn:keywords set to Id
r5038 r5620 42 42 !!---------------------------------------------------------------------- 43 43 !! NEMO/OPA 3.3 , NEMO Consortium (2011) 44 !! $Id :$44 !! $Id$ 45 45 !! Software governed by the CeCILL licence (NEMOGCM/NEMO_CeCILL.txt) 46 46 !!---------------------------------------------------------------------- … … 64 64 ! start and count arrays 65 65 LOGICAL :: ll_found_restart 66 CHARACTER(len=256) :: cl_path 66 67 CHARACTER(len=256) :: cl_filename 67 68 CHARACTER(len=NF90_MAX_NAME) :: cl_dname … … 70 71 !!---------------------------------------------------------------------- 71 72 72 ! Find a restart file 73 ! Find a restart file. Assume iceberg restarts in same directory as ocean restarts. 74 cl_path = TRIM(cn_ocerst_indir) 75 IF( cl_path(LEN_TRIM(cl_path):) /= '/' ) cl_path = TRIM(cl_path) // '/' 73 76 cl_filename = ' ' 74 77 IF ( lk_mpp ) THEN 75 78 cl_filename = ' ' 76 79 WRITE( cl_filename, '("restart_icebergs_",I4.4,".nc")' ) narea-1 77 INQUIRE( file=TRIM(cl_ filename), exist=ll_found_restart )80 INQUIRE( file=TRIM(cl_path)//TRIM(cl_filename), exist=ll_found_restart ) 78 81 ELSE 79 82 cl_filename = 'restart_icebergs.nc' 80 INQUIRE( file=TRIM(cl_ filename), exist=ll_found_restart )83 INQUIRE( file=TRIM(cl_path)//TRIM(cl_filename), exist=ll_found_restart ) 81 84 ENDIF 82 85 … … 86 89 87 90 IF (nn_verbose_level >= 0 .AND. lwp) & 88 WRITE(numout,'(2a)') 'icebergs, read_restart_bergs: found restart file = ',TRIM(cl_ filename)89 90 nret = NF90_OPEN(TRIM(cl_ filename), NF90_NOWRITE, ncid)91 WRITE(numout,'(2a)') 'icebergs, read_restart_bergs: found restart file = ',TRIM(cl_path)//TRIM(cl_filename) 92 93 nret = NF90_OPEN(TRIM(cl_path)//TRIM(cl_filename), NF90_NOWRITE, ncid) 91 94 IF (nret .ne. NF90_NOERR) CALL ctl_stop('icebergs, read_restart_bergs: nf_open failed') 92 95 … … 228 231 INTEGER :: jn ! dummy loop index 229 232 INTEGER :: ix_dim, iy_dim, ik_dim, in_dim 233 CHARACTER(len=256) :: cl_path 230 234 CHARACTER(len=256) :: cl_filename 231 235 TYPE(iceberg), POINTER :: this … … 233 237 !!---------------------------------------------------------------------- 234 238 239 ! Assume we write iceberg restarts to same directory as ocean restarts. 240 cl_path = TRIM(cn_ocerst_outdir) 241 IF( cl_path(LEN_TRIM(cl_path):) /= '/' ) cl_path = TRIM(cl_path) // '/' 235 242 IF( lk_mpp ) THEN 236 WRITE(cl_filename,'( "icebergs_",I8.8,"_restart_",I4.4,".nc")')kt, narea-1243 WRITE(cl_filename,'(A,"_icebergs_",I8.8,"_restart_",I4.4,".nc")') TRIM(cexper), kt, narea-1 237 244 ELSE 238 WRITE(cl_filename,'( "icebergs_",I8.8,"_restart.nc")')kt239 ENDIF 240 IF (nn_verbose_level >= 0) WRITE(numout,'(2a)') 'icebergs, write_restart: creating ',TRIM(cl_ filename)241 242 nret = NF90_CREATE(TRIM(cl_ filename), NF90_CLOBBER, ncid)245 WRITE(cl_filename,'(A,"_icebergs_",I8.8,"_restart.nc")') TRIM(cexper), kt 246 ENDIF 247 IF (nn_verbose_level >= 0) WRITE(numout,'(2a)') 'icebergs, write_restart: creating ',TRIM(cl_path)//TRIM(cl_filename) 248 249 nret = NF90_CREATE(TRIM(cl_path)//TRIM(cl_filename), NF90_CLOBBER, ncid) 243 250 IF (nret .ne. NF90_NOERR) CALL ctl_stop('icebergs, write_restart: nf_create failed') 244 251 … … 372 379 ENDIF 373 380 ENDDO 374 IF( lwp ) WRITE(numout,*) 'file: ',TRIM(cl_ filename),' var: stored_ice written'381 IF( lwp ) WRITE(numout,*) 'file: ',TRIM(cl_path)//TRIM(cl_filename),' var: stored_ice written' 375 382 376 383 nret = NF90_PUT_VAR( ncid, nkountid, num_bergs(:) ) … … 379 386 nret = NF90_PUT_VAR( ncid, nsheatid, berg_grid%stored_heat(:,:) ) 380 387 IF (nret .ne. NF90_NOERR) CALL ctl_stop('icebergs, write_restart: nf_put_var stored_heat failed') 381 IF( lwp ) WRITE(numout,*) 'file: ',TRIM(cl_ filename),' var: stored_heat written'388 IF( lwp ) WRITE(numout,*) 'file: ',TRIM(cl_path)//TRIM(cl_filename),' var: stored_heat written' 382 389 383 390 nret = NF90_PUT_VAR( ncid, ncalvid , src_calving(:,:) ) … … 385 392 nret = NF90_PUT_VAR( ncid, ncalvhid, src_calving_hflx(:,:) ) 386 393 IF (nret .ne. NF90_NOERR) CALL ctl_stop('icebergs, write_restart: nf_put_var calving_hflx failed') 387 IF( lwp ) WRITE(numout,*) 'file: ',TRIM(cl_ filename),' var: calving written'394 IF( lwp ) WRITE(numout,*) 'file: ',TRIM(cl_path)//TRIM(cl_filename),' var: calving written' 388 395 389 396 IF ( ASSOCIATED(first_berg) ) THEN -
branches/2014/dev_r4621_NOC4_BDY_VERT_INTERP/NEMOGCM/NEMO/OPA_SRC/ICB/icbstp.F90
- Property svn:keywords set to Id
r5038 r5620 46 46 !!---------------------------------------------------------------------- 47 47 !! NEMO/OPA 3.3 , NEMO Consortium (2011) 48 !! $Id :$48 !! $Id$ 49 49 !! Software governed by the CeCILL licence (NEMOGCM/NEMO_CeCILL.txt) 50 50 !!---------------------------------------------------------------------- -
branches/2014/dev_r4621_NOC4_BDY_VERT_INTERP/NEMOGCM/NEMO/OPA_SRC/ICB/icbthm.F90
- Property svn:keywords set to Id
r3631 r5620 31 31 PUBLIC icb_thm ! routine called in icbstp.F90 module 32 32 33 !! $Id$ 33 34 CONTAINS 34 35 -
branches/2014/dev_r4621_NOC4_BDY_VERT_INTERP/NEMOGCM/NEMO/OPA_SRC/ICB/icbtrj.F90
- Property svn:keywords set to Id
r3614 r5620 44 44 !!---------------------------------------------------------------------- 45 45 !! NEMO/OPA 3.3 , NEMO Consortium (2011) 46 !! $Id :$46 !! $Id$ 47 47 !! Software governed by the CeCILL licence (NEMOGCM/NEMO_CeCILL.txt) 48 48 !!---------------------------------------------------------------------- -
branches/2014/dev_r4621_NOC4_BDY_VERT_INTERP/NEMOGCM/NEMO/OPA_SRC/ICB/icbutl.F90
- Property svn:keywords set to Id
r5038 r5620 51 51 !!---------------------------------------------------------------------- 52 52 !! NEMO/OPA 3.3 , NEMO Consortium (2011) 53 !! $Id :$53 !! $Id$ 54 54 !! Software governed by the CeCILL licence (NEMOGCM/NEMO_CeCILL.txt) 55 55 !!------------------------------------------------------------------------- -
branches/2014/dev_r4621_NOC4_BDY_VERT_INTERP/NEMOGCM/NEMO/OPA_SRC/IOM/in_out_manager.F90
r5038 r5620 26 26 CHARACTER(lc) :: cn_exp !: experiment name used for output filename 27 27 CHARACTER(lc) :: cn_ocerst_in !: suffix of ocean restart name (input) 28 CHARACTER(lc) :: cn_ocerst_indir !: restart input directory 28 29 CHARACTER(lc) :: cn_ocerst_out !: suffix of ocean restart name (output) 30 CHARACTER(lc) :: cn_ocerst_outdir !: restart output directory 29 31 LOGICAL :: ln_rstart !: start from (F) rest or (T) a restart file 32 LOGICAL :: ln_rst_list !: output restarts at list of times (T) or by frequency (F) 30 33 INTEGER :: nn_no !: job number 31 34 INTEGER :: nn_rstctl !: control of the time step (0, 1 or 2) … … 38 41 INTEGER :: nn_write !: model standard output frequency 39 42 INTEGER :: nn_stock !: restart file frequency 43 INTEGER, DIMENSION(10) :: nn_stocklist !: restart dump times 40 44 LOGICAL :: ln_dimgnnn !: type of dimgout. (F): 1 file for all proc 41 45 !: (T): 1 file per proc 42 46 LOGICAL :: ln_mskland !: mask land points in NetCDF outputs (costly: + ~15%) 47 LOGICAL :: ln_cfmeta !: output additional data to netCDF files required for compliance with the CF metadata standard 43 48 LOGICAL :: ln_clobber !: clobber (overwrite) an existing file 44 49 INTEGER :: nn_chunksz !: chunksize (bytes) for NetCDF file (works only with iom_nf90 routines) … … 78 83 INTEGER :: nwrite !: model standard output frequency 79 84 INTEGER :: nstock !: restart file frequency 85 INTEGER, DIMENSION(10) :: nstocklist !: restart dump times 80 86 81 87 !!---------------------------------------------------------------------- … … 84 90 INTEGER :: nitrst !: time step at which restart file should be written 85 91 LOGICAL :: lrst_oce !: logical to control the oce restart write 86 INTEGER :: numror, numrow !: logical unit for cean restart (read and write) 92 INTEGER :: numror = 0 !: logical unit for ocean restart (read). Init to 0 is needed for SAS (in daymod.F90) 93 INTEGER :: numrow !: logical unit for ocean restart (write) 94 INTEGER :: nrst_lst !: number of restart to output next 87 95 88 96 !!---------------------------------------------------------------------- … … 142 150 LOGICAL :: lwp = .FALSE. !: boolean : true on the 1st processor only .OR. ln_ctl 143 151 LOGICAL :: lsp_area = .TRUE. !: to make a control print over a specific area 152 CHARACTER(lc) :: cxios_context !: context name used in xios 144 153 145 154 !!---------------------------------------------------------------------- -
branches/2014/dev_r4621_NOC4_BDY_VERT_INTERP/NEMOGCM/NEMO/OPA_SRC/IOM/iom.F90
r5038 r5620 33 33 USE icb_oce, ONLY : nclasses, class_num ! !: iceberg classes 34 34 #if defined key_lim3 35 USE par_ice35 USE ice , ONLY : jpl 36 36 #elif defined key_lim2 37 37 USE par_ice_2 … … 61 61 #if defined key_iomput 62 62 PRIVATE iom_set_domain_attr, iom_set_axis_attr, iom_set_field_attr, iom_set_file_attr, iom_get_file_attr, iom_set_grid_attr 63 PRIVATE set_grid, set_ scalar, set_xmlatt, set_mooring, iom_update_file_name, iom_sdate63 PRIVATE set_grid, set_grid_bounds, set_scalar, set_xmlatt, set_mooring, iom_update_file_name, iom_sdate 64 64 # endif 65 65 … … 98 98 CHARACTER(len=10) :: clname 99 99 INTEGER :: ji 100 !!---------------------------------------------------------------------- 100 ! 101 REAL(wp), ALLOCATABLE, DIMENSION(:,:) :: z_bnds 102 !!---------------------------------------------------------------------- 103 104 ALLOCATE( z_bnds(jpk,2) ) 101 105 102 106 clname = cdname 103 107 IF( TRIM(Agrif_CFixed()) /= '0' ) clname = TRIM(Agrif_CFixed())//"_"//TRIM(cdname) 104 # if defined key_mpp_mpi105 108 CALL xios_context_initialize(TRIM(clname), mpi_comm_opa) 106 # else107 CALL xios_context_initialize(TRIM(clname), 0)108 # endif109 109 CALL iom_swap( cdname ) 110 110 … … 121 121 CALL set_scalar 122 122 123 IF( TRIM(cdname) == "nemo") THEN123 IF( TRIM(cdname) == TRIM(cxios_context) ) THEN 124 124 CALL set_grid( "T", glamt, gphit ) 125 125 CALL set_grid( "U", glamu, gphiu ) 126 126 CALL set_grid( "V", glamv, gphiv ) 127 127 CALL set_grid( "W", glamt, gphit ) 128 ENDIF 129 130 IF( TRIM(cdname) == "nemo_crs" ) THEN 128 CALL set_grid_znl( gphit ) 129 ! 130 IF( ln_cfmeta ) THEN ! Add additional grid metadata 131 CALL iom_set_domain_attr("grid_T", area = e12t(nldi:nlei, nldj:nlej)) 132 CALL iom_set_domain_attr("grid_U", area = e12u(nldi:nlei, nldj:nlej)) 133 CALL iom_set_domain_attr("grid_V", area = e12v(nldi:nlei, nldj:nlej)) 134 CALL iom_set_domain_attr("grid_W", area = e12t(nldi:nlei, nldj:nlej)) 135 CALL set_grid_bounds( "T", glamf, gphif, glamt, gphit ) 136 CALL set_grid_bounds( "U", glamv, gphiv, glamu, gphiu ) 137 CALL set_grid_bounds( "V", glamu, gphiu, glamv, gphiv ) 138 CALL set_grid_bounds( "W", glamf, gphif, glamt, gphit ) 139 ENDIF 140 ENDIF 141 142 IF( TRIM(cdname) == TRIM(cxios_context)//"_crs" ) THEN 131 143 CALL dom_grid_crs ! Save the parent grid information & Switch to coarse grid domain 132 144 ! … … 135 147 CALL set_grid( "V", glamv_crs, gphiv_crs ) 136 148 CALL set_grid( "W", glamt_crs, gphit_crs ) 149 CALL set_grid_znl( gphit_crs ) 137 150 ! 138 151 CALL dom_grid_glo ! Return to parent grid domain 139 ENDIF 140 152 ! 153 IF( ln_cfmeta ) THEN ! Add additional grid metadata 154 CALL iom_set_domain_attr("grid_T", area = e1e2t_crs(nldi:nlei, nldj:nlej)) 155 CALL iom_set_domain_attr("grid_U", area = e1u_crs(nldi:nlei, nldj:nlej) * e2u_crs(nldi:nlei, nldj:nlej)) 156 CALL iom_set_domain_attr("grid_V", area = e1v_crs(nldi:nlei, nldj:nlej) * e2v_crs(nldi:nlei, nldj:nlej)) 157 CALL iom_set_domain_attr("grid_W", area = e1e2t_crs(nldi:nlei, nldj:nlej)) 158 CALL set_grid_bounds( "T", glamf_crs, gphif_crs, glamt_crs, gphit_crs ) 159 CALL set_grid_bounds( "U", glamv_crs, gphiv_crs, glamu_crs, gphiu_crs ) 160 CALL set_grid_bounds( "V", glamu_crs, gphiu_crs, glamv_crs, gphiv_crs ) 161 CALL set_grid_bounds( "W", glamf_crs, gphif_crs, glamt_crs, gphit_crs ) 162 ENDIF 163 ENDIF 141 164 142 165 ! vertical grid definition … … 145 168 CALL iom_set_axis_attr( "depthv", gdept_1d ) 146 169 CALL iom_set_axis_attr( "depthw", gdepw_1d ) 170 171 ! Add vertical grid bounds 172 z_bnds(: ,1) = gdepw_1d(:) 173 z_bnds(1:jpkm1,2) = gdepw_1d(2:jpk) 174 z_bnds(jpk: ,2) = gdepw_1d(jpk) + e3t_1d(jpk) 175 CALL iom_set_axis_attr( "deptht", bounds=z_bnds ) 176 CALL iom_set_axis_attr( "depthu", bounds=z_bnds ) 177 CALL iom_set_axis_attr( "depthv", bounds=z_bnds ) 178 z_bnds(: ,2) = gdept_1d(:) 179 z_bnds(2:jpk,1) = gdept_1d(1:jpkm1) 180 z_bnds(1 ,1) = gdept_1d(1) - e3w_1d(1) 181 CALL iom_set_axis_attr( "depthw", bounds=z_bnds ) 182 147 183 # if defined key_floats 148 184 CALL iom_set_axis_attr( "nfloat", (/ (REAL(ji,wp), ji=1,nfloat) /) ) … … 152 188 #endif 153 189 CALL iom_set_axis_attr( "icbcla", class_num ) 190 CALL iom_set_axis_attr( "iax_20C", (/ REAL(20,wp) /) ) 191 CALL iom_set_axis_attr( "iax_28C", (/ REAL(28,wp) /) ) 154 192 155 193 ! automatic definitions of some of the xml attributs … … 162 200 163 201 CALL xios_update_calendar(0) 202 203 DEALLOCATE( z_bnds ) 204 164 205 #endif 165 206 … … 543 584 END SUBROUTINE iom_g1d 544 585 545 SUBROUTINE iom_g2d( kiomid, kdom, cdvar, pvar, ktime, kstart, kcount )586 SUBROUTINE iom_g2d( kiomid, kdom, cdvar, pvar, ktime, kstart, kcount, lrowattr ) 546 587 INTEGER , INTENT(in ) :: kiomid ! Identifier of the file 547 588 INTEGER , INTENT(in ) :: kdom ! Type of domain to be read … … 551 592 INTEGER , INTENT(in ), DIMENSION(2) , OPTIONAL :: kstart ! start axis position of the reading 552 593 INTEGER , INTENT(in ), DIMENSION(2) , OPTIONAL :: kcount ! number of points in each axis 594 LOGICAL , INTENT(in ) , OPTIONAL :: lrowattr ! logical flag telling iom_get to 595 ! look for and use a file attribute 596 ! called open_ocean_jstart to set the start 597 ! value for the 2nd dimension (netcdf only) 553 598 ! 554 599 IF( kiomid > 0 ) THEN 555 600 IF( iom_file(kiomid)%nfid > 0 ) CALL iom_get_123d( kiomid, kdom , cdvar , pv_r2d=pvar, & 556 & ktime=ktime, kstart=kstart, kcount=kcount ) 601 & ktime=ktime, kstart=kstart, kcount=kcount, & 602 & lrowattr=lrowattr ) 557 603 ENDIF 558 604 END SUBROUTINE iom_g2d 559 605 560 SUBROUTINE iom_g3d( kiomid, kdom, cdvar, pvar, ktime, kstart, kcount )606 SUBROUTINE iom_g3d( kiomid, kdom, cdvar, pvar, ktime, kstart, kcount, lrowattr ) 561 607 INTEGER , INTENT(in ) :: kiomid ! Identifier of the file 562 608 INTEGER , INTENT(in ) :: kdom ! Type of domain to be read … … 566 612 INTEGER , INTENT(in ), DIMENSION(3) , OPTIONAL :: kstart ! start axis position of the reading 567 613 INTEGER , INTENT(in ), DIMENSION(3) , OPTIONAL :: kcount ! number of points in each axis 614 LOGICAL , INTENT(in ) , OPTIONAL :: lrowattr ! logical flag telling iom_get to 615 ! look for and use a file attribute 616 ! called open_ocean_jstart to set the start 617 ! value for the 2nd dimension (netcdf only) 568 618 ! 569 619 IF( kiomid > 0 ) THEN 570 620 IF( iom_file(kiomid)%nfid > 0 ) CALL iom_get_123d( kiomid, kdom , cdvar , pv_r3d=pvar, & 571 & ktime=ktime, kstart=kstart, kcount=kcount ) 621 & ktime=ktime, kstart=kstart, kcount=kcount, & 622 & lrowattr=lrowattr ) 572 623 ENDIF 573 624 END SUBROUTINE iom_g3d … … 576 627 SUBROUTINE iom_get_123d( kiomid, kdom , cdvar , & 577 628 & pv_r1d, pv_r2d, pv_r3d, & 578 & ktime , kstart, kcount ) 629 & ktime , kstart, kcount, & 630 & lrowattr ) 579 631 !!----------------------------------------------------------------------- 580 632 !! *** ROUTINE iom_get_123d *** … … 593 645 INTEGER , DIMENSION(:) , INTENT(in ), OPTIONAL :: kstart ! start position of the reading in each axis 594 646 INTEGER , DIMENSION(:) , INTENT(in ), OPTIONAL :: kcount ! number of points to be read in each axis 647 LOGICAL , INTENT(in ), OPTIONAL :: lrowattr ! logical flag telling iom_get to 648 ! look for and use a file attribute 649 ! called open_ocean_jstart to set the start 650 ! value for the 2nd dimension (netcdf only) 595 651 ! 596 652 LOGICAL :: llnoov ! local definition to read overlap 653 LOGICAL :: luse_jattr ! local definition to read open_ocean_jstart file attribute 654 INTEGER :: jstartrow ! start point for 2nd dimension optionally set by file attribute 597 655 INTEGER :: jl ! loop on number of dimension 598 656 INTEGER :: idom ! type of domain … … 604 662 INTEGER :: ix1, ix2, iy1, iy2 ! subdomain indexes 605 663 INTEGER :: ji, jj ! loop counters 606 INTEGER :: irankpv 664 INTEGER :: irankpv ! 607 665 INTEGER :: ind1, ind2 ! substring index 608 666 INTEGER, DIMENSION(jpmax_dims) :: istart ! starting point to read for each axis … … 628 686 IF( PRESENT(kstart) .AND. (.NOT. PRESENT(kcount)) ) CALL ctl_stop(trim(clinfo), 'kstart present needs kcount present') 629 687 IF( PRESENT(kstart) .AND. idom /= jpdom_unknown ) CALL ctl_stop(trim(clinfo), 'kstart present needs kdom = jpdom_unknown') 688 689 luse_jattr = .false. 690 IF( PRESENT(lrowattr) ) THEN 691 IF( lrowattr .AND. idom /= jpdom_data ) CALL ctl_stop(trim(clinfo), 'lrowattr present and true needs kdom = jpdom_data') 692 IF( lrowattr .AND. idom == jpdom_data ) luse_jattr = .true. 693 ENDIF 694 IF( luse_jattr ) THEN 695 SELECT CASE (iom_file(kiomid)%iolib) 696 CASE (jpioipsl, jprstdimg ) 697 CALL ctl_warn(trim(clinfo), 'lrowattr present and true but this only works with netcdf (jpnf90)') 698 luse_jattr = .false. 699 CASE (jpnf90 ) 700 ! Ok 701 CASE DEFAULT 702 CALL ctl_stop( TRIM(clinfo)//' accepted IO library are only jpioipsl, jpnf90 and jprstdimg' ) 703 END SELECT 704 ENDIF 630 705 631 706 ! Search for the variable in the data base (eventually actualize data) … … 701 776 ELSE 702 777 IF( .NOT. PRESENT(pv_r1d) ) THEN ! not a 1D array 703 IF( idom == jpdom_data ) THEN ; istart(1:2) = (/ mig(1), mjg(1) /) ! icnt(1:2) done bellow 704 ELSEIF( idom == jpdom_global ) THEN ; istart(1:2) = (/ nimpp , njmpp /) ! icnt(1:2) done bellow 778 IF( idom == jpdom_data ) THEN 779 jstartrow = 1 780 IF( luse_jattr ) THEN 781 CALL iom_getatt(kiomid, 'open_ocean_jstart', jstartrow ) ! -999 is returned if the attribute is not found 782 jstartrow = MAX(1,jstartrow) 783 ENDIF 784 istart(1:2) = (/ mig(1), mjg(1) + jstartrow - 1 /) ! icnt(1:2) done below 785 ELSEIF( idom == jpdom_global ) THEN ; istart(1:2) = (/ nimpp , njmpp /) ! icnt(1:2) done below 705 786 ENDIF 706 787 ! we do not read the overlap -> we start to read at nldi, nldj … … 1090 1171 1091 1172 SUBROUTINE iom_set_domain_attr( cdid, ni_glo, nj_glo, ibegin, jbegin, ni, nj, zoom_ibegin, zoom_jbegin, zoom_ni, zoom_nj, & 1092 & data_dim, data_ibegin, data_ni, data_jbegin, data_nj, lonvalue, latvalue, mask ) 1093 CHARACTER(LEN=*) , INTENT(in) :: cdid 1094 INTEGER , OPTIONAL, INTENT(in) :: ni_glo, nj_glo, ibegin, jbegin, ni, nj 1095 INTEGER , OPTIONAL, INTENT(in) :: data_dim, data_ibegin, data_ni, data_jbegin, data_nj 1096 INTEGER , OPTIONAL, INTENT(in) :: zoom_ibegin, zoom_jbegin, zoom_ni, zoom_nj 1097 REAL(wp), DIMENSION(:) , OPTIONAL, INTENT(in) :: lonvalue, latvalue 1098 LOGICAL, DIMENSION(:,:), OPTIONAL, INTENT(in) :: mask 1173 & data_dim, data_ibegin, data_ni, data_jbegin, data_nj, lonvalue, latvalue, mask, & 1174 & nvertex, bounds_lon, bounds_lat, area ) 1175 CHARACTER(LEN=*) , INTENT(in) :: cdid 1176 INTEGER , OPTIONAL, INTENT(in) :: ni_glo, nj_glo, ibegin, jbegin, ni, nj 1177 INTEGER , OPTIONAL, INTENT(in) :: data_dim, data_ibegin, data_ni, data_jbegin, data_nj 1178 INTEGER , OPTIONAL, INTENT(in) :: zoom_ibegin, zoom_jbegin, zoom_ni, zoom_nj, nvertex 1179 REAL(wp), DIMENSION(:) , OPTIONAL, INTENT(in) :: lonvalue, latvalue 1180 REAL(wp), DIMENSION(:,:) , OPTIONAL, INTENT(in) :: bounds_lon, bounds_lat, area 1181 LOGICAL, DIMENSION(:,:) , OPTIONAL, INTENT(in) :: mask 1099 1182 1100 1183 IF ( xios_is_valid_domain (cdid) ) THEN … … 1102 1185 & data_dim=data_dim, data_ibegin=data_ibegin, data_ni=data_ni, data_jbegin=data_jbegin, data_nj=data_nj , & 1103 1186 & zoom_ibegin=zoom_ibegin, zoom_jbegin=zoom_jbegin, zoom_ni=zoom_ni, zoom_nj=zoom_nj, & 1104 & lonvalue=lonvalue, latvalue=latvalue,mask=mask ) 1187 & lonvalue=lonvalue, latvalue=latvalue, mask=mask, nvertex=nvertex, bounds_lon=bounds_lon, & 1188 & bounds_lat=bounds_lat, area=area ) 1105 1189 ENDIF 1106 1190 … … 1109 1193 & data_dim=data_dim, data_ibegin=data_ibegin, data_ni=data_ni, data_jbegin=data_jbegin, data_nj=data_nj , & 1110 1194 & zoom_ibegin=zoom_ibegin, zoom_jbegin=zoom_jbegin, zoom_ni=zoom_ni, zoom_nj=zoom_nj, & 1111 & lonvalue=lonvalue, latvalue=latvalue,mask=mask ) 1195 & lonvalue=lonvalue, latvalue=latvalue, mask=mask, nvertex=nvertex, bounds_lon=bounds_lon, & 1196 & bounds_lat=bounds_lat, area=area ) 1112 1197 ENDIF 1113 1198 CALL xios_solve_inheritance() … … 1116 1201 1117 1202 1118 SUBROUTINE iom_set_axis_attr( cdid, paxis )1203 SUBROUTINE iom_set_axis_attr( cdid, paxis, bounds ) 1119 1204 CHARACTER(LEN=*) , INTENT(in) :: cdid 1120 REAL(wp), DIMENSION(:), INTENT(in) :: paxis 1121 IF ( xios_is_valid_axis (cdid) ) CALL xios_set_axis_attr ( cdid, size=size(paxis),value=paxis ) 1122 IF ( xios_is_valid_axisgroup(cdid) ) CALL xios_set_axisgroup_attr( cdid, size=size(paxis),value=paxis ) 1205 REAL(wp), DIMENSION(:) , OPTIONAL, INTENT(in) :: paxis 1206 REAL(wp), DIMENSION(:,:), OPTIONAL, INTENT(in) :: bounds 1207 IF ( PRESENT(paxis) ) THEN 1208 IF ( xios_is_valid_axis (cdid) ) CALL xios_set_axis_attr ( cdid, size=SIZE(paxis), value=paxis ) 1209 IF ( xios_is_valid_axisgroup(cdid) ) CALL xios_set_axisgroup_attr( cdid, size=SIZE(paxis), value=paxis ) 1210 ENDIF 1211 IF ( xios_is_valid_axis (cdid) ) CALL xios_set_axis_attr ( cdid, bounds=bounds ) 1212 IF ( xios_is_valid_axisgroup(cdid) ) CALL xios_set_axisgroup_attr( cdid, bounds=bounds ) 1123 1213 CALL xios_solve_inheritance() 1124 1214 END SUBROUTINE iom_set_axis_attr … … 1183 1273 CALL iom_swap( cdname ) ! swap to cdname context 1184 1274 CALL xios_update_calendar(kt) 1185 IF( cdname /= "nemo" ) CALL iom_swap( "nemo") ! return back to nemo context1275 IF( cdname /= TRIM(cxios_context) ) CALL iom_swap( TRIM(cxios_context) ) ! return back to nemo context 1186 1276 ! 1187 1277 END SUBROUTINE iom_setkt … … 1193 1283 CALL iom_swap( cdname ) ! swap to cdname context 1194 1284 CALL xios_context_finalize() ! finalize the context 1195 IF( cdname /= "nemo" ) CALL iom_swap( "nemo") ! return back to nemo context1285 IF( cdname /= TRIM(cxios_context) ) CALL iom_swap( TRIM(cxios_context) ) ! return back to nemo context 1196 1286 ENDIF 1197 1287 ! … … 1225 1315 CASE('T') ; zmask(:,:,:) = tmask(:,:,:) 1226 1316 CASE('U') ; zmask(2:jpim1,:,:) = tmask(2:jpim1,:,:) + tmask(3:jpi,:,:) ; CALL lbc_lnk( zmask, 'U', 1. ) 1227 CASE('V') ; zmask(:,2:jpjm1,:) = tmask(:,2:jpjm1,:) + tmask(:,3:jp i,:) ; CALL lbc_lnk( zmask, 'V', 1. )1317 CASE('V') ; zmask(:,2:jpjm1,:) = tmask(:,2:jpjm1,:) + tmask(:,3:jpj,:) ; CALL lbc_lnk( zmask, 'V', 1. ) 1228 1318 CASE('W') ; zmask(:,:,2:jpk ) = tmask(:,:,1:jpkm1) + tmask(:,:,2:jpk) ; zmask(:,:,1) = tmask(:,:,1) 1229 1319 END SELECT … … 1236 1326 1237 1327 1328 SUBROUTINE set_grid_bounds( cdgrd, plon_cnr, plat_cnr, plon_pnt, plat_pnt ) 1329 !!---------------------------------------------------------------------- 1330 !! *** ROUTINE set_grid_bounds *** 1331 !! 1332 !! ** Purpose : define horizontal grid corners 1333 !! 1334 !!---------------------------------------------------------------------- 1335 CHARACTER(LEN=1) , INTENT(in) :: cdgrd 1336 ! 1337 REAL(wp), DIMENSION(jpi,jpj), INTENT(in) :: plon_cnr, plat_cnr ! Lat/lon coordinates of a contiguous vertex of cell (i,j) 1338 REAL(wp), DIMENSION(jpi,jpj), OPTIONAL, INTENT(in) :: plon_pnt, plat_pnt ! Lat/lon coordinates of the point of cell (i,j) 1339 ! 1340 REAL(wp), ALLOCATABLE, DIMENSION(:,:,:,:) :: z_bnds ! Lat/lon coordinates of the vertices of cell (i,j) 1341 REAL(wp), ALLOCATABLE, DIMENSION(:,:) :: z_fld ! Working array to determine where to rotate cells 1342 REAL(wp), ALLOCATABLE, DIMENSION(:,:) :: z_rot ! Lat/lon working array for rotation of cells 1343 ! 1344 INTEGER :: icnr, jcnr ! Offset such that the vertex coordinate (i+icnr,j+jcnr) 1345 ! ! represents the bottom-left corner of cell (i,j) 1346 INTEGER :: ji, jj, jn, ni, nj 1347 1348 ALLOCATE( z_bnds(4,jpi,jpj,2), z_fld(jpi,jpj), z_rot(4,2) ) 1349 1350 ! Offset of coordinate representing bottom-left corner 1351 SELECT CASE ( TRIM(cdgrd) ) 1352 CASE ('T', 'W') 1353 icnr = -1 ; jcnr = -1 1354 CASE ('U') 1355 icnr = 0 ; jcnr = -1 1356 CASE ('V') 1357 icnr = -1 ; jcnr = 0 1358 END SELECT 1359 1360 ni = nlei-nldi+1 ; nj = nlej-nldj+1 ! Dimensions of subdomain interior 1361 1362 z_fld(:,:) = 1._wp 1363 CALL lbc_lnk( z_fld, cdgrd, -1. ) ! Working array for location of northfold 1364 1365 ! Cell vertices that can be defined 1366 DO jj = 2, jpjm1 1367 DO ji = 2, jpim1 1368 z_bnds(1,ji,jj,1) = plat_cnr(ji+icnr, jj+jcnr ) ! Bottom-left 1369 z_bnds(2,ji,jj,1) = plat_cnr(ji+icnr+1,jj+jcnr ) ! Bottom-right 1370 z_bnds(3,ji,jj,1) = plat_cnr(ji+icnr+1,jj+jcnr+1) ! Top-right 1371 z_bnds(4,ji,jj,1) = plat_cnr(ji+icnr, jj+jcnr+1) ! Top-left 1372 z_bnds(1,ji,jj,2) = plon_cnr(ji+icnr, jj+jcnr ) ! Bottom-left 1373 z_bnds(2,ji,jj,2) = plon_cnr(ji+icnr+1,jj+jcnr ) ! Bottom-right 1374 z_bnds(3,ji,jj,2) = plon_cnr(ji+icnr+1,jj+jcnr+1) ! Top-right 1375 z_bnds(4,ji,jj,2) = plon_cnr(ji+icnr, jj+jcnr+1) ! Top-left 1376 END DO 1377 END DO 1378 1379 ! Cell vertices on boundries 1380 DO jn = 1, 4 1381 CALL lbc_lnk( z_bnds(jn,:,:,1), cdgrd, 1., pval=999._wp ) 1382 CALL lbc_lnk( z_bnds(jn,:,:,2), cdgrd, 1., pval=999._wp ) 1383 END DO 1384 1385 ! Zero-size cells at closed boundaries if cell points provided, 1386 ! otherwise they are closed cells with unrealistic bounds 1387 IF( PRESENT(plon_pnt) .AND. PRESENT(plat_pnt) ) THEN 1388 IF( (nbondi == -1 .OR. nbondi == 2) .AND. .NOT. (jperio == 1 .OR. jperio == 4 .OR. jperio == 6) ) THEN 1389 DO jn = 1, 4 ! (West or jpni = 1), closed E-W 1390 z_bnds(jn,1,:,1) = plat_pnt(1,:) ; z_bnds(jn,1,:,2) = plon_pnt(1,:) 1391 END DO 1392 ENDIF 1393 IF( (nbondi == 1 .OR. nbondi == 2) .AND. .NOT. (jperio == 1 .OR. jperio == 4 .OR. jperio == 6) ) THEN 1394 DO jn = 1, 4 ! (East or jpni = 1), closed E-W 1395 z_bnds(jn,nlci,:,1) = plat_pnt(nlci,:) ; z_bnds(jn,nlci,:,2) = plon_pnt(nlci,:) 1396 END DO 1397 ENDIF 1398 IF( nbondj == -1 .OR. (nbondj == 2 .AND. jperio /= 2) ) THEN 1399 DO jn = 1, 4 ! South or (jpnj = 1, not symmetric) 1400 z_bnds(jn,:,1,1) = plat_pnt(:,1) ; z_bnds(jn,:,1,2) = plon_pnt(:,1) 1401 END DO 1402 ENDIF 1403 IF( (nbondj == 1 .OR. nbondj == 2) .AND. jperio < 3 ) THEN 1404 DO jn = 1, 4 ! (North or jpnj = 1), no north fold 1405 z_bnds(jn,:,nlcj,1) = plat_pnt(:,nlcj) ; z_bnds(jn,:,nlcj,2) = plon_pnt(:,nlcj) 1406 END DO 1407 ENDIF 1408 ENDIF 1409 1410 ! Rotate cells at the north fold 1411 IF( (nbondj == 1 .OR. nbondj == 2) .AND. jperio >= 3 ) THEN 1412 DO jj = 1, jpj 1413 DO ji = 1, jpi 1414 IF( z_fld(ji,jj) == -1. ) THEN 1415 z_rot(1,:) = z_bnds(3,ji,jj,:) ; z_rot(2,:) = z_bnds(4,ji,jj,:) 1416 z_rot(3,:) = z_bnds(1,ji,jj,:) ; z_rot(4,:) = z_bnds(2,ji,jj,:) 1417 z_bnds(:,ji,jj,:) = z_rot(:,:) 1418 ENDIF 1419 END DO 1420 END DO 1421 1422 ! Invert cells at the symmetric equator 1423 ELSE IF( nbondj == 2 .AND. jperio == 2 ) THEN 1424 DO ji = 1, jpi 1425 z_rot(1:2,:) = z_bnds(3:4,ji,1,:) 1426 z_rot(3:4,:) = z_bnds(1:2,ji,1,:) 1427 z_bnds(:,ji,1,:) = z_rot(:,:) 1428 END DO 1429 ENDIF 1430 1431 CALL iom_set_domain_attr("grid_"//cdgrd, bounds_lat = RESHAPE(z_bnds(:,nldi:nlei,nldj:nlej,1),(/ 4,ni*nj /)), & 1432 bounds_lon = RESHAPE(z_bnds(:,nldi:nlei,nldj:nlej,2),(/ 4,ni*nj /)), nvertex=4 ) 1433 1434 DEALLOCATE( z_bnds, z_fld, z_rot ) 1435 1436 END SUBROUTINE set_grid_bounds 1437 1438 1439 SUBROUTINE set_grid_znl( plat ) 1440 !!---------------------------------------------------------------------- 1441 !! *** ROUTINE set_grid_znl *** 1442 !! 1443 !! ** Purpose : define grids for zonal mean 1444 !! 1445 !!---------------------------------------------------------------------- 1446 REAL(wp), DIMENSION(jpi,jpj), INTENT(in) :: plat 1447 ! 1448 REAL(wp), DIMENSION(:), ALLOCATABLE :: zlon 1449 INTEGER :: ni,nj, ix, iy 1450 1451 1452 ni=nlei-nldi+1 ; nj=nlej-nldj+1 ! define zonal mean domain (jpj*jpk) 1453 ALLOCATE( zlon(ni*nj) ) ; zlon(:) = 0. 1454 1455 CALL iom_set_domain_attr("gznl", ni_glo=jpiglo, nj_glo=jpjglo, ibegin=nimpp+nldi-1, jbegin=njmpp+nldj-1, ni=ni, nj=nj) 1456 CALL iom_set_domain_attr("gznl", data_dim=2, data_ibegin = 1-nldi, data_ni = jpi, data_jbegin = 1-nldj, data_nj = jpj) 1457 CALL iom_set_domain_attr("gznl", lonvalue = zlon, & 1458 & latvalue = RESHAPE(plat(nldi:nlei, nldj:nlej),(/ ni*nj /))) 1459 ! 1460 CALL dom_ngb( 180., 90., ix, iy, 'T' ) ! i-line that passes near the North Pole : Reference latitude (used in plots) 1461 CALL iom_set_domain_attr ('ptr', zoom_ibegin=ix, zoom_nj=jpjglo) 1462 CALL iom_update_file_name('ptr') 1463 ! 1464 END SUBROUTINE set_grid_znl 1465 1238 1466 SUBROUTINE set_scalar 1239 1467 !!---------------------------------------------------------------------- … … 1243 1471 !! 1244 1472 !!---------------------------------------------------------------------- 1245 REAL(wp), DIMENSION(1) :: zz = 1.1473 REAL(wp), DIMENSION(1) :: zz = 1. 1246 1474 !!---------------------------------------------------------------------- 1247 1475 CALL iom_set_domain_attr('scalarpoint', ni_glo=jpnij, nj_glo=1, ibegin=narea, jbegin=1, ni=1, nj=1) 1248 1476 CALL iom_set_domain_attr('scalarpoint', data_dim=2, data_ibegin = 1, data_ni = 1, data_jbegin = 1, data_nj = 1) 1477 1249 1478 zz=REAL(narea,wp) 1250 1479 CALL iom_set_domain_attr('scalarpoint', lonvalue=zz, latvalue=zz) … … 1319 1548 zlatpira = (/ -19.0, -14.0, -8.0, 0.0, 4.0, 8.0, 12.0, 15.0, 20.0 /) 1320 1549 CALL set_mooring( zlonpira, zlatpira ) 1550 1321 1551 1322 1552 END SUBROUTINE set_xmlatt -
branches/2014/dev_r4621_NOC4_BDY_VERT_INTERP/NEMOGCM/NEMO/OPA_SRC/IOM/iom_nf90.F90
r4792 r5620 61 61 INTEGER, DIMENSION(2,5), INTENT(in ), OPTIONAL :: kdompar ! domain parameters: 62 62 63 CHARACTER(LEN= 100) :: clinfo ! info character64 CHARACTER(LEN= 100) :: cltmp ! temporary character63 CHARACTER(LEN=256) :: clinfo ! info character 64 CHARACTER(LEN=256) :: cltmp ! temporary character 65 65 INTEGER :: iln ! lengths of character 66 66 INTEGER :: istop ! temporary storage of nstop … … 422 422 INTEGER, DIMENSION(4) :: idimsz ! dimensions size 423 423 INTEGER, DIMENSION(4) :: idimid ! dimensions id 424 CHARACTER(LEN= 100) :: clinfo ! info character424 CHARACTER(LEN=256) :: clinfo ! info character 425 425 CHARACTER(LEN= 12), DIMENSION(4) :: cltmp ! temporary character 426 426 INTEGER :: if90id ! nf90 file identifier -
branches/2014/dev_r4621_NOC4_BDY_VERT_INTERP/NEMOGCM/NEMO/OPA_SRC/IOM/restart.F90
r5038 r5620 24 24 USE trdmxl_oce ! ocean active mixed layer tracers trends variables 25 25 USE divcur ! hor. divergence and curl (div & cur routines) 26 USE sbc_ice, ONLY : lk_lim327 26 28 27 IMPLICIT NONE … … 57 56 !! 58 57 CHARACTER(LEN=20) :: clkt ! ocean time-step deine as a character 59 CHARACTER(LEN=50) :: clname ! ice output restart file name 58 CHARACTER(LEN=50) :: clname ! ocean output restart file name 59 CHARACTER(lc) :: clpath ! full path to ocean output restart file 60 60 !!---------------------------------------------------------------------- 61 61 ! 62 62 IF( kt == nit000 ) THEN ! default definitions 63 63 lrst_oce = .FALSE. 64 nitrst = nitend 65 ENDIF 66 IF( MOD( kt - 1, nstock ) == 0 ) THEN 64 IF( ln_rst_list ) THEN 65 nrst_lst = 1 66 nitrst = nstocklist( nrst_lst ) 67 ELSE 68 nitrst = nitend 69 ENDIF 70 ENDIF 71 72 ! frequency-based restart dumping (nn_stock) 73 IF( .NOT. ln_rst_list .AND. MOD( kt - 1, nstock ) == 0 ) THEN 67 74 ! we use kt - 1 and not kt - nit000 to keep the same periodicity from the beginning of the experiment 68 75 nitrst = kt + nstock - 1 ! define the next value of nitrst for restart writing … … 73 80 ! except if we write ocean restart files every time step or if an ocean restart file was writen at nitend - 1 74 81 IF( kt == nitrst - 1 .OR. nstock == 1 .OR. ( kt == nitend .AND. .NOT. lrst_oce ) ) THEN 75 ! beware of the format used to write kt (default is i8.8, that should be large enough...) 76 IF( nitrst > 999999999 ) THEN ; WRITE(clkt, * ) nitrst 77 ELSE ; WRITE(clkt, '(i8.8)') nitrst 78 ENDIF 79 ! create the file 80 clname = TRIM(cexper)//"_"//TRIM(ADJUSTL(clkt))//"_"//TRIM(cn_ocerst_out) 81 IF(lwp) THEN 82 WRITE(numout,*) 83 SELECT CASE ( jprstlib ) 84 CASE ( jprstdimg ) ; WRITE(numout,*) ' open ocean restart binary file: '//clname 85 CASE DEFAULT ; WRITE(numout,*) ' open ocean restart NetCDF file: '//clname 86 END SELECT 87 IF ( snc4set%luse ) WRITE(numout,*) ' opened for NetCDF4 chunking and compression' 88 IF( kt == nitrst - 1 ) THEN ; WRITE(numout,*) ' kt = nitrst - 1 = ', kt 89 ELSE ; WRITE(numout,*) ' kt = ' , kt 82 IF( nitrst <= nitend .AND. nitrst > 0 ) THEN 83 ! beware of the format used to write kt (default is i8.8, that should be large enough...) 84 IF( nitrst > 999999999 ) THEN ; WRITE(clkt, * ) nitrst 85 ELSE ; WRITE(clkt, '(i8.8)') nitrst 90 86 ENDIF 91 ENDIF 92 ! 93 CALL iom_open( clname, numrow, ldwrt = .TRUE., kiolib = jprstlib ) 94 lrst_oce = .TRUE. 87 ! create the file 88 clname = TRIM(cexper)//"_"//TRIM(ADJUSTL(clkt))//"_"//TRIM(cn_ocerst_out) 89 clpath = TRIM(cn_ocerst_outdir) 90 IF( clpath(LEN_TRIM(clpath):) /= '/' ) clpath = TRIM(clpath) // '/' 91 IF(lwp) THEN 92 WRITE(numout,*) 93 SELECT CASE ( jprstlib ) 94 CASE ( jprstdimg ) ; WRITE(numout,*) & 95 ' open ocean restart binary file: ',TRIM(clpath)//clname 96 CASE DEFAULT ; WRITE(numout,*) & 97 ' open ocean restart NetCDF file: ',TRIM(clpath)//clname 98 END SELECT 99 IF ( snc4set%luse ) WRITE(numout,*) ' opened for NetCDF4 chunking and compression' 100 IF( kt == nitrst - 1 ) THEN ; WRITE(numout,*) ' kt = nitrst - 1 = ', kt 101 ELSE ; WRITE(numout,*) ' kt = ' , kt 102 ENDIF 103 ENDIF 104 ! 105 CALL iom_open( TRIM(clpath)//TRIM(clname), numrow, ldwrt = .TRUE., kiolib = jprstlib ) 106 lrst_oce = .TRUE. 107 ENDIF 95 108 ENDIF 96 109 ! … … 120 133 CALL iom_rstput( kt, nitrst, numrow, 'hdivb' , hdivb ) 121 134 CALL iom_rstput( kt, nitrst, numrow, 'sshb' , sshb ) 122 IF( lk_lim3 ) CALL iom_rstput( kt, nitrst, numrow, 'fse3t_b', fse3t_b(:,:,:) )123 !124 IF( lk_lim3 ) CALL iom_rstput( kt, nitrst, numrow, 'fse3t_b', fse3t_b(:,:,:) )125 135 ! 126 136 CALL iom_rstput( kt, nitrst, numrow, 'un' , un ) ! now fields … … 135 145 CALL iom_rstput( kt, nitrst, numrow, 'rhd' , rhd ) 136 146 #endif 137 IF( lk_lim3 ) THEN138 CALL iom_rstput( kt, nitrst, numrow, 'fraqsr_1lev' , fraqsr_1lev ) !clem modif139 ENDIF140 147 IF( kt == nitrst ) THEN 141 148 CALL iom_close( numrow ) ! close the restart file (only at last time step) … … 143 150 !!gm not sure what to do here ===>>> ask to Sebastian 144 151 lrst_oce = .FALSE. 152 IF( ln_rst_list ) THEN 153 nrst_lst = MIN(nrst_lst + 1, SIZE(nstocklist,1)) 154 nitrst = nstocklist( nrst_lst ) 155 ENDIF 156 lrst_oce = .FALSE. 145 157 ENDIF 146 158 ! … … 157 169 !! the file has already been opened 158 170 !!---------------------------------------------------------------------- 159 INTEGER :: jlibalt = jprstlib 160 LOGICAL :: llok 171 INTEGER :: jlibalt = jprstlib 172 LOGICAL :: llok 173 CHARACTER(lc) :: clpath ! full path to ocean output restart file 161 174 !!---------------------------------------------------------------------- 162 175 ! … … 172 185 ENDIF 173 186 187 clpath = TRIM(cn_ocerst_indir) 188 IF( clpath(LEN_TRIM(clpath):) /= '/' ) clpath = TRIM(clpath) // '/' 174 189 IF ( jprstlib == jprstdimg ) THEN 175 190 ! eventually read netcdf file (monobloc) for restarting on different number of processors 176 191 ! if {cn_ocerst_in}.nc exists, then set jlibalt to jpnf90 177 INQUIRE( FILE = TRIM(cn_ocerst_in )//'.nc', EXIST = llok )192 INQUIRE( FILE = TRIM(cn_ocerst_indir)//'/'//TRIM(cn_ocerst_in)//'.nc', EXIST = llok ) 178 193 IF ( llok ) THEN ; jlibalt = jpnf90 ; ELSE ; jlibalt = jprstlib ; ENDIF 179 194 ENDIF 180 CALL iom_open( cn_ocerst_in, numror, kiolib = jlibalt )195 CALL iom_open( TRIM(clpath)//cn_ocerst_in, numror, kiolib = jlibalt ) 181 196 ENDIF 182 197 END SUBROUTINE rst_read_open … … 215 230 CALL iom_get( numror, jpdom_autoglo, 'hdivb' , hdivb ) 216 231 CALL iom_get( numror, jpdom_autoglo, 'sshb' , sshb ) 217 IF( lk_lim3 ) CALL iom_get( numror, jpdom_autoglo, 'fse3t_b', fse3t_b(:,:,:) )218 232 ELSE 219 233 neuler = 0 … … 258 272 ENDIF 259 273 260 IF( lk_lim3 .AND. .NOT. lk_vvl ) THEN261 DO jk = 1, jpk262 fse3t_b(:,:,jk) = fse3t_n(:,:,jk)263 END DO264 ENDIF265 266 ENDIF267 !268 IF( lk_lim3 ) THEN269 CALL iom_get( numror, jpdom_autoglo, 'fraqsr_1lev' , fraqsr_1lev )270 274 ENDIF 271 275 ! -
branches/2014/dev_r4621_NOC4_BDY_VERT_INTERP/NEMOGCM/NEMO/OPA_SRC/LBC/lbclnk.F90
r5038 r5620 22 22 USE lib_mpp ! distributed memory computing library 23 23 24 25 INTERFACE lbc_lnk_multi 26 MODULE PROCEDURE mpp_lnk_2d_9 27 END INTERFACE 28 24 29 INTERFACE lbc_lnk 25 30 MODULE PROCEDURE mpp_lnk_3d_gather, mpp_lnk_3d, mpp_lnk_2d … … 39 44 40 45 PUBLIC lbc_lnk ! ocean lateral boundary conditions 46 PUBLIC lbc_lnk_multi ! modified ocean lateral boundary conditions 41 47 PUBLIC lbc_lnk_e 42 48 PUBLIC lbc_bdy_lnk ! ocean lateral BDY boundary conditions -
branches/2014/dev_r4621_NOC4_BDY_VERT_INTERP/NEMOGCM/NEMO/OPA_SRC/LBC/lib_mpp.F90
r5038 r5620 71 71 PUBLIC mpp_min, mpp_max, mpp_sum, mpp_minloc, mpp_maxloc 72 72 PUBLIC mpp_lnk_3d, mpp_lnk_3d_gather, mpp_lnk_2d, mpp_lnk_2d_e 73 PUBLIC mpp_lnk_2d_9 73 74 PUBLIC mppscatter, mppgather 74 75 PUBLIC mpp_ini_ice, mpp_ini_znl … … 78 79 PUBLIC mpp_lbc_north_icb, mpp_lnk_2d_icb 79 80 81 TYPE arrayptr 82 REAL , DIMENSION (:,:), POINTER :: pt2d 83 END TYPE arrayptr 84 80 85 !! * Interfaces 81 86 !! define generic interface for these routine as they are called sometimes … … 164 169 165 170 166 FUNCTION mynode( ldtxt, kumnam_ref , kumnam_cfg , kumond , kstop, localComm )171 FUNCTION mynode( ldtxt, ldname, kumnam_ref , kumnam_cfg , kumond , kstop, localComm ) 167 172 !!---------------------------------------------------------------------- 168 173 !! *** routine mynode *** … … 171 176 !!---------------------------------------------------------------------- 172 177 CHARACTER(len=*),DIMENSION(:), INTENT( out) :: ldtxt 178 CHARACTER(len=*) , INTENT(in ) :: ldname 173 179 INTEGER , INTENT(in ) :: kumnam_ref ! logical unit for reference namelist 174 180 INTEGER , INTENT(in ) :: kumnam_cfg ! logical unit for configuration namelist … … 297 303 298 304 IF( mynode == 0 ) THEN 299 CALL ctl_opn( kumond, 'output.namelist.dyn', 'UNKNOWN', 'FORMATTED', 'SEQUENTIAL', -1, 6, .FALSE. , 1 )300 WRITE(kumond, nammpp)305 CALL ctl_opn( kumond, TRIM(ldname), 'UNKNOWN', 'FORMATTED', 'SEQUENTIAL', -1, 6, .FALSE. , 1 ) 306 WRITE(kumond, nammpp) 301 307 ENDIF 302 308 ! … … 510 516 ! 511 517 END SUBROUTINE mpp_lnk_3d 518 519 SUBROUTINE mpp_lnk_2d_multiple( pt2d_array , type_array , psgn_array , num_fields , cd_mpp, pval ) 520 !!---------------------------------------------------------------------- 521 !! *** routine mpp_lnk_2d_multiple *** 522 !! 523 !! ** Purpose : Message passing management for multiple 2d arrays 524 !! 525 !! ** Method : Use mppsend and mpprecv function for passing mask 526 !! between processors following neighboring subdomains. 527 !! domain parameters 528 !! nlci : first dimension of the local subdomain 529 !! nlcj : second dimension of the local subdomain 530 !! nbondi : mark for "east-west local boundary" 531 !! nbondj : mark for "north-south local boundary" 532 !! noea : number for local neighboring processors 533 !! nowe : number for local neighboring processors 534 !! noso : number for local neighboring processors 535 !! nono : number for local neighboring processors 536 !! 537 !!---------------------------------------------------------------------- 538 539 INTEGER :: num_fields 540 TYPE( arrayptr ), DIMENSION(:) :: pt2d_array 541 CHARACTER(len=1), DIMENSION(:), INTENT(in ) :: type_array ! define the nature of ptab array grid-points 542 ! ! = T , U , V , F , W and I points 543 REAL(wp) , DIMENSION(:), INTENT(in ) :: psgn_array ! =-1 the sign change across the north fold boundary 544 ! ! = 1. , the sign is kept 545 CHARACTER(len=3), OPTIONAL , INTENT(in ) :: cd_mpp ! fill the overlap area only 546 REAL(wp) , OPTIONAL , INTENT(in ) :: pval ! background value (used at closed boundaries) 547 !! 548 INTEGER :: ji, jj, jl ! dummy loop indices 549 INTEGER :: ii !!MULTI SEND DUMMY LOOP INDICES 550 INTEGER :: imigr, iihom, ijhom ! temporary integers 551 INTEGER :: ml_req1, ml_req2, ml_err ! for key_mpi_isend 552 553 REAL(wp) :: zland 554 INTEGER, DIMENSION(MPI_STATUS_SIZE) :: ml_stat ! for key_mpi_isend 555 ! 556 REAL(wp), DIMENSION(:,:,:), ALLOCATABLE :: zt2ns, zt2sn ! 2d for north-south & south-north 557 REAL(wp), DIMENSION(:,:,:), ALLOCATABLE :: zt2ew, zt2we ! 2d for east-west & west-east 558 559 !!---------------------------------------------------------------------- 560 561 ALLOCATE( zt2ns(jpi,jprecj,2*num_fields), zt2sn(jpi,jprecj,2*num_fields), & 562 & zt2ew(jpj,jpreci,2*num_fields), zt2we(jpj,jpreci,2*num_fields) ) 563 564 ! 565 IF( PRESENT( pval ) ) THEN ; zland = pval ! set land value 566 ELSE ; zland = 0.e0 ! zero by default 567 ENDIF 568 569 ! 1. standard boundary treatment 570 ! ------------------------------ 571 ! 572 !First Array 573 DO ii = 1 , num_fields 574 IF( PRESENT( cd_mpp ) ) THEN ! only fill added line/raw with existing values 575 ! 576 ! WARNING pt2d is defined only between nld and nle 577 DO jj = nlcj+1, jpj ! added line(s) (inner only) 578 pt2d_array(ii)%pt2d(nldi :nlei , jj) = pt2d_array(ii)%pt2d(nldi:nlei, nlej) 579 pt2d_array(ii)%pt2d(1 :nldi-1, jj) = pt2d_array(ii)%pt2d(nldi , nlej) 580 pt2d_array(ii)%pt2d(nlei+1:nlci , jj) = pt2d_array(ii)%pt2d( nlei, nlej) 581 END DO 582 DO ji = nlci+1, jpi ! added column(s) (full) 583 pt2d_array(ii)%pt2d(ji, nldj :nlej ) = pt2d_array(ii)%pt2d(nlei, nldj:nlej) 584 pt2d_array(ii)%pt2d(ji, 1 :nldj-1) = pt2d_array(ii)%pt2d(nlei, nldj ) 585 pt2d_array(ii)%pt2d(ji, nlej+1:jpj ) = pt2d_array(ii)%pt2d(nlei, nlej) 586 END DO 587 ! 588 ELSE ! standard close or cyclic treatment 589 ! 590 ! ! East-West boundaries 591 IF( nbondi == 2 .AND. & ! Cyclic east-west 592 & (nperio == 1 .OR. nperio == 4 .OR. nperio == 6) ) THEN 593 pt2d_array(ii)%pt2d( 1 , : ) = pt2d_array(ii)%pt2d( jpim1, : ) ! west 594 pt2d_array(ii)%pt2d( jpi , : ) = pt2d_array(ii)%pt2d( 2 , : ) ! east 595 ELSE ! closed 596 IF( .NOT. type_array(ii) == 'F' ) pt2d_array(ii)%pt2d( 1 : jpreci,:) = zland ! south except F-point 597 pt2d_array(ii)%pt2d(nlci-jpreci+1 : jpi ,:) = zland ! north 598 ENDIF 599 ! ! North-South boundaries (always closed) 600 IF( .NOT. type_array(ii) == 'F' ) pt2d_array(ii)%pt2d(:, 1:jprecj ) = zland ! south except F-point 601 pt2d_array(ii)%pt2d(:, nlcj-jprecj+1:jpj ) = zland ! north 602 ! 603 ENDIF 604 END DO 605 606 ! 2. East and west directions exchange 607 ! ------------------------------------ 608 ! we play with the neigbours AND the row number because of the periodicity 609 ! 610 DO ii = 1 , num_fields 611 SELECT CASE ( nbondi ) ! Read Dirichlet lateral conditions 612 CASE ( -1, 0, 1 ) ! all exept 2 (i.e. close case) 613 iihom = nlci-nreci 614 DO jl = 1, jpreci 615 zt2ew( : , jl , ii ) = pt2d_array(ii)%pt2d( jpreci+jl , : ) 616 zt2we( : , jl , ii ) = pt2d_array(ii)%pt2d( iihom +jl , : ) 617 END DO 618 END SELECT 619 END DO 620 ! 621 ! ! Migrations 622 imigr = jpreci * jpj 623 ! 624 SELECT CASE ( nbondi ) 625 CASE ( -1 ) 626 CALL mppsend( 2, zt2we(1,1,1), num_fields*imigr, noea, ml_req1 ) 627 CALL mpprecv( 1, zt2ew(1,1,num_fields+1), num_fields*imigr, noea ) 628 IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err) 629 CASE ( 0 ) 630 CALL mppsend( 1, zt2ew(1,1,1), num_fields*imigr, nowe, ml_req1 ) 631 CALL mppsend( 2, zt2we(1,1,1), num_fields*imigr, noea, ml_req2 ) 632 CALL mpprecv( 1, zt2ew(1,1,num_fields+1), num_fields*imigr, noea ) 633 CALL mpprecv( 2, zt2we(1,1,num_fields+1), num_fields*imigr, nowe ) 634 IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err) 635 IF(l_isend) CALL mpi_wait(ml_req2,ml_stat,ml_err) 636 CASE ( 1 ) 637 CALL mppsend( 1, zt2ew(1,1,1), num_fields*imigr, nowe, ml_req1 ) 638 CALL mpprecv( 2, zt2we(1,1,num_fields+1), num_fields*imigr, nowe ) 639 IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err) 640 END SELECT 641 ! 642 ! ! Write Dirichlet lateral conditions 643 iihom = nlci - jpreci 644 ! 645 646 DO ii = 1 , num_fields 647 SELECT CASE ( nbondi ) 648 CASE ( -1 ) 649 DO jl = 1, jpreci 650 pt2d_array(ii)%pt2d( iihom+jl , : ) = zt2ew(:,jl,num_fields+ii) 651 END DO 652 CASE ( 0 ) 653 DO jl = 1, jpreci 654 pt2d_array(ii)%pt2d( jl , : ) = zt2we(:,jl,num_fields+ii) 655 pt2d_array(ii)%pt2d( iihom+jl , : ) = zt2ew(:,jl,num_fields+ii) 656 END DO 657 CASE ( 1 ) 658 DO jl = 1, jpreci 659 pt2d_array(ii)%pt2d( jl , : )= zt2we(:,jl,num_fields+ii) 660 END DO 661 END SELECT 662 END DO 663 664 ! 3. North and south directions 665 ! ----------------------------- 666 ! always closed : we play only with the neigbours 667 ! 668 !First Array 669 DO ii = 1 , num_fields 670 IF( nbondj /= 2 ) THEN ! Read Dirichlet lateral conditions 671 ijhom = nlcj-nrecj 672 DO jl = 1, jprecj 673 zt2sn(:,jl , ii) = pt2d_array(ii)%pt2d( : , ijhom +jl ) 674 zt2ns(:,jl , ii) = pt2d_array(ii)%pt2d( : , jprecj+jl ) 675 END DO 676 ENDIF 677 END DO 678 ! 679 ! ! Migrations 680 imigr = jprecj * jpi 681 ! 682 SELECT CASE ( nbondj ) 683 CASE ( -1 ) 684 CALL mppsend( 4, zt2sn(1,1,1), num_fields*imigr, nono, ml_req1 ) 685 CALL mpprecv( 3, zt2ns(1,1,num_fields+1), num_fields*imigr, nono ) 686 IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err) 687 CASE ( 0 ) 688 CALL mppsend( 3, zt2ns(1,1,1), num_fields*imigr, noso, ml_req1 ) 689 CALL mppsend( 4, zt2sn(1,1,1), num_fields*imigr, nono, ml_req2 ) 690 CALL mpprecv( 3, zt2ns(1,1,num_fields+1), num_fields*imigr, nono ) 691 CALL mpprecv( 4, zt2sn(1,1,num_fields+1), num_fields*imigr, noso ) 692 IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err) 693 IF(l_isend) CALL mpi_wait(ml_req2,ml_stat,ml_err) 694 CASE ( 1 ) 695 CALL mppsend( 3, zt2ns(1,1,1), num_fields*imigr, noso, ml_req1 ) 696 CALL mpprecv( 4, zt2sn(1,1,num_fields+1), num_fields*imigr, noso ) 697 IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err) 698 END SELECT 699 ! 700 ! ! Write Dirichlet lateral conditions 701 ijhom = nlcj - jprecj 702 ! 703 704 DO ii = 1 , num_fields 705 !First Array 706 SELECT CASE ( nbondj ) 707 CASE ( -1 ) 708 DO jl = 1, jprecj 709 pt2d_array(ii)%pt2d( : , ijhom+jl ) = zt2ns( : , jl , num_fields+ii ) 710 END DO 711 CASE ( 0 ) 712 DO jl = 1, jprecj 713 pt2d_array(ii)%pt2d( : , jl ) = zt2sn( : , jl , num_fields + ii) 714 pt2d_array(ii)%pt2d( : , ijhom + jl ) = zt2ns( : , jl , num_fields + ii ) 715 END DO 716 CASE ( 1 ) 717 DO jl = 1, jprecj 718 pt2d_array(ii)%pt2d( : , jl ) = zt2sn( : , jl , num_fields + ii ) 719 END DO 720 END SELECT 721 END DO 722 723 ! 4. north fold treatment 724 ! ----------------------- 725 ! 726 DO ii = 1 , num_fields 727 !First Array 728 IF( npolj /= 0 .AND. .NOT. PRESENT(cd_mpp) ) THEN 729 ! 730 SELECT CASE ( jpni ) 731 CASE ( 1 ) ; CALL lbc_nfd ( pt2d_array(ii)%pt2d( : , : ), type_array(ii) , psgn_array(ii) ) ! only 1 northern proc, no mpp 732 CASE DEFAULT ; CALL mpp_lbc_north( pt2d_array(ii)%pt2d( : , : ), type_array(ii), psgn_array(ii) ) ! for all northern procs. 733 END SELECT 734 ! 735 ENDIF 736 ! 737 END DO 738 739 DEALLOCATE( zt2ns, zt2sn, zt2ew, zt2we ) 740 ! 741 END SUBROUTINE mpp_lnk_2d_multiple 742 743 744 SUBROUTINE load_array(pt2d,cd_type,psgn,pt2d_array, type_array, psgn_array,num_fields) 745 !!--------------------------------------------------------------------- 746 REAL(wp), DIMENSION(jpi,jpj), TARGET , INTENT(inout) :: pt2d ! Second 2D array on which the boundary condition is applied 747 CHARACTER(len=1) , INTENT(in ) :: cd_type ! define the nature of ptab array grid-points 748 REAL(wp) , INTENT(in ) :: psgn ! =-1 the sign change across the north fold boundary 749 TYPE(arrayptr) , DIMENSION(9) :: pt2d_array 750 CHARACTER(len=1) , DIMENSION(9) :: type_array ! define the nature of ptab array grid-points 751 REAL(wp) , DIMENSION(9) :: psgn_array ! =-1 the sign change across the north fold boundary 752 INTEGER , INTENT (inout):: num_fields 753 !!--------------------------------------------------------------------- 754 num_fields=num_fields+1 755 pt2d_array(num_fields)%pt2d=>pt2d 756 type_array(num_fields)=cd_type 757 psgn_array(num_fields)=psgn 758 END SUBROUTINE load_array 759 760 761 SUBROUTINE mpp_lnk_2d_9( pt2dA, cd_typeA, psgnA, pt2dB, cd_typeB, psgnB, pt2dC, cd_typeC, psgnC & 762 & , pt2dD, cd_typeD, psgnD, pt2dE, cd_typeE, psgnE, pt2dF, cd_typeF, psgnF & 763 & , pt2dG, cd_typeG, psgnG, pt2dH, cd_typeH, psgnH, pt2dI, cd_typeI, psgnI, cd_mpp, pval) 764 !!--------------------------------------------------------------------- 765 ! Second 2D array on which the boundary condition is applied 766 REAL(wp), DIMENSION(jpi,jpj), TARGET , INTENT(inout) :: pt2dA 767 REAL(wp), DIMENSION(jpi,jpj), TARGET, OPTIONAL, INTENT(inout) :: pt2dB , pt2dC , pt2dD , pt2dE 768 REAL(wp), DIMENSION(jpi,jpj), TARGET, OPTIONAL, INTENT(inout) :: pt2dF , pt2dG , pt2dH , pt2dI 769 ! define the nature of ptab array grid-points 770 CHARACTER(len=1) , INTENT(in ) :: cd_typeA 771 CHARACTER(len=1) , OPTIONAL, INTENT(in ) :: cd_typeB , cd_typeC , cd_typeD , cd_typeE 772 CHARACTER(len=1) , OPTIONAL, INTENT(in ) :: cd_typeF , cd_typeG , cd_typeH , cd_typeI 773 ! =-1 the sign change across the north fold boundary 774 REAL(wp) , INTENT(in ) :: psgnA 775 REAL(wp) , OPTIONAL, INTENT(in ) :: psgnB , psgnC , psgnD , psgnE 776 REAL(wp) , OPTIONAL, INTENT(in ) :: psgnF , psgnG , psgnH , psgnI 777 CHARACTER(len=3) , OPTIONAL, INTENT(in ) :: cd_mpp ! fill the overlap area only 778 REAL(wp) , OPTIONAL, INTENT(in ) :: pval ! background value (used at closed boundaries) 779 !! 780 TYPE(arrayptr) , DIMENSION(9) :: pt2d_array 781 CHARACTER(len=1) , DIMENSION(9) :: type_array ! define the nature of ptab array grid-points 782 ! ! = T , U , V , F , W and I points 783 REAL(wp) , DIMENSION(9) :: psgn_array ! =-1 the sign change across the north fold boundary 784 INTEGER :: num_fields 785 !!--------------------------------------------------------------------- 786 787 num_fields = 0 788 789 !! Load the first array 790 CALL load_array(pt2dA,cd_typeA,psgnA,pt2d_array, type_array, psgn_array,num_fields) 791 792 !! Look if more arrays are added 793 IF(PRESENT (psgnB) )CALL load_array(pt2dB,cd_typeB,psgnB,pt2d_array, type_array, psgn_array,num_fields) 794 IF(PRESENT (psgnC) )CALL load_array(pt2dC,cd_typeC,psgnC,pt2d_array, type_array, psgn_array,num_fields) 795 IF(PRESENT (psgnD) )CALL load_array(pt2dD,cd_typeD,psgnD,pt2d_array, type_array, psgn_array,num_fields) 796 IF(PRESENT (psgnE) )CALL load_array(pt2dE,cd_typeE,psgnE,pt2d_array, type_array, psgn_array,num_fields) 797 IF(PRESENT (psgnF) )CALL load_array(pt2dF,cd_typeF,psgnF,pt2d_array, type_array, psgn_array,num_fields) 798 IF(PRESENT (psgnG) )CALL load_array(pt2dG,cd_typeG,psgnG,pt2d_array, type_array, psgn_array,num_fields) 799 IF(PRESENT (psgnH) )CALL load_array(pt2dH,cd_typeH,psgnH,pt2d_array, type_array, psgn_array,num_fields) 800 IF(PRESENT (psgnI) )CALL load_array(pt2dI,cd_typeI,psgnI,pt2d_array, type_array, psgn_array,num_fields) 801 802 CALL mpp_lnk_2d_multiple(pt2d_array,type_array,psgn_array,num_fields,cd_mpp,pval) 803 END SUBROUTINE mpp_lnk_2d_9 512 804 513 805 … … 3184 3476 LOGICAL, PUBLIC :: ln_nnogather !: namelist control of northfold comms (needed here in case "key_mpp_mpi" is not used) 3185 3477 INTEGER :: ncomm_ice 3478 INTEGER, PUBLIC :: mpi_comm_opa ! opa local communicator 3186 3479 !!---------------------------------------------------------------------- 3187 3480 CONTAINS … … 3192 3485 END FUNCTION lib_mpp_alloc 3193 3486 3194 FUNCTION mynode( ldtxt, kumnam_ref, knumnam_cfg, kumond , kstop, localComm ) RESULT (function_value)3487 FUNCTION mynode( ldtxt, ldname, kumnam_ref, knumnam_cfg, kumond , kstop, localComm ) RESULT (function_value) 3195 3488 INTEGER, OPTIONAL , INTENT(in ) :: localComm 3196 3489 CHARACTER(len=*),DIMENSION(:) :: ldtxt 3490 CHARACTER(len=*) :: ldname 3197 3491 INTEGER :: kumnam_ref, knumnam_cfg , kumond , kstop 3198 IF( PRESENT( localComm ) .OR. .NOT.PRESENT( localComm ) ) function_value = 0 3492 IF( PRESENT( localComm ) ) mpi_comm_opa = localComm 3493 function_value = 0 3199 3494 IF( .FALSE. ) ldtxt(:) = 'never done' 3200 CALL ctl_opn( kumond, 'output.namelist.dyn', 'UNKNOWN', 'FORMATTED', 'SEQUENTIAL', -1, 6, .FALSE. , 1 )3495 CALL ctl_opn( kumond, TRIM(ldname), 'UNKNOWN', 'FORMATTED', 'SEQUENTIAL', -1, 6, .FALSE. , 1 ) 3201 3496 END FUNCTION mynode 3202 3497 -
branches/2014/dev_r4621_NOC4_BDY_VERT_INTERP/NEMOGCM/NEMO/OPA_SRC/LBC/mppini_2.h90
r5038 r5620 45 45 INTEGER :: inum ! temporary logical unit 46 46 INTEGER :: idir ! temporary integers 47 INTEGER :: jstartrow ! temporary integers 47 48 INTEGER :: ios ! Local integer output status for namelist read 48 49 INTEGER :: & … … 100 101 ! open the file 101 102 ! Remember that at this level in the code, mpp is not yet initialized, so 102 ! the file must be open with jpdom_unknown, and kstart amd kcount forced 103 ! the file must be open with jpdom_unknown, and kstart and kcount forced 104 jstartrow = 1 103 105 IF ( ln_zco ) THEN 104 106 CALL iom_open ( 'bathy_level.nc', inum ) ! Level bathymetry 105 CALL iom_get ( inum, jpdom_unknown, 'Bathy_level', zdta, kstart=(/jpizoom,jpjzoom/), kcount=(/jpiglo,jpjglo/) ) 107 ! Optionally use a file attribute (open_ocean_jstart) to set a start row for reading from the global file 108 ! This allows the unextended grid bathymetry to be stored in the same file as the under ice-shelf extended bathymetry 109 CALL iom_getatt(inum, 'open_ocean_jstart', jstartrow ) ! -999 is returned if the attribute is not found 110 jstartrow = MAX(1,jstartrow) 111 CALL iom_get ( inum, jpdom_unknown, 'Bathy_level', zdta, kstart=(/jpizoom,jpjzoom+jstartrow-1/), kcount=(/jpiglo,jpjglo/) ) 106 112 ELSE 107 113 CALL iom_open ( 'bathy_meter.nc', inum ) ! Meter bathy in case of partial steps 108 CALL iom_get ( inum, jpdom_unknown, 'Bathymetry' , zdta, kstart=(/jpizoom,jpjzoom/), kcount=(/jpiglo,jpjglo/) ) 114 IF ( ln_isfcav ) THEN 115 CALL iom_get ( inum, jpdom_unknown, 'Bathymetry_isf' , zdta, kstart=(/jpizoom,jpjzoom/), kcount=(/jpiglo,jpjglo/) ) 116 ELSE 117 ! Optionally use a file attribute (open_ocean_jstart) to set a start row for reading from the global file 118 ! This allows the unextended grid bathymetry to be stored in the same file as the under ice-shelf extended bathymetry 119 CALL iom_getatt(inum, 'open_ocean_jstart', jstartrow ) ! -999 is returned if the attribute is not found 120 jstartrow = MAX(1,jstartrow) 121 CALL iom_get ( inum, jpdom_unknown, 'Bathymetry' , zdta, kstart=(/jpizoom,jpjzoom+jstartrow-1/) & 122 & , kcount=(/jpiglo,jpjglo/) ) 123 ENDIF 109 124 ENDIF 110 125 CALL iom_close (inum) -
branches/2014/dev_r4621_NOC4_BDY_VERT_INTERP/NEMOGCM/NEMO/OPA_SRC/LDF/ldfdyn_c2d.h90
r4325 r5620 140 140 !!---------------------------------------------------------------------- 141 141 USE ldftra_oce, ONLY: aht0 142 USE iom 142 143 ! 143 144 LOGICAL, INTENT (in) :: ld_print ! If true, output arrays on numout … … 146 147 INTEGER :: inum, iim, ijm ! local integers 147 148 INTEGER :: ifreq, il1, il2, ij, ii 148 INTEGER :: ijpt0,ijpt1 149 INTEGER :: ijpt0,ijpt1, ierror 149 150 REAL(wp) :: zahmeq, zcoft, zcoff, zmsk 150 151 CHARACTER (len=15) :: clexp 151 INTEGER, POINTER, DIMENSION(:,:) :: icof152 INTEGER, POINTER, DIMENSION(:,:) :: idata152 INTEGER, POINTER, DIMENSION(:,:) :: icof 153 REAL(wp), DIMENSION(:,:), ALLOCATABLE :: ztemp2d ! temporary array to read ahmcoef file 153 154 !!---------------------------------------------------------------------- 154 155 ! 155 156 CALL wrk_alloc( jpi , jpj , icof ) 156 CALL wrk_alloc( jpidta, jpjdta, idata )157 157 ! 158 158 IF(lwp) WRITE(numout,*) … … 233 233 ! Read 2d integer array to specify western boundary increase in the 234 234 ! ===================== equatorial strip (20N-20S) defined at t-points 235 236 CALL ctl_opn( inum, 'ahmcoef', 'OLD', 'FORMATTED', 'SEQUENTIAL', -1, numout, lwp ) 237 READ(inum,9101) clexp, iim, ijm 238 READ(inum,'(/)') 239 ifreq = 40 240 il1 = 1 241 DO jn = 1, jpidta/ifreq+1 242 READ(inum,'(/)') 243 il2 = MIN( jpidta, il1+ifreq-1 ) 244 READ(inum,9201) ( ii, ji = il1, il2, 5 ) 245 READ(inum,'(/)') 246 DO jj = jpjdta, 1, -1 247 READ(inum,9202) ij, ( idata(ji,jj), ji = il1, il2 ) 248 END DO 249 il1 = il1 + ifreq 250 END DO 251 252 DO jj = 1, nlcj 253 DO ji = 1, nlci 254 icof(ji,jj) = idata( mig(ji), mjg(jj) ) 255 END DO 256 END DO 257 DO jj = nlcj+1, jpj 258 DO ji = 1, nlci 259 icof(ji,jj) = icof(ji,nlcj) 260 END DO 261 END DO 262 DO jj = 1, jpj 263 DO ji = nlci+1, jpi 264 icof(ji,jj) = icof(nlci,jj) 265 END DO 266 END DO 267 268 9101 FORMAT(1x,a15,2i8) 269 9201 FORMAT(3x,13(i3,12x)) 270 9202 FORMAT(i3,41i3) 271 235 ! 236 ALLOCATE( ztemp2d(jpi,jpj) ) 237 ztemp2d(:,:) = 0. 238 CALL iom_open ( 'ahmcoef.nc', inum ) 239 CALL iom_get ( inum, jpdom_data, 'icof', ztemp2d) 240 icof(:,:) = NINT(ztemp2d(:,:)) 241 CALL iom_close( inum ) 242 DEALLOCATE(ztemp2d) 272 243 273 244 ! Set ahm1 and ahm2 ( T- and F- points) (used for laplacian operator) … … 346 317 ! 347 318 CALL wrk_dealloc( jpi , jpj , icof ) 348 CALL wrk_dealloc( jpidta, jpjdta, idata )349 319 ! 350 320 END SUBROUTINE ldf_dyn_c2d_orca … … 367 337 !!---------------------------------------------------------------------- 368 338 USE ldftra_oce, ONLY: aht0 339 USE iom 369 340 ! 370 341 LOGICAL, INTENT (in) :: ld_print ! If true, output arrays on numout … … 374 345 INTEGER :: iim, ijm 375 346 INTEGER :: ifreq, il1, il2, ij, ii 376 INTEGER :: ijpt0,ijpt1 347 INTEGER :: ijpt0,ijpt1, ierror 377 348 REAL(wp) :: zahmeq, zcoft, zcoff, zmsk, zam20s 378 349 CHARACTER (len=15) :: clexp 379 INTEGER, POINTER, DIMENSION(:,:) :: icof380 INTEGER, POINTER, DIMENSION(:,:) :: idata350 INTEGER, POINTER, DIMENSION(:,:) :: icof 351 REAL(wp), DIMENSION(:,:), ALLOCATABLE :: ztemp2d ! temporary array to read ahmcoef file 381 352 !!---------------------------------------------------------------------- 382 353 ! 383 354 CALL wrk_alloc( jpi , jpj , icof ) 384 CALL wrk_alloc( jpidta, jpjdta, idata )385 355 ! 386 387 356 IF(lwp) WRITE(numout,*) 388 357 IF(lwp) WRITE(numout,*) 'inildf: 2d eddy viscosity coefficient' … … 463 432 ! Read 2d integer array to specify western boundary increase in the 464 433 ! ===================== equatorial strip (20N-20S) defined at t-points 465 466 CALL ctl_opn( inum, 'ahmcoef', 'UNKNOWN', 'FORMATTED', 'SEQUENTIAL', & 467 & 1, numout, lwp ) 468 REWIND inum 469 READ(inum,9101) clexp, iim, ijm 470 READ(inum,'(/)') 471 ifreq = 40 472 il1 = 1 473 DO jn = 1, jpidta/ifreq+1 474 READ(inum,'(/)') 475 il2 = MIN( jpidta, il1+ifreq-1 ) 476 READ(inum,9201) ( ii, ji = il1, il2, 5 ) 477 READ(inum,'(/)') 478 DO jj = jpjdta, 1, -1 479 READ(inum,9202) ij, ( idata(ji,jj), ji = il1, il2 ) 480 END DO 481 il1 = il1 + ifreq 482 END DO 483 484 DO jj = 1, nlcj 485 DO ji = 1, nlci 486 icof(ji,jj) = idata( mig(ji), mjg(jj) ) 487 END DO 488 END DO 489 DO jj = nlcj+1, jpj 490 DO ji = 1, nlci 491 icof(ji,jj) = icof(ji,nlcj) 492 END DO 493 END DO 494 DO jj = 1, jpj 495 DO ji = nlci+1, jpi 496 icof(ji,jj) = icof(nlci,jj) 497 END DO 498 END DO 499 500 9101 FORMAT(1x,a15,2i8) 501 9201 FORMAT(3x,13(i3,12x)) 502 9202 FORMAT(i3,41i3) 503 434 ALLOCATE( ztemp2d(jpi,jpj) ) 435 ztemp2d(:,:) = 0. 436 CALL iom_open ( 'ahmcoef.nc', inum ) 437 CALL iom_get ( inum, jpdom_data, 'icof', ztemp2d) 438 icof(:,:) = NINT(ztemp2d(:,:)) 439 CALL iom_close( inum ) 440 DEALLOCATE(ztemp2d) 504 441 505 442 ! Set ahm1 and ahm2 ( T- and F- points) (used for laplacian operator) … … 583 520 ! 584 521 CALL wrk_dealloc( jpi , jpj , icof ) 585 CALL wrk_dealloc( jpidta, jpjdta, idata )586 522 ! 587 523 END SUBROUTINE ldf_dyn_c2d_orca_R1 -
branches/2014/dev_r4621_NOC4_BDY_VERT_INTERP/NEMOGCM/NEMO/OPA_SRC/LDF/ldfdyn_c3d.h90
r4292 r5620 27 27 !!---------------------------------------------------------------------- 28 28 USE ldftra_oce, ONLY : aht0 29 USE iom 29 30 !! 30 31 LOGICAL, INTENT (in) :: ld_print ! If true, output arrays on numout … … 193 194 !!---------------------------------------------------------------------- 194 195 USE ldftra_oce, ONLY: aht0 196 USE iom 195 197 !! 196 198 LOGICAL, INTENT(in) :: ld_print ! If true, output arrays on numout … … 204 206 CHARACTER (len=15) :: clexp 205 207 INTEGER , POINTER, DIMENSION(:,:) :: icof 206 INTEGER , POINTER, DIMENSION(:,:) :: idata207 208 REAL(wp), POINTER, DIMENSION(: ) :: zcoef 208 209 REAL(wp), POINTER, DIMENSION(:,:) :: zahm0 210 ! 211 REAL(wp), DIMENSION(:,:), ALLOCATABLE :: ztemp2d ! temporary array to read ahmcoef file 209 212 !!---------------------------------------------------------------------- 210 213 ! 211 214 CALL wrk_alloc( jpi , jpj , icof ) 212 CALL wrk_alloc( jpidta, jpjdta, idata )213 215 CALL wrk_alloc( jpk , zcoef ) 214 216 CALL wrk_alloc( jpi , jpj , zahm0 ) … … 221 223 ! Read 2d integer array to specify western boundary increase in the 222 224 ! ===================== equatorial strip (20N-20S) defined at t-points 223 224 CALL ctl_opn( inum, 'ahmcoef', 'OLD', 'FORMATTED', 'SEQUENTIAL', -1, numout, lwp ) 225 READ(inum,9101) clexp, iim, ijm 226 READ(inum,'(/)') 227 ifreq = 40 228 il1 = 1 229 DO jn = 1, jpidta/ifreq+1 230 READ(inum,'(/)') 231 il2 = MIN( jpidta, il1+ifreq-1 ) 232 READ(inum,9201) ( ii, ji = il1, il2, 5 ) 233 READ(inum,'(/)') 234 DO jj = jpjdta, 1, -1 235 READ(inum,9202) ij, ( idata(ji,jj), ji = il1, il2 ) 236 END DO 237 il1 = il1 + ifreq 238 END DO 239 240 DO jj = 1, nlcj 241 DO ji = 1, nlci 242 icof(ji,jj) = idata( mig(ji), mjg(jj) ) 243 END DO 244 END DO 245 DO jj = nlcj+1, jpj 246 DO ji = 1, nlci 247 icof(ji,jj) = icof(ji,nlcj) 248 END DO 249 END DO 250 DO jj = 1, jpj 251 DO ji = nlci+1, jpi 252 icof(ji,jj) = icof(nlci,jj) 253 END DO 254 END DO 255 256 9101 FORMAT(1x,a15,2i8) 257 9201 FORMAT(3x,13(i3,12x)) 258 9202 FORMAT(i3,41i3) 259 225 ALLOCATE( ztemp2d(jpi,jpj) ) 226 ztemp2d(:,:) = 0. 227 CALL iom_open ( 'ahmcoef.nc', inum ) 228 CALL iom_get ( inum, jpdom_data, 'icof', ztemp2d) 229 icof(:,:) = NINT(ztemp2d(:,:)) 230 CALL iom_close( inum ) 231 DEALLOCATE(ztemp2d) 232 260 233 ! Set ahm1 and ahm2 261 234 ! ================= … … 455 428 ! 456 429 CALL wrk_dealloc( jpi , jpj , icof ) 457 CALL wrk_dealloc( jpidta, jpjdta, idata )458 430 CALL wrk_dealloc( jpk , zcoef ) 459 431 CALL wrk_dealloc( jpi , jpj , zahm0 ) -
branches/2014/dev_r4621_NOC4_BDY_VERT_INTERP/NEMOGCM/NEMO/OPA_SRC/LDF/ldfdyn_smag.F90
- Property svn:keywords set to Id
r3634 r5620 31 31 !!---------------------------------------------------------------------- 32 32 !! OPA 9.0 , LOCEAN-IPSL (2005) 33 !! $Id : ldf_tra_smag.F90 1482 2010-06-13 15:28:06Z$33 !! $Id$ 34 34 !! This software is governed by the CeCILL licence see modipsl/doc/NEMO_CeCILL.txt 35 35 !!---------------------------------------------------------------------- … … 51 51 !!---------------------------------------------------------------------- 52 52 !! OPA 9.0 , LOCEAN-IPSL (2005) 53 !! $Id : ldfdyn_c3d.h90 1581 2009-08-05 14:53:12Z smasson$53 !! $Id$ 54 54 !! This software is governed by the CeCILL licence see modipsl/doc/NEMO_CeCILL.txt 55 55 !!---------------------------------------------------------------------- -
branches/2014/dev_r4621_NOC4_BDY_VERT_INTERP/NEMOGCM/NEMO/OPA_SRC/LDF/ldfslp.F90
r5038 r5620 142 142 DO jj = 1, jpjm1 143 143 DO ji = 1, jpim1 144 ! IF should be useless check zpshde (PM) 145 IF ( mbku(ji,jj) > 1 ) zgru(ji,jj,mbku(ji,jj)) = gru(ji,jj) 146 IF ( mbkv(ji,jj) > 1 ) zgrv(ji,jj,mbkv(ji,jj)) = grv(ji,jj) 144 zgru(ji,jj,mbku(ji,jj)) = gru(ji,jj) 145 zgrv(ji,jj,mbkv(ji,jj)) = grv(ji,jj) 146 END DO 147 END DO 148 ENDIF 149 IF( ln_zps .AND. ln_isfcav ) THEN ! partial steps correction at the bottom ocean level 150 DO jj = 1, jpjm1 151 DO ji = 1, jpim1 147 152 IF ( miku(ji,jj) > 1 ) zgru(ji,jj,miku(ji,jj)) = grui(ji,jj) 148 153 IF ( mikv(ji,jj) > 1 ) zgrv(ji,jj,mikv(ji,jj)) = grvi(ji,jj) … … 151 156 ENDIF 152 157 ! 153 zdzr(:,:,1) = 0._wp !== Local vertical density gradient at T-point == ! (evaluated from N^2) 154 DO jk = 1, jpkm1 158 !== Local vertical density gradient at T-point == ! (evaluated from N^2) 159 ! interior value 160 DO jk = 2, jpkm1 155 161 ! ! zdzr = d/dz(prd)= - ( prd ) / grav * mk(pn2) -- at t point 156 162 ! ! trick: tmask(ik ) = 0 => all pn2 = 0 => zdzr = 0 … … 162 168 END DO 163 169 ! surface initialisation 164 DO jj = 1, jpjm1 165 DO ji = 1, jpim1 166 zdzr(ji,jj,1:mikt(ji,jj)) = 0._wp 167 END DO 168 END DO 170 zdzr(:,:,1) = 0._wp 171 IF ( ln_isfcav ) THEN 172 ! if isf need to overwrite the interior value at at the first ocean point 173 DO jj = 1, jpjm1 174 DO ji = 1, jpim1 175 zdzr(ji,jj,1:mikt(ji,jj)) = 0._wp 176 END DO 177 END DO 178 END IF 169 179 ! 170 180 ! !== Slopes just below the mixed layer ==! … … 175 185 ! =========================== | vslp = d/dj( prd ) / d/dz( prd ) 176 186 ! 177 DO jj = 2, jpjm1 178 DO ji = fs_2, fs_jpim1 ! vector opt. 179 IF (miku(ji,jj) .GT. miku(ji+1,jj)) zhmlpu(ji,jj) = hmlpt(ji ,jj) 180 IF (miku(ji,jj) .LT. miku(ji+1,jj)) zhmlpu(ji,jj) = hmlpt(ji+1,jj) 181 IF (miku(ji,jj) .EQ. miku(ji+1,jj)) zhmlpu(ji,jj) = MAX(hmlpt(ji ,jj), hmlpt(ji+1,jj)) 182 IF (mikv(ji,jj) .GT. miku(ji,jj+1)) zhmlpv(ji,jj) = hmlpt(ji ,jj) 183 IF (mikv(ji,jj) .LT. miku(ji,jj+1)) zhmlpv(ji,jj) = hmlpt(ji,jj+1) 184 IF (mikv(ji,jj) .EQ. miku(ji,jj+1)) zhmlpv(ji,jj) = MAX(hmlpt(ji,jj), hmlpt(ji,jj+1)) 187 IF ( ln_isfcav ) THEN 188 DO jj = 2, jpjm1 189 DO ji = fs_2, fs_jpim1 ! vector opt. 190 IF (miku(ji,jj) .GT. miku(ji+1,jj)) zhmlpu(ji,jj) = MAX(hmlpt(ji ,jj ), 5._wp) 191 IF (miku(ji,jj) .LT. miku(ji+1,jj)) zhmlpu(ji,jj) = MAX(hmlpt(ji+1,jj ), 5._wp) 192 IF (miku(ji,jj) .EQ. miku(ji+1,jj)) zhmlpu(ji,jj) = MAX(hmlpt(ji ,jj ), hmlpt(ji+1,jj ), 5._wp) 193 IF (mikv(ji,jj) .GT. miku(ji,jj+1)) zhmlpv(ji,jj) = MAX(hmlpt(ji ,jj ), 5._wp) 194 IF (mikv(ji,jj) .LT. miku(ji,jj+1)) zhmlpv(ji,jj) = MAX(hmlpt(ji ,jj+1), 5._wp) 195 IF (mikv(ji,jj) .EQ. miku(ji,jj+1)) zhmlpv(ji,jj) = MAX(hmlpt(ji ,jj ), hmlpt(ji ,jj+1), 5._wp) 196 ENDDO 185 197 ENDDO 186 ENDDO 198 ELSE 199 DO jj = 2, jpjm1 200 DO ji = fs_2, fs_jpim1 ! vector opt. 201 zhmlpu(ji,jj) = MAX(hmlpt(ji,jj), hmlpt(ji+1,jj ), 5._wp) 202 zhmlpv(ji,jj) = MAX(hmlpt(ji,jj), hmlpt(ji ,jj+1), 5._wp) 203 ENDDO 204 ENDDO 205 END IF 187 206 DO jk = 2, jpkm1 !* Slopes at u and v points 188 207 DO jj = 2, jpjm1 … … 198 217 zbv = MIN( zbv, -100._wp* ABS( zav ) , -7.e+3_wp/fse3v(ji,jj,jk)* ABS( zav ) ) 199 218 ! ! uslp and vslp output in zwz and zww, resp. 200 zfi = MAX( omlmask(ji,jj,jk), omlmask(ji+1,jj ,jk) )201 zfj = MAX( omlmask(ji,jj,jk), omlmask(ji ,jj+1,jk) )219 zfi = MAX( omlmask(ji,jj,jk), omlmask(ji+1,jj ,jk) ) 220 zfj = MAX( omlmask(ji,jj,jk), omlmask(ji ,jj+1,jk) ) 202 221 ! thickness of water column between surface and level k at u/v point 203 zdepu = 0.5_wp * (( fsdept(ji,jj,jk) + fsdept(ji+1,jj ,jk) ) & 204 - 2 * MAX( risfdep(ji,jj), risfdep(ji+1,jj ) ) & 205 - fse3u(ji,jj,miku(ji,jj)) ) 206 zdepv = 0.5_wp * (( fsdept(ji,jj,jk) + fsdept(ji ,jj+1,jk) ) & 207 - 2 * MAX( risfdep(ji,jj), risfdep(ji,jj+1) ) & 208 - fse3v(ji,jj,mikv(ji,jj)) ) 209 zwz(ji,jj,jk) = ( 1. - zfi) * zau / ( zbu - zeps ) & 210 & + zfi * uslpml(ji,jj) & 211 & * zdepu / MAX( zhmlpu(ji,jj), 5._wp ) 212 zwz(ji,jj,jk) = zwz(ji,jj,jk) * umask(ji,jj,jk) * umask(ji,jj,jk-1) 213 zww(ji,jj,jk) = ( 1. - zfj) * zav / ( zbv - zeps ) & 214 & + zfj * vslpml(ji,jj) & 215 & * zdepv / MAX( zhmlpv(ji,jj), 5._wp ) 216 zww(ji,jj,jk) = zww(ji,jj,jk) * vmask(ji,jj,jk) * vmask(ji,jj,jk-1) 222 zdepu = 0.5_wp * ( ( fsdept(ji,jj,jk) + fsdept(ji+1,jj ,jk) ) & 223 - 2 * MAX( risfdep(ji,jj), risfdep(ji+1,jj ) ) - fse3u(ji,jj,miku(ji,jj)) ) 224 zdepv = 0.5_wp * ( ( fsdept(ji,jj,jk) + fsdept(ji ,jj+1,jk) ) & 225 - 2 * MAX( risfdep(ji,jj), risfdep(ji ,jj+1) ) - fse3v(ji,jj,mikv(ji,jj)) ) 226 ! 227 zwz(ji,jj,jk) = ( 1. - zfi) * zau / ( zbu - zeps ) & 228 & + zfi * uslpml(ji,jj) * zdepu / zhmlpu(ji,jj) 229 zwz(ji,jj,jk) = zwz(ji,jj,jk) * wumask(ji,jj,jk) 230 zww(ji,jj,jk) = ( 1. - zfj) * zav / ( zbv - zeps ) & 231 & + zfj * vslpml(ji,jj) * zdepv / zhmlpv(ji,jj) 232 zww(ji,jj,jk) = zww(ji,jj,jk) * wvmask(ji,jj,jk) 217 233 218 234 … … 266 282 uslp(ji,jj,jk) = uslp(ji,jj,jk) * ( umask(ji,jj+1,jk) + umask(ji,jj-1,jk ) ) * 0.5_wp & 267 283 & * ( umask(ji,jj ,jk) + umask(ji,jj ,jk+1) ) * 0.5_wp & 268 & * umask(ji,jj,jk-1) !* umask(ji,jj,jk) * umask(ji,jj,jk+1)284 & * umask(ji,jj,jk-1) 269 285 vslp(ji,jj,jk) = vslp(ji,jj,jk) * ( vmask(ji+1,jj,jk) + vmask(ji-1,jj,jk ) ) * 0.5_wp & 270 286 & * ( vmask(ji ,jj,jk) + vmask(ji ,jj,jk+1) ) * 0.5_wp & 271 & * vmask(ji,jj,jk-1) !* vmask(ji,jj,jk) * vmask(ji,jj,jk+1)287 & * vmask(ji,jj,jk-1) 272 288 END DO 273 289 END DO … … 282 298 DO ji = fs_2, fs_jpim1 ! vector opt. 283 299 ! !* Local vertical density gradient evaluated from N^2 284 zbw = zm1_2g * pn2 (ji,jj,jk) * ( prd (ji,jj,jk) + prd (ji,jj,jk-1) + 2. ) * tmask(ji,jj,jk) * tmask(ji,jj,jk-1)300 zbw = zm1_2g * pn2 (ji,jj,jk) * ( prd (ji,jj,jk) + prd (ji,jj,jk-1) + 2. ) * wmask(ji,jj,jk) 285 301 ! !* Slopes at w point 286 302 ! ! i- & j-gradient of density at w-points … … 298 314 zbj = MIN( zbw , -100._wp* ABS( zaj ) , -7.e+3_wp/fse3w(ji,jj,jk)* ABS( zaj ) ) 299 315 ! ! wslpi and wslpj with ML flattening (output in zwz and zww, resp.) 300 zfk = MAX( omlmask(ji,jj,jk), omlmask(ji,jj,jk-1) ) 316 zfk = MAX( omlmask(ji,jj,jk), omlmask(ji,jj,jk-1) ) ! zfk=1 in the ML otherwise zfk=0 301 317 zck = ( fsdepw(ji,jj,jk) - fsdepw(ji,jj,mikt(ji,jj) ) ) / MAX( hmlp(ji,jj), 10._wp ) 302 318 zwz(ji,jj,jk) = ( zai / ( zbi - zeps ) * ( 1._wp - zfk ) & 303 & + zck * wslpiml(ji,jj) * zfk ) * tmask(ji,jj,jk) * tmask(ji,jj,jk-1)319 & + zck * wslpiml(ji,jj) * zfk ) * wmask(ji,jj,jk) 304 320 zww(ji,jj,jk) = ( zaj / ( zbj - zeps ) * ( 1._wp - zfk ) & 305 & + zck * wslpjml(ji,jj) * zfk ) * tmask(ji,jj,jk) * tmask(ji,jj,jk-1)321 & + zck * wslpjml(ji,jj) * zfk ) * wmask(ji,jj,jk) 306 322 307 323 !!gm modif to suppress omlmask.... (as in Griffies operator) … … 356 372 zck = ( umask(ji,jj,jk) + umask(ji-1,jj,jk) ) & 357 373 & * ( vmask(ji,jj,jk) + vmask(ji,jj-1,jk) ) * 0.25 358 wslpi(ji,jj,jk) = wslpi(ji,jj,jk) * zck * tmask(ji,jj,jk-1) * tmask(ji,jj,jk)359 wslpj(ji,jj,jk) = wslpj(ji,jj,jk) * zck * tmask(ji,jj,jk-1) * tmask(ji,jj,jk)374 wslpi(ji,jj,jk) = wslpi(ji,jj,jk) * zck * wmask(ji,jj,jk) 375 wslpj(ji,jj,jk) = wslpj(ji,jj,jk) * zck * wmask(ji,jj,jk) 360 376 END DO 361 377 END DO … … 423 439 vslp(ji,jj,jk) = -1./e2v(ji,jj) * ( fsdept_b(ji,jj+1,jk) - fsdept_b(ji ,jj ,jk) ) * vmask(ji,jj,jk) 424 440 wslpi(ji,jj,jk) = -1./e1t(ji,jj) * ( fsdepw_b(ji+1,jj,jk) - fsdepw_b(ji-1,jj,jk) ) & 425 & * tmask(ji,jj,jk) * tmask(ji,jj,jk-1) * 0.5441 & * wmask(ji,jj,jk) * 0.5 426 442 wslpj(ji,jj,jk) = -1./e2t(ji,jj) * ( fsdepw_b(ji,jj+1,jk) - fsdepw_b(ji,jj-1,jk) ) & 427 & * tmask(ji,jj,jk) * tmask(ji,jj,jk-1) * 0.5443 & * wmask(ji,jj,jk) * 0.5 428 444 END DO 429 445 END DO … … 736 752 DO ji = 1, jpi 737 753 ik = nmln(ji,jj) - 1 738 IF( jk <= ik .AND. jk >= mikt(ji,jj) ) THEN ; omlmask(ji,jj,jk) = 1._wp 739 ELSE ; omlmask(ji,jj,jk) = 0._wp 754 IF( jk <= ik .AND. jk >= mikt(ji,jj) ) THEN 755 omlmask(ji,jj,jk) = 1._wp 756 ELSE 757 omlmask(ji,jj,jk) = 0._wp 740 758 ENDIF 741 759 END DO … … 794 812 zbj = MIN( zbw , -100._wp* ABS( zaj ) , -7.e+3_wp/fse3w(ji,jj,ik)* ABS( zaj ) ) 795 813 ! !- i- & j-slope at w-points (wslpiml, wslpjml) 796 wslpiml(ji,jj) = zai / ( zbi - zeps ) * tmask (ji,jj,ik)797 wslpjml(ji,jj) = zaj / ( zbj - zeps ) * tmask (ji,jj,ik)814 wslpiml(ji,jj) = zai / ( zbi - zeps ) * wmask (ji,jj,ik) 815 wslpjml(ji,jj) = zaj / ( zbj - zeps ) * wmask (ji,jj,ik) 798 816 END DO 799 817 END DO -
branches/2014/dev_r4621_NOC4_BDY_VERT_INTERP/NEMOGCM/NEMO/OPA_SRC/LDF/ldftra_smag.F90
- Property svn:keywords set to Id
r3634 r5620 31 31 !!---------------------------------------------------------------------- 32 32 !! OPA 9.0 , LOCEAN-IPSL (2005) 33 !! $Id : ldf_tra_smag.F90 1482 2010-06-13 15:28:06Z$33 !! $Id$ 34 34 !! This software is governed by the CeCILL licence see modipsl/doc/NEMO_CeCILL.txt 35 35 !!---------------------------------------------------------------------- -
branches/2014/dev_r4621_NOC4_BDY_VERT_INTERP/NEMOGCM/NEMO/OPA_SRC/OBS/julian.F90
r2715 r5620 24 24 & greg2jul ! Convert date to relative time 25 25 26 !! $Id$ 26 27 CONTAINS 27 28 -
branches/2014/dev_r4621_NOC4_BDY_VERT_INTERP/NEMOGCM/NEMO/OPA_SRC/SBC/cpl_oasis3.F90
r5038 r5620 15 15 !!---------------------------------------------------------------------- 16 16 !!---------------------------------------------------------------------- 17 !! 'key_oasis3' coupled Ocean/Atmosphere via OASIS3 17 !! 'key_oasis3' coupled Ocean/Atmosphere via OASIS3-MCT 18 !! 'key_oa3mct_v3' to be added for OASIS3-MCT version 3 18 19 !!---------------------------------------------------------------------- 19 20 !! cpl_init : initialization of coupled mode communication … … 61 62 #endif 62 63 63 INTEGER, PUBLIC, PARAMETER :: nmaxfld=40 ! Maximum number of coupling fields 64 INTEGER :: nrcv ! total number of fields received 65 INTEGER :: nsnd ! total number of fields sent 66 INTEGER :: ncplmodel ! Maximum number of models to/from which NEMO is potentialy sending/receiving data 67 INTEGER, PUBLIC, PARAMETER :: nmaxfld=50 ! Maximum number of coupling fields 64 68 INTEGER, PUBLIC, PARAMETER :: nmaxcat=5 ! Maximum number of coupling fields 65 69 INTEGER, PUBLIC, PARAMETER :: nmaxcpl=5 ! Maximum number of coupling fields … … 86 90 CONTAINS 87 91 88 SUBROUTINE cpl_init( kl_comm )92 SUBROUTINE cpl_init( cd_modname, kl_comm ) 89 93 !!------------------------------------------------------------------- 90 94 !! *** ROUTINE cpl_init *** … … 95 99 !! ** Method : OASIS3 MPI communication 96 100 !!-------------------------------------------------------------------- 97 INTEGER, INTENT(out) :: kl_comm ! local communicator of the model 101 CHARACTER(len = *), INTENT(in) :: cd_modname ! model name as set in namcouple file 102 INTEGER , INTENT(out) :: kl_comm ! local communicator of the model 98 103 !!-------------------------------------------------------------------- 99 104 … … 104 109 ! 1st Initialize the OASIS system for the application 105 110 !------------------------------------------------------------------ 106 CALL oasis_init_comp ( ncomp_id, 'oceanx', nerror )111 CALL oasis_init_comp ( ncomp_id, TRIM(cd_modname), nerror ) 107 112 IF ( nerror /= OASIS_Ok ) & 108 113 CALL oasis_abort (ncomp_id, 'cpl_init', 'Failure in oasis_init_comp') … … 144 149 IF(lwp) WRITE(numout,*) 145 150 151 ncplmodel = kcplmodel 146 152 IF( kcplmodel > nmaxcpl ) THEN 147 CALL oasis_abort ( ncomp_id, 'cpl_define', ' kcplmodel is larger than nmaxcpl, increase nmaxcpl') ; RETURN153 CALL oasis_abort ( ncomp_id, 'cpl_define', 'ncplmodel is larger than nmaxcpl, increase nmaxcpl') ; RETURN 148 154 ENDIF 155 156 nrcv = krcv 157 IF( nrcv > nmaxfld ) THEN 158 CALL oasis_abort ( ncomp_id, 'cpl_define', 'nrcv is larger than nmaxfld, increase nmaxfld') ; RETURN 159 ENDIF 160 161 nsnd = ksnd 162 IF( nsnd > nmaxfld ) THEN 163 CALL oasis_abort ( ncomp_id, 'cpl_define', 'nsnd is larger than nmaxfld, increase nmaxfld') ; RETURN 164 ENDIF 165 149 166 ! 150 167 ! ... Define the shape for the area that excludes the halo … … 400 417 401 418 402 INTEGER FUNCTION cpl_freq( kid)419 INTEGER FUNCTION cpl_freq( cdfieldname ) 403 420 !!--------------------------------------------------------------------- 404 421 !! *** ROUTINE cpl_freq *** … … 406 423 !! ** Purpose : - send back the coupling frequency for a particular field 407 424 !!---------------------------------------------------------------------- 408 INTEGER,INTENT(in) :: kid ! variable index 409 !! 425 CHARACTER(len = *), INTENT(in) :: cdfieldname ! field name as set in namcouple file 426 !! 427 INTEGER :: id 410 428 INTEGER :: info 411 429 INTEGER, DIMENSION(1) :: itmp 430 INTEGER :: ji,jm ! local loop index 431 INTEGER :: mop 412 432 !!---------------------------------------------------------------------- 413 CALL oasis_get_freqs(kid, 1, itmp, info) 414 cpl_freq = itmp(1) 433 cpl_freq = 0 ! defaut definition 434 id = -1 ! defaut definition 435 ! 436 DO ji = 1, nsnd 437 IF (ssnd(ji)%laction ) THEN 438 DO jm = 1, ncplmodel 439 IF( ssnd(ji)%nid(1,jm) /= -1 ) THEN 440 IF( TRIM(cdfieldname) == TRIM(ssnd(ji)%clname) ) THEN 441 id = ssnd(ji)%nid(1,jm) 442 mop = OASIS_Out 443 ENDIF 444 ENDIF 445 ENDDO 446 ENDIF 447 ENDDO 448 DO ji = 1, nrcv 449 IF (srcv(ji)%laction ) THEN 450 DO jm = 1, ncplmodel 451 IF( srcv(ji)%nid(1,jm) /= -1 ) THEN 452 IF( TRIM(cdfieldname) == TRIM(srcv(ji)%clname) ) THEN 453 id = srcv(ji)%nid(1,jm) 454 mop = OASIS_In 455 ENDIF 456 ENDIF 457 ENDDO 458 ENDIF 459 ENDDO 460 ! 461 IF( id /= -1 ) THEN 462 #if defined key_oa3mct_v3 463 CALL oasis_get_freqs(id, mop, 1, itmp, info) 464 #else 465 CALL oasis_get_freqs(id, 1, itmp, info) 466 #endif 467 cpl_freq = itmp(1) 468 ENDIF 415 469 ! 416 470 END FUNCTION cpl_freq -
branches/2014/dev_r4621_NOC4_BDY_VERT_INTERP/NEMOGCM/NEMO/OPA_SRC/SBC/cyclone.F90
- Property svn:keywords set to Id
r4230 r5620 41 41 !!---------------------------------------------------------------------- 42 42 !! NEMO/OPA 3.3 , LOCEAN-IPSL (2010) 43 !! $Id : module_example 1146 2008-06-25 11:42:56Z rblod$43 !! $Id$ 44 44 !! Software governed by the CeCILL licence (modipsl/doc/NEMO_CeCILL.txt) 45 45 !!---------------------------------------------------------------------- -
branches/2014/dev_r4621_NOC4_BDY_VERT_INTERP/NEMOGCM/NEMO/OPA_SRC/SBC/fldread.F90
r5035 r5620 71 71 END TYPE FLD 72 72 73 TYPE, PUBLIC :: MAP_POINTER !: Array of integer pointers to 1D arrays 74 INTEGER, POINTER :: ptr(:) 73 TYPE, PUBLIC :: MAP_POINTER !: Map from input data file to local domain 74 INTEGER, POINTER, DIMENSION(:) :: ptr ! Array of integer pointers to 1D arrays 75 LOGICAL :: ll_unstruc ! Unstructured (T) or structured (F) boundary data file 75 76 END TYPE MAP_POINTER 76 77 … … 115 116 CONTAINS 116 117 117 SUBROUTINE fld_read( kt, kn_fsbc, sd, map, kit, kt_offset, jpk_bdy )118 SUBROUTINE fld_read( kt, kn_fsbc, sd, map, kit, kt_offset, jpk_bdy, fvl ) 118 119 !!--------------------------------------------------------------------- 119 120 !! *** ROUTINE fld_read *** … … 138 139 !! 139 140 INTEGER , INTENT(in ), OPTIONAL :: jpk_bdy ! number of vertical levels in the BDY data 141 LOGICAL , INTENT(in ), OPTIONAL :: fvl ! number of vertical levels in the BDY data 140 142 !! 141 143 INTEGER :: itmp ! temporary variable … … 157 159 IF( PRESENT(kit) ) ll_firstcall = ll_firstcall .and. kit == 1 158 160 159 it_offset = 0 161 IF ( nn_components == jp_iam_sas ) THEN ; it_offset = nn_fsbc 162 ELSE ; it_offset = 0 163 ENDIF 160 164 IF( PRESENT(kt_offset) ) it_offset = kt_offset 161 165 … … 174 178 IF( PRESENT(map) ) imap = map(jf) 175 179 IF( PRESENT(jpk_bdy) ) THEN 176 CALL fld_init( kn_fsbc, sd(jf), imap, jpk_bdy ) ! read each before field (put them in after as they will be swapped)180 CALL fld_init( kn_fsbc, sd(jf), imap, jpk_bdy, fvl ) ! read each before field (put them in after as they will be swapped) 177 181 ELSE 178 182 CALL fld_init( kn_fsbc, sd(jf), imap ) ! read each before field (put them in after as they will be swapped) … … 270 274 ! read after data 271 275 IF( PRESENT(jpk_bdy) ) THEN 272 CALL fld_get( sd(jf), imap, jpk_bdy )276 CALL fld_get( sd(jf), imap, jpk_bdy, fvl) 273 277 ELSE 274 278 CALL fld_get( sd(jf), imap ) … … 314 318 315 319 316 SUBROUTINE fld_init( kn_fsbc, sdjf, map , jpk_bdy )320 SUBROUTINE fld_init( kn_fsbc, sdjf, map , jpk_bdy, fvl) 317 321 !!--------------------------------------------------------------------- 318 322 !! *** ROUTINE fld_init *** … … 325 329 TYPE(MAP_POINTER),INTENT(in) :: map ! global-to-local mapping indices 326 330 INTEGER , INTENT(in), OPTIONAL :: jpk_bdy ! number of vertical levels in the BDY data 331 LOGICAL , INTENT(in), OPTIONAL :: fvl ! number of vertical levels in the BDY data 327 332 !! 328 333 LOGICAL :: llprevyr ! are we reading previous year file? … … 420 425 ! read before data in after arrays(as we will swap it later) 421 426 IF( PRESENT(jpk_bdy) ) THEN 422 CALL fld_get( sdjf, map, jpk_bdy )427 CALL fld_get( sdjf, map, jpk_bdy, fvl ) 423 428 ELSE 424 429 CALL fld_get( sdjf, map ) … … 467 472 ENDIF 468 473 ! 469 it_offset = 0 474 IF ( nn_components == jp_iam_sas ) THEN ; it_offset = nn_fsbc 475 ELSE ; it_offset = 0 476 ENDIF 470 477 IF( PRESENT(kt_offset) ) it_offset = kt_offset 471 478 IF( PRESENT(kit) ) THEN ; it_offset = ( kit + it_offset ) * NINT( rdt/REAL(nn_baro,wp) ) … … 597 604 598 605 599 SUBROUTINE fld_get( sdjf, map, jpk_bdy )606 SUBROUTINE fld_get( sdjf, map, jpk_bdy, fvl ) 600 607 !!--------------------------------------------------------------------- 601 608 !! *** ROUTINE fld_get *** … … 606 613 TYPE(MAP_POINTER),INTENT(in) :: map ! global-to-local mapping indices 607 614 INTEGER , INTENT(in), OPTIONAL :: jpk_bdy ! number of vertical levels in the bdy data 615 LOGICAL , INTENT(in), OPTIONAL :: fvl ! number of vertical levels in the bdy data 608 616 !! 609 617 INTEGER :: ipk ! number of vertical levels of sdjf%fdta ( 2D: ipk=1 ; 3D: ipk=jpk ) … … 620 628 IF( PRESENT(jpk_bdy) ) THEN 621 629 IF( sdjf%ln_tint ) THEN ; 622 CALL fld_map( sdjf%num, sdjf%clvar, sdjf%fdta(:,:,:,2), sdjf%nrec_a(1), map %ptr, sdjf%igrd, sdjf%ibdy, jpk_bdy)630 CALL fld_map( sdjf%num, sdjf%clvar, sdjf%fdta(:,:,:,2), sdjf%nrec_a(1), map, sdjf%igrd, sdjf%ibdy, jpk_bdy, fvl ) 623 631 ELSE ; 624 CALL fld_map( sdjf%num, sdjf%clvar, sdjf%fnow(:,:,: ), sdjf%nrec_a(1), map %ptr, sdjf%igrd, sdjf%ibdy, jpk_bdy)632 CALL fld_map( sdjf%num, sdjf%clvar, sdjf%fnow(:,:,: ), sdjf%nrec_a(1), map, sdjf%igrd, sdjf%ibdy, jpk_bdy, fvl ) 625 633 ENDIF 626 634 ELSE 627 635 IF( sdjf%ln_tint ) THEN ; 628 CALL fld_map( sdjf%num, sdjf%clvar, sdjf%fdta(:,:,:,2), sdjf%nrec_a(1), map %ptr)636 CALL fld_map( sdjf%num, sdjf%clvar, sdjf%fdta(:,:,:,2), sdjf%nrec_a(1), map ) 629 637 ELSE ; 630 CALL fld_map( sdjf%num, sdjf%clvar, sdjf%fnow(:,:,: ), sdjf%nrec_a(1), map %ptr)638 CALL fld_map( sdjf%num, sdjf%clvar, sdjf%fnow(:,:,: ), sdjf%nrec_a(1), map ) 631 639 ENDIF 632 640 ENDIF … … 685 693 END SUBROUTINE fld_get 686 694 687 SUBROUTINE fld_map( num, clvar, dta, nrec, map, igrd, ibdy, jpk_bdy )695 SUBROUTINE fld_map( num, clvar, dta, nrec, map, igrd, ibdy, jpk_bdy, fvl ) 688 696 !!--------------------------------------------------------------------- 689 697 !! *** ROUTINE fld_map *** … … 693 701 !!---------------------------------------------------------------------- 694 702 #if defined key_bdy 695 USE bdy_oce, ONLY: dta_global, dta_global_z, dta_global2, dta_global2_z! workspace to read in global data arrays703 USE bdy_oce, ONLY: idx_bdy, dta_global, dta_global_z, dta_global_dz, dta_global2, dta_global2_z, dta_global2_dz ! workspace to read in global data arrays 696 704 #endif 697 705 INTEGER , INTENT(in ) :: num ! stream number … … 699 707 REAL(wp), DIMENSION(:,:,:), INTENT(out) :: dta ! output field on model grid (2 dimensional) 700 708 INTEGER , INTENT(in ) :: nrec ! record number to read (ie time slice) 701 INTEGER, DIMENSION(:), INTENT(in ) :: map ! global-to-local mapping indices709 TYPE(MAP_POINTER) , INTENT(in ) :: map ! global-to-local mapping indices 702 710 INTEGER , INTENT(in), OPTIONAL :: igrd, ibdy, jpk_bdy ! grid type, set number and number of vertical levels in the bdy data 711 LOGICAL , INTENT(in), OPTIONAL :: fvl ! grid type, set number and number of vertical levels in the bdy data 703 712 INTEGER :: jpkm1_bdy! number of vertical levels in the bdy data minus 1 704 713 !! … … 713 722 REAL(wp), POINTER, DIMENSION(:,:,:) :: dta_read ! work space for global data 714 723 REAL(wp), POINTER, DIMENSION(:,:,:) :: dta_read_z ! work space for global data 724 REAL(wp), POINTER, DIMENSION(:,:,:) :: dta_read_dz ! work space for global data 715 725 !!--------------------------------------------------------------------- 716 726 … … 724 734 #if defined key_bdy 725 735 ipj = iom_file(num)%dimsz(2,idvar) 726 IF ( ipj == 1) THEN736 IF ( map%ll_unstruc) THEN ! unstructured open boundary data file 727 737 dta_read => dta_global 728 738 IF( PRESENT(jpk_bdy) ) THEN 729 739 IF( jpk_bdy>0 ) THEN 730 740 dta_read_z => dta_global_z 741 dta_read_dz => dta_global_dz 731 742 jpkm1_bdy = jpk_bdy-1 732 743 ENDIF 733 744 ENDIF 734 ELSE ! we assume that this is astructured open boundary file745 ELSE ! structured open boundary file 735 746 dta_read => dta_global2 736 747 IF( PRESENT(jpk_bdy) ) THEN 737 748 IF( jpk_bdy>0 ) THEN 738 749 dta_read_z => dta_global2_z 750 dta_read_dz => dta_global2_dz 739 751 jpkm1_bdy = jpk_bdy-1 740 752 ENDIF … … 750 762 CASE DEFAULT ; 751 763 764 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! 765 ! Do we include something here to adjust barotropic velocities ! 766 ! in case of a depth difference between bdy files and ! 767 ! bathymetry in the case ln_full_vel = .false. and jpk_bdy>0? ! 768 ! [as the enveloping and parital cells could change H ! 769 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! 770 752 771 IF( PRESENT(jpk_bdy) .AND. jpk_bdy>0 ) THEN ! boundary data not on model grid: vertical interpolation 753 772 CALL iom_get ( num, jpdom_unknown, clvar, dta_read(1:ilendta,1:ipj,1:jpk_bdy), nrec ) … … 764 783 END SELECT 765 784 CALL iom_getatt(num, '_FillValue', fv, cdvar=clvar ) 785 766 786 #if defined key_bdy 767 CALL fld_bdy_interp(dta_read, dta_read_z, map, jpk_bdy, igrd, ibdy, fv, dta)787 CALL fld_bdy_interp(dta_read, dta_read_z, dta_read_dz, map, jpk_bdy, igrd, ibdy, fv, dta, fvl) 768 788 #endif 769 789 ELSE ! boundary data assumed to be on model grid … … 772 792 DO ib = 1, ipi 773 793 DO ik = 1, ipk 774 dta(ib,1,ik) = dta_read(map (ib),1,ik)794 dta(ib,1,ik) = dta_read(map%ptr(ib),1,ik) 775 795 END DO 776 796 END DO 777 797 ELSE ! we assume that this is a structured open boundary file 778 798 DO ib = 1, ipi 779 jj=1+floor(REAL(map (ib)-1)/REAL(ilendta))780 ji=map (ib)-(jj-1)*ilendta799 jj=1+floor(REAL(map%ptr(ib)-1)/REAL(ilendta)) 800 ji=map%ptr(ib)-(jj-1)*ilendta 781 801 DO ik = 1, ipk 782 802 dta(ib,1,ik) = dta_read(ji,jj,ik) … … 790 810 791 811 #if defined key_bdy 792 SUBROUTINE fld_bdy_interp(dta_read, dta_read_z, map, jpk_bdy, igrd, ibdy, fv, dta)812 SUBROUTINE fld_bdy_interp(dta_read, dta_read_z, dta_read_dz, map, jpk_bdy, igrd, ibdy, fv, dta, fvl) 793 813 794 814 !!--------------------------------------------------------------------- … … 802 822 REAL(wp), POINTER, DIMENSION(:,:,:), INTENT(in ) :: dta_read ! work space for global data 803 823 REAL(wp), POINTER, DIMENSION(:,:,:), INTENT(in ) :: dta_read_z ! work space for global data 824 REAL(wp), POINTER, DIMENSION(:,:,:), INTENT(in ) :: dta_read_dz ! work space for global data 804 825 REAL(wp), DIMENSION(:,:,:), INTENT(out) :: dta ! output field on model grid (2 dimensional) 805 INTEGER, DIMENSION(:) , INTENT(in ) :: map ! global-to-local mapping indices 826 TYPE(MAP_POINTER) , INTENT(in ) :: map ! global-to-local mapping indices 827 LOGICAL , INTENT(in), OPTIONAL :: fvl ! grid type, set number and number of vertical levels in the bdy data 806 828 INTEGER , INTENT(in) :: igrd, ibdy, jpk_bdy ! number of levels in bdy data 807 829 INTEGER :: jpkm1_bdy ! number of levels in bdy data minus 1 … … 810 832 INTEGER :: ipi ! length of boundary data on local process 811 833 INTEGER :: ipj ! length of dummy dimension ( = 1 ) 812 INTEGER :: ipk , ipkm1! number of vertical levels of dta ( 2D: ipk=1 ; 3D: ipk=jpk )834 INTEGER :: ipk ! number of vertical levels of dta ( 2D: ipk=1 ; 3D: ipk=jpk ) 813 835 INTEGER :: ilendta ! length of data in file 814 836 INTEGER :: ib, ik, ikk! loop counters 815 837 INTEGER :: ji, jj ! loop counters 816 REAL(wp) :: zl, zi 817 REAL(wp) :: fv_alt ! fillvalue and alternative -ABS(fv)838 REAL(wp) :: zl, zi, zh, zz, zdz ! tmp variable for current depth and interpolation factor 839 REAL(wp) :: fv_alt, ztrans, ztrans_new ! fillvalue and alternative -ABS(fv) 818 840 !!--------------------------------------------------------------------- 819 841 … … 826 848 fv_alt = -ABS(fv) ! set _FillValue < 0 as we make use of MAXVAL and MAXLOC later 827 849 ! 828 IF ( ipj==1) THEN ! we assume that this is an un-structured open boundaryfile850 IF ( map%ll_unstruc ) THEN ! unstructured open boundary data file 829 851 DO ib = 1, ipi 830 852 DO ik = 1, jpk_bdy 831 IF( ( dta_read(map(ib),1,ik) == fv ) ) THEN 832 dta_read_z(map(ib),1,ik) = fv_alt ! safety: put fillvalue into external depth field so consistent with data 833 dta_read_dz(map(ib),1,ik) = 0._wp ! safety: put 0._wp into external thickness factors to ensure transport is correct 834 ENDIF 835 ! dta(ib,1,ik) = fv_alt ! put fillvalue into new field as if all goes well all wet points will be replaced 853 IF( ( dta_read(map%ptr(ib),1,ik) == fv ) ) THEN 854 dta_read_z(map%ptr(ib),1,ik) = fv_alt ! safety: put fillvalue into external depth field so consistent with data 855 dta_read_dz(map%ptr(ib),1,ik) = 0._wp ! safety: put 0._wp into external thickness factors to ensure transport is correct 856 ENDIF 836 857 ENDDO 837 858 ENDDO 838 ! 859 839 860 DO ib = 1, ipi 840 861 DO ik = 1, ipk 841 862 zl = gdept_0(idx_bdy(ibdy)%nbi(ib,igrd),idx_bdy(ibdy)%nbj(ib,igrd),ik) ! if using in step could use fsdept instead of gdept_0? 842 IF( zl < dta_read_z(map (ib),1,1) ) THEN ! above the first level of external data843 dta(ib,1,ik) = dta_read(map (ib),1,1)844 ELSEIF( zl > MAXVAL(dta_read_z(map (ib),1,:),1) ) THEN ! below the last level of external data845 dta(ib,1,ik) = dta_read(map (ib),1,MAXLOC(dta_read_z(map(ib),1,:),1))863 IF( zl < dta_read_z(map%ptr(ib),1,1) ) THEN ! above the first level of external data 864 dta(ib,1,ik) = dta_read(map%ptr(ib),1,1) 865 ELSEIF( zl > MAXVAL(dta_read_z(map%ptr(ib),1,:),1) ) THEN ! below the last level of external data 866 dta(ib,1,ik) = dta_read(map%ptr(ib),1,MAXLOC(dta_read_z(map%ptr(ib),1,:),1)) 846 867 ELSE ! inbetween : vertical interpolation between ikk & ikk+1 847 868 DO ikk = 1, jpkm1_bdy ! when gdept_0(ikk) < zl < gdept_0(ikk+1) 848 IF( ( (zl-dta_read_z(map (ib),1,ikk)) * (zl-dta_read_z(map(ib),1,ikk+1)) <= 0._wp) &849 & .AND. (dta_read_z(map (ib),1,ikk+1) /= fv_alt)) THEN850 zi = ( zl - dta_read_z(map (ib),1,ikk) ) / (dta_read_z(map(ib),1,ikk+1)-dta_read_z(map(ib),1,ikk))851 dta(ib,1,ik) = dta_read(map (ib),1,ikk) + &852 & ( dta_read(map (ib),1,ikk+1) - dta_read(map(ib),1,ikk) ) * zi869 IF( ( (zl-dta_read_z(map%ptr(ib),1,ikk)) * (zl-dta_read_z(map%ptr(ib),1,ikk+1)) <= 0._wp) & 870 & .AND. (dta_read_z(map%ptr(ib),1,ikk+1) /= fv_alt)) THEN 871 zi = ( zl - dta_read_z(map%ptr(ib),1,ikk) ) / (dta_read_z(map%ptr(ib),1,ikk+1)-dta_read_z(map%ptr(ib),1,ikk)) 872 dta(ib,1,ik) = dta_read(map%ptr(ib),1,ikk) + & 873 & ( dta_read(map%ptr(ib),1,ikk+1) - dta_read(map%ptr(ib),1,ikk) ) * zi 853 874 ENDIF 854 875 END DO … … 856 877 END DO 857 878 END DO 858 ELSE ! we assume that this is a structured open boundary file 879 880 IF(igrd == 2) THEN ! do we need to adjust the transport term? 881 DO ib = 1, ipi 882 zh = SUM(dta_read_dz(map%ptr(ib),1,:) ) 883 ztrans = 0._wp 884 ztrans_new = 0._wp 885 DO ik = 1, jpk_bdy 886 ztrans = ztrans + dta_read(map%ptr(ib),1,ik) * dta_read_dz(map%ptr(ib),1,ik) 887 ENDDO 888 DO ik = 1, ipk 889 zdz = e3u_0(idx_bdy(ibdy)%nbi(ib,igrd),idx_bdy(ibdy)%nbj(ib,igrd),ik) 890 ztrans_new = ztrans_new + dta(ib,1,ik) * zdz 891 ENDDO 892 DO ik = 1, ipk 893 zdz = e3u_0(idx_bdy(ibdy)%nbi(ib,igrd),idx_bdy(ibdy)%nbj(ib,igrd),ik) 894 zz = hur(idx_bdy(ibdy)%nbi(ib,igrd),idx_bdy(ibdy)%nbj(ib,igrd)) 895 IF(fvl) THEN ! bdy data are total velocity so adjust bt transport term to match input data 896 dta(ib,1,ik) = dta(ib,1,ik) + ( ztrans - ztrans_new ) * ( zdz * zz ) 897 ELSE ! we're just dealing with bc velocity so bt transport term should sum to zero 898 dta(ib,1,ik) = dta(ib,1,ik) + ( 0._wp - ztrans_new ) * ( zdz * zz ) 899 ENDIF 900 ENDDO 901 ENDDO 902 ENDIF 903 904 IF(igrd == 3) THEN ! do we need to adjust the transport term? 905 DO ib = 1, ipi 906 zh = SUM(dta_read_dz(map%ptr(ib),1,:) ) 907 ztrans = 0._wp 908 ztrans_new = 0._wp 909 DO ik = 1, jpk_bdy 910 ztrans = ztrans + dta_read(map%ptr(ib),1,ik) * dta_read_dz(map%ptr(ib),1,ik) 911 ENDDO 912 DO ik = 1, ipk 913 zdz = e3v_0(idx_bdy(ibdy)%nbi(ib,igrd),idx_bdy(ibdy)%nbj(ib,igrd),ik) 914 ztrans_new = ztrans_new + dta(ib,1,ik) * zdz 915 ENDDO 916 DO ik = 1, ipk 917 zdz = e3v_0(idx_bdy(ibdy)%nbi(ib,igrd),idx_bdy(ibdy)%nbj(ib,igrd),ik) 918 zz = hvr(idx_bdy(ibdy)%nbi(ib,igrd),idx_bdy(ibdy)%nbj(ib,igrd)) 919 IF(fvl) THEN ! bdy data are total velocity so adjust bt transport term to match input data 920 dta(ib,1,ik) = dta(ib,1,ik) + ( ztrans - ztrans_new ) * ( zdz * zz ) 921 ELSE ! we're just dealing with bc velocity so bt transport term should sum to zero 922 dta(ib,1,ik) = dta(ib,1,ik) + ( 0._wp - ztrans_new ) * ( zdz * zz ) 923 ENDIF 924 ENDDO 925 ENDDO 926 ENDIF 927 928 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! 929 ! At this point write out a single velocity profile/dz/H for model and input data ! 930 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! 931 932 ELSE ! structured open boundary file 859 933 DO ib = 1, ipi 860 jj=1+floor(REAL(map (ib)-1)/REAL(ilendta))861 ji=map (ib)-(jj-1)*ilendta934 jj=1+floor(REAL(map%ptr(ib)-1)/REAL(ilendta)) 935 ji=map%ptr(ib)-(jj-1)*ilendta 862 936 DO ik = 1, jpk_bdy 863 937 IF( ( dta_read(ji,jj,ik) == fv ) ) THEN 864 dta_read_z(map(ib),1,ik) = fv_alt ! safety: put fillvalue into external depth field so consistent with data 938 dta_read_z(ji,jj,ik) = fv_alt ! safety: put fillvalue into external depth field so consistent with data 939 dta_read_dz(ji,jj,ik) = 0._wp ! safety: put 0._wp into external thickness factors to ensure transport is correct 865 940 ENDIF 866 941 ! dta(ib,1,ik) = fv_alt ! put fillvalue into new field as if all goes well all wet points will be replaced … … 869 944 ! 870 945 DO ib = 1, ipi 871 jj=1+floor(REAL(map (ib)-1)/REAL(ilendta))872 ji=map (ib)-(jj-1)*ilendta946 jj=1+floor(REAL(map%ptr(ib)-1)/REAL(ilendta)) 947 ji=map%ptr(ib)-(jj-1)*ilendta 873 948 DO ik = 1, ipk 874 949 zl = gdept_0(idx_bdy(ibdy)%nbi(ib,igrd),idx_bdy(ibdy)%nbj(ib,igrd),ik) ! if using in step could use fsdept instead of gdept_0? … … 892 967 893 968 END SUBROUTINE fld_bdy_interp 894 SUBROUTINE fld_bdy_conserve(dta_read, dta_read_z, map, jpk_bdy, igrd, ibdy, fv, dta) 895 896 END SUBROUTINE fld_bdy_conserve 969 970 ! SUBROUTINE fld_bdy_conserve(dta_read, dta_read_z, map, jpk_bdy, igrd, ibdy, fv, dta) 971 972 ! END SUBROUTINE fld_bdy_conserve 897 973 898 974 #endif … … 1193 1269 INTEGER :: ipk ! temporary vertical dimension 1194 1270 CHARACTER (len=5) :: aname 1195 INTEGER , DIMENSION( 3):: ddims1271 INTEGER , DIMENSION(:), ALLOCATABLE :: ddims 1196 1272 INTEGER , POINTER, DIMENSION(:,:) :: data_src 1197 1273 REAL(wp), POINTER, DIMENSION(:,:) :: data_tmp … … 1216 1292 1217 1293 !! get dimensions 1294 IF ( SIZE(sd%fnow, 3) > 1 ) THEN 1295 ALLOCATE( ddims(4) ) 1296 ELSE 1297 ALLOCATE( ddims(3) ) 1298 ENDIF 1218 1299 id = iom_varid( inum, sd%clvar, ddims ) 1219 1300 … … 1312 1393 CALL ctl_stop( ' fld_weight : unable to read the file ' ) 1313 1394 ENDIF 1395 1396 DEALLOCATE (ddims ) 1314 1397 1315 1398 CALL wrk_dealloc( jpi,jpj, data_src ) ! integer -
branches/2014/dev_r4621_NOC4_BDY_VERT_INTERP/NEMOGCM/NEMO/OPA_SRC/SBC/sbc_ice.F90
r5038 r5620 16 16 USE sbc_oce ! surface boundary condition: ocean 17 17 # if defined key_lim3 18 USE par_ice! LIM-3 parameters18 USE ice ! LIM-3 parameters 19 19 # endif 20 20 # if defined key_lim2 … … 58 58 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: qns_ice !: non solar heat flux over ice [W/m2] 59 59 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: qsr_ice !: solar heat flux over ice [W/m2] 60 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: qsr_ice_mean !: daily mean solar heat flux over ice [W/m2]61 60 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: qla_ice !: latent flux over ice [W/m2] 62 61 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: dqla_ice !: latent sensibility over ice [W/m2/K] … … 69 68 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: fr1_i0 !: Solar surface transmission parameter, thick ice [-] 70 69 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: fr2_i0 !: Solar surface transmission parameter, thin ice [-] 71 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: emp_ice !: sublimation - precip over sea ice [kg/m2]70 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: emp_ice !: sublimation - precip over sea ice [kg/m2/s] 72 71 73 72 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: topmelt !: category topmelt 74 73 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: botmelt !: category botmelt 74 75 #if defined key_lim3 76 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: evap_ice !: sublimation [kg/m2/s] 77 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: devap_ice !: sublimation sensitivity [kg/m2/s/K] 78 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: qns_oce !: non solar heat flux over ocean [W/m2] 79 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: qsr_oce !: non solar heat flux over ocean [W/m2] 80 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: qemp_oce !: heat flux of precip and evap over ocean [W/m2] 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] 83 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: emp_oce !: evap - precip over ocean [kg/m2/s] 84 #endif 85 #if defined key_lim3 || defined key_lim2 86 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: wndm_ice !: wind speed module at T-point [m/s] 87 #endif 75 88 76 89 #if defined key_cice … … 100 113 #endif 101 114 102 #if defined key_lim3 || defined key_cice 103 ! not used with LIM2 115 #if defined key_cice 104 116 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: tatm_ice !: air temperature [K] 105 117 #endif … … 125 137 ALLOCATE( qns_ice (jpi,jpj,jpl) , qsr_ice (jpi,jpj,jpl) , & 126 138 & qla_ice (jpi,jpj,jpl) , dqla_ice(jpi,jpj,jpl) , & 127 & dqns_ice(jpi,jpj,jpl) , tn_ice (jpi,jpj,jpl) , & 128 & alb_ice (jpi,jpj,jpl) , & 129 & utau_ice(jpi,jpj) , vtau_ice(jpi,jpj) , & 139 & dqns_ice(jpi,jpj,jpl) , tn_ice (jpi,jpj,jpl) , alb_ice (jpi,jpj,jpl) , & 140 & utau_ice(jpi,jpj) , vtau_ice(jpi,jpj) , wndm_ice(jpi,jpj) , & 130 141 & fr1_i0 (jpi,jpj) , fr2_i0 (jpi,jpj) , & 131 #if defined key_lim3132 & tatm_ice(jpi,jpj) , &133 #endif134 142 #if defined key_lim2 135 143 & a_i(jpi,jpj,jpl) , & 144 #endif 145 #if defined key_lim3 146 & evap_ice(jpi,jpj,jpl) , devap_ice(jpi,jpj,jpl) , qprec_ice(jpi,jpj) , & 147 & qemp_ice(jpi,jpj) , qemp_oce(jpi,jpj) , & 148 & qns_oce (jpi,jpj) , qsr_oce (jpi,jpj) , emp_oce (jpi,jpj) , & 136 149 #endif 137 150 & emp_ice(jpi,jpj) , STAT= ierr(1) ) … … 145 158 a_i(jpi,jpj,ncat) , topmelt(jpi,jpj,ncat) , botmelt(jpi,jpj,ncat) , & 146 159 STAT= ierr(1) ) 147 IF( l k_cpl ) ALLOCATE( u_ice(jpi,jpj) , fr1_i0(jpi,jpj) , tn_ice (jpi,jpj,1) , &160 IF( ln_cpl ) ALLOCATE( u_ice(jpi,jpj) , fr1_i0(jpi,jpj) , tn_ice (jpi,jpj,1) , & 148 161 & v_ice(jpi,jpj) , fr2_i0(jpi,jpj) , alb_ice(jpi,jpj,1) , & 149 162 & emp_ice(jpi,jpj) , qns_ice(jpi,jpj,1) , dqns_ice(jpi,jpj,1) , & … … 152 165 #endif 153 166 ! 154 #if defined key_lim2155 IF( ltrcdm2dc_ice ) ALLOCATE( qsr_ice_mean (jpi,jpj,jpl), STAT=ierr(3) )156 #endif157 !158 167 #if defined key_cice || defined key_lim2 159 IF( l k_cpl ) ALLOCATE( ht_i(jpi,jpj,jpl) , ht_s(jpi,jpj,jpl) , STAT=ierr(5) )168 IF( ln_cpl ) ALLOCATE( ht_i(jpi,jpj,jpl) , ht_s(jpi,jpj,jpl) , STAT=ierr(5) ) 160 169 #endif 161 170 -
branches/2014/dev_r4621_NOC4_BDY_VERT_INTERP/NEMOGCM/NEMO/OPA_SRC/SBC/sbc_oce.F90
r5038 r5620 36 36 LOGICAL , PUBLIC :: ln_blk_mfs !: MFS bulk formulation 37 37 #if defined key_oasis3 38 LOGICAL , PUBLIC :: lk_ cpl = .TRUE. !: coupled formulation38 LOGICAL , PUBLIC :: lk_oasis = .TRUE. !: OASIS used 39 39 #else 40 LOGICAL , PUBLIC :: lk_cpl = .FALSE. !: coupled formulation 41 #endif 40 LOGICAL , PUBLIC :: lk_oasis = .FALSE. !: OASIS unused 41 #endif 42 LOGICAL , PUBLIC :: ln_cpl !: ocean-atmosphere coupled formulation 43 LOGICAL , PUBLIC :: ln_mixcpl !: ocean-atmosphere forced-coupled mixed formulation 42 44 LOGICAL , PUBLIC :: ln_dm2dc !: Daily mean to Diurnal Cycle short wave (qsr) 43 45 LOGICAL , PUBLIC :: ln_rnf !: runoffs / runoff mouths … … 50 52 ! !: =1 levitating ice with mass and salt exchange but no presure effect 51 53 ! !: =2 embedded sea-ice (full salt and mass exchanges and pressure) 52 INTEGER , PUBLIC :: nn_limflx !: LIM3 Multi-category heat flux formulation 54 INTEGER , PUBLIC :: nn_components !: flag for sbc module (including sea-ice) coupling mode (see component definition below) 55 INTEGER , PUBLIC :: nn_limflx !: LIM3 Multi-category heat flux formulation 53 56 ! !: =-1 Use of per-category fluxes 54 57 ! !: = 0 Average per-category fluxes … … 69 72 !! switch definition (improve readability) 70 73 !!---------------------------------------------------------------------- 71 INTEGER , PUBLIC, PARAMETER :: jp_gyre = 0 !: GYRE analytical formulation 72 INTEGER , PUBLIC, PARAMETER :: jp_ana = 1 !: analytical formulation 73 INTEGER , PUBLIC, PARAMETER :: jp_flx = 2 !: flux formulation 74 INTEGER , PUBLIC, PARAMETER :: jp_clio = 3 !: CLIO bulk formulation 75 INTEGER , PUBLIC, PARAMETER :: jp_core = 4 !: CORE bulk formulation 76 INTEGER , PUBLIC, PARAMETER :: jp_cpl = 5 !: Coupled formulation 77 INTEGER , PUBLIC, PARAMETER :: jp_mfs = 6 !: MFS bulk formulation 74 INTEGER , PUBLIC, PARAMETER :: jp_gyre = 0 !: GYRE analytical formulation 75 INTEGER , PUBLIC, PARAMETER :: jp_ana = 1 !: analytical formulation 76 INTEGER , PUBLIC, PARAMETER :: jp_flx = 2 !: flux formulation 77 INTEGER , PUBLIC, PARAMETER :: jp_clio = 3 !: CLIO bulk formulation 78 INTEGER , PUBLIC, PARAMETER :: jp_core = 4 !: CORE bulk formulation 79 INTEGER , PUBLIC, PARAMETER :: jp_purecpl = 5 !: Pure ocean-atmosphere Coupled formulation 80 INTEGER , PUBLIC, PARAMETER :: jp_mfs = 6 !: MFS bulk formulation 81 INTEGER , PUBLIC, PARAMETER :: jp_none = 7 !: for OPA when doing coupling via SAS module 78 82 INTEGER , PUBLIC, PARAMETER :: jp_esopa = -1 !: esopa test, ALL formulations 79 83 80 84 !!---------------------------------------------------------------------- 85 !! component definition 86 !!---------------------------------------------------------------------- 87 INTEGER , PUBLIC, PARAMETER :: jp_iam_nemo = 0 !: Initial single executable configuration 88 ! (no internal OASIS coupling) 89 INTEGER , PUBLIC, PARAMETER :: jp_iam_opa = 1 !: Multi executable configuration - OPA component 90 ! (internal OASIS coupling) 91 INTEGER , PUBLIC, PARAMETER :: jp_iam_sas = 2 !: Multi executable configuration - SAS component 92 ! (internal OASIS coupling) 93 !!---------------------------------------------------------------------- 81 94 !! Ocean Surface Boundary Condition fields 82 95 !!---------------------------------------------------------------------- 96 INTEGER , PUBLIC :: ncpl_qsr_freq !: qsr coupling frequency per days from atmosphere 97 ! 83 98 LOGICAL , PUBLIC :: lhftau = .FALSE. !: HF tau used in TKE: mean(stress module) - module(mean stress) 84 LOGICAL , PUBLIC :: ltrcdm2dc !: In case of Diurnal Cycle short wave, compute a Daily Mean short waves flux85 99 !! !! now ! before !! 86 100 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: utau , utau_b !: sea surface i-stress (ocean referential) [N/m2] … … 90 104 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: wndm !: wind speed module at T-point (=|U10m-Uoce|) [m/s] 91 105 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: qsr !: sea heat flux: solar [W/m2] 92 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: qsr_mean !: daily mean sea heat flux: solar [W/m2]93 106 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: qns , qns_b !: sea heat flux: non solar [W/m2] 94 107 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: qsr_tot !: total solar heat flux (over sea and ice) [W/m2] … … 98 111 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: emp_tot !: total E-P over ocean and ice [Kg/m2/s] 99 112 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: fmmflx !: freshwater budget: freezing/melting [Kg/m2/s] 100 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: rnf , rnf_b !: river runoff [Kg/m2/s] 113 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: rnf , rnf_b !: river runoff [Kg/m2/s] 114 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: fwfisf , fwfisf_b !: ice shelf melting [Kg/m2/s] 101 115 !! 102 116 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: sbc_tsc, sbc_tsc_b !: sbc content trend [K.m/s] jpi,jpj,jpts … … 110 124 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: atm_co2 !: atmospheric pCO2 [ppm] 111 125 #endif 126 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: xcplmask !: coupling mask for ln_mixcpl (warning: allocated in sbccpl) 112 127 113 128 !!---------------------------------------------------------------------- … … 121 136 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: ssh_m !: mean (nn_fsbc time-step) sea surface height [m] 122 137 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: e3t_m !: mean (nn_fsbc time-step) sea surface layer thickness [m] 138 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: frq_m !: mean (nn_fsbc time-step) fraction of solar net radiation absorbed in the 1st T level [-] 123 139 124 140 !! * Substitutions … … 147 163 & sfx (jpi,jpj) , sfx_b(jpi,jpj) , emp_tot(jpi,jpj), fmmflx(jpi,jpj), STAT=ierr(2) ) 148 164 ! 149 ALLOCATE( rnf (jpi,jpj) , sbc_tsc (jpi,jpj,jpts) , qsr_hc (jpi,jpj,jpk) , &150 & rnf_b(jpi,jpj) , sbc_tsc_b(jpi,jpj,jpts) , qsr_hc_b(jpi,jpj,jpk) , STAT=ierr(3) )165 ALLOCATE( fwfisf (jpi,jpj), rnf (jpi,jpj) , sbc_tsc (jpi,jpj,jpts) , qsr_hc (jpi,jpj,jpk) , & 166 & fwfisf_b(jpi,jpj), rnf_b(jpi,jpj) , sbc_tsc_b(jpi,jpj,jpts) , qsr_hc_b(jpi,jpj,jpk) , STAT=ierr(3) ) 151 167 ! 152 168 ALLOCATE( tprecip(jpi,jpj) , sprecip(jpi,jpj) , fr_i(jpi,jpj) , & … … 154 170 & atm_co2(jpi,jpj) , & 155 171 #endif 156 & ssu_m (jpi,jpj) , sst_m(jpi,jpj) , 157 & ssv_m (jpi,jpj) , sss_m (jpi,jpj), ssh_m(jpi,jpj) , STAT=ierr(4) )172 & ssu_m (jpi,jpj) , sst_m(jpi,jpj) , frq_m(jpi,jpj) , & 173 & ssv_m (jpi,jpj) , sss_m(jpi,jpj) , ssh_m(jpi,jpj) , STAT=ierr(4) ) 158 174 ! 159 175 #if defined key_vvl 160 176 ALLOCATE( e3t_m(jpi,jpj) , STAT=ierr(5) ) 161 177 #endif 162 !163 IF( ltrcdm2dc ) ALLOCATE( qsr_mean(jpi,jpj) , STAT=ierr(5) )164 178 ! 165 179 sbc_oce_alloc = MAXVAL( ierr ) -
branches/2014/dev_r4621_NOC4_BDY_VERT_INTERP/NEMOGCM/NEMO/OPA_SRC/SBC/sbcapr.F90
- Property svn:keywords set to Id
r4792 r5620 43 43 !!---------------------------------------------------------------------- 44 44 !! NEMO/OPA 4.0 , NEMO Consortium (2011) 45 !! $Id :$45 !! $Id$ 46 46 !! Software governed by the CeCILL licence (NEMOGCM/NEMO_CeCILL.txt) 47 47 !!---------------------------------------------------------------------- -
branches/2014/dev_r4621_NOC4_BDY_VERT_INTERP/NEMOGCM/NEMO/OPA_SRC/SBC/sbcblk_clio.F90
r5038 r5620 34 34 USE albedo 35 35 USE prtctl ! Print control 36 #if defined key_lim3 36 #if defined key_lim3 37 37 USE ice 38 38 USE sbc_ice ! Surface boundary condition: ice fields 39 USE limthd_dh ! for CALL lim_thd_snwblow 39 40 #elif defined key_lim2 40 41 USE ice_2 42 USE sbc_ice ! Surface boundary condition: ice fields 43 USE par_ice_2 ! Surface boundary condition: ice fields 41 44 #endif 42 45 … … 45 48 46 49 PUBLIC sbc_blk_clio ! routine called by sbcmod.F90 47 PUBLIC blk_ice_clio ! routine called by sbcice_lim.F90 50 #if defined key_lim2 || defined key_lim3 51 PUBLIC blk_ice_clio_tau ! routine called by sbcice_lim.F90 52 PUBLIC blk_ice_clio_flx ! routine called by sbcice_lim.F90 53 #endif 48 54 49 55 INTEGER , PARAMETER :: jpfld = 7 ! maximum number of files to read … … 62 68 LOGICAL :: lbulk_init = .TRUE. ! flag, bulk initialization done or not) 63 69 64 #if ! defined key_lim365 ! in namicerun with LIM366 70 REAL(wp) :: cai = 1.40e-3 ! best estimate of atm drag in order to get correct FS export in ORCA2-LIM 67 71 REAL(wp) :: cao = 1.00e-3 ! chosen by default ==> should depends on many things... !!gmto be updated 68 #endif69 72 70 73 REAL(wp) :: rdtbs2 !: … … 381 384 & + sf(jp_prec)%fnow(:,:,1) * sf(jp_tair)%fnow(:,:,1) * zcprec ! add precip. heat content at Tair in Celcius 382 385 qns(:,:) = qns(:,:) * tmask(:,:,1) 386 #if defined key_lim3 387 qns_oce(:,:) = zqlw(:,:) - zqsb(:,:) - zqla(:,:) 388 qsr_oce(:,:) = qsr(:,:) 389 #endif 383 390 ! NB: if sea-ice model, the snow precip are computed and the associated heat is added to qns (see blk_ice_clio) 384 391 385 CALL iom_put( "qlw_oce", zqlw ) ! output downward longwave heat over the ocean 386 CALL iom_put( "qsb_oce", - zqsb ) ! output downward sensible heat over the ocean 387 CALL iom_put( "qla_oce", - zqla ) ! output downward latent heat over the ocean 388 CALL iom_put( "qns_oce", qns ) ! output downward non solar heat over the ocean 392 IF ( nn_ice == 0 ) THEN 393 CALL iom_put( "qlw_oce" , zqlw ) ! output downward longwave heat over the ocean 394 CALL iom_put( "qsb_oce" , - zqsb ) ! output downward sensible heat over the ocean 395 CALL iom_put( "qla_oce" , - zqla ) ! output downward latent heat over the ocean 396 CALL iom_put( "qemp_oce", qns-zqlw+zqsb+zqla ) ! output downward heat content of E-P over the ocean 397 CALL iom_put( "qns_oce" , qns ) ! output downward non solar heat over the ocean 398 CALL iom_put( "qsr_oce" , qsr ) ! output downward solar heat over the ocean 399 CALL iom_put( "qt_oce" , qns+qsr ) ! output total downward heat over the ocean 400 ENDIF 389 401 390 402 IF(ln_ctl) THEN … … 402 414 END SUBROUTINE blk_oce_clio 403 415 404 405 SUBROUTINE blk_ice_clio( pst , palb_cs, palb_os, palb, & 406 & p_taui, p_tauj, p_qns , p_qsr, & 407 & p_qla , p_dqns, p_dqla, & 408 & p_tpr , p_spr , & 409 & p_fr1 , p_fr2 , cd_grid, pdim ) 416 # if defined key_lim2 || defined key_lim3 417 SUBROUTINE blk_ice_clio_tau 410 418 !!--------------------------------------------------------------------------- 411 !! *** ROUTINE blk_ice_clio *** 419 !! *** ROUTINE blk_ice_clio_tau *** 420 !! 421 !! ** Purpose : Computation momentum flux at the ice-atm interface 422 !! 423 !! ** Method : Read utau from a forcing file. Rearrange if C-grid 424 !! 425 !!---------------------------------------------------------------------- 426 REAL(wp) :: zcoef 427 INTEGER :: ji, jj ! dummy loop indices 428 !!--------------------------------------------------------------------- 429 ! 430 IF( nn_timing == 1 ) CALL timing_start('blk_ice_clio_tau') 431 432 SELECT CASE( cp_ice_msh ) 433 434 CASE( 'C' ) ! C-grid ice dynamics 435 436 zcoef = cai / cao ! Change from air-sea stress to air-ice stress 437 utau_ice(:,:) = zcoef * utau(:,:) 438 vtau_ice(:,:) = zcoef * vtau(:,:) 439 440 CASE( 'I' ) ! I-grid ice dynamics: I-point (i.e. F-point lower-left corner) 441 442 zcoef = 0.5_wp * cai / cao ! Change from air-sea stress to air-ice stress 443 DO jj = 2, jpj ! stress from ocean U- and V-points to ice U,V point 444 DO ji = 2, jpi ! I-grid : no vector opt. 445 utau_ice(ji,jj) = zcoef * ( utau(ji-1,jj ) + utau(ji-1,jj-1) ) 446 vtau_ice(ji,jj) = zcoef * ( vtau(ji ,jj-1) + vtau(ji-1,jj-1) ) 447 END DO 448 END DO 449 450 CALL lbc_lnk( utau_ice(:,:), 'I', -1. ) ; CALL lbc_lnk( vtau_ice(:,:), 'I', -1. ) ! I-point 451 452 END SELECT 453 454 IF(ln_ctl) THEN 455 CALL prt_ctl(tab2d_1=utau_ice , clinfo1=' blk_ice_clio: utau_ice : ', tab2d_2=vtau_ice , clinfo2=' vtau_ice : ') 456 ENDIF 457 458 IF( nn_timing == 1 ) CALL timing_stop('blk_ice_clio_tau') 459 460 END SUBROUTINE blk_ice_clio_tau 461 #endif 462 463 # if defined key_lim2 || defined key_lim3 464 SUBROUTINE blk_ice_clio_flx( ptsu , palb_cs, palb_os, palb ) 465 !!--------------------------------------------------------------------------- 466 !! *** ROUTINE blk_ice_clio_flx *** 412 467 !! 413 468 !! ** Purpose : Computation of the heat fluxes at ocean and snow/ice … … 431 486 !! to take into account solid precip latent heat flux 432 487 !!---------------------------------------------------------------------- 433 REAL(wp), INTENT(in ), DIMENSION(:,:,:) :: p st! ice surface temperature [Kelvin]488 REAL(wp), INTENT(in ), DIMENSION(:,:,:) :: ptsu ! ice surface temperature [Kelvin] 434 489 REAL(wp), INTENT(in ), DIMENSION(:,:,:) :: palb_cs ! ice albedo (clear sky) (alb_ice_cs) [-] 435 490 REAL(wp), INTENT(in ), DIMENSION(:,:,:) :: palb_os ! ice albedo (overcast sky) (alb_ice_os) [-] 436 491 REAL(wp), INTENT( out), DIMENSION(:,:,:) :: palb ! ice albedo (actual value) [-] 437 REAL(wp), INTENT( out), DIMENSION(jpi,jpj) :: p_taui ! surface ice stress at I-point (i-component) [N/m2]438 REAL(wp), INTENT( out), DIMENSION(jpi,jpj) :: p_tauj ! surface ice stress at I-point (j-component) [N/m2]439 REAL(wp), INTENT( out), DIMENSION(:,:,:) :: p_qns ! non solar heat flux over ice (T-point) [W/m2]440 REAL(wp), INTENT( out), DIMENSION(:,:,:) :: p_qsr ! solar heat flux over ice (T-point) [W/m2]441 REAL(wp), INTENT( out), DIMENSION(:,:,:) :: p_qla ! latent heat flux over ice (T-point) [W/m2]442 REAL(wp), INTENT( out), DIMENSION(:,:,:) :: p_dqns ! non solar heat sensistivity (T-point) [W/m2]443 REAL(wp), INTENT( out), DIMENSION(:,:,:) :: p_dqla ! latent heat sensistivity (T-point) [W/m2]444 REAL(wp), INTENT( out), DIMENSION(jpi,jpj) :: p_tpr ! total precipitation (T-point) [Kg/m2/s]445 REAL(wp), INTENT( out), DIMENSION(jpi,jpj) :: p_spr ! solid precipitation (T-point) [Kg/m2/s]446 REAL(wp), INTENT( out), DIMENSION(jpi,jpj) :: p_fr1 ! 1sr fraction of qsr penetration in ice [-]447 REAL(wp), INTENT( out), DIMENSION(jpi,jpj) :: p_fr2 ! 2nd fraction of qsr penetration in ice [-]448 CHARACTER(len=1), INTENT(in ) :: cd_grid ! type of sea-ice grid ("C" or "B" grid)449 INTEGER, INTENT(in ) :: pdim ! number of ice categories450 492 !! 451 493 INTEGER :: ji, jj, jl ! dummy loop indices 452 INTEGER :: ijpl ! number of ice categories (size of 3rd dim of input arrays) 453 !! 454 REAL(wp) :: zcoef, zmt1, zmt2, zmt3, ztatm3 ! temporary scalars 494 !! 495 REAL(wp) :: zmt1, zmt2, zmt3, ztatm3 ! temporary scalars 455 496 REAL(wp) :: ztaevbk, zind1, zind2, zind3, ztamr ! - - 456 497 REAL(wp) :: zesi, zqsati, zdesidt ! - - … … 458 499 REAL(wp) :: zcshi, zclei, zrhovaclei, zrhovacshi ! - - 459 500 REAL(wp) :: ztice3, zticemb, zticemb2, zdqlw, zdqsb ! - - 501 REAL(wp) :: z1_lsub ! - - 460 502 !! 461 503 REAL(wp), DIMENSION(:,:) , POINTER :: ztatm ! Tair in Kelvin … … 464 506 REAL(wp), DIMENSION(:,:) , POINTER :: zrhoa ! air density 465 507 REAL(wp), DIMENSION(:,:,:), POINTER :: z_qlw, z_qsb 508 REAL(wp), DIMENSION(:,:) , POINTER :: zevap, zsnw 466 509 !!--------------------------------------------------------------------- 467 510 ! 468 IF( nn_timing == 1 ) CALL timing_start('blk_ice_clio ')511 IF( nn_timing == 1 ) CALL timing_start('blk_ice_clio_flx') 469 512 ! 470 513 CALL wrk_alloc( jpi,jpj, ztatm, zqatm, zevsqr, zrhoa ) 471 CALL wrk_alloc( jpi,jpj,pdim, z_qlw, z_qsb ) 472 473 ijpl = pdim ! number of ice categories 514 CALL wrk_alloc( jpi,jpj, jpl, z_qlw, z_qsb ) 515 474 516 zpatm = 101000. ! atmospheric pressure (assumed constant here) 475 476 #if defined key_lim3 477 tatm_ice(:,:) = sf(jp_tair)%fnow(:,:,1) ! LIM3: make Tair available in sea-ice. WARNING allocated after call to ice_init 478 #endif 479 ! ! surface ocean fluxes computed with CLIO bulk formulea 480 !------------------------------------! 481 ! momentum fluxes (utau, vtau ) ! 482 !------------------------------------! 483 484 SELECT CASE( cd_grid ) 485 CASE( 'C' ) ! C-grid ice dynamics 486 zcoef = cai / cao ! Change from air-sea stress to air-ice stress 487 p_taui(:,:) = zcoef * utau(:,:) 488 p_tauj(:,:) = zcoef * vtau(:,:) 489 CASE( 'I' ) ! I-grid ice dynamics: I-point (i.e. F-point lower-left corner) 490 zcoef = 0.5_wp * cai / cao ! Change from air-sea stress to air-ice stress 491 DO jj = 2, jpj ! stress from ocean U- and V-points to ice U,V point 492 DO ji = 2, jpi ! I-grid : no vector opt. 493 p_taui(ji,jj) = zcoef * ( utau(ji-1,jj ) + utau(ji-1,jj-1) ) 494 p_tauj(ji,jj) = zcoef * ( vtau(ji ,jj-1) + vtau(ji-1,jj-1) ) 495 END DO 496 END DO 497 CALL lbc_lnk( p_taui(:,:), 'I', -1. ) ; CALL lbc_lnk( p_tauj(:,:), 'I', -1. ) ! I-point 498 END SELECT 499 500 517 !-------------------------------------------------------------------------------- 501 518 ! Determine cloud optical depths as a function of latitude (Chou et al., 1981). 502 519 ! and the correction factor for taking into account the effect of clouds 503 !------------------------------------------------------ 520 !-------------------------------------------------------------------------------- 521 504 522 !CDIR NOVERRCHK 505 523 !CDIR COLLAPSE … … 528 546 zmt2 = ( 272.0 - ztatm(ji,jj) ) / 38.0 ; zind2 = MAX( 0.e0, SIGN( 1.e0, zmt2 ) ) 529 547 zmt3 = ( 281.0 - ztatm(ji,jj) ) / 18.0 ; zind3 = MAX( 0.e0, SIGN( 1.e0, zmt3 ) ) 530 p_spr(ji,jj) = sf(jp_prec)%fnow(ji,jj,1) / rday & ! rday = converte mm/day to kg/m2/s548 sprecip(ji,jj) = sf(jp_prec)%fnow(ji,jj,1) / rday & ! rday = converte mm/day to kg/m2/s 531 549 & * ( zind1 & ! solid (snow) precipitation [kg/m2/s] 532 550 & + ( 1.0 - zind1 ) * ( zind2 * ( 0.5 + zmt2 ) & … … 538 556 ! fraction of qsr_ice which is NOT absorbed in the thin surface layer 539 557 ! and thus which penetrates inside the ice cover ( Maykut and Untersteiner, 1971 ; Elbert anbd Curry, 1993 ) 540 p_fr1(ji,jj) = 0.18 * ( 1.e0 - sf(jp_ccov)%fnow(ji,jj,1) ) + 0.35 * sf(jp_ccov)%fnow(ji,jj,1)541 p_fr2(ji,jj) = 0.82 * ( 1.e0 - sf(jp_ccov)%fnow(ji,jj,1) ) + 0.65 * sf(jp_ccov)%fnow(ji,jj,1)542 END DO 543 END DO 544 CALL iom_put( 'snowpre', p_spr) ! Snow precipitation558 fr1_i0(ji,jj) = 0.18 * ( 1.e0 - sf(jp_ccov)%fnow(ji,jj,1) ) + 0.35 * sf(jp_ccov)%fnow(ji,jj,1) 559 fr2_i0(ji,jj) = 0.82 * ( 1.e0 - sf(jp_ccov)%fnow(ji,jj,1) ) + 0.65 * sf(jp_ccov)%fnow(ji,jj,1) 560 END DO 561 END DO 562 CALL iom_put( 'snowpre', sprecip ) ! Snow precipitation 545 563 546 564 !-----------------------------------------------------------! 547 565 ! snow/ice Shortwave radiation (abedo already computed) ! 548 566 !-----------------------------------------------------------! 549 CALL blk_clio_qsr_ice( palb_cs, palb_os, p_qsr)550 551 DO jl = 1, ijpl567 CALL blk_clio_qsr_ice( palb_cs, palb_os, qsr_ice ) 568 569 DO jl = 1, jpl 552 570 palb(:,:,jl) = ( palb_cs(:,:,jl) * ( 1.e0 - sf(jp_ccov)%fnow(:,:,1) ) & 553 571 & + palb_os(:,:,jl) * sf(jp_ccov)%fnow(:,:,1) ) … … 555 573 556 574 ! ! ========================== ! 557 DO jl = 1, ijpl ! Loop over ice categories !575 DO jl = 1, jpl ! Loop over ice categories ! 558 576 ! ! ========================== ! 559 577 !CDIR NOVERRCHK … … 569 587 ztaevbk = ztatm3 * ztatm(ji,jj) * zcldeff * ( 0.39 - 0.05 * zevsqr(ji,jj) ) 570 588 ! 571 z_qlw(ji,jj,jl) = - emic * stefan * ( ztaevbk + 4. * ztatm3 * ( p st(ji,jj,jl) - ztatm(ji,jj) ) )589 z_qlw(ji,jj,jl) = - emic * stefan * ( ztaevbk + 4. * ztatm3 * ( ptsu(ji,jj,jl) - ztatm(ji,jj) ) ) 572 590 573 591 !---------------------------------------- … … 576 594 577 595 ! vapour pressure at saturation of ice (tmask to avoid overflow in the exponential) 578 zesi = 611.0 * EXP( 21.8745587 * tmask(ji,jj,1) * ( p st(ji,jj,jl) - rtt )/ ( pst(ji,jj,jl) - 7.66 ) )596 zesi = 611.0 * EXP( 21.8745587 * tmask(ji,jj,1) * ( ptsu(ji,jj,jl) - rtt )/ ( ptsu(ji,jj,jl) - 7.66 ) ) 579 597 ! humidity close to the ice surface (at saturation) 580 598 zqsati = ( 0.622 * zesi ) / ( zpatm - 0.378 * zesi ) 581 599 582 600 ! computation of intermediate values 583 zticemb = p st(ji,jj,jl) - 7.66601 zticemb = ptsu(ji,jj,jl) - 7.66 584 602 zticemb2 = zticemb * zticemb 585 ztice3 = p st(ji,jj,jl) * pst(ji,jj,jl) * pst(ji,jj,jl)603 ztice3 = ptsu(ji,jj,jl) * ptsu(ji,jj,jl) * ptsu(ji,jj,jl) 586 604 zdesidt = zesi * ( 9.5 * LOG( 10.0 ) * ( rtt - 7.66 ) / zticemb2 ) 587 605 … … 596 614 597 615 ! sensible heat flux 598 z_qsb(ji,jj,jl) = zrhovacshi * ( p st(ji,jj,jl) - ztatm(ji,jj) )616 z_qsb(ji,jj,jl) = zrhovacshi * ( ptsu(ji,jj,jl) - ztatm(ji,jj) ) 599 617 600 618 ! latent heat flux 601 p_qla(ji,jj,jl) = MAX( 0.e0, zrhovaclei * ( zqsati - zqatm(ji,jj) ) )619 qla_ice(ji,jj,jl) = MAX( 0.e0, zrhovaclei * ( zqsati - zqatm(ji,jj) ) ) 602 620 603 621 ! sensitivity of non solar fluxes (dQ/dT) (long-wave, sensible and latent fluxes) … … 606 624 zdqla = zrhovaclei * ( zdesidt * ( zqsati * zqsati / ( zesi * zesi ) ) * ( zpatm / 0.622 ) ) 607 625 ! 608 p_dqla(ji,jj,jl) = zdqla ! latent flux sensitivity609 p_dqns(ji,jj,jl) = -( zdqlw + zdqsb + zdqla ) ! total non solar sensitivity626 dqla_ice(ji,jj,jl) = zdqla ! latent flux sensitivity 627 dqns_ice(ji,jj,jl) = -( zdqlw + zdqsb + zdqla ) ! total non solar sensitivity 610 628 END DO 611 629 ! … … 619 637 ! 620 638 !CDIR COLLAPSE 621 p_qns(:,:,:) = z_qlw (:,:,:) - z_qsb (:,:,:) - p_qla(:,:,:) ! Downward Non Solar flux622 !CDIR COLLAPSE 623 p_tpr(:,:) = sf(jp_prec)%fnow(:,:,1) / rday ! total precipitation [kg/m2/s]639 qns_ice(:,:,:) = z_qlw (:,:,:) - z_qsb (:,:,:) - qla_ice (:,:,:) ! Downward Non Solar flux 640 !CDIR COLLAPSE 641 tprecip(:,:) = sf(jp_prec)%fnow(:,:,1) / rday ! total precipitation [kg/m2/s] 624 642 ! 625 643 ! ----------------------------------------------------------------------------- ! … … 628 646 !CDIR COLLAPSE 629 647 qns(:,:) = qns(:,:) & ! update the non-solar heat flux with: 630 & - p_spr(:,:) * lfus & ! remove melting solid precip 631 & + p_spr(:,:) * MIN( sf(jp_tair)%fnow(:,:,1), rt0_snow - rt0 ) * cpic & ! add solid P at least below melting 632 & - p_spr(:,:) * sf(jp_tair)%fnow(:,:,1) * rcp ! remove solid precip. at Tair 633 ! 648 & - sprecip(:,:) * lfus & ! remove melting solid precip 649 & + sprecip(:,:) * MIN( sf(jp_tair)%fnow(:,:,1), rt0_snow - rt0 ) * cpic & ! add solid P at least below melting 650 & - sprecip(:,:) * sf(jp_tair)%fnow(:,:,1) * rcp ! remove solid precip. at Tair 651 652 #if defined key_lim3 653 ! ----------------------------------------------------------------------------- ! 654 ! Distribute evapo, precip & associated heat over ice and ocean 655 ! ---------------=====--------------------------------------------------------- ! 656 CALL wrk_alloc( jpi,jpj, zevap, zsnw ) 657 658 ! --- evaporation --- ! 659 z1_lsub = 1._wp / Lsub 660 evap_ice (:,:,:) = qla_ice (:,:,:) * z1_lsub ! sublimation 661 devap_ice(:,:,:) = dqla_ice(:,:,:) * z1_lsub 662 zevap (:,:) = emp(:,:) + tprecip(:,:) ! evaporation over ocean 663 664 ! --- evaporation minus precipitation --- ! 665 zsnw(:,:) = 0._wp 666 CALL lim_thd_snwblow( pfrld, zsnw ) ! snow redistribution by wind 667 emp_oce(:,:) = pfrld(:,:) * zevap(:,:) - ( tprecip(:,:) - sprecip(:,:) ) - sprecip(:,:) * ( 1._wp - zsnw ) 668 emp_ice(:,:) = SUM( a_i_b(:,:,:) * evap_ice(:,:,:), dim=3 ) - sprecip(:,:) * zsnw 669 emp_tot(:,:) = emp_oce(:,:) + emp_ice(:,:) 670 671 ! --- heat flux associated with emp --- ! 672 qemp_oce(:,:) = - pfrld(:,:) * zevap(:,:) * sst_m(:,:) * rcp & ! evap 673 & + ( tprecip(:,:) - sprecip(:,:) ) * ( sf(jp_tair)%fnow(:,:,1) - rt0 ) * rcp & ! liquid precip 674 & + sprecip(:,:) * ( 1._wp - zsnw ) * & ! solid precip 675 & ( ( MIN( sf(jp_tair)%fnow(:,:,1), rt0_snow ) - rt0 ) * cpic * tmask(:,:,1) - lfus ) 676 qemp_ice(:,:) = sprecip(:,:) * zsnw * & ! solid precip (only) 677 & ( ( MIN( sf(jp_tair)%fnow(:,:,1), rt0_snow ) - rt0 ) * cpic * tmask(:,:,1) - lfus ) 678 679 ! --- total solar and non solar fluxes --- ! 680 qns_tot(:,:) = pfrld(:,:) * qns_oce(:,:) + SUM( a_i_b(:,:,:) * qns_ice(:,:,:), dim=3 ) + qemp_ice(:,:) + qemp_oce(:,:) 681 qsr_tot(:,:) = pfrld(:,:) * qsr_oce(:,:) + SUM( a_i_b(:,:,:) * qsr_ice(:,:,:), dim=3 ) 682 683 ! --- heat content of precip over ice in J/m3 (to be used in 1D-thermo) --- ! 684 qprec_ice(:,:) = rhosn * ( ( MIN( sf(jp_tair)%fnow(:,:,1), rt0_snow ) - rt0 ) * cpic * tmask(:,:,1) - lfus ) 685 686 CALL wrk_dealloc( jpi,jpj, zevap, zsnw ) 687 #endif 688 634 689 !!gm : not necessary as all input data are lbc_lnk... 635 CALL lbc_lnk( p_fr1(:,:) , 'T', 1. )636 CALL lbc_lnk( p_fr2(:,:) , 'T', 1. )637 DO jl = 1, ijpl638 CALL lbc_lnk( p_qns(:,:,jl) , 'T', 1. )639 CALL lbc_lnk( p_dqns(:,:,jl) , 'T', 1. )640 CALL lbc_lnk( p_qla(:,:,jl) , 'T', 1. )641 CALL lbc_lnk( p_dqla(:,:,jl) , 'T', 1. )690 CALL lbc_lnk( fr1_i0 (:,:) , 'T', 1. ) 691 CALL lbc_lnk( fr2_i0 (:,:) , 'T', 1. ) 692 DO jl = 1, jpl 693 CALL lbc_lnk( qns_ice (:,:,jl) , 'T', 1. ) 694 CALL lbc_lnk( dqns_ice(:,:,jl) , 'T', 1. ) 695 CALL lbc_lnk( qla_ice (:,:,jl) , 'T', 1. ) 696 CALL lbc_lnk( dqla_ice(:,:,jl) , 'T', 1. ) 642 697 END DO 643 698 644 699 !!gm : mask is not required on forcing 645 DO jl = 1, ijpl 646 p_qns (:,:,jl) = p_qns (:,:,jl) * tmask(:,:,1) 647 p_qla (:,:,jl) = p_qla (:,:,jl) * tmask(:,:,1) 648 p_dqns(:,:,jl) = p_dqns(:,:,jl) * tmask(:,:,1) 649 p_dqla(:,:,jl) = p_dqla(:,:,jl) * tmask(:,:,1) 650 END DO 700 DO jl = 1, jpl 701 qns_ice (:,:,jl) = qns_ice (:,:,jl) * tmask(:,:,1) 702 qla_ice (:,:,jl) = qla_ice (:,:,jl) * tmask(:,:,1) 703 dqns_ice(:,:,jl) = dqns_ice(:,:,jl) * tmask(:,:,1) 704 dqla_ice(:,:,jl) = dqla_ice(:,:,jl) * tmask(:,:,1) 705 END DO 706 707 CALL wrk_dealloc( jpi,jpj, ztatm, zqatm, zevsqr, zrhoa ) 708 CALL wrk_dealloc( jpi,jpj, jpl , z_qlw, z_qsb ) 651 709 652 710 IF(ln_ctl) THEN 653 CALL prt_ctl(tab3d_1=z_qsb , clinfo1=' blk_ice_clio: z_qsb : ', tab3d_2=z_qlw , clinfo2=' z_qlw : ', kdim=ijpl) 654 CALL prt_ctl(tab3d_1=p_qla , clinfo1=' blk_ice_clio: z_qla : ', tab3d_2=p_qsr , clinfo2=' p_qsr : ', kdim=ijpl) 655 CALL prt_ctl(tab3d_1=p_dqns , clinfo1=' blk_ice_clio: p_dqns : ', tab3d_2=p_qns , clinfo2=' p_qns : ', kdim=ijpl) 656 CALL prt_ctl(tab3d_1=p_dqla , clinfo1=' blk_ice_clio: p_dqla : ', tab3d_2=pst , clinfo2=' pst : ', kdim=ijpl) 657 CALL prt_ctl(tab2d_1=p_tpr , clinfo1=' blk_ice_clio: p_tpr : ', tab2d_2=p_spr , clinfo2=' p_spr : ') 658 CALL prt_ctl(tab2d_1=p_taui , clinfo1=' blk_ice_clio: p_taui : ', tab2d_2=p_tauj , clinfo2=' p_tauj : ') 711 CALL prt_ctl(tab3d_1=z_qsb , clinfo1=' blk_ice_clio: z_qsb : ', tab3d_2=z_qlw , clinfo2=' z_qlw : ', kdim=jpl) 712 CALL prt_ctl(tab3d_1=qla_ice , clinfo1=' blk_ice_clio: z_qla : ', tab3d_2=qsr_ice , clinfo2=' qsr_ice : ', kdim=jpl) 713 CALL prt_ctl(tab3d_1=dqns_ice , clinfo1=' blk_ice_clio: dqns_ice : ', tab3d_2=qns_ice , clinfo2=' qns_ice : ', kdim=jpl) 714 CALL prt_ctl(tab3d_1=dqla_ice , clinfo1=' blk_ice_clio: dqla_ice : ', tab3d_2=ptsu , clinfo2=' ptsu : ', kdim=jpl) 715 CALL prt_ctl(tab2d_1=tprecip , clinfo1=' blk_ice_clio: tprecip : ', tab2d_2=sprecip , clinfo2=' sprecip : ') 659 716 ENDIF 660 717 661 CALL wrk_dealloc( jpi,jpj, ztatm, zqatm, zevsqr, zrhoa ) 662 CALL wrk_dealloc( jpi,jpj,pdim, z_qlw, z_qsb ) 663 ! 664 IF( nn_timing == 1 ) CALL timing_stop('blk_ice_clio') 665 ! 666 END SUBROUTINE blk_ice_clio 667 718 IF( nn_timing == 1 ) CALL timing_stop('blk_ice_clio_flx') 719 ! 720 END SUBROUTINE blk_ice_clio_flx 721 722 #endif 668 723 669 724 SUBROUTINE blk_clio_qsr_oce( pqsr_oce ) -
branches/2014/dev_r4621_NOC4_BDY_VERT_INTERP/NEMOGCM/NEMO/OPA_SRC/SBC/sbcblk_core.F90
r5038 r5620 22 22 !! blk_oce_core : computes momentum, heat and freshwater fluxes over ocean 23 23 !! blk_ice_core : computes momentum, heat and freshwater fluxes over ice 24 !! blk_bio_meanqsr : compute daily mean short wave radiation over the ocean25 !! blk_ice_meanqsr : compute daily mean short wave radiation over the ice26 24 !! turb_core_2z : Computes turbulent transfert coefficients 27 25 !! cd_neutral_10m : Estimate of the neutral drag coefficient at 10m … … 46 44 USE sbc_ice ! Surface boundary condition: ice fields 47 45 USE lib_fortran ! to use key_nosignedzero 46 #if defined key_lim3 47 USE ice, ONLY : u_ice, v_ice, jpl, pfrld, a_i_b 48 USE limthd_dh ! for CALL lim_thd_snwblow 49 #elif defined key_lim2 50 USE ice_2, ONLY : u_ice, v_ice 51 USE par_ice_2 52 #endif 48 53 49 54 IMPLICIT NONE … … 51 56 52 57 PUBLIC sbc_blk_core ! routine called in sbcmod module 53 PUBLIC blk_ice_core ! routine called in sbc_ice_lim module 54 PUBLIC blk_ice_meanqsr ! routine called in sbc_ice_lim module 58 #if defined key_lim2 || defined key_lim3 59 PUBLIC blk_ice_core_tau ! routine called in sbc_ice_lim module 60 PUBLIC blk_ice_core_flx ! routine called in sbc_ice_lim module 61 #endif 55 62 PUBLIC turb_core_2z ! routine calles in sbcblk_mfs module 56 63 … … 195 202 ! ! compute the surface ocean fluxes using CORE bulk formulea 196 203 IF( MOD( kt - 1, nn_fsbc ) == 0 ) CALL blk_oce_core( kt, sf, sst_m, ssu_m, ssv_m ) 197 198 ! If diurnal cycle is activated, compute a daily mean short waves flux for biogeochemistery199 IF( ltrcdm2dc ) CALL blk_bio_meanqsr200 204 201 205 #if defined key_cice … … 302 306 ELSE ; qsr(:,:) = zztmp * sf(jp_qsr)%fnow(:,:,1) * tmask(:,:,1) 303 307 ENDIF 308 304 309 zqlw(:,:) = ( sf(jp_qlw)%fnow(:,:,1) - Stef * zst(:,:)*zst(:,:)*zst(:,:)*zst(:,:) ) * tmask(:,:,1) ! Long Wave 305 310 ! ----------------------------------------------------------------------------- ! … … 376 381 emp (:,:) = ( zevap(:,:) & ! mass flux (evap. - precip.) 377 382 & - sf(jp_prec)%fnow(:,:,1) * rn_pfac ) * tmask(:,:,1) 378 qns(:,:) = zqlw(:,:) - zqsb(:,:) - zqla(:,:) & ! Downward Non Solar flux 383 ! 384 qns(:,:) = zqlw(:,:) - zqsb(:,:) - zqla(:,:) & ! Downward Non Solar 379 385 & - sf(jp_snow)%fnow(:,:,1) * rn_pfac * lfus & ! remove latent melting heat for solid precip 380 386 & - zevap(:,:) * pst(:,:) * rcp & ! remove evap heat content at SST … … 384 390 & * ( MIN( sf(jp_tair)%fnow(:,:,1), rt0_snow ) - rt0 ) * cpic * tmask(:,:,1) 385 391 ! 386 CALL iom_put( "qlw_oce", zqlw ) ! output downward longwave heat over the ocean 387 CALL iom_put( "qsb_oce", - zqsb ) ! output downward sensible heat over the ocean 388 CALL iom_put( "qla_oce", - zqla ) ! output downward latent heat over the ocean 389 CALL iom_put( "qhc_oce", qns-zqlw+zqsb+zqla ) ! output downward heat content of E-P over the ocean 390 CALL iom_put( "qns_oce", qns ) ! output downward non solar heat over the ocean 392 #if defined key_lim3 393 qns_oce(:,:) = zqlw(:,:) - zqsb(:,:) - zqla(:,:) ! non solar without emp (only needed by LIM3) 394 qsr_oce(:,:) = qsr(:,:) 395 #endif 396 ! 397 IF ( nn_ice == 0 ) THEN 398 CALL iom_put( "qlw_oce" , zqlw ) ! output downward longwave heat over the ocean 399 CALL iom_put( "qsb_oce" , - zqsb ) ! output downward sensible heat over the ocean 400 CALL iom_put( "qla_oce" , - zqla ) ! output downward latent heat over the ocean 401 CALL iom_put( "qemp_oce", qns-zqlw+zqsb+zqla ) ! output downward heat content of E-P over the ocean 402 CALL iom_put( "qns_oce" , qns ) ! output downward non solar heat over the ocean 403 CALL iom_put( "qsr_oce" , qsr ) ! output downward solar heat over the ocean 404 CALL iom_put( "qt_oce" , qns+qsr ) ! output total downward heat over the ocean 405 tprecip(:,:) = sf(jp_prec)%fnow(:,:,1) * rn_pfac ! output total precipitation [kg/m2/s] 406 sprecip(:,:) = sf(jp_snow)%fnow(:,:,1) * rn_pfac ! output solid precipitation [kg/m2/s] 407 CALL iom_put( 'snowpre', sprecip * 86400. ) ! Snow 408 CALL iom_put( 'precip' , tprecip * 86400. ) ! Total precipitation 409 ENDIF 391 410 ! 392 411 IF(ln_ctl) THEN … … 406 425 407 426 408 SUBROUTINE blk_ice_core( pst , pui , pvi , palb , & 409 & p_taui, p_tauj, p_qns , p_qsr, & 410 & p_qla , p_dqns, p_dqla, & 411 & p_tpr , p_spr , & 412 & p_fr1 , p_fr2 , cd_grid, pdim ) 413 !!--------------------------------------------------------------------- 414 !! *** ROUTINE blk_ice_core *** 427 #if defined key_lim2 || defined key_lim3 428 SUBROUTINE blk_ice_core_tau 429 !!--------------------------------------------------------------------- 430 !! *** ROUTINE blk_ice_core_tau *** 415 431 !! 416 432 !! ** Purpose : provide the surface boundary condition over sea-ice 417 433 !! 418 !! ** Method : compute momentum, heat and freshwater exchanged 419 !! between atmosphere and sea-ice using CORE bulk 420 !! formulea, ice variables and read atmmospheric fields. 434 !! ** Method : compute momentum using CORE bulk 435 !! formulea, ice variables and read atmospheric fields. 421 436 !! NB: ice drag coefficient is assumed to be a constant 422 !! 423 !! caution : the net upward water flux has with mm/day unit 424 !!--------------------------------------------------------------------- 425 REAL(wp), DIMENSION(:,:,:), INTENT(in ) :: pst ! ice surface temperature (>0, =rt0 over land) [Kelvin] 426 REAL(wp), DIMENSION(:,:) , INTENT(in ) :: pui ! ice surface velocity (i- and i- components [m/s] 427 REAL(wp), DIMENSION(:,:) , INTENT(in ) :: pvi ! at I-point (B-grid) or U & V-point (C-grid) 428 REAL(wp), DIMENSION(:,:,:), INTENT(in ) :: palb ! ice albedo (all skies) [%] 429 REAL(wp), DIMENSION(:,:) , INTENT( out) :: p_taui ! i- & j-components of surface ice stress [N/m2] 430 REAL(wp), DIMENSION(:,:) , INTENT( out) :: p_tauj ! at I-point (B-grid) or U & V-point (C-grid) 431 REAL(wp), DIMENSION(:,:,:), INTENT( out) :: p_qns ! non solar heat flux over ice (T-point) [W/m2] 432 REAL(wp), DIMENSION(:,:,:), INTENT( out) :: p_qsr ! solar heat flux over ice (T-point) [W/m2] 433 REAL(wp), DIMENSION(:,:,:), INTENT( out) :: p_qla ! latent heat flux over ice (T-point) [W/m2] 434 REAL(wp), DIMENSION(:,:,:), INTENT( out) :: p_dqns ! non solar heat sensistivity (T-point) [W/m2] 435 REAL(wp), DIMENSION(:,:,:), INTENT( out) :: p_dqla ! latent heat sensistivity (T-point) [W/m2] 436 REAL(wp), DIMENSION(:,:) , INTENT( out) :: p_tpr ! total precipitation (T-point) [Kg/m2/s] 437 REAL(wp), DIMENSION(:,:) , INTENT( out) :: p_spr ! solid precipitation (T-point) [Kg/m2/s] 438 REAL(wp), DIMENSION(:,:) , INTENT( out) :: p_fr1 ! 1sr fraction of qsr penetration in ice (T-point) [%] 439 REAL(wp), DIMENSION(:,:) , INTENT( out) :: p_fr2 ! 2nd fraction of qsr penetration in ice (T-point) [%] 440 CHARACTER(len=1) , INTENT(in ) :: cd_grid ! ice grid ( C or B-grid) 441 INTEGER , INTENT(in ) :: pdim ! number of ice categories 442 !! 443 INTEGER :: ji, jj, jl ! dummy loop indices 444 INTEGER :: ijpl ! number of ice categories (size of 3rd dim of input arrays) 445 REAL(wp) :: zst2, zst3 446 REAL(wp) :: zcoef_wnorm, zcoef_wnorm2, zcoef_dqlw, zcoef_dqla, zcoef_dqsb 447 REAL(wp) :: zztmp ! temporary variable 448 REAL(wp) :: zwnorm_f, zwndi_f , zwndj_f ! relative wind module and components at F-point 449 REAL(wp) :: zwndi_t , zwndj_t ! relative wind components at T-point 450 !! 451 REAL(wp), DIMENSION(:,:) , POINTER :: z_wnds_t ! wind speed ( = | U10m - U_ice | ) at T-point 452 REAL(wp), DIMENSION(:,:,:), POINTER :: z_qlw ! long wave heat flux over ice 453 REAL(wp), DIMENSION(:,:,:), POINTER :: z_qsb ! sensible heat flux over ice 454 REAL(wp), DIMENSION(:,:,:), POINTER :: z_dqlw ! long wave heat sensitivity over ice 455 REAL(wp), DIMENSION(:,:,:), POINTER :: z_dqsb ! sensible heat sensitivity over ice 456 !!--------------------------------------------------------------------- 457 ! 458 IF( nn_timing == 1 ) CALL timing_start('blk_ice_core') 459 ! 460 CALL wrk_alloc( jpi,jpj, z_wnds_t ) 461 CALL wrk_alloc( jpi,jpj,pdim, z_qlw, z_qsb, z_dqlw, z_dqsb ) 462 463 ijpl = pdim ! number of ice categories 464 437 !!--------------------------------------------------------------------- 438 INTEGER :: ji, jj ! dummy loop indices 439 REAL(wp) :: zcoef_wnorm, zcoef_wnorm2 440 REAL(wp) :: zwnorm_f, zwndi_f , zwndj_f ! relative wind module and components at F-point 441 REAL(wp) :: zwndi_t , zwndj_t ! relative wind components at T-point 442 !!--------------------------------------------------------------------- 443 ! 444 IF( nn_timing == 1 ) CALL timing_start('blk_ice_core_tau') 445 ! 465 446 ! local scalars ( place there for vector optimisation purposes) 466 447 zcoef_wnorm = rhoa * Cice 467 448 zcoef_wnorm2 = rhoa * Cice * 0.5 468 zcoef_dqlw = 4.0 * 0.95 * Stef469 zcoef_dqla = -Ls * Cice * 11637800. * (-5897.8)470 zcoef_dqsb = rhoa * cpa * Cice471 449 472 450 !!gm brutal.... 473 z_wnds_t(:,:) = 0.e0474 p_taui (:,:) = 0.e0475 p_tauj (:,:) = 0.e0451 utau_ice (:,:) = 0._wp 452 vtau_ice (:,:) = 0._wp 453 wndm_ice (:,:) = 0._wp 476 454 !!gm end 477 455 478 #if defined key_lim3479 tatm_ice(:,:) = sf(jp_tair)%fnow(:,:,1) ! LIM3: make Tair available in sea-ice. WARNING allocated after call to ice_init480 #endif481 456 ! ----------------------------------------------------------------------------- ! 482 457 ! Wind components and module relative to the moving ocean ( U10m - U_ice ) ! 483 458 ! ----------------------------------------------------------------------------- ! 484 SELECT CASE( c d_grid)459 SELECT CASE( cp_ice_msh ) 485 460 CASE( 'I' ) ! B-grid ice dynamics : I-point (i.e. F-point with sea-ice indexation) 486 461 ! and scalar wind at T-point ( = | U10m - U_ice | ) (masked) … … 489 464 ! ... scalar wind at I-point (fld being at T-point) 490 465 zwndi_f = 0.25 * ( sf(jp_wndi)%fnow(ji-1,jj ,1) + sf(jp_wndi)%fnow(ji ,jj ,1) & 491 & + sf(jp_wndi)%fnow(ji-1,jj-1,1) + sf(jp_wndi)%fnow(ji ,jj-1,1) ) - rn_vfac * pui(ji,jj)466 & + sf(jp_wndi)%fnow(ji-1,jj-1,1) + sf(jp_wndi)%fnow(ji ,jj-1,1) ) - rn_vfac * u_ice(ji,jj) 492 467 zwndj_f = 0.25 * ( sf(jp_wndj)%fnow(ji-1,jj ,1) + sf(jp_wndj)%fnow(ji ,jj ,1) & 493 & + sf(jp_wndj)%fnow(ji-1,jj-1,1) + sf(jp_wndj)%fnow(ji ,jj-1,1) ) - rn_vfac * pvi(ji,jj)468 & + sf(jp_wndj)%fnow(ji-1,jj-1,1) + sf(jp_wndj)%fnow(ji ,jj-1,1) ) - rn_vfac * v_ice(ji,jj) 494 469 zwnorm_f = zcoef_wnorm * SQRT( zwndi_f * zwndi_f + zwndj_f * zwndj_f ) 495 470 ! ... ice stress at I-point 496 p_taui(ji,jj) = zwnorm_f * zwndi_f497 p_tauj(ji,jj) = zwnorm_f * zwndj_f471 utau_ice(ji,jj) = zwnorm_f * zwndi_f 472 vtau_ice(ji,jj) = zwnorm_f * zwndj_f 498 473 ! ... scalar wind at T-point (fld being at T-point) 499 zwndi_t = sf(jp_wndi)%fnow(ji,jj,1) - rn_vfac * 0.25 * ( pui(ji,jj+1) + pui(ji+1,jj+1) &500 & + pui(ji,jj ) + pui(ji+1,jj ) )501 zwndj_t = sf(jp_wndj)%fnow(ji,jj,1) - rn_vfac * 0.25 * ( pvi(ji,jj+1) + pvi(ji+1,jj+1) &502 & + pvi(ji,jj ) + pvi(ji+1,jj ) )503 z_wnds_t(ji,jj) = SQRT( zwndi_t * zwndi_t + zwndj_t * zwndj_t ) * tmask(ji,jj,1)474 zwndi_t = sf(jp_wndi)%fnow(ji,jj,1) - rn_vfac * 0.25 * ( u_ice(ji,jj+1) + u_ice(ji+1,jj+1) & 475 & + u_ice(ji,jj ) + u_ice(ji+1,jj ) ) 476 zwndj_t = sf(jp_wndj)%fnow(ji,jj,1) - rn_vfac * 0.25 * ( v_ice(ji,jj+1) + v_ice(ji+1,jj+1) & 477 & + v_ice(ji,jj ) + v_ice(ji+1,jj ) ) 478 wndm_ice(ji,jj) = SQRT( zwndi_t * zwndi_t + zwndj_t * zwndj_t ) * tmask(ji,jj,1) 504 479 END DO 505 480 END DO 506 CALL lbc_lnk( p_taui, 'I', -1. )507 CALL lbc_lnk( p_tauj, 'I', -1. )508 CALL lbc_lnk( z_wnds_t, 'T', 1. )481 CALL lbc_lnk( utau_ice, 'I', -1. ) 482 CALL lbc_lnk( vtau_ice, 'I', -1. ) 483 CALL lbc_lnk( wndm_ice, 'T', 1. ) 509 484 ! 510 485 CASE( 'C' ) ! C-grid ice dynamics : U & V-points (same as ocean) 511 486 DO jj = 2, jpj 512 487 DO ji = fs_2, jpi ! vect. opt. 513 zwndi_t = ( sf(jp_wndi)%fnow(ji,jj,1) - rn_vfac * 0.5 * ( pui(ji-1,jj ) + pui(ji,jj) ) )514 zwndj_t = ( sf(jp_wndj)%fnow(ji,jj,1) - rn_vfac * 0.5 * ( pvi(ji ,jj-1) + pvi(ji,jj) ) )515 z_wnds_t(ji,jj)= SQRT( zwndi_t * zwndi_t + zwndj_t * zwndj_t ) * tmask(ji,jj,1)488 zwndi_t = ( sf(jp_wndi)%fnow(ji,jj,1) - rn_vfac * 0.5 * ( u_ice(ji-1,jj ) + u_ice(ji,jj) ) ) 489 zwndj_t = ( sf(jp_wndj)%fnow(ji,jj,1) - rn_vfac * 0.5 * ( v_ice(ji ,jj-1) + v_ice(ji,jj) ) ) 490 wndm_ice(ji,jj) = SQRT( zwndi_t * zwndi_t + zwndj_t * zwndj_t ) * tmask(ji,jj,1) 516 491 END DO 517 492 END DO 518 493 DO jj = 2, jpjm1 519 494 DO ji = fs_2, fs_jpim1 ! vect. opt. 520 p_taui(ji,jj) = zcoef_wnorm2 * ( z_wnds_t(ji+1,jj ) + z_wnds_t(ji,jj) ) &521 & * ( 0.5 * (sf(jp_wndi)%fnow(ji+1,jj,1) + sf(jp_wndi)%fnow(ji,jj,1) ) - rn_vfac * pui(ji,jj) )522 p_tauj(ji,jj) = zcoef_wnorm2 * ( z_wnds_t(ji,jj+1 ) + z_wnds_t(ji,jj) ) &523 & * ( 0.5 * (sf(jp_wndj)%fnow(ji,jj+1,1) + sf(jp_wndj)%fnow(ji,jj,1) ) - rn_vfac * pvi(ji,jj) )495 utau_ice(ji,jj) = zcoef_wnorm2 * ( wndm_ice(ji+1,jj ) + wndm_ice(ji,jj) ) & 496 & * ( 0.5 * (sf(jp_wndi)%fnow(ji+1,jj,1) + sf(jp_wndi)%fnow(ji,jj,1) ) - rn_vfac * u_ice(ji,jj) ) 497 vtau_ice(ji,jj) = zcoef_wnorm2 * ( wndm_ice(ji,jj+1 ) + wndm_ice(ji,jj) ) & 498 & * ( 0.5 * (sf(jp_wndj)%fnow(ji,jj+1,1) + sf(jp_wndj)%fnow(ji,jj,1) ) - rn_vfac * v_ice(ji,jj) ) 524 499 END DO 525 500 END DO 526 CALL lbc_lnk( p_taui, 'U', -1. )527 CALL lbc_lnk( p_tauj, 'V', -1. )528 CALL lbc_lnk( z_wnds_t, 'T', 1. )501 CALL lbc_lnk( utau_ice, 'U', -1. ) 502 CALL lbc_lnk( vtau_ice, 'V', -1. ) 503 CALL lbc_lnk( wndm_ice, 'T', 1. ) 529 504 ! 530 505 END SELECT 506 507 IF(ln_ctl) THEN 508 CALL prt_ctl(tab2d_1=utau_ice , clinfo1=' blk_ice_core: utau_ice : ', tab2d_2=vtau_ice , clinfo2=' vtau_ice : ') 509 CALL prt_ctl(tab2d_1=wndm_ice , clinfo1=' blk_ice_core: wndm_ice : ') 510 ENDIF 511 512 IF( nn_timing == 1 ) CALL timing_stop('blk_ice_core_tau') 513 514 END SUBROUTINE blk_ice_core_tau 515 516 517 SUBROUTINE blk_ice_core_flx( ptsu, palb ) 518 !!--------------------------------------------------------------------- 519 !! *** ROUTINE blk_ice_core_flx *** 520 !! 521 !! ** Purpose : provide the surface boundary condition over sea-ice 522 !! 523 !! ** Method : compute heat and freshwater exchanged 524 !! between atmosphere and sea-ice using CORE bulk 525 !! formulea, ice variables and read atmmospheric fields. 526 !! 527 !! caution : the net upward water flux has with mm/day unit 528 !!--------------------------------------------------------------------- 529 REAL(wp), DIMENSION(:,:,:), INTENT(in) :: ptsu ! sea ice surface temperature 530 REAL(wp), DIMENSION(:,:,:), INTENT(in) :: palb ! ice albedo (all skies) 531 !! 532 INTEGER :: ji, jj, jl ! dummy loop indices 533 REAL(wp) :: zst2, zst3 534 REAL(wp) :: zcoef_dqlw, zcoef_dqla, zcoef_dqsb 535 REAL(wp) :: zztmp, z1_lsub ! temporary variable 536 !! 537 REAL(wp), DIMENSION(:,:,:), POINTER :: z_qlw ! long wave heat flux over ice 538 REAL(wp), DIMENSION(:,:,:), POINTER :: z_qsb ! sensible heat flux over ice 539 REAL(wp), DIMENSION(:,:,:), POINTER :: z_dqlw ! long wave heat sensitivity over ice 540 REAL(wp), DIMENSION(:,:,:), POINTER :: z_dqsb ! sensible heat sensitivity over ice 541 REAL(wp), DIMENSION(:,:) , POINTER :: zevap, zsnw ! evaporation and snw distribution after wind blowing (LIM3) 542 !!--------------------------------------------------------------------- 543 ! 544 IF( nn_timing == 1 ) CALL timing_start('blk_ice_core_flx') 545 ! 546 CALL wrk_alloc( jpi,jpj,jpl, z_qlw, z_qsb, z_dqlw, z_dqsb ) 547 548 ! local scalars ( place there for vector optimisation purposes) 549 zcoef_dqlw = 4.0 * 0.95 * Stef 550 zcoef_dqla = -Ls * Cice * 11637800. * (-5897.8) 551 zcoef_dqsb = rhoa * cpa * Cice 531 552 532 553 zztmp = 1. / ( 1. - albo ) 533 554 ! ! ========================== ! 534 DO jl = 1, ijpl! Loop over ice categories !555 DO jl = 1, jpl ! Loop over ice categories ! 535 556 ! ! ========================== ! 536 557 DO jj = 1 , jpj … … 539 560 ! I Radiative FLUXES ! 540 561 ! ----------------------------! 541 zst2 = p st(ji,jj,jl) * pst(ji,jj,jl)542 zst3 = p st(ji,jj,jl) * zst2562 zst2 = ptsu(ji,jj,jl) * ptsu(ji,jj,jl) 563 zst3 = ptsu(ji,jj,jl) * zst2 543 564 ! Short Wave (sw) 544 p_qsr(ji,jj,jl) = zztmp * ( 1. - palb(ji,jj,jl) ) * qsr(ji,jj)565 qsr_ice(ji,jj,jl) = zztmp * ( 1. - palb(ji,jj,jl) ) * qsr(ji,jj) 545 566 ! Long Wave (lw) 546 z_qlw(ji,jj,jl) = 0.95 * ( sf(jp_qlw)%fnow(ji,jj,1) - Stef * p st(ji,jj,jl) * zst3 ) * tmask(ji,jj,1)567 z_qlw(ji,jj,jl) = 0.95 * ( sf(jp_qlw)%fnow(ji,jj,1) - Stef * ptsu(ji,jj,jl) * zst3 ) * tmask(ji,jj,1) 547 568 ! lw sensitivity 548 569 z_dqlw(ji,jj,jl) = zcoef_dqlw * zst3 … … 554 575 ! ... turbulent heat fluxes 555 576 ! Sensible Heat 556 z_qsb(ji,jj,jl) = rhoa * cpa * Cice * z_wnds_t(ji,jj) * ( pst(ji,jj,jl) - sf(jp_tair)%fnow(ji,jj,1) )577 z_qsb(ji,jj,jl) = rhoa * cpa * Cice * wndm_ice(ji,jj) * ( ptsu(ji,jj,jl) - sf(jp_tair)%fnow(ji,jj,1) ) 557 578 ! Latent Heat 558 p_qla(ji,jj,jl) = rn_efac * MAX( 0.e0, rhoa * Ls * Cice * z_wnds_t(ji,jj) &559 & * ( 11637800. * EXP( -5897.8 / p st(ji,jj,jl) ) / rhoa - sf(jp_humi)%fnow(ji,jj,1) ) )560 561 IF( p_qla(ji,jj,jl) > 0._wp ) THEN562 p_dqla(ji,jj,jl) = rn_efac * zcoef_dqla * z_wnds_t(ji,jj) / ( zst2 ) * EXP( -5897.8 / pst(ji,jj,jl) )579 qla_ice(ji,jj,jl) = rn_efac * MAX( 0.e0, rhoa * Ls * Cice * wndm_ice(ji,jj) & 580 & * ( 11637800. * EXP( -5897.8 / ptsu(ji,jj,jl) ) / rhoa - sf(jp_humi)%fnow(ji,jj,1) ) ) 581 ! Latent heat sensitivity for ice (Dqla/Dt) 582 IF( qla_ice(ji,jj,jl) > 0._wp ) THEN 583 dqla_ice(ji,jj,jl) = rn_efac * zcoef_dqla * wndm_ice(ji,jj) / ( zst2 ) * EXP( -5897.8 / ptsu(ji,jj,jl) ) 563 584 ELSE 564 p_dqla(ji,jj,jl) = 0._wp585 dqla_ice(ji,jj,jl) = 0._wp 565 586 ENDIF 566 587 567 588 ! Sensible heat sensitivity (Dqsb_ice/Dtn_ice) 568 z_dqsb(ji,jj,jl) = zcoef_dqsb * z_wnds_t(ji,jj)589 z_dqsb(ji,jj,jl) = zcoef_dqsb * wndm_ice(ji,jj) 569 590 570 591 ! ----------------------------! … … 572 593 ! ----------------------------! 573 594 ! Downward Non Solar flux 574 p_qns (ji,jj,jl) = z_qlw (ji,jj,jl) - z_qsb (ji,jj,jl) - p_qla(ji,jj,jl)595 qns_ice (ji,jj,jl) = z_qlw (ji,jj,jl) - z_qsb (ji,jj,jl) - qla_ice (ji,jj,jl) 575 596 ! Total non solar heat flux sensitivity for ice 576 p_dqns(ji,jj,jl) = - ( z_dqlw(ji,jj,jl) + z_dqsb(ji,jj,jl) + p_dqla(ji,jj,jl) )597 dqns_ice(ji,jj,jl) = - ( z_dqlw(ji,jj,jl) + z_dqsb(ji,jj,jl) + dqla_ice(ji,jj,jl) ) 577 598 END DO 578 599 ! … … 581 602 END DO 582 603 ! 604 tprecip(:,:) = sf(jp_prec)%fnow(:,:,1) * rn_pfac ! total precipitation [kg/m2/s] 605 sprecip(:,:) = sf(jp_snow)%fnow(:,:,1) * rn_pfac ! solid precipitation [kg/m2/s] 606 CALL iom_put( 'snowpre', sprecip * 86400. ) ! Snow precipitation 607 CALL iom_put( 'precip' , tprecip * 86400. ) ! Total precipitation 608 609 #if defined key_lim3 610 CALL wrk_alloc( jpi,jpj, zevap, zsnw ) 611 612 ! --- evaporation --- ! 613 z1_lsub = 1._wp / Lsub 614 evap_ice (:,:,:) = qla_ice (:,:,:) * z1_lsub ! sublimation 615 devap_ice(:,:,:) = dqla_ice(:,:,:) * z1_lsub 616 zevap (:,:) = emp(:,:) + tprecip(:,:) ! evaporation over ocean 617 618 ! --- evaporation minus precipitation --- ! 619 zsnw(:,:) = 0._wp 620 CALL lim_thd_snwblow( pfrld, zsnw ) ! snow distribution over ice after wind blowing 621 emp_oce(:,:) = pfrld(:,:) * zevap(:,:) - ( tprecip(:,:) - sprecip(:,:) ) - sprecip(:,:) * (1._wp - zsnw ) 622 emp_ice(:,:) = SUM( a_i_b(:,:,:) * evap_ice(:,:,:), dim=3 ) - sprecip(:,:) * zsnw 623 emp_tot(:,:) = emp_oce(:,:) + emp_ice(:,:) 624 625 ! --- heat flux associated with emp --- ! 626 qemp_oce(:,:) = - pfrld(:,:) * zevap(:,:) * sst_m(:,:) * rcp & ! evap at sst 627 & + ( tprecip(:,:) - sprecip(:,:) ) * ( sf(jp_tair)%fnow(:,:,1) - rt0 ) * rcp & ! liquid precip at Tair 628 & + sprecip(:,:) * ( 1._wp - zsnw ) * & ! solid precip at min(Tair,Tsnow) 629 & ( ( MIN( sf(jp_tair)%fnow(:,:,1), rt0_snow ) - rt0 ) * cpic * tmask(:,:,1) - lfus ) 630 qemp_ice(:,:) = sprecip(:,:) * zsnw * & ! solid precip (only) 631 & ( ( MIN( sf(jp_tair)%fnow(:,:,1), rt0_snow ) - rt0 ) * cpic * tmask(:,:,1) - lfus ) 632 633 ! --- total solar and non solar fluxes --- ! 634 qns_tot(:,:) = pfrld(:,:) * qns_oce(:,:) + SUM( a_i_b(:,:,:) * qns_ice(:,:,:), dim=3 ) + qemp_ice(:,:) + qemp_oce(:,:) 635 qsr_tot(:,:) = pfrld(:,:) * qsr_oce(:,:) + SUM( a_i_b(:,:,:) * qsr_ice(:,:,:), dim=3 ) 636 637 ! --- heat content of precip over ice in J/m3 (to be used in 1D-thermo) --- ! 638 qprec_ice(:,:) = rhosn * ( ( MIN( sf(jp_tair)%fnow(:,:,1), rt0_snow ) - rt0 ) * cpic * tmask(:,:,1) - lfus ) 639 640 CALL wrk_dealloc( jpi,jpj, zevap, zsnw ) 641 #endif 642 583 643 !-------------------------------------------------------------------- 584 644 ! FRACTIONs of net shortwave radiation which is not absorbed in the … … 586 646 ! ( Maykut and Untersteiner, 1971 ; Ebert and Curry, 1993 ) 587 647 ! 588 p_fr1(:,:) = ( 0.18 * ( 1.0 - cldf_ice ) + 0.35 * cldf_ice ) 589 p_fr2(:,:) = ( 0.82 * ( 1.0 - cldf_ice ) + 0.65 * cldf_ice ) 590 ! 591 p_tpr(:,:) = sf(jp_prec)%fnow(:,:,1) * rn_pfac ! total precipitation [kg/m2/s] 592 p_spr(:,:) = sf(jp_snow)%fnow(:,:,1) * rn_pfac ! solid precipitation [kg/m2/s] 593 CALL iom_put( 'snowpre', p_spr * 86400. ) ! Snow precipitation 594 CALL iom_put( 'precip' , p_tpr * 86400. ) ! Total precipitation 648 fr1_i0(:,:) = ( 0.18 * ( 1.0 - cldf_ice ) + 0.35 * cldf_ice ) 649 fr2_i0(:,:) = ( 0.82 * ( 1.0 - cldf_ice ) + 0.65 * cldf_ice ) 650 ! 595 651 ! 596 652 IF(ln_ctl) THEN 597 CALL prt_ctl(tab3d_1=p_qla , clinfo1=' blk_ice_core: p_qla : ', tab3d_2=z_qsb , clinfo2=' z_qsb : ', kdim=ijpl) 598 CALL prt_ctl(tab3d_1=z_qlw , clinfo1=' blk_ice_core: z_qlw : ', tab3d_2=p_dqla , clinfo2=' p_dqla : ', kdim=ijpl) 599 CALL prt_ctl(tab3d_1=z_dqsb , clinfo1=' blk_ice_core: z_dqsb : ', tab3d_2=z_dqlw , clinfo2=' z_dqlw : ', kdim=ijpl) 600 CALL prt_ctl(tab3d_1=p_dqns , clinfo1=' blk_ice_core: p_dqns : ', tab3d_2=p_qsr , clinfo2=' p_qsr : ', kdim=ijpl) 601 CALL prt_ctl(tab3d_1=pst , clinfo1=' blk_ice_core: pst : ', tab3d_2=p_qns , clinfo2=' p_qns : ', kdim=ijpl) 602 CALL prt_ctl(tab2d_1=p_tpr , clinfo1=' blk_ice_core: p_tpr : ', tab2d_2=p_spr , clinfo2=' p_spr : ') 603 CALL prt_ctl(tab2d_1=p_taui , clinfo1=' blk_ice_core: p_taui : ', tab2d_2=p_tauj , clinfo2=' p_tauj : ') 604 CALL prt_ctl(tab2d_1=z_wnds_t, clinfo1=' blk_ice_core: z_wnds_t : ') 605 ENDIF 606 607 CALL wrk_dealloc( jpi,jpj, z_wnds_t ) 608 CALL wrk_dealloc( jpi,jpj, pdim, z_qlw, z_qsb, z_dqlw, z_dqsb ) 609 ! 610 IF( nn_timing == 1 ) CALL timing_stop('blk_ice_core') 611 ! 612 END SUBROUTINE blk_ice_core 613 614 615 SUBROUTINE blk_bio_meanqsr 616 !!--------------------------------------------------------------------- 617 !! *** ROUTINE blk_bio_meanqsr 618 !! 619 !! ** Purpose : provide daily qsr_mean for PISCES when 620 !! analytic diurnal cycle is applied in physic 621 !! 622 !! ** Method : add part where there is no ice 623 !! 624 !!--------------------------------------------------------------------- 625 IF( nn_timing == 1 ) CALL timing_start('blk_bio_meanqsr') 626 ! 627 qsr_mean(:,:) = (1. - albo ) * sf(jp_qsr)%fnow(:,:,1) 628 ! 629 IF( nn_timing == 1 ) CALL timing_stop('blk_bio_meanqsr') 630 ! 631 END SUBROUTINE blk_bio_meanqsr 632 633 634 SUBROUTINE blk_ice_meanqsr( palb, p_qsr_mean, pdim ) 635 !!--------------------------------------------------------------------- 636 !! 637 !! ** Purpose : provide the daily qsr_mean over sea_ice for PISCES when 638 !! analytic diurnal cycle is applied in physic 639 !! 640 !! ** Method : compute qsr 641 !! 642 !!--------------------------------------------------------------------- 643 REAL(wp), DIMENSION(:,:,:), INTENT(in ) :: palb ! ice albedo (clear sky) (alb_ice_cs) [%] 644 REAL(wp), DIMENSION(:,:,:), INTENT( out) :: p_qsr_mean ! solar heat flux over ice (T-point) [W/m2] 645 INTEGER , INTENT(in ) :: pdim ! number of ice categories 646 ! 647 INTEGER :: ijpl ! number of ice categories (size of 3rd dim of input arrays) 648 INTEGER :: ji, jj, jl ! dummy loop indices 649 REAL(wp) :: zztmp ! temporary variable 650 !!--------------------------------------------------------------------- 651 IF( nn_timing == 1 ) CALL timing_start('blk_ice_meanqsr') 652 ! 653 ijpl = pdim ! number of ice categories 654 zztmp = 1. / ( 1. - albo ) 655 ! ! ========================== ! 656 DO jl = 1, ijpl ! Loop over ice categories ! 657 ! ! ========================== ! 658 DO jj = 1 , jpj 659 DO ji = 1, jpi 660 p_qsr_mean(ji,jj,jl) = zztmp * ( 1. - palb(ji,jj,jl) ) * qsr_mean(ji,jj) 661 END DO 662 END DO 663 END DO 664 ! 665 IF( nn_timing == 1 ) CALL timing_stop('blk_ice_meanqsr') 666 ! 667 END SUBROUTINE blk_ice_meanqsr 668 653 CALL prt_ctl(tab3d_1=qla_ice , clinfo1=' blk_ice_core: qla_ice : ', tab3d_2=z_qsb , clinfo2=' z_qsb : ', kdim=jpl) 654 CALL prt_ctl(tab3d_1=z_qlw , clinfo1=' blk_ice_core: z_qlw : ', tab3d_2=dqla_ice, clinfo2=' dqla_ice : ', kdim=jpl) 655 CALL prt_ctl(tab3d_1=z_dqsb , clinfo1=' blk_ice_core: z_dqsb : ', tab3d_2=z_dqlw , clinfo2=' z_dqlw : ', kdim=jpl) 656 CALL prt_ctl(tab3d_1=dqns_ice, clinfo1=' blk_ice_core: dqns_ice : ', tab3d_2=qsr_ice , clinfo2=' qsr_ice : ', kdim=jpl) 657 CALL prt_ctl(tab3d_1=ptsu , clinfo1=' blk_ice_core: ptsu : ', tab3d_2=qns_ice , clinfo2=' qns_ice : ', kdim=jpl) 658 CALL prt_ctl(tab2d_1=tprecip , clinfo1=' blk_ice_core: tprecip : ', tab2d_2=sprecip , clinfo2=' sprecip : ') 659 ENDIF 660 661 CALL wrk_dealloc( jpi,jpj,jpl, z_qlw, z_qsb, z_dqlw, z_dqsb ) 662 ! 663 IF( nn_timing == 1 ) CALL timing_stop('blk_ice_core_flx') 664 665 END SUBROUTINE blk_ice_core_flx 666 #endif 669 667 670 668 SUBROUTINE turb_core_2z( zt, zu, sst, T_zt, q_sat, q_zt, dU, & … … 848 846 rgt33 = 0.5_wp + SIGN( 0.5_wp, (zw10 - 33._wp) ) ! If zw10 < 33. => 0, else => 1 849 847 cd_neutral_10m = 1.e-3 * ( & 850 & ( rgt33 + 1._wp)*( 2.7_wp/zw10 + 0.142_wp + zw10/13.09_wp - 3.14807E-10*zw10**6) & ! zw10< 33.848 & (1._wp - rgt33)*( 2.7_wp/zw10 + 0.142_wp + zw10/13.09_wp - 3.14807E-10*zw10**6) & ! zw10< 33. 851 849 & + rgt33 * 2.34 ) ! zw10 >= 33. 852 850 ! -
branches/2014/dev_r4621_NOC4_BDY_VERT_INTERP/NEMOGCM/NEMO/OPA_SRC/SBC/sbcblk_mfs.F90
- Property svn:keywords set to Id
r5038 r5620 46 46 !!---------------------------------------------------------------------- 47 47 !! NEMO/OPA 3.2 , LOCEAN-IPSL (2009) 48 !! $Id : sbcblk_mfs.F90 1730 2009-11-16 14:34:19Z poddo$48 !! $Id$ 49 49 !! Software governed by the CeCILL licence (modipsl/doc/NEMO_CeCILL.txt) 50 50 !!---------------------------------------------------------------------- -
branches/2014/dev_r4621_NOC4_BDY_VERT_INTERP/NEMOGCM/NEMO/OPA_SRC/SBC/sbccpl.F90
r5038 r5620 21 21 USE sbc_oce ! Surface boundary condition: ocean fields 22 22 USE sbc_ice ! Surface boundary condition: ice fields 23 USE sbcapr 23 24 USE sbcdcy ! surface boundary condition: diurnal cycle 24 25 USE phycst ! physical constants 25 26 #if defined key_lim3 26 USE par_ice ! ice parameters27 27 USE ice ! ice variables 28 28 #endif … … 33 33 USE cpl_oasis3 ! OASIS3 coupling 34 34 USE geo2ocean ! 35 USE oce , ONLY : tsn, un, vn 35 USE oce , ONLY : tsn, un, vn, sshn, ub, vb, sshb, fraqsr_1lev 36 36 USE albedo ! 37 37 USE in_out_manager ! I/O manager … … 41 41 USE timing ! Timing 42 42 USE lbclnk ! ocean lateral boundary conditions (or mpp link) 43 USE eosbn2 44 USE sbcrnf , ONLY : l_rnfcpl 43 45 #if defined key_cpl_carbon_cycle 44 46 USE p4zflx, ONLY : oce_co2 … … 47 49 USE ice_domain_size, only: ncat 48 50 #endif 51 #if defined key_lim3 52 USE limthd_dh ! for CALL lim_thd_snwblow 53 #endif 54 49 55 IMPLICIT NONE 50 56 PRIVATE 51 !EM XIOS-OASIS-MCT compliance 57 52 58 PUBLIC sbc_cpl_init ! routine called by sbcmod.F90 53 59 PUBLIC sbc_cpl_rcv ! routine called by sbc_ice_lim(_2).F90 … … 90 96 INTEGER, PARAMETER :: jpr_topm = 32 ! topmeltn 91 97 INTEGER, PARAMETER :: jpr_botm = 33 ! botmeltn 92 INTEGER, PARAMETER :: jprcv = 33 ! total number of fields received 93 94 INTEGER, PARAMETER :: jps_fice = 1 ! ice fraction 98 INTEGER, PARAMETER :: jpr_sflx = 34 ! salt flux 99 INTEGER, PARAMETER :: jpr_toce = 35 ! ocean temperature 100 INTEGER, PARAMETER :: jpr_soce = 36 ! ocean salinity 101 INTEGER, PARAMETER :: jpr_ocx1 = 37 ! ocean current on grid 1 102 INTEGER, PARAMETER :: jpr_ocy1 = 38 ! 103 INTEGER, PARAMETER :: jpr_ssh = 39 ! sea surface height 104 INTEGER, PARAMETER :: jpr_fice = 40 ! ice fraction 105 INTEGER, PARAMETER :: jpr_e3t1st = 41 ! first T level thickness 106 INTEGER, PARAMETER :: jpr_fraqsr = 42 ! fraction of solar net radiation absorbed in the first ocean level 107 INTEGER, PARAMETER :: jprcv = 42 ! total number of fields received 108 109 INTEGER, PARAMETER :: jps_fice = 1 ! ice fraction sent to the atmosphere 95 110 INTEGER, PARAMETER :: jps_toce = 2 ! ocean temperature 96 111 INTEGER, PARAMETER :: jps_tice = 3 ! ice temperature … … 107 122 INTEGER, PARAMETER :: jps_ivz1 = 14 ! 108 123 INTEGER, PARAMETER :: jps_co2 = 15 109 INTEGER, PARAMETER :: jpsnd = 15 ! total number of fields sended 124 INTEGER, PARAMETER :: jps_soce = 16 ! ocean salinity 125 INTEGER, PARAMETER :: jps_ssh = 17 ! sea surface height 126 INTEGER, PARAMETER :: jps_qsroce = 18 ! Qsr above the ocean 127 INTEGER, PARAMETER :: jps_qnsoce = 19 ! Qns above the ocean 128 INTEGER, PARAMETER :: jps_oemp = 20 ! ocean freshwater budget (evap - precip) 129 INTEGER, PARAMETER :: jps_sflx = 21 ! salt flux 130 INTEGER, PARAMETER :: jps_otx1 = 22 ! 2 atmosphere-ocean stress components on grid 1 131 INTEGER, PARAMETER :: jps_oty1 = 23 ! 132 INTEGER, PARAMETER :: jps_rnf = 24 ! runoffs 133 INTEGER, PARAMETER :: jps_taum = 25 ! wind stress module 134 INTEGER, PARAMETER :: jps_fice2 = 26 ! ice fraction sent to OPA (by SAS when doing SAS-OPA coupling) 135 INTEGER, PARAMETER :: jps_e3t1st = 27 ! first level depth (vvl) 136 INTEGER, PARAMETER :: jps_fraqsr = 28 ! fraction of solar net radiation absorbed in the first ocean level 137 INTEGER, PARAMETER :: jpsnd = 28 ! total number of fields sended 110 138 111 139 ! !!** namelist namsbc_cpl ** … … 126 154 LOGICAL :: ln_usecplmask ! use a coupling mask file to merge data received from several models 127 155 ! -> file cplmask.nc with the float variable called cplmask (jpi,jpj,nn_cplmodel) 128 129 REAL(wp), ALLOCATABLE, DIMENSION(:,:,:) :: xcplmask130 131 156 TYPE :: DYNARR 132 157 REAL(wp), POINTER, DIMENSION(:,:,:) :: z3 … … 140 165 141 166 !! Substitution 167 # include "domzgr_substitute.h90" 142 168 # include "vectopt_loop_substitute.h90" 143 169 !!---------------------------------------------------------------------- … … 162 188 ALLOCATE( a_i(jpi,jpj,1) , STAT=ierr(2) ) ! used in sbcice_if.F90 (done here as there is no sbc_ice_if_init) 163 189 #endif 164 ALLOCATE( xcplmask(jpi,jpj, nn_cplmodel) , STAT=ierr(3) )190 ALLOCATE( xcplmask(jpi,jpj,0:nn_cplmodel) , STAT=ierr(3) ) 165 191 ! 166 192 sbc_cpl_alloc = MAXVAL( ierr ) … … 183 209 !! * initialise the OASIS coupler 184 210 !!---------------------------------------------------------------------- 185 INTEGER, INTENT(in) :: k_ice ! ice management in the sbc (=0/1/2/3)211 INTEGER, INTENT(in) :: k_ice ! ice management in the sbc (=0/1/2/3) 186 212 !! 187 213 INTEGER :: jn ! dummy loop index … … 217 243 WRITE(numout,*)'sbc_cpl_init : namsbc_cpl namelist ' 218 244 WRITE(numout,*)'~~~~~~~~~~~~' 245 ENDIF 246 IF( lwp .AND. ln_cpl ) THEN ! control print 219 247 WRITE(numout,*)' received fields (mutiple ice categogies)' 220 248 WRITE(numout,*)' 10m wind module = ', TRIM(sn_rcv_w10m%cldes ), ' (', TRIM(sn_rcv_w10m%clcat ), ')' … … 360 388 srcv(jpr_oemp)%clname = 'OOEvaMPr' ! ocean water budget = ocean Evap - ocean precip 361 389 SELECT CASE( TRIM( sn_rcv_emp%cldes ) ) 390 CASE( 'none' ) ! nothing to do 362 391 CASE( 'oce only' ) ; srcv( jpr_oemp )%laction = .TRUE. 363 392 CASE( 'conservative' ) … … 371 400 ! ! Runoffs & Calving ! 372 401 ! ! ------------------------- ! 373 srcv(jpr_rnf )%clname = 'O_Runoff' ; IF( TRIM( sn_rcv_rnf%cldes ) == 'coupled' ) srcv(jpr_rnf)%laction = .TRUE. 374 ! This isn't right - really just want ln_rnf_emp changed 375 ! IF( TRIM( sn_rcv_rnf%cldes ) == 'climato' ) THEN ; ln_rnf = .TRUE. 376 ! ELSE ; ln_rnf = .FALSE. 377 ! ENDIF 402 srcv(jpr_rnf )%clname = 'O_Runoff' 403 IF( TRIM( sn_rcv_rnf%cldes ) == 'coupled' ) THEN 404 srcv(jpr_rnf)%laction = .TRUE. 405 l_rnfcpl = .TRUE. ! -> no need to read runoffs in sbcrnf 406 ln_rnf = nn_components /= jp_iam_sas ! -> force to go through sbcrnf if not sas 407 IF(lwp) WRITE(numout,*) 408 IF(lwp) WRITE(numout,*) ' runoffs received from oasis -> force ln_rnf = ', ln_rnf 409 ENDIF 410 ! 378 411 srcv(jpr_cal )%clname = 'OCalving' ; IF( TRIM( sn_rcv_cal%cldes ) == 'coupled' ) srcv(jpr_cal)%laction = .TRUE. 379 412 … … 385 418 srcv(jpr_qnsmix)%clname = 'O_QnsMix' 386 419 SELECT CASE( TRIM( sn_rcv_qns%cldes ) ) 420 CASE( 'none' ) ! nothing to do 387 421 CASE( 'oce only' ) ; srcv( jpr_qnsoce )%laction = .TRUE. 388 422 CASE( 'conservative' ) ; srcv( (/jpr_qnsice, jpr_qnsmix/) )%laction = .TRUE. … … 400 434 srcv(jpr_qsrmix)%clname = 'O_QsrMix' 401 435 SELECT CASE( TRIM( sn_rcv_qsr%cldes ) ) 436 CASE( 'none' ) ! nothing to do 402 437 CASE( 'oce only' ) ; srcv( jpr_qsroce )%laction = .TRUE. 403 438 CASE( 'conservative' ) ; srcv( (/jpr_qsrice, jpr_qsrmix/) )%laction = .TRUE. … … 415 450 ! 416 451 ! non solar sensitivity mandatory for LIM ice model 417 IF( TRIM( sn_rcv_dqnsdt%cldes ) == 'none' .AND. k_ice /= 0 .AND. k_ice /= 4 ) &452 IF( TRIM( sn_rcv_dqnsdt%cldes ) == 'none' .AND. k_ice /= 0 .AND. k_ice /= 4 .AND. nn_components /= jp_iam_sas ) & 418 453 CALL ctl_stop( 'sbc_cpl_init: sn_rcv_dqnsdt%cldes must be coupled in namsbc_cpl namelist' ) 419 454 ! non solar sensitivity mandatory for mixed oce-ice solar radiation coupling technique … … 448 483 srcv(jpr_topm:jpr_botm)%laction = .TRUE. 449 484 ENDIF 450 451 ! Allocate all parts of frcv used for received fields 485 ! ! ------------------------------- ! 486 ! ! OPA-SAS coupling - rcv by opa ! 487 ! ! ------------------------------- ! 488 srcv(jpr_sflx)%clname = 'O_SFLX' 489 srcv(jpr_fice)%clname = 'RIceFrc' 490 ! 491 IF( nn_components == jp_iam_opa ) THEN ! OPA coupled to SAS via OASIS: force received field by OPA (sent by SAS) 492 srcv(:)%laction = .FALSE. ! force default definition in case of opa <-> sas coupling 493 srcv(:)%clgrid = 'T' ! force default definition in case of opa <-> sas coupling 494 srcv(:)%nsgn = 1. ! force default definition in case of opa <-> sas coupling 495 srcv( (/jpr_qsroce, jpr_qnsoce, jpr_oemp, jpr_sflx, jpr_fice, jpr_otx1, jpr_oty1, jpr_taum/) )%laction = .TRUE. 496 srcv(jpr_otx1)%clgrid = 'U' ! oce components given at U-point 497 srcv(jpr_oty1)%clgrid = 'V' ! and V-point 498 ! Vectors: change of sign at north fold ONLY if on the local grid 499 srcv( (/jpr_otx1,jpr_oty1/) )%nsgn = -1. 500 sn_rcv_tau%clvgrd = 'U,V' 501 sn_rcv_tau%clvor = 'local grid' 502 sn_rcv_tau%clvref = 'spherical' 503 sn_rcv_emp%cldes = 'oce only' 504 ! 505 IF(lwp) THEN ! control print 506 WRITE(numout,*) 507 WRITE(numout,*)' Special conditions for SAS-OPA coupling ' 508 WRITE(numout,*)' OPA component ' 509 WRITE(numout,*) 510 WRITE(numout,*)' received fields from SAS component ' 511 WRITE(numout,*)' ice cover ' 512 WRITE(numout,*)' oce only EMP ' 513 WRITE(numout,*)' salt flux ' 514 WRITE(numout,*)' mixed oce-ice solar flux ' 515 WRITE(numout,*)' mixed oce-ice non solar flux ' 516 WRITE(numout,*)' wind stress U,V on local grid and sperical coordinates ' 517 WRITE(numout,*)' wind stress module' 518 WRITE(numout,*) 519 ENDIF 520 ENDIF 521 ! ! -------------------------------- ! 522 ! ! OPA-SAS coupling - rcv by sas ! 523 ! ! -------------------------------- ! 524 srcv(jpr_toce )%clname = 'I_SSTSST' 525 srcv(jpr_soce )%clname = 'I_SSSal' 526 srcv(jpr_ocx1 )%clname = 'I_OCurx1' 527 srcv(jpr_ocy1 )%clname = 'I_OCury1' 528 srcv(jpr_ssh )%clname = 'I_SSHght' 529 srcv(jpr_e3t1st)%clname = 'I_E3T1st' 530 srcv(jpr_fraqsr)%clname = 'I_FraQsr' 531 ! 532 IF( nn_components == jp_iam_sas ) THEN 533 IF( .NOT. ln_cpl ) srcv(:)%laction = .FALSE. ! force default definition in case of opa <-> sas coupling 534 IF( .NOT. ln_cpl ) srcv(:)%clgrid = 'T' ! force default definition in case of opa <-> sas coupling 535 IF( .NOT. ln_cpl ) srcv(:)%nsgn = 1. ! force default definition in case of opa <-> sas coupling 536 srcv( (/jpr_toce, jpr_soce, jpr_ssh, jpr_fraqsr, jpr_ocx1, jpr_ocy1/) )%laction = .TRUE. 537 srcv( jpr_e3t1st )%laction = lk_vvl 538 srcv(jpr_ocx1)%clgrid = 'U' ! oce components given at U-point 539 srcv(jpr_ocy1)%clgrid = 'V' ! and V-point 540 ! Vectors: change of sign at north fold ONLY if on the local grid 541 srcv(jpr_ocx1:jpr_ocy1)%nsgn = -1. 542 ! Change first letter to couple with atmosphere if already coupled OPA 543 ! this is nedeed as each variable name used in the namcouple must be unique: 544 ! for example O_Runoff received by OPA from SAS and therefore O_Runoff received by SAS from the Atmosphere 545 DO jn = 1, jprcv 546 IF ( srcv(jn)%clname(1:1) == "O" ) srcv(jn)%clname = "S"//srcv(jn)%clname(2:LEN(srcv(jn)%clname)) 547 END DO 548 ! 549 IF(lwp) THEN ! control print 550 WRITE(numout,*) 551 WRITE(numout,*)' Special conditions for SAS-OPA coupling ' 552 WRITE(numout,*)' SAS component ' 553 WRITE(numout,*) 554 IF( .NOT. ln_cpl ) THEN 555 WRITE(numout,*)' received fields from OPA component ' 556 ELSE 557 WRITE(numout,*)' Additional received fields from OPA component : ' 558 ENDIF 559 WRITE(numout,*)' sea surface temperature (Celcius) ' 560 WRITE(numout,*)' sea surface salinity ' 561 WRITE(numout,*)' surface currents ' 562 WRITE(numout,*)' sea surface height ' 563 WRITE(numout,*)' thickness of first ocean T level ' 564 WRITE(numout,*)' fraction of solar net radiation absorbed in the first ocean level' 565 WRITE(numout,*) 566 ENDIF 567 ENDIF 568 569 ! =================================================== ! 570 ! Allocate all parts of frcv used for received fields ! 571 ! =================================================== ! 452 572 DO jn = 1, jprcv 453 573 IF ( srcv(jn)%laction ) ALLOCATE( frcv(jn)%z3(jpi,jpj,srcv(jn)%nct) ) … … 455 575 ! Allocate taum part of frcv which is used even when not received as coupling field 456 576 IF ( .NOT. srcv(jpr_taum)%laction ) ALLOCATE( frcv(jpr_taum)%z3(jpi,jpj,srcv(jpr_taum)%nct) ) 577 ! Allocate w10m part of frcv which is used even when not received as coupling field 578 IF ( .NOT. srcv(jpr_w10m)%laction ) ALLOCATE( frcv(jpr_w10m)%z3(jpi,jpj,srcv(jpr_w10m)%nct) ) 579 ! Allocate jpr_otx1 part of frcv which is used even when not received as coupling field 580 IF ( .NOT. srcv(jpr_otx1)%laction ) ALLOCATE( frcv(jpr_otx1)%z3(jpi,jpj,srcv(jpr_otx1)%nct) ) 581 IF ( .NOT. srcv(jpr_oty1)%laction ) ALLOCATE( frcv(jpr_oty1)%z3(jpi,jpj,srcv(jpr_oty1)%nct) ) 457 582 ! Allocate itx1 and ity1 as they are used in sbc_cpl_ice_tau even if srcv(jpr_itx1)%laction = .FALSE. 458 583 IF( k_ice /= 0 ) THEN … … 478 603 ssnd(jps_tmix)%clname = 'O_TepMix' 479 604 SELECT CASE( TRIM( sn_snd_temp%cldes ) ) 480 CASE( 'none' ) ! nothing to do481 CASE( 'oce only' ) ; ssnd( jps_toce)%laction = .TRUE.482 CASE( ' weighted oce and ice' )605 CASE( 'none' ) ! nothing to do 606 CASE( 'oce only' ) ; ssnd( jps_toce )%laction = .TRUE. 607 CASE( 'oce and ice' , 'weighted oce and ice' ) 483 608 ssnd( (/jps_toce, jps_tice/) )%laction = .TRUE. 484 609 IF ( TRIM( sn_snd_temp%clcat ) == 'yes' ) ssnd(jps_tice)%nct = jpl 485 CASE( 'mixed oce-ice' ) ; ssnd( jps_tmix)%laction = .TRUE.610 CASE( 'mixed oce-ice' ) ; ssnd( jps_tmix )%laction = .TRUE. 486 611 CASE default ; CALL ctl_stop( 'sbc_cpl_init: wrong definition of sn_snd_temp%cldes' ) 487 612 END SELECT 488 613 489 614 ! ! ------------------------- ! 490 615 ! ! Albedo ! … … 493 618 ssnd(jps_albmix)%clname = 'O_AlbMix' 494 619 SELECT CASE( TRIM( sn_snd_alb%cldes ) ) 495 CASE( 'none' )! nothing to do496 CASE( ' weighted ice' ) ;ssnd(jps_albice)%laction = .TRUE.497 CASE( 'mixed oce-ice' ) ;ssnd(jps_albmix)%laction = .TRUE.620 CASE( 'none' ) ! nothing to do 621 CASE( 'ice' , 'weighted ice' ) ; ssnd(jps_albice)%laction = .TRUE. 622 CASE( 'mixed oce-ice' ) ; ssnd(jps_albmix)%laction = .TRUE. 498 623 CASE default ; CALL ctl_stop( 'sbc_cpl_init: wrong definition of sn_snd_alb%cldes' ) 499 624 END SELECT … … 519 644 IF ( TRIM( sn_snd_thick%clcat ) == 'yes' ) ssnd(jps_fice)%nct = jpl 520 645 ENDIF 521 646 522 647 SELECT CASE ( TRIM( sn_snd_thick%cldes ) ) 523 648 CASE( 'none' ) ! nothing to do … … 526 651 IF ( TRIM( sn_snd_thick%clcat ) == 'yes' ) THEN 527 652 ssnd(jps_hice:jps_hsnw)%nct = jpl 528 ELSE529 IF ( jpl > 1 ) THEN530 CALL ctl_stop( 'sbc_cpl_init: use weighted ice and snow option for sn_snd_thick%cldes if not exchanging category fields' )531 ENDIF532 653 ENDIF 533 654 CASE ( 'weighted ice and snow' ) … … 568 689 ! ! ------------------------- ! 569 690 ssnd(jps_co2)%clname = 'O_CO2FLX' ; IF( TRIM(sn_snd_co2%cldes) == 'coupled' ) ssnd(jps_co2 )%laction = .TRUE. 691 692 ! ! ------------------------------- ! 693 ! ! OPA-SAS coupling - snd by opa ! 694 ! ! ------------------------------- ! 695 ssnd(jps_ssh )%clname = 'O_SSHght' 696 ssnd(jps_soce )%clname = 'O_SSSal' 697 ssnd(jps_e3t1st)%clname = 'O_E3T1st' 698 ssnd(jps_fraqsr)%clname = 'O_FraQsr' 699 ! 700 IF( nn_components == jp_iam_opa ) THEN 701 ssnd(:)%laction = .FALSE. ! force default definition in case of opa <-> sas coupling 702 ssnd( (/jps_toce, jps_soce, jps_ssh, jps_fraqsr, jps_ocx1, jps_ocy1/) )%laction = .TRUE. 703 ssnd( jps_e3t1st )%laction = lk_vvl 704 ! vector definition: not used but cleaner... 705 ssnd(jps_ocx1)%clgrid = 'U' ! oce components given at U-point 706 ssnd(jps_ocy1)%clgrid = 'V' ! and V-point 707 sn_snd_crt%clvgrd = 'U,V' 708 sn_snd_crt%clvor = 'local grid' 709 sn_snd_crt%clvref = 'spherical' 710 ! 711 IF(lwp) THEN ! control print 712 WRITE(numout,*) 713 WRITE(numout,*)' sent fields to SAS component ' 714 WRITE(numout,*)' sea surface temperature (T before, Celcius) ' 715 WRITE(numout,*)' sea surface salinity ' 716 WRITE(numout,*)' surface currents U,V on local grid and spherical coordinates' 717 WRITE(numout,*)' sea surface height ' 718 WRITE(numout,*)' thickness of first ocean T level ' 719 WRITE(numout,*)' fraction of solar net radiation absorbed in the first ocean level' 720 WRITE(numout,*) 721 ENDIF 722 ENDIF 723 ! ! ------------------------------- ! 724 ! ! OPA-SAS coupling - snd by sas ! 725 ! ! ------------------------------- ! 726 ssnd(jps_sflx )%clname = 'I_SFLX' 727 ssnd(jps_fice2 )%clname = 'IIceFrc' 728 ssnd(jps_qsroce)%clname = 'I_QsrOce' 729 ssnd(jps_qnsoce)%clname = 'I_QnsOce' 730 ssnd(jps_oemp )%clname = 'IOEvaMPr' 731 ssnd(jps_otx1 )%clname = 'I_OTaux1' 732 ssnd(jps_oty1 )%clname = 'I_OTauy1' 733 ssnd(jps_rnf )%clname = 'I_Runoff' 734 ssnd(jps_taum )%clname = 'I_TauMod' 735 ! 736 IF( nn_components == jp_iam_sas ) THEN 737 IF( .NOT. ln_cpl ) ssnd(:)%laction = .FALSE. ! force default definition in case of opa <-> sas coupling 738 ssnd( (/jps_qsroce, jps_qnsoce, jps_oemp, jps_fice2, jps_sflx, jps_otx1, jps_oty1, jps_taum/) )%laction = .TRUE. 739 ! 740 ! Change first letter to couple with atmosphere if already coupled with sea_ice 741 ! this is nedeed as each variable name used in the namcouple must be unique: 742 ! for example O_SSTSST sent by OPA to SAS and therefore S_SSTSST sent by SAS to the Atmosphere 743 DO jn = 1, jpsnd 744 IF ( ssnd(jn)%clname(1:1) == "O" ) ssnd(jn)%clname = "S"//ssnd(jn)%clname(2:LEN(ssnd(jn)%clname)) 745 END DO 746 ! 747 IF(lwp) THEN ! control print 748 WRITE(numout,*) 749 IF( .NOT. ln_cpl ) THEN 750 WRITE(numout,*)' sent fields to OPA component ' 751 ELSE 752 WRITE(numout,*)' Additional sent fields to OPA component : ' 753 ENDIF 754 WRITE(numout,*)' ice cover ' 755 WRITE(numout,*)' oce only EMP ' 756 WRITE(numout,*)' salt flux ' 757 WRITE(numout,*)' mixed oce-ice solar flux ' 758 WRITE(numout,*)' mixed oce-ice non solar flux ' 759 WRITE(numout,*)' wind stress U,V components' 760 WRITE(numout,*)' wind stress module' 761 ENDIF 762 ENDIF 763 570 764 ! 571 765 ! ================================ ! … … 573 767 ! ================================ ! 574 768 575 CALL cpl_define(jprcv, jpsnd,nn_cplmodel) 769 CALL cpl_define(jprcv, jpsnd, nn_cplmodel) 770 576 771 IF (ln_usecplmask) THEN 577 772 xcplmask(:,:,:) = 0. … … 583 778 xcplmask(:,:,:) = 1. 584 779 ENDIF 585 ! 586 IF( ln_dm2dc .AND. ( cpl_freq( jpr_qsroce ) + cpl_freq( jpr_qsrmix ) /= 86400 ) ) & 780 xcplmask(:,:,0) = 1. - SUM( xcplmask(:,:,1:nn_cplmodel), dim = 3 ) 781 ! 782 ncpl_qsr_freq = cpl_freq( 'O_QsrOce' ) + cpl_freq( 'O_QsrMix' ) + cpl_freq( 'I_QsrOce' ) + cpl_freq( 'I_QsrMix' ) 783 IF( ln_dm2dc .AND. ln_cpl .AND. ncpl_qsr_freq /= 86400 ) & 587 784 & CALL ctl_stop( 'sbc_cpl_init: diurnal cycle reconstruction (ln_dm2dc) needs daily couping for solar radiation' ) 785 ncpl_qsr_freq = 86400 / ncpl_qsr_freq 588 786 589 787 CALL wrk_dealloc( jpi,jpj, zacs, zaos ) … … 639 837 !! emp upward mass flux [evap. - precip. (- runoffs) (- calving)] (ocean only case) 640 838 !!---------------------------------------------------------------------- 641 INTEGER, INTENT(in) :: kt ! ocean model time step index 642 INTEGER, INTENT(in) :: k_fsbc ! frequency of sbc (-> ice model) computation 643 INTEGER, INTENT(in) :: k_ice ! ice management in the sbc (=0/1/2/3) 644 !! 645 LOGICAL :: llnewtx, llnewtau ! update wind stress components and module?? 839 INTEGER, INTENT(in) :: kt ! ocean model time step index 840 INTEGER, INTENT(in) :: k_fsbc ! frequency of sbc (-> ice model) computation 841 INTEGER, INTENT(in) :: k_ice ! ice management in the sbc (=0/1/2/3) 842 843 !! 844 LOGICAL :: llnewtx, llnewtau ! update wind stress components and module?? 646 845 INTEGER :: ji, jj, jn ! dummy loop indices 647 846 INTEGER :: isec ! number of seconds since nit000 (assuming rdttra did not change since nit000) … … 651 850 REAL(wp) :: zcdrag = 1.5e-3 ! drag coefficient 652 851 REAL(wp) :: zzx, zzy ! temporary variables 653 REAL(wp), POINTER, DIMENSION(:,:) :: ztx, zty 852 REAL(wp), POINTER, DIMENSION(:,:) :: ztx, zty, zmsk, zemp, zqns, zqsr 654 853 !!---------------------------------------------------------------------- 655 854 ! 656 855 IF( nn_timing == 1 ) CALL timing_start('sbc_cpl_rcv') 657 856 ! 658 CALL wrk_alloc( jpi,jpj, ztx, zty ) 659 ! ! Receive all the atmos. fields (including ice information) 660 isec = ( kt - nit000 ) * NINT( rdttra(1) ) ! date of exchanges 661 DO jn = 1, jprcv ! received fields sent by the atmosphere 662 IF( srcv(jn)%laction ) CALL cpl_rcv( jn, isec, frcv(jn)%z3, xcplmask, nrcvinfo(jn) ) 857 CALL wrk_alloc( jpi,jpj, ztx, zty, zmsk, zemp, zqns, zqsr ) 858 ! 859 IF( ln_mixcpl ) zmsk(:,:) = 1. - xcplmask(:,:,0) 860 ! 861 ! ! ======================================================= ! 862 ! ! Receive all the atmos. fields (including ice information) 863 ! ! ======================================================= ! 864 isec = ( kt - nit000 ) * NINT( rdttra(1) ) ! date of exchanges 865 DO jn = 1, jprcv ! received fields sent by the atmosphere 866 IF( srcv(jn)%laction ) CALL cpl_rcv( jn, isec, frcv(jn)%z3, xcplmask(:,:,1:nn_cplmodel), nrcvinfo(jn) ) 663 867 END DO 664 868 … … 720 924 ! 721 925 ENDIF 722 723 926 ! ! ========================= ! 724 927 ! ! wind stress module ! (taum) … … 749 952 ENDIF 750 953 ENDIF 751 954 ! 752 955 ! ! ========================= ! 753 956 ! ! 10 m wind speed ! (wndm) … … 762 965 !CDIR NOVERRCHK 763 966 DO ji = 1, jpi 764 wndm(ji,jj) = SQRT( frcv(jpr_taum)%z3(ji,jj,1) * zcoef )967 frcv(jpr_w10m)%z3(ji,jj,1) = SQRT( frcv(jpr_taum)%z3(ji,jj,1) * zcoef ) 765 968 END DO 766 969 END DO 767 970 ENDIF 768 ELSE769 IF ( nrcvinfo(jpr_w10m) == OASIS_Rcv ) wndm(:,:) = frcv(jpr_w10m)%z3(:,:,1)770 971 ENDIF 771 972 … … 774 975 IF( MOD( kt-1, k_fsbc ) == 0 ) THEN 775 976 ! 776 utau(:,:) = frcv(jpr_otx1)%z3(:,:,1) 777 vtau(:,:) = frcv(jpr_oty1)%z3(:,:,1) 778 taum(:,:) = frcv(jpr_taum)%z3(:,:,1) 977 IF( ln_mixcpl ) THEN 978 utau(:,:) = utau(:,:) * xcplmask(:,:,0) + frcv(jpr_otx1)%z3(:,:,1) * zmsk(:,:) 979 vtau(:,:) = vtau(:,:) * xcplmask(:,:,0) + frcv(jpr_oty1)%z3(:,:,1) * zmsk(:,:) 980 taum(:,:) = taum(:,:) * xcplmask(:,:,0) + frcv(jpr_taum)%z3(:,:,1) * zmsk(:,:) 981 wndm(:,:) = wndm(:,:) * xcplmask(:,:,0) + frcv(jpr_w10m)%z3(:,:,1) * zmsk(:,:) 982 ELSE 983 utau(:,:) = frcv(jpr_otx1)%z3(:,:,1) 984 vtau(:,:) = frcv(jpr_oty1)%z3(:,:,1) 985 taum(:,:) = frcv(jpr_taum)%z3(:,:,1) 986 wndm(:,:) = frcv(jpr_w10m)%z3(:,:,1) 987 ENDIF 779 988 CALL iom_put( "taum_oce", taum ) ! output wind stress module 780 989 ! … … 782 991 783 992 #if defined key_cpl_carbon_cycle 784 ! ! atmosph. CO2 (ppm) 993 ! ! ================== ! 994 ! ! atmosph. CO2 (ppm) ! 995 ! ! ================== ! 785 996 IF( srcv(jpr_co2)%laction ) atm_co2(:,:) = frcv(jpr_co2)%z3(:,:,1) 786 997 #endif 787 998 999 ! Fields received by SAS when OASIS coupling 1000 ! (arrays no more filled at sbcssm stage) 1001 ! ! ================== ! 1002 ! ! SSS ! 1003 ! ! ================== ! 1004 IF( srcv(jpr_soce)%laction ) THEN ! received by sas in case of opa <-> sas coupling 1005 sss_m(:,:) = frcv(jpr_soce)%z3(:,:,1) 1006 CALL iom_put( 'sss_m', sss_m ) 1007 ENDIF 1008 ! 1009 ! ! ================== ! 1010 ! ! SST ! 1011 ! ! ================== ! 1012 IF( srcv(jpr_toce)%laction ) THEN ! received by sas in case of opa <-> sas coupling 1013 sst_m(:,:) = frcv(jpr_toce)%z3(:,:,1) 1014 IF( srcv(jpr_soce)%laction .AND. ln_useCT ) THEN ! make sure that sst_m is the potential temperature 1015 sst_m(:,:) = eos_pt_from_ct( sst_m(:,:), sss_m(:,:) ) 1016 ENDIF 1017 ENDIF 1018 ! ! ================== ! 1019 ! ! SSH ! 1020 ! ! ================== ! 1021 IF( srcv(jpr_ssh )%laction ) THEN ! received by sas in case of opa <-> sas coupling 1022 ssh_m(:,:) = frcv(jpr_ssh )%z3(:,:,1) 1023 CALL iom_put( 'ssh_m', ssh_m ) 1024 ENDIF 1025 ! ! ================== ! 1026 ! ! surface currents ! 1027 ! ! ================== ! 1028 IF( srcv(jpr_ocx1)%laction ) THEN ! received by sas in case of opa <-> sas coupling 1029 ssu_m(:,:) = frcv(jpr_ocx1)%z3(:,:,1) 1030 ub (:,:,1) = ssu_m(:,:) ! will be used in sbcice_lim in the call of lim_sbc_tau 1031 CALL iom_put( 'ssu_m', ssu_m ) 1032 ENDIF 1033 IF( srcv(jpr_ocy1)%laction ) THEN 1034 ssv_m(:,:) = frcv(jpr_ocy1)%z3(:,:,1) 1035 vb (:,:,1) = ssv_m(:,:) ! will be used in sbcice_lim in the call of lim_sbc_tau 1036 CALL iom_put( 'ssv_m', ssv_m ) 1037 ENDIF 1038 ! ! ======================== ! 1039 ! ! first T level thickness ! 1040 ! ! ======================== ! 1041 IF( srcv(jpr_e3t1st )%laction ) THEN ! received by sas in case of opa <-> sas coupling 1042 e3t_m(:,:) = frcv(jpr_e3t1st )%z3(:,:,1) 1043 CALL iom_put( 'e3t_m', e3t_m(:,:) ) 1044 ENDIF 1045 ! ! ================================ ! 1046 ! ! fraction of solar net radiation ! 1047 ! ! ================================ ! 1048 IF( srcv(jpr_fraqsr)%laction ) THEN ! received by sas in case of opa <-> sas coupling 1049 frq_m(:,:) = frcv(jpr_fraqsr)%z3(:,:,1) 1050 CALL iom_put( 'frq_m', frq_m ) 1051 ENDIF 1052 788 1053 ! ! ========================= ! 789 IF( k_ice <= 1 ) THEN! heat & freshwater fluxes ! (Ocean only case)1054 IF( k_ice <= 1 .AND. MOD( kt-1, k_fsbc ) == 0 ) THEN ! heat & freshwater fluxes ! (Ocean only case) 790 1055 ! ! ========================= ! 791 1056 ! 792 1057 ! ! total freshwater fluxes over the ocean (emp) 793 SELECT CASE( TRIM( sn_rcv_emp%cldes ) ) ! evaporation - precipitation 794 CASE( 'conservative' ) 795 emp(:,:) = frcv(jpr_tevp)%z3(:,:,1) - ( frcv(jpr_rain)%z3(:,:,1) + frcv(jpr_snow)%z3(:,:,1) ) 796 CASE( 'oce only', 'oce and ice' ) 797 emp(:,:) = frcv(jpr_oemp)%z3(:,:,1) 798 CASE default 799 CALL ctl_stop( 'sbc_cpl_rcv: wrong definition of sn_rcv_emp%cldes' ) 800 END SELECT 1058 IF( srcv(jpr_oemp)%laction .OR. srcv(jpr_rain)%laction ) THEN 1059 SELECT CASE( TRIM( sn_rcv_emp%cldes ) ) ! evaporation - precipitation 1060 CASE( 'conservative' ) 1061 zemp(:,:) = frcv(jpr_tevp)%z3(:,:,1) - ( frcv(jpr_rain)%z3(:,:,1) + frcv(jpr_snow)%z3(:,:,1) ) 1062 CASE( 'oce only', 'oce and ice' ) 1063 zemp(:,:) = frcv(jpr_oemp)%z3(:,:,1) 1064 CASE default 1065 CALL ctl_stop( 'sbc_cpl_rcv: wrong definition of sn_rcv_emp%cldes' ) 1066 END SELECT 1067 ELSE 1068 zemp(:,:) = 0._wp 1069 ENDIF 801 1070 ! 802 1071 ! ! runoffs and calving (added in emp) 803 IF( srcv(jpr_rnf)%laction ) emp(:,:) = emp(:,:) - frcv(jpr_rnf)%z3(:,:,1) 804 IF( srcv(jpr_cal)%laction ) emp(:,:) = emp(:,:) - frcv(jpr_cal)%z3(:,:,1) 805 ! 806 !!gm : this seems to be internal cooking, not sure to need that in a generic interface 807 !!gm at least should be optional... 808 !! IF( TRIM( sn_rcv_rnf%cldes ) == 'coupled' ) THEN ! add to the total freshwater budget 809 !! ! remove negative runoff 810 !! zcumulpos = SUM( MAX( frcv(jpr_rnf)%z3(:,:,1), 0.e0 ) * e1t(:,:) * e2t(:,:) * tmask_i(:,:) ) 811 !! zcumulneg = SUM( MIN( frcv(jpr_rnf)%z3(:,:,1), 0.e0 ) * e1t(:,:) * e2t(:,:) * tmask_i(:,:) ) 812 !! IF( lk_mpp ) CALL mpp_sum( zcumulpos ) ! sum over the global domain 813 !! IF( lk_mpp ) CALL mpp_sum( zcumulneg ) 814 !! IF( zcumulpos /= 0. ) THEN ! distribute negative runoff on positive runoff grid points 815 !! zcumulneg = 1.e0 + zcumulneg / zcumulpos 816 !! frcv(jpr_rnf)%z3(:,:,1) = MAX( frcv(jpr_rnf)%z3(:,:,1), 0.e0 ) * zcumulneg 817 !! ENDIF 818 !! ! add runoff to e-p 819 !! emp(:,:) = emp(:,:) - frcv(jpr_rnf)%z3(:,:,1) 820 !! ENDIF 821 !!gm end of internal cooking 1072 IF( srcv(jpr_rnf)%laction ) rnf(:,:) = frcv(jpr_rnf)%z3(:,:,1) 1073 IF( srcv(jpr_cal)%laction ) zemp(:,:) = zemp(:,:) - frcv(jpr_cal)%z3(:,:,1) 1074 1075 IF( ln_mixcpl ) THEN ; emp(:,:) = emp(:,:) * xcplmask(:,:,0) + zemp(:,:) * zmsk(:,:) 1076 ELSE ; emp(:,:) = zemp(:,:) 1077 ENDIF 822 1078 ! 823 1079 ! ! non solar heat flux over the ocean (qns) 824 IF( srcv(jpr_qnsoce)%laction ) qns(:,:) = frcv(jpr_qnsoce)%z3(:,:,1) 825 IF( srcv(jpr_qnsmix)%laction ) qns(:,:) = frcv(jpr_qnsmix)%z3(:,:,1) 1080 IF( srcv(jpr_qnsoce)%laction ) THEN ; zqns(:,:) = frcv(jpr_qnsoce)%z3(:,:,1) 1081 ELSE IF( srcv(jpr_qnsmix)%laction ) THEN ; zqns(:,:) = frcv(jpr_qnsmix)%z3(:,:,1) 1082 ELSE ; zqns(:,:) = 0._wp 1083 END IF 826 1084 ! update qns over the free ocean with: 827 qns(:,:) = qns(:,:) - emp(:,:) * sst_m(:,:) * rcp ! remove heat content due to mass flux (assumed to be at SST) 828 IF( srcv(jpr_snow )%laction ) THEN 829 qns(:,:) = qns(:,:) - frcv(jpr_snow)%z3(:,:,1) * lfus ! energy for melting solid precipitation over the free ocean 1085 IF( nn_components /= jp_iam_opa ) THEN 1086 zqns(:,:) = zqns(:,:) - zemp(:,:) * sst_m(:,:) * rcp ! remove heat content due to mass flux (assumed to be at SST) 1087 IF( srcv(jpr_snow )%laction ) THEN 1088 zqns(:,:) = zqns(:,:) - frcv(jpr_snow)%z3(:,:,1) * lfus ! energy for melting solid precipitation over the free ocean 1089 ENDIF 1090 ENDIF 1091 IF( ln_mixcpl ) THEN ; qns(:,:) = qns(:,:) * xcplmask(:,:,0) + zqns(:,:) * zmsk(:,:) 1092 ELSE ; qns(:,:) = zqns(:,:) 830 1093 ENDIF 831 1094 832 1095 ! ! solar flux over the ocean (qsr) 833 IF( srcv(jpr_qsroce)%laction ) qsr(:,:) = frcv(jpr_qsroce)%z3(:,:,1) 834 IF( srcv(jpr_qsrmix)%laction ) qsr(:,:) = frcv(jpr_qsrmix)%z3(:,:,1) 835 IF( ln_dm2dc ) qsr(:,:) = sbc_dcy( qsr ) ! modify qsr to include the diurnal cycle 1096 IF ( srcv(jpr_qsroce)%laction ) THEN ; zqsr(:,:) = frcv(jpr_qsroce)%z3(:,:,1) 1097 ELSE IF( srcv(jpr_qsrmix)%laction ) then ; zqsr(:,:) = frcv(jpr_qsrmix)%z3(:,:,1) 1098 ELSE ; zqsr(:,:) = 0._wp 1099 ENDIF 1100 IF( ln_dm2dc .AND. ln_cpl ) zqsr(:,:) = sbc_dcy( zqsr ) ! modify qsr to include the diurnal cycle 1101 IF( ln_mixcpl ) THEN ; qsr(:,:) = qsr(:,:) * xcplmask(:,:,0) + zqsr(:,:) * zmsk(:,:) 1102 ELSE ; qsr(:,:) = zqsr(:,:) 1103 ENDIF 836 1104 ! 837 838 ENDIF 839 ! 840 CALL wrk_dealloc( jpi,jpj, ztx, zty ) 1105 ! salt flux over the ocean (received by opa in case of opa <-> sas coupling) 1106 IF( srcv(jpr_sflx )%laction ) sfx(:,:) = frcv(jpr_sflx )%z3(:,:,1) 1107 ! Ice cover (received by opa in case of opa <-> sas coupling) 1108 IF( srcv(jpr_fice )%laction ) fr_i(:,:) = frcv(jpr_fice )%z3(:,:,1) 1109 ! 1110 1111 ENDIF 1112 ! 1113 CALL wrk_dealloc( jpi,jpj, ztx, zty, zmsk, zemp, zqns, zqsr ) 841 1114 ! 842 1115 IF( nn_timing == 1 ) CALL timing_stop('sbc_cpl_rcv') … … 935 1208 ! 936 1209 ENDIF 937 938 1210 ! ! ======================= ! 939 1211 ! ! put on ice grid ! … … 1057 1329 1058 1330 1059 SUBROUTINE sbc_cpl_ice_flx( p_frld , palbi , psst , pist)1331 SUBROUTINE sbc_cpl_ice_flx( p_frld, palbi, psst, pist ) 1060 1332 !!---------------------------------------------------------------------- 1061 1333 !! *** ROUTINE sbc_cpl_ice_flx *** … … 1099 1371 REAL(wp), INTENT(in ), DIMENSION(:,:) :: p_frld ! lead fraction [0 to 1] 1100 1372 ! optional arguments, used only in 'mixed oce-ice' case 1101 REAL(wp), INTENT(in ), DIMENSION(:,:,:), OPTIONAL :: palbi ! all skies ice albedo 1102 REAL(wp), INTENT(in ), DIMENSION(:,: ), OPTIONAL :: psst ! sea surface temperature [Celsius] 1103 REAL(wp), INTENT(in ), DIMENSION(:,:,:), OPTIONAL :: pist ! ice surface temperature [Kelvin] 1104 ! 1105 INTEGER :: jl ! dummy loop index 1106 REAL(wp), POINTER, DIMENSION(:,:) :: zcptn, ztmp, zicefr 1373 REAL(wp), INTENT(in ), DIMENSION(:,:,:), OPTIONAL :: palbi ! all skies ice albedo 1374 REAL(wp), INTENT(in ), DIMENSION(:,: ), OPTIONAL :: psst ! sea surface temperature [Celsius] 1375 REAL(wp), INTENT(in ), DIMENSION(:,:,:), OPTIONAL :: pist ! ice surface temperature [Kelvin] 1376 ! 1377 INTEGER :: jl ! dummy loop index 1378 REAL(wp), POINTER, DIMENSION(:,: ) :: zcptn, ztmp, zicefr, zmsk 1379 REAL(wp), POINTER, DIMENSION(:,: ) :: zemp_tot, zemp_ice, zsprecip, ztprecip, zqns_tot, zqsr_tot 1380 REAL(wp), POINTER, DIMENSION(:,:,:) :: zqns_ice, zqsr_ice, zdqns_ice 1381 REAL(wp), POINTER, DIMENSION(:,: ) :: zevap, zsnw, zqns_oce, zqsr_oce, zqprec_ice, zqemp_oce ! for LIM3 1107 1382 !!---------------------------------------------------------------------- 1108 1383 ! 1109 1384 IF( nn_timing == 1 ) CALL timing_start('sbc_cpl_ice_flx') 1110 1385 ! 1111 CALL wrk_alloc( jpi,jpj, zcptn, ztmp, zicefr ) 1112 1386 CALL wrk_alloc( jpi,jpj, zcptn, ztmp, zicefr, zmsk, zemp_tot, zemp_ice, zsprecip, ztprecip, zqns_tot, zqsr_tot ) 1387 CALL wrk_alloc( jpi,jpj,jpl, zqns_ice, zqsr_ice, zdqns_ice ) 1388 1389 IF( ln_mixcpl ) zmsk(:,:) = 1. - xcplmask(:,:,0) 1113 1390 zicefr(:,:) = 1.- p_frld(:,:) 1114 1391 zcptn(:,:) = rcp * sst_m(:,:) … … 1118 1395 ! ! ========================= ! 1119 1396 ! 1120 ! ! total Precipitations - total Evaporation (emp_tot) 1121 ! ! solid precipitation - sublimation (emp_ice) 1122 ! ! solid Precipitation (sprecip) 1397 ! ! total Precipitation - total Evaporation (emp_tot) 1398 ! ! solid precipitation - sublimation (emp_ice) 1399 ! ! solid Precipitation (sprecip) 1400 ! ! liquid + solid Precipitation (tprecip) 1123 1401 SELECT CASE( TRIM( sn_rcv_emp%cldes ) ) 1124 1402 CASE( 'conservative' ) ! received fields: jpr_rain, jpr_snow, jpr_ievp, jpr_tevp 1125 sprecip(:,:) = frcv(jpr_snow)%z3(:,:,1)! May need to ensure positive here1126 tprecip(:,:) = frcv(jpr_rain)%z3(:,:,1) + sprecip (:,:)! May need to ensure positive here1127 emp_tot(:,:) = frcv(jpr_tevp)%z3(:,:,1) -tprecip(:,:)1128 emp_ice(:,:) = frcv(jpr_ievp)%z3(:,:,1) - frcv(jpr_snow)%z3(:,:,1)1403 zsprecip(:,:) = frcv(jpr_snow)%z3(:,:,1) ! May need to ensure positive here 1404 ztprecip(:,:) = frcv(jpr_rain)%z3(:,:,1) + zsprecip(:,:) ! May need to ensure positive here 1405 zemp_tot(:,:) = frcv(jpr_tevp)%z3(:,:,1) - ztprecip(:,:) 1406 zemp_ice(:,:) = frcv(jpr_ievp)%z3(:,:,1) - frcv(jpr_snow)%z3(:,:,1) 1129 1407 CALL iom_put( 'rain' , frcv(jpr_rain)%z3(:,:,1) ) ! liquid precipitation 1130 1408 IF( iom_use('hflx_rain_cea') ) & … … 1137 1415 CALL iom_put( 'hflx_evap_cea', ztmp(:,:) * zcptn(:,:) ) ! heat flux from from evap (cell average) 1138 1416 CASE( 'oce and ice' ) ! received fields: jpr_sbpr, jpr_semp, jpr_oemp, jpr_ievp 1139 emp_tot(:,:) = p_frld(:,:) * frcv(jpr_oemp)%z3(:,:,1) + zicefr(:,:) * frcv(jpr_sbpr)%z3(:,:,1) 1140 emp_ice(:,:) = frcv(jpr_semp)%z3(:,:,1) 1141 sprecip(:,:) = - frcv(jpr_semp)%z3(:,:,1) + frcv(jpr_ievp)%z3(:,:,1) 1417 zemp_tot(:,:) = p_frld(:,:) * frcv(jpr_oemp)%z3(:,:,1) + zicefr(:,:) * frcv(jpr_sbpr)%z3(:,:,1) 1418 zemp_ice(:,:) = frcv(jpr_semp)%z3(:,:,1) 1419 zsprecip(:,:) = frcv(jpr_ievp)%z3(:,:,1) - frcv(jpr_semp)%z3(:,:,1) 1420 ztprecip(:,:) = frcv(jpr_semp)%z3(:,:,1) - frcv(jpr_sbpr)%z3(:,:,1) + zsprecip(:,:) 1142 1421 END SELECT 1422 1423 IF( iom_use('subl_ai_cea') ) & 1424 CALL iom_put( 'subl_ai_cea', frcv(jpr_ievp)%z3(:,:,1) * zicefr(:,:) ) ! Sublimation over sea-ice (cell average) 1425 ! 1426 ! ! runoffs and calving (put in emp_tot) 1427 IF( srcv(jpr_rnf)%laction ) rnf(:,:) = frcv(jpr_rnf)%z3(:,:,1) 1428 IF( srcv(jpr_cal)%laction ) THEN 1429 zemp_tot(:,:) = zemp_tot(:,:) - frcv(jpr_cal)%z3(:,:,1) 1430 CALL iom_put( 'calving_cea', frcv(jpr_cal)%z3(:,:,1) ) 1431 ENDIF 1432 1433 IF( ln_mixcpl ) THEN 1434 emp_tot(:,:) = emp_tot(:,:) * xcplmask(:,:,0) + zemp_tot(:,:) * zmsk(:,:) 1435 emp_ice(:,:) = emp_ice(:,:) * xcplmask(:,:,0) + zemp_ice(:,:) * zmsk(:,:) 1436 sprecip(:,:) = sprecip(:,:) * xcplmask(:,:,0) + zsprecip(:,:) * zmsk(:,:) 1437 tprecip(:,:) = tprecip(:,:) * xcplmask(:,:,0) + ztprecip(:,:) * zmsk(:,:) 1438 ELSE 1439 emp_tot(:,:) = zemp_tot(:,:) 1440 emp_ice(:,:) = zemp_ice(:,:) 1441 sprecip(:,:) = zsprecip(:,:) 1442 tprecip(:,:) = ztprecip(:,:) 1443 ENDIF 1143 1444 1144 1445 CALL iom_put( 'snowpre' , sprecip ) ! Snow … … 1147 1448 IF( iom_use('snow_ai_cea') ) & 1148 1449 CALL iom_put( 'snow_ai_cea', sprecip(:,:) * zicefr(:,:) ) ! Snow over sea-ice (cell average) 1149 IF( iom_use('subl_ai_cea') ) &1150 CALL iom_put( 'subl_ai_cea', frcv(jpr_ievp)%z3(:,:,1) * zicefr(:,:) ) ! Sublimation over sea-ice (cell average)1151 !1152 ! ! runoffs and calving (put in emp_tot)1153 IF( srcv(jpr_rnf)%laction ) THEN1154 emp_tot(:,:) = emp_tot(:,:) - frcv(jpr_rnf)%z3(:,:,1)1155 CALL iom_put( 'runoffs' , frcv(jpr_rnf)%z3(:,:,1) ) ! rivers1156 IF( iom_use('hflx_rnf_cea') ) &1157 CALL iom_put( 'hflx_rnf_cea' , frcv(jpr_rnf)%z3(:,:,1) * zcptn(:,:) ) ! heat flux from rivers1158 ENDIF1159 IF( srcv(jpr_cal)%laction ) THEN1160 emp_tot(:,:) = emp_tot(:,:) - frcv(jpr_cal)%z3(:,:,1)1161 CALL iom_put( 'calving', frcv(jpr_cal)%z3(:,:,1) )1162 ENDIF1163 !1164 !!gm : this seems to be internal cooking, not sure to need that in a generic interface1165 !!gm at least should be optional...1166 !! ! remove negative runoff ! sum over the global domain1167 !! zcumulpos = SUM( MAX( frcv(jpr_rnf)%z3(:,:,1), 0.e0 ) * e1t(:,:) * e2t(:,:) * tmask_i(:,:) )1168 !! zcumulneg = SUM( MIN( frcv(jpr_rnf)%z3(:,:,1), 0.e0 ) * e1t(:,:) * e2t(:,:) * tmask_i(:,:) )1169 !! IF( lk_mpp ) CALL mpp_sum( zcumulpos )1170 !! IF( lk_mpp ) CALL mpp_sum( zcumulneg )1171 !! IF( zcumulpos /= 0. ) THEN ! distribute negative runoff on positive runoff grid points1172 !! zcumulneg = 1.e0 + zcumulneg / zcumulpos1173 !! frcv(jpr_rnf)%z3(:,:,1) = MAX( frcv(jpr_rnf)%z3(:,:,1), 0.e0 ) * zcumulneg1174 !! ENDIF1175 !! emp_tot(:,:) = emp_tot(:,:) - frcv(jpr_rnf)%z3(:,:,1) ! add runoff to e-p1176 !!1177 !!gm end of internal cooking1178 1450 1179 1451 ! ! ========================= ! … … 1181 1453 ! ! ========================= ! 1182 1454 CASE( 'oce only' ) ! the required field is directly provided 1183 qns_tot(:,: ) = frcv(jpr_qnsoce)%z3(:,:,1)1455 zqns_tot(:,: ) = frcv(jpr_qnsoce)%z3(:,:,1) 1184 1456 CASE( 'conservative' ) ! the required fields are directly provided 1185 qns_tot(:,: ) = frcv(jpr_qnsmix)%z3(:,:,1)1457 zqns_tot(:,: ) = frcv(jpr_qnsmix)%z3(:,:,1) 1186 1458 IF ( TRIM(sn_rcv_qns%clcat) == 'yes' ) THEN 1187 qns_ice(:,:,1:jpl) = frcv(jpr_qnsice)%z3(:,:,1:jpl)1459 zqns_ice(:,:,1:jpl) = frcv(jpr_qnsice)%z3(:,:,1:jpl) 1188 1460 ELSE 1189 1461 ! Set all category values equal for the moment 1190 1462 DO jl=1,jpl 1191 qns_ice(:,:,jl) = frcv(jpr_qnsice)%z3(:,:,1)1463 zqns_ice(:,:,jl) = frcv(jpr_qnsice)%z3(:,:,1) 1192 1464 ENDDO 1193 1465 ENDIF 1194 1466 CASE( 'oce and ice' ) ! the total flux is computed from ocean and ice fluxes 1195 qns_tot(:,: ) = p_frld(:,:) * frcv(jpr_qnsoce)%z3(:,:,1)1467 zqns_tot(:,: ) = p_frld(:,:) * frcv(jpr_qnsoce)%z3(:,:,1) 1196 1468 IF ( TRIM(sn_rcv_qns%clcat) == 'yes' ) THEN 1197 1469 DO jl=1,jpl 1198 qns_tot(:,: ) =qns_tot(:,:) + a_i(:,:,jl) * frcv(jpr_qnsice)%z3(:,:,jl)1199 qns_ice(:,:,jl) = frcv(jpr_qnsice)%z3(:,:,jl)1470 zqns_tot(:,: ) = zqns_tot(:,:) + a_i(:,:,jl) * frcv(jpr_qnsice)%z3(:,:,jl) 1471 zqns_ice(:,:,jl) = frcv(jpr_qnsice)%z3(:,:,jl) 1200 1472 ENDDO 1201 1473 ELSE 1474 qns_tot(:,: ) = qns_tot(:,:) + zicefr(:,:) * frcv(jpr_qnsice)%z3(:,:,1) 1202 1475 DO jl=1,jpl 1203 qns_tot(:,: ) =qns_tot(:,:) + zicefr(:,:) * frcv(jpr_qnsice)%z3(:,:,1)1204 qns_ice(:,:,jl) = frcv(jpr_qnsice)%z3(:,:,1)1476 zqns_tot(:,: ) = zqns_tot(:,:) + zicefr(:,:) * frcv(jpr_qnsice)%z3(:,:,1) 1477 zqns_ice(:,:,jl) = frcv(jpr_qnsice)%z3(:,:,1) 1205 1478 ENDDO 1206 1479 ENDIF 1207 1480 CASE( 'mixed oce-ice' ) ! the ice flux is cumputed from the total flux, the SST and ice informations 1208 1481 ! ** NEED TO SORT OUT HOW THIS SHOULD WORK IN THE MULTI-CATEGORY CASE - CURRENTLY NOT ALLOWED WHEN INTERFACE INITIALISED ** 1209 qns_tot(:,: ) = frcv(jpr_qnsmix)%z3(:,:,1)1210 qns_ice(:,:,1) = frcv(jpr_qnsmix)%z3(:,:,1) &1482 zqns_tot(:,: ) = frcv(jpr_qnsmix)%z3(:,:,1) 1483 zqns_ice(:,:,1) = frcv(jpr_qnsmix)%z3(:,:,1) & 1211 1484 & + frcv(jpr_dqnsdt)%z3(:,:,1) * ( pist(:,:,1) - ( (rt0 + psst(:,: ) ) * p_frld(:,:) & 1212 1485 & + pist(:,:,1) * zicefr(:,:) ) ) 1213 1486 END SELECT 1214 ztmp(:,:) = p_frld(:,:) * sprecip(:,:) * lfus1215 qns_tot(:,:) = qns_tot(:,:) & ! qns_tot update over free ocean with:1216 & - ztmp(:,:) & ! remove the latent heat flux of solid precip. melting1217 & - ( emp_tot(:,:) & ! remove the heat content of mass flux (assumed to be at SST)1218 & - emp_ice(:,:) * zicefr(:,:) ) * zcptn(:,:)1219 IF( iom_use('hflx_snow_cea') ) &1220 CALL iom_put( 'hflx_snow_cea', ztmp + sprecip(:,:) * zcptn(:,:) ) ! heat flux from snow (cell average)1221 1487 !!gm 1222 !! currently it is taken into account in leads budget but not in the qns_tot, and thus not in1488 !! currently it is taken into account in leads budget but not in the zqns_tot, and thus not in 1223 1489 !! the flux that enter the ocean.... 1224 1490 !! moreover 1 - it is not diagnose anywhere.... … … 1229 1495 IF( srcv(jpr_cal)%laction ) THEN ! Iceberg melting 1230 1496 ztmp(:,:) = frcv(jpr_cal)%z3(:,:,1) * lfus ! add the latent heat of iceberg melting 1231 qns_tot(:,:) =qns_tot(:,:) - ztmp(:,:)1497 zqns_tot(:,:) = zqns_tot(:,:) - ztmp(:,:) 1232 1498 IF( iom_use('hflx_cal_cea') ) & 1233 1499 CALL iom_put( 'hflx_cal_cea', ztmp + frcv(jpr_cal)%z3(:,:,1) * zcptn(:,:) ) ! heat flux from calving 1234 1500 ENDIF 1501 1502 ztmp(:,:) = p_frld(:,:) * zsprecip(:,:) * lfus 1503 IF( iom_use('hflx_snow_cea') ) CALL iom_put( 'hflx_snow_cea', ztmp + sprecip(:,:) * zcptn(:,:) ) ! heat flux from snow (cell average) 1504 1505 #if defined key_lim3 1506 CALL wrk_alloc( jpi,jpj, zevap, zsnw, zqns_oce, zqprec_ice, zqemp_oce ) 1507 1508 ! --- evaporation --- ! 1509 ! clem: evap_ice is set to 0 for LIM3 since we still do not know what to do with sublimation 1510 ! the problem is: the atm. imposes both mass evaporation and heat removed from the snow/ice 1511 ! but it is incoherent WITH the ice model 1512 DO jl=1,jpl 1513 evap_ice(:,:,jl) = 0._wp ! should be: frcv(jpr_ievp)%z3(:,:,1) 1514 ENDDO 1515 zevap(:,:) = zemp_tot(:,:) + ztprecip(:,:) ! evaporation over ocean 1516 1517 ! --- evaporation minus precipitation --- ! 1518 emp_oce(:,:) = emp_tot(:,:) - emp_ice(:,:) 1519 1520 ! --- non solar flux over ocean --- ! 1521 ! note: p_frld cannot be = 0 since we limit the ice concentration to amax 1522 zqns_oce = 0._wp 1523 WHERE( p_frld /= 0._wp ) zqns_oce(:,:) = ( zqns_tot(:,:) - SUM( a_i * zqns_ice, dim=3 ) ) / p_frld(:,:) 1524 1525 ! --- heat flux associated with emp --- ! 1526 zsnw(:,:) = 0._wp 1527 CALL lim_thd_snwblow( p_frld, zsnw ) ! snow distribution over ice after wind blowing 1528 zqemp_oce(:,:) = - zevap(:,:) * p_frld(:,:) * zcptn(:,:) & ! evap 1529 & + ( ztprecip(:,:) - zsprecip(:,:) ) * zcptn(:,:) & ! liquid precip 1530 & + zsprecip(:,:) * ( 1._wp - zsnw ) * ( zcptn(:,:) - lfus ) ! solid precip over ocean 1531 qemp_ice(:,:) = - frcv(jpr_ievp)%z3(:,:,1) * zicefr(:,:) * zcptn(:,:) & ! ice evap 1532 & + zsprecip(:,:) * zsnw * ( zcptn(:,:) - lfus ) ! solid precip over ice 1533 1534 ! --- heat content of precip over ice in J/m3 (to be used in 1D-thermo) --- ! 1535 zqprec_ice(:,:) = rhosn * ( zcptn(:,:) - lfus ) 1536 1537 ! --- total non solar flux --- ! 1538 zqns_tot(:,:) = zqns_tot(:,:) + qemp_ice(:,:) + zqemp_oce(:,:) 1539 1540 ! --- in case both coupled/forced are active, we must mix values --- ! 1541 IF( ln_mixcpl ) THEN 1542 qns_tot(:,:) = qns_tot(:,:) * xcplmask(:,:,0) + zqns_tot(:,:)* zmsk(:,:) 1543 qns_oce(:,:) = qns_oce(:,:) * xcplmask(:,:,0) + zqns_oce(:,:)* zmsk(:,:) 1544 DO jl=1,jpl 1545 qns_ice(:,:,jl) = qns_ice(:,:,jl) * xcplmask(:,:,0) + zqns_ice(:,:,jl)* zmsk(:,:) 1546 ENDDO 1547 qprec_ice(:,:) = qprec_ice(:,:) * xcplmask(:,:,0) + zqprec_ice(:,:)* zmsk(:,:) 1548 qemp_oce (:,:) = qemp_oce(:,:) * xcplmask(:,:,0) + zqemp_oce(:,:)* zmsk(:,:) 1549 !!clem evap_ice(:,:) = evap_ice(:,:) * xcplmask(:,:,0) 1550 ELSE 1551 qns_tot (:,: ) = zqns_tot (:,: ) 1552 qns_oce (:,: ) = zqns_oce (:,: ) 1553 qns_ice (:,:,:) = zqns_ice (:,:,:) 1554 qprec_ice(:,:) = zqprec_ice(:,:) 1555 qemp_oce (:,:) = zqemp_oce (:,:) 1556 ENDIF 1557 1558 CALL wrk_dealloc( jpi,jpj, zevap, zsnw, zqns_oce, zqprec_ice, zqemp_oce ) 1559 #else 1560 1561 ! clem: this formulation is certainly wrong... but better than it was... 1562 zqns_tot(:,:) = zqns_tot(:,:) & ! zqns_tot update over free ocean with: 1563 & - ztmp(:,:) & ! remove the latent heat flux of solid precip. melting 1564 & - ( zemp_tot(:,:) & ! remove the heat content of mass flux (assumed to be at SST) 1565 & - zemp_ice(:,:) * zicefr(:,:) ) * zcptn(:,:) 1566 1567 IF( ln_mixcpl ) THEN 1568 qns_tot(:,:) = qns(:,:) * p_frld(:,:) + SUM( qns_ice(:,:,:) * a_i(:,:,:), dim=3 ) ! total flux from blk 1569 qns_tot(:,:) = qns_tot(:,:) * xcplmask(:,:,0) + zqns_tot(:,:)* zmsk(:,:) 1570 DO jl=1,jpl 1571 qns_ice(:,:,jl) = qns_ice(:,:,jl) * xcplmask(:,:,0) + zqns_ice(:,:,jl)* zmsk(:,:) 1572 ENDDO 1573 ELSE 1574 qns_tot(:,: ) = zqns_tot(:,: ) 1575 qns_ice(:,:,:) = zqns_ice(:,:,:) 1576 ENDIF 1577 1578 #endif 1235 1579 1236 1580 ! ! ========================= ! … … 1238 1582 ! ! ========================= ! 1239 1583 CASE( 'oce only' ) 1240 qsr_tot(:,: ) = MAX( 0._wp , frcv(jpr_qsroce)%z3(:,:,1) )1584 zqsr_tot(:,: ) = MAX( 0._wp , frcv(jpr_qsroce)%z3(:,:,1) ) 1241 1585 CASE( 'conservative' ) 1242 qsr_tot(:,: ) = frcv(jpr_qsrmix)%z3(:,:,1)1586 zqsr_tot(:,: ) = frcv(jpr_qsrmix)%z3(:,:,1) 1243 1587 IF ( TRIM(sn_rcv_qsr%clcat) == 'yes' ) THEN 1244 qsr_ice(:,:,1:jpl) = frcv(jpr_qsrice)%z3(:,:,1:jpl)1588 zqsr_ice(:,:,1:jpl) = frcv(jpr_qsrice)%z3(:,:,1:jpl) 1245 1589 ELSE 1246 1590 ! Set all category values equal for the moment 1247 1591 DO jl=1,jpl 1248 qsr_ice(:,:,jl) = frcv(jpr_qsrice)%z3(:,:,1)1592 zqsr_ice(:,:,jl) = frcv(jpr_qsrice)%z3(:,:,1) 1249 1593 ENDDO 1250 1594 ENDIF 1251 qsr_tot(:,: ) = frcv(jpr_qsrmix)%z3(:,:,1)1252 qsr_ice(:,:,1) = frcv(jpr_qsrice)%z3(:,:,1)1595 zqsr_tot(:,: ) = frcv(jpr_qsrmix)%z3(:,:,1) 1596 zqsr_ice(:,:,1) = frcv(jpr_qsrice)%z3(:,:,1) 1253 1597 CASE( 'oce and ice' ) 1254 qsr_tot(:,: ) = p_frld(:,:) * frcv(jpr_qsroce)%z3(:,:,1)1598 zqsr_tot(:,: ) = p_frld(:,:) * frcv(jpr_qsroce)%z3(:,:,1) 1255 1599 IF ( TRIM(sn_rcv_qsr%clcat) == 'yes' ) THEN 1256 1600 DO jl=1,jpl 1257 qsr_tot(:,: ) =qsr_tot(:,:) + a_i(:,:,jl) * frcv(jpr_qsrice)%z3(:,:,jl)1258 qsr_ice(:,:,jl) = frcv(jpr_qsrice)%z3(:,:,jl)1601 zqsr_tot(:,: ) = zqsr_tot(:,:) + a_i(:,:,jl) * frcv(jpr_qsrice)%z3(:,:,jl) 1602 zqsr_ice(:,:,jl) = frcv(jpr_qsrice)%z3(:,:,jl) 1259 1603 ENDDO 1260 1604 ELSE 1605 qsr_tot(:,: ) = qsr_tot(:,:) + zicefr(:,:) * frcv(jpr_qsrice)%z3(:,:,1) 1261 1606 DO jl=1,jpl 1262 qsr_tot(:,: ) =qsr_tot(:,:) + zicefr(:,:) * frcv(jpr_qsrice)%z3(:,:,1)1263 qsr_ice(:,:,jl) = frcv(jpr_qsrice)%z3(:,:,1)1607 zqsr_tot(:,: ) = zqsr_tot(:,:) + zicefr(:,:) * frcv(jpr_qsrice)%z3(:,:,1) 1608 zqsr_ice(:,:,jl) = frcv(jpr_qsrice)%z3(:,:,1) 1264 1609 ENDDO 1265 1610 ENDIF 1266 1611 CASE( 'mixed oce-ice' ) 1267 qsr_tot(:,: ) = frcv(jpr_qsrmix)%z3(:,:,1)1612 zqsr_tot(:,: ) = frcv(jpr_qsrmix)%z3(:,:,1) 1268 1613 ! ** NEED TO SORT OUT HOW THIS SHOULD WORK IN THE MULTI-CATEGORY CASE - CURRENTLY NOT ALLOWED WHEN INTERFACE INITIALISED ** 1269 1614 ! Create solar heat flux over ice using incoming solar heat flux and albedos 1270 1615 ! ( see OASIS3 user guide, 5th edition, p39 ) 1271 qsr_ice(:,:,1) = frcv(jpr_qsrmix)%z3(:,:,1) * ( 1.- palbi(:,:,1) ) &1616 zqsr_ice(:,:,1) = frcv(jpr_qsrmix)%z3(:,:,1) * ( 1.- palbi(:,:,1) ) & 1272 1617 & / ( 1.- ( albedo_oce_mix(:,: ) * p_frld(:,:) & 1273 1618 & + palbi (:,:,1) * zicefr(:,:) ) ) 1274 1619 END SELECT 1275 IF( ln_dm2dc ) THEN ! modify qsr to include the diurnal cycle1276 qsr_tot(:,: ) = sbc_dcy(qsr_tot(:,: ) )1620 IF( ln_dm2dc .AND. ln_cpl ) THEN ! modify qsr to include the diurnal cycle 1621 zqsr_tot(:,: ) = sbc_dcy( zqsr_tot(:,: ) ) 1277 1622 DO jl=1,jpl 1278 qsr_ice(:,:,jl) = sbc_dcy(qsr_ice(:,:,jl) )1623 zqsr_ice(:,:,jl) = sbc_dcy( zqsr_ice(:,:,jl) ) 1279 1624 ENDDO 1625 ENDIF 1626 1627 #if defined key_lim3 1628 CALL wrk_alloc( jpi,jpj, zqsr_oce ) 1629 ! --- solar flux over ocean --- ! 1630 ! note: p_frld cannot be = 0 since we limit the ice concentration to amax 1631 zqsr_oce = 0._wp 1632 WHERE( p_frld /= 0._wp ) zqsr_oce(:,:) = ( zqsr_tot(:,:) - SUM( a_i * zqsr_ice, dim=3 ) ) / p_frld(:,:) 1633 1634 IF( ln_mixcpl ) THEN ; qsr_oce(:,:) = qsr_oce(:,:) * xcplmask(:,:,0) + zqsr_oce(:,:)* zmsk(:,:) 1635 ELSE ; qsr_oce(:,:) = zqsr_oce(:,:) ; ENDIF 1636 1637 CALL wrk_dealloc( jpi,jpj, zqsr_oce ) 1638 #endif 1639 1640 IF( ln_mixcpl ) THEN 1641 qsr_tot(:,:) = qsr(:,:) * p_frld(:,:) + SUM( qsr_ice(:,:,:) * a_i(:,:,:), dim=3 ) ! total flux from blk 1642 qsr_tot(:,:) = qsr_tot(:,:) * xcplmask(:,:,0) + zqsr_tot(:,:)* zmsk(:,:) 1643 DO jl=1,jpl 1644 qsr_ice(:,:,jl) = qsr_ice(:,:,jl) * xcplmask(:,:,0) + zqsr_ice(:,:,jl)* zmsk(:,:) 1645 ENDDO 1646 ELSE 1647 qsr_tot(:,: ) = zqsr_tot(:,: ) 1648 qsr_ice(:,:,:) = zqsr_ice(:,:,:) 1280 1649 ENDIF 1281 1650 … … 1285 1654 CASE ('coupled') 1286 1655 IF ( TRIM(sn_rcv_dqnsdt%clcat) == 'yes' ) THEN 1287 dqns_ice(:,:,1:jpl) = frcv(jpr_dqnsdt)%z3(:,:,1:jpl)1656 zdqns_ice(:,:,1:jpl) = frcv(jpr_dqnsdt)%z3(:,:,1:jpl) 1288 1657 ELSE 1289 1658 ! Set all category values equal for the moment 1290 1659 DO jl=1,jpl 1291 dqns_ice(:,:,jl) = frcv(jpr_dqnsdt)%z3(:,:,1)1660 zdqns_ice(:,:,jl) = frcv(jpr_dqnsdt)%z3(:,:,1) 1292 1661 ENDDO 1293 1662 ENDIF 1294 1663 END SELECT 1295 1664 1665 IF( ln_mixcpl ) THEN 1666 DO jl=1,jpl 1667 dqns_ice(:,:,jl) = dqns_ice(:,:,jl) * xcplmask(:,:,0) + zdqns_ice(:,:,jl) * zmsk(:,:) 1668 ENDDO 1669 ELSE 1670 dqns_ice(:,:,:) = zdqns_ice(:,:,:) 1671 ENDIF 1672 1296 1673 ! ! ========================= ! 1297 1674 SELECT CASE( TRIM( sn_rcv_iceflx%cldes ) ) ! topmelt and botmelt ! … … 1309 1686 fr2_i0(:,:) = ( 0.82 * ( 1.0 - cldf_ice ) + 0.65 * cldf_ice ) 1310 1687 1311 CALL wrk_dealloc( jpi,jpj, zcptn, ztmp, zicefr ) 1688 CALL wrk_dealloc( jpi,jpj, zcptn, ztmp, zicefr, zmsk, zemp_tot, zemp_ice, zsprecip, ztprecip, zqns_tot, zqsr_tot ) 1689 CALL wrk_dealloc( jpi,jpj,jpl, zqns_ice, zqsr_ice, zdqns_ice ) 1312 1690 ! 1313 1691 IF( nn_timing == 1 ) CALL timing_stop('sbc_cpl_ice_flx') … … 1329 1707 INTEGER :: ji, jj, jl ! dummy loop indices 1330 1708 INTEGER :: isec, info ! local integer 1709 REAL(wp) :: zumax, zvmax 1331 1710 REAL(wp), POINTER, DIMENSION(:,:) :: zfr_l, ztmp1, ztmp2, zotx1, zoty1, zotz1, zitx1, zity1, zitz1 1332 1711 REAL(wp), POINTER, DIMENSION(:,:,:) :: ztmp3, ztmp4 … … 1345 1724 ! ! ------------------------- ! 1346 1725 IF( ssnd(jps_toce)%laction .OR. ssnd(jps_tice)%laction .OR. ssnd(jps_tmix)%laction ) THEN 1347 SELECT CASE( sn_snd_temp%cldes) 1348 CASE( 'oce only' ) ; ztmp1(:,:) = tsn(:,:,1,jp_tem) + rt0 1349 CASE( 'weighted oce and ice' ) ; ztmp1(:,:) = ( tsn(:,:,1,jp_tem) + rt0 ) * zfr_l(:,:) 1350 SELECT CASE( sn_snd_temp%clcat ) 1351 CASE( 'yes' ) 1352 ztmp3(:,:,1:jpl) = tn_ice(:,:,1:jpl) * a_i(:,:,1:jpl) 1353 CASE( 'no' ) 1354 ztmp3(:,:,:) = 0.0 1726 1727 IF ( nn_components == jp_iam_opa ) THEN 1728 ztmp1(:,:) = tsn(:,:,1,jp_tem) ! send temperature as it is (potential or conservative) -> use of ln_useCT on the received part 1729 ELSE 1730 ! we must send the surface potential temperature 1731 IF( ln_useCT ) THEN ; ztmp1(:,:) = eos_pt_from_ct( tsn(:,:,1,jp_tem), tsn(:,:,1,jp_sal) ) 1732 ELSE ; ztmp1(:,:) = tsn(:,:,1,jp_tem) 1733 ENDIF 1734 ! 1735 SELECT CASE( sn_snd_temp%cldes) 1736 CASE( 'oce only' ) ; ztmp1(:,:) = ztmp1(:,:) + rt0 1737 CASE( 'oce and ice' ) ; ztmp1(:,:) = ztmp1(:,:) + rt0 1738 SELECT CASE( sn_snd_temp%clcat ) 1739 CASE( 'yes' ) 1740 ztmp3(:,:,1:jpl) = tn_ice(:,:,1:jpl) 1741 CASE( 'no' ) 1742 WHERE( SUM( a_i, dim=3 ) /= 0. ) 1743 ztmp3(:,:,1) = SUM( tn_ice * a_i, dim=3 ) / SUM( a_i, dim=3 ) 1744 ELSEWHERE 1745 ztmp3(:,:,1) = rt0 ! TODO: Is freezing point a good default? (Maybe SST is better?) 1746 END WHERE 1747 CASE default ; CALL ctl_stop( 'sbc_cpl_snd: wrong definition of sn_snd_temp%clcat' ) 1748 END SELECT 1749 CASE( 'weighted oce and ice' ) ; ztmp1(:,:) = ( ztmp1(:,:) + rt0 ) * zfr_l(:,:) 1750 SELECT CASE( sn_snd_temp%clcat ) 1751 CASE( 'yes' ) 1752 ztmp3(:,:,1:jpl) = tn_ice(:,:,1:jpl) * a_i(:,:,1:jpl) 1753 CASE( 'no' ) 1754 ztmp3(:,:,:) = 0.0 1755 DO jl=1,jpl 1756 ztmp3(:,:,1) = ztmp3(:,:,1) + tn_ice(:,:,jl) * a_i(:,:,jl) 1757 ENDDO 1758 CASE default ; CALL ctl_stop( 'sbc_cpl_snd: wrong definition of sn_snd_temp%clcat' ) 1759 END SELECT 1760 CASE( 'mixed oce-ice' ) 1761 ztmp1(:,:) = ( ztmp1(:,:) + rt0 ) * zfr_l(:,:) 1355 1762 DO jl=1,jpl 1356 ztmp 3(:,:,1) = ztmp3(:,:,1) + tn_ice(:,:,jl) * a_i(:,:,jl)1763 ztmp1(:,:) = ztmp1(:,:) + tn_ice(:,:,jl) * a_i(:,:,jl) 1357 1764 ENDDO 1358 CASE default ; CALL ctl_stop( 'sbc_cpl_snd: wrong definition of sn_snd_temp%clcat' )1765 CASE default ; CALL ctl_stop( 'sbc_cpl_snd: wrong definition of sn_snd_temp%cldes' ) 1359 1766 END SELECT 1360 CASE( 'mixed oce-ice' ) 1361 ztmp1(:,:) = ( tsn(:,:,1,jp_tem) + rt0 ) * zfr_l(:,:) 1362 DO jl=1,jpl 1363 ztmp1(:,:) = ztmp1(:,:) + tn_ice(:,:,jl) * a_i(:,:,jl) 1364 ENDDO 1365 CASE default ; CALL ctl_stop( 'sbc_cpl_snd: wrong definition of sn_snd_temp%cldes' ) 1366 END SELECT 1767 ENDIF 1367 1768 IF( ssnd(jps_toce)%laction ) CALL cpl_snd( jps_toce, isec, RESHAPE ( ztmp1, (/jpi,jpj,1/) ), info ) 1368 1769 IF( ssnd(jps_tice)%laction ) CALL cpl_snd( jps_tice, isec, ztmp3, info ) … … 1373 1774 ! ! ------------------------- ! 1374 1775 IF( ssnd(jps_albice)%laction ) THEN ! ice 1375 ztmp3(:,:,1:jpl) = alb_ice(:,:,1:jpl) * a_i(:,:,1:jpl) 1776 SELECT CASE( sn_snd_alb%cldes ) 1777 CASE( 'ice' ) ; ztmp3(:,:,1:jpl) = alb_ice(:,:,1:jpl) 1778 CASE( 'weighted ice' ) ; ztmp3(:,:,1:jpl) = alb_ice(:,:,1:jpl) * a_i(:,:,1:jpl) 1779 CASE default ; CALL ctl_stop( 'sbc_cpl_snd: wrong definition of sn_snd_alb%cldes' ) 1780 END SELECT 1376 1781 CALL cpl_snd( jps_albice, isec, ztmp3, info ) 1377 1782 ENDIF … … 1386 1791 ! ! Ice fraction & Thickness ! 1387 1792 ! ! ------------------------- ! 1388 ! Send ice fraction field 1793 ! Send ice fraction field to atmosphere 1389 1794 IF( ssnd(jps_fice)%laction ) THEN 1390 1795 SELECT CASE( sn_snd_thick%clcat ) … … 1393 1798 CASE default ; CALL ctl_stop( 'sbc_cpl_snd: wrong definition of sn_snd_thick%clcat' ) 1394 1799 END SELECT 1395 CALL cpl_snd( jps_fice, isec, ztmp3, info ) 1800 IF( ssnd(jps_fice)%laction ) CALL cpl_snd( jps_fice, isec, ztmp3, info ) 1801 ENDIF 1802 1803 ! Send ice fraction field to OPA (sent by SAS in SAS-OPA coupling) 1804 IF( ssnd(jps_fice2)%laction ) THEN 1805 ztmp3(:,:,1) = fr_i(:,:) 1806 IF( ssnd(jps_fice2)%laction ) CALL cpl_snd( jps_fice2, isec, ztmp3, info ) 1396 1807 ENDIF 1397 1808 … … 1414 1825 END SELECT 1415 1826 CASE( 'ice and snow' ) 1416 ztmp3(:,:,1:jpl) = ht_i(:,:,1:jpl) 1417 ztmp4(:,:,1:jpl) = ht_s(:,:,1:jpl) 1827 SELECT CASE( sn_snd_thick%clcat ) 1828 CASE( 'yes' ) 1829 ztmp3(:,:,1:jpl) = ht_i(:,:,1:jpl) 1830 ztmp4(:,:,1:jpl) = ht_s(:,:,1:jpl) 1831 CASE( 'no' ) 1832 WHERE( SUM( a_i, dim=3 ) /= 0. ) 1833 ztmp3(:,:,1) = SUM( ht_i * a_i, dim=3 ) / SUM( a_i, dim=3 ) 1834 ztmp4(:,:,1) = SUM( ht_s * a_i, dim=3 ) / SUM( a_i, dim=3 ) 1835 ELSEWHERE 1836 ztmp3(:,:,1) = 0. 1837 ztmp4(:,:,1) = 0. 1838 END WHERE 1839 CASE default ; CALL ctl_stop( 'sbc_cpl_snd: wrong definition of sn_snd_thick%clcat' ) 1840 END SELECT 1418 1841 CASE default ; CALL ctl_stop( 'sbc_cpl_snd: wrong definition of sn_snd_thick%cldes' ) 1419 1842 END SELECT … … 1441 1864 ! i-1 i i 1442 1865 ! i i+1 (for I) 1443 SELECT CASE( TRIM( sn_snd_crt%cldes ) ) 1444 CASE( 'oce only' ) ! C-grid ==> T 1445 DO jj = 2, jpjm1 1446 DO ji = fs_2, fs_jpim1 ! vector opt. 1447 zotx1(ji,jj) = 0.5 * ( un(ji,jj,1) + un(ji-1,jj ,1) ) 1448 zoty1(ji,jj) = 0.5 * ( vn(ji,jj,1) + vn(ji ,jj-1,1) ) 1449 END DO 1450 END DO 1451 CASE( 'weighted oce and ice' ) 1452 SELECT CASE ( cp_ice_msh ) 1453 CASE( 'C' ) ! Ocean and Ice on C-grid ==> T 1866 IF( nn_components == jp_iam_opa ) THEN 1867 zotx1(:,:) = un(:,:,1) 1868 zoty1(:,:) = vn(:,:,1) 1869 ELSE 1870 SELECT CASE( TRIM( sn_snd_crt%cldes ) ) 1871 CASE( 'oce only' ) ! C-grid ==> T 1454 1872 DO jj = 2, jpjm1 1455 1873 DO ji = fs_2, fs_jpim1 ! vector opt. 1456 zotx1(ji,jj) = 0.5 * ( un (ji,jj,1) + un (ji-1,jj ,1) ) * zfr_l(ji,jj) 1457 zoty1(ji,jj) = 0.5 * ( vn (ji,jj,1) + vn (ji ,jj-1,1) ) * zfr_l(ji,jj) 1458 zitx1(ji,jj) = 0.5 * ( u_ice(ji,jj ) + u_ice(ji-1,jj ) ) * fr_i(ji,jj) 1459 zity1(ji,jj) = 0.5 * ( v_ice(ji,jj ) + v_ice(ji ,jj-1 ) ) * fr_i(ji,jj) 1874 zotx1(ji,jj) = 0.5 * ( un(ji,jj,1) + un(ji-1,jj ,1) ) 1875 zoty1(ji,jj) = 0.5 * ( vn(ji,jj,1) + vn(ji ,jj-1,1) ) 1460 1876 END DO 1461 1877 END DO 1462 CASE( 'I' ) ! Ocean on C grid, Ice on I-point (B-grid) ==> T 1463 DO jj = 2, jpjm1 1464 DO ji = 2, jpim1 ! NO vector opt. 1465 zotx1(ji,jj) = 0.5 * ( un(ji,jj,1) + un(ji-1,jj ,1) ) * zfr_l(ji,jj) 1466 zoty1(ji,jj) = 0.5 * ( vn(ji,jj,1) + vn(ji ,jj-1,1) ) * zfr_l(ji,jj) 1467 zitx1(ji,jj) = 0.25 * ( u_ice(ji+1,jj+1) + u_ice(ji,jj+1) & 1468 & + u_ice(ji+1,jj ) + u_ice(ji,jj ) ) * fr_i(ji,jj) 1469 zity1(ji,jj) = 0.25 * ( v_ice(ji+1,jj+1) + v_ice(ji,jj+1) & 1470 & + v_ice(ji+1,jj ) + v_ice(ji,jj ) ) * fr_i(ji,jj) 1878 CASE( 'weighted oce and ice' ) 1879 SELECT CASE ( cp_ice_msh ) 1880 CASE( 'C' ) ! Ocean and Ice on C-grid ==> T 1881 DO jj = 2, jpjm1 1882 DO ji = fs_2, fs_jpim1 ! vector opt. 1883 zotx1(ji,jj) = 0.5 * ( un (ji,jj,1) + un (ji-1,jj ,1) ) * zfr_l(ji,jj) 1884 zoty1(ji,jj) = 0.5 * ( vn (ji,jj,1) + vn (ji ,jj-1,1) ) * zfr_l(ji,jj) 1885 zitx1(ji,jj) = 0.5 * ( u_ice(ji,jj ) + u_ice(ji-1,jj ) ) * fr_i(ji,jj) 1886 zity1(ji,jj) = 0.5 * ( v_ice(ji,jj ) + v_ice(ji ,jj-1 ) ) * fr_i(ji,jj) 1887 END DO 1471 1888 END DO 1472 END DO1473 CASE( 'F' ) ! Ocean on C grid, Ice on F-point (B-grid) ==> T1474 DO jj = 2, jpjm11475 DO ji = 2, jpim1 ! NO vector opt.1476 zotx1(ji,jj) = 0.5 * ( un(ji,jj,1) + un(ji-1,jj,1) ) * zfr_l(ji,jj)1477 zoty1(ji,jj) = 0.5 * ( vn(ji,jj,1) + vn(ji ,jj-1,1) ) * zfr_l(ji,jj)1478 zitx1(ji,jj) = 0.25 * ( u_ice(ji-1,jj-1) + u_ice(ji,jj-1) &1479 & + u_ice(ji-1,jj ) + u_ice(ji,jj ) ) * fr_i(ji,jj)1480 zity1(ji,jj) = 0.25 * ( v_ice(ji-1,jj-1) + v_ice(ji,jj-1) &1481 & + v_ice(ji-1,jj ) + v_ice(ji,jj ) ) * fr_i(ji,jj)1889 CASE( 'I' ) ! Ocean on C grid, Ice on I-point (B-grid) ==> T 1890 DO jj = 2, jpjm1 1891 DO ji = 2, jpim1 ! NO vector opt. 1892 zotx1(ji,jj) = 0.5 * ( un(ji,jj,1) + un(ji-1,jj ,1) ) * zfr_l(ji,jj) 1893 zoty1(ji,jj) = 0.5 * ( vn(ji,jj,1) + vn(ji ,jj-1,1) ) * zfr_l(ji,jj) 1894 zitx1(ji,jj) = 0.25 * ( u_ice(ji+1,jj+1) + u_ice(ji,jj+1) & 1895 & + u_ice(ji+1,jj ) + u_ice(ji,jj ) ) * fr_i(ji,jj) 1896 zity1(ji,jj) = 0.25 * ( v_ice(ji+1,jj+1) + v_ice(ji,jj+1) & 1897 & + v_ice(ji+1,jj ) + v_ice(ji,jj ) ) * fr_i(ji,jj) 1898 END DO 1482 1899 END DO 1483 END DO 1900 CASE( 'F' ) ! Ocean on C grid, Ice on F-point (B-grid) ==> T 1901 DO jj = 2, jpjm1 1902 DO ji = 2, jpim1 ! NO vector opt. 1903 zotx1(ji,jj) = 0.5 * ( un(ji,jj,1) + un(ji-1,jj ,1) ) * zfr_l(ji,jj) 1904 zoty1(ji,jj) = 0.5 * ( vn(ji,jj,1) + vn(ji ,jj-1,1) ) * zfr_l(ji,jj) 1905 zitx1(ji,jj) = 0.25 * ( u_ice(ji-1,jj-1) + u_ice(ji,jj-1) & 1906 & + u_ice(ji-1,jj ) + u_ice(ji,jj ) ) * fr_i(ji,jj) 1907 zity1(ji,jj) = 0.25 * ( v_ice(ji-1,jj-1) + v_ice(ji,jj-1) & 1908 & + v_ice(ji-1,jj ) + v_ice(ji,jj ) ) * fr_i(ji,jj) 1909 END DO 1910 END DO 1911 END SELECT 1912 CALL lbc_lnk( zitx1, 'T', -1. ) ; CALL lbc_lnk( zity1, 'T', -1. ) 1913 CASE( 'mixed oce-ice' ) 1914 SELECT CASE ( cp_ice_msh ) 1915 CASE( 'C' ) ! Ocean and Ice on C-grid ==> T 1916 DO jj = 2, jpjm1 1917 DO ji = fs_2, fs_jpim1 ! vector opt. 1918 zotx1(ji,jj) = 0.5 * ( un (ji,jj,1) + un (ji-1,jj ,1) ) * zfr_l(ji,jj) & 1919 & + 0.5 * ( u_ice(ji,jj ) + u_ice(ji-1,jj ) ) * fr_i(ji,jj) 1920 zoty1(ji,jj) = 0.5 * ( vn (ji,jj,1) + vn (ji ,jj-1,1) ) * zfr_l(ji,jj) & 1921 & + 0.5 * ( v_ice(ji,jj ) + v_ice(ji ,jj-1 ) ) * fr_i(ji,jj) 1922 END DO 1923 END DO 1924 CASE( 'I' ) ! Ocean on C grid, Ice on I-point (B-grid) ==> T 1925 DO jj = 2, jpjm1 1926 DO ji = 2, jpim1 ! NO vector opt. 1927 zotx1(ji,jj) = 0.5 * ( un(ji,jj,1) + un(ji-1,jj ,1) ) * zfr_l(ji,jj) & 1928 & + 0.25 * ( u_ice(ji+1,jj+1) + u_ice(ji,jj+1) & 1929 & + u_ice(ji+1,jj ) + u_ice(ji,jj ) ) * fr_i(ji,jj) 1930 zoty1(ji,jj) = 0.5 * ( vn(ji,jj,1) + vn(ji ,jj-1,1) ) * zfr_l(ji,jj) & 1931 & + 0.25 * ( v_ice(ji+1,jj+1) + v_ice(ji,jj+1) & 1932 & + v_ice(ji+1,jj ) + v_ice(ji,jj ) ) * fr_i(ji,jj) 1933 END DO 1934 END DO 1935 CASE( 'F' ) ! Ocean on C grid, Ice on F-point (B-grid) ==> T 1936 DO jj = 2, jpjm1 1937 DO ji = 2, jpim1 ! NO vector opt. 1938 zotx1(ji,jj) = 0.5 * ( un(ji,jj,1) + un(ji-1,jj ,1) ) * zfr_l(ji,jj) & 1939 & + 0.25 * ( u_ice(ji-1,jj-1) + u_ice(ji,jj-1) & 1940 & + u_ice(ji-1,jj ) + u_ice(ji,jj ) ) * fr_i(ji,jj) 1941 zoty1(ji,jj) = 0.5 * ( vn(ji,jj,1) + vn(ji ,jj-1,1) ) * zfr_l(ji,jj) & 1942 & + 0.25 * ( v_ice(ji-1,jj-1) + v_ice(ji,jj-1) & 1943 & + v_ice(ji-1,jj ) + v_ice(ji,jj ) ) * fr_i(ji,jj) 1944 END DO 1945 END DO 1946 END SELECT 1484 1947 END SELECT 1485 CALL lbc_lnk( zitx1, 'T', -1. ) ; CALL lbc_lnk( zity1, 'T', -1. ) 1486 CASE( 'mixed oce-ice' ) 1487 SELECT CASE ( cp_ice_msh ) 1488 CASE( 'C' ) ! Ocean and Ice on C-grid ==> T 1489 DO jj = 2, jpjm1 1490 DO ji = fs_2, fs_jpim1 ! vector opt. 1491 zotx1(ji,jj) = 0.5 * ( un (ji,jj,1) + un (ji-1,jj ,1) ) * zfr_l(ji,jj) & 1492 & + 0.5 * ( u_ice(ji,jj ) + u_ice(ji-1,jj ) ) * fr_i(ji,jj) 1493 zoty1(ji,jj) = 0.5 * ( vn (ji,jj,1) + vn (ji ,jj-1,1) ) * zfr_l(ji,jj) & 1494 & + 0.5 * ( v_ice(ji,jj ) + v_ice(ji ,jj-1 ) ) * fr_i(ji,jj) 1495 END DO 1496 END DO 1497 CASE( 'I' ) ! Ocean on C grid, Ice on I-point (B-grid) ==> T 1498 DO jj = 2, jpjm1 1499 DO ji = 2, jpim1 ! NO vector opt. 1500 zotx1(ji,jj) = 0.5 * ( un(ji,jj,1) + un(ji-1,jj ,1) ) * zfr_l(ji,jj) & 1501 & + 0.25 * ( u_ice(ji+1,jj+1) + u_ice(ji,jj+1) & 1502 & + u_ice(ji+1,jj ) + u_ice(ji,jj ) ) * fr_i(ji,jj) 1503 zoty1(ji,jj) = 0.5 * ( vn(ji,jj,1) + vn(ji ,jj-1,1) ) * zfr_l(ji,jj) & 1504 & + 0.25 * ( v_ice(ji+1,jj+1) + v_ice(ji,jj+1) & 1505 & + v_ice(ji+1,jj ) + v_ice(ji,jj ) ) * fr_i(ji,jj) 1506 END DO 1507 END DO 1508 CASE( 'F' ) ! Ocean on C grid, Ice on F-point (B-grid) ==> T 1509 DO jj = 2, jpjm1 1510 DO ji = 2, jpim1 ! NO vector opt. 1511 zotx1(ji,jj) = 0.5 * ( un(ji,jj,1) + un(ji-1,jj ,1) ) * zfr_l(ji,jj) & 1512 & + 0.25 * ( u_ice(ji-1,jj-1) + u_ice(ji,jj-1) & 1513 & + u_ice(ji-1,jj ) + u_ice(ji,jj ) ) * fr_i(ji,jj) 1514 zoty1(ji,jj) = 0.5 * ( vn(ji,jj,1) + vn(ji ,jj-1,1) ) * zfr_l(ji,jj) & 1515 & + 0.25 * ( v_ice(ji-1,jj-1) + v_ice(ji,jj-1) & 1516 & + v_ice(ji-1,jj ) + v_ice(ji,jj ) ) * fr_i(ji,jj) 1517 END DO 1518 END DO 1519 END SELECT 1520 END SELECT 1521 CALL lbc_lnk( zotx1, ssnd(jps_ocx1)%clgrid, -1. ) ; CALL lbc_lnk( zoty1, ssnd(jps_ocy1)%clgrid, -1. ) 1948 CALL lbc_lnk( zotx1, ssnd(jps_ocx1)%clgrid, -1. ) ; CALL lbc_lnk( zoty1, ssnd(jps_ocy1)%clgrid, -1. ) 1949 ! 1950 ENDIF 1522 1951 ! 1523 1952 ! … … 1559 1988 ENDIF 1560 1989 ! 1990 ! 1991 ! Fields sent by OPA to SAS when doing OPA<->SAS coupling 1992 ! ! SSH 1993 IF( ssnd(jps_ssh )%laction ) THEN 1994 ! ! removed inverse barometer ssh when Patm 1995 ! forcing is used (for sea-ice dynamics) 1996 IF( ln_apr_dyn ) THEN ; ztmp1(:,:) = sshb(:,:) - 0.5 * ( ssh_ib(:,:) + ssh_ibb(:,:) ) 1997 ELSE ; ztmp1(:,:) = sshn(:,:) 1998 ENDIF 1999 CALL cpl_snd( jps_ssh , isec, RESHAPE ( ztmp1 , (/jpi,jpj,1/) ), info ) 2000 2001 ENDIF 2002 ! ! SSS 2003 IF( ssnd(jps_soce )%laction ) THEN 2004 CALL cpl_snd( jps_soce , isec, RESHAPE ( tsn(:,:,1,jp_sal), (/jpi,jpj,1/) ), info ) 2005 ENDIF 2006 ! ! first T level thickness 2007 IF( ssnd(jps_e3t1st )%laction ) THEN 2008 CALL cpl_snd( jps_e3t1st, isec, RESHAPE ( fse3t_n(:,:,1) , (/jpi,jpj,1/) ), info ) 2009 ENDIF 2010 ! ! Qsr fraction 2011 IF( ssnd(jps_fraqsr)%laction ) THEN 2012 CALL cpl_snd( jps_fraqsr, isec, RESHAPE ( fraqsr_1lev(:,:) , (/jpi,jpj,1/) ), info ) 2013 ENDIF 2014 ! 2015 ! Fields sent by SAS to OPA when OASIS coupling 2016 ! ! Solar heat flux 2017 IF( ssnd(jps_qsroce)%laction ) CALL cpl_snd( jps_qsroce, isec, RESHAPE ( qsr , (/jpi,jpj,1/) ), info ) 2018 IF( ssnd(jps_qnsoce)%laction ) CALL cpl_snd( jps_qnsoce, isec, RESHAPE ( qns , (/jpi,jpj,1/) ), info ) 2019 IF( ssnd(jps_oemp )%laction ) CALL cpl_snd( jps_oemp , isec, RESHAPE ( emp , (/jpi,jpj,1/) ), info ) 2020 IF( ssnd(jps_sflx )%laction ) CALL cpl_snd( jps_sflx , isec, RESHAPE ( sfx , (/jpi,jpj,1/) ), info ) 2021 IF( ssnd(jps_otx1 )%laction ) CALL cpl_snd( jps_otx1 , isec, RESHAPE ( utau, (/jpi,jpj,1/) ), info ) 2022 IF( ssnd(jps_oty1 )%laction ) CALL cpl_snd( jps_oty1 , isec, RESHAPE ( vtau, (/jpi,jpj,1/) ), info ) 2023 IF( ssnd(jps_rnf )%laction ) CALL cpl_snd( jps_rnf , isec, RESHAPE ( rnf , (/jpi,jpj,1/) ), info ) 2024 IF( ssnd(jps_taum )%laction ) CALL cpl_snd( jps_taum , isec, RESHAPE ( taum, (/jpi,jpj,1/) ), info ) 2025 1561 2026 CALL wrk_dealloc( jpi,jpj, zfr_l, ztmp1, ztmp2, zotx1, zoty1, zotz1, zitx1, zity1, zitz1 ) 1562 2027 CALL wrk_dealloc( jpi,jpj,jpl, ztmp3, ztmp4 ) -
branches/2014/dev_r4621_NOC4_BDY_VERT_INTERP/NEMOGCM/NEMO/OPA_SRC/SBC/sbcfwb.F90
r5038 r5620 8 8 !! 3.0 ! 2006-08 (G. Madec) Surface module 9 9 !! 3.2 ! 2009-07 (C. Talandier) emp mean s spread over erp area 10 !! 3.6 ! 2014-11 (P. Mathiot ) add ice shelf melting 10 11 !!---------------------------------------------------------------------- 11 12 … … 88 89 ! 89 90 IF( kn_fwb == 3 .AND. nn_sssr /= 2 ) CALL ctl_stop( 'sbc_fwb: nn_fwb = 3 requires nn_sssr = 2, we stop ' ) 90 ! 91 area = glob_sum( e1e2t(:,:) ) ! interior global domain surface 91 IF( kn_fwb == 3 .AND. ln_isfcav ) CALL ctl_stop( 'sbc_fwb: nn_fwb = 3 with ln_isfcav = .TRUE. not working, we stop ' ) 92 ! 93 area = glob_sum( e1e2t(:,:) * tmask(:,:,1)) ! interior global domain surface 94 ! isf cavities are excluded because it can feedback to the melting with generation of inhibition of plumes 95 ! and in case of no melt, it can generate HSSW. 92 96 ! 93 97 #if ! defined key_lim2 && ! defined key_lim3 && ! defined key_cice … … 106 110 z_fwf = glob_sum( e1e2t(:,:) * ( emp(:,:) - rnf(:,:) + rdivisf * fwfisf(:,:) - snwice_fmass(:,:) ) ) / area ! sum over the global domain 107 111 zcoef = z_fwf * rcp 108 emp(:,:) = emp(:,:) - z_fwf 109 qns(:,:) = qns(:,:) + zcoef * sst_m(:,:) ! account for change to the heat budget due to fw correction112 emp(:,:) = emp(:,:) - z_fwf * tmask(:,:,1) 113 qns(:,:) = qns(:,:) + zcoef * sst_m(:,:) * tmask(:,:,1) ! account for change to the heat budget due to fw correction 110 114 ENDIF 111 115 ! … … 138 142 IF( MOD( kt-1, kn_fsbc ) == 0 ) THEN ! correct the freshwater fluxes 139 143 zcoef = fwfold * rcp 140 emp(:,:) = emp(:,:) + fwfold 141 qns(:,:) = qns(:,:) - zcoef * sst_m(:,:) ! account for change to the heat budget due to fw correction144 emp(:,:) = emp(:,:) + fwfold * tmask(:,:,1) 145 qns(:,:) = qns(:,:) - zcoef * sst_m(:,:) * tmask(:,:,1) ! account for change to the heat budget due to fw correction 142 146 ENDIF 143 147 ! … … 158 162 zsurf_pos = glob_sum( e1e2t(:,:)*ztmsk_pos(:,:) ) 159 163 ! ! fwf global mean (excluding ocean to ice/snow exchanges) 160 z_fwf = glob_sum( e1e2t(:,:) * ( emp(:,:) - rnf(:,:) - snwice_fmass(:,:) ) ) / area164 z_fwf = glob_sum( e1e2t(:,:) * ( emp(:,:) - rnf(:,:) + rdivisf * fwfisf(:,:) - snwice_fmass(:,:) ) ) / area 161 165 ! 162 166 IF( z_fwf < 0._wp ) THEN ! spread out over >0 erp area to increase evaporation -
branches/2014/dev_r4621_NOC4_BDY_VERT_INTERP/NEMOGCM/NEMO/OPA_SRC/SBC/sbcice_cice.F90
- Property svn:keywords set to Id
r5038 r5620 40 40 # if defined key_cice4 41 41 USE ice_flux, only: strax,stray,strocnx,strocny,frain,fsnow, & 42 strocnxT,strocnyT, & 42 43 sst,sss,uocn,vocn,ss_tltx,ss_tlty,fsalt_gbm, & 43 44 fresh_gbm,fhocn_gbm,fswthru_gbm,frzmlt, & … … 48 49 #else 49 50 USE ice_flux, only: strax,stray,strocnx,strocny,frain,fsnow, & 51 strocnxT,strocnyT, & 50 52 sst,sss,uocn,vocn,ss_tltx,ss_tlty,fsalt_ai, & 51 53 fresh_ai,fhocn_ai,fswthru_ai,frzmlt, & … … 94 96 # include "domzgr_substitute.h90" 95 97 98 !! $Id$ 96 99 CONTAINS 97 100 … … 135 138 IF ( ksbc == jp_flx ) THEN 136 139 CALL cice_sbc_force(kt) 137 ELSE IF ( ksbc == jp_ cpl ) THEN140 ELSE IF ( ksbc == jp_purecpl ) THEN 138 141 CALL sbc_cpl_ice_flx( 1.0-fr_i ) 139 142 ENDIF … … 143 146 CALL cice_sbc_out ( kt, ksbc ) 144 147 145 IF ( ksbc == jp_ cpl ) CALL cice_sbc_hadgam(kt+1)148 IF ( ksbc == jp_purecpl ) CALL cice_sbc_hadgam(kt+1) 146 149 147 150 ENDIF ! End sea-ice time step only … … 184 187 185 188 ! Do some CICE consistency checks 186 IF ( (ksbc == jp_flx) .OR. (ksbc == jp_ cpl) ) THEN189 IF ( (ksbc == jp_flx) .OR. (ksbc == jp_purecpl) ) THEN 187 190 IF ( calc_strair .OR. calc_Tsfc ) THEN 188 191 CALL ctl_stop( 'STOP', 'cice_sbc_init : Forcing option requires calc_strair=F and calc_Tsfc=F in ice_in' ) … … 209 212 210 213 CALL cice2nemo(aice,fr_i, 'T', 1. ) 211 IF ( (ksbc == jp_flx) .OR. (ksbc == jp_ cpl) ) THEN214 IF ( (ksbc == jp_flx) .OR. (ksbc == jp_purecpl) ) THEN 212 215 DO jl=1,ncat 213 216 CALL cice2nemo(aicen(:,:,jl,:),a_i(:,:,jl), 'T', 1. ) … … 316 319 ! forced and coupled case 317 320 318 IF ( (ksbc == jp_flx).OR.(ksbc == jp_ cpl) ) THEN321 IF ( (ksbc == jp_flx).OR.(ksbc == jp_purecpl) ) THEN 319 322 320 323 ztmpn(:,:,:)=0.0 … … 506 509 CALL nemo2cice(ztmp,ss_tlty,'F', -1. ) 507 510 508 CALL wrk_dealloc( jpi,jpj, ztmp )511 CALL wrk_dealloc( jpi,jpj, ztmp, zpice ) 509 512 CALL wrk_dealloc( jpi,jpj,ncat, ztmpn ) 510 513 ! … … 560 563 ! Combine wind stress and ocean-ice stress 561 564 ! [Note that fr_iu hasn't yet been updated, so still from start of CICE timestep] 565 ! strocnx and strocny already weighted by ice fraction in CICE so not done here 562 566 563 567 utau(:,:)=(1.0-fr_iu(:,:))*utau(:,:)-ss_iou(:,:) 564 568 vtau(:,:)=(1.0-fr_iv(:,:))*vtau(:,:)-ss_iov(:,:) 569 570 ! Also need ice/ocean stress on T points so that taum can be updated 571 ! This interpolation is already done in CICE so best to use those values 572 CALL cice2nemo(strocnxT,ztmp1,'T',-1.) 573 CALL cice2nemo(strocnyT,ztmp2,'T',-1.) 574 575 ! Update taum with modulus of ice-ocean stress 576 ! strocnxT and strocnyT are not weighted by ice fraction in CICE so must be done here 577 taum(:,:)=(1.0-fr_i(:,:))*taum(:,:)+fr_i(:,:)*SQRT(ztmp1**2. + ztmp2**2.) 565 578 566 579 ! Freshwater fluxes … … 574 587 ELSE IF (ksbc == jp_core) THEN 575 588 emp(:,:) = (1.0-fr_i(:,:))*emp(:,:) 576 ELSE IF (ksbc == jp_ cpl) THEN589 ELSE IF (ksbc == jp_purecpl) THEN 577 590 ! emp_tot is set in sbc_cpl_ice_flx (called from cice_sbc_in above) 578 591 ! This is currently as required with the coupling fields from the UM atmosphere … … 610 623 ENDIF 611 624 ! Take into account snow melting except for fully coupled when already in qns_tot 612 IF (ksbc == jp_ cpl) THEN625 IF (ksbc == jp_purecpl) THEN 613 626 qsr(:,:)= qsr_tot(:,:) 614 627 qns(:,:)= qns_tot(:,:) … … 645 658 646 659 CALL cice2nemo(aice,fr_i,'T', 1. ) 647 IF ( (ksbc == jp_flx).OR.(ksbc == jp_ cpl) ) THEN660 IF ( (ksbc == jp_flx).OR.(ksbc == jp_purecpl) ) THEN 648 661 DO jl=1,ncat 649 662 CALL cice2nemo(aicen(:,:,jl,:),a_i(:,:,jl), 'T', 1. ) … … 1083 1096 !! Default option Dummy module NO CICE sea-ice model 1084 1097 !!---------------------------------------------------------------------- 1098 !! $Id$ 1085 1099 CONTAINS 1086 1100 -
branches/2014/dev_r4621_NOC4_BDY_VERT_INTERP/NEMOGCM/NEMO/OPA_SRC/SBC/sbcice_if.F90
r5038 r5620 103 103 ! ( d rho / dt ) / ( d rho / ds ) ( s = 34, t = -1.8 ) 104 104 105 fr_i(:,:) = eos_fzp( sss_m ) * tmask(:,:,1) ! sea surface freezing temperature [Celcius] 105 CALL eos_fzp( sss_m(:,:), fr_i(:,:) ) ! sea surface freezing temperature [Celcius] 106 fr_i(:,:) = fr_i(:,:) * tmask(:,:,1) 106 107 107 IF( l k_cpl ) a_i(:,:,1) = fr_i(:,:)108 IF( ln_cpl ) a_i(:,:,1) = fr_i(:,:) 108 109 109 110 ! Flux and ice fraction computation -
branches/2014/dev_r4621_NOC4_BDY_VERT_INTERP/NEMOGCM/NEMO/OPA_SRC/SBC/sbcice_lim.F90
r5038 r5620 19 19 !!---------------------------------------------------------------------- 20 20 !! sbc_ice_lim : sea-ice model time-stepping and update ocean sbc over ice-covered area 21 !! lim_ctl : alerts in case of ice model crash22 !! lim_prt_state : ice control print at a given grid point23 21 !!---------------------------------------------------------------------- 24 22 USE oce ! ocean dynamics and tracers 25 23 USE dom_oce ! ocean space and time domain 26 USE par_ice ! sea-ice parameters27 24 USE ice ! LIM-3: ice variables 28 USE iceini ! LIM-3: ice initialisation25 USE thd_ice ! LIM-3: thermodynamical variables 29 26 USE dom_ice ! LIM-3: ice domain 30 27 … … 40 37 USE limdyn ! Ice dynamics 41 38 USE limtrp ! Ice transport 39 USE limhdf ! Ice horizontal diffusion 42 40 USE limthd ! Ice thermodynamics 43 USE limitd_th ! Thermodynamics on ice thickness distribution44 41 USE limitd_me ! Mechanics on ice thickness distribution 45 42 USE limsbc ! sea surface boundary condition … … 47 44 USE limwri ! Ice outputs 48 45 USE limrst ! Ice restarts 49 USE limupdate1 50 USE limupdate2 46 USE limupdate1 ! update of global variables 47 USE limupdate2 ! update of global variables 51 48 USE limvar ! Ice variables switch 49 50 USE limmsh ! LIM mesh 51 USE limistate ! LIM initial state 52 USE limthd_sal ! LIM ice thermodynamics: salinity 52 53 53 54 USE c1d ! 1D vertical configuration … … 60 61 USE prtctl ! Print control 61 62 USE lib_fortran ! 62 USE cpl_oasis3, ONLY : lk_cpl63 USE limctl 63 64 64 65 #if defined key_bdy … … 70 71 71 72 PUBLIC sbc_ice_lim ! routine called by sbcmod.F90 72 PUBLIC lim_prt_state73 PUBLIC sbc_lim_init ! routine called by sbcmod.F90 73 74 74 75 !! * Substitutions … … 107 108 INTEGER, INTENT(in) :: kblk ! type of bulk (=3 CLIO, =4 CORE, =5 COUPLED) 108 109 !! 109 INTEGER :: ji, jj, jl, jk ! dummy loop index 110 REAL(wp) :: zcoef ! local scalar 110 INTEGER :: jl ! dummy loop index 111 111 REAL(wp), POINTER, DIMENSION(:,:,:) :: zalb_os, zalb_cs ! ice albedo under overcast/clear sky 112 112 REAL(wp), POINTER, DIMENSION(:,:,:) :: zalb_ice ! mean ice albedo (for coupled) 113 REAL(wp), POINTER, DIMENSION(:,: ) :: zutau_ice, zvtau_ice 113 114 !!---------------------------------------------------------------------- 114 115 115 116 IF( nn_timing == 1 ) CALL timing_start('sbc_ice_lim') 116 117 117 IF( kt == nit000 ) THEN 118 IF(lwp) WRITE(numout,*) 119 IF(lwp) WRITE(numout,*) 'sbc_ice_lim : update ocean surface boudary condition' 120 IF(lwp) WRITE(numout,*) '~~~~~~~~~~~ via Louvain la Neuve Ice Model (LIM-3) time stepping' 121 ! 122 CALL ice_init 123 ! 124 IF( ln_nicep ) THEN ! control print at a given point 125 jiindx = 15 ; jjindx = 44 126 IF(lwp) WRITE(numout,*) ' The debugging point is : jiindx : ',jiindx, ' jjindx : ',jjindx 127 ENDIF 128 ENDIF 129 130 ! !----------------------! 131 IF( MOD( kt-1, nn_fsbc ) == 0 ) THEN ! Ice time-step only ! 132 ! !----------------------! 133 ! ! Bulk Formulae ! 134 ! !----------------! 135 ! 136 u_oce(:,:) = ssu_m(:,:) * umask(:,:,1) ! mean surface ocean current at ice velocity point 137 v_oce(:,:) = ssv_m(:,:) * vmask(:,:,1) ! (C-grid dynamics : U- & V-points as the ocean) 138 ! 139 t_bo(:,:) = ( eos_fzp( sss_m ) + rt0 ) * tmask(:,:,1) + rt0 * ( 1. - tmask(:,:,1) ) ! masked sea surface freezing temperature [Kelvin] 140 ! ! (set to rt0 over land) 141 ! ! Ice albedo 142 CALL wrk_alloc( jpi,jpj,jpl, zalb_os, zalb_cs, zalb_ice ) 143 144 CALL albedo_ice( t_su, ht_i, ht_s, zalb_cs, zalb_os ) ! cloud-sky and overcast-sky ice albedos 145 118 !-----------------------! 119 ! --- Ice time step --- ! 120 !-----------------------! 121 IF( MOD( kt-1, nn_fsbc ) == 0 ) THEN 122 123 ! mean surface ocean current at ice velocity point (C-grid dynamics : U- & V-points as the ocean) 124 u_oce(:,:) = ssu_m(:,:) * umask(:,:,1) 125 v_oce(:,:) = ssv_m(:,:) * vmask(:,:,1) 126 127 ! masked sea surface freezing temperature [Kelvin] (set to rt0 over land) 128 CALL eos_fzp( sss_m(:,:) , t_bo(:,:) ) 129 t_bo(:,:) = ( t_bo(:,:) + rt0 ) * tmask(:,:,1) + rt0 * ( 1._wp - tmask(:,:,1) ) 130 131 ! Mask sea ice surface temperature (set to rt0 over land) 132 DO jl = 1, jpl 133 t_su(:,:,jl) = t_su(:,:,jl) * tmask(:,:,1) + rt0 * ( 1._wp - tmask(:,:,1) ) 134 END DO 135 ! 136 !------------------------------------------------! 137 ! --- Dynamical coupling with the atmosphere --- ! 138 !------------------------------------------------! 139 ! It provides the following fields: 140 ! utau_ice, vtau_ice : surface ice stress (U- & V-points) [N/m2] 141 !----------------------------------------------------------------- 146 142 SELECT CASE( kblk ) 147 CASE( jp_core , jp_cpl ) ! CORE and COUPLED bulk formulations 148 149 ! albedo depends on cloud fraction because of non-linear spectral effects 150 zalb_ice(:,:,:) = ( 1. - cldf_ice ) * zalb_cs(:,:,:) + cldf_ice * zalb_os(:,:,:) 151 ! In CLIO the cloud fraction is read in the climatology and the all-sky albedo 152 ! (zalb_ice) is computed within the bulk routine 153 143 CASE( jp_clio ) ; CALL blk_ice_clio_tau ! CLIO bulk formulation 144 CASE( jp_core ) ; CALL blk_ice_core_tau ! CORE bulk formulation 145 CASE( jp_purecpl ) ; CALL sbc_cpl_ice_tau( utau_ice , vtau_ice ) ! Coupled formulation 154 146 END SELECT 155 147 156 ! ! Mask sea ice surface temperature 157 DO jl = 1, jpl 158 t_su(:,:,jl) = t_su(:,:,jl) + rt0 * ( 1. - tmask(:,:,1) ) 159 END DO 160 161 ! Bulk formulae - provides the following fields: 162 ! utau_ice, vtau_ice : surface ice stress (U- & V-points) [N/m2] 148 IF( ln_mixcpl) THEN ! Case of a mixed Bulk/Coupled formulation 149 CALL wrk_alloc( jpi,jpj , zutau_ice, zvtau_ice) 150 CALL sbc_cpl_ice_tau( zutau_ice , zvtau_ice ) 151 utau_ice(:,:) = utau_ice(:,:) * xcplmask(:,:,0) + zutau_ice(:,:) * ( 1. - xcplmask(:,:,0) ) 152 vtau_ice(:,:) = vtau_ice(:,:) * xcplmask(:,:,0) + zvtau_ice(:,:) * ( 1. - xcplmask(:,:,0) ) 153 CALL wrk_dealloc( jpi,jpj , zutau_ice, zvtau_ice) 154 ENDIF 155 156 !-------------------------------------------------------! 157 ! --- ice dynamics and transport (except in 1D case) ---! 158 !-------------------------------------------------------! 159 numit = numit + nn_fsbc ! Ice model time step 160 ! 161 CALL sbc_lim_bef ! Store previous ice values 162 CALL sbc_lim_diag0 ! set diag of mass, heat and salt fluxes to 0 163 CALL lim_rst_opn( kt ) ! Open Ice restart file 164 ! 165 IF( .NOT. lk_c1d ) THEN 166 ! 167 CALL lim_dyn( kt ) ! Ice dynamics ( rheology/dynamics ) 168 ! 169 CALL lim_trp( kt ) ! Ice transport ( Advection/diffusion ) 170 ! 171 IF( nn_monocat /= 2 ) CALL lim_itd_me ! Mechanical redistribution ! (ridging/rafting) 172 ! 173 #if defined key_bdy 174 CALL bdy_ice_lim( kt ) ! bdy ice thermo 175 IF( ln_icectl ) CALL lim_prt( kt, iiceprt, jiceprt, 1, ' - ice thermo bdy - ' ) 176 #endif 177 ! 178 CALL lim_update1( kt ) ! Corrections 179 ! 180 ENDIF 181 182 ! previous lead fraction and ice volume for flux calculations 183 CALL sbc_lim_bef 184 CALL lim_var_glo2eqv ! ht_i and ht_s for ice albedo calculation 185 CALL lim_var_agg(1) ! at_i for coupling (via pfrld) 186 pfrld(:,:) = 1._wp - at_i(:,:) 187 phicif(:,:) = vt_i(:,:) 188 189 !------------------------------------------------------! 190 ! --- Thermodynamical coupling with the atmosphere --- ! 191 !------------------------------------------------------! 192 ! It provides the following fields: 163 193 ! qsr_ice , qns_ice : solar & non solar heat flux over ice (T-point) [W/m2] 164 194 ! qla_ice : latent heat flux over ice (T-point) [W/m2] … … 166 196 ! tprecip , sprecip : total & solid precipitation (T-point) [Kg/m2/s] 167 197 ! fr1_i0 , fr2_i0 : 1sr & 2nd fraction of qsr penetration in ice [%] 168 ! 198 !---------------------------------------------------------------------------------------- 199 CALL wrk_alloc( jpi,jpj,jpl, zalb_os, zalb_cs, zalb_ice ) 200 CALL albedo_ice( t_su, ht_i, ht_s, zalb_cs, zalb_os ) ! cloud-sky and overcast-sky ice albedos 201 169 202 SELECT CASE( kblk ) 170 203 CASE( jp_clio ) ! CLIO bulk formulation 171 CALL blk_ice_clio( t_su , zalb_cs , zalb_os , zalb_ice , & 172 & utau_ice , vtau_ice , qns_ice , qsr_ice , & 173 & qla_ice , dqns_ice , dqla_ice , & 174 & tprecip , sprecip , & 175 & fr1_i0 , fr2_i0 , cp_ice_msh, jpl ) 176 ! 177 IF( nn_limflx /= 2 ) CALL ice_lim_flx( t_su, zalb_ice, qns_ice, qsr_ice , & 178 & dqns_ice, qla_ice, dqla_ice, nn_limflx ) 179 204 ! In CLIO the cloud fraction is read in the climatology and the all-sky albedo 205 ! (zalb_ice) is computed within the bulk routine 206 CALL blk_ice_clio_flx( t_su, zalb_cs, zalb_os, zalb_ice ) 207 IF( ln_mixcpl ) CALL sbc_cpl_ice_flx( p_frld=pfrld, palbi=zalb_ice, psst=sst_m, pist=t_su ) 208 IF( nn_limflx /= 2 ) CALL ice_lim_flx( t_su, zalb_ice, qns_ice, qsr_ice, dqns_ice, evap_ice, devap_ice, nn_limflx ) 180 209 CASE( jp_core ) ! CORE bulk formulation 181 CALL blk_ice_core( t_su , u_ice , v_ice , zalb_ice , & 182 & utau_ice , vtau_ice , qns_ice , qsr_ice , & 183 & qla_ice , dqns_ice , dqla_ice , & 184 & tprecip , sprecip , & 185 & fr1_i0 , fr2_i0 , cp_ice_msh, jpl ) 186 ! 187 IF( nn_limflx /= 2 ) CALL ice_lim_flx( t_su, zalb_ice, qns_ice, qsr_ice , & 188 & dqns_ice, qla_ice, dqla_ice, nn_limflx ) 189 ! 190 CASE ( jp_cpl ) 191 192 CALL sbc_cpl_ice_tau( utau_ice , vtau_ice ) 193 194 ! MV -> seb 195 ! CALL sbc_cpl_ice_flx( p_frld=ato_i, palbi=zalb_ice, psst=sst_m, pist=t_su ) 196 197 ! IF( nn_limflx == 2 ) CALL ice_lim_flx( t_su, zalb_ice, qns_ice, qsr_ice , & 198 ! & dqns_ice, qla_ice, dqla_ice, nn_limflx ) 199 ! ! Latent heat flux is forced to 0 in coupled : 200 ! ! it is included in qns (non-solar heat flux) 201 ! qla_ice (:,:,:) = 0._wp 202 ! dqla_ice (:,:,:) = 0._wp 203 ! END MV -> seb 204 ! 210 ! albedo depends on cloud fraction because of non-linear spectral effects 211 zalb_ice(:,:,:) = ( 1. - cldf_ice ) * zalb_cs(:,:,:) + cldf_ice * zalb_os(:,:,:) 212 CALL blk_ice_core_flx( t_su, zalb_ice ) 213 IF( ln_mixcpl ) CALL sbc_cpl_ice_flx( p_frld=pfrld, palbi=zalb_ice, psst=sst_m, pist=t_su ) 214 IF( nn_limflx /= 2 ) CALL ice_lim_flx( t_su, zalb_ice, qns_ice, qsr_ice, dqns_ice, evap_ice, devap_ice, nn_limflx ) 215 CASE ( jp_purecpl ) 216 ! albedo depends on cloud fraction because of non-linear spectral effects 217 zalb_ice(:,:,:) = ( 1. - cldf_ice ) * zalb_cs(:,:,:) + cldf_ice * zalb_os(:,:,:) 218 CALL sbc_cpl_ice_flx( p_frld=pfrld, palbi=zalb_ice, psst=sst_m, pist=t_su ) 219 ! clem: evap_ice is forced to 0 in coupled mode for now 220 ! but it needs to be changed (along with modif in limthd_dh) once heat flux from evap will be avail. from atm. models 221 evap_ice (:,:,:) = 0._wp ; devap_ice (:,:,:) = 0._wp 222 IF( nn_limflx == 2 ) CALL ice_lim_flx( t_su, zalb_ice, qns_ice, qsr_ice, dqns_ice, evap_ice, devap_ice, nn_limflx ) 205 223 END SELECT 206 207 ! !----------------------! 208 ! ! LIM-3 time-stepping ! 209 ! !----------------------! 210 ! 211 numit = numit + nn_fsbc ! Ice model time step 212 ! 213 ! ! Store previous ice values 214 a_i_b (:,:,:) = a_i (:,:,:) ! ice area 215 e_i_b (:,:,:,:) = e_i (:,:,:,:) ! ice thermal energy 216 v_i_b (:,:,:) = v_i (:,:,:) ! ice volume 217 v_s_b (:,:,:) = v_s (:,:,:) ! snow volume 218 e_s_b (:,:,:,:) = e_s (:,:,:,:) ! snow thermal energy 219 smv_i_b(:,:,:) = smv_i(:,:,:) ! salt content 220 oa_i_b (:,:,:) = oa_i (:,:,:) ! areal age content 221 u_ice_b(:,:) = u_ice(:,:) 222 v_ice_b(:,:) = v_ice(:,:) 223 224 ! salt, heat and mass fluxes 225 sfx (:,:) = 0._wp ; 226 sfx_bri(:,:) = 0._wp ; 227 sfx_sni(:,:) = 0._wp ; sfx_opw(:,:) = 0._wp 228 sfx_bog(:,:) = 0._wp ; sfx_dyn(:,:) = 0._wp 229 sfx_bom(:,:) = 0._wp ; sfx_sum(:,:) = 0._wp 230 sfx_res(:,:) = 0._wp 231 232 wfx_snw(:,:) = 0._wp ; wfx_ice(:,:) = 0._wp 233 wfx_sni(:,:) = 0._wp ; wfx_opw(:,:) = 0._wp 234 wfx_bog(:,:) = 0._wp ; wfx_dyn(:,:) = 0._wp 235 wfx_bom(:,:) = 0._wp ; wfx_sum(:,:) = 0._wp 236 wfx_res(:,:) = 0._wp ; wfx_sub(:,:) = 0._wp 237 wfx_spr(:,:) = 0._wp ; 238 239 hfx_in (:,:) = 0._wp ; hfx_out(:,:) = 0._wp 240 hfx_thd(:,:) = 0._wp ; 241 hfx_snw(:,:) = 0._wp ; hfx_opw(:,:) = 0._wp 242 hfx_bog(:,:) = 0._wp ; hfx_dyn(:,:) = 0._wp 243 hfx_bom(:,:) = 0._wp ; hfx_sum(:,:) = 0._wp 244 hfx_res(:,:) = 0._wp ; hfx_sub(:,:) = 0._wp 245 hfx_spr(:,:) = 0._wp ; hfx_dif(:,:) = 0._wp 246 hfx_err(:,:) = 0._wp ; hfx_err_rem(:,:) = 0._wp 247 248 CALL lim_rst_opn( kt ) ! Open Ice restart file 249 ! 250 IF( ln_nicep ) CALL lim_prt_state( kt, jiindx, jjindx, 1, ' - Beginning the time step - ' ) ! control print 251 ! ---------------------------------------------- 252 ! ice dynamics and transport (except in 1D case) 253 ! ---------------------------------------------- 254 IF( .NOT. lk_c1d ) THEN 255 CALL lim_dyn( kt ) ! Ice dynamics ( rheology/dynamics ) 256 CALL lim_trp( kt ) ! Ice transport ( Advection/diffusion ) 257 CALL lim_var_glo2eqv ! equivalent variables, requested for rafting 258 IF( ln_nicep ) CALL lim_prt_state( kt, jiindx, jjindx,-1, ' - ice dyn & trp - ' ) ! control print 259 CALL lim_itd_me ! Mechanical redistribution ! (ridging/rafting) 260 CALL lim_var_agg( 1 ) 261 #if defined key_bdy 262 ! bdy ice thermo 263 CALL lim_var_glo2eqv ! equivalent variables 264 CALL bdy_ice_lim( kt ) 265 CALL lim_itd_me_zapsmall 266 CALL lim_var_agg(1) 267 IF( ln_nicep ) CALL lim_prt_state( kt, jiindx, jjindx, 1, ' - ice thermo bdy - ' ) ! control print 268 #endif 269 CALL lim_update1 270 ENDIF 271 ! !- Change old values for new values 272 u_ice_b(:,:) = u_ice(:,:) 273 v_ice_b(:,:) = v_ice(:,:) 274 a_i_b (:,:,:) = a_i (:,:,:) 275 v_s_b (:,:,:) = v_s (:,:,:) 276 v_i_b (:,:,:) = v_i (:,:,:) 277 e_s_b (:,:,:,:) = e_s (:,:,:,:) 278 e_i_b (:,:,:,:) = e_i (:,:,:,:) 279 oa_i_b (:,:,:) = oa_i (:,:,:) 280 smv_i_b(:,:,:) = smv_i(:,:,:) 281 282 ! ---------------------------------------------- 283 ! ice thermodynamic 284 ! ---------------------------------------------- 285 CALL lim_var_glo2eqv ! equivalent variables 286 CALL lim_var_agg(1) ! aggregate ice categories 287 ! previous lead fraction and ice volume for flux calculations 288 pfrld(:,:) = 1._wp - at_i(:,:) 289 phicif(:,:) = vt_i(:,:) 290 291 ! MV -> seb 292 SELECT CASE( kblk ) 293 CASE ( jp_cpl ) 294 CALL sbc_cpl_ice_flx( p_frld=pfrld, palbi=zalb_ice, psst=sst_m, pist=t_su ) 295 IF( nn_limflx == 2 ) CALL ice_lim_flx( t_su, zalb_ice, qns_ice, qsr_ice , & 296 & dqns_ice, qla_ice, dqla_ice, nn_limflx ) 297 ! Latent heat flux is forced to 0 in coupled : 298 ! it is included in qns (non-solar heat flux) 299 qla_ice (:,:,:) = 0._wp 300 dqla_ice (:,:,:) = 0._wp 301 END SELECT 302 ! END MV -> seb 303 ! 304 CALL lim_var_bv ! bulk brine volume (diag) 305 CALL lim_thd( kt ) ! Ice thermodynamics 306 zcoef = rdt_ice /rday ! Ice natural aging 307 oa_i(:,:,:) = oa_i(:,:,:) + a_i(:,:,:) * zcoef 308 IF( ln_nicep ) CALL lim_prt_state( kt, jiindx, jjindx, 1, ' - ice thermodyn. - ' ) ! control print 309 CALL lim_itd_th( kt ) ! Remap ice categories, lateral accretion ! 310 CALL lim_var_agg( 1 ) ! requested by limupdate 311 CALL lim_update2 ! Global variables update 312 313 CALL lim_var_glo2eqv ! equivalent variables (outputs) 314 CALL lim_var_agg(2) ! aggregate ice thickness categories 315 IF( ln_nicep ) CALL lim_prt_state( kt, jiindx, jjindx, 2, ' - Final state - ' ) ! control print 316 ! 317 CALL lim_sbc_flx( kt ) ! Update surface ocean mass, heat and salt fluxes 318 ! 319 IF( ln_nicep ) CALL lim_prt_state( kt, jiindx, jjindx, 3, ' - Final state lim_sbc - ' ) ! control print 320 ! 321 ! ! Diagnostics and outputs 322 IF (ln_limdiaout) CALL lim_diahsb 323 324 CALL lim_wri( 1 ) ! Ice outputs 325 224 CALL wrk_dealloc( jpi,jpj,jpl, zalb_os, zalb_cs, zalb_ice ) 225 226 !----------------------------! 227 ! --- ice thermodynamics --- ! 228 !----------------------------! 229 CALL lim_thd( kt ) ! Ice thermodynamics 230 ! 231 CALL lim_update2( kt ) ! Corrections 232 ! 233 CALL lim_sbc_flx( kt ) ! Update surface ocean mass, heat and salt fluxes 234 ! 235 IF(ln_limdiaout) CALL lim_diahsb ! Diagnostics and outputs 236 ! 237 CALL lim_wri( 1 ) ! Ice outputs 238 ! 326 239 IF( kt == nit000 .AND. ln_rstart ) & 327 & CALL iom_close( numrir ) ! clem: close input ice restart file 328 ! 329 IF( lrst_ice ) CALL lim_rst_write( kt ) ! Ice restart file 330 CALL lim_var_glo2eqv ! ??? 331 ! 332 IF( ln_nicep ) CALL lim_ctl( kt ) ! alerts in case of model crash 333 ! 334 CALL wrk_dealloc( jpi,jpj,jpl, zalb_os, zalb_cs, zalb_ice ) 335 ! 336 ENDIF ! End sea-ice time step only 337 338 ! !--------------------------! 339 ! ! at all ocean time step ! 340 ! !--------------------------! 341 ! 342 ! ! Update surface ocean stresses (only in ice-dynamic case) 343 ! ! otherwise the atm.-ocean stresses are used everywhere 240 & CALL iom_close( numrir ) ! close input ice restart file 241 ! 242 IF( lrst_ice ) CALL lim_rst_write( kt ) ! Ice restart file 243 ! 244 IF( ln_icectl ) CALL lim_ctl( kt ) ! alerts in case of model crash 245 ! 246 ENDIF ! End sea-ice time step only 247 248 !-------------------------! 249 ! --- Ocean time step --- ! 250 !-------------------------! 251 ! Update surface ocean stresses (only in ice-dynamic case) otherwise the atm.-ocean stresses are used everywhere 344 252 IF( ln_limdyn ) CALL lim_sbc_tau( kt, ub(:,:,1), vb(:,:,1) ) ! using before instantaneous surf. currents 345 253 !!gm remark, the ocean-ice stress is not saved in ice diag call above ..... find a solution!!! 346 347 ! 348 IF( nn_timing == 1 ) CALL timing_stop('sbc_ice_lim') 254 ! 255 IF( nn_timing == 1 ) CALL timing_stop('sbc_ice_lim') 349 256 ! 350 257 END SUBROUTINE sbc_ice_lim 351 258 259 260 SUBROUTINE sbc_lim_init 261 !!---------------------------------------------------------------------- 262 !! *** ROUTINE sbc_lim_init *** 263 !! 264 !! ** purpose : Allocate all the dynamic arrays of the LIM-3 modules 265 !!---------------------------------------------------------------------- 266 INTEGER :: ierr 267 !!---------------------------------------------------------------------- 268 IF(lwp) WRITE(numout,*) 269 IF(lwp) WRITE(numout,*) 'sbc_ice_lim : update ocean surface boudary condition' 270 IF(lwp) WRITE(numout,*) '~~~~~~~~~~~ via Louvain la Neuve Ice Model (LIM-3) time stepping' 271 ! 272 ! Open the reference and configuration namelist files and namelist output file 273 CALL ctl_opn( numnam_ice_ref, 'namelist_ice_ref', 'OLD', 'FORMATTED', 'SEQUENTIAL', -1, numout, lwp ) 274 CALL ctl_opn( numnam_ice_cfg, 'namelist_ice_cfg', 'OLD', 'FORMATTED', 'SEQUENTIAL', -1, numout, lwp ) 275 IF(lwm) CALL ctl_opn( numoni, 'output.namelist.ice', 'UNKNOWN', 'FORMATTED', 'SEQUENTIAL', -1, numout, lwp, 1 ) 276 277 CALL ice_run ! set some ice run parameters 278 ! 279 ! ! Allocate the ice arrays 280 ierr = ice_alloc () ! ice variables 281 ierr = ierr + dom_ice_alloc () ! domain 282 ierr = ierr + sbc_ice_alloc () ! surface forcing 283 ierr = ierr + thd_ice_alloc () ! thermodynamics 284 ierr = ierr + lim_itd_me_alloc () ! ice thickness distribution - mechanics 285 ! 286 IF( lk_mpp ) CALL mpp_sum( ierr ) 287 IF( ierr /= 0 ) CALL ctl_stop('STOP', 'sbc_lim_init : unable to allocate ice arrays') 288 ! 289 ! ! adequation jpk versus ice/snow layers/categories 290 IF( jpl > jpk .OR. (nlay_i+1) > jpk .OR. nlay_s > jpk ) & 291 & CALL ctl_stop( 'STOP', & 292 & 'sbc_lim_init: the 3rd dimension of workspace arrays is too small.', & 293 & 'use more ocean levels or less ice/snow layers/categories.' ) 294 ! 295 CALL lim_itd_init ! ice thickness distribution initialization 296 ! 297 CALL lim_hdf_init ! set ice horizontal diffusion computation parameters 298 ! 299 CALL lim_thd_init ! set ice thermodynics parameters 300 ! 301 CALL lim_thd_sal_init ! set ice salinity parameters 302 ! 303 CALL lim_msh ! ice mesh initialization 304 ! 305 CALL lim_itd_me_init ! ice thickness distribution initialization for mecanical deformation 306 ! ! Initial sea-ice state 307 IF( .NOT. ln_rstart ) THEN ! start from rest: sea-ice deduced from sst 308 numit = 0 309 numit = nit000 - 1 310 CALL lim_istate 311 ELSE ! start from a restart file 312 CALL lim_rst_read 313 numit = nit000 - 1 314 ENDIF 315 CALL lim_var_agg(1) 316 CALL lim_var_glo2eqv 317 ! 318 CALL lim_sbc_init ! ice surface boundary condition 319 ! 320 fr_i(:,:) = at_i(:,:) ! initialisation of sea-ice fraction 321 tn_ice(:,:,:) = t_su(:,:,:) ! initialisation of surface temp for coupled simu 322 ! 323 nstart = numit + nn_fsbc 324 nitrun = nitend - nit000 + 1 325 nlast = numit + nitrun 326 ! 327 IF( nstock == 0 ) nstock = nlast + 1 328 ! 329 END SUBROUTINE sbc_lim_init 330 331 332 SUBROUTINE ice_run 333 !!------------------------------------------------------------------- 334 !! *** ROUTINE ice_run *** 335 !! 336 !! ** Purpose : Definition some run parameter for ice model 337 !! 338 !! ** Method : Read the namicerun namelist and check the parameter 339 !! values called at the first timestep (nit000) 340 !! 341 !! ** input : Namelist namicerun 342 !!------------------------------------------------------------------- 343 INTEGER :: ios ! Local integer output status for namelist read 344 NAMELIST/namicerun/ jpl, nlay_i, nlay_s, cn_icerst_in, cn_icerst_indir, cn_icerst_out, cn_icerst_outdir, & 345 & ln_limdyn, rn_amax, ln_limdiahsb, ln_limdiaout, ln_icectl, iiceprt, jiceprt 346 !!------------------------------------------------------------------- 347 ! 348 REWIND( numnam_ice_ref ) ! Namelist namicerun in reference namelist : Parameters for ice 349 READ ( numnam_ice_ref, namicerun, IOSTAT = ios, ERR = 901) 350 901 IF( ios /= 0 ) CALL ctl_nam ( ios , 'namicerun in reference namelist', lwp ) 351 352 REWIND( numnam_ice_cfg ) ! Namelist namicerun in configuration namelist : Parameters for ice 353 READ ( numnam_ice_cfg, namicerun, IOSTAT = ios, ERR = 902 ) 354 902 IF( ios /= 0 ) CALL ctl_nam ( ios , 'namicerun in configuration namelist', lwp ) 355 IF(lwm) WRITE ( numoni, namicerun ) 356 ! 357 ! 358 IF(lwp) THEN ! control print 359 WRITE(numout,*) 360 WRITE(numout,*) 'ice_run : ice share parameters for dynamics/advection/thermo of sea-ice' 361 WRITE(numout,*) ' ~~~~~~' 362 WRITE(numout,*) ' number of ice categories = ', jpl 363 WRITE(numout,*) ' number of ice layers = ', nlay_i 364 WRITE(numout,*) ' number of snow layers = ', nlay_s 365 WRITE(numout,*) ' switch for ice dynamics (1) or not (0) ln_limdyn = ', ln_limdyn 366 WRITE(numout,*) ' maximum ice concentration = ', rn_amax 367 WRITE(numout,*) ' Diagnose heat/salt budget or not ln_limdiahsb = ', ln_limdiahsb 368 WRITE(numout,*) ' Output heat/salt budget or not ln_limdiaout = ', ln_limdiaout 369 WRITE(numout,*) ' control prints in ocean.out for (i,j)=(iiceprt,jiceprt) = ', ln_icectl 370 WRITE(numout,*) ' i-index for control prints (ln_icectl=true) = ', iiceprt 371 WRITE(numout,*) ' j-index for control prints (ln_icectl=true) = ', jiceprt 372 ENDIF 373 ! 374 ! sea-ice timestep and inverse 375 rdt_ice = nn_fsbc * rdttra(1) 376 r1_rdtice = 1._wp / rdt_ice 377 378 ! inverse of nlay_i and nlay_s 379 r1_nlay_i = 1._wp / REAL( nlay_i, wp ) 380 r1_nlay_s = 1._wp / REAL( nlay_s, wp ) 381 ! 382 #if defined key_bdy 383 IF( lwp .AND. ln_limdiahsb ) CALL ctl_warn('online conservation check activated but it does not work with BDY') 384 #endif 385 ! 386 END SUBROUTINE ice_run 387 388 389 SUBROUTINE lim_itd_init 390 !!------------------------------------------------------------------ 391 !! *** ROUTINE lim_itd_init *** 392 !! 393 !! ** Purpose : Initializes the ice thickness distribution 394 !! ** Method : ... 395 !! ** input : Namelist namiceitd 396 !!------------------------------------------------------------------- 397 INTEGER :: ios ! Local integer output status for namelist read 398 NAMELIST/namiceitd/ nn_catbnd, rn_himean 399 ! 400 INTEGER :: jl ! dummy loop index 401 REAL(wp) :: zc1, zc2, zc3, zx1 ! local scalars 402 REAL(wp) :: zhmax, znum, zden, zalpha ! 403 !!------------------------------------------------------------------ 404 ! 405 REWIND( numnam_ice_ref ) ! Namelist namiceitd in reference namelist : Parameters for ice 406 READ ( numnam_ice_ref, namiceitd, IOSTAT = ios, ERR = 903) 407 903 IF( ios /= 0 ) CALL ctl_nam ( ios , 'namiceitd in reference namelist', lwp ) 408 409 REWIND( numnam_ice_cfg ) ! Namelist namiceitd in configuration namelist : Parameters for ice 410 READ ( numnam_ice_cfg, namiceitd, IOSTAT = ios, ERR = 904 ) 411 904 IF( ios /= 0 ) CALL ctl_nam ( ios , 'namiceitd in configuration namelist', lwp ) 412 IF(lwm) WRITE ( numoni, namiceitd ) 413 ! 414 ! 415 IF(lwp) THEN ! control print 416 WRITE(numout,*) 417 WRITE(numout,*) 'ice_itd : ice cat distribution' 418 WRITE(numout,*) ' ~~~~~~' 419 WRITE(numout,*) ' shape of ice categories distribution nn_catbnd = ', nn_catbnd 420 WRITE(numout,*) ' mean ice thickness in the domain (only active if nn_catbnd=2) rn_himean = ', rn_himean 421 ENDIF 422 423 !---------------------------------- 424 !- Thickness categories boundaries 425 !---------------------------------- 426 IF(lwp) WRITE(numout,*) 427 IF(lwp) WRITE(numout,*) 'lim_itd_init : Initialization of ice cat distribution ' 428 IF(lwp) WRITE(numout,*) '~~~~~~~~~~~~' 429 430 hi_max(:) = 0._wp 431 432 SELECT CASE ( nn_catbnd ) 433 !---------------------- 434 CASE (1) ! tanh function (CICE) 435 !---------------------- 436 zc1 = 3._wp / REAL( jpl, wp ) 437 zc2 = 10._wp * zc1 438 zc3 = 3._wp 439 440 DO jl = 1, jpl 441 zx1 = REAL( jl-1, wp ) / REAL( jpl, wp ) 442 hi_max(jl) = hi_max(jl-1) + zc1 + zc2 * (1._wp + TANH( zc3 * (zx1 - 1._wp ) ) ) 443 END DO 444 445 !---------------------- 446 CASE (2) ! h^(-alpha) function 447 !---------------------- 448 zalpha = 0.05 ! exponent of the transform function 449 450 zhmax = 3.*rn_himean 451 452 DO jl = 1, jpl 453 znum = jpl * ( zhmax+1 )**zalpha 454 zden = ( jpl - jl ) * ( zhmax+1 )**zalpha + jl 455 hi_max(jl) = ( znum / zden )**(1./zalpha) - 1 456 END DO 457 458 END SELECT 459 460 DO jl = 1, jpl 461 hi_mean(jl) = ( hi_max(jl) + hi_max(jl-1) ) * 0.5_wp 462 END DO 463 464 ! Set hi_max(jpl) to a big value to ensure that all ice is thinner than hi_max(jpl) 465 hi_max(jpl) = 99._wp 466 467 IF(lwp) WRITE(numout,*) ' Thickness category boundaries ' 468 IF(lwp) WRITE(numout,*) ' hi_max ', hi_max(0:jpl) 469 ! 470 END SUBROUTINE lim_itd_init 471 352 472 353 SUBROUTINE ice_lim_flx( ptn_ice, palb_ice, pqns_ice, pqsr_ice, & 354 & pdqn_ice, pqla_ice, pdql_ice, k_limflx ) 473 SUBROUTINE ice_lim_flx( ptn_ice, palb_ice, pqns_ice, pqsr_ice, pdqn_ice, pevap_ice, pdevap_ice, k_limflx ) 355 474 !!--------------------------------------------------------------------- 356 !! *** ROUTINE sbc_ice_lim***475 !! *** ROUTINE ice_lim_flx *** 357 476 !! 358 477 !! ** Purpose : update the ice surface boundary condition by averaging and / or … … 370 489 REAL(wp), DIMENSION(:,:,:), INTENT(inout) :: pqsr_ice ! net solar flux 371 490 REAL(wp), DIMENSION(:,:,:), INTENT(inout) :: pdqn_ice ! non solar flux sensitivity 372 REAL(wp), DIMENSION(:,:,:), INTENT(inout) :: p qla_ice ! latent heat flux373 REAL(wp), DIMENSION(:,:,:), INTENT(inout) :: pd ql_ice ! latent heat fluxsensitivity491 REAL(wp), DIMENSION(:,:,:), INTENT(inout) :: pevap_ice ! sublimation 492 REAL(wp), DIMENSION(:,:,:), INTENT(inout) :: pdevap_ice ! sublimation sensitivity 374 493 ! 375 494 INTEGER :: jl ! dummy loop index … … 380 499 REAL(wp), POINTER, DIMENSION(:,:) :: z_qsr_m ! Mean solar heat flux over all categories 381 500 REAL(wp), POINTER, DIMENSION(:,:) :: z_qns_m ! Mean non solar heat flux over all categories 382 REAL(wp), POINTER, DIMENSION(:,:) :: z_ qla_m ! Mean latent heat fluxover all categories501 REAL(wp), POINTER, DIMENSION(:,:) :: z_evap_m ! Mean sublimation over all categories 383 502 REAL(wp), POINTER, DIMENSION(:,:) :: z_dqn_m ! Mean d(qns)/dT over all categories 384 REAL(wp), POINTER, DIMENSION(:,:) :: z_d ql_m ! Mean d(qla)/dT over all categories503 REAL(wp), POINTER, DIMENSION(:,:) :: z_devap_m ! Mean d(evap)/dT over all categories 385 504 !!---------------------------------------------------------------------- 386 505 … … 390 509 SELECT CASE( k_limflx ) !== averaged on all ice categories ==! 391 510 CASE( 0 , 1 ) 392 CALL wrk_alloc( jpi,jpj, z_qsr_m, z_qns_m, z_ qla_m, z_dqn_m, z_dql_m)393 ! 394 z_qns_m (:,:) = fice_ice_ave ( pqns_ice (:,:,:) )395 z_qsr_m (:,:) = fice_ice_ave ( pqsr_ice (:,:,:) )396 z_dqn_m (:,:) = fice_ice_ave ( pdqn_ice (:,:,:) )397 z_ qla_m(:,:) = fice_ice_ave ( pqla_ice (:,:,:) )398 z_d ql_m(:,:) = fice_ice_ave ( pdql_ice (:,:,:) )511 CALL wrk_alloc( jpi,jpj, z_qsr_m, z_qns_m, z_evap_m, z_dqn_m, z_devap_m) 512 ! 513 z_qns_m (:,:) = fice_ice_ave ( pqns_ice (:,:,:) ) 514 z_qsr_m (:,:) = fice_ice_ave ( pqsr_ice (:,:,:) ) 515 z_dqn_m (:,:) = fice_ice_ave ( pdqn_ice (:,:,:) ) 516 z_evap_m (:,:) = fice_ice_ave ( pevap_ice (:,:,:) ) 517 z_devap_m(:,:) = fice_ice_ave ( pdevap_ice (:,:,:) ) 399 518 DO jl = 1, jpl 400 pdqn_ice (:,:,jl) = z_dqn_m(:,:)401 pd ql_ice(:,:,jl) = z_dql_m(:,:)519 pdqn_ice (:,:,jl) = z_dqn_m(:,:) 520 pdevap_ice(:,:,jl) = z_devap_m(:,:) 402 521 END DO 403 522 ! 404 523 DO jl = 1, jpl 405 pqns_ice (:,:,jl) = z_qns_m(:,:)406 pqsr_ice (:,:,jl) = z_qsr_m(:,:)407 p qla_ice(:,:,jl) = z_qla_m(:,:)524 pqns_ice (:,:,jl) = z_qns_m(:,:) 525 pqsr_ice (:,:,jl) = z_qsr_m(:,:) 526 pevap_ice(:,:,jl) = z_evap_m(:,:) 408 527 END DO 409 528 ! 410 CALL wrk_dealloc( jpi,jpj, z_qsr_m, z_qns_m, z_ qla_m, z_dqn_m, z_dql_m)529 CALL wrk_dealloc( jpi,jpj, z_qsr_m, z_qns_m, z_evap_m, z_dqn_m, z_devap_m) 411 530 END SELECT 412 531 … … 418 537 ztem_m(:,:) = fice_ice_ave ( ptn_ice (:,:,:) ) 419 538 DO jl = 1, jpl 420 pqns_ice (:,:,jl) = pqns_ice(:,:,jl) + pdqn_ice(:,:,jl) * (ptn_ice(:,:,jl) - ztem_m(:,:))421 p qla_ice(:,:,jl) = pqla_ice(:,:,jl) + pdql_ice(:,:,jl) * (ptn_ice(:,:,jl) - ztem_m(:,:))422 pqsr_ice (:,:,jl) = pqsr_ice(:,:,jl) * ( 1._wp - palb_ice(:,:,jl) ) / ( 1._wp - zalb_m(:,:) )539 pqns_ice (:,:,jl) = pqns_ice (:,:,jl) + pdqn_ice (:,:,jl) * ( ptn_ice(:,:,jl) - ztem_m(:,:) ) 540 pevap_ice(:,:,jl) = pevap_ice(:,:,jl) + pdevap_ice(:,:,jl) * ( ptn_ice(:,:,jl) - ztem_m(:,:) ) 541 pqsr_ice (:,:,jl) = pqsr_ice (:,:,jl) * ( 1._wp - palb_ice(:,:,jl) ) / ( 1._wp - zalb_m(:,:) ) 423 542 END DO 424 543 ! … … 429 548 ! 430 549 END SUBROUTINE ice_lim_flx 431 432 433 SUBROUTINE lim_ctl( kt ) 434 !!----------------------------------------------------------------------- 435 !! *** ROUTINE lim_ctl *** 436 !! 437 !! ** Purpose : Alerts in case of model crash 438 !!------------------------------------------------------------------- 439 INTEGER, INTENT(in) :: kt ! ocean time step 440 INTEGER :: ji, jj, jk, jl ! dummy loop indices 441 INTEGER :: inb_altests ! number of alert tests (max 20) 442 INTEGER :: ialert_id ! number of the current alert 443 REAL(wp) :: ztmelts ! ice layer melting point 444 CHARACTER (len=30), DIMENSION(20) :: cl_alname ! name of alert 445 INTEGER , DIMENSION(20) :: inb_alp ! number of alerts positive 446 !!------------------------------------------------------------------- 447 448 inb_altests = 10 449 inb_alp(:) = 0 450 451 ! Alert if incompatible volume and concentration 452 ialert_id = 2 ! reference number of this alert 453 cl_alname(ialert_id) = ' Incompat vol and con ' ! name of the alert 454 455 DO jl = 1, jpl 456 DO jj = 1, jpj 457 DO ji = 1, jpi 458 IF( v_i(ji,jj,jl) /= 0._wp .AND. a_i(ji,jj,jl) == 0._wp ) THEN 459 !WRITE(numout,*) ' ALERTE 2 : Incompatible volume and concentration ' 460 !WRITE(numout,*) ' at_i ', at_i(ji,jj) 461 !WRITE(numout,*) ' Point - category', ji, jj, jl 462 !WRITE(numout,*) ' a_i *** a_i_b ', a_i (ji,jj,jl), a_i_b (ji,jj,jl) 463 !WRITE(numout,*) ' v_i *** v_i_b ', v_i (ji,jj,jl), v_i_b (ji,jj,jl) 464 !WRITE(numout,*) ' d_a_i_thd/trp ', d_a_i_thd(ji,jj,jl), d_a_i_trp(ji,jj,jl) 465 !WRITE(numout,*) ' d_v_i_thd/trp ', d_v_i_thd(ji,jj,jl), d_v_i_trp(ji,jj,jl) 466 inb_alp(ialert_id) = inb_alp(ialert_id) + 1 467 ENDIF 468 END DO 469 END DO 470 END DO 471 472 ! Alerte if very thick ice 473 ialert_id = 3 ! reference number of this alert 474 cl_alname(ialert_id) = ' Very thick ice ' ! name of the alert 475 jl = jpl 476 DO jj = 1, jpj 477 DO ji = 1, jpi 478 IF( ht_i(ji,jj,jl) > 50._wp ) THEN 479 !CALL lim_prt_state( kt, ji, jj, 2, ' ALERTE 3 : Very thick ice ' ) 480 inb_alp(ialert_id) = inb_alp(ialert_id) + 1 481 ENDIF 482 END DO 483 END DO 484 485 ! Alert if very fast ice 486 ialert_id = 4 ! reference number of this alert 487 cl_alname(ialert_id) = ' Very fast ice ' ! name of the alert 488 DO jj = 1, jpj 489 DO ji = 1, jpi 490 IF( MAX( ABS( u_ice(ji,jj) ), ABS( v_ice(ji,jj) ) ) > 1.5 .AND. & 491 & at_i(ji,jj) > 0._wp ) THEN 492 !CALL lim_prt_state( kt, ji, jj, 1, ' ALERTE 4 : Very fast ice ' ) 493 !WRITE(numout,*) ' ice strength : ', strength(ji,jj) 494 !WRITE(numout,*) ' oceanic stress utau : ', utau(ji,jj) 495 !WRITE(numout,*) ' oceanic stress vtau : ', vtau(ji,jj) 496 !WRITE(numout,*) ' sea-ice stress utau_ice : ', utau_ice(ji,jj) 497 !WRITE(numout,*) ' sea-ice stress vtau_ice : ', vtau_ice(ji,jj) 498 !WRITE(numout,*) ' oceanic speed u : ', u_oce(ji,jj) 499 !WRITE(numout,*) ' oceanic speed v : ', v_oce(ji,jj) 500 !WRITE(numout,*) ' sst : ', sst_m(ji,jj) 501 !WRITE(numout,*) ' sss : ', sss_m(ji,jj) 502 !WRITE(numout,*) 503 inb_alp(ialert_id) = inb_alp(ialert_id) + 1 504 ENDIF 505 END DO 506 END DO 507 508 ! Alert if there is ice on continents 509 ialert_id = 6 ! reference number of this alert 510 cl_alname(ialert_id) = ' Ice on continents ' ! name of the alert 511 DO jj = 1, jpj 512 DO ji = 1, jpi 513 IF( tms(ji,jj) <= 0._wp .AND. at_i(ji,jj) > 0._wp ) THEN 514 !CALL lim_prt_state( kt, ji, jj, 1, ' ALERTE 6 : Ice on continents ' ) 515 !WRITE(numout,*) ' masks s, u, v : ', tms(ji,jj), tmu(ji,jj), tmv(ji,jj) 516 !WRITE(numout,*) ' sst : ', sst_m(ji,jj) 517 !WRITE(numout,*) ' sss : ', sss_m(ji,jj) 518 !WRITE(numout,*) ' at_i(ji,jj) : ', at_i(ji,jj) 519 !WRITE(numout,*) ' v_ice(ji,jj) : ', v_ice(ji,jj) 520 !WRITE(numout,*) ' v_ice(ji,jj-1) : ', v_ice(ji,jj-1) 521 !WRITE(numout,*) ' u_ice(ji-1,jj) : ', u_ice(ji-1,jj) 522 !WRITE(numout,*) ' u_ice(ji,jj) : ', v_ice(ji,jj) 523 ! 524 inb_alp(ialert_id) = inb_alp(ialert_id) + 1 525 ENDIF 526 END DO 527 END DO 528 529 ! 530 ! ! Alert if very fresh ice 531 ialert_id = 7 ! reference number of this alert 532 cl_alname(ialert_id) = ' Very fresh ice ' ! name of the alert 533 DO jl = 1, jpl 534 DO jj = 1, jpj 535 DO ji = 1, jpi 536 IF( sm_i(ji,jj,jl) < 0.1 .AND. a_i(ji,jj,jl) > 0._wp ) THEN 537 ! CALL lim_prt_state(kt,ji,jj,1, ' ALERTE 7 : Very fresh ice ' ) 538 ! WRITE(numout,*) ' sst : ', sst_m(ji,jj) 539 ! WRITE(numout,*) ' sss : ', sss_m(ji,jj) 540 ! WRITE(numout,*) 541 inb_alp(ialert_id) = inb_alp(ialert_id) + 1 542 ENDIF 543 END DO 544 END DO 545 END DO 546 ! 547 548 ! ! Alert if too old ice 549 ialert_id = 9 ! reference number of this alert 550 cl_alname(ialert_id) = ' Very old ice ' ! name of the alert 551 DO jl = 1, jpl 552 DO jj = 1, jpj 553 DO ji = 1, jpi 554 IF ( ( ( ABS( o_i(ji,jj,jl) ) > rdt_ice ) .OR. & 555 ( ABS( o_i(ji,jj,jl) ) < 0._wp) ) .AND. & 556 ( a_i(ji,jj,jl) > 0._wp ) ) THEN 557 !CALL lim_prt_state( kt, ji, jj, 1, ' ALERTE 9 : Wrong ice age ') 558 inb_alp(ialert_id) = inb_alp(ialert_id) + 1 559 ENDIF 560 END DO 561 END DO 562 END DO 563 564 ! Alert on salt flux 565 ialert_id = 5 ! reference number of this alert 566 cl_alname(ialert_id) = ' High salt flux ' ! name of the alert 567 DO jj = 1, jpj 568 DO ji = 1, jpi 569 IF( ABS( sfx (ji,jj) ) .GT. 1.0e-2 ) THEN ! = 1 psu/day for 1m ocean depth 570 !CALL lim_prt_state( kt, ji, jj, 3, ' ALERTE 5 : High salt flux ' ) 571 !DO jl = 1, jpl 572 !WRITE(numout,*) ' Category no: ', jl 573 !WRITE(numout,*) ' a_i : ', a_i (ji,jj,jl) , ' a_i_b : ', a_i_b (ji,jj,jl) 574 !WRITE(numout,*) ' d_a_i_trp : ', d_a_i_trp(ji,jj,jl) , ' d_a_i_thd : ', d_a_i_thd(ji,jj,jl) 575 !WRITE(numout,*) ' v_i : ', v_i (ji,jj,jl) , ' v_i_b : ', v_i_b (ji,jj,jl) 576 !WRITE(numout,*) ' d_v_i_trp : ', d_v_i_trp(ji,jj,jl) , ' d_v_i_thd : ', d_v_i_thd(ji,jj,jl) 577 !WRITE(numout,*) ' ' 578 !END DO 579 inb_alp(ialert_id) = inb_alp(ialert_id) + 1 580 ENDIF 581 END DO 582 END DO 583 584 ! Alert if qns very big 585 ialert_id = 8 ! reference number of this alert 586 cl_alname(ialert_id) = ' fnsolar very big ' ! name of the alert 587 DO jj = 1, jpj 588 DO ji = 1, jpi 589 IF( ABS( qns(ji,jj) ) > 1500._wp .AND. at_i(ji,jj) > 0._wp ) THEN 590 ! 591 !WRITE(numout,*) ' ALERTE 8 : Very high non-solar heat flux' 592 !WRITE(numout,*) ' ji, jj : ', ji, jj 593 !WRITE(numout,*) ' qns : ', qns(ji,jj) 594 !WRITE(numout,*) ' sst : ', sst_m(ji,jj) 595 !WRITE(numout,*) ' sss : ', sss_m(ji,jj) 596 ! 597 !CALL lim_prt_state( kt, ji, jj, 2, ' ') 598 inb_alp(ialert_id) = inb_alp(ialert_id) + 1 599 ! 600 ENDIF 601 END DO 602 END DO 603 !+++++ 604 605 ! Alert if very warm ice 606 ialert_id = 10 ! reference number of this alert 607 cl_alname(ialert_id) = ' Very warm ice ' ! name of the alert 608 inb_alp(ialert_id) = 0 609 DO jl = 1, jpl 610 DO jk = 1, nlay_i 611 DO jj = 1, jpj 612 DO ji = 1, jpi 613 ztmelts = -tmut * s_i(ji,jj,jk,jl) + rtt 614 IF( t_i(ji,jj,jk,jl) >= ztmelts .AND. v_i(ji,jj,jl) > 1.e-10 & 615 & .AND. a_i(ji,jj,jl) > 0._wp ) THEN 616 !WRITE(numout,*) ' ALERTE 10 : Very warm ice' 617 !WRITE(numout,*) ' ji, jj, jk, jl : ', ji, jj, jk, jl 618 !WRITE(numout,*) ' t_i : ', t_i(ji,jj,jk,jl) 619 !WRITE(numout,*) ' e_i : ', e_i(ji,jj,jk,jl) 620 !WRITE(numout,*) ' s_i : ', s_i(ji,jj,jk,jl) 621 !WRITE(numout,*) ' ztmelts : ', ztmelts 622 inb_alp(ialert_id) = inb_alp(ialert_id) + 1 623 ENDIF 624 END DO 625 END DO 626 END DO 627 END DO 628 629 ! sum of the alerts on all processors 630 IF( lk_mpp ) THEN 631 DO ialert_id = 1, inb_altests 632 CALL mpp_sum(inb_alp(ialert_id)) 633 END DO 634 ENDIF 635 636 ! print alerts 637 IF( lwp ) THEN 638 ialert_id = 1 ! reference number of this alert 639 cl_alname(ialert_id) = ' NO alerte 1 ' ! name of the alert 640 WRITE(numout,*) ' time step ',kt 641 WRITE(numout,*) ' All alerts at the end of ice model ' 642 DO ialert_id = 1, inb_altests 643 WRITE(numout,*) ialert_id, cl_alname(ialert_id)//' : ', inb_alp(ialert_id), ' times ! ' 644 END DO 645 ENDIF 646 ! 647 END SUBROUTINE lim_ctl 648 649 650 SUBROUTINE lim_prt_state( kt, ki, kj, kn, cd1 ) 651 !!----------------------------------------------------------------------- 652 !! *** ROUTINE lim_prt_state *** 653 !! 654 !! ** Purpose : Writes global ice state on the (i,j) point 655 !! in ocean.ouput 656 !! 3 possibilities exist 657 !! n = 1/-1 -> simple ice state (plus Mechanical Check if -1) 658 !! n = 2 -> exhaustive state 659 !! n = 3 -> ice/ocean salt fluxes 660 !! 661 !! ** input : point coordinates (i,j) 662 !! n : number of the option 663 !!------------------------------------------------------------------- 664 INTEGER , INTENT(in) :: kt ! ocean time step 665 INTEGER , INTENT(in) :: ki, kj, kn ! ocean gridpoint indices 666 CHARACTER(len=*), INTENT(in) :: cd1 ! 667 !! 668 INTEGER :: jl, ji, jj 669 !!------------------------------------------------------------------- 670 671 DO ji = mi0(ki), mi1(ki) 672 DO jj = mj0(kj), mj1(kj) 673 674 WRITE(numout,*) ' time step ',kt,' ',cd1 ! print title 675 676 !---------------- 677 ! Simple state 678 !---------------- 679 680 IF ( kn == 1 .OR. kn == -1 ) THEN 681 WRITE(numout,*) ' lim_prt_state - Point : ',ji,jj 682 WRITE(numout,*) ' ~~~~~~~~~~~~~~ ' 683 WRITE(numout,*) ' Simple state ' 684 WRITE(numout,*) ' masks s,u,v : ', tms(ji,jj), tmu(ji,jj), tmv(ji,jj) 685 WRITE(numout,*) ' lat - long : ', gphit(ji,jj), glamt(ji,jj) 686 WRITE(numout,*) ' Time step : ', numit 687 WRITE(numout,*) ' - Ice drift ' 688 WRITE(numout,*) ' ~~~~~~~~~~~ ' 689 WRITE(numout,*) ' u_ice(i-1,j) : ', u_ice(ji-1,jj) 690 WRITE(numout,*) ' u_ice(i ,j) : ', u_ice(ji,jj) 691 WRITE(numout,*) ' v_ice(i ,j-1): ', v_ice(ji,jj-1) 692 WRITE(numout,*) ' v_ice(i ,j) : ', v_ice(ji,jj) 693 WRITE(numout,*) ' strength : ', strength(ji,jj) 694 WRITE(numout,*) 695 WRITE(numout,*) ' - Cell values ' 696 WRITE(numout,*) ' ~~~~~~~~~~~ ' 697 WRITE(numout,*) ' cell area : ', area(ji,jj) 698 WRITE(numout,*) ' at_i : ', at_i(ji,jj) 699 WRITE(numout,*) ' vt_i : ', vt_i(ji,jj) 700 WRITE(numout,*) ' vt_s : ', vt_s(ji,jj) 701 DO jl = 1, jpl 702 WRITE(numout,*) ' - Category (', jl,')' 703 WRITE(numout,*) ' a_i : ', a_i(ji,jj,jl) 704 WRITE(numout,*) ' ht_i : ', ht_i(ji,jj,jl) 705 WRITE(numout,*) ' ht_s : ', ht_s(ji,jj,jl) 706 WRITE(numout,*) ' v_i : ', v_i(ji,jj,jl) 707 WRITE(numout,*) ' v_s : ', v_s(ji,jj,jl) 708 WRITE(numout,*) ' e_s : ', e_s(ji,jj,1,jl)/1.0e9 709 WRITE(numout,*) ' e_i : ', e_i(ji,jj,1:nlay_i,jl)/1.0e9 710 WRITE(numout,*) ' t_su : ', t_su(ji,jj,jl) 711 WRITE(numout,*) ' t_snow : ', t_s(ji,jj,1,jl) 712 WRITE(numout,*) ' t_i : ', t_i(ji,jj,1:nlay_i,jl) 713 WRITE(numout,*) ' sm_i : ', sm_i(ji,jj,jl) 714 WRITE(numout,*) ' smv_i : ', smv_i(ji,jj,jl) 715 WRITE(numout,*) 716 END DO 717 ENDIF 718 IF( kn == -1 ) THEN 719 WRITE(numout,*) ' Mechanical Check ************** ' 720 WRITE(numout,*) ' Check what means ice divergence ' 721 WRITE(numout,*) ' Total ice concentration ', at_i (ji,jj) 722 WRITE(numout,*) ' Total lead fraction ', ato_i(ji,jj) 723 WRITE(numout,*) ' Sum of both ', ato_i(ji,jj) + at_i(ji,jj) 724 WRITE(numout,*) ' Sum of both minus 1 ', ato_i(ji,jj) + at_i(ji,jj) - 1.00 725 ENDIF 726 727 728 !-------------------- 729 ! Exhaustive state 730 !-------------------- 731 732 IF ( kn .EQ. 2 ) THEN 733 WRITE(numout,*) ' lim_prt_state - Point : ',ji,jj 734 WRITE(numout,*) ' ~~~~~~~~~~~~~~ ' 735 WRITE(numout,*) ' Exhaustive state ' 736 WRITE(numout,*) ' lat - long ', gphit(ji,jj), glamt(ji,jj) 737 WRITE(numout,*) ' Time step ', numit 738 WRITE(numout,*) 739 WRITE(numout,*) ' - Cell values ' 740 WRITE(numout,*) ' ~~~~~~~~~~~ ' 741 WRITE(numout,*) ' cell area : ', area(ji,jj) 742 WRITE(numout,*) ' at_i : ', at_i(ji,jj) 743 WRITE(numout,*) ' vt_i : ', vt_i(ji,jj) 744 WRITE(numout,*) ' vt_s : ', vt_s(ji,jj) 745 WRITE(numout,*) ' u_ice(i-1,j) : ', u_ice(ji-1,jj) 746 WRITE(numout,*) ' u_ice(i ,j) : ', u_ice(ji,jj) 747 WRITE(numout,*) ' v_ice(i ,j-1): ', v_ice(ji,jj-1) 748 WRITE(numout,*) ' v_ice(i ,j) : ', v_ice(ji,jj) 749 WRITE(numout,*) ' strength : ', strength(ji,jj) 750 WRITE(numout,*) ' d_u_ice_dyn : ', d_u_ice_dyn(ji,jj), ' d_v_ice_dyn : ', d_v_ice_dyn(ji,jj) 751 WRITE(numout,*) ' u_ice_b : ', u_ice_b(ji,jj) , ' v_ice_b : ', v_ice_b(ji,jj) 752 WRITE(numout,*) 753 754 DO jl = 1, jpl 755 WRITE(numout,*) ' - Category (',jl,')' 756 WRITE(numout,*) ' ~~~~~~~~ ' 757 WRITE(numout,*) ' ht_i : ', ht_i(ji,jj,jl) , ' ht_s : ', ht_s(ji,jj,jl) 758 WRITE(numout,*) ' t_i : ', t_i(ji,jj,1:nlay_i,jl) 759 WRITE(numout,*) ' t_su : ', t_su(ji,jj,jl) , ' t_s : ', t_s(ji,jj,1,jl) 760 WRITE(numout,*) ' sm_i : ', sm_i(ji,jj,jl) , ' o_i : ', o_i(ji,jj,jl) 761 WRITE(numout,*) ' a_i : ', a_i(ji,jj,jl) , ' a_i_b : ', a_i_b(ji,jj,jl) 762 WRITE(numout,*) ' d_a_i_trp : ', d_a_i_trp(ji,jj,jl) , ' d_a_i_thd : ', d_a_i_thd(ji,jj,jl) 763 WRITE(numout,*) ' v_i : ', v_i(ji,jj,jl) , ' v_i_b : ', v_i_b(ji,jj,jl) 764 WRITE(numout,*) ' d_v_i_trp : ', d_v_i_trp(ji,jj,jl) , ' d_v_i_thd : ', d_v_i_thd(ji,jj,jl) 765 WRITE(numout,*) ' v_s : ', v_s(ji,jj,jl) , ' v_s_b : ', v_s_b(ji,jj,jl) 766 WRITE(numout,*) ' d_v_s_trp : ', d_v_s_trp(ji,jj,jl) , ' d_v_s_thd : ', d_v_s_thd(ji,jj,jl) 767 WRITE(numout,*) ' e_i1 : ', e_i(ji,jj,1,jl)/1.0e9 , ' ei1 : ', e_i_b(ji,jj,1,jl)/1.0e9 768 WRITE(numout,*) ' de_i1_trp : ', d_e_i_trp(ji,jj,1,jl)/1.0e9, ' de_i1_thd : ', d_e_i_thd(ji,jj,1,jl)/1.0e9 769 WRITE(numout,*) ' e_i2 : ', e_i(ji,jj,2,jl)/1.0e9 , ' ei2_b : ', e_i_b(ji,jj,2,jl)/1.0e9 770 WRITE(numout,*) ' de_i2_trp : ', d_e_i_trp(ji,jj,2,jl)/1.0e9, ' de_i2_thd : ', d_e_i_thd(ji,jj,2,jl)/1.0e9 771 WRITE(numout,*) ' e_snow : ', e_s(ji,jj,1,jl) , ' e_snow_b : ', e_s_b(ji,jj,1,jl) 772 WRITE(numout,*) ' d_e_s_trp : ', d_e_s_trp(ji,jj,1,jl) , ' d_e_s_thd : ', d_e_s_thd(ji,jj,1,jl) 773 WRITE(numout,*) ' smv_i : ', smv_i(ji,jj,jl) , ' smv_i_b : ', smv_i_b(ji,jj,jl) 774 WRITE(numout,*) ' d_smv_i_trp: ', d_smv_i_trp(ji,jj,jl) , ' d_smv_i_thd: ', d_smv_i_thd(ji,jj,jl) 775 WRITE(numout,*) ' oa_i : ', oa_i(ji,jj,jl) , ' oa_i_b : ', oa_i_b(ji,jj,jl) 776 WRITE(numout,*) ' d_oa_i_trp : ', d_oa_i_trp(ji,jj,jl) , ' d_oa_i_thd : ', d_oa_i_thd(ji,jj,jl) 777 END DO !jl 778 779 WRITE(numout,*) 780 WRITE(numout,*) ' - Heat / FW fluxes ' 781 WRITE(numout,*) ' ~~~~~~~~~~~~~~~~ ' 782 WRITE(numout,*) ' - Heat fluxes in and out the ice ***' 783 WRITE(numout,*) ' qsr_ini : ', pfrld(ji,jj) * qsr(ji,jj) + SUM( a_i_b(ji,jj,:) * qsr_ice(ji,jj,:) ) 784 WRITE(numout,*) ' qns_ini : ', pfrld(ji,jj) * qns(ji,jj) + SUM( a_i_b(ji,jj,:) * qns_ice(ji,jj,:) ) 785 WRITE(numout,*) 786 WRITE(numout,*) 787 WRITE(numout,*) ' sst : ', sst_m(ji,jj) 788 WRITE(numout,*) ' sss : ', sss_m(ji,jj) 789 WRITE(numout,*) 790 WRITE(numout,*) ' - Stresses ' 791 WRITE(numout,*) ' ~~~~~~~~ ' 792 WRITE(numout,*) ' utau_ice : ', utau_ice(ji,jj) 793 WRITE(numout,*) ' vtau_ice : ', vtau_ice(ji,jj) 794 WRITE(numout,*) ' utau : ', utau (ji,jj) 795 WRITE(numout,*) ' vtau : ', vtau (ji,jj) 796 WRITE(numout,*) ' oc. vel. u : ', u_oce (ji,jj) 797 WRITE(numout,*) ' oc. vel. v : ', v_oce (ji,jj) 798 ENDIF 799 800 !--------------------- 801 ! Salt / heat fluxes 802 !--------------------- 803 804 IF ( kn .EQ. 3 ) THEN 805 WRITE(numout,*) ' lim_prt_state - Point : ',ji,jj 806 WRITE(numout,*) ' ~~~~~~~~~~~~~~ ' 807 WRITE(numout,*) ' - Salt / Heat Fluxes ' 808 WRITE(numout,*) ' ~~~~~~~~~~~~~~~~ ' 809 WRITE(numout,*) ' lat - long ', gphit(ji,jj), glamt(ji,jj) 810 WRITE(numout,*) ' Time step ', numit 811 WRITE(numout,*) 812 WRITE(numout,*) ' - Heat fluxes at bottom interface ***' 813 WRITE(numout,*) ' qsr : ', qsr(ji,jj) 814 WRITE(numout,*) ' qns : ', qns(ji,jj) 815 WRITE(numout,*) 816 WRITE(numout,*) ' hfx_mass : ', hfx_thd(ji,jj) + hfx_dyn(ji,jj) + hfx_snw(ji,jj) + hfx_res(ji,jj) 817 WRITE(numout,*) ' hfx_in : ', hfx_in(ji,jj) 818 WRITE(numout,*) ' hfx_out : ', hfx_out(ji,jj) 819 WRITE(numout,*) ' dhc : ', diag_heat_dhc(ji,jj) 820 WRITE(numout,*) 821 WRITE(numout,*) ' hfx_dyn : ', hfx_dyn(ji,jj) 822 WRITE(numout,*) ' hfx_thd : ', hfx_thd(ji,jj) 823 WRITE(numout,*) ' hfx_res : ', hfx_res(ji,jj) 824 WRITE(numout,*) ' fhtur : ', fhtur(ji,jj) 825 WRITE(numout,*) ' qlead : ', qlead(ji,jj) * r1_rdtice 826 WRITE(numout,*) 827 WRITE(numout,*) ' - Salt fluxes at bottom interface ***' 828 WRITE(numout,*) ' emp : ', emp (ji,jj) 829 WRITE(numout,*) ' sfx : ', sfx (ji,jj) 830 WRITE(numout,*) ' sfx_res : ', sfx_res(ji,jj) 831 WRITE(numout,*) ' sfx_bri : ', sfx_bri(ji,jj) 832 WRITE(numout,*) ' sfx_dyn : ', sfx_dyn(ji,jj) 833 WRITE(numout,*) 834 WRITE(numout,*) ' - Momentum fluxes ' 835 WRITE(numout,*) ' utau : ', utau(ji,jj) 836 WRITE(numout,*) ' vtau : ', vtau(ji,jj) 837 ENDIF 838 WRITE(numout,*) ' ' 839 ! 840 END DO 841 END DO 842 ! 843 END SUBROUTINE lim_prt_state 844 550 551 SUBROUTINE sbc_lim_bef 552 !!---------------------------------------------------------------------- 553 !! *** ROUTINE sbc_lim_bef *** 554 !! 555 !! ** purpose : store ice variables at "before" time step 556 !!---------------------------------------------------------------------- 557 a_i_b (:,:,:) = a_i (:,:,:) ! ice area 558 e_i_b (:,:,:,:) = e_i (:,:,:,:) ! ice thermal energy 559 v_i_b (:,:,:) = v_i (:,:,:) ! ice volume 560 v_s_b (:,:,:) = v_s (:,:,:) ! snow volume 561 e_s_b (:,:,:,:) = e_s (:,:,:,:) ! snow thermal energy 562 smv_i_b(:,:,:) = smv_i(:,:,:) ! salt content 563 oa_i_b (:,:,:) = oa_i (:,:,:) ! areal age content 564 u_ice_b(:,:) = u_ice(:,:) 565 v_ice_b(:,:) = v_ice(:,:) 566 567 END SUBROUTINE sbc_lim_bef 568 569 SUBROUTINE sbc_lim_diag0 570 !!---------------------------------------------------------------------- 571 !! *** ROUTINE sbc_lim_diag0 *** 572 !! 573 !! ** purpose : set ice-ocean and ice-atm. fluxes to zeros at the beggining 574 !! of the time step 575 !!---------------------------------------------------------------------- 576 sfx (:,:) = 0._wp ; 577 sfx_bri(:,:) = 0._wp ; 578 sfx_sni(:,:) = 0._wp ; sfx_opw(:,:) = 0._wp 579 sfx_bog(:,:) = 0._wp ; sfx_dyn(:,:) = 0._wp 580 sfx_bom(:,:) = 0._wp ; sfx_sum(:,:) = 0._wp 581 sfx_res(:,:) = 0._wp 582 583 wfx_snw(:,:) = 0._wp ; wfx_ice(:,:) = 0._wp 584 wfx_sni(:,:) = 0._wp ; wfx_opw(:,:) = 0._wp 585 wfx_bog(:,:) = 0._wp ; wfx_dyn(:,:) = 0._wp 586 wfx_bom(:,:) = 0._wp ; wfx_sum(:,:) = 0._wp 587 wfx_res(:,:) = 0._wp ; wfx_sub(:,:) = 0._wp 588 wfx_spr(:,:) = 0._wp ; 589 590 hfx_thd(:,:) = 0._wp ; 591 hfx_snw(:,:) = 0._wp ; hfx_opw(:,:) = 0._wp 592 hfx_bog(:,:) = 0._wp ; hfx_dyn(:,:) = 0._wp 593 hfx_bom(:,:) = 0._wp ; hfx_sum(:,:) = 0._wp 594 hfx_res(:,:) = 0._wp ; hfx_sub(:,:) = 0._wp 595 hfx_spr(:,:) = 0._wp ; hfx_dif(:,:) = 0._wp 596 hfx_err(:,:) = 0._wp ; hfx_err_rem(:,:) = 0._wp 597 hfx_err_dif(:,:) = 0._wp ; 598 599 afx_tot(:,:) = 0._wp ; 600 afx_dyn(:,:) = 0._wp ; afx_thd(:,:) = 0._wp 601 602 diag_heat(:,:) = 0._wp ; diag_smvi(:,:) = 0._wp ; 603 diag_vice(:,:) = 0._wp ; diag_vsnw(:,:) = 0._wp ; 604 605 END SUBROUTINE sbc_lim_diag0 606 845 607 846 608 FUNCTION fice_cell_ave ( ptab ) … … 853 615 854 616 fice_cell_ave (:,:) = 0.0_wp 855 856 617 DO jl = 1, jpl 857 fice_cell_ave (:,:) = fice_cell_ave (:,:) & 858 & + a_i (:,:,jl) * ptab (:,:,jl) 618 fice_cell_ave (:,:) = fice_cell_ave (:,:) + a_i (:,:,jl) * ptab (:,:,jl) 859 619 END DO 860 620 … … 870 630 871 631 fice_ice_ave (:,:) = 0.0_wp 872 WHERE ( at_i (:,:) .GT.0.0_wp ) fice_ice_ave (:,:) = fice_cell_ave ( ptab (:,:,:)) / at_i (:,:)632 WHERE ( at_i (:,:) > 0.0_wp ) fice_ice_ave (:,:) = fice_cell_ave ( ptab (:,:,:)) / at_i (:,:) 873 633 874 634 END FUNCTION fice_ice_ave … … 883 643 WRITE(*,*) 'sbc_ice_lim: You should not have seen this print! error?', kt, kblk 884 644 END SUBROUTINE sbc_ice_lim 645 SUBROUTINE sbc_lim_init ! Dummy routine 646 END SUBROUTINE sbc_lim_init 885 647 #endif 886 648 -
branches/2014/dev_r4621_NOC4_BDY_VERT_INTERP/NEMOGCM/NEMO/OPA_SRC/SBC/sbcice_lim_2.F90
r5038 r5620 101 101 REAL(wp), DIMENSION(:,:,:), POINTER :: zalb_ice ! mean ice albedo 102 102 REAL(wp), DIMENSION(:,:,:), POINTER :: zsist ! ice surface temperature (K) 103 REAL(wp), DIMENSION(:,: ), POINTER :: zutau_ice, zvtau_ice 103 104 !!---------------------------------------------------------------------- 104 105 CALL wrk_alloc( jpi,jpj,1, zalb_os, zalb_cs, zalb_ice, zsist )106 105 107 106 IF( kt == nit000 ) THEN … … 124 123 &*Agrif_PArent(nn_fsbc)/REAL(nn_fsbc)) + 1 125 124 # endif 125 126 CALL wrk_alloc( jpi,jpj , zutau_ice, zvtau_ice) 127 CALL wrk_alloc( jpi,jpj,1, zalb_os, zalb_cs, zalb_ice, zsist ) 128 126 129 ! Bulk Formulea ! 127 130 !----------------! … … 132 135 DO ji = 2, jpi ! NO vector opt. possible 133 136 u_oce(ji,jj) = 0.5_wp * ( ssu_m(ji-1,jj ) * umask(ji-1,jj ,1) & 134 & + ssu_m(ji-1,jj-1) * umask(ji-1,jj-1,1) ) * tmu(ji,jj)137 & + ssu_m(ji-1,jj-1) * umask(ji-1,jj-1,1) ) * tmu(ji,jj) 135 138 v_oce(ji,jj) = 0.5_wp * ( ssv_m(ji ,jj-1) * vmask(ji ,jj-1,1) & 136 & + ssv_m(ji-1,jj-1) * vmask(ji-1,jj-1,1) ) * tmu(ji,jj)139 & + ssv_m(ji-1,jj-1) * vmask(ji-1,jj-1,1) ) * tmu(ji,jj) 137 140 END DO 138 141 END DO … … 147 150 148 151 ! ... masked sea surface freezing temperature [Kelvin] (set to rt0 over land) 149 tfu(:,:) = eos_fzp( sss_m ) + rt0 152 CALL eos_fzp( sss_m(:,:), tfu(:,:) ) 153 tfu(:,:) = tfu(:,:) + rt0 150 154 151 155 zsist (:,:,1) = sist (:,:) + rt0 * ( 1. - tmask(:,:,1) ) … … 158 162 159 163 SELECT CASE( ksbc ) 160 CASE( jp_core , jp_ cpl ) ! CORE and COUPLED bulk formulations164 CASE( jp_core , jp_purecpl ) ! CORE and COUPLED bulk formulations 161 165 162 166 ! albedo depends on cloud fraction because of non-linear spectral effects … … 182 186 SELECT CASE( ksbc ) 183 187 CASE( jp_clio ) ! CLIO bulk formulation 184 CALL blk_ice_clio( zsist, zalb_cs , zalb_os , zalb_ice , & 185 & utau_ice , vtau_ice , qns_ice , qsr_ice, & 186 & qla_ice , dqns_ice , dqla_ice , & 187 & tprecip , sprecip , & 188 & fr1_i0 , fr2_i0 , cp_ice_msh , jpl ) 188 ! CALL blk_ice_clio( zsist, zalb_cs , zalb_os , zalb_ice , & 189 ! & utau_ice , vtau_ice , qns_ice , qsr_ice, & 190 ! & qla_ice , dqns_ice , dqla_ice , & 191 ! & tprecip , sprecip , & 192 ! & fr1_i0 , fr2_i0 , cp_ice_msh , jpl ) 193 CALL blk_ice_clio_tau 194 CALL blk_ice_clio_flx( zsist, zalb_cs, zalb_os, zalb_ice ) 189 195 190 196 CASE( jp_core ) ! CORE bulk formulation 191 CALL blk_ice_core( zsist, u_ice , v_ice , zalb_ice , & 192 & utau_ice , vtau_ice , qns_ice , qsr_ice, & 193 & qla_ice , dqns_ice , dqla_ice , & 194 & tprecip , sprecip , & 195 & fr1_i0 , fr2_i0 , cp_ice_msh , jpl ) 196 IF( ltrcdm2dc_ice ) CALL blk_ice_meanqsr( zalb_ice, qsr_ice_mean, jpl ) 197 198 CASE( jp_cpl ) ! Coupled formulation : atmosphere-ice stress only (fluxes provided after ice dynamics) 197 CALL blk_ice_core_tau 198 CALL blk_ice_core_flx( zsist, zalb_ice ) 199 200 CASE( jp_purecpl ) ! Coupled formulation : atmosphere-ice stress only (fluxes provided after ice dynamics) 199 201 CALL sbc_cpl_ice_tau( utau_ice , vtau_ice ) 200 202 END SELECT 203 204 IF( ln_mixcpl) THEN 205 CALL sbc_cpl_ice_tau( zutau_ice , zvtau_ice ) 206 utau_ice(:,:) = utau_ice(:,:) * xcplmask(:,:,0) + zutau_ice(:,:) * ( 1. - xcplmask(:,:,0) ) 207 vtau_ice(:,:) = vtau_ice(:,:) * xcplmask(:,:,0) + zvtau_ice(:,:) * ( 1. - xcplmask(:,:,0) ) 208 ENDIF 201 209 202 210 CALL iom_put( 'utau_ice', utau_ice ) ! Wind stress over ice along i-axis at I-point … … 228 236 END IF 229 237 ! ! Ice surface fluxes in coupled mode 230 IF( ksbc == jp_cpl ) THEN238 IF( ln_cpl ) THEN ! pure coupled and mixed forced-coupled configurations 231 239 a_i(:,:,1)=fr_i 232 240 CALL sbc_cpl_ice_flx( frld, & 233 241 ! optional arguments, used only in 'mixed oce-ice' case 234 & palbi = zalb_ice, psst = sst_m, pist =zsist )242 & palbi=zalb_ice, psst=sst_m, pist=zsist ) 235 243 sprecip(:,:) = - emp_ice(:,:) ! Ugly patch, WARNING, in coupled mode, sublimation included in snow (parsub = 0.) 236 244 ENDIF 237 245 CALL lim_thd_2 ( kt ) ! Ice thermodynamics 238 246 CALL lim_sbc_flx_2 ( kt ) ! update surface ocean mass, heat & salt fluxes 239 #if defined key_top240 IF( ltrcdm2dc_ice )CALL lim_bio_meanqsr_2241 #endif242 247 243 248 IF( .NOT. lk_mpp )THEN … … 253 258 IF( .NOT. Agrif_Root() ) CALL agrif_update_lim2( kt ) 254 259 # endif 260 ! 261 CALL wrk_dealloc( jpi,jpj , zutau_ice, zvtau_ice) 262 CALL wrk_dealloc( jpi,jpj,1, zalb_os, zalb_cs, zalb_ice, zsist ) 255 263 ! 256 264 ENDIF ! End sea-ice time step only … … 264 272 IF( ln_limdyn ) CALL lim_sbc_tau_2( kt, ub(:,:,1), vb(:,:,1) ) ! using before instantaneous surf. currents 265 273 ! 266 CALL wrk_dealloc( jpi,jpj,1, zalb_os, zalb_cs, zalb_ice, zsist )267 !268 274 END SUBROUTINE sbc_ice_lim_2 269 275 -
branches/2014/dev_r4621_NOC4_BDY_VERT_INTERP/NEMOGCM/NEMO/OPA_SRC/SBC/sbcisf.F90
- Property svn:keywords set to Id
r5038 r5620 7 7 !! History : 3.2 ! 2011-02 (C.Harris ) Original code isf cav 8 8 !! X.X ! 2006-02 (C. Wang ) Original code bg03 9 !! 3.4 ! 2013-03 (P. Mathiot) Merging 9 !! 3.4 ! 2013-03 (P. Mathiot) Merging + parametrization 10 10 !!---------------------------------------------------------------------- 11 11 … … 37 37 38 38 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: risf_tsc_b, risf_tsc 39 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: fwfisf_b, fwfisf !: evaporation damping [kg/m2/s] 40 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: qisf !: net heat flux from ice shelf 39 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: qisf !: net heat flux from ice shelf 41 40 REAL(wp), PUBLIC :: rn_hisf_tbl !: thickness of top boundary layer [m] 42 41 LOGICAL , PUBLIC :: ln_divisf !: flag to correct divergence … … 81 80 !!---------------------------------------------------------------------- 82 81 !! NEMO/OPA 3.0 , LOCEAN-IPSL (2008) 83 !! $Id : sbcice_if.F90 1730 2009-11-16 14:34:19Z smasson$82 !! $Id$ 84 83 !! Software governed by the CeCILL licence (modipsl/doc/NEMO_CeCILL.txt) 85 84 !!---------------------------------------------------------------------- … … 309 308 sbc_isf_alloc = 0 ! set to zero if no array to be allocated 310 309 IF( .NOT. ALLOCATED( qisf ) ) THEN 311 ALLOCATE( risf_tsc(jpi,jpj,jpts), risf_tsc_b(jpi,jpj,jpts) , & 312 & qisf(jpi,jpj) , fwfisf(jpi,jpj) , fwfisf_b(jpi,jpj) , & 313 & rhisf_tbl(jpi,jpj), r1_hisf_tbl(jpi,jpj), rzisf_tbl(jpi,jpj) , & 314 & ttbl(jpi,jpj) , stbl(jpi,jpj) , utbl(jpi,jpj) , & 315 & vtbl(jpi, jpj) , risfLeff(jpi,jpj) , rhisf_tbl_0(jpi,jpj), & 316 & ralpha(jpi,jpj) , misfkt(jpi,jpj) , misfkb(jpi,jpj) , & 310 ALLOCATE( risf_tsc(jpi,jpj,jpts), risf_tsc_b(jpi,jpj,jpts), qisf(jpi,jpj) , & 311 & rhisf_tbl(jpi,jpj) , r1_hisf_tbl(jpi,jpj), rzisf_tbl(jpi,jpj) , & 312 & ttbl(jpi,jpj) , stbl(jpi,jpj) , utbl(jpi,jpj) , & 313 & vtbl(jpi, jpj) , risfLeff(jpi,jpj) , rhisf_tbl_0(jpi,jpj), & 314 & ralpha(jpi,jpj) , misfkt(jpi,jpj) , misfkb(jpi,jpj) , & 317 315 & STAT= sbc_isf_alloc ) 318 316 ! … … 372 370 ! Calculate freezing temperature 373 371 zpress = grav*rau0*fsdept(ji,jj,ik)*1.e-04 374 zt_frz = eos_fzp(tsb(ji,jj,ik,jp_sal), zpress)372 CALL eos_fzp(tsb(ji,jj,ik,jp_sal), zt_frz, zpress) 375 373 zt_sum = zt_sum + (tsn(ji,jj,ik,jp_tem)-zt_frz) * fse3t(ji,jj,ik) * tmask(ji,jj,ik) ! sum temp 376 374 ENDDO … … 454 452 zti(:,:)=tinsitu( ttbl, stbl, zpress ) 455 453 ! Calculate freezing temperature 456 zfrz(:,:)=eos_fzp( sss_m(:,:), zpress )454 CALL eos_fzp( sss_m(:,:), zfrz(:,:), zpress ) 457 455 458 456 … … 563 561 CALL iom_put('isfgammat', zgammat2d) 564 562 CALL iom_put('isfgammas', zgammas2d) 565 ! 566 !CALL wrk_dealloc( jpi,jpj, zfrz,zpress,zti, zqisf, zfwfisf ) 563 ! 567 564 CALL wrk_dealloc( jpi,jpj, zfrz,zpress,zti, zgammat2d, zgammas2d ) 568 565 ! -
branches/2014/dev_r4621_NOC4_BDY_VERT_INTERP/NEMOGCM/NEMO/OPA_SRC/SBC/sbcmod.F90
r5038 r5620 13 13 !! 3.4 ! 2011-11 (C. Harris) CICE added as an option 14 14 !! 3.5 ! 2012-11 (A. Coward, G. Madec) Rethink of heat, mass and salt surface fluxes 15 !! 3.6 ! 2014-11 (P. Mathiot, C. Harris) add ice shelves melting 15 16 !!---------------------------------------------------------------------- 16 17 … … 23 24 USE phycst ! physical constants 24 25 USE sbc_oce ! Surface boundary condition: ocean fields 26 USE trc_oce ! shared ocean-passive tracers variables 25 27 USE sbc_ice ! Surface boundary condition: ice fields 26 28 USE sbcdcy ! surface boundary condition: diurnal cycle … … 37 39 USE sbcice_cice ! surface boundary condition: CICE sea-ice model 38 40 USE sbccpl ! surface boundary condition: coupled florulation 41 USE cpl_oasis3 ! OASIS routines for coupling 39 42 USE sbcssr ! surface boundary condition: sea surface restoring 40 43 USE sbcrnf ! surface boundary condition: runoffs … … 50 53 USE timing ! Timing 51 54 USE sbcwave ! Wave module 55 USE bdy_par ! Require lk_bdy 52 56 53 57 IMPLICIT NONE … … 82 86 INTEGER :: icpt ! local integer 83 87 !! 84 NAMELIST/namsbc/ nn_fsbc , ln_ana , ln_flx, ln_blk_clio, ln_blk_core, & 85 & ln_blk_mfs, ln_apr_dyn, nn_ice, nn_ice_embd, ln_dm2dc , ln_rnf, & 86 & ln_ssr , nn_isf , nn_fwb , ln_cdgw , ln_wave , ln_sdw, nn_lsm, nn_limflx 88 NAMELIST/namsbc/ nn_fsbc , ln_ana , ln_flx, ln_blk_clio, ln_blk_core, ln_mixcpl, & 89 & ln_blk_mfs, ln_apr_dyn, nn_ice, nn_ice_embd, ln_dm2dc , ln_rnf , & 90 & ln_ssr , nn_isf , nn_fwb, ln_cdgw , ln_wave , ln_sdw , & 91 & nn_lsm , nn_limflx , nn_components, ln_cpl 87 92 INTEGER :: ios 93 INTEGER :: ierr, ierr0, ierr1, ierr2, ierr3, jpm 94 LOGICAL :: ll_purecpl 88 95 !!---------------------------------------------------------------------- 89 96 … … 113 120 nn_ice = 0 114 121 ENDIF 115 122 116 123 IF(lwp) THEN ! Control print 117 124 WRITE(numout,*) ' Namelist namsbc (partly overwritten with CPP key setting)' … … 123 130 WRITE(numout,*) ' CORE bulk formulation ln_blk_core = ', ln_blk_core 124 131 WRITE(numout,*) ' MFS bulk formulation ln_blk_mfs = ', ln_blk_mfs 125 WRITE(numout,*) ' coupled formulation (T if key_oasis3) lk_cpl = ', lk_cpl 132 WRITE(numout,*) ' ocean-atmosphere coupled formulation ln_cpl = ', ln_cpl 133 WRITE(numout,*) ' forced-coupled mixed formulation ln_mixcpl = ', ln_mixcpl 134 WRITE(numout,*) ' OASIS coupling (with atm or sas) lk_oasis = ', lk_oasis 135 WRITE(numout,*) ' components of your executable nn_components = ', nn_components 126 136 WRITE(numout,*) ' Multicategory heat flux formulation (LIM3) nn_limflx = ', nn_limflx 127 137 WRITE(numout,*) ' Misc. options of sbc : ' … … 150 160 END SELECT 151 161 ! 152 #if defined key_top && ! defined key_offline 153 ltrcdm2dc = (ln_dm2dc .AND. ln_blk_core .AND. nn_ice==2) 154 IF( ltrcdm2dc )THEN 155 IF(lwp)THEN 156 WRITE(numout,*)"analytical diurnal cycle, core bulk formulation and LIM2 use: " 157 WRITE(numout,*)"Diurnal cycle on physics but not in passive tracers" 158 ENDIF 159 ENDIF 160 #else 161 ltrcdm2dc = .FALSE. 162 #endif 163 164 ! 162 IF ( nn_components /= jp_iam_nemo .AND. .NOT. lk_oasis ) & 163 & CALL ctl_stop( 'STOP', 'sbc_init : OPA-SAS coupled via OASIS, but key_oasis3 disabled' ) 164 IF ( nn_components == jp_iam_opa .AND. ln_cpl ) & 165 & CALL ctl_stop( 'STOP', 'sbc_init : OPA-SAS coupled via OASIS, but ln_cpl = T in OPA' ) 166 IF ( nn_components == jp_iam_opa .AND. ln_mixcpl ) & 167 & CALL ctl_stop( 'STOP', 'sbc_init : OPA-SAS coupled via OASIS, but ln_mixcpl = T in OPA' ) 168 IF ( ln_cpl .AND. .NOT. lk_oasis ) & 169 & CALL ctl_stop( 'STOP', 'sbc_init : OASIS-coupled atmosphere model, but key_oasis3 disabled' ) 170 IF( ln_mixcpl .AND. .NOT. lk_oasis ) & 171 & CALL ctl_stop( 'the forced-coupled mixed mode (ln_mixcpl) requires the cpp key key_oasis3' ) 172 IF( ln_mixcpl .AND. .NOT. ln_cpl ) & 173 & CALL ctl_stop( 'the forced-coupled mixed mode (ln_mixcpl) requires ln_cpl = T' ) 174 IF( ln_mixcpl .AND. nn_components /= jp_iam_nemo ) & 175 & CALL ctl_stop( 'the forced-coupled mixed mode (ln_mixcpl) is not yet working with sas-opa coupling via oasis' ) 176 165 177 ! ! allocate sbc arrays 166 178 IF( sbc_oce_alloc() /= 0 ) CALL ctl_stop( 'STOP', 'sbc_init : unable to allocate sbc_oce arrays' ) 167 179 168 180 ! ! Checks: 169 IF( .NOT. ln_rnf ) THEN ! no specific treatment in vicinity of river mouths 170 ln_rnf_mouth = .false. 171 IF( sbc_rnf_alloc() /= 0 ) CALL ctl_stop( 'STOP', 'sbc_init : unable to allocate sbc_rnf arrays' ) 172 nkrnf = 0 173 rnf (:,:) = 0.0_wp 174 rnf_b (:,:) = 0.0_wp 175 rnfmsk (:,:) = 0.0_wp 176 rnfmsk_z(:) = 0.0_wp 177 ENDIF 178 IF( nn_isf .EQ. 0 ) THEN ! no specific treatment in vicinity of ice shelf 181 IF( nn_isf .EQ. 0 ) THEN ! variable initialisation if no ice shelf 179 182 IF( sbc_isf_alloc() /= 0 ) CALL ctl_stop( 'STOP', 'sbc_init : unable to allocate sbc_isf arrays' ) 180 183 fwfisf (:,:) = 0.0_wp 184 fwfisf_b(:,:) = 0.0_wp 185 rdivisf = 0.0_wp 181 186 END IF 182 IF( nn_ice == 0 ) fr_i(:,:) = 0.e0! no ice in the domain, ice fraction is always zero187 IF( nn_ice == 0 .AND. nn_components /= jp_iam_opa ) fr_i(:,:) = 0.e0 ! no ice in the domain, ice fraction is always zero 183 188 184 189 sfx(:,:) = 0.0_wp ! the salt flux due to freezing/melting will be computed (i.e. will be non-zero) … … 190 195 191 196 ! ! restartability 192 IF( MOD( nitend - nit000 + 1, nn_fsbc) /= 0 .OR. & 193 MOD( nstock , nn_fsbc) /= 0 ) THEN 194 WRITE(ctmp1,*) 'experiment length (', nitend - nit000 + 1, ') or nstock (', nstock, & 195 & ' is NOT a multiple of nn_fsbc (', nn_fsbc, ')' 196 CALL ctl_stop( ctmp1, 'Impossible to properly do model restart' ) 197 ENDIF 198 ! 199 IF( MOD( rday, REAL(nn_fsbc, wp) * rdt ) /= 0 ) & 200 & CALL ctl_warn( 'nn_fsbc is NOT a multiple of the number of time steps in a day' ) 201 ! 202 IF( ( nn_ice == 2 .OR. nn_ice ==3 ) .AND. .NOT.( ln_blk_clio .OR. ln_blk_core .OR. lk_cpl ) ) & 197 IF( ( nn_ice == 2 .OR. nn_ice ==3 ) .AND. .NOT.( ln_blk_clio .OR. ln_blk_core .OR. ln_cpl ) ) & 203 198 & CALL ctl_stop( 'LIM sea-ice model requires a bulk formulation or coupled configuration' ) 204 IF( nn_ice == 4 .AND. .NOT.( ln_blk_core .OR. l k_cpl ) ) &205 & CALL ctl_stop( 'CICE sea-ice model requires ln_blk_core or l k_cpl' )199 IF( nn_ice == 4 .AND. .NOT.( ln_blk_core .OR. ln_cpl ) ) & 200 & CALL ctl_stop( 'CICE sea-ice model requires ln_blk_core or ln_cpl' ) 206 201 IF( nn_ice == 4 .AND. lk_agrif ) & 207 202 & CALL ctl_stop( 'CICE sea-ice model not currently available with AGRIF' ) … … 210 205 IF( ( nn_ice /= 3 ) .AND. ( nn_limflx >= 0 ) ) & 211 206 & WRITE(numout,*) 'The nn_limflx>=0 option has no effect if sea ice model is not LIM3' 212 IF( ( nn_ice == 3 ) .AND. ( l k_cpl ) .AND. ( ( nn_limflx == -1 ) .OR. ( nn_limflx == 1 ) ) ) &207 IF( ( nn_ice == 3 ) .AND. ( ln_cpl ) .AND. ( ( nn_limflx == -1 ) .OR. ( nn_limflx == 1 ) ) ) & 213 208 & CALL ctl_stop( 'The chosen nn_limflx for LIM3 in coupled mode must be 0 or 2' ) 214 IF( ( nn_ice == 3 ) .AND. ( .NOT. l k_cpl ) .AND. ( nn_limflx == 2 ) ) &209 IF( ( nn_ice == 3 ) .AND. ( .NOT. ln_cpl ) .AND. ( nn_limflx == 2 ) ) & 215 210 & CALL ctl_stop( 'The chosen nn_limflx for LIM3 in forced mode cannot be 2' ) 216 211 217 212 IF( ln_dm2dc ) nday_qsr = -1 ! initialisation flag 218 213 219 IF( ln_dm2dc .AND. .NOT.( ln_flx .OR. ln_blk_core ) ) &214 IF( ln_dm2dc .AND. .NOT.( ln_flx .OR. ln_blk_core ) .AND. nn_components /= jp_iam_opa ) & 220 215 & CALL ctl_stop( 'diurnal cycle into qsr field from daily values requires a flux or core-bulk formulation' ) 221 216 222 IF( ln_dm2dc .AND. ( ( NINT(rday) / ( nn_fsbc * NINT(rdt) ) ) < 8 ) ) &223 & CALL ctl_warn( 'diurnal cycle for qsr: the sampling of the diurnal cycle is too small...' )224 225 217 IF ( ln_wave ) THEN 226 218 !Activated wave module but neither drag nor stokes drift activated … … 236 228 & asked coupling with drag coefficient (ln_cdgw =T) or Stokes drift (ln_sdw=T) ') 237 229 ENDIF 238 239 230 ! ! Choice of the Surface Boudary Condition (set nsbc) 231 ll_purecpl = ln_cpl .AND. .NOT. ln_mixcpl 232 ! 240 233 icpt = 0 241 IF( ln_ana ) THEN ; nsbc = jp_ana ; icpt = icpt + 1 ; ENDIF ! analytical formulation 242 IF( ln_flx ) THEN ; nsbc = jp_flx ; icpt = icpt + 1 ; ENDIF ! flux formulation 243 IF( ln_blk_clio ) THEN ; nsbc = jp_clio ; icpt = icpt + 1 ; ENDIF ! CLIO bulk formulation 244 IF( ln_blk_core ) THEN ; nsbc = jp_core ; icpt = icpt + 1 ; ENDIF ! CORE bulk formulation 245 IF( ln_blk_mfs ) THEN ; nsbc = jp_mfs ; icpt = icpt + 1 ; ENDIF ! MFS bulk formulation 246 IF( lk_cpl ) THEN ; nsbc = jp_cpl ; icpt = icpt + 1 ; ENDIF ! Coupled formulation 247 IF( cp_cfg == 'gyre') THEN ; nsbc = jp_gyre ; ENDIF ! GYRE analytical formulation 248 IF( lk_esopa ) nsbc = jp_esopa ! esopa test, ALL formulations 234 IF( ln_ana ) THEN ; nsbc = jp_ana ; icpt = icpt + 1 ; ENDIF ! analytical formulation 235 IF( ln_flx ) THEN ; nsbc = jp_flx ; icpt = icpt + 1 ; ENDIF ! flux formulation 236 IF( ln_blk_clio ) THEN ; nsbc = jp_clio ; icpt = icpt + 1 ; ENDIF ! CLIO bulk formulation 237 IF( ln_blk_core ) THEN ; nsbc = jp_core ; icpt = icpt + 1 ; ENDIF ! CORE bulk formulation 238 IF( ln_blk_mfs ) THEN ; nsbc = jp_mfs ; icpt = icpt + 1 ; ENDIF ! MFS bulk formulation 239 IF( ll_purecpl ) THEN ; nsbc = jp_purecpl ; icpt = icpt + 1 ; ENDIF ! Pure Coupled formulation 240 IF( cp_cfg == 'gyre') THEN ; nsbc = jp_gyre ; ENDIF ! GYRE analytical formulation 241 IF( nn_components == jp_iam_opa ) & 242 & THEN ; nsbc = jp_none ; icpt = icpt + 1 ; ENDIF ! opa coupling via SAS module 243 IF( lk_esopa ) nsbc = jp_esopa ! esopa test, ALL formulations 249 244 ! 250 245 IF( icpt /= 1 .AND. .NOT.lk_esopa ) THEN … … 257 252 IF(lwp) THEN 258 253 WRITE(numout,*) 259 IF( nsbc == jp_esopa ) WRITE(numout,*) ' ESOPA test All surface boundary conditions' 260 IF( nsbc == jp_gyre ) WRITE(numout,*) ' GYRE analytical formulation' 261 IF( nsbc == jp_ana ) WRITE(numout,*) ' analytical formulation' 262 IF( nsbc == jp_flx ) WRITE(numout,*) ' flux formulation' 263 IF( nsbc == jp_clio ) WRITE(numout,*) ' CLIO bulk formulation' 264 IF( nsbc == jp_core ) WRITE(numout,*) ' CORE bulk formulation' 265 IF( nsbc == jp_cpl ) WRITE(numout,*) ' coupled formulation' 266 IF( nsbc == jp_mfs ) WRITE(numout,*) ' MFS Bulk formulation' 267 ENDIF 268 ! 254 IF( nsbc == jp_esopa ) WRITE(numout,*) ' ESOPA test All surface boundary conditions' 255 IF( nsbc == jp_gyre ) WRITE(numout,*) ' GYRE analytical formulation' 256 IF( nsbc == jp_ana ) WRITE(numout,*) ' analytical formulation' 257 IF( nsbc == jp_flx ) WRITE(numout,*) ' flux formulation' 258 IF( nsbc == jp_clio ) WRITE(numout,*) ' CLIO bulk formulation' 259 IF( nsbc == jp_core ) WRITE(numout,*) ' CORE bulk formulation' 260 IF( nsbc == jp_purecpl ) WRITE(numout,*) ' pure coupled formulation' 261 IF( nsbc == jp_mfs ) WRITE(numout,*) ' MFS Bulk formulation' 262 IF( nsbc == jp_none ) WRITE(numout,*) ' OPA coupled to SAS via oasis' 263 IF( ln_mixcpl ) WRITE(numout,*) ' + forced-coupled mixed formulation' 264 IF( nn_components/= jp_iam_nemo ) & 265 & WRITE(numout,*) ' + OASIS coupled SAS' 266 ENDIF 267 ! 268 IF( lk_oasis ) CALL sbc_cpl_init (nn_ice) ! OASIS initialisation. must be done before: (1) first time step 269 ! ! (2) the use of nn_fsbc 270 271 ! nn_fsbc initialization if OPA-SAS coupling via OASIS 272 ! sas model time step has to be declared in OASIS (mandatory) -> nn_fsbc has to be modified accordingly 273 IF ( nn_components /= jp_iam_nemo ) THEN 274 275 IF ( nn_components == jp_iam_opa ) nn_fsbc = cpl_freq('O_SFLX') / NINT(rdt) 276 IF ( nn_components == jp_iam_sas ) nn_fsbc = cpl_freq('I_SFLX') / NINT(rdt) 277 ! 278 IF(lwp)THEN 279 WRITE(numout,*) 280 WRITE(numout,*)" OPA-SAS coupled via OASIS : nn_fsbc re-defined from OASIS namcouple ", nn_fsbc 281 WRITE(numout,*) 282 ENDIF 283 ENDIF 284 285 IF( MOD( nitend - nit000 + 1, nn_fsbc) /= 0 .OR. & 286 MOD( nstock , nn_fsbc) /= 0 ) THEN 287 WRITE(ctmp1,*) 'experiment length (', nitend - nit000 + 1, ') or nstock (', nstock, & 288 & ' is NOT a multiple of nn_fsbc (', nn_fsbc, ')' 289 CALL ctl_stop( ctmp1, 'Impossible to properly do model restart' ) 290 ENDIF 291 ! 292 IF( MOD( rday, REAL(nn_fsbc, wp) * rdt ) /= 0 ) & 293 & CALL ctl_warn( 'nn_fsbc is NOT a multiple of the number of time steps in a day' ) 294 ! 295 IF( ln_dm2dc .AND. ( ( NINT(rday) / ( nn_fsbc * NINT(rdt) ) ) < 8 ) ) & 296 & CALL ctl_warn( 'diurnal cycle for qsr: the sampling of the diurnal cycle is too small...' ) 297 269 298 CALL sbc_ssm_init ! Sea-surface mean fields initialisation 270 299 ! 271 300 IF( ln_ssr ) CALL sbc_ssr_init ! Sea-Surface Restoring initialisation 272 301 ! 302 CALL sbc_rnf_init ! Runof initialisation 303 ! 304 IF( nn_ice == 3 ) CALL sbc_lim_init ! LIM3 initialisation 305 273 306 IF( nn_ice == 4 ) CALL cice_sbc_init( nsbc ) ! CICE initialisation 274 ! 275 IF( nsbc == jp_cpl ) CALL sbc_cpl_init (nn_ice) ! OASIS initialisation. must be done before first time step 276 307 277 308 END SUBROUTINE sbc_init 278 309 … … 314 345 ! ! ---------------------------------------- ! 315 346 ! 316 IF( ln_apr_dyn ) CALL sbc_apr( kt ) ! atmospheric pressure provided at kt+0.5*nn_fsbc 347 IF ( .NOT. lk_bdy ) then 348 IF( ln_apr_dyn ) CALL sbc_apr( kt ) ! atmospheric pressure provided at kt+0.5*nn_fsbc 349 ENDIF 317 350 ! (caution called before sbc_ssm) 318 351 ! 319 CALL sbc_ssm( kt )! ocean sea surface variables (sst_m, sss_m, ssu_m, ssv_m)320 ! ! averaged over nf_sbc time-step352 IF( nn_components /= jp_iam_sas ) CALL sbc_ssm( kt ) ! ocean sea surface variables (sst_m, sss_m, ssu_m, ssv_m) 353 ! ! averaged over nf_sbc time-step 321 354 322 355 IF (ln_wave) CALL sbc_wave( kt ) … … 329 362 CASE( jp_flx ) ; CALL sbc_flx ( kt ) ! flux formulation 330 363 CASE( jp_clio ) ; CALL sbc_blk_clio( kt ) ! bulk formulation : CLIO for the ocean 331 CASE( jp_core ) ; CALL sbc_blk_core( kt ) ! bulk formulation : CORE for the ocean 332 CASE( jp_cpl ) ; CALL sbc_cpl_rcv ( kt, nn_fsbc, nn_ice ) ! coupled formulation 364 CASE( jp_core ) 365 IF( nn_components == jp_iam_sas ) & 366 & CALL sbc_cpl_rcv ( kt, nn_fsbc, nn_ice ) ! OPA-SAS coupling: SAS receiving fields from OPA 367 CALL sbc_blk_core( kt ) ! bulk formulation : CORE for the ocean 368 ! from oce: sea surface variables (sst_m, sss_m, ssu_m, ssv_m) 369 CASE( jp_purecpl ) ; CALL sbc_cpl_rcv ( kt, nn_fsbc, nn_ice ) ! pure coupled formulation 370 ! 333 371 CASE( jp_mfs ) ; CALL sbc_blk_mfs ( kt ) ! bulk formulation : MFS for the ocean 372 CASE( jp_none ) 373 IF( nn_components == jp_iam_opa ) & 374 CALL sbc_cpl_rcv ( kt, nn_fsbc, nn_ice ) ! OPA-SAS coupling: OPA receiving fields from SAS 334 375 CASE( jp_esopa ) 335 376 CALL sbc_ana ( kt ) ! ESOPA, test ALL the formulations … … 341 382 END SELECT 342 383 384 IF( ln_mixcpl ) CALL sbc_cpl_rcv ( kt, nn_fsbc, nn_ice ) ! forced-coupled mixed formulation after forcing 385 386 343 387 ! !== Misc. Options ==! 344 388 … … 363 407 ! ! (update freshwater fluxes) 364 408 !RBbug do not understand why see ticket 667 365 !clem-bugsal CALL lbc_lnk( emp, 'T', 1. ) 409 !clem: it looks like it is necessary for the north fold (in certain circumstances). Don't know why. 410 CALL lbc_lnk( emp, 'T', 1. ) 366 411 ! 367 412 IF( kt == nit000 ) THEN ! set the forcing field at nit000 - 1 ! … … 404 449 ! CALL iom_rstput( kt, nitrst, numrow, 'qsr_b' , qsr ) 405 450 CALL iom_rstput( kt, nitrst, numrow, 'emp_b' , emp ) 406 CALL iom_rstput( kt, nitrst, numrow, 'sfx_b' , sfx)451 CALL iom_rstput( kt, nitrst, numrow, 'sfx_b' , sfx ) 407 452 ENDIF 408 453 … … 419 464 CALL iom_put( "qns" , qns ) ! solar heat flux 420 465 CALL iom_put( "qsr" , qsr ) ! solar heat flux 421 IF( nn_ice > 0 ) CALL iom_put( "ice_cover", fr_i ) ! ice fraction466 IF( nn_ice > 0 .OR. nn_components == jp_iam_opa ) CALL iom_put( "ice_cover", fr_i ) ! ice fraction 422 467 CALL iom_put( "taum" , taum ) ! wind stress module 423 468 CALL iom_put( "wspd" , wndm ) ! wind speed module over free ocean or leads in presence of sea-ice -
branches/2014/dev_r4621_NOC4_BDY_VERT_INTERP/NEMOGCM/NEMO/OPA_SRC/SBC/sbcrnf.F90
r5038 r5620 32 32 33 33 PUBLIC sbc_rnf ! routine call in sbcmod module 34 PUBLIC sbc_rnf_div ! routine called in sshwzvmodule34 PUBLIC sbc_rnf_div ! routine called in divcurl module 35 35 PUBLIC sbc_rnf_alloc ! routine call in sbcmod module 36 36 PUBLIC sbc_rnf_init ! (PUBLIC for TAM) 37 37 ! !!* namsbc_rnf namelist * 38 CHARACTER(len=100), PUBLIC :: cn_dir !: Root directory for location of ssr files 39 LOGICAL , PUBLIC :: ln_rnf_depth !: depth river runoffs attribute specified in a file 40 LOGICAL , PUBLIC :: ln_rnf_tem !: temperature river runoffs attribute specified in a file 38 CHARACTER(len=100) :: cn_dir !: Root directory for location of rnf files 39 LOGICAL :: ln_rnf_depth !: depth river runoffs attribute specified in a file 40 LOGICAL :: ln_rnf_depth_ini !: depth river runoffs computed at the initialisation 41 REAL(wp) :: rn_rnf_max !: maximum value of the runoff climatologie ( ln_rnf_depth_ini = .true ) 42 REAL(wp) :: rn_dep_max !: depth over which runoffs is spread ( ln_rnf_depth_ini = .true ) 43 INTEGER :: nn_rnf_depth_file !: create (=1) a runoff depth file or not (=0) 44 LOGICAL :: ln_rnf_tem !: temperature river runoffs attribute specified in a file 41 45 LOGICAL , PUBLIC :: ln_rnf_sal !: salinity river runoffs attribute specified in a file 42 LOGICAL , PUBLIC :: ln_rnf_emp !: runoffs into a file to be read or already into precipitation43 46 TYPE(FLD_N) , PUBLIC :: sn_rnf !: information about the runoff file to be read 44 TYPE(FLD_N) , PUBLIC:: sn_cnf !: information about the runoff mouth file to be read47 TYPE(FLD_N) :: sn_cnf !: information about the runoff mouth file to be read 45 48 TYPE(FLD_N) :: sn_s_rnf !: information about the salinities of runoff file to be read 46 49 TYPE(FLD_N) :: sn_t_rnf !: information about the temperatures of runoff file to be read 47 50 TYPE(FLD_N) :: sn_dep_rnf !: information about the depth which river inflow affects 48 51 LOGICAL , PUBLIC :: ln_rnf_mouth !: specific treatment in mouths vicinity 49 REAL(wp) , PUBLIC:: rn_hrnf !: runoffs, depth over which enhanced vertical mixing is used52 REAL(wp) :: rn_hrnf !: runoffs, depth over which enhanced vertical mixing is used 50 53 REAL(wp) , PUBLIC :: rn_avt_rnf !: runoffs, value of the additional vertical mixing coef. [m2/s] 51 REAL(wp) , PUBLIC :: rn_rfact !: multiplicative factor for runoff 54 REAL(wp) :: rn_rfact !: multiplicative factor for runoff 55 56 LOGICAL , PUBLIC :: l_rnfcpl = .false. ! runoffs recieved from oasis 52 57 53 58 INTEGER , PUBLIC :: nkrnf = 0 !: nb of levels over which Kz is increased at river mouths … … 58 63 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: rnf_tsc_b, rnf_tsc !: before and now T & S runoff contents [K.m/s & PSU.m/s] 59 64 60 TYPE(FLD), PUBLIC,ALLOCATABLE, DIMENSION(:) :: sf_rnf ! structure: river runoff (file information, fields read)61 TYPE(FLD), PUBLIC,ALLOCATABLE, DIMENSION(:) :: sf_s_rnf ! structure: river runoff salinity (file information, fields read)62 TYPE(FLD), PUBLIC,ALLOCATABLE, DIMENSION(:) :: sf_t_rnf ! structure: river runoff temperature (file information, fields read)65 TYPE(FLD), ALLOCATABLE, DIMENSION(:) :: sf_rnf ! structure: river runoff (file information, fields read) 66 TYPE(FLD), ALLOCATABLE, DIMENSION(:) :: sf_s_rnf ! structure: river runoff salinity (file information, fields read) 67 TYPE(FLD), ALLOCATABLE, DIMENSION(:) :: sf_t_rnf ! structure: river runoff temperature (file information, fields read) 63 68 64 69 !! * Substitutions … … 105 110 CALL wrk_alloc( jpi,jpj, ztfrz) 106 111 107 !108 IF( kt == nit000 ) CALL sbc_rnf_init ! Read namelist and allocate structures109 110 112 ! ! ---------------------------------------- ! 111 113 IF( kt /= nit000 ) THEN ! Swap of forcing fields ! … … 116 118 ENDIF 117 119 118 ! !-------------------! 119 IF( .NOT. ln_rnf_emp ) THEN ! Update runoff ! 120 ! !-------------------! 121 ! 122 CALL fld_read ( kt, nn_fsbc, sf_rnf ) ! Read Runoffs data and provide it at kt 123 IF( ln_rnf_tem ) CALL fld_read ( kt, nn_fsbc, sf_t_rnf ) ! idem for runoffs temperature if required 124 IF( ln_rnf_sal ) CALL fld_read ( kt, nn_fsbc, sf_s_rnf ) ! idem for runoffs salinity if required 125 ! 126 ! Runoff reduction only associated to the ORCA2_LIM configuration 127 ! when reading the NetCDF file runoff_1m_nomask.nc 128 IF( cp_cfg == 'orca' .AND. jp_cfg == 2 ) THEN 129 WHERE( 40._wp < gphit(:,:) .AND. gphit(:,:) < 65._wp ) 130 sf_rnf(1)%fnow(:,:,1) = 0.85 * sf_rnf(1)%fnow(:,:,1) 120 ! !-------------------! 121 ! ! Update runoff ! 122 ! !-------------------! 123 ! 124 IF( .NOT. l_rnfcpl ) CALL fld_read ( kt, nn_fsbc, sf_rnf ) ! Read Runoffs data and provide it at kt 125 IF( ln_rnf_tem ) CALL fld_read ( kt, nn_fsbc, sf_t_rnf ) ! idem for runoffs temperature if required 126 IF( ln_rnf_sal ) CALL fld_read ( kt, nn_fsbc, sf_s_rnf ) ! idem for runoffs salinity if required 127 ! 128 ! Runoff reduction only associated to the ORCA2_LIM configuration 129 ! when reading the NetCDF file runoff_1m_nomask.nc 130 IF( cp_cfg == 'orca' .AND. jp_cfg == 2 .AND. .NOT. l_rnfcpl ) THEN 131 WHERE( 40._wp < gphit(:,:) .AND. gphit(:,:) < 65._wp ) 132 sf_rnf(1)%fnow(:,:,1) = 0.85 * sf_rnf(1)%fnow(:,:,1) 133 END WHERE 134 ENDIF 135 ! 136 IF( MOD( kt - 1, nn_fsbc ) == 0 ) THEN 137 ! 138 IF( .NOT. l_rnfcpl ) rnf(:,:) = rn_rfact * ( sf_rnf(1)%fnow(:,:,1) ) ! updated runoff value at time step kt 139 ! 140 ! ! set temperature & salinity content of runoffs 141 IF( ln_rnf_tem ) THEN ! use runoffs temperature data 142 rnf_tsc(:,:,jp_tem) = ( sf_t_rnf(1)%fnow(:,:,1) ) * rnf(:,:) * r1_rau0 143 WHERE( sf_t_rnf(1)%fnow(:,:,1) == -999._wp ) ! if missing data value use SST as runoffs temperature 144 rnf_tsc(:,:,jp_tem) = sst_m(:,:) * rnf(:,:) * r1_rau0 131 145 END WHERE 132 ENDIF 133 ! 134 IF( MOD( kt - 1, nn_fsbc ) == 0 ) THEN 135 ! 136 rnf(:,:) = rn_rfact * ( sf_rnf(1)%fnow(:,:,1) ) ! updated runoff value at time step kt 137 ! 138 ! ! set temperature & salinity content of runoffs 139 IF( ln_rnf_tem ) THEN ! use runoffs temperature data 140 rnf_tsc(:,:,jp_tem) = ( sf_t_rnf(1)%fnow(:,:,1) ) * rnf(:,:) * r1_rau0 141 WHERE( sf_t_rnf(1)%fnow(:,:,1) == -999._wp ) ! if missing data value use SST as runoffs temperature 142 rnf_tsc(:,:,jp_tem) = sst_m(:,:) * rnf(:,:) * r1_rau0 143 END WHERE 144 WHERE( sf_t_rnf(1)%fnow(:,:,1) == -222._wp ) ! where fwf comes from melting of ice shelves or iceberg 145 ztfrz(:,:) = -1.9 !tfreez( sss_m(:,:) ) !PM to be discuss (trouble if sensitivity study) 146 rnf_tsc(:,:,jp_tem) = ztfrz(:,:) * rnf(:,:) * r1_rau0 - rnf(:,:) * lfusisf * r1_rau0_rcp 147 END WHERE 148 ELSE ! use SST as runoffs temperature 149 rnf_tsc(:,:,jp_tem) = sst_m(:,:) * rnf(:,:) * r1_rau0 150 ENDIF 151 ! ! use runoffs salinity data 152 IF( ln_rnf_sal ) rnf_tsc(:,:,jp_sal) = ( sf_s_rnf(1)%fnow(:,:,1) ) * rnf(:,:) * r1_rau0 153 ! ! else use S=0 for runoffs (done one for all in the init) 154 IF ( ANY( rnf(:,:) < 0._wp ) ) z_err=1 155 IF(lk_mpp) CALL mpp_sum(z_err) 156 IF( z_err > 0 ) CALL ctl_stop( 'sbc_rnf : negative runnoff values exist' ) 157 ! 158 CALL iom_put( "runoffs", rnf ) ! output runoffs arrays 159 ENDIF 160 ! 161 ENDIF 162 ! 146 WHERE( sf_t_rnf(1)%fnow(:,:,1) == -222._wp ) ! where fwf comes from melting of ice shelves or iceberg 147 ztfrz(:,:) = -1.9 !tfreez( sss_m(:,:) ) !PM to be discuss (trouble if sensitivity study) 148 rnf_tsc(:,:,jp_tem) = ztfrz(:,:) * rnf(:,:) * r1_rau0 - rnf(:,:) * lfusisf * r1_rau0_rcp 149 END WHERE 150 ELSE ! use SST as runoffs temperature 151 rnf_tsc(:,:,jp_tem) = sst_m(:,:) * rnf(:,:) * r1_rau0 152 ENDIF 153 ! ! use runoffs salinity data 154 IF( ln_rnf_sal ) rnf_tsc(:,:,jp_sal) = ( sf_s_rnf(1)%fnow(:,:,1) ) * rnf(:,:) * r1_rau0 155 ! ! else use S=0 for runoffs (done one for all in the init) 156 CALL iom_put( "runoffs", rnf ) ! output runoffs arrays 157 ENDIF 158 ! 159 ! ! ---------------------------------------- ! 163 160 IF( kt == nit000 ) THEN ! set the forcing field at nit000 - 1 ! 164 161 ! ! ---------------------------------------- ! … … 171 168 ELSE !* no restart: set from nit000 values 172 169 IF(lwp) WRITE(numout,*) ' nit000-1 runoff forcing fields set to nit000' 173 174 170 rnf_b (:,: ) = rnf (:,: ) 171 rnf_tsc_b(:,:,:) = rnf_tsc(:,:,:) 175 172 ENDIF 176 173 ENDIF … … 186 183 CALL iom_rstput( kt, nitrst, numrow, 'rnf_sc_b', rnf_tsc(:,:,jp_sal) ) 187 184 ENDIF 185 ! 188 186 CALL wrk_dealloc( jpi,jpj, ztfrz) 189 187 ! … … 211 209 zfact = 0.5_wp 212 210 ! 213 IF( ln_rnf_depth ) THEN !== runoff distributed over several levels ==!211 IF( ln_rnf_depth .OR. ln_rnf_depth_ini ) THEN !== runoff distributed over several levels ==! 214 212 IF( lk_vvl ) THEN ! variable volume case 215 213 DO jj = 1, jpj ! update the depth over which runoffs are distributed … … 255 253 !!---------------------------------------------------------------------- 256 254 CHARACTER(len=32) :: rn_dep_file ! runoff file name 257 INTEGER :: ji, jj, jk ! dummy loop indices255 INTEGER :: ji, jj, jk, jm ! dummy loop indices 258 256 INTEGER :: ierror, inum ! temporary integer 259 257 INTEGER :: ios ! Local integer output status for namelist read 260 ! 261 NAMELIST/namsbc_rnf/ cn_dir, ln_rnf_emp, ln_rnf_depth, ln_rnf_tem, ln_rnf_sal, & 258 INTEGER :: nbrec ! temporary integer 259 REAL(wp) :: zacoef 260 REAL(wp), DIMENSION(12) :: zrec ! times records 261 REAL(wp), DIMENSION(:,:,:), ALLOCATABLE :: zrnfcl 262 REAL(wp), DIMENSION(:,: ), ALLOCATABLE :: zrnf 263 ! 264 NAMELIST/namsbc_rnf/ cn_dir , ln_rnf_depth, ln_rnf_tem, ln_rnf_sal, & 262 265 & sn_rnf, sn_cnf , sn_s_rnf , sn_t_rnf , sn_dep_rnf, & 263 & ln_rnf_mouth , rn_hrnf , rn_avt_rnf, rn_rfact 264 !!---------------------------------------------------------------------- 266 & ln_rnf_mouth , rn_hrnf , rn_avt_rnf, rn_rfact, & 267 & ln_rnf_depth_ini , rn_dep_max , rn_rnf_max, nn_rnf_depth_file 268 !!---------------------------------------------------------------------- 269 ! 270 ! !== allocate runoff arrays 271 IF( sbc_rnf_alloc() /= 0 ) CALL ctl_stop( 'STOP', 'sbc_rnf_alloc : unable to allocate arrays' ) 272 ! 273 IF( .NOT. ln_rnf ) THEN ! no specific treatment in vicinity of river mouths 274 ln_rnf_mouth = .FALSE. ! default definition needed for example by sbc_ssr or by tra_adv_muscl 275 nkrnf = 0 276 rnf (:,:) = 0.0_wp 277 rnf_b (:,:) = 0.0_wp 278 rnfmsk (:,:) = 0.0_wp 279 rnfmsk_z(:) = 0.0_wp 280 RETURN 281 ENDIF 265 282 ! 266 283 ! ! ============ … … 283 300 WRITE(numout,*) '~~~~~~~ ' 284 301 WRITE(numout,*) ' Namelist namsbc_rnf' 285 WRITE(numout,*) ' runoff in a file to be read ln_rnf_emp = ', ln_rnf_emp286 302 WRITE(numout,*) ' specific river mouths treatment ln_rnf_mouth = ', ln_rnf_mouth 287 303 WRITE(numout,*) ' river mouth additional Kz rn_avt_rnf = ', rn_avt_rnf … … 289 305 WRITE(numout,*) ' multiplicative factor for runoff rn_rfact = ', rn_rfact 290 306 ENDIF 291 !292 307 ! ! ================== 293 308 ! ! Type of runoff 294 309 ! ! ================== 295 ! !== allocate runoff arrays 296 IF( sbc_rnf_alloc() /= 0 ) CALL ctl_stop( 'STOP', 'sbc_rnf_alloc : unable to allocate arrays' ) 297 ! 298 IF( ln_rnf_emp ) THEN !== runoffs directly provided in the precipitations ==! 299 IF(lwp) WRITE(numout,*) 300 IF(lwp) WRITE(numout,*) ' runoffs directly provided in the precipitations' 301 IF( ln_rnf_depth .OR. ln_rnf_tem .OR. ln_rnf_sal ) THEN 302 CALL ctl_warn( 'runoffs already included in precipitations, so runoff (T,S, depth) attributes will not be used' ) 303 ln_rnf_depth = .FALSE. ; ln_rnf_tem = .FALSE. ; ln_rnf_sal = .FALSE. 304 ENDIF 305 ! 306 ELSE !== runoffs read in a file : set sf_rnf structure ==! 307 ! 310 ! 311 IF( .NOT. l_rnfcpl ) THEN 308 312 ALLOCATE( sf_rnf(1), STAT=ierror ) ! Create sf_rnf structure (runoff inflow) 309 313 IF(lwp) WRITE(numout,*) … … 314 318 ALLOCATE( sf_rnf(1)%fnow(jpi,jpj,1) ) 315 319 IF( sn_rnf%ln_tint ) ALLOCATE( sf_rnf(1)%fdta(jpi,jpj,1,2) ) 316 ! ! fill sf_rnf with the namelist (sn_rnf) and control print317 320 CALL fld_fill( sf_rnf, (/ sn_rnf /), cn_dir, 'sbc_rnf_init', 'read runoffs data', 'namsbc_rnf' ) 318 ! 319 IF( ln_rnf_tem ) THEN ! Create (if required) sf_t_rnf structure 320 IF(lwp) WRITE(numout,*) 321 IF(lwp) WRITE(numout,*) ' runoffs temperatures read in a file' 322 ALLOCATE( sf_t_rnf(1), STAT=ierror ) 323 IF( ierror > 0 ) THEN 324 CALL ctl_stop( 'sbc_rnf_init: unable to allocate sf_t_rnf structure' ) ; RETURN 325 ENDIF 326 ALLOCATE( sf_t_rnf(1)%fnow(jpi,jpj,1) ) 327 IF( sn_t_rnf%ln_tint ) ALLOCATE( sf_t_rnf(1)%fdta(jpi,jpj,1,2) ) 328 CALL fld_fill (sf_t_rnf, (/ sn_t_rnf /), cn_dir, 'sbc_rnf_init', 'read runoff temperature data', 'namsbc_rnf' ) 329 ENDIF 330 ! 331 IF( ln_rnf_sal ) THEN ! Create (if required) sf_s_rnf and sf_t_rnf structures 332 IF(lwp) WRITE(numout,*) 333 IF(lwp) WRITE(numout,*) ' runoffs salinities read in a file' 334 ALLOCATE( sf_s_rnf(1), STAT=ierror ) 335 IF( ierror > 0 ) THEN 336 CALL ctl_stop( 'sbc_rnf_init: unable to allocate sf_s_rnf structure' ) ; RETURN 337 ENDIF 338 ALLOCATE( sf_s_rnf(1)%fnow(jpi,jpj,1) ) 339 IF( sn_s_rnf%ln_tint ) ALLOCATE( sf_s_rnf(1)%fdta(jpi,jpj,1,2) ) 340 CALL fld_fill (sf_s_rnf, (/ sn_s_rnf /), cn_dir, 'sbc_rnf_init', 'read runoff salinity data', 'namsbc_rnf' ) 341 ENDIF 342 ! 343 IF( ln_rnf_depth ) THEN ! depth of runoffs set from a file 344 IF(lwp) WRITE(numout,*) 345 IF(lwp) WRITE(numout,*) ' runoffs depth read in a file' 346 rn_dep_file = TRIM( cn_dir )//TRIM( sn_dep_rnf%clname ) 347 IF( .NOT. sn_dep_rnf%ln_clim ) THEN ; WRITE(rn_dep_file, '(a,"_y",i4)' ) TRIM( rn_dep_file ), nyear ! add year 348 IF( sn_dep_rnf%cltype == 'monthly' ) WRITE(rn_dep_file, '(a,"m",i2)' ) TRIM( rn_dep_file ), nmonth ! add month 349 ENDIF 350 CALL iom_open ( rn_dep_file, inum ) ! open file 351 CALL iom_get ( inum, jpdom_data, sn_dep_rnf%clvar, h_rnf ) ! read the river mouth array 352 CALL iom_close( inum ) ! close file 353 ! 354 nk_rnf(:,:) = 0 ! set the number of level over which river runoffs are applied 355 DO jj = 1, jpj 356 DO ji = 1, jpi 357 IF( h_rnf(ji,jj) > 0._wp ) THEN 358 jk = 2 359 DO WHILE ( jk /= mbkt(ji,jj) .AND. gdept_0(ji,jj,jk) < h_rnf(ji,jj) ) ; jk = jk + 1 ; END DO 360 nk_rnf(ji,jj) = jk 361 ELSEIF( h_rnf(ji,jj) == -1._wp ) THEN ; nk_rnf(ji,jj) = 1 362 ELSEIF( h_rnf(ji,jj) == -999._wp ) THEN ; nk_rnf(ji,jj) = mbkt(ji,jj) 363 ELSE 364 CALL ctl_stop( 'sbc_rnf_init: runoff depth not positive, and not -999 or -1, rnf value in file fort.999' ) 365 WRITE(999,*) 'ji, jj, h_rnf(ji,jj) :', ji, jj, h_rnf(ji,jj) 366 ENDIF 321 ENDIF 322 ! 323 IF( ln_rnf_tem ) THEN ! Create (if required) sf_t_rnf structure 324 IF(lwp) WRITE(numout,*) 325 IF(lwp) WRITE(numout,*) ' runoffs temperatures read in a file' 326 ALLOCATE( sf_t_rnf(1), STAT=ierror ) 327 IF( ierror > 0 ) THEN 328 CALL ctl_stop( 'sbc_rnf_init: unable to allocate sf_t_rnf structure' ) ; RETURN 329 ENDIF 330 ALLOCATE( sf_t_rnf(1)%fnow(jpi,jpj,1) ) 331 IF( sn_t_rnf%ln_tint ) ALLOCATE( sf_t_rnf(1)%fdta(jpi,jpj,1,2) ) 332 CALL fld_fill (sf_t_rnf, (/ sn_t_rnf /), cn_dir, 'sbc_rnf_init', 'read runoff temperature data', 'namsbc_rnf' ) 333 ENDIF 334 ! 335 IF( ln_rnf_sal ) THEN ! Create (if required) sf_s_rnf and sf_t_rnf structures 336 IF(lwp) WRITE(numout,*) 337 IF(lwp) WRITE(numout,*) ' runoffs salinities read in a file' 338 ALLOCATE( sf_s_rnf(1), STAT=ierror ) 339 IF( ierror > 0 ) THEN 340 CALL ctl_stop( 'sbc_rnf_init: unable to allocate sf_s_rnf structure' ) ; RETURN 341 ENDIF 342 ALLOCATE( sf_s_rnf(1)%fnow(jpi,jpj,1) ) 343 IF( sn_s_rnf%ln_tint ) ALLOCATE( sf_s_rnf(1)%fdta(jpi,jpj,1,2) ) 344 CALL fld_fill (sf_s_rnf, (/ sn_s_rnf /), cn_dir, 'sbc_rnf_init', 'read runoff salinity data', 'namsbc_rnf' ) 345 ENDIF 346 ! 347 IF( ln_rnf_depth ) THEN ! depth of runoffs set from a file 348 IF(lwp) WRITE(numout,*) 349 IF(lwp) WRITE(numout,*) ' runoffs depth read in a file' 350 rn_dep_file = TRIM( cn_dir )//TRIM( sn_dep_rnf%clname ) 351 IF( .NOT. sn_dep_rnf%ln_clim ) THEN ; WRITE(rn_dep_file, '(a,"_y",i4)' ) TRIM( rn_dep_file ), nyear ! add year 352 IF( sn_dep_rnf%cltype == 'monthly' ) WRITE(rn_dep_file, '(a,"m",i2)' ) TRIM( rn_dep_file ), nmonth ! add month 353 ENDIF 354 CALL iom_open ( rn_dep_file, inum ) ! open file 355 CALL iom_get ( inum, jpdom_data, sn_dep_rnf%clvar, h_rnf ) ! read the river mouth array 356 CALL iom_close( inum ) ! close file 357 ! 358 nk_rnf(:,:) = 0 ! set the number of level over which river runoffs are applied 359 DO jj = 1, jpj 360 DO ji = 1, jpi 361 IF( h_rnf(ji,jj) > 0._wp ) THEN 362 jk = 2 363 DO WHILE ( jk /= mbkt(ji,jj) .AND. gdept_0(ji,jj,jk) < h_rnf(ji,jj) ) ; jk = jk + 1 364 END DO 365 nk_rnf(ji,jj) = jk 366 ELSEIF( h_rnf(ji,jj) == -1._wp ) THEN ; nk_rnf(ji,jj) = 1 367 ELSEIF( h_rnf(ji,jj) == -999._wp ) THEN ; nk_rnf(ji,jj) = mbkt(ji,jj) 368 ELSE 369 CALL ctl_stop( 'sbc_rnf_init: runoff depth not positive, and not -999 or -1, rnf value in file fort.999' ) 370 WRITE(999,*) 'ji, jj, h_rnf(ji,jj) :', ji, jj, h_rnf(ji,jj) 371 ENDIF 372 END DO 373 END DO 374 DO jj = 1, jpj ! set the associated depth 375 DO ji = 1, jpi 376 h_rnf(ji,jj) = 0._wp 377 DO jk = 1, nk_rnf(ji,jj) 378 h_rnf(ji,jj) = h_rnf(ji,jj) + fse3t(ji,jj,jk) 367 379 END DO 368 380 END DO 369 DO jj = 1, jpj ! set the associated depth 370 DO ji = 1, jpi 371 h_rnf(ji,jj) = 0._wp 372 DO jk = 1, nk_rnf(ji,jj) 373 h_rnf(ji,jj) = h_rnf(ji,jj) + fse3t(ji,jj,jk) 381 END DO 382 ! 383 ELSE IF( ln_rnf_depth_ini ) THEN ! runoffs applied at the surface 384 ! 385 IF(lwp) WRITE(numout,*) 386 IF(lwp) WRITE(numout,*) ' depth of runoff computed once from max value of runoff' 387 IF(lwp) WRITE(numout,*) ' max value of the runoff climatologie (over global domain) rn_rnf_max = ', rn_rnf_max 388 IF(lwp) WRITE(numout,*) ' depth over which runoffs is spread rn_dep_max = ', rn_dep_max 389 IF(lwp) WRITE(numout,*) ' create (=1) a runoff depth file or not (=0) nn_rnf_depth_file = ', nn_rnf_depth_file 390 391 CALL iom_open( TRIM( sn_rnf%clname ), inum ) ! open runoff file 392 CALL iom_gettime( inum, zrec, kntime=nbrec) 393 ALLOCATE( zrnfcl(jpi,jpj,nbrec) ) ; ALLOCATE( zrnf(jpi,jpj) ) 394 DO jm = 1, nbrec 395 CALL iom_get( inum, jpdom_data, TRIM( sn_rnf%clvar ), zrnfcl(:,:,jm), jm ) 396 END DO 397 CALL iom_close( inum ) 398 zrnf(:,:) = MAXVAL( zrnfcl(:,:,:), DIM=3 ) ! maximum value in time 399 DEALLOCATE( zrnfcl ) 400 ! 401 h_rnf(:,:) = 1. 402 ! 403 zacoef = rn_dep_max / rn_rnf_max ! coef of linear relation between runoff and its depth (150m for max of runoff) 404 ! 405 WHERE( zrnf(:,:) > 0._wp ) h_rnf(:,:) = zacoef * zrnf(:,:) ! compute depth for all runoffs 406 ! 407 DO jj = 1, jpj ! take in account min depth of ocean rn_hmin 408 DO ji = 1, jpi 409 IF( zrnf(ji,jj) > 0._wp ) THEN 410 jk = mbkt(ji,jj) 411 h_rnf(ji,jj) = MIN( h_rnf(ji,jj), gdept_0(ji,jj,jk ) ) 412 ENDIF 413 END DO 414 END DO 415 ! 416 nk_rnf(:,:) = 0 ! number of levels on which runoffs are distributed 417 DO jj = 1, jpj 418 DO ji = 1, jpi 419 IF( zrnf(ji,jj) > 0._wp ) THEN 420 jk = 2 421 DO WHILE ( jk /= mbkt(ji,jj) .AND. gdept_0(ji,jj,jk) < h_rnf(ji,jj) ) ; jk = jk + 1 374 422 END DO 423 nk_rnf(ji,jj) = jk 424 ELSE 425 nk_rnf(ji,jj) = 1 426 ENDIF 427 END DO 428 END DO 429 ! 430 DEALLOCATE( zrnf ) 431 ! 432 DO jj = 1, jpj ! set the associated depth 433 DO ji = 1, jpi 434 h_rnf(ji,jj) = 0._wp 435 DO jk = 1, nk_rnf(ji,jj) 436 h_rnf(ji,jj) = h_rnf(ji,jj) + fse3t(ji,jj,jk) 375 437 END DO 376 438 END DO 377 ELSE ! runoffs applied at the surface 378 nk_rnf(:,:) = 1 379 h_rnf (:,:) = fse3t(:,:,1) 380 ENDIF 381 ! 439 END DO 440 ! 441 IF( nn_rnf_depth_file == 1 ) THEN ! save output nb levels for runoff 442 IF(lwp) WRITE(numout,*) ' create runoff depht file' 443 CALL iom_open ( TRIM( sn_dep_rnf%clname ), inum, ldwrt = .TRUE., kiolib = jprstlib ) 444 CALL iom_rstput( 0, 0, inum, 'rodepth', h_rnf ) 445 CALL iom_close ( inum ) 446 ENDIF 447 ELSE ! runoffs applied at the surface 448 nk_rnf(:,:) = 1 449 h_rnf (:,:) = fse3t(:,:,1) 382 450 ENDIF 383 451 ! … … 400 468 IF( rn_hrnf > 0._wp ) THEN 401 469 nkrnf = 2 402 DO WHILE( nkrnf /= jpkm1 .AND. gdepw_1d(nkrnf+1) < rn_hrnf ) ; nkrnf = nkrnf + 1 ; END DO 470 DO WHILE( nkrnf /= jpkm1 .AND. gdepw_1d(nkrnf+1) < rn_hrnf ) ; nkrnf = nkrnf + 1 471 END DO 403 472 IF( ln_sco ) CALL ctl_warn( 'sbc_rnf: number of levels over which Kz is increased is computed for zco...' ) 404 473 ENDIF -
branches/2014/dev_r4621_NOC4_BDY_VERT_INTERP/NEMOGCM/NEMO/OPA_SRC/SBC/sbcssm.F90
r5038 r5620 58 58 REAL(wp) :: zcoef, zf_sbc ! local scalar 59 59 REAL(wp), DIMENSION(jpi,jpj,jpts) :: zts 60 REAL(wp), DIMENSION(jpi,jpj) :: zub, zvb,zdep61 60 !!--------------------------------------------------------------------- 62 63 ! !* first wet T-, U-, V- ocean level (ISF)variables (T, S, depth, velocity)61 62 ! !* surface T-, U-, V- ocean level variables (T, S, depth, velocity) 64 63 DO jj = 1, jpj 65 64 DO ji = 1, jpi 66 zub(ji,jj) = ub (ji,jj,miku(ji,jj))67 zvb(ji,jj) = vb (ji,jj,mikv(ji,jj))68 65 zts(ji,jj,jp_tem) = tsn(ji,jj,mikt(ji,jj),jp_tem) 69 66 zts(ji,jj,jp_sal) = tsn(ji,jj,mikt(ji,jj),jp_sal) … … 71 68 END DO 72 69 ! 73 IF( lk_vvl ) THEN74 DO jj = 1, jpj75 DO ji = 1, jpi76 zdep(ji,jj) = fse3t_n(ji,jj,mikt(ji,jj))77 END DO78 END DO79 ENDIF80 ! ! ---------------------------------------- !81 70 IF( nn_fsbc == 1 ) THEN ! Instantaneous surface fields ! 82 71 ! ! ---------------------------------------- ! 83 ssu_m(:,:) = zub(:,:)84 ssv_m(:,:) = zvb(:,:)72 ssu_m(:,:) = ub(:,:,1) 73 ssv_m(:,:) = vb(:,:,1) 85 74 IF( ln_useCT ) THEN ; sst_m(:,:) = eos_pt_from_ct( zts(:,:,jp_tem), zts(:,:,jp_sal) ) 86 75 ELSE ; sst_m(:,:) = zts(:,:,jp_tem) … … 92 81 ENDIF 93 82 ! 94 IF( lk_vvl ) fse3t_m(:,:) = zdep(:,:) 83 IF( lk_vvl ) e3t_m(:,:) = fse3t_n(:,:,1) 84 ! 85 frq_m(:,:) = fraqsr_1lev(:,:) 95 86 ! 96 87 ELSE … … 101 92 IF(lwp) WRITE(numout,*) '~~~~~~~ mean fields initialised to instantaneous values' 102 93 zcoef = REAL( nn_fsbc - 1, wp ) 103 ssu_m(:,:) = zcoef * zub(:,:)104 ssv_m(:,:) = zcoef * zvb(:,:)94 ssu_m(:,:) = zcoef * ub(:,:,1) 95 ssv_m(:,:) = zcoef * vb(:,:,1) 105 96 IF( ln_useCT ) THEN ; sst_m(:,:) = zcoef * eos_pt_from_ct( zts(:,:,jp_tem), zts(:,:,jp_sal) ) 106 97 ELSE ; sst_m(:,:) = zcoef * zts(:,:,jp_tem) … … 112 103 ENDIF 113 104 ! 114 IF( lk_vvl ) fse3t_m(:,:) = zcoef * zdep(:,:) 105 IF( lk_vvl ) e3t_m(:,:) = zcoef * fse3t_n(:,:,1) 106 ! 107 frq_m(:,:) = zcoef * fraqsr_1lev(:,:) 115 108 ! ! ---------------------------------------- ! 116 109 ELSEIF( MOD( kt - 2 , nn_fsbc ) == 0 ) THEN ! Initialisation: New mean computation ! … … 121 114 sss_m(:,:) = 0.e0 122 115 ssh_m(:,:) = 0.e0 123 IF( lk_vvl ) fse3t_m(:,:) = 0.e0 116 IF( lk_vvl ) e3t_m(:,:) = 0.e0 117 frq_m(:,:) = 0.e0 124 118 ENDIF 125 119 ! ! ---------------------------------------- ! 126 120 ! ! Cumulate at each time step ! 127 121 ! ! ---------------------------------------- ! 128 ssu_m(:,:) = ssu_m(:,:) + zub(:,:)129 ssv_m(:,:) = ssv_m(:,:) + zvb(:,:)122 ssu_m(:,:) = ssu_m(:,:) + ub(:,:,1) 123 ssv_m(:,:) = ssv_m(:,:) + vb(:,:,1) 130 124 IF( ln_useCT ) THEN ; sst_m(:,:) = sst_m(:,:) + eos_pt_from_ct( zts(:,:,jp_tem), zts(:,:,jp_sal) ) 131 125 ELSE ; sst_m(:,:) = sst_m(:,:) + zts(:,:,jp_tem) … … 137 131 ENDIF 138 132 ! 139 IF( lk_vvl ) fse3t_m(:,:) = fse3t_m(:,:) + zdep(:,:) 133 IF( lk_vvl ) e3t_m(:,:) = fse3t_m(:,:) + fse3t_n(:,:,1) 134 ! 135 frq_m(:,:) = frq_m(:,:) + fraqsr_1lev(:,:) 140 136 141 137 ! ! ---------------------------------------- ! … … 148 144 ssv_m(:,:) = ssv_m(:,:) * zcoef ! 149 145 ssh_m(:,:) = ssh_m(:,:) * zcoef ! mean SSH [m] 150 IF( lk_vvl ) fse3t_m(:,:) = fse3t_m(:,:) * zcoef ! mean vertical scale factor [m] 146 IF( lk_vvl ) e3t_m(:,:) = fse3t_m(:,:) * zcoef ! mean vertical scale factor [m] 147 frq_m(:,:) = frq_m(:,:) * zcoef ! mean fraction of solar net radiation absorbed in the 1st T level [-] 151 148 ! 152 149 ENDIF … … 165 162 CALL iom_rstput( kt, nitrst, numrow, 'sss_m' , sss_m ) 166 163 CALL iom_rstput( kt, nitrst, numrow, 'ssh_m' , ssh_m ) 167 IF( lk_vvl ) THEN 168 CALL iom_rstput( kt, nitrst, numrow, 'fse3t_m' , fse3t_m(:,:) ) 169 END IF 170 ! 171 ENDIF 172 ! 164 IF( lk_vvl ) CALL iom_rstput( kt, nitrst, numrow, 'e3t_m' , e3t_m ) 165 CALL iom_rstput( kt, nitrst, numrow, 'frq_m' , frq_m ) 166 ! 167 ENDIF 168 ! 169 ENDIF 170 ! 171 IF( MOD( kt - 1 , nn_fsbc ) == 0 ) THEN ! Mean value at each nn_fsbc time-step ! 172 CALL iom_put( 'ssu_m', ssu_m ) 173 CALL iom_put( 'ssv_m', ssv_m ) 174 CALL iom_put( 'sst_m', sst_m ) 175 CALL iom_put( 'sss_m', sss_m ) 176 CALL iom_put( 'ssh_m', ssh_m ) 177 IF( lk_vvl ) CALL iom_put( 'e3t_m', e3t_m ) 178 CALL iom_put( 'frq_m', frq_m ) 173 179 ENDIF 174 180 ! … … 206 212 CALL iom_get( numror, jpdom_autoglo, 'sss_m' , sss_m ) ! " " salinity (T-point) 207 213 CALL iom_get( numror, jpdom_autoglo, 'ssh_m' , ssh_m ) ! " " height (T-point) 208 IF( lk_vvl ) CALL iom_get( numror, jpdom_autoglo, 'fse3t_m', fse3t_m(:,:) ) 214 IF( lk_vvl ) CALL iom_get( numror, jpdom_autoglo, 'e3t_m', e3t_m ) 215 ! fraction of solar net radiation absorbed in 1st T level 216 IF( iom_varid( numror, 'frq_m', ldstop = .FALSE. ) > 0 ) THEN 217 CALL iom_get( numror, jpdom_autoglo, 'frq_m' , frq_m ) 218 ELSE 219 frq_m(:,:) = 1._wp ! default definition 220 ENDIF 209 221 ! 210 222 IF( zf_sbc /= REAL( nn_fsbc, wp ) ) THEN ! nn_fsbc has changed between 2 runs … … 217 229 sss_m(:,:) = zcoef * sss_m(:,:) 218 230 ssh_m(:,:) = zcoef * ssh_m(:,:) 219 IF( lk_vvl ) fse3t_m(:,:) = zcoef * fse3t_m(:,:) 231 IF( lk_vvl ) e3t_m(:,:) = zcoef * fse3t_m(:,:) 232 frq_m(:,:) = zcoef * frq_m(:,:) 220 233 ELSE 221 234 IF(lwp) WRITE(numout,*) '~~~~~~~ mean fields read in the ocean restart file' … … 224 237 ENDIF 225 238 ! 239 IF( .NOT. l_ssm_mean ) THEN ! default initialisation. needed by lim_istate 240 ! 241 IF(lwp) WRITE(numout,*) ' default initialisation of ss?_m arrays' 242 ssu_m(:,:) = ub(:,:,1) 243 ssv_m(:,:) = vb(:,:,1) 244 IF( ln_useCT ) THEN ; sst_m(:,:) = eos_pt_from_ct( tsn(:,:,1,jp_tem), tsn(:,:,1,jp_sal) ) 245 ELSE ; sst_m(:,:) = tsn(:,:,1,jp_tem) 246 ENDIF 247 sss_m(:,:) = tsn(:,:,1,jp_sal) 248 ssh_m(:,:) = sshn(:,:) 249 IF( lk_vvl ) e3t_m(:,:) = fse3t_n(:,:,1) 250 frq_m(:,:) = 1._wp 251 ! 252 ENDIF 253 ! 226 254 END SUBROUTINE sbc_ssm_init 227 255 -
branches/2014/dev_r4621_NOC4_BDY_VERT_INTERP/NEMOGCM/NEMO/OPA_SRC/SBC/sbctide.F90
- Property svn:keywords set to Id
r4292 r5620 36 36 !!---------------------------------------------------------------------- 37 37 !! NEMO/OPA 3.5 , NEMO Consortium (2013) 38 !! $Id :$38 !! $Id$ 39 39 !! Software governed by the CeCILL licence (NEMOGCM/NEMO_CeCILL.txt) 40 40 !!---------------------------------------------------------------------- -
branches/2014/dev_r4621_NOC4_BDY_VERT_INTERP/NEMOGCM/NEMO/OPA_SRC/SBC/sbcwave.F90
- Property svn:keywords set to Id
r4792 r5620 39 39 !!---------------------------------------------------------------------- 40 40 !! NEMO/OPA 4.0 , NEMO Consortium (2011) 41 !! $Id :$41 !! $Id$ 42 42 !! Software governed by the CeCILL licence (NEMOGCM/NEMO_CeCILL.txt) 43 43 !!---------------------------------------------------------------------- -
branches/2014/dev_r4621_NOC4_BDY_VERT_INTERP/NEMOGCM/NEMO/OPA_SRC/SBC/tide_mod.F90
- Property svn:keywords set to Id
r4292 r5620 35 35 !!---------------------------------------------------------------------- 36 36 !! NEMO/OPA 3.3 , LOCEAN-IPSL (2010) 37 !! $Id :$37 !! $Id$ 38 38 !! Software governed by the CeCILL licence (modipsl/doc/NEMO_CeCILL.txt) 39 39 !!---------------------------------------------------------------------- -
branches/2014/dev_r4621_NOC4_BDY_VERT_INTERP/NEMOGCM/NEMO/OPA_SRC/SBC/tideini.F90
- Property svn:keywords set to Id
r4792 r5620 36 36 !!---------------------------------------------------------------------- 37 37 !! NEMO/OPA 3.5 , NEMO Consortium (2013) 38 !! $Id :$38 !! $Id$ 39 39 !! Software governed by the CeCILL licence (NEMOGCM/NEMO_CeCILL.txt) 40 40 !!---------------------------------------------------------------------- … … 80 80 END DO 81 81 END DO 82 ! 83 ! Ensure that tidal components have been set in namelist_cfg 84 IF( nb_harmo .EQ. 0 ) CALL ctl_stop( 'tide_init : No tidal components set in nam_tide' ) 82 85 ! 83 86 IF(lwp) THEN -
branches/2014/dev_r4621_NOC4_BDY_VERT_INTERP/NEMOGCM/NEMO/OPA_SRC/SBC/updtide.F90
- Property svn:keywords set to Id
r4292 r5620 26 26 !!---------------------------------------------------------------------- 27 27 !! NEMO/OPA 3.3 , NEMO Consortium (2010) 28 !! $Id : sbcfwb.F90 3625 2012-11-21 13:19:18Z acc$28 !! $Id$ 29 29 !! Software governed by the CeCILL licence (NEMOGCM/NEMO_CeCILL.txt) 30 30 !!---------------------------------------------------------------------- -
branches/2014/dev_r4621_NOC4_BDY_VERT_INTERP/NEMOGCM/NEMO/OPA_SRC/SOL/solver.F90
r4792 r5620 92 92 IF( .NOT. lk_agrif .OR. .NOT. ln_rstart) THEN 93 93 IF( sol_oce_alloc() /= 0 ) CALL ctl_stop( 'STOP', 'solver_init : unable to allocate sol_oce arrays' ) 94 gcx (:,:) = 0.e0 95 gcxb(:,:) = 0.e0 94 96 ENDIF 95 97 -
branches/2014/dev_r4621_NOC4_BDY_VERT_INTERP/NEMOGCM/NEMO/OPA_SRC/STO/stopar.F90
r5488 r5620 849 849 850 850 851 REAL(wp)FUNCTION sto_par_flt_fac( kpasses )851 FUNCTION sto_par_flt_fac( kpasses ) 852 852 !!---------------------------------------------------------------------- 853 853 !! *** FUNCTION sto_par_flt_fac *** … … 858 858 !!---------------------------------------------------------------------- 859 859 INTEGER, INTENT(in) :: kpasses 860 REAL(wp) :: sto_par_flt_fac 860 861 !! 861 862 INTEGER :: jpasses, ji, jj, jflti, jfltj -
branches/2014/dev_r4621_NOC4_BDY_VERT_INTERP/NEMOGCM/NEMO/OPA_SRC/TRA/eosbn2.F90
r5038 r5620 22 22 !! - ! 2013-04 (F. Roquet, G. Madec) add eos_rab, change bn2 computation and reorganize the module 23 23 !! - ! 2014-09 (F. Roquet) add TEOS-10, S-EOS, and modify EOS-80 24 !! - ! 2015-06 (P.A. Bouttier) eos_fzp functions changed to subroutines for AGRIF 24 25 !!---------------------------------------------------------------------- 25 26 … … 47 48 USE lbclnk ! ocean lateral boundary conditions 48 49 USE timing ! Timing 50 USE stopar ! Stochastic T/S fluctuations 51 USE stopts ! Stochastic T/S fluctuations 49 52 50 53 IMPLICIT NONE … … 72 75 PUBLIC eos_init ! called by istate module 73 76 74 ! 75 INTEGER , PUBLIC :: nn_eos = 0 !:= 0/1/2 type of eq. of state and Brunt-Vaisala frequ.76 LOGICAL , PUBLIC :: ln_useCT = .FALSE.! determine if eos_pt_from_ct is used to compute sst_m77 ! !!* Namelist (nameos) * 78 INTEGER , PUBLIC :: nn_eos ! = 0/1/2 type of eq. of state and Brunt-Vaisala frequ. 79 LOGICAL , PUBLIC :: ln_useCT ! determine if eos_pt_from_ct is used to compute sst_m 77 80 78 81 ! !!! simplified eos coefficients … … 313 316 REAL(wp), DIMENSION(jpi,jpj,jpk ), INTENT(in ) :: pdep ! depth [m] 314 317 ! 315 INTEGER :: ji, jj, jk ! dummy loop indices 316 REAL(wp) :: zt , zh , zs , ztm ! local scalars 317 REAL(wp) :: zn , zn0, zn1, zn2, zn3 ! - - 318 INTEGER :: ji, jj, jk, jsmp ! dummy loop indices 319 INTEGER :: jdof 320 REAL(wp) :: zt , zh , zstemp, zs , ztm ! local scalars 321 REAL(wp) :: zn , zn0, zn1, zn2, zn3 ! - - 322 REAL(wp), DIMENSION(:), ALLOCATABLE :: zn0_sto, zn_sto, zsign ! local vectors 318 323 !!---------------------------------------------------------------------- 319 324 ! … … 324 329 CASE( -1, 0 ) !== polynomial TEOS-10 / EOS-80 ==! 325 330 ! 326 DO jk = 1, jpkm1 327 DO jj = 1, jpj 328 DO ji = 1, jpi 329 ! 330 zh = pdep(ji,jj,jk) * r1_Z0 ! depth 331 zt = pts (ji,jj,jk,jp_tem) * r1_T0 ! temperature 332 zs = SQRT( ABS( pts(ji,jj,jk,jp_sal) + rdeltaS ) * r1_S0 ) ! square root salinity 333 ztm = tmask(ji,jj,jk) ! tmask 334 ! 335 zn3 = EOS013*zt & 336 & + EOS103*zs+EOS003 337 ! 338 zn2 = (EOS022*zt & 339 & + EOS112*zs+EOS012)*zt & 340 & + (EOS202*zs+EOS102)*zs+EOS002 341 ! 342 zn1 = (((EOS041*zt & 343 & + EOS131*zs+EOS031)*zt & 344 & + (EOS221*zs+EOS121)*zs+EOS021)*zt & 345 & + ((EOS311*zs+EOS211)*zs+EOS111)*zs+EOS011)*zt & 346 & + (((EOS401*zs+EOS301)*zs+EOS201)*zs+EOS101)*zs+EOS001 347 ! 348 zn0 = (((((EOS060*zt & 349 & + EOS150*zs+EOS050)*zt & 350 & + (EOS240*zs+EOS140)*zs+EOS040)*zt & 351 & + ((EOS330*zs+EOS230)*zs+EOS130)*zs+EOS030)*zt & 352 & + (((EOS420*zs+EOS320)*zs+EOS220)*zs+EOS120)*zs+EOS020)*zt & 353 & + ((((EOS510*zs+EOS410)*zs+EOS310)*zs+EOS210)*zs+EOS110)*zs+EOS010)*zt & 354 & + (((((EOS600*zs+EOS500)*zs+EOS400)*zs+EOS300)*zs+EOS200)*zs+EOS100)*zs+EOS000 355 ! 356 zn = ( ( zn3 * zh + zn2 ) * zh + zn1 ) * zh + zn0 357 ! 358 prhop(ji,jj,jk) = zn0 * ztm ! potential density referenced at the surface 359 ! 360 prd(ji,jj,jk) = ( zn * r1_rau0 - 1._wp ) * ztm ! density anomaly (masked) 331 ! Stochastic equation of state 332 IF ( ln_sto_eos ) THEN 333 ALLOCATE(zn0_sto(1:2*nn_sto_eos)) 334 ALLOCATE(zn_sto(1:2*nn_sto_eos)) 335 ALLOCATE(zsign(1:2*nn_sto_eos)) 336 DO jsmp = 1, 2*nn_sto_eos, 2 337 zsign(jsmp) = 1._wp 338 zsign(jsmp+1) = -1._wp 339 END DO 340 ! 341 DO jk = 1, jpkm1 342 DO jj = 1, jpj 343 DO ji = 1, jpi 344 ! 345 ! compute density (2*nn_sto_eos) times: 346 ! (1) for t+dt, s+ds (with the random TS fluctutation computed in sto_pts) 347 ! (2) for t-dt, s-ds (with the opposite fluctuation) 348 DO jsmp = 1, nn_sto_eos*2 349 jdof = (jsmp + 1) / 2 350 zh = pdep(ji,jj,jk) * r1_Z0 ! depth 351 zt = (pts (ji,jj,jk,jp_tem) + pts_ran(ji,jj,jk,jp_tem,jdof) * zsign(jsmp)) * r1_T0 ! temperature 352 zstemp = pts (ji,jj,jk,jp_sal) + pts_ran(ji,jj,jk,jp_sal,jdof) * zsign(jsmp) 353 zs = SQRT( ABS( zstemp + rdeltaS ) * r1_S0 ) ! square root salinity 354 ztm = tmask(ji,jj,jk) ! tmask 355 ! 356 zn3 = EOS013*zt & 357 & + EOS103*zs+EOS003 358 ! 359 zn2 = (EOS022*zt & 360 & + EOS112*zs+EOS012)*zt & 361 & + (EOS202*zs+EOS102)*zs+EOS002 362 ! 363 zn1 = (((EOS041*zt & 364 & + EOS131*zs+EOS031)*zt & 365 & + (EOS221*zs+EOS121)*zs+EOS021)*zt & 366 & + ((EOS311*zs+EOS211)*zs+EOS111)*zs+EOS011)*zt & 367 & + (((EOS401*zs+EOS301)*zs+EOS201)*zs+EOS101)*zs+EOS001 368 ! 369 zn0_sto(jsmp) = (((((EOS060*zt & 370 & + EOS150*zs+EOS050)*zt & 371 & + (EOS240*zs+EOS140)*zs+EOS040)*zt & 372 & + ((EOS330*zs+EOS230)*zs+EOS130)*zs+EOS030)*zt & 373 & + (((EOS420*zs+EOS320)*zs+EOS220)*zs+EOS120)*zs+EOS020)*zt & 374 & + ((((EOS510*zs+EOS410)*zs+EOS310)*zs+EOS210)*zs+EOS110)*zs+EOS010)*zt & 375 & + (((((EOS600*zs+EOS500)*zs+EOS400)*zs+EOS300)*zs+EOS200)*zs+EOS100)*zs+EOS000 376 ! 377 zn_sto(jsmp) = ( ( zn3 * zh + zn2 ) * zh + zn1 ) * zh + zn0_sto(jsmp) 378 END DO 379 ! 380 ! compute stochastic density as the mean of the (2*nn_sto_eos) densities 381 prhop(ji,jj,jk) = 0._wp ; prd(ji,jj,jk) = 0._wp 382 DO jsmp = 1, nn_sto_eos*2 383 prhop(ji,jj,jk) = prhop(ji,jj,jk) + zn0_sto(jsmp) ! potential density referenced at the surface 384 ! 385 prd(ji,jj,jk) = prd(ji,jj,jk) + ( zn_sto(jsmp) * r1_rau0 - 1._wp ) ! density anomaly (masked) 386 END DO 387 prhop(ji,jj,jk) = 0.5_wp * prhop(ji,jj,jk) * ztm / nn_sto_eos 388 prd (ji,jj,jk) = 0.5_wp * prd (ji,jj,jk) * ztm / nn_sto_eos 389 END DO 361 390 END DO 362 391 END DO 363 END DO 364 ! 392 DEALLOCATE(zn0_sto,zn_sto,zsign) 393 ! Non-stochastic equation of state 394 ELSE 395 DO jk = 1, jpkm1 396 DO jj = 1, jpj 397 DO ji = 1, jpi 398 ! 399 zh = pdep(ji,jj,jk) * r1_Z0 ! depth 400 zt = pts (ji,jj,jk,jp_tem) * r1_T0 ! temperature 401 zs = SQRT( ABS( pts(ji,jj,jk,jp_sal) + rdeltaS ) * r1_S0 ) ! square root salinity 402 ztm = tmask(ji,jj,jk) ! tmask 403 ! 404 zn3 = EOS013*zt & 405 & + EOS103*zs+EOS003 406 ! 407 zn2 = (EOS022*zt & 408 & + EOS112*zs+EOS012)*zt & 409 & + (EOS202*zs+EOS102)*zs+EOS002 410 ! 411 zn1 = (((EOS041*zt & 412 & + EOS131*zs+EOS031)*zt & 413 & + (EOS221*zs+EOS121)*zs+EOS021)*zt & 414 & + ((EOS311*zs+EOS211)*zs+EOS111)*zs+EOS011)*zt & 415 & + (((EOS401*zs+EOS301)*zs+EOS201)*zs+EOS101)*zs+EOS001 416 ! 417 zn0 = (((((EOS060*zt & 418 & + EOS150*zs+EOS050)*zt & 419 & + (EOS240*zs+EOS140)*zs+EOS040)*zt & 420 & + ((EOS330*zs+EOS230)*zs+EOS130)*zs+EOS030)*zt & 421 & + (((EOS420*zs+EOS320)*zs+EOS220)*zs+EOS120)*zs+EOS020)*zt & 422 & + ((((EOS510*zs+EOS410)*zs+EOS310)*zs+EOS210)*zs+EOS110)*zs+EOS010)*zt & 423 & + (((((EOS600*zs+EOS500)*zs+EOS400)*zs+EOS300)*zs+EOS200)*zs+EOS100)*zs+EOS000 424 ! 425 zn = ( ( zn3 * zh + zn2 ) * zh + zn1 ) * zh + zn0 426 ! 427 prhop(ji,jj,jk) = zn0 * ztm ! potential density referenced at the surface 428 ! 429 prd(ji,jj,jk) = ( zn * r1_rau0 - 1._wp ) * ztm ! density anomaly (masked) 430 END DO 431 END DO 432 END DO 433 ENDIF 434 365 435 CASE( 1 ) !== simplified EOS ==! 366 436 ! … … 922 992 923 993 924 FUNCTION eos_fzp_2d( psal, pdep ) RESULT( ptf)994 SUBROUTINE eos_fzp_2d( psal, ptf, pdep ) 925 995 !!---------------------------------------------------------------------- 926 996 !! *** ROUTINE eos_fzp *** … … 936 1006 REAL(wp), DIMENSION(jpi,jpj), INTENT(in ) :: psal ! salinity [psu] 937 1007 REAL(wp), DIMENSION(jpi,jpj), INTENT(in ), OPTIONAL :: pdep ! depth [m] 938 REAL(wp), DIMENSION(jpi,jpj) :: ptf! freezing temperature [Celcius]1008 REAL(wp), DIMENSION(jpi,jpj), INTENT(out ) :: ptf ! freezing temperature [Celcius] 939 1009 ! 940 1010 INTEGER :: ji, jj ! dummy loop indices … … 969 1039 nstop = nstop + 1 970 1040 ! 971 END SELECT 972 ! 973 END FUNCTIONeos_fzp_2d974 975 FUNCTION eos_fzp_0d( psal, pdep ) RESULT( ptf)1041 END SELECT 1042 ! 1043 END SUBROUTINE eos_fzp_2d 1044 1045 SUBROUTINE eos_fzp_0d( psal, ptf, pdep ) 976 1046 !!---------------------------------------------------------------------- 977 1047 !! *** ROUTINE eos_fzp *** … … 985 1055 !! Reference : UNESCO tech. papers in the marine science no. 28. 1978 986 1056 !!---------------------------------------------------------------------- 987 REAL(wp), INTENT(in ) :: psal! salinity [psu]988 REAL(wp), INTENT(in ), OPTIONAL :: pdep! depth [m]989 REAL(wp) :: ptf! freezing temperature [Celcius]1057 REAL(wp), INTENT(in ) :: psal ! salinity [psu] 1058 REAL(wp), INTENT(in ), OPTIONAL :: pdep ! depth [m] 1059 REAL(wp), INTENT(out) :: ptf ! freezing temperature [Celcius] 990 1060 ! 991 1061 REAL(wp) :: zs ! local scalars … … 1017 1087 END SELECT 1018 1088 ! 1019 END FUNCTIONeos_fzp_0d1089 END SUBROUTINE eos_fzp_0d 1020 1090 1021 1091 … … 1183 1253 WRITE(numout,*) ' model uses Conservative Temperature' 1184 1254 WRITE(numout,*) ' Important: model must be initialized with CT and SA fields' 1255 ELSE 1256 WRITE(numout,*) ' model does not use Conservative Temperature' 1185 1257 ENDIF 1186 1258 ENDIF … … 1589 1661 END SELECT 1590 1662 ! 1663 rau0_rcp = rau0 * rcp 1591 1664 r1_rau0 = 1._wp / rau0 1592 1665 r1_rcp = 1._wp / rcp 1593 r1_rau0_rcp = 1._wp / ( rau0 * rcp )1666 r1_rau0_rcp = 1._wp / rau0_rcp 1594 1667 ! 1595 1668 IF(lwp) WRITE(numout,*) … … 1597 1670 IF(lwp) WRITE(numout,*) ' 1. / rau0 r1_rau0 = ', r1_rau0, ' m^3/kg' 1598 1671 IF(lwp) WRITE(numout,*) ' ocean specific heat rcp = ', rcp , ' J/Kelvin' 1672 IF(lwp) WRITE(numout,*) ' rau0 * rcp rau0_rcp = ', rau0_rcp 1599 1673 IF(lwp) WRITE(numout,*) ' 1. / ( rau0 * rcp ) r1_rau0_rcp = ', r1_rau0_rcp 1600 1674 ! -
branches/2014/dev_r4621_NOC4_BDY_VERT_INTERP/NEMOGCM/NEMO/OPA_SRC/TRA/traadv.F90
r5038 r5620 26 26 USE cla ! cross land advection (cla_traadv routine) 27 27 USE ldftra_oce ! lateral diffusion coefficient on tracers 28 ! 28 29 USE in_out_manager ! I/O manager 29 30 USE iom ! I/O module … … 33 34 USE timing ! Timing 34 35 USE sbc_oce 36 USE diaptr ! Poleward heat transport 35 37 36 38 … … 111 113 ! 112 114 IF( ln_mle ) CALL tra_adv_mle( kt, nit000, zun, zvn, zwn, 'TRA' ) ! add the mle transport (if necessary) 115 ! 113 116 CALL iom_put( "uocetr_eff", zun ) ! output effective transport 114 117 CALL iom_put( "vocetr_eff", zvn ) 115 118 CALL iom_put( "wocetr_eff", zwn ) 116 119 ! 120 IF( ln_diaptr ) CALL dia_ptr( zvn ) ! diagnose the effective MSF 121 ! 122 117 123 SELECT CASE ( nadv ) !== compute advection trend and add it to general trend ==! 118 CASE ( 1 ) ; CALL tra_adv_cen2 ( kt, nit000, 'TRA', zun, zvn, zwn, tsb, tsn, tsa, jpts ) ! 2nd order centered119 CASE ( 2 ) ; CALL tra_adv_tvd ( kt, nit000, 'TRA', r2dtra, zun, zvn, zwn, tsb, tsn, tsa, jpts ) ! TVD120 CASE ( 3 ) ; CALL tra_adv_muscl ( kt, nit000, 'TRA', r2dtra, zun, zvn, zwn, tsb, tsa, jpts, ln_traadv_msc_ups ) ! MUSCL121 CASE ( 4 ) ; CALL tra_adv_muscl2 ( kt, nit000, 'TRA', r2dtra, zun, zvn, zwn, tsb, tsn, tsa, jpts ) ! MUSCL2122 CASE ( 5 ) ; CALL tra_adv_ubs ( kt, nit000, 'TRA', r2dtra, zun, zvn, zwn, tsb, tsn, tsa, jpts ) ! UBS123 CASE ( 6 ) ; CALL tra_adv_qck ( kt, nit000, 'TRA', r2dtra, zun, zvn, zwn, tsb, tsn, tsa, jpts ) ! QUICKEST124 CASE ( 7 ) ; CALL tra_adv_tvd_zts( kt, nit000, 'TRA', r2dtra, zun, zvn, zwn, tsb, tsn, tsa, jpts ) ! TVD ZTS124 CASE ( 1 ) ; CALL tra_adv_cen2 ( kt, nit000, 'TRA', zun, zvn, zwn, tsb, tsn, tsa, jpts ) ! 2nd order centered 125 CASE ( 2 ) ; CALL tra_adv_tvd ( kt, nit000, 'TRA', r2dtra, zun, zvn, zwn, tsb, tsn, tsa, jpts ) ! TVD 126 CASE ( 3 ) ; CALL tra_adv_muscl ( kt, nit000, 'TRA', r2dtra, zun, zvn, zwn, tsb, tsa, jpts, ln_traadv_msc_ups ) ! MUSCL 127 CASE ( 4 ) ; CALL tra_adv_muscl2 ( kt, nit000, 'TRA', r2dtra, zun, zvn, zwn, tsb, tsn, tsa, jpts ) ! MUSCL2 128 CASE ( 5 ) ; CALL tra_adv_ubs ( kt, nit000, 'TRA', r2dtra, zun, zvn, zwn, tsb, tsn, tsa, jpts ) ! UBS 129 CASE ( 6 ) ; CALL tra_adv_qck ( kt, nit000, 'TRA', r2dtra, zun, zvn, zwn, tsb, tsn, tsa, jpts ) ! QUICKEST 130 CASE ( 7 ) ; CALL tra_adv_tvd_zts( kt, nit000, 'TRA', r2dtra, zun, zvn, zwn, tsb, tsn, tsa, jpts ) ! TVD ZTS 125 131 ! 126 132 CASE (-1 ) !== esopa: test all possibility with control print ==! … … 206 212 IF( lk_esopa ) ioptio = 1 207 213 208 IF( ( ln_traadv_muscl .OR. ln_traadv_muscl2 .OR. ln_traadv_ubs .OR. ln_traadv_qck ) .AND. nn_isf .NE. 0 )&209 &CALL ctl_stop( 'Only traadv_cen2 and traadv_tvd is compatible with ice shelf cavity')214 IF( ( ln_traadv_muscl .OR. ln_traadv_muscl2 .OR. ln_traadv_ubs .OR. ln_traadv_qck .OR. ln_traadv_tvd_zts ) & 215 .AND. ln_isfcav ) CALL ctl_stop( 'Only traadv_cen2 and traadv_tvd is compatible with ice shelf cavity') 210 216 211 217 IF( ioptio /= 1 ) CALL ctl_stop( 'Choose ONE advection scheme in namelist namtra_adv' ) -
branches/2014/dev_r4621_NOC4_BDY_VERT_INTERP/NEMOGCM/NEMO/OPA_SRC/TRA/traadv_cen2.F90
r5038 r5620 173 173 END DO 174 174 END DO 175 zfzp(:,:) = eos_fzp( tsn(:,:,1,jp_sal), zpres(:,:) )175 CALL eos_fzp( tsn(:,:,1,jp_sal), zfzp(:,:), zpres(:,:) ) 176 176 DO jk = 1, jpk 177 177 DO jj = 1, jpj … … 279 279 END IF 280 280 ! ! "Poleward" heat and salt transports (contribution of upstream fluxes) 281 IF( cdtype == 'TRA' .AND. ln_diaptr .AND. ( MOD( kt, nn_fptr ) == 0 )) THEN282 IF( jn == jp_tem ) htr_adv(:) = ptr_ vj( zwy(:,:,:) )283 IF( jn == jp_sal ) str_adv(:) = ptr_ vj( zwy(:,:,:) )281 IF( cdtype == 'TRA' .AND. ln_diaptr ) THEN 282 IF( jn == jp_tem ) htr_adv(:) = ptr_sj( zwy(:,:,:) ) 283 IF( jn == jp_sal ) str_adv(:) = ptr_sj( zwy(:,:,:) ) 284 284 ENDIF 285 285 ! -
branches/2014/dev_r4621_NOC4_BDY_VERT_INTERP/NEMOGCM/NEMO/OPA_SRC/TRA/traadv_mle.F90
- Property svn:keywords set to Id
r5038 r5620 53 53 !!---------------------------------------------------------------------- 54 54 !! NEMO/OPA 4.0 , NEMO Consortium (2011) 55 !! $Id :$55 !! $Id$ 56 56 !! Software governed by the CeCILL licence (modipsl/doc/NEMO_CeCILL.txt) 57 57 !!---------------------------------------------------------------------- -
branches/2014/dev_r4621_NOC4_BDY_VERT_INTERP/NEMOGCM/NEMO/OPA_SRC/TRA/traadv_muscl.F90
r5038 r5620 21 21 USE trdtra ! tracers trends manager 22 22 USE dynspg_oce ! choice/control of key cpp for surface pressure gradient 23 USE sbcrnf 23 USE sbcrnf ! river runoffs 24 24 USE diaptr ! poleward transport diagnostics 25 25 ! … … 219 219 END IF 220 220 ! ! "Poleward" heat and salt transports (contribution of upstream fluxes) 221 IF( cdtype == 'TRA' .AND. ln_diaptr .AND. ( MOD( kt, nn_fptr ) == 0 )) THEN222 IF( jn == jp_tem ) htr_adv(:) = ptr_ vj( zwy(:,:,:) )223 IF( jn == jp_sal ) str_adv(:) = ptr_ vj( zwy(:,:,:) )221 IF( cdtype == 'TRA' .AND. ln_diaptr ) THEN 222 IF( jn == jp_tem ) htr_adv(:) = ptr_sj( zwy(:,:,:) ) 223 IF( jn == jp_sal ) str_adv(:) = ptr_sj( zwy(:,:,:) ) 224 224 ENDIF 225 225 -
branches/2014/dev_r4621_NOC4_BDY_VERT_INTERP/NEMOGCM/NEMO/OPA_SRC/TRA/traadv_muscl2.F90
r5038 r5620 200 200 201 201 ! ! "Poleward" heat and salt transports (contribution of upstream fluxes) 202 IF( cdtype == 'TRA' .AND. ln_diaptr .AND. ( MOD( kt, nn_fptr ) == 0 )) THEN203 IF( jn == jp_tem ) htr_adv(:) = ptr_ vj( zwy(:,:,:) )204 IF( jn == jp_sal ) str_adv(:) = ptr_ vj( zwy(:,:,:) )202 IF( cdtype == 'TRA' .AND. ln_diaptr ) THEN 203 IF( jn == jp_tem ) htr_adv(:) = ptr_sj( zwy(:,:,:) ) 204 IF( jn == jp_sal ) str_adv(:) = ptr_sj( zwy(:,:,:) ) 205 205 ENDIF 206 206 -
branches/2014/dev_r4621_NOC4_BDY_VERT_INTERP/NEMOGCM/NEMO/OPA_SRC/TRA/traadv_qck.F90
r5038 r5620 355 355 IF( l_trd ) CALL trd_tra( kt, cdtype, jn, jptra_yad, zwy, pvn, ptn(:,:,:,jn) ) 356 356 ! ! "Poleward" heat and salt transports (contribution of upstream fluxes) 357 IF( cdtype == 'TRA' .AND. ln_diaptr .AND. ( MOD( kt, nn_fptr ) == 0 )) THEN358 IF( jn == jp_tem ) htr_adv(:) = ptr_ vj( zwy(:,:,:) )359 IF( jn == jp_sal ) str_adv(:) = ptr_ vj( zwy(:,:,:) )357 IF( cdtype == 'TRA' .AND. ln_diaptr ) THEN 358 IF( jn == jp_tem ) htr_adv(:) = ptr_sj( zwy(:,:,:) ) 359 IF( jn == jp_sal ) str_adv(:) = ptr_sj( zwy(:,:,:) ) 360 360 ENDIF 361 361 ! -
branches/2014/dev_r4621_NOC4_BDY_VERT_INTERP/NEMOGCM/NEMO/OPA_SRC/TRA/traadv_tvd.F90
r5038 r5620 106 106 ENDIF 107 107 ! 108 zwi(:,:,:) = 0.e0 ; zwz(:,:,:) = 0.e0108 zwi(:,:,:) = 0.e0 ; 109 109 ! 110 110 ! ! =========== 111 111 DO jn = 1, kjpt ! tracer loop 112 112 ! ! =========== 113 ! 1. Bottom value : flux set to zero113 ! 1. Bottom and k=1 value : flux set to zero 114 114 ! ---------------------------------- 115 115 zwx(:,:,jpk) = 0.e0 ; zwz(:,:,jpk) = 0.e0 116 116 zwy(:,:,jpk) = 0.e0 ; zwi(:,:,jpk) = 0.e0 117 117 118 zwz(:,:,1 ) = 0._wp 118 119 ! 2. upstream advection with initial mass fluxes & intermediate update 119 120 ! -------------------------------------------------------------------- … … 134 135 135 136 ! upstream tracer flux in the k direction 137 ! Interior value 138 DO jk = 2, jpkm1 139 DO jj = 1, jpj 140 DO ji = 1, jpi 141 zfp_wk = pwn(ji,jj,jk) + ABS( pwn(ji,jj,jk) ) 142 zfm_wk = pwn(ji,jj,jk) - ABS( pwn(ji,jj,jk) ) 143 zwz(ji,jj,jk) = 0.5 * ( zfp_wk * ptb(ji,jj,jk,jn) + zfm_wk * ptb(ji,jj,jk-1,jn) ) * wmask(ji,jj,jk) 144 END DO 145 END DO 146 END DO 136 147 ! Surface value 137 148 IF( lk_vvl ) THEN 138 DO jj = 1, jpj 139 DO ji = 1, jpi 140 zwz(ji,jj, mikt(ji,jj) ) = 0.e0 ! volume variable 141 END DO 142 END DO 149 IF ( ln_isfcav ) THEN 150 DO jj = 1, jpj 151 DO ji = 1, jpi 152 zwz(ji,jj, mikt(ji,jj) ) = 0.e0 ! volume variable 153 END DO 154 END DO 155 ELSE 156 zwz(:,:,1) = 0.e0 ! volume variable 157 END IF 143 158 ELSE 144 DO jj = 1, jpj 145 DO ji = 1, jpi 146 zwz(ji,jj, mikt(ji,jj) ) = pwn(ji,jj,mikt(ji,jj)) * ptb(ji,jj,mikt(ji,jj),jn) ! linear free surface 147 END DO 148 END DO 159 IF ( ln_isfcav ) THEN 160 DO jj = 1, jpj 161 DO ji = 1, jpi 162 zwz(ji,jj, mikt(ji,jj) ) = pwn(ji,jj,mikt(ji,jj)) * ptb(ji,jj,mikt(ji,jj),jn) ! linear free surface 163 END DO 164 END DO 165 ELSE 166 zwz(:,:,1) = pwn(:,:,1) * ptb(:,:,1,jn) ! linear free surface 167 END IF 149 168 ENDIF 150 ! Interior value151 DO jj = 1, jpj152 DO ji = 1, jpi153 DO jk = mikt(ji,jj)+1, jpkm1154 zfp_wk = pwn(ji,jj,jk) + ABS( pwn(ji,jj,jk) )155 zfm_wk = pwn(ji,jj,jk) - ABS( pwn(ji,jj,jk) )156 zwz(ji,jj,jk) = 0.5 * ( zfp_wk * ptb(ji,jj,jk,jn) + zfm_wk * ptb(ji,jj,jk-1,jn) )157 END DO158 END DO159 END DO160 169 161 170 ! total advective trend … … 184 193 END IF 185 194 ! ! "Poleward" heat and salt transports (contribution of upstream fluxes) 186 IF( cdtype == 'TRA' .AND. ln_diaptr .AND. ( MOD( kt, nn_fptr ) == 0 )) THEN187 IF( jn == jp_tem ) htr_adv(:) = ptr_ vj( zwy(:,:,:) )188 IF( jn == jp_sal ) str_adv(:) = ptr_ vj( zwy(:,:,:) )195 IF( cdtype == 'TRA' .AND. ln_diaptr ) THEN 196 IF( jn == jp_tem ) htr_adv(:) = ptr_sj( zwy(:,:,:) ) 197 IF( jn == jp_sal ) str_adv(:) = ptr_sj( zwy(:,:,:) ) 189 198 ENDIF 190 199 … … 202 211 203 212 ! antidiffusive flux on k 204 zwz(:,:,1) = 0.e0 ! Surface value 205 ! 206 DO jj = 1, jpj 207 DO ji = 1, jpi 208 ik=mikt(ji,jj) 209 ! surface value 210 zwz(ji,jj,1:ik) = 0.e0 211 ! Interior value 212 DO jk = mikt(ji,jj)+1, jpkm1 213 ! Interior value 214 DO jk = 2, jpkm1 215 DO jj = 1, jpj 216 DO ji = 1, jpi 213 217 zwz(ji,jj,jk) = 0.5 * pwn(ji,jj,jk) * ( ptn(ji,jj,jk,jn) + ptn(ji,jj,jk-1,jn) ) - zwz(ji,jj,jk) 214 218 END DO 215 219 END DO 216 220 END DO 221 ! surface value 222 IF ( ln_isfcav ) THEN 223 DO jj = 1, jpj 224 DO ji = 1, jpi 225 zwz(ji,jj,mikt(ji,jj)) = 0.e0 226 END DO 227 END DO 228 ELSE 229 zwz(:,:,1) = 0.e0 230 END IF 217 231 CALL lbc_lnk( zwx, 'U', -1. ) ; CALL lbc_lnk( zwy, 'V', -1. ) ! Lateral bondary conditions 218 232 CALL lbc_lnk( zwz, 'W', 1. ) … … 250 264 END IF 251 265 ! ! "Poleward" heat and salt transports (contribution of upstream fluxes) 252 IF( cdtype == 'TRA' .AND. ln_diaptr .AND. ( MOD( kt, nn_fptr ) == 0 )) THEN253 IF( jn == jp_tem ) htr_adv(:) = ptr_ vj( zwy(:,:,:) ) + htr_adv(:)254 IF( jn == jp_sal ) str_adv(:) = ptr_ vj( zwy(:,:,:) ) + str_adv(:)266 IF( cdtype == 'TRA' .AND. ln_diaptr ) THEN 267 IF( jn == jp_tem ) htr_adv(:) = ptr_sj( zwy(:,:,:) ) + htr_adv(:) 268 IF( jn == jp_sal ) str_adv(:) = ptr_sj( zwy(:,:,:) ) + str_adv(:) 255 269 ENDIF 256 270 ! … … 358 372 359 373 ! upstream tracer flux in the k direction 360 ! Surface value361 IF( lk_vvl ) THEN ; zwz(:,:, 1 ) = 0._wp ! volume variable362 ELSE ; zwz(:,:, 1 ) = pwn(:,:,1) * ptb(:,:,1,jn) ! linear free surface363 ENDIF364 374 ! Interior value 365 375 DO jk = 2, jpkm1 … … 372 382 END DO 373 383 END DO 384 ! Surface value 385 IF( lk_vvl ) THEN 386 IF ( ln_isfcav ) THEN 387 DO jj = 1, jpj 388 DO ji = 1, jpi 389 zwz(ji,jj, mikt(ji,jj) ) = 0.e0 ! volume variable + isf 390 END DO 391 END DO 392 ELSE 393 zwz(:,:,1) = 0.e0 ! volume variable + no isf 394 END IF 395 ELSE 396 IF ( ln_isfcav ) THEN 397 DO jj = 1, jpj 398 DO ji = 1, jpi 399 zwz(ji,jj, mikt(ji,jj) ) = pwn(ji,jj,mikt(ji,jj)) * ptb(ji,jj,mikt(ji,jj),jn) ! linear free surface + isf 400 END DO 401 END DO 402 ELSE 403 zwz(:,:,1) = pwn(:,:,1) * ptb(:,:,1,jn) ! linear free surface + no isf 404 END IF 405 ENDIF 374 406 375 407 ! total advective trend … … 398 430 END IF 399 431 ! ! "Poleward" heat and salt transports (contribution of upstream fluxes) 400 IF( cdtype == 'TRA' .AND. ln_diaptr .AND. ( MOD( kt, nn_fptr ) == 0 )) THEN401 IF( jn == jp_tem ) htr_adv(:) = ptr_ vj( zwy(:,:,:) )402 IF( jn == jp_sal ) str_adv(:) = ptr_ vj( zwy(:,:,:) )432 IF( cdtype == 'TRA' .AND. ln_diaptr ) THEN 433 IF( jn == jp_tem ) htr_adv(:) = ptr_sj( zwy(:,:,:) ) 434 IF( jn == jp_sal ) str_adv(:) = ptr_sj( zwy(:,:,:) ) 403 435 ENDIF 404 436 … … 524 556 END IF 525 557 ! ! "Poleward" heat and salt transports (contribution of upstream fluxes) 526 IF( cdtype == 'TRA' .AND. ln_diaptr .AND. ( MOD( kt, nn_fptr ) == 0 )) THEN527 IF( jn == jp_tem ) htr_adv(:) = ptr_ vj( zwy(:,:,:) ) + htr_adv(:)528 IF( jn == jp_sal ) str_adv(:) = ptr_ vj( zwy(:,:,:) ) + str_adv(:)558 IF( cdtype == 'TRA' .AND. ln_diaptr ) THEN 559 IF( jn == jp_tem ) htr_adv(:) = ptr_sj( zwy(:,:,:) ) + htr_adv(:) 560 IF( jn == jp_sal ) str_adv(:) = ptr_sj( zwy(:,:,:) ) + str_adv(:) 529 561 ENDIF 530 562 ! … … 580 612 & paft * tmask + zbig * ( 1._wp - tmask ) ) 581 613 582 DO j j = 2, jpjm1583 DO ji = fs_2, fs_jpim1 ! vector opt.584 DO jk = mikt(ji,jj), jpkm1585 ikm1 = MAX(jk-1,mikt(ji,jj))586 z2dtt = p2dt(jk)587 614 DO jk = 1, jpkm1 615 ikm1 = MAX(jk-1,1) 616 z2dtt = p2dt(jk) 617 DO jj = 2, jpjm1 618 DO ji = fs_2, fs_jpim1 ! vector opt. 619 588 620 ! search maximum in neighbourhood 589 621 zup = MAX( zbup(ji ,jj ,jk ), & -
branches/2014/dev_r4621_NOC4_BDY_VERT_INTERP/NEMOGCM/NEMO/OPA_SRC/TRA/traadv_ubs.F90
r5038 r5620 177 177 END IF 178 178 ! ! "Poleward" heat and salt transports (contribution of upstream fluxes) 179 IF( cdtype == 'TRA' .AND. ln_diaptr .AND. ( MOD( kt, nn_fptr ) == 0 )) THEN180 IF( jn == jp_tem ) htr_adv(:) = ptr_ vj( ztv(:,:,:) )181 IF( jn == jp_sal ) str_adv(:) = ptr_ vj( ztv(:,:,:) )179 IF( cdtype == 'TRA' .AND. ln_diaptr ) THEN 180 IF( jn == jp_tem ) htr_adv(:) = ptr_sj( ztv(:,:,:) ) 181 IF( jn == jp_sal ) str_adv(:) = ptr_sj( ztv(:,:,:) ) 182 182 ENDIF 183 183 -
branches/2014/dev_r4621_NOC4_BDY_VERT_INTERP/NEMOGCM/NEMO/OPA_SRC/TRA/trabbc.F90
r5038 r5620 21 21 USE trdtra ! trends manager: tracers 22 22 USE in_out_manager ! I/O manager 23 USE iom ! I/O manager 24 USE fldread ! read input fields 25 USE lbclnk ! ocean lateral boundary conditions (or mpp link) 26 USE lib_mpp ! distributed memory computing library 23 27 USE prtctl ! Print control 24 28 USE wrk_nemo ! Memory Allocation … … 37 41 38 42 REAL(wp), PUBLIC, DIMENSION(:,:), ALLOCATABLE :: qgh_trd0 ! geothermal heating trend 43 TYPE(FLD), ALLOCATABLE, DIMENSION(:) :: sf_qgh ! structure of input qgh (file informations, fields read) 39 44 40 45 !! * Substitutions … … 42 47 !!---------------------------------------------------------------------- 43 48 !! NEMO/OPA 3.3 , NEMO Consortium (2010) 44 !! $Id $49 !! $Id$ 45 50 !! Software governed by the CeCILL licence (NEMOGCM/NEMO_CeCILL.txt) 46 51 !!---------------------------------------------------------------------- … … 92 97 END DO 93 98 ! 99 CALL lbc_lnk( tsa(:,:,:,jp_tem) , 'T', 1. ) 100 ! 94 101 IF( l_trdtra ) THEN ! Save the geothermal heat flux trend for diagnostics 95 102 ztrdt(:,:,:) = tsa(:,:,:,jp_tem) - ztrdt(:,:,:) … … 125 132 INTEGER :: inum ! temporary logical unit 126 133 INTEGER :: ios ! Local integer output status for namelist read 127 ! 128 NAMELIST/nambbc/ln_trabbc, nn_geoflx, rn_geoflx_cst 134 INTEGER :: ierror ! local integer 135 ! 136 TYPE(FLD_N) :: sn_qgh ! informations about the geotherm. field to be read 137 CHARACTER(len=256) :: cn_dir ! Root directory for location of ssr files 138 ! 139 NAMELIST/nambbc/ln_trabbc, nn_geoflx, rn_geoflx_cst, sn_qgh, cn_dir 129 140 !!---------------------------------------------------------------------- 130 141 … … 161 172 CASE ( 2 ) !* variable geothermal heat flux : read the geothermal fluxes in mW/m2 162 173 IF(lwp) WRITE(numout,*) ' *** variable geothermal heat flux' 163 CALL iom_open ( 'geothermal_heating.nc', inum ) 164 CALL iom_get ( inum, jpdom_data, 'heatflow', qgh_trd0 ) 165 CALL iom_close( inum ) 166 qgh_trd0(:,:) = r1_rau0_rcp * qgh_trd0(:,:) * 1.e-3 ! conversion in W/m2 174 ! 175 ALLOCATE( sf_qgh(1), STAT=ierror ) 176 IF( ierror > 0 ) THEN 177 CALL ctl_stop( 'tra_bbc_init: unable to allocate sf_qgh structure' ) ; 178 RETURN 179 ENDIF 180 ALLOCATE( sf_qgh(1)%fnow(jpi,jpj,1) ) 181 IF( sn_qgh%ln_tint )ALLOCATE( sf_qgh(1)%fdta(jpi,jpj,1,2) ) 182 ! fill sf_chl with sn_chl and control print 183 CALL fld_fill( sf_qgh, (/ sn_qgh /), cn_dir, 'tra_bbc_init', & 184 & 'bottom temperature boundary condition', 'nambbc' ) 185 186 CALL fld_read( nit000, 1, sf_qgh ) ! Read qgh data 187 qgh_trd0(:,:) = r1_rau0_rcp * sf_qgh(1)%fnow(:,:,1) * 1.e-3 ! conversion in W/m2 167 188 ! 168 189 CASE DEFAULT -
branches/2014/dev_r4621_NOC4_BDY_VERT_INTERP/NEMOGCM/NEMO/OPA_SRC/TRA/tradmp.F90
r5038 r5620 21 21 !! tra_dmp : update the tracer trend with the internal damping 22 22 !! tra_dmp_init : initialization, namlist read, parameters control 23 !! dtacof_zoom : restoring coefficient for zoom domain24 !! dtacof : restoring coefficient for global domain25 !! cofdis : compute the distance to the coastline26 23 !!---------------------------------------------------------------------- 27 24 USE oce ! ocean: variables … … 39 36 USE wrk_nemo ! Memory allocation 40 37 USE timing ! Timing 38 USE iom 41 39 42 40 IMPLICIT NONE … … 45 43 PUBLIC tra_dmp ! routine called by step.F90 46 44 PUBLIC tra_dmp_init ! routine called by opa.F90 47 PUBLIC dtacof ! routine called by tradmp.F90, trcdmp.F90 and dyndmp.F9048 PUBLIC dtacof_zoom ! routine called by tradmp.F90, trcdmp.F90 and dyndmp.F9049 50 !!gm why all namelist variable public???? only ln_tradmp should be sufficient51 45 52 46 ! !!* Namelist namtra_dmp : T & S newtonian damping * 47 ! nn_zdmp and cn_resto are public as they are used by C1D/dyndmp.F90 53 48 LOGICAL , PUBLIC :: ln_tradmp !: internal damping flag 54 INTEGER , PUBLIC :: nn_hdmp ! = 0/-1/'latitude' for damping over T and S55 49 INTEGER , PUBLIC :: nn_zdmp ! = 0/1/2 flag for damping in the mixed layer 56 REAL(wp), PUBLIC :: rn_surf ! surface time scale for internal damping [days] 57 REAL(wp), PUBLIC :: rn_bot ! bottom time scale for internal damping [days] 58 REAL(wp), PUBLIC :: rn_dep ! depth of transition between rn_surf and rn_bot [meters] 59 INTEGER , PUBLIC :: nn_file ! = 1 create a damping.coeff NetCDF file 50 CHARACTER(LEN=200) , PUBLIC :: cn_resto ! name of netcdf file containing restoration coefficient field 51 ! 52 60 53 61 54 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: strdmp !: damping salinity trend (psu/s) … … 197 190 !! ** Method : read the namtra_dmp namelist and check the parameters 198 191 !!---------------------------------------------------------------------- 199 INTEGER :: ios ! Local integer output status for namelist read 200 !! 201 NAMELIST/namtra_dmp/ ln_tradmp, nn_hdmp, nn_zdmp, rn_surf, rn_bot, rn_dep, nn_file 202 !!---------------------------------------------------------------------- 203 ! 204 REWIND( numnam_ref ) ! Namelist namtra_dmp in reference namelist : Temperature and salinity damping term 192 NAMELIST/namtra_dmp/ ln_tradmp, nn_zdmp, cn_resto 193 INTEGER :: ios ! Local integer for output status of namelist read 194 INTEGER :: imask ! File handle 195 !! 196 !!---------------------------------------------------------------------- 197 ! 198 REWIND( numnam_ref ) ! Namelist namtra_dmp in reference namelist : T & S relaxation 205 199 READ ( numnam_ref, namtra_dmp, IOSTAT = ios, ERR = 901) 206 200 901 IF( ios /= 0 ) CALL ctl_nam ( ios , 'namtra_dmp in reference namelist', lwp ) 207 201 ! 208 REWIND( numnam_cfg ) ! Namelist namtra_dmp in configuration namelist : Temperature and salinity damping term202 REWIND( numnam_cfg ) ! Namelist namtra_dmp in configuration namelist : T & S relaxation 209 203 READ ( numnam_cfg, namtra_dmp, IOSTAT = ios, ERR = 902 ) 210 204 902 IF( ios /= 0 ) CALL ctl_nam ( ios , 'namtra_dmp in configuration namelist', lwp ) 211 205 IF(lwm) WRITE ( numond, namtra_dmp ) 212 213 IF( lzoom .AND. .NOT. lk_c1d ) nn_zdmp = 0 ! restoring to climatology at closed north or south boundaries 214 215 IF(lwp) THEN ! Namelist print 206 207 IF(lwp) THEN !Namelist print 216 208 WRITE(numout,*) 217 WRITE(numout,*) 'tra_dmp_init : T and S newtonian damping'209 WRITE(numout,*) 'tra_dmp_init : T and S newtonian relaxation' 218 210 WRITE(numout,*) '~~~~~~~' 219 WRITE(numout,*) ' Namelist namtra_dmp : set damping parameter' 220 WRITE(numout,*) ' add a damping term or not ln_tradmp = ', ln_tradmp 221 WRITE(numout,*) ' T and S damping option nn_hdmp = ', nn_hdmp 222 WRITE(numout,*) ' mixed layer damping option nn_zdmp = ', nn_zdmp, '(non-C1D zoom: forced to 0)' 223 WRITE(numout,*) ' surface time scale (days) rn_surf = ', rn_surf 224 WRITE(numout,*) ' bottom time scale (days) rn_bot = ', rn_bot 225 WRITE(numout,*) ' depth of transition (meters) rn_dep = ', rn_dep 226 WRITE(numout,*) ' create a damping.coeff file nn_file = ', nn_file 211 WRITE(numout,*) ' Namelist namtra_dmp : set relaxation parameters' 212 WRITE(numout,*) ' Apply relaxation or not ln_tradmp = ', ln_tradmp 213 WRITE(numout,*) ' mixed layer damping option nn_zdmp = ', nn_zdmp 214 WRITE(numout,*) ' Damping file name cn_resto = ', cn_resto 227 215 WRITE(numout,*) 228 216 ENDIF 229 217 230 IF( ln_tradmp ) THEN ! initialization for T-S damping 231 ! 218 IF( ln_tradmp) THEN 219 ! 220 !Allocate arrays 232 221 IF( tra_dmp_alloc() /= 0 ) CALL ctl_stop( 'STOP', 'tra_dmp_init: unable to allocate arrays' ) 233 ! 234 !!gm I don't understand the specificities of c1d case...... 235 !!gm to be check with the autor of these lines 236 237 #if ! defined key_c1d 238 SELECT CASE ( nn_hdmp ) 239 CASE ( -1 ) ; IF(lwp) WRITE(numout,*) ' tracer damping in the Med & Red seas only' 240 CASE ( 1:90 ) ; IF(lwp) WRITE(numout,*) ' tracer damping poleward of', nn_hdmp, ' degrees' 241 CASE DEFAULT 242 WRITE(ctmp1,*) ' bad flag value for nn_hdmp = ', nn_hdmp 243 CALL ctl_stop(ctmp1) 222 223 !Check values of nn_zdmp 224 SELECT CASE (nn_zdmp) 225 CASE ( 0 ) ; IF(lwp) WRITE(numout,*) ' tracer damping as specified by mask' 226 CASE ( 1 ) ; IF(lwp) WRITE(numout,*) ' no tracer damping in the turbocline' 227 CASE ( 2 ) ; IF(lwp) WRITE(numout,*) ' no tracer damping in the mixed layer' 244 228 END SELECT 245 ! 246 #endif 247 SELECT CASE ( nn_zdmp ) 248 CASE ( 0 ) ; IF(lwp) WRITE(numout,*) ' tracer damping throughout the water column' 249 CASE ( 1 ) ; IF(lwp) WRITE(numout,*) ' no tracer damping in the turbocline (avt > 5 cm2/s)' 250 CASE ( 2 ) ; IF(lwp) WRITE(numout,*) ' no tracer damping in the mixed layer' 251 CASE DEFAULT 252 WRITE(ctmp1,*) 'bad flag value for nn_zdmp = ', nn_zdmp 253 CALL ctl_stop(ctmp1) 254 END SELECT 255 ! 229 230 !TG: Initialisation of dtatsd - Would it be better to have dmpdta routine 231 !so can damp to something other than intitial conditions files? 256 232 IF( .NOT.ln_tsd_tradmp ) THEN 257 233 CALL ctl_warn( 'tra_dmp_init: read T-S data not initialized, we force ln_tsd_tradmp=T' ) 258 234 CALL dta_tsd_init( ld_tradmp=ln_tradmp ) ! forces the initialisation of T-S data 259 235 ENDIF 260 ! 261 strdmp(:,:,:) = 0._wp ! internal damping salinity trend (used in asmtrj) 236 237 !initialise arrays - Are these actually used anywhere else? 238 strdmp(:,:,:) = 0._wp 262 239 ttrdmp(:,:,:) = 0._wp 263 ! ! Damping coefficients initialization 264 IF( lzoom .AND. .NOT. lk_c1d ) THEN ; CALL dtacof_zoom( resto )265 ELSE ; CALL dtacof( nn_hdmp, rn_surf, rn_bot, rn_dep, nn_file, 'TRA', resto)266 ENDIF267 !268 ENDIF269 ! 240 241 !Read in mask from file 242 CALL iom_open ( cn_resto, imask) 243 CALL iom_get ( imask, jpdom_autoglo, 'resto', resto) 244 CALL iom_close( imask ) 245 ENDIF 246 270 247 END SUBROUTINE tra_dmp_init 271 248 272 273 SUBROUTINE dtacof_zoom( presto )274 !!----------------------------------------------------------------------275 !! *** ROUTINE dtacof_zoom ***276 !!277 !! ** Purpose : Compute the damping coefficient for zoom domain278 !!279 !! ** Method : - set along closed boundary due to zoom a damping over280 !! 6 points with a max time scale of 5 days.281 !! - ORCA arctic/antarctic zoom: set the damping along282 !! south/north boundary over a latitude strip.283 !!284 !! ** Action : - resto, the damping coeff. for T and S285 !!----------------------------------------------------------------------286 REAL(wp), DIMENSION(jpi,jpj,jpk), INTENT(inout) :: presto ! restoring coeff. (s-1)287 !288 INTEGER :: ji, jj, jk, jn ! dummy loop indices289 REAL(wp) :: zlat, zlat0, zlat1, zlat2, z1_5d ! local scalar290 REAL(wp), DIMENSION(6) :: zfact ! 1Dworkspace291 !!----------------------------------------------------------------------292 !293 IF( nn_timing == 1 ) CALL timing_start( 'dtacof_zoom')294 !295 296 zfact(1) = 1._wp297 zfact(2) = 1._wp298 zfact(3) = 11._wp / 12._wp299 zfact(4) = 8._wp / 12._wp300 zfact(5) = 4._wp / 12._wp301 zfact(6) = 1._wp / 12._wp302 zfact(:) = zfact(:) / ( 5._wp * rday ) ! 5 days max restoring time scale303 304 presto(:,:,:) = 0._wp305 306 ! damping along the forced closed boundary over 6 grid-points307 DO jn = 1, 6308 IF( lzoom_w ) presto( mi0(jn+jpizoom):mi1(jn+jpizoom), : , : ) = zfact(jn) ! west closed309 IF( lzoom_s ) presto( : , mj0(jn+jpjzoom):mj1(jn+jpjzoom), : ) = zfact(jn) ! south closed310 IF( lzoom_e ) presto( mi0(jpiglo+jpizoom-1-jn):mi1(jpiglo+jpizoom-1-jn) , : , : ) = zfact(jn) ! east closed311 IF( lzoom_n ) presto( : , mj0(jpjglo+jpjzoom-1-jn):mj1(jpjglo+jpjzoom-1-jn) , : ) = zfact(jn) ! north closed312 END DO313 314 ! ! ====================================================315 IF( cp_cfz == "arctic" .OR. cp_cfz == "antarctic" ) THEN ! ORCA configuration : arctic or antarctic zoom316 ! ! ====================================================317 IF(lwp) WRITE(numout,*)318 IF(lwp .AND. cp_cfz == "arctic" ) WRITE(numout,*) ' dtacof_zoom : ORCA Arctic zoom'319 IF(lwp .AND. cp_cfz == "antarctic" ) WRITE(numout,*) ' dtacof_zoom : ORCA Antarctic zoom'320 IF(lwp) WRITE(numout,*)321 !322 ! ! Initialization :323 presto(:,:,:) = 0._wp324 zlat0 = 10._wp ! zlat0 : latitude strip where resto decreases325 zlat1 = 30._wp ! zlat1 : resto = 1 before zlat1326 zlat2 = zlat1 + zlat0 ! zlat2 : resto decreases from 1 to 0 between zlat1 and zlat2327 z1_5d = 1._wp / ( 5._wp * rday ) ! z1_5d : 1 / 5days328 329 DO jk = 2, jpkm1 ! Compute arrays resto ; value for internal damping : 5 days330 DO jj = 1, jpj331 DO ji = 1, jpi332 zlat = ABS( gphit(ji,jj) )333 IF( zlat1 <= zlat .AND. zlat <= zlat2 ) THEN334 presto(ji,jj,jk) = 0.5_wp * z1_5d * ( 1._wp - COS( rpi*(zlat2-zlat)/zlat0 ) )335 ELSEIF( zlat < zlat1 ) THEN336 presto(ji,jj,jk) = z1_5d337 ENDIF338 END DO339 END DO340 END DO341 !342 ENDIF343 ! ! Mask resto array344 presto(:,:,:) = presto(:,:,:) * tmask(:,:,:)345 !346 IF( nn_timing == 1 ) CALL timing_stop( 'dtacof_zoom')347 !348 END SUBROUTINE dtacof_zoom349 350 351 SUBROUTINE dtacof( kn_hdmp, pn_surf, pn_bot, pn_dep, &352 & kn_file, cdtype , presto )353 !!----------------------------------------------------------------------354 !! *** ROUTINE dtacof ***355 !!356 !! ** Purpose : Compute the damping coefficient357 !!358 !! ** Method : Arrays defining the damping are computed for each grid359 !! point for temperature and salinity (resto)360 !! Damping depends on distance to coast, depth and latitude361 !!362 !! ** Action : - resto, the damping coeff. for T and S363 !!----------------------------------------------------------------------364 USE iom365 USE ioipsl366 !!367 INTEGER , INTENT(in ) :: kn_hdmp ! damping option368 REAL(wp) , INTENT(in ) :: pn_surf ! surface time scale (days)369 REAL(wp) , INTENT(in ) :: pn_bot ! bottom time scale (days)370 REAL(wp) , INTENT(in ) :: pn_dep ! depth of transition (meters)371 INTEGER , INTENT(in ) :: kn_file ! save the damping coef on a file or not372 CHARACTER(len=3) , INTENT(in ) :: cdtype ! =TRA, TRC or DYN (tracer/dynamics indicator)373 REAL(wp), DIMENSION(jpi,jpj,jpk), INTENT(inout) :: presto ! restoring coeff. (s-1)374 !375 INTEGER :: ji, jj, jk ! dummy loop indices376 INTEGER :: ii0, ii1, ij0, ij1 ! local integers377 INTEGER :: inum0, icot ! - -378 REAL(wp) :: zinfl, zlon ! local scalars379 REAL(wp) :: zlat, zlat0, zlat1, zlat2 ! - -380 REAL(wp) :: zsdmp, zbdmp ! - -381 CHARACTER(len=20) :: cfile382 REAL(wp), POINTER, DIMENSION(: ) :: zhfac383 REAL(wp), POINTER, DIMENSION(:,: ) :: zmrs384 REAL(wp), POINTER, DIMENSION(:,:,:) :: zdct385 !!----------------------------------------------------------------------386 !387 IF( nn_timing == 1 ) CALL timing_start('dtacof')388 !389 CALL wrk_alloc( jpk, zhfac )390 CALL wrk_alloc( jpi, jpj, zmrs )391 CALL wrk_alloc( jpi, jpj, jpk, zdct )392 #if defined key_c1d393 ! ! ====================394 ! ! C1D configuration : local domain395 ! ! ====================396 !397 IF(lwp) WRITE(numout,*)398 IF(lwp) WRITE(numout,*) ' dtacof : C1D 3x3 local domain'399 IF(lwp) WRITE(numout,*) ' -----------------------------'400 !401 presto(:,:,:) = 0._wp402 !403 zsdmp = 1._wp / ( pn_surf * rday )404 zbdmp = 1._wp / ( pn_bot * rday )405 DO jk = 2, jpkm1406 DO jj = 1, jpj407 DO ji = 1, jpi408 ! ONLY vertical variation from zsdmp (sea surface) to zbdmp (bottom)409 presto(ji,jj,jk) = zbdmp + (zsdmp-zbdmp) * EXP(-fsdept(ji,jj,jk)/pn_dep)410 END DO411 END DO412 END DO413 !414 presto(:,:, : ) = presto(:,:,:) * tmask(:,:,:)415 #else416 ! ! ====================417 ! ! ORCA configuration : global domain418 ! ! ====================419 !420 IF(lwp) WRITE(numout,*)421 IF(lwp) WRITE(numout,*) ' dtacof : Global domain of ORCA'422 IF(lwp) WRITE(numout,*) ' ------------------------------'423 !424 presto(:,:,:) = 0._wp425 !426 IF( kn_hdmp > 0 ) THEN ! Damping poleward of 'nn_hdmp' degrees !427 ! !-----------------------------------------!428 IF(lwp) WRITE(numout,*)429 IF(lwp) WRITE(numout,*) ' Damping poleward of ', kn_hdmp, ' deg.'430 !431 CALL iom_open ( 'dist.coast.nc', icot, ldstop = .FALSE. )432 !433 IF( icot > 0 ) THEN ! distance-to-coast read in file434 CALL iom_get ( icot, jpdom_data, 'Tcoast', zdct )435 CALL iom_close( icot )436 ELSE ! distance-to-coast computed and saved in file (output in zdct)437 CALL cofdis( zdct )438 ENDIF439 440 ! ! Compute arrays resto441 zinfl = 1000.e3_wp ! distance of influence for damping term442 zlat0 = 10._wp ! latitude strip where resto decreases443 zlat1 = REAL( kn_hdmp ) ! resto = 0 between -zlat1 and zlat1444 zlat2 = zlat1 + zlat0 ! resto increases from 0 to 1 between |zlat1| and |zlat2|445 446 DO jj = 1, jpj447 DO ji = 1, jpi448 zlat = ABS( gphit(ji,jj) )449 IF ( zlat1 <= zlat .AND. zlat <= zlat2 ) THEN450 presto(ji,jj,1) = 0.5_wp * ( 1._wp - COS( rpi*(zlat-zlat1)/zlat0 ) )451 ELSEIF ( zlat > zlat2 ) THEN452 presto(ji,jj,1) = 1._wp453 ENDIF454 END DO455 END DO456 457 IF ( kn_hdmp == 20 ) THEN ! North Indian ocean (20N/30N x 45E/100E) : resto=0458 DO jj = 1, jpj459 DO ji = 1, jpi460 zlat = gphit(ji,jj)461 zlon = MOD( glamt(ji,jj), 360._wp )462 IF ( zlat1 < zlat .AND. zlat < zlat2 .AND. 45._wp < zlon .AND. zlon < 100._wp ) THEN463 presto(ji,jj,1) = 0._wp464 ENDIF465 END DO466 END DO467 ENDIF468 469 zsdmp = 1._wp / ( pn_surf * rday )470 zbdmp = 1._wp / ( pn_bot * rday )471 DO jk = 2, jpkm1472 DO jj = 1, jpj473 DO ji = 1, jpi474 zdct(ji,jj,jk) = MIN( zinfl, zdct(ji,jj,jk) )475 ! ... Decrease the value in the vicinity of the coast476 presto(ji,jj,jk) = presto(ji,jj,1 ) * 0.5_wp * ( 1._wp - COS( rpi*zdct(ji,jj,jk)/zinfl) )477 ! ... Vertical variation from zsdmp (sea surface) to zbdmp (bottom)478 presto(ji,jj,jk) = presto(ji,jj,jk) * ( zbdmp + (zsdmp-zbdmp) * EXP(-fsdept(ji,jj,jk)/pn_dep) )479 END DO480 END DO481 END DO482 !483 ENDIF484 485 ! ! =========================486 ! ! Med and Red Sea damping (ORCA configuration only)487 ! ! =========================488 IF( cp_cfg == "orca" .AND. ( kn_hdmp > 0 .OR. kn_hdmp == -1 ) ) THEN489 IF(lwp)WRITE(numout,*)490 IF(lwp)WRITE(numout,*) ' ORCA configuration: Damping in Med and Red Seas'491 !492 zmrs(:,:) = 0._wp493 !494 SELECT CASE ( jp_cfg )495 ! ! =======================496 CASE ( 4 ) ! ORCA_R4 configuration497 ! ! =======================498 ij0 = 50 ; ij1 = 56 ! Mediterranean Sea499 500 ii0 = 81 ; ii1 = 91 ; zmrs( mi0(ii0):mi1(ii1) , mj0(ij0):mj1(ij1) ) = 1._wp501 ij0 = 50 ; ij1 = 55502 ii0 = 75 ; ii1 = 80 ; zmrs( mi0(ii0):mi1(ii1) , mj0(ij0):mj1(ij1) ) = 1._wp503 ij0 = 52 ; ij1 = 53504 ii0 = 70 ; ii1 = 74 ; zmrs( mi0(ii0):mi1(ii1) , mj0(ij0):mj1(ij1) ) = 1._wp505 ! Smooth transition from 0 at surface to 1./rday at the 18th level in Med and Red Sea506 DO jk = 1, 17507 zhfac (jk) = 0.5_wp * ( 1._wp - COS( rpi * REAL(jk-1,wp) / 16._wp ) ) / rday508 END DO509 DO jk = 18, jpkm1510 zhfac (jk) = 1._wp / rday511 END DO512 ! ! =======================513 CASE ( 2 ) ! ORCA_R2 configuration514 ! ! =======================515 ij0 = 96 ; ij1 = 110 ! Mediterranean Sea516 ii0 = 157 ; ii1 = 181 ; zmrs( mi0(ii0):mi1(ii1) , mj0(ij0):mj1(ij1) ) = 1._wp517 ij0 = 100 ; ij1 = 110518 ii0 = 144 ; ii1 = 156 ; zmrs( mi0(ii0):mi1(ii1) , mj0(ij0):mj1(ij1) ) = 1._wp519 ij0 = 100 ; ij1 = 103520 ii0 = 139 ; ii1 = 143 ; zmrs( mi0(ii0):mi1(ii1) , mj0(ij0):mj1(ij1) ) = 1._wp521 !522 ij0 = 101 ; ij1 = 102 ! Decrease before Gibraltar Strait523 ii0 = 139 ; ii1 = 141 ; zmrs( mi0(ii0):mi1(ii1) , mj0(ij0):mj1(ij1) ) = 0._wp524 ii0 = 142 ; ii1 = 142 ; zmrs( mi0(ii0):mi1(ii1) , mj0(ij0):mj1(ij1) ) = 1._wp / 90._wp525 ii0 = 143 ; ii1 = 143 ; zmrs( mi0(ii0):mi1(ii1) , mj0(ij0):mj1(ij1) ) = 0.40_wp526 ii0 = 144 ; ii1 = 144 ; zmrs( mi0(ii0):mi1(ii1) , mj0(ij0):mj1(ij1) ) = 0.75_wp527 !528 ij0 = 87 ; ij1 = 96 ! Red Sea529 ii0 = 147 ; ii1 = 163 ; zmrs( mi0(ii0):mi1(ii1) , mj0(ij0):mj1(ij1) ) = 1._wp530 !531 ij0 = 91 ; ij1 = 91 ! Decrease before Bab el Mandeb Strait532 ii0 = 153 ; ii1 = 160 ; zmrs( mi0(ii0):mi1(ii1) , mj0(ij0):mj1(ij1) ) = 0.80_wp533 ij0 = 90 ; ij1 = 90534 ii0 = 153 ; ii1 = 160 ; zmrs( mi0(ii0):mi1(ii1) , mj0(ij0):mj1(ij1) ) = 0.40_wp535 ij0 = 89 ; ij1 = 89536 ii0 = 158 ; ii1 = 160 ; zmrs( mi0(ii0):mi1(ii1) , mj0(ij0):mj1(ij1) ) = 1._wp / 90._wp537 ij0 = 88 ; ij1 = 88538 ii0 = 160 ; ii1 = 163 ; zmrs( mi0(ii0):mi1(ii1) , mj0(ij0):mj1(ij1) ) = 0._wp539 ! Smooth transition from 0 at surface to 1./rday at the 18th level in Med and Red Sea540 DO jk = 1, 17541 zhfac (jk) = 0.5_wp * ( 1._wp - COS( rpi * REAL(jk-1,wp) / 16._wp ) ) / rday542 END DO543 DO jk = 18, jpkm1544 zhfac (jk) = 1._wp / rday545 END DO546 ! ! =======================547 CASE ( 05 ) ! ORCA_R05 configuration548 ! ! =======================549 ii0 = 568 ; ii1 = 574 ! Mediterranean Sea550 ij0 = 324 ; ij1 = 333 ; zmrs( mi0(ii0):mi1(ii1) , mj0(ij0):mj1(ij1) ) = 1._wp551 ii0 = 575 ; ii1 = 658552 ij0 = 314 ; ij1 = 366 ; zmrs( mi0(ii0):mi1(ii1) , mj0(ij0):mj1(ij1) ) = 1._wp553 !554 ii0 = 641 ; ii1 = 651 ! Black Sea (remaining part555 ij0 = 367 ; ij1 = 372 ; zmrs( mi0(ii0):mi1(ii1) , mj0(ij0):mj1(ij1) ) = 1._wp556 !557 ij0 = 324 ; ij1 = 333 ! Decrease before Gibraltar Strait558 ii0 = 565 ; ii1 = 565 ; zmrs( mi0(ii0):mi1(ii1) , mj0(ij0):mj1(ij1) ) = 1._wp / 90._wp559 ii0 = 566 ; ii1 = 566 ; zmrs( mi0(ii0):mi1(ii1) , mj0(ij0):mj1(ij1) ) = 0.40_wp560 ii0 = 567 ; ii1 = 567 ; zmrs( mi0(ii0):mi1(ii1) , mj0(ij0):mj1(ij1) ) = 0.75_wp561 !562 ii0 = 641 ; ii1 = 665 ! Red Sea563 ij0 = 270 ; ij1 = 310 ; zmrs( mi0(ii0):mi1(ii1) , mj0(ij0):mj1(ij1) ) = 1._wp564 !565 ii0 = 666 ; ii1 = 675 ! Decrease before Bab el Mandeb Strait566 ij0 = 270 ; ij1 = 290567 DO ji = mi0(ii0), mi1(ii1)568 zmrs( ji , mj0(ij0):mj1(ij1) ) = 0.1_wp * ABS( FLOAT(ji - mi1(ii1)) )569 END DO570 zsdmp = 1._wp / ( pn_surf * rday )571 zbdmp = 1._wp / ( pn_bot * rday )572 DO jk = 1, jpk573 zhfac(jk) = ( zbdmp + (zsdmp-zbdmp) * EXP( -fsdept(1,1,jk)/pn_dep ) )574 END DO575 ! ! ========================576 CASE ( 025 ) ! ORCA_R025 configuration577 ! ! ========================578 CALL ctl_stop( ' Not yet implemented in ORCA_R025' )579 !580 END SELECT581 582 DO jk = 1, jpkm1583 presto(:,:,jk) = zmrs(:,:) * zhfac(jk) + ( 1._wp - zmrs(:,:) ) * presto(:,:,jk)584 END DO585 586 ! Mask resto array and set to 0 first and last levels587 presto(:,:, : ) = presto(:,:,:) * tmask(:,:,:)588 presto(:,:, 1 ) = 0._wp589 presto(:,:,jpk) = 0._wp590 ! !--------------------!591 ELSE ! No damping !592 ! !--------------------!593 CALL ctl_stop( 'Choose a correct value of nn_hdmp or put ln_tradmp to FALSE' )594 ENDIF595 #endif596 597 ! !--------------------------------!598 IF( kn_file == 1 ) THEN ! save damping coef. in a file !599 ! !--------------------------------!600 IF(lwp) WRITE(numout,*) ' create damping.coeff.nc file'601 IF( cdtype == 'TRA' ) cfile = 'damping.coeff'602 IF( cdtype == 'TRC' ) cfile = 'damping.coeff.trc'603 IF( cdtype == 'DYN' ) cfile = 'damping.coeff.dyn'604 cfile = TRIM( cfile )605 CALL iom_open ( cfile, inum0, ldwrt = .TRUE., kiolib = jprstlib )606 CALL iom_rstput( 0, 0, inum0, 'Resto', presto )607 CALL iom_close ( inum0 )608 ENDIF609 !610 CALL wrk_dealloc( jpk, zhfac)611 CALL wrk_dealloc( jpi, jpj, zmrs )612 CALL wrk_dealloc( jpi, jpj, jpk, zdct )613 !614 IF( nn_timing == 1 ) CALL timing_stop('dtacof')615 !616 END SUBROUTINE dtacof617 618 619 SUBROUTINE cofdis( pdct )620 !!----------------------------------------------------------------------621 !! *** ROUTINE cofdis ***622 !!623 !! ** Purpose : Compute the distance between ocean T-points and the624 !! ocean model coastlines. Save the distance in a NetCDF file.625 !!626 !! ** Method : For each model level, the distance-to-coast is627 !! computed as follows :628 !! - The coastline is defined as the serie of U-,V-,F-points629 !! that are at the ocean-land bound.630 !! - For each ocean T-point, the distance-to-coast is then631 !! computed as the smallest distance (on the sphere) between the632 !! T-point and all the coastline points.633 !! - For land T-points, the distance-to-coast is set to zero.634 !! C A U T I O N : Computation not yet implemented in mpp case.635 !!636 !! ** Action : - pdct, distance to the coastline (argument)637 !! - NetCDF file 'dist.coast.nc'638 !!----------------------------------------------------------------------639 USE ioipsl ! IOipsl librairy640 !!641 REAL(wp), DIMENSION(jpi,jpj,jpk), INTENT( out ) :: pdct ! distance to the coastline642 !!643 INTEGER :: ji, jj, jk, jl ! dummy loop indices644 INTEGER :: iju, ijt, icoast, itime, ierr, icot ! local integers645 CHARACTER (len=32) :: clname ! local name646 REAL(wp) :: zdate0 ! local scalar647 REAL(wp), POINTER, DIMENSION(:,:) :: zxt, zyt, zzt, zmask648 REAL(wp), POINTER, DIMENSION(: ) :: zxc, zyc, zzc, zdis ! temporary workspace649 LOGICAL , ALLOCATABLE, DIMENSION(:,:) :: llcotu, llcotv, llcotf ! 2D logical workspace650 !!----------------------------------------------------------------------651 !652 IF( nn_timing == 1 ) CALL timing_start('cofdis')653 !654 CALL wrk_alloc( jpi, jpj , zxt, zyt, zzt, zmask )655 CALL wrk_alloc( 3*jpi*jpj, zxc, zyc, zzc, zdis )656 ALLOCATE( llcotu(jpi,jpj), llcotv(jpi,jpj), llcotf(jpi,jpj) )657 !658 IF( lk_mpp ) CALL mpp_sum( ierr )659 IF( ierr /= 0 ) CALL ctl_stop( 'STOP', 'cofdis: requested local arrays unavailable')660 661 ! 0. Initialization662 ! -----------------663 IF(lwp) WRITE(numout,*)664 IF(lwp) WRITE(numout,*) 'cofdis : compute the distance to coastline'665 IF(lwp) WRITE(numout,*) '~~~~~~'666 IF(lwp) WRITE(numout,*)667 IF( lk_mpp ) &668 & CALL ctl_stop(' Computation not yet implemented with key_mpp_...', &669 & ' Rerun the code on another computer or ', &670 & ' create the "dist.coast.nc" file using IDL' )671 672 pdct(:,:,:) = 0._wp673 zxt(:,:) = COS( rad * gphit(:,:) ) * COS( rad * glamt(:,:) )674 zyt(:,:) = COS( rad * gphit(:,:) ) * SIN( rad * glamt(:,:) )675 zzt(:,:) = SIN( rad * gphit(:,:) )676 677 678 ! 1. Loop on vertical levels679 ! --------------------------680 ! ! ===============681 DO jk = 1, jpkm1 ! Horizontal slab682 ! ! ===============683 ! Define the coastline points (U, V and F)684 DO jj = 2, jpjm1685 DO ji = 2, jpim1686 zmask(ji,jj) = ( tmask(ji,jj+1,jk) + tmask(ji+1,jj+1,jk) &687 & + tmask(ji,jj ,jk) + tmask(ji+1,jj ,jk) )688 llcotu(ji,jj) = ( tmask(ji,jj, jk) + tmask(ji+1,jj ,jk) == 1._wp )689 llcotv(ji,jj) = ( tmask(ji,jj ,jk) + tmask(ji ,jj+1,jk) == 1._wp )690 llcotf(ji,jj) = ( zmask(ji,jj) > 0._wp ) .AND. ( zmask(ji,jj) < 4._wp )691 END DO692 END DO693 694 ! Lateral boundaries conditions695 llcotu(:, 1 ) = umask(:, 2 ,jk) == 1696 llcotu(:,jpj) = umask(:,jpjm1,jk) == 1697 llcotv(:, 1 ) = vmask(:, 2 ,jk) == 1698 llcotv(:,jpj) = vmask(:,jpjm1,jk) == 1699 llcotf(:, 1 ) = fmask(:, 2 ,jk) == 1700 llcotf(:,jpj) = fmask(:,jpjm1,jk) == 1701 702 IF( nperio == 1 .OR. nperio == 4 .OR. nperio == 6 ) THEN703 llcotu( 1 ,:) = llcotu(jpim1,:)704 llcotu(jpi,:) = llcotu( 2 ,:)705 llcotv( 1 ,:) = llcotv(jpim1,:)706 llcotv(jpi,:) = llcotv( 2 ,:)707 llcotf( 1 ,:) = llcotf(jpim1,:)708 llcotf(jpi,:) = llcotf( 2 ,:)709 ELSE710 llcotu( 1 ,:) = umask( 2 ,:,jk) == 1711 llcotu(jpi,:) = umask(jpim1,:,jk) == 1712 llcotv( 1 ,:) = vmask( 2 ,:,jk) == 1713 llcotv(jpi,:) = vmask(jpim1,:,jk) == 1714 llcotf( 1 ,:) = fmask( 2 ,:,jk) == 1715 llcotf(jpi,:) = fmask(jpim1,:,jk) == 1716 ENDIF717 IF( nperio == 3 .OR. nperio == 4 ) THEN718 DO ji = 1, jpim1719 iju = jpi - ji + 1720 llcotu(ji,jpj ) = llcotu(iju,jpj-2)721 llcotf(ji,jpjm1) = llcotf(iju,jpj-2)722 llcotf(ji,jpj ) = llcotf(iju,jpj-3)723 END DO724 DO ji = jpi/2, jpim1725 iju = jpi - ji + 1726 llcotu(ji,jpjm1) = llcotu(iju,jpjm1)727 END DO728 DO ji = 2, jpi729 ijt = jpi - ji + 2730 llcotv(ji,jpjm1) = llcotv(ijt,jpj-2)731 llcotv(ji,jpj ) = llcotv(ijt,jpj-3)732 END DO733 ENDIF734 IF( nperio == 5 .OR. nperio == 6 ) THEN735 DO ji = 1, jpim1736 iju = jpi - ji737 llcotu(ji,jpj ) = llcotu(iju,jpjm1)738 llcotf(ji,jpj ) = llcotf(iju,jpj-2)739 END DO740 DO ji = jpi/2, jpim1741 iju = jpi - ji742 llcotf(ji,jpjm1) = llcotf(iju,jpjm1)743 END DO744 DO ji = 1, jpi745 ijt = jpi - ji + 1746 llcotv(ji,jpj ) = llcotv(ijt,jpjm1)747 END DO748 DO ji = jpi/2+1, jpi749 ijt = jpi - ji + 1750 llcotv(ji,jpjm1) = llcotv(ijt,jpjm1)751 END DO752 ENDIF753 754 ! Compute cartesian coordinates of coastline points755 ! and the number of coastline points756 icoast = 0757 DO jj = 1, jpj758 DO ji = 1, jpi759 IF( llcotf(ji,jj) ) THEN760 icoast = icoast + 1761 zxc(icoast) = COS( rad*gphif(ji,jj) ) * COS( rad*glamf(ji,jj) )762 zyc(icoast) = COS( rad*gphif(ji,jj) ) * SIN( rad*glamf(ji,jj) )763 zzc(icoast) = SIN( rad*gphif(ji,jj) )764 ENDIF765 IF( llcotu(ji,jj) ) THEN766 icoast = icoast+1767 zxc(icoast) = COS( rad*gphiu(ji,jj) ) * COS( rad*glamu(ji,jj) )768 zyc(icoast) = COS( rad*gphiu(ji,jj) ) * SIN( rad*glamu(ji,jj) )769 zzc(icoast) = SIN( rad*gphiu(ji,jj) )770 ENDIF771 IF( llcotv(ji,jj) ) THEN772 icoast = icoast+1773 zxc(icoast) = COS( rad*gphiv(ji,jj) ) * COS( rad*glamv(ji,jj) )774 zyc(icoast) = COS( rad*gphiv(ji,jj) ) * SIN( rad*glamv(ji,jj) )775 zzc(icoast) = SIN( rad*gphiv(ji,jj) )776 ENDIF777 END DO778 END DO779 780 ! Distance for the T-points781 DO jj = 1, jpj782 DO ji = 1, jpi783 IF( tmask(ji,jj,jk) == 0._wp ) THEN784 pdct(ji,jj,jk) = 0._wp785 ELSE786 DO jl = 1, icoast787 zdis(jl) = ( zxt(ji,jj) - zxc(jl) )**2 &788 & + ( zyt(ji,jj) - zyc(jl) )**2 &789 & + ( zzt(ji,jj) - zzc(jl) )**2790 END DO791 pdct(ji,jj,jk) = ra * SQRT( MINVAL( zdis(1:icoast) ) )792 ENDIF793 END DO794 END DO795 ! ! ===============796 END DO ! End of slab797 ! ! ===============798 799 800 ! 2. Create the distance to the coast file in NetCDF format801 ! ----------------------------------------------------------802 clname = 'dist.coast'803 itime = 0804 CALL ymds2ju( 0 , 1 , 1 , 0._wp , zdate0 )805 CALL restini( 'NONE', jpi , jpj , glamt, gphit , &806 & jpk , gdept_1d, clname, itime, zdate0, &807 & rdt , icot )808 CALL restput( icot, 'Tcoast', jpi, jpj, jpk, 0, pdct )809 CALL restclo( icot )810 !811 CALL wrk_dealloc( jpi, jpj , zxt, zyt, zzt, zmask )812 CALL wrk_dealloc( 3*jpi*jpj, zxc, zyc, zzc, zdis )813 DEALLOCATE( llcotu, llcotv, llcotf )814 !815 IF( nn_timing == 1 ) CALL timing_stop('cofdis')816 !817 END SUBROUTINE cofdis818 !!======================================================================819 249 END MODULE tradmp -
branches/2014/dev_r4621_NOC4_BDY_VERT_INTERP/NEMOGCM/NEMO/OPA_SRC/TRA/traldf.F90
r5038 r5620 290 290 IF(lwp) WRITE(numout,*) ' homogeneous ocean T = ', zt0, ' S = ',zs0 291 291 292 ! Initialisation of gtui/gtvi in case of no cavity 293 IF ( .NOT. ln_isfcav ) THEN 294 gtui(:,:,:) = 0.0_wp 295 gtvi(:,:,:) = 0.0_wp 296 END IF 292 297 ! ! T & S profile (to be coded +namelist parameter 293 298 -
branches/2014/dev_r4621_NOC4_BDY_VERT_INTERP/NEMOGCM/NEMO/OPA_SRC/TRA/traldf_bilap.F90
r5038 r5620 116 116 END DO 117 117 END DO 118 119 118 ! !== Laplacian ==! 120 119 ! … … 125 124 END DO 126 125 END DO 126 ! 127 127 IF( ln_zps ) THEN ! set gradient at partial step level (last ocean level) 128 128 DO jj = 1, jpjm1 … … 130 130 IF( mbku(ji,jj) == jk ) ztu(ji,jj,jk) = zeeu(ji,jj) * pgu(ji,jj,jn) 131 131 IF( mbkv(ji,jj) == jk ) ztv(ji,jj,jk) = zeev(ji,jj) * pgv(ji,jj,jn) 132 ! (ISH)133 IF( miku(ji,jj) == jk ) ztu(ji,jj,jk) = zeeu(ji,jj) * pgui(ji,jj,jn)134 IF( mikv(ji,jj) == jk ) ztu(ji,jj,jk) = zeev(ji,jj) * pgvi(ji,jj,jn)135 132 END DO 136 133 END DO 137 134 ENDIF 135 ! (ISH) 136 IF( ln_zps .AND. ln_isfcav ) THEN ! set gradient at partial step level (first ocean level in a cavity) 137 DO jj = 1, jpjm1 138 DO ji = 1, jpim1 139 IF( miku(ji,jj) == MAX(jk,2) ) ztu(ji,jj,jk) = zeeu(ji,jj) * pgui(ji,jj,jn) 140 IF( mikv(ji,jj) == MAX(jk,2) ) ztu(ji,jj,jk) = zeev(ji,jj) * pgvi(ji,jj,jn) 141 END DO 142 END DO 143 ENDIF 144 ! 138 145 DO jj = 2, jpjm1 ! Second derivative (divergence) time the eddy diffusivity coefficient 139 146 DO ji = fs_2, fs_jpim1 ! vector opt. … … 166 173 ! 167 174 ! "zonal" mean lateral diffusive heat and salt transport 168 IF( cdtype == 'TRA' .AND. ln_diaptr .AND. ( MOD( kt, nn_fptr ) == 0 )) THEN169 IF( jn == jp_tem ) htr_ldf(:) = ptr_ vj( ztv(:,:,:) )170 IF( jn == jp_sal ) str_ldf(:) = ptr_ vj( ztv(:,:,:) )175 IF( cdtype == 'TRA' .AND. ln_diaptr ) THEN 176 IF( jn == jp_tem ) htr_ldf(:) = ptr_sj( ztv(:,:,:) ) 177 IF( jn == jp_sal ) str_ldf(:) = ptr_sj( ztv(:,:,:) ) 171 178 ENDIF 172 179 ! ! =========== -
branches/2014/dev_r4621_NOC4_BDY_VERT_INTERP/NEMOGCM/NEMO/OPA_SRC/TRA/traldf_bilapg.F90
r4292 r5620 247 247 ! ! =============== 248 248 ! "Poleward" diffusive heat or salt transport 249 IF( cdtype == 'TRA' .AND. ln_diaptr .AND. ( kaht == 2 ) .AND. ( MOD( kt, nn_fptr ) == 0 )) THEN249 IF( cdtype == 'TRA' .AND. ln_diaptr .AND. ( kaht == 2 ) ) THEN 250 250 ! note sign is reversed to give down-gradient diffusive transports (#1043) 251 IF( jn == jp_tem) htr_ldf(:) = ptr_ vj( -zftv(:,:,:) )252 IF( jn == jp_sal) str_ldf(:) = ptr_ vj( -zftv(:,:,:) )251 IF( jn == jp_tem) htr_ldf(:) = ptr_sj( -zftv(:,:,:) ) 252 IF( jn == jp_sal) str_ldf(:) = ptr_sj( -zftv(:,:,:) ) 253 253 ENDIF 254 254 -
branches/2014/dev_r4621_NOC4_BDY_VERT_INTERP/NEMOGCM/NEMO/OPA_SRC/TRA/traldf_iso.F90
r5038 r5620 28 28 USE in_out_manager ! I/O manager 29 29 USE iom ! I/O library 30 #if defined key_diaar531 30 USE phycst ! physical constants 32 31 USE lbclnk ! ocean lateral boundary conditions (or mpp link) 33 #endif34 32 USE wrk_nemo ! Memory Allocation 35 33 USE timing ! Timing … … 106 104 ! 107 105 INTEGER :: ji, jj, jk, jn ! dummy loop indices 106 INTEGER :: ikt 108 107 REAL(wp) :: zmsku, zabe1, zcof1, zcoef3 ! local scalars 109 108 REAL(wp) :: zmskv, zabe2, zcof2, zcoef4 ! - - 110 109 REAL(wp) :: zcoef0, zbtr, ztra ! - - 111 #if defined key_diaar5112 REAL(wp) :: zztmp ! local scalar113 #endif114 110 REAL(wp), POINTER, DIMENSION(:,: ) :: z2d 115 111 REAL(wp), POINTER, DIMENSION(:,:,:) :: zdkt, zdk1t, zdit, zdjt, ztfw … … 149 145 END DO 150 146 END DO 147 148 ! partial cell correction 151 149 IF( ln_zps ) THEN ! partial steps correction at the last ocean level 152 150 DO jj = 1, jpjm1 153 151 DO ji = 1, fs_jpim1 ! vector opt. 154 152 ! IF useless if zpshde defines pgu everywhere 155 IF (mbku(ji,jj) > 1) zdit(ji,jj,mbku(ji,jj)) = pgu(ji,jj,jn) 156 IF (mbkv(ji,jj) > 1) zdjt(ji,jj,mbkv(ji,jj)) = pgv(ji,jj,jn) 157 ! (ISF) 153 zdit(ji,jj,mbku(ji,jj)) = pgu(ji,jj,jn) 154 zdjt(ji,jj,mbkv(ji,jj)) = pgv(ji,jj,jn) 155 END DO 156 END DO 157 ENDIF 158 IF( ln_zps .AND. ln_isfcav ) THEN ! partial steps correction at the first wet level beneath a cavity 159 DO jj = 1, jpjm1 160 DO ji = 1, fs_jpim1 ! vector opt. 158 161 IF (miku(ji,jj) > 1) zdit(ji,jj,miku(ji,jj)) = pgui(ji,jj,jn) 159 162 IF (mikv(ji,jj) > 1) zdjt(ji,jj,mikv(ji,jj)) = pgvi(ji,jj,jn) 160 163 END DO 161 164 END DO 162 END IF165 END IF 163 166 164 167 !!---------------------------------------------------------------------- 165 168 !! II - horizontal trend (full) 166 169 !!---------------------------------------------------------------------- 167 !CDIR PARALLEL DO PRIVATE( zdk1t ) 168 ! ! =============== 169 DO jj = 1, jpj ! Horizontal slab 170 ! ! =============== 171 DO ji = 1, jpi ! vector opt. 172 DO jk = mikt(ji,jj), jpkm1 173 ! 1. Vertical tracer gradient at level jk and jk+1 174 ! ------------------------------------------------ 175 ! surface boundary condition: zdkt(jk=1)=zdkt(jk=2) 176 zdk1t(ji,jj,jk) = ( ptb(ji,jj,jk,jn) - ptb(ji,jj,jk+1,jn) ) * tmask(ji,jj,jk+1) 177 ! 178 IF( jk == mikt(ji,jj) ) THEN ; zdkt(ji,jj,jk) = zdk1t(ji,jj,jk) 179 ELSE ; zdkt(ji,jj,jk) = ( ptb(ji,jj,jk-1,jn) - ptb(ji,jj,jk,jn) ) * tmask(ji,jj,jk) 180 ENDIF 170 !!!!!!!!!!CDIR PARALLEL DO PRIVATE( zdk1t ) 171 ! 1. Vertical tracer gradient at level jk and jk+1 172 ! ------------------------------------------------ 173 ! 174 ! interior value 175 DO jk = 2, jpkm1 176 DO jj = 1, jpj 177 DO ji = 1, jpi ! vector opt. 178 zdk1t(ji,jj,jk) = ( ptb(ji,jj,jk,jn ) - ptb(ji,jj,jk+1,jn) ) * wmask(ji,jj,jk+1) 179 ! 180 zdkt(ji,jj,jk) = ( ptb(ji,jj,jk-1,jn) - ptb(ji,jj,jk,jn ) ) * wmask(ji,jj,jk) 181 181 END DO 182 182 END DO 183 183 END DO 184 185 ! 2. Horizontal fluxes 186 ! -------------------- 187 DO jj = 1 , jpjm1 188 DO ji = 1, fs_jpim1 ! vector opt. 189 DO jk = mikt(ji,jj), jpkm1 184 ! surface boundary condition: zdkt(jk=1)=zdkt(jk=2) 185 zdk1t(:,:,1) = ( ptb(:,:,1,jn ) - ptb(:,:,2,jn) ) * wmask(:,:,2) 186 zdkt (:,:,1) = zdk1t(:,:,1) 187 IF ( ln_isfcav ) THEN 188 DO jj = 1, jpj 189 DO ji = 1, jpi ! vector opt. 190 ikt = mikt(ji,jj) ! surface level 191 zdk1t(ji,jj,ikt) = ( ptb(ji,jj,ikt,jn ) - ptb(ji,jj,ikt+1,jn) ) * wmask(ji,jj,ikt+1) 192 zdkt (ji,jj,ikt) = zdk1t(ji,jj,ikt) 193 END DO 194 END DO 195 END IF 196 197 ! 2. Horizontal fluxes 198 ! -------------------- 199 DO jk = 1, jpkm1 200 DO jj = 1 , jpjm1 201 DO ji = 1, fs_jpim1 ! vector opt. 190 202 zabe1 = ( fsahtu(ji,jj,jk) + pahtb0 ) * re2u_e1u(ji,jj) * fse3u_n(ji,jj,jk) 191 203 zabe2 = ( fsahtv(ji,jj,jk) + pahtb0 ) * re1v_e2v(ji,jj) * fse3v_n(ji,jj,jk) … … 208 220 END DO 209 221 END DO 210 END DO211 222 212 223 ! II.4 Second derivative (divergence) and add to the general trend 213 224 ! ---------------------------------------------------------------- 214 DO jj = 2 , jpjm1 215 DO ji = fs_2, fs_jpim1 ! vector opt. 216 DO jk = mikt(ji,jj), jpkm1 217 zbtr = 1.0 / ( e1t(ji,jj) * e2t(ji,jj) * fse3t(ji,jj,jk) ) 225 DO jj = 2 , jpjm1 226 DO ji = fs_2, fs_jpim1 ! vector opt. 227 zbtr = 1.0 / ( e12t(ji,jj) * fse3t_n(ji,jj,jk) ) 218 228 ztra = zbtr * ( zftu(ji,jj,jk) - zftu(ji-1,jj,jk) + zftv(ji,jj,jk) - zftv(ji,jj-1,jk) ) 219 229 pta(ji,jj,jk,jn) = pta(ji,jj,jk,jn) + ztra … … 225 235 ! 226 236 ! "Poleward" diffusive heat or salt transports (T-S case only) 227 IF( cdtype == 'TRA' .AND. ln_diaptr .AND. ( MOD( kt, nn_fptr ) == 0 )) THEN237 IF( cdtype == 'TRA' .AND. ln_diaptr ) THEN 228 238 ! note sign is reversed to give down-gradient diffusive transports (#1043) 229 IF( jn == jp_tem) htr_ldf(:) = ptr_ vj( -zftv(:,:,:) )230 IF( jn == jp_sal) str_ldf(:) = ptr_ vj( -zftv(:,:,:) )239 IF( jn == jp_tem) htr_ldf(:) = ptr_sj( -zftv(:,:,:) ) 240 IF( jn == jp_sal) str_ldf(:) = ptr_sj( -zftv(:,:,:) ) 231 241 ENDIF 232 242 233 #if defined key_diaar5 234 IF( cdtype == 'TRA' .AND. jn == jp_tem ) THEN235 z2d(:,:) = 0._wp236 ! note sign is reversed to give down-gradient diffusive transports (#1043)237 zztmp = -1.0_wp * rau0 * rcp238 DO jk = 1, jpkm1239 DO jj = 2, jpjm1240 DO ji = fs_2, fs_jpim1 ! vector opt.241 z2d(ji,jj) = z2d(ji,jj) + zftu(ji,jj,jk)243 IF( iom_use("udiff_heattr") .OR. iom_use("vdiff_heattr") ) THEN 244 ! 245 IF( cdtype == 'TRA' .AND. jn == jp_tem ) THEN 246 z2d(:,:) = 0._wp 247 DO jk = 1, jpkm1 248 DO jj = 2, jpjm1 249 DO ji = fs_2, fs_jpim1 ! vector opt. 250 z2d(ji,jj) = z2d(ji,jj) + zftu(ji,jj,jk) 251 END DO 242 252 END DO 243 253 END DO 244 END DO 245 z2d(:,:) = zztmp * z2d(:,:) 246 CALL lbc_lnk( z2d, 'U', -1. ) 247 CALL iom_put( "udiff_heattr", z2d ) ! heat transport in i-direction 248 z2d(:,:) = 0._wp 249 DO jk = 1, jpkm1 250 DO jj = 2, jpjm1 251 DO ji = fs_2, fs_jpim1 ! vector opt. 252 z2d(ji,jj) = z2d(ji,jj) + zftv(ji,jj,jk) 254 z2d(:,:) = - rau0_rcp * z2d(:,:) ! note sign is reversed to give down-gradient diffusive transports (#1043) 255 CALL lbc_lnk( z2d, 'U', -1. ) 256 CALL iom_put( "udiff_heattr", z2d ) ! heat transport in i-direction 257 ! 258 z2d(:,:) = 0._wp 259 DO jk = 1, jpkm1 260 DO jj = 2, jpjm1 261 DO ji = fs_2, fs_jpim1 ! vector opt. 262 z2d(ji,jj) = z2d(ji,jj) + zftv(ji,jj,jk) 263 END DO 253 264 END DO 254 265 END DO 255 END DO256 z2d(:,:) = zztmp * z2d(:,:)257 CALL lbc_lnk( z2d, 'V', -1. )258 CALL iom_put( "vdiff_heattr", z2d ) ! heat transport in i-direction259 END IF260 #endif 266 z2d(:,:) = - rau0_rcp * z2d(:,:) ! note sign is reversed to give down-gradient diffusive transports (#1043) 267 CALL lbc_lnk( z2d, 'V', -1. ) 268 CALL iom_put( "vdiff_heattr", z2d ) ! heat transport in i-direction 269 END IF 270 ! 271 ENDIF 261 272 262 273 !!---------------------------------------------------------------------- … … 278 289 DO jj = 2, jpjm1 279 290 DO ji = fs_2, fs_jpim1 ! vector opt. 280 zcoef0 = - fsahtw(ji,jj,jk) * tmask(ji,jj,jk) * tmask(ji,jj,jk-1)291 zcoef0 = - fsahtw(ji,jj,jk) * wmask(ji,jj,jk) 281 292 ! 282 293 zmsku = 1./MAX( umask(ji ,jj,jk-1) + umask(ji-1,jj,jk) & -
branches/2014/dev_r4621_NOC4_BDY_VERT_INTERP/NEMOGCM/NEMO/OPA_SRC/TRA/traldf_iso_grif.F90
r5038 r5620 113 113 REAL(wp) :: ze1ur, zdxt, ze2vr, ze3wr, zdyt, zdzt 114 114 REAL(wp) :: zah, zah_slp, zaei_slp 115 #if defined key_diaar5116 REAL(wp) :: zztmp ! local scalar117 #endif118 115 REAL(wp), POINTER, DIMENSION(:,: ) :: z2d 119 116 REAL(wp), POINTER, DIMENSION(:,:,:) :: zdit, zdjt, ztfw … … 207 204 END DO 208 205 ! 209 #if defined key_iomput 210 IF( ln_traldf_gdia .AND. cdtype == 'TRA' ) THEN 211 CALL wrk_alloc( jpi , jpj , jpk , zw3d ) 212 DO jk=1,jpkm1 213 zw3d(:,:,jk) = (psix_eiv(:,:,jk+1) - psix_eiv(:,:,jk))/fse3u(:,:,jk) ! u_eiv = -dpsix/dz 214 END DO 215 zw3d(:,:,jpk) = 0._wp 216 CALL iom_put( "uoce_eiv", zw3d ) ! i-eiv current 217 218 DO jk=1,jpk-1 219 zw3d(:,:,jk) = (psiy_eiv(:,:,jk+1) - psiy_eiv(:,:,jk))/fse3v(:,:,jk) ! v_eiv = -dpsiy/dz 220 END DO 221 zw3d(:,:,jpk) = 0._wp 222 CALL iom_put( "voce_eiv", zw3d ) ! j-eiv current 223 224 DO jk=1,jpk-1 225 DO jj = 2, jpjm1 226 DO ji = fs_2, fs_jpim1 ! vector opt. 227 zw3d(ji,jj,jk) = (psiy_eiv(ji,jj,jk) - psiy_eiv(ji,jj-1,jk))/e2t(ji,jj) + & 228 & (psix_eiv(ji,jj,jk) - psix_eiv(ji-1,jj,jk))/e1t(ji,jj) ! w_eiv = dpsiy/dy + dpsiy/dx 229 END DO 230 END DO 231 END DO 232 zw3d(:,:,jpk) = 0._wp 233 CALL iom_put( "woce_eiv", zw3d ) ! vert. eiv current 234 CALL wrk_dealloc( jpi , jpj , jpk , zw3d ) 206 IF( iom_use("uoce_eiv") .OR. iom_use("voce_eiv") .OR. iom_use("woce_eiv") ) THEN 207 ! 208 IF( ln_traldf_gdia .AND. cdtype == 'TRA' ) THEN 209 CALL wrk_alloc( jpi , jpj , jpk , zw3d ) 210 DO jk=1,jpkm1 211 zw3d(:,:,jk) = (psix_eiv(:,:,jk+1) - psix_eiv(:,:,jk))/fse3u(:,:,jk) ! u_eiv = -dpsix/dz 212 END DO 213 zw3d(:,:,jpk) = 0._wp 214 CALL iom_put( "uoce_eiv", zw3d ) ! i-eiv current 215 216 DO jk=1,jpk-1 217 zw3d(:,:,jk) = (psiy_eiv(:,:,jk+1) - psiy_eiv(:,:,jk))/fse3v(:,:,jk) ! v_eiv = -dpsiy/dz 218 END DO 219 zw3d(:,:,jpk) = 0._wp 220 CALL iom_put( "voce_eiv", zw3d ) ! j-eiv current 221 222 DO jk=1,jpk-1 223 DO jj = 2, jpjm1 224 DO ji = fs_2, fs_jpim1 ! vector opt. 225 zw3d(ji,jj,jk) = (psiy_eiv(ji,jj,jk) - psiy_eiv(ji,jj-1,jk))/e2t(ji,jj) + & 226 & (psix_eiv(ji,jj,jk) - psix_eiv(ji-1,jj,jk))/e1t(ji,jj) ! w_eiv = dpsiy/dy + dpsiy/dx 227 END DO 228 END DO 229 END DO 230 zw3d(:,:,jpk) = 0._wp 231 CALL iom_put( "woce_eiv", zw3d ) ! vert. eiv current 232 CALL wrk_dealloc( jpi , jpj , jpk , zw3d ) 233 ENDIF 234 ! 235 235 ENDIF 236 #endif237 236 ! ! =========== 238 237 DO jn = 1, kjpt ! tracer loop … … 387 386 ! 388 387 ! ! "Poleward" diffusive heat or salt transports (T-S case only) 389 IF( cdtype == 'TRA' .AND. ln_diaptr .AND. ( MOD( kt, nn_fptr ) == 0 )) THEN390 IF( jn == jp_tem) htr_ldf(:) = ptr_ vj( zftv(:,:,:) ) ! 3.3 names391 IF( jn == jp_sal) str_ldf(:) = ptr_ vj( zftv(:,:,:) )388 IF( cdtype == 'TRA' .AND. ln_diaptr ) THEN 389 IF( jn == jp_tem) htr_ldf(:) = ptr_sj( zftv(:,:,:) ) ! 3.3 names 390 IF( jn == jp_sal) str_ldf(:) = ptr_sj( zftv(:,:,:) ) 392 391 ENDIF 393 392 394 #if defined key_diaar5 395 IF( cdtype == 'TRA' .AND. jn == jp_tem ) THEN 396 z2d(:,:) = 0._wp 397 zztmp = rau0 * rcp 398 DO jk = 1, jpkm1 399 DO jj = 2, jpjm1 400 DO ji = fs_2, fs_jpim1 ! vector opt. 401 z2d(ji,jj) = z2d(ji,jj) + zftu(ji,jj,jk) 402 END DO 403 END DO 404 END DO 405 z2d(:,:) = zztmp * z2d(:,:) 406 CALL lbc_lnk( z2d, 'U', -1. ) 407 CALL iom_put( "udiff_heattr", z2d ) ! heat transport in i-direction 408 z2d(:,:) = 0._wp 409 DO jk = 1, jpkm1 410 DO jj = 2, jpjm1 411 DO ji = fs_2, fs_jpim1 ! vector opt. 412 z2d(ji,jj) = z2d(ji,jj) + zftv(ji,jj,jk) 413 END DO 414 END DO 415 END DO 416 z2d(:,:) = zztmp * z2d(:,:) 417 CALL lbc_lnk( z2d, 'V', -1. ) 418 CALL iom_put( "vdiff_heattr", z2d ) ! heat transport in j-direction 419 END IF 420 #endif 393 IF( iom_use("udiff_heattr") .OR. iom_use("vdiff_heattr") ) THEN 394 ! 395 IF( cdtype == 'TRA' .AND. jn == jp_tem ) THEN 396 z2d(:,:) = 0._wp 397 DO jk = 1, jpkm1 398 DO jj = 2, jpjm1 399 DO ji = fs_2, fs_jpim1 ! vector opt. 400 z2d(ji,jj) = z2d(ji,jj) + zftu(ji,jj,jk) 401 END DO 402 END DO 403 END DO 404 z2d(:,:) = rau0_rcp * z2d(:,:) 405 CALL lbc_lnk( z2d, 'U', -1. ) 406 CALL iom_put( "udiff_heattr", z2d ) ! heat transport in i-direction 407 ! 408 z2d(:,:) = 0._wp 409 DO jk = 1, jpkm1 410 DO jj = 2, jpjm1 411 DO ji = fs_2, fs_jpim1 ! vector opt. 412 z2d(ji,jj) = z2d(ji,jj) + zftv(ji,jj,jk) 413 END DO 414 END DO 415 END DO 416 z2d(:,:) = rau0_rcp * z2d(:,:) 417 CALL lbc_lnk( z2d, 'V', -1. ) 418 CALL iom_put( "vdiff_heattr", z2d ) ! heat transport in i-direction 419 END IF 420 ! 421 ENDIF 421 422 ! 422 423 END DO -
branches/2014/dev_r4621_NOC4_BDY_VERT_INTERP/NEMOGCM/NEMO/OPA_SRC/TRA/traldf_lap.F90
r5038 r5620 102 102 END DO 103 103 END DO 104 IF( ln_zps ) THEN ! set gradient at partial step level 104 IF( ln_zps ) THEN ! set gradient at partial step level for the last ocean cell 105 105 DO jj = 1, jpjm1 106 106 DO ji = 1, fs_jpim1 ! vector opt. … … 116 116 ztv(ji,jj,jk) = zabe2 * pgv(ji,jj,jn) 117 117 ENDIF 118 119 ! (ISH) 118 END DO 119 END DO 120 ENDIF 121 ! (ISH) 122 IF( ln_zps .AND. ln_isfcav ) THEN ! set gradient at partial step level for the first ocean cell 123 ! into a cavity 124 DO jj = 1, jpjm1 125 DO ji = 1, fs_jpim1 ! vector opt. 120 126 ! ice shelf level level MAX(2,jk) => only where ice shelf 121 127 iku = miku(ji,jj) … … 148 154 ! 149 155 ! "Poleward" diffusive heat or salt transports 150 IF( cdtype == 'TRA' .AND. ln_diaptr .AND. ( MOD( kt, nn_fptr ) == 0 )) THEN151 IF( jn == jp_tem) htr_ldf(:) = ptr_ vj( ztv(:,:,:) )152 IF( jn == jp_sal) str_ldf(:) = ptr_ vj( ztv(:,:,:) )156 IF( cdtype == 'TRA' .AND. ln_diaptr ) THEN 157 IF( jn == jp_tem) htr_ldf(:) = ptr_sj( ztv(:,:,:) ) 158 IF( jn == jp_sal) str_ldf(:) = ptr_sj( ztv(:,:,:) ) 153 159 ENDIF 154 160 ! ! ================== -
branches/2014/dev_r4621_NOC4_BDY_VERT_INTERP/NEMOGCM/NEMO/OPA_SRC/TRA/tranpc.F90
r5038 r5620 9 9 !! 3.0 ! 2008-06 (G. Madec) applied on ta, sa and called before tranxt in step.F90 10 10 !! 3.3 ! 2010-05 (C. Ethe, G. Madec) merge TRC-TRA 11 !! 3. 7 ! 2014-06(L. Brodeau) new algorithm based on local Brunt-Vaisala freq.11 !! 3.6 ! 2015-05 (L. Brodeau) new algorithm based on local Brunt-Vaisala freq. 12 12 !!---------------------------------------------------------------------- 13 13 … … 64 64 INTEGER :: ji, jj, jk ! dummy loop indices 65 65 INTEGER :: inpcc ! number of statically instable water column 66 INTEGER :: jiter, ikbot, ik , ikup, ikdown, ilayer, ikm! local integers66 INTEGER :: jiter, ikbot, ikp, ikup, ikdown, ilayer, ik_low ! local integers 67 67 LOGICAL :: l_bottom_reached, l_column_treated 68 68 REAL(wp) :: zta, zalfa, zsum_temp, zsum_alfa, zaw, zdz, zsum_z 69 69 REAL(wp) :: zsa, zbeta, zsum_sali, zsum_beta, zbw, zrw, z1_r2dt 70 REAL(wp), PARAMETER :: zn2_zero = 1.e-14_wp ! acceptance criteria for neutrality (N2==0) 70 71 REAL(wp), POINTER, DIMENSION(:) :: zvn2 ! vertical profile of N2 at 1 given point... 71 72 REAL(wp), POINTER, DIMENSION(:,:) :: zvts ! vertical profile of T and S at 1 given point... … … 75 76 REAL(wp), POINTER, DIMENSION(:,:,:) :: ztrdt, ztrds ! 3D workspace 76 77 ! 77 !!LB debug: 78 LOGICAL, PARAMETER :: l_LB_debug = .FALSE. 79 INTEGER :: ilc1, jlc1, klc1, nncpu 80 LOGICAL :: lp_monitor_point = .FALSE. 81 !!LB debug. 78 LOGICAL, PARAMETER :: l_LB_debug = .FALSE. ! set to true if you want to follow what is 79 INTEGER :: ilc1, jlc1, klc1, nncpu ! actually happening in a water column at point "ilc1, jlc1" 80 LOGICAL :: lp_monitor_point = .FALSE. ! in CPU domain "nncpu" 82 81 !!---------------------------------------------------------------------- 83 82 ! … … 97 96 ENDIF 98 97 99 !LB debug:100 IF( lwp .AND. l_LB_debug ) THEN101 WRITE(numout,*)102 WRITE(numout,*) 'LOLO: entering tra_npc, kt, narea =', kt, narea103 ENDIF104 !LBdebug: Monitoring of 1 column subject to convection...105 98 IF( l_LB_debug ) THEN 106 ! Location of 1 known convection spot to follow what's happening in the water column 107 ilc1 = 54 ; jlc1 = 15 ; ! Labrador ORCA1 4x4 cpus: 108 nncpu = 15 ; ! the CPU domain contains the convection spot 109 !ilc1 = 14 ; jlc1 = 13 ; ! Labrador ORCA1 8x8 cpus: 110 !nncpu = 54 ; ! the CPU domain contains the convection spot 99 ! Location of 1 known convection site to follow what's happening in the water column 100 ilc1 = 45 ; jlc1 = 3 ; ! ORCA2 4x4, Antarctic coast, more than 2 unstable portions in the water column... 101 nncpu = 1 ; ! the CPU domain contains the convection spot 111 102 klc1 = mbkt(ilc1,jlc1) ! bottom of the ocean for debug point... 112 103 ENDIF 113 !LBdebug. 114 115 CALL eos_rab( tsa, zab ) ! after alpha and beta 116 CALL bn2 ( tsa, zab, zn2 ) ! after Brunt-Vaisala 104 105 CALL eos_rab( tsa, zab ) ! after alpha and beta (given on T-points) 106 CALL bn2 ( tsa, zab, zn2 ) ! after Brunt-Vaisala (given on W-points) 117 107 118 108 inpcc = 0 … … 134 124 IF( ( ji == ilc1 ).AND.( jj == jlc1 ) ) lp_monitor_point = .TRUE. 135 125 ! writing only if on CPU domain where conv region is: 136 lp_monitor_point = (narea == nncpu).AND.lp_monitor_point 137 138 IF(lp_monitor_point) THEN 139 WRITE(numout,*) '' ;WRITE(numout,*) '' ; 140 WRITE(numout,'("Time step = ",i6.6," !!!")') kt 141 WRITE(numout,'(" *** BEFORE anything, N^2 for point ",i3,",",i3,":" )') ji,jj 142 DO jk = 1, klc1 143 WRITE(numout,*) jk, zvn2(jk) 144 END DO 145 WRITE(numout,*) ' ' 146 ENDIF 126 lp_monitor_point = (narea == nncpu).AND.lp_monitor_point 147 127 ENDIF !LB debug end 148 128 149 129 ikbot = mbkt(ji,jj) ! ikbot: ocean bottom T-level 150 ik = 1 ! because N2 is irrelevant at the surface level (will start at ik=2)130 ikp = 1 ! because N2 is irrelevant at the surface level (will start at ikp=2) 151 131 ilayer = 0 152 132 jiter = 0 … … 163 143 DO WHILE ( .NOT. l_bottom_reached ) 164 144 165 ik = ik+ 1145 ikp = ikp + 1 166 146 167 !! Checking level ikfor instability147 !! Testing level ikp for instability 168 148 !! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ 169 170 IF( zvn2(ik) < 0. ) THEN ! Instability found! 171 172 ikm = ik ! first level whith negative N2 173 ilayer = ilayer + 1 ! yet another layer found.... 174 IF(jiter == 1) inpcc = inpcc + 1 175 176 IF(l_LB_debug .AND. lp_monitor_point) & 177 & WRITE(numout,*) 'Negative N2 at ik =', ikm, ' layer nb.', ilayer, & 178 & ' inpcc =', inpcc 179 180 !! Case we mix with upper regions where N2==0: 181 !! All the points above ikup where N2 == 0 must also be mixed => we go 182 !! upward to find a new ikup, where the layer doesn't have N2==0 183 ikup = ikm 184 DO jk = ikm, 2, -1 185 ikup = ikup - 1 186 IF( (zvn2(jk-1) > 0.).OR.(ikup == 1) ) EXIT 187 END DO 188 189 ! adjusting ikup if the upper part of the unstable column was neutral (N2=0) 190 IF((zvn2(ikup+1) == 0.).AND.(ikup /= 1)) ikup = ikup+1 ; 191 192 193 IF( lp_monitor_point ) WRITE(numout,*) ' => ikup is =', ikup, ' layer nb.', ilayer 194 149 IF( zvn2(ikp) < -zn2_zero ) THEN ! Instability found! 150 151 ilayer = ilayer + 1 ! yet another instable portion of the water column found.... 152 153 IF( lp_monitor_point ) THEN 154 WRITE(numout,*) 155 IF( ilayer == 1 .AND. jiter == 1 ) THEN ! first time a column is spoted with an instability 156 WRITE(numout,*) 157 WRITE(numout,*) 'Time step = ',kt,' !!!' 158 ENDIF 159 WRITE(numout,*) ' * Iteration #',jiter,': found instable portion #',ilayer, & 160 & ' in column! Starting at ikp =', ikp 161 WRITE(numout,*) ' *** N2 for point (i,j) = ',ji,' , ',jj 162 DO jk = 1, klc1 163 WRITE(numout,*) jk, zvn2(jk) 164 END DO 165 WRITE(numout,*) 166 ENDIF 167 168 169 IF( jiter == 1 ) inpcc = inpcc + 1 170 171 IF( lp_monitor_point ) WRITE(numout, *) 'Negative N2 at ikp =',ikp,' for layer #', ilayer 172 173 !! ikup is the uppermost point where mixing will start: 174 ikup = ikp - 1 ! ikup is always "at most at ikp-1", less if neutral levels overlying 175 176 !! If the points above ikp-1 have N2 == 0 they must also be mixed: 177 IF( ikp > 2 ) THEN 178 DO jk = ikp-1, 2, -1 179 IF( ABS(zvn2(jk)) < zn2_zero ) THEN 180 ikup = ikup - 1 ! 1 more upper level has N2=0 and must be added for the mixing 181 ELSE 182 EXIT 183 ENDIF 184 END DO 185 ENDIF 186 187 IF( ikup < 1 ) CALL ctl_stop( 'tra_npc : PROBLEM #1') 188 195 189 zsum_temp = 0._wp 196 190 zsum_sali = 0._wp … … 199 193 zsum_z = 0._wp 200 194 201 DO jk = ikup, ikbot+1 ! Inside the instable (and overlying neutral) portion of the column 202 ! 203 IF(l_LB_debug .AND. lp_monitor_point) WRITE(numout,*) ' -> summing for jk =', jk 195 DO jk = ikup, ikbot ! Inside the instable (and overlying neutral) portion of the column 204 196 ! 205 197 zdz = fse3t(ji,jj,jk) … … 209 201 zsum_beta = zsum_beta + zvab(jk,jp_sal)*zdz 210 202 zsum_z = zsum_z + zdz 211 ! 212 !! EXIT if we found the bottom of the unstable portion of the water column 213 IF( (zvn2(jk+1) > 0.).OR.(jk == ikbot ).OR.((jk==ikm).AND.(zvn2(jk+1) == 0.)) ) EXIT 203 ! 204 IF( jk == ikbot ) EXIT ! avoid array-index overshoot in case ikbot = jpk, cause we're calling jk+1 next line 205 !! EXIT when we have reached the last layer that is instable (N2<0) or neutral (N2=0): 206 IF( zvn2(jk+1) > zn2_zero ) EXIT 214 207 END DO 215 208 216 !ik = jk !LB remove? 217 ikdown = jk ! for the current unstable layer, ikdown is the deepest point with a negative N2 218 219 IF(l_LB_debug .AND. lp_monitor_point) & 220 & WRITE(numout,*) ' => ikdown =', ikdown, ' layer nb.', ilayer 221 222 ! Mixing Temperature and salinity between ikup and ikdown: 209 ikdown = jk ! for the current unstable layer, ikdown is the deepest point with a negative or neutral N2 210 IF( ikup == ikdown ) CALL ctl_stop( 'tra_npc : PROBLEM #2') 211 212 ! Mixing Temperature, salinity, alpha and beta from ikup to ikdown included: 223 213 zta = zsum_temp/zsum_z 224 214 zsa = zsum_sali/zsum_z … … 226 216 zbeta = zsum_beta/zsum_z 227 217 228 IF(l_LB_debug .AND. lp_monitor_point) THEN 218 IF( lp_monitor_point ) THEN 219 WRITE(numout,*) 'MIXED T, S, alfa and beta between ikup =',ikup, & 220 & ' and ikdown =',ikdown,', in layer #',ilayer 229 221 WRITE(numout,*) ' => Mean temp. in that portion =', zta 230 222 WRITE(numout,*) ' => Mean sali. in that portion =', zsa 231 WRITE(numout,*) ' => Mean Al phain that portion =', zalfa223 WRITE(numout,*) ' => Mean Alfa in that portion =', zalfa 232 224 WRITE(numout,*) ' => Mean Beta in that portion =', zbeta 233 225 ENDIF … … 240 232 zvab(jk,jp_sal) = zbeta 241 233 END DO 242 ! 243 !! Before updating N2, it is possible that another unstable 244 !! layer exists underneath the one we just homogeneized! 245 ik = ikdown 246 ! 247 ENDIF ! IF( zvn2(ik+1) < 0. ) THEN 248 ! 249 IF( ik == ikbot ) l_bottom_reached = .TRUE. 234 235 236 !! Updating N2 in the relvant portion of the water column 237 !! Temperature, Salinity, Alpha and Beta have been homogenized in the unstable portion 238 !! => Need to re-compute N2! will use Alpha and Beta! 239 240 ikup = MAX(2,ikup) ! ikup can never be 1 ! 241 ik_low = MIN(ikdown+1,ikbot) ! we must go 1 point deeper than ikdown! 242 243 DO jk = ikup, ik_low ! we must go 1 point deeper than ikdown! 244 245 !! Interpolating alfa and beta at W point: 246 zrw = (fsdepw(ji,jj,jk ) - fsdept(ji,jj,jk)) & 247 & / (fsdept(ji,jj,jk-1) - fsdept(ji,jj,jk)) 248 zaw = zvab(jk,jp_tem) * (1._wp - zrw) + zvab(jk-1,jp_tem) * zrw 249 zbw = zvab(jk,jp_sal) * (1._wp - zrw) + zvab(jk-1,jp_sal) * zrw 250 251 !! N2 at W point, doing exactly as in eosbn2.F90: 252 zvn2(jk) = grav*( zaw * ( zvts(jk-1,jp_tem) - zvts(jk,jp_tem) ) & 253 & - zbw * ( zvts(jk-1,jp_sal) - zvts(jk,jp_sal) ) ) & 254 & / fse3w(ji,jj,jk) * tmask(ji,jj,jk) 255 256 !! OR, faster => just considering the vertical gradient of density 257 !! as only the signa maters... 258 !zvn2(jk) = ( zaw * ( zvts(jk-1,jp_tem) - zvts(jk,jp_tem) ) & 259 ! & - zbw * ( zvts(jk-1,jp_sal) - zvts(jk,jp_sal) ) ) 260 261 END DO 262 263 ikp = MIN(ikdown+1,ikbot) 264 265 266 ENDIF !IF( zvn2(ikp) < 0. ) 267 268 269 IF( ikp == ikbot ) l_bottom_reached = .TRUE. 250 270 ! 251 271 END DO ! DO WHILE ( .NOT. l_bottom_reached ) 252 272 253 IF( ik /= ikbot ) STOP 'ERROR: tranpc.F90 => PROBLEM #1'273 IF( ikp /= ikbot ) CALL ctl_stop( 'tra_npc : PROBLEM #3') 254 274 255 ! ******* At this stage ik == ikbot ! *******275 ! ******* At this stage ikp == ikbot ! ******* 256 276 257 IF( ilayer > 0 ) THEN 258 !! least an unstable layer has been found 259 !! Temperature, Salinity, Alpha and Beta have been homogenized in the unstable portion 260 !! => Need to re-compute N2! will use Alpha and Beta! 277 IF( ilayer > 0 ) THEN !! least an unstable layer has been found 261 278 ! 262 DO jk = ikup+1, ikdown+1 ! we must go 1 point deeper than ikdown! 263 !! Doing exactly as in eosbn2.F90: 264 !! * Except that we only are interested in the sign of N2 !!! 265 !! => just considering the vertical gradient of density 266 zrw = (fsdepw(ji,jj,jk ) - fsdept(ji,jj,jk)) & 267 & / (fsdept(ji,jj,jk-1) - fsdept(ji,jj,jk)) 268 zaw = zvab(jk,jp_tem) * (1._wp - zrw) + zvab(jk-1,jp_tem) * zrw 269 zbw = zvab(jk,jp_sal) * (1._wp - zrw) + zvab(jk-1,jp_sal) * zrw 270 271 !zvn2(jk) = grav*( zaw * ( zvts(jk-1,jp_tem) - zvts(jk,jp_tem) ) & 272 ! & - zbw * ( zvts(jk-1,jp_sal) - zvts(jk,jp_sal) ) ) & 273 ! & / fse3w(ji,jj,jk) * tmask(ji,jj,jk) 274 zvn2(jk) = ( zaw * ( zvts(jk-1,jp_tem) - zvts(jk,jp_tem) ) & 275 & - zbw * ( zvts(jk-1,jp_sal) - zvts(jk,jp_sal) ) ) 276 END DO 277 278 IF(l_LB_debug .AND. lp_monitor_point) THEN 279 WRITE(numout, '(" *** After iteration #",i3.3,", N^2 for point ",i3,",",i3,":" )') & 280 & jiter, ji,jj 279 IF( lp_monitor_point ) THEN 280 WRITE(numout,*) 281 WRITE(numout,*) 'After ',jiter,' iteration(s), we neutralized ',ilayer,' instable layer(s)' 282 WRITE(numout,*) ' ==> N2 at i,j=',ji,',',jj,' now looks like this:' 281 283 DO jk = 1, klc1 282 284 WRITE(numout,*) jk, zvn2(jk) 283 285 END DO 284 WRITE(numout,*) ' '286 WRITE(numout,*) 285 287 ENDIF 286 287 ik = 1! starting again at the surface for the next iteration288 ! 289 ikp = 1 ! starting again at the surface for the next iteration 288 290 ilayer = 0 289 291 ENDIF 290 292 ! 291 IF( ik >= ikbot ) THEN 292 IF(l_LB_debug .AND. lp_monitor_point) WRITE(numout,*) ' --- exiting jiter loop ---' 293 l_column_treated = .TRUE. 294 ENDIF 293 IF( ikp >= ikbot ) l_column_treated = .TRUE. 295 294 ! 296 295 END DO ! DO WHILE ( .NOT. l_column_treated ) … … 300 299 tsa(ji,jj,:,jp_sal) = zvts(:,jp_sal) 301 300 302 !! lolo: Should we update something else????303 !! => like alpha and beta?304 305 IF( l_LB_debug .AND. lp_monitor_point) WRITE(numout,*) ''301 !! LB: Potentially some other global variable beside theta and S can be treated here 302 !! like BGC tracers. 303 304 IF( lp_monitor_point ) WRITE(numout,*) 306 305 307 306 ENDIF ! IF( tmask(ji,jj,3) == 1 ) THEN … … 321 320 CALL lbc_lnk( tsa(:,:,:,jp_tem), 'T', 1. ) ; CALL lbc_lnk( tsa(:,:,:,jp_sal), 'T', 1. ) 322 321 ! 323 IF(lwp) THEN 324 WRITE(numout,*) 'LOLO: exiting tra_npc, kt =', kt 325 WRITE(numout,*)' => number of statically instable water column : ',inpcc 326 WRITE(numout,*) '' ; WRITE(numout,*) '' 322 IF( lwp .AND. l_LB_debug ) THEN 323 WRITE(numout,*) 'Exiting tra_npc , kt = ',kt,', => numb. of statically instable water-columns: ', inpcc 324 WRITE(numout,*) 327 325 ENDIF 328 326 ! -
branches/2014/dev_r4621_NOC4_BDY_VERT_INTERP/NEMOGCM/NEMO/OPA_SRC/TRA/tranxt.F90
r5038 r5620 27 27 USE dom_oce ! ocean space and time domain variables 28 28 USE sbc_oce ! surface boundary condition: ocean 29 USE sbcrnf ! river runoffs 29 30 USE zdf_oce ! ocean vertical mixing 30 31 USE domvvl ! variable volume … … 143 144 ELSE ! Leap-Frog + Asselin filter time stepping 144 145 ! 145 IF( lk_vvl ) THEN ; CALL tra_nxt_vvl( kt, nit000, 'TRA', tsb, tsn, tsa, jpts ) ! variable volume level (vvl) 146 ELSE ; CALL tra_nxt_fix( kt, nit000, 'TRA', tsb, tsn, tsa, jpts ) ! fixed volume level 146 IF( lk_vvl ) THEN ; CALL tra_nxt_vvl( kt, nit000, rdttra, 'TRA', tsb, tsn, tsa, & 147 & sbc_tsc, sbc_tsc_b, jpts ) ! variable volume level (vvl) 148 ELSE ; CALL tra_nxt_fix( kt, nit000, 'TRA', tsb, tsn, tsa, jpts ) ! fixed volume level 147 149 ENDIF 148 150 ENDIF … … 241 243 242 244 243 SUBROUTINE tra_nxt_vvl( kt, kit000, cdtype, ptb, ptn, pta, kjpt )245 SUBROUTINE tra_nxt_vvl( kt, kit000, p2dt, cdtype, ptb, ptn, pta, psbc_tc, psbc_tc_b, kjpt ) 244 246 !!---------------------------------------------------------------------- 245 247 !! *** ROUTINE tra_nxt_vvl *** … … 265 267 !! - (ta,sa) time averaged (t,s) (ln_dynhpg_imp = T) 266 268 !!---------------------------------------------------------------------- 267 INTEGER , INTENT(in ) :: kt ! ocean time-step index 268 INTEGER , INTENT(in ) :: kit000 ! first time step index 269 CHARACTER(len=3), INTENT(in ) :: cdtype ! =TRA or TRC (tracer indicator) 270 INTEGER , INTENT(in ) :: kjpt ! number of tracers 271 REAL(wp) , INTENT(inout), DIMENSION(jpi,jpj,jpk,kjpt) :: ptb ! before tracer fields 272 REAL(wp) , INTENT(inout), DIMENSION(jpi,jpj,jpk,kjpt) :: ptn ! now tracer fields 273 REAL(wp) , INTENT(inout), DIMENSION(jpi,jpj,jpk,kjpt) :: pta ! tracer trend 269 INTEGER , INTENT(in ) :: kt ! ocean time-step index 270 INTEGER , INTENT(in ) :: kit000 ! first time step index 271 REAL(wp) , INTENT(in ), DIMENSION(jpk) :: p2dt ! time-step 272 CHARACTER(len=3), INTENT(in ) :: cdtype ! =TRA or TRC (tracer indicator) 273 INTEGER , INTENT(in ) :: kjpt ! number of tracers 274 REAL(wp) , INTENT(inout), DIMENSION(jpi,jpj,jpk,kjpt) :: ptb ! before tracer fields 275 REAL(wp) , INTENT(inout), DIMENSION(jpi,jpj,jpk,kjpt) :: ptn ! now tracer fields 276 REAL(wp) , INTENT(inout), DIMENSION(jpi,jpj,jpk,kjpt) :: pta ! tracer trend 277 REAL(wp) , INTENT(in ), DIMENSION(jpi,jpj,kjpt) :: psbc_tc ! surface tracer content 278 REAL(wp) , INTENT(in ), DIMENSION(jpi,jpj,kjpt) :: psbc_tc_b ! before surface tracer content 279 274 280 !! 275 LOGICAL :: ll_tra , ll_tra_hpg, ll_traqsr! local logical281 LOGICAL :: ll_tra_hpg, ll_traqsr, ll_rnf ! local logical 276 282 INTEGER :: ji, jj, jk, jn ! dummy loop indices 277 283 REAL(wp) :: zfact1, ztc_a , ztc_n , ztc_b , ztc_f , ztc_d ! local scalar … … 286 292 ! 287 293 IF( cdtype == 'TRA' ) THEN 288 ll_tra = .TRUE. ! active tracers case289 294 ll_tra_hpg = ln_dynhpg_imp ! active tracers case and semi-implicit hpg 290 295 ll_traqsr = ln_traqsr ! active tracers case and solar penetration 296 ll_rnf = ln_rnf ! active tracers case and river runoffs 291 297 ELSE 292 ll_tra = .FALSE. ! passive tracers case293 298 ll_tra_hpg = .FALSE. ! passive tracers case or NO semi-implicit hpg 294 299 ll_traqsr = .FALSE. ! active tracers case and NO solar penetration 300 ll_rnf = .FALSE. ! passive tracers or NO river runoffs 295 301 ENDIF 296 302 ! 297 303 DO jn = 1, kjpt 298 304 DO jk = 1, jpkm1 299 zfact1 = atfp * rdttra(jk)305 zfact1 = atfp * p2dt(jk) 300 306 zfact2 = zfact1 / rau0 301 307 DO jj = 1, jpj … … 315 321 ztc_f = ztc_n + atfp * ztc_d 316 322 ! 317 IF( ll_tra .AND. jk == 1 ) THEN ! first level only for T & S318 ze3t_f = ze3t_f - zfact2 * ( emp_b(ji,jj) - emp(ji,jj) )319 ztc_f = ztc_f - zfact1 * ( sbc_tsc(ji,jj,jn) - sbc_tsc_b(ji,jj,jn) )323 IF( jk == 1 ) THEN ! first level 324 ze3t_f = ze3t_f - zfact2 * ( emp_b(ji,jj) - emp(ji,jj) + rnf(ji,jj) - rnf_b(ji,jj) ) 325 ztc_f = ztc_f - zfact1 * ( psbc_tc(ji,jj,jn) - psbc_tc_b(ji,jj,jn) ) 320 326 ENDIF 327 321 328 IF( ll_traqsr .AND. jn == jp_tem .AND. jk <= nksr ) & ! solar penetration (temperature only) 322 329 & ztc_f = ztc_f - zfact1 * ( qsr_hc(ji,jj,jk) - qsr_hc_b(ji,jj,jk) ) 323 330 324 ze3t_f = 1.e0 / ze3t_f 325 ptb(ji,jj,jk,jn) = ztc_f * ze3t_f ! ptb <-- ptn filtered 326 ptn(ji,jj,jk,jn) = pta(ji,jj,jk,jn) ! ptn <-- pta 327 ! 328 IF( ll_tra_hpg ) THEN ! semi-implicit hpg (T & S only) 329 ze3t_d = 1.e0 / ( ze3t_n + rbcp * ze3t_d ) 330 pta(ji,jj,jk,jn) = ze3t_d * ( ztc_n + rbcp * ztc_d ) ! ta <-- Brown & Campana average 331 ENDIF 331 IF( ll_rnf .AND. jk <= nk_rnf(ji,jj) ) & ! river runoffs 332 & ztc_f = ztc_f - zfact1 * ( rnf_tsc(ji,jj,jn) - rnf_tsc_b(ji,jj,jn) ) & 333 & * fse3t_n(ji,jj,jk) / h_rnf(ji,jj) 334 335 ze3t_f = 1.e0 / ze3t_f 336 ptb(ji,jj,jk,jn) = ztc_f * ze3t_f ! ptb <-- ptn filtered 337 ptn(ji,jj,jk,jn) = pta(ji,jj,jk,jn) ! ptn <-- pta 338 ! 339 IF( ll_tra_hpg ) THEN ! semi-implicit hpg (T & S only) 340 ze3t_d = 1.e0 / ( ze3t_n + rbcp * ze3t_d ) 341 pta(ji,jj,jk,jn) = ze3t_d * ( ztc_n + rbcp * ztc_d ) ! ta <-- Brown & Campana average 342 ENDIF 332 343 END DO 333 344 END DO -
branches/2014/dev_r4621_NOC4_BDY_VERT_INTERP/NEMOGCM/NEMO/OPA_SRC/TRA/traqsr.F90
r5038 r5620 32 32 USE wrk_nemo ! Memory Allocation 33 33 USE timing ! Timing 34 USE sbc_ice, ONLY : lk_lim335 34 36 35 IMPLICIT NONE … … 38 37 39 38 PUBLIC tra_qsr ! routine called by step.F90 (ln_traqsr=T) 40 PUBLIC tra_qsr_init ! routine called by opa.F9039 PUBLIC tra_qsr_init ! routine called by nemogcm.F90 41 40 42 41 ! !!* Namelist namtra_qsr: penetrative solar radiation … … 50 49 REAL(wp), PUBLIC :: rn_si0 !: very near surface depth of extinction (RGB & 2 bands) 51 50 REAL(wp), PUBLIC :: rn_si1 !: deepest depth of extinction (water type I) (2 bands) 52 51 53 52 ! Module variables 54 53 REAL(wp) :: xsi0r !: inverse of rn_si0 … … 165 164 CALL iom_put( 'qsr3d', etot3 ) ! Shortwave Radiation 3D distribution 166 165 ! clem: store attenuation coefficient of the first ocean level 167 IF ( l k_lim3 .AND. ln_qsr_ice ) THEN166 IF ( ln_qsr_ice ) THEN 168 167 DO jj = 1, jpj 169 168 DO ji = 1, jpi 170 169 IF ( qsr(ji,jj) /= 0._wp ) THEN 171 170 fraqsr_1lev(ji,jj) = ( qsr_hc(ji,jj,1) / ( r1_rau0_rcp * qsr(ji,jj) ) ) 171 ELSE 172 fraqsr_1lev(ji,jj) = 1. 172 173 ENDIF 173 174 END DO … … 233 234 END DO 234 235 ! clem: store attenuation coefficient of the first ocean level 235 IF ( l k_lim3 .AND. ln_qsr_ice ) THEN236 IF ( ln_qsr_ice ) THEN 236 237 DO jj = 1, jpj 237 238 DO ji = 1, jpi … … 256 257 END DO 257 258 ! clem: store attenuation coefficient of the first ocean level 258 IF ( l k_lim3 .AND. ln_qsr_ice ) THEN259 IF ( ln_qsr_ice ) THEN 259 260 fraqsr_1lev(:,:) = etot3(:,:,1) / r1_rau0_rcp 260 261 ENDIF … … 279 280 END DO 280 281 ! clem: store attenuation coefficient of the first ocean level 281 IF ( l k_lim3 .AND. ln_qsr_ice ) THEN282 IF ( ln_qsr_ice ) THEN 282 283 DO jj = 1, jpj 283 284 DO ji = 1, jpi … … 298 299 END DO 299 300 ! clem: store attenuation coefficient of the first ocean level 300 IF ( l k_lim3 .AND. ln_qsr_ice ) THEN301 IF ( ln_qsr_ice ) THEN 301 302 fraqsr_1lev(:,:) = etot3(:,:,1) / r1_rau0_rcp 302 303 ENDIF … … 324 325 & 'at it= ', kt,' date= ', ndastp 325 326 IF(lwp) WRITE(numout,*) '~~~~' 326 CALL iom_rstput( kt, nitrst, numrow, 'qsr_hc_b', qsr_hc ) 327 CALL iom_rstput( kt, nitrst, numrow, 'qsr_hc_b' , qsr_hc ) 328 CALL iom_rstput( kt, nitrst, numrow, 'fraqsr_1lev', fraqsr_1lev ) ! default definition in sbcssm 327 329 ! 328 330 ENDIF … … 379 381 ! 380 382 IF( nn_timing == 1 ) CALL timing_start('tra_qsr_init') 381 !382 ! Default value for fraqsr_1lev383 IF( .NOT. ln_rstart ) THEN384 fraqsr_1lev(:,:) = 1._wp385 ENDIF386 383 ! 387 384 CALL wrk_alloc( jpi, jpj, zekb, zekg, zekr ) … … 412 409 WRITE(numout,*) ' RGB & 2 bands: shortess depth of extinction rn_si0 = ', rn_si0 413 410 WRITE(numout,*) ' 2 bands: longest depth of extinction rn_si1 = ', rn_si1 414 WRITE(numout,*) ' light penetration for ice-model LIM3 ln_qsr_ice = ', ln_qsr_ice415 411 ENDIF 416 412 … … 564 560 ENDIF 565 561 ! 562 ! initialisation of fraqsr_1lev used in sbcssm 563 IF( iom_varid( numror, 'fraqsr_1lev', ldstop = .FALSE. ) > 0 ) THEN 564 CALL iom_get( numror, jpdom_autoglo, 'fraqsr_1lev' , fraqsr_1lev ) 565 ELSE 566 fraqsr_1lev(:,:) = 1._wp ! default definition 567 ENDIF 568 ! 566 569 CALL wrk_dealloc( jpi, jpj, zekb, zekg, zekr ) 567 570 CALL wrk_dealloc( jpi, jpj, jpk, ze0, ze1, ze2, ze3, zea ) -
branches/2014/dev_r4621_NOC4_BDY_VERT_INTERP/NEMOGCM/NEMO/OPA_SRC/TRA/trasbc.F90
r5038 r5620 9 9 !! 3.3 ! 2010-04 (M. Leclair, G. Madec) Forcing averaged over 2 time steps 10 10 !! - ! 2010-09 (C. Ethe, G. Madec) Merge TRA-TRC 11 !! 3.6 ! 2014-11 (P. Mathiot) isf melting forcing 11 12 !!---------------------------------------------------------------------- 12 13 … … 20 21 USE sbcmod ! ln_rnf 21 22 USE sbcrnf ! River runoff 23 USE sbcisf ! Ice shelf 22 24 USE traqsr ! solar radiation penetration 23 25 USE trd_oce ! trends: ocean variables … … 26 28 USE in_out_manager ! I/O manager 27 29 USE prtctl ! Print control 28 USE sbcrnf ! River runoff29 USE sbcisf ! Ice shelf30 USE sbcmod ! ln_rnf31 30 USE iom 32 31 USE lbclnk ! ocean lateral boundary conditions (or mpp link) -
branches/2014/dev_r4621_NOC4_BDY_VERT_INTERP/NEMOGCM/NEMO/OPA_SRC/TRA/trazdf.F90
r5038 r5620 88 88 & tab3d_2=tsa(:,:,:,jp_sal), clinfo2= ' Sa: ', mask2=tmask, clinfo3='tra' ) 89 89 END SELECT 90 ! DRAKKAR SSS control { 91 ! JMM avoid negative salinities near river outlet ! Ugly fix 92 ! JMM : restore negative salinities to small salinities: 93 WHERE ( tsa(:,:,:,jp_sal) < 0._wp ) tsa(:,:,:,jp_sal) = 0.1_wp 90 94 91 95 IF( l_trdtra ) THEN ! save the vertical diffusive trends for further diagnostics -
branches/2014/dev_r4621_NOC4_BDY_VERT_INTERP/NEMOGCM/NEMO/OPA_SRC/TRA/trazdf_imp.F90
r5038 r5620 122 122 DO jj=1, jpj 123 123 DO ji=1, jpi 124 zwt(ji,jj,1 :mikt(ji,jj)) = 0._wp124 zwt(ji,jj,1) = 0._wp 125 125 END DO 126 126 END DO … … 184 184 DO jj = 2, jpjm1 185 185 DO ji = fs_2, fs_jpim1 186 zwt(ji,jj,1:mikt(ji,jj)) = zwd(ji,jj,1:mikt(ji,jj)) 187 DO jk = mikt(ji,jj)+1, jpkm1 186 zwt(ji,jj,1) = zwd(ji,jj,1) 187 END DO 188 END DO 189 DO jk = 2, jpkm1 190 DO jj = 2, jpjm1 191 DO ji = fs_2, fs_jpim1 188 192 zwt(ji,jj,jk) = zwd(ji,jj,jk) - zwi(ji,jj,jk) * zws(ji,jj,jk-1) / zwt(ji,jj,jk-1) 189 193 END DO … … 196 200 DO jj = 2, jpjm1 197 201 DO ji = fs_2, fs_jpim1 198 ze3tb = ( 1. - r_vvl ) + r_vvl * fse3t_b(ji,jj,mikt(ji,jj)) 199 ze3tn = ( 1. - r_vvl ) + r_vvl * fse3t(ji,jj,mikt(ji,jj)) 200 pta(ji,jj,mikt(ji,jj),jn) = ze3tb * ptb(ji,jj,mikt(ji,jj),jn) & 201 & + p2dt(mikt(ji,jj)) * ze3tn * pta(ji,jj,mikt(ji,jj),jn) 202 DO jk = mikt(ji,jj)+1, jpkm1 202 ze3tb = ( 1. - r_vvl ) + r_vvl * fse3t_b(ji,jj,1) 203 ze3tn = ( 1. - r_vvl ) + r_vvl * fse3t(ji,jj,1) 204 pta(ji,jj,1,jn) = ze3tb * ptb(ji,jj,1,jn) & 205 & + p2dt(1) * ze3tn * pta(ji,jj,1,jn) 206 END DO 207 END DO 208 DO jk = 2, jpkm1 209 DO jj = 2, jpjm1 210 DO ji = fs_2, fs_jpim1 203 211 ze3tb = ( 1. - r_vvl ) + r_vvl * fse3t_b(ji,jj,jk) 204 212 ze3tn = ( 1. - r_vvl ) + r_vvl * fse3t (ji,jj,jk) … … 213 221 DO ji = fs_2, fs_jpim1 214 222 pta(ji,jj,jpkm1,jn) = pta(ji,jj,jpkm1,jn) / zwt(ji,jj,jpkm1) * tmask(ji,jj,jpkm1) 215 DO jk = jpk-2, mikt(ji,jj), -1 223 END DO 224 END DO 225 DO jk = jpk-2, 1, -1 226 DO jj = 2, jpjm1 227 DO ji = fs_2, fs_jpim1 216 228 pta(ji,jj,jk,jn) = ( pta(ji,jj,jk,jn) - zws(ji,jj,jk) * pta(ji,jj,jk+1,jn) ) & 217 229 & / zwt(ji,jj,jk) * tmask(ji,jj,jk) -
branches/2014/dev_r4621_NOC4_BDY_VERT_INTERP/NEMOGCM/NEMO/OPA_SRC/TRA/zpshde.F90
r5038 r5620 8 8 !! - ! 2004-03 (C. Ethe) adapted for passive tracers 9 9 !! 3.3 ! 2010-05 (C. Ethe, G. Madec) merge TRC-TRA 10 !! 3.6 ! 2014-11 (P. Mathiot) Add zps_hde_isf (needed to open a cavity) 10 11 !!====================================================================== 11 12 … … 27 28 PRIVATE 28 29 29 PUBLIC zps_hde ! routine called by step.F90 30 PUBLIC zps_hde ! routine called by step.F90 31 PUBLIC zps_hde_isf ! routine called by step.F90 30 32 31 33 !! * Substitutions … … 40 42 41 43 SUBROUTINE zps_hde( kt, kjpt, pta, pgtu, pgtv, & 44 & prd, pgru, pgrv ) 45 !!---------------------------------------------------------------------- 46 !! *** ROUTINE zps_hde *** 47 !! 48 !! ** Purpose : Compute the horizontal derivative of T, S and rho 49 !! at u- and v-points with a linear interpolation for z-coordinate 50 !! with partial steps. 51 !! 52 !! ** Method : In z-coord with partial steps, scale factors on last 53 !! levels are different for each grid point, so that T, S and rd 54 !! points are not at the same depth as in z-coord. To have horizontal 55 !! gradients again, we interpolate T and S at the good depth : 56 !! Linear interpolation of T, S 57 !! Computation of di(tb) and dj(tb) by vertical interpolation: 58 !! di(t) = t~ - t(i,j,k) or t(i+1,j,k) - t~ 59 !! dj(t) = t~ - t(i,j,k) or t(i,j+1,k) - t~ 60 !! This formulation computes the two cases: 61 !! CASE 1 CASE 2 62 !! k-1 ___ ___________ k-1 ___ ___________ 63 !! Ti T~ T~ Ti+1 64 !! _____ _____ 65 !! k | |Ti+1 k Ti | | 66 !! | |____ ____| | 67 !! ___ | | | ___ | | | 68 !! 69 !! case 1-> e3w(i+1) >= e3w(i) ( and e3w(j+1) >= e3w(j) ) then 70 !! t~ = t(i+1,j ,k) + (e3w(i+1) - e3w(i)) * dk(Ti+1)/e3w(i+1) 71 !! ( t~ = t(i ,j+1,k) + (e3w(j+1) - e3w(j)) * dk(Tj+1)/e3w(j+1) ) 72 !! or 73 !! case 2-> e3w(i+1) <= e3w(i) ( and e3w(j+1) <= e3w(j) ) then 74 !! t~ = t(i,j,k) + (e3w(i) - e3w(i+1)) * dk(Ti)/e3w(i ) 75 !! ( t~ = t(i,j,k) + (e3w(j) - e3w(j+1)) * dk(Tj)/e3w(j ) ) 76 !! Idem for di(s) and dj(s) 77 !! 78 !! For rho, we call eos which will compute rd~(t~,s~) at the right 79 !! depth zh from interpolated T and S for the different formulations 80 !! of the equation of state (eos). 81 !! Gradient formulation for rho : 82 !! di(rho) = rd~ - rd(i,j,k) or rd(i+1,j,k) - rd~ 83 !! 84 !! ** Action : compute for top interfaces 85 !! - pgtu, pgtv: horizontal gradient of tracer at u- & v-points 86 !! - pgru, pgrv: horizontal gradient of rho (if present) at u- & v-points 87 !!---------------------------------------------------------------------- 88 INTEGER , INTENT(in ) :: kt ! ocean time-step index 89 INTEGER , INTENT(in ) :: kjpt ! number of tracers 90 REAL(wp), DIMENSION(jpi,jpj,jpk,kjpt), INTENT(in ) :: pta ! 4D tracers fields 91 REAL(wp), DIMENSION(jpi,jpj, kjpt), INTENT( out) :: pgtu, pgtv ! hor. grad. of ptra at u- & v-pts 92 REAL(wp), DIMENSION(jpi,jpj,jpk ), INTENT(in ), OPTIONAL :: prd ! 3D density anomaly fields 93 REAL(wp), DIMENSION(jpi,jpj ), INTENT( out), OPTIONAL :: pgru, pgrv ! hor. grad of prd at u- & v-pts (bottom) 94 ! 95 INTEGER :: ji, jj, jn ! Dummy loop indices 96 INTEGER :: iku, ikv, ikum1, ikvm1 ! partial step level (ocean bottom level) at u- and v-points 97 REAL(wp) :: ze3wu, ze3wv, zmaxu, zmaxv ! temporary scalars 98 REAL(wp), DIMENSION(jpi,jpj) :: zri, zrj, zhi, zhj ! NB: 3rd dim=1 to use eos 99 REAL(wp), DIMENSION(jpi,jpj,kjpt) :: zti, ztj ! 100 !!---------------------------------------------------------------------- 101 ! 102 IF( nn_timing == 1 ) CALL timing_start( 'zps_hde') 103 ! 104 pgtu(:,:,:)=0.0_wp ; pgtv(:,:,:)=0.0_wp ; 105 zti (:,:,:)=0.0_wp ; ztj (:,:,:)=0.0_wp ; 106 zhi (:,: )=0.0_wp ; zhj (:,: )=0.0_wp ; 107 ! 108 DO jn = 1, kjpt !== Interpolation of tracers at the last ocean level ==! 109 ! 110 DO jj = 1, jpjm1 111 DO ji = 1, jpim1 112 iku = mbku(ji,jj) ; ikum1 = MAX( iku - 1 , 1 ) ! last and before last ocean level at u- & v-points 113 ikv = mbkv(ji,jj) ; ikvm1 = MAX( ikv - 1 , 1 ) ! if level first is a p-step, ik.m1=1 114 ze3wu = fse3w(ji+1,jj ,iku) - fse3w(ji,jj,iku) 115 ze3wv = fse3w(ji ,jj+1,ikv) - fse3w(ji,jj,ikv) 116 ! 117 ! i- direction 118 IF( ze3wu >= 0._wp ) THEN ! case 1 119 zmaxu = ze3wu / fse3w(ji+1,jj,iku) 120 ! interpolated values of tracers 121 zti (ji,jj,jn) = pta(ji+1,jj,iku,jn) + zmaxu * ( pta(ji+1,jj,ikum1,jn) - pta(ji+1,jj,iku,jn) ) 122 ! gradient of tracers 123 pgtu(ji,jj,jn) = umask(ji,jj,1) * ( zti(ji,jj,jn) - pta(ji,jj,iku,jn) ) 124 ELSE ! case 2 125 zmaxu = -ze3wu / fse3w(ji,jj,iku) 126 ! interpolated values of tracers 127 zti (ji,jj,jn) = pta(ji,jj,iku,jn) + zmaxu * ( pta(ji,jj,ikum1,jn) - pta(ji,jj,iku,jn) ) 128 ! gradient of tracers 129 pgtu(ji,jj,jn) = umask(ji,jj,1) * ( pta(ji+1,jj,iku,jn) - zti(ji,jj,jn) ) 130 ENDIF 131 ! 132 ! j- direction 133 IF( ze3wv >= 0._wp ) THEN ! case 1 134 zmaxv = ze3wv / fse3w(ji,jj+1,ikv) 135 ! interpolated values of tracers 136 ztj (ji,jj,jn) = pta(ji,jj+1,ikv,jn) + zmaxv * ( pta(ji,jj+1,ikvm1,jn) - pta(ji,jj+1,ikv,jn) ) 137 ! gradient of tracers 138 pgtv(ji,jj,jn) = vmask(ji,jj,1) * ( ztj(ji,jj,jn) - pta(ji,jj,ikv,jn) ) 139 ELSE ! case 2 140 zmaxv = -ze3wv / fse3w(ji,jj,ikv) 141 ! interpolated values of tracers 142 ztj (ji,jj,jn) = pta(ji,jj,ikv,jn) + zmaxv * ( pta(ji,jj,ikvm1,jn) - pta(ji,jj,ikv,jn) ) 143 ! gradient of tracers 144 pgtv(ji,jj,jn) = vmask(ji,jj,1) * ( pta(ji,jj+1,ikv,jn) - ztj(ji,jj,jn) ) 145 ENDIF 146 END DO 147 END DO 148 CALL lbc_lnk( pgtu(:,:,jn), 'U', -1. ) ; CALL lbc_lnk( pgtv(:,:,jn), 'V', -1. ) ! Lateral boundary cond. 149 ! 150 END DO 151 152 ! horizontal derivative of density anomalies (rd) 153 IF( PRESENT( prd ) ) THEN ! depth of the partial step level 154 pgru(:,:)=0.0_wp ; pgrv(:,:)=0.0_wp ; 155 DO jj = 1, jpjm1 156 DO ji = 1, jpim1 157 iku = mbku(ji,jj) 158 ikv = mbkv(ji,jj) 159 ze3wu = fse3w(ji+1,jj ,iku) - fse3w(ji,jj,iku) 160 ze3wv = fse3w(ji ,jj+1,ikv) - fse3w(ji,jj,ikv) 161 IF( ze3wu >= 0._wp ) THEN ; zhi(ji,jj) = fsdept(ji ,jj,iku) ! i-direction: case 1 162 ELSE ; zhi(ji,jj) = fsdept(ji+1,jj,iku) ! - - case 2 163 ENDIF 164 IF( ze3wv >= 0._wp ) THEN ; zhj(ji,jj) = fsdept(ji,jj ,ikv) ! j-direction: case 1 165 ELSE ; zhj(ji,jj) = fsdept(ji,jj+1,ikv) ! - - case 2 166 ENDIF 167 END DO 168 END DO 169 170 ! Compute interpolated rd from zti, ztj for the 2 cases at the depth of the partial 171 ! step and store it in zri, zrj for each case 172 CALL eos( zti, zhi, zri ) 173 CALL eos( ztj, zhj, zrj ) 174 175 ! Gradient of density at the last level 176 DO jj = 1, jpjm1 177 DO ji = 1, jpim1 178 iku = mbku(ji,jj) 179 ikv = mbkv(ji,jj) 180 ze3wu = fse3w(ji+1,jj ,iku) - fse3w(ji,jj,iku) 181 ze3wv = fse3w(ji ,jj+1,ikv) - fse3w(ji,jj,ikv) 182 IF( ze3wu >= 0._wp ) THEN ; pgru(ji,jj) = umask(ji,jj,1) * ( zri(ji ,jj ) - prd(ji,jj,iku) ) ! i: 1 183 ELSE ; pgru(ji,jj) = umask(ji,jj,1) * ( prd(ji+1,jj,iku) - zri(ji,jj ) ) ! i: 2 184 ENDIF 185 IF( ze3wv >= 0._wp ) THEN ; pgrv(ji,jj) = vmask(ji,jj,1) * ( zrj(ji,jj ) - prd(ji,jj,ikv) ) ! j: 1 186 ELSE ; pgrv(ji,jj) = vmask(ji,jj,1) * ( prd(ji,jj+1,ikv) - zrj(ji,jj ) ) ! j: 2 187 ENDIF 188 END DO 189 END DO 190 CALL lbc_lnk( pgru , 'U', -1. ) ; CALL lbc_lnk( pgrv , 'V', -1. ) ! Lateral boundary conditions 191 ! 192 END IF 193 ! 194 IF( nn_timing == 1 ) CALL timing_stop( 'zps_hde') 195 ! 196 END SUBROUTINE zps_hde 197 ! 198 SUBROUTINE zps_hde_isf( kt, kjpt, pta, pgtu, pgtv, & 42 199 & prd, pgru, pgrv, pmru, pmrv, pgzu, pgzv, pge3ru, pge3rv, & 43 & sgtu, sgtv, sgru, sgrv, smru, smrv, sgzu, sgzv, sge3ru, sge3rv)200 & pgtui, pgtvi, pgrui, pgrvi, pmrui, pmrvi, pgzui, pgzvi, pge3rui, pge3rvi ) 44 201 !!---------------------------------------------------------------------- 45 202 !! *** ROUTINE zps_hde *** … … 82 239 !! 83 240 !! ** Action : compute for top and bottom interfaces 84 !! - pgtu, pgtv, sgtu, sgtv: horizontal gradient of tracer at u- & v-points85 !! - pgru, pgrv, sgru, sgtv: horizontal gradient of rho (if present) at u- & v-points86 !! - pmru, pmrv, smru, smrv: horizontal sum of rho at u- & v- point (used in dynhpg with vvl)87 !! - pgzu, pgzv, sgzu, sgzv: horizontal gradient of z at u- and v- point (used in dynhpg with vvl)88 !! - pge3ru, pge3rv, sge3ru, sge3rv: horizontal gradient of rho weighted by local e3w at u- & v-points241 !! - pgtu, pgtv, pgtui, pgtvi: horizontal gradient of tracer at u- & v-points 242 !! - pgru, pgrv, pgrui, pgtvi: horizontal gradient of rho (if present) at u- & v-points 243 !! - pmru, pmrv, pmrui, pmrvi: horizontal sum of rho at u- & v- point (used in dynhpg with vvl) 244 !! - pgzu, pgzv, pgzui, pgzvi: horizontal gradient of z at u- and v- point (used in dynhpg with vvl) 245 !! - pge3ru, pge3rv, pge3rui, pge3rvi: horizontal gradient of rho weighted by local e3w at u- & v-points 89 246 !!---------------------------------------------------------------------- 90 247 INTEGER , INTENT(in ) :: kt ! ocean time-step index … … 92 249 REAL(wp), DIMENSION(jpi,jpj,jpk,kjpt), INTENT(in ) :: pta ! 4D tracers fields 93 250 REAL(wp), DIMENSION(jpi,jpj, kjpt), INTENT( out) :: pgtu, pgtv ! hor. grad. of ptra at u- & v-pts 94 REAL(wp), DIMENSION(jpi,jpj, kjpt), INTENT( out) :: sgtu, sgtv! hor. grad. of stra at u- & v-pts (ISF)251 REAL(wp), DIMENSION(jpi,jpj, kjpt), INTENT( out) :: pgtui, pgtvi ! hor. grad. of stra at u- & v-pts (ISF) 95 252 REAL(wp), DIMENSION(jpi,jpj,jpk ), INTENT(in ), OPTIONAL :: prd ! 3D density anomaly fields 96 253 REAL(wp), DIMENSION(jpi,jpj ), INTENT( out), OPTIONAL :: pgru, pgrv ! hor. grad of prd at u- & v-pts (bottom) … … 98 255 REAL(wp), DIMENSION(jpi,jpj ), INTENT( out), OPTIONAL :: pgzu, pgzv ! hor. grad of z at u- & v-pts (bottom) 99 256 REAL(wp), DIMENSION(jpi,jpj ), INTENT( out), OPTIONAL :: pge3ru, pge3rv ! hor. grad of prd weighted by local e3w at u- & v-pts (bottom) 100 REAL(wp), DIMENSION(jpi,jpj ), INTENT( out), OPTIONAL :: sgru, sgrv! hor. grad of prd at u- & v-pts (top)101 REAL(wp), DIMENSION(jpi,jpj ), INTENT( out), OPTIONAL :: smru, smrv! hor. sum of prd at u- & v-pts (top)102 REAL(wp), DIMENSION(jpi,jpj ), INTENT( out), OPTIONAL :: sgzu, sgzv! hor. grad of z at u- & v-pts (top)103 REAL(wp), DIMENSION(jpi,jpj ), INTENT( out), OPTIONAL :: sge3ru, sge3rv! hor. grad of prd weighted by local e3w at u- & v-pts (top)257 REAL(wp), DIMENSION(jpi,jpj ), INTENT( out), OPTIONAL :: pgrui, pgrvi ! hor. grad of prd at u- & v-pts (top) 258 REAL(wp), DIMENSION(jpi,jpj ), INTENT( out), OPTIONAL :: pmrui, pmrvi ! hor. sum of prd at u- & v-pts (top) 259 REAL(wp), DIMENSION(jpi,jpj ), INTENT( out), OPTIONAL :: pgzui, pgzvi ! hor. grad of z at u- & v-pts (top) 260 REAL(wp), DIMENSION(jpi,jpj ), INTENT( out), OPTIONAL :: pge3rui, pge3rvi ! hor. grad of prd weighted by local e3w at u- & v-pts (top) 104 261 ! 105 262 INTEGER :: ji, jj, jn ! Dummy loop indices … … 110 267 !!---------------------------------------------------------------------- 111 268 ! 112 IF( nn_timing == 1 ) CALL timing_start( 'zps_hde ')269 IF( nn_timing == 1 ) CALL timing_start( 'zps_hde_isf') 113 270 ! 114 271 pgtu(:,:,:)=0.0_wp ; pgtv(:,:,:)=0.0_wp ; 115 sgtu(:,:,:)=0.0_wp ; sgtv(:,:,:)=0.0_wp ;272 pgtui(:,:,:)=0.0_wp ; pgtvi(:,:,:)=0.0_wp ; 116 273 zti (:,:,:)=0.0_wp ; ztj (:,:,:)=0.0_wp ; 117 274 zhi (:,: )=0.0_wp ; zhj (:,: )=0.0_wp ; … … 256 413 zti(ji,jj,jn) = pta(ji+1,jj,iku,jn) + zmaxu * ( pta(ji+1,jj,iku+1,jn) - pta(ji+1,jj,iku,jn) ) 257 414 ! gradient of tracers 258 sgtu(ji,jj,jn) = umask(ji,jj,iku) * ( zti(ji,jj,jn) - pta(ji,jj,iku,jn) )415 pgtui(ji,jj,jn) = umask(ji,jj,iku) * ( zti(ji,jj,jn) - pta(ji,jj,iku,jn) ) 259 416 ELSE ! case 2 260 417 zmaxu = - ze3wu / fse3w(ji,jj,iku+1) … … 262 419 zti(ji,jj,jn) = pta(ji,jj,iku,jn) + zmaxu * ( pta(ji,jj,iku+1,jn) - pta(ji,jj,iku,jn) ) 263 420 ! gradient of tracers 264 sgtu(ji,jj,jn) = umask(ji,jj,iku) * ( pta(ji+1,jj,iku,jn) - zti(ji,jj,jn) )421 pgtui(ji,jj,jn) = umask(ji,jj,iku) * ( pta(ji+1,jj,iku,jn) - zti(ji,jj,jn) ) 265 422 ENDIF 266 423 ! … … 271 428 ztj(ji,jj,jn) = pta(ji,jj+1,ikv,jn) + zmaxv * ( pta(ji,jj+1,ikv+1,jn) - pta(ji,jj+1,ikv,jn) ) 272 429 ! gradient of tracers 273 sgtv(ji,jj,jn) = vmask(ji,jj,ikv) * ( ztj(ji,jj,jn) - pta(ji,jj,ikv,jn) )430 pgtvi(ji,jj,jn) = vmask(ji,jj,ikv) * ( ztj(ji,jj,jn) - pta(ji,jj,ikv,jn) ) 274 431 ELSE ! case 2 275 432 zmaxv = - ze3wv / fse3w(ji,jj,ikv+1) … … 277 434 ztj(ji,jj,jn) = pta(ji,jj,ikv,jn) + zmaxv * ( pta(ji,jj,ikv+1,jn) - pta(ji,jj,ikv,jn) ) 278 435 ! gradient of tracers 279 sgtv(ji,jj,jn) = vmask(ji,jj,ikv) * ( pta(ji,jj+1,ikv,jn) - ztj(ji,jj,jn) )436 pgtvi(ji,jj,jn) = vmask(ji,jj,ikv) * ( pta(ji,jj+1,ikv,jn) - ztj(ji,jj,jn) ) 280 437 ENDIF 281 438 END DO!! 282 439 END DO!! 283 CALL lbc_lnk( sgtu(:,:,jn), 'U', -1. ) ; CALL lbc_lnk( sgtv(:,:,jn), 'V', -1. ) ! Lateral boundary cond.440 CALL lbc_lnk( pgtui(:,:,jn), 'U', -1. ) ; CALL lbc_lnk( pgtvi(:,:,jn), 'V', -1. ) ! Lateral boundary cond. 284 441 ! 285 442 END DO … … 287 444 ! horizontal derivative of density anomalies (rd) 288 445 IF( PRESENT( prd ) ) THEN ! depth of the partial step level 289 sgru(:,:) =0.0_wp ; sgrv(:,:) =0.0_wp ;290 sgzu(:,:) =0.0_wp ; sgzv(:,:) =0.0_wp ;291 smru(:,:) =0.0_wp ; smru(:,:) =0.0_wp ;292 sge3ru(:,:)=0.0_wp ; sge3rv(:,:)=0.0_wp ;446 pgrui(:,:) =0.0_wp ; pgrvi(:,:) =0.0_wp ; 447 pgzui(:,:) =0.0_wp ; pgzvi(:,:) =0.0_wp ; 448 pmrui(:,:) =0.0_wp ; pmrui(:,:) =0.0_wp ; 449 pge3rui(:,:)=0.0_wp ; pge3rvi(:,:)=0.0_wp ; 293 450 294 451 DO jj = 1, jpjm1 … … 321 478 ze3wv = (gdepw_0(ji,jj+1,ikv+1) - gdept_0(ji,jj+1,ikv)) - (gdepw_0(ji,jj,ikv+1) - gdept_0(ji,jj,ikv)) 322 479 IF( ze3wu >= 0._wp ) THEN 323 sgzu(ji,jj) = (fsde3w(ji+1,jj,iku) + ze3wu) - fsde3w(ji,jj,iku)324 sgru(ji,jj) = umask(ji,jj,iku) * ( zri(ji,jj) - prd(ji,jj,iku) ) ! i: 1325 smru(ji,jj) = umask(ji,jj,iku) * ( zri(ji,jj) + prd(ji,jj,iku) ) ! i: 1326 sge3ru(ji,jj) = umask(ji,jj,iku+1) &480 pgzui (ji,jj) = (fsde3w(ji+1,jj,iku) + ze3wu) - fsde3w(ji,jj,iku) 481 pgrui (ji,jj) = umask(ji,jj,iku) * ( zri(ji,jj) - prd(ji,jj,iku) ) ! i: 1 482 pmrui (ji,jj) = umask(ji,jj,iku) * ( zri(ji,jj) + prd(ji,jj,iku) ) ! i: 1 483 pge3rui(ji,jj) = umask(ji,jj,iku+1) & 327 484 * ( (fse3w(ji+1,jj,iku+1) - ze3wu) * (zri(ji,jj ) + prd(ji+1,jj,iku+1) + 2._wp) & 328 485 - fse3w(ji ,jj,iku+1) * (prd(ji,jj,iku) + prd(ji ,jj,iku+1) + 2._wp) ) ! i: 1 329 486 ELSE 330 sgzu(ji,jj) = fsde3w(ji+1,jj,iku) - (fsde3w(ji,jj,iku) - ze3wu)331 sgru(ji,jj) = umask(ji,jj,iku) * ( prd(ji+1,jj,iku) - zri(ji,jj) ) ! i: 2332 smru(ji,jj) = umask(ji,jj,iku) * ( prd(ji+1,jj,iku) + zri(ji,jj) ) ! i: 2333 sge3ru(ji,jj) = umask(ji,jj,iku+1) &487 pgzui (ji,jj) = fsde3w(ji+1,jj,iku) - (fsde3w(ji,jj,iku) - ze3wu) 488 pgrui (ji,jj) = umask(ji,jj,iku) * ( prd(ji+1,jj,iku) - zri(ji,jj) ) ! i: 2 489 pmrui (ji,jj) = umask(ji,jj,iku) * ( prd(ji+1,jj,iku) + zri(ji,jj) ) ! i: 2 490 pge3rui(ji,jj) = umask(ji,jj,iku+1) & 334 491 * ( fse3w(ji+1,jj,iku+1) * (prd(ji+1,jj,iku) + prd(ji+1,jj,iku+1) + 2._wp) & 335 492 -(fse3w(ji ,jj,iku+1) + ze3wu) * (zri(ji,jj ) + prd(ji ,jj,iku+1) + 2._wp) ) ! i: 2 336 493 ENDIF 337 494 IF( ze3wv >= 0._wp ) THEN 338 sgzv(ji,jj) = (fsde3w(ji,jj+1,ikv) + ze3wv) - fsde3w(ji,jj,ikv)339 sgrv(ji,jj) = vmask(ji,jj,ikv) * ( zrj(ji,jj ) - prd(ji,jj,ikv) ) ! j: 1340 smrv(ji,jj) = vmask(ji,jj,ikv) * ( zrj(ji,jj ) + prd(ji,jj,ikv) ) ! j: 1341 sge3rv(ji,jj) = vmask(ji,jj,ikv+1) &495 pgzvi (ji,jj) = (fsde3w(ji,jj+1,ikv) + ze3wv) - fsde3w(ji,jj,ikv) 496 pgrvi (ji,jj) = vmask(ji,jj,ikv) * ( zrj(ji,jj ) - prd(ji,jj,ikv) ) ! j: 1 497 pmrvi (ji,jj) = vmask(ji,jj,ikv) * ( zrj(ji,jj ) + prd(ji,jj,ikv) ) ! j: 1 498 pge3rvi(ji,jj) = vmask(ji,jj,ikv+1) & 342 499 * ( (fse3w(ji,jj+1,ikv+1) - ze3wv) * ( zrj(ji,jj ) + prd(ji,jj+1,ikv+1) + 2._wp) & 343 500 - fse3w(ji,jj ,ikv+1) * ( prd(ji,jj,ikv) + prd(ji,jj ,ikv+1) + 2._wp) ) ! j: 1 344 501 ! + 2 due to the formulation in density and not in anomalie in hpg sco 345 502 ELSE 346 sgzv(ji,jj) = fsde3w(ji,jj+1,ikv) - (fsde3w(ji,jj,ikv) - ze3wv)347 sgrv(ji,jj) = vmask(ji,jj,ikv) * ( prd(ji,jj+1,ikv) - zrj(ji,jj) ) ! j: 2348 smrv(ji,jj) = vmask(ji,jj,ikv) * ( prd(ji,jj+1,ikv) + zrj(ji,jj) ) ! j: 2349 sge3rv(ji,jj) = vmask(ji,jj,ikv+1) &503 pgzvi (ji,jj) = fsde3w(ji,jj+1,ikv) - (fsde3w(ji,jj,ikv) - ze3wv) 504 pgrvi (ji,jj) = vmask(ji,jj,ikv) * ( prd(ji,jj+1,ikv) - zrj(ji,jj) ) ! j: 2 505 pmrvi (ji,jj) = vmask(ji,jj,ikv) * ( prd(ji,jj+1,ikv) + zrj(ji,jj) ) ! j: 2 506 pge3rvi(ji,jj) = vmask(ji,jj,ikv+1) & 350 507 * ( fse3w(ji,jj+1,ikv+1) * ( prd(ji,jj+1,ikv) + prd(ji,jj+1,ikv+1) + 2._wp) & 351 508 -(fse3w(ji,jj ,ikv+1) + ze3wv) * ( zrj(ji,jj ) + prd(ji,jj ,ikv+1) + 2._wp) ) ! j: 2 … … 353 510 END DO 354 511 END DO 355 CALL lbc_lnk( sgru , 'U', -1. ) ; CALL lbc_lnk( sgrv, 'V', -1. ) ! Lateral boundary conditions356 CALL lbc_lnk( smru , 'U', 1. ) ; CALL lbc_lnk( smrv, 'V', 1. ) ! Lateral boundary conditions357 CALL lbc_lnk( sgzu , 'U', -1. ) ; CALL lbc_lnk( sgzv, 'V', -1. ) ! Lateral boundary conditions358 CALL lbc_lnk( sge3ru , 'U', -1. ) ; CALL lbc_lnk( sge3rv, 'V', -1. ) ! Lateral boundary conditions512 CALL lbc_lnk( pgrui , 'U', -1. ) ; CALL lbc_lnk( pgrvi , 'V', -1. ) ! Lateral boundary conditions 513 CALL lbc_lnk( pmrui , 'U', 1. ) ; CALL lbc_lnk( pmrvi , 'V', 1. ) ! Lateral boundary conditions 514 CALL lbc_lnk( pgzui , 'U', -1. ) ; CALL lbc_lnk( pgzvi , 'V', -1. ) ! Lateral boundary conditions 515 CALL lbc_lnk( pge3rui , 'U', -1. ) ; CALL lbc_lnk( pge3rvi , 'V', -1. ) ! Lateral boundary conditions 359 516 ! 360 517 END IF 361 518 ! 362 IF( nn_timing == 1 ) CALL timing_stop( 'zps_hde') 363 ! 364 END SUBROUTINE zps_hde 365 519 IF( nn_timing == 1 ) CALL timing_stop( 'zps_hde_isf') 520 ! 521 END SUBROUTINE zps_hde_isf 366 522 !!====================================================================== 367 523 END MODULE zpshde -
branches/2014/dev_r4621_NOC4_BDY_VERT_INTERP/NEMOGCM/NEMO/OPA_SRC/TRD/trd_oce.F90
- Property svn:keywords set to Id
r5038 r5620 76 76 !!---------------------------------------------------------------------- 77 77 !! NEMO/OPA 3.3 , NEMO Consortium (2010) 78 !! $Id : trd_oce.F90 3318 2012-02-25 15:50:01Z gm$78 !! $Id$ 79 79 !! Software governed by the CeCILL licence (NEMOGCM/NEMO_CeCILL.txt) 80 80 !!====================================================================== -
branches/2014/dev_r4621_NOC4_BDY_VERT_INTERP/NEMOGCM/NEMO/OPA_SRC/TRD/trddyn.F90
- Property svn:keywords set to Id
r5038 r5620 40 40 !!---------------------------------------------------------------------- 41 41 !! NEMO/OPA 3.3 , NEMO Consortium (2010) 42 !! $Id : trddyn.F90 3325 2012-03-12 14:44:43Z gm$42 !! $Id$ 43 43 !! Software governed by the CeCILL licence (NEMOGCM/NEMO_CeCILL.txt) 44 44 !!---------------------------------------------------------------------- -
branches/2014/dev_r4621_NOC4_BDY_VERT_INTERP/NEMOGCM/NEMO/OPA_SRC/TRD/trdglo.F90
- Property svn:keywords set to Id
r5038 r5620 56 56 !!---------------------------------------------------------------------- 57 57 !! NEMO/OPA 3.3 , NEMO Consortium (2010) 58 !! $Id : trdglo.F90 3325 2012-03-12 14:44:43Z gm$58 !! $Id$ 59 59 !! Software governed by the CeCILL licence (NEMOGCM/NEMO_CeCILL.txt) 60 60 !!---------------------------------------------------------------------- -
branches/2014/dev_r4621_NOC4_BDY_VERT_INTERP/NEMOGCM/NEMO/OPA_SRC/TRD/trdini.F90
- Property svn:keywords set to Id
r5038 r5620 30 30 !!---------------------------------------------------------------------- 31 31 !! NEMO/OPA 3.3 , NEMO Consortium (2010) 32 !! $Id : trdini.F90 3329 2012-03-16 12:22:15Z gm$32 !! $Id$ 33 33 !! Software governed by the CeCILL licence (NEMOGCM/NEMO_CeCILL.txt) 34 34 !!---------------------------------------------------------------------- -
branches/2014/dev_r4621_NOC4_BDY_VERT_INTERP/NEMOGCM/NEMO/OPA_SRC/TRD/trdken.F90
- Property svn:keywords set to Id
r5038 r5620 44 44 !!---------------------------------------------------------------------- 45 45 !! NEMO/OPA 3.3 , NEMO Consortium (2010) 46 !! $Id : trdken.F90 3329 2012-03-16 12:22:15Z gm$46 !! $Id$ 47 47 !! Software governed by the CeCILL licence (NEMOGCM/NEMO_CeCILL.txt) 48 48 !!---------------------------------------------------------------------- -
branches/2014/dev_r4621_NOC4_BDY_VERT_INTERP/NEMOGCM/NEMO/OPA_SRC/TRD/trdmxl.F90
- Property svn:keywords set to Id
r5038 r5620 77 77 !!---------------------------------------------------------------------- 78 78 !! NEMO/OPA 3.3 , NEMO Consortium (2010) 79 !! $Id : trdmxl.F90 3318 2012-02-25 15:50:01Z gm$79 !! $Id$ 80 80 !! Software governed by the CeCILL licence (NEMOGCM/NEMO_CeCILL.txt) 81 81 !!---------------------------------------------------------------------- -
branches/2014/dev_r4621_NOC4_BDY_VERT_INTERP/NEMOGCM/NEMO/OPA_SRC/TRD/trdmxl_oce.F90
- Property svn:keywords set to Id
r5038 r5620 83 83 !!---------------------------------------------------------------------- 84 84 !! NEMO/OPA 4.0 , NEMO Consortium (2011) 85 !! $Id :$85 !! $Id$ 86 86 !! Software governed by the CeCILL licence (NEMOGCM/NEMO_CeCILL.txt) 87 87 !!---------------------------------------------------------------------- -
branches/2014/dev_r4621_NOC4_BDY_VERT_INTERP/NEMOGCM/NEMO/OPA_SRC/TRD/trdmxl_rst.F90
- Property svn:keywords set to Id
r5038 r5620 27 27 !!--------------------------------------------------------------------------------- 28 28 !! NEMO/OPA 3.3 , NEMO Consortium (2010) 29 !! $Id : $29 !! $Id$ 30 30 !! Software governed by the CeCILL licence (NEMOGCM/NEMO_CeCILL.txt) 31 31 !!--------------------------------------------------------------------------------- … … 43 43 INTEGER :: jk ! loop indice 44 44 CHARACTER(LEN=20) :: clkt ! ocean time-step deine as a character 45 CHARACTER(LEN=50) :: clname ! ice output restart file name 45 CHARACTER(LEN=50) :: clname ! output restart file name 46 CHARACTER(LEN=256) :: clpath ! full path to restart file 46 47 !!-------------------------------------------------------------------------------- 47 48 … … 56 57 ! create the file 57 58 clname = TRIM(cexper)//"_"//TRIM(ADJUSTL(clkt))//"_"//TRIM(cn_trdrst_out) 59 clpath = TRIM(cn_ocerst_outdir) 60 IF( clpath(LEN_TRIM(clpath):) /= '/' ) clpath = TRIM(clpath) // '/' 58 61 IF(lwp) THEN 59 62 WRITE(numout,*) … … 67 70 ENDIF 68 71 69 CALL iom_open( clname, nummxlw, ldwrt = .TRUE., kiolib = jprstlib )72 CALL iom_open( TRIM(clpath)//TRIM(clname), nummxlw, ldwrt = .TRUE., kiolib = jprstlib ) 70 73 ENDIF 71 74 … … 133 136 INTEGER :: jlibalt = jprstlib 134 137 LOGICAL :: llok 138 CHARACTER(LEN=256) :: clpath ! full path to restart file 135 139 !!----------------------------------------------------------------------------- 136 140 … … 140 144 WRITE(numout,*) ' ~~~~~~~~~~~~~~~~' 141 145 ENDIF 146 147 clpath = TRIM(cn_ocerst_indir) 148 IF( clpath(LEN_TRIM(clpath):) /= '/' ) clpath = TRIM(clpath) // '/' 149 142 150 IF ( jprstlib == jprstdimg ) THEN 143 151 ! eventually read netcdf file (monobloc) for restarting on different number of processors 144 152 ! if {cn_trdrst_in}.nc exists, then set jlibalt to jpnf90 145 INQUIRE( FILE = TRIM(c n_trdrst_in)//'.nc', EXIST = llok )153 INQUIRE( FILE = TRIM(clpath)//TRIM(cn_trdrst_in)//'.nc', EXIST = llok ) 146 154 IF ( llok ) THEN ; jlibalt = jpnf90 147 155 ELSE ; jlibalt = jprstlib … … 149 157 ENDIF 150 158 151 CALL iom_open( cn_trdrst_in, inum, kiolib = jlibalt )159 CALL iom_open( TRIM(clpath)//TRIM(cn_trdrst_in), inum, kiolib = jlibalt ) 152 160 153 161 IF( ln_trdmxl_instant ) THEN -
branches/2014/dev_r4621_NOC4_BDY_VERT_INTERP/NEMOGCM/NEMO/OPA_SRC/TRD/trdpen.F90
- Property svn:keywords set to Id
r5038 r5620 41 41 !!---------------------------------------------------------------------- 42 42 !! NEMO/OPA 3.3 , NEMO Consortium (2010) 43 !! $Id : trdtra.F90 3318 2012-02-25 15:50:01Z gm$43 !! $Id$ 44 44 !! Software governed by the CeCILL licence (NEMOGCM/NEMO_CeCILL.txt) 45 45 !!---------------------------------------------------------------------- -
branches/2014/dev_r4621_NOC4_BDY_VERT_INTERP/NEMOGCM/NEMO/OPA_SRC/TRD/trdtrc.F90
- Property svn:keywords set to Id
r5038 r5620 18 18 !!---------------------------------------------------------------------- 19 19 !! NEMO/OPA 3.3 , NEMO Consortium (2010) 20 !! $Id : trdtrc.F90 2715 2011-03-30 15:58:35Z rblod$20 !! $Id$ 21 21 !! Software governed by the CeCILL licence (NEMOGCM/NEMO_CeCILL.txt) 22 22 !!====================================================================== -
branches/2014/dev_r4621_NOC4_BDY_VERT_INTERP/NEMOGCM/NEMO/OPA_SRC/ZDF/zdfbfr.F90
r5038 r5620 120 120 zbfrt(ji,jj) = MAX(bfrcoef2d(ji,jj), ztmp) 121 121 zbfrt(ji,jj) = MIN(zbfrt(ji,jj), rn_bfri2_max) 122 ! (ISF)123 ikbt = mikt(ji,jj)124 ! JC: possible WAD implementation should modify line below if layers vanish125 ztmp = tmask(ji,jj,ikbt) * ( vkarmn / LOG( 0.5_wp * fse3t_n(ji,jj,ikbt) / rn_bfrz0 ))**2._wp126 ztfrt(ji,jj) = MAX(tfrcoef2d(ji,jj), ztmp)127 ztfrt(ji,jj) = MIN(ztfrt(ji,jj), rn_tfri2_max)128 129 122 END DO 130 123 END DO 124 ! (ISF) 125 IF ( ln_isfcav ) THEN 126 DO jj = 1, jpj 127 DO ji = 1, jpi 128 ikbt = mikt(ji,jj) 129 ! JC: possible WAD implementation should modify line below if layers vanish 130 ztmp = (1-tmask(ji,jj,1)) * ( vkarmn / LOG( 0.5_wp * fse3t_n(ji,jj,ikbt) / rn_bfrz0 ))**2._wp 131 ztfrt(ji,jj) = MAX(tfrcoef2d(ji,jj), ztmp) 132 ztfrt(ji,jj) = MIN(ztfrt(ji,jj), rn_tfri2_max) 133 END DO 134 END DO 135 END IF 131 136 ! 132 137 ELSE … … 152 157 ! 153 158 ! in case of 2 cell water column, we assume each cell feels the top and bottom friction 154 IF ( miku(ji,jj) + 2 .GE. mbku(ji,jj) ) THEN 155 bfrua(ji,jj) = - 0.5_wp * ( ( zbfrt(ji,jj) + zbfrt(ji+1,jj ) ) & 156 & + ( ztfrt(ji,jj) + ztfrt(ji+1,jj ) ) ) & 157 & * zecu * (1._wp - umask(ji,jj,1)) 158 END IF 159 IF ( mikv(ji,jj) + 2 .GE. mbkv(ji,jj) ) THEN 160 bfrva(ji,jj) = - 0.5_wp * ( ( zbfrt(ji,jj) + zbfrt(ji ,jj+1) ) & 161 & + ( ztfrt(ji,jj) + ztfrt(ji ,jj+1) ) ) & 162 & * zecv * (1._wp - vmask(ji,jj,1)) 163 END IF 164 ! (ISF) ======================================================================== 165 ikbu = miku(ji,jj) ! ocean bottom level at u- and v-points 166 ikbv = mikv(ji,jj) ! (deepest ocean u- and v-points) 167 ! 168 zvu = 0.25 * ( vn(ji,jj ,ikbu) + vn(ji+1,jj ,ikbu) & 169 & + vn(ji,jj-1,ikbu) + vn(ji+1,jj-1,ikbu) ) 170 zuv = 0.25 * ( un(ji,jj ,ikbv) + un(ji-1,jj ,ikbv) & 171 & + un(ji,jj+1,ikbv) + un(ji-1,jj+1,ikbv) ) 172 ! 173 zecu = SQRT( un(ji,jj,ikbu) * un(ji,jj,ikbu) + zvu*zvu + rn_bfeb2 ) 174 zecv = SQRT( vn(ji,jj,ikbv) * vn(ji,jj,ikbv) + zuv*zuv + rn_bfeb2 ) 175 ! 176 tfrua(ji,jj) = - 0.5_wp * ( ztfrt(ji,jj) + ztfrt(ji+1,jj ) ) * zecu * (1._wp - umask(ji,jj,1)) 177 tfrva(ji,jj) = - 0.5_wp * ( ztfrt(ji,jj) + ztfrt(ji ,jj+1) ) * zecv * (1._wp - vmask(ji,jj,1)) 178 ! (ISF) END ==================================================================== 179 ! in case of 2 cell water column, we assume each cell feels the top and bottom friction 180 IF ( miku(ji,jj) + 2 .GE. mbku(ji,jj) ) THEN 181 tfrua(ji,jj) = - 0.5_wp * ( ( ztfrt(ji,jj) + ztfrt(ji+1,jj ) ) & 182 & + ( zbfrt(ji,jj) + zbfrt(ji+1,jj ) ) ) & 183 & * zecu * (1._wp - umask(ji,jj,1)) 184 END IF 185 IF ( mikv(ji,jj) + 2 .GE. mbkv(ji,jj) ) THEN 186 tfrva(ji,jj) = - 0.5_wp * ( ( ztfrt(ji,jj) + ztfrt(ji ,jj+1) ) & 187 & + ( zbfrt(ji,jj) + zbfrt(ji ,jj+1) ) ) & 188 & * zecv * (1._wp - vmask(ji,jj,1)) 159 IF ( ln_isfcav ) THEN 160 IF ( miku(ji,jj) + 1 .GE. mbku(ji,jj) ) THEN 161 bfrua(ji,jj) = - 0.5_wp * ( ( zbfrt(ji,jj) + zbfrt(ji+1,jj ) ) & 162 & + ( ztfrt(ji,jj) + ztfrt(ji+1,jj ) ) ) & 163 & * zecu * (1._wp - umask(ji,jj,1)) 164 END IF 165 IF ( mikv(ji,jj) + 1 .GE. mbkv(ji,jj) ) THEN 166 bfrva(ji,jj) = - 0.5_wp * ( ( zbfrt(ji,jj) + zbfrt(ji ,jj+1) ) & 167 & + ( ztfrt(ji,jj) + ztfrt(ji ,jj+1) ) ) & 168 & * zecv * (1._wp - vmask(ji,jj,1)) 169 END IF 189 170 END IF 190 171 END DO 191 172 END DO 192 !193 173 CALL lbc_lnk( bfrua, 'U', 1. ) ; CALL lbc_lnk( bfrva, 'V', 1. ) ! Lateral boundary condition 174 175 IF ( ln_isfcav ) THEN 176 DO jj = 2, jpjm1 177 DO ji = 2, jpim1 178 ! (ISF) ======================================================================== 179 ikbu = miku(ji,jj) ! ocean top level at u- and v-points 180 ikbv = mikv(ji,jj) ! (1st wet ocean u- and v-points) 181 ! 182 zvu = 0.25 * ( vn(ji,jj ,ikbu) + vn(ji+1,jj ,ikbu) & 183 & + vn(ji,jj-1,ikbu) + vn(ji+1,jj-1,ikbu) ) 184 zuv = 0.25 * ( un(ji,jj ,ikbv) + un(ji-1,jj ,ikbv) & 185 & + un(ji,jj+1,ikbv) + un(ji-1,jj+1,ikbv) ) 186 ! 187 zecu = SQRT( un(ji,jj,ikbu) * un(ji,jj,ikbu) + zvu*zvu + rn_tfeb2 ) 188 zecv = SQRT( vn(ji,jj,ikbv) * vn(ji,jj,ikbv) + zuv*zuv + rn_tfeb2 ) 189 ! 190 tfrua(ji,jj) = - 0.5_wp * ( ztfrt(ji,jj) + ztfrt(ji+1,jj ) ) * zecu * (1._wp - umask(ji,jj,1)) 191 tfrva(ji,jj) = - 0.5_wp * ( ztfrt(ji,jj) + ztfrt(ji ,jj+1) ) * zecv * (1._wp - vmask(ji,jj,1)) 192 ! (ISF) END ==================================================================== 193 ! in case of 2 cell water column, we assume each cell feels the top and bottom friction 194 IF ( miku(ji,jj) + 1 .GE. mbku(ji,jj) ) THEN 195 tfrua(ji,jj) = - 0.5_wp * ( ( ztfrt(ji,jj) + ztfrt(ji+1,jj ) ) & 196 & + ( zbfrt(ji,jj) + zbfrt(ji+1,jj ) ) ) & 197 & * zecu * (1._wp - umask(ji,jj,1)) 198 END IF 199 IF ( mikv(ji,jj) + 1 .GE. mbkv(ji,jj) ) THEN 200 tfrva(ji,jj) = - 0.5_wp * ( ( ztfrt(ji,jj) + ztfrt(ji ,jj+1) ) & 201 & + ( zbfrt(ji,jj) + zbfrt(ji ,jj+1) ) ) & 202 & * zecv * (1._wp - vmask(ji,jj,1)) 203 END IF 204 END DO 205 END DO 206 CALL lbc_lnk( tfrua, 'U', 1. ) ; CALL lbc_lnk( tfrva, 'V', 1. ) ! Lateral boundary condition 207 END IF 208 ! 194 209 ! 195 210 IF(ln_ctl) CALL prt_ctl( tab2d_1=bfrua, clinfo1=' bfr - u: ', mask1=umask, & … … 264 279 IF(lwp) WRITE(numout,*) ' coef rn_bfri2 enhancement factor rn_bfrien = ',rn_bfrien 265 280 ENDIF 266 IF(lwp) WRITE(numout,*) ' top friction coef. rn_bfri1 = ', rn_bfri1 267 IF( ln_tfr2d ) THEN 268 IF(lwp) WRITE(numout,*) ' read coef. enhancement distribution from file ln_tfr2d = ', ln_tfr2d 269 IF(lwp) WRITE(numout,*) ' coef rn_tfri2 enhancement factor rn_tfrien = ',rn_tfrien 270 ENDIF 281 IF ( ln_isfcav ) THEN 282 IF(lwp) WRITE(numout,*) ' top friction coef. rn_bfri1 = ', rn_tfri1 283 IF( ln_tfr2d ) THEN 284 IF(lwp) WRITE(numout,*) ' read coef. enhancement distribution from file ln_tfr2d = ', ln_tfr2d 285 IF(lwp) WRITE(numout,*) ' coef rn_tfri2 enhancement factor rn_tfrien = ',rn_tfrien 286 ENDIF 287 END IF 271 288 ! 272 289 IF(ln_bfr2d) THEN … … 282 299 bfrua(:,:) = - bfrcoef2d(:,:) 283 300 bfrva(:,:) = - bfrcoef2d(:,:) 301 ! 302 IF ( ln_isfcav ) THEN 303 IF(ln_tfr2d) THEN 304 ! tfr_coef is a coefficient in [0,1] giving the mask where to apply the bfr enhancement 305 CALL iom_open('tfr_coef.nc',inum) 306 CALL iom_get (inum, jpdom_data, 'tfr_coef',tfrcoef2d,1) ! tfrcoef2d is used as tmp array 307 CALL iom_close(inum) 308 tfrcoef2d(:,:) = rn_tfri1 * ( 1 + rn_tfrien * tfrcoef2d(:,:) ) 309 ELSE 310 tfrcoef2d(:,:) = rn_tfri1 ! initialize tfrcoef2d to the namelist variable 311 ENDIF 312 ! 313 tfrua(:,:) = - tfrcoef2d(:,:) 314 tfrva(:,:) = - tfrcoef2d(:,:) 315 END IF 284 316 ! 285 317 CASE( 2 ) … … 298 330 IF(lwp) WRITE(numout,*) ' coef rn_bfri2 enhancement factor rn_bfrien = ',rn_bfrien 299 331 ENDIF 300 IF(lwp) WRITE(numout,*) ' quadratic top friction' 301 IF(lwp) WRITE(numout,*) ' friction coef. rn_bfri2 = ', rn_tfri2 302 IF(lwp) WRITE(numout,*) ' Max. coef. (log case) rn_tfri2_max = ', rn_tfri2_max 303 IF(lwp) WRITE(numout,*) ' background tke rn_tfeb2 = ', rn_tfeb2 304 IF(lwp) WRITE(numout,*) ' log formulation ln_tfr2d = ', ln_loglayer 305 IF(lwp) WRITE(numout,*) ' bottom roughness rn_tfrz0 [m] = ', rn_tfrz0 306 IF( rn_tfrz0<=0.e0 ) THEN 307 WRITE(ctmp1,*) ' bottom roughness must be strictly positive' 308 CALL ctl_stop( ctmp1 ) 309 ENDIF 310 IF( ln_tfr2d ) THEN 311 IF(lwp) WRITE(numout,*) ' read coef. enhancement distribution from file ln_tfr2d = ', ln_tfr2d 312 IF(lwp) WRITE(numout,*) ' coef rn_tfri2 enhancement factor rn_tfrien = ',rn_tfrien 313 ENDIF 332 IF ( ln_isfcav ) THEN 333 IF(lwp) WRITE(numout,*) ' quadratic top friction' 334 IF(lwp) WRITE(numout,*) ' friction coef. rn_tfri2 = ', rn_tfri2 335 IF(lwp) WRITE(numout,*) ' Max. coef. (log case) rn_tfri2_max = ', rn_tfri2_max 336 IF(lwp) WRITE(numout,*) ' background tke rn_tfeb2 = ', rn_tfeb2 337 IF(lwp) WRITE(numout,*) ' log formulation ln_tfr2d = ', ln_loglayer 338 IF(lwp) WRITE(numout,*) ' top roughness rn_tfrz0 [m] = ', rn_tfrz0 339 IF( rn_tfrz0<=0.e0 ) THEN 340 WRITE(ctmp1,*) ' top roughness must be strictly positive' 341 CALL ctl_stop( ctmp1 ) 342 ENDIF 343 IF( ln_tfr2d ) THEN 344 IF(lwp) WRITE(numout,*) ' read coef. enhancement distribution from file ln_tfr2d = ', ln_tfr2d 345 IF(lwp) WRITE(numout,*) ' coef rn_tfri2 enhancement factor rn_tfrien = ',rn_tfrien 346 ENDIF 347 END IF 314 348 ! 315 349 IF(ln_bfr2d) THEN … … 323 357 bfrcoef2d(:,:) = rn_bfri2 ! initialize bfrcoef2d to the namelist variable 324 358 ENDIF 359 360 IF ( ln_isfcav ) THEN 361 IF(ln_tfr2d) THEN 362 ! tfr_coef is a coefficient in [0,1] giving the mask where to apply the bfr enhancement 363 CALL iom_open('tfr_coef.nc',inum) 364 CALL iom_get (inum, jpdom_data, 'tfr_coef',tfrcoef2d,1) ! tfrcoef2d is used as tmp array 365 CALL iom_close(inum) 366 ! 367 tfrcoef2d(:,:) = rn_tfri2 * ( 1 + rn_tfrien * tfrcoef2d(:,:) ) 368 ELSE 369 tfrcoef2d(:,:) = rn_tfri2 ! initialize tfrcoef2d to the namelist variable 370 ENDIF 371 END IF 325 372 ! 326 373 IF ( ln_loglayer.AND.(.NOT.lk_vvl) ) THEN ! set "log layer" bottom friction once for all … … 333 380 END DO 334 381 END DO 382 IF ( ln_isfcav ) THEN 383 DO jj = 1, jpj 384 DO ji = 1, jpi 385 ikbt = mikt(ji,jj) 386 ztmp = tmask(ji,jj,ikbt) * ( vkarmn / LOG( 0.5_wp * fse3t_n(ji,jj,ikbt) / rn_tfrz0 ))**2._wp 387 tfrcoef2d(ji,jj) = MAX(tfrcoef2d(ji,jj), ztmp) 388 tfrcoef2d(ji,jj) = MIN(tfrcoef2d(ji,jj), rn_tfri2_max) 389 END DO 390 END DO 391 END IF 335 392 ENDIF 336 393 ! … … 385 442 zminbfr = MIN( zminbfr, MIN( zfru, ABS( bfrcoef2d(ji,jj) ) ) ) 386 443 zmaxbfr = MAX( zmaxbfr, MIN( zfrv, ABS( bfrcoef2d(ji,jj) ) ) ) 444 ! (ISF) 445 IF ( ln_isfcav ) THEN 446 ikbu = miku(ji,jj) ! 1st wet ocean level at u- and v-points 447 ikbv = mikv(ji,jj) 448 zfru = 0.5 * fse3u(ji,jj,ikbu) / rdt 449 zfrv = 0.5 * fse3v(ji,jj,ikbv) / rdt 450 IF( ABS( tfrcoef2d(ji,jj) ) > zfru ) THEN 451 IF( ln_ctl ) THEN 452 WRITE(numout,*) 'TFR ', narea, nimpp+ji, njmpp+jj, ikbu 453 WRITE(numout,*) 'TFR ', ABS( tfrcoef2d(ji,jj) ), zfru 454 ENDIF 455 ictu = ictu + 1 456 ENDIF 457 IF( ABS( tfrcoef2d(ji,jj) ) > zfrv ) THEN 458 IF( ln_ctl ) THEN 459 WRITE(numout,*) 'TFR ', narea, nimpp+ji, njmpp+jj, ikbv 460 WRITE(numout,*) 'TFR ', tfrcoef2d(ji,jj), zfrv 461 ENDIF 462 ictv = ictv + 1 463 ENDIF 464 zmintfr = MIN( zmintfr, MIN( zfru, ABS( tfrcoef2d(ji,jj) ) ) ) 465 zmaxtfr = MAX( zmaxtfr, MIN( zfrv, ABS( tfrcoef2d(ji,jj) ) ) ) 466 END IF 467 ! END ISF 387 468 END DO 388 469 END DO … … 392 473 CALL mpp_min( zminbfr ) 393 474 CALL mpp_max( zmaxbfr ) 475 IF ( ln_isfcav) CALL mpp_min( zmintfr ) 476 IF ( ln_isfcav) CALL mpp_max( zmaxtfr ) 394 477 ENDIF 395 478 IF( .NOT.ln_bfrimp) THEN 396 479 IF( lwp .AND. ictu + ictv > 0 ) THEN 397 WRITE(numout,*) ' Bottom friction stability check failed at ', ictu, ' U-points '398 WRITE(numout,*) ' Bottom friction stability check failed at ', ictv, ' V-points '480 WRITE(numout,*) ' Bottom/Top friction stability check failed at ', ictu, ' U-points ' 481 WRITE(numout,*) ' Bottom/Top friction stability check failed at ', ictv, ' V-points ' 399 482 WRITE(numout,*) ' Bottom friction coefficient now ranges from: ', zminbfr, ' to ', zmaxbfr 400 WRITE(numout,*) ' Bottomfriction coefficient now ranges from: ', zmintfr, ' to ', zmaxtfr401 WRITE(numout,*) ' Bottom friction coefficient will be reduced where necessary'483 IF ( ln_isfcav ) WRITE(numout,*) ' Top friction coefficient now ranges from: ', zmintfr, ' to ', zmaxtfr 484 WRITE(numout,*) ' Bottom/Top friction coefficient will be reduced where necessary' 402 485 ENDIF 403 486 ENDIF -
branches/2014/dev_r4621_NOC4_BDY_VERT_INTERP/NEMOGCM/NEMO/OPA_SRC/ZDF/zdfddm.F90
r5038 r5620 156 156 END DO 157 157 ! mask zmsk in order to have avt and avs masked 158 zmsks(:,:) = zmsks(:,:) * tmask(:,:,jk)158 zmsks(:,:) = zmsks(:,:) * wmask(:,:,jk) 159 159 160 160 … … 191 191 avmu(ji,jj,jk) = MAX( avmu(ji,jj,jk), & 192 192 & avt(ji,jj,jk), avt(ji+1,jj,jk), & 193 & avs(ji,jj,jk), avs(ji+1,jj,jk) ) * umask(ji,jj,jk)193 & avs(ji,jj,jk), avs(ji+1,jj,jk) ) * wumask(ji,jj,jk) 194 194 avmv(ji,jj,jk) = MAX( avmv(ji,jj,jk), & 195 195 & avt(ji,jj,jk), avt(ji,jj+1,jk), & 196 & avs(ji,jj,jk), avs(ji,jj+1,jk) ) * vmask(ji,jj,jk)196 & avs(ji,jj,jk), avs(ji,jj+1,jk) ) * wvmask(ji,jj,jk) 197 197 END DO 198 198 END DO … … 255 255 IF( zdf_ddm_alloc() /= 0 ) CALL ctl_stop( 'STOP', 'zdf_ddm_init : unable to allocate arrays' ) 256 256 ! ! initialization to masked Kz 257 avs(:,:,:) = rn_avt0 * tmask(:,:,:)257 avs(:,:,:) = rn_avt0 * wmask(:,:,:) 258 258 ! 259 259 END SUBROUTINE zdf_ddm_init -
branches/2014/dev_r4621_NOC4_BDY_VERT_INTERP/NEMOGCM/NEMO/OPA_SRC/ZDF/zdfgls.F90
r5038 r5620 20 20 USE domvvl ! ocean space and time domain : variable volume layer 21 21 USE zdf_oce ! ocean vertical physics 22 USE zdfbfr ! bottom friction (only for rn_bfrz0) 22 23 USE sbc_oce ! surface boundary condition: ocean 23 24 USE phycst ! physical constants … … 52 53 53 54 ! !! ** Namelist namzdf_gls ** 54 LOGICAL :: ln_crban ! =T use Craig and Banner scheme55 55 LOGICAL :: ln_length_lim ! use limit on the dissipation rate under stable stratification (Galperin et al. 1988) 56 56 LOGICAL :: ln_sigpsi ! Activate Burchard (2003) modification for k-eps closure & wave breaking mixing 57 INTEGER :: nn_tkebc_surf ! TKE surface boundary condition (=0/1) 58 INTEGER :: nn_tkebc_bot ! TKE bottom boundary condition (=0/1) 59 INTEGER :: nn_psibc_surf ! PSI surface boundary condition (=0/1) 60 INTEGER :: nn_psibc_bot ! PSI bottom boundary condition (=0/1) 57 INTEGER :: nn_bc_surf ! surface boundary condition (=0/1) 58 INTEGER :: nn_bc_bot ! bottom boundary condition (=0/1) 59 INTEGER :: nn_z0_met ! Method for surface roughness computation 61 60 INTEGER :: nn_stab_func ! stability functions G88, KC or Canuto (=0/1/2) 62 61 INTEGER :: nn_clos ! closure 0/1/2/3 MY82/k-eps/k-w/gen … … 66 65 REAL(wp) :: rn_charn ! Charnock constant for surface breaking waves mixing : 1400. (standard) or 2.e5 (Stacey value) 67 66 REAL(wp) :: rn_crban ! Craig and Banner constant for surface breaking waves mixing 68 69 REAL(wp) :: hsro = 0.003_wp ! Minimum surface roughness70 REAL(wp) :: hbro = 0.003_wp ! Bottom roughness (m) 67 REAL(wp) :: rn_hsro ! Minimum surface roughness 68 REAL(wp) :: rn_frac_hs ! Fraction of wave height as surface roughness (if nn_z0_met > 1) 69 71 70 REAL(wp) :: rcm_sf = 0.73_wp ! Shear free turbulence parameters 72 71 REAL(wp) :: ra_sf = -2.0_wp ! Must be negative -2 < ra_sf < -1 … … 96 95 REAL(wp) :: rm7 = 0.0_wp 97 96 REAL(wp) :: rm8 = 0.318_wp 98 97 REAL(wp) :: rtrans = 0.1_wp 99 98 REAL(wp) :: rc02, rc02r, rc03, rc04 ! coefficients deduced from above parameters 100 REAL(wp) :: rc03_sqrt2_galp ! - - - - 101 REAL(wp) :: rsbc_tke1, rsbc_tke2, rsbc_tke3, rfact_tke ! - - - - 102 REAL(wp) :: rsbc_psi1, rsbc_psi2, rsbc_psi3, rfact_psi ! - - - - 103 REAL(wp) :: rsbc_mb , rsbc_std , rsbc_zs ! - - - - 99 REAL(wp) :: rsbc_tke1, rsbc_tke2, rfact_tke ! - - - - 100 REAL(wp) :: rsbc_psi1, rsbc_psi2, rfact_psi ! - - - - 101 REAL(wp) :: rsbc_zs1, rsbc_zs2 ! - - - - 104 102 REAL(wp) :: rc0, rc2, rc3, rf6, rcff, rc_diff ! - - - - 105 103 REAL(wp) :: rs0, rs1, rs2, rs4, rs5, rs6 ! - - - - … … 147 145 REAL(wp) :: gh, gm, shr, dif, zsqen, zav ! - - 148 146 REAL(wp), POINTER, DIMENSION(:,: ) :: zdep 147 REAL(wp), POINTER, DIMENSION(:,: ) :: zkar 149 148 REAL(wp), POINTER, DIMENSION(:,: ) :: zflxs ! Turbulence fluxed induced by internal waves 150 149 REAL(wp), POINTER, DIMENSION(:,: ) :: zhsro ! Surface roughness (surface waves) … … 153 152 REAL(wp), POINTER, DIMENSION(:,:,:) :: shear ! vertical shear 154 153 REAL(wp), POINTER, DIMENSION(:,:,:) :: eps ! dissipation rate 155 REAL(wp), POINTER, DIMENSION(:,:,:) :: zwall_psi ! Wall function use in the wb case (ln_sigpsi.AND.ln_crban=T) 156 REAL(wp), POINTER, DIMENSION(:,:,:) :: z_elem_a, z_elem_b, z_elem_c, psi 154 REAL(wp), POINTER, DIMENSION(:,:,:) :: zwall_psi ! Wall function use in the wb case (ln_sigpsi) 155 REAL(wp), POINTER, DIMENSION(:,:,:) :: psi ! psi at time now 156 REAL(wp), POINTER, DIMENSION(:,:,:) :: z_elem_a ! element of the first matrix diagonal 157 REAL(wp), POINTER, DIMENSION(:,:,:) :: z_elem_b ! element of the second matrix diagonal 158 REAL(wp), POINTER, DIMENSION(:,:,:) :: z_elem_c ! element of the third matrix diagonal 157 159 !!-------------------------------------------------------------------- 158 160 ! 159 161 IF( nn_timing == 1 ) CALL timing_start('zdf_gls') 160 162 ! 161 CALL wrk_alloc( jpi,jpj, zdep, z flxs, zhsro )162 CALL wrk_alloc( jpi,jpj,jpk, eb, mxlb, shear, eps, zwall_psi, z_elem_a, z_elem_b, z_elem_c, psi )163 163 CALL wrk_alloc( jpi,jpj, zdep, zkar, zflxs, zhsro ) 164 CALL wrk_alloc( jpi,jpj,jpk, eb, mxlb, shear, eps, zwall_psi, z_elem_a, z_elem_b, z_elem_c, psi ) 165 164 166 ! Preliminary computing 165 167 … … 174 176 175 177 ! Compute surface and bottom friction at T-points 176 !CDIR NOVERRCHK 177 DO jj = 2, jpjm1 178 !CDIR NOVERRCHK 179 DO ji = fs_2, fs_jpim1 ! vector opt. 180 ! 181 ! surface friction 178 !CDIR NOVERRCHK 179 DO jj = 2, jpjm1 180 !CDIR NOVERRCHK 181 DO ji = fs_2, fs_jpim1 ! vector opt. 182 ! 183 ! surface friction 182 184 ustars2(ji,jj) = r1_rau0 * taum(ji,jj) * tmask(ji,jj,1) 183 ! 184 ! bottom friction (explicit before friction) 185 ! Note that we chose here not to bound the friction as in dynbfr) 186 ztx2 = ( bfrua(ji,jj) * ub(ji,jj,mbku(ji,jj)) + bfrua(ji-1,jj) * ub(ji-1,jj,mbku(ji-1,jj)) ) & 187 & * ( 1._wp - 0.5_wp * umask(ji,jj,1) * umask(ji-1,jj,1) ) 188 zty2 = ( bfrva(ji,jj) * vb(ji,jj,mbkv(ji,jj)) + bfrva(ji,jj-1) * vb(ji,jj-1,mbkv(ji,jj-1)) ) & 189 & * ( 1._wp - 0.5_wp * vmask(ji,jj,1) * vmask(ji,jj-1,1) ) 190 ustarb2(ji,jj) = SQRT( ztx2 * ztx2 + zty2 * zty2 ) * tmask(ji,jj,1) 191 END DO 192 END DO 193 194 ! In case of breaking surface waves mixing, 195 ! Compute surface roughness length according to Charnock formula: 196 IF( ln_crban ) THEN ; zhsro(:,:) = MAX(rsbc_zs * ustars2(:,:), hsro) 197 ELSE ; zhsro(:,:) = hsro 198 ENDIF 185 ! 186 ! bottom friction (explicit before friction) 187 ! Note that we chose here not to bound the friction as in dynbfr) 188 ztx2 = ( bfrua(ji,jj) * ub(ji,jj,mbku(ji,jj)) + bfrua(ji-1,jj) * ub(ji-1,jj,mbku(ji-1,jj)) ) & 189 & * ( 1._wp - 0.5_wp * umask(ji,jj,1) * umask(ji-1,jj,1) ) 190 zty2 = ( bfrva(ji,jj) * vb(ji,jj,mbkv(ji,jj)) + bfrva(ji,jj-1) * vb(ji,jj-1,mbkv(ji,jj-1)) ) & 191 & * ( 1._wp - 0.5_wp * vmask(ji,jj,1) * vmask(ji,jj-1,1) ) 192 ustarb2(ji,jj) = SQRT( ztx2 * ztx2 + zty2 * zty2 ) * tmask(ji,jj,1) 193 END DO 194 END DO 195 196 ! Set surface roughness length 197 SELECT CASE ( nn_z0_met ) 198 ! 199 CASE ( 0 ) ! Constant roughness 200 zhsro(:,:) = rn_hsro 201 CASE ( 1 ) ! Standard Charnock formula 202 zhsro(:,:) = MAX(rsbc_zs1 * ustars2(:,:), rn_hsro) 203 CASE ( 2 ) ! Roughness formulae according to Rascle et al., Ocean Modelling (2008) 204 zdep(:,:) = 30.*TANH(2.*0.3/(28.*SQRT(MAX(ustars2(:,:),rsmall)))) ! Wave age (eq. 10) 205 zhsro(:,:) = MAX(rsbc_zs2 * ustars2(:,:) * zdep(:,:)**1.5, rn_hsro) ! zhsro = rn_frac_hs * Hsw (eq. 11) 206 ! 207 END SELECT 199 208 200 209 ! Compute shear and dissipation rate … … 303 312 ! 304 313 ! Set surface condition on zwall_psi (1 at the bottom) 305 IF( ln_sigpsi ) THEN 306 zcoef = rsc_psi / rsc_psi0 307 DO jj = 2, jpjm1 308 DO ji = fs_2, fs_jpim1 ! vector opt. 309 zwall_psi(ji,jj,1) = zcoef 310 END DO 311 END DO 312 ENDIF 313 314 zwall_psi(:,:,1) = zwall_psi(:,:,2) 315 zwall_psi(:,:,jpk) = 1. 316 ! 314 317 ! Surface boundary condition on tke 315 318 ! --------------------------------- 316 319 ! 317 SELECT CASE ( nn_ tkebc_surf )320 SELECT CASE ( nn_bc_surf ) 318 321 ! 319 322 CASE ( 0 ) ! Dirichlet case 320 ! 321 IF (ln_crban) THEN ! Wave induced mixing case 322 ! ! en(1) = q2(1) = 0.5 * (15.8 * Ccb)^(2/3) * u*^2 323 ! ! balance between the production and the dissipation terms including the wave effect 324 en(:,:,1) = MAX( rsbc_tke1 * ustars2(:,:), rn_emin ) 325 z_elem_a(:,:,1) = en(:,:,1) 326 z_elem_c(:,:,1) = 0._wp 327 z_elem_b(:,:,1) = 1._wp 328 ! 329 ! one level below 330 en(:,:,2) = MAX( rsbc_tke1 * ustars2(:,:) * ( (zhsro(:,:)+fsdepw(:,:,2))/zhsro(:,:) )**ra_sf, rn_emin ) 331 z_elem_a(:,:,2) = 0._wp 332 z_elem_c(:,:,2) = 0._wp 333 z_elem_b(:,:,2) = 1._wp 334 ! 335 ELSE ! No wave induced mixing case 336 ! ! en(1) = u*^2/C0^2 & l(1) = K*zs 337 ! ! balance between the production and the dissipation terms 338 en(:,:,1) = MAX( rc02r * ustars2(:,:), rn_emin ) 339 z_elem_a(:,:,1) = en(:,:,1) 340 z_elem_c(:,:,1) = 0._wp 341 z_elem_b(:,:,1) = 1._wp 342 ! 343 ! one level below 344 en(:,:,2) = MAX( rc02r * ustars2(:,:), rn_emin ) 345 z_elem_a(:,:,2) = 0._wp 346 z_elem_c(:,:,2) = 0._wp 347 z_elem_b(:,:,2) = 1._wp 348 ! 349 ENDIF 350 ! 323 ! First level 324 en(:,:,1) = rc02r * ustars2(:,:) * (1._wp + rsbc_tke1)**(2._wp/3._wp) 325 en(:,:,1) = MAX(en(:,:,1), rn_emin) 326 z_elem_a(:,:,1) = en(:,:,1) 327 z_elem_c(:,:,1) = 0._wp 328 z_elem_b(:,:,1) = 1._wp 329 ! 330 ! One level below 331 en(:,:,2) = rc02r * ustars2(:,:) * (1._wp + rsbc_tke1 * ((zhsro(:,:)+fsdepw(:,:,2)) & 332 & / zhsro(:,:) )**(1.5_wp*ra_sf))**(2._wp/3._wp) 333 en(:,:,2) = MAX(en(:,:,2), rn_emin ) 334 z_elem_a(:,:,2) = 0._wp 335 z_elem_c(:,:,2) = 0._wp 336 z_elem_b(:,:,2) = 1._wp 337 ! 338 ! 351 339 CASE ( 1 ) ! Neumann boundary condition on d(e)/dz 352 ! 353 IF (ln_crban) THEN ! Shear free case: d(e)/dz= Fw 354 ! 355 ! Dirichlet conditions at k=1 (Cosmetic) 356 en(:,:,1) = MAX( rsbc_tke1 * ustars2(:,:), rn_emin ) 357 z_elem_a(:,:,1) = en(:,:,1) 358 z_elem_c(:,:,1) = 0._wp 359 z_elem_b(:,:,1) = 1._wp 360 ! at k=2, set de/dz=Fw 361 z_elem_b(:,:,2) = z_elem_b(:,:,2) + z_elem_a(:,:,2) ! Remove z_elem_a from z_elem_b 362 z_elem_a(:,:,2) = 0._wp 363 zflxs(:,:) = rsbc_tke3 * ustars2(:,:)**1.5_wp * ( (zhsro(:,:)+fsdept(:,:,1) ) / zhsro(:,:) )**(1.5*ra_sf) 364 en(:,:,2) = en(:,:,2) + zflxs(:,:) / fse3w(:,:,2) 365 ! 366 ELSE ! No wave induced mixing case: d(e)/dz=0. 367 ! 368 ! Dirichlet conditions at k=1 (Cosmetic) 369 en(:,:,1) = MAX( rc02r * ustars2(:,:), rn_emin ) 370 z_elem_a(:,:,1) = en(:,:,1) 371 z_elem_c(:,:,1) = 0._wp 372 z_elem_b(:,:,1) = 1._wp 373 ! at k=2 set de/dz=0.: 374 z_elem_b(:,:,2) = z_elem_b(:,:,2) + z_elem_a(:,:,2) ! Remove z_elem_a from z_elem_b 375 z_elem_a(:,:,2) = 0._wp 376 ! 377 ENDIF 378 ! 340 ! 341 ! Dirichlet conditions at k=1 342 en(:,:,1) = rc02r * ustars2(:,:) * (1._wp + rsbc_tke1)**(2._wp/3._wp) 343 en(:,:,1) = MAX(en(:,:,1), rn_emin) 344 z_elem_a(:,:,1) = en(:,:,1) 345 z_elem_c(:,:,1) = 0._wp 346 z_elem_b(:,:,1) = 1._wp 347 ! 348 ! at k=2, set de/dz=Fw 349 !cbr 350 z_elem_b(:,:,2) = z_elem_b(:,:,2) + z_elem_a(:,:,2) ! Remove z_elem_a from z_elem_b 351 z_elem_a(:,:,2) = 0._wp 352 zkar(:,:) = (rl_sf + (vkarmn-rl_sf)*(1.-exp(-rtrans*fsdept(:,:,1)/zhsro(:,:)) )) 353 zflxs(:,:) = rsbc_tke2 * ustars2(:,:)**1.5_wp * zkar(:,:) & 354 & * ((zhsro(:,:)+fsdept(:,:,1)) / zhsro(:,:) )**(1.5_wp*ra_sf) 355 356 en(:,:,2) = en(:,:,2) + zflxs(:,:)/fse3w(:,:,2) 357 ! 358 ! 379 359 END SELECT 380 360 … … 382 362 ! -------------------------------- 383 363 ! 384 SELECT CASE ( nn_ tkebc_bot )364 SELECT CASE ( nn_bc_bot ) 385 365 ! 386 366 CASE ( 0 ) ! Dirichlet … … 457 437 ! ! set the minimum value of tke 458 438 en(:,:,:) = MAX( en(:,:,:), rn_emin ) 459 439 460 440 !!----------------------------------------!! 461 441 !! Solve prognostic equation for psi !! … … 560 540 ! --------------------------------- 561 541 ! 562 SELECT CASE ( nn_ psibc_surf )542 SELECT CASE ( nn_bc_surf ) 563 543 ! 564 544 CASE ( 0 ) ! Dirichlet boundary conditions 565 ! 566 IF( ln_crban ) THEN ! Wave induced mixing case 567 ! ! en(1) = q2(1) = 0.5 * (15.8 * Ccb)^(2/3) * u*^2 568 ! ! balance between the production and the dissipation terms including the wave effect 569 zdep(:,:) = rl_sf * zhsro(:,:) 570 psi (:,:,1) = rc0**rpp * en(:,:,1)**rmm * zdep(:,:)**rnn * tmask(:,:,1) 571 z_elem_a(:,:,1) = psi(:,:,1) 572 z_elem_c(:,:,1) = 0._wp 573 z_elem_b(:,:,1) = 1._wp 574 ! 575 ! one level below 576 zex1 = (rmm*ra_sf+rnn) 577 zex2 = (rmm*ra_sf) 578 zdep(:,:) = ( (zhsro(:,:) + fsdepw(:,:,2))**zex1 ) / zhsro(:,:)**zex2 579 psi (:,:,2) = rsbc_psi1 * ustars2(:,:)**rmm * zdep(:,:) * tmask(:,:,1) 580 z_elem_a(:,:,2) = 0._wp 581 z_elem_c(:,:,2) = 0._wp 582 z_elem_b(:,:,2) = 1._wp 583 ! 584 ELSE ! No wave induced mixing case 585 ! ! en(1) = u*^2/C0^2 & l(1) = K*zs 586 ! ! balance between the production and the dissipation terms 587 ! 588 zdep(:,:) = vkarmn * zhsro(:,:) 589 psi (:,:,1) = rc0**rpp * en(:,:,1)**rmm * zdep(:,:)**rnn * tmask(:,:,1) 590 z_elem_a(:,:,1) = psi(:,:,1) 591 z_elem_c(:,:,1) = 0._wp 592 z_elem_b(:,:,1) = 1._wp 593 ! 594 ! one level below 595 zdep(:,:) = vkarmn * ( zhsro(:,:) + fsdepw(:,:,2) ) 596 psi (:,:,2) = rc0**rpp * en(:,:,1)**rmm * zdep(:,:)**rnn * tmask(:,:,1) 597 z_elem_a(:,:,2) = 0._wp 598 z_elem_c(:,:,2) = 0._wp 599 z_elem_b(:,:,2) = 1. 600 ! 601 ENDIF 602 ! 545 ! 546 ! Surface value 547 zdep(:,:) = zhsro(:,:) * rl_sf ! Cosmetic 548 psi (:,:,1) = rc0**rpp * en(:,:,1)**rmm * zdep(:,:)**rnn * tmask(:,:,1) 549 z_elem_a(:,:,1) = psi(:,:,1) 550 z_elem_c(:,:,1) = 0._wp 551 z_elem_b(:,:,1) = 1._wp 552 ! 553 ! One level below 554 zkar(:,:) = (rl_sf + (vkarmn-rl_sf)*(1._wp-exp(-rtrans*fsdepw(:,:,2)/zhsro(:,:) ))) 555 zdep(:,:) = (zhsro(:,:) + fsdepw(:,:,2)) * zkar(:,:) 556 psi (:,:,2) = rc0**rpp * en(:,:,2)**rmm * zdep(:,:)**rnn * tmask(:,:,1) 557 z_elem_a(:,:,2) = 0._wp 558 z_elem_c(:,:,2) = 0._wp 559 z_elem_b(:,:,2) = 1._wp 560 ! 561 ! 603 562 CASE ( 1 ) ! Neumann boundary condition on d(psi)/dz 604 ! 605 IF( ln_crban ) THEN ! Wave induced mixing case 606 ! 607 zdep(:,:) = rl_sf * zhsro(:,:) 608 psi (:,:,1) = rc0**rpp * en(:,:,1)**rmm * zdep(:,:)**rnn * tmask(:,:,1) 609 z_elem_a(:,:,1) = psi(:,:,1) 610 z_elem_c(:,:,1) = 0._wp 611 z_elem_b(:,:,1) = 1._wp 612 ! 613 ! Neumann condition at k=2 614 z_elem_b(:,:,2) = z_elem_b(:,:,2) + z_elem_a(:,:,2) ! Remove z_elem_a from z_elem_b 615 z_elem_a(:,:,2) = 0._wp 616 ! 617 ! Set psi vertical flux at the surface: 618 zdep(:,:) = (zhsro(:,:) + fsdept(:,:,1))**(rmm*ra_sf+rnn-1._wp) / zhsro(:,:)**(rmm*ra_sf) 619 zflxs(:,:) = rsbc_psi3 * ( zwall_psi(:,:,1)*avm(:,:,1) + zwall_psi(:,:,2)*avm(:,:,2) ) & 620 & * en(:,:,1)**rmm * zdep 621 psi(:,:,2) = psi(:,:,2) + zflxs(:,:) / fse3w(:,:,2) 622 ! 623 ELSE ! No wave induced mixing 624 ! 625 zdep(:,:) = vkarmn * zhsro(:,:) 626 psi (:,:,1) = rc0**rpp * en(:,:,1)**rmm * zdep(:,:)**rnn * tmask(:,:,1) 627 z_elem_a(:,:,1) = psi(:,:,1) 628 z_elem_c(:,:,1) = 0._wp 629 z_elem_b(:,:,1) = 1._wp 630 ! 631 ! Neumann condition at k=2 632 z_elem_b(:,:,2) = z_elem_b(:,:,2) + z_elem_a(:,:,2) ! Remove z_elem_a from z_elem_b 633 z_elem_a(ji,jj,2) = 0._wp 634 ! 635 ! Set psi vertical flux at the surface: 636 zdep(:,:) = zhsro(:,:) + fsdept(:,:,1) 637 zflxs(:,:) = rsbc_psi2 * ( avm(:,:,1) + avm(:,:,2) ) * en(:,:,1)**rmm * zdep**(rnn-1._wp) 638 psi(:,:,2) = psi(:,:,2) + zflxs(:,:) / fse3w(:,:,2) 639 ! 640 ENDIF 641 ! 563 ! 564 ! Surface value: Dirichlet 565 zdep(:,:) = zhsro(:,:) * rl_sf 566 psi (:,:,1) = rc0**rpp * en(:,:,1)**rmm * zdep(:,:)**rnn * tmask(:,:,1) 567 z_elem_a(:,:,1) = psi(:,:,1) 568 z_elem_c(:,:,1) = 0._wp 569 z_elem_b(:,:,1) = 1._wp 570 ! 571 ! Neumann condition at k=2 572 z_elem_b(:,:,2) = z_elem_b(:,:,2) + z_elem_a(:,:,2) ! Remove z_elem_a from z_elem_b 573 z_elem_a(:,:,2) = 0._wp 574 ! 575 ! Set psi vertical flux at the surface: 576 zkar(:,:) = rl_sf + (vkarmn-rl_sf)*(1._wp-exp(-rtrans*fsdept(:,:,1)/zhsro(:,:) )) ! Lengh scale slope 577 zdep(:,:) = ((zhsro(:,:) + fsdept(:,:,1)) / zhsro(:,:))**(rmm*ra_sf) 578 zflxs(:,:) = (rnn + rsbc_tke1 * (rnn + rmm*ra_sf) * zdep(:,:))*(1._wp + rsbc_tke1*zdep(:,:))**(2._wp*rmm/3._wp-1_wp) 579 zdep(:,:) = rsbc_psi1 * (zwall_psi(:,:,1)*avm(:,:,1)+zwall_psi(:,:,2)*avm(:,:,2)) * & 580 & ustars2(:,:)**rmm * zkar(:,:)**rnn * (zhsro(:,:) + fsdept(:,:,1))**(rnn-1.) 581 zflxs(:,:) = zdep(:,:) * zflxs(:,:) 582 psi(:,:,2) = psi(:,:,2) + zflxs(:,:) / fse3w(:,:,2) 583 584 ! 585 ! 642 586 END SELECT 643 587 … … 645 589 ! -------------------------------- 646 590 ! 647 SELECT CASE ( nn_psibc_bot ) 591 SELECT CASE ( nn_bc_bot ) 592 ! 648 593 ! 649 594 CASE ( 0 ) ! Dirichlet 650 ! ! en(ibot) = u*^2 / Co2 and mxln(ibot) = vkarmn * hbro595 ! ! en(ibot) = u*^2 / Co2 and mxln(ibot) = vkarmn * rn_bfrz0 651 596 ! ! Balance between the production and the dissipation terms 652 597 !CDIR NOVERRCHK … … 656 601 ibot = mbkt(ji,jj) + 1 ! k bottom level of w-point 657 602 ibotm1 = mbkt(ji,jj) ! k-1 bottom level of w-point but >=1 658 zdep(ji,jj) = vkarmn * hbro603 zdep(ji,jj) = vkarmn * rn_bfrz0 659 604 psi (ji,jj,ibot) = rc0**rpp * en(ji,jj,ibot)**rmm * zdep(ji,jj)**rnn 660 605 z_elem_a(ji,jj,ibot) = 0._wp … … 663 608 ! 664 609 ! Just above last level, Dirichlet condition again (GOTM like) 665 zdep(ji,jj) = vkarmn * ( hbro+ fse3t(ji,jj,ibotm1) )610 zdep(ji,jj) = vkarmn * ( rn_bfrz0 + fse3t(ji,jj,ibotm1) ) 666 611 psi (ji,jj,ibotm1) = rc0**rpp * en(ji,jj,ibot )**rmm * zdep(ji,jj)**rnn 667 612 z_elem_a(ji,jj,ibotm1) = 0._wp … … 681 626 ! 682 627 ! Bottom level Dirichlet condition: 683 zdep(ji,jj) = vkarmn * hbro628 zdep(ji,jj) = vkarmn * rn_bfrz0 684 629 psi (ji,jj,ibot) = rc0**rpp * en(ji,jj,ibot)**rmm * zdep(ji,jj)**rnn 685 630 ! … … 693 638 ! 694 639 ! Set psi vertical flux at the bottom: 695 zdep(ji,jj) = hbro+ 0.5_wp*fse3t(ji,jj,ibotm1)640 zdep(ji,jj) = rn_bfrz0 + 0.5_wp*fse3t(ji,jj,ibotm1) 696 641 zflxb = rsbc_psi2 * ( avm(ji,jj,ibot) + avm(ji,jj,ibotm1) ) & 697 642 & * (0.5_wp*(en(ji,jj,ibot)+en(ji,jj,ibotm1)))**rmm * zdep(ji,jj)**(rnn-1._wp) … … 736 681 DO jj = 2, jpjm1 737 682 DO ji = fs_2, fs_jpim1 ! vector opt. 738 eps(ji,jj,jk) = rc03 * en(ji,jj,jk) * en(ji,jj,jk) * SQRT( en(ji,jj,jk) ) / psi(ji,jj,jk)683 eps(ji,jj,jk) = rc03 * en(ji,jj,jk) * en(ji,jj,jk) * SQRT( en(ji,jj,jk) ) / MAX( psi(ji,jj,jk), rn_epsmin) 739 684 END DO 740 685 END DO … … 783 728 ! Galperin criterium (NOTE : Not required if the proper value of C3 in stable cases is calculated) 784 729 zrn2 = MAX( rn2(ji,jj,jk), rsmall ) 785 mxln(ji,jj,jk) = MIN( rn_clim_galp * SQRT( 2._wp * en(ji,jj,jk) / zrn2 ), mxln(ji,jj,jk))730 IF (ln_length_lim) mxln(ji,jj,jk) = MIN( rn_clim_galp * SQRT( 2._wp * en(ji,jj,jk) / zrn2 ), mxln(ji,jj,jk) ) 786 731 END DO 787 732 END DO … … 847 792 ! Boundary conditions on stability functions for momentum (Neumann): 848 793 ! Lines below are useless if GOTM style Dirichlet conditions are used 849 zcoef = rcm_sf / SQRT( 2._wp ) 794 795 avmv(:,:,1) = avmv(:,:,2) 796 850 797 DO jj = 2, jpjm1 851 798 DO ji = fs_2, fs_jpim1 ! vector opt. 852 avmv(ji,jj,1) = zcoef 853 END DO 854 END DO 855 zcoef = rc0 / SQRT( 2._wp ) 856 DO jj = 2, jpjm1 857 DO ji = fs_2, fs_jpim1 ! vector opt. 858 avmv(ji,jj,mbkt(ji,jj)+1) = zcoef 799 avmv(ji,jj,mbkt(ji,jj)+1) = avmv(ji,jj,mbkt(ji,jj)) 859 800 END DO 860 801 END DO … … 900 841 avmv_k(:,:,:) = avmv(:,:,:) 901 842 ! 902 CALL wrk_dealloc( jpi,jpj, zdep, z flxs, zhsro )843 CALL wrk_dealloc( jpi,jpj, zdep, zkar, zflxs, zhsro ) 903 844 CALL wrk_dealloc( jpi,jpj,jpk, eb, mxlb, shear, eps, zwall_psi, z_elem_a, z_elem_b, z_elem_c, psi ) 904 845 ! … … 932 873 !! 933 874 NAMELIST/namzdf_gls/rn_emin, rn_epsmin, ln_length_lim, & 934 & rn_clim_galp, ln_crban, ln_sigpsi, & 935 & rn_crban, rn_charn, & 936 & nn_tkebc_surf, nn_tkebc_bot, & 937 & nn_psibc_surf, nn_psibc_bot, & 875 & rn_clim_galp, ln_sigpsi, rn_hsro, & 876 & rn_crban, rn_charn, rn_frac_hs, & 877 & nn_bc_surf, nn_bc_bot, nn_z0_met, & 938 878 & nn_stab_func, nn_clos 939 879 !!---------------------------------------------------------- … … 955 895 WRITE(numout,*) '~~~~~~~~~~~~' 956 896 WRITE(numout,*) ' Namelist namzdf_gls : set gls mixing parameters' 957 WRITE(numout,*) ' minimum value of en rn_emin = ', rn_emin 958 WRITE(numout,*) ' minimum value of eps rn_epsmin = ', rn_epsmin 959 WRITE(numout,*) ' Limit dissipation rate under stable stratif. ln_length_lim = ', ln_length_lim 960 WRITE(numout,*) ' Galperin limit (Standard: 0.53, Holt: 0.26) rn_clim_galp = ', rn_clim_galp 961 WRITE(numout,*) ' TKE Surface boundary condition nn_tkebc_surf = ', nn_tkebc_surf 962 WRITE(numout,*) ' TKE Bottom boundary condition nn_tkebc_bot = ', nn_tkebc_bot 963 WRITE(numout,*) ' PSI Surface boundary condition nn_psibc_surf = ', nn_psibc_surf 964 WRITE(numout,*) ' PSI Bottom boundary condition nn_psibc_bot = ', nn_psibc_bot 965 WRITE(numout,*) ' Craig and Banner scheme ln_crban = ', ln_crban 966 WRITE(numout,*) ' Modify psi Schmidt number (wb case) ln_sigpsi = ', ln_sigpsi 897 WRITE(numout,*) ' minimum value of en rn_emin = ', rn_emin 898 WRITE(numout,*) ' minimum value of eps rn_epsmin = ', rn_epsmin 899 WRITE(numout,*) ' Limit dissipation rate under stable stratif. ln_length_lim = ', ln_length_lim 900 WRITE(numout,*) ' Galperin limit (Standard: 0.53, Holt: 0.26) rn_clim_galp = ', rn_clim_galp 901 WRITE(numout,*) ' TKE Surface boundary condition nn_bc_surf = ', nn_bc_surf 902 WRITE(numout,*) ' TKE Bottom boundary condition nn_bc_bot = ', nn_bc_bot 903 WRITE(numout,*) ' Modify psi Schmidt number (wb case) ln_sigpsi = ', ln_sigpsi 967 904 WRITE(numout,*) ' Craig and Banner coefficient rn_crban = ', rn_crban 968 905 WRITE(numout,*) ' Charnock coefficient rn_charn = ', rn_charn 906 WRITE(numout,*) ' Surface roughness formula nn_z0_met = ', nn_z0_met 907 WRITE(numout,*) ' Wave height frac. (used if nn_z0_met=2) rn_frac_hs = ', rn_frac_hs 969 908 WRITE(numout,*) ' Stability functions nn_stab_func = ', nn_stab_func 970 909 WRITE(numout,*) ' Type of closure nn_clos = ', nn_clos 971 WRITE(numout,*) ' Hard coded parameters' 972 WRITE(numout,*) ' Surface roughness (m) hsro = ', hsro 973 WRITE(numout,*) ' Bottom roughness (m) hbro = ', hbro 910 WRITE(numout,*) ' Surface roughness (m) rn_hsro = ', rn_hsro 911 WRITE(numout,*) ' Bottom roughness (m) (nambfr namelist) rn_bfrz0 = ', rn_bfrz0 974 912 ENDIF 975 913 … … 978 916 979 917 ! !* Check of some namelist values 980 IF( nn_tkebc_surf < 0 .OR. nn_tkebc_surf > 1 ) CALL ctl_stop( 'bad flag: nn_tkebc_surf is 0 or 1' ) 981 IF( nn_psibc_surf < 0 .OR. nn_psibc_surf > 1 ) CALL ctl_stop( 'bad flag: nn_psibc_surf is 0 or 1' ) 982 IF( nn_tkebc_bot < 0 .OR. nn_tkebc_bot > 1 ) CALL ctl_stop( 'bad flag: nn_tkebc_bot is 0 or 1' ) 983 IF( nn_psibc_bot < 0 .OR. nn_psibc_bot > 1 ) CALL ctl_stop( 'bad flag: nn_psibc_bot is 0 or 1' ) 918 IF( nn_bc_surf < 0 .OR. nn_bc_surf > 1 ) CALL ctl_stop( 'bad flag: nn_bc_surf is 0 or 1' ) 919 IF( nn_bc_surf < 0 .OR. nn_bc_surf > 1 ) CALL ctl_stop( 'bad flag: nn_bc_surf is 0 or 1' ) 920 IF( nn_z0_met < 0 .OR. nn_z0_met > 2 ) CALL ctl_stop( 'bad flag: nn_z0_met is 0, 1 or 2' ) 984 921 IF( nn_stab_func < 0 .OR. nn_stab_func > 3 ) CALL ctl_stop( 'bad flag: nn_stab_func is 0, 1, 2 and 3' ) 985 922 IF( nn_clos < 0 .OR. nn_clos > 3 ) CALL ctl_stop( 'bad flag: nn_clos is 0, 1, 2 or 3' ) … … 1001 938 SELECT CASE ( nn_stab_func ) 1002 939 CASE( 0, 1 ) ; rpsi3m = 2.53_wp ! G88 or KC stability functions 1003 CASE( 2 ) ; rpsi3m = 2. 38_wp ! Canuto A stability functions940 CASE( 2 ) ; rpsi3m = 2.62_wp ! Canuto A stability functions 1004 941 CASE( 3 ) ; rpsi3m = 2.38 ! Canuto B stability functions (caution : constant not identified) 1005 942 END SELECT … … 1012 949 rnn = -1._wp 1013 950 rsc_tke = 1._wp 1014 rsc_psi = 1. 3_wp ! Schmidt number for psi951 rsc_psi = 1.2_wp ! Schmidt number for psi 1015 952 rpsi1 = 1.44_wp 1016 953 rpsi3p = 1._wp … … 1140 1077 ! ! See Eq. (13) of Carniel et al, OM, 30, 225-239, 2009 1141 1078 ! ! or Eq. (17) of Burchard, JPO, 31, 3133-3145, 2001 1142 IF( ln_sigpsi .AND. ln_crban ) THEN 1143 zcr = SQRT( 1.5_wp*rsc_tke ) * rcm_sf / vkarmn 1144 rsc_psi0 = vkarmn*vkarmn / ( rpsi2 * rcm_sf*rcm_sf ) & 1145 & * ( rnn*rnn - 4._wp/3._wp * zcr*rnn*rmm - 1._wp/3._wp * zcr*rnn & 1146 & + 2._wp/9._wp * rmm * zcr*zcr + 4._wp/9._wp * zcr*zcr * rmm*rmm ) 1079 IF( ln_sigpsi ) THEN 1080 ra_sf = -1.5 ! Set kinetic energy slope, then deduce rsc_psi and rl_sf 1081 ! Verification: retrieve Burchard (2001) results by uncomenting the line below: 1082 ! Note that the results depend on the value of rn_cm_sf which is constant (=rc0) in his work 1083 ! ra_sf = -SQRT(2./3.*rc0**3./rn_cm_sf*rn_sc_tke)/vkarmn 1084 rsc_psi0 = rsc_tke/(24.*rpsi2)*(-1.+(4.*rnn + ra_sf*(1.+4.*rmm))**2./(ra_sf**2.)) 1147 1085 ELSE 1148 1086 rsc_psi0 = rsc_psi … … 1151 1089 ! !* Shear free turbulence parameters 1152 1090 ! 1153 ra_sf = -4._wp * rnn * SQRT( rsc_tke ) / ( (1._wp+4._wp*rmm) * SQRT( rsc_tke ) & 1154 & - SQRT(rsc_tke + 24._wp*rsc_psi0*rpsi2 ) ) 1155 rl_sf = rc0 * SQRT( rc0 / rcm_sf ) & 1156 & * SQRT( ( (1._wp + 4._wp*rmm + 8._wp*rmm*rmm) * rsc_tke & 1157 & + 12._wp * rsc_psi0 * rpsi2 & 1158 & - (1._wp + 4._wp*rmm) * SQRT( rsc_tke*(rsc_tke+ 24._wp*rsc_psi0*rpsi2) ) ) & 1159 & / ( 12._wp*rnn*rnn ) ) 1091 ra_sf = -4._wp*rnn*SQRT(rsc_tke) / ( (1._wp+4._wp*rmm)*SQRT(rsc_tke) & 1092 & - SQRT(rsc_tke + 24._wp*rsc_psi0*rpsi2 ) ) 1093 1094 IF ( rn_crban==0._wp ) THEN 1095 rl_sf = vkarmn 1096 ELSE 1097 rl_sf = rc0 * SQRT(rc0/rcm_sf) * SQRT( ( (1._wp + 4._wp*rmm + 8._wp*rmm**2_wp)*rsc_tke & 1098 & + 12._wp * rsc_psi0*rpsi2 - (1._wp + 4._wp*rmm) & 1099 & *SQRT(rsc_tke*(rsc_tke & 1100 & + 24._wp*rsc_psi0*rpsi2)) ) & 1101 & /(12._wp*rnn**2.) & 1102 & ) 1103 ENDIF 1160 1104 1161 1105 ! … … 1187 1131 rc03 = rc02 * rc0 1188 1132 rc04 = rc03 * rc0 1189 rc03_sqrt2_galp = rc03 / SQRT(2._wp) / rn_clim_galp 1190 rsbc_mb = 0.5_wp * (15.8_wp*rn_crban)**(2._wp/3._wp) ! Surf. bound. cond. from Mellor and Blumberg 1191 rsbc_std = 3.75_wp ! Surf. bound. cond. standard (prod=diss) 1192 rsbc_tke1 = (-rsc_tke*rn_crban/(rcm_sf*ra_sf*rl_sf))**(2._wp/3._wp) ! k_eps = 53. Dirichlet + Wave breaking 1193 rsbc_tke2 = 0.5_wp / rau0 1194 rsbc_tke3 = rdt * rn_crban ! Neumann + Wave breaking 1195 rsbc_zs = rn_charn / grav ! Charnock formula 1196 rsbc_psi1 = rc0**rpp * rsbc_tke1**rmm * rl_sf**rnn ! Dirichlet + Wave breaking 1197 rsbc_psi2 = -0.5_wp * rdt * rc0**rpp * rnn * vkarmn**rnn / rsc_psi ! Neumann + NO Wave breaking 1198 rsbc_psi3 = -0.5_wp * rdt * rc0**rpp * rl_sf**rnn / rsc_psi * (rnn + rmm*ra_sf) ! Neumann + Wave breaking 1199 rfact_tke = -0.5_wp / rsc_tke * rdt ! Cst used for the Diffusion term of tke 1200 rfact_psi = -0.5_wp / rsc_psi * rdt ! Cst used for the Diffusion term of tke 1133 rsbc_tke1 = -3._wp/2._wp*rn_crban*ra_sf*rl_sf ! Dirichlet + Wave breaking 1134 rsbc_tke2 = rdt * rn_crban / rl_sf ! Neumann + Wave breaking 1135 zcr = MAX(rsmall, rsbc_tke1**(1./(-ra_sf*3._wp/2._wp))-1._wp ) 1136 rtrans = 0.2_wp / zcr ! Ad. inverse transition length between log and wave layer 1137 rsbc_zs1 = rn_charn/grav ! Charnock formula for surface roughness 1138 rsbc_zs2 = rn_frac_hs / 0.85_wp / grav * 665._wp ! Rascle formula for surface roughness 1139 rsbc_psi1 = -0.5_wp * rdt * rc0**(rpp-2._wp*rmm) / rsc_psi 1140 rsbc_psi2 = -0.5_wp * rdt * rc0**rpp * rnn * vkarmn**rnn / rsc_psi ! Neumann + NO Wave breaking 1141 1142 rfact_tke = -0.5_wp / rsc_tke * rdt ! Cst used for the Diffusion term of tke 1143 rfact_psi = -0.5_wp / rsc_psi * rdt ! Cst used for the Diffusion term of tke 1201 1144 1202 1145 ! !* Wall proximity function … … 1257 1200 IF(lwp) WRITE(numout,*) ' ===>>>> : previous run without gls scheme, en and mxln computed by iterative loop' 1258 1201 en (:,:,:) = rn_emin 1259 mxln(:,:,:) = 0.0 011202 mxln(:,:,:) = 0.05 1260 1203 avt_k (:,:,:) = avt (:,:,:) 1261 1204 avm_k (:,:,:) = avm (:,:,:) … … 1267 1210 IF(lwp) WRITE(numout,*) ' ===>>>> : Initialisation of en and mxln by background values' 1268 1211 en (:,:,:) = rn_emin 1269 mxln(:,:,:) = 0.0 011212 mxln(:,:,:) = 0.05 1270 1213 ENDIF 1271 1214 ! … … 1273 1216 ! ! ------------------- 1274 1217 IF(lwp) WRITE(numout,*) '---- gls-rst ----' 1275 CALL iom_rstput( kt, nitrst, numrow, 'en' , en ) 1218 CALL iom_rstput( kt, nitrst, numrow, 'en' , en ) 1276 1219 CALL iom_rstput( kt, nitrst, numrow, 'avt' , avt_k ) 1277 1220 CALL iom_rstput( kt, nitrst, numrow, 'avm' , avm_k ) 1278 CALL iom_rstput( kt, nitrst, numrow, 'avmu' , avmu_k ) 1221 CALL iom_rstput( kt, nitrst, numrow, 'avmu' , avmu_k ) 1279 1222 CALL iom_rstput( kt, nitrst, numrow, 'avmv' , avmv_k ) 1280 1223 CALL iom_rstput( kt, nitrst, numrow, 'mxln' , mxln ) -
branches/2014/dev_r4621_NOC4_BDY_VERT_INTERP/NEMOGCM/NEMO/OPA_SRC/ZDF/zdfini.F90
r5038 r5620 14 14 !!---------------------------------------------------------------------- 15 15 USE par_oce ! mesh and scale factors 16 USE sbc_oce ! surface module (only for nn_isf in the option compatibility test)17 16 USE ldftra_oce ! ocean active tracers: lateral physics 18 17 USE ldfdyn_oce ! ocean dynamics lateral physics … … 118 117 IF( ioptio == 0 .OR. ioptio > 1 .AND. .NOT. lk_esopa ) & 119 118 & CALL ctl_stop( ' one and only one vertical diffusion option has to be defined ' ) 120 IF( ( lk_zdfric .OR. lk_zdfgls .OR. lk_zdfkpp ) .AND. nn_isf .NE. 0) &119 IF( ( lk_zdfric .OR. lk_zdfgls .OR. lk_zdfkpp ) .AND. ln_isfcav ) & 121 120 & CALL ctl_stop( ' only zdfcst and zdftke were tested with ice shelves cavities ' ) 122 121 ! … … 125 124 IF(lwp) WRITE(numout,*) ' convection :' 126 125 ! 127 IF( ln_zdfnpc ) CALL ctl_stop( ' zdf_init: non penetrative convective scheme is not working', & 128 & ' set ln_zdfnpc to FALSE' ) 126 #if defined key_top 127 IF( ln_zdfnpc ) CALL ctl_stop( ' zdf_init: npc scheme is not working with key_top' ) 128 #endif 129 129 ! 130 130 ioptio = 0 -
branches/2014/dev_r4621_NOC4_BDY_VERT_INTERP/NEMOGCM/NEMO/OPA_SRC/ZDF/zdftke.F90
r5038 r5620 26 26 !! ! + cleaning of the parameters + bugs correction 27 27 !! 3.3 ! 2010-10 (C. Ethe, G. Madec) reorganisation of initialisation phase 28 !! 3.6 ! 2014-11 (P. Mathiot) add ice shelf capability 28 29 !!---------------------------------------------------------------------- 29 30 #if defined key_zdftke || defined key_esopa … … 236 237 zfact3 = 0.5_wp * rn_ediss 237 238 ! 239 ! 238 240 ! !<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<< 239 241 ! ! Surface boundary condition on tke 240 242 ! !<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<< 243 IF ( ln_isfcav ) THEN 244 DO jj = 2, jpjm1 ! en(mikt(ji,jj)) = rn_emin 245 DO ji = fs_2, fs_jpim1 ! vector opt. 246 en(ji,jj,mikt(ji,jj))=rn_emin * tmask(ji,jj,1) 247 END DO 248 END DO 249 END IF 241 250 DO jj = 2, jpjm1 ! en(1) = rn_ebb taum / rau0 (min value rn_emin0) 242 251 DO ji = fs_2, fs_jpim1 ! vector opt. 243 IF (mikt(ji,jj) .GT. 1) THEN 244 en(ji,jj,mikt(ji,jj))=rn_emin 245 ELSE 246 en(ji,jj,1) = MAX( rn_emin0, zbbrau * taum(ji,jj) ) * tmask(ji,jj,1) 247 END IF 252 en(ji,jj,1) = MAX( rn_emin0, zbbrau * taum(ji,jj) ) * tmask(ji,jj,1) 248 253 END DO 249 254 END DO … … 301 306 END DO 302 307 zcof = 0.016 / SQRT( zrhoa * zcdrag ) 308 !CDIR NOVERRCHK 303 309 DO jk = 2, jpkm1 !* TKE Langmuir circulation source term added to en 304 DO jj = 2, jpjm1 310 !CDIR NOVERRCHK 311 DO jj = 2, jpjm1 312 !CDIR NOVERRCHK 305 313 DO ji = fs_2, fs_jpim1 ! vector opt. 306 314 zus = zcof * SQRT( taum(ji,jj) ) ! Stokes drift … … 309 317 zwlc = zind * rn_lc * zus * SIN( rpi * fsdepw(ji,jj,jk) / zhlc(ji,jj) ) 310 318 ! ! TKE Langmuir circulation source term 311 en(ji,jj,jk) = en(ji,jj,jk) + rdt * ( zwlc * zwlc * zwlc ) / zhlc(ji,jj) * tmask(ji,jj,jk)319 en(ji,jj,jk) = en(ji,jj,jk) + rdt * ( zwlc * zwlc * zwlc ) / zhlc(ji,jj) * wmask(ji,jj,jk) * tmask(ji,jj,1) 312 320 END DO 313 321 END DO … … 328 336 avmu(ji,jj,jk) = avmu(ji,jj,jk) * ( un(ji,jj,jk-1) - un(ji,jj,jk) ) & 329 337 & * ( ub(ji,jj,jk-1) - ub(ji,jj,jk) ) & 330 & / ( fse3uw_n(ji,jj,jk)&331 & * fse3uw_b(ji,jj,jk))338 & / ( fse3uw_n(ji,jj,jk) & 339 & * fse3uw_b(ji,jj,jk) ) 332 340 avmv(ji,jj,jk) = avmv(ji,jj,jk) * ( vn(ji,jj,jk-1) - vn(ji,jj,jk) ) & 333 341 & * ( vb(ji,jj,jk-1) - vb(ji,jj,jk) ) & … … 338 346 END DO 339 347 ! 340 DO j j = 2, jpjm1341 DO j i = fs_2, fs_jpim1 ! vector opt.342 DO j k = mikt(ji,jj)+1, jpkm1 !* Matrix and right hand side in en348 DO jk = 2, jpkm1 !* Matrix and right hand side in en 349 DO jj = 2, jpjm1 350 DO ji = fs_2, fs_jpim1 ! vector opt. 343 351 zcof = zfact1 * tmask(ji,jj,jk) 344 352 zzd_up = zcof * ( avm (ji,jj,jk+1) + avm (ji,jj,jk ) ) & ! upper diagonal … … 357 365 en(ji,jj,jk) = en(ji,jj,jk) + rdt * ( zesh2 - avt(ji,jj,jk) * rn2(ji,jj,jk) & 358 366 & + zfact3 * dissl(ji,jj,jk) * en (ji,jj,jk) ) & 359 & * tmask(ji,jj,jk) * tmask(ji,jj,jk-1) 360 END DO 361 ! !* Matrix inversion from level 2 (tke prescribed at level 1) 362 DO jk = mikt(ji,jj)+2, jpkm1 ! First recurrence : Dk = Dk - Lk * Uk-1 / Dk-1 367 & * wmask(ji,jj,jk) 368 END DO 369 END DO 370 END DO 371 ! !* Matrix inversion from level 2 (tke prescribed at level 1) 372 DO jk = 3, jpkm1 ! First recurrence : Dk = Dk - Lk * Uk-1 / Dk-1 373 DO jj = 2, jpjm1 374 DO ji = fs_2, fs_jpim1 ! vector opt. 363 375 zdiag(ji,jj,jk) = zdiag(ji,jj,jk) - zd_lw(ji,jj,jk) * zd_up(ji,jj,jk-1) / zdiag(ji,jj,jk-1) 364 376 END DO 365 ! Second recurrence : Lk = RHSk - Lk / Dk-1 * Lk-1 366 zd_lw(ji,jj,mikt(ji,jj)+1) = en(ji,jj,mikt(ji,jj)+1) - zd_lw(ji,jj,mikt(ji,jj)+1) * en(ji,jj,mikt(ji,jj)) ! Surface boudary conditions on tke 367 ! 368 DO jk = mikt(ji,jj)+2, jpkm1 377 END DO 378 END DO 379 ! 380 ! Second recurrence : Lk = RHSk - Lk / Dk-1 * Lk-1 381 DO jj = 2, jpjm1 382 DO ji = fs_2, fs_jpim1 ! vector opt. 383 zd_lw(ji,jj,2) = en(ji,jj,2) - zd_lw(ji,jj,2) * en(ji,jj,1) ! Surface boudary conditions on tke 384 END DO 385 END DO 386 DO jk = 3, jpkm1 387 DO jj = 2, jpjm1 388 DO ji = fs_2, fs_jpim1 ! vector opt. 369 389 zd_lw(ji,jj,jk) = en(ji,jj,jk) - zd_lw(ji,jj,jk) / zdiag(ji,jj,jk-1) *zd_lw(ji,jj,jk-1) 370 390 END DO 371 ! 372 ! thrid recurrence : Ek = ( Lk - Uk * Ek+1 ) / Dk 391 END DO 392 END DO 393 ! 394 ! thrid recurrence : Ek = ( Lk - Uk * Ek+1 ) / Dk 395 DO jj = 2, jpjm1 396 DO ji = fs_2, fs_jpim1 ! vector opt. 373 397 en(ji,jj,jpkm1) = zd_lw(ji,jj,jpkm1) / zdiag(ji,jj,jpkm1) 374 ! 375 DO jk = jpk-2, mikt(ji,jj)+1, -1 398 END DO 399 END DO 400 DO jk = jpk-2, 2, -1 401 DO jj = 2, jpjm1 402 DO ji = fs_2, fs_jpim1 ! vector opt. 376 403 en(ji,jj,jk) = ( zd_lw(ji,jj,jk) - zd_up(ji,jj,jk) * en(ji,jj,jk+1) ) / zdiag(ji,jj,jk) 377 404 END DO 378 ! 379 DO jk = mikt(ji,jj), jpkm1 ! set the minimum value of tke 380 en(ji,jj,jk) = MAX( en(ji,jj,jk), rn_emin ) * tmask(ji,jj,jk) 405 END DO 406 END DO 407 DO jk = 2, jpkm1 ! set the minimum value of tke 408 DO jj = 2, jpjm1 409 DO ji = fs_2, fs_jpim1 ! vector opt. 410 en(ji,jj,jk) = MAX( en(ji,jj,jk), rn_emin ) * wmask(ji,jj,jk) 381 411 END DO 382 412 END DO … … 391 421 DO ji = fs_2, fs_jpim1 ! vector opt. 392 422 en(ji,jj,jk) = en(ji,jj,jk) + rn_efr * en(ji,jj,1) * EXP( -fsdepw(ji,jj,jk) / htau(ji,jj) ) & 393 & * ( 1._wp - fr_i(ji,jj) ) * tmask(ji,jj,jk) * tmask(ji,jj,1)423 & * ( 1._wp - fr_i(ji,jj) ) * wmask(ji,jj,jk) * tmask(ji,jj,1) 394 424 END DO 395 425 END DO … … 400 430 jk = nmln(ji,jj) 401 431 en(ji,jj,jk) = en(ji,jj,jk) + rn_efr * en(ji,jj,1) * EXP( -fsdepw(ji,jj,jk) / htau(ji,jj) ) & 402 & * ( 1._wp - fr_i(ji,jj) ) * tmask(ji,jj,jk) * tmask(ji,jj,1)432 & * ( 1._wp - fr_i(ji,jj) ) * wmask(ji,jj,jk) * tmask(ji,jj,1) 403 433 END DO 404 434 END DO … … 416 446 zdif = rhftau_scl * MAX( 0._wp, zdif + rhftau_add ) ! apply some modifications... 417 447 en(ji,jj,jk) = en(ji,jj,jk) + zbbrau * zdif * EXP( -fsdepw(ji,jj,jk) / htau(ji,jj) ) & 418 & * ( 1._wp - fr_i(ji,jj) ) * tmask(ji,jj,jk) * tmask(ji,jj,jk-1) * tmask(ji,jj,1)448 & * ( 1._wp - fr_i(ji,jj) ) * wmask(ji,jj,jk) * tmask(ji,jj,1) 419 449 END DO 420 450 END DO … … 484 514 ! !* Buoyancy length scale: l=sqrt(2*e/n**2) 485 515 ! 516 ! initialisation of interior minimum value (avoid a 2d loop with mikt) 517 zmxlm(:,:,:) = rmxl_min 518 zmxld(:,:,:) = rmxl_min 519 ! 486 520 IF( ln_mxl0 ) THEN ! surface mixing length = F(stress) : l=vkarmn*2.e5*taum/(rau0*g) 487 521 DO jj = 2, jpjm1 488 522 DO ji = fs_2, fs_jpim1 489 IF (mikt(ji,jj) .GT. 1) THEN 490 zmxlm(ji,jj,mikt(ji,jj)) = rmxl_min 491 ELSE 492 zraug = vkarmn * 2.e5_wp / ( rau0 * grav ) 493 zmxlm(ji,jj,mikt(ji,jj)) = MAX( rn_mxl0, zraug * taum(ji,jj) ) 494 END IF 523 zraug = vkarmn * 2.e5_wp / ( rau0 * grav ) 524 zmxlm(ji,jj,1) = MAX( rn_mxl0, zraug * taum(ji,jj) * tmask(ji,jj,1) ) 495 525 END DO 496 526 END DO 497 527 ELSE 498 DO jj = 2, jpjm1 499 DO ji = fs_2, fs_jpim1 ! surface set to the minimum value 500 zmxlm(ji,jj,mikt(ji,jj)) = MAX( tmask(ji,jj,1) * rn_mxl0, rmxl_min) 501 END DO 502 END DO 528 zmxlm(:,:,1) = rn_mxl0 503 529 ENDIF 504 zmxlm(:,:,jpk) = rmxl_min ! last level set to the interior minium value 505 ! 506 !CDIR NOVERRCHK 507 DO jj = 2, jpjm1 508 !CDIR NOVERRCHK 509 DO ji = fs_2, fs_jpim1 ! vector opt. 510 !CDIR NOVERRCHK 511 DO jk = mikt(ji,jj)+1, jpkm1 ! interior value : l=sqrt(2*e/n^2) 530 ! 531 !CDIR NOVERRCHK 532 DO jk = 2, jpkm1 ! interior value : l=sqrt(2*e/n^2) 533 !CDIR NOVERRCHK 534 DO jj = 2, jpjm1 535 !CDIR NOVERRCHK 536 DO ji = fs_2, fs_jpim1 ! vector opt. 512 537 zrn2 = MAX( rn2(ji,jj,jk), rsmall ) 513 zmxlm(ji,jj,jk) = MAX( rmxl_min, SQRT( 2._wp * en(ji,jj,jk) / zrn2 ) ) 514 END DO 515 zmxld(ji,jj,mikt(ji,jj)) = zmxlm(ji,jj,mikt(ji,jj)) ! surface set to the minimum value 538 zmxlm(ji,jj,jk) = MAX( rmxl_min, SQRT( 2._wp * en(ji,jj,jk) / zrn2 ) ) 539 END DO 516 540 END DO 517 541 END DO … … 519 543 ! !* Physical limits for the mixing length 520 544 ! 521 zmxld(:,:, 1 ) = zmxlm(:,:,1) ! surface set to the zmxlm value545 zmxld(:,:,1 ) = zmxlm(:,:,1) ! surface set to the minimum value 522 546 zmxld(:,:,jpk) = rmxl_min ! last level set to the minimum value 523 547 ! 524 548 SELECT CASE ( nn_mxl ) 525 549 ! 550 ! where wmask = 0 set zmxlm == fse3w 526 551 CASE ( 0 ) ! bounded by the distance to surface and bottom 527 DO j j = 2, jpjm1528 DO j i = fs_2, fs_jpim1 ! vector opt.529 DO j k = mikt(ji,jj)+1, jpkm1552 DO jk = 2, jpkm1 553 DO jj = 2, jpjm1 554 DO ji = fs_2, fs_jpim1 ! vector opt. 530 555 zemxl = MIN( fsdepw(ji,jj,jk) - fsdepw(ji,jj,mikt(ji,jj)), zmxlm(ji,jj,jk), & 531 556 & fsdepw(ji,jj,mbkt(ji,jj)+1) - fsdepw(ji,jj,jk) ) 532 zmxlm(ji,jj,jk) = zemxl 533 zmxld(ji,jj,jk) = zemxl 557 ! wmask prevent zmxlm = 0 if jk = mikt(ji,jj) 558 zmxlm(ji,jj,jk) = zemxl * wmask(ji,jj,jk) + MIN(zmxlm(ji,jj,jk),fse3w(ji,jj,jk)) * (1 - wmask(ji,jj,jk)) 559 zmxld(ji,jj,jk) = zemxl * wmask(ji,jj,jk) + MIN(zmxlm(ji,jj,jk),fse3w(ji,jj,jk)) * (1 - wmask(ji,jj,jk)) 534 560 END DO 535 561 END DO … … 537 563 ! 538 564 CASE ( 1 ) ! bounded by the vertical scale factor 539 DO j j = 2, jpjm1540 DO j i = fs_2, fs_jpim1 ! vector opt.541 DO j k = mikt(ji,jj)+1, jpkm1565 DO jk = 2, jpkm1 566 DO jj = 2, jpjm1 567 DO ji = fs_2, fs_jpim1 ! vector opt. 542 568 zemxl = MIN( fse3w(ji,jj,jk), zmxlm(ji,jj,jk) ) 543 569 zmxlm(ji,jj,jk) = zemxl … … 548 574 ! 549 575 CASE ( 2 ) ! |dk[xml]| bounded by e3t : 550 DO j j = 2, jpjm1551 DO j i = fs_2, fs_jpim1 ! vector opt.552 DO j k = mikt(ji,jj)+1, jpkm1 ! from the surface to the bottom :576 DO jk = 2, jpkm1 ! from the surface to the bottom : 577 DO jj = 2, jpjm1 578 DO ji = fs_2, fs_jpim1 ! vector opt. 553 579 zmxlm(ji,jj,jk) = MIN( zmxlm(ji,jj,jk-1) + fse3t(ji,jj,jk-1), zmxlm(ji,jj,jk) ) 554 580 END DO 555 DO jk = jpkm1, mikt(ji,jj)+1, -1 ! from the bottom to the surface : 581 END DO 582 END DO 583 DO jk = jpkm1, 2, -1 ! from the bottom to the surface : 584 DO jj = 2, jpjm1 585 DO ji = fs_2, fs_jpim1 ! vector opt. 556 586 zemxl = MIN( zmxlm(ji,jj,jk+1) + fse3t(ji,jj,jk+1), zmxlm(ji,jj,jk) ) 557 587 zmxlm(ji,jj,jk) = zemxl … … 562 592 ! 563 593 CASE ( 3 ) ! lup and ldown, |dk[xml]| bounded by e3t : 564 DO j j = 2, jpjm1565 DO j i = fs_2, fs_jpim1 ! vector opt.566 DO j k = mikt(ji,jj)+1, jpkm1 ! from the surface to the bottom : lup594 DO jk = 2, jpkm1 ! from the surface to the bottom : lup 595 DO jj = 2, jpjm1 596 DO ji = fs_2, fs_jpim1 ! vector opt. 567 597 zmxld(ji,jj,jk) = MIN( zmxld(ji,jj,jk-1) + fse3t(ji,jj,jk-1), zmxlm(ji,jj,jk) ) 568 598 END DO 569 DO jk = jpkm1, mikt(ji,jj)+1, -1 ! from the bottom to the surface : ldown 599 END DO 600 END DO 601 DO jk = jpkm1, 2, -1 ! from the bottom to the surface : ldown 602 DO jj = 2, jpjm1 603 DO ji = fs_2, fs_jpim1 ! vector opt. 570 604 zmxlm(ji,jj,jk) = MIN( zmxlm(ji,jj,jk+1) + fse3t(ji,jj,jk+1), zmxlm(ji,jj,jk) ) 571 605 END DO … … 604 638 zsqen = SQRT( en(ji,jj,jk) ) 605 639 zav = rn_ediff * zmxlm(ji,jj,jk) * zsqen 606 avm (ji,jj,jk) = MAX( zav, avmb(jk) ) * tmask(ji,jj,jk)607 avt (ji,jj,jk) = MAX( zav, avtb_2d(ji,jj) * avtb(jk) ) * tmask(ji,jj,jk)640 avm (ji,jj,jk) = MAX( zav, avmb(jk) ) * wmask(ji,jj,jk) 641 avt (ji,jj,jk) = MAX( zav, avtb_2d(ji,jj) * avtb(jk) ) * wmask(ji,jj,jk) 608 642 dissl(ji,jj,jk) = zsqen / zmxld(ji,jj,jk) 609 643 END DO … … 612 646 CALL lbc_lnk( avm, 'W', 1. ) ! Lateral boundary conditions (sign unchanged) 613 647 ! 614 DO jj = 2, jpjm1 615 DO ji = fs_2, fs_jpim1 ! vector opt. 616 DO jk = miku(ji,jj)+1, jpkm1 !* vertical eddy viscosity at u- and v-points 617 avmu(ji,jj,jk) = 0.5 * ( avm(ji,jj,jk) + avm(ji+1,jj ,jk) ) * umask(ji,jj,jk) 618 END DO 619 DO jk = mikv(ji,jj)+1, jpkm1 620 avmv(ji,jj,jk) = 0.5 * ( avm(ji,jj,jk) + avm(ji ,jj+1,jk) ) * vmask(ji,jj,jk) 648 DO jk = 2, jpkm1 !* vertical eddy viscosity at wu- and wv-points 649 DO jj = 2, jpjm1 650 DO ji = fs_2, fs_jpim1 ! vector opt. 651 avmu(ji,jj,jk) = 0.5 * ( avm(ji,jj,jk) + avm(ji+1,jj ,jk) ) * wumask(ji,jj,jk) 652 avmv(ji,jj,jk) = 0.5 * ( avm(ji,jj,jk) + avm(ji ,jj+1,jk) ) * wvmask(ji,jj,jk) 621 653 END DO 622 654 END DO … … 625 657 ! 626 658 IF( nn_pdl == 1 ) THEN !* Prandtl number case: update avt 627 DO j j = 2, jpjm1628 DO j i = fs_2, fs_jpim1 ! vector opt.629 DO j k = mikt(ji,jj)+1, jpkm1659 DO jk = 2, jpkm1 660 DO jj = 2, jpjm1 661 DO ji = fs_2, fs_jpim1 ! vector opt. 630 662 zcoef = avm(ji,jj,jk) * 2._wp * fse3w(ji,jj,jk) * fse3w(ji,jj,jk) 631 663 ! ! shear … … 639 671 !!gm and even better with the use of the "true" ri_crit=0.22222... (this change the results!) 640 672 !!gm zpdlr = MAX( 0.1_wp, ri_crit / MAX( ri_crit , zri ) ) 641 avt(ji,jj,jk) = MAX( zpdlr * avt(ji,jj,jk), avtb_2d(ji,jj) * avtb(jk) ) * tmask(ji,jj,jk)673 avt(ji,jj,jk) = MAX( zpdlr * avt(ji,jj,jk), avtb_2d(ji,jj) * avtb(jk) ) * wmask(ji,jj,jk) 642 674 # if defined key_c1d 643 e_pdl(ji,jj,jk) = zpdlr * tmask(ji,jj,jk) ! c1d configuration : save masked Prandlt number644 e_ric(ji,jj,jk) = zri * tmask(ji,jj,jk) ! c1d config. : save Ri675 e_pdl(ji,jj,jk) = zpdlr * wmask(ji,jj,jk) ! c1d configuration : save masked Prandlt number 676 e_ric(ji,jj,jk) = zri * wmask(ji,jj,jk) ! c1d config. : save Ri 645 677 # endif 646 678 END DO … … 729 761 IF( nn_pdl < 0 .OR. nn_pdl > 1 ) CALL ctl_stop( 'bad flag: nn_pdl is 0 or 1 ' ) 730 762 IF( nn_htau < 0 .OR. nn_htau > 1 ) CALL ctl_stop( 'bad flag: nn_htau is 0, 1 or 2 ' ) 731 IF( nn_etau == 3 .AND. .NOT. l k_cpl ) CALL ctl_stop( 'nn_etau == 3 : HF taum only known in coupled mode' )763 IF( nn_etau == 3 .AND. .NOT. ln_cpl ) CALL ctl_stop( 'nn_etau == 3 : HF taum only known in coupled mode' ) 732 764 733 765 IF( ln_mxl0 ) THEN … … 749 781 ! !* set vertical eddy coef. to the background value 750 782 DO jk = 1, jpk 751 avt (:,:,jk) = avtb(jk) * tmask(:,:,jk)752 avm (:,:,jk) = avmb(jk) * tmask(:,:,jk)753 avmu(:,:,jk) = avmb(jk) * umask(:,:,jk)754 avmv(:,:,jk) = avmb(jk) * vmask(:,:,jk)783 avt (:,:,jk) = avtb(jk) * wmask (:,:,jk) 784 avm (:,:,jk) = avmb(jk) * wmask (:,:,jk) 785 avmu(:,:,jk) = avmb(jk) * wumask(:,:,jk) 786 avmv(:,:,jk) = avmb(jk) * wvmask(:,:,jk) 755 787 END DO 756 788 dissl(:,:,:) = 1.e-12_wp … … 803 835 en (:,:,:) = rn_emin * tmask(:,:,:) 804 836 CALL tke_avn ! recompute avt, avm, avmu, avmv and dissl (approximation) 837 ! 838 avt_k (:,:,:) = avt (:,:,:) 839 avm_k (:,:,:) = avm (:,:,:) 840 avmu_k(:,:,:) = avmu(:,:,:) 841 avmv_k(:,:,:) = avmv(:,:,:) 842 ! 805 843 DO jit = nit000 + 1, nit000 + 10 ; CALL zdf_tke( jit ) ; END DO 806 844 ENDIF … … 808 846 en(:,:,:) = rn_emin * tmask(:,:,:) 809 847 DO jk = 1, jpk ! set the Kz to the background value 810 avt (:,:,jk) = avtb(jk) * tmask(:,:,jk)811 avm (:,:,jk) = avmb(jk) * tmask(:,:,jk)812 avmu(:,:,jk) = avmb(jk) * umask(:,:,jk)813 avmv(:,:,jk) = avmb(jk) * vmask(:,:,jk)848 avt (:,:,jk) = avtb(jk) * wmask (:,:,jk) 849 avm (:,:,jk) = avmb(jk) * wmask (:,:,jk) 850 avmu(:,:,jk) = avmb(jk) * wumask(:,:,jk) 851 avmv(:,:,jk) = avmb(jk) * wvmask(:,:,jk) 814 852 END DO 815 853 ENDIF -
branches/2014/dev_r4621_NOC4_BDY_VERT_INTERP/NEMOGCM/NEMO/OPA_SRC/ZDF/zdftmx.F90
r5038 r5620 126 126 zkz(:,:) = 0.e0 !* Associated potential energy consummed over the whole water column 127 127 DO jk = 2, jpkm1 128 zkz(:,:) = zkz(:,:) + fse3w(:,:,jk) * MAX( 0.e0, rn2(:,:,jk) ) * rau0 * zav_tide(:,:,jk) * tmask(:,:,jk) * tmask(:,:,jk-1)128 zkz(:,:) = zkz(:,:) + fse3w(:,:,jk) * MAX( 0.e0, rn2(:,:,jk) ) * rau0 * zav_tide(:,:,jk) * wmask(:,:,jk) 129 129 END DO 130 130 … … 135 135 END DO 136 136 137 DO j j = 1, jpj !* Here zkz should be equal to en_tmx ==> multiply by en_tmx/zkz to recover en_tmx138 DO j i = 1, jpi139 DO j k = mikt(ji,jj)+1, jpkm1 !* Mutiply by zkz to recover en_tmx, BUT bound by 30/6 ==> zav_tide bound by 300 cm2/s140 zav_tide(ji,jj,jk) = zav_tide(ji,jj,jk) * MIN( zkz(ji,jj), 30./6. ) !kz max = 300 cm2/s137 DO jk = 2, jpkm1 !* Mutiply by zkz to recover en_tmx, BUT bound by 30/6 ==> zav_tide bound by 300 cm2/s 138 DO jj = 1, jpj !* Here zkz should be equal to en_tmx ==> multiply by en_tmx/zkz to recover en_tmx 139 DO ji = 1, jpi 140 zav_tide(ji,jj,jk) = zav_tide(ji,jj,jk) * MIN( zkz(ji,jj), 30./6. ) * wmask(ji,jj,jk) !kz max = 300 cm2/s 141 141 END DO 142 142 END DO … … 166 166 ! ! Update mixing coefs ! 167 167 ! ! ----------------------- ! 168 DO j j = 1, jpj !* Here zkz should be equal to en_tmx ==> multiply by en_tmx/zkz to recover en_tmx169 DO j i = 1, jpi170 DO j k = mikt(ji,jj)+1, jpkm1 !* update momentum & tracer diffusivity with tidal mixing171 avt(ji,jj,jk) = avt(ji,jj,jk) + zav_tide(ji,jj,jk) 172 avm(ji,jj,jk) = avm(ji,jj,jk) + zav_tide(ji,jj,jk) 168 DO jk = 2, jpkm1 !* update momentum & tracer diffusivity with tidal mixing 169 DO jj = 1, jpj !* Here zkz should be equal to en_tmx ==> multiply by en_tmx/zkz to recover en_tmx 170 DO ji = 1, jpi 171 avt(ji,jj,jk) = avt(ji,jj,jk) + zav_tide(ji,jj,jk) * wmask(ji,jj,jk) 172 avm(ji,jj,jk) = avm(ji,jj,jk) + zav_tide(ji,jj,jk) * wmask(ji,jj,jk) 173 173 END DO 174 174 END DO 175 175 END DO 176 176 177 DO j j = 2, jpjm1178 DO j i = fs_2, fs_jpim1 ! vector opt.179 DO j k = mikt(ji,jj)+1, jpkm1 !* update momentum & tracer diffusivity with tidal mixing180 avmu(ji,jj,jk) = avmu(ji,jj,jk) + 0.5 * ( zav_tide(ji,jj,jk) + zav_tide(ji+1,jj ,jk) ) * umask(ji,jj,jk)181 avmv(ji,jj,jk) = avmv(ji,jj,jk) + 0.5 * ( zav_tide(ji,jj,jk) + zav_tide(ji ,jj+1,jk) ) * vmask(ji,jj,jk)177 DO jk = 2, jpkm1 !* update momentum & tracer diffusivity with tidal mixing 178 DO jj = 2, jpjm1 179 DO ji = fs_2, fs_jpim1 ! vector opt. 180 avmu(ji,jj,jk) = avmu(ji,jj,jk) + 0.5 * ( zav_tide(ji,jj,jk) + zav_tide(ji+1,jj ,jk) ) * wumask(ji,jj,jk) 181 avmv(ji,jj,jk) = avmv(ji,jj,jk) + 0.5 * ( zav_tide(ji,jj,jk) + zav_tide(ji ,jj+1,jk) ) * wvmask(ji,jj,jk) 182 182 END DO 183 183 END DO … … 457 457 ztpc = 0.e0 458 458 zpc(:,:,:) = MAX(rn_n2min,rn2(:,:,:)) * zav_tide(:,:,:) 459 DO j j = 1, jpj460 DO j i = 1, jpi461 DO j k= mikt(ji,jj)+1, jpkm1462 ztpc = ztpc + fse3w(ji,jj,jk) * e1t(ji,jj) * e2t(ji,jj) * zpc(ji,jj,jk) * tmask(ji,jj,jk) * tmask_i(ji,jj)459 DO jk= 2, jpkm1 460 DO jj = 1, jpj 461 DO ji = 1, jpi 462 ztpc = ztpc + fse3w(ji,jj,jk) * e1t(ji,jj) * e2t(ji,jj) * zpc(ji,jj,jk) * wmask(ji,jj,jk) * tmask_i(ji,jj) 463 463 END DO 464 464 END DO … … 473 473 zav_tide(:,:,:) = MIN( zav_tide(:,:,:), 60.e-4 ) 474 474 zkz(:,:) = 0.e0 475 DO j j = 1, jpj476 DO j i = 1, jpi477 DO j k = mikt(ji,jj)+1, jpkm1478 zkz(ji,jj) = zkz(ji,jj) + fse3w(ji,jj,jk) * MAX( 0.e0, rn2(ji,jj,jk) ) * rau0 * zav_tide(ji,jj,jk)* tmask(ji,jj,jk)475 DO jk = 2, jpkm1 476 DO jj = 1, jpj 477 DO ji = 1, jpi 478 zkz(ji,jj) = zkz(ji,jj) + fse3w(ji,jj,jk) * MAX(0.e0, rn2(ji,jj,jk)) * rau0 * zav_tide(ji,jj,jk) * wmask(ji,jj,jk) 479 479 END DO 480 480 END DO … … 498 498 WRITE(numout,*) ' Min de zkz ', ztpc, ' Max = ', maxval(zkz(:,:) ) 499 499 500 DO j j = 1, jpj501 DO j i = 1, jpi502 DO j k = mikt(ji,jj)+1, jpkm1503 zav_tide(ji,jj,jk) = zav_tide(ji,jj,jk) * MIN( zkz(ji,jj), 30./6. ) !kz max = 300 cm2/s500 DO jk = 2, jpkm1 501 DO jj = 1, jpj 502 DO ji = 1, jpi 503 zav_tide(ji,jj,jk) = zav_tide(ji,jj,jk) * MIN( zkz(ji,jj), 30./6. ) * wmask(ji,jj,jk) !kz max = 300 cm2/s 504 504 END DO 505 505 END DO … … 510 510 DO jj = 1, jpj 511 511 DO ji = 1, jpi 512 ztpc = ztpc + fse3w(ji,jj,jk) * e1t(ji,jj) * e2t(ji,jj) * zpc(ji,jj,jk) * tmask(ji,jj,jk) * tmask_i(ji,jj)512 ztpc = ztpc + fse3w(ji,jj,jk) * e1t(ji,jj) * e2t(ji,jj) * zpc(ji,jj,jk) * wmask(ji,jj,jk) * tmask_i(ji,jj) 513 513 END DO 514 514 END DO … … 519 519 DO jk = 1, jpk 520 520 ze_z = SUM( e1t(:,:) * e2t(:,:) * zav_tide(:,:,jk) * tmask_i(:,:) ) & 521 & / MAX( 1.e-20, SUM( e1t(:,:) * e2t(:,:) * tmask (:,:,jk) * tmask_i(:,:) ) )521 & / MAX( 1.e-20, SUM( e1t(:,:) * e2t(:,:) * wmask (:,:,jk) * tmask_i(:,:) ) ) 522 522 ztpc = 1.E50 523 523 DO jj = 1, jpj … … 540 540 END DO 541 541 ze_z = SUM( e1t(:,:) * e2t(:,:) * zkz(:,:) * tmask_i(:,:) ) & 542 & / MAX( 1.e-20, SUM( e1t(:,:) * e2t(:,:) * tmask (:,:,jk) * tmask_i(:,:) ) )542 & / MAX( 1.e-20, SUM( e1t(:,:) * e2t(:,:) * wmask (:,:,jk) * tmask_i(:,:) ) ) 543 543 WRITE(numout,*) ' jk= ', jk,' ', ze_z * 1.e4,' cm2/s' 544 544 END DO … … 546 546 zkz(:,:) = az_tmx(:,:,jk) /rn_n2min 547 547 ze_z = SUM( e1t(:,:) * e2t(:,:) * zkz(:,:) * tmask_i(:,:) ) & 548 & / MAX( 1.e-20, SUM( e1t(:,:) * e2t(:,:) * tmask (:,:,jk) * tmask_i(:,:) ) )548 & / MAX( 1.e-20, SUM( e1t(:,:) * e2t(:,:) * wmask (:,:,jk) * tmask_i(:,:) ) ) 549 549 WRITE(numout,*) 550 550 WRITE(numout,*) ' N2 min - jk= ', jk,' ', ze_z * 1.e4,' cm2/s min= ',MINVAL(zkz)*1.e4, & -
branches/2014/dev_r4621_NOC4_BDY_VERT_INTERP/NEMOGCM/NEMO/OPA_SRC/nemogcm.F90
r5038 r5620 82 82 USE crsini ! initialise grid coarsening utility 83 83 USE lbcnfd, ONLY: isendto, nsndto, nfsloop, nfeloop ! Setup of north fold exchanges 84 USE sbc_oce, ONLY: lk_oasis 85 USE stopar 86 USE stopts 84 87 85 88 IMPLICIT NONE … … 184 187 ! 185 188 #if defined key_agrif 186 CALL Agrif_ParentGrid_To_ChildGrid() 187 IF( lk_diaobs ) CALL dia_obs_wri 188 IF( nn_timing == 1 ) CALL timing_finalize 189 CALL Agrif_ChildGrid_To_ParentGrid() 189 IF ( Agrif_Level() < Agrif_MaxLevel() ) THEN 190 CALL Agrif_ParentGrid_To_ChildGrid() 191 IF( lk_diaobs ) CALL dia_obs_wri 192 IF( nn_timing == 1 ) CALL timing_finalize 193 CALL Agrif_ChildGrid_To_ParentGrid() 194 ENDIF 190 195 #endif 191 196 IF( nn_timing == 1 ) CALL timing_finalize … … 195 200 #if defined key_iomput 196 201 CALL xios_finalize ! end mpp communications with xios 197 IF( lk_ cpl) CALL cpl_finalize ! end coupling and mpp communications with OASIS202 IF( lk_oasis ) CALL cpl_finalize ! end coupling and mpp communications with OASIS 198 203 #else 199 IF( lk_ cpl) THEN204 IF( lk_oasis ) THEN 200 205 CALL cpl_finalize ! end coupling and mpp communications with OASIS 201 206 ELSE … … 222 227 & nn_bench, nn_timing 223 228 NAMELIST/namcfg/ cp_cfg, cp_cfz, jp_cfg, jpidta, jpjdta, jpkdta, jpiglo, jpjglo, & 224 & jpizoom, jpjzoom, jperio 229 & jpizoom, jpjzoom, jperio, ln_use_jattr 225 230 !!---------------------------------------------------------------------- 226 231 ! 227 232 cltxt = '' 233 cxios_context = 'nemo' 228 234 ! 229 235 ! ! Open reference namelist and configuration namelist files … … 261 267 nperio = 0 262 268 jperio = 0 269 ln_use_jattr = .false. 263 270 ENDIF 264 271 #endif … … 271 278 #if defined key_iomput 272 279 IF( Agrif_Root() ) THEN 273 IF( lk_ cpl) THEN274 CALL cpl_init( ilocal_comm )! nemo local communicator given by oasis275 CALL xios_initialize( " oceanx",local_comm=ilocal_comm ) ! send nemo communicator to xios280 IF( lk_oasis ) THEN 281 CALL cpl_init( "oceanx", ilocal_comm ) ! nemo local communicator given by oasis 282 CALL xios_initialize( "not used",local_comm=ilocal_comm ) ! send nemo communicator to xios 276 283 ELSE 277 CALL xios_initialize( " nemo",return_comm=ilocal_comm ) ! nemo local communicator given by xios284 CALL xios_initialize( "for_xios_mpi_id",return_comm=ilocal_comm ) ! nemo local communicator given by xios 278 285 ENDIF 279 286 ENDIF 280 narea = mynode( cltxt, numnam_ref, numnam_cfg, numond , nstop, ilocal_comm ) ! Nodes selection 287 ! Nodes selection (control print return in cltxt) 288 narea = mynode( cltxt, 'output.namelist.dyn', numnam_ref, numnam_cfg, numond , nstop, ilocal_comm ) 281 289 #else 282 IF( lk_ cpl) THEN290 IF( lk_oasis ) THEN 283 291 IF( Agrif_Root() ) THEN 284 CALL cpl_init( ilocal_comm )! nemo local communicator given by oasis292 CALL cpl_init( "oceanx", ilocal_comm ) ! nemo local communicator given by oasis 285 293 ENDIF 286 narea = mynode( cltxt, numnam_ref, numnam_cfg, numond , nstop, ilocal_comm ) ! Nodes selection (control print return in cltxt) 294 ! Nodes selection (control print return in cltxt) 295 narea = mynode( cltxt, 'output.namelist.dyn', numnam_ref, numnam_cfg, numond , nstop, ilocal_comm ) 287 296 ELSE 288 297 ilocal_comm = 0 289 narea = mynode( cltxt, numnam_ref, numnam_cfg, numond , nstop ) ! Nodes selection (control print return in cltxt) 298 ! Nodes selection (control print return in cltxt) 299 narea = mynode( cltxt, 'output.namelist.dyn', numnam_ref, numnam_cfg, numond , nstop ) 290 300 ENDIF 291 301 #endif … … 341 351 WRITE(numout,*) ' NEMO team' 342 352 WRITE(numout,*) ' Ocean General Circulation Model' 343 WRITE(numout,*) ' version 3. 4 (2011) '353 WRITE(numout,*) ' version 3.6 (2015) ' 344 354 WRITE(numout,*) 345 355 WRITE(numout,*) … … 383 393 IF( lk_tide ) CALL tide_init( nit000 ) ! Initialisation of the tidal harmonics 384 394 395 CALL sbc_init ! Forcings : surface module (clem: moved here for bdy purpose) 396 385 397 IF( lk_bdy ) CALL bdy_init ! Open boundaries initialisation 386 398 IF( lk_bdy ) CALL bdy_dta_init ! Open boundaries initialisation of external data arrays … … 389 401 390 402 CALL dyn_nept_init ! simplified form of Neptune effect 391 392 403 ! 393 404 IF( ln_crs ) CALL crs_init ! Domain initialization of coarsened grid 394 405 ! 395 406 ! Ocean physics 396 CALL sbc_init ! Forcings : surface module397 407 ! ! Vertical physics 398 408 CALL zdf_init ! namelist read … … 431 441 IF( nn_cla == 1 .AND. cp_cfg == 'orca' .AND. jp_cfg == 2 ) CALL cla_init ! Cross Land Advection 432 442 CALL icb_init( rdt, nit000) ! initialise icebergs instance 443 CALL sto_par_init ! Stochastic parametrization 444 IF( ln_sto_eos ) CALL sto_pts_init ! RRandom T/S fluctuations 433 445 434 446 #if defined key_top … … 506 518 WRITE(numout,*) ' left bottom j index of the zoom (in data domain) jpizoom = ', jpjzoom 507 519 WRITE(numout,*) ' lateral cond. type (between 0 and 6) jperio = ', jperio 520 WRITE(numout,*) ' use file attribute if exists as i/p j-start ln_use_jattr = ', ln_use_jattr 508 521 ENDIF 509 522 ! ! Parameter control -
branches/2014/dev_r4621_NOC4_BDY_VERT_INTERP/NEMOGCM/NEMO/OPA_SRC/par_oce.F90
r5038 r5620 53 53 ! ! = 6 cyclic East-West AND North fold F-point pivot 54 54 55 ! Input file read offset 56 LOGICAL :: ln_use_jattr !: Use file global attribute: open_ocean_jstart to determine start j-row 57 ! when reading input from those netcdf files that have the 58 ! attribute defined. This is designed to enable input files associated 59 ! with the extended grids used in the under ice shelf configurations to 60 ! be used without redundant rows when the ice shelves are not in use. 61 55 62 !! Values set to pp_not_used indicates that this parameter is not used in THIS config. 56 63 !! Values set to pp_to_be_computed indicates that variables will be computed in domzgr -
branches/2014/dev_r4621_NOC4_BDY_VERT_INTERP/NEMOGCM/NEMO/OPA_SRC/step.F90
r5038 r5620 83 83 IF ( kstp == (nit000 + 1) ) lk_agrif_fstep = .FALSE. 84 84 # if defined key_iomput 85 IF( Agrif_Nbstepint() == 0 ) CALL iom_swap( "nemo")85 IF( Agrif_Nbstepint() == 0 ) CALL iom_swap( cxios_context ) 86 86 # endif 87 87 #endif 88 88 indic = 0 ! reset to no error condition 89 89 IF( kstp == nit000 ) THEN 90 CALL iom_init( "nemo" ) ! iom_put initialization (must be done after nemo_init for AGRIF+XIOS+OASIS) 91 IF( ln_crs ) CALL iom_init( "nemo_crs" ) ! initialize context for coarse grid 90 ! must be done after nemo_init for AGRIF+XIOS+OASIS 91 CALL iom_init( cxios_context ) ! iom_put initialization 92 IF( ln_crs ) CALL iom_init( TRIM(cxios_context)//"_crs" ) ! initialize context for coarse grid 92 93 ENDIF 93 94 94 95 IF( kstp /= nit000 ) CALL day( kstp ) ! Calendar (day was already called at nit000 in day_init) 95 CALL iom_setkt( kstp - nit000 + 1, "nemo" ) ! say to iom thatwe are at time step kstp96 IF( ln_crs ) CALL iom_setkt( kstp - nit000 + 1, "nemo_crs" ) ! say to iom thatwe are at time step kstp96 CALL iom_setkt( kstp - nit000 + 1, cxios_context ) ! tell iom we are at time step kstp 97 IF( ln_crs ) CALL iom_setkt( kstp - nit000 + 1, TRIM(cxios_context)//"_crs" ) ! tell iom we are at time step kstp 97 98 98 99 !>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>> … … 100 101 !<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<< 101 102 IF( lk_tide ) CALL sbc_tide( kstp ) 102 IF( lk_bdy ) CALL bdy_dta ( kstp, time_offset=+1 ) ! update dynamic & tracer data at open boundaries 103 103 IF( lk_bdy ) THEN 104 IF( ln_apr_dyn) CALL sbc_apr( kstp ) ! bdy_dta needs ssh_ib 105 CALL bdy_dta ( kstp, time_offset=+1 ) ! update dynamic & tracer data at open boundaries 106 ENDIF 104 107 CALL sbc ( kstp ) ! Sea Boundary Condition (including sea-ice) 105 108 ! clem: moved here for bdy ice purpose 109 !>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>> 110 ! Update stochastic parameters and random T/S fluctuations 111 !>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>> 112 CALL sto_par( kstp ) ! Stochastic parameters 106 113 107 114 !>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>> … … 122 129 IF( lk_zdfkpp ) CALL zdf_kpp( kstp ) ! KPP closure scheme for Kz 123 130 IF( lk_zdfcst ) THEN ! Constant Kz (reset avt, avm[uv] to the background value) 124 avt (:,:,:) = rn_avt0 * tmask(:,:,:)125 avmu(:,:,:) = rn_avm0 * umask(:,:,:)126 avmv(:,:,:) = rn_avm0 * vmask(:,:,:)131 avt (:,:,:) = rn_avt0 * wmask (:,:,:) 132 avmu(:,:,:) = rn_avm0 * wumask(:,:,:) 133 avmv(:,:,:) = rn_avm0 * wvmask(:,:,:) 127 134 ENDIF 128 135 IF( ln_rnf_mouth ) THEN ! increase diffusivity at rivers mouths … … 145 152 ! 146 153 IF( lk_ldfslp ) THEN ! slope of lateral mixing 147 CALL eos( tsb, rhd, gdept_0(:,:,:) ) ! before in situ density 148 IF( ln_zps ) CALL zps_hde( kstp, jpts, tsb, gtsu, gtsv, & ! Partial steps: before horizontal gradient 149 & rhd, gru , grv , aru , arv , gzu , gzv , ge3ru , ge3rv , & ! 150 & gtui, gtvi, grui, grvi, arui, arvi, gzui, gzvi, ge3rui, ge3rvi ) ! of t, s, rd at the last ocean level 154 IF(ln_sto_eos ) CALL sto_pts( tsn ) ! Random T/S fluctuations 155 CALL eos( tsb, rhd, gdept_0(:,:,:) ) ! before in situ density 156 IF( ln_zps .AND. .NOT. ln_isfcav) & 157 & CALL zps_hde ( kstp, jpts, tsb, gtsu, gtsv, & ! Partial steps: before horizontal gradient 158 & rhd, gru , grv ) ! of t, s, rd at the last ocean level 159 IF( ln_zps .AND. ln_isfcav) & 160 & CALL zps_hde_isf( kstp, jpts, tsb, gtsu, gtsv, & ! Partial steps for top cell (ISF) 161 & rhd, gru , grv , aru , arv , gzu , gzv , ge3ru , ge3rv , & 162 & gtui, gtvi, grui, grvi, arui, arvi, gzui, gzvi, ge3rui, ge3rvi ) ! of t, s, rd at the first ocean level 151 163 IF( ln_traldf_grif ) THEN ! before slope for Griffies operator 152 164 CALL ldf_slp_grif( kstp ) … … 158 170 IF( lk_traldf_eiv ) CALL ldf_eiv( kstp ) ! eddy induced velocity coefficient 159 171 #endif 160 #if defined key_traldf_c3d && key_traldf_smag172 #if defined key_traldf_c3d && defined key_traldf_smag 161 173 CALL ldf_tra_smag( kstp ) ! eddy induced velocity coefficient 162 174 # endif 163 #if defined key_dynldf_c3d && key_dynldf_smag175 #if defined key_dynldf_c3d && defined key_dynldf_smag 164 176 CALL ldf_dyn_smag( kstp ) ! eddy induced velocity coefficient 165 177 # endif … … 176 188 ! Note that the computation of vertical velocity above, hence "after" sea level 177 189 ! is necessary to compute momentum advection for the rhs of barotropic loop: 190 IF(ln_sto_eos ) CALL sto_pts( tsn ) ! Random T/S fluctuations 178 191 CALL eos ( tsn, rhd, rhop, fsdept_n(:,:,:) ) ! now in situ density for hpg computation 179 IF( ln_zps ) CALL zps_hde( kstp, jpts, tsn, gtsu, gtsv, & ! Partial steps: before horizontal gradient 180 & rhd, gru , grv , aru , arv , gzu , gzv , ge3ru , ge3rv , & ! 181 & gtui, gtvi, grui, grvi, arui, arvi, gzui, gzvi, ge3rui, ge3rvi ) ! of t, s, rd at the last ocean level 192 IF( ln_zps .AND. .NOT. ln_isfcav) & 193 & CALL zps_hde ( kstp, jpts, tsn, gtsu, gtsv, & ! Partial steps: before horizontal gradient 194 & rhd, gru , grv ) ! of t, s, rd at the last ocean level 195 IF( ln_zps .AND. ln_isfcav) & 196 & CALL zps_hde_isf( kstp, jpts, tsn, gtsu, gtsv, & ! Partial steps for top cell (ISF) 197 & rhd, gru , grv , aru , arv , gzu , gzv , ge3ru , ge3rv , & 198 & gtui, gtvi, grui, grvi, arui, arvi, gzui, gzvi, ge3rui, ge3rvi ) ! of t, s, rd at the last ocean level 182 199 183 200 ua(:,:,:) = 0.e0 ! set dynamics trends to zero … … 208 225 ! diagnostics and outputs (ua, va, tsa used as workspace) 209 226 !<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<< 210 IF( lk_floats ) CALL flo_stp( kstp ) ! drifting Floats 211 IF( lk_diahth ) CALL dia_hth( kstp ) ! Thermocline depth (20 degres isotherm depth) 212 IF( .NOT. lk_cpl ) CALL dia_fwb( kstp ) ! Fresh water budget diagnostics 213 IF( ln_diaptr ) CALL dia_ptr( kstp ) ! Poleward TRansports diagnostics 214 IF( lk_diadct ) CALL dia_dct( kstp ) ! Transports 215 IF( lk_diaar5 ) CALL dia_ar5( kstp ) ! ar5 diag 216 IF( lk_diaharm ) CALL dia_harm( kstp ) ! Tidal harmonic analysis 217 CALL dia_wri( kstp ) ! ocean model: outputs 218 ! 219 IF( ln_crs ) CALL crs_fld( kstp ) ! ocean model: online field coarsening & output 220 227 IF( lk_floats ) CALL flo_stp( kstp ) ! drifting Floats 228 IF( lk_diahth ) CALL dia_hth( kstp ) ! Thermocline depth (20 degres isotherm depth) 229 IF( .NOT. ln_cpl ) CALL dia_fwb( kstp ) ! Fresh water budget diagnostics 230 IF( lk_diadct ) CALL dia_dct( kstp ) ! Transports 231 IF( lk_diaar5 ) CALL dia_ar5( kstp ) ! ar5 diag 232 IF( lk_diaharm ) CALL dia_harm( kstp ) ! Tidal harmonic analysis 233 CALL dia_wri( kstp ) ! ocean model: outputs 234 ! 235 IF( ln_crs ) CALL crs_fld( kstp ) ! ocean model: online field coarsening & output 221 236 222 237 #if defined key_top … … 244 259 IF( lk_zdfkpp ) CALL tra_kpp ( kstp ) ! KPP non-local tracer fluxes 245 260 CALL tra_ldf ( kstp ) ! lateral mixing 261 262 IF( ln_diaptr ) CALL dia_ptr ! Poleward adv/ldf TRansports diagnostics 263 246 264 #if defined key_agrif 247 265 IF(.NOT. Agrif_Root()) CALL Agrif_Sponge_tra ! tracers sponge … … 252 270 IF( ln_zdfnpc ) CALL tra_npc( kstp ) ! update after fields by non-penetrative convection 253 271 CALL tra_nxt( kstp ) ! tracer fields at next time step 272 IF( ln_sto_eos ) CALL sto_pts( tsn ) ! Random T/S fluctuations 254 273 CALL eos ( tsa, rhd, rhop, fsdept_n(:,:,:) ) ! Time-filtered in situ density for hpg computation 255 IF( ln_zps ) CALL zps_hde( kstp, jpts, tsa, gtsu, gtsv, & ! Partial steps: before horizontal gradient 256 & rhd, gru , grv , aru , arv , gzu , gzv , ge3ru , ge3rv , & ! 257 & gtui, gtvi, grui, grvi, arui, arvi, gzui, gzvi, ge3rui, ge3rvi ) ! of t, s, rd at the last ocean level 274 IF( ln_zps .AND. .NOT. ln_isfcav) & 275 & CALL zps_hde ( kstp, jpts, tsa, gtsu, gtsv, & ! Partial steps: before horizontal gradient 276 & rhd, gru , grv ) ! of t, s, rd at the last ocean level 277 IF( ln_zps .AND. ln_isfcav) & 278 & CALL zps_hde_isf( kstp, jpts, tsa, gtsu, gtsv, & ! Partial steps for top cell (ISF) 279 & rhd, gru , grv , aru , arv , gzu , gzv , ge3ru , ge3rv , & 280 & gtui, gtvi, grui, grvi, arui, arvi, gzui, gzvi, ge3rui, ge3rvi ) ! of t, s, rd at the last ocean level 258 281 ELSE ! centered hpg (eos then time stepping) 259 282 IF ( .NOT. lk_dynspg_ts ) THEN ! eos already called in time-split case 283 IF( ln_sto_eos ) CALL sto_pts( tsn ) ! Random T/S fluctuations 260 284 CALL eos ( tsn, rhd, rhop, fsdept_n(:,:,:) ) ! now in situ density for hpg computation 261 IF( ln_zps ) CALL zps_hde( kstp, jpts, tsn, gtsu, gtsv, & ! Partial steps: before horizontal gradient 262 & rhd, gru , grv , aru , arv , gzu , gzv , ge3ru , ge3rv , & ! 263 & gtui, gtvi, grui, grvi, arui, arvi, gzui, gzvi, ge3rui, ge3rvi ) ! of t, s, rd at the last ocean level 285 IF( ln_zps .AND. .NOT. ln_isfcav) & 286 & CALL zps_hde ( kstp, jpts, tsn, gtsu, gtsv, & ! Partial steps: before horizontal gradient 287 & rhd, gru , grv ) ! of t, s, rd at the last ocean level 288 IF( ln_zps .AND. ln_isfcav) & 289 & CALL zps_hde_isf( kstp, jpts, tsn, gtsu, gtsv, & ! Partial steps for top cell (ISF) 290 & rhd, gru , grv , aru , arv , gzu , gzv , ge3ru , ge3rv , & 291 & gtui, gtvi, grui, grvi, arui, arvi, gzui, gzvi, ge3rui, ge3rvi ) ! of t, s, rd at the last ocean level 264 292 ENDIF 265 293 IF( ln_zdfnpc ) CALL tra_npc( kstp ) ! update after fields by non-penetrative convection … … 322 350 CALL iom_close( numror ) ! close input ocean restart file 323 351 IF(lwm) CALL FLUSH ( numond ) ! flush output namelist oce 324 IF( lwm.AND.numoni /= -1 ) CALL FLUSH ( numoni ) ! flush output namelist ice 352 IF( lwm.AND.numoni /= -1 ) CALL FLUSH ( numoni ) ! flush output namelist ice 325 353 ENDIF 326 354 IF( lrst_oce ) CALL rst_write ( kstp ) ! write output ocean restart file … … 329 357 ! Coupled mode 330 358 !<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<< 331 IF( lk_ cpl) CALL sbc_cpl_snd( kstp ) ! coupled mode : field exchanges359 IF( lk_oasis ) CALL sbc_cpl_snd( kstp ) ! coupled mode : field exchanges 332 360 ! 333 361 #if defined key_iomput 334 362 IF( kstp == nitend .OR. indic < 0 ) THEN 335 CALL iom_context_finalize( "nemo") ! needed for XIOS+AGRIF336 IF( ln_crs ) CALL iom_context_finalize( "nemo_crs" ) !363 CALL iom_context_finalize( cxios_context ) ! needed for XIOS+AGRIF 364 IF( ln_crs ) CALL iom_context_finalize( trim(cxios_context)//"_crs" ) ! 337 365 ENDIF 338 366 #endif -
branches/2014/dev_r4621_NOC4_BDY_VERT_INTERP/NEMOGCM/NEMO/OPA_SRC/step_oce.F90
r5038 r5620 27 27 USE sbc_oce ! surface boundary condition: ocean 28 28 USE sbctide ! Tide initialisation 29 USE sbcapr ! surface boundary condition: ssh_ib required by bdydta 29 30 30 31 USE traqsr ! solar radiation penetration (tra_qsr routine) … … 53 54 54 55 USE dynnxt ! time-stepping (dyn_nxt routine) 56 57 USE stopar ! Stochastic parametrization (sto_par routine) 58 USE stopts 55 59 56 60 USE bdy_par ! for lk_bdy -
branches/2014/dev_r4621_NOC4_BDY_VERT_INTERP/NEMOGCM/NEMO/OPA_SRC/timing.F90
r3610 r5620 211 211 WRITE(numtime,*) ' NEMO team' 212 212 WRITE(numtime,*) ' Ocean General Circulation Model' 213 WRITE(numtime,*) ' version 3. 3 (2010) '213 WRITE(numtime,*) ' version 3.6 (2015) ' 214 214 WRITE(numtime,*) 215 215 WRITE(numtime,*) ' Timing Informations ' -
branches/2014/dev_r4621_NOC4_BDY_VERT_INTERP/NEMOGCM/NEMO/OPA_SRC/trc_oce.F90
r4792 r5620 32 32 !! 'key_top' bio-model 33 33 !!---------------------------------------------------------------------- 34 LOGICAL, PUBLIC, PARAMETER :: lk_top = .TRUE. !: TOP model 34 35 LOGICAL, PUBLIC, PARAMETER :: lk_qsr_bio = .TRUE. !: bio-model light absorption flag 35 36 #else … … 37 38 !! Default option No bio-model light absorption 38 39 !!---------------------------------------------------------------------- 40 LOGICAL, PUBLIC, PARAMETER :: lk_top = .FALSE. !: TOP model 39 41 LOGICAL, PUBLIC, PARAMETER :: lk_qsr_bio = .FALSE. !: bio-model light absorption flag 40 42 #endif -
branches/2014/dev_r4621_NOC4_BDY_VERT_INTERP/NEMOGCM/NEMO/OPA_SRC/wrk_nemo.F90
- Property svn:keywords set to Id
r3294 r5620 121 121 122 122 LOGICAL :: linit = .FALSE. 123 LOGICAL :: ldebug = .FALSE. 123 124 !!---------------------------------------------------------------------- 124 125 !! NEMO/OPA 4.0 , NEMO Consortium (2011) 125 !! $Id :$126 !! $Id$ 126 127 !! Software governed by the CeCILL licence (NEMOGCM/NEMO_CeCILL.txt) 127 128 !!---------------------------------------------------------------------- … … 486 487 487 488 IF( SUM( tree(ii)%ishape ) == 0 ) THEN ! create a new branch 489 IF(ldebug) PRINT *, 'create new branch ', ii,ishape, isrt, itype 488 490 tree(ii)%itype = itype ! define the type of this branch 489 491 tree(ii)%ishape(:) = ishape(:) ! define the shape of this branch … … 515 517 tree(ii)%current%next%in_use = .FALSE. ! this leaf is not yet used 516 518 tree(ii)%current%next%indic = tree(ii)%current%indic + 1 ! number of this leaf 519 IF(ldebug) PRINT *, 'add a leaf ', ii, tree(ii)%current%indic 517 520 tree(ii)%current%next%prev => tree(ii)%current ! previous leaf of the new leaf is the current leaf 518 521 tree(ii)%current%next%next => NULL() ! next leaf is not yet defined
Note: See TracChangeset
for help on using the changeset viewer.