- Timestamp:
- 2020-10-06T18:17:44+02:00 (4 years ago)
- Location:
- NEMO/branches/2020/dev_r13296_HPC-07_mocavero_mpi3/src/OCE
- Files:
-
- 109 edited
Legend:
- Unmodified
- Added
- Removed
-
NEMO/branches/2020/dev_r13296_HPC-07_mocavero_mpi3/src/OCE/BDY/bdy_oce.F90
r12377 r13571 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_r13296_HPC-07_mocavero_mpi3/src/OCE/BDY/bdydta.F90
r13237 r13571 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_r13296_HPC-07_mocavero_mpi3/src/OCE/BDY/bdyice.F90
r13226 r13571 94 94 IF( ANY(llsend1) .OR. ANY(llrecv1) ) THEN ! if need to send/recv in at least one direction 95 95 ! 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)96 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 & 97 & , 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 & 98 & , a_ip, 'T', 1._wp, v_ip, 'T', 1._wp, v_il, 'T', 1._wp & 99 & , kfillmode=jpfillnothing ,lsend=llsend1, lrecv=llrecv1 ) 100 100 ! 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 )101 CALL lbc_lnk_multi('bdyice', t_s , 'T', 1._wp, e_s , 'T', 1._wp, kfillmode=jpfillnothing ,lsend=llsend1, lrecv=llrecv1 ) 102 CALL lbc_lnk_multi('bdyice', t_i , 'T', 1._wp, e_i , 'T', 1._wp, kfillmode=jpfillnothing ,lsend=llsend1, lrecv=llrecv1 ) 103 103 END IF 104 104 END DO ! ir … … 163 163 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 164 h_ip(ji,jj, jl) = ( h_ip(ji,jj, jl) * zwgt1 + dta%hip(i_bdy,jl) * zwgt ) * tmask(ji,jj,1) ! Ice pond depth 165 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 166 ! 166 167 sz_i(ji,jj,:,jl) = s_i(ji,jj,jl) … … 170 171 a_ip(ji,jj,jl) = 0._wp 171 172 h_ip(ji,jj,jl) = 0._wp 173 h_il(ji,jj,jl) = 0._wp 174 ENDIF 175 176 IF( .NOT.ln_pnd_lids ) THEN 177 h_il(ji,jj,jl) = 0._wp 172 178 ENDIF 173 179 ! … … 231 237 a_ip(ji,jj, jl) = a_ip(ib,jb, jl) 232 238 h_ip(ji,jj, jl) = h_ip(ib,jb, jl) 239 h_il(ji,jj, jl) = h_il(ib,jb, jl) 233 240 ! 234 241 sz_i(ji,jj,:,jl) = sz_i(ib,jb,:,jl) … … 265 272 ! 266 273 ! 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 274 v_ip(ji,jj,jl) = h_ip(ji,jj,jl) * a_ip(ji,jj,jl) 275 v_il(ji,jj,jl) = h_il(ji,jj,jl) * a_ip(ji,jj,jl) 273 276 ! 274 277 ELSE ! no ice at the boundary … … 278 281 h_s (ji,jj, jl) = 0._wp 279 282 oa_i(ji,jj, jl) = 0._wp 280 a_ip(ji,jj, jl) = 0._wp281 v_ip(ji,jj, jl) = 0._wp282 283 t_su(ji,jj, jl) = rt0 283 284 t_s (ji,jj,:,jl) = rt0 284 285 t_i (ji,jj,:,jl) = rt0 285 286 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 287 a_ip(ji,jj,jl) = 0._wp 288 h_ip(ji,jj,jl) = 0._wp 289 h_il(ji,jj,jl) = 0._wp 290 290 291 291 IF( nn_icesal == 1 ) THEN ! if constant salinity … … 303 303 e_s (ji,jj,:,jl) = 0._wp 304 304 e_i (ji,jj,:,jl) = 0._wp 305 v_ip(ji,jj, jl) = 0._wp 306 v_il(ji,jj, jl) = 0._wp 305 307 306 308 ENDIF -
NEMO/branches/2020/dev_r13296_HPC-07_mocavero_mpi3/src/OCE/BDY/bdyini.F90
r13286 r13571 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_r13296_HPC-07_mocavero_mpi3/src/OCE/BDY/bdylib.F90
r13226 r13571 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_r13296_HPC-07_mocavero_mpi3/src/OCE/BDY/bdytra.F90
r13226 r13571 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_r13296_HPC-07_mocavero_mpi3/src/OCE/C1D/dtauvd.F90
r13295 r13571 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_r13296_HPC-07_mocavero_mpi3/src/OCE/CRS/crsfld.F90
r13295 r13571 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_r13296_HPC-07_mocavero_mpi3/src/OCE/DIA/diaar5.F90
r13295 r13571 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_r13296_HPC-07_mocavero_mpi3/src/OCE/DIA/diacfl.F90
r13295 r13571 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_r13296_HPC-07_mocavero_mpi3/src/OCE/DIA/diahth.F90
r13295 r13571 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_r13296_HPC-07_mocavero_mpi3/src/OCE/DIA/diaptr.F90
r13295 r13571 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_r13296_HPC-07_mocavero_mpi3/src/OCE/DIA/diawri.F90
r13295 r13571 118 118 INTEGER :: ji, jj, jk ! dummy loop indices 119 119 INTEGER :: ikbot ! local integer 120 REAL(wp):: ze3 120 121 REAL(wp):: zztmp , zztmpx ! local scalar 121 122 REAL(wp):: zztmp2, zztmpy ! - - … … 175 176 CALL iom_put( "sst", ts(:,:,1,jp_tem,Kmm) ) ! surface temperature 176 177 IF ( iom_use("sbt") ) THEN 177 DO_2D( 1, 1, 1, 1)178 DO_2D( 0, 0, 0, 0 ) 178 179 ikbot = mbkt(ji,jj) 179 180 z2d(ji,jj) = ts(ji,jj,ikbot,jp_tem,Kmm) … … 185 186 CALL iom_put( "sss", ts(:,:,1,jp_sal,Kmm) ) ! surface salinity 186 187 IF ( iom_use("sbs") ) THEN 187 DO_2D( 1, 1, 1, 1)188 DO_2D( 0, 0, 0, 0 ) 188 189 ikbot = mbkt(ji,jj) 189 190 z2d(ji,jj) = ts(ji,jj,ikbot,jp_sal,Kmm) … … 207 208 ! 208 209 END_2D 209 CALL lbc_lnk( 'diawri', z2d, 'T', 1.0_wp )210 210 CALL iom_put( "taubot", z2d ) 211 211 ENDIF … … 214 214 CALL iom_put( "ssu", uu(:,:,1,Kmm) ) ! surface i-current 215 215 IF ( iom_use("sbu") ) THEN 216 DO_2D( 1, 1, 1, 1)216 DO_2D( 0, 0, 0, 0 ) 217 217 ikbot = mbku(ji,jj) 218 218 z2d(ji,jj) = uu(ji,jj,ikbot,Kmm) … … 224 224 CALL iom_put( "ssv", vv(:,:,1,Kmm) ) ! surface j-current 225 225 IF ( iom_use("sbv") ) THEN 226 DO_2D( 1, 1, 1, 1)226 DO_2D( 0, 0, 0, 0 ) 227 227 ikbot = mbkv(ji,jj) 228 228 z2d(ji,jj) = vv(ji,jj,ikbot,Kmm) … … 253 253 IF( iom_use('logavs') ) CALL iom_put( "logavs", LOG( MAX( 1.e-20_wp, avs(:,:,:) ) ) ) 254 254 255 IF ( iom_use("socegrad") .OR. iom_use("socegrad2") ) THEN 256 z3d(:,:,jpk) = 0. 257 DO_3D( 0, 0, 0, 0, 1, jpkm1 ) 258 zztmp = ts(ji,jj,jk,jp_sal,Kmm) 259 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) 260 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) 261 z3d(ji,jj,jk) = 0.25 * ( zztmpx * zztmpx + zztmpy * zztmpy ) & 262 & * umask(ji,jj,jk) * umask(ji-1,jj,jk) * vmask(ji,jj,jk) * umask(ji,jj-1,jk) 263 END_3D 264 CALL iom_put( "socegrad2", z3d ) ! square of module of sal gradient 265 DO_3D( 0, 0, 0, 0, 1, jpkm1 ) 266 z3d(ji,jj,jk) = SQRT( z3d(ji,jj,jk) ) 267 END_3D 268 CALL iom_put( "socegrad" , z3d ) ! module of sal gradient 269 ENDIF 270 255 271 IF ( iom_use("sstgrad") .OR. iom_use("sstgrad2") ) THEN 256 DO_2D( 0, 0, 0, 0 ) 272 DO_2D( 0, 0, 0, 0 ) ! sst gradient 257 273 zztmp = ts(ji,jj,1,jp_tem,Kmm) 258 274 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) … … 261 277 & * umask(ji,jj,1) * umask(ji-1,jj,1) * vmask(ji,jj,1) * umask(ji,jj-1,1) 262 278 END_2D 263 CALL lbc_lnk( 'diawri', z2d, 'T', 1.0_wp )264 279 CALL iom_put( "sstgrad2", z2d ) ! square of module of sst gradient 265 z2d(:,:) = SQRT( z2d(:,:) ) 280 DO_2D( 0, 0, 0, 0 ) 281 z2d(ji,jj) = SQRT( z2d(ji,jj) ) 282 END_2D 266 283 CALL iom_put( "sstgrad" , z2d ) ! module of sst gradient 267 284 ENDIF … … 270 287 IF( iom_use("heatc") ) THEN 271 288 z2d(:,:) = 0._wp 272 DO_3D( 1, 1, 1, 1, 1, jpkm1 )289 DO_3D( 0, 0, 0, 0, 1, jpkm1 ) 273 290 z2d(ji,jj) = z2d(ji,jj) + e3t(ji,jj,jk,Kmm) * ts(ji,jj,jk,jp_tem,Kmm) * tmask(ji,jj,jk) 274 291 END_3D … … 278 295 IF( iom_use("saltc") ) THEN 279 296 z2d(:,:) = 0._wp 280 DO_3D( 1, 1, 1, 1, 1, jpkm1 )297 DO_3D( 0, 0, 0, 0, 1, jpkm1 ) 281 298 z2d(ji,jj) = z2d(ji,jj) + e3t(ji,jj,jk,Kmm) * ts(ji,jj,jk,jp_sal,Kmm) * tmask(ji,jj,jk) 282 299 END_3D … … 284 301 ENDIF 285 302 ! 286 IF ( iom_use("eken") ) THEN 303 IF( iom_use("salt2c") ) THEN 304 z2d(:,:) = 0._wp 305 DO_3D( 0, 0, 0, 0, 1, jpkm1 ) 306 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) 307 END_3D 308 CALL iom_put( "salt2c", rho0 * z2d ) ! vertically integrated salt content (PSU*kg/m2) 309 ENDIF 310 ! 311 IF ( iom_use("ke") .OR. iom_use("ke_int") ) THEN 287 312 z3d(:,:,jpk) = 0._wp 288 313 DO_3D( 0, 0, 0, 0, 1, jpkm1 ) 289 zztmp = 0.25_wp * r1_e1e2t(ji,jj) / e3t(ji,jj,jk,Kmm) 290 z3d(ji,jj,jk) = zztmp * ( uu(ji-1,jj,jk,Kmm)**2 * e2u(ji-1,jj) * e3u(ji-1,jj,jk,Kmm) & 291 & + uu(ji ,jj,jk,Kmm)**2 * e2u(ji ,jj) * e3u(ji ,jj,jk,Kmm) & 292 & + vv(ji,jj-1,jk,Kmm)**2 * e1v(ji,jj-1) * e3v(ji,jj-1,jk,Kmm) & 293 & + vv(ji,jj ,jk,Kmm)**2 * e1v(ji,jj ) * e3v(ji,jj ,jk,Kmm) ) 294 END_3D 295 CALL lbc_lnk( 'diawri', z3d, 'T', 1.0_wp ) 296 CALL iom_put( "eken", z3d ) ! kinetic energy 314 zztmpx = 0.5 * ( uu(ji-1,jj ,jk,Kmm) + uu(ji,jj,jk,Kmm) ) 315 zztmpy = 0.5 * ( vv(ji ,jj-1,jk,Kmm) + vv(ji,jj,jk,Kmm) ) 316 z3d(ji,jj,jk) = 0.5 * ( zztmpx*zztmpx + zztmpy*zztmpy ) 317 END_3D 318 CALL iom_put( "ke", z3d ) ! kinetic energy 319 320 z2d(:,:) = 0._wp 321 DO_3D( 0, 0, 0, 0, 1, jpkm1 ) 322 z2d(ji,jj) = z2d(ji,jj) + e3t(ji,jj,jk,Kmm) * z3d(ji,jj,jk) * e1e2t(ji,jj) * tmask(ji,jj,jk) 323 END_3D 324 CALL iom_put( "ke_int", z2d ) ! vertically integrated kinetic energy 297 325 ENDIF 298 326 ! 299 327 CALL iom_put( "hdiv", hdiv ) ! Horizontal divergence 328 329 IF ( iom_use("relvor") .OR. iom_use("absvor") .OR. iom_use("potvor") ) THEN 330 331 z3d(:,:,jpk) = 0._wp 332 DO_3D( 0, 0, 0, 0, 1, jpkm1 ) 333 z3d(ji,jj,jk) = ( e2v(ji+1,jj ) * vv(ji+1,jj ,jk,Kmm) - e2v(ji,jj) * vv(ji,jj,jk,Kmm) & 334 & - e1u(ji ,jj+1) * uu(ji ,jj+1,jk,Kmm) + e1u(ji,jj) * uu(ji,jj,jk,Kmm) ) * r1_e1e2f(ji,jj) 335 END_3D 336 CALL iom_put( "relvor", z3d ) ! relative vorticity 337 338 DO_3D( 0, 0, 0, 0, 1, jpkm1 ) 339 z3d(ji,jj,jk) = ff_f(ji,jj) + z3d(ji,jj,jk) 340 END_3D 341 CALL iom_put( "absvor", z3d ) ! absolute vorticity 342 343 DO_3D( 0, 0, 0, 0, 1, jpkm1 ) 344 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) & 345 & + e3t(ji,jj ,jk,Kmm)*tmask(ji,jj ,jk) + e3t(ji+1,jj ,jk,Kmm)*tmask(ji+1,jj ,jk) ) 346 IF( ze3 /= 0._wp ) THEN ; ze3 = 4._wp / ze3 347 ELSE ; ze3 = 0._wp 348 ENDIF 349 z3d(ji,jj,jk) = ze3 * z3d(ji,jj,jk) 350 END_3D 351 CALL iom_put( "potvor", z3d ) ! potential vorticity 352 353 ENDIF 300 354 ! 301 355 IF( iom_use("u_masstr") .OR. iom_use("u_masstr_vint") .OR. iom_use("u_heattr") .OR. iom_use("u_salttr") ) THEN … … 315 369 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) ) 316 370 END_3D 317 CALL lbc_lnk( 'diawri', z2d, 'U', -1.0_wp )318 371 CALL iom_put( "u_heattr", 0.5*rcp * z2d ) ! heat transport in i-direction 319 372 ENDIF … … 324 377 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) ) 325 378 END_3D 326 CALL lbc_lnk( 'diawri', z2d, 'U', -1.0_wp )327 379 CALL iom_put( "u_salttr", 0.5 * z2d ) ! heat transport in i-direction 328 380 ENDIF … … 342 394 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) ) 343 395 END_3D 344 CALL lbc_lnk( 'diawri', z2d, 'V', -1.0_wp )345 396 CALL iom_put( "v_heattr", 0.5*rcp * z2d ) ! heat transport in j-direction 346 397 ENDIF … … 351 402 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) ) 352 403 END_3D 353 CALL lbc_lnk( 'diawri', z2d, 'V', -1.0_wp )354 404 CALL iom_put( "v_salttr", 0.5 * z2d ) ! heat transport in j-direction 355 405 ENDIF … … 360 410 z2d(ji,jj) = z2d(ji,jj) + e3t(ji,jj,jk,Kmm) * ts(ji,jj,jk,jp_tem,Kmm) 361 411 END_3D 362 CALL lbc_lnk( 'diawri', z2d, 'T', -1.0_wp )363 412 CALL iom_put( "tosmint", rho0 * z2d ) ! Vertical integral of temperature 364 413 ENDIF … … 368 417 z2d(ji,jj) = z2d(ji,jj) + e3t(ji,jj,jk,Kmm) * ts(ji,jj,jk,jp_sal,Kmm) 369 418 END_3D 370 CALL lbc_lnk( 'diawri', z2d, 'T', -1.0_wp )371 419 CALL iom_put( "somint", rho0 * z2d ) ! Vertical integral of salinity 372 420 ENDIF -
NEMO/branches/2020/dev_r13296_HPC-07_mocavero_mpi3/src/OCE/DIU/diu_bulk.F90
r13295 r13571 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_r13296_HPC-07_mocavero_mpi3/src/OCE/DOM/closea.F90
r13286 r13571 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_r13296_HPC-07_mocavero_mpi3/src/OCE/DOM/daymod.F90
r13286 r13571 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_r13296_HPC-07_mocavero_mpi3/src/OCE/DOM/dom_oce.F90
r13561 r13571 224 224 225 225 !!---------------------------------------------------------------------- 226 !! variable defined here to avoid circular dependencies... 227 !! --------------------------------------------------------------------- 228 INTEGER, PUBLIC :: nbasin ! number of basin to be considered in diaprt (glo, atl, pac, ind, ipc) 229 230 !!---------------------------------------------------------------------- 226 231 !! agrif domain 227 232 !!---------------------------------------------------------------------- -
NEMO/branches/2020/dev_r13296_HPC-07_mocavero_mpi3/src/OCE/DOM/domain.F90
r13286 r13571 120 120 WRITE(numout,*) ' cn_cfg = ', TRIM( cn_cfg ), ' nn_cfg = ', nn_cfg 121 121 ENDIF 122 lwxios = .FALSE.123 ln_xios_read = .FALSE.124 122 ! 125 123 ! !== Reference coordinate system ==! … … 177 175 ! 178 176 IF( ln_linssh ) THEN != Fix in time : set to the reference one for all 179 !177 ! 180 178 DO jt = 1, jpt ! depth of t- and w-grid-points 181 179 gdept(:,:,:,jt) = gdept_0(:,:,:) … … 204 202 ELSE != time varying : initialize before/now/after variables 205 203 ! 206 IF( .NOT.l_offline ) CALL dom_vvl_init( Kbb, Kmm, Kaa )204 IF( .NOT.l_offline ) CALL dom_vvl_init( Kbb, Kmm, Kaa ) 207 205 ! 208 206 ENDIF … … 248 246 !!---------------------------------------------------------------------- 249 247 ! 250 DO ji = 1, jpi ! local domain indices ==> global domain , including halos, indices248 DO ji = 1, jpi ! local domain indices ==> global domain indices, including halos 251 249 mig(ji) = ji + nimpp - 1 252 250 END DO … … 254 252 mjg(jj) = jj + njmpp - 1 255 253 END DO 256 ! ! local domain indices ==> global domain , excluding halos, indices254 ! ! local domain indices ==> global domain indices, excluding halos 257 255 ! 258 256 mig0(:) = mig(:) - nn_hls … … 493 491 !!---------------------------------------------------------------------- 494 492 ! 495 IF(lk_mpp) THEN 496 CALL mpp_minloc( 'domain', glamt(:,:), tmask_i(:,:), zglmin, imil ) 497 CALL mpp_minloc( 'domain', gphit(:,:), tmask_i(:,:), zgpmin, imip ) 498 CALL mpp_minloc( 'domain', e1t(:,:), tmask_i(:,:), ze1min, imi1 ) 499 CALL mpp_minloc( 'domain', e2t(:,:), tmask_i(:,:), ze2min, imi2 ) 500 CALL mpp_maxloc( 'domain', glamt(:,:), tmask_i(:,:), zglmax, imal ) 501 CALL mpp_maxloc( 'domain', gphit(:,:), tmask_i(:,:), zgpmax, imap ) 502 CALL mpp_maxloc( 'domain', e1t(:,:), tmask_i(:,:), ze1max, ima1 ) 503 CALL mpp_maxloc( 'domain', e2t(:,:), tmask_i(:,:), ze2max, ima2 ) 504 ELSE 505 llmsk = tmask_i(:,:) == 1._wp 506 zglmin = MINVAL( glamt(:,:), mask = llmsk ) 507 zgpmin = MINVAL( gphit(:,:), mask = llmsk ) 508 ze1min = MINVAL( e1t(:,:), mask = llmsk ) 509 ze2min = MINVAL( e2t(:,:), mask = llmsk ) 510 zglmin = MAXVAL( glamt(:,:), mask = llmsk ) 511 zgpmin = MAXVAL( gphit(:,:), mask = llmsk ) 512 ze1max = MAXVAL( e1t(:,:), mask = llmsk ) 513 ze2max = MAXVAL( e2t(:,:), mask = llmsk ) 514 ! 515 imil = MINLOC( glamt(:,:), mask = llmsk ) + (/ nimpp - 1, njmpp - 1 /) 516 imip = MINLOC( gphit(:,:), mask = llmsk ) + (/ nimpp - 1, njmpp - 1 /) 517 imi1 = MINLOC( e1t(:,:), mask = llmsk ) + (/ nimpp - 1, njmpp - 1 /) 518 imi2 = MINLOC( e2t(:,:), mask = llmsk ) + (/ nimpp - 1, njmpp - 1 /) 519 imal = MAXLOC( glamt(:,:), mask = llmsk ) + (/ nimpp - 1, njmpp - 1 /) 520 imap = MAXLOC( gphit(:,:), mask = llmsk ) + (/ nimpp - 1, njmpp - 1 /) 521 ima1 = MAXLOC( e1t(:,:), mask = llmsk ) + (/ nimpp - 1, njmpp - 1 /) 522 ima2 = MAXLOC( e2t(:,:), mask = llmsk ) + (/ nimpp - 1, njmpp - 1 /) 523 ENDIF 493 llmsk = tmask_h(:,:) == 1._wp 494 ! 495 CALL mpp_minloc( 'domain', glamt(:,:), llmsk, zglmin, imil ) 496 CALL mpp_minloc( 'domain', gphit(:,:), llmsk, zgpmin, imip ) 497 CALL mpp_minloc( 'domain', e1t(:,:), llmsk, ze1min, imi1 ) 498 CALL mpp_minloc( 'domain', e2t(:,:), llmsk, ze2min, imi2 ) 499 CALL mpp_maxloc( 'domain', glamt(:,:), llmsk, zglmax, imal ) 500 CALL mpp_maxloc( 'domain', gphit(:,:), llmsk, zgpmax, imap ) 501 CALL mpp_maxloc( 'domain', e1t(:,:), llmsk, ze1max, ima1 ) 502 CALL mpp_maxloc( 'domain', e2t(:,:), llmsk, ze2max, ima2 ) 524 503 ! 525 504 IF(lwp) THEN … … 643 622 ! 644 623 ! !== ORCA family specificities ==! 645 IF( cn_cfg== "ORCA" ) THEN624 IF( TRIM(cn_cfg) == "orca" .OR. TRIM(cn_cfg) == "ORCA" ) THEN 646 625 CALL iom_rstput( 0, 0, inum, 'ORCA' , 1._wp , ktype = jp_i4 ) 647 626 CALL iom_rstput( 0, 0, inum, 'ORCA_index', REAL( nn_cfg, wp), ktype = jp_i4 ) -
NEMO/branches/2020/dev_r13296_HPC-07_mocavero_mpi3/src/OCE/DOM/dommsk.F90
r13295 r13571 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 … … 131 130 ! 132 131 tmask(:,:,:) = 0._wp 133 DO_2D( 1, 1, 1, 1)132 DO_2D( nn_hls, nn_hls, nn_hls, nn_hls ) 134 133 iktop = k_top(ji,jj) 135 134 ikbot = k_bot(ji,jj) … … 195 194 IF( rn_shlat /= 0 ) THEN ! Not free-slip lateral boundary condition 196 195 ! 197 ALLOCATE( zwf(jpi,jpj) )198 !199 196 DO jk = 1, jpk 200 zwf(:,:) = fmask(:,:,jk)201 197 DO_2D( 0, 0, 0, 0 ) 202 198 IF( fmask(ji,jj,jk) == 0._wp ) THEN 203 fmask(ji,jj,jk) = rn_shlat * MIN( 1._wp , MAX( zwf(ji+1,jj), zwf(ji,jj+1),&204 & zwf(ji-1,jj), zwf(ji,jj-1) ))199 fmask(ji,jj,jk) = rn_shlat * MIN( 1._wp , MAX( umask(ji,jj,jk), umask(ji,jj+1,jk), & 200 & vmask(ji,jj,jk), vmask(ji+1,jj,jk) ) ) 205 201 ENDIF 206 202 END_2D 207 203 DO jj = 2, jpjm1 208 204 IF( fmask(1,jj,jk) == 0._wp ) THEN 209 fmask(1 ,jj,jk) = rn_shlat * MIN( 1._wp , MAX( zwf(2,jj), zwf(1,jj+1), zwf(1,jj-1) ) )205 fmask(1 ,jj,jk) = rn_shlat * MIN( 1._wp , MAX( vmask(2,jj,jk), umask(1,jj+1,jk), umask(1,jj,jk) ) ) 210 206 ENDIF 211 207 IF( fmask(jpi,jj,jk) == 0._wp ) THEN 212 fmask(jpi,jj,jk) = rn_shlat * MIN( 1._wp , MAX( zwf(jpi,jj+1), zwf(jpim1,jj), zwf(jpi,jj-1) ) )208 fmask(jpi,jj,jk) = rn_shlat * MIN( 1._wp , MAX( umask(jpi,jj+1,jk), vmask(jpim1,jj,jk), umask(jpi,jj-1,jk) ) ) 213 209 ENDIF 214 210 END DO 215 211 DO ji = 2, jpim1 216 212 IF( fmask(ji,1,jk) == 0._wp ) THEN 217 fmask(ji, 1 ,jk) = rn_shlat * MIN( 1._wp , MAX( zwf(ji+1,1), zwf(ji,2), zwf(ji-1,1) ) )213 fmask(ji, 1 ,jk) = rn_shlat * MIN( 1._wp , MAX( vmask(ji+1,1,jk), umask(ji,2,jk), vmask(ji,1,jk) ) ) 218 214 ENDIF 219 215 IF( fmask(ji,jpj,jk) == 0._wp ) THEN 220 fmask(ji,jpj,jk) = rn_shlat * MIN( 1._wp , MAX( zwf(ji+1,jpj), zwf(ji-1,jpj), zwf(ji,jpjm1) ) )216 fmask(ji,jpj,jk) = rn_shlat * MIN( 1._wp , MAX( vmask(ji+1,jpj,jk), vmask(ji-1,jpj,jk), umask(ji,jpjm1,jk) ) ) 221 217 ENDIF 222 218 END DO 223 219 END DO 224 !225 DEALLOCATE( zwf )226 220 ! 227 221 CALL lbc_lnk( 'dommsk', fmask, 'F', 1._wp ) ! Lateral boundary conditions on fmask -
NEMO/branches/2020/dev_r13296_HPC-07_mocavero_mpi3/src/OCE/DOM/domutl.F90
r13286 r13571 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_r13296_HPC-07_mocavero_mpi3/src/OCE/DOM/domvvl.F90
r13295 r13571 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_r13296_HPC-07_mocavero_mpi3/src/OCE/DOM/dtatsd.F90
r13295 r13571 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_r13296_HPC-07_mocavero_mpi3/src/OCE/DYN/divhor.F90
r13295 r13571 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_r13296_HPC-07_mocavero_mpi3/src/OCE/DYN/dynadv_cen2.F90
r13295 r13571 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_r13296_HPC-07_mocavero_mpi3/src/OCE/DYN/dynadv_ubs.F90
r13295 r13571 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_r13296_HPC-07_mocavero_mpi3/src/OCE/DYN/dynatf.F90
r13295 r13571 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_r13296_HPC-07_mocavero_mpi3/src/OCE/DYN/dynkeg.F90
r13295 r13571 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_r13296_HPC-07_mocavero_mpi3/src/OCE/DYN/dynldf_iso.F90
r13295 r13571 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_r13296_HPC-07_mocavero_mpi3/src/OCE/DYN/dynldf_lap_blp.F90
r13295 r13571 84 84 END_2D 85 85 ! 86 DO_2D( 0, 0, 0, 0 ) 86 DO_2D( 0, 0, 0, 0 ) ! - curl( curl) + grad( div ) 87 87 pu_rhs(ji,jj,jk) = pu_rhs(ji,jj,jk) + zsign * umask(ji,jj,jk) * ( & ! * by umask is mandatory for dyn_ldf_blp use 88 88 & - ( zcur(ji ,jj) - zcur(ji,jj-1) ) * r1_e2u(ji,jj) / e3u(ji,jj,jk,Kmm) & -
NEMO/branches/2020/dev_r13296_HPC-07_mocavero_mpi3/src/OCE/DYN/dynspg.F90
r13295 r13571 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_r13296_HPC-07_mocavero_mpi3/src/OCE/DYN/dynspg_exp.F90
r13295 r13571 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_r13296_HPC-07_mocavero_mpi3/src/OCE/DYN/dynspg_ts.F90
r13295 r13571 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) … … 475 475 ! 476 476 ! ! ocean u- and v-depth at mid-step (separate DO-loops remove the need of a lbc_lnk) 477 DO_2D( 1, 1, 1, 0 ) 477 DO_2D( 1, 1, 1, 0 ) ! not jpi-column 478 478 zhup2_e(ji,jj) = hu_0(ji,jj) + r1_2 * r1_e1e2u(ji,jj) & 479 479 & * ( e1e2t(ji ,jj) * zsshp2_e(ji ,jj) & 480 480 & + e1e2t(ji+1,jj) * zsshp2_e(ji+1,jj) ) * ssumask(ji,jj) 481 481 END_2D 482 DO_2D( 1, 0, 1, 1 ) 482 DO_2D( 1, 0, 1, 1 ) ! not jpj-row 483 483 zhvp2_e(ji,jj) = hv_0(ji,jj) + r1_2 * r1_e1e2v(ji,jj) & 484 484 & * ( e1e2t(ji,jj ) * zsshp2_e(ji,jj ) & … … 917 917 CALL iom_get( numror, jpdom_auto, 'ub2_i_b' , ub2_i_b(:,:), cd_type = 'U', psgn = -1._wp, ldxios = lrxios ) 918 918 CALL iom_get( numror, jpdom_auto, 'vb2_i_b' , vb2_i_b(:,:), cd_type = 'V', psgn = -1._wp, ldxios = lrxios ) 919 ELSE 920 ub2_i_b(:,:) = 0._wp ; vb2_i_b(:,:) = 0._wp ! used in the 1st update of agrif 919 921 ENDIF 920 922 #endif … … 922 924 IF(lwp) WRITE(numout,*) 923 925 IF(lwp) WRITE(numout,*) ' ==>>> start from rest: set barotropic values to 0' 924 ub2_b (:,:) = 0._wp ; vb2_b(:,:) = 0._wp ! used in the 1st interpol of agrif925 un_adv (:,:) = 0._wp ; vn_adv(:,:) = 0._wp ! used in the 1st interpol of agrif926 un_bf (:,:) = 0._wp ; vn_bf(:,:) = 0._wp ! used in the 1st update of agrif926 ub2_b (:,:) = 0._wp ; vb2_b (:,:) = 0._wp ! used in the 1st interpol of agrif 927 un_adv (:,:) = 0._wp ; vn_adv (:,:) = 0._wp ! used in the 1st interpol of agrif 928 un_bf (:,:) = 0._wp ; vn_bf (:,:) = 0._wp ! used in the 1st update of agrif 927 929 #if defined key_agrif 928 IF ( .NOT.Agrif_Root() ) THEN 929 ub2_i_b(:,:) = 0._wp ; vb2_i_b(:,:) = 0._wp ! used in the 1st update of agrif 930 ENDIF 930 ub2_i_b(:,:) = 0._wp ; vb2_i_b(:,:) = 0._wp ! used in the 1st update of agrif 931 931 #endif 932 932 ENDIF … … 1308 1308 !!---------------------------------------------------------------------- 1309 1309 ! 1310 DO_2D( 1, 1, 1, 0 ) 1310 DO_2D( 1, 1, 1, 0 ) ! not jpi-column 1311 1311 IF ( phU(ji,jj) > 0._wp ) THEN ; pUmsk(ji,jj) = pTmsk(ji ,jj) 1312 1312 ELSE ; pUmsk(ji,jj) = pTmsk(ji+1,jj) … … 1316 1316 END_2D 1317 1317 ! 1318 DO_2D( 1, 0, 1, 1 ) 1318 DO_2D( 1, 0, 1, 1 ) ! not jpj-row 1319 1319 IF ( phV(ji,jj) > 0._wp ) THEN ; pVmsk(ji,jj) = pTmsk(ji,jj ) 1320 1320 ELSE ; pVmsk(ji,jj) = pTmsk(ji,jj+1) … … 1405 1405 ! !== Set the barotropic drag coef. ==! 1406 1406 ! 1407 IF( ln_isfcav ) THEN ! top+bottom friction (ocean cavities)1407 IF( ln_isfcav.OR.ln_drgice_imp ) THEN ! top+bottom friction (ocean cavities) 1408 1408 1409 1409 DO_2D( 0, 0, 0, 0 ) … … 1456 1456 ! !== TOP stress contribution from baroclinic velocities ==! (no W/D case) 1457 1457 ! 1458 IF( ln_isfcav ) THEN1458 IF( ln_isfcav.OR.ln_drgice_imp ) THEN 1459 1459 ! 1460 1460 IF( ln_bt_fw ) THEN ! FORWARD integration: use NOW top baroclinic velocity -
NEMO/branches/2020/dev_r13296_HPC-07_mocavero_mpi3/src/OCE/DYN/dynvor.F90
r13295 r13571 217 217 INTEGER :: ji, jj, jk ! dummy loop indices 218 218 REAL(wp) :: zx1, zy1, zx2, zy2 ! local scalars 219 REAL(wp), DIMENSION(jpi,jpj) :: zwx, zwy, zwt ! 2D workspace220 REAL(wp), DIMENSION(jpi,jpj,jpk ) :: zwz ! 3D workspace219 REAL(wp), DIMENSION(jpi,jpj) :: zwx, zwy, zwt ! 2D workspace 220 REAL(wp), DIMENSION(jpi,jpj,jpkm1) :: zwz ! 3D workspace, jpkm1 -> avoid lbc_lnk on jpk that is not defined 221 221 !!---------------------------------------------------------------------- 222 222 ! … … 246 246 CASE ( np_CRV ) !* Coriolis + relative vorticity 247 247 DO jk = 1, jpkm1 ! Horizontal slab 248 DO_2D( 1, 0, 1, 0 ) 248 DO_2D( 1, 0, 1, 0 ) ! relative vorticity 249 249 zwz(ji,jj,jk) = ( e2v(ji+1,jj) * pv(ji+1,jj,jk) - e2v(ji,jj) * pv(ji,jj,jk) & 250 250 & - e1u(ji,jj+1) * pu(ji,jj+1,jk) + e1u(ji,jj) * pu(ji,jj,jk) ) * r1_e1e2f(ji,jj) … … 533 533 REAL(wp) :: zua, zva ! local scalars 534 534 REAL(wp) :: zmsk, ze3f ! local scalars 535 REAL(wp), DIMENSION(jpi,jpj) :: zwx , zwy , z1_e3f536 REAL(wp), DIMENSION(jpi,jpj) :: ztnw, ztne, ztsw, ztse537 REAL(wp), DIMENSION(jpi,jpj,jpk ) :: zwz535 REAL(wp), DIMENSION(jpi,jpj) :: zwx , zwy , z1_e3f 536 REAL(wp), DIMENSION(jpi,jpj) :: ztnw, ztne, ztsw, ztse 537 REAL(wp), DIMENSION(jpi,jpj,jpkm1) :: zwz ! 3D workspace, jpkm1 -> jpkm1 -> avoid lbc_lnk on jpk that is not defined 538 538 !!---------------------------------------------------------------------- 539 539 ! … … 677 677 REAL(wp) :: zua, zva ! local scalars 678 678 REAL(wp) :: zmsk, z1_e3t ! local scalars 679 REAL(wp), DIMENSION(jpi,jpj) :: zwx , zwy680 REAL(wp), DIMENSION(jpi,jpj) :: ztnw, ztne, ztsw, ztse681 REAL(wp), DIMENSION(jpi,jpj,jpk ) :: zwz679 REAL(wp), DIMENSION(jpi,jpj) :: zwx , zwy 680 REAL(wp), DIMENSION(jpi,jpj) :: ztnw, ztne, ztsw, ztse 681 REAL(wp), DIMENSION(jpi,jpj,jpkm1) :: zwz ! 3D workspace, avoid lbc_lnk on jpk that is not defined 682 682 !!---------------------------------------------------------------------- 683 683 ! -
NEMO/branches/2020/dev_r13296_HPC-07_mocavero_mpi3/src/OCE/DYN/dynzad.F90
r13295 r13571 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_r13296_HPC-07_mocavero_mpi3/src/OCE/DYN/dynzdf.F90
r13295 r13571 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_r13296_HPC-07_mocavero_mpi3/src/OCE/DYN/sshwzv.F90
r13295 r13571 203 203 ELSE !== Quasi-Eulerian vertical coordinate ==! ('key_qco') 204 204 ! !==========================================! 205 DO jk = jpkm1, 1, -1 ! integrate from the bottom the hor. divergence205 DO jk = jpkm1, 1, -1 ! integrate from the bottom the hor. divergence 206 206 pww(:,:,jk) = pww(:,:,jk+1) - ( e3t(:,:,jk,Kmm) * hdiv(:,:,jk) & 207 207 & + r1_Dt * ( e3t(:,:,jk,Kaa) & … … 393 393 ! 394 394 IF( MAXVAL( Cu_adv(:,:,:) ) > Cu_min ) THEN ! Quick check if any breaches anywhere 395 DO_3DS( 1, 1, 1, 1, jpkm1, 2, -1 ) 395 DO_3DS( 1, 1, 1, 1, jpkm1, 2, -1 ) ! or scan Courant criterion and partition ! w where necessary 396 396 ! 397 397 zCu = MAX( Cu_adv(ji,jj,jk) , Cu_adv(ji,jj,jk-1) ) -
NEMO/branches/2020/dev_r13296_HPC-07_mocavero_mpi3/src/OCE/DYN/wet_dry.F90
r13295 r13571 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_r13296_HPC-07_mocavero_mpi3/src/OCE/FLO/flo_oce.F90
r11536 r13571 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_r13296_HPC-07_mocavero_mpi3/src/OCE/ICB/icbtrj.F90
r13062 r13571 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_r13296_HPC-07_mocavero_mpi3/src/OCE/IOM/iom.F90
r13295 r13571 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 ! … … 230 231 CALL iom_set_axis_attr( "ghw_abl", bounds=za_bnds ) 231 232 232 CALL iom_set_axis_attr( "nfloat", (/ (REAL(ji,wp), ji=1,jpnfl) /) )233 CALL iom_set_axis_attr( "nfloat", (/ (REAL(ji,wp), ji=1,jpnfl) /) ) 233 234 # if defined key_si3 234 235 CALL iom_set_axis_attr( "ncatice", (/ (REAL(ji,wp), ji=1,jpl) /) ) … … 243 244 CALL iom_set_axis_attr( "iax_26C", (/ REAL(26,wp) /) ) ! strange syntaxe and idea... 244 245 CALL iom_set_axis_attr( "iax_28C", (/ REAL(28,wp) /) ) ! strange syntaxe and idea... 245 CALL iom_set_axis_attr( "basin" , (/ (REAL(ji,wp), ji=1,5) /) ) 246 ! for diaprt, we need to define an axis which size can be 1 (default) or 5 (if the file subbasins.nc exists) 247 INQUIRE( FILE = 'subbasins.nc', EXIST = ll_exist ) 248 nbasin = 1 + 4 * COUNT( (/ll_exist/) ) 249 CALL iom_set_axis_attr( "basin" , (/ (REAL(ji,wp), ji=1,nbasin) /) ) 246 250 ENDIF 247 251 ! … … 350 354 rst_file = TRIM(clpath)//TRIM(cn_ocerst_in) 351 355 ELSE 352 rst_file = TRIM(clpath)// '1_'//TRIM(cn_ocerst_in)356 rst_file = TRIM(clpath)//TRIM(Agrif_CFixed())//'_'//TRIM(cn_ocerst_in) 353 357 ENDIF 354 358 !set name of the restart file and enable available fields -
NEMO/branches/2020/dev_r13296_HPC-07_mocavero_mpi3/src/OCE/IOM/iom_def.F90
r13286 r13571 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_r13296_HPC-07_mocavero_mpi3/src/OCE/ISF/isf_oce.F90
r12077 r13571 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_r13296_HPC-07_mocavero_mpi3/src/OCE/ISF/isfcavmlt.F90
r13295 r13571 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_r13296_HPC-07_mocavero_mpi3/src/OCE/LBC/lbc_lnk_multi_generic.h90
r13286 r13571 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_r13296_HPC-07_mocavero_mpi3/src/OCE/LBC/lib_mpp.F90
r13561 r13571 74 74 PUBLIC tic_tac 75 75 #if ! defined key_mpp_mpi 76 PUBLIC MPI_wait 76 77 PUBLIC MPI_Wtime 77 78 #endif … … 116 117 #else 117 118 INTEGER, PUBLIC, PARAMETER :: MPI_STATUS_SIZE = 1 119 INTEGER, PUBLIC, PARAMETER :: MPI_REAL = 4 118 120 INTEGER, PUBLIC, PARAMETER :: MPI_DOUBLE_PRECISION = 8 119 121 LOGICAL, PUBLIC, PARAMETER :: lk_mpp = .FALSE. !: mpp flag -
NEMO/branches/2020/dev_r13296_HPC-07_mocavero_mpi3/src/OCE/LBC/mpp_lbc_north_icb_generic.h90
r13286 r13571 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_r13296_HPC-07_mocavero_mpi3/src/OCE/LBC/mpp_loc_generic.h90
r13286 r13571 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_r13296_HPC-07_mocavero_mpi3/src/OCE/LBC/mpp_nfd_generic.h90
r13290 r13571 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_r13296_HPC-07_mocavero_mpi3/src/OCE/LBC/mppini.F90
r13561 r13571 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 … … 646 641 WRITE(inum,'(6i8,a,3i8,a)') jpnij,jpimax,jpjmax,jpk,jpiglo,jpjglo,& 647 642 & ' ( local: ',narea,jpi,jpj,' )' 648 WRITE(inum,'(a)') 'nproc jpijpj Nis0 Njs0 Nie0 Nje0 nimp njmp nono noso nowe noea nbondi nbondj '643 WRITE(inum,'(a)') 'nproc jpi jpj Nis0 Njs0 Nie0 Nje0 nimp njmp nono noso nowe noea nbondi nbondj ' 649 644 650 645 DO jproc = 1, jpnij … … 733 728 END SUBROUTINE mpp_init 734 729 730 #endif 735 731 736 732 SUBROUTINE mpp_basesplit( kiglo, kjglo, khls, knbi, knbj, kimax, kjmax, kimppt, kjmppt, klci, klcj) … … 847 843 !! ** Method : 848 844 !!---------------------------------------------------------------------- 849 INTEGER, INTENT(in ) :: knbij ! total number if subdomains(knbi*knbj)845 INTEGER, INTENT(in ) :: knbij ! total number of subdomains (knbi*knbj) 850 846 INTEGER, OPTIONAL, INTENT( out) :: knbi, knbj ! number if subdomains along i and j (knbi and knbj) 851 847 INTEGER, OPTIONAL, INTENT( out) :: knbcnt ! number of land subdomains … … 855 851 INTEGER :: iszitst, iszjtst 856 852 INTEGER :: isziref, iszjref 853 INTEGER :: iszimin, iszjmin 857 854 INTEGER :: inbij, iszij 858 855 INTEGER :: inbimax, inbjmax, inbijmax, inbijold … … 883 880 inbimax = 0 884 881 inbjmax = 0 885 isziref = Ni0glo*Nj0glo+1 886 iszjref = Ni0glo*Nj0glo+1 882 isziref = jpiglo*jpjglo+1 ! define a value that is larger than the largest possible 883 iszjref = jpiglo*jpjglo+1 884 ! 885 iszimin = 4*nn_hls ! minimum size of the MPI subdomain so halos are always adressing neighbor inner domain 886 iszjmin = 4*nn_hls 887 IF( jperio == 3 .OR. jperio == 4 ) iszjmin = MAX(iszjmin, 2+3*nn_hls) ! V and F folding must be outside of southern halos 888 IF( jperio == 5 .OR. jperio == 6 ) iszjmin = MAX(iszjmin, 1+3*nn_hls) ! V and F folding must be outside of southern halos 887 889 ! 888 890 ! get the list of knbi that gives a smaller jpimax than knbi-1 … … 892 894 iszitst = ( nx_global+2-2*nn_hls + (ji-1) ) / ji + 2*nn_hls ! first dim. 893 895 #else 894 iszitst = ( Ni0glo + (ji-1) ) / ji 896 iszitst = ( Ni0glo + (ji-1) ) / ji + 2*nn_hls ! max subdomain i-size 895 897 #endif 896 IF( iszitst < isziref ) THEN898 IF( iszitst < isziref .AND. iszitst >= iszimin ) THEN 897 899 isziref = iszitst 898 900 inbimax = inbimax + 1 … … 903 905 iszjtst = ( ny_global+2-2*nn_hls + (ji-1) ) / ji + 2*nn_hls ! first dim. 904 906 #else 905 iszjtst = ( Nj0glo + (ji-1) ) / ji 907 iszjtst = ( Nj0glo + (ji-1) ) / ji + 2*nn_hls ! max subdomain j-size 906 908 #endif 907 IF( iszjtst < iszjref ) THEN909 IF( iszjtst < iszjref .AND. iszjtst >= iszjmin ) THEN 908 910 iszjref = iszjtst 909 911 inbjmax = inbjmax + 1 … … 958 960 isz0 = 0 ! number of best partitions 959 961 inbij = 1 ! start with the min value of inbij1 => 1 960 iszij = Ni0glo*Nj0glo+1 ! default: larger than global domain962 iszij = jpiglo*jpjglo+1 ! default: larger than global domain 961 963 DO WHILE( inbij <= inbijmax ) ! if we did not reach the max of inbij1 962 964 ii = MINLOC(iszij1, mask = inbij1 == inbij, dim = 1) ! warning: send back the first occurence if multiple results 963 965 IF ( iszij1(ii) < iszij ) THEN 966 ii = MINLOC( iszi1+iszj1, mask = iszij1 == iszij1(ii) .AND. inbij1 == inbij, dim = 1) ! select the smaller perimeter if multiple min 964 967 isz0 = isz0 + 1 965 968 indexok(isz0) = ii … … 1379 1382 END SUBROUTINE init_nfdcom 1380 1383 1381 #endif1382 1384 1383 1385 SUBROUTINE init_doloop -
NEMO/branches/2020/dev_r13296_HPC-07_mocavero_mpi3/src/OCE/LDF/ldfc1d_c2d.F90
r13295 r13571 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_r13296_HPC-07_mocavero_mpi3/src/OCE/LDF/ldfdyn.F90
r13295 r13571 311 311 IF( ierr /= 0 ) CALL ctl_stop( 'STOP', 'ldf_dyn_init: failed to allocate Smagorinsky arrays') 312 312 ! 313 DO_2D( 1, 1, 1, 1 ) 313 DO_2D( 1, 1, 1, 1 ) ! Set local gridscale values 314 314 esqt(ji,jj) = ( 2._wp * e1e2t(ji,jj) / ( e1t(ji,jj) + e2t(ji,jj) ) )**2 315 315 esqf(ji,jj) = ( 2._wp * e1e2f(ji,jj) / ( e1f(ji,jj) + e2f(ji,jj) ) )**2 … … 434 434 DO jk = 1, jpkm1 435 435 ! 436 DO_2D( 0, 0, 0, 0 ) 436 DO_2D( 0, 0, 0, 0 ) ! T-point value 437 437 ! 438 438 zu2pv2_ij = uu(ji ,jj ,jk,Kbb) * uu(ji ,jj ,jk,Kbb) + vv(ji ,jj ,jk,Kbb) * vv(ji ,jj ,jk,Kbb) … … 448 448 END_2D 449 449 ! 450 DO_2D( 1, 0, 1, 0 ) 450 DO_2D( 1, 0, 1, 0 ) ! F-point value 451 451 ! 452 452 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_r13296_HPC-07_mocavero_mpi3/src/OCE/LDF/ldfslp.F90
r13295 r13571 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_r13296_HPC-07_mocavero_mpi3/src/OCE/LDF/ldftra.F90
r13295 r13571 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_r13296_HPC-07_mocavero_mpi3/src/OCE/SBC/cpl_oasis3.F90
r13286 r13571 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_r13296_HPC-07_mocavero_mpi3/src/OCE/SBC/fldread.F90
r13295 r13571 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_r13296_HPC-07_mocavero_mpi3/src/OCE/SBC/sbc_ice.F90
r12396 r13571 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_r13296_HPC-07_mocavero_mpi3/src/OCE/SBC/sbc_oce.F90
r13295 r13571 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_r13296_HPC-07_mocavero_mpi3/src/OCE/SBC/sbcblk.F90
r13295 r13571 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 ! … … 568 578 zwnd_j(:,:) = 0._wp 569 579 CALL wnd_cyc( kt, zwnd_i, zwnd_j ) ! add analytical tropical cyclone (Vincent et al. JGR 2012) 570 DO_2D( 1, 1, 1, 1)580 DO_2D( nn_hls, nn_hls, nn_hls, nn_hls ) 571 581 zwnd_i(ji,jj) = pwndi(ji,jj) + zwnd_i(ji,jj) 572 582 zwnd_j(ji,jj) = pwndj(ji,jj) + zwnd_j(ji,jj) … … 576 586 #else 577 587 ! ... scalar wind module at T-point (not masked) 578 DO_2D( 1, 1, 1, 1)588 DO_2D( nn_hls, nn_hls, nn_hls, nn_hls ) 579 589 wndm(ji,jj) = SQRT( pwndi(ji,jj) * pwndi(ji,jj) + pwndj(ji,jj) * pwndj(ji,jj) ) 580 590 END_2D … … 628 638 ! use scalar version of gamma_moist() ... 629 639 IF( ln_tpot ) THEN 630 DO_2D( 1, 1, 1, 1)640 DO_2D( nn_hls, nn_hls, nn_hls, nn_hls ) 631 641 ztpot(ji,jj) = ptair(ji,jj) + gamma_moist( ptair(ji,jj), zqair(ji,jj) ) * rn_zqt 632 642 END_2D … … 690 700 691 701 IF( ln_abl ) THEN !== ABL formulation ==! multiplication by rho_air and turbulent fluxes computation done in ablstp 692 DO_2D( 1, 1, 1, 1)702 DO_2D( nn_hls, nn_hls, nn_hls, nn_hls ) 693 703 zztmp = zU_zu(ji,jj) 694 704 wndm(ji,jj) = zztmp ! Store zU_zu in wndm to compute ustar2 in ablmod … … 710 720 pevp(:,:) = pevp(:,:) * tmask(:,:,1) 711 721 712 DO_2D( 1, 1, 1, 1)722 DO_2D( nn_hls, nn_hls, nn_hls, nn_hls ) 713 723 IF( wndm(ji,jj) > 0._wp ) THEN 714 724 zztmp = taum(ji,jj) / wndm(ji,jj) … … 828 838 829 839 ! use scalar version of L_vap() for AGRIF compatibility 830 DO_2D( 1, 1, 1, 1)840 DO_2D( nn_hls, nn_hls, nn_hls, nn_hls ) 831 841 zqla(ji,jj) = - L_vap( ztskk(ji,jj) ) * pevp(ji,jj) ! Latent Heat flux !!GS: possibility to add a global qla to avoid recomputation after abl update 832 842 END_2D … … 933 943 ! ------------------------------------------------------------ ! 934 944 ! C-grid ice dynamics : U & V-points (same as ocean) 935 DO_2D( 1, 1, 1, 1)945 DO_2D( nn_hls, nn_hls, nn_hls, nn_hls ) 936 946 wndm_ice(ji,jj) = SQRT( pwndi(ji,jj) * pwndi(ji,jj) + pwndj(ji,jj) * pwndj(ji,jj) ) 937 947 END_2D … … 978 988 zztmp1 = 11637800.0_wp 979 989 zztmp2 = -5897.8_wp 980 DO_2D( 1, 1, 1, 1)990 DO_2D( nn_hls, nn_hls, nn_hls, nn_hls ) 981 991 pcd_dui(ji,jj) = zcd_dui (ji,jj) 982 992 pseni (ji,jj) = wndm_ice(ji,jj) * Ch_ice(ji,jj) … … 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(:,:) ) … … 1233 1253 ! 1234 1254 DO jl = 1, jpl 1235 DO_2D( 1, 1, 1, 1)1255 DO_2D( nn_hls, nn_hls, nn_hls, nn_hls ) 1236 1256 zhe = ( rn_cnd_s * phi(ji,jj,jl) + rcnd_i * phs(ji,jj,jl) ) * zfac ! Effective thickness 1237 1257 IF( zhe >= zfac2 ) zgfac(ji,jj,jl) = MIN( 2._wp, 0.5_wp * ( 1._wp + LOG( zhe * zfac3 ) ) ) ! Enhanced conduction factor … … 1248 1268 ! 1249 1269 DO jl = 1, jpl 1250 DO_2D( 1, 1, 1, 1)1270 DO_2D( nn_hls, nn_hls, nn_hls, nn_hls ) 1251 1271 ! 1252 1272 zkeff_h = zfac * zgfac(ji,jj,jl) / & ! Effective conductivity of the snow-ice system divided by thickness -
NEMO/branches/2020/dev_r13296_HPC-07_mocavero_mpi3/src/OCE/SBC/sbcblk_algo_coare3p0.F90
r13295 r13571 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_r13296_HPC-07_mocavero_mpi3/src/OCE/SBC/sbcblk_algo_coare3p6.F90
r13295 r13571 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_r13296_HPC-07_mocavero_mpi3/src/OCE/SBC/sbcblk_algo_ecmwf.F90
r13295 r13571 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_r13296_HPC-07_mocavero_mpi3/src/OCE/SBC/sbcblk_algo_ncar.F90
r13295 r13571 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_r13296_HPC-07_mocavero_mpi3/src/OCE/SBC/sbcblk_phy.F90
r13295 r13571 181 181 !!---------------------------------------------------------------------------------- 182 182 ! 183 DO_2D( 1, 1, 1, 1)183 DO_2D( nn_hls, nn_hls, nn_hls, nn_hls ) 184 184 ztc = ptak(ji,jj) - rt0 ! air temp, in deg. C 185 185 ztc2 = ztc*ztc … … 270 270 INTEGER :: ji, jj ! dummy loop indices 271 271 !!---------------------------------------------------------------------------------- 272 DO_2D( 1, 1, 1, 1)272 DO_2D( nn_hls, nn_hls, nn_hls, nn_hls ) 273 273 gamma_moist_vctr(ji,jj) = gamma_moist_sclr( ptak(ji,jj), pqa(ji,jj) ) 274 274 END_2D … … 315 315 !!------------------------------------------------------------------- 316 316 ! 317 DO_2D( 1, 1, 1, 1)317 DO_2D( nn_hls, nn_hls, nn_hls, nn_hls ) 318 318 ! 319 319 zqa = (1._wp + rctv0*pqa(ji,jj)) … … 351 351 !!------------------------------------------------------------------- 352 352 ! 353 DO_2D( 1, 1, 1, 1)353 DO_2D( nn_hls, nn_hls, nn_hls, nn_hls ) 354 354 ! 355 355 zqa = 0.5_wp*(pqa(ji,jj)+pssq(ji,jj)) ! ~ mean q within the layer... … … 448 448 !!---------------------------------------------------------------------------------- 449 449 ! 450 DO_2D( 1, 1, 1, 1)450 DO_2D( nn_hls, nn_hls, nn_hls, nn_hls ) 451 451 ! 452 452 ze_sat = e_sat_sclr( ptak(ji,jj) ) … … 473 473 !!---------------------------------------------------------------------------------- 474 474 ! 475 DO_2D( 1, 1, 1, 1)475 DO_2D( nn_hls, nn_hls, nn_hls, nn_hls ) 476 476 ze = prha(ji,jj)*e_sat_sclr(ptak(ji,jj)) 477 477 q_air_rh(ji,jj) = ze*reps0/(pslp(ji,jj) - (1. - reps0)*ze) … … 511 511 INTEGER :: ji, jj ! dummy loop indices 512 512 !!---------------------------------------------------------------------------------- 513 DO_2D( 1, 1, 1, 1)513 DO_2D( nn_hls, nn_hls, nn_hls, nn_hls ) 514 514 515 515 zdt = pTa(ji,jj) - pTs(ji,jj) ; zdt = SIGN( MAX(ABS(zdt),1.E-6_wp), zdt ) … … 621 621 IF( PRESENT(pfact_evap) ) zfact_evap = pfact_evap 622 622 623 DO_2D( 1, 1, 1, 1)623 DO_2D( nn_hls, nn_hls, nn_hls, nn_hls ) 624 624 625 625 CALL BULK_FORMULA_SCLR( pzu, pTs(ji,jj), pqs(ji,jj), pTa(ji,jj), pqa(ji,jj), & -
NEMO/branches/2020/dev_r13296_HPC-07_mocavero_mpi3/src/OCE/SBC/sbcblk_skin_coare.F90
r13295 r13571 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_r13296_HPC-07_mocavero_mpi3/src/OCE/SBC/sbcblk_skin_ecmwf.F90
r13295 r13571 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_r13296_HPC-07_mocavero_mpi3/src/OCE/SBC/sbccpl.F90
r13295 r13571 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_r13296_HPC-07_mocavero_mpi3/src/OCE/SBC/sbcdcy.F90
r13295 r13571 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_r13296_HPC-07_mocavero_mpi3/src/OCE/SBC/sbcflx.F90
r13295 r13571 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_r13296_HPC-07_mocavero_mpi3/src/OCE/SBC/sbcmod.F90
r13286 r13571 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 ! … … 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 ! … … 563 566 ENDIF 564 567 ! 565 CALL iom_put( "utau", utau ) ! i-wind stress (stress can be updated at each time step in sea-ice)566 CALL iom_put( "vtau", vtau ) ! j-wind stress567 !568 568 IF(sn_cfctl%l_prtctl) THEN ! print mean trends (used for debugging) 569 569 CALL prt_ctl(tab2d_1=fr_i , clinfo1=' fr_i - : ', mask1=tmask ) -
NEMO/branches/2020/dev_r13296_HPC-07_mocavero_mpi3/src/OCE/SBC/sbcrnf.F90
r13295 r13571 215 215 END_2D 216 216 ELSE !* variable volume case 217 DO_2D( 1, 1, 1, 1 ) 217 DO_2D( 1, 1, 1, 1 ) ! update the depth over which runoffs are distributed 218 218 h_rnf(ji,jj) = 0._wp 219 DO jk = 1, nk_rnf(ji,jj) ! recalculates h_rnf to be the depth in metres219 DO jk = 1, nk_rnf(ji,jj) ! recalculates h_rnf to be the depth in metres 220 220 h_rnf(ji,jj) = h_rnf(ji,jj) + e3t(ji,jj,jk,Kmm) ! to the bottom of the relevant grid box 221 221 END DO … … 374 374 ENDIF 375 375 END_2D 376 DO_2D( 1, 1, 1, 1 ) 376 DO_2D( 1, 1, 1, 1 ) ! set the associated depth 377 377 h_rnf(ji,jj) = 0._wp 378 378 DO jk = 1, nk_rnf(ji,jj) … … 404 404 WHERE( zrnfcl(:,:,1) > 0._wp ) h_rnf(:,:) = zacoef * zrnfcl(:,:,1) ! compute depth for all runoffs 405 405 ! 406 DO_2D( 1, 1, 1, 1 ) 406 DO_2D( 1, 1, 1, 1 ) ! take in account min depth of ocean rn_hmin 407 407 IF( zrnfcl(ji,jj,1) > 0._wp ) THEN 408 408 jk = mbkt(ji,jj) … … 423 423 END_2D 424 424 ! 425 DO_2D( 1, 1, 1, 1 ) 425 DO_2D( 1, 1, 1, 1 ) ! set the associated depth 426 426 h_rnf(ji,jj) = 0._wp 427 427 DO jk = 1, nk_rnf(ji,jj) -
NEMO/branches/2020/dev_r13296_HPC-07_mocavero_mpi3/src/OCE/SBC/sbcwave.F90
r13295 r13571 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_r13296_HPC-07_mocavero_mpi3/src/OCE/TRA/eosbn2.F90
r13295 r13571 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_r13296_HPC-07_mocavero_mpi3/src/OCE/TRA/traadv_cen.F90
r13295 r13571 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_r13296_HPC-07_mocavero_mpi3/src/OCE/TRA/traadv_fct.F90
r13570 r13571 161 161 zwy(ji,jj,jk) = 0.5 * ( zfp_vj * pt(ji,jj,jk,jn,Kbb) + zfm_vj * pt(ji ,jj+1,jk,jn,Kbb) ) 162 162 END_3D 163 ! !* upstream tracer flux in the k direction *!164 DO_3D( 1, 1, 1, 1, 2, jpkm1 ) 163 ! !* upstream tracer flux in the k direction *! 164 DO_3D( 1, 1, 1, 1, 2, jpkm1 ) ! Interior value ( multiplied by wmask) 165 165 zfp_wk = pW(ji,jj,jk) + ABS( pW(ji,jj,jk) ) 166 166 zfm_wk = pW(ji,jj,jk) - ABS( pW(ji,jj,jk) ) 167 167 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) 168 168 END_3D 169 IF( ln_linssh ) THEN ! top ocean value (only in linear free surface as zwz has been w-masked)170 IF( ln_isfcav ) THEN ! top of the ice-shelf cavities and at the ocean surface169 IF( ln_linssh ) THEN ! top ocean value (only in linear free surface as zwz has been w-masked) 170 IF( ln_isfcav ) THEN ! top of the ice-shelf cavities and at the ocean surface 171 171 DO_2D( 1, 1, 1, 1 ) 172 172 zwz(ji,jj, mikt(ji,jj) ) = pW(ji,jj,mikt(ji,jj)) * pt(ji,jj,mikt(ji,jj),jn,Kbb) ! linear free surface 173 173 END_2D 174 ELSE ! no cavities: only at the ocean surface174 ELSE ! no cavities: only at the ocean surface 175 175 DO_2D( 1, 1, 1, 1 ) 176 176 zwz(ji,jj,1) = pW(ji,jj,1) * pt(ji,jj,1,jn,Kbb) … … 179 179 ENDIF 180 180 ! 181 DO_3D( 0, 0, 0, 0, 1, jpkm1 ) 182 ! ! total intermediate advective trends181 DO_3D( 0, 0, 0, 0, 1, jpkm1 ) !* trend and after field with monotonic scheme 182 ! ! total intermediate advective trends 183 183 ztra = - ( zwx(ji,jj,jk) - zwx(ji-1,jj ,jk ) & 184 184 & + zwy(ji,jj,jk) - zwy(ji ,jj-1,jk ) & 185 185 & + zwz(ji,jj,jk) - zwz(ji ,jj ,jk+1) ) * r1_e1e2t(ji,jj) 186 ! ! update and guess with monotonic sheme186 ! ! update and guess with monotonic sheme 187 187 pt(ji,jj,jk,jn,Krhs) = pt(ji,jj,jk,jn,Krhs) + ztra & 188 188 & / e3t(ji,jj,jk,Kmm ) * tmask(ji,jj,jk) … … 195 195 ! 196 196 ztw(:,:,1) = 0._wp ; ztw(:,:,jpk) = 0._wp ; 197 DO_3D( 0, 0, 0, 0, 2, jpkm1 ) 197 DO_3D( 0, 0, 0, 0, 2, jpkm1 ) ! Interior value ( multiplied by wmask) 198 198 zfp_wk = wi(ji,jj,jk) + ABS( wi(ji,jj,jk) ) 199 199 zfm_wk = wi(ji,jj,jk) - ABS( wi(ji,jj,jk) ) … … 228 228 zltv(:,:,jpk) = 0._wp 229 229 DO jk = 1, jpkm1 ! Laplacian 230 DO_2D( 1, 0, 1, 0 ) 230 DO_2D( 1, 0, 1, 0 ) ! 1st derivative (gradient) 231 231 ztu(ji,jj,jk) = ( pt(ji+1,jj ,jk,jn,Kmm) - pt(ji,jj,jk,jn,Kmm) ) * umask(ji,jj,jk) 232 232 ztv(ji,jj,jk) = ( pt(ji ,jj+1,jk,jn,Kmm) - pt(ji,jj,jk,jn,Kmm) ) * vmask(ji,jj,jk) 233 233 END_2D 234 DO_2D( 0, 0, 0, 0 ) 234 DO_2D( 0, 0, 0, 0 ) ! 2nd derivative * 1/ 6 235 235 zltu(ji,jj,jk) = ( ztu(ji,jj,jk) + ztu(ji-1,jj,jk) ) * r1_6 236 236 zltv(ji,jj,jk) = ( ztv(ji,jj,jk) + ztv(ji,jj-1,jk) ) * r1_6 … … 243 243 #endif 244 244 ! 245 DO_3D( 1, 0, 1, 0, 1, jpkm1 ) 245 DO_3D( 1, 0, 1, 0, 1, jpkm1 ) ! Horizontal advective fluxes 246 246 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 247 247 zC2t_v = pt(ji,jj,jk,jn,Kmm) + pt(ji ,jj+1,jk,jn,Kmm) 248 ! ! C4 minus upstream advective fluxes248 ! ! C4 minus upstream advective fluxes 249 249 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) 250 250 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) … … 254 254 ztu(:,:,jpk) = 0._wp ! Bottom value : flux set to zero 255 255 ztv(:,:,jpk) = 0._wp 256 DO_3D( 1, 0, 1, 0, 1, jpkm1 ) 256 DO_3D( 1, 0, 1, 0, 1, jpkm1 ) ! 1st derivative (gradient) 257 257 ztu(ji,jj,jk) = ( pt(ji+1,jj ,jk,jn,Kmm) - pt(ji,jj,jk,jn,Kmm) ) * umask(ji,jj,jk) 258 258 ztv(ji,jj,jk) = ( pt(ji ,jj+1,jk,jn,Kmm) - pt(ji,jj,jk,jn,Kmm) ) * vmask(ji,jj,jk) … … 264 264 #endif 265 265 ! 266 DO_3D( 0, 0, 0, 0, 1, jpkm1 ) 266 DO_3D( 0, 0, 0, 0, 1, jpkm1 ) ! Horizontal advective fluxes 267 267 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) 268 268 zC2t_v = pt(ji,jj,jk,jn,Kmm) + pt(ji ,jj+1,jk,jn,Kmm) … … 297 297 ! 298 298 IF ( ll_zAimp ) THEN 299 DO_3D( 0, 0, 0, 0, 1, jpkm1 ) 300 ! ! total intermediate advective trends299 DO_3D( 0, 0, 0, 0, 1, jpkm1 ) !* trend and after field with monotonic scheme 300 ! ! total intermediate advective trends 301 301 ztra = - ( zwx(ji,jj,jk) - zwx(ji-1,jj ,jk ) & 302 302 & + zwy(ji,jj,jk) - zwy(ji ,jj-1,jk ) & … … 307 307 CALL tridia_solver( zwdia, zwsup, zwinf, ztw, ztw , 0 ) 308 308 ! 309 DO_3D( 0, 0, 0, 0, 2, jpkm1 ) 309 DO_3D( 0, 0, 0, 0, 2, jpkm1 ) ! Interior value ( multiplied by wmask) 310 310 zfp_wk = wi(ji,jj,jk) + ABS( wi(ji,jj,jk) ) 311 311 zfm_wk = wi(ji,jj,jk) - ABS( wi(ji,jj,jk) ) … … 337 337 ! 338 338 ztw(:,:,1) = 0._wp ; ztw(:,:,jpk) = 0._wp 339 DO_3D( 0, 0, 0, 0, 2, jpkm1 ) 339 DO_3D( 0, 0, 0, 0, 2, jpkm1 ) ! Interior value ( multiplied by wmask) 340 340 zfp_wk = wi(ji,jj,jk) + ABS( wi(ji,jj,jk) ) 341 341 zfm_wk = wi(ji,jj,jk) - ABS( wi(ji,jj,jk) ) … … 471 471 pbb(ji,jj,jk) = pbb(ji,jj,jk) * ( zcv * zav + ( 1._wp - zcv) * zbv ) 472 472 473 ! monotonic flux in the k direction, i.e. pcc474 ! -------------------------------------------473 ! monotonic flux in the k direction, i.e. pcc 474 ! ------------------------------------------- 475 475 za = MIN( 1., zbetdo(ji,jj,jk+1), zbetup(ji,jj,jk) ) 476 476 zb = MIN( 1., zbetup(ji,jj,jk+1), zbetdo(ji,jj,jk) ) … … 502 502 !!---------------------------------------------------------------------- 503 503 504 DO_3D( 1, 1, 1, 1, 3, jpkm1 ) 504 DO_3D( 1, 1, 1, 1, 3, jpkm1 ) !== build the three diagonal matrix ==! 505 505 zwd (ji,jj,jk) = 4._wp 506 506 zwi (ji,jj,jk) = 1._wp … … 516 516 END_3D 517 517 ! 518 jk = 2 518 jk = 2 ! Switch to second order centered at top 519 519 DO_2D( 1, 1, 1, 1 ) 520 520 zwd (ji,jj,jk) = 1._wp … … 525 525 ! 526 526 ! !== tridiagonal solve ==! 527 DO_2D( 1, 1, 1, 1 ) 527 DO_2D( 1, 1, 1, 1 ) ! first recurrence 528 528 zwt(ji,jj,2) = zwd(ji,jj,2) 529 529 END_2D … … 532 532 END_3D 533 533 ! 534 DO_2D( 1, 1, 1, 1 ) 534 DO_2D( 1, 1, 1, 1 ) ! second recurrence: Zk = Yk - Ik / Tk-1 Zk-1 535 535 pt_out(ji,jj,2) = zwrm(ji,jj,2) 536 536 END_2D … … 539 539 END_3D 540 540 541 DO_2D( 1, 1, 1, 1 ) 541 DO_2D( 1, 1, 1, 1 ) ! third recurrence: Xk = (Zk - Sk Xk+1 ) / Tk 542 542 pt_out(ji,jj,jpkm1) = pt_out(ji,jj,jpkm1) / zwt(ji,jj,jpkm1) 543 543 END_2D … … 567 567 ! !== build the three diagonal matrix & the RHS ==! 568 568 ! 569 DO_3D( 0, 0, 0, 0, 3, jpkm1 ) 569 DO_3D( 0, 0, 0, 0, 3, jpkm1 ) ! interior (from jk=3 to jpk-1) 570 570 zwd (ji,jj,jk) = 3._wp * wmask(ji,jj,jk) + 1._wp ! diagonal 571 571 zwi (ji,jj,jk) = wmask(ji,jj,jk) ! lower diagonal … … 586 586 END IF 587 587 ! 588 DO_2D( 0, 0, 0, 0 ) 588 DO_2D( 0, 0, 0, 0 ) ! 2nd order centered at top & bottom 589 589 ikt = mikt(ji,jj) + 1 ! w-point below the 1st wet point 590 590 ikb = MAX(mbkt(ji,jj), 2) ! - above the last wet point … … 603 603 ! !== tridiagonal solver ==! 604 604 ! 605 DO_2D( 0, 0, 0, 0 ) 605 DO_2D( 0, 0, 0, 0 ) !* 1st recurrence: Tk = Dk - Ik Sk-1 / Tk-1 606 606 zwt(ji,jj,2) = zwd(ji,jj,2) 607 607 END_2D … … 610 610 END_3D 611 611 ! 612 DO_2D( 0, 0, 0, 0 ) 612 DO_2D( 0, 0, 0, 0 ) !* 2nd recurrence: Zk = Yk - Ik / Tk-1 Zk-1 613 613 pt_out(ji,jj,2) = zwrm(ji,jj,2) 614 614 END_2D … … 617 617 END_3D 618 618 619 DO_2D( 0, 0, 0, 0 ) 619 DO_2D( 0, 0, 0, 0 ) !* 3d recurrence: Xk = (Zk - Sk Xk+1 ) / Tk 620 620 pt_out(ji,jj,jpkm1) = pt_out(ji,jj,jpkm1) / zwt(ji,jj,jpkm1) 621 621 END_2D … … 659 659 kstart = 1 + klev 660 660 ! 661 DO_2D( 0, 0, 0, 0 ) 661 DO_2D( 0, 0, 0, 0 ) !* 1st recurrence: Tk = Dk - Ik Sk-1 / Tk-1 662 662 zwt(ji,jj,kstart) = pD(ji,jj,kstart) 663 663 END_2D … … 666 666 END_3D 667 667 ! 668 DO_2D( 0, 0, 0, 0 ) 668 DO_2D( 0, 0, 0, 0 ) !* 2nd recurrence: Zk = Yk - Ik / Tk-1 Zk-1 669 669 pt_out(ji,jj,kstart) = pRHS(ji,jj,kstart) 670 670 END_2D … … 673 673 END_3D 674 674 675 DO_2D( 0, 0, 0, 0 ) 675 DO_2D( 0, 0, 0, 0 ) !* 3d recurrence: Xk = (Zk - Sk Xk+1 ) / Tk 676 676 pt_out(ji,jj,jpkm1) = pt_out(ji,jj,jpkm1) / zwt(ji,jj,jpkm1) 677 677 END_2D -
NEMO/branches/2020/dev_r13296_HPC-07_mocavero_mpi3/src/OCE/TRA/traadv_mus.F90
r13295 r13571 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_r13296_HPC-07_mocavero_mpi3/src/OCE/TRA/traadv_qck.F90
r13295 r13571 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_r13296_HPC-07_mocavero_mpi3/src/OCE/TRA/traadv_ubs.F90
r13295 r13571 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_r13296_HPC-07_mocavero_mpi3/src/OCE/TRA/trabbl.F90
r13295 r13571 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_r13296_HPC-07_mocavero_mpi3/src/OCE/TRA/traldf_iso.F90
r13295 r13571 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_r13296_HPC-07_mocavero_mpi3/src/OCE/TRA/traldf_lap_blp.F90
r13295 r13571 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_r13296_HPC-07_mocavero_mpi3/src/OCE/TRA/traldf_triad.F90
r13295 r13571 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_r13296_HPC-07_mocavero_mpi3/src/OCE/TRA/tramle.F90
r13295 r13571 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_r13296_HPC-07_mocavero_mpi3/src/OCE/TRA/tranpc.F90
r13295 r13571 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_r13296_HPC-07_mocavero_mpi3/src/OCE/TRA/traqsr.F90
r13295 r13571 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_r13296_HPC-07_mocavero_mpi3/src/OCE/TRA/trasbc.F90
r13295 r13571 129 129 END_2D 130 130 IF( ln_linssh ) THEN !* linear free surface 131 DO_2D( 0, 1, 0, 0 ) 131 DO_2D( 0, 1, 0, 0 ) !==>> add concentration/dilution effect due to constant volume cell 132 132 sbc_tsc(ji,jj,jp_tem) = sbc_tsc(ji,jj,jp_tem) + r1_rho0 * emp(ji,jj) * pts(ji,jj,1,jp_tem,Kmm) 133 133 sbc_tsc(ji,jj,jp_sal) = sbc_tsc(ji,jj,jp_sal) + r1_rho0 * emp(ji,jj) * pts(ji,jj,1,jp_sal,Kmm) 134 END_2D 134 END_2D !==>> output c./d. term 135 135 IF( iom_use('emp_x_sst') ) CALL iom_put( "emp_x_sst", emp (:,:) * pts(:,:,1,jp_tem,Kmm) ) 136 136 IF( iom_use('emp_x_sss') ) CALL iom_put( "emp_x_sss", emp (:,:) * pts(:,:,1,jp_sal,Kmm) ) -
NEMO/branches/2020/dev_r13296_HPC-07_mocavero_mpi3/src/OCE/TRA/trazdf.F90
r13295 r13571 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_r13296_HPC-07_mocavero_mpi3/src/OCE/TRA/zpshde.F90
r13295 r13571 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_r13296_HPC-07_mocavero_mpi3/src/OCE/TRD/trddyn.F90
r13295 r13571 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_r13296_HPC-07_mocavero_mpi3/src/OCE/TRD/trdglo.F90
r13295 r13571 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_r13296_HPC-07_mocavero_mpi3/src/OCE/TRD/trdmxl.F90
r13295 r13571 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_r13296_HPC-07_mocavero_mpi3/src/OCE/TRD/trdtra.F90
r13295 r13571 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_r13296_HPC-07_mocavero_mpi3/src/OCE/TRD/trdvor.F90
r13295 r13571 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_r13296_HPC-07_mocavero_mpi3/src/OCE/USR/usrdef_fmask.F90
r13286 r13571 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_r13296_HPC-07_mocavero_mpi3/src/OCE/USR/usrdef_istate.F90
r13295 r13571 57 57 IF(lwp) WRITE(numout,*) '~~~~~~~~~~~~~~ Ocean at rest, with an horizontally uniform T and S profiles' 58 58 ! 59 pu (:,:,:) = 0._wp ! ocean at rest59 pu (:,:,:) = 0._wp ! ocean at rest 60 60 pv (:,:,:) = 0._wp 61 61 pssh(:,:) = 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_r13296_HPC-07_mocavero_mpi3/src/OCE/ZDF/zdfddm.F90
r13295 r13571 94 94 !!gm and many acces in memory 95 95 96 DO_2D( 1, 1, 1, 1 ) 96 DO_2D( 1, 1, 1, 1 ) !== R=zrau = (alpha / beta) (dk[t] / dk[s]) ==! 97 97 zrw = ( gdepw(ji,jj,jk ,Kmm) - gdept(ji,jj,jk,Kmm) ) & 98 98 !!gm please, use e3w at Kmm below … … 110 110 END_2D 111 111 112 DO_2D( 1, 1, 1, 1 ) 112 DO_2D( 1, 1, 1, 1 ) !== indicators ==! 113 113 ! stability indicator: msks=1 if rn2>0; 0 elsewhere 114 114 IF( rn2(ji,jj,jk) + 1.e-12 <= 0. ) THEN ; zmsks(ji,jj) = 0._wp -
NEMO/branches/2020/dev_r13296_HPC-07_mocavero_mpi3/src/OCE/ZDF/zdfdrg.F90
r13295 r13571 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_r13296_HPC-07_mocavero_mpi3/src/OCE/ZDF/zdfgls.F90
r13295 r13571 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_r13296_HPC-07_mocavero_mpi3/src/OCE/ZDF/zdfiwm.F90
r13295 r13571 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_r13296_HPC-07_mocavero_mpi3/src/OCE/ZDF/zdfmxl.F90
r13295 r13571 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_r13296_HPC-07_mocavero_mpi3/src/OCE/ZDF/zdfosm.F90
r13295 r13571 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_r13296_HPC-07_mocavero_mpi3/src/OCE/ZDF/zdfphy.F90
r13226 r13571 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_r13296_HPC-07_mocavero_mpi3/src/OCE/ZDF/zdfric.F90
r13295 r13571 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_r13296_HPC-07_mocavero_mpi3/src/OCE/ZDF/zdfsh2.F90
r13295 r13571 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_r13296_HPC-07_mocavero_mpi3/src/OCE/ZDF/zdftke.F90
r13295 r13571 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_r13296_HPC-07_mocavero_mpi3/src/OCE/lib_fortran.F90
r13295 r13571 217 217 IF( SIZE(p2d,2) /= jpj ) CALL ctl_stop( 'STOP', 'wrong call of sum3x3_2d, the second dimension is not equal to jpj' ) 218 218 ! 219 DO_2D( 1, 1, 1, 1 ) 220 IF( MOD(mig(ji), 3) == 1 .AND. MOD(mjg(jj), 3) == 1 ) THEN ! bottom left corber of a 3x3 box 219 ! work over the whole domain (guarantees all internal cells are set when nn_hls=2) 220 ! 221 DO_2D( nn_hls, nn_hls, nn_hls, nn_hls ) 222 IF( MOD(mig(ji), 3) == MOD(nn_hls, 3) .AND. & 223 & MOD(mjg(jj), 3) == MOD(nn_hls, 3) ) THEN ! bottom left corner of a 3x3 box 221 224 ji2 = MIN(mig(ji)+2, jpiglo) - nimpp + 1 ! right position of the box 222 225 jj2 = MIN(mjg(jj)+2, jpjglo) - njmpp + 1 ! upper position of the box … … 227 230 END_2D 228 231 CALL lbc_lnk( 'lib_fortran', p2d, 'T', 1.0_wp ) 229 IF( nbondi /= -1 ) THEN 230 IF( MOD(mig( 1), 3) == 1 ) p2d( 1,:) = p2d( 2,:) 231 IF( MOD(mig( 1), 3) == 2 ) p2d( 2,:) = p2d( 1,:) 232 ! no need for 2nd exchange when nn_hls = 2 233 IF( nn_hls /= 2 ) THEN 234 IF( nbondi /= -1 ) THEN 235 IF( MOD(mig( 1), 3) == 1 ) p2d( 1,:) = p2d( 2,:) 236 IF( MOD(mig( 1), 3) == 2 ) p2d( 2,:) = p2d( 1,:) 237 ENDIF 238 IF( nbondi /= 1 ) THEN 239 IF( MOD(mig(jpi-2), 3) == 1 ) p2d( jpi,:) = p2d(jpi-1,:) 240 IF( MOD(mig(jpi-2), 3) == 0 ) p2d(jpi-1,:) = p2d( jpi,:) 241 ENDIF 242 IF( nbondj /= -1 ) THEN 243 IF( MOD(mjg( 1), 3) == 1 ) p2d(:, 1) = p2d(:, 2) 244 IF( MOD(mjg( 1), 3) == 2 ) p2d(:, 2) = p2d(:, 1) 245 ENDIF 246 IF( nbondj /= 1 ) THEN 247 IF( MOD(mjg(jpj-2), 3) == 1 ) p2d(:, jpj) = p2d(:,jpj-1) 248 IF( MOD(mjg(jpj-2), 3) == 0 ) p2d(:,jpj-1) = p2d(:, jpj) 249 ENDIF 250 CALL lbc_lnk( 'lib_fortran', p2d, 'T', 1.0_wp ) 232 251 ENDIF 233 IF( nbondi /= 1 ) THEN234 IF( MOD(mig(jpi-2), 3) == 1 ) p2d( jpi,:) = p2d(jpi-1,:)235 IF( MOD(mig(jpi-2), 3) == 0 ) p2d(jpi-1,:) = p2d( jpi,:)236 ENDIF237 IF( nbondj /= -1 ) THEN238 IF( MOD(mjg( 1), 3) == 1 ) p2d(:, 1) = p2d(:, 2)239 IF( MOD(mjg( 1), 3) == 2 ) p2d(:, 2) = p2d(:, 1)240 ENDIF241 IF( nbondj /= 1 ) THEN242 IF( MOD(mjg(jpj-2), 3) == 1 ) p2d(:, jpj) = p2d(:,jpj-1)243 IF( MOD(mjg(jpj-2), 3) == 0 ) p2d(:,jpj-1) = p2d(:, jpj)244 ENDIF245 CALL lbc_lnk( 'lib_fortran', p2d, 'T', 1.0_wp )246 252 247 253 END SUBROUTINE sum3x3_2d … … 264 270 ! 265 271 DO jn = 1, ipn 266 DO_2D( 1, 1, 1, 1 ) 267 IF( MOD(mig(ji), 3) == 1 .AND. MOD(mjg(jj), 3) == 1 ) THEN ! bottom left corber of a 3x3 box 272 ! 273 ! work over the whole domain (guarantees all internal cells are set when nn_hls=2) 274 ! 275 DO_2D( nn_hls, nn_hls, nn_hls, nn_hls ) 276 IF( MOD(mig(ji), 3) == MOD(nn_hls, 3) .AND. & 277 & MOD(mjg(jj), 3) == MOD(nn_hls, 3) ) THEN ! bottom left corner of a 3x3 box 268 278 ji2 = MIN(mig(ji)+2, jpiglo) - nimpp + 1 ! right position of the box 269 279 jj2 = MIN(mjg(jj)+2, jpjglo) - njmpp + 1 ! upper position of the box … … 275 285 END DO 276 286 CALL lbc_lnk( 'lib_fortran', p3d, 'T', 1.0_wp ) 277 IF( nbondi /= -1 ) THEN 278 IF( MOD(mig( 1), 3) == 1 ) p3d( 1,:,:) = p3d( 2,:,:) 279 IF( MOD(mig( 1), 3) == 2 ) p3d( 2,:,:) = p3d( 1,:,:) 287 ! no need for 2nd exchange when nn_hls = 2 288 IF( nn_hls /= 2 ) THEN 289 IF( nbondi /= -1 ) THEN 290 IF( MOD(mig( 1), 3) == 1 ) p3d( 1,:,:) = p3d( 2,:,:) 291 IF( MOD(mig( 1), 3) == 2 ) p3d( 2,:,:) = p3d( 1,:,:) 292 ENDIF 293 IF( nbondi /= 1 ) THEN 294 IF( MOD(mig(jpi-2), 3) == 1 ) p3d( jpi,:,:) = p3d(jpi-1,:,:) 295 IF( MOD(mig(jpi-2), 3) == 0 ) p3d(jpi-1,:,:) = p3d( jpi,:,:) 296 ENDIF 297 IF( nbondj /= -1 ) THEN 298 IF( MOD(mjg( 1), 3) == 1 ) p3d(:, 1,:) = p3d(:, 2,:) 299 IF( MOD(mjg( 1), 3) == 2 ) p3d(:, 2,:) = p3d(:, 1,:) 300 ENDIF 301 IF( nbondj /= 1 ) THEN 302 IF( MOD(mjg(jpj-2), 3) == 1 ) p3d(:, jpj,:) = p3d(:,jpj-1,:) 303 IF( MOD(mjg(jpj-2), 3) == 0 ) p3d(:,jpj-1,:) = p3d(:, jpj,:) 304 ENDIF 305 CALL lbc_lnk( 'lib_fortran', p3d, 'T', 1.0_wp ) 280 306 ENDIF 281 IF( nbondi /= 1 ) THEN282 IF( MOD(mig(jpi-2), 3) == 1 ) p3d( jpi,:,:) = p3d(jpi-1,:,:)283 IF( MOD(mig(jpi-2), 3) == 0 ) p3d(jpi-1,:,:) = p3d( jpi,:,:)284 ENDIF285 IF( nbondj /= -1 ) THEN286 IF( MOD(mjg( 1), 3) == 1 ) p3d(:, 1,:) = p3d(:, 2,:)287 IF( MOD(mjg( 1), 3) == 2 ) p3d(:, 2,:) = p3d(:, 1,:)288 ENDIF289 IF( nbondj /= 1 ) THEN290 IF( MOD(mjg(jpj-2), 3) == 1 ) p3d(:, jpj,:) = p3d(:,jpj-1,:)291 IF( MOD(mjg(jpj-2), 3) == 0 ) p3d(:,jpj-1,:) = p3d(:, jpj,:)292 ENDIF293 CALL lbc_lnk( 'lib_fortran', p3d, 'T', 1.0_wp )294 307 295 308 END SUBROUTINE sum3x3_3d -
NEMO/branches/2020/dev_r13296_HPC-07_mocavero_mpi3/src/OCE/module_example
r11536 r13571 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_r13296_HPC-07_mocavero_mpi3/src/OCE/nemogcm.F90
r13286 r13571 54 54 USE asminc ! assimilation increments 55 55 USE asmbkg ! writing out state trajectory 56 USE diaptr ! poleward transports (dia_ptr_init routine)57 56 USE diadct ! sections transports (dia_dct_init routine) 58 57 USE diaobs ! Observation diagnostics (dia_obs_init routine) … … 472 471 ! ! Lateral physics 473 472 CALL ldf_tra_init ! Lateral ocean tracer physics 474 CALL ldf_eiv_init ! eddy induced velocity param. 473 CALL ldf_eiv_init ! eddy induced velocity param. must be done after ldf_tra_init 475 474 CALL ldf_dyn_init ! Lateral ocean momentum physics 476 475 … … 510 509 CALL flo_init( Nnn ) ! drifting Floats 511 510 IF( ln_diacfl ) CALL dia_cfl_init ! Initialise CFL diagnostics 512 ! CALL dia_ptr_init ! Poleward TRansports initialization513 511 CALL dia_dct_init ! Sections tranports 514 512 CALL dia_hsb_init( Nnn ) ! heat content, salt content and volume budgets -
NEMO/branches/2020/dev_r13296_HPC-07_mocavero_mpi3/src/OCE/stpctl.F90
r13216 r13571 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 … … 119 118 ! !== test of local extrema ==! 120 119 ! !== done by all processes at every time step ==! 121 llmsk(:,:,1) = ssmask(:,:) == 1._wp 120 ! 121 llmsk( 1:Nis1,:,:) = .FALSE. ! exclude halos from the checked region 122 llmsk(Nie1: jpi,:,:) = .FALSE. 123 llmsk(:, 1:Njs1,:) = .FALSE. 124 llmsk(:,Nje1: jpj,:) = .FALSE. 125 ! 126 llmsk(Nis0:Nie0,Njs0:Nje0,1) = ssmask(Nis0:Nie0,Njs0:Nje0) == 1._wp ! define only the inner domain 122 127 IF( ll_wd ) THEN 123 128 zmax(1) = MAXVAL( ABS( ssh(:,:,Kmm) + ssh_ref ), mask = llmsk(:,:,1) ) ! ssh max … … 125 130 zmax(1) = MAXVAL( ABS( ssh(:,:,Kmm) ), mask = llmsk(:,:,1) ) ! ssh max 126 131 ENDIF 127 llmsk( :,:,:) = umask(:,:,:) == 1._wp132 llmsk(Nis0:Nie0,Njs0:Nje0,:) = umask(Nis0:Nie0,Njs0:Nje0,:) == 1._wp ! define only the inner domain 128 133 zmax(2) = MAXVAL( ABS( uu(:,:,:,Kmm) ), mask = llmsk ) ! velocity max (zonal only) 129 llmsk( :,:,:) = tmask(:,:,:) == 1._wp134 llmsk(Nis0:Nie0,Njs0:Nje0,:) = tmask(Nis0:Nie0,Njs0:Nje0,:) == 1._wp ! define only the inner domain 130 135 zmax(3) = MAXVAL( -ts(:,:,:,jp_sal,Kmm), mask = llmsk ) ! minus salinity max 131 136 zmax(4) = MAXVAL( ts(:,:,:,jp_sal,Kmm), mask = llmsk ) ! salinity max … … 143 148 zmax(5:8) = 0._wp 144 149 ENDIF 145 zmax(9) = REAL( nstop, wp ) ! stop indicator150 zmax(9) = REAL( nstop, wp ) ! stop indicator 146 151 ! !== get global extrema ==! 147 152 ! !== done by all processes if writting run.stat ==! … … 183 188 IF( lwm .AND. kt /= nitend ) istatus = NF90_CLOSE(nrunid) 184 189 ! get global loc on the min/max 185 CALL mpp_maxloc( 'stpctl', ABS(ssh(:,:, Kmm)), ssmask(:,: ), zzz, iloc(1:2,1) ) ! mpp_maxloc ok if mask = F 186 CALL mpp_maxloc( 'stpctl', ABS( uu(:,:,:, Kmm)), umask(:,:,:), zzz, iloc(1:3,2) ) 187 CALL mpp_minloc( 'stpctl', ts(:,:,:,jp_sal,Kmm) , tmask(:,:,:), zzz, iloc(1:3,3) ) 188 CALL mpp_maxloc( 'stpctl', ts(:,:,:,jp_sal,Kmm) , tmask(:,:,:), zzz, iloc(1:3,4) ) 190 llmsk(Nis0:Nie0,Njs0:Nje0,1) = ssmask(Nis0:Nie0,Njs0:Nje0 ) == 1._wp ! define only the inner domain 191 CALL mpp_maxloc( 'stpctl', ABS(ssh(:,:, Kmm)), llmsk(:,:,1), zzz, iloc(1:2,1) ) ! mpp_maxloc ok if mask = F 192 llmsk(Nis0:Nie0,Njs0:Nje0,:) = umask(Nis0:Nie0,Njs0:Nje0,:) == 1._wp ! define only the inner domain 193 CALL mpp_maxloc( 'stpctl', ABS( uu(:,:,:, Kmm)), llmsk(:,:,:), zzz, iloc(1:3,2) ) 194 llmsk(Nis0:Nie0,Njs0:Nje0,:) = tmask(Nis0:Nie0,Njs0:Nje0,:) == 1._wp ! define only the inner domain 195 CALL mpp_minloc( 'stpctl', ts(:,:,:,jp_sal,Kmm) , llmsk(:,:,:), zzz, iloc(1:3,3) ) 196 CALL mpp_maxloc( 'stpctl', ts(:,:,:,jp_sal,Kmm) , llmsk(:,:,:), zzz, iloc(1:3,4) ) 189 197 ! find which subdomain has the max. 190 198 iareamin(:) = jpnij+1 ; iareamax(:) = 0 ; iareasum(:) = 0 … … 199 207 ELSE ! find local min and max locations: 200 208 ! if we are here, this means that the subdomain contains some oce points -> no need to test the mask used in maxloc 201 iloc(1:2,1) = MAXLOC( ABS( ssh(:,:, Kmm)), mask = ssmask(:,: ) == 1._wp ) + (/ nimpp - 1, njmpp - 1 /) 202 iloc(1:3,2) = MAXLOC( ABS( uu(:,:,:, Kmm)), mask = umask(:,:,:) == 1._wp ) + (/ nimpp - 1, njmpp - 1, 0 /) 203 iloc(1:3,3) = MINLOC( ts(:,:,:,jp_sal,Kmm) , mask = tmask(:,:,:) == 1._wp ) + (/ nimpp - 1, njmpp - 1, 0 /) 204 iloc(1:3,4) = MAXLOC( ts(:,:,:,jp_sal,Kmm) , mask = tmask(:,:,:) == 1._wp ) + (/ nimpp - 1, njmpp - 1, 0 /) 209 llmsk(Nis0:Nie0,Njs0:Nje0,1) = ssmask(Nis0:Nie0,Njs0:Nje0 ) == 1._wp ! define only the inner domain 210 iloc(1:2,1) = MAXLOC( ABS( ssh(:,:, Kmm)), mask = llmsk(:,:,1) ) 211 llmsk(Nis0:Nie0,Njs0:Nje0,:) = umask(Nis0:Nie0,Njs0:Nje0,:) == 1._wp ! define only the inner domain 212 iloc(1:3,2) = MAXLOC( ABS( uu(:,:,:, Kmm)), mask = llmsk(:,:,:) ) 213 llmsk(Nis0:Nie0,Njs0:Nje0,:) = tmask(Nis0:Nie0,Njs0:Nje0,:) == 1._wp ! define only the inner domain 214 iloc(1:3,3) = MINLOC( ts(:,:,:,jp_sal,Kmm) , mask = llmsk(:,:,:) ) 215 iloc(1:3,4) = MAXLOC( ts(:,:,:,jp_sal,Kmm) , mask = llmsk(:,:,:) ) 216 DO ji = 1, 4 ! local domain indices ==> global domain indices, excluding halos 217 iloc(1:2,ji) = (/ mig0(iloc(1,ji)), mjg0(iloc(2,ji)) /) 218 END DO 205 219 iareamin(:) = narea ; iareamax(:) = narea ; iareasum(:) = 1 ! this is local information 206 220 ENDIF -
NEMO/branches/2020/dev_r13296_HPC-07_mocavero_mpi3/src/OCE/timing.F90
r12489 r13571 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.