Changeset 5965 for branches/2014/dev_r4650_UKMO14.5_SST_BIAS_CORRECTION/NEMOGCM/NEMO/OPA_SRC/TRA/traldf_iso.F90
- Timestamp:
- 2015-12-01T16:35:30+01:00 (8 years ago)
- File:
-
- 1 edited
Legend:
- Unmodified
- Added
- Removed
-
branches/2014/dev_r4650_UKMO14.5_SST_BIAS_CORRECTION/NEMOGCM/NEMO/OPA_SRC/TRA/traldf_iso.F90
r4292 r5965 28 28 USE in_out_manager ! I/O manager 29 29 USE iom ! I/O library 30 #if defined key_diaar531 30 USE phycst ! physical constants 32 31 USE lbclnk ! ocean lateral boundary conditions (or mpp link) 33 #endif34 32 USE wrk_nemo ! Memory Allocation 35 33 USE timing ! Timing … … 52 50 53 51 SUBROUTINE tra_ldf_iso( kt, kit000, cdtype, pgu, pgv, & 52 & pgui, pgvi, & 54 53 & ptb, pta, kjpt, pahtb0 ) 55 54 !!---------------------------------------------------------------------- … … 98 97 CHARACTER(len=3) , INTENT(in ) :: cdtype ! =TRA or TRC (tracer indicator) 99 98 INTEGER , INTENT(in ) :: kjpt ! number of tracers 100 REAL(wp), DIMENSION(jpi,jpj ,kjpt), INTENT(in ) :: pgu, pgv ! tracer gradient at pstep levels 99 REAL(wp), DIMENSION(jpi,jpj ,kjpt), INTENT(in ) :: pgu , pgv ! tracer gradient at pstep levels 100 REAL(wp), DIMENSION(jpi,jpj ,kjpt), INTENT(in ) :: pgui, pgvi ! tracer gradient at pstep levels 101 101 REAL(wp), DIMENSION(jpi,jpj,jpk,kjpt), INTENT(in ) :: ptb ! before and now tracer fields 102 102 REAL(wp), DIMENSION(jpi,jpj,jpk,kjpt), INTENT(inout) :: pta ! tracer trend … … 104 104 ! 105 105 INTEGER :: ji, jj, jk, jn ! dummy loop indices 106 INTEGER :: ikt 106 107 REAL(wp) :: zmsku, zabe1, zcof1, zcoef3 ! local scalars 107 108 REAL(wp) :: zmskv, zabe2, zcof2, zcoef4 ! - - 108 109 REAL(wp) :: zcoef0, zbtr, ztra ! - - 109 #if defined key_diaar5 110 REAL(wp) :: zztmp ! local scalar 111 #endif 112 REAL(wp), POINTER, DIMENSION(:,: ) :: zdkt, zdk1t, z2d 113 REAL(wp), POINTER, DIMENSION(:,:,:) :: zdit, zdjt, ztfw 110 REAL(wp), POINTER, DIMENSION(:,: ) :: z2d 111 REAL(wp), POINTER, DIMENSION(:,:,:) :: zdkt, zdk1t, zdit, zdjt, ztfw 114 112 !!---------------------------------------------------------------------- 115 113 ! 116 114 IF( nn_timing == 1 ) CALL timing_start('tra_ldf_iso') 117 115 ! 118 CALL wrk_alloc( jpi, jpj, z dkt, zdk1t, z2d )119 CALL wrk_alloc( jpi, jpj, jpk, zdit, zdjt, ztfw 116 CALL wrk_alloc( jpi, jpj, z2d ) 117 CALL wrk_alloc( jpi, jpj, jpk, zdit, zdjt, ztfw, zdkt, zdk1t ) 120 118 ! 121 119 … … 147 145 END DO 148 146 END DO 147 148 ! partial cell correction 149 149 IF( ln_zps ) THEN ! partial steps correction at the last ocean level 150 150 DO jj = 1, jpjm1 151 151 DO ji = 1, fs_jpim1 ! vector opt. 152 ! IF useless if zpshde defines pgu everywhere 152 153 zdit(ji,jj,mbku(ji,jj)) = pgu(ji,jj,jn) 153 zdjt(ji,jj,mbkv(ji,jj)) = pgv(ji,jj,jn) 154 zdjt(ji,jj,mbkv(ji,jj)) = pgv(ji,jj,jn) 154 155 END DO 155 156 END DO 156 157 ENDIF 158 IF( ln_zps .AND. ln_isfcav ) THEN ! partial steps correction at the first wet level beneath a cavity 159 DO jj = 1, jpjm1 160 DO ji = 1, fs_jpim1 ! vector opt. 161 IF (miku(ji,jj) > 1) zdit(ji,jj,miku(ji,jj)) = pgui(ji,jj,jn) 162 IF (mikv(ji,jj) > 1) zdjt(ji,jj,mikv(ji,jj)) = pgvi(ji,jj,jn) 163 END DO 164 END DO 165 END IF 157 166 158 167 !!---------------------------------------------------------------------- 159 168 !! II - horizontal trend (full) 160 169 !!---------------------------------------------------------------------- 161 !CDIR PARALLEL DO PRIVATE( zdk1t ) 162 ! ! =============== 163 DO jk = 1, jpkm1 ! Horizontal slab 164 ! ! =============== 170 !!!!!!!!!!CDIR PARALLEL DO PRIVATE( zdk1t ) 165 171 ! 1. Vertical tracer gradient at level jk and jk+1 166 172 ! ------------------------------------------------ 167 ! surface boundary condition: zdkt(jk=1)=zdkt(jk=2) 168 zdk1t(:,:) = ( ptb(:,:,jk,jn) - ptb(:,:,jk+1,jn) ) * tmask(:,:,jk+1) 169 ! 170 IF( jk == 1 ) THEN ; zdkt(:,:) = zdk1t(:,:) 171 ELSE ; zdkt(:,:) = ( ptb(:,:,jk-1,jn) - ptb(:,:,jk,jn) ) * tmask(:,:,jk) 172 ENDIF 173 174 ! 2. Horizontal fluxes 175 ! -------------------- 173 ! 174 ! interior value 175 DO jk = 2, jpkm1 176 DO jj = 1, jpj 177 DO ji = 1, jpi ! vector opt. 178 zdk1t(ji,jj,jk) = ( ptb(ji,jj,jk,jn ) - ptb(ji,jj,jk+1,jn) ) * wmask(ji,jj,jk+1) 179 ! 180 zdkt(ji,jj,jk) = ( ptb(ji,jj,jk-1,jn) - ptb(ji,jj,jk,jn ) ) * wmask(ji,jj,jk) 181 END DO 182 END DO 183 END DO 184 ! surface boundary condition: zdkt(jk=1)=zdkt(jk=2) 185 zdk1t(:,:,1) = ( ptb(:,:,1,jn ) - ptb(:,:,2,jn) ) * wmask(:,:,2) 186 zdkt (:,:,1) = zdk1t(:,:,1) 187 IF ( ln_isfcav ) THEN 188 DO jj = 1, jpj 189 DO ji = 1, jpi ! vector opt. 190 ikt = mikt(ji,jj) ! surface level 191 zdk1t(ji,jj,ikt) = ( ptb(ji,jj,ikt,jn ) - ptb(ji,jj,ikt+1,jn) ) * wmask(ji,jj,ikt+1) 192 zdkt (ji,jj,ikt) = zdk1t(ji,jj,ikt) 193 END DO 194 END DO 195 END IF 196 197 ! 2. Horizontal fluxes 198 ! -------------------- 199 DO jk = 1, jpkm1 176 200 DO jj = 1 , jpjm1 177 201 DO ji = 1, fs_jpim1 ! vector opt. … … 189 213 ! 190 214 zftu(ji,jj,jk ) = ( zabe1 * zdit(ji,jj,jk) & 191 & + zcof1 * ( zdkt (ji+1,jj ) + zdk1t(ji,jj) &192 & + zdk1t(ji+1,jj ) + zdkt (ji,jj) ) ) * umask(ji,jj,jk)215 & + zcof1 * ( zdkt (ji+1,jj,jk) + zdk1t(ji,jj,jk) & 216 & + zdk1t(ji+1,jj,jk) + zdkt (ji,jj,jk) ) ) * umask(ji,jj,jk) 193 217 zftv(ji,jj,jk) = ( zabe2 * zdjt(ji,jj,jk) & 194 & + zcof2 * ( zdkt (ji,jj+1 ) + zdk1t(ji,jj) &195 & + zdk1t(ji,jj+1 ) + zdkt (ji,jj) ) ) * vmask(ji,jj,jk)218 & + zcof2 * ( zdkt (ji,jj+1,jk) + zdk1t(ji,jj,jk) & 219 & + zdk1t(ji,jj+1,jk) + zdkt (ji,jj,jk) ) ) * vmask(ji,jj,jk) 196 220 END DO 197 221 END DO … … 211 235 ! 212 236 ! "Poleward" diffusive heat or salt transports (T-S case only) 213 IF( cdtype == 'TRA' .AND. ln_diaptr .AND. ( MOD( kt, nn_fptr ) == 0 )) THEN237 IF( cdtype == 'TRA' .AND. ln_diaptr ) THEN 214 238 ! note sign is reversed to give down-gradient diffusive transports (#1043) 215 IF( jn == jp_tem) htr_ldf(:) = ptr_ vj( -zftv(:,:,:) )216 IF( jn == jp_sal) str_ldf(:) = ptr_ vj( -zftv(:,:,:) )239 IF( jn == jp_tem) htr_ldf(:) = ptr_sj( -zftv(:,:,:) ) 240 IF( jn == jp_sal) str_ldf(:) = ptr_sj( -zftv(:,:,:) ) 217 241 ENDIF 218 242 219 #if defined key_diaar5 220 IF( cdtype == 'TRA' .AND. jn == jp_tem ) THEN221 z2d(:,:) = 0._wp222 ! note sign is reversed to give down-gradient diffusive transports (#1043)223 zztmp = -1.0_wp * rau0 * rcp224 DO jk = 1, jpkm1225 DO jj = 2, jpjm1226 DO ji = fs_2, fs_jpim1 ! vector opt.227 z2d(ji,jj) = z2d(ji,jj) + zftu(ji,jj,jk)243 IF( iom_use("udiff_heattr") .OR. iom_use("vdiff_heattr") ) THEN 244 ! 245 IF( cdtype == 'TRA' .AND. jn == jp_tem ) THEN 246 z2d(:,:) = 0._wp 247 DO jk = 1, jpkm1 248 DO jj = 2, jpjm1 249 DO ji = fs_2, fs_jpim1 ! vector opt. 250 z2d(ji,jj) = z2d(ji,jj) + zftu(ji,jj,jk) 251 END DO 228 252 END DO 229 253 END DO 230 END DO 231 z2d(:,:) = zztmp * z2d(:,:) 232 CALL lbc_lnk( z2d, 'U', -1. ) 233 CALL iom_put( "udiff_heattr", z2d ) ! heat transport in i-direction 234 z2d(:,:) = 0._wp 235 DO jk = 1, jpkm1 236 DO jj = 2, jpjm1 237 DO ji = fs_2, fs_jpim1 ! vector opt. 238 z2d(ji,jj) = z2d(ji,jj) + zftv(ji,jj,jk) 254 z2d(:,:) = - rau0_rcp * z2d(:,:) ! note sign is reversed to give down-gradient diffusive transports (#1043) 255 CALL lbc_lnk( z2d, 'U', -1. ) 256 CALL iom_put( "udiff_heattr", z2d ) ! heat transport in i-direction 257 ! 258 z2d(:,:) = 0._wp 259 DO jk = 1, jpkm1 260 DO jj = 2, jpjm1 261 DO ji = fs_2, fs_jpim1 ! vector opt. 262 z2d(ji,jj) = z2d(ji,jj) + zftv(ji,jj,jk) 263 END DO 239 264 END DO 240 265 END DO 241 END DO242 z2d(:,:) = zztmp * z2d(:,:)243 CALL lbc_lnk( z2d, 'V', -1. )244 CALL iom_put( "vdiff_heattr", z2d ) ! heat transport in i-direction245 END IF246 #endif 266 z2d(:,:) = - rau0_rcp * z2d(:,:) ! note sign is reversed to give down-gradient diffusive transports (#1043) 267 CALL lbc_lnk( z2d, 'V', -1. ) 268 CALL iom_put( "vdiff_heattr", z2d ) ! heat transport in i-direction 269 END IF 270 ! 271 ENDIF 247 272 248 273 !!---------------------------------------------------------------------- … … 264 289 DO jj = 2, jpjm1 265 290 DO ji = fs_2, fs_jpim1 ! vector opt. 266 zcoef0 = - fsahtw(ji,jj,jk) * tmask(ji,jj,jk)291 zcoef0 = - fsahtw(ji,jj,jk) * wmask(ji,jj,jk) 267 292 ! 268 293 zmsku = 1./MAX( umask(ji ,jj,jk-1) + umask(ji-1,jj,jk) & … … 297 322 END DO 298 323 ! 299 CALL wrk_dealloc( jpi, jpj, zdkt, zdk1t,z2d )300 CALL wrk_dealloc( jpi, jpj, jpk, zdit, zdjt, ztfw 324 CALL wrk_dealloc( jpi, jpj, z2d ) 325 CALL wrk_dealloc( jpi, jpj, jpk, zdit, zdjt, ztfw, zdkt, zdk1t ) 301 326 ! 302 327 IF( nn_timing == 1 ) CALL timing_stop('tra_ldf_iso') … … 309 334 !!---------------------------------------------------------------------- 310 335 CONTAINS 311 SUBROUTINE tra_ldf_iso( kt, kit000,cdtype, pgu, pgv, p tb, pta, kjpt, pahtb0 ) ! Empty routine336 SUBROUTINE tra_ldf_iso( kt, kit000,cdtype, pgu, pgv, pgui, pgvi, ptb, pta, kjpt, pahtb0 ) ! Empty routine 312 337 INTEGER:: kt, kit000 313 338 CHARACTER(len=3) :: cdtype 314 REAL, DIMENSION(:,:,:) :: pgu, pgv ! tracer gradient at pstep levels339 REAL, DIMENSION(:,:,:) :: pgu, pgv, pgui, pgvi ! tracer gradient at pstep levels 315 340 REAL, DIMENSION(:,:,:,:) :: ptb, pta 316 341 WRITE(*,*) 'tra_ldf_iso: You should not have seen this print! error?', kt, kit000, cdtype, &
Note: See TracChangeset
for help on using the changeset viewer.
