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

source: branches/2011/dev_MERCATOR_2011_MERGE/NEMOGCM/NEMO/NST_SRC/agrif_opa_update.F90 @ 3049

Last change on this file since 3049 was 3049, checked in by cbricaud, 13 years ago

add changes from dev_r2802_MERCATOR10_diadct
  • Property svn:keywords set to Id
File size: 12.7 KB
RevLine 
[390]1#define TWO_WAY
2
[636]3MODULE agrif_opa_update
[2528]4#if defined key_agrif  && ! defined key_offline
[636]5   USE par_oce
6   USE oce
7   USE dom_oce
[782]8   USE agrif_oce
[2715]9   USE in_out_manager  ! I/O manager
10   USE lib_mpp
[3049]11   USE traswp
12   
[636]13   IMPLICIT NONE
14   PRIVATE
[390]15
[636]16   PUBLIC Agrif_Update_Tra, Agrif_Update_Dyn
[390]17
[1300]18   INTEGER, PUBLIC :: nbcline = 0
[390]19
[1156]20   !!----------------------------------------------------------------------
[2528]21   !! NEMO/NST 3.3 , NEMO Consortium (2010)
[1156]22   !! $Id$
[2528]23   !! Software governed by the CeCILL licence (NEMOGCM/NEMO_CeCILL.txt)
[1156]24   !!----------------------------------------------------------------------
25
[636]26CONTAINS
27
28   SUBROUTINE Agrif_Update_Tra( kt )
29      !!---------------------------------------------
30      !!   *** ROUTINE Agrif_Update_Tra ***
31      !!---------------------------------------------
[2715]32      USE wrk_nemo, ONLY: wrk_in_use, wrk_not_released
33      USE wrk_nemo, ONLY: wrk_3d_1
34      !!
[636]35      INTEGER, INTENT(in) :: kt
[2715]36      REAL(wp), POINTER, DIMENSION(:,:,:) :: ztab
[636]37
[2715]38       
[636]39      IF((Agrif_NbStepint() .NE. (Agrif_irhot()-1)).AND.(kt /= 0)) RETURN
[390]40#if defined TWO_WAY
[2715]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
[390]47      Agrif_UseSpecialValueInUpdate = .TRUE.
48      Agrif_SpecialValueFineGrid = 0.
[636]49
50      IF (MOD(nbcline,nbclineupdate) == 0) THEN
[2715]51         CALL Agrif_Update_Variable(ztab,tn_id, procname=updateT)
52         CALL Agrif_Update_Variable(ztab,sn_id, procname=updateS)
[390]53      ELSE
[2715]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)
[390]56      ENDIF
57
58      Agrif_UseSpecialValueInUpdate = .FALSE.
[2715]59
[3049]60      CALL Agrif_ChildGrid_To_ParentGrid()
61      CALL tra_swap
62      CALL Agrif_ParentGrid_To_ChildGrid()
63
[2715]64      IF( wrk_not_released(3, 1) ) THEN
65         CALL ctl_stop('Agrif_Update_Tra: ERROR: failed to release workspace arrays')
66      END IF
[390]67#endif
68
[636]69   END SUBROUTINE Agrif_Update_Tra
[390]70
[636]71   SUBROUTINE Agrif_Update_Dyn( kt )
72      !!---------------------------------------------
73      !!   *** ROUTINE Agrif_Update_Dyn ***
74      !!---------------------------------------------
[2715]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      !!
[636]79      INTEGER, INTENT(in) :: kt
[2715]80      REAL(wp), POINTER, DIMENSION(:,:) :: ztab2d
81      REAL(wp), POINTER, DIMENSION(:,:,:) :: ztab
[636]82
83
[390]84      IF ((Agrif_NbStepint() .NE. (Agrif_irhot()-1)).AND.(kt /= 0)) Return
85#if defined TWO_WAY
[2715]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
[390]91
92      IF (mod(nbcline,nbclineupdate) == 0) THEN
[2715]93         CALL Agrif_Update_Variable(ztab,un_id,procname = updateU)
94         CALL Agrif_Update_Variable(ztab,vn_id,procname = updateV)
[390]95      ELSE
[2715]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)         
[390]98      ENDIF
99
[2715]100      CALL Agrif_Update_Variable(ztab2d,e1u_id,procname = updateU2d)
101      CALL Agrif_Update_Variable(ztab2d,e2v_id,procname = updateV2d) 
[636]102
[390]103      nbcline = nbcline + 1
104
[782]105      Agrif_UseSpecialValueInUpdate = ln_spc_dyn
[636]106      Agrif_SpecialValueFineGrid = 0.
[2715]107      CALL Agrif_Update_Variable(ztab2d,sshn_id,procname = updateSSH)
[636]108      Agrif_UseSpecialValueInUpdate = .FALSE.
[390]109
[2715]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
[390]113
[1438]114!Done in step
115!      CALL Agrif_ChildGrid_To_ParentGrid()
116!      CALL recompute_diags( kt )
117!      CALL Agrif_ParentGrid_To_ChildGrid()
[390]118
119#endif
120
[636]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      !!---------------------------------------------
[390]135#  include "domzgr_substitute.h90"
136
[636]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
[390]140
[636]141      INTEGER :: ji,jj,jk
142
143      IF (before) THEN
[390]144         DO jk=k1,k2
[636]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
[390]162
[636]163   END SUBROUTINE updateT
[390]164
[636]165   SUBROUTINE updateS( tabres, i1, i2, j1, j2, k1, k2, before )
166      !!---------------------------------------------
167      !!           *** ROUTINE updateS ***
168      !!---------------------------------------------
[390]169#  include "domzgr_substitute.h90"
170
[636]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
[390]174
[636]175      INTEGER :: ji,jj,jk
[390]176
[636]177      IF (before) THEN
[390]178         DO jk=k1,k2
[636]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
[390]196
[636]197   END SUBROUTINE updateS
[390]198
[636]199   SUBROUTINE updateu( tabres, i1, i2, j1, j2, k1, k2, before )
200      !!---------------------------------------------
201      !!           *** ROUTINE updateu ***
202      !!---------------------------------------------
[390]203#  include "domzgr_substitute.h90"
204
[636]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
[390]208
[636]209      INTEGER :: ji, jj, jk
210      REAL(wp) :: zrhoy
211
212      IF (before) THEN
213         zrhoy = Agrif_Rhoy()
[390]214         DO jk=k1,k2
[636]215            DO jj=j1,j2
216               DO ji=i1,i2
217                  tabres(ji,jj,jk) = e2u(ji,jj) * un(ji,jj,jk)
[2715]218                  tabres(ji,jj,jk) = tabres(ji,jj,jk) * fse3u(ji,jj,jk)
[636]219               END DO
220            END DO
221         END DO
222         tabres = zrhoy * tabres
223      ELSE
[390]224         DO jk=k1,k2
[636]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
[390]234
[636]235   END SUBROUTINE updateu
[390]236
[636]237   SUBROUTINE updatev( tabres, i1, i2, j1, j2, k1, k2, before )
238      !!---------------------------------------------
239      !!           *** ROUTINE updatev ***
240      !!---------------------------------------------
[390]241#  include "domzgr_substitute.h90"
242
[636]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
[390]247
[636]248      REAL(wp) :: zrhox
249
250      IF (before) THEN
251         zrhox = Agrif_Rhox()
[390]252         DO jk=k1,k2
[636]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
[390]262         DO jk=k1,k2
[636]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
[390]272
[636]273   END SUBROUTINE updatev
[390]274
[636]275   SUBROUTINE updateu2d( tabres, i1, i2, j1, j2, before )
276      !!---------------------------------------------
277      !!          *** ROUTINE updateu2d ***
278      !!---------------------------------------------
[390]279#  include "domzgr_substitute.h90"
280
[636]281      INTEGER, INTENT(in) :: i1, i2, j1, j2
282      REAL(wp), DIMENSION(i1:i2,j1:j2), INTENT(inout) :: tabres
283      LOGICAL, INTENT(in) :: before
[390]284
[636]285      INTEGER :: ji, jj, jk
286      REAL(wp) :: zrhoy
287      REAL(wp) :: zhinv
[390]288
[636]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
[390]318               ENDIF
[636]319            END DO
320         END DO
321      ENDIF
[390]322
[636]323   END SUBROUTINE updateu2d
[390]324
[636]325   SUBROUTINE updatev2d( tabres, i1, i2, j1, j2, before )
326      !!---------------------------------------------
327      !!          *** ROUTINE updatev2d ***
328      !!---------------------------------------------
[390]329
[636]330      INTEGER, INTENT(in) :: i1, i2, j1, j2
331      REAL(wp), DIMENSION(i1:i2,j1:j2), INTENT(inout) :: tabres
332      LOGICAL, INTENT(in) :: before
[390]333
[636]334      INTEGER :: ji, jj, jk
335      REAL(wp) :: zrhox
336      REAL(wp) :: zhinv
[390]337
[636]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
[390]368               ENDIF
[636]369            END DO
370         END DO
371      ENDIF
[390]372
[636]373   END SUBROUTINE updatev2d
[390]374
[636]375   SUBROUTINE updateSSH( tabres, i1, i2, j1, j2, before )
376      !!---------------------------------------------
377      !!          *** ROUTINE updateSSH ***
378      !!---------------------------------------------
[390]379#  include "domzgr_substitute.h90"
380
[636]381      INTEGER, INTENT(in) :: i1, i2, j1, j2
382      REAL(wp), DIMENSION(i1:i2,j1:j2), INTENT(inout) :: tabres
383      LOGICAL, INTENT(in) :: before
[390]384
[636]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
[390]393               tabres(ji,jj) = e1t(ji,jj) * e2t(ji,jj) * sshn(ji,jj)
[636]394            END DO
395         END DO
396         tabres = zrhox * zrhoy * tabres
397      ELSE
398         DO jj=j1,j2
399            DO ji=i1,i2
[390]400               sshn(ji,jj) = tabres(ji,jj) / (e1t(ji,jj) * e2t(ji,jj))
401               sshn(ji,jj) = sshn(ji,jj) * tmask(ji,jj,1)
[636]402            END DO
403         END DO
404      ENDIF
[390]405
[636]406   END SUBROUTINE updateSSH
407
[390]408#else
[636]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
[390]416#endif
[636]417END MODULE agrif_opa_update
Note: See TracBrowser for help on using the repository browser.