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/r12377_ticket2386/src/NST – NEMO

source: NEMO/branches/2020/r12377_ticket2386/src/NST/agrif_user.F90 @ 13694

Last change on this file since 13694 was 13694, checked in by andmirek, 3 years ago

Ticket #2386: merge with trunk rev 13688

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