Changeset 6043 for branches/2014/dev_r4650_UKMO14.12_STAND_ALONE_OBSOPER/NEMOGCM/NEMO/OPA_SRC/DOM/dommsk.F90
- Timestamp:
- 2015-12-14T10:27:28+01:00 (8 years ago)
- File:
-
- 1 edited
Legend:
- Unmodified
- Added
- Removed
-
branches/2014/dev_r4650_UKMO14.12_STAND_ALONE_OBSOPER/NEMOGCM/NEMO/OPA_SRC/DOM/dommsk.F90
r5600 r6043 17 17 !! - ! 2005-11 (V. Garnier) Surface pressure gradient organization 18 18 !! 3.2 ! 2009-07 (R. Benshila) Suppression of rigid-lid option 19 !! 3.6 ! 2015-05 (P. Mathiot) ISF: add wmask,wumask and wvmask 19 20 !!---------------------------------------------------------------------- 20 21 21 22 !!---------------------------------------------------------------------- 22 23 !! dom_msk : compute land/ocean mask 23 !! dom_msk_nsa : update land/ocean mask when no-slip accurate option is used.24 24 !!---------------------------------------------------------------------- 25 25 USE oce ! ocean dynamics and tracers … … 28 28 USE lbclnk ! ocean lateral boundary conditions (or mpp link) 29 29 USE lib_mpp 30 USE dynspg_oce ! choice/control of key cpp for surface pressure gradient31 30 USE wrk_nemo ! Memory allocation 32 31 USE timing ! Timing … … 36 35 37 36 PUBLIC dom_msk ! routine called by inidom.F90 38 PUBLIC dom_msk_alloc ! routine called by nemogcm.F9039 37 40 38 ! !!* Namelist namlbc : lateral boundary condition * … … 42 40 LOGICAL, PUBLIC :: ln_vorlat ! consistency of vorticity boundary condition 43 41 ! with analytical eqs. 44 45 46 INTEGER, ALLOCATABLE, SAVE, DIMENSION(:,:) :: icoord ! Workspace for dom_msk_nsa()47 42 48 43 !! * Substitutions … … 54 49 !!---------------------------------------------------------------------- 55 50 CONTAINS 56 57 INTEGER FUNCTION dom_msk_alloc()58 !!---------------------------------------------------------------------59 !! *** FUNCTION dom_msk_alloc ***60 !!---------------------------------------------------------------------61 dom_msk_alloc = 062 #if defined key_noslip_accurate63 ALLOCATE(icoord(jpi*jpj*jpk,3), STAT=dom_msk_alloc)64 #endif65 IF( dom_msk_alloc /= 0 ) CALL ctl_warn('dom_msk_alloc: failed to allocate icoord array')66 !67 END FUNCTION dom_msk_alloc68 69 51 70 52 SUBROUTINE dom_msk … … 129 111 !! tmask_i : interior ocean mask 130 112 !!---------------------------------------------------------------------- 131 ! 132 INTEGER :: ji, jj, jk ! dummy loop indices 113 INTEGER :: ji, jj, jk ! dummy loop indices 133 114 INTEGER :: iif, iil, ii0, ii1, ii ! local integers 134 115 INTEGER :: ijf, ijl, ij0, ij1 ! - - … … 199 180 END DO 200 181 201 !!gm ????202 #if defined key_zdfkpp203 IF( cp_cfg == 'orca' ) THEN204 IF( jp_cfg == 2 ) THEN ! land point on Bab el Mandeb zonal section205 ij0 = 87 ; ij1 = 88206 ii0 = 160 ; ii1 = 161207 tmask( mi0(ii0):mi1(ii1) , mj0(ij0):mj1(ij1) , 1:jpk ) = 0._wp208 ELSE209 IF(lwp) WRITE(numout,*)210 IF(lwp) WRITE(numout,cform_war)211 IF(lwp) WRITE(numout,*)212 IF(lwp) WRITE(numout,*)' A mask must be applied on Bab el Mandeb strait'213 IF(lwp) WRITE(numout,*)' in case of ORCAs configurations'214 IF(lwp) WRITE(numout,*)' This is a problem which is not yet solved'215 IF(lwp) WRITE(numout,*)216 ENDIF217 ENDIF218 #endif219 !!gm end220 221 182 ! Interior domain mask (used for global sum) 222 183 ! -------------------- … … 284 245 ! 3. Ocean/land mask at wu-, wv- and w points 285 246 !---------------------------------------------- 286 wmask (:,:,1) = tmask(:,:,1) ! ????????287 wumask(:,:,1) = umask(:,:,1) ! ????????288 wvmask(:,:,1) = vmask(:,:,1) ! ????????289 DO jk =2,jpk290 wmask (:,:,jk) =tmask(:,:,jk) * tmask(:,:,jk-1)291 wumask(:,:,jk) =umask(:,:,jk) * umask(:,:,jk-1)292 wvmask(:,:,jk) =vmask(:,:,jk) * vmask(:,:,jk-1)247 wmask (:,:,1) = tmask(:,:,1) ! surface 248 wumask(:,:,1) = umask(:,:,1) 249 wvmask(:,:,1) = vmask(:,:,1) 250 DO jk = 2, jpk ! interior values 251 wmask (:,:,jk) = tmask(:,:,jk) * tmask(:,:,jk-1) 252 wumask(:,:,jk) = umask(:,:,jk) * umask(:,:,jk-1) 253 wvmask(:,:,jk) = vmask(:,:,jk) * vmask(:,:,jk-1) 293 254 END DO 294 255 … … 339 300 ENDIF 340 301 341 342 ! mask for second order calculation of vorticity343 ! ----------------------------------------------344 CALL dom_msk_nsa345 346 347 302 ! Lateral boundary conditions on velocity (modify fmask) 348 303 ! --------------------------------------- … … 377 332 IF( cp_cfg == "orca" .AND. jp_cfg == 2 ) THEN ! ORCA_R2 configuration 378 333 ! ! Increased lateral friction near of some straits 379 IF( nn_cla == 0 ) THEN 380 ! ! Gibraltar strait : partial slip (fmask=0.5) 381 ij0 = 101 ; ij1 = 101 382 ii0 = 139 ; ii1 = 140 ; fmask( mi0(ii0):mi1(ii1) , mj0(ij0):mj1(ij1) , 1:jpk ) = 0.5_wp 383 ij0 = 102 ; ij1 = 102 384 ii0 = 139 ; ii1 = 140 ; fmask( mi0(ii0):mi1(ii1) , mj0(ij0):mj1(ij1) , 1:jpk ) = 0.5_wp 385 ! 386 ! ! Bab el Mandeb : partial slip (fmask=1) 387 ij0 = 87 ; ij1 = 88 388 ii0 = 160 ; ii1 = 160 ; fmask( mi0(ii0):mi1(ii1) , mj0(ij0):mj1(ij1) , 1:jpk ) = 1._wp 389 ij0 = 88 ; ij1 = 88 390 ii0 = 159 ; ii1 = 159 ; fmask( mi0(ii0):mi1(ii1) , mj0(ij0):mj1(ij1) , 1:jpk ) = 1._wp 391 ! 392 ENDIF 334 ! ! Gibraltar strait : partial slip (fmask=0.5) 335 ij0 = 101 ; ij1 = 101 336 ii0 = 139 ; ii1 = 140 ; fmask( mi0(ii0):mi1(ii1) , mj0(ij0):mj1(ij1) , 1:jpk ) = 0.5_wp 337 ij0 = 102 ; ij1 = 102 338 ii0 = 139 ; ii1 = 140 ; fmask( mi0(ii0):mi1(ii1) , mj0(ij0):mj1(ij1) , 1:jpk ) = 0.5_wp 339 ! 340 ! ! Bab el Mandeb : partial slip (fmask=1) 341 ij0 = 87 ; ij1 = 88 342 ii0 = 160 ; ii1 = 160 ; fmask( mi0(ii0):mi1(ii1) , mj0(ij0):mj1(ij1) , 1:jpk ) = 1._wp 343 ij0 = 88 ; ij1 = 88 344 ii0 = 159 ; ii1 = 159 ; fmask( mi0(ii0):mi1(ii1) , mj0(ij0):mj1(ij1) , 1:jpk ) = 1._wp 345 ! 393 346 ! ! Danish straits : strong slip (fmask > 2) 394 347 ! We keep this as an example but it is instable in this case … … 500 453 ! 501 454 END SUBROUTINE dom_msk 502 503 #if defined key_noslip_accurate504 !!----------------------------------------------------------------------505 !! 'key_noslip_accurate' : accurate no-slip boundary condition506 !!----------------------------------------------------------------------507 508 SUBROUTINE dom_msk_nsa509 !!---------------------------------------------------------------------510 !! *** ROUTINE dom_msk_nsa ***511 !!512 !! ** Purpose :513 !!514 !! ** Method :515 !!516 !! ** Action :517 !!----------------------------------------------------------------------518 INTEGER :: ji, jj, jk, jl ! dummy loop indices519 INTEGER :: ine, inw, ins, inn, itest, ierror, iind, ijnd520 REAL(wp) :: zaa521 !!---------------------------------------------------------------------522 !523 IF( nn_timing == 1 ) CALL timing_start('dom_msk_nsa')524 !525 IF(lwp) WRITE(numout,*)526 IF(lwp) WRITE(numout,*) 'dom_msk_nsa : noslip accurate boundary condition'527 IF(lwp) WRITE(numout,*) '~~~~~~~~~~~ using Schchepetkin and O Brian scheme'528 IF( lk_mpp ) CALL ctl_stop( ' mpp version is not yet implemented' )529 530 ! mask for second order calculation of vorticity531 ! ----------------------------------------------532 ! noslip boundary condition: fmask=1 at convex corner, store533 ! index of straight coast meshes ( 'west', refering to a coast,534 ! means west of the ocean, aso)535 536 DO jk = 1, jpk537 DO jl = 1, 4538 npcoa(jl,jk) = 0539 DO ji = 1, 2*(jpi+jpj)540 nicoa(ji,jl,jk) = 0541 njcoa(ji,jl,jk) = 0542 END DO543 END DO544 END DO545 546 IF( jperio == 2 ) THEN547 WRITE(numout,*) ' '548 WRITE(numout,*) ' symetric boundary conditions need special'549 WRITE(numout,*) ' treatment not implemented. we stop.'550 STOP551 ENDIF552 553 ! convex corners554 555 DO jk = 1, jpkm1556 DO jj = 1, jpjm1557 DO ji = 1, jpim1558 zaa = tmask(ji ,jj,jk) + tmask(ji ,jj+1,jk) &559 &+ tmask(ji+1,jj,jk) + tmask(ji+1,jj+1,jk)560 IF( ABS(zaa-3._wp) <= 0.1_wp ) fmask(ji,jj,jk) = 1._wp561 END DO562 END DO563 END DO564 565 ! north-south straight coast566 567 DO jk = 1, jpkm1568 inw = 0569 ine = 0570 DO jj = 2, jpjm1571 DO ji = 2, jpim1572 zaa = tmask(ji+1,jj,jk) + tmask(ji+1,jj+1,jk)573 IF( ABS(zaa-2._wp) <= 0.1_wp .AND. fmask(ji,jj,jk) == 0._wp ) THEN574 inw = inw + 1575 nicoa(inw,1,jk) = ji576 njcoa(inw,1,jk) = jj577 IF( nprint == 1 ) WRITE(numout,*) ' west : ', jk, inw, ji, jj578 ENDIF579 zaa = tmask(ji,jj,jk) + tmask(ji,jj+1,jk)580 IF( ABS(zaa-2._wp) <= 0.1_wp .AND. fmask(ji,jj,jk) == 0._wp ) THEN581 ine = ine + 1582 nicoa(ine,2,jk) = ji583 njcoa(ine,2,jk) = jj584 IF( nprint == 1 ) WRITE(numout,*) ' east : ', jk, ine, ji, jj585 ENDIF586 END DO587 END DO588 npcoa(1,jk) = inw589 npcoa(2,jk) = ine590 END DO591 592 ! west-east straight coast593 594 DO jk = 1, jpkm1595 ins = 0596 inn = 0597 DO jj = 2, jpjm1598 DO ji =2, jpim1599 zaa = tmask(ji,jj+1,jk) + tmask(ji+1,jj+1,jk)600 IF( ABS(zaa-2._wp) <= 0.1_wp .AND. fmask(ji,jj,jk) == 0._wp ) THEN601 ins = ins + 1602 nicoa(ins,3,jk) = ji603 njcoa(ins,3,jk) = jj604 IF( nprint == 1 ) WRITE(numout,*) ' south : ', jk, ins, ji, jj605 ENDIF606 zaa = tmask(ji+1,jj,jk) + tmask(ji,jj,jk)607 IF( ABS(zaa-2._wp) <= 0.1_wp .AND. fmask(ji,jj,jk) == 0._wp ) THEN608 inn = inn + 1609 nicoa(inn,4,jk) = ji610 njcoa(inn,4,jk) = jj611 IF( nprint == 1 ) WRITE(numout,*) ' north : ', jk, inn, ji, jj612 ENDIF613 END DO614 END DO615 npcoa(3,jk) = ins616 npcoa(4,jk) = inn617 END DO618 619 itest = 2 * ( jpi + jpj )620 DO jk = 1, jpk621 IF( npcoa(1,jk) > itest .OR. npcoa(2,jk) > itest .OR. &622 npcoa(3,jk) > itest .OR. npcoa(4,jk) > itest ) THEN623 624 WRITE(ctmp1,*) ' level jk = ',jk625 WRITE(ctmp2,*) ' straight coast index arraies are too small.:'626 WRITE(ctmp3,*) ' npe, npw, nps, npn = ', npcoa(1,jk), npcoa(2,jk), &627 & npcoa(3,jk), npcoa(4,jk)628 WRITE(ctmp4,*) ' 2*(jpi+jpj) = ',itest,'. we stop.'629 CALL ctl_stop( ctmp1, ctmp2, ctmp3, ctmp4 )630 ENDIF631 END DO632 633 ierror = 0634 iind = 0635 ijnd = 0636 IF( nperio == 1 .OR. nperio == 4 .OR. nperio == 6 ) iind = 2637 IF( nperio == 3 .OR. nperio == 4 .OR. nperio == 5 .OR. nperio == 6 ) ijnd = 2638 DO jk = 1, jpk639 DO jl = 1, npcoa(1,jk)640 IF( nicoa(jl,1,jk)+3 > jpi+iind ) THEN641 ierror = ierror+1642 icoord(ierror,1) = nicoa(jl,1,jk)643 icoord(ierror,2) = njcoa(jl,1,jk)644 icoord(ierror,3) = jk645 ENDIF646 END DO647 DO jl = 1, npcoa(2,jk)648 IF(nicoa(jl,2,jk)-2 < 1-iind ) THEN649 ierror = ierror + 1650 icoord(ierror,1) = nicoa(jl,2,jk)651 icoord(ierror,2) = njcoa(jl,2,jk)652 icoord(ierror,3) = jk653 ENDIF654 END DO655 DO jl = 1, npcoa(3,jk)656 IF( njcoa(jl,3,jk)+3 > jpj+ijnd ) THEN657 ierror = ierror + 1658 icoord(ierror,1) = nicoa(jl,3,jk)659 icoord(ierror,2) = njcoa(jl,3,jk)660 icoord(ierror,3) = jk661 ENDIF662 END DO663 DO jl = 1, npcoa(4,jk)664 IF( njcoa(jl,4,jk)-2 < 1) THEN665 ierror=ierror + 1666 icoord(ierror,1) = nicoa(jl,4,jk)667 icoord(ierror,2) = njcoa(jl,4,jk)668 icoord(ierror,3) = jk669 ENDIF670 END DO671 END DO672 673 IF( ierror > 0 ) THEN674 IF(lwp) WRITE(numout,*)675 IF(lwp) WRITE(numout,*) ' Problem on lateral conditions'676 IF(lwp) WRITE(numout,*) ' Bad marking off at points:'677 DO jl = 1, ierror678 IF(lwp) WRITE(numout,*) 'Level:',icoord(jl,3), &679 & ' Point(',icoord(jl,1),',',icoord(jl,2),')'680 END DO681 CALL ctl_stop( 'We stop...' )682 ENDIF683 !684 IF( nn_timing == 1 ) CALL timing_stop('dom_msk_nsa')685 !686 END SUBROUTINE dom_msk_nsa687 688 #else689 !!----------------------------------------------------------------------690 !! Default option : Empty routine691 !!----------------------------------------------------------------------692 SUBROUTINE dom_msk_nsa693 END SUBROUTINE dom_msk_nsa694 #endif695 455 696 456 !!======================================================================
Note: See TracChangeset
for help on using the changeset viewer.
