[1901] | 1 | ! |
---|
[8163] | 2 | ! $Id: modarrays.F 2715 2011-03-30 15:58:35Z rblod $ |
---|
[1901] | 3 | ! |
---|
| 4 | C AGRIF (Adaptive Grid Refinement In Fortran) |
---|
| 5 | C |
---|
| 6 | C Copyright (C) 2003 Laurent Debreu (Laurent.Debreu@imag.fr) |
---|
| 7 | C Christophe Vouland (Christophe.Vouland@imag.fr) |
---|
| 8 | C |
---|
| 9 | C This program is free software; you can redistribute it and/or modify |
---|
| 10 | C it under the terms of the GNU General Public License as published by |
---|
| 11 | C the Free Software Foundation; either version 2 of the License, or |
---|
| 12 | C (at your option) any later version. |
---|
| 13 | C |
---|
| 14 | C This program is distributed in the hope that it will be useful, |
---|
| 15 | C but WITHOUT ANY WARRANTY; without even the implied warranty of |
---|
| 16 | C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the |
---|
| 17 | C GNU General Public License for more details. |
---|
| 18 | C |
---|
| 19 | C You should have received a copy of the GNU General Public License |
---|
| 20 | C along with this program; if not, write to the Free Software |
---|
| 21 | C Foundation, Inc., 59 Temple Place- Suite 330, Boston, MA 02111-1307, USA. |
---|
| 22 | C |
---|
| 23 | C |
---|
| 24 | C |
---|
| 25 | CCC Module Agrif_Arrays |
---|
| 26 | C |
---|
| 27 | Module Agrif_Arrays |
---|
| 28 | Use Agrif_Types |
---|
| 29 | C |
---|
| 30 | implicit none |
---|
| 31 | C |
---|
| 32 | Contains |
---|
| 33 | C ************************************************************************** |
---|
| 34 | CCC Subroutine Agrif_Childbounds |
---|
| 35 | C ************************************************************************** |
---|
| 36 | C |
---|
| 37 | Subroutine Agrif_Childbounds(nbdim,lboundloc,uboundloc, |
---|
| 38 | & pttab,petab,pttruetab,cetruetab,memberin) |
---|
| 39 | C |
---|
| 40 | CCC Description: |
---|
| 41 | CCC Subroutine calculating the global indices of the child grid |
---|
| 42 | C |
---|
| 43 | C |
---|
| 44 | C Declarations: |
---|
| 45 | C |
---|
| 46 | |
---|
| 47 | C |
---|
| 48 | C Arguments |
---|
| 49 | INTEGER :: nbdim |
---|
| 50 | INTEGER,DIMENSION(nbdim) :: lboundloc,uboundloc |
---|
| 51 | INTEGER,DIMENSION(nbdim) :: pttab,petab,pttruetab,cetruetab |
---|
| 52 | LOGICAL :: memberin |
---|
| 53 | C |
---|
| 54 | C Local variables |
---|
| 55 | INTEGER :: i,lbglob,ubglob |
---|
| 56 | C |
---|
[2019] | 57 | #ifdef key_mpp_mpi |
---|
[1901] | 58 | INTEGER :: indglob1,indglob2 |
---|
| 59 | #endif |
---|
| 60 | C |
---|
| 61 | C |
---|
| 62 | do i = 1,nbdim |
---|
| 63 | C |
---|
| 64 | lbglob = lboundloc(i) |
---|
| 65 | ubglob = uboundloc(i) |
---|
| 66 | C |
---|
[2019] | 67 | #ifdef key_mpp_mpi |
---|
[1901] | 68 | C |
---|
| 69 | Call AGRIF_InvLoc(lbglob,Agrif_ProcRank,i,indglob1) |
---|
| 70 | C |
---|
| 71 | Call AGRIF_InvLoc(ubglob,Agrif_ProcRank,i,indglob2) |
---|
| 72 | C |
---|
| 73 | pttruetab(i) = max(pttab(i),indglob1) |
---|
| 74 | C |
---|
| 75 | cetruetab(i) = min(petab(i),indglob2) |
---|
| 76 | C |
---|
| 77 | #else |
---|
| 78 | C |
---|
| 79 | pttruetab(i) = max(pttab(i),lbglob) |
---|
| 80 | C |
---|
| 81 | cetruetab(i) = min(petab(i),ubglob) |
---|
| 82 | C |
---|
| 83 | #endif |
---|
| 84 | C |
---|
| 85 | enddo |
---|
| 86 | |
---|
| 87 | memberin = .TRUE. |
---|
| 88 | |
---|
| 89 | do i=1,nbdim |
---|
| 90 | IF (cetruetab(i) < pttruetab(i)) THEN |
---|
| 91 | memberin = .FALSE. |
---|
| 92 | EXIT |
---|
| 93 | ENDIF |
---|
| 94 | enddo |
---|
| 95 | C |
---|
| 96 | Return |
---|
| 97 | C |
---|
| 98 | C |
---|
| 99 | End Subroutine Agrif_Childbounds |
---|
| 100 | C |
---|
| 101 | C |
---|
| 102 | C ************************************************************************** |
---|
| 103 | CCC Subroutine Agrif_nbdim_Get_bound |
---|
| 104 | C ************************************************************************** |
---|
| 105 | C |
---|
| 106 | Subroutine Agrif_nbdim_Get_bound(Variable, |
---|
| 107 | & lower,upper,indice,nbdim) |
---|
| 108 | C |
---|
| 109 | CCC Description: |
---|
| 110 | CCC This subroutine is used to get the lower and the upper boundaries of a |
---|
| 111 | C table. Output datas are scalar. |
---|
| 112 | C |
---|
| 113 | C Declarations: |
---|
| 114 | C |
---|
| 115 | |
---|
| 116 | C |
---|
| 117 | C Arguments |
---|
| 118 | C |
---|
| 119 | ! we want extract boundaries of this table |
---|
| 120 | TYPE(AGRIF_Variable), Pointer :: Variable |
---|
| 121 | INTEGER :: lower,upper ! output data |
---|
| 122 | ! direction in wich we want to know the dimension |
---|
| 123 | INTEGER :: indice |
---|
| 124 | INTEGER :: nbdim ! dimension of the table |
---|
| 125 | C |
---|
| 126 | C Local variables |
---|
| 127 | C |
---|
[2715] | 128 | |
---|
| 129 | lower = Variable % lb(indice) |
---|
| 130 | upper = Variable % ub(indice) |
---|
[1901] | 131 | return |
---|
| 132 | C |
---|
| 133 | End Subroutine Agrif_nbdim_Get_bound |
---|
| 134 | C |
---|
| 135 | C |
---|
| 136 | C ************************************************************************** |
---|
| 137 | CCC Subroutine Agrif_Get_bound_dimension |
---|
| 138 | C ************************************************************************** |
---|
| 139 | C |
---|
| 140 | Subroutine Agrif_nbdim_Get_bound_dimension(Variable, |
---|
| 141 | & lower,upper,nbdim) |
---|
| 142 | C |
---|
| 143 | CCC Description: |
---|
| 144 | CCC This subroutine is used to get the lower and the upper boundaries of a |
---|
| 145 | C table. Output datas are scalar. |
---|
| 146 | C |
---|
| 147 | C Declarations: |
---|
| 148 | C |
---|
| 149 | |
---|
| 150 | C |
---|
| 151 | C Arguments |
---|
| 152 | C |
---|
| 153 | ! we want extract boundaries of this table |
---|
| 154 | TYPE(AGRIF_Variable), Pointer :: Variable |
---|
| 155 | INTEGER :: nbdim ! dimension of the table |
---|
| 156 | INTEGER,DIMENSION(nbdim) :: lower,upper ! output data |
---|
| 157 | C |
---|
| 158 | C Local variables |
---|
| 159 | C |
---|
| 160 | lower = Variable % lb(1:nbdim) |
---|
| 161 | upper = Variable % ub(1:nbdim) |
---|
| 162 | return |
---|
| 163 | C |
---|
| 164 | End Subroutine Agrif_nbdim_Get_bound_dimension |
---|
| 165 | |
---|
| 166 | C ************************************************************************** |
---|
| 167 | CCC Subroutine Agrif_nbdim_allocation |
---|
| 168 | C ************************************************************************** |
---|
| 169 | C |
---|
| 170 | Subroutine Agrif_nbdim_allocation(Variable,inf,sup,nbdim) |
---|
| 171 | C |
---|
| 172 | CCC Description: |
---|
| 173 | CCC This subroutine is used to Allocate the table Variable |
---|
| 174 | C |
---|
| 175 | C Declarations: |
---|
| 176 | C |
---|
| 177 | |
---|
| 178 | C |
---|
| 179 | C Arguments |
---|
| 180 | C |
---|
| 181 | TYPE(AGRIF_Variable), Pointer :: Variable |
---|
| 182 | INTEGER :: nbdim ! dimension of the table |
---|
| 183 | INTEGER,DIMENSION(nbdim) :: inf,sup |
---|
| 184 | C |
---|
| 185 | C Local variables |
---|
| 186 | C |
---|
| 187 | SELECT CASE (nbdim) |
---|
| 188 | CASE (1) |
---|
| 189 | allocate(Variable%array1( |
---|
| 190 | & inf(1):sup(1))) |
---|
| 191 | CASE (2) |
---|
| 192 | allocate(Variable%array2( |
---|
| 193 | & inf(1):sup(1), |
---|
| 194 | & inf(2):sup(2))) |
---|
| 195 | CASE (3) |
---|
| 196 | allocate(Variable%array3( |
---|
| 197 | & inf(1):sup(1), |
---|
| 198 | & inf(2):sup(2), |
---|
| 199 | & inf(3):sup(3))) |
---|
| 200 | CASE (4) |
---|
| 201 | allocate(Variable%array4( |
---|
| 202 | & inf(1):sup(1), |
---|
| 203 | & inf(2):sup(2), |
---|
| 204 | & inf(3):sup(3), |
---|
| 205 | & inf(4):sup(4))) |
---|
| 206 | CASE (5) |
---|
| 207 | allocate(Variable%array5( |
---|
| 208 | & inf(1):sup(1), |
---|
| 209 | & inf(2):sup(2), |
---|
| 210 | & inf(3):sup(3), |
---|
| 211 | & inf(4):sup(4), |
---|
| 212 | & inf(5):sup(5))) |
---|
| 213 | CASE (6) |
---|
| 214 | allocate(Variable%array6( |
---|
| 215 | & inf(1):sup(1), |
---|
| 216 | & inf(2):sup(2), |
---|
| 217 | & inf(3):sup(3), |
---|
| 218 | & inf(4):sup(4), |
---|
| 219 | & inf(5):sup(5), |
---|
| 220 | & inf(6):sup(6))) |
---|
| 221 | END SELECT |
---|
| 222 | C |
---|
| 223 | return |
---|
| 224 | C |
---|
| 225 | End Subroutine Agrif_nbdim_allocation |
---|
| 226 | C |
---|
| 227 | C |
---|
| 228 | C ************************************************************************** |
---|
| 229 | CCC Subroutine Agrif_nbdim_deallocation |
---|
| 230 | C ************************************************************************** |
---|
| 231 | C |
---|
| 232 | Subroutine Agrif_nbdim_deallocation(Variable,nbdim) |
---|
| 233 | C |
---|
| 234 | CCC Description: |
---|
| 235 | CCC This subroutine is used to give the same value to the table Variable |
---|
| 236 | C |
---|
| 237 | C Declarations: |
---|
| 238 | C |
---|
| 239 | |
---|
| 240 | C |
---|
| 241 | C Arguments |
---|
| 242 | C |
---|
| 243 | TYPE(AGRIF_Variable), Pointer :: Variable |
---|
| 244 | INTEGER :: nbdim ! dimension of the table |
---|
| 245 | C |
---|
| 246 | C Local variables |
---|
| 247 | C |
---|
| 248 | |
---|
| 249 | SELECT CASE (nbdim) |
---|
| 250 | CASE (1) |
---|
| 251 | Deallocate(Variable%array1) |
---|
| 252 | CASE (2) |
---|
| 253 | Deallocate(Variable%array2) |
---|
| 254 | CASE (3) |
---|
| 255 | Deallocate(Variable%array3) |
---|
| 256 | CASE (4) |
---|
| 257 | Deallocate(Variable%array4) |
---|
| 258 | CASE (5) |
---|
| 259 | Deallocate(Variable%array5) |
---|
| 260 | CASE (6) |
---|
| 261 | Deallocate(Variable%array6) |
---|
| 262 | END SELECT |
---|
| 263 | C |
---|
| 264 | return |
---|
| 265 | C |
---|
| 266 | End Subroutine Agrif_nbdim_deallocation |
---|
| 267 | C |
---|
| 268 | C |
---|
| 269 | C ************************************************************************** |
---|
| 270 | CCC Subroutine Agrif_nbdim_Full_VarEQreal |
---|
| 271 | C ************************************************************************** |
---|
| 272 | C |
---|
| 273 | Subroutine Agrif_nbdim_Full_VarEQreal(Variable,Value,nbdim) |
---|
| 274 | C |
---|
| 275 | CCC Description: |
---|
| 276 | CCC This subroutine is used to get the lower and the upper boundaries of a |
---|
| 277 | C table. Output datas are scalar. |
---|
| 278 | C |
---|
| 279 | C Declarations: |
---|
| 280 | C |
---|
| 281 | |
---|
| 282 | C |
---|
| 283 | C Arguments |
---|
| 284 | C |
---|
| 285 | TYPE(AGRIF_Variable), Pointer :: Variable |
---|
| 286 | REAL :: Value |
---|
| 287 | INTEGER :: nbdim ! dimension of the table |
---|
| 288 | C |
---|
| 289 | C Local variables |
---|
| 290 | C |
---|
| 291 | SELECT CASE (nbdim) |
---|
| 292 | CASE (1) |
---|
| 293 | Variable%array1 = Value |
---|
| 294 | CASE (2) |
---|
| 295 | Variable%array2 = Value |
---|
| 296 | CASE (3) |
---|
| 297 | Call Agrif_set_tozero3D(Variable%array3) |
---|
| 298 | ! Variable%array3 = Value |
---|
| 299 | CASE (4) |
---|
| 300 | Variable%array4 = Value |
---|
| 301 | CASE (5) |
---|
| 302 | Variable%array5 = Value |
---|
| 303 | CASE (6) |
---|
| 304 | Variable%array6 = Value |
---|
| 305 | END SELECT |
---|
| 306 | C |
---|
| 307 | return |
---|
| 308 | C |
---|
| 309 | End Subroutine Agrif_nbdim_Full_VarEQreal |
---|
| 310 | |
---|
| 311 | Subroutine Agrif_set_tozero3D(tab3D) |
---|
| 312 | real,dimension(:,:,:),target :: tab3D |
---|
| 313 | |
---|
| 314 | tab3D = 0. |
---|
| 315 | |
---|
| 316 | end subroutine agrif_set_tozero3D |
---|
| 317 | C |
---|
| 318 | C |
---|
[2019] | 319 | #if !defined key_mpp_mpi |
---|
[1901] | 320 | C ************************************************************************** |
---|
| 321 | CCC Subroutine Agrif_nbdim_VarEQreal |
---|
| 322 | C ************************************************************************** |
---|
| 323 | C |
---|
| 324 | Subroutine Agrif_nbdim_VarEQreal(Variable,inf,sup,Value,nbdim) |
---|
| 325 | C |
---|
| 326 | CCC Description: |
---|
| 327 | CCC This subroutine is used to give the same value to a part of |
---|
| 328 | C the table Variable |
---|
| 329 | C |
---|
| 330 | C Declarations: |
---|
| 331 | C |
---|
| 332 | |
---|
| 333 | C |
---|
| 334 | C Arguments |
---|
| 335 | C |
---|
| 336 | TYPE(AGRIF_Variable), Pointer :: Variable |
---|
| 337 | REAL :: Value |
---|
| 338 | INTEGER :: nbdim ! dimension of the table |
---|
| 339 | INTEGER,DIMENSION(nbdim) :: inf,sup |
---|
| 340 | C |
---|
| 341 | C Local variables |
---|
| 342 | C |
---|
| 343 | SELECT CASE (nbdim) |
---|
| 344 | CASE (1) |
---|
| 345 | Variable%array1( |
---|
| 346 | & inf(1):sup(1) |
---|
| 347 | & ) = Value |
---|
| 348 | CASE (2) |
---|
| 349 | Variable%array2( |
---|
| 350 | & inf(1):sup(1), |
---|
| 351 | & inf(2):sup(2) |
---|
| 352 | & ) = Value |
---|
| 353 | CASE (3) |
---|
| 354 | Variable%array3( |
---|
| 355 | & inf(1):sup(1), |
---|
| 356 | & inf(2):sup(2), |
---|
| 357 | & inf(3):sup(3) |
---|
| 358 | & ) = Value |
---|
| 359 | CASE (4) |
---|
| 360 | Variable%array4( |
---|
| 361 | & inf(1):sup(1), |
---|
| 362 | & inf(2):sup(2), |
---|
| 363 | & inf(3):sup(3), |
---|
| 364 | & inf(4):sup(4) |
---|
| 365 | & ) = Value |
---|
| 366 | CASE (5) |
---|
| 367 | Variable%array5( |
---|
| 368 | & inf(1):sup(1), |
---|
| 369 | & inf(2):sup(2), |
---|
| 370 | & inf(3):sup(3), |
---|
| 371 | & inf(4):sup(4), |
---|
| 372 | & inf(5):sup(5) |
---|
| 373 | & ) = Value |
---|
| 374 | CASE (6) |
---|
| 375 | Variable%array6( |
---|
| 376 | & inf(1):sup(1), |
---|
| 377 | & inf(2):sup(2), |
---|
| 378 | & inf(3):sup(3), |
---|
| 379 | & inf(4):sup(4), |
---|
| 380 | & inf(5):sup(5), |
---|
| 381 | & inf(6):sup(6) |
---|
| 382 | & ) = Value |
---|
| 383 | END SELECT |
---|
| 384 | C |
---|
| 385 | return |
---|
| 386 | C |
---|
| 387 | End Subroutine Agrif_nbdim_VarEQreal |
---|
| 388 | #endif |
---|
| 389 | C |
---|
| 390 | C |
---|
| 391 | C |
---|
| 392 | C ************************************************************************** |
---|
| 393 | CCC Subroutine Agrif_nbdim_VarEQvar |
---|
| 394 | C ************************************************************************** |
---|
| 395 | C |
---|
| 396 | Subroutine Agrif_nbdim_VarEQvar(Variable,inf,sup, |
---|
| 397 | & Variable2,inf2,sup2, |
---|
| 398 | & nbdim) |
---|
| 399 | C |
---|
| 400 | CCC Description: |
---|
| 401 | CCC This subroutine is used to give the value of a part of the table |
---|
| 402 | C Variable2 to the table Variable |
---|
| 403 | C |
---|
| 404 | C Declarations: |
---|
| 405 | C |
---|
| 406 | |
---|
| 407 | C |
---|
| 408 | C Arguments |
---|
| 409 | C |
---|
| 410 | TYPE(AGRIF_Variable), Pointer :: Variable |
---|
| 411 | TYPE(AGRIF_Variable), Pointer :: Variable2 |
---|
| 412 | INTEGER :: nbdim ! dimension of the table |
---|
| 413 | INTEGER,DIMENSION(nbdim) :: inf,sup |
---|
| 414 | INTEGER,DIMENSION(nbdim) :: inf2,sup2 |
---|
| 415 | C |
---|
| 416 | C Local variables |
---|
| 417 | C |
---|
| 418 | SELECT CASE (nbdim) |
---|
| 419 | CASE (1) |
---|
| 420 | Variable%array1(inf(1):sup(1)) = |
---|
| 421 | & Variable2%array1(inf2(1):sup2(1)) |
---|
| 422 | CASE (2) |
---|
| 423 | |
---|
| 424 | Call Agrif_Copy_2d(Variable%array2,Variable2%array2, |
---|
| 425 | & lbound(Variable%array2), |
---|
| 426 | & lbound(Variable2%array2), |
---|
| 427 | & inf,sup,inf2,sup2) |
---|
| 428 | |
---|
| 429 | CASE (3) |
---|
| 430 | |
---|
| 431 | Call Agrif_Copy_3d(Variable%array3,Variable2%array3, |
---|
| 432 | & lbound(Variable%array3), |
---|
| 433 | & lbound(Variable2%array3), |
---|
| 434 | & inf,sup,inf2,sup2) |
---|
| 435 | |
---|
| 436 | CASE (4) |
---|
| 437 | |
---|
| 438 | Call Agrif_Copy_4d(Variable%array4,Variable2%array4, |
---|
| 439 | & lbound(Variable%array4), |
---|
| 440 | & lbound(Variable2%array4), |
---|
| 441 | & inf,sup,inf2,sup2) |
---|
| 442 | |
---|
| 443 | CASE (5) |
---|
| 444 | Variable%array5(inf(1):sup(1), |
---|
| 445 | & inf(2):sup(2), |
---|
| 446 | & inf(3):sup(3), |
---|
| 447 | & inf(4):sup(4), |
---|
| 448 | & inf(5):sup(5)) = |
---|
| 449 | & Variable2%array5(inf2(1):sup2(1), |
---|
| 450 | & inf2(2):sup2(2), |
---|
| 451 | & inf2(3):sup2(3), |
---|
| 452 | & inf2(4):sup2(4), |
---|
| 453 | & inf2(5):sup2(5)) |
---|
| 454 | CASE (6) |
---|
| 455 | Variable%array6(inf(1):sup(1), |
---|
| 456 | & inf(2):sup(2), |
---|
| 457 | & inf(3):sup(3), |
---|
| 458 | & inf(4):sup(4), |
---|
| 459 | & inf(5):sup(5), |
---|
| 460 | & inf(6):sup(6)) = |
---|
| 461 | & Variable2%array6(inf2(1):sup2(1), |
---|
| 462 | & inf2(2):sup2(2), |
---|
| 463 | & inf2(3):sup2(3), |
---|
| 464 | & inf2(4):sup2(4), |
---|
| 465 | & inf2(5):sup2(5), |
---|
| 466 | & inf2(6):sup2(6)) |
---|
| 467 | END SELECT |
---|
| 468 | C |
---|
| 469 | return |
---|
| 470 | C |
---|
| 471 | End Subroutine Agrif_nbdim_VarEQvar |
---|
| 472 | C |
---|
| 473 | C ************************************************************************** |
---|
| 474 | CCC Subroutine Agrif_nbdim_Full_VarEQvar |
---|
| 475 | C ************************************************************************** |
---|
| 476 | C |
---|
| 477 | Subroutine Agrif_nbdim_Full_VarEQvar(Variable,Variable2, |
---|
| 478 | & nbdim) |
---|
| 479 | C |
---|
| 480 | CCC Description: |
---|
| 481 | CCC This subroutine is used to give the value of the table Variable2 |
---|
| 482 | C to the table Variable |
---|
| 483 | C |
---|
| 484 | C Declarations: |
---|
| 485 | C |
---|
| 486 | |
---|
| 487 | C |
---|
| 488 | C Arguments |
---|
| 489 | C |
---|
| 490 | TYPE(AGRIF_Variable), Pointer :: Variable |
---|
| 491 | TYPE(AGRIF_Variable), Pointer :: Variable2 |
---|
| 492 | INTEGER :: nbdim ! dimension of the table |
---|
| 493 | C |
---|
| 494 | C Local variables |
---|
| 495 | C |
---|
| 496 | SELECT CASE (nbdim) |
---|
| 497 | CASE (1) |
---|
| 498 | Variable%array1 = Variable2%array1 |
---|
| 499 | CASE (2) |
---|
| 500 | Variable%array2 = Variable2%array2 |
---|
| 501 | CASE (3) |
---|
| 502 | Variable%array3 = Variable2%array3 |
---|
| 503 | CASE (4) |
---|
| 504 | Variable%array4 = Variable2%array4 |
---|
| 505 | CASE (5) |
---|
| 506 | Variable%array5 = Variable2%array5 |
---|
| 507 | CASE (6) |
---|
| 508 | Variable%array6 = Variable2%array6 |
---|
| 509 | END SELECT |
---|
| 510 | C |
---|
| 511 | return |
---|
| 512 | C |
---|
| 513 | End Subroutine Agrif_nbdim_Full_VarEQvar |
---|
| 514 | C |
---|
| 515 | C |
---|
| 516 | |
---|
| 517 | C ************************************************************************** |
---|
| 518 | CCC Subroutine GiveAgrif_SpecialValueToTab_mpi |
---|
| 519 | C ************************************************************************** |
---|
| 520 | C |
---|
| 521 | Subroutine GiveAgrif_SpecialValueToTab_mpi(Variable1,Variable2, |
---|
| 522 | & bound1,lower,upper,Value,nbdim) |
---|
| 523 | C |
---|
| 524 | CCC Description: |
---|
| 525 | CCC |
---|
| 526 | C |
---|
| 527 | C Declarations: |
---|
| 528 | C |
---|
| 529 | |
---|
| 530 | C |
---|
| 531 | C Arguments |
---|
| 532 | C |
---|
| 533 | TYPE(AGRIF_VARIABLE), Pointer :: Variable1 |
---|
| 534 | TYPE(AGRIF_VARIABLE), Pointer :: Variable2 |
---|
| 535 | INTEGER :: nbdim |
---|
| 536 | INTEGER,DIMENSION(:,:,:) :: bound1 |
---|
| 537 | INTEGER,DIMENSION(nbdim) :: lower,upper |
---|
| 538 | REAL :: Value |
---|
| 539 | C |
---|
| 540 | C Local variables |
---|
| 541 | C |
---|
| 542 | SELECT CASE (nbdim) |
---|
| 543 | CASE (1) |
---|
| 544 | Where (Variable1 % array1( |
---|
| 545 | & bound1(1,1,2):bound1(1,2,2)) |
---|
| 546 | & == Value) |
---|
| 547 | Variable2 % array1(bound1(1,1,1):bound1(1,2,1)) |
---|
| 548 | & = Value |
---|
| 549 | C |
---|
| 550 | End Where |
---|
| 551 | CASE (2) |
---|
| 552 | Where (Variable1 % array2( |
---|
| 553 | & bound1(1,1,2):bound1(1,2,2), |
---|
| 554 | & bound1(2,1,2):bound1(2,2,2)) |
---|
| 555 | & == Value) |
---|
| 556 | Variable2 % array2(bound1(1,1,1):bound1(1,2,1), |
---|
| 557 | & bound1(2,1,1):bound1(2,2,1)) |
---|
| 558 | & = Value |
---|
| 559 | C |
---|
| 560 | End Where |
---|
| 561 | CASE (3) |
---|
| 562 | Where (Variable1 % array3( |
---|
| 563 | & bound1(1,1,2):bound1(1,2,2), |
---|
| 564 | & bound1(2,1,2):bound1(2,2,2), |
---|
| 565 | & bound1(3,1,2):bound1(3,2,2)) |
---|
| 566 | & == Value) |
---|
| 567 | Variable2 % array3(bound1(1,1,1):bound1(1,2,1), |
---|
| 568 | & bound1(2,1,1):bound1(2,2,1), |
---|
| 569 | & bound1(3,1,1):bound1(3,2,1)) |
---|
| 570 | & = Value |
---|
| 571 | C |
---|
| 572 | End Where |
---|
| 573 | CASE (4) |
---|
| 574 | Where (Variable1 % array4( |
---|
| 575 | & bound1(1,1,2):bound1(1,2,2), |
---|
| 576 | & bound1(2,1,2):bound1(2,2,2), |
---|
| 577 | & bound1(3,1,2):bound1(3,2,2), |
---|
| 578 | & bound1(4,1,2):bound1(4,2,2)) |
---|
| 579 | & == Value) |
---|
| 580 | Variable2 % array4(bound1(1,1,1):bound1(1,2,1), |
---|
| 581 | & bound1(2,1,1):bound1(2,2,1), |
---|
| 582 | & bound1(3,1,1):bound1(3,2,1), |
---|
| 583 | & bound1(4,1,1):bound1(4,2,1)) |
---|
| 584 | & = Value |
---|
| 585 | C |
---|
| 586 | End Where |
---|
| 587 | CASE (5) |
---|
| 588 | Where (Variable1 % array5( |
---|
| 589 | & bound1(1,1,2):bound1(1,2,2), |
---|
| 590 | & bound1(2,1,2):bound1(2,2,2), |
---|
| 591 | & bound1(3,1,2):bound1(3,2,2), |
---|
| 592 | & bound1(4,1,2):bound1(4,2,2), |
---|
| 593 | & bound1(5,1,2):bound1(5,2,2)) |
---|
| 594 | & == Value) |
---|
| 595 | Variable2 % array5(bound1(1,1,1):bound1(1,2,1), |
---|
| 596 | & bound1(2,1,1):bound1(2,2,1), |
---|
| 597 | & bound1(3,1,1):bound1(3,2,1), |
---|
| 598 | & bound1(4,1,1):bound1(4,2,1), |
---|
| 599 | & bound1(5,1,1):bound1(5,2,1)) |
---|
| 600 | & = Value |
---|
| 601 | C |
---|
| 602 | End Where |
---|
| 603 | CASE (6) |
---|
| 604 | Where (Variable1 % array6( |
---|
| 605 | & bound1(1,1,2):bound1(1,2,2), |
---|
| 606 | & bound1(2,1,2):bound1(2,2,2), |
---|
| 607 | & bound1(3,1,2):bound1(3,2,2), |
---|
| 608 | & bound1(4,1,2):bound1(4,2,2), |
---|
| 609 | & bound1(5,1,2):bound1(5,2,2), |
---|
| 610 | & bound1(6,1,2):bound1(6,2,2)) |
---|
| 611 | & == Value) |
---|
| 612 | Variable2 % array6(bound1(1,1,1):bound1(1,2,1), |
---|
| 613 | & bound1(2,1,1):bound1(2,2,1), |
---|
| 614 | & bound1(3,1,1):bound1(3,2,1), |
---|
| 615 | & bound1(4,1,1):bound1(4,2,1), |
---|
| 616 | & bound1(5,1,1):bound1(5,2,1), |
---|
| 617 | & bound1(6,1,1):bound1(6,2,1)) |
---|
| 618 | & = Value |
---|
| 619 | C |
---|
| 620 | End Where |
---|
| 621 | END SELECT |
---|
| 622 | C |
---|
| 623 | return |
---|
| 624 | C |
---|
| 625 | End Subroutine GiveAgrif_SpecialValueToTab_mpi |
---|
| 626 | |
---|
| 627 | C ************************************************************************** |
---|
| 628 | CCC Subroutine GiveAgrif_SpecialValueToTab |
---|
| 629 | C ************************************************************************** |
---|
| 630 | C |
---|
| 631 | Subroutine GiveAgrif_SpecialValueToTab(Variable1,Variable2, |
---|
| 632 | & lower,upper,Value,nbdim) |
---|
| 633 | C |
---|
| 634 | CCC Description: |
---|
| 635 | CCC |
---|
| 636 | C |
---|
| 637 | C Declarations: |
---|
| 638 | C |
---|
| 639 | |
---|
| 640 | C |
---|
| 641 | C Arguments |
---|
| 642 | C |
---|
| 643 | TYPE(AGRIF_VARIABLE), Pointer :: Variable1 |
---|
| 644 | TYPE(AGRIF_VARIABLE), Pointer :: Variable2 |
---|
| 645 | INTEGER :: nbdim |
---|
| 646 | INTEGER,DIMENSION(nbdim) :: lower,upper |
---|
| 647 | REAL :: Value |
---|
| 648 | C |
---|
| 649 | C Local variables |
---|
| 650 | C |
---|
| 651 | SELECT CASE (nbdim) |
---|
| 652 | CASE (1) |
---|
| 653 | Where (Variable1 % array1( |
---|
| 654 | & lower(1):upper(1)) |
---|
| 655 | & == Value) |
---|
| 656 | Variable2 % array1(lower(1):upper(1)) |
---|
| 657 | & = Value |
---|
| 658 | C |
---|
| 659 | End Where |
---|
| 660 | CASE (2) |
---|
| 661 | Where (Variable1 % array2( |
---|
| 662 | & lower(1):upper(1), |
---|
| 663 | & lower(2):upper(2)) |
---|
| 664 | & == Value) |
---|
| 665 | Variable2 % array2(lower(1):upper(1), |
---|
| 666 | & lower(2):upper(2)) |
---|
| 667 | & = Value |
---|
| 668 | C |
---|
| 669 | End Where |
---|
| 670 | CASE (3) |
---|
| 671 | Where (Variable1 % array3( |
---|
| 672 | & lower(1):upper(1), |
---|
| 673 | & lower(2):upper(2), |
---|
| 674 | & lower(3):upper(3)) |
---|
| 675 | & == Value) |
---|
| 676 | Variable2 % array3(lower(1):upper(1), |
---|
| 677 | & lower(2):upper(2), |
---|
| 678 | & lower(3):upper(3)) |
---|
| 679 | & = Value |
---|
| 680 | C |
---|
| 681 | End Where |
---|
| 682 | CASE (4) |
---|
| 683 | Where (Variable1 % array4( |
---|
| 684 | & lower(1):upper(1), |
---|
| 685 | & lower(2):upper(2), |
---|
| 686 | & lower(3):upper(3), |
---|
| 687 | & lower(4):upper(4)) |
---|
| 688 | & == Value) |
---|
| 689 | Variable2 % array4(lower(1):upper(1), |
---|
| 690 | & lower(2):upper(2), |
---|
| 691 | & lower(3):upper(3), |
---|
| 692 | & lower(4):upper(4)) |
---|
| 693 | & = Value |
---|
| 694 | C |
---|
| 695 | End Where |
---|
| 696 | CASE (5) |
---|
| 697 | Where (Variable1 % array5( |
---|
| 698 | & lower(1):upper(1), |
---|
| 699 | & lower(2):upper(2), |
---|
| 700 | & lower(3):upper(3), |
---|
| 701 | & lower(4):upper(4), |
---|
| 702 | & lower(5):upper(5)) |
---|
| 703 | & == Value) |
---|
| 704 | Variable2 % array5(lower(1):upper(1), |
---|
| 705 | & lower(2):upper(2), |
---|
| 706 | & lower(3):upper(3), |
---|
| 707 | & lower(4):upper(4), |
---|
| 708 | & lower(5):upper(5)) |
---|
| 709 | & = Value |
---|
| 710 | C |
---|
| 711 | End Where |
---|
| 712 | CASE (6) |
---|
| 713 | Where (Variable1 % array6( |
---|
| 714 | & lower(1):upper(1), |
---|
| 715 | & lower(2):upper(2), |
---|
| 716 | & lower(2):upper(3), |
---|
| 717 | & lower(4):upper(4), |
---|
| 718 | & lower(5):upper(5), |
---|
| 719 | & lower(6):upper(6)) |
---|
| 720 | & == Value) |
---|
| 721 | Variable2 % array6(lower(1):upper(1), |
---|
| 722 | & lower(2):upper(2), |
---|
| 723 | & lower(3):upper(3), |
---|
| 724 | & lower(4):upper(4), |
---|
| 725 | & lower(5):upper(5), |
---|
| 726 | & lower(6):upper(6)) |
---|
| 727 | & = Value |
---|
| 728 | C |
---|
| 729 | End Where |
---|
| 730 | END SELECT |
---|
| 731 | C |
---|
| 732 | return |
---|
| 733 | C |
---|
| 734 | End Subroutine GiveAgrif_SpecialValueToTab |
---|
| 735 | |
---|
| 736 | C |
---|
| 737 | C |
---|
[2019] | 738 | #ifdef key_mpp_mpi |
---|
[1901] | 739 | C ************************************************************************** |
---|
| 740 | CCC Subroutine Where_ValTabToTab_mpi |
---|
| 741 | C ************************************************************************** |
---|
| 742 | C |
---|
| 743 | Subroutine Where_ValTabToTab_mpi( |
---|
| 744 | & Variable1,Variable2, |
---|
| 745 | & lower,upper,Value,nbdim) |
---|
| 746 | C |
---|
| 747 | CCC Description: |
---|
| 748 | CCC |
---|
| 749 | C |
---|
| 750 | C Declarations: |
---|
| 751 | C |
---|
| 752 | |
---|
| 753 | C |
---|
| 754 | C Arguments |
---|
| 755 | C |
---|
| 756 | TYPE(AGRIF_VARIABLE), Pointer :: Variable1 |
---|
| 757 | TYPE(AGRIF_VARIABLE), Pointer :: Variable2 |
---|
| 758 | INTEGER :: nbdim |
---|
| 759 | INTEGER,DIMENSION(nbdim) :: lower,upper |
---|
| 760 | REAL :: Value |
---|
| 761 | INTEGER :: i,j,k,l,m,n |
---|
| 762 | C |
---|
| 763 | C Local variables |
---|
| 764 | C |
---|
| 765 | SELECT CASE (nbdim) |
---|
| 766 | CASE (1) |
---|
| 767 | DO i = lower(1),upper(1) |
---|
| 768 | IF (variable1%array1(i) == Value) then |
---|
| 769 | variable1%array1(i)=Variable2%array1(i) |
---|
| 770 | ENDIF |
---|
| 771 | ENDDO |
---|
| 772 | CASE (2) |
---|
| 773 | DO j = lower(2),upper(2) |
---|
| 774 | DO i = lower(1),upper(1) |
---|
| 775 | IF (variable1%array2(i,j) == Value) then |
---|
| 776 | variable1%array2(i,j)=Variable2%array2(i,j) |
---|
| 777 | ENDIF |
---|
| 778 | ENDDO |
---|
| 779 | ENDDO |
---|
| 780 | CASE (3) |
---|
| 781 | DO k = lower(3),upper(3) |
---|
| 782 | DO j = lower(2),upper(2) |
---|
| 783 | DO i = lower(1),upper(1) |
---|
| 784 | IF (variable1%array3(i,j,k) == Value) then |
---|
| 785 | variable1%array3(i,j,k)=Variable2%array3(i,j,k) |
---|
| 786 | ENDIF |
---|
| 787 | ENDDO |
---|
| 788 | ENDDO |
---|
| 789 | ENDDO |
---|
| 790 | CASE (4) |
---|
| 791 | DO l = lower(4),upper(4) |
---|
| 792 | DO k = lower(3),upper(3) |
---|
| 793 | DO j = lower(2),upper(2) |
---|
| 794 | DO i = lower(1),upper(1) |
---|
| 795 | IF (variable1%array4(i,j,k,l) == Value) then |
---|
| 796 | variable1%array4(i,j,k,l)=Variable2%array4(i,j,k,l) |
---|
| 797 | ENDIF |
---|
| 798 | ENDDO |
---|
| 799 | ENDDO |
---|
| 800 | ENDDO |
---|
| 801 | ENDDO |
---|
| 802 | CASE (5) |
---|
| 803 | DO m = lower(5),upper(5) |
---|
| 804 | DO l = lower(4),upper(4) |
---|
| 805 | DO k = lower(3),upper(3) |
---|
| 806 | DO j = lower(2),upper(2) |
---|
| 807 | DO i = lower(1),upper(1) |
---|
| 808 | IF (variable1%array5(i,j,k,l,m) == Value) then |
---|
| 809 | variable1%array5(i,j,k,l,m)=Variable2%array5(i,j,k,l,m) |
---|
| 810 | ENDIF |
---|
| 811 | ENDDO |
---|
| 812 | ENDDO |
---|
| 813 | ENDDO |
---|
| 814 | ENDDO |
---|
| 815 | ENDDO |
---|
| 816 | CASE (6) |
---|
| 817 | DO n = lower(6),upper(6) |
---|
| 818 | DO m = lower(5),upper(5) |
---|
| 819 | DO l = lower(4),upper(4) |
---|
| 820 | DO k = lower(3),upper(3) |
---|
| 821 | DO j = lower(2),upper(2) |
---|
| 822 | DO i = lower(1),upper(1) |
---|
| 823 | IF (variable1%array6(i,j,k,l,m,n) == Value) then |
---|
| 824 | variable1%array6(i,j,k,l,m,n)=Variable2%array6(i,j,k,l,m,n) |
---|
| 825 | ENDIF |
---|
| 826 | ENDDO |
---|
| 827 | ENDDO |
---|
| 828 | ENDDO |
---|
| 829 | ENDDO |
---|
| 830 | ENDDO |
---|
| 831 | ENDDO |
---|
| 832 | END SELECT |
---|
| 833 | C |
---|
| 834 | return |
---|
| 835 | C |
---|
| 836 | End Subroutine Where_ValTabToTab_mpi |
---|
| 837 | #endif |
---|
| 838 | |
---|
| 839 | C ************************************************************************** |
---|
| 840 | CCC Subroutine PreProcessToInterpOrUpdate |
---|
| 841 | C ************************************************************************** |
---|
| 842 | C |
---|
| 843 | Subroutine PreProcessToInterpOrUpdate(parent,child, |
---|
| 844 | & petab_Child, |
---|
| 845 | & pttab_Child,pttab_Parent, |
---|
| 846 | & s_Child,s_Parent, |
---|
| 847 | & ds_Child,ds_Parent, |
---|
| 848 | & nbdim) |
---|
| 849 | C |
---|
| 850 | CCC Description: |
---|
| 851 | CCC |
---|
| 852 | C |
---|
| 853 | C Declarations: |
---|
| 854 | C |
---|
| 855 | C arguments |
---|
| 856 | TYPE(AGRIF_PVariable) :: parent ! Variable on the parent grid |
---|
| 857 | TYPE(AGRIF_PVariable) :: child ! Variable on the child grid |
---|
| 858 | INTEGER :: nbdim |
---|
| 859 | INTEGER,DIMENSION(6) :: pttab_child |
---|
| 860 | INTEGER,DIMENSION(6) :: petab_child |
---|
| 861 | INTEGER,DIMENSION(6) :: pttab_parent |
---|
| 862 | TYPE(AGRIF_Variable), Pointer :: root ! Pointer on the variable of the |
---|
| 863 | ! root grid |
---|
| 864 | TYPE(Agrif_Grid), Pointer :: Agrif_Child_Gr,Agrif_Parent_Gr |
---|
| 865 | REAL, DIMENSION(6) :: s_child,s_parent |
---|
| 866 | REAL, DIMENSION(6) :: ds_child,ds_parent |
---|
| 867 | C locals variables |
---|
| 868 | INTEGER :: n |
---|
| 869 | |
---|
| 870 | C |
---|
| 871 | C Arguments |
---|
| 872 | C |
---|
| 873 | |
---|
| 874 | C |
---|
| 875 | C Local variables |
---|
| 876 | C |
---|
| 877 | Agrif_Child_Gr => Agrif_Curgrid |
---|
| 878 | Agrif_Parent_Gr => Agrif_Curgrid % parent |
---|
| 879 | C |
---|
| 880 | root => child % var % root_var |
---|
| 881 | C |
---|
| 882 | C Number of dimensions of the current grid |
---|
| 883 | nbdim = root % nbdim |
---|
| 884 | C |
---|
| 885 | do n=1,nbdim |
---|
| 886 | C |
---|
| 887 | Select case(root % interptab(n)) |
---|
| 888 | C |
---|
| 889 | C Value of interptab(n) can be either x,y,z or N for a no space |
---|
| 890 | C DIMENSION |
---|
| 891 | C |
---|
| 892 | C The DIMENSION is 'x' |
---|
| 893 | case('x') |
---|
| 894 | C |
---|
| 895 | pttab_Child(n) = root % point(1) |
---|
| 896 | C |
---|
| 897 | pttab_Parent(n) = root % point(1) |
---|
| 898 | C |
---|
| 899 | s_Child(n) = Agrif_Child_Gr % Agrif_x(1) |
---|
| 900 | C |
---|
| 901 | s_Parent(n) = Agrif_Parent_Gr % Agrif_x(1) |
---|
| 902 | C |
---|
| 903 | ds_Child(n) = Agrif_Child_Gr % Agrif_d(1) |
---|
| 904 | C |
---|
| 905 | ds_Parent(n) = Agrif_Parent_Gr % Agrif_d(1) |
---|
| 906 | C |
---|
| 907 | if (root % posvar(n).EQ.1) then |
---|
| 908 | C |
---|
| 909 | petab_Child(n) = pttab_Child(n) + Agrif_Child_Gr%nb(1) |
---|
| 910 | C |
---|
| 911 | else |
---|
| 912 | C |
---|
| 913 | petab_Child(n) = pttab_Child(n) + |
---|
| 914 | & Agrif_Child_Gr%nb(1) - 1 |
---|
| 915 | C |
---|
| 916 | s_Child(n) = s_Child(n) + ds_Child(n)/2. |
---|
| 917 | C |
---|
| 918 | s_Parent(n) = s_Parent(n) + ds_Parent(n)/2. |
---|
| 919 | C |
---|
| 920 | endif |
---|
| 921 | C |
---|
| 922 | C The DIMENSION is 'y' |
---|
| 923 | case('y') |
---|
| 924 | C |
---|
| 925 | pttab_Child(n) = root % point(2) |
---|
| 926 | C |
---|
| 927 | pttab_Parent(n) = root % point(2) |
---|
| 928 | C |
---|
| 929 | s_Child(n) = Agrif_Child_Gr % Agrif_x(2) |
---|
| 930 | C |
---|
| 931 | s_Parent(n) = Agrif_Parent_Gr % Agrif_x(2) |
---|
| 932 | C |
---|
| 933 | ds_Child(n) = Agrif_Child_Gr % Agrif_d(2) |
---|
| 934 | C |
---|
| 935 | ds_Parent(n) = Agrif_Parent_Gr % Agrif_d(2) |
---|
| 936 | C |
---|
| 937 | if (root % posvar(n).EQ.1) then |
---|
| 938 | C |
---|
| 939 | petab_Child(n) = pttab_Child(n) + Agrif_Child_Gr%nb(2) |
---|
| 940 | C |
---|
| 941 | else |
---|
| 942 | C |
---|
| 943 | petab_Child(n) = pttab_Child(n) + |
---|
| 944 | & Agrif_Child_Gr%nb(2) - 1 |
---|
| 945 | C |
---|
| 946 | s_Child(n) = s_Child(n) + ds_Child(n)/2. |
---|
| 947 | C |
---|
| 948 | s_Parent(n) = s_Parent(n) + ds_Parent(n)/2. |
---|
| 949 | C |
---|
| 950 | endif |
---|
| 951 | |
---|
| 952 | C |
---|
| 953 | C The DIMENSION is 'z' |
---|
| 954 | case('z') |
---|
| 955 | C |
---|
| 956 | pttab_Child(n) = root % point(3) |
---|
| 957 | C |
---|
| 958 | pttab_Parent(n) = root % point(3) |
---|
| 959 | C |
---|
| 960 | s_Child(n) = Agrif_Child_Gr % Agrif_x(3) |
---|
| 961 | C |
---|
| 962 | s_Parent(n) = Agrif_Parent_Gr % Agrif_x(3) |
---|
| 963 | C |
---|
| 964 | ds_Child(n) = Agrif_Child_Gr % Agrif_d(3) |
---|
| 965 | C |
---|
| 966 | ds_Parent(n) = Agrif_Parent_Gr % Agrif_d(3) |
---|
| 967 | C |
---|
| 968 | if (root % posvar(n).EQ.1) then |
---|
| 969 | C |
---|
| 970 | petab_Child(n) = pttab_Child(n) + Agrif_Child_Gr%nb(3) |
---|
| 971 | C |
---|
| 972 | else |
---|
| 973 | C |
---|
| 974 | petab_Child(n) = pttab_Child(n) + |
---|
| 975 | & Agrif_Child_Gr%nb(3) - 1 |
---|
| 976 | C |
---|
| 977 | s_Child(n) = s_Child(n) + ds_Child(n)/2. |
---|
| 978 | C |
---|
| 979 | s_Parent(n) = s_Parent(n) + ds_Parent(n)/2. |
---|
| 980 | C |
---|
| 981 | endif |
---|
| 982 | C |
---|
| 983 | C The DIMENSION is not space |
---|
| 984 | case('N') |
---|
| 985 | C |
---|
| 986 | C The next coefficients are calculated in order to do a simple copy of |
---|
| 987 | C values of the grid variable when the procedure of interpolation is |
---|
| 988 | C called for this DIMENSION |
---|
| 989 | C |
---|
| 990 | Call Agrif_nbdim_Get_bound(child % var, |
---|
| 991 | & pttab_Child(n),petab_Child(n),n,nbdim) |
---|
| 992 | C |
---|
| 993 | C No interpolation but only a copy of the values of the grid variable |
---|
| 994 | C |
---|
| 995 | pttab_Parent(n) = pttab_Child(n) |
---|
| 996 | C |
---|
| 997 | s_Child(n)=0. |
---|
| 998 | C |
---|
| 999 | s_Parent(n)=0. |
---|
| 1000 | C |
---|
| 1001 | ds_Child(n)=1. |
---|
| 1002 | C |
---|
| 1003 | ds_Parent(n)=1. |
---|
| 1004 | C |
---|
| 1005 | End select |
---|
| 1006 | C |
---|
| 1007 | enddo |
---|
| 1008 | C |
---|
| 1009 | return |
---|
| 1010 | C |
---|
| 1011 | End Subroutine PreProcessToInterpOrUpdate |
---|
| 1012 | |
---|
[2019] | 1013 | #ifdef key_mpp_mpi |
---|
[1901] | 1014 | C |
---|
| 1015 | C ************************************************************************** |
---|
| 1016 | CCC Subroutine GetLocalBoundaries |
---|
| 1017 | C ************************************************************************** |
---|
| 1018 | C |
---|
| 1019 | Subroutine GetLocalBoundaries(tab1,tab2,i,lb,ub,deb,fin) |
---|
| 1020 | C |
---|
| 1021 | CCC Descritpion: |
---|
| 1022 | C |
---|
| 1023 | C |
---|
| 1024 | C Declarations: |
---|
| 1025 | C |
---|
| 1026 | |
---|
| 1027 | C |
---|
| 1028 | C |
---|
| 1029 | C Scalar arguments |
---|
| 1030 | INTEGER :: tab1,tab2 |
---|
| 1031 | INTEGER :: i |
---|
| 1032 | INTEGER :: lb,ub |
---|
| 1033 | INTEGER :: deb,fin |
---|
| 1034 | C |
---|
| 1035 | C Local scalars |
---|
| 1036 | INTEGER :: imin,imax |
---|
| 1037 | INTEGER :: i1,i2 |
---|
| 1038 | C |
---|
| 1039 | C |
---|
| 1040 | Call AGRIF_InvLoc(lb,AGRIF_ProcRank,i,imin) |
---|
| 1041 | C |
---|
| 1042 | Call AGRIF_InvLoc(ub,AGRIF_ProcRank,i,imax) |
---|
| 1043 | C |
---|
| 1044 | C |
---|
| 1045 | if (imin > tab2) then |
---|
| 1046 | C |
---|
| 1047 | i1 = imax - imin |
---|
| 1048 | C |
---|
| 1049 | else |
---|
| 1050 | C |
---|
| 1051 | i1 = max(tab1 - imin,0) |
---|
| 1052 | C |
---|
| 1053 | endif |
---|
| 1054 | C |
---|
| 1055 | if (imax < tab1) then |
---|
| 1056 | C |
---|
| 1057 | i2 = -(imax - imin) |
---|
| 1058 | C |
---|
| 1059 | else |
---|
| 1060 | C |
---|
| 1061 | i2 = min(tab2 - imax,0) |
---|
| 1062 | C |
---|
| 1063 | endif |
---|
| 1064 | C |
---|
| 1065 | deb = lb + i1 |
---|
| 1066 | C |
---|
| 1067 | fin = ub + i2 |
---|
| 1068 | C |
---|
| 1069 | C |
---|
| 1070 | End Subroutine GetLocalBoundaries |
---|
| 1071 | C |
---|
| 1072 | #endif |
---|
| 1073 | C |
---|
| 1074 | C |
---|
[2019] | 1075 | #ifdef key_mpp_mpi |
---|
[1901] | 1076 | C |
---|
| 1077 | C |
---|
| 1078 | C ************************************************************************** |
---|
| 1079 | CCC Subroutine Agrif_GlobtoLocInd2 |
---|
| 1080 | C ************************************************************************** |
---|
| 1081 | C |
---|
| 1082 | Subroutine Agrif_GlobtoLocInd2(tabarray,lboundl,uboundl,tab1,tab2, |
---|
| 1083 | & nbdim,rank,member) |
---|
| 1084 | C |
---|
| 1085 | CCC Description: |
---|
| 1086 | CCC For a global index located on the current processor, tabarray gives the |
---|
| 1087 | CCC corresponding local index |
---|
| 1088 | C |
---|
| 1089 | C |
---|
| 1090 | C Declarations: |
---|
| 1091 | C |
---|
| 1092 | |
---|
| 1093 | C |
---|
| 1094 | C Arguments |
---|
| 1095 | INTEGER :: nbdim |
---|
| 1096 | INTEGER,DIMENSION(nbdim) :: tab1,tab2 |
---|
| 1097 | INTEGER,DIMENSION(nbdim,2,2 ) :: tabarray |
---|
| 1098 | INTEGER,DIMENSION(nbdim) :: lboundl,uboundl |
---|
| 1099 | INTEGER :: rank |
---|
| 1100 | LOGICAL :: member |
---|
| 1101 | C |
---|
| 1102 | C Local variables |
---|
| 1103 | INTEGER :: i,i1,k |
---|
| 1104 | INTEGER :: nbloc(nbdim) |
---|
| 1105 | C |
---|
| 1106 | C |
---|
| 1107 | tabarray(:,1,:) = HUGE(1) |
---|
| 1108 | tabarray(:,2,:) = -HUGE(1) |
---|
| 1109 | |
---|
| 1110 | nbloc = 0 |
---|
| 1111 | C |
---|
| 1112 | do i = 1,nbdim |
---|
| 1113 | C |
---|
| 1114 | Call Agrif_Invloc(lboundl(i),rank,i,i1) |
---|
| 1115 | |
---|
| 1116 | do k=tab1(i)+lboundl(i)-i1,tab2(i)+lboundl(i)-i1 |
---|
| 1117 | IF ((k .GE. lboundl(i)) .AND. (k.LE.uboundl(i))) THEN |
---|
| 1118 | nbloc(i) = 1 |
---|
| 1119 | tabarray(i,1,1) = min(tabarray(i,1,1),k-lboundl(i)+i1) |
---|
| 1120 | tabarray(i,2,1) = max(tabarray(i,2,1),k-lboundl(i)+i1) |
---|
| 1121 | |
---|
| 1122 | tabarray(i,1,2) = min(tabarray(i,1,2),k) |
---|
| 1123 | tabarray(i,2,2) = max(tabarray(i,2,2),k) |
---|
| 1124 | ENDIF |
---|
| 1125 | enddo |
---|
| 1126 | C |
---|
| 1127 | enddo |
---|
| 1128 | |
---|
| 1129 | member = .FALSE. |
---|
| 1130 | IF (sum(nbloc) == nbdim) member = .TRUE. |
---|
| 1131 | C |
---|
| 1132 | Return |
---|
| 1133 | C |
---|
| 1134 | C |
---|
| 1135 | End Subroutine Agrif_GlobtoLocInd2 |
---|
| 1136 | C |
---|
| 1137 | #endif |
---|
| 1138 | |
---|
| 1139 | Subroutine Agrif_Copy_2d(tabout,tabin,l,m,inf,sup,inf2,sup2) |
---|
| 1140 | integer,dimension(2) :: l,m,inf,sup,inf2,sup2 |
---|
| 1141 | real,target,dimension(l(1):,l(2):) :: tabout |
---|
| 1142 | real,target,dimension(m(1):,m(2):) :: tabin |
---|
| 1143 | tabout(inf(1):sup(1), |
---|
| 1144 | & inf(2):sup(2)) = |
---|
| 1145 | & tabin(inf2(1):sup2(1), |
---|
| 1146 | & inf2(2):sup2(2)) |
---|
| 1147 | End Subroutine Agrif_Copy_2d |
---|
| 1148 | |
---|
| 1149 | Subroutine Agrif_Copy_3d(tabout,tabin,l,m,inf,sup,inf2,sup2) |
---|
| 1150 | integer,dimension(3) :: l,m,inf,sup,inf2,sup2 |
---|
| 1151 | real,target,dimension(l(1):,l(2):,l(3):) :: tabout |
---|
| 1152 | real,target,dimension(m(1):,m(2):,m(3):) :: tabin |
---|
| 1153 | tabout(inf(1):sup(1), |
---|
| 1154 | & inf(2):sup(2), |
---|
| 1155 | & inf(3):sup(3)) = |
---|
| 1156 | & tabin(inf2(1):sup2(1), |
---|
| 1157 | & inf2(2):sup2(2), |
---|
| 1158 | & inf2(3):sup2(3)) |
---|
| 1159 | End Subroutine Agrif_Copy_3d |
---|
| 1160 | |
---|
| 1161 | Subroutine Agrif_Copy_4d(tabout,tabin,l,m,inf,sup,inf2,sup2) |
---|
| 1162 | integer,dimension(4) :: l,m,inf,sup,inf2,sup2 |
---|
| 1163 | real,target,dimension(l(1):,l(2):,l(3):,l(4):) :: tabout |
---|
| 1164 | real,target,dimension(m(1):,m(2):,m(3):,m(4):) :: tabin |
---|
| 1165 | tabout(inf(1):sup(1), |
---|
| 1166 | & inf(2):sup(2), |
---|
| 1167 | & inf(3):sup(3), |
---|
| 1168 | & inf(4):sup(4)) = |
---|
| 1169 | & tabin(inf2(1):sup2(1), |
---|
| 1170 | & inf2(2):sup2(2), |
---|
| 1171 | & inf2(3):sup2(3), |
---|
| 1172 | & inf2(4):sup2(4)) |
---|
| 1173 | End Subroutine Agrif_Copy_4d |
---|
| 1174 | |
---|
| 1175 | End Module Agrif_Arrays |
---|