- Timestamp:
- 2016-07-19T10:38:35+02:00 (8 years ago)
- File:
-
- 1 edited
Legend:
- Unmodified
- Added
- Removed
-
branches/NERC/dev_r5549_BDY_ZEROGRAD/NEMOGCM/NEMO/OPA_SRC/DOM/dommsk.F90
r5506 r6808 7 7 !! 6.0 ! 1993-03 (M. Guyon) symetrical conditions (M. Guyon) 8 8 !! 7.0 ! 1996-01 (G. Madec) suppression of common work arrays 9 !! - ! 1996-05 (G. Madec) mask computed from tmask and sup- 10 !! ! pression of the double computation of bmask 9 !! - ! 1996-05 (G. Madec) mask computed from tmask 11 10 !! 8.0 ! 1997-02 (G. Madec) mesh information put in domhgr.F 12 11 !! 8.1 ! 1997-07 (G. Madec) modification of mbathy and fmask … … 17 16 !! - ! 2005-11 (V. Garnier) Surface pressure gradient organization 18 17 !! 3.2 ! 2009-07 (R. Benshila) Suppression of rigid-lid option 18 !! 3.6 ! 2015-05 (P. Mathiot) ISF: add wmask,wumask and wvmask 19 19 !!---------------------------------------------------------------------- 20 20 21 21 !!---------------------------------------------------------------------- 22 22 !! dom_msk : compute land/ocean mask 23 !! dom_msk_nsa : update land/ocean mask when no-slip accurate option is used.24 23 !!---------------------------------------------------------------------- 25 24 USE oce ! ocean dynamics and tracers 26 25 USE dom_oce ! ocean space and time domain 26 ! 27 27 USE in_out_manager ! I/O manager 28 28 USE lbclnk ! ocean lateral boundary conditions (or mpp link) 29 USE lib_mpp 30 USE dynspg_oce ! choice/control of key cpp for surface pressure gradient 29 USE lib_mpp ! 31 30 USE wrk_nemo ! Memory allocation 32 31 USE timing ! Timing … … 35 34 PRIVATE 36 35 37 PUBLIC dom_msk ! routine called by inidom.F90 38 PUBLIC dom_msk_alloc ! routine called by nemogcm.F90 36 PUBLIC dom_msk ! routine called by inidom.F90 39 37 40 38 ! !!* Namelist namlbc : lateral boundary condition * … … 43 41 ! with analytical eqs. 44 42 45 46 INTEGER, ALLOCATABLE, SAVE, DIMENSION(:,:) :: icoord ! Workspace for dom_msk_nsa()47 48 43 !! * Substitutions 49 44 # include "vectopt_loop_substitute.h90" … … 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 … … 73 55 !! 74 56 !! ** Purpose : Compute land/ocean mask arrays at tracer points, hori- 75 !! zontal velocity points (u & v), vorticity points (f) and baro- 76 !! tropic stream function points (b). 57 !! zontal velocity points (u & v), vorticity points (f) points. 77 58 !! 78 59 !! ** Method : The ocean/land mask is computed from the basin bathy- … … 92 73 !! 1. IF mbathy( ji ,jj) and mbathy( ji ,jj+1) 93 74 !! and mbathy(ji+1,jj) and mbathy(ji+1,jj+1) >= jk. 94 !! b-point : the same definition as for f-point of the first ocean95 !! level (surface level) but with 0 along coastlines.96 75 !! tmask_i : interior ocean mask at t-point, i.e. excluding duplicated 97 76 !! rows/lines due to cyclic or North Fold boundaries as well … … 107 86 !! 108 87 !! N.B. If nperio not equal to 0, the land/ocean mask arrays 109 !! are defined with the proper value at lateral domain boundaries, 110 !! but bmask. indeed, bmask defined the domain over which the 111 !! barotropic stream function is computed. this domain cannot 112 !! contain identical columns because the matrix associated with 113 !! the barotropic stream function equation is then no more inverti- 114 !! ble. therefore bmask is set to 0 along lateral domain boundaries 115 !! even IF nperio is not zero. 88 !! are defined with the proper value at lateral domain boundaries. 116 89 !! 117 90 !! In case of open boundaries (lk_bdy=T): 118 91 !! - tmask is set to 1 on the points to be computed bay the open 119 92 !! boundaries routines. 120 !! - bmask is set to 0 on the open boundaries.121 93 !! 122 94 !! ** Action : tmask : land/ocean mask at t-point (=0. or 1.) … … 125 97 !! fmask : land/ocean mask at f-point (=0. or 1.) 126 98 !! =rn_shlat along lateral boundaries 127 !! bmask : land/ocean mask at barotropic stream128 !! function point (=0. or 1.) and set to 0 along lateral boundaries129 99 !! tmask_i : interior ocean mask 130 100 !!---------------------------------------------------------------------- 131 ! 132 INTEGER :: ji, jj, jk ! dummy loop indices 101 INTEGER :: ji, jj, jk ! dummy loop indices 133 102 INTEGER :: iif, iil, ii0, ii1, ii ! local integers 134 103 INTEGER :: ijf, ijl, ij0, ij1 ! - - … … 199 168 END DO 200 169 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 170 ! Interior domain mask (used for global sum) 222 171 ! -------------------- 223 172 tmask_i(:,:) = ssmask(:,:) ! (ISH) tmask_i = 1 even on the ice shelf 173 174 tmask_h(:,:) = 1._wp ! 0 on the halo and 1 elsewhere 224 175 iif = jpreci ! ??? 225 176 iil = nlci - jpreci + 1 … … 227 178 ijl = nlcj - jprecj + 1 228 179 229 tmask_ i( 1 :iif, : ) = 0._wp ! first columns230 tmask_ i(iil:jpi, : ) = 0._wp ! last columns (including mpp extra columns)231 tmask_ i( : , 1 :ijf) = 0._wp ! first rows232 tmask_ i( : ,ijl:jpj) = 0._wp ! last rows (including mpp extra rows)180 tmask_h( 1 :iif, : ) = 0._wp ! first columns 181 tmask_h(iil:jpi, : ) = 0._wp ! last columns (including mpp extra columns) 182 tmask_h( : , 1 :ijf) = 0._wp ! first rows 183 tmask_h( : ,ijl:jpj) = 0._wp ! last rows (including mpp extra rows) 233 184 234 185 ! north fold mask … … 241 192 IF( mjg(nlej) == jpjglo ) THEN ! only half of the nlcj-1 row 242 193 DO ji = iif+1, iil-1 243 tmask_ i(ji,nlej-1) = tmask_i(ji,nlej-1) * tpol(mig(ji))194 tmask_h(ji,nlej-1) = tmask_h(ji,nlej-1) * tpol(mig(ji)) 244 195 END DO 245 196 ENDIF 246 197 ENDIF 198 199 tmask_i(:,:) = tmask_i(:,:) * tmask_h(:,:) 200 247 201 IF( jperio == 5 .OR. jperio == 6 ) THEN ! F-point pivot 248 202 tpol( 1 :jpiglo) = 0._wp … … 264 218 END DO 265 219 END DO 266 ! (ISF) MIN(1,SUM(umask)) is here to check if you have effectively at least 1 wet u point220 ! (ISF) MIN(1,SUM(umask)) is here to check if you have effectively at least 1 wet cell at u point 267 221 DO jj = 1, jpjm1 268 222 DO ji = 1, fs_jpim1 ! vector loop 269 umask_i(ji,jj) = ssmask(ji,jj) * ssmask(ji+1,jj ) * MIN(1._wp,SUM(umask(ji,jj,:)))270 vmask_i(ji,jj) = ssmask(ji,jj) * ssmask(ji ,jj+1) * MIN(1._wp,SUM(vmask(ji,jj,:)))223 ssumask(ji,jj) = ssmask(ji,jj) * ssmask(ji+1,jj ) * MIN(1._wp,SUM(umask(ji,jj,:))) 224 ssvmask(ji,jj) = ssmask(ji,jj) * ssmask(ji ,jj+1) * MIN(1._wp,SUM(vmask(ji,jj,:))) 271 225 END DO 272 226 DO ji = 1, jpim1 ! NO vector opt. 273 fmask_i(ji,jj) = ssmask(ji,jj ) * ssmask(ji+1,jj ) &227 ssfmask(ji,jj) = ssmask(ji,jj ) * ssmask(ji+1,jj ) & 274 228 & * ssmask(ji,jj+1) * ssmask(ji+1,jj+1) * MIN(1._wp,SUM(fmask(ji,jj,:))) 275 229 END DO 276 230 END DO 277 CALL lbc_lnk( umask , 'U', 1._wp ) ! Lateral boundary conditions278 CALL lbc_lnk( vmask , 'V', 1._wp )279 CALL lbc_lnk( fmask , 'F', 1._wp )280 CALL lbc_lnk( umask_i, 'U', 1._wp ) ! Lateral boundary conditions281 CALL lbc_lnk( vmask_i, 'V', 1._wp )282 CALL lbc_lnk( fmask_i, 'F', 1._wp )231 CALL lbc_lnk( umask , 'U', 1._wp ) ! Lateral boundary conditions 232 CALL lbc_lnk( vmask , 'V', 1._wp ) 233 CALL lbc_lnk( fmask , 'F', 1._wp ) 234 CALL lbc_lnk( ssumask, 'U', 1._wp ) ! Lateral boundary conditions 235 CALL lbc_lnk( ssvmask, 'V', 1._wp ) 236 CALL lbc_lnk( ssfmask, 'F', 1._wp ) 283 237 284 238 ! 3. Ocean/land mask at wu-, wv- and w points 285 239 !---------------------------------------------- 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)240 wmask (:,:,1) = tmask(:,:,1) ! surface 241 wumask(:,:,1) = umask(:,:,1) 242 wvmask(:,:,1) = vmask(:,:,1) 243 DO jk = 2, jpk ! interior values 244 wmask (:,:,jk) = tmask(:,:,jk) * tmask(:,:,jk-1) 245 wumask(:,:,jk) = umask(:,:,jk) * umask(:,:,jk-1) 246 wvmask(:,:,jk) = vmask(:,:,jk) * vmask(:,:,jk-1) 293 247 END DO 294 248 295 ! 4. ocean/land mask for the elliptic equation296 ! --------------------------------------------297 bmask(:,:) = ssmask(:,:) ! elliptic equation is written at t-point298 !299 ! ! Boundary conditions300 ! ! cyclic east-west : bmask must be set to 0. on rows 1 and jpi301 IF( nperio == 1 .OR. nperio == 4 .OR. nperio == 6 ) THEN302 bmask( 1 ,:) = 0._wp303 bmask(jpi,:) = 0._wp304 ENDIF305 IF( nperio == 2 ) THEN ! south symmetric : bmask must be set to 0. on row 1306 bmask(:, 1 ) = 0._wp307 ENDIF308 ! ! north fold :309 IF( nperio == 3 .OR. nperio == 4 ) THEN ! T-pt pivot : bmask set to 0. on row jpj and on half jpjglo-1 row310 DO ji = 1, jpi311 ii = ji + nimpp - 1312 bmask(ji,jpj-1) = bmask(ji,jpj-1) * tpol(ii)313 bmask(ji,jpj ) = 0._wp314 END DO315 ENDIF316 IF( nperio == 5 .OR. nperio == 6 ) THEN ! F-pt pivot and T-pt elliptic eq. : bmask set to 0. on row jpj317 bmask(:,jpj) = 0._wp318 ENDIF319 !320 IF( lk_mpp ) THEN ! mpp specificities321 ! ! bmask is set to zero on the overlap region322 IF( nbondi /= -1 .AND. nbondi /= 2 ) bmask( 1 :jpreci,:) = 0._wp323 IF( nbondi /= 1 .AND. nbondi /= 2 ) bmask(nlci:jpi ,:) = 0._wp324 IF( nbondj /= -1 .AND. nbondj /= 2 ) bmask(:, 1 :jprecj) = 0._wp325 IF( nbondj /= 1 .AND. nbondj /= 2 ) bmask(:,nlcj:jpj ) = 0._wp326 !327 IF( npolj == 3 .OR. npolj == 4 ) THEN ! north fold : bmask must be set to 0. on rows jpj-1 and jpj328 DO ji = 1, nlci329 ii = ji + nimpp - 1330 bmask(ji,nlcj-1) = bmask(ji,nlcj-1) * tpol(ii)331 bmask(ji,nlcj ) = 0._wp332 END DO333 ENDIF334 IF( npolj == 5 .OR. npolj == 6 ) THEN ! F-pt pivot and T-pt elliptic eq. : bmask set to 0. on row jpj335 DO ji = 1, nlci336 bmask(ji,nlcj ) = 0._wp337 END DO338 ENDIF339 ENDIF340 341 342 ! mask for second order calculation of vorticity343 ! ----------------------------------------------344 CALL dom_msk_nsa345 346 347 249 ! Lateral boundary conditions on velocity (modify fmask) 348 250 ! --------------------------------------- … … 377 279 IF( cp_cfg == "orca" .AND. jp_cfg == 2 ) THEN ! ORCA_R2 configuration 378 280 ! ! 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 281 ! ! Gibraltar strait : partial slip (fmask=0.5) 282 ij0 = 101 ; ij1 = 101 283 ii0 = 139 ; ii1 = 140 ; fmask( mi0(ii0):mi1(ii1) , mj0(ij0):mj1(ij1) , 1:jpk ) = 0.5_wp 284 ij0 = 102 ; ij1 = 102 285 ii0 = 139 ; ii1 = 140 ; fmask( mi0(ii0):mi1(ii1) , mj0(ij0):mj1(ij1) , 1:jpk ) = 0.5_wp 286 ! 287 ! ! Bab el Mandeb : partial slip (fmask=1) 288 ij0 = 87 ; ij1 = 88 289 ii0 = 160 ; ii1 = 160 ; fmask( mi0(ii0):mi1(ii1) , mj0(ij0):mj1(ij1) , 1:jpk ) = 1._wp 290 ij0 = 88 ; ij1 = 88 291 ii0 = 159 ; ii1 = 159 ; fmask( mi0(ii0):mi1(ii1) , mj0(ij0):mj1(ij1) , 1:jpk ) = 1._wp 292 ! 393 293 ! ! Danish straits : strong slip (fmask > 2) 394 294 ! We keep this as an example but it is instable in this case … … 413 313 IF(lwp) WRITE(numout,*) ' Gibraltar ' 414 314 ii0 = 282 ; ii1 = 283 ! Gibraltar Strait 415 ij0 = 2 01 +isrow ; ij1 = 241 - isrow ; fmask( mi0(ii0):mi1(ii1),mj0(ij0):mj1(ij1),1:jpk ) = 2._wp315 ij0 = 241 - isrow ; ij1 = 241 - isrow ; fmask( mi0(ii0):mi1(ii1),mj0(ij0):mj1(ij1),1:jpk ) = 2._wp 416 316 417 317 IF(lwp) WRITE(numout,*) ' Bhosporus ' 418 318 ii0 = 314 ; ii1 = 315 ! Bhosporus Strait 419 ij0 = 2 08 +isrow ; ij1 = 248 - isrow ; fmask( mi0(ii0):mi1(ii1),mj0(ij0):mj1(ij1),1:jpk ) = 2._wp319 ij0 = 248 - isrow ; ij1 = 248 - isrow ; fmask( mi0(ii0):mi1(ii1),mj0(ij0):mj1(ij1),1:jpk ) = 2._wp 420 320 421 321 IF(lwp) WRITE(numout,*) ' Makassar (Top) ' 422 322 ii0 = 48 ; ii1 = 48 ! Makassar Strait (Top) 423 ij0 = 1 49 +isrow ; ij1 = 190 - isrow ; fmask( mi0(ii0):mi1(ii1),mj0(ij0):mj1(ij1),1:jpk ) = 3._wp323 ij0 = 189 - isrow ; ij1 = 190 - isrow ; fmask( mi0(ii0):mi1(ii1),mj0(ij0):mj1(ij1),1:jpk ) = 3._wp 424 324 425 325 IF(lwp) WRITE(numout,*) ' Lombok ' 426 326 ii0 = 44 ; ii1 = 44 ! Lombok Strait 427 ij0 = 1 24 +isrow ; ij1 = 165 - isrow ; fmask( mi0(ii0):mi1(ii1),mj0(ij0):mj1(ij1),1:jpk ) = 2._wp327 ij0 = 164 - isrow ; ij1 = 165 - isrow ; fmask( mi0(ii0):mi1(ii1),mj0(ij0):mj1(ij1),1:jpk ) = 2._wp 428 328 429 329 IF(lwp) WRITE(numout,*) ' Ombai ' 430 330 ii0 = 53 ; ii1 = 53 ! Ombai Strait 431 ij0 = 1 24 +isrow ; ij1 = 165 - isrow ; fmask( mi0(ii0):mi1(ii1),mj0(ij0):mj1(ij1),1:jpk ) = 2._wp331 ij0 = 164 - isrow ; ij1 = 165 - isrow ; fmask( mi0(ii0):mi1(ii1),mj0(ij0):mj1(ij1),1:jpk ) = 2._wp 432 332 433 333 IF(lwp) WRITE(numout,*) ' Timor Passage ' 434 334 ii0 = 56 ; ii1 = 56 ! Timor Passage 435 ij0 = 1 24 +isrow ; ij1 = 165 - isrow ; fmask( mi0(ii0):mi1(ii1),mj0(ij0):mj1(ij1),1:jpk ) = 2._wp335 ij0 = 164 - isrow ; ij1 = 165 - isrow ; fmask( mi0(ii0):mi1(ii1),mj0(ij0):mj1(ij1),1:jpk ) = 2._wp 436 336 437 337 IF(lwp) WRITE(numout,*) ' West Halmahera ' 438 338 ii0 = 58 ; ii1 = 58 ! West Halmahera Strait 439 ij0 = 1 41 +isrow ; ij1 = 182 - isrow ; fmask( mi0(ii0):mi1(ii1),mj0(ij0):mj1(ij1),1:jpk ) = 3._wp339 ij0 = 181 - isrow ; ij1 = 182 - isrow ; fmask( mi0(ii0):mi1(ii1),mj0(ij0):mj1(ij1),1:jpk ) = 3._wp 440 340 441 341 IF(lwp) WRITE(numout,*) ' East Halmahera ' 442 342 ii0 = 55 ; ii1 = 55 ! East Halmahera Strait 443 ij0 = 1 41 +isrow ; ij1 = 182 - isrow ; fmask( mi0(ii0):mi1(ii1),mj0(ij0):mj1(ij1),1:jpk ) = 3._wp343 ij0 = 181 - isrow ; ij1 = 182 - isrow ; fmask( mi0(ii0):mi1(ii1),mj0(ij0):mj1(ij1),1:jpk ) = 3._wp 444 344 ! 445 345 ENDIF 446 346 ! 447 347 CALL lbc_lnk( fmask, 'F', 1._wp ) ! Lateral boundary conditions on fmask 448 348 ! 449 349 ! CAUTION : The fmask may be further modified in dyn_vor_init ( dynvor.F90 ) 450 451 IF( nprint == 1 .AND. lwp ) THEN ! Control print452 imsk(:,:) = INT( tmask_i(:,:) )453 WRITE(numout,*) ' tmask_i : '454 CALL prihin( imsk(:,:), jpi, jpj, 1, jpi, 1, &455 & 1, jpj, 1, 1, numout)456 WRITE (numout,*)457 WRITE (numout,*) ' dommsk: tmask for each level'458 WRITE (numout,*) ' ----------------------------'459 DO jk = 1, jpk460 imsk(:,:) = INT( tmask(:,:,jk) )461 462 WRITE(numout,*)463 WRITE(numout,*) ' level = ',jk464 CALL prihin( imsk(:,:), jpi, jpj, 1, jpi, 1, &465 & 1, jpj, 1, 1, numout)466 END DO467 WRITE(numout,*)468 WRITE(numout,*) ' dom_msk: vmask for each level'469 WRITE(numout,*) ' -----------------------------'470 DO jk = 1, jpk471 imsk(:,:) = INT( vmask(:,:,jk) )472 WRITE(numout,*)473 WRITE(numout,*) ' level = ',jk474 CALL prihin( imsk(:,:), jpi, jpj, 1, jpi, 1, &475 & 1, jpj, 1, 1, numout)476 END DO477 WRITE(numout,*)478 WRITE(numout,*) ' dom_msk: fmask for each level'479 WRITE(numout,*) ' -----------------------------'480 DO jk = 1, jpk481 imsk(:,:) = INT( fmask(:,:,jk) )482 WRITE(numout,*)483 WRITE(numout,*) ' level = ',jk484 CALL prihin( imsk(:,:), jpi, jpj, 1, jpi, 1, &485 & 1, jpj, 1, 1, numout )486 END DO487 WRITE(numout,*)488 WRITE(numout,*) ' dom_msk: bmask '489 WRITE(numout,*) ' ---------------'490 WRITE(numout,*)491 imsk(:,:) = INT( bmask(:,:) )492 CALL prihin( imsk(:,:), jpi, jpj, 1, jpi, 1, &493 & 1, jpj, 1, 1, numout )494 ENDIF495 350 ! 496 351 CALL wrk_dealloc( jpi, jpj, imsk ) … … 500 355 ! 501 356 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 357 696 358 !!======================================================================
Note: See TracChangeset
for help on using the changeset viewer.
