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 @ 2715

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

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