- Timestamp:
- 2018-01-04T13:30:03+01:00 (6 years ago)
- Location:
- branches/UKMO/dev_r5518_GO6_package_OMP/NEMOGCM/NEMO/OPA_SRC
- Files:
-
- 20 edited
-
DIA/diaprod.F90 (modified) (9 diffs)
-
DIA/diawri.F90 (modified) (18 diffs)
-
DOM/domvvl.F90 (modified) (35 diffs)
-
DYN/divcur.F90 (modified) (2 diffs)
-
DYN/dynldf_bilap.F90 (modified) (6 diffs)
-
DYN/dynvor.F90 (modified) (10 diffs)
-
LDF/ldfslp.F90 (modified) (18 diffs)
-
SOL/solpcg.F90 (modified) (8 diffs)
-
TRA/eosbn2.F90 (modified) (17 diffs)
-
TRA/traadv_tvd.F90 (modified) (29 diffs)
-
TRA/trabbc.F90 (modified) (1 diff)
-
TRA/traldf_iso.F90 (modified) (15 diffs)
-
TRA/tranxt.F90 (modified) (2 diffs)
-
TRA/trazdf_imp.F90 (modified) (9 diffs)
-
TRD/trdtra.F90 (modified) (4 diffs)
-
ZDF/zdfevd.F90 (modified) (2 diffs)
-
ZDF/zdftke.F90 (modified) (35 diffs)
-
ZDF/zdftmx.F90 (modified) (13 diffs)
-
lib_fortran.F90 (modified) (22 diffs)
-
stpctl.F90 (modified) (1 diff)
Legend:
- Unmodified
- Added
- Removed
-
branches/UKMO/dev_r5518_GO6_package_OMP/NEMOGCM/NEMO/OPA_SRC/DIA/diaprod.F90
r6491 r9176 88 88 IF( iom_use("ut") ) THEN 89 89 z3d(:,:,:) = 0.e0 90 !$OMP PARALLEL DO 90 91 DO jk = 1, jpkm1 91 92 DO jj = 2, jpjm1 … … 100 101 IF( iom_use("vt") ) THEN 101 102 z3d(:,:,:) = 0.e0 103 !$OMP PARALLEL DO 102 104 DO jk = 1, jpkm1 103 105 DO jj = 2, jpjm1 … … 117 119 END DO 118 120 END DO 121 !$OMP PARALLEL DO 119 122 DO jk = 2, jpkm1 120 123 DO jj = 2, jpjm1 … … 129 132 IF( iom_use("us") ) THEN 130 133 z3d(:,:,:) = 0.e0 134 !$OMP PARALLEL DO 131 135 DO jk = 1, jpkm1 132 136 DO jj = 2, jpjm1 … … 141 145 IF( iom_use("vs") ) THEN 142 146 z3d(:,:,:) = 0.e0 147 !$OMP PARALLEL DO 143 148 DO jk = 1, jpkm1 144 149 DO jj = 2, jpjm1 … … 158 163 END DO 159 164 END DO 165 !$OMP PARALLEL DO 160 166 DO jk = 2, jpkm1 161 167 DO jj = 2, jpjm1 … … 170 176 IF( iom_use("urhop") ) THEN 171 177 z3d(:,:,:) = 0.e0 178 !$OMP PARALLEL DO 172 179 DO jk = 1, jpkm1 173 180 DO jj = 2, jpjm1 … … 182 189 IF( iom_use("vrhop") ) THEN 183 190 z3d(:,:,:) = 0.e0 191 !$OMP PARALLEL DO 184 192 DO jk = 1, jpkm1 185 193 DO jj = 2, jpjm1 … … 199 207 END DO 200 208 END DO 209 !$OMP PARALLEL DO 201 210 DO jk = 2, jpkm1 202 211 DO jj = 2, jpjm1 -
branches/UKMO/dev_r5518_GO6_package_OMP/NEMOGCM/NEMO/OPA_SRC/DIA/diawri.F90
r6498 r9176 131 131 REAL(wp) :: zztmp, zztmpx, zztmpy ! 132 132 !! 133 REAL(wp), POINTER, DIMENSION(:,:):: z2d ! 2D workspace134 REAL(wp), POINTER, DIMENSION(:,:,:) :: z3d ! 3D workspace133 REAL(wp), DIMENSION(jpi,jpj ) :: z2d ! 2D workspace 134 REAL(wp), DIMENSION(jpi,jpj,jpk) :: z3d ! 3D workspace 135 135 !!---------------------------------------------------------------------- 136 136 ! 137 137 IF( nn_timing == 1 ) CALL timing_start('dia_wri') 138 138 ! 139 140 139 ! CALL wrk_alloc( jpi , jpj , z2d ) 140 ! CALL wrk_alloc( jpi , jpj, jpk , z3d ) 141 141 ! 142 142 ! Output the initial state and forcings … … 176 176 CALL iom_put( "sss", tsn(:,:,1,jp_sal) ) ! surface salinity 177 177 IF ( iom_use("sbs") ) THEN 178 !$OMP PARALLEL DO PRIVATE(jkbot) 178 179 DO jj = 1, jpj 179 180 DO ji = 1, jpi … … 187 188 IF ( iom_use("taubot") ) THEN ! bottom stress 188 189 z2d(:,:) = 0._wp 190 !$OMP PARALLEL DO PRIVATE(zztmpx, zztmpy) 189 191 DO jj = 2, jpjm1 190 192 DO ji = fs_2, fs_jpim1 ! vector opt. … … 204 206 CALL iom_put( "ssu", un(:,:,1) ) ! surface i-current 205 207 IF ( iom_use("sbu") ) THEN 208 !$OMP PARALLEL DO PRIVATE(jkbot) 206 209 DO jj = 1, jpj 207 210 DO ji = 1, jpi … … 221 224 CALL iom_put( "ssv", vn(:,:,1) ) ! surface j-current 222 225 IF ( iom_use("sbv") ) THEN 226 !$OMP PARALLEL DO PRIVATE(jkbot) 223 227 DO jj = 1, jpj 224 228 DO ji = 1, jpi … … 239 243 ! Caution: in the VVL case, it only correponds to the baroclinic mass transport. 240 244 z2d(:,:) = rau0 * e12t(:,:) 245 !$OMP PARALLEL DO 241 246 DO jk = 1, jpk 242 247 z3d(:,:,jk) = wn(:,:,jk) * z2d(:,:) … … 258 263 259 264 IF ( iom_use("sstgrad") .OR. iom_use("sstgrad2") ) THEN 265 !$OMP PARALLEL DO PRIVATE(zztmp, zztmpx, zztmpy) 260 266 DO jj = 2, jpjm1 ! sst gradient 261 267 DO ji = fs_2, fs_jpim1 ! vector opt. … … 269 275 CALL lbc_lnk( z2d, 'T', 1. ) 270 276 CALL iom_put( "sstgrad2", z2d ) ! square of module of sst gradient 271 z2d(:,:) = SQRT( z2d(:,:) ) 277 !$OMP PARALLEL DO 278 DO jj = 1, jpj 279 z2d(:,jj) = SQRT( z2d(:,jj) ) 280 ENDDO 272 281 CALL iom_put( "sstgrad" , z2d ) ! module of sst gradient 273 282 ENDIF … … 276 285 IF( iom_use("heatc") ) THEN 277 286 z2d(:,:) = 0._wp 287 !$OMP PARALLEL DO REDUCTION(+:z2d) 278 288 DO jk = 1, jpkm1 279 289 DO jj = 1, jpj … … 288 298 IF( iom_use("saltc") ) THEN 289 299 z2d(:,:) = 0._wp 300 !$OMP PARALLEL DO REDUCTION(+:z2d) 290 301 DO jk = 1, jpkm1 291 302 DO jj = 1, jpj … … 300 311 IF ( iom_use("eken") ) THEN 301 312 rke(:,:,jk) = 0._wp ! kinetic energy 313 !$OMP PARALLEL DO PRIVATE(zztmp, zztmpx, zztmpy) 302 314 DO jk = 1, jpkm1 303 315 DO jj = 2, jpjm1 … … 325 337 IF( iom_use("u_masstr") .OR. iom_use("u_heattr") .OR. iom_use("u_salttr") ) THEN 326 338 z3d(:,:,jpk) = 0.e0 339 !$OMP PARALLEL DO 327 340 DO jk = 1, jpkm1 328 341 z3d(:,:,jk) = rau0 * un(:,:,jk) * e2u(:,:) * fse3u(:,:,jk) * umask(:,:,jk) … … 333 346 IF( iom_use("u_heattr") ) THEN 334 347 z2d(:,:) = 0.e0 348 !$OMP PARALLEL DO REDUCTION(+:z2d) 335 349 DO jk = 1, jpkm1 336 350 DO jj = 2, jpjm1 … … 346 360 IF( iom_use("u_salttr") ) THEN 347 361 z2d(:,:) = 0.e0 362 !$OMP PARALLEL DO REDUCTION(+:z2d) 348 363 DO jk = 1, jpkm1 349 364 DO jj = 2, jpjm1 … … 360 375 IF( iom_use("v_masstr") .OR. iom_use("v_heattr") .OR. iom_use("v_salttr") ) THEN 361 376 z3d(:,:,jpk) = 0.e0 377 !$OMP PARALLEL DO 362 378 DO jk = 1, jpkm1 363 379 z3d(:,:,jk) = rau0 * vn(:,:,jk) * e1v(:,:) * fse3v(:,:,jk) * vmask(:,:,jk) … … 368 384 IF( iom_use("v_heattr") ) THEN 369 385 z2d(:,:) = 0.e0 386 !$OMP PARALLEL DO REDUCTION(+:z2d) 370 387 DO jk = 1, jpkm1 371 388 DO jj = 2, jpjm1 … … 381 398 IF( iom_use("v_salttr") ) THEN 382 399 z2d(:,:) = 0.e0 400 !$OMP PARALLEL DO REDUCTION(+:z2d) 383 401 DO jk = 1, jpkm1 384 402 DO jj = 2, jpjm1 … … 392 410 ENDIF 393 411 ! 394 395 412 ! CALL wrk_dealloc( jpi , jpj , z2d ) 413 ! CALL wrk_dealloc( jpi , jpj, jpk , z3d ) 396 414 ! 397 415 IF( nn_timing == 1 ) CALL timing_stop('dia_wri') -
branches/UKMO/dev_r5518_GO6_package_OMP/NEMOGCM/NEMO/OPA_SRC/DOM/domvvl.F90
r6498 r9176 172 172 fsdept_b(:,:,1) = 0.5_wp * fse3w_b(:,:,1) 173 173 fsdepw_b(:,:,1) = 0.0_wp 174 174 !$OPM PARALLEL 175 175 DO jk = 2, jpk 176 !$OMP DO PRIVATE(zcoef) 176 177 DO jj = 1,jpj 177 178 DO ji = 1,jpi … … 189 190 END DO 190 191 END DO 192 !$OMP END DO 191 193 END DO 194 !$OPM PARALLEL 192 195 193 196 ! Before depth and Inverse of the local depth of the water column at u- and v- points … … 214 217 ENDIF 215 218 IF ( ln_vvl_zstar_at_eqtor ) THEN 219 !$OMP PARALLEL DO 216 220 DO jj = 1, jpj 217 221 DO ji = 1, jpi … … 273 277 !!---------------------------------------------------------------------- 274 278 REAL(wp), POINTER, DIMENSION(:,:,:) :: ze3t 275 REAL(wp), POINTER, DIMENSION(:,:) :: zht, z_scale, zwu, zwv, zhdiv279 REAL(wp), DIMENSION(jpi, jpj ) :: zht, z_scale, zwu, zwv, zhdiv 276 280 !! * Arguments 277 281 INTEGER, INTENT( in ) :: kt ! time step … … 285 289 !!---------------------------------------------------------------------- 286 290 IF( nn_timing == 1 ) CALL timing_start('dom_vvl_sf_nxt') 287 291 ! CALL wrk_alloc( jpi, jpj, zht, z_scale, zwu, zwv, zhdiv ) 288 292 CALL wrk_alloc( jpi, jpj, jpk, ze3t ) 289 293 … … 306 310 ! z_star coordinate and barotropic z-tilde part ! 307 311 ! ! --------------------------------------------- ! 308 309 z_scale(:,:) = ( ssha(:,:) - sshb(:,:) ) * ssmask(:,:) / ( ht_0(:,:) + sshn(:,:) + 1. - ssmask(:,:) ) 312 !$OMP PARALLEL 313 !$OMP DO 314 DO jj = 1, jpj 315 z_scale(:,jj) = ( ssha(:,jj) - sshb(:,jj) ) * ssmask(:,jj) / ( ht_0(:,jj) + sshn(:,jj) + 1. - ssmask(:,jj) ) 316 END DO 317 !$OMP END DO 318 !$OMP DO 310 319 DO jk = 1, jpkm1 311 320 ! formally this is the same as fse3t_a = e3t_0*(1+ssha/ht_0) 312 321 fse3t_a(:,:,jk) = fse3t_b(:,:,jk) + fse3t_n(:,:,jk) * z_scale(:,:) * tmask(:,:,jk) 313 322 END DO 323 !$OMP END DO 324 !$OMP END PARALLEL 314 325 315 326 IF( ln_vvl_ztilde .OR. ln_vvl_layer .AND. ll_do_bclinic ) THEN ! z_tilde or layer coordinate ! … … 323 334 zhdiv(:,:) = 0. 324 335 zht(:,:) = 0. 336 !$OMP PARALLEL DO REDUCTION(+:zhdiv, zht) 325 337 DO jk = 1, jpkm1 326 338 zhdiv(:,:) = zhdiv(:,:) + fse3t_n(:,:,jk) * hdivn(:,:,jk) 327 339 zht (:,:) = zht (:,:) + fse3t_n(:,:,jk) * tmask(:,:,jk) 328 340 END DO 329 zhdiv(:,:) = zhdiv(:,:) / ( zht(:,:) + 1. - tmask_i(:,:) ) 341 !$OMP DO 342 DO jj = 1, jpj 343 zhdiv(:,jj) = zhdiv(:,jj) / ( zht(:,jj) + 1. - tmask_i(:,jj) ) 344 END DO 345 !$OMP END DO 330 346 331 347 ! 2 - Low frequency baroclinic horizontal divergence (z-tilde case only) … … 333 349 IF( ln_vvl_ztilde ) THEN 334 350 IF( kt .GT. nit000 ) THEN 351 !$OMP PARALLEL DO 335 352 DO jk = 1, jpkm1 336 353 hdiv_lf(:,:,jk) = hdiv_lf(:,:,jk) - rdt * frq_rst_hdv(:,:) & … … 347 364 ! ---------------------------------- 348 365 IF( ln_vvl_ztilde ) THEN ! z_tilde case 366 !$OMP PARALLEL DO 349 367 DO jk = 1, jpkm1 350 368 tilde_e3t_a(:,:,jk) = tilde_e3t_a(:,:,jk) - ( fse3t_n(:,:,jk) * ( hdivn(:,:,jk) - zhdiv(:,:) ) - hdiv_lf(:,:,jk) ) 351 369 END DO 352 370 ELSE ! layer case 371 !$OMP PARALLEL DO 353 372 DO jk = 1, jpkm1 354 373 tilde_e3t_a(:,:,jk) = tilde_e3t_a(:,:,jk) - fse3t_n(:,:,jk) * ( hdivn(:,:,jk) - zhdiv(:,:) ) * tmask(:,:,jk) … … 359 378 ! ------------------ 360 379 IF( ln_vvl_ztilde ) THEN 380 !$OMP PARALLEL DO 361 381 DO jk = 1, jpk 362 382 tilde_e3t_a(:,:,jk) = tilde_e3t_a(:,:,jk) - frq_rst_e3t(:,:) * tilde_e3t_b(:,:,jk) … … 369 389 zwv(:,:) = 0.0_wp 370 390 ! a - first derivative: diffusive fluxes 391 !$OMP PARALLEL 392 !$OMP DO 371 393 DO jk = 1, jpkm1 372 394 DO jj = 1, jpjm1 … … 376 398 vn_td(ji,jj,jk) = rn_ahe3 * vmask(ji,jj,jk) * re1v_e2v(ji,jj) & 377 399 & * ( tilde_e3t_b(ji,jj,jk) - tilde_e3t_b(ji ,jj+1,jk) ) 400 END DO 401 END DO 402 END DO 403 !$OMP END DO 404 !$OMP DO REDUCTION(+:zwu, zwv) 405 DO jk = 1, jpkm1 406 DO jj = 1, jpjm1 407 DO ji = 1, fs_jpim1 ! vector opt. 378 408 zwu(ji,jj) = zwu(ji,jj) + un_td(ji,jj,jk) 379 409 zwv(ji,jj) = zwv(ji,jj) + vn_td(ji,jj,jk) … … 381 411 END DO 382 412 END DO 413 !$OMP END DO 414 !$OMP END PARALLEL 383 415 ! b - correction for last oceanic u-v points 416 !$OMP PARALLEL DO 384 417 DO jj = 1, jpj 385 418 DO ji = 1, jpi … … 389 422 END DO 390 423 ! c - second derivative: divergence of diffusive fluxes 424 !$OMP PARALLEL DO 391 425 DO jk = 1, jpkm1 392 426 DO jj = 2, jpjm1 … … 413 447 ENDIF 414 448 CALL lbc_lnk( tilde_e3t_a(:,:,:), 'T', 1._wp ) 415 tilde_e3t_a(:,:,:) = tilde_e3t_b(:,:,:) + z2dt * tmask(:,:,:) * tilde_e3t_a(:,:,:) 416 449 !$OMP PARALLEL DO 450 DO jk = 1, jpk 451 tilde_e3t_a(:,:,jk) = tilde_e3t_b(:,:,jk) + z2dt * tmask(:,:,jk) * tilde_e3t_a(:,:,jk) 452 ENDDO 417 453 ! Maximum deformation control 418 454 ! ~~~~~~~~~~~~~~~~~~~~~~~~~~~ 419 455 ze3t(:,:,jpk) = 0.0_wp 420 DO jk = 1, jpkm1 421 ze3t(:,:,jk) = tilde_e3t_a(:,:,jk) / e3t_0(:,:,jk) * tmask(:,:,jk) * tmask_i(:,:) 422 END DO 456 !$OMP PARALLEL DO 457 DO jk = 1, jpkm1 458 DO jj = 1, jpj 459 !dir$ IVDEP 460 DO ji = 1, jpi 461 ze3t(ji, jj ,jk) = tilde_e3t_a(ji, jj ,jk) / e3t_0(ji, jj ,jk) * tmask(ji, jj ,jk) * tmask_i(ji, jj) 462 ENDDO 463 ENDDO 464 END DO 465 !$OMP PARALLEL 466 !$OMP DO 467 DO jk = 1, jpkm1 468 ze3t(:, : ,jk) = tilde_e3t_a(:, : ,jk) / e3t_0(:, : ,jk) * tmask_i(:, :) 469 END DO 470 !$OMP END DO 471 !$OMP DO 472 DO jk = 1, jpkm1 473 ze3t(:, : ,jk) = ze3t(:, : ,jk) * tmask(:, : ,jk) 474 END DO 475 !$OMP END DO 476 !$OMP END PARALLEL 477 423 478 z_tmax = MAXVAL( ze3t(:,:,:) ) 424 479 IF( lk_mpp ) CALL mpp_max( z_tmax ) ! max over the global domain … … 448 503 ! - ML - end test 449 504 ! - ML - Imposing these limits will cause a baroclinicity error which is corrected for below 450 tilde_e3t_a(:,:,:) = MIN( tilde_e3t_a(:,:,:), rn_zdef_max * e3t_0(:,:,:) ) 451 tilde_e3t_a(:,:,:) = MAX( tilde_e3t_a(:,:,:), - rn_zdef_max * e3t_0(:,:,:) ) 452 505 !$OMP PARALLEL DO 506 DO jk =1, jpk 507 tilde_e3t_a(:,:,jk) = MIN( tilde_e3t_a(:,:,jk), rn_zdef_max * e3t_0(:,:,jk) ) 508 tilde_e3t_a(:,:,jk) = MAX( tilde_e3t_a(:,:,jk), - rn_zdef_max * e3t_0(:,:,jk) ) 509 ENDDO 453 510 ! 454 511 ! "tilda" change in the after scale factor 455 512 ! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ 513 !$OMP PARALLEL DO 456 514 DO jk = 1, jpkm1 457 515 dtilde_e3t_a(:,:,jk) = tilde_e3t_a(:,:,jk) - tilde_e3t_b(:,:,jk) … … 464 522 ! (keep in mind that the idea is to reduce Eulerian velocity as much as possible) 465 523 zht(:,:) = 0. 524 !$OMP PARALLEL DO REDUCTION(+:zht) 466 525 DO jk = 1, jpkm1 467 526 zht(:,:) = zht(:,:) + tilde_e3t_a(:,:,jk) * tmask(:,:,jk) 468 527 END DO 469 528 z_scale(:,:) = - zht(:,:) / ( ht_0(:,:) + sshn(:,:) + 1. - ssmask(:,:) ) 529 !$OMP PARALLEL DO 470 530 DO jk = 1, jpkm1 471 531 dtilde_e3t_a(:,:,jk) = dtilde_e3t_a(:,:,jk) + fse3t_n(:,:,jk) * z_scale(:,:) * tmask(:,:,jk) … … 476 536 IF( ln_vvl_ztilde .OR. ln_vvl_layer ) THEN ! z_tilde or layer coordinate ! 477 537 ! ! ---baroclinic part--------- ! 538 !$OMP PARALLEL DO 478 539 DO jk = 1, jpkm1 479 540 fse3t_a(:,:,jk) = fse3t_a(:,:,jk) + dtilde_e3t_a(:,:,jk) * tmask(:,:,jk) … … 491 552 ! 492 553 zht(:,:) = 0.0_wp 554 !$OMP PARALLEL DO REDUCTION(+:zht) 493 555 DO jk = 1, jpkm1 494 556 zht(:,:) = zht(:,:) + fse3t_n(:,:,jk) * tmask(:,:,jk) … … 499 561 ! 500 562 zht(:,:) = 0.0_wp 563 !$OMP PARALLEL DO REDUCTION(+:zht) 501 564 DO jk = 1, jpkm1 502 565 zht(:,:) = zht(:,:) + fse3t_a(:,:,jk) * tmask(:,:,jk) … … 507 570 ! 508 571 zht(:,:) = 0.0_wp 572 !$OMP PARALLEL DO REDUCTION(+:zht) 509 573 DO jk = 1, jpkm1 510 574 zht(:,:) = zht(:,:) + fse3t_b(:,:,jk) * tmask(:,:,jk) … … 540 604 hu_a(:,:) = 0._wp ! Ocean depth at U-points 541 605 hv_a(:,:) = 0._wp ! Ocean depth at V-points 606 542 607 DO jk = 1, jpkm1 543 608 hu_a(:,:) = hu_a(:,:) + fse3u_a(:,:,jk) * umask(:,:,jk) … … 545 610 END DO 546 611 ! ! Inverse of the local depth 547 hur_a(:,:) = 1._wp / ( hu_a(:,:) + 1._wp - umask_i(:,:) ) * umask_i(:,:) 548 hvr_a(:,:) = 1._wp / ( hv_a(:,:) + 1._wp - vmask_i(:,:) ) * vmask_i(:,:) 549 550 CALL wrk_dealloc( jpi, jpj, zht, z_scale, zwu, zwv, zhdiv ) 612 !$OMP PARALLEL DO 613 DO jj = 1, jpj 614 hur_a(:,jj) = 1._wp / ( hu_a(:,jj) + 1._wp - umask_i(:,jj) ) * umask_i(:,jj) 615 hvr_a(:,jj) = 1._wp / ( hv_a(:,jj) + 1._wp - vmask_i(:,jj) ) * vmask_i(:,jj) 616 ENDDO 617 618 ! CALL wrk_dealloc( jpi, jpj, zht, z_scale, zwu, zwv, zhdiv ) 551 619 CALL wrk_dealloc( jpi, jpj, jpk, ze3t ) 552 620 … … 603 671 tilde_e3t_b(:,:,:) = tilde_e3t_n(:,:,:) 604 672 ELSE 605 tilde_e3t_b(:,:,:) = tilde_e3t_n(:,:,:) & 673 !$OMP PARALLEL DO 674 DO jk = 1,jpk 675 tilde_e3t_b(:,:,:) = tilde_e3t_n(:,:,:) & 606 676 & + atfp * ( tilde_e3t_b(:,:,:) - 2.0_wp * tilde_e3t_n(:,:,:) + tilde_e3t_a(:,:,:) ) 677 ENDDO 607 678 ENDIF 608 679 tilde_e3t_n(:,:,:) = tilde_e3t_a(:,:,:) … … 636 707 fsdepw_n(:,:,1) = 0.0_wp 637 708 fsde3w_n(:,:,1) = fsdept_n(:,:,1) - sshn(:,:) 638 709 !$OMP PARALLEL SHARED(jk) 639 710 DO jk = 2, jpk 711 !$OMP DO PRIVATE(zcoef) 640 712 DO jj = 1,jpj 641 713 DO ji = 1,jpi … … 649 721 END DO 650 722 END DO 723 !$OMP END DO 651 724 END DO 725 !$OMP END PARALLEL 652 726 653 727 ! Local depth and Inverse of the local depth of the water column at u- and v- points … … 663 737 ! -------------------------------------------- 664 738 ht(:,:) = 0. 739 !$OMP PARALLEL DO REDUCTION(+:ht) 665 740 DO jk = 1, jpkm1 666 741 ht(:,:) = ht(:,:) + fse3t_n(:,:,jk) * tmask(:,:,jk) … … 705 780 ! ! ------------------------------------- ! 706 781 ! horizontal surface weighted interpolation 782 !$OMP PARALLEL DO 707 783 DO jk = 1, jpk 708 784 DO jj = 1, jpjm1 … … 718 794 ! boundary conditions 719 795 CALL lbc_lnk( pe3_out(:,:,:), 'U', 1._wp ) 720 pe3_out(:,:,:) = pe3_out(:,:,:) + e3u_0(:,:,:) 796 !$OMP PARALLEL DO 797 DO jk = 1, jpk 798 pe3_out(:,:,jk) = pe3_out(:,:,jk) + e3u_0(:,:,jk) 799 ENDDO 721 800 ! ! ------------------------------------- ! 722 801 CASE( 'V' ) ! interpolation from T-point to V-point ! 723 802 ! ! ------------------------------------- ! 724 803 ! horizontal surface weighted interpolation 804 !$OMP PARALLEL DO 725 805 DO jk = 1, jpk 726 806 DO jj = 1, jpjm1 … … 736 816 ! boundary conditions 737 817 CALL lbc_lnk( pe3_out(:,:,:), 'V', 1._wp ) 738 pe3_out(:,:,:) = pe3_out(:,:,:) + e3v_0(:,:,:) 818 !$OMP PARALLEL DO 819 DO jk = 1, jpk 820 pe3_out(:,:,jk) = pe3_out(:,:,jk) + e3v_0(:,:,jk) 821 ENDDO 739 822 ! ! ------------------------------------- ! 740 823 CASE( 'F' ) ! interpolation from U-point to F-point ! 741 824 ! ! ------------------------------------- ! 742 825 ! horizontal surface weighted interpolation 826 !$OMP PARALLEL DO 743 827 DO jk = 1, jpk 744 828 DO jj = 1, jpjm1 … … 754 838 ! boundary conditions 755 839 CALL lbc_lnk( pe3_out(:,:,:), 'F', 1._wp ) 756 pe3_out(:,:,:) = pe3_out(:,:,:) + e3f_0(:,:,:) 840 !$OMP PARALLEL DO 841 DO jk = 1, jpk 842 pe3_out(:,:,jk) = pe3_out(:,:,jk) + e3f_0(:,:,jk) 843 ENDDO 757 844 ! ! ------------------------------------- ! 758 845 CASE( 'W' ) ! interpolation from T-point to W-point ! … … 761 848 pe3_out(:,:,1) = e3w_0(:,:,1) + pe3_in(:,:,1) - e3t_0(:,:,1) 762 849 ! - ML - The use of mask in this formaula enables the special treatment of the last w- point without indirect adressing 850 !$OMP PARALLEL DO 763 851 DO jk = 2, jpk 764 852 pe3_out(:,:,jk) = e3w_0(:,:,jk) + ( 1.0_wp - 0.5_wp * tmask(:,:,jk) ) * ( pe3_in(:,:,jk-1) - e3t_0(:,:,jk-1) ) & … … 771 859 pe3_out(:,:,1) = e3uw_0(:,:,1) + pe3_in(:,:,1) - e3u_0(:,:,1) 772 860 ! - ML - The use of mask in this formaula enables the special treatment of the last w- point without indirect adressing 861 !$OMP PARALLEL DO 773 862 DO jk = 2, jpk 774 863 pe3_out(:,:,jk) = e3uw_0(:,:,jk) + ( 1.0_wp - 0.5_wp * umask(:,:,jk) ) * ( pe3_in(:,:,jk-1) - e3u_0(:,:,jk-1) ) & … … 781 870 pe3_out(:,:,1) = e3vw_0(:,:,1) + pe3_in(:,:,1) - e3v_0(:,:,1) 782 871 ! - ML - The use of mask in this formaula enables the special treatment of the last w- point without indirect adressing 872 !$OMP PARALLEL DO 783 873 DO jk = 2, jpk 784 874 pe3_out(:,:,jk) = e3vw_0(:,:,jk) + ( 1.0_wp - 0.5_wp * vmask(:,:,jk) ) * ( pe3_in(:,:,jk-1) - e3v_0(:,:,jk-1) ) & … … 857 947 IF(lwp) write(numout,*) 'Compute scale factor from sshn' 858 948 IF(lwp) write(numout,*) 'neuler is forced to 0' 949 !$OMP PARALLEL DO 859 950 DO jk=1,jpk 860 951 fse3t_n(:,:,jk) = e3t_0(:,:,jk) * ( ht_0(:,:) + sshn(:,:) ) & -
branches/UKMO/dev_r5518_GO6_package_OMP/NEMOGCM/NEMO/OPA_SRC/DYN/divcur.F90
r6487 r9176 105 105 IF(lwp) WRITE(numout,*) '~~~~~~~ NOT optimal for auto-tasking case' 106 106 ENDIF 107 108 !! ===============107 ! 108 !$OMP PARALLEL DO ! =============== 109 109 DO jk = 1, jpkm1 ! Horizontal slab 110 110 ! ! =============== … … 287 287 ENDIF 288 288 289 !! ===============289 !$OMP PARALLEL DO ! =============== 290 290 DO jk = 1, jpkm1 ! Horizontal slab 291 291 ! ! =============== -
branches/UKMO/dev_r5518_GO6_package_OMP/NEMOGCM/NEMO/OPA_SRC/DYN/dynldf_bilap.F90
r6486 r9176 77 77 INTEGER :: ji, jj, jk ! dummy loop indices 78 78 REAL(wp) :: zua, zva, zbt, ze2u, ze2v ! temporary scalar 79 REAL(wp), POINTER, DIMENSION(:,:) :: zcu, zcv79 REAL(wp), DIMENSION(jpi,jpj ) :: zcu, zcv 80 80 REAL(wp), POINTER, DIMENSION(:,:,:) :: zuf, zut, zlu, zlv 81 81 !!---------------------------------------------------------------------- … … 83 83 IF( nn_timing == 1 ) CALL timing_start('dyn_ldf_bilap') 84 84 ! 85 85 ! CALL wrk_alloc( jpi, jpj, zcu, zcv ) 86 86 CALL wrk_alloc( jpi, jpj, jpk, zuf, zut, zlu, zlv ) 87 87 ! … … 102 102 zlv(:,:,:) = 0._wp 103 103 104 ! ! =============== 105 DO jk = 1, jpkm1 ! Horizontal slab 106 ! ! =============== 104 ! 107 105 ! Laplacian 108 106 ! --------- 109 107 110 108 IF( ln_sco .OR. ln_zps ) THEN ! s-coordinate or z-coordinate with partial steps 111 zuf(:,:,jk) = rotb(:,:,jk) * fse3f(:,:,jk) 112 DO jj = 2, jpjm1 113 DO ji = fs_2, fs_jpim1 ! vector opt. 114 zlu(ji,jj,jk) = - ( zuf(ji,jj,jk) - zuf(ji,jj-1,jk) ) / ( e2u(ji,jj) * fse3u(ji,jj,jk) ) & 115 & + ( hdivb(ji+1,jj,jk) - hdivb(ji,jj,jk) ) / e1u(ji,jj) 116 117 zlv(ji,jj,jk) = + ( zuf(ji,jj,jk) - zuf(ji-1,jj,jk) ) / ( e1v(ji,jj) * fse3v(ji,jj,jk) ) & 118 & + ( hdivb(ji,jj+1,jk) - hdivb(ji,jj,jk) ) / e2v(ji,jj) 119 END DO 109 !$OMP PARALLEL DO 110 ! ! =============== 111 DO jk = 1, jpkm1 ! Horizontal slab 112 ! ! =============== 113 ! Laplacian 114 ! --------- 115 zuf(:,:,jk) = rotb(:,:,jk) * fse3f(:,:,jk) 116 DO jj = 2, jpjm1 117 DO ji = fs_2, fs_jpim1 ! vector opt. 118 zlu(ji,jj,jk) = - ( zuf(ji,jj,jk) - zuf(ji,jj-1,jk) ) / ( e2u(ji,jj) * fse3u(ji,jj,jk) ) & 119 & + ( hdivb(ji+1,jj,jk) - hdivb(ji,jj,jk) ) / e1u(ji,jj) 120 121 zlv(ji,jj,jk) = + ( zuf(ji,jj,jk) - zuf(ji-1,jj,jk) ) / ( e1v(ji,jj) * fse3v(ji,jj,jk) ) & 122 & + ( hdivb(ji,jj+1,jk) - hdivb(ji,jj,jk) ) / e2v(ji,jj) 123 END DO 124 END DO 120 125 END DO 121 126 ELSE ! z-coordinate - full step 122 DO jj = 2, jpjm1 123 DO ji = fs_2, fs_jpim1 ! vector opt. 124 zlu(ji,jj,jk) = - ( rotb (ji ,jj,jk) - rotb (ji,jj-1,jk) ) / e2u(ji,jj) & 125 & + ( hdivb(ji+1,jj,jk) - hdivb(ji,jj ,jk) ) / e1u(ji,jj) 126 127 zlv(ji,jj,jk) = + ( rotb (ji,jj ,jk) - rotb (ji-1,jj,jk) ) / e1v(ji,jj) & 128 & + ( hdivb(ji,jj+1,jk) - hdivb(ji ,jj,jk) ) / e2v(ji,jj) 127 !$OMP PARALLEL DO 128 ! ! =============== 129 DO jk = 1, jpkm1 ! Horizontal slab 130 ! ! =============== 131 DO jj = 2, jpjm1 132 DO ji = fs_2, fs_jpim1 ! vector opt. 133 zlu(ji,jj,jk) = - ( rotb (ji ,jj,jk) - rotb (ji,jj-1,jk) ) / e2u(ji,jj) & 134 & + ( hdivb(ji+1,jj,jk) - hdivb(ji,jj ,jk) ) / e1u(ji,jj) 135 136 zlv(ji,jj,jk) = + ( rotb (ji,jj ,jk) - rotb (ji-1,jj,jk) ) / e1v(ji,jj) & 137 & + ( hdivb(ji,jj+1,jk) - hdivb(ji ,jj,jk) ) / e2v(ji,jj) 138 END DO 129 139 END DO 130 END DO 140 END DO 131 141 ENDIF 132 END DO133 142 CALL lbc_lnk( zlu, 'U', -1. ) ; CALL lbc_lnk( zlv, 'V', -1. ) ! Boundary conditions 134 135 143 !$OMP PARALLE DO PRIVATE(zcu, zcv, zbt) 136 144 DO jk = 1, jpkm1 137 145 … … 145 153 146 154 ! Contravariant "laplacian" 147 zcu(:,:) = e1u(:,:) * zlu(:,:,jk) 148 zcv(:,:) = e2v(:,:) * zlv(:,:,jk) 155 DO jj = 1, jpj 156 DO ji = 1, jpi 157 zcu(ji,jj) = e1u(ji,jj) * zlu(ji,jj,jk) 158 zcv(ji,jj) = e2v(ji,jj) * zlv(ji,jj,jk) 159 END DO 160 END DO 149 161 150 162 ! Laplacian curl ( * e3f if s-coordinates or z-coordinate with partial steps) … … 180 192 CALL lbc_lnk( zuf, 'F', 1. ) 181 193 CALL lbc_lnk( zut, 'T', 1. ) 182 194 !OMP PARALLEL DO PRIVATE(ze2u, ze2v, zua, zva) 183 195 DO jk = 1, jpkm1 184 196 … … 205 217 END DO ! End of slab 206 218 ! ! =============== 207 219 ! CALL wrk_dealloc( jpi, jpj, zcu, zcv ) 208 220 CALL wrk_dealloc( jpi, jpj, jpk, zuf, zut, zlu, zlv ) 209 221 ! -
branches/UKMO/dev_r5518_GO6_package_OMP/NEMOGCM/NEMO/OPA_SRC/DYN/dynvor.F90
r6486 r9176 222 222 INTEGER :: ji, jj, jk ! dummy loop indices 223 223 REAL(wp) :: zx1, zy1, zfact2, zx2, zy2 ! local scalars 224 REAL(wp), POINTER, DIMENSION(:,:) :: zwx, zwy, zwz224 REAL(wp), DIMENSION(jpi, jpj) :: zwx, zwy, zwz 225 225 !!---------------------------------------------------------------------- 226 226 ! 227 227 IF( nn_timing == 1 ) CALL timing_start('vor_ene') 228 228 ! 229 229 ! CALL wrk_alloc( jpi, jpj, zwx, zwy, zwz ) 230 230 ! 231 231 IF( kt == nit000 ) THEN … … 237 237 zfact2 = 0.5 * 0.5 ! Local constant initialization 238 238 239 ! CDIR PARALLEL DO PRIVATE( zwx, zwy, zwz)239 !$OMP PARALLEL DO PRIVATE( zwx, zwy, zwz, zy1, zy2, zx1, zx2 ) 240 240 ! ! =============== 241 241 DO jk = 1, jpkm1 ! Horizontal slab … … 292 292 END DO ! End of slab 293 293 ! ! =============== 294 294 ! CALL wrk_dealloc( jpi, jpj, zwx, zwy, zwz ) 295 295 ! 296 296 IF( nn_timing == 1 ) CALL timing_stop('vor_ene') … … 350 350 zfact2 = 0.5 * 0.5 351 351 352 ! CDIR PARALLEL DO PRIVATE( zwx, zwy, zwz, zww)352 !!!!$OMP PARALLEL DO PRIVATE( zwx, zwy, zwz, zww, zy1, zy2, zx1, zx2, zua, zva, zcua, zcva) 353 353 ! ! =============== 354 354 DO jk = 1, jpkm1 ! Horizontal slab … … 466 466 zfact1 = 0.5 * 0.25 ! Local constant initialization 467 467 468 ! CDIR PARALLEL DO PRIVATE( zwx, zwy, zwz)468 !!!!$OMP PARALLEL DO PRIVATE( zwx, zwy, zwz, zuav, zvau ) 469 469 ! ! =============== 470 470 DO jk = 1, jpkm1 ! Horizontal slab … … 599 599 600 600 IF( ln_dynvor_een_old ) THEN ! original formulation 601 !$OMP PARALLEL DO PRIVATE(ze3) 601 602 DO jk = 1, jpk 602 603 DO jj = 1, jpjm1 … … 609 610 END DO 610 611 ELSE ! new formulation from NEMO 3.6 612 !$OMP PARALLEL DO PRIVATE(ze3, zmsk) 611 613 DO jk = 1, jpk 612 614 DO jj = 1, jpjm1 … … 628 630 629 631 630 ! CDIR PARALLEL DO PRIVATE( zwx, zwy, zwz, ztnw, ztne, ztsw, ztse)632 !!!!!$OMP PARALLEL DO PRIVATE( zwx, zwy, zwz, ztnw, ztne, ztsw, ztse, zua, zva ) 631 633 ! ! =============== 632 634 DO jk = 1, jpkm1 ! Horizontal slab … … 637 639 SELECT CASE( kvor ) ! vorticity considered 638 640 CASE ( 1 ) ! planetary vorticity (Coriolis) 639 zwz(:,:) = ff(:,:) * ze3f(:,:,jk)641 zwz(:,:) = ff(:,:) * ze3f(:,:,jk) 640 642 CASE ( 2 ) ! relative vorticity 641 zwz(:,:) = rotn(:,:,jk) * ze3f(:,:,jk)643 zwz(:,:) = rotn(:,:,jk) * ze3f(:,:,jk) 642 644 CASE ( 3 ) ! metric term 643 645 DO jj = 1, jpjm1 … … 650 652 CALL lbc_lnk( zwz, 'F', 1. ) 651 653 CASE ( 4 ) ! total (relative + planetary vorticity) 652 zwz(:,:) = ( rotn(:,:,jk) + ff(:,:) ) * ze3f(:,:,jk)654 zwz(:,:) = ( rotn(:,:,jk) + ff(:,:) ) * ze3f(:,:,jk) 653 655 CASE ( 5 ) ! total (coriolis + metric) 654 656 DO jj = 1, jpjm1 -
branches/UKMO/dev_r5518_GO6_package_OMP/NEMOGCM/NEMO/OPA_SRC/LDF/ldfslp.F90
r6498 r9176 105 105 INTEGER :: ii0, ii1, iku ! temporary integer 106 106 INTEGER :: ij0, ij1, ikv ! temporary integer 107 REAL(wp) :: zeps, zm1_g, zm1_2g, z1_16, zcofw ! local scalars107 REAL(wp) :: zeps, zm1_g, zm1_2g, z1_16, zcofw, zcofwa ! local scalars 108 108 REAL(wp) :: zci, zfi, zau, zbu, zai, zbi ! - - 109 109 REAL(wp) :: zcj, zfj, zav, zbv, zaj, zbj ! - - … … 131 131 zwz(:,:,:) = 0._wp 132 132 ! 133 !$OMP PARALLEL DO 133 134 DO jk = 1, jpk !== i- & j-gradient of density ==! 134 135 DO jj = 1, jpjm1 … … 139 140 END DO 140 141 END DO 142 141 143 IF( ln_zps ) THEN ! partial steps correction at the bottom ocean level 144 !$OMP PARALLEL DO 142 145 DO jj = 1, jpjm1 143 146 DO ji = 1, jpim1 … … 148 151 ENDIF 149 152 IF( ln_zps .AND. ln_isfcav ) THEN ! partial steps correction at the bottom ocean level 153 !$OMP PARALLEL DO 150 154 DO jj = 1, jpjm1 151 155 DO ji = 1, jpim1 … … 158 162 !== Local vertical density gradient at T-point == ! (evaluated from N^2) 159 163 ! interior value 164 !$OMP PARALLEL DO 160 165 DO jk = 2, jpkm1 161 166 ! ! zdzr = d/dz(prd)= - ( prd ) / grav * mk(pn2) -- at t point … … 171 176 IF ( ln_isfcav ) THEN 172 177 ! if isf need to overwrite the interior value at at the first ocean point 178 !$OMP PARALLEL DO 173 179 DO jj = 1, jpjm1 174 180 DO ji = 1, jpim1 … … 186 192 ! 187 193 IF ( ln_isfcav ) THEN 194 !$OMP PARALLEL DO 188 195 DO jj = 2, jpjm1 189 196 DO ji = fs_2, fs_jpim1 ! vector opt. … … 195 202 ENDDO 196 203 ELSE 204 !$OMP PARALLEL DO 197 205 DO jj = 2, jpjm1 198 206 DO ji = fs_2, fs_jpim1 ! vector opt. … … 202 210 ENDDO 203 211 END IF 212 !$OMP PARALLEL DO PRIVATE(zau, zav, zbu, zbv, zbu, zbv, zfi, zfj, zdepu, zdepv) 204 213 DO jk = 2, jpkm1 !* Slopes at u and v points 205 214 DO jj = 2, jpjm1 … … 243 252 END DO 244 253 END DO 254 !$OMP END PARALLEL DO 245 255 CALL lbc_lnk( zwz, 'U', -1. ) ; CALL lbc_lnk( zww, 'V', -1. ) ! lateral boundary conditions 246 256 ! 247 257 ! !* horizontal Shapiro filter 258 !$OMP PARALLEL DO 248 259 DO jk = 2, jpkm1 249 260 DO jj = 2, jpjm1, MAX(1, jpj-3) ! rows jj=2 and =jpjm1 only … … 287 298 END DO 288 299 END DO 289 300 !$OMP END PARALLEL DO 290 301 291 302 ! II. slopes at w point | wslpi = mij( d/di( prd ) / d/dz( prd ) 292 303 ! =========================== | wslpj = mij( d/dj( prd ) / d/dz( prd ) 293 304 ! 305 !$OMP PARALLEL DO PRIVATE(zbw, zci, zcj, zai, zaj, zbi, zbj, zfk, zck) 294 306 DO jk = 2, jpkm1 295 307 DO jj = 2, jpjm1 … … 329 341 END DO 330 342 END DO 343 !$OMP END PARALLEL DO 331 344 CALL lbc_lnk( zwz, 'T', -1. ) ; CALL lbc_lnk( zww, 'T', -1. ) ! lateral boundary conditions 332 345 ! 333 346 ! !* horizontal Shapiro filter 347 !$OMP PARALLEL DO PRIVATE(zcofwa, zcofw, zck) 334 348 DO jk = 2, jpkm1 335 349 DO jj = 2, jpjm1, MAX(1, jpj-3) ! rows jj=2 and =jpjm1 only 336 350 DO ji = 2, jpim1 337 zcofw = tmask(ji,jj,jk) * z1_16351 zcofwa = tmask(ji,jj,jk) * z1_16 338 352 wslpi(ji,jj,jk) = ( zwz(ji-1,jj-1,jk) + zwz(ji+1,jj-1,jk) & 339 353 & + zwz(ji-1,jj+1,jk) + zwz(ji+1,jj+1,jk) & 340 354 & + 2.*( zwz(ji ,jj-1,jk) + zwz(ji-1,jj ,jk) & 341 355 & + zwz(ji+1,jj ,jk) + zwz(ji ,jj+1,jk) ) & 342 & + 4.* zwz(ji ,jj ,jk) ) * zcofw 356 & + 4.* zwz(ji ,jj ,jk) ) * zcofwa 343 357 344 358 wslpj(ji,jj,jk) = ( zww(ji-1,jj-1,jk) + zww(ji+1,jj-1,jk) & … … 346 360 & + 2.*( zww(ji ,jj-1,jk) + zww(ji-1,jj ,jk) & 347 361 & + zww(ji+1,jj ,jk) + zww(ji ,jj+1,jk) ) & 348 & + 4.* zww(ji ,jj ,jk) ) * zcofw 362 & + 4.* zww(ji ,jj ,jk) ) * zcofwa 349 363 END DO 350 364 END DO … … 422 436 ! set the slope of diffusion to the slope of s-surfaces 423 437 ! ( c a u t i o n : minus sign as fsdep has positive value ) 438 !$OMP PARALLEL DO 424 439 DO jj = 2, jpjm1 425 440 DO ji = fs_2, fs_jpim1 ! vector opt. … … 430 445 END DO 431 446 END DO 432 447 !$OMP PARALLEL DO 433 448 DO jk = 2, jpk 434 449 DO jj = 2, jpjm1 … … 746 761 ! 747 762 ! !== surface mixed layer mask ! 763 !$OMP PARALLEL DO PRIVATE(ik) 748 764 DO jk = 1, jpk ! =1 inside the mixed layer, =0 otherwise 749 765 DO jj = 1, jpj … … 770 786 !----------------------------------------------------------------------- 771 787 ! 788 !$OMP PARALLEL DO PRIVATE(iku, ikv, zbu, zbv, zau, zav, ik, ikm1, zbw, & 789 !$OMP& zci, zcj, zai, zaj, zbi, zbj) 772 790 DO jj = 2, jpjm1 773 791 DO ji = 2, jpim1 … … 872 890 ! set the slope of diffusion to the slope of s-surfaces 873 891 ! ( c a u t i o n : minus sign as fsdep has positive value ) 892 !$OMP PARALLEL DO 874 893 DO jk = 1, jpk 875 894 DO jj = 2, jpjm1 -
branches/UKMO/dev_r5518_GO6_package_OMP/NEMOGCM/NEMO/OPA_SRC/SOL/solpcg.F90
r6486 r9176 94 94 REAL(wp), DIMENSION(2) :: zsum 95 95 REAL(wp), POINTER, DIMENSION(:,:) :: zgcr 96 REAL(wp), DIMENSION(jpi, jpj) :: tmp1, tmp2 96 97 !!---------------------------------------------------------------------- 97 98 ! … … 109 110 ! gcr = gcb-a.gcx 110 111 ! gcdes = gcr 112 !$OMP PARALLEL DO PRIVATE(zgcad) 111 113 DO jj = 2, jpjm1 112 114 DO ji = fs_2, fs_jpim1 ! vector opt. … … 120 122 END DO 121 123 END DO 124 !$OMP END PARALLEL DO 122 125 123 126 ! rnorme = (gcr,gcr) 124 rnorme = glob_sum( gcr(:,:) * gcdmat(:,:) * gcr(:,:) ) 125 127 tmp1 = 0. 128 !$OMP PARALLEL DO 129 DO jj = 2, jpjm1 130 DO ji = fs_2, fs_jpim1 ! vector opt. 131 tmp1(ji, jj) = gcr(ji, jj) * gcdmat(ji, jj) * gcr(ji, jj) 132 END DO 133 END DO 134 !$OMP END PARALLEL DO 135 rnorme = glob_sum( tmp1(:,:) ) 126 136 CALL lbc_lnk( gcdes, c_solver_pt, 1. ) ! lateral boundary condition 127 137 128 138 ! gccd = matrix . gcdes 139 gccd = 0. 140 !$OMP PARALLEL DO 129 141 DO jj = 2, jpjm1 130 142 DO ji = fs_2, fs_jpim1 ! vector opt. … … 134 146 END DO 135 147 END DO 136 148 !$OMP END PARALLEL DO 137 149 ! alph = (gcr,gcr)/(gcdes,gccd) 138 radd = glob_sum( gcdes(:,:) * gcdmat(:,:) * gccd(:,:) ) 150 !$OMP PARALLEL DO 151 DO jj = 1, jpj 152 DO ji = 1, jpi 153 tmp1(ji, jj) = gcdes(ji, jj) * gcdmat(ji, jj) * gccd(ji, jj) 154 END DO 155 END DO 156 !$OMP END PARALLEL DO 157 radd = glob_sum( tmp1 ) 139 158 alph = rnorme /radd 140 159 141 160 ! gcx = gcx + alph * gcdes 142 161 ! gcr = gcr - alph * gccd 162 !$OMP PARALLEL DO 143 163 DO jj = 2, jpjm1 144 164 DO ji = fs_2, fs_jpim1 ! vector opt. … … 147 167 END DO 148 168 END DO 149 169 !$OMP END PARALLEL DO 150 170 ! Algorithm wtih Eijkhout rearrangement 151 171 ! ------------------------------------- … … 158 178 159 179 ! zgcr = matrix . gcr 180 !$OMP PARALLEL DO 160 181 DO jj = 2, jpjm1 161 182 DO ji = fs_2, fs_jpim1 ! vector opt. … … 168 189 ! rnorme = (gcr,gcr) 169 190 rr = rnorme 170 171 ! zgcad = (zgcr,gcr) 172 zsum(1) = glob_sum(gcr(:,:) * gcdmat(:,:) * gcr(:,:)) 173 zsum(2) = glob_sum(gcr(:,:) * gcdmat(:,:) * zgcr(:,:) * bmask(:,:)) 191 192 ! zgcad = (zgcr,gcr) 193 tmp2 = 0. 194 !$OMP PARALLEL 195 !$OMP DO 196 DO jj = 1, jpj 197 DO ji = 1, jpi 198 tmp2(ji, jj) = gcr(ji, jj) * gcdmat(ji, jj) 199 tmp1(ji, jj) = tmp2(ji, jj) * gcr(ji, jj) 200 END DO 201 END DO 202 !$OMP END DO 203 !$OMP DO 204 !DIR$ IVDEP 205 DO jj = 1, jpj 206 !DIR$ IVDEP 207 DO ji = 1, jpi 208 tmp2(ji, jj) = tmp2(ji, jj) * zgcr(ji, jj) * bmask(ji, jj) 209 END DO 210 END DO 211 !$OMP END DO 212 !$OMP END PARALLEL 213 214 ! zsum(1) = glob_sum(gcr(:,:) * gcdmat(:,:) * gcr(:,:)) 215 ! zsum(2) = glob_sum(gcr(:,:) * gcdmat(:,:) * zgcr(:,:) * bmask(:,:)) 216 zsum = glob_asum_2d(tmp1, tmp2) 174 217 175 218 !!RB we should gather the 2 glob_sum … … 190 233 ! gcx = gcx + alph * gcdes 191 234 ! gcr = gcr - alph * gccd 235 !$OMP PARALLEL DO 192 236 DO jj = 2, jpjm1 193 237 DO ji = fs_2, fs_jpim1 ! vector opt. -
branches/UKMO/dev_r5518_GO6_package_OMP/NEMOGCM/NEMO/OPA_SRC/TRA/eosbn2.F90
r6793 r9176 231 231 CASE( -1, 0 ) !== polynomial TEOS-10 / EOS-80 ==! 232 232 ! 233 !$OMP PARALLEL DO PRIVATE(zh, zt, zs, ztm, zn3, zn2, zn1, zn0, zn) 233 234 DO jk = 1, jpkm1 234 235 DO jj = 1, jpj … … 271 272 CASE( 1 ) !== simplified EOS ==! 272 273 ! 274 !$OMP PARALLEL DO PRIVATE(zt, zs, zh, ztm, zn) 273 275 DO jk = 1, jpkm1 274 276 DO jj = 1, jpj … … 393 395 ! Non-stochastic equation of state 394 396 ELSE 397 !$OMP PARALLEL DO PRIVATE(zh, zt, zs, ztm, zn3, zn2, zn1, zn0, zn0, zn) 395 398 DO jk = 1, jpkm1 396 399 DO jj = 1, jpj … … 435 438 CASE( 1 ) !== simplified EOS ==! 436 439 ! 440 !$OMP PARALLEL DO PRIVATE(zt, zs, zh, ztm, zn) 437 441 DO jk = 1, jpkm1 438 442 DO jj = 1, jpj … … 493 497 CASE( -1, 0 ) !== polynomial TEOS-10 / EOS-80 ==! 494 498 ! 499 !$OMP PARALLEL DO PRIVATE(zh, zt, zs, zn3, zn2, zn1, zn0, zn) 495 500 DO jj = 1, jpjm1 496 501 DO ji = 1, fs_jpim1 ! vector opt. … … 532 537 CASE( 1 ) !== simplified EOS ==! 533 538 ! 539 !$OMP PARALLEL DO PRIVATE(zt, zs, zh, zn) 534 540 DO jj = 1, jpjm1 535 541 DO ji = 1, fs_jpim1 ! vector opt. … … 583 589 CASE( -1, 0 ) !== polynomial TEOS-10 / EOS-80 ==! 584 590 ! 591 !$OMP PARALLEL DO PRIVATE(zh, zt, zs, ztm, zn3, zn2, zn1, zn0, zn) 585 592 DO jk = 1, jpkm1 586 593 DO jj = 1, jpj … … 640 647 CASE( 1 ) !== simplified EOS ==! 641 648 ! 649 !$OMP PARALLEL DO PRIVATE(zt, zs, zh, ztm, zn) 642 650 DO jk = 1, jpkm1 643 651 DO jj = 1, jpj … … 697 705 CASE( -1, 0 ) !== polynomial TEOS-10 / EOS-80 ==! 698 706 ! 707 !$OMP PARALLEL DO PRIVATE(zh, zt, zs, zn3, zn2, zn1, zn0, zn) 699 708 DO jj = 1, jpjm1 700 709 DO ji = 1, fs_jpim1 ! vector opt. … … 755 764 CASE( 1 ) !== simplified EOS ==! 756 765 ! 766 !$OMP PARALLEL DO PRIVATE(zt, zs, zh, zn) 757 767 DO jj = 1, jpjm1 758 768 DO ji = 1, fs_jpim1 ! vector opt. … … 910 920 IF( nn_timing == 1 ) CALL timing_start('bn2') 911 921 ! 922 !$OMP PARALLEL DO PRIVATE(zrw, zaw, zbw) 912 923 DO jk = 2, jpkm1 ! interior points only (2=< jk =< jpkm1 ) 913 924 DO jj = 1, jpj ! surface and bottom value set to zero one for all in istate.F90 … … 962 973 z1_T0 = 1._wp/40._wp 963 974 ! 975 !$OMP PARALLEL DO PRIVATE(zt, zs,ztm, zn, zd) 964 976 DO jj = 1, jpj 965 977 DO ji = 1, jpi … … 1016 1028 CASE ( -1, 1 ) !== CT,SA (TEOS-10 formulation) ==! 1017 1029 ! 1030 !$OMP PARALLEL DO PRIVATE(zs) 1018 1031 DO jj = 1, jpj 1019 1032 DO ji = 1, jpi … … 1023 1036 END DO 1024 1037 END DO 1025 ptf(:,:) = ptf(:,:) * psal(:,:) 1038 !$OMP PARALLEL DO 1039 DO jj = 1, jpj 1040 DO ji = 1, jpi 1041 ptf(ji,jj) = ptf(ji,jj) * psal(ji,jj) 1042 END DO 1043 END DO 1026 1044 ! 1027 1045 IF( PRESENT( pdep ) ) ptf(:,:) = ptf(:,:) - 7.53e-4 * pdep(:,:) … … 1029 1047 CASE ( 0 ) !== PT,SP (UNESCO formulation) ==! 1030 1048 ! 1031 ptf(:,:) = ( - 0.0575_wp + 1.710523e-3_wp * SQRT( psal(:,:) ) & 1032 & - 2.154996e-4_wp * psal(:,:) ) * psal(:,:) 1049 !$OMP PARALLEL DO 1050 DO jj = 1, jpj 1051 DO ji = 1, jpi 1052 ptf(ji,jj) = ( - 0.0575_wp + 1.710523e-3_wp * SQRT( psal(ji,jj) ) & 1053 & - 2.154996e-4_wp * psal(ji,jj) ) * psal(ji,jj) 1054 END DO 1055 END DO 1033 1056 ! 1034 1057 IF( PRESENT( pdep ) ) ptf(:,:) = ptf(:,:) - 7.53e-4 * pdep(:,:) … … 1125 1148 CASE( -1, 0 ) !== polynomial TEOS-10 / EOS-80 ==! 1126 1149 ! 1150 !$OMP PARALLEL DO PRIVATE(zh, zt, zs, ztm, zn2, zn1, zn0, zn) 1127 1151 DO jk = 1, jpkm1 1128 1152 DO jj = 1, jpj … … 1188 1212 CASE( 1 ) !== Vallis (2006) simplified EOS ==! 1189 1213 ! 1214 !$OMP PARALLEL DO PRIVATE(zt, zs, zh, ztm, zn) 1190 1215 DO jk = 1, jpkm1 1191 1216 DO jj = 1, jpj -
branches/UKMO/dev_r5518_GO6_package_OMP/NEMOGCM/NEMO/OPA_SRC/TRA/traadv_tvd.F90
r6795 r9176 120 120 ! -------------------------------------------------------------------- 121 121 ! upstream tracer flux in the i and j direction 122 !$OMP PARALLEL DO PRIVATE(zfp_ui, zfm_ui, zfp_vj, zfm_vj) 122 123 DO jk = 1, jpkm1 123 124 DO jj = 1, jpjm1 … … 133 134 END DO 134 135 END DO 135 136 !$OMP END PARALLEL DO 136 137 ! upstream tracer flux in the k direction 137 138 ! Interior value 139 !$OMP PARALLEL DO PRIVATE(zfp_wk, zfm_wk) 138 140 DO jk = 2, jpkm1 139 141 DO jj = 1, jpj … … 145 147 END DO 146 148 END DO 149 !$OMP END PARALLEL DO 147 150 ! Surface value 148 151 IF( lk_vvl ) THEN … … 158 161 ELSE 159 162 IF ( ln_isfcav ) THEN 163 !$OMP PARALLEL DO 160 164 DO jj = 1, jpj 161 165 DO ji = 1, jpi 162 166 zwz(ji,jj, mikt(ji,jj) ) = pwn(ji,jj,mikt(ji,jj)) * ptb(ji,jj,mikt(ji,jj),jn) ! linear free surface 163 167 END DO 164 END DO 168 END DO 169 !$OMP END PARALLEL DO 165 170 ELSE 166 171 zwz(:,:,1) = pwn(:,:,1) * ptb(:,:,1,jn) ! linear free surface … … 169 174 170 175 ! total advective trend 176 !$OMP PARALLEL DO PRIVATE(z2dtt, ztra) 171 177 DO jk = 1, jpkm1 172 178 z2dtt = p2dt(jk) … … 183 189 END DO 184 190 END DO 191 !$OMP END PARALLEL DO 185 192 ! ! Lateral boundary conditions on zwi (unchanged sign) 186 193 CALL lbc_lnk( zwi, 'T', 1. ) … … 200 207 ! -------------------------------------------------- 201 208 ! antidiffusive flux on i and j 209 !$OMP PARALLEL DO 202 210 DO jk = 1, jpkm1 203 211 DO jj = 1, jpjm1 … … 208 216 END DO 209 217 END DO 210 218 !$OMP END PARALLEL DO 211 219 ! antidiffusive flux on k 212 220 ! Interior value 221 !$OMP PARALLEL DO 213 222 DO jk = 2, jpkm1 214 223 DO jj = 1, jpj … … 218 227 END DO 219 228 END DO 229 !$OMP END PARALLEL DO 220 230 ! surface value 221 231 IF ( ln_isfcav ) THEN … … 238 248 ! 5. final trend with corrected fluxes 239 249 ! ------------------------------------ 250 !$OMP PARALLEL DO PRIVATE(zbtr, ztra) 240 251 DO jk = 1, jpkm1 241 252 DO jj = 2, jpjm1 … … 251 262 END DO 252 263 END DO 253 264 !$OMP END PARALLEL DO 254 265 ! ! trend diagnostics (contribution of upstream fluxes) 255 266 IF( l_trd ) THEN … … 356 367 ! -------------------------------------------------------------------- 357 368 ! upstream tracer flux in the i and j direction 369 !$OMP PARALLEL DO PRIVATE(zfp_ui, zfm_ui, zfp_vj, zfm_vj) 358 370 DO jk = 1, jpkm1 359 371 DO jj = 1, jpjm1 … … 369 381 END DO 370 382 END DO 371 383 !$OMP END PARALLEL DO 372 384 ! upstream tracer flux in the k direction 373 385 ! Interior value 386 !$OMP PARALLEL DO PRIVATE(zfp_wk, zfm_wk) 374 387 DO jk = 2, jpkm1 375 388 DO jj = 1, jpj … … 381 394 END DO 382 395 END DO 396 !$OMP END PARALLEL DO 383 397 ! Surface value 384 398 IF( lk_vvl ) THEN … … 394 408 ELSE 395 409 IF ( ln_isfcav ) THEN 410 !$OMP PARALLEL DO 396 411 DO jj = 1, jpj 397 412 DO ji = 1, jpi … … 399 414 END DO 400 415 END DO 416 !$OMP END PARALLEL DO 401 417 ELSE 402 418 zwz(:,:,1) = pwn(:,:,1) * ptb(:,:,1,jn) ! linear free surface + no isf … … 405 421 406 422 ! total advective trend 423 !$OMP PARALLEL DO PRIVATE(z2dtt, ztra) 407 424 DO jk = 1, jpkm1 408 425 z2dtt = p2dt(jk) … … 419 436 END DO 420 437 END DO 438 !$OMP END PARALLEL DO 421 439 ! ! Lateral boundary conditions on zwi (unchanged sign) 422 440 CALL lbc_lnk( zwi, 'T', 1. ) … … 437 455 ! antidiffusive flux on i and j 438 456 ! 457 !$OMP PARALLEL DO 439 458 DO jk = 1, jpkm1 440 459 ! … … 463 482 END DO 464 483 END DO 465 484 !$OMP END PARALLEL DO 466 485 ! antidiffusive flux on k 467 486 zwz(:,:,1) = 0._wp ! Surface value … … 489 508 jta = MOD(jta,3) + 1 490 509 ENDIF 510 !$OMP PARALLEL DO 491 511 DO jk = 2, jpkm1 ! Interior value 492 512 DO jj = 2, jpjm1 … … 497 517 END DO 498 518 END DO 499 519 !$OMP END PARALLEL DO 500 520 jtaken = MOD( jtaken + 1 , 2 ) 501 521 !$OMP PARALLEL DO PRIVATE (zbtr, ztra) 502 522 DO jk = 2, jpkm1 ! Interior value 503 523 DO jj = 2, jpjm1 … … 510 530 END DO 511 531 END DO 512 513 END DO 514 532 !$OMP END PARALLEL DO 533 END DO 534 !$OMP PARALLEL DO 515 535 DO jk = 2, jpkm1 ! Anti-diffusive vertical flux using average flux from the sub-timestepping 516 536 DO jj = 2, jpjm1 … … 520 540 END DO 521 541 END DO 542 !$OMP END PARALLEL DO 522 543 CALL lbc_lnk( zwx, 'U', -1. ) ; CALL lbc_lnk( zwy, 'V', -1. ) ! Lateral bondary conditions 523 544 CALL lbc_lnk( zwz, 'W', 1. ) … … 530 551 ! 5. final trend with corrected fluxes 531 552 ! ------------------------------------ 553 !$OMP PARALLEL DO PRIVATE(zbtr, ztra) 532 554 DO jk = 1, jpkm1 533 555 DO jj = 2, jpjm1 … … 543 565 END DO 544 566 END DO 545 567 !$OMP END PARALLEL DO 546 568 ! ! trend diagnostics (contribution of upstream fluxes) 547 569 IF( l_trd ) THEN … … 612 634 & paft * tmask + zbig * ( 1._wp - tmask ) ) 613 635 636 !$OMP PARALLEL DO PRIVATE(ikm1, z2dtt, zup, zdo, zpos, zneg, zbt) 614 637 DO jk = 1, jpkm1 615 638 ikm1 = MAX(jk-1,1) … … 647 670 END DO 648 671 END DO 672 !$OMP END PARALLEL DO 649 673 CALL lbc_lnk( zbetup, 'T', 1. ) ; CALL lbc_lnk( zbetdo, 'T', 1. ) ! lateral boundary cond. (unchanged sign) 650 674 651 675 ! 3. monotonic flux in the i & j direction (paa & pbb) 652 676 ! ---------------------------------------- 677 !$OMP PARALLEL DO PRIVATE(zau, zbu, zcu, zav, zbv, zcv, za, zb, zc) 653 678 DO jk = 1, jpkm1 654 679 DO jj = 2, jpjm1 … … 673 698 END DO 674 699 END DO 700 !$OMP END PARALLEL DO 675 701 CALL lbc_lnk( paa, 'U', -1. ) ; CALL lbc_lnk( pbb, 'V', -1. ) ! lateral boundary condition (changed sign) 676 702 ! -
branches/UKMO/dev_r5518_GO6_package_OMP/NEMOGCM/NEMO/OPA_SRC/TRA/trabbc.F90
r6486 r9176 89 89 ! 90 90 ! ! Add the geothermal heat flux trend on temperature 91 !$OMP PARALLEL DO PRIVATE(ik, zqgh_trd) 91 92 DO jj = 2, jpjm1 92 93 DO ji = 2, jpim1 -
branches/UKMO/dev_r5518_GO6_package_OMP/NEMOGCM/NEMO/OPA_SRC/TRA/traldf_iso.F90
r6486 r9176 108 108 REAL(wp) :: zmskv, zabe2, zcof2, zcoef4 ! - - 109 109 REAL(wp) :: zcoef0, zbtr, ztra ! - - 110 REAL(wp), POINTER, DIMENSION(:,:) :: z2d110 REAL(wp), DIMENSION(jpi,jpj ) :: z2d 111 111 REAL(wp), POINTER, DIMENSION(:,:,:) :: zdkt, zdk1t, zdit, zdjt, ztfw 112 112 !!---------------------------------------------------------------------- … … 114 114 IF( nn_timing == 1 ) CALL timing_start('tra_ldf_iso') 115 115 ! 116 116 ! CALL wrk_alloc( jpi, jpj, z2d ) 117 117 CALL wrk_alloc( jpi, jpj, jpk, zdit, zdjt, ztfw, zdkt, zdk1t ) 118 118 ! … … 137 137 138 138 ! Horizontal tracer gradient 139 !$OMP PARALLEL DO 139 140 DO jk = 1, jpkm1 140 141 DO jj = 1, jpjm1 … … 145 146 END DO 146 147 END DO 148 !$OMP END PARALLEL DO 147 149 148 150 ! partial cell correction 149 151 IF( ln_zps ) THEN ! partial steps correction at the last ocean level 152 !$OMP PARALLEL DO 150 153 DO jj = 1, jpjm1 151 154 DO ji = 1, fs_jpim1 ! vector opt. … … 157 160 ENDIF 158 161 IF( ln_zps .AND. ln_isfcav ) THEN ! partial steps correction at the first wet level beneath a cavity 162 !$OMP PARALLEL DO 159 163 DO jj = 1, jpjm1 160 164 DO ji = 1, fs_jpim1 ! vector opt. … … 173 177 ! 174 178 ! interior value 179 !$OMP PARALLEL DO 175 180 DO jk = 2, jpkm1 176 181 DO jj = 1, jpj … … 182 187 END DO 183 188 END DO 189 !$OMP END PARALLEL DO 184 190 ! surface boundary condition: zdkt(jk=1)=zdkt(jk=2) 185 191 zdk1t(:,:,1) = ( ptb(:,:,1,jn ) - ptb(:,:,2,jn) ) * wmask(:,:,2) 186 192 zdkt (:,:,1) = zdk1t(:,:,1) 187 193 IF ( ln_isfcav ) THEN 194 !$OMP PARALLEL DO PRIVATE(ikt) 188 195 DO jj = 1, jpj 189 196 DO ji = 1, jpi ! vector opt. … … 193 200 END DO 194 201 END DO 202 !$OMP END PARALLEL DO 195 203 END IF 196 204 197 205 ! 2. Horizontal fluxes 198 206 ! -------------------- 207 !$OMP PARALLEL DO PRIVATE(zabe1, zabe2, zmsku, zmskv, zcof1, zcof2, zbtr, ztra) 199 208 DO jk = 1, jpkm1 200 209 DO jj = 1 , jpjm1 … … 233 242 END DO ! End of slab 234 243 ! ! =============== 244 !$OMP END PARALLEL DO 235 245 ! 236 246 ! "Poleward" diffusive heat or salt transports (T-S case only) … … 245 255 IF( cdtype == 'TRA' .AND. jn == jp_tem ) THEN 246 256 z2d(:,:) = 0._wp 257 !$OMP PARALLEL DO REDUCTION(+:z2d) 247 258 DO jk = 1, jpkm1 248 259 DO jj = 2, jpjm1 … … 252 263 END DO 253 264 END DO 265 254 266 z2d(:,:) = - rau0_rcp * z2d(:,:) ! note sign is reversed to give down-gradient diffusive transports (#1043) 267 255 268 CALL lbc_lnk( z2d, 'U', -1. ) 256 269 CALL iom_put( "udiff_heattr", z2d ) ! heat transport in i-direction 257 270 ! 258 271 z2d(:,:) = 0._wp 272 !$OMP PARALLEL DO REDUCTION(+:z2d) 259 273 DO jk = 1, jpkm1 260 274 DO jj = 2, jpjm1 … … 264 278 END DO 265 279 END DO 280 266 281 z2d(:,:) = - rau0_rcp * z2d(:,:) ! note sign is reversed to give down-gradient diffusive transports (#1043) 267 282 CALL lbc_lnk( z2d, 'V', -1. ) … … 286 301 287 302 ! interior (2=<jk=<jpk-1) 303 !$OMP PARALLEL DO PRIVATE(zcoef0, zmsku, zmskv, zcoef3, zcoef4 ) 288 304 DO jk = 2, jpkm1 289 305 DO jj = 2, jpjm1 … … 306 322 END DO 307 323 END DO 308 324 !$OMP END PARALLEL DO 309 325 310 326 ! I.5 Divergence of vertical fluxes added to the general tracer trend 311 327 ! ------------------------------------------------------------------- 328 !$OMP PARALLEL DO PRIVATE(zbtr, ztra) 312 329 DO jk = 1, jpkm1 313 330 DO jj = 2, jpjm1 … … 319 336 END DO 320 337 END DO 338 !$OMP END PARALLEL DO 321 339 ! 322 340 END DO 323 341 ! 324 342 ! CALL wrk_dealloc( jpi, jpj, z2d ) 325 343 CALL wrk_dealloc( jpi, jpj, jpk, zdit, zdjt, ztfw, zdkt, zdk1t ) 326 344 ! -
branches/UKMO/dev_r5518_GO6_package_OMP/NEMOGCM/NEMO/OPA_SRC/TRA/tranxt.F90
r6487 r9176 153 153 ! trends computation 154 154 IF( l_trdtra ) THEN ! trend of the Asselin filter (tb filtered - tb)/dt 155 !$OMP PARALLEL DO PRIVATE(zfact) 155 156 DO jk = 1, jpkm1 156 157 zfact = 1._wp / r2dtra(jk) … … 304 305 ! 305 306 DO jn = 1, kjpt 307 !$OMP PARALLEL DO PRIVATE(zfact1, zfact2, ze3t_b, ze3t_n, ze3t_a, ztc_b, ztc_n, ztc_a, ze3t_d, ztc_d, & 308 !$OMP& ze3t_f, ztc_f, ze3t_d) 306 309 DO jk = 1, jpkm1 307 310 zfact1 = atfp * p2dt(jk) -
branches/UKMO/dev_r5518_GO6_package_OMP/NEMOGCM/NEMO/OPA_SRC/TRA/trazdf_imp.F90
r6486 r9176 129 129 ! isoneutral diffusion: add the contribution 130 130 IF( ln_traldf_grif ) THEN ! Griffies isoneutral diff 131 !$OMP PARALLEL DO 131 132 DO jk = 2, jpkm1 132 133 DO jj = 2, jpjm1 … … 137 138 END DO 138 139 ELSE IF( l_traldf_rot ) THEN ! standard isoneutral diff 140 !$OMP PARALLEL DO 139 141 DO jk = 2, jpkm1 140 142 DO jj = 2, jpjm1 … … 149 151 #endif 150 152 ! Diagonal, lower (i), upper (s) (including the bottom boundary condition since avt is masked) 153 !$OMP PARALLEL DO PRIVATE(ze3ta, ze3tn) 151 154 DO jk = 1, jpkm1 152 155 DO jj = 2, jpjm1 … … 187 190 END DO 188 191 END DO 192 193 !$OMP PARALLEL 189 194 DO jk = 2, jpkm1 195 !$OMP DO 190 196 DO jj = 2, jpjm1 191 197 DO ji = fs_2, fs_jpim1 … … 193 199 END DO 194 200 END DO 195 END DO 201 !$OMP END DO 202 END DO 203 !$OMP END PARALLEL 196 204 ! 197 205 END IF 198 206 ! 199 207 ! second recurrence: Zk = Yk - Ik / Tk-1 Zk-1 208 !$OMP PARALLEL DO PRIVATE(ze3tb, ze3tn) 200 209 DO jj = 2, jpjm1 201 210 DO ji = fs_2, fs_jpim1 … … 206 215 END DO 207 216 END DO 217 218 !$OMP PARALLEL 208 219 DO jk = 2, jpkm1 220 !$OMP DO PRIVATE(ze3tb, ze3tn, zrhs) 209 221 DO jj = 2, jpjm1 210 222 DO ji = fs_2, fs_jpim1 … … 215 227 END DO 216 228 END DO 217 END DO 218 229 !$OMP END DO 230 END DO 231 !$OMP END PARALLEL 219 232 ! third recurrence: Xk = (Zk - Sk Xk+1 ) / Tk (result is the after tracer) 233 !$OMP PARALLEL 234 !$OMP DO 220 235 DO jj = 2, jpjm1 221 236 DO ji = fs_2, fs_jpim1 … … 223 238 END DO 224 239 END DO 240 225 241 DO jk = jpk-2, 1, -1 242 !$OMP DO 226 243 DO jj = 2, jpjm1 227 244 DO ji = fs_2, fs_jpim1 … … 230 247 END DO 231 248 END DO 232 END DO 249 !$OMP END DO 250 END DO 251 !$OMP END PARALLEL 233 252 ! ! ================= ! 234 253 END DO ! end tracer loop ! -
branches/UKMO/dev_r5518_GO6_package_OMP/NEMOGCM/NEMO/OPA_SRC/TRD/trdtra.F90
r6486 r9176 127 127 zwt(:,:, 1 ) = 0._wp ; zws(:,:, 1 ) = 0._wp ! vertical diffusive fluxes 128 128 zwt(:,:,jpk) = 0._wp ; zws(:,:,jpk) = 0._wp 129 !$OMP PARALLEL DO 129 130 DO jk = 2, jpk 130 131 zwt(:,:,jk) = avt(:,:,jk) * ( tsa(:,:,jk-1,jp_tem) - tsa(:,:,jk,jp_tem) ) / fse3w(:,:,jk) * tmask(:,:,jk) … … 133 134 ! 134 135 ztrdt(:,:,jpk) = 0._wp ; ztrds(:,:,jpk) = 0._wp 136 !$OMP PARALLEL DO 135 137 DO jk = 1, jpkm1 136 138 ztrdt(:,:,jk) = ( zwt(:,:,jk) - zwt(:,:,jk+1) ) / fse3t(:,:,jk) … … 142 144 ! 143 145 CASE DEFAULT ! other trends: mask and send T & S trends to trd_tra_mng 144 ztrds(:,:,:) = ptrd(:,:,:) * tmask(:,:,:) 146 !$OMP PARALLEL DO 147 DO jk = 1, jpk 148 ztrds(:,:,jk) = ptrd(:,:,jk) * tmask(:,:,jk) 149 ENDDO 145 150 CALL trd_tra_mng( trdt, ztrds, ktrd, kt ) 146 151 END SELECT … … 200 205 ptrd(:,:,jpk) = 0._wp 201 206 ! 207 !$OMP PARALLEL DO 202 208 DO jk = 1, jpkm1 ! advective trend 203 209 DO jj = 2, jpjm1 -
branches/UKMO/dev_r5518_GO6_package_OMP/NEMOGCM/NEMO/OPA_SRC/ZDF/zdfevd.F90
r6486 r9176 77 77 zavm_evd(:,:,:) = avm(:,:,:) ! set avm prior to evd application 78 78 ! 79 !$OMP PARALLEL DO 79 80 DO jk = 1, jpkm1 80 81 DO jj = 2, jpj ! no vector opt. … … 103 104 ! 104 105 CASE DEFAULT ! enhance vertical eddy diffusivity only (if rn2<-1.e-12) 106 !$OMP PARALLEL DO 105 107 DO jk = 1, jpkm1 106 108 !!! WHERE( rn2(:,:,jk) <= -1.e-12 ) avt(:,:,jk) = tmask(:,:,jk) * avevd ! agissant sur T SEUL! -
branches/UKMO/dev_r5518_GO6_package_OMP/NEMOGCM/NEMO/OPA_SRC/ZDF/zdftke.F90
r6498 r9176 227 227 REAL(wp) :: zbbrau, zesh2 ! temporary scalars 228 228 REAL(wp) :: zfact1, zfact2, zfact3 ! - - 229 REAL(wp) :: ztx2 , zty2 , zcof 230 REAL(wp) :: ztau , zdif 229 REAL(wp) :: ztx2 , zty2 , zcof, zcofa ! - - 230 REAL(wp) :: ztau , zdif, zdifa ! - - 231 231 REAL(wp) :: zus , zwlc , zind ! - - 232 232 REAL(wp) :: zzd_up, zzd_lw ! - - … … 253 253 ! !<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<< 254 254 IF ( ln_isfcav ) THEN 255 !$OMP PARALLEL DO 255 256 DO jj = 2, jpjm1 ! en(mikt(ji,jj)) = rn_emin 256 257 DO ji = fs_2, fs_jpim1 ! vector opt. … … 259 260 END DO 260 261 END IF 262 !$OMP PARALLEL DO 261 263 DO jj = 2, jpjm1 ! en(1) = rn_ebb taum / rau0 (min value rn_emin0) 262 264 DO ji = fs_2, fs_jpim1 ! vector opt. … … 296 298 ! !* total energy produce by LC : cumulative sum over jk 297 299 zpelc(:,:,1) = MAX( rn2b(:,:,1), 0._wp ) * fsdepw(:,:,1) * fse3w(:,:,1) 300 !$OMP PARALLEL 298 301 DO jk = 2, jpk 299 zpelc(:,:,jk) = zpelc(:,:,jk-1) + MAX( rn2b(:,:,jk), 0._wp ) * fsdepw(:,:,jk) * fse3w(:,:,jk) 300 END DO 302 !$OMP DO 303 DO jj = 1, jpj 304 zpelc(:,jj,jk) = zpelc(:,jj,jk-1) + MAX( rn2b(:,jj,jk), 0._wp ) * fsdepw(:,jj,jk) * fse3w(:,jj,jk) 305 END DO 306 !$OMP END DO 307 END DO 308 !$OMP END PARALLEL 301 309 ! !* finite Langmuir Circulation depth 302 310 zcof = 0.5 * 0.016 * 0.016 / ( zrhoa * zcdrag ) 311 zcofa = 0.016 / SQRT( zrhoa * zcdrag ) 303 312 imlc(:,:) = mbkt(:,:) + 1 ! Initialization to the number of w ocean point (=2 over land) 313 !$OMP PARALLEL SHARED(imlc) 304 314 DO jk = jpkm1, 2, -1 315 !$OMP DO PRIVATE(zus) 305 316 DO jj = 1, jpj ! Last w-level at which zpelc>=0.5*us*us 306 317 DO ji = 1, jpi ! with us=0.016*wind(starting from jpk-1) … … 309 320 END DO 310 321 END DO 322 !$OMP END DO 311 323 END DO 312 324 ! ! finite LC depth 325 !$OMP DO 313 326 DO jj = 1, jpj 314 327 DO ji = 1, jpi … … 316 329 END DO 317 330 END DO 318 zcof = 0.016 / SQRT( zrhoa * zcdrag ) 319 !CDIR NOVERRCHK 331 !$OMP END DO 332 ! zcof = 0.016 / SQRT( zrhoa * zcdrag ) 333 !$OMP DO PRIVATE(zus, zind, zwlc) 320 334 DO jk = 2, jpkm1 !* TKE Langmuir circulation source term added to en 321 !CDIR NOVERRCHK 322 DO jj = 2, jpjm1 323 !CDIR NOVERRCHK 324 DO ji = fs_2, fs_jpim1 ! vector opt. 325 zus = zcof * SQRT( taum(ji,jj) ) ! Stokes drift 335 DO jj = 2, jpjm1 336 DO ji = fs_2, fs_jpim1 ! vector opt. 337 zus = zcofa * SQRT( taum(ji,jj) ) ! Stokes drift 326 338 ! ! vertical velocity due to LC 327 339 zind = 0.5 - SIGN( 0.5, fsdepw(ji,jj,jk) - zhlc(ji,jj) ) … … 333 345 END DO 334 346 END DO 347 !$OMP END DO 348 !$OMP END PARALLEL 335 349 ! 336 350 ENDIF … … 343 357 ! ! zdiag : diagonal zd_up : upper diagonal zd_lw : lower diagonal 344 358 ! 359 !$OMP PARALLEL DO 345 360 DO jk = 2, jpkm1 !* Shear production at uw- and vw-points (energy conserving form) 346 361 DO jj = 1, jpj ! here avmu, avmv used as workspace … … 358 373 END DO 359 374 ! 375 !$OMP PARALLEL DO PRIVATE(zcof, zzd_up, zzd_lw, zesh2) 360 376 DO jk = 2, jpkm1 !* Matrix and right hand side in en 361 377 DO jj = 2, jpjm1 … … 390 406 END DO 391 407 ! !* Matrix inversion from level 2 (tke prescribed at level 1) 408 !$OMP PARALLEL 392 409 DO jk = 3, jpkm1 ! First recurrence : Dk = Dk - Lk * Uk-1 / Dk-1 410 !$OMP DO 393 411 DO jj = 2, jpjm1 394 412 DO ji = fs_2, fs_jpim1 ! vector opt. … … 396 414 END DO 397 415 END DO 398 END DO 416 !$OMP END DO 417 END DO 418 !$OMP END PARALLEL 399 419 ! 400 420 ! Second recurrence : Lk = RHSk - Lk / Dk-1 * Lk-1 421 !$OMP PARALLEL DO 401 422 DO jj = 2, jpjm1 402 423 DO ji = fs_2, fs_jpim1 ! vector opt. … … 404 425 END DO 405 426 END DO 427 !$OMP PARALLEL 406 428 DO jk = 3, jpkm1 429 !$OMP DO 407 430 DO jj = 2, jpjm1 408 431 DO ji = fs_2, fs_jpim1 ! vector opt. … … 410 433 END DO 411 434 END DO 412 END DO 435 !$OMP END DO 436 END DO 437 !$OMP END PARALLEL 413 438 ! 414 439 ! thrid recurrence : Ek = ( Lk - Uk * Ek+1 ) / Dk 440 !$OMP PARALLEL DO 415 441 DO jj = 2, jpjm1 416 442 DO ji = fs_2, fs_jpim1 ! vector opt. … … 418 444 END DO 419 445 END DO 446 !$OMP PARALLEL 420 447 DO jk = jpk-2, 2, -1 448 !$OMP DO 421 449 DO jj = 2, jpjm1 422 450 DO ji = fs_2, fs_jpim1 ! vector opt. … … 424 452 END DO 425 453 END DO 426 END DO 454 !$OMP END DO 455 END DO 456 !$OMP END PARALLEL 457 !$OMP PARALLEL DO 427 458 DO jk = 2, jpkm1 ! set the minimum value of tke 428 459 DO jj = 2, jpjm1 … … 440 471 ! !<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<< 441 472 IF( nn_htau == 2 ) THEN !* mixed-layer depth dependant length scale 473 !$OMP PARALLEL DO 442 474 DO jj = 2, jpjm1 443 475 DO ji = fs_2, fs_jpim1 ! vector opt. … … 452 484 ! 453 485 IF( nn_etau == 1 ) THEN !* penetration below the mixed layer (rn_efr fraction) 486 !$OMP PARALLEL DO 454 487 DO jk = 2, jpkm1 455 488 DO jj = 2, jpjm1 … … 461 494 END DO 462 495 ELSEIF( nn_etau == 2 ) THEN !* act only at the base of the mixed layer (jk=nmln) (rn_efr fraction) 496 !$OMP PARALLEL DO PRIVATE(jk) 463 497 DO jj = 2, jpjm1 464 498 DO ji = fs_2, fs_jpim1 ! vector opt. … … 469 503 END DO 470 504 ELSEIF( nn_etau == 3 ) THEN !* penetration belox the mixed layer (HF variability) 471 ! CDIR NOVERRCHK505 !$OMP PARALLEL DO PRIVATE(ztx2, zty2, ztau, zdif, zdifa) 472 506 DO jk = 2, jpkm1 473 !CDIR NOVERRCHK 474 DO jj = 2, jpjm1 475 !CDIR NOVERRCHK 507 DO jj = 2, jpjm1 476 508 DO ji = fs_2, fs_jpim1 ! vector opt. 477 509 ztx2 = utau(ji-1,jj ) + utau(ji,jj) 478 510 zty2 = vtau(ji ,jj-1) + vtau(ji,jj) 479 511 ztau = 0.5_wp * SQRT( ztx2 * ztx2 + zty2 * zty2 ) * tmask(ji,jj,1) ! module of the mean stress 480 zdif = taum(ji,jj) - ztau ! mean of modulus - modulus of the mean481 zdif = rhftau_scl * MAX( 0._wp, zdif + rhftau_add ) ! apply some modifications...512 zdifa = taum(ji,jj) - ztau ! mean of modulus - modulus of the mean 513 zdif = rhftau_scl * MAX( 0._wp, zdifa + rhftau_add ) ! apply some modifications... 482 514 en(ji,jj,jk) = en(ji,jj,jk) + zbbrau * zdif * EXP( -fsdepw(ji,jj,jk) / htau(ji,jj) ) & 483 515 & * ( 1._wp - fr_i(ji,jj) ) * wmask(ji,jj,jk) * tmask(ji,jj,1) … … 487 519 ELSEIF( nn_etau == 4 ) THEN !* column integral independant of htau (rn_efr must be scaled up) 488 520 IF( nn_htau == 2 ) THEN ! efr dependant on time-varying htau 521 !$OMP PARALLEL DO 489 522 DO jj = 2, jpjm1 490 523 DO ji = fs_2, fs_jpim1 ! vector opt. … … 493 526 END DO 494 527 ENDIF 528 !$OMP PARALLEL DO 495 529 DO jk = 2, jpkm1 496 530 DO jj = 2, jpjm1 … … 504 538 CALL lbc_lnk( en, 'W', 1. ) ! Lateral boundary conditions (sign unchanged) 505 539 ! 540 !$OMP PARALLEL DO 506 541 DO jk = 2, jpkm1 ! TKE budget: near-inertial waves term 507 542 DO jj = 2, jpjm1 … … 580 615 ! 581 616 IF( ln_mxl0 ) THEN ! surface mixing length = F(stress) : l=vkarmn*2.e5*taum/(rau0*g) 617 !$OMP PARALLEL DO PRIVATE(zraug) 582 618 DO jj = 2, jpjm1 583 619 DO ji = fs_2, fs_jpim1 … … 590 626 ENDIF 591 627 ! 592 ! CDIR NOVERRCHK628 !$OMP PARALLEL DO PRIVATE(zrn2) 593 629 DO jk = 2, jpkm1 ! interior value : l=sqrt(2*e/n^2) 594 !CDIR NOVERRCHK595 630 DO jj = 2, jpjm1 596 !CDIR NOVERRCHK597 631 DO ji = fs_2, fs_jpim1 ! vector opt. 598 632 zrn2 = MAX( rn2(ji,jj,jk), rsmall ) … … 611 645 ! where wmask = 0 set zmxlm == fse3w 612 646 CASE ( 0 ) ! bounded by the distance to surface and bottom 647 !$OMP PARALLEL DO PRIVATE(zemxl) 613 648 DO jk = 2, jpkm1 614 649 DO jj = 2, jpjm1 … … 624 659 ! 625 660 CASE ( 1 ) ! bounded by the vertical scale factor 661 !$OMP PARALLEL DO PRIVATE(zemxl) 626 662 DO jk = 2, jpkm1 627 663 DO jj = 2, jpjm1 … … 635 671 ! 636 672 CASE ( 2 ) ! |dk[xml]| bounded by e3t : 673 !$OMP PARALLEL 637 674 DO jk = 2, jpkm1 ! from the surface to the bottom : 675 !$OMP DO 638 676 DO jj = 2, jpjm1 639 677 DO ji = fs_2, fs_jpim1 ! vector opt. … … 643 681 END DO 644 682 DO jk = jpkm1, 2, -1 ! from the bottom to the surface : 683 !$OMP DO PRIVATE(zemxl) 645 684 DO jj = 2, jpjm1 646 685 DO ji = fs_2, fs_jpim1 ! vector opt. … … 651 690 END DO 652 691 END DO 692 !$OMP END PARALLEL 653 693 ! 654 694 CASE ( 3 ) ! lup and ldown, |dk[xml]| bounded by e3t : 695 !$OMP PARALLEL 655 696 DO jk = 2, jpkm1 ! from the surface to the bottom : lup 697 !$OMP DO 656 698 DO jj = 2, jpjm1 657 699 DO ji = fs_2, fs_jpim1 ! vector opt. … … 661 703 END DO 662 704 DO jk = jpkm1, 2, -1 ! from the bottom to the surface : ldown 705 !$OMP DO 663 706 DO jj = 2, jpjm1 664 707 DO ji = fs_2, fs_jpim1 ! vector opt. … … 667 710 END DO 668 711 END DO 669 ! CDIR NOVERRCHK712 !$OMP DO PRIVATE(zemlm, zemlp) 670 713 DO jk = 2, jpkm1 671 !CDIR NOVERRCHK 672 DO jj = 2, jpjm1 673 !CDIR NOVERRCHK 714 DO jj = 2, jpjm1 674 715 DO ji = fs_2, fs_jpim1 ! vector opt. 675 716 zemlm = MIN ( zmxld(ji,jj,jk), zmxlm(ji,jj,jk) ) … … 680 721 END DO 681 722 END DO 723 !$OMP END PARALLEL 682 724 ! 683 725 END SELECT … … 691 733 ! ! Vertical eddy viscosity and diffusivity (avmu, avmv, avt) 692 734 ! !<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<< 693 !CDIR NOVERRCHK694 735 DO jk = 1, jpkm1 !* vertical eddy viscosity & diffivity at w-points 695 !CDIR NOVERRCHK696 736 DO jj = 2, jpjm1 697 !CDIR NOVERRCHK698 737 DO ji = fs_2, fs_jpim1 ! vector opt. 699 738 zsqen = SQRT( en(ji,jj,jk) ) … … 894 933 ENDIF 895 934 ! !* set vertical eddy coef. to the background value 935 !$OMP PARALLEL DO 896 936 DO jk = 1, jpk 897 937 avt (:,:,jk) = avtb(jk) * wmask (:,:,jk) … … 959 999 ELSE !* Start from rest 960 1000 en(:,:,:) = rn_emin * tmask(:,:,:) 1001 !$OMP PARALLEL DO 961 1002 DO jk = 1, jpk ! set the Kz to the background value 962 1003 avt (:,:,jk) = avtb(jk) * wmask (:,:,jk) -
branches/UKMO/dev_r5518_GO6_package_OMP/NEMOGCM/NEMO/OPA_SRC/ZDF/zdftmx.F90
r6498 r9176 111 111 INTEGER :: ji, jj, jk ! dummy loop indices 112 112 REAL(wp) :: ztpc ! scalar workspace 113 REAL(wp), POINTER, DIMENSION(:,:) :: zkz113 REAL(wp), DIMENSION(jpi,jpj) :: zkz 114 114 !!---------------------------------------------------------------------- 115 115 ! 116 116 IF( nn_timing == 1 ) CALL timing_start('zdf_tmx') 117 117 ! 118 118 ! CALL wrk_alloc( jpi,jpj, zkz ) 119 119 120 120 ! ! ----------------------- ! … … 128 128 zkz(:,:) = zkz(:,:) + fse3w(:,:,jk) * MAX( 0.e0, rn2(:,:,jk) ) * rau0 * zav_tide(:,:,jk) * wmask(:,:,jk) 129 129 END DO 130 131 130 DO jj = 1, jpj !* Here zkz should be equal to en_tmx ==> multiply by en_tmx/zkz to recover en_tmx 132 131 DO ji = 1, jpi … … 134 133 END DO 135 134 END DO 136 137 135 DO jk = 2, jpkm1 !* Mutiply by zkz to recover en_tmx, BUT bound by 30/6 ==> zav_tide bound by 300 cm2/s 138 136 DO jj = 1, jpj !* Here zkz should be equal to en_tmx ==> multiply by en_tmx/zkz to recover en_tmx … … 142 140 END DO 143 141 END DO 144 145 142 IF( kt == nit000 ) THEN !* check at first time-step: diagnose the energy consumed by zav_tide 146 143 ztpc = 0.e0 … … 166 163 ! ! Update mixing coefs ! 167 164 ! ! ----------------------- ! 165 !$OMP PARALLEL DO 168 166 DO jk = 2, jpkm1 !* update momentum & tracer diffusivity with tidal mixing 169 167 DO jj = 1, jpj !* Here zkz should be equal to en_tmx ==> multiply by en_tmx/zkz to recover en_tmx … … 174 172 END DO 175 173 END DO 176 174 !$OMP PARALLEL DO 177 175 DO jk = 2, jpkm1 !* update momentum & tracer diffusivity with tidal mixing 178 176 DO jj = 2, jpjm1 … … 190 188 IF(ln_ctl) CALL prt_ctl(tab3d_1=zav_tide , clinfo1=' tmx - av_tide: ', tab3d_2=avt, clinfo2=' avt: ', ovlap=1, kdim=jpk) 191 189 ! 192 190 ! CALL wrk_dealloc( jpi,jpj, zkz ) 193 191 ! 194 192 IF( nn_timing == 1 ) CALL timing_stop('zdf_tmx') … … 222 220 INTEGER :: ji, jj, jk ! dummy loop indices 223 221 REAL(wp) :: zcoef, ztpc ! temporary scalar 224 REAL(wp), DIMENSION( :,:) , POINTER:: zkz ! 2D workspace225 REAL(wp), DIMENSION( :,:) , POINTER:: zsum1 , zsum2 , zsum ! - -222 REAL(wp), DIMENSION(jpi, jpj) :: zkz ! 2D workspace 223 REAL(wp), DIMENSION(jpi, jpj) :: zsum1 , zsum2 , zsum ! - - 226 224 REAL(wp), DIMENSION(:,:,:), POINTER :: zempba_3d_1, zempba_3d_2 ! 3D workspace 227 225 REAL(wp), DIMENSION(:,:,:), POINTER :: zempba_3d , zdn2dz ! - - … … 231 229 IF( nn_timing == 1 ) CALL timing_start('tmx_itf') 232 230 ! 233 231 ! CALL wrk_alloc( jpi,jpj, zkz, zsum1 , zsum2 , zsum ) 234 232 CALL wrk_alloc( jpi,jpj,jpk, zempba_3d_1, zempba_3d_2, zempba_3d, zdn2dz, zavt_itf ) 235 233 … … 237 235 zempba_3d_1(:,:,jpk) = 0.e0 238 236 zempba_3d_2(:,:,jpk) = 0.e0 237 !$OMP PARALLEL DO 239 238 DO jk = 1, jpkm1 240 239 zdn2dz (:,:,jk) = rn2(:,:,jk) - rn2(:,:,jk+1) ! Vertical profile of dN2/dz 241 !CDIR NOVERRCHK242 240 zempba_3d_1(:,:,jk) = SQRT( MAX( 0.e0, rn2(:,:,jk) ) ) ! - - of N 243 241 zempba_3d_2(:,:,jk) = MAX( 0.e0, rn2(:,:,jk) ) ! - - of N^2 … … 257 255 END DO 258 256 END DO 259 260 257 DO jk= 1, jpk 261 258 DO jj = 1, jpj … … 313 310 314 311 ! ! Update pav with the ITF mixing coefficient 312 !$OMP PARALLEL DO 315 313 DO jk = 2, jpkm1 316 314 pav(:,:,jk) = pav (:,:,jk) * ( 1.e0 - mask_itf(:,:) ) & … … 318 316 END DO 319 317 ! 320 318 ! CALL wrk_dealloc( jpi,jpj, zkz, zsum1 , zsum2 , zsum ) 321 319 CALL wrk_dealloc( jpi,jpj,jpk, zempba_3d_1, zempba_3d_2, zempba_3d, zdn2dz, zavt_itf ) 322 320 ! -
branches/UKMO/dev_r5518_GO6_package_OMP/NEMOGCM/NEMO/OPA_SRC/lib_fortran.F90
r6486 r9176 27 27 PUBLIC DDPDD ! also used in closea module 28 28 PUBLIC glob_min, glob_max 29 PUBLIC glob_asum_2d 29 30 #if defined key_nosignedzero 30 31 PUBLIC SIGN … … 189 190 END FUNCTION glob_sum_1d 190 191 191 FUNCTION glob_sum_2d( ptab )192 !!---------------------------------------------------------------------- 193 !! *** FUNCTION glob_sum_2d***192 FUNCTION sum_2d_ref( ptab ) 193 !!---------------------------------------------------------------------- 194 !! *** FUNCTION sum_2d_ref *** 194 195 !! 195 196 !! ** Purpose : perform a sum in calling DDPDD routine 196 197 !!---------------------------------------------------------------------- 197 198 REAL(wp), INTENT(in), DIMENSION(:,:) :: ptab 198 REAL(wp) :: glob_sum_2d! global masked sum199 COMPLEX(wp) :: sum_2d_ref ! global masked sum 199 200 !! 200 201 COMPLEX(wp):: ctmp 201 202 REAL(wp) :: ztmp 203 !$ COMPLEX(wp):: comp 202 204 INTEGER :: ji, jj ! dummy loop indices 203 205 !!----------------------------------------------------------------------- 204 206 ! 205 ztmp = 0.e0206 207 ctmp = CMPLX( 0.e0, 0.e0, wp ) 208 !$ comp = CMPLX( 0.e0, 0.e0, wp ) 209 !$OMP PARALLEL FIRSTPRIVATE(ctmp) PRIVATE(ztmp) SHARED(comp) 210 !$OMP DO 207 211 DO jj = 1, jpj 208 212 DO ji =1, jpi … … 211 215 END DO 212 216 END DO 217 !$OMP ENDDO 218 !$OMP CRITICAL 219 !$ CALL DDPDD( ctmp, comp ) 220 !$OMP END CRITICAL 221 !$OMP END PARALLEL 222 !$ ctmp = comp 223 sum_2d_ref = ctmp 224 ! 225 END FUNCTION sum_2d_ref 226 227 FUNCTION glob_sum_2d( ptab ) 228 !!---------------------------------------------------------------------- 229 !! *** FUNCTION glob_sum_2d *** 230 !! 231 !! ** Purpose : perform a sum in calling DDPDD routine 232 !!---------------------------------------------------------------------- 233 REAL(wp), INTENT(in), DIMENSION(:,:) :: ptab 234 REAL(wp) :: glob_sum_2d ! global masked sum 235 !! 236 COMPLEX(wp):: ctmp 237 REAL(wp) :: ztmp 238 INTEGER :: ji, jj ! dummy loop indices 239 !!----------------------------------------------------------------------- 240 ! 241 ctmp = sum_2d_ref(ptab) 213 242 IF( lk_mpp ) CALL mpp_sum( ctmp ) ! sum over the global domain 214 243 glob_sum_2d = REAL(ctmp,wp) … … 228 257 COMPLEX(wp):: ctmp 229 258 REAL(wp) :: ztmp 259 !$ COMPLEX(wp):: comp 230 260 INTEGER :: ji, jj, jk ! dummy loop indices 231 261 INTEGER :: ijpk ! local variables: size of ptab … … 234 264 ijpk = SIZE(ptab,3) 235 265 ! 236 ztmp = 0.e0237 266 ctmp = CMPLX( 0.e0, 0.e0, wp ) 267 !$ comp = CMPLX( 0.e0, 0.e0, wp ) 268 !$OMP PARALLEL FIRSTPRIVATE(ctmp) PRIVATE(ztmp) SHARED(comp) 269 !$OMP DO 238 270 DO jk = 1, ijpk 239 271 DO jj = 1, jpj … … 244 276 END DO 245 277 END DO 278 !$OMP ENDDO 279 !$OMP CRITICAL 280 !$ CALL DDPDD( ctmp, comp ) 281 !$OMP END CRITICAL 282 !$OMP END PARALLEL 283 !$ ctmp = comp 246 284 IF( lk_mpp ) CALL mpp_sum( ctmp ) ! sum over the global domain 247 285 glob_sum_3d = REAL(ctmp,wp) … … 261 299 COMPLEX(wp):: ctmp 262 300 REAL(wp) :: ztmp 301 !$ COMPLEX(wp):: comp 263 302 INTEGER :: ji, jj ! dummy loop indices 264 303 !!----------------------------------------------------------------------- … … 266 305 ztmp = 0.e0 267 306 ctmp = CMPLX( 0.e0, 0.e0, wp ) 307 !$ comp = CMPLX( 0.e0, 0.e0, wp ) 308 !$OMP PARALLEL FIRSTPRIVATE(ctmp) PRIVATE(ztmp) SHARED(comp) 309 !$OMP DO 268 310 DO jj = 1, jpj 269 311 DO ji =1, jpi … … 274 316 END DO 275 317 END DO 318 !$OMP ENDDO 319 !$OMP CRITICAL 320 !$ CALL DDPDD( ctmp, comp ) 321 !$OMP END CRITICAL 322 !$OMP END PARALLEL 323 !$ ctmp = comp 276 324 IF( lk_mpp ) CALL mpp_sum( ctmp ) ! sum over the global domain 277 325 glob_sum_2d_a = REAL(ctmp,wp) … … 279 327 END FUNCTION glob_sum_2d_a 280 328 329 FUNCTION glob_asum_2d( ptab1, ptab2 ) 330 !!---------------------------------------------------------------------- 331 !! *** FUNCTION glob_sum_2d_a *** 332 !! 333 !! ** Purpose : perform a sum on two 2D arrays in calling DDPDD routine 334 !!---------------------------------------------------------------------- 335 REAL(wp), INTENT(in), DIMENSION(:,:) :: ptab1, ptab2 336 REAL(wp), DIMENSION(2) :: glob_asum_2d ! global masked sum 337 !! 338 COMPLEX(wp), DIMENSION(2) :: ctmp 339 !!----------------------------------------------------------------------- 340 ! 341 ctmp(1) = sum_2d_ref(ptab1) 342 ctmp(2) = sum_2d_ref(ptab2) 343 IF( lk_mpp ) CALL mpp_sum( ctmp, 2 ) ! sum over the global domain 344 glob_asum_2d = REAL(ctmp,wp) 345 ! 346 END FUNCTION glob_asum_2d 281 347 282 348 FUNCTION glob_sum_3d_a( ptab1, ptab2 ) … … 291 357 COMPLEX(wp):: ctmp 292 358 REAL(wp) :: ztmp 359 !$ COMPLEX(wp):: comp 293 360 INTEGER :: ji, jj, jk ! dummy loop indices 294 361 INTEGER :: ijpk ! local variables: size of ptab … … 299 366 ztmp = 0.e0 300 367 ctmp = CMPLX( 0.e0, 0.e0, wp ) 368 !$ comp = CMPLX( 0.e0, 0.e0, wp ) 369 !$OMP PARALLEL FIRSTPRIVATE(ctmp) PRIVATE(ztmp) SHARED(comp) 370 !$OMP DO 301 371 DO jk = 1, ijpk 302 372 DO jj = 1, jpj … … 309 379 END DO 310 380 END DO 381 !$OMP ENDDO 382 !$OMP CRITICAL 383 !$ CALL DDPDD( ctmp, comp ) 384 !$OMP END CRITICAL 385 !$OMP END PARALLEL 386 !$ ctmp = comp 311 387 IF( lk_mpp ) CALL mpp_sum( ctmp ) ! sum over the global domain 312 388 glob_sum_3d_a = REAL(ctmp,wp) … … 317 393 318 394 ! --- MIN --- 395 FUNCTION glob_min_2d_ref( ptab ) 396 !!----------------------------------------------------------------------- 397 !! *** FUNCTION glob_min_2D *** 398 !! 399 !! ** Purpose : perform a masked min on the inner global domain of a 2D array 400 !!----------------------------------------------------------------------- 401 REAL(wp), INTENT(in), DIMENSION(jpi,jpj) :: ptab ! input 2D array 402 REAL(wp) :: glob_min_2d_ref ! global masked min 403 INTEGER :: jj, ji ! local index 404 !!----------------------------------------------------------------------- 405 ! 406 glob_min_2d_ref = 1.e32 407 !$OMP PARALLEL DO REDUCTION(MIN:glob_min_2d_ref) 408 DO jj = 1, jpj 409 DO ji =1, jpi 410 glob_min_2d_ref = MIN(glob_min_2d_ref, ptab(ji,jj)*tmask_i(ji,jj) ) 411 ENDDO 412 ENDDO 413 !$OMP END PARALLEL DO 414 ! 415 END FUNCTION glob_min_2d_ref 416 319 417 FUNCTION glob_min_2d( ptab ) 320 418 !!----------------------------------------------------------------------- … … 323 421 !! ** Purpose : perform a masked min on the inner global domain of a 2D array 324 422 !!----------------------------------------------------------------------- 325 REAL(wp), INTENT(in), DIMENSION( :,:) :: ptab ! input 2D array423 REAL(wp), INTENT(in), DIMENSION(jpi,jpj) :: ptab ! input 2D array 326 424 REAL(wp) :: glob_min_2d ! global masked min 327 !!----------------------------------------------------------------------- 328 ! 329 glob_min_2d = MINVAL( ptab(:,:)*tmask_i(:,:) ) 425 INTEGER :: jj, ji ! local index 426 !!----------------------------------------------------------------------- 427 ! 428 glob_min_2d = glob_min_2d_ref (ptab) 330 429 IF( lk_mpp ) CALL mpp_min( glob_min_2d ) 331 430 ! 332 431 END FUNCTION glob_min_2d 432 433 FUNCTION glob_min_3d_ref( ptab ) 434 !!----------------------------------------------------------------------- 435 !! *** FUNCTION glob_min_3D *** 436 !! 437 !! ** Purpose : perform a masked min on the inner global domain of a 3D array 438 !!----------------------------------------------------------------------- 439 REAL(wp), INTENT(in), DIMENSION(:,:,:) :: ptab ! input 3D array 440 REAL(wp) :: glob_min_3d_ref ! global masked min 441 !! 442 INTEGER :: jk 443 INTEGER :: ijpk ! local variable: size of the 3d dimension of ptab 444 !!----------------------------------------------------------------------- 445 ! 446 ijpk = SIZE(ptab,3) 447 ! 448 glob_min_3d_ref = 1.e32 449 !$OMP PARALLEL DO REDUCTION(MIN:glob_min_3d_ref) 450 DO jk = 1, ijpk 451 glob_min_3d_ref = MIN( glob_min_3d_ref, MINVAL( ptab(:,:,jk)*tmask_i(:,:) ) ) 452 END DO 453 !$OMP END PARALLEL DO 454 ! 455 END FUNCTION glob_min_3d_ref 333 456 334 457 FUNCTION glob_min_3d( ptab ) … … 340 463 REAL(wp), INTENT(in), DIMENSION(:,:,:) :: ptab ! input 3D array 341 464 REAL(wp) :: glob_min_3d ! global masked min 342 !! 343 INTEGER :: jk 344 INTEGER :: ijpk ! local variable: size of the 3d dimension of ptab 345 !!----------------------------------------------------------------------- 346 ! 347 ijpk = SIZE(ptab,3) 348 ! 349 glob_min_3d = MINVAL( ptab(:,:,1)*tmask_i(:,:) ) 350 DO jk = 2, ijpk 351 glob_min_3d = MIN( glob_min_3d, MINVAL( ptab(:,:,jk)*tmask_i(:,:) ) ) 352 END DO 465 !!----------------------------------------------------------------------- 466 ! 467 glob_min_3d = glob_min_3d_ref(ptab) 353 468 IF( lk_mpp ) CALL mpp_min( glob_min_3d ) 354 469 ! … … 366 481 !!----------------------------------------------------------------------- 367 482 ! 368 glob_min_2d_a(1) = MINVAL( ptab1(:,:)*tmask_i(:,:))369 glob_min_2d_a(2) = MINVAL( ptab2(:,:)*tmask_i(:,:))483 glob_min_2d_a(1) = glob_min_2d_ref( ptab1 ) 484 glob_min_2d_a(2) = glob_min_2d_ref( ptab2 ) 370 485 IF( lk_mpp ) CALL mpp_min( glob_min_2d_a, 2 ) 371 486 ! … … 381 496 REAL(wp), INTENT(in), DIMENSION(:,:,:) :: ptab1, ptab2 ! input 3D array 382 497 REAL(wp) , DIMENSION(2) :: glob_min_3d_a ! global masked min 498 !!----------------------------------------------------------------------- 499 ! 500 glob_min_3d_a(1) = glob_min_3d_ref( ptab1 ) 501 glob_min_3d_a(2) = glob_min_3d_ref( ptab2 ) 502 IF( lk_mpp ) CALL mpp_min( glob_min_3d_a, 2 ) 503 ! 504 END FUNCTION glob_min_3d_a 505 506 ! --- MAX --- 507 FUNCTION glob_max_2d_ref( ptab ) 508 !!----------------------------------------------------------------------- 509 !! *** FUNCTION glob_max_2D *** 510 !! 511 !! ** Purpose : perform a masked max on the inner global domain of a 2D array 512 !!----------------------------------------------------------------------- 513 REAL(wp), INTENT(in), DIMENSION(:,:) :: ptab ! input 2D array 514 REAL(wp) :: glob_max_2d_ref ! global masked max 515 INTEGER :: jj, ji ! local index 516 !!----------------------------------------------------------------------- 517 ! 518 glob_max_2d_ref = -1.e32 519 !$OMP PARALLEL DO REDUCTION(MAX:glob_max_2d_ref) 520 DO jj = 1, jpj 521 DO ji =1, jpi 522 glob_max_2d_ref = MAX(glob_max_2d_ref, ptab(ji,jj)*tmask_i(ji,jj) ) 523 ENDDO 524 ENDDO 525 !$OMP END PARALLEL DO 526 ! 527 END FUNCTION glob_max_2d_ref 528 529 FUNCTION glob_max_2d( ptab ) 530 !!----------------------------------------------------------------------- 531 !! *** FUNCTION glob_max_2D *** 532 !! 533 !! ** Purpose : perform a masked max on the inner global domain of a 2D array 534 !!----------------------------------------------------------------------- 535 REAL(wp), INTENT(in), DIMENSION(:,:) :: ptab ! input 2D array 536 REAL(wp) :: glob_max_2d ! global masked max 537 !!----------------------------------------------------------------------- 538 ! 539 glob_max_2d = glob_max_2d_ref( ptab ) 540 IF( lk_mpp ) CALL mpp_max( glob_max_2d ) 541 ! 542 END FUNCTION glob_max_2d 543 544 FUNCTION glob_max_3d_ref( ptab ) 545 !!----------------------------------------------------------------------- 546 !! *** FUNCTION glob_max_3D *** 547 !! 548 !! ** Purpose : perform a masked max on the inner global domain of a 3D array 549 !!----------------------------------------------------------------------- 550 REAL(wp), INTENT(in), DIMENSION(:,:,:) :: ptab ! input 3D array 551 REAL(wp) :: glob_max_3d_ref ! global masked max 383 552 !! 384 553 INTEGER :: jk … … 386 555 !!----------------------------------------------------------------------- 387 556 ! 388 ijpk = SIZE(ptab1,3) 389 ! 390 glob_min_3d_a(1) = MINVAL( ptab1(:,:,1)*tmask_i(:,:) ) 391 glob_min_3d_a(2) = MINVAL( ptab2(:,:,1)*tmask_i(:,:) ) 392 DO jk = 2, ijpk 393 glob_min_3d_a(1) = MIN( glob_min_3d_a(1), MINVAL( ptab1(:,:,jk)*tmask_i(:,:) ) ) 394 glob_min_3d_a(2) = MIN( glob_min_3d_a(2), MINVAL( ptab2(:,:,jk)*tmask_i(:,:) ) ) 557 ijpk = SIZE(ptab,3) 558 ! 559 glob_max_3d_ref = -1e32 560 !$OMP PARALLEL DO REDUCTION(MAX:glob_max_3d_ref) 561 DO jk = 1, ijpk 562 glob_max_3d_ref = MAX( glob_max_3d_ref, MAXVAL( ptab(:,:,jk)*tmask_i(:,:) ) ) 395 563 END DO 396 IF( lk_mpp ) CALL mpp_min( glob_min_3d_a, 2 ) 397 ! 398 END FUNCTION glob_min_3d_a 399 400 ! --- MAX --- 401 FUNCTION glob_max_2d( ptab ) 402 !!----------------------------------------------------------------------- 403 !! *** FUNCTION glob_max_2D *** 404 !! 405 !! ** Purpose : perform a masked max on the inner global domain of a 2D array 406 !!----------------------------------------------------------------------- 407 REAL(wp), INTENT(in), DIMENSION(:,:) :: ptab ! input 2D array 408 REAL(wp) :: glob_max_2d ! global masked max 409 !!----------------------------------------------------------------------- 410 ! 411 glob_max_2d = MAXVAL( ptab(:,:)*tmask_i(:,:) ) 412 IF( lk_mpp ) CALL mpp_max( glob_max_2d ) 413 ! 414 END FUNCTION glob_max_2d 564 !$OMP END PARALLEL DO 565 ! 566 END FUNCTION glob_max_3d_ref 415 567 416 568 FUNCTION glob_max_3d( ptab ) … … 422 574 REAL(wp), INTENT(in), DIMENSION(:,:,:) :: ptab ! input 3D array 423 575 REAL(wp) :: glob_max_3d ! global masked max 424 !! 425 INTEGER :: jk 426 INTEGER :: ijpk ! local variable: size of the 3d dimension of ptab 427 !!----------------------------------------------------------------------- 428 ! 429 ijpk = SIZE(ptab,3) 430 ! 431 glob_max_3d = MAXVAL( ptab(:,:,1)*tmask_i(:,:) ) 432 DO jk = 2, ijpk 433 glob_max_3d = MAX( glob_max_3d, MAXVAL( ptab(:,:,jk)*tmask_i(:,:) ) ) 434 END DO 576 !!----------------------------------------------------------------------- 577 ! 578 glob_max_3d = glob_max_3d_ref( ptab ) 435 579 IF( lk_mpp ) CALL mpp_max( glob_max_3d ) 436 580 ! … … 448 592 !!----------------------------------------------------------------------- 449 593 ! 450 glob_max_2d_a(1) = MAXVAL( ptab1(:,:)*tmask_i(:,:))451 glob_max_2d_a(2) = MAXVAL( ptab2(:,:)*tmask_i(:,:))594 glob_max_2d_a(1) = glob_max_2d_ref( ptab1 ) 595 glob_max_2d_a(2) = glob_max_2d_ref( ptab2 ) 452 596 IF( lk_mpp ) CALL mpp_max( glob_max_2d_a, 2 ) 453 597 ! … … 463 607 REAL(wp), INTENT(in), DIMENSION(:,:,:) :: ptab1, ptab2 ! input 3D array 464 608 REAL(wp) , DIMENSION(2) :: glob_max_3d_a ! global masked max 465 !! 466 INTEGER :: jk 467 INTEGER :: ijpk ! local variable: size of the 3d dimension of ptab 468 !!----------------------------------------------------------------------- 469 ! 470 ijpk = SIZE(ptab1,3) 471 ! 472 glob_max_3d_a(1) = MAXVAL( ptab1(:,:,1)*tmask_i(:,:) ) 473 glob_max_3d_a(2) = MAXVAL( ptab2(:,:,1)*tmask_i(:,:) ) 474 DO jk = 2, ijpk 475 glob_max_3d_a(1) = MAX( glob_max_3d_a(1), MAXVAL( ptab1(:,:,jk)*tmask_i(:,:) ) ) 476 glob_max_3d_a(2) = MAX( glob_max_3d_a(2), MAXVAL( ptab2(:,:,jk)*tmask_i(:,:) ) ) 477 END DO 609 !!----------------------------------------------------------------------- 610 ! 611 glob_max_3d_a(1) = glob_max_3d_ref( ptab1 ) 612 glob_max_3d_a(2) = glob_max_3d_ref( ptab2 ) 478 613 IF( lk_mpp ) CALL mpp_max( glob_max_3d_a, 2 ) 479 614 ! -
branches/UKMO/dev_r5518_GO6_package_OMP/NEMOGCM/NEMO/OPA_SRC/stpctl.F90
r6487 r9176 156 156 ! 157 157 IF(lwp) WRITE(numsol,9200) kt, niter, res, SQRT(epsr)/eps ! Solver 158 IF(lwp) call flush(numsol) 158 159 ! 159 160 IF( kindic < 0 .AND. zsmin > 0.e0 .AND. zumax <= 20.e0 ) THEN ! create a abort file if problem found
Note: See TracChangeset
for help on using the changeset viewer.
