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_r7881_HPC09_ZDF/NEMOGCM/NEMO/NST_SRC – NEMO

source: branches/2017/dev_r7881_HPC09_ZDF/NEMOGCM/NEMO/NST_SRC/agrif_top_interp.F90 @ 7953

Last change on this file since 7953 was 7953, checked in by gm, 7 years ago

#1880 (HPC-09): add zdfphy (the ZDF manager) + remove all key_...

  • Property svn:keywords set to Id
File size: 8.6 KB
Line 
1MODULE agrif_top_interp
2   !!======================================================================
3   !!                   ***  MODULE  agrif_top_interp  ***
4   !! AGRIF: interpolation package
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
22   USE wrk_nemo 
23
24   IMPLICIT NONE
25   PRIVATE
26
27   PUBLIC Agrif_trc, interptrn
28
29  !!----------------------------------------------------------------------
30   !! NEMO/NST 4.0 , NEMO Consortium (2017)
31   !! $Id$
32   !! Software governed by the CeCILL licence (NEMOGCM/NEMO_CeCILL.txt)
33   !!----------------------------------------------------------------------
34CONTAINS
35
36   SUBROUTINE Agrif_trc
37      !!----------------------------------------------------------------------
38      !!                   ***  ROUTINE Agrif_trc  ***
39      !!----------------------------------------------------------------------
40      !
41      IF( Agrif_Root() )   RETURN
42      !
43      Agrif_SpecialValue    = 0._wp
44      Agrif_UseSpecialValue = .TRUE.
45      !
46      CALL Agrif_Bc_variable( trn_id, procname=interptrn )
47      Agrif_UseSpecialValue = .FALSE.
48      !
49   END SUBROUTINE Agrif_trc
50
51
52   SUBROUTINE interptrn( ptab, i1, i2, j1, j2, k1, k2, n1, n2, before, nb, ndir )
53      !!----------------------------------------------------------------------
54      !!                   *** ROUTINE interptrn ***
55      !!----------------------------------------------------------------------
56      REAL(wp), DIMENSION(i1:i2,j1:j2,k1:k2,n1:n2), INTENT(inout) ::   ptab
57      INTEGER                                     , INTENT(in   ) ::   i1, i2, j1, j2, k1, k2, n1, n2
58      LOGICAL                                     , INTENT(in   ) ::   before
59      INTEGER                                     , INTENT(in   ) ::   nb , ndir
60      !!
61      INTEGER ::   ji, jj, jk, jn   ! dummy loop indices
62      INTEGER ::   imin, imax, jmin, jmax
63      LOGICAL ::   western_side, eastern_side,northern_side,southern_side
64      REAL(wp)::   zrhox , zalpha1, zalpha2, zalpha3
65      REAL(wp)::   zalpha4, zalpha5, zalpha6, zalpha7
66      !!----------------------------------------------------------------------
67      !
68      IF( before ) THEN         
69         ptab(i1:i2,j1:j2,k1:k2,n1:n2) = trn(i1:i2,j1:j2,k1:k2,n1:n2)
70      ELSE
71         !
72         western_side  = (nb == 1).AND.(ndir == 1)
73         eastern_side  = (nb == 1).AND.(ndir == 2)
74         southern_side = (nb == 2).AND.(ndir == 1)
75         northern_side = (nb == 2).AND.(ndir == 2)
76         !
77         zrhox = Agrif_Rhox()
78         !
79         zalpha1 = ( zrhox - 1. ) * 0.5
80         zalpha2 = 1. - zalpha1
81         !
82         zalpha3 = ( zrhox - 1. ) / ( zrhox + 1. )
83         zalpha4 = 1. - zalpha3
84         !
85         zalpha6 = 2. * ( zrhox - 1. ) / ( zrhox + 1. )
86         zalpha7 =    - ( zrhox - 1. ) / ( zrhox + 3. )
87         zalpha5 = 1. - zalpha6 - zalpha7
88         !
89         imin = i1
90         imax = i2
91         jmin = j1
92         jmax = j2
93         !
94         ! Remove CORNERS
95         IF((nbondj == -1).OR.(nbondj == 2)) jmin = 3
96         IF((nbondj == +1).OR.(nbondj == 2)) jmax = nlcj-2
97         IF((nbondi == -1).OR.(nbondi == 2)) imin = 3
98         IF((nbondi == +1).OR.(nbondi == 2)) imax = nlci-2       
99         !
100         IF( eastern_side) THEN
101            DO jn = 1, jptra
102               tra(nlci,j1:j2,k1:k2,jn) = zalpha1 * ptab(nlci,j1:j2,k1:k2,jn) + zalpha2 * ptab(nlci-1,j1:j2,k1:k2,jn)
103               DO jk = 1, jpkm1
104                  DO jj = jmin,jmax
105                     IF( umask(nlci-2,jj,jk) == 0.e0 ) THEN
106                        tra(nlci-1,jj,jk,jn) = tra(nlci,jj,jk,jn) * tmask(nlci-1,jj,jk)
107                     ELSE
108                        tra(nlci-1,jj,jk,jn)=(zalpha4*tra(nlci,jj,jk,jn)+zalpha3*tra(nlci-2,jj,jk,jn))*tmask(nlci-1,jj,jk)
109                        IF( un(nlci-2,jj,jk) > 0.e0 ) THEN
110                           tra(nlci-1,jj,jk,jn)=( zalpha6*tra(nlci-2,jj,jk,jn)+zalpha5*tra(nlci,jj,jk,jn) & 
111                                 + zalpha7*tra(nlci-3,jj,jk,jn) ) * tmask(nlci-1,jj,jk)
112                        ENDIF
113                     ENDIF
114                  END DO
115               END DO
116            ENDDO
117         ENDIF
118         !
119         IF( northern_side ) THEN           
120            DO jn = 1, jptra
121               tra(i1:i2,nlcj,k1:k2,jn) = zalpha1 * ptab(i1:i2,nlcj,k1:k2,jn) + zalpha2 * ptab(i1:i2,nlcj-1,k1:k2,jn)
122               DO jk = 1, jpkm1
123                  DO ji = imin,imax
124                     IF( vmask(ji,nlcj-2,jk) == 0.e0 ) THEN
125                        tra(ji,nlcj-1,jk,jn) = tra(ji,nlcj,jk,jn) * tmask(ji,nlcj-1,jk)
126                     ELSE
127                        tra(ji,nlcj-1,jk,jn)=(zalpha4*tra(ji,nlcj,jk,jn)+zalpha3*tra(ji,nlcj-2,jk,jn))*tmask(ji,nlcj-1,jk)       
128                        IF (vn(ji,nlcj-2,jk) > 0.e0 ) THEN
129                           tra(ji,nlcj-1,jk,jn)=( zalpha6*tra(ji,nlcj-2,jk,jn)+zalpha5*tra(ji,nlcj,jk,jn)  &
130                                 + zalpha7*tra(ji,nlcj-3,jk,jn) ) * tmask(ji,nlcj-1,jk)
131                        ENDIF
132                     ENDIF
133                  END DO
134               END DO
135            ENDDO
136         ENDIF
137         !
138         IF( western_side) THEN           
139            DO jn = 1, jptra
140               tra(1,j1:j2,k1:k2,jn) = zalpha1 * ptab(1,j1:j2,k1:k2,jn) + zalpha2 * ptab(2,j1:j2,k1:k2,jn)
141               DO jk = 1, jpkm1
142                  DO jj = jmin,jmax
143                     IF( umask(2,jj,jk) == 0.e0 ) THEN
144                        tra(2,jj,jk,jn) = tra(1,jj,jk,jn) * tmask(2,jj,jk)
145                     ELSE
146                        tra(2,jj,jk,jn)=(zalpha4*tra(1,jj,jk,jn)+zalpha3*tra(3,jj,jk,jn))*tmask(2,jj,jk)       
147                        IF( un(2,jj,jk) < 0.e0 ) THEN
148                           tra(2,jj,jk,jn)=(zalpha6*tra(3,jj,jk,jn)+zalpha5*tra(1,jj,jk,jn)+zalpha7*tra(4,jj,jk,jn))*tmask(2,jj,jk)
149                        ENDIF
150                     ENDIF
151                  END DO
152               END DO
153            END DO
154         ENDIF
155         !
156         IF( southern_side ) THEN           
157            DO jn = 1, jptra
158               tra(i1:i2,1,k1:k2,jn) = zalpha1 * ptab(i1:i2,1,k1:k2,jn) + zalpha2 * ptab(i1:i2,2,k1:k2,jn)
159               DO jk=1,jpk     
160                  DO ji=imin,imax
161                     IF( vmask(ji,2,jk) == 0.e0 ) THEN
162                        tra(ji,2,jk,jn)=tra(ji,1,jk,jn) * tmask(ji,2,jk)
163                     ELSE
164                        tra(ji,2,jk,jn)=(zalpha4*tra(ji,1,jk,jn)+zalpha3*tra(ji,3,jk,jn))*tmask(ji,2,jk)
165                        IF( vn(ji,2,jk) < 0.e0 ) THEN
166                           tra(ji,2,jk,jn)=(zalpha6*tra(ji,3,jk,jn)+zalpha5*tra(ji,1,jk,jn)+zalpha7*tra(ji,4,jk,jn))*tmask(ji,2,jk)
167                        ENDIF
168                     ENDIF
169                  END DO
170               END DO
171            ENDDO
172         ENDIF
173         !
174         ! Treatment of corners
175         !
176         ! East south
177         IF ((eastern_side).AND.((nbondj == -1).OR.(nbondj == 2))) THEN
178            tra(nlci-1,2,:,:) = ptab(nlci-1,2,:,:)
179         ENDIF
180         ! East north
181         IF ((eastern_side).AND.((nbondj == 1).OR.(nbondj == 2))) THEN
182            tra(nlci-1,nlcj-1,:,:) = ptab(nlci-1,nlcj-1,:,:)
183         ENDIF
184         ! West south
185         IF ((western_side).AND.((nbondj == -1).OR.(nbondj == 2))) THEN
186            tra(2,2,:,:) = ptab(2,2,:,:)
187         ENDIF
188         ! West north
189         IF ((western_side).AND.((nbondj == 1).OR.(nbondj == 2))) THEN
190            tra(2,nlcj-1,:,:) = ptab(2,nlcj-1,:,:)
191         ENDIF
192         !
193      ENDIF
194      !
195   END SUBROUTINE interptrn
196
197#else
198   !!----------------------------------------------------------------------
199   !!   Empty module                                           no TOP AGRIF
200   !!----------------------------------------------------------------------
201CONTAINS
202   SUBROUTINE Agrif_TOP_Interp_empty
203      !!---------------------------------------------
204      !!   *** ROUTINE agrif_Top_Interp_empty ***
205      !!---------------------------------------------
206      WRITE(*,*)  'agrif_top_interp : You should not have seen this print! error?'
207   END SUBROUTINE Agrif_TOP_Interp_empty
208#endif
209
210   !!======================================================================
211END MODULE agrif_top_interp
Note: See TracBrowser for help on using the repository browser.