- Timestamp:
- 2020-12-02T14:55:21+01:00 (4 years ago)
- Location:
- NEMO/branches/2020/dev_r13327_KERNEL-06_2_techene_e3
- Files:
-
- 110 edited
Legend:
- Unmodified
- Added
- Removed
-
NEMO/branches/2020/dev_r13327_KERNEL-06_2_techene_e3
- Property svn:externals
-
old new 8 8 9 9 # SETTE 10 ^/utils/CI/sette@13 292sette10 ^/utils/CI/sette@13559 sette
-
- Property svn:externals
-
NEMO/branches/2020/dev_r13327_KERNEL-06_2_techene_e3/src/OCE/BDY/bdy_oce.F90
r12377 r13998 63 63 REAL(wp), POINTER, DIMENSION(:,:) :: aip !: now ice pond concentration 64 64 REAL(wp), POINTER, DIMENSION(:,:) :: hip !: now ice pond depth 65 REAL(wp), POINTER, DIMENSION(:,:) :: hil !: now ice pond lid depth 65 66 #if defined key_top 66 67 CHARACTER(LEN=20) :: cn_obc !: type of boundary condition to apply … … 115 116 REAL(wp), DIMENSION(jp_bdy) :: rice_apnd !: pond conc. of incoming sea ice 116 117 REAL(wp), DIMENSION(jp_bdy) :: rice_hpnd !: pond thick. of incoming sea ice 118 REAL(wp), DIMENSION(jp_bdy) :: rice_hlid !: pond lid thick. of incoming sea ice 117 119 ! 118 120 !!---------------------------------------------------------------------- -
NEMO/branches/2020/dev_r13327_KERNEL-06_2_techene_e3/src/OCE/BDY/bdydta.F90
r13237 r13998 43 43 PUBLIC bdy_dta_init ! routine called by nemogcm.F90 44 44 45 INTEGER , PARAMETER :: jpbdyfld = 1 6! maximum number of files to read45 INTEGER , PARAMETER :: jpbdyfld = 17 ! maximum number of files to read 46 46 INTEGER , PARAMETER :: jp_bdyssh = 1 ! 47 47 INTEGER , PARAMETER :: jp_bdyu2d = 2 ! … … 60 60 INTEGER , PARAMETER :: jp_bdyaip = 15 ! 61 61 INTEGER , PARAMETER :: jp_bdyhip = 16 ! 62 INTEGER , PARAMETER :: jp_bdyhil = 17 ! 62 63 #if ! defined key_si3 63 64 INTEGER , PARAMETER :: jpl = 1 … … 187 188 dta_bdy(jbdy)%aip(ib,jl) = a_ip(ii,ij,jl) * tmask(ii,ij,1) 188 189 dta_bdy(jbdy)%hip(ib,jl) = h_ip(ii,ij,jl) * tmask(ii,ij,1) 190 dta_bdy(jbdy)%hil(ib,jl) = h_il(ii,ij,jl) * tmask(ii,ij,1) 189 191 END DO 190 192 END DO … … 289 291 IF( TRIM(bf_alias(jp_bdytsu)%clrootname) == 'NOT USED' ) bf_alias(jp_bdytsu)%fnow(:,1,:) = rice_tem (jbdy) 290 292 IF( TRIM(bf_alias(jp_bdys_i)%clrootname) == 'NOT USED' ) bf_alias(jp_bdys_i)%fnow(:,1,:) = rice_sal (jbdy) 291 IF( TRIM(bf_alias(jp_bdyaip)%clrootname) == 'NOT USED' ) bf_alias(jp_bdyaip)%fnow(:,1,:) = rice_apnd(jbdy) * &! rice_apnd is the pond fraction292 & bf_alias(jp_bdya_i)%fnow(:,1,:) ! ( a_ip = rice_apnd *a_i )293 IF( TRIM(bf_alias(jp_bdyaip)%clrootname) == 'NOT USED' ) & ! rice_apnd is the pond fraction 294 & bf_alias(jp_bdyaip)%fnow(:,1,:) = rice_apnd(jbdy) * bf_alias(jp_bdya_i)%fnow(:,1,:) ! ( a_ip = rice_apnd*a_i ) 293 295 IF( TRIM(bf_alias(jp_bdyhip)%clrootname) == 'NOT USED' ) bf_alias(jp_bdyhip)%fnow(:,1,:) = rice_hpnd(jbdy) 294 296 IF( TRIM(bf_alias(jp_bdyhil)%clrootname) == 'NOT USED' ) bf_alias(jp_bdyhil)%fnow(:,1,:) = rice_hlid(jbdy) 297 295 298 ! if T_i is read and not T_su, set T_su = T_i 296 299 IF( TRIM(bf_alias(jp_bdyt_i)%clrootname) /= 'NOT USED' .AND. TRIM(bf_alias(jp_bdytsu)%clrootname) == 'NOT USED' ) & … … 316 319 bf_alias(jp_bdyaip)%fnow(:,1,:) = 0._wp 317 320 bf_alias(jp_bdyhip)%fnow(:,1,:) = 0._wp 321 bf_alias(jp_bdyhil)%fnow(:,1,:) = 0._wp 322 ENDIF 323 IF ( .NOT.ln_pnd_lids ) THEN 324 bf_alias(jp_bdyhil)%fnow(:,1,:) = 0._wp 318 325 ENDIF 319 326 … … 321 328 ipl = SIZE(bf_alias(jp_bdya_i)%fnow, 3) 322 329 IF( ipl /= jpl ) THEN ! ice: convert N-cat fields (input) into jpl-cat (output) 323 CALL ice_var_itd( bf_alias(jp_bdyh_i)%fnow(:,1,:), bf_alias(jp_bdyh_s)%fnow(:,1,:), bf_alias(jp_bdya_i)%fnow(:,1,:), & 324 & dta_alias%h_i , dta_alias%h_s , dta_alias%a_i , & 325 & bf_alias(jp_bdyt_i)%fnow(:,1,:), bf_alias(jp_bdyt_s)%fnow(:,1,:), & 326 & bf_alias(jp_bdytsu)%fnow(:,1,:), bf_alias(jp_bdys_i)%fnow(:,1,:), & 327 & bf_alias(jp_bdyaip)%fnow(:,1,:), bf_alias(jp_bdyhip)%fnow(:,1,:), &328 & dta_alias%t_i , dta_alias%t_s , & 329 & dta_alias%tsu , dta_alias%s_i , & 330 & dta_alias%aip , dta_alias%hip )330 CALL ice_var_itd( bf_alias(jp_bdyh_i)%fnow(:,1,:), bf_alias(jp_bdyh_s)%fnow(:,1,:), bf_alias(jp_bdya_i)%fnow(:,1,:), & ! in 331 & dta_alias%h_i , dta_alias%h_s , dta_alias%a_i , & ! out 332 & bf_alias(jp_bdyt_i)%fnow(:,1,:), bf_alias(jp_bdyt_s)%fnow(:,1,:), & ! in (optional) 333 & bf_alias(jp_bdytsu)%fnow(:,1,:), bf_alias(jp_bdys_i)%fnow(:,1,:), & ! in - 334 & bf_alias(jp_bdyaip)%fnow(:,1,:), bf_alias(jp_bdyhip)%fnow(:,1,:), bf_alias(jp_bdyhil)%fnow(:,1,:), & ! in - 335 & dta_alias%t_i , dta_alias%t_s , & ! out - 336 & dta_alias%tsu , dta_alias%s_i , & ! out - 337 & dta_alias%aip , dta_alias%hip , dta_alias%hil ) ! out - 331 338 ENDIF 332 339 ENDIF … … 374 381 ! ! =F => baroclinic velocities in 3D boundary data 375 382 LOGICAL :: ln_zinterp ! =T => requires a vertical interpolation of the bdydta 376 REAL(wp) :: rn_ice_tem, rn_ice_sal, rn_ice_age, rn_ice_apnd, rn_ice_hpnd 383 REAL(wp) :: rn_ice_tem, rn_ice_sal, rn_ice_age, rn_ice_apnd, rn_ice_hpnd, rn_ice_hlid 377 384 INTEGER :: ipk,ipl ! 378 385 INTEGER :: idvar ! variable ID … … 387 394 TYPE(FLD_N), DIMENSION(1), TARGET :: bn_tem, bn_sal, bn_u3d, bn_v3d ! must be an array to be used with fld_fill 388 395 TYPE(FLD_N), DIMENSION(1), TARGET :: bn_ssh, bn_u2d, bn_v2d ! informations about the fields to be read 389 TYPE(FLD_N), DIMENSION(1), TARGET :: bn_a_i, bn_h_i, bn_h_s, bn_t_i, bn_t_s, bn_tsu, bn_s_i, bn_aip, bn_hip 396 TYPE(FLD_N), DIMENSION(1), TARGET :: bn_a_i, bn_h_i, bn_h_s, bn_t_i, bn_t_s, bn_tsu, bn_s_i, bn_aip, bn_hip, bn_hil 390 397 TYPE(FLD_N), DIMENSION(:), POINTER :: bn_alias ! must be an array to be used with fld_fill 391 398 TYPE(FLD ), DIMENSION(:), POINTER :: bf_alias 392 399 ! 393 NAMELIST/nambdy_dta/ cn_dir, bn_tem, bn_sal, bn_u3d, bn_v3d, bn_ssh, bn_u2d, bn_v2d 394 NAMELIST/nambdy_dta/ bn_a_i, bn_h_i, bn_h_s, bn_t_i, bn_t_s, bn_tsu, bn_s_i, bn_aip, bn_hip395 NAMELIST/nambdy_dta/ rn_ice_tem, rn_ice_sal, rn_ice_age, rn_ice_apnd, rn_ice_hpnd396 NAMELIST/nambdy_dta/ln_full_vel, ln_zinterp400 NAMELIST/nambdy_dta/ cn_dir, bn_tem, bn_sal, bn_u3d, bn_v3d, bn_ssh, bn_u2d, bn_v2d, & 401 & bn_a_i, bn_h_i, bn_h_s, bn_t_i, bn_t_s, bn_tsu, bn_s_i, bn_aip, bn_hip, bn_hil, & 402 & rn_ice_tem, rn_ice_sal, rn_ice_age, rn_ice_apnd, rn_ice_hpnd, rn_ice_hlid, & 403 & ln_full_vel, ln_zinterp 397 404 !!--------------------------------------------------------------------------- 398 405 ! … … 464 471 #if defined key_si3 465 472 IF( .NOT.ln_pnd ) THEN 466 rn_ice_apnd = 0. ; rn_ice_hpnd = 0. 467 CALL ctl_warn( 'rn_ice_apnd & rn_ice_hpnd = 0 when no ponds' ) 473 rn_ice_apnd = 0. ; rn_ice_hpnd = 0. ; rn_ice_hlid = 0. 474 CALL ctl_warn( 'rn_ice_apnd & rn_ice_hpnd = 0 & rn_ice_hlid = 0 when no ponds' ) 475 ENDIF 476 IF( .NOT.ln_pnd_lids ) THEN 477 rn_ice_hlid = 0. 468 478 ENDIF 469 479 #endif … … 475 485 rice_apnd(jbdy) = rn_ice_apnd 476 486 rice_hpnd(jbdy) = rn_ice_hpnd 477 487 rice_hlid(jbdy) = rn_ice_hlid 488 478 489 479 490 DO jfld = 1, jpbdyfld … … 576 587 IF( jfld == jp_bdya_i .OR. jfld == jp_bdyh_i .OR. jfld == jp_bdyh_s .OR. & 577 588 & jfld == jp_bdyt_i .OR. jfld == jp_bdyt_s .OR. jfld == jp_bdytsu .OR. & 578 & jfld == jp_bdys_i .OR. jfld == jp_bdyaip .OR. jfld == jp_bdyhip 589 & jfld == jp_bdys_i .OR. jfld == jp_bdyaip .OR. jfld == jp_bdyhip .OR. jfld == jp_bdyhil ) THEN 579 590 igrd = 1 ! T point 580 591 ipk = ipl ! jpl-cat data … … 627 638 bf_alias => bf(jp_bdyhip,jbdy:jbdy) ! alias for hip structure of bdy number jbdy 628 639 bn_alias => bn_hip ! alias for hip structure of nambdy_dta 640 ENDIF 641 IF( jfld == jp_bdyhil ) THEN 642 cl3 = 'hil' 643 bf_alias => bf(jp_bdyhil,jbdy:jbdy) ! alias for hil structure of bdy number jbdy 644 bn_alias => bn_hil ! alias for hil structure of nambdy_dta 629 645 ENDIF 630 646 … … 696 712 ENDIF 697 713 ENDIF 714 IF( jfld == jp_bdyhil ) THEN 715 IF( ipk == jpl ) THEN ; dta_bdy(jbdy)%hil => bf_alias(1)%fnow(:,1,:) 716 ELSE ; ALLOCATE( dta_bdy(jbdy)%hil(iszdim,jpl) ) 717 ENDIF 718 ENDIF 698 719 ENDIF 699 720 -
NEMO/branches/2020/dev_r13327_KERNEL-06_2_techene_e3/src/OCE/BDY/bdyice.F90
r13226 r13998 61 61 !!---------------------------------------------------------------------- 62 62 ! controls 63 IF( ln_timing ) CALL timing_start('bdy_ice_thd') ! timing 64 IF( ln_icediachk ) CALL ice_cons_hsm(0,'bdy_ice_thd', rdiag_v, rdiag_s, rdiag_t, rdiag_fv, rdiag_fs, rdiag_ft) ! conservation 65 IF( ln_icediachk ) CALL ice_cons2D (0,'bdy_ice_thd', diag_v, diag_s, diag_t, diag_fv, diag_fs, diag_ft) ! conservation 63 IF( ln_timing ) CALL timing_start('bdy_ice_thd') ! timing 66 64 ! 67 65 CALL ice_var_glo2eqv … … 94 92 IF( ANY(llsend1) .OR. ANY(llrecv1) ) THEN ! if need to send/recv in at least one direction 95 93 ! exchange 3d arrays 96 CALL lbc_lnk_multi( 'bdyice', a_i , 'T', 1.0_wp, h_i , 'T', 1.0_wp, h_s , 'T', 1.0_wp, oa_i, 'T', 1.0_wp&97 & , a_ip, 'T', 1.0_wp, v_ip, 'T', 1.0_wp, s_i , 'T', 1.0_wp, t_su, 'T', 1.0_wp &98 & , v_i , 'T', 1.0_wp, v_s , 'T', 1.0_wp, sv_i, 'T', 1.0_wp&99 & , kfillmode=jpfillnothing ,lsend=llsend1, lrecv=llrecv1)94 CALL lbc_lnk_multi('bdyice', a_i , 'T', 1._wp, h_i , 'T', 1._wp, h_s , 'T', 1._wp, oa_i, 'T', 1._wp & 95 & , s_i , 'T', 1._wp, t_su, 'T', 1._wp, v_i , 'T', 1._wp, v_s , 'T', 1._wp, sv_i, 'T', 1._wp & 96 & , a_ip, 'T', 1._wp, v_ip, 'T', 1._wp, v_il, 'T', 1._wp & 97 & , kfillmode=jpfillnothing ,lsend=llsend1, lrecv=llrecv1 ) 100 98 ! exchange 4d arrays : third dimension = 1 and then third dimension = jpk 101 CALL lbc_lnk_multi( 'bdyice', t_s , 'T', 1.0_wp, e_s , 'T', 1.0_wp, kfillmode=jpfillnothing ,lsend=llsend1, lrecv=llrecv1 )102 CALL lbc_lnk_multi( 'bdyice', t_i , 'T', 1.0_wp, e_i , 'T', 1.0_wp, kfillmode=jpfillnothing ,lsend=llsend1, lrecv=llrecv1 )99 CALL lbc_lnk_multi('bdyice', t_s , 'T', 1._wp, e_s , 'T', 1._wp, kfillmode=jpfillnothing ,lsend=llsend1, lrecv=llrecv1 ) 100 CALL lbc_lnk_multi('bdyice', t_i , 'T', 1._wp, e_i , 'T', 1._wp, kfillmode=jpfillnothing ,lsend=llsend1, lrecv=llrecv1 ) 103 101 END IF 104 102 END DO ! ir … … 110 108 ! 111 109 ! controls 112 IF( ln_icectl ) CALL ice_prt ( kt, iiceprt, jiceprt, 1, ' - ice thermo bdy - ' ) ! prints 113 IF( ln_icediachk ) CALL ice_cons_hsm(1,'bdy_ice_thd', rdiag_v, rdiag_s, rdiag_t, rdiag_fv, rdiag_fs, rdiag_ft) ! conservation 114 IF( ln_icediachk ) CALL ice_cons2D (1,'bdy_ice_thd', diag_v, diag_s, diag_t, diag_fv, diag_fs, diag_ft) ! conservation 115 IF( ln_timing ) CALL timing_stop ('bdy_ice_thd') ! timing 110 IF( ln_icectl ) CALL ice_prt ( kt, iiceprt, jiceprt, 1, ' - ice thermo bdy - ' ) ! prints 111 IF( ln_timing ) CALL timing_stop ('bdy_ice_thd') ! timing 116 112 ! 117 113 END SUBROUTINE bdy_ice … … 163 159 a_ip(ji,jj, jl) = ( a_ip(ji,jj, jl) * zwgt1 + dta%aip(i_bdy,jl) * zwgt ) * tmask(ji,jj,1) ! Ice pond concentration 164 160 h_ip(ji,jj, jl) = ( h_ip(ji,jj, jl) * zwgt1 + dta%hip(i_bdy,jl) * zwgt ) * tmask(ji,jj,1) ! Ice pond depth 161 h_il(ji,jj, jl) = ( h_il(ji,jj, jl) * zwgt1 + dta%hil(i_bdy,jl) * zwgt ) * tmask(ji,jj,1) ! Ice pond lid depth 165 162 ! 166 163 sz_i(ji,jj,:,jl) = s_i(ji,jj,jl) … … 170 167 a_ip(ji,jj,jl) = 0._wp 171 168 h_ip(ji,jj,jl) = 0._wp 169 h_il(ji,jj,jl) = 0._wp 170 ENDIF 171 172 IF( .NOT.ln_pnd_lids ) THEN 173 h_il(ji,jj,jl) = 0._wp 172 174 ENDIF 173 175 ! … … 231 233 a_ip(ji,jj, jl) = a_ip(ib,jb, jl) 232 234 h_ip(ji,jj, jl) = h_ip(ib,jb, jl) 235 h_il(ji,jj, jl) = h_il(ib,jb, jl) 233 236 ! 234 237 sz_i(ji,jj,:,jl) = sz_i(ib,jb,:,jl) … … 265 268 ! 266 269 ! melt ponds 267 IF( a_i(ji,jj,jl) > epsi10 ) THEN268 a_ip_frac(ji,jj,jl) = a_ip(ji,jj,jl) / a_i (ji,jj,jl)269 ELSE270 a_ip_frac(ji,jj,jl) = 0._wp271 ENDIF272 270 v_ip(ji,jj,jl) = h_ip(ji,jj,jl) * a_ip(ji,jj,jl) 271 v_il(ji,jj,jl) = h_il(ji,jj,jl) * a_ip(ji,jj,jl) 273 272 ! 274 273 ELSE ! no ice at the boundary … … 278 277 h_s (ji,jj, jl) = 0._wp 279 278 oa_i(ji,jj, jl) = 0._wp 280 a_ip(ji,jj, jl) = 0._wp281 v_ip(ji,jj, jl) = 0._wp282 279 t_su(ji,jj, jl) = rt0 283 280 t_s (ji,jj,:,jl) = rt0 284 281 t_i (ji,jj,:,jl) = rt0 285 282 286 a_ip_frac(ji,jj,jl) = 0._wp 287 h_ip (ji,jj,jl) = 0._wp 288 a_ip (ji,jj,jl) = 0._wp 289 v_ip (ji,jj,jl) = 0._wp 283 a_ip(ji,jj,jl) = 0._wp 284 h_ip(ji,jj,jl) = 0._wp 285 h_il(ji,jj,jl) = 0._wp 290 286 291 287 IF( nn_icesal == 1 ) THEN ! if constant salinity … … 303 299 e_s (ji,jj,:,jl) = 0._wp 304 300 e_i (ji,jj,:,jl) = 0._wp 301 v_ip(ji,jj, jl) = 0._wp 302 v_il(ji,jj, jl) = 0._wp 305 303 306 304 ENDIF -
NEMO/branches/2020/dev_r13327_KERNEL-06_2_techene_e3/src/OCE/BDY/bdyini.F90
r13286 r13998 786 786 ii = idx_bdy(ib_bdy)%nbi(ib,igrd) 787 787 ij = idx_bdy(ib_bdy)%nbj(ib,igrd) 788 IF( mig (ii) > 2 .AND. mig(ii) < jpiglo-2 .AND. mjg(ij) > 2 .AND. mjg(ij) < jpjglo-2 ) THEN788 IF( mig0(ii) > 2 .AND. mig0(ii) < Ni0glo-2 .AND. mjg0(ij) > 2 .AND. mjg0(ij) < Nj0glo-2 ) THEN 789 789 WRITE(ctmp1,*) ' Orlanski is not safe when the open boundaries are on the interior of the computational domain' 790 790 CALL ctl_stop( ctmp1 ) … … 1071 1071 SUBROUTINE bdy_read_seg( kb_bdy, knblendta ) 1072 1072 !!---------------------------------------------------------------------- 1073 !! *** ROUTINE bdy_ coords_seg ***1073 !! *** ROUTINE bdy_read_seg *** 1074 1074 !! 1075 1075 !! ** Purpose : build bdy coordinates with segments defined in namelist … … 1111 1111 CASE( 'N' ) 1112 1112 IF( nbdyind == -1 ) THEN ! Automatic boundary definition: if nbdysegX = -1 1113 nbdyind = jpjglo - 2 ! set boundary to whole side of model domain.1113 nbdyind = Nj0glo - 2 ! set boundary to whole side of model domain. 1114 1114 nbdybeg = 2 1115 nbdyend = jpiglo - 11115 nbdyend = Ni0glo - 1 1116 1116 ENDIF 1117 1117 nbdysegn = nbdysegn + 1 1118 1118 npckgn(nbdysegn) = kb_bdy ! Save bdy package number 1119 jpjnob(nbdysegn) = nbdyind 1119 jpjnob(nbdysegn) = nbdyind 1120 1120 jpindt(nbdysegn) = nbdybeg 1121 1121 jpinft(nbdysegn) = nbdyend … … 1125 1125 nbdyind = 2 ! set boundary to whole side of model domain. 1126 1126 nbdybeg = 2 1127 nbdyend = jpiglo - 11127 nbdyend = Ni0glo - 1 1128 1128 ENDIF 1129 1129 nbdysegs = nbdysegs + 1 … … 1135 1135 CASE( 'E' ) 1136 1136 IF( nbdyind == -1 ) THEN ! Automatic boundary definition: if nbdysegX = -1 1137 nbdyind = jpiglo - 2 ! set boundary to whole side of model domain.1137 nbdyind = Ni0glo - 2 ! set boundary to whole side of model domain. 1138 1138 nbdybeg = 2 1139 nbdyend = jpjglo - 11139 nbdyend = Nj0glo - 1 1140 1140 ENDIF 1141 1141 nbdysege = nbdysege + 1 … … 1149 1149 nbdyind = 2 ! set boundary to whole side of model domain. 1150 1150 nbdybeg = 2 1151 nbdyend = jpjglo - 11151 nbdyend = Nj0glo - 1 1152 1152 ENDIF 1153 1153 nbdysegw = nbdysegw + 1 … … 1192 1192 IF(lwp) WRITE(numout,*) 'Number of north segments : ', nbdysegn 1193 1193 IF(lwp) WRITE(numout,*) 'Number of south segments : ', nbdysegs 1194 ! 1194 1195 ! 1. Check bounds 1195 1196 !---------------- 1196 1197 DO ib = 1, nbdysegn 1197 1198 IF (lwp) WRITE(numout,*) '**check north seg bounds pckg: ', npckgn(ib) 1198 IF ((jpjnob(ib).ge. jpjglo-1).or.&1199 IF ((jpjnob(ib).ge.Nj0glo-1).or.& 1199 1200 &(jpjnob(ib).le.1)) CALL ctl_stop( 'nbdyind out of domain' ) 1200 1201 IF (jpindt(ib).ge.jpinft(ib)) CALL ctl_stop( 'Bdy start index is greater than end index' ) 1201 1202 IF (jpindt(ib).lt.1 ) CALL ctl_stop( 'Start index out of domain' ) 1202 IF (jpinft(ib).gt. jpiglo) CALL ctl_stop( 'End index out of domain' )1203 IF (jpinft(ib).gt.Ni0glo) CALL ctl_stop( 'End index out of domain' ) 1203 1204 END DO 1204 1205 ! 1205 1206 DO ib = 1, nbdysegs 1206 1207 IF (lwp) WRITE(numout,*) '**check south seg bounds pckg: ', npckgs(ib) 1207 IF ((jpjsob(ib).ge. jpjglo-1).or.&1208 IF ((jpjsob(ib).ge.Nj0glo-1).or.& 1208 1209 &(jpjsob(ib).le.1)) CALL ctl_stop( 'nbdyind out of domain' ) 1209 1210 IF (jpisdt(ib).ge.jpisft(ib)) CALL ctl_stop( 'Bdy start index is greater than end index' ) 1210 1211 IF (jpisdt(ib).lt.1 ) CALL ctl_stop( 'Start index out of domain' ) 1211 IF (jpisft(ib).gt. jpiglo) CALL ctl_stop( 'End index out of domain' )1212 IF (jpisft(ib).gt.Ni0glo) CALL ctl_stop( 'End index out of domain' ) 1212 1213 END DO 1213 1214 ! 1214 1215 DO ib = 1, nbdysege 1215 1216 IF (lwp) WRITE(numout,*) '**check east seg bounds pckg: ', npckge(ib) 1216 IF ((jpieob(ib).ge. jpiglo-1).or.&1217 IF ((jpieob(ib).ge.Ni0glo-1).or.& 1217 1218 &(jpieob(ib).le.1)) CALL ctl_stop( 'nbdyind out of domain' ) 1218 1219 IF (jpjedt(ib).ge.jpjeft(ib)) CALL ctl_stop( 'Bdy start index is greater than end index' ) 1219 1220 IF (jpjedt(ib).lt.1 ) CALL ctl_stop( 'Start index out of domain' ) 1220 IF (jpjeft(ib).gt. jpjglo) CALL ctl_stop( 'End index out of domain' )1221 IF (jpjeft(ib).gt.Nj0glo) CALL ctl_stop( 'End index out of domain' ) 1221 1222 END DO 1222 1223 ! 1223 1224 DO ib = 1, nbdysegw 1224 1225 IF (lwp) WRITE(numout,*) '**check west seg bounds pckg: ', npckgw(ib) 1225 IF ((jpiwob(ib).ge. jpiglo-1).or.&1226 IF ((jpiwob(ib).ge.Ni0glo-1).or.& 1226 1227 &(jpiwob(ib).le.1)) CALL ctl_stop( 'nbdyind out of domain' ) 1227 1228 IF (jpjwdt(ib).ge.jpjwft(ib)) CALL ctl_stop( 'Bdy start index is greater than end index' ) 1228 1229 IF (jpjwdt(ib).lt.1 ) CALL ctl_stop( 'Start index out of domain' ) 1229 IF (jpjwft(ib).gt. jpjglo) CALL ctl_stop( 'End index out of domain' )1230 IF (jpjwft(ib).gt.Nj0glo) CALL ctl_stop( 'End index out of domain' ) 1230 1231 ENDDO 1231 !1232 1232 ! 1233 1233 ! 2. Look for segment crossings … … 1378 1378 DO ji = 1, jpi 1379 1379 DO jj = 1, jpj 1380 IF( mig (ji) == jpiwob(ib) .AND. mjg(jj) == jpjwdt(ib) ) ztestmask(1) = tmask(ji,jj,1)1381 IF( mig (ji) == jpiwob(ib) .AND. mjg(jj) == jpjwft(ib) ) ztestmask(2) = tmask(ji,jj,1)1380 IF( mig0(ji) == jpiwob(ib) .AND. mjg0(jj) == jpjwdt(ib) ) ztestmask(1) = tmask(ji,jj,1) 1381 IF( mig0(ji) == jpiwob(ib) .AND. mjg0(jj) == jpjwft(ib) ) ztestmask(2) = tmask(ji,jj,1) 1382 1382 END DO 1383 1383 END DO … … 1414 1414 DO ji = 1, jpi 1415 1415 DO jj = 1, jpj 1416 IF( mig (ji) == jpieob(ib)+1 .AND. mjg(jj) == jpjedt(ib) ) ztestmask(1) = tmask(ji,jj,1)1417 IF( mig (ji) == jpieob(ib)+1 .AND. mjg(jj) == jpjeft(ib) ) ztestmask(2) = tmask(ji,jj,1)1416 IF( mig0(ji) == jpieob(ib)+1 .AND. mjg0(jj) == jpjedt(ib) ) ztestmask(1) = tmask(ji,jj,1) 1417 IF( mig0(ji) == jpieob(ib)+1 .AND. mjg0(jj) == jpjeft(ib) ) ztestmask(2) = tmask(ji,jj,1) 1418 1418 END DO 1419 1419 END DO … … 1450 1450 DO ji = 1, jpi 1451 1451 DO jj = 1, jpj 1452 IF( mjg (jj) == jpjsob(ib) .AND. mig(ji) == jpisdt(ib) ) ztestmask(1) = tmask(ji,jj,1)1453 IF( mjg (jj) == jpjsob(ib) .AND. mig(ji) == jpisft(ib) ) ztestmask(2) = tmask(ji,jj,1)1452 IF( mjg0(jj) == jpjsob(ib) .AND. mig0(ji) == jpisdt(ib) ) ztestmask(1) = tmask(ji,jj,1) 1453 IF( mjg0(jj) == jpjsob(ib) .AND. mig0(ji) == jpisft(ib) ) ztestmask(2) = tmask(ji,jj,1) 1454 1454 END DO 1455 1455 END DO … … 1472 1472 DO ji = 1, jpi 1473 1473 DO jj = 1, jpj 1474 IF( mjg (jj) == jpjnob(ib)+1 .AND. mig(ji) == jpindt(ib) ) ztestmask(1) = tmask(ji,jj,1)1475 IF( mjg (jj) == jpjnob(ib)+1 .AND. mig(ji) == jpinft(ib) ) ztestmask(2) = tmask(ji,jj,1)1474 IF( mjg0(jj) == jpjnob(ib)+1 .AND. mig0(ji) == jpindt(ib) ) ztestmask(1) = tmask(ji,jj,1) 1475 IF( mjg0(jj) == jpjnob(ib)+1 .AND. mig0(ji) == jpinft(ib) ) ztestmask(2) = tmask(ji,jj,1) 1476 1476 END DO 1477 1477 END DO … … 1526 1526 DO ij = jpjedt(iseg), jpjeft(iseg) 1527 1527 icount = icount + 1 1528 nbidta(icount, igrd, ib_bdy) = jpieob(iseg) + 2 - ir 1529 nbjdta(icount, igrd, ib_bdy) = ij 1528 nbidta(icount, igrd, ib_bdy) = jpieob(iseg) + 2 - ir + nn_hls 1529 nbjdta(icount, igrd, ib_bdy) = ij + nn_hls 1530 1530 nbrdta(icount, igrd, ib_bdy) = ir 1531 1531 ENDDO … … 1538 1538 DO ij = jpjedt(iseg), jpjeft(iseg) 1539 1539 icount = icount + 1 1540 nbidta(icount, igrd, ib_bdy) = jpieob(iseg) + 1 - ir 1541 nbjdta(icount, igrd, ib_bdy) = ij 1540 nbidta(icount, igrd, ib_bdy) = jpieob(iseg) + 1 - ir + nn_hls 1541 nbjdta(icount, igrd, ib_bdy) = ij + nn_hls 1542 1542 nbrdta(icount, igrd, ib_bdy) = ir 1543 1543 ENDDO … … 1551 1551 DO ij = jpjedt(iseg), jpjeft(iseg) 1552 1552 icount = icount + 1 1553 nbidta(icount, igrd, ib_bdy) = jpieob(iseg) + 2 - ir 1554 nbjdta(icount, igrd, ib_bdy) = ij 1553 nbidta(icount, igrd, ib_bdy) = jpieob(iseg) + 2 - ir + nn_hls 1554 nbjdta(icount, igrd, ib_bdy) = ij + nn_hls 1555 1555 nbrdta(icount, igrd, ib_bdy) = ir 1556 1556 ENDDO … … 1571 1571 DO ij = jpjwdt(iseg), jpjwft(iseg) 1572 1572 icount = icount + 1 1573 nbidta(icount, igrd, ib_bdy) = jpiwob(iseg) + ir - 1 1574 nbjdta(icount, igrd, ib_bdy) = ij 1573 nbidta(icount, igrd, ib_bdy) = jpiwob(iseg) + ir - 1 + nn_hls 1574 nbjdta(icount, igrd, ib_bdy) = ij + nn_hls 1575 1575 nbrdta(icount, igrd, ib_bdy) = ir 1576 1576 ENDDO … … 1583 1583 DO ij = jpjwdt(iseg), jpjwft(iseg) 1584 1584 icount = icount + 1 1585 nbidta(icount, igrd, ib_bdy) = jpiwob(iseg) + ir - 1 1586 nbjdta(icount, igrd, ib_bdy) = ij 1585 nbidta(icount, igrd, ib_bdy) = jpiwob(iseg) + ir - 1 + nn_hls 1586 nbjdta(icount, igrd, ib_bdy) = ij + nn_hls 1587 1587 nbrdta(icount, igrd, ib_bdy) = ir 1588 1588 ENDDO … … 1596 1596 DO ij = jpjwdt(iseg), jpjwft(iseg) 1597 1597 icount = icount + 1 1598 nbidta(icount, igrd, ib_bdy) = jpiwob(iseg) + ir - 1 1599 nbjdta(icount, igrd, ib_bdy) = ij 1598 nbidta(icount, igrd, ib_bdy) = jpiwob(iseg) + ir - 1 + nn_hls 1599 nbjdta(icount, igrd, ib_bdy) = ij + nn_hls 1600 1600 nbrdta(icount, igrd, ib_bdy) = ir 1601 1601 ENDDO … … 1616 1616 DO ii = jpindt(iseg), jpinft(iseg) 1617 1617 icount = icount + 1 1618 nbidta(icount, igrd, ib_bdy) = ii 1619 nbjdta(icount, igrd, ib_bdy) = jpjnob(iseg) + 2 - ir 1618 nbidta(icount, igrd, ib_bdy) = ii + nn_hls 1619 nbjdta(icount, igrd, ib_bdy) = jpjnob(iseg) + 2 - ir + nn_hls 1620 1620 nbrdta(icount, igrd, ib_bdy) = ir 1621 1621 ENDDO … … 1629 1629 DO ii = jpindt(iseg), jpinft(iseg) 1630 1630 icount = icount + 1 1631 nbidta(icount, igrd, ib_bdy) = ii 1632 nbjdta(icount, igrd, ib_bdy) = jpjnob(iseg) + 2 - ir 1631 nbidta(icount, igrd, ib_bdy) = ii + nn_hls 1632 nbjdta(icount, igrd, ib_bdy) = jpjnob(iseg) + 2 - ir + nn_hls 1633 1633 nbrdta(icount, igrd, ib_bdy) = ir 1634 1634 ENDDO … … 1643 1643 DO ii = jpindt(iseg), jpinft(iseg) 1644 1644 icount = icount + 1 1645 nbidta(icount, igrd, ib_bdy) = ii 1646 nbjdta(icount, igrd, ib_bdy) = jpjnob(iseg) + 1 - ir 1645 nbidta(icount, igrd, ib_bdy) = ii + nn_hls 1646 nbjdta(icount, igrd, ib_bdy) = jpjnob(iseg) + 1 - ir + nn_hls 1647 1647 nbrdta(icount, igrd, ib_bdy) = ir 1648 1648 ENDDO … … 1661 1661 DO ii = jpisdt(iseg), jpisft(iseg) 1662 1662 icount = icount + 1 1663 nbidta(icount, igrd, ib_bdy) = ii 1664 nbjdta(icount, igrd, ib_bdy) = jpjsob(iseg) + ir - 1 1663 nbidta(icount, igrd, ib_bdy) = ii + nn_hls 1664 nbjdta(icount, igrd, ib_bdy) = jpjsob(iseg) + ir - 1 + nn_hls 1665 1665 nbrdta(icount, igrd, ib_bdy) = ir 1666 1666 ENDDO … … 1674 1674 DO ii = jpisdt(iseg), jpisft(iseg) 1675 1675 icount = icount + 1 1676 nbidta(icount, igrd, ib_bdy) = ii 1677 nbjdta(icount, igrd, ib_bdy) = jpjsob(iseg) + ir - 1 1676 nbidta(icount, igrd, ib_bdy) = ii + nn_hls 1677 nbjdta(icount, igrd, ib_bdy) = jpjsob(iseg) + ir - 1 + nn_hls 1678 1678 nbrdta(icount, igrd, ib_bdy) = ir 1679 1679 ENDDO … … 1688 1688 DO ii = jpisdt(iseg), jpisft(iseg) 1689 1689 icount = icount + 1 1690 nbidta(icount, igrd, ib_bdy) = ii 1691 nbjdta(icount, igrd, ib_bdy) = jpjsob(iseg) + ir - 1 1690 nbidta(icount, igrd, ib_bdy) = ii + nn_hls 1691 nbjdta(icount, igrd, ib_bdy) = jpjsob(iseg) + ir - 1 + nn_hls 1692 1692 nbrdta(icount, igrd, ib_bdy) = ir 1693 1693 ENDDO -
NEMO/branches/2020/dev_r13327_KERNEL-06_2_techene_e3/src/OCE/BDY/bdylib.F90
r13226 r13998 44 44 !!---------------------------------------------------------------------- 45 45 TYPE(OBC_INDEX), INTENT(in) :: idx ! OBC indices 46 REAL(wp), DIMENSION(:,:), 46 REAL(wp), DIMENSION(:,:), POINTER, INTENT(in) :: dta ! OBC external data 47 47 REAL(wp), DIMENSION(jpi,jpj,jpk), INTENT(inout) :: phia ! tracer trend 48 48 !! … … 73 73 !!---------------------------------------------------------------------- 74 74 TYPE(OBC_INDEX), INTENT(in) :: idx ! OBC indices 75 REAL(wp), DIMENSION(:,:), 75 REAL(wp), DIMENSION(:,:), POINTER, INTENT(in) :: dta ! OBC external data 76 76 REAL(wp), DIMENSION(jpi,jpj,jpk), INTENT(inout) :: phia ! tracer trend 77 77 !! … … 100 100 !! 101 101 !!---------------------------------------------------------------------- 102 TYPE(OBC_INDEX), INTENT(in) :: idx ! OBC indices103 REAL(wp), DIMENSION(:,:), INTENT(in) :: dta ! OBC external data104 REAL(wp), DIMENSION(jpi,jpj,jpk), INTENT(inout) :: phib ! before tracer field105 REAL(wp), DIMENSION(jpi,jpj,jpk), INTENT(inout) :: phia ! tracer trend106 LOGICAL , OPTIONAL, INTENT(in) :: lrim0 ! indicate if rim 0 is treated107 LOGICAL , INTENT(in) :: ll_npo ! switch for NPO version102 TYPE(OBC_INDEX), INTENT(in ) :: idx ! OBC indices 103 REAL(wp), DIMENSION(:,:), POINTER, INTENT(in ) :: dta ! OBC external data 104 REAL(wp), DIMENSION(jpi,jpj,jpk), INTENT(inout) :: phib ! before tracer field 105 REAL(wp), DIMENSION(jpi,jpj,jpk), INTENT(inout) :: phia ! tracer trend 106 LOGICAL , INTENT(in ) :: lrim0 ! indicate if rim 0 is treated 107 LOGICAL , INTENT(in ) :: ll_npo ! switch for NPO version 108 108 !! 109 109 INTEGER :: igrd ! grid index … … 128 128 !! References: Marchesiello, McWilliams and Shchepetkin, Ocean Modelling vol. 3 (2001) 129 129 !!---------------------------------------------------------------------- 130 TYPE(OBC_INDEX), INTENT(in ) :: idx ! BDY indices131 INTEGER , INTENT(in ) :: igrd ! grid index132 REAL(wp), DIMENSION(:,:), INTENT(in ) :: phib ! model before 2D field133 REAL(wp), DIMENSION(:,:), INTENT(inout) :: phia ! model after 2D field (to be updated)134 REAL(wp), DIMENSION(: ), INTENT(in ) :: phi_ext ! external forcing data135 LOGICAL , OPTIONAL,INTENT(in ) :: lrim0 ! indicate if rim 0 is treated136 LOGICAL , INTENT(in ) :: ll_npo ! switch for NPO version130 TYPE(OBC_INDEX), INTENT(in ) :: idx ! BDY indices 131 INTEGER , INTENT(in ) :: igrd ! grid index 132 REAL(wp), DIMENSION(:,:), INTENT(in ) :: phib ! model before 2D field 133 REAL(wp), DIMENSION(:,:), INTENT(inout) :: phia ! model after 2D field (to be updated) 134 REAL(wp), DIMENSION(: ), POINTER, INTENT(in ) :: phi_ext ! external forcing data 135 LOGICAL , INTENT(in ) :: lrim0 ! indicate if rim 0 is treated 136 LOGICAL , INTENT(in ) :: ll_npo ! switch for NPO version 137 137 ! 138 138 INTEGER :: jb ! dummy loop indices … … 188 188 END SELECT 189 189 ! 190 IF( PRESENT(lrim0) ) THEN 191 IF( lrim0 ) THEN ; ibeg = 1 ; iend = idx%nblenrim0(igrd) ! rim 0 192 ELSE ; ibeg = idx%nblenrim0(igrd)+1 ; iend = idx%nblenrim(igrd) ! rim 1 193 END IF 194 ELSE ; ibeg = 1 ; iend = idx%nblenrim(igrd) ! both 195 END IF 190 IF( lrim0 ) THEN ; ibeg = 1 ; iend = idx%nblenrim0(igrd) ! rim 0 191 ELSE ; ibeg = idx%nblenrim0(igrd)+1 ; iend = idx%nblenrim(igrd) ! rim 1 192 ENDIF 196 193 ! 197 194 DO jb = ibeg, iend … … 275 272 & - (1.-zsign_ups) * zry * ( phib(iijp1,ijjp1) - phib(ii ,ij ) ) & 276 273 & + zwgt * ( phi_ext(jb) - phib(ii,ij) ) ) / ( 1. + zrx ) 277 end 274 endif 278 275 phia(ii,ij) = phia(ii,ij) * zmask(ii,ij) 279 276 END DO … … 293 290 !! References: Marchesiello, McWilliams and Shchepetkin, Ocean Modelling vol. 3 (2001) 294 291 !!---------------------------------------------------------------------- 295 TYPE(OBC_INDEX), INTENT(in ) :: idx ! BDY indices296 INTEGER , INTENT(in ) :: igrd ! grid index297 REAL(wp), DIMENSION(:,:,:), INTENT(in ) :: phib ! model before 3D field298 REAL(wp), DIMENSION(:,:,:), INTENT(inout) :: phia ! model after 3D field (to be updated)299 REAL(wp), DIMENSION(:,: ), INTENT(in ) :: phi_ext ! external forcing data300 LOGICAL , OPTIONAL,INTENT(in ) :: lrim0 ! indicate if rim 0 is treated301 LOGICAL , INTENT(in ) :: ll_npo ! switch for NPO version292 TYPE(OBC_INDEX), INTENT(in ) :: idx ! BDY indices 293 INTEGER , INTENT(in ) :: igrd ! grid index 294 REAL(wp), DIMENSION(:,:,:), INTENT(in ) :: phib ! model before 3D field 295 REAL(wp), DIMENSION(:,:,:), INTENT(inout) :: phia ! model after 3D field (to be updated) 296 REAL(wp), DIMENSION(:,: ), POINTER, INTENT(in ) :: phi_ext ! external forcing data 297 LOGICAL , INTENT(in ) :: lrim0 ! indicate if rim 0 is treated 298 LOGICAL , INTENT(in ) :: ll_npo ! switch for NPO version 302 299 ! 303 300 INTEGER :: jb, jk ! dummy loop indices … … 353 350 END SELECT 354 351 ! 355 IF( PRESENT(lrim0) ) THEN 356 IF( lrim0 ) THEN ; ibeg = 1 ; iend = idx%nblenrim0(igrd) ! rim 0 357 ELSE ; ibeg = idx%nblenrim0(igrd)+1 ; iend = idx%nblenrim(igrd) ! rim 1 358 END IF 359 ELSE ; ibeg = 1 ; iend = idx%nblenrim(igrd) ! both 360 END IF 352 IF( lrim0 ) THEN ; ibeg = 1 ; iend = idx%nblenrim0(igrd) ! rim 0 353 ELSE ; ibeg = idx%nblenrim0(igrd)+1 ; iend = idx%nblenrim(igrd) ! rim 1 354 ENDIF 361 355 ! 362 356 DO jk = 1, jpk … … 441 435 & - (1.-zsign_ups) * zry * ( phib(iijp1,ijjp1,jk) - phib(ii ,ij ,jk) ) & 442 436 & + zwgt * ( phi_ext(jb,jk) - phib(ii,ij,jk) ) ) / ( 1. + zrx ) 443 end 437 endif 444 438 phia(ii,ij,jk) = phia(ii,ij,jk) * zmask(ii,ij,jk) 445 439 END DO … … 466 460 REAL(wp), DIMENSION(:,:,:), INTENT(inout) :: phia ! model after 3D field (to be updated), must be masked 467 461 TYPE(OBC_INDEX), INTENT(in ) :: idx ! OBC indices 468 LOGICAL , OPTIONAL,INTENT(in ) :: lrim0 ! indicate if rim 0 is treated462 LOGICAL , INTENT(in ) :: lrim0 ! indicate if rim 0 is treated 469 463 !! 470 464 REAL(wp) :: zweight … … 486 480 END SELECT 487 481 ! 488 IF( PRESENT(lrim0) ) THEN 489 IF( lrim0 ) THEN ; ibeg = 1 ; iend = idx%nblenrim0(igrd) ! rim 0 490 ELSE ; ibeg = idx%nblenrim0(igrd)+1 ; iend = idx%nblenrim(igrd) ! rim 1 491 END IF 492 ELSE ; ibeg = 1 ; iend = idx%nblenrim(igrd) ! both 493 END IF 482 IF( lrim0 ) THEN ; ibeg = 1 ; iend = idx%nblenrim0(igrd) ! rim 0 483 ELSE ; ibeg = idx%nblenrim0(igrd)+1 ; iend = idx%nblenrim(igrd) ! rim 1 484 ENDIF 494 485 ! 495 486 DO ib = ibeg, iend -
NEMO/branches/2020/dev_r13327_KERNEL-06_2_techene_e3/src/OCE/BDY/bdytra.F90
r13226 r13998 61 61 IF( ir == 0 ) THEN ; llrim0 = .TRUE. 62 62 ELSE ; llrim0 = .FALSE. 63 END 63 ENDIF 64 64 DO ib_bdy=1, nb_bdy 65 65 ! … … 69 69 DO jn = 1, jpts 70 70 ! 71 SELECT CASE( TRIM(cn_tra(ib_bdy)) )71 SELECT CASE( cn_tra(ib_bdy) ) 72 72 CASE('none' ) ; CYCLE 73 73 CASE('frs' ) ! treat the whole boundary at once 74 IF( ir == 0 ) CALL bdy_frs ( idx_bdy(ib_bdy),pts(:,:,:,jn,Kaa), zdta(jn)%tra )74 IF( ir == 0 ) CALL bdy_frs ( idx_bdy(ib_bdy), pts(:,:,:,jn,Kaa), zdta(jn)%tra ) 75 75 CASE('specified' ) ! treat the whole rim at once 76 IF( ir == 0 ) CALL bdy_spe ( idx_bdy(ib_bdy),pts(:,:,:,jn,Kaa), zdta(jn)%tra )77 CASE('neumann' ) ; CALL bdy_nmn ( idx_bdy(ib_bdy), igrd , pts(:,:,:,jn,Kaa), llrim0 ) ! tsa masked78 CASE('orlanski' ) ; CALL bdy_orl ( idx_bdy(ib_bdy), pts(:,:,:,jn,Kbb), pts(:,:,:,jn,Kaa), &79 & zdta(jn)%tra, llrim0, ll_npo=.false. )80 CASE('orlanski_npo') ; CALL bdy_orl ( idx_bdy(ib_bdy), pts(:,:,:,jn,Kbb), pts(:,:,:,jn,Kaa), &81 & zdta(jn)%tra, llrim0, ll_npo=.true. )82 CASE('runoff' ) ; CALL bdy_rnf ( idx_bdy(ib_bdy), pts(:,:,:,jn,Kaa), jn, llrim0 )76 IF( ir == 0 ) CALL bdy_spe ( idx_bdy(ib_bdy), pts(:,:,:,jn,Kaa), zdta(jn)%tra ) 77 CASE('neumann' ) ; CALL bdy_nmn ( idx_bdy(ib_bdy), igrd , pts(:,:,:,jn,Kaa), llrim0 ) ! tsa masked 78 CASE('orlanski' ) ; CALL bdy_orl ( idx_bdy(ib_bdy), pts(:,:,:,jn,Kbb), pts(:,:,:,jn,Kaa), zdta(jn)%tra, & 79 & llrim0, ll_npo=.FALSE. ) 80 CASE('orlanski_npo') ; CALL bdy_orl ( idx_bdy(ib_bdy), pts(:,:,:,jn,Kbb), pts(:,:,:,jn,Kaa), zdta(jn)%tra, & 81 & llrim0, ll_npo=.TRUE. ) 82 CASE('runoff' ) ; CALL bdy_rnf ( idx_bdy(ib_bdy), pts(:,:,:,jn,Kaa), jn, llrim0 ) 83 83 CASE DEFAULT ; CALL ctl_stop( 'bdy_tra : unrecognised option for open boundaries for T and S' ) 84 84 END SELECT … … 88 88 ! 89 89 IF( nn_hls > 1 .AND. ir == 1 ) CYCLE ! at least 2 halos will be corrected -> no need to correct rim 1 before rim 0 90 IF( nn_hls == 1 ) THEN ; llsend1(:) = .false. ; llrecv1(:) = .false. ; END 90 IF( nn_hls == 1 ) THEN ; llsend1(:) = .false. ; llrecv1(:) = .false. ; ENDIF 91 91 DO ib_bdy=1, nb_bdy 92 SELECT CASE( TRIM(cn_tra(ib_bdy)) )92 SELECT CASE( cn_tra(ib_bdy) ) 93 93 CASE('neumann','runoff') 94 94 llsend1(:) = llsend1(:) .OR. lsend_bdyint(ib_bdy,1,:,ir) ! possibly every direction, T points … … 101 101 IF( ANY(llsend1) .OR. ANY(llrecv1) ) THEN ! if need to send/recv in at least one direction 102 102 CALL lbc_lnk( 'bdytra', pts(:,:,:,jn,Kaa), 'T', 1.0_wp, kfillmode=jpfillnothing ,lsend=llsend1, lrecv=llrecv1 ) 103 END 103 ENDIF 104 104 ! 105 105 END DO ! ir … … 135 135 pt(ii,ij,1:jpkm1) = 0.1 * tmask(ii,ij,1:jpkm1) 136 136 END DO 137 END 137 ENDIF 138 138 ! 139 139 END SUBROUTINE bdy_rnf -
NEMO/branches/2020/dev_r13327_KERNEL-06_2_techene_e3/src/OCE/C1D/dtauvd.F90
r13295 r13998 158 158 ENDIF 159 159 ! 160 DO_2D( 1, 1, 1, 1 ) 160 DO_2D( 1, 1, 1, 1 ) ! vertical interpolation of U & V current: 161 161 DO jk = 1, jpk 162 162 zl = gdept(ji,jj,jk,Kmm) -
NEMO/branches/2020/dev_r13327_KERNEL-06_2_techene_e3/src/OCE/CRS/crsfld.F90
r13295 r13998 146 146 CALL iom_put( "voces" , zs_crs ) ! vS 147 147 148 IF( iom_use( " eken") ) THEN ! kinetic energy148 IF( iom_use( "ke") ) THEN ! kinetic energy 149 149 z3d(:,:,jk) = 0._wp 150 150 DO_3D( 0, 0, 0, 0, 1, jpkm1 ) … … 159 159 ! 160 160 CALL crs_dom_ope( z3d, 'VOL', 'T', tmask, zt_crs, p_e12=e1e2t, p_e3=ze3t, psgn=1.0_wp ) 161 CALL iom_put( " eken", zt_crs )161 CALL iom_put( "ke", zt_crs ) 162 162 ENDIF 163 163 ! Horizontal divergence ( following OCE/DYN/divhor.F90 ) -
NEMO/branches/2020/dev_r13327_KERNEL-06_2_techene_e3/src/OCE/DIA/diaar5.F90
r13295 r13998 144 144 IF( ln_linssh ) THEN 145 145 IF( ln_isfcav ) THEN 146 DO ji = 1, jpi 147 DO jj = 1, jpj 148 iks = mikt(ji,jj) 149 zbotpres(ji,jj) = zbotpres(ji,jj) + ssh(ji,jj,Kmm) * zrhd(ji,jj,iks) + riceload(ji,jj) 150 END DO 151 END DO 146 DO_2D( nn_hls, nn_hls, nn_hls, nn_hls ) 147 iks = mikt(ji,jj) 148 zbotpres(ji,jj) = zbotpres(ji,jj) + ssh(ji,jj,Kmm) * zrhd(ji,jj,iks) + riceload(ji,jj) 149 END_2D 152 150 ELSE 153 151 zbotpres(:,:) = zbotpres(:,:) + ssh(:,:,Kmm) * zrhd(:,:,1) … … 385 383 zvol0 (:,:) = 0._wp 386 384 thick0(:,:) = 0._wp 387 DO_3D( 1, 1, 1, 1, 1, jpkm1 ) 385 DO_3D( 1, 1, 1, 1, 1, jpkm1 ) ! interpolation of salinity at the last ocean level (i.e. the partial step) 388 386 idep = tmask(ji,jj,jk) * e3t_0(ji,jj,jk) 389 387 zvol0 (ji,jj) = zvol0 (ji,jj) + idep * e1e2t(ji,jj) … … 403 401 sn0(:,:,:) = sn0(:,:,:) * tmask(:,:,:) 404 402 IF( ln_zps ) THEN ! z-coord. partial steps 405 DO_2D( 1, 1, 1, 1 ) 403 DO_2D( 1, 1, 1, 1 ) ! interpolation of salinity at the last ocean level (i.e. the partial step) 406 404 ik = mbkt(ji,jj) 407 405 IF( ik > 1 ) THEN -
NEMO/branches/2020/dev_r13327_KERNEL-06_2_techene_e3/src/OCE/DIA/diacfl.F90
r13295 r13998 56 56 INTEGER , DIMENSION(3) :: iloc_u , iloc_v , iloc_w , iloc ! workspace 57 57 REAL(wp), DIMENSION(jpi,jpj,jpk) :: zCu_cfl, zCv_cfl, zCw_cfl ! workspace 58 LOGICAL , DIMENSION(jpi,jpj,jpk) :: llmsk 58 59 !!---------------------------------------------------------------------- 59 60 ! 60 61 IF( ln_timing ) CALL timing_start('dia_cfl') 61 62 ! 62 DO_3D( 1, 1, 1, 1, 1, jpk ) 63 llmsk( 1:Nis1,:,:) = .FALSE. ! exclude halos from the checked region 64 llmsk(Nie1: jpi,:,:) = .FALSE. 65 llmsk(:, 1:Njs1,:) = .FALSE. 66 llmsk(:,Nje1: jpj,:) = .FALSE. 67 ! 68 DO_3D( 0, 0, 0, 0, 1, jpk ) ! calculate Courant numbers 63 69 zCu_cfl(ji,jj,jk) = ABS( uu(ji,jj,jk,Kmm) ) * rDt / e1u (ji,jj) ! for i-direction 64 70 zCv_cfl(ji,jj,jk) = ABS( vv(ji,jj,jk,Kmm) ) * rDt / e2v (ji,jj) ! for j-direction 65 zCw_cfl(ji,jj,jk) = ABS( ww(ji,jj,jk) ) * rDt / e3w(ji,jj,jk,Kmm) ! for k-direction71 zCw_cfl(ji,jj,jk) = ABS( ww(ji,jj,jk) ) * rDt / e3w(ji,jj,jk,Kmm) ! for k-direction 66 72 END_3D 67 73 ! 68 74 ! write outputs 69 IF( iom_use('cfl_cu') ) CALL iom_put( 'cfl_cu', MAXVAL( zCu_cfl, dim=3 ) ) 70 IF( iom_use('cfl_cv') ) CALL iom_put( 'cfl_cv', MAXVAL( zCv_cfl, dim=3 ) ) 71 IF( iom_use('cfl_cw') ) CALL iom_put( 'cfl_cw', MAXVAL( zCw_cfl, dim=3 ) ) 75 IF( iom_use('cfl_cu') ) THEN 76 llmsk(Nis0:Nie0,Njs0:Nje0,:) = umask(Nis0:Nie0,Njs0:Nje0,:) == 1._wp ! define only the inner domain 77 CALL iom_put( 'cfl_cu', MAXVAL( zCu_cfl, mask = llmsk, dim=3 ) ) 78 ENDIF 79 IF( iom_use('cfl_cv') ) THEN 80 llmsk(Nis0:Nie0,Njs0:Nje0,:) = vmask(Nis0:Nie0,Njs0:Nje0,:) == 1._wp ! define only the inner domain 81 CALL iom_put( 'cfl_cv', MAXVAL( zCv_cfl, mask = llmsk, dim=3 ) ) 82 ENDIF 83 IF( iom_use('cfl_cw') ) THEN 84 llmsk(Nis0:Nie0,Njs0:Nje0,:) = wmask(Nis0:Nie0,Njs0:Nje0,:) == 1._wp ! define only the inner domain 85 CALL iom_put( 'cfl_cw', MAXVAL( zCw_cfl, mask = llmsk, dim=3 ) ) 86 ENDIF 72 87 73 88 ! ! calculate maximum values and locations 74 IF( lk_mpp ) THEN 75 CALL mpp_maxloc( 'diacfl', zCu_cfl, umask, zCu_max, iloc_u ) 76 CALL mpp_maxloc( 'diacfl', zCv_cfl, vmask, zCv_max, iloc_v ) 77 CALL mpp_maxloc( 'diacfl', zCw_cfl, wmask, zCw_max, iloc_w ) 78 ELSE 79 iloc = MAXLOC( ABS( zcu_cfl(:,:,:) ) ) 80 iloc_u(1) = iloc(1) + nimpp - 1 81 iloc_u(2) = iloc(2) + njmpp - 1 82 iloc_u(3) = iloc(3) 83 zCu_max = zCu_cfl(iloc(1),iloc(2),iloc(3)) 84 ! 85 iloc = MAXLOC( ABS( zcv_cfl(:,:,:) ) ) 86 iloc_v(1) = iloc(1) + nimpp - 1 87 iloc_v(2) = iloc(2) + njmpp - 1 88 iloc_v(3) = iloc(3) 89 zCv_max = zCv_cfl(iloc(1),iloc(2),iloc(3)) 90 ! 91 iloc = MAXLOC( ABS( zcw_cfl(:,:,:) ) ) 92 iloc_w(1) = iloc(1) + nimpp - 1 93 iloc_w(2) = iloc(2) + njmpp - 1 94 iloc_w(3) = iloc(3) 95 zCw_max = zCw_cfl(iloc(1),iloc(2),iloc(3)) 96 ENDIF 89 llmsk(Nis0:Nie0,Njs0:Nje0,:) = umask(Nis0:Nie0,Njs0:Nje0,:) == 1._wp ! define only the inner domain 90 CALL mpp_maxloc( 'diacfl', zCu_cfl, llmsk, zCu_max, iloc_u ) 91 llmsk(Nis0:Nie0,Njs0:Nje0,:) = vmask(Nis0:Nie0,Njs0:Nje0,:) == 1._wp ! define only the inner domain 92 CALL mpp_maxloc( 'diacfl', zCv_cfl, llmsk, zCv_max, iloc_v ) 93 llmsk(Nis0:Nie0,Njs0:Nje0,:) = wmask(Nis0:Nie0,Njs0:Nje0,:) == 1._wp ! define only the inner domain 94 CALL mpp_maxloc( 'diacfl', zCw_cfl, llmsk, zCw_max, iloc_w ) 97 95 ! 98 ! ! write out to file 99 IF( lwp ) THEN 96 IF( lwp ) THEN ! write out to file 100 97 WRITE(numcfl,FMT='(2x,i6,3x,a6,4x,f7.4,1x,i4,1x,i4,1x,i4)') kt, 'Max Cu', zCu_max, iloc_u(1), iloc_u(2), iloc_u(3) 101 98 WRITE(numcfl,FMT='(11x, a6,4x,f7.4,1x,i4,1x,i4,1x,i4)') 'Max Cv', zCv_max, iloc_v(1), iloc_v(2), iloc_v(3) -
NEMO/branches/2020/dev_r13327_KERNEL-06_2_techene_e3/src/OCE/DIA/diahth.F90
r13295 r13998 170 170 ! MLD: rho = rho(1) + zrho1 ! 171 171 ! ------------------------------------------------------------- ! 172 DO_3DS( 1, 1, 1, 1, jpkm1, 2, -1 ) 172 DO_3DS( 1, 1, 1, 1, jpkm1, 2, -1 ) ! loop from bottom to 2 173 173 ! 174 174 zzdep = gdepw(ji,jj,jk,Kmm) … … 207 207 ! depth of temperature inversion ! 208 208 ! ------------------------------------------------------------- ! 209 DO_3DS( 1, 1, 1, 1, jpkm1, nlb10, -1 ) 209 DO_3DS( 1, 1, 1, 1, jpkm1, nlb10, -1 ) ! loop from bottom to nlb10 210 210 ! 211 211 zzdep = gdepw(ji,jj,jk,Kmm) * tmask(ji,jj,1) … … 305 305 ! --------------------------------------- ! 306 306 iktem(:,:) = 1 307 DO_3D( 1, 1, 1, 1, 1, jpkm1 ) 307 DO_3D( 1, 1, 1, 1, 1, jpkm1 ) ! beware temperature is not always decreasing with depth => loop from top to bottom 308 308 zztmp = ts(ji,jj,jk,jp_tem,Kmm) 309 309 IF( zztmp >= ptem ) iktem(ji,jj) = jk -
NEMO/branches/2020/dev_r13327_KERNEL-06_2_techene_e3/src/OCE/DIA/diaptr.F90
r13295 r13998 36 36 END INTERFACE 37 37 38 PUBLIC ptr_sj ! call by tra_ldf & tra_adv routines39 PUBLIC ptr_sjk !40 PUBLIC dia_ptr_init ! call in memogcm41 38 PUBLIC dia_ptr ! call in step module 42 39 PUBLIC dia_ptr_hst ! called from tra_ldf/tra_adv routines 43 40 44 ! !!** namelist namptr **45 41 REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: hstr_adv, hstr_ldf, hstr_eiv !: Heat/Salt TRansports(adv, diff, Bolus.) 46 42 REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: hstr_ove, hstr_btr, hstr_vtr !: heat Salt TRansports(overturn, baro, merional) 47 43 48 LOGICAL , PUBLIC :: l_diaptr !: tracers trend flag (set from namelist in trdini) 49 INTEGER, PARAMETER, PUBLIC :: nptr = 5 ! (glo, atl, pac, ind, ipc) 44 LOGICAL, PUBLIC :: l_diaptr !: tracers trend flag 50 45 51 46 REAL(wp) :: rc_sv = 1.e-6_wp ! conversion from m3/s to Sverdrup … … 59 54 REAL(wp), TARGET, ALLOCATABLE, SAVE, DIMENSION(:,:) :: p_fval2d 60 55 61 LOGICAL :: ll_init = .TRUE. !: tracers trend flag (set from namelist in trdini)56 LOGICAL :: ll_init = .TRUE. !: tracers trend flag 62 57 63 58 !! * Substitutions … … 88 83 ! 89 84 !overturning calculation 90 REAL(wp), DIMENSION( jpj,jpk,nptr) ::sjk, r1_sjk, v_msf ! i-mean i-k-surface and its inverse91 REAL(wp), DIMENSION( jpj,jpk,nptr) :: zt_jk, zs_jk! i-mean T and S, j-Stream-Function92 93 REAL(wp), DIMENSION( jpi,jpj,jpk,nptr) ::z4d1, z4d294 REAL(wp), DIMENSION( jpi,jpj,nptr) :: z3dtr ! i-mean T and S, j-Stream-Function85 REAL(wp), DIMENSION(:,:,: ), ALLOCATABLE :: sjk, r1_sjk, v_msf ! i-mean i-k-surface and its inverse 86 REAL(wp), DIMENSION(:,:,: ), ALLOCATABLE :: zt_jk, zs_jk ! i-mean T and S, j-Stream-Function 87 88 REAL(wp), DIMENSION(:,:,:,:), ALLOCATABLE :: z4d1, z4d2 89 REAL(wp), DIMENSION(:,:,: ), ALLOCATABLE :: z3dtr 95 90 !!---------------------------------------------------------------------- 96 91 ! 97 92 IF( ln_timing ) CALL timing_start('dia_ptr') 98 93 99 IF( kt == nit000 .AND. ll_init ) CALL dia_ptr_init 100 ! 101 IF( .NOT. l_diaptr ) RETURN 102 94 IF( kt == nit000 .AND. ll_init ) CALL dia_ptr_init ! -> will define l_diaptr and nbasin 95 ! 96 IF( .NOT. l_diaptr ) THEN 97 IF( ln_timing ) CALL timing_stop('dia_ptr') 98 RETURN 99 ENDIF 100 ! 101 ALLOCATE( z3dtr(jpi,jpj,nbasin) ) 102 ! 103 103 IF( PRESENT( pvtr ) ) THEN 104 104 IF( iom_use( 'zomsf' ) ) THEN ! effective MSF 105 DO jn = 1, nptr ! by sub-basins 105 ALLOCATE( z4d1(jpi,jpj,jpk,nbasin) ) 106 DO jn = 1, nbasin ! by sub-basins 106 107 z4d1(1,:,:,jn) = ptr_sjk( pvtr(:,:,:), btmsk34(:,:,jn) ) ! zonal cumulative effective transport excluding closed seas 107 108 DO jk = jpkm1, 1, -1 … … 113 114 END DO 114 115 CALL iom_put( 'zomsf', z4d1 * rc_sv ) 116 DEALLOCATE( z4d1 ) 115 117 ENDIF 116 118 IF( iom_use( 'sopstove' ) .OR. iom_use( 'sophtove' ) .OR. & … … 127 129 ENDIF 128 130 IF( iom_use( 'sopstove' ) .OR. iom_use( 'sophtove' ) ) THEN 129 DO jn = 1, nptr 131 DO jn = 1, nbasin 132 ALLOCATE( sjk(jpj,jpk,nbasin), r1_sjk(jpj,jpk,nbasin), v_msf(jpj,jpk,nbasin), & 133 & zt_jk(jpj,jpk,nbasin), zs_jk(jpj,jpk,nbasin) ) 130 134 sjk(:,:,jn) = ptr_sjk( zmask(:,:,:), btmsk(:,:,jn) ) 131 135 r1_sjk(:,:,jn) = 0._wp … … 137 141 hstr_ove(:,jp_tem,jn) = SUM( v_msf(:,:,jn)*zt_jk(:,:,jn), 2 ) 138 142 hstr_ove(:,jp_sal,jn) = SUM( v_msf(:,:,jn)*zs_jk(:,:,jn), 2 ) 143 DEALLOCATE( sjk, r1_sjk, v_msf, zt_jk, zs_jk ) 139 144 ! 140 145 ENDDO 141 DO jn = 1, n ptr146 DO jn = 1, nbasin 142 147 z3dtr(1,:,jn) = hstr_ove(:,jp_tem,jn) * rc_pwatt ! (conversion in PW) 143 148 DO ji = 1, jpi … … 146 151 ENDDO 147 152 CALL iom_put( 'sophtove', z3dtr ) 148 DO jn = 1, n ptr153 DO jn = 1, nbasin 149 154 z3dtr(1,:,jn) = hstr_ove(:,jp_sal,jn) * rc_ggram ! (conversion in Gg) 150 155 DO ji = 1, jpi … … 157 162 IF( iom_use( 'sopstbtr' ) .OR. iom_use( 'sophtbtr' ) ) THEN 158 163 ! Calculate barotropic heat and salt transport here 159 DO jn = 1, nptr 164 DO jn = 1, nbasin 165 ALLOCATE( sjk(jpj,1,nbasin), r1_sjk(jpj,1,nbasin) ) 160 166 sjk(:,1,jn) = ptr_sj( zmask(:,:,:), btmsk(:,:,jn) ) 161 167 r1_sjk(:,1,jn) = 0._wp … … 167 173 hstr_btr(:,jp_tem,jn) = zvsum(:) * ztsum(:) * r1_sjk(:,1,jn) 168 174 hstr_btr(:,jp_sal,jn) = zvsum(:) * zssum(:) * r1_sjk(:,1,jn) 175 DEALLOCATE( sjk, r1_sjk ) 169 176 ! 170 177 ENDDO 171 DO jn = 1, n ptr178 DO jn = 1, nbasin 172 179 z3dtr(1,:,jn) = hstr_btr(:,jp_tem,jn) * rc_pwatt ! (conversion in PW) 173 180 DO ji = 1, jpi … … 176 183 ENDDO 177 184 CALL iom_put( 'sophtbtr', z3dtr ) 178 DO jn = 1, n ptr185 DO jn = 1, nbasin 179 186 z3dtr(1,:,jn) = hstr_btr(:,jp_sal,jn) * rc_ggram ! (conversion in Gg) 180 187 DO ji = 1, jpi … … 190 197 zts(:,:,:,:) = 0._wp 191 198 IF( iom_use( 'zotem' ) .OR. iom_use( 'zosal' ) .OR. iom_use( 'zosrf' ) ) THEN ! i-mean i-k-surface 199 ALLOCATE( z4d1(jpi,jpj,jpk,nbasin), z4d2(jpi,jpj,jpk,nbasin) ) 192 200 DO_3D( 1, 1, 1, 1, 1, jpkm1 ) 193 201 zsfc = e1t(ji,jj) * e3t(ji,jj,jk,Kmm) … … 197 205 END_3D 198 206 ! 199 DO jn = 1, n ptr207 DO jn = 1, nbasin 200 208 zmask(1,:,:) = ptr_sjk( zmask(:,:,:), btmsk(:,:,jn) ) 209 DO ji = 1, jpi 210 zmask(ji,:,:) = zmask(1,:,:) 211 ENDDO 201 212 z4d1(:,:,:,jn) = zmask(:,:,:) 202 213 ENDDO 203 214 CALL iom_put( 'zosrf', z4d1 ) 204 215 ! 205 DO jn = 1, n ptr216 DO jn = 1, nbasin 206 217 z4d2(1,:,:,jn) = ptr_sjk( zts(:,:,:,jp_tem), btmsk(:,:,jn) ) & 207 218 & / MAX( z4d1(1,:,:,jn), 10.e-15 ) … … 212 223 CALL iom_put( 'zotem', z4d2 ) 213 224 ! 214 DO jn = 1, n ptr225 DO jn = 1, nbasin 215 226 z4d2(1,:,:,jn) = ptr_sjk( zts(:,:,:,jp_sal), btmsk(:,:,jn) ) & 216 227 & / MAX( z4d1(1,:,:,jn), 10.e-15 ) … … 220 231 ENDDO 221 232 CALL iom_put( 'zosal', z4d2 ) 233 DEALLOCATE( z4d1, z4d2 ) 222 234 ! 223 235 ENDIF … … 226 238 IF( iom_use( 'sophtadv' ) .OR. iom_use( 'sopstadv' ) ) THEN 227 239 ! 228 DO jn = 1, n ptr240 DO jn = 1, nbasin 229 241 z3dtr(1,:,jn) = hstr_adv(:,jp_tem,jn) * rc_pwatt ! (conversion in PW) 230 242 DO ji = 1, jpi … … 233 245 ENDDO 234 246 CALL iom_put( 'sophtadv', z3dtr ) 235 DO jn = 1, n ptr247 DO jn = 1, nbasin 236 248 z3dtr(1,:,jn) = hstr_adv(:,jp_sal,jn) * rc_ggram ! (conversion in Gg) 237 249 DO ji = 1, jpi … … 244 256 IF( iom_use( 'sophtldf' ) .OR. iom_use( 'sopstldf' ) ) THEN 245 257 ! 246 DO jn = 1, n ptr258 DO jn = 1, nbasin 247 259 z3dtr(1,:,jn) = hstr_ldf(:,jp_tem,jn) * rc_pwatt ! (conversion in PW) 248 260 DO ji = 1, jpi … … 251 263 ENDDO 252 264 CALL iom_put( 'sophtldf', z3dtr ) 253 DO jn = 1, n ptr265 DO jn = 1, nbasin 254 266 z3dtr(1,:,jn) = hstr_ldf(:,jp_sal,jn) * rc_ggram ! (conversion in Gg) 255 267 DO ji = 1, jpi … … 262 274 IF( iom_use( 'sophteiv' ) .OR. iom_use( 'sopsteiv' ) ) THEN 263 275 ! 264 DO jn = 1, n ptr276 DO jn = 1, nbasin 265 277 z3dtr(1,:,jn) = hstr_eiv(:,jp_tem,jn) * rc_pwatt ! (conversion in PW) 266 278 DO ji = 1, jpi … … 269 281 ENDDO 270 282 CALL iom_put( 'sophteiv', z3dtr ) 271 DO jn = 1, n ptr283 DO jn = 1, nbasin 272 284 z3dtr(1,:,jn) = hstr_eiv(:,jp_sal,jn) * rc_ggram ! (conversion in Gg) 273 285 DO ji = 1, jpi … … 287 299 CALL dia_ptr_hst( jp_tem, 'vtr', zts(:,:,:,jp_tem) ) 288 300 CALL dia_ptr_hst( jp_sal, 'vtr', zts(:,:,:,jp_sal) ) 289 DO jn = 1, n ptr301 DO jn = 1, nbasin 290 302 z3dtr(1,:,jn) = hstr_vtr(:,jp_tem,jn) * rc_pwatt ! (conversion in PW) 291 303 DO ji = 1, jpi … … 294 306 ENDDO 295 307 CALL iom_put( 'sophtvtr', z3dtr ) 296 DO jn = 1, n ptr308 DO jn = 1, nbasin 297 309 z3dtr(1,:,jn) = hstr_vtr(:,jp_sal,jn) * rc_ggram ! (conversion in Gg) 298 310 DO ji = 1, jpi … … 311 323 ENDIF 312 324 ! 325 DEALLOCATE( z3dtr ) 326 ! 313 327 IF( ln_timing ) CALL timing_stop('dia_ptr') 314 328 ! … … 320 334 !! *** ROUTINE dia_ptr_init *** 321 335 !! 322 !! ** Purpose : Initialization , namelist read336 !! ** Purpose : Initialization 323 337 !!---------------------------------------------------------------------- 324 338 INTEGER :: inum, jn ! local integers … … 326 340 REAL(wp), DIMENSION(jpi,jpj) :: zmsk 327 341 !!---------------------------------------------------------------------- 328 329 l_diaptr = .FALSE. 330 IF( iom_use( 'zomsf' ) .OR. iom_use( 'zotem' ) .OR. iom_use( 'zosal' ) .OR. & 331 & iom_use( 'zosrf' ) .OR. iom_use( 'sopstove' ) .OR. iom_use( 'sophtove' ) .OR. & 332 & iom_use( 'sopstbtr' ) .OR. iom_use( 'sophtbtr' ) .OR. iom_use( 'sophtadv' ) .OR. & 333 & iom_use( 'sopstadv' ) .OR. iom_use( 'sophtldf' ) .OR. iom_use( 'sopstldf' ) .OR. & 334 & iom_use( 'sophteiv' ) .OR. iom_use( 'sopsteiv' ) .OR. iom_use( 'sopstvtr' ) .OR. & 335 & iom_use( 'sophtvtr' ) .OR. iom_use( 'uocetr_vsum_cumul' ) ) l_diaptr = .TRUE. 336 342 343 ! l_diaptr is defined with iom_use 344 ! --> dia_ptr_init must be done after the call to iom_init 345 ! --> cannot be .TRUE. without cpp key: key_iom --> nbasin define by iom_init is initialized 346 l_diaptr = iom_use( 'zomsf' ) .OR. iom_use( 'zotem' ) .OR. iom_use( 'zosal' ) .OR. & 347 & iom_use( 'zosrf' ) .OR. iom_use( 'sopstove' ) .OR. iom_use( 'sophtove' ) .OR. & 348 & iom_use( 'sopstbtr' ) .OR. iom_use( 'sophtbtr' ) .OR. iom_use( 'sophtadv' ) .OR. & 349 & iom_use( 'sopstadv' ) .OR. iom_use( 'sophtldf' ) .OR. iom_use( 'sopstldf' ) .OR. & 350 & iom_use( 'sophteiv' ) .OR. iom_use( 'sopsteiv' ) .OR. iom_use( 'sopstvtr' ) .OR. & 351 & iom_use( 'sophtvtr' ) .OR. iom_use( 'uocetr_vsum_cumul' ) 337 352 338 353 IF(lwp) THEN ! Control print … … 340 355 WRITE(numout,*) 'dia_ptr_init : poleward transport and msf initialization' 341 356 WRITE(numout,*) '~~~~~~~~~~~~' 342 WRITE(numout,*) ' Namelist namptr : set ptr parameters'343 357 WRITE(numout,*) ' Poleward heat & salt transport (T) or not (F) l_diaptr = ', l_diaptr 344 358 ENDIF … … 347 361 ! 348 362 IF( dia_ptr_alloc() /= 0 ) CALL ctl_stop( 'STOP', 'dia_ptr_init : unable to allocate arrays' ) 349 363 ! 350 364 rc_pwatt = rc_pwatt * rho0_rcp ! conversion from K.s-1 to PetaWatt 351 365 rc_ggram = rc_ggram * rho0 ! conversion from m3/s to Gg/s … … 354 368 355 369 btmsk(:,:,1) = tmask_i(:,:) 356 CALL iom_open( 'subbasins', inum, ldstop = .FALSE. ) 357 CALL iom_get( inum, jpdom_global, 'atlmsk', btmsk(:,:,2) ) ! Atlantic basin 358 CALL iom_get( inum, jpdom_global, 'pacmsk', btmsk(:,:,3) ) ! Pacific basin 359 CALL iom_get( inum, jpdom_global, 'indmsk', btmsk(:,:,4) ) ! Indian basin 360 CALL iom_close( inum ) 361 btmsk(:,:,5) = MAX ( btmsk(:,:,3), btmsk(:,:,4) ) ! Indo-Pacific basin 362 DO jn = 2, nptr 363 btmsk(:,:,jn) = btmsk(:,:,jn) * tmask_i(:,:) ! interior domain only 370 IF( nbasin == 5 ) THEN ! nbasin has been initialized in iom_init to define the axis "basin" 371 CALL iom_open( 'subbasins', inum ) 372 CALL iom_get( inum, jpdom_global, 'atlmsk', btmsk(:,:,2) ) ! Atlantic basin 373 CALL iom_get( inum, jpdom_global, 'pacmsk', btmsk(:,:,3) ) ! Pacific basin 374 CALL iom_get( inum, jpdom_global, 'indmsk', btmsk(:,:,4) ) ! Indian basin 375 CALL iom_close( inum ) 376 btmsk(:,:,5) = MAX ( btmsk(:,:,3), btmsk(:,:,4) ) ! Indo-Pacific basin 377 ENDIF 378 DO jn = 2, nbasin 379 btmsk(:,:,jn) = btmsk(:,:,jn) * tmask_i(:,:) ! interior domain only 364 380 END DO 365 381 ! JD : modification so that overturning streamfunction is available in Atlantic at 34S to compare with observations … … 370 386 END WHERE 371 387 btmsk34(:,:,1) = btmsk(:,:,1) 372 DO jn = 2, n ptr373 btmsk34(:,:,jn) = btmsk(:,:,jn) * zmsk(:,:) ! interior domain only388 DO jn = 2, nbasin 389 btmsk34(:,:,jn) = btmsk(:,:,jn) * zmsk(:,:) ! interior domain only 374 390 ENDDO 375 391 … … 405 421 IF( cptr == 'adv' ) THEN 406 422 IF( ktra == jp_tem ) THEN 407 DO jn = 1, n ptr423 DO jn = 1, nbasin 408 424 hstr_adv(:,jp_tem,jn) = ptr_sj( pvflx(:,:,:), btmsk(:,:,jn) ) 409 425 ENDDO 410 426 ENDIF 411 427 IF( ktra == jp_sal ) THEN 412 DO jn = 1, n ptr428 DO jn = 1, nbasin 413 429 hstr_adv(:,jp_sal,jn) = ptr_sj( pvflx(:,:,:), btmsk(:,:,jn) ) 414 430 ENDDO … … 418 434 IF( cptr == 'ldf' ) THEN 419 435 IF( ktra == jp_tem ) THEN 420 DO jn = 1, n ptr436 DO jn = 1, nbasin 421 437 hstr_ldf(:,jp_tem,jn) = ptr_sj( pvflx(:,:,:), btmsk(:,:,jn) ) 422 438 ENDDO 423 439 ENDIF 424 440 IF( ktra == jp_sal ) THEN 425 DO jn = 1, n ptr441 DO jn = 1, nbasin 426 442 hstr_ldf(:,jp_sal,jn) = ptr_sj( pvflx(:,:,:), btmsk(:,:,jn) ) 427 443 ENDDO … … 431 447 IF( cptr == 'eiv' ) THEN 432 448 IF( ktra == jp_tem ) THEN 433 DO jn = 1, n ptr449 DO jn = 1, nbasin 434 450 hstr_eiv(:,jp_tem,jn) = ptr_sj( pvflx(:,:,:), btmsk(:,:,jn) ) 435 451 ENDDO 436 452 ENDIF 437 453 IF( ktra == jp_sal ) THEN 438 DO jn = 1, n ptr454 DO jn = 1, nbasin 439 455 hstr_eiv(:,jp_sal,jn) = ptr_sj( pvflx(:,:,:), btmsk(:,:,jn) ) 440 456 ENDDO … … 444 460 IF( cptr == 'vtr' ) THEN 445 461 IF( ktra == jp_tem ) THEN 446 DO jn = 1, n ptr462 DO jn = 1, nbasin 447 463 hstr_vtr(:,jp_tem,jn) = ptr_sj( pvflx(:,:,:), btmsk(:,:,jn) ) 448 464 ENDDO 449 465 ENDIF 450 466 IF( ktra == jp_sal ) THEN 451 DO jn = 1, n ptr467 DO jn = 1, nbasin 452 468 hstr_vtr(:,jp_sal,jn) = ptr_sj( pvflx(:,:,:), btmsk(:,:,jn) ) 453 469 ENDDO … … 467 483 ierr(:) = 0 468 484 ! 485 ! nbasin has been initialized in iom_init to define the axis "basin" 486 ! 469 487 IF( .NOT. ALLOCATED( btmsk ) ) THEN 470 ALLOCATE( btmsk(jpi,jpj,n ptr) , btmsk34(jpi,jpj,nptr), &471 & hstr_adv(jpj,jpts,n ptr), hstr_eiv(jpj,jpts,nptr), &472 & hstr_ove(jpj,jpts,n ptr), hstr_btr(jpj,jpts,nptr), &473 & hstr_ldf(jpj,jpts,n ptr), hstr_vtr(jpj,jpts,nptr), STAT=ierr(1) )488 ALLOCATE( btmsk(jpi,jpj,nbasin) , btmsk34(jpi,jpj,nbasin), & 489 & hstr_adv(jpj,jpts,nbasin), hstr_eiv(jpj,jpts,nbasin), & 490 & hstr_ove(jpj,jpts,nbasin), hstr_btr(jpj,jpts,nbasin), & 491 & hstr_ldf(jpj,jpts,nbasin), hstr_vtr(jpj,jpts,nbasin), STAT=ierr(1) ) 474 492 ! 475 493 ALLOCATE( p_fval1d(jpj), p_fval2d(jpj,jpk), Stat=ierr(2)) -
NEMO/branches/2020/dev_r13327_KERNEL-06_2_techene_e3/src/OCE/DIA/diawri.F90
r13734 r13998 190 190 CALL iom_put( "sst", ts(:,:,1,jp_tem,Kmm) ) ! surface temperature 191 191 IF ( iom_use("sbt") ) THEN 192 DO_2D( 1, 1, 1, 1)192 DO_2D( 0, 0, 0, 0 ) 193 193 ikbot = mbkt(ji,jj) 194 194 z2d(ji,jj) = ts(ji,jj,ikbot,jp_tem,Kmm) … … 200 200 CALL iom_put( "sss", ts(:,:,1,jp_sal,Kmm) ) ! surface salinity 201 201 IF ( iom_use("sbs") ) THEN 202 DO_2D( 1, 1, 1, 1)202 DO_2D( 0, 0, 0, 0 ) 203 203 ikbot = mbkt(ji,jj) 204 204 z2d(ji,jj) = ts(ji,jj,ikbot,jp_sal,Kmm) … … 222 222 ! 223 223 END_2D 224 CALL lbc_lnk( 'diawri', z2d, 'T', 1.0_wp )225 224 CALL iom_put( "taubot", z2d ) 226 225 ENDIF … … 229 228 CALL iom_put( "ssu", uu(:,:,1,Kmm) ) ! surface i-current 230 229 IF ( iom_use("sbu") ) THEN 231 DO_2D( 1, 1, 1, 1)230 DO_2D( 0, 0, 0, 0 ) 232 231 ikbot = mbku(ji,jj) 233 232 z2d(ji,jj) = uu(ji,jj,ikbot,Kmm) … … 239 238 CALL iom_put( "ssv", vv(:,:,1,Kmm) ) ! surface j-current 240 239 IF ( iom_use("sbv") ) THEN 241 DO_2D( 1, 1, 1, 1)240 DO_2D( 0, 0, 0, 0 ) 242 241 ikbot = mbkv(ji,jj) 243 242 z2d(ji,jj) = vv(ji,jj,ikbot,Kmm) … … 268 267 IF( iom_use('logavs') ) CALL iom_put( "logavs", LOG( MAX( 1.e-20_wp, avs(:,:,:) ) ) ) 269 268 269 IF ( iom_use("socegrad") .OR. iom_use("socegrad2") ) THEN 270 z3d(:,:,jpk) = 0. 271 DO_3D( 0, 0, 0, 0, 1, jpkm1 ) 272 zztmp = ts(ji,jj,jk,jp_sal,Kmm) 273 zztmpx = (ts(ji+1,jj,jk,jp_sal,Kmm) - zztmp) * r1_e1u(ji,jj) + (zztmp - ts(ji-1,jj ,jk,jp_sal,Kmm)) * r1_e1u(ji-1,jj) 274 zztmpy = (ts(ji,jj+1,jk,jp_sal,Kmm) - zztmp) * r1_e2v(ji,jj) + (zztmp - ts(ji ,jj-1,jk,jp_sal,Kmm)) * r1_e2v(ji,jj-1) 275 z3d(ji,jj,jk) = 0.25 * ( zztmpx * zztmpx + zztmpy * zztmpy ) & 276 & * umask(ji,jj,jk) * umask(ji-1,jj,jk) * vmask(ji,jj,jk) * umask(ji,jj-1,jk) 277 END_3D 278 CALL iom_put( "socegrad2", z3d ) ! square of module of sal gradient 279 DO_3D( 0, 0, 0, 0, 1, jpkm1 ) 280 z3d(ji,jj,jk) = SQRT( z3d(ji,jj,jk) ) 281 END_3D 282 CALL iom_put( "socegrad" , z3d ) ! module of sal gradient 283 ENDIF 284 270 285 IF ( iom_use("sstgrad") .OR. iom_use("sstgrad2") ) THEN 271 DO_2D( 0, 0, 0, 0 ) 286 DO_2D( 0, 0, 0, 0 ) ! sst gradient 272 287 zztmp = ts(ji,jj,1,jp_tem,Kmm) 273 288 zztmpx = ( ts(ji+1,jj,1,jp_tem,Kmm) - zztmp ) * r1_e1u(ji,jj) + ( zztmp - ts(ji-1,jj ,1,jp_tem,Kmm) ) * r1_e1u(ji-1,jj) … … 276 291 & * umask(ji,jj,1) * umask(ji-1,jj,1) * vmask(ji,jj,1) * umask(ji,jj-1,1) 277 292 END_2D 278 CALL lbc_lnk( 'diawri', z2d, 'T', 1.0_wp )279 293 CALL iom_put( "sstgrad2", z2d ) ! square of module of sst gradient 280 z2d(:,:) = SQRT( z2d(:,:) ) 294 DO_2D( 0, 0, 0, 0 ) 295 z2d(ji,jj) = SQRT( z2d(ji,jj) ) 296 END_2D 281 297 CALL iom_put( "sstgrad" , z2d ) ! module of sst gradient 282 298 ENDIF … … 285 301 IF( iom_use("heatc") ) THEN 286 302 z2d(:,:) = 0._wp 287 DO_3D( 1, 1, 1, 1, 1, jpkm1 )303 DO_3D( 0, 0, 0, 0, 1, jpkm1 ) 288 304 z2d(ji,jj) = z2d(ji,jj) + e3t(ji,jj,jk,Kmm) * ts(ji,jj,jk,jp_tem,Kmm) * tmask(ji,jj,jk) 289 305 END_3D … … 293 309 IF( iom_use("saltc") ) THEN 294 310 z2d(:,:) = 0._wp 295 DO_3D( 1, 1, 1, 1, 1, jpkm1 )311 DO_3D( 0, 0, 0, 0, 1, jpkm1 ) 296 312 z2d(ji,jj) = z2d(ji,jj) + e3t(ji,jj,jk,Kmm) * ts(ji,jj,jk,jp_sal,Kmm) * tmask(ji,jj,jk) 297 313 END_3D … … 299 315 ENDIF 300 316 ! 301 IF ( iom_use("eken") ) THEN 317 IF( iom_use("salt2c") ) THEN 318 z2d(:,:) = 0._wp 319 DO_3D( 0, 0, 0, 0, 1, jpkm1 ) 320 z2d(ji,jj) = z2d(ji,jj) + e3t(ji,jj,jk,Kmm) * ts(ji,jj,jk,jp_sal,Kmm) * ts(ji,jj,jk,jp_sal,Kmm) * tmask(ji,jj,jk) 321 END_3D 322 CALL iom_put( "salt2c", rho0 * z2d ) ! vertically integrated salt content (PSU*kg/m2) 323 ENDIF 324 ! 325 IF ( iom_use("ke") .OR. iom_use("ke_int") ) THEN 302 326 z3d(:,:,jpk) = 0._wp 303 327 DO_3D( 0, 0, 0, 0, 1, jpkm1 ) 304 zztmp = 0.25_wp * r1_e1e2t(ji,jj) / e3t(ji,jj,jk,Kmm) 305 z3d(ji,jj,jk) = zztmp * ( uu(ji-1,jj,jk,Kmm)**2 * e2u(ji-1,jj) * e3u(ji-1,jj,jk,Kmm) & 306 & + uu(ji ,jj,jk,Kmm)**2 * e2u(ji ,jj) * e3u(ji ,jj,jk,Kmm) & 307 & + vv(ji,jj-1,jk,Kmm)**2 * e1v(ji,jj-1) * e3v(ji,jj-1,jk,Kmm) & 308 & + vv(ji,jj ,jk,Kmm)**2 * e1v(ji,jj ) * e3v(ji,jj ,jk,Kmm) ) 309 END_3D 310 CALL lbc_lnk( 'diawri', z3d, 'T', 1.0_wp ) 311 CALL iom_put( "eken", z3d ) ! kinetic energy 328 zztmpx = 0.5 * ( uu(ji-1,jj ,jk,Kmm) + uu(ji,jj,jk,Kmm) ) 329 zztmpy = 0.5 * ( vv(ji ,jj-1,jk,Kmm) + vv(ji,jj,jk,Kmm) ) 330 z3d(ji,jj,jk) = 0.5 * ( zztmpx*zztmpx + zztmpy*zztmpy ) 331 END_3D 332 CALL iom_put( "ke", z3d ) ! kinetic energy 333 334 z2d(:,:) = 0._wp 335 DO_3D( 0, 0, 0, 0, 1, jpkm1 ) 336 z2d(ji,jj) = z2d(ji,jj) + e3t(ji,jj,jk,Kmm) * z3d(ji,jj,jk) * e1e2t(ji,jj) * tmask(ji,jj,jk) 337 END_3D 338 CALL iom_put( "ke_int", z2d ) ! vertically integrated kinetic energy 312 339 ENDIF 313 340 ! … … 339 366 ! 340 367 CALL iom_put( "hdiv", hdiv ) ! Horizontal divergence 368 369 IF ( iom_use("relvor") .OR. iom_use("absvor") .OR. iom_use("potvor") ) THEN 370 371 z3d(:,:,jpk) = 0._wp 372 DO_3D( 0, 0, 0, 0, 1, jpkm1 ) 373 z3d(ji,jj,jk) = ( e2v(ji+1,jj ) * vv(ji+1,jj ,jk,Kmm) - e2v(ji,jj) * vv(ji,jj,jk,Kmm) & 374 & - e1u(ji ,jj+1) * uu(ji ,jj+1,jk,Kmm) + e1u(ji,jj) * uu(ji,jj,jk,Kmm) ) * r1_e1e2f(ji,jj) 375 END_3D 376 CALL iom_put( "relvor", z3d ) ! relative vorticity 377 378 DO_3D( 0, 0, 0, 0, 1, jpkm1 ) 379 z3d(ji,jj,jk) = ff_f(ji,jj) + z3d(ji,jj,jk) 380 END_3D 381 CALL iom_put( "absvor", z3d ) ! absolute vorticity 382 383 DO_3D( 0, 0, 0, 0, 1, jpkm1 ) 384 ze3 = ( e3t(ji,jj+1,jk,Kmm)*tmask(ji,jj+1,jk) + e3t(ji+1,jj+1,jk,Kmm)*tmask(ji+1,jj+1,jk) & 385 & + e3t(ji,jj ,jk,Kmm)*tmask(ji,jj ,jk) + e3t(ji+1,jj ,jk,Kmm)*tmask(ji+1,jj ,jk) ) 386 IF( ze3 /= 0._wp ) THEN ; ze3 = 4._wp / ze3 387 ELSE ; ze3 = 0._wp 388 ENDIF 389 z3d(ji,jj,jk) = ze3 * z3d(ji,jj,jk) 390 END_3D 391 CALL iom_put( "potvor", z3d ) ! potential vorticity 392 393 ENDIF 341 394 ! 342 395 IF( iom_use("u_masstr") .OR. iom_use("u_masstr_vint") .OR. iom_use("u_heattr") .OR. iom_use("u_salttr") ) THEN … … 356 409 z2d(ji,jj) = z2d(ji,jj) + z3d(ji,jj,jk) * ( ts(ji,jj,jk,jp_tem,Kmm) + ts(ji+1,jj,jk,jp_tem,Kmm) ) 357 410 END_3D 358 CALL lbc_lnk( 'diawri', z2d, 'U', -1.0_wp )359 411 CALL iom_put( "u_heattr", 0.5*rcp * z2d ) ! heat transport in i-direction 360 412 ENDIF … … 365 417 z2d(ji,jj) = z2d(ji,jj) + z3d(ji,jj,jk) * ( ts(ji,jj,jk,jp_sal,Kmm) + ts(ji+1,jj,jk,jp_sal,Kmm) ) 366 418 END_3D 367 CALL lbc_lnk( 'diawri', z2d, 'U', -1.0_wp )368 419 CALL iom_put( "u_salttr", 0.5 * z2d ) ! heat transport in i-direction 369 420 ENDIF … … 383 434 z2d(ji,jj) = z2d(ji,jj) + z3d(ji,jj,jk) * ( ts(ji,jj,jk,jp_tem,Kmm) + ts(ji,jj+1,jk,jp_tem,Kmm) ) 384 435 END_3D 385 CALL lbc_lnk( 'diawri', z2d, 'V', -1.0_wp )386 436 CALL iom_put( "v_heattr", 0.5*rcp * z2d ) ! heat transport in j-direction 387 437 ENDIF … … 392 442 z2d(ji,jj) = z2d(ji,jj) + z3d(ji,jj,jk) * ( ts(ji,jj,jk,jp_sal,Kmm) + ts(ji,jj+1,jk,jp_sal,Kmm) ) 393 443 END_3D 394 CALL lbc_lnk( 'diawri', z2d, 'V', -1.0_wp )395 444 CALL iom_put( "v_salttr", 0.5 * z2d ) ! heat transport in j-direction 396 445 ENDIF … … 401 450 z2d(ji,jj) = z2d(ji,jj) + e3t(ji,jj,jk,Kmm) * ts(ji,jj,jk,jp_tem,Kmm) 402 451 END_3D 403 CALL lbc_lnk( 'diawri', z2d, 'T', -1.0_wp )404 452 CALL iom_put( "tosmint", rho0 * z2d ) ! Vertical integral of temperature 405 453 ENDIF … … 409 457 z2d(ji,jj) = z2d(ji,jj) + e3t(ji,jj,jk,Kmm) * ts(ji,jj,jk,jp_sal,Kmm) 410 458 END_3D 411 CALL lbc_lnk( 'diawri', z2d, 'T', -1.0_wp )412 459 CALL iom_put( "somint", rho0 * z2d ) ! Vertical integral of salinity 413 460 ENDIF -
NEMO/branches/2020/dev_r13327_KERNEL-06_2_techene_e3/src/OCE/DIU/diu_bulk.F90
r13295 r13998 22 22 23 23 ! Namelist parameters 24 LOGICAL, PUBLIC :: ln_diurnal 25 LOGICAL, PUBLIC :: ln_diurnal_only 24 LOGICAL, PUBLIC :: ln_diurnal = .false. ! force definition if diurnal_sst_bulk_init is not called 25 LOGICAL, PUBLIC :: ln_diurnal_only = .false. ! force definition if diurnal_sst_bulk_init is not called 26 26 27 27 ! Parameters -
NEMO/branches/2020/dev_r13327_KERNEL-06_2_techene_e3/src/OCE/DIU/diu_coolskin.F90
r13295 r13998 95 95 !!---------------------------------------------------------------------- 96 96 ! 97 IF( .NOT. ln_blk) CALL ctl_stop("diu_coolskin.f90: diurnal flux processing only implemented for bulk forcing")97 IF( .NOT. (ln_blk .OR. ln_abl) ) CALL ctl_stop("diu_coolskin.f90: diurnal flux processing only implemented for bulk forcing") 98 98 ! 99 99 DO_2D( 1, 1, 1, 1 ) -
NEMO/branches/2020/dev_r13327_KERNEL-06_2_techene_e3/src/OCE/DOM/closea.F90
r13286 r13998 38 38 LOGICAL, PUBLIC :: ln_clo_rnf !: closed sea treated as runoff (update rnf mask) 39 39 40 LOGICAL, PUBLIC :: l_sbc_clo !: T => net evap/precip over closed seas spread outover the globe/river mouth 41 LOGICAL, PUBLIC :: l_clo_rnf !: T => Some closed seas output freshwater (RNF) to specified runoff points. 42 43 INTEGER, PUBLIC :: ncsg !: number of closed seas global mappings (inferred from closea_mask_glo field) 44 INTEGER, PUBLIC :: ncsr !: number of closed seas rnf mappings (inferred from closea_mask_rnf field) 45 INTEGER, PUBLIC :: ncse !: number of closed seas empmr mappings (inferred from closea_mask_emp field) 40 ! WARNING: keep default definitions in the following lines as dom_clo is called only if ln_closea = .true. 41 LOGICAL, PUBLIC :: l_sbc_clo = .FALSE. !: T => net evap/precip over closed seas spread outover the globe/river mouth 42 LOGICAL, PUBLIC :: l_clo_rnf = .FALSE. !: T => Some closed seas output freshwater (RNF) to specified runoff points. 43 44 INTEGER, PUBLIC :: ncsg = 0 !: number of closed seas global mappings (inferred from closea_mask_glo field) 45 INTEGER, PUBLIC :: ncsr = 0 !: number of closed seas rnf mappings (inferred from closea_mask_rnf field) 46 INTEGER, PUBLIC :: ncse = 0 !: number of closed seas empmr mappings (inferred from closea_mask_emp field) 46 47 47 48 INTEGER, PUBLIC, SAVE, ALLOCATABLE, DIMENSION(:,:) :: mask_opnsea, mask_csundef !: mask defining the open sea and the undefined closed sea -
NEMO/branches/2020/dev_r13327_KERNEL-06_2_techene_e3/src/OCE/DOM/daymod.F90
r13286 r13998 82 82 ndt05 = NINT( 0.5 * rn_Dt ) 83 83 84 IF( .NOT. l_offline ) CALL day_rst( nit000, 'READ' ) 85 84 lrst_oce = .NOT. l_offline ! force definition of offline 85 IF( lrst_oce ) CALL day_rst( nit000, 'READ' ) 86 86 87 ! set the calandar from ndastp (read in restart file and namelist) 87 88 nyear = ndastp / 10000 -
NEMO/branches/2020/dev_r13327_KERNEL-06_2_techene_e3/src/OCE/DOM/dom_oce.F90
r13736 r13998 222 222 223 223 !!---------------------------------------------------------------------- 224 !! variable defined here to avoid circular dependencies... 225 !! --------------------------------------------------------------------- 226 INTEGER, PUBLIC :: nbasin ! number of basin to be considered in diaprt (glo, atl, pac, ind, ipc) 227 228 !!---------------------------------------------------------------------- 224 229 !! agrif domain 225 230 !!---------------------------------------------------------------------- -
NEMO/branches/2020/dev_r13327_KERNEL-06_2_techene_e3/src/OCE/DOM/domain.F90
r13914 r13998 257 257 !!---------------------------------------------------------------------- 258 258 ! 259 DO ji = 1, jpi ! local domain indices ==> global domain , including halos, indices259 DO ji = 1, jpi ! local domain indices ==> global domain indices, including halos 260 260 mig(ji) = ji + nimpp - 1 261 261 END DO … … 263 263 mjg(jj) = jj + njmpp - 1 264 264 END DO 265 ! ! local domain indices ==> global domain , excluding halos, indices265 ! ! local domain indices ==> global domain indices, excluding halos 266 266 ! 267 267 mig0(:) = mig(:) - nn_hls … … 568 568 !!---------------------------------------------------------------------- 569 569 ! 570 IF(lk_mpp) THEN 571 CALL mpp_minloc( 'domain', glamt(:,:), tmask_i(:,:), zglmin, imil ) 572 CALL mpp_minloc( 'domain', gphit(:,:), tmask_i(:,:), zgpmin, imip ) 573 CALL mpp_minloc( 'domain', e1t(:,:), tmask_i(:,:), ze1min, imi1 ) 574 CALL mpp_minloc( 'domain', e2t(:,:), tmask_i(:,:), ze2min, imi2 ) 575 CALL mpp_maxloc( 'domain', glamt(:,:), tmask_i(:,:), zglmax, imal ) 576 CALL mpp_maxloc( 'domain', gphit(:,:), tmask_i(:,:), zgpmax, imap ) 577 CALL mpp_maxloc( 'domain', e1t(:,:), tmask_i(:,:), ze1max, ima1 ) 578 CALL mpp_maxloc( 'domain', e2t(:,:), tmask_i(:,:), ze2max, ima2 ) 579 ELSE 580 llmsk = tmask_i(:,:) == 1._wp 581 zglmin = MINVAL( glamt(:,:), mask = llmsk ) 582 zgpmin = MINVAL( gphit(:,:), mask = llmsk ) 583 ze1min = MINVAL( e1t(:,:), mask = llmsk ) 584 ze2min = MINVAL( e2t(:,:), mask = llmsk ) 585 zglmin = MAXVAL( glamt(:,:), mask = llmsk ) 586 zgpmin = MAXVAL( gphit(:,:), mask = llmsk ) 587 ze1max = MAXVAL( e1t(:,:), mask = llmsk ) 588 ze2max = MAXVAL( e2t(:,:), mask = llmsk ) 589 ! 590 imil = MINLOC( glamt(:,:), mask = llmsk ) + (/ nimpp - 1, njmpp - 1 /) 591 imip = MINLOC( gphit(:,:), mask = llmsk ) + (/ nimpp - 1, njmpp - 1 /) 592 imi1 = MINLOC( e1t(:,:), mask = llmsk ) + (/ nimpp - 1, njmpp - 1 /) 593 imi2 = MINLOC( e2t(:,:), mask = llmsk ) + (/ nimpp - 1, njmpp - 1 /) 594 imal = MAXLOC( glamt(:,:), mask = llmsk ) + (/ nimpp - 1, njmpp - 1 /) 595 imap = MAXLOC( gphit(:,:), mask = llmsk ) + (/ nimpp - 1, njmpp - 1 /) 596 ima1 = MAXLOC( e1t(:,:), mask = llmsk ) + (/ nimpp - 1, njmpp - 1 /) 597 ima2 = MAXLOC( e2t(:,:), mask = llmsk ) + (/ nimpp - 1, njmpp - 1 /) 598 ENDIF 570 llmsk = tmask_h(:,:) == 1._wp 571 ! 572 CALL mpp_minloc( 'domain', glamt(:,:), llmsk, zglmin, imil ) 573 CALL mpp_minloc( 'domain', gphit(:,:), llmsk, zgpmin, imip ) 574 CALL mpp_minloc( 'domain', e1t(:,:), llmsk, ze1min, imi1 ) 575 CALL mpp_minloc( 'domain', e2t(:,:), llmsk, ze2min, imi2 ) 576 CALL mpp_maxloc( 'domain', glamt(:,:), llmsk, zglmax, imal ) 577 CALL mpp_maxloc( 'domain', gphit(:,:), llmsk, zgpmax, imap ) 578 CALL mpp_maxloc( 'domain', e1t(:,:), llmsk, ze1max, ima1 ) 579 CALL mpp_maxloc( 'domain', e2t(:,:), llmsk, ze2max, ima2 ) 599 580 ! 600 581 IF(lwp) THEN … … 718 699 ! 719 700 ! !== ORCA family specificities ==! 720 IF( cn_cfg== "ORCA" ) THEN701 IF( TRIM(cn_cfg) == "orca" .OR. TRIM(cn_cfg) == "ORCA" ) THEN 721 702 CALL iom_rstput( 0, 0, inum, 'ORCA' , 1._wp , ktype = jp_i4 ) 722 703 CALL iom_rstput( 0, 0, inum, 'ORCA_index', REAL( nn_cfg, wp), ktype = jp_i4 ) -
NEMO/branches/2020/dev_r13327_KERNEL-06_2_techene_e3/src/OCE/DOM/dommsk.F90
r13736 r13998 92 92 INTEGER :: iktop, ikbot ! - - 93 93 INTEGER :: ios, inum 94 REAL(wp), ALLOCATABLE, DIMENSION(:,:) :: zwf ! 2D workspace95 94 !! 96 95 NAMELIST/namlbc/ rn_shlat, ln_vorlat … … 205 204 IF( rn_shlat /= 0 ) THEN ! Not free-slip lateral boundary condition 206 205 ! 207 ALLOCATE( zwf(jpi,jpj) )208 !209 206 DO jk = 1, jpk 210 zwf(:,:) = fmask(:,:,jk)211 207 DO_2D( 0, 0, 0, 0 ) 212 208 IF( fmask(ji,jj,jk) == 0._wp ) THEN 213 fmask(ji,jj,jk) = rn_shlat * MIN( 1._wp , MAX( zwf(ji+1,jj), zwf(ji,jj+1),&214 & zwf(ji-1,jj), zwf(ji,jj-1) ))209 fmask(ji,jj,jk) = rn_shlat * MIN( 1._wp , MAX( umask(ji,jj,jk), umask(ji,jj+1,jk), & 210 & vmask(ji,jj,jk), vmask(ji+1,jj,jk) ) ) 215 211 ENDIF 216 212 END_2D 217 213 DO jj = 2, jpjm1 218 214 IF( fmask(1,jj,jk) == 0._wp ) THEN 219 fmask(1 ,jj,jk) = rn_shlat * MIN( 1._wp , MAX( zwf(2,jj), zwf(1,jj+1), zwf(1,jj-1) ) )215 fmask(1 ,jj,jk) = rn_shlat * MIN( 1._wp , MAX( vmask(2,jj,jk), umask(1,jj+1,jk), umask(1,jj,jk) ) ) 220 216 ENDIF 221 217 IF( fmask(jpi,jj,jk) == 0._wp ) THEN 222 fmask(jpi,jj,jk) = rn_shlat * MIN( 1._wp , MAX( zwf(jpi,jj+1), zwf(jpim1,jj), zwf(jpi,jj-1) ) )218 fmask(jpi,jj,jk) = rn_shlat * MIN( 1._wp , MAX( umask(jpi,jj+1,jk), vmask(jpim1,jj,jk), umask(jpi,jj-1,jk) ) ) 223 219 ENDIF 224 220 END DO 225 221 DO ji = 2, jpim1 226 222 IF( fmask(ji,1,jk) == 0._wp ) THEN 227 fmask(ji, 1 ,jk) = rn_shlat * MIN( 1._wp , MAX( zwf(ji+1,1), zwf(ji,2), zwf(ji-1,1) ) )223 fmask(ji, 1 ,jk) = rn_shlat * MIN( 1._wp , MAX( vmask(ji+1,1,jk), umask(ji,2,jk), vmask(ji,1,jk) ) ) 228 224 ENDIF 229 225 IF( fmask(ji,jpj,jk) == 0._wp ) THEN 230 fmask(ji,jpj,jk) = rn_shlat * MIN( 1._wp , MAX( zwf(ji+1,jpj), zwf(ji-1,jpj), zwf(ji,jpjm1) ) )226 fmask(ji,jpj,jk) = rn_shlat * MIN( 1._wp , MAX( vmask(ji+1,jpj,jk), vmask(ji-1,jpj,jk), umask(ji,jpjm1,jk) ) ) 231 227 ENDIF 232 228 END DO 233 229 END DO 234 !235 DEALLOCATE( zwf )236 230 ! 237 231 CALL lbc_lnk( 'dommsk', fmask, 'F', 1._wp ) ! Lateral boundary conditions on fmask -
NEMO/branches/2020/dev_r13327_KERNEL-06_2_techene_e3/src/OCE/DOM/domutl.F90
r13286 r13998 48 48 INTEGER , DIMENSION(2) :: iloc 49 49 REAL(wp) :: zlon, zmini 50 REAL(wp), DIMENSION(jpi,jpj) :: zglam, zgphi, zmask, zdist 50 REAL(wp), DIMENSION(jpi,jpj) :: zglam, zgphi, zdist 51 LOGICAL , DIMENSION(jpi,jpj) :: llmsk 51 52 !!-------------------------------------------------------------------- 52 53 ! … … 54 55 IF ( PRESENT(kkk) ) ik=kkk 55 56 ! 56 CALL dom_uniq(zmask,cdgrid)57 !58 57 SELECT CASE( cdgrid ) 59 CASE( 'U' ) ; zglam(:,:) = glamu(:,:) ; zgphi(:,:) = gphiu(:,:) ; zmask(:,:) = zmask(:,:) * umask(:,:,ik)60 CASE( 'V' ) ; zglam(:,:) = glamv(:,:) ; zgphi(:,:) = gphiv(:,:) ; zmask(:,:) = zmask(:,:) * vmask(:,:,ik)61 CASE( 'F' ) ; zglam(:,:) = glamf(:,:) ; zgphi(:,:) = gphif(:,:) ; zmask(:,:) = zmask(:,:) * fmask(:,:,ik)62 CASE DEFAULT ; zglam(:,:) = glamt(:,:) ; zgphi(:,:) = gphit(:,:) ; zmask(:,:) = zmask(:,:) * tmask(:,:,ik)58 CASE( 'U' ) ; zglam(:,:) = glamu(:,:) ; zgphi(:,:) = gphiu(:,:) ; llmsk(:,:) = tmask_h(:,:) * umask(:,:,ik) == 1._wp 59 CASE( 'V' ) ; zglam(:,:) = glamv(:,:) ; zgphi(:,:) = gphiv(:,:) ; llmsk(:,:) = tmask_h(:,:) * vmask(:,:,ik) == 1._wp 60 CASE( 'F' ) ; zglam(:,:) = glamf(:,:) ; zgphi(:,:) = gphif(:,:) ; llmsk(:,:) = tmask_h(:,:) * fmask(:,:,ik) == 1._wp 61 CASE DEFAULT; zglam(:,:) = glamt(:,:) ; zgphi(:,:) = gphit(:,:) ; llmsk(:,:) = tmask_h(:,:) * tmask(:,:,ik) == 1._wp 63 62 END SELECT 64 63 ! … … 68 67 IF( zlon < 90. ) WHERE( zglam(:,:) > 180. ) zglam(:,:) = zglam(:,:) - 360. ! glam between -180 and 180 69 68 zglam(:,:) = zglam(:,:) - zlon 70 69 ! 71 70 zgphi(:,:) = zgphi(:,:) - plat 72 71 zdist(:,:) = zglam(:,:) * zglam(:,:) + zgphi(:,:) * zgphi(:,:) 73 74 IF( lk_mpp ) THEN 75 CALL mpp_minloc( 'domngb', zdist(:,:), zmask, zmini, iloc) 76 kii = iloc(1) ; kjj = iloc(2) 77 ELSE 78 iloc(:) = MINLOC( zdist(:,:), mask = zmask(:,:) == 1.e0 ) 79 kii = iloc(1) + nimpp - 1 80 kjj = iloc(2) + njmpp - 1 81 ENDIF 72 ! 73 CALL mpp_minloc( 'domngb', zdist(:,:), llmsk, zmini, iloc, ldhalo = .TRUE. ) 74 kii = iloc(1) 75 kjj = iloc(2) 82 76 ! 83 77 END SUBROUTINE dom_ngb -
NEMO/branches/2020/dev_r13327_KERNEL-06_2_techene_e3/src/OCE/DOM/domvvl.F90
r13895 r13998 202 202 gdept(:,:,1,Kbb) = 0.5_wp * e3w(:,:,1,Kbb) 203 203 gdepw(:,:,1,Kbb) = 0.0_wp 204 DO_3D( 1, 1, 1, 1, 2, jpk ) 204 DO_3D( 1, 1, 1, 1, 2, jpk ) ! vertical sum 205 205 ! zcoef = tmask - wmask ! 0 everywhere tmask = wmask, ie everywhere expect at jk = mikt 206 206 ! ! 1 everywhere from mbkt to mikt + 1 or 1 (if no isf) … … 334 334 LOGICAL :: ll_do_bclinic ! local logical 335 335 REAL(wp), DIMENSION(jpi,jpj) :: zht, z_scale, zwu, zwv, zhdiv 336 REAL(wp), DIMENSION(jpi,jpj,jpk) :: ze3t 336 REAL(wp), DIMENSION(:,:,:), ALLOCATABLE :: ze3t 337 LOGICAL , DIMENSION(:,:,:), ALLOCATABLE :: llmsk 337 338 !!---------------------------------------------------------------------- 338 339 ! … … 419 420 zwu(:,:) = 0._wp 420 421 zwv(:,:) = 0._wp 421 DO_3D( 1, 0, 1, 0, 1, jpkm1 ) 422 DO_3D( 1, 0, 1, 0, 1, jpkm1 ) ! a - first derivative: diffusive fluxes 422 423 un_td(ji,jj,jk) = rn_ahe3 * umask(ji,jj,jk) * e2_e1u(ji,jj) & 423 424 & * ( tilde_e3t_b(ji,jj,jk) - tilde_e3t_b(ji+1,jj ,jk) ) … … 427 428 zwv(ji,jj) = zwv(ji,jj) + vn_td(ji,jj,jk) 428 429 END_3D 429 DO_2D( 1, 1, 1, 1 ) 430 DO_2D( 1, 1, 1, 1 ) ! b - correction for last oceanic u-v points 430 431 un_td(ji,jj,mbku(ji,jj)) = un_td(ji,jj,mbku(ji,jj)) - zwu(ji,jj) 431 432 vn_td(ji,jj,mbkv(ji,jj)) = vn_td(ji,jj,mbkv(ji,jj)) - zwv(ji,jj) 432 433 END_2D 433 DO_3D( 0, 0, 0, 0, 1, jpkm1 ) 434 DO_3D( 0, 0, 0, 0, 1, jpkm1 ) ! c - second derivative: divergence of diffusive fluxes 434 435 tilde_e3t_a(ji,jj,jk) = tilde_e3t_a(ji,jj,jk) + ( un_td(ji-1,jj ,jk) - un_td(ji,jj,jk) & 435 436 & + vn_td(ji ,jj-1,jk) - vn_td(ji,jj,jk) & 436 437 & ) * r1_e1e2t(ji,jj) 437 438 END_3D 438 ! ! d - thickness diffusion transport: boundary conditions439 ! ! d - thickness diffusion transport: boundary conditions 439 440 ! (stored for tracer advction and continuity equation) 440 441 CALL lbc_lnk_multi( 'domvvl', un_td , 'U' , -1._wp, vn_td , 'V' , -1._wp) … … 447 448 ! Maximum deformation control 448 449 ! ~~~~~~~~~~~~~~~~~~~~~~~~~~~ 449 ze3t(:,:,jpk) = 0._wp 450 DO jk = 1, jpkm1 451 ze3t(:,:,jk) = tilde_e3t_a(:,:,jk) / e3t_0(:,:,jk) * tmask(:,:,jk) * tmask_i(:,:) 452 END DO 453 z_tmax = MAXVAL( ze3t(:,:,:) ) 454 CALL mpp_max( 'domvvl', z_tmax ) ! max over the global domain 455 z_tmin = MINVAL( ze3t(:,:,:) ) 456 CALL mpp_min( 'domvvl', z_tmin ) ! min over the global domain 450 ALLOCATE( ze3t(jpi,jpj,jpk), llmsk(jpi,jpj,jpk) ) 451 DO_3D( 0, 0, 0, 0, 1, jpkm1 ) 452 ze3t(ji,jj,jk) = tilde_e3t_a(ji,jj,jk) / e3t_0(ji,jj,jk) * tmask(ji,jj,jk) * tmask_i(ji,jj) 453 END_3D 454 ! 455 llmsk( 1:Nis1,:,:) = .FALSE. ! exclude halos from the checked region 456 llmsk(Nie1: jpi,:,:) = .FALSE. 457 llmsk(:, 1:Njs1,:) = .FALSE. 458 llmsk(:,Nje1: jpj,:) = .FALSE. 459 ! 460 llmsk(Nis0:Nie0,Njs0:Nje0,:) = tmask(Nis0:Nie0,Njs0:Nje0,:) == 1._wp ! define only the inner domain 461 z_tmax = MAXVAL( ze3t(:,:,:), mask = llmsk ) ; CALL mpp_max( 'domvvl', z_tmax ) ! max over the global domain 462 z_tmin = MINVAL( ze3t(:,:,:), mask = llmsk ) ; CALL mpp_min( 'domvvl', z_tmin ) ! min over the global domain 457 463 ! - ML - test: for the moment, stop simulation for too large e3_t variations 458 464 IF( ( z_tmax > rn_zdef_max ) .OR. ( z_tmin < - rn_zdef_max ) ) THEN 459 IF( lk_mpp ) THEN 460 CALL mpp_maxloc( 'domvvl', ze3t, tmask, z_tmax, ijk_max ) 461 CALL mpp_minloc( 'domvvl', ze3t, tmask, z_tmin, ijk_min ) 462 ELSE 463 ijk_max = MAXLOC( ze3t(:,:,:) ) 464 ijk_max(1) = ijk_max(1) + nimpp - 1 465 ijk_max(2) = ijk_max(2) + njmpp - 1 466 ijk_min = MINLOC( ze3t(:,:,:) ) 467 ijk_min(1) = ijk_min(1) + nimpp - 1 468 ijk_min(2) = ijk_min(2) + njmpp - 1 469 ENDIF 465 CALL mpp_maxloc( 'domvvl', ze3t, llmsk, z_tmax, ijk_max ) 466 CALL mpp_minloc( 'domvvl', ze3t, llmsk, z_tmin, ijk_min ) 470 467 IF (lwp) THEN 471 468 WRITE(numout, *) 'MAX( tilde_e3t_a(:,:,:) / e3t_0(:,:,:) ) =', z_tmax … … 476 473 ENDIF 477 474 ENDIF 475 DEALLOCATE( ze3t, llmsk ) 478 476 ! - ML - end test 479 477 ! - ML - Imposing these limits will cause a baroclinicity error which is corrected for below -
NEMO/branches/2020/dev_r13327_KERNEL-06_2_techene_e3/src/OCE/DOM/dtatsd.F90
r13295 r13998 186 186 ENDIF 187 187 ! 188 DO_2D( 1, 1, 1, 1 ) 188 DO_2D( 1, 1, 1, 1 ) ! vertical interpolation of T & S 189 189 DO jk = 1, jpk ! determines the intepolated T-S profiles at each (i,j) points 190 190 zl = gdept_0(ji,jj,jk) -
NEMO/branches/2020/dev_r13327_KERNEL-06_2_techene_e3/src/OCE/DYN/divhor.F90
r13295 r13998 77 77 ENDIF 78 78 ! 79 DO_3D( 0, 0, 0, 0, 1, jpkm1 ) 80 hdiv(ji,jj,jk) = ( e2u(ji ,jj) * e3u(ji ,jj,jk,Kmm) * uu(ji ,jj,jk,Kmm) &79 DO_3D( 0, 0, 0, 0, 1, jpkm1 ) !== Horizontal divergence ==! 80 hdiv(ji,jj,jk) = ( e2u(ji ,jj) * e3u(ji ,jj,jk,Kmm) * uu(ji ,jj,jk,Kmm) & 81 81 & - e2u(ji-1,jj) * e3u(ji-1,jj,jk,Kmm) * uu(ji-1,jj,jk,Kmm) & 82 82 & + e1v(ji,jj ) * e3v(ji,jj ,jk,Kmm) * vv(ji,jj ,jk,Kmm) & -
NEMO/branches/2020/dev_r13327_KERNEL-06_2_techene_e3/src/OCE/DYN/dynadv_cen2.F90
r13295 r13998 72 72 zfu(:,:,jk) = 0.25_wp * e2u(:,:) * e3u(:,:,jk,Kmm) * puu(:,:,jk,Kmm) 73 73 zfv(:,:,jk) = 0.25_wp * e1v(:,:) * e3v(:,:,jk,Kmm) * pvv(:,:,jk,Kmm) 74 DO_2D( 1, 0, 1, 0 ) 74 DO_2D( 1, 0, 1, 0 ) ! horizontal momentum fluxes (at T- and F-point) 75 75 zfu_t(ji+1,jj ,jk) = ( zfu(ji,jj,jk) + zfu(ji+1,jj,jk) ) * ( puu(ji,jj,jk,Kmm) + puu(ji+1,jj ,jk,Kmm) ) 76 76 zfv_f(ji ,jj ,jk) = ( zfv(ji,jj,jk) + zfv(ji+1,jj,jk) ) * ( puu(ji,jj,jk,Kmm) + puu(ji ,jj+1,jk,Kmm) ) … … 78 78 zfv_t(ji ,jj+1,jk) = ( zfv(ji,jj,jk) + zfv(ji,jj+1,jk) ) * ( pvv(ji,jj,jk,Kmm) + pvv(ji ,jj+1,jk,Kmm) ) 79 79 END_2D 80 DO_2D( 0, 0, 0, 0 ) 80 DO_2D( 0, 0, 0, 0 ) ! divergence of horizontal momentum fluxes 81 81 puu(ji,jj,jk,Krhs) = puu(ji,jj,jk,Krhs) - ( zfu_t(ji+1,jj,jk) - zfu_t(ji,jj ,jk) & 82 82 & + zfv_f(ji ,jj,jk) - zfv_f(ji,jj-1,jk) ) * r1_e1e2u(ji,jj) & … … 98 98 ! !== Vertical advection ==! 99 99 ! 100 DO_2D( 0, 0, 0, 0 ) 100 DO_2D( 0, 0, 0, 0 ) ! surface/bottom advective fluxes set to zero 101 101 zfu_uw(ji,jj,jpk) = 0._wp ; zfv_vw(ji,jj,jpk) = 0._wp 102 102 zfu_uw(ji,jj, 1 ) = 0._wp ; zfv_vw(ji,jj, 1 ) = 0._wp … … 109 109 ENDIF 110 110 DO jk = 2, jpkm1 ! interior advective fluxes 111 DO_2D( 0, 1, 0, 1 ) 111 DO_2D( 0, 1, 0, 1 ) ! 1/4 * Vertical transport 112 112 zfw(ji,jj,jk) = 0.25_wp * e1e2t(ji,jj) * ww(ji,jj,jk) 113 113 END_2D … … 117 117 END_2D 118 118 END DO 119 DO_3D( 0, 0, 0, 0, 1, jpkm1 ) 119 DO_3D( 0, 0, 0, 0, 1, jpkm1 ) ! divergence of vertical momentum flux divergence 120 120 puu(ji,jj,jk,Krhs) = puu(ji,jj,jk,Krhs) - ( zfu_uw(ji,jj,jk) - zfu_uw(ji,jj,jk+1) ) * r1_e1e2u(ji,jj) & 121 121 & / e3u(ji,jj,jk,Kmm) -
NEMO/branches/2020/dev_r13327_KERNEL-06_2_techene_e3/src/OCE/DYN/dynadv_ubs.F90
r13295 r13998 108 108 zfv(:,:,jk) = e1v(:,:) * e3v(:,:,jk,Kmm) * pvv(:,:,jk,Kmm) 109 109 ! 110 DO_2D( 0, 0, 0, 0 ) 110 DO_2D( 0, 0, 0, 0 ) ! laplacian 111 111 zlu_uu(ji,jj,jk,1) = ( puu (ji+1,jj ,jk,Kbb) - 2.*puu (ji,jj,jk,Kbb) + puu (ji-1,jj ,jk,Kbb) ) * umask(ji,jj,jk) 112 112 zlv_vv(ji,jj,jk,1) = ( pvv (ji ,jj+1,jk,Kbb) - 2.*pvv (ji,jj,jk,Kbb) + pvv (ji ,jj-1,jk,Kbb) ) * vmask(ji,jj,jk) … … 136 136 zfv(:,:,jk) = 0.25_wp * e1v(:,:) * e3v(:,:,jk,Kmm) * pvv(:,:,jk,Kmm) 137 137 ! 138 DO_2D( 1, 0, 1, 0 ) 138 DO_2D( 1, 0, 1, 0 ) ! horizontal momentum fluxes at T- and F-point 139 139 zui = ( puu(ji,jj,jk,Kmm) + puu(ji+1,jj ,jk,Kmm) ) 140 140 zvj = ( pvv(ji,jj,jk,Kmm) + pvv(ji ,jj+1,jk,Kmm) ) … … 168 168 & * ( pvv(ji,jj,jk,Kmm) + pvv(ji+1,jj ,jk,Kmm) - gamma1 * zl_v ) 169 169 END_2D 170 DO_2D( 0, 0, 0, 0 ) 170 DO_2D( 0, 0, 0, 0 ) ! divergence of horizontal momentum fluxes 171 171 puu(ji,jj,jk,Krhs) = puu(ji,jj,jk,Krhs) - ( zfu_t(ji+1,jj,jk) - zfu_t(ji,jj ,jk) & 172 172 & + zfv_f(ji ,jj,jk) - zfv_f(ji,jj-1,jk) ) * r1_e1e2u(ji,jj) & … … 187 187 ! ! Vertical advection ! 188 188 ! ! ==================== ! 189 DO_2D( 0, 0, 0, 0 ) 189 DO_2D( 0, 0, 0, 0 ) ! surface/bottom advective fluxes set to zero 190 190 zfu_uw(ji,jj,jpk) = 0._wp 191 191 zfv_vw(ji,jj,jpk) = 0._wp … … 208 208 END_2D 209 209 END DO 210 DO_3D( 0, 0, 0, 0, 1, jpkm1 ) 210 DO_3D( 0, 0, 0, 0, 1, jpkm1 ) ! divergence of vertical momentum flux divergence 211 211 puu(ji,jj,jk,Krhs) = puu(ji,jj,jk,Krhs) - ( zfu_uw(ji,jj,jk) - zfu_uw(ji,jj,jk+1) ) * r1_e1e2u(ji,jj) & 212 212 & / e3u(ji,jj,jk,Kmm) -
NEMO/branches/2020/dev_r13327_KERNEL-06_2_techene_e3/src/OCE/DYN/dynatf.F90
r13295 r13998 34 34 USE dynspg_ts ! surface pressure gradient: split-explicit scheme 35 35 USE domvvl ! variable volume 36 USE bdy_oce , ONLY: ln_bdy36 USE bdy_oce , ONLY : ln_bdy 37 37 USE bdydta ! ocean open boundary conditions 38 38 USE bdydyn ! ocean open boundary conditions … … 50 50 USE prtctl ! Print control 51 51 USE timing ! Timing 52 USE zdfdrg , ONLY : ln_drgice_imp, rCdU_top 52 53 #if defined key_agrif 53 54 USE agrif_oce_interp … … 120 121 REAL(wp) :: zve3a, zve3n, zve3b, z1_2dt ! - - 121 122 REAL(wp), ALLOCATABLE, DIMENSION(:,:) :: zue, zve, zwfld 123 REAL(wp), ALLOCATABLE, DIMENSION(:,:) :: zutau, zvtau 122 124 REAL(wp), ALLOCATABLE, DIMENSION(:,:,:) :: ze3t_f, ze3u_f, ze3v_f, zua, zva 123 125 !!---------------------------------------------------------------------- … … 321 323 ENDIF 322 324 ! 325 IF ( iom_use("utau") ) THEN 326 IF ( ln_drgice_imp.OR.ln_isfcav ) THEN 327 ALLOCATE(zutau(jpi,jpj)) 328 DO_2D( 0, 0, 0, 0 ) 329 jk = miku(ji,jj) 330 zutau(ji,jj) = utau(ji,jj) + 0.5_wp * rho0 * ( rCdU_top(ji+1,jj)+rCdU_top(ji,jj) ) * puu(ji,jj,jk,Kaa) 331 END_2D 332 CALL iom_put( "utau", zutau(:,:) ) 333 DEALLOCATE(zutau) 334 ELSE 335 CALL iom_put( "utau", utau(:,:) ) 336 ENDIF 337 ENDIF 338 ! 339 IF ( iom_use("vtau") ) THEN 340 IF ( ln_drgice_imp.OR.ln_isfcav ) THEN 341 ALLOCATE(zvtau(jpi,jpj)) 342 DO_2D( 0, 0, 0, 0 ) 343 jk = mikv(ji,jj) 344 zvtau(ji,jj) = vtau(ji,jj) + 0.5_wp * rho0 * ( rCdU_top(ji,jj+1)+rCdU_top(ji,jj) ) * pvv(ji,jj,jk,Kaa) 345 END_2D 346 CALL iom_put( "vtau", zvtau(:,:) ) 347 DEALLOCATE(zvtau) 348 ELSE 349 CALL iom_put( "vtau", vtau(:,:) ) 350 ENDIF 351 ENDIF 352 ! 323 353 IF(sn_cfctl%l_prtctl) CALL prt_ctl( tab3d_1=puu(:,:,:,Kaa), clinfo1=' nxt - puu(:,:,:,Kaa): ', mask1=umask, & 324 354 & tab3d_2=pvv(:,:,:,Kaa), clinfo2=' pvv(:,:,:,Kaa): ' , mask2=vmask ) -
NEMO/branches/2020/dev_r13327_KERNEL-06_2_techene_e3/src/OCE/DYN/dynkeg.F90
r13295 r13998 125 125 END SELECT 126 126 ! 127 DO_3D( 0, 0, 0, 0, 1, jpkm1 ) 127 DO_3D( 0, 0, 0, 0, 1, jpkm1 ) !== grad( KE ) added to the general momentum trends ==! 128 128 puu(ji,jj,jk,Krhs) = puu(ji,jj,jk,Krhs) - ( zhke(ji+1,jj ,jk) - zhke(ji,jj,jk) ) / e1u(ji,jj) 129 129 pvv(ji,jj,jk,Krhs) = pvv(ji,jj,jk,Krhs) - ( zhke(ji ,jj+1,jk) - zhke(ji,jj,jk) ) / e2v(ji,jj) -
NEMO/branches/2020/dev_r13327_KERNEL-06_2_techene_e3/src/OCE/DYN/dynldf_iso.F90
r13295 r13998 128 128 IF( ln_dynldf_hor .AND. ln_traldf_iso ) THEN 129 129 ! 130 DO_3D( 0, 0, 0, 0, 1, jpk ) 130 DO_3D( 0, 0, 0, 0, 1, jpk ) ! set the slopes of iso-level 131 131 uslp (ji,jj,jk) = - ( gdept(ji+1,jj,jk,Kbb) - gdept(ji ,jj ,jk,Kbb) ) * r1_e1u(ji,jj) * umask(ji,jj,jk) 132 132 vslp (ji,jj,jk) = - ( gdept(ji,jj+1,jk,Kbb) - gdept(ji ,jj ,jk,Kbb) ) * r1_e2v(ji,jj) * vmask(ji,jj,jk) … … 268 268 ! Second derivative (divergence) and add to the general trend 269 269 ! ----------------------------------------------------------- 270 DO_2D( 0, 0, 0, 0 ) 270 DO_2D( 0, 0, 0, 0 ) !!gm Question vectop possible??? !!bug 271 271 puu(ji,jj,jk,Krhs) = puu(ji,jj,jk,Krhs) + ( ziut(ji+1,jj) - ziut(ji,jj ) & 272 272 & + zjuf(ji ,jj) - zjuf(ji,jj-1) ) * r1_e1e2u(ji,jj) & -
NEMO/branches/2020/dev_r13327_KERNEL-06_2_techene_e3/src/OCE/DYN/dynldf_lap_blp.F90
r13513 r13998 94 94 END_2D 95 95 ! 96 DO_2D( 0, 0, 0, 0 ) 96 DO_2D( 0, 0, 0, 0 ) ! - curl( curl) + grad( div ) 97 97 pu_rhs(ji,jj,jk) = pu_rhs(ji,jj,jk) + zsign * umask(ji,jj,jk) * ( & ! * by umask is mandatory for dyn_ldf_blp use 98 98 & - ( zcur(ji ,jj) - zcur(ji,jj-1) ) * r1_e2u(ji,jj) / e3u(ji,jj,jk,Kmm) & -
NEMO/branches/2020/dev_r13327_KERNEL-06_2_techene_e3/src/OCE/DYN/dynspg.F90
r13295 r13998 102 102 IF( ln_apr_dyn .AND. .NOT.ln_dynspg_ts ) THEN !== Atmospheric pressure gradient (added later in time-split case) ==! 103 103 zg_2 = grav * 0.5 104 DO_2D( 0, 0, 0, 0 ) 104 DO_2D( 0, 0, 0, 0 ) ! gradient of Patm using inverse barometer ssh 105 105 spgu(ji,jj) = spgu(ji,jj) + zg_2 * ( ssh_ib (ji+1,jj) - ssh_ib (ji,jj) & 106 106 & + ssh_ibb(ji+1,jj) - ssh_ibb(ji,jj) ) * r1_e1u(ji,jj) … … 117 117 CALL upd_tide(zt0step, Kmm) 118 118 ! 119 DO_2D( 0, 0, 0, 0 ) 119 DO_2D( 0, 0, 0, 0 ) ! add tide potential forcing 120 120 spgu(ji,jj) = spgu(ji,jj) + grav * ( pot_astro(ji+1,jj) - pot_astro(ji,jj) ) * r1_e1u(ji,jj) 121 121 spgv(ji,jj) = spgv(ji,jj) + grav * ( pot_astro(ji,jj+1) - pot_astro(ji,jj) ) * r1_e2v(ji,jj) … … 124 124 IF (ln_scal_load) THEN 125 125 zld = rn_scal_load * grav 126 DO_2D( 0, 0, 0, 0 ) 126 DO_2D( 0, 0, 0, 0 ) ! add scalar approximation for load potential 127 127 spgu(ji,jj) = spgu(ji,jj) + zld * ( pssh(ji+1,jj,Kmm) - pssh(ji,jj,Kmm) ) * r1_e1u(ji,jj) 128 128 spgv(ji,jj) = spgv(ji,jj) + zld * ( pssh(ji,jj+1,Kmm) - pssh(ji,jj,Kmm) ) * r1_e2v(ji,jj) … … 143 143 ENDIF 144 144 ! 145 DO_3D( 0, 0, 0, 0, 1, jpkm1 ) 145 DO_3D( 0, 0, 0, 0, 1, jpkm1 ) !== Add all terms to the general trend 146 146 puu(ji,jj,jk,Krhs) = puu(ji,jj,jk,Krhs) + spgu(ji,jj) 147 147 pvv(ji,jj,jk,Krhs) = pvv(ji,jj,jk,Krhs) + spgv(ji,jj) -
NEMO/branches/2020/dev_r13327_KERNEL-06_2_techene_e3/src/OCE/DYN/dynspg_exp.F90
r13295 r13998 74 74 IF( ln_linssh ) THEN !* linear free surface : add the surface pressure gradient trend 75 75 ! 76 DO_2D( 0, 0, 0, 0 ) 76 DO_2D( 0, 0, 0, 0 ) ! now surface pressure gradient 77 77 spgu(ji,jj) = - grav * ( ssh(ji+1,jj,Kmm) - ssh(ji,jj,Kmm) ) * r1_e1u(ji,jj) 78 78 spgv(ji,jj) = - grav * ( ssh(ji,jj+1,Kmm) - ssh(ji,jj,Kmm) ) * r1_e2v(ji,jj) 79 79 END_2D 80 80 ! 81 DO_3D( 0, 0, 0, 0, 1, jpkm1 ) 81 DO_3D( 0, 0, 0, 0, 1, jpkm1 ) ! Add it to the general trend 82 82 puu(ji,jj,jk,Krhs) = puu(ji,jj,jk,Krhs) + spgu(ji,jj) 83 83 pvv(ji,jj,jk,Krhs) = pvv(ji,jj,jk,Krhs) + spgv(ji,jj) -
NEMO/branches/2020/dev_r13327_KERNEL-06_2_techene_e3/src/OCE/DYN/dynspg_ts.F90
r13895 r13998 264 264 IF( ln_wd_il ) THEN ! W/D : limiter applied to spgspg 265 265 CALL wad_spg( pssh(:,:,Kmm), zcpx, zcpy ) ! Calculating W/D gravity filters, zcpx and zcpy 266 DO_2D( 0, 0, 0, 0 ) 266 DO_2D( 0, 0, 0, 0 ) ! SPG with the application of W/D gravity filters 267 267 zu_trd(ji,jj) = zu_trd(ji,jj) - grav * ( pssh(ji+1,jj ,Kmm) - pssh(ji ,jj ,Kmm) ) & 268 268 & * r1_e1u(ji,jj) * zcpx(ji,jj) * wdrampu(ji,jj) !jth … … 279 279 ENDIF 280 280 ! 281 DO_2D( 0, 0, 0, 0 ) 281 DO_2D( 0, 0, 0, 0 ) ! Remove coriolis term (and possibly spg) from barotropic trend 282 282 zu_frc(ji,jj) = zu_frc(ji,jj) - zu_trd(ji,jj) * ssumask(ji,jj) 283 283 zv_frc(ji,jj) = zv_frc(ji,jj) - zv_trd(ji,jj) * ssvmask(ji,jj) … … 477 477 #if defined key_qcoTest_FluxForm 478 478 ! ! 'key_qcoTest_FluxForm' : simple ssh average 479 DO_2D( 1, 1, 1, 0 ) 479 DO_2D( 1, 1, 1, 0 ) ! not jpi-column 480 480 zhup2_e(ji,jj) = hu_0(ji,jj) + r1_2 * ( zsshp2_e(ji,jj) + zsshp2_e(ji+1,jj ) ) * ssumask(ji,jj) 481 481 END_2D … … 485 485 #else 486 486 ! ! no 'key_qcoTest_FluxForm' : surface weighted ssh average 487 DO_2D( 1, 1, 1, 0 ) 487 DO_2D( 1, 1, 1, 0 ) ! not jpi-column 488 488 zhup2_e(ji,jj) = hu_0(ji,jj) + r1_2 * r1_e1e2u(ji,jj) & 489 489 & * ( e1e2t(ji ,jj) * zsshp2_e(ji ,jj) & 490 490 & + e1e2t(ji+1,jj) * zsshp2_e(ji+1,jj) ) * ssumask(ji,jj) 491 491 END_2D 492 DO_2D( 1, 0, 1, 1 ) 492 DO_2D( 1, 0, 1, 1 ) ! not jpj-row 493 493 zhvp2_e(ji,jj) = hv_0(ji,jj) + r1_2 * r1_e1e2v(ji,jj) & 494 494 & * ( e1e2t(ji,jj ) * zsshp2_e(ji,jj ) & … … 950 950 CALL iom_get( numror, jpdom_auto, 'ub2_i_b' , ub2_i_b(:,:), cd_type = 'U', psgn = -1._wp, ldxios = lrxios ) 951 951 CALL iom_get( numror, jpdom_auto, 'vb2_i_b' , vb2_i_b(:,:), cd_type = 'V', psgn = -1._wp, ldxios = lrxios ) 952 ELSE 953 ub2_i_b(:,:) = 0._wp ; vb2_i_b(:,:) = 0._wp ! used in the 1st update of agrif 952 954 ENDIF 953 955 #endif … … 955 957 IF(lwp) WRITE(numout,*) 956 958 IF(lwp) WRITE(numout,*) ' ==>>> start from rest: set barotropic values to 0' 957 ub2_b (:,:) = 0._wp ; vb2_b(:,:) = 0._wp ! used in the 1st interpol of agrif958 un_adv (:,:) = 0._wp ; vn_adv(:,:) = 0._wp ! used in the 1st interpol of agrif959 un_bf (:,:) = 0._wp ; vn_bf(:,:) = 0._wp ! used in the 1st update of agrif959 ub2_b (:,:) = 0._wp ; vb2_b (:,:) = 0._wp ! used in the 1st interpol of agrif 960 un_adv (:,:) = 0._wp ; vn_adv (:,:) = 0._wp ! used in the 1st interpol of agrif 961 un_bf (:,:) = 0._wp ; vn_bf (:,:) = 0._wp ! used in the 1st update of agrif 960 962 #if defined key_agrif 961 IF ( .NOT.Agrif_Root() ) THEN 962 ub2_i_b(:,:) = 0._wp ; vb2_i_b(:,:) = 0._wp ! used in the 1st update of agrif 963 ENDIF 963 ub2_i_b(:,:) = 0._wp ; vb2_i_b(:,:) = 0._wp ! used in the 1st update of agrif 964 964 #endif 965 965 ENDIF … … 1295 1295 !!---------------------------------------------------------------------- 1296 1296 ! 1297 DO_2D( 1, 1, 1, 0 ) 1297 DO_2D( 1, 1, 1, 0 ) ! not jpi-column 1298 1298 IF ( phU(ji,jj) > 0._wp ) THEN ; pUmsk(ji,jj) = pTmsk(ji ,jj) 1299 1299 ELSE ; pUmsk(ji,jj) = pTmsk(ji+1,jj) … … 1303 1303 END_2D 1304 1304 ! 1305 DO_2D( 1, 0, 1, 1 ) 1305 DO_2D( 1, 0, 1, 1 ) ! not jpj-row 1306 1306 IF ( phV(ji,jj) > 0._wp ) THEN ; pVmsk(ji,jj) = pTmsk(ji,jj ) 1307 1307 ELSE ; pVmsk(ji,jj) = pTmsk(ji,jj+1) … … 1391 1391 ! !== Set the barotropic drag coef. ==! 1392 1392 ! 1393 IF( ln_isfcav ) THEN ! top+bottom friction (ocean cavities)1393 IF( ln_isfcav.OR.ln_drgice_imp ) THEN ! top+bottom friction (ocean cavities) 1394 1394 1395 1395 DO_2D( 0, 0, 0, 0 ) … … 1442 1442 ! !== TOP stress contribution from baroclinic velocities ==! (no W/D case) 1443 1443 ! 1444 IF( ln_isfcav ) THEN1444 IF( ln_isfcav.OR.ln_drgice_imp ) THEN 1445 1445 ! 1446 1446 IF( ln_bt_fw ) THEN ! FORWARD integration: use NOW top baroclinic velocity -
NEMO/branches/2020/dev_r13327_KERNEL-06_2_techene_e3/src/OCE/DYN/dynvor.F90
r13734 r13998 223 223 REAL(wp) :: zx1, zy1, zx2, zy2 ! local scalars 224 224 REAL(wp), DIMENSION(jpi,jpj) :: zwx, zwy, zwt ! 2D workspace 225 REAL(wp), ALLOCATABLE, DIMENSION(:,:,:) :: zwz ! 3D workspace 225 REAL(wp), ALLOCATABLE, DIMENSION(:,:,:) :: zwz ! 3D workspace, jpkm1 -> avoid lbc_lnk on jpk that is not defined 226 226 !!---------------------------------------------------------------------- 227 227 ! … … 248 248 ENDIF 249 249 END DO 250 CALL lbc_lnk( 'dynvor', zwz, 'F', 1. )250 CALL lbc_lnk( 'dynvor', zwz, 'F', 1.0_wp ) 251 251 ! 252 252 END SELECT … … 591 591 REAL(wp) :: zua, zva ! local scalars 592 592 REAL(wp) :: zmsk, ze3f ! local scalars 593 REAL(wp), DIMENSION(jpi,jpj) :: zwx , zwy , z1_e3f594 REAL(wp), DIMENSION(jpi,jpj) :: ztnw, ztne, ztsw, ztse595 REAL(wp), DIMENSION(jpi,jpj,jpk ) :: zwz593 REAL(wp), DIMENSION(jpi,jpj) :: zwx , zwy , z1_e3f 594 REAL(wp), DIMENSION(jpi,jpj) :: ztnw, ztne, ztsw, ztse 595 REAL(wp), DIMENSION(jpi,jpj,jpkm1) :: zwz ! 3D workspace, jpkm1 -> jpkm1 -> avoid lbc_lnk on jpk that is not defined 596 596 !!---------------------------------------------------------------------- 597 597 ! … … 740 740 REAL(wp) :: zua, zva ! local scalars 741 741 REAL(wp) :: zmsk, z1_e3t ! local scalars 742 REAL(wp), DIMENSION(jpi,jpj) :: zwx , zwy743 REAL(wp), DIMENSION(jpi,jpj) :: ztnw, ztne, ztsw, ztse744 REAL(wp), DIMENSION(jpi,jpj,jpk ) :: zwz742 REAL(wp), DIMENSION(jpi,jpj) :: zwx , zwy 743 REAL(wp), DIMENSION(jpi,jpj) :: ztnw, ztne, ztsw, ztse 744 REAL(wp), DIMENSION(jpi,jpj,jpkm1) :: zwz ! 3D workspace, avoid lbc_lnk on jpk that is not defined 745 745 !!---------------------------------------------------------------------- 746 746 ! -
NEMO/branches/2020/dev_r13327_KERNEL-06_2_techene_e3/src/OCE/DYN/dynzad.F90
r13295 r13998 71 71 ENDIF 72 72 73 IF( l_trddyn ) THEN ! Save puu(:,:,:,Krhs) and pvv(:,:,:,Krhs) trends73 IF( l_trddyn ) THEN ! Save puu(:,:,:,Krhs) and pvv(:,:,:,Krhs) trends 74 74 ALLOCATE( ztrdu(jpi,jpj,jpk) , ztrdv(jpi,jpj,jpk) ) 75 75 ztrdu(:,:,:) = puu(:,:,:,Krhs) … … 77 77 ENDIF 78 78 79 DO jk = 2, jpkm1 ! Vertical momentum advection at level w and u- and v- vertical80 DO_2D( 0, 1, 0, 1 ) 79 DO jk = 2, jpkm1 ! Vertical momentum advection at level w and u- and v- vertical 80 DO_2D( 0, 1, 0, 1 ) ! vertical fluxes 81 81 zww(ji,jj) = 0.25_wp * e1e2t(ji,jj) * ww(ji,jj,jk) 82 82 END_2D 83 DO_2D( 0, 0, 0, 0 ) 83 DO_2D( 0, 0, 0, 0 ) ! vertical momentum advection at w-point 84 84 zwuw(ji,jj,jk) = ( zww(ji+1,jj ) + zww(ji,jj) ) * ( puu(ji,jj,jk-1,Kmm) - puu(ji,jj,jk,Kmm) ) 85 85 zwvw(ji,jj,jk) = ( zww(ji ,jj+1) + zww(ji,jj) ) * ( pvv(ji,jj,jk-1,Kmm) - pvv(ji,jj,jk,Kmm) ) … … 95 95 END_2D 96 96 ! 97 DO_3D( 0, 0, 0, 0, 1, jpkm1 ) 97 DO_3D( 0, 0, 0, 0, 1, jpkm1 ) ! Vertical momentum advection at u- and v-points 98 98 puu(ji,jj,jk,Krhs) = puu(ji,jj,jk,Krhs) - ( zwuw(ji,jj,jk) + zwuw(ji,jj,jk+1) ) * r1_e1e2u(ji,jj) & 99 99 & / e3u(ji,jj,jk,Kmm) … … 102 102 END_3D 103 103 104 IF( l_trddyn ) THEN ! save the vertical advection trends for diagnostic104 IF( l_trddyn ) THEN ! save the vertical advection trends for diagnostic 105 105 ztrdu(:,:,:) = puu(:,:,:,Krhs) - ztrdu(:,:,:) 106 106 ztrdv(:,:,:) = pvv(:,:,:,Krhs) - ztrdv(:,:,:) … … 108 108 DEALLOCATE( ztrdu, ztrdv ) 109 109 ENDIF 110 ! ! Control print110 ! ! Control print 111 111 IF(sn_cfctl%l_prtctl) CALL prt_ctl( tab3d_1=puu(:,:,:,Krhs), clinfo1=' zad - Ua: ', mask1=umask, & 112 112 & tab3d_2=pvv(:,:,:,Krhs), clinfo2= ' Va: ', mask2=vmask, clinfo3='dyn' ) -
NEMO/branches/2020/dev_r13327_KERNEL-06_2_techene_e3/src/OCE/DYN/dynzdf.F90
r13295 r13998 131 131 pvv(ji,jj,jk,Kaa) = ( pvv(ji,jj,jk,Kaa) - vv_b(ji,jj,Kaa) ) * vmask(ji,jj,jk) 132 132 END_3D 133 DO_2D( 0, 0, 0, 0 ) 133 DO_2D( 0, 0, 0, 0 ) ! Add bottom/top stress due to barotropic component only 134 134 iku = mbku(ji,jj) ! ocean bottom level at u- and v-points 135 135 ikv = mbkv(ji,jj) ! (deepest ocean u- and v-points) … … 141 141 pvv(ji,jj,ikv,Kaa) = pvv(ji,jj,ikv,Kaa) + rDt * 0.5*( rCdU_bot(ji,jj+1)+rCdU_bot(ji,jj) ) * vv_b(ji,jj,Kaa) / ze3va 142 142 END_2D 143 IF( ln_isfcav ) THEN ! Ocean cavities (ISF)143 IF( ln_isfcav.OR.ln_drgice_imp ) THEN ! Ocean cavities (ISF) 144 144 DO_2D( 0, 0, 0, 0 ) 145 145 iku = miku(ji,jj) ! top ocean level at u- and v-points … … 190 190 END_3D 191 191 END SELECT 192 DO_2D( 0, 0, 0, 0 ) 192 DO_2D( 0, 0, 0, 0 ) !* Surface boundary conditions 193 193 zwi(ji,jj,1) = 0._wp 194 194 ze3ua = ( 1._wp - r_vvl ) * e3u(ji,jj,1,Kmm) & … … 227 227 END_3D 228 228 END SELECT 229 DO_2D( 0, 0, 0, 0 ) 229 DO_2D( 0, 0, 0, 0 ) !* Surface boundary conditions 230 230 zwi(ji,jj,1) = 0._wp 231 231 zwd(ji,jj,1) = 1._wp - zws(ji,jj,1) … … 247 247 zwd(ji,jj,iku) = zwd(ji,jj,iku) - rDt * 0.5*( rCdU_bot(ji+1,jj)+rCdU_bot(ji,jj) ) / ze3ua 248 248 END_2D 249 IF ( ln_isfcav ) THEN ! top friction (always implicit)249 IF ( ln_isfcav.OR.ln_drgice_imp ) THEN ! top friction (always implicit) 250 250 DO_2D( 0, 0, 0, 0 ) 251 251 !!gm top Cd is masked (=0 outside cavities) no need of test on mik>=2 ==>> it has been suppressed … … 273 273 !----------------------------------------------------------------------- 274 274 ! 275 DO_3D( 0, 0, 0, 0, 2, jpkm1 ) 275 DO_3D( 0, 0, 0, 0, 2, jpkm1 ) !== First recurrence : Dk = Dk - Lk * Uk-1 / Dk-1 (increasing k) == 276 276 zwd(ji,jj,jk) = zwd(ji,jj,jk) - zwi(ji,jj,jk) * zws(ji,jj,jk-1) / zwd(ji,jj,jk-1) 277 277 END_3D 278 278 ! 279 DO_2D( 0, 0, 0, 0 ) 279 DO_2D( 0, 0, 0, 0 ) !== second recurrence: SOLk = RHSk - Lk / Dk-1 Lk-1 ==! 280 280 ze3ua = ( 1._wp - r_vvl ) * e3u(ji,jj,1,Kmm) & 281 281 & + r_vvl * e3u(ji,jj,1,Kaa) … … 287 287 END_3D 288 288 ! 289 DO_2D( 0, 0, 0, 0 ) 289 DO_2D( 0, 0, 0, 0 ) !== thrid recurrence : SOLk = ( Lk - Uk * Ek+1 ) / Dk ==! 290 290 puu(ji,jj,jpkm1,Kaa) = puu(ji,jj,jpkm1,Kaa) / zwd(ji,jj,jpkm1) 291 291 END_2D … … 329 329 END_3D 330 330 END SELECT 331 DO_2D( 0, 0, 0, 0 ) 331 DO_2D( 0, 0, 0, 0 ) !* Surface boundary conditions 332 332 zwi(ji,jj,1) = 0._wp 333 333 ze3va = ( 1._wp - r_vvl ) * e3v(ji,jj,1,Kmm) & … … 366 366 END_3D 367 367 END SELECT 368 DO_2D( 0, 0, 0, 0 ) 368 DO_2D( 0, 0, 0, 0 ) !* Surface boundary conditions 369 369 zwi(ji,jj,1) = 0._wp 370 370 zwd(ji,jj,1) = 1._wp - zws(ji,jj,1) … … 385 385 zwd(ji,jj,ikv) = zwd(ji,jj,ikv) - rDt * 0.5*( rCdU_bot(ji,jj+1)+rCdU_bot(ji,jj) ) / ze3va 386 386 END_2D 387 IF ( ln_isfcav ) THEN387 IF ( ln_isfcav.OR.ln_drgice_imp ) THEN 388 388 DO_2D( 0, 0, 0, 0 ) 389 389 ikv = mikv(ji,jj) ! (first wet ocean u- and v-points) … … 410 410 !----------------------------------------------------------------------- 411 411 ! 412 DO_3D( 0, 0, 0, 0, 2, jpkm1 ) 412 DO_3D( 0, 0, 0, 0, 2, jpkm1 ) !== First recurrence : Dk = Dk - Lk * Uk-1 / Dk-1 (increasing k) == 413 413 zwd(ji,jj,jk) = zwd(ji,jj,jk) - zwi(ji,jj,jk) * zws(ji,jj,jk-1) / zwd(ji,jj,jk-1) 414 414 END_3D 415 415 ! 416 DO_2D( 0, 0, 0, 0 ) 416 DO_2D( 0, 0, 0, 0 ) !== second recurrence: SOLk = RHSk - Lk / Dk-1 Lk-1 ==! 417 417 ze3va = ( 1._wp - r_vvl ) * e3v(ji,jj,1,Kmm) & 418 418 & + r_vvl * e3v(ji,jj,1,Kaa) … … 424 424 END_3D 425 425 ! 426 DO_2D( 0, 0, 0, 0 ) 426 DO_2D( 0, 0, 0, 0 ) !== third recurrence : SOLk = ( Lk - Uk * SOLk+1 ) / Dk ==! 427 427 pvv(ji,jj,jpkm1,Kaa) = pvv(ji,jj,jpkm1,Kaa) / zwd(ji,jj,jpkm1) 428 428 END_2D -
NEMO/branches/2020/dev_r13327_KERNEL-06_2_techene_e3/src/OCE/DYN/sshwzv.F90
r13915 r13998 206 206 ELSE !== Quasi-Eulerian vertical coordinate ==! ('key_qco') 207 207 ! !==========================================! 208 DO jk = jpkm1, 1, -1 ! integrate from the bottom the hor. divergence208 DO jk = jpkm1, 1, -1 ! integrate from the bottom the hor. divergence 209 209 pww(:,:,jk) = pww(:,:,jk+1) - ( e3t(:,:,jk,Kmm) * hdiv(:,:,jk) & 210 210 & + r1_Dt * ( e3t(:,:,jk,Kaa) & … … 398 398 ! 399 399 IF( MAXVAL( Cu_adv(:,:,:) ) > Cu_min ) THEN ! Quick check if any breaches anywhere 400 DO_3DS( 1, 1, 1, 1, jpkm1, 2, -1 ) 400 DO_3DS( 1, 1, 1, 1, jpkm1, 2, -1 ) ! or scan Courant criterion and partition ! w where necessary 401 401 ! 402 402 zCu = MAX( Cu_adv(ji,jj,jk) , Cu_adv(ji,jj,jk-1) ) -
NEMO/branches/2020/dev_r13327_KERNEL-06_2_techene_e3/src/OCE/DYN/wet_dry.F90
r13295 r13998 57 57 REAL(wp), PUBLIC :: ssh_ref !: height of z=0 with respect to the geoid; 58 58 59 LOGICAL, PUBLIC :: ll_wd !: Wetting/drying activation switch if either ln_wd_il or ln_wd_dl59 LOGICAL, PUBLIC :: ll_wd = .FALSE. !: Wetting/drying activation switch (ln_wd_il or ln_wd_dl) <- default def if wad_init not called 60 60 61 61 PUBLIC wad_init ! initialisation routine called by step.F90 … … 111 111 112 112 r_rn_wdmin1 = 1 / rn_wdmin1 113 ll_wd = .FALSE.114 113 IF( ln_wd_il .OR. ln_wd_dl ) THEN 115 114 ll_wd = .TRUE. … … 307 306 zwdlmtv(:,:) = 1._wp 308 307 ! 309 DO_2D( 0, 1, 0, 1 ) 308 DO_2D( 0, 1, 0, 1 ) ! Horizontal Flux in u and v direction 310 309 ! 311 310 IF( tmask(ji, jj, 1 ) < 0.5_wp) CYCLE ! we don't care about land cells -
NEMO/branches/2020/dev_r13327_KERNEL-06_2_techene_e3/src/OCE/FLO/flo_oce.F90
r11536 r13998 19 19 !! ---------------- 20 20 LOGICAL, PUBLIC :: ln_floats !: Activate floats or not 21 INTEGER, PUBLIC :: jpnfl 21 INTEGER, PUBLIC :: jpnfl = 0 !: total number of floats during the run 22 22 INTEGER, PUBLIC :: jpnnewflo !: number of floats added in a new run 23 23 INTEGER, PUBLIC :: jpnrstflo !: number of floats for the restart -
NEMO/branches/2020/dev_r13327_KERNEL-06_2_techene_e3/src/OCE/ICB/icbtrj.F90
r13062 r13998 35 35 PUBLIC icb_trj_end ! routine called in icbstp.F90 module 36 36 37 INTEGER :: num_traj 37 INTEGER :: num_traj = 0 38 38 INTEGER :: n_dim, m_dim 39 39 INTEGER :: ntrajid -
NEMO/branches/2020/dev_r13327_KERNEL-06_2_techene_e3/src/OCE/IOM/iom.F90
r13512 r13998 123 123 REAL(wp), DIMENSION(2,jpkam1) :: za_bnds ! ABL vertical boundaries 124 124 LOGICAL :: ll_closedef = .TRUE. 125 LOGICAL :: ll_exist 125 126 !!---------------------------------------------------------------------- 126 127 ! … … 235 236 CALL iom_set_axis_attr( "ghw_abl", bounds=za_bnds ) 236 237 237 CALL iom_set_axis_attr( "nfloat", (/ (REAL(ji,wp), ji=1,jpnfl) /) )238 CALL iom_set_axis_attr( "nfloat", (/ (REAL(ji,wp), ji=1,jpnfl) /) ) 238 239 # if defined key_si3 239 240 CALL iom_set_axis_attr( "ncatice", (/ (REAL(ji,wp), ji=1,jpl) /) ) … … 248 249 CALL iom_set_axis_attr( "iax_26C", (/ REAL(26,wp) /) ) ! strange syntaxe and idea... 249 250 CALL iom_set_axis_attr( "iax_28C", (/ REAL(28,wp) /) ) ! strange syntaxe and idea... 250 CALL iom_set_axis_attr( "basin" , (/ (REAL(ji,wp), ji=1,5) /) ) 251 ! for diaprt, we need to define an axis which size can be 1 (default) or 5 (if the file subbasins.nc exists) 252 INQUIRE( FILE = 'subbasins.nc', EXIST = ll_exist ) 253 nbasin = 1 + 4 * COUNT( (/ll_exist/) ) 254 CALL iom_set_axis_attr( "basin" , (/ (REAL(ji,wp), ji=1,nbasin) /) ) 251 255 ENDIF 252 256 ! … … 355 359 rst_file = TRIM(clpath)//TRIM(cn_ocerst_in) 356 360 ELSE 357 rst_file = TRIM(clpath)// '1_'//TRIM(cn_ocerst_in)361 rst_file = TRIM(clpath)//TRIM(Agrif_CFixed())//'_'//TRIM(cn_ocerst_in) 358 362 ENDIF 359 363 !set name of the restart file and enable available fields … … 1915 1919 IF( iom_use(cdname) ) THEN 1916 1920 #if defined key_iomput 1917 IF( SIZE(pfield2d, dim=1) == jpi .AND. SIZE(pfield2d, dim=2) == jpj ) THEN 1918 CALL xios_send_field( cdname, pfield2d(Nis0:Nie0, Njs0:Nje0) ) ! this extraction will create a copy of pfield2d 1919 ELSE 1920 CALL xios_send_field( cdname, pfield2d ) 1921 ENDIF 1921 CALL xios_send_field( cdname, pfield2d ) 1922 1922 #else 1923 1923 WRITE(numout,*) pfield2d ! iom_use(cdname) = .F. -> useless test to avoid compilation warnings … … 1931 1931 IF( iom_use(cdname) ) THEN 1932 1932 #if defined key_iomput 1933 IF( SIZE(pfield2d, dim=1) == jpi .AND. SIZE(pfield2d, dim=2) == jpj ) THEN 1934 CALL xios_send_field( cdname, pfield2d(Nis0:Nie0, Njs0:Nje0) ) ! this extraction will create a copy of pfield2d 1935 ELSE 1936 CALL xios_send_field( cdname, pfield2d ) 1937 ENDIF 1933 CALL xios_send_field( cdname, pfield2d ) 1938 1934 #else 1939 1935 WRITE(numout,*) pfield2d ! iom_use(cdname) = .F. -> useless test to avoid compilation warnings … … 1947 1943 IF( iom_use(cdname) ) THEN 1948 1944 #if defined key_iomput 1949 IF( SIZE(pfield3d, dim=1) == jpi .AND. SIZE(pfield3d, dim=2) == jpj ) THEN 1950 CALL xios_send_field( cdname, pfield3d(Nis0:Nie0, Njs0:Nje0,:) ) ! this extraction will create a copy of pfield3d 1951 ELSE 1952 CALL xios_send_field( cdname, pfield3d ) 1953 ENDIF 1945 CALL xios_send_field( cdname, pfield3d ) 1954 1946 #else 1955 1947 WRITE(numout,*) pfield3d ! iom_use(cdname) = .F. -> useless test to avoid compilation warnings … … 1963 1955 IF( iom_use(cdname) ) THEN 1964 1956 #if defined key_iomput 1965 IF( SIZE(pfield3d, dim=1) == jpi .AND. SIZE(pfield3d, dim=2) == jpj ) THEN 1966 CALL xios_send_field( cdname, pfield3d(Nis0:Nie0, Njs0:Nje0,:) ) ! this extraction will create a copy of pfield3d 1967 ELSE 1968 CALL xios_send_field( cdname, pfield3d ) 1969 ENDIF 1957 CALL xios_send_field( cdname, pfield3d ) 1970 1958 #else 1971 1959 WRITE(numout,*) pfield3d ! iom_use(cdname) = .F. -> useless test to avoid compilation warnings … … 1979 1967 IF( iom_use(cdname) ) THEN 1980 1968 #if defined key_iomput 1981 IF( SIZE(pfield4d, dim=1) == jpi .AND. SIZE(pfield4d, dim=2) == jpj ) THEN 1982 CALL xios_send_field( cdname, pfield4d(Nis0:Nie0, Njs0:Nje0,:,:) ) ! this extraction will create a copy of pfield4d 1983 ELSE 1984 CALL xios_send_field (cdname, pfield4d ) 1985 ENDIF 1969 CALL xios_send_field (cdname, pfield4d ) 1986 1970 #else 1987 1971 WRITE(numout,*) pfield4d ! iom_use(cdname) = .F. -> useless test to avoid compilation warnings … … 1995 1979 IF( iom_use(cdname) ) THEN 1996 1980 #if defined key_iomput 1997 IF( SIZE(pfield4d, dim=1) == jpi .AND. SIZE(pfield4d, dim=2) == jpj ) THEN 1998 CALL xios_send_field( cdname, pfield4d(Nis0:Nie0, Njs0:Nje0,:,:) ) ! this extraction will create a copy of pfield4d 1999 ELSE 2000 CALL xios_send_field (cdname, pfield4d ) 2001 ENDIF 1981 CALL xios_send_field (cdname, pfield4d ) 2002 1982 #else 2003 1983 WRITE(numout,*) pfield4d ! iom_use(cdname) = .F. -> useless test to avoid compilation warnings … … 2205 2185 ! 2206 2186 CALL iom_set_domain_attr("grid_"//cdgrd, ni_glo=Ni0glo,nj_glo=Nj0glo,ibegin=mig0(Nis0)-1,jbegin=mjg0(Njs0)-1,ni=Ni_0,nj=Nj_0) 2207 CALL iom_set_domain_attr("grid_"//cdgrd, data_dim=2, data_ibegin = 0, data_ni = Ni_0, data_jbegin = 0, data_nj = Nj_0)2187 CALL iom_set_domain_attr("grid_"//cdgrd, data_dim=2, data_ibegin = -nn_hls, data_ni = jpi, data_jbegin = -nn_hls, data_nj = jpj) 2208 2188 !don't define lon and lat for restart reading context. 2209 2189 IF ( .NOT.ldrxios ) & … … 2304 2284 CALL dom_ngb( 180.0_wp, 90.0_wp, ix, iy, 'T' ) ! i-line that passes near the North Pole : Reference latitude (used in plots) 2305 2285 CALL iom_set_domain_attr("gznl", ni_glo=Ni0glo, nj_glo=Nj0glo, ibegin=mig0(Nis0)-1, jbegin=mjg0(Njs0)-1, ni=Ni_0, nj=Nj_0) 2306 CALL iom_set_domain_attr("gznl", data_dim=2, data_ibegin = 0, data_ni = Ni_0, data_jbegin = 0, data_nj = Nj_0)2286 CALL iom_set_domain_attr("gznl", data_dim=2, data_ibegin = -nn_hls, data_ni = jpi, data_jbegin = -nn_hls, data_nj = jpj) 2307 2287 CALL iom_set_domain_attr("gznl", lonvalue = real(zlon, dp), & 2308 2288 & latvalue = real(RESHAPE(plat(Nis0:Nie0, Njs0:Nje0),(/ Ni_0*Nj_0 /)),dp)) 2309 CALL iom_set_zoom_domain_attr("ptr", ibegin=ix-1, jbegin=0, ni=1, nj=Nj _0)2289 CALL iom_set_zoom_domain_attr("ptr", ibegin=ix-1, jbegin=0, ni=1, nj=Nj0glo) 2310 2290 ! 2311 2291 CALL iom_update_file_name('ptr') -
NEMO/branches/2020/dev_r13327_KERNEL-06_2_techene_e3/src/OCE/IOM/iom_def.F90
r13286 r13998 33 33 INTEGER, PUBLIC :: iom_open_init = 0 !: used to initialize iom_file(:)%nfid to 0 34 34 !XIOS write restart 35 LOGICAL, PUBLIC :: lwxios 36 INTEGER, PUBLIC :: nxioso !: type of restart file when writing using XIOS 1 - single, 2 - multiple35 LOGICAL, PUBLIC :: lwxios = .FALSE. !: write single file restart using XIOS 36 INTEGER, PUBLIC :: nxioso = 0 !: type of restart file when writing using XIOS 1 - single, 2 - multiple 37 37 !XIOS read restart 38 LOGICAL, PUBLIC :: lrxios 38 LOGICAL, PUBLIC :: lrxios = .FALSE. !: read single file restart using XIOS 39 39 LOGICAL, PUBLIC :: lxios_sini = .FALSE. ! is restart in a single file 40 40 LOGICAL, PUBLIC :: lxios_set = .FALSE. -
NEMO/branches/2020/dev_r13327_KERNEL-06_2_techene_e3/src/OCE/ISF/isf_oce.F90
r12077 r13998 74 74 ! 75 75 ! 2.1 -------- ice shelf cavity parameter -------------- 76 LOGICAL , PUBLIC :: l_isfoasis 76 LOGICAL , PUBLIC :: l_isfoasis = .FALSE. 77 77 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: risfload !: ice shelf load 78 78 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: fwfisf_oasis -
NEMO/branches/2020/dev_r13327_KERNEL-06_2_techene_e3/src/OCE/ISF/isfcavmlt.F90
r13295 r13998 136 136 !! ** Method : The ice shelf melt latent heat is defined as being equal to the ocean/ice heat flux. 137 137 !! From this we can derived the fwf, ocean/ice heat flux and the heat content flux as being : 138 !! qfwf = Gammat * Rau0 * Cp * ( Tw - Tfrz ) / Lf138 !! qfwf = Gammat * rho0 * Cp * ( Tw - Tfrz ) / Lf 139 139 !! qhoce = qlat 140 140 !! qhc = qfwf * Cp * Tfrz -
NEMO/branches/2020/dev_r13327_KERNEL-06_2_techene_e3/src/OCE/LBC/lbc_lnk_multi_generic.h90
r13286 r13998 35 35 #endif 36 36 37 SUBROUTINE ROUTINE_MULTI( cdname & 38 & , pt1, cdna1, psgn1, pt2 , cdna2 , psgn2 , pt3 , cdna3 , psgn3 , pt4, cdna4, psgn4 & 39 & , pt5, cdna5, psgn5, pt6 , cdna6 , psgn6 , pt7 , cdna7 , psgn7 , pt8, cdna8, psgn8 & 40 & , pt9, cdna9, psgn9, pt10, cdna10, psgn10, pt11, cdna11, psgn11 & 37 SUBROUTINE ROUTINE_MULTI( cdname & 38 & , pt1 , cdna1 , psgn1 , pt2 , cdna2 , psgn2 , pt3 , cdna3 , psgn3 , pt4 , cdna4 , psgn4 & 39 & , pt5 , cdna5 , psgn5 , pt6 , cdna6 , psgn6 , pt7 , cdna7 , psgn7 , pt8 , cdna8 , psgn8 & 40 & , pt9 , cdna9 , psgn9 , pt10, cdna10, psgn10, pt11, cdna11, psgn11, pt12, cdna12, psgn12 & 41 & , pt13, cdna13, psgn13, pt14, cdna14, psgn14, pt15, cdna15, psgn15, pt16, cdna16, psgn16 & 41 42 & , kfillmode, pfillval, lsend, lrecv ) 42 43 !!--------------------------------------------------------------------- 43 CHARACTER(len=*) , INTENT(in ) :: cdname ! name of the calling subroutine 44 ARRAY_TYPE(:,:,:,:) , TARGET, INTENT(inout) :: pt1 ! arrays on which the lbc is applied 45 ARRAY_TYPE(:,:,:,:), OPTIONAL, TARGET, INTENT(inout) :: pt2 , pt3 , pt4 , pt5 , pt6 , pt7 , pt8 , pt9 , pt10 , pt11 46 CHARACTER(len=1) , INTENT(in ) :: cdna1 ! nature of pt2D. array grid-points 47 CHARACTER(len=1) , OPTIONAL , INTENT(in ) :: cdna2, cdna3, cdna4, cdna5, cdna6, cdna7, cdna8, cdna9, cdna10, cdna11 48 REAL(wp) , INTENT(in ) :: psgn1 ! sign used across the north fold 49 REAL(wp) , OPTIONAL , INTENT(in ) :: psgn2, psgn3, psgn4, psgn5, psgn6, psgn7, psgn8, psgn9, psgn10, psgn11 50 INTEGER , OPTIONAL , INTENT(in ) :: kfillmode ! filling method for halo over land (default = constant) 51 REAL(wp) , OPTIONAL , INTENT(in ) :: pfillval ! background value (used at closed boundaries) 52 LOGICAL, DIMENSION(4), OPTIONAL , INTENT(in ) :: lsend, lrecv ! indicate how communications are to be carried out 44 CHARACTER(len=*) , INTENT(in ) :: cdname ! name of the calling subroutine 45 ARRAY_TYPE(:,:,:,:) , TARGET, INTENT(inout) :: pt1 ! arrays on which the lbc is applied 46 ARRAY_TYPE(:,:,:,:) , OPTIONAL, TARGET, INTENT(inout) :: pt2 , pt3 , pt4 , pt5 , pt6 , pt7 , pt8 , pt9 , & 47 & pt10 , pt11 , pt12 , pt13 , pt14 , pt15 , pt16 48 CHARACTER(len=1) , INTENT(in ) :: cdna1 ! nature of pt2D. array grid-points 49 CHARACTER(len=1) , OPTIONAL , INTENT(in ) :: cdna2 , cdna3 , cdna4 , cdna5 , cdna6 , cdna7 , cdna8 , cdna9, & 50 & cdna10, cdna11, cdna12, cdna13, cdna14, cdna15, cdna16 51 REAL(wp) , INTENT(in ) :: psgn1 ! sign used across the north fold 52 REAL(wp) , OPTIONAL , INTENT(in ) :: psgn2 , psgn3 , psgn4 , psgn5 , psgn6 , psgn7 , psgn8 , psgn9, & 53 & psgn10, psgn11, psgn12, psgn13, psgn14, psgn15, psgn16 54 INTEGER , OPTIONAL , INTENT(in ) :: kfillmode ! filling method for halo over land (default = constant) 55 REAL(wp) , OPTIONAL , INTENT(in ) :: pfillval ! background value (used at closed boundaries) 56 LOGICAL, DIMENSION(4), OPTIONAL , INTENT(in ) :: lsend, lrecv ! indicate how communications are to be carried out 53 57 !! 54 58 INTEGER :: kfld ! number of elements that will be attributed 55 PTR_TYPE , DIMENSION(1 1) :: ptab_ptr ! pointer array56 CHARACTER(len=1) , DIMENSION(1 1) :: cdna_ptr ! nature of ptab_ptr grid-points57 REAL(wp) , DIMENSION(1 1) :: psgn_ptr ! sign used across the north fold boundary59 PTR_TYPE , DIMENSION(16) :: ptab_ptr ! pointer array 60 CHARACTER(len=1) , DIMENSION(16) :: cdna_ptr ! nature of ptab_ptr grid-points 61 REAL(wp) , DIMENSION(16) :: psgn_ptr ! sign used across the north fold boundary 58 62 !!--------------------------------------------------------------------- 59 63 ! … … 74 78 IF( PRESENT(psgn10) ) CALL ROUTINE_LOAD( pt10, cdna10, psgn10, ptab_ptr, cdna_ptr, psgn_ptr, kfld ) 75 79 IF( PRESENT(psgn11) ) CALL ROUTINE_LOAD( pt11, cdna11, psgn11, ptab_ptr, cdna_ptr, psgn_ptr, kfld ) 80 IF( PRESENT(psgn12) ) CALL ROUTINE_LOAD( pt12, cdna12, psgn12, ptab_ptr, cdna_ptr, psgn_ptr, kfld ) 81 IF( PRESENT(psgn13) ) CALL ROUTINE_LOAD( pt13, cdna13, psgn13, ptab_ptr, cdna_ptr, psgn_ptr, kfld ) 82 IF( PRESENT(psgn14) ) CALL ROUTINE_LOAD( pt14, cdna14, psgn14, ptab_ptr, cdna_ptr, psgn_ptr, kfld ) 83 IF( PRESENT(psgn15) ) CALL ROUTINE_LOAD( pt15, cdna15, psgn15, ptab_ptr, cdna_ptr, psgn_ptr, kfld ) 84 IF( PRESENT(psgn16) ) CALL ROUTINE_LOAD( pt16, cdna16, psgn16, ptab_ptr, cdna_ptr, psgn_ptr, kfld ) 76 85 ! 77 CALL lbc_lnk_ptr ( cdname,ptab_ptr, cdna_ptr, psgn_ptr, kfld, kfillmode, pfillval, lsend, lrecv )86 CALL lbc_lnk_ptr( cdname, ptab_ptr, cdna_ptr, psgn_ptr, kfld, kfillmode, pfillval, lsend, lrecv ) 78 87 ! 79 88 END SUBROUTINE ROUTINE_MULTI -
NEMO/branches/2020/dev_r13327_KERNEL-06_2_techene_e3/src/OCE/LBC/lib_mpp.F90
r13286 r13998 73 73 PUBLIC tic_tac 74 74 #if ! defined key_mpp_mpi 75 PUBLIC MPI_wait 75 76 PUBLIC MPI_Wtime 76 77 #endif … … 115 116 #else 116 117 INTEGER, PUBLIC, PARAMETER :: MPI_STATUS_SIZE = 1 118 INTEGER, PUBLIC, PARAMETER :: MPI_REAL = 4 117 119 INTEGER, PUBLIC, PARAMETER :: MPI_DOUBLE_PRECISION = 8 118 120 LOGICAL, PUBLIC, PARAMETER :: lk_mpp = .FALSE. !: mpp flag … … 509 511 ALLOCATE(todelay(idvar)%y1d(isz)) 510 512 todelay(idvar)%y1d(:) = CMPLX(todelay(idvar)%z1d(:), 0., wp) ! create %y1d, complex variable needed by mpi_sumdd 513 ndelayid(idvar) = MPI_REQUEST_NULL ! initialised request to a valid value 511 514 END IF 512 515 ENDIF … … 516 519 ALLOCATE(todelay(idvar)%z1d(isz), todelay(idvar)%y1d(isz)) ! allocate also %z1d as used for the restart 517 520 CALL mpi_allreduce( y_in(:), todelay(idvar)%y1d(:), isz, MPI_DOUBLE_COMPLEX, mpi_sumdd, ilocalcomm, ierr ) ! get %y1d 518 todelay(idvar)%z1d(:) = REAL(todelay(idvar)%y1d(:), wp) ! define %z1d from %y1d519 ENDIF 520 521 IF( ndelayid(idvar) > 0 )CALL mpp_delay_rcv( idvar ) ! make sure %z1d is received521 ndelayid(idvar) = MPI_REQUEST_NULL 522 ENDIF 523 524 CALL mpp_delay_rcv( idvar ) ! make sure %z1d is received 522 525 523 526 ! send back pout from todelay(idvar)%z1d defined at previous call … … 528 531 IF( ln_timing ) CALL tic_tac( .TRUE., ld_global = .TRUE.) 529 532 CALL mpi_allreduce( y_in(:), todelay(idvar)%y1d(:), isz, MPI_DOUBLE_COMPLEX, mpi_sumdd, ilocalcomm, ierr ) 530 ndelayid(idvar) = 1533 ndelayid(idvar) = MPI_REQUEST_NULL 531 534 IF( ln_timing ) CALL tic_tac(.FALSE., ld_global = .TRUE.) 532 535 # else … … 589 592 DEALLOCATE(todelay(idvar)%z1d) 590 593 ndelayid(idvar) = -1 ! do as if we had no restart 594 ELSE 595 ndelayid(idvar) = MPI_REQUEST_NULL 591 596 END IF 592 597 ENDIF … … 596 601 ALLOCATE(todelay(idvar)%z1d(isz)) 597 602 CALL mpi_allreduce( p_in(:), todelay(idvar)%z1d(:), isz, MPI_DOUBLE_PRECISION, mpi_max, ilocalcomm, ierr ) ! get %z1d 598 ENDIF 599 600 IF( ndelayid(idvar) > 0 ) CALL mpp_delay_rcv( idvar ) ! make sure %z1d is received 603 ndelayid(idvar) = MPI_REQUEST_NULL 604 ENDIF 605 606 CALL mpp_delay_rcv( idvar ) ! make sure %z1d is received 601 607 602 608 ! send back pout from todelay(idvar)%z1d defined at previous call … … 604 610 605 611 ! send p_in into todelay(idvar)%z1d with a non-blocking communication 612 ! (PM) Should we get rid of MPI2 option ? MPI3 was release in 2013. Who is still using MPI2 ? 606 613 # if defined key_mpi2 607 614 IF( ln_timing ) CALL tic_tac( .TRUE., ld_global = .TRUE.) 608 CALL mpi_allreduce( p_in(:), todelay(idvar)%z1d(:), isz, MPI_TYPE, mpi_max, ilocalcomm, ndelayid(idvar),ierr )615 CALL mpi_allreduce( p_in(:), todelay(idvar)%z1d(:), isz, MPI_TYPE, mpi_max, ilocalcomm, ierr ) 609 616 IF( ln_timing ) CALL tic_tac(.FALSE., ld_global = .TRUE.) 610 617 # else … … 629 636 !!---------------------------------------------------------------------- 630 637 #if defined key_mpp_mpi 631 IF( ndelayid(kid) /= -2 ) THEN 632 #if ! defined key_mpi2 633 IF( ln_timing ) CALL tic_tac( .TRUE., ld_global = .TRUE.) 634 CALL mpi_wait( ndelayid(kid), MPI_STATUS_IGNORE, ierr ) ! make sure todelay(kid) is received 635 IF( ln_timing ) CALL tic_tac(.FALSE., ld_global = .TRUE.) 636 #endif 637 IF( ASSOCIATED(todelay(kid)%y1d) ) todelay(kid)%z1d(:) = REAL(todelay(kid)%y1d(:), wp) ! define %z1d from %y1d 638 ndelayid(kid) = -2 ! add flag to know that mpi_wait was already called on kid 639 ENDIF 638 IF( ln_timing ) CALL tic_tac( .TRUE., ld_global = .TRUE.) 639 ! test on ndelayid(kid) useless as mpi_wait return immediatly if the request handle is MPI_REQUEST_NULL 640 CALL mpi_wait( ndelayid(kid), MPI_STATUS_IGNORE, ierr ) ! after this ndelayid(kid) = MPI_REQUEST_NULL 641 IF( ln_timing ) CALL tic_tac( .FALSE., ld_global = .TRUE.) 642 IF( ASSOCIATED(todelay(kid)%y1d) ) todelay(kid)%z1d(:) = REAL(todelay(kid)%y1d(:), wp) ! define %z1d from %y1d 640 643 #endif 641 644 END SUBROUTINE mpp_delay_rcv -
NEMO/branches/2020/dev_r13327_KERNEL-06_2_techene_e3/src/OCE/LBC/mpp_lbc_north_icb_generic.h90
r13286 r13998 67 67 ! 68 68 IF( ln_timing ) CALL tic_tac(.TRUE.) 69 #if defined key_mpp_mpi 69 70 CALL MPI_ALLGATHER( znorthloc_e(1,1-kextj) , itaille, MPI_TYPE, & 70 71 & znorthgloio_e(1,1-kextj,1), itaille, MPI_TYPE, & 71 72 & ncomm_north, ierr ) 73 #endif 72 74 ! 73 75 IF( ln_timing ) CALL tic_tac(.FALSE.) -
NEMO/branches/2020/dev_r13327_KERNEL-06_2_techene_e3/src/OCE/LBC/mpp_loc_generic.h90
r13286 r13998 2 2 # if defined SINGLE_PRECISION 3 3 # define ARRAY_TYPE(i,j,k) REAL(sp) , INTENT(in ) :: ARRAY_IN(i,j,k) 4 # define MASK_TYPE(i,j,k) REAL(sp) , INTENT(in ) :: MASK_IN(i,j,k) 4 #if defined key_mpp_mpi 5 # define MPI_TYPE MPI_2REAL 6 #endif 5 7 # define PRECISION sp 6 8 # else 7 9 # define ARRAY_TYPE(i,j,k) REAL(dp) , INTENT(in ) :: ARRAY_IN(i,j,k) 8 # define MASK_TYPE(i,j,k) REAL(dp) , INTENT(in ) :: MASK_IN(i,j,k) 10 #if defined key_mpp_mpi 11 # define MPI_TYPE MPI_2DOUBLE_PRECISION 12 #endif 9 13 # define PRECISION dp 10 14 # endif … … 12 16 # if defined DIM_2d 13 17 # define ARRAY_IN(i,j,k) ptab(i,j) 14 # define MASK_IN(i,j,k) pmask(i,j)18 # define MASK_IN(i,j,k) ldmsk(i,j) 15 19 # define INDEX_TYPE(k) INTEGER , INTENT( out) :: kindex(2) 16 20 # define K_SIZE(ptab) 1 … … 18 22 # if defined DIM_3d 19 23 # define ARRAY_IN(i,j,k) ptab(i,j,k) 20 # define MASK_IN(i,j,k) pmask(i,j,k)24 # define MASK_IN(i,j,k) ldmsk(i,j,k) 21 25 # define INDEX_TYPE(k) INTEGER , INTENT( out) :: kindex(3) 22 26 # define K_SIZE(ptab) SIZE(ptab,3) 23 27 # endif 24 28 # if defined OPERATION_MAXLOC 25 # define MPI_OPERATION mpi_maxloc29 # define MPI_OPERATION MPI_MAXLOC 26 30 # define LOC_OPERATION MAXLOC 27 31 # define ERRVAL -HUGE 28 32 # endif 29 33 # if defined OPERATION_MINLOC 30 # define MPI_OPERATION mpi_minloc34 # define MPI_OPERATION MPI_MINLOC 31 35 # define LOC_OPERATION MINLOC 32 36 # define ERRVAL HUGE 33 37 # endif 34 38 35 SUBROUTINE ROUTINE_LOC( cdname, ptab, pmask, pmin, kindex)39 SUBROUTINE ROUTINE_LOC( cdname, ptab, ldmsk, pmin, kindex, ldhalo ) 36 40 !!---------------------------------------------------------------------- 37 CHARACTER(len=*), INTENT(in ) :: cdname ! name of the calling subroutine41 CHARACTER(len=*), INTENT(in ) :: cdname ! name of the calling subroutine 38 42 ARRAY_TYPE(:,:,:) ! array on which loctrans operation is applied 39 MASK_TYPE(:,:,:)! local mask40 REAL(PRECISION) 43 LOGICAL , INTENT(in ) :: MASK_IN(:,:,:) ! local mask 44 REAL(PRECISION) , INTENT( out) :: pmin ! Global minimum of ptab 41 45 INDEX_TYPE(:) ! index of minimum in global frame 46 LOGICAL, OPTIONAL, INTENT(in ) :: ldhalo ! If .false. (default) excludes halos in kindex 42 47 ! 43 48 INTEGER :: ierror, ii, idim 44 49 INTEGER :: index0 50 INTEGER , DIMENSION(:), ALLOCATABLE :: ilocs 45 51 REAL(PRECISION) :: zmin ! local minimum 46 INTEGER , DIMENSION(:), ALLOCATABLE :: ilocs47 REAL(dp), DIMENSION(2,1) :: zain, zaout52 REAL(PRECISION), DIMENSION(2,1) :: zain, zaout 53 LOGICAL :: llhalo 48 54 !!----------------------------------------------------------------------- 49 55 ! 50 56 IF( narea == 1 .AND. numcom == -1 ) CALL mpp_report( cdname, ld_glb = .TRUE. ) 51 57 ! 58 IF( PRESENT(ldhalo) ) THEN ; llhalo = ldhalo 59 ELSE ; llhalo = .FALSE. 60 ENDIF 61 ! 52 62 idim = SIZE(kindex) 53 63 ! 54 IF ( ALL(MASK_IN(:,:,:) /= 1._wp) ) THEN 55 ! special case for land processors 56 zmin = ERRVAL(zmin) 57 index0 = 0 58 ELSE 64 IF ( ANY( MASK_IN(:,:,:) ) ) THEN ! there is at least 1 valid point... 65 ! 59 66 ALLOCATE ( ilocs(idim) ) 60 67 ! 61 ilocs = LOC_OPERATION( ARRAY_IN(:,:,:) , mask= MASK_IN(:,:,:) == 1._wp)68 ilocs = LOC_OPERATION( ARRAY_IN(:,:,:) , mask= MASK_IN(:,:,:) ) 62 69 zmin = ARRAY_IN(ilocs(1),ilocs(2),ilocs(3)) 63 70 ! … … 79 86 index0 = index0 + jpiglo * jpjglo * (kindex(3)-1) 80 87 #endif 88 ELSE 89 ! special case for land processors 90 zmin = ERRVAL(zmin) 91 index0 = 0 81 92 END IF 93 ! 82 94 zain(1,:) = zmin 83 zain(2,:) = REAL(index0, wp)95 zain(2,:) = REAL(index0, PRECISION) 84 96 ! 97 #if defined key_mpp_mpi 85 98 IF( ln_timing ) CALL tic_tac(.TRUE., ld_global = .TRUE.) 86 #if defined key_mpp_mpi 87 CALL MPI_ALLREDUCE( zain, zaout, 1, MPI_2DOUBLE_PRECISION, MPI_OPERATION ,MPI_COMM_OCE, ierror)99 CALL MPI_ALLREDUCE( zain, zaout, 1, MPI_TYPE, MPI_OPERATION ,MPI_COMM_OCE, ierror) 100 IF( ln_timing ) CALL tic_tac(.FALSE., ld_global = .TRUE.) 88 101 #else 89 102 zaout(:,:) = zain(:,:) 90 103 #endif 91 IF( ln_timing ) CALL tic_tac(.FALSE., ld_global = .TRUE.)92 104 ! 93 105 pmin = zaout(1,1) … … 104 116 kindex(:) = kindex(:) + 1 ! start indices at 1 105 117 118 IF( .NOT. llhalo ) THEN 119 kindex(1) = kindex(1) - nn_hls 120 #if defined DIM_2d || defined DIM_3d /* avoid warning when kindex has 1 element */ 121 kindex(2) = kindex(2) - nn_hls 122 #endif 123 ENDIF 124 106 125 END SUBROUTINE ROUTINE_LOC 107 126 … … 109 128 #undef PRECISION 110 129 #undef ARRAY_TYPE 111 #undef MASK_TYPE112 130 #undef ARRAY_IN 113 131 #undef MASK_IN 114 132 #undef K_SIZE 133 #if defined key_mpp_mpi 134 # undef MPI_TYPE 135 #endif 115 136 #undef MPI_OPERATION 116 137 #undef LOC_OPERATION -
NEMO/branches/2020/dev_r13327_KERNEL-06_2_techene_e3/src/OCE/LBC/mpp_nfd_generic.h90
r13290 r13998 317 317 ! start waiting time measurement 318 318 IF( ln_timing ) CALL tic_tac(.TRUE.) 319 #if defined key_mpp_mpi 319 320 CALL MPI_ALLGATHER( znorthloc, ibuffsize, MPI_TYPE, znorthglo, ibuffsize, MPI_TYPE, ncomm_north, ierr ) 321 #endif 320 322 ! stop waiting time measurement 321 323 IF( ln_timing ) CALL tic_tac(.FALSE.) -
NEMO/branches/2020/dev_r13327_KERNEL-06_2_techene_e3/src/OCE/LBC/mppini.F90
r13915 r13998 62 62 !!---------------------------------------------------------------------- 63 63 ! 64 jpiglo = Ni0glo 65 jpjglo = Nj0glo 64 nn_hls = 1 65 jpiglo = Ni0glo + 2 * nn_hls 66 jpjglo = Nj0glo + 2 * nn_hls 66 67 jpimax = jpiglo 67 68 jpjmax = jpjglo … … 72 73 jpjm1 = jpj-1 ! " " 73 74 jpkm1 = MAX( 1, jpk-1 ) ! " " 74 !75 CALL init_doloop ! set start/end indices or do-loop depending on the halo width value (nn_hls)76 !77 75 jpij = jpi*jpj 78 76 jpni = 1 79 77 jpnj = 1 80 78 jpnij = jpni*jpnj 81 nn_hls = 182 79 nimpp = 1 83 80 njmpp = 1 … … 91 88 l_Jperio = jpnj == 1 .AND. (jperio == 2 .OR. jperio == 7) 92 89 ! 90 CALL init_doloop ! set start/end indices or do-loop depending on the halo width value (nn_hls) 91 ! 93 92 IF(lwp) THEN 94 93 WRITE(numout,*) … … 99 98 ENDIF 100 99 ! 101 IF( jpni /= 1 .OR. jpnj /= 1 .OR. jpnij /= 1 ) &102 CALL ctl_stop( 'mpp_init: equality jpni = jpnj = jpnij = 1 is not satisfied', &103 & 'the domain is lay out for distributed memory computing!' )104 !105 100 #if defined key_agrif 106 101 IF (.NOT.agrif_root()) THEN … … 676 671 END SUBROUTINE mpp_init 677 672 673 #endif 678 674 679 675 SUBROUTINE mpp_basesplit( kiglo, kjglo, khls, knbi, knbj, kimax, kjmax, kimppt, kjmppt, klci, klcj) … … 790 786 !! ** Method : 791 787 !!---------------------------------------------------------------------- 792 INTEGER, INTENT(in ) :: knbij ! total number if subdomains(knbi*knbj)788 INTEGER, INTENT(in ) :: knbij ! total number of subdomains (knbi*knbj) 793 789 INTEGER, OPTIONAL, INTENT( out) :: knbi, knbj ! number if subdomains along i and j (knbi and knbj) 794 790 INTEGER, OPTIONAL, INTENT( out) :: knbcnt ! number of land subdomains … … 798 794 INTEGER :: iszitst, iszjtst 799 795 INTEGER :: isziref, iszjref 796 INTEGER :: iszimin, iszjmin 800 797 INTEGER :: inbij, iszij 801 798 INTEGER :: inbimax, inbjmax, inbijmax, inbijold … … 826 823 inbimax = 0 827 824 inbjmax = 0 828 isziref = Ni0glo*Nj0glo+1 829 iszjref = Ni0glo*Nj0glo+1 825 isziref = jpiglo*jpjglo+1 ! define a value that is larger than the largest possible 826 iszjref = jpiglo*jpjglo+1 827 ! 828 iszimin = 4*nn_hls ! minimum size of the MPI subdomain so halos are always adressing neighbor inner domain 829 iszjmin = 4*nn_hls 830 IF( jperio == 3 .OR. jperio == 4 ) iszjmin = MAX(iszjmin, 2+3*nn_hls) ! V and F folding must be outside of southern halos 831 IF( jperio == 5 .OR. jperio == 6 ) iszjmin = MAX(iszjmin, 1+3*nn_hls) ! V and F folding must be outside of southern halos 830 832 ! 831 833 ! get the list of knbi that gives a smaller jpimax than knbi-1 … … 835 837 iszitst = ( nx_global+2-2*nn_hls + (ji-1) ) / ji + 2*nn_hls ! first dim. 836 838 #else 837 iszitst = ( Ni0glo + (ji-1) ) / ji 839 iszitst = ( Ni0glo + (ji-1) ) / ji + 2*nn_hls ! max subdomain i-size 838 840 #endif 839 IF( iszitst < isziref ) THEN841 IF( iszitst < isziref .AND. iszitst >= iszimin ) THEN 840 842 isziref = iszitst 841 843 inbimax = inbimax + 1 … … 846 848 iszjtst = ( ny_global+2-2*nn_hls + (ji-1) ) / ji + 2*nn_hls ! first dim. 847 849 #else 848 iszjtst = ( Nj0glo + (ji-1) ) / ji 850 iszjtst = ( Nj0glo + (ji-1) ) / ji + 2*nn_hls ! max subdomain j-size 849 851 #endif 850 IF( iszjtst < iszjref ) THEN852 IF( iszjtst < iszjref .AND. iszjtst >= iszjmin ) THEN 851 853 iszjref = iszjtst 852 854 inbjmax = inbjmax + 1 … … 901 903 isz0 = 0 ! number of best partitions 902 904 inbij = 1 ! start with the min value of inbij1 => 1 903 iszij = Ni0glo*Nj0glo+1 ! default: larger than global domain905 iszij = jpiglo*jpjglo+1 ! default: larger than global domain 904 906 DO WHILE( inbij <= inbijmax ) ! if we did not reach the max of inbij1 905 907 ii = MINLOC(iszij1, mask = inbij1 == inbij, dim = 1) ! warning: send back the first occurence if multiple results 906 908 IF ( iszij1(ii) < iszij ) THEN 909 ii = MINLOC( iszi1+iszj1, mask = iszij1 == iszij1(ii) .AND. inbij1 == inbij, dim = 1) ! select the smaller perimeter if multiple min 907 910 isz0 = isz0 + 1 908 911 indexok(isz0) = ii … … 1322 1325 END SUBROUTINE init_nfdcom 1323 1326 1324 #endif1325 1327 1326 1328 SUBROUTINE init_doloop -
NEMO/branches/2020/dev_r13327_KERNEL-06_2_techene_e3/src/OCE/LDF/ldfc1d_c2d.F90
r13295 r13998 80 80 pah1(:,:,jk) = pahs1(:,:) * ( zratio + zc * ( 1._wp + TANH( - ( gdept_0(:,:,jk) - zh ) * zw) ) ) 81 81 END DO 82 DO_3DS( 1, 0, 1, 0, jpkm1, 1, -1 ) 82 DO_3DS( 1, 0, 1, 0, jpkm1, 1, -1 ) ! pah2 at F-point (zdep2 is an approximation in zps-coord.) 83 83 zdep2 = ( gdept_0(ji,jj+1,jk) + gdept_0(ji+1,jj+1,jk) & 84 84 & + gdept_0(ji,jj ,jk) + gdept_0(ji+1,jj ,jk) ) * r1_4 -
NEMO/branches/2020/dev_r13327_KERNEL-06_2_techene_e3/src/OCE/LDF/ldfdyn.F90
r13769 r13998 325 325 IF( ierr /= 0 ) CALL ctl_stop( 'STOP', 'ldf_dyn_init: failed to allocate Smagorinsky arrays') 326 326 ! 327 DO_2D( 1, 1, 1, 1 ) 327 DO_2D( 1, 1, 1, 1 ) ! Set local gridscale values 328 328 esqt(ji,jj) = ( 2._wp * e1e2t(ji,jj) / ( e1t(ji,jj) + e2t(ji,jj) ) )**2 329 329 esqf(ji,jj) = ( 2._wp * e1e2f(ji,jj) / ( e1f(ji,jj) + e2f(ji,jj) ) )**2 … … 448 448 DO jk = 1, jpkm1 449 449 ! 450 DO_2D( 0, 0, 0, 0 ) 450 DO_2D( 0, 0, 0, 0 ) ! T-point value 451 451 ! 452 452 zu2pv2_ij = uu(ji ,jj ,jk,Kbb) * uu(ji ,jj ,jk,Kbb) + vv(ji ,jj ,jk,Kbb) * vv(ji ,jj ,jk,Kbb) … … 462 462 END_2D 463 463 ! 464 DO_2D( 1, 0, 1, 0 ) 464 DO_2D( 1, 0, 1, 0 ) ! F-point value 465 465 ! 466 466 zu2pv2_ij_p1 = uu(ji ,jj+1,jk, kbb) * uu(ji ,jj+1,jk, kbb) + vv(ji+1,jj ,jk, kbb) * vv(ji+1,jj ,jk, kbb) -
NEMO/branches/2020/dev_r13327_KERNEL-06_2_techene_e3/src/OCE/LDF/ldfslp.F90
r13295 r13998 128 128 IF( ln_timing ) CALL timing_start('ldf_slp') 129 129 ! 130 zeps = 1.e-20_wp !== Local constant initialization ==!130 zeps = 1.e-20_wp !== Local constant initialization ==! 131 131 z1_16 = 1.0_wp / 16._wp 132 132 zm1_g = -1.0_wp / grav … … 137 137 zwz(:,:,:) = 0._wp 138 138 ! 139 DO_3D( 1, 0, 1, 0, 1, jpk ) 139 DO_3D( 1, 0, 1, 0, 1, jpk ) !== i- & j-gradient of density ==! 140 140 zgru(ji,jj,jk) = umask(ji,jj,jk) * ( prd(ji+1,jj ,jk) - prd(ji,jj,jk) ) 141 141 zgrv(ji,jj,jk) = vmask(ji,jj,jk) * ( prd(ji ,jj+1,jk) - prd(ji,jj,jk) ) … … 154 154 ENDIF 155 155 ! 156 zdzr(:,:,1) = 0._wp !== Local vertical density gradient at T-point == ! (evaluated from N^2)156 zdzr(:,:,1) = 0._wp !== Local vertical density gradient at T-point == ! (evaluated from N^2) 157 157 DO jk = 2, jpkm1 158 158 ! ! zdzr = d/dz(prd)= - ( prd ) / grav * mk(pn2) -- at t point … … 165 165 END DO 166 166 ! 167 ! !== Slopes just below the mixed layer ==!167 ! !== Slopes just below the mixed layer ==! 168 168 CALL ldf_slp_mxl( prd, pn2, zgru, zgrv, zdzr, Kmm ) ! output: uslpml, vslpml, wslpiml, wslpjml 169 169 … … 186 186 END IF 187 187 188 DO_3D( 0, 0, 0, 0, 2, jpkm1 ) 188 DO_3D( 0, 0, 0, 0, 2, jpkm1 ) !* Slopes at u and v points 189 189 ! ! horizontal and vertical density gradient at u- and v-points 190 190 zau = zgru(ji,jj,jk) * r1_e1u(ji,jj) … … 231 231 CALL lbc_lnk_multi( 'ldfslp', zwz, 'U', -1.0_wp, zww, 'V', -1.0_wp ) ! lateral boundary conditions 232 232 ! 233 ! 233 ! !* horizontal Shapiro filter 234 234 DO jk = 2, jpkm1 235 DO_2D( 0, 0, 0, 0 ) 235 DO_2D( 0, 0, 0, 0 ) ! rows jj=2 and =jpjm1 only 236 236 uslp(ji,jj,jk) = z1_16 * ( zwz(ji-1,jj-1,jk) + zwz(ji+1,jj-1,jk) & 237 237 & + zwz(ji-1,jj+1,jk) + zwz(ji+1,jj+1,jk) & … … 245 245 & + 4.* zww(ji,jj ,jk) ) 246 246 END_2D 247 DO jj = 3, jpj-2 ! other rows247 DO jj = 3, jpj-2 ! other rows 248 248 DO ji = 2, jpim1 ! vector opt. 249 249 uslp(ji,jj,jk) = z1_16 * ( zwz(ji-1,jj-1,jk) + zwz(ji+1,jj-1,jk) & … … 259 259 END DO 260 260 END DO 261 ! 261 ! !* decrease along coastal boundaries 262 262 DO_2D( 0, 0, 0, 0 ) 263 263 uslp(ji,jj,jk) = uslp(ji,jj,jk) * ( umask(ji,jj+1,jk) + umask(ji,jj-1,jk ) ) * 0.5_wp & … … 307 307 ! !* horizontal Shapiro filter 308 308 DO jk = 2, jpkm1 309 DO_2D( 0, 0, 0, 0 ) 309 DO_2D( 0, 0, 0, 0 ) ! rows jj=2 and =jpjm1 only 310 310 zcofw = wmask(ji,jj,jk) * z1_16 311 311 wslpi(ji,jj,jk) = ( zwz(ji-1,jj-1,jk) + zwz(ji+1,jj-1,jk) & … … 401 401 ! 402 402 ip = jl ; jp = jl ! guaranteed nonzero gradients ( absolute value larger than repsln) 403 DO_3D( 1, 0, 1, 0, 1, jpkm1 ) 403 DO_3D( 1, 0, 1, 0, 1, jpkm1 ) ! done each pair of triad ! NB: not masked ==> a minimum value is set 404 404 zdit = ( ts(ji+1,jj,jk,jp_tem,Kbb) - ts(ji,jj,jk,jp_tem,Kbb) ) ! i-gradient of T & S at u-point 405 405 zdis = ( ts(ji+1,jj,jk,jp_sal,Kbb) - ts(ji,jj,jk,jp_sal,Kbb) ) … … 427 427 428 428 DO kp = 0, 1 !== unmasked before density i- j-, k-gradients ==! 429 DO_3D( 1, 1, 1, 1, 1, jpkm1 ) 430 IF( jk+kp > 1 ) THEN ! k-gradient of T & S a jk+kp429 DO_3D( 1, 1, 1, 1, 1, jpkm1 ) ! done each pair of triad ! NB: not masked ==> a minimum value is set 430 IF( jk+kp > 1 ) THEN ! k-gradient of T & S a jk+kp 431 431 zdkt = ( ts(ji,jj,jk+kp-1,jp_tem,Kbb) - ts(ji,jj,jk+kp,jp_tem,Kbb) ) 432 432 zdks = ( ts(ji,jj,jk+kp-1,jp_sal,Kbb) - ts(ji,jj,jk+kp,jp_sal,Kbb) ) … … 442 442 END DO 443 443 ! 444 DO_2D( 1, 1, 1, 1 ) 444 DO_2D( 1, 1, 1, 1 ) !== Reciprocal depth of the w-point below ML base ==! 445 445 jk = MIN( nmln(ji,jj), mbkt(ji,jj) ) + 1 ! MIN in case ML depth is the ocean depth 446 446 z1_mlbw(ji,jj) = 1._wp / gdepw(ji,jj,jk,Kmm) … … 628 628 ! 629 629 ! !== surface mixed layer mask ! 630 DO_3D( 1, 1, 1, 1, 1, jpk ) 630 DO_3D( 1, 1, 1, 1, 1, jpk ) ! =1 inside the mixed layer, =0 otherwise 631 631 ik = nmln(ji,jj) - 1 632 632 IF( jk <= ik ) THEN ; omlmask(ji,jj,jk) = 1._wp -
NEMO/branches/2020/dev_r13327_KERNEL-06_2_techene_e3/src/OCE/LDF/ldftra.F90
r13295 r13998 246 246 ENDIF 247 247 ! 248 IF( ln_ldfeiv .AND. .NOT.( ln_traldf_iso .OR. ln_traldf_triad ) ) & 249 & CALL ctl_stop( 'ln_ldfeiv=T requires iso-neutral laplacian diffusion' ) 250 IF( ln_isfcav .AND. ln_traldf_triad ) & 251 & CALL ctl_stop( ' ice shelf cavity and traldf_triad not tested' ) 248 IF( ln_isfcav .AND. ln_traldf_triad ) CALL ctl_stop( ' ice shelf cavity and traldf_triad not tested' ) 252 249 ! 253 250 IF( nldf_tra == np_lap_i .OR. nldf_tra == np_lap_it .OR. & … … 541 538 IF( ln_traldf_blp ) CALL ctl_stop( 'ldf_eiv_init: eddy induced velocity ONLY with laplacian diffusivity' ) 542 539 ! 540 IF( .NOT.( ln_traldf_iso .OR. ln_traldf_triad ) ) & 541 & CALL ctl_stop( 'ln_ldfeiv=T requires iso-neutral laplacian diffusion' ) 543 542 ! != allocate the aei arrays 544 543 ALLOCATE( aeiu(jpi,jpj,jpk), aeiv(jpi,jpj,jpk), STAT=ierr ) … … 694 693 CALL lbc_lnk( 'ldftra', zaeiw(:,:), 'W', 1.0_wp ) ! lateral boundary condition 695 694 ! 696 DO_2D( 0, 0, 0, 0 ) 695 DO_2D( 0, 0, 0, 0 ) !== aei at u- and v-points ==! 697 696 paeiu(ji,jj,1) = 0.5_wp * ( zaeiw(ji,jj) + zaeiw(ji+1,jj ) ) * umask(ji,jj,1) 698 697 paeiv(ji,jj,1) = 0.5_wp * ( zaeiw(ji,jj) + zaeiw(ji ,jj+1) ) * vmask(ji,jj,1) … … 813 812 CALL iom_put( "voce_eiv", zw3d ) 814 813 ! 815 DO_3D( 0, 0, 0, 0, 1, jpkm1 ) 814 DO_3D( 0, 0, 0, 0, 1, jpkm1 ) ! e1 e2 w_eiv = dk[psix] + dk[psix] 816 815 zw3d(ji,jj,jk) = ( psi_vw(ji,jj,jk) - psi_vw(ji ,jj-1,jk) & 817 816 & + psi_uw(ji,jj,jk) - psi_uw(ji-1,jj ,jk) ) / e1e2t(ji,jj) -
NEMO/branches/2020/dev_r13327_KERNEL-06_2_techene_e3/src/OCE/SBC/cpl_oasis3.F90
r13286 r13998 165 165 ENDIF 166 166 ! 167 ! ... Define the shape for the area that excludes the halo 168 ! For serial configuration (key_mpp_mpi not being active) 169 ! nl* is set to the global values 1 and jp*glo. 167 ! ... Define the shape for the area that excludes the halo as we don't want them to be "seen" by oasis 170 168 ! 171 169 ishape(1) = 1 … … 176 174 ! ... Allocate memory for data exchange 177 175 ! 178 ALLOCATE(exfld(Ni_0, Nj_0), stat = nerror) 176 ALLOCATE(exfld(Ni_0, Nj_0), stat = nerror) ! allocate only inner domain (without halos) 179 177 IF( nerror > 0 ) THEN 180 178 CALL oasis_abort ( ncomp_id, 'cpl_define', 'Failure in allocating exfld') ; RETURN … … 182 180 ! 183 181 ! ----------------------------------------------------------------- 184 ! ... Define the partition 182 ! ... Define the partition, excluding halos as we don't want them to be "seen" by oasis 185 183 ! ----------------------------------------------------------------- 186 184 187 paral(1) = 2 188 paral(2) = jpiglo * (Njs0-1+njmpp-1) + (Nis0-1+nimpp-1) ! NEMO lower left corner global offset189 paral(3) = Ni_0 ! local extent in i190 paral(4) = Nj_0 ! local extent in j191 paral(5) = jpiglo ! global extent in x185 paral(1) = 2 ! box partitioning 186 paral(2) = Ni0glo * mjg0(nn_hls) + mig0(nn_hls) ! NEMO lower left corner global offset, without halos 187 paral(3) = Ni_0 ! local extent in i, excluding halos 188 paral(4) = Nj_0 ! local extent in j, excluding halos 189 paral(5) = Ni0glo ! global extent in x, excluding halos 192 190 193 191 IF( sn_cfctl%l_oasout ) THEN 194 192 WRITE(numout,*) ' multiexchg: paral (1:5)', paral 195 WRITE(numout,*) ' multiexchg: jpi, jpj =', jpi, jpj193 WRITE(numout,*) ' multiexchg: Ni_0, Nj_0 =', Ni_0, Nj_0 196 194 WRITE(numout,*) ' multiexchg: Nis0, Nie0, nimpp =', Nis0, Nie0, nimpp 197 195 WRITE(numout,*) ' multiexchg: Njs0, Nje0, njmpp =', Njs0, Nje0, njmpp 198 196 ENDIF 199 197 200 CALL oasis_def_partition ( id_part, paral, nerror, jpiglo*jpjglo )198 CALL oasis_def_partition ( id_part, paral, nerror, Ni0glo*Nj0glo ) ! global number of points, excluding halos 201 199 ! 202 200 ! ... Announce send variables. … … 327 325 DO jm = 1, ssnd(kid)%ncplmodel 328 326 329 IF( ssnd(kid)%nid(jc,jm) /= -1 ) THEN 327 IF( ssnd(kid)%nid(jc,jm) /= -1 ) THEN ! exclude halos from data sent to oasis 330 328 CALL oasis_put ( ssnd(kid)%nid(jc,jm), kstep, pdata(Nis0:Nie0, Njs0:Nje0,jc), kinfo ) 331 329 … … 386 384 & kinfo == OASIS_RecvOut .OR. kinfo == OASIS_FromRestOut 387 385 388 IF ( sn_cfctl%l_oasout ) WRITE(numout,*) "llaction, kinfo, kstep, ivarid: " , llaction, kinfo, kstep, srcv(kid)%nid(jc,jm) 386 IF ( sn_cfctl%l_oasout ) & 387 & WRITE(numout,*) "llaction, kinfo, kstep, ivarid: " , llaction, kinfo, kstep, srcv(kid)%nid(jc,jm) 389 388 390 IF( llaction ) THEN 389 IF( llaction ) THEN ! data received from oasis do not include halos 391 390 392 391 kinfo = OASIS_Rcv … … 417 416 ENDDO 418 417 419 !--- Fill the overlap areas and extra hallows (mpp) 420 !--- check periodicity conditions (all cases) 418 !--- we must call lbc_lnk to fill the halos that where not received. 421 419 IF( .NOT. ll_1st ) THEN 422 420 CALL lbc_lnk( 'cpl_oasis3', pdata(:,:,jc), srcv(kid)%clgrid, srcv(kid)%nsgn ) -
NEMO/branches/2020/dev_r13327_KERNEL-06_2_techene_e3/src/OCE/SBC/fldread.F90
r13295 r13998 216 216 WRITE(numout, clfmt) TRIM( sd(jf)%clvar ), kt, REAL(isecsbc,wp)/rday, nyear, nmonth, nday, & 217 217 & sd(jf)%nrec(1,ibb), sd(jf)%nrec(1,iaa), REAL(sd(jf)%nrec(2,ibb),wp)/rday, REAL(sd(jf)%nrec(2,iaa),wp)/rday 218 WRITE(numout, *) ' zt_offset is : ',zt_offset218 IF( zt_offset /= 0._wp ) WRITE(numout, *) ' zt_offset is : ', zt_offset 219 219 ENDIF 220 220 ! temporal interpolation weights -
NEMO/branches/2020/dev_r13327_KERNEL-06_2_techene_e3/src/OCE/SBC/sbc_ice.F90
r12396 r13998 69 69 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: emp_oce !: evap - precip over ocean [kg/m2/s] 70 70 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: wndm_ice !: wind speed module at T-point [m/s] 71 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: sstfrz !: wind speed module at T-point [m/s] 71 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: sstfrz !: sea surface freezing temperature [degC] 72 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: rCdU_ice !: ice-ocean drag at T-point (<0) [m/s] 72 73 #endif 73 74 … … 89 90 ! variables used in the coupled interface 90 91 INTEGER , PUBLIC, PARAMETER :: jpl = ncat 91 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: u_ice, v_ice ! jpi, jpj92 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: u_ice, v_ice 92 93 93 94 ! already defined in ice.F90 for SI3 … … 98 99 #endif 99 100 100 REAL(wp), PUBLIC, SAVE :: cldf_ice= 0.81 !: cloud fraction over sea ice, summer CLIO value [-]101 REAL(wp), PUBLIC, SAVE :: pp_cldf = 0.81 !: cloud fraction over sea ice, summer CLIO value [-] 101 102 102 103 !! arrays relating to embedding ice in the ocean … … 131 132 & qemp_ice(jpi,jpj) , qevap_ice(jpi,jpj,jpl) , qemp_oce (jpi,jpj) , & 132 133 & qns_oce (jpi,jpj) , qsr_oce (jpi,jpj) , emp_oce (jpi,jpj) , & 133 & emp_ice (jpi,jpj) , sstfrz (jpi,jpj) , STAT= ierr(2) )134 & emp_ice (jpi,jpj) , sstfrz (jpi,jpj) , rCdU_ice (jpi,jpj) , STAT= ierr(2) ) 134 135 #endif 135 136 … … 167 168 LOGICAL , PUBLIC, PARAMETER :: lk_si3 = .FALSE. !: no SI3 ice model 168 169 LOGICAL , PUBLIC, PARAMETER :: lk_cice = .FALSE. !: no CICE ice model 169 REAL(wp) , PUBLIC, PARAMETER :: cldf_ice = 0.81!: cloud fraction over sea ice, summer CLIO value [-]170 REAL(wp) , PUBLIC, PARAMETER :: pp_cldf = 0.81 !: cloud fraction over sea ice, summer CLIO value [-] 170 171 INTEGER , PUBLIC, PARAMETER :: jpl = 1 171 172 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: u_ice, v_ice ! jpi, jpj -
NEMO/branches/2020/dev_r13327_KERNEL-06_2_techene_e3/src/OCE/SBC/sbc_oce.F90
r13295 r13998 136 136 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: atm_co2 !: atmospheric pCO2 [ppm] 137 137 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: xcplmask !: coupling mask for ln_mixcpl (warning: allocated in sbccpl) 138 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: cloud_fra !: cloud cover (fraction of cloud in a gridcell) [-] 138 139 139 140 !!--------------------------------------------------------------------- … … 188 189 ! 189 190 ALLOCATE( tprecip(jpi,jpj) , sprecip(jpi,jpj) , fr_i(jpi,jpj) , & 190 & atm_co2(jpi,jpj) , tsk_m(jpi,jpj) , 191 & atm_co2(jpi,jpj) , tsk_m(jpi,jpj) , cloud_fra(jpi,jpj), & 191 192 & ssu_m (jpi,jpj) , sst_m(jpi,jpj) , frq_m(jpi,jpj) , & 192 193 & ssv_m (jpi,jpj) , sss_m(jpi,jpj) , ssh_m(jpi,jpj) , STAT=ierr(4) ) -
NEMO/branches/2020/dev_r13327_KERNEL-06_2_techene_e3/src/OCE/SBC/sbcblk.F90
r13305 r13998 44 44 USE lib_fortran ! to use key_nosignedzero 45 45 #if defined key_si3 46 USE ice , ONLY : jpl, a_i_b, at_i_b, rn_cnd_s, hfx_err_dif47 USE ice thd_dh ! for CALL ice_thd_snwblow46 USE ice , ONLY : u_ice, v_ice, jpl, a_i_b, at_i_b, t_su, rn_cnd_s, hfx_err_dif, nn_qtrice 47 USE icevar ! for CALL ice_var_snwblow 48 48 #endif 49 49 USE sbcblk_algo_ncar ! => turb_ncar : NCAR - CORE (Large & Yeager, 2009) … … 87 87 INTEGER , PUBLIC, PARAMETER :: jp_voatm = 11 ! index of surface current (j-component) 88 88 ! ! seen by the atmospheric forcing (m/s) at T-point 89 INTEGER , PUBLIC, PARAMETER :: jp_hpgi = 12 ! index of ABL geostrophic wind or hpg (i-component) (m/s) at T-point 90 INTEGER , PUBLIC, PARAMETER :: jp_hpgj = 13 ! index of ABL geostrophic wind or hpg (j-component) (m/s) at T-point 91 INTEGER , PUBLIC, PARAMETER :: jpfld = 13 ! maximum number of files to read 89 INTEGER , PUBLIC, PARAMETER :: jp_cc = 12 ! index of cloud cover (-) range:0-1 90 INTEGER , PUBLIC, PARAMETER :: jp_hpgi = 13 ! index of ABL geostrophic wind or hpg (i-component) (m/s) at T-point 91 INTEGER , PUBLIC, PARAMETER :: jp_hpgj = 14 ! index of ABL geostrophic wind or hpg (j-component) (m/s) at T-point 92 INTEGER , PUBLIC, PARAMETER :: jpfld = 14 ! maximum number of files to read 92 93 93 94 ! Warning: keep this structure allocatable for Agrif... … … 175 176 TYPE(FLD_N) :: sn_qlw , sn_tair , sn_prec, sn_snow ! " " 176 177 TYPE(FLD_N) :: sn_slp , sn_uoatm, sn_voatm ! " " 177 TYPE(FLD_N) :: sn_ hpgi, sn_hpgj! " "178 TYPE(FLD_N) :: sn_cc, sn_hpgi, sn_hpgj ! " " 178 179 INTEGER :: ipka ! number of levels in the atmospheric variable 179 180 NAMELIST/namsbc_blk/ sn_wndi, sn_wndj, sn_humi, sn_qsr, sn_qlw , & ! input fields 180 181 & sn_tair, sn_prec, sn_snow, sn_slp, sn_uoatm, sn_voatm, & 181 & sn_ hpgi, sn_hpgj,&182 & sn_cc, sn_hpgi, sn_hpgj, & 182 183 & ln_NCAR, ln_COARE_3p0, ln_COARE_3p6, ln_ECMWF, & ! bulk algorithm 183 184 & cn_dir , rn_zqt, rn_zu, & … … 260 261 slf_i(jp_tair ) = sn_tair ; slf_i(jp_humi ) = sn_humi 261 262 slf_i(jp_prec ) = sn_prec ; slf_i(jp_snow ) = sn_snow 262 slf_i(jp_slp ) = sn_slp 263 slf_i(jp_slp ) = sn_slp ; slf_i(jp_cc ) = sn_cc 263 264 slf_i(jp_uoatm) = sn_uoatm ; slf_i(jp_voatm) = sn_voatm 264 265 slf_i(jp_hpgi ) = sn_hpgi ; slf_i(jp_hpgj ) = sn_hpgj … … 289 290 ! 290 291 IF( TRIM(sf(jfpr)%clrootname) == 'NOT USED' ) THEN !-- not used field --! (only now allocated and set to default) 291 IF( jfpr == jp_slp 292 IF( jfpr == jp_slp ) THEN 292 293 sf(jfpr)%fnow(:,:,1:ipka) = 101325._wp ! use standard pressure in Pa 293 294 ELSEIF( jfpr == jp_prec .OR. jfpr == jp_snow .OR. jfpr == jp_uoatm .OR. jfpr == jp_voatm ) THEN 294 295 sf(jfpr)%fnow(:,:,1:ipka) = 0._wp ! no precip or no snow or no surface currents 295 ELSEIF( ( jfpr == jp_hpgi .OR. jfpr == jp_hpgj ) .AND. .NOT. ln_abl ) THEN 296 DEALLOCATE( sf(jfpr)%fnow ) ! deallocate as not used in this case 296 ELSEIF( jfpr == jp_hpgi .OR. jfpr == jp_hpgj ) THEN 297 IF( .NOT. ln_abl ) THEN 298 DEALLOCATE( sf(jfpr)%fnow ) ! deallocate as not used in this case 299 ELSE 300 sf(jfpr)%fnow(:,:,1:ipka) = 0._wp 301 ENDIF 302 ELSEIF( jfpr == jp_cc ) THEN 303 sf(jp_cc)%fnow(:,:,1:ipka) = pp_cldf 297 304 ELSE 298 305 WRITE(ctmp1,*) 'sbc_blk_init: no default value defined for field number', jfpr … … 303 310 ! 304 311 IF( sf(jfpr)%freqh > 0. .AND. MOD( NINT(3600. * sf(jfpr)%freqh), nn_fsbc * NINT(rn_Dt) ) /= 0 ) & 305 306 312 & CALL ctl_warn( 'sbc_blk_init: sbcmod timestep rn_Dt*nn_fsbc is NOT a submultiple of atmospheric forcing frequency.', & 313 & ' This is not ideal. You should consider changing either rn_Dt or nn_fsbc value...' ) 307 314 ENDIF 308 315 END DO … … 559 566 ptsk(:,:) = pst(:,:) + rt0 ! by default: skin temperature = "bulk SST" (will remain this way if NCAR algorithm used!) 560 567 568 ! --- cloud cover --- ! 569 cloud_fra(:,:) = sf(jp_cc)%fnow(:,:,1) 570 561 571 ! ----------------------------------------------------------------------------- ! 562 572 ! 0 Wind components and module at T-point relative to the moving ocean ! … … 1019 1029 REAL(wp) :: zcoef_dqlw, zcoef_dqla ! - - 1020 1030 REAL(wp) :: zztmp, zztmp2, z1_rLsub ! - - 1021 REAL(wp) :: zfr1, zfr2 ! local variables1022 1031 REAL(wp), DIMENSION(jpi,jpj,jpl) :: z1_st ! inverse of surface temperature 1023 1032 REAL(wp), DIMENSION(jpi,jpj,jpl) :: z_qlw ! long wave heat flux over ice … … 1028 1037 REAL(wp), DIMENSION(jpi,jpj) :: zqair ! specific humidity of air at z=rn_zqt [kg/kg] !LB 1029 1038 REAL(wp), DIMENSION(jpi,jpj) :: ztmp, ztmp2 1039 REAL(wp), DIMENSION(jpi,jpj) :: ztri 1030 1040 !!--------------------------------------------------------------------- 1031 1041 ! … … 1112 1122 ! --- evaporation minus precipitation --- ! 1113 1123 zsnw(:,:) = 0._wp 1114 CALL ice_ thd_snwblow( (1.-at_i_b(:,:)), zsnw ) ! snow distribution over ice after wind blowing1124 CALL ice_var_snwblow( (1.-at_i_b(:,:)), zsnw ) ! snow distribution over ice after wind blowing 1115 1125 emp_oce(:,:) = ( 1._wp - at_i_b(:,:) ) * zevap(:,:) - ( tprecip(:,:) - sprecip(:,:) ) - sprecip(:,:) * (1._wp - zsnw ) 1116 1126 emp_ice(:,:) = SUM( a_i_b(:,:,:) * evap_ice(:,:,:), dim=3 ) - sprecip(:,:) * zsnw … … 1139 1149 END DO 1140 1150 1141 ! --- shortwave radiation transmitted below the surface (W/m2, see Grenfell Maykut 77) --- ! 1142 zfr1 = ( 0.18 * ( 1.0 - cldf_ice ) + 0.35 * cldf_ice ) ! transmission when hi>10cm 1143 zfr2 = ( 0.82 * ( 1.0 - cldf_ice ) + 0.65 * cldf_ice ) ! zfr2 such that zfr1 + zfr2 to equal 1 1144 ! 1145 WHERE ( phs(:,:,:) <= 0._wp .AND. phi(:,:,:) < 0.1_wp ) ! linear decrease from hi=0 to 10cm 1146 qtr_ice_top(:,:,:) = qsr_ice(:,:,:) * ( zfr1 + zfr2 * ( 1._wp - phi(:,:,:) * 10._wp ) ) 1147 ELSEWHERE( phs(:,:,:) <= 0._wp .AND. phi(:,:,:) >= 0.1_wp ) ! constant (zfr1) when hi>10cm 1148 qtr_ice_top(:,:,:) = qsr_ice(:,:,:) * zfr1 1149 ELSEWHERE ! zero when hs>0 1150 qtr_ice_top(:,:,:) = 0._wp 1151 END WHERE 1152 ! 1153 1151 ! --- shortwave radiation transmitted thru the surface scattering layer (W/m2) --- ! 1152 IF( nn_qtrice == 0 ) THEN 1153 ! formulation derived from Grenfell and Maykut (1977), where transmission rate 1154 ! 1) depends on cloudiness 1155 ! 2) is 0 when there is any snow 1156 ! 3) tends to 1 for thin ice 1157 ztri(:,:) = 0.18 * ( 1.0 - cloud_fra(:,:) ) + 0.35 * cloud_fra(:,:) ! surface transmission when hi>10cm 1158 DO jl = 1, jpl 1159 WHERE ( phs(:,:,jl) <= 0._wp .AND. phi(:,:,jl) < 0.1_wp ) ! linear decrease from hi=0 to 10cm 1160 qtr_ice_top(:,:,jl) = qsr_ice(:,:,jl) * ( ztri(:,:) + ( 1._wp - ztri(:,:) ) * ( 1._wp - phi(:,:,jl) * 10._wp ) ) 1161 ELSEWHERE( phs(:,:,jl) <= 0._wp .AND. phi(:,:,jl) >= 0.1_wp ) ! constant (ztri) when hi>10cm 1162 qtr_ice_top(:,:,jl) = qsr_ice(:,:,jl) * ztri(:,:) 1163 ELSEWHERE ! zero when hs>0 1164 qtr_ice_top(:,:,jl) = 0._wp 1165 END WHERE 1166 ENDDO 1167 ELSEIF( nn_qtrice == 1 ) THEN 1168 ! formulation is derived from the thesis of M. Lebrun (2019). 1169 ! It represents the best fit using several sets of observations 1170 ! It comes with snow conductivities adapted to freezing/melting conditions (see icethd_zdf_bl99.F90) 1171 qtr_ice_top(:,:,:) = 0.3_wp * qsr_ice(:,:,:) 1172 ENDIF 1173 ! 1154 1174 IF( iom_use('evap_ao_cea') .OR. iom_use('hflx_evap_cea') ) THEN 1155 1175 ztmp(:,:) = zevap(:,:) * ( 1._wp - at_i_b(:,:) ) -
NEMO/branches/2020/dev_r13327_KERNEL-06_2_techene_e3/src/OCE/SBC/sbcblk_algo_coare3p0.F90
r13295 r13998 394 394 !!------------------------------------------------------------------- 395 395 ! 396 DO_2D( 1, 1, 1, 1)396 DO_2D( nn_hls, nn_hls, nn_hls, nn_hls ) 397 397 ! 398 398 zw = pwnd(ji,jj) ! wind speed … … 430 430 !!---------------------------------------------------------------------------------- 431 431 ! 432 DO_2D( 1, 1, 1, 1)432 DO_2D( nn_hls, nn_hls, nn_hls, nn_hls ) 433 433 ! 434 434 zta = pzeta(ji,jj) … … 481 481 REAL(wp) :: zta, zphi_h, zphi_c, zpsi_k, zpsi_c, zf, zc, zstab 482 482 ! 483 DO_2D( 1, 1, 1, 1)483 DO_2D( nn_hls, nn_hls, nn_hls, nn_hls ) 484 484 ! 485 485 zta = pzeta(ji,jj) -
NEMO/branches/2020/dev_r13327_KERNEL-06_2_techene_e3/src/OCE/SBC/sbcblk_algo_coare3p6.F90
r13295 r13998 430 430 !!---------------------------------------------------------------------------------- 431 431 ! 432 DO_2D( 1, 1, 1, 1)432 DO_2D( nn_hls, nn_hls, nn_hls, nn_hls ) 433 433 ! 434 434 zta = pzeta(ji,jj) … … 481 481 REAL(wp) :: zta, zphi_h, zphi_c, zpsi_k, zpsi_c, zf, zc, zstab 482 482 ! 483 DO_2D( 1, 1, 1, 1)483 DO_2D( nn_hls, nn_hls, nn_hls, nn_hls ) 484 484 ! 485 485 zta = pzeta(ji,jj) -
NEMO/branches/2020/dev_r13327_KERNEL-06_2_techene_e3/src/OCE/SBC/sbcblk_algo_ecmwf.F90
r13295 r13998 410 410 REAL(wp) :: zzeta, zx, ztmp, psi_unst, psi_stab, stab 411 411 !!---------------------------------------------------------------------------------- 412 DO_2D( 1, 1, 1, 1)412 DO_2D( nn_hls, nn_hls, nn_hls, nn_hls ) 413 413 ! 414 414 zzeta = MIN( pzeta(ji,jj) , 5._wp ) !! Very stable conditions (L positif and big!): … … 455 455 !!---------------------------------------------------------------------------------- 456 456 ! 457 DO_2D( 1, 1, 1, 1)457 DO_2D( nn_hls, nn_hls, nn_hls, nn_hls ) 458 458 ! 459 459 zzeta = MIN(pzeta(ji,jj) , 5._wp) ! Very stable conditions (L positif and big!): -
NEMO/branches/2020/dev_r13327_KERNEL-06_2_techene_e3/src/OCE/SBC/sbcblk_algo_ncar.F90
r13295 r13998 241 241 !!---------------------------------------------------------------------------------- 242 242 ! 243 DO_2D( 1, 1, 1, 1)243 DO_2D( nn_hls, nn_hls, nn_hls, nn_hls ) 244 244 ! 245 245 zw = pw10(ji,jj) … … 277 277 REAL(wp) :: zx2, zx, zstab ! local scalars 278 278 !!---------------------------------------------------------------------------------- 279 DO_2D( 1, 1, 1, 1)279 DO_2D( nn_hls, nn_hls, nn_hls, nn_hls ) 280 280 zx2 = SQRT( ABS( 1._wp - 16._wp*pzeta(ji,jj) ) ) 281 281 zx2 = MAX( zx2 , 1._wp ) … … 308 308 !!---------------------------------------------------------------------------------- 309 309 ! 310 DO_2D( 1, 1, 1, 1)310 DO_2D( nn_hls, nn_hls, nn_hls, nn_hls ) 311 311 zx2 = SQRT( ABS( 1._wp - 16._wp*pzeta(ji,jj) ) ) 312 312 zx2 = MAX( zx2 , 1._wp ) -
NEMO/branches/2020/dev_r13327_KERNEL-06_2_techene_e3/src/OCE/SBC/sbcblk_skin_coare.F90
r13295 r13998 89 89 REAL(wp) :: zQabs, zdlt, zfr, zalfa, zqlat, zus 90 90 !!--------------------------------------------------------------------- 91 DO_2D( 1, 1, 1, 1)91 DO_2D( nn_hls, nn_hls, nn_hls, nn_hls ) 92 92 93 93 zQabs = pQnsol(ji,jj) ! first guess of heat flux absorbed within the viscous sublayer of thicknes delta, … … 156 156 ztime = REAL(nsec_day,wp)/(24._wp*3600._wp) ! time of current time step since 00:00 for current day (UTC) -> ztime = 0 -> 00:00 / ztime = 0.5 -> 12:00 ... 157 157 158 DO_2D( 1, 1, 1, 1)158 DO_2D( nn_hls, nn_hls, nn_hls, nn_hls ) 159 159 160 160 l_exit = .FALSE. -
NEMO/branches/2020/dev_r13327_KERNEL-06_2_techene_e3/src/OCE/SBC/sbcblk_skin_ecmwf.F90
r13295 r13998 95 95 REAL(wp) :: zQabs, zdlt, zfr, zalfa, zus 96 96 !!--------------------------------------------------------------------- 97 DO_2D( 1, 1, 1, 1)97 DO_2D( nn_hls, nn_hls, nn_hls, nn_hls ) 98 98 99 99 zQabs = pQnsol(ji,jj) ! first guess of heat flux absorbed within the viscous sublayer of thicknes delta, … … 173 173 IF( PRESENT(pustk) ) l_pustk_known = .TRUE. 174 174 175 DO_2D( 1, 1, 1, 1)175 DO_2D( nn_hls, nn_hls, nn_hls, nn_hls ) 176 176 177 177 zHwl = Hz_wl(ji,jj) ! first guess for warm-layer depth (and unique..., less advanced than COARE3p6 !) -
NEMO/branches/2020/dev_r13327_KERNEL-06_2_techene_e3/src/OCE/SBC/sbccpl.F90
r13295 r13998 41 41 #endif 42 42 #if defined key_si3 43 USE ice thd_dh ! for CALL ice_thd_snwblow43 USE icevar ! for CALL ice_var_snwblow 44 44 #endif 45 45 ! … … 48 48 USE lib_mpp ! distribued memory computing library 49 49 USE lbclnk ! ocean lateral boundary conditions (or mpp link) 50 51 #if defined key_oasis3 52 USE mod_oasis, ONLY : OASIS_Sent, OASIS_ToRest, OASIS_SentOut, OASIS_ToRestOut 53 #endif 50 54 51 55 IMPLICIT NONE … … 152 156 INTEGER, PARAMETER :: jps_wlev = 32 ! water level 153 157 INTEGER, PARAMETER :: jps_fice1 = 33 ! first-order ice concentration (for semi-implicit coupling of atmos-ice fluxes) 154 INTEGER, PARAMETER :: jps_a_p = 34 ! meltpond area 158 INTEGER, PARAMETER :: jps_a_p = 34 ! meltpond area fraction 155 159 INTEGER, PARAMETER :: jps_ht_p = 35 ! meltpond thickness 156 160 INTEGER, PARAMETER :: jps_kice = 36 ! sea ice effective conductivity … … 159 163 160 164 INTEGER, PARAMETER :: jpsnd = 38 ! total number of fields sent 165 166 #if ! defined key_oasis3 167 ! Dummy variables to enable compilation when oasis3 is not being used 168 INTEGER :: OASIS_Sent = -1 169 INTEGER :: OASIS_SentOut = -1 170 INTEGER :: OASIS_ToRest = -1 171 INTEGER :: OASIS_ToRestOut = -1 172 #endif 161 173 162 174 ! !!** namelist namsbc_cpl ** … … 184 196 LOGICAL :: ln_usecplmask ! use a coupling mask file to merge data received from several models 185 197 ! -> file cplmask.nc with the float variable called cplmask (jpi,jpj,nn_cplmodel) 198 LOGICAL :: ln_scale_ice_flux ! use ice fluxes that are already "ice weighted" ( i.e. multiplied ice concentration) 199 186 200 TYPE :: DYNARR 187 201 REAL(wp), POINTER, DIMENSION(:,:,:) :: z3 … … 191 205 192 206 REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:) :: alb_oce_mix ! ocean albedo sent to atmosphere (mix clear/overcast sky) 207 #if defined key_si3 || defined key_cice 208 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: a_i_last_couple !: Ice fractional area at last coupling time 209 #endif 193 210 194 211 REAL(wp) :: rpref = 101000._wp ! reference atmospheric pressure[N/m2] … … 211 228 !! *** FUNCTION sbc_cpl_alloc *** 212 229 !!---------------------------------------------------------------------- 213 INTEGER :: ierr( 4)230 INTEGER :: ierr(5) 214 231 !!---------------------------------------------------------------------- 215 232 ierr(:) = 0 … … 221 238 #endif 222 239 ALLOCATE( xcplmask(jpi,jpj,0:nn_cplmodel) , STAT=ierr(3) ) 223 ! 224 IF( .NOT. ln_apr_dyn ) ALLOCATE( ssh_ib(jpi,jpj), ssh_ibb(jpi,jpj), apr(jpi, jpj), STAT=ierr(4) ) 240 #if defined key_si3 || defined key_cice 241 ALLOCATE( a_i_last_couple(jpi,jpj,jpl) , STAT=ierr(4) ) 242 #endif 243 ! 244 IF( .NOT. ln_apr_dyn ) ALLOCATE( ssh_ib(jpi,jpj), ssh_ibb(jpi,jpj), apr(jpi, jpj), STAT=ierr(5) ) 225 245 226 246 sbc_cpl_alloc = MAXVAL( ierr ) … … 249 269 REAL(wp), DIMENSION(jpi,jpj) :: zacs, zaos 250 270 !! 251 NAMELIST/namsbc_cpl/ sn_snd_temp , sn_snd_alb , sn_snd_thick, sn_snd_crt , sn_snd_co2 , & 271 NAMELIST/namsbc_cpl/ nn_cplmodel , ln_usecplmask, nn_cats_cpl , ln_scale_ice_flux, & 272 & sn_snd_temp , sn_snd_alb , sn_snd_thick, sn_snd_crt , sn_snd_co2 , & 252 273 & sn_snd_ttilyr, sn_snd_cond , sn_snd_mpnd , sn_snd_sstfrz, sn_snd_thick1, & 253 & sn_snd_ifrac , sn_snd_crtw , sn_snd_wlev , sn_rcv_hsig , sn_rcv_phioc ,&254 & sn_rcv_w10m , sn_rcv_taumod, sn_rcv_tau , sn_rcv_dqnsdt, sn_rcv_qsr ,&274 & sn_snd_ifrac , sn_snd_crtw , sn_snd_wlev , sn_rcv_hsig , sn_rcv_phioc , & 275 & sn_rcv_w10m , sn_rcv_taumod, sn_rcv_tau , sn_rcv_dqnsdt, sn_rcv_qsr , & 255 276 & sn_rcv_sdrfx , sn_rcv_sdrfy , sn_rcv_wper , sn_rcv_wnum , sn_rcv_tauwoc, & 256 & sn_rcv_wdrag , sn_rcv_qns , sn_rcv_emp , sn_rcv_rnf , sn_rcv_cal ,&257 & sn_rcv_iceflx, sn_rcv_co2 , nn_cplmodel , ln_usecplmask, sn_rcv_mslp ,&258 & sn_rcv_icb , sn_rcv_isf , sn_rcv_wfreq , sn_rcv_tauw, nn_cats_cpl ,&277 & sn_rcv_wdrag , sn_rcv_qns , sn_rcv_emp , sn_rcv_rnf , sn_rcv_cal , & 278 & sn_rcv_iceflx, sn_rcv_co2 , sn_rcv_mslp , & 279 & sn_rcv_icb , sn_rcv_isf , sn_rcv_wfreq, sn_rcv_tauw , & 259 280 & sn_rcv_ts_ice 260 261 281 !!--------------------------------------------------------------------- 262 282 ! … … 278 298 ENDIF 279 299 IF( lwp .AND. ln_cpl ) THEN ! control print 300 WRITE(numout,*)' nn_cplmodel = ', nn_cplmodel 301 WRITE(numout,*)' ln_usecplmask = ', ln_usecplmask 302 WRITE(numout,*)' ln_scale_ice_flux = ', ln_scale_ice_flux 303 WRITE(numout,*)' nn_cats_cpl = ', nn_cats_cpl 280 304 WRITE(numout,*)' received fields (mutiple ice categogies)' 281 305 WRITE(numout,*)' 10m wind module = ', TRIM(sn_rcv_w10m%cldes ), ' (', TRIM(sn_rcv_w10m%clcat ), ')' … … 326 350 WRITE(numout,*)' - orientation = ', sn_snd_crtw%clvor 327 351 WRITE(numout,*)' - mesh = ', sn_snd_crtw%clvgrd 328 WRITE(numout,*)' nn_cplmodel = ', nn_cplmodel329 WRITE(numout,*)' ln_usecplmask = ', ln_usecplmask330 WRITE(numout,*)' nn_cats_cpl = ', nn_cats_cpl331 352 ENDIF 332 353 … … 367 388 IF( TRIM( sn_rcv_tau%cldes ) == 'oce only' .OR. TRIM( sn_rcv_tau%cldes ) == 'oce and ice' & 368 389 .OR. TRIM( sn_rcv_tau%cldes ) == 'mixed oce-ice' ) THEN ! avoid working with the atmospheric fields if they are not coupled 369 390 ! 370 391 IF( TRIM( sn_rcv_tau%clvor ) == 'local grid' ) srcv(jpr_otx1:jpr_itz2)%nsgn = -1. 371 392 … … 698 719 ! Change first letter to couple with atmosphere if already coupled OPA 699 720 ! this is nedeed as each variable name used in the namcouple must be unique: 700 ! for example O_Runoff received by OPA from SAS and therefore O_Runoff received by SAS from the Atmosphere721 ! for example O_Runoff received by OPA from SAS and therefore S_Runoff received by SAS from the Atmosphere 701 722 DO jn = 1, jprcv 702 723 IF( srcv(jn)%clname(1:1) == "O" ) srcv(jn)%clname = "S"//srcv(jn)%clname(2:LEN(srcv(jn)%clname)) … … 822 843 END SELECT 823 844 845 ! Initialise ice fractions from last coupling time to zero (needed by Met-Office) 846 #if defined key_si3 || defined key_cice 847 a_i_last_couple(:,:,:) = 0._wp 848 #endif 824 849 ! ! ------------------------- ! 825 850 ! ! Ice Meltponds ! … … 1110 1135 REAL(wp) :: zcdrag = 1.5e-3 ! drag coefficient 1111 1136 REAL(wp) :: zzx, zzy ! temporary variables 1112 REAL(wp), DIMENSION(jpi,jpj) :: ztx, zty, zmsk, zemp, zqns, zqsr 1137 REAL(wp), DIMENSION(jpi,jpj) :: ztx, zty, zmsk, zemp, zqns, zqsr, zcloud_fra 1113 1138 !!---------------------------------------------------------------------- 1114 1139 ! … … 1170 1195 ! 1171 1196 IF( srcv(jpr_otx1)%clgrid == 'T' ) THEN 1172 DO_2D( 0, 0, 0, 0 ) 1197 DO_2D( 0, 0, 0, 0 ) ! T ==> (U,V) 1173 1198 frcv(jpr_otx1)%z3(ji,jj,1) = 0.5 * ( frcv(jpr_otx1)%z3(ji+1,jj ,1) + frcv(jpr_otx1)%z3(ji,jj,1) ) 1174 1199 frcv(jpr_oty1)%z3(ji,jj,1) = 0.5 * ( frcv(jpr_oty1)%z3(ji ,jj+1,1) + frcv(jpr_oty1)%z3(ji,jj,1) ) … … 1224 1249 ENDIF 1225 1250 ENDIF 1226 1251 !!$ ! ! ========================= ! 1252 !!$ SELECT CASE( TRIM( sn_rcv_clouds%cldes ) ) ! cloud fraction ! 1253 !!$ ! ! ========================= ! 1254 !!$ cloud_fra(:,:) = frcv(jpr_clfra)*z3(:,:,1) 1255 !!$ END SELECT 1256 !!$ 1257 zcloud_fra(:,:) = pp_cldf ! should be real cloud fraction instead (as in the bulk) but needs to be read from atm. 1258 IF( ln_mixcpl ) THEN 1259 cloud_fra(:,:) = cloud_fra(:,:) * xcplmask(:,:,0) + zcloud_fra(:,:)* zmsk(:,:) 1260 ELSE 1261 cloud_fra(:,:) = zcloud_fra(:,:) 1262 ENDIF 1263 ! ! ========================= ! 1227 1264 ! u(v)tau and taum will be modified by ice model 1228 1265 ! -> need to be reset before each call of the ice/fsbc … … 1549 1586 p_tauj(:,:) = frcv(jpr_ity1)%z3(:,:,1) 1550 1587 CASE( 'T' ) 1551 DO_2D( 0, 0, 0, 0 ) 1588 DO_2D( 0, 0, 0, 0 ) ! T ==> (U,V) 1552 1589 ! take care of the land-sea mask to avoid "pollution" of coastal stress. p[uv]taui used in frazil and rheology 1553 1590 zztmp1 = 0.5_wp * ( 2. - umask(ji,jj,1) ) * MAX( tmask(ji,jj,1),tmask(ji+1,jj ,1) ) … … 1623 1660 ! 1624 1661 INTEGER :: ji, jj, jl ! dummy loop index 1625 REAL(wp) :: ztri ! local scalar1626 1662 REAL(wp), DIMENSION(jpi,jpj) :: zcptn, zcptrain, zcptsnw, ziceld, zmsk, zsnw 1627 1663 REAL(wp), DIMENSION(jpi,jpj) :: zemp_tot, zemp_ice, zemp_oce, ztprecip, zsprecip , zevap_oce, zdevap_ice 1628 1664 REAL(wp), DIMENSION(jpi,jpj) :: zqns_tot, zqns_oce, zqsr_tot, zqsr_oce, zqprec_ice, zqemp_oce, zqemp_ice 1665 REAL(wp), DIMENSION(jpi,jpj) :: zevap_ice_total 1629 1666 REAL(wp), DIMENSION(jpi,jpj,jpl) :: zqns_ice, zqsr_ice, zdqns_ice, zqevap_ice, zevap_ice, zqtr_ice_top, ztsu 1667 REAL(wp), DIMENSION(jpi,jpj) :: ztri 1630 1668 !!---------------------------------------------------------------------- 1631 1669 ! … … 1647 1685 ztprecip(:,:) = frcv(jpr_rain)%z3(:,:,1) + zsprecip(:,:) ! May need to ensure positive here 1648 1686 zemp_tot(:,:) = frcv(jpr_tevp)%z3(:,:,1) - ztprecip(:,:) 1649 zemp_ice(:,:) = ( frcv(jpr_ievp)%z3(:,:,1) - frcv(jpr_snow)%z3(:,:,1) ) * picefr(:,:)1650 1687 CASE( 'oce and ice' ) ! received fields: jpr_sbpr, jpr_semp, jpr_oemp, jpr_ievp 1651 1688 zemp_tot(:,:) = ziceld(:,:) * frcv(jpr_oemp)%z3(:,:,1) + picefr(:,:) * frcv(jpr_sbpr)%z3(:,:,1) … … 1659 1696 1660 1697 #if defined key_si3 1698 1699 ! --- evaporation over ice (kg/m2/s) --- ! 1700 IF (ln_scale_ice_flux) THEN ! typically met-office requirements 1701 IF (sn_rcv_emp%clcat == 'yes') THEN 1702 WHERE( a_i(:,:,:) > 1.e-10 ) ; zevap_ice(:,:,:) = frcv(jpr_ievp)%z3(:,:,:) * a_i_last_couple(:,:,:) / a_i(:,:,:) 1703 ELSEWHERE ; zevap_ice(:,:,:) = 0._wp 1704 END WHERE 1705 WHERE( picefr(:,:) > 1.e-10 ) ; zevap_ice_total(:,:) = SUM( zevap_ice(:,:,:) * a_i(:,:,:), dim=3 ) / picefr(:,:) 1706 ELSEWHERE ; zevap_ice_total(:,:) = 0._wp 1707 END WHERE 1708 ELSE 1709 WHERE( picefr(:,:) > 1.e-10 ) ; zevap_ice(:,:,1) = frcv(jpr_ievp)%z3(:,:,1) * SUM( a_i_last_couple, dim=3 ) / picefr(:,:) 1710 ELSEWHERE ; zevap_ice(:,:,1) = 0._wp 1711 END WHERE 1712 zevap_ice_total(:,:) = zevap_ice(:,:,1) 1713 DO jl = 2, jpl 1714 zevap_ice(:,:,jl) = zevap_ice(:,:,1) 1715 ENDDO 1716 ENDIF 1717 ELSE 1718 IF (sn_rcv_emp%clcat == 'yes') THEN 1719 zevap_ice(:,:,1:jpl) = frcv(jpr_ievp)%z3(:,:,1:jpl) 1720 WHERE( picefr(:,:) > 1.e-10 ) ; zevap_ice_total(:,:) = SUM( zevap_ice(:,:,:) * a_i(:,:,:), dim=3 ) / picefr(:,:) 1721 ELSEWHERE ; zevap_ice_total(:,:) = 0._wp 1722 END WHERE 1723 ELSE 1724 zevap_ice(:,:,1) = frcv(jpr_ievp)%z3(:,:,1) 1725 zevap_ice_total(:,:) = zevap_ice(:,:,1) 1726 DO jl = 2, jpl 1727 zevap_ice(:,:,jl) = zevap_ice(:,:,1) 1728 ENDDO 1729 ENDIF 1730 ENDIF 1731 1732 IF ( TRIM( sn_rcv_emp%cldes ) == 'conservative' ) THEN 1733 ! For conservative case zemp_ice has not been defined yet. Do it now. 1734 zemp_ice(:,:) = zevap_ice_total(:,:) * picefr(:,:) - frcv(jpr_snow)%z3(:,:,1) * picefr(:,:) 1735 ENDIF 1736 1661 1737 ! zsnw = snow fraction over ice after wind blowing (=picefr if no blowing) 1662 zsnw(:,:) = 0._wp ; CALL ice_ thd_snwblow( ziceld, zsnw )1738 zsnw(:,:) = 0._wp ; CALL ice_var_snwblow( ziceld, zsnw ) 1663 1739 1664 1740 ! --- evaporation minus precipitation corrected (because of wind blowing on snow) --- ! … … 1667 1743 1668 1744 ! --- evaporation over ocean (used later for qemp) --- ! 1669 zevap_oce(:,:) = frcv(jpr_tevp)%z3(:,:,1) - frcv(jpr_ievp)%z3(:,:,1) * picefr(:,:) 1670 1671 ! --- evaporation over ice (kg/m2/s) --- ! 1672 DO jl=1,jpl 1673 IF(sn_rcv_emp%clcat == 'yes') THEN ; zevap_ice(:,:,jl) = frcv(jpr_ievp)%z3(:,:,jl) 1674 ELSE ; zevap_ice(:,:,jl) = frcv(jpr_ievp)%z3(:,:,1 ) ; ENDIF 1675 ENDDO 1745 zevap_oce(:,:) = frcv(jpr_tevp)%z3(:,:,1) - zevap_ice_total(:,:) * picefr(:,:) 1676 1746 1677 1747 ! since the sensitivity of evap to temperature (devap/dT) is not prescribed by the atmosphere, we set it to 0 … … 1751 1821 !! IF( srcv(jpr_rnf)%laction ) CALL iom_put( 'runoffs' , rnf(:,:) * tmask(:,:,1) ) ! runoff 1752 1822 !! IF( srcv(jpr_isf)%laction ) CALL iom_put( 'iceshelf_cea', -fwfisf(:,:) * tmask(:,:,1) ) ! iceshelf 1753 IF( srcv(jpr_cal)%laction ) CALL iom_put( 'calving_cea' , frcv(jpr_cal)%z3(:,:,1) * tmask(:,:,1) ) ! calving1754 IF( srcv(jpr_icb)%laction ) CALL iom_put( 'iceberg_cea' , frcv(jpr_icb)%z3(:,:,1) * tmask(:,:,1) ) ! icebergs1755 IF( iom_use('snowpre') ) CALL iom_put( 'snowpre' , sprecip(:,:) ) ! Snow1756 IF( iom_use('precip') ) CALL iom_put( 'precip' , tprecip(:,:) ) ! total precipitation1757 IF( iom_use('rain') ) CALL iom_put( 'rain' , tprecip(:,:) - sprecip(:,:) ) ! liquid precipitation1758 IF( iom_use('snow_ao_cea') ) CALL iom_put( 'snow_ao_cea' , sprecip(:,:) * ( 1._wp - zsnw(:,:) ) ) ! Snow over ice-free ocean (cell average)1759 IF( iom_use('snow_ai_cea') ) CALL iom_put( 'snow_ai_cea' , sprecip(:,:) * zsnw(:,:) ) ! Snow over sea-ice (cell average)1760 IF( iom_use('rain_ao_cea') ) CALL iom_put( 'rain_ao_cea' , ( tprecip(:,:) - sprecip(:,:) ) * picefr(:,:) ) ! liquid precipitation over ocean (cell average)1761 IF( iom_use('subl_ai_cea') ) CALL iom_put( 'subl_ai_cea' , frcv(jpr_ievp)%z3(:,:,1) * picefr(:,:) * tmask(:,:,1) )! Sublimation over sea-ice (cell average)1762 IF( iom_use('evap_ao_cea') ) CALL iom_put( 'evap_ao_cea' , ( frcv(jpr_tevp)%z3(:,:,1) &1763 & - frcv(jpr_ievp)%z3(:,:,1) * picefr(:,:) ) * tmask(:,:,1) )! ice-free oce evap (cell average)1823 IF( srcv(jpr_cal)%laction ) CALL iom_put( 'calving_cea' , frcv(jpr_cal)%z3(:,:,1) * tmask(:,:,1) ) ! calving 1824 IF( srcv(jpr_icb)%laction ) CALL iom_put( 'iceberg_cea' , frcv(jpr_icb)%z3(:,:,1) * tmask(:,:,1) ) ! icebergs 1825 IF( iom_use('snowpre') ) CALL iom_put( 'snowpre' , sprecip(:,:) ) ! Snow 1826 IF( iom_use('precip') ) CALL iom_put( 'precip' , tprecip(:,:) ) ! total precipitation 1827 IF( iom_use('rain') ) CALL iom_put( 'rain' , tprecip(:,:) - sprecip(:,:) ) ! liquid precipitation 1828 IF( iom_use('snow_ao_cea') ) CALL iom_put( 'snow_ao_cea' , sprecip(:,:) * ( 1._wp - zsnw(:,:) ) ) ! Snow over ice-free ocean (cell average) 1829 IF( iom_use('snow_ai_cea') ) CALL iom_put( 'snow_ai_cea' , sprecip(:,:) * zsnw(:,:) ) ! Snow over sea-ice (cell average) 1830 IF( iom_use('rain_ao_cea') ) CALL iom_put( 'rain_ao_cea' , ( tprecip(:,:) - sprecip(:,:) ) * picefr(:,:) ) ! liquid precipitation over ocean (cell average) 1831 IF( iom_use('subl_ai_cea') ) CALL iom_put( 'subl_ai_cea' , frcv(jpr_ievp)%z3(:,:,1) * picefr(:,:) * tmask(:,:,1) ) ! Sublimation over sea-ice (cell average) 1832 IF( iom_use('evap_ao_cea') ) CALL iom_put( 'evap_ao_cea' , ( frcv(jpr_tevp)%z3(:,:,1) & 1833 & - frcv(jpr_ievp)%z3(:,:,1) * picefr(:,:) ) * tmask(:,:,1) ) ! ice-free oce evap (cell average) 1764 1834 ! note: runoff output is done in sbcrnf (which includes icebergs too) and iceshelf output is done in sbcisf 1765 1835 ! … … 1769 1839 CASE( 'oce only' ) ! the required field is directly provided 1770 1840 zqns_tot(:,:) = frcv(jpr_qnsoce)%z3(:,:,1) 1841 ! For Met Office sea ice non-solar fluxes are already delt with by JULES so setting to zero 1842 ! here so the only flux is the ocean only one. 1843 zqns_ice(:,:,:) = 0._wp 1771 1844 CASE( 'conservative' ) ! the required fields are directly provided 1772 1845 zqns_tot(:,:) = frcv(jpr_qnsmix)%z3(:,:,1) … … 1798 1871 zqns_ice(:,:,jl) = frcv(jpr_qnsmix)%z3(:,:,jl) & 1799 1872 & + frcv(jpr_dqnsdt)%z3(:,:,jl) * ( pist(:,:,jl) - ( ( rt0 + psst(:,:) ) * ziceld(:,:) & 1800 & 1873 & + pist(:,:,jl) * picefr(:,:) ) ) 1801 1874 END DO 1802 1875 ELSE … … 1804 1877 zqns_ice(:,:,jl) = frcv(jpr_qnsmix)%z3(:,:, 1) & 1805 1878 & + frcv(jpr_dqnsdt)%z3(:,:, 1) * ( pist(:,:,jl) - ( ( rt0 + psst(:,:) ) * ziceld(:,:) & 1806 & 1879 & + pist(:,:,jl) * picefr(:,:) ) ) 1807 1880 END DO 1808 1881 ENDIF … … 1910 1983 CASE( 'oce only' ) 1911 1984 zqsr_tot(:,: ) = MAX( 0._wp , frcv(jpr_qsroce)%z3(:,:,1) ) 1985 ! For Met Office sea ice solar fluxes are already delt with by JULES so setting to zero 1986 ! here so the only flux is the ocean only one. 1987 zqsr_ice(:,:,:) = 0._wp 1912 1988 CASE( 'conservative' ) 1913 1989 zqsr_tot(:,: ) = frcv(jpr_qsrmix)%z3(:,:,1) … … 1995 2071 ENDDO 1996 2072 ENDIF 2073 CASE( 'none' ) 2074 zdqns_ice(:,:,:) = 0._wp 1997 2075 END SELECT 1998 2076 … … 2010 2088 ! ! ========================= ! 2011 2089 CASE ('coupled') 2012 IF( ln_mixcpl ) THEN 2013 DO jl=1,jpl 2014 qml_ice(:,:,jl) = qml_ice(:,:,jl) * xcplmask(:,:,0) + frcv(jpr_topm)%z3(:,:,jl) * zmsk(:,:) 2015 qcn_ice(:,:,jl) = qcn_ice(:,:,jl) * xcplmask(:,:,0) + frcv(jpr_botm)%z3(:,:,jl) * zmsk(:,:) 2016 ENDDO 2090 IF (ln_scale_ice_flux) THEN 2091 WHERE( a_i(:,:,:) > 1.e-10_wp ) 2092 qml_ice(:,:,:) = frcv(jpr_topm)%z3(:,:,:) * a_i_last_couple(:,:,:) / a_i(:,:,:) 2093 qcn_ice(:,:,:) = frcv(jpr_botm)%z3(:,:,:) * a_i_last_couple(:,:,:) / a_i(:,:,:) 2094 ELSEWHERE 2095 qml_ice(:,:,:) = 0.0_wp 2096 qcn_ice(:,:,:) = 0.0_wp 2097 END WHERE 2017 2098 ELSE 2018 2099 qml_ice(:,:,:) = frcv(jpr_topm)%z3(:,:,:) … … 2025 2106 IF( .NOT.ln_cndflx ) THEN !== No conduction flux as surface forcing ==! 2026 2107 ! 2027 ! ! ===> used prescribed cloud fraction representative for polar oceans in summer (0.81) 2028 ztri = 0.18 * ( 1.0 - cldf_ice ) + 0.35 * cldf_ice ! surface transmission when hi>10cm (Grenfell Maykut 77) 2029 ! 2030 WHERE ( phs(:,:,:) <= 0._wp .AND. phi(:,:,:) < 0.1_wp ) ! linear decrease from hi=0 to 10cm 2031 zqtr_ice_top(:,:,:) = qsr_ice(:,:,:) * ( ztri + ( 1._wp - ztri ) * ( 1._wp - phi(:,:,:) * 10._wp ) ) 2032 ELSEWHERE( phs(:,:,:) <= 0._wp .AND. phi(:,:,:) >= 0.1_wp ) ! constant (ztri) when hi>10cm 2033 zqtr_ice_top(:,:,:) = qsr_ice(:,:,:) * ztri 2034 ELSEWHERE ! zero when hs>0 2035 zqtr_ice_top(:,:,:) = 0._wp 2036 END WHERE 2108 IF( nn_qtrice == 0 ) THEN 2109 ! formulation derived from Grenfell and Maykut (1977), where transmission rate 2110 ! 1) depends on cloudiness 2111 ! ! ===> used prescribed cloud fraction representative for polar oceans in summer (0.81) 2112 ! ! should be real cloud fraction instead (as in the bulk) but needs to be read from atm. 2113 ! 2) is 0 when there is any snow 2114 ! 3) tends to 1 for thin ice 2115 ztri(:,:) = 0.18 * ( 1.0 - cloud_fra(:,:) ) + 0.35 * cloud_fra(:,:) ! surface transmission when hi>10cm 2116 DO jl = 1, jpl 2117 WHERE ( phs(:,:,jl) <= 0._wp .AND. phi(:,:,jl) < 0.1_wp ) ! linear decrease from hi=0 to 10cm 2118 zqtr_ice_top(:,:,jl) = zqsr_ice(:,:,jl) * ( ztri(:,:) + ( 1._wp - ztri(:,:) ) * ( 1._wp - phi(:,:,jl) * 10._wp ) ) 2119 ELSEWHERE( phs(:,:,jl) <= 0._wp .AND. phi(:,:,jl) >= 0.1_wp ) ! constant (ztri) when hi>10cm 2120 zqtr_ice_top(:,:,jl) = zqsr_ice(:,:,jl) * ztri(:,:) 2121 ELSEWHERE ! zero when hs>0 2122 zqtr_ice_top(:,:,jl) = 0._wp 2123 END WHERE 2124 ENDDO 2125 ELSEIF( nn_qtrice == 1 ) THEN 2126 ! formulation is derived from the thesis of M. Lebrun (2019). 2127 ! It represents the best fit using several sets of observations 2128 ! It comes with snow conductivities adapted to freezing/melting conditions (see icethd_zdf_bl99.F90) 2129 zqtr_ice_top(:,:,:) = 0.3_wp * zqsr_ice(:,:,:) 2130 ENDIF 2037 2131 ! 2038 2132 ELSEIF( ln_cndflx .AND. .NOT.ln_cndemulate ) THEN !== conduction flux as surface forcing ==! 2039 2133 ! 2040 ! 2041 ! 2134 ! ! ===> here we must receive the qtr_ice_top array from the coupler 2135 ! for now just assume zero (fully opaque ice) 2042 2136 zqtr_ice_top(:,:,:) = 0._wp 2043 2137 ! … … 2096 2190 ! 2097 2191 isec = ( kt - nit000 ) * NINT( rn_Dt ) ! date of exchanges 2192 info = OASIS_idle 2098 2193 2099 2194 zfr_l(:,:) = 1.- fr_i(:,:) … … 2234 2329 ENDIF 2235 2330 2331 #if defined key_si3 || defined key_cice 2332 ! If this coupling was successful then save ice fraction for use between coupling points. 2333 ! This is needed for some calculations where the ice fraction at the last coupling point 2334 ! is needed. 2335 IF( info == OASIS_Sent .OR. info == OASIS_ToRest .OR. & 2336 & info == OASIS_SentOut .OR. info == OASIS_ToRestOut ) THEN 2337 IF ( sn_snd_thick%clcat == 'yes' ) THEN 2338 a_i_last_couple(:,:,1:jpl) = a_i(:,:,1:jpl) 2339 ENDIF 2340 ENDIF 2341 #endif 2342 2236 2343 IF( ssnd(jps_fice1)%laction ) THEN 2237 2344 SELECT CASE( sn_snd_thick1%clcat ) … … 2297 2404 SELECT CASE( sn_snd_mpnd%clcat ) 2298 2405 CASE( 'yes' ) 2299 ztmp3(:,:,1:jpl) = a_ip_ frac(:,:,1:jpl)2406 ztmp3(:,:,1:jpl) = a_ip_eff(:,:,1:jpl) 2300 2407 ztmp4(:,:,1:jpl) = h_ip(:,:,1:jpl) 2301 2408 CASE( 'no' ) … … 2303 2410 ztmp4(:,:,:) = 0.0 2304 2411 DO jl=1,jpl 2305 ztmp3(:,:,1) = ztmp3(:,:,1) + a_ip_frac(:,:,jpl) 2306 ztmp4(:,:,1) = ztmp4(:,:,1) + h_ip(:,:,jpl) 2412 ztmp3(:,:,1) = ztmp3(:,:,1) + a_ip_frac(:,:,jpl) 2413 ztmp4(:,:,1) = ztmp4(:,:,1) + h_ip(:,:,jpl) 2307 2414 ENDDO 2308 2415 CASE default ; CALL ctl_stop( 'sbc_cpl_snd: wrong definition of sn_snd_mpnd%clcat' ) -
NEMO/branches/2020/dev_r13327_KERNEL-06_2_techene_e3/src/OCE/SBC/sbcdcy.F90
r13295 r13998 110 110 111 111 imask_night(:,:) = 0 112 DO_2D( 1, 1, 1, 1)112 DO_2D( nn_hls, nn_hls, nn_hls, nn_hls ) 113 113 ztmpm = 0._wp 114 114 IF( ABS(rab(ji,jj)) < 1. ) THEN ! day duration is less than 24h … … 193 193 194 194 zsin = SIN( zdecrad ) ; zcos = COS( zdecrad ) 195 DO_2D( 1, 1, 1, 1)195 DO_2D( nn_hls, nn_hls, nn_hls, nn_hls ) 196 196 ztmp = rad * gphit(ji,jj) 197 197 raa(ji,jj) = SIN( ztmp ) * zsin … … 202 202 ! rab to test if the day time is equal to 0, less than 24h of full day 203 203 rab(:,:) = -raa(:,:) / rbb(:,:) 204 DO_2D( 1, 1, 1, 1)204 DO_2D( nn_hls, nn_hls, nn_hls, nn_hls ) 205 205 IF( ABS(rab(ji,jj)) < 1._wp ) THEN ! day duration is less than 24h 206 206 ! When is it night? … … 226 226 ! Avoid possible infinite scaling factor, associated with very short daylight 227 227 ! periods, by ignoring periods less than 1/1000th of a day (ticket #1040) 228 DO_2D( 1, 1, 1, 1)228 DO_2D( nn_hls, nn_hls, nn_hls, nn_hls ) 229 229 IF( ABS(rab(ji,jj)) < 1._wp ) THEN ! day duration is less than 24h 230 230 rscal(ji,jj) = 0.0_wp -
NEMO/branches/2020/dev_r13327_KERNEL-06_2_techene_e3/src/OCE/SBC/sbcflx.F90
r13295 r13998 29 29 PUBLIC sbc_flx ! routine called by step.F90 30 30 31 INTEGER , PARAMETER :: jpfld = 5 ! maximum number of files to read32 31 INTEGER , PARAMETER :: jp_utau = 1 ! index of wind stress (i-component) file 33 32 INTEGER , PARAMETER :: jp_vtau = 2 ! index of wind stress (j-component) file … … 35 34 INTEGER , PARAMETER :: jp_qsr = 4 ! index of solar heat file 36 35 INTEGER , PARAMETER :: jp_emp = 5 ! index of evaporation-precipation file 36 !!INTEGER , PARAMETER :: jp_sfx = 6 ! index of salt flux flux 37 INTEGER , PARAMETER :: jpfld = 5 !! 6 ! maximum number of files to read 37 38 TYPE(FLD), ALLOCATABLE, DIMENSION(:) :: sf ! structure of input fields (file informations, fields read) 38 39 … … 59 60 !! net downward radiative flux qsr (watt/m2) 60 61 !! net upward freshwater (evapo - precip) emp (kg/m2/s) 62 !! salt flux sfx (pss*dh*rho/dt => g/m2/s) 61 63 !! 62 64 !! CAUTION : - never mask the surface stress fields … … 71 73 !! - emp upward mass flux (evap. - precip.) 72 74 !! - sfx salt flux; set to zero at nit000 but possibly non-zero 73 !! if ice is present75 !! if ice 74 76 !!---------------------------------------------------------------------- 75 77 INTEGER, INTENT(in) :: kt ! ocean time step … … 85 87 CHARACTER(len=100) :: cn_dir ! Root directory for location of flx files 86 88 TYPE(FLD_N), DIMENSION(jpfld) :: slf_i ! array of namelist information structures 87 TYPE(FLD_N) :: sn_utau, sn_vtau, sn_qtot, sn_qsr, sn_emp ! informations about the fields to be read88 NAMELIST/namsbc_flx/ cn_dir, sn_utau, sn_vtau, sn_qtot, sn_qsr, sn_emp 89 TYPE(FLD_N) :: sn_utau, sn_vtau, sn_qtot, sn_qsr, sn_emp !!, sn_sfx ! informations about the fields to be read 90 NAMELIST/namsbc_flx/ cn_dir, sn_utau, sn_vtau, sn_qtot, sn_qsr, sn_emp !!, sn_sfx 89 91 !!--------------------------------------------------------------------- 90 92 ! … … 105 107 slf_i(jp_utau) = sn_utau ; slf_i(jp_vtau) = sn_vtau 106 108 slf_i(jp_qtot) = sn_qtot ; slf_i(jp_qsr ) = sn_qsr 107 slf_i(jp_emp ) = sn_emp 109 slf_i(jp_emp ) = sn_emp !! ; slf_i(jp_sfx ) = sn_sfx 108 110 ! 109 111 ALLOCATE( sf(jpfld), STAT=ierror ) ! set sf structure … … 118 120 CALL fld_fill( sf, slf_i, cn_dir, 'sbc_flx', 'flux formulation for ocean surface boundary condition', 'namsbc_flx' ) 119 121 ! 120 sfx(:,:) = 0.0_wp ! salt flux due to freezing/melting (non-zero only if ice is present)121 !122 122 ENDIF 123 123 … … 126 126 IF( MOD( kt-1, nn_fsbc ) == 0 ) THEN ! update ocean fluxes at each SBC frequency 127 127 128 IF( ln_dm2dc ) THEN ; qsr(:,:) = sbc_dcy( sf(jp_qsr)%fnow(:,:,1) ) ! modify now Qsr to include the diurnal cycle 129 ELSE ; qsr(:,:) = sf(jp_qsr)%fnow(:,:,1) 128 IF( ln_dm2dc ) THEN ! modify now Qsr to include the diurnal cycle 129 qsr(:,:) = sbc_dcy( sf(jp_qsr)%fnow(:,:,1) ) * tmask(ji,jj,1) 130 ELSE 131 DO_2D( 0, 0, 0, 0 ) 132 qsr(ji,jj) = sf(jp_qsr)%fnow(ji,jj,1) * tmask(ji,jj,1) 133 END_2D 130 134 ENDIF 131 DO_2D( 1, 1, 1, 1 ) 132 utau(ji,jj) = sf(jp_utau)%fnow(ji,jj,1) 133 vtau(ji,jj) = sf(jp_vtau)%fnow(ji,jj,1) 134 qns (ji,jj) = sf(jp_qtot)%fnow(ji,jj,1) - sf(jp_qsr)%fnow(ji,jj,1) 135 emp (ji,jj) = sf(jp_emp )%fnow(ji,jj,1) 135 DO_2D( 0, 0, 0, 0 ) ! set the ocean fluxes from read fields 136 utau(ji,jj) = sf(jp_utau)%fnow(ji,jj,1) * umask(ji,jj,1) 137 vtau(ji,jj) = sf(jp_vtau)%fnow(ji,jj,1) * vmask(ji,jj,1) 138 qns (ji,jj) = ( sf(jp_qtot)%fnow(ji,jj,1) - sf(jp_qsr)%fnow(ji,jj,1) ) * tmask(ji,jj,1) 139 emp (ji,jj) = sf(jp_emp )%fnow(ji,jj,1) * tmask(ji,jj,1) 140 !!sfx (ji,jj) = sf(jp_sfx )%fnow(ji,jj,1) * tmask(ji,jj,1) 136 141 END_2D 137 142 ! ! add to qns the heat due to e-p 138 qns(:,:) = qns(:,:) - emp(:,:) * sst_m(:,:) * rcp ! mass flux is at SST 143 !!clem: I do not think it is needed 144 !!qns(:,:) = qns(:,:) - emp(:,:) * sst_m(:,:) * rcp ! mass flux is at SST 139 145 ! 140 qns(:,:) = qns(:,:) * tmask(:,:,1) 141 emp(:,:) = emp(:,:) * tmask(:,:,1) 146 ! clem: without these lbc calls, it seems that the northfold is not ok (true in 3.6, not sure in 4.x) 147 CALL lbc_lnk_multi( 'sbcflx', utau, 'U', -1._wp, vtau, 'V', -1._wp, & 148 & qns, 'T', 1._wp, emp , 'T', 1._wp, qsr, 'T', 1._wp ) !! sfx, 'T', 1._wp ) 142 149 ! 143 ! ! module of wind stress and wind speed at T-point144 zcoef = 1. / ( zrhoa * zcdrag )145 DO_2D( 0, 0, 0, 0 )146 ztx = utau(ji-1,jj ) + utau(ji,jj)147 zty = vtau(ji ,jj-1) + vtau(ji,jj)148 zmod = 0.5 * SQRT( ztx * ztx + zty * zty )149 taum(ji,jj) = zmod150 wndm(ji,jj) = SQRT( zmod * zcoef )151 END_2D152 taum(:,:) = taum(:,:) * tmask(:,:,1) ; wndm(:,:) = wndm(:,:) * tmask(:,:,1)153 CALL lbc_lnk( 'sbcflx', taum(:,:), 'T', 1.0_wp ) ; CALL lbc_lnk( 'sbcflx', wndm(:,:), 'T', 1.0_wp )154 155 150 IF( nitend-nit000 <= 100 .AND. lwp ) THEN ! control print (if less than 100 time-step asked) 156 151 WRITE(numout,*) … … 166 161 ! 167 162 ENDIF 163 ! ! module of wind stress and wind speed at T-point 164 ! Note the use of 0.5*(2-umask) in order to unmask the stress along coastlines 165 zcoef = 1. / ( zrhoa * zcdrag ) 166 DO_2D( 0, 0, 0, 0 ) 167 ztx = ( utau(ji-1,jj ) + utau(ji,jj) ) * 0.5_wp * ( 2._wp - MIN( umask(ji-1,jj ,1), umask(ji,jj,1) ) ) 168 zty = ( vtau(ji ,jj-1) + vtau(ji,jj) ) * 0.5_wp * ( 2._wp - MIN( vmask(ji ,jj-1,1), vmask(ji,jj,1) ) ) 169 zmod = 0.5_wp * SQRT( ztx * ztx + zty * zty ) * tmask(ji,jj,1) 170 taum(ji,jj) = zmod 171 wndm(ji,jj) = SQRT( zmod * zcoef ) !!clem: not used? 172 END_2D 173 ! 174 CALL lbc_lnk_multi( 'sbcflx', taum, 'T', 1._wp, wndm, 'T', 1._wp ) 168 175 ! 169 176 END SUBROUTINE sbc_flx -
NEMO/branches/2020/dev_r13327_KERNEL-06_2_techene_e3/src/OCE/SBC/sbcfwb.F90
r13286 r13998 94 94 snwice_mass_b(:,:) = 0.e0 ! no sea-ice model is being used : no snow+ice mass 95 95 snwice_mass (:,:) = 0.e0 96 snwice_fmass (:,:) = 0.e0 96 97 #endif 97 98 ! -
NEMO/branches/2020/dev_r13327_KERNEL-06_2_techene_e3/src/OCE/SBC/sbcmod.F90
r13895 r13998 99 99 & nn_ice , ln_ice_embd, & 100 100 & ln_traqsr, ln_dm2dc , & 101 & ln_rnf , nn_fwb , ln_ssr , ln_apr_dyn,&102 & ln_wave , ln_cdgw , ln_sdw , ln_tauwoc , ln_stcor ,&101 & ln_rnf , nn_fwb , ln_ssr , ln_apr_dyn, & 102 & ln_wave , ln_cdgw , ln_sdw , ln_tauwoc , ln_stcor , & 103 103 & ln_tauw , nn_lsm, nn_sdrift 104 104 !!---------------------------------------------------------------------- … … 119 119 #if defined key_mpp_mpi 120 120 ncom_fsbc = nn_fsbc ! make nn_fsbc available for lib_mpp 121 #endif 122 #if ! defined key_si3 123 IF( nn_ice == 2 ) nn_ice = 0 ! without key key_si3 you cannot use si3... 121 124 #endif 122 125 ! … … 226 229 CASE DEFAULT !- not supported 227 230 END SELECT 228 IF( ln_diurnal .AND. .NOT. ln_blk) CALL ctl_stop( "sbc_init: diurnal flux processing only implemented for bulk forcing" )231 IF( ln_diurnal .AND. .NOT. (ln_blk.OR.ln_abl) ) CALL ctl_stop( "sbc_init: diurnal flux processing only implemented for bulk forcing" ) 229 232 ! 230 233 ! !** allocate and set required variables … … 243 246 ENDIF 244 247 ! 245 246 248 IF( nn_ice == 0 ) THEN !* No sea-ice in the domain : ice fraction is always zero 247 249 IF( nn_components /= jp_iam_opa ) fr_i(:,:) = 0._wp ! except for OPA in SAS-OPA coupled case … … 250 252 sfx (:,:) = 0._wp !* salt flux due to freezing/melting 251 253 fmmflx(:,:) = 0._wp !* freezing minus melting flux 254 cloud_fra(:,:) = pp_cldf !* cloud fraction over sea ice (used in si3) 252 255 253 256 taum(:,:) = 0._wp !* wind stress module (needed in GLS in case of reduced restart) … … 334 337 IF( l_sbc_clo ) CALL sbc_clo_init ! closed sea surface initialisation 335 338 ! 336 IF( ln_blk ) CALL sbc_blk_init ! bulk formulae initialization337 338 IF( ln_abl ) CALL sbc_abl_init ! Atmospheric Boundary Layer (ABL)339 340 IF( ln_ssr ) CALL sbc_ssr_init ! Sea-Surface Restoring initialization339 IF( ln_blk ) CALL sbc_blk_init ! bulk formulae initialization 340 341 IF( ln_abl ) CALL sbc_abl_init ! Atmospheric Boundary Layer (ABL) 342 343 IF( ln_ssr ) CALL sbc_ssr_init ! Sea-Surface Restoring initialization 341 344 ! 342 345 ! … … 561 564 ENDIF 562 565 ! 563 CALL iom_put( "utau", utau ) ! i-wind stress (stress can be updated at each time step in sea-ice)564 CALL iom_put( "vtau", vtau ) ! j-wind stress565 !566 566 IF(sn_cfctl%l_prtctl) THEN ! print mean trends (used for debugging) 567 567 CALL prt_ctl(tab2d_1=fr_i , clinfo1=' fr_i - : ', mask1=tmask ) -
NEMO/branches/2020/dev_r13327_KERNEL-06_2_techene_e3/src/OCE/SBC/sbcrnf.F90
r13895 r13998 214 214 END_2D 215 215 ELSE !* variable volume case 216 DO_2D( 1, 1, 1, 1 ) 216 DO_2D( 1, 1, 1, 1 ) ! update the depth over which runoffs are distributed 217 217 h_rnf(ji,jj) = 0._wp 218 DO jk = 1, nk_rnf(ji,jj) ! recalculates h_rnf to be the depth in metres218 DO jk = 1, nk_rnf(ji,jj) ! recalculates h_rnf to be the depth in metres 219 219 h_rnf(ji,jj) = h_rnf(ji,jj) + e3t(ji,jj,jk,Kmm) ! to the bottom of the relevant grid box 220 220 END DO … … 373 373 ENDIF 374 374 END_2D 375 DO_2D( 1, 1, 1, 1 ) 375 DO_2D( 1, 1, 1, 1 ) ! set the associated depth 376 376 h_rnf(ji,jj) = 0._wp 377 377 DO jk = 1, nk_rnf(ji,jj) … … 403 403 WHERE( zrnfcl(:,:,1) > 0._wp ) h_rnf(:,:) = zacoef * zrnfcl(:,:,1) ! compute depth for all runoffs 404 404 ! 405 DO_2D( 1, 1, 1, 1 ) 405 DO_2D( 1, 1, 1, 1 ) ! take in account min depth of ocean rn_hmin 406 406 IF( zrnfcl(ji,jj,1) > 0._wp ) THEN 407 407 jk = mbkt(ji,jj) … … 422 422 END_2D 423 423 ! 424 DO_2D( 1, 1, 1, 1 ) 424 DO_2D( 1, 1, 1, 1 ) ! set the associated depth 425 425 h_rnf(ji,jj) = 0._wp 426 426 DO jk = 1, nk_rnf(ji,jj) -
NEMO/branches/2020/dev_r13327_KERNEL-06_2_techene_e3/src/OCE/SBC/sbcwave.F90
r13295 r13998 106 106 !!--------------------------------------------------------------------- 107 107 ! 108 ALLOCATE( ze3divh(jpi,jpj,jpk ) )108 ALLOCATE( ze3divh(jpi,jpj,jpkm1) ) ! jpkm1 -> avoid lbc_lnk on jpk that is not defined 109 109 ALLOCATE( zk_t(jpi,jpj), zk_u(jpi,jpj), zk_v(jpi,jpj), zu0_sd(jpi,jpj), zv0_sd(jpi,jpj) ) 110 110 ! … … 121 121 zk_t(ji,jj) = ABS( tsd2d(ji,jj) ) / MAX( ABS( 5.97_wp*ztransp ), 0.0000001_wp ) 122 122 END_2D 123 DO_2D( 1, 0, 1, 0 ) 123 DO_2D( 1, 0, 1, 0 ) ! exp. wave number & Stokes drift velocity at u- & v-points 124 124 zk_u(ji,jj) = 0.5_wp * ( zk_t(ji,jj) + zk_t(ji+1,jj) ) 125 125 zk_v(ji,jj) = 0.5_wp * ( zk_t(ji,jj) + zk_t(ji,jj+1) ) … … 164 164 zsqrtpi = SQRT(rpi) 165 165 z_two_thirds = 2.0_wp / 3.0_wp 166 DO_3D( 0, 0, 0, 0, 1, jpkm1 ) 166 DO_3D( 0, 0, 0, 0, 1, jpkm1 ) ! exp. wave number & Stokes drift velocity at u- & v-points 167 167 zbot_u = ( gdepw(ji,jj,jk+1,Kmm) + gdepw(ji+1,jj,jk+1,Kmm) ) ! 2 * bottom depth 168 168 zbot_v = ( gdepw(ji,jj,jk+1,Kmm) + gdepw(ji,jj+1,jk+1,Kmm) ) ! 2 * bottom depth … … 204 204 ! !== vertical Stokes Drift 3D velocity ==! 205 205 ! 206 DO_3D( 0, 1, 0, 1, 1, jpkm1 ) 206 DO_3D( 0, 1, 0, 1, 1, jpkm1 ) ! Horizontal e3*divergence 207 207 ze3divh(ji,jj,jk) = ( e2u(ji ,jj) * e3u(ji ,jj,jk,Kmm) * usd(ji ,jj,jk) & 208 208 & - e2u(ji-1,jj) * e3u(ji-1,jj,jk,Kmm) * usd(ji-1,jj,jk) & -
NEMO/branches/2020/dev_r13327_KERNEL-06_2_techene_e3/src/OCE/TRA/eosbn2.F90
r13295 r13998 873 873 IF( ln_timing ) CALL timing_start('bn2') 874 874 ! 875 DO_3D( 1, 1, 1, 1, 2, jpkm1 ) 875 DO_3D( 1, 1, 1, 1, 2, jpkm1 ) ! interior points only (2=< jk =< jpkm1 ); surface and bottom value set to zero one for all in istate.F90 876 876 zrw = ( gdepw(ji,jj,jk ,Kmm) - gdept(ji,jj,jk,Kmm) ) & 877 877 & / ( gdept(ji,jj,jk-1,Kmm) - gdept(ji,jj,jk,Kmm) ) -
NEMO/branches/2020/dev_r13327_KERNEL-06_2_techene_e3/src/OCE/TRA/traadv_cen.F90
r13295 r13998 112 112 ztu(:,:,jpk) = 0._wp ! Bottom value : flux set to zero 113 113 ztv(:,:,jpk) = 0._wp 114 DO_3D( 0, 0, 0, 0, 1, jpkm1 ) 114 DO_3D( 0, 0, 0, 0, 1, jpkm1 ) ! masked gradient 115 115 ztu(ji,jj,jk) = ( pt(ji+1,jj ,jk,jn,Kmm) - pt(ji,jj,jk,jn,Kmm) ) * umask(ji,jj,jk) 116 116 ztv(ji,jj,jk) = ( pt(ji ,jj+1,jk,jn,Kmm) - pt(ji,jj,jk,jn,Kmm) ) * vmask(ji,jj,jk) … … 118 118 CALL lbc_lnk_multi( 'traadv_cen', ztu, 'U', -1.0_wp , ztv, 'V', -1.0_wp ) ! Lateral boundary cond. 119 119 ! 120 DO_3D( 0, 0, 1, 0, 1, jpkm1 )120 DO_3D( 0, 0, 0, 0, 1, jpkm1 ) ! Horizontal advective fluxes 121 121 zC2t_u = pt(ji,jj,jk,jn,Kmm) + pt(ji+1,jj ,jk,jn,Kmm) ! C2 interpolation of T at u- & v-points (x2) 122 122 zC2t_v = pt(ji,jj,jk,jn,Kmm) + pt(ji ,jj+1,jk,jn,Kmm) … … 128 128 zwy(ji,jj,jk) = 0.5_wp * pV(ji,jj,jk) * zC4t_v 129 129 END_3D 130 CALL lbc_lnk_multi( 'traadv_cen', zwx, 'U', -1. , zwy, 'V', -1. ) 130 131 ! 131 132 CASE DEFAULT 132 CALL ctl_stop( 'traadv_ fct: wrong value for nn_fct' )133 CALL ctl_stop( 'traadv_cen: wrong value for nn_cen' ) 133 134 END SELECT 134 135 ! … … 158 159 ENDIF 159 160 ! 160 DO_3D( 0, 0, 0, 0, 1, jpkm1 ) 161 DO_3D( 0, 0, 0, 0, 1, jpkm1 ) !-- Divergence of advective fluxes --! 161 162 pt(ji,jj,jk,jn,Krhs) = pt(ji,jj,jk,jn,Krhs) & 162 163 & - ( zwx(ji,jj,jk) - zwx(ji-1,jj ,jk ) & … … 165 166 & * r1_e1e2t(ji,jj) / e3t(ji,jj,jk,Kmm) 166 167 END_3D 167 ! ! trend diagnostics168 ! ! trend diagnostics 168 169 IF( l_trd ) THEN 169 170 CALL trd_tra( kt, Kmm, Krhs, cdtype, jn, jptra_xad, zwx, pU, pt(:,:,:,jn,Kmm) ) -
NEMO/branches/2020/dev_r13327_KERNEL-06_2_techene_e3/src/OCE/TRA/traadv_fct.F90
r13295 r13998 160 160 zwy(ji,jj,jk) = 0.5 * ( zfp_vj * pt(ji,jj,jk,jn,Kbb) + zfm_vj * pt(ji ,jj+1,jk,jn,Kbb) ) 161 161 END_3D 162 ! !* upstream tracer flux in the k direction *!163 DO_3D( 1, 1, 1, 1, 2, jpkm1 ) 162 ! !* upstream tracer flux in the k direction *! 163 DO_3D( 1, 1, 1, 1, 2, jpkm1 ) ! Interior value ( multiplied by wmask) 164 164 zfp_wk = pW(ji,jj,jk) + ABS( pW(ji,jj,jk) ) 165 165 zfm_wk = pW(ji,jj,jk) - ABS( pW(ji,jj,jk) ) 166 166 zwz(ji,jj,jk) = 0.5 * ( zfp_wk * pt(ji,jj,jk,jn,Kbb) + zfm_wk * pt(ji,jj,jk-1,jn,Kbb) ) * wmask(ji,jj,jk) 167 167 END_3D 168 IF( ln_linssh ) THEN ! top ocean value (only in linear free surface as zwz has been w-masked)169 IF( ln_isfcav ) THEN ! top of the ice-shelf cavities and at the ocean surface168 IF( ln_linssh ) THEN ! top ocean value (only in linear free surface as zwz has been w-masked) 169 IF( ln_isfcav ) THEN ! top of the ice-shelf cavities and at the ocean surface 170 170 DO_2D( 1, 1, 1, 1 ) 171 171 zwz(ji,jj, mikt(ji,jj) ) = pW(ji,jj,mikt(ji,jj)) * pt(ji,jj,mikt(ji,jj),jn,Kbb) ! linear free surface 172 172 END_2D 173 ELSE ! no cavities: only at the ocean surface173 ELSE ! no cavities: only at the ocean surface 174 174 DO_2D( 1, 1, 1, 1 ) 175 175 zwz(ji,jj,1) = pW(ji,jj,1) * pt(ji,jj,1,jn,Kbb) … … 178 178 ENDIF 179 179 ! 180 DO_3D( 0, 0, 0, 0, 1, jpkm1 ) 181 ! ! total intermediate advective trends180 DO_3D( 0, 0, 0, 0, 1, jpkm1 ) !* trend and after field with monotonic scheme 181 ! ! total intermediate advective trends 182 182 ztra = - ( zwx(ji,jj,jk) - zwx(ji-1,jj ,jk ) & 183 183 & + zwy(ji,jj,jk) - zwy(ji ,jj-1,jk ) & 184 184 & + zwz(ji,jj,jk) - zwz(ji ,jj ,jk+1) ) * r1_e1e2t(ji,jj) 185 ! ! update and guess with monotonic sheme185 ! ! update and guess with monotonic sheme 186 186 pt(ji,jj,jk,jn,Krhs) = pt(ji,jj,jk,jn,Krhs) + ztra & 187 187 & / e3t(ji,jj,jk,Kmm ) * tmask(ji,jj,jk) … … 194 194 ! 195 195 ztw(:,:,1) = 0._wp ; ztw(:,:,jpk) = 0._wp ; 196 DO_3D( 0, 0, 0, 0, 2, jpkm1 ) 196 DO_3D( 0, 0, 0, 0, 2, jpkm1 ) ! Interior value ( multiplied by wmask) 197 197 zfp_wk = wi(ji,jj,jk) + ABS( wi(ji,jj,jk) ) 198 198 zfm_wk = wi(ji,jj,jk) - ABS( wi(ji,jj,jk) ) … … 227 227 zltv(:,:,jpk) = 0._wp 228 228 DO jk = 1, jpkm1 ! Laplacian 229 DO_2D( 1, 0, 1, 0 ) 229 DO_2D( 1, 0, 1, 0 ) ! 1st derivative (gradient) 230 230 ztu(ji,jj,jk) = ( pt(ji+1,jj ,jk,jn,Kmm) - pt(ji,jj,jk,jn,Kmm) ) * umask(ji,jj,jk) 231 231 ztv(ji,jj,jk) = ( pt(ji ,jj+1,jk,jn,Kmm) - pt(ji,jj,jk,jn,Kmm) ) * vmask(ji,jj,jk) 232 232 END_2D 233 DO_2D( 0, 0, 0, 0 ) 233 DO_2D( 0, 0, 0, 0 ) ! 2nd derivative * 1/ 6 234 234 zltu(ji,jj,jk) = ( ztu(ji,jj,jk) + ztu(ji-1,jj,jk) ) * r1_6 235 235 zltv(ji,jj,jk) = ( ztv(ji,jj,jk) + ztv(ji,jj-1,jk) ) * r1_6 … … 238 238 CALL lbc_lnk_multi( 'traadv_fct', zltu, 'T', 1.0_wp , zltv, 'T', 1.0_wp ) ! Lateral boundary cond. (unchanged sgn) 239 239 ! 240 DO_3D( 1, 0, 1, 0, 1, jpkm1 ) 240 DO_3D( 1, 0, 1, 0, 1, jpkm1 ) ! Horizontal advective fluxes 241 241 zC2t_u = pt(ji,jj,jk,jn,Kmm) + pt(ji+1,jj ,jk,jn,Kmm) ! 2 x C2 interpolation of T at u- & v-points 242 242 zC2t_v = pt(ji,jj,jk,jn,Kmm) + pt(ji ,jj+1,jk,jn,Kmm) 243 ! ! C4 minus upstream advective fluxes243 ! ! C4 minus upstream advective fluxes 244 244 zwx(ji,jj,jk) = 0.5_wp * pU(ji,jj,jk) * ( zC2t_u + zltu(ji,jj,jk) - zltu(ji+1,jj,jk) ) - zwx(ji,jj,jk) 245 245 zwy(ji,jj,jk) = 0.5_wp * pV(ji,jj,jk) * ( zC2t_v + zltv(ji,jj,jk) - zltv(ji,jj+1,jk) ) - zwy(ji,jj,jk) … … 249 249 ztu(:,:,jpk) = 0._wp ! Bottom value : flux set to zero 250 250 ztv(:,:,jpk) = 0._wp 251 DO_3D( 1, 0, 1, 0, 1, jpkm1 ) 251 DO_3D( 1, 0, 1, 0, 1, jpkm1 ) ! 1st derivative (gradient) 252 252 ztu(ji,jj,jk) = ( pt(ji+1,jj ,jk,jn,Kmm) - pt(ji,jj,jk,jn,Kmm) ) * umask(ji,jj,jk) 253 253 ztv(ji,jj,jk) = ( pt(ji ,jj+1,jk,jn,Kmm) - pt(ji,jj,jk,jn,Kmm) ) * vmask(ji,jj,jk) … … 255 255 CALL lbc_lnk_multi( 'traadv_fct', ztu, 'U', -1.0_wp , ztv, 'V', -1.0_wp ) ! Lateral boundary cond. (unchanged sgn) 256 256 ! 257 DO_3D( 0, 0, 0, 0, 1, jpkm1 ) 257 DO_3D( 0, 0, 0, 0, 1, jpkm1 ) ! Horizontal advective fluxes 258 258 zC2t_u = pt(ji,jj,jk,jn,Kmm) + pt(ji+1,jj ,jk,jn,Kmm) ! 2 x C2 interpolation of T at u- & v-points (x2) 259 259 zC2t_v = pt(ji,jj,jk,jn,Kmm) + pt(ji ,jj+1,jk,jn,Kmm) … … 288 288 ! 289 289 IF ( ll_zAimp ) THEN 290 DO_3D( 0, 0, 0, 0, 1, jpkm1 ) 291 ! ! total intermediate advective trends290 DO_3D( 0, 0, 0, 0, 1, jpkm1 ) !* trend and after field with monotonic scheme 291 ! ! total intermediate advective trends 292 292 ztra = - ( zwx(ji,jj,jk) - zwx(ji-1,jj ,jk ) & 293 293 & + zwy(ji,jj,jk) - zwy(ji ,jj-1,jk ) & … … 298 298 CALL tridia_solver( zwdia, zwsup, zwinf, ztw, ztw , 0 ) 299 299 ! 300 DO_3D( 0, 0, 0, 0, 2, jpkm1 ) 300 DO_3D( 0, 0, 0, 0, 2, jpkm1 ) ! Interior value ( multiplied by wmask) 301 301 zfp_wk = wi(ji,jj,jk) + ABS( wi(ji,jj,jk) ) 302 302 zfm_wk = wi(ji,jj,jk) - ABS( wi(ji,jj,jk) ) … … 324 324 ! 325 325 ztw(:,:,1) = 0._wp ; ztw(:,:,jpk) = 0._wp 326 DO_3D( 0, 0, 0, 0, 2, jpkm1 ) 326 DO_3D( 0, 0, 0, 0, 2, jpkm1 ) ! Interior value ( multiplied by wmask) 327 327 zfp_wk = wi(ji,jj,jk) + ABS( wi(ji,jj,jk) ) 328 328 zfm_wk = wi(ji,jj,jk) - ABS( wi(ji,jj,jk) ) … … 454 454 pbb(ji,jj,jk) = pbb(ji,jj,jk) * ( zcv * zav + ( 1._wp - zcv) * zbv ) 455 455 456 ! monotonic flux in the k direction, i.e. pcc457 ! -------------------------------------------456 ! monotonic flux in the k direction, i.e. pcc 457 ! ------------------------------------------- 458 458 za = MIN( 1., zbetdo(ji,jj,jk+1), zbetup(ji,jj,jk) ) 459 459 zb = MIN( 1., zbetup(ji,jj,jk+1), zbetdo(ji,jj,jk) ) … … 481 481 !!---------------------------------------------------------------------- 482 482 483 DO_3D( 1, 1, 1, 1, 3, jpkm1 ) 483 DO_3D( 1, 1, 1, 1, 3, jpkm1 ) !== build the three diagonal matrix ==! 484 484 zwd (ji,jj,jk) = 4._wp 485 485 zwi (ji,jj,jk) = 1._wp … … 495 495 END_3D 496 496 ! 497 jk = 2 497 jk = 2 ! Switch to second order centered at top 498 498 DO_2D( 1, 1, 1, 1 ) 499 499 zwd (ji,jj,jk) = 1._wp … … 504 504 ! 505 505 ! !== tridiagonal solve ==! 506 DO_2D( 1, 1, 1, 1 ) 506 DO_2D( 1, 1, 1, 1 ) ! first recurrence 507 507 zwt(ji,jj,2) = zwd(ji,jj,2) 508 508 END_2D … … 511 511 END_3D 512 512 ! 513 DO_2D( 1, 1, 1, 1 ) 513 DO_2D( 1, 1, 1, 1 ) ! second recurrence: Zk = Yk - Ik / Tk-1 Zk-1 514 514 pt_out(ji,jj,2) = zwrm(ji,jj,2) 515 515 END_2D … … 518 518 END_3D 519 519 520 DO_2D( 1, 1, 1, 1 ) 520 DO_2D( 1, 1, 1, 1 ) ! third recurrence: Xk = (Zk - Sk Xk+1 ) / Tk 521 521 pt_out(ji,jj,jpkm1) = pt_out(ji,jj,jpkm1) / zwt(ji,jj,jpkm1) 522 522 END_2D … … 546 546 ! !== build the three diagonal matrix & the RHS ==! 547 547 ! 548 DO_3D( 0, 0, 0, 0, 3, jpkm1 ) 548 DO_3D( 0, 0, 0, 0, 3, jpkm1 ) ! interior (from jk=3 to jpk-1) 549 549 zwd (ji,jj,jk) = 3._wp * wmask(ji,jj,jk) + 1._wp ! diagonal 550 550 zwi (ji,jj,jk) = wmask(ji,jj,jk) ! lower diagonal … … 565 565 END IF 566 566 ! 567 DO_2D( 0, 0, 0, 0 ) 567 DO_2D( 0, 0, 0, 0 ) ! 2nd order centered at top & bottom 568 568 ikt = mikt(ji,jj) + 1 ! w-point below the 1st wet point 569 569 ikb = MAX(mbkt(ji,jj), 2) ! - above the last wet point … … 582 582 ! !== tridiagonal solver ==! 583 583 ! 584 DO_2D( 0, 0, 0, 0 ) 584 DO_2D( 0, 0, 0, 0 ) !* 1st recurrence: Tk = Dk - Ik Sk-1 / Tk-1 585 585 zwt(ji,jj,2) = zwd(ji,jj,2) 586 586 END_2D … … 589 589 END_3D 590 590 ! 591 DO_2D( 0, 0, 0, 0 ) 591 DO_2D( 0, 0, 0, 0 ) !* 2nd recurrence: Zk = Yk - Ik / Tk-1 Zk-1 592 592 pt_out(ji,jj,2) = zwrm(ji,jj,2) 593 593 END_2D … … 596 596 END_3D 597 597 598 DO_2D( 0, 0, 0, 0 ) 598 DO_2D( 0, 0, 0, 0 ) !* 3d recurrence: Xk = (Zk - Sk Xk+1 ) / Tk 599 599 pt_out(ji,jj,jpkm1) = pt_out(ji,jj,jpkm1) / zwt(ji,jj,jpkm1) 600 600 END_2D … … 638 638 kstart = 1 + klev 639 639 ! 640 DO_2D( 0, 0, 0, 0 ) 640 DO_2D( 0, 0, 0, 0 ) !* 1st recurrence: Tk = Dk - Ik Sk-1 / Tk-1 641 641 zwt(ji,jj,kstart) = pD(ji,jj,kstart) 642 642 END_2D … … 645 645 END_3D 646 646 ! 647 DO_2D( 0, 0, 0, 0 ) 647 DO_2D( 0, 0, 0, 0 ) !* 2nd recurrence: Zk = Yk - Ik / Tk-1 Zk-1 648 648 pt_out(ji,jj,kstart) = pRHS(ji,jj,kstart) 649 649 END_2D … … 652 652 END_3D 653 653 654 DO_2D( 0, 0, 0, 0 ) 654 DO_2D( 0, 0, 0, 0 ) !* 3d recurrence: Xk = (Zk - Sk Xk+1 ) / Tk 655 655 pt_out(ji,jj,jpkm1) = pt_out(ji,jj,jpkm1) / zwt(ji,jj,jpkm1) 656 656 END_2D -
NEMO/branches/2020/dev_r13327_KERNEL-06_2_techene_e3/src/OCE/TRA/traadv_mus.F90
r13295 r13998 148 148 END_3D 149 149 ! 150 DO_3D( 0, 1, 0, 1, 1, jpkm1 ) 150 DO_3D( 0, 1, 0, 1, 1, jpkm1 ) !-- Slopes limitation 151 151 zslpx(ji,jj,jk) = SIGN( 1.0_wp, zslpx(ji,jj,jk) ) * MIN( ABS( zslpx(ji ,jj,jk) ), & 152 152 & 2.*ABS( zwx (ji-1,jj,jk) ), & … … 157 157 END_3D 158 158 ! 159 DO_3D( 0, 0, 0, 0, 1, jpkm1 ) 159 DO_3D( 0, 0, 0, 0, 1, jpkm1 ) !-- MUSCL horizontal advective fluxes 160 160 ! MUSCL fluxes 161 161 z0u = SIGN( 0.5_wp, pU(ji,jj,jk) ) … … 175 175 CALL lbc_lnk_multi( 'traadv_mus', zwx, 'U', -1.0_wp , zwy, 'V', -1.0_wp ) ! lateral boundary conditions (changed sign) 176 176 ! 177 DO_3D( 0, 0, 0, 0, 1, jpkm1 ) 177 DO_3D( 0, 0, 0, 0, 1, jpkm1 ) !-- Tracer advective trend 178 178 pt(ji,jj,jk,jn,Krhs) = pt(ji,jj,jk,jn,Krhs) - ( zwx(ji,jj,jk) - zwx(ji-1,jj ,jk ) & 179 179 & + zwy(ji,jj,jk) - zwy(ji ,jj-1,jk ) ) & … … 204 204 & * ( 0.25 + SIGN( 0.25_wp, zwx(ji,jj,jk) * zwx(ji,jj,jk+1) ) ) 205 205 END_3D 206 DO_3D( 1, 1, 1, 1, 2, jpkm1 ) 206 DO_3D( 1, 1, 1, 1, 2, jpkm1 ) !-- Slopes limitation 207 207 zslpx(ji,jj,jk) = SIGN( 1.0_wp, zslpx(ji,jj,jk) ) * MIN( ABS( zslpx(ji,jj,jk ) ), & 208 208 & 2.*ABS( zwx (ji,jj,jk+1) ), & 209 209 & 2.*ABS( zwx (ji,jj,jk ) ) ) 210 210 END_3D 211 DO_3D( 0, 0, 0, 0, 1, jpk-2 ) 211 DO_3D( 0, 0, 0, 0, 1, jpk-2 ) !-- vertical advective flux 212 212 z0w = SIGN( 0.5_wp, pW(ji,jj,jk+1) ) 213 213 zalpha = 0.5 + z0w … … 227 227 ENDIF 228 228 ! 229 DO_3D( 0, 0, 0, 0, 1, jpkm1 ) 229 DO_3D( 0, 0, 0, 0, 1, jpkm1 ) !-- vertical advective trend 230 230 pt(ji,jj,jk,jn,Krhs) = pt(ji,jj,jk,jn,Krhs) - ( zwx(ji,jj,jk) - zwx(ji,jj,jk+1) ) & 231 231 & * r1_e1e2t(ji,jj) / e3t(ji,jj,jk,Kmm) -
NEMO/branches/2020/dev_r13327_KERNEL-06_2_techene_e3/src/OCE/TRA/traadv_qck.F90
r13295 r13998 142 142 ! 143 143 !!gm why not using a SHIFT instruction... 144 DO_3D( 0, 0, 0, 0, 1, jpkm1 ) 144 DO_3D( 0, 0, 0, 0, 1, jpkm1 ) !--- Computation of the ustream and downstream value of the tracer and the mask 145 145 zfc(ji,jj,jk) = pt(ji-1,jj,jk,jn,Kbb) ! Upstream in the x-direction for the tracer 146 146 zfd(ji,jj,jk) = pt(ji+1,jj,jk,jn,Kbb) ! Downstream in the x-direction for the tracer … … 327 327 ! ! =========== 328 328 ! 329 DO_3D( 0, 0, 0, 0, 2, jpkm1 ) 329 DO_3D( 0, 0, 0, 0, 2, jpkm1 ) !* Interior point (w-masked 2nd order centered flux) 330 330 zwz(ji,jj,jk) = 0.5 * pW(ji,jj,jk) * ( pt(ji,jj,jk-1,jn,Kmm) + pt(ji,jj,jk,jn,Kmm) ) * wmask(ji,jj,jk) 331 331 END_3D … … 340 340 ENDIF 341 341 ! 342 DO_3D( 0, 0, 0, 0, 1, jpkm1 ) 342 DO_3D( 0, 0, 0, 0, 1, jpkm1 ) !== Tracer flux divergence added to the general trend ==! 343 343 pt(ji,jj,jk,jn,Krhs) = pt(ji,jj,jk,jn,Krhs) - ( zwz(ji,jj,jk) - zwz(ji,jj,jk+1) ) & 344 344 & * r1_e1e2t(ji,jj) / e3t(ji,jj,jk,Kmm) -
NEMO/branches/2020/dev_r13327_KERNEL-06_2_techene_e3/src/OCE/TRA/traadv_ubs.F90
r13295 r13998 124 124 ! ! =========== 125 125 ! 126 DO jk = 1, jpkm1 !== horizontal laplacian of before tracer ==!127 DO_2D( 1, 0, 1, 0 ) 126 DO jk = 1, jpkm1 !== horizontal laplacian of before tracer ==! 127 DO_2D( 1, 0, 1, 0 ) ! First derivative (masked gradient) 128 128 zeeu = e2_e1u(ji,jj) * e3u(ji,jj,jk,Kmm) * umask(ji,jj,jk) 129 129 zeev = e1_e2v(ji,jj) * e3v(ji,jj,jk,Kmm) * vmask(ji,jj,jk) … … 131 131 ztv(ji,jj,jk) = zeev * ( pt(ji ,jj+1,jk,jn,Kbb) - pt(ji,jj,jk,jn,Kbb) ) 132 132 END_2D 133 DO_2D( 0, 0, 0, 0 ) 133 DO_2D( 0, 0, 0, 0 ) ! Second derivative (divergence) 134 134 zcoef = 1._wp / ( 6._wp * e3t(ji,jj,jk,Kmm) ) 135 135 zltu(ji,jj,jk) = ( ztu(ji,jj,jk) - ztu(ji-1,jj,jk) ) * zcoef … … 140 140 CALL lbc_lnk( 'traadv_ubs', zltu, 'T', 1.0_wp ) ; CALL lbc_lnk( 'traadv_ubs', zltv, 'T', 1.0_wp ) ! Lateral boundary cond. (unchanged sgn) 141 141 ! 142 DO_3D( 1, 0, 1, 0, 1, jpkm1 ) 143 zfp_ui = pU(ji,jj,jk) + ABS( pU(ji,jj,jk) ) ! upstream transport (x2)142 DO_3D( 1, 0, 1, 0, 1, jpkm1 ) !== Horizontal advective fluxes ==! (UBS) 143 zfp_ui = pU(ji,jj,jk) + ABS( pU(ji,jj,jk) ) ! upstream transport (x2) 144 144 zfm_ui = pU(ji,jj,jk) - ABS( pU(ji,jj,jk) ) 145 145 zfp_vj = pV(ji,jj,jk) + ABS( pV(ji,jj,jk) ) … … 166 166 ! 167 167 zltu(:,:,:) = pt(:,:,:,jn,Krhs) - zltu(:,:,:) ! Horizontal advective trend used in vertical 2nd order FCT case 168 ! ! and/or in trend diagnostic (l_trd=T)168 ! ! and/or in trend diagnostic (l_trd=T) 169 169 ! 170 170 IF( l_trd ) THEN ! trend diagnostics … … 187 187 IF( l_trd ) zltv(:,:,:) = pt(:,:,:,jn,Krhs) ! store pt(:,:,:,:,Krhs) if trend diag. 188 188 ! 189 ! !* upstream advection with initial mass fluxes & intermediate update ==!189 ! !* upstream advection with initial mass fluxes & intermediate update ==! 190 190 DO_3D( 1, 1, 1, 1, 2, jpkm1 ) 191 191 zfp_wk = pW(ji,jj,jk) + ABS( pW(ji,jj,jk) ) … … 193 193 ztw(ji,jj,jk) = 0.5_wp * ( zfp_wk * pt(ji,jj,jk,jn,Kbb) + zfm_wk * pt(ji,jj,jk-1,jn,Kbb) ) * wmask(ji,jj,jk) 194 194 END_3D 195 IF( ln_linssh ) THEN ! top ocean value (only in linear free surface as ztw has been w-masked)196 IF( ln_isfcav ) THEN ! top of the ice-shelf cavities and at the ocean surface195 IF( ln_linssh ) THEN ! top ocean value (only in linear free surface as ztw has been w-masked) 196 IF( ln_isfcav ) THEN ! top of the ice-shelf cavities and at the ocean surface 197 197 DO_2D( 1, 1, 1, 1 ) 198 198 ztw(ji,jj, mikt(ji,jj) ) = pW(ji,jj,mikt(ji,jj)) * pt(ji,jj,mikt(ji,jj),jn,Kbb) ! linear free surface 199 199 END_2D 200 ELSE ! no cavities: only at the ocean surface200 ELSE ! no cavities: only at the ocean surface 201 201 ztw(:,:,1) = pW(:,:,1) * pt(:,:,1,jn,Kbb) 202 202 ENDIF 203 203 ENDIF 204 204 ! 205 DO_3D( 0, 0, 0, 0, 1, jpkm1 ) 205 DO_3D( 0, 0, 0, 0, 1, jpkm1 ) !* trend and after field with monotonic scheme 206 206 ztak = - ( ztw(ji,jj,jk) - ztw(ji,jj,jk+1) ) & 207 207 & * r1_e1e2t(ji,jj) / e3t(ji,jj,jk,Kmm) … … 230 230 END SELECT 231 231 ! 232 DO_3D( 0, 0, 0, 0, 1, jpkm1 ) 232 DO_3D( 0, 0, 0, 0, 1, jpkm1 ) ! final trend with corrected fluxes 233 233 pt(ji,jj,jk,jn,Krhs) = pt(ji,jj,jk,jn,Krhs) - ( ztw(ji,jj,jk) - ztw(ji,jj,jk+1) ) & 234 234 & * r1_e1e2t(ji,jj) / e3t(ji,jj,jk,Kmm) 235 235 END_3D 236 236 ! 237 IF( l_trd ) THEN ! vertical advective trend diagnostics238 DO_3D( 0, 0, 0, 0, 1, jpkm1 ) 237 IF( l_trd ) THEN ! vertical advective trend diagnostics 238 DO_3D( 0, 0, 0, 0, 1, jpkm1 ) ! (compute -w.dk[ptn]= -dk[w.ptn] + ptn.dk[w]) 239 239 zltv(ji,jj,jk) = pt(ji,jj,jk,jn,Krhs) - zltv(ji,jj,jk) & 240 240 & + pt(ji,jj,jk,jn,Kmm) * ( pW(ji,jj,jk) - pW(ji,jj,jk+1) ) & -
NEMO/branches/2020/dev_r13327_KERNEL-06_2_techene_e3/src/OCE/TRA/trabbl.F90
r13295 r13998 197 197 END_2D 198 198 ! 199 DO_2D( 0, 0, 0, 0 ) 199 DO_2D( 0, 0, 0, 0 ) ! Compute the trend 200 200 ik = mbkt(ji,jj) ! bottom T-level index 201 201 pt_rhs(ji,jj,ik,jn) = pt_rhs(ji,jj,ik,jn) & … … 358 358 IF( nn_bbl_ldf == 1 ) THEN ! diffusive bbl ! 359 359 ! !-------------------! 360 DO_2D( 1, 0, 1, 0 ) 360 DO_2D( 1, 0, 1, 0 ) ! (criteria for non zero flux: grad(rho).grad(h) < 0 ) 361 361 ! ! i-direction 362 362 za = zab(ji+1,jj,jp_tem) + zab(ji,jj,jp_tem) ! 2*(alpha,beta) at u-point … … 388 388 ! 389 389 CASE( 1 ) != use of upper velocity 390 DO_2D( 1, 0, 1, 0 ) 390 DO_2D( 1, 0, 1, 0 ) ! criteria: grad(rho).grad(h)<0 and grad(rho).grad(h)<0 391 391 ! ! i-direction 392 392 za = zab(ji+1,jj,jp_tem) + zab(ji,jj,jp_tem) ! 2*(alpha,beta) at u-point … … 417 417 CASE( 2 ) != bbl velocity = F( delta rho ) 418 418 zgbbl = grav * rn_gambbl 419 DO_2D( 1, 0, 1, 0 ) 419 DO_2D( 1, 0, 1, 0 ) ! criteria: rho_up > rho_down 420 420 ! ! i-direction 421 421 ! down-slope T-point i/k-index (deep) & up-slope T-point i/k-index (shelf) … … 505 505 IF( tra_bbl_alloc() /= 0 ) CALL ctl_stop( 'STOP', 'tra_bbl_init : unable to allocate arrays' ) 506 506 ! 507 IF( nn_bbl_adv == 1 ) WRITE(numout,*) ' * Advective BBL using upper velocity' 508 IF( nn_bbl_adv == 2 ) WRITE(numout,*) ' * Advective BBL using velocity = F( delta rho)' 507 IF(lwp) THEN 508 IF( nn_bbl_adv == 1 ) WRITE(numout,*) ' * Advective BBL using upper velocity' 509 IF( nn_bbl_adv == 2 ) WRITE(numout,*) ' * Advective BBL using velocity = F( delta rho)' 510 ENDIF 509 511 ! 510 512 ! !* vertical index of "deep" bottom u- and v-points 511 DO_2D( 1, 0, 1, 0 ) 513 DO_2D( 1, 0, 1, 0 ) ! (the "shelf" bottom k-indices are mbku and mbkv) 512 514 mbku_d(ji,jj) = MAX( mbkt(ji+1,jj ) , mbkt(ji,jj) ) ! >= 1 as mbkt=1 over land 513 515 mbkv_d(ji,jj) = MAX( mbkt(ji ,jj+1) , mbkt(ji,jj) ) … … 530 532 END_2D 531 533 ! 532 DO_2D( 1, 0, 1, 0 ) 534 DO_2D( 1, 0, 1, 0 ) !* bbl thickness at u- (v-) point; minimum of top & bottom e3u_0 (e3v_0) 533 535 e3u_bbl_0(ji,jj) = MIN( e3u_0(ji,jj,mbkt(ji+1,jj )), e3u_0(ji,jj,mbkt(ji,jj)) ) 534 536 e3v_bbl_0(ji,jj) = MIN( e3v_0(ji,jj,mbkt(ji ,jj+1)), e3v_0(ji,jj,mbkt(ji,jj)) ) -
NEMO/branches/2020/dev_r13327_KERNEL-06_2_techene_e3/src/OCE/TRA/traldf_iso.F90
r13295 r13998 205 205 END_3D 206 206 IF( ln_zps ) THEN ! botton and surface ocean correction of the horizontal gradient 207 DO_2D( 1, 0, 1, 0 ) 207 DO_2D( 1, 0, 1, 0 ) ! bottom correction (partial bottom cell) 208 208 zdit(ji,jj,mbku(ji,jj)) = pgu(ji,jj,jn) 209 209 zdjt(ji,jj,mbkv(ji,jj)) = pgv(ji,jj,jn) … … 229 229 ELSE ; zdkt(:,:) = ( pt(:,:,jk-1,jn) - pt(:,:,jk,jn) ) * wmask(:,:,jk) 230 230 ENDIF 231 DO_2D( 1, 0, 1, 0 ) 231 DO_2D( 1, 0, 1, 0 ) !== Horizontal fluxes 232 232 zabe1 = pahu(ji,jj,jk) * e2_e1u(ji,jj) * e3u(ji,jj,jk,Kmm) 233 233 zabe2 = pahv(ji,jj,jk) * e1_e2v(ji,jj) * e3v(ji,jj,jk,Kmm) … … 250 250 END_2D 251 251 ! 252 DO_2D( 0, 0, 0, 0 ) 252 DO_2D( 0, 0, 0, 0 ) !== horizontal divergence and add to pta 253 253 pt_rhs(ji,jj,jk,jn) = pt_rhs(ji,jj,jk,jn) & 254 254 & + zsign * ( zftu(ji,jj,jk) - zftu(ji-1,jj,jk) + zftv(ji,jj,jk) - zftv(ji,jj-1,jk) ) & … … 266 266 ztfw(:,:, 1 ) = 0._wp ; ztfw(:,:,jpk) = 0._wp 267 267 268 DO_3D( 0, 0, 0, 0, 2, jpkm1 ) 268 DO_3D( 0, 0, 0, 0, 2, jpkm1 ) ! interior (2=<jk=<jpk-1) 269 269 ! 270 270 zmsku = wmask(ji,jj,jk) / MAX( umask(ji ,jj,jk-1) + umask(ji-1,jj,jk) & … … 311 311 ENDIF 312 312 ! 313 DO_3D( 0, 0, 0, 0, 1, jpkm1 ) 313 DO_3D( 0, 0, 0, 0, 1, jpkm1 ) !== Divergence of vertical fluxes added to pta ==! 314 314 pt_rhs(ji,jj,jk,jn) = pt_rhs(ji,jj,jk,jn) + zsign * ( ztfw (ji,jj,jk) - ztfw(ji,jj,jk+1) ) * r1_e1e2t(ji,jj) & 315 315 & / e3t(ji,jj,jk,Kmm) -
NEMO/branches/2020/dev_r13327_KERNEL-06_2_techene_e3/src/OCE/TRA/traldf_lap_blp.F90
r13295 r13998 108 108 ! ! =========== ! 109 109 ! 110 DO_3D( 1, 0, 1, 0, 1, jpkm1 ) 110 DO_3D( 1, 0, 1, 0, 1, jpkm1 ) !== First derivative (gradient) ==! 111 111 ztu(ji,jj,jk) = zaheeu(ji,jj,jk) * ( pt(ji+1,jj ,jk,jn) - pt(ji,jj,jk,jn) ) 112 112 ztv(ji,jj,jk) = zaheev(ji,jj,jk) * ( pt(ji ,jj+1,jk,jn) - pt(ji,jj,jk,jn) ) 113 113 END_3D 114 IF( ln_zps ) THEN ! set gradient at bottom/top ocean level115 DO_2D( 1, 0, 1, 0 ) 114 IF( ln_zps ) THEN ! set gradient at bottom/top ocean level 115 DO_2D( 1, 0, 1, 0 ) ! bottom 116 116 ztu(ji,jj,mbku(ji,jj)) = zaheeu(ji,jj,mbku(ji,jj)) * pgu(ji,jj,jn) 117 117 ztv(ji,jj,mbkv(ji,jj)) = zaheev(ji,jj,mbkv(ji,jj)) * pgv(ji,jj,jn) 118 118 END_2D 119 IF( ln_isfcav ) THEN ! top in ocean cavities only119 IF( ln_isfcav ) THEN ! top in ocean cavities only 120 120 DO_2D( 1, 0, 1, 0 ) 121 121 IF( miku(ji,jj) > 1 ) ztu(ji,jj,miku(ji,jj)) = zaheeu(ji,jj,miku(ji,jj)) * pgui(ji,jj,jn) … … 125 125 ENDIF 126 126 ! 127 DO_3D( 0, 0, 0, 0, 1, jpkm1 ) 127 DO_3D( 0, 0, 0, 0, 1, jpkm1 ) !== Second derivative (divergence) added to the general tracer trends ==! 128 128 pt_rhs(ji,jj,jk,jn) = pt_rhs(ji,jj,jk,jn) + ( ztu(ji,jj,jk) - ztu(ji-1,jj,jk) & 129 129 & + ztv(ji,jj,jk) - ztv(ji,jj-1,jk) ) & -
NEMO/branches/2020/dev_r13327_KERNEL-06_2_techene_e3/src/OCE/TRA/traldf_triad.F90
r13295 r13998 211 211 zftv(:,:,:) = 0._wp 212 212 ! 213 DO_3D( 1, 0, 1, 0, 1, jpkm1 ) 213 DO_3D( 1, 0, 1, 0, 1, jpkm1 ) !== before lateral T & S gradients at T-level jk ==! 214 214 zdit(ji,jj,jk) = ( pt(ji+1,jj ,jk,jn) - pt(ji,jj,jk,jn) ) * umask(ji,jj,jk) 215 215 zdjt(ji,jj,jk) = ( pt(ji ,jj+1,jk,jn) - pt(ji,jj,jk,jn) ) * vmask(ji,jj,jk) 216 216 END_3D 217 217 IF( ln_zps .AND. l_grad_zps ) THEN ! partial steps: correction at top/bottom ocean level 218 DO_2D( 1, 0, 1, 0 ) 218 DO_2D( 1, 0, 1, 0 ) ! bottom level 219 219 zdit(ji,jj,mbku(ji,jj)) = pgu(ji,jj,jn) 220 220 zdjt(ji,jj,mbkv(ji,jj)) = pgv(ji,jj,jn) … … 361 361 ENDIF 362 362 ! 363 DO_3D( 0, 0, 0, 0, 1, jpkm1 ) 363 DO_3D( 0, 0, 0, 0, 1, jpkm1 ) !== Divergence of vertical fluxes added to pta ==! 364 364 pt_rhs(ji,jj,jk,jn) = pt_rhs(ji,jj,jk,jn) & 365 365 & + zsign * ( ztfw(ji,jj,jk+1) - ztfw(ji,jj,jk) ) & -
NEMO/branches/2020/dev_r13327_KERNEL-06_2_techene_e3/src/OCE/TRA/tramle.F90
r13295 r13998 100 100 inml_mle(:,:) = mbkt(:,:) + 1 ! init. to number of ocean w-level (T-level + 1) 101 101 IF ( nla10 > 0 ) THEN ! avoid case where first level is thicker than 10m 102 DO_3DS( 1, 1, 1, 1, jpkm1, nlb10, -1 ) 102 DO_3DS( 1, 1, 1, 1, jpkm1, nlb10, -1 ) ! from the bottom to nlb10 (10m) 103 103 IF( rhop(ji,jj,jk) > rhop(ji,jj,nla10) + rn_rho_c_mle ) inml_mle(ji,jj) = jk ! Mixed layer 104 104 END_3D … … 110 110 zbm (:,:) = 0._wp 111 111 zn2 (:,:) = 0._wp 112 DO_3D( 1, 1, 1, 1, 1, ikmax ) 112 DO_3D( 1, 1, 1, 1, 1, ikmax ) ! MLD and mean buoyancy and N2 over the mixed layer 113 113 zc = e3t(ji,jj,jk,Kmm) * REAL( MIN( MAX( 0, inml_mle(ji,jj)-jk ) , 1 ) ) ! zc being 0 outside the ML t-points 114 114 zmld(ji,jj) = zmld(ji,jj) + zc … … 182 182 zpsi_vw(:,:,:) = 0._wp 183 183 ! 184 DO_3D( 1, 0, 1, 0, 2, ikmax ) 184 DO_3D( 1, 0, 1, 0, 2, ikmax ) ! start from 2 : surface value = 0 185 185 zcuw = 1._wp - ( gdepw(ji+1,jj,jk,Kmm) + gdepw(ji,jj,jk,Kmm) ) * zhu(ji,jj) 186 186 zcvw = 1._wp - ( gdepw(ji,jj+1,jk,Kmm) + gdepw(ji,jj,jk,Kmm) ) * zhv(ji,jj) … … 196 196 ! !== transport increased by the MLE induced transport ==! 197 197 DO jk = 1, ikmax 198 DO_2D( 1, 0, 1, 0 ) 198 DO_2D( 1, 0, 1, 0 ) ! CAUTION pu,pv must be defined at row/column i=1 / j=1 199 199 pu(ji,jj,jk) = pu(ji,jj,jk) + ( zpsi_uw(ji,jj,jk) - zpsi_uw(ji,jj,jk+1) ) 200 200 pv(ji,jj,jk) = pv(ji,jj,jk) + ( zpsi_vw(ji,jj,jk) - zpsi_vw(ji,jj,jk+1) ) … … 283 283 IF( ierr /= 0 ) CALL ctl_stop( 'tra_adv_mle_init: failed to allocate arrays' ) 284 284 z1_t2 = 1._wp / ( rn_time * rn_time ) 285 DO_2D( 0, 1, 0, 1 ) 285 DO_2D( 0, 1, 0, 1 ) ! "coriolis+ time^-1" at u- & v-points 286 286 zfu = ( ff_f(ji,jj) + ff_f(ji,jj-1) ) * 0.5_wp 287 287 zfv = ( ff_f(ji,jj) + ff_f(ji-1,jj) ) * 0.5_wp -
NEMO/branches/2020/dev_r13327_KERNEL-06_2_techene_e3/src/OCE/TRA/tranpc.F90
r13295 r13998 103 103 inpcc = 0 104 104 ! 105 DO_2D( 0, 0, 0, 0 ) 105 DO_2D( 0, 0, 0, 0 ) ! interior column only 106 106 ! 107 107 IF( tmask(ji,jj,2) == 1 ) THEN ! At least 2 ocean points -
NEMO/branches/2020/dev_r13327_KERNEL-06_2_techene_e3/src/OCE/TRA/traqsr.F90
r13895 r13998 63 63 REAL(wp) :: xsi1r ! inverse of rn_si1 64 64 ! 65 REAL(wp) , DIMENSION(3,61):: rkrgb ! tabulated attenuation coefficients for RGB absorption65 REAL(wp) , PUBLIC, DIMENSION(3,61) :: rkrgb ! tabulated attenuation coefficients for RGB absorption 66 66 TYPE(FLD), ALLOCATABLE, DIMENSION(:) :: sf_chl ! structure of input Chl (file informations, fields read) 67 67 … … 231 231 END_2D 232 232 ! 233 ! * interior equi-partition in R-G-B depending on vertical profile of Chl233 ! !* interior equi-partition in R-G-B depending on vertical profile of Chl 234 234 DO_3D( 0, 0, 0, 0, 2, nksr + 1 ) 235 235 ze3t = e3t(ji,jj,jk-1,Kmm) … … 246 246 END_3D 247 247 ! 248 DO_3D( 0, 0, 0, 0, 1, nksr ) 248 DO_3D( 0, 0, 0, 0, 1, nksr ) !* now qsr induced heat content 249 249 qsr_hc(ji,jj,jk) = r1_rho0_rcp * ( ztmp3d(ji,jj,jk) - ztmp3d(ji,jj,jk+1) ) 250 250 END_3D … … 256 256 zz0 = rn_abs * r1_rho0_rcp ! surface equi-partition in 2-bands 257 257 zz1 = ( 1. - rn_abs ) * r1_rho0_rcp 258 DO_3D( 0, 0, 0, 0, 1, nksr ) 258 DO_3D( 0, 0, 0, 0, 1, nksr ) ! solar heat absorbed at T-point in the top 400m 259 259 zc0 = zz0 * EXP( -gdepw(ji,jj,jk ,Kmm)*xsi0r ) + zz1 * EXP( -gdepw(ji,jj,jk ,Kmm)*xsi1r ) 260 260 zc1 = zz0 * EXP( -gdepw(ji,jj,jk+1,Kmm)*xsi0r ) + zz1 * EXP( -gdepw(ji,jj,jk+1,Kmm)*xsi1r ) … … 264 264 END SELECT 265 265 ! 266 ! !-----------------------------! 267 ! ! update to the temp. trend ! 266 268 ! !-----------------------------! 267 269 DO_3D( 0, 0, 0, 0, 1, nksr ) … … 417 419 IF( .NOT.lk_top ) CALL ctl_stop( 'No bio model : ln_qsr_bio = true impossible ' ) 418 420 ! 421 CALL trc_oce_rgb( rkrgb ) ! tabulated attenuation coef. 422 ! 423 nksr = trc_oce_ext_lev( r_si2, 33._wp ) ! level of light extinction 424 ! 425 IF(lwp) WRITE(numout,*) ' level of light extinction = ', nksr, ' ref depth = ', gdepw_1d(nksr+1), ' m' 426 ! 419 427 END SELECT 420 428 ! -
NEMO/branches/2020/dev_r13327_KERNEL-06_2_techene_e3/src/OCE/TRA/trasbc.F90
r13895 r13998 128 128 END_2D 129 129 IF( ln_linssh ) THEN !* linear free surface 130 DO_2D( 0, 0, 0, 0 )130 DO_2D( 0, 1, 0, 0 ) !==>> add concentration/dilution effect due to constant volume cell 131 131 sbc_tsc(ji,jj,jp_tem) = sbc_tsc(ji,jj,jp_tem) + r1_rho0 * emp(ji,jj) * pts(ji,jj,1,jp_tem,Kmm) 132 132 sbc_tsc(ji,jj,jp_sal) = sbc_tsc(ji,jj,jp_sal) + r1_rho0 * emp(ji,jj) * pts(ji,jj,1,jp_sal,Kmm) 133 END_2D 133 END_2D !==>> output c./d. term 134 134 IF( iom_use('emp_x_sst') ) CALL iom_put( "emp_x_sst", emp (:,:) * pts(:,:,1,jp_tem,Kmm) ) 135 135 IF( iom_use('emp_x_sss') ) CALL iom_put( "emp_x_sss", emp (:,:) * pts(:,:,1,jp_sal,Kmm) ) -
NEMO/branches/2020/dev_r13327_KERNEL-06_2_techene_e3/src/OCE/TRA/trazdf.F90
r13295 r13998 208 208 ! used as a work space array: its value is modified. 209 209 ! 210 DO_2D( 0, 0, 0, 0 ) 210 DO_2D( 0, 0, 0, 0 ) !* 1st recurrence: Tk = Dk - Ik Sk-1 / Tk-1 (increasing k) ! done one for all passive tracers (so included in the IF instruction) 211 211 zwt(ji,jj,1) = zwd(ji,jj,1) 212 212 END_2D … … 217 217 ENDIF 218 218 ! 219 DO_2D( 0, 0, 0, 0 ) 219 DO_2D( 0, 0, 0, 0 ) !* 2nd recurrence: Zk = Yk - Ik / Tk-1 Zk-1 220 220 pt(ji,jj,1,jn,Kaa) = e3t(ji,jj,1,Kbb) * pt(ji,jj,1,jn,Kbb) & 221 221 & + p2dt * e3t(ji,jj,1,Kmm) * pt(ji,jj,1,jn,Krhs) … … 227 227 END_3D 228 228 ! 229 DO_2D( 0, 0, 0, 0 ) 229 DO_2D( 0, 0, 0, 0 ) !* 3d recurrence: Xk = (Zk - Sk Xk+1 ) / Tk (result is the after tracer) 230 230 pt(ji,jj,jpkm1,jn,Kaa) = pt(ji,jj,jpkm1,jn,Kaa) / zwt(ji,jj,jpkm1) * tmask(ji,jj,jpkm1) 231 231 END_2D -
NEMO/branches/2020/dev_r13327_KERNEL-06_2_techene_e3/src/OCE/TRA/zpshde.F90
r13295 r13998 167 167 CALL eos( ztj, zhj, zrj ) ! at the partial step depth output in zri, zrj 168 168 ! 169 DO_2D( 1, 0, 1, 0 ) 169 DO_2D( 1, 0, 1, 0 ) ! Gradient of density at the last level 170 170 iku = mbku(ji,jj) 171 171 ikv = mbkv(ji,jj) … … 329 329 CALL eos( ztj, zhj, zrj ) 330 330 331 DO_2D( 1, 0, 1, 0 ) 331 DO_2D( 1, 0, 1, 0 ) ! Gradient of density at the last level 332 332 iku = mbku(ji,jj) 333 333 ikv = mbkv(ji,jj) … … 420 420 CALL eos( ztj, zhj, zrj ) ! at the partial step depth output in zri, zrj 421 421 ! 422 DO_2D( 1, 0, 1, 0 ) 422 DO_2D( 1, 0, 1, 0 ) ! Gradient of density at the last level 423 423 iku = miku(ji,jj) 424 424 ikv = mikv(ji,jj) -
NEMO/branches/2020/dev_r13327_KERNEL-06_2_techene_e3/src/OCE/TRD/trddyn.F90
r13295 r13998 124 124 z3dx(:,:,:) = 0._wp ! U.dxU & V.dyV (approximation) 125 125 z3dy(:,:,:) = 0._wp 126 DO_3D( 0, 0, 0, 0, 1, jpkm1 ) 126 DO_3D( 0, 0, 0, 0, 1, jpkm1 ) ! no mask as un,vn are masked 127 127 z3dx(ji,jj,jk) = uu(ji,jj,jk,Kmm) * ( uu(ji+1,jj,jk,Kmm) - uu(ji-1,jj,jk,Kmm) ) / ( 2._wp * e1u(ji,jj) ) 128 128 z3dy(ji,jj,jk) = vv(ji,jj,jk,Kmm) * ( vv(ji,jj+1,jk,Kmm) - vv(ji,jj-1,jk,Kmm) ) / ( 2._wp * e2v(ji,jj) ) -
NEMO/branches/2020/dev_r13327_KERNEL-06_2_techene_e3/src/OCE/TRD/trdglo.F90
r13295 r13998 86 86 ! 87 87 CASE( 'TRA' ) !== Tracers (T & S) ==! 88 DO_3D( 1, 1, 1, 1, 1, jpkm1 ) 88 DO_3D( 1, 1, 1, 1, 1, jpkm1 ) ! global sum of mask volume trend and trend*T (including interior mask) 89 89 zvm = e1e2t(ji,jj) * e3t(ji,jj,jk,Kmm) * tmask(ji,jj,jk) * tmask_i(ji,jj) 90 90 zvt = ptrdx(ji,jj,jk) * zvm … … 218 218 END_3D 219 219 220 DO_3D( 0, 0, 0, 0, 1, jpkm1 ) 220 DO_3D( 0, 0, 0, 0, 1, jpkm1 ) ! Density flux divergence at t-point 221 221 zkepe(ji,jj,jk) = - ( zkz(ji,jj,jk) - zkz(ji ,jj ,jk+1) & 222 222 & + zkx(ji,jj,jk) - zkx(ji-1,jj ,jk ) & -
NEMO/branches/2020/dev_r13327_KERNEL-06_2_techene_e3/src/OCE/TRD/trdmxl.F90
r13295 r13998 120 120 ! 121 121 wkx(:,:,:) = 0._wp !== now ML weights for vertical averaging ==! 122 DO_3D( 1, 1, 1, 1, 1, jpktrd ) 122 DO_3D( 1, 1, 1, 1, 1, jpktrd ) ! initialize wkx with vertical scale factor in mixed-layer 123 123 IF( jk - kmxln(ji,jj) < 0 ) THEN 124 124 wkx(ji,jj,jk) = e3t(ji,jj,jk,Kmm) * tmask(ji,jj,jk) -
NEMO/branches/2020/dev_r13327_KERNEL-06_2_techene_e3/src/OCE/TRD/trdtra.F90
r13295 r13998 210 210 !!---------------------------------------------------------------------- 211 211 ! 212 SELECT CASE( cdir ) ! shift depending on the direction212 SELECT CASE( cdir ) ! shift depending on the direction 213 213 CASE( 'X' ) ; ii = 1 ; ij = 0 ; ik = 0 ! i-trend 214 214 CASE( 'Y' ) ; ii = 0 ; ij = 1 ; ik = 0 ! j-trend … … 216 216 END SELECT 217 217 ! 218 ! ! set to zero uncomputed values218 ! ! set to zero uncomputed values 219 219 ptrd(jpi,:,:) = 0._wp ; ptrd(1,:,:) = 0._wp 220 220 ptrd(:,jpj,:) = 0._wp ; ptrd(:,1,:) = 0._wp 221 221 ptrd(:,:,jpk) = 0._wp 222 222 ! 223 DO_3D( 0, 0, 0, 0, 1, jpkm1 ) 223 DO_3D( 0, 0, 0, 0, 1, jpkm1 ) ! advective trend 224 224 ptrd(ji,jj,jk) = - ( pf (ji,jj,jk) - pf (ji-ii,jj-ij,jk-ik) & 225 225 & - ( pu(ji,jj,jk) - pu(ji-ii,jj-ij,jk-ik) ) * pt(ji,jj,jk) ) & -
NEMO/branches/2020/dev_r13327_KERNEL-06_2_techene_e3/src/OCE/TRD/trdvor.F90
r13295 r13998 103 103 CASE( jpdyn_zad ) ; CALL trd_vor_zint( putrd, pvtrd, jpvor_zad, Kmm ) ! Vertical Advection 104 104 CASE( jpdyn_spg ) ; CALL trd_vor_zint( putrd, pvtrd, jpvor_spg, Kmm ) ! Surface Pressure Grad. 105 CASE( jpdyn_zdf ) ! Vertical Diffusion105 CASE( jpdyn_zdf ) ! Vertical Diffusion 106 106 ztswu(:,:) = 0.e0 ; ztswv(:,:) = 0.e0 107 DO_2D( 0, 0, 0, 0 ) 107 DO_2D( 0, 0, 0, 0 ) ! wind stress trends 108 108 ztswu(ji,jj) = 0.5 * ( utau_b(ji,jj) + utau(ji,jj) ) / ( e3u(ji,jj,1,Kmm) * rho0 ) 109 109 ztswv(ji,jj) = 0.5 * ( vtau_b(ji,jj) + vtau(ji,jj) ) / ( e3v(ji,jj,1,Kmm) * rho0 ) -
NEMO/branches/2020/dev_r13327_KERNEL-06_2_techene_e3/src/OCE/USR/usrdef_fmask.F90
r13286 r13998 58 58 !!---------------------------------------------------------------------- 59 59 ! 60 IF( TRIM( cd_cfg ) == "orca" ) THEN !== ORCA Configurations ==!60 IF( TRIM( cd_cfg ) == "orca" .OR. TRIM( cd_cfg ) == "ORCA" ) THEN !== ORCA Configurations ==! 61 61 ! 62 62 SELECT CASE ( kcfg ) -
NEMO/branches/2020/dev_r13327_KERNEL-06_2_techene_e3/src/OCE/USR/usrdef_istate.F90
r13874 r13998 58 58 IF(lwp) WRITE(numout,*) '~~~~~~~~~~~~~~ Ocean at rest, with an horizontally uniform T and S profiles' 59 59 ! 60 pu (:,:,:) = 0._wp ! ocean at rest60 pu (:,:,:) = 0._wp ! ocean at rest 61 61 pv (:,:,:) = 0._wp 62 62 ! 63 DO_3D( 1, 1, 1, 1, 1, jpk ) 63 DO_3D( 1, 1, 1, 1, 1, jpk ) ! horizontally uniform T & S profiles 64 64 pts(ji,jj,jk,jp_tem) = ( ( 16. - 12. * TANH( (pdept(ji,jj,jk) - 400) / 700 ) ) & 65 65 & * (-TANH( (500. - pdept(ji,jj,jk)) / 150. ) + 1.) / 2. & -
NEMO/branches/2020/dev_r13327_KERNEL-06_2_techene_e3/src/OCE/ZDF/zdfddm.F90
r13427 r13998 95 95 !!gm and many acces in memory 96 96 97 DO_2D( 1, 1, 1, 1 ) 97 DO_2D( 1, 1, 1, 1 ) !== R=zrau = (alpha / beta) (dk[t] / dk[s]) ==! 98 98 zrw = ( gdepw(ji,jj,jk ,Kmm) - gdept(ji,jj,jk,Kmm) ) & 99 99 !!gm please, use e3w at Kmm below … … 111 111 END_2D 112 112 113 DO_2D( 1, 1, 1, 1 ) 113 DO_2D( 1, 1, 1, 1 ) !== indicators ==! 114 114 ! stability indicator: msks=1 if rn2>0; 0 elsewhere 115 115 IF( rn2(ji,jj,jk) + 1.e-12 <= 0. ) THEN ; zmsks(ji,jj) = 0._wp -
NEMO/branches/2020/dev_r13327_KERNEL-06_2_techene_e3/src/OCE/ZDF/zdfdrg.F90
r13295 r13998 32 32 USE lib_mpp ! distributed memory computing 33 33 USE prtctl ! Print control 34 USE sbc_oce , ONLY : nn_ice 34 35 35 36 IMPLICIT NONE … … 41 42 42 43 ! !!* Namelist namdrg: nature of drag coefficient namelist * 43 LOGICAL :: ln_OFF! free-slip : Cd = 044 LOGICAL , PUBLIC :: ln_drg_OFF ! free-slip : Cd = 0 44 45 LOGICAL :: ln_lin ! linear drag: Cd = Cd0_lin 45 46 LOGICAL :: ln_non_lin ! non-linear drag: Cd = Cd0_nl |U| 46 47 LOGICAL :: ln_loglayer ! logarithmic drag: Cd = vkarmn/log(z/z0) 47 48 LOGICAL , PUBLIC :: ln_drgimp ! implicit top/bottom friction flag 48 49 LOGICAL , PUBLIC :: ln_drgice_imp ! implicit ice-ocean drag 49 50 ! !!* Namelist namdrg_top & _bot: TOP or BOTTOM coefficient namelist * 50 51 REAL(wp) :: rn_Cd0 !: drag coefficient [ - ] … … 226 227 INTEGER :: ios, ioptio ! local integers 227 228 !! 228 NAMELIST/namdrg/ ln_ OFF, ln_lin, ln_non_lin, ln_loglayer, ln_drgimp229 NAMELIST/namdrg/ ln_drg_OFF, ln_lin, ln_non_lin, ln_loglayer, ln_drgimp, ln_drgice_imp 229 230 !!---------------------------------------------------------------------- 230 231 ! … … 237 238 IF(lwm) WRITE ( numond, namdrg ) 238 239 ! 240 IF ( ln_drgice_imp .AND. nn_ice /= 2 ) ln_drgice_imp = .FALSE. 241 ! 239 242 IF(lwp) THEN 240 243 WRITE(numout,*) … … 242 245 WRITE(numout,*) '~~~~~~~~~~~~' 243 246 WRITE(numout,*) ' Namelist namdrg : top/bottom friction choices' 244 WRITE(numout,*) ' free-slip : Cd = 0 ln_ OFF = ', ln_OFF247 WRITE(numout,*) ' free-slip : Cd = 0 ln_drg_OFF = ', ln_drg_OFF 245 248 WRITE(numout,*) ' linear drag : Cd = Cd0 ln_lin = ', ln_lin 246 249 WRITE(numout,*) ' non-linear drag: Cd = Cd0_nl |U| ln_non_lin = ', ln_non_lin 247 250 WRITE(numout,*) ' logarithmic drag: Cd = vkarmn/log(z/z0) ln_loglayer = ', ln_loglayer 248 251 WRITE(numout,*) ' implicit friction ln_drgimp = ', ln_drgimp 252 WRITE(numout,*) ' implicit ice-ocean drag ln_drgice_imp =', ln_drgice_imp 249 253 ENDIF 250 254 ! 251 255 ioptio = 0 ! set ndrg and control check 252 IF( ln_ OFF) THEN ; ndrg = np_OFF ; ioptio = ioptio + 1 ; ENDIF256 IF( ln_drg_OFF ) THEN ; ndrg = np_OFF ; ioptio = ioptio + 1 ; ENDIF 253 257 IF( ln_lin ) THEN ; ndrg = np_lin ; ioptio = ioptio + 1 ; ENDIF 254 258 IF( ln_non_lin ) THEN ; ndrg = np_non_lin ; ioptio = ioptio + 1 ; ENDIF … … 257 261 IF( ioptio /= 1 ) CALL ctl_stop( 'zdf_drg_init: Choose ONE type of drag coef in namdrg' ) 258 262 ! 263 IF ( ln_drgice_imp.AND.(.NOT.ln_drgimp) ) & 264 & CALL ctl_stop( 'zdf_drg_init: ln_drgice_imp=T requires ln_drgimp=T' ) 259 265 ! 260 266 ! !== BOTTOM drag setting ==! (applied at seafloor) … … 263 269 CALL drg_init( 'BOTTOM' , mbkt , & ! <== in 264 270 & r_Cdmin_bot, r_Cdmax_bot, r_z0_bot, r_ke0_bot, rCd0_bot, rCdU_bot ) ! ==> out 265 266 271 ! 267 272 ! !== TOP drag setting ==! (applied at the top of ocean cavities) 268 273 ! 269 IF( ln_isfcav ) THEN ! Ocean cavities: top friction setting 270 ALLOCATE( rCd0_top(jpi,jpj), rCdU_top(jpi,jpj) ) 274 IF( ln_isfcav.OR.ln_drgice_imp ) THEN ! Ocean cavities: top friction setting 275 ALLOCATE( rCdU_top(jpi,jpj) ) 276 ENDIF 277 ! 278 IF( ln_isfcav ) THEN 279 ALLOCATE( rCd0_top(jpi,jpj)) 271 280 CALL drg_init( 'TOP ' , mikt , & ! <== in 272 281 & r_Cdmin_top, r_Cdmax_top, r_z0_top, r_ke0_top, rCd0_top, rCdU_top ) ! ==> out … … 374 383 IF(ll_bot) zmsk_boost(:,:) = zmsk_boost(:,:) * ssmask(:,:) ! x seafloor mask 375 384 ! 385 l_log_not_linssh = .FALSE. ! default definition 376 386 ! 377 387 SELECT CASE( ndrg ) … … 422 432 l_log_not_linssh = .FALSE. !- don't update Cd at each time step 423 433 ! 424 DO_2D( 1, 1, 1, 1 ) 434 DO_2D( 1, 1, 1, 1 ) ! pCd0 = mask (and boosted) logarithmic drag coef. 425 435 zzz = 0.5_wp * e3t_0(ji,jj,k_mk(ji,jj)) 426 436 zcd = ( vkarmn / LOG( zzz / rn_z0 ) )**2 -
NEMO/branches/2020/dev_r13327_KERNEL-06_2_techene_e3/src/OCE/ZDF/zdfgls.F90
r13295 r13998 19 19 USE dom_oce ! ocean space and time domain 20 20 USE domvvl ! ocean space and time domain : variable volume layer 21 USE zdfdrg , ONLY : ln_drg_OFF ! top/bottom free-slip flag 21 22 USE zdfdrg , ONLY : r_z0_top , r_z0_bot ! top/bottom roughness 22 23 USE zdfdrg , ONLY : rCdU_top , rCdU_bot ! top/bottom friction … … 53 54 INTEGER :: nn_bc_bot ! bottom boundary condition (=0/1) 54 55 INTEGER :: nn_z0_met ! Method for surface roughness computation 56 INTEGER :: nn_z0_ice ! Roughness accounting for sea ice 55 57 INTEGER :: nn_stab_func ! stability functions G88, KC or Canuto (=0/1/2) 56 58 INTEGER :: nn_clos ! closure 0/1/2/3 MY82/k-eps/k-w/gen … … 61 63 REAL(wp) :: rn_crban ! Craig and Banner constant for surface breaking waves mixing 62 64 REAL(wp) :: rn_hsro ! Minimum surface roughness 65 REAL(wp) :: rn_hsri ! Ice ocean roughness 63 66 REAL(wp) :: rn_frac_hs ! Fraction of wave height as surface roughness (if nn_z0_met > 1) 64 67 … … 152 155 REAL(wp), DIMENSION(jpi,jpj) :: zflxs ! Turbulence fluxed induced by internal waves 153 156 REAL(wp), DIMENSION(jpi,jpj) :: zhsro ! Surface roughness (surface waves) 157 REAL(wp), DIMENSION(jpi,jpj) :: zice_fra ! Tapering of wave breaking under sea ice 154 158 REAL(wp), DIMENSION(jpi,jpj,jpk) :: eb ! tke at time before 155 159 REAL(wp), DIMENSION(jpi,jpj,jpk) :: hmxl_b ! mixing length at time before … … 167 171 ustar2_bot (:,:) = 0._wp 168 172 173 SELECT CASE ( nn_z0_ice ) 174 CASE( 0 ) ; zice_fra(:,:) = 0._wp 175 CASE( 1 ) ; zice_fra(:,:) = TANH( fr_i(:,:) * 10._wp ) 176 CASE( 2 ) ; zice_fra(:,:) = fr_i(:,:) 177 CASE( 3 ) ; zice_fra(:,:) = MIN( 4._wp * fr_i(:,:) , 1._wp ) 178 END SELECT 179 169 180 ! Compute surface, top and bottom friction at T-points 170 DO_2D( 0, 0, 0, 0 ) 171 ! 172 ! surface friction 173 ustar2_surf(ji,jj) = r1_rho0 * taum(ji,jj) * tmask(ji,jj,1) 174 ! 175 !!gm Rq we may add here r_ke0(_top/_bot) ? ==>> think about that... 176 ! bottom friction (explicit before friction) 177 zmsku = ( 2._wp - umask(ji-1,jj,mbkt(ji,jj)) * umask(ji,jj,mbkt(ji,jj)) ) 178 zmskv = ( 2._wp - vmask(ji,jj-1,mbkt(ji,jj)) * vmask(ji,jj,mbkt(ji,jj)) ) ! (CAUTION: CdU<0) 179 ustar2_bot(ji,jj) = - rCdU_bot(ji,jj) * SQRT( ( zmsku*( uu(ji,jj,mbkt(ji,jj),Kbb)+uu(ji-1,jj,mbkt(ji,jj),Kbb) ) )**2 & 180 & + ( zmskv*( vv(ji,jj,mbkt(ji,jj),Kbb)+vv(ji,jj-1,mbkt(ji,jj),Kbb) ) )**2 ) 181 DO_2D( 0, 0, 0, 0 ) !== surface ocean friction 182 ustar2_surf(ji,jj) = r1_rho0 * taum(ji,jj) * tmask(ji,jj,1) ! surface friction 181 183 END_2D 182 IF( ln_isfcav ) THEN !top friction 183 DO_2D( 0, 0, 0, 0 ) 184 zmsku = ( 2. - umask(ji-1,jj,mikt(ji,jj)) * umask(ji,jj,mikt(ji,jj)) ) 185 zmskv = ( 2. - vmask(ji,jj-1,mikt(ji,jj)) * vmask(ji,jj,mikt(ji,jj)) ) ! (CAUTION: CdU<0) 186 ustar2_top(ji,jj) = - rCdU_top(ji,jj) * SQRT( ( zmsku*( uu(ji,jj,mikt(ji,jj),Kbb)+uu(ji-1,jj,mikt(ji,jj),Kbb) ) )**2 & 187 & + ( zmskv*( vv(ji,jj,mikt(ji,jj),Kbb)+vv(ji,jj-1,mikt(ji,jj),Kbb) ) )**2 ) 184 ! 185 !!gm Rq we may add here r_ke0(_top/_bot) ? ==>> think about that... 186 ! 187 IF( .NOT.ln_drg_OFF ) THEN !== top/bottom friction (explicit before friction) 188 DO_2D( 0, 0, 0, 0 ) ! bottom friction (explicit before friction) 189 zmsku = ( 2._wp - umask(ji-1,jj,mbkt(ji,jj)) * umask(ji,jj,mbkt(ji,jj)) ) 190 zmskv = ( 2._wp - vmask(ji,jj-1,mbkt(ji,jj)) * vmask(ji,jj,mbkt(ji,jj)) ) ! (CAUTION: CdU<0) 191 ustar2_bot(ji,jj) = - rCdU_bot(ji,jj) * SQRT( ( zmsku*( uu(ji,jj,mbkt(ji,jj),Kbb)+uu(ji-1,jj,mbkt(ji,jj),Kbb) ) )**2 & 192 & + ( zmskv*( vv(ji,jj,mbkt(ji,jj),Kbb)+vv(ji,jj-1,mbkt(ji,jj),Kbb) ) )**2 ) 188 193 END_2D 194 IF( ln_isfcav ) THEN 195 DO_2D( 0, 0, 0, 0 ) ! top friction 196 zmsku = ( 2. - umask(ji-1,jj,mikt(ji,jj)) * umask(ji,jj,mikt(ji,jj)) ) 197 zmskv = ( 2. - vmask(ji,jj-1,mikt(ji,jj)) * vmask(ji,jj,mikt(ji,jj)) ) ! (CAUTION: CdU<0) 198 ustar2_top(ji,jj) = - rCdU_top(ji,jj) * SQRT( ( zmsku*( uu(ji,jj,mikt(ji,jj),Kbb)+uu(ji-1,jj,mikt(ji,jj),Kbb) ) )**2 & 199 & + ( zmskv*( vv(ji,jj,mikt(ji,jj),Kbb)+vv(ji,jj-1,mikt(ji,jj),Kbb) ) )**2 ) 200 END_2D 201 ENDIF 189 202 ENDIF 190 203 … … 204 217 END SELECT 205 218 ! 206 DO_3D( 1, 0, 1, 0, 2, jpkm1 ) 219 ! adapt roughness where there is sea ice 220 zhsro(:,:) = ( (1._wp-zice_fra(:,:)) * zhsro(:,:) + zice_fra(:,:) * rn_hsri )*tmask(:,:,1) + (1._wp - tmask(:,:,1))*rn_hsro 221 ! 222 DO_3D( 0, 0, 0, 0, 2, jpkm1 ) !== Compute dissipation rate ==! 207 223 eps(ji,jj,jk) = rc03 * en(ji,jj,jk) * SQRT( en(ji,jj,jk) ) / hmxl_n(ji,jj,jk) 208 224 END_3D … … 288 304 CASE ( 0 ) ! Dirichlet boundary condition (set e at k=1 & 2) 289 305 ! First level 290 en (:,:,1) = MAX( rn_emin , rc02r * ustar2_surf(:,:) * (1._wp + rsbc_tke1)**r2_3 )306 en (:,:,1) = MAX( rn_emin , rc02r * ustar2_surf(:,:) * (1._wp + (1._wp-zice_fra(:,:))*rsbc_tke1)**r2_3 ) 291 307 zd_lw(:,:,1) = en(:,:,1) 292 308 zd_up(:,:,1) = 0._wp … … 294 310 ! 295 311 ! One level below 296 en (:,:,2) = MAX( rc02r * ustar2_surf(:,:) * ( 1._wp + rsbc_tke1 * ((zhsro(:,:)+gdepw(:,:,2,Kmm))&297 & / zhsro(:,:) )**(1.5_wp*ra_sf) )**(2._wp/3._wp) 312 en (:,:,2) = MAX( rc02r * ustar2_surf(:,:) * ( 1._wp + (1._wp-zice_fra(:,:))*rsbc_tke1 * ((zhsro(:,:)+gdepw(:,:,2,Kmm)) & 313 & / zhsro(:,:) )**(1.5_wp*ra_sf) )**(2._wp/3._wp) , rn_emin ) 298 314 zd_lw(:,:,2) = 0._wp 299 315 zd_up(:,:,2) = 0._wp … … 304 320 ! 305 321 ! Dirichlet conditions at k=1 306 en (:,:,1) = MAX( rc02r * ustar2_surf(:,:) * (1._wp + rsbc_tke1)**r2_3 , rn_emin )322 en (:,:,1) = MAX( rc02r * ustar2_surf(:,:) * (1._wp + (1._wp-zice_fra(:,:))*rsbc_tke1)**r2_3 , rn_emin ) 307 323 zd_lw(:,:,1) = en(:,:,1) 308 324 zd_up(:,:,1) = 0._wp … … 311 327 ! at k=2, set de/dz=Fw 312 328 !cbr 313 zdiag(:,:,2) = zdiag(:,:,2) + zd_lw(:,:,2) ! Remove zd_lw from zdiag 314 zd_lw(:,:,2) = 0._wp 329 DO_2D( 0, 0, 0, 0 ) ! zdiag zd_lw not defined/used on the halo 330 zdiag(ji,jj,2) = zdiag(ji,jj,2) + zd_lw(ji,jj,2) ! Remove zd_lw from zdiag 331 zd_lw(ji,jj,2) = 0._wp 332 END_2D 315 333 zkar (:,:) = (rl_sf + (vkarmn-rl_sf)*(1.-EXP(-rtrans*gdept(:,:,1,Kmm)/zhsro(:,:)) )) 316 zflxs(:,:) = rsbc_tke2 * ustar2_surf(:,:)**1.5_wp * zkar(:,:) &334 zflxs(:,:) = rsbc_tke2 * (1._wp-zice_fra(:,:)) * ustar2_surf(:,:)**1.5_wp * zkar(:,:) & 317 335 & * ( ( zhsro(:,:)+gdept(:,:,1,Kmm) ) / zhsro(:,:) )**(1.5_wp*ra_sf) 318 336 !!gm why not : * ( 1._wp + gdept(:,:,1,Kmm) / zhsro(:,:) )**(1.5_wp*ra_sf) … … 400 418 ! ---------------------------------------------------------- 401 419 ! 402 DO_3D( 0, 0, 0, 0, 2, jpkm1 ) 420 DO_3D( 0, 0, 0, 0, 2, jpkm1 ) ! First recurrence : Dk = Dk - Lk * Uk-1 / Dk-1 403 421 zdiag(ji,jj,jk) = zdiag(ji,jj,jk) - zd_lw(ji,jj,jk) * zd_up(ji,jj,jk-1) / zdiag(ji,jj,jk-1) 404 422 END_3D 405 DO_3D( 0, 0, 0, 0, 2, jpk )423 DO_3D( 0, 0, 0, 0, 2, jpkm1 ) ! Second recurrence : Lk = RHSk - Lk / Dk-1 * Lk-1 406 424 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) 407 425 END_3D 408 DO_3DS( 0, 0, 0, 0, jpk -1, 2, -1 )426 DO_3DS( 0, 0, 0, 0, jpkm1, 2, -1 ) ! thrid recurrence : Ek = ( Lk - Uk * Ek+1 ) / Dk 409 427 en(ji,jj,jk) = ( zd_lw(ji,jj,jk) - zd_up(ji,jj,jk) * en(ji,jj,jk+1) ) / zdiag(ji,jj,jk) 410 428 END_3D … … 521 539 ! 522 540 ! Neumann condition at k=2 523 zdiag(:,:,2) = zdiag(:,:,2) + zd_lw(:,:,2) ! Remove zd_lw from zdiag 524 zd_lw(:,:,2) = 0._wp 541 DO_2D( 0, 0, 0, 0 ) ! zdiag zd_lw not defined/used on the halo 542 zdiag(ji,jj,2) = zdiag(ji,jj,2) + zd_lw(ji,jj,2) ! Remove zd_lw from zdiag 543 zd_lw(ji,jj,2) = 0._wp 544 END_2D 525 545 ! 526 546 ! Set psi vertical flux at the surface: 527 547 zkar (:,:) = rl_sf + (vkarmn-rl_sf)*(1._wp-EXP(-rtrans*gdept(:,:,1,Kmm)/zhsro(:,:) )) ! Lengh scale slope 528 548 zdep (:,:) = ((zhsro(:,:) + gdept(:,:,1,Kmm)) / zhsro(:,:))**(rmm*ra_sf) 529 zflxs(:,:) = (rnn + rsbc_tke1 * (rnn + rmm*ra_sf) * zdep(:,:))*(1._wp + rsbc_tke1*zdep(:,:))**(2._wp*rmm/3._wp-1_wp) 549 zflxs(:,:) = (rnn + (1._wp-zice_fra(:,:))*rsbc_tke1 * (rnn + rmm*ra_sf) * zdep(:,:)) & 550 & *(1._wp + (1._wp-zice_fra(:,:))*rsbc_tke1*zdep(:,:))**(2._wp*rmm/3._wp-1_wp) 530 551 zdep (:,:) = rsbc_psi1 * (zwall_psi(:,:,1)*p_avm(:,:,1)+zwall_psi(:,:,2)*p_avm(:,:,2)) * & 531 552 & ustar2_surf(:,:)**rmm * zkar(:,:)**rnn * (zhsro(:,:) + gdept(:,:,1,Kmm))**(rnn-1.) … … 593 614 ! ---------------- 594 615 ! 595 DO_3D( 0, 0, 0, 0, 2, jpkm1 ) 616 DO_3D( 0, 0, 0, 0, 2, jpkm1 ) ! First recurrence : Dk = Dk - Lk * Uk-1 / Dk-1 596 617 zdiag(ji,jj,jk) = zdiag(ji,jj,jk) - zd_lw(ji,jj,jk) * zd_up(ji,jj,jk-1) / zdiag(ji,jj,jk-1) 597 618 END_3D 598 DO_3D( 0, 0, 0, 0, 2, jpk )619 DO_3D( 0, 0, 0, 0, 2, jpkm1 ) ! Second recurrence : Lk = RHSk - Lk / Dk-1 * Lk-1 599 620 zd_lw(ji,jj,jk) = psi(ji,jj,jk) - zd_lw(ji,jj,jk) / zdiag(ji,jj,jk-1) * zd_lw(ji,jj,jk-1) 600 621 END_3D 601 DO_3DS( 0, 0, 0, 0, jpk -1, 2, -1 )622 DO_3DS( 0, 0, 0, 0, jpkm1, 2, -1 ) ! Third recurrence : Ek = ( Lk - Uk * Ek+1 ) / Dk 602 623 psi(ji,jj,jk) = ( zd_lw(ji,jj,jk) - zd_up(ji,jj,jk) * psi(ji,jj,jk+1) ) / zdiag(ji,jj,jk) 603 624 END_3D … … 635 656 ! Limit dissipation rate under stable stratification 636 657 ! -------------------------------------------------- 637 DO_3D( 0, 0, 0, 0, 1, jpkm1 ) 658 DO_3D( 0, 0, 0, 0, 1, jpkm1 ) ! Note that this set boundary conditions on hmxl_n at the same time 638 659 ! limitation 639 660 eps (ji,jj,jk) = MAX( eps(ji,jj,jk), rn_epsmin ) … … 700 721 ! default value, in case jpk > mbkt(ji,jj)+1. Not needed but avoid a bug when looking for undefined values (-fpe0) 701 722 zstm(:,:,jpk) = 0. 702 DO_2D( 0, 0, 0, 0 ) 723 DO_2D( 0, 0, 0, 0 ) ! update bottom with good values 703 724 zstm(ji,jj,mbkt(ji,jj)+1) = zstm(ji,jj,mbkt(ji,jj)) 704 725 END_2D … … 750 771 REAL(wp):: zcr ! local scalar 751 772 !! 752 NAMELIST/namzdf_gls/rn_emin, rn_epsmin, ln_length_lim, &753 & rn_clim_galp, ln_sigpsi, rn_hsro, 754 & rn_crban, rn_charn, rn_frac_hs, &755 & nn_bc_surf, nn_bc_bot, nn_z0_met, 773 NAMELIST/namzdf_gls/rn_emin, rn_epsmin, ln_length_lim, & 774 & rn_clim_galp, ln_sigpsi, rn_hsro, rn_hsri, & 775 & rn_crban, rn_charn, rn_frac_hs, & 776 & nn_bc_surf, nn_bc_bot, nn_z0_met, nn_z0_ice, & 756 777 & nn_stab_func, nn_clos 757 778 !!---------------------------------------------------------- … … 779 800 WRITE(numout,*) ' Charnock coefficient rn_charn = ', rn_charn 780 801 WRITE(numout,*) ' Surface roughness formula nn_z0_met = ', nn_z0_met 802 WRITE(numout,*) ' surface wave breaking under ice nn_z0_ice = ', nn_z0_ice 803 SELECT CASE( nn_z0_ice ) 804 CASE( 0 ) ; WRITE(numout,*) ' ==>>> no impact of ice cover on surface wave breaking' 805 CASE( 1 ) ; WRITE(numout,*) ' ==>>> roughness uses rn_hsri and is weigthed by 1-TANH( fr_i(:,:) * 10 )' 806 CASE( 2 ) ; WRITE(numout,*) ' ==>>> roughness uses rn_hsri and is weighted by 1-fr_i(:,:)' 807 CASE( 3 ) ; WRITE(numout,*) ' ==>>> roughness uses rn_hsri and is weighted by 1-MIN( 1, 4 * fr_i(:,:) )' 808 CASE DEFAULT 809 CALL ctl_stop( 'zdf_gls_init: wrong value for nn_z0_ice, should be 0,1,2, or 3') 810 END SELECT 781 811 WRITE(numout,*) ' Wave height frac. (used if nn_z0_met=2) rn_frac_hs = ', rn_frac_hs 782 812 WRITE(numout,*) ' Stability functions nn_stab_func = ', nn_stab_func 783 813 WRITE(numout,*) ' Type of closure nn_clos = ', nn_clos 784 814 WRITE(numout,*) ' Surface roughness (m) rn_hsro = ', rn_hsro 785 WRITE(numout,*) 786 WRITE(numout,*) ' Namelist namdrg_top/_bot: used values:' 787 WRITE(numout,*) ' top ocean cavity roughness (m) rn_z0(_top) = ', r_z0_top 788 WRITE(numout,*) ' Bottom seafloor roughness (m) rn_z0(_bot) = ', r_z0_bot 815 WRITE(numout,*) ' Ice-ocean roughness (used if nn_z0_ice/=0) rn_hsri = ', rn_hsri 789 816 WRITE(numout,*) 790 817 ENDIF -
NEMO/branches/2020/dev_r13327_KERNEL-06_2_techene_e3/src/OCE/ZDF/zdfiwm.F90
r13295 r13998 146 146 zemx_iwm (ji,jj,1) = 0._wp ; zemx_iwm (ji,jj,jpk) = 0._wp 147 147 END_2D 148 zemx_iwm ( 1:nn_hls,:,:) = 0._wp ; zemx_iwm (:, 1:nn_hls,:) = 0._wp149 zemx_iwm (jpi-nn_hls+1:jpi ,:,:) = 0._wp ; zemx_iwm (:,jpj-nn_hls+1: jpj,:) = 0._wp150 148 ENDIF 151 149 IF( iom_use("av_ratio") ) THEN … … 153 151 zav_ratio(ji,jj,1) = 0._wp ; zav_ratio(ji,jj,jpk) = 0._wp 154 152 END_2D 155 zav_ratio( 1:nn_hls,:,:) = 0._wp ; zav_ratio(:, 1:nn_hls,:) = 0._wp 156 zav_ratio(jpi-nn_hls+1:jpi ,:,:) = 0._wp ; zav_ratio(:,jpj-nn_hls+1: jpj,:) = 0._wp 157 ENDIF 158 IF( iom_use("av_wave") ) THEN 153 ENDIF 154 IF( iom_use("av_wave") .OR. sn_cfctl%l_prtctl ) THEN 159 155 DO_2D( 0, 0, 0, 0 ) 160 156 zav_wave (ji,jj,1) = 0._wp ; zav_wave (ji,jj,jpk) = 0._wp 161 157 END_2D 162 zav_wave( 1:nn_hls,:,:) = 0._wp ; zav_wave(:, 1:nn_hls,:) = 0._wp163 zav_wave(jpi-nn_hls+1:jpi ,:,:) = 0._wp ; zav_wave(:,jpj-nn_hls+1: jpj,:) = 0._wp164 158 ENDIF 165 159 ! … … 170 164 ! !* Critical slope mixing: distribute energy over the time-varying ocean depth, 171 165 ! using an exponential decay from the seafloor. 172 DO_2D( 0, 0, 0, 0 ) 166 DO_2D( 0, 0, 0, 0 ) ! part independent of the level 173 167 zhdep(ji,jj) = gdepw_0(ji,jj,mbkt(ji,jj)+1) ! depth of the ocean 174 168 zfact(ji,jj) = rho0 * ( 1._wp - EXP( -zhdep(ji,jj) / hcri_iwm(ji,jj) ) ) … … 176 170 END_2D 177 171 !!gm gde3w ==>>> check for ssh taken into account.... seem OK gde3w_n=gdept(:,:,:,Kmm) - ssh(:,:,Kmm) 178 DO_3D( 0, 0, 0, 0, 2, jpkm1 ) 172 DO_3D( 0, 0, 0, 0, 2, jpkm1 ) ! complete with the level-dependent part 179 173 IF ( zfact(ji,jj) == 0._wp .OR. wmask(ji,jj,jk) == 0._wp ) THEN ! optimization 180 174 zemx_iwm(ji,jj,jk) = 0._wp … … 299 293 END_3D 300 294 ! 301 IF( ln_mevar ) THEN ! Variable mixing efficiency case : modify zav_wave in the302 DO_3D( 0, 0, 0, 0, 2, jpkm1 ) 295 IF( ln_mevar ) THEN ! Variable mixing efficiency case : modify zav_wave in the 296 DO_3D( 0, 0, 0, 0, 2, jpkm1 ) ! energetic (Reb > 480) and buoyancy-controlled (Reb <10.224 ) regimes 303 297 IF( zReb(ji,jj,jk) > 480.00_wp ) THEN 304 298 zav_wave(ji,jj,jk) = 3.6515_wp * znu_w(ji,jj,jk) * SQRT( zReb(ji,jj,jk) ) … … 309 303 ENDIF 310 304 ! 311 DO_3D( 0, 0, 0, 0, 2, jpkm1 ) 305 DO_3D( 0, 0, 0, 0, 2, jpkm1 ) ! Bound diffusivity by molecular value and 100 cm2/s 312 306 zav_wave(ji,jj,jk) = MIN( MAX( 1.4e-7_wp, zav_wave(ji,jj,jk) ), 1.e-2_wp ) * wmask(ji,jj,jk) 313 307 END_3D … … 336 330 ! ! ----------------------- ! 337 331 ! 338 IF( ln_tsdiff ) THEN !* Option for differential mixing of salinity and temperature332 IF( ln_tsdiff ) THEN !* Option for differential mixing of salinity and temperature 339 333 ztmp1 = 0.505_wp + 0.495_wp * TANH( 0.92_wp * ( LOG10( 1.e-20_wp ) - 0.60_wp ) ) 340 DO_3D( 0, 0, 0, 0, 2, jpkm1 ) 334 DO_3D( 0, 0, 0, 0, 2, jpkm1 ) ! Calculate S/T diffusivity ratio as a function of Reb 341 335 ztmp2 = zReb(ji,jj,jk) * 5._wp * r1_6 342 336 IF ( ztmp2 > 1.e-20_wp .AND. wmask(ji,jj,jk) == 1._wp ) THEN … … 353 347 END_3D 354 348 ! 355 ELSE !* update momentum & tracer diffusivity with wave-driven mixing349 ELSE !* update momentum & tracer diffusivity with wave-driven mixing 356 350 DO_3D( 0, 0, 0, 0, 2, jpkm1 ) 357 351 p_avs(ji,jj,jk) = p_avs(ji,jj,jk) + zav_wave(ji,jj,jk) … … 361 355 ENDIF 362 356 363 ! !* output internal wave-driven mixing coefficient357 ! !* output internal wave-driven mixing coefficient 364 358 CALL iom_put( "av_wave", zav_wave ) 365 !* output useful diagnostics: Kz*N^2 ,359 !* output useful diagnostics: Kz*N^2 , 366 360 !!gm Kz*N2 should take into account the ratio avs/avt if it is used.... (see diaar5) 367 ! vertical integral of rho0 * Kz * N^2 , energy density (zemx_iwm)361 ! vertical integral of rho0 * Kz * N^2 , energy density (zemx_iwm) 368 362 IF( iom_use("bflx_iwm") .OR. iom_use("pcmap_iwm") ) THEN 369 363 ALLOCATE( z2d(jpi,jpj) , z3d(jpi,jpj,jpk) ) -
NEMO/branches/2020/dev_r13327_KERNEL-06_2_techene_e3/src/OCE/ZDF/zdfmxl.F90
r13295 r13998 96 96 ! 97 97 ! w-level of the mixing and mixed layers 98 nmln(:,:) = nlb10 ! Initialization to the number of w ocean point99 hmlp(:,:) = 0._wp ! here hmlp used as a dummy variable, integrating vertically N^2100 zN2_c = grav * rho_c * r1_rho0 ! convert density criteria into N^2 criteria101 DO_3D( 1, 1, 1, 1, nlb10, jpkm1 ) 98 nmln(:,:) = nlb10 ! Initialization to the number of w ocean point 99 hmlp(:,:) = 0._wp ! here hmlp used as a dummy variable, integrating vertically N^2 100 zN2_c = grav * rho_c * r1_rho0 ! convert density criteria into N^2 criteria 101 DO_3D( 1, 1, 1, 1, nlb10, jpkm1 ) ! Mixed layer level: w-level 102 102 ikt = mbkt(ji,jj) 103 103 hmlp(ji,jj) = & … … 107 107 ! 108 108 ! w-level of the turbocline and mixing layer (iom_use) 109 imld(:,:) = mbkt(:,:) + 1 ! Initialization to the number of w ocean point110 DO_3DS( 1, 1, 1, 1, jpkm1, nlb10, -1 ) 109 imld(:,:) = mbkt(:,:) + 1 ! Initialization to the number of w ocean point 110 DO_3DS( 1, 1, 1, 1, jpkm1, nlb10, -1 ) ! from the bottom to nlb10 111 111 IF( avt (ji,jj,jk) < avt_c * wmask(ji,jj,jk) ) imld(ji,jj) = jk ! Turbocline 112 112 END_3D -
NEMO/branches/2020/dev_r13327_KERNEL-06_2_techene_e3/src/OCE/ZDF/zdfosm.F90
r13295 r13998 1184 1184 ! KPP-style Ri# mixing 1185 1185 IF( ln_kpprimix) THEN 1186 DO_3D( 1, 0, 1, 0, 2, jpkm1 ) 1186 DO_3D( 1, 0, 1, 0, 2, jpkm1 ) !* Shear production at uw- and vw-points (energy conserving form) 1187 1187 z3du(ji,jj,jk) = 0.5 * ( uu(ji,jj,jk-1,Kmm) - uu(ji ,jj,jk,Kmm) ) & 1188 1188 & * ( uu(ji,jj,jk-1,Kbb) - uu(ji ,jj,jk,Kbb) ) * wumask(ji,jj,jk) & … … 1516 1516 ! 1517 1517 hbl(:,:) = 0._wp ! here hbl used as a dummy variable, integrating vertically N^2 1518 DO_3D( 1, 1, 1, 1, 1, jpkm1 ) 1518 DO_3D( 1, 1, 1, 1, 1, jpkm1 ) ! Mixed layer level: w-level 1519 1519 ikt = mbkt(ji,jj) 1520 1520 hbl(ji,jj) = hbl(ji,jj) + MAX( rn2(ji,jj,jk) , 0._wp ) * e3w(ji,jj,jk,Kmm) … … 1629 1629 !code saving tracer trends removed, replace with trdmxl_oce 1630 1630 1631 DO_3D( 0, 0, 0, 0, 1, jpkm1 ) 1631 DO_3D( 0, 0, 0, 0, 1, jpkm1 ) ! add non-local u and v fluxes 1632 1632 puu(ji,jj,jk,Krhs) = puu(ji,jj,jk,Krhs) & 1633 1633 & - ( ghamu(ji,jj,jk ) & -
NEMO/branches/2020/dev_r13327_KERNEL-06_2_techene_e3/src/OCE/ZDF/zdfphy.F90
r13226 r13998 28 28 USE sbc_oce ! surface module (only for nn_isf in the option compatibility test) 29 29 USE sbcrnf ! surface boundary condition: runoff variables 30 USE sbc_ice ! sea ice drag 30 31 #if defined key_agrif 31 32 USE agrif_oce_interp ! interpavm … … 253 254 ENDIF 254 255 ! 256 #if defined key_si3 257 IF ( ln_drgice_imp) THEN 258 IF ( ln_isfcav ) THEN 259 rCdU_top(:,:) = rCdU_top(:,:) + ssmask(:,:) * tmask(:,:,1) * rCdU_ice(:,:) 260 ELSE 261 rCdU_top(:,:) = rCdU_ice(:,:) 262 ENDIF 263 ENDIF 264 #endif 265 ! 255 266 ! !== Kz from chosen turbulent closure ==! (avm_k, avt_k) 256 267 ! … … 326 337 ! 327 338 END SUBROUTINE zdf_phy 339 340 328 341 INTEGER FUNCTION zdf_phy_alloc() 329 342 !!---------------------------------------------------------------------- -
NEMO/branches/2020/dev_r13327_KERNEL-06_2_techene_e3/src/OCE/ZDF/zdfric.F90
r13295 r13998 160 160 ! 161 161 ! !== avm and avt = F(Richardson number) ==! 162 DO_3D( 1, 0, 1, 0, 2, jpkm1 ) 162 DO_3D( 1, 0, 1, 0, 2, jpkm1 ) ! coefficient = F(richardson number) (avm-weighted Ri) 163 163 zcfRi = 1._wp / ( 1._wp + rn_alp * MAX( 0._wp , avm(ji,jj,jk) * rn2(ji,jj,jk) / ( p_sh2(ji,jj,jk) + 1.e-20 ) ) ) 164 164 zav = rn_avmri * zcfRi**nn_ric … … 173 173 IF( ln_mldw ) THEN !== set a minimum value in the Ekman layer ==! 174 174 ! 175 DO_2D( 0, 0, 0, 0 ) 175 DO_2D( 0, 0, 0, 0 ) !* Ekman depth 176 176 zustar = SQRT( taum(ji,jj) * r1_rho0 ) 177 177 zhek = rn_ekmfc * zustar / ( ABS( ff_t(ji,jj) ) + rsmall ) ! Ekman depth 178 178 zh_ekm(ji,jj) = MAX( rn_mldmin , MIN( zhek , rn_mldmax ) ) ! set allowed range 179 179 END_2D 180 DO_3D( 0, 0, 0, 0, 2, jpkm1 ) 180 DO_3D( 0, 0, 0, 0, 2, jpkm1 ) !* minimum mixing coeff. within the Ekman layer 181 181 IF( gdept(ji,jj,jk,Kmm) < zh_ekm(ji,jj) ) THEN 182 182 p_avm(ji,jj,jk) = MAX( p_avm(ji,jj,jk), rn_wvmix ) * wmask(ji,jj,jk) -
NEMO/branches/2020/dev_r13327_KERNEL-06_2_techene_e3/src/OCE/ZDF/zdfsh2.F90
r13295 r13998 60 60 ! 61 61 DO jk = 2, jpkm1 62 DO_2D( 1, 0, 1, 0 ) 62 DO_2D( 1, 0, 1, 0 ) !* 2 x shear production at uw- and vw-points (energy conserving form) 63 63 zsh2u(ji,jj) = ( p_avm(ji+1,jj,jk) + p_avm(ji,jj,jk) ) & 64 64 & * ( uu(ji,jj,jk-1,Kmm) - uu(ji,jj,jk,Kmm) ) & … … 72 72 & * wvmask(ji,jj,jk) 73 73 END_2D 74 DO_2D( 0, 0, 0, 0 ) 74 DO_2D( 0, 0, 0, 0 ) !* shear production at w-point ! coast mask: =2 at the coast ; =1 otherwise (NB: wmask useless as zsh2 are masked) 75 75 p_sh2(ji,jj,jk) = 0.25 * ( ( zsh2u(ji-1,jj) + zsh2u(ji,jj) ) * ( 2. - umask(ji-1,jj,jk) * umask(ji,jj,jk) ) & 76 76 & + ( zsh2v(ji,jj-1) + zsh2v(ji,jj) ) * ( 2. - vmask(ji,jj-1,jk) * vmask(ji,jj,jk) ) ) -
NEMO/branches/2020/dev_r13327_KERNEL-06_2_techene_e3/src/OCE/ZDF/zdftke.F90
r13295 r13998 28 28 !! 3.6 ! 2014-11 (P. Mathiot) add ice shelf capability 29 29 !! 4.0 ! 2017-04 (G. Madec) remove CPP ddm key & avm at t-point only 30 !! - ! 2017-05 (G. Madec) add top/bottom friction as boundary condition (ln_drg)30 !! - ! 2017-05 (G. Madec) add top/bottom friction as boundary condition 31 31 !!---------------------------------------------------------------------- 32 32 … … 68 68 ! !!** Namelist namzdf_tke ** 69 69 LOGICAL :: ln_mxl0 ! mixing length scale surface value as function of wind stress or not 70 INTEGER :: nn_mxlice ! type of scaling under sea-ice (=0/1/2/3) 71 REAL(wp) :: rn_mxlice ! ice thickness value when scaling under sea-ice 70 72 INTEGER :: nn_mxl ! type of mixing length (=0/1/2/3) 71 73 REAL(wp) :: rn_mxl0 ! surface min value of mixing length (kappa*z_o=0.4*0.1 m) [m] 72 INTEGER :: nn_mxlice ! type of scaling under sea-ice73 REAL(wp) :: rn_mxlice ! max constant ice thickness value when scaling under sea-ice ( nn_mxlice=1)74 74 INTEGER :: nn_pdl ! Prandtl number or not (ratio avt/avm) (=0/1) 75 75 REAL(wp) :: rn_ediff ! coefficient for avt: avt=rn_ediff*mxl*sqrt(e) … … 79 79 REAL(wp) :: rn_emin0 ! surface minimum value of tke [m2/s2] 80 80 REAL(wp) :: rn_bshear ! background shear (>0) currently a numerical threshold (do not change it) 81 LOGICAL :: ln_drg ! top/bottom friction forcing flag82 81 INTEGER :: nn_etau ! type of depth penetration of surface tke (=0/1/2/3) 83 82 INTEGER :: nn_htau ! type of tke profile of penetration (=0/1) 84 83 REAL(wp) :: rn_efr ! fraction of TKE surface value which penetrates in the ocean 85 REAL(wp) :: rn_eice ! =0 ON below sea-ice, =4 OFF when ice fraction > 1/486 84 LOGICAL :: ln_lc ! Langmuir cells (LC) as a source term of TKE or not 87 85 REAL(wp) :: rn_lc ! coef to compute vertical velocity of Langmuir cells 86 INTEGER :: nn_eice ! attenutaion of langmuir & surface wave breaking under ice (=0/1/2/3) 88 87 89 88 REAL(wp) :: ri_cri ! critic Richardson number (deduced from rn_ediff and rn_ediss values) … … 200 199 REAL(wp), DIMENSION(:,:,:) , INTENT(in ) :: p_avm, p_avt ! vertical eddy viscosity & diffusivity (w-points) 201 200 ! 202 INTEGER :: ji, jj, jk ! dummy loop arguments201 INTEGER :: ji, jj, jk ! dummy loop arguments 203 202 REAL(wp) :: zetop, zebot, zmsku, zmskv ! local scalars 204 203 REAL(wp) :: zrhoa = 1.22 ! Air density kg/m3 205 204 REAL(wp) :: zcdrag = 1.5e-3 ! drag coefficient 206 REAL(wp) :: zbbrau, z ri! local scalars207 REAL(wp) :: zfact1, zfact2, zfact3 ! - 208 REAL(wp) :: ztx2 , zty2 , zcof ! - 209 REAL(wp) :: ztau , zdif ! - 210 REAL(wp) :: zus , zwlc , zind ! - 211 REAL(wp) :: zzd_up, zzd_lw ! - 205 REAL(wp) :: zbbrau, zbbirau, zri ! local scalars 206 REAL(wp) :: zfact1, zfact2, zfact3 ! - - 207 REAL(wp) :: ztx2 , zty2 , zcof ! - - 208 REAL(wp) :: ztau , zdif ! - - 209 REAL(wp) :: zus , zwlc , zind ! - - 210 REAL(wp) :: zzd_up, zzd_lw ! - - 212 211 INTEGER , DIMENSION(jpi,jpj) :: imlc 213 REAL(wp), DIMENSION(jpi,jpj) :: z hlc, zfr_i212 REAL(wp), DIMENSION(jpi,jpj) :: zice_fra, zhlc, zus3 214 213 REAL(wp), DIMENSION(jpi,jpj,jpk) :: zpelc, zdiag, zd_up, zd_lw 215 214 !!-------------------------------------------------------------------- 216 215 ! 217 zbbrau = rn_ebb / rho0 ! Local constant initialisation 218 zfact1 = -.5_wp * rn_Dt 219 zfact2 = 1.5_wp * rn_Dt * rn_ediss 220 zfact3 = 0.5_wp * rn_ediss 216 zbbrau = rn_ebb / rho0 ! Local constant initialisation 217 zbbirau = 3.75_wp / rho0 218 zfact1 = -.5_wp * rn_Dt 219 zfact2 = 1.5_wp * rn_Dt * rn_ediss 220 zfact3 = 0.5_wp * rn_ediss 221 ! 222 ! ice fraction considered for attenuation of langmuir & wave breaking 223 SELECT CASE ( nn_eice ) 224 CASE( 0 ) ; zice_fra(:,:) = 0._wp 225 CASE( 1 ) ; zice_fra(:,:) = TANH( fr_i(:,:) * 10._wp ) 226 CASE( 2 ) ; zice_fra(:,:) = fr_i(:,:) 227 CASE( 3 ) ; zice_fra(:,:) = MIN( 4._wp * fr_i(:,:) , 1._wp ) 228 END SELECT 221 229 ! 222 230 ! !<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<< 223 231 ! ! Surface/top/bottom boundary condition on tke 224 232 ! !<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<< 225 ! 226 DO_2D( 0, 0, 0, 0 ) 233 ! 234 DO_2D( 0, 0, 0, 0 ) ! en(1) = rn_ebb taum / rau0 (min value rn_emin0) 235 !! clem: this should be the right formulation but it makes the model unstable unless drags are calculated implicitly 236 !! one way around would be to increase zbbirau 237 !! en(ji,jj,1) = MAX( rn_emin0, ( ( 1._wp - fr_i(ji,jj) ) * zbbrau + & 238 !! & fr_i(ji,jj) * zbbirau ) * taum(ji,jj) ) * tmask(ji,jj,1) 227 239 en(ji,jj,1) = MAX( rn_emin0, zbbrau * taum(ji,jj) ) * tmask(ji,jj,1) 228 240 END_2D … … 236 248 ! Note that stress averaged is done using an wet-only calculation of u and v at t-point like in zdfsh2 237 249 ! 238 IF( ln_drg ) THEN!== friction used as top/bottom boundary condition on TKE239 ! 240 DO_2D( 0, 0, 0, 0 ) 250 IF( .NOT.ln_drg_OFF ) THEN !== friction used as top/bottom boundary condition on TKE 251 ! 252 DO_2D( 0, 0, 0, 0 ) ! bottom friction 241 253 zmsku = ( 2. - umask(ji-1,jj,mbkt(ji,jj)) * umask(ji,jj,mbkt(ji,jj)) ) 242 254 zmskv = ( 2. - vmask(ji,jj-1,mbkt(ji,jj)) * vmask(ji,jj,mbkt(ji,jj)) ) … … 246 258 en(ji,jj,mbkt(ji,jj)+1) = MAX( zebot, rn_emin ) * ssmask(ji,jj) 247 259 END_2D 248 IF( ln_isfcav ) THEN ! top friction249 DO_2D( 0, 0, 0, 0 ) 260 IF( ln_isfcav ) THEN 261 DO_2D( 0, 0, 0, 0 ) ! top friction 250 262 zmsku = ( 2. - umask(ji-1,jj,mikt(ji,jj)) * umask(ji,jj,mikt(ji,jj)) ) 251 263 zmskv = ( 2. - vmask(ji,jj-1,mikt(ji,jj)) * vmask(ji,jj,mikt(ji,jj)) ) … … 274 286 zcof = 0.5 * 0.016 * 0.016 / ( zrhoa * zcdrag ) 275 287 imlc(:,:) = mbkt(:,:) + 1 ! Initialization to the number of w ocean point (=2 over land) 276 DO_3DS( 1, 1, 1, 1, jpkm1, 2, -1 ) 277 zus = zcof * taum(ji,jj)288 DO_3DS( 1, 1, 1, 1, jpkm1, 2, -1 ) ! Last w-level at which zpelc>=0.5*us*us 289 zus = zcof * taum(ji,jj) ! with us=0.016*wind(starting from jpk-1) 278 290 IF( zpelc(ji,jj,jk) > zus ) imlc(ji,jj) = jk 279 291 END_3D … … 285 297 DO_2D( 0, 0, 0, 0 ) 286 298 zus = zcof * SQRT( taum(ji,jj) ) ! Stokes drift 287 zfr_i(ji,jj) = ( 1._wp - 4._wp * fr_i(ji,jj) ) * zus * zus * zus * tmask(ji,jj,1) ! zus > 0. ok 288 IF (zfr_i(ji,jj) < 0. ) zfr_i(ji,jj) = 0. 299 zus3(ji,jj) = MAX( 0._wp, 1._wp - zice_fra(ji,jj) ) * zus * zus * zus * tmask(ji,jj,1) ! zus > 0. ok 289 300 END_2D 290 DO_3D( 0, 0, 0, 0, 2, jpkm1 ) 291 IF ( zfr_i(ji,jj) /= 0. ) THEN 292 ! vertical velocity due to LC 301 DO_3D( 0, 0, 0, 0, 2, jpkm1 ) !* TKE Langmuir circulation source term added to en 302 IF ( zus3(ji,jj) /= 0._wp ) THEN 293 303 IF ( gdepw(ji,jj,jk,Kmm) - zhlc(ji,jj) < 0 .AND. wmask(ji,jj,jk) /= 0. ) THEN 294 304 ! ! vertical velocity due to LC 295 zwlc = rn_lc * SIN( rpi * gdepw(ji,jj,jk,Kmm) / zhlc(ji,jj) ) ! warning: optimization: zus^3 is in zfr_i305 zwlc = rn_lc * SIN( rpi * gdepw(ji,jj,jk,Kmm) / zhlc(ji,jj) ) 296 306 ! ! TKE Langmuir circulation source term 297 en(ji,jj,jk) = en(ji,jj,jk) + rn_Dt * z fr_i(ji,jj) * ( zwlc * zwlc * zwlc ) / zhlc(ji,jj)307 en(ji,jj,jk) = en(ji,jj,jk) + rn_Dt * zus3(ji,jj) * ( zwlc * zwlc * zwlc ) / zhlc(ji,jj) 298 308 ENDIF 299 309 ENDIF … … 309 319 ! ! zdiag : diagonal zd_up : upper diagonal zd_lw : lower diagonal 310 320 ! 311 IF( nn_pdl == 1 ) THEN !* Prandtl number = F( Ri )321 IF( nn_pdl == 1 ) THEN !* Prandtl number = F( Ri ) 312 322 DO_3D( 0, 0, 0, 0, 2, jpkm1 ) 313 323 ! ! local Richardson number … … 322 332 ENDIF 323 333 ! 324 DO_3D( 0, 0, 0, 0, 2, jpkm1 ) 334 DO_3D( 0, 0, 0, 0, 2, jpkm1 ) !* Matrix and right hand side in en 325 335 zcof = zfact1 * tmask(ji,jj,jk) 326 336 ! ! A minimum of 2.e-5 m2/s is imposed on TKE vertical 327 337 ! ! eddy coefficient (ensure numerical stability) 328 338 zzd_up = zcof * MAX( p_avm(ji,jj,jk+1) + p_avm(ji,jj,jk ) , 2.e-5_wp ) & ! upper diagonal 329 & / ( e3t(ji,jj,jk ,Kmm) & 330 & * e3w(ji,jj,jk ,Kmm) ) 339 & / ( e3t(ji,jj,jk ,Kmm) * e3w(ji,jj,jk ,Kmm) ) 331 340 zzd_lw = zcof * MAX( p_avm(ji,jj,jk ) + p_avm(ji,jj,jk-1) , 2.e-5_wp ) & ! lower diagonal 332 & / ( e3t(ji,jj,jk-1,Kmm) & 333 & * e3w(ji,jj,jk ,Kmm) ) 341 & / ( e3t(ji,jj,jk-1,Kmm) * e3w(ji,jj,jk ,Kmm) ) 334 342 ! 335 343 zd_up(ji,jj,jk) = zzd_up ! Matrix (zdiag, zd_up, zd_lw) … … 344 352 END_3D 345 353 ! !* Matrix inversion from level 2 (tke prescribed at level 1) 346 DO_3D( 0, 0, 0, 0, 3, jpkm1 ) 354 DO_3D( 0, 0, 0, 0, 3, jpkm1 ) ! First recurrence : Dk = Dk - Lk * Uk-1 / Dk-1 347 355 zdiag(ji,jj,jk) = zdiag(ji,jj,jk) - zd_lw(ji,jj,jk) * zd_up(ji,jj,jk-1) / zdiag(ji,jj,jk-1) 348 356 END_3D 349 DO_2D( 0, 0, 0, 0 ) 357 DO_2D( 0, 0, 0, 0 ) ! Second recurrence : Lk = RHSk - Lk / Dk-1 * Lk-1 350 358 zd_lw(ji,jj,2) = en(ji,jj,2) - zd_lw(ji,jj,2) * en(ji,jj,1) ! Surface boudary conditions on tke 351 359 END_2D … … 353 361 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) 354 362 END_3D 355 DO_2D( 0, 0, 0, 0 ) 363 DO_2D( 0, 0, 0, 0 ) ! thrid recurrence : Ek = ( Lk - Uk * Ek+1 ) / Dk 356 364 en(ji,jj,jpkm1) = zd_lw(ji,jj,jpkm1) / zdiag(ji,jj,jpkm1) 357 365 END_2D … … 359 367 en(ji,jj,jk) = ( zd_lw(ji,jj,jk) - zd_up(ji,jj,jk) * en(ji,jj,jk+1) ) / zdiag(ji,jj,jk) 360 368 END_3D 361 DO_3D( 0, 0, 0, 0, 2, jpkm1 ) 369 DO_3D( 0, 0, 0, 0, 2, jpkm1 ) ! set the minimum value of tke 362 370 en(ji,jj,jk) = MAX( en(ji,jj,jk), rn_emin ) * wmask(ji,jj,jk) 363 371 END_3D … … 368 376 !!gm BUG : in the exp remove the depth of ssh !!! 369 377 !!gm i.e. use gde3w in argument (gdepw(:,:,:,Kmm)) 370 371 378 ! 379 ! penetration is partly switched off below sea-ice if nn_eice/=0 380 ! 372 381 IF( nn_etau == 1 ) THEN !* penetration below the mixed layer (rn_efr fraction) 373 DO_3D( 0, 0, 0, 0, 2, jpkm1 ) 382 DO_3D( 0, 0, 0, 0, 2, jpkm1 ) 374 383 en(ji,jj,jk) = en(ji,jj,jk) + rn_efr * en(ji,jj,1) * EXP( -gdepw(ji,jj,jk,Kmm) / htau(ji,jj) ) & 375 & * MAX( 0.,1._wp - rn_eice *fr_i(ji,jj) )* wmask(ji,jj,jk) * tmask(ji,jj,1)384 & * MAX( 0._wp, 1._wp - zice_fra(ji,jj) ) * wmask(ji,jj,jk) * tmask(ji,jj,1) 376 385 END_3D 377 386 ELSEIF( nn_etau == 2 ) THEN !* act only at the base of the mixed layer (jk=nmln) (rn_efr fraction) … … 379 388 jk = nmln(ji,jj) 380 389 en(ji,jj,jk) = en(ji,jj,jk) + rn_efr * en(ji,jj,1) * EXP( -gdepw(ji,jj,jk,Kmm) / htau(ji,jj) ) & 381 & * MAX( 0.,1._wp - rn_eice *fr_i(ji,jj) )* wmask(ji,jj,jk) * tmask(ji,jj,1)390 & * MAX( 0._wp, 1._wp - zice_fra(ji,jj) ) * wmask(ji,jj,jk) * tmask(ji,jj,1) 382 391 END_2D 383 392 ELSEIF( nn_etau == 3 ) THEN !* penetration belox the mixed layer (HF variability) … … 389 398 zdif = rhftau_scl * MAX( 0._wp, zdif + rhftau_add ) ! apply some modifications... 390 399 en(ji,jj,jk) = en(ji,jj,jk) + zbbrau * zdif * EXP( -gdepw(ji,jj,jk,Kmm) / htau(ji,jj) ) & 391 & * MAX( 0.,1._wp - rn_eice *fr_i(ji,jj) ) * wmask(ji,jj,jk) * tmask(ji,jj,1)400 & * MAX( 0._wp, 1._wp - zice_fra(ji,jj) ) * wmask(ji,jj,jk) * tmask(ji,jj,1) 392 401 END_3D 393 402 ENDIF … … 451 460 zmxlm(:,:,:) = rmxl_min 452 461 zmxld(:,:,:) = rmxl_min 453 ! 462 ! 454 463 IF( ln_mxl0 ) THEN ! surface mixing length = F(stress) : l=vkarmn*2.e5*taum/(rho0*g) 455 464 ! 456 465 zraug = vkarmn * 2.e5_wp / ( rho0 * grav ) 457 466 #if ! defined key_si3 && ! defined key_cice 458 DO_2D( 0, 0, 0, 0 ) 467 DO_2D( 0, 0, 0, 0 ) ! No sea-ice 459 468 zmxlm(ji,jj,1) = zraug * taum(ji,jj) * tmask(ji,jj,1) 460 469 END_2D … … 467 476 END_2D 468 477 ! 469 CASE( 1 ) 478 CASE( 1 ) ! scaling with constant sea-ice thickness 470 479 DO_2D( 0, 0, 0, 0 ) 471 zmxlm(ji,jj,1) = ( ( 1. - fr_i(ji,jj) ) * zraug * taum(ji,jj) + fr_i(ji,jj) * rn_mxlice ) * tmask(ji,jj,1) 480 zmxlm(ji,jj,1) = ( ( 1._wp - fr_i(ji,jj) ) * zraug * taum(ji,jj) + & 481 & fr_i(ji,jj) * rn_mxlice ) * tmask(ji,jj,1) 472 482 END_2D 473 483 ! 474 CASE( 2 ) 484 CASE( 2 ) ! scaling with mean sea-ice thickness 475 485 DO_2D( 0, 0, 0, 0 ) 476 486 #if defined key_si3 477 zmxlm(ji,jj,1) = ( ( 1. - fr_i(ji,jj) ) * zraug * taum(ji,jj) + fr_i(ji,jj) * hm_i(ji,jj) * 2. ) * tmask(ji,jj,1) 487 zmxlm(ji,jj,1) = ( ( 1._wp - fr_i(ji,jj) ) * zraug * taum(ji,jj) + & 488 & fr_i(ji,jj) * hm_i(ji,jj) * 2._wp ) * tmask(ji,jj,1) 478 489 #elif defined key_cice 479 490 zmaxice = MAXVAL( h_i(ji,jj,:) ) 480 zmxlm(ji,jj,1) = ( ( 1. - fr_i(ji,jj) ) * zraug * taum(ji,jj) + fr_i(ji,jj) * zmaxice ) * tmask(ji,jj,1) 491 zmxlm(ji,jj,1) = ( ( 1._wp - fr_i(ji,jj) ) * zraug * taum(ji,jj) + & 492 & fr_i(ji,jj) * zmaxice ) * tmask(ji,jj,1) 481 493 #endif 482 494 END_2D 483 495 ! 484 CASE( 3 ) 496 CASE( 3 ) ! scaling with max sea-ice thickness 485 497 DO_2D( 0, 0, 0, 0 ) 486 498 zmaxice = MAXVAL( h_i(ji,jj,:) ) 487 zmxlm(ji,jj,1) = ( ( 1. - fr_i(ji,jj) ) * zraug * taum(ji,jj) + fr_i(ji,jj) * zmaxice ) * tmask(ji,jj,1) 499 zmxlm(ji,jj,1) = ( ( 1._wp - fr_i(ji,jj) ) * zraug * taum(ji,jj) + & 500 & fr_i(ji,jj) * zmaxice ) * tmask(ji,jj,1) 488 501 END_2D 489 502 ! … … 533 546 ! 534 547 CASE ( 2 ) ! |dk[xml]| bounded by e3t : 535 DO_3D( 0, 0, 0, 0, 2, jpkm1 ) 548 DO_3D( 0, 0, 0, 0, 2, jpkm1 ) ! from the surface to the bottom : 536 549 zmxlm(ji,jj,jk) = & 537 550 & MIN( zmxlm(ji,jj,jk-1) + e3t(ji,jj,jk-1,Kmm), zmxlm(ji,jj,jk) ) 538 551 END_3D 539 DO_3DS( 0, 0, 0, 0, jpkm1, 2, -1 ) 552 DO_3DS( 0, 0, 0, 0, jpkm1, 2, -1 ) ! from the bottom to the surface : 540 553 zemxl = MIN( zmxlm(ji,jj,jk+1) + e3t(ji,jj,jk+1,Kmm), zmxlm(ji,jj,jk) ) 541 554 zmxlm(ji,jj,jk) = zemxl … … 544 557 ! 545 558 CASE ( 3 ) ! lup and ldown, |dk[xml]| bounded by e3t : 546 DO_3D( 0, 0, 0, 0, 2, jpkm1 ) 559 DO_3D( 0, 0, 0, 0, 2, jpkm1 ) ! from the surface to the bottom : lup 547 560 zmxld(ji,jj,jk) = & 548 561 & MIN( zmxld(ji,jj,jk-1) + e3t(ji,jj,jk-1,Kmm), zmxlm(ji,jj,jk) ) 549 562 END_3D 550 DO_3DS( 0, 0, 0, 0, jpkm1, 2, -1 ) 563 DO_3DS( 0, 0, 0, 0, jpkm1, 2, -1 ) ! from the bottom to the surface : ldown 551 564 zmxlm(ji,jj,jk) = & 552 565 & MIN( zmxlm(ji,jj,jk+1) + e3t(ji,jj,jk+1,Kmm), zmxlm(ji,jj,jk) ) … … 564 577 ! ! Vertical eddy viscosity and diffusivity (avm and avt) 565 578 ! !<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<< 566 DO_3D( 0, 0, 0, 0, 1, jpkm1 ) 579 DO_3D( 0, 0, 0, 0, 1, jpkm1 ) !* vertical eddy viscosity & diffivity at w-points 567 580 zsqen = SQRT( en(ji,jj,jk) ) 568 581 zav = rn_ediff * zmxlm(ji,jj,jk) * zsqen … … 573 586 ! 574 587 ! 575 IF( nn_pdl == 1 ) THEN !* Prandtl number case: update avt588 IF( nn_pdl == 1 ) THEN !* Prandtl number case: update avt 576 589 DO_3D( 0, 0, 0, 0, 2, jpkm1 ) 577 590 p_avt(ji,jj,jk) = MAX( apdlr(ji,jj,jk) * p_avt(ji,jj,jk), avtb_2d(ji,jj) * avtb(jk) ) * wmask(ji,jj,jk) … … 610 623 & rn_emin0, rn_bshear, nn_mxl , ln_mxl0 , & 611 624 & rn_mxl0 , nn_mxlice, rn_mxlice, & 612 & nn_pdl , ln_ drg , ln_lc , rn_lc,&613 & nn_etau , nn_htau , rn_efr , rn_eice625 & nn_pdl , ln_lc , rn_lc , & 626 & nn_etau , nn_htau , rn_efr , nn_eice 614 627 !!---------------------------------------------------------------------- 615 628 ! … … 637 650 WRITE(numout,*) ' mixing length type nn_mxl = ', nn_mxl 638 651 WRITE(numout,*) ' surface mixing length = F(stress) or not ln_mxl0 = ', ln_mxl0 652 WRITE(numout,*) ' surface mixing length minimum value rn_mxl0 = ', rn_mxl0 639 653 IF( ln_mxl0 ) THEN 640 654 WRITE(numout,*) ' type of scaling under sea-ice nn_mxlice = ', nn_mxlice 641 655 IF( nn_mxlice == 1 ) & 642 656 WRITE(numout,*) ' ice thickness when scaling under sea-ice rn_mxlice = ', rn_mxlice 643 ENDIF 644 WRITE(numout,*) ' surface mixing length minimum value rn_mxl0 = ', rn_mxl0 645 WRITE(numout,*) ' top/bottom friction forcing flag ln_drg = ', ln_drg 657 SELECT CASE( nn_mxlice ) ! Type of scaling under sea-ice 658 CASE( 0 ) ; WRITE(numout,*) ' ==>>> No scaling under sea-ice' 659 CASE( 1 ) ; WRITE(numout,*) ' ==>>> scaling with constant sea-ice thickness' 660 CASE( 2 ) ; WRITE(numout,*) ' ==>>> scaling with mean sea-ice thickness' 661 CASE( 3 ) ; WRITE(numout,*) ' ==>>> scaling with max sea-ice thickness' 662 CASE DEFAULT 663 CALL ctl_stop( 'zdf_tke_init: wrong value for nn_mxlice, should be 0,1,2,3 or 4') 664 END SELECT 665 ENDIF 646 666 WRITE(numout,*) ' Langmuir cells parametrization ln_lc = ', ln_lc 647 667 WRITE(numout,*) ' coef to compute vertical velocity of LC rn_lc = ', rn_lc … … 649 669 WRITE(numout,*) ' type of tke penetration profile nn_htau = ', nn_htau 650 670 WRITE(numout,*) ' fraction of TKE that penetrates rn_efr = ', rn_efr 651 WRITE(numout,*) ' below sea-ice: =0 ON rn_eice = ', rn_eice 652 WRITE(numout,*) ' =4 OFF when ice fraction > 1/4 ' 653 IF( ln_drg ) THEN 654 WRITE(numout,*) 655 WRITE(numout,*) ' Namelist namdrg_top/_bot: used values:' 656 WRITE(numout,*) ' top ocean cavity roughness (m) rn_z0(_top)= ', r_z0_top 657 WRITE(numout,*) ' Bottom seafloor roughness (m) rn_z0(_bot)= ', r_z0_bot 658 ENDIF 671 WRITE(numout,*) ' langmuir & surface wave breaking under ice nn_eice = ', nn_eice 672 SELECT CASE( nn_eice ) 673 CASE( 0 ) ; WRITE(numout,*) ' ==>>> no impact of ice cover on langmuir & surface wave breaking' 674 CASE( 1 ) ; WRITE(numout,*) ' ==>>> weigthed by 1-TANH( fr_i(:,:) * 10 )' 675 CASE( 2 ) ; WRITE(numout,*) ' ==>>> weighted by 1-fr_i(:,:)' 676 CASE( 3 ) ; WRITE(numout,*) ' ==>>> weighted by 1-MIN( 1, 4 * fr_i(:,:) )' 677 CASE DEFAULT 678 CALL ctl_stop( 'zdf_tke_init: wrong value for nn_eice, should be 0,1,2, or 3') 679 END SELECT 659 680 WRITE(numout,*) 660 681 WRITE(numout,*) ' ==>>> critical Richardson nb with your parameters ri_cri = ', ri_cri -
NEMO/branches/2020/dev_r13327_KERNEL-06_2_techene_e3/src/OCE/module_example
r11536 r13998 93 93 INTEGER :: ji, jj, jk ! dummy loop arguments (DOCTOR : start with j, but not jp) 94 94 INTEGER :: itoto, itata ! temporary integers (DOCTOR : start with i 95 REAL(wp) :: zmlmin, zbbr au! temporary scalars (DOCTOR : start with z)95 REAL(wp) :: zmlmin, zbbrho ! temporary scalars (DOCTOR : start with z) 96 96 REAL(wp) :: zfact1, zfact2 ! do not use continuation lines in declaration 97 97 REAL(wp), DIMENSION(jpi,jpj) :: zwrk_2d ! 2D workspace … … 101 101 102 102 zmlmin = 1.e-8 ! Local constant initialization 103 zbbr au = .5 * ebb / rau0103 zbbrho = .5 * ebb / rho0 104 104 zfact1 = -.5 * rdt * efave 105 105 zfact2 = 1.5 * rdt * ediss -
NEMO/branches/2020/dev_r13327_KERNEL-06_2_techene_e3/src/OCE/nemogcm.F90
r13915 r13998 449 449 ! ! Lateral physics 450 450 CALL ldf_tra_init ! Lateral ocean tracer physics 451 CALL ldf_eiv_init ! eddy induced velocity param. 451 CALL ldf_eiv_init ! eddy induced velocity param. must be done after ldf_tra_init 452 452 CALL ldf_dyn_init ! Lateral ocean momentum physics 453 453 … … 487 487 CALL flo_init( Nnn ) ! drifting Floats 488 488 IF( ln_diacfl ) CALL dia_cfl_init ! Initialise CFL diagnostics 489 ! CALL dia_ptr_init ! Poleward TRansports initialization490 489 CALL dia_dct_init ! Sections tranports 491 490 CALL dia_hsb_init( Nnn ) ! heat content, salt content and volume budgets -
NEMO/branches/2020/dev_r13327_KERNEL-06_2_techene_e3/src/OCE/stpctl.F90
r13608 r13998 49 49 !! 50 50 !! ** Method : - Save the time step in numstp 51 !! - Print it each 50 time steps52 51 !! - Stop the run IF problem encountered by setting nstop > 0 53 52 !! Problems checked: |ssh| maximum larger than 10 m … … 68 67 REAL(wp) :: zzz ! local real 69 68 REAL(wp), DIMENSION(9) :: zmax, zmaxlocal 70 LOGICAL :: ll_wrtstp, ll_colruns, ll_wrtruns 69 LOGICAL :: ll_wrtstp, ll_colruns, ll_wrtruns, ll_0oce 71 70 LOGICAL, DIMENSION(jpi,jpj,jpk) :: llmsk 72 71 CHARACTER(len=20) :: clname … … 120 119 ! !== test of local extrema ==! 121 120 ! !== done by all processes at every time step ==! 122 llmsk(:,:,1) = ssmask(:,:) == 1._wp 121 ! 122 llmsk( 1:Nis1,:,:) = .FALSE. ! exclude halos from the checked region 123 llmsk(Nie1: jpi,:,:) = .FALSE. 124 llmsk(:, 1:Njs1,:) = .FALSE. 125 llmsk(:,Nje1: jpj,:) = .FALSE. 126 ! 127 llmsk(Nis0:Nie0,Njs0:Nje0,1) = ssmask(Nis0:Nie0,Njs0:Nje0) == 1._wp ! define only the inner domain 128 ! 129 ll_0oce = .NOT. ANY( llmsk(:,:,1) ) ! no ocean point in the inner domain? 130 ! 123 131 IF( ll_wd ) THEN 124 132 zmax(1) = MAXVAL( ABS( ssh(:,:,Kmm) + ssh_ref ), mask = llmsk(:,:,1) ) ! ssh max … … 126 134 zmax(1) = MAXVAL( ABS( ssh(:,:,Kmm) ), mask = llmsk(:,:,1) ) ! ssh max 127 135 ENDIF 128 llmsk( :,:,:) = umask(:,:,:) == 1._wp136 llmsk(Nis0:Nie0,Njs0:Nje0,:) = umask(Nis0:Nie0,Njs0:Nje0,:) == 1._wp ! define only the inner domain 129 137 zmax(2) = MAXVAL( ABS( uu(:,:,:,Kmm) ), mask = llmsk ) ! velocity max (zonal only) 130 llmsk( :,:,:) = tmask(:,:,:) == 1._wp138 llmsk(Nis0:Nie0,Njs0:Nje0,:) = tmask(Nis0:Nie0,Njs0:Nje0,:) == 1._wp ! define only the inner domain 131 139 zmax(3) = MAXVAL( -ts(:,:,:,jp_sal,Kmm), mask = llmsk ) ! minus salinity max 132 140 zmax(4) = MAXVAL( ts(:,:,:,jp_sal,Kmm), mask = llmsk ) ! salinity max … … 144 152 zmax(5:8) = 0._wp 145 153 ENDIF 146 zmax(9) = REAL( nstop, wp ) ! stop indicator 154 zmax(9) = REAL( nstop, wp ) ! stop indicator 155 ! 147 156 ! !== get global extrema ==! 148 157 ! !== done by all processes if writting run.stat ==! 149 158 IF( ll_colruns ) THEN 150 159 zmaxlocal(:) = zmax(:) 151 CALL mpp_max( "stpctl", zmax ) ! max over the global domain 160 CALL mpp_max( "stpctl", zmax ) ! max over the global domain: ok even of ll_0oce = .true. 152 161 nstop = NINT( zmax(9) ) ! update nstop indicator (now sheared among all local domains) 153 ENDIF 162 ELSE 163 ! if no ocean point: MAXVAL returns -HUGE => we must overwrite this value to avoid error handling bellow. 164 IF( ll_0oce ) zmax(1:4) = (/ 0._wp, 0._wp, -1._wp, 1._wp /) ! default "valid" values... 165 ENDIF 166 ! 167 zmax(3) = -zmax(3) ! move back from max(-zz) to min(zz) : easier to manage! 168 zmax(5) = -zmax(5) ! move back from max(-zz) to min(zz) : easier to manage! 169 IF( ll_colruns ) THEN 170 zmaxlocal(3) = -zmaxlocal(3) ! move back from max(-zz) to min(zz) : easier to manage! 171 zmaxlocal(5) = -zmaxlocal(5) ! move back from max(-zz) to min(zz) : easier to manage! 172 ENDIF 173 ! 154 174 ! !== write "run.stat" files ==! 155 175 ! !== done only by 1st subdomain at writting timestep ==! 156 176 IF( ll_wrtruns ) THEN 157 WRITE(numrun,9500) kt, zmax(1), zmax(2), -zmax(3), zmax(4) 158 istatus = NF90_PUT_VAR( nrunid, nvarid(1), (/ zmax(1)/), (/kt/), (/1/) ) 159 istatus = NF90_PUT_VAR( nrunid, nvarid(2), (/ zmax(2)/), (/kt/), (/1/) ) 160 istatus = NF90_PUT_VAR( nrunid, nvarid(3), (/-zmax(3)/), (/kt/), (/1/) ) 161 istatus = NF90_PUT_VAR( nrunid, nvarid(4), (/ zmax(4)/), (/kt/), (/1/) ) 162 istatus = NF90_PUT_VAR( nrunid, nvarid(5), (/-zmax(5)/), (/kt/), (/1/) ) 163 istatus = NF90_PUT_VAR( nrunid, nvarid(6), (/ zmax(6)/), (/kt/), (/1/) ) 164 IF( ln_zad_Aimp ) THEN 165 istatus = NF90_PUT_VAR( nrunid, nvarid(7), (/ zmax(7)/), (/kt/), (/1/) ) 166 istatus = NF90_PUT_VAR( nrunid, nvarid(8), (/ zmax(8)/), (/kt/), (/1/) ) 167 ENDIF 177 WRITE(numrun,9500) kt, zmax(1), zmax(2), zmax(3), zmax(4) 178 DO ji = 1, 6 + 2 * COUNT( (/ln_zad_Aimp/) ) 179 istatus = NF90_PUT_VAR( nrunid, nvarid(ji), (/zmax(ji)/), (/kt/), (/1/) ) 180 END DO 168 181 IF( kt == nitend ) istatus = NF90_CLOSE(nrunid) 169 182 ENDIF … … 171 184 ! !== done by all processes at every time step ==! 172 185 ! 173 IF( 174 & 175 & zmax(3) >= 0._wp .OR. & ! negative or zero sea surface salinity176 & 177 & 178 & 179 & 186 IF( zmax(1) > 20._wp .OR. & ! too large sea surface height ( > 20 m ) 187 & zmax(2) > 10._wp .OR. & ! too large velocity ( > 10 m/s) 188 & zmax(3) <= 0._wp .OR. & ! negative or zero sea surface salinity 189 & zmax(4) >= 100._wp .OR. & ! too large sea surface salinity ( > 100 ) 190 & zmax(4) < 0._wp .OR. & ! too large sea surface salinity (keep this line for sea-ice) 191 & ISNAN( zmax(1) + zmax(2) + zmax(3) ) .OR. & ! NaN encounter in the tests 192 & ABS( zmax(1) + zmax(2) + zmax(3) ) > HUGE(1._wp) ) THEN ! Infinity encounter in the tests 180 193 ! 181 194 iloc(:,:) = 0 … … 184 197 IF( lwm .AND. kt /= nitend ) istatus = NF90_CLOSE(nrunid) 185 198 ! get global loc on the min/max 186 CALL mpp_maxloc( 'stpctl', ABS(ssh(:,:, Kmm)), ssmask(:,: ), zzz, iloc(1:2,1) ) ! mpp_maxloc ok if mask = F 187 CALL mpp_maxloc( 'stpctl', ABS( uu(:,:,:, Kmm)), umask(:,:,:), zzz, iloc(1:3,2) ) 188 CALL mpp_minloc( 'stpctl', ts(:,:,:,jp_sal,Kmm) , tmask(:,:,:), zzz, iloc(1:3,3) ) 189 CALL mpp_maxloc( 'stpctl', ts(:,:,:,jp_sal,Kmm) , tmask(:,:,:), zzz, iloc(1:3,4) ) 199 llmsk(Nis0:Nie0,Njs0:Nje0,1) = ssmask(Nis0:Nie0,Njs0:Nje0 ) == 1._wp ! define only the inner domain 200 CALL mpp_maxloc( 'stpctl', ABS(ssh(:,:, Kmm)), llmsk(:,:,1), zzz, iloc(1:2,1) ) ! mpp_maxloc ok if mask = F 201 llmsk(Nis0:Nie0,Njs0:Nje0,:) = umask(Nis0:Nie0,Njs0:Nje0,:) == 1._wp ! define only the inner domain 202 CALL mpp_maxloc( 'stpctl', ABS( uu(:,:,:, Kmm)), llmsk(:,:,:), zzz, iloc(1:3,2) ) 203 llmsk(Nis0:Nie0,Njs0:Nje0,:) = tmask(Nis0:Nie0,Njs0:Nje0,:) == 1._wp ! define only the inner domain 204 CALL mpp_minloc( 'stpctl', ts(:,:,:,jp_sal,Kmm) , llmsk(:,:,:), zzz, iloc(1:3,3) ) 205 CALL mpp_maxloc( 'stpctl', ts(:,:,:,jp_sal,Kmm) , llmsk(:,:,:), zzz, iloc(1:3,4) ) 190 206 ! find which subdomain has the max. 191 207 iareamin(:) = jpnij+1 ; iareamax(:) = 0 ; iareasum(:) = 0 … … 200 216 ELSE ! find local min and max locations: 201 217 ! if we are here, this means that the subdomain contains some oce points -> no need to test the mask used in maxloc 202 iloc(1:2,1) = MAXLOC( ABS( ssh(:,:, Kmm)), mask = ssmask(:,: ) == 1._wp ) + (/ nimpp - 1, njmpp - 1 /) 203 iloc(1:3,2) = MAXLOC( ABS( uu(:,:,:, Kmm)), mask = umask(:,:,:) == 1._wp ) + (/ nimpp - 1, njmpp - 1, 0 /) 204 iloc(1:3,3) = MINLOC( ts(:,:,:,jp_sal,Kmm) , mask = tmask(:,:,:) == 1._wp ) + (/ nimpp - 1, njmpp - 1, 0 /) 205 iloc(1:3,4) = MAXLOC( ts(:,:,:,jp_sal,Kmm) , mask = tmask(:,:,:) == 1._wp ) + (/ nimpp - 1, njmpp - 1, 0 /) 218 llmsk(Nis0:Nie0,Njs0:Nje0,1) = ssmask(Nis0:Nie0,Njs0:Nje0 ) == 1._wp ! define only the inner domain 219 iloc(1:2,1) = MAXLOC( ABS( ssh(:,:, Kmm)), mask = llmsk(:,:,1) ) 220 llmsk(Nis0:Nie0,Njs0:Nje0,:) = umask(Nis0:Nie0,Njs0:Nje0,:) == 1._wp ! define only the inner domain 221 iloc(1:3,2) = MAXLOC( ABS( uu(:,:,:, Kmm)), mask = llmsk(:,:,:) ) 222 llmsk(Nis0:Nie0,Njs0:Nje0,:) = tmask(Nis0:Nie0,Njs0:Nje0,:) == 1._wp ! define only the inner domain 223 iloc(1:3,3) = MINLOC( ts(:,:,:,jp_sal,Kmm) , mask = llmsk(:,:,:) ) 224 iloc(1:3,4) = MAXLOC( ts(:,:,:,jp_sal,Kmm) , mask = llmsk(:,:,:) ) 225 DO ji = 1, 4 ! local domain indices ==> global domain indices, excluding halos 226 iloc(1:2,ji) = (/ mig0(iloc(1,ji)), mjg0(iloc(2,ji)) /) 227 END DO 206 228 iareamin(:) = narea ; iareamax(:) = narea ; iareasum(:) = 1 ! this is local information 207 229 ENDIF 208 230 ! 209 231 WRITE(ctmp1,*) ' stp_ctl: |ssh| > 20 m or |U| > 10 m/s or S <= 0 or S >= 100 or NaN encounter in the tests' 210 CALL wrt_line( ctmp2, kt, '|ssh| max', 211 CALL wrt_line( ctmp3, kt, '|U| max', 212 CALL wrt_line( ctmp4, kt, 'Sal min', -zmax(3), iloc(:,3), iareasum(3), iareamin(3), iareamax(3) )213 CALL wrt_line( ctmp5, kt, 'Sal max', 232 CALL wrt_line( ctmp2, kt, '|ssh| max', zmax(1), iloc(:,1), iareasum(1), iareamin(1), iareamax(1) ) 233 CALL wrt_line( ctmp3, kt, '|U| max', zmax(2), iloc(:,2), iareasum(2), iareamin(2), iareamax(2) ) 234 CALL wrt_line( ctmp4, kt, 'Sal min', zmax(3), iloc(:,3), iareasum(3), iareamin(3), iareamax(3) ) 235 CALL wrt_line( ctmp5, kt, 'Sal max', zmax(4), iloc(:,4), iareasum(4), iareamin(4), iareamax(4) ) 214 236 IF( Agrif_Root() ) THEN 215 237 WRITE(ctmp6,*) ' ===> output of last computed fields in output.abort* files' -
NEMO/branches/2020/dev_r13327_KERNEL-06_2_techene_e3/src/OCE/timing.F90
r12489 r13998 213 213 214 214 215 SUBROUTINE timing_init 215 SUBROUTINE timing_init( clname ) 216 216 !!---------------------------------------------------------------------- 217 217 !! *** ROUTINE timing_init *** … … 221 221 REAL(wp) :: zdum 222 222 LOGICAL :: ll_f 223 223 CHARACTER(len=*), INTENT(in), OPTIONAL :: clname 224 CHARACTER(len=20) :: cln 225 226 IF( PRESENT(clname) ) THEN ; cln = clname 227 ELSE ; cln = 'timing.output' 228 ENDIF 229 224 230 IF( ln_onefile ) THEN 225 IF( lwp) CALL ctl_opn( numtime, 'timing.output', 'REPLACE', 'FORMATTED', 'SEQUENTIAL', -1, numout,.TRUE., narea )231 IF( lwp) CALL ctl_opn( numtime, cln, 'REPLACE', 'FORMATTED', 'SEQUENTIAL', -1, numout,.TRUE., narea ) 226 232 lwriter = lwp 227 233 ELSE 228 CALL ctl_opn( numtime, 'timing.output', 'REPLACE', 'FORMATTED', 'SEQUENTIAL', -1, numout,.FALSE., narea )234 CALL ctl_opn( numtime, cln, 'REPLACE', 'FORMATTED', 'SEQUENTIAL', -1, numout,.FALSE., narea ) 229 235 lwriter = .TRUE. 230 236 ENDIF … … 418 424 s_timer => s_timer_root 419 425 DO WHILE ( ASSOCIATED( s_timer%next ) ) 420 IF (.NOT. ASSOCIATED(s_timer%next)) EXIT426 IF (.NOT. ASSOCIATED(s_timer%next)) EXIT 421 427 IF ( s_timer%tsum_clock < s_timer%next%tsum_clock ) THEN 422 428 ALLOCATE(s_wrk) … … 426 432 ll_ord = .FALSE. 427 433 CYCLE 428 ENDIF 429 IF( ASSOCIATED(s_timer%next) ) s_timer => s_timer%next430 END DO 434 ENDIF 435 IF( ASSOCIATED(s_timer%next) ) s_timer => s_timer%next 436 END DO 431 437 IF( ll_ord ) EXIT 432 438 END DO … … 441 447 clfmt = '(1x,a,4x,f12.3,6x,f12.3,x,f12.3,2x,f12.3,6x,f7.3,2x,i9)' 442 448 DO WHILE ( ASSOCIATED(s_timer) ) 443 WRITE(numtime,TRIM(clfmt)) s_timer%cname, & 444 & s_timer%tsum_clock,s_timer%tsum_clock*100./t_elaps(2), & 445 & s_timer%tsum_cpu ,s_timer%tsum_cpu*100./t_cpu(2) , & 446 & s_timer%tsum_cpu/s_timer%tsum_clock, s_timer%niter 449 IF( s_timer%tsum_clock > 0._wp ) & 450 WRITE(numtime,TRIM(clfmt)) s_timer%cname, & 451 & s_timer%tsum_clock,s_timer%tsum_clock*100./t_elaps(2), & 452 & s_timer%tsum_cpu ,s_timer%tsum_cpu*100./t_cpu(2) , & 453 & s_timer%tsum_cpu/s_timer%tsum_clock, s_timer%niter 447 454 s_timer => s_timer%next 448 455 END DO … … 607 614 clfmt = '((A),E15.7,2x,f6.2,5x,f12.2,5x,f6.2,5x,f7.2,2x,f12.2,4x,f6.2,2x,f9.2)' 608 615 DO WHILE ( ASSOCIATED(sl_timer_ave) ) 609 WRITE(numtime,TRIM(clfmt)) sl_timer_ave%cname(1:18), & 610 & sl_timer_ave%tsum_clock,sl_timer_ave%tsum_clock*100.*jpnij/tot_etime, & 611 & sl_timer_ave%tsum_cpu ,sl_timer_ave%tsum_cpu*100.*jpnij/tot_ctime , & 612 & sl_timer_ave%tsum_cpu/sl_timer_ave%tsum_clock, & 613 & sl_timer_ave%tmax_clock*100.*jpnij/tot_etime, & 614 & sl_timer_ave%tmin_clock*100.*jpnij/tot_etime, & 615 & sl_timer_ave%niter/REAL(jpnij) 616 IF( sl_timer_ave%tsum_clock > 0. ) & 617 WRITE(numtime,TRIM(clfmt)) sl_timer_ave%cname(1:18), & 618 & sl_timer_ave%tsum_clock,sl_timer_ave%tsum_clock*100.*jpnij/tot_etime, & 619 & sl_timer_ave%tsum_cpu ,sl_timer_ave%tsum_cpu*100.*jpnij/tot_ctime , & 620 & sl_timer_ave%tsum_cpu/sl_timer_ave%tsum_clock, & 621 & sl_timer_ave%tmax_clock*100.*jpnij/tot_etime, & 622 & sl_timer_ave%tmin_clock*100.*jpnij/tot_etime, & 623 & sl_timer_ave%niter/REAL(jpnij) 616 624 sl_timer_ave => sl_timer_ave%next 617 625 END DO
Note: See TracChangeset
for help on using the changeset viewer.