source: NEMO/branches/2019/dev_r10984_HPC-13_IRRMANN_BDY_optimization/src/OCE/BDY/bdylib.F90 @ 11049

Last change on this file since 11049 was 11049, checked in by girrmann, 19 months ago

dev_r10984_HPC-13 : CYCLE instruction is not systematic anymore, computation is done on the halo whenever possible and overwritten by lbc_bdy instruction, see #2285

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