Changeset 14986 for NEMO/branches/2021/dev_r14116_HPC-10_mcastril_Mixed_Precision_implementation/src/OCE/TRA/traadv.F90
- Timestamp:
- 2021-06-14T13:34:08+02:00 (3 years ago)
- File:
-
- 1 edited
Legend:
- Unmodified
- Added
- Removed
-
NEMO/branches/2021/dev_r14116_HPC-10_mcastril_Mixed_Precision_implementation/src/OCE/TRA/traadv.F90
r14648 r14986 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 development20 ! TEMP: [tiling] This change not necessary after all lbc_lnks removed in the nn_hls = 2 case in tra_adv_fct 21 21 USE domtile 22 22 USE domvvl ! variable vertical scale factors … … 25 25 USE traadv_cen ! centered scheme (tra_adv_cen routine) 26 26 USE traadv_fct ! FCT scheme (tra_adv_fct routine) 27 USE traadv_fct_lf ! FCT scheme (tra_adv_fct routine - loop fusion version)28 27 USE traadv_mus ! MUSCL scheme (tra_adv_mus routine) 29 USE traadv_mus_lf ! MUSCL scheme (tra_adv_mus routine - loop fusion version)30 28 USE traadv_ubs ! UBS scheme (tra_adv_ubs routine) 31 29 USE traadv_qck ! QUICKEST scheme (tra_adv_qck routine) … … 61 59 LOGICAL :: ln_traadv_qck ! QUICKEST scheme flag 62 60 63 INTEGER :: nadv ! choice of the type of advection scheme61 INTEGER, PUBLIC :: nadv ! choice of the type of advection scheme 64 62 ! ! associated indices: 65 INTEGER, PARAMETER :: np_NO_adv = 0 ! no T-S advection66 INTEGER, PARAMETER :: np_CEN = 1 ! 2nd/4th order centered scheme67 INTEGER, PARAMETER :: np_FCT = 2 ! 2nd/4th order Flux Corrected Transport scheme68 INTEGER, PARAMETER :: np_MUS = 3 ! MUSCL scheme69 INTEGER, PARAMETER :: np_UBS = 4 ! 3rd order Upstream Biased Scheme70 INTEGER, PARAMETER :: np_QCK = 5 ! QUICK scheme63 INTEGER, PARAMETER, PUBLIC :: np_NO_adv = 0 ! no T-S advection 64 INTEGER, PARAMETER, PUBLIC :: np_CEN = 1 ! 2nd/4th order centered scheme 65 INTEGER, PARAMETER, PUBLIC :: np_FCT = 2 ! 2nd/4th order Flux Corrected Transport scheme 66 INTEGER, PARAMETER, PUBLIC :: np_MUS = 3 ! MUSCL scheme 67 INTEGER, PARAMETER, PUBLIC :: np_UBS = 4 ! 3rd order Upstream Biased Scheme 68 INTEGER, PARAMETER, PUBLIC :: np_QCK = 5 ! QUICK scheme 71 69 72 70 !! * Substitutions … … 94 92 ! 95 93 INTEGER :: ji, jj, jk ! dummy loop index 96 ! TEMP: [tiling] This change not necessary and can be A2D(nn_hls) if using XIOS (subdomain support)94 ! TEMP: [tiling] This change not necessary and can be A2D(nn_hls) after all lbc_lnks removed in the nn_hls = 2 case in tra_adv_fct 97 95 REAL(wp), DIMENSION(:,:,:), ALLOCATABLE, SAVE :: zuu, zvv, zww ! 3D workspace 98 96 REAL(wp), DIMENSION(:,:,:), ALLOCATABLE :: ztrdt, ztrds 99 ! TEMP: [tiling] This change not necessary after extra haloes development97 ! TEMP: [tiling] This change not necessary after all lbc_lnks removed in the nn_hls = 2 case in tra_adv_fct 100 98 LOGICAL :: lskip 101 99 !!---------------------------------------------------------------------- … … 105 103 lskip = .FALSE. 106 104 107 ! TEMP: [tiling] These changes not necessary if using XIOS (subdomain support)108 IF( ntile == 0.OR. ntile == 1 ) THEN ! Do only on the first tile105 ! TEMP: [tiling] These changes not necessary after all lbc_lnks removed in the nn_hls = 2 case in tra_adv_fct 106 IF( .NOT. l_istiled .OR. ntile == 1 ) THEN ! Do only on the first tile 109 107 ALLOCATE( zuu(jpi,jpj,jpk), zvv(jpi,jpj,jpk), zww(jpi,jpj,jpk) ) 110 108 ENDIF 111 109 112 ! 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) 113 IF( nadv /= np_CEN .OR. (nadv == np_CEN .AND. nn_cen_h == 4) .OR. ln_ldfeiv_dia ) THEN 114 IF( ln_tile ) THEN 115 IF( ntile == 1 ) THEN 116 CALL dom_tile( ntsi, ntsj, ntei, ntej, ktile = 0 ) 117 ELSE 118 lskip = .TRUE. 119 ENDIF 110 ! TEMP: [tiling] These changes not necessary after all lbc_lnks removed in the nn_hls = 2 case in tra_adv_fct 111 IF( ln_tile .AND. nadv == np_FCT ) THEN 112 IF( ntile == 1 ) THEN 113 CALL dom_tile_stop( ldhold=.TRUE. ) 114 ELSE 115 lskip = .TRUE. 120 116 ENDIF 121 117 ENDIF … … 123 119 ! !== effective transport ==! 124 120 IF( ln_wave .AND. ln_sdw ) THEN 125 DO_3D ( nn_hls, nn_hls, nn_hls, nn_hls, 1, jpkm1 )121 DO_3D_OVR( nn_hls, nn_hls-1, nn_hls, nn_hls-1, 1, jpkm1 ) 126 122 zuu(ji,jj,jk) = e2u (ji,jj) * e3u(ji,jj,jk,Kmm) * ( uu(ji,jj,jk,Kmm) + usd(ji,jj,jk) ) 127 123 zvv(ji,jj,jk) = e1v (ji,jj) * e3v(ji,jj,jk,Kmm) * ( vv(ji,jj,jk,Kmm) + vsd(ji,jj,jk) ) … … 129 125 END_3D 130 126 ELSE 131 DO_3D ( nn_hls, nn_hls, nn_hls, nn_hls, 1, jpkm1 )127 DO_3D_OVR( nn_hls, nn_hls-1, nn_hls, nn_hls-1, 1, jpkm1 ) 132 128 zuu(ji,jj,jk) = e2u (ji,jj) * e3u(ji,jj,jk,Kmm) * uu(ji,jj,jk,Kmm) ! eulerian transport only 133 129 zvv(ji,jj,jk) = e1v (ji,jj) * e3v(ji,jj,jk,Kmm) * vv(ji,jj,jk,Kmm) … … 137 133 ! 138 134 IF( ln_vvl_ztilde .OR. ln_vvl_layer ) THEN ! add z-tilde and/or vvl corrections 139 DO_3D ( nn_hls, nn_hls, nn_hls, nn_hls, 1, jpkm1 )135 DO_3D_OVR( nn_hls, nn_hls-1, nn_hls, nn_hls-1, 1, jpkm1 ) 140 136 zuu(ji,jj,jk) = zuu(ji,jj,jk) + un_td(ji,jj,jk) 141 137 zvv(ji,jj,jk) = zvv(ji,jj,jk) + vn_td(ji,jj,jk) … … 143 139 ENDIF 144 140 ! 145 DO_2D ( nn_hls, nn_hls, nn_hls, nn_hls)141 DO_2D_OVR( nn_hls, nn_hls-1, nn_hls, nn_hls-1 ) 146 142 zuu(ji,jj,jpk) = 0._wp ! no transport trough the bottom 147 143 zvv(ji,jj,jpk) = 0._wp … … 149 145 END_2D 150 146 ! 151 ! TEMP: [tiling] These changes not necessary if using XIOS (subdomain support)152 147 IF( ln_ldfeiv .AND. .NOT. ln_traldf_triad ) & 153 & CALL ldf_eiv_trp( kt, nit000, zuu(A2D(nn_hls),:), zvv(A2D(nn_hls),:), zww(A2D(nn_hls),:), & 154 & 'TRA', Kmm, Krhs ) ! add the eiv transport (if necessary) 155 ! 156 IF( ln_mle ) CALL tra_mle_trp( kt, nit000, zuu(A2D(nn_hls),:), zvv(A2D(nn_hls),:), zww(A2D(nn_hls),:), & 157 & 'TRA', Kmm ) ! add the mle transport (if necessary) 158 ! 159 ! TEMP: [tiling] This change not necessary if using XIOS (subdomain support) 160 IF( ntile == 0 .OR. ntile == nijtile ) THEN ! Do only on the last tile 148 & CALL ldf_eiv_trp( kt, nit000, zuu, zvv, zww, 'TRA', Kmm, Krhs ) ! add the eiv transport (if necessary) 149 ! 150 IF( ln_mle ) CALL tra_mle_trp( kt, nit000, zuu, zvv, zww, 'TRA', Kmm ) ! add the mle transport (if necessary) 151 ! 152 ! TEMP: [tiling] This change not necessary after all lbc_lnks removed in the nn_hls = 2 case in tra_adv_fct 153 IF( .NOT. l_istiled .OR. ntile == nijtile ) THEN ! Do only on the last tile 161 154 CALL iom_put( "uocetr_eff", zuu ) ! output effective transport 162 155 CALL iom_put( "vocetr_eff", zvv ) … … 164 157 ENDIF 165 158 ! 166 167 ! TEMP: [tiling] This c hange not necessary if using XIOS (subdomain support)159 !!gm ??? 160 ! TEMP: [tiling] This copy-in not necessary after all lbc_lnks removed in the nn_hls = 2 case in tra_adv_fct 168 161 CALL dia_ptr( kt, Kmm, zvv(A2D(nn_hls),:) ) ! diagnose the effective MSF 169 162 !!gm ??? 170 163 ! 171 164 … … 179 172 ! 180 173 CASE ( np_CEN ) ! Centered scheme : 2nd / 4th order 181 IF (nn_hls.EQ.2) CALL lbc_lnk( 'traadv', pts(:,:,:,:,Kmm), 'T', 1._wp )182 174 CALL tra_adv_cen ( kt, nit000, 'TRA', zuu, zvv, zww, Kmm, pts, jpts, Krhs, nn_cen_h, nn_cen_v ) 183 175 CASE ( np_FCT ) ! FCT scheme : 2nd / 4th order 184 IF (nn_hls.EQ.2) THEN185 CALL lbc_lnk( 'traadv', pts(:,:,:,:,Kbb), 'T', 1._wp, pts(:,:,:,:,Kmm), 'T', 1._wp)186 CALL lbc_lnk( 'traadv', zuu(:,:,:), 'U', -1._wp, zvv(:,:,:), 'V', -1._wp, zww(:,:,:), 'W', 1._wp)187 #if defined key_loop_fusion188 CALL tra_adv_fct_lf ( kt, nit000, 'TRA', rDt, zuu, zvv, zww, Kbb, Kmm, pts, jpts, Krhs, nn_fct_h, nn_fct_v )189 #else190 176 CALL tra_adv_fct ( kt, nit000, 'TRA', rDt, zuu, zvv, zww, Kbb, Kmm, pts, jpts, Krhs, nn_fct_h, nn_fct_v ) 191 #endif192 ELSE193 CALL tra_adv_fct ( kt, nit000, 'TRA', rDt, zuu, zvv, zww, Kbb, Kmm, pts, jpts, Krhs, nn_fct_h, nn_fct_v )194 END IF195 177 CASE ( np_MUS ) ! MUSCL 196 IF (nn_hls.EQ.2) THEN197 CALL lbc_lnk( 'traadv', pts(:,:,:,:,Kbb), 'T', 1._wp)198 #if defined key_loop_fusion199 CALL tra_adv_mus_lf ( kt, nit000, 'TRA', rDt, zuu, zvv, zww, Kbb, Kmm, pts, jpts, Krhs, ln_mus_ups )200 #else201 178 CALL tra_adv_mus ( kt, nit000, 'TRA', rDt, zuu, zvv, zww, Kbb, Kmm, pts, jpts, Krhs, ln_mus_ups ) 202 #endif203 ELSE204 CALL tra_adv_mus ( kt, nit000, 'TRA', rDt, zuu, zvv, zww, Kbb, Kmm, pts, jpts, Krhs, ln_mus_ups )205 END IF206 179 CASE ( np_UBS ) ! UBS 207 IF (nn_hls.EQ.2) CALL lbc_lnk( 'traadv', pts(:,:,:,:,Kbb), 'T', 1._wp)208 180 CALL tra_adv_ubs ( kt, nit000, 'TRA', rDt, zuu, zvv, zww, Kbb, Kmm, pts, jpts, Krhs, nn_ubs_v ) 209 181 CASE ( np_QCK ) ! QUICKEST 210 IF (nn_hls.EQ.2) THEN211 CALL lbc_lnk( 'traadv', zuu(:,:,:), 'U', -1._wp, zvv(:,:,:), 'V', -1._wp)212 CALL lbc_lnk( 'traadv', pts(:,:,:,:,Kbb), 'T', 1._wp)213 END IF214 182 CALL tra_adv_qck ( kt, nit000, 'TRA', rDt, zuu, zvv, zww, Kbb, Kmm, pts, jpts, Krhs ) 215 183 ! … … 226 194 ENDIF 227 195 228 ! 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) 229 IF( ln_tile .AND. ntile == 0 ) CALL dom_tile( ntsi, ntsj, ntei, ntej, ktile = 1 ) 230 196 ! TEMP: [tiling] This change not necessary after all lbc_lnks removed in the nn_hls = 2 case in tra_adv_fct 197 IF( ln_tile .AND. .NOT. l_istiled ) CALL dom_tile_start( ldhold=.TRUE. ) 231 198 ENDIF 232 199 ! ! print mean trends (used for debugging) … … 234 201 & tab3d_2=CASTWP(pts(:,:,:,jp_sal,Krhs)), clinfo2= ' Sa: ', mask2=tmask, clinfo3='tra' ) 235 202 236 ! TEMP: [tiling] This change not necessary if using XIOS (subdomain support)237 IF( ntile == 0.OR. ntile == nijtile ) THEN ! Do only for the full domain203 ! TEMP: [tiling] This change not necessary after all lbc_lnks removed in the nn_hls = 2 case in tra_adv_fct 204 IF( .NOT. l_istiled .OR. ntile == nijtile ) THEN ! Do only for the full domain 238 205 DEALLOCATE( zuu, zvv, zww ) 239 206 ENDIF … … 307 274 CALL ctl_stop( 'tra_adv_init: FCT scheme, choose 2nd or 4th order' ) 308 275 ENDIF 276 ! TEMP: [tiling] This change not necessary after all lbc_lnks removed in the nn_hls = 2 case in tra_adv_fct 277 IF( ln_traadv_fct .AND. ln_tile ) THEN 278 CALL ctl_warn( 'tra_adv_init: FCT scheme does not yet work with tiling' ) 279 ENDIF 309 280 IF( ln_traadv_ubs .AND. ( nn_ubs_v /= 2 .AND. nn_ubs_v /= 4 ) ) THEN ! UBS 310 281 CALL ctl_stop( 'tra_adv_init: UBS scheme, choose 2nd or 4th order' )
Note: See TracChangeset
for help on using the changeset viewer.
