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

Last change on this file since 13371 was 13371, checked in by jchanut, 7 months ago

#2222, remove constrain on jpk_parent ⇐ jpk_child with last library change

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