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 NEMO/branches/UKMO/r8395_coupling_sequence/NEMOGCM/NEMO/OPA_SRC/BDY – NEMO

source: NEMO/branches/UKMO/r8395_coupling_sequence/NEMOGCM/NEMO/OPA_SRC/BDY/bdylib.F90 @ 10763

Last change on this file since 10763 was 10763, checked in by jcastill, 5 years ago

Remove svn keywords properly

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