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_lim3_interp.F90 in branches/2016/dev_v3_6_STABLE_r6506_AGRIF_LIM3/NEMOGCM/NEMO/NST_SRC – NEMO

source: branches/2016/dev_v3_6_STABLE_r6506_AGRIF_LIM3/NEMOGCM/NEMO/NST_SRC/agrif_lim3_interp.F90 @ 7069

Last change on this file since 7069 was 7069, checked in by clem, 7 years ago

agrif+lim3 update + trunk update
File size: 8.9 KB
Line 
1MODULE agrif_lim3_interp
2   !!=====================================================================================
3   !!                       ***  MODULE agrif_lim3_interp ***
4   !! Nesting module :  interp surface ice boundary condition from a parent grid
5   !! Sea-Ice model  :  LIM 3.6 Sea ice model time-stepping
6   !!=====================================================================================
7   !! History :  2.0   !  04-2008  (F. Dupont)  initial version
8   !!            3.4   !  09-2012  (R. Benshila, C. Herbaut) update and EVP
9   !!            3.6   !  05-2016  (C. Rousset)  Add LIM3 compatibility
10   !!----------------------------------------------------------------------
11#if defined key_agrif && defined key_lim3 
12   !!----------------------------------------------------------------------
13   !!   'key_lim3'  :                                 LIM 3.6 sea-ice model
14   !!   'key_agrif' :                                 AGRIF library
15   !!----------------------------------------------------------------------
16   !!  agrif_interp_lim3    : interpolation of ice at "after" sea-ice time step
17   !!  agrif_interp_u_ice   : atomic routine to interpolate u_ice
18   !!  agrif_interp_v_ice   : atomic routine to interpolate v_ice
19   !!  agrif_interp_tra_ice : atomic routine to interpolate ice properties
20   !!----------------------------------------------------------------------
21   USE par_oce
22   USE dom_oce
23   USE sbc_oce
24   USE ice
25   USE agrif_ice
26
27   IMPLICIT NONE
28   PRIVATE
29
30   PUBLIC agrif_interp_lim3
31
32   !!----------------------------------------------------------------------
33   !! NEMO/NST 3.6 , NEMO Consortium (2016)
34   !! $Id: agrif_lim3_interp.F90 6204 2016-01-04 13:47:06Z cetlod $
35   !! Software governed by the CeCILL licence     (NEMOGCM/NEMO_CeCILL.txt)
36   !!----------------------------------------------------------------------
37
38CONTAINS
39
40   SUBROUTINE agrif_interp_lim3( cd_type )
41      !!-----------------------------------------------------------------------
42      !!                 *** ROUTINE agrif_rhg_lim3  ***
43      !!
44      !!  ** Method  : simple call to atomic routines using stored values to
45      !!  fill the boundaries depending of the position of the point and
46      !!  computing factor for time interpolation
47      !!-----------------------------------------------------------------------
48      CHARACTER(len=1), INTENT( in ) :: cd_type
49      !!   
50      REAL(wp) :: zbeta
51      !!-----------------------------------------------------------------------
52      !
53      IF( Agrif_Root() )  RETURN
54      !
55      zbeta = REAL(lim_nbstep) / ( Agrif_Rhot() * REAL(Agrif_Parent(nn_fsbc)) / REAL(nn_fsbc) )
56      !
57      ! clem: calledweight = zbeta(1/3;2/3;1) => 2/3*var1+1/3*var2 puis 1/3;2/3 puis 0;1
58      Agrif_SpecialValue=-9999.
59      Agrif_UseSpecialValue = .TRUE.
60      SELECT CASE(cd_type)
61      CASE('U')
62         CALL Agrif_Bc_variable( u_ice_id  , procname=interp_u_ice  , calledweight=zbeta )
63      CASE('V')
64         CALL Agrif_Bc_variable( v_ice_id  , procname=interp_v_ice  , calledweight=zbeta )
65      CASE('T')
66         CALL Agrif_Bc_variable( tra_ice_id, procname=interp_tra_ice, calledweight=zbeta )
67      END SELECT
68      Agrif_SpecialValue=0.
69      Agrif_UseSpecialValue = .FALSE.
70      !
71   END SUBROUTINE agrif_interp_lim3
72
73   !!------------------
74   !! Local subroutines
75   !!------------------
76   SUBROUTINE interp_u_ice( ptab, i1, i2, j1, j2, before )
77      !!-----------------------------------------------------------------------
78      !!                     *** ROUTINE interp_u_ice ***
79      !!
80      !! i1 i2 j1 j2 are the index of the boundaries parent(when before) and child (when after)
81      !! To solve issues when parent grid is "land" masked but not all the corresponding child grid points,
82      !! put -9999 WHERE the parent grid is masked. The child solution will be found in the 9(?) points around
83      !!-----------------------------------------------------------------------
84      INTEGER , INTENT(in) :: i1, i2, j1, j2
85      REAL(wp), DIMENSION(i1:i2,j1:j2), INTENT(inout) :: ptab
86      LOGICAL , INTENT(in) :: before
87      !!
88      REAL(wp) :: zrhoy
89      !!-----------------------------------------------------------------------
90      !
91      IF( before ) THEN  ! parent grid
92         ptab(:,:) = e2u(i1:i2,j1:j2) * u_ice_b(i1:i2,j1:j2)
93         WHERE( umask(i1:i2,j1:j2,1) == 0. )  ptab(:,:) = -9999.
94      ELSE               ! child grid
95         zrhoy = Agrif_Rhoy()
96         u_ice(i1:i2,j1:j2) = ptab(:,:) / ( e2u(i1:i2,j1:j2) * zrhoy ) * umask(i1:i2,j1:j2,1)
97      ENDIF
98      !
99   END SUBROUTINE interp_u_ice
100
101
102   SUBROUTINE interp_v_ice( ptab, i1, i2, j1, j2, before )
103      !!-----------------------------------------------------------------------
104      !!                    *** ROUTINE interp_v_ice ***
105      !!
106      !! i1 i2 j1 j2 are the index of the boundaries parent(when before) and child (when after)
107      !! To solve issues when parent grid is "land" masked but not all the corresponding child grid points,
108      !! put -9999 WHERE the parent grid is masked. The child solution will be found in the 9(?) points around
109      !!-----------------------------------------------------------------------     
110      INTEGER , INTENT(in) :: i1, i2, j1, j2
111      REAL(wp), DIMENSION(i1:i2,j1:j2), INTENT(inout) :: ptab
112      LOGICAL , INTENT(in) :: before
113      !!
114      REAL(wp) :: zrhox
115      !!-----------------------------------------------------------------------
116      !
117      IF( before ) THEN  ! parent grid
118         ptab(:,:) = e1v(i1:i2,j1:j2) * v_ice_b(i1:i2,j1:j2)
119         WHERE( vmask(i1:i2,j1:j2,1) == 0. )  ptab(:,:) = -9999.
120      ELSE               ! child grid
121         zrhox = Agrif_Rhox()
122         v_ice(i1:i2,j1:j2) = ptab(:,:) / ( e1v(i1:i2,j1:j2) * zrhox ) * vmask(i1:i2,j1:j2,1)
123      ENDIF
124      !
125   END SUBROUTINE interp_v_ice
126
127
128   SUBROUTINE interp_tra_ice( ptab, i1, i2, j1, j2, k1, k2, before )
129      !!-----------------------------------------------------------------------
130      !!                    *** ROUTINE interp_tra_ice ***                           
131      !!
132      !! i1 i2 j1 j2 are the index of the boundaries parent(when before) and child (when after)
133      !! To solve issues when parent grid is "land" masked but not all the corresponding child grid points,
134      !! put -9999 WHERE the parent grid is masked. The child solution will be found in the 9(?) points around
135      !!-----------------------------------------------------------------------
136      REAL(wp), DIMENSION(i1:i2,j1:j2,k1:k2), INTENT(inout) :: ptab
137      INTEGER , INTENT(in) :: i1, i2, j1, j2, k1, k2
138      LOGICAL , INTENT(in) :: before
139      !!
140      INTEGER :: jk, jl, jm
141      !!-----------------------------------------------------------------------
142      ! clem: pkoi on n'utilise pas les quantités intégrées ici => before: * e12t ; after: * r1_e12t / rhox / rhoy
143      ! a priori c'est ok comme ca (cf ce qui est fait dans l'ocean). Je ne sais pas pkoi ceci dit
144     
145      IF( before ) THEN  ! parent grid
146         jm = 1
147         DO jl = 1, jpl
148            ptab(:,:,jm) = a_i_b  (i1:i2,j1:j2,jl) ; jm = jm + 1
149            ptab(:,:,jm) = v_i_b  (i1:i2,j1:j2,jl) ; jm = jm + 1
150            ptab(:,:,jm) = v_s_b  (i1:i2,j1:j2,jl) ; jm = jm + 1
151            ptab(:,:,jm) = smv_i_b(i1:i2,j1:j2,jl) ; jm = jm + 1
152            ptab(:,:,jm) = oa_i_b (i1:i2,j1:j2,jl) ; jm = jm + 1
153            DO jk = 1, nlay_s
154               ptab(:,:,jm) = e_s_b(i1:i2,j1:j2,jk,jl) ; jm = jm + 1
155            ENDDO
156            DO jk = 1, nlay_i
157               ptab(:,:,jm) = e_i_b(i1:i2,j1:j2,jk,jl) ; jm = jm + 1
158            ENDDO
159         ENDDO
160         !!ptab(:,:,jm) = ato_i(i1:i2,j1:j2)
161         
162         DO jk = k1, k2
163            WHERE( tmask(i1:i2,j1:j2,1) == 0. )  ptab(:,:,jk) = -9999.
164         ENDDO
165         
166      ELSE               ! child grid
167         jm = 1
168         DO jl = 1, jpl
169            a_i  (i1:i2,j1:j2,jl) = ptab(:,:,jm) * tmask(i1:i2,j1:j2,1) ; jm = jm + 1
170            v_i  (i1:i2,j1:j2,jl) = ptab(:,:,jm) * tmask(i1:i2,j1:j2,1) ; jm = jm + 1
171            v_s  (i1:i2,j1:j2,jl) = ptab(:,:,jm) * tmask(i1:i2,j1:j2,1) ; jm = jm + 1
172            smv_i(i1:i2,j1:j2,jl) = ptab(:,:,jm) * tmask(i1:i2,j1:j2,1) ; jm = jm + 1
173            oa_i (i1:i2,j1:j2,jl) = ptab(:,:,jm) * tmask(i1:i2,j1:j2,1) ; jm = jm + 1
174            DO jk = 1, nlay_s
175               e_s(i1:i2,j1:j2,jk,jl) = ptab(:,:,jm) * tmask(i1:i2,j1:j2,1) ; jm = jm + 1
176            ENDDO
177            DO jk = 1, nlay_i
178               e_i(i1:i2,j1:j2,jk,jl) = ptab(:,:,jm) * tmask(i1:i2,j1:j2,1) ; jm = jm + 1
179            ENDDO
180         ENDDO
181         !!ato_i(i1:i2,j1:j2) = ptab(:,:,jm) * tmask(i1:i2,j1:j2,1)
182         
183      ENDIF
184      !
185   END SUBROUTINE interp_tra_ice
186
187#else
188CONTAINS
189   SUBROUTINE agrif_lim3_interp_empty
190      !!---------------------------------------------
191      !!   *** ROUTINE agrif_lim3_interp_empty ***
192      !!---------------------------------------------
193      WRITE(*,*)  'agrif_lim3_interp : You should not have seen this print! error?'
194   END SUBROUTINE agrif_lim3_interp_empty
195#endif
196END MODULE agrif_lim3_interp
Note: See TracBrowser for help on using the repository browser.