- Timestamp:
- 2020-09-24T20:38:10+02:00 (4 years ago)
- File:
-
- 1 edited
Legend:
- Unmodified
- Added
- Removed
-
NEMO/branches/2020/dev_r13383_HPC-02_Daley_Tiling/src/OCE/TRA/traadv.F90
r13237 r13516 18 18 USE oce ! ocean dynamics and active tracers 19 19 USE dom_oce ! ocean space and time domain 20 ! TEMP: This change not necessary after trd_tra is tiled and extended haloes development 21 USE domain, ONLY : dom_tile 20 22 USE domvvl ! variable vertical scale factors 21 23 USE sbcwave ! wave module … … 65 67 INTEGER, PARAMETER :: np_UBS = 4 ! 3rd order Upstream Biased Scheme 66 68 INTEGER, PARAMETER :: np_QCK = 5 ! QUICK scheme 67 69 70 !! * Substitutions 71 # include "do_loop_substitute.h90" 68 72 # include "domzgr_substitute.h90" 69 73 !!---------------------------------------------------------------------- … … 86 90 REAL(wp), DIMENSION(jpi,jpj,jpk,jpts,jpt), INTENT(inout) :: pts ! active tracers and RHS of tracer equation 87 91 ! 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 92 ! TEMP: This change not necessary after trd_tra is tiled 93 INTEGER :: itile 94 INTEGER :: ji, jj, jk ! dummy loop index 95 ! TEMP: This change not necessary and can be ST_2D(nn_hls) if using XIOS (subdomain support) 96 REAL(wp), DIMENSION(:,:,:), ALLOCATABLE, SAVE :: zuu, zvv, zww ! 3D workspace 97 ! TEMP: This change not necessary after trd_tra is tiled 98 REAL(wp), DIMENSION(:,:,:), ALLOCATABLE, SAVE :: ztrdt, ztrds 99 ! TEMP: This change not necessary after extra haloes development 100 LOGICAL :: lskip 91 101 !!---------------------------------------------------------------------- 92 102 ! 93 103 IF( ln_timing ) CALL timing_start('tra_adv') 94 104 ! 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 ) 105 lskip = .FALSE. 106 107 ! TEMP: These changes not necessary if using XIOS (subdomain support) 108 IF( ntile == 0 .OR. ntile == 1 ) THEN ! Do only on the first tile 109 ALLOCATE( zuu(jpi,jpj,jpk), zvv(jpi,jpj,jpk), zww(jpi,jpj,jpk) ) 110 ! TEMP: This can be ST_2D(nn_hls) after trd_tra is tiled 111 IF( l_trdtra ) ALLOCATE( ztrdt(jpi,jpj,jpk), ztrds(jpi,jpj,jpk) ) 112 ENDIF 113 114 ! TEMP: These changes not necessary after extra haloes development (lbc_lnk removed from tra_adv_*, ldf_eiv_dia) 115 IF( nadv /= np_CEN .OR. (nadv == np_CEN .AND. nn_cen_h == 4) .OR. ln_ldfeiv_dia ) THEN 116 IF( ln_tile ) THEN 117 IF( ntile == 1 ) THEN 118 CALL dom_tile( ntsi, ntsj, ntei, ntej, ktile = 0 ) 119 ELSE 120 lskip = .TRUE. 121 ENDIF 122 ENDIF 123 ENDIF 124 IF( .NOT. lskip ) THEN 125 126 ! TEMP: This change not necessary after trd_tra is tiled 127 itile = ntile 128 ! !== effective transport ==! 129 ! TODO: NOT TESTED- requires waves 130 IF( ln_wave .AND. ln_sdw ) THEN 131 DO_3D( 1, 1, 1, 1, 1, jpkm1 ) 132 zuu(ji,jj,jk) = e2u (ji,jj) * e3u(ji,jj,jk,Kmm) * ( uu(ji,jj,jk,Kmm) + usd(ji,jj,jk) ) 133 zvv(ji,jj,jk) = e1v (ji,jj) * e3v(ji,jj,jk,Kmm) * ( vv(ji,jj,jk,Kmm) + vsd(ji,jj,jk) ) 134 zww(ji,jj,jk) = e1e2t(ji,jj) * ( ww(ji,jj,jk) + wsd(ji,jj,jk) ) 135 END_3D 136 ELSE 137 DO_3D( 1, 1, 1, 1, 1, jpkm1 ) 138 zuu(ji,jj,jk) = e2u (ji,jj) * e3u(ji,jj,jk,Kmm) * uu(ji,jj,jk,Kmm) ! eulerian transport only 139 zvv(ji,jj,jk) = e1v (ji,jj) * e3v(ji,jj,jk,Kmm) * vv(ji,jj,jk,Kmm) 140 zww(ji,jj,jk) = e1e2t(ji,jj) * ww(ji,jj,jk) 141 END_3D 142 ENDIF 143 ! 144 ! TODO: NOT TESTED- requires ztilde 145 IF( ln_vvl_ztilde .OR. ln_vvl_layer ) THEN ! add z-tilde and/or vvl corrections 146 DO_3D( 1, 1, 1, 1, 1, jpkm1 ) 147 zuu(ji,jj,jk) = zuu(ji,jj,jk) + un_td(ji,jj,jk) 148 zvv(ji,jj,jk) = zvv(ji,jj,jk) + vn_td(ji,jj,jk) 149 END_3D 150 ENDIF 151 ! 152 DO_2D( 1, 1, 1, 1 ) 153 zuu(ji,jj,jpk) = 0._wp ! no transport trough the bottom 154 zvv(ji,jj,jpk) = 0._wp 155 zww(ji,jj,jpk) = 0._wp 156 END_2D 157 ! 158 ! TEMP: These changes not necessary if using XIOS (subdomain support) 159 IF( ln_ldfeiv .AND. .NOT. ln_traldf_triad ) & 160 & CALL ldf_eiv_trp( kt, nit000, zuu(ST_2D(nn_hls),:), zvv(ST_2D(nn_hls),:), zww(ST_2D(nn_hls),:), & 161 & 'TRA', Kmm, Krhs ) ! add the eiv transport (if necessary) 162 ! 163 IF( ln_mle ) CALL tra_mle_trp( kt, nit000, zuu(ST_2D(nn_hls),:), zvv(ST_2D(nn_hls),:), zww(ST_2D(nn_hls),:), & 164 & 'TRA', Kmm ) ! add the mle transport (if necessary) 165 ! 166 ! TEMP: This change not necessary if using XIOS (subdomain support) 167 IF( ntile == 0 .OR. ntile == nijtile ) THEN ! Do only on the last tile 168 CALL iom_put( "uocetr_eff", zuu ) ! output effective transport 169 CALL iom_put( "vocetr_eff", zvv ) 170 CALL iom_put( "wocetr_eff", zww ) 171 ENDIF 172 ! 173 !!gm ??? 174 ! TEMP: This change not necessary if using XIOS (subdomain support) 175 CALL dia_ptr( kt, Kmm, zvv(ST_2D(nn_hls),:) ) ! diagnose the effective MSF 176 !!gm ??? 177 ! 178 179 IF( l_trdtra ) THEN !* Save ta and sa trends 180 DO_3D( 0, 0, 0, 0, 1, jpk ) 181 ztrdt(ji,jj,jk) = pts(ji,jj,jk,jp_tem,Krhs) 182 ztrds(ji,jj,jk) = pts(ji,jj,jk,jp_sal,Krhs) 183 END_3D 184 ENDIF 185 ! 186 SELECT CASE ( nadv ) !== compute advection trend and add it to general trend ==! 187 ! 188 CASE ( np_CEN ) ! Centered scheme : 2nd / 4th order 189 CALL tra_adv_cen ( kt, nit000, 'TRA', zuu, zvv, zww, Kmm, pts, jpts, Krhs, nn_cen_h, nn_cen_v ) 190 CASE ( np_FCT ) ! FCT scheme : 2nd / 4th order 191 CALL tra_adv_fct ( kt, nit000, 'TRA', rDt, zuu, zvv, zww, Kbb, Kmm, pts, jpts, Krhs, nn_fct_h, nn_fct_v ) 192 CASE ( np_MUS ) ! MUSCL 193 CALL tra_adv_mus ( kt, nit000, 'TRA', rDt, zuu, zvv, zww, Kbb, Kmm, pts, jpts, Krhs, ln_mus_ups ) 194 CASE ( np_UBS ) ! UBS 195 CALL tra_adv_ubs ( kt, nit000, 'TRA', rDt, zuu, zvv, zww, Kbb, Kmm, pts, jpts, Krhs, nn_ubs_v ) 196 CASE ( np_QCK ) ! QUICKEST 197 CALL tra_adv_qck ( kt, nit000, 'TRA', rDt, zuu, zvv, zww, Kbb, Kmm, pts, jpts, Krhs ) 198 ! 199 END SELECT 200 ! 201 ! TEMP: These changes not necessary after trd_tra is tiled 202 IF( l_trdtra ) THEN ! save the advective trends for further diagnostics 203 DO_3D( 0, 0, 0, 0, 1, jpk ) 204 ztrdt(ji,jj,jk) = pts(ji,jj,jk,jp_tem,Krhs) - ztrdt(ji,jj,jk) 205 ztrds(ji,jj,jk) = pts(ji,jj,jk,jp_sal,Krhs) - ztrds(ji,jj,jk) 206 END_3D 207 208 IF( ntile == 0 .OR. ntile == nijtile ) THEN ! Do only for the full domain 209 IF( ln_tile ) CALL dom_tile( ntsi, ntsj, ntei, ntej, ktile = 0 ) ! Use full domain 210 211 ! TODO: TO BE TILED- trd_tra 212 CALL trd_tra( kt, Kmm, Krhs, 'TRA', jp_tem, jptra_totad, ztrdt ) 213 CALL trd_tra( kt, Kmm, Krhs, 'TRA', jp_sal, jptra_totad, ztrds ) 214 DEALLOCATE( ztrdt, ztrds ) 215 216 IF( ln_tile ) CALL dom_tile( ntsi, ntsj, ntei, ntej, ktile = itile ) ! Revert to tile domain 217 ENDIF 218 ENDIF 219 220 ! TEMP: This change not necessary after extra haloes development (lbc_lnk removed from tra_adv_*, ldf_eiv_dia) 221 IF( ln_tile .AND. ntile == 0 ) CALL dom_tile( ntsi, ntsj, ntei, ntej, ktile = 1 ) 222 168 223 ENDIF 169 224 ! ! 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, & 171 & tab3d_2=pts(:,:,:,jp_sal,Krhs), clinfo2= ' Sa: ', mask2=tmask, clinfo3='tra' ) 225 IF(sn_cfctl%l_prtctl) CALL prt_ctl( tab3d_1=pts(:,:,:,jp_tem,Krhs), clinfo1=' adv - Ta: ', mask1=tmask, & 226 & tab3d_2=pts(:,:,:,jp_sal,Krhs), clinfo2= ' Sa: ', mask2=tmask, & 227 & clinfo3='tra' ) 228 229 ! TEMP: This change not necessary if using XIOS (subdomain support) 230 IF( ntile == 0 .OR. ntile == nijtile ) THEN ! Do only for the full domain 231 DEALLOCATE( zuu, zvv, zww ) 232 ENDIF 172 233 ! 173 234 IF( ln_timing ) CALL timing_stop( 'tra_adv' )
Note: See TracChangeset
for help on using the changeset viewer.
