Changeset 14037 for NEMO/branches/2020/dev_r13333_KERNEL-08_techene_gm_HPG_SPG/src/OCE/TRA/traqsr.F90
- Timestamp:
- 2020-12-03T12:20:38+01:00 (3 years ago)
- Location:
- NEMO/branches/2020/dev_r13333_KERNEL-08_techene_gm_HPG_SPG
- Files:
-
- 2 edited
-
. (modified) (1 prop)
-
src/OCE/TRA/traqsr.F90 (modified) (15 diffs)
Legend:
- Unmodified
- Added
- Removed
-
NEMO/branches/2020/dev_r13333_KERNEL-08_techene_gm_HPG_SPG
- Property svn:externals
-
old new 8 8 9 9 # SETTE 10 ^/utils/CI/sette @13292sette10 ^/utils/CI/sette_wave@13990 sette
-
- Property svn:externals
-
NEMO/branches/2020/dev_r13333_KERNEL-08_techene_gm_HPG_SPG/src/OCE/TRA/traqsr.F90
r13333 r14037 22 22 USE phycst ! physical constants 23 23 USE dom_oce ! ocean space and time domain 24 USE domain, ONLY : dom_tile 24 25 USE sbc_oce ! surface boundary condition: ocean 25 26 USE trc_oce ! share SMS/Ocean variables … … 107 108 ! 108 109 INTEGER :: ji, jj, jk ! dummy loop indices 109 INTEGER :: irgb 110 INTEGER :: irgb, isi, iei, isj, iej ! local integers 110 111 REAL(wp) :: zchl, zcoef, z1_2 ! local scalars 111 112 REAL(wp) :: zc0 , zc1 , zc2 , zc3 ! - - … … 120 121 IF( ln_timing ) CALL timing_start('tra_qsr') 121 122 ! 122 IF( kt == nit000 ) THEN 123 IF(lwp) WRITE(numout,*) 124 IF(lwp) WRITE(numout,*) 'tra_qsr : penetration of the surface solar radiation' 125 IF(lwp) WRITE(numout,*) '~~~~~~~' 123 IF( ntile == 0 .OR. ntile == 1 ) THEN ! Do only on the first tile 124 IF( kt == nit000 ) THEN 125 IF(lwp) WRITE(numout,*) 126 IF(lwp) WRITE(numout,*) 'tra_qsr : penetration of the surface solar radiation' 127 IF(lwp) WRITE(numout,*) '~~~~~~~' 128 ENDIF 126 129 ENDIF 127 130 ! 128 131 IF( l_trdtra ) THEN ! trends diagnostic: save the input temperature trend 129 ALLOCATE( ztrdt(jpi,jpj,jpk) ) 132 ALLOCATE( ztrdt(jpi,jpj,jpk) ) 130 133 ztrdt(:,:,:) = pts(:,:,:,jp_tem,Krhs) 131 134 ENDIF … … 134 137 ! ! before qsr induced heat content ! 135 138 ! !-----------------------------------! 139 ! NOTE: [tiling-comms-merge] Many DO loop bounds changed (probably more than necessary) to avoid changing results when using tiling. Some bounds were also adjusted to account for those changed in tra_atf 140 IF( ntsi == Nis0 ) THEN ; isi = nn_hls ; ELSE ; isi = 0 ; ENDIF ! Avoid double-counting when using tiling 141 IF( ntsj == Njs0 ) THEN ; isj = nn_hls ; ELSE ; isj = 0 ; ENDIF 142 IF( ntei == Nie0 ) THEN ; iei = nn_hls ; ELSE ; iei = 0 ; ENDIF 143 IF( ntej == Nje0 ) THEN ; iej = nn_hls ; ELSE ; iej = 0 ; ENDIF 144 136 145 IF( kt == nit000 ) THEN !== 1st time step ==! 137 146 IF( ln_rstart .AND. iom_varid( numror, 'qsr_hc_b', ldstop = .FALSE. ) > 0 .AND. .NOT.l_1st_euler ) THEN ! read in restart 138 IF(lwp) WRITE(numout,*) ' nit000-1 qsr tracer content forcing field read in the restart file'139 147 z1_2 = 0.5_wp 140 CALL iom_get( numror, jpdom_auto, 'qsr_hc_b', qsr_hc_b, ldxios = lrxios ) ! before heat content trend due to Qsr flux 148 IF( ntile == 0 .OR. ntile == 1 ) THEN ! Do only on the first tile 149 IF(lwp) WRITE(numout,*) ' nit000-1 qsr tracer content forcing field read in the restart file' 150 CALL iom_get( numror, jpdom_auto, 'qsr_hc_b', qsr_hc_b ) ! before heat content trend due to Qsr flux 151 ENDIF 141 152 ELSE ! No restart or restart not found: Euler forward time stepping 142 153 z1_2 = 1._wp 143 qsr_hc_b(:,:,:) = 0._wp 154 DO_3D( isj, iej, isi, iei, 1, jpk ) 155 qsr_hc_b(ji,jj,jk) = 0._wp 156 END_3D 144 157 ENDIF 145 158 ELSE !== Swap of qsr heat content ==! 146 159 z1_2 = 0.5_wp 147 qsr_hc_b(:,:,:) = qsr_hc(:,:,:) 160 DO_3D( isj, iej, isi, iei, 1, jpk ) 161 qsr_hc_b(ji,jj,jk) = qsr_hc(ji,jj,jk) 162 END_3D 148 163 ENDIF 149 164 ! … … 154 169 CASE( np_BIO ) !== bio-model fluxes ==! 155 170 ! 156 DO jk = 1, nksr157 qsr_hc( :,:,jk) = r1_rho0_rcp * ( etot3(:,:,jk) - etot3(:,:,jk+1) )158 END DO171 DO_3D( isj, iej, isi, iei, 1, nksr ) 172 qsr_hc(ji,jj,jk) = r1_rho0_rcp * ( etot3(ji,jj,jk) - etot3(ji,jj,jk+1) ) 173 END_3D 159 174 ! 160 175 CASE( np_RGB , np_RGBc ) !== R-G-B fluxes ==! 161 176 ! 162 ALLOCATE( ze0 ( jpi,jpj) , ze1 (jpi,jpj) , &163 & ze2 ( jpi,jpj) , ze3 (jpi,jpj) , &164 & ztmp3d( jpi,jpj,nksr + 1) )177 ALLOCATE( ze0 (A2D(nn_hls)) , ze1 (A2D(nn_hls)) , & 178 & ze2 (A2D(nn_hls)) , ze3 (A2D(nn_hls)) , & 179 & ztmp3d(A2D(nn_hls),nksr + 1) ) 165 180 ! 166 181 IF( nqsr == np_RGBc ) THEN !* Variable Chlorophyll 167 CALL fld_read( kt, 1, sf_chl ) ! Read Chl data and provides it at the current time step 182 IF( ntile == 0 .OR. ntile == 1 ) THEN ! Do only for the full domain 183 IF( ln_tile ) CALL dom_tile( ntsi, ntsj, ntei, ntej, ktile = 0 ) ! Use full domain 184 CALL fld_read( kt, 1, sf_chl ) ! Read Chl data and provides it at the current time step 185 IF( ln_tile ) CALL dom_tile( ntsi, ntsj, ntei, ntej, ktile = 1 ) ! Revert to tile domain 186 ENDIF 168 187 ! 169 188 ! Separation in R-G-B depending on the surface Chl … … 172 191 ! most expensive calculations) 173 192 ! 174 DO_2D( 0, 0, 0, 0)193 DO_2D( isj, iej, isi, iei ) 175 194 ! zlogc = log(zchl) 176 195 zlogc = LOG ( MIN( 10. , MAX( 0.03, sf_chl(1)%fnow(ji,jj,1) ) ) ) … … 191 210 192 211 ! 193 DO_3D( 0, 0, 0, 0, 1, nksr + 1 )212 DO_3D( isj, iej, isi, iei, 1, nksr + 1 ) 194 213 ! zchl = ALOG( ze0(ji,jj) ) 195 214 zlogc = ze0(ji,jj) … … 216 235 zlui = 41 + 20.*LOG10(zchl) + 1.e-15 217 236 DO jk = 1, nksr + 1 218 ztmp3d(:,:,jk) = zlui 237 ztmp3d(:,:,jk) = zlui 219 238 END DO 220 239 ENDIF 221 240 ! 222 241 zcoef = ( 1. - rn_abs ) / 3._wp !* surface equi-partition in R-G-B 223 DO_2D( 0, 0, 0, 0)242 DO_2D( isj, iej, isi, iei ) 224 243 ze0(ji,jj) = rn_abs * qsr(ji,jj) 225 244 ze1(ji,jj) = zcoef * qsr(ji,jj) … … 231 250 END_2D 232 251 ! 233 ! * interior equi-partition in R-G-B depending on vertical profile of Chl234 DO_3D( 0, 0, 0, 0, 2, nksr + 1 )252 ! !* interior equi-partition in R-G-B depending on vertical profile of Chl 253 DO_3D( isj, iej, isi, iei, 2, nksr + 1 ) 235 254 ze3t = e3t(ji,jj,jk-1,Kmm) 236 255 irgb = NINT( ztmp3d(ji,jj,jk) ) … … 246 265 END_3D 247 266 ! 248 DO_3D( 0, 0, 0, 0, 1, nksr )267 DO_3D( isj, iej, isi, iei, 1, nksr ) !* now qsr induced heat content 249 268 qsr_hc(ji,jj,jk) = r1_rho0_rcp * ( ztmp3d(ji,jj,jk) - ztmp3d(ji,jj,jk+1) ) 250 269 END_3D … … 256 275 zz0 = rn_abs * r1_rho0_rcp ! surface equi-partition in 2-bands 257 276 zz1 = ( 1. - rn_abs ) * r1_rho0_rcp 258 DO_3D( 0, 0, 0, 0, 1, nksr )277 DO_3D( isj, iej, isi, iei, 1, nksr ) !* now qsr induced heat content 259 278 zc0 = zz0 * EXP( -gdepw(ji,jj,jk ,Kmm)*xsi0r ) + zz1 * EXP( -gdepw(ji,jj,jk ,Kmm)*xsi1r ) 260 279 zc1 = zz0 * EXP( -gdepw(ji,jj,jk+1,Kmm)*xsi0r ) + zz1 * EXP( -gdepw(ji,jj,jk+1,Kmm)*xsi1r ) … … 264 283 END SELECT 265 284 ! 285 ! !-----------------------------! 286 ! ! update to the temp. trend ! 266 287 ! !-----------------------------! 267 288 DO_3D( 0, 0, 0, 0, 1, nksr ) … … 272 293 ! 273 294 ! sea-ice: store the 1st ocean level attenuation coefficient 274 DO_2D( 0, 0, 0, 0)295 DO_2D( isj, iej, isi, iei ) 275 296 IF( qsr(ji,jj) /= 0._wp ) THEN ; fraqsr_1lev(ji,jj) = qsr_hc(ji,jj,1) / ( r1_rho0_rcp * qsr(ji,jj) ) 276 297 ELSE ; fraqsr_1lev(ji,jj) = 1._wp 277 298 ENDIF 278 299 END_2D 279 CALL lbc_lnk( 'traqsr', fraqsr_1lev(:,:), 'T', 1._wp ) 280 ! 281 IF( iom_use('qsr3d') ) THEN ! output the shortwave Radiation distribution 282 ALLOCATE( zetot(jpi,jpj,jpk) ) 283 zetot(:,:,nksr+1:jpk) = 0._wp ! below ~400m set to zero 284 DO jk = nksr, 1, -1 285 zetot(:,:,jk) = zetot(:,:,jk+1) + qsr_hc(:,:,jk) * rho0_rcp 286 END DO 287 CALL iom_put( 'qsr3d', zetot ) ! 3D distribution of shortwave Radiation 288 DEALLOCATE( zetot ) 289 ENDIF 290 ! 291 IF( lrst_oce ) THEN ! write in the ocean restart file 292 IF( lwxios ) CALL iom_swap( cwxios_context ) 293 CALL iom_rstput( kt, nitrst, numrow, 'qsr_hc_b' , qsr_hc , ldxios = lwxios ) 294 CALL iom_rstput( kt, nitrst, numrow, 'fraqsr_1lev', fraqsr_1lev, ldxios = lwxios ) 295 IF( lwxios ) CALL iom_swap( cxios_context ) 300 ! 301 ! TEMP: [tiling] This change not necessary and working array can use A2D(nn_hls) if using XIOS (subdomain support) 302 IF( ntile == 0 .OR. ntile == nijtile ) THEN ! Do only for the full domain 303 IF( iom_use('qsr3d') ) THEN ! output the shortwave Radiation distribution 304 ALLOCATE( zetot(jpi,jpj,jpk) ) 305 zetot(:,:,nksr+1:jpk) = 0._wp ! below ~400m set to zero 306 DO jk = nksr, 1, -1 307 zetot(:,:,jk) = zetot(:,:,jk+1) + qsr_hc(:,:,jk) * rho0_rcp 308 END DO 309 CALL iom_put( 'qsr3d', zetot ) ! 3D distribution of shortwave Radiation 310 DEALLOCATE( zetot ) 311 ENDIF 312 ENDIF 313 ! 314 IF( ntile == 0 .OR. ntile == nijtile ) THEN ! Do only on the last tile 315 IF( lrst_oce ) THEN ! write in the ocean restart file 316 CALL iom_rstput( kt, nitrst, numrow, 'qsr_hc_b' , qsr_hc ) 317 CALL iom_rstput( kt, nitrst, numrow, 'fraqsr_1lev', fraqsr_1lev ) 318 ENDIF 296 319 ENDIF 297 320 ! … … 299 322 ztrdt(:,:,:) = pts(:,:,:,jp_tem,Krhs) - ztrdt(:,:,:) 300 323 CALL trd_tra( kt, Kmm, Krhs, 'TRA', jp_tem, jptra_qsr, ztrdt ) 301 DEALLOCATE( ztrdt ) 324 DEALLOCATE( ztrdt ) 302 325 ENDIF 303 326 ! ! print mean trends (used for debugging) … … 429 452 ! 1st ocean level attenuation coefficient (used in sbcssm) 430 453 IF( iom_varid( numror, 'fraqsr_1lev', ldstop = .FALSE. ) > 0 ) THEN 431 CALL iom_get( numror, jpdom_auto, 'fraqsr_1lev' , fraqsr_1lev , ldxios = lrxios)454 CALL iom_get( numror, jpdom_auto, 'fraqsr_1lev' , fraqsr_1lev ) 432 455 ELSE 433 456 fraqsr_1lev(:,:) = 1._wp ! default : no penetration 434 457 ENDIF 435 458 ! 436 IF( lwxios ) THEN437 CALL iom_set_rstw_var_active('qsr_hc_b')438 CALL iom_set_rstw_var_active('fraqsr_1lev')439 ENDIF440 !441 459 END SUBROUTINE tra_qsr_init 442 460
Note: See TracChangeset
for help on using the changeset viewer.
