Changeset 13409 for NEMO/branches/UKMO/dev_r12866_HPC-02_Daley_Tiling_trial_extra_halo/src/OCE/TRA/traadv.F90
- Timestamp:
- 2020-08-17T15:28:54+02:00 (4 years ago)
- File:
-
- 1 edited
Legend:
- Unmodified
- Added
- Removed
-
NEMO/branches/UKMO/dev_r12866_HPC-02_Daley_Tiling_trial_extra_halo/src/OCE/TRA/traadv.F90
r12810 r13409 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 !!---------------------------------------------------------------------- 69 73 !! NEMO/OCE 4.0 , NEMO Consortium (2018) … … 85 89 REAL(wp), DIMENSION(jpi,jpj,jpk,jpts,jpt), INTENT(inout) :: pts ! active tracers and RHS of tracer equation 86 90 ! 87 INTEGER :: jk ! dummy loop index 88 REAL(wp), DIMENSION(jpi,jpj,jpk) :: zuu, zvv, zww ! 3D workspace 89 REAL(wp), DIMENSION(:,:,:), ALLOCATABLE :: ztrdt, ztrds 91 ! TEMP: This change not necessary after trd_tra is tiled 92 INTEGER :: itile 93 INTEGER :: ji, jj, jk ! dummy loop index 94 REAL(wp), SAVE :: zsum1, zsum2 95 ! TEMP: This change not necessary and can be A2D 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 90 101 !!---------------------------------------------------------------------- 91 102 ! 92 103 IF( ln_timing ) CALL timing_start('tra_adv') 93 104 ! 94 ! !== effective transport ==! 95 zuu(:,:,jpk) = 0._wp 96 zvv(:,:,jpk) = 0._wp 97 zww(:,:,jpk) = 0._wp 98 IF( ln_wave .AND. ln_sdw ) THEN 99 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) ) 103 END DO 104 ELSE 105 DO jk = 1, jpkm1 106 zuu(:,:,jk) = e2u (:,:) * e3u(:,:,jk,Kmm) * uu(:,:,jk,Kmm) ! eulerian transport only 107 zvv(:,:,jk) = e1v (:,:) * e3v(:,:,jk,Kmm) * vv(:,:,jk,Kmm) 108 zww(:,:,jk) = e1e2t(:,:) * ww(:,:,jk) 109 END DO 110 ENDIF 111 ! 112 IF( ln_vvl_ztilde .OR. ln_vvl_layer ) THEN ! add z-tilde and/or vvl corrections 113 zuu(:,:,:) = zuu(:,:,:) + un_td(:,:,:) 114 zvv(:,:,:) = zvv(:,:,:) + vn_td(:,:,:) 115 ENDIF 116 ! 117 zuu(:,:,jpk) = 0._wp ! no transport trough the bottom 118 zvv(:,:,jpk) = 0._wp 119 zww(:,:,jpk) = 0._wp 120 ! 121 IF( ln_ldfeiv .AND. .NOT. ln_traldf_triad ) & 122 & CALL ldf_eiv_trp( kt, nit000, zuu, zvv, zww, 'TRA', Kmm, Krhs ) ! add the eiv transport (if necessary) 123 ! 124 IF( ln_mle ) CALL tra_mle_trp( kt, nit000, zuu, zvv, zww, 'TRA', Kmm ) ! add the mle transport (if necessary) 125 ! 126 CALL iom_put( "uocetr_eff", zuu ) ! output effective transport 127 CALL iom_put( "vocetr_eff", zvv ) 128 CALL iom_put( "wocetr_eff", zww ) 129 ! 130 !!gm ??? 131 CALL dia_ptr( kt, Kmm, zvv ) ! diagnose the effective MSF 132 !!gm ??? 133 ! 134 135 IF( l_trdtra ) THEN !* Save ta and sa trends 136 ALLOCATE( ztrdt(jpi,jpj,jpk), ztrds(jpi,jpj,jpk) ) 137 ztrdt(:,:,:) = pts(:,:,:,jp_tem,Krhs) 138 ztrds(:,:,:) = pts(:,:,:,jp_sal,Krhs) 139 ENDIF 140 ! 141 SELECT CASE ( nadv ) !== compute advection trend and add it to general trend ==! 142 ! 143 CASE ( np_CEN ) ! Centered scheme : 2nd / 4th order 144 CALL tra_adv_cen ( kt, nit000, 'TRA', zuu, zvv, zww, Kmm, pts, jpts, Krhs, nn_cen_h, nn_cen_v ) 145 CASE ( np_FCT ) ! FCT scheme : 2nd / 4th order 146 CALL tra_adv_fct ( kt, nit000, 'TRA', rDt, zuu, zvv, zww, Kbb, Kmm, pts, jpts, Krhs, nn_fct_h, nn_fct_v ) 147 CASE ( np_MUS ) ! MUSCL 148 CALL tra_adv_mus ( kt, nit000, 'TRA', rDt, zuu, zvv, zww, Kbb, Kmm, pts, jpts, Krhs, ln_mus_ups ) 149 CASE ( np_UBS ) ! UBS 150 CALL tra_adv_ubs ( kt, nit000, 'TRA', rDt, zuu, zvv, zww, Kbb, Kmm, pts, jpts, Krhs, nn_ubs_v ) 151 CASE ( np_QCK ) ! QUICKEST 152 CALL tra_adv_qck ( kt, nit000, 'TRA', rDt, zuu, zvv, zww, Kbb, Kmm, pts, jpts, Krhs ) 153 ! 154 END SELECT 155 ! 156 IF( l_trdtra ) THEN ! save the advective trends for further diagnostics 157 DO jk = 1, jpkm1 158 ztrdt(:,:,jk) = pts(:,:,jk,jp_tem,Krhs) - ztrdt(:,:,jk) 159 ztrds(:,:,jk) = pts(:,:,jk,jp_sal,Krhs) - ztrds(:,:,jk) 160 END DO 161 CALL trd_tra( kt, Kmm, Krhs, 'TRA', jp_tem, jptra_totad, ztrdt ) 162 CALL trd_tra( kt, Kmm, Krhs, 'TRA', jp_sal, jptra_totad, ztrds ) 163 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 A2D 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_11_11( 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_11_11( 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_11_11( 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_11_11 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(A2D,:), zvv(A2D,:), zww(A2D,:), & 161 & 'TRA', Kmm, Krhs ) ! add the eiv transport (if necessary) 162 ! 163 IF( ln_mle ) CALL tra_mle_trp( kt, nit000, zuu(A2D,:), zvv(A2D,:), zww(A2D,:), & 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(A2D,:) ) ! diagnose the effective MSF 176 !!gm ??? 177 ! 178 179 IF( l_trdtra ) THEN !* Save ta and sa trends 180 DO_3D_00_00( 1, jpkm1 ) 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_00_00( 1, jpkm1 ) 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 164 223 ENDIF 165 224 ! ! print mean trends (used for debugging) 166 IF(sn_cfctl%l_prtctl) CALL prt_ctl( tab3d_1=pts(:,:,:,jp_tem,Krhs), clinfo1=' adv - Ta: ', mask1=tmask, & 167 & 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, psum1=zsum1, & 226 & tab3d_2=pts(:,:,:,jp_sal,Krhs), clinfo2= ' Sa: ', mask2=tmask, psum2=zsum2, & 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 168 233 ! 169 234 IF( ln_timing ) CALL timing_stop( 'tra_adv' )
Note: See TracChangeset
for help on using the changeset viewer.