Changeset 473 for trunk/NEMO/OPA_SRC/lbclnk.F90
- Timestamp:
- 2006-05-11T17:04:37+02:00 (18 years ago)
- File:
-
- 1 edited
-
trunk/NEMO/OPA_SRC/lbclnk.F90 (modified) (9 diffs)
Legend:
- Unmodified
- Added
- Removed
-
trunk/NEMO/OPA_SRC/lbclnk.F90
r311 r473 19 19 20 20 INTERFACE lbc_lnk 21 MODULE PROCEDURE mpp_lnk_3d , mpp_lnk_2d21 MODULE PROCEDURE mpp_lnk_3d_gather, mpp_lnk_3d, mpp_lnk_2d 22 22 END INTERFACE 23 23 … … 49 49 50 50 INTERFACE lbc_lnk 51 MODULE PROCEDURE lbc_lnk_3d , lbc_lnk_2d51 MODULE PROCEDURE lbc_lnk_3d_gather, lbc_lnk_3d, lbc_lnk_2d 52 52 END INTERFACE 53 53 … … 62 62 CONTAINS 63 63 64 SUBROUTINE lbc_lnk_3d( pt3d, cd_type, psgn ) 64 SUBROUTINE lbc_lnk_3d_gather( pt3d1, cd_type1, pt3d2, cd_type2, psgn ) 65 !!--------------------------------------------------------------------- 66 !! *** ROUTINE lbc_lnk_3d_gather *** 67 !! 68 !! ** Purpose : set lateral boundary conditions (non mpp case) 69 !! 70 !! ** Method : 71 !! 72 !! History : 73 !! ! 97-06 (G. Madec) Original code 74 !! 8.5 ! 02-09 (G. Madec) F90: Free form and module 75 !!---------------------------------------------------------------------- 76 !! * Arguments 77 CHARACTER(len=1), INTENT( in ) :: & 78 cd_type1, cd_type2 ! nature of pt3d grid-points 79 ! ! = T , U , V , F or W gridpoints 80 REAL(wp), DIMENSION(jpi,jpj,jpk), INTENT( inout ) :: & 81 pt3d1, pt3d2 ! 3D array on which the boundary condition is applied 82 REAL(wp), INTENT( in ) :: & 83 psgn ! control of the sign change 84 ! ! =-1 , the sign is changed if north fold boundary 85 ! ! = 1 , no sign change 86 ! ! = 0 , no sign change and > 0 required (use the inner 87 ! ! row/column if closed boundary) 88 89 90 !! * Local declarations 91 INTEGER :: ji, jk 92 INTEGER :: ijt, iju 93 !!---------------------------------------------------------------------- 94 !! OPA 9.0 , LOCEAN-IPSL (2005) 95 !! $Header$ 96 !! This software is governed by the CeCILL licence see modipsl/doc/NEMO_CeCILL.txt 97 !!---------------------------------------------------------------------- 98 99 ! ! =============== 100 DO jk = 1, jpk ! Horizontal slab 101 ! ! =============== 102 103 ! ! East-West boundaries 104 ! ! ==================== 105 SELECT CASE ( nperio ) 106 107 CASE ( 1 , 4 , 6 ) ! * cyclic east-west 108 pt3d1( 1 ,:,jk) = pt3d1(jpim1,:,jk) ! all points 109 pt3d1(jpi,:,jk) = pt3d1( 2 ,:,jk) 110 pt3d2( 1 ,:,jk) = pt3d2(jpim1,:,jk) 111 pt3d2(jpi,:,jk) = pt3d2( 2 ,:,jk) 112 113 CASE DEFAULT ! * closed 114 SELECT CASE ( cd_type1 ) 115 CASE ( 'T' , 'U' , 'V' , 'W' ) ! T-, U-, V-, W-points 116 pt3d1( 1 ,:,jk) = 0.e0 117 pt3d1(jpi,:,jk) = 0.e0 118 CASE ( 'F' ) ! F-point 119 pt3d1(jpi,:,jk) = 0.e0 120 END SELECT 121 SELECT CASE ( cd_type2 ) 122 CASE ( 'T' , 'U' , 'V' , 'W' ) ! T-, U-, V-, W-points 123 pt3d2( 1 ,:,jk) = 0.e0 124 pt3d2(jpi,:,jk) = 0.e0 125 CASE ( 'F' ) ! F-point 126 pt3d2(jpi,:,jk) = 0.e0 127 END SELECT 128 129 END SELECT 130 131 ! ! North-South boundaries 132 ! ! ====================== 133 SELECT CASE ( nperio ) 134 135 CASE ( 2 ) ! * south symmetric 136 137 SELECT CASE ( cd_type1 ) 138 CASE ( 'T' , 'U' , 'W' ) ! T-, U-, W-points 139 pt3d1(:, 1 ,jk) = pt3d1(:,3,jk) 140 pt3d1(:,jpj,jk) = 0.e0 141 CASE ( 'V' , 'F' ) ! V-, F-points 142 pt3d1(:, 1 ,jk) = psgn * pt3d1(:,2,jk) 143 pt3d1(:,jpj,jk) = 0.e0 144 END SELECT 145 SELECT CASE ( cd_type2 ) 146 CASE ( 'T' , 'U' , 'W' ) ! T-, U-, W-points 147 pt3d2(:, 1 ,jk) = pt3d2(:,3,jk) 148 pt3d2(:,jpj,jk) = 0.e0 149 CASE ( 'V' , 'F' ) ! V-, F-points 150 pt3d2(:, 1 ,jk) = psgn * pt3d2(:,2,jk) 151 pt3d2(:,jpj,jk) = 0.e0 152 END SELECT 153 154 CASE ( 3 , 4 ) ! * North fold T-point pivot 155 156 pt3d1( 1 ,jpj,jk) = 0.e0 157 pt3d1(jpi,jpj,jk) = 0.e0 158 pt3d2( 1 ,jpj,jk) = 0.e0 159 pt3d2(jpi,jpj,jk) = 0.e0 160 161 SELECT CASE ( cd_type1 ) 162 CASE ( 'T' , 'W' ) ! T-, W-point 163 DO ji = 2, jpi 164 ijt = jpi-ji+2 165 pt3d1(ji, 1 ,jk) = 0.e0 166 pt3d1(ji,jpj,jk) = psgn * pt3d1(ijt,jpj-2,jk) 167 END DO 168 DO ji = jpi/2+1, jpi 169 ijt = jpi-ji+2 170 pt3d1(ji,jpjm1,jk) = psgn * pt3d1(ijt,jpjm1,jk) 171 END DO 172 CASE ( 'U' ) ! U-point 173 DO ji = 1, jpi-1 174 iju = jpi-ji+1 175 pt3d1(ji, 1 ,jk) = 0.e0 176 pt3d1(ji,jpj,jk) = psgn * pt3d1(iju,jpj-2,jk) 177 END DO 178 DO ji = jpi/2, jpi-1 179 iju = jpi-ji+1 180 pt3d1(ji,jpjm1,jk) = psgn * pt3d1(iju,jpjm1,jk) 181 END DO 182 CASE ( 'V' ) ! V-point 183 DO ji = 2, jpi 184 ijt = jpi-ji+2 185 pt3d1(ji, 1 ,jk) = 0.e0 186 pt3d1(ji,jpj-1,jk) = psgn * pt3d1(ijt,jpj-2,jk) 187 pt3d1(ji,jpj ,jk) = psgn * pt3d1(ijt,jpj-3,jk) 188 END DO 189 CASE ( 'F' ) ! F-point 190 DO ji = 1, jpi-1 191 iju = jpi-ji+1 192 pt3d1(ji,jpj-1,jk) = psgn * pt3d1(iju,jpj-2,jk) 193 pt3d1(ji,jpj ,jk) = psgn * pt3d1(iju,jpj-3,jk) 194 END DO 195 END SELECT 196 SELECT CASE ( cd_type2 ) 197 CASE ( 'T' , 'W' ) ! T-, W-point 198 DO ji = 2, jpi 199 ijt = jpi-ji+2 200 pt3d2(ji, 1 ,jk) = 0.e0 201 pt3d2(ji,jpj,jk) = psgn * pt3d2(ijt,jpj-2,jk) 202 END DO 203 DO ji = jpi/2+1, jpi 204 ijt = jpi-ji+2 205 pt3d2(ji,jpjm1,jk) = psgn * pt3d2(ijt,jpjm1,jk) 206 END DO 207 CASE ( 'U' ) ! U-point 208 DO ji = 1, jpi-1 209 iju = jpi-ji+1 210 pt3d2(ji, 1 ,jk) = 0.e0 211 pt3d2(ji,jpj,jk) = psgn * pt3d2(iju,jpj-2,jk) 212 END DO 213 DO ji = jpi/2, jpi-1 214 iju = jpi-ji+1 215 pt3d2(ji,jpjm1,jk) = psgn * pt3d2(iju,jpjm1,jk) 216 END DO 217 CASE ( 'V' ) ! V-point 218 DO ji = 2, jpi 219 ijt = jpi-ji+2 220 pt3d2(ji, 1 ,jk) = 0.e0 221 pt3d2(ji,jpj-1,jk) = psgn * pt3d2(ijt,jpj-2,jk) 222 pt3d2(ji,jpj ,jk) = psgn * pt3d2(ijt,jpj-3,jk) 223 END DO 224 CASE ( 'F' ) ! F-point 225 DO ji = 1, jpi-1 226 iju = jpi-ji+1 227 pt3d2(ji,jpj-1,jk) = psgn * pt3d2(iju,jpj-2,jk) 228 pt3d2(ji,jpj ,jk) = psgn * pt3d2(iju,jpj-3,jk) 229 END DO 230 END SELECT 231 232 CASE ( 5 , 6 ) ! * North fold F-point pivot 233 234 pt3d1( 1 ,jpj,jk) = 0.e0 235 pt3d1(jpi,jpj,jk) = 0.e0 236 pt3d2( 1 ,jpj,jk) = 0.e0 237 pt3d2(jpi,jpj,jk) = 0.e0 238 239 SELECT CASE ( cd_type1 ) 240 CASE ( 'T' , 'W' ) ! T-, W-point 241 DO ji = 1, jpi 242 ijt = jpi-ji+1 243 pt3d1(ji, 1 ,jk) = 0.e0 244 pt3d1(ji,jpj,jk) = psgn * pt3d1(ijt,jpj-1,jk) 245 END DO 246 CASE ( 'U' ) ! U-point 247 DO ji = 1, jpi-1 248 iju = jpi-ji 249 pt3d1(ji, 1 ,jk) = 0.e0 250 pt3d1(ji,jpj,jk) = psgn * pt3d1(iju,jpj-1,jk) 251 END DO 252 CASE ( 'V' ) ! V-point 253 DO ji = 1, jpi 254 ijt = jpi-ji+1 255 pt3d1(ji, 1 ,jk) = 0.e0 256 pt3d1(ji,jpj,jk) = psgn * pt3d1(ijt,jpj-2,jk) 257 END DO 258 DO ji = jpi/2+1, jpi 259 ijt = jpi-ji+1 260 pt3d1(ji,jpjm1,jk) = psgn * pt3d1(ijt,jpjm1,jk) 261 END DO 262 CASE ( 'F' ) ! F-point 263 DO ji = 1, jpi-1 264 iju = jpi-ji 265 pt3d1(ji,jpj ,jk) = psgn * pt3d1(iju,jpj-2,jk) 266 END DO 267 DO ji = jpi/2+1, jpi-1 268 iju = jpi-ji 269 pt3d1(ji,jpjm1,jk) = psgn * pt3d1(iju,jpjm1,jk) 270 END DO 271 END SELECT 272 SELECT CASE ( cd_type2 ) 273 CASE ( 'T' , 'W' ) ! T-, W-point 274 DO ji = 1, jpi 275 ijt = jpi-ji+1 276 pt3d2(ji, 1 ,jk) = 0.e0 277 pt3d2(ji,jpj,jk) = psgn * pt3d2(ijt,jpj-1,jk) 278 END DO 279 CASE ( 'U' ) ! U-point 280 DO ji = 1, jpi-1 281 iju = jpi-ji 282 pt3d2(ji, 1 ,jk) = 0.e0 283 pt3d2(ji,jpj,jk) = psgn * pt3d2(iju,jpj-1,jk) 284 END DO 285 CASE ( 'V' ) ! V-point 286 DO ji = 1, jpi 287 ijt = jpi-ji+1 288 pt3d2(ji, 1 ,jk) = 0.e0 289 pt3d2(ji,jpj,jk) = psgn * pt3d2(ijt,jpj-2,jk) 290 END DO 291 DO ji = jpi/2+1, jpi 292 ijt = jpi-ji+1 293 pt3d2(ji,jpjm1,jk) = psgn * pt3d2(ijt,jpjm1,jk) 294 END DO 295 CASE ( 'F' ) ! F-point 296 DO ji = 1, jpi-1 297 iju = jpi-ji 298 pt3d2(ji,jpj ,jk) = psgn * pt3d2(iju,jpj-2,jk) 299 END DO 300 DO ji = jpi/2+1, jpi-1 301 iju = jpi-ji 302 pt3d2(ji,jpjm1,jk) = psgn * pt3d2(iju,jpjm1,jk) 303 END DO 304 END SELECT 305 306 CASE DEFAULT ! * closed 307 308 SELECT CASE ( cd_type1 ) 309 CASE ( 'T' , 'U' , 'V' , 'W' ) ! T-, U-, V-, W-points 310 pt3d1(:, 1 ,jk) = 0.e0 311 pt3d1(:,jpj,jk) = 0.e0 312 CASE ( 'F' ) ! F-point 313 pt3d1(:,jpj,jk) = 0.e0 314 END SELECT 315 SELECT CASE ( cd_type2 ) 316 CASE ( 'T' , 'U' , 'V' , 'W' ) ! T-, U-, V-, W-points 317 pt3d2(:, 1 ,jk) = 0.e0 318 pt3d2(:,jpj,jk) = 0.e0 319 CASE ( 'F' ) ! F-point 320 pt3d2(:,jpj,jk) = 0.e0 321 END SELECT 322 323 END SELECT 324 ! ! =============== 325 END DO ! End of slab 326 ! ! =============== 327 328 END SUBROUTINE lbc_lnk_3d_gather 329 330 331 SUBROUTINE lbc_lnk_3d( pt3d, cd_type, psgn, cd_mpp ) 65 332 !!--------------------------------------------------------------------- 66 333 !! *** ROUTINE lbc_lnk_3d *** … … 86 353 ! ! = 0 , no sign change and > 0 required (use the inner 87 354 ! ! row/column if closed boundary) 355 CHARACTER(len=3), INTENT( in ), OPTIONAL :: & 356 cd_mpp ! fill the overlap area only (here do nothing) 88 357 89 358 !! * Local declarations … … 95 364 !! This software is governed by the CeCILL licence see modipsl/doc/NEMO_CeCILL.txt 96 365 !!---------------------------------------------------------------------- 366 367 IF (PRESENT(cd_mpp)) THEN 368 ! only fill the overlap area and extra allows 369 ! this is in mpp case. In this module, just do nothing 370 ELSE 97 371 98 372 ! ! =============== … … 228 502 END DO ! End of slab 229 503 ! ! =============== 504 ENDIF 230 505 END SUBROUTINE lbc_lnk_3d 231 506 232 507 233 SUBROUTINE lbc_lnk_2d( pt2d, cd_type, psgn )508 SUBROUTINE lbc_lnk_2d( pt2d, cd_type, psgn, cd_mpp ) 234 509 !!--------------------------------------------------------------------- 235 510 !! *** ROUTINE lbc_lnk_2d *** … … 255 530 REAL(wp), DIMENSION(jpi,jpj), INTENT( inout ) :: & 256 531 pt2d ! 2D array on which the boundary condition is applied 532 CHARACTER(len=3), INTENT( in ), OPTIONAL :: & 533 cd_mpp ! fill the overlap area only (here do nothing) 257 534 258 535 !! * Local declarations … … 262 539 !! OPA 8.5, LODYC-IPSL (2002) 263 540 !!---------------------------------------------------------------------- 264 541 542 IF (PRESENT(cd_mpp)) THEN 543 ! only fill the overlap area and extra allows 544 ! this is in mpp case. In this module, just do nothing 545 ELSE 265 546 266 547 ! ! East-West boundaries … … 424 705 END SELECT 425 706 707 ENDIF 708 426 709 END SUBROUTINE lbc_lnk_2d 427 710
Note: See TracChangeset
for help on using the changeset viewer.
