Changeset 13982 for NEMO/trunk/src/OCE/TRA/traadv.F90
- Timestamp:
- 2020-12-02T11:57:05+01:00 (3 years ago)
- File:
-
- 1 edited
-
NEMO/trunk/src/OCE/TRA/traadv.F90 (modified) (4 diffs)
Legend:
- Unmodified
- Added
- Removed
-
NEMO/trunk/src/OCE/TRA/traadv.F90
r13237 r13982 18 18 USE oce ! ocean dynamics and active tracers 19 19 USE dom_oce ! ocean space and time domain 20 ! TEMP: [tiling] This change not necessary after extended haloes development 21 USE domain, ONLY : dom_tile 20 22 USE domvvl ! variable vertical scale factors 21 23 USE sbcwave ! wave module … … 23 25 USE traadv_cen ! centered scheme (tra_adv_cen routine) 24 26 USE traadv_fct ! FCT scheme (tra_adv_fct routine) 27 USE traadv_fct_lf ! FCT scheme (tra_adv_fct routine - loop fusion version) 25 28 USE traadv_mus ! MUSCL scheme (tra_adv_mus routine) 29 USE traadv_mus_lf ! MUSCL scheme (tra_adv_mus routine - loop fusion version) 26 30 USE traadv_ubs ! UBS scheme (tra_adv_ubs routine) 27 31 USE traadv_qck ! QUICKEST scheme (tra_adv_qck routine) … … 65 69 INTEGER, PARAMETER :: np_UBS = 4 ! 3rd order Upstream Biased Scheme 66 70 INTEGER, PARAMETER :: np_QCK = 5 ! QUICK scheme 67 71 72 !! * Substitutions 73 # include "do_loop_substitute.h90" 68 74 # include "domzgr_substitute.h90" 69 75 !!---------------------------------------------------------------------- … … 86 92 REAL(wp), DIMENSION(jpi,jpj,jpk,jpts,jpt), INTENT(inout) :: pts ! active tracers and RHS of tracer equation 87 93 ! 88 INTEGER :: jk ! dummy loop index 89 REAL(wp), DIMENSION(jpi,jpj,jpk) :: zuu, zvv, zww ! 3D workspace 90 REAL(wp), DIMENSION(:,:,:), ALLOCATABLE :: ztrdt, ztrds 94 INTEGER :: ji, jj, jk ! dummy loop index 95 ! TEMP: [tiling] This change not necessary and can be A2D(nn_hls) if using XIOS (subdomain support) 96 REAL(wp), DIMENSION(:,:,:), ALLOCATABLE, SAVE :: zuu, zvv, zww ! 3D workspace 97 REAL(wp), DIMENSION(:,:,:), ALLOCATABLE :: ztrdt, ztrds 98 ! TEMP: [tiling] This change not necessary after extra haloes development 99 LOGICAL :: lskip 91 100 !!---------------------------------------------------------------------- 92 101 ! 93 102 IF( ln_timing ) CALL timing_start('tra_adv') 94 103 ! 95 ! !== effective transport ==! 96 zuu(:,:,jpk) = 0._wp 97 zvv(:,:,jpk) = 0._wp 98 zww(:,:,jpk) = 0._wp 99 IF( ln_wave .AND. ln_sdw ) THEN 100 DO jk = 1, jpkm1 ! eulerian transport + Stokes Drift 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) ) 107 END DO 108 ELSE 109 DO jk = 1, jpkm1 110 zuu(:,:,jk) = e2u (:,:) * e3u(:,:,jk,Kmm) * uu(:,:,jk,Kmm) ! eulerian transport only 111 zvv(:,:,jk) = e1v (:,:) * e3v(:,:,jk,Kmm) * vv(:,:,jk,Kmm) 112 zww(:,:,jk) = e1e2t(:,:) * ww(:,:,jk) 113 END DO 114 ENDIF 115 ! 116 IF( ln_vvl_ztilde .OR. ln_vvl_layer ) THEN ! add z-tilde and/or vvl corrections 117 zuu(:,:,:) = zuu(:,:,:) + un_td(:,:,:) 118 zvv(:,:,:) = zvv(:,:,:) + vn_td(:,:,:) 119 ENDIF 120 ! 121 zuu(:,:,jpk) = 0._wp ! no transport trough the bottom 122 zvv(:,:,jpk) = 0._wp 123 zww(:,:,jpk) = 0._wp 124 ! 125 IF( ln_ldfeiv .AND. .NOT. ln_traldf_triad ) & 126 & CALL ldf_eiv_trp( kt, nit000, zuu, zvv, zww, 'TRA', Kmm, Krhs ) ! add the eiv transport (if necessary) 127 ! 128 IF( ln_mle ) CALL tra_mle_trp( kt, nit000, zuu, zvv, zww, 'TRA', Kmm ) ! add the mle transport (if necessary) 129 ! 130 CALL iom_put( "uocetr_eff", zuu ) ! output effective transport 131 CALL iom_put( "vocetr_eff", zvv ) 132 CALL iom_put( "wocetr_eff", zww ) 133 ! 134 !!gm ??? 135 CALL dia_ptr( kt, Kmm, zvv ) ! diagnose the effective MSF 136 !!gm ??? 137 ! 138 139 IF( l_trdtra ) THEN !* Save ta and sa trends 140 ALLOCATE( ztrdt(jpi,jpj,jpk), ztrds(jpi,jpj,jpk) ) 141 ztrdt(:,:,:) = pts(:,:,:,jp_tem,Krhs) 142 ztrds(:,:,:) = pts(:,:,:,jp_sal,Krhs) 143 ENDIF 144 ! 145 SELECT CASE ( nadv ) !== compute advection trend and add it to general trend ==! 146 ! 147 CASE ( np_CEN ) ! Centered scheme : 2nd / 4th order 148 CALL tra_adv_cen ( kt, nit000, 'TRA', zuu, zvv, zww, Kmm, pts, jpts, Krhs, nn_cen_h, nn_cen_v ) 149 CASE ( np_FCT ) ! FCT scheme : 2nd / 4th order 150 CALL tra_adv_fct ( kt, nit000, 'TRA', rDt, zuu, zvv, zww, Kbb, Kmm, pts, jpts, Krhs, nn_fct_h, nn_fct_v ) 151 CASE ( np_MUS ) ! MUSCL 152 CALL tra_adv_mus ( kt, nit000, 'TRA', rDt, zuu, zvv, zww, Kbb, Kmm, pts, jpts, Krhs, ln_mus_ups ) 153 CASE ( np_UBS ) ! UBS 154 CALL tra_adv_ubs ( kt, nit000, 'TRA', rDt, zuu, zvv, zww, Kbb, Kmm, pts, jpts, Krhs, nn_ubs_v ) 155 CASE ( np_QCK ) ! QUICKEST 156 CALL tra_adv_qck ( kt, nit000, 'TRA', rDt, zuu, zvv, zww, Kbb, Kmm, pts, jpts, Krhs ) 157 ! 158 END SELECT 159 ! 160 IF( l_trdtra ) THEN ! save the advective trends for further diagnostics 161 DO jk = 1, jpkm1 162 ztrdt(:,:,jk) = pts(:,:,jk,jp_tem,Krhs) - ztrdt(:,:,jk) 163 ztrds(:,:,jk) = pts(:,:,jk,jp_sal,Krhs) - ztrds(:,:,jk) 164 END DO 165 CALL trd_tra( kt, Kmm, Krhs, 'TRA', jp_tem, jptra_totad, ztrdt ) 166 CALL trd_tra( kt, Kmm, Krhs, 'TRA', jp_sal, jptra_totad, ztrds ) 167 DEALLOCATE( ztrdt, ztrds ) 104 lskip = .FALSE. 105 106 ! TEMP: [tiling] These changes not necessary if using XIOS (subdomain support) 107 IF( ntile == 0 .OR. ntile == 1 ) THEN ! Do only on the first tile 108 ALLOCATE( zuu(jpi,jpj,jpk), zvv(jpi,jpj,jpk), zww(jpi,jpj,jpk) ) 109 ENDIF 110 111 ! TEMP: [tiling] These changes not necessary after extra haloes development (lbc_lnk removed from tra_adv_*) and if XIOS has subdomain support (ldf_eiv_dia) 112 IF( nadv /= np_CEN .OR. (nadv == np_CEN .AND. nn_cen_h == 4) .OR. ln_ldfeiv_dia ) THEN 113 IF( ln_tile ) THEN 114 IF( ntile == 1 ) THEN 115 CALL dom_tile( ntsi, ntsj, ntei, ntej, ktile = 0 ) 116 ELSE 117 lskip = .TRUE. 118 ENDIF 119 ENDIF 120 ENDIF 121 IF( .NOT. lskip ) THEN 122 ! !== effective transport ==! 123 IF( ln_wave .AND. ln_sdw ) THEN 124 DO_3D( nn_hls, nn_hls, nn_hls, nn_hls, 1, jpkm1 ) 125 zuu(ji,jj,jk) = e2u (ji,jj) * e3u(ji,jj,jk,Kmm) * ( uu(ji,jj,jk,Kmm) + usd(ji,jj,jk) ) 126 zvv(ji,jj,jk) = e1v (ji,jj) * e3v(ji,jj,jk,Kmm) * ( vv(ji,jj,jk,Kmm) + vsd(ji,jj,jk) ) 127 zww(ji,jj,jk) = e1e2t(ji,jj) * ( ww(ji,jj,jk) + wsd(ji,jj,jk) ) 128 END_3D 129 ELSE 130 DO_3D( nn_hls, nn_hls, nn_hls, nn_hls, 1, jpkm1 ) 131 zuu(ji,jj,jk) = e2u (ji,jj) * e3u(ji,jj,jk,Kmm) * uu(ji,jj,jk,Kmm) ! eulerian transport only 132 zvv(ji,jj,jk) = e1v (ji,jj) * e3v(ji,jj,jk,Kmm) * vv(ji,jj,jk,Kmm) 133 zww(ji,jj,jk) = e1e2t(ji,jj) * ww(ji,jj,jk) 134 END_3D 135 ENDIF 136 ! 137 IF( ln_vvl_ztilde .OR. ln_vvl_layer ) THEN ! add z-tilde and/or vvl corrections 138 DO_3D( nn_hls, nn_hls, nn_hls, nn_hls, 1, jpkm1 ) 139 zuu(ji,jj,jk) = zuu(ji,jj,jk) + un_td(ji,jj,jk) 140 zvv(ji,jj,jk) = zvv(ji,jj,jk) + vn_td(ji,jj,jk) 141 END_3D 142 ENDIF 143 ! 144 DO_2D( nn_hls, nn_hls, nn_hls, nn_hls ) 145 zuu(ji,jj,jpk) = 0._wp ! no transport trough the bottom 146 zvv(ji,jj,jpk) = 0._wp 147 zww(ji,jj,jpk) = 0._wp 148 END_2D 149 ! 150 ! TEMP: [tiling] These changes not necessary if using XIOS (subdomain support) 151 IF( ln_ldfeiv .AND. .NOT. ln_traldf_triad ) & 152 & CALL ldf_eiv_trp( kt, nit000, zuu(A2D(nn_hls),:), zvv(A2D(nn_hls),:), zww(A2D(nn_hls),:), & 153 & 'TRA', Kmm, Krhs ) ! add the eiv transport (if necessary) 154 ! 155 IF( ln_mle ) CALL tra_mle_trp( kt, nit000, zuu(A2D(nn_hls),:), zvv(A2D(nn_hls),:), zww(A2D(nn_hls),:), & 156 & 'TRA', Kmm ) ! add the mle transport (if necessary) 157 ! 158 ! TEMP: [tiling] This change not necessary if using XIOS (subdomain support) 159 IF( ntile == 0 .OR. ntile == nijtile ) THEN ! Do only on the last tile 160 CALL iom_put( "uocetr_eff", zuu ) ! output effective transport 161 CALL iom_put( "vocetr_eff", zvv ) 162 CALL iom_put( "wocetr_eff", zww ) 163 ENDIF 164 ! 165 !!gm ??? 166 ! TEMP: [tiling] This change not necessary if using XIOS (subdomain support) 167 CALL dia_ptr( kt, Kmm, zvv(A2D(nn_hls),:) ) ! diagnose the effective MSF 168 !!gm ??? 169 ! 170 171 IF( l_trdtra ) THEN !* Save ta and sa trends 172 ALLOCATE( ztrdt(jpi,jpj,jpk), ztrds(jpi,jpj,jpk) ) 173 ztrdt(:,:,:) = pts(:,:,:,jp_tem,Krhs) 174 ztrds(:,:,:) = pts(:,:,:,jp_sal,Krhs) 175 ENDIF 176 ! 177 ! NOTE: [tiling-comms-merge] These lbc_lnk calls are still needed (pts in the zco case because zps_hde is not called in step, zuu/zvv/zww in all cases, I think because DO loop bounds need to be updated in DYN as done in TRA) 178 SELECT CASE ( nadv ) !== compute advection trend and add it to general trend ==! 179 ! 180 CASE ( np_CEN ) ! Centered scheme : 2nd / 4th order 181 IF (nn_hls.EQ.2) CALL lbc_lnk( 'traadv', pts(:,:,:,:,Kmm), 'T', 1. ) 182 CALL tra_adv_cen ( kt, nit000, 'TRA', zuu, zvv, zww, Kmm, pts, jpts, Krhs, nn_cen_h, nn_cen_v ) 183 CASE ( np_FCT ) ! FCT scheme : 2nd / 4th order 184 IF (nn_hls.EQ.2) THEN 185 CALL lbc_lnk_multi( 'traadv', pts(:,:,:,:,Kbb), 'T', 1., pts(:,:,:,:,Kmm), 'T', 1.) 186 CALL lbc_lnk_multi( 'traadv', zuu(:,:,:), 'U', -1., zvv(:,:,:), 'V', -1., zww(:,:,:), 'W', 1.) 187 #if defined key_loop_fusion 188 CALL tra_adv_fct_lf ( kt, nit000, 'TRA', rDt, zuu, zvv, zww, Kbb, Kmm, pts, jpts, Krhs, nn_fct_h, nn_fct_v ) 189 #else 190 CALL tra_adv_fct ( kt, nit000, 'TRA', rDt, zuu, zvv, zww, Kbb, Kmm, pts, jpts, Krhs, nn_fct_h, nn_fct_v ) 191 #endif 192 ELSE 193 CALL tra_adv_fct ( kt, nit000, 'TRA', rDt, zuu, zvv, zww, Kbb, Kmm, pts, jpts, Krhs, nn_fct_h, nn_fct_v ) 194 END IF 195 CASE ( np_MUS ) ! MUSCL 196 ! NOTE: [tiling-comms-merge] I added this lbc_lnk as it did not validate against the trunk when using ln_zco 197 IF (nn_hls.EQ.2) THEN 198 CALL lbc_lnk( 'traadv', pts(:,:,:,:,Kbb), 'T', 1.) 199 #if defined key_loop_fusion 200 CALL tra_adv_mus_lf ( kt, nit000, 'TRA', rDt, zuu, zvv, zww, Kbb, Kmm, pts, jpts, Krhs, ln_mus_ups ) 201 #else 202 CALL tra_adv_mus ( kt, nit000, 'TRA', rDt, zuu, zvv, zww, Kbb, Kmm, pts, jpts, Krhs, ln_mus_ups ) 203 #endif 204 ELSE 205 CALL tra_adv_mus ( kt, nit000, 'TRA', rDt, zuu, zvv, zww, Kbb, Kmm, pts, jpts, Krhs, ln_mus_ups ) 206 END IF 207 CASE ( np_UBS ) ! UBS 208 IF (nn_hls.EQ.2) CALL lbc_lnk( 'traadv', pts(:,:,:,:,Kbb), 'T', 1.) 209 CALL tra_adv_ubs ( kt, nit000, 'TRA', rDt, zuu, zvv, zww, Kbb, Kmm, pts, jpts, Krhs, nn_ubs_v ) 210 CASE ( np_QCK ) ! QUICKEST 211 IF (nn_hls.EQ.2) THEN 212 CALL lbc_lnk_multi( 'traadv', zuu(:,:,:), 'U', -1., zvv(:,:,:), 'V', -1.) 213 CALL lbc_lnk( 'traadv', pts(:,:,:,:,Kbb), 'T', 1.) 214 END IF 215 CALL tra_adv_qck ( kt, nit000, 'TRA', rDt, zuu, zvv, zww, Kbb, Kmm, pts, jpts, Krhs ) 216 ! 217 END SELECT 218 ! 219 IF( l_trdtra ) THEN ! save the advective trends for further diagnostics 220 DO jk = 1, jpkm1 221 ztrdt(:,:,jk) = pts(:,:,jk,jp_tem,Krhs) - ztrdt(:,:,jk) 222 ztrds(:,:,jk) = pts(:,:,jk,jp_sal,Krhs) - ztrds(:,:,jk) 223 END DO 224 CALL trd_tra( kt, Kmm, Krhs, 'TRA', jp_tem, jptra_totad, ztrdt ) 225 CALL trd_tra( kt, Kmm, Krhs, 'TRA', jp_sal, jptra_totad, ztrds ) 226 DEALLOCATE( ztrdt, ztrds ) 227 ENDIF 228 229 ! TEMP: [tiling] This change not necessary after extra haloes development (lbc_lnk removed from tra_adv_*) and if XIOS has subdomain support (ldf_eiv_dia) 230 IF( ln_tile .AND. ntile == 0 ) CALL dom_tile( ntsi, ntsj, ntei, ntej, ktile = 1 ) 231 168 232 ENDIF 169 233 ! ! print mean trends (used for debugging) 170 IF(sn_cfctl%l_prtctl) CALL prt_ctl( tab3d_1=pts(:,:,:,jp_tem,Krhs), clinfo1=' adv - Ta: ', mask1=tmask, 234 IF(sn_cfctl%l_prtctl) CALL prt_ctl( tab3d_1=pts(:,:,:,jp_tem,Krhs), clinfo1=' adv - Ta: ', mask1=tmask, & 171 235 & tab3d_2=pts(:,:,:,jp_sal,Krhs), clinfo2= ' Sa: ', mask2=tmask, clinfo3='tra' ) 236 237 ! TEMP: [tiling] This change not necessary if using XIOS (subdomain support) 238 IF( ntile == 0 .OR. ntile == nijtile ) THEN ! Do only for the full domain 239 DEALLOCATE( zuu, zvv, zww ) 240 ENDIF 172 241 ! 173 242 IF( ln_timing ) CALL timing_stop( 'tra_adv' )
Note: See TracChangeset
for help on using the changeset viewer.
