Changeset 5989 for branches/2014/dev_r4650_UKMO10_Tidally_Meaned_Diagnostics/NEMOGCM/NEMO/OPA_SRC/DOM/dommsk.F90
- Timestamp:
- 2015-12-03T09:10:32+01:00 (8 years ago)
- File:
-
- 1 edited
Legend:
- Unmodified
- Added
- Removed
-
branches/2014/dev_r4650_UKMO10_Tidally_Meaned_Diagnostics/NEMOGCM/NEMO/OPA_SRC/DOM/dommsk.F90
r5260 r5989 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 ! - - 135 116 INTEGER :: ios 117 INTEGER :: isrow ! index for ORCA1 starting row 136 118 INTEGER , POINTER, DIMENSION(:,:) :: imsk 137 119 REAL(wp), POINTER, DIMENSION(:,:) :: zwf … … 198 180 END DO 199 181 200 !!gm ????201 #if defined key_zdfkpp202 IF( cp_cfg == 'orca' ) THEN203 IF( jp_cfg == 2 ) THEN ! land point on Bab el Mandeb zonal section204 ij0 = 87 ; ij1 = 88205 ii0 = 160 ; ii1 = 161206 tmask( mi0(ii0):mi1(ii1) , mj0(ij0):mj1(ij1) , 1:jpk ) = 0._wp207 ELSE208 IF(lwp) WRITE(numout,*)209 IF(lwp) WRITE(numout,cform_war)210 IF(lwp) WRITE(numout,*)211 IF(lwp) WRITE(numout,*)' A mask must be applied on Bab el Mandeb strait'212 IF(lwp) WRITE(numout,*)' in case of ORCAs configurations'213 IF(lwp) WRITE(numout,*)' This is a problem which is not yet solved'214 IF(lwp) WRITE(numout,*)215 ENDIF216 ENDIF217 #endif218 !!gm end219 220 182 ! Interior domain mask (used for global sum) 221 183 ! -------------------- … … 283 245 ! 3. Ocean/land mask at wu-, wv- and w points 284 246 !---------------------------------------------- 285 wmask (:,:,1) = tmask(:,:,1) ! ????????286 wumask(:,:,1) = umask(:,:,1) ! ????????287 wvmask(:,:,1) = vmask(:,:,1) ! ????????288 DO jk =2,jpk289 wmask (:,:,jk) =tmask(:,:,jk) * tmask(:,:,jk-1)290 wumask(:,:,jk) =umask(:,:,jk) * umask(:,:,jk-1)291 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) 292 254 END DO 293 255 … … 338 300 ENDIF 339 301 340 341 ! mask for second order calculation of vorticity342 ! ----------------------------------------------343 CALL dom_msk_nsa344 345 346 302 ! Lateral boundary conditions on velocity (modify fmask) 347 303 ! --------------------------------------- … … 376 332 IF( cp_cfg == "orca" .AND. jp_cfg == 2 ) THEN ! ORCA_R2 configuration 377 333 ! ! Increased lateral friction near of some straits 378 IF( nn_cla == 0 ) THEN 379 ! ! Gibraltar strait : partial slip (fmask=0.5) 380 ij0 = 101 ; ij1 = 101 381 ii0 = 139 ; ii1 = 140 ; fmask( mi0(ii0):mi1(ii1) , mj0(ij0):mj1(ij1) , 1:jpk ) = 0.5_wp 382 ij0 = 102 ; ij1 = 102 383 ii0 = 139 ; ii1 = 140 ; fmask( mi0(ii0):mi1(ii1) , mj0(ij0):mj1(ij1) , 1:jpk ) = 0.5_wp 384 ! 385 ! ! Bab el Mandeb : partial slip (fmask=1) 386 ij0 = 87 ; ij1 = 88 387 ii0 = 160 ; ii1 = 160 ; fmask( mi0(ii0):mi1(ii1) , mj0(ij0):mj1(ij1) , 1:jpk ) = 1._wp 388 ij0 = 88 ; ij1 = 88 389 ii0 = 159 ; ii1 = 159 ; fmask( mi0(ii0):mi1(ii1) , mj0(ij0):mj1(ij1) , 1:jpk ) = 1._wp 390 ! 391 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 ! 392 346 ! ! Danish straits : strong slip (fmask > 2) 393 347 ! We keep this as an example but it is instable in this case … … 401 355 IF( cp_cfg == "orca" .AND. jp_cfg == 1 ) THEN ! ORCA R1 configuration 402 356 ! ! Increased lateral friction near of some straits 357 ! This dirty section will be suppressed by simplification process: 358 ! all this will come back in input files 359 ! Currently these hard-wired indices relate to configuration with 360 ! extend grid (jpjglo=332) 361 ! 362 isrow = 332 - jpjglo 363 ! 403 364 IF(lwp) WRITE(numout,*) 404 365 IF(lwp) WRITE(numout,*) ' orca_r1: increase friction near the following straits : ' 405 366 IF(lwp) WRITE(numout,*) ' Gibraltar ' 406 ii0 = 28 3 ; ii1 = 284! Gibraltar Strait407 ij0 = 2 00 ; ij1 = 200 ; fmask( mi0(ii0):mi1(ii1) , mj0(ij0):mj1(ij1), 1:jpk ) =2._wp367 ii0 = 282 ; ii1 = 283 ! Gibraltar Strait 368 ij0 = 241 - isrow ; ij1 = 241 - isrow ; fmask( mi0(ii0):mi1(ii1),mj0(ij0):mj1(ij1),1:jpk ) = 2._wp 408 369 409 370 IF(lwp) WRITE(numout,*) ' Bhosporus ' 410 ii0 = 314 ; ii1 = 315 ! Bhosporus Strait411 ij0 = 2 08 ; ij1 = 208 ; fmask( mi0(ii0):mi1(ii1) , mj0(ij0):mj1(ij1), 1:jpk ) =2._wp371 ii0 = 314 ; ii1 = 315 ! Bhosporus Strait 372 ij0 = 248 - isrow ; ij1 = 248 - isrow ; fmask( mi0(ii0):mi1(ii1),mj0(ij0):mj1(ij1),1:jpk ) = 2._wp 412 373 413 374 IF(lwp) WRITE(numout,*) ' Makassar (Top) ' 414 ii0 = 48 ; ii1 = 48 ! Makassar Strait (Top)415 ij0 = 1 49 ; ij1 = 150 ; fmask( mi0(ii0):mi1(ii1) , mj0(ij0):mj1(ij1), 1:jpk ) =3._wp375 ii0 = 48 ; ii1 = 48 ! Makassar Strait (Top) 376 ij0 = 189 - isrow ; ij1 = 190 - isrow ; fmask( mi0(ii0):mi1(ii1),mj0(ij0):mj1(ij1),1:jpk ) = 3._wp 416 377 417 378 IF(lwp) WRITE(numout,*) ' Lombok ' 418 ii0 = 44 ; ii1 = 44 ! Lombok Strait419 ij0 = 1 24 ; ij1 = 125 ; fmask( mi0(ii0):mi1(ii1) , mj0(ij0):mj1(ij1), 1:jpk ) =2._wp379 ii0 = 44 ; ii1 = 44 ! Lombok Strait 380 ij0 = 164 - isrow ; ij1 = 165 - isrow ; fmask( mi0(ii0):mi1(ii1),mj0(ij0):mj1(ij1),1:jpk ) = 2._wp 420 381 421 382 IF(lwp) WRITE(numout,*) ' Ombai ' 422 ii0 = 53 ; ii1 = 53 ! Ombai Strait423 ij0 = 1 24 ; ij1 = 125 ; fmask( mi0(ii0):mi1(ii1) , mj0(ij0):mj1(ij1),1:jpk ) = 2._wp383 ii0 = 53 ; ii1 = 53 ! Ombai Strait 384 ij0 = 164 - isrow ; ij1 = 165 - isrow ; fmask( mi0(ii0):mi1(ii1),mj0(ij0):mj1(ij1),1:jpk ) = 2._wp 424 385 425 386 IF(lwp) WRITE(numout,*) ' Timor Passage ' 426 ii0 = 56 ; ii1 = 56 ! Timor Passage427 ij0 = 1 24 ; ij1 = 125 ; fmask( mi0(ii0):mi1(ii1) , mj0(ij0):mj1(ij1),1:jpk ) = 2._wp387 ii0 = 56 ; ii1 = 56 ! Timor Passage 388 ij0 = 164 - isrow ; ij1 = 165 - isrow ; fmask( mi0(ii0):mi1(ii1),mj0(ij0):mj1(ij1),1:jpk ) = 2._wp 428 389 429 390 IF(lwp) WRITE(numout,*) ' West Halmahera ' 430 ii0 = 58 ; ii1 = 58 ! West Halmahera Strait431 ij0 = 1 41 ; ij1 = 142 ; fmask( mi0(ii0):mi1(ii1) , mj0(ij0):mj1(ij1),1:jpk ) = 3._wp391 ii0 = 58 ; ii1 = 58 ! West Halmahera Strait 392 ij0 = 181 - isrow ; ij1 = 182 - isrow ; fmask( mi0(ii0):mi1(ii1),mj0(ij0):mj1(ij1),1:jpk ) = 3._wp 432 393 433 394 IF(lwp) WRITE(numout,*) ' East Halmahera ' 434 ii0 = 55 ; ii1 = 55 ! East Halmahera Strait435 ij0 = 1 41 ; ij1 = 142 ; fmask( mi0(ii0):mi1(ii1) , mj0(ij0):mj1(ij1),1:jpk ) = 3._wp395 ii0 = 55 ; ii1 = 55 ! East Halmahera Strait 396 ij0 = 181 - isrow ; ij1 = 182 - isrow ; fmask( mi0(ii0):mi1(ii1),mj0(ij0):mj1(ij1),1:jpk ) = 3._wp 436 397 ! 437 398 ENDIF … … 492 453 ! 493 454 END SUBROUTINE dom_msk 494 495 #if defined key_noslip_accurate496 !!----------------------------------------------------------------------497 !! 'key_noslip_accurate' : accurate no-slip boundary condition498 !!----------------------------------------------------------------------499 500 SUBROUTINE dom_msk_nsa501 !!---------------------------------------------------------------------502 !! *** ROUTINE dom_msk_nsa ***503 !!504 !! ** Purpose :505 !!506 !! ** Method :507 !!508 !! ** Action :509 !!----------------------------------------------------------------------510 INTEGER :: ji, jj, jk, jl ! dummy loop indices511 INTEGER :: ine, inw, ins, inn, itest, ierror, iind, ijnd512 REAL(wp) :: zaa513 !!---------------------------------------------------------------------514 !515 IF( nn_timing == 1 ) CALL timing_start('dom_msk_nsa')516 !517 IF(lwp) WRITE(numout,*)518 IF(lwp) WRITE(numout,*) 'dom_msk_nsa : noslip accurate boundary condition'519 IF(lwp) WRITE(numout,*) '~~~~~~~~~~~ using Schchepetkin and O Brian scheme'520 IF( lk_mpp ) CALL ctl_stop( ' mpp version is not yet implemented' )521 522 ! mask for second order calculation of vorticity523 ! ----------------------------------------------524 ! noslip boundary condition: fmask=1 at convex corner, store525 ! index of straight coast meshes ( 'west', refering to a coast,526 ! means west of the ocean, aso)527 528 DO jk = 1, jpk529 DO jl = 1, 4530 npcoa(jl,jk) = 0531 DO ji = 1, 2*(jpi+jpj)532 nicoa(ji,jl,jk) = 0533 njcoa(ji,jl,jk) = 0534 END DO535 END DO536 END DO537 538 IF( jperio == 2 ) THEN539 WRITE(numout,*) ' '540 WRITE(numout,*) ' symetric boundary conditions need special'541 WRITE(numout,*) ' treatment not implemented. we stop.'542 STOP543 ENDIF544 545 ! convex corners546 547 DO jk = 1, jpkm1548 DO jj = 1, jpjm1549 DO ji = 1, jpim1550 zaa = tmask(ji ,jj,jk) + tmask(ji ,jj+1,jk) &551 &+ tmask(ji+1,jj,jk) + tmask(ji+1,jj+1,jk)552 IF( ABS(zaa-3._wp) <= 0.1_wp ) fmask(ji,jj,jk) = 1._wp553 END DO554 END DO555 END DO556 557 ! north-south straight coast558 559 DO jk = 1, jpkm1560 inw = 0561 ine = 0562 DO jj = 2, jpjm1563 DO ji = 2, jpim1564 zaa = tmask(ji+1,jj,jk) + tmask(ji+1,jj+1,jk)565 IF( ABS(zaa-2._wp) <= 0.1_wp .AND. fmask(ji,jj,jk) == 0._wp ) THEN566 inw = inw + 1567 nicoa(inw,1,jk) = ji568 njcoa(inw,1,jk) = jj569 IF( nprint == 1 ) WRITE(numout,*) ' west : ', jk, inw, ji, jj570 ENDIF571 zaa = tmask(ji,jj,jk) + tmask(ji,jj+1,jk)572 IF( ABS(zaa-2._wp) <= 0.1_wp .AND. fmask(ji,jj,jk) == 0._wp ) THEN573 ine = ine + 1574 nicoa(ine,2,jk) = ji575 njcoa(ine,2,jk) = jj576 IF( nprint == 1 ) WRITE(numout,*) ' east : ', jk, ine, ji, jj577 ENDIF578 END DO579 END DO580 npcoa(1,jk) = inw581 npcoa(2,jk) = ine582 END DO583 584 ! west-east straight coast585 586 DO jk = 1, jpkm1587 ins = 0588 inn = 0589 DO jj = 2, jpjm1590 DO ji =2, jpim1591 zaa = tmask(ji,jj+1,jk) + tmask(ji+1,jj+1,jk)592 IF( ABS(zaa-2._wp) <= 0.1_wp .AND. fmask(ji,jj,jk) == 0._wp ) THEN593 ins = ins + 1594 nicoa(ins,3,jk) = ji595 njcoa(ins,3,jk) = jj596 IF( nprint == 1 ) WRITE(numout,*) ' south : ', jk, ins, ji, jj597 ENDIF598 zaa = tmask(ji+1,jj,jk) + tmask(ji,jj,jk)599 IF( ABS(zaa-2._wp) <= 0.1_wp .AND. fmask(ji,jj,jk) == 0._wp ) THEN600 inn = inn + 1601 nicoa(inn,4,jk) = ji602 njcoa(inn,4,jk) = jj603 IF( nprint == 1 ) WRITE(numout,*) ' north : ', jk, inn, ji, jj604 ENDIF605 END DO606 END DO607 npcoa(3,jk) = ins608 npcoa(4,jk) = inn609 END DO610 611 itest = 2 * ( jpi + jpj )612 DO jk = 1, jpk613 IF( npcoa(1,jk) > itest .OR. npcoa(2,jk) > itest .OR. &614 npcoa(3,jk) > itest .OR. npcoa(4,jk) > itest ) THEN615 616 WRITE(ctmp1,*) ' level jk = ',jk617 WRITE(ctmp2,*) ' straight coast index arraies are too small.:'618 WRITE(ctmp3,*) ' npe, npw, nps, npn = ', npcoa(1,jk), npcoa(2,jk), &619 & npcoa(3,jk), npcoa(4,jk)620 WRITE(ctmp4,*) ' 2*(jpi+jpj) = ',itest,'. we stop.'621 CALL ctl_stop( ctmp1, ctmp2, ctmp3, ctmp4 )622 ENDIF623 END DO624 625 ierror = 0626 iind = 0627 ijnd = 0628 IF( nperio == 1 .OR. nperio == 4 .OR. nperio == 6 ) iind = 2629 IF( nperio == 3 .OR. nperio == 4 .OR. nperio == 5 .OR. nperio == 6 ) ijnd = 2630 DO jk = 1, jpk631 DO jl = 1, npcoa(1,jk)632 IF( nicoa(jl,1,jk)+3 > jpi+iind ) THEN633 ierror = ierror+1634 icoord(ierror,1) = nicoa(jl,1,jk)635 icoord(ierror,2) = njcoa(jl,1,jk)636 icoord(ierror,3) = jk637 ENDIF638 END DO639 DO jl = 1, npcoa(2,jk)640 IF(nicoa(jl,2,jk)-2 < 1-iind ) THEN641 ierror = ierror + 1642 icoord(ierror,1) = nicoa(jl,2,jk)643 icoord(ierror,2) = njcoa(jl,2,jk)644 icoord(ierror,3) = jk645 ENDIF646 END DO647 DO jl = 1, npcoa(3,jk)648 IF( njcoa(jl,3,jk)+3 > jpj+ijnd ) THEN649 ierror = ierror + 1650 icoord(ierror,1) = nicoa(jl,3,jk)651 icoord(ierror,2) = njcoa(jl,3,jk)652 icoord(ierror,3) = jk653 ENDIF654 END DO655 DO jl = 1, npcoa(4,jk)656 IF( njcoa(jl,4,jk)-2 < 1) THEN657 ierror=ierror + 1658 icoord(ierror,1) = nicoa(jl,4,jk)659 icoord(ierror,2) = njcoa(jl,4,jk)660 icoord(ierror,3) = jk661 ENDIF662 END DO663 END DO664 665 IF( ierror > 0 ) THEN666 IF(lwp) WRITE(numout,*)667 IF(lwp) WRITE(numout,*) ' Problem on lateral conditions'668 IF(lwp) WRITE(numout,*) ' Bad marking off at points:'669 DO jl = 1, ierror670 IF(lwp) WRITE(numout,*) 'Level:',icoord(jl,3), &671 & ' Point(',icoord(jl,1),',',icoord(jl,2),')'672 END DO673 CALL ctl_stop( 'We stop...' )674 ENDIF675 !676 IF( nn_timing == 1 ) CALL timing_stop('dom_msk_nsa')677 !678 END SUBROUTINE dom_msk_nsa679 680 #else681 !!----------------------------------------------------------------------682 !! Default option : Empty routine683 !!----------------------------------------------------------------------684 SUBROUTINE dom_msk_nsa685 END SUBROUTINE dom_msk_nsa686 #endif687 455 688 456 !!======================================================================
Note: See TracChangeset
for help on using the changeset viewer.
