source: NEMO/branches/2020/dev_r12973_AGRIF_CMEMS/src/NST/agrif_user.F90 @ 13076

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

ticket #2129 : correct indexes in declaration in agrif_user

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