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_update.F90 in NEMO/branches/2019/ENHANCE-02_ISF_domcfg/src – NEMO

source: NEMO/branches/2019/ENHANCE-02_ISF_domcfg/src/agrif_update.F90 @ 11568

Last change on this file since 11568 was 10727, checked in by rblod, 5 years ago

new nesting tools (attempt) and brutal cleaning of DOMAINcfg, see ticket #2129

File size: 6.2 KB
Line 
1#if defined key_agrif
2subroutine agrif_update_all
3USE agrif_parameters
4USE agrif_profiles
5external update_bottom_level, update_e3t, update_e3u, update_e3v
6
7if (agrif_root()) return
8call agrif_update_variable(bottom_level_id,locupdate=(/npt_copy,0/),procname = update_bottom_level)
9
10      Agrif_UseSpecialValueInUpdate = .TRUE.
11      Agrif_SpecialValueFineGrid    = 0._wp
12     
13call agrif_update_variable(e3t_id,procname = update_e3t)
14      Agrif_UseSpecialValueInUpdate = .FALSE.
15
16call agrif_update_variable(e3u_id,procname = update_e3u)
17call agrif_update_variable(e3v_id,procname = update_e3v)
18     
19end subroutine agrif_update_all
20
21    SUBROUTINE update_bottom_level( ptab, i1, i2, j1, j2, before, nb,ndir)
22    USE dom_oce
23    USE domzgr
24      !!----------------------------------------------------------------------
25      !!                  ***  ROUTINE interpsshn  ***
26      !!---------------------------------------------------------------------- 
27      INTEGER                         , INTENT(in   ) ::   i1, i2, j1, j2
28      REAL, DIMENSION(i1:i2,j1:j2)    , INTENT(inout) ::   ptab
29      LOGICAL                         , INTENT(in   ) ::   before
30      INTEGER                         , INTENT(in   ) ::   nb , ndir
31      LOGICAL  ::   western_side, eastern_side,northern_side,southern_side
32      !
33      !!----------------------------------------------------------------------
34      INTEGER :: ji,jj     
35      !
36         western_side  = (nb == 1).AND.(ndir == 1)
37         eastern_side  = (nb == 1).AND.(ndir == 2)
38         southern_side = (nb == 2).AND.(ndir == 1)
39         northern_side = (nb == 2).AND.(ndir == 2)
40
41      IF( before) THEN
42         ptab(i1:i2,j1:j2) = mbkt(i1:i2,j1:j2)*ssmask(i1:i2,j1:j2)
43      ELSE
44         mbkt(i1:i2,j1:j2) = nint(ptab(i1:i2,j1:j2))
45         
46         WHERE (mbkt(i1:i2,j1:j2)==0)
47           ssmask(i1:i2,j1:j2) = 0.
48         END WHERE
49           
50      ENDIF
51      !
52   END SUBROUTINE update_bottom_level
53   
54   SUBROUTINE update_e3t( tabres, i1, i2, j1, j2, k1, k2,  before )
55   USE dom_oce
56   implicit none
57      !!---------------------------------------------
58      !!           *** update_e3t updateT ***
59      !!---------------------------------------------
60      INTEGER, INTENT(in) :: i1,i2,j1,j2,k1,k2
61      REAL(wp),DIMENSION(i1:i2,j1:j2,k1:k2), INTENT(inout) :: tabres
62      LOGICAL, INTENT(in) :: before
63      !!
64      INTEGER :: ji,jj,jk
65      !!---------------------------------------------
66      !
67      IF (before) THEN
68            DO jk=k1,k2
69               DO jj=j1,j2
70                  DO ji=i1,i2
71                   if (mbkt(ji,jj) < jk) then
72                     tabres(ji,jj,jk) = e3t_0(ji,jj,jk)
73                   else
74                     tabres(ji,jj,jk) = 0.
75                   endif
76                  END DO
77               END DO
78            END DO
79      ELSE
80            DO jk=k1,k2
81               DO jj=j1,j2
82                  DO ji=i1,i2
83                   if (mbkt(ji,jj) < jk) then
84                     e3t_0(ji,jj,jk) = e3t_1d(jk)
85                   else
86                     e3t_0(ji,jj,jk) = MAX(tabres(ji,jj,jk),MIN(e3zps_min,e3t_1d(jk)*e3zps_rat))
87                   endif
88                  END DO
89               END DO
90            END DO
91         !
92      ENDIF
93      !
94   END SUBROUTINE update_e3t
95   
96   SUBROUTINE update_e3u( tabres, i1, i2, j1, j2, k1, k2, before )
97   USE dom_oce
98   implicit none
99      !!---------------------------------------------
100      !!           *** ROUTINE update_e3u ***
101      !!---------------------------------------------
102      INTEGER                               , INTENT(in   ) :: i1, i2, j1, j2, k1, k2
103      REAL(wp), DIMENSION(i1:i2,j1:j2,k1:k2), INTENT(inout) :: tabres
104      LOGICAL                                     , INTENT(in   ) :: before
105      !
106      INTEGER  :: ji, jj, jk
107      REAL :: zrhoy
108      !!---------------------------------------------
109      !
110      IF( before ) THEN
111         zrhoy = Agrif_Rhoy()
112         DO jk = k1, k2
113          do jj=j1,j2
114          do ji=i1,i2
115           if (min(mbkt(ji,jj),mbkt(ji+1,jj))<jk) then
116            tabres(ji,jj,jk) = zrhoy * e2u(ji,jj) * MIN(e3zps_min,e3t_1d(jk)*e3zps_rat)
117           else
118            tabres(ji,jj,jk) = zrhoy * e2u(ji,jj) * e3u_0(ji,jj,jk)
119           endif
120          enddo
121          enddo
122         END DO
123      ELSE
124         DO jk=k1,k2
125            DO jj=j1,j2
126               DO ji=i1,i2
127                 if (min(mbkt(ji,jj),mbkt(ji+1,jj))<jk) then
128                   e3u_0(ji,jj,jk)=e3t_1d(jk)
129                 else
130                   e3u_0(ji,jj,jk) = MAX(tabres(ji,jj,jk) / e2u(ji,jj),MIN(e3zps_min,e3t_1d(jk)*e3zps_rat))
131                 endif
132               END DO
133            END DO
134         END DO
135         !
136      ENDIF
137      !
138   END SUBROUTINE update_e3u
139   
140   SUBROUTINE update_e3v( tabres, i1, i2, j1, j2, k1, k2, before )
141   USE dom_oce
142   implicit none
143      !!---------------------------------------------
144      !!           *** ROUTINE update_e3v ***
145      !!---------------------------------------------
146      INTEGER                               , INTENT(in   ) :: i1, i2, j1, j2, k1, k2
147      REAL(wp), DIMENSION(i1:i2,j1:j2,k1:k2), INTENT(inout) :: tabres
148      LOGICAL                                     , INTENT(in   ) :: before
149      !
150      INTEGER  :: ji, jj, jk
151      REAL :: zrhox
152      !!---------------------------------------------
153      !
154      IF( before ) THEN
155         zrhox = Agrif_Rhox()
156         DO jk = k1, k2
157          do jj=j1,j2
158          do ji=i1,i2
159           if (min(mbkt(ji,jj),mbkt(ji,jj+1))<jk) then
160            tabres(ji,jj,jk) = zrhox * e1v(ji,jj) * MIN(e3zps_min,e3t_1d(jk)*e3zps_rat)
161           else
162            tabres(ji,jj,jk) = zrhox * e1v(ji,jj) * e3v_0(ji,jj,jk)
163           endif
164          enddo
165          enddo
166         END DO
167      ELSE
168         DO jk=k1,k2
169            DO jj=j1,j2
170               DO ji=i1,i2
171                 if (min(mbkt(ji,jj),mbkt(ji,jj+1))<jk) then
172                   e3v_0(ji,jj,jk)=e3t_1d(jk)
173                 else
174                   e3v_0(ji,jj,jk) = MAX(tabres(ji,jj,jk) / e1v(ji,jj),MIN(e3zps_min,e3t_1d(jk)*e3zps_rat))
175                 endif
176               END DO
177            END DO
178         END DO
179         !
180      ENDIF
181      !
182   END SUBROUTINE update_e3v
183   
184#else
185subroutine agrif_update_all_empty
186end subroutine agrif_update_all_empty
187#endif
Note: See TracBrowser for help on using the repository browser.