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/2019/dev_r10721_KERNEL-02_Storkey_Coward_IMMERSE_first_steps/src/OCE/BDY – NEMO

source: NEMO/branches/2019/dev_r10721_KERNEL-02_Storkey_Coward_IMMERSE_first_steps/src/OCE/BDY/bdylib.F90 @ 10957

Last change on this file since 10957 was 10957, checked in by davestorkey, 6 years ago

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