New URL for NEMO forge!   http://forge.nemo-ocean.eu

Since March 2022 along with NEMO 4.2 release, the code development moved to a self-hosted GitLab.
This present forge is now archived and remained online for history.
agrif_user.F90 in NEMO/branches/2020/dev_r12973_AGRIF_CMEMS/src/NST – NEMO

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

Last change on this file since 13147 was 13147, checked in by jchanut, 2 years ago

#2129, correct output print for agrif sponge parameters

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