- Timestamp:
- 2012-11-16T10:58:11+01:00 (12 years ago)
- Location:
- branches/2012/dev_r3327_MERCATOR1_BDY/NEMOGCM/NEMO/OPA_SRC
- Files:
-
- 21 edited
-
BDY/bdyice_lim2.F90 (modified) (1 diff)
-
DIA/diadct.F90 (modified) (5 diffs)
-
DIA/diaptr.F90 (modified) (2 diffs)
-
DIA/diawri.F90 (modified) (2 diffs)
-
DOM/closea.F90 (modified) (9 diffs)
-
DOM/dom_oce.F90 (modified) (1 diff)
-
DOM/domain.F90 (modified) (1 diff)
-
DOM/domzgr.F90 (modified) (3 diffs)
-
DYN/dynhpg.F90 (modified) (16 diffs)
-
IOM/prtctl.F90 (modified) (1 diff)
-
LBC/lib_mpp.F90 (modified) (10 diffs)
-
SBC/sbccpl.F90 (modified) (4 diffs)
-
SBC/sbcmod.F90 (modified) (1 diff)
-
SBC/sbcrnf.F90 (modified) (1 diff)
-
TRA/traldf_iso_grif.F90 (modified) (1 diff)
-
TRD/trdtra.F90 (modified) (1 diff)
-
ZDF/zdfddm.F90 (modified) (1 diff)
-
ZDF/zdftke.F90 (modified) (4 diffs)
-
lib_fortran.F90 (modified) (4 diffs)
-
nemogcm.F90 (modified) (1 diff)
-
timing.F90 (modified) (14 diffs)
Legend:
- Unmodified
- Added
- Removed
-
branches/2012/dev_r3327_MERCATOR1_BDY/NEMOGCM/NEMO/OPA_SRC/BDY/bdyice_lim2.F90
r3294 r3570 53 53 CYCLE 54 54 CASE(jp_frs) 55 CALL bdy_ice_frs( idx_bdy(ib_bdy), dta_ idx(ib_bdy) )55 CALL bdy_ice_frs( idx_bdy(ib_bdy), dta_bdy(ib_bdy) ) 56 56 CASE DEFAULT 57 57 CALL ctl_stop( 'bdy_ice_lim_2 : unrecognised option for open boundaries for ice fields' ) -
branches/2012/dev_r3327_MERCATOR1_BDY/NEMOGCM/NEMO/OPA_SRC/DIA/diadct.F90
r3294 r3570 38 38 USE dianam ! build name of file 39 39 USE lib_mpp ! distributed memory computing library 40 #if defined key_lim2 || defined key_lim3 41 USE ice 40 #if defined key_lim2 41 USE ice_2 42 #endif 43 #if defined key_lim3 44 USE ice_3 42 45 #endif 43 46 USE domvvl … … 362 365 WRITE(numout,*)" List of points in global domain:" 363 366 DO jpt=1,iptglo 364 WRITE(numout,*)' # I J ',jpt,coordtemp(jpt) 367 WRITE(numout,*)' # I J ',jpt,coordtemp(jpt),directemp(jpt) 365 368 ENDDO 366 369 ENDIF … … 403 406 404 407 IF(jsec==nn_secdebug .AND. secs(jsec)%nb_point .NE. 0)THEN 405 WRITE(narea+200,*)'avant secs(jsec)%nb_point iptloc ',secs(jsec)%nb_point,iptloc406 408 DO jpt = 1,iptloc 407 409 iiglo = secs(jsec)%listPoint(jpt)%I + jpizoom - 1 + nimpp - 1 408 410 ijglo = secs(jsec)%listPoint(jpt)%J + jpjzoom - 1 + njmpp - 1 409 WRITE(narea+200,*)'avant # I J : ',iiglo,ijglo410 411 ENDDO 411 412 ENDIF … … 421 422 ENDIF 422 423 IF(jsec==nn_secdebug .AND. secs(jsec)%nb_point .NE. 0)THEN 423 WRITE(narea+200,*)'apres secs(jsec)%nb_point iptloc ',secs(jsec)%nb_point,iptloc424 424 DO jpt = 1,secs(jsec)%nb_point 425 425 iiglo = secs(jsec)%listPoint(jpt)%I + jpizoom - 1 + nimpp - 1 426 426 ijglo = secs(jsec)%listPoint(jpt)%J + jpjzoom - 1 + njmpp - 1 427 WRITE(narea+200,*)'apres # I J : ',iiglo,ijglo428 427 ENDDO 429 428 ENDIF … … 626 625 ELSE ; isgnv = 1 627 626 ENDIF 628 629 IF( ld_debug )write(numout,*)"isgnu isgnv ",isgnu,isgnv 627 IF( sec%slopeSection .GE. 9999. ) isgnv = 1 628 629 IF( ld_debug )write(numout,*)"sec%slopeSection isgnu isgnv ",sec%slopeSection,isgnu,isgnv 630 630 631 631 !--------------------------------------! -
branches/2012/dev_r3327_MERCATOR1_BDY/NEMOGCM/NEMO/OPA_SRC/DIA/diaptr.F90
r3294 r3570 332 332 !!---------------------------------------------------------------------- 333 333 USE oce, vt => ua ! use ua as workspace 334 USE oce, vs => ua ! use ua as workspace334 USE oce, vs => va ! use va as workspace 335 335 IMPLICIT none 336 336 !! … … 378 378 zv = ( vn(ji,jj,jk) + vn(ji,jj-1,jk) ) * 0.5_wp 379 379 #endif 380 vt( :,jj,jk) = zv * tsn(:,jj,jk,jp_tem)381 vs( :,jj,jk) = zv * tsn(:,jj,jk,jp_sal)380 vt(ji,jj,jk) = zv * tsn(ji,jj,jk,jp_tem) 381 vs(ji,jj,jk) = zv * tsn(ji,jj,jk,jp_sal) 382 382 END DO 383 383 END DO -
branches/2012/dev_r3327_MERCATOR1_BDY/NEMOGCM/NEMO/OPA_SRC/DIA/diawri.F90
r3294 r3570 171 171 z3d(:,:,jpk) = 0.e0 172 172 DO jk = 1, jpkm1 173 z3d(:,:,jk) = rau0 * un(:,:,jk) * e 1u(:,:) * fse3u(:,:,jk)173 z3d(:,:,jk) = rau0 * un(:,:,jk) * e2u(:,:) * fse3u(:,:,jk) 174 174 END DO 175 175 CALL iom_put( "u_masstr", z3d ) ! mass transport in i-direction … … 186 186 CALL iom_put( "u_heattr", z2d ) ! heat transport in i-direction 187 187 DO jk = 1, jpkm1 188 z3d(:,:,jk) = rau0 * vn(:,:,jk) * e 2v(:,:) * fse3v(:,:,jk)188 z3d(:,:,jk) = rau0 * vn(:,:,jk) * e1v(:,:) * fse3v(:,:,jk) 189 189 END DO 190 190 CALL iom_put( "v_masstr", z3d ) ! mass transport in j-direction -
branches/2012/dev_r3327_MERCATOR1_BDY/NEMOGCM/NEMO/OPA_SRC/DOM/closea.F90
r2715 r3570 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 ) ! 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 -
branches/2012/dev_r3327_MERCATOR1_BDY/NEMOGCM/NEMO/OPA_SRC/DOM/dom_oce.F90
r3294 r3570 52 52 REAL(wp), PUBLIC :: rdtmax !: maximum time step on tracers 53 53 REAL(wp), PUBLIC :: rdth !: depth variation of tracer step 54 INTEGER , PUBLIC :: nclosea !: =0 suppress closed sea/lake from the ORCA domain or not (=1)55 54 56 55 ! !!! associated variables -
branches/2012/dev_r3327_MERCATOR1_BDY/NEMOGCM/NEMO/OPA_SRC/DOM/domain.F90
r3294 r3570 238 238 rdtmax = rn_rdtmin 239 239 rdth = rn_rdth 240 nclosea = nn_closea241 240 242 241 REWIND( numnam ) ! Namelist cross land advection -
branches/2012/dev_r3327_MERCATOR1_BDY/NEMOGCM/NEMO/OPA_SRC/DOM/domzgr.F90
r3294 r3570 422 422 CALL iom_close( inum ) 423 423 mbathy(:,:) = INT( bathy(:,:) ) 424 ! ! =====================424 ! 425 425 IF( cp_cfg == "orca" .AND. jp_cfg == 2 ) THEN ! ORCA R2 configuration 426 ! ! =====================426 ! 427 427 IF( nn_cla == 0 ) THEN 428 428 ii0 = 140 ; ii1 = 140 ! Gibraltar Strait open … … 454 454 CALL iom_get ( inum, jpdom_data, 'Bathymetry', bathy ) 455 455 CALL iom_close( inum ) 456 ! ! =====================456 ! 457 457 IF( cp_cfg == "orca" .AND. jp_cfg == 2 ) THEN ! ORCA R2 configuration 458 ! ! =====================458 ! 459 459 IF( nn_cla == 0 ) THEN 460 460 ii0 = 140 ; ii1 = 140 ! Gibraltar Strait open … … 489 489 ENDIF 490 490 ! 491 ! ! =========================== ! 492 IF( nclosea == 0 ) THEN ! NO closed seas or lakes ! 493 DO jl = 1, jpncs ! =========================== ! 494 DO jj = ncsj1(jl), ncsj2(jl) 495 DO ji = ncsi1(jl), ncsi2(jl) 496 mbathy(ji,jj) = 0 ! suppress closed seas and lakes from bathymetry 497 bathy (ji,jj) = 0._wp 498 END DO 499 END DO 500 END DO 501 ENDIF 502 ! 503 ! ! =========================== ! 504 ! ! set a minimum depth ! 505 ! ! =========================== ! 506 IF ( .not. ln_sco ) THEN 491 IF( nn_closea == 0 ) CALL clo_bat( bathy, mbathy ) !== NO closed seas or lakes ==! 492 ! 493 IF ( .not. ln_sco ) THEN !== set a minimum depth ==! 507 494 IF( rn_hmin < 0._wp ) THEN ; ik = - INT( rn_hmin ) ! from a nb of level 508 495 ELSE ; ik = MINLOC( gdepw_0, mask = gdepw_0 > rn_hmin, dim = 1 ) ! from a depth -
branches/2012/dev_r3327_MERCATOR1_BDY/NEMOGCM/NEMO/OPA_SRC/DYN/dynhpg.F90
r3294 r3570 678 678 REAL(wp) :: zrhdt1 679 679 REAL(wp) :: zdpdx1, zdpdx2, zdpdy1, zdpdy2 680 INTEGER :: zbhitwe, zbhitns 681 REAL(wp), POINTER, DIMENSION(:,:,:) :: zdeptht, zrhh 680 REAL(wp), POINTER, DIMENSION(:,:,:) :: zdept, zrhh 682 681 REAL(wp), POINTER, DIMENSION(:,:,:) :: zhpi, zu, zv, fsp, xsp, asp, bsp, csp, dsp 683 682 !!---------------------------------------------------------------------- 684 683 ! 685 684 CALL wrk_alloc( jpi,jpj,jpk, zhpi, zu, zv, fsp, xsp, asp, bsp, csp, dsp ) 686 CALL wrk_alloc( jpi,jpj,jpk, zdept ht, zrhh )685 CALL wrk_alloc( jpi,jpj,jpk, zdept, zrhh ) 687 686 ! 688 687 IF( kt == nit000 ) THEN … … 717 716 END DO 718 717 719 ! Transfer the depth of "T(:,:,:)" to vertical coordinate "zdeptht(:,:,:)" 720 DO jj = 1, jpj 721 DO ji = 1, jpi 722 zdeptht(ji,jj,1) = 0.5_wp * fse3w(ji,jj,1) 723 zdeptht(ji,jj,1) = zdeptht(ji,jj,1) - sshn(ji,jj) * znad 724 DO jk = 2, jpk 725 zdeptht(ji,jj,jk) = zdeptht(ji,jj,jk-1) + fse3w(ji,jj,jk) 726 END DO 727 END DO 728 END DO 729 730 DO jk = 1, jpkm1 731 DO jj = 1, jpj 732 DO ji = 1, jpi 733 fsp(ji,jj,jk) = zrhh(ji,jj,jk) 734 xsp(ji,jj,jk) = zdeptht(ji,jj,jk) 735 END DO 736 END DO 737 END DO 718 ! Transfer the depth of "T(:,:,:)" to vertical coordinate "zdept(:,:,:)" 719 DO jj = 1, jpj; DO ji = 1, jpi 720 zdept(ji,jj,1) = 0.5_wp * fse3w(ji,jj,1) - sshn(ji,jj) * znad 721 END DO ; END DO 722 723 DO jk = 2, jpk; DO jj = 1, jpj; DO ji = 1, jpi 724 zdept(ji,jj,jk) = zdept(ji,jj,jk-1) + fse3w(ji,jj,jk) 725 END DO ; END DO ; END DO 726 727 fsp(:,:,:) = zrhh(:,:,:) 728 xsp(:,:,:) = zdept(:,:,:) 738 729 739 730 ! Construct the vertical density profile with the … … 745 736 DO jj = 2, jpj 746 737 DO ji = 2, jpi 747 zrhdt1 = zrhh(ji,jj,1) - interp3(zdept ht(ji,jj,1),asp(ji,jj,1), &738 zrhdt1 = zrhh(ji,jj,1) - interp3(zdept(ji,jj,1),asp(ji,jj,1), & 748 739 bsp(ji,jj,1), csp(ji,jj,1), & 749 dsp(ji,jj,1) ) * 0.5_wp * zdeptht(ji,jj,1) 750 zrhdt1 = MAX(zrhdt1, 1000._wp - rau0) ! no lighter than fresh water 740 dsp(ji,jj,1) ) * 0.25_wp * fse3w(ji,jj,1) 751 741 752 742 ! assuming linear profile across the top half surface layer … … 760 750 DO ji = 2, jpi 761 751 zhpi(ji,jj,jk) = zhpi(ji,jj,jk-1) + & 762 integ 2(zdeptht(ji,jj,jk-1), zdeptht(ji,jj,jk),&752 integ_spline(zdept(ji,jj,jk-1), zdept(ji,jj,jk),& 763 753 asp(ji,jj,jk-1), bsp(ji,jj,jk-1), & 764 754 csp(ji,jj,jk-1), dsp(ji,jj,jk-1)) … … 793 783 END DO 794 784 785 DO jk = 1, jpkm1 786 DO jj = 2, jpjm1 787 DO ji = 2, jpim1 788 zu(ji,jj,jk) = min(zu(ji,jj,jk), max(-zdept(ji,jj,jk), -zdept(ji+1,jj,jk))) 789 zu(ji,jj,jk) = max(zu(ji,jj,jk), min(-zdept(ji,jj,jk), -zdept(ji+1,jj,jk))) 790 zv(ji,jj,jk) = min(zv(ji,jj,jk), max(-zdept(ji,jj,jk), -zdept(ji,jj+1,jk))) 791 zv(ji,jj,jk) = max(zv(ji,jj,jk), min(-zdept(ji,jj,jk), -zdept(ji,jj+1,jk))) 792 END DO 793 END DO 794 END DO 795 796 795 797 DO jk = 1, jpkm1 796 798 DO jj = 2, jpjm1 … … 803 805 !!!!! for u equation 804 806 IF( jk <= mbku(ji,jj) ) THEN 805 IF( -zdept ht(ji+1,jj,mbku(ji,jj)) >= -zdeptht(ji,jj,mbku(ji,jj)) ) THEN807 IF( -zdept(ji+1,jj,jk) >= -zdept(ji,jj,jk) ) THEN 806 808 jis = ji + 1; jid = ji 807 809 ELSE … … 811 813 ! integrate the pressure on the shallow side 812 814 jk1 = jk 813 zbhitwe = 0 814 DO WHILE ( -zdeptht(jis,jj,jk1) > zuijk ) 815 DO WHILE ( -zdept(jis,jj,jk1) > zuijk ) 815 816 IF( jk1 == mbku(ji,jj) ) THEN 816 z bhitwe = 1817 zuijk = -zdept(jis,jj,jk1) 817 818 EXIT 818 819 ENDIF 819 zdeps = MIN(zdept ht(jis,jj,jk1+1), -zuijk)820 zdeps = MIN(zdept(jis,jj,jk1+1), -zuijk) 820 821 zpwes = zpwes + & 821 integ 2(zdeptht(jis,jj,jk1), zdeps, &822 integ_spline(zdept(jis,jj,jk1), zdeps, & 822 823 asp(jis,jj,jk1), bsp(jis,jj,jk1), & 823 824 csp(jis,jj,jk1), dsp(jis,jj,jk1)) … … 825 826 END DO 826 827 827 IF(zbhitwe == 1) THEN828 zuijk = -zdeptht(jis,jj,jk1)829 ENDIF830 831 828 ! integrate the pressure on the deep side 832 829 jk1 = jk 833 zbhitwe = 0 834 DO WHILE ( -zdeptht(jid,jj,jk1) < zuijk ) 830 DO WHILE ( -zdept(jid,jj,jk1) < zuijk ) 835 831 IF( jk1 == 1 ) THEN 836 zbhitwe = 1 832 zdeps = zdept(jid,jj,1) + MIN(zuijk, sshn(jid,jj)*znad) 833 zrhdt1 = zrhh(jid,jj,1) - interp3(zdept(jid,jj,1), asp(jid,jj,1), & 834 bsp(jid,jj,1), csp(jid,jj,1), & 835 dsp(jid,jj,1)) * zdeps 836 zpwed = zpwed + 0.5_wp * (zrhh(jid,jj,1) + zrhdt1) * zdeps 837 837 EXIT 838 838 ENDIF 839 zdeps = MAX(zdept ht(jid,jj,jk1-1), -zuijk)839 zdeps = MAX(zdept(jid,jj,jk1-1), -zuijk) 840 840 zpwed = zpwed + & 841 integ 2(zdeps, zdeptht(jid,jj,jk1), &841 integ_spline(zdeps, zdept(jid,jj,jk1), & 842 842 asp(jid,jj,jk1-1), bsp(jid,jj,jk1-1), & 843 843 csp(jid,jj,jk1-1), dsp(jid,jj,jk1-1) ) … … 845 845 END DO 846 846 847 IF( zbhitwe == 1 ) THEN848 zdeps = zdeptht(jid,jj,1) + MIN(zuijk, sshn(jid,jj)*znad)849 zrhdt1 = zrhh(jid,jj,1) - interp3(zdeptht(jid,jj,1), asp(jid,jj,1), &850 bsp(jid,jj,1), csp(jid,jj,1), &851 dsp(jid,jj,1)) * zdeps852 zrhdt1 = MAX(zrhdt1, 1000._wp - rau0) ! no lighter than fresh water853 zpwed = zpwed + 0.5_wp * (zrhh(jid,jj,1) + zrhdt1) * zdeps854 ENDIF855 856 847 ! update the momentum trends in u direction 857 848 … … 870 861 !!!!! for v equation 871 862 IF( jk <= mbkv(ji,jj) ) THEN 872 IF( -zdept ht(ji,jj+1,mbkv(ji,jj)) >= -zdeptht(ji,jj,mbkv(ji,jj)) ) THEN863 IF( -zdept(ji,jj+1,jk) >= -zdept(ji,jj,jk) ) THEN 873 864 jjs = jj + 1; jjd = jj 874 865 ELSE … … 878 869 ! integrate the pressure on the shallow side 879 870 jk1 = jk 880 zbhitns = 0 881 DO WHILE ( -zdeptht(ji,jjs,jk1) > zvijk ) 871 DO WHILE ( -zdept(ji,jjs,jk1) > zvijk ) 882 872 IF( jk1 == mbkv(ji,jj) ) THEN 883 z bhitns = 1873 zvijk = -zdept(ji,jjs,jk1) 884 874 EXIT 885 875 ENDIF 886 zdeps = MIN(zdept ht(ji,jjs,jk1+1), -zvijk)876 zdeps = MIN(zdept(ji,jjs,jk1+1), -zvijk) 887 877 zpnss = zpnss + & 888 integ 2(zdeptht(ji,jjs,jk1), zdeps, &878 integ_spline(zdept(ji,jjs,jk1), zdeps, & 889 879 asp(ji,jjs,jk1), bsp(ji,jjs,jk1), & 890 880 csp(ji,jjs,jk1), dsp(ji,jjs,jk1) ) … … 892 882 END DO 893 883 894 IF(zbhitns == 1) THEN895 zvijk = -zdeptht(ji,jjs,jk1)896 ENDIF897 898 884 ! integrate the pressure on the deep side 899 885 jk1 = jk 900 zbhitns = 0 901 DO WHILE ( -zdeptht(ji,jjd,jk1) < zvijk ) 886 DO WHILE ( -zdept(ji,jjd,jk1) < zvijk ) 902 887 IF( jk1 == 1 ) THEN 903 zbhitns = 1 888 zdeps = zdept(ji,jjd,1) + MIN(zvijk, sshn(ji,jjd)*znad) 889 zrhdt1 = zrhh(ji,jjd,1) - interp3(zdept(ji,jjd,1), asp(ji,jjd,1), & 890 bsp(ji,jjd,1), csp(ji,jjd,1), & 891 dsp(ji,jjd,1) ) * zdeps 892 zpnsd = zpnsd + 0.5_wp * (zrhh(ji,jjd,1) + zrhdt1) * zdeps 904 893 EXIT 905 894 ENDIF 906 zdeps = MAX(zdept ht(ji,jjd,jk1-1), -zvijk)895 zdeps = MAX(zdept(ji,jjd,jk1-1), -zvijk) 907 896 zpnsd = zpnsd + & 908 integ 2(zdeps, zdeptht(ji,jjd,jk1), &897 integ_spline(zdeps, zdept(ji,jjd,jk1), & 909 898 asp(ji,jjd,jk1-1), bsp(ji,jjd,jk1-1), & 910 899 csp(ji,jjd,jk1-1), dsp(ji,jjd,jk1-1) ) … … 912 901 END DO 913 902 914 IF( zbhitns == 1 ) THEN915 zdeps = zdeptht(ji,jjd,1) + MIN(zvijk, sshn(ji,jjd)*znad)916 zrhdt1 = zrhh(ji,jjd,1) - interp3(zdeptht(ji,jjd,1), asp(ji,jjd,1), &917 bsp(ji,jjd,1), csp(ji,jjd,1), &918 dsp(ji,jjd,1) ) * zdeps919 zrhdt1 = MAX(zrhdt1, 1000._wp - rau0) ! no lighter than fresh water920 zpnsd = zpnsd + 0.5_wp * (zrhh(ji,jjd,1) + zrhdt1) * zdeps921 ENDIF922 903 923 904 ! update the momentum trends in v direction … … 941 922 ! 942 923 CALL wrk_dealloc( jpi,jpj,jpk, zhpi, zu, zv, fsp, xsp, asp, bsp, csp, dsp ) 943 CALL wrk_dealloc( jpi,jpj,jpk, zdept ht, zrhh )924 CALL wrk_dealloc( jpi,jpj,jpk, zdept, zrhh ) 944 925 ! 945 926 END SUBROUTINE hpg_prj … … 1121 1102 1122 1103 1123 FUNCTION integ 2(xl, xr, a, b, c, d) RESULT(f)1104 FUNCTION integ_spline(xl, xr, a, b, c, d) RESULT(f) 1124 1105 !!---------------------------------------------------------------------- 1125 1106 !! *** ROUTINE interp1 *** … … 1143 1124 & xl * ( a + xl * ( za1 + xl * ( za2 + za3 * xl ) ) ) 1144 1125 1145 END FUNCTION integ 21126 END FUNCTION integ_spline 1146 1127 1147 1128 1148 1129 !!====================================================================== 1149 1130 END MODULE dynhpg 1131 -
branches/2012/dev_r3327_MERCATOR1_BDY/NEMOGCM/NEMO/OPA_SRC/IOM/prtctl.F90
r3294 r3570 118 118 IF( PRESENT(tab2d_1) ) ztab2d_1(:,:) = tab2d_1(:,:) 119 119 IF( PRESENT(tab2d_2) ) ztab2d_2(:,:) = tab2d_2(:,:) 120 IF( PRESENT(tab3d_1) ) ztab3d_1(:,:,1:kdir) = tab3d_1(:,:, :)121 IF( PRESENT(tab3d_2) ) ztab3d_2(:,:,1:kdir) = tab3d_2(:,:, :)120 IF( PRESENT(tab3d_1) ) ztab3d_1(:,:,1:kdir) = tab3d_1(:,:,1:kdir) 121 IF( PRESENT(tab3d_2) ) ztab3d_2(:,:,1:kdir) = tab3d_2(:,:,1:kdir) 122 122 IF( PRESENT(mask1) ) zmask1 (:,:,:) = mask1 (:,:,:) 123 123 IF( PRESENT(mask2) ) zmask2 (:,:,:) = mask2 (:,:,:) -
branches/2012/dev_r3327_MERCATOR1_BDY/NEMOGCM/NEMO/OPA_SRC/LBC/lib_mpp.F90
r3294 r3570 80 80 END INTERFACE 81 81 INTERFACE mpp_sum 82 # if defined key_mpp_rep83 82 MODULE PROCEDURE mppsum_a_int, mppsum_int, mppsum_a_real, mppsum_real, & 84 83 mppsum_realdd, mppsum_a_realdd 85 # else86 MODULE PROCEDURE mppsum_a_int, mppsum_int, mppsum_a_real, mppsum_real87 # endif88 84 END INTERFACE 89 85 INTERFACE mpp_lbc_north … … 114 110 !$AGRIF_END_DO_NOT_TREAT 115 111 116 # if defined key_mpp_rep117 112 INTEGER :: MPI_SUMDD 118 # endif119 113 120 114 ! variables used in case of sea-ice 121 INTEGER, PUBLIC :: ncomm_ice !: communicator made by the processors with sea-ice 115 INTEGER, PUBLIC :: ncomm_ice !: communicator made by the processors with sea-ice (public so that it can be freed in limthd) 116 INTEGER :: ngrp_iworld ! group ID for the world processors (for rheology) 122 117 INTEGER :: ngrp_ice ! group ID for the ice processors (for rheology) 123 118 INTEGER :: ndim_rank_ice ! number of 'ice' processors … … 355 350 mynode = mpprank 356 351 ! 357 #if defined key_mpp_rep358 352 CALL MPI_OP_CREATE(DDPDD_MPI, .TRUE., MPI_SUMDD, ierr) 359 #endif360 353 ! 361 354 END FUNCTION mynode … … 1506 1499 END SUBROUTINE mppsum_real 1507 1500 1508 # if defined key_mpp_rep1509 1501 SUBROUTINE mppsum_realdd( ytab, kcom ) 1510 1502 !!---------------------------------------------------------------------- … … 1559 1551 1560 1552 END SUBROUTINE mppsum_a_realdd 1561 # endif1562 1553 1563 1554 SUBROUTINE mpp_minloc2d( ptab, pmask, pmin, ki,kj ) … … 1977 1968 !! ndim_rank_ice = number of processors with ice 1978 1969 !! nrank_ice (ndim_rank_ice) = ice processors 1979 !! ngrp_ world = group ID for the world processors1970 !! ngrp_iworld = group ID for the world processors 1980 1971 !! ngrp_ice = group ID for the ice processors 1981 1972 !! ncomm_ice = communicator for the ice procs. … … 2026 2017 2027 2018 ! Create the world group 2028 CALL MPI_COMM_GROUP( mpi_comm_opa, ngrp_ world, ierr )2019 CALL MPI_COMM_GROUP( mpi_comm_opa, ngrp_iworld, ierr ) 2029 2020 2030 2021 ! Create the ice group from the world group 2031 CALL MPI_GROUP_INCL( ngrp_ world, ndim_rank_ice, nrank_ice, ngrp_ice, ierr )2022 CALL MPI_GROUP_INCL( ngrp_iworld, ndim_rank_ice, nrank_ice, ngrp_ice, ierr ) 2032 2023 2033 2024 ! Create the ice communicator , ie the pool of procs with sea-ice … … 2036 2027 ! Find proc number in the world of proc 0 in the north 2037 2028 ! The following line seems to be useless, we just comment & keep it as reminder 2038 ! CALL MPI_GROUP_TRANSLATE_RANKS(ngrp_ice,1,0,ngrp_world,n_ice_root,ierr) 2039 ! 2029 ! CALL MPI_GROUP_TRANSLATE_RANKS(ngrp_ice,1,0,ngrp_iworld,n_ice_root,ierr) 2030 ! 2031 CALL MPI_GROUP_FREE(ngrp_ice, ierr) 2032 CALL MPI_GROUP_FREE(ngrp_iworld, ierr) 2033 2040 2034 DEALLOCATE(kice, zwork) 2041 2035 ! … … 2599 2593 END SUBROUTINE mpi_init_opa 2600 2594 2601 #if defined key_mpp_rep2602 2595 SUBROUTINE DDPDD_MPI (ydda, yddb, ilen, itype) 2603 2596 !!--------------------------------------------------------------------- … … 2628 2621 2629 2622 END SUBROUTINE DDPDD_MPI 2630 #endif2631 2623 2632 2624 #else -
branches/2012/dev_r3327_MERCATOR1_BDY/NEMOGCM/NEMO/OPA_SRC/SBC/sbccpl.F90
r3294 r3570 721 721 ! ! (geographical to local grid -> rotate the components) 722 722 CALL rot_rep( frcv(jpr_otx1)%z3(:,:,1), frcv(jpr_oty1)%z3(:,:,1), srcv(jpr_otx1)%clgrid, 'en->i', ztx ) 723 frcv(jpr_otx1)%z3(:,:,1) = ztx(:,:) ! overwrite 1st component on the 1st grid724 723 IF( srcv(jpr_otx2)%laction ) THEN 725 724 CALL rot_rep( frcv(jpr_otx2)%z3(:,:,1), frcv(jpr_oty2)%z3(:,:,1), srcv(jpr_otx2)%clgrid, 'en->j', zty ) … … 727 726 CALL rot_rep( frcv(jpr_otx1)%z3(:,:,1), frcv(jpr_oty1)%z3(:,:,1), srcv(jpr_otx1)%clgrid, 'en->j', zty ) 728 727 ENDIF 728 frcv(jpr_otx1)%z3(:,:,1) = ztx(:,:) ! overwrite 1st component on the 1st grid 729 729 frcv(jpr_oty1)%z3(:,:,1) = zty(:,:) ! overwrite 2nd component on the 2nd grid 730 730 ENDIF … … 949 949 ! ! (geographical to local grid -> rotate the components) 950 950 CALL rot_rep( frcv(jpr_itx1)%z3(:,:,1), frcv(jpr_ity1)%z3(:,:,1), srcv(jpr_itx1)%clgrid, 'en->i', ztx ) 951 frcv(jpr_itx1)%z3(:,:,1) = ztx(:,:) ! overwrite 1st component on the 1st grid952 951 IF( srcv(jpr_itx2)%laction ) THEN 953 952 CALL rot_rep( frcv(jpr_itx2)%z3(:,:,1), frcv(jpr_ity2)%z3(:,:,1), srcv(jpr_itx2)%clgrid, 'en->j', zty ) … … 955 954 CALL rot_rep( frcv(jpr_itx1)%z3(:,:,1), frcv(jpr_ity1)%z3(:,:,1), srcv(jpr_itx1)%clgrid, 'en->j', zty ) 956 955 ENDIF 956 frcv(jpr_itx1)%z3(:,:,1) = ztx(:,:) ! overwrite 1st component on the 1st grid 957 957 frcv(jpr_ity1)%z3(:,:,1) = zty(:,:) ! overwrite 2nd component on the 1st grid 958 958 ENDIF -
branches/2012/dev_r3327_MERCATOR1_BDY/NEMOGCM/NEMO/OPA_SRC/SBC/sbcmod.F90
r3294 r3570 272 272 ! !== Misc. Options ==! 273 273 274 SELECT CASE( nn_ice ) ! Update heat and freshwater fluxes over sea-ice areas 275 CASE( 1 ) ; CALL sbc_ice_if ( kt ) ! Ice-cover climatology ("Ice-if" model) 276 ! 277 CASE( 2 ) ; CALL sbc_ice_lim_2( kt, nsbc ) ! LIM-2 ice model 278 IF( lk_bdy ) CALL bdy_ice_lim_2( kt ) ! BDY boundary condition 279 ! 280 CASE( 3 ) ; CALL sbc_ice_lim ( kt, nsbc ) ! LIM-3 ice model 281 ! 282 CASE( 4 ) ; CALL sbc_ice_cice ( kt, nsbc ) ! CICE ice model 274 SELECT CASE( nn_ice ) ! Update heat and freshwater fluxes over sea-ice areas 275 CASE( 1 ) ; CALL sbc_ice_if ( kt ) ! Ice-cover climatology ("Ice-if" model) 276 CASE( 2 ) ; CALL sbc_ice_lim_2( kt, nsbc ) ! LIM-2 ice model 277 IF( lk_bdy ) CALL bdy_ice_lim_2( kt ) ! BDY boundary condition 278 CASE( 3 ) ; CALL sbc_ice_lim ( kt, nsbc ) ! LIM-3 ice model 279 CASE( 4 ) ; CALL sbc_ice_cice ( kt, nsbc ) ! CICE ice model 283 280 END SELECT 284 281 285 IF( ln_rnf ) CALL sbc_rnf( kt ) ! add runoffs to fresh water fluxes282 IF( ln_rnf ) CALL sbc_rnf( kt ) ! add runoffs to fresh water fluxes 286 283 287 IF( ln_ssr ) CALL sbc_ssr( kt ) ! add SST/SSS damping term288 289 IF( nn_fwb /= 0 ) CALL sbc_fwb( kt, nn_fwb, nn_fsbc ) ! control the freshwater budget290 291 IF( n closea == 1 ) CALL sbc_clo( kt ) ! treatment of closed sea in the model domain292 ! ! (update freshwater fluxes)284 IF( ln_ssr ) CALL sbc_ssr( kt ) ! add SST/SSS damping term 285 286 IF( nn_fwb /= 0 ) CALL sbc_fwb( kt, nn_fwb, nn_fsbc ) ! control the freshwater budget 287 288 IF( nn_closea == 1 ) CALL sbc_clo( kt ) ! treatment of closed sea in the model domain 289 ! ! (update freshwater fluxes) 293 290 !RBbug do not understand why see ticket 667 294 291 CALL lbc_lnk( emp, 'T', 1. ) -
branches/2012/dev_r3327_MERCATOR1_BDY/NEMOGCM/NEMO/OPA_SRC/SBC/sbcrnf.F90
r3294 r3570 457 457 CALL iom_close( inum ) ! close file 458 458 459 IF( n closea == 1 ) CALL clo_rnf( rnfmsk )! closed sea inflow set as ruver mouth460 461 rnfmsk_z(:) = 0._wp 459 IF( nn_closea == 1 ) CALL clo_rnf( rnfmsk ) ! closed sea inflow set as ruver mouth 460 461 rnfmsk_z(:) = 0._wp ! vertical structure 462 462 rnfmsk_z(1) = 1.0 463 463 rnfmsk_z(2) = 1.0 ! ********** -
branches/2012/dev_r3327_MERCATOR1_BDY/NEMOGCM/NEMO/OPA_SRC/TRA/traldf_iso_grif.F90
r3294 r3570 225 225 DO jj = 2, jpjm1 226 226 DO ji = fs_2, fs_jpim1 ! vector opt. 227 zw3d(ji,jj,jk) = (psiy_eiv(ji,jj,jk) - psiy_eiv(ji,jj-1,jk))/e2 v(ji,jj) + &228 & (psix_eiv(ji,jj,jk) - psix_eiv(ji-1,jj,jk))/e1 u(ji,jj) ! w_eiv = dpsiy/dy + dpsiy/dx227 zw3d(ji,jj,jk) = (psiy_eiv(ji,jj,jk) - psiy_eiv(ji,jj-1,jk))/e2t(ji,jj) + & 228 & (psix_eiv(ji,jj,jk) - psix_eiv(ji-1,jj,jk))/e1t(ji,jj) ! w_eiv = dpsiy/dy + dpsiy/dx 229 229 END DO 230 230 END DO -
branches/2012/dev_r3327_MERCATOR1_BDY/NEMOGCM/NEMO/OPA_SRC/TRD/trdtra.F90
r3294 r3570 8 8 !! 3.3 ! 2010-06 (C. Ethe) merge TRA-TRC 9 9 !!---------------------------------------------------------------------- 10 #if defined key_trdtra || defined key_trd mld || defined key_trdmld_trc10 #if defined key_trdtra || defined key_trdtrc || defined key_trdmld || defined key_trdmld_trc 11 11 !!---------------------------------------------------------------------- 12 12 !! trd_tra : Call the trend to be computed -
branches/2012/dev_r3327_MERCATOR1_BDY/NEMOGCM/NEMO/OPA_SRC/ZDF/zdfddm.F90
r3294 r3570 227 227 ENDIF 228 228 ! 229 ! ! allocate zdfddm arrays229 ! ! allocate zdfddm arrays 230 230 IF( zdf_ddm_alloc() /= 0 ) CALL ctl_stop( 'STOP', 'zdf_ddm_init : unable to allocate arrays' ) 231 ! ! initialization to masked Kz 232 avs(:,:,:) = rn_avt0 * tmask(:,:,:) 231 233 ! 232 234 END SUBROUTINE zdf_ddm_init -
branches/2012/dev_r3327_MERCATOR1_BDY/NEMOGCM/NEMO/OPA_SRC/ZDF/zdftke.F90
r3294 r3570 87 87 REAL(wp) , ALLOCATABLE, SAVE, DIMENSION(:,:) :: htau ! depth of tke penetration (nn_htau) 88 88 REAL(wp) , ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: dissl ! now mixing lenght of dissipation 89 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: avt_k , avm_k ! not enhanced Kz 90 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: avmu_k, avmv_k ! not enhanced Kz 89 91 #if defined key_c1d 90 92 ! !!** 1D cfg only ** ('key_c1d') … … 112 114 & e_pdl(jpi,jpj,jpk) , e_ric(jpi,jpj,jpk) , & 113 115 #endif 114 & en (jpi,jpj,jpk) , htau (jpi,jpj) , dissl(jpi,jpj,jpk) , STAT= zdf_tke_alloc ) 116 & en (jpi,jpj,jpk) , htau (jpi,jpj) , dissl(jpi,jpj,jpk) , & 117 & avt_k (jpi,jpj,jpk) , avm_k (jpi,jpj,jpk), & 118 & avmu_k(jpi,jpj,jpk) , avmv_k(jpi,jpj,jpk), STAT= zdf_tke_alloc ) 115 119 ! 116 120 IF( lk_mpp ) CALL mpp_sum ( zdf_tke_alloc ) … … 168 172 !!---------------------------------------------------------------------- 169 173 ! 174 IF( kt /= nit000 ) THEN ! restore before value to compute tke 175 avt (:,:,:) = avt_k (:,:,:) 176 avm (:,:,:) = avm_k (:,:,:) 177 avmu(:,:,:) = avmu_k(:,:,:) 178 avmv(:,:,:) = avmv_k(:,:,:) 179 ENDIF 180 ! 170 181 CALL tke_tke ! now tke (en) 171 182 ! 172 183 CALL tke_avn ! now avt, avm, avmu, avmv 184 ! 185 avt_k (:,:,:) = avt (:,:,:) 186 avm_k (:,:,:) = avm (:,:,:) 187 avmu_k(:,:,:) = avmu(:,:,:) 188 avmv_k(:,:,:) = avmv(:,:,:) 173 189 ! 174 190 END SUBROUTINE zdf_tke … … 811 827 ! ! ------------------- 812 828 IF(lwp) WRITE(numout,*) '---- tke-rst ----' 813 CALL iom_rstput( kt, nitrst, numrow, 'en' , en )814 CALL iom_rstput( kt, nitrst, numrow, 'avt' , avt 815 CALL iom_rstput( kt, nitrst, numrow, 'avm' , avm 816 CALL iom_rstput( kt, nitrst, numrow, 'avmu' , avmu 817 CALL iom_rstput( kt, nitrst, numrow, 'avmv' , avmv 818 CALL iom_rstput( kt, nitrst, numrow, 'dissl', dissl )829 CALL iom_rstput( kt, nitrst, numrow, 'en' , en ) 830 CALL iom_rstput( kt, nitrst, numrow, 'avt' , avt_k ) 831 CALL iom_rstput( kt, nitrst, numrow, 'avm' , avm_k ) 832 CALL iom_rstput( kt, nitrst, numrow, 'avmu' , avmu_k ) 833 CALL iom_rstput( kt, nitrst, numrow, 'avmv' , avmv_k ) 834 CALL iom_rstput( kt, nitrst, numrow, 'dissl', dissl ) 819 835 ! 820 836 ENDIF -
branches/2012/dev_r3327_MERCATOR1_BDY/NEMOGCM/NEMO/OPA_SRC/lib_fortran.F90
r3294 r3570 14 14 !! of intrinsinc sign function 15 15 !!---------------------------------------------------------------------- 16 USE par_oce 17 USE lib_mpp ! distributed memory computing18 USE dom_oce ! ocean domain19 USE in_out_manager ! I/O manager16 USE par_oce ! Ocean parameter 17 USE dom_oce ! ocean domain 18 USE in_out_manager ! I/O manager 19 USE lib_mpp ! distributed memory computing 20 20 21 21 IMPLICIT NONE 22 22 PRIVATE 23 23 24 PUBLIC glob_sum 24 PUBLIC glob_sum ! used in many places 25 PUBLIC DDPDD ! also used in closea module 25 26 #if defined key_nosignedzero 26 27 PUBLIC SIGN … … 47 48 48 49 #if ! defined key_mpp_rep 50 49 51 FUNCTION glob_sum_2d( ptab ) 50 52 !!----------------------------------------------------------------------- … … 246 248 END FUNCTION glob_sum_3d_a 247 249 250 #endif 248 251 249 252 SUBROUTINE DDPDD( ydda, yddb ) … … 280 283 ! 281 284 END SUBROUTINE DDPDD 282 #endif283 285 284 286 #if defined key_nosignedzero -
branches/2012/dev_r3327_MERCATOR1_BDY/NEMOGCM/NEMO/OPA_SRC/nemogcm.F90
r3490 r3570 413 413 WRITE(numout,*) ' number of proc. following j nn_jsplt = ', nn_jsplt 414 414 WRITE(numout,*) ' benchmark parameter (0/1) nn_bench = ', nn_bench 415 WRITE(numout,*) ' timing activated (0/1) nn_timing = ', nn_timing 415 416 ENDIF 416 417 ! -
branches/2012/dev_r3327_MERCATOR1_BDY/NEMOGCM/NEMO/OPA_SRC/timing.F90
r3294 r3570 76 76 LOGICAL :: ln_onefile = .TRUE. 77 77 LOGICAL :: lwriter 78 79 78 !!---------------------------------------------------------------------- 80 79 !! NEMO/OPA 4.0 , NEMO Consortium (2011) … … 322 321 IF( lwriter ) WRITE(numtime,*) 'Total timing (sum) :' 323 322 IF( lwriter ) WRITE(numtime,*) '--------------------' 324 IF( lwriter ) WRITE(numtime, *) 'Elapsed Time (s) ','CPU Time (s)'325 IF( lwriter ) WRITE(numtime,'(5x,f12.3, 2x,f12.3)') tot_etime, tot_ctime323 IF( lwriter ) WRITE(numtime,"('Elapsed Time (s) CPU Time (s)')") 324 IF( lwriter ) WRITE(numtime,'(5x,f12.3,1x,f12.3)') tot_etime, tot_ctime 326 325 IF( lwriter ) WRITE(numtime,*) 327 326 #if defined key_mpp_mpi … … 406 405 TYPE(timer), POINTER :: sl_timer_ave => NULL() 407 406 INTEGER :: icode 407 INTEGER :: ierr 408 408 LOGICAL :: ll_ord 409 409 CHARACTER(len=200) :: clfmt 410 410 411 411 ! Initialised the global strucutre 412 ALLOCATE(sl_timer_glob_root) 413 ALLOCATE(sl_timer_glob_root%cname (jpnij)) 414 ALLOCATE(sl_timer_glob_root%tsum_cpu (jpnij)) 415 ALLOCATE(sl_timer_glob_root%tsum_clock(jpnij)) 416 ALLOCATE(sl_timer_glob_root%niter (jpnij)) 412 ALLOCATE(sl_timer_glob_root, Stat=ierr) 413 IF(ierr /= 0)THEN 414 WRITE(numtime,*) 'Failed to allocate global timing structure in waver_info' 415 RETURN 416 END IF 417 418 ALLOCATE(sl_timer_glob_root%cname (jpnij), & 419 sl_timer_glob_root%tsum_cpu (jpnij), & 420 sl_timer_glob_root%tsum_clock(jpnij), & 421 sl_timer_glob_root%niter (jpnij), Stat=ierr) 422 IF(ierr /= 0)THEN 423 WRITE(numtime,*) 'Failed to allocate global timing structure in waver_info' 424 RETURN 425 END IF 417 426 sl_timer_glob_root%cname(:) = '' 418 427 sl_timer_glob_root%tsum_cpu(:) = 0._wp … … 421 430 sl_timer_glob_root%next => NULL() 422 431 sl_timer_glob_root%prev => NULL() 423 ALLOCATE(sl_timer_glob) 424 ALLOCATE(sl_timer_glob%cname (jpnij)) 425 ALLOCATE(sl_timer_glob%tsum_cpu (jpnij)) 426 ALLOCATE(sl_timer_glob%tsum_clock(jpnij)) 427 ALLOCATE(sl_timer_glob%niter (jpnij)) 432 !ARPDBG - don't need to allocate a pointer that's immediately then 433 ! set to point to some other object. 434 !ALLOCATE(sl_timer_glob) 435 !ALLOCATE(sl_timer_glob%cname (jpnij)) 436 !ALLOCATE(sl_timer_glob%tsum_cpu (jpnij)) 437 !ALLOCATE(sl_timer_glob%tsum_clock(jpnij)) 438 !ALLOCATE(sl_timer_glob%niter (jpnij)) 428 439 sl_timer_glob => sl_timer_glob_root 429 440 ! … … 451 462 sl_timer_ave => sl_timer_ave_root 452 463 ENDIF 453 464 454 465 ! Gather info from all processors 455 466 s_timer => s_timer_root … … 467 478 sl_timer_glob%niter, 1, MPI_INTEGER, & 468 479 0, MPI_COMM_OPA, icode) 480 469 481 IF( narea == 1 .AND. ASSOCIATED(s_timer%next) ) THEN 470 482 ALLOCATE(sl_timer_glob%next) … … 479 491 s_timer => s_timer%next 480 492 END DO 493 494 WRITE(*,*) 'ARPDBG: timing: done gathers' 481 495 482 496 IF( narea == 1 ) THEN … … 500 514 ENDIF 501 515 sl_timer_glob => sl_timer_glob%next 502 END DO 516 END DO 517 518 WRITE(*,*) 'ARPDBG: timing: done computing stats' 503 519 504 ! reorder the ave arged list by CPU time520 ! reorder the averaged list by CPU time 505 521 s_wrk => NULL() 506 522 sl_timer_ave => sl_timer_ave_root … … 509 525 sl_timer_ave => sl_timer_ave_root 510 526 DO WHILE( ASSOCIATED( sl_timer_ave%next ) ) 511 IF( .NOT. ASSOCIATED(sl_timer_ave%next) ) EXIT 527 528 IF( .NOT. ASSOCIATED(sl_timer_ave%next) ) EXIT 529 512 530 IF ( sl_timer_ave%tsum_clock < sl_timer_ave%next%tsum_clock ) THEN 513 531 ALLOCATE(s_wrk) 532 ! Copy data into the new object pointed to by s_wrk 514 533 s_wrk = sl_timer_ave%next 534 ! Insert this new timer object before our current position 515 535 CALL insert (sl_timer_ave, sl_timer_ave_root, s_wrk) 536 ! Remove the old object from the list 516 537 CALL suppress(sl_timer_ave%next) 517 538 ll_ord = .FALSE. 518 539 CYCLE 519 540 ENDIF 520 IF( ASSOCIATED(sl_timer_ave%next) ) sl_timer_ave => sl_timer_ave%next541 IF( ASSOCIATED(sl_timer_ave%next) ) sl_timer_ave => sl_timer_ave%next 521 542 END DO 522 IF( ll_ord ) EXIT543 IF( ll_ord ) EXIT 523 544 END DO 524 545 525 546 ! write averaged info 526 WRITE(numtime,*) 'Averaged timing on all processors :' 527 WRITE(numtime,*) '-----------------------------------' 528 WRITE(numtime,*) 'Section ', & 529 & 'Elapsed Time (s) ','Elapsed Time (%) ', & 530 & 'CPU Time(s) ','CPU Time (%) ','CPU/Elapsed ', & 531 & 'Max Elapsed (%) ','Min elapsed (%) ', & 532 & 'Frequency' 547 WRITE(numtime,"('Averaged timing on all processors :')") 548 WRITE(numtime,"('-----------------------------------')") 549 WRITE(numtime,"('Section',13x,'Elap. Time(s)',2x,'Elap. Time(%)',2x, & 550 & 'CPU Time(s)',2x,'CPU Time(%)',2x,'CPU/Elap',1x, & 551 & 'Max elap(%)',2x,'Min elap(%)',2x, & 552 & 'Freq')") 533 553 sl_timer_ave => sl_timer_ave_root 534 clfmt = '( 1x,a,4x,f12.3,6x,f12.3,x,f12.3,2x,f12.3,6x,f7.3,5x,f12.3,5x,f12.3,2x,f9.2)'554 clfmt = '((A),E15.7,2x,f6.2,5x,f12.2,5x,f6.2,5x,f7.2,2x,f12.2,4x,f6.2,2x,f9.2)' 535 555 DO WHILE ( ASSOCIATED(sl_timer_ave) ) 536 WRITE(numtime,TRIM(clfmt)) sl_timer_ave%cname , &556 WRITE(numtime,TRIM(clfmt)) sl_timer_ave%cname(1:18), & 537 557 & sl_timer_ave%tsum_clock,sl_timer_ave%tsum_clock*100.*jpnij/tot_etime, & 538 558 & sl_timer_ave%tsum_cpu ,sl_timer_ave%tsum_cpu*100.*jpnij/tot_ctime , & … … 712 732 !!---------------------------------------------------------------------- 713 733 l_initdone = .TRUE. 714 IF(lwp) WRITE(numout,*)715 IF(lwp) WRITE(numout,*) 'timing_reset : instrumented routines for timing'716 IF(lwp) WRITE(numout,*) '~~~~~~~~~~~~'717 CALL timing_list(s_timer_root)718 WRITE(numout,*)734 ! IF(lwp) WRITE(numout,*) 735 ! IF(lwp) WRITE(numout,*) 'timing_reset : instrumented routines for timing' 736 ! IF(lwp) WRITE(numout,*) '~~~~~~~~~~~~' 737 ! CALL timing_list(s_timer_root) 738 ! WRITE(numout,*) 719 739 ! 720 740 END SUBROUTINE timing_reset … … 734 754 !!---------------------------------------------------------------------- 735 755 !! *** ROUTINE insert *** 736 !! ** Purpose : insert an element in 756 !! ** Purpose : insert an element in timer structure 737 757 !!---------------------------------------------------------------------- 738 758 TYPE(timer), POINTER, INTENT(inout) :: sd_current, sd_root, sd_ptr … … 740 760 741 761 IF( ASSOCIATED( sd_current, sd_root ) ) THEN 762 ! If our current element is the root element then 763 ! replace it with the one being inserted 742 764 sd_root => sd_ptr 743 765 ELSE … … 747 769 sd_ptr%prev => sd_current%prev 748 770 sd_current%prev => sd_ptr 771 ! Nullify the pointer to the new element now that it is held 772 ! within the list. If we don't do this then a subsequent call 773 ! to ALLOCATE memory to this pointer will fail. 774 sd_ptr => NULL() 749 775 ! 750 776 END SUBROUTINE insert … … 764 790 IF ( ASSOCIATED(sl_temp%next) ) sl_temp%next%prev => sl_temp%prev 765 791 DEALLOCATE(sl_temp) 792 sl_temp => NULL() 766 793 ! 767 794 END SUBROUTINE suppress
Note: See TracChangeset
for help on using the changeset viewer.
