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

Last change on this file since 13109 was 13109, checked in by rblod, 4 months ago

ticket #2129 : major corrections in domcfg

File size: 8.5 KB
RevLine 
[13056]1MODULE agrif_connect
[10727]2
[13056]3   USE dom_oce
4   USE domzgr
5   USE agrif_parameters
6   USE agrif_profiles
[10727]7
[13056]8   IMPLICIT NONE
9   PRIVATE
[10727]10
[13056]11   PUBLIC agrif_boundary_connections 
[10727]12
[13056]13CONTAINS
[10727]14
[13056]15#if defined key_agrif
[10727]16
[13056]17   SUBROUTINE agrif_boundary_connections
18      !!----------------------------------------------------------------------
19      !!                  ***  ROUTINE agrif_boundary_connections  ***
20      !!---------------------------------------------------------------------- 
21      IF( Agrif_Root() ) return
22
23      CALL agrif_connection()
[10727]24      !
[13056]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.
[13109]31      Agrif_UseSpecialValue = .FALSE.
[13056]32      Agrif_SpecialValue = 0.
33      CALL Agrif_Bc_variable(e3t_connect_id, procname = connect_e3t_connect)
[10727]34      Agrif_UseSpecialValue = .FALSE.
[13056]35      !   
36   END SUBROUTINE agrif_boundary_connections
[10727]37
[13056]38   SUBROUTINE connect_e3t_copy( ptab, i1, i2, j1, j2, k1, k2, before, nb,ndir)
[10727]39      !!----------------------------------------------------------------------
[13056]40      !!                  ***  ROUTINE connect_e3t_copy  ***
[10727]41      !!---------------------------------------------------------------------- 
[13056]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
[10727]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   
[13056]57   SUBROUTINE connect_bottom_level( ptab, i1, i2, j1, j2, before, nb,ndir)
[10727]58      !!----------------------------------------------------------------------
[13056]59      !!                  ***  ROUTINE connect_bottom_level  ***
[10727]60      !!---------------------------------------------------------------------- 
61      INTEGER                         , INTENT(in   ) ::   i1, i2, j1, j2
[13056]62      REAL(wp), DIMENSION(i1:i2,j1:j2), INTENT(inout) ::   ptab
[10727]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.
[13024]74         ELSEWHERE
75           ssmask(i1:i2,j1:j2) = 1.
[13056]76         END WHERE           
[10727]77      ENDIF
78      !
79   END SUBROUTINE connect_bottom_level
80   
[13056]81   SUBROUTINE connect_e3t_connect( ptab, i1, i2, j1, j2, k1, k2, before, nb,ndir)
[10727]82      !!----------------------------------------------------------------------
[13056]83      !!                  ***  ROUTINE connect_e3t_connect  ***
[10727]84      !!---------------------------------------------------------------------- 
[13056]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
[10727]89      !
90      !!----------------------------------------------------------------------
[13056]91      INTEGER :: ji, jj, jk 
[13109]92      REAL(wp), DIMENSION(i1:i2,j1:j2) :: bathy_local, bathy_interp
93      REAL(wp) :: zdepth, zmax 
[10727]94      !
95      IF( before) THEN
[13024]96         DO jk=1,jpk
[10727]97            DO jj=j1,j2
98               DO ji=i1,i2
[13056]99                  IF( mbkt(ji,jj) .GE. jk ) THEN
100                     ptab(ji,jj,jk) = e3t_0(ji,jj,jk)
101                  ELSE
102                     ptab(ji,jj,jk) = 0.
103                  ENDIF
[10727]104               END DO
105            END DO
106         END DO
[13056]107         !
108         DO jj=j1,j2
109            DO ji=i1,i2
110               ptab(ji,jj,jpk+1) = SUM ( e3t_0(ji,jj, 1:mbkt(ji,jj) ) ) * ssmask(ji,jj)
111            END DO
112         END DO
[10727]113      ELSE
[13056]114         DO jj=j1,j2
115            DO ji=i1,i2
116               bathy_local (ji,jj) = SUM ( e3t_0(ji,jj, 1:mbkt(ji,jj) ) ) * ssmask(ji,jj)
[13109]117               bathy_interp (ji,jj) = ptab(ji,jj,jpk+1)
118
119        ! Connected bathymetry
120               bathy_local(ji,jj)=(1.-ztabramp(ji,jj))*bathy_local(ji,jj)+ztabramp(ji,jj)*bathy_interp(ji,jj)
[10727]121            END DO
122         END DO
[13109]123
124        ! Update mbkt and ssmask
125         zmax = gdepw_1d(jpk) + e3t_1d(jpk)
126         bathy_local(:,:) = MAX(MIN(zmax,bathy_local(:,:)),0._wp)
127         WHERE( bathy_local(i1:i2,j1:j2) == 0._wp); mbathy(i1:i2,j1:j2) = 0
128         ELSE WHERE                       ; mbathy(i1:i2,j1:j2) = jpkm1
129         END WHERE
130
131         DO jk=jpkm1,1,-1
132           zdepth = gdepw_1d(jk)+MIN(e3zps_min,e3t_1d(jk)*e3zps_rat)
133           WHERE( 0._wp < bathy_local(:,:) .AND. bathy_local(:,:) <= zdepth ) mbathy(i1:i2,j1:j2) = jk-1
134         ENDDO
135
136         WHERE (mbathy(i1:i2,j1:j2) == 0); ssmask(i1:i2,j1:j2) = 0
137         ELSE WHERE                      ; ssmask(i1:i2,j1:j2) = 1.
138         END WHERE
139         
140         mbkt(i1:i2,j1:j2) = MAX( mbathy(i1:i2,j1:j2), 1 )
141
[13056]142         !
143         DO jk=1,jpk
144            DO jj=j1,j2
145               DO ji=i1,i2
146                  IF( e3t_interp(ji,jj,jk) == -10 ) THEN ! the connection has not yet been done
147                     e3t_interp(ji,jj,jk) = MAX( ptab(ji,jj,jk),MIN(e3zps_min, e3t_1d(jk)*e3zps_rat) )
148                     e3t_interp(ji,jj,jk) = MIN( e3t_interp(ji,jj,jk),e3t_1d(jk) )
[13104]149                     e3t_0(ji,jj,jk) = ( 1. - ztabramp(ji,jj) )*e3t_0(ji,jj,jk) + ztabramp(ji,jj)*e3t_interp(ji,jj,jk)
[13056]150                  ENDIF
[13109]151                  IF( jk > mbkt(ji,jj)) THEN
152                    e3t_0(ji,jj,jk) = e3t_1d(jk)
153                  ENDIF
[13056]154             END DO
155           END DO
156         END DO
[10727]157      ENDIF
[13056]158      !
159   END SUBROUTINE connect_e3t_connect
[10727]160   
[13056]161   SUBROUTINE agrif_connection
[10727]162      !!----------------------------------------------------------------------
[13056]163      !!                 *** ROUTINE  Agrif_connection ***
[10727]164      !!----------------------------------------------------------------------
[13056]165      INTEGER  ::   ji, jj, ind1, ind2
166      INTEGER  ::   ispongearea, istart
167      REAL(wp) ::   z1_spongearea
168      !!----------------------------------------------------------------------
[10727]169      !
[13056]170      ! Define ramp from boundaries towards domain interior at T-points
171      ! Store it in ztabramp
172
173      ALLOCATE(ztabramp(jpi,jpj))
174      ispongearea = 1 + npt_connect * Agrif_irhox()
175      istart = npt_copy * Agrif_irhox()
176      z1_spongearea = 1._wp / REAL( ispongearea, wp )
177     
178      ztabramp(:,:) = 0._wp
179
180      ! --- West --- !
181      IF( ((nbondi == -1) .OR. (nbondi == 2) ).AND. .NOT. (jperio == 1 .OR. jperio == 4 .OR. jperio == 6)) THEN
182         ind1 = 1+nbghostcells + istart
183         ind2 = ind1 + ispongearea 
184         DO jj = 1, jpj
185            DO ji = ind1, ind2               
186               ztabramp(ji,jj) = REAL( ind2 - ji ) * z1_spongearea * umask(ind1,jj,1)
[10727]187            END DO
[13056]188         ENDDO
189      ENDIF
[10727]190
[13056]191      ! --- East --- !
192      IF( ((nbondi == 1) .OR. (nbondi == 2) ).AND. .NOT. (jperio == 1 .OR. jperio == 4 .OR. jperio == 6)) THEN
193         ind2 = nlci - nbghostcells - istart
194         ind1 = ind2 -ispongearea       
195         DO jj = 1, jpj
196            DO ji = ind1, ind2
197               ztabramp(ji,jj) = MAX( ztabramp(ji,jj), REAL( ji - ind1 ) * z1_spongearea * umask(ind2-1,jj,1) )
198            ENDDO
199         ENDDO
200      ENDIF
[10727]201
[13056]202      ! --- South --- !
203      IF(( (nbondj == -1) .OR. (nbondj == 2) ).AND.(ln_bry_south)) THEN
204         ind1 = 1+nbghostcells + istart
205         ind2 = ind1 + ispongearea 
206         DO jj = ind1, ind2 
207            DO ji = 1, jpi
208               ztabramp(ji,jj) = MAX( ztabramp(ji,jj), REAL( ind2 - jj ) * z1_spongearea * vmask(ji,ind1,1) )
[10727]209            END DO
[13056]210         ENDDO
[10727]211      ENDIF
212
[13056]213      ! --- North --- !
214      IF( (nbondj == 1) .OR. (nbondj == 2) ) THEN
215         ind2 = nlcj - nbghostcells - istart
216         ind1 = ind2 -ispongearea         
217         DO jj = ind1, ind2
218            DO ji = 1, jpi
219               ztabramp(ji,jj) = MAX( ztabramp(ji,jj), REAL( jj - ind1 ) * z1_spongearea * vmask(ji,ind2-1,1) )
220            END DO
221         ENDDO
222      ENDIF
223      !
224   END SUBROUTINE agrif_connection
225
[10727]226#else
[13056]227   SUBROUTINE agrif_boundary_connections
228   END SUBROUTINE agrif_boundary_connections
229#endif
230
231END MODULE agrif_connect
Note: See TracBrowser for help on using the repository browser.