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 @ 14013

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

Manually merge with Christian's branch agrif top sponge/interp #2129

  • Property svn:keywords set to Id
File size: 8.5 KB
RevLine 
[636]1MODULE agrif_top_interp
[9019]2   !!======================================================================
3   !!                   ***  MODULE  agrif_top_interp  ***
4   !! AGRIF: interpolation package for TOP
5   !!======================================================================
6   !! History :  2.0  !  ???
7   !!----------------------------------------------------------------------
[1206]8#if defined key_agrif && defined key_top
[9019]9   !!----------------------------------------------------------------------
10   !!   'key_agrif'                                              AGRIF zoom
11   !!   'key_top'                                           on-line tracers
12   !!----------------------------------------------------------------------
[636]13   USE par_oce
14   USE oce
15   USE dom_oce     
[782]16   USE agrif_oce
[2715]17   USE agrif_top_sponge
[5656]18   USE par_trc
[1271]19   USE trc
[12377]20   USE vremap
[9019]21   !
22   USE lib_mpp     ! MPP library
[628]23
[636]24   IMPLICIT NONE
25   PRIVATE
[628]26
[5656]27   PUBLIC Agrif_trc, interptrn
[636]28
[2715]29  !!----------------------------------------------------------------------
[9598]30   !! NEMO/NST 4.0 , NEMO Consortium (2018)
[1156]31   !! $Id$
[10068]32   !! Software governed by the CeCILL license (see ./LICENSE)
[1156]33   !!----------------------------------------------------------------------
[6140]34CONTAINS
[1156]35
[1271]36   SUBROUTINE Agrif_trc
[3680]37      !!----------------------------------------------------------------------
[9019]38      !!                   ***  ROUTINE Agrif_trc  ***
[3680]39      !!----------------------------------------------------------------------
40      !
41      IF( Agrif_Root() )   RETURN
[9019]42      !
43      Agrif_SpecialValue    = 0._wp
[636]44      Agrif_UseSpecialValue = .TRUE.
[14013]45      l_vremap              = ln_vert_remap
[9019]46      !
[5656]47      CALL Agrif_Bc_variable( trn_id, procname=interptrn )
[13351]48      !
[636]49      Agrif_UseSpecialValue = .FALSE.
[13351]50      l_vremap              = .FALSE.
[5656]51      !
52   END SUBROUTINE Agrif_trc
[636]53
[12377]54   SUBROUTINE interptrn( ptab, i1, i2, j1, j2, k1, k2, n1, n2, before )
[9019]55      !!----------------------------------------------------------------------
[9788]56      !!                  *** ROUTINE interptrn ***
[9019]57      !!----------------------------------------------------------------------
58      REAL(wp), DIMENSION(i1:i2,j1:j2,k1:k2,n1:n2), INTENT(inout) ::   ptab
59      INTEGER                                     , INTENT(in   ) ::   i1, i2, j1, j2, k1, k2, n1, n2
60      LOGICAL                                     , INTENT(in   ) ::   before
[5656]61      !
[13337]62      INTEGER  ::   ji, jj, jk, jn  ! dummy loop indices
63      INTEGER  ::   N_in, N_out
64      INTEGER  :: item
[9031]65      ! vertical interpolation:
[14013]66      REAL(wp) :: zhtot, zwgt
67      REAL(wp), DIMENSION(k1:k2,1:jptra) :: tabin, tabin_i
68      REAL(wp), DIMENSION(k1:k2) :: z_in, h_in_i, z_in_i
[13337]69      REAL(wp), DIMENSION(1:jpk) :: h_out, z_out
[12377]70      !!----------------------------------------------------------------------
[9031]71
[13337]72      IF( before ) THEN
73
74         item = Kmm_a
75         IF( l_ini_child )   Kmm_a = Kbb_a 
76
[9788]77         DO jn = 1,jptra
[9031]78            DO jk=k1,k2
79               DO jj=j1,j2
80                 DO ji=i1,i2
[12377]81                       ptab(ji,jj,jk,jn) = tr(ji,jj,jk,jn,Kmm_a)
[9031]82                 END DO
[9788]83              END DO
84           END DO
[13337]85         END DO
[9788]86
[14013]87         IF( l_vremap .OR. l_ini_child .OR. ln_zps ) THEN
88            ! Fill cell depths (i.e. gdept) to be interpolated
[13337]89            ! Warning: these are masked, hence extrapolated prior interpolation.
[14013]90            DO jj=j1,j2
91               DO ji=i1,i2
92                  ptab(ji,jj,k1,jptra+1) = 0.5_wp * tmask(ji,jj,k1) * e3t(ji,jj,k1,Kmm_a)
93                  DO jk=k1+1,k2
94                     ptab(ji,jj,jk,jptra+1) = tmask(ji,jj,jk) * &
95                        & ( ptab(ji,jj,jk-1,jptra+1) + 0.5_wp * (e3t(ji,jj,jk-1,Kmm_a)+e3t(ji,jj,jk,Kmm_a)) )
[13337]96                  END DO
97               END DO
98            END DO
99
100            ! Save ssh at last level:
101            IF (.NOT.ln_linssh) THEN
102               ptab(i1:i2,j1:j2,k2,jptra+1) = ssh(i1:i2,j1:j2,Kmm_a)*tmask(i1:i2,j1:j2,1) 
103            END IF     
104         ENDIF
105         Kmm_a = item
106
[9788]107      ELSE
[13337]108         item = Krhs_a
109         IF( l_ini_child )   Krhs_a = Kbb_a 
[9031]110
[13337]111         IF( l_vremap .OR. l_ini_child ) THEN
112            IF (ln_linssh) ptab(i1:i2,j1:j2,k2,n2) = 0._wp 
113               
114            DO jj=j1,j2
115               DO ji=i1,i2
[14013]116                  tr(ji,jj,:,:,Krhs_a) = 0. 
117                  !
118                  ! Build vertical grids:
[13337]119                  N_in = mbkt_parent(ji,jj)
[14013]120                  ! Input grid (account for partial cells if any):
121                  DO jk=1,N_in
122                     z_in(jk) = ptab(ji,jj,jk,n2) - ptab(ji,jj,k2,n2)
123                     tabin(jk,1:jptra) = ptab(ji,jj,jk,1:jptra)
[13337]124                  END DO
[14013]125                 
126                  ! Intermediate grid:
127                  DO jk = 1, N_in
128                     h_in_i(jk) = e3t0_parent(ji,jj,jk) * & 
129                       &       (1._wp + ptab(ji,jj,k2,n2)/(ht0_parent(ji,jj)*ssmask(ji,jj) + 1._wp - ssmask(ji,jj)))
130                  END DO
131                  z_in_i(1) = 0.5_wp * h_in_i(1)
[13337]132                  DO jk=2,N_in
[14013]133                     z_in_i(jk) = z_in_i(jk-1) + 0.5_wp * ( h_in_i(jk) + h_in_i(jk-1) )
[13337]134                  END DO
[14013]135                  z_in_i(1:N_in) = z_in_i(1:N_in)  - ptab(ji,jj,k2,n2)
[13337]136
[14013]137                  ! Output (Child) grid:
138                  N_out = mbkt(ji,jj)
139                  DO jk=1,N_out
[13337]140                     h_out(jk) = e3t(ji,jj,jk,Krhs_a)
141                  END DO
[14013]142                  z_out(1) = 0.5_wp * h_out(1)
[13337]143                  DO jk=2,N_out
[14013]144                     z_out(jk) = z_out(jk-1) + 0.5_wp * ( h_out(jk)+h_out(jk-1) )
[13337]145                  END DO
[14013]146                  IF (.NOT.ln_linssh) z_out(1:N_out) = z_out(1:N_out)  - ssh(ji,jj,Krhs_a)               
[13337]147
148                  IF (N_in*N_out > 0) THEN
149                     IF( l_ini_child ) THEN
150                        CALL remap_linear(tabin(1:N_in,1:jptra),z_in(1:N_in),tr(ji,jj,1:N_out,1:jptra,Krhs_a),          &
151                                      &   z_out(1:N_out),N_in,N_out,jptra) 
[14013]152                     ELSE 
153                        CALL remap_linear(tabin(1:N_in,1:jptra),z_in(1:N_in),tabin_i(1:N_in,1:jptra),                     &
154                                     &   z_in_i(1:N_in),N_in,N_in,jptra)
155                        CALL reconstructandremap(tabin_i(1:N_in,1:jptra),h_in_i(1:N_in),tr(ji,jj,1:N_out,1:jptra,Krhs_a), &
156                                      &   h_out(1:N_out),N_in,N_out,jptra)   
[13337]157                     ENDIF
158                  ENDIF
[9031]159               END DO
[13337]160            END DO
161            Krhs_a = item
162 
163         ELSE
[14013]164
165            IF ( Agrif_Parent(ln_zps) ) THEN ! Account for partial cells
166                                             ! linear vertical interpolation
167               DO jj=j1,j2
168                  DO ji=i1,i2
169                     !
170                     N_in  = mbkt(ji,jj)
171                     N_out = mbkt(ji,jj)
172                     z_in(1) = ptab(ji,jj,1,n2)
173                     tabin(1,1:jptra) = ptab(ji,jj,1,1:jptra)
174                     DO jk=2, N_in
175                        z_in(jk) = ptab(ji,jj,jk,n2)
176                        tabin(jk,1:jptra) = ptab(ji,jj,jk,1:jptra)
177                     END DO
178                     IF (.NOT.ln_linssh) z_in(1:N_in) = z_in(1:N_in) - ptab(ji,jj,k2,n2)
179                     z_out(1) = 0.5_wp * e3t(ji,jj,1,Krhs_a)
180                     DO jk=2, N_out
181                        z_out(jk) = z_out(jk-1) + 0.5_wp * (e3t(ji,jj,jk-1,Krhs_a) + e3t(ji,jj,jk,Krhs_a))
182                     END DO
183                     IF (.NOT.ln_linssh) z_out(1:N_out) = z_out(1:N_out) - ssh(ji,jj,Krhs_a)
184                     CALL remap_linear(tabin(1:N_in,1:jptra),z_in(1:N_in),ptab(ji,jj,1:N_out,1:jptra), &
185                                   &   z_out(1:N_out),N_in,N_out,jptra) 
186                  END DO
187               END DO
188
189            ENDIF
190
[13337]191            DO jn=1, jptra
192                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) 
193            END DO
194         ENDIF
195
[628]196      ENDIF
[3680]197      !
[5656]198   END SUBROUTINE interptrn
[2715]199
[628]200#else
[9019]201   !!----------------------------------------------------------------------
202   !!   Empty module                                           no TOP AGRIF
203   !!----------------------------------------------------------------------
[636]204CONTAINS
205   SUBROUTINE Agrif_TOP_Interp_empty
206      !!---------------------------------------------
207      !!   *** ROUTINE agrif_Top_Interp_empty ***
208      !!---------------------------------------------
209      WRITE(*,*)  'agrif_top_interp : You should not have seen this print! error?'
210   END SUBROUTINE Agrif_TOP_Interp_empty
[628]211#endif
[9019]212
213   !!======================================================================
[636]214END MODULE agrif_top_interp
Note: See TracBrowser for help on using the repository browser.