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_r2787_LOCEAN3_TRA_TRP/NEMOGCM/NEMO/NST_SRC – NEMO

source: branches/2011/dev_r2787_LOCEAN3_TRA_TRP/NEMOGCM/NEMO/NST_SRC/agrif_opa_update.F90 @ 2789

Last change on this file since 2789 was 2789, checked in by cetlod, 13 years ago

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