Changeset 13151
- Timestamp:
- 2020-06-24T14:38:26+02:00 (4 years ago)
- Location:
- NEMO/branches/2020/dev_r12527_Gurvan_ShallowWater/src
- Files:
-
- 8 added
- 163 edited
Legend:
- Unmodified
- Added
- Removed
-
NEMO/branches/2020/dev_r12527_Gurvan_ShallowWater/src/ABL/ablrst.F90
r11945 r13151 74 74 ENDIF 75 75 ! 76 CALL iom_open( TRIM(clpath)//TRIM(clname), numraw, ldwrt = .TRUE., kdlev = jpka )76 CALL iom_open( TRIM(clpath)//TRIM(clname), numraw, ldwrt = .TRUE., kdlev = jpka, cdcomp = 'ABL' ) 77 77 lrst_abl = .TRUE. 78 78 ENDIF … … 146 146 ENDIF 147 147 148 CALL iom_open ( TRIM(cn_ablrst_indir)//'/'//cn_ablrst_in, numrar , kdlev = jpka)148 CALL iom_open ( TRIM(cn_ablrst_indir)//'/'//cn_ablrst_in, numrar ) 149 149 150 150 ! Time info -
NEMO/branches/2020/dev_r12527_Gurvan_ShallowWater/src/ABL/sbcabl.F90
r12489 r13151 75 75 !!--------------------------------------------------------------------- 76 76 77 REWIND( numnam_ref )! Namelist namsbc_abl in reference namelist : ABL parameters77 ! Namelist namsbc_abl in reference namelist : ABL parameters 78 78 READ ( numnam_ref, namsbc_abl, IOSTAT = ios, ERR = 901 ) 79 79 901 IF( ios /= 0 ) CALL ctl_nam ( ios , 'namsbc_abl in reference namelist' ) 80 ! 81 REWIND( numnam_cfg ) ! Namelist namsbc_abl in configuration namelist : ABL parameters 80 ! Namelist namsbc_abl in configuration namelist : ABL parameters 82 81 READ ( numnam_cfg, namsbc_abl, IOSTAT = ios, ERR = 902 ) 83 82 902 IF( ios /= 0 ) CALL ctl_nam ( ios , 'namsbc_abl in configuration namelist' ) -
NEMO/branches/2020/dev_r12527_Gurvan_ShallowWater/src/ICE/icectl.F90
r12489 r13151 331 331 IF(lwp) WRITE(numout,*) 332 332 333 CALL iom_open( TRIM(cdfile_name), inum, ldwrt = .TRUE., kdlev = jpl )333 CALL iom_open( TRIM(cdfile_name), inum, ldwrt = .TRUE., kdlev = jpl, cdcomp = 'ICE' ) 334 334 335 335 CALL iom_rstput( 0, 0, inum, 'cons_mass', pdiag_mass(:,:) , ktype = jp_r8 ) ! ice mass spurious lost/gain … … 725 725 726 726 CALL prt_ctl_info(' ') 727 CALL prt_ctl_info(' - Heat / FW fluxes : ')728 CALL prt_ctl_info(' ~~~~~~~~~~~~~~~~~~ ')729 CALL prt_ctl(tab2d_1=sst_m , clinfo1= ' sst : ', tab2d_2=sss_m , clinfo2= ' sss : ')730 CALL prt_ctl(tab2d_1=qsr , clinfo1= ' qsr : ', tab2d_2=qns , clinfo2= ' qns : ')731 CALL prt_ctl(tab2d_1=emp , clinfo1= ' emp : ', tab2d_2=sfx , clinfo2= ' sfx : ')732 733 CALL prt_ctl_info(' ')734 727 CALL prt_ctl_info(' - Stresses : ') 735 728 CALL prt_ctl_info(' ~~~~~~~~~~ ') -
NEMO/branches/2020/dev_r12527_Gurvan_ShallowWater/src/ICE/icedyn_rhg_evp.F90
r12489 r13151 49 49 !! * Substitutions 50 50 # include "do_loop_substitute.h90" 51 # include "domzgr_substitute.h90" 51 52 !!---------------------------------------------------------------------- 52 53 !! NEMO/ICE 4.0 , NEMO Consortium (2018) -
NEMO/branches/2020/dev_r12527_Gurvan_ShallowWater/src/ICE/iceistate.F90
r12489 r13151 18 18 USE oce ! dynamics and tracers variables 19 19 USE dom_oce ! ocean domain 20 USE sbc_oce , ONLY : sst_m, sss_m, ln_ice_embd 20 USE sbc_oce , ONLY : sst_m, sss_m, ln_ice_embd 21 21 USE sbc_ice , ONLY : tn_ice, snwice_mass, snwice_mass_b 22 22 USE eosbn2 ! equation of state … … 60 60 INTEGER , PARAMETER :: jp_hpd = 9 ! index of pnd depth (m) 61 61 TYPE(FLD), ALLOCATABLE, DIMENSION(:) :: si ! structure of input fields (file informations, fields read) 62 ! 62 63 63 !! * Substitutions 64 64 # include "do_loop_substitute.h90" … … 77 77 !! 78 78 !! ** Method : This routine will put some ice where ocean 79 !! is at the freezing point, then fill in ice 80 !! state variables using prescribed initial 81 !! values in the namelist 79 !! is at the freezing point, then fill in ice 80 !! state variables using prescribed initial 81 !! values in the namelist 82 82 !! 83 83 !! ** Steps : 1) Set initial surface and basal temperatures … … 91 91 !! where there is no ice 92 92 !!-------------------------------------------------------------------- 93 INTEGER, INTENT(in) :: kt ! time step 93 INTEGER, INTENT(in) :: kt ! time step 94 94 INTEGER, INTENT(in) :: Kbb, Kmm, Kaa ! ocean time level indices 95 95 ! … … 102 102 REAL(wp), DIMENSION(jpi,jpj) :: zt_su_ini, zht_s_ini, zsm_i_ini, ztm_i_ini !data from namelist or nc file 103 103 REAL(wp), DIMENSION(jpi,jpj) :: zapnd_ini, zhpnd_ini !data from namelist or nc file 104 REAL(wp), DIMENSION(jpi,jpj,jpl) :: zti_3d , zts_3d ! temporaryarrays104 REAL(wp), DIMENSION(jpi,jpj,jpl) :: zti_3d , zts_3d !locak arrays 105 105 !! 106 106 REAL(wp), DIMENSION(:,:), ALLOCATABLE :: zhi_2d, zhs_2d, zai_2d, zti_2d, zts_2d, ztsu_2d, zsi_2d, zaip_2d, zhip_2d … … 117 117 ! basal temperature (considered at freezing point) [Kelvin] 118 118 CALL eos_fzp( sss_m(:,:), t_bo(:,:) ) 119 t_bo(:,:) = ( t_bo(:,:) + rt0 ) * tmask(:,:,1) 119 t_bo(:,:) = ( t_bo(:,:) + rt0 ) * tmask(:,:,1) 120 120 ! 121 121 ! surface temperature and conductivity … … 142 142 e_i (:,:,:,:) = 0._wp 143 143 e_s (:,:,:,:) = 0._wp 144 144 145 145 ! general fields 146 146 a_i (:,:,:) = 0._wp … … 213 213 IF( TRIM(si(jp_apd)%clrootname) == 'NOT USED' ) & 214 214 & si(jp_apd)%fnow(:,:,1) = ( rn_apd_ini_n * zswitch + rn_apd_ini_s * (1._wp - zswitch) ) * tmask(:,:,1) & ! rn_apd = pond fraction => rn_apnd * a_i = pond conc. 215 & * si(jp_ati)%fnow(:,:,1) 215 & * si(jp_ati)%fnow(:,:,1) 216 216 ! 217 217 ! pond depth … … 227 227 ! 228 228 ! change the switch for the following 229 WHERE( zat_i_ini(:,:) > 0._wp ) ; zswitch(:,:) = tmask(:,:,1) 229 WHERE( zat_i_ini(:,:) > 0._wp ) ; zswitch(:,:) = tmask(:,:,1) 230 230 ELSEWHERE ; zswitch(:,:) = 0._wp 231 231 END WHERE … … 234 234 ! !---------------! 235 235 ! no ice if (sst - Tfreez) >= thresold 236 WHERE( ( sst_m(:,:) - (t_bo(:,:) - rt0) ) * tmask(:,:,1) >= rn_thres_sst ) ; zswitch(:,:) = 0._wp 236 WHERE( ( sst_m(:,:) - (t_bo(:,:) - rt0) ) * tmask(:,:,1) >= rn_thres_sst ) ; zswitch(:,:) = 0._wp 237 237 ELSEWHERE ; zswitch(:,:) = tmask(:,:,1) 238 238 END WHERE … … 247 247 zt_su_ini(:,:) = rn_tsu_ini_n * zswitch(:,:) 248 248 ztm_s_ini(:,:) = rn_tms_ini_n * zswitch(:,:) 249 zapnd_ini(:,:) = rn_apd_ini_n * zswitch(:,:) * zat_i_ini(:,:) ! rn_apd = pond fraction => rn_apd * a_i = pond conc. 249 zapnd_ini(:,:) = rn_apd_ini_n * zswitch(:,:) * zat_i_ini(:,:) ! rn_apd = pond fraction => rn_apd * a_i = pond conc. 250 250 zhpnd_ini(:,:) = rn_hpd_ini_n * zswitch(:,:) 251 251 ELSEWHERE … … 268 268 zhpnd_ini(:,:) = 0._wp 269 269 ENDIF 270 270 271 271 !-------------! 272 272 ! fill fields ! … … 295 295 ALLOCATE( zhi_2d(npti,jpl), zhs_2d(npti,jpl), zai_2d (npti,jpl), & 296 296 & zti_2d(npti,jpl), zts_2d(npti,jpl), ztsu_2d(npti,jpl), zsi_2d(npti,jpl), zaip_2d(npti,jpl), zhip_2d(npti,jpl) ) 297 297 298 298 ! distribute 1-cat into jpl-cat: (jpi*jpj) -> (jpi*jpj,jpl) 299 299 CALL ice_var_itd( h_i_1d(1:npti) , h_s_1d(1:npti) , at_i_1d(1:npti), & … … 341 341 DO jl = 1, jpl 342 342 DO_3D_11_11( 1, nlay_i ) 343 t_i (ji,jj,jk,jl) = zti_3d(ji,jj,jl) 343 t_i (ji,jj,jk,jl) = zti_3d(ji,jj,jl) 344 344 ztmelts = - rTmlt * sz_i(ji,jj,jk,jl) + rt0 ! melting temperature in K 345 345 e_i(ji,jj,jk,jl) = zswitch(ji,jj) * v_i(ji,jj,jl) * r1_nlay_i * & … … 357 357 END WHERE 358 358 v_ip(:,:,:) = h_ip(:,:,:) * a_ip(:,:,:) 359 359 360 360 ! specific temperatures for coupled runs 361 361 tn_ice(:,:,:) = t_su(:,:,:) … … 377 377 ssh(:,:,Kbb) = ssh(:,:,Kbb) - snwice_mass(:,:) * r1_rho0 378 378 ! 379 IF( .NOT.ln_linssh ) THEN 380 ! 381 WHERE( ht_0(:,:) > 0 ) ; z2d(:,:) = 1._wp + ssh(:,:,Kmm)*tmask(:,:,1) / ht_0(:,:) 382 ELSEWHERE ; z2d(:,:) = 1._wp ; END WHERE 383 ! 384 DO jk = 1,jpkm1 ! adjust initial vertical scale factors 385 e3t(:,:,jk,Kmm) = e3t_0(:,:,jk) * z2d(:,:) 386 e3t(:,:,jk,Kbb) = e3t(:,:,jk,Kmm) 387 e3t(:,:,jk,Kaa) = e3t(:,:,jk,Kmm) 388 END DO 389 ! 390 ! Reconstruction of all vertical scale factors at now and before time-steps 391 ! ========================================================================= 392 ! Horizontal scale factor interpolations 393 ! -------------------------------------- 394 CALL dom_vvl_interpol( e3t(:,:,:,Kbb), e3u(:,:,:,Kbb), 'U' ) 395 CALL dom_vvl_interpol( e3t(:,:,:,Kbb), e3v(:,:,:,Kbb), 'V' ) 396 CALL dom_vvl_interpol( e3t(:,:,:,Kmm), e3u(:,:,:,Kmm), 'U' ) 397 CALL dom_vvl_interpol( e3t(:,:,:,Kmm), e3v(:,:,:,Kmm), 'V' ) 398 CALL dom_vvl_interpol( e3u(:,:,:,Kmm), e3f(:,:,:), 'F' ) 399 ! Vertical scale factor interpolations 400 ! ------------------------------------ 401 CALL dom_vvl_interpol( e3t(:,:,:,Kmm), e3w (:,:,:,Kmm), 'W' ) 402 CALL dom_vvl_interpol( e3u(:,:,:,Kmm), e3uw(:,:,:,Kmm), 'UW' ) 403 CALL dom_vvl_interpol( e3v(:,:,:,Kmm), e3vw(:,:,:,Kmm), 'VW' ) 404 CALL dom_vvl_interpol( e3u(:,:,:,Kbb), e3uw(:,:,:,Kbb), 'UW' ) 405 CALL dom_vvl_interpol( e3v(:,:,:,Kbb), e3vw(:,:,:,Kbb), 'VW' ) 406 ! t- and w- points depth 407 ! ---------------------- 408 !!gm not sure of that.... 409 gdept(:,:,1,Kmm) = 0.5_wp * e3w(:,:,1,Kmm) 410 gdepw(:,:,1,Kmm) = 0.0_wp 411 gde3w(:,:,1) = gdept(:,:,1,Kmm) - ssh(:,:,Kmm) 412 DO jk = 2, jpk 413 gdept(:,:,jk,Kmm) = gdept(:,:,jk-1,Kmm) + e3w(:,:,jk ,Kmm) 414 gdepw(:,:,jk,Kmm) = gdepw(:,:,jk-1,Kmm) + e3t(:,:,jk-1,Kmm) 415 gde3w(:,:,jk) = gdept(:,:,jk ,Kmm) - ssh (:,:,Kmm) 416 END DO 417 ENDIF 379 IF( .NOT.ln_linssh ) CALL dom_vvl_zgr( Kbb, Kmm, Kaa ) ! interpolation scale factor, depth and water column 380 ! !!st 381 ! IF( .NOT.ln_linssh ) THEN 382 ! ! 383 ! WHERE( ht_0(:,:) > 0 ) ; z2d(:,:) = 1._wp + ssh(:,:,Kmm)*tmask(:,:,1) / ht_0(:,:) 384 ! ELSEWHERE ; z2d(:,:) = 1._wp ; END WHERE 385 ! ! 386 ! DO jk = 1,jpkm1 ! adjust initial vertical scale factors 387 ! e3t(:,:,jk,Kmm) = e3t_0(:,:,jk) * z2d(:,:) 388 ! e3t(:,:,jk,Kbb) = e3t(:,:,jk,Kmm) 389 ! e3t(:,:,jk,Kaa) = e3t(:,:,jk,Kmm) 390 ! END DO 391 ! ! 392 ! ! Reconstruction of all vertical scale factors at now and before time-steps 393 ! ! ========================================================================= 394 ! ! Horizontal scale factor interpolations 395 ! ! -------------------------------------- 396 ! CALL dom_vvl_interpol( e3t(:,:,:,Kbb), e3u(:,:,:,Kbb), 'U' ) 397 ! CALL dom_vvl_interpol( e3t(:,:,:,Kbb), e3v(:,:,:,Kbb), 'V' ) 398 ! CALL dom_vvl_interpol( e3t(:,:,:,Kmm), e3u(:,:,:,Kmm), 'U' ) 399 ! CALL dom_vvl_interpol( e3t(:,:,:,Kmm), e3v(:,:,:,Kmm), 'V' ) 400 ! CALL dom_vvl_interpol( e3u(:,:,:,Kmm), e3f(:,:,:), 'F' ) 401 ! ! Vertical scale factor interpolations 402 ! ! ------------------------------------ 403 ! CALL dom_vvl_interpol( e3t(:,:,:,Kmm), e3w (:,:,:,Kmm), 'W' ) 404 ! CALL dom_vvl_interpol( e3u(:,:,:,Kmm), e3uw(:,:,:,Kmm), 'UW' ) 405 ! CALL dom_vvl_interpol( e3v(:,:,:,Kmm), e3vw(:,:,:,Kmm), 'VW' ) 406 ! CALL dom_vvl_interpol( e3u(:,:,:,Kbb), e3uw(:,:,:,Kbb), 'UW' ) 407 ! CALL dom_vvl_interpol( e3v(:,:,:,Kbb), e3vw(:,:,:,Kbb), 'VW' ) 408 ! ! t- and w- points depth 409 ! ! ---------------------- 410 ! !!gm not sure of that.... 411 ! gdept(:,:,1,Kmm) = 0.5_wp * e3w(:,:,1,Kmm) 412 ! gdepw(:,:,1,Kmm) = 0.0_wp 413 ! gde3w(:,:,1) = gdept(:,:,1,Kmm) - ssh(:,:,Kmm) 414 ! DO jk = 2, jpk 415 ! gdept(:,:,jk,Kmm) = gdept(:,:,jk-1,Kmm) + e3w(:,:,jk ,Kmm) 416 ! gdepw(:,:,jk,Kmm) = gdepw(:,:,jk-1,Kmm) + e3t(:,:,jk-1,Kmm) 417 ! gde3w(:,:,jk) = gdept(:,:,jk ,Kmm) - ssh (:,:,Kmm) 418 ! END DO 419 ! ENDIF 418 420 ENDIF 419 421 420 422 !------------------------------------ 421 423 ! 4) store fields at before time-step … … 432 434 v_ice_b(:,:) = v_ice(:,:) 433 435 ! total concentration is needed for Lupkes parameterizations 434 at_i_b (:,:) = at_i (:,:) 436 at_i_b (:,:) = at_i (:,:) 435 437 436 438 !!clem: output of initial state should be written here but it is impossible because 437 439 !! the ocean and ice are in the same file 438 !! CALL dia_wri_state( 'output.init' )440 !! CALL dia_wri_state( Kmm, 'output.init' ) 439 441 ! 440 442 END SUBROUTINE ice_istate … … 444 446 !!------------------------------------------------------------------- 445 447 !! *** ROUTINE ice_istate_init *** 446 !! 447 !! ** Purpose : Definition of initial state of the ice 448 !! 449 !! ** Method : Read the namini namelist and check the parameter 448 !! 449 !! ** Purpose : Definition of initial state of the ice 450 !! 451 !! ** Method : Read the namini namelist and check the parameter 450 452 !! values called at the first timestep (nit000) 451 453 !! … … 453 455 !! 454 456 !!----------------------------------------------------------------------------- 455 INTEGER :: ios ! Local integer output status for namelist read456 INTEGER :: ifpr, ierror 457 INTEGER :: ios, ifpr, ierror ! Local integers 458 457 459 ! 458 460 CHARACTER(len=256) :: cn_dir ! Root directory for location of ice files … … 488 490 WRITE(numout,*) ' max ocean temp. above Tfreeze with initial ice rn_thres_sst = ', rn_thres_sst 489 491 IF( ln_iceini .AND. .NOT.ln_iceini_file ) THEN 490 WRITE(numout,*) ' initial snw thickness in the north-south rn_hts_ini = ', rn_hts_ini_n,rn_hts_ini_s 492 WRITE(numout,*) ' initial snw thickness in the north-south rn_hts_ini = ', rn_hts_ini_n,rn_hts_ini_s 491 493 WRITE(numout,*) ' initial ice thickness in the north-south rn_hti_ini = ', rn_hti_ini_n,rn_hti_ini_s 492 494 WRITE(numout,*) ' initial ice concentr in the north-south rn_ati_ini = ', rn_ati_ini_n,rn_ati_ini_s -
NEMO/branches/2020/dev_r12527_Gurvan_ShallowWater/src/ICE/icerst.F90
r12377 r13151 80 80 ENDIF 81 81 ! 82 CALL iom_open( TRIM(clpath)//TRIM(clname), numriw, ldwrt = .TRUE., kdlev = jpl )82 CALL iom_open( TRIM(clpath)//TRIM(clname), numriw, ldwrt = .TRUE., kdlev = jpl, cdcomp = 'ICE' ) 83 83 lrst_ice = .TRUE. 84 84 ENDIF … … 185 185 ENDIF 186 186 187 CALL iom_open ( TRIM(cn_icerst_indir)//'/'//cn_icerst_in, numrir , kdlev = jpl)187 CALL iom_open ( TRIM(cn_icerst_indir)//'/'//cn_icerst_in, numrir ) 188 188 189 189 ! test if v_i exists -
NEMO/branches/2020/dev_r12527_Gurvan_ShallowWater/src/OCE/ASM/asminc.F90
r12489 r13151 9 9 !! ! 2007-04 (A. Weaver) Merge with OPAVAR/NEMOVAR 10 10 !! NEMO 3.3 ! 2010-05 (D. Lea) Update to work with NEMO v3.2 11 !! - ! 2010-05 (D. Lea) add calc_month_len routine based on day_init 11 !! - ! 2010-05 (D. Lea) add calc_month_len routine based on day_init 12 12 !! 3.4 ! 2012-10 (A. Weaver and K. Mogensen) Fix for direct initialization 13 13 !! ! 2014-09 (D. Lea) Local calc_date removed use routine from OBS … … 31 31 USE zpshde ! Partial step : Horizontal Derivative 32 32 USE asmpar ! Parameters for the assmilation interface 33 USE asmbkg ! 33 USE asmbkg ! 34 34 USE c1d ! 1D initialization 35 35 USE sbc_oce ! Surface boundary condition variables. … … 45 45 IMPLICIT NONE 46 46 PRIVATE 47 47 48 48 PUBLIC asm_inc_init !: Initialize the increment arrays and IAU weights 49 49 PUBLIC tra_asm_inc !: Apply the tracer (T and S) increments … … 72 72 REAL(wp), PUBLIC, DIMENSION(:,:,:), ALLOCATABLE :: u_bkg , v_bkg !: Background u- & v- velocity components 73 73 REAL(wp), PUBLIC, DIMENSION(:,:,:), ALLOCATABLE :: t_bkginc, s_bkginc !: Increment to the background T & S 74 REAL(wp), PUBLIC, DIMENSION(:,:,:), ALLOCATABLE :: u_bkginc, v_bkginc !: Increment to the u- & v-components 74 REAL(wp), PUBLIC, DIMENSION(:,:,:), ALLOCATABLE :: u_bkginc, v_bkginc !: Increment to the u- & v-components 75 75 REAL(wp), PUBLIC, DIMENSION(:) , ALLOCATABLE :: wgtiau !: IAU weights for each time step 76 76 #if defined key_asminc … … 80 80 INTEGER , PUBLIC :: nitbkg !: Time step of the background state used in the Jb term 81 81 INTEGER , PUBLIC :: nitdin !: Time step of the background state for direct initialization 82 INTEGER , PUBLIC :: nitiaustr !: Time step of the start of the IAU interval 82 INTEGER , PUBLIC :: nitiaustr !: Time step of the start of the IAU interval 83 83 INTEGER , PUBLIC :: nitiaufin !: Time step of the end of the IAU interval 84 ! 84 ! 85 85 INTEGER , PUBLIC :: niaufn !: Type of IAU weighing function: = 0 Constant weighting 86 ! !: = 1 Linear hat-like, centred in middle of IAU interval 86 ! !: = 1 Linear hat-like, centred in middle of IAU interval 87 87 REAL(wp), PUBLIC :: salfixmin !: Ensure that the salinity is larger than this value if (ln_salfix) 88 88 … … 95 95 !! * Substitutions 96 96 # include "do_loop_substitute.h90" 97 # include "domzgr_substitute.h90" 97 98 !!---------------------------------------------------------------------- 98 99 !! NEMO/OCE 4.0 , NEMO Consortium (2018) … … 105 106 !!---------------------------------------------------------------------- 106 107 !! *** ROUTINE asm_inc_init *** 107 !! 108 !! 108 109 !! ** Purpose : Initialize the assimilation increment and IAU weights. 109 110 !! 110 111 !! ** Method : Initialize the assimilation increment and IAU weights. 111 112 !! 112 !! ** Action : 113 !! ** Action : 113 114 !!---------------------------------------------------------------------- 114 115 INTEGER, INTENT(in) :: Kbb, Kmm, Krhs ! time level indices … … 262 263 ! 263 264 ! !--------------------------------------------------------- 264 IF( niaufn == 0 ) THEN ! Constant IAU forcing 265 IF( niaufn == 0 ) THEN ! Constant IAU forcing 265 266 ! !--------------------------------------------------------- 266 267 DO jt = 1, iiauper … … 268 269 END DO 269 270 ! !--------------------------------------------------------- 270 ELSEIF ( niaufn == 1 ) THEN ! Linear hat-like, centred in middle of IAU interval 271 ELSEIF ( niaufn == 1 ) THEN ! Linear hat-like, centred in middle of IAU interval 271 272 ! !--------------------------------------------------------- 272 273 ! Compute the normalization factor 273 274 znorm = 0._wp 274 275 IF( MOD( iiauper, 2 ) == 0 ) THEN ! Even number of time steps in IAU interval 275 imid = iiauper / 2 276 imid = iiauper / 2 276 277 DO jt = 1, imid 277 278 znorm = znorm + REAL( jt ) … … 279 280 znorm = 2.0 * znorm 280 281 ELSE ! Odd number of time steps in IAU interval 281 imid = ( iiauper + 1 ) / 2 282 imid = ( iiauper + 1 ) / 2 282 283 DO jt = 1, imid - 1 283 284 znorm = znorm + REAL( jt ) … … 306 307 DO jt = 1, icycper 307 308 ztotwgt = ztotwgt + wgtiau(jt) 308 WRITE(numout,*) ' ', jt, ' ', wgtiau(jt) 309 END DO 309 WRITE(numout,*) ' ', jt, ' ', wgtiau(jt) 310 END DO 310 311 WRITE(numout,*) ' ===================================' 311 312 WRITE(numout,*) ' Time-integrated weight = ', ztotwgt 312 313 WRITE(numout,*) ' ===================================' 313 314 ENDIF 314 315 315 316 ENDIF 316 317 … … 337 338 CALL iom_open( c_asminc, inum ) 338 339 ! 339 CALL iom_get( inum, 'time' , zdate_inc ) 340 CALL iom_get( inum, 'time' , zdate_inc ) 340 341 CALL iom_get( inum, 'z_inc_dateb', z_inc_dateb ) 341 342 CALL iom_get( inum, 'z_inc_datef', z_inc_datef ) … … 344 345 ! 345 346 IF(lwp) THEN 346 WRITE(numout,*) 347 WRITE(numout,*) 347 348 WRITE(numout,*) 'asm_inc_init : Assimilation increments valid between dates ', z_inc_dateb,' and ', z_inc_datef 348 349 WRITE(numout,*) '~~~~~~~~~~~~' … … 358 359 & ' not agree with Direct Initialization time' ) 359 360 360 IF ( ln_trainc ) THEN 361 IF ( ln_trainc ) THEN 361 362 CALL iom_get( inum, jpdom_autoglo, 'bckint', t_bkginc, 1 ) 362 363 CALL iom_get( inum, jpdom_autoglo, 'bckins', s_bkginc, 1 ) … … 370 371 ENDIF 371 372 372 IF ( ln_dyninc ) THEN 373 CALL iom_get( inum, jpdom_autoglo, 'bckinu', u_bkginc, 1 ) 374 CALL iom_get( inum, jpdom_autoglo, 'bckinv', v_bkginc, 1 ) 373 IF ( ln_dyninc ) THEN 374 CALL iom_get( inum, jpdom_autoglo, 'bckinu', u_bkginc, 1 ) 375 CALL iom_get( inum, jpdom_autoglo, 'bckinv', v_bkginc, 1 ) 375 376 ! Apply the masks 376 377 u_bkginc(:,:,:) = u_bkginc(:,:,:) * umask(:,:,:) … … 381 382 WHERE( ABS( v_bkginc(:,:,:) ) > 1.0e+10 ) v_bkginc(:,:,:) = 0.0 382 383 ENDIF 383 384 384 385 IF ( ln_sshinc ) THEN 385 386 CALL iom_get( inum, jpdom_autoglo, 'bckineta', ssh_bkginc, 1 ) … … 407 408 IF ( ln_dyninc .AND. nn_divdmp > 0 ) THEN ! Apply divergence damping filter 408 409 ! !-------------------------------------- 409 ALLOCATE( zhdiv(jpi,jpj) ) 410 ALLOCATE( zhdiv(jpi,jpj) ) 410 411 ! 411 412 DO jt = 1, nn_divdmp … … 417 418 & - e2u(ji-1,jj) * e3u(ji-1,jj,jk,Kmm) * u_bkginc(ji-1,jj,jk) & 418 419 & + e1v(ji,jj ) * e3v(ji,jj ,jk,Kmm) * v_bkginc(ji,jj ,jk) & 419 & - e1v(ji,jj-1) * e3v(ji,jj-1,jk,Kmm) * v_bkginc(ji,jj-1,jk) ) / e3t(ji,jj,jk,Kmm) 420 & - e1v(ji,jj-1) * e3v(ji,jj-1,jk,Kmm) * v_bkginc(ji,jj-1,jk) ) & 421 & / e3t(ji,jj,jk,Kmm) 420 422 END_2D 421 423 CALL lbc_lnk( 'asminc', zhdiv, 'T', 1. ) ! lateral boundary cond. (no sign change) … … 425 427 & + 0.2_wp * ( zhdiv(ji+1,jj) - zhdiv(ji ,jj) ) * r1_e1u(ji,jj) * umask(ji,jj,jk) 426 428 v_bkginc(ji,jj,jk) = v_bkginc(ji,jj,jk) & 427 & + 0.2_wp * ( zhdiv(ji,jj+1) - zhdiv(ji,jj ) ) * r1_e2v(ji,jj) * vmask(ji,jj,jk) 429 & + 0.2_wp * ( zhdiv(ji,jj+1) - zhdiv(ji,jj ) ) * r1_e2v(ji,jj) * vmask(ji,jj,jk) 428 430 END_2D 429 431 END DO … … 431 433 END DO 432 434 ! 433 DEALLOCATE( zhdiv ) 435 DEALLOCATE( zhdiv ) 434 436 ! 435 437 ENDIF … … 452 454 CALL iom_open( c_asmdin, inum ) 453 455 ! 454 CALL iom_get( inum, 'rdastp', zdate_bkg ) 456 CALL iom_get( inum, 'rdastp', zdate_bkg ) 455 457 ! 456 458 IF(lwp) THEN 457 WRITE(numout,*) 459 WRITE(numout,*) 458 460 WRITE(numout,*) ' ==>>> Assimilation background state valid at : ', zdate_bkg 459 461 WRITE(numout,*) … … 464 466 & ' not agree with Direct Initialization time' ) 465 467 ! 466 IF ( ln_trainc ) THEN 468 IF ( ln_trainc ) THEN 467 469 CALL iom_get( inum, jpdom_autoglo, 'tn', t_bkg ) 468 470 CALL iom_get( inum, jpdom_autoglo, 'sn', s_bkg ) … … 471 473 ENDIF 472 474 ! 473 IF ( ln_dyninc ) THEN 475 IF ( ln_dyninc ) THEN 474 476 CALL iom_get( inum, jpdom_autoglo, 'un', u_bkg ) 475 477 CALL iom_get( inum, jpdom_autoglo, 'vn', v_bkg ) … … 499 501 ! 500 502 END SUBROUTINE asm_inc_init 501 502 503 504 503 505 SUBROUTINE tra_asm_inc( kt, Kbb, Kmm, pts, Krhs ) 504 506 !!---------------------------------------------------------------------- 505 507 !! *** ROUTINE tra_asm_inc *** 506 !! 508 !! 507 509 !! ** Purpose : Apply the tracer (T and S) assimilation increments 508 510 !! 509 511 !! ** Method : Direct initialization or Incremental Analysis Updating 510 512 !! 511 !! ** Action : 513 !! ** Action : 512 514 !!---------------------------------------------------------------------- 513 515 INTEGER , INTENT(in ) :: kt ! Current time step … … 521 523 !!---------------------------------------------------------------------- 522 524 ! 523 ! freezing point calculation taken from oc_fz_pt (but calculated for all depths) 524 ! used to prevent the applied increments taking the temperature below the local freezing point 525 ! freezing point calculation taken from oc_fz_pt (but calculated for all depths) 526 ! used to prevent the applied increments taking the temperature below the local freezing point 525 527 DO jk = 1, jpkm1 526 528 CALL eos_fzp( pts(:,:,jk,jp_sal,Kmm), fzptnz(:,:,jk), gdept(:,:,jk,Kmm) ) … … 537 539 ! 538 540 IF(lwp) THEN 539 WRITE(numout,*) 541 WRITE(numout,*) 540 542 WRITE(numout,*) 'tra_asm_inc : Tracer IAU at time step = ', kt,' with IAU weight = ', wgtiau(it) 541 543 WRITE(numout,*) '~~~~~~~~~~~~' … … 547 549 ! Do not apply negative increments if the temperature will fall below freezing 548 550 WHERE(t_bkginc(:,:,jk) > 0.0_wp .OR. & 549 & pts(:,:,jk,jp_tem,Kmm) + pts(:,:,jk,jp_tem,Krhs) + t_bkginc(:,:,jk) * wgtiau(it) > fzptnz(:,:,jk) ) 550 pts(:,:,jk,jp_tem,Krhs) = pts(:,:,jk,jp_tem,Krhs) + t_bkginc(:,:,jk) * zincwgt 551 & pts(:,:,jk,jp_tem,Kmm) + pts(:,:,jk,jp_tem,Krhs) + t_bkginc(:,:,jk) * wgtiau(it) > fzptnz(:,:,jk) ) 552 pts(:,:,jk,jp_tem,Krhs) = pts(:,:,jk,jp_tem,Krhs) + t_bkginc(:,:,jk) * zincwgt 551 553 END WHERE 552 554 ELSE 553 pts(:,:,jk,jp_tem,Krhs) = pts(:,:,jk,jp_tem,Krhs) + t_bkginc(:,:,jk) * zincwgt 555 pts(:,:,jk,jp_tem,Krhs) = pts(:,:,jk,jp_tem,Krhs) + t_bkginc(:,:,jk) * zincwgt 554 556 ENDIF 555 557 IF (ln_salfix) THEN … … 557 559 ! minimum value salfixmin 558 560 WHERE(s_bkginc(:,:,jk) > 0.0_wp .OR. & 559 & pts(:,:,jk,jp_sal,Kmm) + pts(:,:,jk,jp_sal,Krhs) + s_bkginc(:,:,jk) * wgtiau(it) > salfixmin ) 561 & pts(:,:,jk,jp_sal,Kmm) + pts(:,:,jk,jp_sal,Krhs) + s_bkginc(:,:,jk) * wgtiau(it) > salfixmin ) 560 562 pts(:,:,jk,jp_sal,Krhs) = pts(:,:,jk,jp_sal,Krhs) + s_bkginc(:,:,jk) * zincwgt 561 563 END WHERE … … 574 576 ELSEIF ( ln_asmdin ) THEN ! Direct Initialization 575 577 ! !-------------------------------------- 576 ! 578 ! 577 579 IF ( kt == nitdin_r ) THEN 578 580 ! … … 582 584 IF (ln_temnofreeze) THEN 583 585 ! Do not apply negative increments if the temperature will fall below freezing 584 WHERE( t_bkginc(:,:,:) > 0.0_wp .OR. pts(:,:,:,jp_tem,Kmm) + t_bkginc(:,:,:) > fzptnz(:,:,:) ) 585 pts(:,:,:,jp_tem,Kmm) = t_bkg(:,:,:) + t_bkginc(:,:,:) 586 WHERE( t_bkginc(:,:,:) > 0.0_wp .OR. pts(:,:,:,jp_tem,Kmm) + t_bkginc(:,:,:) > fzptnz(:,:,:) ) 587 pts(:,:,:,jp_tem,Kmm) = t_bkg(:,:,:) + t_bkginc(:,:,:) 586 588 END WHERE 587 589 ELSE 588 pts(:,:,:,jp_tem,Kmm) = t_bkg(:,:,:) + t_bkginc(:,:,:) 590 pts(:,:,:,jp_tem,Kmm) = t_bkg(:,:,:) + t_bkginc(:,:,:) 589 591 ENDIF 590 592 IF (ln_salfix) THEN 591 593 ! Do not apply negative increments if the salinity will fall below a specified 592 594 ! minimum value salfixmin 593 WHERE( s_bkginc(:,:,:) > 0.0_wp .OR. pts(:,:,:,jp_sal,Kmm) + s_bkginc(:,:,:) > salfixmin ) 594 pts(:,:,:,jp_sal,Kmm) = s_bkg(:,:,:) + s_bkginc(:,:,:) 595 WHERE( s_bkginc(:,:,:) > 0.0_wp .OR. pts(:,:,:,jp_sal,Kmm) + s_bkginc(:,:,:) > salfixmin ) 596 pts(:,:,:,jp_sal,Kmm) = s_bkg(:,:,:) + s_bkginc(:,:,:) 595 597 END WHERE 596 598 ELSE 597 pts(:,:,:,jp_sal,Kmm) = s_bkg(:,:,:) + s_bkginc(:,:,:) 599 pts(:,:,:,jp_sal,Kmm) = s_bkg(:,:,:) + s_bkginc(:,:,:) 598 600 ENDIF 599 601 … … 617 619 DEALLOCATE( s_bkg ) 618 620 ENDIF 619 ! 621 ! 620 622 ENDIF 621 623 ! Perhaps the following call should be in step … … 628 630 !!---------------------------------------------------------------------- 629 631 !! *** ROUTINE dyn_asm_inc *** 630 !! 632 !! 631 633 !! ** Purpose : Apply the dynamics (u and v) assimilation increments. 632 634 !! 633 635 !! ** Method : Direct initialization or Incremental Analysis Updating. 634 636 !! 635 !! ** Action : 637 !! ** Action : 636 638 !!---------------------------------------------------------------------- 637 639 INTEGER , INTENT( in ) :: kt ! ocean time-step index … … 654 656 ! 655 657 IF(lwp) THEN 656 WRITE(numout,*) 658 WRITE(numout,*) 657 659 WRITE(numout,*) 'dyn_asm_inc : Dynamics IAU at time step = ', kt,' with IAU weight = ', wgtiau(it) 658 660 WRITE(numout,*) '~~~~~~~~~~~~' … … 674 676 ELSEIF ( ln_asmdin ) THEN ! Direct Initialization 675 677 ! !----------------------------------------- 676 ! 678 ! 677 679 IF ( kt == nitdin_r ) THEN 678 680 ! … … 681 683 ! Initialize the now fields with the background + increment 682 684 puu(:,:,:,Kmm) = u_bkg(:,:,:) + u_bkginc(:,:,:) 683 pvv(:,:,:,Kmm) = v_bkg(:,:,:) + v_bkginc(:,:,:) 685 pvv(:,:,:,Kmm) = v_bkg(:,:,:) + v_bkginc(:,:,:) 684 686 ! 685 687 puu(:,:,:,Kbb) = puu(:,:,:,Kmm) ! Update before fields … … 700 702 !!---------------------------------------------------------------------- 701 703 !! *** ROUTINE ssh_asm_inc *** 702 !! 704 !! 703 705 !! ** Purpose : Apply the sea surface height assimilation increment. 704 706 !! 705 707 !! ** Method : Direct initialization or Incremental Analysis Updating. 706 708 !! 707 !! ** Action : 709 !! ** Action : 708 710 !!---------------------------------------------------------------------- 709 711 INTEGER, INTENT(IN) :: kt ! Current time step … … 725 727 ! 726 728 IF(lwp) THEN 727 WRITE(numout,*) 729 WRITE(numout,*) 728 730 WRITE(numout,*) 'ssh_asm_inc : SSH IAU at time step = ', & 729 731 & kt,' with IAU weight = ', wgtiau(it) … … 758 760 ! 759 761 ssh(:,:,Kbb) = ssh(:,:,Kmm) ! Update before fields 762 #if ! defined key_qco 760 763 e3t(:,:,:,Kbb) = e3t(:,:,:,Kmm) 764 #endif 761 765 !!gm why not e3u(:,:,:,Kbb), e3v(:,:,:,Kbb), gdept(:,:,:,Kbb) ???? 762 766 ! … … 775 779 !! *** ROUTINE ssh_asm_div *** 776 780 !! 777 !! ** Purpose : ssh increment with z* is incorporated via a correction of the local divergence 781 !! ** Purpose : ssh increment with z* is incorporated via a correction of the local divergence 778 782 !! across all the water column 779 783 !! … … 791 795 REAL(wp), DIMENSION(:,:) , POINTER :: ztim ! local array 792 796 !!---------------------------------------------------------------------- 793 ! 797 ! 794 798 #if defined key_asminc 795 799 CALL ssh_asm_inc( kt, Kbb, Kmm ) !== (calculate increments) 796 800 ! 797 IF( ln_linssh ) THEN 801 IF( ln_linssh ) THEN 798 802 phdivn(:,:,1) = phdivn(:,:,1) - ssh_iau(:,:) / e3t(:,:,1,Kmm) * tmask(:,:,1) 799 ELSE 803 ELSE 800 804 ALLOCATE( ztim(jpi,jpj) ) 801 805 ztim(:,:) = ssh_iau(:,:) / ( ht(:,:) + 1.0 - ssmask(:,:) ) 802 DO jk = 1, jpkm1 803 phdivn(:,:,jk) = phdivn(:,:,jk) - ztim(:,:) * tmask(:,:,jk) 806 DO jk = 1, jpkm1 807 phdivn(:,:,jk) = phdivn(:,:,jk) - ztim(:,:) * tmask(:,:,jk) 804 808 END DO 805 809 ! … … 814 818 !!---------------------------------------------------------------------- 815 819 !! *** ROUTINE seaice_asm_inc *** 816 !! 820 !! 817 821 !! ** Purpose : Apply the sea ice assimilation increment. 818 822 !! 819 823 !! ** Method : Direct initialization or Incremental Analysis Updating. 820 824 !! 821 !! ** Action : 825 !! ** Action : 822 826 !! 823 827 !!---------------------------------------------------------------------- … … 840 844 ! 841 845 it = kt - nit000 + 1 842 zincwgt = wgtiau(it) ! IAU weight for the current time step 846 zincwgt = wgtiau(it) ! IAU weight for the current time step 843 847 ! note this is not a tendency so should not be divided by rn_Dt (as with the tracer and other increments) 844 848 ! 845 849 IF(lwp) THEN 846 WRITE(numout,*) 850 WRITE(numout,*) 847 851 WRITE(numout,*) 'seaice_asm_inc : sea ice conc IAU at time step = ', kt,' with IAU weight = ', wgtiau(it) 848 852 WRITE(numout,*) '~~~~~~~~~~~~' … … 862 866 ! 863 867 ! Nudge sea ice depth to bring it up to a required minimum depth 864 WHERE( zseaicendg(:,:) > 0.0_wp .AND. hm_i(:,:) < zhicifmin ) 865 zhicifinc(:,:) = (zhicifmin - hm_i(:,:)) * zincwgt 868 WHERE( zseaicendg(:,:) > 0.0_wp .AND. hm_i(:,:) < zhicifmin ) 869 zhicifinc(:,:) = (zhicifmin - hm_i(:,:)) * zincwgt 866 870 ELSEWHERE 867 871 zhicifinc(:,:) = 0.0_wp … … 896 900 IF ( kt == nitdin_r ) THEN 897 901 ! 902 <<<<<<< .working 898 903 l_1st_euler = 0 ! Force Euler forward step 904 ======= 905 l_1st_euler = .TRUE. ! Force Euler forward step 906 >>>>>>> .merge-right.r13092 899 907 ! 900 908 ! Sea-ice : SI3 case … … 903 911 zofrld (:,:) = 1._wp - at_i(:,:) 904 912 zohicif(:,:) = hm_i(:,:) 905 ! 913 ! 906 914 ! Initialize the now fields the background + increment 907 915 at_i(:,:) = 1. - MIN( MAX( 1.-at_i(:,:) - seaice_bkginc(:,:), 0.0_wp), 1.0_wp) 908 at_i_b(:,:) = at_i(:,:) 916 at_i_b(:,:) = at_i(:,:) 909 917 fr_i(:,:) = at_i(:,:) ! adjust ice fraction 910 918 ! … … 912 920 ! 913 921 ! Nudge sea ice depth to bring it up to a required minimum depth 914 WHERE( zseaicendg(:,:) > 0.0_wp .AND. hm_i(:,:) < zhicifmin ) 922 WHERE( zseaicendg(:,:) > 0.0_wp .AND. hm_i(:,:) < zhicifmin ) 915 923 zhicifinc(:,:) = zhicifmin - hm_i(:,:) 916 924 ELSEWHERE … … 942 950 !#if defined defined key_si3 || defined key_cice 943 951 ! 944 ! IF (ln_seaicebal ) THEN 952 ! IF (ln_seaicebal ) THEN 945 953 ! !! balancing salinity increments 946 954 ! !! simple case from limflx.F90 (doesn't include a mass flux) … … 954 962 ! 955 963 ! DO jj = 1, jpj 956 ! DO ji = 1, jpi 964 ! DO ji = 1, jpi 957 965 ! ! calculate change in ice and snow mass per unit area 958 966 ! ! positive values imply adding salt to the ocean (results from ice formation) … … 965 973 ! 966 974 ! ! prevent small mld 967 ! ! less than 10m can cause salinity instability 975 ! ! less than 10m can cause salinity instability 968 976 ! IF (mld < 10) mld=10 969 977 ! 970 ! ! set to bottom of a level 978 ! ! set to bottom of a level 971 979 ! DO jk = jpk-1, 2, -1 972 ! IF ((mld > gdepw(ji,jj,jk )) .and. (mld < gdepw(ji,jj,jk+1))) THEN973 ! mld=gdepw(ji,jj,jk+1 )980 ! IF ((mld > gdepw(ji,jj,jk,Kmm)) .and. (mld < gdepw(ji,jj,jk+1,Kmm))) THEN 981 ! mld=gdepw(ji,jj,jk+1,Kmm) 974 982 ! jkmax=jk 975 983 ! ENDIF … … 977 985 ! 978 986 ! ! avoid applying salinity balancing in shallow water or on land 979 ! ! 987 ! ! 980 988 ! 981 989 ! ! dsal_ocn (psu kg m^-2) / (kg m^-3 * m) … … 988 996 ! 989 997 ! ! put increments in for levels in the mixed layer 990 ! ! but prevent salinity below a threshold value 991 ! 992 ! DO jk = 1, jkmax 993 ! 994 ! IF (dsal_ocn > 0.0_wp .or. sb(ji,jj,jk)+dsal_ocn > sal_thresh) THEN 998 ! ! but prevent salinity below a threshold value 999 ! 1000 ! DO jk = 1, jkmax 1001 ! 1002 ! IF (dsal_ocn > 0.0_wp .or. sb(ji,jj,jk)+dsal_ocn > sal_thresh) THEN 995 1003 ! sb(ji,jj,jk) = sb(ji,jj,jk) + dsal_ocn 996 1004 ! sn(ji,jj,jk) = sn(ji,jj,jk) + dsal_ocn … … 1003 1011 ! ! 1004 1012 ! !! Adjust fsalt. A +ve fsalt means adding salt to ocean 1005 ! !! fsalt(ji,jj) = fsalt(ji,jj) + zpmess ! adjust fsalt 1006 ! !! 1007 ! !! emps(ji,jj) = emps(ji,jj) + zpmess ! or adjust emps (see icestp1d) 1013 ! !! fsalt(ji,jj) = fsalt(ji,jj) + zpmess ! adjust fsalt 1014 ! !! 1015 ! !! emps(ji,jj) = emps(ji,jj) + zpmess ! or adjust emps (see icestp1d) 1008 1016 ! !! ! E-P (kg m-2 s-2) 1009 1017 ! ! emp(ji,jj) = emp(ji,jj) + zpmess ! E-P (kg m-2 s-2) … … 1018 1026 ! 1019 1027 END SUBROUTINE seaice_asm_inc 1020 1028 1021 1029 !!====================================================================== 1022 1030 END MODULE asminc -
NEMO/branches/2020/dev_r12527_Gurvan_ShallowWater/src/OCE/BDY/bdydta.F90
r12396 r13151 70 70 !! * Substitutions 71 71 # include "do_loop_substitute.h90" 72 # include "domzgr_substitute.h90" 72 73 !!---------------------------------------------------------------------- 73 74 !! NEMO/OCE 4.0 , NEMO Consortium (2018) … … 92 93 INTEGER :: ii, ij, ik, igrd, ipl ! local integers 93 94 INTEGER, DIMENSION(jpbgrd) :: ilen1 94 INTEGER, DIMENSION(:), POINTER :: nblen, nblenrim ! short cuts95 95 TYPE(OBC_DATA) , POINTER :: dta_alias ! short cut 96 96 TYPE(FLD), DIMENSION(:), POINTER :: bf_alias … … 108 108 DO jbdy = 1, nb_bdy 109 109 ! 110 nblen => idx_bdy(jbdy)%nblen111 nblenrim => idx_bdy(jbdy)%nblenrim112 !113 110 IF( nn_dyn2d_dta(jbdy) == 0 ) THEN 114 ilen1(:) = nblen(:)115 111 IF( dta_bdy(jbdy)%lneed_ssh ) THEN 116 112 igrd = 1 117 DO ib = 1, i len1(igrd)113 DO ib = 1, idx_bdy(jbdy)%nblenrim(igrd) ! ssh is allocated and used only on the rim 118 114 ii = idx_bdy(jbdy)%nbi(ib,igrd) 119 115 ij = idx_bdy(jbdy)%nbj(ib,igrd) … … 121 117 END DO 122 118 ENDIF 123 IF( dta_bdy(jbdy)%lneed_dyn2d ) THEN119 IF( dta_bdy(jbdy)%lneed_dyn2d .AND. ASSOCIATED(dta_bdy(jbdy)%u2d) ) THEN ! no SIZE with a unassociated pointer 124 120 igrd = 2 125 DO ib = 1, ilen1(igrd)121 DO ib = 1, SIZE(dta_bdy(jbdy)%u2d) ! u2d is used only on the rim except if ln_full_vel = T, see bdy_dta_init 126 122 ii = idx_bdy(jbdy)%nbi(ib,igrd) 127 123 ij = idx_bdy(jbdy)%nbj(ib,igrd) … … 129 125 END DO 130 126 igrd = 3 131 DO ib = 1, ilen1(igrd)127 DO ib = 1, SIZE(dta_bdy(jbdy)%v2d) ! v2d is used only on the rim except if ln_full_vel = T, see bdy_dta_init 132 128 ii = idx_bdy(jbdy)%nbi(ib,igrd) 133 129 ij = idx_bdy(jbdy)%nbj(ib,igrd) … … 138 134 ! 139 135 IF( nn_dyn3d_dta(jbdy) == 0 ) THEN 140 ilen1(:) = nblen(:)141 136 IF( dta_bdy(jbdy)%lneed_dyn3d ) THEN 142 137 igrd = 2 143 DO ib = 1, i len1(igrd)138 DO ib = 1, idx_bdy(jbdy)%nblen(igrd) 144 139 DO ik = 1, jpkm1 145 140 ii = idx_bdy(jbdy)%nbi(ib,igrd) … … 149 144 END DO 150 145 igrd = 3 151 DO ib = 1, i len1(igrd)146 DO ib = 1, idx_bdy(jbdy)%nblen(igrd) 152 147 DO ik = 1, jpkm1 153 148 ii = idx_bdy(jbdy)%nbi(ib,igrd) … … 160 155 161 156 IF( nn_tra_dta(jbdy) == 0 ) THEN 162 ilen1(:) = nblen(:)163 157 IF( dta_bdy(jbdy)%lneed_tra ) THEN 164 158 igrd = 1 165 DO ib = 1, i len1(igrd)159 DO ib = 1, idx_bdy(jbdy)%nblen(igrd) 166 160 DO ik = 1, jpkm1 167 161 ii = idx_bdy(jbdy)%nbi(ib,igrd) … … 176 170 #if defined key_si3 177 171 IF( nn_ice_dta(jbdy) == 0 ) THEN ! set ice to initial values 178 ilen1(:) = nblen(:)179 172 IF( dta_bdy(jbdy)%lneed_ice ) THEN 180 173 igrd = 1 181 174 DO jl = 1, jpl 182 DO ib = 1, i len1(igrd)175 DO ib = 1, idx_bdy(jbdy)%nblen(igrd) 183 176 ii = idx_bdy(jbdy)%nbi(ib,igrd) 184 177 ij = idx_bdy(jbdy)%nbj(ib,igrd) … … 236 229 ! tidal harmonic forcing ONLY: initialise arrays 237 230 IF( nn_dyn2d_dta(jbdy) == 2 ) THEN ! we did not read ssh, u/v2d 238 IF( dta_alias%lneed_ssh ) dta_alias%ssh(:) = 0._wp239 IF( dta_alias%lneed_dyn2d ) dta_alias%u2d(:) = 0._wp240 IF( dta_alias%lneed_dyn2d ) dta_alias%v2d(:) = 0._wp231 IF( dta_alias%lneed_ssh .AND. ASSOCIATED(dta_alias%ssh) ) dta_alias%ssh(:) = 0._wp 232 IF( dta_alias%lneed_dyn2d .AND. ASSOCIATED(dta_alias%u2d) ) dta_alias%u2d(:) = 0._wp 233 IF( dta_alias%lneed_dyn2d .AND. ASSOCIATED(dta_alias%v2d) ) dta_alias%v2d(:) = 0._wp 241 234 ENDIF 242 235 … … 245 238 ! 246 239 igrd = 2 ! zonal velocity 247 dta_alias%u2d(:) = 0._wp ! compute barotrope zonal velocity and put it in u2d248 240 DO ib = 1, idx_bdy(jbdy)%nblen(igrd) 249 241 ii = idx_bdy(jbdy)%nbi(ib,igrd) 250 242 ij = idx_bdy(jbdy)%nbj(ib,igrd) 243 dta_alias%u2d(ib) = 0._wp ! compute barotrope zonal velocity and put it in u2d 251 244 DO ik = 1, jpkm1 252 dta_alias%u2d(ib) = dta_alias%u2d(ib) + e3u(ii,ij,ik,Kmm) * umask(ii,ij,ik) * dta_alias%u3d(ib,ik) 245 dta_alias%u2d(ib) = dta_alias%u2d(ib) & 246 & + e3u(ii,ij,ik,Kmm) * umask(ii,ij,ik) * dta_alias%u3d(ib,ik) 253 247 END DO 254 248 dta_alias%u2d(ib) = dta_alias%u2d(ib) * r1_hu(ii,ij,Kmm) … … 258 252 END DO 259 253 igrd = 3 ! meridional velocity 260 dta_alias%v2d(:) = 0._wp ! compute barotrope meridional velocity and put it in v2d261 254 DO ib = 1, idx_bdy(jbdy)%nblen(igrd) 262 255 ii = idx_bdy(jbdy)%nbi(ib,igrd) 263 256 ij = idx_bdy(jbdy)%nbj(ib,igrd) 257 dta_alias%v2d(ib) = 0._wp ! compute barotrope meridional velocity and put it in v2d 264 258 DO ik = 1, jpkm1 265 dta_alias%v2d(ib) = dta_alias%v2d(ib) + e3v(ii,ij,ik,Kmm) * vmask(ii,ij,ik) * dta_alias%v3d(ib,ik) 259 dta_alias%v2d(ib) = dta_alias%v2d(ib) & 260 & + e3v(ii,ij,ik,Kmm) * vmask(ii,ij,ik) * dta_alias%v3d(ib,ik) 266 261 END DO 267 262 dta_alias%v2d(ib) = dta_alias%v2d(ib) * r1_hv(ii,ij,Kmm) … … 283 278 284 279 #if defined key_si3 285 IF( dta_alias%lneed_ice ) THEN280 IF( dta_alias%lneed_ice .AND. idx_bdy(jbdy)%nblen(1) > 0 ) THEN 286 281 ! fill temperature and salinity arrays 287 282 IF( TRIM(bf_alias(jp_bdyt_i)%clrootname) == 'NOT USED' ) bf_alias(jp_bdyt_i)%fnow(:,1,:) = rice_tem (jbdy) … … 338 333 DO jbdy = 1, nb_bdy ! Tidal component added in ts loop 339 334 IF ( nn_dyn2d_dta(jbdy) .GE. 2 ) THEN 340 nblen => idx_bdy(jbdy)%nblen 341 nblenrim => idx_bdy(jbdy)%nblenrim 342 IF( cn_dyn2d(jbdy) == 'frs' ) THEN ; ilen1(:)=nblen(:) 343 ELSE ; ilen1(:)=nblenrim(:) 335 IF( cn_dyn2d(jbdy) == 'frs' ) THEN ; ilen1(:)=idx_bdy(jbdy)%nblen(:) 336 ELSE ; ilen1(:)=idx_bdy(jbdy)%nblenrim(:) 344 337 ENDIF 345 338 IF ( dta_bdy(jbdy)%lneed_ssh ) dta_bdy_s(jbdy)%ssh(1:ilen1(1)) = dta_bdy(jbdy)%ssh(1:ilen1(1)) -
NEMO/branches/2020/dev_r12527_Gurvan_ShallowWater/src/OCE/BDY/bdydyn.F90
r12377 r13151 29 29 30 30 PUBLIC bdy_dyn ! routine called in dyn_nxt 31 31 32 !! * Substitutions 33 # include "domzgr_substitute.h90" 32 34 !!---------------------------------------------------------------------- 33 35 !! NEMO/OCE 4.0 , NEMO Consortium (2018) -
NEMO/branches/2020/dev_r12527_Gurvan_ShallowWater/src/OCE/C1D/step_c1d.F90
r12377 r13151 83 83 IF(.NOT.ln_linssh ) CALL dom_vvl_sf_nxt( kstp, Nbb, Nnn, Naa ) ! after vertical scale factors 84 84 85 IF(.NOT.ln_linssh ) CALL wzv ( kstp, Nbb, Nnn, ww, Naa) ! now cross-level velocity85 IF(.NOT.ln_linssh ) CALL wzv ( kstp, Nbb, Nnn, Naa, ww ) ! now cross-level velocity 86 86 !>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>> 87 87 ! diagnostics and outputs -
NEMO/branches/2020/dev_r12527_Gurvan_ShallowWater/src/OCE/CRS/crsfld.F90
r12377 r13151 33 33 !! * Substitutions 34 34 # include "do_loop_substitute.h90" 35 # include "domzgr_substitute.h90" 35 36 !!---------------------------------------------------------------------- 36 37 !! NEMO/OCE 4.0 , NEMO Consortium (2018) … … 68 69 69 70 ! Depth work arrrays 70 ze3t(:,:,:) = e3t(:,:,:,Kmm) 71 ze3u(:,:,:) = e3u(:,:,:,Kmm) 72 ze3v(:,:,:) = e3v(:,:,:,Kmm) 73 ze3w(:,:,:) = e3w(:,:,:,Kmm) 71 DO jk = 1 , jpk 72 ze3t(:,:,jk) = e3t(:,:,jk,Kmm) 73 ze3u(:,:,jk) = e3u(:,:,jk,Kmm) 74 ze3v(:,:,jk) = e3v(:,:,jk,Kmm) 75 ze3w(:,:,jk) = e3w(:,:,jk,Kmm) 76 END DO 74 77 75 78 IF( kt == nit000 ) THEN -
NEMO/branches/2020/dev_r12527_Gurvan_ShallowWater/src/OCE/CRS/crsini.F90
r12377 r13151 28 28 PUBLIC crs_init ! called by nemogcm.F90 module 29 29 30 !! * Substitutions 31 # include "domzgr_substitute.h90" 30 32 !!---------------------------------------------------------------------- 31 33 !! NEMO/OCE 4.0 , NEMO Consortium (2018) … … 174 176 175 177 ! 176 ze3t(:,:,:) = e3t(:,:,:,Kmm) 177 ze3u(:,:,:) = e3u(:,:,:,Kmm) 178 ze3v(:,:,:) = e3v(:,:,:,Kmm) 179 ze3w(:,:,:) = e3w(:,:,:,Kmm) 178 DO jk = 1, jpk 179 ze3t(:,:,jk) = e3t(:,:,jk,Kmm) 180 ze3u(:,:,jk) = e3u(:,:,jk,Kmm) 181 ze3v(:,:,jk) = e3v(:,:,jk,Kmm) 182 ze3w(:,:,jk) = e3w(:,:,jk,Kmm) 183 END DO 180 184 181 185 ! 3.d.2 Surfaces -
NEMO/branches/2020/dev_r12527_Gurvan_ShallowWater/src/OCE/DIA/diaar5.F90
r12489 r13151 32 32 REAL(wp) :: vol0 ! ocean volume (interior domain) 33 33 REAL(wp) :: area_tot ! total ocean surface (interior domain) 34 REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,: ) :: area ! cell surface (interior domain)35 34 REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,: ) :: thick0 ! ocean thickness (interior domain) 36 35 REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: sn0 ! initial salinity … … 40 39 !! * Substitutions 41 40 # include "do_loop_substitute.h90" 41 # include "domzgr_substitute.h90" 42 42 !!---------------------------------------------------------------------- 43 43 !! NEMO/OCE 4.0 , NEMO Consortium (2018) … … 54 54 !!---------------------------------------------------------------------- 55 55 ! 56 ALLOCATE( area(jpi,jpj),thick0(jpi,jpj) , sn0(jpi,jpj,jpk) , STAT=dia_ar5_alloc )56 ALLOCATE( thick0(jpi,jpj) , sn0(jpi,jpj,jpk) , STAT=dia_ar5_alloc ) 57 57 ! 58 58 CALL mpp_sum ( 'diaar5', dia_ar5_alloc ) … … 77 77 ! 78 78 REAL(wp), ALLOCATABLE, DIMENSION(:,:) :: zarea_ssh , zbotpres ! 2D workspace 79 REAL(wp), ALLOCATABLE, DIMENSION(:,:) :: z pe, z2d! 2D workspace80 REAL(wp), ALLOCATABLE, DIMENSION(:,:,:) :: z rhd , zrhop, ztpot ! 3D workspace79 REAL(wp), ALLOCATABLE, DIMENSION(:,:) :: z2d, zpe ! 2D workspace 80 REAL(wp), ALLOCATABLE, DIMENSION(:,:,:) :: z3d, zrhd , zrhop, ztpot, zgdept ! 3D workspace (zgdept: needed to use the substitute) 81 81 REAL(wp), ALLOCATABLE, DIMENSION(:,:,:,:) :: ztsn ! 4D workspace 82 82 … … 90 90 ALLOCATE( zrhd(jpi,jpj,jpk) , zrhop(jpi,jpj,jpk) ) 91 91 ALLOCATE( ztsn(jpi,jpj,jpk,jpts) ) 92 zarea_ssh(:,:) = area(:,:) * ssh(:,:,Kmm)93 ENDIF 94 ! 95 CALL iom_put( 'e2u' , e2u (:,:) )96 CALL iom_put( 'e1v' , e1v (:,:) )97 CALL iom_put( 'areacello', area(:,:) )92 zarea_ssh(:,:) = e1e2t(:,:) * ssh(:,:,Kmm) 93 ENDIF 94 ! 95 CALL iom_put( 'e2u' , e2u (:,:) ) 96 CALL iom_put( 'e1v' , e1v (:,:) ) 97 CALL iom_put( 'areacello', e1e2t(:,:) ) 98 98 ! 99 99 IF( iom_use( 'volcello' ) .OR. iom_use( 'masscello' ) ) THEN 100 100 zrhd(:,:,jpk) = 0._wp ! ocean volume ; rhd is used as workspace 101 101 DO jk = 1, jpkm1 102 zrhd(:,:,jk) = area(:,:) * e3t(:,:,jk,Kmm) * tmask(:,:,jk)102 zrhd(:,:,jk) = e1e2t(:,:) * e3t(:,:,jk,Kmm) * tmask(:,:,jk) 103 103 END DO 104 DO jk = 1, jpk 105 z3d(:,:,jk) = rho0 * e3t(:,:,jk,Kmm) * tmask(:,:,jk) 106 END DO 104 107 CALL iom_put( 'volcello' , zrhd(:,:,:) ) ! WARNING not consistent with CMIP DR where volcello is at ca. 2000 105 CALL iom_put( 'masscello' , rho0 * e3t(:,:,:,Kmm) * tmask(:,:,:) )! ocean mass108 CALL iom_put( 'masscello' , z3d (:,:,:) ) ! ocean mass 106 109 ENDIF 107 110 ! … … 129 132 ztsn(:,:,:,jp_tem) = ts(:,:,:,jp_tem,Kmm) ! thermosteric ssh 130 133 ztsn(:,:,:,jp_sal) = sn0(:,:,:) 131 CALL eos( ztsn, zrhd, gdept(:,:,:,Kmm) ) ! now in situ density using initial salinity 134 DO jk = 1, jpk 135 zgdept(:,:,jk) = gdept(:,:,jk,Kmm) 136 END DO 137 CALL eos( ztsn, zrhd, zgdept) ! now in situ density using initial salinity 132 138 ! 133 139 zbotpres(:,:) = 0._wp ! no atmospheric surface pressure, levitating sea-ice … … 151 157 END IF 152 158 ! 153 zarho = glob_sum( 'diaar5', area(:,:) * zbotpres(:,:) )159 zarho = glob_sum( 'diaar5', e1e2t(:,:) * zbotpres(:,:) ) 154 160 zssh_steric = - zarho / area_tot 155 161 CALL iom_put( 'sshthster', zssh_steric ) 156 162 157 163 ! ! steric sea surface height 158 CALL eos( ts(:,:,:,:,Kmm), zrhd, zrhop, gdept(:,:,:,Kmm)) ! now in situ and potential density164 CALL eos( ts(:,:,:,:,Kmm), zrhd, zrhop, zgdept ) ! now in situ and potential density 159 165 zrhop(:,:,jpk) = 0._wp 160 166 CALL iom_put( 'rhop', zrhop ) … … 177 183 END IF 178 184 ! 179 zarho = glob_sum( 'diaar5', area(:,:) * zbotpres(:,:) )185 zarho = glob_sum( 'diaar5', e1e2t(:,:) * zbotpres(:,:) ) 180 186 zssh_steric = - zarho / area_tot 181 187 CALL iom_put( 'sshsteric', zssh_steric ) … … 191 197 ztsn(:,:,:,:) = 0._wp ! ztsn(:,:,1,jp_tem/sal) is used here as 2D Workspace for temperature & salinity 192 198 DO_3D_11_11( 1, jpkm1 ) 193 zztmp = area(ji,jj) * e3t(ji,jj,jk,Kmm)199 zztmp = e1e2t(ji,jj) * e3t(ji,jj,jk,Kmm) 194 200 ztsn(ji,jj,1,jp_tem) = ztsn(ji,jj,1,jp_tem) + zztmp * ts(ji,jj,jk,jp_tem,Kmm) 195 201 ztsn(ji,jj,1,jp_sal) = ztsn(ji,jj,1,jp_sal) + zztmp * ts(ji,jj,jk,jp_sal,Kmm) … … 237 243 z2d(:,:) = 0._wp 238 244 DO jk = 1, jpkm1 239 z2d(:,:) = z2d(:,:) + area(:,:) * e3t(:,:,jk,Kmm) * ztpot(:,:,jk)245 z2d(:,:) = z2d(:,:) + e1e2t(:,:) * e3t(:,:,jk,Kmm) * ztpot(:,:,jk) 240 246 END DO 241 247 ztemp = glob_sum( 'diaar5', z2d(:,:) ) … … 244 250 ! 245 251 IF( iom_use( 'ssttot' ) ) THEN ! Output potential temperature in case we use TEOS-10 246 zsst = glob_sum( 'diaar5', area(:,:) * ztpot(:,:,1) )252 zsst = glob_sum( 'diaar5', e1e2t(:,:) * ztpot(:,:,1) ) 247 253 CALL iom_put( 'ssttot', zsst / area_tot ) 248 254 ENDIF … … 259 265 ELSE 260 266 IF( iom_use('ssttot') ) THEN ! Output sst in case we use EOS-80 261 zsst = glob_sum( 'diaar5', area(:,:) * ts(:,:,1,jp_tem,Kmm) )267 zsst = glob_sum( 'diaar5', e1e2t(:,:) * ts(:,:,1,jp_tem,Kmm) ) 262 268 CALL iom_put('ssttot', zsst / area_tot ) 263 269 ENDIF … … 375 381 IF( dia_ar5_alloc() /= 0 ) CALL ctl_stop( 'STOP', 'dia_ar5_init : unable to allocate arrays' ) 376 382 377 area(:,:) = e1e2t(:,:) 378 area_tot = glob_sum( 'diaar5', area(:,:) ) 383 area_tot = glob_sum( 'diaar5', e1e2t(:,:) ) 379 384 380 385 ALLOCATE( zvol0(jpi,jpj) ) … … 383 388 DO_3D_11_11( 1, jpkm1 ) 384 389 idep = tmask(ji,jj,jk) * e3t_0(ji,jj,jk) 385 zvol0 (ji,jj) = zvol0 (ji,jj) + idep * area(ji,jj)390 zvol0 (ji,jj) = zvol0 (ji,jj) + idep * e1e2t(ji,jj) 386 391 thick0(ji,jj) = thick0(ji,jj) + idep 387 392 END_3D -
NEMO/branches/2020/dev_r12527_Gurvan_ShallowWater/src/OCE/DIA/diacfl.F90
r12489 r13151 34 34 !! * Substitutions 35 35 # include "do_loop_substitute.h90" 36 # include "domzgr_substitute.h90" 36 37 !!---------------------------------------------------------------------- 37 38 !! NEMO/OCE 4.0 , NEMO Consortium (2018) -
NEMO/branches/2020/dev_r12527_Gurvan_ShallowWater/src/OCE/DIA/diadct.F90
r12489 r13151 11 11 !! 3.4 ! 09/2011 (C Bricaud) 12 12 !!---------------------------------------------------------------------- 13 !! does not work with agrif 14 #if ! defined key_agrif13 #if ! defined key_agrif 14 !! ==>> CAUTION: does not work with agrif 15 15 !!---------------------------------------------------------------------- 16 16 !! dia_dct : Compute the transport through a sec. … … 66 66 TYPE SECTION 67 67 CHARACTER(len=60) :: name ! name of the sec 68 LOGICAL :: llstrpond ! true if you want the computation of salt and 69 ! heat transports 68 LOGICAL :: llstrpond ! true if you want the computation of salt and heat transports 70 69 LOGICAL :: ll_ice_section ! ice surface and ice volume computation 71 70 LOGICAL :: ll_date_line ! = T if the section crosses the date-line … … 74 73 INTEGER, DIMENSION(nb_point_max) :: direction ! vector direction of the point in the section 75 74 CHARACTER(len=40),DIMENSION(nb_class_max) :: classname ! characteristics of the class 76 REAL(wp), DIMENSION(nb_class_max) :: zsigi ,&! in-situ density classes (99 if you don't want)77 zsigp ,&! potential density classes (99 if you don't want)78 zsal ,&! salinity classes (99 if you don't want)79 ztem ,&! temperature classes(99 if you don't want)80 75 REAL(wp), DIMENSION(nb_class_max) :: zsigi ! in-situ density classes (99 if you don't want) 76 REAL(wp), DIMENSION(nb_class_max) :: zsigp ! potential density classes (99 if you don't want) 77 REAL(wp), DIMENSION(nb_class_max) :: zsal ! salinity classes (99 if you don't want) 78 REAL(wp), DIMENSION(nb_class_max) :: ztem ! temperature classes(99 if you don't want) 79 REAL(wp), DIMENSION(nb_class_max) :: zlay ! level classes (99 if you don't want) 81 80 REAL(wp), DIMENSION(nb_type_class,nb_class_max) :: transport ! transport output 82 81 REAL(wp) :: slopeSection ! slope of the section … … 90 89 REAL(wp), ALLOCATABLE, DIMENSION(:,:,:) :: transports_2d 91 90 91 92 !! * Substitutions 93 # include "domzgr_substitute.h90" 92 94 !!---------------------------------------------------------------------- 93 95 !! NEMO/OCE 4.0 , NEMO Consortium (2018) … … 95 97 !! Software governed by the CeCILL license (see ./LICENSE) 96 98 !!---------------------------------------------------------------------- 99 97 100 CONTAINS 98 101 … … 1119 1122 !! | | | interpolation between ptab(I,J,K) and ptab(I,J,K+1) 1120 1123 !! | | | zbis = 1121 !! | | | [ e3w (I+1,J,K)*ptab(I,J,K) + ( e3w(I,J,K) - e3w(I+1,J,K) ) * ptab(I,J,K-1) ]1122 !! | | | /[ e3w(I+1,J,K) + e3w(I,J,K) - e3w(I+1,J,K) ]1124 !! | | | [ e3w_n(I+1,J,K,NOW)*ptab(I,J,K) + ( e3w_n(I,J,K,NOW) - e3w_n(I+1,J,K,NOW) ) * ptab(I,J,K-1) ] 1125 !! | | | /[ e3w_n(I+1,J,K,NOW) + e3w_n(I,J,K,NOW) - e3w_n(I+1,J,K,NOW) ] 1123 1126 !! | | | 1124 1127 !! | | | 2. Horizontal interpolation: compute value at U/V point … … 1212 1215 ELSE ! full step or partial step case 1213 1216 1214 ze3t = e3t(ii2,ij2,kk,Kmm) - e3t(ii1,ij1,kk,Kmm) 1215 zwgt1 = ( e3w(ii2,ij2,kk,Kmm) - e3w(ii1,ij1,kk,Kmm) ) / e3w(ii2,ij2,kk,Kmm) 1216 zwgt2 = ( e3w(ii1,ij1,kk,Kmm) - e3w(ii2,ij2,kk,Kmm) ) / e3w(ii1,ij1,kk,Kmm) 1217 ze3t = e3t(ii2,ij2,kk,Kmm) - e3t(ii1,ij1,kk,Kmm) 1218 zwgt1 = ( e3w(ii2,ij2,kk,Kmm) - e3w(ii1,ij1,kk,Kmm) ) & 1219 & / e3w(ii2,ij2,kk,Kmm) 1220 zwgt2 = ( e3w(ii1,ij1,kk,Kmm) - e3w(ii2,ij2,kk,Kmm) ) & 1221 & / e3w(ii1,ij1,kk,Kmm) 1217 1222 1218 1223 IF(kk .NE. 1)THEN -
NEMO/branches/2020/dev_r12527_Gurvan_ShallowWater/src/OCE/DIA/diahsb.F90
r12489 r13151 50 50 REAL(wp), DIMENSION(:,:,:), ALLOCATABLE :: tmask_ini 51 51 52 !! * Substitutions 53 # include "domzgr_substitute.h90" 52 54 !!---------------------------------------------------------------------- 53 55 !! NEMO/OCE 4.0 , NEMO Consortium (2018) … … 156 158 ! 157 159 DO jk = 1, jpkm1 ! volume variation (calculated with scale factors) 158 zwrk(:,:,jk) = surf(:,:)*e3t(:,:,jk,Kmm)*tmask(:,:,jk) - surf_ini(:,:)*e3t_ini(:,:,jk)*tmask_ini(:,:,jk) 160 zwrk(:,:,jk) = surf (:,:) * e3t (:,:,jk,Kmm)*tmask (:,:,jk) & 161 & - surf_ini(:,:) * e3t_ini(:,:,jk )*tmask_ini(:,:,jk) 159 162 END DO 160 163 zdiff_v2 = glob_sum_full( 'diahsb', zwrk(:,:,:) ) ! glob_sum_full needed as tmask and tmask_ini could be different 161 164 DO jk = 1, jpkm1 ! heat content variation 162 zwrk(:,:,jk) = ( surf(:,:)*e3t(:,:,jk,Kmm)*ts(:,:,jk,jp_tem,Kmm) - surf_ini(:,:)*hc_loc_ini(:,:,jk) ) 165 zwrk(:,:,jk) = ( surf (:,:) * e3t(:,:,jk,Kmm)*ts(:,:,jk,jp_tem,Kmm) & 166 & - surf_ini(:,:) * hc_loc_ini(:,:,jk) ) 163 167 END DO 164 168 zdiff_hc = glob_sum_full( 'diahsb', zwrk(:,:,:) ) 165 169 DO jk = 1, jpkm1 ! salt content variation 166 zwrk(:,:,jk) = ( surf(:,:)*e3t(:,:,jk,Kmm)*ts(:,:,jk,jp_sal,Kmm) - surf_ini(:,:)*sc_loc_ini(:,:,jk) ) 170 zwrk(:,:,jk) = ( surf (:,:) * e3t(:,:,jk,Kmm)*ts(:,:,jk,jp_sal,Kmm) & 171 & - surf_ini(:,:) * sc_loc_ini(:,:,jk) ) 167 172 END DO 168 173 zdiff_sc = glob_sum_full( 'diahsb', zwrk(:,:,:) ) … … 287 292 DO jk = 1, jpk 288 293 ! if ice sheet/oceqn coupling, need to mask ini variables here (mask could change at the next NEMO instance). 289 e3t_ini (:,:,jk) = e3t(:,:,jk,Kmm) *tmask(:,:,jk) ! initial vertical scale factors294 e3t_ini (:,:,jk) = e3t(:,:,jk,Kmm)*tmask(:,:,jk) ! initial vertical scale factors 290 295 tmask_ini (:,:,jk) = tmask(:,:,jk) ! initial mask 291 hc_loc_ini(:,:,jk) = ts(:,:,jk,jp_tem,Kmm) * e3t(:,:,jk,Kmm) *tmask(:,:,jk) ! initial heat content292 sc_loc_ini(:,:,jk) = ts(:,:,jk,jp_sal,Kmm) * e3t(:,:,jk,Kmm) *tmask(:,:,jk) ! initial salt content296 hc_loc_ini(:,:,jk) = ts(:,:,jk,jp_tem,Kmm)*e3t(:,:,jk,Kmm)*tmask(:,:,jk) ! initial heat content 297 sc_loc_ini(:,:,jk) = ts(:,:,jk,jp_sal,Kmm)*e3t(:,:,jk,Kmm)*tmask(:,:,jk) ! initial salt content 293 298 END DO 294 299 frc_v = 0._wp ! volume trend due to forcing -
NEMO/branches/2020/dev_r12527_Gurvan_ShallowWater/src/OCE/DIA/diahth.F90
r12489 r13151 42 42 !! * Substitutions 43 43 # include "do_loop_substitute.h90" 44 # include "domzgr_substitute.h90" 44 45 !!---------------------------------------------------------------------- 45 46 !! NEMO/OCE 4.0 , NEMO Consortium (2018) … … 361 362 ik = ilevel(ji,jj) 362 363 zthick(ji,jj) = pdep - zthick(ji,jj) ! remaining thickness to reach depht pdep 363 phtc(ji,jj) = phtc(ji,jj) + pt(ji,jj,ik+1) * MIN( e3t(ji,jj,ik+1,Kmm), zthick(ji,jj) ) & 364 phtc(ji,jj) = phtc(ji,jj) & 365 & + pt (ji,jj,ik+1) * MIN( e3t(ji,jj,ik+1,Kmm), zthick(ji,jj) ) & 364 366 * tmask(ji,jj,ik+1) 365 367 END_2D -
NEMO/branches/2020/dev_r12527_Gurvan_ShallowWater/src/OCE/DIA/diamlr.F90
r12377 r13151 4 4 !! Management of the IOM context for multiple-linear-regression analysis 5 5 !!====================================================================== 6 !! History : ! 2019 (S. Mueller)6 !! History : 4.0 ! 2019 (S. Mueller) Original code 7 7 !!---------------------------------------------------------------------- 8 8 9 9 USE par_oce , ONLY : wp, jpi, jpj 10 10 USE phycst , ONLY : rpi 11 USE dom_oce , ONLY : adatrj 12 USE tide_mod 13 ! 11 14 USE in_out_manager , ONLY : lwp, numout, ln_timing 12 15 USE iom , ONLY : iom_put, iom_use, iom_update_file_name 13 USE dom_oce , ONLY : adatrj14 16 USE timing , ONLY : timing_start, timing_stop 15 17 #if defined key_iomput 16 18 USE xios 17 19 #endif 18 USE tide_mod19 20 20 21 IMPLICIT NONE 21 22 PRIVATE 22 23 23 LOGICAL, PUBLIC :: lk_diamlr = .FALSE. 24 LOGICAL, PUBLIC :: lk_diamlr = .FALSE. !: ===>>> NOT a DOCTOR norm name : use l_diamlr 25 ! lk_ is used only for logical controlled by a CPP key 24 26 25 27 PUBLIC :: dia_mlr_init, dia_mlr_iom_init, dia_mlr … … 33 35 !!---------------------------------------------------------------------- 34 36 CONTAINS 35 37 36 38 SUBROUTINE dia_mlr_init 37 39 !!---------------------------------------------------------------------- 38 40 !! *** ROUTINE dia_mlr_init *** 39 41 !! 40 !! ** Purpose : initialisation of IOM context management for 42 !! ** Purpose : initialisation of IOM context management for 41 43 !! multiple-linear-regression analysis 42 44 !! 43 45 !!---------------------------------------------------------------------- 44 46 ! 45 47 lk_diamlr = .TRUE. 46 48 ! 47 49 IF(lwp) THEN 48 50 WRITE(numout, *) … … 50 52 WRITE(numout, *) '~~~~~~~~~~~~ multiple-linear-regression analysis' 51 53 END IF 52 54 ! 53 55 END SUBROUTINE dia_mlr_init 56 54 57 55 58 SUBROUTINE dia_mlr_iom_init … … 84 87 INTEGER :: itide ! Number of available tidal components 85 88 REAL(wp) :: ztide_phase ! Tidal-constituent phase at adatrj=0 86 CHARACTER (LEN=4), DIMENSION(jpmax_harmo) :: ctide_selected = ' 89 CHARACTER (LEN=4), DIMENSION(jpmax_harmo) :: ctide_selected = 'n/a ' 87 90 TYPE(tide_harmonic), DIMENSION(:), POINTER :: stideconst 88 91 … … 145 148 ! Retrieve information (frequency, phase, nodal correction) about all 146 149 ! available tidal constituents for placeholder substitution below 147 ctide_selected(1:34) = (/ 'Mf', 'Mm', 'Ssa', 'Mtm', 'Msf', & 148 & 'Msqm', 'Sa', 'K1', 'O1', 'P1', & 149 & 'Q1', 'J1', 'S1', 'M2', 'S2', 'N2', & 150 & 'K2', 'nu2', 'mu2', '2N2', 'L2', & 151 & 'T2', 'eps2', 'lam2', 'R2', 'M3', & 152 & 'MKS2', 'MN4', 'MS4', 'M4', 'N4', & 153 & 'S4', 'M6', 'M8' /) 150 ! Warning: we must use the same character length in an array constructor (at least for gcc compiler) 151 ctide_selected(1:34) = (/ 'Mf ', 'Mm ', 'Ssa ', 'Mtm ', 'Msf ', & 152 & 'Msqm', 'Sa ', 'K1 ', 'O1 ', 'P1 ', & 153 & 'Q1 ', 'J1 ', 'S1 ', 'M2 ', 'S2 ', 'N2 ', & 154 & 'K2 ', 'nu2 ', 'mu2 ', '2N2 ', 'L2 ', & 155 & 'T2 ', 'eps2', 'lam2', 'R2 ', 'M3 ', & 156 & 'MKS2', 'MN4 ', 'MS4 ', 'M4 ', 'N4 ', & 157 & 'S4 ', 'M6 ', 'M8 ' /) 154 158 CALL tide_init_harmonics(ctide_selected, stideconst) 155 159 itide = size(stideconst) … … 157 161 itide = 0 158 162 ENDIF 159 163 160 164 DO jm = 1, jpscanmax 161 165 WRITE (cl3i, '(i3.3)') jm … … 236 240 ! If enabled, keep handle in list of fields selected for analysis 237 241 IF ( llxatt_enabled ) THEN 238 242 239 243 ! Set name attribute (and overwrite possible pre-configured name) 240 244 ! with field id to enable id string retrieval from stored handle … … 323 327 CALL xios_set_attr ( slxhdl_fld, standard_name=TRIM( clxatt_comment ), long_name=TRIM( clxatt_expr ), & 324 328 & operation="average" ) 325 329 326 330 ! iii) set up the output of scalar products with itself and with 327 331 ! other active regressors … … 396 400 END SUBROUTINE dia_mlr_iom_init 397 401 402 398 403 SUBROUTINE dia_mlr 399 404 !!---------------------------------------------------------------------- … … 403 408 !! 404 409 !!---------------------------------------------------------------------- 405 406 410 REAL(wp), DIMENSION(jpi,jpj) :: zadatrj2d 411 !!---------------------------------------------------------------------- 407 412 408 413 IF( ln_timing ) CALL timing_start('dia_mlr') … … 411 416 ! (value of adatrj converted to time in units of seconds) 412 417 ! 413 ! A 2-dimensional field of constant value is sent, and subsequently used 414 ! directly or transformed to a scalar or a constant 3-dimensional field as 415 ! required. 418 ! A 2-dimensional field of constant value is sent, and subsequently used directly 419 ! or transformed to a scalar or a constant 3-dimensional field as required. 416 420 zadatrj2d(:,:) = adatrj*86400.0_wp 417 421 IF ( iom_use('diamlr_time') ) CALL iom_put('diamlr_time', zadatrj2d) 418 422 ! 419 423 IF( ln_timing ) CALL timing_stop('dia_mlr') 420 424 ! 421 425 END SUBROUTINE dia_mlr 422 426 427 !!====================================================================== 423 428 END MODULE diamlr -
NEMO/branches/2020/dev_r12527_Gurvan_ShallowWater/src/OCE/DIA/diaptr.F90
r12489 r13151 60 60 61 61 LOGICAL :: ll_init = .TRUE. !: tracers trend flag (set from namelist in trdini) 62 62 63 !! * Substitutions 63 64 # include "do_loop_substitute.h90" 65 # include "domzgr_substitute.h90" 64 66 !!---------------------------------------------------------------------- 65 67 !! NEMO/OCE 4.0 , NEMO Consortium (2018) -
NEMO/branches/2020/dev_r12527_Gurvan_ShallowWater/src/OCE/DIA/diawri.F90
r12493 r13151 85 85 !! * Substitutions 86 86 # include "do_loop_substitute.h90" 87 # include "domzgr_substitute.h90" 87 88 !!---------------------------------------------------------------------- 88 89 !! NEMO/OCE 4.0 , NEMO Consortium (2018) … … 136 137 CALL iom_put("e3v_0", e3v_0(:,:,:) ) 137 138 ! 138 CALL iom_put( "e3t" , e3t(:,:,:,Kmm) ) 139 CALL iom_put( "e3u" , e3u(:,:,:,Kmm) ) 140 CALL iom_put( "e3v" , e3v(:,:,:,Kmm) ) 141 CALL iom_put( "e3w" , e3w(:,:,:,Kmm) ) 142 IF( iom_use("e3tdef") ) & 143 CALL iom_put( "e3tdef" , ( ( e3t(:,:,:,Kmm) - e3t_0(:,:,:) ) / e3t_0(:,:,:) * 100 * tmask(:,:,:) ) ** 2 ) 144 145 IF( ll_wd ) THEN 146 CALL iom_put( "ssh" , (ssh(:,:,Kmm)+ssh_ref)*tmask(:,:,1) ) ! sea surface height (brought back to the reference used for wetting and drying) 139 IF ( iom_use("e3t") .OR. iom_use("e3tdef") ) THEN ! time-varying e3t 140 DO jk = 1, jpk 141 z3d(:,:,jk) = e3t(:,:,jk,Kmm) 142 END DO 143 CALL iom_put( "e3t" , z3d(:,:,:) ) 144 CALL iom_put( "e3tdef" , ( ( z3d(:,:,:) - e3t_0(:,:,:) ) / e3t_0(:,:,:) * 100 * tmask(:,:,:) ) ** 2 ) 145 ENDIF 146 IF ( iom_use("e3u") ) THEN ! time-varying e3u 147 DO jk = 1, jpk 148 z3d(:,:,jk) = e3u(:,:,jk,Kmm) 149 END DO 150 CALL iom_put( "e3u" , z3d(:,:,:) ) 151 ENDIF 152 IF ( iom_use("e3v") ) THEN ! time-varying e3v 153 DO jk = 1, jpk 154 z3d(:,:,jk) = e3v(:,:,jk,Kmm) 155 END DO 156 CALL iom_put( "e3v" , z3d(:,:,:) ) 157 ENDIF 158 IF ( iom_use("e3w") ) THEN ! time-varying e3w 159 DO jk = 1, jpk 160 z3d(:,:,jk) = e3w(:,:,jk,Kmm) 161 END DO 162 CALL iom_put( "e3w" , z3d(:,:,:) ) 163 ENDIF 164 165 IF( ll_wd ) THEN ! sea surface height (brought back to the reference used for wetting and drying) 166 CALL iom_put( "ssh" , (ssh(:,:,Kmm)+ssh_ref)*tmask(:,:,1) ) 147 167 ELSE 148 168 CALL iom_put( "ssh" , ssh(:,:,Kmm) ) ! sea surface height … … 208 228 209 229 IF( ln_zad_Aimp ) ww = ww + wi ! Recombine explicit and implicit parts of vertical velocity for diagnostic output 210 !211 230 CALL iom_put( "woce", ww ) ! vertical velocity 231 212 232 IF( iom_use('w_masstr') .OR. iom_use('w_masstr2') ) THEN ! vertical mass transport & its square value 213 233 ! Caution: in the VVL case, it only correponds to the baroclinic mass transport. … … 415 435 ! 416 436 REAL(wp), DIMENSION(jpi,jpj) :: zw2d ! 2D workspace 417 REAL(wp), DIMENSION(jpi,jpj,jpk) :: zw3d ! 3D workspace437 REAL(wp), DIMENSION(jpi,jpj,jpk) :: zw3d, ze3t, zgdept ! 3D workspace 418 438 REAL(wp), DIMENSION(:,:,:), ALLOCATABLE :: zw3d_abl ! ABL 3D workspace 419 439 !!---------------------------------------------------------------------- … … 455 475 it = kt 456 476 itmod = kt - nit000 + 1 477 478 ! store e3t for subsitute 479 DO jk = 1, jpk 480 ze3t (:,:,jk) = e3t (:,:,jk,Kmm) 481 zgdept(:,:,jk) = gdept(:,:,jk,Kmm) 482 END DO 457 483 458 484 … … 569 595 DEALLOCATE(zw3d_abl) 570 596 ENDIF 597 ! 571 598 572 599 ! Declare all the output fields as NETCDF variables … … 578 605 & jpi, jpj, nh_T, ipk, 1, ipk, nz_T, 32, clop, zsto, zout ) 579 606 IF( .NOT.ln_linssh ) THEN 580 CALL histdef( nid_T, "vovvle3t", "Level thickness" , "m" ,& ! e3t (:,:,:,Kmm)607 CALL histdef( nid_T, "vovvle3t", "Level thickness" , "m" ,& ! e3t n 581 608 & jpi, jpj, nh_T, ipk, 1, ipk, nz_T, 32, clop, zsto, zout ) 582 CALL histdef( nid_T, "vovvldep", "T point depth" , "m" ,& ! e3t (:,:,:,Kmm)609 CALL histdef( nid_T, "vovvldep", "T point depth" , "m" ,& ! e3t n 583 610 & jpi, jpj, nh_T, ipk, 1, ipk, nz_T, 32, clop, zsto, zout ) 584 CALL histdef( nid_T, "vovvldef", "Squared level deformation" , "%^2" ,& ! e3t (:,:,:,Kmm)611 CALL histdef( nid_T, "vovvldef", "Squared level deformation" , "%^2" ,& ! e3t n 585 612 & jpi, jpj, nh_T, ipk, 1, ipk, nz_T, 32, clop, zsto, zout ) 586 613 ENDIF … … 766 793 767 794 IF( .NOT.ln_linssh ) THEN 768 CALL histwrite( nid_T, "votemper", it, ts(:,:,:,jp_tem,Kmm) * e3t(:,:,:,Kmm) , ndim_T , ndex_T ) ! heat content769 CALL histwrite( nid_T, "vosaline", it, ts(:,:,:,jp_sal,Kmm) * e3t(:,:,:,Kmm) , ndim_T , ndex_T ) ! salt content770 CALL histwrite( nid_T, "sosstsst", it, ts(:,:,1,jp_tem,Kmm) * e3t(:,:,1,Kmm) , ndim_hT, ndex_hT ) ! sea surface heat content771 CALL histwrite( nid_T, "sosaline", it, ts(:,:,1,jp_sal,Kmm) * e3t(:,:,1,Kmm) , ndim_hT, ndex_hT ) ! sea surface salinity content795 CALL histwrite( nid_T, "votemper", it, ts(:,:,:,jp_tem,Kmm) * ze3t(:,:,:) , ndim_T , ndex_T ) ! heat content 796 CALL histwrite( nid_T, "vosaline", it, ts(:,:,:,jp_sal,Kmm) * ze3t(:,:,:) , ndim_T , ndex_T ) ! salt content 797 CALL histwrite( nid_T, "sosstsst", it, ts(:,:,1,jp_tem,Kmm) * ze3t(:,:,1) , ndim_hT, ndex_hT ) ! sea surface heat content 798 CALL histwrite( nid_T, "sosaline", it, ts(:,:,1,jp_sal,Kmm) * ze3t(:,:,1) , ndim_hT, ndex_hT ) ! sea surface salinity content 772 799 ELSE 773 800 CALL histwrite( nid_T, "votemper", it, ts(:,:,:,jp_tem,Kmm) , ndim_T , ndex_T ) ! temperature … … 777 804 ENDIF 778 805 IF( .NOT.ln_linssh ) THEN 779 zw3d(:,:,:) = ( ( e3t(:,:,:,Kmm) - e3t_0(:,:,:) ) / e3t_0(:,:,:) * 100 * tmask(:,:,:) ) ** 2780 CALL histwrite( nid_T, "vovvle3t", it, e3t (:,:,:,Kmm), ndim_T , ndex_T ) ! level thickness781 CALL histwrite( nid_T, "vovvldep", it, gdept(:,:,:,Kmm) , ndim_T , ndex_T ) ! t-point depth806 zw3d(:,:,:) = ( ( ze3t(:,:,:) - e3t_0(:,:,:) ) / e3t_0(:,:,:) * 100 * tmask(:,:,:) ) ** 2 807 CALL histwrite( nid_T, "vovvle3t", it, ze3t (:,:,:) , ndim_T , ndex_T ) ! level thickness 808 CALL histwrite( nid_T, "vovvldep", it, zgdept , ndim_T , ndex_T ) ! t-point depth 782 809 CALL histwrite( nid_T, "vovvldef", it, zw3d , ndim_T , ndex_T ) ! level thickness deformation 783 810 ENDIF … … 918 945 !! 919 946 INTEGER :: inum, jk 947 REAL(wp), DIMENSION(jpi,jpj,jpk) :: ze3t, zgdept ! 3D workspace !!st patch to use substitution 920 948 !!---------------------------------------------------------------------- 921 949 ! 922 IF(lwp) WRITE(numout,*) 923 IF(lwp) WRITE(numout,*) 'dia_wri_state : single instantaneous ocean state' 924 IF(lwp) WRITE(numout,*) '~~~~~~~~~~~~~ and forcing fields file created ' 925 IF(lwp) WRITE(numout,*) ' and named :', cdfile_name, '...nc' 926 927 #if defined key_si3 928 CALL iom_open( TRIM(cdfile_name), inum, ldwrt = .TRUE., kdlev = jpl ) 929 #else 930 CALL iom_open( TRIM(cdfile_name), inum, ldwrt = .TRUE. ) 931 #endif 932 950 IF(lwp) THEN 951 WRITE(numout,*) 952 WRITE(numout,*) 'dia_wri_state : single instantaneous ocean state' 953 WRITE(numout,*) '~~~~~~~~~~~~~ and forcing fields file created ' 954 WRITE(numout,*) ' and named :', cdfile_name, '...nc' 955 ENDIF 956 ! 957 DO jk = 1, jpk 958 ze3t(:,:,jk) = e3t(:,:,jk,Kmm) 959 zgdept(:,:,jk) = gdept(:,:,jk,Kmm) 960 END DO 961 ! 962 CALL iom_open( TRIM(cdfile_name), inum, ldwrt = .TRUE. ) 963 ! 933 964 CALL iom_rstput( 0, 0, inum, 'votemper', ts(:,:,:,jp_tem,Kmm) ) ! now temperature 934 965 CALL iom_rstput( 0, 0, inum, 'vosaline', ts(:,:,:,jp_sal,Kmm) ) ! now salinity 935 CALL iom_rstput( 0, 0, inum, 'sossheig', ssh(:,: ,Kmm)) ! sea surface height936 CALL iom_rstput( 0, 0, inum, 'vozocrtx', uu(:,:,: ,Kmm)) ! now i-velocity937 CALL iom_rstput( 0, 0, inum, 'vomecrty', vv(:,:,: ,Kmm)) ! now j-velocity966 CALL iom_rstput( 0, 0, inum, 'sossheig', ssh(:,: ,Kmm) ) ! sea surface height 967 CALL iom_rstput( 0, 0, inum, 'vozocrtx', uu(:,:,: ,Kmm) ) ! now i-velocity 968 CALL iom_rstput( 0, 0, inum, 'vomecrty', vv(:,:,: ,Kmm) ) ! now j-velocity 938 969 IF( ln_zad_Aimp ) THEN 939 970 CALL iom_rstput( 0, 0, inum, 'vovecrtz', ww + wi ) ! now k-velocity … … 942 973 ENDIF 943 974 CALL iom_rstput( 0, 0, inum, 'risfdep', risfdep ) ! now k-velocity 944 CALL iom_rstput( 0, 0, inum, 'ht' , ht 945 975 CALL iom_rstput( 0, 0, inum, 'ht' , ht(:,:) ) ! now water column height 976 ! 946 977 IF ( ln_isf ) THEN 947 978 IF (ln_isfcav_mlt) THEN … … 949 980 CALL iom_rstput( 0, 0, inum, 'rhisf_cav_tbl', rhisf_tbl_cav ) ! now k-velocity 950 981 CALL iom_rstput( 0, 0, inum, 'rfrac_cav_tbl', rfrac_tbl_cav ) ! now k-velocity 951 CALL iom_rstput( 0, 0, inum, 'misfkb_cav', REAL(misfkb_cav, 8)) ! now k-velocity952 CALL iom_rstput( 0, 0, inum, 'misfkt_cav', REAL(misfkt_cav, 8)) ! now k-velocity953 CALL iom_rstput( 0, 0, inum, 'mskisf_cav', REAL(mskisf_cav, 8), ktype = jp_i1 )982 CALL iom_rstput( 0, 0, inum, 'misfkb_cav', REAL(misfkb_cav,wp) ) ! now k-velocity 983 CALL iom_rstput( 0, 0, inum, 'misfkt_cav', REAL(misfkt_cav,wp) ) ! now k-velocity 984 CALL iom_rstput( 0, 0, inum, 'mskisf_cav', REAL(mskisf_cav,wp), ktype = jp_i1 ) 954 985 END IF 955 986 IF (ln_isfpar_mlt) THEN 956 CALL iom_rstput( 0, 0, inum, 'isfmsk_par', REAL(mskisf_par, 8)) ! now k-velocity987 CALL iom_rstput( 0, 0, inum, 'isfmsk_par', REAL(mskisf_par,wp) ) ! now k-velocity 957 988 CALL iom_rstput( 0, 0, inum, 'fwfisf_par', fwfisf_par ) ! now k-velocity 958 989 CALL iom_rstput( 0, 0, inum, 'rhisf_par_tbl', rhisf_tbl_par ) ! now k-velocity 959 990 CALL iom_rstput( 0, 0, inum, 'rfrac_par_tbl', rfrac_tbl_par ) ! now k-velocity 960 CALL iom_rstput( 0, 0, inum, 'misfkb_par', REAL(misfkb_par, 8)) ! now k-velocity961 CALL iom_rstput( 0, 0, inum, 'misfkt_par', REAL(misfkt_par, 8)) ! now k-velocity962 CALL iom_rstput( 0, 0, inum, 'mskisf_par', REAL(mskisf_par, 8), ktype = jp_i1 )991 CALL iom_rstput( 0, 0, inum, 'misfkb_par', REAL(misfkb_par,wp) ) ! now k-velocity 992 CALL iom_rstput( 0, 0, inum, 'misfkt_par', REAL(misfkt_par,wp) ) ! now k-velocity 993 CALL iom_rstput( 0, 0, inum, 'mskisf_par', REAL(mskisf_par,wp), ktype = jp_i1 ) 963 994 END IF 964 995 END IF 965 996 ! 966 997 IF( ALLOCATED(ahtu) ) THEN 967 998 CALL iom_rstput( 0, 0, inum, 'ahtu', ahtu ) ! aht at u-point … … 978 1009 CALL iom_rstput( 0, 0, inum, 'sozotaux', utau ) ! i-wind stress 979 1010 CALL iom_rstput( 0, 0, inum, 'sometauy', vtau ) ! j-wind stress 980 IF( .NOT.ln_linssh ) THEN 981 CALL iom_rstput( 0, 0, inum, 'vovvldep', gdept(:,:,:,Kmm)) ! T-cell depth982 CALL iom_rstput( 0, 0, inum, 'vovvle3t', e3t(:,:,:,Kmm)) ! T-cell thickness1011 IF( .NOT.ln_linssh ) THEN 1012 CALL iom_rstput( 0, 0, inum, 'vovvldep', zgdept ) ! T-cell depth 1013 CALL iom_rstput( 0, 0, inum, 'vovvle3t', ze3t ) ! T-cell thickness 983 1014 END IF 984 1015 IF( ln_wave .AND. ln_sdw ) THEN … … 993 1024 CALL iom_rstput ( 0, 0, inum, "qz1_abl", tq_abl(:,:,2,nt_a,2) ) ! now first level humidity 994 1025 ENDIF 995 1026 ! 1027 CALL iom_close( inum ) 1028 ! 996 1029 #if defined key_si3 997 1030 IF( nn_ice == 2 ) THEN ! condition needed in case agrif + ice-model but no-ice in child grid 1031 CALL iom_open( TRIM(cdfile_name)//'_ice', inum, ldwrt = .TRUE., kdlev = jpl, cdcomp = 'ICE' ) 998 1032 CALL ice_wri_state( inum ) 1033 CALL iom_close( inum ) 999 1034 ENDIF 1000 1035 #endif 1001 ! 1002 CALL iom_close( inum ) 1003 ! 1036 1004 1037 END SUBROUTINE dia_wri_state 1005 1038 -
NEMO/branches/2020/dev_r12527_Gurvan_ShallowWater/src/OCE/DOM/dom_oce.F90
r12489 r13151 2 2 !!====================================================================== 3 3 !! *** MODULE dom_oce *** 4 !!5 4 !! ** Purpose : Define in memory all the ocean space domain variables 6 5 !!====================================================================== 7 !! History : 1.0 ! 2005-10 (A. Beckmann, G. Madec) reactivate s-coordinate 6 !! History : 1.0 ! 2005-10 (A. Beckmann, G. Madec) reactivate s-coordinate 8 7 !! 3.3 ! 2010-11 (G. Madec) add mbk. arrays associated to the deepest ocean level 9 8 !! 3.4 ! 2011-01 (A. R. Porter, STFC Daresbury) dynamical allocation … … 13 12 !! - ! 2015-11 (G. Madec, A. Coward) time varying zgr by default 14 13 !! 4.1 ! 2019-08 (A. Coward, D. Storkey) rename prognostic variables in preparation for new time scheme. 14 !! 4.x ! 2020-02 (G. Madec, S. Techene) introduce ssh to h0 ratio 15 15 !!---------------------------------------------------------------------- 16 16 … … 71 71 ! ! = 6 cyclic East-West AND North fold F-point pivot 72 72 ! ! = 7 bi-cyclic East-West AND North-South 73 LOGICAL, PUBLIC :: l_Iperio, l_Jperio ! should we explicitely take care I/J periodicity 74 75 ! !domain MPP decomposition parameters73 LOGICAL, PUBLIC :: l_Iperio, l_Jperio ! should we explicitely take care I/J periodicity 74 75 ! !: domain MPP decomposition parameters 76 76 INTEGER , PUBLIC :: nimpp, njmpp !: i- & j-indexes for mpp-subdomain left bottom 77 77 INTEGER , PUBLIC :: nreci, nrecj !: overlap region in i and j … … 81 81 INTEGER, ALLOCATABLE, PUBLIC :: nbondi_bdy(:) !: mark i-direction local boundaries for BDY open boundaries 82 82 INTEGER, ALLOCATABLE, PUBLIC :: nbondj_bdy(:) !: mark j-direction local boundaries for BDY open boundaries 83 INTEGER, ALLOCATABLE, PUBLIC :: nbondi_bdy_b(:) !: mark i-direction of neighbours local boundaries for BDY open boundaries 84 INTEGER, ALLOCATABLE, PUBLIC :: nbondj_bdy_b(:) !: mark j-direction of neighbours local boundaries for BDY open boundaries 83 INTEGER, ALLOCATABLE, PUBLIC :: nbondi_bdy_b(:) !: mark i-direction of neighbours local boundaries for BDY open boundaries 84 INTEGER, ALLOCATABLE, PUBLIC :: nbondj_bdy_b(:) !: mark j-direction of neighbours local boundaries for BDY open boundaries 85 85 86 86 INTEGER, PUBLIC :: npolj !: north fold mark (0, 3 or 4) … … 126 126 LOGICAL, PUBLIC :: ln_zps !: z-coordinate - partial step 127 127 LOGICAL, PUBLIC :: ln_sco !: s-coordinate or hybrid z-s coordinate 128 LOGICAL, PUBLIC :: ln_isfcav !: presence of ISF 128 LOGICAL, PUBLIC :: ln_isfcav !: presence of ISF 129 129 ! ! reference scale factors 130 130 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: e3t_0 !: t- vert. scale factor [m] … … 136 136 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: e3vw_0 !: vw-vert. scale factor [m] 137 137 ! ! time-dependent scale factors 138 #if ! defined key_qco 138 139 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:,:) :: e3t, e3u, e3v, e3w, e3uw, e3vw !: vert. scale factor [m] 139 140 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: e3f !: F-point vert. scale factor [m] 141 #endif 142 ! ! time-dependent ratio ssh / h_0 143 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: r3t, r3u, r3v !: time-dependent ratio at t-, u- and v-point [-] 144 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: r3f !: mid-time-level ratio at f-point [-] 145 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: r3t_f, r3u_f, r3v_f !: now time-filtered ratio at t-, u- and v-point [-] 140 146 141 147 ! ! reference depths of cells 142 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: gdept_0 !: t- depth [m]143 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: gdepw_0 !: w- depth [m]144 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: gde3w_0 !: w- depth (sum of e3w) [m]148 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: gdept_0 !: t- depth [m] 149 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: gdepw_0 !: w- depth [m] 150 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: gde3w_0 !: w- depth (sum of e3w) [m] 145 151 ! ! time-dependent depths of cells 146 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:,:) :: gdept, gdepw 147 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: gde3w 148 149 ! ! reference heights of water column 150 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: ht_0 !: t-depth [m] 151 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: hu_0 !: u-depth [m] 152 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: hv_0 !: v-depth [m] 153 ! time-dependent heights of water column 154 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: ht !: height of water column at T-points [m] 155 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: hu, hv, r1_hu, r1_hv !: height of water column [m] and reciprocal [1/m] 152 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:,:) :: gdept, gdepw 153 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: gde3w 154 155 ! ! reference heights of ocean water column and its inverse 156 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: ht_0, r1_ht_0 !: t-depth [m] and [1/m] 157 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: hu_0, r1_hu_0 !: u-depth [m] and [1/m] 158 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: hv_0, r1_hv_0 !: v-depth [m] and [1/m] 159 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: hf_0, r1_hf_0 !: f-depth [m] and [1/m] 160 ! ! time-dependent heights of ocean water column 161 #if ! defined key_qco 162 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: ht !: t-points [m] 163 #endif 164 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: hu, r1_hu !: u-depth [m] and [1/m] 165 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: hv, r1_hv !: v-depth [m] and [1/m] 156 166 157 167 INTEGER, PUBLIC :: nla10 !: deepest W level Above ~10m (nlb10 - 1) 158 INTEGER, PUBLIC :: nlb10 !: shallowest W level Bellow ~10m (nla10 + 1) 168 INTEGER, PUBLIC :: nlb10 !: shallowest W level Bellow ~10m (nla10 + 1) 159 169 160 170 !! 1D reference vertical coordinate … … 169 179 !! --------------------------------------------------------------------- 170 180 !!gm Proposition of new name for top/bottom vertical indices 171 ! INTEGER , PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: mtk_t, mtk_u, mtk_v !: top first wet T-, U-, V-, F-level (ISF)172 ! INTEGER , PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: mbk_t, mbk_u, mbk_v !: bottom last wet T-, U-and V-level181 ! INTEGER , PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: mtk_t, mtk_u, mtk_v !: top first wet T-, U-, and V-level (ISF) 182 ! INTEGER , PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: mbk_t, mbk_u, mbk_v !: bottom last wet T-, U-, and V-level 173 183 !!gm 174 184 INTEGER , PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: mbkt, mbku, mbkv !: bottom last wet T-, U- and V-level … … 178 188 INTEGER , PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: mikt, miku, mikv, mikf !: top first wet T-, U-, V-, F-level (ISF) 179 189 180 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: ssmask, ssumask, ssvmask!: surface mask at T-,U-, V- and F-pts181 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:), TARGET :: tmask, umask, vmask, fmask !: land/ocean mask at T-, U-, V- and F-pts182 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:), TARGET :: wmask, wumask, wvmask !: land/ocean mask at WT-, WU- and WV-pts190 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: ssmask, ssumask, ssvmask, ssfmask !: surface mask at T-,U-, V- and F-pts 191 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:), TARGET :: tmask, umask, vmask, fmask !: land/ocean mask at T-, U-, V- and F-pts 192 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:), TARGET :: wmask, wumask, wvmask !: land/ocean mask at WT-, WU- and WV-pts 183 193 184 194 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:) :: tpol, fpol !: north fold mask (jperio= 3 or 4) … … 198 208 INTEGER , PUBLIC :: nsec_monday !: seconds between 00h of the last Monday and half of the current time step 199 209 INTEGER , PUBLIC :: nsec_day !: seconds between 00h of the current day and half of the current time step 200 REAL(wp), PUBLIC :: fjulday !: current julian day 210 REAL(wp), PUBLIC :: fjulday !: current julian day 201 211 REAL(wp), PUBLIC :: fjulstartyear !: first day of the current year in julian days 202 212 REAL(wp), PUBLIC :: adatrj !: number of elapsed days since the begining of the whole simulation 203 213 ! !: (cumulative duration of previous runs that may have used different time-step size) 204 INTEGER , PUBLIC, DIMENSION( 0: 2) :: nyear_len !: length in days of the previous/current/next year205 INTEGER , PUBLIC, DIMENSION(-11:25) :: nmonth_len !: length in days of the months of the current year206 INTEGER , PUBLIC, DIMENSION(-11:25) :: nmonth_beg !: second since Jan 1st 0h of the current year and the half of the months207 INTEGER , PUBLIC :: nsec1jan000!: second since Jan 1st 0h of nit000 year and Jan 1st 0h the current year208 INTEGER , PUBLIC :: nsec000_1jan000 !: second since Jan 1st 0h of nit000 year and nit000209 INTEGER , PUBLIC :: nsecend_1jan000 !: second since Jan 1st 0h of nit000 year and nitend214 INTEGER , PUBLIC, DIMENSION( 0: 2) :: nyear_len !: length in days of the previous/current/next year 215 INTEGER , PUBLIC, DIMENSION(-11:25) :: nmonth_len !: length in days of the months of the current year 216 INTEGER , PUBLIC, DIMENSION(-11:25) :: nmonth_beg !: second since Jan 1st 0h of the current year and the half of the months 217 INTEGER , PUBLIC :: nsec1jan000 !: second since Jan 1st 0h of nit000 year and Jan 1st 0h the current year 218 INTEGER , PUBLIC :: nsec000_1jan000 !: second since Jan 1st 0h of nit000 year and nit000 219 INTEGER , PUBLIC :: nsecend_1jan000 !: second since Jan 1st 0h of nit000 year and nitend 210 220 211 221 !!---------------------------------------------------------------------- … … 220 230 !!---------------------------------------------------------------------- 221 231 !! NEMO/OCE 4.0 , NEMO Consortium (2018) 222 !! $Id$ 232 !! $Id$ 223 233 !! Software governed by the CeCILL license (see ./LICENSE) 224 234 !!---------------------------------------------------------------------- … … 234 244 235 245 CHARACTER(len=3) FUNCTION Agrif_CFixed() 236 Agrif_CFixed = '0' 246 Agrif_CFixed = '0' 237 247 END FUNCTION Agrif_CFixed 238 248 #endif … … 240 250 INTEGER FUNCTION dom_oce_alloc() 241 251 !!---------------------------------------------------------------------- 242 INTEGER, DIMENSION(12) :: ierr 252 INTEGER :: ii 253 INTEGER, DIMENSION(30) :: ierr 243 254 !!---------------------------------------------------------------------- 244 i err(:) = 0255 ii = 0 ; ierr(:) = 0 245 256 ! 246 ALLOCATE( mig(jpi), mjg(jpj), STAT=ierr(1) ) 247 ! 248 ALLOCATE( mi0(jpiglo) , mi1 (jpiglo), mj0(jpjglo) , mj1 (jpjglo) , & 249 & tpol(jpiglo) , fpol(jpiglo) , STAT=ierr(2) ) 250 ! 257 ii = ii+1 258 ALLOCATE( mig(jpi), mjg(jpj), STAT=ierr(ii) ) 259 ! 260 ii = ii+1 261 ALLOCATE( mi0 (jpiglo) , mi1 (jpiglo), mj0(jpjglo) , mj1 (jpjglo) , & 262 & tpol(jpiglo) , fpol(jpiglo) , STAT=ierr(ii) ) 263 ! 264 ii = ii+1 251 265 ALLOCATE( glamt(jpi,jpj) , glamu(jpi,jpj) , glamv(jpi,jpj) , glamf(jpi,jpj) , & 252 266 & gphit(jpi,jpj) , gphiu(jpi,jpj) , gphiv(jpi,jpj) , gphif(jpi,jpj) , & … … 259 273 & e1e2v(jpi,jpj) , r1_e1e2v(jpi,jpj) , e1_e2v(jpi,jpj) , & 260 274 & e1e2f(jpi,jpj) , r1_e1e2f(jpi,jpj) , & 261 & ff_f (jpi,jpj) , ff_t (jpi,jpj) , STAT=ierr(3) ) 262 ! 275 & ff_f (jpi,jpj) , ff_t (jpi,jpj) , STAT=ierr(ii) ) 276 ! 277 ii = ii+1 263 278 ALLOCATE( gdept_0(jpi,jpj,jpk) , gdepw_0(jpi,jpj,jpk) , gde3w_0(jpi,jpj,jpk) , & 264 & gdept (jpi,jpj,jpk,jpt) , gdepw (jpi,jpj,jpk,jpt) , gde3w (jpi,jpj,jpk) , STAT=ierr(4) ) 265 ! 266 ALLOCATE( e3t_0(jpi,jpj,jpk) , e3u_0(jpi,jpj,jpk) , e3v_0(jpi,jpj,jpk) , e3f_0(jpi,jpj,jpk) , e3w_0(jpi,jpj,jpk) , & 267 & e3t (jpi,jpj,jpk,jpt) , e3u (jpi,jpj,jpk,jpt) , e3v (jpi,jpj,jpk,jpt) , e3f (jpi,jpj,jpk) , e3w (jpi,jpj,jpk,jpt) , & 268 & e3uw_0(jpi,jpj,jpk) , e3vw_0(jpi,jpj,jpk) , & 269 & e3uw (jpi,jpj,jpk,jpt) , e3vw (jpi,jpj,jpk,jpt) , STAT=ierr(5) ) 270 ! 271 ALLOCATE( ht_0(jpi,jpj) , hu_0(jpi,jpj) , hv_0(jpi,jpj) , & 272 & ht (jpi,jpj) , hu( jpi,jpj,jpt), hv( jpi,jpj,jpt) , r1_hu(jpi,jpj,jpt) , r1_hv(jpi,jpj,jpt) , & 273 & STAT=ierr(6) ) 274 ! 275 ALLOCATE( risfdep(jpi,jpj) , bathy(jpi,jpj) , STAT=ierr(7) ) 276 ! 277 ALLOCATE( gdept_1d(jpk) , gdepw_1d(jpk) , e3t_1d(jpk) , e3w_1d(jpk) , STAT=ierr(8) ) 278 ! 279 ALLOCATE( tmask_i(jpi,jpj) , tmask_h(jpi,jpj) , & 280 & ssmask (jpi,jpj) , ssumask(jpi,jpj) , ssvmask(jpi,jpj) , & 281 & mbkt (jpi,jpj) , mbku (jpi,jpj) , mbkv (jpi,jpj) , STAT=ierr(9) ) 282 ! 283 ALLOCATE( mikt(jpi,jpj), miku(jpi,jpj), mikv(jpi,jpj), mikf(jpi,jpj), STAT=ierr(10) ) 284 ! 285 ALLOCATE( tmask(jpi,jpj,jpk) , umask(jpi,jpj,jpk) , & 286 & vmask(jpi,jpj,jpk) , fmask(jpi,jpj,jpk) , STAT=ierr(11) ) 287 ! 288 ALLOCATE( wmask(jpi,jpj,jpk) , wumask(jpi,jpj,jpk), wvmask(jpi,jpj,jpk) , STAT=ierr(12) ) 279 & gdept (jpi,jpj,jpk,jpt) , gdepw (jpi,jpj,jpk,jpt) , gde3w (jpi,jpj,jpk) , STAT=ierr(ii) ) 280 ! 281 ii = ii+1 282 ALLOCATE( e3t_0(jpi,jpj,jpk) , e3u_0 (jpi,jpj,jpk) , e3v_0 (jpi,jpj,jpk) , e3f_0(jpi,jpj,jpk) , & 283 & e3w_0(jpi,jpj,jpk) , e3uw_0(jpi,jpj,jpk) , e3vw_0(jpi,jpj,jpk) , STAT=ierr(ii) ) 284 ! 285 #if ! defined key_qco 286 ii = ii+1 287 ALLOCATE( e3t(jpi,jpj,jpk,jpt) , e3u (jpi,jpj,jpk,jpt) , e3v (jpi,jpj,jpk,jpt) , e3f(jpi,jpj,jpk) , & 288 & e3w(jpi,jpj,jpk,jpt) , e3uw(jpi,jpj,jpk,jpt) , e3vw(jpi,jpj,jpk,jpt) , STAT=ierr(ii) ) 289 #endif 290 ! 291 ii = ii+1 292 ALLOCATE( r3t (jpi,jpj,jpt) , r3u (jpi,jpj,jpt) , r3v (jpi,jpj,jpt) , r3f (jpi,jpj) , & 293 & r3t_f(jpi,jpj) , r3u_f(jpi,jpj) , r3v_f(jpi,jpj) , STAT=ierr(ii) ) 294 ! 295 ii = ii+1 296 ALLOCATE( ht_0(jpi,jpj) , hu_0(jpi,jpj) , hv_0(jpi,jpj) , hf_0(jpi,jpj) , & 297 & r1_ht_0(jpi,jpj) , r1_hu_0(jpi,jpj) , r1_hv_0(jpi,jpj), r1_hf_0(jpi,jpj) , STAT=ierr(ii) ) 298 ! 299 #if ! defined key_qco 300 ii = ii+1 301 ALLOCATE( ht (jpi,jpj) , hu (jpi,jpj,jpt), hv (jpi,jpj,jpt) , & 302 & r1_hu (jpi,jpj,jpt), r1_hv (jpi,jpj,jpt) , STAT=ierr(ii) ) 303 #else 304 ii = ii+1 305 ALLOCATE( hu (jpi,jpj,jpt), hv (jpi,jpj,jpt) , & 306 & r1_hu (jpi,jpj,jpt), r1_hv (jpi,jpj,jpt) , STAT=ierr(ii) ) 307 #endif 308 ! 309 ii = ii+1 310 ALLOCATE( risfdep(jpi,jpj) , bathy(jpi,jpj) , STAT=ierr(ii) ) 311 ! 312 ii = ii+1 313 ALLOCATE( gdept_1d(jpk) , gdepw_1d(jpk) , e3t_1d(jpk) , e3w_1d(jpk) , STAT=ierr(ii) ) 314 ! 315 ii = ii+1 316 ALLOCATE( tmask_i(jpi,jpj) , tmask_h(jpi,jpj) , & 317 & ssmask (jpi,jpj) , ssumask(jpi,jpj) , ssvmask(jpi,jpj) , ssfmask(jpi,jpj) , & 318 & mbkt (jpi,jpj) , mbku (jpi,jpj) , mbkv (jpi,jpj) , STAT=ierr(ii) ) 319 ! 320 ii = ii+1 321 ALLOCATE( mikt(jpi,jpj), miku(jpi,jpj), mikv(jpi,jpj), mikf(jpi,jpj), STAT=ierr(ii) ) 322 ! 323 ii = ii+1 324 ALLOCATE( tmask(jpi,jpj,jpk) , umask(jpi,jpj,jpk) , & 325 & vmask(jpi,jpj,jpk) , fmask(jpi,jpj,jpk) , STAT=ierr(ii) ) 326 ! 327 ii = ii+1 328 ALLOCATE( wmask(jpi,jpj,jpk) , wumask(jpi,jpj,jpk), wvmask(jpi,jpj,jpk) , STAT=ierr(ii) ) 289 329 ! 290 330 dom_oce_alloc = MAXVAL(ierr) -
NEMO/branches/2020/dev_r12527_Gurvan_ShallowWater/src/OCE/DOM/domain.F90
r12489 r13151 6 6 !! History : OPA ! 1990-10 (C. Levy - G. Madec) Original code 7 7 !! ! 1992-01 (M. Imbard) insert time step initialization 8 !! ! 1996-06 (G. Madec) generalized vertical coordinate 8 !! ! 1996-06 (G. Madec) generalized vertical coordinate 9 9 !! ! 1997-02 (G. Madec) creation of domwri.F 10 10 !! ! 2001-05 (E.Durand - G. Madec) insert closed sea … … 15 15 !! 3.7 ! 2015-11 (G. Madec, A. Coward) time varying zgr by default 16 16 !! 4.0 ! 2016-10 (G. Madec, S. Flavoni) domain configuration / user defined interface 17 !! 4.x ! 2020-02 (G. Madec, S. Techene) introduce ssh to h0 ratio 17 18 !!---------------------------------------------------------------------- 18 19 19 20 !!---------------------------------------------------------------------- 20 21 !! dom_init : initialize the space and time domain … … 34 35 USE dommsk ! domain: set the mask system 35 36 USE domwri ! domain: write the meshmask file 37 #if ! defined key_qco 36 38 USE domvvl ! variable volume 39 #else 40 USE domqco ! variable volume 41 #endif 37 42 USE c1d ! 1D configuration 38 43 USE dyncor_c1d ! 1D configuration: Coriolis term (cor_c1d routine) … … 61 66 !!---------------------------------------------------------------------- 62 67 !! *** ROUTINE dom_init *** 63 !! 64 !! ** Purpose : Domain initialization. Call the routines that are 65 !! required to create the arrays which define the space 68 !! 69 !! ** Purpose : Domain initialization. Call the routines that are 70 !! required to create the arrays which define the space 66 71 !! and time domain of the ocean model. 67 72 !! … … 76 81 CHARACTER (len=*), INTENT(in) :: cdstr ! model: NEMO or SAS. Determines core restart variables 77 82 ! 78 INTEGER :: ji, jj, jk, ik! dummy loop indices83 INTEGER :: ji, jj, jk, jt ! dummy loop indices 79 84 INTEGER :: iconf = 0 ! local integers 80 CHARACTER (len=64) :: cform = "(A12, 3(A13, I7))" 85 CHARACTER (len=64) :: cform = "(A12, 3(A13, I7))" 81 86 INTEGER , DIMENSION(jpi,jpj) :: ik_top , ik_bot ! top and bottom ocean level 82 87 REAL(wp), DIMENSION(jpi,jpj) :: z1_hu_0, z1_hv_0 … … 110 115 CASE( 7 ) ; WRITE(numout,*) ' (i.e. cyclic east-west and north-south)' 111 116 CASE DEFAULT 112 CALL ctl_stop( ' jperio is out of range' )117 CALL ctl_stop( 'dom_init: jperio is out of range' ) 113 118 END SELECT 114 119 WRITE(numout,*) ' Ocean model configuration used:' … … 140 145 IF( ln_closea ) CALL dom_clo ! Read in masks to define closed seas and lakes 141 146 142 CALL dom_zgr( ik_top, ik_bot ) ! Vertical mesh and bathymetry 147 CALL dom_zgr( ik_top, ik_bot ) ! Vertical mesh and bathymetry (return top and bottom ocean t-level indices) 143 148 144 149 CALL dom_msk( ik_top, ik_bot ) ! Masks … … 147 152 hu_0(:,:) = 0._wp 148 153 hv_0(:,:) = 0._wp 154 hf_0(:,:) = 0._wp 149 155 DO jk = 1, jpk 150 156 ht_0(:,:) = ht_0(:,:) + e3t_0(:,:,jk) * tmask(:,:,jk) 151 157 hu_0(:,:) = hu_0(:,:) + e3u_0(:,:,jk) * umask(:,:,jk) 152 158 hv_0(:,:) = hv_0(:,:) + e3v_0(:,:,jk) * vmask(:,:,jk) 159 hf_0(:,:) = hf_0(:,:) + e3f_0(:,:,jk) * fmask(:,:,jk) 153 160 END DO 154 161 ! 162 r1_ht_0(:,:) = ssmask (:,:) / ( ht_0(:,:) + 1._wp - ssmask (:,:) ) 163 r1_hu_0(:,:) = ssumask(:,:) / ( hu_0(:,:) + 1._wp - ssumask(:,:) ) 164 r1_hv_0(:,:) = ssvmask(:,:) / ( hv_0(:,:) + 1._wp - ssvmask(:,:) ) 165 r1_hf_0(:,:) = ssfmask(:,:) / ( hf_0(:,:) + 1._wp - ssfmask(:,:) ) 166 167 ! 168 #if defined key_qco 169 ! !== initialisation of time varying coordinate ==! Quasi-Euerian coordinate case 170 ! 171 IF( .NOT.l_offline ) CALL dom_qco_init( Kbb, Kmm, Kaa ) 172 ! 173 IF( ln_linssh ) CALL ctl_stop('STOP','domain: key_qco and ln_linssh = T are incompatible') 174 ! 175 #else 155 176 ! !== time varying part of coordinate system ==! 156 177 ! 157 178 IF( ln_linssh ) THEN != Fix in time : set to the reference one for all 158 !159 ! before ! now ! after !160 gdept(:,:,:, Kbb) = gdept_0 ; gdept(:,:,:,Kmm) = gdept_0 ; gdept(:,:,:,Kaa) = gdept_0 ! depth of grid-points161 gdepw(:,:,:, Kbb) = gdepw_0 ; gdepw(:,:,:,Kmm) = gdepw_0 ; gdepw(:,:,:,Kaa) = gdepw_0 !162 gde3w = gde3w_0 ! --- !163 !164 e3t(:,:,:,Kbb) = e3t_0 ; e3t(:,:,:,Kmm) = e3t_0 ; e3t(:,:,:,Kaa) = e3t_0 ! scale factors165 e3u(:,:,:,Kbb) = e3u_0 ; e3u(:,:,:,Kmm) = e3u_0 ; e3u(:,:,:,Kaa) = e3u_0 !166 e3v(:,:,:,Kbb) = e3v_0 ; e3v(:,:,:,Kmm) = e3v_0 ; e3v(:,:,:,Kaa) = e3v_0 !167 e3f = e3f_0 ! --- !168 e3w(:,:,:,Kbb) = e3w_0 ; e3w(:,:,:,Kmm) = e3w_0 ; e3w(:,:,:,Kaa) = e3w_0 !169 e3uw(:,:,:,Kbb) = e3uw_0 ; e3uw(:,:,:,Kmm) = e3uw_0 ; e3uw(:,:,:,Kaa) = e3uw_0 !170 e3vw(:,:,:,Kbb) = e3vw_0 ; e3vw(:,:,:,Kmm) = e3vw_0 ; e3vw(:,:,:,Kaa) = e3vw_0 !171 !172 z1_hu_0(:,:) = ssumask(:,:) / ( hu_0(:,:) + 1._wp - ssumask(:,:) ) ! _i mask due to ISF173 z1_hv_0(:,:) = ssvmask(:,:) / ( hv_0(:,:) + 1._wp - ssvmask(:,:))174 ! 175 ! before ! now ! after !176 ht = ht_0 ! ! water column thickness177 hu(:,:,Kbb) = hu_0 ; hu(:,:,Kmm) = hu_0 ; hu(:,:,Kaa) = hu_0 !178 hv(:,:,Kbb) = hv_0 ; hv(:,:,Kmm) = hv_0 ; hv(:,:,Kaa) = hv_0 !179 r1_h u(:,:,Kbb) = z1_hu_0 ; r1_hu(:,:,Kmm) = z1_hu_0 ; r1_hu(:,:,Kaa) = z1_hu_0 ! inverse of water column thickness180 r1_hv(:,:,Kbb) = z1_hv_0 ; r1_hv(:,:,Kmm) = z1_hv_0 ; r1_hv(:,:,Kaa) = z1_hv_0 !181 !179 ! 180 DO jt = 1, jpt ! depth of t- and w-grid-points 181 gdept(:,:,:,jt) = gdept_0(:,:,:) 182 gdepw(:,:,:,jt) = gdepw_0(:,:,:) 183 END DO 184 gde3w(:,:,:) = gde3w_0(:,:,:) ! = gdept as the sum of e3t 185 ! 186 DO jt = 1, jpt ! vertical scale factors 187 e3t(:,:,:,jt) = e3t_0(:,:,:) 188 e3u(:,:,:,jt) = e3u_0(:,:,:) 189 e3v(:,:,:,jt) = e3v_0(:,:,:) 190 e3w(:,:,:,jt) = e3w_0(:,:,:) 191 e3uw(:,:,:,jt) = e3uw_0(:,:,:) 192 e3vw(:,:,:,jt) = e3vw_0(:,:,:) 193 END DO 194 e3f(:,:,:) = e3f_0(:,:,:) 195 ! 196 DO jt = 1, jpt ! water column thickness and its inverse 197 hu(:,:,jt) = hu_0(:,:) 198 hv(:,:,jt) = hv_0(:,:) 199 r1_hu(:,:,jt) = r1_hu_0(:,:) 200 r1_hv(:,:,jt) = r1_hv_0(:,:) 201 END DO 202 ht(:,:) = ht_0(:,:) 182 203 ! 183 204 ELSE != time varying : initialize before/now/after variables 184 205 ! 185 IF( .NOT.l_offline ) CALL dom_vvl_init( Kbb, Kmm, Kaa ) 186 ! 187 ENDIF 206 IF( .NOT.l_offline ) CALL dom_vvl_init( Kbb, Kmm, Kaa ) 207 ! 208 ENDIF 209 #endif 210 188 211 ! 189 212 IF( lk_c1d ) CALL cor_c1d ! 1D configuration: Coriolis set at T-point … … 198 221 WRITE(numout,*) 'dom_init : ==>>> END of domain initialization' 199 222 WRITE(numout,*) '~~~~~~~~' 200 WRITE(numout,*) 223 WRITE(numout,*) 201 224 ENDIF 202 225 ! … … 210 233 !! ** Purpose : initialization of global domain <--> local domain indices 211 234 !! 212 !! ** Method : 235 !! ** Method : 213 236 !! 214 237 !! ** Action : - mig , mjg : local domain indices ==> global domain indices … … 226 249 END DO 227 250 ! ! global domain indices ==> local domain indices 228 ! ! (return (m.0,m.1)=(1,0) if data domain gridpoint is to the west/south of the 229 ! ! local domain, or (m.0,m.1)=(jp.+1,jp.) to the east/north of local domain. 251 ! ! (return (m.0,m.1)=(1,0) if data domain gridpoint is to the west/south of the 252 ! ! local domain, or (m.0,m.1)=(jp.+1,jp.) to the east/north of local domain. 230 253 DO ji = 1, jpiglo 231 254 mi0(ji) = MAX( 1 , MIN( ji - nimpp + 1, jpi+1 ) ) … … 273 296 !!---------------------------------------------------------------------- 274 297 !! *** ROUTINE dom_nam *** 275 !! 298 !! 276 299 !! ** Purpose : read domaine namelists and print the variables. 277 300 !! … … 355 378 l_1st_euler = ln_1st_euler 356 379 IF( .NOT. l_1st_euler .AND. .NOT. ln_rstart ) THEN 357 IF(lwp) WRITE(numout,*) 380 IF(lwp) WRITE(numout,*) 358 381 IF(lwp) WRITE(numout,*)' ==>>> Start from rest (ln_rstart=F)' 359 382 IF(lwp) WRITE(numout,*)' an Euler initial time step is used : l_1st_euler is forced to .true. ' … … 383 406 IF(lwp) WRITE(numout,*) 384 407 SELECT CASE ( nleapy ) ! Choose calendar for IOIPSL 385 CASE ( 1 ) 408 CASE ( 1 ) 386 409 CALL ioconf_calendar('gregorian') 387 410 IF(lwp) WRITE(numout,*) ' ==>>> The IOIPSL calendar is "gregorian", i.e. leap year' … … 419 442 IF( TRIM(Agrif_CFixed()) == '0' ) THEN 420 443 lrxios = ln_xios_read.AND.ln_rstart 421 !set output file type for XIOS based on NEMO namelist 422 IF (nn_wxios > 0) lwxios = .TRUE. 444 !set output file type for XIOS based on NEMO namelist 445 IF (nn_wxios > 0) lwxios = .TRUE. 423 446 nxioso = nn_wxios 424 447 ENDIF … … 463 486 !!---------------------------------------------------------------------- 464 487 INTEGER, DIMENSION(2) :: imi1, imi2, ima1, ima2 465 INTEGER, DIMENSION(2) :: iloc ! 488 INTEGER, DIMENSION(2) :: iloc ! 466 489 REAL(wp) :: ze1min, ze1max, ze2min, ze2max 467 490 !!---------------------------------------------------------------------- … … 473 496 CALL mpp_maxloc( 'domain', e2t(:,:), tmask_i(:,:), ze2max, ima2 ) 474 497 ELSE 475 ze1min = MINVAL( e1t(:,:), mask = tmask_i(:,:) == 1._wp ) 476 ze2min = MINVAL( e2t(:,:), mask = tmask_i(:,:) == 1._wp ) 477 ze1max = MAXVAL( e1t(:,:), mask = tmask_i(:,:) == 1._wp ) 478 ze2max = MAXVAL( e2t(:,:), mask = tmask_i(:,:) == 1._wp ) 498 ze1min = MINVAL( e1t(:,:), mask = tmask_i(:,:) == 1._wp ) 499 ze2min = MINVAL( e2t(:,:), mask = tmask_i(:,:) == 1._wp ) 500 ze1max = MAXVAL( e1t(:,:), mask = tmask_i(:,:) == 1._wp ) 501 ze2max = MAXVAL( e2t(:,:), mask = tmask_i(:,:) == 1._wp ) 479 502 ! 480 503 iloc = MINLOC( e1t(:,:), mask = tmask_i(:,:) == 1._wp ) … … 507 530 !!---------------------------------------------------------------------- 508 531 !! *** ROUTINE dom_nam *** 509 !! 532 !! 510 533 !! ** Purpose : read the domain size in domain configuration file 511 534 !! … … 514 537 CHARACTER(len=*) , INTENT(out) :: cd_cfg ! configuration name 515 538 INTEGER , INTENT(out) :: kk_cfg ! configuration resolution 516 INTEGER , INTENT(out) :: kpi, kpj, kpk ! global domain sizes 517 INTEGER , INTENT(out) :: kperio ! lateral global domain b.c. 539 INTEGER , INTENT(out) :: kpi, kpj, kpk ! global domain sizes 540 INTEGER , INTENT(out) :: kperio ! lateral global domain b.c. 518 541 ! 519 542 INTEGER :: inum ! local integer … … 547 570 cd_cfg = 'UNKNOWN' 548 571 kk_cfg = -9999999 549 !- or they may be present as global attributes 550 !- (netcdf only) 572 !- or they may be present as global attributes 573 !- (netcdf only) 551 574 CALL iom_getatt( inum, 'cn_cfg', cd_cfg ) ! returns ! if not found 552 575 CALL iom_getatt( inum, 'nn_cfg', kk_cfg ) ! returns -999 if not found … … 570 593 WRITE(numout,*) ' type of global domain lateral boundary jperio = ', kperio 571 594 ENDIF 572 ! 595 ! 573 596 END SUBROUTINE domain_cfg 574 575 597 598 576 599 SUBROUTINE cfg_write 577 600 !!---------------------------------------------------------------------- 578 601 !! *** ROUTINE cfg_write *** 579 !! 580 !! ** Purpose : Create the "cn_domcfg_out" file, a NetCDF file which 581 !! contains all the ocean domain informations required to 602 !! 603 !! ** Purpose : Create the "cn_domcfg_out" file, a NetCDF file which 604 !! contains all the ocean domain informations required to 582 605 !! define an ocean configuration. 583 606 !! … … 585 608 !! ocean configuration. 586 609 !! 587 !! ** output file : domcfg_out.nc : domain size, characteristics, horizontal 610 !! ** output file : domcfg_out.nc : domain size, characteristics, horizontal 588 611 !! mesh, Coriolis parameter, and vertical scale factors 589 612 !! NB: also contain ORCA family information … … 603 626 ! ! create 'domcfg_out.nc' file ! 604 627 ! ! ============================= ! 605 ! 628 ! 606 629 clnam = cn_domcfg_out ! filename (configuration information) 607 630 CALL iom_open( TRIM(clnam), inum, ldwrt = .TRUE. ) 608 631 609 632 ! 610 633 ! !== ORCA family specificities ==! 611 634 IF( cn_cfg == "ORCA" ) THEN 612 635 CALL iom_rstput( 0, 0, inum, 'ORCA' , 1._wp , ktype = jp_i4 ) 613 CALL iom_rstput( 0, 0, inum, 'ORCA_index', REAL( nn_cfg, wp), ktype = jp_i4 ) 636 CALL iom_rstput( 0, 0, inum, 'ORCA_index', REAL( nn_cfg, wp), ktype = jp_i4 ) 614 637 ENDIF 615 638 ! … … 643 666 CALL iom_rstput( 0, 0, inum, 'glamv', glamv, ktype = jp_r8 ) 644 667 CALL iom_rstput( 0, 0, inum, 'glamf', glamf, ktype = jp_r8 ) 645 ! 668 ! 646 669 CALL iom_rstput( 0, 0, inum, 'gphit', gphit, ktype = jp_r8 ) ! longitude 647 670 CALL iom_rstput( 0, 0, inum, 'gphiu', gphiu, ktype = jp_r8 ) 648 671 CALL iom_rstput( 0, 0, inum, 'gphiv', gphiv, ktype = jp_r8 ) 649 672 CALL iom_rstput( 0, 0, inum, 'gphif', gphif, ktype = jp_r8 ) 650 ! 673 ! 651 674 CALL iom_rstput( 0, 0, inum, 'e1t' , e1t , ktype = jp_r8 ) ! i-scale factors (e1.) 652 675 CALL iom_rstput( 0, 0, inum, 'e1u' , e1u , ktype = jp_r8 ) … … 663 686 ! 664 687 ! !== vertical mesh ==! 665 ! 688 ! 666 689 CALL iom_rstput( 0, 0, inum, 'e3t_1d' , e3t_1d , ktype = jp_r8 ) ! reference 1D-coordinate 667 690 CALL iom_rstput( 0, 0, inum, 'e3w_1d' , e3w_1d , ktype = jp_r8 ) … … 674 697 CALL iom_rstput( 0, 0, inum, 'e3uw_0' , e3uw_0 , ktype = jp_r8 ) 675 698 CALL iom_rstput( 0, 0, inum, 'e3vw_0' , e3vw_0 , ktype = jp_r8 ) 676 ! 699 ! 677 700 ! !== wet top and bottom level ==! (caution: multiplied by ssmask) 678 701 ! … … 694 717 ! 695 718 ! ! ============================ 696 ! ! close the files 719 ! ! close the files 697 720 ! ! ============================ 698 721 CALL iom_close( inum ) -
NEMO/branches/2020/dev_r12527_Gurvan_ShallowWater/src/OCE/DOM/dommsk.F90
r12377 r13151 2 2 !!====================================================================== 3 3 !! *** MODULE dommsk *** 4 !! Ocean initialization : domain land/sea mask 4 !! Ocean initialization : domain land/sea mask 5 5 !!====================================================================== 6 6 !! History : OPA ! 1987-07 (G. Madec) Original code … … 18 18 !! 3.6 ! 2015-05 (P. Mathiot) ISF: add wmask,wumask and wvmask 19 19 !! 4.0 ! 2016-06 (G. Madec, S. Flavoni) domain configuration / user defined interface 20 !! 4.x ! 2020-02 (G. Madec, S. Techene) introduce ssh to h0 ratio 20 21 !!---------------------------------------------------------------------- 21 22 … … 40 41 ! !!* Namelist namlbc : lateral boundary condition * 41 42 REAL(wp) :: rn_shlat ! type of lateral boundary condition on velocity 42 LOGICAL, PUBLIC :: ln_vorlat ! consistency of vorticity boundary condition 43 LOGICAL, PUBLIC :: ln_vorlat ! consistency of vorticity boundary condition 43 44 ! with analytical eqs. 44 45 … … 47 48 !!---------------------------------------------------------------------- 48 49 !! NEMO/OCE 4.0 , NEMO Consortium (2018) 49 !! $Id$ 50 !! $Id$ 50 51 !! Software governed by the CeCILL license (see ./LICENSE) 51 52 !!---------------------------------------------------------------------- … … 59 60 !! zontal velocity points (u & v), vorticity points (f) points. 60 61 !! 61 !! ** Method : The ocean/land mask at t-point is deduced from ko_top 62 !! and ko_bot, the indices of the fist and last ocean t-levels which 62 !! ** Method : The ocean/land mask at t-point is deduced from ko_top 63 !! and ko_bot, the indices of the fist and last ocean t-levels which 63 64 !! are either defined in usrdef_zgr or read in zgr_read. 64 !! The velocity masks (umask, vmask, wmask, wumask, wvmask) 65 !! The velocity masks (umask, vmask, wmask, wumask, wvmask) 65 66 !! are deduced from a product of the two neighboring tmask. 66 67 !! The vorticity mask (fmask) is deduced from tmask taking … … 77 78 !! due to cyclic or North Fold boundaries as well as MPP halos. 78 79 !! 79 !! ** Action : tmask, umask, vmask, wmask, wumask, wvmask : land/ocean mask 80 !! ** Action : tmask, umask, vmask, wmask, wumask, wvmask : land/ocean mask 80 81 !! at t-, u-, v- w, wu-, and wv-points (=0. or 1.) 81 !! fmask : land/ocean mask at f-point (=0., or =1., or 82 !! fmask : land/ocean mask at f-point (=0., or =1., or 82 83 !! =rn_shlat along lateral boundaries) 83 !! tmask_i : interior ocean mask 84 !! tmask_i : interior ocean mask 84 85 !! tmask_h : halo mask 85 86 !! ssmask , ssumask, ssvmask, ssfmask : 2D ocean mask … … 108 109 902 IF( ios > 0 ) CALL ctl_nam ( ios , 'namlbc in configuration namelist' ) 109 110 IF(lwm) WRITE ( numond, namlbc ) 110 111 111 112 IF(lwp) THEN ! control print 112 113 WRITE(numout,*) … … 115 116 WRITE(numout,*) ' Namelist namlbc' 116 117 WRITE(numout,*) ' lateral momentum boundary cond. rn_shlat = ',rn_shlat 117 WRITE(numout,*) ' consistency with analytical form ln_vorlat = ',ln_vorlat 118 WRITE(numout,*) ' consistency with analytical form ln_vorlat = ',ln_vorlat 118 119 ENDIF 119 120 ! … … 140 141 ! 141 142 ! the following call is mandatory 142 ! it masks boundaries (bathy=0) where needed depending on the configuration (closed, periodic...) 143 ! it masks boundaries (bathy=0) where needed depending on the configuration (closed, periodic...) 143 144 CALL lbc_lnk( 'dommsk', tmask , 'T', 1._wp ) ! Lateral boundary conditions 144 145 145 146 ! Mask corrections for bdy (read in mppini2) 146 147 READ ( numnam_ref, nambdy, IOSTAT = ios, ERR = 903) … … 157 158 END_3D 158 159 ENDIF 159 160 160 161 ! Ocean/land mask at u-, v-, and f-points (computed from tmask) 161 162 ! ---------------------------------------- … … 174 175 END DO 175 176 CALL lbc_lnk_multi( 'dommsk', umask, 'U', 1., vmask, 'V', 1., fmask, 'F', 1. ) ! Lateral boundary conditions 176 177 177 178 ! Ocean/land mask at wu-, wv- and w points (computed from tmask) 178 179 !----------------------------------------- … … 182 183 DO jk = 2, jpk ! interior values 183 184 wmask (:,:,jk) = tmask(:,:,jk) * tmask(:,:,jk-1) 184 wumask(:,:,jk) = umask(:,:,jk) * umask(:,:,jk-1) 185 wumask(:,:,jk) = umask(:,:,jk) * umask(:,:,jk-1) 185 186 wvmask(:,:,jk) = vmask(:,:,jk) * vmask(:,:,jk-1) 186 187 END DO … … 192 193 ssumask(:,:) = MAXVAL( umask(:,:,:), DIM=3 ) 193 194 ssvmask(:,:) = MAXVAL( vmask(:,:,:), DIM=3 ) 195 ssfmask(:,:) = MAXVAL( fmask(:,:,:), DIM=3 ) 194 196 195 197 … … 201 203 ! 202 204 ! ! halo mask : 0 on the halo and 1 elsewhere 203 tmask_h(:,:) = 1._wp 205 tmask_h(:,:) = 1._wp 204 206 tmask_h( 1 :iif, : ) = 0._wp ! first columns 205 207 tmask_h(iil:jpi, : ) = 0._wp ! last columns (including mpp extra columns) … … 208 210 ! 209 211 ! ! north fold mask 210 tpol(1:jpiglo) = 1._wp 212 tpol(1:jpiglo) = 1._wp 211 213 fpol(1:jpiglo) = 1._wp 212 214 IF( jperio == 3 .OR. jperio == 4 ) THEN ! T-point pivot … … 225 227 ENDIF 226 228 ! 227 ! ! interior mask : 2D ocean mask x halo mask 229 ! ! interior mask : 2D ocean mask x halo mask 228 230 tmask_i(:,:) = ssmask(:,:) * tmask_h(:,:) 229 231 230 232 231 233 ! Lateral boundary conditions on velocity (modify fmask) 232 ! --------------------------------------- 234 ! --------------------------------------- 233 235 IF( rn_shlat /= 0 ) THEN ! Not free-slip lateral boundary condition 234 236 ! … … 236 238 ! 237 239 DO jk = 1, jpk 238 zwf(:,:) = fmask(:,:,jk) 240 zwf(:,:) = fmask(:,:,jk) 239 241 DO_2D_00_00 240 242 IF( fmask(ji,jj,jk) == 0._wp ) THEN … … 250 252 fmask(jpi,jj,jk) = rn_shlat * MIN( 1._wp , MAX( zwf(jpi,jj+1), zwf(jpim1,jj), zwf(jpi,jj-1) ) ) 251 253 ENDIF 252 END DO 254 END DO 253 255 DO ji = 2, jpim1 254 256 IF( fmask(ji,1,jk) == 0._wp ) THEN … … 259 261 ENDIF 260 262 END DO 261 #if defined key_agrif 262 IF( .NOT. AGRIF_Root() ) THEN 263 IF ((nbondi == 1).OR.(nbondi == 2)) fmask(nlci-1 , : ,jk) = 0.e0 ! east 264 IF ((nbondi == -1).OR.(nbondi == 2)) fmask(1 , : ,jk) = 0.e0 ! west 265 IF ((nbondj == 1).OR.(nbondj == 2)) fmask(: ,nlcj-1 ,jk) = 0.e0 ! north 266 IF ((nbondj == -1).OR.(nbondj == 2)) fmask(: ,1 ,jk) = 0.e0 ! south 267 ENDIF 268 #endif 263 #if defined key_agrif 264 IF( .NOT. AGRIF_Root() ) THEN 265 IF ((nbondi == 1).OR.(nbondi == 2)) fmask(nlci-1 , : ,jk) = 0.e0 ! east 266 IF ((nbondi == -1).OR.(nbondi == 2)) fmask(1 , : ,jk) = 0.e0 ! west 267 IF ((nbondj == 1).OR.(nbondj == 2)) fmask(: ,nlcj-1 ,jk) = 0.e0 ! north 268 IF ((nbondj == -1).OR.(nbondj == 2)) fmask(: ,1 ,jk) = 0.e0 ! south 269 ENDIF 270 #endif 269 271 END DO 270 272 ! … … 276 278 ! 277 279 ENDIF 278 280 279 281 ! User defined alteration of fmask (use to reduce ocean transport in specified straits) 280 ! -------------------------------- 282 ! -------------------------------- 281 283 ! 282 284 CALL usr_def_fmask( cn_cfg, nn_cfg, fmask ) 283 285 ! 284 286 END SUBROUTINE dom_msk 285 287 286 288 !!====================================================================== 287 289 END MODULE dommsk -
NEMO/branches/2020/dev_r12527_Gurvan_ShallowWater/src/OCE/DOM/domvvl.F90
r12489 r13151 2 2 !!====================================================================== 3 3 !! *** MODULE domvvl *** 4 !! Ocean : 4 !! Ocean : 5 5 !!====================================================================== 6 6 !! History : 2.0 ! 2006-06 (B. Levier, L. Marie) original code … … 9 9 !! 3.6 ! 2014-11 (P. Mathiot) add ice shelf capability 10 10 !! 4.1 ! 2019-08 (A. Coward, D. Storkey) rename dom_vvl_sf_swp -> dom_vvl_sf_update for new timestepping 11 !! 4.x ! 2020-02 (G. Madec, S. Techene) introduce ssh to h0 ratio 11 12 !!---------------------------------------------------------------------- 12 13 13 !!----------------------------------------------------------------------14 !! dom_vvl_init : define initial vertical scale factors, depths and column thickness15 !! dom_vvl_sf_nxt : Compute next vertical scale factors16 !! dom_vvl_sf_update : Swap vertical scale factors and update the vertical grid17 !! dom_vvl_interpol : Interpolate vertical scale factors from one grid point to another18 !! dom_vvl_rst : read/write restart file19 !! dom_vvl_ctl : Check the vvl options20 !!----------------------------------------------------------------------21 14 USE oce ! ocean dynamics and tracers 22 15 USE phycst ! physical constant … … 35 28 IMPLICIT NONE 36 29 PRIVATE 37 38 PUBLIC dom_vvl_init ! called by domain.F90 39 PUBLIC dom_vvl_zgr ! called by isfcpl.F90 40 PUBLIC dom_vvl_sf_nxt ! called by step.F90 41 PUBLIC dom_vvl_sf_update ! called by step.F90 42 PUBLIC dom_vvl_interpol ! called by dynnxt.F90 43 30 44 31 ! !!* Namelist nam_vvl 45 32 LOGICAL , PUBLIC :: ln_vvl_zstar = .FALSE. ! zstar vertical coordinate … … 63 50 REAL(wp) , ALLOCATABLE, SAVE, DIMENSION(:,:) :: frq_rst_hdv ! retoring period for low freq. divergence 64 51 52 #if defined key_qco 53 !!---------------------------------------------------------------------- 54 !! 'key_qco' EMPTY MODULE Quasi-Eulerian vertical coordonate 55 !!---------------------------------------------------------------------- 56 #else 57 !!---------------------------------------------------------------------- 58 !! Default key Old management of time varying vertical coordinate 59 !!---------------------------------------------------------------------- 60 61 !!---------------------------------------------------------------------- 62 !! dom_vvl_init : define initial vertical scale factors, depths and column thickness 63 !! dom_vvl_sf_nxt : Compute next vertical scale factors 64 !! dom_vvl_sf_update : Swap vertical scale factors and update the vertical grid 65 !! dom_vvl_interpol : Interpolate vertical scale factors from one grid point to another 66 !! dom_vvl_rst : read/write restart file 67 !! dom_vvl_ctl : Check the vvl options 68 !!---------------------------------------------------------------------- 69 70 PUBLIC dom_vvl_init ! called by domain.F90 71 PUBLIC dom_vvl_zgr ! called by isfcpl.F90 72 PUBLIC dom_vvl_sf_nxt ! called by step.F90 73 PUBLIC dom_vvl_sf_update ! called by step.F90 74 PUBLIC dom_vvl_interpol ! called by dynnxt.F90 75 65 76 !! * Substitutions 66 77 # include "do_loop_substitute.h90" … … 98 109 !!---------------------------------------------------------------------- 99 110 !! *** ROUTINE dom_vvl_init *** 100 !! 111 !! 101 112 !! ** Purpose : Initialization of all scale factors, depths 102 113 !! and water column heights … … 107 118 !! ** Action : - e3t_(n/b) and tilde_e3t_(n/b) 108 119 !! - Regrid: e3[u/v](:,:,:,Kmm) 109 !! e3[u/v](:,:,:,Kmm) 110 !! e3w(:,:,:,Kmm) 120 !! e3[u/v](:,:,:,Kmm) 121 !! e3w(:,:,:,Kmm) 111 122 !! e3[u/v]w_b 112 !! e3[u/v]w_n 123 !! e3[u/v]w_n 113 124 !! gdept(:,:,:,Kmm), gdepw(:,:,:,Kmm) and gde3w 114 125 !! - h(t/u/v)_0 … … 135 146 ! 136 147 END SUBROUTINE dom_vvl_init 137 ! 148 149 138 150 SUBROUTINE dom_vvl_zgr(Kbb, Kmm, Kaa) 139 151 !!---------------------------------------------------------------------- 140 152 !! *** ROUTINE dom_vvl_init *** 141 !! 142 !! ** Purpose : Interpolation of all scale factors, 153 !! 154 !! ** Purpose : Interpolation of all scale factors, 143 155 !! depths and water column heights 144 156 !! … … 147 159 !! ** Action : - e3t_(n/b) and tilde_e3t_(n/b) 148 160 !! - Regrid: e3(u/v)_n 149 !! e3(u/v)_b 150 !! e3w_n 151 !! e3(u/v)w_b 152 !! e3(u/v)w_n 161 !! e3(u/v)_b 162 !! e3w_n 163 !! e3(u/v)w_b 164 !! e3(u/v)w_n 153 165 !! gdept_n, gdepw_n and gde3w_n 154 166 !! - h(t/u/v)_0 … … 168 180 CALL dom_vvl_interpol( e3t(:,:,:,Kbb), e3u(:,:,:,Kbb), 'U' ) ! from T to U 169 181 CALL dom_vvl_interpol( e3t(:,:,:,Kmm), e3u(:,:,:,Kmm), 'U' ) 170 CALL dom_vvl_interpol( e3t(:,:,:,Kbb), e3v(:,:,:,Kbb), 'V' ) ! from T to V 182 CALL dom_vvl_interpol( e3t(:,:,:,Kbb), e3v(:,:,:,Kbb), 'V' ) ! from T to V 171 183 CALL dom_vvl_interpol( e3t(:,:,:,Kmm), e3v(:,:,:,Kmm), 'V' ) 172 184 CALL dom_vvl_interpol( e3u(:,:,:,Kmm), e3f(:,:,:), 'F' ) ! from U to F 173 ! ! Vertical interpolation of e3t,u,v 185 ! ! Vertical interpolation of e3t,u,v 174 186 CALL dom_vvl_interpol( e3t(:,:,:,Kmm), e3w (:,:,:,Kmm), 'W' ) ! from T to W 175 187 CALL dom_vvl_interpol( e3t(:,:,:,Kbb), e3w (:,:,:,Kbb), 'W' ) … … 193 205 ! zcoef = tmask - wmask ! 0 everywhere tmask = wmask, ie everywhere expect at jk = mikt 194 206 ! ! 1 everywhere from mbkt to mikt + 1 or 1 (if no isf) 195 ! ! 0.5 where jk = mikt 207 ! ! 0.5 where jk = mikt 196 208 !!gm ??????? BUG ? gdept(:,:,:,Kmm) as well as gde3w does not include the thickness of ISF ?? 197 209 zcoef = ( tmask(ji,jj,jk) - wmask(ji,jj,jk) ) 198 210 gdepw(ji,jj,jk,Kmm) = gdepw(ji,jj,jk-1,Kmm) + e3t(ji,jj,jk-1,Kmm) 199 211 gdept(ji,jj,jk,Kmm) = zcoef * ( gdepw(ji,jj,jk ,Kmm) + 0.5 * e3w(ji,jj,jk,Kmm)) & 200 & + (1-zcoef) * ( gdept(ji,jj,jk-1,Kmm) + e3w(ji,jj,jk,Kmm)) 212 & + (1-zcoef) * ( gdept(ji,jj,jk-1,Kmm) + e3w(ji,jj,jk,Kmm)) 201 213 gde3w(ji,jj,jk) = gdept(ji,jj,jk,Kmm) - ssh(ji,jj,Kmm) 202 214 gdepw(ji,jj,jk,Kbb) = gdepw(ji,jj,jk-1,Kbb) + e3t(ji,jj,jk-1,Kbb) 203 215 gdept(ji,jj,jk,Kbb) = zcoef * ( gdepw(ji,jj,jk ,Kbb) + 0.5 * e3w(ji,jj,jk,Kbb)) & 204 & + (1-zcoef) * ( gdept(ji,jj,jk-1,Kbb) + e3w(ji,jj,jk,Kbb)) 216 & + (1-zcoef) * ( gdept(ji,jj,jk-1,Kbb) + e3w(ji,jj,jk,Kbb)) 205 217 END_3D 206 218 ! … … 261 273 IF( cn_cfg == "orca" .OR. cn_cfg == "ORCA" ) THEN 262 274 IF( nn_cfg == 3 ) THEN ! ORCA2: Suppress ztilde in the Foxe Basin for ORCA2 263 ii0 = 103 ; ii1 = 111 264 ij0 = 128 ; ij1 = 135 ; 275 ii0 = 103 ; ii1 = 111 276 ij0 = 128 ; ij1 = 135 ; 265 277 frq_rst_e3t( mi0(ii0):mi1(ii1) , mj0(ij0):mj1(ij1) ) = 0.0_wp 266 278 frq_rst_hdv( mi0(ii0):mi1(ii1) , mj0(ij0):mj1(ij1) ) = 1.e0_wp / rn_Dt … … 280 292 CALL iom_set_rstw_var_active('tilde_e3t_n') 281 293 END IF 282 ! ! -------------! 294 ! ! -------------! 283 295 IF( ln_vvl_ztilde ) THEN ! z_tilde case ! 284 296 ! ! ------------ ! … … 291 303 292 304 293 SUBROUTINE dom_vvl_sf_nxt( kt, Kbb, Kmm, Kaa, kcall ) 305 SUBROUTINE dom_vvl_sf_nxt( kt, Kbb, Kmm, Kaa, kcall ) 294 306 !!---------------------------------------------------------------------- 295 307 !! *** ROUTINE dom_vvl_sf_nxt *** 296 !! 308 !! 297 309 !! ** Purpose : - compute the after scale factors used in tra_zdf, dynnxt, 298 310 !! tranxt and dynspg routines 299 311 !! 300 312 !! ** Method : - z_star case: Repartition of ssh INCREMENT proportionnaly to the level thickness. 301 !! - z_tilde_case: after scale factor increment = 313 !! - z_tilde_case: after scale factor increment = 302 314 !! high frequency part of horizontal divergence 303 315 !! + retsoring towards the background grid … … 307 319 !! 308 320 !! ** Action : - hdiv_lf : restoring towards full baroclinic divergence in z_tilde case 309 !! - tilde_e3t_a: after increment of vertical scale factor 321 !! - tilde_e3t_a: after increment of vertical scale factor 310 322 !! in z_tilde case 311 323 !! - e3(t/u/v)_a … … 410 422 un_td(ji,jj,jk) = rn_ahe3 * umask(ji,jj,jk) * e2_e1u(ji,jj) & 411 423 & * ( tilde_e3t_b(ji,jj,jk) - tilde_e3t_b(ji+1,jj ,jk) ) 412 vn_td(ji,jj,jk) = rn_ahe3 * vmask(ji,jj,jk) * e1_e2v(ji,jj) & 424 vn_td(ji,jj,jk) = rn_ahe3 * vmask(ji,jj,jk) * e1_e2v(ji,jj) & 413 425 & * ( tilde_e3t_b(ji,jj,jk) - tilde_e3t_b(ji ,jj+1,jk) ) 414 426 zwu(ji,jj) = zwu(ji,jj) + un_td(ji,jj,jk) … … 460 472 WRITE(numout, *) 'at i, j, k=', ijk_max 461 473 WRITE(numout, *) 'MIN( tilde_e3t_a(:,:,:) / e3t_0(:,:,:) ) =', z_tmin 462 WRITE(numout, *) 'at i, j, k=', ijk_min 474 WRITE(numout, *) 'at i, j, k=', ijk_min 463 475 CALL ctl_stop( 'STOP', 'MAX( ABS( tilde_e3t_a(:,:,: ) ) / e3t_0(:,:,:) ) too high') 464 476 ENDIF … … 575 587 !!---------------------------------------------------------------------- 576 588 !! *** ROUTINE dom_vvl_sf_update *** 577 !! 578 !! ** Purpose : for z tilde case: compute time filter and swap of scale factors 589 !! 590 !! ** Purpose : for z tilde case: compute time filter and swap of scale factors 579 591 !! compute all depths and related variables for next time step 580 592 !! write outputs and restart file … … 586 598 !! ** Action : - tilde_e3t_(b/n) ready for next time step 587 599 !! - Recompute: 588 !! e3(u/v)_b 589 !! e3w(:,:,:,Kmm) 590 !! e3(u/v)w_b 591 !! e3(u/v)w_n 600 !! e3(u/v)_b 601 !! e3w(:,:,:,Kmm) 602 !! e3(u/v)w_b 603 !! e3(u/v)w_n 592 604 !! gdept(:,:,:,Kmm), gdepw(:,:,:,Kmm) and gde3w 593 605 !! h(u/v) and h(u/v)r … … 620 632 tilde_e3t_b(:,:,:) = tilde_e3t_n(:,:,:) 621 633 ELSE 622 tilde_e3t_b(:,:,:) = tilde_e3t_n(:,:,:) & 634 tilde_e3t_b(:,:,:) = tilde_e3t_n(:,:,:) & 623 635 & + rn_atfp * ( tilde_e3t_b(:,:,:) - 2.0_wp * tilde_e3t_n(:,:,:) + tilde_e3t_a(:,:,:) ) 624 636 ENDIF … … 632 644 ! - ML - e3u(:,:,:,Kbb) and e3v(:,:,:,Kbb) are already computed in dynnxt 633 645 ! - JC - hu(:,:,:,Kbb), hv(:,:,:,:,Kbb), hur_b, hvr_b also 634 646 635 647 CALL dom_vvl_interpol( e3u(:,:,:,Kmm), e3f(:,:,:), 'F' ) 636 648 637 649 ! Vertical scale factor interpolations 638 650 CALL dom_vvl_interpol( e3t(:,:,:,Kmm), e3w(:,:,:,Kmm), 'W' ) … … 653 665 gdepw(ji,jj,jk,Kmm) = gdepw(ji,jj,jk-1,Kmm) + e3t(ji,jj,jk-1,Kmm) 654 666 gdept(ji,jj,jk,Kmm) = zcoef * ( gdepw(ji,jj,jk ,Kmm) + 0.5 * e3w(ji,jj,jk,Kmm) ) & 655 & + (1-zcoef) * ( gdept(ji,jj,jk-1,Kmm) + e3w(ji,jj,jk,Kmm) ) 667 & + (1-zcoef) * ( gdept(ji,jj,jk-1,Kmm) + e3w(ji,jj,jk,Kmm) ) 656 668 gde3w(ji,jj,jk) = gdept(ji,jj,jk,Kmm) - ssh(ji,jj,Kmm) 657 669 END_3D … … 772 784 !!--------------------------------------------------------------------- 773 785 !! *** ROUTINE dom_vvl_rst *** 774 !! 786 !! 775 787 !! ** Purpose : Read or write VVL file in restart file 776 788 !! … … 789 801 !!---------------------------------------------------------------------- 790 802 ! 791 IF( TRIM(cdrw) == 'READ' ) THEN ! Read/initialise 803 IF( TRIM(cdrw) == 'READ' ) THEN ! Read/initialise 792 804 ! ! =============== 793 805 IF( ln_rstart ) THEN !* Read the restart file … … 808 820 CALL iom_get( numror, jpdom_autoglo, 'e3t_b', e3t(:,:,:,Kbb), ldxios = lrxios ) 809 821 CALL iom_get( numror, jpdom_autoglo, 'e3t_n', e3t(:,:,:,Kmm), ldxios = lrxios ) 810 ! needed to restart if land processor not computed 822 ! needed to restart if land processor not computed 811 823 IF(lwp) write(numout,*) 'dom_vvl_rst : e3t(:,:,:,Kbb) and e3t(:,:,:,Kmm) found in restart files' 812 WHERE ( tmask(:,:,:) == 0.0_wp ) 824 WHERE ( tmask(:,:,:) == 0.0_wp ) 813 825 e3t(:,:,:,Kmm) = e3t_0(:,:,:) 814 826 e3t(:,:,:,Kbb) = e3t_0(:,:,:) … … 873 885 ! 874 886 875 IF( ll_wd ) THEN ! MJB ll_wd edits start here - these are essential 887 IF( ll_wd ) THEN ! MJB ll_wd edits start here - these are essential 876 888 ! 877 889 IF( cn_cfg == 'wad' ) THEN … … 908 920 CALL ctl_stop( 'dom_vvl_rst: ht_0 must be positive at potentially wet points' ) 909 921 ENDIF 910 END DO 911 END DO 922 END DO 923 END DO 912 924 ! 913 925 ELSE … … 950 962 CALL iom_rstput( kt, nitrst, numrow, 'tilde_e3t_n', tilde_e3t_n(:,:,:), ldxios = lwxios) 951 963 END IF 952 ! ! -------------! 964 ! ! -------------! 953 965 IF( ln_vvl_ztilde ) THEN ! z_tilde case ! 954 966 ! ! ------------ ! … … 965 977 !!--------------------------------------------------------------------- 966 978 !! *** ROUTINE dom_vvl_ctl *** 967 !! 979 !! 968 980 !! ** Purpose : Control the consistency between namelist options 969 981 !! for vertical coordinate … … 974 986 & ln_vvl_zstar_at_eqtor , rn_ahe3 , rn_rst_e3t , & 975 987 & rn_lf_cutoff , rn_zdef_max , ln_vvl_dbg ! not yet implemented: ln_vvl_kepe 976 !!---------------------------------------------------------------------- 988 !!---------------------------------------------------------------------- 977 989 ! 978 990 READ ( numnam_ref, nam_vvl, IOSTAT = ios, ERR = 901) … … 1031 1043 END SUBROUTINE dom_vvl_ctl 1032 1044 1045 #endif 1046 1033 1047 !!====================================================================== 1034 1048 END MODULE domvvl -
NEMO/branches/2020/dev_r12527_Gurvan_ShallowWater/src/OCE/DOM/istate.F90
r12489 r13151 43 43 !! * Substitutions 44 44 # include "do_loop_substitute.h90" 45 # include "domzgr_substitute.h90" 45 46 !!---------------------------------------------------------------------- 46 47 !! NEMO/OCE 4.0 , NEMO Consortium (2018) … … 59 60 ! 60 61 INTEGER :: ji, jj, jk ! dummy loop indices 62 REAL(wp), DIMENSION(jpi,jpj,jpk) :: zgdept ! 3D table !!st patch to use gdept subtitute 61 63 !!gm see comment further down 62 64 REAL(wp), ALLOCATABLE, DIMENSION(:,:,:,:) :: zuvd ! U & V data workspace … … 115 117 ! 116 118 ELSE ! user defined initial T and S 117 CALL usr_def_istate( gdept(:,:,:,Kbb), tmask, ts(:,:,:,:,Kbb), uu(:,:,:,Kbb), vv(:,:,:,Kbb), ssh(:,:,Kbb) ) 119 DO jk = 1, jpk 120 zgdept(:,:,jk) = gdept(:,:,jk,Kbb) 121 END DO 122 CALL usr_def_istate( zgdept, tmask, ts(:,:,:,:,Kbb), uu(:,:,:,Kbb), vv(:,:,:,Kbb), ssh(:,:,Kbb) ) 118 123 ENDIF 119 124 ts (:,:,:,:,Kmm) = ts (:,:,:,:,Kbb) ! set now values from to before ones … … 127 132 !!gm POTENTIAL BUG : 128 133 !!gm ISSUE : if ssh(:,:,Kbb) /= 0 then, in non linear free surface, the e3._n, e3._b should be recomputed 129 !! as well as gdept and gdepw.... !!!!!134 !! as well as gdept_ and gdepw_.... !!!!! 130 135 !! ===>>>> probably a call to domvvl initialisation here.... 131 136 -
NEMO/branches/2020/dev_r12527_Gurvan_ShallowWater/src/OCE/DYN/divhor.F90
r12377 r13151 21 21 USE dom_oce ! ocean space and time domain 22 22 USE sbc_oce, ONLY : ln_rnf ! river runoff 23 USE sbcrnf , ONLY : sbc_rnf_div ! river runoff 23 USE sbcrnf , ONLY : sbc_rnf_div ! river runoff 24 24 USE isf_oce, ONLY : ln_isf ! ice shelf 25 25 USE isfhdiv, ONLY : isf_hdiv ! ice shelf 26 #if defined key_asminc 26 #if defined key_asminc 27 27 USE asminc ! Assimilation increment 28 28 #endif … … 40 40 !! * Substitutions 41 41 # include "do_loop_substitute.h90" 42 # include "domzgr_substitute.h90" 42 43 !!---------------------------------------------------------------------- 43 44 !! NEMO/OCE 4.0 , NEMO Consortium (2018) 44 !! $Id$ 45 !! $Id$ 45 46 !! Software governed by the CeCILL license (see ./LICENSE) 46 47 !!---------------------------------------------------------------------- … … 50 51 !!---------------------------------------------------------------------- 51 52 !! *** ROUTINE div_hor *** 52 !! 53 !! 53 54 !! ** Purpose : compute the horizontal divergence at now time-step 54 55 !! 55 56 !! ** Method : the now divergence is computed as : 56 57 !! hdiv = 1/(e1e2t*e3t) ( di[e2u*e3u un] + dj[e1v*e3v vn] ) 57 !! and correct with runoff inflow (div_rnf) and cross land flow (div_cla) 58 !! and correct with runoff inflow (div_rnf) and cross land flow (div_cla) 58 59 !! 59 60 !! ** Action : - update hdiv, the now horizontal divergence … … 78 79 DO_3D_00_00( 1, jpkm1 ) 79 80 hdiv(ji,jj,jk) = ( e2u(ji ,jj) * e3u(ji ,jj,jk,Kmm) * uu(ji ,jj,jk,Kmm) & 80 & 81 & 82 & 81 & - e2u(ji-1,jj) * e3u(ji-1,jj,jk,Kmm) * uu(ji-1,jj,jk,Kmm) & 82 & + e1v(ji,jj ) * e3v(ji,jj ,jk,Kmm) * vv(ji,jj ,jk,Kmm) & 83 & - e1v(ji,jj-1) * e3v(ji,jj-1,jk,Kmm) * vv(ji,jj-1,jk,Kmm) ) & 83 84 & * r1_e1e2t(ji,jj) / e3t(ji,jj,jk,Kmm) 84 85 END_3D … … 95 96 IF( ln_rnf ) CALL sbc_rnf_div( hdiv, Kmm ) !== runoffs ==! (update hdiv field) 96 97 ! 97 #if defined key_asminc 98 #if defined key_asminc 98 99 IF( ln_sshinc .AND. ln_asmiau ) CALL ssh_asm_div( kt, Kbb, Kmm, hdiv ) !== SSH assimilation ==! (update hdiv field) 99 ! 100 ! 100 101 #endif 101 102 ! … … 107 108 ! 108 109 END SUBROUTINE div_hor 109 110 110 111 !!====================================================================== 111 112 END MODULE divhor -
NEMO/branches/2020/dev_r12527_Gurvan_ShallowWater/src/OCE/DYN/dynadv_cen2.F90
r12377 r13151 28 28 !! * Substitutions 29 29 # include "do_loop_substitute.h90" 30 # include "domzgr_substitute.h90" 30 31 !!---------------------------------------------------------------------- 31 32 !! NEMO/OCE 4.0 , NEMO Consortium (2018) … … 79 80 DO_2D_00_00 80 81 puu(ji,jj,jk,Krhs) = puu(ji,jj,jk,Krhs) - ( zfu_t(ji+1,jj,jk) - zfu_t(ji,jj ,jk) & 81 & + zfv_f(ji ,jj,jk) - zfv_f(ji,jj-1,jk) ) * r1_e1e2u(ji,jj) / e3u(ji,jj,jk,Kmm) 82 & + zfv_f(ji ,jj,jk) - zfv_f(ji,jj-1,jk) ) * r1_e1e2u(ji,jj) & 83 & / e3u(ji,jj,jk,Kmm) 82 84 pvv(ji,jj,jk,Krhs) = pvv(ji,jj,jk,Krhs) - ( zfu_f(ji,jj ,jk) - zfu_f(ji-1,jj,jk) & 83 & + zfv_t(ji,jj+1,jk) - zfv_t(ji ,jj,jk) ) * r1_e1e2v(ji,jj) / e3v(ji,jj,jk,Kmm) 85 & + zfv_t(ji,jj+1,jk) - zfv_t(ji ,jj,jk) ) * r1_e1e2v(ji,jj) & 86 & / e3v(ji,jj,jk,Kmm) 84 87 END_2D 85 88 END DO … … 115 118 END DO 116 119 DO_3D_00_00( 1, jpkm1 ) 117 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) / e3u(ji,jj,jk,Kmm) 118 pvv(ji,jj,jk,Krhs) = pvv(ji,jj,jk,Krhs) - ( zfv_vw(ji,jj,jk) - zfv_vw(ji,jj,jk+1) ) * r1_e1e2v(ji,jj) / e3v(ji,jj,jk,Kmm) 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 & / e3u(ji,jj,jk,Kmm) 122 pvv(ji,jj,jk,Krhs) = pvv(ji,jj,jk,Krhs) - ( zfv_vw(ji,jj,jk) - zfv_vw(ji,jj,jk+1) ) * r1_e1e2v(ji,jj) & 123 & / e3v(ji,jj,jk,Kmm) 119 124 END_3D 120 125 ! -
NEMO/branches/2020/dev_r12527_Gurvan_ShallowWater/src/OCE/DYN/dynadv_ubs.F90
r12377 r13151 34 34 !! * Substitutions 35 35 # include "do_loop_substitute.h90" 36 # include "domzgr_substitute.h90" 36 37 !!---------------------------------------------------------------------- 37 38 !! NEMO/OCE 4.0 , NEMO Consortium (2018) … … 169 170 DO_2D_00_00 170 171 puu(ji,jj,jk,Krhs) = puu(ji,jj,jk,Krhs) - ( zfu_t(ji+1,jj,jk) - zfu_t(ji,jj ,jk) & 171 & + zfv_f(ji ,jj,jk) - zfv_f(ji,jj-1,jk) ) * r1_e1e2u(ji,jj) / e3u(ji,jj,jk,Kmm) 172 & + zfv_f(ji ,jj,jk) - zfv_f(ji,jj-1,jk) ) * r1_e1e2u(ji,jj) & 173 & / e3u(ji,jj,jk,Kmm) 172 174 pvv(ji,jj,jk,Krhs) = pvv(ji,jj,jk,Krhs) - ( zfu_f(ji,jj ,jk) - zfu_f(ji-1,jj,jk) & 173 & + zfv_t(ji,jj+1,jk) - zfv_t(ji ,jj,jk) ) * r1_e1e2v(ji,jj) / e3v(ji,jj,jk,Kmm) 175 & + zfv_t(ji,jj+1,jk) - zfv_t(ji ,jj,jk) ) * r1_e1e2v(ji,jj) & 176 & / e3v(ji,jj,jk,Kmm) 174 177 END_2D 175 178 END DO … … 206 209 END DO 207 210 DO_3D_00_00( 1, jpkm1 ) 208 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) / e3u(ji,jj,jk,Kmm) 209 pvv(ji,jj,jk,Krhs) = pvv(ji,jj,jk,Krhs) - ( zfv_vw(ji,jj,jk) - zfv_vw(ji,jj,jk+1) ) * r1_e1e2v(ji,jj) / e3v(ji,jj,jk,Kmm) 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 & / e3u(ji,jj,jk,Kmm) 213 pvv(ji,jj,jk,Krhs) = pvv(ji,jj,jk,Krhs) - ( zfv_vw(ji,jj,jk) - zfv_vw(ji,jj,jk+1) ) * r1_e1e2v(ji,jj) & 214 & / e3v(ji,jj,jk,Kmm) 210 215 END_3D 211 216 ! -
NEMO/branches/2020/dev_r12527_Gurvan_ShallowWater/src/OCE/DYN/dynatf.F90
r12489 r13151 13 13 !! - ! 2002-10 (C. Talandier, A-M. Treguier) Open boundary cond. 14 14 !! 2.0 ! 2005-11 (V. Garnier) Surface pressure gradient organization 15 !! 2.3 ! 2007-07 (D. Storkey) Calls to BDY routines. 15 !! 2.3 ! 2007-07 (D. Storkey) Calls to BDY routines. 16 16 !! 3.2 ! 2009-06 (G. Madec, R.Benshila) re-introduce the vvl option 17 17 !! 3.3 ! 2010-09 (D. Storkey, E.O'Dea) Bug fix for BDY module … … 22 22 !! 4.1 ! 2019-08 (A. Coward, D. Storkey) Rename dynnxt.F90 -> dynatf.F90. Now just does time filtering. 23 23 !!------------------------------------------------------------------------- 24 24 25 25 !!---------------------------------------------------------------------------------------------- 26 26 !! dyn_atf : apply Asselin time filtering to "now" velocities and vertical scale factors … … 42 42 USE trdken ! trend manager: kinetic energy 43 43 USE isf_oce , ONLY: ln_isf ! ice shelf 44 USE isfdynatf , ONLY: isf_dynatf ! ice shelf volume filter correction subroutine 44 USE isfdynatf , ONLY: isf_dynatf ! ice shelf volume filter correction subroutine 45 45 ! 46 46 USE in_out_manager ! I/O manager … … 59 59 PUBLIC dyn_atf ! routine called by step.F90 60 60 61 #if defined key_qco 62 !!---------------------------------------------------------------------- 63 !! 'key_qco' EMPTY ROUTINE Quasi-Eulerian vertical coordonate 64 !!---------------------------------------------------------------------- 65 CONTAINS 66 67 SUBROUTINE dyn_atf ( kt, Kbb, Kmm, Kaa, puu, pvv, pe3t, pe3u, pe3v ) 68 INTEGER , INTENT(in ) :: kt ! ocean time-step index 69 INTEGER , INTENT(in ) :: Kbb, Kmm, Kaa ! before and after time level indices 70 REAL(wp), DIMENSION(jpi,jpj,jpk,jpt), INTENT(inout) :: puu, pvv ! velocities to be time filtered 71 REAL(wp), DIMENSION(jpi,jpj,jpk,jpt), INTENT(inout) :: pe3t, pe3u, pe3v ! scale factors to be time filtered 72 73 WRITE(*,*) 'dyn_atf: You should not have seen this print! error?', kt 74 END SUBROUTINE dyn_atf 75 76 #else 77 61 78 !! * Substitutions 62 79 # include "do_loop_substitute.h90" 63 80 !!---------------------------------------------------------------------- 64 81 !! NEMO/OCE 4.0 , NEMO Consortium (2018) 65 !! $Id$ 82 !! $Id$ 66 83 !! Software governed by the CeCILL license (see ./LICENSE) 67 84 !!---------------------------------------------------------------------- … … 71 88 !!---------------------------------------------------------------------- 72 89 !! *** ROUTINE dyn_atf *** 73 !! 74 !! ** Purpose : Finalize after horizontal velocity. Apply the boundary 90 !! 91 !! ** Purpose : Finalize after horizontal velocity. Apply the boundary 75 92 !! condition on the after velocity and apply the Asselin time 76 93 !! filter to the now fields. … … 79 96 !! estimate (ln_dynspg_ts=T) 80 97 !! 81 !! * Apply lateral boundary conditions on after velocity 98 !! * Apply lateral boundary conditions on after velocity 82 99 !! at the local domain boundaries through lbc_lnk call, 83 100 !! at the one-way open boundaries (ln_bdy=T), … … 86 103 !! * Apply the Asselin time filter to the now fields 87 104 !! arrays to start the next time step: 88 !! (puu(Kmm),pvv(Kmm)) = (puu(Kmm),pvv(Kmm)) 105 !! (puu(Kmm),pvv(Kmm)) = (puu(Kmm),pvv(Kmm)) 89 106 !! + rn_atfp [ (puu(Kbb),pvv(Kbb)) + (puu(Kaa),pvv(Kaa)) - 2 (puu(Kmm),pvv(Kmm)) ] 90 107 !! Note that with flux form advection and non linear free surface, … … 92 109 !! As a result, dyn_atf MUST be called after tra_atf. 93 110 !! 94 !! ** Action : puu(Kmm),pvv(Kmm) filtered now horizontal velocity 111 !! ** Action : puu(Kmm),pvv(Kmm) filtered now horizontal velocity 95 112 !!---------------------------------------------------------------------- 96 113 INTEGER , INTENT(in ) :: kt ! ocean time-step index … … 103 120 REAL(wp) :: zve3a, zve3n, zve3b, z1_2dt ! - - 104 121 REAL(wp), ALLOCATABLE, DIMENSION(:,:) :: zue, zve, zwfld 105 REAL(wp), ALLOCATABLE, DIMENSION(:,:,:) :: ze3t_f, ze3u_f, ze3v_f, zua, zva 122 REAL(wp), ALLOCATABLE, DIMENSION(:,:,:) :: ze3t_f, ze3u_f, ze3v_f, zua, zva 106 123 !!---------------------------------------------------------------------- 107 124 ! … … 131 148 ! 132 149 IF( .NOT.ln_bt_fw ) THEN 133 ! Remove advective velocity from "now velocities" 134 ! prior to asselin filtering 135 ! In the forward case, this is done below after asselin filtering 136 ! so that asselin contribution is removed at the same time 150 ! Remove advective velocity from "now velocities" 151 ! prior to asselin filtering 152 ! In the forward case, this is done below after asselin filtering 153 ! so that asselin contribution is removed at the same time 137 154 DO jk = 1, jpkm1 138 155 puu(:,:,jk,Kmm) = ( puu(:,:,jk,Kmm) - un_adv(:,:)*r1_hu(:,:,Kmm) + uu_b(:,:,Kmm) )*umask(:,:,jk) 139 156 pvv(:,:,jk,Kmm) = ( pvv(:,:,jk,Kmm) - vn_adv(:,:)*r1_hv(:,:,Kmm) + vv_b(:,:,Kmm) )*vmask(:,:,jk) 140 END DO 157 END DO 141 158 ENDIF 142 159 ENDIF 143 160 144 161 ! Update after velocity on domain lateral boundaries 145 ! -------------------------------------------------- 162 ! -------------------------------------------------- 146 163 # if defined key_agrif 147 164 CALL Agrif_dyn( kt ) !* AGRIF zoom boundaries … … 198 215 zwfld(:,:) = emp_b(:,:) - emp(:,:) 199 216 IF ( ln_rnf ) zwfld(:,:) = zwfld(:,:) - ( rnf_b(:,:) - rnf(:,:) ) 217 200 218 DO jk = 1, jpkm1 201 219 ze3t_f(:,:,jk) = ze3t_f(:,:,jk) - zcoef * zwfld(:,:) * tmask(:,:,jk) & 202 & * pe3t(:,:,jk,Kmm) / ( ht(:,:) + 1._wp - ssmask(:,:) ) 220 & * pe3t(:,:,jk,Kmm) / ( ht(:,:) + 1._wp - ssmask(:,:) ) 203 221 END DO 204 222 ! … … 237 255 pvv(ji,jj,jk,Kmm) = ( zve3n + rn_atfp * ( zve3b - 2._wp * zve3n + zve3a ) ) / ze3v_f(ji,jj,jk) 238 256 END_3D 239 pe3u(:,:,1:jpkm1,Kmm) = ze3u_f(:,:,1:jpkm1) 257 pe3u(:,:,1:jpkm1,Kmm) = ze3u_f(:,:,1:jpkm1) 240 258 pe3v(:,:,1:jpkm1,Kmm) = ze3v_f(:,:,1:jpkm1) 241 259 ! … … 248 266 IF( ln_dynspg_ts .AND. ln_bt_fw ) THEN 249 267 ! Revert filtered "now" velocities to time split estimate 250 ! Doing it here also means that asselin filter contribution is removed 268 ! Doing it here also means that asselin filter contribution is removed 251 269 zue(:,:) = pe3u(:,:,1,Kmm) * puu(:,:,1,Kmm) * umask(:,:,1) 252 zve(:,:) = pe3v(:,:,1,Kmm) * pvv(:,:,1,Kmm) * vmask(:,:,1) 270 zve(:,:) = pe3v(:,:,1,Kmm) * pvv(:,:,1,Kmm) * vmask(:,:,1) 253 271 DO jk = 2, jpkm1 254 272 zue(:,:) = zue(:,:) + pe3u(:,:,jk,Kmm) * puu(:,:,jk,Kmm) * umask(:,:,jk) 255 zve(:,:) = zve(:,:) + pe3v(:,:,jk,Kmm) * pvv(:,:,jk,Kmm) * vmask(:,:,jk) 273 zve(:,:) = zve(:,:) + pe3v(:,:,jk,Kmm) * pvv(:,:,jk,Kmm) * vmask(:,:,jk) 256 274 END DO 257 275 DO jk = 1, jpkm1 … … 305 323 IF(sn_cfctl%l_prtctl) CALL prt_ctl( tab3d_1=puu(:,:,:,Kaa), clinfo1=' nxt - puu(:,:,:,Kaa): ', mask1=umask, & 306 324 & tab3d_2=pvv(:,:,:,Kaa), clinfo2=' pvv(:,:,:,Kaa): ' , mask2=vmask ) 307 ! 325 ! 308 326 IF( ln_dynspg_ts ) DEALLOCATE( zue, zve ) 309 327 IF( l_trddyn ) DEALLOCATE( zua, zva ) … … 312 330 END SUBROUTINE dyn_atf 313 331 332 #endif 333 314 334 !!========================================================================= 315 335 END MODULE dynatf -
NEMO/branches/2020/dev_r12527_Gurvan_ShallowWater/src/OCE/DYN/dynhpg.F90
r12377 r13151 43 43 USE in_out_manager ! I/O manager 44 44 USE prtctl ! Print control 45 USE lbclnk ! lateral boundary condition 45 USE lbclnk ! lateral boundary condition 46 46 USE lib_mpp ! MPP library 47 47 USE eosbn2 ! compute density … … 76 76 !! * Substitutions 77 77 # include "do_loop_substitute.h90" 78 # include "domzgr_substitute.h90" 79 78 80 !!---------------------------------------------------------------------- 79 81 !! NEMO/OCE 4.0 , NEMO Consortium (2018) … … 204 206 ! 205 207 IF( ioptio /= 1 ) CALL ctl_stop( 'NO or several hydrostatic pressure gradient options used' ) 206 ! 208 ! 207 209 IF(lwp) THEN 208 210 WRITE(numout,*) … … 217 219 WRITE(numout,*) 218 220 ENDIF 219 ! 221 ! 220 222 END SUBROUTINE dyn_hpg_init 221 223 … … 427 429 zcpx(ji,jj) = 0._wp 428 430 END IF 429 431 430 432 ll_tmp1 = MIN( ssh(ji,jj,Kmm) , ssh(ji,jj+1,Kmm) ) > & 431 433 & MAX( -ht_0(ji,jj) , -ht_0(ji,jj+1) ) .AND. & … … 452 454 DO_2D_00_00 453 455 ! hydrostatic pressure gradient along s-surfaces 454 zhpi(ji,jj,1) = zcoef0 * ( e3w(ji+1,jj ,1,Kmm) * ( znad + rhd(ji+1,jj ,1) ) & 455 & - e3w(ji ,jj ,1,Kmm) * ( znad + rhd(ji ,jj ,1) ) ) * r1_e1u(ji,jj) 456 zhpj(ji,jj,1) = zcoef0 * ( e3w(ji ,jj+1,1,Kmm) * ( znad + rhd(ji ,jj+1,1) ) & 457 & - e3w(ji ,jj ,1,Kmm) * ( znad + rhd(ji ,jj ,1) ) ) * r1_e2v(ji,jj) 456 zhpi(ji,jj,1) = & 457 & zcoef0 * ( e3w(ji+1,jj ,1,Kmm) * ( znad + rhd(ji+1,jj ,1) ) & 458 & - e3w(ji ,jj ,1,Kmm) * ( znad + rhd(ji ,jj ,1) ) ) & 459 & * r1_e1u(ji,jj) 460 zhpj(ji,jj,1) = & 461 & zcoef0 * ( e3w(ji ,jj+1,1,Kmm) * ( znad + rhd(ji ,jj+1,1) ) & 462 & - e3w(ji ,jj ,1,Kmm) * ( znad + rhd(ji ,jj ,1) ) ) & 463 & * r1_e2v(ji,jj) 458 464 ! s-coordinate pressure gradient correction 459 465 zuap = -zcoef0 * ( rhd (ji+1,jj,1) + rhd (ji,jj,1) + 2._wp * znad ) & … … 464 470 IF( ln_wd_il ) THEN 465 471 zhpi(ji,jj,1) = zhpi(ji,jj,1) * zcpx(ji,jj) 466 zhpj(ji,jj,1) = zhpj(ji,jj,1) * zcpy(ji,jj) 472 zhpj(ji,jj,1) = zhpj(ji,jj,1) * zcpy(ji,jj) 467 473 zuap = zuap * zcpx(ji,jj) 468 474 zvap = zvap * zcpy(ji,jj) … … 478 484 ! hydrostatic pressure gradient along s-surfaces 479 485 zhpi(ji,jj,jk) = zhpi(ji,jj,jk-1) + zcoef0 * r1_e1u(ji,jj) & 480 & * ( e3w(ji+1,jj,jk,Kmm) * ( rhd(ji+1,jj,jk) + rhd(ji+1,jj,jk-1) + 2*znad )&481 & 486 & * ( e3w(ji+1,jj,jk,Kmm) * ( rhd(ji+1,jj,jk) + rhd(ji+1,jj,jk-1) + 2*znad ) & 487 & - e3w(ji ,jj,jk,Kmm) * ( rhd(ji ,jj,jk) + rhd(ji ,jj,jk-1) + 2*znad ) ) 482 488 zhpj(ji,jj,jk) = zhpj(ji,jj,jk-1) + zcoef0 * r1_e2v(ji,jj) & 483 & 484 & 489 & * ( e3w(ji,jj+1,jk,Kmm) * ( rhd(ji,jj+1,jk) + rhd(ji,jj+1,jk-1) + 2*znad ) & 490 & - e3w(ji,jj ,jk,Kmm) * ( rhd(ji,jj, jk) + rhd(ji,jj ,jk-1) + 2*znad ) ) 485 491 ! s-coordinate pressure gradient correction 486 492 zuap = -zcoef0 * ( rhd (ji+1,jj ,jk) + rhd (ji,jj,jk) + 2._wp * znad ) & … … 491 497 IF( ln_wd_il ) THEN 492 498 zhpi(ji,jj,jk) = zhpi(ji,jj,jk) * zcpx(ji,jj) 493 zhpj(ji,jj,jk) = zhpj(ji,jj,jk) * zcpy(ji,jj) 499 zhpj(ji,jj,jk) = zhpj(ji,jj,jk) * zcpy(ji,jj) 494 500 zuap = zuap * zcpx(ji,jj) 495 501 zvap = zvap * zcpy(ji,jj) … … 522 528 !! pvv(:,:,:,Krhs) = pvv(:,:,:,Krhs) - 1/e2v * zhpj 523 529 !! iceload is added 524 !! 530 !! 525 531 !! ** Action : - Update (puu(:,:,:,Krhs),pvv(:,:,:,Krhs)) with the now hydrastatic pressure trend 526 532 !!---------------------------------------------------------------------- … … 540 546 znad=1._wp ! To use density and not density anomaly 541 547 ! 542 ! ! iniitialised to 0. zhpi zhpi 548 ! ! iniitialised to 0. zhpi zhpi 543 549 zhpi(:,:,:) = 0._wp ; zhpj(:,:,:) = 0._wp 544 550 … … 554 560 CALL eos( zts_top, risfdep, zrhdtop_oce ) 555 561 556 !================================================================================== 557 !===== Compute surface value ===================================================== 562 !================================================================================== 563 !===== Compute surface value ===================================================== 558 564 !================================================================================== 559 565 DO_2D_00_00 … … 567 573 & - 0.5_wp * e3w(ji,jj,ikt,Kmm) & 568 574 & * ( 2._wp * znad + rhd(ji,jj,ikt) + zrhdtop_oce(ji,jj) ) & 569 & + ( risfload(ji+1,jj) - risfload(ji,jj)) ) 575 & + ( risfload(ji+1,jj) - risfload(ji,jj)) ) 570 576 zhpj(ji,jj,1) = zcoef0 / e2v(ji,jj) * ( 0.5_wp * e3w(ji,jj+1,iktp1j,Kmm) & 571 577 & * ( 2._wp * znad + rhd(ji,jj+1,iktp1j) + zrhdtop_oce(ji,jj+1) ) & 572 & - 0.5_wp * e3w(ji,jj,ikt,Kmm) & 578 & - 0.5_wp * e3w(ji,jj,ikt,Kmm) & 573 579 & * ( 2._wp * znad + rhd(ji,jj,ikt) + zrhdtop_oce(ji,jj) ) & 574 & + ( risfload(ji,jj+1) - risfload(ji,jj)) ) 580 & + ( risfload(ji,jj+1) - risfload(ji,jj)) ) 575 581 ! s-coordinate pressure gradient correction (=0 if z coordinate) 576 582 zuap = -zcoef0 * ( rhd (ji+1,jj,1) + rhd (ji,jj,1) + 2._wp * znad ) & … … 582 588 pvv(ji,jj,1,Krhs) = pvv(ji,jj,1,Krhs) + (zhpj(ji,jj,1) + zvap) * vmask(ji,jj,1) 583 589 END_2D 584 !================================================================================== 585 !===== Compute interior value ===================================================== 590 !================================================================================== 591 !===== Compute interior value ===================================================== 586 592 !================================================================================== 587 593 ! interior value (2=<jk=<jpkm1) … … 589 595 ! hydrostatic pressure gradient along s-surfaces 590 596 zhpi(ji,jj,jk) = zhpi(ji,jj,jk-1) + zcoef0 / e1u(ji,jj) & 591 & * ( e3w(ji+1,jj,jk,Kmm) * ( rhd(ji+1,jj,jk) + rhd(ji+1,jj,jk-1) + 2*znad ) * wmask(ji+1,jj,jk) & 592 & - e3w(ji ,jj,jk,Kmm) * ( rhd(ji ,jj,jk) + rhd(ji ,jj,jk-1) + 2*znad ) * wmask(ji ,jj,jk) ) 597 & * ( e3w(ji+1,jj,jk,Kmm) & 598 & * ( rhd(ji+1,jj,jk) + rhd(ji+1,jj,jk-1) + 2*znad ) * wmask(ji+1,jj,jk) & 599 & - e3w(ji ,jj,jk,Kmm) & 600 & * ( rhd(ji ,jj,jk) + rhd(ji ,jj,jk-1) + 2*znad ) * wmask(ji ,jj,jk) ) 593 601 zhpj(ji,jj,jk) = zhpj(ji,jj,jk-1) + zcoef0 / e2v(ji,jj) & 594 & * ( e3w(ji,jj+1,jk,Kmm) * ( rhd(ji,jj+1,jk) + rhd(ji,jj+1,jk-1) + 2*znad ) * wmask(ji,jj+1,jk) & 595 & - e3w(ji,jj ,jk,Kmm) * ( rhd(ji,jj, jk) + rhd(ji,jj ,jk-1) + 2*znad ) * wmask(ji,jj ,jk) ) 602 & * ( e3w(ji,jj+1,jk,Kmm) & 603 & * ( rhd(ji,jj+1,jk) + rhd(ji,jj+1,jk-1) + 2*znad ) * wmask(ji,jj+1,jk) & 604 & - e3w(ji,jj ,jk,Kmm) & 605 & * ( rhd(ji,jj, jk) + rhd(ji,jj ,jk-1) + 2*znad ) * wmask(ji,jj ,jk) ) 596 606 ! s-coordinate pressure gradient correction 597 607 zuap = -zcoef0 * ( rhd (ji+1,jj ,jk) + rhd (ji,jj,jk) + 2._wp * znad ) & … … 650 660 zcpx(ji,jj) = 0._wp 651 661 END IF 652 662 653 663 ll_tmp1 = MIN( ssh(ji,jj,Kmm) , ssh(ji,jj+1,Kmm) ) > & 654 664 & MAX( -ht_0(ji,jj) , -ht_0(ji,jj+1) ) .AND. & … … 771 781 !------------------------------------------------------------- 772 782 773 !!bug gm : e3w-gde3w = 0.5*e3w .... and gde3w(2)-gde3w(1)=e3w(2) .... to be verified774 ! true if gde3w is really defined as the sum of the e3w scale factors as, it seems to me, it should be783 !!bug gm : e3w-gde3w(:,:,:) = 0.5*e3w .... and gde3w(:,:,2)-gde3w(:,:,1)=e3w(:,:,2,Kmm) .... to be verified 784 ! true if gde3w(:,:,:) is really defined as the sum of the e3w scale factors as, it seems to me, it should be 775 785 776 786 DO_2D_00_00 … … 825 835 IF( ln_wd_il ) THEN 826 836 zhpi(ji,jj,1) = zhpi(ji,jj,1) * zcpx(ji,jj) 827 zhpj(ji,jj,1) = zhpj(ji,jj,1) * zcpy(ji,jj) 837 zhpj(ji,jj,1) = zhpj(ji,jj,1) * zcpy(ji,jj) 828 838 ENDIF 829 839 ! add to the general momentum trend … … 845 855 IF( ln_wd_il ) THEN 846 856 zhpi(ji,jj,jk) = zhpi(ji,jj,jk) * zcpx(ji,jj) 847 zhpj(ji,jj,jk) = zhpj(ji,jj,jk) * zcpy(ji,jj) 857 zhpj(ji,jj,jk) = zhpj(ji,jj,jk) * zcpy(ji,jj) 848 858 ENDIF 849 859 ! add to the general momentum trend … … 916 926 zcpx(ji,jj) = ABS( (ssh(ji+1,jj,Kmm) + ht_0(ji+1,jj) - ssh(ji,jj,Kmm) - ht_0(ji,jj)) & 917 927 & / (ssh(ji+1,jj,Kmm) - ssh(ji ,jj,Kmm)) ) 918 928 919 929 zcpx(ji,jj) = max(min( zcpx(ji,jj) , 1.0_wp),0.0_wp) 920 930 ELSE 921 931 zcpx(ji,jj) = 0._wp 922 932 END IF 923 933 924 934 ll_tmp1 = MIN( ssh(ji,jj,Kmm) , ssh(ji,jj+1,Kmm) ) > & 925 935 & MAX( -ht_0(ji,jj) , -ht_0(ji,jj+1) ) .AND. & … … 1002 1012 !!gm BUG ? if it is ssh at u- & v-point then it should be: 1003 1013 ! zsshu_n(ji,jj) = (e1e2t(ji,jj) * ssh(ji,jj,Kmm) + e1e2t(ji+1,jj) * ssh(ji+1,jj,Kmm)) * & 1004 ! & r1_e1e2u(ji,jj) * umask(ji,jj,1) * 0.5_wp 1014 ! & r1_e1e2u(ji,jj) * umask(ji,jj,1) * 0.5_wp 1005 1015 ! zsshv_n(ji,jj) = (e1e2t(ji,jj) * ssh(ji,jj,Kmm) + e1e2t(ji,jj+1) * ssh(ji,jj+1,Kmm)) * & 1006 ! & r1_e1e2v(ji,jj) * vmask(ji,jj,1) * 0.5_wp 1016 ! & r1_e1e2v(ji,jj) * vmask(ji,jj,1) * 0.5_wp 1007 1017 !!gm not this: 1008 1018 zsshu_n(ji,jj) = (e1e2u(ji,jj) * ssh(ji,jj,Kmm) + e1e2u(ji+1, jj) * ssh(ji+1,jj,Kmm)) * & 1009 & r1_e1e2u(ji,jj) * umask(ji,jj,1) * 0.5_wp 1019 & r1_e1e2u(ji,jj) * umask(ji,jj,1) * 0.5_wp 1010 1020 zsshv_n(ji,jj) = (e1e2v(ji,jj) * ssh(ji,jj,Kmm) + e1e2v(ji+1, jj) * ssh(ji,jj+1,Kmm)) * & 1011 & r1_e1e2v(ji,jj) * vmask(ji,jj,1) * 0.5_wp 1021 & r1_e1e2v(ji,jj) * vmask(ji,jj,1) * 0.5_wp 1012 1022 END_2D 1013 1023 … … 1015 1025 1016 1026 DO_2D_00_00 1017 zu(ji,jj,1) = - ( e3u(ji,jj,1,Kmm) - zsshu_n(ji,jj) * znad) 1027 zu(ji,jj,1) = - ( e3u(ji,jj,1,Kmm) - zsshu_n(ji,jj) * znad) 1018 1028 zv(ji,jj,1) = - ( e3v(ji,jj,1,Kmm) - zsshv_n(ji,jj) * znad) 1019 1029 END_2D … … 1098 1108 zdpdx2 = zdpdx2 * zcpx(ji,jj) * wdrampu(ji,jj) 1099 1109 ENDIF 1100 puu(ji,jj,jk,Krhs) = puu(ji,jj,jk,Krhs) + (zdpdx1 + zdpdx2) * umask(ji,jj,jk) 1110 puu(ji,jj,jk,Krhs) = puu(ji,jj,jk,Krhs) + (zdpdx1 + zdpdx2) * umask(ji,jj,jk) 1101 1111 ENDIF 1102 1112 … … 1154 1164 ENDIF 1155 1165 IF( ln_wd_il ) THEN 1156 zdpdy1 = zdpdy1 * zcpy(ji,jj) * wdrampv(ji,jj) 1157 zdpdy2 = zdpdy2 * zcpy(ji,jj) * wdrampv(ji,jj) 1166 zdpdy1 = zdpdy1 * zcpy(ji,jj) * wdrampv(ji,jj) 1167 zdpdy2 = zdpdy2 * zcpy(ji,jj) * wdrampv(ji,jj) 1158 1168 ENDIF 1159 1169 … … 1189 1199 !!---------------------------------------------------------------------- 1190 1200 ! 1191 !!gm WHAT !!!!! THIS IS VERY DANGEROUS !!!!! 1201 !!gm WHAT !!!!! THIS IS VERY DANGEROUS !!!!! 1192 1202 jpi = size(fsp,1) 1193 1203 jpj = size(fsp,2) … … 1359 1369 !!====================================================================== 1360 1370 END MODULE dynhpg 1361 -
NEMO/branches/2020/dev_r12527_Gurvan_ShallowWater/src/OCE/DYN/dynldf_iso.F90
r12377 r13151 22 22 USE ldftra ! lateral physics: eddy diffusivity 23 23 USE zdf_oce ! ocean vertical physics 24 USE ldfslp ! iso-neutral slopes 24 USE ldfslp ! iso-neutral slopes 25 25 ! 26 26 USE in_out_manager ! I/O manager … … 36 36 37 37 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: akzu, akzv !: vertical component of rotated lateral viscosity 38 39 REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:) :: zfuw, zdiu, zdju, zdj1u ! 2D workspace (dyn_ldf_iso) 38 39 REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:) :: zfuw, zdiu, zdju, zdj1u ! 2D workspace (dyn_ldf_iso) 40 40 REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:) :: zfvw, zdiv, zdjv, zdj1v ! - - 41 41 42 42 !! * Substitutions 43 43 # include "do_loop_substitute.h90" 44 # include "domzgr_substitute.h90" 44 45 !!---------------------------------------------------------------------- 45 46 !! NEMO/OCE 4.0 , NEMO Consortium (2018) … … 53 54 !! *** ROUTINE dyn_ldf_iso_alloc *** 54 55 !!---------------------------------------------------------------------- 55 ALLOCATE( akzu(jpi,jpj,jpk) , zfuw(jpi,jpk) , zdiu(jpi,jpk) , zdju(jpi,jpk) , zdj1u(jpi,jpk) , & 56 ALLOCATE( akzu(jpi,jpj,jpk) , zfuw(jpi,jpk) , zdiu(jpi,jpk) , zdju(jpi,jpk) , zdj1u(jpi,jpk) , & 56 57 & akzv(jpi,jpj,jpk) , zfvw(jpi,jpk) , zdiv(jpi,jpk) , zdjv(jpi,jpk) , zdj1v(jpi,jpk) , STAT=dyn_ldf_iso_alloc ) 57 58 ! … … 63 64 !!---------------------------------------------------------------------- 64 65 !! *** ROUTINE dyn_ldf_iso *** 65 !! 66 !! 66 67 !! ** Purpose : Compute the before trend of the rotated laplacian 67 68 !! operator of lateral momentum diffusion except the diagonal … … 137 138 ! 138 139 ENDIF 139 140 140 141 zaht_0 = 0.5_wp * rn_Ud * rn_Ld ! aht_0 from namtra_ldf = zaht_max 141 142 142 143 ! ! =============== 143 144 DO jk = 1, jpkm1 ! Horizontal slab … … 161 162 162 163 ! -----f----- 163 ! Horizontal fluxes on U | 164 ! Horizontal fluxes on U | 164 165 ! --------------------=== t u t 165 ! | 166 ! | 166 167 ! i-flux at t-point -----f----- 167 168 168 169 IF( ln_zps ) THEN ! z-coordinate - partial steps : min(e3u) 169 170 DO_2D_00_01 170 zabe1 = ( ahmt(ji,jj,jk)+rn_ahm_b ) * e2t(ji,jj) * MIN( e3u(ji,jj,jk,Kmm), e3u(ji-1,jj,jk,Kmm) ) * r1_e1t(ji,jj) 171 zabe1 = ( ahmt(ji,jj,jk)+rn_ahm_b ) * e2t(ji,jj) & 172 & * MIN( e3u(ji ,jj,jk,Kmm), & 173 & e3u(ji-1,jj,jk,Kmm) ) * r1_e1t(ji,jj) 171 174 172 175 zmskt = 1._wp / MAX( umask(ji-1,jj,jk )+umask(ji,jj,jk+1) & … … 181 184 ELSE ! other coordinate system (zco or sco) : e3t 182 185 DO_2D_00_01 183 zabe1 = ( ahmt(ji,jj,jk)+rn_ahm_b ) * e2t(ji,jj) * e3t(ji,jj,jk,Kmm) * r1_e1t(ji,jj) 186 zabe1 = ( ahmt(ji,jj,jk)+rn_ahm_b ) & 187 & * e2t(ji,jj) * e3t(ji,jj,jk,Kmm) * r1_e1t(ji,jj) 184 188 185 189 zmskt = 1._wp / MAX( umask(ji-1,jj,jk ) + umask(ji,jj,jk+1) & … … 196 200 ! j-flux at f-point 197 201 DO_2D_10_10 198 zabe2 = ( ahmf(ji,jj,jk) + rn_ahm_b ) * e1f(ji,jj) * e3f(ji,jj,jk) * r1_e2f(ji,jj) 202 zabe2 = ( ahmf(ji,jj,jk) + rn_ahm_b ) & 203 & * e1f(ji,jj) * e3f(ji,jj,jk) * r1_e2f(ji,jj) 199 204 200 205 zmskf = 1._wp / MAX( umask(ji,jj+1,jk )+umask(ji,jj,jk+1) & … … 215 220 216 221 DO_2D_00_10 217 zabe1 = ( ahmf(ji,jj,jk) + rn_ahm_b ) * e2f(ji,jj) * e3f(ji,jj,jk) * r1_e1f(ji,jj) 222 zabe1 = ( ahmf(ji,jj,jk) + rn_ahm_b ) & 223 & * e2f(ji,jj) * e3f(ji,jj,jk) * r1_e1f(ji,jj) 218 224 219 225 zmskf = 1._wp / MAX( vmask(ji+1,jj,jk )+vmask(ji,jj,jk+1) & … … 230 236 IF( ln_zps ) THEN ! z-coordinate - partial steps : min(e3u) 231 237 DO_2D_01_10 232 zabe2 = ( ahmt(ji,jj,jk)+rn_ahm_b ) * e1t(ji,jj) * MIN( e3v(ji,jj,jk,Kmm), e3v(ji,jj-1,jk,Kmm) ) * r1_e2t(ji,jj) 238 zabe2 = ( ahmt(ji,jj,jk)+rn_ahm_b ) * e1t(ji,jj) & 239 & * MIN( e3v(ji,jj ,jk,Kmm), & 240 & e3v(ji,jj-1,jk,Kmm) ) * r1_e2t(ji,jj) 233 241 234 242 zmskt = 1._wp / MAX( vmask(ji,jj-1,jk )+vmask(ji,jj,jk+1) & … … 243 251 ELSE ! other coordinate system (zco or sco) : e3t 244 252 DO_2D_01_10 245 zabe2 = ( ahmt(ji,jj,jk)+rn_ahm_b ) * e1t(ji,jj) * e3t(ji,jj,jk,Kmm) * r1_e2t(ji,jj) 253 zabe2 = ( ahmt(ji,jj,jk)+rn_ahm_b ) & 254 & * e1t(ji,jj) * e3t(ji,jj,jk,Kmm) * r1_e2t(ji,jj) 246 255 247 256 zmskt = 1./MAX( vmask(ji,jj-1,jk )+vmask(ji,jj,jk+1) & … … 261 270 DO_2D_00_00 262 271 puu(ji,jj,jk,Krhs) = puu(ji,jj,jk,Krhs) + ( ziut(ji+1,jj) - ziut(ji,jj ) & 263 & + zjuf(ji ,jj) - zjuf(ji,jj-1) ) * r1_e1e2u(ji,jj) / e3u(ji,jj,jk,Kmm) 272 & + zjuf(ji ,jj) - zjuf(ji,jj-1) ) * r1_e1e2u(ji,jj) & 273 & / e3u(ji,jj,jk,Kmm) 264 274 pvv(ji,jj,jk,Krhs) = pvv(ji,jj,jk,Krhs) + ( zivf(ji,jj ) - zivf(ji-1,jj) & 265 & + zjvt(ji,jj+1) - zjvt(ji,jj ) ) * r1_e1e2v(ji,jj) / e3v(ji,jj,jk,Kmm) 275 & + zjvt(ji,jj+1) - zjvt(ji,jj ) ) * r1_e1e2v(ji,jj) & 276 & / e3v(ji,jj,jk,Kmm) 266 277 END_2D 267 278 ! ! =============== … … 278 289 ! ! =============== 279 290 280 291 281 292 ! I. vertical trends associated with the lateral mixing 282 293 ! ===================================================== … … 375 386 DO jk = 1, jpkm1 376 387 DO ji = 2, jpim1 377 puu(ji,jj,jk,Krhs) = puu(ji,jj,jk,Krhs) + ( zfuw(ji,jk) - zfuw(ji,jk+1) ) * r1_e1e2u(ji,jj) / e3u(ji,jj,jk,Kmm) 378 pvv(ji,jj,jk,Krhs) = pvv(ji,jj,jk,Krhs) + ( zfvw(ji,jk) - zfvw(ji,jk+1) ) * r1_e1e2v(ji,jj) / e3v(ji,jj,jk,Kmm) 388 puu(ji,jj,jk,Krhs) = puu(ji,jj,jk,Krhs) + ( zfuw(ji,jk) - zfuw(ji,jk+1) ) * r1_e1e2u(ji,jj) & 389 & / e3u(ji,jj,jk,Kmm) 390 pvv(ji,jj,jk,Krhs) = pvv(ji,jj,jk,Krhs) + ( zfvw(ji,jk) - zfvw(ji,jk+1) ) * r1_e1e2v(ji,jj) & 391 & / e3v(ji,jj,jk,Kmm) 379 392 END DO 380 393 END DO -
NEMO/branches/2020/dev_r12527_Gurvan_ShallowWater/src/OCE/DYN/dynldf_lap_blp.F90
r12377 r13151 14 14 USE dom_oce ! ocean space and time domain 15 15 USE ldfdyn ! lateral diffusion: eddy viscosity coef. 16 USE ldfslp ! iso-neutral slopes 16 USE ldfslp ! iso-neutral slopes 17 17 USE zdf_oce ! ocean vertical physics 18 18 ! … … 28 28 !! * Substitutions 29 29 # include "do_loop_substitute.h90" 30 # include "domzgr_substitute.h90" 30 31 !!---------------------------------------------------------------------- 31 32 !! NEMO/OCE 4.0 , NEMO Consortium (2018) 32 !! $Id$ 33 !! $Id$ 33 34 !! Software governed by the CeCILL license (see ./LICENSE) 34 35 !!---------------------------------------------------------------------- … … 38 39 !!---------------------------------------------------------------------- 39 40 !! *** ROUTINE dyn_ldf_lap *** 40 !! 41 !! ** Purpose : Compute the before horizontal momentum diffusive 41 !! 42 !! ** Purpose : Compute the before horizontal momentum diffusive 42 43 !! trend and add it to the general trend of momentum equation. 43 44 !! 44 !! ** Method : The Laplacian operator apply on horizontal velocity is 45 !! writen as : grad_h( ahmt div_h(U )) - curl_h( ahmf curl_z(U) ) 45 !! ** Method : The Laplacian operator apply on horizontal velocity is 46 !! writen as : grad_h( ahmt div_h(U )) - curl_h( ahmf curl_z(U) ) 46 47 !! 47 48 !! ** Action : - pu_rhs, pv_rhs increased by the harmonic operator applied on pu, pv. … … 76 77 !!gm open question here : e3f at before or now ? probably now... 77 78 !!gm note that ahmf has already been multiplied by fmask 78 zcur(ji-1,jj-1) = ahmf(ji-1,jj-1,jk) * e3f(ji-1,jj-1,jk) * r1_e1e2f(ji-1,jj-1) & 79 & * ( e2v(ji ,jj-1) * pv(ji ,jj-1,jk) - e2v(ji-1,jj-1) * pv(ji-1,jj-1,jk) & 80 & - e1u(ji-1,jj ) * pu(ji-1,jj ,jk) + e1u(ji-1,jj-1) * pu(ji-1,jj-1,jk) ) 79 zcur(ji-1,jj-1) = & 80 & ahmf(ji-1,jj-1,jk) * e3f(ji-1,jj-1,jk) * r1_e1e2f(ji-1,jj-1) & 81 & * ( e2v(ji ,jj-1) * pv(ji ,jj-1,jk) - e2v(ji-1,jj-1) * pv(ji-1,jj-1,jk) & 82 & - e1u(ji-1,jj ) * pu(ji-1,jj ,jk) + e1u(ji-1,jj-1) * pu(ji-1,jj-1,jk) ) 81 83 ! ! ahm * div (computed from 2 to jpi/jpj) 82 84 !!gm note that ahmt has already been multiplied by tmask 83 zdiv(ji,jj) = ahmt(ji,jj,jk) * r1_e1e2t(ji,jj) / e3t(ji,jj,jk,Kbb) & 84 & * ( e2u(ji,jj)*e3u(ji,jj,jk,Kbb) * pu(ji,jj,jk) - e2u(ji-1,jj)*e3u(ji-1,jj,jk,Kbb) * pu(ji-1,jj,jk) & 85 & + e1v(ji,jj)*e3v(ji,jj,jk,Kbb) * pv(ji,jj,jk) - e1v(ji,jj-1)*e3v(ji,jj-1,jk,Kbb) * pv(ji,jj-1,jk) ) 85 zdiv(ji,jj) = & 86 & ahmt(ji,jj,jk) * r1_e1e2t(ji,jj) / e3t(ji,jj,jk,Kbb) & 87 & * ( e2u(ji,jj)*e3u(ji,jj,jk,Kbb) * pu(ji,jj,jk) & 88 & - e2u(ji-1,jj)*e3u(ji-1,jj,jk,Kbb) * pu(ji-1,jj,jk) & 89 & + e1v(ji,jj)*e3v(ji,jj,jk,Kbb) * pv(ji,jj,jk) & 90 & - e1v(ji,jj-1)*e3v(ji,jj-1,jk,Kbb) * pv(ji,jj-1,jk) ) 86 91 END_2D 87 92 ! 88 93 DO_2D_00_00 89 pu_rhs(ji,jj,jk) = pu_rhs(ji,jj,jk) + zsign * ( & 90 & - ( zcur(ji ,jj) - zcur(ji,jj-1) ) * r1_e2u(ji,jj) / e3u(ji,jj,jk,Kmm) & 91 & + ( zdiv(ji+1,jj) - zdiv(ji,jj ) ) * r1_e1u(ji,jj) ) 94 pu_rhs(ji,jj,jk) = pu_rhs(ji,jj,jk) + zsign * ( & 95 & - ( zcur(ji ,jj) - zcur(ji,jj-1) ) * r1_e2u(ji,jj) & 96 & / e3u(ji,jj,jk,Kmm) & 97 & + ( zdiv(ji+1,jj) - zdiv(ji,jj ) ) * r1_e1u(ji,jj) ) 92 98 ! 93 pv_rhs(ji,jj,jk) = pv_rhs(ji,jj,jk) + zsign * ( & 94 & ( zcur(ji,jj ) - zcur(ji-1,jj) ) * r1_e1v(ji,jj) / e3v(ji,jj,jk,Kmm) & 95 & + ( zdiv(ji,jj+1) - zdiv(ji ,jj) ) * r1_e2v(ji,jj) ) 99 pv_rhs(ji,jj,jk) = pv_rhs(ji,jj,jk) + zsign * ( & 100 & ( zcur(ji,jj ) - zcur(ji-1,jj) ) * r1_e1v(ji,jj) & 101 & / e3v(ji,jj,jk,Kmm) & 102 & + ( zdiv(ji,jj+1) - zdiv(ji ,jj) ) * r1_e2v(ji,jj) ) 96 103 END_2D 97 104 ! ! =============== … … 105 112 !!---------------------------------------------------------------------- 106 113 !! *** ROUTINE dyn_ldf_blp *** 107 !! 108 !! ** Purpose : Compute the before lateral momentum viscous trend 114 !! 115 !! ** Purpose : Compute the before lateral momentum viscous trend 109 116 !! and add it to the general trend of momentum equation. 110 117 !! -
NEMO/branches/2020/dev_r12527_Gurvan_ShallowWater/src/OCE/DYN/dynspg_ts.F90
r12489 r13151 87 87 !! * Substitutions 88 88 # include "do_loop_substitute.h90" 89 # include "domzgr_substitute.h90" 89 90 !!---------------------------------------------------------------------- 90 91 !! NEMO/OCE 4.0 , NEMO Consortium (2018) … … 161 162 REAL(wp), DIMENSION(jpi,jpj) :: zCdU_u, zCdU_v ! top/bottom stress at u- & v-points 162 163 REAL(wp), DIMENSION(jpi,jpj) :: zhU, zhV ! fluxes 164 REAL(wp), DIMENSION(jpi, jpj, jpk) :: ze3u, ze3v 163 165 ! 164 166 REAL(wp) :: zwdramp ! local scalar - only used if ln_wd_dl = .True. … … 227 229 ! != zu_frc = 1/H e3*d/dt(Ua) =! (Vertical mean of Ua, the 3D trends) 228 230 ! ! --------------------------- ! 229 zu_frc(:,:) = SUM( e3u(:,:,:,Kmm) * uu(:,:,:,Krhs) * umask(:,:,:) , DIM=3 ) * r1_hu(:,:,Kmm) 230 zv_frc(:,:) = SUM( e3v(:,:,:,Kmm) * vv(:,:,:,Krhs) * vmask(:,:,:) , DIM=3 ) * r1_hv(:,:,Kmm) 231 DO jk = 1 , jpk 232 ze3u(:,:,jk) = e3u(:,:,jk,Kmm) 233 ze3v(:,:,jk) = e3v(:,:,jk,Kmm) 234 END DO 235 ! 236 zu_frc(:,:) = SUM( ze3u(:,:,:) * uu(:,:,:,Krhs) * umask(:,:,:) , DIM=3 ) * r1_hu(:,:,Kmm) 237 zv_frc(:,:) = SUM( ze3v(:,:,:) * vv(:,:,:,Krhs) * vmask(:,:,:) , DIM=3 ) * r1_hv(:,:,Kmm) 231 238 ! 232 239 ! … … 250 257 zhV(:,:) = pvv_b(:,:,Kmm) * hv(:,:,Kmm) * e1v(:,:) ! NB: FULL domain : put a value in last row and column 251 258 ! 252 CALL dyn_cor_2d( h u(:,:,Kmm), hv(:,:,Kmm), puu_b(:,:,Kmm), pvv_b(:,:,Kmm), zhU, zhV, & ! <<== in259 CALL dyn_cor_2d( ht(:,:), hu(:,:,Kmm), hv(:,:,Kmm), puu_b(:,:,Kmm), pvv_b(:,:,Kmm), zhU, zhV, & ! <<== in 253 260 & zu_trd, zv_trd ) ! ==>> out 254 261 ! … … 567 574 ! at each time step. We however keep them constant here for optimization. 568 575 ! Recall that zhU and zhV hold fluxes at jn+0.5 (extrapolated not backward interpolated) 569 CALL dyn_cor_2d( zh up2_e, zhvp2_e, ua_e, va_e, zhU, zhV, zu_trd, zv_trd )576 CALL dyn_cor_2d( zhtp2_e, zhup2_e, zhvp2_e, ua_e, va_e, zhU, zhV, zu_trd, zv_trd ) 570 577 ! 571 578 ! Add tidal astronomical forcing if defined … … 1088 1095 ! 1089 1096 SELECT CASE( nvor_scheme ) 1090 CASE( np_EEN ) != EEN scheme using e3f (energy & enstrophy scheme)1097 CASE( np_EEN ) != EEN scheme using e3f energy & enstrophy scheme 1091 1098 SELECT CASE( nn_een_e3f ) !* ff_f/e3 at F-point 1092 1099 CASE ( 0 ) ! original formulation (masked averaging of e3t divided by 4) … … 1115 1122 END_2D 1116 1123 ! 1117 CASE( np_EET ) != EEN scheme using e3t (energy conserving scheme)1124 CASE( np_EET ) != EEN scheme using e3t energy conserving scheme 1118 1125 ftne(1,:) = 0._wp ; ftnw(1,:) = 0._wp ; ftse(1,:) = 0._wp ; ftsw(1,:) = 0._wp 1119 1126 DO_2D_01_01 … … 1179 1186 1180 1187 1181 SUBROUTINE dyn_cor_2d( ph u, phv, punb, pvnb, zhU, zhV, zu_trd, zv_trd )1188 SUBROUTINE dyn_cor_2d( pht, phu, phv, punb, pvnb, zhU, zhV, zu_trd, zv_trd ) 1182 1189 !!--------------------------------------------------------------------- 1183 1190 !! *** ROUTINE dyn_cor_2d *** … … 1187 1194 INTEGER :: ji ,jj ! dummy loop indices 1188 1195 REAL(wp) :: zx1, zx2, zy1, zy2, z1_hu, z1_hv ! - - 1189 REAL(wp), DIMENSION(jpi,jpj), INTENT(in ) :: ph u, phv, punb, pvnb, zhU, zhV1196 REAL(wp), DIMENSION(jpi,jpj), INTENT(in ) :: pht, phu, phv, punb, pvnb, zhU, zhV 1190 1197 REAL(wp), DIMENSION(jpi,jpj), INTENT( out) :: zu_trd, zv_trd 1191 1198 !!---------------------------------------------------------------------- … … 1196 1203 z1_hv = ssvmask(ji,jj) / ( phv(ji,jj) + 1._wp - ssvmask(ji,jj) ) 1197 1204 zu_trd(ji,jj) = + r1_4 * r1_e1e2u(ji,jj) * z1_hu & 1198 & * ( e1e2t(ji+1,jj)* ht(ji+1,jj)*ff_t(ji+1,jj) * ( pvnb(ji+1,jj) + pvnb(ji+1,jj-1) ) &1199 & + e1e2t(ji ,jj)* ht(ji ,jj)*ff_t(ji ,jj) * ( pvnb(ji ,jj) + pvnb(ji ,jj-1) ) )1205 & * ( e1e2t(ji+1,jj)*pht(ji+1,jj)*ff_t(ji+1,jj) * ( pvnb(ji+1,jj) + pvnb(ji+1,jj-1) ) & 1206 & + e1e2t(ji ,jj)*pht(ji ,jj)*ff_t(ji ,jj) * ( pvnb(ji ,jj) + pvnb(ji ,jj-1) ) ) 1200 1207 ! 1201 1208 zv_trd(ji,jj) = - r1_4 * r1_e1e2v(ji,jj) * z1_hv & 1202 & * ( e1e2t(ji,jj+1)* ht(ji,jj+1)*ff_t(ji,jj+1) * ( punb(ji,jj+1) + punb(ji-1,jj+1) ) &1203 & + e1e2t(ji,jj )* ht(ji,jj )*ff_t(ji,jj ) * ( punb(ji,jj ) + punb(ji-1,jj ) ) )1209 & * ( e1e2t(ji,jj+1)*pht(ji,jj+1)*ff_t(ji,jj+1) * ( punb(ji,jj+1) + punb(ji-1,jj+1) ) & 1210 & + e1e2t(ji,jj )*pht(ji,jj )*ff_t(ji,jj ) * ( punb(ji,jj ) + punb(ji-1,jj ) ) ) 1204 1211 END_2D 1205 1212 ! -
NEMO/branches/2020/dev_r12527_Gurvan_ShallowWater/src/OCE/DYN/dynvor.F90
r12377 r13151 15 15 !! 3.2 ! 2009-04 (R. Benshila) vvl: correction of een scheme 16 16 !! 3.3 ! 2010-10 (C. Ethe, G. Madec) reorganisation of initialisation phase 17 !! 3.7 ! 2014-04 (G. Madec) trend simplification: suppress jpdyn_trd_dat vorticity 17 !! 3.7 ! 2014-04 (G. Madec) trend simplification: suppress jpdyn_trd_dat vorticity 18 18 !! - ! 2014-06 (G. Madec) suppression of velocity curl from in-core memory 19 19 !! - ! 2016-12 (G. Madec, E. Clementi) add Stokes-Coriolis trends (ln_stcor=T) … … 70 70 INTEGER, PUBLIC, PARAMETER :: np_MIX = 5 ! MIX scheme 71 71 72 INTEGER :: ncor, nrvm, ntot ! choice of calculated vorticity 72 INTEGER :: ncor, nrvm, ntot ! choice of calculated vorticity 73 73 ! ! associated indices: 74 74 INTEGER, PUBLIC, PARAMETER :: np_COR = 1 ! Coriolis (planetary) … … 79 79 80 80 REAL(wp), ALLOCATABLE, DIMENSION(:,:) :: di_e2u_2 ! = di(e2u)/2 used in T-point metric term calculation 81 REAL(wp), ALLOCATABLE, DIMENSION(:,:) :: dj_e1v_2 ! = dj(e1v)/2 - - - - 81 REAL(wp), ALLOCATABLE, DIMENSION(:,:) :: dj_e1v_2 ! = dj(e1v)/2 - - - - 82 82 REAL(wp), ALLOCATABLE, DIMENSION(:,:) :: di_e2v_2e1e2f ! = di(e2u)/(2*e1e2f) used in F-point metric term calculation 83 REAL(wp), ALLOCATABLE, DIMENSION(:,:) :: dj_e1u_2e1e2f ! = dj(e1v)/(2*e1e2f) - - - - 84 83 REAL(wp), ALLOCATABLE, DIMENSION(:,:) :: dj_e1u_2e1e2f ! = dj(e1v)/(2*e1e2f) - - - - 84 85 85 REAL(wp) :: r1_4 = 0.250_wp ! =1/4 86 86 REAL(wp) :: r1_8 = 0.125_wp ! =1/8 87 87 REAL(wp) :: r1_12 = 1._wp / 12._wp ! 1/12 88 88 89 89 !! * Substitutions 90 90 # include "do_loop_substitute.h90" 91 # include "domzgr_substitute.h90" 92 91 93 !!---------------------------------------------------------------------- 92 94 !! NEMO/OCE 4.0 , NEMO Consortium (2018) … … 103 105 !! ** Action : - Update (puu(:,:,:,Krhs),pvv(:,:,:,Krhs)) with the now vorticity term trend 104 106 !! - save the trends in (ztrdu,ztrdv) in 2 parts (relative 105 !! and planetary vorticity trends) and send them to trd_dyn 107 !! and planetary vorticity trends) and send them to trd_dyn 106 108 !! for futher diagnostics (l_trddyn=T) 107 109 !!---------------------------------------------------------------------- … … 193 195 !! *** ROUTINE vor_enT *** 194 196 !! 195 !! ** Purpose : Compute the now total vorticity trend and add it to 197 !! ** Purpose : Compute the now total vorticity trend and add it to 196 198 !! the general trend of the momentum equation. 197 199 !! 198 !! ** Method : Trend evaluated using now fields (centered in time) 200 !! ** Method : Trend evaluated using now fields (centered in time) 199 201 !! and t-point evaluation of vorticity (planetary and relative). 200 202 !! conserves the horizontal kinetic energy. 201 !! The general trend of momentum is increased due to the vorticity 203 !! The general trend of momentum is increased due to the vorticity 202 204 !! term which is given by: 203 205 !! voru = 1/bu mj[ ( mi(mj(bf*rvor))+bt*f_t)/e3t mj[vn] ] … … 233 235 & - e1u(ji,jj+1) * pu(ji,jj+1,jk) + e1u(ji,jj) * pu(ji,jj,jk) ) * r1_e1e2f(ji,jj) 234 236 END_2D 235 IF( ln_dynvor_msk ) THEN ! mask/unmask relative vorticity 237 IF( ln_dynvor_msk ) THEN ! mask/unmask relative vorticity 236 238 DO_2D_10_10 237 239 zwz(ji,jj,jk) = zwz(ji,jj,jk) * fmask(ji,jj,jk) … … 248 250 & - e1u(ji,jj+1) * pu(ji,jj+1,jk) + e1u(ji,jj) * pu(ji,jj,jk) ) * r1_e1e2f(ji,jj) 249 251 END_2D 250 IF( ln_dynvor_msk ) THEN ! mask/unmask relative vorticity 252 IF( ln_dynvor_msk ) THEN ! mask/unmask relative vorticity 251 253 DO_2D_10_10 252 254 zwz(ji,jj,jk) = zwz(ji,jj,jk) * fmask(ji,jj,jk) … … 269 271 DO_2D_01_01 270 272 zwt(ji,jj) = r1_4 * ( zwz(ji-1,jj ,jk) + zwz(ji,jj ,jk) & 271 & + zwz(ji-1,jj-1,jk) + zwz(ji,jj-1,jk) ) * e1e2t(ji,jj)*e3t(ji,jj,jk,Kmm) 273 & + zwz(ji-1,jj-1,jk) + zwz(ji,jj-1,jk) ) & 274 & * e1e2t(ji,jj)*e3t(ji,jj,jk,Kmm) 272 275 END_2D 273 276 CASE ( np_MET ) !* metric term 274 277 DO_2D_01_01 275 zwt(ji,jj) = ( ( pv(ji,jj,jk) + pv(ji,jj-1,jk) ) * di_e2u_2(ji,jj) & 276 & - ( pu(ji,jj,jk) + pu(ji-1,jj,jk) ) * dj_e1v_2(ji,jj) ) * e3t(ji,jj,jk,Kmm) 278 zwt(ji,jj) = ( ( pv(ji,jj,jk) + pv(ji,jj-1,jk) ) * di_e2u_2(ji,jj) & 279 & - ( pu(ji,jj,jk) + pu(ji-1,jj,jk) ) * dj_e1v_2(ji,jj) ) & 280 & * e3t(ji,jj,jk,Kmm) 277 281 END_2D 278 282 CASE ( np_CRV ) !* Coriolis + relative vorticity 279 283 DO_2D_01_01 280 zwt(ji,jj) = ( ff_t(ji,jj) + r1_4 * ( zwz(ji-1,jj ,jk) + zwz(ji,jj ,jk) & 281 & + zwz(ji-1,jj-1,jk) + zwz(ji,jj-1,jk) ) ) * e1e2t(ji,jj)*e3t(ji,jj,jk,Kmm) 284 zwt(ji,jj) = ( ff_t(ji,jj) + r1_4 * ( zwz(ji-1,jj ,jk) + zwz(ji,jj ,jk) & 285 & + zwz(ji-1,jj-1,jk) + zwz(ji,jj-1,jk) ) ) & 286 & * e1e2t(ji,jj)*e3t(ji,jj,jk,Kmm) 282 287 END_2D 283 288 CASE ( np_CME ) !* Coriolis + metric 284 289 DO_2D_01_01 285 zwt(ji,jj) = ( ff_t(ji,jj) * e1e2t(ji,jj) & 286 & + ( pv(ji,jj,jk) + pv(ji,jj-1,jk) ) * di_e2u_2(ji,jj) & 287 & - ( pu(ji,jj,jk) + pu(ji-1,jj,jk) ) * dj_e1v_2(ji,jj) ) * e3t(ji,jj,jk,Kmm) 290 zwt(ji,jj) = ( ff_t(ji,jj) * e1e2t(ji,jj) & 291 & + ( pv(ji,jj,jk) + pv(ji,jj-1,jk) ) * di_e2u_2(ji,jj) & 292 & - ( pu(ji,jj,jk) + pu(ji-1,jj,jk) ) * dj_e1v_2(ji,jj) ) & 293 & * e3t(ji,jj,jk,Kmm) 288 294 END_2D 289 295 CASE DEFAULT ! error … … 298 304 ! 299 305 pv_rhs(ji,jj,jk) = pv_rhs(ji,jj,jk) - r1_4 * r1_e1e2v(ji,jj) / e3v(ji,jj,jk,Kmm) & 300 & * ( zwt(ji,jj+1) * ( pu(ji,jj+1,jk) + pu(ji-1,jj+1,jk) ) & 301 & + zwt(ji,jj ) * ( pu(ji,jj ,jk) + pu(ji-1,jj ,jk) ) ) 306 & * ( zwt(ji,jj+1) * ( pu(ji,jj+1,jk) + pu(ji-1,jj+1,jk) ) & 307 & + zwt(ji,jj ) * ( pu(ji,jj ,jk) + pu(ji-1,jj ,jk) ) ) 302 308 END_2D 303 309 ! ! =============== … … 311 317 !! *** ROUTINE vor_ene *** 312 318 !! 313 !! ** Purpose : Compute the now total vorticity trend and add it to 319 !! ** Purpose : Compute the now total vorticity trend and add it to 314 320 !! the general trend of the momentum equation. 315 321 !! 316 !! ** Method : Trend evaluated using now fields (centered in time) 322 !! ** Method : Trend evaluated using now fields (centered in time) 317 323 !! and the Sadourny (1975) flux form formulation : conserves the 318 324 !! horizontal kinetic energy. 319 !! The general trend of momentum is increased due to the vorticity 325 !! The general trend of momentum is increased due to the vorticity 320 326 !! term which is given by: 321 327 !! voru = 1/e1u mj-1[ (rvor+f)/e3f mi(e1v*e3v pvv(:,:,:,Kmm)) ] … … 350 356 SELECT CASE( kvor ) !== vorticity considered ==! 351 357 CASE ( np_COR ) !* Coriolis (planetary vorticity) 352 zwz(:,:) = ff_f(:,:) 358 zwz(:,:) = ff_f(:,:) 353 359 CASE ( np_RVO ) !* relative vorticity 354 360 DO_2D_10_10 … … 396 402 zx2 = zwx(ji ,jj) + zwx(ji ,jj+1) 397 403 pu_rhs(ji,jj,jk) = pu_rhs(ji,jj,jk) + r1_4 * r1_e1u(ji,jj) * ( zwz(ji ,jj-1) * zy1 + zwz(ji,jj) * zy2 ) 398 pv_rhs(ji,jj,jk) = pv_rhs(ji,jj,jk) - r1_4 * r1_e2v(ji,jj) * ( zwz(ji-1,jj ) * zx1 + zwz(ji,jj) * zx2 ) 404 pv_rhs(ji,jj,jk) = pv_rhs(ji,jj,jk) - r1_4 * r1_e2v(ji,jj) * ( zwz(ji-1,jj ) * zx1 + zwz(ji,jj) * zx2 ) 399 405 END_2D 400 406 ! ! =============== … … 446 452 SELECT CASE( kvor ) !== vorticity considered ==! 447 453 CASE ( np_COR ) !* Coriolis (planetary vorticity) 448 zwz(:,:) = ff_f(:,:) 454 zwz(:,:) = ff_f(:,:) 449 455 CASE ( np_RVO ) !* relative vorticity 450 456 DO_2D_10_10 … … 504 510 !! *** ROUTINE vor_een *** 505 511 !! 506 !! ** Purpose : Compute the now total vorticity trend and add it to 512 !! ** Purpose : Compute the now total vorticity trend and add it to 507 513 !! the general trend of the momentum equation. 508 514 !! 509 !! ** Method : Trend evaluated using now fields (centered in time) 510 !! and the Arakawa and Lamb (1980) flux form formulation : conserves 515 !! ** Method : Trend evaluated using now fields (centered in time) 516 !! and the Arakawa and Lamb (1980) flux form formulation : conserves 511 517 !! both the horizontal kinetic energy and the potential enstrophy 512 518 !! when horizontal divergence is zero (see the NEMO documentation) … … 545 551 CASE ( 0 ) ! original formulation (masked averaging of e3t divided by 4) 546 552 DO_2D_10_10 547 ze3f = ( e3t(ji,jj+1,jk,Kmm)*tmask(ji,jj+1,jk) + e3t(ji+1,jj+1,jk,Kmm)*tmask(ji+1,jj+1,jk) & 548 & + e3t(ji,jj ,jk,Kmm)*tmask(ji,jj ,jk) + e3t(ji+1,jj ,jk,Kmm)*tmask(ji+1,jj ,jk) ) 553 ze3f = ( e3t(ji ,jj+1,jk,Kmm)*tmask(ji ,jj+1,jk) & 554 & + e3t(ji+1,jj+1,jk,Kmm)*tmask(ji+1,jj+1,jk) & 555 & + e3t(ji ,jj ,jk,Kmm)*tmask(ji ,jj ,jk) & 556 & + e3t(ji+1,jj ,jk,Kmm)*tmask(ji+1,jj ,jk) ) 549 557 IF( ze3f /= 0._wp ) THEN ; z1_e3f(ji,jj) = 4._wp / ze3f 550 558 ELSE ; z1_e3f(ji,jj) = 0._wp … … 553 561 CASE ( 1 ) ! new formulation (masked averaging of e3t divided by the sum of mask) 554 562 DO_2D_10_10 555 ze3f = ( e3t(ji,jj+1,jk,Kmm)*tmask(ji,jj+1,jk) + e3t(ji+1,jj+1,jk,Kmm)*tmask(ji+1,jj+1,jk) & 556 & + e3t(ji,jj ,jk,Kmm)*tmask(ji,jj ,jk) + e3t(ji+1,jj ,jk,Kmm)*tmask(ji+1,jj ,jk) ) 563 ze3f = ( e3t(ji ,jj+1,jk,Kmm)*tmask(ji ,jj+1,jk) & 564 & + e3t(ji+1,jj+1,jk,Kmm)*tmask(ji+1,jj+1,jk) & 565 & + e3t(ji ,jj ,jk,Kmm)*tmask(ji ,jj ,jk) & 566 & + e3t(ji+1,jj ,jk,Kmm)*tmask(ji+1,jj ,jk) ) 557 567 zmsk = ( tmask(ji,jj+1,jk) + tmask(ji+1,jj+1,jk) & 558 568 & + tmask(ji,jj ,jk) + tmask(ji+1,jj ,jk) ) … … 644 654 !! *** ROUTINE vor_eeT *** 645 655 !! 646 !! ** Purpose : Compute the now total vorticity trend and add it to 656 !! ** Purpose : Compute the now total vorticity trend and add it to 647 657 !! the general trend of the momentum equation. 648 658 !! 649 !! ** Method : Trend evaluated using now fields (centered in time) 650 !! and the Arakawa and Lamb (1980) vector form formulation using 659 !! ** Method : Trend evaluated using now fields (centered in time) 660 !! and the Arakawa and Lamb (1980) vector form formulation using 651 661 !! a modified version of Arakawa and Lamb (1980) scheme (see vor_een). 652 !! The change consists in 662 !! The change consists in 653 663 !! Add this trend to the general momentum trend (pu_rhs,pv_rhs). 654 664 !! … … 667 677 REAL(wp) :: zua, zva ! local scalars 668 678 REAL(wp) :: zmsk, z1_e3t ! local scalars 669 REAL(wp), DIMENSION(jpi,jpj) :: zwx , zwy 679 REAL(wp), DIMENSION(jpi,jpj) :: zwx , zwy 670 680 REAL(wp), DIMENSION(jpi,jpj) :: ztnw, ztne, ztsw, ztse 671 681 REAL(wp), DIMENSION(jpi,jpj,jpk) :: zwz … … 827 837 ! 828 838 IF( ioptio /= 1 ) CALL ctl_stop( ' use ONE and ONLY one vorticity scheme' ) 829 ! 839 ! 830 840 IF(lwp) WRITE(numout,*) ! type of calculated vorticity (set ncor, nrvm, ntot) 831 841 ncor = np_COR ! planetary vorticity … … 836 846 ntot = np_COR ! - - 837 847 CASE( np_VEC_c2 ) 838 IF(lwp) WRITE(numout,*) ' ==>>> vector form dynamics : total vorticity = Coriolis + relative vorticity' 848 IF(lwp) WRITE(numout,*) ' ==>>> vector form dynamics : total vorticity = Coriolis + relative vorticity' 839 849 nrvm = np_RVO ! relative vorticity 840 ntot = np_CRV ! relative + planetary vorticity 850 ntot = np_CRV ! relative + planetary vorticity 841 851 CASE( np_FLX_c2 , np_FLX_ubs ) 842 852 IF(lwp) WRITE(numout,*) ' ==>>> flux form dynamics : total vorticity = Coriolis + metric term' … … 863 873 ! 864 874 END SELECT 865 875 866 876 IF(lwp) THEN ! Print the choice 867 877 WRITE(numout,*) … … 873 883 CASE( np_EEN ) ; WRITE(numout,*) ' ==>>> energy and enstrophy conserving scheme (EEN)' 874 884 CASE( np_MIX ) ; WRITE(numout,*) ' ==>>> mixed enstrophy/energy conserving scheme (MIX)' 875 END SELECT 885 END SELECT 876 886 ENDIF 877 887 ! -
NEMO/branches/2020/dev_r12527_Gurvan_ShallowWater/src/OCE/DYN/dynzad.F90
r12377 r13151 29 29 !! * Substitutions 30 30 # include "do_loop_substitute.h90" 31 # include "domzgr_substitute.h90" 31 32 !!---------------------------------------------------------------------- 32 33 !! NEMO/OCE 4.0 , NEMO Consortium (2018) … … 95 96 ! 96 97 DO_3D_00_00( 1, jpkm1 ) 97 puu(ji,jj,jk,Krhs) = puu(ji,jj,jk,Krhs) - ( zwuw(ji,jj,jk) + zwuw(ji,jj,jk+1) ) * r1_e1e2u(ji,jj) / e3u(ji,jj,jk,Kmm) 98 pvv(ji,jj,jk,Krhs) = pvv(ji,jj,jk,Krhs) - ( zwvw(ji,jj,jk) + zwvw(ji,jj,jk+1) ) * r1_e1e2v(ji,jj) / e3v(ji,jj,jk,Kmm) 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 & / e3u(ji,jj,jk,Kmm) 100 pvv(ji,jj,jk,Krhs) = pvv(ji,jj,jk,Krhs) - ( zwvw(ji,jj,jk) + zwvw(ji,jj,jk+1) ) * r1_e1e2v(ji,jj) & 101 & / e3v(ji,jj,jk,Kmm) 99 102 END_3D 100 103 -
NEMO/branches/2020/dev_r12527_Gurvan_ShallowWater/src/OCE/DYN/dynzdf.F90
r12489 r13151 38 38 !! * Substitutions 39 39 # include "do_loop_substitute.h90" 40 # include "domzgr_substitute.h90" 40 41 !!---------------------------------------------------------------------- 41 42 !! NEMO/OCE 4.0 , NEMO Consortium (2018) … … 55 56 !! ** Method : - Leap-Frog time stepping on all trends but the vertical mixing 56 57 !! u(after) = u(before) + 2*dt * u(rhs) vector form or linear free surf. 57 !! u(after) = ( e3u_b*u(before) + 2*dt * e3u_n*u(rhs) ) / e3u (after)otherwise58 !! u(after) = ( e3u_b*u(before) + 2*dt * e3u_n*u(rhs) ) / e3u_after otherwise 58 59 !! - update the after velocity with the implicit vertical mixing. 59 60 !! This requires to solver the following system: 60 !! u(after) = u(after) + 1/e3u (after) dk+1[ mi(avm) / e3uw(after)dk[ua] ]61 !! u(after) = u(after) + 1/e3u_after dk+1[ mi(avm) / e3uw_after dk[ua] ] 61 62 !! with the following surface/top/bottom boundary condition: 62 63 !! surface: wind stress input (averaged over kt-1/2 & kt+1/2) … … 112 113 ELSE ! applied on thickness weighted velocity 113 114 DO jk = 1, jpkm1 114 puu(:,:,jk,Kaa) = ( e3u(:,:,jk,Kbb) * puu(:,:,jk,Kbb) & 115 & + rDt * e3u(:,:,jk,Kmm) * puu(:,:,jk,Krhs) ) / e3u(:,:,jk,Kaa) * umask(:,:,jk) 116 pvv(:,:,jk,Kaa) = ( e3v(:,:,jk,Kbb) * pvv(:,:,jk,Kbb) & 117 & + rDt * e3v(:,:,jk,Kmm) * pvv(:,:,jk,Krhs) ) / e3v(:,:,jk,Kaa) * vmask(:,:,jk) 115 puu(:,:,jk,Kaa) = ( e3u(:,:,jk,Kbb) * puu(:,:,jk,Kbb) & 116 & + rDt * e3u(:,:,jk,Kmm) * puu(:,:,jk,Krhs) ) & 117 & / e3u(:,:,jk,Kaa) * umask(:,:,jk) 118 pvv(:,:,jk,Kaa) = ( e3v(:,:,jk,Kbb) * pvv(:,:,jk,Kbb) & 119 & + rDt * e3v(:,:,jk,Kmm) * pvv(:,:,jk,Krhs) ) & 120 & / e3v(:,:,jk,Kaa) * vmask(:,:,jk) 118 121 END DO 119 122 ENDIF … … 131 134 iku = mbku(ji,jj) ! ocean bottom level at u- and v-points 132 135 ikv = mbkv(ji,jj) ! (deepest ocean u- and v-points) 133 ze3ua = ( 1._wp - r_vvl ) * e3u(ji,jj,iku,Kmm) + r_vvl * e3u(ji,jj,iku,Kaa) 134 ze3va = ( 1._wp - r_vvl ) * e3v(ji,jj,ikv,Kmm) + r_vvl * e3v(ji,jj,ikv,Kaa) 136 ze3ua = ( 1._wp - r_vvl ) * e3u(ji,jj,iku,Kmm) & 137 & + r_vvl * e3u(ji,jj,iku,Kaa) 138 ze3va = ( 1._wp - r_vvl ) * e3v(ji,jj,ikv,Kmm) & 139 & + r_vvl * e3v(ji,jj,ikv,Kaa) 135 140 puu(ji,jj,iku,Kaa) = puu(ji,jj,iku,Kaa) + rDt * 0.5*( rCdU_bot(ji+1,jj)+rCdU_bot(ji,jj) ) * uu_b(ji,jj,Kaa) / ze3ua 136 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 … … 140 145 iku = miku(ji,jj) ! top ocean level at u- and v-points 141 146 ikv = mikv(ji,jj) ! (first wet ocean u- and v-points) 142 ze3ua = ( 1._wp - r_vvl ) * e3u(ji,jj,iku,Kmm) + r_vvl * e3u(ji,jj,iku,Kaa) 143 ze3va = ( 1._wp - r_vvl ) * e3v(ji,jj,ikv,Kmm) + r_vvl * e3v(ji,jj,ikv,Kaa) 147 ze3ua = ( 1._wp - r_vvl ) * e3u(ji,jj,iku,Kmm) & 148 & + r_vvl * e3u(ji,jj,iku,Kaa) 149 ze3va = ( 1._wp - r_vvl ) * e3v(ji,jj,ikv,Kmm) & 150 & + r_vvl * e3v(ji,jj,ikv,Kaa) 144 151 puu(ji,jj,iku,Kaa) = puu(ji,jj,iku,Kaa) + rDt * 0.5*( rCdU_top(ji+1,jj)+rCdU_top(ji,jj) ) * uu_b(ji,jj,Kaa) / ze3ua 145 152 pvv(ji,jj,ikv,Kaa) = pvv(ji,jj,ikv,Kaa) + rDt * 0.5*( rCdU_top(ji,jj+1)+rCdU_top(ji,jj) ) * vv_b(ji,jj,Kaa) / ze3va … … 156 163 CASE( np_lap_i ) ! rotated lateral mixing: add its vertical mixing (akzu) 157 164 DO_3D_00_00( 1, jpkm1 ) 158 ze3ua = ( 1._wp - r_vvl ) * e3u(ji,jj,jk,Kmm) + r_vvl * e3u(ji,jj,jk,Kaa) ! after scale factor at U-point 165 ze3ua = ( 1._wp - r_vvl ) * e3u(ji,jj,jk,Kmm) & 166 & + r_vvl * e3u(ji,jj,jk,Kaa) ! after scale factor at U-point 159 167 zzwi = - zdt * ( avm(ji+1,jj,jk ) + avm(ji,jj,jk ) + akzu(ji,jj,jk ) ) & 160 168 & / ( ze3ua * e3uw(ji,jj,jk ,Kmm) ) * wumask(ji,jj,jk ) … … 169 177 CASE DEFAULT ! iso-level lateral mixing 170 178 DO_3D_00_00( 1, jpkm1 ) 171 ze3ua = ( 1._wp - r_vvl ) * e3u(ji,jj,jk,Kmm) + r_vvl * e3u(ji,jj,jk,Kaa) ! after scale factor at U-point 172 zzwi = - zdt * ( avm(ji+1,jj,jk ) + avm(ji,jj,jk ) ) / ( ze3ua * e3uw(ji,jj,jk ,Kmm) ) * wumask(ji,jj,jk ) 173 zzws = - zdt * ( avm(ji+1,jj,jk+1) + avm(ji,jj,jk+1) ) / ( ze3ua * e3uw(ji,jj,jk+1,Kmm) ) * wumask(ji,jj,jk+1) 179 ze3ua = ( 1._wp - r_vvl ) * e3u(ji,jj,jk,Kmm) & ! after scale factor at U-point 180 & + r_vvl * e3u(ji,jj,jk,Kaa) 181 zzwi = - zdt * ( avm(ji+1,jj,jk ) + avm(ji,jj,jk ) ) & 182 & / ( ze3ua * e3uw(ji,jj,jk ,Kmm) ) * wumask(ji,jj,jk ) 183 zzws = - zdt * ( avm(ji+1,jj,jk+1) + avm(ji,jj,jk+1) ) & 184 & / ( ze3ua * e3uw(ji,jj,jk+1,Kmm) ) * wumask(ji,jj,jk+1) 174 185 zWui = ( wi(ji,jj,jk ) + wi(ji+1,jj,jk ) ) / ze3ua 175 186 zWus = ( wi(ji,jj,jk+1) + wi(ji+1,jj,jk+1) ) / ze3ua … … 181 192 DO_2D_00_00 182 193 zwi(ji,jj,1) = 0._wp 183 ze3ua = ( 1._wp - r_vvl ) * e3u(ji,jj,1,Kmm) + r_vvl * e3u(ji,jj,1,Kaa) 184 zzws = - zdt * ( avm(ji+1,jj,2) + avm(ji ,jj,2) ) / ( ze3ua * e3uw(ji,jj,2,Kmm) ) * wumask(ji,jj,2) 194 ze3ua = ( 1._wp - r_vvl ) * e3u(ji,jj,1,Kmm) & 195 & + r_vvl * e3u(ji,jj,1,Kaa) 196 zzws = - zdt * ( avm(ji+1,jj,2) + avm(ji ,jj,2) ) & 197 & / ( ze3ua * e3uw(ji,jj,2,Kmm) ) * wumask(ji,jj,2) 185 198 zWus = ( wi(ji ,jj,2) + wi(ji+1,jj,2) ) / ze3ua 186 199 zws(ji,jj,1 ) = zzws - zdt * MAX( zWus, 0._wp ) … … 191 204 CASE( np_lap_i ) ! rotated lateral mixing: add its vertical mixing (akzu) 192 205 DO_3D_00_00( 1, jpkm1 ) 193 ze3ua = ( 1._wp - r_vvl ) * e3u(ji,jj,jk,Kmm) + r_vvl * e3u(ji,jj,jk,Kaa) ! after scale factor at U-point 206 ze3ua = ( 1._wp - r_vvl ) * e3u(ji,jj,jk,Kmm) & 207 & + r_vvl * e3u(ji,jj,jk,Kaa) ! after scale factor at U-point 194 208 zzwi = - zdt * ( avm(ji+1,jj,jk ) + avm(ji,jj,jk ) + akzu(ji,jj,jk ) ) & 195 209 & / ( ze3ua * e3uw(ji,jj,jk ,Kmm) ) * wumask(ji,jj,jk ) … … 202 216 CASE DEFAULT ! iso-level lateral mixing 203 217 DO_3D_00_00( 1, jpkm1 ) 204 ze3ua = ( 1._wp - r_vvl ) * e3u(ji,jj,jk,Kmm) + r_vvl * e3u(ji,jj,jk,Kaa) ! after scale factor at U-point 205 zzwi = - zdt * ( avm(ji+1,jj,jk ) + avm(ji,jj,jk ) ) / ( ze3ua * e3uw(ji,jj,jk ,Kmm) ) * wumask(ji,jj,jk ) 206 zzws = - zdt * ( avm(ji+1,jj,jk+1) + avm(ji,jj,jk+1) ) / ( ze3ua * e3uw(ji,jj,jk+1,Kmm) ) * wumask(ji,jj,jk+1) 218 ze3ua = ( 1._wp - r_vvl ) * e3u(ji,jj,jk,Kmm) & 219 & + r_vvl * e3u(ji,jj,jk,Kaa) ! after scale factor at U-point 220 zzwi = - zdt * ( avm(ji+1,jj,jk ) + avm(ji,jj,jk ) ) & 221 & / ( ze3ua * e3uw(ji,jj,jk ,Kmm) ) * wumask(ji,jj,jk ) 222 zzws = - zdt * ( avm(ji+1,jj,jk+1) + avm(ji,jj,jk+1) ) & 223 & / ( ze3ua * e3uw(ji,jj,jk+1,Kmm) ) * wumask(ji,jj,jk+1) 207 224 zwi(ji,jj,jk) = zzwi 208 225 zws(ji,jj,jk) = zzws … … 226 243 DO_2D_00_00 227 244 iku = mbku(ji,jj) ! ocean bottom level at u- and v-points 228 ze3ua = ( 1._wp - r_vvl ) * e3u(ji,jj,iku,Kmm) + r_vvl * e3u(ji,jj,iku,Kaa) ! after scale factor at T-point 245 ze3ua = ( 1._wp - r_vvl ) * e3u(ji,jj,iku,Kmm) & 246 & + r_vvl * e3u(ji,jj,iku,Kaa) ! after scale factor at T-point 229 247 zwd(ji,jj,iku) = zwd(ji,jj,iku) - rDt * 0.5*( rCdU_bot(ji+1,jj)+rCdU_bot(ji,jj) ) / ze3ua 230 248 END_2D … … 233 251 !!gm top Cd is masked (=0 outside cavities) no need of test on mik>=2 ==>> it has been suppressed 234 252 iku = miku(ji,jj) ! ocean top level at u- and v-points 235 ze3ua = ( 1._wp - r_vvl ) * e3u(ji,jj,iku,Kmm) + r_vvl * e3u(ji,jj,iku,Kaa) ! after scale factor at T-point 253 ze3ua = ( 1._wp - r_vvl ) * e3u(ji,jj,iku,Kmm) & 254 & + r_vvl * e3u(ji,jj,iku,Kaa) ! after scale factor at T-point 236 255 zwd(ji,jj,iku) = zwd(ji,jj,iku) - rDt * 0.5*( rCdU_top(ji+1,jj)+rCdU_top(ji,jj) ) / ze3ua 237 256 END_2D … … 259 278 ! 260 279 DO_2D_00_00 261 ze3ua = ( 1._wp - r_vvl ) * e3u(ji,jj,1,Kmm) + r_vvl * e3u(ji,jj,1,Kaa) 280 ze3ua = ( 1._wp - r_vvl ) * e3u(ji,jj,1,Kmm) & 281 & + r_vvl * e3u(ji,jj,1,Kaa) 262 282 puu(ji,jj,1,Kaa) = puu(ji,jj,1,Kaa) + rDt * 0.5_wp * ( utau_b(ji,jj) + utau(ji,jj) ) & 263 283 & / ( ze3ua * rho0 ) * umask(ji,jj,1) … … 282 302 CASE( np_lap_i ) ! rotated lateral mixing: add its vertical mixing (akzv) 283 303 DO_3D_00_00( 1, jpkm1 ) 284 ze3va = ( 1._wp - r_vvl ) * e3v(ji,jj,jk,Kmm) + r_vvl * e3v(ji,jj,jk,Kaa) ! after scale factor at V-point 304 ze3va = ( 1._wp - r_vvl ) * e3v(ji,jj,jk,Kmm) & 305 & + r_vvl * e3v(ji,jj,jk,Kaa) ! after scale factor at V-point 285 306 zzwi = - zdt * ( avm(ji,jj+1,jk ) + avm(ji,jj,jk ) + akzv(ji,jj,jk ) ) & 286 307 & / ( ze3va * e3vw(ji,jj,jk ,Kmm) ) * wvmask(ji,jj,jk ) … … 295 316 CASE DEFAULT ! iso-level lateral mixing 296 317 DO_3D_00_00( 1, jpkm1 ) 297 ze3va = ( 1._wp - r_vvl ) * e3v(ji,jj,jk,Kmm) + r_vvl * e3v(ji,jj,jk,Kaa) ! after scale factor at V-point 298 zzwi = - zdt * ( avm(ji,jj+1,jk ) + avm(ji,jj,jk ) ) / ( ze3va * e3vw(ji,jj,jk ,Kmm) ) * wvmask(ji,jj,jk ) 299 zzws = - zdt * ( avm(ji,jj+1,jk+1) + avm(ji,jj,jk+1) ) / ( ze3va * e3vw(ji,jj,jk+1,Kmm) ) * wvmask(ji,jj,jk+1) 318 ze3va = ( 1._wp - r_vvl ) * e3v(ji,jj,jk,Kmm) & 319 & + r_vvl * e3v(ji,jj,jk,Kaa) ! after scale factor at V-point 320 zzwi = - zdt * ( avm(ji,jj+1,jk ) + avm(ji,jj,jk ) ) & 321 & / ( ze3va * e3vw(ji,jj,jk ,Kmm) ) * wvmask(ji,jj,jk ) 322 zzws = - zdt * ( avm(ji,jj+1,jk+1) + avm(ji,jj,jk+1) ) & 323 & / ( ze3va * e3vw(ji,jj,jk+1,Kmm) ) * wvmask(ji,jj,jk+1) 300 324 zWvi = ( wi(ji,jj,jk ) + wi(ji,jj+1,jk ) ) / ze3va 301 325 zWvs = ( wi(ji,jj,jk+1) + wi(ji,jj+1,jk+1) ) / ze3va … … 307 331 DO_2D_00_00 308 332 zwi(ji,jj,1) = 0._wp 309 ze3va = ( 1._wp - r_vvl ) * e3v(ji,jj,1,Kmm) + r_vvl * e3v(ji,jj,1,Kaa) 310 zzws = - zdt * ( avm(ji,jj+1,2) + avm(ji,jj,2) ) / ( ze3va * e3vw(ji,jj,2,Kmm) ) * wvmask(ji,jj,2) 333 ze3va = ( 1._wp - r_vvl ) * e3v(ji,jj,1,Kmm) & 334 & + r_vvl * e3v(ji,jj,1,Kaa) 335 zzws = - zdt * ( avm(ji,jj+1,2) + avm(ji,jj,2) ) & 336 & / ( ze3va * e3vw(ji,jj,2,Kmm) ) * wvmask(ji,jj,2) 311 337 zWvs = ( wi(ji,jj ,2) + wi(ji,jj+1,2) ) / ze3va 312 338 zws(ji,jj,1 ) = zzws - zdt * MAX( zWvs, 0._wp ) … … 317 343 CASE( np_lap_i ) ! rotated lateral mixing: add its vertical mixing (akzu) 318 344 DO_3D_00_00( 1, jpkm1 ) 319 ze3va = ( 1._wp - r_vvl ) * e3v(ji,jj,jk,Kmm) + r_vvl * e3v(ji,jj,jk,Kaa) ! after scale factor at V-point 345 ze3va = ( 1._wp - r_vvl ) * e3v(ji,jj,jk,Kmm) & 346 & + r_vvl * e3v(ji,jj,jk,Kaa) ! after scale factor at V-point 320 347 zzwi = - zdt * ( avm(ji,jj+1,jk ) + avm(ji,jj,jk ) + akzv(ji,jj,jk ) ) & 321 348 & / ( ze3va * e3vw(ji,jj,jk ,Kmm) ) * wvmask(ji,jj,jk ) … … 328 355 CASE DEFAULT ! iso-level lateral mixing 329 356 DO_3D_00_00( 1, jpkm1 ) 330 ze3va = ( 1._wp - r_vvl ) * e3v(ji,jj,jk,Kmm) + r_vvl * e3v(ji,jj,jk,Kaa) ! after scale factor at V-point 331 zzwi = - zdt * ( avm(ji,jj+1,jk ) + avm(ji,jj,jk ) ) / ( ze3va * e3vw(ji,jj,jk ,Kmm) ) * wvmask(ji,jj,jk ) 332 zzws = - zdt * ( avm(ji,jj+1,jk+1) + avm(ji,jj,jk+1) ) / ( ze3va * e3vw(ji,jj,jk+1,Kmm) ) * wvmask(ji,jj,jk+1) 357 ze3va = ( 1._wp - r_vvl ) * e3v(ji,jj,jk,Kmm) & 358 & + r_vvl * e3v(ji,jj,jk,Kaa) ! after scale factor at V-point 359 zzwi = - zdt * ( avm(ji,jj+1,jk ) + avm(ji,jj,jk ) ) & 360 & / ( ze3va * e3vw(ji,jj,jk ,Kmm) ) * wvmask(ji,jj,jk ) 361 zzws = - zdt * ( avm(ji,jj+1,jk+1) + avm(ji,jj,jk+1) ) & 362 & / ( ze3va * e3vw(ji,jj,jk+1,Kmm) ) * wvmask(ji,jj,jk+1) 333 363 zwi(ji,jj,jk) = zzwi 334 364 zws(ji,jj,jk) = zzws … … 351 381 DO_2D_00_00 352 382 ikv = mbkv(ji,jj) ! (deepest ocean u- and v-points) 353 ze3va = ( 1._wp - r_vvl ) * e3v(ji,jj,ikv,Kmm) + r_vvl * e3v(ji,jj,ikv,Kaa) ! after scale factor at T-point 383 ze3va = ( 1._wp - r_vvl ) * e3v(ji,jj,ikv,Kmm) & 384 & + r_vvl * e3v(ji,jj,ikv,Kaa) ! after scale factor at T-point 354 385 zwd(ji,jj,ikv) = zwd(ji,jj,ikv) - rDt * 0.5*( rCdU_bot(ji,jj+1)+rCdU_bot(ji,jj) ) / ze3va 355 386 END_2D … … 357 388 DO_2D_00_00 358 389 ikv = mikv(ji,jj) ! (first wet ocean u- and v-points) 359 ze3va = ( 1._wp - r_vvl ) * e3v(ji,jj,ikv,Kmm) + r_vvl * e3v(ji,jj,ikv,Kaa) ! after scale factor at T-point 390 ze3va = ( 1._wp - r_vvl ) * e3v(ji,jj,ikv,Kmm) & 391 & + r_vvl * e3v(ji,jj,ikv,Kaa) ! after scale factor at T-point 360 392 zwd(ji,jj,ikv) = zwd(ji,jj,ikv) - rDt * 0.5*( rCdU_top(ji,jj+1)+rCdU_top(ji,jj) ) / ze3va 361 393 END_2D … … 383 415 ! 384 416 DO_2D_00_00 385 ze3va = ( 1._wp - r_vvl ) * e3v(ji,jj,1,Kmm) + r_vvl * e3v(ji,jj,1,Kaa) 417 ze3va = ( 1._wp - r_vvl ) * e3v(ji,jj,1,Kmm) & 418 & + r_vvl * e3v(ji,jj,1,Kaa) 386 419 pvv(ji,jj,1,Kaa) = pvv(ji,jj,1,Kaa) + rDt * 0.5_wp * ( vtau_b(ji,jj) + vtau(ji,jj) ) & 387 420 & / ( ze3va * rho0 ) * vmask(ji,jj,1) -
NEMO/branches/2020/dev_r12527_Gurvan_ShallowWater/src/OCE/DYN/sshwzv.F90
r12489 r13151 1 MODULE sshwzv 1 MODULE sshwzv 2 2 !!============================================================================== 3 3 !! *** MODULE sshwzv *** … … 5 5 !!============================================================================== 6 6 !! History : 3.1 ! 2009-02 (G. Madec, M. Leclair) Original code 7 !! 3.3 ! 2010-04 (M. Leclair, G. Madec) modified LF-RA 7 !! 3.3 ! 2010-04 (M. Leclair, G. Madec) modified LF-RA 8 8 !! - ! 2010-05 (K. Mogensen, A. Weaver, M. Martin, D. Lea) Assimilation interface 9 9 !! - ! 2010-09 (D.Storkey and E.O'Dea) bug fixes for BDY module … … 20 20 USE oce ! ocean dynamics and tracers variables 21 21 USE isf_oce ! ice shelf 22 USE dom_oce ! ocean space and time domain variables 22 USE dom_oce ! ocean space and time domain variables 23 23 USE sbc_oce ! surface boundary condition: ocean 24 24 USE domvvl ! Variable volume … … 31 31 #endif 32 32 ! 33 USE iom 33 USE iom 34 34 USE in_out_manager ! I/O manager 35 35 USE restart ! only for lrst_oce … … 50 50 !! * Substitutions 51 51 # include "do_loop_substitute.h90" 52 # include "domzgr_substitute.h90" 53 52 54 !!---------------------------------------------------------------------- 53 55 !! NEMO/OCE 4.0 , NEMO Consortium (2018) … … 60 62 !!---------------------------------------------------------------------- 61 63 !! *** ROUTINE ssh_nxt *** 62 !! 64 !! 63 65 !! ** Purpose : compute the after ssh (ssh(Kaa)) 64 66 !! … … 74 76 INTEGER , INTENT(in ) :: Kbb, Kmm, Kaa ! time level index 75 77 REAL(wp), DIMENSION(jpi,jpj,jpt), INTENT(inout) :: pssh ! sea-surface height 76 ! 78 ! 77 79 INTEGER :: jk ! dummy loop index 78 80 REAL(wp) :: zcoef ! local scalar … … 106 108 ! In time-split case we need a first guess of the ssh after (using the baroclinic timestep) in order to 107 109 ! compute the vertical velocity which can be used to compute the non-linear terms of the momentum equations. 108 ! 110 ! 109 111 pssh(:,:,Kaa) = ( pssh(:,:,Kbb) - rDt * ( zcoef * ( emp_b(:,:) + emp(:,:) ) + zhdiv(:,:) ) ) * ssmask(:,:) 110 112 ! 111 113 #if defined key_agrif 112 Kbb_a = Kbb; Kmm_a = Kmm; Krhs_a = Kaa; CALL agrif_ssh( kt ) 114 Kbb_a = Kbb ; Kmm_a = Kmm ; Krhs_a = Kaa 115 CALL agrif_ssh( kt ) 113 116 #endif 114 117 ! … … 129 132 END SUBROUTINE ssh_nxt 130 133 131 132 SUBROUTINE wzv( kt, Kbb, Kmm, pww, Kaa)134 135 SUBROUTINE wzv( kt, Kbb, Kmm, Kaa, pww ) 133 136 !!---------------------------------------------------------------------- 134 137 !! *** ROUTINE wzv *** 135 !! 138 !! 136 139 !! ** Purpose : compute the now vertical velocity 137 140 !! 138 !! ** Method : - Using the incompressibility hypothesis, the vertical 139 !! velocity is computed by integrating the horizontal divergence 141 !! ** Method : - Using the incompressibility hypothesis, the vertical 142 !! velocity is computed by integrating the horizontal divergence 140 143 !! from the bottom to the surface minus the scale factor evolution. 141 144 !! The boundary conditions are w=0 at the bottom (no flux) and. … … 147 150 INTEGER , INTENT(in) :: kt ! time step 148 151 INTEGER , INTENT(in) :: Kbb, Kmm, Kaa ! time level indices 149 REAL(wp), DIMENSION(jpi,jpj,jpk), INTENT(inout) :: pww ! now vertical velocity152 REAL(wp), DIMENSION(jpi,jpj,jpk), INTENT(inout) :: pww ! vertical velocity at Kmm 150 153 ! 151 154 INTEGER :: ji, jj, jk ! dummy loop indices … … 160 163 IF(lwp) WRITE(numout,*) '~~~~~ ' 161 164 ! 162 pww(:,:,jpk) = 0._wp 165 pww(:,:,jpk) = 0._wp ! bottom boundary condition: w=0 (set once for all) 163 166 ENDIF 164 167 ! !------------------------------! … … 166 169 ! !------------------------------! 167 170 ! 168 IF( ln_vvl_ztilde .OR. ln_vvl_layer ) THEN ! z_tilde and layer cases 169 ALLOCATE( zhdiv(jpi,jpj,jpk) ) 171 ! !===============================! 172 IF( ln_vvl_ztilde .OR. ln_vvl_layer ) THEN !== z_tilde and layer cases ==! 173 ! !===============================! 174 ALLOCATE( zhdiv(jpi,jpj,jpk) ) 170 175 ! 171 176 DO jk = 1, jpkm1 … … 181 186 DO jk = jpkm1, 1, -1 ! integrate from the bottom the hor. divergence 182 187 ! computation of w 183 pww(:,:,jk) = pww(:,:,jk+1) - ( e3t(:,:,jk,Kmm) * hdiv(:,:,jk) + zhdiv(:,:,jk) & 184 & + r1_Dt * ( e3t(:,:,jk,Kaa) - e3t(:,:,jk,Kbb) ) ) * tmask(:,:,jk) 188 pww(:,:,jk) = pww(:,:,jk+1) - ( e3t(:,:,jk,Kmm) * hdiv(:,:,jk) & 189 & + zhdiv(:,:,jk) & 190 & + r1_Dt * ( e3t(:,:,jk,Kaa) & 191 & - e3t(:,:,jk,Kbb) ) ) * tmask(:,:,jk) 185 192 END DO 186 193 ! IF( ln_vvl_layer ) pww(:,:,:) = 0.e0 187 DEALLOCATE( zhdiv ) 188 ELSE ! z_star and linear free surface cases 189 DO jk = jpkm1, 1, -1 ! integrate from the bottom the hor. divergence 190 ! computation of w 191 pww(:,:,jk) = pww(:,:,jk+1) - ( e3t(:,:,jk,Kmm) * hdiv(:,:,jk) & 192 & + r1_Dt * ( e3t(:,:,jk,Kaa) - e3t(:,:,jk,Kbb) ) ) * tmask(:,:,jk) 194 DEALLOCATE( zhdiv ) 195 ! !=================================! 196 ELSEIF( ln_linssh ) THEN !== linear free surface cases ==! 197 ! !=================================! 198 DO jk = jpkm1, 1, -1 ! integrate from the bottom the hor. divergence 199 pww(:,:,jk) = pww(:,:,jk+1) - ( e3t(:,:,jk,Kmm) * hdiv(:,:,jk) ) * tmask(:,:,jk) 200 END DO 201 ! !==========================================! 202 ELSE !== Quasi-Eulerian vertical coordinate ==! ('key_qco') 203 ! !==========================================! 204 DO jk = jpkm1, 1, -1 ! integrate from the bottom the hor. divergence 205 pww(:,:,jk) = pww(:,:,jk+1) - ( e3t(:,:,jk,Kmm) * hdiv(:,:,jk) & 206 & + r1_Dt * ( e3t(:,:,jk,Kaa) & 207 & - e3t(:,:,jk,Kbb) ) ) * tmask(:,:,jk) 193 208 END DO 194 209 ENDIF … … 200 215 ENDIF 201 216 ! 202 #if defined key_agrif 203 IF( .NOT. AGRIF_Root() ) THEN 204 IF ((nbondi == 1).OR.(nbondi == 2)) pww(nlci-1 , : ,:) = 0.e0 ! east 205 IF ((nbondi == -1).OR.(nbondi == 2)) pww(2 , : ,:) = 0.e0 ! west 206 IF ((nbondj == 1).OR.(nbondj == 2)) pww(: ,nlcj-1 ,:) = 0.e0 ! north 207 IF ((nbondj == -1).OR.(nbondj == 2)) pww(: ,2 ,:) = 0.e0 ! south 208 ENDIF 209 #endif 217 #if defined key_agrif 218 IF( .NOT. AGRIF_Root() ) THEN 219 IF ((nbondi == 1).OR.(nbondi == 2)) pww(nlci-1 , : ,:) = 0.e0 ! east 220 IF ((nbondi == -1).OR.(nbondi == 2)) pww(2 , : ,:) = 0.e0 ! west 221 IF ((nbondj == 1).OR.(nbondj == 2)) pww(: ,nlcj-1 ,:) = 0.e0 ! north 222 IF ((nbondj == -1).OR.(nbondj == 2)) pww(: ,2 ,:) = 0.e0 ! south 223 ENDIF 224 #endif 210 225 ! 211 226 IF( ln_timing ) CALL timing_stop('wzv') … … 214 229 215 230 216 SUBROUTINE ssh_atf( kt, Kbb, Kmm, Kaa, pssh )231 SUBROUTINE ssh_atf( kt, Kbb, Kmm, Kaa, pssh, pssh_f ) 217 232 !!---------------------------------------------------------------------- 218 233 !! *** ROUTINE ssh_atf *** … … 229 244 !! Reference : Leclair, M., and G. Madec, 2009, Ocean Modelling. 230 245 !!---------------------------------------------------------------------- 231 INTEGER , INTENT(in ) :: kt ! ocean time-step index 232 INTEGER , INTENT(in ) :: Kbb, Kmm, Kaa ! ocean time level indices 233 REAL(wp), DIMENSION(jpi,jpj,jpt), INTENT(inout) :: pssh ! SSH field 246 INTEGER , INTENT(in ) :: kt ! ocean time-step index 247 INTEGER , INTENT(in ) :: Kbb, Kmm, Kaa ! ocean time level indices 248 REAL(wp), DIMENSION(jpi,jpj,jpt) , TARGET, INTENT(inout) :: pssh ! SSH field 249 REAL(wp), DIMENSION(jpi,jpj ), OPTIONAL, TARGET, INTENT( out) :: pssh_f ! filtered SSH field 234 250 ! 235 251 REAL(wp) :: zcoef ! local scalar 252 REAL(wp), POINTER, DIMENSION(:,:) :: zssh ! pointer for filtered SSH 236 253 !!---------------------------------------------------------------------- 237 254 ! … … 245 262 ! !== Euler time-stepping: no filter, just swap ==! 246 263 IF ( .NOT.( l_1st_euler ) ) THEN ! Only do time filtering for leapfrog timesteps 264 IF( PRESENT( pssh_f ) ) THEN ; zssh => pssh_f 265 ELSE ; zssh => pssh(:,:,Kmm) 266 ENDIF 247 267 ! ! filtered "now" field 248 268 pssh(:,:,Kmm) = pssh(:,:,Kmm) + rn_atfp * ( pssh(:,:,Kbb) - 2 * pssh(:,:,Kmm) + pssh(:,:,Kaa) ) … … 266 286 END SUBROUTINE ssh_atf 267 287 288 268 289 SUBROUTINE wAimp( kt, Kmm ) 269 290 !!---------------------------------------------------------------------- 270 291 !! *** ROUTINE wAimp *** 271 !! 292 !! 272 293 !! ** Purpose : compute the Courant number and partition vertical velocity 273 294 !! if a proportion needs to be treated implicitly 274 295 !! 275 !! ** Method : - 296 !! ** Method : - 276 297 !! 277 298 !! ** action : ww : now vertical velocity (to be handled explicitly) … … 279 300 !! 280 301 !! Reference : Shchepetkin, A. F. (2015): An adaptive, Courant-number-dependent 281 !! implicit scheme for vertical advection in oceanic modeling. 302 !! implicit scheme for vertical advection in oceanic modeling. 282 303 !! Ocean Modelling, 91, 38-69. 283 304 !!---------------------------------------------------------------------- … … 306 327 DO_3D_00_00( 1, jpkm1 ) 307 328 z1_e3t = 1._wp / e3t(ji,jj,jk,Kmm) 308 ! 2*rn_Dt and not rDt (for restartability) 309 Cu_adv(ji,jj,jk) = 2._wp * rn_Dt * ( ( MAX( ww(ji,jj,jk) , 0._wp ) - MIN( ww(ji,jj,jk+1) , 0._wp ) ) & 310 & + ( MAX( e2u(ji ,jj)*e3u(ji ,jj,jk,Kmm)*uu(ji ,jj,jk,Kmm) + un_td(ji ,jj,jk), 0._wp ) - & 311 & MIN( e2u(ji-1,jj)*e3u(ji-1,jj,jk,Kmm)*uu(ji-1,jj,jk,Kmm) + un_td(ji-1,jj,jk), 0._wp ) ) & 312 & * r1_e1e2t(ji,jj) & 313 & + ( MAX( e1v(ji,jj )*e3v(ji,jj ,jk,Kmm)*vv(ji,jj ,jk,Kmm) + vn_td(ji,jj ,jk), 0._wp ) - & 314 & MIN( e1v(ji,jj-1)*e3v(ji,jj-1,jk,Kmm)*vv(ji,jj-1,jk,Kmm) + vn_td(ji,jj-1,jk), 0._wp ) ) & 315 & * r1_e1e2t(ji,jj) & 316 & ) * z1_e3t 329 ! 2*rdt and not r2dt (for restartability) 330 Cu_adv(ji,jj,jk) = 2._wp * rDt * & 331 & ( ( MAX( ww(ji,jj,jk) , 0._wp ) - MIN( ww(ji,jj,jk+1) , 0._wp ) ) & 332 & + ( MAX( e2u(ji ,jj) * e3u(ji ,jj,jk,Kmm) & 333 & * uu (ji ,jj,jk,Kmm) + un_td(ji ,jj,jk), 0._wp ) - & 334 & MIN( e2u(ji-1,jj) * e3u(ji-1,jj,jk,Kmm) & 335 & * uu (ji-1,jj,jk,Kmm) + un_td(ji-1,jj,jk), 0._wp ) ) & 336 & * r1_e1e2t(ji ,jj) & 337 & + ( MAX( e1v(ji,jj ) * e3v(ji,jj ,jk,Kmm) & 338 & * vv (ji,jj ,jk,Kmm) + vn_td(ji,jj ,jk), 0._wp ) - & 339 & MIN( e1v(ji,jj-1) * e3v(ji,jj-1,jk,Kmm) & 340 & * vv (ji,jj-1,jk,Kmm) + vn_td(ji,jj-1,jk), 0._wp ) ) & 341 & * r1_e1e2t(ji,jj ) & 342 & ) * z1_e3t 317 343 END_3D 318 344 ELSE 319 345 DO_3D_00_00( 1, jpkm1 ) 320 346 z1_e3t = 1._wp / e3t(ji,jj,jk,Kmm) 321 ! 2*rn_Dt and not rDt (for restartability) 322 Cu_adv(ji,jj,jk) = 2._wp * rn_Dt * ( ( MAX( ww(ji,jj,jk) , 0._wp ) - MIN( ww(ji,jj,jk+1) , 0._wp ) ) & 323 & + ( MAX( e2u(ji ,jj)*e3u(ji ,jj,jk,Kmm)*uu(ji ,jj,jk,Kmm), 0._wp ) - & 324 & MIN( e2u(ji-1,jj)*e3u(ji-1,jj,jk,Kmm)*uu(ji-1,jj,jk,Kmm), 0._wp ) ) & 325 & * r1_e1e2t(ji,jj) & 326 & + ( MAX( e1v(ji,jj )*e3v(ji,jj ,jk,Kmm)*vv(ji,jj ,jk,Kmm), 0._wp ) - & 327 & MIN( e1v(ji,jj-1)*e3v(ji,jj-1,jk,Kmm)*vv(ji,jj-1,jk,Kmm), 0._wp ) ) & 328 & * r1_e1e2t(ji,jj) & 329 & ) * z1_e3t 347 ! 2*rdt and not r2dt (for restartability) 348 Cu_adv(ji,jj,jk) = 2._wp * rDt * & 349 & ( ( MAX( ww(ji,jj,jk) , 0._wp ) - MIN( ww(ji,jj,jk+1) , 0._wp ) ) & 350 & + ( MAX( e2u(ji ,jj)*e3u(ji ,jj,jk,Kmm)*uu(ji ,jj,jk,Kmm), 0._wp ) - & 351 & MIN( e2u(ji-1,jj)*e3u(ji-1,jj,jk,Kmm)*uu(ji-1,jj,jk,Kmm), 0._wp ) ) & 352 & * r1_e1e2t(ji,jj) & 353 & + ( MAX( e1v(ji,jj )*e3v(ji,jj ,jk,Kmm)*vv(ji,jj ,jk,Kmm), 0._wp ) - & 354 & MIN( e1v(ji,jj-1)*e3v(ji,jj-1,jk,Kmm)*vv(ji,jj-1,jk,Kmm), 0._wp ) ) & 355 & * r1_e1e2t(ji,jj) & 356 & ) * z1_e3t 330 357 END_3D 331 358 ENDIF … … 339 366 zCu = MAX( Cu_adv(ji,jj,jk) , Cu_adv(ji,jj,jk-1) ) 340 367 ! alt: 341 ! IF ( ww(ji,jj,jk) > 0._wp ) THEN 342 ! zCu = Cu_adv(ji,jj,jk) 368 ! IF ( ww(ji,jj,jk) > 0._wp ) THEN 369 ! zCu = Cu_adv(ji,jj,jk) 343 370 ! ELSE 344 371 ! zCu = Cu_adv(ji,jj,jk-1) 345 ! ENDIF 372 ! ENDIF 346 373 ! 347 374 IF( zCu <= Cu_min ) THEN !<-- Fully explicit … … 360 387 Cu_adv(ji,jj,jk) = zcff ! Reuse array to output coefficient below and in stp_ctl 361 388 END_3D 362 Cu_adv(:,:,1) = 0._wp 389 Cu_adv(:,:,1) = 0._wp 363 390 ELSE 364 391 ! Fully explicit everywhere … … 366 393 wi (:,:,:) = 0._wp 367 394 ENDIF 368 CALL iom_put("wimp",wi) 395 CALL iom_put("wimp",wi) 369 396 CALL iom_put("wi_cff",Cu_adv) 370 397 CALL iom_put("wexp",ww) -
NEMO/branches/2020/dev_r12527_Gurvan_ShallowWater/src/OCE/DYN/wet_dry.F90
r12489 r13151 33 33 !! * Substitutions 34 34 # include "do_loop_substitute.h90" 35 # include "domzgr_substitute.h90" 35 36 !!---------------------------------------------------------------------- 36 37 !! critical depths,filters, limiters,and masks for Wetting and Drying -
NEMO/branches/2020/dev_r12527_Gurvan_ShallowWater/src/OCE/FLO/flo4rk.F90
r12489 r13151 26 26 REAL(wp), DIMENSION (3) :: scoef1 = (/ 0.5 , 0.5 , 1.0 /) ! 27 27 28 # include "domzgr_substitute.h90" 28 29 !!---------------------------------------------------------------------- 29 30 !! NEMO/OCE 4.0 , NEMO Consortium (2018) -
NEMO/branches/2020/dev_r12527_Gurvan_ShallowWater/src/OCE/FLO/floblk.F90
r12489 r13151 20 20 PUBLIC flo_blk ! routine called by floats.F90 21 21 22 # include "domzgr_substitute.h90" 23 22 24 !!---------------------------------------------------------------------- 23 25 !! NEMO/OCE 4.0 , NEMO Consortium (2018) 24 !! $Id$ 26 !! $Id$ 25 27 !! Software governed by the CeCILL license (see ./LICENSE) 26 28 !!---------------------------------------------------------------------- … … 30 32 !!--------------------------------------------------------------------- 31 33 !! *** ROUTINE flo_blk *** 32 !! 34 !! 33 35 !! ** Purpose : Compute the geographical position,latitude, longitude 34 36 !! and depth of each float at each time step. 35 !! 37 !! 36 38 !! ** Method : The position of a float is computed with Bruno Blanke 37 39 !! algorithm. We need to know the velocity field, the old positions … … 47 49 zuoutfl,zvoutfl,zwoutfl, & ! transport across the ouput face 48 50 zvol, & ! volume of the mesh 49 zsurfz, & ! surface of the face of the mesh 51 zsurfz, & ! surface of the face of the mesh 50 52 zind 51 53 … … 53 55 54 56 INTEGER , DIMENSION ( jpnfl ) :: iil, ijl, ikl ! index of nearest mesh 55 INTEGER , DIMENSION ( jpnfl ) :: iiloc , ijloc 57 INTEGER , DIMENSION ( jpnfl ) :: iiloc , ijloc 56 58 INTEGER , DIMENSION ( jpnfl ) :: iiinfl, ijinfl, ikinfl ! index of input mesh of the float. 57 59 INTEGER , DIMENSION ( jpnfl ) :: iioutfl, ijoutfl, ikoutfl ! index of output mesh of the float. 58 REAL(wp) , DIMENSION ( jpnfl ) :: zgifl, zgjfl, zgkfl ! position of floats, index on 60 REAL(wp) , DIMENSION ( jpnfl ) :: zgifl, zgjfl, zgkfl ! position of floats, index on 59 61 ! ! velocity mesh. 60 62 REAL(wp) , DIMENSION ( jpnfl ) :: ztxfl, ztyfl, ztzfl ! time for a float to quit the mesh 61 ! ! across one of the face x,y and z 62 REAL(wp) , DIMENSION ( jpnfl ) :: zttfl ! time for a float to quit the mesh 63 REAL(wp) , DIMENSION ( jpnfl ) :: zagefl ! time during which, trajectorie of 63 ! ! across one of the face x,y and z 64 REAL(wp) , DIMENSION ( jpnfl ) :: zttfl ! time for a float to quit the mesh 65 REAL(wp) , DIMENSION ( jpnfl ) :: zagefl ! time during which, trajectorie of 64 66 ! ! the float has been computed 65 REAL(wp) , DIMENSION ( jpnfl ) :: zagenewfl ! new age of float after calculation 67 REAL(wp) , DIMENSION ( jpnfl ) :: zagenewfl ! new age of float after calculation 66 68 ! ! of new position 67 69 REAL(wp) , DIMENSION ( jpnfl ) :: zufl, zvfl, zwfl ! interpolated vel. at float position … … 77 79 78 80 ! Initialisation of parameters 79 81 80 82 DO jfl = 1, jpnfl 81 83 ! ages of floats are put at zero 82 84 zagefl(jfl) = 0. 83 ! index on the velocity grid 84 ! We considere k coordinate negative, with this transformation 85 ! the computation in the 3 direction is the same. 85 ! index on the velocity grid 86 ! We considere k coordinate negative, with this transformation 87 ! the computation in the 3 direction is the same. 86 88 zgifl(jfl) = tpifl(jfl) - 0.5 87 89 zgjfl(jfl) = tpjfl(jfl) - 0.5 88 90 zgkfl(jfl) = MIN(-1.,-(tpkfl(jfl))) 89 ! surface drift every 10 days 91 ! surface drift every 10 days 90 92 IF( ln_argo ) THEN 91 93 IF( MOD(kt,150) >= 146 .OR. MOD(kt,150) == 0 ) zgkfl(jfl) = -1. … … 96 98 ikl(jfl) = INT(zgkfl(jfl)) 97 99 END DO 98 100 99 101 iloop = 0 100 102 222 DO jfl = 1, jpnfl … … 104 106 iiloc(jfl) = iil(jfl) - mig(1) + 1 105 107 ijloc(jfl) = ijl(jfl) - mjg(1) + 1 106 # else 108 # else 107 109 iiloc(jfl) = iil(jfl) 108 110 ijloc(jfl) = ijl(jfl) 109 111 # endif 110 111 ! compute the transport across the mesh where the float is. 112 !!bug (gm) change e3t into e3. but never checked 113 zsurfx(1) = e2u(iiloc(jfl)-1,ijloc(jfl) ) * e3u(iiloc(jfl)-1,ijloc(jfl) ,-ikl(jfl),Kmm) 114 zsurfx(2) = e2u(iiloc(jfl) ,ijloc(jfl) ) * e3u(iiloc(jfl) ,ijloc(jfl) ,-ikl(jfl),Kmm) 115 zsurfy(1) = e1v(iiloc(jfl) ,ijloc(jfl)-1) * e3v(iiloc(jfl) ,ijloc(jfl)-1,-ikl(jfl),Kmm) 116 zsurfy(2) = e1v(iiloc(jfl) ,ijloc(jfl) ) * e3v(iiloc(jfl) ,ijloc(jfl) ,-ikl(jfl),Kmm) 112 113 ! compute the transport across the mesh where the float is. 114 !!bug (gm) change e3t into e3. but never checked 115 zsurfx(1) = & 116 & e2u(iiloc(jfl)-1,ijloc(jfl) ) & 117 & * e3u(iiloc(jfl)-1,ijloc(jfl) ,-ikl(jfl),Kmm) 118 zsurfx(2) = & 119 & e2u(iiloc(jfl) ,ijloc(jfl) ) & 120 & * e3u(iiloc(jfl) ,ijloc(jfl) ,-ikl(jfl),Kmm) 121 zsurfy(1) = & 122 & e1v(iiloc(jfl) ,ijloc(jfl)-1) & 123 & * e3v(iiloc(jfl) ,ijloc(jfl)-1,-ikl(jfl),Kmm) 124 zsurfy(2) = & 125 & e1v(iiloc(jfl) ,ijloc(jfl) ) & 126 & * e3v(iiloc(jfl) ,ijloc(jfl) ,-ikl(jfl),Kmm) 117 127 118 128 ! for a isobar float zsurfz is put to zero. The vertical velocity will be zero too. … … 129 139 zwoutfl=-(wb(iiloc(jfl),ijloc(jfl),- ikl(jfl) ) & 130 140 & + ww(iiloc(jfl),ijloc(jfl),- ikl(jfl) ) )/2. * zsurfz*nisobfl(jfl) 131 132 ! interpolation of velocity field on the float initial position 141 142 ! interpolation of velocity field on the float initial position 133 143 zufl(jfl)= zuinfl + ( zgifl(jfl) - float(iil(jfl)-1) ) * ( zuoutfl - zuinfl) 134 144 zvfl(jfl)= zvinfl + ( zgjfl(jfl) - float(ijl(jfl)-1) ) * ( zvoutfl - zvinfl) 135 145 zwfl(jfl)= zwinfl + ( zgkfl(jfl) - float(ikl(jfl)-1) ) * ( zwoutfl - zwinfl) 136 146 137 147 ! faces of input and output 138 148 ! u-direction … … 147 157 iiinfl (jfl) = iil(jfl) - 1 148 158 ENDIF 149 ! v-direction 159 ! v-direction 150 160 IF( zvfl(jfl) < 0. ) THEN 151 161 ijoutfl(jfl) = ijl(jfl) - 1. … … 169 179 ikinfl (jfl) = ikl(jfl) - 1. 170 180 ENDIF 171 181 172 182 ! compute the time to go out the mesh across a face 173 183 ! u-direction … … 175 185 zgidfl(jfl) = float(iioutfl(jfl) - iiinfl(jfl)) 176 186 IF( zufl(jfl)*zuoutfl <= 0. ) THEN 177 ztxfl(jfl) = 1.E99187 ztxfl(jfl) = HUGE(1._wp) 178 188 ELSE 179 189 IF( ABS(zudfl(jfl)) >= 1.E-5 ) THEN … … 191 201 zgjdfl(jfl) = float(ijoutfl(jfl)-ijinfl(jfl)) 192 202 IF( zvfl(jfl)*zvoutfl <= 0. ) THEN 193 ztyfl(jfl) = 1.E99203 ztyfl(jfl) = HUGE(1._wp) 194 204 ELSE 195 205 IF( ABS(zvdfl(jfl)) >= 1.E-5 ) THEN … … 203 213 ENDIF 204 214 ENDIF 205 ! w-direction 206 IF( nisobfl(jfl) == 1. ) THEN 215 ! w-direction 216 IF( nisobfl(jfl) == 1. ) THEN 207 217 zwdfl (jfl) = zwoutfl - zwinfl 208 218 zgkdfl(jfl) = float(ikoutfl(jfl) - ikinfl(jfl)) 209 219 IF( zwfl(jfl)*zwoutfl <= 0. ) THEN 210 ztzfl(jfl) = 1.E99220 ztzfl(jfl) = HUGE(1._wp) 211 221 ELSE 212 222 IF( ABS(zwdfl(jfl)) >= 1.E-5 ) THEN … … 221 231 ENDIF 222 232 ENDIF 223 233 224 234 ! the time to go leave the mesh is the smallest time 225 226 IF( nisobfl(jfl) == 1. ) THEN 235 236 IF( nisobfl(jfl) == 1. ) THEN 227 237 zttfl(jfl) = MIN(ztxfl(jfl),ztyfl(jfl),ztzfl(jfl)) 228 238 ELSE … … 231 241 ! new age of the FLOAT 232 242 zagenewfl(jfl) = zagefl(jfl) + zttfl(jfl)*zvol 233 ! test to know if the "age" of the float is not bigger than the 243 ! test to know if the "age" of the float is not bigger than the 234 244 ! time step 235 245 IF( zagenewfl(jfl) > rn_Dt ) THEN … … 237 247 zagenewfl(jfl) = rn_Dt 238 248 ENDIF 239 249 240 250 ! In the "minimal" direction we compute the index of new mesh 241 251 ! on i-direction … … 250 260 iiinfl(jfl) = ind 251 261 ELSE 252 IF( ABS(zudfl(jfl)) >= 1.E-5 ) THEN 262 IF( ABS(zudfl(jfl)) >= 1.E-5 ) THEN 253 263 zgifl(jfl) = zgifl(jfl) + zgidfl(jfl)*zufl(jfl) & 254 264 & * ( EXP( zudfl(jfl)/zgidfl(jfl)*zttfl(jfl) ) - 1. ) / zudfl(jfl) … … 268 278 ijinfl(jfl) = ind 269 279 ELSE 270 IF( ABS(zvdfl(jfl)) >= 1.E-5 ) THEN 280 IF( ABS(zvdfl(jfl)) >= 1.E-5 ) THEN 271 281 zgjfl(jfl) = zgjfl(jfl)+zgjdfl(jfl)*zvfl(jfl) & 272 282 & * ( EXP(zvdfl(jfl)/zgjdfl(jfl)*zttfl(jfl)) - 1. ) / zvdfl(jfl) … … 287 297 ikinfl(jfl) = ind 288 298 ELSE 289 IF( ABS(zwdfl(jfl)) >= 1.E-5 ) THEN 299 IF( ABS(zwdfl(jfl)) >= 1.E-5 ) THEN 290 300 zgkfl(jfl) = zgkfl(jfl)+zgkdfl(jfl)*zwfl(jfl) & 291 301 & * ( EXP(zwdfl(jfl)/zgkdfl(jfl)*zttfl(jfl)) - 1. ) / zwdfl(jfl) … … 295 305 ENDIF 296 306 ENDIF 297 307 298 308 ! coordinate of the new point on the temperature grid 299 309 300 310 iil(jfl) = MAX(iiinfl(jfl),iioutfl(jfl)) 301 311 ijl(jfl) = MAX(ijinfl(jfl),ijoutfl(jfl)) … … 306 316 !!Alexcadm . ikoutfl(jfl),ztxfl(jfl),ztyfl(jfl) 307 317 !!Alexcadm . ,ztzfl(jfl),zgifl(jfl), 308 !!Alexcadm . zgjfl(jfl) 318 !!Alexcadm . zgjfl(jfl) 309 319 !!Alexcadm IF (jfl == 910) write(*,*)'Flotteur 910', 310 320 !!Alexcadm . iiinfl(jfl),iioutfl(jfl),ijinfl(jfl) … … 312 322 !!Alexcadm . ikoutfl(jfl),ztxfl(jfl),ztyfl(jfl) 313 323 !!Alexcadm . ,ztzfl(jfl),zgifl(jfl), 314 !!Alexcadm . zgjfl(jfl) 324 !!Alexcadm . zgjfl(jfl) 315 325 ! reinitialisation of the age of FLOAT 316 326 zagefl(jfl) = zagenewfl(jfl) … … 327 337 # endif 328 338 END DO 329 339 330 340 ! synchronisation 331 341 CALL mpp_sum( 'floblk', zgifl , jpnfl ) ! sums over the global domain … … 335 345 CALL mpp_sum( 'floblk', iil , jpnfl ) 336 346 CALL mpp_sum( 'floblk', ijl , jpnfl ) 337 347 338 348 ! Test to know if a float hasn't integrated enought time 339 349 IF( ln_argo ) THEN … … 361 371 !!Alexcadm . tpkfl(jpnfl),zufl(jpnfl),zvfl(jpnfl),zwfl(jpnfl) 362 372 IF( ifin == 0 ) THEN 363 iloop = iloop + 1 373 iloop = iloop + 1 364 374 GO TO 222 365 375 ENDIF … … 369 379 370 380 !!====================================================================== 371 END MODULE floblk 381 END MODULE floblk -
NEMO/branches/2020/dev_r12527_Gurvan_ShallowWater/src/OCE/IOM/iom.F90
r12489 r13151 111 111 CHARACTER(len=lc) :: clname 112 112 INTEGER :: irefyear, irefmonth, irefday 113 INTEGER :: ji , jkmin113 INTEGER :: ji 114 114 LOGICAL :: llrst_context ! is context related to restart 115 115 ! … … 220 220 221 221 ! Add vertical grid bounds 222 jkmin = MIN(2,jpk) ! in case jpk=1 (i.e. sas2D) 223 zt_bnds(2,: ) = gdept_1d(:) 224 zt_bnds(1,jkmin:jpk) = gdept_1d(1:jpkm1) 225 zt_bnds(1,1 ) = gdept_1d(1) - e3w_1d(1) 226 zw_bnds(1,: ) = gdepw_1d(:) 227 zw_bnds(2,1:jpkm1 ) = gdepw_1d(jkmin:jpk) 228 zw_bnds(2,jpk: ) = gdepw_1d(jpk) + e3t_1d(jpk) 222 zt_bnds(2,: ) = gdept_1d(:) 223 zt_bnds(1,2:jpk ) = gdept_1d(1:jpkm1) 224 zt_bnds(1,1 ) = gdept_1d(1) - e3w_1d(1) 225 zw_bnds(1,: ) = gdepw_1d(:) 226 zw_bnds(2,1:jpkm1) = gdepw_1d(2:jpk) 227 zw_bnds(2,jpk: ) = gdepw_1d(jpk) + e3t_1d(jpk) 229 228 CALL iom_set_axis_attr( "deptht", bounds=zw_bnds ) 230 229 CALL iom_set_axis_attr( "depthu", bounds=zw_bnds ) … … 665 664 666 665 667 SUBROUTINE iom_open( cdname, kiomid, ldwrt, kdom, ldstop, ldiof, kdlev )666 SUBROUTINE iom_open( cdname, kiomid, ldwrt, kdom, ldstop, ldiof, kdlev, cdcomp ) 668 667 !!--------------------------------------------------------------------- 669 668 !! *** SUBROUTINE iom_open *** … … 678 677 LOGICAL , INTENT(in ), OPTIONAL :: ldiof ! Interp On the Fly, needed for AGRIF (default = .FALSE.) 679 678 INTEGER , INTENT(in ), OPTIONAL :: kdlev ! number of vertical levels 679 CHARACTER(len=3), INTENT(in ), OPTIONAL :: cdcomp ! name of component calling iom_nf90_open 680 680 ! 681 681 CHARACTER(LEN=256) :: clname ! the name of the file based on cdname [[+clcpu]+clcpu] … … 823 823 ENDIF 824 824 IF( istop == nstop ) THEN ! no error within this routine 825 CALL iom_nf90_open( clname, kiomid, llwrt, llok, idompar, kdlev = kdlev )825 CALL iom_nf90_open( clname, kiomid, llwrt, llok, idompar, kdlev = kdlev, cdcomp = cdcomp ) 826 826 ENDIF 827 827 ! … … 1385 1385 REAL(wp), DIMENSION(jpi,jpj) :: z2d 1386 1386 #if defined key_iomput 1387 IF( xios_field_is_active( cdname, at_current_timestep_arg = .TRUE. ) ) THEN 1388 z2d(:,:) = 0._wp 1389 CALL xios_recv_field( cdname, z2d) 1390 ENDIF 1387 !!an juste pour compiler xios2.0 1388 ! IF( xios_field_is_active( cdname, at_current_timestep_arg = .TRUE. ) ) THEN 1389 ! z2d(:,:) = 0._wp 1390 ! CALL xios_recv_field( cdname, z2d) 1391 ! ENDIF 1392 !!an 1391 1393 #else 1392 1394 IF( .FALSE. ) WRITE(numout,*) cdname, z2d ! useless test to avoid compilation warnings -
NEMO/branches/2020/dev_r12527_Gurvan_ShallowWater/src/OCE/IOM/iom_def.F90
r12377 r13151 50 50 TYPE, PUBLIC :: file_descriptor 51 51 CHARACTER(LEN=240) :: name !: name of the file 52 CHARACTER(LEN=3 ) :: comp !: name of component opening the file ('OCE', 'ICE'...) 52 53 INTEGER :: nfid !: identifier of the file (0 if closed) 53 54 !: jpioipsl option has been removed) … … 64 65 REAL(kind=wp), DIMENSION(jpmax_vars) :: scf !: scale_factor of the variables 65 66 REAL(kind=wp), DIMENSION(jpmax_vars) :: ofs !: add_offset of the variables 66 INTEGER :: nlev ! number of vertical levels67 67 END TYPE file_descriptor 68 68 TYPE(file_descriptor), DIMENSION(jpmax_files), PUBLIC :: iom_file !: array containing the info for all opened files -
NEMO/branches/2020/dev_r12527_Gurvan_ShallowWater/src/OCE/IOM/iom_nf90.F90
r12377 r13151 19 19 !!---------------------------------------------------------------------- 20 20 USE dom_oce ! ocean space and time domain 21 USE sbc_oce, ONLY: jpka,ght_abl ! abl vertical level number and height21 USE sbc_oce, ONLY: ght_abl ! abl vertical level number and height 22 22 USE lbclnk ! lateal boundary condition / mpp exchanges 23 23 USE iom_def ! iom variables definitions … … 46 46 CONTAINS 47 47 48 SUBROUTINE iom_nf90_open( cdname, kiomid, ldwrt, ldok, kdompar, kdlev )48 SUBROUTINE iom_nf90_open( cdname, kiomid, ldwrt, ldok, kdompar, kdlev, cdcomp ) 49 49 !!--------------------------------------------------------------------- 50 50 !! *** SUBROUTINE iom_open *** … … 58 58 INTEGER, DIMENSION(2,5), INTENT(in ), OPTIONAL :: kdompar ! domain parameters: 59 59 INTEGER , INTENT(in ), OPTIONAL :: kdlev ! size of the ice/abl third dimension 60 CHARACTER(len=3) , INTENT(in ), OPTIONAL :: cdcomp ! name of component calling iom_nf90_open 60 61 61 62 CHARACTER(LEN=256) :: clinfo ! info character 62 63 CHARACTER(LEN=256) :: cltmp ! temporary character 64 CHARACTER(LEN=3 ) :: clcomp ! name of component calling iom_nf90_open 63 65 INTEGER :: iln ! lengths of character 64 66 INTEGER :: istop ! temporary storage of nstop … … 70 72 INTEGER :: ihdf5 ! local variable for retrieval of value for NF90_HDF5 71 73 LOGICAL :: llclobber ! local definition of ln_clobber 72 INTEGER :: ilevels ! vertical levels73 74 !--------------------------------------------------------------------- 74 75 ! … … 77 78 ! 78 79 ! !number of vertical levels 79 IF( PRESENT(kdlev) ) THEN ; ilevels = kdlev ! use input value (useful for sea-ice and abl) 80 ELSE ; ilevels = jpk ! by default jpk 80 IF( PRESENT(cdcomp) ) THEN 81 IF( .NOT. PRESENT(kdlev) ) CALL ctl_stop( 'iom_nf90_open: cdcomp and kdlev must both be present' ) 82 clcomp = cdcomp ! use input value 83 ELSE 84 clcomp = 'OCE' ! by default 81 85 ENDIF 82 86 ! … … 125 129 CALL iom_nf90_check(NF90_SET_FILL( if90id, NF90_NOFILL, idmy ), clinfo) 126 130 ! define dimensions 127 CALL iom_nf90_check(NF90_DEF_DIM( if90id, 'x', kdompar(1,1), idmy ), clinfo) 128 CALL iom_nf90_check(NF90_DEF_DIM( if90id, 'y', kdompar(2,1), idmy ), clinfo) 129 IF( PRESENT(kdlev) ) THEN 130 IF( kdlev == jpka ) THEN 131 CALL iom_nf90_check(NF90_DEF_DIM( if90id, 'nav_lev', kdlev, idmy ), clinfo) 132 CALL iom_nf90_check(NF90_DEF_DIM( if90id, 'time_counter', NF90_UNLIMITED, idmy ), clinfo) 133 ELSE 134 CALL iom_nf90_check(NF90_DEF_DIM( if90id, 'nav_lev', jpk, idmy ), clinfo) 135 CALL iom_nf90_check(NF90_DEF_DIM( if90id, 'time_counter', NF90_UNLIMITED, idmy ), clinfo) 136 CALL iom_nf90_check(NF90_DEF_DIM( if90id, 'numcat', kdlev, idmy ), clinfo) 137 ENDIF 138 ELSE 139 CALL iom_nf90_check(NF90_DEF_DIM( if90id, 'nav_lev', jpk, idmy ), clinfo) 140 CALL iom_nf90_check(NF90_DEF_DIM( if90id, 'time_counter', NF90_UNLIMITED, idmy ), clinfo) 141 ENDIF 131 CALL iom_nf90_check(NF90_DEF_DIM( if90id, 'x', kdompar(1,1), idmy ), clinfo) 132 CALL iom_nf90_check(NF90_DEF_DIM( if90id, 'y', kdompar(2,1), idmy ), clinfo) 133 SELECT CASE (clcomp) 134 CASE ('OCE') ; CALL iom_nf90_check(NF90_DEF_DIM( if90id, 'nav_lev', jpk, idmy ), clinfo) 135 CASE ('ICE') ; CALL iom_nf90_check(NF90_DEF_DIM( if90id, 'numcat', kdlev, idmy ), clinfo) 136 CASE ('ABL') ; CALL iom_nf90_check(NF90_DEF_DIM( if90id, 'nav_lev', kdlev, idmy ), clinfo) 137 CASE ('SED') ; CALL iom_nf90_check(NF90_DEF_DIM( if90id, 'numsed', kdlev, idmy ), clinfo) 138 CASE DEFAULT ; CALL ctl_stop( 'iom_nf90_open unknown component type' ) 139 END SELECT 140 CALL iom_nf90_check(NF90_DEF_DIM( if90id, 'time_counter', NF90_UNLIMITED, idmy ), clinfo) 142 141 ! global attributes 143 142 CALL iom_nf90_check(NF90_PUT_ATT( if90id, NF90_GLOBAL, 'DOMAIN_number_total' , jpnij ), clinfo) … … 165 164 ENDDO 166 165 iom_file(kiomid)%name = TRIM(cdname) 166 iom_file(kiomid)%comp = clcomp 167 167 iom_file(kiomid)%nfid = if90id 168 168 iom_file(kiomid)%nvars = 0 169 169 iom_file(kiomid)%irec = -1 ! useless for NetCDF files, used to know if the file is in define mode 170 iom_file(kiomid)%nlev = ilevels171 170 CALL iom_nf90_check(NF90_Inquire(if90id, unlimitedDimId = iom_file(kiomid)%iduld), clinfo) 172 171 IF( iom_file(kiomid)%iduld .GE. 0 ) THEN … … 529 528 INTEGER, DIMENSION(4) :: idimid ! dimensions id 530 529 CHARACTER(LEN=256) :: clinfo ! info character 531 CHARACTER(LEN= 12), DIMENSION(5) :: cltmp ! temporary character532 530 INTEGER :: if90id ! nf90 file identifier 533 INTEGER :: idmy ! dummy variable534 531 INTEGER :: itype ! variable type 535 532 INTEGER, DIMENSION(4) :: ichunksz ! NetCDF4 chunk sizes. Will be computed using … … 540 537 ! ! when appropriate (currently chunking is applied to 4d fields only) 541 538 INTEGER :: idlv ! local variable 542 INTEGER :: idim3 ! id of the third dimension543 539 !--------------------------------------------------------------------- 544 540 ! … … 554 550 ENDIF 555 551 ! define the dimension variables if it is not already done 556 ! Warning: we must use the same character length in an array constructor (at least for gcc compiler) 557 cltmp = (/ 'nav_lon ', 'nav_lat ', 'nav_lev ', 'time_counter', 'numcat ' /) 558 CALL iom_nf90_check(NF90_DEF_VAR( if90id, TRIM(cltmp(1)), NF90_FLOAT , (/ 1, 2 /), iom_file(kiomid)%nvid(1) ), clinfo) 559 CALL iom_nf90_check(NF90_DEF_VAR( if90id, TRIM(cltmp(2)), NF90_FLOAT , (/ 1, 2 /), iom_file(kiomid)%nvid(2) ), clinfo) 560 CALL iom_nf90_check(NF90_DEF_VAR( if90id, TRIM(cltmp(3)), NF90_FLOAT , (/ 3 /), iom_file(kiomid)%nvid(3) ), clinfo) 561 CALL iom_nf90_check(NF90_DEF_VAR( if90id, TRIM(cltmp(4)), NF90_DOUBLE, (/ 4 /), iom_file(kiomid)%nvid(4) ), clinfo) 552 DO jd = 1, 2 553 CALL iom_nf90_check(NF90_INQUIRE_DIMENSION(if90id,jd,iom_file(kiomid)%cn_var(jd),iom_file(kiomid)%dimsz(jd,jd)),clinfo) 554 CALL iom_nf90_check(NF90_DEF_VAR( if90id, TRIM(iom_file(kiomid)%cn_var(jd)), NF90_FLOAT , (/ 1, 2 /), & 555 & iom_file(kiomid)%nvid(jd) ), clinfo) 556 END DO 557 iom_file(kiomid)%dimsz(2,1) = iom_file(kiomid)%dimsz(2,2) ! second dim of first variable 558 iom_file(kiomid)%dimsz(1,2) = iom_file(kiomid)%dimsz(1,1) ! first dim of second variable 559 DO jd = 3, 4 560 CALL iom_nf90_check(NF90_INQUIRE_DIMENSION(if90id,jd,iom_file(kiomid)%cn_var(jd),iom_file(kiomid)%dimsz(1,jd)), clinfo) 561 CALL iom_nf90_check(NF90_DEF_VAR( if90id, TRIM(iom_file(kiomid)%cn_var(jd)), NF90_FLOAT , (/ jd /), & 562 & iom_file(kiomid)%nvid(jd) ), clinfo) 563 END DO 562 564 ! update informations structure related the dimension variable we just added... 563 565 iom_file(kiomid)%nvars = 4 564 566 iom_file(kiomid)%luld(1:4) = (/ .FALSE., .FALSE., .FALSE., .TRUE. /) 565 iom_file(kiomid)%cn_var(1:4) = cltmp(1:4)566 567 iom_file(kiomid)%ndims(1:4) = (/ 2, 2, 1, 1 /) 567 IF( NF90_INQ_DIMID( if90id, 'numcat', idmy ) == nf90_noerr ) THEN ! add a 5th variable corresponding to the 5th dimension568 CALL iom_nf90_check(NF90_DEF_VAR( if90id, TRIM(cltmp(5)), NF90_FLOAT , (/ 5 /), iom_file(kiomid)%nvid(5) ), clinfo)569 iom_file(kiomid)%nvars = 5570 iom_file(kiomid)%luld(5) = .FALSE.571 iom_file(kiomid)%cn_var(5) = cltmp(5)572 iom_file(kiomid)%ndims(5) = 1573 ENDIF574 ! trick: defined to 0 to say that dimension variables are defined but not yet written575 iom_file(kiomid)%dimsz(1, 1) = 0576 568 IF(lwp) WRITE(numout,*) TRIM(clinfo)//' define dimension variables done' 577 569 ENDIF … … 594 586 IF( PRESENT(pv_r0d) ) THEN ; idims = 0 595 587 ELSEIF( PRESENT(pv_r1d) ) THEN 596 IF(( SIZE(pv_r1d,1) == jpk ).OR.( SIZE(pv_r1d,1) == jpka )) THEN ; idim3 = 3 597 ELSE ; idim3 = 5 598 ENDIF 599 idims = 2 ; idimid(1:idims) = (/idim3,4/) 600 ELSEIF( PRESENT(pv_r2d) ) THEN ; idims = 3 ; idimid(1:idims) = (/1,2 ,4/) 588 idims = 2 ; idimid(1:idims) = (/3,4/) 589 ELSEIF( PRESENT(pv_r2d) ) THEN ; idims = 3 ; idimid(1:idims) = (/1,2,4/) 601 590 ELSEIF( PRESENT(pv_r3d) ) THEN 602 IF(( SIZE(pv_r3d,3) == jpk ).OR.( SIZE(pv_r3d,3) == jpka )) THEN ; idim3 = 3 603 ELSE ; idim3 = 5 604 ENDIF 605 idims = 4 ; idimid(1:idims) = (/1,2,idim3,4/) 591 idims = 4 ; idimid(1:idims) = (/1,2,3,4/) 606 592 ENDIF 607 593 IF( PRESENT(ktype) ) THEN ! variable external type … … 678 664 ! ============= 679 665 ! trick: is defined to 0 => dimension variable are defined but not yet written 680 IF( iom_file(kiomid)%dimsz(1, 1) == 0 ) THEN 681 CALL iom_nf90_check( NF90_INQ_VARID( if90id, 'nav_lon' , idmy ) , clinfo ) 682 CALL iom_nf90_check( NF90_PUT_VAR ( if90id, idmy, glamt(ix1:ix2, iy1:iy2) ), clinfo ) 683 CALL iom_nf90_check( NF90_INQ_VARID( if90id, 'nav_lat' , idmy ) , clinfo ) 684 CALL iom_nf90_check( NF90_PUT_VAR ( if90id, idmy, gphit(ix1:ix2, iy1:iy2) ), clinfo ) 685 CALL iom_nf90_check( NF90_INQ_VARID( if90id, 'nav_lev' , idmy ), clinfo ) 686 IF (iom_file(kiomid)%nlev == jpka) THEN ; CALL iom_nf90_check( NF90_PUT_VAR ( if90id, idmy, ght_abl), clinfo ) 687 ELSE ; CALL iom_nf90_check( NF90_PUT_VAR ( if90id, idmy, gdept_1d), clinfo ) 688 ENDIF 689 IF( NF90_INQ_VARID( if90id, 'numcat', idmy ) == nf90_noerr ) THEN 690 CALL iom_nf90_check( NF90_PUT_VAR ( if90id, idmy, (/ (idlv, idlv = 1,iom_file(kiomid)%nlev) /)), clinfo ) 691 ENDIF 692 ! +++ WRONG VALUE: to be improved but not really useful... 693 CALL iom_nf90_check( NF90_INQ_VARID( if90id, 'time_counter', idmy ), clinfo ) 694 CALL iom_nf90_check( NF90_PUT_VAR( if90id, idmy, kt ), clinfo ) 695 ! update the values of the variables dimensions size 696 CALL iom_nf90_check( NF90_INQUIRE_DIMENSION( if90id, 1, len = iom_file(kiomid)%dimsz(1,1) ), clinfo ) 697 CALL iom_nf90_check( NF90_INQUIRE_DIMENSION( if90id, 2, len = iom_file(kiomid)%dimsz(2,1) ), clinfo ) 698 iom_file(kiomid)%dimsz(1:2, 2) = iom_file(kiomid)%dimsz(1:2, 1) 699 CALL iom_nf90_check( NF90_INQUIRE_DIMENSION( if90id, 3, len = iom_file(kiomid)%dimsz(1,3) ), clinfo ) 700 iom_file(kiomid)%dimsz(1 , 4) = 1 ! unlimited dimension 666 IF( iom_file(kiomid)%dimsz(1, 4) == 0 ) THEN ! time_counter = 0 667 CALL iom_nf90_check( NF90_PUT_VAR( if90id, 1, glamt(ix1:ix2, iy1:iy2) ), clinfo ) 668 CALL iom_nf90_check( NF90_PUT_VAR( if90id, 2, gphit(ix1:ix2, iy1:iy2) ), clinfo ) 669 SELECT CASE (iom_file(kiomid)%comp) 670 CASE ('OCE') 671 CALL iom_nf90_check( NF90_PUT_VAR( if90id, 3, gdept_1d ), clinfo ) 672 CASE ('ABL') 673 CALL iom_nf90_check( NF90_PUT_VAR( if90id, 3, ght_abl ), clinfo ) 674 CASE DEFAULT 675 CALL iom_nf90_check( NF90_PUT_VAR( if90id, 3, (/ (idlv, idlv = 1,iom_file(kiomid)%dimsz(1,3)) /) ), clinfo ) 676 END SELECT 677 ! "wrong" value: to be improved but not really useful... 678 CALL iom_nf90_check( NF90_PUT_VAR( if90id, 4, kt ), clinfo ) 679 ! update the size of the variable corresponding to the unlimited dimension 680 iom_file(kiomid)%dimsz(1, 4) = 1 ! so we don't enter this IF case any more... 701 681 IF(lwp) WRITE(numout,*) TRIM(clinfo)//' write dimension variables done' 702 682 ENDIF -
NEMO/branches/2020/dev_r12527_Gurvan_ShallowWater/src/OCE/IOM/restart.F90
r12489 r13151 291 291 ! 292 292 IF( l_1st_euler ) THEN ! Euler restart 293 ts (:,:,:,:,Kbb) = ts (:,:,:,:,Kmm) ! all before fields set to now values 294 uu (:,:,: ,Kbb) = uu (:,:,: ,Kmm) 295 vv (:,:,: ,Kbb) = vv (:,:,: ,Kmm) 296 ssh (:,: ,Kbb) = ssh (:,: ,Kmm) 297 ! 298 IF( .NOT.ln_linssh ) THEN 299 DO jk = 1, jpk 300 e3t(:,:,jk,Kbb) = e3t(:,:,jk,Kmm) 301 END DO 302 ENDIF 303 ! 293 ts (:,:,:,:,Kbb) = ts (:,:,:,:,Kmm) ! all before fields set to now values 294 uu (:,:,: ,Kbb) = uu (:,:,: ,Kmm) 295 vv (:,:,: ,Kbb) = vv (:,:,: ,Kmm) 296 ssh(:,: ,Kbb) = ssh(:,: ,Kmm) 304 297 ENDIF 305 298 ! -
NEMO/branches/2020/dev_r12527_Gurvan_ShallowWater/src/OCE/ISF/isfcavgam.F90
r12077 r13151 29 29 ! 30 30 PUBLIC isfcav_gammats 31 31 32 # include "domzgr_substitute.h90" 32 33 !!---------------------------------------------------------------------- 33 34 !! NEMO/OCE 4.0 , NEMO Consortium (2018) -
NEMO/branches/2020/dev_r12527_Gurvan_ShallowWater/src/OCE/ISF/isfcpl.F90
r12489 r13151 15 15 USE isfutils, ONLY : debug 16 16 USE lib_mpp , ONLY: mpp_sum, mpp_max ! mpp routine 17 #if ! defined key_qco 17 18 USE domvvl , ONLY: dom_vvl_zgr ! vertical scale factor interpolation 19 #else 20 USE domqco , ONLY: dom_qco_zgr ! vertical scale factor interpolation 21 #endif 18 22 USE domngb , ONLY: dom_ngb ! find the closest grid point from a given lon/lat position 19 23 ! … … 43 47 !! * Substitutions 44 48 # include "do_loop_substitute.h90" 49 # include "domzgr_substitute.h90" 45 50 !!---------------------------------------------------------------------- 46 51 !! NEMO/OCE 4.0 , NEMO Consortium (2018) … … 112 117 vv (:,:,:,Kbb) = vv (:,:,:,Kmm) 113 118 ssh (:,:,Kbb) = ssh (:,:,Kmm) 119 #if ! defined key_qco 114 120 e3t(:,:,:,Kbb) = e3t(:,:,:,Kmm) 115 121 #endif 116 122 ! prepare writing restart 117 123 IF( lwxios ) THEN … … 135 141 INTEGER, INTENT(in) :: Kmm ! ocean time level index 136 142 !!---------------------------------------------------------------------- 143 INTEGER :: jk ! loop index 144 REAL(wp), DIMENSION(jpi,jpj,jpk) :: ze3t, ze3u, ze3v, zgdepw ! e3t , e3u, e3v !!st patch to use substitution 145 !!---------------------------------------------------------------------- 146 ! 147 DO jk = 1, jpk 148 ze3t(:,:,jk) = e3t(:,:,jk,Kmm) 149 ze3u(:,:,jk) = e3u(:,:,jk,Kmm) 150 ze3v(:,:,jk) = e3v(:,:,jk,Kmm) 151 ! 152 zgdepw(:,:,jk) = gdepw(:,:,jk,Kmm) 153 END DO 137 154 ! 138 155 IF( lwxios ) CALL iom_swap( cwxios_context ) 139 156 CALL iom_rstput( kt, nitrst, numrow, 'tmask' , tmask , ldxios = lwxios ) 140 157 CALL iom_rstput( kt, nitrst, numrow, 'ssmask' , ssmask, ldxios = lwxios ) 141 CALL iom_rstput( kt, nitrst, numrow, 'e3t_n' , e3t(:,:,:,Kmm), ldxios = lwxios )142 CALL iom_rstput( kt, nitrst, numrow, 'e3u_n' , e3u(:,:,:,Kmm), ldxios = lwxios )143 CALL iom_rstput( kt, nitrst, numrow, 'e3v_n' , e3v(:,:,:,Kmm), ldxios = lwxios )144 CALL iom_rstput( kt, nitrst, numrow, 'gdepw_n', gdepw(:,:,:,Kmm), ldxios = lwxios )158 CALL iom_rstput( kt, nitrst, numrow, 'e3t_n' , ze3t , ldxios = lwxios ) 159 CALL iom_rstput( kt, nitrst, numrow, 'e3u_n' , ze3u , ldxios = lwxios ) 160 CALL iom_rstput( kt, nitrst, numrow, 'e3v_n' , ze3v , ldxios = lwxios ) 161 CALL iom_rstput( kt, nitrst, numrow, 'gdepw_n', zgdepw , ldxios = lwxios ) 145 162 IF( lwxios ) CALL iom_swap( cxios_context ) 146 163 ! … … 209 226 IF(lwp) write(numout,*) 'isfcpl_ssh : recompute scale factor from ssh (new wet cell,Kmm)' 210 227 IF(lwp) write(numout,*) '~~~~~~~~~~~' 228 #if ! defined key_qco 211 229 DO jk = 1, jpk 212 e3t(:,:,jk,Kmm) = e3t_0(:,:,jk) * ( ht_0(:,:) + ssh(:,:,Kmm) ) & 213 & / ( ht_0(:,:) + 1._wp - ssmask(:,:) ) * tmask(:,:,jk) & 214 & + e3t_0(:,:,jk) * (1._wp -tmask(:,:,jk)) 230 e3t(:,:,jk,Kmm) = e3t_0(:,:,jk) * ( 1._wp + (ht_0(:,:) + ssh(:,:,Kmm)) * r1_ht_0(:,:) ) 215 231 END DO 216 232 e3t(:,:,:,Kbb) = e3t(:,:,:,Kmm) 217 233 CALL dom_vvl_zgr(Kbb, Kmm, Kaa) 234 #else 235 CALL dom_qco_zgr(Kbb, Kmm, Kaa) 236 #endif 218 237 ! 219 238 END SUBROUTINE isfcpl_ssh … … 400 419 ! 1.1: get volume flux before coupling (>0 out) 401 420 DO_2D_00_00 402 zqvolb(ji,jj,jk) = ( e2u(ji,jj) * ze3u_b(ji,jj,jk) * uu(ji,jj,jk,Kmm) - e2u(ji-1,jj ) * ze3u_b(ji-1,jj ,jk) * uu(ji-1,jj ,jk,Kmm) & 403 & + e1v(ji,jj) * ze3v_b(ji,jj,jk) * vv(ji,jj,jk,Kmm) - e1v(ji ,jj-1) * ze3v_b(ji ,jj-1,jk) * vv(ji ,jj-1,jk,Kmm) ) & 404 & * ztmask_b(ji,jj,jk) 421 zqvolb(ji,jj,jk) = & 422 & ( e2u(ji ,jj ) * ze3u_b(ji ,jj ,jk) * uu(ji ,jj ,jk,Kmm) & 423 & - e2u(ji-1,jj ) * ze3u_b(ji-1,jj ,jk) * uu(ji-1,jj ,jk,Kmm) & 424 & + e1v(ji ,jj ) * ze3v_b(ji ,jj ,jk) * vv(ji ,jj ,jk,Kmm) & 425 & - e1v(ji ,jj-1) * ze3v_b(ji ,jj-1,jk) * vv(ji ,jj-1,jk,Kmm) ) & 426 & * ztmask_b(ji,jj,jk) 405 427 END_2D 406 428 ! … … 412 434 ! compute volume flux divergence after coupling 413 435 DO_2D_00_00 414 zqvoln(ji,jj,jk) = ( e2u(ji,jj) * e3u(ji,jj,jk,Kmm) * uu(ji,jj,jk,Kmm) - e2u(ji-1,jj ) * e3u(ji-1,jj ,jk,Kmm) * uu(ji-1,jj ,jk,Kmm) & 415 & + e1v(ji,jj) * e3v(ji,jj,jk,Kmm) * vv(ji,jj,jk,Kmm) - e1v(ji ,jj-1) * e3v(ji ,jj-1,jk,Kmm) * vv(ji ,jj-1,jk,Kmm) ) & 416 & * tmask(ji,jj,jk) 436 zqvoln(ji,jj,jk) = & 437 & ( e2u(ji ,jj ) * e3u(ji ,jj ,jk,Kmm) * uu(ji ,jj ,jk,Kmm) & 438 & - e2u(ji-1,jj ) * e3u(ji-1,jj ,jk,Kmm) * uu(ji-1,jj ,jk,Kmm) & 439 & + e1v(ji ,jj ) * e3v(ji ,jj ,jk,Kmm) * vv(ji ,jj ,jk,Kmm) & 440 & - e1v(ji ,jj-1) * e3v(ji ,jj-1,jk,Kmm) * vv(ji ,jj-1,jk,Kmm) ) & 441 & * tmask(ji,jj,jk) 417 442 END_2D 418 443 ! … … 523 548 524 549 ! volume diff 525 zdvol = e3t(ji,jj,jk,Kmm) * tmask(ji,jj,jk) - ze3t_b(ji,jj,jk) * ztmask_b(ji,jj,jk) 550 zdvol = e3t (ji,jj,jk,Kmm) * tmask (ji,jj,jk) & 551 & - ze3t_b(ji,jj,jk ) * ztmask_b(ji,jj,jk) 526 552 527 553 ! heat diff 528 zdtem = ts 554 zdtem = ts(ji,jj,jk,jp_tem,Kmm) * e3t(ji,jj,jk,Kmm) * tmask (ji,jj,jk) & 529 555 - zt_b(ji,jj,jk) * ze3t_b(ji,jj,jk) * ztmask_b(ji,jj,jk) 530 556 … … 555 581 DO ji = nldi,nlei 556 582 jip1=MIN(ji+1,jpi) ; jim1=MAX(ji-1,1) ; jjp1=MIN(jj+1,jpj) ; jjm1=MAX(jj-1,1) ; 557 IF ( tmask(ji,jj,jk) == 0._wp .AND. ztmask_b(ji,jj,jk) == 1._wp ) nisfl(narea) = nisfl(narea) + MAX(SUM(tmask(jim1:jip1,jjm1:jjp1,jk)),1._wp) 583 IF ( tmask(ji,jj,jk) == 0._wp .AND. ztmask_b(ji,jj,jk) == 1._wp ) THEN 584 nisfl(narea) = nisfl(narea) + MAX(SUM(tmask(jim1:jip1,jjm1:jjp1,jk)),1._wp) 585 ENDIF 558 586 ENDDO 559 587 ENDDO -
NEMO/branches/2020/dev_r12527_Gurvan_ShallowWater/src/OCE/ISF/isfdiags.F90
r12340 r13151 26 26 !! * Substitutions 27 27 # include "do_loop_substitute.h90" 28 # include "domzgr_substitute.h90" 28 29 !!---------------------------------------------------------------------- 29 30 !! NEMO/OCE 4.0 , NEMO Consortium (2018) -
NEMO/branches/2020/dev_r12527_Gurvan_ShallowWater/src/OCE/ISF/isfdynatf.F90
r12489 r13151 14 14 15 15 USE phycst , ONLY: r1_rho0 ! physical constant 16 USE dom_oce, ONLY: tmask, ssmask, ht, e3t, r1_e1e2t ! time and space domain 16 USE dom_oce ! time and space domain 17 USE oce, ONLY : ssh ! sea-surface height !!st needed for substitution 17 18 18 19 USE in_out_manager … … 25 26 !! * Substitutions 26 27 # include "do_loop_substitute.h90" 28 # include "domzgr_substitute.h90" 27 29 28 30 CONTAINS … … 81 83 ! add the increment 82 84 DO jk = 1, jpkm1 83 pe3t_f(:,:,jk) = pe3t_f(:,:,jk) - tmask(:,:,jk) * zfwfinc(:,:) * e3t(:,:,jk,Kmm) 85 pe3t_f(:,:,jk) = pe3t_f(:,:,jk) - tmask(:,:,jk) * zfwfinc(:,:) & 86 & * e3t(:,:,jk,Kmm) 84 87 END DO 85 88 ! -
NEMO/branches/2020/dev_r12527_Gurvan_ShallowWater/src/OCE/ISF/isfhdiv.F90
r12489 r13151 26 26 !! * Substitutions 27 27 # include "do_loop_substitute.h90" 28 # include "domzgr_substitute.h90" 28 29 29 30 CONTAINS … … 134 135 ! 135 136 DO jk=1,jpk 136 phdiv(:,:,jk) = phdiv(:,:,jk) + pqvol(:,:,jk) * r1_e1e2t(:,:) / e3t(:,:,jk,Kmm) 137 phdiv(:,:,jk) = phdiv(:,:,jk) + pqvol(:,:,jk) * r1_e1e2t(:,:) & 138 & / e3t(:,:,jk,Kmm) 137 139 END DO 138 140 ! -
NEMO/branches/2020/dev_r12527_Gurvan_ShallowWater/src/OCE/ISF/isfload.F90
r12340 r13151 13 13 USE isf_oce, ONLY: cn_isfload, rn_isfload_T, rn_isfload_S ! ice shelf variables 14 14 15 USE dom_oce , ONLY: e3w, gdept, risfdep, mikt! vertical scale factor15 USE dom_oce ! vertical scale factor 16 16 USE eosbn2 , ONLY: eos ! eos routine 17 17 … … 26 26 !! * Substitutions 27 27 # include "do_loop_substitute.h90" 28 # include "domzgr_substitute.h90" 28 29 29 30 CONTAINS … … 99 100 ! 100 101 ! top layer of the ice shelf 101 pisfload(ji,jj) = pisfload(ji,jj) + (znad + zrhd(ji,jj,1) ) * e3w(ji,jj,1,Kmm) 102 pisfload(ji,jj) = pisfload(ji,jj) + (znad + zrhd(ji,jj,1) ) & 103 & * e3w(ji,jj,1,Kmm) 102 104 ! 103 105 ! core layers of the ice shelf 104 106 DO jk = 2, ikt-1 105 pisfload(ji,jj) = pisfload(ji,jj) + (2._wp * znad + zrhd(ji,jj,jk-1) + zrhd(ji,jj,jk)) * e3w(ji,jj,jk,Kmm) 107 pisfload(ji,jj) = pisfload(ji,jj) + (2._wp * znad + zrhd(ji,jj,jk-1) + zrhd(ji,jj,jk)) & 108 & * e3w(ji,jj,jk,Kmm) 106 109 END DO 107 110 ! -
NEMO/branches/2020/dev_r12527_Gurvan_ShallowWater/src/OCE/ISF/isfstp.F90
r12242 r13151 11 11 12 12 !!---------------------------------------------------------------------- 13 !! isfstp : compute iceshelf melt and heat flux14 !!---------------------------------------------------------------------- 15 !16 USE isf _oce ! isf variables17 USE isf load, ONLY: isf_load ! ice shelf load18 USE isf tbl , ONLY: isf_tbl_lvl ! ice shelf boundary layer19 USE isf par , ONLY: isf_par, isf_par_init ! ice shelf parametrisation20 USE isfc av , ONLY: isf_cav, isf_cav_init ! ice shelf cavity21 USE isfcpl , ONLY: isfcpl_rst_write, isfcpl_init ! isf variables 22 23 USE dom_oce, ONLY: ht, e3t, ln_isfcav, ln_linssh ! ocean space and time domain24 USE domvvl , ONLY: ln_vvl_zstar! zstar logical25 USE zdfdrg , ONLY: r_Cdmin_top, r_ke0_top! vertical physics: top/bottom drag coef.13 !! isfstp : compute iceshelf melt and heat flux 14 !!---------------------------------------------------------------------- 15 USE isf_oce ! isf variables 16 USE isfload , ONLY: isf_load ! ice shelf load 17 USE isftbl , ONLY: isf_tbl_lvl ! ice shelf boundary layer 18 USE isfpar , ONLY: isf_par, isf_par_init ! ice shelf parametrisation 19 USE isfcav , ONLY: isf_cav, isf_cav_init ! ice shelf cavity 20 USE isfcpl , ONLY: isfcpl_rst_write, isfcpl_init ! isf variables 21 22 USE dom_oce ! ocean space and time domain 23 USE oce , ONLY: ssh ! sea surface height 24 USE domvvl , ONLY: ln_vvl_zstar ! zstar logical 25 USE zdfdrg , ONLY: r_Cdmin_top, r_ke0_top ! vertical physics: top/bottom drag coef. 26 26 ! 27 27 USE lib_mpp, ONLY: ctl_stop, ctl_nam … … 31 31 32 32 IMPLICIT NONE 33 34 33 PRIVATE 35 34 36 35 PUBLIC isf_stp, isf_init, isf_nam ! routine called in sbcmod and divhor 37 36 37 !! * Substitutions 38 # include "domzgr_substitute.h90" 38 39 !!---------------------------------------------------------------------- 39 40 !! NEMO/OCE 4.0 , NEMO Consortium (2018) … … 41 42 !! Software governed by the CeCILL license (see ./LICENSE) 42 43 !!---------------------------------------------------------------------- 44 43 45 CONTAINS 44 46 … … 60 62 INTEGER, INTENT(in) :: kt ! ocean time step 61 63 INTEGER, INTENT(in) :: Kmm ! ocean time level index 64 !!---------------------------------------------------------------------- 65 INTEGER :: jk ! loop index 66 REAL(wp), DIMENSION(jpi,jpj,jpk) :: ze3t ! e3t 62 67 !!--------------------------------------------------------------------- 63 68 ! … … 78 83 ! 1.2: compute misfkb, rhisf_tbl, rfrac (deepest level, thickness, fraction of deepest cell affected by tbl) 79 84 rhisf_tbl_cav(:,:) = rn_htbl * mskisf_cav(:,:) 80 CALL isf_tbl_lvl(ht, e3t(:,:,:,Kmm), misfkt_cav, misfkb_cav, rhisf_tbl_cav, rfrac_tbl_cav) 85 DO jk = 1, jpk 86 ze3t(:,:,jk) = e3t(:,:,jk,Kmm) 87 END DO 88 CALL isf_tbl_lvl(ht(:,:), ze3t, misfkt_cav, misfkb_cav, rhisf_tbl_cav, rfrac_tbl_cav) 81 89 ! 82 90 ! 1.3: compute ice shelf melt … … 100 108 ! by simplicity, we assume the top level where param applied do not change with time (done in init part) 101 109 rhisf_tbl_par(:,:) = rhisf0_tbl_par(:,:) 102 CALL isf_tbl_lvl(ht, e3t(:,:,:,Kmm), misfkt_par, misfkb_par, rhisf_tbl_par, rfrac_tbl_par) 110 DO jk = 1, jpk 111 ze3t(:,:,jk) = e3t(:,:,jk,Kmm) 112 END DO 113 CALL isf_tbl_lvl(ht(:,:), ze3t, misfkt_par, misfkb_par, rhisf_tbl_par, rfrac_tbl_par) 103 114 ! 104 115 ! 2.3: compute ice shelf melt -
NEMO/branches/2020/dev_r12527_Gurvan_ShallowWater/src/OCE/ISF/isftbl.F90
r12340 r13151 25 25 !! * Substitutions 26 26 # include "do_loop_substitute.h90" 27 # include "domzgr_substitute.h90" 27 28 28 29 CONTAINS … … 56 57 REAL(wp), DIMENSION(jpi,jpj) :: zhtbl ! thickness of the tbl 57 58 REAL(wp), DIMENSION(jpi,jpj) :: zfrac ! thickness of the tbl 59 INTEGER :: jk ! loop index 60 REAL(wp), DIMENSION(jpi,jpj,jpk) :: ze3t,ze3u,ze3v ! e3 58 61 !!-------------------------------------------------------------------- 59 62 ! … … 64 67 zhtbl = phtbl 65 68 ! 69 DO jk = 1, jpk 70 ze3u(:,:,jk) = e3u(:,:,jk,Kmm) 71 END DO 66 72 ! compute tbl lvl and thickness 67 CALL isf_tbl_lvl( hu(:,:,Kmm), e3u(:,:,:,Kmm), ktop, ikbot, zhtbl, zfrac )73 CALL isf_tbl_lvl( hu(:,:,Kmm), ze3u, ktop, ikbot, zhtbl, zfrac ) 68 74 ! 69 75 ! compute tbl property at U point 70 CALL isf_tbl_avg( miku, ikbot, zhtbl, zfrac, e3u(:,:,:,Kmm), pvarin, zvarout )76 CALL isf_tbl_avg( miku, ikbot, zhtbl, zfrac, ze3u, pvarin, zvarout ) 71 77 ! 72 78 ! compute tbl property at T point … … 82 88 zhtbl = phtbl 83 89 ! 90 DO jk = 1, jpk 91 ze3v(:,:,jk) = e3v(:,:,jk,Kmm) 92 END DO 84 93 ! compute tbl lvl and thickness 85 CALL isf_tbl_lvl( hv(:,:,Kmm), e3v(:,:,:,Kmm), ktop, ikbot, zhtbl, zfrac )94 CALL isf_tbl_lvl( hv(:,:,Kmm), ze3v, ktop, ikbot, zhtbl, zfrac ) 86 95 ! 87 96 ! compute tbl property at V point 88 CALL isf_tbl_avg( mikv, ikbot, zhtbl, zfrac, e3v(:,:,:,Kmm), pvarin, zvarout )97 CALL isf_tbl_avg( mikv, ikbot, zhtbl, zfrac, ze3v, pvarin, zvarout ) 89 98 ! 90 99 ! pvarout is an averaging of wet point … … 98 107 ! 99 108 ! compute tbl property at T point 100 CALL isf_tbl_avg( ktop, kbot, phtbl, pfrac, e3t(:,:,:,Kmm), pvarin, pvarout ) 109 DO jk = 1, jpk 110 ze3t(:,:,jk) = e3t(:,:,jk,Kmm) 111 END DO 112 CALL isf_tbl_avg( ktop, kbot, phtbl, pfrac, ze3t, pvarin, pvarout ) 101 113 ! 102 114 END SELECT … … 212 224 ! phtbl need to be bounded by water column thickness before 213 225 ! test: if htbl = water column thickness, should return mbathy 214 ! test: if htbl = 0 should return ktop (phtbl cap to e3t(ji,jj,1))226 ! test: if htbl = 0 should return ktop (phtbl cap to pe3t(ji,jj,1)) 215 227 ! 216 228 ! get ktbl -
NEMO/branches/2020/dev_r12527_Gurvan_ShallowWater/src/OCE/LDF/ldfslp.F90
r12377 r13151 75 75 !! * Substitutions 76 76 # include "do_loop_substitute.h90" 77 # include "domzgr_substitute.h90" 77 78 !!---------------------------------------------------------------------- 78 79 !! NEMO/OCE 4.0 , NEMO Consortium (2018) … … 198 199 ! ! max slope = 1/2 * e3 / e1 199 200 IF (ln_zps .AND. jk==mbku(ji,jj)) & 200 zbu = MIN( zbu, - z1_slpmax * ABS( zau ) , - 2._wp * e1u(ji,jj) / e3u(ji,jj,jk,Kmm)* ABS( zau ) ) 201 zbu = MIN( zbu, - z1_slpmax * ABS( zau ) , & 202 & - 2._wp * e1u(ji,jj) / e3u(ji,jj,jk,Kmm)* ABS( zau ) ) 201 203 IF (ln_zps .AND. jk==mbkv(ji,jj)) & 202 zbv = MIN( zbv, - z1_slpmax * ABS( zav ) , - 2._wp * e2v(ji,jj) / e3v(ji,jj,jk,Kmm)* ABS( zav ) ) 204 zbv = MIN( zbv, - z1_slpmax * ABS( zav ) , & 205 & - 2._wp * e2v(ji,jj) / e3v(ji,jj,jk,Kmm)* ABS( zav ) ) 203 206 ! ! uslp and vslp output in zwz and zww, resp. 204 207 zfi = MAX( omlmask(ji,jj,jk), omlmask(ji+1,jj,jk) ) 205 208 zfj = MAX( omlmask(ji,jj,jk), omlmask(ji,jj+1,jk) ) 206 209 ! thickness of water column between surface and level k at u/v point 207 zdepu = 0.5_wp * ( ( gdept (ji,jj,jk,Kmm) + gdept (ji+1,jj,jk,Kmm) ) & 208 - 2 * MAX( risfdep(ji,jj), risfdep(ji+1,jj) ) - e3u(ji,jj,miku(ji,jj),Kmm) ) 209 zdepv = 0.5_wp * ( ( gdept (ji,jj,jk,Kmm) + gdept (ji,jj+1,jk,Kmm) ) & 210 - 2 * MAX( risfdep(ji,jj), risfdep(ji,jj+1) ) - e3v(ji,jj,mikv(ji,jj),Kmm) ) 210 zdepu = 0.5_wp * ( ( gdept (ji,jj,jk,Kmm) + gdept (ji+1,jj,jk,Kmm) ) & 211 & - 2 * MAX( risfdep(ji,jj), risfdep(ji+1,jj) ) & 212 & - e3u(ji,jj,miku(ji,jj),Kmm) ) 213 zdepv = 0.5_wp * ( ( gdept (ji,jj,jk,Kmm) + gdept (ji,jj+1,jk,Kmm) ) & 214 & - 2 * MAX( risfdep(ji,jj), risfdep(ji,jj+1) ) & 215 & - e3v(ji,jj,mikv(ji,jj),Kmm) ) 211 216 ! 212 217 zwz(ji,jj,jk) = ( ( 1._wp - zfi) * zau / ( zbu - zeps ) & … … 293 298 ! ! ! jk must be >= ML level for zfk=1. otherwise zfk=0. 294 299 ! zfk = REAL( 1 - 1/(1 + jk / nmln(ji+1,jj)), wp ) 295 ! zck = gdepw(ji,jj,jk ) / MAX( hmlp(ji,jj), 10. )300 ! zck = gdepw(ji,jj,jk,Kmm) / MAX( hmlp(ji,jj), 10. ) 296 301 ! zwz(ji,jj,jk) = ( zfk * zai / ( zbi - zeps ) + ( 1._wp - zfk ) * wslpiml(ji,jj) * zck ) * tmask(ji,jj,jk) 297 302 ! zww(ji,jj,jk) = ( zfk * zaj / ( zbj - zeps ) + ( 1._wp - zfk ) * wslpjml(ji,jj) * zck ) * tmask(ji,jj,jk) -
NEMO/branches/2020/dev_r12527_Gurvan_ShallowWater/src/OCE/LDF/ldftra.F90
r12489 r13151 95 95 !! * Substitutions 96 96 # include "do_loop_substitute.h90" 97 # include "domzgr_substitute.h90" 97 98 !!---------------------------------------------------------------------- 98 99 !! NEMO/OCE 4.0 , NEMO Consortium (2018) -
NEMO/branches/2020/dev_r12527_Gurvan_ShallowWater/src/OCE/SBC/fldread.F90
r12489 r13151 127 127 !! * Substitutions 128 128 # include "do_loop_substitute.h90" 129 # include "domzgr_substitute.h90" 129 130 !!---------------------------------------------------------------------- 130 131 !! NEMO/OCE 4.0 , NEMO Consortium (2018) … … 617 618 zcoef = ( umask(ji,jj,jk) - wumask(ji,jj,jk) ) 618 619 zdhalf(jk) = zdhalf(jk-1) + e3u(ji,jj,jk-1,Kmm) 619 zdepth(jk) = 620 & 620 zdepth(jk) = zcoef * ( zdhalf(jk ) + 0.5_wp * e3uw(ji,jj,jk,Kmm)) & 621 & + (1._wp-zcoef) * ( zdepth(jk-1) + e3uw(ji,jj,jk,Kmm)) 621 622 END DO 622 623 CASE(3) ! depth of V points: we must not use gdept_n as we don't want to do a communication … … 631 632 zcoef = ( vmask(ji,jj,jk) - wvmask(ji,jj,jk) ) 632 633 zdhalf(jk) = zdhalf(jk-1) + e3v(ji,jj,jk-1,Kmm) 633 zdepth(jk) = 634 &+ (1._wp-zcoef) * ( zdepth(jk-1) + e3vw(ji,jj,jk,Kmm))634 zdepth(jk) = zcoef * ( zdhalf(jk ) + 0.5_wp * e3vw(ji,jj,jk,Kmm)) & 635 + (1._wp-zcoef) * ( zdepth(jk-1) + e3vw(ji,jj,jk,Kmm)) 635 636 END DO 636 637 END SELECT -
NEMO/branches/2020/dev_r12527_Gurvan_ShallowWater/src/OCE/SBC/sbcblk.F90
r12489 r13151 639 639 END IF 640 640 641 !! CALL iom_put( "Cd_oce", zcd_oce) ! output value of pure ocean-atm. transfer coef.642 !! CALL iom_put( "Ch_oce", zch_oce) ! output value of pure ocean-atm. transfer coef.643 644 IF( ABS(rn_zu - rn_zqt) < 0.1_wp ) THEN645 !! If zu == zt, then ensuring once for all that:646 t_zu(:,:) = ztpot(:,:)647 q_zu(:,:) = zqair(:,:)648 ENDIF649 650 651 641 ! Turbulent fluxes over ocean => BULK_FORMULA @ sbcblk_phy.F90 652 642 ! ------------------------------------------------------------- … … 663 653 ELSE !== BLK formulation ==! turbulent fluxes computation 664 654 CALL BULK_FORMULA( rn_zu, ptsk(:,:), pssq(:,:), t_zu(:,:), q_zu(:,:), & 665 & zcd_oce(:,:), zch_oce(:,:), zce_oce(:,:), &666 & wndm(:,:), zU_zu(:,:), pslp(:,:), &667 & taum(:,:), psen(:,:), zqla(:,:), &668 & pEvap=pevp(:,:), prhoa=rhoa(:,:) )655 & zcd_oce(:,:), zch_oce(:,:), zce_oce(:,:), & 656 & wndm(:,:), zU_zu(:,:), pslp(:,:), & 657 & taum(:,:), psen(:,:), zqla(:,:), & 658 & pEvap=pevp(:,:), prhoa=rhoa(:,:), pfact_evap=rn_efac ) 669 659 670 660 zqla(:,:) = zqla(:,:) * tmask(:,:,1) … … 1046 1036 evap_ice (:,:,:) = rn_efac * qla_ice (:,:,:) * z1_rLsub ! sublimation 1047 1037 devap_ice(:,:,:) = rn_efac * dqla_ice(:,:,:) * z1_rLsub ! d(sublimation)/dT 1048 zevap (:,:) = rn_efac * ( emp(:,:) + tprecip(:,:) ) ! evaporation over ocean1038 zevap (:,:) = emp(:,:) + tprecip(:,:) ! evaporation over ocean !LB: removed rn_efac here, correct??? 1049 1039 1050 1040 ! --- evaporation minus precipitation --- ! -
NEMO/branches/2020/dev_r12527_Gurvan_ShallowWater/src/OCE/SBC/sbcblk_algo_coare3p0.F90
r12377 r13151 194 194 IF( kt == nit000 ) CALL SBCBLK_ALGO_COARE3P0_INIT(l_use_cs, l_use_wl) 195 195 196 l_zt_equal_zu = .FALSE. 197 IF( ABS(zu - zt) < 0.01_wp ) l_zt_equal_zu = .TRUE. ! testing "zu == zt" is risky with double precision 196 l_zt_equal_zu = ( ABS(zu - zt) < 0.01_wp ) ! testing "zu == zt" is risky with double precision 198 197 IF( .NOT. l_zt_equal_zu ) ALLOCATE( zeta_t(jpi,jpj) ) 199 198 … … 396 395 ! 397 396 DO_2D_11_11 398 399 400 401 402 403 404 405 406 407 408 397 ! 398 zw = pwnd(ji,jj) ! wind speed 399 ! 400 ! Charnock's constant, increases with the wind : 401 zgt10 = 0.5 + SIGN(0.5_wp,(zw - 10)) ! If zw<10. --> 0, else --> 1 402 zgt18 = 0.5 + SIGN(0.5_wp,(zw - 18.)) ! If zw<18. --> 0, else --> 1 403 ! 404 alfa_charn_3p0(ji,jj) = (1. - zgt10)*0.011 & ! wind is lower than 10 m/s 405 & + zgt10*((1. - zgt18)*(0.011 + (0.018 - 0.011) & 406 & *(zw - 10.)/(18. - 10.)) + zgt18*( 0.018 ) ) ! Hare et al. (1999) 407 ! 409 408 END_2D 410 409 ! … … 432 431 ! 433 432 DO_2D_11_11 434 435 436 437 438 439 440 441 442 443 444 445 446 447 448 449 450 451 452 453 454 455 433 ! 434 zta = pzeta(ji,jj) 435 ! 436 zphi_m = ABS(1. - 15.*zta)**.25 !!Kansas unstable 437 ! 438 zpsi_k = 2.*LOG((1. + zphi_m)/2.) + LOG((1. + zphi_m*zphi_m)/2.) & 439 & - 2.*ATAN(zphi_m) + 0.5*rpi 440 ! 441 zphi_c = ABS(1. - 10.15*zta)**.3333 !!Convective 442 ! 443 zpsi_c = 1.5*LOG((1. + zphi_c + zphi_c*zphi_c)/3.) & 444 & - 1.7320508*ATAN((1. + 2.*zphi_c)/1.7320508) + 1.813799447 445 ! 446 zf = zta*zta 447 zf = zf/(1. + zf) 448 zc = MIN(50._wp, 0.35_wp*zta) 449 zstab = 0.5 + SIGN(0.5_wp, zta) 450 ! 451 psi_m_coare(ji,jj) = (1. - zstab) * ( (1. - zf)*zpsi_k + zf*zpsi_c ) & ! (zta < 0) 452 & - zstab * ( 1. + 1.*zta & ! (zta > 0) 453 & + 0.6667*(zta - 14.28)/EXP(zc) + 8.525 ) ! " 454 ! 456 455 END_2D 457 456 ! … … 483 482 ! 484 483 DO_2D_11_11 485 486 487 488 489 490 491 492 493 494 495 496 497 498 499 500 501 502 503 504 505 484 ! 485 zta = pzeta(ji,jj) 486 ! 487 zphi_h = (ABS(1. - 15.*zta))**.5 !! Kansas unstable (zphi_h = zphi_m**2 when unstable, zphi_m when stable) 488 ! 489 zpsi_k = 2.*LOG((1. + zphi_h)/2.) 490 ! 491 zphi_c = (ABS(1. - 34.15*zta))**.3333 !! Convective 492 ! 493 zpsi_c = 1.5*LOG((1. + zphi_c + zphi_c*zphi_c)/3.) & 494 & -1.7320508*ATAN((1. + 2.*zphi_c)/1.7320508) + 1.813799447 495 ! 496 zf = zta*zta 497 zf = zf/(1. + zf) 498 zc = MIN(50._wp,0.35_wp*zta) 499 zstab = 0.5 + SIGN(0.5_wp, zta) 500 ! 501 psi_h_coare(ji,jj) = (1. - zstab) * ( (1. - zf)*zpsi_k + zf*zpsi_c ) & 502 & - zstab * ( (ABS(1. + 2.*zta/3.))**1.5 & 503 & + .6667*(zta - 14.28)/EXP(zc) + 8.525 ) 504 ! 506 505 END_2D 507 506 ! -
NEMO/branches/2020/dev_r12527_Gurvan_ShallowWater/src/OCE/SBC/sbcblk_algo_coare3p6.F90
r12377 r13151 194 194 IF( kt == nit000 ) CALL SBCBLK_ALGO_COARE3P6_INIT(l_use_cs, l_use_wl) 195 195 196 l_zt_equal_zu = .FALSE. 197 IF( ABS(zu - zt) < 0.01_wp ) l_zt_equal_zu = .TRUE. ! testing "zu == zt" is risky with double precision 196 l_zt_equal_zu = ( ABS(zu - zt) < 0.01_wp ) ! testing "zu == zt" is risky with double precision 198 197 IF( .NOT. l_zt_equal_zu ) ALLOCATE( zeta_t(jpi,jpj) ) 199 198 … … 432 431 ! 433 432 DO_2D_11_11 434 435 436 437 438 439 440 441 442 443 444 445 446 447 448 449 450 451 452 453 454 455 433 ! 434 zta = pzeta(ji,jj) 435 ! 436 zphi_m = ABS(1. - 15.*zta)**.25 !!Kansas unstable 437 ! 438 zpsi_k = 2.*LOG((1. + zphi_m)/2.) + LOG((1. + zphi_m*zphi_m)/2.) & 439 & - 2.*ATAN(zphi_m) + 0.5*rpi 440 ! 441 zphi_c = ABS(1. - 10.15*zta)**.3333 !!Convective 442 ! 443 zpsi_c = 1.5*LOG((1. + zphi_c + zphi_c*zphi_c)/3.) & 444 & - 1.7320508*ATAN((1. + 2.*zphi_c)/1.7320508) + 1.813799447 445 ! 446 zf = zta*zta 447 zf = zf/(1. + zf) 448 zc = MIN(50._wp, 0.35_wp*zta) 449 zstab = 0.5 + SIGN(0.5_wp, zta) 450 ! 451 psi_m_coare(ji,jj) = (1. - zstab) * ( (1. - zf)*zpsi_k + zf*zpsi_c ) & ! (zta < 0) 452 & - zstab * ( 1. + 1.*zta & ! (zta > 0) 453 & + 0.6667*(zta - 14.28)/EXP(zc) + 8.525 ) ! " 454 ! 456 455 END_2D 457 456 ! … … 483 482 ! 484 483 DO_2D_11_11 485 486 487 488 489 490 491 492 493 494 495 496 497 498 499 500 501 502 503 504 505 484 ! 485 zta = pzeta(ji,jj) 486 ! 487 zphi_h = (ABS(1. - 15.*zta))**.5 !! Kansas unstable (zphi_h = zphi_m**2 when unstable, zphi_m when stable) 488 ! 489 zpsi_k = 2.*LOG((1. + zphi_h)/2.) 490 ! 491 zphi_c = (ABS(1. - 34.15*zta))**.3333 !! Convective 492 ! 493 zpsi_c = 1.5*LOG((1. + zphi_c + zphi_c*zphi_c)/3.) & 494 & -1.7320508*ATAN((1. + 2.*zphi_c)/1.7320508) + 1.813799447 495 ! 496 zf = zta*zta 497 zf = zf/(1. + zf) 498 zc = MIN(50._wp,0.35_wp*zta) 499 zstab = 0.5 + SIGN(0.5_wp, zta) 500 ! 501 psi_h_coare(ji,jj) = (1. - zstab) * ( (1. - zf)*zpsi_k + zf*zpsi_c ) & 502 & - zstab * ( (ABS(1. + 2.*zta/3.))**1.5 & 503 & + .6667*(zta - 14.28)/EXP(zc) + 8.525 ) 504 ! 506 505 END_2D 507 506 ! -
NEMO/branches/2020/dev_r12527_Gurvan_ShallowWater/src/OCE/SBC/sbcblk_algo_ecmwf.F90
r12377 r13151 98 98 & Qsw, rad_lw, slp, pdT_cs, & ! optionals for cool-skin (and warm-layer) 99 99 & pdT_wl, pHz_wl ) ! optionals for warm-layer only 100 !!---------------------------------------------------------------------- 100 !!---------------------------------------------------------------------------------- 101 101 !! *** ROUTINE turb_ecmwf *** 102 102 !! … … 184 184 LOGICAL :: l_zt_equal_zu = .FALSE. ! if q and t are given at same height as U 185 185 ! 186 REAL(wp), DIMENSION(jpi,jpj) :: 187 REAL(wp), DIMENSION(jpi,jpj) :: dt_zu, dq_zu 188 REAL(wp), DIMENSION(jpi,jpj) :: znu_a !: Nu_air, Viscosity of air186 REAL(wp), DIMENSION(jpi,jpj) :: u_star, t_star, q_star 187 REAL(wp), DIMENSION(jpi,jpj) :: dt_zu, dq_zu 188 REAL(wp), DIMENSION(jpi,jpj) :: znu_a !: Nu_air, Viscosity of air 189 189 REAL(wp), DIMENSION(jpi,jpj) :: Linv !: 1/L (inverse of Monin Obukhov length... 190 190 REAL(wp), DIMENSION(jpi,jpj) :: z0, z0t, z0q … … 196 196 CHARACTER(len=40), PARAMETER :: crtnm = 'turb_ecmwf@sbcblk_algo_ecmwf.F90' 197 197 !!---------------------------------------------------------------------------------- 198 199 198 IF( kt == nit000 ) CALL SBCBLK_ALGO_ECMWF_INIT(l_use_cs, l_use_wl) 200 199 201 l_zt_equal_zu = .FALSE. 202 IF( ABS(zu - zt) < 0.01_wp ) l_zt_equal_zu = .TRUE. ! testing "zu == zt" is risky with double precision 200 l_zt_equal_zu = ( ABS(zu - zt) < 0.01_wp ) ! testing "zu == zt" is risky with double precision 203 201 204 202 !! Initializations for cool skin and warm layer: … … 413 411 !!---------------------------------------------------------------------------------- 414 412 DO_2D_11_11 415 416 417 418 419 420 421 422 423 424 425 426 427 428 429 430 431 432 433 434 435 436 413 ! 414 zzeta = MIN( pzeta(ji,jj) , 5._wp ) !! Very stable conditions (L positif and big!): 415 ! 416 ! Unstable (Paulson 1970): 417 ! eq.3.20, Chap.3, p.33, IFS doc - Cy31r1 418 zx = SQRT(ABS(1._wp - 16._wp*zzeta)) 419 ztmp = 1._wp + SQRT(zx) 420 ztmp = ztmp*ztmp 421 psi_unst = LOG( 0.125_wp*ztmp*(1._wp + zx) ) & 422 & -2._wp*ATAN( SQRT(zx) ) + 0.5_wp*rpi 423 ! 424 ! Unstable: 425 ! eq.3.22, Chap.3, p.33, IFS doc - Cy31r1 426 psi_stab = -2._wp/3._wp*(zzeta - 5._wp/0.35_wp)*EXP(-0.35_wp*zzeta) & 427 & - zzeta - 2._wp/3._wp*5._wp/0.35_wp 428 ! 429 ! Combining: 430 stab = 0.5_wp + SIGN(0.5_wp, zzeta) ! zzeta > 0 => stab = 1 431 ! 432 psi_m_ecmwf(ji,jj) = (1._wp - stab) * psi_unst & ! (zzeta < 0) Unstable 433 & + stab * psi_stab ! (zzeta > 0) Stable 434 ! 437 435 END_2D 438 436 END FUNCTION psi_m_ecmwf … … 458 456 ! 459 457 DO_2D_11_11 460 461 462 463 464 465 466 467 468 469 470 471 472 473 474 475 476 477 478 458 ! 459 zzeta = MIN(pzeta(ji,jj) , 5._wp) ! Very stable conditions (L positif and big!): 460 ! 461 zx = ABS(1._wp - 16._wp*zzeta)**.25 ! this is actually (1/phi_m)**2 !!! 462 ! ! eq.3.19, Chap.3, p.33, IFS doc - Cy31r1 463 ! Unstable (Paulson 1970) : 464 psi_unst = 2._wp*LOG(0.5_wp*(1._wp + zx*zx)) ! eq.3.20, Chap.3, p.33, IFS doc - Cy31r1 465 ! 466 ! Stable: 467 psi_stab = -2._wp/3._wp*(zzeta - 5._wp/0.35_wp)*EXP(-0.35_wp*zzeta) & ! eq.3.22, Chap.3, p.33, IFS doc - Cy31r1 468 & - ABS(1._wp + 2._wp/3._wp*zzeta)**1.5_wp - 2._wp/3._wp*5._wp/0.35_wp + 1._wp 469 ! LB: added ABS() to avoid NaN values when unstable, which contaminates the unstable solution... 470 ! 471 stab = 0.5_wp + SIGN(0.5_wp, zzeta) ! zzeta > 0 => stab = 1 472 ! 473 ! 474 psi_h_ecmwf(ji,jj) = (1._wp - stab) * psi_unst & ! (zzeta < 0) Unstable 475 & + stab * psi_stab ! (zzeta > 0) Stable 476 ! 479 477 END_2D 480 478 END FUNCTION psi_h_ecmwf -
NEMO/branches/2020/dev_r12527_Gurvan_ShallowWater/src/OCE/SBC/sbcblk_algo_ncar.F90
r12377 r13151 112 112 REAL(wp), DIMENSION(jpi,jpj) :: stab ! stability test integer 113 113 !!---------------------------------------------------------------------------------- 114 ! 115 l_zt_equal_zu = .FALSE. 116 IF( ABS(zu - zt) < 0.01_wp ) l_zt_equal_zu = .TRUE. ! testing "zu == zt" is risky with double precision 114 l_zt_equal_zu = ( ABS(zu - zt) < 0.01_wp ) ! testing "zu == zt" is risky with double precision 117 115 118 116 U_blk = MAX( 0.5_wp , U_zu ) ! relative wind speed at zu (normally 10m), we don't want to fall under 0.5 m/s … … 143 141 ENDIF 144 142 145 !! Initializing values at z_u with z_t values: 146 t_zu = t_zt ; q_zu = q_zt 143 !! First guess of temperature and humidity at height zu: 144 t_zu = MAX( t_zt , 180._wp ) ! who knows what's given on masked-continental regions... 145 q_zu = MAX( q_zt , 1.e-6_wp ) ! " 147 146 148 147 !! ITERATION BLOCK -
NEMO/branches/2020/dev_r12527_Gurvan_ShallowWater/src/OCE/SBC/sbcblk_phy.F90
r12377 r13151 520 520 zCe = zz0*pqst(ji,jj)/zdq 521 521 522 CALL BULK_FORMULA ( pzu, pTs(ji,jj), pqs(ji,jj), pTa(ji,jj), pqa(ji,jj), &523 & zCd, zCh, zCe,&524 & pwnd(ji,jj), pUb(ji,jj), pslp(ji,jj),&525 & pTau(ji,jj), zQsen, zQlat )526 522 CALL BULK_FORMULA_SCLR( pzu, pTs(ji,jj), pqs(ji,jj), pTa(ji,jj), pqa(ji,jj), & 523 & zCd, zCh, zCe, & 524 & pwnd(ji,jj), pUb(ji,jj), pslp(ji,jj), & 525 & pTau(ji,jj), zQsen, zQlat ) 526 527 527 zTs2 = pTs(ji,jj)*pTs(ji,jj) 528 528 zQlw = emiss_w*(prlw(ji,jj) - stefan*zTs2*zTs2) ! Net longwave flux … … 535 535 536 536 537 SUBROUTINE BULK_FORMULA_VCTR( pzu, pTs, pqs, pTa, pqa, & 538 & pCd, pCh, pCe, & 539 & pwnd, pUb, pslp, & 540 & pTau, pQsen, pQlat, pEvap, prhoa ) 537 SUBROUTINE BULK_FORMULA_SCLR( pzu, pTs, pqs, pTa, pqa, & 538 & pCd, pCh, pCe, & 539 & pwnd, pUb, pslp, & 540 & pTau, pQsen, pQlat, & 541 & pEvap, prhoa, pfact_evap ) 542 !!---------------------------------------------------------------------------------- 543 REAL(wp), INTENT(in) :: pzu ! height above the sea-level where all this takes place (normally 10m) 544 REAL(wp), INTENT(in) :: pTs ! water temperature at the air-sea interface [K] 545 REAL(wp), INTENT(in) :: pqs ! satur. spec. hum. at T=pTs [kg/kg] 546 REAL(wp), INTENT(in) :: pTa ! potential air temperature at z=pzu [K] 547 REAL(wp), INTENT(in) :: pqa ! specific humidity at z=pzu [kg/kg] 548 REAL(wp), INTENT(in) :: pCd 549 REAL(wp), INTENT(in) :: pCh 550 REAL(wp), INTENT(in) :: pCe 551 REAL(wp), INTENT(in) :: pwnd ! wind speed module at z=pzu [m/s] 552 REAL(wp), INTENT(in) :: pUb ! bulk wind speed at z=pzu (inc. pot. effect of gustiness etc) [m/s] 553 REAL(wp), INTENT(in) :: pslp ! sea-level atmospheric pressure [Pa] 554 !! 555 REAL(wp), INTENT(out) :: pTau ! module of the wind stress [N/m^2] 556 REAL(wp), INTENT(out) :: pQsen ! [W/m^2] 557 REAL(wp), INTENT(out) :: pQlat ! [W/m^2] 558 !! 559 REAL(wp), INTENT(out), OPTIONAL :: pEvap ! Evaporation [kg/m^2/s] 560 REAL(wp), INTENT(out), OPTIONAL :: prhoa ! Air density at z=pzu [kg/m^3] 561 REAL(wp), INTENT(in) , OPTIONAL :: pfact_evap ! ABOMINATION: corrective factor for evaporation (doing this against my will! /laurent) 562 !! 563 REAL(wp) :: ztaa, zgamma, zrho, zUrho, zevap, zfact_evap 564 INTEGER :: jq 565 !!---------------------------------------------------------------------------------- 566 zfact_evap = 1._wp 567 IF( PRESENT(pfact_evap) ) zfact_evap = pfact_evap 568 569 !! Need ztaa, absolute temperature at pzu (formula to estimate rho_air needs absolute temperature, not the potential temperature "pTa") 570 ztaa = pTa ! first guess... 571 DO jq = 1, 4 572 zgamma = gamma_moist( 0.5*(ztaa+pTs) , pqa ) !LOLO: why not "0.5*(pqs+pqa)" rather then "pqa" ??? 573 ztaa = pTa - zgamma*pzu ! Absolute temp. is slightly colder... 574 END DO 575 zrho = rho_air(ztaa, pqa, pslp) 576 zrho = rho_air(ztaa, pqa, pslp-zrho*grav*pzu) ! taking into account that we are pzu m above the sea level where SLP is given! 577 578 zUrho = pUb*MAX(zrho, 1._wp) ! rho*U10 579 580 pTau = zUrho * pCd * pwnd ! Wind stress module 581 582 zevap = zUrho * pCe * (pqa - pqs) 583 pQsen = zUrho * pCh * (pTa - pTs) * cp_air(pqa) 584 pQlat = L_vap(pTs) * zevap 585 586 IF( PRESENT(pEvap) ) pEvap = - zfact_evap * zevap 587 IF( PRESENT(prhoa) ) prhoa = zrho 588 589 END SUBROUTINE BULK_FORMULA_SCLR 590 591 SUBROUTINE BULK_FORMULA_VCTR( pzu, pTs, pqs, pTa, pqa, & 592 & pCd, pCh, pCe, & 593 & pwnd, pUb, pslp, & 594 & pTau, pQsen, pQlat, & 595 & pEvap, prhoa, pfact_evap ) 541 596 !!---------------------------------------------------------------------------------- 542 597 REAL(wp), INTENT(in) :: pzu ! height above the sea-level where all this takes place (normally 10m) … … 558 613 REAL(wp), DIMENSION(jpi,jpj), INTENT(out), OPTIONAL :: pEvap ! Evaporation [kg/m^2/s] 559 614 REAL(wp), DIMENSION(jpi,jpj), INTENT(out), OPTIONAL :: prhoa ! Air density at z=pzu [kg/m^3] 560 !! 561 REAL(wp) :: ztaa, zgamma, zrho, zUrho, zevap 562 INTEGER :: ji, jj, jq ! dummy loop indices 563 !!---------------------------------------------------------------------------------- 564 DO_2D_11_11 565 566 !! Need ztaa, absolute temperature at pzu (formula to estimate rho_air needs absolute temperature, not the potential temperature "pTa") 567 ztaa = pTa(ji,jj) ! first guess... 568 DO jq = 1, 4 569 zgamma = gamma_moist( 0.5*(ztaa+pTs(ji,jj)) , pqa(ji,jj) ) 570 ztaa = pTa(ji,jj) - zgamma*pzu ! Absolute temp. is slightly colder... 571 END DO 572 zrho = rho_air(ztaa, pqa(ji,jj), pslp(ji,jj)) 573 zrho = rho_air(ztaa, pqa(ji,jj), pslp(ji,jj)-zrho*grav*pzu) ! taking into account that we are pzu m above the sea level where SLP is given! 574 575 zUrho = pUb(ji,jj)*MAX(zrho, 1._wp) ! rho*U10 576 577 pTau(ji,jj) = zUrho * pCd(ji,jj) * pwnd(ji,jj) ! Wind stress module 578 579 zevap = zUrho * pCe(ji,jj) * (pqa(ji,jj) - pqs(ji,jj)) 580 pQsen(ji,jj) = zUrho * pCh(ji,jj) * (pTa(ji,jj) - pTs(ji,jj)) * cp_air(pqa(ji,jj)) 581 pQlat(ji,jj) = L_vap(pTs(ji,jj)) * zevap 582 583 IF( PRESENT(pEvap) ) pEvap(ji,jj) = - zevap 615 REAL(wp), INTENT(in) , OPTIONAL :: pfact_evap ! ABOMINATION: corrective factor for evaporation (doing this against my will! /laurent) 616 !! 617 REAL(wp) :: ztaa, zgamma, zrho, zUrho, zevap, zfact_evap 618 INTEGER :: ji, jj 619 !!---------------------------------------------------------------------------------- 620 zfact_evap = 1._wp 621 IF( PRESENT(pfact_evap) ) zfact_evap = pfact_evap 622 623 DO_2D_11_11 624 625 CALL BULK_FORMULA_SCLR( pzu, pTs(ji,jj), pqs(ji,jj), pTa(ji,jj), pqa(ji,jj), & 626 & pCd(ji,jj), pCh(ji,jj), pCe(ji,jj), & 627 & pwnd(ji,jj), pUb(ji,jj), pslp(ji,jj), & 628 & pTau(ji,jj), pQsen(ji,jj), pQlat(ji,jj), & 629 & pEvap=zevap, prhoa=zrho, pfact_evap=zfact_evap ) 630 631 IF( PRESENT(pEvap) ) pEvap(ji,jj) = zevap 584 632 IF( PRESENT(prhoa) ) prhoa(ji,jj) = zrho 585 633 586 634 END_2D 587 635 END SUBROUTINE BULK_FORMULA_VCTR 588 589 590 SUBROUTINE BULK_FORMULA_SCLR( pzu, pTs, pqs, pTa, pqa, &591 & pCd, pCh, pCe, &592 & pwnd, pUb, pslp, &593 & pTau, pQsen, pQlat, pEvap, prhoa )594 !!----------------------------------------------------------------------------------595 REAL(wp), INTENT(in) :: pzu ! height above the sea-level where all this takes place (normally 10m)596 REAL(wp), INTENT(in) :: pTs ! water temperature at the air-sea interface [K]597 REAL(wp), INTENT(in) :: pqs ! satur. spec. hum. at T=pTs [kg/kg]598 REAL(wp), INTENT(in) :: pTa ! potential air temperature at z=pzu [K]599 REAL(wp), INTENT(in) :: pqa ! specific humidity at z=pzu [kg/kg]600 REAL(wp), INTENT(in) :: pCd601 REAL(wp), INTENT(in) :: pCh602 REAL(wp), INTENT(in) :: pCe603 REAL(wp), INTENT(in) :: pwnd ! wind speed module at z=pzu [m/s]604 REAL(wp), INTENT(in) :: pUb ! bulk wind speed at z=pzu (inc. pot. effect of gustiness etc) [m/s]605 REAL(wp), INTENT(in) :: pslp ! sea-level atmospheric pressure [Pa]606 !!607 REAL(wp), INTENT(out) :: pTau ! module of the wind stress [N/m^2]608 REAL(wp), INTENT(out) :: pQsen ! [W/m^2]609 REAL(wp), INTENT(out) :: pQlat ! [W/m^2]610 !!611 REAL(wp), INTENT(out), OPTIONAL :: pEvap ! Evaporation [kg/m^2/s]612 REAL(wp), INTENT(out), OPTIONAL :: prhoa ! Air density at z=pzu [kg/m^3]613 !!614 REAL(wp) :: ztaa, zgamma, zrho, zUrho, zevap615 INTEGER :: jq616 !!----------------------------------------------------------------------------------617 618 !! Need ztaa, absolute temperature at pzu (formula to estimate rho_air needs absolute temperature, not the potential temperature "pTa")619 ztaa = pTa ! first guess...620 DO jq = 1, 4621 zgamma = gamma_moist( 0.5*(ztaa+pTs) , pqa )622 ztaa = pTa - zgamma*pzu ! Absolute temp. is slightly colder...623 END DO624 zrho = rho_air(ztaa, pqa, pslp)625 zrho = rho_air(ztaa, pqa, pslp-zrho*grav*pzu) ! taking into account that we are pzu m above the sea level where SLP is given!626 627 zUrho = pUb*MAX(zrho, 1._wp) ! rho*U10628 629 pTau = zUrho * pCd * pwnd ! Wind stress module630 631 zevap = zUrho * pCe * (pqa - pqs)632 pQsen = zUrho * pCh * (pTa - pTs) * cp_air(pqa)633 pQlat = L_vap(pTs) * zevap634 635 IF( PRESENT(pEvap) ) pEvap = - zevap636 IF( PRESENT(prhoa) ) prhoa = zrho637 638 END SUBROUTINE BULK_FORMULA_SCLR639 640 641 636 642 637 -
NEMO/branches/2020/dev_r12527_Gurvan_ShallowWater/src/OCE/SBC/sbccpl.F90
r12489 r13151 199 199 !! Substitution 200 200 # include "do_loop_substitute.h90" 201 # include "domzgr_substitute.h90" 201 202 !!---------------------------------------------------------------------- 202 203 !! NEMO/OCE 4.0 , NEMO Consortium (2018) … … 1115 1116 IF( ln_dm2dc .AND. ncpl_qsr_freq /= 86400 ) & 1116 1117 & CALL ctl_stop( 'sbc_cpl_rcv: diurnal cycle reconstruction (ln_dm2dc) needs daily couping for solar radiation' ) 1117 ncpl_qsr_freq = 86400 / ncpl_qsr_freq ! used by top 1118 1119 IF( ncpl_qsr_freq /= 0) ncpl_qsr_freq = 86400 / ncpl_qsr_freq ! used by top 1120 1118 1121 ENDIF 1119 1122 ! -
NEMO/branches/2020/dev_r12527_Gurvan_ShallowWater/src/OCE/SBC/sbcice_cice.F90
r12489 r13151 12 12 USE oce ! ocean dynamics and tracers 13 13 USE dom_oce ! ocean space and time domain 14 # if ! defined key_qco 14 15 USE domvvl 16 # else 17 USE domqco 18 # endif 15 19 USE phycst, only : rcp, rho0, r1_rho0, rhos, rhoi 16 20 USE in_out_manager ! I/O manager … … 36 40 # if defined key_cice4 37 41 USE ice_flux, only: strax,stray,strocnx,strocny,frain,fsnow, & 38 strocnxT,strocnyT, & 42 strocnxT,strocnyT, & 39 43 sst,sss,uocn,vocn,ss_tltx,ss_tlty,fsalt_gbm, & 40 44 fresh_gbm,fhocn_gbm,fswthru_gbm,frzmlt, & … … 45 49 #else 46 50 USE ice_flux, only: strax,stray,strocnx,strocny,frain,fsnow, & 47 strocnxT,strocnyT, & 51 strocnxT,strocnyT, & 48 52 sst,sss,uocn,vocn,ss_tltx,ss_tlty,fsalt_ai, & 49 53 fresh_ai,fhocn_ai,fswthru_ai,frzmlt, & … … 70 74 INTEGER :: jj_off 71 75 72 INTEGER , PARAMETER :: jpfld = 13 ! maximum number of files to read 76 INTEGER , PARAMETER :: jpfld = 13 ! maximum number of files to read 73 77 INTEGER , PARAMETER :: jp_snow = 1 ! index of snow file 74 78 INTEGER , PARAMETER :: jp_rain = 2 ! index of rain file … … 109 113 !!--------------------------------------------------------------------- 110 114 !! *** ROUTINE sbc_ice_cice *** 111 !! 112 !! ** Purpose : update the ocean surface boundary condition via the 113 !! CICE Sea Ice Model time stepping 114 !! 115 !! ** Method : - Get any extra forcing fields for CICE 115 !! 116 !! ** Purpose : update the ocean surface boundary condition via the 117 !! CICE Sea Ice Model time stepping 118 !! 119 !! ** Method : - Get any extra forcing fields for CICE 116 120 !! - Prepare forcing fields 117 121 !! - CICE model time stepping 118 !! - call the routine that computes mass and 122 !! - call the routine that computes mass and 119 123 !! heat fluxes at the ice/ocean interface 120 124 !! … … 171 175 ! there is no restart file. 172 176 ! Values from a CICE restart file would overwrite this 173 IF( .NOT. ln_rstart ) THEN 174 CALL nemo2cice( ts(:,:,1,jp_tem,Kmm) , sst , 'T' , 1.) 175 ENDIF 177 IF( .NOT. ln_rstart ) THEN 178 CALL nemo2cice( ts(:,:,1,jp_tem,Kmm) , sst , 'T' , 1.) 179 ENDIF 176 180 #endif 177 181 … … 233 237 !!gm This should be put elsewhere.... (same remark for limsbc) 234 238 !!gm especially here it is assumed zstar coordinate, but it can be ztilde.... 239 #if defined key_qco 240 IF( .NOT.ln_linssh ) CALL dom_qco_zgr( Kbb, Kmm, Kaa ) ! interpolation scale factor, depth and water column 241 #else 235 242 IF( .NOT.ln_linssh ) THEN 236 243 ! 237 244 DO jk = 1,jpkm1 ! adjust initial vertical scale factors 238 e3t(:,:,jk,Kmm) = e3t_0(:,:,jk)*( 1._wp + ssh(:,:,Kmm)* tmask(:,:,1)/(ht_0(:,:) + 1.0 - tmask(:,:,1)) )239 e3t(:,:,jk,Kbb) = e3t_0(:,:,jk)*( 1._wp + ssh(:,:,Kbb)* tmask(:,:,1)/(ht_0(:,:) + 1.0 - tmask(:,:,1)) )240 END DO245 e3t(:,:,jk,Kmm) = e3t_0(:,:,jk)*( 1._wp + ssh(:,:,Kmm)*r1_ht_0(:,:)*tmask(:,:,jk) ) 246 e3t(:,:,jk,Kbb) = e3t_0(:,:,jk)*( 1._wp + ssh(:,:,Kbb)*r1_ht_0(:,:)*tmask(:,:,jk) ) 247 END DO 241 248 e3t(:,:,:,Krhs) = e3t(:,:,:,Kbb) 242 249 ! Reconstruction of all vertical scale factors at now and before time-steps … … 267 274 END DO 268 275 ENDIF 276 #endif 269 277 ENDIF 270 278 ENDIF … … 272 280 END SUBROUTINE cice_sbc_init 273 281 274 282 275 283 SUBROUTINE cice_sbc_in( kt, ksbc ) 276 284 !!--------------------------------------------------------------------- … … 281 289 INTEGER, INTENT(in ) :: ksbc ! surface forcing type 282 290 ! 283 INTEGER :: ji, jj, jl ! dummy loop indices 291 INTEGER :: ji, jj, jl ! dummy loop indices 284 292 REAL(wp), DIMENSION(jpi,jpj) :: ztmp, zpice 285 293 REAL(wp), DIMENSION(jpi,jpj,ncat) :: ztmpn … … 293 301 ztmp(:,:)=0.0 294 302 295 ! Aggregate ice concentration already set in cice_sbc_out (or cice_sbc_init on 303 ! Aggregate ice concentration already set in cice_sbc_out (or cice_sbc_init on 296 304 ! the first time-step) 297 305 298 ! forced and coupled case 306 ! forced and coupled case 299 307 300 308 IF( (ksbc == jp_flx).OR.(ksbc == jp_purecpl) ) THEN … … 356 364 ! Convert to GBM 357 365 IF(ksbc == jp_flx) THEN 358 ztmp(:,:) = (topmelt(:,:,jl)+botmelt(:,:,jl))*a_i(:,:,jl) 366 ztmp(:,:) = (topmelt(:,:,jl)+botmelt(:,:,jl))*a_i(:,:,jl) 359 367 ELSE 360 368 ztmp(:,:) = (topmelt(:,:,jl)+botmelt(:,:,jl)) … … 380 388 CALL nemo2cice(ztmp,Tair,'T', 1. ) ! Air temperature (K) 381 389 CALL nemo2cice(ztmp,potT,'T', 1. ) ! Potential temp (K) 382 ! Following line uses MAX(....) to avoid problems if tatm_ice has unset halo rows 383 ztmp(:,:) = 101000. / ( 287.04 * MAX(1.0,tatm_ice(:,:)) ) 390 ! Following line uses MAX(....) to avoid problems if tatm_ice has unset halo rows 391 ztmp(:,:) = 101000. / ( 287.04 * MAX(1.0,tatm_ice(:,:)) ) 384 392 ! Constant (101000.) atm pressure assumed 385 393 CALL nemo2cice(ztmp,rhoa,'T', 1. ) ! Air density (kg/m^3) … … 389 397 CALL nemo2cice(ztmp,zlvl,'T', 1. ) ! Atmos level height (m) 390 398 391 ! May want to check all values are physically realistic (as in CICE routine 399 ! May want to check all values are physically realistic (as in CICE routine 392 400 ! prepare_forcing)? 393 401 394 402 ! Divide shortwave into spectral bands (as in prepare_forcing) 395 403 ztmp(:,:)=qsr_ice(:,:,1)*frcvdr ! visible direct 396 CALL nemo2cice(ztmp,swvdr,'T', 1. ) 404 CALL nemo2cice(ztmp,swvdr,'T', 1. ) 397 405 ztmp(:,:)=qsr_ice(:,:,1)*frcvdf ! visible diffuse 398 CALL nemo2cice(ztmp,swvdf,'T', 1. ) 406 CALL nemo2cice(ztmp,swvdf,'T', 1. ) 399 407 ztmp(:,:)=qsr_ice(:,:,1)*frcidr ! near IR direct 400 408 CALL nemo2cice(ztmp,swidr,'T', 1. ) … … 406 414 ! Snowfall 407 415 ! Ensure fsnow is positive (as in CICE routine prepare_forcing) 408 IF( iom_use('snowpre') ) CALL iom_put('snowpre',MAX( (1.0-fr_i(:,:))*sprecip(:,:) ,0.0)) !!Joakim edit 409 ztmp(:,:)=MAX(fr_i(:,:)*sprecip(:,:),0.0) 410 CALL nemo2cice(ztmp,fsnow,'T', 1. ) 416 IF( iom_use('snowpre') ) CALL iom_put('snowpre',MAX( (1.0-fr_i(:,:))*sprecip(:,:) ,0.0)) !!Joakim edit 417 ztmp(:,:)=MAX(fr_i(:,:)*sprecip(:,:),0.0) 418 CALL nemo2cice(ztmp,fsnow,'T', 1. ) 411 419 412 420 ! Rainfall 413 421 IF( iom_use('precip') ) CALL iom_put('precip', (1.0-fr_i(:,:))*(tprecip(:,:)-sprecip(:,:)) ) !!Joakim edit 414 422 ztmp(:,:)=fr_i(:,:)*(tprecip(:,:)-sprecip(:,:)) 415 CALL nemo2cice(ztmp,frain,'T', 1. ) 423 CALL nemo2cice(ztmp,frain,'T', 1. ) 416 424 417 425 ! Freezing/melting potential … … 482 490 INTEGER, INTENT( in ) :: kt ! ocean time step 483 491 INTEGER, INTENT( in ) :: ksbc ! surface forcing type 484 492 485 493 INTEGER :: ji, jj, jl ! dummy loop indices 486 494 REAL(wp), DIMENSION(jpi,jpj) :: ztmp1, ztmp2 … … 490 498 IF(lwp) WRITE(numout,*)'cice_sbc_out' 491 499 ENDIF 492 493 ! x comp of ocean-ice stress 500 501 ! x comp of ocean-ice stress 494 502 CALL cice2nemo(strocnx,ztmp1,'F', -1. ) 495 503 ss_iou(:,:)=0.0 … … 500 508 CALL lbc_lnk( 'sbcice_cice', ss_iou , 'U', -1. ) 501 509 502 ! y comp of ocean-ice stress 510 ! y comp of ocean-ice stress 503 511 CALL cice2nemo(strocny,ztmp1,'F', -1. ) 504 512 ss_iov(:,:)=0.0 … … 513 521 ! Combine wind stress and ocean-ice stress 514 522 ! [Note that fr_iu hasn't yet been updated, so still from start of CICE timestep] 515 ! strocnx and strocny already weighted by ice fraction in CICE so not done here 523 ! strocnx and strocny already weighted by ice fraction in CICE so not done here 516 524 517 525 utau(:,:)=(1.0-fr_iu(:,:))*utau(:,:)-ss_iou(:,:) 518 vtau(:,:)=(1.0-fr_iv(:,:))*vtau(:,:)-ss_iov(:,:) 519 520 ! Also need ice/ocean stress on T points so that taum can be updated 521 ! This interpolation is already done in CICE so best to use those values 522 CALL cice2nemo(strocnxT,ztmp1,'T',-1.) 523 CALL cice2nemo(strocnyT,ztmp2,'T',-1.) 524 525 ! Update taum with modulus of ice-ocean stress 526 ! strocnxT and strocnyT are not weighted by ice fraction in CICE so must be done here 527 taum(:,:)=(1.0-fr_i(:,:))*taum(:,:)+fr_i(:,:)*SQRT(ztmp1*ztmp1 + ztmp2*ztmp2) 528 529 ! Freshwater fluxes 526 vtau(:,:)=(1.0-fr_iv(:,:))*vtau(:,:)-ss_iov(:,:) 527 528 ! Also need ice/ocean stress on T points so that taum can be updated 529 ! This interpolation is already done in CICE so best to use those values 530 CALL cice2nemo(strocnxT,ztmp1,'T',-1.) 531 CALL cice2nemo(strocnyT,ztmp2,'T',-1.) 532 533 ! Update taum with modulus of ice-ocean stress 534 ! strocnxT and strocnyT are not weighted by ice fraction in CICE so must be done here 535 taum(:,:)=(1.0-fr_i(:,:))*taum(:,:)+fr_i(:,:)*SQRT(ztmp1*ztmp1 + ztmp2*ztmp2) 536 537 ! Freshwater fluxes 530 538 531 539 IF(ksbc == jp_flx) THEN 532 540 ! Note that emp from the forcing files is evap*(1-aice)-(tprecip-aice*sprecip) 533 541 ! What we want here is evap*(1-aice)-tprecip*(1-aice) hence manipulation below 534 ! Not ideal since aice won't be the same as in the atmosphere. 542 ! Not ideal since aice won't be the same as in the atmosphere. 535 543 ! Better to use evap and tprecip? (but for now don't read in evap in this case) 536 544 emp(:,:) = emp(:,:)+fr_i(:,:)*(tprecip(:,:)-sprecip(:,:)) 537 545 ELSE IF(ksbc == jp_blk) THEN 538 emp(:,:) = (1.0-fr_i(:,:))*emp(:,:) 546 emp(:,:) = (1.0-fr_i(:,:))*emp(:,:) 539 547 ELSE IF(ksbc == jp_purecpl) THEN 540 ! emp_tot is set in sbc_cpl_ice_flx (called from cice_sbc_in above) 548 ! emp_tot is set in sbc_cpl_ice_flx (called from cice_sbc_in above) 541 549 ! This is currently as required with the coupling fields from the UM atmosphere 542 emp(:,:) = emp_tot(:,:)+tprecip(:,:)*fr_i(:,:) 550 emp(:,:) = emp_tot(:,:)+tprecip(:,:)*fr_i(:,:) 543 551 ENDIF 544 552 … … 560 568 emp(:,:)=emp(:,:)-ztmp1(:,:) 561 569 fmmflx(:,:) = ztmp1(:,:) !!Joakim edit 562 570 563 571 CALL lbc_lnk_multi( 'sbcice_cice', emp , 'T', 1., sfx , 'T', 1. ) 564 572 … … 634 642 !! *** ROUTINE cice_sbc_hadgam *** 635 643 !! ** Purpose: Prepare fields needed to pass to HadGAM3 atmosphere 636 !! 644 !! 637 645 !! 638 646 !!--------------------------------------------------------------------- … … 657 665 CALL cice2nemo(vvel,v_ice,'F', -1. ) 658 666 ! 659 ! Ice concentration (CO_1) = a_i calculated at end of cice_sbc_out 667 ! Ice concentration (CO_1) = a_i calculated at end of cice_sbc_out 660 668 ! 661 669 ! Snow and ice thicknesses (CO_2 and CO_3) … … 689 697 !!--------------------------------------------------------------------- 690 698 !! ** Method : READ monthly flux file in NetCDF files 691 !! 692 !! snowfall 693 !! rainfall 694 !! sublimation rate 699 !! 700 !! snowfall 701 !! rainfall 702 !! sublimation rate 695 703 !! topmelt (category) 696 704 !! botmelt (category) … … 709 717 TYPE(FLD_N) :: sn_snow, sn_rain, sn_sblm ! informations about the fields to be read 710 718 TYPE(FLD_N) :: sn_top1, sn_top2, sn_top3, sn_top4, sn_top5 711 TYPE(FLD_N) :: sn_bot1, sn_bot2, sn_bot3, sn_bot4, sn_bot5 719 TYPE(FLD_N) :: sn_bot1, sn_bot2, sn_bot3, sn_bot4, sn_bot5 712 720 !! 713 721 NAMELIST/namsbc_cice/ cn_dir, sn_snow, sn_rain, sn_sblm, & … … 727 735 ! ! file ! frequency ! variable ! time intep ! clim ! 'yearly' or ! weights ! rotation ! landmask 728 736 ! ! name ! (hours) ! name ! (T/F) ! (T/F) ! 'monthly' ! filename ! pairs ! file 729 sn_snow = FLD_N( 'snowfall_1m' , -1. , 'snowfall' , .true. , .true. , ' yearly' , '' , '' , '' ) 730 sn_rain = FLD_N( 'rainfall_1m' , -1. , 'rainfall' , .true. , .true. , ' yearly' , '' , '' , '' ) 737 sn_snow = FLD_N( 'snowfall_1m' , -1. , 'snowfall' , .true. , .true. , ' yearly' , '' , '' , '' ) 738 sn_rain = FLD_N( 'rainfall_1m' , -1. , 'rainfall' , .true. , .true. , ' yearly' , '' , '' , '' ) 731 739 sn_sblm = FLD_N( 'sublim_1m' , -1. , 'sublim' , .true. , .true. , ' yearly' , '' , '' , '' ) 732 740 sn_top1 = FLD_N( 'topmeltn1_1m' , -1. , 'topmeltn1' , .true. , .true. , ' yearly' , '' , '' , '' ) … … 754 762 slf_i(jp_bot2) = sn_bot2 ; slf_i(jp_bot3) = sn_bot3 ; slf_i(jp_bot4) = sn_bot4 755 763 slf_i(jp_bot5) = sn_bot5 756 764 757 765 ! set sf structure 758 766 ALLOCATE( sf(jpfld), STAT=ierror ) … … 792 800 ! control print (if less than 100 time-step asked) 793 801 IF( nitend-nit000 <= 100 .AND. lwp ) THEN 794 WRITE(numout,*) 802 WRITE(numout,*) 795 803 WRITE(numout,*) ' read forcing fluxes for CICE OK' 796 804 CALL FLUSH(numout) … … 802 810 !!--------------------------------------------------------------------- 803 811 !! *** ROUTINE nemo2cice *** 804 !! ** Purpose : Transfer field in NEMO array to field in CICE array. 812 !! ** Purpose : Transfer field in NEMO array to field in CICE array. 805 813 #if defined key_nemocice_decomp 806 !! 814 !! 807 815 !! NEMO and CICE PE sub domains are identical, hence 808 !! there is no need to gather or scatter data from 816 !! there is no need to gather or scatter data from 809 817 !! one PE configuration to another. 810 818 #else 811 !! Automatically gather/scatter between 819 !! Automatically gather/scatter between 812 820 !! different processors and blocks 813 821 !! ** Method : A. Ensure all haloes are filled in NEMO field (pn) 814 822 !! B. Gather pn into global array (png) 815 823 !! C. Map png into CICE global array (pcg) 816 !! D. Scatter pcg to CICE blocks (pc) + update haloes 824 !! D. Scatter pcg to CICE blocks (pc) + update haloes 817 825 #endif 818 826 !!--------------------------------------------------------------------- … … 858 866 IF( jpnij > 1) THEN 859 867 CALL mppsync 860 CALL mppgather (pn,0,png) 868 CALL mppgather (pn,0,png) 861 869 CALL mppsync 862 870 ELSE … … 869 877 ! (may be OK but not 100% sure) 870 878 871 IF(nproc==0) THEN 879 IF(nproc==0) THEN 872 880 ! pcg(:,:)=0.0 873 881 DO jn=1,jpnij … … 890 898 CASE ( 'T' ) 891 899 grid_loc=field_loc_center 892 CASE ( 'F' ) 900 CASE ( 'F' ) 893 901 grid_loc=field_loc_NEcorner 894 902 END SELECT … … 897 905 CASE ( -1 ) 898 906 field_type=field_type_vector 899 CASE ( 1 ) 907 CASE ( 1 ) 900 908 field_type=field_type_scalar 901 909 END SELECT … … 916 924 !! ** Purpose : Transfer field in CICE array to field in NEMO array. 917 925 #if defined key_nemocice_decomp 918 !! 926 !! 919 927 !! NEMO and CICE PE sub domains are identical, hence 920 !! there is no need to gather or scatter data from 928 !! there is no need to gather or scatter data from 921 929 !! one PE configuration to another. 922 #else 930 #else 923 931 !! Automatically deal with scatter/gather between 924 932 !! different processors and blocks … … 926 934 !! B. Map pcg into NEMO global array (png) 927 935 !! C. Scatter png into NEMO field (pn) for each processor 928 !! D. Ensure all haloes are filled in pn 936 !! D. Ensure all haloes are filled in pn 929 937 #endif 930 938 !!--------------------------------------------------------------------- … … 958 966 CASE ( 'T' ) 959 967 grid_loc=field_loc_center 960 CASE ( 'F' ) 968 CASE ( 'F' ) 961 969 grid_loc=field_loc_NEcorner 962 970 END SELECT … … 965 973 CASE ( -1 ) 966 974 field_type=field_type_vector 967 CASE ( 1 ) 975 CASE ( 1 ) 968 976 field_type=field_type_scalar 969 977 END SELECT … … 979 987 #else 980 988 981 ! A. Gather CICE blocks (pc) into global array (pcg) 989 ! A. Gather CICE blocks (pc) into global array (pcg) 982 990 983 991 CALL gather_global(pcg, pc, 0, distrb_info) … … 1005 1013 IF( jpnij > 1) THEN 1006 1014 CALL mppsync 1007 CALL mppscatter (png,0,pn) 1015 CALL mppscatter (png,0,pn) 1008 1016 CALL mppsync 1009 1017 ELSE -
NEMO/branches/2020/dev_r12527_Gurvan_ShallowWater/src/OCE/SBC/sbcrnf.F90
r12489 r13151 34 34 PUBLIC sbc_rnf_alloc ! called in sbcmod module 35 35 PUBLIC sbc_rnf_init ! called in sbcmod module 36 36 37 37 ! !!* namsbc_rnf namelist * 38 38 CHARACTER(len=100) :: cn_dir !: Root directory for location of rnf files … … 58 58 LOGICAL , PUBLIC :: l_rnfcpl = .false. !: runoffs recieved from oasis 59 59 INTEGER , PUBLIC :: nkrnf = 0 !: nb of levels over which Kz is increased at river mouths 60 60 61 61 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: rnfmsk !: river mouth mask (hori.) 62 62 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:) :: rnfmsk_z !: river mouth mask (vert.) 63 63 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: h_rnf !: depth of runoff in m 64 64 INTEGER, PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: nk_rnf !: depth of runoff in model levels 65 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: rnf_tsc_b, rnf_tsc !: before and now T & S runoff contents [K.m/s & PSU.m/s] 65 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: rnf_tsc_b, rnf_tsc !: before and now T & S runoff contents [K.m/s & PSU.m/s] 66 66 67 67 TYPE(FLD), ALLOCATABLE, DIMENSION(:) :: sf_rnf ! structure: river runoff (file information, fields read) 68 68 TYPE(FLD), ALLOCATABLE, DIMENSION(:) :: sf_i_rnf ! structure: iceberg flux (file information, fields read) 69 TYPE(FLD), ALLOCATABLE, DIMENSION(:) :: sf_s_rnf ! structure: river runoff salinity (file information, fields read) 70 TYPE(FLD), ALLOCATABLE, DIMENSION(:) :: sf_t_rnf ! structure: river runoff temperature (file information, fields read) 71 69 TYPE(FLD), ALLOCATABLE, DIMENSION(:) :: sf_s_rnf ! structure: river runoff salinity (file information, fields read) 70 TYPE(FLD), ALLOCATABLE, DIMENSION(:) :: sf_t_rnf ! structure: river runoff temperature (file information, fields read) 71 72 72 !! * Substitutions 73 73 # include "do_loop_substitute.h90" 74 # include "domzgr_substitute.h90" 74 75 !!---------------------------------------------------------------------- 75 76 !! NEMO/OCE 4.0 , NEMO Consortium (2018) … … 227 228 ELSE !== runoff put only at the surface ==! 228 229 h_rnf (:,:) = e3t (:,:,1,Kmm) ! update h_rnf to be depth of top box 229 phdivn(:,:,1) = phdivn(:,:,1) - ( rnf(:,:) +rnf_b(:,:) ) * zfact * r1_rho0 / e3t(:,:,1,Kmm)230 phdivn(:,:,1) = phdivn(:,:,1) - ( rnf(:,:)+rnf_b(:,:) ) * zfact * r1_rho0 / e3t(:,:,1,Kmm) 230 231 ENDIF 231 232 ! … … 249 250 INTEGER :: ios ! Local integer output status for namelist read 250 251 INTEGER :: nbrec ! temporary integer 251 REAL(wp) :: zacoef 252 REAL(wp), DIMENSION(jpi,jpj,2) :: zrnfcl 252 REAL(wp) :: zacoef 253 REAL(wp), DIMENSION(jpi,jpj,2) :: zrnfcl 253 254 !! 254 255 NAMELIST/namsbc_rnf/ cn_dir , ln_rnf_depth, ln_rnf_tem, ln_rnf_sal, ln_rnf_icb, & … … 261 262 IF( sbc_rnf_alloc() /= 0 ) CALL ctl_stop( 'STOP', 'sbc_rnf_alloc : unable to allocate arrays' ) 262 263 ! 263 IF( .NOT. ln_rnf ) THEN ! no specific treatment in vicinity of river mouths 264 IF( .NOT. ln_rnf ) THEN ! no specific treatment in vicinity of river mouths 264 265 ln_rnf_mouth = .FALSE. ! default definition needed for example by sbc_ssr or by tra_adv_muscl 265 266 nkrnf = 0 … … 297 298 ! ! ================== 298 299 ! 299 IF( .NOT. l_rnfcpl ) THEN 300 IF( .NOT. l_rnfcpl ) THEN 300 301 ALLOCATE( sf_rnf(1), STAT=ierror ) ! Create sf_rnf structure (runoff inflow) 301 302 IF(lwp) WRITE(numout,*) … … 352 353 IF(lwp) WRITE(numout,*) ' ==>>> runoffs depth read in a file' 353 354 rn_dep_file = TRIM( cn_dir )//TRIM( sn_dep_rnf%clname ) 354 IF( .NOT. sn_dep_rnf%ln_clim ) THEN ; WRITE(rn_dep_file, '(a,"_y",i4)' ) TRIM( rn_dep_file ), nyear ! add year 355 IF( sn_dep_rnf%cltype == 'monthly' ) WRITE(rn_dep_file, '(a,"m",i2)' ) TRIM( rn_dep_file ), nmonth ! add month 355 IF( .NOT. sn_dep_rnf%ln_clim ) THEN ; WRITE(rn_dep_file, '(a,"_y",i4)' ) TRIM( rn_dep_file ), nyear ! add year 356 IF( sn_dep_rnf%cltype == 'monthly' ) WRITE(rn_dep_file, '(a,"m",i2)' ) TRIM( rn_dep_file ), nmonth ! add month 356 357 ENDIF 357 358 CALL iom_open ( rn_dep_file, inum ) ! open file -
NEMO/branches/2020/dev_r12527_Gurvan_ShallowWater/src/OCE/SBC/sbcssm.F90
r12377 r13151 10 10 11 11 !!---------------------------------------------------------------------- 12 !! sbc_ssm : calculate sea surface mean currents, temperature, 12 !! sbc_ssm : calculate sea surface mean currents, temperature, 13 13 !! and salinity over nn_fsbc time-step 14 14 !!---------------------------------------------------------------------- … … 31 31 32 32 LOGICAL, SAVE :: l_ssm_mean = .FALSE. ! keep track of whether means have been read from restart file 33 33 34 # include "domzgr_substitute.h90" 34 35 !!---------------------------------------------------------------------- 35 36 !! NEMO/OCE 4.0 , NEMO Consortium (2018) … … 42 43 !!--------------------------------------------------------------------- 43 44 !! *** ROUTINE sbc_oce *** 44 !! 45 !! 45 46 !! ** Purpose : provide ocean surface variable to sea-surface boundary 46 !! condition computation 47 !! 48 !! ** Method : compute mean surface velocity (2 components at U and 47 !! condition computation 48 !! 49 !! ** Method : compute mean surface velocity (2 components at U and 49 50 !! V-points) [m/s], temperature [Celsius] and salinity [psu] over 50 51 !! the periode (kt - nn_fsbc) to kt … … 200 201 ! 201 202 ELSE 202 ! 203 ! 203 204 IF(lwp) WRITE(numout,*) 204 205 IF(lwp) WRITE(numout,*) 'sbc_ssm_init : sea surface mean fields' … … 222 223 ! 223 224 IF( zf_sbc /= REAL( nn_fsbc, wp ) ) THEN ! nn_fsbc has changed between 2 runs 224 IF(lwp) WRITE(numout,*) ' restart with a change in the frequency of mean from ', zf_sbc, ' to ', nn_fsbc 225 zcoef = REAL( nn_fsbc - 1, wp ) / zf_sbc 226 ssu_m(:,:) = zcoef * ssu_m(:,:) 225 IF(lwp) WRITE(numout,*) ' restart with a change in the frequency of mean from ', zf_sbc, ' to ', nn_fsbc 226 zcoef = REAL( nn_fsbc - 1, wp ) / zf_sbc 227 ssu_m(:,:) = zcoef * ssu_m(:,:) 227 228 ssv_m(:,:) = zcoef * ssv_m(:,:) 228 229 sst_m(:,:) = zcoef * sst_m(:,:) … … 252 253 ENDIF 253 254 ! 254 IF( .NOT. ln_traqsr ) fraqsr_1lev(:,:) = 1._wp ! default definition: qsr 100% in the fisrt level 255 IF( .NOT. ln_traqsr ) fraqsr_1lev(:,:) = 1._wp ! default definition: qsr 100% in the fisrt level 255 256 ! 256 257 IF( lwxios.AND.nn_fsbc > 1 ) THEN -
NEMO/branches/2020/dev_r12527_Gurvan_ShallowWater/src/OCE/SBC/sbcwave.F90
r12377 r13151 73 73 !! * Substitutions 74 74 # include "do_loop_substitute.h90" 75 # include "domzgr_substitute.h90" 75 76 !!---------------------------------------------------------------------- 76 77 !! NEMO/OCE 4.0 , NEMO Consortium (2018) … … 207 208 & - e2u(ji-1,jj) * e3u(ji-1,jj,jk,Kmm) * usd(ji-1,jj,jk) & 208 209 & + e1v(ji,jj ) * e3v(ji,jj ,jk,Kmm) * vsd(ji,jj ,jk) & 209 & - e1v(ji,jj-1) * e3v(ji,jj-1,jk,Kmm) * vsd(ji,jj-1,jk) ) * r1_e1e2t(ji,jj) 210 & - e1v(ji,jj-1) * e3v(ji,jj-1,jk,Kmm) * vsd(ji,jj-1,jk) ) & 211 & * r1_e1e2t(ji,jj) 210 212 END_3D 211 213 ! -
NEMO/branches/2020/dev_r12527_Gurvan_ShallowWater/src/OCE/STO/storng.F90
r12377 r13151 50 50 51 51 ! Parameters to generate real random variates 52 REAL(KIND=wp), PARAMETER :: huge64=9223372036854775808.0 ! +153 52 REAL(KIND=wp), PARAMETER :: zero=0.0, half=0.5, one=1.0, two=2.0 54 53 … … 275 274 REAL(KIND=wp) :: uran 276 275 277 uran = half * ( one + REAL(kiss(),wp) / huge64)276 uran = half * ( one + REAL(kiss(),wp) / HUGE(1._wp) ) 278 277 279 278 END SUBROUTINE kiss_uniform … … 298 297 rsq = two 299 298 DO WHILE ( (rsq.GE.one).OR. (rsq.EQ.zero) ) 300 u1 = REAL(kiss(),wp) / huge64301 u2 = REAL(kiss(),wp) / huge64299 u1 = REAL(kiss(),wp) / HUGE(1._wp) 300 u2 = REAL(kiss(),wp) / HUGE(1._wp) 302 301 rsq = u1*u1 + u2*u2 303 302 ENDDO -
NEMO/branches/2020/dev_r12527_Gurvan_ShallowWater/src/OCE/TRA/eosbn2.F90
r12489 r13151 180 180 !! * Substitutions 181 181 # include "do_loop_substitute.h90" 182 # include "domzgr_substitute.h90" 182 183 !!---------------------------------------------------------------------- 183 184 !! NEMO/OCE 4.0 , NEMO Consortium (2018) -
NEMO/branches/2020/dev_r12527_Gurvan_ShallowWater/src/OCE/TRA/traadv.F90
r12489 r13151 65 65 INTEGER, PARAMETER :: np_UBS = 4 ! 3rd order Upstream Biased Scheme 66 66 INTEGER, PARAMETER :: np_QCK = 5 ! QUICK scheme 67 67 68 # include "domzgr_substitute.h90" 68 69 !!---------------------------------------------------------------------- 69 70 !! NEMO/OCE 4.0 , NEMO Consortium (2018) … … 98 99 IF( ln_wave .AND. ln_sdw ) THEN 99 100 DO jk = 1, jpkm1 ! eulerian transport + Stokes Drift 100 zuu(:,:,jk) = e2u (:,:) * e3u(:,:,jk,Kmm) * ( uu(:,:,jk,Kmm) + usd(:,:,jk) ) 101 zvv(:,:,jk) = e1v (:,:) * e3v(:,:,jk,Kmm) * ( vv(:,:,jk,Kmm) + vsd(:,:,jk) ) 102 zww(:,:,jk) = e1e2t(:,:) * ( ww(:,:,jk) + wsd(:,:,jk) ) 101 zuu(:,:,jk) = & 102 & e2u (:,:) * e3u(:,:,jk,Kmm) * ( uu(:,:,jk,Kmm) + usd(:,:,jk) ) 103 zvv(:,:,jk) = & 104 & e1v (:,:) * e3v(:,:,jk,Kmm) * ( vv(:,:,jk,Kmm) + vsd(:,:,jk) ) 105 zww(:,:,jk) = & 106 & e1e2t(:,:) * ( ww(:,:,jk) + wsd(:,:,jk) ) 103 107 END DO 104 108 ELSE -
NEMO/branches/2020/dev_r12527_Gurvan_ShallowWater/src/OCE/TRA/traadv_cen.F90
r12377 r13151 13 13 USE dom_oce ! ocean space and time domain 14 14 USE eosbn2 ! equation of state 15 USE traadv_fct ! acces to routine interp_4th_cpt 15 USE traadv_fct ! acces to routine interp_4th_cpt 16 16 USE trd_oce ! trends: ocean variables 17 USE trdtra ! trends manager: tracers 17 USE trdtra ! trends manager: tracers 18 18 USE diaptr ! poleward transport diagnostics 19 19 USE diaar5 ! AR5 diagnostics … … 28 28 29 29 PUBLIC tra_adv_cen ! called by traadv.F90 30 30 31 31 REAL(wp) :: r1_6 = 1._wp / 6._wp ! =1/6 32 32 … … 37 37 !! * Substitutions 38 38 # include "do_loop_substitute.h90" 39 # include "domzgr_substitute.h90" 39 40 !!---------------------------------------------------------------------- 40 41 !! NEMO/OCE 4.0 , NEMO Consortium (2018) … … 45 46 46 47 SUBROUTINE tra_adv_cen( kt, kit000, cdtype, pU, pV, pW, & 47 & Kmm, pt, kjpt, Krhs, kn_cen_h, kn_cen_v ) 48 & Kmm, pt, kjpt, Krhs, kn_cen_h, kn_cen_v ) 48 49 !!---------------------------------------------------------------------- 49 50 !! *** ROUTINE tra_adv_cen *** 50 !! 51 !! 51 52 !! ** Purpose : Compute the now trend due to the advection of tracers 52 53 !! and add it to the general trend of passive tracer equations. 53 54 !! 54 55 !! ** Method : The advection is evaluated by a 2nd or 4th order scheme 55 !! using now fields (leap-frog scheme). 56 !! using now fields (leap-frog scheme). 56 57 !! kn_cen_h = 2 ==>> 2nd order centered scheme on the horizontal 57 58 !! = 4 ==>> 4th order - - - - … … 90 91 l_ptr = .FALSE. 91 92 IF( ( cdtype == 'TRA' .AND. l_trdtra ) .OR. ( cdtype == 'TRC' .AND. l_trdtrc ) ) l_trd = .TRUE. 92 IF( cdtype == 'TRA' .AND. ( iom_use( 'sophtadv' ) .OR. iom_use( 'sophtadv' ) ) ) l_ptr = .TRUE. 93 IF( cdtype == 'TRA' .AND. ( iom_use( 'sophtadv' ) .OR. iom_use( 'sophtadv' ) ) ) l_ptr = .TRUE. 93 94 IF( cdtype == 'TRA' .AND. ( iom_use("uadv_heattr") .OR. iom_use("vadv_heattr") .OR. & 94 95 & iom_use("uadv_salttr") .OR. iom_use("vadv_salttr") ) ) l_hst = .TRUE. 95 96 ! 96 ! 97 ! 97 98 zwz(:,:, 1 ) = 0._wp ! surface & bottom vertical flux set to zero for all tracers 98 99 zwz(:,:,jpk) = 0._wp … … 150 151 IF( ln_isfcav ) THEN ! ice-shelf cavities (top of the ocean) 151 152 DO_2D_11_11 152 zwz(ji,jj, mikt(ji,jj) ) = pW(ji,jj,mikt(ji,jj)) * pt(ji,jj,mikt(ji,jj),jn,Kmm) 153 zwz(ji,jj, mikt(ji,jj) ) = pW(ji,jj,mikt(ji,jj)) * pt(ji,jj,mikt(ji,jj),jn,Kmm) 153 154 END_2D 154 155 ELSE ! no ice-shelf cavities (only ocean surface) … … 156 157 ENDIF 157 158 ENDIF 158 ! 159 ! 159 160 DO_3D_00_00( 1, jpkm1 ) 160 161 pt(ji,jj,jk,jn,Krhs) = pt(ji,jj,jk,jn,Krhs) & 161 162 & - ( zwx(ji,jj,jk) - zwx(ji-1,jj ,jk ) & 162 163 & + zwy(ji,jj,jk) - zwy(ji ,jj-1,jk ) & 163 & + zwz(ji,jj,jk) - zwz(ji ,jj ,jk+1) ) * r1_e1e2t(ji,jj) / e3t(ji,jj,jk,Kmm) 164 & + zwz(ji,jj,jk) - zwz(ji ,jj ,jk+1) ) & 165 & * r1_e1e2t(ji,jj) / e3t(ji,jj,jk,Kmm) 164 166 END_3D 165 167 ! ! trend diagnostics … … 169 171 CALL trd_tra( kt, Kmm, Krhs, cdtype, jn, jptra_zad, zwz, pW, pt(:,:,:,jn,Kmm) ) 170 172 END IF 171 ! ! "Poleward" heat and salt transports 173 ! ! "Poleward" heat and salt transports 172 174 IF( l_ptr ) CALL dia_ptr_hst( jn, 'adv', zwy(:,:,:) ) 173 175 ! ! heat and salt transport … … 177 179 ! 178 180 END SUBROUTINE tra_adv_cen 179 181 180 182 !!====================================================================== 181 183 END MODULE traadv_cen -
NEMO/branches/2020/dev_r12527_Gurvan_ShallowWater/src/OCE/TRA/traadv_fct.F90
r12489 r13151 10 10 !! tra_adv_fct : update the tracer trend with a 3D advective trends using a 2nd or 4th order FCT scheme 11 11 !! with sub-time-stepping in the vertical direction 12 !! nonosc : compute monotonic tracer fluxes by a non-oscillatory algorithm 12 !! nonosc : compute monotonic tracer fluxes by a non-oscillatory algorithm 13 13 !! interp_4th_cpt : 4th order compact scheme for the vertical component of the advection 14 14 !!---------------------------------------------------------------------- … … 24 24 ! 25 25 USE in_out_manager ! I/O manager 26 USE iom ! 26 USE iom ! 27 27 USE lib_mpp ! MPP library 28 USE lbclnk ! ocean lateral boundary condition (or mpp link) 29 USE lib_fortran ! Fortran utilities (allows no signed zero when 'key_nosignedzero' defined) 28 USE lbclnk ! ocean lateral boundary condition (or mpp link) 29 USE lib_fortran ! Fortran utilities (allows no signed zero when 'key_nosignedzero' defined) 30 30 31 31 IMPLICIT NONE … … 46 46 !! * Substitutions 47 47 # include "do_loop_substitute.h90" 48 # include "domzgr_substitute.h90" 48 49 !!---------------------------------------------------------------------- 49 50 !! NEMO/OCE 4.0 , NEMO Consortium (2018) … … 57 58 !!---------------------------------------------------------------------- 58 59 !! *** ROUTINE tra_adv_fct *** 59 !! 60 !! 60 61 !! ** Purpose : Compute the now trend due to total advection of tracers 61 62 !! and add it to the general trend of tracer equations … … 63 64 !! ** Method : - 2nd or 4th FCT scheme on the horizontal direction 64 65 !! (choice through the value of kn_fct) 65 !! - on the vertical the 4th order is a compact scheme 66 !! - corrected flux (monotonic correction) 66 !! - on the vertical the 4th order is a compact scheme 67 !! - corrected flux (monotonic correction) 67 68 !! 68 69 !! ** Action : - update pt(:,:,:,:,Krhs) with the now advective tracer trends … … 81 82 REAL(wp), DIMENSION(jpi,jpj,jpk,kjpt,jpt), INTENT(inout) :: pt ! tracers and RHS of tracer equation 82 83 ! 83 INTEGER :: ji, jj, jk, jn ! dummy loop indices 84 INTEGER :: ji, jj, jk, jn ! dummy loop indices 84 85 REAL(wp) :: ztra ! local scalar 85 86 REAL(wp) :: zfp_ui, zfp_vj, zfp_wk, zC2t_u, zC4t_u ! - - … … 102 103 ll_zAimp = .FALSE. 103 104 IF( ( cdtype == 'TRA' .AND. l_trdtra ) .OR. ( cdtype =='TRC' .AND. l_trdtrc ) ) l_trd = .TRUE. 104 IF( cdtype == 'TRA' .AND. ( iom_use( 'sophtadv' ) .OR. iom_use( 'sophtadv' ) ) ) l_ptr = .TRUE. 105 IF( cdtype == 'TRA' .AND. ( iom_use( 'sophtadv' ) .OR. iom_use( 'sophtadv' ) ) ) l_ptr = .TRUE. 105 106 IF( cdtype == 'TRA' .AND. ( iom_use("uadv_heattr") .OR. iom_use("vadv_heattr") .OR. & 106 107 & iom_use("uadv_salttr") .OR. iom_use("vadv_salttr") ) ) l_hst = .TRUE. … … 111 112 ENDIF 112 113 ! 113 IF( l_ptr ) THEN 114 IF( l_ptr ) THEN 114 115 ALLOCATE( zptry(jpi,jpj,jpk) ) 115 116 zptry(:,:,:) = 0._wp 116 117 ENDIF 117 118 ! ! surface & bottom value : flux set to zero one for all 118 zwz(:,:, 1 ) = 0._wp 119 zwz(:,:, 1 ) = 0._wp 119 120 zwx(:,:,jpk) = 0._wp ; zwy(:,:,jpk) = 0._wp ; zwz(:,:,jpk) = 0._wp 120 121 ! 121 zwi(:,:,:) = 0._wp 122 zwi(:,:,:) = 0._wp 122 123 ! 123 124 ! If adaptive vertical advection, check if it is needed on this PE at this time … … 129 130 ALLOCATE(zwdia(jpi,jpj,jpk), zwinf(jpi,jpj,jpk),zwsup(jpi,jpj,jpk)) 130 131 DO_3D_00_00( 1, jpkm1 ) 131 zwdia(ji,jj,jk) = 1._wp + p2dt * ( MAX( wi(ji,jj,jk ) , 0._wp ) - MIN( wi(ji,jj,jk+1) , 0._wp ) ) / e3t(ji,jj,jk,Krhs) 132 zwdia(ji,jj,jk) = 1._wp + p2dt * ( MAX( wi(ji,jj,jk) , 0._wp ) - MIN( wi(ji,jj,jk+1) , 0._wp ) ) & 133 & / e3t(ji,jj,jk,Krhs) 132 134 zwinf(ji,jj,jk) = p2dt * MIN( wi(ji,jj,jk ) , 0._wp ) / e3t(ji,jj,jk,Krhs) 133 135 zwsup(ji,jj,jk) = -p2dt * MAX( wi(ji,jj,jk+1) , 0._wp ) / e3t(ji,jj,jk,Krhs) … … 138 140 ! 139 141 ! !== upstream advection with initial mass fluxes & intermediate update ==! 140 ! !* upstream tracer flux in the i and j direction 142 ! !* upstream tracer flux in the i and j direction 141 143 DO_3D_10_10( 1, jpkm1 ) 142 144 ! upstream scheme … … 157 159 IF( ln_isfcav ) THEN ! top of the ice-shelf cavities and at the ocean surface 158 160 DO_2D_11_11 159 zwz(ji,jj, mikt(ji,jj) ) = pW(ji,jj,mikt(ji,jj)) * pt(ji,jj,mikt(ji,jj),jn,Kbb) ! linear free surface 161 zwz(ji,jj, mikt(ji,jj) ) = pW(ji,jj,mikt(ji,jj)) * pt(ji,jj,mikt(ji,jj),jn,Kbb) ! linear free surface 160 162 END_2D 161 163 ELSE ! no cavities: only at the ocean surface … … 163 165 ENDIF 164 166 ENDIF 165 ! 167 ! 166 168 DO_3D_00_00( 1, jpkm1 ) 167 169 ! ! total intermediate advective trends … … 170 172 & + zwz(ji,jj,jk) - zwz(ji ,jj ,jk+1) ) * r1_e1e2t(ji,jj) 171 173 ! ! update and guess with monotonic sheme 172 pt(ji,jj,jk,jn,Krhs) = pt(ji,jj,jk,jn,Krhs) + ztra / e3t(ji,jj,jk,Kmm) * tmask(ji,jj,jk) 173 zwi(ji,jj,jk) = ( e3t(ji,jj,jk,Kbb) * pt(ji,jj,jk,jn,Kbb) + p2dt * ztra ) / e3t(ji,jj,jk,Krhs) * tmask(ji,jj,jk) 174 pt(ji,jj,jk,jn,Krhs) = pt(ji,jj,jk,jn,Krhs) + ztra & 175 & / e3t(ji,jj,jk,Kmm ) * tmask(ji,jj,jk) 176 zwi(ji,jj,jk) = ( e3t(ji,jj,jk,Kbb) * pt(ji,jj,jk,jn,Kbb) + p2dt * ztra ) & 177 & / e3t(ji,jj,jk,Krhs) * tmask(ji,jj,jk) 174 178 END_3D 175 179 176 180 IF ( ll_zAimp ) THEN 177 181 CALL tridia_solver( zwdia, zwsup, zwinf, zwi, zwi , 0 ) … … 186 190 DO_3D_00_00( 1, jpkm1 ) 187 191 pt(ji,jj,jk,jn,Krhs) = pt(ji,jj,jk,jn,Krhs) - ( ztw(ji,jj,jk) - ztw(ji ,jj ,jk+1) ) & 188 & 192 & * r1_e1e2t(ji,jj) / e3t(ji,jj,jk,Kmm) 189 193 END_3D 190 194 ! 191 195 END IF 192 ! 196 ! 193 197 IF( l_trd .OR. l_hst ) THEN ! trend diagnostics (contribution of upstream fluxes) 194 198 ztrdx(:,:,:) = zwx(:,:,:) ; ztrdy(:,:,:) = zwy(:,:,:) ; ztrdz(:,:,:) = zwz(:,:,:) 195 199 END IF 196 200 ! ! "Poleward" heat and salt transports (contribution of upstream fluxes) 197 IF( l_ptr ) zptry(:,:,:) = zwy(:,:,:) 201 IF( l_ptr ) zptry(:,:,:) = zwy(:,:,:) 198 202 ! 199 203 ! !== anti-diffusive flux : high order minus low order ==! … … 225 229 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 226 230 zC2t_v = pt(ji,jj,jk,jn,Kmm) + pt(ji ,jj+1,jk,jn,Kmm) 227 ! ! C4 minus upstream advective fluxes 231 ! ! C4 minus upstream advective fluxes 228 232 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) 229 233 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) … … 245 249 zC4t_u = zC2t_u + r1_6 * ( ztu(ji-1,jj ,jk) - ztu(ji+1,jj ,jk) ) 246 250 zC4t_v = zC2t_v + r1_6 * ( ztv(ji ,jj-1,jk) - ztv(ji ,jj+1,jk) ) 247 ! ! C4 minus upstream advective fluxes 251 ! ! C4 minus upstream advective fluxes 248 252 zwx(ji,jj,jk) = 0.5_wp * pU(ji,jj,jk) * zC4t_u - zwx(ji,jj,jk) 249 253 zwy(ji,jj,jk) = 0.5_wp * pV(ji,jj,jk) * zC4t_v - zwy(ji,jj,jk) … … 251 255 ! 252 256 END SELECT 253 ! 257 ! 254 258 SELECT CASE( kn_fct_v ) !* vertical anti-diffusive fluxes (w-masked interior values) 255 259 ! … … 270 274 zwz(:,:,1) = 0._wp ! only ocean surface as interior zwz values have been w-masked 271 275 ENDIF 272 ! 276 ! 273 277 IF ( ll_zAimp ) THEN 274 278 DO_3D_00_00( 1, jpkm1 ) … … 277 281 & + zwy(ji,jj,jk) - zwy(ji ,jj-1,jk ) & 278 282 & + zwz(ji,jj,jk) - zwz(ji ,jj ,jk+1) ) * r1_e1e2t(ji,jj) 279 ztw(ji,jj,jk) = zwi(ji,jj,jk) + p2dt * ztra / e3t(ji,jj,jk,Krhs) *tmask(ji,jj,jk)283 ztw(ji,jj,jk) = zwi(ji,jj,jk) + p2dt * ztra / e3t(ji,jj,jk,Krhs)*tmask(ji,jj,jk) 280 284 END_3D 281 285 ! … … 316 320 DO_3D_00_00( 1, jpkm1 ) 317 321 pt(ji,jj,jk,jn,Krhs) = pt(ji,jj,jk,jn,Krhs) - ( ztw(ji,jj,jk) - ztw(ji ,jj ,jk+1) ) & 318 & 319 END_3D 320 END IF 322 & * r1_e1e2t(ji,jj) / e3t(ji,jj,jk,Kmm) 323 END_3D 324 END IF 321 325 ! 322 326 IF( l_trd .OR. l_hst ) THEN ! trend diagnostics // heat/salt transport 323 ztrdx(:,:,:) = ztrdx(:,:,:) + zwx(:,:,:) ! <<< add anti-diffusive fluxes 327 ztrdx(:,:,:) = ztrdx(:,:,:) + zwx(:,:,:) ! <<< add anti-diffusive fluxes 324 328 ztrdy(:,:,:) = ztrdy(:,:,:) + zwy(:,:,:) ! to upstream fluxes 325 329 ztrdz(:,:,:) = ztrdz(:,:,:) + zwz(:,:,:) ! … … 344 348 DEALLOCATE( zwdia, zwinf, zwsup ) 345 349 ENDIF 346 IF( l_trd .OR. l_hst ) THEN 350 IF( l_trd .OR. l_hst ) THEN 347 351 DEALLOCATE( ztrdx, ztrdy, ztrdz ) 348 352 ENDIF 349 IF( l_ptr ) THEN 353 IF( l_ptr ) THEN 350 354 DEALLOCATE( zptry ) 351 355 ENDIF … … 357 361 !!--------------------------------------------------------------------- 358 362 !! *** ROUTINE nonosc *** 359 !! 360 !! ** Purpose : compute monotonic tracer fluxes from the upstream 361 !! scheme and the before field by a nonoscillatory algorithm 363 !! 364 !! ** Purpose : compute monotonic tracer fluxes from the upstream 365 !! scheme and the before field by a nonoscillatory algorithm 362 366 !! 363 367 !! ** Method : ... ??? … … 367 371 !! in-space based differencing for fluid 368 372 !!---------------------------------------------------------------------- 369 INTEGER , INTENT(in ) :: Kmm ! time level index 373 INTEGER , INTENT(in ) :: Kmm ! time level index 370 374 REAL(wp) , INTENT(in ) :: p2dt ! tracer time-step 371 375 REAL(wp), DIMENSION (jpi,jpj,jpk), INTENT(in ) :: pbef, paft ! before & after field … … 453 457 !!---------------------------------------------------------------------- 454 458 !! *** ROUTINE interp_4th_cpt_org *** 455 !! 459 !! 456 460 !! ** Purpose : Compute the interpolation of tracer at w-point 457 461 !! … … 464 468 REAL(wp),DIMENSION(jpi,jpj,jpk) :: zwd, zwi, zws, zwrm, zwt 465 469 !!---------------------------------------------------------------------- 466 470 467 471 DO_3D_11_11( 3, jpkm1 ) 468 472 zwd (ji,jj,jk) = 4._wp … … 475 479 zwi (ji,jj,jk) = 0._wp 476 480 zws (ji,jj,jk) = 0._wp 477 zwrm(ji,jj,jk) = 0.5 * ( pt_in(ji,jj,jk-1) + pt_in(ji,jj,jk) ) 481 zwrm(ji,jj,jk) = 0.5 * ( pt_in(ji,jj,jk-1) + pt_in(ji,jj,jk) ) 478 482 ENDIF 479 483 END_3D … … 499 503 END_2D 500 504 DO_3D_11_11( 3, jpkm1 ) 501 pt_out(ji,jj,jk) = zwrm(ji,jj,jk) - zwi(ji,jj,jk) / zwt(ji,jj,jk-1) *pt_out(ji,jj,jk-1) 505 pt_out(ji,jj,jk) = zwrm(ji,jj,jk) - zwi(ji,jj,jk) / zwt(ji,jj,jk-1) *pt_out(ji,jj,jk-1) 502 506 END_3D 503 507 … … 508 512 pt_out(ji,jj,jk) = ( pt_out(ji,jj,jk) - zws(ji,jj,jk) * pt_out(ji,jj,jk+1) ) / zwt(ji,jj,jk) 509 513 END_3D 510 ! 514 ! 511 515 END SUBROUTINE interp_4th_cpt_org 512 516 513 517 514 518 SUBROUTINE interp_4th_cpt( pt_in, pt_out ) 515 519 !!---------------------------------------------------------------------- 516 520 !! *** ROUTINE interp_4th_cpt *** 517 !! 521 !! 518 522 !! ** Purpose : Compute the interpolation of tracer at w-point 519 523 !! … … 543 547 ! CASE( np_CEN2 ) ! 2nd order centered at top & bottom 544 548 ! END SELECT 545 !!gm 549 !!gm 546 550 ! 547 551 IF ( ln_isfcav ) THEN ! set level two values which may not be set in ISF case … … 561 565 zwi (ji,jj,ikb) = 0._wp 562 566 zws (ji,jj,ikb) = 0._wp 563 zwrm(ji,jj,ikb) = 0.5_wp * ( pt_in(ji,jj,ikb-1) + pt_in(ji,jj,ikb) ) 567 zwrm(ji,jj,ikb) = 0.5_wp * ( pt_in(ji,jj,ikb-1) + pt_in(ji,jj,ikb) ) 564 568 END_2D 565 569 ! … … 577 581 END_2D 578 582 DO_3D_00_00( 3, jpkm1 ) 579 pt_out(ji,jj,jk) = zwrm(ji,jj,jk) - zwi(ji,jj,jk) / zwt(ji,jj,jk-1) *pt_out(ji,jj,jk-1) 583 pt_out(ji,jj,jk) = zwrm(ji,jj,jk) - zwi(ji,jj,jk) / zwt(ji,jj,jk-1) *pt_out(ji,jj,jk-1) 580 584 END_3D 581 585 … … 586 590 pt_out(ji,jj,jk) = ( pt_out(ji,jj,jk) - zws(ji,jj,jk) * pt_out(ji,jj,jk+1) ) / zwt(ji,jj,jk) 587 591 END_3D 588 ! 592 ! 589 593 END SUBROUTINE interp_4th_cpt 590 594 … … 593 597 !!---------------------------------------------------------------------- 594 598 !! *** ROUTINE tridia_solver *** 595 !! 599 !! 596 600 !! ** Purpose : solve a symmetric 3diagonal system 597 601 !! 598 602 !! ** Method : solve M.t_out = RHS(t) where M is a tri diagonal matrix ( jpk*jpk ) 599 !! 603 !! 600 604 !! ( D_1 U_1 0 0 0 )( t_1 ) ( RHS_1 ) 601 605 !! ( L_2 D_2 U_2 0 0 )( t_2 ) ( RHS_2 ) … … 603 607 !! ( ... )( ... ) ( ... ) 604 608 !! ( 0 0 0 L_k D_k )( t_k ) ( RHS_k ) 605 !! 609 !! 606 610 !! M is decomposed in the product of an upper and lower triangular matrix. 607 !! The tri-diagonals matrix is given as input 3D arrays: pD, pU, pL 611 !! The tri-diagonals matrix is given as input 3D arrays: pD, pU, pL 608 612 !! (i.e. the Diagonal, the Upper diagonal, and the Lower diagonal). 609 613 !! The solution is pta. … … 613 617 REAL(wp),DIMENSION(:,:,:), INTENT(in ) :: pRHS ! Right-Hand-Side 614 618 REAL(wp),DIMENSION(:,:,:), INTENT( out) :: pt_out !!gm field at level=F(klev) 615 INTEGER , INTENT(in ) :: klev ! =1 pt_out at w-level 619 INTEGER , INTENT(in ) :: klev ! =1 pt_out at w-level 616 620 ! ! =0 pt at t-level 617 621 INTEGER :: ji, jj, jk ! dummy loop integers … … 633 637 END_2D 634 638 DO_3D_00_00( kstart+1, jpkm1 ) 635 pt_out(ji,jj,jk) = pRHS(ji,jj,jk) - pL(ji,jj,jk) / zwt(ji,jj,jk-1) *pt_out(ji,jj,jk-1) 639 pt_out(ji,jj,jk) = pRHS(ji,jj,jk) - pL(ji,jj,jk) / zwt(ji,jj,jk-1) *pt_out(ji,jj,jk-1) 636 640 END_3D 637 641 -
NEMO/branches/2020/dev_r12527_Gurvan_ShallowWater/src/OCE/TRA/traadv_mus.F90
r12377 r13151 29 29 USE in_out_manager ! I/O manager 30 30 USE lib_mpp ! distribued memory computing 31 USE lbclnk ! ocean lateral boundary condition (or mpp link) 32 USE lib_fortran ! Fortran utilities (allows no signed zero when 'key_nosignedzero' defined) 31 USE lbclnk ! ocean lateral boundary condition (or mpp link) 32 USE lib_fortran ! Fortran utilities (allows no signed zero when 'key_nosignedzero' defined) 33 33 34 34 IMPLICIT NONE … … 36 36 37 37 PUBLIC tra_adv_mus ! routine called by traadv.F90 38 38 39 39 REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:) :: upsmsk !: mixed upstream/centered scheme near some straits 40 40 ! ! and in closed seas (orca 2 and 1 configurations) 41 41 REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: xind !: mixed upstream/centered index 42 42 43 43 LOGICAL :: l_trd ! flag to compute trends 44 44 LOGICAL :: l_ptr ! flag to compute poleward transport … … 47 47 !! * Substitutions 48 48 # include "do_loop_substitute.h90" 49 # include "domzgr_substitute.h90" 49 50 !!---------------------------------------------------------------------- 50 51 !! NEMO/OCE 4.0 , NEMO Consortium (2018) 51 !! $Id$ 52 !! $Id$ 52 53 !! Software governed by the CeCILL license (see ./LICENSE) 53 54 !!---------------------------------------------------------------------- … … 64 65 !! 65 66 !! ** Method : MUSCL scheme plus centered scheme at ocean boundaries 66 !! ld_msc_ups=T : 67 !! ld_msc_ups=T : 67 68 !! 68 69 !! ** Action : - update pt(:,:,:,:,Krhs) with the now advective tracer trends … … 88 89 REAL(wp) :: zv, z0v, zzwy, z0w ! - - 89 90 REAL(wp), DIMENSION(jpi,jpj,jpk) :: zwx, zslpx ! 3D workspace 90 REAL(wp), DIMENSION(jpi,jpj,jpk) :: zwy, zslpy ! - - 91 REAL(wp), DIMENSION(jpi,jpj,jpk) :: zwy, zslpy ! - - 91 92 !!---------------------------------------------------------------------- 92 93 ! … … 112 113 & upsmsk(:,:) ) * tmask(:,:,jk) ! =>0 in some user defined area 113 114 END DO 114 ENDIF 115 ! 116 ENDIF 117 ! 115 ENDIF 116 ! 117 ENDIF 118 ! 118 119 l_trd = .FALSE. 119 120 l_hst = .FALSE. 120 121 l_ptr = .FALSE. 121 122 IF( ( cdtype == 'TRA' .AND. l_trdtra ) .OR. ( cdtype == 'TRC' .AND. l_trdtrc ) ) l_trd = .TRUE. 122 IF( cdtype == 'TRA' .AND. ( iom_use( 'sophtadv' ) .OR. iom_use( 'sophtadv' ) ) ) l_ptr = .TRUE. 123 IF( cdtype == 'TRA' .AND. ( iom_use( 'sophtadv' ) .OR. iom_use( 'sophtadv' ) ) ) l_ptr = .TRUE. 123 124 IF( cdtype == 'TRA' .AND. ( iom_use("uadv_heattr") .OR. iom_use("vadv_heattr") .OR. & 124 125 & iom_use("uadv_salttr") .OR. iom_use("vadv_salttr") ) ) l_hst = .TRUE. … … 130 131 ! !-- first guess of the slopes 131 132 zwx(:,:,jpk) = 0._wp ! bottom values 132 zwy(:,:,jpk) = 0._wp 133 zwy(:,:,jpk) = 0._wp 133 134 DO_3D_10_10( 1, jpkm1 ) 134 135 zwx(ji,jj,jk) = umask(ji,jj,jk) * ( pt(ji+1,jj,jk,jn,Kbb) - pt(ji,jj,jk,jn,Kbb) ) … … 176 177 DO_3D_00_00( 1, jpkm1 ) 177 178 pt(ji,jj,jk,jn,Krhs) = pt(ji,jj,jk,jn,Krhs) - ( zwx(ji,jj,jk) - zwx(ji-1,jj ,jk ) & 178 & +zwy(ji,jj,jk) - zwy(ji ,jj-1,jk ) ) &179 & 179 & + zwy(ji,jj,jk) - zwy(ji ,jj-1,jk ) ) & 180 & * r1_e1e2t(ji,jj) / e3t(ji,jj,jk,Kmm) 180 181 END_3D 181 182 ! ! trend diagnostics … … 184 185 CALL trd_tra( kt, Kmm, Krhs, cdtype, jn, jptra_yad, zwy, pV, pt(:,:,:,jn,Kbb) ) 185 186 END IF 186 ! ! "Poleward" heat and salt transports 187 ! ! "Poleward" heat and salt transports 187 188 IF( l_ptr ) CALL dia_ptr_hst( jn, 'adv', zwy(:,:,:) ) 188 189 ! ! heat transport … … 227 228 ! 228 229 DO_3D_00_00( 1, jpkm1 ) 229 pt(ji,jj,jk,jn,Krhs) = pt(ji,jj,jk,jn,Krhs) - ( zwx(ji,jj,jk) - zwx(ji,jj,jk+1) ) * r1_e1e2t(ji,jj) / e3t(ji,jj,jk,Kmm) 230 pt(ji,jj,jk,jn,Krhs) = pt(ji,jj,jk,jn,Krhs) - ( zwx(ji,jj,jk) - zwx(ji,jj,jk+1) ) & 231 & * r1_e1e2t(ji,jj) / e3t(ji,jj,jk,Kmm) 230 232 END_3D 231 233 ! ! send trends for diagnostic -
NEMO/branches/2020/dev_r12527_Gurvan_ShallowWater/src/OCE/TRA/traadv_qck.F90
r12377 r13151 19 19 USE trc_oce ! share passive tracers/Ocean variables 20 20 USE trd_oce ! trends: ocean variables 21 USE trdtra ! trends manager: tracers 21 USE trdtra ! trends manager: tracers 22 22 USE diaptr ! poleward transport diagnostics 23 23 USE iom … … 26 26 USE lib_mpp ! distribued memory computing 27 27 USE lbclnk ! ocean lateral boundary condition (or mpp link) 28 USE lib_fortran ! Fortran utilities (allows no signed zero when 'key_nosignedzero' defined) 28 USE lib_fortran ! Fortran utilities (allows no signed zero when 'key_nosignedzero' defined) 29 29 30 30 IMPLICIT NONE … … 41 41 !! * Substitutions 42 42 # include "do_loop_substitute.h90" 43 # include "domzgr_substitute.h90" 43 44 !!---------------------------------------------------------------------- 44 45 !! NEMO/OCE 4.0 , NEMO Consortium (2018) … … 104 105 l_ptr = .FALSE. 105 106 IF( ( cdtype == 'TRA' .AND. l_trdtra ) .OR. ( cdtype == 'TRC' .AND. l_trdtrc ) ) l_trd = .TRUE. 106 IF( cdtype == 'TRA' .AND. ( iom_use( 'sophtadv' ) .OR. iom_use( 'sophtadv' ) ) ) l_ptr = .TRUE. 107 IF( cdtype == 'TRA' .AND. ( iom_use( 'sophtadv' ) .OR. iom_use( 'sophtadv' ) ) ) l_ptr = .TRUE. 107 108 ! 108 109 ! 109 110 ! ! horizontal fluxes are computed with the QUICKEST + ULTIMATE scheme 110 CALL tra_adv_qck_i( kt, cdtype, p2dt, pU, Kbb, Kmm, pt, kjpt, Krhs ) 111 CALL tra_adv_qck_j( kt, cdtype, p2dt, pV, Kbb, Kmm, pt, kjpt, Krhs ) 111 CALL tra_adv_qck_i( kt, cdtype, p2dt, pU, Kbb, Kmm, pt, kjpt, Krhs ) 112 CALL tra_adv_qck_j( kt, cdtype, p2dt, pV, Kbb, Kmm, pt, kjpt, Krhs ) 112 113 113 114 ! ! vertical fluxes are computed with the 2nd order centered scheme … … 137 138 DO jn = 1, kjpt ! tracer loop 138 139 ! ! =========== 139 zfu(:,:,:) = 0._wp ; zfc(:,:,:) = 0._wp 140 zfd(:,:,:) = 0._wp ; zwx(:,:,:) = 0._wp 140 zfu(:,:,:) = 0._wp ; zfc(:,:,:) = 0._wp 141 zfd(:,:,:) = 0._wp ; zwx(:,:,:) = 0._wp 141 142 ! 142 143 !!gm why not using a SHIFT instruction... … … 145 146 zfd(ji,jj,jk) = pt(ji+1,jj,jk,jn,Kbb) ! Downstream in the x-direction for the tracer 146 147 END_3D 147 CALL lbc_lnk_multi( 'traadv_qck', zfc(:,:,:), 'T', 1. , zfd(:,:,:), 'T', 1. ) ! Lateral boundary conditions 148 148 CALL lbc_lnk_multi( 'traadv_qck', zfc(:,:,:), 'T', 1. , zfd(:,:,:), 'T', 1. ) ! Lateral boundary conditions 149 149 150 ! 150 151 ! Horizontal advective fluxes 151 152 ! --------------------------- 152 153 DO_3D_00_00( 1, jpkm1 ) 153 zdir = 0.5 + SIGN( 0.5, pU(ji,jj,jk) ) ! if pU > 0 : zdir = 1 otherwise zdir = 0 154 zfu(ji,jj,jk) = zdir * zfc(ji,jj,jk ) + ( 1. - zdir ) * zfd(ji+1,jj,jk) ! FU in the x-direction for T 155 END_3D 156 ! 157 DO_3D_00_00( 1, jpkm1 ) 158 zdir = 0.5 + SIGN( 0.5, pU(ji,jj,jk) ) ! if pU > 0 : zdir = 1 otherwise zdir = 0 159 zdx = ( zdir * e1t(ji,jj) + ( 1. - zdir ) * e1t(ji+1,jj) ) * e2u(ji,jj) * e3u(ji,jj,jk,Kmm) 154 zdir = 0.5 + SIGN( 0.5, pU(ji,jj,jk) ) ! if pU > 0 : zdir = 1 otherwise zdir = 0 155 zfu(ji,jj,jk) = zdir * zfc(ji,jj,jk ) + ( 1. - zdir ) * zfd(ji+1,jj,jk) ! FU in the x-direction for T 156 END_3D 157 ! 158 DO_3D_00_00( 1, jpkm1 ) 159 zdir = 0.5 + SIGN( 0.5, pU(ji,jj,jk) ) ! if pU > 0 : zdir = 1 otherwise zdir = 0 160 zdx = ( zdir * e1t(ji,jj) + ( 1. - zdir ) * e1t(ji+1,jj) ) & 161 & * e2u(ji,jj) * e3u(ji,jj,jk,Kmm) 160 162 zwx(ji,jj,jk) = ABS( pU(ji,jj,jk) ) * p2dt / zdx ! (0<zc_cfl<1 : Courant number on x-direction) 161 163 zfc(ji,jj,jk) = zdir * pt(ji ,jj,jk,jn,Kbb) + ( 1. - zdir ) * pt(ji+1,jj,jk,jn,Kbb) ! FC in the x-direction for T 162 164 zfd(ji,jj,jk) = zdir * pt(ji+1,jj,jk,jn,Kbb) + ( 1. - zdir ) * pt(ji ,jj,jk,jn,Kbb) ! FD in the x-direction for T 163 165 END_3D 164 !--- Lateral boundary conditions 166 !--- Lateral boundary conditions 165 167 CALL lbc_lnk_multi( 'traadv_qck', zfu(:,:,:), 'T', 1. , zfd(:,:,:), 'T', 1., zfc(:,:,:), 'T', 1., zwx(:,:,:), 'T', 1. ) 166 168 … … 172 174 zfu(ji,jj,jk) = tmask(ji-1,jj,jk) + tmask(ji,jj,jk) + tmask(ji+1,jj,jk) - 2. 173 175 END_3D 174 CALL lbc_lnk( 'traadv_qck', zfu(:,:,:), 'T', 1. ) ! Lateral boundary conditions 176 CALL lbc_lnk( 'traadv_qck', zfu(:,:,:), 'T', 1. ) ! Lateral boundary conditions 175 177 176 178 ! 177 179 ! Tracer flux on the x-direction 178 DO jk = 1, jpkm1 180 DO jk = 1, jpkm1 179 181 ! 180 182 DO_2D_00_00 181 zdir = 0.5 + SIGN( 0.5, pU(ji,jj,jk) ) ! if pU > 0 : zdir = 1 otherwise zdir = 0 183 zdir = 0.5 + SIGN( 0.5, pU(ji,jj,jk) ) ! if pU > 0 : zdir = 1 otherwise zdir = 0 182 184 !--- If the second ustream point is a land point 183 185 !--- the flux is computed by the 1st order UPWIND scheme … … 226 228 DO jn = 1, kjpt ! tracer loop 227 229 ! ! =========== 228 zfu(:,:,:) = 0.0 ; zfc(:,:,:) = 0.0 229 zfd(:,:,:) = 0.0 ; zwy(:,:,:) = 0.0 230 ! 231 DO jk = 1, jpkm1 232 ! 230 zfu(:,:,:) = 0.0 ; zfc(:,:,:) = 0.0 231 zfd(:,:,:) = 0.0 ; zwy(:,:,:) = 0.0 232 ! 233 DO jk = 1, jpkm1 234 ! 233 235 !--- Computation of the ustream and downstream value of the tracer and the mask 234 236 DO_2D_00_00 … … 239 241 END_2D 240 242 END DO 241 CALL lbc_lnk_multi( 'traadv_qck', zfc(:,:,:), 'T', 1. , zfd(:,:,:), 'T', 1. ) ! Lateral boundary conditions 242 243 243 CALL lbc_lnk_multi( 'traadv_qck', zfc(:,:,:), 'T', 1. , zfd(:,:,:), 'T', 1. ) ! Lateral boundary conditions 244 245 244 246 ! 245 247 ! Horizontal advective fluxes … … 247 249 ! 248 250 DO_3D_00_00( 1, jpkm1 ) 249 zdir = 0.5 + SIGN( 0.5, pV(ji,jj,jk) ) ! if pU > 0 : zdir = 1 otherwise zdir = 0 250 zfu(ji,jj,jk) = zdir * zfc(ji,jj,jk ) + ( 1. - zdir ) * zfd(ji,jj+1,jk) ! FU in the x-direction for T 251 END_3D 252 ! 253 DO_3D_00_00( 1, jpkm1 ) 254 zdir = 0.5 + SIGN( 0.5, pV(ji,jj,jk) ) ! if pU > 0 : zdir = 1 otherwise zdir = 0 255 zdx = ( zdir * e2t(ji,jj) + ( 1. - zdir ) * e2t(ji,jj+1) ) * e1v(ji,jj) * e3v(ji,jj,jk,Kmm) 251 zdir = 0.5 + SIGN( 0.5, pV(ji,jj,jk) ) ! if pU > 0 : zdir = 1 otherwise zdir = 0 252 zfu(ji,jj,jk) = zdir * zfc(ji,jj,jk ) + ( 1. - zdir ) * zfd(ji,jj+1,jk) ! FU in the x-direction for T 253 END_3D 254 ! 255 DO_3D_00_00( 1, jpkm1 ) 256 zdir = 0.5 + SIGN( 0.5, pV(ji,jj,jk) ) ! if pU > 0 : zdir = 1 otherwise zdir = 0 257 zdx = ( zdir * e2t(ji,jj) + ( 1. - zdir ) * e2t(ji,jj+1) ) & 258 & * e1v(ji,jj) * e3v(ji,jj,jk,Kmm) 256 259 zwy(ji,jj,jk) = ABS( pV(ji,jj,jk) ) * p2dt / zdx ! (0<zc_cfl<1 : Courant number on x-direction) 257 260 zfc(ji,jj,jk) = zdir * pt(ji,jj ,jk,jn,Kbb) + ( 1. - zdir ) * pt(ji,jj+1,jk,jn,Kbb) ! FC in the x-direction for T … … 259 262 END_3D 260 263 261 !--- Lateral boundary conditions 264 !--- Lateral boundary conditions 262 265 CALL lbc_lnk_multi( 'traadv_qck', zfu(:,:,:), 'T', 1. , zfd(:,:,:), 'T', 1., zfc(:,:,:), 'T', 1., zwy(:,:,:), 'T', 1. ) 263 266 … … 269 272 zfu(ji,jj,jk) = tmask(ji,jj-1,jk) + tmask(ji,jj,jk) + tmask(ji,jj+1,jk) - 2. 270 273 END_3D 271 CALL lbc_lnk( 'traadv_qck', zfu(:,:,:), 'T', 1. ) !--- Lateral boundary conditions 274 CALL lbc_lnk( 'traadv_qck', zfu(:,:,:), 'T', 1. ) !--- Lateral boundary conditions 272 275 ! 273 276 ! Tracer flux on the x-direction 274 DO jk = 1, jpkm1 277 DO jk = 1, jpkm1 275 278 ! 276 279 DO_2D_00_00 277 zdir = 0.5 + SIGN( 0.5, pV(ji,jj,jk) ) ! if pU > 0 : zdir = 1 otherwise zdir = 0 280 zdir = 0.5 + SIGN( 0.5, pV(ji,jj,jk) ) ! if pU > 0 : zdir = 1 otherwise zdir = 0 278 281 !--- If the second ustream point is a land point 279 282 !--- the flux is computed by the 1st order UPWIND scheme … … 312 315 CHARACTER(len=3) , INTENT(in ) :: cdtype ! =TRA or TRC (tracer indicator) 313 316 INTEGER , INTENT(in ) :: kjpt ! number of tracers 314 REAL(wp), DIMENSION(jpi,jpj,jpk ), INTENT(in ) :: pW ! vertical velocity 317 REAL(wp), DIMENSION(jpi,jpj,jpk ), INTENT(in ) :: pW ! vertical velocity 315 318 REAL(wp), DIMENSION(jpi,jpj,jpk,kjpt,jpt), INTENT(inout) :: pt ! active tracers and RHS of tracer equation 316 319 ! … … 332 335 IF( ln_isfcav ) THEN ! ice-shelf cavities (top of the ocean) 333 336 DO_2D_11_11 334 zwz(ji,jj, mikt(ji,jj) ) = pW(ji,jj,mikt(ji,jj)) * pt(ji,jj,mikt(ji,jj),jn,Kmm) ! linear free surface 337 zwz(ji,jj, mikt(ji,jj) ) = pW(ji,jj,mikt(ji,jj)) * pt(ji,jj,mikt(ji,jj),jn,Kmm) ! linear free surface 335 338 END_2D 336 339 ELSE ! no ocean cavities (only ocean surface) … … 356 359 !! ** Purpose : Computation of advective flux with Quickest scheme 357 360 !! 358 !! ** Method : 361 !! ** Method : 359 362 !!---------------------------------------------------------------------- 360 363 REAL(wp), DIMENSION(jpi,jpj,jpk), INTENT(in ) :: pfu ! second upwind point … … 363 366 REAL(wp), DIMENSION(jpi,jpj,jpk), INTENT(inout) :: puc ! input as Courant number ; output as flux 364 367 !! 365 INTEGER :: ji, jj, jk ! dummy loop indices 366 REAL(wp) :: zcoef1, zcoef2, zcoef3 ! local scalars 368 INTEGER :: ji, jj, jk ! dummy loop indices 369 REAL(wp) :: zcoef1, zcoef2, zcoef3 ! local scalars 367 370 REAL(wp) :: zc, zcurv, zfho ! - - 368 371 !---------------------------------------------------------------------- … … 374 377 zcoef2 = 0.5 * zc * ( pfd(ji,jj,jk) - pfc(ji,jj,jk) ) 375 378 zcoef3 = ( 1. - ( zc * zc ) ) * r1_6 * zcurv 376 zfho = zcoef1 - zcoef2 - zcoef3 ! phi_f QUICKEST 379 zfho = zcoef1 - zcoef2 - zcoef3 ! phi_f QUICKEST 377 380 ! 378 381 zcoef1 = pfd(ji,jj,jk) - pfu(ji,jj,jk) … … 380 383 zcoef3 = ABS( zcurv ) 381 384 IF( zcoef3 >= zcoef2 ) THEN 382 zfho = pfc(ji,jj,jk) 385 zfho = pfc(ji,jj,jk) 383 386 ELSE 384 387 zcoef3 = pfu(ji,jj,jk) + ( ( pfc(ji,jj,jk) - pfu(ji,jj,jk) ) / MAX( zc, 1.e-9 ) ) ! phi_REF 385 388 IF( zcoef1 >= 0. ) THEN 386 zfho = MAX( pfc(ji,jj,jk), zfho ) 387 zfho = MIN( zfho, MIN( zcoef3, pfd(ji,jj,jk) ) ) 389 zfho = MAX( pfc(ji,jj,jk), zfho ) 390 zfho = MIN( zfho, MIN( zcoef3, pfd(ji,jj,jk) ) ) 388 391 ELSE 389 zfho = MIN( pfc(ji,jj,jk), zfho ) 390 zfho = MAX( zfho, MAX( zcoef3, pfd(ji,jj,jk) ) ) 392 zfho = MIN( pfc(ji,jj,jk), zfho ) 393 zfho = MAX( zfho, MAX( zcoef3, pfd(ji,jj,jk) ) ) 391 394 ENDIF 392 395 ENDIF -
NEMO/branches/2020/dev_r12527_Gurvan_ShallowWater/src/OCE/TRA/traadv_ubs.F90
r12377 r13151 10 10 !!---------------------------------------------------------------------- 11 11 !! tra_adv_ubs : update the tracer trend with the horizontal 12 !! advection trends using a third order biaised scheme 12 !! advection trends using a third order biaised scheme 13 13 !!---------------------------------------------------------------------- 14 14 USE oce ! ocean dynamics and active tracers … … 16 16 USE trc_oce ! share passive tracers/Ocean variables 17 17 USE trd_oce ! trends: ocean variables 18 USE traadv_fct ! acces to routine interp_4th_cpt 19 USE trdtra ! trends manager: tracers 18 USE traadv_fct ! acces to routine interp_4th_cpt 19 USE trdtra ! trends manager: tracers 20 20 USE diaptr ! poleward transport diagnostics 21 21 USE diaar5 ! AR5 diagnostics … … 25 25 USE lib_mpp ! massively parallel library 26 26 USE lbclnk ! ocean lateral boundary condition (or mpp link) 27 USE lib_fortran ! Fortran utilities (allows no signed zero when 'key_nosignedzero' defined) 27 USE lib_fortran ! Fortran utilities (allows no signed zero when 'key_nosignedzero' defined) 28 28 29 29 IMPLICIT NONE … … 39 39 !! * Substitutions 40 40 # include "do_loop_substitute.h90" 41 # include "domzgr_substitute.h90" 41 42 !!---------------------------------------------------------------------- 42 43 !! NEMO/OCE 4.0 , NEMO Consortium (2018) … … 50 51 !!---------------------------------------------------------------------- 51 52 !! *** ROUTINE tra_adv_ubs *** 52 !! 53 !! 53 54 !! ** Purpose : Compute the now trend due to the advection of tracers 54 55 !! and add it to the general trend of passive tracer equations. … … 59 60 !! For example the i-component of the advective fluxes are given by : 60 61 !! ! e2u e3u un ( mi(Tn) - zltu(i ) ) if un(i) >= 0 61 !! ztu = ! or 62 !! ztu = ! or 62 63 !! ! e2u e3u un ( mi(Tn) - zltu(i+1) ) if un(i) < 0 63 64 !! where zltu is the second derivative of the before temperature field: 64 65 !! zltu = 1/e3t di[ e2u e3u / e1u di[Tb] ] 65 !! This results in a dissipatively dominant (i.e. hyper-diffusive) 66 !! truncation error. The overall performance of the advection scheme 67 !! is similar to that reported in (Farrow and Stevens, 1995). 66 !! This results in a dissipatively dominant (i.e. hyper-diffusive) 67 !! truncation error. The overall performance of the advection scheme 68 !! is similar to that reported in (Farrow and Stevens, 1995). 68 69 !! For stability reasons, the first term of the fluxes which corresponds 69 !! to a second order centered scheme is evaluated using the now velocity 70 !! (centered in time) while the second term which is the diffusive part 71 !! of the scheme, is evaluated using the before velocity (forward in time). 70 !! to a second order centered scheme is evaluated using the now velocity 71 !! (centered in time) while the second term which is the diffusive part 72 !! of the scheme, is evaluated using the before velocity (forward in time). 72 73 !! Note that UBS is not positive. Do not use it on passive tracers. 73 74 !! On the vertical, the advection is evaluated using a FCT scheme, 74 !! as the UBS have been found to be too diffusive. 75 !! kn_ubs_v argument controles whether the FCT is based on 76 !! a 2nd order centrered scheme (kn_ubs_v=2) or on a 4th order compact 75 !! as the UBS have been found to be too diffusive. 76 !! kn_ubs_v argument controles whether the FCT is based on 77 !! a 2nd order centrered scheme (kn_ubs_v=2) or on a 4th order compact 77 78 !! scheme (kn_ubs_v=4). 78 79 !! … … 81 82 !! - poleward advective heat and salt transport (ln_diaptr=T) 82 83 !! 83 !! Reference : Shchepetkin, A. F., J. C. McWilliams, 2005, Ocean Modelling, 9, 347-404. 84 !! Farrow, D.E., Stevens, D.P., 1995, J. Phys. Ocean. 25, 1731 Ð1741.84 !! Reference : Shchepetkin, A. F., J. C. McWilliams, 2005, Ocean Modelling, 9, 347-404. 85 !! Farrow, D.E., Stevens, D.P., 1995, J. Phys. Ocean. 25, 1731�1741. 85 86 !!---------------------------------------------------------------------- 86 87 INTEGER , INTENT(in ) :: kt ! ocean time-step index … … 111 112 l_ptr = .FALSE. 112 113 IF( ( cdtype == 'TRA' .AND. l_trdtra ) .OR. ( cdtype == 'TRC' .AND. l_trdtrc ) ) l_trd = .TRUE. 113 IF( cdtype == 'TRA' .AND. ( iom_use( 'sophtadv' ) .OR. iom_use( 'sophtadv' ) ) ) l_ptr = .TRUE. 114 IF( cdtype == 'TRA' .AND. ( iom_use( 'sophtadv' ) .OR. iom_use( 'sophtadv' ) ) ) l_ptr = .TRUE. 114 115 IF( cdtype == 'TRA' .AND. ( iom_use("uadv_heattr") .OR. iom_use("vadv_heattr") .OR. & 115 116 & iom_use("uadv_salttr") .OR. iom_use("vadv_salttr") ) ) l_hst = .TRUE. … … 122 123 DO jn = 1, kjpt ! tracer loop 123 124 ! ! =========== 124 ! 125 ! 125 126 DO jk = 1, jpkm1 !== horizontal laplacian of before tracer ==! 126 127 DO_2D_10_10 … … 135 136 zltv(ji,jj,jk) = ( ztv(ji,jj,jk) - ztv(ji,jj-1,jk) ) * zcoef 136 137 END_2D 137 ! 138 END DO 138 ! 139 END DO 139 140 CALL lbc_lnk( 'traadv_ubs', zltu, 'T', 1. ) ; CALL lbc_lnk( 'traadv_ubs', zltv, 'T', 1. ) ! Lateral boundary cond. (unchanged sgn) 140 ! 141 ! 141 142 DO_3D_10_10( 1, jpkm1 ) 142 143 zfp_ui = pU(ji,jj,jk) + ABS( pU(ji,jj,jk) ) ! upstream transport (x2) … … 158 159 pt(ji,jj,jk,jn,Krhs) = pt(ji,jj,jk,jn,Krhs) & 159 160 & - ( ztu(ji,jj,jk) - ztu(ji-1,jj ,jk) & 160 & + ztv(ji,jj,jk) - ztv(ji ,jj-1,jk) ) * r1_e1e2t(ji,jj) / e3t(ji,jj,jk,Kmm) 161 & + ztv(ji,jj,jk) - ztv(ji ,jj-1,jk) ) & 162 & * r1_e1e2t(ji,jj) / e3t(ji,jj,jk,Kmm) 161 163 END_2D 162 ! 164 ! 163 165 END DO 164 166 ! 165 167 zltu(:,:,:) = pt(:,:,:,jn,Krhs) - zltu(:,:,:) ! Horizontal advective trend used in vertical 2nd order FCT case 166 ! ! and/or in trend diagnostic (l_trd=T) 167 ! 168 ! ! and/or in trend diagnostic (l_trd=T) 169 ! 168 170 IF( l_trd ) THEN ! trend diagnostics 169 171 CALL trd_tra( kt, Kmm, Krhs, cdtype, jn, jptra_xad, ztu, pU, pt(:,:,:,jn,Kmm) ) 170 172 CALL trd_tra( kt, Kmm, Krhs, cdtype, jn, jptra_yad, ztv, pV, pt(:,:,:,jn,Kmm) ) 171 173 END IF 172 ! 174 ! 173 175 ! ! "Poleward" heat and salt transports (contribution of upstream fluxes) 174 176 IF( l_ptr ) CALL dia_ptr_hst( jn, 'adv', ztv(:,:,:) ) … … 181 183 SELECT CASE( kn_ubs_v ) ! select the vertical advection scheme 182 184 ! 183 CASE( 2 ) ! 2nd order FCT 184 ! 185 CASE( 2 ) ! 2nd order FCT 186 ! 185 187 IF( l_trd ) zltv(:,:,:) = pt(:,:,:,jn,Krhs) ! store pt(:,:,:,:,Krhs) if trend diag. 186 188 ! … … 194 196 IF( ln_isfcav ) THEN ! top of the ice-shelf cavities and at the ocean surface 195 197 DO_2D_11_11 196 ztw(ji,jj, mikt(ji,jj) ) = pW(ji,jj,mikt(ji,jj)) * pt(ji,jj,mikt(ji,jj),jn,Kbb) ! linear free surface 198 ztw(ji,jj, mikt(ji,jj) ) = pW(ji,jj,mikt(ji,jj)) * pt(ji,jj,mikt(ji,jj),jn,Kbb) ! linear free surface 197 199 END_2D 198 200 ELSE ! no cavities: only at the ocean surface … … 202 204 ! 203 205 DO_3D_00_00( 1, jpkm1 ) 204 ztak = - ( ztw(ji,jj,jk) - ztw(ji,jj,jk+1) ) * r1_e1e2t(ji,jj) / e3t(ji,jj,jk,Kmm) 205 pt(ji,jj,jk,jn,Krhs) = pt(ji,jj,jk,jn,Krhs) + ztak 206 ztak = - ( ztw(ji,jj,jk) - ztw(ji,jj,jk+1) ) & 207 & * r1_e1e2t(ji,jj) / e3t(ji,jj,jk,Kmm) 208 pt(ji,jj,jk,jn,Krhs) = pt(ji,jj,jk,jn,Krhs) + ztak 206 209 zti(ji,jj,jk) = ( pt(ji,jj,jk,jn,Kbb) + p2dt * ( ztak + zltu(ji,jj,jk) ) ) * tmask(ji,jj,jk) 207 210 END_3D … … 228 231 ! 229 232 DO_3D_00_00( 1, jpkm1 ) 230 pt(ji,jj,jk,jn,Krhs) = pt(ji,jj,jk,jn,Krhs) - ( ztw(ji,jj,jk) - ztw(ji,jj,jk+1) ) * r1_e1e2t(ji,jj) / e3t(ji,jj,jk,Kmm) 233 pt(ji,jj,jk,jn,Krhs) = pt(ji,jj,jk,jn,Krhs) - ( ztw(ji,jj,jk) - ztw(ji,jj,jk+1) ) & 234 & * r1_e1e2t(ji,jj) / e3t(ji,jj,jk,Kmm) 231 235 END_3D 232 236 ! … … 235 239 zltv(ji,jj,jk) = pt(ji,jj,jk,jn,Krhs) - zltv(ji,jj,jk) & 236 240 & + pt(ji,jj,jk,jn,Kmm) * ( pW(ji,jj,jk) - pW(ji,jj,jk+1) ) & 237 & * r1_e1e2t(ji,jj) / e3t(ji,jj,jk,Kmm)241 & * r1_e1e2t(ji,jj) / e3t(ji,jj,jk,Kmm) 238 242 END_3D 239 243 CALL trd_tra( kt, Kmm, Krhs, cdtype, jn, jptra_zad, zltv ) … … 248 252 !!--------------------------------------------------------------------- 249 253 !! *** ROUTINE nonosc_z *** 250 !! 251 !! ** Purpose : compute monotonic tracer fluxes from the upstream 252 !! scheme and the before field by a nonoscillatory algorithm 254 !! 255 !! ** Purpose : compute monotonic tracer fluxes from the upstream 256 !! scheme and the before field by a nonoscillatory algorithm 253 257 !! 254 258 !! ** Method : ... ??? -
NEMO/branches/2020/dev_r12527_Gurvan_ShallowWater/src/OCE/TRA/traatf.F90
r12489 r13151 26 26 !!---------------------------------------------------------------------- 27 27 USE oce ! ocean dynamics and tracers variables 28 USE dom_oce ! ocean space and time domain variables 28 USE dom_oce ! ocean space and time domain variables 29 29 USE sbc_oce ! surface boundary condition: ocean 30 30 USE sbcrnf ! river runoffs … … 33 33 USE domvvl ! variable volume 34 34 USE trd_oce ! trends: ocean variables 35 USE trdtra ! trends manager: tracers 35 USE trdtra ! trends manager: tracers 36 36 USE traqsr ! penetrative solar radiation (needed for nksr) 37 37 USE phycst ! physical constant … … 58 58 !! * Substitutions 59 59 # include "do_loop_substitute.h90" 60 # include "domzgr_substitute.h90" 60 61 !!---------------------------------------------------------------------- 61 62 !! NEMO/OCE 4.0 , NEMO Consortium (2018) … … 69 70 !! *** ROUTINE traatf *** 70 71 !! 71 !! ** Purpose : Apply the boundary condition on the after temperature 72 !! ** Purpose : Apply the boundary condition on the after temperature 72 73 !! and salinity fields and add the Asselin time filter on now fields. 73 !! 74 !! ** Method : At this stage of the computation, ta and sa are the 74 !! 75 !! ** Method : At this stage of the computation, ta and sa are the 75 76 !! after temperature and salinity as the time stepping has 76 77 !! been performed in trazdf_imp or trazdf_exp module. 77 78 !! 78 !! - Apply lateral boundary conditions on (ta,sa) 79 !! at the local domain boundaries through lbc_lnk call, 80 !! at the one-way open boundaries (ln_bdy=T), 79 !! - Apply lateral boundary conditions on (ta,sa) 80 !! at the local domain boundaries through lbc_lnk call, 81 !! at the one-way open boundaries (ln_bdy=T), 81 82 !! at the AGRIF zoom boundaries (lk_agrif=T) 82 83 !! … … 88 89 INTEGER , INTENT(in ) :: kt ! ocean time-step index 89 90 INTEGER , INTENT(in ) :: Kbb, Kmm, Kaa ! time level indices 90 REAL(wp), DIMENSION(jpi,jpj,jpk,jpts,jpt), INTENT(inout) :: pts ! active tracers 91 REAL(wp), DIMENSION(jpi,jpj,jpk,jpts,jpt), INTENT(inout) :: pts ! active tracers 91 92 !! 92 93 INTEGER :: ji, jj, jk, jn ! dummy loop indices … … 104 105 105 106 ! Update after tracer on domain lateral boundaries 106 ! 107 ! 107 108 #if defined key_agrif 108 109 CALL Agrif_tra ! AGRIF zoom boundaries … … 112 113 ! 113 114 IF( ln_bdy ) CALL bdy_tra( kt, Kbb, pts, Kaa ) ! BDY open boundaries 114 115 115 116 ! trends computation initialisation 116 IF( l_trdtra ) THEN 117 IF( l_trdtra ) THEN 117 118 ALLOCATE( ztrdt(jpi,jpj,jpk) , ztrds(jpi,jpj,jpk) ) 118 119 ztrdt(:,:,jpk) = 0._wp 119 120 ztrds(:,:,jpk) = 0._wp 120 IF( ln_traldf_iso ) THEN ! diagnose the "pure" Kz diffusive trend 121 IF( ln_traldf_iso ) THEN ! diagnose the "pure" Kz diffusive trend 121 122 CALL trd_tra( kt, Kmm, Kaa, 'TRA', jp_tem, jptra_zdfp, ztrdt ) 122 123 CALL trd_tra( kt, Kmm, Kaa, 'TRA', jp_sal, jptra_zdfp, ztrds ) 123 124 ENDIF 124 ! total trend for the non-time-filtered variables. 125 zfact = 1. 0/ rn_Dt125 ! total trend for the non-time-filtered variables. 126 zfact = 1._wp / rn_Dt 126 127 ! G Nurser 23 Mar 2017. Recalculate trend as Delta(e3t*T)/e3tn; e3tn cancel from pts(Kmm) terms 127 128 DO jk = 1, jpkm1 … … 132 133 CALL trd_tra( kt, Kmm, Kaa, 'TRA', jp_sal, jptra_tot, ztrds ) 133 134 IF( ln_linssh ) THEN ! linear sea surface height only 134 ! Store now fields before applying the Asselin filter 135 ! Store now fields before applying the Asselin filter 135 136 ! in order to calculate Asselin filter trend later. 136 ztrdt(:,:,:) = pts(:,:,:,jp_tem,Kmm) 137 ztrdt(:,:,:) = pts(:,:,:,jp_tem,Kmm) 137 138 ztrds(:,:,:) = pts(:,:,:,jp_sal,Kmm) 138 139 ENDIF … … 159 160 & pts(:,:,:,jp_tem,Kaa), 'T', 1., pts(:,:,:,jp_sal,Kaa), 'T', 1. ) 160 161 ! 161 ENDIF 162 ENDIF 162 163 ! 163 164 IF( l_trdtra .AND. ln_linssh ) THEN ! trend of the Asselin filter (tb filtered - tb)/dt 164 zfact = 1._wp / rDt165 165 DO jk = 1, jpkm1 166 ztrdt(:,:,jk) = ( pts(:,:,jk,jp_tem,Kmm) - ztrdt(:,:,jk) ) * zfact167 ztrds(:,:,jk) = ( pts(:,:,jk,jp_sal,Kmm) - ztrds(:,:,jk) ) * zfact166 ztrdt(:,:,jk) = ( pts(:,:,jk,jp_tem,Kmm) - ztrdt(:,:,jk) ) * r1_Dt 167 ztrds(:,:,jk) = ( pts(:,:,jk,jp_sal,Kmm) - ztrds(:,:,jk) ) * r1_Dt 168 168 END DO 169 169 CALL trd_tra( kt, Kmm, Kaa, 'TRA', jp_tem, jptra_atf, ztrdt ) … … 186 186 !! 187 187 !! ** Purpose : fixed volume: apply the Asselin time filter to the "now" field 188 !! 188 !! 189 189 !! ** Method : - Apply a Asselin time filter on now fields. 190 190 !! … … 211 211 ! 212 212 DO_3D_00_00( 1, jpkm1 ) 213 ztn = pt(ji,jj,jk,jn,Kmm) 213 ztn = pt(ji,jj,jk,jn,Kmm) 214 214 ztd = pt(ji,jj,jk,jn,Kaa) - 2._wp * ztn + pt(ji,jj,jk,jn,Kbb) ! time laplacian on tracers 215 215 ! … … 226 226 !! *** ROUTINE tra_atf_vvl *** 227 227 !! 228 !! ** Purpose : Time varying volume: apply the Asselin time filter 229 !! 228 !! ** Purpose : Time varying volume: apply the Asselin time filter 229 !! 230 230 !! ** Method : - Apply a thickness weighted Asselin time filter on now fields. 231 !! pt(Kmm) = ( e3t (Kmm)*pt(Kmm) + rn_atfp*[ e3t(Kbb)*pt(Kbb) - 2 e3t(Kmm)*pt(Kmm) + e3t_a*pt(Kaa) ] )232 !! /( e3t (Kmm) + rn_atfp*[ e3t(Kbb) - 2 e3t(Kmm) + e3t(Kaa)] )231 !! pt(Kmm) = ( e3t_Kmm*pt(Kmm) + rn_atfp*[ e3t_Kbb*pt(Kbb) - 2 e3t_Kmm*pt(Kmm) + e3t_Kaa*pt(Kaa) ] ) 232 !! /( e3t_Kmm + rn_atfp*[ e3t_Kbb - 2 e3t_Kmm + e3t_Kaa ] ) 233 233 !! 234 234 !! ** Action : - pt(Kmm) ready for the next time step … … 257 257 ENDIF 258 258 ! 259 IF( cdtype == 'TRA' ) THEN 259 IF( cdtype == 'TRA' ) THEN 260 260 ll_traqsr = ln_traqsr ! active tracers case and solar penetration 261 261 ll_rnf = ln_rnf ! active tracers case and river runoffs … … 263 263 ELSE ! passive tracers case 264 264 ll_traqsr = .FALSE. ! NO solar penetration 265 ll_rnf = .FALSE. ! NO river runoffs ???? !!gm BUG ? 266 ll_isf = .FALSE. ! NO ice shelf melting/freezing !!gm BUG ?? 265 ll_rnf = .FALSE. ! NO river runoffs ???? !!gm BUG ? 266 ll_isf = .FALSE. ! NO ice shelf melting/freezing !!gm BUG ?? 267 267 ENDIF 268 268 ! … … 274 274 zfact1 = rn_atfp * p2dt 275 275 zfact2 = zfact1 * r1_rho0 276 DO jn = 1, kjpt 276 DO jn = 1, kjpt 277 277 DO_3D_00_00( 1, jpkm1 ) 278 278 ze3t_b = e3t(ji,jj,jk,Kbb) … … 291 291 ! 292 292 ! Add asselin correction on scale factors: 293 zscale = tmask(ji,jj,jk) * e3t(ji,jj,jk,Kmm) / ( ht(ji,jj) + 1._wp - ssmask(ji,jj) ) 294 ze3t_f = ze3t_f - zfact2 * zscale * ( emp_b(ji,jj) - emp(ji,jj) ) 295 IF ( ll_rnf ) ze3t_f = ze3t_f + zfact2 * zscale * ( rnf_b(ji,jj) - rnf(ji,jj) ) 293 zscale = tmask(ji,jj,jk) * e3t(ji,jj,jk,Kmm) / ( ht(ji,jj) + 1._wp - ssmask(ji,jj) ) 294 ze3t_f = ze3t_f - zfact2 * zscale * ( emp_b(ji,jj) - emp(ji,jj) ) 295 IF ( ll_rnf ) ze3t_f = ze3t_f + zfact2 * zscale * ( rnf_b(ji,jj) - rnf(ji,jj) ) 296 296 IF ( ll_isf ) THEN 297 297 IF ( ln_isfcav_mlt ) ze3t_f = ze3t_f - zfact2 * zscale * ( fwfisf_cav_b(ji,jj) - fwfisf_cav(ji,jj) ) … … 299 299 ENDIF 300 300 ! 301 IF( jk == mikt(ji,jj) ) THEN ! first level 301 IF( jk == mikt(ji,jj) ) THEN ! first level 302 302 ztc_f = ztc_f - zfact1 * ( psbc_tc(ji,jj,jn) - psbc_tc_b(ji,jj,jn) ) 303 303 ENDIF 304 304 ! 305 305 ! solar penetration (temperature only) 306 IF( ll_traqsr .AND. jn == jp_tem .AND. jk <= nksr ) & 307 & ztc_f = ztc_f - zfact1 * ( qsr_hc(ji,jj,jk) - qsr_hc_b(ji,jj,jk) ) 306 IF( ll_traqsr .AND. jn == jp_tem .AND. jk <= nksr ) & 307 & ztc_f = ztc_f - zfact1 * ( qsr_hc(ji,jj,jk) - qsr_hc_b(ji,jj,jk) ) 308 308 ! 309 309 ! 310 310 IF( ll_rnf .AND. jk <= nk_rnf(ji,jj) ) & 311 & ztc_f = ztc_f - zfact1 * ( rnf_tsc(ji,jj,jn) - rnf_tsc_b(ji,jj,jn) ) & 311 & ztc_f = ztc_f - zfact1 * ( rnf_tsc(ji,jj,jn) - rnf_tsc_b(ji,jj,jn) ) & 312 312 & * e3t(ji,jj,jk,Kmm) / h_rnf(ji,jj) 313 313 … … 323 323 & * e3t(ji,jj,jk,Kmm) / rhisf_tbl_cav(ji,jj) 324 324 END IF 325 ! level partially include in Losch_2008 ice shelf boundary layer 325 ! level partially include in Losch_2008 ice shelf boundary layer 326 326 IF ( jk == misfkb_cav(ji,jj) ) THEN 327 327 ztc_f = ztc_f - zfact1 * ( risf_cav_tsc(ji,jj,jn) - risf_cav_tsc_b(ji,jj,jn) ) & … … 337 337 & * e3t(ji,jj,jk,Kmm) / rhisf_tbl_par(ji,jj) 338 338 END IF 339 ! level partially include in Losch_2008 ice shelf boundary layer 339 ! level partially include in Losch_2008 ice shelf boundary layer 340 340 IF ( jk == misfkb_par(ji,jj) ) THEN 341 341 ztc_f = ztc_f - zfact1 * ( risf_par_tsc(ji,jj,jn) - risf_par_tsc_b(ji,jj,jn) ) & … … 366 366 ! 367 367 END_3D 368 ! 368 ! 369 369 END DO 370 370 ! 371 371 IF( ( l_trdtra .AND. cdtype == 'TRA' ) .OR. ( l_trdtrc .AND. cdtype == 'TRC' ) ) THEN 372 IF( l_trdtra .AND. cdtype == 'TRA' ) THEN 372 IF( l_trdtra .AND. cdtype == 'TRA' ) THEN 373 373 CALL trd_tra( kt, Kmm, Kaa, cdtype, jp_tem, jptra_atf, ztrd_atf(:,:,:,jp_tem) ) 374 374 CALL trd_tra( kt, Kmm, Kaa, cdtype, jp_sal, jptra_atf, ztrd_atf(:,:,:,jp_sal) ) -
NEMO/branches/2020/dev_r12527_Gurvan_ShallowWater/src/OCE/TRA/trabbc.F90
r12489 r13151 12 12 13 13 !!---------------------------------------------------------------------- 14 !! tra_bbc : update the tracer trend at ocean bottom 14 !! tra_bbc : update the tracer trend at ocean bottom 15 15 !! tra_bbc_init : initialization of geothermal heat flux trend 16 16 !!---------------------------------------------------------------------- … … 19 19 USE phycst ! physical constants 20 20 USE trd_oce ! trends: ocean variables 21 USE trdtra ! trends manager: tracers 21 USE trdtra ! trends manager: tracers 22 22 ! 23 23 USE in_out_manager ! I/O manager 24 USE iom ! xIOS 24 USE iom ! xIOS 25 25 USE fldread ! read input fields 26 26 USE lbclnk ! ocean lateral boundary conditions (or mpp link) … … 43 43 44 44 TYPE(FLD), ALLOCATABLE, DIMENSION(:) :: sf_qgh ! structure of input qgh (file informations, fields read) 45 45 46 46 !! * Substitutions 47 47 # include "do_loop_substitute.h90" 48 # include "domzgr_substitute.h90" 48 49 !!---------------------------------------------------------------------- 49 50 !! NEMO/OCE 4.0 , NEMO Consortium (2018) … … 57 58 !! *** ROUTINE tra_bbc *** 58 59 !! 59 !! ** Purpose : Compute the bottom boundary contition on temperature 60 !! associated with geothermal heating and add it to the 60 !! ** Purpose : Compute the bottom boundary contition on temperature 61 !! associated with geothermal heating and add it to the 61 62 !! general trend of temperature equations. 62 63 !! 63 !! ** Method : The geothermal heat flux set to its constant value of 64 !! ** Method : The geothermal heat flux set to its constant value of 64 65 !! 86.4 mW/m2 (Stein and Stein 1992, Huang 1999). 65 66 !! The temperature trend associated to this heat flux through the … … 91 92 ! ! Add the geothermal trend on temperature 92 93 DO_2D_00_00 93 pts(ji,jj,mbkt(ji,jj),jp_tem,Krhs) = pts(ji,jj,mbkt(ji,jj),jp_tem,Krhs) + qgh_trd0(ji,jj) / e3t(ji,jj,mbkt(ji,jj),Kmm) 94 pts(ji,jj,mbkt(ji,jj),jp_tem,Krhs) = pts(ji,jj,mbkt(ji,jj),jp_tem,Krhs) & 95 & + qgh_trd0(ji,jj) / e3t(ji,jj,mbkt(ji,jj),Kmm) 94 96 END_2D 95 97 ! … … 133 135 CHARACTER(len=256) :: cn_dir ! Root directory for location of ssr files 134 136 !! 135 NAMELIST/nambbc/ln_trabbc, nn_geoflx, rn_geoflx_cst, sn_qgh, cn_dir 137 NAMELIST/nambbc/ln_trabbc, nn_geoflx, rn_geoflx_cst, sn_qgh, cn_dir 136 138 !!---------------------------------------------------------------------- 137 139 ! -
NEMO/branches/2020/dev_r12527_Gurvan_ShallowWater/src/OCE/TRA/trabbl.F90
r12377 r13151 31 31 USE trdtra ! trends: active tracers 32 32 ! 33 USE iom ! IOM library 33 USE iom ! IOM library 34 34 USE in_out_manager ! I/O manager 35 35 USE lbclnk ! ocean lateral boundary conditions 36 36 USE prtctl ! Print control 37 37 USE timing ! Timing 38 USE lib_fortran ! Fortran utilities (allows no signed zero when 'key_nosignedzero' defined) 38 USE lib_fortran ! Fortran utilities (allows no signed zero when 'key_nosignedzero' defined) 39 39 40 40 IMPLICIT NONE … … 68 68 !! * Substitutions 69 69 # include "do_loop_substitute.h90" 70 # include "domzgr_substitute.h90" 70 71 !!---------------------------------------------------------------------- 71 72 !! NEMO/OCE 4.0 , NEMO Consortium (2018) … … 195 196 zptb(ji,jj) = pt(ji,jj,ik,jn) ! bottom before T and S 196 197 END_2D 197 ! 198 ! 198 199 DO_2D_00_00 199 200 ik = mbkt(ji,jj) ! bottom T-level index … … 391 392 za = zab(ji+1,jj,jp_tem) + zab(ji,jj,jp_tem) ! 2*(alpha,beta) at u-point 392 393 zb = zab(ji+1,jj,jp_sal) + zab(ji,jj,jp_sal) 393 ! ! 2*masked bottom density gradient 394 ! ! 2*masked bottom density gradient 394 395 zgdrho = ( za * ( zts(ji+1,jj,jp_tem) - zts(ji,jj,jp_tem) ) & 395 396 - zb * ( zts(ji+1,jj,jp_sal) - zts(ji,jj,jp_sal) ) ) * umask(ji,jj,1) … … 513 514 END_2D 514 515 ! converte into REAL to use lbc_lnk ; impose a min value of 1 as a zero can be set in lbclnk 515 zmbku(:,:) = REAL( mbku_d(:,:), wp ) ; zmbkv(:,:) = REAL( mbkv_d(:,:), wp ) 516 CALL lbc_lnk_multi( 'trabbl', zmbku,'U',1., zmbkv,'V',1.) 516 zmbku(:,:) = REAL( mbku_d(:,:), wp ) ; zmbkv(:,:) = REAL( mbkv_d(:,:), wp ) 517 CALL lbc_lnk_multi( 'trabbl', zmbku,'U',1., zmbkv,'V',1.) 517 518 mbku_d(:,:) = MAX( INT( zmbku(:,:) ), 1 ) ; mbkv_d(:,:) = MAX( NINT( zmbkv(:,:) ), 1 ) 518 519 ! -
NEMO/branches/2020/dev_r12527_Gurvan_ShallowWater/src/OCE/TRA/traisf.F90
r12377 r13151 11 11 !!---------------------------------------------------------------------- 12 12 USE isf_oce ! Ice shelf variables 13 USE dom_oce , ONLY : e3t, r1_e1e2t! ocean space domain variables13 USE dom_oce ! ocean space domain variables 14 14 USE isfutils, ONLY : debug ! debug option 15 15 USE timing , ONLY : timing_start, timing_stop ! Timing … … 23 23 !! * Substitutions 24 24 # include "do_loop_substitute.h90" 25 # include "domzgr_substitute.h90" 25 26 !!---------------------------------------------------------------------- 26 27 !! NEMO/OCE 4.0 , NEMO Consortium (2018) … … 33 34 !!---------------------------------------------------------------------- 34 35 !! *** ROUTINE tra_isf *** 35 !! 36 !! 36 37 !! ** Purpose : Compute the temperature trend due to the ice shelf melting (qhoce + qhc) 37 38 !! … … 61 62 ! 62 63 ! Dynamical stability at start up after change in under ice shelf cavity geometry is achieve by correcting the divergence. 63 ! This is achieved by applying a volume flux in order to keep the horizontal divergence after remapping 64 ! This is achieved by applying a volume flux in order to keep the horizontal divergence after remapping 64 65 ! the same as at the end of the latest time step. So correction need to be apply at nit000 (euler time step) and 65 66 ! half of it at nit000+1 (leap frog time step). … … 89 90 !! *** Purpose : Compute the temperature trend due to the ice shelf melting (qhoce + qhc) for cav or par case 90 91 !! 91 !! *** Action :: Update pts(:,:,:,:,Krhs) with the surface boundary condition trend 92 !! *** Action :: Update pts(:,:,:,:,Krhs) with the surface boundary condition trend 92 93 !! 93 94 !!---------------------------------------------------------------------- … … 98 99 REAL(wp), DIMENSION(jpi,jpj,jpts), INTENT(in ) :: ptsc , ptsc_b 99 100 !!---------------------------------------------------------------------- 100 INTEGER :: ji,jj,jk ! loop index 101 INTEGER :: ji,jj,jk ! loop index 101 102 INTEGER :: ikt, ikb ! top and bottom level of the tbl 102 103 REAL(wp), DIMENSION(jpi,jpj) :: ztc ! total ice shelf tracer trend … … 117 118 END DO 118 119 ! 119 ! level partially include in ice shelf boundary layer 120 ! level partially include in ice shelf boundary layer 120 121 pts(ji,jj,ikb,jp_tem) = pts(ji,jj,ikb,jp_tem) + ztc(ji,jj) * pfrac(ji,jj) 121 122 ! … … 128 129 !! *** ROUTINE tra_isf_cpl *** 129 130 !! 130 !! *** Action :: Update pts(:,:,:,:,Krhs) with the ice shelf coupling trend 131 !! *** Action :: Update pts(:,:,:,:,Krhs) with the ice shelf coupling trend 131 132 !! 132 133 !!---------------------------------------------------------------------- … … 140 141 ! 141 142 DO jk = 1,jpk 142 ptsa(:,:,jk,jp_tem) = ptsa(:,:,jk,jp_tem) + ptsc(:,:,jk,jp_tem) * r1_e1e2t(:,:) / e3t(:,:,jk,Kmm) 143 ptsa(:,:,jk,jp_sal) = ptsa(:,:,jk,jp_sal) + ptsc(:,:,jk,jp_sal) * r1_e1e2t(:,:) / e3t(:,:,jk,Kmm) 143 ptsa(:,:,jk,jp_tem) = & 144 & ptsa(:,:,jk,jp_tem) + ptsc(:,:,jk,jp_tem) * r1_e1e2t(:,:) / e3t(:,:,jk,Kmm) 145 ptsa(:,:,jk,jp_sal) = & 146 & ptsa(:,:,jk,jp_sal) + ptsc(:,:,jk,jp_sal) * r1_e1e2t(:,:) / e3t(:,:,jk,Kmm) 144 147 END DO 145 148 ! -
NEMO/branches/2020/dev_r12527_Gurvan_ShallowWater/src/OCE/TRA/traldf_iso.F90
r12489 r13151 15 15 !!---------------------------------------------------------------------- 16 16 !! tra_ldf_iso : update the tracer trend with the horizontal component of a iso-neutral laplacian operator 17 !! and with the vertical part of the isopycnal or geopotential s-coord. operator 17 !! and with the vertical part of the isopycnal or geopotential s-coord. operator 18 18 !!---------------------------------------------------------------------- 19 19 USE oce ! ocean dynamics and active tracers … … 41 41 !! * Substitutions 42 42 # include "do_loop_substitute.h90" 43 # include "domzgr_substitute.h90" 43 44 !!---------------------------------------------------------------------- 44 45 !! NEMO/OCE 4.0 , NEMO Consortium (2018) … … 54 55 !! *** ROUTINE tra_ldf_iso *** 55 56 !! 56 !! ** Purpose : Compute the before horizontal tracer (t & s) diffusive 57 !! trend for a laplacian tensor (ezxcept the dz[ dz[.] ] term) and 57 !! ** Purpose : Compute the before horizontal tracer (t & s) diffusive 58 !! trend for a laplacian tensor (ezxcept the dz[ dz[.] ] term) and 58 59 !! add it to the general trend of tracer equation. 59 60 !! 60 !! ** Method : The horizontal component of the lateral diffusive trends 61 !! ** Method : The horizontal component of the lateral diffusive trends 61 62 !! is provided by a 2nd order operator rotated along neural or geopo- 62 63 !! tential surfaces to which an eddy induced advection can be added … … 69 70 !! 70 71 !! 2nd part : horizontal fluxes of the lateral mixing operator 71 !! ======== 72 !! ======== 72 73 !! zftu = pahu e2u*e3u/e1u di[ tb ] 73 74 !! - pahu e2u*uslp dk[ mi(mk(tb)) ] … … 111 112 REAL(wp) :: zcoef0, ze3w_2, zsign ! - - 112 113 REAL(wp), DIMENSION(jpi,jpj) :: zdkt, zdk1t, z2d 113 REAL(wp), DIMENSION(jpi,jpj,jpk) :: zdit, zdjt, zftu, zftv, ztfw 114 REAL(wp), DIMENSION(jpi,jpj,jpk) :: zdit, zdjt, zftu, zftv, ztfw 114 115 !!---------------------------------------------------------------------- 115 116 ! … … 119 120 IF(lwp) WRITE(numout,*) '~~~~~~~~~~~' 120 121 ! 121 akz (:,:,:) = 0._wp 122 akz (:,:,:) = 0._wp 122 123 ah_wslp2(:,:,:) = 0._wp 123 124 ENDIF 124 ! 125 ! 125 126 l_hst = .FALSE. 126 127 l_ptr = .FALSE. 127 IF( cdtype == 'TRA' .AND. ( iom_use( 'sophtldf' ) .OR. iom_use( 'sopstldf' ) ) ) l_ptr = .TRUE. 128 IF( cdtype == 'TRA' .AND. ( iom_use( 'sophtldf' ) .OR. iom_use( 'sopstldf' ) ) ) l_ptr = .TRUE. 128 129 IF( cdtype == 'TRA' .AND. ( iom_use("uadv_heattr") .OR. iom_use("vadv_heattr") .OR. & 129 130 & iom_use("uadv_salttr") .OR. iom_use("vadv_salttr") ) ) l_hst = .TRUE. … … 133 134 ELSE ; zsign = -1._wp 134 135 ENDIF 135 136 136 137 !!---------------------------------------------------------------------- 137 138 !! 0 - calculate ah_wslp2 and akz … … 167 168 IF( ln_traldf_blp ) THEN ! bilaplacian operator 168 169 DO_3D_10_10( 2, jpkm1 ) 169 akz(ji,jj,jk) = 16._wp * ah_wslp2(ji,jj,jk) & 170 & * ( akz(ji,jj,jk) + ah_wslp2(ji,jj,jk) / ( e3w(ji,jj,jk,Kmm) * e3w(ji,jj,jk,Kmm) ) ) 170 akz(ji,jj,jk) = 16._wp & 171 & * ah_wslp2 (ji,jj,jk) & 172 & * ( akz (ji,jj,jk) & 173 & + ah_wslp2(ji,jj,jk) & 174 & / ( e3w(ji,jj,jk,Kmm) * e3w(ji,jj,jk,Kmm) ) ) 171 175 END_3D 172 176 ELSEIF( ln_traldf_lap ) THEN ! laplacian operator … … 179 183 ! 180 184 ELSE ! 33 flux set to zero with akz=ah_wslp2 ==>> computed in full implicit 181 akz(:,:,:) = ah_wslp2(:,:,:) 185 akz(:,:,:) = ah_wslp2(:,:,:) 182 186 ENDIF 183 187 ENDIF … … 186 190 DO jn = 1, kjpt ! tracer loop 187 191 ! ! =========== 188 ! 189 !!---------------------------------------------------------------------- 190 !! I - masked horizontal derivative 192 ! 193 !!---------------------------------------------------------------------- 194 !! I - masked horizontal derivative 191 195 !!---------------------------------------------------------------------- 192 196 !!gm : bug.... why (x,:,:)? (1,jpj,:) and (jpi,1,:) should be sufficient.... … … 195 199 !!end 196 200 197 ! Horizontal tracer gradient 201 ! Horizontal tracer gradient 198 202 DO_3D_10_10( 1, jpkm1 ) 199 203 zdit(ji,jj,jk) = ( pt(ji+1,jj ,jk,jn) - pt(ji,jj,jk,jn) ) * umask(ji,jj,jk) … … 202 206 IF( ln_zps ) THEN ! botton and surface ocean correction of the horizontal gradient 203 207 DO_2D_10_10 204 zdit(ji,jj,mbku(ji,jj)) = pgu(ji,jj,jn) 208 zdit(ji,jj,mbku(ji,jj)) = pgu(ji,jj,jn) 205 209 zdjt(ji,jj,mbkv(ji,jj)) = pgv(ji,jj,jn) 206 210 END_2D 207 211 IF( ln_isfcav ) THEN ! first wet level beneath a cavity 208 212 DO_2D_10_10 209 IF( miku(ji,jj) > 1 ) zdit(ji,jj,miku(ji,jj)) = pgui(ji,jj,jn) 210 IF( mikv(ji,jj) > 1 ) zdjt(ji,jj,mikv(ji,jj)) = pgvi(ji,jj,jn) 213 IF( miku(ji,jj) > 1 ) zdit(ji,jj,miku(ji,jj)) = pgui(ji,jj,jn) 214 IF( mikv(ji,jj) > 1 ) zdjt(ji,jj,mikv(ji,jj)) = pgvi(ji,jj,jn) 211 215 END_2D 212 216 ENDIF … … 243 247 zftv(ji,jj,jk) = ( zabe2 * zdjt(ji,jj,jk) & 244 248 & + zcof2 * ( zdkt (ji,jj+1) + zdk1t(ji,jj) & 245 & + zdk1t(ji,jj+1) + zdkt (ji,jj) ) ) * vmask(ji,jj,jk) 249 & + zdk1t(ji,jj+1) + zdkt (ji,jj) ) ) * vmask(ji,jj,jk) 246 250 END_2D 247 251 ! 248 252 DO_2D_00_00 249 pt_rhs(ji,jj,jk,jn) = pt_rhs(ji,jj,jk,jn) + zsign * ( zftu(ji,jj,jk) - zftu(ji-1,jj,jk)&250 & 251 & 253 pt_rhs(ji,jj,jk,jn) = pt_rhs(ji,jj,jk,jn) & 254 & + zsign * ( zftu(ji,jj,jk) - zftu(ji-1,jj,jk) + zftv(ji,jj,jk) - zftv(ji,jj-1,jk) ) & 255 & * r1_e1e2t(ji,jj) / e3t(ji,jj,jk,Kmm) 252 256 END_2D 253 END DO ! End of slab 257 END DO ! End of slab 254 258 255 259 !!---------------------------------------------------------------------- … … 261 265 ! ! Surface and bottom vertical fluxes set to zero 262 266 ztfw(:,:, 1 ) = 0._wp ; ztfw(:,:,jpk) = 0._wp 263 267 264 268 DO_3D_00_00( 2, jpkm1 ) 265 269 ! … … 290 294 END_3D 291 295 ! 292 ELSE ! bilaplacian 296 ELSE ! bilaplacian 293 297 SELECT CASE( kpass ) 294 298 CASE( 1 ) ! 1st pass : eddy coef = ah_wslp2 295 299 DO_3D_00_00( 2, jpkm1 ) 296 ztfw(ji,jj,jk) = ztfw(ji,jj,jk)&297 & + ah_wslp2(ji,jj,jk)* e1e2t(ji,jj) &298 & 300 ztfw(ji,jj,jk) = & 301 & ztfw(ji,jj,jk) + ah_wslp2(ji,jj,jk) * e1e2t(ji,jj) & 302 & * ( pt(ji,jj,jk-1,jn) - pt(ji,jj,jk,jn) ) / e3w(ji,jj,jk,Kmm) * wmask(ji,jj,jk) 299 303 END_3D 300 304 CASE( 2 ) ! 2nd pass : eddy flux = ah_wslp2 and akz applied on pt and pt2 gradients, resp. 301 305 DO_3D_00_00( 2, jpkm1 ) 302 ztfw(ji,jj,jk) = ztfw(ji,jj,jk) + e1e2t(ji,jj) / e3w(ji,jj,jk,Kmm) * wmask(ji,jj,jk) 306 ztfw(ji,jj,jk) = ztfw(ji,jj,jk) + e1e2t(ji,jj) / e3w(ji,jj,jk,Kmm) * wmask(ji,jj,jk) & 303 307 & * ( ah_wslp2(ji,jj,jk) * ( pt (ji,jj,jk-1,jn) - pt (ji,jj,jk,jn) ) & 304 308 & + akz(ji,jj,jk) * ( pt2(ji,jj,jk-1,jn) - pt2(ji,jj,jk,jn) ) ) … … 306 310 END SELECT 307 311 ENDIF 308 ! 312 ! 309 313 DO_3D_00_00( 1, jpkm1 ) 310 pt_rhs(ji,jj,jk,jn) = pt_rhs(ji,jj,jk,jn) + zsign * ( ztfw (ji,jj,jk) - ztfw(ji,jj,jk+1) ) &311 & * r1_e1e2t(ji,jj)/ e3t(ji,jj,jk,Kmm)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 & / e3t(ji,jj,jk,Kmm) 312 316 END_3D 313 317 ! -
NEMO/branches/2020/dev_r12527_Gurvan_ShallowWater/src/OCE/TRA/traldf_lap_blp.F90
r12377 r13151 4 4 !! Ocean tracers: lateral diffusivity trend (laplacian and bilaplacian) 5 5 !!============================================================================== 6 !! History : 3.7 ! 2014-01 (G. Madec, S. Masson) Original code, re-entrant laplacian 6 !! History : 3.7 ! 2014-01 (G. Madec, S. Masson) Original code, re-entrant laplacian 7 7 !!---------------------------------------------------------------------- 8 8 … … 38 38 !! * Substitutions 39 39 # include "do_loop_substitute.h90" 40 # include "domzgr_substitute.h90" 40 41 !!---------------------------------------------------------------------- 41 42 !! NEMO/OCE 4.0 , NEMO Consortium (2018) … … 47 48 SUBROUTINE tra_ldf_lap( kt, Kmm, kit000, cdtype, pahu, pahv , & 48 49 & pgu , pgv , pgui, pgvi, & 49 & pt , pt_rhs, kjpt, kpass ) 50 & pt , pt_rhs, kjpt, kpass ) 50 51 !!---------------------------------------------------------------------- 51 52 !! *** ROUTINE tra_ldf_lap *** 52 !! 53 !! ** Purpose : Compute the before horizontal tracer (t & s) diffusive 53 !! 54 !! ** Purpose : Compute the before horizontal tracer (t & s) diffusive 54 55 !! trend and add it to the general trend of tracer equation. 55 56 !! 56 57 !! ** Method : Second order diffusive operator evaluated using before 57 !! fields (forward time scheme). The horizontal diffusive trends of 58 !! fields (forward time scheme). The horizontal diffusive trends of 58 59 !! the tracer is given by: 59 60 !! difft = 1/(e1e2t*e3t) { di-1[ pahu e2u*e3u/e1u di(tb) ] … … 62 63 !! pt_rhs = pt_rhs + difft 63 64 !! 64 !! ** Action : - Update pt_rhs arrays with the before iso-level 65 !! ** Action : - Update pt_rhs arrays with the before iso-level 65 66 !! harmonic mixing trend. 66 67 !!---------------------------------------------------------------------- … … 75 76 REAL(wp), DIMENSION(jpi,jpj, kjpt), INTENT(in ) :: pgui, pgvi ! tracer gradient at top levels 76 77 REAL(wp), DIMENSION(jpi,jpj,jpk,kjpt), INTENT(in ) :: pt ! before tracer fields 77 REAL(wp), DIMENSION(jpi,jpj,jpk,kjpt), INTENT(inout) :: pt_rhs ! tracer trend 78 REAL(wp), DIMENSION(jpi,jpj,jpk,kjpt), INTENT(inout) :: pt_rhs ! tracer trend 78 79 ! 79 80 INTEGER :: ji, jj, jk, jn ! dummy loop indices … … 105 106 ! ! =========== ! 106 107 DO jn = 1, kjpt ! tracer loop ! 107 ! ! =========== ! 108 ! 108 ! ! =========== ! 109 ! 109 110 DO_3D_10_10( 1, jpkm1 ) 110 111 ztu(ji,jj,jk) = zaheeu(ji,jj,jk) * ( pt(ji+1,jj ,jk,jn) - pt(ji,jj,jk,jn) ) … … 118 119 IF( ln_isfcav ) THEN ! top in ocean cavities only 119 120 DO_2D_10_10 120 IF( miku(ji,jj) > 1 ) ztu(ji,jj,miku(ji,jj)) = zaheeu(ji,jj,miku(ji,jj)) * pgui(ji,jj,jn) 121 IF( mikv(ji,jj) > 1 ) ztv(ji,jj,mikv(ji,jj)) = zaheev(ji,jj,mikv(ji,jj)) * pgvi(ji,jj,jn) 121 IF( miku(ji,jj) > 1 ) ztu(ji,jj,miku(ji,jj)) = zaheeu(ji,jj,miku(ji,jj)) * pgui(ji,jj,jn) 122 IF( mikv(ji,jj) > 1 ) ztv(ji,jj,mikv(ji,jj)) = zaheev(ji,jj,mikv(ji,jj)) * pgvi(ji,jj,jn) 122 123 END_2D 123 124 ENDIF … … 142 143 ! 143 144 END SUBROUTINE tra_ldf_lap 144 145 145 146 146 147 SUBROUTINE tra_ldf_blp( kt, Kmm, kit000, cdtype, pahu, pahv , & … … 149 150 !!---------------------------------------------------------------------- 150 151 !! *** ROUTINE tra_ldf_blp *** 151 !! 152 !! ** Purpose : Compute the before lateral tracer diffusive 152 !! 153 !! ** Purpose : Compute the before lateral tracer diffusive 153 154 !! trend and add it to the general trend of tracer equation. 154 155 !! … … 200 201 ! 201 202 CALL lbc_lnk( 'traldf_lap_blp', zlap(:,:,:,:) , 'T', 1. ) ! Lateral boundary conditions (unchanged sign) 202 ! ! Partial top/bottom cell: GRADh( zlap ) 203 ! ! Partial top/bottom cell: GRADh( zlap ) 203 204 IF( ln_isfcav .AND. ln_zps ) THEN ; CALL zps_hde_isf( kt, Kmm, kjpt, zlap, zglu, zglv, zgui, zgvi ) ! both top & bottom 204 ELSEIF( ln_zps ) THEN ; CALL zps_hde ( kt, Kmm, kjpt, zlap, zglu, zglv ) ! only bottom 205 ELSEIF( ln_zps ) THEN ; CALL zps_hde ( kt, Kmm, kjpt, zlap, zglu, zglv ) ! only bottom 205 206 ENDIF 206 207 ! -
NEMO/branches/2020/dev_r12527_Gurvan_ShallowWater/src/OCE/TRA/traldf_triad.F90
r12489 r13151 41 41 !! * Substitutions 42 42 # include "do_loop_substitute.h90" 43 # include "domzgr_substitute.h90" 43 44 !!---------------------------------------------------------------------- 44 45 !! NEMO/OCE 4.0 , NEMO Consortium (2018) … … 108 109 IF(lwp) WRITE(numout,*) '~~~~~~~~~~~~~' 109 110 ENDIF 110 ! 111 ! 111 112 l_hst = .FALSE. 112 113 l_ptr = .FALSE. … … 120 121 ELSE ; zsign = -1._wp 121 122 ENDIF 122 ! 123 ! 123 124 !!---------------------------------------------------------------------- 124 125 !! 0 - calculate ah_wslp2, akz, and optionally zpsi_uw, zpsi_vw … … 127 128 IF( kpass == 1 ) THEN !== first pass only and whatever the tracer is ==! 128 129 ! 129 akz (:,:,:) = 0._wp 130 akz (:,:,:) = 0._wp 130 131 ah_wslp2(:,:,:) = 0._wp 131 132 IF( ln_ldfeiv_dia ) THEN … … 154 155 END DO 155 156 ! 156 DO jp = 0, 1 ! j-k triads 157 DO jp = 0, 1 ! j-k triads 157 158 DO kp = 0, 1 158 159 DO_3D_10_10( 1, jpkm1 ) … … 179 180 IF( ln_traldf_blp ) THEN ! bilaplacian operator 180 181 DO_3D_10_10( 2, jpkm1 ) 181 akz(ji,jj,jk) = 16._wp * ah_wslp2(ji,jj,jk) & 182 & * ( akz(ji,jj,jk) + ah_wslp2(ji,jj,jk) / ( e3w(ji,jj,jk,Kmm) * e3w(ji,jj,jk,Kmm) ) ) 182 akz(ji,jj,jk) = 16._wp & 183 & * ah_wslp2 (ji,jj,jk) & 184 & * ( akz (ji,jj,jk) & 185 & + ah_wslp2(ji,jj,jk) & 186 & / ( e3w (ji,jj,jk,Kmm) * e3w(ji,jj,jk,Kmm) ) ) 183 187 END_3D 184 188 ELSEIF( ln_traldf_lap ) THEN ! laplacian operator … … 191 195 ! 192 196 ELSE ! 33 flux set to zero with akz=ah_wslp2 ==>> computed in full implicit 193 akz(:,:,:) = ah_wslp2(:,:,:) 197 akz(:,:,:) = ah_wslp2(:,:,:) 194 198 ENDIF 195 199 ! … … 218 222 IF( ln_isfcav ) THEN ! top level (ocean cavities only) 219 223 DO_2D_10_10 220 IF( miku(ji,jj) > 1 ) zdit(ji,jj,miku(ji,jj) ) = pgui(ji,jj,jn) 221 IF( mikv(ji,jj) > 1 ) zdjt(ji,jj,mikv(ji,jj) ) = pgvi(ji,jj,jn) 224 IF( miku(ji,jj) > 1 ) zdit(ji,jj,miku(ji,jj) ) = pgui(ji,jj,jn) 225 IF( mikv(ji,jj) > 1 ) zdjt(ji,jj,mikv(ji,jj) ) = pgvi(ji,jj,jn) 222 226 END_2D 223 227 ENDIF … … 326 330 ! !== horizontal divergence and add to the general trend ==! 327 331 DO_2D_00_00 328 pt_rhs(ji,jj,jk,jn) = pt_rhs(ji,jj,jk,jn) + zsign * ( zftu(ji-1,jj,jk) - zftu(ji,jj,jk) & 329 & + zftv(ji,jj-1,jk) - zftv(ji,jj,jk) ) & 330 & / ( e1e2t(ji,jj) * e3t(ji,jj,jk,Kmm) ) 332 pt_rhs(ji,jj,jk,jn) = pt_rhs(ji,jj,jk,jn) & 333 & + zsign * ( zftu(ji-1,jj ,jk) - zftu(ji,jj,jk) & 334 & + zftv(ji ,jj-1,jk) - zftv(ji,jj,jk) ) & 335 & / ( e1e2t(ji,jj) * e3t(ji,jj,jk,Kmm) ) 331 336 END_2D 332 337 ! … … 340 345 & * ( pt(ji,jj,jk-1,jn) - pt(ji,jj,jk,jn) ) 341 346 END_3D 342 ELSE ! bilaplacian 347 ELSE ! bilaplacian 343 348 SELECT CASE( kpass ) 344 349 CASE( 1 ) ! 1st pass : eddy coef = ah_wslp2 345 350 DO_3D_10_00( 2, jpkm1 ) 346 ztfw(ji,jj,jk) = ztfw(ji,jj,jk) - e1e2t(ji,jj) / e3w(ji,jj,jk,Kmm) * tmask(ji,jj,jk) 351 ztfw(ji,jj,jk) = ztfw(ji,jj,jk) - e1e2t(ji,jj) / e3w(ji,jj,jk,Kmm) * tmask(ji,jj,jk) & 347 352 & * ah_wslp2(ji,jj,jk) * ( pt(ji,jj,jk-1,jn) - pt(ji,jj,jk,jn) ) 348 353 END_3D 349 354 CASE( 2 ) ! 2nd pass : eddy flux = ah_wslp2 and akz applied on pt and pt2 gradients, resp. 350 355 DO_3D_10_00( 2, jpkm1 ) 351 ztfw(ji,jj,jk) = ztfw(ji,jj,jk) - e1e2t(ji,jj) / e3w(ji,jj,jk,Kmm) * tmask(ji,jj,jk) 356 ztfw(ji,jj,jk) = ztfw(ji,jj,jk) - e1e2t(ji,jj) / e3w(ji,jj,jk,Kmm) * tmask(ji,jj,jk) & 352 357 & * ( ah_wslp2(ji,jj,jk) * ( pt (ji,jj,jk-1,jn) - pt (ji,jj,jk,jn) ) & 353 358 & + akz (ji,jj,jk) * ( pt2(ji,jj,jk-1,jn) - pt2(ji,jj,jk,jn) ) ) 354 359 END_3D 355 END SELECT 360 END SELECT 356 361 ENDIF 357 362 ! 358 363 DO_3D_00_00( 1, jpkm1 ) 359 pt_rhs(ji,jj,jk,jn) = pt_rhs(ji,jj,jk,jn) + zsign * ( ztfw(ji,jj,jk+1) - ztfw(ji,jj,jk) ) & 360 & / ( e1e2t(ji,jj) * e3t(ji,jj,jk,Kmm) ) 364 pt_rhs(ji,jj,jk,jn) = pt_rhs(ji,jj,jk,jn) & 365 & + zsign * ( ztfw(ji,jj,jk+1) - ztfw(ji,jj,jk) ) & 366 & / ( e1e2t(ji,jj) * e3t(ji,jj,jk,Kmm) ) 361 367 END_3D 362 368 ! -
NEMO/branches/2020/dev_r12527_Gurvan_ShallowWater/src/OCE/TRA/tramle.F90
r12489 r13151 49 49 !! * Substitutions 50 50 # include "do_loop_substitute.h90" 51 # include "domzgr_substitute.h90" 51 52 !!---------------------------------------------------------------------- 52 53 !! NEMO/OCE 4.0 , NEMO Consortium (2018) -
NEMO/branches/2020/dev_r12527_Gurvan_ShallowWater/src/OCE/TRA/tranpc.F90
r12489 r13151 35 35 !! * Substitutions 36 36 # include "do_loop_substitute.h90" 37 # include "domzgr_substitute.h90" 37 38 !!---------------------------------------------------------------------- 38 39 !! NEMO/OCE 4.0 , NEMO Consortium (2018) … … 71 72 REAL(wp), DIMENSION( jpk ) :: zvn2 ! vertical profile of N2 at 1 given point... 72 73 REAL(wp), DIMENSION( jpk,jpts) :: zvts, zvab ! vertical profile of T & S , and alpha & betaat 1 given point 73 REAL(wp), DIMENSION(jpi,jpj,jpk ) :: zn2 ! N^2 74 REAL(wp), DIMENSION(jpi,jpj,jpk ) :: zn2 ! N^2 74 75 REAL(wp), DIMENSION(jpi,jpj,jpk,jpts) :: zab ! alpha and beta 75 76 REAL(wp), ALLOCATABLE, DIMENSION(:,:,:) :: ztrdt, ztrds ! 3D workspace … … 86 87 IF( l_trdtra ) THEN !* Save initial after fields 87 88 ALLOCATE( ztrdt(jpi,jpj,jpk) , ztrds(jpi,jpj,jpk) ) 88 ztrdt(:,:,:) = pts(:,:,:,jp_tem,Kaa) 89 ztrdt(:,:,:) = pts(:,:,:,jp_tem,Kaa) 89 90 ztrds(:,:,:) = pts(:,:,:,jp_sal,Kaa) 90 91 ENDIF … … 92 93 IF( l_LB_debug ) THEN 93 94 ! Location of 1 known convection site to follow what's happening in the water column 94 ilc1 = 45 ; jlc1 = 3 ; ! ORCA2 4x4, Antarctic coast, more than 2 unstable portions in the water column... 95 ilc1 = 45 ; jlc1 = 3 ; ! ORCA2 4x4, Antarctic coast, more than 2 unstable portions in the water column... 95 96 nncpu = 1 ; ! the CPU domain contains the convection spot 96 klc1 = mbkt(ilc1,jlc1) ! bottom of the ocean for debug point... 97 klc1 = mbkt(ilc1,jlc1) ! bottom of the ocean for debug point... 97 98 ENDIF 98 99 ! … … 105 106 ! 106 107 IF( tmask(ji,jj,2) == 1 ) THEN ! At least 2 ocean points 107 ! ! consider one ocean column 108 ! ! consider one ocean column 108 109 zvts(:,jp_tem) = pts(ji,jj,:,jp_tem,Kaa) ! temperature 109 110 zvts(:,jp_sal) = pts(ji,jj,:,jp_sal,Kaa) ! salinity 110 111 ! 111 zvab(:,jp_tem) = zab(ji,jj,:,jp_tem) ! Alpha 112 zvab(:,jp_sal) = zab(ji,jj,:,jp_sal) ! Beta 113 zvn2(:) = zn2(ji,jj,:) ! N^2 112 zvab(:,jp_tem) = zab(ji,jj,:,jp_tem) ! Alpha 113 zvab(:,jp_sal) = zab(ji,jj,:,jp_sal) ! Beta 114 zvn2(:) = zn2(ji,jj,:) ! N^2 114 115 ! 115 116 IF( l_LB_debug ) THEN !LB debug: … … 117 118 IF( ( ji == ilc1 ).AND.( jj == jlc1 ) ) lp_monitor_point = .TRUE. 118 119 ! writing only if on CPU domain where conv region is: 119 lp_monitor_point = (narea == nncpu).AND.lp_monitor_point 120 lp_monitor_point = (narea == nncpu).AND.lp_monitor_point 120 121 ENDIF !LB debug end 121 122 ! … … 129 130 ! 130 131 jiter = jiter + 1 131 ! 132 ! 132 133 IF( jiter >= 400 ) EXIT 133 134 ! … … 144 145 ilayer = ilayer + 1 ! yet another instable portion of the water column found.... 145 146 ! 146 IF( lp_monitor_point ) THEN 147 IF( lp_monitor_point ) THEN 147 148 WRITE(numout,*) 148 149 IF( ilayer == 1 .AND. jiter == 1 ) THEN ! first time a column is spoted with an instability … … 159 160 ENDIF 160 161 ! 161 IF( jiter == 1 ) inpcc = inpcc + 1 162 IF( jiter == 1 ) inpcc = inpcc + 1 162 163 ! 163 164 IF( lp_monitor_point ) WRITE(numout, *) 'Negative N2 at ikp =',ikp,' for layer #', ilayer … … 184 185 zsum_beta = 0._wp 185 186 zsum_z = 0._wp 186 187 187 188 DO jk = ikup, ikbot ! Inside the instable (and overlying neutral) portion of the column 188 189 ! … … 193 194 zsum_beta = zsum_beta + zvab(jk,jp_sal)*zdz 194 195 zsum_z = zsum_z + zdz 195 ! 196 ! 196 197 IF( jk == ikbot ) EXIT ! avoid array-index overshoot in case ikbot = jpk, cause we're calling jk+1 next line 197 198 !! EXIT when we have reached the last layer that is instable (N2<0) or neutral (N2=0): 198 199 IF( zvn2(jk+1) > zn2_zero ) EXIT 199 200 END DO 200 201 201 202 ikdown = jk ! for the current unstable layer, ikdown is the deepest point with a negative or neutral N2 202 203 IF( ikup == ikdown ) CALL ctl_stop( 'tra_npc : PROBLEM #2') … … 224 225 zvab(jk,jp_sal) = zbeta 225 226 END DO 226 227 227 228 228 229 !! Updating N2 in the relvant portion of the water column 229 230 !! Temperature, Salinity, Alpha and Beta have been homogenized in the unstable portion 230 231 !! => Need to re-compute N2! will use Alpha and Beta! 231 232 232 233 ikup = MAX(2,ikup) ! ikup can never be 1 ! 233 234 ik_low = MIN(ikdown+1,ikbot) ! we must go 1 point deeper than ikdown! 234 235 235 236 DO jk = ikup, ik_low ! we must go 1 point deeper than ikdown! 236 237 … … 252 253 253 254 END DO 254 255 255 256 ikp = MIN(ikdown+1,ikbot) 256 257 257 258 258 259 ENDIF !IF( zvn2(ikp) < 0. ) … … 264 265 265 266 IF( ikp /= ikbot ) CALL ctl_stop( 'tra_npc : PROBLEM #3') 266 267 267 268 ! ******* At this stage ikp == ikbot ! ******* 268 269 269 270 IF( ilayer > 0 ) THEN !! least an unstable layer has been found 270 271 ! -
NEMO/branches/2020/dev_r12527_Gurvan_ShallowWater/src/OCE/TRA/traqsr.F90
r12489 r13151 9 9 !! NEMO 1.0 ! 2002-06 (G. Madec) F90: Free form and module 10 10 !! - ! 2005-11 (G. Madec) zco, zps, sco coordinate 11 !! 3.2 ! 2009-04 (G. Madec & NEMO team) 12 !! 3.6 ! 2012-05 (C. Rousset) store attenuation coef for use in ice model 11 !! 3.2 ! 2009-04 (G. Madec & NEMO team) 12 !! 3.6 ! 2012-05 (C. Rousset) store attenuation coef for use in ice model 13 13 !! 3.6 ! 2015-12 (O. Aumont, J. Jouanno, C. Ethe) use vertical profile of chlorophyll 14 !! 3.7 ! 2015-11 (G. Madec, A. Coward) remove optimisation for fix volume 14 !! 3.7 ! 2015-11 (G. Madec, A. Coward) remove optimisation for fix volume 15 15 !!---------------------------------------------------------------------- 16 16 17 17 !!---------------------------------------------------------------------- 18 !! tra_qsr : temperature trend due to the penetration of solar radiation 19 !! tra_qsr_init : initialization of the qsr penetration 18 !! tra_qsr : temperature trend due to the penetration of solar radiation 19 !! tra_qsr_init : initialization of the qsr penetration 20 20 !!---------------------------------------------------------------------- 21 21 USE oce ! ocean dynamics and active tracers … … 44 44 ! !!* Namelist namtra_qsr: penetrative solar radiation 45 45 LOGICAL , PUBLIC :: ln_traqsr !: light absorption (qsr) flag 46 LOGICAL , PUBLIC :: ln_qsr_rgb !: Red-Green-Blue light absorption flag 46 LOGICAL , PUBLIC :: ln_qsr_rgb !: Red-Green-Blue light absorption flag 47 47 LOGICAL , PUBLIC :: ln_qsr_2bd !: 2 band light absorption flag 48 48 LOGICAL , PUBLIC :: ln_qsr_bio !: bio-model light absorption flag … … 53 53 ! 54 54 INTEGER , PUBLIC :: nksr !: levels below which the light cannot penetrate (depth larger than 391 m) 55 55 56 56 INTEGER, PARAMETER :: np_RGB = 1 ! R-G-B light penetration with constant Chlorophyll 57 57 INTEGER, PARAMETER :: np_RGBc = 2 ! R-G-B light penetration with Chlorophyll data … … 68 68 !! * Substitutions 69 69 # include "do_loop_substitute.h90" 70 # include "domzgr_substitute.h90" 70 71 !!---------------------------------------------------------------------- 71 72 !! NEMO/OCE 4.0 , NEMO Consortium (2018) … … 86 87 !! Considering the 2 wavebands case: 87 88 !! I(k) = Qsr*( rn_abs*EXP(z(k)/rn_si0) + (1.-rn_abs)*EXP(z(k)/rn_si1) ) 88 !! The temperature trend associated with the solar radiation penetration 89 !! The temperature trend associated with the solar radiation penetration 89 90 !! is given by : zta = 1/e3t dk[ I ] / (rho0*Cp) 90 91 !! At the bottom, boudary condition for the radiation is no flux : 91 92 !! all heat which has not been absorbed in the above levels is put 92 93 !! in the last ocean level. 93 !! The computation is only done down to the level where 94 !! I(k) < 1.e-15 W/m2 (i.e. over the top nksr levels) . 94 !! The computation is only done down to the level where 95 !! I(k) < 1.e-15 W/m2 (i.e. over the top nksr levels) . 95 96 !! 96 97 !! ** Action : - update ta with the penetrative solar radiation trend … … 112 113 REAL(wp) :: zz0 , zz1 ! - - 113 114 REAL(wp) :: zCb, zCmax, zze, zpsi, zpsimax, zdelpsi, zCtot, zCze 114 REAL(wp) :: zlogc, zlogc2, zlogc3 115 REAL(wp) :: zlogc, zlogc2, zlogc3 115 116 REAL(wp), ALLOCATABLE, DIMENSION(:,:) :: zekb, zekg, zekr 116 117 REAL(wp), ALLOCATABLE, DIMENSION(:,:,:) :: ze0, ze1, ze2, ze3, zea, ztrdt … … 127 128 ! 128 129 IF( l_trdtra ) THEN ! trends diagnostic: save the input temperature trend 129 ALLOCATE( ztrdt(jpi,jpj,jpk) ) 130 ALLOCATE( ztrdt(jpi,jpj,jpk) ) 130 131 ztrdt(:,:,:) = pts(:,:,:,jp_tem,Krhs) 131 132 ENDIF … … 162 163 ALLOCATE( zekb(jpi,jpj) , zekg(jpi,jpj) , zekr (jpi,jpj) , & 163 164 & ze0 (jpi,jpj,jpk) , ze1 (jpi,jpj,jpk) , ze2 (jpi,jpj,jpk) , & 164 & ze3 (jpi,jpj,jpk) , zea (jpi,jpj,jpk) , zchl3d(jpi,jpj,jpk) ) 165 & ze3 (jpi,jpj,jpk) , zea (jpi,jpj,jpk) , zchl3d(jpi,jpj,jpk) ) 165 166 ! 166 167 IF( nqsr == np_RGBc ) THEN !* Variable Chlorophyll … … 182 183 zpsimax = 0.6 - 0.640 * zlogc + 0.021 * zlogc2 + 0.115 * zlogc3 183 184 zdelpsi = 0.710 + 0.159 * zlogc + 0.021 * zlogc2 184 zCze = 1.12 * (zchl)**0.803 185 zCze = 1.12 * (zchl)**0.803 185 186 ! 186 187 zchl3d(ji,jj,jk) = zCze * ( zCb + zCmax * EXP( -( (zpsi - zpsimax) / zdelpsi )**2 ) ) … … 191 192 ELSE !* constant chrlorophyll 192 193 DO jk = 1, nksr + 1 193 zchl3d(:,:,jk) = 0.05 194 zchl3d(:,:,jk) = 0.05 194 195 ENDDO 195 196 ENDIF … … 230 231 END_3D 231 232 ! 232 DEALLOCATE( zekb , zekg , zekr , ze0 , ze1 , ze2 , ze3 , zea , zchl3d ) 233 DEALLOCATE( zekb , zekg , zekr , ze0 , ze1 , ze2 , ze3 , zea , zchl3d ) 233 234 ! 234 235 CASE( np_2BD ) !== 2-bands fluxes ==! … … 239 240 zc0 = zz0 * EXP( -gdepw(ji,jj,jk ,Kmm)*xsi0r ) + zz1 * EXP( -gdepw(ji,jj,jk ,Kmm)*xsi1r ) 240 241 zc1 = zz0 * EXP( -gdepw(ji,jj,jk+1,Kmm)*xsi0r ) + zz1 * EXP( -gdepw(ji,jj,jk+1,Kmm)*xsi1r ) 241 qsr_hc(ji,jj,jk) = qsr(ji,jj) * ( zc0 * wmask(ji,jj,jk) - zc1 * wmask(ji,jj,jk+1) ) 242 qsr_hc(ji,jj,jk) = qsr(ji,jj) * ( zc0 * wmask(ji,jj,jk) - zc1 * wmask(ji,jj,jk+1) ) 242 243 END_3D 243 244 ! … … 247 248 DO_3D_00_00( 1, nksr ) 248 249 pts(ji,jj,jk,jp_tem,Krhs) = pts(ji,jj,jk,jp_tem,Krhs) & 249 & + z1_2 * ( qsr_hc_b(ji,jj,jk) + qsr_hc(ji,jj,jk) ) / e3t(ji,jj,jk,Kmm) 250 & + z1_2 * ( qsr_hc_b(ji,jj,jk) + qsr_hc(ji,jj,jk) ) & 251 & / e3t(ji,jj,jk,Kmm) 250 252 END_3D 251 253 ! … … 263 265 DO jk = nksr, 1, -1 264 266 zetot(:,:,jk) = zetot(:,:,jk+1) + qsr_hc(:,:,jk) * rho0_rcp 265 END DO 267 END DO 266 268 CALL iom_put( 'qsr3d', zetot ) ! 3D distribution of shortwave Radiation 267 DEALLOCATE( zetot ) 269 DEALLOCATE( zetot ) 268 270 ENDIF 269 271 ! … … 271 273 IF( lwxios ) CALL iom_swap( cwxios_context ) 272 274 CALL iom_rstput( kt, nitrst, numrow, 'qsr_hc_b' , qsr_hc , ldxios = lwxios ) 273 CALL iom_rstput( kt, nitrst, numrow, 'fraqsr_1lev', fraqsr_1lev, ldxios = lwxios ) 275 CALL iom_rstput( kt, nitrst, numrow, 'fraqsr_1lev', fraqsr_1lev, ldxios = lwxios ) 274 276 IF( lwxios ) CALL iom_swap( cxios_context ) 275 277 ENDIF … … 278 280 ztrdt(:,:,:) = pts(:,:,:,jp_tem,Krhs) - ztrdt(:,:,:) 279 281 CALL trd_tra( kt, Kmm, Krhs, 'TRA', jp_tem, jptra_qsr, ztrdt ) 280 DEALLOCATE( ztrdt ) 282 DEALLOCATE( ztrdt ) 281 283 ENDIF 282 284 ! ! print mean trends (used for debugging) … … 297 299 !! from two length scale of penetration (rn_si0,rn_si1) and a ratio 298 300 !! (rn_abs). These parameters are read in the namtra_qsr namelist. The 299 !! default values correspond to clear water (type I in Jerlov' 301 !! default values correspond to clear water (type I in Jerlov' 300 302 !! (1968) classification. 301 303 !! called by tra_qsr at the first timestep (nit000) … … 347 349 & ' 2 bands, 3 RGB bands or bio-model light penetration' ) 348 350 ! 349 IF( ln_qsr_rgb .AND. nn_chldta == 0 ) nqsr = np_RGB 351 IF( ln_qsr_rgb .AND. nn_chldta == 0 ) nqsr = np_RGB 350 352 IF( ln_qsr_rgb .AND. nn_chldta == 1 ) nqsr = np_RGBc 351 353 IF( ln_qsr_2bd ) nqsr = np_2BD … … 357 359 ! 358 360 SELECT CASE( nqsr ) 359 ! 361 ! 360 362 CASE( np_RGB , np_RGBc ) !== Red-Green-Blue light penetration ==! 361 ! 363 ! 362 364 IF(lwp) WRITE(numout,*) ' ==>>> R-G-B light penetration ' 363 365 ! 364 366 CALL trc_oce_rgb( rkrgb ) ! tabulated attenuation coef. 365 ! 367 ! 366 368 nksr = trc_oce_ext_lev( r_si2, 33._wp ) ! level of light extinction 367 369 ! -
NEMO/branches/2020/dev_r12527_Gurvan_ShallowWater/src/OCE/TRA/trasbc.F90
r12489 r13151 9 9 !! 3.3 ! 2010-04 (M. Leclair, G. Madec) Forcing averaged over 2 time steps 10 10 !! - ! 2010-09 (C. Ethe, G. Madec) Merge TRA-TRC 11 !! 3.6 ! 2014-11 (P. Mathiot) isf melting forcing 11 !! 3.6 ! 2014-11 (P. Mathiot) isf melting forcing 12 12 !! 4.1 ! 2019-09 (P. Mathiot) isf moved in traisf 13 13 !!---------------------------------------------------------------------- … … 21 21 USE phycst ! physical constant 22 22 USE eosbn2 ! Equation Of State 23 USE sbcmod ! ln_rnf 24 USE sbcrnf ! River runoff 23 USE sbcmod ! ln_rnf 24 USE sbcrnf ! River runoff 25 25 USE traqsr ! solar radiation penetration 26 26 USE trd_oce ! trends: ocean variables 27 USE trdtra ! trends manager: tracers 28 #if defined key_asminc 27 USE trdtra ! trends manager: tracers 28 #if defined key_asminc 29 29 USE asminc ! Assimilation increment 30 30 #endif … … 43 43 !! * Substitutions 44 44 # include "do_loop_substitute.h90" 45 # include "domzgr_substitute.h90" 45 46 !!---------------------------------------------------------------------- 46 47 !! NEMO/OCE 4.0 , NEMO Consortium (2018) … … 53 54 !!---------------------------------------------------------------------- 54 55 !! *** ROUTINE tra_sbc *** 55 !! 56 !! 56 57 !! ** Purpose : Compute the tracer surface boundary condition trend of 57 58 !! (flux through the interface, concentration/dilution effect) 58 59 !! and add it to the general trend of tracer equations. 59 60 !! 60 !! ** Method : The (air+ice)-sea flux has two components: 61 !! (1) Fext, external forcing (i.e. flux through the (air+ice)-sea interface); 62 !! (2) Fwe , tracer carried with the water that is exchanged with air+ice. 61 !! ** Method : The (air+ice)-sea flux has two components: 62 !! (1) Fext, external forcing (i.e. flux through the (air+ice)-sea interface); 63 !! (2) Fwe , tracer carried with the water that is exchanged with air+ice. 63 64 !! The input forcing fields (emp, rnf, sfx) contain Fext+Fwe, 64 65 !! they are simply added to the tracer trend (ts(Krhs)). … … 68 69 !! concentration/dilution effect associated with water exchanges. 69 70 !! 70 !! ** Action : - Update ts(Krhs) with the surface boundary condition trend 71 !! ** Action : - Update ts(Krhs) with the surface boundary condition trend 71 72 !! - send trends to trdtra module for further diagnostics(l_trdtra=T) 72 73 !!---------------------------------------------------------------------- … … 75 76 REAL(wp), DIMENSION(jpi,jpj,jpk,jpts,jpt), INTENT(inout) :: pts ! active tracers and RHS of tracer equation 76 77 ! 77 INTEGER :: ji, jj, jk, jn ! dummy loop indices 78 INTEGER :: ji, jj, jk, jn ! dummy loop indices 78 79 INTEGER :: ikt, ikb ! local integers 79 80 REAL(wp) :: zfact, z1_e3t, zdep, ztim ! local scalar … … 90 91 ! 91 92 IF( l_trdtra ) THEN !* Save ta and sa trends 92 ALLOCATE( ztrdt(jpi,jpj,jpk) , ztrds(jpi,jpj,jpk) ) 93 ALLOCATE( ztrdt(jpi,jpj,jpk) , ztrds(jpi,jpj,jpk) ) 93 94 ztrdt(:,:,:) = pts(:,:,:,jp_tem,Krhs) 94 95 ztrds(:,:,:) = pts(:,:,:,jp_sal,Krhs) … … 127 128 sbc_tsc(ji,jj,jp_sal) = r1_rho0 * sfx(ji,jj) ! salt flux due to freezing/melting 128 129 END_2D 129 IF( ln_linssh ) THEN !* linear free surface 130 IF( ln_linssh ) THEN !* linear free surface 130 131 DO_2D_01_00 131 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) … … 138 139 DO jn = 1, jpts !== update tracer trend ==! 139 140 DO_2D_01_00 140 pts(ji,jj,1,jn,Krhs) = pts(ji,jj,1,jn,Krhs) + zfact * ( sbc_tsc_b(ji,jj,jn) + sbc_tsc(ji,jj,jn) ) / e3t(ji,jj,1,Kmm) 141 pts(ji,jj,1,jn,Krhs) = pts(ji,jj,1,jn,Krhs) + zfact * ( sbc_tsc_b(ji,jj,jn) + sbc_tsc(ji,jj,jn) ) & 142 & / e3t(ji,jj,1,Kmm) 141 143 END_2D 142 144 END DO 143 ! 145 ! 144 146 IF( lrst_oce ) THEN !== write sbc_tsc in the ocean restart file ==! 145 147 IF( lwxios ) CALL iom_swap( cwxios_context ) … … 153 155 !---------------------------------------- 154 156 ! 155 IF( ln_rnf ) THEN ! input of heat and salt due to river runoff 157 IF( ln_rnf ) THEN ! input of heat and salt due to river runoff 156 158 zfact = 0.5_wp 157 159 DO_2D_01_00 … … 162 164 & + ( rnf_tsc_b(ji,jj,jp_tem) + rnf_tsc(ji,jj,jp_tem) ) * zdep 163 165 IF( ln_rnf_sal ) pts(ji,jj,jk,jp_sal,Krhs) = pts(ji,jj,jk,jp_sal,Krhs) & 164 & + ( rnf_tsc_b(ji,jj,jp_sal) + rnf_tsc(ji,jj,jp_sal) ) * zdep 166 & + ( rnf_tsc_b(ji,jj,jp_sal) + rnf_tsc(ji,jj,jp_sal) ) * zdep 165 167 END DO 166 168 ENDIF … … 179 181 IF( ln_sshinc ) THEN ! input of heat and salt due to assimilation 180 182 ! 181 IF( ln_linssh ) THEN 183 IF( ln_linssh ) THEN 182 184 DO_2D_01_00 183 185 ztim = ssh_iau(ji,jj) / e3t(ji,jj,1,Kmm) … … 202 204 CALL trd_tra( kt, Kmm, Krhs, 'TRA', jp_tem, jptra_nsr, ztrdt ) 203 205 CALL trd_tra( kt, Kmm, Krhs, 'TRA', jp_sal, jptra_nsr, ztrds ) 204 DEALLOCATE( ztrdt , ztrds ) 206 DEALLOCATE( ztrdt , ztrds ) 205 207 ENDIF 206 208 ! -
NEMO/branches/2020/dev_r12527_Gurvan_ShallowWater/src/OCE/TRA/trazdf.F90
r12489 r13151 13 13 !!---------------------------------------------------------------------- 14 14 USE oce ! ocean dynamics and tracers variables 15 USE dom_oce ! ocean space and time domain variables 15 USE dom_oce ! ocean space and time domain variables 16 16 USE domvvl ! variable volume 17 17 USE phycst ! physical constant … … 19 19 USE sbc_oce ! surface boundary condition: ocean 20 20 USE ldftra ! lateral diffusion: eddy diffusivity 21 USE ldfslp ! lateral diffusion: iso-neutral slope 21 USE ldfslp ! lateral diffusion: iso-neutral slope 22 22 USE trd_oce ! trends: ocean variables 23 23 USE trdtra ! trends: tracer trend manager … … 37 37 !! * Substitutions 38 38 # include "do_loop_substitute.h90" 39 # include "domzgr_substitute.h90" 39 40 !!---------------------------------------------------------------------- 40 41 !! NEMO/OCE 4.0 , NEMO Consortium (2018) … … 84 85 IF( l_trdtra ) THEN ! save the vertical diffusive trends for further diagnostics 85 86 DO jk = 1, jpkm1 86 ztrdt(:,:,jk) = ( ( pts(:,:,jk,jp_tem,Kaa)*e3t(:,:,jk,Kaa) - pts(:,:,jk,jp_tem,Kbb)*e3t(:,:,jk,Kbb) ) & 87 & / (e3t(:,:,jk,Kmm)*rDt) ) - ztrdt(:,:,jk) 88 ztrds(:,:,jk) = ( ( pts(:,:,jk,jp_sal,Kaa)*e3t(:,:,jk,Kaa) - pts(:,:,jk,jp_sal,Kbb)*e3t(:,:,jk,Kbb) ) & 89 & / (e3t(:,:,jk,Kmm)*rDt) ) - ztrds(:,:,jk) 87 ztrdt(:,:,jk) = ( ( pts(:,:,jk,jp_tem,Kaa)*e3t(:,:,jk,Kaa) & 88 & - pts(:,:,jk,jp_tem,Kbb)*e3t(:,:,jk,Kbb) ) & 89 & / ( e3t(:,:,jk,Kmm)*rDt ) ) & 90 & - ztrdt(:,:,jk) 91 ztrds(:,:,jk) = ( ( pts(:,:,jk,jp_sal,Kaa)*e3t(:,:,jk,Kaa) & 92 & - pts(:,:,jk,jp_sal,Kbb)*e3t(:,:,jk,Kbb) ) & 93 & / ( e3t(:,:,jk,Kmm)*rDt ) ) & 94 & - ztrds(:,:,jk) 90 95 END DO 91 96 !!gm this should be moved in trdtra.F90 and done on all trends … … 104 109 END SUBROUTINE tra_zdf 105 110 106 107 SUBROUTINE tra_zdf_imp( kt, kit000, cdtype, p2dt, Kbb, Kmm, Krhs, pt, Kaa, kjpt ) 111 112 SUBROUTINE tra_zdf_imp( kt, kit000, cdtype, p2dt, Kbb, Kmm, Krhs, pt, Kaa, kjpt ) 108 113 !!---------------------------------------------------------------------- 109 114 !! *** ROUTINE tra_zdf_imp *** 110 115 !! 111 116 !! ** Purpose : Compute the after tracer through a implicit computation 112 !! of the vertical tracer diffusion (including the vertical component 113 !! of lateral mixing (only for 2nd order operator, for fourth order 114 !! it is already computed and add to the general trend in traldf) 117 !! of the vertical tracer diffusion (including the vertical component 118 !! of lateral mixing (only for 2nd order operator, for fourth order 119 !! it is already computed and add to the general trend in traldf) 115 120 !! 116 121 !! ** Method : The vertical diffusion of a tracer ,t , is given by: … … 154 159 zwt(:,:,1) = 0._wp 155 160 ! 156 IF( l_ldfslp ) THEN ! isoneutral diffusion: add the contribution 157 IF( ln_traldf_msc ) THEN ! MSC iso-neutral operator 161 IF( l_ldfslp ) THEN ! isoneutral diffusion: add the contribution 162 IF( ln_traldf_msc ) THEN ! MSC iso-neutral operator 158 163 DO_3D_00_00( 2, jpkm1 ) 159 zwt(ji,jj,jk) = zwt(ji,jj,jk) + akz(ji,jj,jk) 164 zwt(ji,jj,jk) = zwt(ji,jj,jk) + akz(ji,jj,jk) 160 165 END_3D 161 166 ELSE ! standard or triad iso-neutral operator … … 200 205 ! The solution will be in the 4d array pta. 201 206 ! The 3d array zwt is used as a work space array. 202 ! En route to the solution pt(:,:,:,:,Kaa) is used a to evaluate the rhs and then 207 ! En route to the solution pt(:,:,:,:,Kaa) is used a to evaluate the rhs and then 203 208 ! used as a work space array: its value is modified. 204 209 ! … … 210 215 END_3D 211 216 ! 212 ENDIF 213 ! 217 ENDIF 218 ! 214 219 DO_2D_00_00 215 pt(ji,jj,1,jn,Kaa) = e3t(ji,jj,1,Kbb) * pt(ji,jj,1,jn,Kbb) + p2dt * e3t(ji,jj,1,Kmm) * pt(ji,jj,1,jn,Krhs) 220 pt(ji,jj,1,jn,Kaa) = e3t(ji,jj,1,Kbb) * pt(ji,jj,1,jn,Kbb) & 221 & + p2dt * e3t(ji,jj,1,Kmm) * pt(ji,jj,1,jn,Krhs) 216 222 END_2D 217 223 DO_3D_00_00( 2, jpkm1 ) 218 zrhs = e3t(ji,jj,jk,Kbb) * pt(ji,jj,jk,jn,Kbb) + p2dt * e3t(ji,jj,jk,Kmm) * pt(ji,jj,jk,jn,Krhs) ! zrhs=right hand side 224 zrhs = e3t(ji,jj,jk,Kbb) * pt(ji,jj,jk,jn,Kbb) & 225 & + p2dt * e3t(ji,jj,jk,Kmm) * pt(ji,jj,jk,jn,Krhs) ! zrhs=right hand side 219 226 pt(ji,jj,jk,jn,Kaa) = zrhs - zwi(ji,jj,jk) / zwt(ji,jj,jk-1) * pt(ji,jj,jk-1,jn,Kaa) 220 227 END_3D -
NEMO/branches/2020/dev_r12527_Gurvan_ShallowWater/src/OCE/TRA/zpshde.F90
r12377 r13151 32 32 !! * Substitutions 33 33 # include "do_loop_substitute.h90" 34 # include "domzgr_substitute.h90" 34 35 !!---------------------------------------------------------------------- 35 36 !! NEMO/OCE 4.0 , NEMO Consortium (2018) … … 65 66 !! ___ | | | ___ | | | 66 67 !! 67 !! case 1-> e3w(i+1 ) >= e3w(i) ( and e3w(j+1) >= e3w(j) ) then68 !! t~ = t(i+1,j ,k) + (e3w(i+1 ) - e3w(i)) * dk(Ti+1)/e3w(i+1)69 !! ( t~ = t(i ,j+1,k) + (e3w( j+1) - e3w(j)) * dk(Tj+1)/e3w(j+1) )68 !! case 1-> e3w(i+1,:,:,Kmm) >= e3w(i,:,:,Kmm) ( and e3w(:,j+1,:,Kmm) >= e3w(:,j,:,Kmm) ) then 69 !! t~ = t(i+1,j ,k) + (e3w(i+1,j,k,Kmm) - e3w(i,j,k,Kmm)) * dk(Ti+1)/e3w(i+1,j,k,Kmm) 70 !! ( t~ = t(i ,j+1,k) + (e3w(i,j+1,k,Kmm) - e3w(i,j,k,Kmm)) * dk(Tj+1)/e3w(i,j+1,k,Kmm) ) 70 71 !! or 71 !! case 2-> e3w(i+1 ) <= e3w(i) ( and e3w(j+1) <= e3w(j) ) then72 !! t~ = t(i,j,k) + (e3w(i ) - e3w(i+1)) * dk(Ti)/e3w(i)73 !! ( t~ = t(i,j,k) + (e3w( j) - e3w(j+1)) * dk(Tj)/e3w(j) )72 !! case 2-> e3w(i+1,:,:,Kmm) <= e3w(i,:,:,Kmm) ( and e3w(:,j+1,:,Kmm) <= e3w(:,j,:,Kmm) ) then 73 !! t~ = t(i,j,k) + (e3w(i,j,k,Kmm) - e3w(i+1,j,k,Kmm)) * dk(Ti)/e3w(i,j,k,Kmm) 74 !! ( t~ = t(i,j,k) + (e3w(i,j,k,Kmm) - e3w(i,j+1,k,Kmm)) * dk(Tj)/e3w(i,j,k,Kmm) ) 74 75 !! Idem for di(s) and dj(s) 75 76 !! … … 109 110 iku = mbku(ji,jj) ; ikum1 = MAX( iku - 1 , 1 ) ! last and before last ocean level at u- & v-points 110 111 ikv = mbkv(ji,jj) ; ikvm1 = MAX( ikv - 1 , 1 ) ! if level first is a p-step, ik.m1=1 111 !!gm BUG ? when applied to before fields, e3w(:,:, :,Kbb) should be used....112 !!gm BUG ? when applied to before fields, e3w(:,:,k,Kbb) should be used.... 112 113 ze3wu = e3w(ji+1,jj ,iku,Kmm) - e3w(ji,jj,iku,Kmm) 113 114 ze3wv = e3w(ji ,jj+1,ikv,Kmm) - e3w(ji,jj,ikv,Kmm) … … 214 215 !! ___ | | | ___ | | | 215 216 !! 216 !! case 1-> e3w(i+1 ) >= e3w(i) ( and e3w(j+1) >= e3w(j) ) then217 !! t~ = t(i+1,j ,k) + (e3w(i+1 ) - e3w(i)) * dk(Ti+1)/e3w(i+1)218 !! ( t~ = t(i ,j+1,k) + (e3w( j+1) - e3w(j)) * dk(Tj+1)/e3w(j+1) )217 !! case 1-> e3w(i+1,j,k,Kmm) >= e3w(i,j,k,Kmm) ( and e3w(i,j+1,k,Kmm) >= e3w(i,j,k,Kmm) ) then 218 !! t~ = t(i+1,j ,k) + (e3w(i+1,j ,k,Kmm) - e3w(i,j,k,Kmm)) * dk(Ti+1)/e3w(i+1,j ,k,Kmm) 219 !! ( t~ = t(i ,j+1,k) + (e3w(i ,j+1,k,Kmm) - e3w(i,j,k,Kmm)) * dk(Tj+1)/e3w(i ,j+1,k,Kmm) ) 219 220 !! or 220 !! case 2-> e3w(i+1 ) <= e3w(i) ( and e3w(j+1) <= e3w(j) ) then221 !! t~ = t(i,j,k) + (e3w(i ) - e3w(i+1)) * dk(Ti)/e3w(i)222 !! ( t~ = t(i,j,k) + (e3w( j) - e3w(j+1)) * dk(Tj)/e3w(j) )221 !! case 2-> e3w(i+1,j,k,Kmm) <= e3w(i,j,k,Kmm) ( and e3w(i,j+1,k,Kmm) <= e3w(i,j,k,Kmm) ) then 222 !! t~ = t(i,j,k) + (e3w(i,j,k,Kmm) - e3w(i+1,j ,k,Kmm)) * dk(Ti)/e3w(i,j,k,Kmm) 223 !! ( t~ = t(i,j,k) + (e3w(i,j,k,Kmm) - e3w(i ,j+1,k,Kmm)) * dk(Tj)/e3w(i,j,k,Kmm) ) 223 224 !! Idem for di(s) and dj(s) 224 225 !! … … 356 357 ! (ISF) case partial step top and bottom in adjacent cell in vertical 357 358 ! cannot used e3w because if 2 cell water column, we have ps at top and bottom 358 ! in this case e3w(i,j ) - e3w(i,j+1) is not the distance between Tj~ and Tj359 ! in this case e3w(i,j,k,Kmm) - e3w(i,j+1,k,Kmm) is not the distance between Tj~ and Tj 359 360 ! the only common depth between cells (i,j) and (i,j+1) is gdepw_0 360 361 ze3wu = gdept(ji,jj,iku,Kmm) - gdept(ji+1,jj,iku,Kmm) -
NEMO/branches/2020/dev_r12527_Gurvan_ShallowWater/src/OCE/TRD/trddyn.F90
r12489 r13151 37 37 !! * Substitutions 38 38 # include "do_loop_substitute.h90" 39 # include "domzgr_substitute.h90" 39 40 !!---------------------------------------------------------------------- 40 41 !! NEMO/OCE 4.0 , NEMO Consortium (2018) -
NEMO/branches/2020/dev_r12527_Gurvan_ShallowWater/src/OCE/TRD/trdglo.F90
r12489 r13151 52 52 !! * Substitutions 53 53 # include "do_loop_substitute.h90" 54 # include "domzgr_substitute.h90" 54 55 !!---------------------------------------------------------------------- 55 56 !! NEMO/OCE 4.0 , NEMO Consortium (2018) … … 116 117 DO_3D_10_10( 1, jpkm1 ) 117 118 zvt = ptrdx(ji,jj,jk) * tmask_i(ji+1,jj) * tmask_i(ji,jj) * umask(ji,jj,jk) & 118 & * e1e2u (ji,jj) * e3u(ji,jj,jk,Kmm)119 & * e1e2u (ji ,jj) * e3u(ji,jj,jk,Kmm) 119 120 zvs = ptrdy(ji,jj,jk) * tmask_i(ji,jj+1) * tmask_i(ji,jj) * vmask(ji,jj,jk) & 120 & * e1e2v (ji,jj) * e3u(ji,jj,jk,Kmm)121 & * e1e2v (ji,jj ) * e3u(ji,jj,jk,Kmm) 121 122 umo(ktrd) = umo(ktrd) + zvt 122 123 vmo(ktrd) = vmo(ktrd) + zvs … … 211 212 zcof = 0.5_wp / rho0 ! Density flux at u and v-points 212 213 DO_3D_10_10( 1, jpkm1 ) 213 zkx(ji,jj,jk) = zcof * e2u(ji,jj) * e3u(ji,jj,jk,Kmm) * uu(ji,jj,jk,Kmm) * ( rhop(ji,jj,jk) + rhop(ji+1,jj,jk) ) 214 zky(ji,jj,jk) = zcof * e1v(ji,jj) * e3v(ji,jj,jk,Kmm) * vv(ji,jj,jk,Kmm) * ( rhop(ji,jj,jk) + rhop(ji,jj+1,jk) ) 214 zkx(ji,jj,jk) = zcof * e2u(ji,jj) * e3u(ji,jj,jk,Kmm) & 215 & * uu(ji,jj,jk,Kmm) * ( rhop(ji,jj,jk) + rhop(ji+1,jj,jk) ) 216 zky(ji,jj,jk) = zcof * e1v(ji,jj) * e3v(ji,jj,jk,Kmm) & 217 & * vv(ji,jj,jk,Kmm) * ( rhop(ji,jj,jk) + rhop(ji,jj+1,jk) ) 215 218 END_3D 216 219 … … 219 222 & + zkx(ji,jj,jk) - zkx(ji-1,jj ,jk ) & 220 223 & + zky(ji,jj,jk) - zky(ji ,jj-1,jk ) ) & 221 & 224 & / ( e1e2t(ji,jj) * e3t(ji,jj,jk,Kmm) ) * tmask(ji,jj,jk) * tmask_i(ji,jj) 222 225 END_3D 223 226 … … 226 229 peke = 0._wp 227 230 DO jk = 1, jpkm1 228 peke = peke + SUM( zkepe(:,:,jk) * gdept(:,:,jk,Kmm) * e1e2t(:,:) * e3t(:,:,jk,Kmm) ) 231 peke = peke + SUM( zkepe(:,:,jk) * gdept(:,:,jk,Kmm) * e1e2t(:,:) & 232 & * e3t(:,:,jk,Kmm) ) 229 233 END DO 230 234 peke = grav * peke … … 524 528 525 529 DO_3D_00_00( 1, jpk ) 526 tvolu = tvolu + e1u(ji,jj) * e2u(ji,jj) * e3u(ji,jj,jk,Kmm) * tmask_i(ji+1,jj ) * tmask_i(ji,jj) * umask(ji,jj,jk) 527 tvolv = tvolv + e1v(ji,jj) * e2v(ji,jj) * e3v(ji,jj,jk,Kmm) * tmask_i(ji ,jj+1) * tmask_i(ji,jj) * vmask(ji,jj,jk) 530 tvolu = tvolu + e1u(ji,jj) * e2u(ji,jj) * e3u(ji,jj,jk,Kmm) & 531 & * tmask_i(ji+1,jj ) * tmask_i(ji,jj) * umask(ji,jj,jk) 532 tvolv = tvolv + e1v(ji,jj) * e2v(ji,jj) * e3v(ji,jj,jk,Kmm) & 533 & * tmask_i(ji ,jj+1) * tmask_i(ji,jj) * vmask(ji,jj,jk) 528 534 END_3D 529 535 CALL mpp_sum( 'trdglo', tvolu ) ! sums over the global domain -
NEMO/branches/2020/dev_r12527_Gurvan_ShallowWater/src/OCE/TRD/trdken.F90
r12489 r13151 41 41 !! * Substitutions 42 42 # include "do_loop_substitute.h90" 43 # include "domzgr_substitute.h90" 43 44 !!---------------------------------------------------------------------- 44 45 !! NEMO/OCE 4.0 , NEMO Consortium (2018) -
NEMO/branches/2020/dev_r12527_Gurvan_ShallowWater/src/OCE/TRD/trdmxl.F90
r12377 r13151 70 70 !! * Substitutions 71 71 # include "do_loop_substitute.h90" 72 # include "domzgr_substitute.h90" 72 73 !!---------------------------------------------------------------------- 73 74 !! NEMO/OCE 4.0 , NEMO Consortium (2018) … … 120 121 wkx(:,:,:) = 0._wp !== now ML weights for vertical averaging ==! 121 122 DO_3D_11_11( 1, jpktrd ) 122 IF( jk - kmxln(ji,jj) < 0 ) wkx(ji,jj,jk) = e3t(ji,jj,jk,Kmm) * tmask(ji,jj,jk) 123 IF( jk - kmxln(ji,jj) < 0 ) THEN 124 wkx(ji,jj,jk) = e3t(ji,jj,jk,Kmm) * tmask(ji,jj,jk) 125 ENDIF 123 126 END_3D 124 127 hmxl(:,:) = 0._wp ! NOW mixed-layer depth -
NEMO/branches/2020/dev_r12527_Gurvan_ShallowWater/src/OCE/TRD/trdpen.F90
r12377 r13151 35 35 REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:,:,:) :: rab_pe ! partial derivatives of PE anomaly with respect to T and S 36 36 37 !! * Substitutions 38 # include "domzgr_substitute.h90" 37 39 !!---------------------------------------------------------------------- 38 40 !! NEMO/OCE 4.0 , NEMO Consortium (2018) … … 40 42 !! Software governed by the CeCILL license (see ./LICENSE) 41 43 !!---------------------------------------------------------------------- 44 42 45 CONTAINS 43 46 -
NEMO/branches/2020/dev_r12527_Gurvan_ShallowWater/src/OCE/TRD/trdtra.F90
r12489 r13151 42 42 !! * Substitutions 43 43 # include "do_loop_substitute.h90" 44 # include "domzgr_substitute.h90" 44 45 !!---------------------------------------------------------------------- 45 46 !! NEMO/OCE 4.0 , NEMO Consortium (2018) … … 128 129 zwt(:,:,jpk) = 0._wp ; zws(:,:,jpk) = 0._wp 129 130 DO jk = 2, jpk 130 zwt(:,:,jk) = avt(:,:,jk) * ( ts(:,:,jk-1,jp_tem,Krhs) - ts(:,:,jk,jp_tem,Krhs) ) / e3w(:,:,jk,Kmm) * tmask(:,:,jk) 131 zws(:,:,jk) = avs(:,:,jk) * ( ts(:,:,jk-1,jp_sal,Krhs) - ts(:,:,jk,jp_sal,Krhs) ) / e3w(:,:,jk,Kmm) * tmask(:,:,jk) 131 zwt(:,:,jk) = avt(:,:,jk) * ( ts(:,:,jk-1,jp_tem,Krhs) - ts(:,:,jk,jp_tem,Krhs) ) & 132 & / e3w(:,:,jk,Kmm) * tmask(:,:,jk) 133 zws(:,:,jk) = avs(:,:,jk) * ( ts(:,:,jk-1,jp_sal,Krhs) - ts(:,:,jk,jp_sal,Krhs) ) & 134 & / e3w(:,:,jk,Kmm) * tmask(:,:,jk) 132 135 END DO 133 136 ! … … 142 145 zwt(:,:,:) = 0._wp ; zws(:,:,:) = 0._wp ! vertical diffusive fluxes 143 146 DO jk = 2, jpk 144 zwt(:,:,jk) = avt_evd(:,:,jk) * ( ts(:,:,jk-1,jp_tem,Krhs) - ts(:,:,jk,jp_tem,Krhs) ) / e3w(:,:,jk,Kmm) * tmask(:,:,jk) 145 zws(:,:,jk) = avt_evd(:,:,jk) * ( ts(:,:,jk-1,jp_sal,Krhs) - ts(:,:,jk,jp_sal,Krhs) ) / e3w(:,:,jk,Kmm) * tmask(:,:,jk) 147 zwt(:,:,jk) = avt_evd(:,:,jk) * ( ts(:,:,jk-1,jp_tem,Krhs) - ts(:,:,jk,jp_tem,Krhs) ) & 148 & / e3w(:,:,jk,Kmm) * tmask(:,:,jk) 149 zws(:,:,jk) = avt_evd(:,:,jk) * ( ts(:,:,jk-1,jp_sal,Krhs) - ts(:,:,jk,jp_sal,Krhs) ) & 150 & / e3w(:,:,jk,Kmm) * tmask(:,:,jk) 146 151 END DO 147 152 ! -
NEMO/branches/2020/dev_r12527_Gurvan_ShallowWater/src/OCE/TRD/trdvor.F90
r12489 r13151 57 57 !! * Substitutions 58 58 # include "do_loop_substitute.h90" 59 # include "domzgr_substitute.h90" 59 60 !!---------------------------------------------------------------------- 60 61 !! NEMO/OCE 4.0 , NEMO Consortium (2018) … … 192 193 DO jj = 1, jpjm1 193 194 vortrd(ji,jj,ktrd) = ( zvdpvor(ji+1,jj) - zvdpvor(ji,jj) & 194 & - ( zudpvor(ji,jj+1) - zudpvor(ji,jj) ) ) / ( e1f(ji,jj) * e2f(ji,jj) ) 195 & - ( zudpvor(ji,jj+1) - zudpvor(ji,jj) ) ) & 196 & / ( e1f(ji,jj) * e2f(ji,jj) ) 195 197 END DO 196 198 END DO … … 268 270 DO jj = 1, jpjm1 269 271 vortrd(ji,jj,jpvor_bev) = ( zvbet(ji+1,jj) - zvbet(ji,jj) & 270 & - ( zubet(ji,jj+1) - zubet(ji,jj) ) ) / ( e1f(ji,jj) * e2f(ji,jj) ) 272 & - ( zubet(ji,jj+1) - zubet(ji,jj) ) ) & 273 & / ( e1f(ji,jj) * e2f(ji,jj) ) 271 274 END DO 272 275 END DO … … 283 286 DO jj=1,jpjm1 284 287 vortrd(ji,jj,ktrd) = ( zvdpvor(ji+1,jj) - zvdpvor(ji,jj) & 285 & - ( zudpvor(ji,jj+1) - zudpvor(ji,jj) ) ) / ( e1f(ji,jj) * e2f(ji,jj) ) 288 & - ( zudpvor(ji,jj+1) - zudpvor(ji,jj) ) ) & 289 & / ( e1f(ji,jj) * e2f(ji,jj) ) 286 290 END DO 287 291 END DO … … 345 349 DO jj = 1, jpjm1 346 350 vor_avr(ji,jj) = ( ( zvv(ji+1,jj) - zvv(ji,jj) ) & 347 & - ( zuu(ji,jj+1) - zuu(ji,jj) ) ) / ( e1f(ji,jj) * e2f(ji,jj) ) * fmask(ji,jj,1) 351 & - ( zuu(ji,jj+1) - zuu(ji,jj) ) ) & 352 & / ( e1f(ji,jj) * e2f(ji,jj) ) * fmask(ji,jj,1) 348 353 END DO 349 354 END DO -
NEMO/branches/2020/dev_r12527_Gurvan_ShallowWater/src/OCE/ZDF/zdfddm.F90
r12377 r13151 94 94 DO_2D_11_11 95 95 zrw = ( gdepw(ji,jj,jk ,Kmm) - gdept(ji,jj,jk,Kmm) ) & 96 !!gm please, use e3w (:,:,:,Kmm)below96 !!gm please, use e3w at Kmm below 97 97 & / ( gdept(ji,jj,jk-1,Kmm) - gdept(ji,jj,jk,Kmm) ) 98 98 ! -
NEMO/branches/2020/dev_r12527_Gurvan_ShallowWater/src/OCE/ZDF/zdfdrg.F90
r12489 r13151 74 74 !! * Substitutions 75 75 # include "do_loop_substitute.h90" 76 # include "domzgr_substitute.h90" 76 77 !!---------------------------------------------------------------------- 77 78 !! NEMO/OCE 4.0 , NEMO Consortium (2018) -
NEMO/branches/2020/dev_r12527_Gurvan_ShallowWater/src/OCE/ZDF/zdfgls.F90
r12489 r13151 105 105 !! * Substitutions 106 106 # include "do_loop_substitute.h90" 107 # include "domzgr_substitute.h90" 107 108 !!---------------------------------------------------------------------- 108 109 !! NEMO/OCE 4.0 , NEMO Consortium (2018) … … 263 264 zcof = rfact_tke * tmask(ji,jj,jk) 264 265 ! ! lower diagonal, in fact not used for jk = 2 (see surface conditions) 265 zd_lw(ji,jj,jk) = zcof * ( p_avm(ji,jj,jk ) + p_avm(ji,jj,jk-1) ) / ( e3t(ji,jj,jk-1,Kmm) * e3w(ji,jj,jk,Kmm) ) 266 zd_lw(ji,jj,jk) = zcof * ( p_avm(ji,jj,jk ) + p_avm(ji,jj,jk-1) ) & 267 & / ( e3t(ji,jj,jk-1,Kmm) * e3w(ji,jj,jk,Kmm) ) 266 268 ! ! upper diagonal, in fact not used for jk = ibotm1 (see bottom conditions) 267 zd_up(ji,jj,jk) = zcof * ( p_avm(ji,jj,jk+1) + p_avm(ji,jj,jk ) ) / ( e3t(ji,jj,jk ,Kmm) * e3w(ji,jj,jk,Kmm) ) 269 zd_up(ji,jj,jk) = zcof * ( p_avm(ji,jj,jk+1) + p_avm(ji,jj,jk ) ) & 270 & / ( e3t(ji,jj,jk ,Kmm) * e3w(ji,jj,jk,Kmm) ) 268 271 ! ! diagonal 269 272 zdiag(ji,jj,jk) = 1._wp - zd_lw(ji,jj,jk) - zd_up(ji,jj,jk) + rn_Dt * zdiss * wmask(ji,jj,jk) … … 473 476 zcof = rfact_psi * zwall_psi(ji,jj,jk) * tmask(ji,jj,jk) 474 477 ! ! lower diagonal 475 zd_lw(ji,jj,jk) = zcof * ( p_avm(ji,jj,jk ) + p_avm(ji,jj,jk-1) ) / ( e3t(ji,jj,jk-1,Kmm) * e3w(ji,jj,jk,Kmm) ) 478 zd_lw(ji,jj,jk) = zcof * ( p_avm(ji,jj,jk ) + p_avm(ji,jj,jk-1) ) & 479 & / ( e3t(ji,jj,jk-1,Kmm) * e3w(ji,jj,jk,Kmm) ) 476 480 ! ! upper diagonal 477 zd_up(ji,jj,jk) = zcof * ( p_avm(ji,jj,jk+1) + p_avm(ji,jj,jk ) ) / ( e3t(ji,jj,jk ,Kmm) * e3w(ji,jj,jk,Kmm) ) 481 zd_up(ji,jj,jk) = zcof * ( p_avm(ji,jj,jk+1) + p_avm(ji,jj,jk ) ) & 482 & / ( e3t(ji,jj,jk ,Kmm) * e3w(ji,jj,jk,Kmm) ) 478 483 ! ! diagonal 479 484 zdiag(ji,jj,jk) = 1._wp - zd_lw(ji,jj,jk) - zd_up(ji,jj,jk) + rn_Dt * zdiss * wmask(ji,jj,jk) … … 1100 1105 !!====================================================================== 1101 1106 END MODULE zdfgls 1102 -
NEMO/branches/2020/dev_r12527_Gurvan_ShallowWater/src/OCE/ZDF/zdfiwm.F90
r12510 r13151 51 51 !! * Substitutions 52 52 # include "do_loop_substitute.h90" 53 # include "domzgr_substitute.h90" 53 54 !!---------------------------------------------------------------------- 54 55 !! NEMO/OCE 4.0 , NEMO Consortium (2018) … … 94 95 !! 2. Pycnocline-intensified low-mode dissipation 95 96 !! zemx_iwm(z) = ( epyc_iwm / rho0 ) * ( sqrt(rn2(z))^nn_zpyc ) 96 !! / SUM( sqrt(rn2(z))^nn_zpyc * e3w (z))97 !! / SUM( sqrt(rn2(z))^nn_zpyc * e3w[z] ) 97 98 !! where epyc_iwm is a map of available power, and nn_zpyc 98 99 !! is the chosen stratification-dependence of the internal wave … … 100 101 !! 3. WKB-height dependent high mode dissipation 101 102 !! zemx_iwm(z) = ( ebot_iwm / rho0 ) * rn2(z) * EXP(-z_wkb(z)/hbot_iwm) 102 !! / SUM( rn2(z) * EXP(-z_wkb(z)/hbot_iwm) * e3w (z))103 !! / SUM( rn2(z) * EXP(-z_wkb(z)/hbot_iwm) * e3w[z] ) 103 104 !! where hbot_iwm is the characteristic length scale of the WKB bottom 104 105 !! intensification, ebot_iwm is a map of available power, and z_wkb is the 105 106 !! WKB-stretched height above bottom defined as 106 !! z_wkb(z) = H * SUM( sqrt(rn2(z'>=z)) * e3w (z'>=z) )107 !! / SUM( sqrt(rn2(z')) * e3w (z') )107 !! z_wkb(z) = H * SUM( sqrt(rn2(z'>=z)) * e3w[z'>=z) ) 108 !! / SUM( sqrt(rn2(z')) * e3w[z') ) 108 109 !! 109 110 !! - update the model vertical eddy viscosity and diffusivity: … … 178 179 zfact(:,:) = 0._wp 179 180 DO jk = 2, jpkm1 ! part independent of the level 180 zfact(:,:) = zfact(:,:) + e3w(:,:,jk,Kmm) * SQRT( MAX( 0._wp, rn2(:,:,jk) ) ) * wmask(:,:,jk) 181 zfact(:,:) = & 182 & zfact(:,:) + & 183 & e3w(:,:,jk,Kmm) * SQRT( MAX( 0._wp, rn2(:,:,jk) ) ) * wmask(:,:,jk) 181 184 END DO 182 185 ! -
NEMO/branches/2020/dev_r12527_Gurvan_ShallowWater/src/OCE/ZDF/zdfmxl.F90
r12489 r13151 38 38 !! * Substitutions 39 39 # include "do_loop_substitute.h90" 40 # include "domzgr_substitute.h90" 40 41 !!---------------------------------------------------------------------- 41 42 !! NEMO/OCE 4.0 , NEMO Consortium (2018) … … 100 101 DO_3D_11_11( nlb10, jpkm1 ) 101 102 ikt = mbkt(ji,jj) 102 hmlp(ji,jj) = hmlp(ji,jj) + MAX( rn2b(ji,jj,jk) , 0._wp ) * e3w(ji,jj,jk,Kmm) 103 hmlp(ji,jj) = & 104 & hmlp(ji,jj) + MAX( rn2b(ji,jj,jk) , 0._wp ) * e3w(ji,jj,jk,Kmm) 103 105 IF( hmlp(ji,jj) < zN2_c ) nmln(ji,jj) = MIN( jk , ikt ) + 1 ! Mixed layer level 104 106 END_3D -
NEMO/branches/2020/dev_r12527_Gurvan_ShallowWater/src/OCE/ZDF/zdfosm.F90
r12489 r13151 103 103 INTEGER :: idebug = 236 104 104 INTEGER :: jdebug = 228 105 105 106 !! * Substitutions 106 107 # include "do_loop_substitute.h90" 108 # include "domzgr_substitute.h90" 107 109 !!---------------------------------------------------------------------- 108 110 !! NEMO/OCE 4.0 , NEMO Consortium (2018) … … 503 505 & - zbeta * ( zs_bl(ji,jj) - ts(ji,jj,jm,jp_sal,Kmm) ) ), 0.0 ) + zvel_max 504 506 505 zhbl_s = zhbl_s + MIN( - zwb_ent(ji,jj) / zdb * rn_Dt / FLOAT(ibld(ji,jj)-imld(ji,jj) ), e3w(ji,jj,jk,Kmm) ) 507 zhbl_s = zhbl_s + MIN( - zwb_ent(ji,jj) / zdb * rn_Dt / FLOAT(ibld(ji,jj)-imld(ji,jj) ), & 508 & e3w(ji,jj,jk,Kmm) ) 509 506 510 zhbl_s = MIN(zhbl_s, ht(ji,jj)) 507 511 … … 594 598 zwb_ent(ji,jj) = 0._wp 595 599 ENDIF 596 inhml = MAX( INT( zari * zhbl(ji,jj) / e3t(ji,jj,ibld(ji,jj),Kmm) ) , 1 ) 600 inhml = MAX( INT( zari * zhbl(ji,jj) & 601 & / e3t(ji,jj,ibld(ji,jj),Kmm) ), 1 ) 597 602 imld(ji,jj) = MAX( ibld(ji,jj) - inhml, 1) 598 603 zhml(ji,jj) = gdepw(ji,jj,imld(ji,jj),Kmm) … … 608 613 IF ( zdb_bl(ji,jj) > 0._wp ) THEN 609 614 ! pycnocline thickness set by stratification - use same relationship as for neutral conditions. 610 zari = MIN( 4.5 * ( zvstr(ji,jj)**2 ) & 611 & / ( zdb_bl(ji,jj) * zhbl(ji,jj) ) + 0.01 , 0.2 ) 612 inhml = MAX( INT( zari * zhbl(ji,jj) / e3t(ji,jj,ibld(ji,jj),Kmm) ) , 1 ) 615 zari = MIN( 4.5 * ( zvstr(ji,jj)**2 ) & 616 & / ( zdb_bl(ji,jj) * zhbl(ji,jj) ) + 0.01 , 0.2 ) 617 inhml = MAX( INT( zari * zhbl(ji,jj) & 618 & / e3t(ji,jj,ibld(ji,jj),Kmm) ), 1 ) 613 619 imld(ji,jj) = MAX( ibld(ji,jj) - inhml, 1) 614 620 zhml(ji,jj) = gdepw(ji,jj,imld(ji,jj),Kmm) -
NEMO/branches/2020/dev_r12527_Gurvan_ShallowWater/src/OCE/ZDF/zdfsh2.F90
r12377 r13151 24 24 !! * Substitutions 25 25 # include "do_loop_substitute.h90" 26 # include "domzgr_substitute.h90" 26 27 !!---------------------------------------------------------------------- 27 28 !! NEMO/OCE 4.0 , NEMO Consortium (2018) … … 62 63 zsh2u(ji,jj) = ( p_avm(ji+1,jj,jk) + p_avm(ji,jj,jk) ) & 63 64 & * ( uu(ji,jj,jk-1,Kmm) - uu(ji,jj,jk,Kmm) ) & 64 & * ( uu(ji,jj,jk-1,Kbb) - uu(ji,jj,jk,Kbb) ) / ( e3uw(ji,jj,jk,Kmm) * e3uw(ji,jj,jk,Kbb) ) * wumask(ji,jj,jk) 65 & * ( uu(ji,jj,jk-1,Kbb) - uu(ji,jj,jk,Kbb) ) & 66 & / ( e3uw(ji,jj,jk ,Kmm) * e3uw(ji,jj,jk,Kbb) ) & 67 & * wumask(ji,jj,jk) 65 68 zsh2v(ji,jj) = ( p_avm(ji,jj+1,jk) + p_avm(ji,jj,jk) ) & 66 69 & * ( vv(ji,jj,jk-1,Kmm) - vv(ji,jj,jk,Kmm) ) & 67 & * ( vv(ji,jj,jk-1,Kbb) - vv(ji,jj,jk,Kbb) ) / ( e3vw(ji,jj,jk,Kmm) * e3vw(ji,jj,jk,Kbb) ) * wvmask(ji,jj,jk) 70 & * ( vv(ji,jj,jk-1,Kbb) - vv(ji,jj,jk,Kbb) ) & 71 & / ( e3vw(ji,jj,jk ,Kmm) * e3vw(ji,jj,jk,Kbb) ) & 72 & * wvmask(ji,jj,jk) 68 73 END_2D 69 74 DO_2D_00_00 -
NEMO/branches/2020/dev_r12527_Gurvan_ShallowWater/src/OCE/ZDF/zdftke.F90
r12489 r13151 90 90 !! * Substitutions 91 91 # include "do_loop_substitute.h90" 92 # include "domzgr_substitute.h90" 92 93 !!---------------------------------------------------------------------- 93 94 !! NEMO/OCE 4.0 , NEMO Consortium (2018) … … 214 215 ! ! Surface/top/bottom boundary condition on tke 215 216 ! !<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<< 216 217 ! 217 218 DO_2D_00_00 218 219 en(ji,jj,1) = MAX( rn_emin0, zbbrau * taum(ji,jj) ) * tmask(ji,jj,1) 219 220 END_2D 220 IF ( ln_isfcav ) THEN221 DO_2D_00_00222 en(ji,jj,mikt(ji,jj)) = rn_emin * tmask(ji,jj,1)223 END_2D224 ENDIF225 221 ! 226 222 ! !<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<< … … 249 245 zetop = - 0.001875_wp * rCdU_top(ji,jj) * SQRT( ( zmsku*( uu(ji,jj,mikt(ji,jj),Kbb)+uu(ji-1,jj,mikt(ji,jj),Kbb) ) )**2 & 250 246 & + ( zmskv*( vv(ji,jj,mikt(ji,jj),Kbb)+vv(ji,jj-1,mikt(ji,jj),Kbb) ) )**2 ) 251 en(ji,jj,mikt(ji,jj)) = MAX( zetop, rn_emin ) * (1._wp - tmask(ji,jj,1)) ! masked at ocean surface247 en(ji,jj,mikt(ji,jj)) = en(ji,jj,1) * tmask(ji,jj,1) + MAX( zetop, rn_emin ) * (1._wp - tmask(ji,jj,1)) * ssmask(ji,jj) ! masked at ocean surface 252 248 END_2D 253 249 ENDIF … … 260 256 ! 261 257 ! !* total energy produce by LC : cumulative sum over jk 262 zpelc(:,:,1) = 258 zpelc(:,:,1) = MAX( rn2b(:,:,1), 0._wp ) * gdepw(:,:,1,Kmm) * e3w(:,:,1,Kmm) 263 259 DO jk = 2, jpk 264 zpelc(:,:,jk) = zpelc(:,:,jk-1) + MAX( rn2b(:,:,jk), 0._wp ) * gdepw(:,:,jk,Kmm) * e3w(:,:,jk,Kmm) 260 zpelc(:,:,jk) = zpelc(:,:,jk-1) + & 261 & MAX( rn2b(:,:,jk), 0._wp ) * gdepw(:,:,jk,Kmm) * e3w(:,:,jk,Kmm) 265 262 END DO 266 263 ! !* finite Langmuir Circulation depth … … 316 313 ! ! eddy coefficient (ensure numerical stability) 317 314 zzd_up = zcof * MAX( p_avm(ji,jj,jk+1) + p_avm(ji,jj,jk ) , 2.e-5_wp ) & ! upper diagonal 318 & / ( e3t(ji,jj,jk ,Kmm) * e3w(ji,jj,jk ,Kmm) ) 315 & / ( e3t(ji,jj,jk ,Kmm) & 316 & * e3w(ji,jj,jk ,Kmm) ) 319 317 zzd_lw = zcof * MAX( p_avm(ji,jj,jk ) + p_avm(ji,jj,jk-1) , 2.e-5_wp ) & ! lower diagonal 320 & / ( e3t(ji,jj,jk-1,Kmm) * e3w(ji,jj,jk ,Kmm) ) 318 & / ( e3t(ji,jj,jk-1,Kmm) & 319 & * e3w(ji,jj,jk ,Kmm) ) 321 320 ! 322 321 zd_up(ji,jj,jk) = zzd_up ! Matrix (zdiag, zd_up, zd_lw) … … 467 466 & gdepw(ji,jj,mbkt(ji,jj)+1,Kmm) - gdepw(ji,jj,jk,Kmm) ) 468 467 ! wmask prevent zmxlm = 0 if jk = mikt(ji,jj) 469 zmxlm(ji,jj,jk) = zemxl * wmask(ji,jj,jk) + MIN( zmxlm(ji,jj,jk) , e3w(ji,jj,jk,Kmm) ) * (1 - wmask(ji,jj,jk)) 470 zmxld(ji,jj,jk) = zemxl * wmask(ji,jj,jk) + MIN( zmxlm(ji,jj,jk) , e3w(ji,jj,jk,Kmm) ) * (1 - wmask(ji,jj,jk)) 468 zmxlm(ji,jj,jk) = zemxl * wmask(ji,jj,jk) & 469 & + MIN( zmxlm(ji,jj,jk) , e3w(ji,jj,jk,Kmm) ) * (1 - wmask(ji,jj,jk)) 470 zmxld(ji,jj,jk) = zemxl * wmask(ji,jj,jk) & 471 & + MIN( zmxlm(ji,jj,jk) , e3w(ji,jj,jk,Kmm) ) * (1 - wmask(ji,jj,jk)) 471 472 END_3D 472 473 ! … … 480 481 CASE ( 2 ) ! |dk[xml]| bounded by e3t : 481 482 DO_3D_00_00( 2, jpkm1 ) 482 zmxlm(ji,jj,jk) = MIN( zmxlm(ji,jj,jk-1) + e3t(ji,jj,jk-1,Kmm), zmxlm(ji,jj,jk) ) 483 zmxlm(ji,jj,jk) = & 484 & MIN( zmxlm(ji,jj,jk-1) + e3t(ji,jj,jk-1,Kmm), zmxlm(ji,jj,jk) ) 483 485 END_3D 484 486 DO_3DS_00_00( jpkm1, 2, -1 ) … … 490 492 CASE ( 3 ) ! lup and ldown, |dk[xml]| bounded by e3t : 491 493 DO_3D_00_00( 2, jpkm1 ) 492 zmxld(ji,jj,jk) = MIN( zmxld(ji,jj,jk-1) + e3t(ji,jj,jk-1,Kmm), zmxlm(ji,jj,jk) ) 494 zmxld(ji,jj,jk) = & 495 & MIN( zmxld(ji,jj,jk-1) + e3t(ji,jj,jk-1,Kmm), zmxlm(ji,jj,jk) ) 493 496 END_3D 494 497 DO_3DS_00_00( jpkm1, 2, -1 ) 495 zmxlm(ji,jj,jk) = MIN( zmxlm(ji,jj,jk+1) + e3t(ji,jj,jk+1,Kmm), zmxlm(ji,jj,jk) ) 498 zmxlm(ji,jj,jk) = & 499 & MIN( zmxlm(ji,jj,jk+1) + e3t(ji,jj,jk+1,Kmm), zmxlm(ji,jj,jk) ) 496 500 END_3D 497 501 DO_3D_00_00( 2, jpkm1 ) … … 518 522 IF( nn_pdl == 1 ) THEN !* Prandtl number case: update avt 519 523 DO_3D_00_00( 2, jpkm1 ) 520 p_avt(ji,jj,jk) = MAX( apdlr(ji,jj,jk) * p_avt(ji,jj,jk), avtb_2d(ji,jj) * avtb(jk) ) * tmask(ji,jj,jk)524 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) 521 525 END_3D 522 526 ENDIF -
NEMO/branches/2020/dev_r12527_Gurvan_ShallowWater/src/OCE/nemogcm.F90
r12489 r13151 29 29 !! 3.3.1! 2011-01 (A. R. Porter, STFC Daresbury) dynamical allocation 30 30 !! - ! 2011-11 (C. Harris) decomposition changes for running with CICE 31 !! 3.6 ! 2012-05 (C. Calone, J. Simeon, G. Madec, C. Ethe) Add grid coarsening 31 !! 3.6 ! 2012-05 (C. Calone, J. Simeon, G. Madec, C. Ethe) Add grid coarsening 32 32 !! - ! 2014-12 (G. Madec) remove KPP scheme and cross-land advection (cla) 33 33 !! 4.0 ! 2016-10 (G. Madec, S. Flavoni) domain configuration / user defined interface … … 53 53 USE ldftra ! lateral diffusivity setting (ldftra_init routine) 54 54 USE trdini ! dyn/tra trends initialization (trd_init routine) 55 USE asminc ! assimilation increments 55 USE asminc ! assimilation increments 56 56 USE asmbkg ! writing out state trajectory 57 57 USE diaptr ! poleward transports (dia_ptr_init routine) … … 60 60 USE diacfl ! CFL diagnostics (dia_cfl_init routine) 61 61 USE diamlr ! IOM context management for multiple-linear-regression analysis 62 USE step ! NEMO time-stepping (stp routine) 62 #if defined key_qco 63 USE stepMLF ! NEMO time-stepping (stp_MLF routine) 64 #else 65 USE step ! NEMO time-stepping (stp routine) 66 #endif 63 67 USE isfstp ! ice shelf (isf_stp_init routine) 64 68 USE icbini ! handle bergs, initialisation … … 84 88 #endif 85 89 ! 90 USE in_out_manager ! I/O manager 86 91 USE lib_mpp ! distributed memory computing 87 92 USE mppini ! shared/distributed memory setting (mpp_init routine) 88 USE lbcnfd , ONLY : isendto, nsndto, nfsloop, nfeloop ! Setup of north fold exchanges 93 USE lbcnfd , ONLY : isendto, nsndto, nfsloop, nfeloop ! Setup of north fold exchanges 89 94 USE lib_fortran ! Fortran utilities (allows no signed zero when 'key_nosignedzero' defined) 90 95 #if defined key_iomput … … 143 148 Kbb_a = Nbb; Kmm_a = Nnn; Krhs_a = Nrhs ! agrif_oce module copies of time level indices 144 149 CALL Agrif_Declare_Var_dom ! AGRIF: set the meshes for DOM 145 CALL Agrif_Declare_Var ! " " " " " DYN/TRA 150 CALL Agrif_Declare_Var ! " " " " " DYN/TRA 146 151 # if defined key_top 147 152 CALL Agrif_Declare_Var_top ! " " " " " TOP … … 181 186 ! 182 187 DO WHILE( istp <= nitend .AND. nstop == 0 ) 188 #if defined key_qco 189 CALL stp_MLF 190 #else 183 191 CALL stp 192 #endif 184 193 istp = istp + 1 185 194 END DO … … 204 213 IF ( istp == nitend ) elapsed_time = zstptiming - elapsed_time 205 214 ENDIF 206 207 CALL stp ( istp ) 215 216 #if defined key_qco 217 CALL stp_MLF ( istp ) 218 #else 219 CALL stp ( istp ) 220 #endif 208 221 istp = istp + 1 209 222 … … 215 228 ! 216 229 DO WHILE( istp <= nitend .AND. nstop == 0 ) 217 CALL stp_diurnal( istp ) ! time step only the diurnal SST 230 CALL stp_diurnal( istp ) ! time step only the diurnal SST 218 231 istp = istp + 1 219 232 END DO … … 317 330 IF( lwm ) CALL ctl_opn( numond, 'output.namelist.dyn', 'REPLACE', 'FORMATTED', 'SEQUENTIAL', -1, -1, .FALSE. ) 318 331 ! open /dev/null file to be able to supress output write easily 332 IF( Agrif_Root() ) THEN 319 333 CALL ctl_opn( numnul, '/dev/null', 'REPLACE', 'FORMATTED', 'SEQUENTIAL', -1, -1, .FALSE. ) 320 ! 334 #ifdef key_agrif 335 ELSE 336 numnul = Agrif_Parent(numnul) 337 #endif 338 ENDIF 321 339 ! !--------------------! 322 340 ! ! Open listing units ! -> need sn_cfctl from namctl to define lwp … … 387 405 903 IF( ios /= 0 ) CALL ctl_nam ( ios , 'namcfg in reference namelist' ) 388 406 READ ( numnam_cfg, namcfg, IOSTAT = ios, ERR = 904 ) 389 904 IF( ios > 0 ) CALL ctl_nam ( ios , 'namcfg in configuration namelist' ) 407 904 IF( ios > 0 ) CALL ctl_nam ( ios , 'namcfg in configuration namelist' ) 390 408 ! 391 409 IF( ln_read_cfg ) THEN ! Read sizes in domain configuration file … … 423 441 CALL wad_init ! Wetting and drying options 424 442 CALL dom_init( Nbb, Nnn, Naa, "OPA") ! Domain 425 IF( ln_crs ) CALL crs_init( Nnn ) ! coarsened grid: domain initialization 443 IF( ln_crs ) CALL crs_init( Nnn ) ! coarsened grid: domain initialization 426 444 IF( sn_cfctl%l_prtctl ) & 427 445 & CALL prt_ctl_init ! Print control 428 446 429 447 CALL diurnal_sst_bulk_init ! diurnal sst 430 IF( ln_diurnal ) CALL diurnal_sst_coolskin_init ! cool skin 431 ! 448 IF( ln_diurnal ) CALL diurnal_sst_coolskin_init ! cool skin 449 ! 432 450 IF( ln_diurnal_only ) THEN ! diurnal only: a subset of the initialisation routines 433 451 CALL istate_init( Nbb, Nnn, Naa ) ! ocean initial state (Dynamics and tracers) … … 437 455 CALL dia_obs_init( Nnn ) ! Initialize observational data 438 456 CALL dia_obs( nit000 - 1, Nnn ) ! Observation operator for restart 439 ENDIF 457 ENDIF 440 458 IF( lk_asminc ) CALL asm_inc_init( Nbb, Nnn, Nrhs ) ! Assimilation increments 441 459 ! … … 443 461 ENDIF 444 462 ! 445 463 446 464 CALL istate_init( Nbb, Nnn, Naa ) ! ocean initial state (Dynamics and tracers) 447 465 448 ! ! external forcing 466 ! ! external forcing 449 467 CALL tide_init ! tidal harmonics 450 468 CALL sbc_init( Nbb, Nnn, Naa ) ! surface boundary conditions (including sea-ice) … … 453 471 ! ! Ocean physics 454 472 CALL zdf_phy_init( Nnn ) ! Vertical physics 455 473 456 474 ! ! Lateral physics 457 475 CALL ldf_tra_init ! Lateral ocean tracer physics … … 490 508 CALL sto_par_init ! Stochastic parametrization 491 509 IF( ln_sto_eos ) CALL sto_pts_init ! RRandom T/S fluctuations 492 510 493 511 ! ! Diagnostics 494 512 CALL flo_init( Nnn ) ! drifting Floats … … 538 556 WRITE(numout,*) ' sn_cfctl%l_prttrc = ', sn_cfctl%l_prttrc 539 557 WRITE(numout,*) ' sn_cfctl%l_oasout = ', sn_cfctl%l_oasout 540 WRITE(numout,*) ' sn_cfctl%procmin = ', sn_cfctl%procmin 541 WRITE(numout,*) ' sn_cfctl%procmax = ', sn_cfctl%procmax 542 WRITE(numout,*) ' sn_cfctl%procincr = ', sn_cfctl%procincr 543 WRITE(numout,*) ' sn_cfctl%ptimincr = ', sn_cfctl%ptimincr 558 WRITE(numout,*) ' sn_cfctl%procmin = ', sn_cfctl%procmin 559 WRITE(numout,*) ' sn_cfctl%procmax = ', sn_cfctl%procmax 560 WRITE(numout,*) ' sn_cfctl%procincr = ', sn_cfctl%procincr 561 WRITE(numout,*) ' sn_cfctl%ptimincr = ', sn_cfctl%ptimincr 544 562 WRITE(numout,*) ' level of print nn_print = ', nn_print 545 563 WRITE(numout,*) ' Start i indice for SUM control nn_ictls = ', nn_ictls … … 665 683 !!---------------------------------------------------------------------- 666 684 ! 667 ierr = oce_alloc () ! ocean 685 ierr = oce_alloc () ! ocean 668 686 ierr = ierr + dia_wri_alloc() 669 687 ierr = ierr + dom_oce_alloc() ! ocean domain … … 677 695 END SUBROUTINE nemo_alloc 678 696 679 697 680 698 SUBROUTINE nemo_set_cfctl(sn_cfctl, setto, for_all ) 681 699 !!---------------------------------------------------------------------- … … 708 726 !!====================================================================== 709 727 END MODULE nemogcm 710 -
NEMO/branches/2020/dev_r12527_Gurvan_ShallowWater/src/OCE/oce.F90
r12489 r13151 32 32 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: Cu_adv !: vertical Courant number (adaptive-implicit) 33 33 34 !! free surface ! before ! now ! after !35 !! ------------ ! fields ! fields ! fields !34 !! free surface 35 !! ------------ 36 36 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: ssh, uu_b, vv_b !: SSH [m] and barotropic velocities [m/s] 37 37 38 38 !! Arrays at barotropic time step: ! befbefore! before ! now ! after ! 39 39 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: ubb_e , ub_e , un_e , ua_e !: u-external velocity -
NEMO/branches/2020/dev_r12527_Gurvan_ShallowWater/src/OCE/step.F90
r12489 r13151 33 33 !! 4.1 ! 2019-08 (A. Coward, D. Storkey) rewrite in preparation for new timestepping scheme 34 34 !!---------------------------------------------------------------------- 35 35 #if defined key_qco 36 !!---------------------------------------------------------------------- 37 !! 'key_qco' EMPTY MODULE Quasi-Eulerian vertical coordonate 38 !!---------------------------------------------------------------------- 39 #else 36 40 !!---------------------------------------------------------------------- 37 41 !! stp : OPA system time-stepping … … 87 91 !! --------------------------------------------------------------------- 88 92 #if defined key_agrif 93 IF( nstop > 0 ) return ! avoid to go further if an error was detected during previous time step 89 94 kstp = nit000 + Agrif_Nb_Step() 90 95 Kbb_a = Nbb; Kmm_a = Nnn; Krhs_a = Nrhs ! agrif_oce module copies of time level indices … … 181 186 CALL ssh_nxt ( kstp, Nbb, Nnn, ssh, Naa ) ! after ssh (includes call to div_hor) 182 187 IF( .NOT.ln_linssh ) CALL dom_vvl_sf_nxt( kstp, Nbb, Nnn, Naa ) ! after vertical scale factors 183 CALL wzv ( kstp, Nbb, Nnn, ww, Naa) ! now cross-level velocity188 CALL wzv ( kstp, Nbb, Nnn, Naa, ww ) ! now cross-level velocity 184 189 IF( ln_zad_Aimp ) CALL wAimp ( kstp, Nnn ) ! Adaptive-implicit vertical advection partitioning 185 190 CALL eos ( ts(:,:,:,:,Nnn), rhd, rhop, gdept(:,:,:,Nnn) ) ! now in situ density for hpg computation … … 210 215 CALL dyn_zdf ( kstp, Nbb, Nnn, Nrhs, uu, vv, Naa ) ! vertical diffusion 211 216 IF( ln_dynspg_ts ) THEN ! vertical scale factors and vertical velocity need to be updated 212 CALL wzv ( kstp, Nbb, Nnn, ww, Naa) ! now cross-level velocity217 CALL wzv ( kstp, Nbb, Nnn, Naa, ww ) ! now cross-level velocity 213 218 IF( ln_zad_Aimp ) CALL wAimp ( kstp, Nnn ) ! Adaptive-implicit vertical advection partitioning 214 219 ENDIF … … 244 249 ! Active tracers 245 250 !<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<< 251 !!an ne reste que ça, ssh linéaire 246 252 ts(:,:,:,:,Nrhs) = 0._wp ! set tracer trends to zero 247 253 248 254 IF( lk_asminc .AND. ln_asmiau .AND. & 249 & ln_trainc ) CALL tra_asm_inc( kstp, Nbb, Nnn, ts, Nrhs ) ! apply tracer assimilation increment250 CALL tra_sbc ( kstp, Nnn, ts, Nrhs ) ! surface boundary condition251 IF( ln_traqsr ) CALL tra_qsr ( kstp, Nnn, ts, Nrhs ) ! penetrative solar radiation qsr252 IF( ln_isf ) CALL tra_isf ( kstp, Nnn, ts, Nrhs ) ! ice shelf heat flux253 IF( ln_trabbc ) CALL tra_bbc ( kstp, Nnn, ts, Nrhs ) ! bottom heat flux254 IF( ln_trabbl ) CALL tra_bbl ( kstp, Nbb, Nnn, ts, Nrhs ) ! advective (and/or diffusive) bottom boundary layer scheme255 IF( ln_tradmp ) CALL tra_dmp ( kstp, Nbb, Nnn, ts, Nrhs ) ! internal damping trends256 IF( ln_bdy ) CALL bdy_tra_dmp( kstp, Nbb, ts, Nrhs ) ! bdy damping trends255 ! & ln_trainc ) CALL tra_asm_inc( kstp, Nbb, Nnn, ts, Nrhs ) ! apply tracer assimilation increment 256 ! CALL tra_sbc ( kstp, Nnn, ts, Nrhs ) ! surface boundary condition 257 ! IF( ln_traqsr ) CALL tra_qsr ( kstp, Nnn, ts, Nrhs ) ! penetrative solar radiation qsr 258 ! IF( ln_isf ) CALL tra_isf ( kstp, Nnn, ts, Nrhs ) ! ice shelf heat flux 259 ! IF( ln_trabbc ) CALL tra_bbc ( kstp, Nnn, ts, Nrhs ) ! bottom heat flux 260 ! IF( ln_trabbl ) CALL tra_bbl ( kstp, Nbb, Nnn, ts, Nrhs ) ! advective (and/or diffusive) bottom boundary layer scheme 261 ! IF( ln_tradmp ) CALL tra_dmp ( kstp, Nbb, Nnn, ts, Nrhs ) ! internal damping trends 262 ! IF( ln_bdy ) CALL bdy_tra_dmp( kstp, Nbb, ts, Nrhs ) ! bdy damping trends 257 263 #if defined key_agrif 258 264 IF(.NOT. Agrif_Root()) & … … 260 266 #endif 261 267 CALL tra_adv ( kstp, Nbb, Nnn, ts, Nrhs ) ! hor. + vert. advection ==> RHS 262 IF( ln_zdfosm ) CALL tra_osm ( kstp, Nnn, ts, Nrhs ) ! OSMOSIS non-local tracer fluxes ==> RHS268 ! IF( ln_zdfosm ) CALL tra_osm ( kstp, Nnn, ts, Nrhs ) ! OSMOSIS non-local tracer fluxes ==> RHS 263 269 IF( lrst_oce .AND. ln_zdfosm ) & 264 & CALL osm_rst ( kstp, Nnn, 'WRITE' ) ! write OSMOSIS outputs + ww (so must do here) to restarts265 CALL tra_ldf ( kstp, Nbb, Nnn, ts, Nrhs ) ! lateral mixing266 267 CALL tra_zdf ( kstp, Nbb, Nnn, Nrhs, ts, Naa ) ! vertical mixing and after tracer fields268 IF( ln_zdfnpc ) CALL tra_npc ( kstp, Nnn, Nrhs, ts, Naa ) ! update after fields by non-penetrative convection270 ! & CALL osm_rst ( kstp, Nnn, 'WRITE' ) ! write OSMOSIS outputs + ww (so must do here) to restarts 271 ! à voir CALL tra_ldf ( kstp, Nbb, Nnn, ts, Nrhs ) ! lateral mixing 272 273 ! CALL tra_zdf ( kstp, Nbb, Nnn, Nrhs, ts, Naa ) ! vertical mixing and after tracer fields 274 ! IF( ln_zdfnpc ) CALL tra_npc ( kstp, Nnn, Nrhs, ts, Naa ) ! update after fields by non-penetrative convection 269 275 270 276 !>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>> … … 285 291 !! 286 292 !!jc2: dynnxt must be the latest call. e3t(:,:,:,Nbb) are indeed updated in that routine 287 CALL tra_atf ( kstp, Nbb, Nnn, Naa, ts ) ! time filtering of "now" tracer arrays288 CALL dyn_atf ( kstp, Nbb, Nnn, Naa, uu, vv, e3t, e3u, e3v ) ! time filtering of "now" velocities and scale factors289 CALL ssh_atf ( kstp, Nbb, Nnn, Naa, ssh ) ! time filtering of "now" sea surface height293 ! écrire à la main CALL tra_atf ( kstp, Nbb, Nnn, Naa, ts ) ! time filtering of "now" tracer arrays 294 ! CALL dyn_atf ( kstp, Nbb, Nnn, Naa, uu, vv, e3t, e3u, e3v ) ! time filtering of "now" velocities and scale factors 295 ! CALL ssh_atf ( kstp, Nbb, Nnn, Naa, ssh ) ! time filtering of "now" sea surface height 290 296 ! 291 297 ! Swap time levels … … 309 315 #if defined key_agrif 310 316 !>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>> 311 ! AGRIF 317 ! AGRIF recursive integration 312 318 !<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<< 313 319 Kbb_a = Nbb; Kmm_a = Nnn; Krhs_a = Nrhs ! agrif_oce module copies of time level indices 314 320 CALL Agrif_Integrate_ChildGrids( stp ) ! allows to finish all the Child Grids before updating 315 316 IF( Agrif_NbStepint() == 0 ) THEN 317 CALL Agrif_update_all( ) ! Update all components 318 ENDIF 321 #endif 322 !>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>> 323 ! Control 324 !<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<< 325 CALL stp_ctl ( kstp, Nbb, Nnn, indic ) 326 #if defined key_agrif 327 !>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>> 328 ! AGRIF update 329 !<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<< 330 IF( Agrif_NbStepint() == 0 .AND. nstop == 0 ) THEN 331 CALL Agrif_update_all( ) ! Update all components 332 ENDIF 319 333 #endif 320 334 IF( ln_diaobs ) CALL dia_obs ( kstp, Nnn ) ! obs-minus-model (assimilation) diagnostics (call after dynamics update) 321 335 322 336 !>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>> 323 ! Control 324 !<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<< 325 CALL stp_ctl ( kstp, Nbb, Nnn, indic ) 326 337 ! File manipulation at the end of the first time step 338 !<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<< 327 339 IF( kstp == nit000 ) THEN ! 1st time step only 328 340 CALL iom_close( numror ) ! close input ocean restart file … … 338 350 ! 339 351 #if defined key_iomput 352 !>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>> 353 ! Finalize contextes if end of simulation or error detected 354 !<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<< 340 355 IF( kstp == nitend .OR. indic < 0 ) THEN 341 356 CALL iom_context_finalize( cxios_context ) ! needed for XIOS+AGRIF 342 IF(lrxios) CALL iom_context_finalize( crxios_context)357 IF( lrxios ) CALL iom_context_finalize( crxios_context ) 343 358 IF( ln_crs ) CALL iom_context_finalize( trim(cxios_context)//"_crs" ) ! 344 359 ENDIF … … 355 370 END SUBROUTINE stp 356 371 ! 372 #endif 357 373 !!====================================================================== 358 374 END MODULE step -
NEMO/branches/2020/dev_r12527_Gurvan_ShallowWater/src/OFF/dtadyn.F90
r12489 r13151 23 23 USE c1d ! 1D configuration: lk_c1d 24 24 USE dom_oce ! ocean domain: variables 25 #if ! defined key_qco 25 26 USE domvvl ! variable volume 27 #else 28 USE domqco 29 #endif 26 30 USE zdf_oce ! ocean vertical physics: variables 27 31 USE sbc_oce ! surface module: variables … … 52 56 PUBLIC dta_dyn_sed ! called by nemo_gcm 53 57 PUBLIC dta_dyn_atf ! called by nemo_gcm 58 #if ! defined key_qco 54 59 PUBLIC dta_dyn_sf_interp ! called by nemo_gcm 60 #endif 55 61 56 62 CHARACTER(len=100) :: cn_dir !: Root directory for location of ssr files … … 128 134 IF( l_ldfslp .AND. .NOT.lk_c1d ) CALL dta_dyn_slp( kt, Kbb, Kmm ) ! Computation of slopes 129 135 ! 130 ts (:,:,:,jp_tem,Kmm) = sf_dyn(jf_tem)%fnow(:,:,:)* tmask(:,:,:) ! temperature131 ts (:,:,:,jp_sal,Kmm) = sf_dyn(jf_sal)%fnow(:,:,:)* tmask(:,:,:) ! salinity132 wndm (:,:) = sf_dyn(jf_wnd)%fnow(:,:,1)* tmask(:,:,1) ! wind speed - needed for gas exchange133 fmmflx(:,:) = sf_dyn(jf_fmf)%fnow(:,:,1)* tmask(:,:,1) ! downward salt flux (v3.5+)134 fr_i (:,:) = sf_dyn(jf_ice)%fnow(:,:,1)* tmask(:,:,1) ! Sea-ice fraction135 qsr (:,:) = sf_dyn(jf_qsr)%fnow(:,:,1)* tmask(:,:,1) ! solar radiation136 emp (:,:) = sf_dyn(jf_emp)%fnow(:,:,1)* tmask(:,:,1) ! E-P136 ts (:,:,:,jp_tem,Kmm) = sf_dyn(jf_tem)%fnow(:,:,:) * tmask(:,:,:) ! temperature 137 ts (:,:,:,jp_sal,Kmm) = sf_dyn(jf_sal)%fnow(:,:,:) * tmask(:,:,:) ! salinity 138 wndm (:,:) = sf_dyn(jf_wnd)%fnow(:,:,1) * tmask(:,:,1) ! wind speed - needed for gas exchange 139 fmmflx(:,:) = sf_dyn(jf_fmf)%fnow(:,:,1) * tmask(:,:,1) ! downward salt flux (v3.5+) 140 fr_i (:,:) = sf_dyn(jf_ice)%fnow(:,:,1) * tmask(:,:,1) ! Sea-ice fraction 141 qsr (:,:) = sf_dyn(jf_qsr)%fnow(:,:,1) * tmask(:,:,1) ! solar radiation 142 emp (:,:) = sf_dyn(jf_emp)%fnow(:,:,1) * tmask(:,:,1) ! E-P 137 143 IF( ln_dynrnf ) THEN 138 rnf (:,:)= sf_dyn(jf_rnf)%fnow(:,:,1) * tmask(:,:,1) ! E-P139 IF( ln_dynrnf_depth .AND. .NOT. ln_linssh ) CALL dta_dyn_hrnf(Kmm)140 ENDIF 141 ! 142 uu(:,:,:,Kmm) = sf_dyn(jf_uwd)%fnow(:,:,:) * umask(:,:,:) ! effective u-transport143 vv(:,:,:,Kmm) = sf_dyn(jf_vwd)%fnow(:,:,:) * vmask(:,:,:) ! effective v-transport144 ww(:,:,:) = sf_dyn(jf_wwd)%fnow(:,:,:) * tmask(:,:,:) ! effective v-transport144 rnf(:,:) = sf_dyn(jf_rnf)%fnow(:,:,1) * tmask(:,:,1) ! E-P 145 IF( ln_dynrnf_depth .AND. .NOT.ln_linssh ) CALL dta_dyn_hrnf( Kmm ) 146 ENDIF 147 ! 148 uu(:,:,:,Kmm) = sf_dyn(jf_uwd)%fnow(:,:,:) * umask(:,:,:) ! effective u-transport 149 vv(:,:,:,Kmm) = sf_dyn(jf_vwd)%fnow(:,:,:) * vmask(:,:,:) ! effective v-transport 150 ww(:,:,:) = sf_dyn(jf_wwd)%fnow(:,:,:) * tmask(:,:,:) ! effective v-transport 145 151 ! 146 152 IF( .NOT.ln_linssh ) THEN 147 153 ALLOCATE( zemp(jpi,jpj) , zhdivtr(jpi,jpj,jpk) ) 148 zhdivtr(:,:,:) = sf_dyn(jf_div )%fnow(:,:,:)* tmask(:,:,:) ! effective u-transport154 zhdivtr(:,:,:) = sf_dyn(jf_div )%fnow(:,:,:) * tmask(:,:,:) ! effective u-transport 149 155 emp_b (:,:) = sf_dyn(jf_empb)%fnow(:,:,1) * tmask(:,:,1) ! E-P 150 156 zemp (:,:) = ( 0.5_wp * ( emp(:,:) + emp_b(:,:) ) + rnf(:,:) + fwbcorr ) * tmask(:,:,1) 151 CALL dta_dyn_ssh( kt, zhdivtr, ssh(:,:,Kbb), zemp, ssh(:,:,Kaa), e3t(:,:,:,Kaa) ) != ssh, vertical scale factor & vertical transport 157 #if defined key_qco 158 CALL dta_dyn_ssh( kt, zhdivtr, ssh(:,:,Kbb), zemp, ssh(:,:,Kaa) ) 159 CALL dom_qco_r3c( ssh(:,:,Kaa), r3t(:,:,Kaa), r3u(:,:,Kaa), r3v(:,:,Kaa) ) 160 #else 161 CALL dta_dyn_ssh( kt, zhdivtr, ssh(:,:,Kbb), zemp, ssh(:,:,Kaa), e3t(:,:,:,Kaa) ) != ssh, vertical scale factor 162 #endif 152 163 DEALLOCATE( zemp , zhdivtr ) 153 164 ! Write in the tracer restart file … … 329 340 ENDIF 330 341 ! 342 #if defined key_qco 343 CALL dom_qco_r3c( ssh(:,:,Kbb), r3t(:,:,Kbb), r3u(:,:,Kbb), r3v(:,:,Kbb) ) 344 CALL dom_qco_r3c( ssh(:,:,Kmm), r3t(:,:,Kmm), r3u(:,:,Kmm), r3v(:,:,Kmm) ) 345 #else 331 346 DO jk = 1, jpkm1 332 e3t(:,:,jk,Kmm) = e3t_0(:,:,jk) * ( 1._wp + ssh(:,:,Kmm) * tmask(:,:,1) / ( ht_0(:,:) + 1.0 - tmask(:,:,1)) )333 END DO347 e3t(:,:,jk,Kmm) = e3t_0(:,:,jk) * ( 1._wp + ssh(:,:,Kmm) * r1_ht_0(:,:) * tmask(:,:,jk) ) 348 END DO 334 349 e3t(:,:,jpk,Kaa) = e3t_0(:,:,jpk) 335 350 … … 342 357 ! ------------------------------------ 343 358 CALL dom_vvl_interpol( e3t(:,:,:,Kmm), e3w(:,:,:,Kmm), 'W' ) 344 359 !!gm this should be computed from ssh(Kbb) 345 360 e3t(:,:,:,Kbb) = e3t(:,:,:,Kmm) 346 361 e3u(:,:,:,Kbb) = e3u(:,:,:,Kmm) … … 366 381 gdepw(:,:,:,Kbb) = gdepw(:,:,:,Kmm) 367 382 ! 368 ENDIF 383 ENDIF 384 #endif 369 385 ! 370 386 IF( ln_dynrnf .AND. ln_dynrnf_depth ) THEN ! read depht over which runoffs are distributed … … 389 405 ENDIF 390 406 END_2D 407 !!st pourquoi on n'utilise pas le gde3w ici plutôt que de faire une boucle ? 391 408 DO_2D_11_11 392 409 h_rnf(ji,jj) = 0._wp … … 413 430 END SUBROUTINE dta_dyn_init 414 431 432 415 433 SUBROUTINE dta_dyn_sed( kt, Kmm ) 416 434 !!---------------------------------------------------------------------- … … 529 547 END SUBROUTINE dta_dyn_sed_init 530 548 549 531 550 SUBROUTINE dta_dyn_atf( kt, Kbb, Kmm, Kaa ) 532 551 !!--------------------------------------------------------------------- … … 551 570 ! 552 571 END SUBROUTINE dta_dyn_atf 572 553 573 574 #if ! defined key_qco 554 575 SUBROUTINE dta_dyn_sf_interp( kt, Kmm ) 555 576 !!--------------------------------------------------------------------- … … 588 609 ! 589 610 END SUBROUTINE dta_dyn_sf_interp 590 611 #endif 612 613 591 614 SUBROUTINE dta_dyn_ssh( kt, phdivtr, psshb, pemp, pssha, pe3ta ) 592 615 !!---------------------------------------------------------------------- … … 606 629 !! The boundary conditions are w=0 at the bottom (no flux) 607 630 !! 608 !! ** action : ssh(:,:,Kaa) / e3t(:,:, :,Kaa) / ww631 !! ** action : ssh(:,:,Kaa) / e3t(:,:,k,Kaa) / ww 609 632 !! 610 633 !! Reference : Leclair, M., and G. Madec, 2009, Ocean Modelling. … … 630 653 ! ! Sea surface elevation time-stepping 631 654 pssha(:,:) = ( psshb(:,:) - z2dt * ( r1_rho0 * pemp(:,:) + zhdiv(:,:) ) ) * ssmask(:,:) 632 ! ! 633 ! ! After acale factors at t-points ( z_star coordinate ) 634 DO jk = 1, jpkm1 635 pe3ta(:,:,jk) = e3t_0(:,:,jk) * ( 1._wp + pssha(:,:) * tmask(:,:,1) / ( ht_0(:,:) + 1.0 - tmask(:,:,1) ) ) 636 END DO 655 ! 656 IF( PRESENT( pe3ta ) ) THEN ! After acale factors at t-points ( z_star coordinate ) 657 DO jk = 1, jpkm1 658 pe3ta(:,:,jk) = e3t_0(:,:,jk) * ( 1._wp + pssha(:,:) * r1_ht_0(:,:) * tmask(:,:,jk) ) 659 END DO 660 ENDIF 637 661 ! 638 662 END SUBROUTINE dta_dyn_ssh … … 657 681 !!---------------------------------------------------------------------- 658 682 ! 683 !!st code dupliqué même remarque que plus haut pourquoi ne pas utiliser gdepw ? 659 684 DO_2D_11_11 660 685 h_rnf(ji,jj) = 0._wp -
NEMO/branches/2020/dev_r12527_Gurvan_ShallowWater/src/OFF/nemogcm.F90
r12377 r13151 28 28 USE usrdef_nam ! user defined configuration 29 29 USE eosbn2 ! equation of state (eos bn2 routine) 30 #if defined key_qco 31 USE domqco ! tools for scale factor (dom_qco_r3c routine) 32 #endif 30 33 ! ! ocean physics 31 34 USE ldftra ! lateral diffusivity setting (ldf_tra_init routine) … … 117 120 CALL dta_dyn ( istp, Nbb, Nnn, Naa ) ! Interpolation of the dynamical fields 118 121 #endif 122 #if ! defined key_sed_off 123 IF( .NOT.ln_linssh ) THEN 124 CALL dta_dyn_atf( istp, Nbb, Nnn, Naa ) ! time filter of sea surface height and vertical scale factors 125 # if defined key_qco 126 CALL dom_qco_r3c( ssh(:,:,Kmm), r3t_f, r3u_f, r3v_f ) 127 # endif 128 ENDIF 119 129 CALL trc_stp ( istp, Nbb, Nnn, Nrhs, Naa ) ! time-stepping 120 #if ! defined key_sed_off 121 IF( .NOT.ln_linssh ) CALL dta_dyn_atf( istp, Nbb, Nnn, Naa ) ! time filter of sea surface height and vertical scale factors 130 # if defined key_qco 131 !r3t(:,:,Kmm) = r3t_f(:,:) ! update ssh to h0 ratio 132 !r3u(:,:,Kmm) = r3u_f(:,:) 133 !r3v(:,:,Kmm) = r3v_f(:,:) 134 # endif 122 135 #endif 123 136 ! Swap time levels … … 127 140 Naa = Nrhs 128 141 ! 129 #if ! defined key_sed_off 142 #if ! defined key_qco 143 # if ! defined key_sed_off 130 144 IF( .NOT.ln_linssh ) CALL dta_dyn_sf_interp( istp, Nnn ) ! calculate now grid parameters 131 #endif 145 # endif 146 #endif 132 147 CALL stp_ctl ( istp, indic ) ! Time loop: control and print 133 148 istp = istp + 1 … … 209 224 IF( lwm ) CALL ctl_opn( numond, 'output.namelist.dyn', 'REPLACE', 'FORMATTED', 'SEQUENTIAL', -1, -1, .FALSE. ) 210 225 ! open /dev/null file to be able to supress output write easily 226 IF( Agrif_Root() ) THEN 211 227 CALL ctl_opn( numnul, '/dev/null', 'REPLACE', 'FORMATTED', 'SEQUENTIAL', -1, -1, .FALSE. ) 228 #ifdef key_agrif 229 ELSE 230 numnul = Agrif_Parent(numnul) 231 #endif 232 ENDIF 212 233 ! 213 234 ! !--------------------! -
NEMO/branches/2020/dev_r12527_Gurvan_ShallowWater/src/SAO/nemogcm.F90
r12377 r13151 29 29 USE sao_intp 30 30 ! 31 USE in_out_manager ! I/O manager 31 32 USE lib_mpp ! distributed memory computing 32 33 USE mppini ! shared/distributed memory setting (mpp_init routine) … … 139 140 IF( lwm ) CALL ctl_opn( numond, 'output.namelist.dyn', 'REPLACE', 'FORMATTED', 'SEQUENTIAL', -1, -1, .FALSE. ) 140 141 ! open /dev/null file to be able to supress output write easily 142 IF( Agrif_Root() ) THEN 141 143 CALL ctl_opn( numnul, '/dev/null', 'REPLACE', 'FORMATTED', 'SEQUENTIAL', -1, -1, .FALSE. ) 144 #ifdef key_agrif 145 ELSE 146 numnul = Agrif_Parent(numnul) 147 #endif 148 ENDIF 142 149 ! 143 150 ! !--------------------! -
NEMO/branches/2020/dev_r12527_Gurvan_ShallowWater/src/SAS/diawri.F90
r12489 r13151 99 99 ! Output the initial state and forcings 100 100 IF( ninist == 1 ) THEN 101 CALL dia_wri_state( 'output.init', Kmm)101 CALL dia_wri_state( Kmm, 'output.init' ) 102 102 ninist = 0 103 103 ENDIF … … 126 126 END FUNCTION dia_wri_alloc_abl 127 127 128 SUBROUTINE dia_wri( kt )128 SUBROUTINE dia_wri( kt, Kmm ) 129 129 !!--------------------------------------------------------------------- 130 130 !! *** ROUTINE dia_wri *** … … 140 140 !! 141 141 INTEGER, INTENT( in ) :: kt ! ocean time-step index 142 INTEGER, INTENT( in ) :: Kmm ! ocean time level index 142 143 !! 143 144 LOGICAL :: ll_print = .FALSE. ! =T print and flush numout … … 154 155 ! Output the initial state and forcings 155 156 IF( ninist == 1 ) THEN 156 CALL dia_wri_state( 'output.init' )157 CALL dia_wri_state( Kmm, 'output.init' ) 157 158 ninist = 0 158 159 ENDIF … … 257 258 IF( ln_abl ) THEN 258 259 ! Define the ABL grid FILE ( nid_A ) 259 CALL dia_nam( clhstnam, n write, 'grid_ABL' )260 CALL dia_nam( clhstnam, nn_write, 'grid_ABL' ) 260 261 IF(lwp) WRITE(numout,*) " Name of NETCDF file ", clhstnam ! filename 261 262 CALL histbeg( clhstnam, jpi, glamt, jpj, gphit, & ! Horizontal grid: glamt and gphit … … 414 415 #endif 415 416 416 SUBROUTINE dia_wri_state( cdfile_name, Kmm)417 SUBROUTINE dia_wri_state( Kmm, cdfile_name ) 417 418 !!--------------------------------------------------------------------- 418 419 !! *** ROUTINE dia_wri_state *** … … 427 428 !! File 'output.abort.nc' is created in case of abnormal job end 428 429 !!---------------------------------------------------------------------- 430 INTEGER , INTENT( in ) :: Kmm ! ocean time levelindex 429 431 CHARACTER (len=* ), INTENT( in ) :: cdfile_name ! name of the file created 430 INTEGER , INTENT( in ) :: Kmm ! ocean time levelindex431 432 !! 432 433 INTEGER :: inum … … 437 438 IF(lwp) WRITE(numout,*) '~~~~~~~~~~~~~ and forcing fields file created ' 438 439 IF(lwp) WRITE(numout,*) ' and named :', cdfile_name, '...nc' 439 440 #if defined key_si3 441 CALL iom_open( TRIM(cdfile_name), inum, ldwrt = .TRUE., kdlev = jpl ) 442 #else 443 CALL iom_open( TRIM(cdfile_name), inum, ldwrt = .TRUE. ) 444 #endif 445 440 ! 441 CALL iom_open( TRIM(cdfile_name), inum, ldwrt = .TRUE. ) 442 ! 446 443 CALL iom_rstput( 0, 0, inum, 'votemper', ts (:,:,:,jp_tem,Kmm) ) ! now temperature 447 444 CALL iom_rstput( 0, 0, inum, 'vosaline', ts (:,:,:,jp_sal,Kmm) ) ! now salinity … … 456 453 CALL iom_rstput( 0, 0, inum, 'sozotaux', utau ) ! i-wind stress 457 454 CALL iom_rstput( 0, 0, inum, 'sometauy', vtau ) ! j-wind stress 458 455 ! 456 CALL iom_close( inum ) 457 ! 459 458 #if defined key_si3 460 459 IF( nn_ice == 2 ) THEN ! condition needed in case agrif + ice-model but no-ice in child grid 460 CALL iom_open( TRIM(cdfile_name)//'_ice', inum, ldwrt = .TRUE., kdlev = jpl, cdcomp = 'ICE' ) 461 461 CALL ice_wri_state( inum ) 462 ENDIF 463 #endif 464 ! 465 CALL iom_close( inum ) 466 ! 462 CALL iom_close( inum ) 463 ENDIF 464 #endif 465 467 466 END SUBROUTINE dia_wri_state 468 467 -
NEMO/branches/2020/dev_r12527_Gurvan_ShallowWater/src/SAS/nemogcm.F90
r12489 r13151 35 35 USE step_diu ! diurnal bulk SST timestepping (called from here if run offline) 36 36 ! 37 USE in_out_manager ! I/O manager 37 38 USE lib_mpp ! distributed memory computing 38 39 USE mppini ! shared/distributed memory setting (mpp_init routine) … … 256 257 ENDIF 257 258 ! open /dev/null file to be able to supress output write easily 259 IF( Agrif_Root() ) THEN 258 260 CALL ctl_opn( numnul, '/dev/null', 'REPLACE', 'FORMATTED', 'SEQUENTIAL', -1, -1, .FALSE. ) 261 #ifdef key_agrif 262 ELSE 263 numnul = Agrif_Parent(numnul) 264 #endif 265 ENDIF 259 266 ! 260 267 ! !--------------------! -
NEMO/branches/2020/dev_r12527_Gurvan_ShallowWater/src/SAS/sbcssm.F90
r12377 r13151 26 26 USE lib_mpp ! distributed memory computing library 27 27 USE prtctl ! print control 28 USE fldread ! read input fields 28 USE fldread ! read input fields 29 29 USE timing ! Timing 30 30 … … 38 38 LOGICAL :: ln_3d_uve ! specify whether input velocity data is 3D 39 39 LOGICAL :: ln_read_frq ! specify whether we must read frq or not 40 40 41 41 LOGICAL :: l_sasread ! Ice intilisation: =T read a file ; =F anaytical initilaistion 42 42 LOGICAL :: l_initdone = .false. … … 69 69 !! for an off-line simulation using surface processes only 70 70 !! 71 !! ** Method : calculates the position of data 71 !! ** Method : calculates the position of data 72 72 !! - interpolates data if needed 73 73 !!---------------------------------------------------------------------- 74 74 INTEGER, INTENT(in) :: kt ! ocean time-step index 75 75 INTEGER, INTENT(in) :: Kbb, Kmm ! ocean time level indices 76 76 ! (not needed for SAS but needed to keep a consistent interface in sbcmod.F90) 77 77 ! 78 78 INTEGER :: ji, jj ! dummy loop indices … … 82 82 ! 83 83 IF( ln_timing ) CALL timing_start( 'sbc_ssm') 84 84 85 85 IF ( l_sasread ) THEN 86 86 IF( nfld_3d > 0 ) CALL fld_read( kt, 1, sf_ssm_3d ) !== read data at kt time step ==! 87 87 IF( nfld_2d > 0 ) CALL fld_read( kt, 1, sf_ssm_2d ) !== read data at kt time step ==! 88 ! 88 ! 89 89 IF( ln_3d_uve ) THEN 90 90 IF( .NOT. ln_linssh ) THEN 91 e3t_m(:,:) = sf_ssm_3d(jf_e3t)%fnow(:,:,1) * tmask(:,:,1) ! vertical scale factor 91 e3t_m(:,:) = sf_ssm_3d(jf_e3t)%fnow(:,:,1) * tmask(:,:,1) ! vertical scale factor 92 92 ELSE 93 93 e3t_m(:,:) = e3t_0(:,:,1) ! vertical scale factor 94 94 ENDIF 95 95 ssu_m(:,:) = sf_ssm_3d(jf_usp)%fnow(:,:,1) * umask(:,:,1) ! u-velocity 96 ssv_m(:,:) = sf_ssm_3d(jf_vsp)%fnow(:,:,1) * vmask(:,:,1) ! v-velocity 96 ssv_m(:,:) = sf_ssm_3d(jf_vsp)%fnow(:,:,1) * vmask(:,:,1) ! v-velocity 97 97 ELSE 98 98 IF( .NOT. ln_linssh ) THEN 99 e3t_m(:,:) = sf_ssm_2d(jf_e3t)%fnow(:,:,1) * tmask(:,:,1) ! vertical scale factor 99 e3t_m(:,:) = sf_ssm_2d(jf_e3t)%fnow(:,:,1) * tmask(:,:,1) ! vertical scale factor 100 100 ELSE 101 101 e3t_m(:,:) = e3t_0(:,:,1) ! vertical scale factor 102 102 ENDIF 103 103 ssu_m(:,:) = sf_ssm_2d(jf_usp)%fnow(:,:,1) * umask(:,:,1) ! u-velocity 104 ssv_m(:,:) = sf_ssm_2d(jf_vsp)%fnow(:,:,1) * vmask(:,:,1) ! v-velocity 104 ssv_m(:,:) = sf_ssm_2d(jf_vsp)%fnow(:,:,1) * vmask(:,:,1) ! v-velocity 105 105 ENDIF 106 106 ! … … 123 123 ssh (:,:,Kmm) = 0._wp ! - - 124 124 ENDIF 125 125 126 126 IF ( nn_ice == 1 ) THEN 127 127 ts(:,:,1,jp_tem,Kmm) = sst_m(:,:) … … 132 132 uu (:,:,1,Kbb) = ssu_m(:,:) 133 133 vv (:,:,1,Kbb) = ssv_m(:,:) 134 134 135 135 IF(sn_cfctl%l_prtctl) THEN ! print control 136 136 CALL prt_ctl(tab2d_1=sst_m, clinfo1=' sst_m - : ', mask1=tmask ) … … 162 162 !! *** ROUTINE sbc_ssm_init *** 163 163 !! 164 !! ** Purpose : Initialisation of sea surface mean data 165 !!---------------------------------------------------------------------- 166 INTEGER, INTENT(in) :: Kbb, Kmm ! ocean time level indices 167 164 !! ** Purpose : Initialisation of sea surface mean data 165 !!---------------------------------------------------------------------- 166 INTEGER, INTENT(in) :: Kbb, Kmm ! ocean time level indices 167 ! (not needed for SAS but needed to keep a consistent interface in sbcmod.F90) 168 168 INTEGER :: ierr, ierr0, ierr1, ierr2, ierr3 ! return error code 169 169 INTEGER :: ifpr ! dummy loop indice … … 195 195 902 IF( ios > 0 ) CALL ctl_nam ( ios , 'namsbc_sas in configuration namelist' ) 196 196 IF(lwm) WRITE ( numond, namsbc_sas ) 197 ! 197 ! 198 198 IF(lwp) THEN ! Control print 199 199 WRITE(numout,*) ' Namelist namsbc_sas' 200 WRITE(numout,*) ' Initialisation using an input file l_sasread = ', l_sasread 200 WRITE(numout,*) ' Initialisation using an input file l_sasread = ', l_sasread 201 201 WRITE(numout,*) ' Are we supplying a 3D u,v and e3 field ln_3d_uve = ', ln_3d_uve 202 202 WRITE(numout,*) ' Are we reading frq (fraction of qsr absorbed in the 1st T level) ln_read_frq = ', ln_read_frq … … 226 226 ln_closea = .false. 227 227 ENDIF 228 229 ! 228 229 ! 230 230 IF( l_sasread ) THEN ! store namelist information in an array 231 ! 231 ! 232 232 !! following code is a bit messy, but distinguishes between when u,v are 3d arrays and 233 233 !! when we have other 3d arrays that we need to read in … … 275 275 ENDIF 276 276 ! 277 ierr1 = 0 ! default definition if slf_?d(ifpr)%ln_tint = .false. 277 ierr1 = 0 ! default definition if slf_?d(ifpr)%ln_tint = .false. 278 278 IF( nfld_3d > 0 ) THEN 279 279 ALLOCATE( sf_ssm_3d(nfld_3d), STAT=ierr ) ! set sf structure … … 282 282 ENDIF 283 283 DO ifpr = 1, nfld_3d 284 284 ALLOCATE( sf_ssm_3d(ifpr)%fnow(jpi,jpj,jpk) , STAT=ierr0 ) 285 285 IF( slf_3d(ifpr)%ln_tint ) ALLOCATE( sf_ssm_3d(ifpr)%fdta(jpi,jpj,jpk,2) , STAT=ierr1 ) 286 286 IF( ierr0 + ierr1 > 0 ) THEN … … 298 298 ENDIF 299 299 DO ifpr = 1, nfld_2d 300 300 ALLOCATE( sf_ssm_2d(ifpr)%fnow(jpi,jpj,1) , STAT=ierr0 ) 301 301 IF( slf_2d(ifpr)%ln_tint ) ALLOCATE( sf_ssm_2d(ifpr)%fdta(jpi,jpj,1,2) , STAT=ierr1 ) 302 302 IF( ierr0 + ierr1 > 0 ) THEN -
NEMO/branches/2020/dev_r12527_Gurvan_ShallowWater/src/SAS/step.F90
r12377 r13151 78 78 79 79 #if defined key_agrif 80 IF( nstop > 0 ) return ! avoid to go further if an error was detected during previous time step 80 81 kstp = nit000 + Agrif_Nb_Step() 81 82 Kbb_a = Nbb; Kmm_a = Nnn; Krhs_a = Nrhs ! agrif_oce module copies of time level indices … … 109 110 #if defined key_agrif 110 111 !>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>> 111 ! AGRIF 112 ! AGRIF recursive integration 112 113 !<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<< 113 114 CALL Agrif_Integrate_ChildGrids( stp ) 114 115 IF( Agrif_NbStepint() == 0 ) THEN ! AGRIF Update from zoom N to zoom 1 then to Parent116 #if defined key_si3117 CALL Agrif_Update_ice( ) ! update sea-ice118 #endif119 ENDIF120 115 #endif 121 116 … … 126 121 IF( indic < 0 ) THEN 127 122 CALL ctl_stop( 'step: indic < 0' ) 128 CALL dia_wri_state( 'output.abort', Nnn)123 CALL dia_wri_state( Nnn, 'output.abort' ) 129 124 ENDIF 130 IF( kstp == nit000 ) CALL iom_close( numror ) ! close input ocean restart file 125 #if defined key_agrif 126 !>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>> 127 ! AGRIF update 128 !<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<< 129 IF( Agrif_NbStepint() == 0 .AND. nstop == 0 ) THEN ! AGRIF Update from zoom N to zoom 1 then to Parent 130 #if defined key_si3 131 CALL Agrif_Update_ice( ) ! update sea-ice 132 #endif 133 ENDIF 134 #endif 135 !>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>> 136 ! File manipulation at the end of the first time step 137 !<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<< 138 IF( kstp == nit000 ) CALL iom_close( numror ) ! close input ocean restart file 131 139 132 140 !>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>> -
NEMO/branches/2020/dev_r12527_Gurvan_ShallowWater/src/SWE/asminc.F90
r12614 r13151 95 95 !! * Substitutions 96 96 # include "do_loop_substitute.h90" 97 !!st10 98 # include "domzgr_substitute.h90" 99 !!st10 97 100 !!---------------------------------------------------------------------- 98 101 !! NEMO/OCE 4.0 , NEMO Consortium (2018) … … 417 420 & - e2u(ji-1,jj) * e3u(ji-1,jj,jk,Kmm) * u_bkginc(ji-1,jj,jk) & 418 421 & + e1v(ji,jj ) * e3v(ji,jj ,jk,Kmm) * v_bkginc(ji,jj ,jk) & 419 & - e1v(ji,jj-1) * e3v(ji,jj-1,jk,Kmm) * v_bkginc(ji,jj-1,jk) ) / e3t(ji,jj,jk,Kmm) 422 & - e1v(ji,jj-1) * e3v(ji,jj-1,jk,Kmm) * v_bkginc(ji,jj-1,jk) ) & 423 & / e3t(ji,jj,jk,Kmm) 420 424 END_2D 421 425 CALL lbc_lnk( 'asminc', zhdiv, 'T', 1. ) ! lateral boundary cond. (no sign change) … … 758 762 ! 759 763 ssh(:,:,Kbb) = ssh(:,:,Kmm) ! Update before fields 764 !!st11 765 #if ! defined key_qco 760 766 e3t(:,:,:,Kbb) = e3t(:,:,:,Kmm) 761 !!gm why not e3u(:,:,:,Kbb), e3v(:,:,:,Kbb), gdept(:,:,:,Kbb) ???? 767 #endif 768 !!st11 769 !!gm why not e3u(:,:,:,Kbb), e3v(:,:,:,Kbb), gdept(:,:,jk,Kbb) ???? 762 770 ! 763 771 DEALLOCATE( ssh_bkg ) … … 970 978 ! ! set to bottom of a level 971 979 ! DO jk = jpk-1, 2, -1 972 ! IF ((mld > gdepw(ji,jj,jk )) .and. (mld < gdepw(ji,jj,jk+1))) THEN973 ! mld=gdepw(ji,jj,jk+1 )980 ! IF ((mld > gdepw(ji,jj,jk,Kmm)) .and. (mld < gdepw(ji,jj,jk+1,Kmm))) THEN 981 ! mld=gdepw(ji,jj,jk+1,Kmm) 974 982 ! jkmax=jk 975 983 ! ENDIF -
NEMO/branches/2020/dev_r12527_Gurvan_ShallowWater/src/SWE/diawri.F90
r12667 r13151 85 85 !! * Substitutions 86 86 # include "do_loop_substitute.h90" 87 !!st12 88 # include "domzgr_substitute.h90" 87 89 !!---------------------------------------------------------------------- 88 90 !! NEMO/OCE 4.0 , NEMO Consortium (2018) … … 137 139 CALL iom_put("e3v_0", e3v_0(:,:,:) ) 138 140 ! 139 CALL iom_put( "e3t" , e3t(:,:,:,Kmm) ) 140 CALL iom_put( "e3u" , e3u(:,:,:,Kmm) ) 141 CALL iom_put( "e3v" , e3v(:,:,:,Kmm) ) 142 CALL iom_put( "e3w" , e3w(:,:,:,Kmm) ) 143 IF( iom_use("e3tdef") ) & 144 CALL iom_put( "e3tdef" , ( ( e3t(:,:,:,Kmm) - e3t_0(:,:,:) ) / e3t_0(:,:,:) * 100 * tmask(:,:,:) ) ** 2 ) 145 141 !!st13 142 #if ! defined key_qco 143 IF ( iom_use("e3t") .OR. iom_use("e3tdef") ) THEN ! time-varying e3t 144 DO jk = 1, jpk 145 z3d(:,:,jk) = e3t(:,:,jk,Kmm) 146 END DO 147 CALL iom_put( "e3t" , z3d(:,:,:) ) 148 CALL iom_put( "e3tdef" , ( ( z3d(:,:,:) - e3t_0(:,:,:) ) / e3t_0(:,:,:) * 100 * tmask(:,:,:) ) ** 2 ) 149 ENDIF 150 IF ( iom_use("e3u") ) THEN ! time-varying e3u 151 DO jk = 1, jpk 152 z3d(:,:,jk) = e3u(:,:,jk,Kmm) 153 END DO 154 CALL iom_put( "e3u" , z3d(:,:,:) ) 155 ENDIF 156 IF ( iom_use("e3v") ) THEN ! time-varying e3v 157 DO jk = 1, jpk 158 z3d(:,:,jk) = e3v(:,:,jk,Kmm) 159 END DO 160 CALL iom_put( "e3v" , z3d(:,:,:) ) 161 ENDIF 162 IF ( iom_use("e3w") ) THEN ! time-varying e3w 163 DO jk = 1, jpk 164 z3d(:,:,jk) = e3w(:,:,jk,Kmm) 165 END DO 166 CALL iom_put( "e3w" , z3d(:,:,:) ) 167 ENDIF 168 #endif 169 !!st13 146 170 IF( ll_wd ) THEN 147 171 CALL iom_put( "ssh" , (ssh(:,:,Kmm)+ssh_ref)*tmask(:,:,1) ) ! sea surface height (brought back to the reference used for wetting and drying) … … 351 375 ! 352 376 REAL(wp), DIMENSION(jpi,jpj) :: zw2d ! 2D workspace 353 REAL(wp), DIMENSION(jpi,jpj,jpk) :: zw3d ! 3D workspace 377 !!st14 378 REAL(wp), DIMENSION(jpi,jpj,jpk) :: zw3d, ze3t, zgdept ! 3D workspace 354 379 REAL(wp), DIMENSION(:,:,:), ALLOCATABLE :: zw3d_abl ! ABL 3D workspace 355 380 !!---------------------------------------------------------------------- … … 391 416 it = kt 392 417 itmod = kt - nit000 + 1 393 418 !!st15 419 ! store e3t for subsitute 420 DO jk = 1, jpk 421 ze3t (:,:,jk) = e3t (:,:,jk,Kmm) 422 zgdept(:,:,jk) = gdept(:,:,jk,Kmm) 423 END DO 424 !!st15 394 425 395 426 ! 1. Define NETCDF files and fields at beginning of first time step … … 514 545 & jpi, jpj, nh_T, ipk, 1, ipk, nz_T, 32, clop, zsto, zout ) 515 546 IF( .NOT.ln_linssh ) THEN 516 CALL histdef( nid_T, "vovvle3t", "Level thickness" , "m" ,& ! e3t(:,:,:,Kmm)547 CALL histdef( nid_T, "vovvle3t", "Level thickness" , "m" ,& ! ze3t(:,:,:,Kmm) 517 548 & jpi, jpj, nh_T, ipk, 1, ipk, nz_T, 32, clop, zsto, zout ) 518 CALL histdef( nid_T, "vovvldep", "T point depth" , "m" ,& ! e3t(:,:,:,Kmm)549 CALL histdef( nid_T, "vovvldep", "T point depth" , "m" ,& ! ze3t(:,:,:,Kmm) 519 550 & jpi, jpj, nh_T, ipk, 1, ipk, nz_T, 32, clop, zsto, zout ) 520 CALL histdef( nid_T, "vovvldef", "Squared level deformation" , "%^2" ,& ! e3t(:,:,:,Kmm)551 CALL histdef( nid_T, "vovvldef", "Squared level deformation" , "%^2" ,& ! ze3t(:,:,:,Kmm) 521 552 & jpi, jpj, nh_T, ipk, 1, ipk, nz_T, 32, clop, zsto, zout ) 522 553 ENDIF … … 700 731 WRITE(numout,*) '~~~~~~ ' 701 732 ENDIF 702 733 !!st16 703 734 IF( .NOT.ln_linssh ) THEN 704 CALL histwrite( nid_T, "votemper", it, ts(:,:,:,jp_tem,Kmm) * e3t(:,:,:,Kmm) , ndim_T , ndex_T ) ! heat content 705 CALL histwrite( nid_T, "vosaline", it, ts(:,:,:,jp_sal,Kmm) * e3t(:,:,:,Kmm) , ndim_T , ndex_T ) ! salt content 706 CALL histwrite( nid_T, "sosstsst", it, ts(:,:,1,jp_tem,Kmm) * e3t(:,:,1,Kmm) , ndim_hT, ndex_hT ) ! sea surface heat content 707 CALL histwrite( nid_T, "sosaline", it, ts(:,:,1,jp_sal,Kmm) * e3t(:,:,1,Kmm) , ndim_hT, ndex_hT ) ! sea surface salinity content 735 CALL histwrite( nid_T, "votemper", it, ts(:,:,:,jp_tem,Kmm) * ze3t(:,:,:) , ndim_T , ndex_T ) ! heat content 736 CALL histwrite( nid_T, "vosaline", it, ts(:,:,:,jp_sal,Kmm) * ze3t(:,:,:) , ndim_T , ndex_T ) ! salt content 737 CALL histwrite( nid_T, "sosstsst", it, ts(:,:,1,jp_tem,Kmm) * ze3t(:,:,1) , ndim_hT, ndex_hT ) ! sea surface heat content 738 CALL histwrite( nid_T, "sosaline", it, ts(:,:,1,jp_sal,Kmm) * ze3t(:,:,1) , ndim_hT, ndex_hT ) ! sea surface salinity content 739 !!st16 708 740 ELSE 709 741 CALL histwrite( nid_T, "votemper", it, ts(:,:,:,jp_tem,Kmm) , ndim_T , ndex_T ) ! temperature … … 713 745 ENDIF 714 746 IF( .NOT.ln_linssh ) THEN 715 zw3d(:,:,:) = ( ( e3t(:,:,:,Kmm) - e3t_0(:,:,:) ) / e3t_0(:,:,:) * 100 * tmask(:,:,:) ) ** 2 716 CALL histwrite( nid_T, "vovvle3t", it, e3t (:,:,:,Kmm) , ndim_T , ndex_T ) ! level thickness 717 CALL histwrite( nid_T, "vovvldep", it, gdept(:,:,:,Kmm) , ndim_T , ndex_T ) ! t-point depth 747 !!st17 if ! defined key_qco 748 zw3d(:,:,:) = ( ( ze3t(:,:,:) - e3t_0(:,:,:) ) / e3t_0(:,:,:) * 100 * tmask(:,:,:) ) ** 2 749 CALL histwrite( nid_T, "vovvle3t", it, ze3t (:,:,:) , ndim_T , ndex_T ) ! level thickness 750 CALL histwrite( nid_T, "vovvldep", it, zgdept , ndim_T , ndex_T ) ! t-point depth 751 !!st17 718 752 CALL histwrite( nid_T, "vovvldef", it, zw3d , ndim_T , ndex_T ) ! level thickness deformation 719 753 ENDIF … … 854 888 !! 855 889 INTEGER :: inum, jk 890 !!st18 TBR 891 REAL(wp), DIMENSION(jpi,jpj,jpk) :: ze3t, zgdept ! 3D workspace !!st patch to use substitution 856 892 !!---------------------------------------------------------------------- 857 893 ! … … 860 896 IF(lwp) WRITE(numout,*) '~~~~~~~~~~~~~ and forcing fields file created ' 861 897 IF(lwp) WRITE(numout,*) ' and named :', cdfile_name, '...nc' 862 898 !!st19 TBR 899 DO jk = 1, jpk 900 ze3t(:,:,jk) = e3t(:,:,jk,Kmm) 901 zgdept(:,:,jk) = gdept(:,:,jk,Kmm) 902 END DO 903 !!st19 863 904 #if defined key_si3 864 905 CALL iom_open( TRIM(cdfile_name), inum, ldwrt = .TRUE., kdlev = jpl ) … … 878 919 ENDIF 879 920 CALL iom_rstput( 0, 0, inum, 'risfdep', risfdep ) ! now k-velocity 880 CALL iom_rstput( 0, 0, inum, 'ht' , ht 921 CALL iom_rstput( 0, 0, inum, 'ht' , ht(:,:) ) ! now water column height 881 922 882 923 IF ( ln_isf ) THEN … … 885 926 CALL iom_rstput( 0, 0, inum, 'rhisf_cav_tbl', rhisf_tbl_cav ) ! now k-velocity 886 927 CALL iom_rstput( 0, 0, inum, 'rfrac_cav_tbl', rfrac_tbl_cav ) ! now k-velocity 887 CALL iom_rstput( 0, 0, inum, 'misfkb_cav', REAL(misfkb_cav, 8)) ! now k-velocity888 CALL iom_rstput( 0, 0, inum, 'misfkt_cav', REAL(misfkt_cav, 8)) ! now k-velocity889 CALL iom_rstput( 0, 0, inum, 'mskisf_cav', REAL(mskisf_cav, 8), ktype = jp_i1 )928 CALL iom_rstput( 0, 0, inum, 'misfkb_cav', REAL(misfkb_cav,wp) ) ! now k-velocity 929 CALL iom_rstput( 0, 0, inum, 'misfkt_cav', REAL(misfkt_cav,wp) ) ! now k-velocity 930 CALL iom_rstput( 0, 0, inum, 'mskisf_cav', REAL(mskisf_cav,wp), ktype = jp_i1 ) 890 931 END IF 891 932 IF (ln_isfpar_mlt) THEN 892 CALL iom_rstput( 0, 0, inum, 'isfmsk_par', REAL(mskisf_par, 8)) ! now k-velocity933 CALL iom_rstput( 0, 0, inum, 'isfmsk_par', REAL(mskisf_par,wp) ) ! now k-velocity 893 934 CALL iom_rstput( 0, 0, inum, 'fwfisf_par', fwfisf_par ) ! now k-velocity 894 935 CALL iom_rstput( 0, 0, inum, 'rhisf_par_tbl', rhisf_tbl_par ) ! now k-velocity 895 936 CALL iom_rstput( 0, 0, inum, 'rfrac_par_tbl', rfrac_tbl_par ) ! now k-velocity 896 CALL iom_rstput( 0, 0, inum, 'misfkb_par', REAL(misfkb_par, 8)) ! now k-velocity897 CALL iom_rstput( 0, 0, inum, 'misfkt_par', REAL(misfkt_par, 8)) ! now k-velocity898 CALL iom_rstput( 0, 0, inum, 'mskisf_par', REAL(mskisf_par, 8), ktype = jp_i1 )937 CALL iom_rstput( 0, 0, inum, 'misfkb_par', REAL(misfkb_par,wp) ) ! now k-velocity 938 CALL iom_rstput( 0, 0, inum, 'misfkt_par', REAL(misfkt_par,wp) ) ! now k-velocity 939 CALL iom_rstput( 0, 0, inum, 'mskisf_par', REAL(mskisf_par,wp), ktype = jp_i1 ) 899 940 END IF 900 941 END IF 901 942 ! 902 943 IF( ALLOCATED(ahtu) ) THEN 903 944 CALL iom_rstput( 0, 0, inum, 'ahtu', ahtu ) ! aht at u-point … … 914 955 CALL iom_rstput( 0, 0, inum, 'sozotaux', utau ) ! i-wind stress 915 956 CALL iom_rstput( 0, 0, inum, 'sometauy', vtau ) ! j-wind stress 916 IF( .NOT.ln_linssh ) THEN 917 CALL iom_rstput( 0, 0, inum, 'vovvldep', gdept(:,:,:,Kmm) ) ! T-cell depth 918 CALL iom_rstput( 0, 0, inum, 'vovvle3t', e3t(:,:,:,Kmm) ) ! T-cell thickness 957 !!st20 TBR 958 IF( .NOT.ln_linssh ) THEN 959 CALL iom_rstput( 0, 0, inum, 'vovvldep', zgdept ) ! T-cell depth 960 CALL iom_rstput( 0, 0, inum, 'vovvle3t', ze3t ) ! T-cell thickness 919 961 END IF 920 962 IF( ln_wave .AND. ln_sdw ) THEN -
NEMO/branches/2020/dev_r12527_Gurvan_ShallowWater/src/SWE/dom_oce.F90
r12614 r13151 71 71 ! ! = 6 cyclic East-West AND North fold F-point pivot 72 72 ! ! = 7 bi-cyclic East-West AND North-South 73 LOGICAL, PUBLIC :: l_Iperio, l_Jperio ! should we explicitely take care I/J periodicity 74 75 ! !domain MPP decomposition parameters73 LOGICAL, PUBLIC :: l_Iperio, l_Jperio ! should we explicitely take care I/J periodicity 74 75 ! !: domain MPP decomposition parameters 76 76 INTEGER , PUBLIC :: nimpp, njmpp !: i- & j-indexes for mpp-subdomain left bottom 77 77 INTEGER , PUBLIC :: nreci, nrecj !: overlap region in i and j … … 136 136 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: e3vw_0 !: vw-vert. scale factor [m] 137 137 ! ! time-dependent scale factors 138 !!st1 139 #if ! defined key_qco 138 140 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:,:) :: e3t, e3u, e3v, e3w, e3uw, e3vw !: vert. scale factor [m] 139 141 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: e3f !: F-point vert. scale factor [m] 142 #endif 143 ! ! time-dependent ratio ssh / h_0 144 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: r3t, r3u, r3v !: time-dependent ratio at t-, u- and v-point [-] 145 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: r3f !: mid-time-level ratio at f-point [-] 146 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: r3t_f, r3u_f, r3v_f !: now time-filtered ratio at t-, u- and v-point [-] 140 147 141 148 ! ! reference depths of cells 142 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: gdept_0 !: t- depth [m]143 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: gdepw_0 !: w- depth [m]144 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: gde3w_0 !: w- depth (sum of e3w) [m]149 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: gdept_0 !: t- depth [m] 150 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: gdepw_0 !: w- depth [m] 151 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: gde3w_0 !: w- depth (sum of e3w) [m] 145 152 ! ! time-dependent depths of cells 146 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:,:) :: gdept, gdepw 147 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: gde3w 153 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:,:) :: gdept, gdepw 154 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: gde3w 155 !!st2 156 ! ! reference heights of ocean water column and its inverse 157 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: ht_0, r1_ht_0 !: t-depth [m] and [1/m] 158 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: hu_0, r1_hu_0 !: u-depth [m] and [1/m] 159 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: hv_0, r1_hv_0 !: v-depth [m] and [1/m] 160 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: hf_0, r1_hf_0 !: f-depth [m] and [1/m] 161 ! ! time-dependent heights of ocean water column 162 #if ! defined key_qco 163 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: ht !: t-points [m] 164 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: hu, r1_hu !: u-depth [m] and [1/m] 165 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: hv, r1_hv !: v-depth [m] and [1/m] 166 #endif 167 !!st2 148 168 149 ! ! reference heights of water column150 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: ht_0 !: t-depth [m]151 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: hu_0 !: u-depth [m]152 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: hv_0 !: v-depth [m]153 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: hf_0 !: f-depth [m]154 ! ! inverse of reference heights of water column155 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: r1_ht_0 !: t-depth [1/m]156 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: r1_hu_0 !: u-depth [1/m]157 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: r1_hv_0 !: v-depth [1/m]158 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: r1_hf_0 !: f-depth [1/m]159 160 ! time-dependent heights of water column161 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: ht !: height of water column at T-points [m]162 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: hu, hv, r1_hu, r1_hv !: height of water column [m] and reciprocal [1/m]163 164 169 INTEGER, PUBLIC :: nla10 !: deepest W level Above ~10m (nlb10 - 1) 165 170 INTEGER, PUBLIC :: nlb10 !: shallowest W level Bellow ~10m (nla10 + 1) … … 176 181 !! --------------------------------------------------------------------- 177 182 !!gm Proposition of new name for top/bottom vertical indices 178 ! INTEGER , PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: mtk_t, mtk_u, mtk_v !: top first wet T-, U-, V-, F-level (ISF)179 ! INTEGER , PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: mbk_t, mbk_u, mbk_v !: bottom last wet T-, U-and V-level183 ! INTEGER , PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: mtk_t, mtk_u, mtk_v !: top first wet T-, U-, and V-level (ISF) 184 ! INTEGER , PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: mbk_t, mbk_u, mbk_v !: bottom last wet T-, U-, and V-level 180 185 !!gm 181 186 INTEGER , PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: mbkt, mbku, mbkv !: bottom last wet T-, U- and V-level … … 244 249 END FUNCTION Agrif_CFixed 245 250 #endif 246 251 !!st3: dom_oce_alloc modified to ease the ifdef if necessary (gm stuff) 247 252 INTEGER FUNCTION dom_oce_alloc() 248 253 !!---------------------------------------------------------------------- 249 INTEGER, DIMENSION(12) :: ierr 254 INTEGER :: ii 255 INTEGER, DIMENSION(30) :: ierr 250 256 !!---------------------------------------------------------------------- 251 i err(:) = 0257 ii = 0 ; ierr(:) = 0 252 258 ! 253 ALLOCATE( mig(jpi), mjg(jpj), STAT=ierr(1) ) 254 ! 255 ALLOCATE( mi0(jpiglo) , mi1 (jpiglo), mj0(jpjglo) , mj1 (jpjglo) , & 256 & tpol(jpiglo) , fpol(jpiglo) , STAT=ierr(2) ) 257 ! 259 ii = ii+1 260 ALLOCATE( mig(jpi), mjg(jpj), STAT=ierr(ii) ) 261 ! 262 ii = ii+1 263 ALLOCATE( mi0 (jpiglo) , mi1 (jpiglo), mj0(jpjglo) , mj1 (jpjglo) , & 264 & tpol(jpiglo) , fpol(jpiglo) , STAT=ierr(ii) ) 265 ! 266 ii = ii+1 258 267 ALLOCATE( glamt(jpi,jpj) , glamu(jpi,jpj) , glamv(jpi,jpj) , glamf(jpi,jpj) , & 259 268 & gphit(jpi,jpj) , gphiu(jpi,jpj) , gphiv(jpi,jpj) , gphif(jpi,jpj) , & … … 266 275 & e1e2v(jpi,jpj) , r1_e1e2v(jpi,jpj) , e1_e2v(jpi,jpj) , & 267 276 & e1e2f(jpi,jpj) , r1_e1e2f(jpi,jpj) , & 268 & ff_f (jpi,jpj) , ff_t (jpi,jpj) , STAT=ierr(3) ) 269 ! 277 & ff_f (jpi,jpj) , ff_t (jpi,jpj) , STAT=ierr(ii) ) 278 ! 279 ii = ii+1 280 ALLOCATE( e3t_0(jpi,jpj,jpk) , e3u_0 (jpi,jpj,jpk) , e3v_0 (jpi,jpj,jpk) , e3f_0(jpi,jpj,jpk) , & 281 & e3w_0(jpi,jpj,jpk) , e3uw_0(jpi,jpj,jpk) , e3vw_0(jpi,jpj,jpk) , STAT=ierr(ii) ) 282 ! 283 ii = ii+1 270 284 ALLOCATE( gdept_0(jpi,jpj,jpk) , gdepw_0(jpi,jpj,jpk) , gde3w_0(jpi,jpj,jpk) , & 271 & gdept (jpi,jpj,jpk,jpt) , gdepw (jpi,jpj,jpk,jpt) , gde3w (jpi,jpj,jpk) , STAT=ierr(4) ) 272 ! 273 ALLOCATE( e3t_0(jpi,jpj,jpk) , e3u_0(jpi,jpj,jpk) , e3v_0(jpi,jpj,jpk) , e3f_0(jpi,jpj,jpk) , e3w_0(jpi,jpj,jpk) , & 274 & e3t (jpi,jpj,jpk,jpt) , e3u (jpi,jpj,jpk,jpt) , e3v (jpi,jpj,jpk,jpt) , e3f (jpi,jpj,jpk) , e3w (jpi,jpj,jpk,jpt) , & 275 & e3uw_0(jpi,jpj,jpk) , e3vw_0(jpi,jpj,jpk) , & 276 & e3uw (jpi,jpj,jpk,jpt) , e3vw (jpi,jpj,jpk,jpt) , STAT=ierr(5) ) 277 ! 278 ALLOCATE( ht_0(jpi,jpj) , hu_0(jpi,jpj) , hv_0(jpi,jpj) , hf_0(jpi,jpj) , & 279 & r1_ht_0(jpi,jpj) , r1_hu_0(jpi,jpj) , r1_hv_0(jpi,jpj) , r1_hf_0(jpi,jpj) , & 280 & ht (jpi,jpj) , hu (jpi,jpj,jpt) , hv (jpi,jpj,jpt) , & 281 & r1_hu (jpi,jpj,jpt) , r1_hv (jpi,jpj,jpt) , STAT=ierr(6) ) 282 ! 283 ALLOCATE( risfdep(jpi,jpj) , bathy(jpi,jpj) , STAT=ierr(7) ) 284 ! 285 ALLOCATE( gdept_1d(jpk) , gdepw_1d(jpk) , e3t_1d(jpk) , e3w_1d(jpk) , STAT=ierr(8) ) 286 ! 287 ALLOCATE( tmask_i(jpi,jpj) , tmask_h(jpi,jpj) , & 285 & gdept (jpi,jpj,jpk,jpt) , gdepw (jpi,jpj,jpk,jpt) , gde3w (jpi,jpj,jpk) , STAT=ierr(ii) ) 286 ! 287 !!st4 288 #if ! defined key_qco 289 ii = ii+1 290 ALLOCATE( e3t(jpi,jpj,jpk,jpt) , e3u (jpi,jpj,jpk,jpt) , e3v (jpi,jpj,jpk,jpt) , e3f(jpi,jpj,jpk) , & 291 & e3w(jpi,jpj,jpk,jpt) , e3uw(jpi,jpj,jpk,jpt) , e3vw(jpi,jpj,jpk,jpt) , STAT=ierr(ii) ) 292 #endif 293 !!st4 294 ! 295 ii = ii+1 296 ALLOCATE( r3t (jpi,jpj,jpt) , r3u (jpi,jpj,jpt) , r3v (jpi,jpj,jpt) , r3f (jpi,jpj) , & 297 & r3t_f(jpi,jpj) , r3u_f(jpi,jpj) , r3v_f(jpi,jpj) , STAT=ierr(ii) ) 298 ! 299 ii = ii+1 300 ALLOCATE( ht_0(jpi,jpj) , hu_0(jpi,jpj) , hv_0(jpi,jpj) , hf_0(jpi,jpj) , & 301 & r1_ht_0(jpi,jpj) , r1_hu_0(jpi,jpj) , r1_hv_0(jpi,jpj), r1_hf_0(jpi,jpj) , STAT=ierr(ii) ) 302 ! 303 #if ! defined key_qco 304 ii = ii+1 305 ALLOCATE( ht (jpi,jpj) , hu (jpi,jpj,jpt), hv (jpi,jpj,jpt) , & 306 & r1_hu (jpi,jpj,jpt), r1_hv (jpi,jpj,jpt) , STAT=ierr(ii) ) 307 #endif 308 ! 309 ii = ii+1 310 ALLOCATE( risfdep(jpi,jpj) , bathy(jpi,jpj) , STAT=ierr(ii) ) 311 ! 312 ii = ii+1 313 ALLOCATE( gdept_1d(jpk) , gdepw_1d(jpk) , e3t_1d(jpk) , e3w_1d(jpk) , STAT=ierr(ii) ) 314 ! 315 ii = ii+1 316 ALLOCATE( tmask_i(jpi,jpj) , tmask_h(jpi,jpj) , & 288 317 & ssmask (jpi,jpj) , ssumask(jpi,jpj) , ssvmask(jpi,jpj) , ssfmask(jpi,jpj) , & 289 & mbkt (jpi,jpj) , mbku (jpi,jpj) , mbkv (jpi,jpj) , STAT=ierr(9) ) 290 ! 291 ALLOCATE( mikt(jpi,jpj), miku(jpi,jpj), mikv(jpi,jpj), mikf(jpi,jpj), STAT=ierr(10) ) 292 ! 293 ALLOCATE( tmask(jpi,jpj,jpk) , umask(jpi,jpj,jpk) , & 294 & vmask(jpi,jpj,jpk) , fmask(jpi,jpj,jpk) , STAT=ierr(11) ) 295 ! 296 ALLOCATE( wmask(jpi,jpj,jpk) , wumask(jpi,jpj,jpk), wvmask(jpi,jpj,jpk) , STAT=ierr(12) ) 318 & mbkt (jpi,jpj) , mbku (jpi,jpj) , mbkv (jpi,jpj) , STAT=ierr(ii) ) 319 ! 320 ii = ii+1 321 ALLOCATE( mikt(jpi,jpj), miku(jpi,jpj), mikv(jpi,jpj), mikf(jpi,jpj), STAT=ierr(ii) ) 322 ! 323 ii = ii+1 324 ALLOCATE( tmask(jpi,jpj,jpk) , umask(jpi,jpj,jpk) , & 325 & vmask(jpi,jpj,jpk) , fmask(jpi,jpj,jpk) , STAT=ierr(ii) ) 326 ! 327 ii = ii+1 328 ALLOCATE( wmask(jpi,jpj,jpk) , wumask(jpi,jpj,jpk), wvmask(jpi,jpj,jpk) , STAT=ierr(ii) ) 297 329 ! 298 330 dom_oce_alloc = MAXVAL(ierr) -
NEMO/branches/2020/dev_r12527_Gurvan_ShallowWater/src/SWE/domain.F90
r12822 r13151 34 34 USE dommsk ! domain: set the mask system 35 35 USE domwri ! domain: write the meshmask file 36 !!st5 37 #if ! defined key_qco 36 38 USE domvvl ! variable volume 39 #else 40 USE domqco ! variable volume 41 #endif 42 !!st5 37 43 USE c1d ! 1D configuration 38 44 USE dyncor_c1d ! 1D configuration: Coriolis term (cor_c1d routine) … … 78 84 CHARACTER (len=*), INTENT(in) :: cdstr ! model: NEMO or SAS. Determines core restart variables 79 85 ! 80 INTEGER :: ji, jj, jk, ik ! dummy loop indices 86 !!st6 87 INTEGER :: ji, jj, jk, jt ! dummy loop indices 88 !!st6 81 89 INTEGER :: iconf = 0 ! local integers 82 90 CHARACTER (len=64) :: cform = "(A12, 3(A13, I7))" … … 114 122 CASE( 7 ) ; WRITE(numout,*) ' (i.e. cyclic east-west and north-south)' 115 123 CASE DEFAULT 116 CALL ctl_stop( ' jperio is out of range' )124 CALL ctl_stop( 'dom_init: jperio is out of range' ) 117 125 END SELECT 118 126 WRITE(numout,*) ' Ocean model configuration used:' … … 144 152 IF( ln_closea ) CALL dom_clo ! Read in masks to define closed seas and lakes 145 153 146 CALL dom_zgr( ik_top, ik_bot ) ! Vertical mesh and bathymetry 154 CALL dom_zgr( ik_top, ik_bot ) ! Vertical mesh and bathymetry (return top and bottom ocean t-level indices) 147 155 148 156 CALL dom_msk( ik_top, ik_bot ) ! Masks 149 150 ht_0(:,:) = 0._wp 157 ! 158 ht_0(:,:) = 0._wp ! Reference ocean thickness 151 159 hu_0(:,:) = 0._wp 152 160 hv_0(:,:) = 0._wp … … 190 198 ! r1_e1e2t(ji,jj) = r1_e1e2t(ji,jj) / zcoeff 191 199 !!an45 200 !!st7 : make it easier to use key_qco condition (gm stuff) 201 #if defined key_qco 202 ! !== initialisation of time varying coordinate ==! Quasi-Euerian coordinate case 203 ! 204 IF( .NOT.l_offline ) CALL dom_qco_init( Kbb, Kmm, Kaa ) 205 ! 206 IF( ln_linssh ) CALL ctl_stop('STOP','domain: key_qco and ln_linssh = T are incompatible') 207 ! 208 #else 192 209 ! !== time varying part of coordinate system ==! 193 210 ! 194 211 IF( ln_linssh ) THEN != Fix in time : set to the reference one for all 195 !196 ! before ! now ! after !197 gdept(:,:,:, Kbb) = gdept_0 ; gdept(:,:,:,Kmm) = gdept_0 ; gdept(:,:,:,Kaa) = gdept_0 ! depth of grid-points198 gdepw(:,:,:, Kbb) = gdepw_0 ; gdepw(:,:,:,Kmm) = gdepw_0 ; gdepw(:,:,:,Kaa) = gdepw_0 !199 gde3w = gde3w_0 ! --- !200 !201 e3t(:,:,:,Kbb) = e3t_0 ; e3t(:,:,:,Kmm) = e3t_0 ; e3t(:,:,:,Kaa) = e3t_0 ! scale factors202 e3u(:,:,:,Kbb) = e3u_0 ; e3u(:,:,:,Kmm) = e3u_0 ; e3u(:,:,:,Kaa) = e3u_0 !203 e3v(:,:,:,Kbb) = e3v_0 ; e3v(:,:,:,Kmm) = e3v_0 ; e3v(:,:,:,Kaa) = e3v_0 !204 e3f = e3f_0 ! --- !205 e3w(:,:,:,Kbb) = e3w_0 ; e3w(:,:,:,Kmm) = e3w_0 ; e3w(:,:,:,Kaa) = e3w_0 !206 e3uw(:,:,:,Kbb) = e3uw_0 ; e3uw(:,:,:,Kmm) = e3uw_0 ; e3uw(:,:,:,Kaa) = e3uw_0 !207 e3vw(:,:,:,Kbb) = e3vw_0 ; e3vw(:,:,:,Kmm) = e3vw_0 ; e3vw(:,:,:,Kaa) = e3vw_0 !208 !209 z1_hu_0(:,:) = ssumask(:,:) / ( hu_0(:,:) + 1._wp - ssumask(:,:) ) ! _i mask due to ISF210 z1_hv_0(:,:) = ssvmask(:,:) / ( hv_0(:,:) + 1._wp - ssvmask(:,:))211 ! 212 ! before ! now ! after !213 ht = ht_0 ! ! water column thickness214 hu(:,:,Kbb) = hu_0 ; hu(:,:,Kmm) = hu_0 ; hu(:,:,Kaa) = hu_0 !215 hv(:,:,Kbb) = hv_0 ; hv(:,:,Kmm) = hv_0 ; hv(:,:,Kaa) = hv_0 !216 r1_h u(:,:,Kbb) = z1_hu_0 ; r1_hu(:,:,Kmm) = z1_hu_0 ; r1_hu(:,:,Kaa) = z1_hu_0 ! inverse of water column thickness217 r1_hv(:,:,Kbb) = z1_hv_0 ; r1_hv(:,:,Kmm) = z1_hv_0 ; r1_hv(:,:,Kaa) = z1_hv_0 !218 !212 ! 213 DO jt = 1, jpt ! depth of t- and w-grid-points 214 gdept(:,:,:,jt) = gdept_0(:,:,:) 215 gdepw(:,:,:,jt) = gdepw_0(:,:,:) 216 END DO 217 gde3w(:,:,:) = gde3w_0(:,:,:) ! = gdept as the sum of e3t 218 ! 219 DO jt = 1, jpt ! vertical scale factors 220 e3t(:,:,:,jt) = e3t_0(:,:,:) 221 e3u(:,:,:,jt) = e3u_0(:,:,:) 222 e3v(:,:,:,jt) = e3v_0(:,:,:) 223 e3w(:,:,:,jt) = e3w_0(:,:,:) 224 e3uw(:,:,:,jt) = e3uw_0(:,:,:) 225 e3vw(:,:,:,jt) = e3vw_0(:,:,:) 226 END DO 227 e3f(:,:,:) = e3f_0(:,:,:) 228 ! 229 DO jt = 1, jpt ! water column thickness and its inverse 230 hu(:,:,jt) = hu_0(:,:) 231 hv(:,:,jt) = hv_0(:,:) 232 r1_hu(:,:,jt) = r1_hu_0(:,:) 233 r1_hv(:,:,jt) = r1_hv_0(:,:) 234 END DO 235 ht(:,:) = ht_0(:,:) 219 236 ! 220 237 ELSE != time varying : initialize before/now/after variables 221 238 ! 222 IF( .NOT.l_offline ) CALL dom_vvl_init( Kbb, Kmm, Kaa ) 223 ! 224 ENDIF 239 IF( .NOT.l_offline ) CALL dom_vvl_init( Kbb, Kmm, Kaa ) 240 ! 241 ENDIF 242 #endif 243 !!st7 225 244 ! 226 245 IF( lk_c1d ) CALL cor_c1d ! 1D configuration: Coriolis set at T-point … … 238 257 WRITE(numout,*) 239 258 ENDIF 240 241 259 ! 242 260 END SUBROUTINE dom_init -
NEMO/branches/2020/dev_r12527_Gurvan_ShallowWater/src/SWE/domvvl.F90
r13005 r13151 1 1 2 MODULE domvvl 2 3 !!====================================================================== … … 11 12 !!---------------------------------------------------------------------- 12 13 13 !!----------------------------------------------------------------------14 !! dom_vvl_init : define initial vertical scale factors, depths and column thickness15 !! dom_vvl_sf_nxt : Compute next vertical scale factors16 !! dom_vvl_sf_update : Swap vertical scale factors and update the vertical grid17 !! dom_vvl_interpol : Interpolate vertical scale factors from one grid point to another18 !! dom_vvl_rst : read/write restart file19 !! dom_vvl_ctl : Check the vvl options20 !!----------------------------------------------------------------------21 14 USE oce ! ocean dynamics and tracers 22 15 USE phycst ! physical constant … … 36 29 PRIVATE 37 30 38 PUBLIC dom_vvl_init ! called by domain.F9039 PUBLIC dom_vvl_zgr ! called by isfcpl.F9040 PUBLIC dom_vvl_sf_nxt ! called by step.F9041 PUBLIC dom_vvl_sf_update ! called by step.F9042 PUBLIC dom_vvl_interpol ! called by dynnxt.F9043 44 31 ! !!* Namelist nam_vvl 45 32 LOGICAL , PUBLIC :: ln_vvl_zstar = .FALSE. ! zstar vertical coordinate … … 62 49 REAL(wp) , ALLOCATABLE, SAVE, DIMENSION(:,:) :: frq_rst_e3t ! retoring period for scale factors 63 50 REAL(wp) , ALLOCATABLE, SAVE, DIMENSION(:,:) :: frq_rst_hdv ! retoring period for low freq. divergence 64 51 !!stoops 52 #if defined key_qco 53 !!---------------------------------------------------------------------- 54 !! 'key_qco' EMPTY MODULE Quasi-Eulerian vertical coordonate 55 !!---------------------------------------------------------------------- 56 #else 57 !!---------------------------------------------------------------------- 58 !! Default key Old management of time varying vertical coordinate 59 !!---------------------------------------------------------------------- 60 !!st 61 !!---------------------------------------------------------------------- 62 !! dom_vvl_init : define initial vertical scale factors, depths and column thickness 63 !! dom_vvl_sf_nxt : Compute next vertical scale factors 64 !! dom_vvl_sf_update : Swap vertical scale factors and update the vertical grid 65 !! dom_vvl_interpol : Interpolate vertical scale factors from one grid point to another 66 !! dom_vvl_rst : read/write restart file 67 !! dom_vvl_ctl : Check the vvl options 68 !!---------------------------------------------------------------------- 69 70 PUBLIC dom_vvl_init ! called by domain.F90 71 PUBLIC dom_vvl_zgr ! called by isfcpl.F90 72 PUBLIC dom_vvl_sf_nxt ! called by step.F90 73 PUBLIC dom_vvl_sf_update ! called by step.F90 74 PUBLIC dom_vvl_interpol ! called by dynnxt.F90 75 PUBLIC dom_vvl_interpol_st! called by dynnxt.F90 76 PUBLIC dom_vvl_sf_nxt_st ! called by step.F90 77 PUBLIC dom_vvl_sf_update_st 78 !!st 79 65 80 !! * Substitutions 66 81 # include "do_loop_substitute.h90" … … 132 147 e3t(:,:,jpk,Kaa) = e3t_0(:,:,jpk) ! last level always inside the sea floor set one for all 133 148 ! 134 CALL dom_vvl_zgr (Kbb, Kmm, Kaa) ! interpolation scale factor, depth and water column149 CALL dom_vvl_zgr_st(Kbb, Kmm, Kaa) ! interpolation scale factor, depth and water column 135 150 ! 136 151 END SUBROUTINE dom_vvl_init … … 290 305 END SUBROUTINE dom_vvl_zgr 291 306 307 308 SUBROUTINE dom_vvl_zgr_st(Kbb, Kmm, Kaa) 309 !!---------------------------------------------------------------------- 310 !! *** ROUTINE dom_vvl_init *** 311 !! 312 !! ** Purpose : Interpolation of all scale factors, 313 !! depths and water column heights 314 !! 315 !! ** Method : - interpolate scale factors 316 !! 317 !! ** Action : - e3t_(n/b) and tilde_e3t_(n/b) 318 !! - Regrid: e3(u/v)_n 319 !! e3(u/v)_b 320 !! e3w_n 321 !! e3(u/v)w_b 322 !! e3(u/v)w_n 323 !! gdept_n, gdepw_n and gde3w_n 324 !! - h(t/u/v)_0 325 !! - frq_rst_e3t and frq_rst_hdv 326 !! 327 !! Reference : Leclair, M., and G. Madec, 2011, Ocean Modelling. 328 !!---------------------------------------------------------------------- 329 INTEGER, INTENT(in) :: Kbb, Kmm, Kaa 330 !!---------------------------------------------------------------------- 331 INTEGER :: ji, jj, jk 332 INTEGER :: ii0, ii1, ij0, ij1 333 REAL(wp):: zcoef 334 !!---------------------------------------------------------------------- 335 ! 336 ! !== Set of all other vertical scale factors ==! (now and before) 337 ! ! Horizontal interpolation of e3t 338 CALL dom_vvl_interpol_st( r3u(:,:,Kbb), e3u(:,:,:,Kbb), 'U' ) ! from T to U 339 CALL dom_vvl_interpol_st( r3u(:,:,Kmm), e3u(:,:,:,Kmm), 'U' ) 340 CALL dom_vvl_interpol_st( r3v(:,:,Kbb), e3v(:,:,:,Kbb), 'V' ) ! from T to V 341 CALL dom_vvl_interpol_st( r3v(:,:,Kmm), e3v(:,:,:,Kmm), 'V' ) 342 CALL dom_vvl_interpol_st( r3f(:,:), e3f(:,:,:), 'F' ) ! from U to F 343 ! ! Vertical interpolation of e3t,u,v 344 CALL dom_vvl_interpol_st( r3t(:,:,Kmm), e3w (:,:,:,Kmm), 'W' ) ! from T to W 345 CALL dom_vvl_interpol_st( r3t(:,:,Kbb), e3w (:,:,:,Kbb), 'W' ) 346 CALL dom_vvl_interpol_st( r3u(:,:,Kmm), e3uw(:,:,:,Kmm), 'UW' ) ! from U to UW 347 CALL dom_vvl_interpol_st( r3u(:,:,Kbb), e3uw(:,:,:,Kbb), 'UW' ) 348 CALL dom_vvl_interpol_st( r3v(:,:,Kmm), e3vw(:,:,:,Kmm), 'VW' ) ! from V to UW 349 CALL dom_vvl_interpol_st( r3v(:,:,Kbb), e3vw(:,:,:,Kbb), 'VW' ) 350 351 ! We need to define e3[tuv]_a for AGRIF initialisation (should not be a problem for the restartability...) 352 e3t(:,:,:,Kaa) = e3t(:,:,:,Kmm) 353 e3u(:,:,:,Kaa) = e3u(:,:,:,Kmm) 354 e3v(:,:,:,Kaa) = e3v(:,:,:,Kmm) 355 ! 356 DO_3D_11_11( 1, jpk ) 357 gdepw(ji,jj,jk,Kmm) = gdepw_0(ji,jj,jk) * (1._wp + r3t(ji,jj,Kmm)) 358 gdept(ji,jj,jk,Kmm) = gdept_0(ji,jj,jk) * (1._wp + r3t(ji,jj,Kmm)) 359 gde3w(ji,jj,jk ) = gdept(ji,jj,jk,Kmm) - ssh(ji,jj,Kmm) 360 gdepw(ji,jj,jk,Kbb) = gdepw_0(ji,jj,jk) * (1._wp + r3t(ji,jj,Kbb)) 361 gdept(ji,jj,jk,Kbb) = gdept_0(ji,jj,jk) * (1._wp + r3t(ji,jj,Kbb)) 362 END_3D 363 ! 364 ! !== thickness of the water column !! (ocean portion only) 365 ht(:,:) = ht_0(:,:) + ssh(:,:,Kmm) 366 hu(:,:,Kbb) = (hu_0(:,:)*(1._wp+r3u(:,:,Kbb))) 367 hv(:,:,Kbb) = (hv_0(:,:)*(1._wp+r3v(:,:,Kbb))) 368 hu(:,:,Kbb) = (hu_0(:,:)*(1._wp+r3u(:,:,Kmm))) 369 hv(:,:,Kbb) = (hv_0(:,:)*(1._wp+r3v(:,:,Kmm))) 370 ! !== inverse of water column thickness ==! (u- and v- points) 371 r1_hu(:,:,Kbb) = ssumask(:,:) / ( hu(:,:,Kbb) + 1._wp - ssumask(:,:) ) ! _i mask due to ISF 372 r1_hu(:,:,Kmm) = ssumask(:,:) / ( hu(:,:,Kmm) + 1._wp - ssumask(:,:) ) 373 r1_hv(:,:,Kbb) = ssvmask(:,:) / ( hv(:,:,Kbb) + 1._wp - ssvmask(:,:) ) 374 r1_hv(:,:,Kmm) = ssvmask(:,:) / ( hv(:,:,Kmm) + 1._wp - ssvmask(:,:) ) 375 ! 376 IF(lwxios) THEN 377 ! define variables in restart file when writing with XIOS 378 CALL iom_set_rstw_var_active('e3t_b') 379 CALL iom_set_rstw_var_active('e3t_n') 380 ! 381 ENDIF 382 ! 383 END SUBROUTINE dom_vvl_zgr_st 384 292 385 293 386 SUBROUTINE dom_vvl_sf_nxt( kt, Kbb, Kmm, Kaa, kcall ) … … 572 665 573 666 667 668 SUBROUTINE dom_vvl_sf_nxt_st( kt, Kbb, Kmm, Kaa, kcall ) 669 !!---------------------------------------------------------------------- 670 !! *** ROUTINE dom_vvl_sf_nxt *** 671 !! 672 !! ** Purpose : - compute the after scale factors used in tra_zdf, dynnxt, 673 !! tranxt and dynspg routines 674 !! 675 !! ** Method : - z_star case: Repartition of ssh INCREMENT proportionnaly to the level thickness. 676 !! - z_tilde_case: after scale factor increment = 677 !! high frequency part of horizontal divergence 678 !! + retsoring towards the background grid 679 !! + thickness difusion 680 !! Then repartition of ssh INCREMENT proportionnaly 681 !! to the "baroclinic" level thickness. 682 !! 683 !! ** Action : - hdiv_lf : restoring towards full baroclinic divergence in z_tilde case 684 !! - tilde_e3t_a: after increment of vertical scale factor 685 !! in z_tilde case 686 !! - e3(t/u/v)_a 687 !! 688 !! Reference : Leclair, M., and Madec, G. 2011, Ocean Modelling. 689 !!---------------------------------------------------------------------- 690 INTEGER, INTENT( in ) :: kt ! time step 691 INTEGER, INTENT( in ) :: Kbb, Kmm, Kaa ! time step 692 INTEGER, INTENT( in ), OPTIONAL :: kcall ! optional argument indicating call sequence 693 ! 694 INTEGER :: ji, jj, jk ! dummy loop indices 695 INTEGER , DIMENSION(3) :: ijk_max, ijk_min ! temporary integers 696 REAL(wp) :: z_tmin, z_tmax ! local scalars 697 LOGICAL :: ll_do_bclinic ! local logical 698 REAL(wp), DIMENSION(jpi,jpj) :: zht, z_scale, zwu, zwv, zhdiv 699 REAL(wp), DIMENSION(jpi,jpj,jpk) :: ze3t 700 !!---------------------------------------------------------------------- 701 ! 702 IF( ln_linssh ) RETURN ! No calculation in linear free surface 703 ! 704 IF( ln_timing ) CALL timing_start('dom_vvl_sf_nxt') 705 ! 706 IF( kt == nit000 ) THEN 707 IF(lwp) WRITE(numout,*) 708 IF(lwp) WRITE(numout,*) 'dom_vvl_sf_nxt : compute after scale factors' 709 IF(lwp) WRITE(numout,*) '~~~~~~~~~~~~~~' 710 ENDIF 711 712 ll_do_bclinic = .TRUE. 713 IF( PRESENT(kcall) ) THEN 714 IF( kcall == 2 .AND. ln_vvl_ztilde ) ll_do_bclinic = .FALSE. 715 ENDIF 716 717 ! ******************************* ! 718 ! After acale factors at t-points ! 719 ! ******************************* ! 720 ! 721 DO jk = 1, jpkm1 722 e3t(:,:,jk,Kaa) = e3t_0(:,:,jk) * ( 1._wp + r3t(:,:,Kaa) ) 723 e3u(:,:,jk,Kaa) = e3u_0(:,:,jk) * ( 1._wp + r3u(:,:,Kaa) ) 724 e3v(:,:,jk,Kaa) = e3v_0(:,:,jk) * ( 1._wp + r3v(:,:,Kaa) ) 725 END DO 726 ! 727 ! *********************************** ! 728 ! After scale factors at u- v- points ! 729 ! *********************************** ! 730 731 !!st CALL dom_vvl_interpol_st( r3u(:,:,Kaa), e3u(:,:,:,Kaa), 'U' ) 732 !!st CALL dom_vvl_interpol_st( r3v(:,:,Kaa), e3v(:,:,:,Kaa), 'V' ) 733 734 ! *********************************** ! 735 ! After depths at u- v points ! 736 ! *********************************** ! 737 738 !!st hu(:,:,Kaa) = e3u(:,:,1,Kaa) * umask(:,:,1) 739 !!st hv(:,:,Kaa) = e3v(:,:,1,Kaa) * vmask(:,:,1) 740 !!st DO jk = 2, jpkm1 741 !!st hu(:,:,Kaa) = hu(:,:,Kaa) + e3u(:,:,jk,Kaa) * umask(:,:,jk) 742 !!st hv(:,:,Kaa) = hv(:,:,Kaa) + e3v(:,:,jk,Kaa) * vmask(:,:,jk) 743 !!st 744 !!st END DO 745 hu(:,:,Kaa) = (hu_0(:,:)*(1._wp+r3u(:,:,Kaa))) 746 hv(:,:,Kaa) = (hv_0(:,:)*(1._wp+r3v(:,:,Kaa))) 747 ! ! Inverse of the local depth 748 !!gm BUG ? don't understand the use of umask_i here ..... 749 r1_hu(:,:,Kaa) = ssumask(:,:) / ( hu(:,:,Kaa) + 1._wp - ssumask(:,:) ) 750 r1_hv(:,:,Kaa) = ssvmask(:,:) / ( hv(:,:,Kaa) + 1._wp - ssvmask(:,:) ) 751 ! 752 IF( ln_timing ) CALL timing_stop('dom_vvl_sf_nxt') 753 ! 754 END SUBROUTINE dom_vvl_sf_nxt_st 755 756 757 574 758 SUBROUTINE dom_vvl_sf_update( kt, Kbb, Kmm, Kaa ) 575 759 !!---------------------------------------------------------------------- … … 672 856 ! 673 857 END SUBROUTINE dom_vvl_sf_update 674 858 859 860 SUBROUTINE dom_vvl_sf_update_st( kt, Kbb, Kmm, Kaa ) 861 !!---------------------------------------------------------------------- 862 !! *** ROUTINE dom_vvl_sf_update *** 863 !! 864 !! ** Purpose : for z tilde case: compute time filter and swap of scale factors 865 !! compute all depths and related variables for next time step 866 !! write outputs and restart file 867 !! 868 !! ** Method : - swap of e3t with trick for volume/tracer conservation (ONLY FOR Z TILDE CASE) 869 !! - reconstruct scale factor at other grid points (interpolate) 870 !! - recompute depths and water height fields 871 !! 872 !! ** Action : - tilde_e3t_(b/n) ready for next time step 873 !! - Recompute: 874 !! e3(u/v)_b 875 !! e3w(:,:,:,Kmm) 876 !! e3(u/v)w_b 877 !! e3(u/v)w_n 878 !! gdept(:,:,:,Kmm), gdepw(:,:,:,Kmm) and gde3w 879 !! h(u/v) and h(u/v)r 880 !! 881 !! Reference : Leclair, M., and G. Madec, 2009, Ocean Modelling. 882 !! Leclair, M., and G. Madec, 2011, Ocean Modelling. 883 !!---------------------------------------------------------------------- 884 INTEGER, INTENT( in ) :: kt ! time step 885 INTEGER, INTENT( in ) :: Kbb, Kmm, Kaa ! time level indices 886 ! 887 INTEGER :: ji, jj, jk ! dummy loop indices 888 REAL(wp) :: zcoef ! local scalar 889 !!---------------------------------------------------------------------- 890 ! 891 IF( ln_linssh ) RETURN ! No calculation in linear free surface 892 ! 893 IF( ln_timing ) CALL timing_start('dom_vvl_sf_update') 894 ! 895 IF( kt == nit000 ) THEN 896 IF(lwp) WRITE(numout,*) 897 IF(lwp) WRITE(numout,*) 'dom_vvl_sf_update : - interpolate scale factors and compute depths for next time step' 898 IF(lwp) WRITE(numout,*) '~~~~~~~~~~~~~~~~~' 899 ENDIF 900 ! 901 902 ! Compute all missing vertical scale factor and depths 903 ! ==================================================== 904 ! Horizontal scale factor interpolations 905 ! -------------------------------------- 906 ! - ML - e3u(:,:,:,Kbb) and e3v(:,:,:,Kbb) are already computed in dynnxt 907 ! - JC - hu(:,:,:,Kbb), hv(:,:,:,:,Kbb), hur_b, hvr_b also 908 909 CALL dom_vvl_interpol_st( r3f(:,:), e3f(:,:,:), 'F' ) 910 911 ! Vertical scale factor interpolations 912 CALL dom_vvl_interpol_st( r3t(:,:,Kmm), e3w(:,:,:,Kmm), 'W' ) 913 CALL dom_vvl_interpol_st( r3u(:,:,Kmm), e3uw(:,:,:,Kmm), 'UW' ) 914 CALL dom_vvl_interpol_st( r3v(:,:,Kmm), e3vw(:,:,:,Kmm), 'VW' ) 915 CALL dom_vvl_interpol_st( r3t(:,:,Kbb), e3w(:,:,:,Kbb), 'W' ) 916 CALL dom_vvl_interpol_st( r3u(:,:,Kbb), e3uw(:,:,:,Kbb), 'UW' ) 917 CALL dom_vvl_interpol_st( r3v(:,:,Kbb), e3vw(:,:,:,Kbb), 'VW' ) 918 919 ! t- and w- points depth (set the isf depth as it is in the initial step) 920 DO_3D_11_11( 1, jpk ) 921 gdepw(ji,jj,jk,Kmm) = gdepw_0(ji,jj,jk) * (1._wp + r3t(ji,jj,Kmm)) 922 gdept(ji,jj,jk,Kmm) = gdept_0(ji,jj,jk) * (1._wp + r3t(ji,jj,Kmm)) 923 gde3w(ji,jj,jk ) = gdept(ji,jj,jk,Kmm) - ssh(ji,jj,Kmm) 924 END_3D 925 926 ! Local depth and Inverse of the local depth of the water 927 ! ------------------------------------------------------- 928 ! 929 ht(:,:) = ht_0(:,:) + ssh(:,:,Kmm) 930 931 ! write restart file 932 ! ================== 933 IF( lrst_oce ) CALL dom_vvl_rst( kt, Kbb, Kmm, 'WRITE' ) 934 ! 935 IF( ln_timing ) CALL timing_stop('dom_vvl_sf_update') 936 ! 937 END SUBROUTINE dom_vvl_sf_update_st 938 939 940 941 SUBROUTINE dom_vvl_interpol_st( rc3, pe3, cdp ) 942 !!--------------------------------------------------------------------- 943 !! *** ROUTINE dom_vvl__interpol *** 944 !! 945 !! ** Purpose : interpolate scale factors from one grid point to another 946 !! 947 !! ** Method : e3_out = e3_0 + interpolation(e3_in - e3_0) 948 !! - horizontal interpolation: grid cell surface averaging 949 !! - vertical interpolation: simple averaging 950 !!---------------------------------------------------------------------- 951 REAL(wp), DIMENSION(:,:) , INTENT(in ) :: rc3 ! input e3 NOT used here (ssh is used instead) 952 REAL(wp), DIMENSION(:,:,:), INTENT(inout) :: pe3 ! scale factor e3 to be updated [m] 953 CHARACTER(LEN=*) , INTENT(in ) :: cdp ! grid point of the scale factor ( 'U', 'V', 'W, 'F', 'UW' or 'VW' ) 954 ! 955 INTEGER :: ji, jj, jk ! dummy loop indices 956 REAL(wp), DIMENSION(jpi,jpj) :: zc3 ! 2D workspace 957 !!---------------------------------------------------------------------- 958 ! 959 SELECT CASE ( cdp ) !== type of interpolation ==! 960 ! 961 CASE( 'U' ) !* from T- to U-point : hor. surface weighted mean 962 DO jk = 1, jpkm1 963 pe3(:,:,jk) = e3u_0(:,:,jk) * ( 1.0_wp + rc3(:,:) ) 964 END DO 965 ! 966 CASE( 'V' ) !* from T- to V-point : hor. surface weighted mean 967 DO jk = 1, jpkm1 968 pe3(:,:,jk) = e3v_0(:,:,jk) * ( 1.0_wp + rc3(:,:) ) 969 END DO 970 ! 971 CASE( 'F' ) !* from U-point to F-point : hor. surface weighted mean 972 DO jk = 1, jpkm1 ! Horizontal interpolation of e3f from ssh 973 e3f(:,:,jk) = e3f_0(:,:,jk) * ( 1._wp + rc3(:,:) ) 974 END DO 975 ! 976 CASE( 'W' ) !* from T- to W-point : vertical simple mean 977 DO jk = 1, jpk 978 pe3(:,:,jk) = e3w_0(:,:,jk) * ( 1.0_wp + rc3(:,:) ) 979 END DO 980 ! 981 CASE( 'UW' ) !* from U- to UW-point 982 DO jk = 1, jpk 983 pe3(:,:,jk) = e3uw_0(:,:,jk) * ( 1.0_wp + rc3(:,:) ) 984 END DO 985 CASE( 'VW' ) !* from U- to UW-point : vertical simple mean 986 DO jk = 1, jpk 987 pe3(:,:,jk) = e3vw_0(:,:,jk) * ( 1.0_wp + rc3(:,:) ) 988 END DO 989 ! 990 END SELECT 991 ! 992 END SUBROUTINE dom_vvl_interpol_st 993 675 994 676 995 SUBROUTINE dom_vvl_interpol( pssh, pe3, cdp ) … … 723 1042 & + e1e2t(ji+1,jj+1) * pssh(ji+1,jj+1) ) * r1_hf_0(ji,jj) * r1_e1e2f(ji,jj) 724 1043 END_2D 725 !!an dans le cas tourné, hf augmente et trend VOR diminue726 ! DO_2D_10_10727 ! zc3(ji,jj) = ( e1e2t(ji ,jj ) * pssh(ji ,jj ) &728 ! & + e1e2t(ji+1,jj ) * pssh(ji+1,jj ) &729 ! & + e1e2t(ji ,jj+1) * pssh(ji ,jj+1) &730 ! & + e1e2t(ji+1,jj+1) * pssh(ji+1,jj+1) ) * r1_hf_0(ji,jj) * r1_e1e2f(ji,jj) &731 ! & / MAX( tmask(ji,jj) + tmask(ji+1,jj) + tmask(ji,jj+1) + tmask(ji+1,jj+1), 1._wp )732 ! END_2D733 734 1044 CALL lbc_lnk( 'domvvl', zc3(:,:), 'F', 1._wp ) 735 1045 ! … … 771 1081 ! 772 1082 END SUBROUTINE dom_vvl_interpol 773 1083 774 1084 775 1085 SUBROUTINE dom_vvl_rst( kt, Kbb, Kmm, cdrw ) … … 1036 1346 END SUBROUTINE dom_vvl_ctl 1037 1347 1348 #endif 1349 !!stoops 1350 1038 1351 !!====================================================================== 1039 1352 END MODULE domvvl -
NEMO/branches/2020/dev_r12527_Gurvan_ShallowWater/src/SWE/dynadv.F90
r13005 r13151 74 74 CASE( np_VEC_c2 ) 75 75 CALL dyn_keg ( kt, nn_dynkeg, Kmm, puu, pvv, Krhs ) ! vector form : horizontal gradient of kinetic energy 76 !!an SWE : w = 077 76 CALL dyn_zad ( kt, Kmm, puu, pvv, Krhs ) ! vector form : vertical advection 78 77 CASE( np_FLX_c2 ) -
NEMO/branches/2020/dev_r12527_Gurvan_ShallowWater/src/SWE/dynatf.F90
r12614 r13151 58 58 59 59 PUBLIC dyn_atf ! routine called by step.F90 60 !!st22 61 #if defined key_qco 62 !!---------------------------------------------------------------------- 63 !! 'key_qco' EMPTY ROUTINE Quasi-Eulerian vertical coordonate 64 !!---------------------------------------------------------------------- 65 CONTAINS 66 67 SUBROUTINE dyn_atf ( kt, Kbb, Kmm, Kaa, puu, pvv, pe3t, pe3u, pe3v ) 68 INTEGER , INTENT(in ) :: kt ! ocean time-step index 69 INTEGER , INTENT(in ) :: Kbb, Kmm, Kaa ! before and after time level indices 70 REAL(wp), DIMENSION(jpi,jpj,jpk,jpt), INTENT(inout) :: puu, pvv ! velocities to be time filtered 71 REAL(wp), DIMENSION(jpi,jpj,jpk,jpt), INTENT(inout) :: pe3t, pe3u, pe3v ! scale factors to be time filtered 72 73 WRITE(*,*) 'dyn_atf: You should not have seen this print! error?', kt 74 END SUBROUTINE dyn_atf 75 76 #else 60 77 61 78 !! * Substitutions … … 312 329 END SUBROUTINE dyn_atf 313 330 331 #endif 332 !!st22 314 333 !!========================================================================= 315 334 END MODULE dynatf -
NEMO/branches/2020/dev_r12527_Gurvan_ShallowWater/src/SWE/dynkeg.F90
r13005 r13151 29 29 30 30 PUBLIC dyn_keg ! routine called by step module 31 PUBLIC dyn_kegAD ! routine called by step module32 31 33 32 INTEGER, PARAMETER, PUBLIC :: nkeg_C2 = 0 !: 2nd order centered scheme (standard scheme) … … 156 155 ! 157 156 END SUBROUTINE dyn_keg 158 159 160 SUBROUTINE dyn_kegAD( kt, kscheme, puu, pvv, pu_rhs, pv_rhs )161 !!----------------------------------------------------------------------162 !! *** ROUTINE dyn_kegAD ***163 !!164 !! ** Purpose : Compute the now momentum trend due to the horizontal165 !! gradient of the horizontal kinetic energy and add it to the166 !! general momentum trend.167 !!168 !! ** Method : * kscheme = nkeg_C2 : 2nd order centered scheme that169 !! conserve kinetic energy. Compute the now horizontal kinetic energy170 !! zhke = 1/2 [ mi-1( un^2 ) + mj-1( vn^2 ) ]171 !! * kscheme = nkeg_HW : Hollingsworth correction following172 !! Arakawa (2001). The now horizontal kinetic energy is given by:173 !! zhke = 1/6 [ mi-1( 2 * un^2 + ((u(j+1)+u(j-1))/2)^2 )174 !! + mj-1( 2 * vn^2 + ((v(i+1)+v(i-1))/2)^2 ) ]175 !!176 !! Take its horizontal gradient and add it to the general momentum177 !! trend.178 !! u(rhs) = u(rhs) - 1/e1u di[ zhke ]179 !! v(rhs) = v(rhs) - 1/e2v dj[ zhke ]180 !!181 !! ** Action : - Update the (puu(:,:,:,Krhs), pvv(:,:,:,Krhs)) with the hor. ke gradient trend182 !! - send this trends to trd_dyn (l_trddyn=T) for post-processing183 !!184 !! ** References : Arakawa, A., International Geophysics 2001.185 !! Hollingsworth et al., Quart. J. Roy. Meteor. Soc., 1983.186 !!----------------------------------------------------------------------187 !188 INTEGER , INTENT( in ) :: kt ! ocean time-step index189 INTEGER , INTENT( in ) :: kscheme ! =0/1/2 type of KEG scheme190 REAL(wp), DIMENSION(jpi,jpj,jpk) , INTENT(inout) :: puu, pvv ! ocean velocities at Kmm191 REAL(wp), DIMENSION(jpi,jpj,jpk),OPTIONAL, INTENT(inout) :: pu_rhs, pv_rhs ! RHS192 !193 INTEGER :: ji, jj, jk ! dummy loop indices194 REAL(wp) :: zu, zv ! local scalars195 REAL(wp), DIMENSION(jpi,jpj,jpk) :: zhke196 REAL(wp), ALLOCATABLE, DIMENSION(:,:,:) :: ztrdu, ztrdv197 !!----------------------------------------------------------------------198 !199 IF( ln_timing ) CALL timing_start('dyn_keg')200 !201 IF( kt == nit000 ) THEN202 IF(lwp) WRITE(numout,*)203 IF(lwp) WRITE(numout,*) 'dyn_kegAD : kinetic energy gradient trend, scheme number=', kscheme204 IF(lwp) WRITE(numout,*) '~~~~~~~~~'205 ENDIF206 207 zhke(:,:,jpk) = 0._wp208 157 209 SELECT CASE ( kscheme ) !== Horizontal kinetic energy at T-point ==!210 !!an45 to be ADDED : que cas C2 - "wet points only" il suffit de x2 le terme quadratic a la coast (nn_dynkeg_adv = 2)211 CASE ( nkeg_C2_wpo ) !-- Standard scheme --!212 DO_3D_01_01( 1, jpkm1 )213 zu = ( puu(ji-1,jj ,jk) * puu(ji-1,jj ,jk) &214 & + puu(ji ,jj ,jk) * puu(ji ,jj ,jk) ) * ( 2._wp - umask(ji-1,jj,jk) * umask(ji,jj,jk) )215 zv = ( pvv(ji ,jj-1,jk) * pvv(ji ,jj-1,jk) &216 & + pvv(ji ,jj ,jk) * pvv(ji ,jj ,jk) ) * ( 2._wp - vmask(ji,jj-1,jk) * vmask(ji,jj,jk) )217 zhke(ji,jj,jk) = 0.25_wp * ( zv + zu )218 END_3D219 !!an45220 !221 CASE ( nkeg_C2 ) !-- Standard scheme --!222 DO_3D_01_01( 1, jpkm1 )223 zu = puu(ji-1,jj ,jk) * puu(ji-1,jj ,jk) &224 & + puu(ji ,jj ,jk) * puu(ji ,jj ,jk)225 zv = pvv(ji ,jj-1,jk) * pvv(ji ,jj-1,jk) &226 & + pvv(ji ,jj ,jk) * pvv(ji ,jj ,jk)227 zhke(ji,jj,jk) = 0.25_wp * ( zv + zu )228 END_3D229 !!an 00_00 ?230 CASE ( nkeg_HW ) !-- Hollingsworth scheme --!231 DO_3D_00_00( 1, jpkm1 )232 zu = 8._wp * ( puu(ji-1,jj ,jk) * puu(ji-1,jj ,jk) &233 & + puu(ji ,jj ,jk) * puu(ji ,jj ,jk) ) &234 & + ( puu(ji-1,jj-1,jk) + puu(ji-1,jj+1,jk) ) * ( puu(ji-1,jj-1,jk) + puu(ji-1,jj+1,jk) ) &235 & + ( puu(ji ,jj-1,jk) + puu(ji ,jj+1,jk) ) * ( puu(ji ,jj-1,jk) + puu(ji ,jj+1,jk) )236 !237 zv = 8._wp * ( pvv(ji ,jj-1,jk) * pvv(ji ,jj-1,jk) &238 & + pvv(ji ,jj ,jk) * pvv(ji ,jj ,jk) ) &239 & + ( pvv(ji-1,jj-1,jk) + pvv(ji+1,jj-1,jk) ) * ( pvv(ji-1,jj-1,jk) + pvv(ji+1,jj-1,jk) ) &240 & + ( pvv(ji-1,jj ,jk) + pvv(ji+1,jj ,jk) ) * ( pvv(ji-1,jj ,jk) + pvv(ji+1,jj ,jk) )241 zhke(ji,jj,jk) = r1_48 * ( zv + zu )242 END_3D243 CALL lbc_lnk( 'dynkeg', zhke, 'T', 1. )244 !245 END SELECT246 !247 IF( PRESENT( pu_rhs ) .AND. PRESENT( pv_rhs ) ) THEN !*** NO alternating direction ***!248 !249 DO_3D_00_00( 1, jpkm1 )250 pu_rhs(ji,jj,jk) = pu_rhs(ji,jj,jk) - ( zhke(ji+1,jj ,jk) - zhke(ji,jj,jk) ) / e1u(ji,jj)251 pv_rhs(ji,jj,jk) = pv_rhs(ji,jj,jk) - ( zhke(ji ,jj+1,jk) - zhke(ji,jj,jk) ) / e2v(ji,jj)252 END_3D253 !254 ELSEIF( PRESENT( pu_rhs ) .AND. .NOT. PRESENT( pv_rhs ) ) THEN !*** Alternating direction : i-component ***!255 !256 DO_3D_00_00( 1, jpkm1 )257 pu_rhs(ji,jj,jk) = pu_rhs(ji,jj,jk) - ( zhke(ji+1,jj ,jk) - zhke(ji,jj,jk) ) / e1u(ji,jj)258 END_3D259 !260 ELSEIF( .NOT. PRESENT( pu_rhs ) .AND. PRESENT( pv_rhs ) ) THEN !*** Alternating direction : j-component ***!261 !262 DO_3D_00_00( 1, jpkm1 )263 pv_rhs(ji,jj,jk) = pv_rhs(ji,jj,jk) - ( zhke(ji ,jj+1,jk) - zhke(ji,jj,jk) ) / e2v(ji,jj)264 END_3D265 !266 ENDIF267 IF( ln_timing ) CALL timing_stop('dyn_kegAD')268 !269 END SUBROUTINE dyn_kegAD270 158 !!====================================================================== 271 159 END MODULE dynkeg -
NEMO/branches/2020/dev_r12527_Gurvan_ShallowWater/src/SWE/dynldf_lap_blp.F90
r13005 r13151 20 20 USE in_out_manager ! I/O manager 21 21 USE lbclnk ! ocean lateral boundary conditions (or mpp link) 22 USE lib_mpp ! MPP library 23 ! 24 USE usrdef_nam , ONLY : nn_dynldf_lap_typ ! use laplacian parameter 25 ! 22 26 23 IMPLICIT NONE 27 24 PRIVATE … … 34 31 INTEGER, PUBLIC, PARAMETER :: np_dynldf_lap_symN = 3 ! symmetric laplacian (cartesian) 35 32 36 !INTEGER, PUBLIC, PARAMETER :: nn_dynldf_lap_typ = 1 ! choose type of laplacian (ideally from namelist)33 INTEGER, PUBLIC, PARAMETER :: ln_dynldf_lap_typ = 1 ! choose type of laplacian (ideally from namelist) 37 34 !!anSYM 38 35 !! * Substitutions 39 36 # include "do_loop_substitute.h90" 37 !!st21 38 # include "domzgr_substitute.h90" 40 39 !!---------------------------------------------------------------------- 41 40 !! NEMO/OCE 4.0 , NEMO Consortium (2018) … … 80 79 WRITE(numout,*) 'dyn_ldf : iso-level harmonic (laplacian) operator, pass=', kpass 81 80 WRITE(numout,*) '~~~~~~~ ' 82 WRITE(numout,*) ' nn_dynldf_lap_typ = ', nn_dynldf_lap_typ83 SELECT CASE( nn_dynldf_lap_typ ) ! print the choice of operator81 WRITE(numout,*) ' ln_dynldf_lap_typ = ', ln_dynldf_lap_typ 82 SELECT CASE( ln_dynldf_lap_typ ) ! print the choice of operator 84 83 CASE( np_dynldf_lap_rot ) ; WRITE(numout,*) ' ==>>> div-rot laplacian' 85 84 CASE( np_dynldf_lap_sym ) ; WRITE(numout,*) ' ==>>> symmetric laplacian (covariant form)' 86 CASE( np_dynldf_lap_symN) ; WRITE(numout,*) ' ==>>> symmetric laplacian ( cartesianform)'85 CASE( np_dynldf_lap_symN) ; WRITE(numout,*) ' ==>>> symmetric laplacian (simple form)' 87 86 END SELECT 88 87 ENDIF … … 92 91 ENDIF 93 92 ! 94 SELECT CASE( nn_dynldf_lap_typ )93 SELECT CASE( ln_dynldf_lap_typ ) 95 94 ! 96 95 CASE ( np_dynldf_lap_rot ) !== Vorticity-Divergence form ==! … … 102 101 !!gm open question here : e3f at before or now ? probably now... 103 102 !!gm note that ahmf has already been multiplied by fmask 104 zcur(ji-1,jj-1) = ahmf(ji-1,jj-1,jk) * e3f(ji-1,jj-1,jk) * r1_e1e2f(ji-1,jj-1) & 105 & * ( e2v(ji ,jj-1) * pv(ji ,jj-1,jk) - e2v(ji-1,jj-1) * pv(ji-1,jj-1,jk) & 106 & - e1u(ji-1,jj ) * pu(ji-1,jj ,jk) + e1u(ji-1,jj-1) * pu(ji-1,jj-1,jk) ) 107 ! ! ahm * div (computed from 2 to jpi/jpj) 103 zcur(ji-1,jj-1) = & 104 & ahmf(ji-1,jj-1,jk) * e3f(ji-1,jj-1,jk) * r1_e1e2f(ji-1,jj-1) & 105 & * ( e2v(ji ,jj-1) * pv(ji ,jj-1,jk) - e2v(ji-1,jj-1) * pv(ji-1,jj-1,jk) & 106 & - e1u(ji-1,jj ) * pu(ji-1,jj ,jk) + e1u(ji-1,jj-1) * pu(ji-1,jj-1,jk) ) 107 ! ! ahm * div (computed from 2 to jpi/jpj) 108 108 !!gm note that ahmt has already been multiplied by tmask 109 109 zdiv(ji,jj) = ahmt(ji,jj,jk) * r1_e1e2t(ji,jj) / e3t(ji,jj,jk,Kbb) & … … 160 160 END DO ! End of slab 161 161 ! 162 CASE ( np_dynldf_lap_symN ) !== Symmetric form ==! ( cartesianway)162 CASE ( np_dynldf_lap_symN ) !== Symmetric form ==! (naive way) 163 163 ! 164 164 DO jk = 1, jpkm1 ! Horizontal slab … … 193 193 ! 194 194 CASE DEFAULT ! error 195 CALL ctl_stop('STOP','dyn_ldf_lap: wrong value for nn_dynldf_lap_typ' )195 CALL ctl_stop('STOP','dyn_ldf_lap: wrong value for ln_dynldf_lap_typ' ) 196 196 END SELECT 197 197 ! -
NEMO/branches/2020/dev_r12527_Gurvan_ShallowWater/src/SWE/dynvor.F90
r13005 r13151 22 22 !! - ! 2018-04 (G. Madec) add pre-computed gradient for metric term calculation 23 23 !! 4.x ! 2020-03 (G. Madec, A. Nasser) make ln_dynvor_msk truly efficient on relative vorticity 24 !! 4.x ! 2020-03 (G. Madec, A. Nasser) alternate direction computation of vorticity tendancy25 !! ! for ENS, ENE26 24 !!---------------------------------------------------------------------- 27 25 … … 47 45 USE lib_mpp ! MPP library 48 46 USE timing ! Timing 49 !!anAD only50 USE dynkeg, ONLY : dyn_kegAD51 USE dynadv, ONLY : nn_dynkeg52 47 53 48 IMPLICIT NONE … … 58 53 59 54 ! !!* Namelist namdyn_vor: vorticity term 60 LOGICAL, PUBLIC :: ln_dynvor_ens !: enstrophy conserving scheme (ENS) 61 LOGICAL, PUBLIC :: ln_dynvor_ens_adVO = .FALSE. !: AD enstrophy conserving scheme (ENS_ad) 62 LOGICAL, PUBLIC :: ln_dynvor_ens_adKE = .FALSE. !: AD enstrophy conserving scheme (ENS_ad) 63 LOGICAL, PUBLIC :: ln_dynvor_ens_adKEVO = .FALSE. !: AD enstrophy conserving scheme (ENS_ad) 64 LOGICAL, PUBLIC :: ln_dynvor_ene !: f-point energy conserving scheme (ENE) 65 LOGICAL, PUBLIC :: ln_dynvor_ene_adVO = .FALSE. !: f-point AD energy conserving scheme (ENE_ad) 66 LOGICAL, PUBLIC :: ln_dynvor_ene_adKE = .FALSE. !: f-point AD energy conserving scheme (ENE_ad) 67 LOGICAL, PUBLIC :: ln_dynvor_ene_adKEVO = .FALSE. !: f-point AD energy conserving scheme (ENE_ad) 68 LOGICAL, PUBLIC :: ln_dynvor_enT !: t-point energy conserving scheme (ENT) 69 LOGICAL, PUBLIC :: ln_dynvor_eeT !: t-point energy conserving scheme (EET) 70 LOGICAL, PUBLIC :: ln_dynvor_een !: energy & enstrophy conserving scheme (EEN) 71 INTEGER, PUBLIC :: nn_een_e3f !: e3f=masked averaging of e3t divided by 4 (=0) or by the sum of mask (=1) 72 LOGICAL, PUBLIC :: ln_dynvor_mix !: mixed scheme (MIX) 73 LOGICAL, PUBLIC :: ln_dynvor_msk !: vorticity multiplied by fmask (=T) or not (=F) (all vorticity schemes) 55 LOGICAL, PUBLIC :: ln_dynvor_ens !: enstrophy conserving scheme (ENS) 56 LOGICAL, PUBLIC :: ln_dynvor_ene !: f-point energy conserving scheme (ENE) 57 LOGICAL, PUBLIC :: ln_dynvor_enT !: t-point energy conserving scheme (ENT) 58 LOGICAL, PUBLIC :: ln_dynvor_eeT !: t-point energy conserving scheme (EET) 59 LOGICAL, PUBLIC :: ln_dynvor_een !: energy & enstrophy conserving scheme (EEN) 60 INTEGER, PUBLIC :: nn_een_e3f !: e3f=masked averaging of e3t divided by 4 (=0) or by the sum of mask (=1) 61 LOGICAL, PUBLIC :: ln_dynvor_mix !: mixed scheme (MIX) 62 LOGICAL, PUBLIC :: ln_dynvor_msk !: vorticity multiplied by fmask (=T) or not (=F) (all vorticity schemes) 74 63 75 64 INTEGER, PUBLIC :: nvor_scheme !: choice of the type of advection scheme … … 81 70 INTEGER, PUBLIC, PARAMETER :: np_EEN = 4 ! EEN scheme 82 71 INTEGER, PUBLIC, PARAMETER :: np_MIX = 5 ! MIX scheme 83 !!an 84 INTEGER, PUBLIC, PARAMETER :: np_ENS_adKE = 11 ! ENS scheme - AD scheme (KE only) 85 INTEGER, PUBLIC, PARAMETER :: np_ENS_adVO = 12 ! ENS scheme - AD scheme (VOR only) 86 INTEGER, PUBLIC, PARAMETER :: np_ENS_adKEVO = 13 ! ENS scheme - AD scheme (KE+VOR) 87 INTEGER, PUBLIC, PARAMETER :: np_ENE_adKE = 21 ! ENE scheme - AD scheme (KE only) 88 INTEGER, PUBLIC, PARAMETER :: np_ENE_adVO = 22 ! ENE scheme - AD scheme (VOR only) 89 INTEGER, PUBLIC, PARAMETER :: np_ENE_adKEVO = 23 ! ENE scheme - AD scheme (KE+VOR) 90 !!an 91 92 !!an ds step on pourra spécifier la valeur de ntot = np_COR ou np_COR + np_RVO 93 INTEGER, PUBLIC :: ncor, nrvm, ntot ! choice of calculated vorticity 72 73 INTEGER :: ncor, nrvm, ntot ! choice of calculated vorticity 94 74 ! ! associated indices: 95 75 INTEGER, PUBLIC, PARAMETER :: np_COR = 1 ! Coriolis (planetary) … … 110 90 !! * Substitutions 111 91 # include "do_loop_substitute.h90" 92 !!st23 93 # include "domzgr_substitute.h90" 112 94 !!---------------------------------------------------------------------- 113 95 !! NEMO/OCE 4.0 , NEMO Consortium (2018) … … 117 99 CONTAINS 118 100 119 SUBROUTINE dyn_vor( kt, K bb, Kmm, puu, pvv, Krhs)101 SUBROUTINE dyn_vor( kt, Kmm, puu, pvv, Krhs ) 120 102 !!---------------------------------------------------------------------- 121 103 !! … … 127 109 !! for futher diagnostics (l_trddyn=T) 128 110 !!---------------------------------------------------------------------- 129 INTEGER :: ji, jj, jk ! dummy loop indice 130 INTEGER , INTENT( in ) :: kt ! ocean time-step index 131 INTEGER , INTENT( in ) :: Kmm, Krhs, Kbb ! ocean time level indices 132 REAL(wp), DIMENSION(jpi,jpj,jpk,jpt), INTENT(inout) :: puu, pvv ! ocean velocity field and RHS of momentum equation 111 INTEGER , INTENT( in ) :: kt ! ocean time-step index 112 INTEGER , INTENT( in ) :: Kmm, Krhs ! ocean time level indices 113 REAL(wp), DIMENSION(jpi,jpj,jpk,jpt), INTENT(inout) :: puu, pvv ! ocean velocity field and RHS of momentum equation 133 114 ! 134 115 REAL(wp), ALLOCATABLE, DIMENSION(:,:,:) :: ztrdu, ztrdv 135 REAL(wp), ALLOCATABLE, DIMENSION(:,:,:) :: zuu, zvv136 116 !!---------------------------------------------------------------------- 137 117 ! … … 187 167 IF( ln_stcor ) CALL vor_eeT( kt, Kmm, ncor, usd, vsd, puu(:,:,:,Krhs), pvv(:,:,:,Krhs) ) ! add the Stokes-Coriolis trend 188 168 CASE( np_ENE ) !* energy conserving scheme 189 CALL dyn_kegAD( kt, nn_dynkeg, puu(:,:,:,Kmm) , pvv(:,:,:,Kmm) , pu_rhs=puu(:,:,:,Krhs), pv_rhs=pvv(:,:,:,Krhs) ) 190 CALL vor_ene( kt, Kmm, ntot, puu(:,:,:,Kmm) , pvv(:,:,:,Kmm) , puu(:,:,:,Krhs), pvv(:,:,:,Krhs) ) ! total vorticity trend 169 CALL vor_ene( kt, Kmm, ntot, puu(:,:,:,Kmm) , pvv(:,:,:,Kmm) , puu(:,:,:,Krhs), pvv(:,:,:,Krhs) ) ! total vorticity trend 191 170 IF( ln_stcor ) CALL vor_ene( kt, Kmm, ncor, usd, vsd, puu(:,:,:,Krhs), pvv(:,:,:,Krhs) ) ! add the Stokes-Coriolis trend 192 193 CASE( np_ENE_adVO ) !* energy conserving scheme with alternating direction194 IF( MOD( kt , 2 ) == 1 ) THEN ! even time step: u-vor then v-vor components195 196 !== Alternative direction - VOR only ==!197 198 CALL dyn_kegAD( kt, nn_dynkeg, puu(:,:,:,Kmm) , pvv(:,:,:,Kmm) , pu_rhs=puu(:,:,:,Krhs), pv_rhs=pvv(:,:,:,Krhs) ) ! compute and add uu-vorticity trend199 200 ALLOCATE( zuu(jpi,jpj,jpk) )201 CALL vor_ene( kt, Kmm, ntot, puu(:,:,:,Kmm) , pvv(:,:,:,Kmm) , pu_rhs=puu(:,:,:,Krhs) ) ! compute and add uu-vorticity trend202 zuu(:,:,:) = puu(:,:,:,Kbb) + rDt * puu(:,:,:,Krhs) * umask(:,:,:)203 CALL lbc_lnk( 'dynvor', zuu(:,:,:) , 'U', -1._wp )204 CALL vor_ene( kt, Kmm, ntot, zuu(:,:,:) , pvv(:,:,:,Kmm) , pv_rhs=pvv(:,:,:,Krhs) ) ! compute and add vv-vorticity trend205 DEALLOCATE( zuu )206 ELSE207 CALL dyn_kegAD( kt, nn_dynkeg, puu(:,:,:,Kmm) , pvv(:,:,:,Kmm) , pu_rhs=puu(:,:,:,Krhs), pv_rhs=pvv(:,:,:,Krhs) ) ! compute and add uu-vorticity trend208 209 ALLOCATE( zvv(jpi,jpj,jpk) )210 CALL vor_ene( kt, Kmm, ntot, puu(:,:,:,Kmm) , pvv(:,:,:,Kmm) , pv_rhs=pvv(:,:,:,Krhs) ) ! compute and add vv-vorticity trend211 zvv(:,:,:) = pvv(:,:,:,Kbb) + rDt * pvv(:,:,:,Krhs) * vmask(:,:,:)212 CALL lbc_lnk( 'dynvor', zvv(:,:,:) , 'V', -1._wp )213 CALL vor_ene( kt, Kmm, ntot, puu(:,:,:,Kmm), zvv(:,:,:) , pu_rhs=puu(:,:,:,Krhs) ) ! compute and add uu-vorticity trend214 DEALLOCATE( zvv )215 ENDIF216 IF( ln_stcor ) CALL vor_ene( kt, Kmm, ncor, usd, vsd, puu(:,:,:,Krhs), pvv(:,:,:,Krhs) ) ! add the Stokes-Coriolis trend217 CASE( np_ENE_adKE ) !* energy conserving scheme with alternating direction218 IF( MOD( kt , 2 ) == 1 ) THEN ! even time step: u-vor then v-vor components219 220 !== Alternative direction - KEG only ==!221 222 CALL vor_ene( kt, Kmm, ntot, puu(:,:,:,Kmm) , pvv(:,:,:,Kmm) , puu(:,:,:,Krhs), pvv(:,:,:,Krhs) ) ! total vorticity trend223 224 ALLOCATE( zuu(jpi,jpj,jpk) )225 CALL dyn_kegAD( kt, nn_dynkeg, puu(:,:,:,Kmm) , pvv(:,:,:,Kmm) , pu_rhs=puu(:,:,:,Krhs) ) ! compute and add uu-vorticity trend226 zuu(:,:,:) = puu(:,:,:,Kbb) + rDt * puu(:,:,:,Krhs) * umask(:,:,:)227 CALL lbc_lnk( 'dynvor', zuu(:,:,:) , 'U', -1._wp )228 CALL dyn_kegAD( kt, nn_dynkeg, zuu(:,:,:) , pvv(:,:,:,Kmm) , pv_rhs=pvv(:,:,:,Krhs) ) ! compute and add vv-vorticity trend229 DEALLOCATE( zuu )230 ELSE231 232 CALL vor_ene( kt, Kmm, ntot, puu(:,:,:,Kmm) , pvv(:,:,:,Kmm) , puu(:,:,:,Krhs), pvv(:,:,:,Krhs) ) ! total vorticity trend233 234 ALLOCATE( zvv(jpi,jpj,jpk) )235 CALL dyn_kegAD( kt, nn_dynkeg, puu(:,:,:,Kmm) , pvv(:,:,:,Kmm) , pv_rhs=pvv(:,:,:,Krhs) ) ! compute and add vv-vorticity trend236 zvv(:,:,:) = pvv(:,:,:,Kbb) + rDt * pvv(:,:,:,Krhs) * vmask(:,:,:)237 CALL lbc_lnk( 'dynvor', zvv(:,:,:) , 'V', -1._wp )238 CALL dyn_kegAD( kt, nn_dynkeg, puu(:,:,:,Kmm) , zvv(:,:,:) , pu_rhs=puu(:,:,:,Krhs) ) ! compute and add uu-vorticity trend239 DEALLOCATE( zvv )240 ENDIF241 IF( ln_stcor ) CALL vor_ene( kt, Kmm, ncor, usd, vsd, puu(:,:,:,Krhs), pvv(:,:,:,Krhs) ) ! add the Stokes-Coriolis trend242 243 CASE( np_ENE_adKEVO ) !* energy conserving scheme with alternating direction244 IF( MOD( kt , 2 ) == 1 ) THEN ! even time step: u-vor then v-vor components245 246 !== Alternative direction - KE + VOR ==!247 248 ALLOCATE( zuu(jpi,jpj,jpk) )249 CALL vor_ene( kt, Kmm, ntot, puu(:,:,:,Kmm) , pvv(:,:,:,Kmm) , pu_rhs=puu(:,:,:,Krhs) ) ! compute and add uu-vorticity trend250 CALL dyn_kegAD( kt, nn_dynkeg, puu(:,:,:,Kmm) , pvv(:,:,:,Kmm) , pu_rhs=puu(:,:,:,Krhs) ) !251 zuu(:,:,:) = puu(:,:,:,Kbb) + rDt * puu(:,:,:,Krhs) * umask(:,:,:)252 CALL lbc_lnk( 'dynvor', zuu(:,:,:) , 'U', -1._wp )253 CALL vor_ene( kt, Kmm, ntot, zuu(:,:,:) , pvv(:,:,:,Kmm) , pv_rhs=pvv(:,:,:,Krhs) ) ! compute and add vv-vorticity trend254 CALL dyn_kegAD( kt, nn_dynkeg, zuu(:,:,:) , pvv(:,:,:,Kmm) , pv_rhs=pvv(:,:,:,Krhs) )255 DEALLOCATE( zuu )256 ELSE257 258 ALLOCATE( zvv(jpi,jpj,jpk) )259 CALL vor_ene( kt, Kmm, ntot, puu(:,:,:,Kmm) , pvv(:,:,:,Kmm) , pv_rhs=pvv(:,:,:,Krhs) ) ! compute and add vv-vorticity trend260 CALL dyn_kegAD( kt, nn_dynkeg, puu(:,:,:,Kmm) , pvv(:,:,:,Kmm) , pv_rhs=pvv(:,:,:,Krhs) )261 zvv(:,:,:) = pvv(:,:,:,Kbb) + rDt * pvv(:,:,:,Krhs) * vmask(:,:,:)262 CALL lbc_lnk( 'dynvor', zvv(:,:,:) , 'V', -1._wp )263 CALL vor_ene( kt, Kmm, ntot, puu(:,:,:,Kmm), zvv(:,:,:) , pu_rhs=puu(:,:,:,Krhs) ) ! compute and add uu-vorticity trend264 CALL dyn_kegAD( kt, nn_dynkeg, puu(:,:,:,Kmm), zvv(:,:,:) , pu_rhs=puu(:,:,:,Krhs) )265 DEALLOCATE( zvv )266 ENDIF267 171 CASE( np_ENS ) !* enstrophy conserving scheme 268 CALL dyn_kegAD( kt, nn_dynkeg, puu(:,:,:,Kmm) , pvv(:,:,:,Kmm) , pu_rhs=puu(:,:,:,Krhs), pv_rhs=pvv(:,:,:,Krhs) )269 CALL vor_ens( kt, Kmm, ntot, puu(:,:,:,Kmm) , pvv(:,:,:,Kmm) , puu(:,:,:,Krhs), pvv(:,:,:,Krhs) ) ! total vorticity trend270 IF( ln_stcor ) CALL vor_ens( kt, Kmm, ncor, usd, vsd, puu(:,:,:,Krhs), pvv(:,:,:,Krhs) ) ! add the Stokes-Coriolis trend271 CASE( np_ENS_adVO ) !* enstrophy conserving scheme with alternating direction272 IF( MOD( kt , 2 ) == 1 ) THEN ! even time step: u-vor then v-vor components273 274 !== Alternative direction - VOR only ==!275 276 CALL dyn_kegAD( kt, nn_dynkeg, puu(:,:,:,Kmm) , pvv(:,:,:,Kmm) , pu_rhs=puu(:,:,:,Krhs), pv_rhs=pvv(:,:,:,Krhs) )277 278 ALLOCATE( zuu(jpi,jpj,jpk) )279 CALL vor_ens( kt, Kmm, ntot, puu(:,:,:,Kmm) , pvv(:,:,:,Kmm) , pu_rhs=puu(:,:,:,Krhs) ) ! compute and add uu-vorticity trend280 zuu(:,:,:) = puu(:,:,:,Kbb) + rDt * puu(:,:,:,Krhs) * umask(:,:,:)281 CALL lbc_lnk( 'dynvor', zuu(:,:,:) , 'U', -1._wp )282 CALL vor_ens( kt, Kmm, ntot, zuu(:,:,:) , pvv(:,:,:,Kmm) , pv_rhs=pvv(:,:,:,Krhs) ) ! compute and add vv-vorticity trend283 DEALLOCATE( zuu )284 ELSE285 CALL dyn_kegAD( kt, nn_dynkeg, puu(:,:,:,Kmm) , pvv(:,:,:,Kmm) , pu_rhs=puu(:,:,:,Krhs), pv_rhs=pvv(:,:,:,Krhs) )286 287 ALLOCATE( zvv(jpi,jpj,jpk) )288 CALL vor_ens( kt, Kmm, ntot, puu(:,:,:,Kmm) , pvv(:,:,:,Kmm) , pv_rhs=pvv(:,:,:,Krhs) ) ! compute and add vv-vorticity trend289 zvv(:,:,:) = pvv(:,:,:,Kbb) + rDt * pvv(:,:,:,Krhs) * vmask(:,:,:)290 CALL lbc_lnk( 'dynvor', zvv(:,:,:) , 'V', -1._wp )291 CALL vor_ens( kt, Kmm, ntot, puu(:,:,:,Kmm) , zvv(:,:,:), pu_rhs=puu(:,:,:,Krhs) ) ! compute and add uu-vorticity trend292 DEALLOCATE( zvv )293 ENDIF294 IF( ln_stcor ) CALL vor_ens( kt, Kmm, ncor, usd, vsd, puu(:,:,:,Krhs), pvv(:,:,:,Krhs) ) ! add the Stokes-Coriolis trend295 CASE( np_ENS_adKE ) !* enstrophy conserving scheme with alternating direction296 IF( MOD( kt , 2 ) == 1 ) THEN ! even time step: u-vor then v-vor components297 298 !== Alternative direction - KEG only ==!299 300 172 CALL vor_ens( kt, Kmm, ntot, puu(:,:,:,Kmm) , pvv(:,:,:,Kmm) , puu(:,:,:,Krhs), pvv(:,:,:,Krhs) ) ! total vorticity trend 301 302 ALLOCATE( zuu(jpi,jpj,jpk) )303 CALL dyn_kegAD( kt, nn_dynkeg, puu(:,:,:,Kmm) , pvv(:,:,:,Kmm) , pu_rhs=puu(:,:,:,Krhs) ) ! compute and add uu-vorticity trend304 zuu(:,:,:) = puu(:,:,:,Kbb) + rDt * puu(:,:,:,Krhs) * umask(:,:,:)305 CALL lbc_lnk( 'dynvor', zuu(:,:,:) , 'U', -1._wp )306 CALL dyn_kegAD( kt, nn_dynkeg, zuu(:,:,:) , pvv(:,:,:,Kmm) , pv_rhs=pvv(:,:,:,Krhs) ) ! compute and add vv-vorticity trend307 DEALLOCATE( zuu )308 ELSE309 310 CALL vor_ens( kt, Kmm, ntot, puu(:,:,:,Kmm) , pvv(:,:,:,Kmm) , puu(:,:,:,Krhs), pvv(:,:,:,Krhs) ) ! total vorticity trend311 312 ALLOCATE( zvv(jpi,jpj,jpk) )313 CALL dyn_kegAD( kt, nn_dynkeg, puu(:,:,:,Kmm) , pvv(:,:,:,Kmm) , pv_rhs=pvv(:,:,:,Krhs) ) ! compute and add vv-vorticity trend314 zvv(:,:,:) = pvv(:,:,:,Kbb) + rDt * pvv(:,:,:,Krhs) * vmask(:,:,:)315 CALL lbc_lnk( 'dynvor', zvv(:,:,:) , 'V', -1._wp )316 CALL dyn_kegAD( kt, nn_dynkeg, puu(:,:,:,Kmm) , zvv(:,:,:) , pu_rhs=puu(:,:,:,Krhs) ) ! compute and add uu-vorticity trend317 DEALLOCATE( zvv )318 ENDIF319 CASE( np_ENS_adKEVO ) !* enstrophy conserving scheme with alternating direction320 IF( MOD( kt , 2 ) == 1 ) THEN ! even time step: u-vor then v-vor components321 322 !== Alternative direction - KE + VOR ==!323 324 ALLOCATE( zuu(jpi,jpj,jpk) )325 CALL vor_ens( kt, Kmm, ntot, puu(:,:,:,Kmm) , pvv(:,:,:,Kmm) , pu_rhs=puu(:,:,:,Krhs) ) ! compute and add uu-vorticity trend326 CALL dyn_kegAD( kt, nn_dynkeg, puu(:,:,:,Kmm) , pvv(:,:,:,Kmm) , pu_rhs=puu(:,:,:,Krhs) ) !327 zuu(:,:,:) = puu(:,:,:,Kbb) + rDt * puu(:,:,:,Krhs) * umask(:,:,:)328 CALL lbc_lnk( 'dynvor', zuu(:,:,:) , 'U', -1._wp )329 CALL vor_ens( kt, Kmm, ntot, zuu(:,:,:) , pvv(:,:,:,Kmm) , pv_rhs=pvv(:,:,:,Krhs) ) ! compute and add vv-vorticity trend330 CALL dyn_kegAD( kt, nn_dynkeg, zuu(:,:,:) , pvv(:,:,:,Kmm) , pv_rhs=pvv(:,:,:,Krhs) )331 DEALLOCATE( zuu )332 ELSE333 334 ALLOCATE( zvv(jpi,jpj,jpk) )335 CALL vor_ens( kt, Kmm, ntot, puu(:,:,:,Kmm) , pvv(:,:,:,Kmm) , pv_rhs=pvv(:,:,:,Krhs) ) ! compute and add vv-vorticity trend336 CALL dyn_kegAD( kt, nn_dynkeg, puu(:,:,:,Kmm) , pvv(:,:,:,Kmm) , pv_rhs=pvv(:,:,:,Krhs) )337 zvv(:,:,:) = pvv(:,:,:,Kbb) + rDt * pvv(:,:,:,Krhs) * vmask(:,:,:)338 CALL lbc_lnk( 'dynvor', zvv(:,:,:) , 'V', -1._wp )339 CALL vor_ens( kt, Kmm, ntot, puu(:,:,:,Kmm), zvv(:,:,:) , pu_rhs=puu(:,:,:,Krhs) ) ! compute and add uu-vorticity trend340 CALL dyn_kegAD( kt, nn_dynkeg, puu(:,:,:,Kmm), zvv(:,:,:) , pu_rhs=puu(:,:,:,Krhs) )341 DEALLOCATE( zvv )342 ENDIF343 173 IF( ln_stcor ) CALL vor_ens( kt, Kmm, ncor, usd, vsd, puu(:,:,:,Krhs), pvv(:,:,:,Krhs) ) ! add the Stokes-Coriolis trend 344 174 CASE( np_MIX ) !* mixed ene-ens scheme … … 427 257 DO_2D_01_01 428 258 zwt(ji,jj) = r1_4 * ( zwz(ji-1,jj ,jk) + zwz(ji,jj ,jk) & 429 & + zwz(ji-1,jj-1,jk) + zwz(ji,jj-1,jk) ) * e1e2t(ji,jj)*e3t(ji,jj,jk,Kmm) 259 & + zwz(ji-1,jj-1,jk) + zwz(ji,jj-1,jk) ) & 260 & * e1e2t(ji,jj)*e3t(ji,jj,jk,Kmm) 430 261 END_2D 431 262 CASE ( np_MET ) !* metric term 432 263 DO_2D_01_01 433 zwt(ji,jj) = ( ( pv(ji,jj,jk) + pv(ji,jj-1,jk) ) * di_e2u_2(ji,jj) & 434 & - ( pu(ji,jj,jk) + pu(ji-1,jj,jk) ) * dj_e1v_2(ji,jj) ) * e3t(ji,jj,jk,Kmm) 264 zwt(ji,jj) = ( ( pv(ji,jj,jk) + pv(ji,jj-1,jk) ) * di_e2u_2(ji,jj) & 265 & - ( pu(ji,jj,jk) + pu(ji-1,jj,jk) ) * dj_e1v_2(ji,jj) ) & 266 & * e3t(ji,jj,jk,Kmm) 435 267 END_2D 436 268 CASE ( np_CRV ) !* Coriolis + relative vorticity 437 269 DO_2D_01_01 438 zwt(ji,jj) = ( ff_t(ji,jj) + r1_4 * ( zwz(ji-1,jj ,jk) + zwz(ji,jj ,jk) & 439 & + zwz(ji-1,jj-1,jk) + zwz(ji,jj-1,jk) ) ) * e1e2t(ji,jj)*e3t(ji,jj,jk,Kmm) 270 zwt(ji,jj) = ( ff_t(ji,jj) + r1_4 * ( zwz(ji-1,jj ,jk) + zwz(ji,jj ,jk) & 271 & + zwz(ji-1,jj-1,jk) + zwz(ji,jj-1,jk) ) ) & 272 & * e1e2t(ji,jj)*e3t(ji,jj,jk,Kmm) 440 273 END_2D 441 274 CASE ( np_CME ) !* Coriolis + metric 442 275 DO_2D_01_01 443 zwt(ji,jj) = ( ff_t(ji,jj) * e1e2t(ji,jj) & 444 & + ( pv(ji,jj,jk) + pv(ji,jj-1,jk) ) * di_e2u_2(ji,jj) & 445 & - ( pu(ji,jj,jk) + pu(ji-1,jj,jk) ) * dj_e1v_2(ji,jj) ) * e3t(ji,jj,jk,Kmm) 276 zwt(ji,jj) = ( ff_t(ji,jj) * e1e2t(ji,jj) & 277 & + ( pv(ji,jj,jk) + pv(ji,jj-1,jk) ) * di_e2u_2(ji,jj) & 278 & - ( pu(ji,jj,jk) + pu(ji-1,jj,jk) ) * dj_e1v_2(ji,jj) ) & 279 & * e3t(ji,jj,jk,Kmm) 446 280 END_2D 447 281 CASE DEFAULT ! error … … 485 319 !! References : Sadourny, r., 1975, j. atmos. sciences, 32, 680-689. 486 320 !!---------------------------------------------------------------------- 487 INTEGER 488 INTEGER 489 INTEGER 490 REAL(wp), DIMENSION(jpi,jpj,jpk) 491 REAL(wp), DIMENSION(jpi,jpj,jpk), OPTIONAL,INTENT(inout) :: pu_rhs, pv_rhs ! total v-trend321 INTEGER , INTENT(in ) :: kt ! ocean time-step index 322 INTEGER , INTENT(in ) :: Kmm ! ocean time level index 323 INTEGER , INTENT(in ) :: kvor ! total, planetary, relative, or metric 324 REAL(wp), DIMENSION(jpi,jpj,jpk), INTENT(inout) :: pu, pv ! now velocities 325 REAL(wp), DIMENSION(jpi,jpj,jpk), INTENT(inout) :: pu_rhs, pv_rhs ! total v-trend 492 326 ! 493 327 INTEGER :: ji, jj, jk ! dummy loop indices … … 543 377 END SELECT 544 378 ! 545 IF( PRESENT( pu_rhs ) .AND. PRESENT( pv_rhs ) ) THEN !*** NO alternating direction ***! 546 ! 547 ! !== horizontal fluxes and potential vorticity ==! 548 zwx(:,:) = e2u(:,:) * e3u(:,:,jk,Kmm) * pu(:,:,jk) 549 zwy(:,:) = e1v(:,:) * e3v(:,:,jk,Kmm) * pv(:,:,jk) 550 zwz(:,:) = zwz(:,:) / e3f(:,:,jk) 551 ! 552 ! !== compute and add the vorticity term trend =! 553 DO_2D_00_00 554 zy1 = zwy(ji,jj-1) + zwy(ji+1,jj-1) 555 zy2 = zwy(ji,jj ) + zwy(ji+1,jj ) 556 zx1 = zwx(ji-1,jj) + zwx(ji-1,jj+1) 557 zx2 = zwx(ji ,jj) + zwx(ji ,jj+1) 558 pu_rhs(ji,jj,jk) = pu_rhs(ji,jj,jk) + r1_4 * r1_e1u(ji,jj) * ( zwz(ji ,jj-1) * zy1 + zwz(ji,jj) * zy2 ) 559 pv_rhs(ji,jj,jk) = pv_rhs(ji,jj,jk) - r1_4 * r1_e2v(ji,jj) * ( zwz(ji-1,jj ) * zx1 + zwz(ji,jj) * zx2 ) 560 END_2D 561 ! 562 ! 563 ELSEIF( PRESENT( pu_rhs ) .AND. .NOT. PRESENT( pv_rhs ) ) THEN !*** Alternating direction : i-component ***! 564 ! 565 ! 566 ! !== horizontal fluxes and potential vorticity ==! 567 zwy(:,:) = e1v(:,:) * e3v(:,:,jk,Kmm) * pv(:,:,jk) 568 zwz(:,:) = zwz(:,:) / e3f(:,:,jk) 569 ! 570 ! !== compute and add the vorticity term trend =! 571 DO_2D_00_00 572 zy1 = zwy(ji,jj-1) + zwy(ji+1,jj-1) 573 zy2 = zwy(ji,jj ) + zwy(ji+1,jj ) 574 pu_rhs(ji,jj,jk) = pu_rhs(ji,jj,jk) + r1_4 * r1_e1u(ji,jj) * ( zwz(ji ,jj-1) * zy1 + zwz(ji,jj) * zy2 ) 575 END_2D 576 ! 577 ELSEIF( .NOT. PRESENT( pu_rhs ) .AND. PRESENT( pv_rhs ) ) THEN !*** Alternating direction : j-component ***! 578 ! 579 ! 580 ! !== horizontal fluxes and potential vorticity ==! 581 zwx(:,:) = e2u(:,:) * e3u(:,:,jk,Kmm) * pu(:,:,jk) 582 zwz(:,:) = zwz(:,:) / e3f(:,:,jk) 583 ! 584 ! !== compute and add the vorticity term trend =! 585 DO_2D_00_00 586 zx1 = zwx(ji-1,jj) + zwx(ji-1,jj+1) 587 zx2 = zwx(ji ,jj) + zwx(ji ,jj+1) 588 pv_rhs(ji,jj,jk) = pv_rhs(ji,jj,jk) - r1_4 * r1_e2v(ji,jj) * ( zwz(ji-1,jj ) * zx1 + zwz(ji,jj) * zx2 ) 589 END_2D 590 ! 591 ENDIF 379 ! !== horizontal fluxes and potential vorticity ==! 380 zwx(:,:) = e2u(:,:) * e3u(:,:,jk,Kmm) * pu(:,:,jk) 381 zwy(:,:) = e1v(:,:) * e3v(:,:,jk,Kmm) * pv(:,:,jk) 382 zwz(:,:) = zwz(:,:) / e3f(:,:,jk) 383 ! 384 ! !== compute and add the vorticity term trend =! 385 DO_2D_00_00 386 zy1 = zwy(ji,jj-1) + zwy(ji+1,jj-1) 387 zy2 = zwy(ji,jj ) + zwy(ji+1,jj ) 388 zx1 = zwx(ji-1,jj) + zwx(ji-1,jj+1) 389 zx2 = zwx(ji ,jj) + zwx(ji ,jj+1) 390 pu_rhs(ji,jj,jk) = pu_rhs(ji,jj,jk) + r1_4 * r1_e1u(ji,jj) * ( zwz(ji ,jj-1) * zy1 + zwz(ji,jj) * zy2 ) 391 pv_rhs(ji,jj,jk) = pv_rhs(ji,jj,jk) - r1_4 * r1_e2v(ji,jj) * ( zwz(ji-1,jj ) * zx1 + zwz(ji,jj) * zx2 ) 392 END_2D 592 393 ! ! =============== 593 394 END DO ! End of slab … … 616 417 !! References : Sadourny, r., 1975, j. atmos. sciences, 32, 680-689. 617 418 !!---------------------------------------------------------------------- 618 INTEGER 619 INTEGER 620 INTEGER 621 REAL(wp), DIMENSION(jpi,jpj,jpk) 622 REAL(wp), DIMENSION(jpi,jpj,jpk), OPTIONAL,INTENT(inout) :: pu_rhs, pv_rhs ! total v-trend419 INTEGER , INTENT(in ) :: kt ! ocean time-step index 420 INTEGER , INTENT(in ) :: Kmm ! ocean time level index 421 INTEGER , INTENT(in ) :: kvor ! total, planetary, relative, or metric 422 REAL(wp), DIMENSION(jpi,jpj,jpk), INTENT(inout) :: pu, pv ! now velocities 423 REAL(wp), DIMENSION(jpi,jpj,jpk), INTENT(inout) :: pu_rhs, pv_rhs ! total v-trend 623 424 ! 624 425 INTEGER :: ji, jj, jk ! dummy loop indices … … 674 475 ! 675 476 ! 676 !!an wut ? v et u 677 IF( PRESENT( pu_rhs ) .AND. PRESENT( pv_rhs ) ) THEN !*** NO alternating direction ***! 678 ! 679 ! !== horizontal fluxes and potential vorticity ==! 680 zwx(:,:) = e2u(:,:) * e3u(:,:,jk,Kmm) * pu(:,:,jk) 681 zwy(:,:) = e1v(:,:) * e3v(:,:,jk,Kmm) * pv(:,:,jk) 682 zwz(:,:) = zwz(:,:) / e3f(:,:,jk) 683 ! 684 ! !== compute and add the vorticity term trend =! 685 DO_2D_00_00 686 zuav = r1_8 * r1_e1u(ji,jj) * ( zwy(ji ,jj-1) + zwy(ji+1,jj-1) & 687 & + zwy(ji ,jj ) + zwy(ji+1,jj ) ) 688 zvau =-r1_8 * r1_e2v(ji,jj) * ( zwx(ji-1,jj ) + zwx(ji-1,jj+1) & 689 & + zwx(ji ,jj ) + zwx(ji ,jj+1) ) 690 pu_rhs(ji,jj,jk) = pu_rhs(ji,jj,jk) + zuav * ( zwz(ji ,jj-1) + zwz(ji,jj) ) 691 pv_rhs(ji,jj,jk) = pv_rhs(ji,jj,jk) + zvau * ( zwz(ji-1,jj ) + zwz(ji,jj) ) 692 END_2D 693 ! 694 ELSEIF( PRESENT( pu_rhs ) .AND. .NOT. PRESENT( pv_rhs ) ) THEN !*** Alternating direction : i-component ***! 695 ! 696 ! 697 ! !== horizontal fluxes and potential vorticity ==! 698 zwy(:,:) = e1v(:,:) * e3v(:,:,jk,Kmm) * pv(:,:,jk) 699 zwz(:,:) = zwz(:,:) / e3f(:,:,jk) 700 ! 701 ! !== compute and add the vorticity term trend =! 702 DO_2D_00_00 703 zuav = r1_8 * r1_e1u(ji,jj) * ( zwy(ji ,jj-1) + zwy(ji+1,jj-1) & 704 & + zwy(ji ,jj ) + zwy(ji+1,jj ) ) 705 pu_rhs(ji,jj,jk) = pu_rhs(ji,jj,jk) + zuav * ( zwz(ji ,jj-1) + zwz(ji,jj) ) 706 END_2D 707 ! 708 ELSEIF( .NOT. PRESENT( pu_rhs ) .AND. PRESENT( pv_rhs ) ) THEN !*** Alternating direction : j-component ***! 709 ! 710 ! 711 ! !== horizontal fluxes and potential vorticity ==! 712 zwx(:,:) = e2u(:,:) * e3u(:,:,jk,Kmm) * pu(:,:,jk) 713 zwz(:,:) = zwz(:,:) / e3f(:,:,jk) 714 ! 715 ! !== compute and add the vorticity term trend =! 716 DO_2D_00_00 717 zvau =-r1_8 * r1_e2v(ji,jj) * ( zwx(ji-1,jj ) + zwx(ji-1,jj+1) & 718 & + zwx(ji ,jj ) + zwx(ji ,jj+1) ) 719 pv_rhs(ji,jj,jk) = pv_rhs(ji,jj,jk) + zvau * ( zwz(ji-1,jj ) + zwz(ji,jj) ) 720 END_2D 721 ! 722 ENDIF 477 ! !== horizontal fluxes and potential vorticity ==! 478 zwx(:,:) = e2u(:,:) * e3u(:,:,jk,Kmm) * pu(:,:,jk) 479 zwy(:,:) = e1v(:,:) * e3v(:,:,jk,Kmm) * pv(:,:,jk) 480 zwz(:,:) = zwz(:,:) / e3f(:,:,jk) 481 ! 482 ! !== compute and add the vorticity term trend =! 483 DO_2D_00_00 484 zuav = r1_8 * r1_e1u(ji,jj) * ( zwy(ji ,jj-1) + zwy(ji+1,jj-1) & 485 & + zwy(ji ,jj ) + zwy(ji+1,jj ) ) 486 zvau =-r1_8 * r1_e2v(ji,jj) * ( zwx(ji-1,jj ) + zwx(ji-1,jj+1) & 487 & + zwx(ji ,jj ) + zwx(ji ,jj+1) ) 488 pu_rhs(ji,jj,jk) = pu_rhs(ji,jj,jk) + zuav * ( zwz(ji ,jj-1) + zwz(ji,jj) ) 489 pv_rhs(ji,jj,jk) = pv_rhs(ji,jj,jk) + zvau * ( zwz(ji-1,jj ) + zwz(ji,jj) ) 490 END_2D 723 491 ! ! =============== 724 492 END DO ! End of slab … … 772 540 CASE ( 0 ) ! original formulation (masked averaging of e3t divided by 4) 773 541 DO_2D_10_10 774 ze3f = ( e3t(ji,jj+1,jk,Kmm)*tmask(ji,jj+1,jk) + e3t(ji+1,jj+1,jk,Kmm)*tmask(ji+1,jj+1,jk) & 775 & + e3t(ji,jj ,jk,Kmm)*tmask(ji,jj ,jk) + e3t(ji+1,jj ,jk,Kmm)*tmask(ji+1,jj ,jk) ) 542 ze3f = ( e3t(ji ,jj+1,jk,Kmm)*tmask(ji ,jj+1,jk) & 543 & + e3t(ji+1,jj+1,jk,Kmm)*tmask(ji+1,jj+1,jk) & 544 & + e3t(ji ,jj ,jk,Kmm)*tmask(ji ,jj ,jk) & 545 & + e3t(ji+1,jj ,jk,Kmm)*tmask(ji+1,jj ,jk) ) 776 546 IF( ze3f /= 0._wp ) THEN ; z1_e3f(ji,jj) = 4._wp / ze3f 777 547 ELSE ; z1_e3f(ji,jj) = 0._wp … … 780 550 CASE ( 1 ) ! new formulation (masked averaging of e3t divided by the sum of mask) 781 551 DO_2D_10_10 782 ze3f = ( e3t(ji,jj+1,jk,Kmm)*tmask(ji,jj+1,jk) + e3t(ji+1,jj+1,jk,Kmm)*tmask(ji+1,jj+1,jk) & 783 & + e3t(ji,jj ,jk,Kmm)*tmask(ji,jj ,jk) + e3t(ji+1,jj ,jk,Kmm)*tmask(ji+1,jj ,jk) ) 552 ze3f = ( e3t(ji ,jj+1,jk,Kmm)*tmask(ji ,jj+1,jk) & 553 & + e3t(ji+1,jj+1,jk,Kmm)*tmask(ji+1,jj+1,jk) & 554 & + e3t(ji ,jj ,jk,Kmm)*tmask(ji ,jj ,jk) & 555 & + e3t(ji+1,jj ,jk,Kmm)*tmask(ji+1,jj ,jk) ) 784 556 zmsk = ( tmask(ji,jj+1,jk) + tmask(ji+1,jj+1,jk) & 785 557 & + tmask(ji,jj ,jk) + tmask(ji+1,jj ,jk) ) … … 1000 772 !! 1001 773 NAMELIST/namdyn_vor/ ln_dynvor_ens, ln_dynvor_ene, ln_dynvor_enT, ln_dynvor_eeT, & 1002 & ln_dynvor_een, nn_een_e3f , ln_dynvor_mix, ln_dynvor_msk, & 1003 & ln_dynvor_ens_adVO, ln_dynvor_ens_adKE, ln_dynvor_ens_adKEVO, & ! Alternative direction parameters 1004 & ln_dynvor_ene_adVO, ln_dynvor_ene_adKE, ln_dynvor_ene_adKEVO 774 & ln_dynvor_een, nn_een_e3f , ln_dynvor_mix, ln_dynvor_msk 1005 775 !!---------------------------------------------------------------------- 1006 776 ! … … 1019 789 IF(lwp) THEN ! Namelist print 1020 790 WRITE(numout,*) ' Namelist namdyn_vor : choice of the vorticity term scheme' 1021 WRITE(numout,*) ' enstrophy conserving scheme ln_dynvor_ens 1022 WRITE(numout,*) ' f-point energy conserving scheme ln_dynvor_ene 1023 WRITE(numout,*) ' t-point energy conserving scheme ln_dynvor_enT 1024 WRITE(numout,*) ' energy conserving scheme (een using e3t) ln_dynvor_eeT 1025 WRITE(numout,*) ' enstrophy and energy conserving scheme ln_dynvor_een 1026 WRITE(numout,*) ' e3f = averaging /4 (=0) or /sum(tmask) (=1) nn_een_e3f 1027 WRITE(numout,*) ' mixed enstrophy/energy conserving scheme ln_dynvor_mix 1028 WRITE(numout,*) ' masked (=T) or unmasked(=F) vorticity ln_dynvor_msk 791 WRITE(numout,*) ' enstrophy conserving scheme ln_dynvor_ens = ', ln_dynvor_ens 792 WRITE(numout,*) ' f-point energy conserving scheme ln_dynvor_ene = ', ln_dynvor_ene 793 WRITE(numout,*) ' t-point energy conserving scheme ln_dynvor_enT = ', ln_dynvor_enT 794 WRITE(numout,*) ' energy conserving scheme (een using e3t) ln_dynvor_eeT = ', ln_dynvor_eeT 795 WRITE(numout,*) ' enstrophy and energy conserving scheme ln_dynvor_een = ', ln_dynvor_een 796 WRITE(numout,*) ' e3f = averaging /4 (=0) or /sum(tmask) (=1) nn_een_e3f = ', nn_een_e3f 797 WRITE(numout,*) ' mixed enstrophy/energy conserving scheme ln_dynvor_mix = ', ln_dynvor_mix 798 WRITE(numout,*) ' masked (=T) or unmasked(=F) vorticity ln_dynvor_msk = ', ln_dynvor_msk 1029 799 ENDIF 1030 800 … … 1039 809 DO_3D_10_10( 1, jpk ) 1040 810 IF( tmask(ji,jj+1,jk) + tmask(ji+1,jj+1,jk) & 1041 & + tmask(ji,jj ,jk) + tmask(ji+1,jj 811 & + tmask(ji,jj ,jk) + tmask(ji+1,jj+1,jk) == 3._wp ) fmask(ji,jj,jk) = 1._wp 1042 812 END_3D 1043 813 ! … … 1049 819 ioptio = 0 ! type of scheme for vorticity (set nvor_scheme) 1050 820 IF( ln_dynvor_ens ) THEN ; ioptio = ioptio + 1 ; nvor_scheme = np_ENS ; ENDIF 1051 IF( ln_dynvor_ens_adVO ) THEN ; ioptio = ioptio + 1 ; nvor_scheme = np_ENS_adVO ; ENDIF1052 IF( ln_dynvor_ens_adKE ) THEN ; ioptio = ioptio + 1 ; nvor_scheme = np_ENS_adKE ; ENDIF1053 IF( ln_dynvor_ens_adKEVO ) THEN ; ioptio = ioptio + 1 ; nvor_scheme = np_ENS_adKEVO ; ENDIF1054 821 IF( ln_dynvor_ene ) THEN ; ioptio = ioptio + 1 ; nvor_scheme = np_ENE ; ENDIF 1055 IF( ln_dynvor_ene_adVO ) THEN ; ioptio = ioptio + 1 ; nvor_scheme = np_ENE_adVO ; ENDIF1056 IF( ln_dynvor_ene_adKE ) THEN ; ioptio = ioptio + 1 ; nvor_scheme = np_ENE_adKE ; ENDIF1057 IF( ln_dynvor_ene_adKEVO ) THEN ; ioptio = ioptio + 1 ; nvor_scheme = np_ENE_adKEVO ; ENDIF1058 822 IF( ln_dynvor_enT ) THEN ; ioptio = ioptio + 1 ; nvor_scheme = np_ENT ; ENDIF 1059 823 IF( ln_dynvor_eeT ) THEN ; ioptio = ioptio + 1 ; nvor_scheme = np_EET ; ENDIF … … 1072 836 CASE( np_VEC_c2 ) 1073 837 IF(lwp) WRITE(numout,*) ' ==>>> vector form dynamics : total vorticity = Coriolis + relative vorticity' 1074 nrvm = np_RVO ! relative vorticity 838 nrvm = np_RVO ! relative vorticity 1075 839 ntot = np_CRV ! relative + planetary vorticity 1076 840 CASE( np_FLX_c2 , np_FLX_ubs ) … … 1102 866 WRITE(numout,*) 1103 867 SELECT CASE( nvor_scheme ) 1104 1105 CASE( np_ENS ) ; WRITE(numout,*) ' ==>>> enstrophy conserving scheme (ENS)' 1106 CASE( np_ENS_adVO ) ; WRITE(numout,*) ' ==>>> AD enstrophy conserving scheme (ENS_adVO) on vorticity only' 1107 CASE( np_ENS_adKE ) ; WRITE(numout,*) ' ==>>> AD enstrophy conserving scheme (ENS_adKE) on kinetic energy only' 1108 CASE( np_ENS_adKEVO ) ; WRITE(numout,*) ' ==>>> AD enstrophy conserving scheme (ENS_adKEVO) on kinetic energy and vorticity' 1109 1110 CASE( np_ENE ) ; WRITE(numout,*) ' ==>>> energy conserving scheme (Coriolis at F-points) (ENE)' 1111 CASE( np_ENE_adVO ) ; WRITE(numout,*) ' ==>>> AD energy conserving scheme (Coriolis at F-points) (ENE_adVO) on vorticity only' 1112 CASE( np_ENE_adKE ) ; WRITE(numout,*) ' ==>>> AD energy conserving scheme (Coriolis at F-points) (ENE_adKE) on kinetic energy only' 1113 CASE( np_ENE_adKEVO ) ; WRITE(numout,*) ' ==>>> AD energy conserving scheme (Coriolis at F-points) (ENE_adKEVO) on kinetic energy and vorticity' 1114 1115 CASE( np_ENT ) ; WRITE(numout,*) ' ==>>> energy conserving scheme (Coriolis at T-points) (ENT)' 1116 CASE( np_EET ) ; WRITE(numout,*) ' ==>>> energy conserving scheme (EEN scheme using e3t) (EET)' 1117 CASE( np_EEN ) ; WRITE(numout,*) ' ==>>> energy and enstrophy conserving scheme (EEN)' 1118 CASE( np_MIX ) ; WRITE(numout,*) ' ==>>> mixed enstrophy/energy conserving scheme (MIX)' 868 CASE( np_ENS ) ; WRITE(numout,*) ' ==>>> enstrophy conserving scheme (ENS)' 869 CASE( np_ENE ) ; WRITE(numout,*) ' ==>>> energy conserving scheme (Coriolis at F-points) (ENE)' 870 CASE( np_ENT ) ; WRITE(numout,*) ' ==>>> energy conserving scheme (Coriolis at T-points) (ENT)' 871 CASE( np_EET ) ; WRITE(numout,*) ' ==>>> energy conserving scheme (EEN scheme using e3t) (EET)' 872 CASE( np_EEN ) ; WRITE(numout,*) ' ==>>> energy and enstrophy conserving scheme (EEN)' 873 CASE( np_MIX ) ; WRITE(numout,*) ' ==>>> mixed enstrophy/energy conserving scheme (MIX)' 1119 874 END SELECT 1120 875 ENDIF -
NEMO/branches/2020/dev_r12527_Gurvan_ShallowWater/src/SWE/ldfdyn.F90
r13005 r13151 25 25 USE lib_mpp ! distribued memory computing library 26 26 USE lbclnk ! ocean lateral boundary conditions (or mpp link) 27 ! 28 USE usrdef_nam , ONLY : ln_dynldf_lap_PM 29 ! 27 30 28 IMPLICIT NONE 31 29 PRIVATE … … 62 60 INTEGER , PUBLIC :: nldf_dyn !: type of lateral diffusion used defined from ln_dynldf_... (namlist logicals) 63 61 LOGICAL , PUBLIC :: l_ldfdyn_time !: flag for time variation of the lateral eddy viscosity coef. 64 !!an 65 !LOGICAL , PUBLIC :: ll_dynldf_lap_PM !: flag for P.Marchand modification on viscosity 66 !!an 62 67 63 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: ahmt, ahmf !: eddy viscosity coef. at T- and F-points [m2/s or m4/s] 68 64 REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: dtensq !: horizontal tension squared (Smagorinsky only) … … 327 323 IF( .NOT.l_ldfdyn_time ) THEN !* No time variation 328 324 IF( ln_dynldf_lap ) THEN ! laplacian operator (mask only) 329 !!an ! 330 WRITE(numout,*) ' ln_dynldf_lap_PM = ',ln_dynldf_lap_PM 331 IF( ln_dynldf_lap_PM ) THEN ! laplacian operator (mask only) 325 ahmt(:,:,1:jpkm1) = ahmt(:,:,1:jpkm1) * tmask(:,:,1:jpkm1) 326 WRITE(numout,*) ' ahmt tmask ' 332 327 !! mask tension at the coast (equivalent of ghostpoints at T) 333 DO jk = 1, jpk 334 DO jj = 1, jpjm1 335 DO ji = 1, jpim1 ! NO vector opt. 336 ! si sum(fmask)==3 = mouillé (on touche pas) 337 ! si sum = 2 alors on met a 0 zsum = fmask + fmask + fmask,.. et si zsum < 2 -> 0 sinon = 1 338 zsum = fmask(ji,jj ,jk) + fmask(ji+1,jj ,jk) & 339 & + fmask(ji,jj+1,jk) + fmask(ji+1,jj+1,jk) 340 IF ( zsum < 2._wp ) ahmt(ji,jj,jk) = 0 341 ! 342 !ahmt(ji,jj,jk) = ahmt(ji,jj,jk) * fmask(ji,jj ,jk) * fmask(ji+1,jj ,jk) & 343 ! & * fmask(ji,jj+1,jk) * fmask(ji+1,jj+1,jk) 344 END DO 345 END DO 346 END DO 347 ahmt(jpi,:,1:jpkm1) = 0._wp 348 ahmt(:,jpj,1:jpkm1) = 0._wp 349 WRITE(numout,*) ' ahmt x0' 350 !! apply no slip at the coast (ssfmask = 1 within the domain and at the coast contrary to fmask in free slip) 351 DO jk = 1, jpkm1 352 ahmf(:,:,jk) = ahmf(:,:,jk) * ( 2._wp * ssfmask(:,:) - fmask(:,:,jk) ) 353 END DO 354 WRITE(numout,*) ' ahmf x2' 355 ELSE 356 ! classic boundary condition on the viscosity coefficient 357 ahmt(:,:,1:jpkm1) = ahmt(:,:,1:jpkm1) * tmask(:,:,1:jpkm1) 358 WRITE(numout,*) ' ahmt tmasked ' 359 ahmf(:,:,1:jpkm1) = ahmf(:,:,1:jpkm1) * fmask(:,:,1:jpkm1) 360 WRITE(numout,*) ' ahmf fmasked ' 361 ENDIF 362 !!an ! 328 ! DO jk = 1, jpk 329 ! DO jj = 1, jpjm1 330 ! DO ji = 1, jpim1 ! NO vector opt. 331 ! ! si sum(fmask)==3 = mouillé (on touche pas) 332 ! ! si sum = 2 alors on met a 0 zsum = fmask + fmask + fmask,.. et si zsum < 2 -> 0 sinon = 1 333 ! zsum = fmask(ji,jj ,jk) + fmask(ji+1,jj ,jk) & 334 ! & + fmask(ji,jj+1,jk) + fmask(ji+1,jj+1,jk) 335 ! IF ( zsum < 2._wp ) ahmt(ji,jj,jk) = 0 336 ! ! 337 ! !ahmt(ji,jj,jk) = ahmt(ji,jj,jk) * fmask(ji,jj ,jk) * fmask(ji+1,jj ,jk) & 338 ! ! & * fmask(ji,jj+1,jk) * fmask(ji+1,jj+1,jk) 339 ! END DO 340 ! END DO 341 ! END DO 342 ! ahmt(jpi,:,1:jpkm1) = 0._wp 343 ! ahmt(:,jpj,1:jpkm1) = 0._wp 344 ! WRITE(numout,*) ' an45 ahmt x0' 345 346 ahmf(:,:,1:jpkm1) = ahmf(:,:,1:jpkm1) * fmask(:,:,1:jpkm1) 347 WRITE(numout,*) ' ahmf fmask ' 348 !!an apply no slip at the coast (ssfmask = 1 within the domain and at the coast contrary to fmask in free slip) 349 ! DO jk = 1, jpkm1 350 ! ahmf(:,:,jk) = ahmf(:,:,jk) * ( 2._wp * ssfmask(:,:) - fmask(:,:,jk) ) 351 ! END DO 352 ! WRITE(numout,*) ' an45 ahmf x2' 353 363 354 ELSEIF( ln_dynldf_blp ) THEN ! bilaplacian operator (square root + mask) 364 355 ahmt(:,:,1:jpkm1) = SQRT( ahmt(:,:,1:jpkm1) ) * tmask(:,:,1:jpkm1) -
NEMO/branches/2020/dev_r12527_Gurvan_ShallowWater/src/SWE/nemogcm.F90
r12614 r13151 60 60 USE diacfl ! CFL diagnostics (dia_cfl_init routine) 61 61 USE diamlr ! IOM context management for multiple-linear-regression analysis 62 #if defined key_RK3 63 USE stpRK3 64 #elif defined key_qco 65 USE stpLF 66 #else 62 67 USE step ! NEMO time-stepping (stp routine) 68 #endif 63 69 USE isfstp ! ice shelf (isf_stp_init routine) 64 70 USE icbini ! handle bergs, initialisation … … 175 181 IF ( istp == nitend ) elapsed_time = zstptiming - elapsed_time 176 182 ENDIF 177 178 CALL stp ( istp ) 183 #if defined key_RK3 184 CALL stp_RK3 ( istp ) 185 #elif defined key_qco 186 CALL stp_LF ( istp ) 187 #else 188 CALL stp ( istp ) 189 #endif 179 190 istp = istp + 1 180 191 -
NEMO/branches/2020/dev_r12527_Gurvan_ShallowWater/src/SWE/sbcice_cice.F90
r12614 r13151 12 12 USE oce ! ocean dynamics and tracers 13 13 USE dom_oce ! ocean space and time domain 14 !!st8 15 # if ! defined key_qco 14 16 USE domvvl 17 # else 18 USE domqco 19 # endif 20 !!st8 15 21 USE phycst, only : rcp, rho0, r1_rho0, rhos, rhoi 16 22 USE in_out_manager ! I/O manager … … 233 239 !!gm This should be put elsewhere.... (same remark for limsbc) 234 240 !!gm especially here it is assumed zstar coordinate, but it can be ztilde.... 241 !!st9 242 #if defined key_qco 243 IF( .NOT.ln_linssh ) CALL dom_qco_zgr( Kbb, Kmm, Kaa ) ! interpolation scale factor, depth and water column 244 #else 235 245 IF( .NOT.ln_linssh ) THEN 236 246 ! 237 247 DO jk = 1,jpkm1 ! adjust initial vertical scale factors 238 e3t(:,:,jk,Kmm) = e3t_0(:,:,jk)*( 1._wp + ssh(:,:,Kmm)* tmask(:,:,1)/(ht_0(:,:) + 1.0 - tmask(:,:,1)) )239 e3t(:,:,jk,Kbb) = e3t_0(:,:,jk)*( 1._wp + ssh(:,:,Kbb)* tmask(:,:,1)/(ht_0(:,:) + 1.0 - tmask(:,:,1)) )240 END DO248 e3t(:,:,jk,Kmm) = e3t_0(:,:,jk)*( 1._wp + ssh(:,:,Kmm)*r1_ht_0(:,:)*tmask(:,:,jk) ) 249 e3t(:,:,jk,Kbb) = e3t_0(:,:,jk)*( 1._wp + ssh(:,:,Kbb)*r1_ht_0(:,:)*tmask(:,:,jk) ) 250 END DO 241 251 e3t(:,:,:,Krhs) = e3t(:,:,:,Kbb) 242 252 ! Reconstruction of all vertical scale factors at now and before time-steps … … 267 277 END DO 268 278 ENDIF 279 #endif 280 !!st9 269 281 ENDIF 270 282 ENDIF -
NEMO/branches/2020/dev_r12527_Gurvan_ShallowWater/src/SWE/step.F90
r13005 r13151 6 6 !! History : NEMO ! 2020-03 (A. Nasser, G. Madec) Original code from 4.0.2 7 7 !!---------------------------------------------------------------------- 8 8 #if defined key_qco 9 !!---------------------------------------------------------------------- 10 !! 'key_qco' EMPTY MODULE Quasi-Eulerian vertical coordonate 11 !!---------------------------------------------------------------------- 12 #else 9 13 !!---------------------------------------------------------------------- 10 14 !! stp : Shallow Water time-stepping … … 13 17 USE phycst ! physical constants 14 18 USE usrdef_nam 15 USE lib_mpp ! MPP library16 USE dynvor , ONLY : ln_dynvor_ens_adVO, ln_dynvor_ens_adKE, ln_dynvor_ens_adKEVO, &17 & ln_dynvor_ene_adVO, ln_dynvor_ene_adKE, ln_dynvor_ene_adKEVO18 19 ! 19 20 USE iom ! xIOs server … … 122 123 ! LATERAL PHYSICS 123 124 ! ! eddy diffusivity coeff. 124 IF( l_ldfdyn_time ) CALL ldf_dyn( kstp, Nbb )! eddy viscosity coeff.125 IF( l_ldfdyn_time ) CALL ldf_dyn( kstp, Nbb ) ! eddy viscosity coeff. 125 126 126 127 !>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>> … … 129 130 130 131 CALL ssh_nxt ( kstp, Nbb, Nnn, ssh, Naa ) ! after ssh (includes call to div_hor) 131 132 IF( .NOT.ln_linssh ) CALL dom_vvl_sf_nxt( kstp, Nbb, Nnn, Naa ) ! after vertical scale factors133 134 132 uu(:,:,:,Nrhs) = 0._wp ! set dynamics trends to zero 135 133 vv(:,:,:,Nrhs) = 0._wp 136 134 137 IF( ln_bdy ) CALL bdy_dyn3d_dmp ( kstp, Nbb, uu, vv, Nrhs ) ! bdy damping trends 135 IF( .NOT.ln_linssh ) CALL dom_vvl_sf_nxt( kstp, Nbb, Nnn, Naa ) ! after vertical scale factors 136 137 IF( ln_bdy ) CALL bdy_dyn3d_dmp ( kstp, Nbb, uu, vv, Nrhs ) ! bdy damping trends 138 138 139 139 #if defined key_agrif 140 140 IF(.NOT. Agrif_Root()) & 141 & CALL Agrif_Sponge_dyn ! momentum sponge 142 #endif 141 & CALL Agrif_Sponge_dyn ! momentum sponge 142 #endif 143 CALL dyn_adv( kstp, Nbb, Nnn , uu, vv, Nrhs ) ! advection (VF or FF) ==> RHS 144 145 CALL dyn_vor( kstp, Nnn , uu, vv, Nrhs ) ! vorticity ==> RHS 146 147 CALL dyn_ldf( kstp, Nbb, Nnn , uu, vv, Nrhs ) ! lateral mixing 143 148 144 149 !!an - calcul du gradient de pression horizontal (explicit) … … 148 153 END_3D 149 154 ! 150 151 ! IF( kstp == nit000 .AND. lwp ) THEN152 ! WRITE(numout,*)153 ! WRITE(numout,*) 'step.F90 : classic script used'154 ! WRITE(numout,*) '~~~~~~~'155 ! IF( ln_dynvor_ens_adVO .OR. ln_dynvor_ens_adKE .OR. ln_dynvor_ens_adKEVO &156 ! & .OR. ln_dynvor_ene_adVO .OR. ln_dynvor_ene_adKE .OR. ln_dynvor_ene_adKEVO ) THEN157 ! CALL ctl_stop('STOP','step : alternative direction asked but classis step' )158 ! ENDIF159 ! ENDIF160 !!an161 ! CALL dyn_adv( kstp, Nbb, Nnn , uu, vv, Nrhs ) ! advection (VF or FF) ==> RHS162 !163 ! CALL dyn_vor( kstp, Nbb, Nnn , uu, vv, Nrhs ) ! vorticity ==> RHS164 !165 !!an In dynvor, dynkegAD is called even if not AD, so we keep the same step.F90166 167 CALL dyn_vor( kstp, Nbb, Nnn , uu, vv, Nrhs) ! vorticity ==> RHS168 169 CALL dyn_ldf( kstp, Nbb, Nnn , uu, vv, Nrhs ) ! lateral mixing170 171 155 ! add wind stress forcing and layer linear friction to the RHS 172 156 z1_2rho0 = 0.5_wp * r1_rho0 … … 175 159 & - rn_rfr * uu(ji,jj,jk,Nbb) 176 160 vv(ji,jj,jk,Nrhs) = vv(ji,jj,jk,Nrhs) + z1_2rho0 * ( vtau_b(ji,jj) + vtau(ji,jj) ) / e3v(ji,jj,jk,Nnn) & 177 & - rn_rfr * vv(ji,jj,jk,Nbb) 161 & - rn_rfr * vv(ji,jj,jk,Nbb) 178 162 END_3D 179 163 !!an … … 182 166 ! Leap-Frog time splitting + Robert-Asselin time filter on u,v,e3 183 167 !<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<< 184 168 169 !! what about IF( .NOT.ln_linssh ) ? 185 170 !!an futur module dyn_nxt (a la place de dyn_atf) 186 171 … … 209 194 uu(ji,jj,jk,Naa) = zua 210 195 vv(ji,jj,jk,Naa) = zva 211 END_3D196 END_3D 212 197 ENDIF 213 198 ! … … 220 205 zue3a = zue3b + rDt * e3u(ji,jj,jk,Nrhs) * uu(ji,jj,jk,Nrhs) * umask(ji,jj,jk) 221 206 zve3a = zve3b + rDt * e3v(ji,jj,jk,Nrhs) * vv(ji,jj,jk,Nrhs) * vmask(ji,jj,jk) 222 ! 207 ! 223 208 uu(ji,jj,jk,Naa) = zue3a / e3u(ji,jj,jk,Naa) 224 vv(ji,jj,jk,Naa) = zve3a / e3v(ji,jj,jk,Naa) 225 END_3D226 ELSE ! Leap Frog time stepping + Asselin filter 209 vv(ji,jj,jk,Naa) = zve3a / e3v(ji,jj,jk,Naa) 210 END_3D 211 ELSE ! Leap Frog time stepping + Asselin filter 227 212 DO_3D_11_11(1,jpkm1) 228 213 zue3n = e3u(ji,jj,jk,Nnn) * uu(ji,jj,jk,Nnn) … … 239 224 ! ! Asselin time filter on u,v (Nnn) 240 225 uu(ji,jj,jk,Nnn) = ( zue3n + rn_atfp * ( zue3b - 2._wp * zue3n + zue3a ) ) / ze3u_tf 241 vv(ji,jj,jk,Nnn) = ( zve3n + rn_atfp * ( zve3b - 2._wp * zve3n + zve3a ) ) / ze3v_tf 226 vv(ji,jj,jk,Nnn) = ( zve3n + rn_atfp * ( zve3b - 2._wp * zve3n + zve3a ) ) / ze3v_tf 242 227 ! 243 228 e3u(ji,jj,jk,Nnn) = ze3u_tf … … 246 231 ! 247 232 uu(ji,jj,jk,Naa) = zue3a / e3u(ji,jj,jk,Naa) 248 vv(ji,jj,jk,Naa) = zve3a / e3v(ji,jj,jk,Naa) 249 END_3D233 vv(ji,jj,jk,Naa) = zve3a / e3v(ji,jj,jk,Naa) 234 END_3D 250 235 ENDIF 251 236 ENDIF 252 237 238 253 239 CALL lbc_lnk_multi( 'stp', uu(:,:,:,Nnn), 'U', -1., vv(:,:,:,Nnn), 'V', -1., & !* local domain boundaries 254 240 & uu(:,:,:,Naa), 'U', -1., vv(:,:,:,Naa), 'V', -1. ) … … 263 249 !! CALL dyn_atf ( kstp, Nbb, Nnn, Naa, uu, vv, e3t, e3u, e3v ) ! time filtering of "now" velocities and scale factors 264 250 !!an TO BE ADDED : a simplifier 265 ! CALL ssh_atf ( kstp, Nbb, Nnn, Naa, ssh ) ! time filtering of "now" sea surface height 266 251 !! CALL ssh_atf ( kstp, Nbb, Nnn, Naa, ssh ) ! time filtering of "now" sea surface height 267 252 IF ( .NOT.( l_1st_euler ) ) THEN ! Only do time filtering for leapfrog timesteps 268 253 ! ! filtering "now" field 269 254 ssh(:,:,Nnn) = ssh(:,:,Nnn) + rn_atfp * ( ssh(:,:,Nbb) - 2 * ssh(:,:,Nnn) + ssh(:,:,Naa) ) 270 255 ENDIF 271 272 256 !!an 273 257 … … 280 264 ! 281 265 CALL dom_vvl_sf_update( kstp, Nbb, Nnn, Naa ) ! recompute vertical scale factors 282 283 266 !>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>> 284 267 ! diagnostics and outputs … … 287 270 IF( ln_diacfl ) CALL dia_cfl ( kstp, Nnn ) ! Courant number diagnostics 288 271 289 CALL dia_wri ( kstp, Nnn ) ! ocean model: outputs 290 272 CALL dia_wri ( kstp, Nnn ) ! ocean model: outputs 291 273 ! 292 274 IF( lrst_oce ) CALL rst_write ( kstp, Nbb, Nnn ) ! write output ocean restart file … … 335 317 ! 336 318 END SUBROUTINE stp 319 #endif 337 320 ! 338 321 !!====================================================================== -
NEMO/branches/2020/dev_r12527_Gurvan_ShallowWater/src/SWE/stpctl.F90
r12614 r13151 35 35 INTEGER :: idrun, idtime, idssh, idu, ids1, ids2, idt1, idt2, idc1, idw1, istatus 36 36 LOGICAL :: lsomeoce 37 !!stoops 38 # include "domzgr_substitute.h90" 37 39 !!---------------------------------------------------------------------- 38 40 !! NEMO/OCE 4.0 , NEMO Consortium (2018) -
NEMO/branches/2020/dev_r12527_Gurvan_ShallowWater/src/TOP/C14/trcsms_c14.F90
r12489 r13151 28 28 !! * Substitutions 29 29 # include "do_loop_substitute.h90" 30 # include "domzgr_substitute.h90" 30 31 !!---------------------------------------------------------------------- 31 32 !! NEMO/TOP 4.0 , NEMO Consortium (2018) -
NEMO/branches/2020/dev_r12527_Gurvan_ShallowWater/src/TOP/CFC/trcsms_cfc.F90
r12489 r13151 49 49 !! * Substitutions 50 50 # include "do_loop_substitute.h90" 51 # include "domzgr_substitute.h90" 51 52 !!---------------------------------------------------------------------- 52 53 !! NEMO/TOP 4.0 , NEMO Consortium (2018) -
NEMO/branches/2020/dev_r12527_Gurvan_ShallowWater/src/TOP/PISCES/P2Z/p2zbio.F90
r12377 r13151 58 58 !! * Substitutions 59 59 # include "do_loop_substitute.h90" 60 # include "domzgr_substitute.h90" 60 61 !!---------------------------------------------------------------------- 61 62 !! NEMO/TOP 4.0 , NEMO Consortium (2018) -
NEMO/branches/2020/dev_r12527_Gurvan_ShallowWater/src/TOP/PISCES/P2Z/p2zexp.F90
r12489 r13151 39 39 !! * Substitutions 40 40 # include "do_loop_substitute.h90" 41 # include "domzgr_substitute.h90" 41 42 !!---------------------------------------------------------------------- 42 43 !! NEMO/TOP 4.0 , NEMO Consortium (2018) -
NEMO/branches/2020/dev_r12527_Gurvan_ShallowWater/src/TOP/PISCES/P2Z/p2zopt.F90
r12377 r13151 40 40 !! * Substitutions 41 41 # include "do_loop_substitute.h90" 42 # include "domzgr_substitute.h90" 42 43 !!---------------------------------------------------------------------- 43 44 !! NEMO/TOP 4.0 , NEMO Consortium (2018) -
NEMO/branches/2020/dev_r12527_Gurvan_ShallowWater/src/TOP/PISCES/P2Z/p2zsed.F90
r12377 r13151 33 33 !! * Substitutions 34 34 # include "do_loop_substitute.h90" 35 # include "domzgr_substitute.h90" 35 36 !!---------------------------------------------------------------------- 36 37 !! NEMO/TOP 4.0 , NEMO Consortium (2018) -
NEMO/branches/2020/dev_r12527_Gurvan_ShallowWater/src/TOP/PISCES/P4Z/p4zbc.F90
r12377 r13151 48 48 !! * Substitutions 49 49 # include "do_loop_substitute.h90" 50 # include "domzgr_substitute.h90" 50 51 !!---------------------------------------------------------------------- 51 52 !! NEMO/TOP 4.0 , NEMO Consortium (2018) -
NEMO/branches/2020/dev_r12527_Gurvan_ShallowWater/src/TOP/PISCES/P4Z/p4zbio.F90
r12377 r13151 40 40 !! * Substitutions 41 41 # include "do_loop_substitute.h90" 42 # include "domzgr_substitute.h90" 42 43 !!---------------------------------------------------------------------- 43 44 !! NEMO/TOP 4.0 , NEMO Consortium (2018) -
NEMO/branches/2020/dev_r12527_Gurvan_ShallowWater/src/TOP/PISCES/P4Z/p4zche.F90
r12377 r13151 132 132 !! * Substitutions 133 133 # include "do_loop_substitute.h90" 134 # include "domzgr_substitute.h90" 134 135 !!---------------------------------------------------------------------- 135 136 !! NEMO/TOP 4.0 , NEMO Consortium (2018) -
NEMO/branches/2020/dev_r12527_Gurvan_ShallowWater/src/TOP/PISCES/P4Z/p4zfechem.F90
r12377 r13151 33 33 !! * Substitutions 34 34 # include "do_loop_substitute.h90" 35 # include "domzgr_substitute.h90" 35 36 !!---------------------------------------------------------------------- 36 37 !! NEMO/TOP 4.0 , NEMO Consortium (2018) -
NEMO/branches/2020/dev_r12527_Gurvan_ShallowWater/src/TOP/PISCES/P4Z/p4zflx.F90
r12377 r13151 54 54 !! * Substitutions 55 55 # include "do_loop_substitute.h90" 56 # include "domzgr_substitute.h90" 56 57 !!---------------------------------------------------------------------- 57 58 !! NEMO/TOP 4.0 , NEMO Consortium (2018) -
NEMO/branches/2020/dev_r12527_Gurvan_ShallowWater/src/TOP/PISCES/P4Z/p4zopt.F90
r12377 r13151 44 44 !! * Substitutions 45 45 # include "do_loop_substitute.h90" 46 # include "domzgr_substitute.h90" 46 47 !!---------------------------------------------------------------------- 47 48 !! NEMO/TOP 4.0 , NEMO Consortium (2018) -
NEMO/branches/2020/dev_r12527_Gurvan_ShallowWater/src/TOP/PISCES/P4Z/p4zpoc.F90
r12377 r13151 39 39 !! * Substitutions 40 40 # include "do_loop_substitute.h90" 41 # include "domzgr_substitute.h90" 41 42 !!---------------------------------------------------------------------- 42 43 !! NEMO/TOP 4.0 , NEMO Consortium (2018) -
NEMO/branches/2020/dev_r12527_Gurvan_ShallowWater/src/TOP/PISCES/P4Z/p4zprod.F90
r12377 r13151 48 48 !! * Substitutions 49 49 # include "do_loop_substitute.h90" 50 # include "domzgr_substitute.h90" 50 51 !!---------------------------------------------------------------------- 51 52 !! NEMO/TOP 4.0 , NEMO Consortium (2018) -
NEMO/branches/2020/dev_r12527_Gurvan_ShallowWater/src/TOP/PISCES/P4Z/p4zrem.F90
r12377 r13151 44 44 !! * Substitutions 45 45 # include "do_loop_substitute.h90" 46 # include "domzgr_substitute.h90" 46 47 !!---------------------------------------------------------------------- 47 48 !! NEMO/TOP 4.0 , NEMO Consortium (2018) -
NEMO/branches/2020/dev_r12527_Gurvan_ShallowWater/src/TOP/PISCES/P4Z/p4zsed.F90
r12377 r13151 39 39 !! * Substitutions 40 40 # include "do_loop_substitute.h90" 41 # include "domzgr_substitute.h90" 41 42 !!---------------------------------------------------------------------- 42 43 !! NEMO/TOP 4.0 , NEMO Consortium (2018) -
NEMO/branches/2020/dev_r12527_Gurvan_ShallowWater/src/TOP/PISCES/P4Z/p4zsink.F90
r12377 r13151 40 40 !! * Substitutions 41 41 # include "do_loop_substitute.h90" 42 # include "domzgr_substitute.h90" 42 43 !!---------------------------------------------------------------------- 43 44 !! NEMO/TOP 4.0 , NEMO Consortium (2018) -
NEMO/branches/2020/dev_r12527_Gurvan_ShallowWater/src/TOP/PISCES/P4Z/p4zsms.F90
r12489 r13151 41 41 !! * Substitutions 42 42 # include "do_loop_substitute.h90" 43 # include "domzgr_substitute.h90" 43 44 !!---------------------------------------------------------------------- 44 45 !! NEMO/TOP 4.0 , NEMO Consortium (2018) -
NEMO/branches/2020/dev_r12527_Gurvan_ShallowWater/src/TOP/PISCES/P4Z/p5zprod.F90
r12377 r13151 52 52 !! * Substitutions 53 53 # include "do_loop_substitute.h90" 54 # include "domzgr_substitute.h90" 54 55 !!---------------------------------------------------------------------- 55 56 !! NEMO/TOP 4.0 , NEMO Consortium (2018) -
NEMO/branches/2020/dev_r12527_Gurvan_ShallowWater/src/TOP/PISCES/SED/oce_sed.F90
r12489 r13151 13 13 USE dom_oce , ONLY : glamt => glamt !: longitude of t-point (degre) 14 14 USE dom_oce , ONLY : gphit => gphit !: latitude of t-point (degre) 15 !!st 16 #if ! defined key_qco 15 17 USE dom_oce , ONLY : e3t => e3t !: latitude of t-point (degre) 18 #endif 16 19 USE dom_oce , ONLY : e3t_1d => e3t_1d !: reference depth of t-points (m) 17 20 USE dom_oce , ONLY : gdepw_0 => gdepw_0 !: reference depth of t-points (m) … … 53 56 54 57 END MODULE oce_sed 55 56 -
NEMO/branches/2020/dev_r12527_Gurvan_ShallowWater/src/TOP/PISCES/SED/seddta.F90
r12489 r13151 24 24 !! * Substitutions 25 25 # include "do_loop_substitute.h90" 26 # include "domzgr_substitute.h90" 26 27 !! $Id$ 27 28 CONTAINS … … 164 165 CALL pack_arr ( jpoce, rainrm_dta(1:jpoce,jscal), trc_data(1:jpi,1:jpj,14), iarroce(1:jpoce) ) 165 166 rainrm_dta(1:jpoce,jscal) = rainrm_dta(1:jpoce,jscal) * 1e-4 166 ! vector temperature [ °C] and salinity167 ! vector temperature [�C] and salinity 167 168 CALL pack_arr ( jpoce, temp(1:jpoce), trc_data(1:jpi,1:jpj,15), iarroce(1:jpoce) ) 168 169 CALL pack_arr ( jpoce, salt(1:jpoce), trc_data(1:jpi,1:jpj,16), iarroce(1:jpoce) ) -
NEMO/branches/2020/dev_r12527_Gurvan_ShallowWater/src/TOP/PISCES/SED/sedrst.F90
r12489 r13151 80 80 IF(lwp) WRITE(numsed,*) & 81 81 ' open sed restart.output NetCDF file: ',TRIM(clpath)//clname 82 CALL iom_open( TRIM(clpath)//TRIM(clname), numrsw, ldwrt = .TRUE., kdlev = jpksed )82 CALL iom_open( TRIM(clpath)//TRIM(clname), numrsw, ldwrt = .TRUE., kdlev = jpksed, cdcomp = 'SED' ) 83 83 lrst_sed = .TRUE. 84 84 ENDIF -
NEMO/branches/2020/dev_r12527_Gurvan_ShallowWater/src/TOP/PISCES/trcwri_pisces.F90
r12377 r13151 21 21 !! * Substitutions 22 22 # include "do_loop_substitute.h90" 23 # include "domzgr_substitute.h90" 23 24 !!---------------------------------------------------------------------- 24 25 !! NEMO/TOP 4.0 , NEMO Consortium (2018) -
NEMO/branches/2020/dev_r12527_Gurvan_ShallowWater/src/TOP/TRP/trcadv.F90
r12489 r13151 58 58 INTEGER, PARAMETER :: np_UBS = 4 ! 3rd order Upstream Biased Scheme 59 59 INTEGER, PARAMETER :: np_QCK = 5 ! QUICK scheme 60 60 61 # include "domzgr_substitute.h90" 61 62 !!---------------------------------------------------------------------- 62 63 !! NEMO/TOP 4.0 , NEMO Consortium (2018) -
NEMO/branches/2020/dev_r12527_Gurvan_ShallowWater/src/TOP/TRP/trcatf.F90
r12489 r13151 31 31 USE trd_oce 32 32 USE trdtra 33 # if defined key_qco 34 USE traatfqco 35 # else 33 36 USE traatf 37 # endif 34 38 USE bdy_oce , ONLY: ln_bdy 35 39 USE trcbdy ! BDY open boundaries … … 50 54 !! * Substitutions 51 55 # include "do_loop_substitute.h90" 56 # include "domzgr_substitute.h90" 52 57 !!---------------------------------------------------------------------- 53 58 !! NEMO/TOP 4.0 , NEMO Consortium (2018) … … 107 112 DO jn = 1, jptra 108 113 CALL trd_tra( kt, Kmm, Kaa, 'TRC', jn, jptra_zdfp, ztrdt(:,:,:,jn) ) 109 END DO114 END DO 110 115 ENDIF 111 116 112 117 ! total trend for the non-time-filtered variables. 113 118 zfact = 1.0 / rn_Dt 114 ! G Nurser 23 Mar 2017. Recalculate trend as Delta(e3t *T)/e3tn; e3tn cancel from ts(Kmm) terms119 ! G Nurser 23 Mar 2017. Recalculate trend as Delta(e3ta*Ta)/e3tn; e3tn cancel from ts(Kmm) terms 115 120 IF( ln_linssh ) THEN ! linear sea surface height only 116 121 DO jn = 1, jptra … … 129 134 DO jn = 1, jptra 130 135 CALL trd_tra( kt, Kmm, Kaa, 'TRC', jn, jptra_tot, ztrdt(:,:,:,jn) ) 131 END DO136 END DO 132 137 ! 133 138 IF( ln_linssh ) THEN ! linear sea surface height only … … 146 151 DO jn = 1, jptra 147 152 CALL trd_tra( kt, Kmm, Kaa, 'TRC', jn, jptra_atf, ztrdt(:,:,:,jn) ) 148 END DO153 END DO 149 154 END IF 150 155 ! 151 156 ELSE 152 157 IF( .NOT. l_offline ) THEN ! Leap-Frog + Asselin filter time stepping 158 <<<<<<< .working 153 159 IF( ln_linssh ) THEN ; CALL tra_atf_fix( kt, Kbb, Kmm, Kaa, nittrc000, 'TRC', ptr, jptra ) ! linear ssh 154 160 ELSE ; CALL tra_atf_vvl( kt, Kbb, Kmm, Kaa, nittrc000, rn_Dt, 'TRC', ptr, sbc_trc, sbc_trc_b, jptra ) ! non-linear ssh 161 ======= 162 # if defined key_qco 163 IF( ln_linssh ) THEN ; CALL tra_atf_fix_lf( kt, Kbb, Kmm, Kaa, nittrc000, 'TRC', ptr, jptra ) ! linear ssh 164 ELSE ; CALL tra_atf_qco_lf( kt, Kbb, Kmm, Kaa, nittrc000, rn_Dt, 'TRC', ptr, sbc_trc, sbc_trc_b, jptra ) ! non-linear ssh 165 # else 166 IF( ln_linssh ) THEN ; CALL tra_atf_fix ( kt, Kbb, Kmm, Kaa, nittrc000, 'TRC', ptr, jptra ) ! linear ssh 167 ELSE ; CALL tra_atf_vvl ( kt, Kbb, Kmm, Kaa, nittrc000, rn_Dt, 'TRC', ptr, sbc_trc, sbc_trc_b, jptra ) ! non-linear ssh 168 # endif 169 >>>>>>> .merge-right.r13092 155 170 ENDIF 156 171 ELSE 157 CALL trc_atf_off ( kt, Kbb, Kmm, Kaa, ptr ) ! offline172 CALL trc_atf_off ( kt, Kbb, Kmm, Kaa, ptr ) ! offline 158 173 ENDIF 159 174 ! … … 182 197 END SUBROUTINE trc_atf 183 198 184 199 # if ! defined key_qco 185 200 SUBROUTINE trc_atf_off( kt, Kbb, Kmm, Kaa, ptr ) 186 201 !!---------------------------------------------------------------------- … … 198 213 !! This can be summurized for tempearture as: 199 214 !! ztm = ( e3t_n*tn + rbcp*[ e3t_b*tb - 2 e3t_n*tn + e3t_a*ta ] ) ln_dynhpg_imp = T 200 !! /( e3t(:,:, :,Kmm) + rbcp*[ e3t(:,:,:,Kbb) - 2 e3t(:,:,:,Kmm) + e3t(:,:,:,Kaa) ] )215 !! /( e3t(:,:,jk,Kmm) + rbcp*[ e3t(:,:,jk,Kbb) - 2 e3t(:,:,jk,Kmm) + e3t(:,:,jk,Kaa) ] ) 201 216 !! ztm = 0 otherwise 217 <<<<<<< .working 202 218 !! tb = ( e3t_n*tn + rn_atfp*[ e3t_b*tb - 2 e3t_n*tn + e3t_a*ta ] ) 203 219 !! /( e3t(:,:,:,Kmm) + rn_atfp*[ e3t(:,:,:,Kbb) - 2 e3t(:,:,:,Kmm) + e3t(:,:,:,Kaa) ] ) 220 ======= 221 !! tb = ( e3t_n*tn + rn_atfp*[ e3t_b*tb - 2 e3t_n*tn + e3t_a*ta ] ) 222 !! /( e3t(:,:,jk,Kmm) + rn_atfp*[ e3t(:,:,jk,Kbb) - 2 e3t(:,:,jk,Kmm) + e3t(:,:,jk,Kaa) ] ) 223 >>>>>>> .merge-right.r13092 204 224 !! tn = ta 205 225 !! ta = zt (NB: reset to 0 after eos_bn2 call) … … 257 277 ! 258 278 END SUBROUTINE trc_atf_off 259 279 # else 280 SUBROUTINE trc_atf_off( kt, Kbb, Kmm, Kaa, ptr ) 281 !!---------------------------------------------------------------------- 282 !! *** ROUTINE tra_atf_off *** 283 !! 284 !! !!!!!!!!!!!!!!!!! REWRITE HEADER COMMENTS !!!!!!!!!!!!!! 285 !! 286 !! ** Purpose : Time varying volume: apply the Asselin time filter 287 !! 288 !! ** Method : - Apply a thickness weighted Asselin time filter on now fields. 289 !! - save in (ta,sa) a thickness weighted average over the three 290 !! time levels which will be used to compute rdn and thus the semi- 291 !! implicit hydrostatic pressure gradient (ln_dynhpg_imp = T) 292 !! - swap tracer fields to prepare the next time_step. 293 !! This can be summurized for tempearture as: 294 !! ztm = ( e3t_n*tn + rbcp*[ e3t_b*tb - 2 e3t_n*tn + e3t_a*ta ] ) ln_dynhpg_imp = T 295 !! /( e3t(:,:,jk,Kmm) + rbcp*[ e3t(:,:,jk,Kbb) - 2 e3t(:,:,jk,Kmm) + e3t(:,:,jk,Kaa) ] ) 296 !! ztm = 0 otherwise 297 !! tb = ( e3t_n*tn + rn_atfp*[ e3t_b*tb - 2 e3t_n*tn + e3t_a*ta ] ) 298 !! /( e3t(:,:,jk,Kmm) + rn_atfp*[ e3t(:,:,jk,Kbb) - 2 e3t(:,:,jk,Kmm) + e3t(:,:,jk,Kaa) ] ) 299 !! tn = ta 300 !! ta = zt (NB: reset to 0 after eos_bn2 call) 301 !! 302 !! ** Action : - (tb,sb) and (tn,sn) ready for the next time step 303 !! - (ta,sa) time averaged (t,s) (ln_dynhpg_imp = T) 304 !!---------------------------------------------------------------------- 305 INTEGER , INTENT(in ) :: kt ! ocean time-step index 306 INTEGER , INTENT(in ) :: Kbb, Kmm, Kaa ! time level indices 307 REAL(wp), DIMENSION(jpi,jpj,jpk,jptra,jpt), INTENT(inout) :: ptr ! passive tracers 308 !! 309 INTEGER :: ji, jj, jk, jn ! dummy loop indices 310 REAL(wp) :: ztc_a , ztc_n , ztc_b , ztc_f , ztc_d ! local scalar 311 REAL(wp) :: ze3t_b, ze3t_n, ze3t_a, ze3t_f ! - - 312 !!---------------------------------------------------------------------- 313 ! 314 IF( kt == nittrc000 ) THEN 315 IF(lwp) WRITE(numout,*) 316 IF(lwp) WRITE(numout,*) 'trc_atf_off : Asselin time filtering' 317 IF(lwp) WRITE(numout,*) '~~~~~~~~~~~' 318 IF( .NOT. ln_linssh ) THEN 319 rfact1 = rn_atfp * rn_Dt 320 rfact2 = rfact1 / rho0 321 ENDIF 322 ! 323 ENDIF 324 ! 325 DO jn = 1, jptra 326 DO_3D_11_11( 1, jpkm1 ) 327 ze3t_b = 1._wp + r3t(ji,jj,Kbb) * tmask(ji,jj,jk) 328 ze3t_n = 1._wp + r3t(ji,jj,Kmm) * tmask(ji,jj,jk) 329 ze3t_a = 1._wp + r3t(ji,jj,Kaa) * tmask(ji,jj,jk) 330 ! ! tracer content at Before, now and after 331 ztc_b = ptr(ji,jj,jk,jn,Kbb) * ze3t_b 332 ztc_n = ptr(ji,jj,jk,jn,Kmm) * ze3t_n 333 ztc_a = ptr(ji,jj,jk,jn,Kaa) * ze3t_a 334 ! 335 ztc_d = ztc_a - 2. * ztc_n + ztc_b 336 ! 337 ze3t_f = 1._wp + r3t_f(ji,jj)*tmask(ji,jj,jk) 338 ztc_f = ztc_n + rn_atfp * ztc_d 339 ! 340 IF( .NOT. ln_linssh .AND. jk == mikt(ji,jj) ) THEN ! first level 341 ztc_f = ztc_f - rfact1 * ( sbc_trc(ji,jj,jn) - sbc_trc_b(ji,jj,jn) ) 342 ENDIF 343 344 ze3t_f = 1.e0 / ze3t_f 345 ptr(ji,jj,jk,jn,Kmm) = ztc_f * ze3t_f ! time filtered "now" field 346 ! 347 END_3D 348 ! 349 END DO 350 ! 351 END SUBROUTINE trc_atf_off 352 # endif 353 260 354 #else 261 355 !!---------------------------------------------------------------------- -
NEMO/branches/2020/dev_r12527_Gurvan_ShallowWater/src/TOP/TRP/trcdmp.F90
r12377 r13151 45 45 !! * Substitutions 46 46 # include "do_loop_substitute.h90" 47 # include "domzgr_substitute.h90" 47 48 !!---------------------------------------------------------------------- 48 49 !! NEMO/TOP 4.0 , NEMO Consortium (2018) -
NEMO/branches/2020/dev_r12527_Gurvan_ShallowWater/src/TOP/TRP/trcldf.F90
r12377 r13151 44 44 !! * Substitutions 45 45 # include "do_loop_substitute.h90" 46 # include "domzgr_substitute.h90" 46 47 !!---------------------------------------------------------------------- 47 48 !! NEMO/TOP 4.0 , NEMO Consortium (2018) -
NEMO/branches/2020/dev_r12527_Gurvan_ShallowWater/src/TOP/TRP/trcsbc.F90
r12489 r13151 30 30 !! * Substitutions 31 31 # include "do_loop_substitute.h90" 32 # include "domzgr_substitute.h90" 32 33 !!---------------------------------------------------------------------- 33 34 !! NEMO/TOP 4.0 , NEMO Consortium (2018) … … 49 50 !! The surface freshwater flux modify the ocean volume 50 51 !! and thus the concentration of a tracer as : 51 !! tr(Krhs) = tr(Krhs) + emp * tr(Kmm) / e3t for k=152 !! tr(Krhs) = tr(Krhs) + emp * tr(Kmm) / e3t_ for k=1 52 53 !! where emp, the surface freshwater budget (evaporation minus 53 54 !! precipitation ) given in kg/m2/s is divided -
NEMO/branches/2020/dev_r12527_Gurvan_ShallowWater/src/TOP/TRP/trcsink.F90
r12377 r13151 26 26 !! * Substitutions 27 27 # include "do_loop_substitute.h90" 28 # include "domzgr_substitute.h90" 28 29 !!---------------------------------------------------------------------- 29 30 !! NEMO/TOP 4.0 , NEMO Consortium (2018) -
NEMO/branches/2020/dev_r12527_Gurvan_ShallowWater/src/TOP/TRP/trdmxl_trc.F90
r12489 r13151 51 51 !! * Substitutions 52 52 # include "do_loop_substitute.h90" 53 # include "domzgr_substitute.h90" 53 54 !!---------------------------------------------------------------------- 54 55 !! NEMO/TOP 4.0 , NEMO Consortium (2018) -
NEMO/branches/2020/dev_r12527_Gurvan_ShallowWater/src/TOP/trcbc.F90
r12489 r13151 48 48 !! * Substitutions 49 49 # include "do_loop_substitute.h90" 50 # include "domzgr_substitute.h90" 50 51 !!---------------------------------------------------------------------- 51 52 !! NEMO/TOP 4.0 , NEMO Consortium (2018) -
NEMO/branches/2020/dev_r12527_Gurvan_ShallowWater/src/TOP/trcdta.F90
r12377 r13151 41 41 !! Substitutions 42 42 #include "do_loop_substitute.h90" 43 #include "domzgr_substitute.h90" 43 44 !!---------------------------------------------------------------------- 44 45 !! NEMO/TOP 4.0 , NEMO Consortium (2018) … … 206 207 ztp(jk) = ptrcdta(ji,jj,jpkm1) 207 208 ELSE ! inbetween : vertical interpolation between jkk & jkk+1 208 DO jkk = 1, jpkm1 ! when gdept (jkk) < zl < gdept(jkk+1)209 DO jkk = 1, jpkm1 ! when gdept_1d(jkk) < zl < gdept_1d(jkk+1) 209 210 IF( (zl-gdept_1d(jkk)) * (zl-gdept_1d(jkk+1)) <= 0._wp ) THEN 210 211 zi = ( zl - gdept_1d(jkk) ) / (gdept_1d(jkk+1)-gdept_1d(jkk)) -
NEMO/branches/2020/dev_r12527_Gurvan_ShallowWater/src/TOP/trcini.F90
r12377 r13151 30 30 31 31 PUBLIC trc_init ! called by opa 32 32 33 # include "domzgr_substitute.h90" 33 34 !!---------------------------------------------------------------------- 34 35 !! NEMO/TOP 4.0 , NEMO Consortium (2018) -
NEMO/branches/2020/dev_r12527_Gurvan_ShallowWater/src/TOP/trcrst.F90
r12489 r13151 33 33 PUBLIC trc_rst_cal 34 34 35 # include "domzgr_substitute.h90" 35 36 !!---------------------------------------------------------------------- 36 37 !! NEMO/TOP 4.0 , NEMO Consortium (2018) -
NEMO/branches/2020/dev_r12527_Gurvan_ShallowWater/src/TOP/trcstp.F90
r12489 r13151 36 36 REAL(wp) :: rsecfst, rseclast ! ??? 37 37 REAL(wp), DIMENSION(:,:,:), SAVE, ALLOCATABLE :: qsr_arr ! save qsr during TOP time-step 38 38 39 # include "domzgr_substitute.h90" 39 40 !!---------------------------------------------------------------------- 40 41 !! NEMO/TOP 4.0 , NEMO Consortium (2018) … … 142 143 ! 143 144 ! Define logical parameter ton control dirunal cycle in TOP 144 l_trcdm2dc = ln_dm2dc .OR. ( ln_cpl .AND. ncpl_qsr_freq /= 1 ) 145 l_trcdm2dc = l_trcdm2dc .AND. .NOT. l_offline 145 l_trcdm2dc = ln_dm2dc .OR. ( ln_cpl .AND. ncpl_qsr_freq /= 1 .AND. ncpl_qsr_freq /= 0 ) 146 l_trcdm2dc = l_trcdm2dc .AND. .NOT. l_offline 147 ! 146 148 IF( l_trcdm2dc .AND. lwp ) CALL ctl_warn( 'Coupling with passive tracers and used of diurnal cycle.', & 147 149 & 'Computation of a daily mean shortwave for some biogeochemical models ' ) -
NEMO/branches/2020/dev_r12527_Gurvan_ShallowWater/src/TOP/trcwri.F90
r12377 r13151 60 60 CALL iom_put( "e3v_0", e3v_0(:,:,:) ) 61 61 ! 62 #if ! defined key_qco 62 63 CALL iom_put( "e3t" , e3t(:,:,:,Kmm) ) 63 64 CALL iom_put( "e3u" , e3u(:,:,:,Kmm) ) 64 65 CALL iom_put( "e3v" , e3v(:,:,:,Kmm) ) 66 #endif 65 67 ! 66 68 ENDIF
Note: See TracChangeset
for help on using the changeset viewer.