source: NEMO/trunk/src/NST/agrif_user.F90 @ 14976

Last change on this file since 14976 was 14976, checked in by jchanut, 4 months ago

#2638, merge dev_14608_AGRIF_domcfg branch into trunk

  • Property svn:keywords set to Id
File size: 52.3 KB
Line 
1#undef UPD_HIGH   /* MIX HIGH UPDATE */
2#define DIV_CONS   /* DIVERGENCE CONS */
3#if defined key_agrif
4   !! * Substitutions
5#  include "do_loop_substitute.h90"
6   !!----------------------------------------------------------------------
7   !! NEMO/NST 4.0 , NEMO Consortium (2018)
8   !! $Id$
9   !! Software governed by the CeCILL license (see ./LICENSE)
10   !!----------------------------------------------------------------------
11   SUBROUTINE agrif_user
12   END SUBROUTINE agrif_user
13
14   
15   SUBROUTINE agrif_before_regridding
16   END SUBROUTINE agrif_before_regridding
17
18   
19   SUBROUTINE Agrif_InitWorkspace
20   END SUBROUTINE Agrif_InitWorkspace
21
22   
23   SUBROUTINE Agrif_InitValues
24      !!----------------------------------------------------------------------
25      !!                 *** ROUTINE Agrif_InitValues ***
26      !!----------------------------------------------------------------------
27      USE nemogcm
28      !!----------------------------------------------------------------------
29      !
30      CALL nemo_init       !* Initializations of each fine grid
31      Kbb_a = Nbb; Kmm_a = Nnn; Krhs_a = Nrhs   ! agrif_oce module copies of time level indices
32      !
33      !                    !* Agrif initialization
34      CALL Agrif_InitValues_cont
35# if defined key_top
36      CALL Agrif_InitValues_cont_top
37# endif
38# if defined key_si3
39      CALL Agrif_InitValues_cont_ice
40# endif
41      !   
42   END SUBROUTINE Agrif_initvalues
43
44   
45   SUBROUTINE agrif_declare_var_ini
46      !!----------------------------------------------------------------------
47      !!                 *** ROUTINE agrif_declare_var_ini ***
48      !!----------------------------------------------------------------------
49      USE agrif_util
50      USE agrif_oce
51      USE par_oce
52      USE zdf_oce 
53      USE oce
54      USE dom_oce
55      !
56      IMPLICIT NONE
57      !
58      INTEGER :: ind1, ind2, ind3, imaxrho
59      INTEGER :: nbghostcellsfine_tot_x, nbghostcellsfine_tot_y
60      INTEGER :: its
61      External :: nemo_mapping
62      !!----------------------------------------------------------------------
63
64! In case of East-West periodicity, prevent AGRIF interpolation at east and west boundaries
65! The procnames will not be called at these boundaries
66      IF (l_Iperio) THEN
67         CALL Agrif_Set_NearCommonBorderX(.TRUE.)
68         CALL Agrif_Set_DistantCommonBorderX(.TRUE.)
69      ENDIF
70
71      IF ( .NOT. lk_south ) THEN
72         CALL Agrif_Set_NearCommonBorderY(.TRUE.)
73      ENDIF
74
75      IF ( .NOT. lk_north ) THEN
76         CALL Agrif_Set_DistantCommonBorderY(.TRUE.)
77      ENDIF
78
79      ! 1. Declaration of the type of variable which have to be interpolated
80      !---------------------------------------------------------------------
81!      ind1 =              nbghostcells
82      ind2 = nn_hls + 1 + nbghostcells_x
83      ind3 = nn_hls + 1 + nbghostcells_y_s
84      nbghostcellsfine_tot_x = nbghostcells_x+1
85      nbghostcellsfine_tot_y = MAX(nbghostcells_y_s,nbghostcells_y_n)+1
86      ind1 = MAX(nbghostcellsfine_tot_x, nbghostcellsfine_tot_y)
87      imaxrho = MAX(Agrif_irhox(), Agrif_irhoy())
88
89      CALL agrif_declare_variable((/2,2,0  /),(/ind2  ,ind3,0    /),(/'x','y','N'    /),(/1,1,1  /),(/jpi,jpj,jpk    /),        e3t_id)
90      CALL agrif_declare_variable((/2,2,0  /),(/ind2  ,ind3,0    /),(/'x','y','N'    /),(/1,1,1  /),(/jpi,jpj,jpk    /),e3t0_interp_id)
91      CALL agrif_declare_variable((/2,2    /),(/ind2  ,ind3      /),(/'x','y'        /),(/1,1    /),(/jpi,jpj        /),       mbkt_id)
92      CALL agrif_declare_variable((/2,2    /),(/ind2  ,ind3      /),(/'x','y'        /),(/1,1    /),(/jpi,jpj        /),        ht0_id)
93   
94      ! Initial or restart velues
95      its = jpts+1
96      CALL agrif_declare_variable((/2,2,0,0/),(/ind2  ,ind3  ,0,0/),(/'x','y','N','N'/),(/1,1,1,1/),(/jpi,jpj,jpk,its/), tsini_id)
97      CALL agrif_declare_variable((/1,2,0,0/),(/ind2-1,ind3  ,0,0/),(/'x','y','N','N'/),(/1,1,1,1/),(/jpi,jpj,jpk,2  /),  uini_id) 
98      CALL agrif_declare_variable((/2,1,0,0/),(/ind2  ,ind3-1,0,0/),(/'x','y','N','N'/),(/1,1,1,1/),(/jpi,jpj,jpk,2  /),  vini_id)
99      CALL agrif_declare_variable((/2,2    /),(/ind2  ,ind3      /),(/'x','y'        /),(/1,1    /),(/jpi,jpj        /),sshini_id)
100      !
101      ! Update location
102      CALL agrif_declare_variable((/2,2/),(/ind2  ,ind3  /),(/'x','y'/),(/1,1/),(/jpi,jpj/), batupd_id)
103     
104      ! 2. Type of interpolation
105      !-------------------------
106      CALL Agrif_Set_bcinterp(        e3t_id,interp =AGRIF_constant)
107      CALL Agrif_Set_bcinterp(e3t0_interp_id,interp =AGRIF_linear  )
108      CALL Agrif_Set_interp  (e3t0_interp_id,interp =AGRIF_linear  )
109      CALL Agrif_Set_bcinterp(       mbkt_id,interp =AGRIF_constant)
110      CALL Agrif_Set_interp  (       mbkt_id,interp =AGRIF_constant)
111      CALL Agrif_Set_bcinterp(        ht0_id,interp =AGRIF_constant)
112      CALL Agrif_Set_interp  (        ht0_id,interp =AGRIF_constant)
113
114      ! Initial fields
115      CALL Agrif_Set_bcinterp( tsini_id,interp =AGRIF_linear  )
116      CALL Agrif_Set_interp  ( tsini_id,interp =AGRIF_linear  )
117      CALL Agrif_Set_bcinterp(  uini_id,interp =AGRIF_linear  )
118      CALL Agrif_Set_interp  (  uini_id,interp =AGRIF_linear  )
119      CALL Agrif_Set_bcinterp(  vini_id,interp =AGRIF_linear  )
120      CALL Agrif_Set_interp  (  vini_id,interp =AGRIF_linear  )
121      CALL Agrif_Set_bcinterp(sshini_id,interp =AGRIF_linear  )
122      CALL Agrif_Set_interp  (sshini_id,interp =AGRIF_linear  )
123
124       ! 3. Location of interpolation
125      !-----------------------------
126      CALL Agrif_Set_bc(  e3t_id, (/-nn_sponge_len*imaxrho-2,ind1-1/) ) 
127
128      ! extend the interpolation zone by 1 more point than necessary:
129      ! RB check here
130      CALL Agrif_Set_bc( e3t0_interp_id, (/-nn_sponge_len*imaxrho-2,ind1-1/) )
131      CALL Agrif_Set_bc(        mbkt_id, (/-nn_sponge_len*imaxrho-2,ind1-1/) )
132      CALL Agrif_Set_bc(         ht0_id, (/-nn_sponge_len*imaxrho-2,ind1-1/) )
133
134      CALL Agrif_Set_bc(       tsini_id, (/0,ind1-1/) ) ! if west,  rhox=3 and nbghost=3: columns 2 to 4
135      CALL Agrif_Set_bc(        uini_id, (/0,ind1-1/) ) 
136      CALL Agrif_Set_bc(        vini_id, (/0,ind1-1/) )
137      CALL Agrif_Set_bc(      sshini_id, (/0,ind1-1/) )
138
139      ! 4. Update type
140      !---------------
141# if defined UPD_HIGH
142      CALL Agrif_Set_Updatetype(batupd_id, update = Agrif_Update_Full_Weighting)
143#else
144      CALL Agrif_Set_Updatetype(batupd_id, update = Agrif_Update_Average)
145#endif     
146
147      CALL Agrif_Set_ExternalMapping(nemo_mapping)
148      !
149   END SUBROUTINE agrif_declare_var_ini
150
151
152   SUBROUTINE Agrif_Init_Domain
153      !!----------------------------------------------------------------------
154      !!                 *** ROUTINE Agrif_Init_Domain ***
155      !!----------------------------------------------------------------------
156      USE agrif_oce_update
157      USE agrif_oce_interp
158      USE agrif_oce_sponge
159      USE Agrif_Util
160      USE oce 
161      USE dom_oce
162      USE zdf_oce
163      USE nemogcm
164      USE agrif_oce
165      !
166      USE lbclnk
167      USE lib_mpp
168      USE in_out_manager
169      !
170      IMPLICIT NONE
171      !
172      !
173      LOGICAL :: check_namelist
174      CHARACTER(len=15) :: cl_check1, cl_check2, cl_check3, cl_check4 
175      REAL(wp), DIMENSION(jpi,jpj) ::   zk   ! workspace
176      INTEGER :: ji, jj, jk
177      INTEGER :: jpk_parent, ierr
178      !!----------------------------------------------------------------------
179   
180     ! CALL Agrif_Declare_Var_ini
181
182      IF( agrif_oce_alloc()  > 0 )   CALL ctl_warn('agrif agrif_oce_alloc: allocation of arrays failed')
183
184      ! Build consistent parent bathymetry and number of levels
185      ! on the child grid
186      Agrif_UseSpecialValue = .FALSE.
187      ht0_parent( :,:) = 0._wp
188      mbkt_parent(:,:) = 0
189      !
190!     CALL Agrif_Bc_variable(ht0_id ,calledweight=1.,procname=interpht0 )
191!     CALL Agrif_Bc_variable(mbkt_id,calledweight=1.,procname=interpmbkt)
192      CALL Agrif_Init_Variable(ht0_id , procname=interpht0 )
193      CALL Agrif_Init_Variable(mbkt_id, procname=interpmbkt)
194      !
195      ! Assume step wise change of bathymetry near interface
196      ! TODO: Switch to linear interpolation of bathymetry in the s-coordinate case
197      !       and no refinement
198      DO_2D( 1, 0, 1, 0 )
199         mbku_parent(ji,jj) = MIN( mbkt_parent(ji+1,jj  ), mbkt_parent(ji,jj) )
200         mbkv_parent(ji,jj) = MIN( mbkt_parent(ji  ,jj+1), mbkt_parent(ji,jj) )
201      END_2D
202      IF ( ln_sco.AND.Agrif_Parent(ln_sco) ) THEN
203         DO_2D( 1, 0, 1, 0 )
204            hu0_parent(ji,jj) = 0.5_wp * ( ht0_parent(ji,jj)+ht0_parent(ji+1,jj) ) * ssumask(ji,jj)
205            hv0_parent(ji,jj) = 0.5_wp * ( ht0_parent(ji,jj)+ht0_parent(ji,jj+1) ) * ssvmask(ji,jj)
206         END_2D
207      ELSE
208         DO_2D( 1, 0, 1, 0 )
209            hu0_parent(ji,jj) = MIN( ht0_parent(ji,jj), ht0_parent(ji+1,jj) )
210            hv0_parent(ji,jj) = MIN( ht0_parent(ji,jj), ht0_parent(ji,jj+1) )
211         END_2D
212      ENDIF
213      !
214      CALL lbc_lnk( 'Agrif_Init_Domain', hu0_parent, 'U', 1.0_wp, hv0_parent, 'V', 1.0_wp )
215      DO_2D( 0, 0, 0, 0 )
216         zk(ji,jj) = REAL( mbku_parent(ji,jj), wp )
217      END_2D
218      CALL lbc_lnk( 'Agrif_InitValues_Domain', zk, 'U', 1.0_wp )
219      mbku_parent(:,:) = MAX( NINT( zk(:,:) ), 1 )
220      DO_2D( 0, 0, 0, 0 )
221         zk(ji,jj) = REAL( mbkv_parent(ji,jj), wp )
222      END_2D
223      CALL lbc_lnk( 'Agrif_InitValues_Domain', zk, 'V', 1.0_wp )
224      mbkv_parent(:,:) = MAX( NINT( zk(:,:) ), 1 ) 
225      !
226      ! Build "intermediate" parent vertical grid on child domain
227      jpk_parent = Agrif_parent( jpk )
228      ALLOCATE(e3t0_parent(jpi,jpj,jpk_parent), &
229         &     e3u0_parent(jpi,jpj,jpk_parent), &
230         &     e3v0_parent(jpi,jpj,jpk_parent), STAT = ierr) 
231      IF( ierr  > 0 )   CALL ctl_warn('Agrif_Init_Domain: allocation of arrays failed')
232       
233      ! Retrieve expected parent scale factors on child grid:
234      Agrif_UseSpecialValue = .FALSE.
235      e3t0_parent(:,:,:) = 0._wp
236      CALL Agrif_Init_Variable(e3t0_interp_id, procname=interpe3t0_vremap)
237      !
238      ! Deduce scale factors at U and V points:
239      DO_3D( 0, 0, 0, 0, 1, jpk_parent )
240         e3u0_parent(ji,jj,jk) = 0.5_wp * (e3t0_parent(ji,jj,jk) + e3t0_parent(ji+1,jj  ,jk))
241         e3v0_parent(ji,jj,jk) = 0.5_wp * (e3t0_parent(ji,jj,jk) + e3t0_parent(ji  ,jj+1,jk))
242      END_3D
243
244      ! Assume a step at the bottom except if (pure) s-coordinates
245      IF ( .NOT.Agrif_Parent(ln_sco) ) THEN
246         DO_2D( 1, 0, 1, 0 )
247            jk = mbku_parent(ji,jj)
248            e3u0_parent(ji,jj,jk) = MIN(e3t0_parent(ji,jj,jk), e3t0_parent(ji+1,jj  ,jk))
249            jk = mbkv_parent(ji,jj)
250            e3v0_parent(ji,jj,jk) = MIN(e3t0_parent(ji,jj,jk), e3t0_parent(ji  ,jj+1,jk))
251         END_2D
252      ENDIF
253
254      CALL lbc_lnk( 'Agrif_Init_Domain', e3u0_parent, 'U', 1.0_wp, e3v0_parent, 'V', 1.0_wp )
255
256      ! check if masks and bathymetries match
257      IF(ln_chk_bathy) THEN
258         Agrif_UseSpecialValue = .FALSE.
259         !
260         IF(lwp) WRITE(numout,*) ' '
261         IF(lwp) WRITE(numout,*) 'AGRIF: Check Bathymetry and masks near bdys. Level: ', Agrif_Level()
262         !
263         kindic_agr = 0
264         !         
265         CALL Agrif_check_bat( kindic_agr )           
266         !
267         CALL mpp_sum( 'agrif_InitValues_Domain', kindic_agr )
268         IF( kindic_agr /= 0 ) THEN
269            CALL ctl_stop('==> Child Bathymetry is NOT correct near boundaries.')
270         ELSE
271            IF(lwp) WRITE(numout,*) '==> Child Bathymetry is ok near boundaries.'
272            IF(lwp) WRITE(numout,*) ' '
273         ENDIF 
274      ENDIF
275      !
276      WHERE (ssumask(:,:) == 0._wp) mbku_parent(:,:) = 0
277      WHERE (ssvmask(:,:) == 0._wp) mbkv_parent(:,:) = 0
278      WHERE (ssmask(:,:)  == 0._wp) mbkt_parent(:,:) = 0
279      !
280      IF ( .NOT.ln_vert_remap ) DEALLOCATE(e3t0_parent, e3u0_parent, e3v0_parent)
281
282   END SUBROUTINE Agrif_Init_Domain
283
284
285   SUBROUTINE Agrif_InitValues_cont
286      !!----------------------------------------------------------------------
287      !!                 *** ROUTINE Agrif_InitValues_cont ***
288      !!
289      !! ** Purpose ::   Declaration of variables to be interpolated
290      !!----------------------------------------------------------------------
291      USE agrif_oce_update
292      USE agrif_oce_interp
293      USE agrif_oce_sponge
294      USE Agrif_Util
295      USE oce 
296      USE dom_oce
297      USE zdf_oce
298      USE nemogcm
299      USE agrif_oce
300      !
301      USE lbclnk
302      USE lib_mpp
303      USE in_out_manager
304      !
305      IMPLICIT NONE
306      !
307      LOGICAL :: check_namelist
308      CHARACTER(len=15) :: cl_check1, cl_check2, cl_check3, cl_check4 
309
310      ! 1. Declaration of the type of variable which have to be interpolated
311      !---------------------------------------------------------------------
312      CALL agrif_declare_var
313
314      ! 2. First interpolations of potentially non zero fields
315      !-------------------------------------------------------
316      Agrif_SpecialValue    = 0._wp
317      Agrif_UseSpecialValue = .TRUE.
318      l_vremap              = ln_vert_remap
319
320      CALL Agrif_Bc_variable(ts_interp_id,calledweight=1.,procname=interptsn)
321      CALL Agrif_Sponge
322      tabspongedone_tsn = .FALSE.
323      CALL Agrif_Bc_variable(ts_sponge_id,calledweight=1.,procname=interptsn_sponge)
324      ! reset tsa to zero
325      ts(:,:,:,:,Krhs_a) = 0._wp
326
327      Agrif_UseSpecialValue = ln_spc_dyn
328      use_sign_north = .TRUE.
329      sign_north = -1.
330      CALL Agrif_Bc_variable(un_interp_id,calledweight=1.,procname=interpun)
331      CALL Agrif_Bc_variable(vn_interp_id,calledweight=1.,procname=interpvn)
332      tabspongedone_u = .FALSE.
333      tabspongedone_v = .FALSE.
334      CALL Agrif_Bc_variable(un_sponge_id,calledweight=1.,procname=interpun_sponge)
335      tabspongedone_u = .FALSE.
336      tabspongedone_v = .FALSE.
337      CALL Agrif_Bc_variable(vn_sponge_id,calledweight=1.,procname=interpvn_sponge)
338      IF (nn_shift_bar>0) THEN
339         CALL Agrif_Sponge_2d
340         tabspongedone_u = .FALSE.
341         tabspongedone_v = .FALSE.
342         CALL Agrif_Bc_variable(unb_sponge_id,calledweight=1.,procname=interpunb_sponge)
343         tabspongedone_u = .FALSE.
344         tabspongedone_v = .FALSE.
345         CALL Agrif_Bc_variable(vnb_sponge_id,calledweight=1.,procname=interpvnb_sponge)
346      ENDIF
347      use_sign_north = .FALSE.
348      uu(:,:,:,Krhs_a) = 0._wp
349      vv(:,:,:,Krhs_a) = 0._wp
350
351      Agrif_UseSpecialValue = .TRUE.
352      CALL Agrif_Bc_variable(sshn_id,calledweight=1., procname=interpsshn )
353      hbdy(:,:) = 0._wp
354      ssh(:,:,Krhs_a) = 0._wp
355
356      IF ( ln_dynspg_ts ) THEN
357         Agrif_UseSpecialValue = ln_spc_dyn
358         use_sign_north = .TRUE.
359         sign_north = -1.
360         CALL Agrif_Bc_variable(ub2b_interp_id,calledweight=1.,procname=interpub2b)   ! must be called before unb_id to define ubdy
361         CALL Agrif_Bc_variable(vb2b_interp_id,calledweight=1.,procname=interpvb2b)   ! must be called before vnb_id to define vbdy
362         CALL Agrif_Bc_variable( unb_interp_id,calledweight=1.,procname=interpunb )
363         CALL Agrif_Bc_variable( vnb_interp_id,calledweight=1.,procname=interpvnb )
364         use_sign_north = .FALSE.
365         ubdy(:,:) = 0._wp
366         vbdy(:,:) = 0._wp
367      ELSEIF ( ln_dynspg_EXP ) THEN
368         Agrif_UseSpecialValue = ln_spc_dyn
369         use_sign_north = .TRUE.
370         sign_north = -1.
371         ubdy(:,:) = 0._wp
372         vbdy(:,:) = 0._wp
373         CALL Agrif_Bc_variable( unb_interp_id,calledweight=1.,procname=interpunb )
374         CALL Agrif_Bc_variable( vnb_interp_id,calledweight=1.,procname=interpvnb )
375         use_sign_north = .FALSE.
376         ubdy(:,:) = 0._wp
377         vbdy(:,:) = 0._wp
378      ENDIF
379      Agrif_UseSpecialValue = .FALSE. 
380      l_vremap              = .FALSE.
381
382      !-----------------
383      check_namelist = .TRUE.
384
385      IF( check_namelist ) THEN 
386         ! Check free surface scheme
387         IF ( ( Agrif_Parent(ln_dynspg_ts ).AND.ln_dynspg_exp ).OR.&
388            & ( Agrif_Parent(ln_dynspg_exp).AND.ln_dynspg_ts ) ) THEN
389            WRITE(cl_check1,*)  Agrif_Parent( ln_dynspg_ts )
390            WRITE(cl_check2,*)  ln_dynspg_ts
391            WRITE(cl_check3,*)  Agrif_Parent( ln_dynspg_exp )
392            WRITE(cl_check4,*)  ln_dynspg_exp
393            CALL ctl_stop( 'Incompatible free surface scheme between grids' ,  &
394                  &               'parent grid ln_dynspg_ts  :'//cl_check1  ,  & 
395                  &               'child  grid ln_dynspg_ts  :'//cl_check2  ,  &
396                  &               'parent grid ln_dynspg_exp :'//cl_check3  ,  &
397                  &               'child  grid ln_dynspg_exp :'//cl_check4  ,  &
398                  &               'those logicals should be identical' )                 
399            STOP
400         ENDIF
401
402         ! Check if identical linear free surface option
403         IF ( ( Agrif_Parent(ln_linssh ).AND.(.NOT.ln_linssh )).OR.&
404            & ( (.NOT.Agrif_Parent(ln_linssh)).AND.ln_linssh ) ) THEN
405            WRITE(cl_check1,*)  Agrif_Parent(ln_linssh )
406            WRITE(cl_check2,*)  ln_linssh
407            CALL ctl_stop( 'Incompatible linearized fs option between grids',  &
408                  &               'parent grid ln_linssh  :'//cl_check1     ,  &
409                  &               'child  grid ln_linssh  :'//cl_check2     ,  &
410                  &               'those logicals should be identical' )                 
411            STOP
412         ENDIF
413      ENDIF
414
415   END SUBROUTINE Agrif_InitValues_cont
416
417   SUBROUTINE agrif_declare_var
418      !!----------------------------------------------------------------------
419      !!                 *** ROUTINE agrif_declare_var ***
420      !!----------------------------------------------------------------------
421      USE agrif_util
422      USE agrif_oce
423      USE par_oce
424      USE zdf_oce 
425      USE oce
426      !
427      IMPLICIT NONE
428      !
429      INTEGER :: ind1, ind2, ind3, imaxrho
430      !!----------------------------------------------------------------------
431
432      ! 1. Declaration of the type of variable which have to be interpolated
433      !---------------------------------------------------------------------
434      ind1 =              nbghostcells
435      ind2 = nn_hls + 1 + nbghostcells_x
436      ind3 = nn_hls + 1 + nbghostcells_y_s
437      imaxrho = MAX(Agrif_irhox(), Agrif_irhoy())
438
439      CALL agrif_declare_variable((/2,2,0,0/),(/ind2,ind3,0,0/)  ,(/'x','y','N','N'/),(/1,1,1,1/),(/jpi,jpj,jpk,jpts+1/),ts_interp_id)
440      CALL agrif_declare_variable((/2,2,0,0/),(/ind2,ind3,0,0/)  ,(/'x','y','N','N'/),(/1,1,1,1/),(/jpi,jpj,jpk,jpts+1/),ts_update_id)
441      CALL agrif_declare_variable((/2,2,0,0/),(/ind2,ind3,0,0/)  ,(/'x','y','N','N'/),(/1,1,1,1/),(/jpi,jpj,jpk,jpts+1/),ts_sponge_id)
442      CALL agrif_declare_variable((/1,2,0,0/),(/ind2-1,ind3,0,0/),(/'x','y','N','N'/),(/1,1,1,1/),(/jpi,jpj,jpk,2/),un_interp_id)
443      CALL agrif_declare_variable((/2,1,0,0/),(/ind2,ind3-1,0,0/),(/'x','y','N','N'/),(/1,1,1,1/),(/jpi,jpj,jpk,2/),vn_interp_id)
444      CALL agrif_declare_variable((/1,2,0,0/),(/ind2-1,ind3,0,0/),(/'x','y','N','N'/),(/1,1,1,1/),(/jpi,jpj,jpk,2/),un_update_id)
445      CALL agrif_declare_variable((/2,1,0,0/),(/ind2,ind3-1,0,0/),(/'x','y','N','N'/),(/1,1,1,1/),(/jpi,jpj,jpk,2/),vn_update_id)
446      CALL agrif_declare_variable((/1,2,0,0/),(/ind2-1,ind3,0,0/),(/'x','y','N','N'/),(/1,1,1,1/),(/jpi,jpj,jpk,2/),un_sponge_id)
447      CALL agrif_declare_variable((/2,1,0,0/),(/ind2,ind3-1,0,0/),(/'x','y','N','N'/),(/1,1,1,1/),(/jpi,jpj,jpk,2/),vn_sponge_id)
448
449      CALL agrif_declare_variable((/2,2/),(/ind2,ind3/),(/'x','y'/),(/1,1/),(/jpi,jpj/)  ,sshn_id)
450      CALL agrif_declare_variable((/1,2/),(/ind2-1,ind3/),(/'x','y'/),(/1,1/),(/jpi,jpj/), unb_interp_id)
451      CALL agrif_declare_variable((/2,1/),(/ind2,ind3-1/),(/'x','y'/),(/1,1/),(/jpi,jpj/), vnb_interp_id)
452      CALL agrif_declare_variable((/1,2/),(/ind2-1,ind3/),(/'x','y'/),(/1,1/),(/jpi,jpj/),ub2b_interp_id)
453      CALL agrif_declare_variable((/2,1/),(/ind2,ind3-1/),(/'x','y'/),(/1,1/),(/jpi,jpj/),vb2b_interp_id)
454      CALL agrif_declare_variable((/1,2/),(/ind2-1,ind3/),(/'x','y'/),(/1,1/),(/jpi,jpj/), unb_sponge_id)
455      CALL agrif_declare_variable((/2,1/),(/ind2,ind3-1/),(/'x','y'/),(/1,1/),(/jpi,jpj/), vnb_sponge_id)
456      CALL agrif_declare_variable((/1,2/),(/ind2-1,ind3/),(/'x','y'/),(/1,1/),(/jpi,jpj/),ub2b_update_id)
457      CALL agrif_declare_variable((/2,1/),(/ind2,ind3-1/),(/'x','y'/),(/1,1/),(/jpi,jpj/),vb2b_update_id)
458      CALL agrif_declare_variable((/1,2/),(/ind2-1,ind3/),(/'x','y'/),(/1,1/),(/jpi,jpj/), unb_update_id)
459      CALL agrif_declare_variable((/2,1/),(/ind2,ind3-1/),(/'x','y'/),(/1,1/),(/jpi,jpj/), vnb_update_id)
460      CALL agrif_declare_variable((/2,2/),(/ind2,ind3/),(/'x','y'/),(/1,1/),(/jpi,jpj/)  ,ub2b_cor_id)
461      CALL agrif_declare_variable((/2,2/),(/ind2,ind3/),(/'x','y'/),(/1,1/),(/jpi,jpj/)  ,vb2b_cor_id)
462!      CALL agrif_declare_variable((/2,2/),(/ind2,ind3/),(/'x','y'/),(/1,1/),(/jpi,jpj/),glamt_id)
463!      CALL agrif_declare_variable((/2,2/),(/ind2,ind3/),(/'x','y'/),(/1,1/),(/jpi,jpj/),gphit_id)
464
465
466      IF( ln_zdftke.OR.ln_zdfgls ) THEN  ! logical not known at this point
467!         CALL agrif_declare_variable((/2,2,0/),(/ind3,ind3,0/),(/'x','y','N'/),(/1,1,1/),(/jpi,jpj,jpk/), en_id)
468!         CALL agrif_declare_variable((/2,2,0/),(/ind3,ind3,0/),(/'x','y','N'/),(/1,1,1/),(/jpi,jpj,jpk/),avt_id)
469         CALL agrif_declare_variable((/2,2,0,0/),(/ind2,ind3,0,0/),(/'x','y','N','N'/),(/1,1,1,1/),(/jpi,jpj,jpk,2/),avm_id)
470      ENDIF
471     
472      ! 2. Type of interpolation
473      !-------------------------
474      CALL Agrif_Set_bcinterp( ts_interp_id,interp =AGRIF_linear)
475      CALL Agrif_Set_bcinterp( ts_sponge_id,interp =AGRIF_linear)
476
477#if defined DIV_CONS
478      lk_tint2d_notinterp = .TRUE.
479      CALL Agrif_Set_bcinterp(sshn_id,interp=AGRIF_constant)
480      CALL Agrif_Set_bcinterp(ub2b_cor_id,interp=AGRIF_constant)
481      CALL Agrif_Set_bcinterp(vb2b_cor_id,interp=AGRIF_constant)
482      CALL Agrif_Set_bcinterp(ub2b_interp_id,interp1=Agrif_linear,interp2=AGRIF_linearconserv)
483      CALL Agrif_Set_bcinterp(vb2b_interp_id,interp1=AGRIF_linearconserv,interp2=Agrif_linear)
484#else
485      lk_tint2d_notinterp = .FALSE.
486      CALL Agrif_Set_bcinterp(sshn_id,interp =AGRIF_linear)
487      CALL Agrif_Set_bcinterp(ub2b_interp_id,interp1=Agrif_linear,interp2=AGRIF_ppm) 
488      CALL Agrif_Set_bcinterp(vb2b_interp_id,interp1=AGRIF_ppm,interp2=Agrif_linear)
489#endif
490
491      CALL Agrif_Set_bcinterp(unb_interp_id,interp1=Agrif_linear,interp2=AGRIF_ppm   )
492      CALL Agrif_Set_bcinterp(vnb_interp_id,interp1=AGRIF_ppm   ,interp2=Agrif_linear)
493      CALL Agrif_Set_bcinterp(unb_sponge_id,interp1=Agrif_linear,interp2=AGRIF_ppm   )
494      CALL Agrif_Set_bcinterp(vnb_sponge_id,interp1=AGRIF_ppm   ,interp2=Agrif_linear)
495
496      CALL Agrif_Set_bcinterp(un_interp_id,interp1=Agrif_linear,interp2=AGRIF_ppm   )
497      CALL Agrif_Set_bcinterp(vn_interp_id,interp1=AGRIF_ppm   ,interp2=Agrif_linear)
498
499      CALL Agrif_Set_bcinterp(un_sponge_id,interp1=Agrif_linear,interp2=AGRIF_ppm   )
500      CALL Agrif_Set_bcinterp(vn_sponge_id,interp1=AGRIF_ppm   ,interp2=Agrif_linear)
501
502      IF( ln_zdftke.OR.ln_zdfgls )  CALL Agrif_Set_bcinterp( avm_id, interp=AGRIF_linear )
503   
504
505!      CALL Agrif_Set_bcinterp(gphit_id,interp=AGRIF_constant)
506!      CALL Agrif_Set_bcinterp(glamt_id,interp=AGRIF_constant)
507
508      ! 3. Location of interpolation
509      !-----------------------------
510      CALL Agrif_Set_bc(  ts_interp_id, (/0,ind1-1/) ) ! if west,  rhox=3 and nbghost=3: columns 2 to 4
511      CALL Agrif_Set_bc(  un_interp_id, (/0,ind1-1/) ) 
512      CALL Agrif_Set_bc(  vn_interp_id, (/0,ind1-1/) )
513
514      CALL Agrif_Set_bc(  ts_sponge_id, (/-nn_sponge_len*imaxrho-1,0/) )  ! if west,  rhox=3, nn_sponge_len=2
515      CALL Agrif_Set_bc(  un_sponge_id, (/-nn_sponge_len*imaxrho-1,0/) )  ! and nbghost=3:
516      CALL Agrif_Set_bc(  vn_sponge_id, (/-nn_sponge_len*imaxrho-1,0/) )  ! columns 4 to 11
517
518      CALL Agrif_Set_bc(       sshn_id, (/-imaxrho*nn_shift_bar,ind1-1/) )
519      CALL Agrif_Set_bc( unb_interp_id, (/-imaxrho*nn_shift_bar,ind1-1/) )
520      CALL Agrif_Set_bc( vnb_interp_id, (/-imaxrho*nn_shift_bar,ind1-1/) )
521      CALL Agrif_Set_bc(ub2b_interp_id, (/-imaxrho*nn_shift_bar,ind1-1/) )
522      CALL Agrif_Set_bc(vb2b_interp_id, (/-imaxrho*nn_shift_bar,ind1-1/) )
523      CALL Agrif_Set_bc( unb_sponge_id, (/-(nn_sponge_len+nn_shift_bar)*imaxrho,-imaxrho*nn_shift_bar/) )
524      CALL Agrif_Set_bc( vnb_sponge_id, (/-(nn_sponge_len+nn_shift_bar)*imaxrho,-imaxrho*nn_shift_bar/) )
525      CALL Agrif_Set_bc(   ub2b_cor_id, (/-imaxrho*nn_shift_bar,ind1/) )
526      CALL Agrif_Set_bc(   vb2b_cor_id, (/-imaxrho*nn_shift_bar,ind1/) )
527      IF( ln_zdftke.OR.ln_zdfgls ) CALL Agrif_Set_bc( avm_id, (/0,ind1-1/) )
528!!$      CALL Agrif_Set_bc(glamt_id, (/0,ind1-1/) ) 
529!!$      CALL Agrif_Set_bc(gphit_id, (/0,ind1-1/) ) 
530
531      ! 4. Update type
532      !---------------
533
534# if defined UPD_HIGH
535      CALL Agrif_Set_Updatetype(  ts_interp_id,update  = Agrif_Update_Full_Weighting)
536      CALL Agrif_Set_Updatetype(  un_update_id,update1 = Agrif_Update_Average       , update2 = Agrif_Update_Full_Weighting)
537      CALL Agrif_Set_Updatetype(  vn_update_id,update1 = Agrif_Update_Full_Weighting, update2 = Agrif_Update_Average       )
538
539      CALL Agrif_Set_Updatetype( unb_update_id,update1 = Agrif_Update_Average       , update2 = Agrif_Update_Full_Weighting) 
540      CALL Agrif_Set_Updatetype( vnb_update_id,update1 = Agrif_Update_Full_Weighting, update2 = Agrif_Update_Average       )
541      CALL Agrif_Set_Updatetype(ub2b_update_id,update1 = Agrif_Update_Average       , update2 = Agrif_Update_Full_Weighting)
542      CALL Agrif_Set_Updatetype(vb2b_update_id,update1 = Agrif_Update_Full_Weighting, update2 = Agrif_Update_Average       )
543      CALL Agrif_Set_Updatetype(       sshn_id,update  = Agrif_Update_Full_Weighting)
544      CALL Agrif_Set_Updatetype(        e3t_id,update  = Agrif_Update_Full_Weighting)
545
546  !    IF( ln_zdftke.OR.ln_zdfgls ) THEN
547!         CALL Agrif_Set_Updatetype( en_id, update = AGRIF_Update_Full_Weighting)
548!         CALL Agrif_Set_Updatetype(avt_id, update = AGRIF_Update_Full_Weighting)
549!         CALL Agrif_Set_Updatetype(avm_id, update = AGRIF_Update_Full_Weighting)
550   !   ENDIF
551
552#else
553      CALL Agrif_Set_Updatetype(  ts_update_id,update  = AGRIF_Update_Average)
554      CALL Agrif_Set_Updatetype(  un_update_id,update1 = Agrif_Update_Copy   , update2 = Agrif_Update_Average)
555      CALL Agrif_Set_Updatetype(  vn_update_id,update1 = Agrif_Update_Average, update2 = Agrif_Update_Copy   )
556
557      CALL Agrif_Set_Updatetype( unb_update_id,update1 = Agrif_Update_Copy   , update2 = Agrif_Update_Average)
558      CALL Agrif_Set_Updatetype( vnb_update_id,update1 = Agrif_Update_Average, update2 = Agrif_Update_Copy   )
559      CALL Agrif_Set_Updatetype(ub2b_update_id,update1 = Agrif_Update_Copy   , update2 = Agrif_Update_Average)
560      CALL Agrif_Set_Updatetype(vb2b_update_id,update1 = Agrif_Update_Average, update2 = Agrif_Update_Copy   )
561      CALL Agrif_Set_Updatetype(       sshn_id,update  = AGRIF_Update_Average)
562      CALL Agrif_Set_Updatetype(        e3t_id,update  = AGRIF_Update_Average)
563
564 !     IF( ln_zdftke.OR.ln_zdfgls ) THEN
565!         CALL Agrif_Set_Updatetype( en_id, update = AGRIF_Update_Average)
566!         CALL Agrif_Set_Updatetype(avt_id, update = AGRIF_Update_Average)
567!         CALL Agrif_Set_Updatetype(avm_id, update = AGRIF_Update_Average)
568 !     ENDIF
569
570#endif
571      !
572   END SUBROUTINE agrif_declare_var
573
574#if defined key_si3
575   SUBROUTINE Agrif_InitValues_cont_ice
576      !!----------------------------------------------------------------------
577      !!                 *** ROUTINE Agrif_InitValues_cont_ice ***
578      !!----------------------------------------------------------------------
579      USE Agrif_Util
580      USE sbc_oce, ONLY : nn_fsbc  ! clem: necessary otherwise Agrif_Parent(nn_fsbc) = nn_fsbc
581      USE ice
582      USE agrif_ice
583      USE in_out_manager
584      USE agrif_ice_interp
585      USE lib_mpp
586      !
587      IMPLICIT NONE
588      !
589      !!----------------------------------------------------------------------
590      ! Controls
591
592      ! clem: For some reason, nn_fsbc(child)/=1 does not work properly (signal can be largely degraded by the agrif zoom)
593      !          the run must satisfy CFL=Uice/(dx/dt) < 0.6/nn_fsbc(child)
594      !          therefore, if nn_fsbc(child)>1 one must reduce the time-step in proportion to nn_fsbc(child), which is not acceptable
595      !       If a solution is found, the following stop could be removed because the rest of the code take nn_fsbc(child) into account     
596      IF( nn_fsbc > 1 )  CALL ctl_stop('nn_fsbc(child) must be set to 1 otherwise agrif and sea-ice may not work properly')
597
598      ! stop if rhot * nn_fsbc(parent) /= N * nn_fsbc(child) with N being integer
599      IF( MOD( Agrif_irhot() * Agrif_Parent(nn_fsbc), nn_fsbc ) /= 0 )  THEN
600         CALL ctl_stop('rhot * nn_fsbc(parent) /= N * nn_fsbc(child), therefore nn_fsbc(child) should be set to 1 or nn_fsbc(parent)')
601      ENDIF
602      ! First Interpolations (using "after" ice subtime step => nbstep_ice=1)
603      !----------------------------------------------------------------------
604      nbstep_ice = ( Agrif_irhot() * Agrif_Parent(nn_fsbc) / nn_fsbc ) ! clem: to have calledweight=1 in interp (otherwise the western border of the zoom is wrong)
605      CALL agrif_interp_ice('U') ! interpolation of ice velocities
606      CALL agrif_interp_ice('V') ! interpolation of ice velocities
607      CALL agrif_interp_ice('T') ! interpolation of ice tracers
608      nbstep_ice = 0   
609      !
610   END SUBROUTINE Agrif_InitValues_cont_ice
611
612   
613   SUBROUTINE agrif_declare_var_ice
614      !!----------------------------------------------------------------------
615      !!                 *** ROUTINE agrif_declare_var_ice ***
616      !!----------------------------------------------------------------------
617      USE Agrif_Util
618      USE ice
619      USE par_oce, ONLY : nbghostcells, nbghostcells_x, nbghostcells_y_s
620      !
621      IMPLICIT NONE
622      !
623      INTEGER :: ind1, ind2, ind3
624      INTEGER :: ipl
625      !!----------------------------------------------------------------------
626      !
627      ! 1. Declaration of the type of variable which have to be interpolated (parent=>child)
628      !       agrif_declare_variable(position,1st point index,--,--,dimensions,name)
629      !           ex.:  position=> 1,1 = not-centered (in i and j)
630      !                            2,2 =     centered (    -     )
631      !                 index   => 1,1 = one ghost line
632      !                            2,2 = two ghost lines
633      !-------------------------------------------------------------------------------------
634      ind1 =              nbghostcells
635      ind2 = nn_hls + 1 + nbghostcells_x
636      ind3 = nn_hls + 1 + nbghostcells_y_s
637      ipl = jpl*(9+nlay_s+nlay_i)
638      CALL agrif_declare_variable((/2,2,0/),(/ind2,ind3,0/),(/'x','y','N'/),(/1,1,1/),(/jpi,jpj,ipl/),tra_ice_id)
639      CALL agrif_declare_variable((/1,2/)  ,(/ind2-1,ind3/),(/'x','y'    /),(/1,1  /),(/jpi,jpj    /),  u_ice_id)
640      CALL agrif_declare_variable((/2,1/)  ,(/ind2,ind3-1/),(/'x','y'    /),(/1,1  /),(/jpi,jpj    /),  v_ice_id)
641
642      CALL agrif_declare_variable((/2,2,0/),(/ind3,ind3,0/),(/'x','y','N'/),(/1,1,1/),(/jpi,jpj,ipl/),tra_iceini_id)
643      CALL agrif_declare_variable((/1,2/)  ,(/ind2-1,ind3/),(/'x','y'    /),(/1,1  /),(/jpi,jpj    /),  u_iceini_id)
644      CALL agrif_declare_variable((/2,1/)  ,(/ind2,ind3-1/),(/'x','y'    /),(/1,1  /),(/jpi,jpj    /),  v_iceini_id)
645
646      ! 2. Set interpolations (normal & tangent to the grid cell for velocities)
647      !-----------------------------------
648      CALL Agrif_Set_bcinterp(tra_ice_id, interp  = AGRIF_linear)
649      CALL Agrif_Set_bcinterp(u_ice_id  , interp1 = Agrif_linear,interp2 = AGRIF_ppm   )
650      CALL Agrif_Set_bcinterp(v_ice_id  , interp1 = AGRIF_ppm   ,interp2 = Agrif_linear)
651
652      CALL Agrif_Set_bcinterp(tra_iceini_id, interp  = AGRIF_linear)
653      CALL Agrif_Set_interp  (tra_iceini_id, interp  = AGRIF_linear)
654      CALL Agrif_Set_bcinterp(u_iceini_id  , interp  = AGRIF_linear)
655      CALL Agrif_Set_interp  (u_iceini_id  , interp  = AGRIF_linear)
656      CALL Agrif_Set_bcinterp(v_iceini_id  , interp  = AGRIF_linear)
657      CALL Agrif_Set_interp  (v_iceini_id  , interp  = AGRIF_linear)
658
659      ! 3. Set location of interpolations
660      !----------------------------------
661      CALL Agrif_Set_bc(tra_ice_id,(/0,ind1/))
662      CALL Agrif_Set_bc(u_ice_id  ,(/0,ind1/))
663      CALL Agrif_Set_bc(v_ice_id  ,(/0,ind1/))
664
665      CALL Agrif_Set_bc(tra_iceini_id,(/0,ind1/))
666      CALL Agrif_Set_bc(u_iceini_id  ,(/0,ind1/))
667      CALL Agrif_Set_bc(v_iceini_id  ,(/0,ind1/))
668
669      ! 4. Set update type in case 2 ways (child=>parent) (normal & tangent to the grid cell for velocities)
670      !--------------------------------------------------
671# if defined UPD_HIGH
672      CALL Agrif_Set_Updatetype(tra_ice_id, update  = Agrif_Update_Full_Weighting)
673      CALL Agrif_Set_Updatetype(u_ice_id  , update1 = Agrif_Update_Average       , update2 = Agrif_Update_Full_Weighting)
674      CALL Agrif_Set_Updatetype(v_ice_id  , update1 = Agrif_Update_Full_Weighting, update2 = Agrif_Update_Average       )
675# else
676      CALL Agrif_Set_Updatetype(tra_ice_id, update  = AGRIF_Update_Average)
677      CALL Agrif_Set_Updatetype(u_ice_id  , update1 = Agrif_Update_Copy   , update2 = Agrif_Update_Average)
678      CALL Agrif_Set_Updatetype(v_ice_id  , update1 = Agrif_Update_Average, update2 = Agrif_Update_Copy   )
679# endif
680
681   END SUBROUTINE agrif_declare_var_ice
682#endif
683
684
685# if defined key_top
686   SUBROUTINE Agrif_InitValues_cont_top
687      !!----------------------------------------------------------------------
688      !!                 *** ROUTINE Agrif_InitValues_cont_top ***
689      !!----------------------------------------------------------------------
690      USE Agrif_Util
691      USE oce 
692      USE dom_oce
693      USE nemogcm
694      USE par_trc
695      USE lib_mpp
696      USE trc
697      USE in_out_manager
698      USE agrif_oce_sponge
699      USE agrif_top_update
700      USE agrif_top_interp
701      USE agrif_top_sponge
702      !
703      IMPLICIT NONE
704      !
705      CHARACTER(len=10) :: cl_check1, cl_check2, cl_check3
706      LOGICAL :: check_namelist
707      !!----------------------------------------------------------------------
708
709      ! 1. Declaration of the type of variable which have to be interpolated
710      !---------------------------------------------------------------------
711      CALL agrif_declare_var_top
712
713      ! 2. First interpolations of potentially non zero fields
714      !-------------------------------------------------------
715      Agrif_SpecialValue=0._wp
716      Agrif_UseSpecialValue = .TRUE.
717      CALL Agrif_Bc_variable(trn_id,calledweight=1.,procname=interptrn)
718      Agrif_UseSpecialValue = .FALSE.
719      CALL Agrif_Sponge
720      tabspongedone_trn = .FALSE.
721      CALL Agrif_Bc_variable(trn_sponge_id,calledweight=1.,procname=interptrn_sponge)
722      ! reset tsa to zero
723      tr(:,:,:,:,Krhs_a) = 0._wp
724
725      ! 3. Some controls
726      !-----------------
727      check_namelist = .TRUE.
728
729      IF( check_namelist ) THEN
730         ! Check time steps
731         IF( NINT(Agrif_Rhot()) * NINT(rdt) .NE. Agrif_Parent(rdt) ) THEN
732            WRITE(cl_check1,*)  Agrif_Parent(rdt)
733            WRITE(cl_check2,*)  rdt
734            WRITE(cl_check3,*)  rdt*Agrif_Rhot()
735            CALL ctl_stop( 'incompatible time step between grids',   &
736               &               'parent grid value : '//cl_check1    ,   & 
737               &               'child  grid value : '//cl_check2    ,   & 
738               &               'value on child grid should be changed to  &
739               &               :'//cl_check3  )
740         ENDIF
741
742         ! Check run length
743         IF( Agrif_IRhot() * (Agrif_Parent(nitend)- &
744            Agrif_Parent(nit000)+1) .NE. (nitend-nit000+1) ) THEN
745            WRITE(cl_check1,*)  (Agrif_Parent(nit000)-1)*Agrif_IRhot() + 1
746            WRITE(cl_check2,*)   Agrif_Parent(nitend)   *Agrif_IRhot()
747            CALL ctl_warn( 'incompatible run length between grids'               ,   &
748               &              ' nit000 on fine grid will be change to : '//cl_check1,   &
749               &              ' nitend on fine grid will be change to : '//cl_check2    )
750            nit000 = (Agrif_Parent(nit000)-1)*Agrif_IRhot() + 1
751            nitend =  Agrif_Parent(nitend)   *Agrif_IRhot()
752         ENDIF
753      ENDIF
754      !
755   END SUBROUTINE Agrif_InitValues_cont_top
756
757
758   SUBROUTINE agrif_declare_var_top
759      !!----------------------------------------------------------------------
760      !!                 *** ROUTINE agrif_declare_var_top ***
761      !!----------------------------------------------------------------------
762      USE agrif_util
763      USE agrif_oce
764      USE dom_oce
765      USE trc
766      !!
767      IMPLICIT NONE
768      !
769      INTEGER :: ind1, ind2, ind3, imaxrho
770      !!----------------------------------------------------------------------
771!RB_CMEMS : declare here init for top     
772      ! 1. Declaration of the type of variable which have to be interpolated
773      !---------------------------------------------------------------------
774      ind1 =              nbghostcells
775      ind2 = nn_hls + 1 + nbghostcells_x
776      ind3 = nn_hls + 1 + nbghostcells_y_s
777      imaxrho = MAX(Agrif_irhox(), Agrif_irhoy())
778
779      CALL agrif_declare_variable((/2,2,0,0/),(/ind2,ind3,0,0/),(/'x','y','N','N'/),(/1,1,1,1/),(/jpi,jpj,jpk,jptra+1/),trn_id)
780      CALL agrif_declare_variable((/2,2,0,0/),(/ind2,ind3,0,0/),(/'x','y','N','N'/),(/1,1,1,1/),(/jpi,jpj,jpk,jptra+1/),trn_sponge_id)
781
782      ! 2. Type of interpolation
783      !-------------------------
784      CALL Agrif_Set_bcinterp(trn_id,interp=AGRIF_linear)
785      CALL Agrif_Set_bcinterp(trn_sponge_id,interp=AGRIF_linear)
786
787      ! 3. Location of interpolation
788      !-----------------------------
789      CALL Agrif_Set_bc(trn_id,(/0,ind1-1/))
790      CALL Agrif_Set_bc(trn_sponge_id,(/-nn_sponge_len*imaxrho-1,0/))
791
792      ! 4. Update type
793      !---------------
794# if defined UPD_HIGH
795      CALL Agrif_Set_Updatetype(trn_id, update = Agrif_Update_Full_Weighting)
796#else
797      CALL Agrif_Set_Updatetype(trn_id, update = AGRIF_Update_Average)
798#endif
799   !
800   END SUBROUTINE agrif_declare_var_top
801# endif
802   
803
804   SUBROUTINE Agrif_detect( kg, ksizex )
805      !!----------------------------------------------------------------------
806      !!                      *** ROUTINE Agrif_detect ***
807      !!----------------------------------------------------------------------
808      INTEGER, DIMENSION(2) :: ksizex
809      INTEGER, DIMENSION(ksizex(1),ksizex(2)) :: kg 
810      !!----------------------------------------------------------------------
811      !
812      RETURN
813      !
814   END SUBROUTINE Agrif_detect
815
816   
817   SUBROUTINE agrif_nemo_init
818      !!----------------------------------------------------------------------
819      !!                     *** ROUTINE agrif_init ***
820      !!----------------------------------------------------------------------
821      USE agrif_oce 
822      USE agrif_ice
823      USE dom_oce
824      USE in_out_manager
825      USE lib_mpp
826      !
827      IMPLICIT NONE
828      !
829      INTEGER  ::   ios                 ! Local integer output status for namelist read
830      NAMELIST/namagrif/ ln_agrif_2way, ln_init_chfrpar, rn_sponge_tra, rn_sponge_dyn, rn_trelax_tra, rn_trelax_dyn, &
831                       & ln_spc_dyn, ln_vert_remap, ln_chk_bathy
832      !!--------------------------------------------------------------------------------------
833      !
834      READ  ( numnam_ref, namagrif, IOSTAT = ios, ERR = 901)
835901 IF( ios /= 0 )   CALL ctl_nam ( ios , 'namagrif in reference namelist' )
836      READ  ( numnam_cfg, namagrif, IOSTAT = ios, ERR = 902 )
837902 IF( ios >  0 )   CALL ctl_nam ( ios , 'namagrif in configuration namelist' )
838      IF(lwm) WRITE ( numond, namagrif )
839      !
840      IF(lwp) THEN                    ! control print
841         WRITE(numout,*)
842         WRITE(numout,*) 'agrif_nemo_init : AGRIF parameters'
843         WRITE(numout,*) '~~~~~~~~~~~~~~~'
844         WRITE(numout,*) '   Namelist namagrif : set AGRIF parameters'
845         WRITE(numout,*) '      Two way nesting activated ln_agrif_2way         = ', ln_agrif_2way
846         WRITE(numout,*) '      child initial state from parent ln_init_chfrpar = ', ln_init_chfrpar
847         WRITE(numout,*) '      ad. sponge coeft for tracers      rn_sponge_tra = ', rn_sponge_tra
848         WRITE(numout,*) '      ad. sponge coeft for dynamics     rn_sponge_tra = ', rn_sponge_dyn
849         WRITE(numout,*) '      ad. time relaxation for tracers   rn_trelax_tra = ', rn_trelax_tra
850         WRITE(numout,*) '      ad. time relaxation for dynamics  rn_trelax_dyn = ', rn_trelax_dyn
851         WRITE(numout,*) '      use special values for dynamics   ln_spc_dyn    = ', ln_spc_dyn
852         WRITE(numout,*) '      vertical remapping                ln_vert_remap = ', ln_vert_remap
853         WRITE(numout,*) '      check bathymetry                  ln_chk_bathy  = ', ln_chk_bathy
854      ENDIF
855
856! JC => side effects of lines below to be checked:
857      IF (.not.agrif_root()) THEN
858         nbghostcells_x   = nbghostcells
859         nbghostcells_y_s = nbghostcells
860         nbghostcells_y_n = nbghostcells
861 
862
863         lk_west  = .TRUE.
864         lk_east  = .TRUE.
865         lk_south = .TRUE.
866         lk_north = .TRUE.
867         !
868         ! Correct number of ghost cells according to periodicity
869         !
870         IF( l_Iperio         ) THEN ; lk_west  = .FALSE. ; lk_east = .FALSE. ; nbghostcells_x = 0 ; ENDIF
871         IF( Agrif_Iy() == 1  ) THEN ; lk_south = .FALSE. ; nbghostcells_y_s = 1 ; ENDIF
872         IF( Agrif_Iy() + nbcellsy/AGRIF_Irhoy() ==  Agrif_Parent(Nj0glo) - 1 ) THEN ; lk_north = .FALSE. ; nbghostcells_y_n = 1 ; ENDIF
873         !
874         ! Some checks
875         IF( (.NOT.ln_vert_remap).AND.(jpkglo>Agrif_Parent(jpkglo)) )                    CALL ctl_stop( 'STOP',    &
876           &   'agrif_nemo_init: Agrif children must have less or equal number of vertical levels without ln_vert_remap defined' ) 
877         IF( Ni0glo /= nbcellsx + nbghostcells_x + nbghostcells_x   )   CALL ctl_stop( 'STOP',    &
878           &   'agrif_nemo_init: Agrif children requires jpiglo == nbcellsx + 2*nbghostcells_x' )
879         IF( Nj0glo /= nbcellsy + nbghostcells_y_s + nbghostcells_y_n )   CALL ctl_stop( 'STOP',    &
880           &   'agrif_nemo_init: Agrif children requires jpjglo == nbcellsy + nbghostcells_y_s + nbghostcells_y_n' )
881         IF( ln_use_jattr )   CALL ctl_stop( 'STOP', 'agrif_nemo_init:Agrif children requires ln_use_jattr = .false. ' )
882      ELSE
883         ! Root grid
884         nbghostcells_x   = 1 
885         nbghostcells_y_s = 1 
886         nbghostcells_y_n = 1 
887         IF ( l_Iperio.OR.l_NFold ) THEN
888           nbghostcells_x = 0
889         ENDIF
890         IF ( l_NFold ) THEN
891           nbghostcells_y_n = 0 ! for completeness
892         ENDIF
893      ENDIF
894      !
895      !
896   END SUBROUTINE agrif_nemo_init
897
898   
899# if ! defined key_mpi_off
900   SUBROUTINE Agrif_InvLoc( indloc, nprocloc, i, indglob )
901      !!----------------------------------------------------------------------
902      !!                     *** ROUTINE Agrif_InvLoc ***
903      !!----------------------------------------------------------------------
904      USE dom_oce
905      !!
906      IMPLICIT NONE
907      !
908      INTEGER :: indglob, indloc, nprocloc, i
909      !!----------------------------------------------------------------------
910      !
911      SELECT CASE( i )
912      CASE(1)        ;   indglob = mig(indloc)
913      CASE(2)        ;   indglob = mjg(indloc)
914      CASE DEFAULT   ;   indglob = indloc
915      END SELECT
916      !
917   END SUBROUTINE Agrif_InvLoc
918
919   
920   SUBROUTINE Agrif_get_proc_info( imin, imax, jmin, jmax )
921      !!----------------------------------------------------------------------
922      !!                 *** ROUTINE Agrif_get_proc_info ***
923      !!----------------------------------------------------------------------
924      USE par_oce
925      !!
926      IMPLICIT NONE
927      !
928      INTEGER, INTENT(out) :: imin, imax
929      INTEGER, INTENT(out) :: jmin, jmax
930      !!----------------------------------------------------------------------
931      !
932      imin = mig( 1 )
933      jmin = mjg( 1 )
934      imax = mig(jpi)
935      jmax = mjg(jpj)
936      !
937   END SUBROUTINE Agrif_get_proc_info
938
939   
940   SUBROUTINE Agrif_estimate_parallel_cost(imin, imax,jmin, jmax, nbprocs, grid_cost)
941      !!----------------------------------------------------------------------
942      !!                 *** ROUTINE Agrif_estimate_parallel_cost ***
943      !!----------------------------------------------------------------------
944      USE par_oce
945      !!
946      IMPLICIT NONE
947      !
948      INTEGER,  INTENT(in)  :: imin, imax
949      INTEGER,  INTENT(in)  :: jmin, jmax
950      INTEGER,  INTENT(in)  :: nbprocs
951      REAL(wp), INTENT(out) :: grid_cost
952      !!----------------------------------------------------------------------
953      !
954      grid_cost = REAL(imax-imin+1,wp)*REAL(jmax-jmin+1,wp) / REAL(nbprocs,wp)
955      !
956   END SUBROUTINE Agrif_estimate_parallel_cost
957
958# endif
959
960   SUBROUTINE nemo_mapping(ndim,ptx,pty,bounds,bounds_chunks,correction_required,nb_chunks)
961      !!----------------------------------------------------------------------
962      !!                   *** ROUTINE Nemo_mapping ***
963      !!----------------------------------------------------------------------
964      USE dom_oce
965      !!
966      IMPLICIT NONE
967      !
968      INTEGER :: ndim
969      INTEGER :: ptx, pty
970      INTEGER, DIMENSION(ndim,2,2) :: bounds
971      INTEGER, DIMENSION(:,:,:,:), ALLOCATABLE :: bounds_chunks
972      LOGICAL, DIMENSION(:), ALLOCATABLE :: correction_required
973      INTEGER :: nb_chunks
974      !
975      INTEGER :: i
976
977      IF (agrif_debug_interp) THEN
978         DO i=1,ndim
979            WRITE(*,*) 'direction = ',i,bounds(i,1,2),bounds(i,2,2)
980         ENDDO
981      ENDIF
982
983      IF(( bounds(2,2,2) > jpjglo).AND. ( l_NFold )) THEN
984         IF( bounds(2,1,2) <=jpjglo) THEN
985            nb_chunks = 2
986            ALLOCATE(bounds_chunks(nb_chunks,ndim,2,2))
987            ALLOCATE(correction_required(nb_chunks))
988            DO i = 1,nb_chunks
989               bounds_chunks(i,:,:,:) = bounds
990            END DO
991       
992      ! FIRST CHUNCK (for j<=jpjglo)   
993
994      ! Original indices
995            bounds_chunks(1,1,1,1) = bounds(1,1,2)
996            bounds_chunks(1,1,2,1) = bounds(1,2,2)
997            bounds_chunks(1,2,1,1) = bounds(2,1,2)
998            bounds_chunks(1,2,2,1) = jpjglo
999
1000            bounds_chunks(1,1,1,2) = bounds(1,1,2)
1001            bounds_chunks(1,1,2,2) = bounds(1,2,2)
1002            bounds_chunks(1,2,1,2) = bounds(2,1,2)
1003            bounds_chunks(1,2,2,2) = jpjglo
1004
1005      ! Correction required or not
1006            correction_required(1)=.FALSE.
1007       
1008      ! SECOND CHUNCK (for j>jpjglo)
1009
1010      ! Original indices
1011            bounds_chunks(2,1,1,1) = bounds(1,1,2)
1012            bounds_chunks(2,1,2,1) = bounds(1,2,2)
1013            bounds_chunks(2,2,1,1) = jpjglo-2
1014            bounds_chunks(2,2,2,1) = bounds(2,2,2)
1015
1016      ! Where to find them
1017      ! We use the relation TAB(ji,jj)=TAB(jpiglo-ji+2,jpjglo-2-(jj-jpjglo))
1018
1019            IF( ptx == 2) THEN ! T, V points
1020               bounds_chunks(2,1,1,2) = jpiglo-bounds(1,2,2)+2
1021               bounds_chunks(2,1,2,2) = jpiglo-bounds(1,1,2)+2
1022            ELSE ! U, F points
1023               bounds_chunks(2,1,1,2) = jpiglo-bounds(1,2,2)+1
1024               bounds_chunks(2,1,2,2) = jpiglo-bounds(1,1,2)+1       
1025            ENDIF
1026
1027            IF( pty == 2) THEN ! T, U points
1028               bounds_chunks(2,2,1,2) = jpjglo-2-(bounds(2,2,2) -jpjglo)
1029               bounds_chunks(2,2,2,2) = jpjglo-2-(jpjglo-2      -jpjglo)
1030            ELSE ! V, F points
1031               bounds_chunks(2,2,1,2) = jpjglo-3-(bounds(2,2,2) -jpjglo)
1032               bounds_chunks(2,2,2,2) = jpjglo-3-(jpjglo-2      -jpjglo)
1033            ENDIF
1034      ! Correction required or not
1035            correction_required(2)=.TRUE.
1036
1037         ELSE
1038            nb_chunks = 1
1039            ALLOCATE(bounds_chunks(nb_chunks,ndim,2,2))
1040            ALLOCATE(correction_required(nb_chunks))
1041            DO i=1,nb_chunks
1042               bounds_chunks(i,:,:,:) = bounds
1043            END DO
1044
1045            bounds_chunks(1,1,1,1) = bounds(1,1,2)
1046            bounds_chunks(1,1,2,1) = bounds(1,2,2)
1047            bounds_chunks(1,2,1,1) = bounds(2,1,2)
1048            bounds_chunks(1,2,2,1) = bounds(2,2,2)
1049
1050            bounds_chunks(1,1,1,2) = jpiglo-bounds(1,2,2)+2
1051            bounds_chunks(1,1,2,2) = jpiglo-bounds(1,1,2)+2
1052
1053            bounds_chunks(1,2,1,2) = jpjglo-2-(bounds(2,2,2)-jpjglo)
1054            bounds_chunks(1,2,2,2) = jpjglo-2-(bounds(2,1,2)-jpjglo)
1055
1056            IF( ptx == 2) THEN ! T, V points
1057               bounds_chunks(1,1,1,2) = jpiglo-bounds(1,2,2)+2
1058               bounds_chunks(1,1,2,2) = jpiglo-bounds(1,1,2)+2
1059            ELSE ! U, F points
1060               bounds_chunks(1,1,1,2) = jpiglo-bounds(1,2,2)+1
1061               bounds_chunks(1,1,2,2) = jpiglo-bounds(1,1,2)+1       
1062            ENDIF
1063
1064            IF (pty == 2) THEN ! T, U points
1065               bounds_chunks(1,2,1,2) = jpjglo-2-(bounds(2,2,2) -jpjglo)
1066               bounds_chunks(1,2,2,2) = jpjglo-2-(bounds(2,1,2) -jpjglo)
1067            ELSE ! V, F points
1068               bounds_chunks(1,2,1,2) = jpjglo-3-(bounds(2,2,2) -jpjglo)
1069               bounds_chunks(1,2,2,2) = jpjglo-3-(bounds(2,1,2) -jpjglo)
1070            ENDIF
1071
1072            correction_required(1)=.TRUE.         
1073         ENDIF
1074
1075      ELSE IF ((bounds(1,1,2) < 1).AND.( l_Iperio )) THEN
1076         IF (bounds(1,2,2) > 0) THEN
1077            nb_chunks = 2
1078            ALLOCATE(correction_required(nb_chunks))
1079            correction_required=.FALSE.
1080            ALLOCATE(bounds_chunks(nb_chunks,ndim,2,2))
1081            DO i=1,nb_chunks
1082               bounds_chunks(i,:,:,:) = bounds
1083            END DO
1084             
1085            bounds_chunks(1,1,1,2) = bounds(1,1,2)+jpiglo-2
1086            bounds_chunks(1,1,2,2) = 1+jpiglo-2
1087         
1088            bounds_chunks(1,1,1,1) = bounds(1,1,2)
1089            bounds_chunks(1,1,2,1) = 1
1090       
1091            bounds_chunks(2,1,1,2) = 2
1092            bounds_chunks(2,1,2,2) = bounds(1,2,2)
1093         
1094            bounds_chunks(2,1,1,1) = 2
1095            bounds_chunks(2,1,2,1) = bounds(1,2,2)
1096
1097         ELSE
1098            nb_chunks = 1
1099            ALLOCATE(correction_required(nb_chunks))
1100            correction_required=.FALSE.
1101            ALLOCATE(bounds_chunks(nb_chunks,ndim,2,2))
1102            DO i=1,nb_chunks
1103               bounds_chunks(i,:,:,:) = bounds
1104            END DO   
1105            bounds_chunks(1,1,1,2) = bounds(1,1,2)+jpiglo-2
1106            bounds_chunks(1,1,2,2) = bounds(1,2,2)+jpiglo-2
1107         
1108            bounds_chunks(1,1,1,1) = bounds(1,1,2)
1109           bounds_chunks(1,1,2,1) = bounds(1,2,2)
1110         ENDIF
1111      ELSE
1112         nb_chunks=1 
1113         ALLOCATE(correction_required(nb_chunks))
1114         correction_required=.FALSE.
1115         ALLOCATE(bounds_chunks(nb_chunks,ndim,2,2))
1116         DO i=1,nb_chunks
1117            bounds_chunks(i,:,:,:) = bounds
1118         END DO
1119         bounds_chunks(1,1,1,2) = bounds(1,1,2)
1120         bounds_chunks(1,1,2,2) = bounds(1,2,2)
1121         bounds_chunks(1,2,1,2) = bounds(2,1,2)
1122         bounds_chunks(1,2,2,2) = bounds(2,2,2)
1123         
1124         bounds_chunks(1,1,1,1) = bounds(1,1,2)
1125         bounds_chunks(1,1,2,1) = bounds(1,2,2)
1126         bounds_chunks(1,2,1,1) = bounds(2,1,2)
1127         bounds_chunks(1,2,2,1) = bounds(2,2,2)             
1128      ENDIF
1129       
1130   END SUBROUTINE nemo_mapping
1131
1132   FUNCTION agrif_external_switch_index(ptx,pty,i1,isens)
1133
1134      USE dom_oce
1135      !
1136      IMPLICIT NONE
1137
1138      INTEGER :: ptx, pty, i1, isens
1139      INTEGER :: agrif_external_switch_index
1140      !!----------------------------------------------------------------------
1141
1142      IF( isens == 1 ) THEN
1143         IF( ptx == 2 ) THEN ! T, V points
1144            agrif_external_switch_index = jpiglo-i1+2
1145         ELSE ! U, F points
1146            agrif_external_switch_index = jpiglo-i1+1     
1147         ENDIF
1148      ELSE IF( isens ==2 ) THEN
1149         IF ( pty == 2 ) THEN ! T, U points
1150            agrif_external_switch_index = jpjglo-2-(i1 -jpjglo)
1151         ELSE ! V, F points
1152            agrif_external_switch_index = jpjglo-3-(i1 -jpjglo)
1153         ENDIF
1154      ENDIF
1155
1156   END FUNCTION agrif_external_switch_index
1157
1158   SUBROUTINE Correct_field(tab2d,i1,i2,j1,j2)
1159      !!----------------------------------------------------------------------
1160      !!                   *** ROUTINE Correct_field ***
1161      !!----------------------------------------------------------------------
1162      USE dom_oce
1163      USE agrif_oce
1164      !
1165      IMPLICIT NONE
1166      !
1167      INTEGER :: i1,i2,j1,j2
1168      REAL(wp), DIMENSION(i1:i2,j1:j2) :: tab2d
1169      !
1170      INTEGER :: i,j
1171      REAL(wp), DIMENSION(i1:i2,j1:j2) :: tab2dtemp
1172      !!----------------------------------------------------------------------
1173
1174      tab2dtemp = tab2d
1175
1176      IF( .NOT. use_sign_north ) THEN
1177         DO j=j1,j2
1178            DO i=i1,i2
1179               tab2d(i,j)=tab2dtemp(i2-(i-i1),j2-(j-j1))
1180            END DO
1181         END DO
1182      ELSE
1183         DO j=j1,j2
1184            DO i=i1,i2
1185               tab2d(i,j)=sign_north * tab2dtemp(i2-(i-i1),j2-(j-j1))
1186            END DO
1187         END DO
1188      ENDIF
1189
1190   END SUBROUTINE Correct_field
1191
1192#else
1193   SUBROUTINE Subcalledbyagrif
1194      !!----------------------------------------------------------------------
1195      !!                   *** ROUTINE Subcalledbyagrif ***
1196      !!----------------------------------------------------------------------
1197      WRITE(*,*) 'Impossible to be here'
1198   END SUBROUTINE Subcalledbyagrif
1199#endif
Note: See TracBrowser for help on using the repository browser.