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

source: branches/UKMO/r5518_INGV1_WAVE-coupling/NEMOGCM/NEMO/NST_SRC/agrif_top_interp.F90 @ 7152

Last change on this file since 7152 was 7152, checked in by jcastill, 7 years ago

Initial implementation of wave coupling branch - INGV wave branch + UKMO wave coupling branch

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