Changeset 14789 for NEMO/branches/2021/dev_r13747_HPC-11_mcastril_HPDAonline_DiagGPU/src/OCE/DOM/domvvl.F90
- Timestamp:
- 2021-05-05T13:18:04+02:00 (3 years ago)
- Location:
- NEMO/branches/2021/dev_r13747_HPC-11_mcastril_HPDAonline_DiagGPU
- Files:
-
- 2 edited
-
. (modified) (1 prop)
-
src/OCE/DOM/domvvl.F90 (modified) (28 diffs)
Legend:
- Unmodified
- Added
- Removed
-
NEMO/branches/2021/dev_r13747_HPC-11_mcastril_HPDAonline_DiagGPU
- Property svn:externals
-
old new 3 3 ^/utils/build/mk@HEAD mk 4 4 ^/utils/tools@HEAD tools 5 ^/vendors/AGRIF/dev _r12970_AGRIF_CMEMSext/AGRIF5 ^/vendors/AGRIF/dev@HEAD ext/AGRIF 6 6 ^/vendors/FCM@HEAD ext/FCM 7 7 ^/vendors/IOIPSL@HEAD ext/IOIPSL 8 ^/vendors/PPR@HEAD ext/PPR 8 9 9 10 # SETTE 10 ^/utils/CI/sette@1 3559sette11 ^/utils/CI/sette@14244 sette
-
- Property svn:externals
-
NEMO/branches/2021/dev_r13747_HPC-11_mcastril_HPDAonline_DiagGPU/src/OCE/DOM/domvvl.F90
r13497 r14789 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 ratio11 !! - ! 2020-02 (G. Madec, S. Techene) introduce ssh to h0 ratio 12 12 !!---------------------------------------------------------------------- 13 13 … … 50 50 REAL(wp) , ALLOCATABLE, SAVE, DIMENSION(:,:) :: frq_rst_hdv ! retoring period for low freq. divergence 51 51 52 #if defined key_qco 52 #if defined key_qco || defined key_linssh 53 53 !!---------------------------------------------------------------------- 54 !! 'key_qco' EMPTY MODULE Quasi-Eulerian vertical coordonate 54 !! 'key_qco' Quasi-Eulerian vertical coordinate 55 !! OR EMPTY MODULE 56 !! 'key_linssh' Fix in time vertical coordinate 55 57 !!---------------------------------------------------------------------- 56 58 #else … … 58 60 !! Default key Old management of time varying vertical coordinate 59 61 !!---------------------------------------------------------------------- 60 62 61 63 !!---------------------------------------------------------------------- 62 64 !! dom_vvl_init : define initial vertical scale factors, depths and column thickness … … 73 75 PUBLIC dom_vvl_sf_update ! called by step.F90 74 76 PUBLIC dom_vvl_interpol ! called by dynnxt.F90 75 77 76 78 !! * Substitutions 77 79 # include "do_loop_substitute.h90" … … 109 111 !!---------------------------------------------------------------------- 110 112 !! *** ROUTINE dom_vvl_init *** 111 !! 113 !! 112 114 !! ** Purpose : Initialization of all scale factors, depths 113 115 !! and water column heights … … 118 120 !! ** Action : - e3t_(n/b) and tilde_e3t_(n/b) 119 121 !! - Regrid: e3[u/v](:,:,:,Kmm) 120 !! e3[u/v](:,:,:,Kmm) 121 !! e3w(:,:,:,Kmm) 122 !! e3[u/v](:,:,:,Kmm) 123 !! e3w(:,:,:,Kmm) 122 124 !! e3[u/v]w_b 123 !! e3[u/v]w_n 125 !! e3[u/v]w_n 124 126 !! gdept(:,:,:,Kmm), gdepw(:,:,:,Kmm) and gde3w 125 127 !! - h(t/u/v)_0 … … 151 153 !!---------------------------------------------------------------------- 152 154 !! *** ROUTINE dom_vvl_init *** 153 !! 154 !! ** Purpose : Interpolation of all scale factors, 155 !! 156 !! ** Purpose : Interpolation of all scale factors, 155 157 !! depths and water column heights 156 158 !! … … 159 161 !! ** Action : - e3t_(n/b) and tilde_e3t_(n/b) 160 162 !! - Regrid: e3(u/v)_n 161 !! e3(u/v)_b 162 !! e3w_n 163 !! e3(u/v)w_b 164 !! e3(u/v)w_n 163 !! e3(u/v)_b 164 !! e3w_n 165 !! e3(u/v)w_b 166 !! e3(u/v)w_n 165 167 !! gdept_n, gdepw_n and gde3w_n 166 168 !! - h(t/u/v)_0 … … 180 182 CALL dom_vvl_interpol( e3t(:,:,:,Kbb), e3u(:,:,:,Kbb), 'U' ) ! from T to U 181 183 CALL dom_vvl_interpol( e3t(:,:,:,Kmm), e3u(:,:,:,Kmm), 'U' ) 182 CALL dom_vvl_interpol( e3t(:,:,:,Kbb), e3v(:,:,:,Kbb), 'V' ) ! from T to V 184 CALL dom_vvl_interpol( e3t(:,:,:,Kbb), e3v(:,:,:,Kbb), 'V' ) ! from T to V 183 185 CALL dom_vvl_interpol( e3t(:,:,:,Kmm), e3v(:,:,:,Kmm), 'V' ) 184 186 CALL dom_vvl_interpol( e3u(:,:,:,Kmm), e3f(:,:,:), 'F' ) ! from U to F 185 ! ! Vertical interpolation of e3t,u,v 187 ! ! Vertical interpolation of e3t,u,v 186 188 CALL dom_vvl_interpol( e3t(:,:,:,Kmm), e3w (:,:,:,Kmm), 'W' ) ! from T to W 187 189 CALL dom_vvl_interpol( e3t(:,:,:,Kbb), e3w (:,:,:,Kbb), 'W' ) … … 205 207 ! zcoef = tmask - wmask ! 0 everywhere tmask = wmask, ie everywhere expect at jk = mikt 206 208 ! ! 1 everywhere from mbkt to mikt + 1 or 1 (if no isf) 207 ! ! 0.5 where jk = mikt 209 ! ! 0.5 where jk = mikt 208 210 !!gm ??????? BUG ? gdept(:,:,:,Kmm) as well as gde3w does not include the thickness of ISF ?? 209 211 zcoef = ( tmask(ji,jj,jk) - wmask(ji,jj,jk) ) 210 212 gdepw(ji,jj,jk,Kmm) = gdepw(ji,jj,jk-1,Kmm) + e3t(ji,jj,jk-1,Kmm) 211 213 gdept(ji,jj,jk,Kmm) = zcoef * ( gdepw(ji,jj,jk ,Kmm) + 0.5 * e3w(ji,jj,jk,Kmm)) & 212 & + (1-zcoef) * ( gdept(ji,jj,jk-1,Kmm) + e3w(ji,jj,jk,Kmm)) 214 & + (1-zcoef) * ( gdept(ji,jj,jk-1,Kmm) + e3w(ji,jj,jk,Kmm)) 213 215 gde3w(ji,jj,jk) = gdept(ji,jj,jk,Kmm) - ssh(ji,jj,Kmm) 214 216 gdepw(ji,jj,jk,Kbb) = gdepw(ji,jj,jk-1,Kbb) + e3t(ji,jj,jk-1,Kbb) 215 217 gdept(ji,jj,jk,Kbb) = zcoef * ( gdepw(ji,jj,jk ,Kbb) + 0.5 * e3w(ji,jj,jk,Kbb)) & 216 & + (1-zcoef) * ( gdept(ji,jj,jk-1,Kbb) + e3w(ji,jj,jk,Kbb)) 218 & + (1-zcoef) * ( gdept(ji,jj,jk-1,Kbb) + e3w(ji,jj,jk,Kbb)) 217 219 END_3D 218 220 ! … … 273 275 IF( cn_cfg == "orca" .OR. cn_cfg == "ORCA" ) THEN 274 276 IF( nn_cfg == 3 ) THEN ! ORCA2: Suppress ztilde in the Foxe Basin for ORCA2 275 ii0 = 103 + nn_hls - 1 ; ii1 = 111 + nn_hls - 1 277 ii0 = 103 + nn_hls - 1 ; ii1 = 111 + nn_hls - 1 276 278 ij0 = 128 + nn_hls ; ij1 = 135 + nn_hls 277 279 frq_rst_e3t( mi0(ii0):mi1(ii1) , mj0(ij0):mj1(ij1) ) = 0.0_wp … … 282 284 ENDIF 283 285 ! 284 IF(lwxios) THEN285 ! define variables in restart file when writing with XIOS286 CALL iom_set_rstw_var_active('e3t_b')287 CALL iom_set_rstw_var_active('e3t_n')288 ! ! ----------------------- !289 IF( ln_vvl_ztilde .OR. ln_vvl_layer ) THEN ! z_tilde and layer cases !290 ! ! ----------------------- !291 CALL iom_set_rstw_var_active('tilde_e3t_b')292 CALL iom_set_rstw_var_active('tilde_e3t_n')293 END IF294 ! ! -------------!295 IF( ln_vvl_ztilde ) THEN ! z_tilde case !296 ! ! ------------ !297 CALL iom_set_rstw_var_active('hdiv_lf')298 ENDIF299 !300 ENDIF301 !302 286 END SUBROUTINE dom_vvl_zgr 303 287 304 288 305 SUBROUTINE dom_vvl_sf_nxt( kt, Kbb, Kmm, Kaa, kcall ) 289 SUBROUTINE dom_vvl_sf_nxt( kt, Kbb, Kmm, Kaa, kcall ) 306 290 !!---------------------------------------------------------------------- 307 291 !! *** ROUTINE dom_vvl_sf_nxt *** 308 !! 292 !! 309 293 !! ** Purpose : - compute the after scale factors used in tra_zdf, dynnxt, 310 294 !! tranxt and dynspg routines 311 295 !! 312 296 !! ** Method : - z_star case: Repartition of ssh INCREMENT proportionnaly to the level thickness. 313 !! - z_tilde_case: after scale factor increment = 297 !! - z_tilde_case: after scale factor increment = 314 298 !! high frequency part of horizontal divergence 315 299 !! + retsoring towards the background grid … … 319 303 !! 320 304 !! ** Action : - hdiv_lf : restoring towards full baroclinic divergence in z_tilde case 321 !! - tilde_e3t_a: after increment of vertical scale factor 305 !! - tilde_e3t_a: after increment of vertical scale factor 322 306 !! in z_tilde case 323 307 !! - e3(t/u/v)_a … … 423 407 un_td(ji,jj,jk) = rn_ahe3 * umask(ji,jj,jk) * e2_e1u(ji,jj) & 424 408 & * ( tilde_e3t_b(ji,jj,jk) - tilde_e3t_b(ji+1,jj ,jk) ) 425 vn_td(ji,jj,jk) = rn_ahe3 * vmask(ji,jj,jk) * e1_e2v(ji,jj) & 409 vn_td(ji,jj,jk) = rn_ahe3 * vmask(ji,jj,jk) * e1_e2v(ji,jj) & 426 410 & * ( tilde_e3t_b(ji,jj,jk) - tilde_e3t_b(ji ,jj+1,jk) ) 427 411 zwu(ji,jj) = zwu(ji,jj) + un_td(ji,jj,jk) … … 439 423 ! ! d - thickness diffusion transport: boundary conditions 440 424 ! (stored for tracer advction and continuity equation) 441 CALL lbc_lnk_multi( 'domvvl', un_td , 'U' , -1._wp, vn_td , 'V' , -1._wp) 442 425 CALL lbc_lnk( 'domvvl', un_td , 'U' , -1._wp, vn_td , 'V' , -1._wp) 443 426 ! 4 - Time stepping of baroclinic scale factors 444 427 ! --------------------------------------------- … … 453 436 END_3D 454 437 ! 455 llmsk( 1:Nis1,:,:) = .FALSE. ! exclude halos from the checked region456 llmsk(Nie 1:jpi,:,:) = .FALSE.457 llmsk(:, 1:Njs1,:) = .FALSE.458 llmsk(:,Nje 1:jpj,:) = .FALSE.438 llmsk( 1:nn_hls,:,:) = .FALSE. ! exclude halos from the checked region 439 llmsk(Nie0+1: jpi,:,:) = .FALSE. 440 llmsk(:, 1:nn_hls,:) = .FALSE. 441 llmsk(:,Nje0+1: jpj,:) = .FALSE. 459 442 ! 460 443 llmsk(Nis0:Nie0,Njs0:Nje0,:) = tmask(Nis0:Nie0,Njs0:Nje0,:) == 1._wp ! define only the inner domain … … 469 452 WRITE(numout, *) 'at i, j, k=', ijk_max 470 453 WRITE(numout, *) 'MIN( tilde_e3t_a(:,:,:) / e3t_0(:,:,:) ) =', z_tmin 471 WRITE(numout, *) 'at i, j, k=', ijk_min 454 WRITE(numout, *) 'at i, j, k=', ijk_min 472 455 CALL ctl_stop( 'STOP', 'MAX( ABS( tilde_e3t_a(:,:,: ) ) / e3t_0(:,:,:) ) too high') 473 456 ENDIF … … 585 568 !!---------------------------------------------------------------------- 586 569 !! *** ROUTINE dom_vvl_sf_update *** 587 !! 588 !! ** Purpose : for z tilde case: compute time filter and swap of scale factors 570 !! 571 !! ** Purpose : for z tilde case: compute time filter and swap of scale factors 589 572 !! compute all depths and related variables for next time step 590 573 !! write outputs and restart file … … 596 579 !! ** Action : - tilde_e3t_(b/n) ready for next time step 597 580 !! - Recompute: 598 !! e3(u/v)_b 599 !! e3w(:,:,:,Kmm) 600 !! e3(u/v)w_b 601 !! e3(u/v)w_n 581 !! e3(u/v)_b 582 !! e3w(:,:,:,Kmm) 583 !! e3(u/v)w_b 584 !! e3(u/v)w_n 602 585 !! gdept(:,:,:,Kmm), gdepw(:,:,:,Kmm) and gde3w 603 586 !! h(u/v) and h(u/v)r … … 630 613 tilde_e3t_b(:,:,:) = tilde_e3t_n(:,:,:) 631 614 ELSE 632 tilde_e3t_b(:,:,:) = tilde_e3t_n(:,:,:) & 615 tilde_e3t_b(:,:,:) = tilde_e3t_n(:,:,:) & 633 616 & + rn_atfp * ( tilde_e3t_b(:,:,:) - 2.0_wp * tilde_e3t_n(:,:,:) + tilde_e3t_a(:,:,:) ) 634 617 ENDIF … … 642 625 ! - ML - e3u(:,:,:,Kbb) and e3v(:,:,:,Kbb) are already computed in dynnxt 643 626 ! - JC - hu(:,:,:,Kbb), hv(:,:,:,:,Kbb), hur_b, hvr_b also 644 627 645 628 CALL dom_vvl_interpol( e3u(:,:,:,Kmm), e3f(:,:,:), 'F' ) 646 629 647 630 ! Vertical scale factor interpolations 648 631 CALL dom_vvl_interpol( e3t(:,:,:,Kmm), e3w(:,:,:,Kmm), 'W' ) … … 663 646 gdepw(ji,jj,jk,Kmm) = gdepw(ji,jj,jk-1,Kmm) + e3t(ji,jj,jk-1,Kmm) 664 647 gdept(ji,jj,jk,Kmm) = zcoef * ( gdepw(ji,jj,jk ,Kmm) + 0.5 * e3w(ji,jj,jk,Kmm) ) & 665 & + (1-zcoef) * ( gdept(ji,jj,jk-1,Kmm) + e3w(ji,jj,jk,Kmm) ) 648 & + (1-zcoef) * ( gdept(ji,jj,jk-1,Kmm) + e3w(ji,jj,jk,Kmm) ) 666 649 gde3w(ji,jj,jk) = gdept(ji,jj,jk,Kmm) - ssh(ji,jj,Kmm) 667 650 END_3D … … 782 765 !!--------------------------------------------------------------------- 783 766 !! *** ROUTINE dom_vvl_rst *** 784 !! 767 !! 785 768 !! ** Purpose : Read or write VVL file in restart file 786 769 !! 787 !! ** Method : use of IOM library 788 !! if the restart does not contain vertical scale factors, 789 !! they are set to the _0 values 790 !! if the restart does not contain vertical scale factors increments (z_tilde), 791 !! they are set to 0. 770 !! ** Method : * restart comes from a linear ssh simulation : 771 !! an attempt to read e3t_n stops simulation 772 !! * restart comes from a z-star, z-tilde, or layer : 773 !! read e3t_n and e3t_b 774 !! * restart comes from a z-star : 775 !! set tilde_e3t_n, tilde_e3t_n, and hdiv_lf to 0 776 !! * restart comes from layer : 777 !! read tilde_e3t_n and tilde_e3t_b 778 !! set hdiv_lf to 0 779 !! * restart comes from a z-tilde: 780 !! read tilde_e3t_n, tilde_e3t_b, and hdiv_lf 781 !! 782 !! NB: if l_1st_euler = T (ln_1st_euler or ssh_b not found) 783 !! Kbb fields set to Kmm ones 792 784 !!---------------------------------------------------------------------- 793 785 INTEGER , INTENT(in) :: kt ! ocean time-step … … 795 787 CHARACTER(len=*), INTENT(in) :: cdrw ! "READ"/"WRITE" flag 796 788 ! 797 INTEGER :: ji, jj, jk 798 INTEGER :: id 1, id2, id3, id4, id5! local integers799 !!---------------------------------------------------------------------- 800 ! 801 IF( TRIM(cdrw) == 'READ' ) THEN ! Read/initialise802 ! ! ===============803 IF( ln_rstart ) THEN !* Read the restart file804 CALL rst_read_open ! open the restart file if necessary805 CALL iom_get( numror, jpdom_auto, 'sshn' , ssh(:,:,Kmm), ldxios = lrxios )789 INTEGER :: ji, jj, jk ! dummy loop indices 790 INTEGER :: id3, id4, id5 ! local integers 791 !!---------------------------------------------------------------------- 792 ! 793 ! !=====================! 794 IF( TRIM(cdrw) == 'READ' ) THEN ! Read / initialise ! 795 ! !=====================! 796 ! 797 IF( ln_rstart ) THEN !== Read the restart file ==! 806 798 ! 807 id1 = iom_varid( numror, 'e3t_b', ldstop = .FALSE. ) 808 id2 = iom_varid( numror, 'e3t_n', ldstop = .FALSE. ) 809 id3 = iom_varid( numror, 'tilde_e3t_b', ldstop = .FALSE. ) 799 CALL rst_read_open !* open the restart file if necessary 800 ! ! --------- ! 801 ! ! all cases ! 802 ! ! --------- ! 803 ! 804 id3 = iom_varid( numror, 'tilde_e3t_b', ldstop = .FALSE. ) !* check presence 810 805 id4 = iom_varid( numror, 'tilde_e3t_n', ldstop = .FALSE. ) 811 id5 = iom_varid( numror, 'hdiv_lf' , ldstop = .FALSE. )806 id5 = iom_varid( numror, 'hdiv_lf' , ldstop = .FALSE. ) 812 807 ! 813 ! ! --------- ! 814 ! ! all cases ! 815 ! ! --------- ! 816 ! 817 IF( MIN( id1, id2 ) > 0 ) THEN ! all required arrays exist 818 CALL iom_get( numror, jpdom_auto, 'e3t_b', e3t(:,:,:,Kbb), ldxios = lrxios ) 819 CALL iom_get( numror, jpdom_auto, 'e3t_n', e3t(:,:,:,Kmm), ldxios = lrxios ) 820 ! needed to restart if land processor not computed 821 IF(lwp) write(numout,*) 'dom_vvl_rst : e3t(:,:,:,Kbb) and e3t(:,:,:,Kmm) found in restart files' 822 WHERE ( tmask(:,:,:) == 0.0_wp ) 823 e3t(:,:,:,Kmm) = e3t_0(:,:,:) 808 ! !* scale factors 809 IF(lwp) WRITE(numout,*) ' Kmm scale factor read in the restart file' 810 CALL iom_get( numror, jpdom_auto, 'e3t_n', e3t(:,:,:,Kmm) ) 811 WHERE ( tmask(:,:,:) == 0.0_wp ) 812 e3t(:,:,:,Kmm) = e3t_0(:,:,:) 813 END WHERE 814 IF( l_1st_euler ) THEN ! euler 815 IF(lwp) WRITE(numout,*) ' Euler first time step : e3t(Kbb) = e3t(Kmm)' 816 e3t(:,:,:,Kbb) = e3t(:,:,:,Kmm) 817 ELSE ! leap frog 818 IF(lwp) WRITE(numout,*) ' Kbb scale factor read in the restart file' 819 CALL iom_get( numror, jpdom_auto, 'e3t_b', e3t(:,:,:,Kbb) ) 820 WHERE ( tmask(:,:,:) == 0.0_wp ) 824 821 e3t(:,:,:,Kbb) = e3t_0(:,:,:) 825 822 END WHERE 826 IF( l_1st_euler ) THEN827 e3t(:,:,:,Kbb) = e3t(:,:,:,Kmm)828 ENDIF829 ELSE IF( id1 > 0 ) THEN830 IF(lwp) write(numout,*) 'dom_vvl_rst WARNING : e3t(:,:,:,Kmm) not found in restart files'831 IF(lwp) write(numout,*) 'e3t_n set equal to e3t_b.'832 IF(lwp) write(numout,*) 'l_1st_euler is forced to true'833 CALL iom_get( numror, jpdom_auto, 'e3t_b', e3t(:,:,:,Kbb), ldxios = lrxios )834 e3t(:,:,:,Kmm) = e3t(:,:,:,Kbb)835 l_1st_euler = .true.836 ELSE IF( id2 > 0 ) THEN837 IF(lwp) write(numout,*) 'dom_vvl_rst WARNING : e3t(:,:,:,Kbb) not found in restart files'838 IF(lwp) write(numout,*) 'e3t_b set equal to e3t_n.'839 IF(lwp) write(numout,*) 'l_1st_euler is forced to true'840 CALL iom_get( numror, jpdom_auto, 'e3t_n', e3t(:,:,:,Kmm), ldxios = lrxios )841 e3t(:,:,:,Kbb) = e3t(:,:,:,Kmm)842 l_1st_euler = .true.843 ELSE844 IF(lwp) write(numout,*) 'dom_vvl_rst WARNING : e3t(:,:,:,Kmm) not found in restart file'845 IF(lwp) write(numout,*) 'Compute scale factor from sshn'846 IF(lwp) write(numout,*) 'l_1st_euler is forced to true'847 DO jk = 1, jpk848 e3t(:,:,jk,Kmm) = e3t_0(:,:,jk) * ( ht_0(:,:) + ssh(:,:,Kmm) ) &849 & / ( ht_0(:,:) + 1._wp - ssmask(:,:) ) * tmask(:,:,jk) &850 & + e3t_0(:,:,jk) * (1._wp -tmask(:,:,jk))851 END DO852 e3t(:,:,:,Kbb) = e3t(:,:,:,Kmm)853 l_1st_euler = .true.854 823 ENDIF 855 ! !----------- !856 IF( ln_vvl_zstar ) THEN !z_star case !857 ! !----------- !824 ! ! ------------ ! 825 IF( ln_vvl_zstar ) THEN ! z_star case ! 826 ! ! ------------ ! 858 827 IF( MIN( id3, id4 ) > 0 ) THEN 859 828 CALL ctl_stop( 'dom_vvl_rst: z_star cannot restart from a z_tilde or layer run' ) 860 829 ENDIF 861 ! ! ----------------------- ! 862 ELSE ! z_tilde and layer cases ! 863 ! ! ----------------------- ! 864 IF( MIN( id3, id4 ) > 0 ) THEN ! all required arrays exist 865 CALL iom_get( numror, jpdom_auto, 'tilde_e3t_b', tilde_e3t_b(:,:,:), ldxios = lrxios ) 866 CALL iom_get( numror, jpdom_auto, 'tilde_e3t_n', tilde_e3t_n(:,:,:), ldxios = lrxios ) 867 ELSE ! one at least array is missing 830 ! ! ------------------------ ! 831 ELSE ! z_tilde and layer cases ! 832 ! ! ------------------------ ! 833 ! 834 IF( id4 > 0 ) THEN !* scale factor increments 835 IF(lwp) WRITE(numout,*) ' Kmm scale factor increments read in the restart file' 836 CALL iom_get( numror, jpdom_auto, 'tilde_e3t_n', tilde_e3t_n(:,:,:) ) 837 IF( l_1st_euler ) THEN ! euler 838 IF(lwp) WRITE(numout,*) ' Euler first time step : tilde_e3t(Kbb) = tilde_e3t(Kmm)' 839 tilde_e3t_b(:,:,:) = tilde_e3t_n(:,:,:) 840 ELSE ! leap frog 841 IF(lwp) WRITE(numout,*) ' Kbb scale factor increments read in the restart file' 842 CALL iom_get( numror, jpdom_auto, 'tilde_e3t_b', tilde_e3t_b(:,:,:) ) 843 ENDIF 844 ELSE 868 845 tilde_e3t_b(:,:,:) = 0.0_wp 869 846 tilde_e3t_n(:,:,:) = 0.0_wp 870 847 ENDIF 871 ! ! ------------ !872 IF( ln_vvl_ztilde ) THEN ! z_tilde case !873 ! ! ------------ !848 ! ! ------------ ! 849 IF( ln_vvl_ztilde ) THEN ! z_tilde case ! 850 ! ! ------------ ! 874 851 IF( id5 > 0 ) THEN ! required array exists 875 CALL iom_get( numror, jpdom_auto, 'hdiv_lf', hdiv_lf(:,:,:) , ldxios = lrxios)852 CALL iom_get( numror, jpdom_auto, 'hdiv_lf', hdiv_lf(:,:,:) ) 876 853 ELSE ! array is missing 877 854 hdiv_lf(:,:,:) = 0.0_wp … … 880 857 ENDIF 881 858 ! 882 ELSE ! * Initialize at "rest"859 ELSE !== Initialize at "rest" with ssh ==! 883 860 ! 884 885 IF( ll_wd ) THEN ! MJB ll_wd edits start here - these are essential 886 ! 887 IF( cn_cfg == 'wad' ) THEN 888 ! Wetting and drying test case 889 CALL usr_def_istate( gdept(:,:,:,Kbb), tmask, ts(:,:,:,:,Kbb), uu(:,:,:,Kbb), vv(:,:,:,Kbb), ssh(:,:,Kbb) ) 890 ts (:,:,:,:,Kmm) = ts (:,:,:,:,Kbb) ! set now values from to before ones 891 ssh (:,:,Kmm) = ssh(:,:,Kbb) 892 uu (:,:,:,Kmm) = uu (:,:,:,Kbb) 893 vv (:,:,:,Kmm) = vv (:,:,:,Kbb) 894 ELSE 895 ! if not test case 896 ssh(:,:,Kmm) = -ssh_ref 897 ssh(:,:,Kbb) = -ssh_ref 898 899 DO_2D( 1, 1, 1, 1 ) 900 IF( ht_0(ji,jj)-ssh_ref < rn_wdmin1 ) THEN ! if total depth is less than min depth 901 ssh(ji,jj,Kbb) = rn_wdmin1 - (ht_0(ji,jj) ) 902 ssh(ji,jj,Kmm) = rn_wdmin1 - (ht_0(ji,jj) ) 903 ENDIF 904 END_2D 905 ENDIF !If test case else 906 907 ! Adjust vertical metrics for all wad 908 DO jk = 1, jpk 909 e3t(:,:,jk,Kmm) = e3t_0(:,:,jk) * ( ht_0(:,:) + ssh(:,:,Kmm) ) & 910 & / ( ht_0(:,:) + 1._wp - ssmask(:,:) ) * tmask(:,:,jk) & 911 & + e3t_0(:,:,jk) * ( 1._wp - tmask(:,:,jk) ) 912 END DO 913 e3t(:,:,:,Kbb) = e3t(:,:,:,Kmm) 914 915 DO_2D( 1, 1, 1, 1 ) 916 IF ( ht_0(ji,jj) .LE. 0.0 .AND. NINT( ssmask(ji,jj) ) .EQ. 1) THEN 917 CALL ctl_stop( 'dom_vvl_rst: ht_0 must be positive at potentially wet points' ) 918 ENDIF 919 END_2D 920 ! 921 ELSE 922 ! 923 ! Just to read set ssh in fact, called latter once vertical grid 924 ! is set up: 925 ! CALL usr_def_istate( gdept_0, tmask, ts(:,:,:,:,Kbb), uu(:,:,:,Kbb), vv(:,:,:,Kbb), ssh(:,:,Kbb) ) 926 ! ! 927 ! DO jk=1,jpk 928 ! e3t(:,:,jk,Kbb) = e3t_0(:,:,jk) * ( ht_0(:,:) + ssh(:,:,Kbb) ) & 929 ! & / ( ht_0(:,:) + 1._wp -ssmask(:,:) ) * tmask(:,:,jk) 930 ! END DO 931 ! e3t(:,:,:,Kmm) = e3t(:,:,:,Kbb) 932 ssh(:,:,Kmm)=0._wp 933 e3t(:,:,:,Kmm)=e3t_0(:,:,:) 934 e3t(:,:,:,Kbb)=e3t_0(:,:,:) 935 ! 936 END IF ! end of ll_wd edits 937 861 DO jk = 1, jpk 862 e3t(:,:,jk,Kmm) = e3t_0(:,:,jk) * ( 1._wp + ssh(:,:,Kmm) * r1_ht_0(:,:) * tmask(:,:,jk) ) 863 END DO 864 e3t(:,:,:,Kbb) = e3t(:,:,:,Kmm) 865 ! 938 866 IF( ln_vvl_ztilde .OR. ln_vvl_layer) THEN 939 867 tilde_e3t_b(:,:,:) = 0._wp 940 868 tilde_e3t_n(:,:,:) = 0._wp 941 869 IF( ln_vvl_ztilde ) hdiv_lf(:,:,:) = 0._wp 942 END 870 ENDIF 943 871 ENDIF 944 ! 945 ELSEIF( TRIM(cdrw) == 'WRITE' ) THEN ! Create restart file 946 ! ! =================== 872 ! !=======================! 873 ELSEIF( TRIM(cdrw) == 'WRITE' ) THEN ! Create restart file ! 874 ! !=======================! 875 ! 947 876 IF(lwp) WRITE(numout,*) '---- dom_vvl_rst ----' 948 IF( lwxios ) CALL iom_swap( cwxios_context )949 877 ! ! --------- ! 950 878 ! ! all cases ! 951 879 ! ! --------- ! 952 CALL iom_rstput( kt, nitrst, numrow, 'e3t_b', e3t(:,:,:,Kbb) , ldxios = lwxios)953 CALL iom_rstput( kt, nitrst, numrow, 'e3t_n', e3t(:,:,:,Kmm) , ldxios = lwxios)880 CALL iom_rstput( kt, nitrst, numrow, 'e3t_b', e3t(:,:,:,Kbb) ) 881 CALL iom_rstput( kt, nitrst, numrow, 'e3t_n', e3t(:,:,:,Kmm) ) 954 882 ! ! ----------------------- ! 955 883 IF( ln_vvl_ztilde .OR. ln_vvl_layer ) THEN ! z_tilde and layer cases ! 956 884 ! ! ----------------------- ! 957 CALL iom_rstput( kt, nitrst, numrow, 'tilde_e3t_b', tilde_e3t_b(:,:,:) , ldxios = lwxios)958 CALL iom_rstput( kt, nitrst, numrow, 'tilde_e3t_n', tilde_e3t_n(:,:,:) , ldxios = lwxios)885 CALL iom_rstput( kt, nitrst, numrow, 'tilde_e3t_b', tilde_e3t_b(:,:,:)) 886 CALL iom_rstput( kt, nitrst, numrow, 'tilde_e3t_n', tilde_e3t_n(:,:,:)) 959 887 END IF 960 ! ! -------------! 888 ! ! -------------! 961 889 IF( ln_vvl_ztilde ) THEN ! z_tilde case ! 962 890 ! ! ------------ ! 963 CALL iom_rstput( kt, nitrst, numrow, 'hdiv_lf', hdiv_lf(:,:,:) , ldxios = lwxios)891 CALL iom_rstput( kt, nitrst, numrow, 'hdiv_lf', hdiv_lf(:,:,:)) 964 892 ENDIF 965 893 ! 966 IF( lwxios ) CALL iom_swap( cxios_context )967 894 ENDIF 968 895 ! … … 973 900 !!--------------------------------------------------------------------- 974 901 !! *** ROUTINE dom_vvl_ctl *** 975 !! 902 !! 976 903 !! ** Purpose : Control the consistency between namelist options 977 904 !! for vertical coordinate … … 982 909 & ln_vvl_zstar_at_eqtor , rn_ahe3 , rn_rst_e3t , & 983 910 & rn_lf_cutoff , rn_zdef_max , ln_vvl_dbg ! not yet implemented: ln_vvl_kepe 984 !!---------------------------------------------------------------------- 911 !!---------------------------------------------------------------------- 985 912 ! 986 913 READ ( numnam_ref, nam_vvl, IOSTAT = ios, ERR = 901)
Note: See TracChangeset
for help on using the changeset viewer.
