New URL for NEMO forge!   http://forge.nemo-ocean.eu

Since March 2022 along with NEMO 4.2 release, the code development moved to a self-hosted GitLab.
This present forge is now archived and remained online for history.
bdylib.F90 in branches/NERC/dev_r6998_ORCHESTRA/NEMOGCM/NEMO/OPA_SRC/BDY – NEMO

source: branches/NERC/dev_r6998_ORCHESTRA/NEMOGCM/NEMO/OPA_SRC/BDY/bdylib.F90 @ 7029

Last change on this file since 7029 was 7029, checked in by jamesharle, 8 years ago

Adding ORCHESTRA configuration
Merging with branches/2016/dev_r5549_BDY_ZEROGRAD
Merging with branches/2016/dev_r5840_BDY_MSK
Merging with branches/2014/dev_r4621_NOC4_BDY_VERT_INTERP
  • Property svn:keywords set to Id
File size: 24.0 KB
Line 
1MODULE bdylib
2   !!======================================================================
3   !!                       ***  MODULE  bdylib  ***
4   !! Unstructured Open Boundary Cond. :  Library module of generic boundary algorithms.
5   !!======================================================================
6   !! History :  3.6  !  2013     (D. Storkey) original code
7   !!----------------------------------------------------------------------
8#if defined key_bdy 
9   !!----------------------------------------------------------------------
10   !!   'key_bdy' :                    Unstructured Open Boundary Condition
11   !!----------------------------------------------------------------------
12   !!   bdy_orlanski_2d
13   !!   bdy_orlanski_3d
14   !!----------------------------------------------------------------------
15   USE oce            ! ocean dynamics and tracers
16   USE dom_oce        ! ocean space and time domain
17   USE bdy_oce        ! ocean open boundary conditions
18   USE phycst         ! physical constants
19   !
20   USE in_out_manager !
21   USE lbclnk         ! ocean lateral boundary conditions (or mpp link)
22   USE timing         ! Timing
23
24   IMPLICIT NONE
25   PRIVATE
26
27   PUBLIC   bdy_orlanski_2d     ! routine called where?
28   PUBLIC   bdy_orlanski_3d     ! routine called where?
29   PUBLIC   bdy_nmn             ! routine called where?
30
31   !!----------------------------------------------------------------------
32   !! NEMO/OPA 3.3 , NEMO Consortium (2010)
33   !! $Id$
34   !! Software governed by the CeCILL licence (NEMOGCM/NEMO_CeCILL.txt)
35   !!----------------------------------------------------------------------
36CONTAINS
37
38   SUBROUTINE bdy_orlanski_2d( idx, igrd, phib, phia, phi_ext, ll_npo )
39      !!----------------------------------------------------------------------
40      !!                 ***  SUBROUTINE bdy_orlanski_2d  ***
41      !!             
42      !!              - Apply Orlanski radiation condition adaptively to 2D fields:
43      !!                  - radiation plus weak nudging at outflow points
44      !!                  - no radiation and strong nudging at inflow points
45      !!
46      !!
47      !! References:  Marchesiello, McWilliams and Shchepetkin, Ocean Modelling vol. 3 (2001)   
48      !!----------------------------------------------------------------------
49      TYPE(OBC_INDEX),          INTENT(in   ) ::   idx      ! BDY indices
50      INTEGER ,                 INTENT(in   ) ::   igrd     ! grid index
51      REAL(wp), DIMENSION(:,:), INTENT(in   ) ::   phib     ! model before 2D field
52      REAL(wp), DIMENSION(:,:), INTENT(inout) ::   phia     ! model after 2D field (to be updated)
53      REAL(wp), DIMENSION(:)  , INTENT(in   ) ::   phi_ext  ! external forcing data
54      LOGICAL ,                 INTENT(in   ) ::   ll_npo   ! switch for NPO version
55      !
56      INTEGER  ::   jb                                     ! dummy loop indices
57      INTEGER  ::   ii, ij, iibm1, iibm2, ijbm1, ijbm2     ! 2D addresses
58      INTEGER  ::   iijm1, iijp1, ijjm1, ijjp1             ! 2D addresses
59      INTEGER  ::   iibm1jp1, iibm1jm1, ijbm1jp1, ijbm1jm1 ! 2D addresses
60      INTEGER  ::   ii_offset, ij_offset                   ! offsets for mask indices
61      INTEGER  ::   flagu, flagv                           ! short cuts
62      REAL(wp) ::   zmask_x, zmask_y1, zmask_y2
63      REAL(wp) ::   zex1, zex2, zey, zey1, zey2
64      REAL(wp) ::   zdt, zdx, zdy, znor2, zrx, zry         ! intermediate calculations
65      REAL(wp) ::   zout, zwgt, zdy_centred
66      REAL(wp) ::   zdy_1, zdy_2, zsign_ups
67      REAL(wp), PARAMETER :: zepsilon = 1.e-30                 ! local small value
68      REAL(wp), POINTER, DIMENSION(:,:)          :: pmask      ! land/sea mask for field
69      REAL(wp), POINTER, DIMENSION(:,:)          :: pmask_xdif ! land/sea mask for x-derivatives
70      REAL(wp), POINTER, DIMENSION(:,:)          :: pmask_ydif ! land/sea mask for y-derivatives
71      REAL(wp), POINTER, DIMENSION(:,:)          :: pe_xdif    ! scale factors for x-derivatives
72      REAL(wp), POINTER, DIMENSION(:,:)          :: pe_ydif    ! scale factors for y-derivatives
73      !!----------------------------------------------------------------------
74      !
75      IF( nn_timing == 1 )   CALL timing_start('bdy_orlanski_2d')
76      !
77      ! ----------------------------------!
78      ! Orlanski boundary conditions     :!
79      ! ----------------------------------!
80     
81      SELECT CASE(igrd)
82         CASE(1)
83            pmask      => tmask(:,:,1)
84            pmask_xdif => umask(:,:,1)
85            pmask_ydif => vmask(:,:,1)
86            pe_xdif    => e1u(:,:)
87            pe_ydif    => e2v(:,:)
88            ii_offset = 0
89            ij_offset = 0
90         CASE(2)
91            pmask      => umask(:,:,1)
92            pmask_xdif => tmask(:,:,1)
93            pmask_ydif => fmask(:,:,1)
94            pe_xdif    => e1t(:,:)
95            pe_ydif    => e2f(:,:)
96            ii_offset = 1
97            ij_offset = 0
98         CASE(3)
99            pmask      => vmask(:,:,1)
100            pmask_xdif => fmask(:,:,1)
101            pmask_ydif => tmask(:,:,1)
102            pe_xdif    => e1f(:,:)
103            pe_ydif    => e2t(:,:)
104            ii_offset = 0
105            ij_offset = 1
106         CASE DEFAULT ;   CALL ctl_stop( 'unrecognised value for igrd in bdy_orlanksi_2d' )
107      END SELECT
108      !
109      DO jb = 1, idx%nblenrim(igrd)
110         ii  = idx%nbi(jb,igrd)
111         ij  = idx%nbj(jb,igrd) 
112         flagu = int( idx%flagu(jb,igrd) )
113         flagv = int( idx%flagv(jb,igrd) )
114         !
115         ! Calculate positions of b-1 and b-2 points for this rim point
116         ! also (b-1,j-1) and (b-1,j+1) points
117         iibm1 = ii + flagu ; iibm2 = ii + 2*flagu 
118         ijbm1 = ij + flagv ; ijbm2 = ij + 2*flagv
119          !
120         iijm1 = ii - abs(flagv) ; iijp1 = ii + abs(flagv) 
121         ijjm1 = ij - abs(flagu) ; ijjp1 = ij + abs(flagu)
122         !
123         iibm1jm1 = ii + flagu - abs(flagv) ; iibm1jp1 = ii + flagu + abs(flagv) 
124         ijbm1jm1 = ij + flagv - abs(flagu) ; ijbm1jp1 = ij + flagv + abs(flagu) 
125         !
126         ! Calculate scale factors for calculation of spatial derivatives.       
127         zex1 = ( abs(iibm1-iibm2) * pe_xdif(iibm1+ii_offset,ijbm1          )         &
128        &       + abs(ijbm1-ijbm2) * pe_ydif(iibm1          ,ijbm1+ij_offset) ) 
129         zex2 = ( abs(iibm1-iibm2) * pe_xdif(iibm2+ii_offset,ijbm2          )         &
130        &       + abs(ijbm1-ijbm2) * pe_ydif(iibm2          ,ijbm2+ij_offset) ) 
131         zey1 = ( (iibm1-iibm1jm1) * pe_xdif(iibm1jm1+ii_offset,ijbm1jm1          )  & 
132        &      +  (ijbm1-ijbm1jm1) * pe_ydif(iibm1jm1          ,ijbm1jm1+ij_offset) ) 
133         zey2 = ( (iibm1jp1-iibm1) * pe_xdif(iibm1+ii_offset,ijbm1)                  &
134        &      +  (ijbm1jp1-ijbm1) * pe_ydif(iibm1          ,ijbm1+ij_offset) ) 
135         ! make sure scale factors are nonzero
136         if( zey1 .lt. rsmall ) zey1 = zey2
137         if( zey2 .lt. rsmall ) zey2 = zey1
138         zex1 = max(zex1,rsmall); zex2 = max(zex2,rsmall)
139         zey1 = max(zey1,rsmall); zey2 = max(zey2,rsmall); 
140         !
141         ! Calculate masks for calculation of spatial derivatives.       
142         zmask_x = ( abs(iibm1-iibm2) * pmask_xdif(iibm2+ii_offset,ijbm2          )         &
143        &          + abs(ijbm1-ijbm2) * pmask_ydif(iibm2          ,ijbm2+ij_offset) ) 
144         zmask_y1 = ( (iibm1-iibm1jm1) * pmask_xdif(iibm1jm1+ii_offset,ijbm1jm1          )  & 
145        &          +  (ijbm1-ijbm1jm1) * pmask_ydif(iibm1jm1          ,ijbm1jm1+ij_offset) ) 
146         zmask_y2 = ( (iibm1jp1-iibm1) * pmask_xdif(iibm1+ii_offset,ijbm1)                  &
147        &          +  (ijbm1jp1-ijbm1) * pmask_ydif(iibm1          ,ijbm1+ij_offset) ) 
148
149         ! Calculation of terms required for both versions of the scheme.
150         ! Mask derivatives to ensure correct land boundary conditions for each variable.
151         ! Centred derivative is calculated as average of "left" and "right" derivatives for
152         ! this reason.
153         ! Note no rdt factor in expression for zdt because it cancels in the expressions for
154         ! zrx and zry.
155         zdt = phia(iibm1,ijbm1) - phib(iibm1,ijbm1)
156         zdx = ( ( phia(iibm1,ijbm1) - phia(iibm2,ijbm2) ) / zex2 ) * zmask_x 
157         zdy_1 = ( ( phib(iibm1   ,ijbm1   ) - phib(iibm1jm1,ijbm1jm1) ) / zey1 ) * zmask_y1   
158         zdy_2 = ( ( phib(iibm1jp1,ijbm1jp1) - phib(iibm1   ,ijbm1)    ) / zey2 ) * zmask_y2 
159         zdy_centred = 0.5 * ( zdy_1 + zdy_2 )
160!!$         zdy_centred = phib(iibm1jp1,ijbm1jp1) - phib(iibm1jm1,ijbm1jm1)
161         ! upstream differencing for tangential derivatives
162         zsign_ups = sign( 1., zdt * zdy_centred )
163         zsign_ups = 0.5*( zsign_ups + abs(zsign_ups) )
164         zdy = zsign_ups * zdy_1 + (1. - zsign_ups) * zdy_2
165         znor2 = zdx * zdx + zdy * zdy
166         znor2 = max(znor2,zepsilon)
167         !
168         zrx = zdt * zdx / ( zex1 * znor2 ) 
169!!$         zrx = min(zrx,2.0_wp)
170         zout = sign( 1., zrx )
171         zout = 0.5*( zout + abs(zout) )
172         zwgt = 2.*rdt*( (1.-zout) * idx%nbd(jb,igrd) + zout * idx%nbdout(jb,igrd) )
173         ! only apply radiation on outflow points
174         if( ll_npo ) then     !! NPO version !!
175            phia(ii,ij) = (1.-zout) * ( phib(ii,ij) + zwgt * ( phi_ext(jb) - phib(ii,ij) ) )        &
176           &            + zout      * ( phib(ii,ij) + zrx*phia(iibm1,ijbm1)                         &
177           &                            + zwgt * ( phi_ext(jb) - phib(ii,ij) ) ) / ( 1. + zrx ) 
178         else                  !! full oblique radiation !!
179            zsign_ups = sign( 1., zdt * zdy )
180            zsign_ups = 0.5*( zsign_ups + abs(zsign_ups) )
181            zey = zsign_ups * zey1 + (1.-zsign_ups) * zey2 
182            zry = zdt * zdy / ( zey * znor2 ) 
183            phia(ii,ij) = (1.-zout) * ( phib(ii,ij) + zwgt * ( phi_ext(jb) - phib(ii,ij) ) )        &
184           &            + zout      * ( phib(ii,ij) + zrx*phia(iibm1,ijbm1)                         &
185           &                    - zsign_ups      * zry * ( phib(ii   ,ij   ) - phib(iijm1,ijjm1 ) ) &
186           &                    - (1.-zsign_ups) * zry * ( phib(iijp1,ijjp1) - phib(ii   ,ij    ) ) &
187           &                    + zwgt * ( phi_ext(jb) - phib(ii,ij) ) ) / ( 1. + zrx ) 
188         end if
189         phia(ii,ij) = phia(ii,ij) * pmask(ii,ij)
190      END DO
191      !
192      IF( nn_timing == 1 )   CALL timing_stop('bdy_orlanski_2d')
193      !
194   END SUBROUTINE bdy_orlanski_2d
195
196
197   SUBROUTINE bdy_orlanski_3d( idx, igrd, phib, phia, phi_ext, ll_npo )
198      !!----------------------------------------------------------------------
199      !!                 ***  SUBROUTINE bdy_orlanski_3d  ***
200      !!             
201      !!              - Apply Orlanski radiation condition adaptively to 3D fields:
202      !!                  - radiation plus weak nudging at outflow points
203      !!                  - no radiation and strong nudging at inflow points
204      !!
205      !!
206      !! References:  Marchesiello, McWilliams and Shchepetkin, Ocean Modelling vol. 3 (2001)   
207      !!----------------------------------------------------------------------
208      TYPE(OBC_INDEX),            INTENT(in   ) ::   idx      ! BDY indices
209      INTEGER ,                   INTENT(in   ) ::   igrd     ! grid index
210      REAL(wp), DIMENSION(:,:,:), INTENT(in   ) ::   phib     ! model before 3D field
211      REAL(wp), DIMENSION(:,:,:), INTENT(inout) ::   phia     ! model after 3D field (to be updated)
212      REAL(wp), DIMENSION(:,:)  , INTENT(in   ) ::   phi_ext  ! external forcing data
213      LOGICAL ,                   INTENT(in   ) ::   ll_npo   ! switch for NPO version
214      !
215      INTEGER  ::   jb, jk                                 ! dummy loop indices
216      INTEGER  ::   ii, ij, iibm1, iibm2, ijbm1, ijbm2     ! 2D addresses
217      INTEGER  ::   iijm1, iijp1, ijjm1, ijjp1             ! 2D addresses
218      INTEGER  ::   iibm1jp1, iibm1jm1, ijbm1jp1, ijbm1jm1 ! 2D addresses
219      INTEGER  ::   ii_offset, ij_offset                   ! offsets for mask indices
220      INTEGER  ::   flagu, flagv                           ! short cuts
221      REAL(wp) ::   zmask_x, zmask_y1, zmask_y2
222      REAL(wp) ::   zex1, zex2, zey, zey1, zey2
223      REAL(wp) ::   zdt, zdx, zdy, znor2, zrx, zry         ! intermediate calculations
224      REAL(wp) ::   zout, zwgt, zdy_centred
225      REAL(wp) ::   zdy_1, zdy_2,  zsign_ups
226      REAL(wp), PARAMETER :: zepsilon = 1.e-30                 ! local small value
227      REAL(wp), POINTER, DIMENSION(:,:,:)        :: pmask      ! land/sea mask for field
228      REAL(wp), POINTER, DIMENSION(:,:,:)        :: pmask_xdif ! land/sea mask for x-derivatives
229      REAL(wp), POINTER, DIMENSION(:,:,:)        :: pmask_ydif ! land/sea mask for y-derivatives
230      REAL(wp), POINTER, DIMENSION(:,:)          :: pe_xdif    ! scale factors for x-derivatives
231      REAL(wp), POINTER, DIMENSION(:,:)          :: pe_ydif    ! scale factors for y-derivatives
232      !!----------------------------------------------------------------------
233      !
234      IF( nn_timing == 1 )   CALL timing_start('bdy_orlanski_3d')
235      !
236      ! ----------------------------------!
237      ! Orlanski boundary conditions     :!
238      ! ----------------------------------!
239      !
240      SELECT CASE(igrd)
241         CASE(1)
242            pmask      => tmask(:,:,:)
243            pmask_xdif => umask(:,:,:)
244            pmask_ydif => vmask(:,:,:)
245            pe_xdif    => e1u(:,:)
246            pe_ydif    => e2v(:,:)
247            ii_offset = 0
248            ij_offset = 0
249         CASE(2)
250            pmask      => umask(:,:,:)
251            pmask_xdif => tmask(:,:,:)
252            pmask_ydif => fmask(:,:,:)
253            pe_xdif    => e1t(:,:)
254            pe_ydif    => e2f(:,:)
255            ii_offset = 1
256            ij_offset = 0
257         CASE(3)
258            pmask      => vmask(:,:,:)
259            pmask_xdif => fmask(:,:,:)
260            pmask_ydif => tmask(:,:,:)
261            pe_xdif    => e1f(:,:)
262            pe_ydif    => e2t(:,:)
263            ii_offset = 0
264            ij_offset = 1
265         CASE DEFAULT ;   CALL ctl_stop( 'unrecognised value for igrd in bdy_orlanksi_2d' )
266      END SELECT
267
268      DO jk = 1, jpk
269         !           
270         DO jb = 1, idx%nblenrim(igrd)
271            ii  = idx%nbi(jb,igrd)
272            ij  = idx%nbj(jb,igrd) 
273            flagu = int( idx%flagu(jb,igrd) )
274            flagv = int( idx%flagv(jb,igrd) )
275            !
276            ! calculate positions of b-1 and b-2 points for this rim point
277            ! also (b-1,j-1) and (b-1,j+1) points
278            iibm1 = ii + flagu ; iibm2 = ii + 2*flagu 
279            ijbm1 = ij + flagv ; ijbm2 = ij + 2*flagv
280            !
281            iijm1 = ii - abs(flagv) ; iijp1 = ii + abs(flagv) 
282            ijjm1 = ij - abs(flagu) ; ijjp1 = ij + abs(flagu)
283            !
284            iibm1jm1 = ii + flagu - abs(flagv) ; iibm1jp1 = ii + flagu + abs(flagv) 
285            ijbm1jm1 = ij + flagv - abs(flagu) ; ijbm1jp1 = ij + flagv + abs(flagu) 
286            !
287            ! Calculate scale factors for calculation of spatial derivatives.       
288            zex1 = ( abs(iibm1-iibm2) * pe_xdif(iibm1+ii_offset,ijbm1          )         &
289           &       + abs(ijbm1-ijbm2) * pe_ydif(iibm1          ,ijbm1+ij_offset) ) 
290            zex2 = ( abs(iibm1-iibm2) * pe_xdif(iibm2+ii_offset,ijbm2          )         &
291           &       + abs(ijbm1-ijbm2) * pe_ydif(iibm2          ,ijbm2+ij_offset) ) 
292            zey1 = ( (iibm1-iibm1jm1) * pe_xdif(iibm1jm1+ii_offset,ijbm1jm1          )  & 
293           &      +  (ijbm1-ijbm1jm1) * pe_ydif(iibm1jm1          ,ijbm1jm1+ij_offset) ) 
294            zey2 = ( (iibm1jp1-iibm1) * pe_xdif(iibm1+ii_offset,ijbm1)                  &
295           &      +  (ijbm1jp1-ijbm1) * pe_ydif(iibm1          ,ijbm1+ij_offset) ) 
296            ! make sure scale factors are nonzero
297            if( zey1 .lt. rsmall ) zey1 = zey2
298            if( zey2 .lt. rsmall ) zey2 = zey1
299            zex1 = max(zex1,rsmall); zex2 = max(zex2,rsmall); 
300            zey1 = max(zey1,rsmall); zey2 = max(zey2,rsmall); 
301            !
302            ! Calculate masks for calculation of spatial derivatives.       
303            zmask_x = ( abs(iibm1-iibm2) * pmask_xdif(iibm2+ii_offset,ijbm2          ,jk)          &
304           &          + abs(ijbm1-ijbm2) * pmask_ydif(iibm2          ,ijbm2+ij_offset,jk) ) 
305            zmask_y1 = ( (iibm1-iibm1jm1) * pmask_xdif(iibm1jm1+ii_offset,ijbm1jm1          ,jk)   & 
306           &          +  (ijbm1-ijbm1jm1) * pmask_ydif(iibm1jm1          ,ijbm1jm1+ij_offset,jk) ) 
307            zmask_y2 = ( (iibm1jp1-iibm1) * pmask_xdif(iibm1+ii_offset,ijbm1          ,jk)         &
308           &          +  (ijbm1jp1-ijbm1) * pmask_ydif(iibm1          ,ijbm1+ij_offset,jk) ) 
309            !
310            ! Calculate normal (zrx) and tangential (zry) components of radiation velocities.
311            ! Mask derivatives to ensure correct land boundary conditions for each variable.
312            ! Centred derivative is calculated as average of "left" and "right" derivatives for
313            ! this reason.
314            zdt = phia(iibm1,ijbm1,jk) - phib(iibm1,ijbm1,jk)
315            zdx = ( ( phia(iibm1,ijbm1,jk) - phia(iibm2,ijbm2,jk) ) / zex2 ) * zmask_x                 
316            zdy_1 = ( ( phib(iibm1   ,ijbm1   ,jk) - phib(iibm1jm1,ijbm1jm1,jk) ) / zey1 ) * zmask_y1 
317            zdy_2 = ( ( phib(iibm1jp1,ijbm1jp1,jk) - phib(iibm1   ,ijbm1   ,jk) ) / zey2 ) * zmask_y2     
318            zdy_centred = 0.5 * ( zdy_1 + zdy_2 )
319!!$            zdy_centred = phib(iibm1jp1,ijbm1jp1,jk) - phib(iibm1jm1,ijbm1jm1,jk)
320            ! upstream differencing for tangential derivatives
321            zsign_ups = sign( 1., zdt * zdy_centred )
322            zsign_ups = 0.5*( zsign_ups + abs(zsign_ups) )
323            zdy = zsign_ups * zdy_1 + (1. - zsign_ups) * zdy_2
324            znor2 = zdx * zdx + zdy * zdy
325            znor2 = max(znor2,zepsilon)
326            !
327            ! update boundary value:
328            zrx = zdt * zdx / ( zex1 * znor2 )
329!!$            zrx = min(zrx,2.0_wp)
330            zout = sign( 1., zrx )
331            zout = 0.5*( zout + abs(zout) )
332            zwgt = 2.*rdt*( (1.-zout) * idx%nbd(jb,igrd) + zout * idx%nbdout(jb,igrd) )
333            ! only apply radiation on outflow points
334            if( ll_npo ) then     !! NPO version !!
335               phia(ii,ij,jk) = (1.-zout) * ( phib(ii,ij,jk) + zwgt * ( phi_ext(jb,jk) - phib(ii,ij,jk) ) ) &
336              &               + zout      * ( phib(ii,ij,jk) + zrx*phia(iibm1,ijbm1,jk)                     &
337              &                            + zwgt * ( phi_ext(jb,jk) - phib(ii,ij,jk) ) ) / ( 1. + zrx ) 
338            else                  !! full oblique radiation !!
339               zsign_ups = sign( 1., zdt * zdy )
340               zsign_ups = 0.5*( zsign_ups + abs(zsign_ups) )
341               zey = zsign_ups * zey1 + (1.-zsign_ups) * zey2 
342               zry = zdt * zdy / ( zey * znor2 ) 
343               phia(ii,ij,jk) = (1.-zout) * ( phib(ii,ij,jk) + zwgt * ( phi_ext(jb,jk) - phib(ii,ij,jk) ) )    &
344              &               + zout      * ( phib(ii,ij,jk) + zrx*phia(iibm1,ijbm1,jk)                        &
345              &                       - zsign_ups      * zry * ( phib(ii   ,ij   ,jk) - phib(iijm1,ijjm1,jk) ) &
346              &                       - (1.-zsign_ups) * zry * ( phib(iijp1,ijjp1,jk) - phib(ii   ,ij   ,jk) ) &
347              &                       + zwgt * ( phi_ext(jb,jk) - phib(ii,ij,jk) ) ) / ( 1. + zrx ) 
348            end if
349            phia(ii,ij,jk) = phia(ii,ij,jk) * pmask(ii,ij,jk)
350         END DO
351         !
352      END DO
353      !
354      IF( nn_timing == 1 )   CALL timing_stop('bdy_orlanski_3d')
355      !
356   END SUBROUTINE bdy_orlanski_3d
357
358   SUBROUTINE bdy_nmn( idx, igrd, phia )
359      !!----------------------------------------------------------------------
360      !!                 ***  SUBROUTINE bdy_nmn  ***
361      !!                   
362      !! ** Purpose : Duplicate the value at open boundaries, zero gradient.
363      !!
364      !!----------------------------------------------------------------------
365      INTEGER,                    INTENT(in)     ::   igrd     ! grid index
366      REAL(wp), DIMENSION(:,:,:), INTENT(inout)  ::   phia     ! model after 3D field (to be updated)
367      TYPE(OBC_INDEX), INTENT(in) ::   idx  ! OBC indices
368      !!
369      REAL(wp) ::   zcoef, zcoef1, zcoef2
370      REAL(wp), POINTER, DIMENSION(:,:,:)        :: pmask      ! land/sea mask for field
371      REAL(wp), POINTER, DIMENSION(:,:)        :: bdypmask      ! land/sea mask for field
372      INTEGER  ::   ib, ik   ! dummy loop indices
373      INTEGER  ::   ii, ij, ip, jp   ! 2D addresses
374      !!----------------------------------------------------------------------
375      !
376      IF( nn_timing == 1 ) CALL timing_start('bdy_nmn')
377      !
378      SELECT CASE(igrd)
379         CASE(1)
380            pmask => tmask(:,:,:)
381            bdypmask => bdytmask(:,:)
382         CASE(2)
383            pmask => umask(:,:,:)
384            bdypmask => bdyumask(:,:)
385         CASE(3)
386            pmask => vmask(:,:,:)
387            bdypmask => bdyvmask(:,:)
388         CASE DEFAULT ;   CALL ctl_stop( 'unrecognised value for igrd in bdy_nmn' )
389      END SELECT
390      DO ib = 1, idx%nblenrim(igrd)
391         ii = idx%nbi(ib,igrd)
392         ij = idx%nbj(ib,igrd)
393         DO ik = 1, jpkm1
394            ! search the sense of the gradient
395            zcoef1 = bdypmask(ii-1,ij  )*pmask(ii-1,ij,ik) +  bdypmask(ii+1,ij  )*pmask(ii+1,ij,ik)
396            zcoef2 = bdypmask(ii  ,ij-1)*pmask(ii,ij-1,ik) +  bdypmask(ii  ,ij+1)*pmask(ii,ij+1,ik)
397            IF ( nint(zcoef1+zcoef2) == 0) THEN
398               ! corner **** we probably only want to set the tangentail component for the dynamics here
399               zcoef = pmask(ii-1,ij,ik) + pmask(ii+1,ij,ik) +  pmask(ii,ij-1,ik) +  pmask(ii,ij+1,ik)
400               IF (zcoef > .5_wp) THEN ! Only set none isolated points.
401                 phia(ii,ij,ik) = phia(ii-1,ij  ,ik) * pmask(ii-1,ij  ,ik) + &
402                   &              phia(ii+1,ij  ,ik) * pmask(ii+1,ij  ,ik) + &
403                   &              phia(ii  ,ij-1,ik) * pmask(ii  ,ij-1,ik) + &
404                   &              phia(ii  ,ij+1,ik) * pmask(ii  ,ij+1,ik)
405                 phia(ii,ij,ik) = ( phia(ii,ij,ik) / zcoef ) * pmask(ii,ij,ik)
406               ELSE
407                 phia(ii,ij,ik) = phia(ii,ij  ,ik) * pmask(ii,ij  ,ik)
408               ENDIF
409            ELSEIF ( nint(zcoef1+zcoef2) == 2) THEN
410               ! oblique corner **** we probably only want to set the normal component for the dynamics here
411               zcoef = pmask(ii-1,ij,ik)*bdypmask(ii-1,ij  ) + pmask(ii+1,ij,ik)*bdypmask(ii+1,ij  ) + &
412                   &   pmask(ii,ij-1,ik)*bdypmask(ii,ij -1 ) +  pmask(ii,ij+1,ik)*bdypmask(ii,ij+1  )
413               phia(ii,ij,ik) = phia(ii-1,ij  ,ik) * pmask(ii-1,ij  ,ik)*bdypmask(ii-1,ij  ) + &
414                   &            phia(ii+1,ij  ,ik) * pmask(ii+1,ij  ,ik)*bdypmask(ii+1,ij  )  + &
415                   &            phia(ii  ,ij-1,ik) * pmask(ii  ,ij-1,ik)*bdypmask(ii,ij -1 ) + &
416                   &            phia(ii  ,ij+1,ik) * pmask(ii  ,ij+1,ik)*bdypmask(ii,ij+1  )
417 
418               phia(ii,ij,ik) = ( phia(ii,ij,ik) / MAX(1._wp, zcoef) ) * pmask(ii,ij,ik)
419            ELSE
420               ip = nint(bdypmask(ii+1,ij  )*pmask(ii+1,ij,ik) - bdypmask(ii-1,ij  )*pmask(ii-1,ij,ik))
421               jp = nint(bdypmask(ii  ,ij+1)*pmask(ii,ij+1,ik) - bdypmask(ii  ,ij-1)*pmask(ii,ij-1,ik))
422               phia(ii,ij,ik) = phia(ii+ip,ij+jp,ik) * pmask(ii+ip,ij+jp,ik)
423            ENDIF
424         END DO
425      END DO
426      !
427      IF( nn_timing == 1 ) CALL timing_stop('bdy_nmn')
428      !
429   END SUBROUTINE bdy_nmn
430
431#else
432   !!----------------------------------------------------------------------
433   !!   Dummy module                   NO Unstruct Open Boundary Conditions
434   !!----------------------------------------------------------------------
435CONTAINS
436   SUBROUTINE bdy_orlanski_2d( idx, igrd, phib, phia, phi_ext  )      ! Empty routine
437      WRITE(*,*) 'bdy_orlanski_2d: You should not have seen this print! error?', kt
438   END SUBROUTINE bdy_orlanski_2d
439   SUBROUTINE bdy_orlanski_3d( idx, igrd, phib, phia, phi_ext  )      ! Empty routine
440      WRITE(*,*) 'bdy_orlanski_3d: You should not have seen this print! error?', kt
441   END SUBROUTINE bdy_orlanski_3d
442   SUBROUTINE bdy_nmn( idx, igrd, phia )      ! Empty routine
443      WRITE(*,*) 'bdy_nmn: You should not have seen this print! error?', kt
444   END SUBROUTINE bdy_nmn
445#endif
446
447   !!======================================================================
448END MODULE bdylib
Note: See TracBrowser for help on using the repository browser.