Changeset 3421 for trunk/NEMOGCM/NEMO/OPA_SRC/DOM/closea.F90
- Timestamp:
- 2012-07-02T16:44:12+02:00 (12 years ago)
- File:
-
- 1 edited
-
trunk/NEMOGCM/NEMO/OPA_SRC/DOM/closea.F90 (modified) (9 diffs)
Legend:
- Unmodified
- Added
- Removed
-
trunk/NEMOGCM/NEMO/OPA_SRC/DOM/closea.F90
r2715 r3421 7 7 !! 8.5 ! 02-06 (E. Durand, G. Madec) F90 8 8 !! 9.0 ! 06-07 (G. Madec) add clo_rnf, clo_ups, clo_bat 9 !! NEMO 3.4 ! 03-12 (P.G. Fogli) sbc_clo bug fix & mpp reproducibility 9 10 !!---------------------------------------------------------------------- 10 11 … … 20 21 USE in_out_manager ! I/O manager 21 22 USE sbc_oce ! ocean surface boundary conditions 22 USE lib_mpp ! distributed memory computing library 23 USE lbclnk ! ??? 23 USE lib_fortran, ONLY: glob_sum, DDPDD 24 USE lbclnk ! lateral boundary condition - MPP exchanges 25 USE lib_mpp ! MPP library 26 USE timing 24 27 25 28 IMPLICIT NONE … … 85 88 SELECT CASE ( jp_cfg ) 86 89 ! ! ======================= 90 CASE ( 1 ) ! ORCA_R1 configuration 91 ! ! ======================= 92 ncsnr(1) = 1 ; ncstt(1) = 0 ! Caspian Sea 93 ncsi1(1) = 332 ; ncsj1(1) = 203 94 ncsi2(1) = 344 ; ncsj2(1) = 235 95 ncsir(1,1) = 1 ; ncsjr(1,1) = 1 96 ! 97 ! ! ======================= 87 98 CASE ( 2 ) ! ORCA_R2 configuration 88 99 ! ! ======================= … … 177 188 INTEGER, INTENT(in) :: kt ! ocean model time step 178 189 ! 179 INTEGER :: ji, jj, jc, jn ! dummy loop indices 180 REAL(wp) :: zze2 181 REAL(wp), DIMENSION (jpncs) :: zfwf 182 !!---------------------------------------------------------------------- 183 ! 190 INTEGER :: ji, jj, jc, jn ! dummy loop indices 191 REAL(wp), PARAMETER :: rsmall = 1.e-20_wp ! Closed sea correction epsilon 192 REAL(wp) :: zze2, ztmp, zcorr ! 193 COMPLEX(wp) :: ctmp 194 REAL(wp), DIMENSION(jpncs) :: zfwf ! 1D workspace 195 !!---------------------------------------------------------------------- 196 ! 197 IF( nn_timing == 1 ) CALL timing_start('sbc_clo') 184 198 ! !------------------! 185 199 IF( kt == nit000 ) THEN ! Initialisation ! … … 189 203 IF(lwp) WRITE(numout,*)'~~~~~~~' 190 204 191 ! Total surface of ocean 192 surf(jpncs+1) = SUM( e1t(:,:) * e2t(:,:) * tmask_i(:,:) ) 193 194 DO jc = 1, jpncs 195 surf(jc) =0.e0 196 DO jj = ncsj1(jc), ncsj2(jc) 197 DO ji = ncsi1(jc), ncsi2(jc) 198 surf(jc) = surf(jc) + e1t(ji,jj) * e2t(ji,jj) * tmask_i(ji,jj) ! surface of closed seas 205 surf(:) = 0.e0_wp 206 ! 207 surf(jpncs+1) = glob_sum( e1e2t(:,:) ) ! surface of the global ocean 208 ! 209 ! ! surface of closed seas 210 IF( lk_mpp_rep ) THEN ! MPP reproductible calculation 211 DO jc = 1, jpncs 212 ctmp = CMPLX( 0.e0, 0.e0, wp ) 213 DO jj = ncsj1(jc), ncsj2(jc) 214 DO ji = ncsi1(jc), ncsi2(jc) 215 ztmp = e1e2t(ji,jj) * tmask_i(ji,jj) 216 CALL DDPDD( CMPLX( ztmp, 0.e0, wp ), ctmp ) 217 END DO 199 218 END DO 200 END DO 201 END DO 202 IF( lk_mpp ) CALL mpp_sum ( surf, jpncs+1 ) ! mpp: sum over all the global domain 219 IF( lk_mpp ) CALL mpp_sum( ctmp ) 220 surf(jc) = REAL(ctmp,wp) 221 END DO 222 ELSE ! Standard calculation 223 DO jc = 1, jpncs 224 DO jj = ncsj1(jc), ncsj2(jc) 225 DO ji = ncsi1(jc), ncsi2(jc) 226 surf(jc) = surf(jc) + e1e2t(ji,jj) * tmask_i(ji,jj) ! surface of closed seas 227 END DO 228 END DO 229 END DO 230 IF( lk_mpp ) CALL mpp_sum ( surf, jpncs+1 ) ! mpp: sum over all the global domain 231 ENDIF 203 232 204 233 IF(lwp) WRITE(numout,*)' Closed sea surfaces' … … 215 244 ! !--------------------! 216 245 ! ! update emp, emps ! 217 zfwf = 0.e0 !--------------------! 218 DO jc = 1, jpncs 219 DO jj = ncsj1(jc), ncsj2(jc) 220 DO ji = ncsi1(jc), ncsi2(jc) 221 zfwf(jc) = zfwf(jc) + e1t(ji,jj) * e2t(ji,jj) * ( emp(ji,jj)-rnf(ji,jj) ) * tmask_i(ji,jj) 222 END DO 223 END DO 224 END DO 225 IF( lk_mpp ) CALL mpp_sum ( zfwf(:) , jpncs ) ! mpp: sum over all the global domain 246 zfwf = 0.e0_wp !--------------------! 247 IF( lk_mpp_rep ) THEN ! MPP reproductible calculation 248 DO jc = 1, jpncs 249 ctmp = CMPLX( 0.e0, 0.e0, wp ) 250 DO jj = ncsj1(jc), ncsj2(jc) 251 DO ji = ncsi1(jc), ncsi2(jc) 252 ztmp = e1e2t(ji,jj) * ( emp(ji,jj)-rnf(ji,jj) ) * tmask_i(ji,jj) 253 CALL DDPDD( CMPLX( ztmp, 0.e0, wp ), ctmp ) 254 END DO 255 END DO 256 IF( lk_mpp ) CALL mpp_sum( ctmp ) 257 zfwf(jc) = REAL(ctmp,wp) 258 END DO 259 ELSE ! Standard calculation 260 DO jc = 1, jpncs 261 DO jj = ncsj1(jc), ncsj2(jc) 262 DO ji = ncsi1(jc), ncsi2(jc) 263 zfwf(jc) = zfwf(jc) + e1e2t(ji,jj) * ( emp(ji,jj)-rnf(ji,jj) ) * tmask_i(ji,jj) 264 END DO 265 END DO 266 END DO 267 IF( lk_mpp ) CALL mpp_sum ( zfwf(:) , jpncs ) ! mpp: sum over all the global domain 268 ENDIF 226 269 227 270 IF( cp_cfg == "orca" .AND. jp_cfg == 2 ) THEN ! Black Sea case for ORCA_R2 configuration 228 zze2 = ( zfwf(3) + zfwf(4) ) / 2.271 zze2 = ( zfwf(3) + zfwf(4) ) * 0.5_wp 229 272 zfwf(3) = zze2 230 273 zfwf(4) = zze2 231 274 ENDIF 232 275 276 zcorr = 0._wp 277 233 278 DO jc = 1, jpncs 234 279 ! 235 IF( ncstt(jc) == 0 ) THEN 236 ! water/evap excess is shared by all open ocean 237 emp (:,:) = emp (:,:) + zfwf(jc) / surf(jpncs+1) 238 emps(:,:) = emps(:,:) + zfwf(jc) / surf(jpncs+1) 239 ELSEIF( ncstt(jc) == 1 ) THEN 240 ! Excess water in open sea, at outflow location, excess evap shared 241 IF ( zfwf(jc) <= 0.e0 ) THEN 242 DO jn = 1, ncsnr(jc) 280 ! The following if avoids the redistribution of the round off 281 IF ( ABS(zfwf(jc) / surf(jpncs+1) ) > rsmall) THEN 282 ! 283 IF( ncstt(jc) == 0 ) THEN ! water/evap excess is shared by all open ocean 284 emp (:,:) = emp (:,:) + zfwf(jc) / surf(jpncs+1) 285 emps(:,:) = emps(:,:) + zfwf(jc) / surf(jpncs+1) 286 ! accumulate closed seas correction 287 zcorr = zcorr + zfwf(jc) / surf(jpncs+1) 288 ! 289 ELSEIF( ncstt(jc) == 1 ) THEN ! Excess water in open sea, at outflow location, excess evap shared 290 IF ( zfwf(jc) <= 0.e0_wp ) THEN 291 DO jn = 1, ncsnr(jc) 292 ji = mi0(ncsir(jc,jn)) 293 jj = mj0(ncsjr(jc,jn)) ! Location of outflow in open ocean 294 IF ( ji > 1 .AND. ji < jpi & 295 .AND. jj > 1 .AND. jj < jpj ) THEN 296 emp (ji,jj) = emp (ji,jj) + zfwf(jc) / ( REAL(ncsnr(jc)) * e1e2t(ji,jj) ) 297 emps(ji,jj) = emps(ji,jj) + zfwf(jc) / ( REAL(ncsnr(jc)) * e1e2t(ji,jj) ) 298 ENDIF 299 END DO 300 ELSE 301 emp (:,:) = emp (:,:) + zfwf(jc) / surf(jpncs+1) 302 emps(:,:) = emps(:,:) + zfwf(jc) / surf(jpncs+1) 303 ! accumulate closed seas correction 304 zcorr = zcorr + zfwf(jc) / surf(jpncs+1) 305 ENDIF 306 ELSEIF( ncstt(jc) == 2 ) THEN ! Excess e-p-r (either sign) goes to open ocean, at outflow location 307 DO jn = 1, ncsnr(jc) 243 308 ji = mi0(ncsir(jc,jn)) 244 309 jj = mj0(ncsjr(jc,jn)) ! Location of outflow in open ocean 245 IF ( ji > 1 .AND. ji < jpi & 246 .AND. jj > 1 .AND. jj < jpj ) THEN 247 emp (ji,jj) = emp (ji,jj) + zfwf(jc) / & 248 (FLOAT(ncsnr(jc)) * e1t(ji,jj) * e2t(ji,jj)) 249 emps(ji,jj) = emps(ji,jj) + zfwf(jc) / & 250 (FLOAT(ncsnr(jc)) * e1t(ji,jj) * e2t(ji,jj)) 251 END IF 252 END DO 253 ELSE 254 emp (:,:) = emp (:,:) + zfwf(jc) / surf(jpncs+1) 255 emps(:,:) = emps(:,:) + zfwf(jc) / surf(jpncs+1) 256 ENDIF 257 ELSEIF( ncstt(jc) == 2 ) THEN 258 ! Excess e-p+r (either sign) goes to open ocean, at outflow location 259 IF( ji > 1 .AND. ji < jpi & 260 .AND. jj > 1 .AND. jj < jpj ) THEN 261 DO jn = 1, ncsnr(jc) 262 ji = mi0(ncsir(jc,jn)) 263 jj = mj0(ncsjr(jc,jn)) ! Location of outflow in open ocean 264 emp (ji,jj) = emp (ji,jj) + zfwf(jc) & 265 / (FLOAT(ncsnr(jc)) * e1t(ji,jj) * e2t(ji,jj) ) 266 emps(ji,jj) = emps(ji,jj) + zfwf(jc) & 267 / (FLOAT(ncsnr(jc)) * e1t(ji,jj) * e2t(ji,jj) ) 268 END DO 310 IF( ji > 1 .AND. ji < jpi & 311 .AND. jj > 1 .AND. jj < jpj ) THEN 312 emp (ji,jj) = emp (ji,jj) + zfwf(jc) / ( REAL(ncsnr(jc)) * e1e2t(ji,jj) ) 313 emps(ji,jj) = emps(ji,jj) + zfwf(jc) / ( REAL(ncsnr(jc)) * e1e2t(ji,jj) ) 314 ENDIF 315 END DO 269 316 ENDIF 270 ENDIF271 !272 DO jj = ncsj1(jc), ncsj2(jc)273 DO ji = ncsi1(jc), ncsi2(jc)274 emp (ji,jj) = emp(ji,jj) - zfwf(jc) / surf(jc)275 emps(ji,jj) = emps(ji,jj) - zfwf(jc) / surf(jc)276 END DO 277 END DO278 !317 ! 318 DO jj = ncsj1(jc), ncsj2(jc) 319 DO ji = ncsi1(jc), ncsi2(jc) 320 emp (ji,jj) = emp (ji,jj) - zfwf(jc) / surf(jc) 321 emps(ji,jj) = emps(ji,jj) - zfwf(jc) / surf(jc) 322 END DO 323 END DO 324 ! 325 END IF 279 326 END DO 280 ! 281 CALL lbc_lnk( emp , 'T', 1. ) 282 CALL lbc_lnk( emps, 'T', 1. ) 327 328 IF ( ABS(zcorr) > rsmall ) THEN ! remove the global correction from the closed seas 329 DO jc = 1, jpncs ! only if it is large enough 330 DO jj = ncsj1(jc), ncsj2(jc) 331 DO ji = ncsi1(jc), ncsi2(jc) 332 emp (ji,jj) = emp (ji,jj) - zcorr 333 emps(ji,jj) = emps(ji,jj) - zcorr 334 END DO 335 END DO 336 END DO 337 ENDIF 338 ! 339 emp (:,:) = emp (:,:) * tmask(:,:,1) 340 emps(:,:) = emps(:,:) * tmask(:,:,1) 341 ! 342 CALL lbc_lnk( emp , 'T', 1._wp ) 343 CALL lbc_lnk( emps, 'T', 1._wp ) 344 ! 345 IF( nn_timing == 1 ) CALL timing_stop('sbc_clo') 283 346 ! 284 347 END SUBROUTINE sbc_clo 285 286 348 349 287 350 SUBROUTINE clo_rnf( p_rnfmsk ) 288 351 !!--------------------------------------------------------------------- … … 308 371 ii = mi0( ncsir(jc,jn) ) 309 372 ij = mj0( ncsjr(jc,jn) ) 310 p_rnfmsk(ii,ij) = MAX( p_rnfmsk(ii,ij), 1.0 )373 p_rnfmsk(ii,ij) = MAX( p_rnfmsk(ii,ij), 1.0_wp ) 311 374 END DO 312 375 ENDIF … … 336 399 DO jj = ncsj1(jc), ncsj2(jc) 337 400 DO ji = ncsi1(jc), ncsi2(jc) 338 p_upsmsk(ji,jj) = 0.5 401 p_upsmsk(ji,jj) = 0.5_wp ! mixed upstream/centered scheme over closed seas 339 402 END DO 340 403 END DO … … 374 437 !!====================================================================== 375 438 END MODULE closea 439
Note: See TracChangeset
for help on using the changeset viewer.
