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

source: branches/2017/dev_r7881_no_wrk_alloc/NEMOGCM/NEMO/NST_SRC/agrif_top_interp.F90 @ 8016

Last change on this file since 8016 was 8016, checked in by timgraham, 7 years ago

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