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_connect.F90 in utils/tools_dev_r12970_AGRIF_CMEMS/DOMAINcfg/src – NEMO

source: utils/tools_dev_r12970_AGRIF_CMEMS/DOMAINcfg/src/agrif_connect.F90 @ 13056

Last change on this file since 13056 was 13056, checked in by rblod, 4 years ago

ticket #2129 : cleaning domcfg
File size: 7.4 KB
Line 
1MODULE agrif_connect
2
3   USE dom_oce
4   USE domzgr
5   USE agrif_parameters
6   USE agrif_profiles
7
8   IMPLICIT NONE
9   PRIVATE
10
11   PUBLIC agrif_boundary_connections 
12
13CONTAINS
14
15#if defined key_agrif
16
17   SUBROUTINE agrif_boundary_connections
18      !!----------------------------------------------------------------------
19      !!                  ***  ROUTINE agrif_boundary_connections  ***
20      !!---------------------------------------------------------------------- 
21      IF( Agrif_Root() ) return
22
23      CALL agrif_connection()
24      !
25      CALL Agrif_Bc_variable(bottom_level_id, procname = connect_bottom_level)
26      !
27      CALL Agrif_Bc_variable(e3t_copy_id, procname = connect_e3t_copy)
28
29      ALLOCATE(e3t_interp(jpi,jpj,jpk))
30      e3t_interp = -10.
31      Agrif_UseSpecialValue = .TRUE.
32      Agrif_SpecialValue = 0.
33      CALL Agrif_Bc_variable(e3t_connect_id, procname = connect_e3t_connect)
34      Agrif_UseSpecialValue = .FALSE.
35      !   
36   END SUBROUTINE agrif_boundary_connections
37
38   SUBROUTINE connect_e3t_copy( ptab, i1, i2, j1, j2, k1, k2, before, nb,ndir)
39      !!----------------------------------------------------------------------
40      !!                  ***  ROUTINE connect_e3t_copy  ***
41      !!---------------------------------------------------------------------- 
42      INTEGER                               , INTENT(in   ) ::   i1, i2, j1, j2, k1, k2
43      REAL(wp), DIMENSION(i1:i2,j1:j2,k1:k2), INTENT(inout) ::   ptab
44      LOGICAL                               , INTENT(in   ) ::   before
45      INTEGER                               , INTENT(in   ) ::   nb , ndir
46      !
47      !!----------------------------------------------------------------------
48      !
49      IF( before) THEN
50         ptab(i1:i2,j1:j2,k1:k2) = e3t_0(i1:i2,j1:j2,k1:k2)
51      ELSE
52         e3t_0(i1:i2,j1:j2,k1:k2) = ptab(i1:i2,j1:j2,k1:k2)
53      ENDIF
54      !
55   END SUBROUTINE connect_e3t_copy
56   
57   SUBROUTINE connect_bottom_level( ptab, i1, i2, j1, j2, before, nb,ndir)
58      !!----------------------------------------------------------------------
59      !!                  ***  ROUTINE connect_bottom_level  ***
60      !!---------------------------------------------------------------------- 
61      INTEGER                         , INTENT(in   ) ::   i1, i2, j1, j2
62      REAL(wp), DIMENSION(i1:i2,j1:j2), INTENT(inout) ::   ptab
63      LOGICAL                         , INTENT(in   ) ::   before
64      INTEGER                         , INTENT(in   ) ::   nb , ndir
65      !
66      !!----------------------------------------------------------------------
67      !
68      IF( before) THEN
69         ptab(i1:i2,j1:j2) = mbkt(i1:i2,j1:j2)*ssmask(i1:i2,j1:j2)
70      ELSE
71         mbkt(i1:i2,j1:j2) = nint(ptab(i1:i2,j1:j2))
72         WHERE (mbkt(i1:i2,j1:j2)==0)
73           ssmask(i1:i2,j1:j2) = 0.
74         ELSEWHERE
75           ssmask(i1:i2,j1:j2) = 1.
76         END WHERE           
77      ENDIF
78      !
79   END SUBROUTINE connect_bottom_level
80   
81   SUBROUTINE connect_e3t_connect( ptab, i1, i2, j1, j2, k1, k2, before, nb,ndir)
82      !!----------------------------------------------------------------------
83      !!                  ***  ROUTINE connect_e3t_connect  ***
84      !!---------------------------------------------------------------------- 
85      INTEGER                               , INTENT(in   ) ::   i1, i2, j1, j2, k1, k2
86      REAL(wp), DIMENSION(i1:i2,j1:j2,k1:k2), INTENT(inout) ::   ptab
87      LOGICAL                               , INTENT(in   ) ::   before
88      INTEGER                               , INTENT(in   ) ::   nb , ndir
89      !
90      !!----------------------------------------------------------------------
91      INTEGER :: ji, jj, jk 
92      REAL(wp), DIMENSION(i1:i2,j1:j2) :: bathy_local   
93      !
94      IF( before) THEN
95         DO jk=1,jpk
96            DO jj=j1,j2
97               DO ji=i1,i2
98                  IF( mbkt(ji,jj) .GE. jk ) THEN
99                     ptab(ji,jj,jk) = e3t_0(ji,jj,jk)
100                  ELSE
101                     ptab(ji,jj,jk) = 0.
102                  ENDIF
103               END DO
104            END DO
105         END DO
106         !
107         DO jj=j1,j2
108            DO ji=i1,i2
109               ptab(ji,jj,jpk+1) = SUM ( e3t_0(ji,jj, 1:mbkt(ji,jj) ) ) * ssmask(ji,jj)
110            END DO
111         END DO
112      ELSE
113         DO jj=j1,j2
114            DO ji=i1,i2
115               bathy_local (ji,jj) = SUM ( e3t_0(ji,jj, 1:mbkt(ji,jj) ) ) * ssmask(ji,jj)
116            END DO
117         END DO
118         !
119         DO jk=1,jpk
120            DO jj=j1,j2
121               DO ji=i1,i2
122                  IF( e3t_interp(ji,jj,jk) == -10 ) THEN ! the connection has not yet been done
123                     e3t_interp(ji,jj,jk) = MAX( ptab(ji,jj,jk),MIN(e3zps_min, e3t_1d(jk)*e3zps_rat) )
124                     e3t_interp(ji,jj,jk) = MIN( e3t_interp(ji,jj,jk),e3t_1d(jk) )
125                     e3t_0(ji,jj,jk) = ztabramp(ji,jj)*e3t_0(ji,jj,jk)+(1.-ztabramp(ji,jj))*e3t_interp(ji,jj,jk)
126                  ENDIF
127             END DO
128           END DO
129         END DO
130      ENDIF
131      !
132   END SUBROUTINE connect_e3t_connect
133   
134   SUBROUTINE agrif_connection
135      !!----------------------------------------------------------------------
136      !!                 *** ROUTINE  Agrif_connection ***
137      !!----------------------------------------------------------------------
138      INTEGER  ::   ji, jj, ind1, ind2
139      INTEGER  ::   ispongearea, istart
140      REAL(wp) ::   z1_spongearea
141      !!----------------------------------------------------------------------
142      !
143      ! Define ramp from boundaries towards domain interior at T-points
144      ! Store it in ztabramp
145
146      ALLOCATE(ztabramp(jpi,jpj))
147      ispongearea = 1 + npt_connect * Agrif_irhox()
148      istart = npt_copy * Agrif_irhox()
149      z1_spongearea = 1._wp / REAL( ispongearea, wp )
150     
151      ztabramp(:,:) = 0._wp
152
153      ! --- West --- !
154      IF( ((nbondi == -1) .OR. (nbondi == 2) ).AND. .NOT. (jperio == 1 .OR. jperio == 4 .OR. jperio == 6)) THEN
155         ind1 = 1+nbghostcells + istart
156         ind2 = ind1 + ispongearea 
157         DO jj = 1, jpj
158            DO ji = ind1, ind2               
159               ztabramp(ji,jj) = REAL( ind2 - ji ) * z1_spongearea * umask(ind1,jj,1)
160            END DO
161         ENDDO
162      ENDIF
163
164      ! --- East --- !
165      IF( ((nbondi == 1) .OR. (nbondi == 2) ).AND. .NOT. (jperio == 1 .OR. jperio == 4 .OR. jperio == 6)) THEN
166         ind2 = nlci - nbghostcells - istart
167         ind1 = ind2 -ispongearea       
168         DO jj = 1, jpj
169            DO ji = ind1, ind2
170               ztabramp(ji,jj) = MAX( ztabramp(ji,jj), REAL( ji - ind1 ) * z1_spongearea * umask(ind2-1,jj,1) )
171            ENDDO
172         ENDDO
173      ENDIF
174
175      ! --- South --- !
176      IF(( (nbondj == -1) .OR. (nbondj == 2) ).AND.(ln_bry_south)) THEN
177         ind1 = 1+nbghostcells + istart
178         ind2 = ind1 + ispongearea 
179         DO jj = ind1, ind2 
180            DO ji = 1, jpi
181               ztabramp(ji,jj) = MAX( ztabramp(ji,jj), REAL( ind2 - jj ) * z1_spongearea * vmask(ji,ind1,1) )
182            END DO
183         ENDDO
184      ENDIF
185
186      ! --- North --- !
187      IF( (nbondj == 1) .OR. (nbondj == 2) ) THEN
188         ind2 = nlcj - nbghostcells - istart
189         ind1 = ind2 -ispongearea         
190         DO jj = ind1, ind2
191            DO ji = 1, jpi
192               ztabramp(ji,jj) = MAX( ztabramp(ji,jj), REAL( jj - ind1 ) * z1_spongearea * vmask(ji,ind2-1,1) )
193            END DO
194         ENDDO
195      ENDIF
196      !
197   END SUBROUTINE agrif_connection
198
199#else
200   SUBROUTINE agrif_boundary_connections
201   END SUBROUTINE agrif_boundary_connections
202#endif
203
204END MODULE agrif_connect
Note: See TracBrowser for help on using the repository browser.