source: NEMO/trunk/src/NST/agrif_top_interp.F90 @ 13216

Last change on this file since 13216 was 13216, checked in by rblod, 4 months ago

Merge dev_r12973_AGRIF_CMEMS

  • Property svn:keywords set to Id
File size: 5.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      !
46      CALL Agrif_Bc_variable( trn_id, procname=interptrn )
47      Agrif_UseSpecialValue = .FALSE.
48      !
49   END SUBROUTINE Agrif_trc
50
51   SUBROUTINE interptrn( ptab, i1, i2, j1, j2, k1, k2, n1, n2, before )
52      !!----------------------------------------------------------------------
53      !!                  *** ROUTINE interptrn ***
54      !!----------------------------------------------------------------------
55      REAL(wp), DIMENSION(i1:i2,j1:j2,k1:k2,n1:n2), INTENT(inout) ::   ptab
56      INTEGER                                     , INTENT(in   ) ::   i1, i2, j1, j2, k1, k2, n1, n2
57      LOGICAL                                     , INTENT(in   ) ::   before
58      !
59      INTEGER  ::   ji, jj, jk, jn, ibdy, jbdy   ! dummy loop indices
60      INTEGER  ::   imin, imax, jmin, jmax, N_in, N_out
61      REAL(wp) ::   zrho, z1, z2, z3, z4, z5, z6, z7
62
63      ! vertical interpolation:
64      REAL(wp), DIMENSION(i1:i2,j1:j2,1:jpk,1:jptra) :: ptab_child
65      REAL(wp), DIMENSION(k1:k2,1:jptra) :: tabin
66      REAL(wp), DIMENSION(k1:k2) :: h_in
67      REAL(wp), DIMENSION(1:jpk) :: h_out
68      !!----------------------------------------------------------------------
69
70      IF( before ) THEN         
71         DO jn = 1,jptra
72            DO jk=k1,k2
73               DO jj=j1,j2
74                 DO ji=i1,i2
75                       ptab(ji,jj,jk,jn) = tr(ji,jj,jk,jn,Kmm_a)
76                 END DO
77              END DO
78           END DO
79        END DO
80
81# if defined key_vertical
82        DO jk=k1,k2
83           DO jj=j1,j2
84              DO ji=i1,i2
85                 ptab(ji,jj,jk,jptra+1) = tmask(ji,jj,jk) * e3t(ji,jj,jk,Kmm_a) 
86              END DO
87           END DO
88        END DO
89# endif
90      ELSE 
91
92# if defined key_vertical
93         DO jj=j1,j2
94            DO ji=i1,i2
95               ptab_child(ji,jj,:) = 0._wp
96               N_in = 0
97               DO jk=k1,k2 !k2 = jpk of parent grid
98                  IF (ptab(ji,jj,jk,n2) == 0) EXIT
99                  N_in = N_in + 1
100                  tabin(jk,:) = ptab(ji,jj,jk,n1:n2-1)
101                  h_in(N_in) = ptab(ji,jj,jk,n2)
102               END DO
103               N_out = 0
104               DO jk=1,jpk ! jpk of child grid
105                  IF (tmask(ji,jj,jk) == 0) EXIT
106                  N_out = N_out + 1
107                  h_out(jk) = e3t(ji,jj,jk,Krhs_a)
108               ENDDO
109               IF (N_in > 0) THEN
110                  CALL reconstructandremap(tabin(1:N_in,1:jptra),h_in,ptab_child(ji,jj,1:N_out,1:jptra),h_out,N_in,N_out,jptra)
111               ENDIF
112            ENDDO
113         ENDDO
114# else
115         ptab_child(i1:i2,j1:j2,1:jpk,1:jptra) = ptab(i1:i2,j1:j2,1:jpk,1:jptra)
116# endif
117         !
118         DO jn=1, jptra
119            tr(i1:i2,j1:j2,1:jpk,jn,Krhs_a)=ptab_child(i1:i2,j1:j2,1:jpk,jn)*tmask(i1:i2,j1:j2,1:jpk) 
120         END DO
121      ENDIF
122      !
123   END SUBROUTINE interptrn
124
125#else
126   !!----------------------------------------------------------------------
127   !!   Empty module                                           no TOP AGRIF
128   !!----------------------------------------------------------------------
129CONTAINS
130   SUBROUTINE Agrif_TOP_Interp_empty
131      !!---------------------------------------------
132      !!   *** ROUTINE agrif_Top_Interp_empty ***
133      !!---------------------------------------------
134      WRITE(*,*)  'agrif_top_interp : You should not have seen this print! error?'
135   END SUBROUTINE Agrif_TOP_Interp_empty
136#endif
137
138   !!======================================================================
139END MODULE agrif_top_interp
Note: See TracBrowser for help on using the repository browser.