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 NEMO/branches/2020/dev_r13312_AGRIF-03-04_jchanut_vinterp_tstep/src/NST – NEMO

source: NEMO/branches/2020/dev_r13312_AGRIF-03-04_jchanut_vinterp_tstep/src/NST/agrif_top_interp.F90 @ 13337

Last change on this file since 13337 was 13337, checked in by jchanut, 4 years ago

#2222, start suppressing key_vertical (add ln_vremap namelist flag)
  • Property svn:keywords set to Id
File size: 7.0 KB
Line 
1MODULE agrif_top_interp
2   !!======================================================================
3   !!                   ***  MODULE  agrif_top_interp  ***
4   !! AGRIF: interpolation package for TOP
5   !!======================================================================
6   !! History :  2.0  !  ???
7   !!----------------------------------------------------------------------
8#if defined key_agrif && defined key_top
9   !!----------------------------------------------------------------------
10   !!   'key_agrif'                                              AGRIF zoom
11   !!   'key_top'                                           on-line tracers
12   !!----------------------------------------------------------------------
13   USE par_oce
14   USE oce
15   USE dom_oce     
16   USE agrif_oce
17   USE agrif_top_sponge
18   USE par_trc
19   USE trc
20   USE vremap
21   !
22   USE lib_mpp     ! MPP library
23
24   IMPLICIT NONE
25   PRIVATE
26
27   PUBLIC Agrif_trc, interptrn
28
29  !!----------------------------------------------------------------------
30   !! NEMO/NST 4.0 , NEMO Consortium (2018)
31   !! $Id$
32   !! Software governed by the CeCILL license (see ./LICENSE)
33   !!----------------------------------------------------------------------
34CONTAINS
35
36   SUBROUTINE Agrif_trc
37      !!----------------------------------------------------------------------
38      !!                   ***  ROUTINE Agrif_trc  ***
39      !!----------------------------------------------------------------------
40      !
41      IF( Agrif_Root() )   RETURN
42      !
43      Agrif_SpecialValue    = 0._wp
44      Agrif_UseSpecialValue = .TRUE.
45      l_vremap = ln_vremap
46      !
47      CALL Agrif_Bc_variable( trn_id, procname=interptrn )
48      Agrif_UseSpecialValue = .FALSE.
49      l_vremap = .FALSE.
50      !
51   END SUBROUTINE Agrif_trc
52
53   SUBROUTINE interptrn( ptab, i1, i2, j1, j2, k1, k2, n1, n2, before )
54      !!----------------------------------------------------------------------
55      !!                  *** ROUTINE interptrn ***
56      !!----------------------------------------------------------------------
57      REAL(wp), DIMENSION(i1:i2,j1:j2,k1:k2,n1:n2), INTENT(inout) ::   ptab
58      INTEGER                                     , INTENT(in   ) ::   i1, i2, j1, j2, k1, k2, n1, n2
59      LOGICAL                                     , INTENT(in   ) ::   before
60      !
61      INTEGER  ::   ji, jj, jk, jn  ! dummy loop indices
62      INTEGER  ::   N_in, N_out
63      INTEGER  :: item
64      ! vertical interpolation:
65      REAL(wp) :: zhtot
66      REAL(wp), DIMENSION(k1:k2,1:jptra) :: tabin
67      REAL(wp), DIMENSION(k1:k2) :: h_in, z_in
68      REAL(wp), DIMENSION(1:jpk) :: h_out, z_out
69      !!----------------------------------------------------------------------
70
71      IF( before ) THEN
72
73         item = Kmm_a
74         IF( l_ini_child )   Kmm_a = Kbb_a 
75
76         DO jn = 1,jptra
77            DO jk=k1,k2
78               DO jj=j1,j2
79                 DO ji=i1,i2
80                       ptab(ji,jj,jk,jn) = tr(ji,jj,jk,jn,Kmm_a)
81                 END DO
82              END DO
83           END DO
84         END DO
85
86         IF( l_vremap .OR. l_ini_child) THEN
87            ! Interpolate thicknesses
88            ! Warning: these are masked, hence extrapolated prior interpolation.
89            DO jk=k1,k2
90               DO jj=j1,j2
91                  DO ji=i1,i2
92                      ptab(ji,jj,jk,jptra+1) = tmask(ji,jj,jk) * e3t(ji,jj,jk,Kmm_a)
93
94                  END DO
95               END DO
96            END DO
97
98            ! Extrapolate thicknesses in partial bottom cells:
99            ! Set them to Agrif_SpecialValue (0.). Correct bottom thicknesses are retrieved later on
100            IF (ln_zps) THEN
101               DO jj=j1,j2
102                  DO ji=i1,i2
103                      jk = mbkt(ji,jj)
104                      ptab(ji,jj,jk,jptra+1) = 0._wp
105                  END DO
106               END DO           
107            END IF
108       
109            ! Save ssh at last level:
110            IF (.NOT.ln_linssh) THEN
111               ptab(i1:i2,j1:j2,k2,jptra+1) = ssh(i1:i2,j1:j2,Kmm_a)*tmask(i1:i2,j1:j2,1) 
112            ELSE
113               ptab(i1:i2,j1:j2,k2,jptra+1) = 0._wp
114            END IF     
115         ENDIF
116         Kmm_a = item
117
118      ELSE
119         item = Krhs_a
120         IF( l_ini_child )   Krhs_a = Kbb_a 
121
122         IF( l_vremap .OR. l_ini_child ) THEN
123            IF (ln_linssh) ptab(i1:i2,j1:j2,k2,n2) = 0._wp 
124               
125            DO jj=j1,j2
126               DO ji=i1,i2
127                  tr(ji,jj,:,:,Krhs_a) = 0.                 
128                  N_in = mbkt_parent(ji,jj)
129                  zhtot = 0._wp
130                  DO jk=1,N_in !k2 = jpk of parent grid
131                     IF (jk==N_in) THEN
132                        h_in(jk) = ht0_parent(ji,jj) + ptab(ji,jj,k2,n2) - zhtot
133                     ELSE
134                        h_in(jk) = ptab(ji,jj,jk,n2)
135                     ENDIF
136                     zhtot = zhtot + h_in(jk)
137                     tabin(jk,:) = ptab(ji,jj,jk,n1:n2-1)
138                  END DO
139                  z_in(1) = 0.5_wp * h_in(1) - zhtot + ht0_parent(ji,jj)
140                  DO jk=2,N_in
141                     z_in(jk) = z_in(jk-1) + 0.5_wp * h_in(jk)
142                  END DO
143
144                  N_out = 0
145                  DO jk=1,jpk ! jpk of child grid
146                     IF (tmask(ji,jj,jk) == 0._wp) EXIT
147                     N_out = N_out + 1
148                     h_out(jk) = e3t(ji,jj,jk,Krhs_a)
149                  END DO
150
151                  z_out(1) = 0.5_wp * h_out(1) - SUM(h_out(1:N_out)) + ht_0(ji,jj)
152                  DO jk=2,N_out
153                     z_out(jk) = z_out(jk-1) + 0.5_wp * h_out(jk)
154                  END DO
155
156                  IF (N_in*N_out > 0) THEN
157                     IF( l_ini_child ) THEN
158                        CALL remap_linear(tabin(1:N_in,1:jptra),z_in(1:N_in),tr(ji,jj,1:N_out,1:jptra,Krhs_a),          &
159                                      &   z_out(1:N_out),N_in,N_out,jptra) 
160                     ELSE
161                        CALL reconstructandremap(tabin(1:N_in,1:jptra),h_in(1:N_in),tr(ji,jj,1:N_out,1:jptra,Krhs_a),   &
162                                      &   h_out(1:N_out),N_in,N_out,jptra) 
163                     ENDIF
164                  ENDIF
165               END DO
166            END DO
167            Krhs_a = item
168 
169         ELSE
170         
171            DO jn=1, jptra
172                tr(i1:i2,j1:j2,1:jpk,jn,Krhs_a)=ptab(i1:i2,j1:j2,1:jpk,jn)*tmask(i1:i2,j1:j2,1:jpk) 
173            END DO
174         ENDIF
175
176      ENDIF
177      !
178   END SUBROUTINE interptrn
179
180#else
181   !!----------------------------------------------------------------------
182   !!   Empty module                                           no TOP AGRIF
183   !!----------------------------------------------------------------------
184CONTAINS
185   SUBROUTINE Agrif_TOP_Interp_empty
186      !!---------------------------------------------
187      !!   *** ROUTINE agrif_Top_Interp_empty ***
188      !!---------------------------------------------
189      WRITE(*,*)  'agrif_top_interp : You should not have seen this print! error?'
190   END SUBROUTINE Agrif_TOP_Interp_empty
191#endif
192
193   !!======================================================================
194END MODULE agrif_top_interp
Note: See TracBrowser for help on using the repository browser.