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

Last change on this file since 13565 was 13565, checked in by jchanut, 5 months ago

#2222, 1) Added parent bathymetry volume consistency check 2) Added velocity extrapolation in update 3) Corrected bdy issue #2519

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