- Timestamp:
- 2020-06-07T18:26:09+02:00 (4 years ago)
- File:
-
- 1 moved
Legend:
- Unmodified
- Added
- Removed
-
utils/tools_dev_r12970_AGRIF_CMEMS/DOMAINcfg/src/agrif_connect.F90
r13055 r13056 1 MODULE 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 13 CONTAINS 14 1 15 #if defined key_agrif 2 subroutine agrif_boundary_connections 3 use agrif_profiles 4 use agrif_parameters 5 implicit none 6 external connect_e3t_copy, connect_e3t_connect, connect_bottom_level,connect_e3u, connect_e3v 7 if (agrif_root()) return 8 9 call Agrif_connection() 10 11 call Agrif_Bc_variable(bottom_level_id, procname = connect_bottom_level) 12 13 call Agrif_Bc_variable(e3t_copy_id, procname = connect_e3t_copy) 14 15 Allocate(e3t_interp(jpi,jpj,jpk)) 16 e3t_interp = -10. 17 Agrif_UseSpecialValue = .TRUE. 18 Agrif_SpecialValue = 0. 19 call Agrif_Bc_variable(e3t_connect_id, procname = connect_e3t_connect) 20 Agrif_UseSpecialValue = .FALSE. 21 22 ! Call Agrif_make_connection() 23 24 Agrif_SpecialValue = 0. 25 Agrif_UseSpecialValue = ln_spc_dyn 26 ! 27 ! CALL Agrif_Bc_variable( e3u_id, procname=connect_e3u ) 28 ! CALL Agrif_Bc_variable( e3v_id, procname=connect_e3v ) 29 ! 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) 30 34 Agrif_UseSpecialValue = .FALSE. 31 32 end subroutine agrif_boundary_connections 33 34 35 SUBROUTINE connect_e3t_copy( ptab, i1, i2, j1, j2, k1, k2, before, nb,ndir) 36 USE dom_oce 37 USE domzgr 38 USE agrif_parameters 39 !!---------------------------------------------------------------------- 40 !! *** ROUTINE interpsshn *** 41 !!---------------------------------------------------------------------- 42 INTEGER , INTENT(in ) :: i1, i2, j1, j2, k1, k2 43 REAL, DIMENSION(i1:i2,j1:j2,k1:k2), INTENT(inout) :: ptab 44 LOGICAL , INTENT(in ) :: before 45 INTEGER , INTENT(in ) :: nb , ndir 46 LOGICAL :: western_side, eastern_side,northern_side,southern_side 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 47 46 ! 48 47 !!---------------------------------------------------------------------- 49 INTEGER :: ji,jj,jk 50 ! 51 western_side = (nb == 1).AND.(ndir == 1) 52 eastern_side = (nb == 1).AND.(ndir == 2) 53 southern_side = (nb == 2).AND.(ndir == 1) 54 northern_side = (nb == 2).AND.(ndir == 2) 55 48 ! 56 49 IF( before) THEN 57 50 ptab(i1:i2,j1:j2,k1:k2) = e3t_0(i1:i2,j1:j2,k1:k2) … … 62 55 END SUBROUTINE connect_e3t_copy 63 56 64 SUBROUTINE connect_bottom_level( ptab, i1, i2, j1, j2, before, nb,ndir) 65 USE dom_oce 66 USE domzgr 67 !!---------------------------------------------------------------------- 68 !! *** ROUTINE interpsshn *** 57 SUBROUTINE connect_bottom_level( ptab, i1, i2, j1, j2, before, nb,ndir) 58 !!---------------------------------------------------------------------- 59 !! *** ROUTINE connect_bottom_level *** 69 60 !!---------------------------------------------------------------------- 70 61 INTEGER , INTENT(in ) :: i1, i2, j1, j2 71 REAL , DIMENSION(i1:i2,j1:j2), INTENT(inout) :: ptab62 REAL(wp), DIMENSION(i1:i2,j1:j2), INTENT(inout) :: ptab 72 63 LOGICAL , INTENT(in ) :: before 73 64 INTEGER , INTENT(in ) :: nb , ndir 74 LOGICAL :: western_side, eastern_side,northern_side,southern_side75 65 ! 76 66 !!---------------------------------------------------------------------- 77 INTEGER :: ji,jj 78 ! 79 western_side = (nb == 1).AND.(ndir == 1) 80 eastern_side = (nb == 1).AND.(ndir == 2) 81 southern_side = (nb == 2).AND.(ndir == 1) 82 northern_side = (nb == 2).AND.(ndir == 2) 83 67 ! 84 68 IF( before) THEN 85 69 ptab(i1:i2,j1:j2) = mbkt(i1:i2,j1:j2)*ssmask(i1:i2,j1:j2) … … 90 74 ELSEWHERE 91 75 ssmask(i1:i2,j1:j2) = 1. 92 END WHERE 93 76 END WHERE 94 77 ENDIF 95 78 ! 96 79 END SUBROUTINE connect_bottom_level 97 80 98 SUBROUTINE connect_e3t_connect( ptab, i1, i2, j1, j2, k1, k2, before, nb,ndir) 99 USE dom_oce 100 USE domzgr 101 !!---------------------------------------------------------------------- 102 !! *** ROUTINE interpsshn *** 103 !!---------------------------------------------------------------------- 104 INTEGER , INTENT(in ) :: i1, i2, j1, j2, k1, k2 105 REAL, DIMENSION(i1:i2,j1:j2,k1:k2), INTENT(inout) :: ptab 106 LOGICAL , INTENT(in ) :: before 107 INTEGER , INTENT(in ) :: nb , ndir 108 LOGICAL :: western_side, eastern_side,northern_side,southern_side 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 109 89 ! 110 90 !!---------------------------------------------------------------------- 111 INTEGER :: ji,jj,jk 112 REAL,DIMENSION(i1:i2,j1:j2) :: bathy_local 113 ! 114 western_side = (nb == 1).AND.(ndir == 1) 115 eastern_side = (nb == 1).AND.(ndir == 2) 116 southern_side = (nb == 2).AND.(ndir == 1) 117 northern_side = (nb == 2).AND.(ndir == 2) 118 91 INTEGER :: ji, jj, jk 92 REAL(wp), DIMENSION(i1:i2,j1:j2) :: bathy_local 93 ! 119 94 IF( before) THEN 120 do jk=1,jpk121 do jj=j1,j2122 do ji=i1,i2123 if (mbkt(ji,jj)>=jk) then124 ptab(ji,jj,jk) = e3t_0(ji,jj,jk)125 else126 ptab(ji,jj,jk) = 0.127 endif128 enddo129 enddo130 enddo131 132 do jj=j1,j2133 do ji=i1,i2134 ptab(ji,jj,jpk+1) = SUM ( e3t_0(ji,jj, 1:mbkt(ji,jj) ) ) * ssmask(ji,jj)135 enddo136 enddo137 138 ELSE139 do jj=j1,j2140 do ji=i1,i2141 bathy_local (ji,jj) = SUM ( e3t_0(ji,jj, 1:mbkt(ji,jj) ) ) * ssmask(ji,jj)142 enddo143 enddo144 145 DO jk=1,jpk146 DO jj=j1,j2147 DO ji=i1,i2148 if (e3t_interp(ji,jj,jk) == -10) then ! the connection has not yet been done149 e3t_interp(ji,jj,jk) = MAX(ptab(ji,jj,jk),MIN(e3zps_min, e3t_1d(jk)*e3zps_rat ))150 e3t_interp(ji,jj,jk) = MIN(e3t_interp(ji,jj,jk),e3t_1d(jk))151 e3t_0(ji,jj,jk) = ztabramp(ji,jj)*e3t_0(ji,jj,jk)+(1.-ztabramp(ji,jj))*e3t_interp(ji,jj,jk)152 endif153 ENDDO154 ENDDO155 ENDDO156 ENDIF157 !158 END SUBROUTINE connect_e3t_connect159 160 SUBROUTINE connect_e3u( ptab, i1, i2, j1, j2, k1, k2,before, nb, ndir )161 USE dom_oce162 !!----------------------------------------------------------------------163 !! *** ROUTINE interpun ***164 !!---------------------------------------------165 !!166 INTEGER, INTENT(in) :: i1,i2,j1,j2,k1,k2167 REAL(wp), DIMENSION(i1:i2,j1:j2,k1:k2), INTENT(inout) :: ptab168 LOGICAL, INTENT(in) :: before169 INTEGER, INTENT(in) :: nb , ndir170 !!171 INTEGER :: ji,jj,jk172 REAL(wp) :: zrhoy173 ! vertical interpolation:174 REAL(wp), DIMENSION(k1:k2) :: tabin, h_in175 REAL(wp), DIMENSION(1:jpk) :: h_out176 INTEGER :: N_in, N_out, iref177 REAL(wp) :: h_diff178 LOGICAL :: western_side, eastern_side179 !!---------------------------------------------180 !181 IF (before) THEN182 95 DO jk=1,jpk 183 96 DO jj=j1,j2 184 97 DO ji=i1,i2 185 if (min(mbkt(ji,jj),mbkt(ji+1,jj))<jk) then 186 ptab(ji,jj,jk) = 0. 187 else 188 ptab(ji,jj,jk) = e2u(ji,jj) * e3u_0(ji,jj,jk) 189 endif 190 # if defined key_vertical 191 ptab(ji,jj,jk,2) = (umask(ji,jj,jk) * e2u(ji,jj) * e3u_n(ji,jj,jk)) 192 # endif 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 193 103 END DO 194 104 END DO 195 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 196 112 ELSE 197 zrhoy = Agrif_rhoy() 198 # if defined key_vertical 199 ! VERTICAL REFINEMENT BEGIN 200 western_side = (nb == 1).AND.(ndir == 1) 201 eastern_side = (nb == 1).AND.(ndir == 2) 202 203 DO ji=i1,i2 204 iref = ji 205 IF (western_side) iref = MAX(2,ji) 206 IF (eastern_side) iref = MIN(nlci-2,ji) 207 DO jj=j1,j2 208 N_in = 0 209 DO jk=k1,k2 210 IF (ptab(ji,jj,jk,2) == 0) EXIT 211 N_in = N_in + 1 212 tabin(jk) = ptab(ji,jj,jk,1)/ptab(ji,jj,jk,2) 213 h_in(N_in) = ptab(ji,jj,jk,2)/(e2u(ji,jj)*zrhoy) 214 ENDDO 215 216 IF (N_in == 0) THEN 217 ua(ji,jj,:) = 0._wp 218 CYCLE 219 ENDIF 220 221 N_out = 0 222 DO jk=1,jpk 223 if (umask(iref,jj,jk) == 0) EXIT 224 N_out = N_out + 1 225 h_out(N_out) = e3u_a(iref,jj,jk) 226 ENDDO 227 228 IF (N_out == 0) THEN 229 ua(ji,jj,:) = 0._wp 230 CYCLE 231 ENDIF 232 233 IF (N_in * N_out > 0) THEN 234 h_diff = sum(h_out(1:N_out))-sum(h_in(1:N_in)) 235 ! Should be able to remove the next IF/ELSEIF statement once scale factors are dealt with properly 236 if (h_diff < -1.e4) then 237 print *,'CHECK YOUR BATHY ...', h_diff, sum(h_out(1:N_out)), sum(h_in(1:N_in)) 238 ! stop 239 endif 240 ENDIF 241 call reconstructandremap(tabin(1:N_in),h_in(1:N_in),ua(ji,jj,1:N_out),h_out(1:N_out),N_in,N_out) 242 ENDDO 243 ENDDO 244 245 # else 246 DO jk = 1, jpkm1 247 DO jj=j1,j2 248 do ji=i1,i2 249 if (min(mbkt(ji+1,jj),mbkt(ji,jj))<jk) then 250 e3u_0(ji,jj,jk)=e3t_1d(jk) 251 else 252 e3u_0(ji,jj,jk) = MAX(ptab(ji,jj,jk) / ( zrhoy * e2u(ji,jj) ),MIN(e3zps_min,e3t_1d(jk)*e3zps_rat)) 253 endif 254 enddo 255 256 END DO 257 END DO 258 # endif 259 260 ENDIF 261 ! 262 END SUBROUTINE connect_e3u 263 264 SUBROUTINE connect_e3v( ptab, i1, i2, j1, j2, k1, k2, before, nb, ndir ) 265 USE dom_oce 266 !!---------------------------------------------------------------------- 267 !! *** ROUTINE interpvn *** 268 !!---------------------------------------------------------------------- 269 ! 270 INTEGER, INTENT(in) :: i1,i2,j1,j2,k1,k2 271 REAL(wp), DIMENSION(i1:i2,j1:j2,k1:k2), INTENT(inout) :: ptab 272 LOGICAL, INTENT(in) :: before 273 INTEGER, INTENT(in) :: nb , ndir 274 ! 275 INTEGER :: ji,jj,jk 276 REAL(wp) :: zrhox 277 ! vertical interpolation: 278 REAL(wp), DIMENSION(k1:k2) :: tabin, h_in 279 REAL(wp), DIMENSION(1:jpk) :: h_out 280 INTEGER :: N_in, N_out, jref 281 REAL(wp) :: h_diff 282 LOGICAL :: northern_side,southern_side 283 !!--------------------------------------------- 284 ! 285 IF (before) THEN 286 DO jk=k1,k2 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 287 120 DO jj=j1,j2 288 121 DO ji=i1,i2 289 if (min(mbkt(ji,jj),mbkt(ji,jj+1))<jk) then 290 ptab(ji,jj,jk) = 0. 291 else 292 ptab(ji,jj,jk) = (e1v(ji,jj) * e3v_0(ji,jj,jk)) 293 endif 294 # if defined key_vertical 295 ptab(ji,jj,jk,2) = vmask(ji,jj,jk) * e1v(ji,jj) * e3v_n(ji,jj,jk) 296 # endif 297 END DO 298 END DO 299 END DO 300 ELSE 301 zrhox = Agrif_rhox() 302 # if defined key_vertical 303 304 southern_side = (nb == 2).AND.(ndir == 1) 305 northern_side = (nb == 2).AND.(ndir == 2) 306 307 DO jj=j1,j2 308 jref = jj 309 IF (southern_side) jref = MAX(2,jj) 310 IF (northern_side) jref = MIN(nlcj-2,jj) 311 DO ji=i1,i2 312 N_in = 0 313 DO jk=k1,k2 314 if (ptab(ji,jj,jk,2) == 0) EXIT 315 N_in = N_in + 1 316 tabin(jk) = ptab(ji,jj,jk,1)/ptab(ji,jj,jk,2) 317 h_in(N_in) = ptab(ji,jj,jk,2)/(e1v(ji,jj)*zrhox) 318 END DO 319 IF (N_in == 0) THEN 320 va(ji,jj,:) = 0._wp 321 CYCLE 322 ENDIF 323 324 N_out = 0 325 DO jk=1,jpk 326 if (vmask(ji,jref,jk) == 0) EXIT 327 N_out = N_out + 1 328 h_out(N_out) = e3v_a(ji,jref,jk) 329 END DO 330 IF (N_out == 0) THEN 331 va(ji,jj,:) = 0._wp 332 CYCLE 333 ENDIF 334 call reconstructandremap(tabin(1:N_in),h_in(1:N_in),va(ji,jj,1:N_out),h_out(1:N_out),N_in,N_out) 335 END DO 336 END DO 337 # else 338 DO jk = 1, jpkm1 339 DO jj=j1,j2 340 DO ji=i1,i2 341 if (min(mbkt(ji,jj),mbkt(ji,jj+1))<jk) then 342 e3v_0(ji,jj,jk)=e3t_1d(jk) 343 else 344 e3v_0(ji,jj,jk) = MAX(ptab(ji,jj,jk) / ( zrhox * e1v(ji,jj) ),MIN(e3zps_min,e3t_1d(jk)*e3zps_rat)) 345 endif 346 ENDDO 347 ENDDO 348 END DO 349 # endif 350 ENDIF 351 ! 352 END SUBROUTINE connect_e3v 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 353 198 354 199 #else 355 subroutine agrif_boundary_connections_empty 356 end subroutine agrif_boundary_connections_empty 200 SUBROUTINE agrif_boundary_connections 201 END SUBROUTINE agrif_boundary_connections 357 202 #endif 203 204 END MODULE agrif_connect
Note: See TracChangeset
for help on using the changeset viewer.