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_sponge.F90 in NEMO/branches/2019/dev_r10721_KERNEL-02_Storkey_Coward_IMMERSE_first_steps_rewrite_time_filterswap/src/NST – NEMO

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

Last change on this file since 11021 was 10989, checked in by acc, 5 years ago

2019/dev_r10721_KERNEL-02_Storkey_Coward_IMMERSE_first_steps : Convert NST routines in preparation for getting AGRIF back up and running. AGRIF conv stage now works but requires some renaming of recently changes DIU modules (included in this commit). AGRIF compile and link stage not yet working (agrif routines need to be passed the time-level indices) but non-AGRIF SETTE tests are all OK

  • Property svn:keywords set to Id
File size: 6.8 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.