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 branches/2011/dev_r2802_LOCEAN10_agrif_lim/NEMOGCM/NEMO/NST_SRC – NEMO

source: branches/2011/dev_r2802_LOCEAN10_agrif_lim/NEMOGCM/NEMO/NST_SRC/agrif_opa_update.F90 @ 2804

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

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