source: NEMO/branches/2019/dev_r10721_KERNEL-02_Storkey_Coward_IMMERSE_first_steps_rewrite_time_filterswap/src/NST/agrif_top_sponge.F90 @ 11463

Last change on this file since 11463 was 11463, checked in by acc, 14 months ago

Branch: dev_r10721_KERNEL-02_Storkey_Coward_IMMERSE_first_steps_rewrite_time_filterswap. Minor bugfix in step.F90 to enable AGRIF SETTE tests to run. Also merged prettification changes to NST routines from the dev_r10721_KERNEL-02_Storkey_Coward_IMMERSE_first_steps branch. Neither AGRIF_DEMO nor VORTEX restart perfectly (drifting after 8 and 121 timesteps, respectively).

  • Property svn:keywords set to Id
File size: 6.9 KB
Line 
1#define SPONGE_TOP
2
3MODULE agrif_top_sponge
4   !!======================================================================
5   !!                ***  MODULE agrif_top_sponge  ***
6   !! AGRIF :   sponge layer pakage for passive tracers (TOP)
7   !!======================================================================
8   !! History :  2.0  ! 2006-08  (R. Benshila, L. Debreu)  Original code
9   !!----------------------------------------------------------------------
10#if defined key_agrif && defined key_top
11   !!----------------------------------------------------------------------
12   !!   Agrif_Sponge_trc :
13   !!   interptrn_sponge : 
14   !!----------------------------------------------------------------------
15   USE par_oce
16   USE par_trc
17   USE oce
18   USE trc
19   USE dom_oce
20   USE agrif_oce
21   USE agrif_oce_sponge
22   !
23   USE in_out_manager
24   USE lib_mpp
25
26   IMPLICIT NONE
27   PRIVATE
28
29   PUBLIC Agrif_Sponge_trc, interptrn_sponge
30
31   !!----------------------------------------------------------------------
32   !! NEMO/NST 4.0 , NEMO Consortium (2018)
33   !! $Id$
34   !! Software governed by the CeCILL license (see ./LICENSE)
35   !!----------------------------------------------------------------------
36CONTAINS
37
38   SUBROUTINE Agrif_Sponge_trc
39      !!----------------------------------------------------------------------
40      !!                   *** ROUTINE Agrif_Sponge_Trc ***
41      !!----------------------------------------------------------------------
42      REAL(wp) ::   zcoef   ! local scalar
43      !!----------------------------------------------------------------------
44      !
45#if defined SPONGE_TOP
46!! Assume persistence
47      zcoef = REAL(Agrif_rhot()-1,wp)/REAL(Agrif_rhot())
48      CALL Agrif_sponge
49      Agrif_SpecialValue    = 0._wp
50      Agrif_UseSpecialValue = .TRUE.
51      tabspongedone_trn     = .FALSE.
52      CALL Agrif_Bc_Variable( trn_sponge_id, calledweight=zcoef, procname=interptrn_sponge )
53      Agrif_UseSpecialValue = .FALSE.
54#endif
55      !
56   END SUBROUTINE Agrif_Sponge_Trc
57
58
59   SUBROUTINE interptrn_sponge( tabres, i1, i2, j1, j2, k1, k2, n1, n2, before )
60      !!----------------------------------------------------------------------
61      !!                   *** ROUTINE interptrn_sponge ***
62      !!----------------------------------------------------------------------
63      INTEGER                                     , INTENT(in   ) ::   i1, i2, j1, j2, k1, k2, n1, n2
64      REAL(wp), DIMENSION(i1:i2,j1:j2,k1:k2,n1:n2), INTENT(inout) ::   tabres
65      LOGICAL                                     , INTENT(in   ) ::   before
66      !
67      INTEGER  ::   ji, jj, jk, jn   ! dummy loop indices
68      REAL(wp) ::   zabe1, zabe2
69      REAL(wp), DIMENSION(i1:i2,j1:j2)             ::   ztu, ztv
70      REAL(wp), DIMENSION(i1:i2,j1:j2,k1:k2,n1:n2) ::   trbdiff
71      ! vertical interpolation:
72      REAL(wp), DIMENSION(i1:i2,j1:j2,jpk,n1:n2) ::tabres_child
73      REAL(wp), DIMENSION(k1:k2,n1:n2-1) :: tabin
74      REAL(wp), DIMENSION(k1:k2) :: h_in
75      REAL(wp), DIMENSION(1:jpk) :: h_out
76      INTEGER :: N_in, N_out
77      REAL(wp) :: h_diff
78      !!----------------------------------------------------------------------
79      !
80      IF( before ) THEN
81         DO jn = 1, jptra
82            DO jk=k1,k2
83               DO jj=j1,j2
84                  DO ji=i1,i2
85                     tabres(ji,jj,jk,jn) = tr(ji,jj,jk,jn,Kbb)
86                  END DO
87               END DO
88            END DO
89         END DO
90
91# if defined key_vertical
92         DO jk=k1,k2
93            DO jj=j1,j2
94               DO ji=i1,i2
95                  tabres(ji,jj,jk,jpts+1) = tmask(ji,jj,jk) * e3t(ji,jj,jk,Kmm) 
96               END DO
97            END DO
98         END DO
99# endif
100      ELSE     
101# if defined key_vertical
102         tabres_child(:,:,:,:) = 0.
103         DO jj=j1,j2
104            DO ji=i1,i2
105               N_in = 0
106               DO jk=k1,k2 !k2 = jpk of parent grid
107                  IF (tabres(ji,jj,jk,n2) == 0) EXIT
108                  N_in = N_in + 1
109                  tabin(jk,:) = tabres(ji,jj,jk,n1:n2-1)
110                  h_in(N_in)  = tabres(ji,jj,jk,n2)
111               END DO
112               N_out = 0
113               DO jk=1,jpk ! jpk of child grid
114                  IF (tmask(ji,jj,jk) == 0) EXIT
115                  N_out     = N_out + 1
116                  h_out(jk) = e3t(ji,jj,jk,Kmm) !Child grid scale factors. Could multiply by e1e2t here instead of division above
117               ENDDO
118               IF (N_in > 0) THEN
119                  h_diff = SUM( h_out(1:N_out) ) - SUM( h_in(1:N_in) )
120                  tabres(ji,jj,k2,:) = tabres(ji,jj,k2-1,:) !what is this line for?????
121                  DO jn=1,jptra
122                     call reconstructandremap(tabin(1:N_in,jn),h_in,tabres_child(ji,jj,1:N_out,jn),h_out,N_in,N_out)
123                  ENDDO
124               ENDIF
125            ENDDO
126         ENDDO
127# endif
128
129         DO jj=j1,j2
130            DO ji=i1,i2
131               DO jk=1,jpkm1
132# if defined key_vertical
133                  trbdiff(ji,jj,jk,1:jptra) = tr(ji,jj,jk,1:jptra,Kbb) - tabres_child(ji,jj,jk,1:jptra)
134# else
135                  trbdiff(ji,jj,jk,1:jptra) = tr(ji,jj,jk,1:jptra,Kbb) -       tabres(ji,jj,jk,1:jptra)
136# endif
137               ENDDO
138            ENDDO
139         ENDDO
140
141         DO jn = 1, jptra
142            DO jk = 1, jpkm1
143               DO jj = j1,j2-1
144                  DO ji = i1,i2-1
145                     zabe1 = fsaht_spu(ji,jj) * e2_e1u(ji,jj) * e3u(ji,jj,jk,Kmm) * umask(ji,jj,jk)
146                     zabe2 = fsaht_spv(ji,jj) * e1_e2v(ji,jj) * e3v(ji,jj,jk,Kmm) * vmask(ji,jj,jk)
147                     ztu(ji,jj) = zabe1 * ( trbdiff(ji+1,jj  ,jk,jn) - trbdiff(ji,jj,jk,jn) )
148                     ztv(ji,jj) = zabe2 * ( trbdiff(ji  ,jj+1,jk,jn) - trbdiff(ji,jj,jk,jn) )
149                  END DO
150               END DO
151               !
152               DO jj = j1+1,j2-1
153                  DO ji = i1+1,i2-1
154                     IF( .NOT. tabspongedone_trn(ji,jj) ) THEN
155                        tr(ji,jj,jk,jn,Krhs) = tr(ji,jj,jk,jn,Krhs) + (  ztu(ji,jj) - ztu(ji-1,jj  )       &
156                           &                                           + ztv(ji,jj) - ztv(ji  ,jj-1)  )    &
157                           &                                          * r1_e1e2t(ji,jj) / e3t(ji,jj,jk,Kmm)
158                     ENDIF
159                  END DO
160               END DO
161            END DO
162            !
163         END DO
164         !
165         tabspongedone_trn(i1+1:i2-1,j1+1:j2-1) = .TRUE.
166      ENDIF
167      !                 
168   END SUBROUTINE interptrn_sponge
169
170#else
171   !!----------------------------------------------------------------------
172   !!   Empty module                                           no TOP AGRIF
173   !!----------------------------------------------------------------------
174CONTAINS
175   SUBROUTINE agrif_top_sponge_empty
176      WRITE(*,*)  'agrif_top_sponge : You should not have seen this print! error?'
177   END SUBROUTINE agrif_top_sponge_empty
178#endif
179
180   !!======================================================================
181END MODULE agrif_top_sponge
Note: See TracBrowser for help on using the repository browser.