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

source: branches/2017/dev_r8624_AGRIF3_VVL/NEMOGCM/NEMO/NST_SRC/agrif_top_update.F90 @ 8741

Last change on this file since 8741 was 8741, checked in by jchanut, 6 years ago

AGRIF + vvl Main changes - #1965
  • Property svn:keywords set to Id
File size: 9.5 KB
Line 
1#define TWO_WAY
2#undef DECAL_FEEDBACK
3
4MODULE agrif_top_update
5   !!======================================================================
6   !!                ***  MODULE agrif_top_update  ***
7   !! AGRIF :   
8   !!----------------------------------------------------------------------
9   !! History : 
10   !!----------------------------------------------------------------------
11
12#if defined key_agrif && defined key_top
13   USE par_oce
14   USE oce
15   USE par_trc
16   USE trc
17   USE dom_oce
18   USE agrif_oce
19   USE wrk_nemo 
20
21   IMPLICIT NONE
22   PRIVATE
23
24   PUBLIC Agrif_Update_Trc
25
26   INTEGER, PUBLIC ::   nbcline_trc = 0   !: ???
27
28   !!----------------------------------------------------------------------
29   !! NEMO/NST 3.7 , NEMO Consortium (2015)
30   !! $Id$
31   !! Software governed by the CeCILL licence (NEMOGCM/NEMO_CeCILL.txt)
32   !!----------------------------------------------------------------------
33CONTAINS
34
35   SUBROUTINE Agrif_Update_Trc( )
36      !!----------------------------------------------------------------------
37      !!                   *** ROUTINE Agrif_Update_Trc ***
38      !!----------------------------------------------------------------------
39      !
40      IF (Agrif_Root()) RETURN 
41      !
42#if defined TWO_WAY   
43      Agrif_UseSpecialValueInUpdate = .TRUE.
44      Agrif_SpecialValueFineGrid    = 0._wp
45      !
46      IF( MOD(nbcline_trc,nbclineupdate) == 0 ) THEN
47# if ! defined DECAL_FEEDBACK
48         CALL Agrif_Update_Variable(trn_id, procname=updateTRC )
49# else
50         CALL Agrif_Update_Variable(trn_id, locupdate=(/1,0/),procname=updateTRC )
51# endif
52      ELSE
53# if ! defined DECAL_FEEDBACK
54         CALL Agrif_Update_Variable( trn_id, locupdate=(/0,2/), procname=updateTRC )
55# else
56         CALL Agrif_Update_Variable( trn_id, locupdate=(/1,2/), procname=updateTRC )
57# endif
58      ENDIF
59      !
60      Agrif_UseSpecialValueInUpdate = .FALSE.
61      nbcline_trc = nbcline_trc + 1
62#endif
63      !
64   END SUBROUTINE Agrif_Update_Trc
65
66
67   SUBROUTINE updateTRC( ptab, i1, i2, j1, j2, k1, k2, n1, n2, before, nb, ndir )
68      !!----------------------------------------------------------------------
69      !!                      *** ROUTINE updateT ***
70      !!----------------------------------------------------------------------
71      INTEGER                                    , INTENT(in   ) ::   i1, i2, j1, j2, k1, k2, n1, n2
72      REAL(wp),DIMENSION(i1:i2,j1:j2,k1:k2,n1:n2), INTENT(inout) ::   ptab
73      LOGICAL                                    , INTENT(in   ) ::   before
74      INTEGER, INTENT(in) :: nb, ndir
75      !!
76      LOGICAL :: western_side, eastern_side, southern_side, northern_side 
77      INTEGER :: ji,jj,jk,jn
78      REAL(wp) :: ztb, ztnu, ztno
79      !!----------------------------------------------------------------------
80      !
81      !
82      IF (before) THEN
83         DO jn = n1,n2
84            DO jk=k1,k2
85               DO jj=j1,j2
86                  DO ji=i1,i2
87!> jc tmp
88                     tabres(ji,jj,jk,jn) = trn(ji,jj,jk,jn)  * e3t_n(ji,jj,jk) / e3t_0(ji,jj,jk)
89!                     tabres(ji,jj,jk,jn) = trn(ji,jj,jk,jn)  * e3t_n(ji,jj,jk)
90!< jc tmp
91                  END DO
92               END DO
93            END DO
94         END DO
95      ELSE
96!> jc tmp
97         DO jn = n1,n2
98            tabres(i1:i2,j1:j2,k1:k2,jn) =  tabres(i1:i2,j1:j2,k1:k2,jn) * e3t_0(i1:i2,j1:j2,k1:k2) &
99                                         & * tmask(i1:i2,j1:j2,k1:k2)
100         ENDDO
101!< jc tmp
102         IF (.NOT.(lk_agrif_fstep.AND.(neuler==0))) THEN
103            ! Add asselin part
104            DO jn = n1,n2
105               DO jk=k1,k2
106                  DO jj=j1,j2
107                     DO ji=i1,i2
108                        IF( tabres(ji,jj,jk,jn) .NE. 0. ) THEN
109                           ztb  = trb(ji,jj,jk,jn) * e3t_b(ji,jj,jk) ! fse3t_b prior update should be used
110                           ztnu = tabres(ji,jj,jk,jn)
111                           ztno = trn(ji,jj,jk,jn) * e3t_a(ji,jj,jk)
112                           trb(ji,jj,jk,jn) = ( ztb + atfp * ( ztnu - ztno) )  & 
113                                     &        * tmask(ji,jj,jk) / e3t_b(ji,jj,jk)
114                        ENDIF
115                     ENDDO
116                  ENDDO
117               ENDDO
118            ENDDO
119         ENDIF
120         DO jn = n1,n2
121            DO jk=k1,k2
122               DO jj=j1,j2
123                  DO ji=i1,i2
124                     IF( tabres(ji,jj,jk,jn) .NE. 0. ) THEN
125                        trn(ji,jj,jk,jn) = tabres(ji,jj,jk,jn) / e3t_n(ji,jj,jk)
126                     END IF
127                  END DO
128               END DO
129            END DO
130         END DO
131         !
132         IF  ((neuler==0).AND.(Agrif_Nb_Step()==0) ) THEN
133            trb(i1:i2,j1:j2,k1:k2,n1:n2)  = trn(i1:i2,j1:j2,k1:k2,n1:n2)
134         ENDIF
135         !
136         !
137# if defined DECAL_FEEDBACK
138         IF (.NOT.ln_linssh) THEN
139            western_side  = (nb == 1).AND.(ndir == 1)
140            eastern_side  = (nb == 1).AND.(ndir == 2)
141            southern_side = (nb == 2).AND.(ndir == 1)
142            northern_side = (nb == 2).AND.(ndir == 2)
143            !
144            ! Asselin correction
145            IF (.NOT.(lk_agrif_fstep.AND.(neuler==0))) THEN
146               IF (southern_side) THEN
147                  DO jn = n1,n2
148                     DO jk=k1,k2
149                        DO ji=i1,i2
150                           ztb  = trb(ji,j1-1,jk,jn) * e3t_b(ji,j1-1,jk) ! fse3t_b prior update should be used
151                           ztnu = trn(ji,j1-1,jk,jn) * e3t_n(ji,j1-1,jk)
152                           ztno = trn(ji,j1-1,jk,jn) * e3t_a(ji,j1-1,jk)
153                           trb(ji,j1-1,jk,jn) = ( ztb + atfp * ( ztnu - ztno) )  & 
154                                     &        * tmask(ji,j1-1,jk) / e3t_b(ji,j1-1,jk)
155                        END DO
156                     ENDDO
157                  ENDDO
158               ENDIF
159               IF (northern_side) THEN
160                  DO jn = n1,n2
161                     DO jk=k1,k2
162                        DO ji=i1,i2
163                           ztb  = trb(ji,j2+1,jk,jn) * e3t_b(ji,j2+1,jk) ! fse3t_b prior update should be used
164                           ztnu = trn(ji,j2+1,jk,jn) * e3t_n(ji,j2+1,jk)
165                           ztno = trn(ji,j2+1,jk,jn) * e3t_a(ji,j2+1,jk)
166                           trb(ji,j2+1,jk,jn) = ( ztb + atfp * ( ztnu - ztno) )  & 
167                                     &        * tmask(ji,j2+1,jk) / e3t_b(ji,j2+1,jk)
168                        END DO
169                     ENDDO
170                  ENDDO
171               ENDIF
172               IF (western_side) THEN
173                  DO jn = n1,n2
174                     DO jk=k1,k2
175                        DO jj=j1,j2
176                           ztb  = trb(i1-1,jj,jk,jn) * e3t_b(i1-1,jj,jk) ! fse3t_b prior update should be used
177                           ztnu = trn(i1-1,jj,jk,jn) * e3t_n(i1-1,jj,jk)
178                           ztno = trn(i1-1,jj,jk,jn) * e3t_a(i1-1,jj,jk)
179                           trb(i1-1,jj,jk,jn) = ( ztb + atfp * ( ztnu - ztno) )  & 
180                                     &        * tmask(i1-1,jj,jk) / e3t_b(i1-1,jj,jk)
181                        END DO
182                     ENDDO
183                  ENDDO
184               ENDIF
185               IF (eastern_side) THEN
186                  DO jn = n1,n2
187                     DO jk=k1,k2
188                        DO jj=j1,j2
189                           ztb  = trb(i2+1,jj,jk,jn) * e3t_b(i2+1,jj,jk) ! fse3t_b prior update should be used
190                           ztnu = trn(i2+1,jj,jk,jn) * e3t_n(i2+1,jj,jk)
191                           ztno = trn(i2+1,jj,jk,jn) * e3t_a(i2+1,jj,jk)
192                           trb(i2+1,jj,jk,jn) = ( ztb + atfp * ( ztnu - ztno) )  & 
193                                     &        * tmask(i2+1,jj,jk) / e3t_b(i2+1,jj,jk)
194                        END DO
195                     ENDDO
196                  ENDDO
197               ENDIF
198            ENDIF ! Asselin correction
199
200            IF (southern_side) THEN
201               DO jn = n1,n2
202                  DO jk=k1,k2
203                     DO ji=i1,i2
204                        trn(ji,j1-1,jk,jn) = trn(ji,j1-1,jk,jn) * e3t_a(ji,j1-1,jk) / e3t_n(ji,j1-1,jk)
205                     END DO
206                  ENDDO
207               ENDDO
208            ENDIF
209            IF (northern_side) THEN
210               DO jn = n1,n2
211                  DO jk=k1,k2
212                     DO ji=i1,i2
213                        trn(ji,j2+1,jk,jn) = trn(ji,j2+1,jk,jn) * e3t_a(ji,j2+1,jk) / e3t_n(ji,j2+1,jk)
214                     END DO
215                  ENDDO
216               ENDDO
217            ENDIF
218            IF (western_side) THEN
219               DO jn = n1,n2
220                  DO jk=k1,k2
221                     DO jj=j1,j2
222                        trn(i1-1,jj,jk,jn) = trn(i1-1,jj,jk,jn) * e3t_a(i1-1,jj,jk) / e3t_n(i1-1,jj,jk)
223                     END DO
224                  ENDDO
225               ENDDO
226            ENDIF
227            IF (eastern_side) THEN
228               DO jn = n1,n2
229                  DO jk=k1,k2
230                     DO jj=j1,j2
231                        trn(i2+1,jj,jk,jn) = trn(i2+1,jj,jk,jn) * e3t_a(i2+1,jj,jk) / e3t_n(i2+1,jj,jk)
232                     END DO
233                  ENDDO
234               ENDDO
235            ENDIF
236         ENDIF
237#endif
238      ENDIF
239      !
240   END SUBROUTINE updateTRC
241
242#else
243CONTAINS
244   SUBROUTINE agrif_top_update_empty
245      !!---------------------------------------------
246      !!   *** ROUTINE agrif_Top_update_empty ***
247      !!---------------------------------------------
248      WRITE(*,*)  'agrif_top_update : You should not have seen this print! error?'
249   END SUBROUTINE agrif_top_update_empty
250#endif
251
252   !!======================================================================
253END MODULE agrif_top_update
Note: See TracBrowser for help on using the repository browser.