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

source: branches/UKMO/r8395_cpl_tauwav/NEMOGCM/NEMO/NST_SRC/agrif_top_interp.F90 @ 12286

Last change on this file since 12286 was 12286, checked in by jcastill, 4 years ago

Remove svn keywords

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