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.
agrif_top_interp.F90 in branches/2017/dev_CNRS_2017/NEMOGCM/NEMO/NST_SRC – NEMO

source: branches/2017/dev_CNRS_2017/NEMOGCM/NEMO/NST_SRC/agrif_top_interp.F90 @ 9012

Last change on this file since 9012 was 8882, checked in by flavoni, 6 years ago

dev_CNRS_2017 branch: merged dev_r7881_ENHANCE09_RK3 with trunk r8864
  • Property svn:keywords set to Id
File size: 8.9 KB
Line 
1MODULE agrif_top_interp
2   !!======================================================================
3   !!                   ***  MODULE  agrif_top_interp  ***
4   !! AGRIF: interpolation package for TOP
5   !!======================================================================
6   !! History :  2.0  !  ???
7   !!----------------------------------------------------------------------
8#if defined key_agrif && defined key_top
9   !!----------------------------------------------------------------------
10   !!   'key_agrif'                                              AGRIF zoom
11   !!   'key_top'                                           on-line tracers
12   !!----------------------------------------------------------------------
13   USE par_oce
14   USE oce
15   USE dom_oce     
16   USE agrif_oce
17   USE agrif_top_sponge
18   USE par_trc
19   USE trc
20   !
21   USE lib_mpp     ! MPP library
22
23   IMPLICIT NONE
24   PRIVATE
25
26   PUBLIC Agrif_trc, interptrn
27
28  !!----------------------------------------------------------------------
29   !! NEMO/NST 4.0 , NEMO Consortium (2017)
30   !! $Id$
31   !! Software governed by the CeCILL licence (NEMOGCM/NEMO_CeCILL.txt)
32   !!----------------------------------------------------------------------
33CONTAINS
34
35   SUBROUTINE Agrif_trc
36      !!----------------------------------------------------------------------
37      !!                   ***  ROUTINE Agrif_trc  ***
38      !!----------------------------------------------------------------------
39      !
40      IF( Agrif_Root() )   RETURN
41      !
42      Agrif_SpecialValue    = 0._wp
43      Agrif_UseSpecialValue = .TRUE.
44      !
45      CALL Agrif_Bc_variable( trn_id, procname=interptrn )
46      Agrif_UseSpecialValue = .FALSE.
47      !
48   END SUBROUTINE Agrif_trc
49
50
51   SUBROUTINE interptrn( ptab, i1, i2, j1, j2, k1, k2, n1, n2, before, nb, ndir )
52      !!----------------------------------------------------------------------
53      !!                   *** ROUTINE interptrn ***
54      !!----------------------------------------------------------------------
55      REAL(wp), DIMENSION(i1:i2,j1:j2,k1:k2,n1:n2), INTENT(inout) ::   ptab
56      INTEGER                                     , INTENT(in   ) ::   i1, i2, j1, j2, k1, k2, n1, n2
57      LOGICAL                                     , INTENT(in   ) ::   before
58      INTEGER                                     , INTENT(in   ) ::   nb , ndir
59      !!
60      INTEGER ::   ji, jj, jk, jn   ! dummy loop indices
61      INTEGER ::   imin, imax, jmin, jmax
62      LOGICAL ::   ll_west, ll_east, ll_north, ll_south
63      REAL(wp) ::   zrhox, z1, z2, z3, z4, z5, z6, z7
64      !!----------------------------------------------------------------------
65      !
66      IF( before ) THEN         
67         ptab(i1:i2,j1:j2,k1:k2,n1:n2) = trn(i1:i2,j1:j2,k1:k2,n1:n2)
68      ELSE
69         !
70         IF( nbghostcells > 1 ) THEN  ! no smoothing
71            tra(i1:i2,j1:j2,k1:k2,n1:n2) = ptab(i1:i2,j1:j2,k1:k2,n1:n2)
72         ELSE                         ! smoothing
73            !
74            ll_west  = (nb == 1).AND.(ndir == 1)   ;   ll_east  = (nb == 1).AND.(ndir == 2)
75            ll_south = (nb == 2).AND.(ndir == 1)   ;   ll_north = (nb == 2).AND.(ndir == 2)
76            !
77            zrhox = Agrif_Rhox()
78            z1 = ( zrhox - 1. ) * 0.5
79            z3 = ( zrhox - 1. ) / ( zrhox + 1. )
80            z6 = 2. * ( zrhox - 1. ) / ( zrhox + 1. )
81            z7 =    - ( zrhox - 1. ) / ( zrhox + 3. )
82            !
83            z2 = 1. - z1
84            z4 = 1. - z3
85            z5 = 1. - z6 - z7
86            !
87            imin = i1   ;   imax = i2
88            jmin = j1   ;   jmax = j2
89            !
90            ! Remove CORNERS
91            IF((nbondj == -1).OR.(nbondj == 2))   jmin = 3
92            IF((nbondj == +1).OR.(nbondj == 2))   jmax = nlcj-2
93            IF((nbondi == -1).OR.(nbondi == 2))   imin = 3
94            IF((nbondi == +1).OR.(nbondi == 2))   imax = nlci-2       
95            !
96            IF( ll_east ) THEN       !== eastern side  ==!
97               DO jn = 1, jptra
98                  tra(nlci,j1:j2,k1:k2,jn) = z1 * ptab(nlci,j1:j2,k1:k2,jn) + z2 * ptab(nlci-1,j1:j2,k1:k2,jn)
99                  DO jk = 1, jpkm1
100                     DO jj = jmin,jmax
101                        IF( umask(nlci-2,jj,jk) == 0._wp ) THEN
102                           tra(nlci-1,jj,jk,jn) = tra(nlci,jj,jk,jn) * tmask(nlci-1,jj,jk)
103                        ELSE
104                           tra(nlci-1,jj,jk,jn) = ( z4*tra(nlci,jj,jk,jn)+z3*tra(nlci-2,jj,jk,jn) ) * tmask(nlci-1,jj,jk)
105                           IF( un(nlci-2,jj,jk) > 0._wp ) THEN
106                              tra(nlci-1,jj,jk,jn) = ( z6*tra(nlci-2,jj,jk,jn)+z5*tra(nlci,jj,jk,jn)   & 
107                                 &                    +z7*tra(nlci-3,jj,jk,jn) ) * tmask(nlci-1,jj,jk)
108                           ENDIF
109                        ENDIF
110                     END DO
111                  END DO
112               ENDDO
113            ENDIF
114            !
115            IF( ll_north ) THEN        !==  northern side  ==!
116               DO jn = 1, jptra
117                  tra(i1:i2,nlcj,k1:k2,jn) = z1 * ptab(i1:i2,nlcj,k1:k2,jn) + z2 * ptab(i1:i2,nlcj-1,k1:k2,jn)
118                  DO jk = 1, jpkm1
119                     DO ji = imin, imax
120                        IF( vmask(ji,nlcj-2,jk) == 0._wp ) THEN
121                           tra(ji,nlcj-1,jk,jn) = tra(ji,nlcj,jk,jn) * tmask(ji,nlcj-1,jk)
122                        ELSE
123                           tra(ji,nlcj-1,jk,jn) = ( z4*tra(ji,nlcj,jk,jn)+z3*tra(ji,nlcj-2,jk,jn) ) * tmask(ji,nlcj-1,jk)       
124                           IF (vn(ji,nlcj-2,jk) > 0._wp ) THEN
125                              tra(ji,nlcj-1,jk,jn) = ( z6*tra(ji,nlcj-2,jk,jn)+z5*tra(ji,nlcj,jk,jn)  &
126                                 &                    +z7*tra(ji,nlcj-3,jk,jn) ) * tmask(ji,nlcj-1,jk)
127                           ENDIF
128                        ENDIF
129                     END DO
130                  END DO
131               END DO
132            ENDIF
133            !
134            IF( ll_west ) THEN         !==  western side  ==!         
135               DO jn = 1, jptra
136                  tra(1,j1:j2,k1:k2,jn) = z1 * ptab(1,j1:j2,k1:k2,jn) + z2 * ptab(2,j1:j2,k1:k2,jn)
137                  DO jk = 1, jpkm1
138                     DO jj = jmin,jmax
139                        IF( umask(2,jj,jk) == 0._wp ) THEN
140                           tra(2,jj,jk,jn) = tra(1,jj,jk,jn) * tmask(2,jj,jk)
141                        ELSE
142                           tra(2,jj,jk,jn) = ( z4*tra(1,jj,jk,jn)+z3*tra(3,jj,jk,jn) ) * tmask(2,jj,jk)       
143                           IF( un(2,jj,jk) < 0._wp ) THEN
144                              tra(2,jj,jk,jn) = ( z6*tra(3,jj,jk,jn)+z5*tra(1,jj,jk,jn)+z7*tra(4,jj,jk,jn) ) * tmask(2,jj,jk)
145                           ENDIF
146                        ENDIF
147                     END DO
148                  END DO
149               END DO
150            ENDIF
151            !
152            IF( ll_south ) THEN        !==  southern side  ==!
153               DO jn = 1, jptra
154                  tra(i1:i2,1,k1:k2,jn) = z1 * ptab(i1:i2,1,k1:k2,jn) + z2 * ptab(i1:i2,2,k1:k2,jn)
155                  DO jk = 1, jpk     
156                     DO ji = imin, imax
157                        IF( vmask(ji,2,jk) == 0._wp ) THEN
158                           tra(ji,2,jk,jn) = tra(ji,1,jk,jn) * tmask(ji,2,jk)
159                        ELSE
160                           tra(ji,2,jk,jn) = ( z4*tra(ji,1,jk,jn)+z3*tra(ji,3,jk,jn) ) * tmask(ji,2,jk)
161                           IF( vn(ji,2,jk) < 0._wp ) THEN
162                              tra(ji,2,jk,jn) = ( z6*tra(ji,3,jk,jn)+z5*tra(ji,1,jk,jn)+z7*tra(ji,4,jk,jn) ) * tmask(ji,2,jk)
163                           ENDIF
164                        ENDIF
165                     END DO
166                  END DO
167               END DO
168            ENDIF
169            !
170            ! Treatment of corners
171            IF( ll_east .AND.((nbondj == -1).OR.(nbondj == 2)) )   tra(nlci-1,   2  ,:,:) = ptab(nlci-1,   2  ,:,:)   ! East south
172            IF( ll_east .AND.((nbondj ==  1).OR.(nbondj == 2)) )   tra(nlci-1,nlcj-1,:,:) = ptab(nlci-1,nlcj-1,:,:)   ! East north
173            IF( ll_west .AND.((nbondj == -1).OR.(nbondj == 2)) )   tra(   2  ,   2  ,:,:) = ptab(   2  ,   2  ,:,:)   ! West south
174            IF( ll_west .AND.((nbondj ==  1).OR.(nbondj == 2)) )   tra(   2  ,nlcj-1,:,:) = ptab(   2  ,nlcj-1,:,:)   ! West north
175            !
176         ENDIF
177      ENDIF
178      !
179   END SUBROUTINE interptrn
180
181#else
182   !!----------------------------------------------------------------------
183   !!   Empty module                                           no TOP AGRIF
184   !!----------------------------------------------------------------------
185CONTAINS
186   SUBROUTINE Agrif_TOP_Interp_empty
187      !!---------------------------------------------
188      !!   *** ROUTINE agrif_Top_Interp_empty ***
189      !!---------------------------------------------
190      WRITE(*,*)  'agrif_top_interp : You should not have seen this print! error?'
191   END SUBROUTINE Agrif_TOP_Interp_empty
192#endif
193
194   !!======================================================================
195END MODULE agrif_top_interp
Note: See TracBrowser for help on using the repository browser.