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_update.F90 in trunk/NEMOGCM/NEMO/NST_SRC – NEMO

source: trunk/NEMOGCM/NEMO/NST_SRC/agrif_opa_update.F90 @ 2802

Last change on this file since 2802 was 2802, checked in by rblod, 13 years ago

Correct update of T and S with agrif, see ticket #847
  • Property svn:keywords set to Id
File size: 12.7 KB
Line 
1#define TWO_WAY
2
3MODULE agrif_opa_update
4#if defined key_agrif  && ! defined key_offline
5   USE par_oce
6   USE oce
7   USE dom_oce
8   USE agrif_oce
9   USE in_out_manager  ! I/O manager
10   USE lib_mpp
11   USE traswp
12   
13   IMPLICIT NONE
14   PRIVATE
15
16   PUBLIC Agrif_Update_Tra, Agrif_Update_Dyn
17
18   INTEGER, PUBLIC :: nbcline = 0
19
20   !!----------------------------------------------------------------------
21   !! NEMO/NST 3.3 , NEMO Consortium (2010)
22   !! $Id$
23   !! Software governed by the CeCILL licence (NEMOGCM/NEMO_CeCILL.txt)
24   !!----------------------------------------------------------------------
25
26CONTAINS
27
28   SUBROUTINE Agrif_Update_Tra( kt )
29      !!---------------------------------------------
30      !!   *** ROUTINE Agrif_Update_Tra ***
31      !!---------------------------------------------
32      USE wrk_nemo, ONLY: wrk_in_use, wrk_not_released
33      USE wrk_nemo, ONLY: wrk_3d_1
34      !!
35      INTEGER, INTENT(in) :: kt
36      REAL(wp), POINTER, DIMENSION(:,:,:) :: ztab
37
38       
39      IF((Agrif_NbStepint() .NE. (Agrif_irhot()-1)).AND.(kt /= 0)) RETURN
40#if defined TWO_WAY
41      ztab => wrk_3d_1
42      IF( wrk_in_use(3, 1) ) THEN
43         CALL ctl_stop('agrif_update_tra: ERROR: requested workspace arrays unavailable')
44         RETURN
45      END IF
46
47      Agrif_UseSpecialValueInUpdate = .TRUE.
48      Agrif_SpecialValueFineGrid = 0.
49
50      IF (MOD(nbcline,nbclineupdate) == 0) THEN
51         CALL Agrif_Update_Variable(ztab,tn_id, procname=updateT)
52         CALL Agrif_Update_Variable(ztab,sn_id, procname=updateS)
53      ELSE
54         CALL Agrif_Update_Variable(ztab,tn_id,locupdate=(/0,2/), procname=updateT)
55         CALL Agrif_Update_Variable(ztab,sn_id,locupdate=(/0,2/), procname=updateS)
56      ENDIF
57
58      Agrif_UseSpecialValueInUpdate = .FALSE.
59
60      CALL Agrif_ChildGrid_To_ParentGrid()
61      CALL tra_swap
62      CALL Agrif_ParentGrid_To_ChildGrid()
63
64      IF( wrk_not_released(3, 1) ) THEN
65         CALL ctl_stop('Agrif_Update_Tra: ERROR: failed to release workspace arrays')
66      END IF
67#endif
68
69   END SUBROUTINE Agrif_Update_Tra
70
71   SUBROUTINE Agrif_Update_Dyn( kt )
72      !!---------------------------------------------
73      !!   *** ROUTINE Agrif_Update_Dyn ***
74      !!---------------------------------------------
75      USE wrk_nemo, ONLY: wrk_in_use, wrk_not_released
76      USE wrk_nemo, ONLY: wrk_2d_1
77      USE wrk_nemo, ONLY: wrk_3d_1
78      !!
79      INTEGER, INTENT(in) :: kt
80      REAL(wp), POINTER, DIMENSION(:,:) :: ztab2d
81      REAL(wp), POINTER, DIMENSION(:,:,:) :: ztab
82
83
84      IF ((Agrif_NbStepint() .NE. (Agrif_irhot()-1)).AND.(kt /= 0)) Return
85#if defined TWO_WAY
86      ztab => wrk_3d_1 ; ztab2d => wrk_2d_1
87      IF( ( wrk_in_use(2, 1)) .OR.  wrk_in_use(3, 1) )THEN
88         CALL ctl_stop('agrif_update_dyn: ERROR: requested workspace arrays unavailable')
89         RETURN
90      END IF
91
92      IF (mod(nbcline,nbclineupdate) == 0) THEN
93         CALL Agrif_Update_Variable(ztab,un_id,procname = updateU)
94         CALL Agrif_Update_Variable(ztab,vn_id,procname = updateV)
95      ELSE
96         CALL Agrif_Update_Variable(ztab,un_id,locupdate=(/0,1/),procname = updateU)
97         CALL Agrif_Update_Variable(ztab,vn_id,locupdate=(/0,1/),procname = updateV)         
98      ENDIF
99
100      CALL Agrif_Update_Variable(ztab2d,e1u_id,procname = updateU2d)
101      CALL Agrif_Update_Variable(ztab2d,e2v_id,procname = updateV2d) 
102
103      nbcline = nbcline + 1
104
105      Agrif_UseSpecialValueInUpdate = ln_spc_dyn
106      Agrif_SpecialValueFineGrid = 0.
107      CALL Agrif_Update_Variable(ztab2d,sshn_id,procname = updateSSH)
108      Agrif_UseSpecialValueInUpdate = .FALSE.
109
110      IF( wrk_not_released(2, 1) .OR. wrk_not_released(3, 1) )THEN
111         CALL ctl_stop('agrif_update_dyn: ERROR: failed to release workspace arrays')
112      END IF
113
114!Done in step
115!      CALL Agrif_ChildGrid_To_ParentGrid()
116!      CALL recompute_diags( kt )
117!      CALL Agrif_ParentGrid_To_ChildGrid()
118
119#endif
120
121   END SUBROUTINE Agrif_Update_Dyn
122
123   SUBROUTINE recompute_diags( kt )
124      !!---------------------------------------------
125      !!   *** ROUTINE recompute_diags ***
126      !!---------------------------------------------
127      INTEGER, INTENT(in) :: kt
128
129   END SUBROUTINE recompute_diags
130
131   SUBROUTINE updateT( tabres, i1, i2, j1, j2, k1, k2, before )
132      !!---------------------------------------------
133      !!           *** ROUTINE updateT ***
134      !!---------------------------------------------
135#  include "domzgr_substitute.h90"
136
137      INTEGER, INTENT(in) :: i1,i2,j1,j2,k1,k2
138      REAL(wp),DIMENSION(i1:i2,j1:j2,k1:k2), INTENT(inout) :: tabres
139      LOGICAL, iNTENT(in) :: before
140
141      INTEGER :: ji,jj,jk
142
143      IF (before) THEN
144         DO jk=k1,k2
145            DO jj=j1,j2
146               DO ji=i1,i2
147                  tabres(ji,jj,jk) = tn(ji,jj,jk)
148               END DO
149            END DO
150         END DO
151      ELSE
152         DO jk=k1,k2
153            DO jj=j1,j2
154               DO ji=i1,i2
155                  IF( tabres(ji,jj,jk) .NE. 0. ) THEN
156                     tn(ji,jj,jk) = tabres(ji,jj,jk) * tmask(ji,jj,jk)
157                  ENDIF
158               END DO
159            END DO
160         END DO
161      ENDIF
162
163   END SUBROUTINE updateT
164
165   SUBROUTINE updateS( tabres, i1, i2, j1, j2, k1, k2, before )
166      !!---------------------------------------------
167      !!           *** ROUTINE updateS ***
168      !!---------------------------------------------
169#  include "domzgr_substitute.h90"
170
171      INTEGER, INTENT(in) :: i1,i2,j1,j2,k1,k2
172      REAL(wp),DIMENSION(i1:i2,j1:j2,k1:k2), INTENT(inout) :: tabres
173      LOGICAL, iNTENT(in) :: before
174
175      INTEGER :: ji,jj,jk
176
177      IF (before) THEN
178         DO jk=k1,k2
179            DO jj=j1,j2
180               DO ji=i1,i2
181                  tabres(ji,jj,jk) = sn(ji,jj,jk)
182               END DO
183            END DO
184         END DO
185      ELSE
186         DO jk=k1,k2
187            DO jj=j1,j2
188               DO ji=i1,i2
189                  IF (tabres(ji,jj,jk).NE.0.) THEN
190                     sn(ji,jj,jk) = tabres(ji,jj,jk) * tmask(ji,jj,jk)
191                  ENDIF
192               END DO
193            END DO
194         END DO
195      ENDIF
196
197   END SUBROUTINE updateS
198
199   SUBROUTINE updateu( tabres, i1, i2, j1, j2, k1, k2, before )
200      !!---------------------------------------------
201      !!           *** ROUTINE updateu ***
202      !!---------------------------------------------
203#  include "domzgr_substitute.h90"
204
205      INTEGER, INTENT(in) :: i1, i2, j1, j2, k1, k2
206      REAL(wp), DIMENSION(i1:i2,j1:j2,k1:k2), INTENT(inout) :: tabres
207      LOGICAL, INTENT(in) :: before
208
209      INTEGER :: ji, jj, jk
210      REAL(wp) :: zrhoy
211
212      IF (before) THEN
213         zrhoy = Agrif_Rhoy()
214         DO jk=k1,k2
215            DO jj=j1,j2
216               DO ji=i1,i2
217                  tabres(ji,jj,jk) = e2u(ji,jj) * un(ji,jj,jk)
218                  tabres(ji,jj,jk) = tabres(ji,jj,jk) * fse3u(ji,jj,jk)
219               END DO
220            END DO
221         END DO
222         tabres = zrhoy * tabres
223      ELSE
224         DO jk=k1,k2
225            DO jj=j1,j2
226               DO ji=i1,i2
227                  un(ji,jj,jk) = tabres(ji,jj,jk) / (e2u(ji,jj))
228                  un(ji,jj,jk) = un(ji,jj,jk) * umask(ji,jj,jk)
229                  un(ji,jj,jk) = un(ji,jj,jk) / fse3u(ji,jj,jk)
230               END DO
231            END DO
232         END DO
233      ENDIF
234
235   END SUBROUTINE updateu
236
237   SUBROUTINE updatev( tabres, i1, i2, j1, j2, k1, k2, before )
238      !!---------------------------------------------
239      !!           *** ROUTINE updatev ***
240      !!---------------------------------------------
241#  include "domzgr_substitute.h90"
242
243      INTEGER :: i1,i2,j1,j2,k1,k2
244      INTEGER :: ji,jj,jk
245      REAL(wp), DIMENSION(i1:i2,j1:j2,k1:k2) :: tabres
246      LOGICAL :: before
247
248      REAL(wp) :: zrhox
249
250      IF (before) THEN
251         zrhox = Agrif_Rhox()
252         DO jk=k1,k2
253            DO jj=j1,j2
254               DO ji=i1,i2
255                  tabres(ji,jj,jk) = e1v(ji,jj) * vn(ji,jj,jk)
256                  tabres(ji,jj,jk) = tabres(ji,jj,jk) * fse3v(ji,jj,jk)
257               END DO
258            END DO
259         END DO
260         tabres = zrhox * tabres
261      ELSE
262         DO jk=k1,k2
263            DO jj=j1,j2
264               DO ji=i1,i2
265                  vn(ji,jj,jk) = tabres(ji,jj,jk) / (e1v(ji,jj))
266                  vn(ji,jj,jk) = vn(ji,jj,jk) * vmask(ji,jj,jk)
267                  vn(ji,jj,jk) = vn(ji,jj,jk) / fse3v(ji,jj,jk)
268               END DO
269            END DO
270         END DO
271      ENDIF
272
273   END SUBROUTINE updatev
274
275   SUBROUTINE updateu2d( tabres, i1, i2, j1, j2, before )
276      !!---------------------------------------------
277      !!          *** ROUTINE updateu2d ***
278      !!---------------------------------------------
279#  include "domzgr_substitute.h90"
280
281      INTEGER, INTENT(in) :: i1, i2, j1, j2
282      REAL(wp), DIMENSION(i1:i2,j1:j2), INTENT(inout) :: tabres
283      LOGICAL, INTENT(in) :: before
284
285      INTEGER :: ji, jj, jk
286      REAL(wp) :: zrhoy
287      REAL(wp) :: zhinv
288
289      IF (before) THEN
290         zrhoy = Agrif_Rhoy()
291         DO jk = 1,jpkm1
292            DO jj=j1,j2
293               DO ji=i1,i2
294                  tabres(ji,jj) = tabres(ji,jj) + fse3u(ji,jj,jk) * un(ji,jj,jk)
295               END DO
296            END DO
297         END DO
298         DO jj=j1,j2
299            DO ji=i1,i2
300               tabres(ji,jj) = tabres(ji,jj) * e2u(ji,jj)
301            END DO
302         END DO
303         tabres = zrhoy * tabres
304      ELSE
305         DO jj=j1,j2
306            DO ji=i1,i2
307               IF(umask(ji,jj,1) .NE. 0.) THEN             
308                  spgu(ji,jj) = 0.e0
309                  DO jk=1,jpk
310                     spgu(ji,jj) = spgu(ji,jj) + fse3u(ji,jj,jk) * un(ji,jj,jk)
311                  END DO
312                  spgu(ji,jj) = spgu(ji,jj) * e2u(ji,jj)
313                  zhinv = (tabres(ji,jj)-spgu(ji,jj))/(hu(ji,jj)*e2u(ji,jj))
314                  Do jk=1,jpk             
315                     un(ji,jj,jk) = un(ji,jj,jk) + zhinv
316                     un(ji,jj,jk) = un(ji,jj,jk) * umask(ji,jj,jk)           
317                  END DO
318               ENDIF
319            END DO
320         END DO
321      ENDIF
322
323   END SUBROUTINE updateu2d
324
325   SUBROUTINE updatev2d( tabres, i1, i2, j1, j2, before )
326      !!---------------------------------------------
327      !!          *** ROUTINE updatev2d ***
328      !!---------------------------------------------
329
330      INTEGER, INTENT(in) :: i1, i2, j1, j2
331      REAL(wp), DIMENSION(i1:i2,j1:j2), INTENT(inout) :: tabres
332      LOGICAL, INTENT(in) :: before
333
334      INTEGER :: ji, jj, jk
335      REAL(wp) :: zrhox
336      REAL(wp) :: zhinv
337
338      IF (before) THEN
339         zrhox = Agrif_Rhox()
340         tabres = 0.e0
341         DO jk = 1,jpkm1
342            DO jj=j1,j2
343               DO ji=i1,i2
344                  tabres(ji,jj) = tabres(ji,jj) + fse3v(ji,jj,jk) * vn(ji,jj,jk)
345               END DO
346            END DO
347         END DO
348         DO jj=j1,j2
349            DO ji=i1,i2
350               tabres(ji,jj) = tabres(ji,jj) * e1v(ji,jj)
351            END DO
352         END DO
353         tabres = zrhox * tabres
354      ELSE
355         DO jj=j1,j2
356            DO ji=i1,i2
357               IF(vmask(ji,jj,1) .NE. 0.) THEN             
358                  spgv(ji,jj) = 0.
359                  DO jk=1,jpk
360                     spgv(ji,jj) = spgv(ji,jj) + fse3v(ji,jj,jk) * vn(ji,jj,jk)
361                  END DO
362                  spgv(ji,jj) = spgv(ji,jj) * e1v(ji,jj)
363                  zhinv = (tabres(ji,jj)-spgv(ji,jj))/(hv(ji,jj)*e1v(ji,jj))
364                  DO jk=1,jpk             
365                     vn(ji,jj,jk) = vn(ji,jj,jk) + zhinv
366                     vn(ji,jj,jk) = vn(ji,jj,jk) * vmask(ji,jj,jk)
367                  END DO
368               ENDIF
369            END DO
370         END DO
371      ENDIF
372
373   END SUBROUTINE updatev2d
374
375   SUBROUTINE updateSSH( tabres, i1, i2, j1, j2, before )
376      !!---------------------------------------------
377      !!          *** ROUTINE updateSSH ***
378      !!---------------------------------------------
379#  include "domzgr_substitute.h90"
380
381      INTEGER, INTENT(in) :: i1, i2, j1, j2
382      REAL(wp), DIMENSION(i1:i2,j1:j2), INTENT(inout) :: tabres
383      LOGICAL, INTENT(in) :: before
384
385      INTEGER :: ji, jj
386      REAL(wp) :: zrhox, zrhoy
387
388      IF (before) THEN
389         zrhox = Agrif_Rhox()
390         zrhoy = Agrif_Rhoy()
391         DO jj=j1,j2
392            DO ji=i1,i2
393               tabres(ji,jj) = e1t(ji,jj) * e2t(ji,jj) * sshn(ji,jj)
394            END DO
395         END DO
396         tabres = zrhox * zrhoy * tabres
397      ELSE
398         DO jj=j1,j2
399            DO ji=i1,i2
400               sshn(ji,jj) = tabres(ji,jj) / (e1t(ji,jj) * e2t(ji,jj))
401               sshn(ji,jj) = sshn(ji,jj) * tmask(ji,jj,1)
402            END DO
403         END DO
404      ENDIF
405
406   END SUBROUTINE updateSSH
407
408#else
409CONTAINS
410   SUBROUTINE agrif_opa_update_empty
411      !!---------------------------------------------
412      !!   *** ROUTINE agrif_opa_update_empty ***
413      !!---------------------------------------------
414      WRITE(*,*)  'agrif_opa_update : You should not have seen this print! error?'
415   END SUBROUTINE agrif_opa_update_empty
416#endif
417END MODULE agrif_opa_update
Note: See TracBrowser for help on using the repository browser.