- Timestamp:
- 2011-12-11T16:00:26+01:00 (13 years ago)
- File:
-
- 1 edited
Legend:
- Unmodified
- Added
- Removed
-
branches/2011/DEV_r2739_STFC_dCSE/NEMOGCM/NEMO/OPA_SRC/TRA/traqsr.F90
r2715 r3211 53 53 REAL(wp), DIMENSION(3,61) :: rkrgb !: tabulated attenuation coefficients for RGB absorption 54 54 55 !! * Control permutation of array indices 56 # include "oce_ftrans.h90" 57 # include "dom_oce_ftrans.h90" 58 # include "sbc_oce_ftrans.h90" 59 # include "trc_oce_ftrans.h90" 60 55 61 !! * Substitutions 56 62 # include "domzgr_substitute.h90" … … 94 100 USE wrk_nemo, ONLY: ze0 => wrk_3d_1 , ze1 => wrk_3d_2 , ze2 => wrk_3d_3 95 101 USE wrk_nemo, ONLY: ze3 => wrk_3d_4 , zea => wrk_3d_5 102 103 !! DCSE_NEMO: need additional directives for renamed module variables 104 !FTRANS ze0 ze1 ze2 ze3 zea :I :I :z 96 105 ! 97 106 INTEGER, INTENT(in) :: kt ! ocean time-step … … 102 111 REAL(wp) :: zc0, zc1, zc2, zc3 ! - - 103 112 REAL(wp) :: zz0, zz1, z1_e3t ! - - 113 114 !FTRANS ztrdt :I :I :z 104 115 REAL(wp), DIMENSION(:,:,:), ALLOCATABLE :: ztrdt 105 116 !!---------------------------------------------------------------------- … … 144 155 IF( lk_qsr_bio .AND. ln_qsr_bio ) THEN ! bio-model fluxes : all vertical coordinates ! 145 156 ! ! ============================================== ! 157 #if defined key_z_first 158 DO jj = 1, jpj 159 DO ji = 1, jpi 160 DO jk = 1, jpkm1 161 qsr_hc(:,:,jk) = ro0cpr * ( etot3(:,:,jk) - etot3(:,:,jk+1) ) 162 END DO 163 END DO 164 END DO 165 #else 146 166 DO jk = 1, jpkm1 147 167 qsr_hc(:,:,jk) = ro0cpr * ( etot3(:,:,jk) - etot3(:,:,jk+1) ) 148 168 END DO 169 #endif 149 170 ! Add to the general trend 171 #if defined key_z_first 172 DO jj = 2, jpjm1 173 DO ji = 2, jpim1 174 DO jk = 1, jpkm1 175 #else 150 176 DO jk = 1, jpkm1 151 177 DO jj = 2, jpjm1 152 178 DO ji = fs_2, fs_jpim1 ! vector opt. 179 #endif 153 180 z1_e3t = zfact / fse3t(ji,jj,jk) 154 181 tsa(ji,jj,jk,jp_tem) = tsa(ji,jj,jk,jp_tem) + ( qsr_hc_b(ji,jj,jk) + qsr_hc(ji,jj,jk) ) * z1_e3t … … 198 225 zea(:,:,1) = qsr(:,:) 199 226 ! 227 #if defined key_z_first 228 DO jj = 1, jpj 229 DO ji = 1, jpi 230 DO jk = 2, nksr+1 231 #else 200 232 DO jk = 2, nksr+1 201 233 !CDIR NOVERRCHK … … 203 235 !CDIR NOVERRCHK 204 236 DO ji = 1, jpi 237 #endif 205 238 zc0 = ze0(ji,jj,jk-1) * EXP( - fse3t(ji,jj,jk-1) * xsi0r ) 206 239 zc1 = ze1(ji,jj,jk-1) * EXP( - fse3t(ji,jj,jk-1) * zekb(ji,jj) ) … … 216 249 END DO 217 250 ! 251 #if defined key_z_first 252 DO jj = 1, jpj 253 DO ji = 1, jpi 254 DO jk = 1, nksr ! compute and add qsr trend to ta 255 qsr_hc(ji,jj,jk) = ro0cpr * ( zea(ji,jj,jk) - zea(ji,jj,jk+1) ) 256 END DO 257 END DO 258 END DO 259 #else 218 260 DO jk = 1, nksr ! compute and add qsr trend to ta 219 261 qsr_hc(:,:,jk) = ro0cpr * ( zea(:,:,jk) - zea(:,:,jk+1) ) 220 262 END DO 263 #endif 221 264 zea(:,:,nksr+1:jpk) = 0.e0 ! below 400m set to zero 222 265 CALL iom_put( 'qsr3d', zea ) ! Shortwave Radiation 3D distribution 223 266 ! 224 267 ELSE !* Constant Chlorophyll 268 #if defined key_z_first 269 DO jj = 1, jpj 270 DO ji = 1, jpi 271 DO jk = 1, nksr 272 qsr_hc(ji,jj,jk) = etot3(ji,jj,jk) * qsr(ji,jj) 273 END DO 274 END DO 275 END DO 276 #else 225 277 DO jk = 1, nksr 226 278 qsr_hc(:,:,jk) = etot3(:,:,jk) * qsr(:,:) 227 279 END DO 280 #endif 228 281 ENDIF 229 282 … … 236 289 zz0 = rn_abs * ro0cpr 237 290 zz1 = ( 1. - rn_abs ) * ro0cpr 291 #if defined key_z_first 292 DO jj = 2, jpjm1 293 DO ji = 2, jpim1 294 DO jk = 1, nksr ! solar heat absorbed at T-point in the top 400m 295 #else 238 296 DO jk = 1, nksr ! solar heat absorbed at T-point in the top 400m 239 297 DO jj = 2, jpjm1 240 298 DO ji = 2, jpim1 299 #endif 241 300 zc0 = zz0 * EXP( -fsdepw(ji,jj,jk )*xsi0r ) + zz1 * EXP( -fsdepw(ji,jj,jk )*xsi1r ) 242 301 zc1 = zz0 * EXP( -fsdepw(ji,jj,jk+1)*xsi0r ) + zz1 * EXP( -fsdepw(ji,jj,jk+1)*xsi1r ) … … 246 305 END DO 247 306 ELSE !* constant volume: coef. computed one for all 307 #if defined key_z_first 308 DO jj = 2, jpjm1 309 DO ji = 2, jpim1 310 DO jk = 1, nksr 311 #else 248 312 DO jk = 1, nksr 249 313 DO jj = 2, jpjm1 250 314 DO ji = fs_2, fs_jpim1 ! vector opt. 315 #endif 251 316 qsr_hc(ji,jj,jk) = etot3(ji,jj,jk) * qsr(ji,jj) 252 317 END DO … … 259 324 ! 260 325 ! Add to the general trend 326 #if defined key_z_first 327 DO jj = 2, jpjm1 328 DO ji = 2, jpim1 329 DO jk = 1, nksr 330 #else 261 331 DO jk = 1, nksr 262 332 DO jj = 2, jpjm1 263 333 DO ji = fs_2, fs_jpim1 ! vector opt. 334 #endif 264 335 z1_e3t = zfact / fse3t(ji,jj,jk) 265 336 tsa(ji,jj,jk,jp_tem) = tsa(ji,jj,jk,jp_tem) + ( qsr_hc_b(ji,jj,jk) + qsr_hc(ji,jj,jk) ) * z1_e3t … … 293 364 END SUBROUTINE tra_qsr 294 365 366 !! * Reset control of array index permutation 367 !FTRANS CLEAR 368 # include "oce_ftrans.h90" 369 # include "dom_oce_ftrans.h90" 370 # include "sbc_oce_ftrans.h90" 371 # include "trc_oce_ftrans.h90" 295 372 296 373 SUBROUTINE tra_qsr_init … … 315 392 USE wrk_nemo, ONLY: ze0 => wrk_3d_1 , ze1 => wrk_3d_2 , ze2 => wrk_3d_3 316 393 USE wrk_nemo, ONLY: ze3 => wrk_3d_4 , zea => wrk_3d_5 394 395 !! DCSE_NEMO: Need additional directives for renamed module variables 396 !FTRANS ze0 ze1 ze2 ze3 zea :I :I :z 397 317 398 ! 318 399 INTEGER :: ji, jj, jk ! dummy loop indices … … 433 514 ! 434 515 zcoef = ( 1. - rn_abs ) / 3.e0 ! equi-partition in R-G-B 516 517 #if defined key_z_first 518 DO jj = 1, jpj 519 DO ji = 1, jpi 520 ze0(ji,jj,1) = rn_abs 521 ze1(ji,jj,1) = zcoef 522 ze2(ji,jj,1) = zcoef 523 ze3(ji,jj,1) = zcoef 524 zea(ji,jj,1) = tmask(ji,jj,1) ! = ( ze0+ze1+z2+ze3 ) * tmask 525 DO jk = 2, nksr+1 526 #else 435 527 ze0(:,:,1) = rn_abs 436 528 ze1(:,:,1) = zcoef … … 438 530 ze3(:,:,1) = zcoef 439 531 zea(:,:,1) = tmask(:,:,1) ! = ( ze0+ze1+z2+ze3 ) * tmask 440 441 532 DO jk = 2, nksr+1 442 533 !CDIR NOVERRCHK … … 444 535 !CDIR NOVERRCHK 445 536 DO ji = 1, jpi 537 #endif 446 538 zc0 = ze0(ji,jj,jk-1) * EXP( - fse3t_0(ji,jj,jk-1) * xsi0r ) 447 539 zc1 = ze1(ji,jj,jk-1) * EXP( - fse3t_0(ji,jj,jk-1) * zekb(ji,jj) ) … … 457 549 END DO 458 550 ! 551 #if defined key_z_first 552 DO jj = 1, jpj 553 DO ji = 1, jpi 554 DO jk = 1, nksr 555 etot3(ji,jj,jk) = ro0cpr * ( zea(ji,jj,jk) - zea(ji,jj,jk+1) ) 556 END DO 557 END DO 558 END DO 559 #else 459 560 DO jk = 1, nksr 460 561 etot3(:,:,jk) = ro0cpr * ( zea(:,:,jk) - zea(:,:,jk+1) ) 461 562 END DO 563 #endif 462 564 etot3(:,:,nksr+1:jpk) = 0.e0 ! below 400m set to zero 463 565 ENDIF … … 481 583 zz0 = rn_abs * ro0cpr 482 584 zz1 = ( 1. - rn_abs ) * ro0cpr 585 #if defined key_z_first 586 DO jj = 1, jpj !* solar heat absorbed at T-point computed once for all 587 DO ji = 1, jpi 588 DO jk = 1, nksr ! top 400 meters 589 zc0 = zz0 * EXP( -fsdepw(ji,jj,jk )*xsi0r ) + zz1 * EXP( -fsdepw(ji,jj,jk )*xsi1r ) 590 zc1 = zz0 * EXP( -fsdepw(ji,jj,jk+1)*xsi0r ) + zz1 * EXP( -fsdepw(ji,jj,jk+1)*xsi1r ) 591 etot3(ji,jj,jk) = ( zc0 * tmask(ji,jj,jk) - zc1 * tmask(ji,jj,jk+1) ) 592 END DO 593 DO jk = nksr+1, jpk 594 etot3(ji,jj,jk) = 0.e0 ! below 400m set to zero 595 END DO 596 END DO 597 END DO 598 #else 483 599 DO jk = 1, nksr !* solar heat absorbed at T-point computed once for all 484 600 DO jj = 1, jpj ! top 400 meters … … 491 607 END DO 492 608 etot3(:,:,nksr+1:jpk) = 0.e0 ! below 400m set to zero 609 #endif 493 610 ! 494 611 ENDIF
Note: See TracChangeset
for help on using the changeset viewer.
