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 @ 13026

Last change on this file since 13026 was 13026, checked in by rblod, 3 years ago

AGRIF with northfold and perio, see ticket #2129

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