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_opa_interp.F90 in branches/2013/dev_MERGE_2013/NEMOGCM/NEMO/NST_SRC – NEMO

source: branches/2013/dev_MERGE_2013/NEMOGCM/NEMO/NST_SRC/agrif_opa_interp.F90 @ 4291

Last change on this file since 4291 was 3294, checked in by rblod, 12 years ago

Merge of 3.4beta into the trunk
  • Property svn:keywords set to Id
File size: 19.6 KB
Line 
1MODULE agrif_opa_interp
2   !!======================================================================
3   !!                   ***  MODULE  agrif_opa_interp  ***
4   !! AGRIF: interpolation package
5   !!======================================================================
6   !! History :  2.0  !  2002-06  (XXX)  Original cade
7   !!             -   !  2005-11  (XXX)
8   !!            3.2  !  2009-04  (R. Benshila)
9   !!----------------------------------------------------------------------
10#if defined key_agrif && ! defined key_offline
11   !!----------------------------------------------------------------------
12   !!   'key_agrif'                                              AGRIF zoom
13   !!   NOT 'key_offline'                               NO off-line tracers
14   !!----------------------------------------------------------------------
15   !!   Agrif_tra     :
16   !!   Agrif_dyn     :
17   !!   interpu       :
18   !!   interpv       :
19   !!----------------------------------------------------------------------
20   USE par_oce
21   USE oce
22   USE dom_oce     
23   USE sol_oce
24   USE agrif_oce
25   USE phycst
26   USE in_out_manager
27   USE agrif_opa_sponge
28   USE lib_mpp
29   USE wrk_nemo 
30
31   IMPLICIT NONE
32   PRIVATE
33   
34   PUBLIC   Agrif_tra, Agrif_dyn, Agrif_ssh, interpu, interpv
35
36#  include "domzgr_substitute.h90" 
37#  include "vectopt_loop_substitute.h90"
38   !!----------------------------------------------------------------------
39   !! NEMO/NST 3.3 , NEMO Consortium (2010)
40   !! $Id$
41   !! Software governed by the CeCILL licence (NEMOGCM/NEMO_CeCILL.txt)
42   !!----------------------------------------------------------------------
43
44   CONTAINS
45   
46   SUBROUTINE Agrif_tra
47      !!----------------------------------------------------------------------
48      !!                  ***  ROUTINE Agrif_Tra  ***
49      !!----------------------------------------------------------------------
50      !!
51      INTEGER  ::   ji, jj, jk, jn   ! dummy loop indices
52      REAL(wp) ::   zrhox , alpha1, alpha2, alpha3
53      REAL(wp) ::   alpha4, alpha5, alpha6, alpha7
54      REAL(wp), POINTER, DIMENSION(:,:,:,:) :: ztsa
55      !!----------------------------------------------------------------------
56      !
57      IF( Agrif_Root() )   RETURN
58
59      CALL wrk_alloc( jpi, jpj, jpk, jpts, ztsa ) 
60
61      Agrif_SpecialValue    = 0.e0
62      Agrif_UseSpecialValue = .TRUE.
63      ztsa(:,:,:,:) = 0.e0
64
65      CALL Agrif_Bc_variable( ztsa, tsn_id, procname=interptsn )
66      Agrif_UseSpecialValue = .FALSE.
67
68      zrhox = Agrif_Rhox()
69
70      alpha1 = ( zrhox - 1. ) * 0.5
71      alpha2 = 1. - alpha1
72
73      alpha3 = ( zrhox - 1. ) / ( zrhox + 1. )
74      alpha4 = 1. - alpha3
75
76      alpha6 = 2. * ( zrhox - 1. ) / ( zrhox + 1. )
77      alpha7 =    - ( zrhox - 1. ) / ( zrhox + 3. )
78      alpha5 = 1. - alpha6 - alpha7
79
80      IF( nbondi == 1 .OR. nbondi == 2 ) THEN
81
82         DO jn = 1, jpts
83            tsa(nlci,:,:,jn) = alpha1 * ztsa(nlci,:,:,jn) + alpha2 * ztsa(nlci-1,:,:,jn)
84            DO jk = 1, jpkm1
85               DO jj = 1, jpj
86                  IF( umask(nlci-2,jj,jk) == 0.e0 ) THEN
87                     tsa(nlci-1,jj,jk,jn) = tsa(nlci,jj,jk,jn) * tmask(nlci-1,jj,jk)
88                  ELSE
89                     tsa(nlci-1,jj,jk,jn)=(alpha4*tsa(nlci,jj,jk,jn)+alpha3*tsa(nlci-2,jj,jk,jn))*tmask(nlci-1,jj,jk)
90                     IF( un(nlci-2,jj,jk) > 0.e0 ) THEN
91                        tsa(nlci-1,jj,jk,jn)=( alpha6*tsa(nlci-2,jj,jk,jn)+alpha5*tsa(nlci,jj,jk,jn)  &
92                           &                 + alpha7*tsa(nlci-3,jj,jk,jn) ) * tmask(nlci-1,jj,jk)
93                     ENDIF
94                  ENDIF
95               END DO
96            END DO
97         ENDDO
98      ENDIF
99
100      IF( nbondj == 1 .OR. nbondj == 2 ) THEN
101
102         DO jn = 1, jpts
103            tsa(:,nlcj,:,jn) = alpha1 * ztsa(:,nlcj,:,jn) + alpha2 * ztsa(:,nlcj-1,:,jn)
104            DO jk = 1, jpkm1
105               DO ji = 1, jpi
106                  IF( vmask(ji,nlcj-2,jk) == 0.e0 ) THEN
107                     tsa(ji,nlcj-1,jk,jn) = tsa(ji,nlcj,jk,jn) * tmask(ji,nlcj-1,jk)
108                  ELSE
109                     tsa(ji,nlcj-1,jk,jn)=(alpha4*tsa(ji,nlcj,jk,jn)+alpha3*tsa(ji,nlcj-2,jk,jn))*tmask(ji,nlcj-1,jk)       
110                     IF (vn(ji,nlcj-2,jk) > 0.e0 ) THEN
111                        tsa(ji,nlcj-1,jk,jn)=( alpha6*tsa(ji,nlcj-2,jk,jn)+alpha5*tsa(ji,nlcj,jk,jn)  &
112                           &                 + alpha7*tsa(ji,nlcj-3,jk,jn) ) * tmask(ji,nlcj-1,jk)
113                     ENDIF
114                  ENDIF
115               END DO
116            END DO
117         ENDDO 
118      ENDIF
119
120      IF( nbondi == -1 .OR. nbondi == 2 ) THEN
121         DO jn = 1, jpts
122            tsa(1,:,:,jn) = alpha1 * ztsa(1,:,:,jn) + alpha2 * ztsa(2,:,:,jn)
123            DO jk = 1, jpkm1
124               DO jj = 1, jpj
125                  IF( umask(2,jj,jk) == 0.e0 ) THEN
126                     tsa(2,jj,jk,jn) = tsa(1,jj,jk,jn) * tmask(2,jj,jk)
127                  ELSE
128                     tsa(2,jj,jk,jn)=(alpha4*tsa(1,jj,jk,jn)+alpha3*tsa(3,jj,jk,jn))*tmask(2,jj,jk)       
129                     IF( un(2,jj,jk) < 0.e0 ) THEN
130                        tsa(2,jj,jk,jn)=(alpha6*tsa(3,jj,jk,jn)+alpha5*tsa(1,jj,jk,jn)+alpha7*tsa(4,jj,jk,jn))*tmask(2,jj,jk)
131                     ENDIF
132                  ENDIF
133               END DO
134            END DO
135         END DO
136      ENDIF
137
138      IF( nbondj == -1 .OR. nbondj == 2 ) THEN
139         DO jn = 1, jpts
140            tsa(:,1,:,jn) = alpha1 * ztsa(:,1,:,jn) + alpha2 * ztsa(:,2,:,jn)
141            DO jk=1,jpk     
142               DO ji=1,jpi
143                  IF( vmask(ji,2,jk) == 0.e0 ) THEN
144                     tsa(ji,2,jk,jn)=tsa(ji,1,jk,jn) * tmask(ji,2,jk)
145                  ELSE
146                     tsa(ji,2,jk,jn)=(alpha4*tsa(ji,1,jk,jn)+alpha3*tsa(ji,3,jk,jn))*tmask(ji,2,jk)
147                     IF( vn(ji,2,jk) < 0.e0 ) THEN
148                        tsa(ji,2,jk,jn)=(alpha6*tsa(ji,3,jk,jn)+alpha5*tsa(ji,1,jk,jn)+alpha7*tsa(ji,4,jk,jn))*tmask(ji,2,jk)
149                     ENDIF
150                  ENDIF
151               END DO
152            END DO
153         ENDDO
154      ENDIF
155      !
156      CALL wrk_dealloc( jpi, jpj, jpk, jpts, ztsa ) 
157      !
158   END SUBROUTINE Agrif_tra
159
160
161   SUBROUTINE Agrif_dyn( kt )
162      !!----------------------------------------------------------------------
163      !!                  ***  ROUTINE Agrif_DYN  ***
164      !!---------------------------------------------------------------------- 
165      !!
166      INTEGER, INTENT(in) ::   kt
167      !!
168      INTEGER :: ji,jj,jk
169      REAL(wp) :: timeref
170      REAL(wp) :: z2dt, znugdt
171      REAL(wp) :: zrhox, rhoy
172      REAL(wp), POINTER, DIMENSION(:,:,:) :: zua, zva
173      REAL(wp), POINTER, DIMENSION(:,:) :: spgv1, spgu1, zua2d, zva2d
174      !!---------------------------------------------------------------------- 
175
176      IF( Agrif_Root() )   RETURN
177
178      CALL wrk_alloc( jpi, jpj, spgv1, spgu1, zua2d, zva2d )
179      CALL wrk_alloc( jpi, jpj, jpk, zua, zva )
180
181      zrhox = Agrif_Rhox()
182      rhoy = Agrif_Rhoy()
183
184      timeref = 1.
185
186      ! time step: leap-frog
187      z2dt = 2. * rdt
188      ! time step: Euler if restart from rest
189      IF( neuler == 0 .AND. kt == nit000 ) z2dt = rdt
190      ! coefficients
191      znugdt =  grav * z2dt   
192
193      Agrif_SpecialValue=0.
194      Agrif_UseSpecialValue = ln_spc_dyn
195
196      zua = 0.
197      zva = 0.
198      CALL Agrif_Bc_variable(zua,un_id,procname=interpu)
199      CALL Agrif_Bc_variable(zva,vn_id,procname=interpv)
200      zua2d = 0.
201      zva2d = 0.
202
203      Agrif_SpecialValue=0.
204      Agrif_UseSpecialValue = ln_spc_dyn
205      CALL Agrif_Bc_variable(zua2d,e1u_id,calledweight=1.,procname=interpu2d)
206      CALL Agrif_Bc_variable(zva2d,e2v_id,calledweight=1.,procname=interpv2d)
207      Agrif_UseSpecialValue = .FALSE.
208
209
210      IF((nbondi == -1).OR.(nbondi == 2)) THEN
211
212         DO jj=1,jpj
213            laplacu(2,jj) = timeref * (zua2d(2,jj)/(rhoy*e2u(2,jj)))*umask(2,jj,1)
214         END DO
215
216         DO jk=1,jpkm1
217            DO jj=1,jpj
218               ua(1:2,jj,jk) = (zua(1:2,jj,jk)/(rhoy*e2u(1:2,jj)))
219               ua(1:2,jj,jk) = ua(1:2,jj,jk) / fse3u(1:2,jj,jk)
220            END DO
221         END DO
222
223         DO jk=1,jpkm1
224            DO jj=1,jpj
225               ua(2,jj,jk) = (ua(2,jj,jk) - z2dt * znugdt * laplacu(2,jj))*umask(2,jj,jk)
226            END DO
227         END DO
228
229         spgu(2,:)=0.
230
231         DO jk=1,jpkm1
232            DO jj=1,jpj
233               spgu(2,jj)=spgu(2,jj)+fse3u(2,jj,jk)*ua(2,jj,jk)
234            END DO
235         END DO
236
237         DO jj=1,jpj
238            IF (umask(2,jj,1).NE.0.) THEN
239               spgu(2,jj)=spgu(2,jj)/hu(2,jj)
240            ENDIF
241         END DO
242
243         DO jk=1,jpkm1
244            DO jj=1,jpj
245               ua(2,jj,jk) = 0.25*(ua(1,jj,jk)+2.*ua(2,jj,jk)+ua(3,jj,jk))
246               ua(2,jj,jk) = ua(2,jj,jk) * umask(2,jj,jk)
247            END DO
248         END DO
249
250         spgu1(2,:)=0.
251
252         DO jk=1,jpkm1
253            DO jj=1,jpj
254               spgu1(2,jj)=spgu1(2,jj)+fse3u(2,jj,jk)*ua(2,jj,jk)
255            END DO
256         END DO
257
258         DO jj=1,jpj
259            IF (umask(2,jj,1).NE.0.) THEN
260               spgu1(2,jj)=spgu1(2,jj)/hu(2,jj)
261            ENDIF
262         END DO
263
264         DO jk=1,jpkm1
265            DO jj=1,jpj
266               ua(2,jj,jk) = (ua(2,jj,jk)+spgu(2,jj)-spgu1(2,jj))*umask(2,jj,jk)
267            END DO
268         END DO
269
270         DO jk=1,jpkm1
271            DO jj=1,jpj
272               va(2,jj,jk) = (zva(2,jj,jk)/(zrhox*e1v(2,jj)))*vmask(2,jj,jk)
273               va(2,jj,jk) = va(2,jj,jk) / fse3v(2,jj,jk)
274            END DO
275         END DO
276
277      ENDIF
278
279      IF((nbondi == 1).OR.(nbondi == 2)) THEN
280
281         DO jj=1,jpj
282            laplacu(nlci-2,jj) = timeref * (zua2d(nlci-2,jj)/(rhoy*e2u(nlci-2,jj)))
283         END DO
284
285         DO jk=1,jpkm1
286            DO jj=1,jpj
287               ua(nlci-2:nlci-1,jj,jk) = (zua(nlci-2:nlci-1,jj,jk)/(rhoy*e2u(nlci-2:nlci-1,jj)))
288
289               ua(nlci-2:nlci-1,jj,jk) = ua(nlci-2:nlci-1,jj,jk) / fse3u(nlci-2:nlci-1,jj,jk)
290
291            END DO
292         END DO
293
294         DO jk=1,jpkm1
295            DO jj=1,jpj
296               ua(nlci-2,jj,jk) = (ua(nlci-2,jj,jk)- z2dt * znugdt * laplacu(nlci-2,jj))*umask(nlci-2,jj,jk)
297            END DO
298         END DO
299
300
301         spgu(nlci-2,:)=0.
302
303         do jk=1,jpkm1
304            do jj=1,jpj
305               spgu(nlci-2,jj)=spgu(nlci-2,jj)+fse3u(nlci-2,jj,jk)*ua(nlci-2,jj,jk)
306            enddo
307         enddo
308
309         DO jj=1,jpj
310            IF (umask(nlci-2,jj,1).NE.0.) THEN
311               spgu(nlci-2,jj)=spgu(nlci-2,jj)/hu(nlci-2,jj)
312            ENDIF
313         END DO
314
315         DO jk=1,jpkm1
316            DO jj=1,jpj
317               ua(nlci-2,jj,jk) = 0.25*(ua(nlci-3,jj,jk)+2.*ua(nlci-2,jj,jk)+ua(nlci-1,jj,jk))
318
319               ua(nlci-2,jj,jk) = ua(nlci-2,jj,jk) * umask(nlci-2,jj,jk)
320
321            END DO
322         END DO
323
324         spgu1(nlci-2,:)=0.
325
326         DO jk=1,jpkm1
327            DO jj=1,jpj
328               spgu1(nlci-2,jj)=spgu1(nlci-2,jj)+fse3u(nlci-2,jj,jk)*ua(nlci-2,jj,jk)*umask(nlci-2,jj,jk)
329            END DO
330         END DO
331
332         DO jj=1,jpj
333            IF (umask(nlci-2,jj,1).NE.0.) THEN
334               spgu1(nlci-2,jj)=spgu1(nlci-2,jj)/hu(nlci-2,jj)
335            ENDIF
336         END DO
337
338         DO jk=1,jpkm1
339            DO jj=1,jpj
340               ua(nlci-2,jj,jk) = (ua(nlci-2,jj,jk)+spgu(nlci-2,jj)-spgu1(nlci-2,jj))*umask(nlci-2,jj,jk)
341            END DO
342         END DO
343
344         DO jk=1,jpkm1
345            DO jj=1,jpj-1
346               va(nlci-1,jj,jk) = (zva(nlci-1,jj,jk)/(zrhox*e1v(nlci-1,jj)))*vmask(nlci-1,jj,jk)
347               va(nlci-1,jj,jk) = va(nlci-1,jj,jk) / fse3v(nlci-1,jj,jk)
348            END DO
349         END DO
350
351      ENDIF
352
353      IF((nbondj == -1).OR.(nbondj == 2)) THEN
354
355         DO ji=1,jpi
356            laplacv(ji,2) = timeref * (zva2d(ji,2)/(zrhox*e1v(ji,2)))
357         END DO
358
359         DO jk=1,jpkm1
360            DO ji=1,jpi
361               va(ji,1:2,jk) = (zva(ji,1:2,jk)/(zrhox*e1v(ji,1:2)))
362               va(ji,1:2,jk) = va(ji,1:2,jk) / fse3v(ji,1:2,jk)
363            END DO
364         END DO
365
366         DO jk=1,jpkm1
367            DO ji=1,jpi
368               va(ji,2,jk) = (va(ji,2,jk) - z2dt * znugdt * laplacv(ji,2))*vmask(ji,2,jk)
369            END DO
370         END DO
371
372         spgv(:,2)=0.
373
374         DO jk=1,jpkm1
375            DO ji=1,jpi
376               spgv(ji,2)=spgv(ji,2)+fse3v(ji,2,jk)*va(ji,2,jk)
377            END DO
378         END DO
379
380         DO ji=1,jpi
381            IF (vmask(ji,2,1).NE.0.) THEN
382               spgv(ji,2)=spgv(ji,2)/hv(ji,2)
383            ENDIF
384         END DO
385
386         DO jk=1,jpkm1
387            DO ji=1,jpi
388               va(ji,2,jk)=0.25*(va(ji,1,jk)+2.*va(ji,2,jk)+va(ji,3,jk))
389               va(ji,2,jk)=va(ji,2,jk)*vmask(ji,2,jk)
390            END DO
391         END DO
392
393         spgv1(:,2)=0.
394
395         DO jk=1,jpkm1
396            DO ji=1,jpi
397               spgv1(ji,2)=spgv1(ji,2)+fse3v(ji,2,jk)*va(ji,2,jk)*vmask(ji,2,jk)
398            END DO
399         END DO
400
401         DO ji=1,jpi
402            IF (vmask(ji,2,1).NE.0.) THEN
403               spgv1(ji,2)=spgv1(ji,2)/hv(ji,2)
404            ENDIF
405         END DO
406
407         DO jk=1,jpkm1
408            DO ji=1,jpi
409               va(ji,2,jk) = (va(ji,2,jk)+spgv(ji,2)-spgv1(ji,2))*vmask(ji,2,jk)
410            END DO
411         END DO
412
413         DO jk=1,jpkm1
414            DO ji=1,jpi
415               ua(ji,2,jk) = (zua(ji,2,jk)/(rhoy*e2u(ji,2)))*umask(ji,2,jk) 
416               ua(ji,2,jk) = ua(ji,2,jk) / fse3u(ji,2,jk)
417            END DO
418         END DO
419
420      ENDIF
421
422      IF((nbondj == 1).OR.(nbondj == 2)) THEN
423
424         DO ji=1,jpi
425            laplacv(ji,nlcj-2) = timeref * (zva2d(ji,nlcj-2)/(zrhox*e1v(ji,nlcj-2)))
426         END DO
427
428         DO jk=1,jpkm1
429            DO ji=1,jpi
430               va(ji,nlcj-2:nlcj-1,jk) = (zva(ji,nlcj-2:nlcj-1,jk)/(zrhox*e1v(ji,nlcj-2:nlcj-1)))
431               va(ji,nlcj-2:nlcj-1,jk) = va(ji,nlcj-2:nlcj-1,jk) / fse3v(ji,nlcj-2:nlcj-1,jk)
432            END DO
433         END DO
434
435         DO jk=1,jpkm1
436            DO ji=1,jpi
437               va(ji,nlcj-2,jk) = (va(ji,nlcj-2,jk)-z2dt * znugdt * laplacv(ji,nlcj-2))*vmask(ji,nlcj-2,jk)
438            END DO
439         END DO
440
441
442         spgv(:,nlcj-2)=0.
443
444         DO jk=1,jpkm1
445            DO ji=1,jpi
446               spgv(ji,nlcj-2)=spgv(ji,nlcj-2)+fse3v(ji,nlcj-2,jk)*va(ji,nlcj-2,jk)
447            END DO
448         END DO
449
450         DO ji=1,jpi
451            IF (vmask(ji,nlcj-2,1).NE.0.) THEN
452               spgv(ji,nlcj-2)=spgv(ji,nlcj-2)/hv(ji,nlcj-2)
453            ENDIF
454         END DO
455
456         DO jk=1,jpkm1
457            DO ji=1,jpi
458               va(ji,nlcj-2,jk)=0.25*(va(ji,nlcj-3,jk)+2.*va(ji,nlcj-2,jk)+va(ji,nlcj-1,jk))
459               va(ji,nlcj-2,jk) = va(ji,nlcj-2,jk) * vmask(ji,nlcj-2,jk)
460            END DO
461         END DO
462
463         spgv1(:,nlcj-2)=0.
464
465         DO jk=1,jpkm1
466            DO ji=1,jpi
467               spgv1(ji,nlcj-2)=spgv1(ji,nlcj-2)+fse3v(ji,nlcj-2,jk)*va(ji,nlcj-2,jk)
468            END DO
469         END DO
470
471         DO ji=1,jpi
472            IF (vmask(ji,nlcj-2,1).NE.0.) THEN
473               spgv1(ji,nlcj-2)=spgv1(ji,nlcj-2)/hv(ji,nlcj-2)
474            ENDIF
475         END DO
476
477         DO jk=1,jpkm1
478            DO ji=1,jpi
479               va(ji,nlcj-2,jk) = (va(ji,nlcj-2,jk)+spgv(ji,nlcj-2)-spgv1(ji,nlcj-2))*vmask(ji,nlcj-2,jk)
480            END DO
481         END DO
482
483         DO jk=1,jpkm1
484            DO ji=1,jpi
485               ua(ji,nlcj-1,jk) = (zua(ji,nlcj-1,jk)/(rhoy*e2u(ji,nlcj-1)))*umask(ji,nlcj-1,jk)
486               ua(ji,nlcj-1,jk) = ua(ji,nlcj-1,jk) / fse3u(ji,nlcj-1,jk)
487            END DO
488         END DO
489
490      ENDIF
491      !
492      CALL wrk_dealloc( jpi, jpj, spgv1, spgu1, zua2d, zva2d )
493      CALL wrk_dealloc( jpi, jpj, jpk, zua, zva )
494      !
495   END SUBROUTINE Agrif_dyn
496
497
498   SUBROUTINE Agrif_ssh( kt )
499      !!----------------------------------------------------------------------
500      !!                  ***  ROUTINE Agrif_DYN  ***
501      !!---------------------------------------------------------------------- 
502      INTEGER, INTENT(in) ::   kt
503      !!
504      !!---------------------------------------------------------------------- 
505
506      IF( Agrif_Root() )   RETURN
507
508
509      IF((nbondi == -1).OR.(nbondi == 2)) THEN
510         ssha(2,:)=ssha(3,:)
511         sshn(2,:)=sshn(3,:)
512      ENDIF
513
514      IF((nbondi == 1).OR.(nbondi == 2)) THEN
515         ssha(nlci-1,:)=ssha(nlci-2,:)
516         sshn(nlci-1,:)=sshn(nlci-2,:)       
517      ENDIF
518
519      IF((nbondj == -1).OR.(nbondj == 2)) THEN
520         ssha(:,2)=sshn(:,3)
521         sshn(:,2)=sshb(:,3)
522      ENDIF
523
524      IF((nbondj == 1).OR.(nbondj == 2)) THEN
525         ssha(:,nlcj-1)=ssha(:,nlcj-2)
526         ssha(:,nlcj-1)=sshn(:,nlcj-2)               
527      ENDIF
528
529   END SUBROUTINE Agrif_ssh
530
531
532   SUBROUTINE interpu(tabres,i1,i2,j1,j2,k1,k2)
533      !!----------------------------------------------------------------------
534      !!                  ***  ROUTINE interpu  ***
535      !!---------------------------------------------------------------------- 
536      INTEGER, INTENT(in) :: i1,i2,j1,j2,k1,k2
537      REAL(wp),DIMENSION(i1:i2,j1:j2,k1:k2), INTENT(inout) :: tabres
538      !!
539      INTEGER :: ji,jj,jk
540      !!---------------------------------------------------------------------- 
541
542      DO jk=k1,k2
543         DO jj=j1,j2
544            DO ji=i1,i2
545               tabres(ji,jj,jk) = e2u(ji,jj) * un(ji,jj,jk)
546               tabres(ji,jj,jk) = tabres(ji,jj,jk) * fse3u(ji,jj,jk)
547            END DO
548         END DO
549      END DO
550   END SUBROUTINE interpu
551
552
553   SUBROUTINE interpu2d(tabres,i1,i2,j1,j2)
554      !!----------------------------------------------------------------------
555      !!                  ***  ROUTINE interpu2d  ***
556      !!---------------------------------------------------------------------- 
557      INTEGER, INTENT(in) :: i1,i2,j1,j2
558      REAL(wp), DIMENSION(i1:i2,j1:j2), INTENT(inout) :: tabres
559      !!
560      INTEGER :: ji,jj
561      !!---------------------------------------------------------------------- 
562
563      DO jj=j1,j2
564         DO ji=i1,i2
565            tabres(ji,jj) = e2u(ji,jj) * ((gcx(ji+1,jj) - gcx(ji,jj))/e1u(ji,jj)) &
566               * umask(ji,jj,1)
567         END DO
568      END DO
569
570   END SUBROUTINE interpu2d
571
572
573   SUBROUTINE interpv(tabres,i1,i2,j1,j2,k1,k2)
574      !!----------------------------------------------------------------------
575      !!                  ***  ROUTINE interpv  ***
576      !!---------------------------------------------------------------------- 
577      INTEGER, INTENT(in) :: i1,i2,j1,j2,k1,k2
578      REAL(wp),DIMENSION(i1:i2,j1:j2,k1:k2), INTENT(inout) :: tabres
579      !!
580      INTEGER :: ji, jj, jk
581      !!---------------------------------------------------------------------- 
582
583      DO jk=k1,k2
584         DO jj=j1,j2
585            DO ji=i1,i2
586               tabres(ji,jj,jk) = e1v(ji,jj) * vn(ji,jj,jk)
587               tabres(ji,jj,jk) = tabres(ji,jj,jk) * fse3v(ji,jj,jk)
588            END DO
589         END DO
590      END DO
591
592   END SUBROUTINE interpv
593
594
595   SUBROUTINE interpv2d(tabres,i1,i2,j1,j2)
596      !!----------------------------------------------------------------------
597      !!                  ***  ROUTINE interpu2d  ***
598      !!---------------------------------------------------------------------- 
599      INTEGER, INTENT(in) :: i1,i2,j1,j2
600      REAL(wp), DIMENSION(i1:i2,j1:j2), INTENT(inout) :: tabres
601      !!
602      INTEGER :: ji,jj
603      !!---------------------------------------------------------------------- 
604
605      DO jj=j1,j2
606         DO ji=i1,i2
607            tabres(ji,jj) = e1v(ji,jj) * ((gcx(ji,jj+1) - gcx(ji,jj))/e2v(ji,jj)) &
608               * vmask(ji,jj,1)
609         END DO
610      END DO
611
612   END SUBROUTINE interpv2d
613
614#else
615   !!----------------------------------------------------------------------
616   !!   Empty module                                          no AGRIF zoom
617   !!----------------------------------------------------------------------
618CONTAINS
619   SUBROUTINE Agrif_OPA_Interp_empty
620      WRITE(*,*)  'agrif_opa_interp : You should not have seen this print! error?'
621   END SUBROUTINE Agrif_OPA_Interp_empty
622#endif
623
624   !!======================================================================
625END MODULE agrif_opa_interp
Note: See TracBrowser for help on using the repository browser.