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

source: branches/2011/dev_LOCEAN_CMCC_INGV_MERCATOR_2011/NEMOGCM/NEMO/NST_SRC/agrif_opa_update.F90 @ 3104

Last change on this file since 3104 was 3104, checked in by cetlod, 12 years ago

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