Page 1 Source Listing W3GSUC_R4 2014-11-12 21:37 w3gsrumd.f90 1 !/ ------------------------------------------------------------------- / 2 MODULE W3GSRUMD 3 !/ 4 !/ +-----------------------------------+ 5 !/ | WAVEWATCH III NOAA/NCEP | 6 !/ | T. J. Campbell, NRL | 7 !/ | FORTRAN 90 | 8 !/ | Last update : 15-Jun-2012 | 9 !/ +-----------------------------------+ 10 !/ 11 !/ 30-Oct-2009 : Origination. ( version 3.14 ) 12 !/ 12-Nov-2010 : Change T_NNS, W3NN*, W3SORT, W3ISRT to public. 13 !/ Add W3GFIJ (public). Implement r4 & r8 interfaces. 14 !/ Change to number of search buckets based on 15 !/ dimensions of input grid. ( version 3.14 ) 16 !/ 01-Dec-2010 : Assign cells to buckets based on overlap. The 17 !/ nearest-neighbor bucket search is removed (no longer 18 !/ needed). Add support for tripole grids (JCLO). 19 !/ Add W3GFCD (public). ( version 3.14 ) 20 !/ 06-Dec-2010 : Remove restriction on longitude range. Change ICLO 21 !/ to integer and remove JCLO. Implement support for 22 !/ r4 and r8 source grids. ( version 3.14 ) 23 !/ 15-Jun-2012 : Fixed various format statem,ents that gave compile 24 !/ warnings with Intel compiler on NCEP R&D machine 25 !/ zeus (H. L. Tolman) ( version 4.07 ) 26 !/ 27 ! 1. Purpose : 28 ! 29 ! Search and regrid utilities (data structures and associated 30 ! methods) for logically rectangular grids. 31 ! 32 ! The grid-search-utility (GSU) object can be used for rapid searching 33 ! of the associated grid to identify a grid cell that encloses a target 34 ! point and to compute interpolation weights. The GSU object maintains 35 ! internal pointers to the associated grid coordinate arrays. Rapid 36 ! searching is done using a bucket search algorithm. The search buckets 37 ! are based on the bounding box for the associated grid and an optional 38 ! user defined approximate number of grid cells per search bucket. 39 ! 40 ! Grid cells are identified by the cell's lower-left corner grid point. 41 ! The vertices (grid points) associated with a grid cell are assigned a 42 ! sequential index in a counterclockwise order beginning with the cell's 43 ! lower-left corner grid point. That is, when moving from vertex 1 to 44 ! vertex 2 to vertex 3, etc., the grid cell interior is always to the left. 45 ! Note that though cell will be counterclockwise w.r.t. indices, this does 46 ! not necessarily mean that the cell will be counterclockwise geographically, 47 ! specifically in situation of curvilinear grid. 48 ! 49 ! (x4,y4) (x3,y3) 50 ! _____________________ 51 ! / / 52 ! / / 53 ! / / 54 ! / / 55 ! /____________________/ 56 ! (x1,y1) (x2,y2) 57 ! Page 2 Source Listing W3GSUC_R4 2014-11-12 21:37 w3gsrumd.f90 58 ! There are two types of index space closure supported for lat/lon grids. 59 ! 60 ! 1) Simple closure: Grid is periodic in the i-index and wraps 61 ! at i=NX+1. In other words, (NX+1,j) => (1,j). 62 ! 63 ! 2) Tripole grid closure: Grid is periodic in the i-index and 64 ! and wraps at i=NX+1 and has closure at j=NY+1. In other words, 65 ! (NX+1,j<=NY) => (1,j) and (i,NY+1) => (MOD(NX-i+1,NX)+1,NY). 66 ! The tripole grid closure requires that NX be even. 67 ! 68 ! A simple interpolation example: 69 ! 70 ! ----------------------------------------------------------- 71 ! ! Define data 72 ! TYPE(T_GSU) :: GSU 73 ! INTEGER :: NX, NY !source grid dimensions 74 ! REAL, POINTER :: XS(:,:), YS(:,:) !source grid coordinates 75 ! REAL :: FS(NX,NY) !source field 76 ! INTEGER :: NT !number of target points 77 ! REAL :: XT(NT), YT(NT), FT(NT) !target coordinates and field 78 ! INTEGER :: IS(4), JS(4) !interpolation points 79 ! REAL :: RW(4) !interpolation weights 80 ! 81 ! ! Setup source grid and field and target points 82 ! < ... > 83 ! 84 ! ! Create grid-search-utility object for source grid 85 ! GSU = W3GSUC( .TRUE., .FALSE., .FALSE., NX, NY, XS, YS ) 86 ! 87 ! ! Interpolate source field to target points 88 ! DO K=1,NT 89 ! FT(K) = 0 90 ! IF ( W3GRMP( GSU, XT(K), YT(K), IS, JS, RW ) ) THEN 91 ! DO L=1,4 92 ! FT(K) = FT(K) + RW(L)*FS(IS(L),JS(L)) 93 ! END DO 94 ! END IF 95 ! END DO 96 ! 97 ! ! Destroy grid-search-utility object 98 ! CALL W3GSUD( GSU ) 99 ! ----------------------------------------------------------- 100 ! 101 ! 2. Variables and types : 102 ! 103 ! All module variables and types are scoped private by default. 104 ! The private module variables and types are not listed in this section. 105 ! 106 ! Name Type Scope Description 107 ! ---------------------------------------------------------------- 108 ! MSKC_NONE I.P. Public Named constant identifying a non-masked 109 ! enclosing grid cell 110 ! MSKC_PART I.P. Public Named constant identifying a partially 111 ! masked enclosing grid cell 112 ! MSKC_FULL I.P. Public Named constant identifying a fully 113 ! masked enclosing grid cell 114 ! ICLO_NONE I.P. Public Named constant identifying a grid with Page 3 Source Listing W3GSUC_R4 2014-11-12 21:37 w3gsrumd.f90 115 ! no closure in index space 116 ! ICLO_SMPL I.P. Public Named constant identifying a grid with 117 ! simple closure: (NX+1,j) => (1,j) 118 ! ICLO_TRPL I.P. Public Named constant identifying a grid with 119 ! tripole closure: (NX+1,j<=NY) => (1,j) 120 ! and (i,NY+1) => (MOD(NX-i+1,NX)+1,NY) 121 ! T_GSU TYPE Public Grid-search-utility type (opaque) 122 ! T_NNS TYPE Public Nearest-neighbor grid-point search type 123 ! ---------------------------------------------------------------- 124 ! 125 ! 3. Subroutines and functions : 126 ! 127 ! All module subroutines and functions are scoped private by default. 128 ! 129 ! Name Type Scope Description 130 ! ---------------------------------------------------------------- 131 ! W3GSUC Func. Public Create grid-search-utility object. 132 ! W3GSUD Subr. Public Destroy grid-search-utility object. 133 ! W3GSUP Subr. Public Print grid-search-utility object to stdout. 134 ! W3GFCL Func. Public Find grid cell that encloses target point (bucket search). 135 ! W3GFCD Func. Public Find grid cell that encloses target point (direct search). 136 ! W3GFPT Func. Public Find grid point that is closest to target point. 137 ! W3GRMP Func. Public Compute interpolation coeff. from grid. 138 ! W3DIST Func. Public Compute distance between two points. 139 ! W3INAN Func. Public Check if input is infinite or NaN. 140 ! W3NNSC Func. Public Create nearest-neighbor-search object. 141 ! W3NNSD Subr. Public Destroy nearest-neighbor-search object. 142 ! W3NNSP Subr. Public Print nearest-neighbor-search object to stdout. 143 ! W3SORT Subr. Public Sort input arrays in increasing order. 144 ! W3ISRT Subr. Public Insert data into array. 145 ! W3CKCL Func. Public Check if point lies within grid cell. 146 ! ---------------------------------------------------------------- 147 ! W3RMBL Subr. Private Compute bilinear interpolation coeff. from cell. 148 ! ---------------------------------------------------------------- 149 ! 150 ! 4. Subroutines and functions used : 151 ! 152 ! Name Type Module Description 153 ! ---------------------------------------------------------------- 154 ! STRACE Subr. W3SERVMD Subroutine tracing. 155 ! EXTCDE Subr. W3SERVMD Abort program with exit code. 156 ! ---------------------------------------------------------------- 157 ! 158 ! 5. Remarks : 159 ! 160 ! - The GSU object is an "opaque" object. This means that the 161 ! internals of the object are not accessible outside this module. 162 ! - The burden is upon the user to invoke the destroy method when 163 ! finished with a GSU object. If created GSU objects are 164 ! not properly destroyed, then memory leaks may be introduced. 165 ! 166 ! 6. Switches : 167 ! 168 ! !/S Enable subroutine tracing. 169 ! 170 ! 7. Source code : 171 ! Page 4 Source Listing W3GSUC_R4 2014-11-12 21:37 w3gsrumd.f90 172 !/ ------------------------------------------------------------------- / 173 !/ 174 !/ Use associated modules 175 !/ 176 USE W3SERVMD, ONLY: EXTCDE 177 !/ 178 !/ Specify default data typing 179 !/ 180 IMPLICIT NONE 181 !/ 182 !/ Specify default accessibility 183 !/ 184 PRIVATE 185 !/ 186 !/ Public module methods 187 !/ 188 PUBLIC W3GSUC 189 PUBLIC W3GSUD 190 PUBLIC W3GSUP 191 PUBLIC W3GFCL 192 PUBLIC W3GFCD 193 PUBLIC W3GFPT 194 PUBLIC W3GFIJ 195 PUBLIC W3GRMP 196 PUBLIC W3DIST 197 PUBLIC W3INAN 198 PUBLIC W3NNSC 199 PUBLIC W3NNSD 200 PUBLIC W3NNSP 201 PUBLIC W3SORT 202 PUBLIC W3ISRT 203 PUBLIC W3CKCL 204 !/ 205 !/ Public return codes 206 !/ 207 INTEGER, PARAMETER, PUBLIC :: MSKC_NONE = 0 208 INTEGER, PARAMETER, PUBLIC :: MSKC_PART = 1 209 INTEGER, PARAMETER, PUBLIC :: MSKC_FULL = 2 210 !/ 211 !/ Public index closure types (for lat/lon grids only) 212 !/ ICLO_NONE : no closure in index space 213 !/ ICLO_SMPL : closure in i-index at i=NX+1: (NX+1,j) => (1,j) 214 !/ ICLO_TRPL : tripole grid closure: (NX+1,j<=NY) => (1,j) and 215 !/ (i,NY+1) => (MOD(NX-i+1,NX)+1,NY) 216 !/ 217 INTEGER, PARAMETER, PUBLIC :: ICLO_NONE = 0 218 INTEGER, PARAMETER, PUBLIC :: ICLO_SMPL = 1 219 INTEGER, PARAMETER, PUBLIC :: ICLO_TRPL = 2 220 !/ 221 !/ Public grid-search-utility type 222 !/ This is an opaque type -- that is, it's internals are private and only 223 !/ accessible to subroutines in this module where the type is declared. 224 !/ 225 TYPE, PUBLIC :: T_GSU 226 PRIVATE 227 TYPE(CLASS_GSU), POINTER :: PTR => NULL() 228 END TYPE T_GSU Page 5 Source Listing W3GSUC_R4 2014-11-12 21:37 w3gsrumd.f90 229 !/ 230 !/ Private grid-search-utility class 231 !/ 232 TYPE :: CLASS_GSU 233 LOGICAL :: IJG ! grid array ordering flag: T = (NX,NY), F = (NY,NX) 234 LOGICAL :: LLG ! spherical coordinate flag of associated grid 235 INTEGER :: ICLO ! parameter indicating type of index space closure 236 ! this flag must be set by the user 237 LOGICAL :: LCLO ! flag indicating longitudinal periodicity 238 ! this flag is calculated internally 239 ! ICLO != ICLO_NONE => LCLO = T 240 LOGICAL :: L360 ! flag indicating longitude range: 241 ! T = [0:360], F = [-180:180] 242 INTEGER :: GKIND ! kind (precision: 4 or 8) of associated grid 243 INTEGER :: NX, NY ! dimensions of associated grid 244 REAL(4), POINTER :: XG4(:,:), YG4(:,:) ! coordinates of associated grid (r4) 245 REAL(8), POINTER :: XG8(:,:), YG8(:,:) ! coordinates of associated grid (r8) 246 TYPE(T_NNS), POINTER :: NNP ! nearest-neighbor point search indices object 247 INTEGER :: NBX, NBY ! number of buckets in each spatial direction 248 REAL(8) :: DXB, DYB ! spatial extent of each search bucket 249 REAL(8) :: XMIN, YMIN, XMAX, YMAX ! bounding box of search domain 250 TYPE(T_BKT), POINTER :: B(:,:) ! array of search buckets 251 END TYPE CLASS_GSU 252 !/ 253 !/ Private search bucket type 254 !/ 255 TYPE :: T_BKT 256 INTEGER :: N ! number of cells in bucket 257 INTEGER, POINTER :: I(:) ! i-index of cell c 258 INTEGER, POINTER :: J(:) ! j-index of cell c 259 END TYPE T_BKT 260 !/ 261 !/ Public nearest-neighbor grid-point search type 262 !/ 263 TYPE, PUBLIC :: T_NNS 264 INTEGER :: NLVL ! number of nnbr levels 265 INTEGER :: NNBR ! total number of nnbr's 266 INTEGER, POINTER :: N1(:) ! starting nearest-nbr loop index for level l 267 INTEGER, POINTER :: N2(:) ! ending nearest-nbr loop index for level l 268 INTEGER, POINTER :: DI(:) ! i-index delta for nearest-nbr n 269 INTEGER, POINTER :: DJ(:) ! j-index delta for nearest-nbr n 270 END TYPE T_NNS 271 !/ 272 !/ Private module parameters 273 !/ 274 REAL(8), PARAMETER :: PI = 3.14159265358979323846D0 275 REAL(8), PARAMETER :: PI2 = 2D0*PI 276 REAL(8), PARAMETER :: PI3H = 3D0*PI/2D0 277 REAL(8), PARAMETER :: D2R = PI/180D0 278 REAL(8), PARAMETER :: R2D = 1D0/D2R 279 REAL(8), PARAMETER :: D360 = 360D0 280 REAL(8), PARAMETER :: D270 = 270D0 281 REAL(8), PARAMETER :: D180 = 180D0 282 REAL(8), PARAMETER :: D90 = 90D0 283 REAL(8), PARAMETER :: ZERO = 0.0D0 284 REAL(8), PARAMETER :: ONE = 1.0D0 285 REAL(8), PARAMETER :: HALF = 0.5D0 Page 6 Source Listing W3GSUC_R4 2014-11-12 21:37 w3gsrumd.f90 286 !/ 287 !/ Module Interfaces 288 !/ 289 INTERFACE W3GSUC 290 MODULE PROCEDURE W3GSUC_R4 291 MODULE PROCEDURE W3GSUC_R8 292 END INTERFACE W3GSUC 293 INTERFACE W3GFCL 294 MODULE PROCEDURE W3GFCL_R4 295 MODULE PROCEDURE W3GFCL_R8 296 END INTERFACE W3GFCL 297 INTERFACE W3GFCD 298 MODULE PROCEDURE W3GFCD_R4 299 MODULE PROCEDURE W3GFCD_R8 300 END INTERFACE W3GFCD 301 INTERFACE W3GFPT 302 MODULE PROCEDURE W3GFPT_R4 303 MODULE PROCEDURE W3GFPT_R8 304 END INTERFACE W3GFPT 305 INTERFACE W3GFIJ 306 MODULE PROCEDURE W3GFIJ_R4 307 MODULE PROCEDURE W3GFIJ_R8 308 END INTERFACE W3GFIJ 309 INTERFACE W3GRMP 310 MODULE PROCEDURE W3GRMP_R4 311 MODULE PROCEDURE W3GRMP_R8 312 END INTERFACE W3GRMP 313 INTERFACE W3RMBL 314 MODULE PROCEDURE W3RMBL_R4 315 MODULE PROCEDURE W3RMBL_R8 316 END INTERFACE W3RMBL 317 INTERFACE W3DIST 318 MODULE PROCEDURE W3DIST_R4 319 MODULE PROCEDURE W3DIST_R8 320 END INTERFACE W3DIST 321 INTERFACE W3CKCL 322 MODULE PROCEDURE W3CKCL_R4 323 MODULE PROCEDURE W3CKCL_R8 324 END INTERFACE W3CKCL 325 INTERFACE W3SORT 326 MODULE PROCEDURE W3SORT_R4 327 MODULE PROCEDURE W3SORT_R8 328 END INTERFACE W3SORT 329 INTERFACE W3ISRT 330 MODULE PROCEDURE W3ISRT_R4 331 MODULE PROCEDURE W3ISRT_R8 332 END INTERFACE W3ISRT 333 INTERFACE W3INAN 334 MODULE PROCEDURE W3INAN_R4 335 MODULE PROCEDURE W3INAN_R8 336 END INTERFACE W3INAN 337 338 !/ 339 CONTAINS 340 !/ ------------------------------------------------------------------- / 341 FUNCTION W3GSUC_R4(IJG, LLG, ICLO, NX, NY, XG, YG, NCB, NNP, DEBUG) & 342 RESULT(GSU) Page 7 Source Listing W3GSUC_R4 2014-11-12 21:37 w3gsrumd.f90 343 !/ 344 !/ +-----------------------------------+ 345 !/ | WAVEWATCH III NOAA/NCEP | 346 !/ | T. J. Campbell, NRL | 347 !/ | FORTRAN 90 | 348 !/ | Last update : 06-Dec-2010 | 349 !/ +-----------------------------------+ 350 !/ 351 !/ 30-Oct-2009 : Origination. ( version 3.14 ) 352 !/ 12-Nov-2010 : Change to number of search buckets based on 353 !/ dimensions of input grid. ( version 3.14 ) 354 !/ 01-Dec-2010 : Restore NCB optional input. Assign cells to buckets 355 !/ based on overlap. The nearest-neighbor bucket search 356 !/ is removed (no longer needed). Add support for 357 !/ tripole grids (JCLO). ( version 3.14 ) 358 !/ 06-Dec-2010 : Remove restriction on longitude range. Change 359 !/ ICLO to integer and remove JCLO. Implement r4 and r8 360 !/ input grid versions. ( version 3.14 ) 361 !/ 362 ! 1. Purpose : 363 ! 364 ! Create grid-search-utility (GSU) object for a logically rectangular 365 ! grid defined by the input coordinates. 366 ! Single precision input grid. 367 ! 368 ! 2. Method : 369 ! 370 ! 3. Parameters : 371 ! 372 ! Return parameter 373 ! ---------------------------------------------------------------- 374 ! GSU Type O Created grid-search-utility object. 375 ! ---------------------------------------------------------------- 376 ! 377 ! Parameter list 378 ! ---------------------------------------------------------------- 379 ! IJG Log. I Logical flag indicating ordering of input 380 ! coord. arrays: T = (NX,NY) and F = (NY,NX). 381 ! LLG Log. I Logical flag indicating the coordinate system: 382 ! T = spherical lat/lon (degrees) and F = Cartesian. 383 ! ICLO Int. I Parameter indicating type of index space closure 384 ! NX, NY Int. I Dimensions of input grid. 385 ! XG R.A. I Pointer to array of x-coordinates of input grid. 386 ! YG R.A. I Pointer to array of y-coordinates of input grid. 387 ! NCB Int. I Optional (approximate) number of cells (in each 388 ! direction) per search bucket. (default is NCB_DEFAULT) 389 ! NCB >= 1 is required. NCB = 1 gives most efficient 390 ! searching, but uses more memory. Increasing NCB leads 391 ! to fewer buckets (less memory) but slower searching. 392 ! NNP Int. I Optional maximum number of nearest-neighbor grid 393 ! point search levels. (default is NNP_DEFAULT) 394 ! DEBUG Log. I Optional logical flag to turn on debug mode. 395 ! Default is FALSE. 396 ! 397 ! Internal parameters 398 ! ---------------------------------------------------------------- 399 ! NCB_DEFAULT Int. Default number of grid cells (in each direction) Page 8 Source Listing W3GSUC_R4 2014-11-12 21:37 w3gsrumd.f90 400 ! per search bucket. 401 ! NNP_DEFAULT Int. Default maximum number of nearest-neighbor grid 402 ! point search levels. 403 ! ---------------------------------------------------------------- 404 ! 405 ! 4. Subroutines used : 406 ! 407 ! See module documentation. 408 ! 409 ! 5. Called by : 410 ! 411 ! 6. Error messages : 412 ! 413 ! - Check on correct coordinate system with global grid. 414 ! - Check on association of input grid coordinate array pointers. 415 ! 416 ! 7. Remarks : 417 ! 418 ! - LCLO is calculated internally. 419 ! - ICLO != ICLO_NONE => LCLO = T. 420 ! - Periodic Cartesian grids are not allowed. 421 ! 422 ! 8. Structure : 423 ! 424 ! ----------------------------------------------------------------- 425 ! 1. Test input 426 ! 2. Allocate object and set grid related data and pointers 427 ! 3. Create nearest-neighbor point search object 428 ! 4. Construct bucket search "object" 429 ! 5. Set return parameter 430 ! ----------------------------------------------------------------- 431 ! 432 ! 9. Switches : 433 ! 434 ! !/S Enable subroutine tracing. 435 ! !/T8 Enables debugging flag. 436 ! 437 ! 10. Source code : 438 ! 439 !/ ------------------------------------------------------------------- / 440 !/ 441 !/ ------------------------------------------------------------------- / 442 !/ Return parameter 443 !/ 444 TYPE(T_GSU) :: GSU 445 !/ 446 !/ ------------------------------------------------------------------- / 447 !/ Parameter list 448 !/ 449 LOGICAL, INTENT(IN) :: IJG 450 LOGICAL, INTENT(IN) :: LLG 451 INTEGER, INTENT(IN) :: ICLO 452 INTEGER, INTENT(IN) :: NX, NY 453 REAL(4), POINTER :: XG(:,:), YG(:,:) 454 INTEGER, INTENT(IN), OPTIONAL :: NCB 455 INTEGER, INTENT(IN), OPTIONAL :: NNP 456 LOGICAL, INTENT(IN), OPTIONAL :: DEBUG Page 9 Source Listing W3GSUC_R4 2014-11-12 21:37 w3gsrumd.f90 457 !/ 458 !/ ------------------------------------------------------------------- / 459 !/ Local parameters 460 !/ 461 TYPE(CLASS_GSU), POINTER :: PTR 462 INTEGER, PARAMETER :: NCB_DEFAULT = 1 463 INTEGER, PARAMETER :: NNP_DEFAULT = 2 464 LOGICAL :: LDBG, LBC, LPL, LNPL, LSPL 465 INTEGER :: I, J, K, L, N, IC(4), JC(4), IB, JB, NXC, NYC 466 INTEGER :: NS, IB1(2), IB2(2), JB1(2), JB2(2), IBC(4), JBC(4) 467 INTEGER :: ISTEP, ISTAT 468 REAL(8) :: X, Y, XC(4), YC(4) 469 !/ 470 ! -------------------------------------------------------------------- / 471 ! 1. Test input 472 ! 473 SELECT CASE ( ICLO ) 474 CASE ( ICLO_NONE, ICLO_SMPL, ICLO_TRPL ) 475 CONTINUE 476 CASE DEFAULT 477 WRITE(*,'(/1A,1A,1I2/)') 'W3GSUC_R4 ERROR -- ', & 478 'unsupported ICLO: ',ICLO 479 CALL EXTCDE (1) 480 END SELECT 481 482 IF ( ICLO.NE.ICLO_NONE .AND. .NOT.LLG ) THEN 483 WRITE(*,'(/1A,1A/)') 'W3GSUC_R4 ERROR -- ', & 484 'index space closure with cartesian grids is not supported' 485 CALL EXTCDE (1) 486 END IF 487 488 IF ( ICLO.EQ.ICLO_TRPL .AND. MOD(NX,2).NE.0 ) THEN 489 WRITE(*,'(/1A,1A/)') 'W3GSUC_R4 ERROR -- ', & 490 'tripole grid closure requires NX even' 491 CALL EXTCDE (1) 492 END IF 493 494 IF ( .NOT.ASSOCIATED(XG) .OR. .NOT.ASSOCIATED(YG) ) THEN 495 WRITE(*,'(/1A,1A/)') 'W3GSUC_R4 ERROR -- ', & 496 'input grid coordinate array pointers are not associated' 497 CALL EXTCDE (1) 498 END IF 499 500 IF ( PRESENT(NCB) ) THEN 501 IF ( NCB .LE. 0 ) THEN 502 WRITE(*,'(/1A,1A/)') 'W3GSUC_R4 ERROR -- ', & 503 'NCB must be greater than zero' 504 CALL EXTCDE (1) 505 END IF 506 END IF 507 ! 508 IF ( PRESENT(DEBUG) ) THEN 509 LDBG = DEBUG 510 ELSE 511 LDBG = .FALSE. 512 END IF 513 ! Page 10 Source Listing W3GSUC_R4 2014-11-12 21:37 w3gsrumd.f90 514 ! -------------------------------------------------------------------- / 515 ! 2. Allocate object and set grid related data and pointers 516 ! 517 ALLOCATE(PTR, STAT=ISTAT) 518 IF ( ISTAT .NE. 0 ) THEN 519 WRITE(*,'(/1A,1A/)') 'W3GSUC_R4 ERROR -- ', & 520 'gsu object allocation failed' 521 CALL EXTCDE (ISTAT) 522 END IF 523 PTR%IJG = IJG 524 PTR%LLG = LLG 525 PTR%ICLO = ICLO 526 PTR%NX = NX 527 PTR%NY = NY 528 PTR%XG4 => XG 529 PTR%YG4 => YG 530 PTR%GKIND = 4 531 ! 532 ! -------------------------------------------------------------------- / 533 ! 3. Create nearest-neighbor point search object 534 ! 535 IF ( PRESENT(NNP) ) THEN 536 PTR%NNP => W3NNSC(NNP) 537 ELSE 538 PTR%NNP => W3NNSC(NNP_DEFAULT) 539 END IF 540 ! 541 ! -------------------------------------------------------------------- / 542 ! 4. Construct bucket search "object" 543 ! 544 !-----number of cells 545 SELECT CASE ( ICLO ) 546 CASE ( ICLO_NONE ) 547 NXC = NX-1; NYC = NY-1; 548 CASE ( ICLO_SMPL ) 549 NXC = NX; NYC = NY-1; 550 CASE ( ICLO_TRPL ) 551 NXC = NX; NYC = NY; 552 END SELECT 553 ! 554 !-----initialize longitudinal periodicity flag (LCLO) 555 IF ( LLG .AND. ICLO.NE.ICLO_NONE ) THEN 556 PTR%LCLO = .TRUE. 557 ELSE 558 PTR%LCLO = .FALSE. 559 END IF 560 ! 561 !-----check existence of longitudinal branch cut 562 !-----check if source grid includes poles 563 IF ( LDBG ) THEN 564 WRITE(*,'(/A)') 'W3GSUC_R4 - check source grid' 565 END IF 566 LNPL = .FALSE. 567 LSPL = .FALSE. 568 DO I=1,NXC 569 DO J=1,NYC 570 !-------------create list of cell vertices Page 11 Source Listing W3GSUC_R4 2014-11-12 21:37 w3gsrumd.f90 571 IC(1) = I ; JC(1) = J ; 572 IC(2) = I+1; JC(2) = J ; 573 IC(3) = I+1; JC(3) = J+1; 574 IC(4) = I ; JC(4) = J+1; 575 DO L=1,4 576 !-----------------i-closure 577 IF ( ICLO.NE.ICLO_NONE ) THEN 578 IF ( IC(L) .LT. 1 ) IC(L) = IC(L) + NX 579 IF ( IC(L) .GT. NX ) IC(L) = IC(L) - NX 580 END IF 581 !-----------------j-closure 582 IF ( ICLO.EQ.ICLO_TRPL ) THEN 583 IF ( JC(L) .GT. NY ) THEN 584 JC(L) = NY 585 IC(L) = MOD(NX-IC(L)+1,NX) + 1 586 END IF 587 END IF 588 !-----------------copy cell vertex coordinates into local variables 589 IF ( IJG ) THEN 590 XC(L) = XG(IC(L),JC(L)); YC(L) = YG(IC(L),JC(L)); 591 ELSE 592 XC(L) = XG(JC(L),IC(L)); YC(L) = YG(JC(L),IC(L)); 593 END IF 594 END DO !L 595 !-------------check if cell includes a pole or branch cut 596 LPL = .FALSE. 597 LBC = .FALSE. 598 IF ( LLG ) THEN 599 !-----------------count longitudinal branch cut crossings 600 N = 0 601 DO L=1,4 602 K = MOD(L,4)+1 603 IF ( ABS(XC(K)-XC(L)) .GT. D180 ) N = N + 1 604 END DO 605 !-----------------multiple longitudinal branch cut crossing => cell includes branch cut 606 LBC = N.GT.1 607 IF ( LBC .AND. LDBG ) & 608 WRITE(*,'(A,8I6)') & 609 'W3GSUC_R4 -- cell includes branch cut:',IC(:),JC(:) 610 !-----------------single longitudinal branch cut crossing 611 ! or single vertex at 90 degrees => cell includes pole 612 LPL = N.EQ.1 .OR. COUNT(ABS(YC).EQ.D90).EQ.1 613 IF ( LPL.AND.MINVAL(YC).GT.ZERO ) THEN 614 IF ( LDBG ) & 615 WRITE(*,'(A,8I6)') & 616 'W3GSUC_R4 -- cell includes N-pole:',IC(:),JC(:) 617 LNPL = .TRUE. 618 END IF 619 IF ( LPL.AND.MAXVAL(YC).LT.ZERO ) THEN 620 IF ( LDBG ) & 621 WRITE(*,'(A,8I6)') & 622 'W3GSUC_R4 -- cell includes S-pole:',IC(:),JC(:) 623 LSPL = .TRUE. 624 END IF 625 !-----------------longitudinal branch cut crossing => longitudinal closure 626 IF ( N.GT.0 ) PTR%LCLO = .TRUE. 627 END IF !LLG Page 12 Source Listing W3GSUC_R4 2014-11-12 21:37 w3gsrumd.f90 628 END DO !J 629 END DO !I 630 ! 631 !-----compute domain for search buckets 632 ! if longitudinal periodicity, then force domain in x to [0:360] 633 ! if grid includes north pole, then set ymax = 90 degrees 634 ! if grid includes south pole, then set ymin = -90 degrees 635 PTR%XMIN = MINVAL(XG); PTR%XMAX = MAXVAL(XG); 636 PTR%YMIN = MINVAL(YG); PTR%YMAX = MAXVAL(YG); 637 IF ( PTR%LCLO ) THEN 638 PTR%XMIN = ZERO; PTR%XMAX = D360; 639 END IF 640 IF ( LSPL ) PTR%YMIN = -D90 641 IF ( LNPL ) PTR%YMAX = D90 642 PTR%L360 = PTR%XMIN.GE.ZERO 643 ! 644 !-----compute number of search buckets and bucket size 645 IF ( PRESENT(NCB) ) THEN 646 PTR%NBX = MAX(1,NX/NCB) 647 PTR%NBY = MAX(1,NY/NCB) 648 ELSE 649 PTR%NBX = MAX(1,NX/NCB_DEFAULT) 650 PTR%NBY = MAX(1,NY/NCB_DEFAULT) 651 END IF 652 PTR%DXB = (PTR%XMAX-PTR%XMIN)/REAL(PTR%NBX) 653 PTR%DYB = (PTR%YMAX-PTR%YMIN)/REAL(PTR%NBY) 654 ! 655 !-----print debug info 656 IF ( LDBG ) THEN 657 WRITE(*,'(/A,1I2,1L2,1I2)') 'W3GSUC_R4 - ICLO,LCLO,GKIND: ', & 658 PTR%ICLO,PTR%LCLO,PTR%GKIND 659 WRITE(*,'(A,4E14.6)') 'W3GSUC_R4 - grid search domain:', & 660 PTR%XMIN,PTR%YMIN,PTR%XMAX,PTR%YMAX 661 WRITE(*,'(A,2I6)') 'W3GSUC_R4 - number of search buckets:', & 662 PTR%NBX,PTR%NBY 663 WRITE(*,'(A,2E14.6)') 'W3GSUC_R4 - search bucket size:', & 664 PTR%DXB,PTR%DYB 665 END IF 666 ! 667 !-----allocate array of search buckets 668 ALLOCATE(PTR%B(PTR%NBY,PTR%NBX),STAT=ISTAT) 669 IF ( ISTAT .NE. 0 ) THEN 670 WRITE(*,'(/1A,1A/)') 'W3GSUC_R4 ERROR -- ', & 671 'search bucket array allocation failed' 672 CALL EXTCDE (ISTAT) 673 END IF 674 ! 675 !-----BEGIN ISTEP_LOOP 676 ! first step: compute number of cells in each bucket 677 ! second step: allocate buckets and assign cells to buckets 678 ISTEP_LOOP: DO ISTEP=1,2 679 ! 680 !-----allocate search bucket cell lists 681 IF ( ISTEP .EQ. 2 ) THEN 682 DO IB=1,PTR%NBX 683 DO JB=1,PTR%NBY 684 NULLIFY(PTR%B(JB,IB)%I) Page 13 Source Listing W3GSUC_R4 2014-11-12 21:37 w3gsrumd.f90 685 NULLIFY(PTR%B(JB,IB)%J) 686 IF ( PTR%B(JB,IB)%N .GT. 0 ) THEN 687 ALLOCATE(PTR%B(JB,IB)%I(PTR%B(JB,IB)%N),STAT=ISTAT) 688 IF ( ISTAT .NE. 0 ) THEN 689 WRITE(*,'(/1A,2A,3I6/)') 'W3GSUC_R4 ERROR -- ', & 690 'search bucket cell-i list allocation failed -- ', & 691 'bucket: ',IB,JB,N 692 CALL EXTCDE (ISTAT) 693 END IF 694 ALLOCATE(PTR%B(JB,IB)%J(PTR%B(JB,IB)%N),STAT=ISTAT) 695 IF ( ISTAT .NE. 0 ) THEN 696 WRITE(*,'(/1A,2A,3I6/)') 'W3GSUC_R4 ERROR -- ', & 697 'search bucket cell-j list allocation failed -- ', & 698 'bucket: ',IB,JB,N 699 CALL EXTCDE (ISTAT) 700 END IF 701 END IF 702 END DO 703 END DO 704 END IF !ISTEP.EQ.2 705 ! 706 !-----build search bucket cell lists 707 PTR%B(:,:)%N = 0 708 DO I=1,NXC 709 DO J=1,NYC 710 IF ( ICLO.EQ.ICLO_TRPL ) THEN 711 IF ( J.EQ.NYC .AND. I.GT.NX/2+1 ) CYCLE 712 ENDIF 713 !-------------create list of cell vertices 714 IC(1) = I ; JC(1) = J ; 715 IC(2) = I+1; JC(2) = J ; 716 IC(3) = I+1; JC(3) = J+1; 717 IC(4) = I ; JC(4) = J+1; 718 DO L=1,4 719 !-----------------i-closure 720 IF ( ICLO.NE.ICLO_NONE ) THEN 721 IF ( IC(L) .LT. 1 ) IC(L) = IC(L) + NX 722 IF ( IC(L) .GT. NX ) IC(L) = IC(L) - NX 723 END IF 724 !-----------------j-closure 725 IF ( ICLO.EQ.ICLO_TRPL ) THEN 726 IF ( JC(L) .GT. NY ) THEN 727 JC(L) = NY 728 IC(L) = MOD(NX-IC(L)+1,NX) + 1 729 END IF 730 END IF 731 !-----------------copy cell vertex coordinates into local variables 732 IF ( IJG ) THEN 733 XC(L) = XG(IC(L),JC(L)); YC(L) = YG(IC(L),JC(L)); 734 ELSE 735 XC(L) = XG(JC(L),IC(L)); YC(L) = YG(JC(L),IC(L)); 736 END IF 737 END DO !L 738 !-------------check if cell includes a pole or branch cut 739 LPL = .FALSE. 740 LBC = .FALSE. 741 IF ( LLG ) THEN Page 14 Source Listing W3GSUC_R4 2014-11-12 21:37 w3gsrumd.f90 742 !-----------------shift longitudes to appropriate range 743 XC = MOD(XC,D360) 744 IF ( PTR%LCLO .OR. PTR%L360 ) THEN 745 WHERE ( XC.LT.ZERO ) XC = XC + D360 746 ELSE 747 WHERE ( XC.GT.D180 ) XC = XC - D360 748 END IF 749 !-----------------count longitudinal branch cut crossings 750 N = 0 751 DO L=1,4 752 K = MOD(L,4)+1 753 IF ( ABS(XC(K)-XC(L)) .GT. D180 ) N = N + 1 754 END DO 755 !-----------------multiple longitudinal branch cut crossing => cell includes branch cut 756 LBC = N.GT.1 757 !-----------------single longitudinal branch cut crossing 758 ! or single vertex at 90 degrees => cell includes pole 759 LPL = N.EQ.1 .OR. COUNT(ABS(YC).EQ.D90).EQ.1 760 END IF !LLG 761 !-------------set bucket id for each cell vertex 762 DO L=1,4 763 IBC(L) = INT((XC(L)-PTR%XMIN)/PTR%DXB)+1 764 IF ( .NOT.PTR%LCLO ) IBC(L) = MIN(IBC(L),PTR%NBX) 765 JBC(L) = MIN(INT((YC(L)-PTR%YMIN)/PTR%DYB)+1,PTR%NBY) 766 END DO !L 767 !-------------set bucket overlap bounds 768 IF ( LPL ) THEN 769 !---------------cell includes pole: overlap includes full longitudinal range 770 NS = 1 771 IB1(1) = 1 772 IB2(1) = PTR%NBX 773 IF ( MINVAL(YC).GT.ZERO ) THEN 774 JB1(1) = MAX(1,MINVAL(JBC)) 775 JB2(1) = PTR%NBY 776 END IF 777 IF ( MAXVAL(YC).LT.ZERO ) THEN 778 JB1(1) = 1 779 JB2(1) = MIN(PTR%NBY,MAXVAL(JBC)) 780 END IF 781 IB1(2) = 0 782 IB2(2) = 0 783 JB1(2) = 0 784 JB2(2) = 0 785 ELSE IF ( LBC ) THEN 786 !---------------cell includes branch cut: split overlap into two sets 787 NS = 2 788 IB1(1) = PTR%NBX 789 IB2(1) = PTR%NBX 790 IB1(2) = 1 791 IB2(2) = 1 792 DO L=1,4 793 IF ( IBC(L) .GT. PTR%NBX/2 ) THEN 794 IB1(1) = MIN(IB1(1),IBC(L)) 795 ELSE 796 IB2(2) = MAX(IB2(2),IBC(L)) 797 END IF 798 END DO !L Page 15 Source Listing W3GSUC_R4 2014-11-12 21:37 w3gsrumd.f90 799 JB1(:) = MAX(1,MINVAL(JBC)) 800 JB2(:) = MIN(PTR%NBY,MAXVAL(JBC)) 801 ELSE 802 !---------------default: overlap computed from min/max 803 NS = 1 804 IB1(1) = MAX(1,MINVAL(IBC)) 805 IB2(1) = MIN(PTR%NBX,MAXVAL(IBC)) 806 JB1(1) = MAX(1,MINVAL(JBC)) 807 JB2(1) = MIN(PTR%NBY,MAXVAL(JBC)) 808 IB1(2) = 0 809 IB2(2) = 0 810 JB1(2) = 0 811 JB2(2) = 0 812 END IF 813 !-------------debug output 814 IF ( LDBG .AND. ISTEP.EQ.1 ) THEN 815 WRITE(*,'(/A,2I6)') 'W3GSUC_R4 -- BUCKET SORT:',I,J 816 WRITE(*,'(A,2L6,1I6)') 'W3GSUC_R4 -- LBC,LPL:',LBC,LPL 817 WRITE(*,'(A,4I6)') 'W3GSUC_R4 -- IC:',IC(:) 818 WRITE(*,'(A,4I6)') 'W3GSUC_R4 -- JC:',JC(:) 819 WRITE(*,'(A,4E14.6)') 'W3GSUC_R4 -- XC:',XC(:) 820 WRITE(*,'(A,4E14.6)') 'W3GSUC_R4 -- YC:',YC(:) 821 WRITE(*,'(A,4I6)') 'W3GSUC_R4 -- IBC:',IBC(:) 822 WRITE(*,'(A,4I6)') 'W3GSUC_R4 -- JBC:',JBC(:) 823 WRITE(*,'(A,1I6)') 'W3GSUC_R4 -- NS:',NS 824 WRITE(*,'(A,4I6)') 'W3GSUC_R4 -- IB1:',IB1(:) 825 WRITE(*,'(A,4I6)') 'W3GSUC_R4 -- JB1:',JB1(:) 826 WRITE(*,'(A,4I6)') 'W3GSUC_R4 -- IB2:',IB2(:) 827 WRITE(*,'(A,4I6)') 'W3GSUC_R4 -- JB2:',JB2(:) 828 END IF 829 !-------------assign cell to buckets based on overlap 830 DO K=1,NS 831 DO IB=IB1(K),IB2(K) 832 DO JB=JB1(K),JB2(K) 833 PTR%B(JB,IB)%N = PTR%B(JB,IB)%N + 1 834 IF ( ISTEP .EQ. 2 ) THEN 835 PTR%B(JB,IB)%I(PTR%B(JB,IB)%N) = IC(1) 836 PTR%B(JB,IB)%J(PTR%B(JB,IB)%N) = JC(1) 837 END IF 838 END DO !JB 839 END DO !IB 840 END DO !K 841 END DO !J 842 END DO !I 843 ! 844 !-----END ISTEP_LOOP 845 END DO ISTEP_LOOP 846 ! 847 !-----print debug info 848 IF ( LDBG ) THEN 849 WRITE(*,'(/A,3I6,4E14.6)') 'W3GSUC_R4 - search bucket list:' 850 WRITE(*,'(3A6,4A14)') 'I','J','N','X1','Y1','X2','Y2' 851 DO IB=1,PTR%NBX 852 DO JB=1,PTR%NBY 853 WRITE(*,'(3I6,4E14.6)') IB,JB,PTR%B(JB,IB)%N, & 854 PTR%XMIN+(IB-1)*PTR%DXB,PTR%YMIN+(JB-1)*PTR%DYB, & 855 PTR%XMIN+(IB-0)*PTR%DXB,PTR%YMIN+(JB-0)*PTR%DYB Page 16 Source Listing W3GSUC_R4 2014-11-12 21:37 w3gsrumd.f90 856 END DO 857 END DO 858 END IF 859 ! 860 ! -------------------------------------------------------------------- / 861 ! 5. Set return parameter 862 ! 863 GSU%PTR => PTR 864 !/ 865 !/ End of W3GSUC_R4 -------------------------------------------------- / 866 !/ 867 END FUNCTION W3GSUC_R4 ENTRY POINTS Name w3gsrumd_mp_w3gsuc_r4_ SYMBOL CROSS REFERENCE Name Object Declared Type Bytes Dimen Elements Attributes References ABS Func 603 scalar PRIV 603,612,753,759 ASSOCIATED Func 494 scalar PRIV 494 B Local 668 RECORD 152 2 1 PTR 668,684,685,686,687,694,707,833,83 5,836,853,1196,1212,1213,1214,1215 ,1222,1235,1361,1363,1364,1381,146 2,1463,1464,1465,1466,1470,1471,15 72,1575,1625,1634,1635,1636,1795,2 037 CLASS_GSU Type 461 576 scalar PRIV 227,251,461,989,1548 COUNT Func 612 scalar PRIV 612,759 D180 Param 603 R(8) 8 scalar 603,747,753,1131,1275,1281,1805,18 65,2047,2108,2281,2336,2510,2565,4 865,4920,4923,4951,4952,5140,5195, 5198,5226,5227 D360 Param 638 R(8) 8 scalar 638,743,745,747,1166,1271,1273,127 5,1801,1803,1805,1861,1863,1865,20 43,2045,2047,2104,2106,2108,2277,2 279,2281,2332,2334,2336,2506,2508, 2510,2561,2563,2565,4635,4726,4921 ,4924,4951,4952,4954,4955,5196,519 9,5226,5227,5229,5230 D90 Param 612 R(8) 8 scalar 612,640,641,759,1140,1168,1169,128 7,4873,4883,5148,5158 DEBUG Dummy 341 L(4) 4 scalar ARG,IN,PRIV 508,509 DXB Local 652 R(8) 8 scalar 652,664,763,854,855,1180,1192,1291 ,1382,1383,1605,1617,1618,1792,203 4 DYB Local 653 R(8) 8 scalar 653,664,765,854,855,1181,1192,1293 ,1382,1383,1605,1617,1618,1792,203 4 EXTCDE Subr 479 176,479,485,491,497,504,521,672,69 2,699,1007,1013,1019,1025,1032,104 Page 17 Source Listing W3GSUC_R4 2014-11-12 21:37 Symbol Table w3gsrumd.f90 Name Object Declared Type Bytes Dimen Elements Attributes References 9,1200,1220,1227,1558,1766,2008,22 47,2476,2692,2834,2975,3109,3282,3 289,3296,3301,3654,3661,3668,3673, 4361,4553 GKIND Local 530 I(4) 4 scalar 530,658,1058,1186,1589,1784,2026,2 265,2494,3320,3692 GSU Local 444 T_GSU 8 scalar 863 I Local 465 I(4) 4 scalar 568,571,572,573,574,708,711,714,71 5,716,717,815 I Local 684 I(4) 4 1 1 PTR 684,687,835,1212,1215,1363,1463,14 64,1635,1831,1832,1833,1834,2074,2 075,2076,2077 IB Local 465 I(4) 4 scalar 682,684,685,686,687,691,694,698,83 1,833,835,836,851,853,854,855 IB1 Local 466 I(4) 4 1 2 771,781,788,790,794,804,808,824,83 1 IB2 Local 466 I(4) 4 1 2 772,782,789,791,796,805,809,826,83 1 IBC Local 466 I(4) 4 1 4 763,764,793,794,796,804,805,821 IC Local 465 I(4) 4 1 4 571,572,573,574,578,579,585,590,59 2,609,616,622,714,715,716,717,721, 722,728,733,735,817,835 ICLO Dummy 341 I(4) 4 scalar ARG,IN,PRIV 473,478,482,488,525,545,555,577,58 2,710,720,725 ICLO Local 525 I(4) 4 scalar 525,658,1053,1186,1587,1781,2023,2 262,2491,3318,3690 ICLO_NONE Param 474 I(4) 4 scalar 217,474,482,546,555,577,720,1002,1 010,1074,1083,1105,1248,1837,2080, 2288,2308,2517,2537,3431,3435,3803 ,3807 ICLO_SMPL Param 474 I(4) 4 scalar 218,474,548,1002,1076,2290,2519 ICLO_TRPL Param 474 I(4) 4 scalar 219,474,488,550,582,710,725,1002,1 016,1078,1110,1238,1253,1841,2084, 2292,2312,2521,2541,3439,3811 IJG Dummy 341 L(4) 4 scalar ARG,IN,PRIV 523,589,732 IJG Local 523 L(4) 4 scalar 523,1051,1585,1779,2021,2260,2489, 2705,2847,3316,3688 INT Func 763 scalar PRIV 763,765 ISTAT Local 467 I(4) 4 scalar 517,518,521,668,669,672,687,688,69 2,694,695,699 ISTEP Local 467 I(4) 4 scalar 678,681,814,834 ISTEP_LOOP Label 678 scalar 845 J Local 465 I(4) 4 scalar 569,571,572,573,574,709,711,714,71 5,716,717,815 J Local 685 I(4) 4 1 1 PTR 685,694,836,1213,1222,1364,1465,14 66,1635,1831,1832,1833,1834,2074,2 075,2076,2077 JB Local 465 I(4) 4 scalar 683,684,685,686,687,691,694,698,83 2,833,835,836,852,853,854,855 JB1 Local 466 I(4) 4 1 2 774,778,783,799,806,810,825,832 JB2 Local 466 I(4) 4 1 2 775,779,784,800,807,811,827,832 JBC Local 466 I(4) 4 1 4 765,774,779,799,800,806,807,822 JC Local 465 I(4) 4 1 4 571,572,573,574,583,584,590,592,60 9,616,622,714,715,716,717,726,727, 733,735,818,836 Page 18 Source Listing W3GSUC_R4 2014-11-12 21:37 Symbol Table w3gsrumd.f90 Name Object Declared Type Bytes Dimen Elements Attributes References K Local 465 I(4) 4 scalar 602,603,752,753,830,831,832 L Local 465 I(4) 4 scalar 575,578,579,583,584,585,590,592,60 1,602,603,718,721,722,726,727,728, 733,735,751,752,753,762,763,764,76 5,792,793,794,796 L360 Local 642 L(4) 4 scalar 642,744,1170,1272,1783,2025,2264,2 493 LBC Local 464 L(4) 4 scalar 597,606,607,740,756,785,816 LCLO Local 556 L(4) 4 scalar 556,558,626,637,658,744,764,1084,1 086,1154,1165,1186,1272,1292,1588, 1782,2024,2263,2492,3319,3691 LDBG Local 464 L(4) 4 scalar 509,511,563,607,614,620,656,814,84 8 LLG Dummy 341 L(4) 4 scalar ARG,IN,PRIV 482,524,555,598,741 LLG Local 524 L(4) 4 scalar 524,1052,1586,1780,2022,2261,2490, 2706,2848,3317,3689 LNPL Local 464 L(4) 4 scalar 566,617,641 LPL Local 464 L(4) 4 scalar 596,612,613,619,739,759,768,816 LSPL Local 464 L(4) 4 scalar 567,623,640 MAX Func 646 scalar PRIV 646,647,649,650,774,796,799,804,80 6 MAXVAL Func 619 scalar PRIV 619,635,636,777,779,800,805,807 MIN Func 764 scalar PRIV 764,765,779,794,800,805,807 MINVAL Func 613 scalar PRIV 613,635,636,773,774,799,804,806 MOD Func 488 scalar PRIV 488,585,602,728,743,752 N Local 465 I(4) 4 scalar 600,603,606,612,626,691,698,750,75 3,756,759 N Local 686 I(4) 4 scalar 686,687,694,707,833,835,836,853,12 14,1215,1222,1235,1361,1363,1364,1 381,1462,1575,1625,1634,1636,1827, 1829,2069,2071 NBX Local 646 I(4) 4 scalar 646,649,652,662,668,682,764,772,78 8,789,793,805,851,1174,1177,1180,1 190,1196,1210,1292,1300,1316,1317, 1321,1333,1379,1460,1573,1604,1614 ,1625,1632,1791,2033 NBY Local 647 I(4) 4 scalar 647,650,653,662,668,683,765,775,77 9,800,807,852,1175,1178,1181,1190, 1196,1211,1293,1303,1307,1328,1335 ,1380,1461,1574,1604,1615,1624,163 1,1791,2033 NCB Dummy 341 I(4) 4 scalar ARG,IN,PRIV 500,501,645,646,647 NCB_DEFAULT Param 462 I(4) 4 scalar 649,650 NNP Dummy 341 I(4) 4 scalar ARG,IN,PRIV 535,536 NNP Local 536 T_NNS 296 scalar PTR,TGT 536,538,1064,1066,1458,1596,3292,3 327,3664,3699 NNP_DEFAULT Param 463 I(4) 4 scalar 538 NS Local 466 I(4) 4 scalar 770,787,803,823,830 NX Dummy 341 I(4) 4 scalar ARG,IN,PRIV 488,526,547,549,551,578,579,585,64 6,649,711,721,722,728 NX Local 526 I(4) 4 scalar 526,1054,1590,1785,2027,2266,2495, 3321,3693 NXC Local 465 I(4) 4 scalar 547,549,551,568,708 NY Dummy 341 I(4) 4 scalar ARG,IN,PRIV 527,547,549,551,583,584,647,650,72 6,727 Page 19 Source Listing W3GSUC_R4 2014-11-12 21:37 Symbol Table w3gsrumd.f90 Name Object Declared Type Bytes Dimen Elements Attributes References NY Local 527 I(4) 4 scalar 527,1055,1590,1785,2027,2266,2495, 3321,3693 NYC Local 465 I(4) 4 scalar 547,549,551,569,709,711 PRESENT Func 500 scalar PRIV 500,508,535,645 PTR Local 461 CLASS_GSU 576 scalar PTR,TGT 517,523,524,525,526,527,528,529,53 0,536,538,556,558,626,635,636,637, 638,640,641,642,646,647,649,650,65 2,653,658,660,662,664,668,682,683, 684,685,686,687,694,707,744,763,76 4,765,772,775,779,788,789,793,800, 805,807,833,835,836,851,852,853,85 4,855,863 PTR Local 863 CLASS_GSU 576 scalar PTR,TGT 863,1391,1456,1458,1460,1461,1462, 1463,1464,1465,1466,1470,1471,1473 ,1474,1555,1567,1763,1779,1780,178 1,1782,1783,1784,1785,1787,1789,17 91,1792,1793,1794,1795,2005,2021,2 022,2023,2024,2025,2026,2027,2029, 2031,2033,2034,2035,2036,2037,2244 ,2260,2261,2262,2263,2264,2265,226 6,2268,2270,2473,2489,2490,2491,24 92,2493,2494,2495,2497,2499,2689,2 705,2706,2831,2847,2848,2972,3106, 3279,3292,3316,3317,3318,3319,3320 ,3321,3323,3325,3327,3651,3664,368 8,3689,3690,3691,3692,3693,3695,36 97,3699 REAL Func 652 scalar PRIV 652,653 T_GSU Type 444 8 scalar 228,444,972,1446,1539,1737,1979,22 21,2450,2667,2809,2954,3088,3246,3 618 W3GSUC_R4 Func 341 RECORD 8 scalar PRIV W3NNSC Func 536 RECORD 296 scalar PTR 198,536,538,1064,1066 X Local 468 R(8) 8 scalar XC Local 468 R(8) 8 1 4 590,592,603,733,735,743,745,747,75 3,763,819 XG Dummy 341 R(4) 4 2 1 ARG,PTR,INOUT 494,528,590,592,635,733,735 PRIV XG4 Local 528 R(4) 4 2 1 PTR 528,1787,2029,2268,2497,3323,3695 XMAX Local 635 R(8) 8 scalar 635,638,652,660,1163,1166,1180,118 8,1603,1794,2036 XMIN Local 635 R(8) 8 scalar 635,638,642,652,660,763,854,855,11 63,1166,1170,1180,1188,1291,1382,1 383,1603,1617,1618,1793,2035 Y Local 468 R(8) 8 scalar YC Local 468 R(8) 8 1 4 590,592,612,613,619,733,735,759,76 5,773,777,820 YG Dummy 341 R(4) 4 2 1 ARG,PTR,INOUT 494,529,590,592,636,733,735 PRIV YG4 Local 529 R(4) 4 2 1 PTR 529,1787,2029,2268,2497,3323,3695 YMAX Local 636 R(8) 8 scalar 636,641,653,660,1164,1169,1181,118 8,1603,1794,2036 YMIN Local 636 R(8) 8 scalar 636,640,653,660,765,854,855,1164,1 168,1181,1188,1293,1382,1383,1603, 1617,1618,1793,2035 Page 20 Source Listing W3GSUC_R4 2014-11-12 21:37 Symbol Table w3gsrumd.f90 Name Object Declared Type Bytes Dimen Elements Attributes References ZERO Param 613 R(8) 8 scalar 613,619,638,642,745,773,777,1141,1 147,1166,1170,1273,1301,1305,1803, 1863,2045,2106,2279,2334,2508,2563 ,3329,3352,3384,3389,3496,3701,372 4,3756,3761,3868,4282,4284,4288,43 08,4474,4476,4480,4500,4883,4950,4 954,4955,5158,5225,5229,5230 Page 21 Source Listing W3GSUC_R4 2014-11-12 21:37 w3gsrumd.f90 868 !/ ------------------------------------------------------------------- / 869 FUNCTION W3GSUC_R8(IJG, LLG, ICLO, NX, NY, XG, YG, NCB, NNP, DEBUG) & 870 RESULT(GSU) 871 !/ 872 !/ +-----------------------------------+ 873 !/ | WAVEWATCH III NOAA/NCEP | 874 !/ | T. J. Campbell, NRL | 875 !/ | FORTRAN 90 | 876 !/ | Last update : 06-Dec-2010 | 877 !/ +-----------------------------------+ 878 !/ 879 !/ 30-Oct-2009 : Origination. ( version 3.14 ) 880 !/ 12-Nov-2010 : Change to number of search buckets based on 881 !/ dimensions of input grid. ( version 3.14 ) 882 !/ 01-Dec-2010 : Restore NCB optional input. Assign cells to buckets 883 !/ based on overlap. The nearest-neighbor bucket search 884 !/ is removed (no longer needed). Add support for 885 !/ tripole grids (JCLO). ( version 3.14 ) 886 !/ 06-Dec-2010 : Remove restriction on longitude range. Change 887 !/ ICLO to integer and remove JCLO. Implement r4 and r8 888 !/ input grid versions. ( version 3.14 ) 889 !/ 890 ! 1. Purpose : 891 ! 892 ! Create grid-search-utility (GSU) object for a logically rectangular 893 ! grid defined by the input coordinates. 894 ! Double precision input grid. 895 ! 896 ! 2. Method : 897 ! 898 ! 3. Parameters : 899 ! 900 ! Return parameter 901 ! ---------------------------------------------------------------- 902 ! GSU Type O Created grid-search-utility object. 903 ! ---------------------------------------------------------------- 904 ! 905 ! Parameter list 906 ! ---------------------------------------------------------------- 907 ! IJG Log. I Logical flag indicating ordering of input 908 ! coord. arrays: T = (NX,NY) and F = (NY,NX). 909 ! LLG Log. I Logical flag indicating the coordinate system: 910 ! T = spherical lat/lon (degrees) and F = Cartesian. 911 ! ICLO Int. I Parameter indicating type of index space closure 912 ! NX, NY Int. I Dimensions of input grid. 913 ! XG R.A. I Pointer to array of x-coordinates of input grid. 914 ! YG R.A. I Pointer to array of y-coordinates of input grid. 915 ! NCB Int. I Optional (approximate) number of cells (in each 916 ! direction) per search bucket. (default is NCB_DEFAULT) 917 ! NCB >= 1 is required. NCB = 1 gives most efficient 918 ! searching, but uses more memory. Increasing NCB leads 919 ! to fewer buckets (less memory) but slower searching. 920 ! NNP Int. I Optional maximum number of nearest-neighbor grid 921 ! point search levels. (default is NNP_DEFAULT) 922 ! DEBUG Log. I Optional logical flag to turn on debug mode. 923 ! Default is FALSE. 924 ! Page 22 Source Listing W3GSUC_R8 2014-11-12 21:37 w3gsrumd.f90 925 ! Internal parameters 926 ! ---------------------------------------------------------------- 927 ! NCB_DEFAULT Int. Default number of grid cells (in each direction) 928 ! per search bucket. 929 ! NNP_DEFAULT Int. Default maximum number of nearest-neighbor grid 930 ! point search levels. 931 ! ---------------------------------------------------------------- 932 ! 933 ! 4. Subroutines used : 934 ! 935 ! See module documentation. 936 ! 937 ! 5. Called by : 938 ! 939 ! 6. Error messages : 940 ! 941 ! - Check on correct coordinate system with global grid. 942 ! - Check on association of input grid coordinate array pointers. 943 ! 944 ! 7. Remarks : 945 ! 946 ! - LCLO is calculated internally. 947 ! - ICLO != ICLO_NONE => LCLO = T. 948 ! - Periodic Cartesian grids are not allowed. 949 ! 950 ! 8. Structure : 951 ! 952 ! ----------------------------------------------------------------- 953 ! 1. Test input 954 ! 2. Allocate object and set grid related data and pointers 955 ! 3. Create nearest-neighbor point search object 956 ! 4. Construct bucket search "object" 957 ! 5. Set return parameter 958 ! ----------------------------------------------------------------- 959 ! 960 ! 9. Switches : 961 ! 962 ! !/S Enable subroutine tracing. 963 ! !/T8 Enables debugging flag. 964 ! 965 ! 10. Source code : 966 ! 967 !/ ------------------------------------------------------------------- / 968 !/ 969 !/ ------------------------------------------------------------------- / 970 !/ Return parameter 971 !/ 972 TYPE(T_GSU) :: GSU 973 !/ 974 !/ ------------------------------------------------------------------- / 975 !/ Parameter list 976 !/ 977 LOGICAL, INTENT(IN) :: IJG 978 LOGICAL, INTENT(IN) :: LLG 979 INTEGER, INTENT(IN) :: ICLO 980 INTEGER, INTENT(IN) :: NX, NY 981 REAL(8), POINTER :: XG(:,:), YG(:,:) Page 23 Source Listing W3GSUC_R8 2014-11-12 21:37 w3gsrumd.f90 982 INTEGER, INTENT(IN), OPTIONAL :: NCB 983 INTEGER, INTENT(IN), OPTIONAL :: NNP 984 LOGICAL, INTENT(IN), OPTIONAL :: DEBUG 985 !/ 986 !/ ------------------------------------------------------------------- / 987 !/ Local parameters 988 !/ 989 TYPE(CLASS_GSU), POINTER :: PTR 990 INTEGER, PARAMETER :: NCB_DEFAULT = 1 991 INTEGER, PARAMETER :: NNP_DEFAULT = 2 992 LOGICAL :: LDBG, LBC, LPL, LNPL, LSPL 993 INTEGER :: I, J, K, L, N, IC(4), JC(4), IB, JB, NXC, NYC 994 INTEGER :: NS, IB1(2), IB2(2), JB1(2), JB2(2), IBC(4), JBC(4) 995 INTEGER :: ISTEP, ISTAT 996 REAL(8) :: X, Y, XC(4), YC(4) 997 !/ 998 ! -------------------------------------------------------------------- / 999 ! 1. Test input 1000 ! 1001 SELECT CASE ( ICLO ) 1002 CASE ( ICLO_NONE, ICLO_SMPL, ICLO_TRPL ) 1003 CONTINUE 1004 CASE DEFAULT 1005 WRITE(*,'(/1A,1A,1I2/)') 'W3GSUC_R8 ERROR -- ', & 1006 'unsupported ICLO: ',ICLO 1007 CALL EXTCDE (1) 1008 END SELECT 1009 1010 IF ( ICLO.NE.ICLO_NONE .AND. .NOT.LLG ) THEN 1011 WRITE(*,'(/1A,1A/)') 'W3GSUC_R8 ERROR -- ', & 1012 'index space closure with cartesian grids is not supported' 1013 CALL EXTCDE (1) 1014 END IF 1015 1016 IF ( ICLO.EQ.ICLO_TRPL .AND. MOD(NX,2).NE.0 ) THEN 1017 WRITE(*,'(/1A,1A/)') 'W3GSUC_R8 ERROR -- ', & 1018 'tripole grid closure requires NX even' 1019 CALL EXTCDE (1) 1020 END IF 1021 1022 IF ( .NOT.ASSOCIATED(XG) .OR. .NOT.ASSOCIATED(YG) ) THEN 1023 WRITE(*,'(/1A,1A/)') 'W3GSUC_R8 ERROR -- ', & 1024 'input grid coordinate array pointers are not associated' 1025 CALL EXTCDE (1) 1026 END IF 1027 1028 IF ( PRESENT(NCB) ) THEN 1029 IF ( NCB .LE. 0 ) THEN 1030 WRITE(*,'(/1A,1A/)') 'W3GSUC_R8 ERROR -- ', & 1031 'NCB must be greater than zero' 1032 CALL EXTCDE (1) 1033 END IF 1034 END IF 1035 ! 1036 IF ( PRESENT(DEBUG) ) THEN 1037 LDBG = DEBUG 1038 ELSE Page 24 Source Listing W3GSUC_R8 2014-11-12 21:37 w3gsrumd.f90 1039 LDBG = .FALSE. 1040 END IF 1041 ! 1042 ! -------------------------------------------------------------------- / 1043 ! 2. Allocate object and set grid related data and pointers 1044 ! 1045 ALLOCATE(PTR, STAT=ISTAT) 1046 IF ( ISTAT .NE. 0 ) THEN 1047 WRITE(*,'(/1A,1A/)') 'W3GSUC_R8 ERROR -- ', & 1048 'gsu object allocation failed' 1049 CALL EXTCDE (ISTAT) 1050 END IF 1051 PTR%IJG = IJG 1052 PTR%LLG = LLG 1053 PTR%ICLO = ICLO 1054 PTR%NX = NX 1055 PTR%NY = NY 1056 PTR%XG8 => XG 1057 PTR%YG8 => YG 1058 PTR%GKIND = 8 1059 ! 1060 ! -------------------------------------------------------------------- / 1061 ! 3. Create nearest-neighbor point search object 1062 ! 1063 IF ( PRESENT(NNP) ) THEN 1064 PTR%NNP => W3NNSC(NNP) 1065 ELSE 1066 PTR%NNP => W3NNSC(NNP_DEFAULT) 1067 END IF 1068 ! 1069 ! -------------------------------------------------------------------- / 1070 ! 4. Construct bucket search "object" 1071 ! 1072 !-----number of cells 1073 SELECT CASE ( ICLO ) 1074 CASE ( ICLO_NONE ) 1075 NXC = NX-1; NYC = NY-1; 1076 CASE ( ICLO_SMPL ) 1077 NXC = NX; NYC = NY-1; 1078 CASE ( ICLO_TRPL ) 1079 NXC = NX; NYC = NY; 1080 END SELECT 1081 ! 1082 !-----initialize longitudinal periodicity flag (LCLO) 1083 IF ( LLG .AND. ICLO.NE.ICLO_NONE ) THEN 1084 PTR%LCLO = .TRUE. 1085 ELSE 1086 PTR%LCLO = .FALSE. 1087 END IF 1088 ! 1089 !-----check existence of longitudinal branch cut 1090 !-----check if source grid includes poles 1091 IF ( LDBG ) THEN 1092 WRITE(*,'(/A)') 'W3GSUC_R8 - check source grid' 1093 END IF 1094 LNPL = .FALSE. 1095 LSPL = .FALSE. Page 25 Source Listing W3GSUC_R8 2014-11-12 21:37 w3gsrumd.f90 1096 DO I=1,NXC 1097 DO J=1,NYC 1098 !-------------create list of cell vertices 1099 IC(1) = I ; JC(1) = J ; 1100 IC(2) = I+1; JC(2) = J ; 1101 IC(3) = I+1; JC(3) = J+1; 1102 IC(4) = I ; JC(4) = J+1; 1103 DO L=1,4 1104 !-----------------i-closure 1105 IF ( ICLO.NE.ICLO_NONE ) THEN 1106 IF ( IC(L) .LT. 1 ) IC(L) = IC(L) + NX 1107 IF ( IC(L) .GT. NX ) IC(L) = IC(L) - NX 1108 END IF 1109 !-----------------j-closure 1110 IF ( ICLO.EQ.ICLO_TRPL ) THEN 1111 IF ( JC(L) .GT. NY ) THEN 1112 JC(L) = NY 1113 IC(L) = MOD(NX-IC(L)+1,NX) + 1 1114 END IF 1115 END IF 1116 !-----------------copy cell vertex coordinates into local variables 1117 IF ( IJG ) THEN 1118 XC(L) = XG(IC(L),JC(L)); YC(L) = YG(IC(L),JC(L)); 1119 ELSE 1120 XC(L) = XG(JC(L),IC(L)); YC(L) = YG(JC(L),IC(L)); 1121 END IF 1122 END DO !L 1123 !-------------check if cell includes a pole or branch cut 1124 LPL = .FALSE. 1125 LBC = .FALSE. 1126 IF ( LLG ) THEN 1127 !-----------------count longitudinal branch cut crossings 1128 N = 0 1129 DO L=1,4 1130 K = MOD(L,4)+1 1131 IF ( ABS(XC(K)-XC(L)) .GT. D180 ) N = N + 1 1132 END DO 1133 !-----------------multiple longitudinal branch cut crossing => cell includes branch cut 1134 LBC = N.GT.1 1135 IF ( LBC .AND. LDBG ) & 1136 WRITE(*,'(A,8I6)') & 1137 'W3GSUC_R8 -- cell includes branch cut:',IC(:),JC(:) 1138 !-----------------single longitudinal branch cut crossing 1139 ! or single vertex at 90 degrees => cell includes pole 1140 LPL = N.EQ.1 .OR. COUNT(ABS(YC).EQ.D90).EQ.1 1141 IF ( LPL.AND.MINVAL(YC).GT.ZERO ) THEN 1142 IF ( LDBG ) & 1143 WRITE(*,'(A,8I6)') & 1144 'W3GSUC_R8 -- cell includes N-pole:',IC(:),JC(:) 1145 LNPL = .TRUE. 1146 END IF 1147 IF ( LPL.AND.MAXVAL(YC).LT.ZERO ) THEN 1148 IF ( LDBG ) & 1149 WRITE(*,'(A,8I6)') & 1150 'W3GSUC_R8 -- cell includes S-pole:',IC(:),JC(:) 1151 LSPL = .TRUE. 1152 END IF Page 26 Source Listing W3GSUC_R8 2014-11-12 21:37 w3gsrumd.f90 1153 !-----------------longitudinal branch cut crossing => longitudinal closure 1154 IF ( N.GT.0 ) PTR%LCLO = .TRUE. 1155 END IF !LLG 1156 END DO !J 1157 END DO !I 1158 ! 1159 !-----compute domain for search buckets 1160 ! if longitudinal periodicity, then force domain in x to [0:360] 1161 ! if grid includes north pole, then set ymax = 90 degrees 1162 ! if grid includes south pole, then set ymin = -90 degrees 1163 PTR%XMIN = MINVAL(XG); PTR%XMAX = MAXVAL(XG); 1164 PTR%YMIN = MINVAL(YG); PTR%YMAX = MAXVAL(YG); 1165 IF ( PTR%LCLO ) THEN 1166 PTR%XMIN = ZERO; PTR%XMAX = D360; 1167 END IF 1168 IF ( LSPL ) PTR%YMIN = -D90 1169 IF ( LNPL ) PTR%YMAX = D90 1170 PTR%L360 = PTR%XMIN.GE.ZERO 1171 ! 1172 !-----compute number of search buckets and bucket size 1173 IF ( PRESENT(NCB) ) THEN 1174 PTR%NBX = MAX(1,NX/NCB) 1175 PTR%NBY = MAX(1,NY/NCB) 1176 ELSE 1177 PTR%NBX = MAX(1,NX/NCB_DEFAULT) 1178 PTR%NBY = MAX(1,NY/NCB_DEFAULT) 1179 END IF 1180 PTR%DXB = (PTR%XMAX-PTR%XMIN)/REAL(PTR%NBX) 1181 PTR%DYB = (PTR%YMAX-PTR%YMIN)/REAL(PTR%NBY) 1182 ! 1183 !-----print debug info 1184 IF ( LDBG ) THEN 1185 WRITE(*,'(/A,1I2,1L2,1I2)') 'W3GSUC_R8 - ICLO,LCLO,GKIND: ', & 1186 PTR%ICLO,PTR%LCLO,PTR%GKIND 1187 WRITE(*,'(A,4E14.6)') 'W3GSUC_R8 - grid search domain:', & 1188 PTR%XMIN,PTR%YMIN,PTR%XMAX,PTR%YMAX 1189 WRITE(*,'(A,2I6)') 'W3GSUC_R8 - number of search buckets:', & 1190 PTR%NBX,PTR%NBY 1191 WRITE(*,'(A,2E14.6)') 'W3GSUC_R8 - search bucket size:', & 1192 PTR%DXB,PTR%DYB 1193 END IF 1194 ! 1195 !-----allocate array of search buckets 1196 ALLOCATE(PTR%B(PTR%NBY,PTR%NBX),STAT=ISTAT) 1197 IF ( ISTAT .NE. 0 ) THEN 1198 WRITE(*,'(/1A,1A/)') 'W3GSUC_R8 ERROR -- ', & 1199 'search bucket array allocation failed' 1200 CALL EXTCDE (ISTAT) 1201 END IF 1202 ! 1203 !-----BEGIN ISTEP_LOOP 1204 ! first step: compute number of cells in each bucket 1205 ! second step: allocate buckets and assign cells to buckets 1206 ISTEP_LOOP: DO ISTEP=1,2 1207 ! 1208 !-----allocate search bucket cell lists 1209 IF ( ISTEP .EQ. 2 ) THEN Page 27 Source Listing W3GSUC_R8 2014-11-12 21:37 w3gsrumd.f90 1210 DO IB=1,PTR%NBX 1211 DO JB=1,PTR%NBY 1212 NULLIFY(PTR%B(JB,IB)%I) 1213 NULLIFY(PTR%B(JB,IB)%J) 1214 IF ( PTR%B(JB,IB)%N .GT. 0 ) THEN 1215 ALLOCATE(PTR%B(JB,IB)%I(PTR%B(JB,IB)%N),STAT=ISTAT) 1216 IF ( ISTAT .NE. 0 ) THEN 1217 WRITE(*,'(/1A,2A,3I6/)') 'W3GSUC_R8 ERROR -- ', & 1218 'search bucket cell-i list allocation failed -- ', & 1219 'bucket: ',IB,JB,N 1220 CALL EXTCDE (ISTAT) 1221 END IF 1222 ALLOCATE(PTR%B(JB,IB)%J(PTR%B(JB,IB)%N),STAT=ISTAT) 1223 IF ( ISTAT .NE. 0 ) THEN 1224 WRITE(*,'(/1A,2A,3I6/)') 'W3GSUC_R8 ERROR -- ', & 1225 'search bucket cell-j list allocation failed -- ', & 1226 'bucket: ',IB,JB,N 1227 CALL EXTCDE (ISTAT) 1228 END IF 1229 END IF 1230 END DO 1231 END DO 1232 END IF !ISTEP.EQ.2 1233 ! 1234 !-----build search bucket cell lists 1235 PTR%B(:,:)%N = 0 1236 DO I=1,NXC 1237 DO J=1,NYC 1238 IF ( ICLO.EQ.ICLO_TRPL ) THEN 1239 IF ( J.EQ.NYC .AND. I.GT.NX/2+1 ) CYCLE 1240 ENDIF 1241 !-------------create list of cell vertices 1242 IC(1) = I ; JC(1) = J ; 1243 IC(2) = I+1; JC(2) = J ; 1244 IC(3) = I+1; JC(3) = J+1; 1245 IC(4) = I ; JC(4) = J+1; 1246 DO L=1,4 1247 !-----------------i-closure 1248 IF ( ICLO.NE.ICLO_NONE ) THEN 1249 IF ( IC(L) .LT. 1 ) IC(L) = IC(L) + NX 1250 IF ( IC(L) .GT. NX ) IC(L) = IC(L) - NX 1251 END IF 1252 !-----------------j-closure 1253 IF ( ICLO.EQ.ICLO_TRPL ) THEN 1254 IF ( JC(L) .GT. NY ) THEN 1255 JC(L) = NY 1256 IC(L) = MOD(NX-IC(L)+1,NX) + 1 1257 END IF 1258 END IF 1259 !-----------------copy cell vertex coordinates into local variables 1260 IF ( IJG ) THEN 1261 XC(L) = XG(IC(L),JC(L)); YC(L) = YG(IC(L),JC(L)); 1262 ELSE 1263 XC(L) = XG(JC(L),IC(L)); YC(L) = YG(JC(L),IC(L)); 1264 END IF 1265 END DO !L 1266 !-------------check if cell includes a pole or branch cut Page 28 Source Listing W3GSUC_R8 2014-11-12 21:37 w3gsrumd.f90 1267 LPL = .FALSE. 1268 LBC = .FALSE. 1269 IF ( LLG ) THEN 1270 !-----------------shift longitudes to appropriate range 1271 XC = MOD(XC,D360) 1272 IF ( PTR%LCLO .OR. PTR%L360 ) THEN 1273 WHERE ( XC.LT.ZERO ) XC = XC + D360 1274 ELSE 1275 WHERE ( XC.GT.D180 ) XC = XC - D360 1276 END IF 1277 !-----------------count longitudinal branch cut crossings 1278 N = 0 1279 DO L=1,4 1280 K = MOD(L,4)+1 1281 IF ( ABS(XC(K)-XC(L)) .GT. D180 ) N = N + 1 1282 END DO 1283 !-----------------multiple longitudinal branch cut crossing => cell includes branch cut 1284 LBC = N.GT.1 1285 !-----------------single longitudinal branch cut crossing 1286 ! or single vertex at 90 degrees => cell includes pole 1287 LPL = N.EQ.1 .OR. COUNT(ABS(YC).EQ.D90).EQ.1 1288 END IF !LLG 1289 !-------------set bucket id for each cell vertex 1290 DO L=1,4 1291 IBC(L) = INT((XC(L)-PTR%XMIN)/PTR%DXB)+1 1292 IF ( .NOT.PTR%LCLO ) IBC(L) = MIN(IBC(L),PTR%NBX) 1293 JBC(L) = MIN(INT((YC(L)-PTR%YMIN)/PTR%DYB)+1,PTR%NBY) 1294 END DO !L 1295 !-------------set bucket overlap bounds 1296 IF ( LPL ) THEN 1297 !---------------cell includes pole: overlap includes full longitudinal range 1298 NS = 1 1299 IB1(1) = 1 1300 IB2(1) = PTR%NBX 1301 IF ( MINVAL(YC).GT.ZERO ) THEN 1302 JB1(1) = MAX(1,MINVAL(JBC)) 1303 JB2(1) = PTR%NBY 1304 END IF 1305 IF ( MAXVAL(YC).LT.ZERO ) THEN 1306 JB1(1) = 1 1307 JB2(1) = MIN(PTR%NBY,MAXVAL(JBC)) 1308 END IF 1309 IB1(2) = 0 1310 IB2(2) = 0 1311 JB1(2) = 0 1312 JB2(2) = 0 1313 ELSE IF ( LBC ) THEN 1314 !---------------cell includes branch cut: split overlap into two sets 1315 NS = 2 1316 IB1(1) = PTR%NBX 1317 IB2(1) = PTR%NBX 1318 IB1(2) = 1 1319 IB2(2) = 1 1320 DO L=1,4 1321 IF ( IBC(L) .GT. PTR%NBX/2 ) THEN 1322 IB1(1) = MIN(IB1(1),IBC(L)) 1323 ELSE Page 29 Source Listing W3GSUC_R8 2014-11-12 21:37 w3gsrumd.f90 1324 IB2(2) = MAX(IB2(2),IBC(L)) 1325 END IF 1326 END DO !L 1327 JB1(:) = MAX(1,MINVAL(JBC)) 1328 JB2(:) = MIN(PTR%NBY,MAXVAL(JBC)) 1329 ELSE 1330 !---------------default: overlap computed from min/max 1331 NS = 1 1332 IB1(1) = MAX(1,MINVAL(IBC)) 1333 IB2(1) = MIN(PTR%NBX,MAXVAL(IBC)) 1334 JB1(1) = MAX(1,MINVAL(JBC)) 1335 JB2(1) = MIN(PTR%NBY,MAXVAL(JBC)) 1336 IB1(2) = 0 1337 IB2(2) = 0 1338 JB1(2) = 0 1339 JB2(2) = 0 1340 END IF 1341 !-------------debug output 1342 IF ( LDBG .AND. ISTEP.EQ.1 ) THEN 1343 WRITE(*,'(/A,2I6)') 'W3GSUC_R8 -- BUCKET SORT:',I,J 1344 WRITE(*,'(A,2L6,1I6)') 'W3GSUC_R8 -- LBC,LPL:',LBC,LPL 1345 WRITE(*,'(A,4I6)') 'W3GSUC_R8 -- IC:',IC(:) 1346 WRITE(*,'(A,4I6)') 'W3GSUC_R8 -- JC:',JC(:) 1347 WRITE(*,'(A,4E14.6)') 'W3GSUC_R8 -- XC:',XC(:) 1348 WRITE(*,'(A,4E14.6)') 'W3GSUC_R8 -- YC:',YC(:) 1349 WRITE(*,'(A,4I6)') 'W3GSUC_R8 -- IBC:',IBC(:) 1350 WRITE(*,'(A,4I6)') 'W3GSUC_R8 -- JBC:',JBC(:) 1351 WRITE(*,'(A,1I6)') 'W3GSUC_R8 -- NS:',NS 1352 WRITE(*,'(A,4I6)') 'W3GSUC_R8 -- IB1:',IB1(:) 1353 WRITE(*,'(A,4I6)') 'W3GSUC_R8 -- JB1:',JB1(:) 1354 WRITE(*,'(A,4I6)') 'W3GSUC_R8 -- IB2:',IB2(:) 1355 WRITE(*,'(A,4I6)') 'W3GSUC_R8 -- JB2:',JB2(:) 1356 END IF 1357 !-------------assign cell to buckets based on overlap 1358 DO K=1,NS 1359 DO IB=IB1(K),IB2(K) 1360 DO JB=JB1(K),JB2(K) 1361 PTR%B(JB,IB)%N = PTR%B(JB,IB)%N + 1 1362 IF ( ISTEP .EQ. 2 ) THEN 1363 PTR%B(JB,IB)%I(PTR%B(JB,IB)%N) = IC(1) 1364 PTR%B(JB,IB)%J(PTR%B(JB,IB)%N) = JC(1) 1365 END IF 1366 END DO !JB 1367 END DO !IB 1368 END DO !K 1369 END DO !J 1370 END DO !I 1371 ! 1372 !-----END ISTEP_LOOP 1373 END DO ISTEP_LOOP 1374 ! 1375 !-----print debug info 1376 IF ( LDBG ) THEN 1377 WRITE(*,'(/A,3I6,4E14.6)') 'W3GSUC_R8 - search bucket list:' 1378 WRITE(*,'(3A6,4A14)') 'I','J','N','X1','Y1','X2','Y2' 1379 DO IB=1,PTR%NBX 1380 DO JB=1,PTR%NBY Page 30 Source Listing W3GSUC_R8 2014-11-12 21:37 w3gsrumd.f90 1381 WRITE(*,'(3I6,4E14.6)') IB,JB,PTR%B(JB,IB)%N, & 1382 PTR%XMIN+(IB-1)*PTR%DXB,PTR%YMIN+(JB-1)*PTR%DYB, & 1383 PTR%XMIN+(IB-0)*PTR%DXB,PTR%YMIN+(JB-0)*PTR%DYB 1384 END DO 1385 END DO 1386 END IF 1387 ! 1388 ! -------------------------------------------------------------------- / 1389 ! 5. Set return parameter 1390 ! 1391 GSU%PTR => PTR 1392 !/ 1393 !/ End of W3GSUC_R8 -------------------------------------------------- / 1394 !/ 1395 END FUNCTION W3GSUC_R8 ENTRY POINTS Name w3gsrumd_mp_w3gsuc_r8_ SYMBOL CROSS REFERENCE Name Object Declared Type Bytes Dimen Elements Attributes References ABS Func 1131 scalar PRIV 1131,1140,1281,1287 ASSOCIATED Func 1022 scalar PRIV 1022 COUNT Func 1140 scalar PRIV 1140,1287 DEBUG Dummy 869 L(4) 4 scalar ARG,IN,PRIV 1036,1037 GSU Local 972 T_GSU 8 scalar 1391 I Local 993 I(4) 4 scalar 1096,1099,1100,1101,1102,1236,1239 ,1242,1243,1244,1245,1343 IB Local 993 I(4) 4 scalar 1210,1212,1213,1214,1215,1219,1222 ,1226,1359,1361,1363,1364,1379,138 1,1382,1383 IB1 Local 994 I(4) 4 1 2 1299,1309,1316,1318,1322,1332,1336 ,1352,1359 IB2 Local 994 I(4) 4 1 2 1300,1310,1317,1319,1324,1333,1337 ,1354,1359 IBC Local 994 I(4) 4 1 4 1291,1292,1321,1322,1324,1332,1333 ,1349 IC Local 993 I(4) 4 1 4 1099,1100,1101,1102,1106,1107,1113 ,1118,1120,1137,1144,1150,1242,124 3,1244,1245,1249,1250,1256,1261,12 63,1345,1363 ICLO Dummy 869 I(4) 4 scalar ARG,IN,PRIV 1001,1006,1010,1016,1053,1073,1083 ,1105,1110,1238,1248,1253 IJG Dummy 869 L(4) 4 scalar ARG,IN,PRIV 1051,1117,1260 INT Func 1291 scalar PRIV 1291,1293 ISTAT Local 995 I(4) 4 scalar 1045,1046,1049,1196,1197,1200,1215 ,1216,1220,1222,1223,1227 ISTEP Local 995 I(4) 4 scalar 1206,1209,1342,1362 ISTEP_LOOP Label 1206 scalar 1373 J Local 993 I(4) 4 scalar 1097,1099,1100,1101,1102,1237,1239 Page 31 Source Listing W3GSUC_R8 2014-11-12 21:37 Symbol Table w3gsrumd.f90 Name Object Declared Type Bytes Dimen Elements Attributes References ,1242,1243,1244,1245,1343 JB Local 993 I(4) 4 scalar 1211,1212,1213,1214,1215,1219,1222 ,1226,1360,1361,1363,1364,1380,138 1,1382,1383 JB1 Local 994 I(4) 4 1 2 1302,1306,1311,1327,1334,1338,1353 ,1360 JB2 Local 994 I(4) 4 1 2 1303,1307,1312,1328,1335,1339,1355 ,1360 JBC Local 994 I(4) 4 1 4 1293,1302,1307,1327,1328,1334,1335 ,1350 JC Local 993 I(4) 4 1 4 1099,1100,1101,1102,1111,1112,1118 ,1120,1137,1144,1150,1242,1243,124 4,1245,1254,1255,1261,1263,1346,13 64 K Local 993 I(4) 4 scalar 1130,1131,1280,1281,1358,1359,1360 L Local 993 I(4) 4 scalar 1103,1106,1107,1111,1112,1113,1118 ,1120,1129,1130,1131,1246,1249,125 0,1254,1255,1256,1261,1263,1279,12 80,1281,1290,1291,1292,1293,1320,1 321,1322,1324 LBC Local 992 L(4) 4 scalar 1125,1134,1135,1268,1284,1313,1344 LDBG Local 992 L(4) 4 scalar 1037,1039,1091,1135,1142,1148,1184 ,1342,1376 LLG Dummy 869 L(4) 4 scalar ARG,IN,PRIV 1010,1052,1083,1126,1269 LNPL Local 992 L(4) 4 scalar 1094,1145,1169 LPL Local 992 L(4) 4 scalar 1124,1140,1141,1147,1267,1287,1296 ,1344 LSPL Local 992 L(4) 4 scalar 1095,1151,1168 MAX Func 1174 scalar PRIV 1174,1175,1177,1178,1302,1324,1327 ,1332,1334 MAXVAL Func 1147 scalar PRIV 1147,1163,1164,1305,1307,1328,1333 ,1335 MIN Func 1292 scalar PRIV 1292,1293,1307,1322,1328,1333,1335 MINVAL Func 1141 scalar PRIV 1141,1163,1164,1301,1302,1327,1332 ,1334 MOD Func 1016 scalar PRIV 1016,1113,1130,1256,1271,1280 N Local 993 I(4) 4 scalar 1128,1131,1134,1140,1154,1219,1226 ,1278,1281,1284,1287 NCB Dummy 869 I(4) 4 scalar ARG,IN,PRIV 1028,1029,1173,1174,1175 NCB_DEFAULT Param 990 I(4) 4 scalar 1177,1178 NNP Dummy 869 I(4) 4 scalar ARG,IN,PRIV 1063,1064 NNP_DEFAULT Param 991 I(4) 4 scalar 1066 NS Local 994 I(4) 4 scalar 1298,1315,1331,1351,1358 NX Dummy 869 I(4) 4 scalar ARG,IN,PRIV 1016,1054,1075,1077,1079,1106,1107 ,1113,1174,1177,1239,1249,1250,125 6 NXC Local 993 I(4) 4 scalar 1075,1077,1079,1096,1236 NY Dummy 869 I(4) 4 scalar ARG,IN,PRIV 1055,1075,1077,1079,1111,1112,1175 ,1178,1254,1255 NYC Local 993 I(4) 4 scalar 1075,1077,1079,1097,1237,1239 PRESENT Func 1028 scalar PRIV 1028,1036,1063,1173 PTR Local 989 CLASS_GSU 576 scalar PTR,TGT 1045,1051,1052,1053,1054,1055,1056 ,1057,1058,1064,1066,1084,1086,115 4,1163,1164,1165,1166,1168,1169,11 70,1174,1175,1177,1178,1180,1181,1 Page 32 Source Listing W3GSUC_R8 2014-11-12 21:37 Symbol Table w3gsrumd.f90 Name Object Declared Type Bytes Dimen Elements Attributes References 186,1188,1190,1192,1196,1210,1211, 1212,1213,1214,1215,1222,1235,1272 ,1291,1292,1293,1300,1303,1307,131 6,1317,1321,1328,1333,1335,1361,13 63,1364,1379,1380,1381,1382,1383,1 391 REAL Func 1180 scalar PRIV 1180,1181 W3GSUC_R8 Func 869 RECORD 8 scalar PRIV X Local 996 R(8) 8 scalar XC Local 996 R(8) 8 1 4 1118,1120,1131,1261,1263,1271,1273 ,1275,1281,1291,1347 XG Dummy 869 R(8) 8 2 1 ARG,PTR,INOUT 1022,1056,1118,1120,1163,1261,1263 PRIV XG8 Local 1056 R(8) 8 2 1 PTR 1056,1789,2031,2270,2499,3325,3697 Y Local 996 R(8) 8 scalar YC Local 996 R(8) 8 1 4 1118,1120,1140,1141,1147,1261,1263 ,1287,1293,1301,1305,1348 YG Dummy 869 R(8) 8 2 1 ARG,PTR,INOUT 1022,1057,1118,1120,1164,1261,1263 PRIV YG8 Local 1057 R(8) 8 2 1 PTR 1057,1789,2031,2270,2499,3325,3697 Page 33 Source Listing W3GSUC_R8 2014-11-12 21:37 w3gsrumd.f90 1396 !/ ------------------------------------------------------------------- / 1397 SUBROUTINE W3GSUD(GSU) 1398 !/ 1399 !/ +-----------------------------------+ 1400 !/ | WAVEWATCH III NOAA/NCEP | 1401 !/ | T. J. Campbell, NRL | 1402 !/ | FORTRAN 90 | 1403 !/ | Last update : 30-Oct-2009 | 1404 !/ +-----------------------------------+ 1405 !/ 1406 !/ 30-Oct-2009 : Origination. ( version 3.14 ) 1407 !/ 1408 ! 1. Purpose : 1409 ! 1410 ! Destroy grid search utility (GSU) object. 1411 ! 1412 ! 2. Method : 1413 ! 1414 ! 3. Parameters : 1415 ! 1416 ! Parameter list 1417 ! ---------------------------------------------------------------- 1418 ! GSU Type I Grid-search-utility object. 1419 ! ---------------------------------------------------------------- 1420 ! 1421 ! 4. Subroutines used : 1422 ! 1423 ! See module documentation. 1424 ! 1425 ! 5. Called by : 1426 ! 1427 ! 6. Error messages : 1428 ! 1429 ! - Check on previous creation of grid-search-utility object. 1430 ! 1431 ! 7. Remarks : 1432 ! 1433 ! 8. Structure : 1434 ! 1435 ! 9. Switches : 1436 ! 1437 ! !/S Enable subroutine tracing. 1438 ! 1439 ! 10. Source code : 1440 ! 1441 !/ ------------------------------------------------------------------- / 1442 !/ 1443 !/ ------------------------------------------------------------------- / 1444 !/ Parameter list 1445 !/ 1446 TYPE(T_GSU), INTENT(INOUT) :: GSU 1447 !/ 1448 !/ ------------------------------------------------------------------- / 1449 !/ Local parameters 1450 !/ 1451 INTEGER :: IB, JB 1452 !/ Page 34 Source Listing W3GSUD 2014-11-12 21:37 w3gsrumd.f90 1453 ! 1454 ! -------------------------------------------------------------------- / 1455 ! 1456 IF ( ASSOCIATED(GSU%PTR) ) THEN 1457 ! 1458 CALL W3NNSD(GSU%PTR%NNP) 1459 ! 1460 DO IB=1,GSU%PTR%NBX 1461 DO JB=1,GSU%PTR%NBY 1462 IF ( GSU%PTR%B(JB,IB)%N .GT. 0 ) THEN 1463 DEALLOCATE(GSU%PTR%B(JB,IB)%I) 1464 NULLIFY(GSU%PTR%B(JB,IB)%I) 1465 DEALLOCATE(GSU%PTR%B(JB,IB)%J) 1466 NULLIFY(GSU%PTR%B(JB,IB)%J) 1467 END IF 1468 END DO 1469 END DO 1470 DEALLOCATE(GSU%PTR%B) 1471 NULLIFY(GSU%PTR%B) 1472 ! 1473 DEALLOCATE(GSU%PTR) 1474 NULLIFY(GSU%PTR) 1475 ! 1476 END IF 1477 !/ 1478 !/ End of W3GSUD ----------------------------------------------------- / 1479 !/ 1480 END SUBROUTINE W3GSUD Page 35 Source Listing W3GSUD 2014-11-12 21:37 Entry Points w3gsrumd.f90 ENTRY POINTS Name w3gsrumd_mp_w3gsud_ SYMBOL CROSS REFERENCE Name Object Declared Type Bytes Dimen Elements Attributes References ASSOCIATED Func 1456 scalar PRIV 1456 GSU Dummy 1397 T_GSU 8 scalar ARG,INOUT,PRIV 1456,1458,1460,1461,1462,1463,1464 ,1465,1466,1470,1471,1473,1474 IB Local 1451 I(4) 4 scalar 1460,1462,1463,1464,1465,1466 JB Local 1451 I(4) 4 scalar 1461,1462,1463,1464,1465,1466 W3GSUD Subr 1397 W3NNSD Subr 1458 199,1458 Page 36 Source Listing W3GSUD 2014-11-12 21:37 w3gsrumd.f90 1481 !/ ------------------------------------------------------------------- / 1482 SUBROUTINE W3GSUP(GSU, IUNIT, LFULL) 1483 !/ 1484 !/ +-----------------------------------+ 1485 !/ | WAVEWATCH III NOAA/NCEP | 1486 !/ | T. J. Campbell, NRL | 1487 !/ | FORTRAN 90 | 1488 !/ | Last update : 06-Dec-2010 | 1489 !/ +-----------------------------------+ 1490 !/ 1491 !/ 30-Oct-2009 : Origination. ( version 3.14 ) 1492 !/ 01-Dec-2010 : Add output of approx memory usage. ( version 3.14 ) 1493 !/ 06-Dec-2010 : Change ICLO to int. Remove JCLO. 1494 !/ Add GKIND. ( version 3.14 ) 1495 !/ 1496 ! 1. Purpose : 1497 ! 1498 ! Print grid-search-utility (GSU) object to IUNIT. 1499 ! 1500 ! 2. Method : 1501 ! 1502 ! 3. Parameters : 1503 ! 1504 ! Parameter list 1505 ! ---------------------------------------------------------------- 1506 ! GSU Type I Grid-search-utility object. 1507 ! IUNIT Int. I Optional unit for output. Default is stdout. 1508 ! LFULL Log. I Optional logical flag to turn on full-output 1509 ! mode. Default is FALSE. When full-output 1510 ! is enabled the search bucket cell lists and 1511 ! nearest-neighbor point search indices are output. 1512 ! ---------------------------------------------------------------- 1513 ! 1514 ! 4. Subroutines used : 1515 ! 1516 ! See module documentation. 1517 ! 1518 ! 5. Called by : 1519 ! 1520 ! 6. Error messages : 1521 ! 1522 ! - Check on previous creation of grid-search-utility object. 1523 ! 1524 ! 7. Remarks : 1525 ! 1526 ! 8. Structure : 1527 ! 1528 ! 9. Switches : 1529 ! 1530 ! !/S Enable subroutine tracing. 1531 ! 1532 ! 10. Source code : 1533 ! 1534 !/ ------------------------------------------------------------------- / 1535 !/ 1536 !/ ------------------------------------------------------------------- / 1537 !/ Parameter list Page 37 Source Listing W3GSUP 2014-11-12 21:37 w3gsrumd.f90 1538 !/ 1539 TYPE(T_GSU), INTENT(IN) :: GSU 1540 INTEGER, OPTIONAL, INTENT(IN) :: IUNIT 1541 LOGICAL, OPTIONAL, INTENT(IN) :: LFULL 1542 !/ 1543 !/ ------------------------------------------------------------------- / 1544 !/ Local parameters 1545 !/ 1546 INTEGER, PARAMETER :: NBYTE_PTR=4 1547 INTEGER, PARAMETER :: NBYTE_INT=4 1548 TYPE(CLASS_GSU), POINTER :: PTR 1549 INTEGER :: NDST, I, J, K, L, N, IB, JB, NBYTE 1550 !/ 1551 ! 1552 ! -------------------------------------------------------------------- / 1553 ! 1. Test input 1554 ! 1555 IF ( .NOT.ASSOCIATED(GSU%PTR) ) THEN 1556 WRITE(*,'(/1A,1A/)') 'W3GSUP ERROR -- ', & 1557 'grid search utility object not created' 1558 CALL EXTCDE (1) 1559 END IF 1560 1561 IF ( PRESENT(IUNIT) ) THEN 1562 NDST = IUNIT 1563 ELSE 1564 NDST = 6 1565 END IF 1566 1567 PTR => GSU%PTR 1568 ! 1569 ! -------------------------------------------------------------------- / 1570 ! 2. Compute approximate memory usage 1571 ! 1572 NBYTE = (NBYTE_INT+NBYTE_PTR*2)*SIZE(PTR%B) 1573 DO IB=1,PTR%NBX 1574 DO JB=1,PTR%NBY 1575 NBYTE = NBYTE + NBYTE_INT*2*PTR%B(JB,IB)%N 1576 END DO 1577 END DO 1578 ! 1579 ! -------------------------------------------------------------------- / 1580 ! 3. Output 1581 ! 1582 WRITE(NDST,'(//80A)') ('-',K=1,80) 1583 WRITE(NDST,'(A)') 'Report on grid search utility object' 1584 WRITE(NDST,'( 80A)') ('-',K=1,80) 1585 WRITE(NDST,'(A,1L2)') 'Grid ijg:',PTR%IJG 1586 WRITE(NDST,'(A,1L2)') 'Grid llg:',PTR%LLG 1587 WRITE(NDST,'(A,1I2)') 'Grid iclo:',PTR%ICLO 1588 WRITE(NDST,'(A,1L2)') 'Grid lclo:',PTR%LCLO 1589 WRITE(NDST,'(A,1I2)') 'Grid precision:',PTR%GKIND 1590 WRITE(NDST,'(A,2I6)') 'Grid nx,ny:',PTR%NX,PTR%NY 1591 IF ( PRESENT(LFULL) ) THEN 1592 IF ( LFULL ) THEN 1593 WRITE(NDST,'( 80A)') ('-',K=1,80) 1594 WRITE(NDST,'(A)') 'Nearest-neighbor point search indices' Page 38 Source Listing W3GSUP 2014-11-12 21:37 w3gsrumd.f90 1595 WRITE(NDST,'( 80A)') ('-',K=1,80) 1596 CALL W3NNSP(PTR%NNP,NDST) 1597 END IF 1598 END IF 1599 WRITE(NDST,'( 80A)') ('-',K=1,80) 1600 WRITE(NDST,'(A)') 'Bucket-search object' 1601 WRITE(NDST,'( 80A)') ('-',K=1,80) 1602 WRITE(NDST,'(A,4E14.6)') 'Spatial grid search domain: ', & 1603 PTR%XMIN,PTR%YMIN,PTR%XMAX,PTR%YMAX 1604 WRITE(NDST,'(A,2I6)') 'nbx,nby:',PTR%NBX,PTR%NBY 1605 WRITE(NDST,'(A,2E14.6)') 'dxb,dyb:',PTR%DXB,PTR%DYB 1606 WRITE(NDST,'(A,1F10.1)') 'Approximate memory usage (MB):', & 1607 REAL(NBYTE)/2**20 1608 IF ( PRESENT(LFULL) ) THEN 1609 IF ( LFULL ) THEN 1610 WRITE(NDST,'( 80A)') ('-',K=1,80) 1611 WRITE(NDST,'(A)') 'Search bucket bounds:' 1612 WRITE(NDST,'( 80A)') ('-',K=1,80) 1613 WRITE(NDST,'(2A4,4A14)') 'IB','JB','X1','Y1','X2','Y2' 1614 DO IB=1,PTR%NBX 1615 DO JB=1,PTR%NBY 1616 WRITE(*,'(2I4,4E14.6)') IB,JB, & 1617 PTR%XMIN+(IB-1)*PTR%DXB,PTR%YMIN+(JB-1)*PTR%DYB, & 1618 PTR%XMIN+(IB )*PTR%DXB,PTR%YMIN+(JB )*PTR%DYB 1619 END DO 1620 END DO 1621 WRITE(NDST,'( 80A)') ('-',K=1,80) 1622 WRITE(NDST,'(A)') 'Number of cells in each search bucket:' 1623 WRITE(NDST,'( 80A)') ('-',K=1,80) 1624 DO JB=PTR%NBY,1,-1 1625 WRITE(NDST,'(500I4)') (PTR%B(JB,IB)%N,IB=1,PTR%NBX) 1626 END DO 1627 WRITE(NDST,'( 80A)') ('-',K=1,80) 1628 WRITE(NDST,'(A)') 'Search bucket cell lists:' 1629 WRITE(NDST,'( 80A)') ('-',K=1,80) 1630 WRITE(NDST,'(3A4,A)') 'IB','JB','NC',': ( IC, JC), ...' 1631 DO JB=1,PTR%NBY 1632 DO IB=1,PTR%NBX 1633 WRITE(NDST,'(3I4,A,500(A,I3,A,I3,A))') IB,JB, & 1634 PTR%B(JB,IB)%N, ': ', & 1635 ( '(',PTR%B(JB,IB)%I(K),',',PTR%B(JB,IB)%J(K),') ', & 1636 K=1,PTR%B(JB,IB)%N ) 1637 END DO 1638 END DO 1639 END IF !LFULL 1640 END IF !PRESENT(LFULL) 1641 WRITE(NDST,'( 80A)') ('-',K=1,80) 1642 WRITE(NDST,'( 80A)') ('-',K=1,80) 1643 !/ 1644 !/ End of W3GSUP ----------------------------------------------------- / 1645 !/ 1646 END SUBROUTINE W3GSUP Page 39 Source Listing W3GSUP 2014-11-12 21:37 Entry Points w3gsrumd.f90 ENTRY POINTS Name w3gsrumd_mp_w3gsup_ SYMBOL CROSS REFERENCE Name Object Declared Type Bytes Dimen Elements Attributes References ASSOCIATED Func 1555 scalar PRIV 1555 GSU Dummy 1482 T_GSU 8 scalar ARG,IN,PRIV 1555,1567 I Local 1549 I(4) 4 scalar IB Local 1549 I(4) 4 scalar 1573,1575,1614,1616,1617,1618,1625 ,1632,1633,1634,1635,1636 IUNIT Dummy 1482 I(4) 4 scalar ARG,IN,PRIV 1561,1562 J Local 1549 I(4) 4 scalar JB Local 1549 I(4) 4 scalar 1574,1575,1615,1616,1617,1618,1624 ,1625,1631,1633,1634,1635,1636 K Local 1549 I(4) 4 scalar 1582,1584,1593,1595,1599,1601,1610 ,1612,1621,1623,1627,1629,1635,163 6,1641,1642 L Local 1549 I(4) 4 scalar LFULL Dummy 1482 L(4) 4 scalar ARG,IN,PRIV 1591,1592,1608,1609 N Local 1549 I(4) 4 scalar NBYTE Local 1549 I(4) 4 scalar 1572,1575,1607 NBYTE_INT Param 1547 I(4) 4 scalar 1572,1575 NBYTE_PTR Param 1546 I(4) 4 scalar 1572 NDST Local 1549 I(4) 4 scalar 1562,1564,1582,1583,1584,1585,1586 ,1587,1588,1589,1590,1593,1594,159 5,1596,1599,1600,1601,1602,1604,16 05,1606,1610,1611,1612,1613,1621,1 622,1623,1625,1627,1628,1629,1630, 1633,1641,1642 PRESENT Func 1561 scalar PRIV 1561,1591,1608 PTR Local 1548 CLASS_GSU 576 scalar PTR 1567,1572,1573,1574,1575,1585,1586 ,1587,1588,1589,1590,1596,1603,160 4,1605,1614,1615,1617,1618,1624,16 25,1631,1632,1634,1635,1636 REAL Func 1607 scalar PRIV 1607 SIZE Func 1572 scalar PRIV 1572 W3GSUP Subr 1482 W3NNSP Subr 1596 200,1596 Page 40 Source Listing W3GSUP 2014-11-12 21:37 w3gsrumd.f90 1647 !/ ------------------------------------------------------------------- / 1648 FUNCTION W3GFCL_R4(GSU, XT, YT, IS, JS, XS, YS, POLE, DEBUG) & 1649 RESULT(INGRID) 1650 !/ 1651 !/ +-----------------------------------+ 1652 !/ | WAVEWATCH III NOAA/NCEP | 1653 !/ | T. J. Campbell, NRL | 1654 !/ | FORTRAN 90 | 1655 !/ | Last update : 06-Dec-2010 | 1656 !/ +-----------------------------------+ 1657 !/ 1658 !/ 30-Oct-2009 : Origination. ( version 3.14 ) 1659 !/ 12-Nov-2010 : Implement r4 & r8 interfaces. ( version 3.14 ) 1660 !/ 01-Dec-2010 : Remove search using nnbr buckets. ( version 3.14 ) 1661 !/ 06-Dec-2010 : Remove restriction on longitude range. Change ICLO 1662 !/ to integer and remove JCLO. Implement support for 1663 !/ r4 and r8 source grids. ( version 3.14 ) 1664 !/ 1665 ! 1. Purpose : 1666 ! 1667 ! Find cell in grid, associated with the input grid-search-utility 1668 ! object (GSU), that encloses the target point (xt,yt). 1669 ! Single precision interface. 1670 ! 1671 ! 2. Method : 1672 ! 1673 ! 3. Parameters : 1674 ! 1675 ! Return parameter 1676 ! ---------------------------------------------------------------- 1677 ! INGRID Log. O Logical flag indicating if target point lies 1678 ! within the source grid domain. 1679 ! ---------------------------------------------------------------- 1680 ! 1681 ! Parameter list 1682 ! ---------------------------------------------------------------- 1683 ! GSU Type I Grid-search-utility object. 1684 ! XT Real I X-coordinate of target point. 1685 ! YT Real I Y-coordinate of target point. 1686 ! IS,JS I.A. O (I,J) indices of vertices of enclosing grid cell. 1687 ! XS,YS R.A. O (X,Y) coord. of vertices of enclosing grid cell. 1688 ! POLE Log. O Optional logical flag to indicate whether or not 1689 ! the enclosing grid cell includes a pole. 1690 ! DEBUG Log. I Optional logical flag to turn on debug mode. 1691 ! Default is FALSE. 1692 ! ---------------------------------------------------------------- 1693 ! 1694 ! 4. Subroutines used : 1695 ! 1696 ! See module documentation. 1697 ! 1698 ! 5. Called by : 1699 ! 1700 ! 6. Error messages : 1701 ! 1702 ! - Check on previous creation of grid-search-utility object. 1703 ! Page 41 Source Listing W3GFCL_R4 2014-11-12 21:37 w3gsrumd.f90 1704 ! 7. Remarks : 1705 ! 1706 ! - The target point coordinates may be modified by this routine. 1707 ! - The target point longitude will be shifted to the source grid 1708 ! longitudinal range. 1709 ! - If enclosing cell includes a branch cut, then the coordinates of 1710 ! of the cell vertices AND the target point will be adjusted so 1711 ! that the branch cut is shifted 180 degrees. 1712 ! 1713 ! 8. Structure : 1714 ! 1715 ! ----------------------------------------------------------------- 1716 ! 1. Test input 1717 ! 2. Initialize search 1718 ! 3. Search for enclosing cell in central and nearest nbr buckets 1719 ! ----------------------------------------------------------------- 1720 ! 1721 ! 9. Switches : 1722 ! 1723 ! !/S Enable subroutine tracing. 1724 ! 1725 ! 10. Source code : 1726 ! 1727 !/ ------------------------------------------------------------------- / 1728 !/ 1729 !/ ------------------------------------------------------------------- / 1730 !/ Return parameter 1731 !/ 1732 LOGICAL :: INGRID 1733 !/ 1734 !/ ------------------------------------------------------------------- / 1735 !/ Parameter list 1736 !/ 1737 TYPE(T_GSU), INTENT(IN) :: GSU 1738 REAL(4), INTENT(INOUT) :: XT 1739 REAL(4), INTENT(INOUT) :: YT 1740 INTEGER, INTENT(INOUT) :: IS(4), JS(4) 1741 REAL(4), INTENT(INOUT) :: XS(4), YS(4) 1742 LOGICAL, INTENT(OUT),OPTIONAL :: POLE 1743 LOGICAL, INTENT(IN), OPTIONAL :: DEBUG 1744 !/ 1745 !/ ------------------------------------------------------------------- / 1746 !/ Local parameters 1747 !/ 1748 LOGICAL :: LDBG, LPLC 1749 INTEGER :: I, J, K, L, N, IB, JB 1750 LOGICAL :: IJG, LLG, LCLO, L360 1751 INTEGER :: ICLO, GKIND 1752 INTEGER :: NX, NY 1753 REAL(4), POINTER :: XG4(:,:), YG4(:,:) 1754 REAL(8), POINTER :: XG8(:,:), YG8(:,:) 1755 INTEGER :: NBX, NBY 1756 REAL(8) :: DXB, DYB, XMIN, XMAX, YMIN, YMAX 1757 TYPE(T_BKT), POINTER :: B(:,:) 1758 !/ 1759 ! 1760 ! -------------------------------------------------------------------- / Page 42 Source Listing W3GFCL_R4 2014-11-12 21:37 w3gsrumd.f90 1761 ! 1. Test input 1762 ! 1763 IF ( .NOT.ASSOCIATED(GSU%PTR) ) THEN 1764 WRITE(*,'(/2A/)') 'W3GFCL_R4 ERROR -- ', & 1765 'grid search utility object not created' 1766 CALL EXTCDE (1) 1767 END IF 1768 ! 1769 ! -------------------------------------------------------------------- / 1770 ! 2. Initialize search 1771 ! 1772 IF ( PRESENT(DEBUG) ) THEN 1773 LDBG = DEBUG 1774 ELSE 1775 LDBG = .FALSE. 1776 END IF 1777 ! 1778 ! Local pointers to grid search utility object data 1779 IJG = GSU%PTR%IJG 1780 LLG = GSU%PTR%LLG 1781 ICLO = GSU%PTR%ICLO 1782 LCLO = GSU%PTR%LCLO 1783 L360 = GSU%PTR%L360 1784 GKIND = GSU%PTR%GKIND 1785 NX = GSU%PTR%NX; NY = GSU%PTR%NY; 1786 IF ( GKIND.EQ.4 ) THEN 1787 XG4 => GSU%PTR%XG4; YG4 => GSU%PTR%YG4; 1788 ELSE 1789 XG8 => GSU%PTR%XG8; YG8 => GSU%PTR%YG8; 1790 END IF 1791 NBX = GSU%PTR%NBX; NBY = GSU%PTR%NBY; 1792 DXB = GSU%PTR%DXB; DYB = GSU%PTR%DYB; 1793 XMIN = GSU%PTR%XMIN; YMIN = GSU%PTR%YMIN; 1794 XMAX = GSU%PTR%XMAX; YMAX = GSU%PTR%YMAX; 1795 B => GSU%PTR%B 1796 ! 1797 INGRID = .FALSE. 1798 ! 1799 ! Shift target to appropriate longitude range 1800 IF ( LLG ) THEN 1801 XT = MOD(XT,REAL(D360,4)) 1802 IF ( LCLO .OR. L360 ) THEN 1803 IF ( XT.LT.ZERO ) XT = XT + D360 1804 ELSE 1805 IF ( XT.GT.D180 ) XT = XT - D360 1806 END IF 1807 END IF 1808 IF ( LDBG ) WRITE(*,'(/A,2E14.6)') 'W3GFCL_R4 - TARGET POINT:',XT,YT 1809 ! 1810 ! Target point must lie within search domain 1811 IF ( XT.LT.XMIN .OR. XT.GT.XMAX .OR. & 1812 YT.LT.YMIN .OR. YT.GT.YMAX ) THEN 1813 IF ( LDBG ) WRITE(*,'(A)') & 1814 'W3GFCL_R4 - TARGET POINT OUTSIDE SEARCH DOMAIN' 1815 RETURN 1816 END IF 1817 ! Page 43 Source Listing W3GFCL_R4 2014-11-12 21:37 w3gsrumd.f90 1818 ! Search bucket that contains the target point. 1819 IB = INT((XT-XMIN)/DXB)+1; IF ( .NOT.LCLO ) IB = MIN(IB,NBX); 1820 JB = INT((YT-YMIN)/DYB)+1; JB = MIN(JB,NBY); 1821 ! 1822 ! -------------------------------------------------------------------- / 1823 ! 3. Search for enclosing cell in bucket 1824 ! 1825 IF ( LDBG ) & 1826 WRITE(*,'(A,3I6,4E14.6)') & 1827 'W3GFCL_R4 - BUCKET SEARCH:',IB,JB,B(JB,IB)%N, & 1828 XMIN+(IB-1)*DXB,YMIN+(JB-1)*DYB,XMIN+IB*DXB,YMIN+JB*DYB 1829 CELL_LOOP: DO K=1,B(JB,IB)%N 1830 !---------setup cell corner indices 1831 IS(1) = B(JB,IB)%I(K) ; JS(1) = B(JB,IB)%J(K) ; 1832 IS(2) = B(JB,IB)%I(K)+1; JS(2) = B(JB,IB)%J(K) ; 1833 IS(3) = B(JB,IB)%I(K)+1; JS(3) = B(JB,IB)%J(K)+1; 1834 IS(4) = B(JB,IB)%I(K) ; JS(4) = B(JB,IB)%J(K)+1; 1835 !---------setup cell corner coordinates and adjust for periodicity 1836 DO L=1,4 1837 IF ( ICLO.NE.ICLO_NONE ) THEN 1838 IF ( IS(L) .LT. 1 ) IS(L) = IS(L) + NX 1839 IF ( IS(L) .GT. NX ) IS(L) = IS(L) - NX 1840 END IF 1841 IF ( ICLO.EQ.ICLO_TRPL ) THEN 1842 IF ( JS(L) .GT. NY ) THEN 1843 JS(L) = NY 1844 IS(L) = MOD(NX-IS(L)+1,NX) + 1 1845 END IF 1846 END IF 1847 IF ( IJG ) THEN 1848 IF ( GKIND.EQ.4 ) THEN 1849 XS(L) = XG4(IS(L),JS(L)); YS(L) = YG4(IS(L),JS(L)); 1850 ELSE 1851 XS(L) = XG8(IS(L),JS(L)); YS(L) = YG8(IS(L),JS(L)); 1852 END IF 1853 ELSE 1854 IF ( GKIND.EQ.4 ) THEN 1855 XS(L) = XG4(JS(L),IS(L)); YS(L) = YG4(JS(L),IS(L)); 1856 ELSE 1857 XS(L) = XG8(JS(L),IS(L)); YS(L) = YG8(JS(L),IS(L)); 1858 END IF 1859 END IF 1860 IF ( LLG ) THEN 1861 XS(L) = MOD(XS(L),REAL(D360,4)) 1862 IF ( LCLO .OR. L360 ) THEN 1863 IF ( XS(L).LT.ZERO ) XS(L) = XS(L) + D360 1864 ELSE 1865 IF ( XS(L).GT.D180 ) XS(L) = XS(L) - D360 1866 END IF 1867 END IF 1868 END DO !L 1869 IF ( LDBG ) & 1870 WRITE(*,'(A,3I6,4(/A,1I1,A,2I6,2E14.6))') & 1871 'W3GFCL_R4 - CHECK CELL:',IB,JB,K, & 1872 (' CORNER(',L,'):',IS(L),JS(L),XS(L),YS(L),L=1,4) 1873 !---------check if point is enclosed in cell defined by xs(1:4) & ys(1:4) 1874 INGRID = W3CKCL(LLG,XT,YT,4,XS,YS,LPLC,LDBG) Page 44 Source Listing W3GFCL_R4 2014-11-12 21:37 w3gsrumd.f90 1875 IF ( LDBG ) WRITE(*,'(A,1L2)')'W3GFCL_R4 - INGRID:',INGRID 1876 IF ( INGRID ) THEN 1877 !-------------exit search 1878 IF ( LDBG ) & 1879 WRITE(*,'(A,3I6,4(2I6))') & 1880 'W3GFCL_R4 - ENCLOSING CELL:',IB,JB,K,(IS(L),JS(L),L=1,4) 1881 IF ( PRESENT(POLE) ) POLE = LPLC 1882 EXIT CELL_LOOP 1883 END IF !point in cell 1884 END DO CELL_LOOP 1885 !/ 1886 !/ End of W3GFCL_R4 -------------------------------------------------- / 1887 !/ 1888 END FUNCTION W3GFCL_R4 ENTRY POINTS Name w3gsrumd_mp_w3gfcl_r4_ SYMBOL CROSS REFERENCE Name Object Declared Type Bytes Dimen Elements Attributes References ASSOCIATED Func 1763 scalar PRIV 1763 B Local 1757 RECORD 152 2 1 PTR 1795,1827,1829,1831,1832,1833,1834 CELL_LOOP Label 1829 scalar 1882,1884 DEBUG Dummy 1648 L(4) 4 scalar ARG,IN,PRIV 1772,1773 DXB Local 1756 R(8) 8 scalar 1792,1819,1828 DYB Local 1756 R(8) 8 scalar 1792,1820,1828 GKIND Local 1751 I(4) 4 scalar 1784,1786,1848,1854 GSU Dummy 1648 T_GSU 8 scalar ARG,IN,PRIV 1763,1779,1780,1781,1782,1783,1784 ,1785,1787,1789,1791,1792,1793,179 4,1795 I Local 1749 I(4) 4 scalar IB Local 1749 I(4) 4 scalar 1819,1827,1828,1829,1831,1832,1833 ,1834,1871,1880 ICLO Local 1751 I(4) 4 scalar 1781,1837,1841 IJG Local 1750 L(4) 4 scalar 1779,1847 INGRID Local 1732 L(4) 4 scalar 1797,1874,1875,1876 INT Func 1819 scalar PRIV 1819,1820 IS Dummy 1648 I(4) 4 1 4 ARG,INOUT,PRIV 1831,1832,1833,1834,1838,1839,1844 ,1849,1851,1855,1857,1872,1880 J Local 1749 I(4) 4 scalar JB Local 1749 I(4) 4 scalar 1820,1827,1828,1829,1831,1832,1833 ,1834,1871,1880 JS Dummy 1648 I(4) 4 1 4 ARG,INOUT,PRIV 1831,1832,1833,1834,1842,1843,1849 ,1851,1855,1857,1872,1880 K Local 1749 I(4) 4 scalar 1829,1831,1832,1833,1834,1871,1880 L Local 1749 I(4) 4 scalar 1836,1838,1839,1842,1843,1844,1849 ,1851,1855,1857,1861,1863,1865,187 2,1880 L360 Local 1750 L(4) 4 scalar 1783,1802,1862 LCLO Local 1750 L(4) 4 scalar 1782,1802,1819,1862 Page 45 Source Listing W3GFCL_R4 2014-11-12 21:37 Symbol Table w3gsrumd.f90 Name Object Declared Type Bytes Dimen Elements Attributes References LDBG Local 1748 L(4) 4 scalar 1773,1775,1808,1813,1825,1869,1874 ,1875,1878 LLG Local 1750 L(4) 4 scalar 1780,1800,1860,1874 LPLC Local 1748 L(4) 4 scalar 1874,1881 MIN Func 1819 scalar PRIV 1819,1820 MOD Func 1801 scalar PRIV 1801,1844,1861 N Local 1749 I(4) 4 scalar NBX Local 1755 I(4) 4 scalar 1791,1819 NBY Local 1755 I(4) 4 scalar 1791,1820 NX Local 1752 I(4) 4 scalar 1785,1838,1839,1844 NY Local 1752 I(4) 4 scalar 1785,1842,1843 POLE Dummy 1648 L(4) 4 scalar ARG,OUT,PRIV 1881 PRESENT Func 1772 scalar PRIV 1772,1881 REAL Func 1801 scalar PRIV 1801,1861 T_BKT Type 1757 152 scalar PRIV 250,259,1757,1999 W3CKCL Local 1874 scalar 203,1874,2117,2345,2574 W3GFCL_R4 Func 1648 L(4) 4 scalar PRIV 2716,2993,3337 XG4 Local 1753 R(4) 4 2 1 PTR 1787,1849,1855 XG8 Local 1754 R(8) 8 2 1 PTR 1789,1851,1857 XMAX Local 1756 R(8) 8 scalar 1794,1811 XMIN Local 1756 R(8) 8 scalar 1793,1811,1819,1828 XS Dummy 1648 R(4) 4 1 4 ARG,INOUT,PRIV 1849,1851,1855,1857,1861,1863,1865 ,1872,1874 XT Dummy 1648 R(4) 4 scalar ARG,INOUT,PRIV 1801,1803,1805,1808,1811,1819,1874 YG4 Local 1753 R(4) 4 2 1 PTR 1787,1849,1855 YG8 Local 1754 R(8) 8 2 1 PTR 1789,1851,1857 YMAX Local 1756 R(8) 8 scalar 1794,1812 YMIN Local 1756 R(8) 8 scalar 1793,1812,1820,1828 YS Dummy 1648 R(4) 4 1 4 ARG,INOUT,PRIV 1849,1851,1855,1857,1872,1874 YT Dummy 1648 R(4) 4 scalar ARG,INOUT,PRIV 1808,1812,1820,1874 Page 46 Source Listing W3GFCL_R4 2014-11-12 21:37 w3gsrumd.f90 1889 !/ ------------------------------------------------------------------- / 1890 FUNCTION W3GFCL_R8(GSU, XT, YT, IS, JS, XS, YS, POLE, DEBUG) & 1891 RESULT(INGRID) 1892 !/ 1893 !/ +-----------------------------------+ 1894 !/ | WAVEWATCH III NOAA/NCEP | 1895 !/ | T. J. Campbell, NRL | 1896 !/ | FORTRAN 90 | 1897 !/ | Last update : 06-Dec-2010 | 1898 !/ +-----------------------------------+ 1899 !/ 1900 !/ 30-Oct-2009 : Origination. ( version 3.14 ) 1901 !/ 12-Nov-2010 : Implement r4 & r8 interfaces. ( version 3.14 ) 1902 !/ 01-Dec-2010 : Remove search using nnbr buckets. ( version 3.14 ) 1903 !/ 06-Dec-2010 : Remove restriction on longitude range. Change ICLO 1904 !/ to integer and remove JCLO. Implement support for 1905 !/ r4 and r8 source grids. ( version 3.14 ) 1906 !/ 1907 ! 1. Purpose : 1908 ! 1909 ! Find cell in grid, associated with the input grid-search-utility 1910 ! object (GSU), that encloses the target point (xt,yt). 1911 ! Double precision interface. 1912 ! 1913 ! 2. Method : 1914 ! 1915 ! 3. Parameters : 1916 ! 1917 ! Return parameter 1918 ! ---------------------------------------------------------------- 1919 ! INGRID Log. O Logical flag indicating if target point lies 1920 ! within the source grid domain. 1921 ! ---------------------------------------------------------------- 1922 ! 1923 ! Parameter list 1924 ! ---------------------------------------------------------------- 1925 ! GSU Type I Grid-search-utility object. 1926 ! XT Real I X-coordinate of target point. 1927 ! YT Real I Y-coordinate of target point. 1928 ! IS,JS I.A. O (I,J) indices of vertices of enclosing grid cell. 1929 ! XS,YS R.A. O (X,Y) coord. of vertices of enclosing grid cell. 1930 ! POLE Log. O Optional logical flag to indicate whether or not 1931 ! the enclosing grid cell includes a pole. 1932 ! DEBUG Log. I Optional logical flag to turn on debug mode. 1933 ! Default is FALSE. 1934 ! ---------------------------------------------------------------- 1935 ! 1936 ! 4. Subroutines used : 1937 ! 1938 ! See module documentation. 1939 ! 1940 ! 5. Called by : 1941 ! 1942 ! 6. Error messages : 1943 ! 1944 ! - Check on previous creation of grid-search-utility object. 1945 ! Page 47 Source Listing W3GFCL_R8 2014-11-12 21:37 w3gsrumd.f90 1946 ! 7. Remarks : 1947 ! 1948 ! - The target point coordinates may be modified by this routine. 1949 ! - The target point longitude will be shifted to the source grid 1950 ! longitudinal range. 1951 ! - If enclosing cell includes a branch cut, then the coordinates of 1952 ! of the cell vertices AND the target point will be adjusted so 1953 ! that the branch cut is shifted 180 degrees. 1954 ! 1955 ! 8. Structure : 1956 ! 1957 ! ----------------------------------------------------------------- 1958 ! 1. Test input 1959 ! 2. Initialize search 1960 ! 3. Search for enclosing cell in central and nearest nbr buckets 1961 ! ----------------------------------------------------------------- 1962 ! 1963 ! 9. Switches : 1964 ! 1965 ! !/S Enable subroutine tracing. 1966 ! 1967 ! 10. Source code : 1968 ! 1969 !/ ------------------------------------------------------------------- / 1970 !/ 1971 !/ ------------------------------------------------------------------- / 1972 !/ Return parameter 1973 !/ 1974 LOGICAL :: INGRID 1975 !/ 1976 !/ ------------------------------------------------------------------- / 1977 !/ Parameter list 1978 !/ 1979 TYPE(T_GSU), INTENT(IN) :: GSU 1980 REAL(8), INTENT(INOUT) :: XT 1981 REAL(8), INTENT(INOUT) :: YT 1982 INTEGER, INTENT(INOUT) :: IS(4), JS(4) 1983 REAL(8), INTENT(INOUT) :: XS(4), YS(4) 1984 LOGICAL, INTENT(OUT),OPTIONAL :: POLE 1985 LOGICAL, INTENT(IN), OPTIONAL :: DEBUG 1986 !/ 1987 !/ ------------------------------------------------------------------- / 1988 !/ Local parameters 1989 !/ 1990 LOGICAL :: LDBG, LPLC 1991 INTEGER :: I, J, K, L, N, IB, JB 1992 LOGICAL :: IJG, LLG, LCLO, L360 1993 INTEGER :: ICLO, GKIND 1994 INTEGER :: NX, NY 1995 REAL(4), POINTER :: XG4(:,:), YG4(:,:) 1996 REAL(8), POINTER :: XG8(:,:), YG8(:,:) 1997 INTEGER :: NBX, NBY 1998 REAL(8) :: DXB, DYB, XMIN, XMAX, YMIN, YMAX 1999 TYPE(T_BKT), POINTER :: B(:,:) 2000 !/ 2001 ! 2002 ! -------------------------------------------------------------------- / Page 48 Source Listing W3GFCL_R8 2014-11-12 21:37 w3gsrumd.f90 2003 ! 1. Test input 2004 ! 2005 IF ( .NOT.ASSOCIATED(GSU%PTR) ) THEN 2006 WRITE(*,'(/2A/)') 'W3GFCL_R8 ERROR -- ', & 2007 'grid search utility object not created' 2008 CALL EXTCDE (1) 2009 END IF 2010 ! 2011 ! -------------------------------------------------------------------- / 2012 ! 2. Initialize search 2013 ! 2014 IF ( PRESENT(DEBUG) ) THEN 2015 LDBG = DEBUG 2016 ELSE 2017 LDBG = .FALSE. 2018 END IF 2019 ! 2020 ! Local pointers to grid search utility object data 2021 IJG = GSU%PTR%IJG 2022 LLG = GSU%PTR%LLG 2023 ICLO = GSU%PTR%ICLO 2024 LCLO = GSU%PTR%LCLO 2025 L360 = GSU%PTR%L360 2026 GKIND = GSU%PTR%GKIND 2027 NX = GSU%PTR%NX; NY = GSU%PTR%NY; 2028 IF ( GKIND.EQ.4 ) THEN 2029 XG4 => GSU%PTR%XG4; YG4 => GSU%PTR%YG4; 2030 ELSE 2031 XG8 => GSU%PTR%XG8; YG8 => GSU%PTR%YG8; 2032 END IF 2033 NBX = GSU%PTR%NBX; NBY = GSU%PTR%NBY; 2034 DXB = GSU%PTR%DXB; DYB = GSU%PTR%DYB; 2035 XMIN = GSU%PTR%XMIN; YMIN = GSU%PTR%YMIN; 2036 XMAX = GSU%PTR%XMAX; YMAX = GSU%PTR%YMAX; 2037 B => GSU%PTR%B 2038 ! 2039 INGRID = .FALSE. 2040 ! 2041 ! Shift target to appropriate longitude range 2042 IF ( LLG ) THEN 2043 XT = MOD(XT,REAL(D360,8)) 2044 IF ( LCLO .OR. L360 ) THEN 2045 IF ( XT.LT.ZERO ) XT = XT + D360 2046 ELSE 2047 IF ( XT.GT.D180 ) XT = XT - D360 2048 END IF 2049 END IF 2050 IF ( LDBG ) WRITE(*,'(/A,2E14.6)') 'W3GFCL_R8 - TARGET POINT:',XT,YT 2051 ! 2052 ! Target point must lie within search domain 2053 IF ( XT.LT.XMIN .OR. XT.GT.XMAX .OR. & 2054 YT.LT.YMIN .OR. YT.GT.YMAX ) THEN 2055 IF ( LDBG ) WRITE(*,'(A)') & 2056 'W3GFCL_R8 - TARGET POINT OUTSIDE SEARCH DOMAIN' 2057 RETURN 2058 END IF 2059 ! Page 49 Source Listing W3GFCL_R8 2014-11-12 21:37 w3gsrumd.f90 2060 ! Search bucket that contains the target point. 2061 IB = INT((XT-XMIN)/DXB)+1; IF ( .NOT.LCLO ) IB = MIN(IB,NBX); 2062 JB = INT((YT-YMIN)/DYB)+1; JB = MIN(JB,NBY); 2063 ! 2064 ! -------------------------------------------------------------------- / 2065 ! 3. Search for enclosing cell in bucket 2066 ! 2067 IF ( LDBG ) & 2068 WRITE(*,'(A,3I6,4E14.6)') & 2069 'W3GFCL_R8 - BUCKET SEARCH:',IB,JB,B(JB,IB)%N, & 2070 XMIN+(IB-1)*DXB,YMIN+(JB-1)*DYB,XMIN+IB*DXB,YMIN+JB*DYB 2071 CELL_LOOP: DO K=1,B(JB,IB)%N 2072 2073 !---------setup cell corner indices 2074 IS(1) = B(JB,IB)%I(K) ; JS(1) = B(JB,IB)%J(K) ; 2075 IS(2) = B(JB,IB)%I(K)+1; JS(2) = B(JB,IB)%J(K) ; 2076 IS(3) = B(JB,IB)%I(K)+1; JS(3) = B(JB,IB)%J(K)+1; 2077 IS(4) = B(JB,IB)%I(K) ; JS(4) = B(JB,IB)%J(K)+1; 2078 !---------setup cell corner coordinates and adjust for periodicity 2079 DO L=1,4 2080 IF ( ICLO.NE.ICLO_NONE ) THEN 2081 IF ( IS(L) .LT. 1 ) IS(L) = IS(L) + NX 2082 IF ( IS(L) .GT. NX ) IS(L) = IS(L) - NX 2083 END IF 2084 IF ( ICLO.EQ.ICLO_TRPL ) THEN 2085 IF ( JS(L) .GT. NY ) THEN 2086 JS(L) = NY 2087 IS(L) = MOD(NX-IS(L)+1,NX) + 1 2088 END IF 2089 END IF 2090 IF ( IJG ) THEN 2091 IF ( GKIND.EQ.4 ) THEN 2092 XS(L) = XG4(IS(L),JS(L)); YS(L) = YG4(IS(L),JS(L)); 2093 ELSE 2094 XS(L) = XG8(IS(L),JS(L)); YS(L) = YG8(IS(L),JS(L)); 2095 END IF 2096 ELSE 2097 IF ( GKIND.EQ.4 ) THEN 2098 XS(L) = XG4(JS(L),IS(L)); YS(L) = YG4(JS(L),IS(L)); 2099 ELSE 2100 XS(L) = XG8(JS(L),IS(L)); YS(L) = YG8(JS(L),IS(L)); 2101 END IF 2102 END IF 2103 IF ( LLG ) THEN 2104 XS(L) = MOD(XS(L),REAL(D360,8)) 2105 IF ( LCLO .OR. L360 ) THEN 2106 IF ( XS(L).LT.ZERO ) XS(L) = XS(L) + D360 2107 ELSE 2108 IF ( XS(L).GT.D180 ) XS(L) = XS(L) - D360 2109 END IF 2110 END IF 2111 END DO !L 2112 IF ( LDBG ) & 2113 WRITE(*,'(A,3I6,4(/A,1I1,A,2I6,2E14.6))') & 2114 'W3GFCL_R8 - CHECK CELL:',IB,JB,K, & 2115 (' CORNER(',L,'):',IS(L),JS(L),XS(L),YS(L),L=1,4) 2116 !---------check if point is enclosed in cell defined by xs(1:4) & ys(1:4) Page 50 Source Listing W3GFCL_R8 2014-11-12 21:37 w3gsrumd.f90 2117 INGRID = W3CKCL(LLG,XT,YT,4,XS,YS,LPLC,LDBG) 2118 IF ( LDBG ) WRITE(*,'(A,1L2)')'W3GFCL_R8 - INGRID:',INGRID 2119 IF ( INGRID ) THEN 2120 !-------------exit search 2121 IF ( LDBG ) & 2122 WRITE(*,'(A,3I6,4(2I6))') & 2123 'W3GFCL_R8 - ENCLOSING CELL:',IB,JB,K,(IS(L),JS(L),L=1,4) 2124 IF ( PRESENT(POLE) ) POLE = LPLC 2125 EXIT CELL_LOOP 2126 END IF !point in cell 2127 END DO CELL_LOOP 2128 !/ 2129 !/ End of W3GFCL_R8 -------------------------------------------------- / 2130 !/ 2131 END FUNCTION W3GFCL_R8 ENTRY POINTS Name w3gsrumd_mp_w3gfcl_r8_ SYMBOL CROSS REFERENCE Name Object Declared Type Bytes Dimen Elements Attributes References ASSOCIATED Func 2005 scalar PRIV 2005 B Local 1999 RECORD 152 2 1 PTR 2037,2069,2071,2074,2075,2076,2077 CELL_LOOP Label 2071 scalar 2125,2127 DEBUG Dummy 1890 L(4) 4 scalar ARG,IN,PRIV 2014,2015 DXB Local 1998 R(8) 8 scalar 2034,2061,2070 DYB Local 1998 R(8) 8 scalar 2034,2062,2070 GKIND Local 1993 I(4) 4 scalar 2026,2028,2091,2097 GSU Dummy 1890 T_GSU 8 scalar ARG,IN,PRIV 2005,2021,2022,2023,2024,2025,2026 ,2027,2029,2031,2033,2034,2035,203 6,2037 I Local 1991 I(4) 4 scalar IB Local 1991 I(4) 4 scalar 2061,2069,2070,2071,2074,2075,2076 ,2077,2114,2123 ICLO Local 1993 I(4) 4 scalar 2023,2080,2084 IJG Local 1992 L(4) 4 scalar 2021,2090 INGRID Local 1974 L(4) 4 scalar 2039,2117,2118,2119 INT Func 2061 scalar PRIV 2061,2062 IS Dummy 1890 I(4) 4 1 4 ARG,INOUT,PRIV 2074,2075,2076,2077,2081,2082,2087 ,2092,2094,2098,2100,2115,2123 J Local 1991 I(4) 4 scalar JB Local 1991 I(4) 4 scalar 2062,2069,2070,2071,2074,2075,2076 ,2077,2114,2123 JS Dummy 1890 I(4) 4 1 4 ARG,INOUT,PRIV 2074,2075,2076,2077,2085,2086,2092 ,2094,2098,2100,2115,2123 K Local 1991 I(4) 4 scalar 2071,2074,2075,2076,2077,2114,2123 L Local 1991 I(4) 4 scalar 2079,2081,2082,2085,2086,2087,2092 ,2094,2098,2100,2104,2106,2108,211 5,2123 L360 Local 1992 L(4) 4 scalar 2025,2044,2105 Page 51 Source Listing W3GFCL_R8 2014-11-12 21:37 Symbol Table w3gsrumd.f90 Name Object Declared Type Bytes Dimen Elements Attributes References LCLO Local 1992 L(4) 4 scalar 2024,2044,2061,2105 LDBG Local 1990 L(4) 4 scalar 2015,2017,2050,2055,2067,2112,2117 ,2118,2121 LLG Local 1992 L(4) 4 scalar 2022,2042,2103,2117 LPLC Local 1990 L(4) 4 scalar 2117,2124 MIN Func 2061 scalar PRIV 2061,2062 MOD Func 2043 scalar PRIV 2043,2087,2104 N Local 1991 I(4) 4 scalar NBX Local 1997 I(4) 4 scalar 2033,2061 NBY Local 1997 I(4) 4 scalar 2033,2062 NX Local 1994 I(4) 4 scalar 2027,2081,2082,2087 NY Local 1994 I(4) 4 scalar 2027,2085,2086 POLE Dummy 1890 L(4) 4 scalar ARG,OUT,PRIV 2124 PRESENT Func 2014 scalar PRIV 2014,2124 REAL Func 2043 scalar PRIV 2043,2104 W3GFCL_R8 Func 1890 L(4) 4 scalar PRIV 2858,3127,3709 XG4 Local 1995 R(4) 4 2 1 PTR 2029,2092,2098 XG8 Local 1996 R(8) 8 2 1 PTR 2031,2094,2100 XMAX Local 1998 R(8) 8 scalar 2036,2053 XMIN Local 1998 R(8) 8 scalar 2035,2053,2061,2070 XS Dummy 1890 R(8) 8 1 4 ARG,INOUT,PRIV 2092,2094,2098,2100,2104,2106,2108 ,2115,2117 XT Dummy 1890 R(8) 8 scalar ARG,INOUT,PRIV 2043,2045,2047,2050,2053,2061,2117 YG4 Local 1995 R(4) 4 2 1 PTR 2029,2092,2098 YG8 Local 1996 R(8) 8 2 1 PTR 2031,2094,2100 YMAX Local 1998 R(8) 8 scalar 2036,2054 YMIN Local 1998 R(8) 8 scalar 2035,2054,2062,2070 YS Dummy 1890 R(8) 8 1 4 ARG,INOUT,PRIV 2092,2094,2098,2100,2115,2117 YT Dummy 1890 R(8) 8 scalar ARG,INOUT,PRIV 2050,2054,2062,2117 Page 52 Source Listing W3GFCL_R8 2014-11-12 21:37 w3gsrumd.f90 2132 !/ ------------------------------------------------------------------- / 2133 FUNCTION W3GFCD_R4(GSU, XT, YT, IS, JS, XS, YS, POLE, DEBUG) & 2134 RESULT(INGRID) 2135 !/ 2136 !/ +-----------------------------------+ 2137 !/ | WAVEWATCH III NOAA/NCEP | 2138 !/ | T. J. Campbell, NRL | 2139 !/ | FORTRAN 90 | 2140 !/ | Last update : 06-Dec-2010 | 2141 !/ +-----------------------------------+ 2142 !/ 2143 !/ 01-Dec-2010 : Origination. ( version 3.14 ) 2144 !/ 06-Dec-2010 : Remove restriction on longitude range. Change ICLO 2145 !/ to integer and remove JCLO. Implement support for 2146 !/ r4 and r8 source grids. ( version 3.14 ) 2147 !/ 2148 ! 1. Purpose : 2149 ! 2150 ! Find cell in grid, associated with the input grid-search-utility 2151 ! object (GSU), that encloses the target point (xt,yt), using direct 2152 ! grid search (i.e., no bucket search). 2153 ! Single precision interface. 2154 ! 2155 ! 2. Method : 2156 ! 2157 ! 3. Parameters : 2158 ! 2159 ! Return parameter 2160 ! ---------------------------------------------------------------- 2161 ! INGRID Log. O Logical flag indicating if target point lies 2162 ! within the source grid domain. 2163 ! ---------------------------------------------------------------- 2164 ! 2165 ! Parameter list 2166 ! ---------------------------------------------------------------- 2167 ! GSU Type I Grid-search-utility object. 2168 ! XT Real I X-coordinate of target point. 2169 ! YT Real I Y-coordinate of target point. 2170 ! IS,JS I.A. O (I,J) indices of vertices of enclosing grid cell. 2171 ! XS,YS R.A. O (X,Y) coord. of vertices of enclosing grid cell. 2172 ! POLE Log. O Optional logical flag to indicate whether or not 2173 ! the enclosing grid cell includes a pole. 2174 ! DEBUG Log. I Optional logical flag to turn on debug mode. 2175 ! Default is FALSE. 2176 ! ---------------------------------------------------------------- 2177 ! 2178 ! 4. Subroutines used : 2179 ! 2180 ! See module documentation. 2181 ! 2182 ! 5. Called by : 2183 ! 2184 ! 6. Error messages : 2185 ! 2186 ! - Check on previous creation of grid-search-utility object. 2187 ! 2188 ! 7. Remarks : Page 53 Source Listing W3GFCD_R4 2014-11-12 21:37 w3gsrumd.f90 2189 ! 2190 ! - The target point coordinates may be modified by this routine. 2191 ! - The target point longitude will be shifted to the source grid 2192 ! longitudinal range. 2193 ! - If enclosing cell includes a branch cut, then the coordinates of 2194 ! of the cell vertices AND the target point will be adjusted so 2195 ! that the branch cut is shifted 180 degrees. 2196 ! 2197 ! 8. Structure : 2198 ! 2199 ! ----------------------------------------------------------------- 2200 ! 1. Test input 2201 ! 2. Initialize search 2202 ! 3. Search for enclosing cell 2203 ! ----------------------------------------------------------------- 2204 ! 2205 ! 9. Switches : 2206 ! 2207 ! !/S Enable subroutine tracing. 2208 ! 2209 ! 10. Source code : 2210 ! 2211 !/ ------------------------------------------------------------------- / 2212 !/ 2213 !/ ------------------------------------------------------------------- / 2214 !/ Return parameter 2215 !/ 2216 LOGICAL :: INGRID 2217 !/ 2218 !/ ------------------------------------------------------------------- / 2219 !/ Parameter list 2220 !/ 2221 TYPE(T_GSU), INTENT(IN) :: GSU 2222 REAL(4), INTENT(INOUT) :: XT 2223 REAL(4), INTENT(INOUT) :: YT 2224 INTEGER, INTENT(INOUT) :: IS(4), JS(4) 2225 REAL(4), INTENT(INOUT) :: XS(4), YS(4) 2226 LOGICAL, INTENT(OUT),OPTIONAL :: POLE 2227 LOGICAL, INTENT(IN), OPTIONAL :: DEBUG 2228 !/ 2229 !/ ------------------------------------------------------------------- / 2230 !/ Local parameters 2231 !/ 2232 LOGICAL :: LDBG, LPLC 2233 INTEGER :: I, J, K, L, N, IB, JB 2234 LOGICAL :: IJG, LLG, LCLO, L360 2235 INTEGER :: ICLO, GKIND 2236 INTEGER :: NX, NY, NXC, NYC 2237 REAL(4), POINTER :: XG4(:,:), YG4(:,:) 2238 REAL(8), POINTER :: XG8(:,:), YG8(:,:) 2239 !/ 2240 ! 2241 ! -------------------------------------------------------------------- / 2242 ! 1. Test input 2243 ! 2244 IF ( .NOT.ASSOCIATED(GSU%PTR) ) THEN 2245 WRITE(*,'(/2A/)') 'W3GFCD_R4 ERROR -- ', & Page 54 Source Listing W3GFCD_R4 2014-11-12 21:37 w3gsrumd.f90 2246 'grid search utility object not created' 2247 CALL EXTCDE (1) 2248 END IF 2249 ! 2250 ! -------------------------------------------------------------------- / 2251 ! 2. Initialize search 2252 ! 2253 IF ( PRESENT(DEBUG) ) THEN 2254 LDBG = DEBUG 2255 ELSE 2256 LDBG = .FALSE. 2257 END IF 2258 ! 2259 ! Local pointers to grid search utility object data 2260 IJG = GSU%PTR%IJG 2261 LLG = GSU%PTR%LLG 2262 ICLO = GSU%PTR%ICLO 2263 LCLO = GSU%PTR%LCLO 2264 L360 = GSU%PTR%L360 2265 GKIND = GSU%PTR%GKIND 2266 NX = GSU%PTR%NX; NY = GSU%PTR%NY; 2267 IF ( GKIND.EQ.4 ) THEN 2268 XG4 => GSU%PTR%XG4; YG4 => GSU%PTR%YG4; 2269 ELSE 2270 XG8 => GSU%PTR%XG8; YG8 => GSU%PTR%YG8; 2271 END IF 2272 ! 2273 INGRID = .FALSE. 2274 ! 2275 ! Shift target to appropriate longitude range 2276 IF ( LLG ) THEN 2277 XT = MOD(XT,REAL(D360,4)) 2278 IF ( LCLO .OR. L360 ) THEN 2279 IF ( XT.LT.ZERO ) XT = XT + D360 2280 ELSE 2281 IF ( XT.GT.D180 ) XT = XT - D360 2282 END IF 2283 END IF 2284 IF ( LDBG ) WRITE(*,'(/A,2E14.6)') 'W3GFCD_R4 - TARGET POINT:',XT,YT 2285 2286 !-----number of cells 2287 SELECT CASE ( ICLO ) 2288 CASE ( ICLO_NONE ) 2289 NXC = NX-1; NYC = NY-1; 2290 CASE ( ICLO_SMPL ) 2291 NXC = NX; NYC = NY-1; 2292 CASE ( ICLO_TRPL ) 2293 NXC = NX; NYC = NY; 2294 END SELECT 2295 ! 2296 ! -------------------------------------------------------------------- / 2297 ! 3. Search for enclosing cell 2298 ! 2299 CELL_LOOP: DO I=1,NXC 2300 DO J=1,NYC 2301 !-------------create list of cell vertices 2302 IS(1) = I ; JS(1) = J ; Page 55 Source Listing W3GFCD_R4 2014-11-12 21:37 w3gsrumd.f90 2303 IS(2) = I+1; JS(2) = J ; 2304 IS(3) = I+1; JS(3) = J+1; 2305 IS(4) = I ; JS(4) = J+1; 2306 !-------------setup cell corner coordinates and adjust for periodicity 2307 DO L=1,4 2308 IF ( ICLO.NE.ICLO_NONE ) THEN 2309 IF ( IS(L) .LT. 1 ) IS(L) = IS(L) + NX 2310 IF ( IS(L) .GT. NX ) IS(L) = IS(L) - NX 2311 END IF 2312 IF ( ICLO.EQ.ICLO_TRPL ) THEN 2313 IF ( JS(L) .GT. NY ) THEN 2314 JS(L) = NY 2315 IS(L) = MOD(NX-IS(L)+1,NX) + 1 2316 END IF 2317 END IF 2318 IF ( IJG ) THEN 2319 IF ( GKIND.EQ.4 ) THEN 2320 XS(L) = XG4(IS(L),JS(L)); YS(L) = YG4(IS(L),JS(L)); 2321 ELSE 2322 XS(L) = XG8(IS(L),JS(L)); YS(L) = YG8(IS(L),JS(L)); 2323 END IF 2324 ELSE 2325 IF ( GKIND.EQ.4 ) THEN 2326 XS(L) = XG4(JS(L),IS(L)); YS(L) = YG4(JS(L),IS(L)); 2327 ELSE 2328 XS(L) = XG8(JS(L),IS(L)); YS(L) = YG8(JS(L),IS(L)); 2329 END IF 2330 END IF 2331 IF ( LLG ) THEN 2332 XS(L) = MOD(XS(L),REAL(D360,4)) 2333 IF ( LCLO .OR. L360 ) THEN 2334 IF ( XS(L).LT.ZERO ) XS(L) = XS(L) + D360 2335 ELSE 2336 IF ( XS(L).GT.D180 ) XS(L) = XS(L) - D360 2337 END IF 2338 END IF 2339 END DO !L 2340 IF ( LDBG ) & 2341 WRITE(*,'(A,4(/A,1I1,A,2I6,2E14.6))') & 2342 'W3GFCD_R4 - CHECK CELL:', & 2343 (' CORNER(',L,'):',IS(L),JS(L),XS(L),YS(L),L=1,4) 2344 !-------------check if point is enclosed in cell defined by xs(1:4) & ys(1:4) 2345 INGRID = W3CKCL(LLG,XT,YT,4,XS,YS,LPLC,LDBG) 2346 IF ( LDBG ) WRITE(*,'(A,1L2)')'W3GFCD_R4 - INGRID:',INGRID 2347 IF ( INGRID ) THEN 2348 !-----------------exit search 2349 IF ( LDBG ) & 2350 WRITE(*,'(A,4(2I6))') & 2351 'W3GFCD_R4 - ENCLOSING CELL:',(IS(L),JS(L),L=1,4) 2352 IF ( PRESENT(POLE) ) POLE = LPLC 2353 EXIT CELL_LOOP 2354 END IF !point in cell 2355 END DO !J 2356 END DO CELL_LOOP 2357 !/ 2358 !/ End of W3GFCD_R4--------------------------------------------------- / 2359 !/ Page 56 Source Listing W3GFCD_R4 2014-11-12 21:37 w3gsrumd.f90 2360 END FUNCTION W3GFCD_R4 ENTRY POINTS Name w3gsrumd_mp_w3gfcd_r4_ SYMBOL CROSS REFERENCE Name Object Declared Type Bytes Dimen Elements Attributes References ASSOCIATED Func 2244 scalar PRIV 2244 CELL_LOOP Label 2299 scalar 2353,2356 DEBUG Dummy 2133 L(4) 4 scalar ARG,IN,PRIV 2253,2254 GKIND Local 2235 I(4) 4 scalar 2265,2267,2319,2325 GSU Dummy 2133 T_GSU 8 scalar ARG,IN,PRIV 2244,2260,2261,2262,2263,2264,2265 ,2266,2268,2270 I Local 2233 I(4) 4 scalar 2299,2302,2303,2304,2305 IB Local 2233 I(4) 4 scalar ICLO Local 2235 I(4) 4 scalar 2262,2287,2308,2312 IJG Local 2234 L(4) 4 scalar 2260,2318 INGRID Local 2216 L(4) 4 scalar 2273,2345,2346,2347 IS Dummy 2133 I(4) 4 1 4 ARG,INOUT,PRIV 2302,2303,2304,2305,2309,2310,2315 ,2320,2322,2326,2328,2343,2351 J Local 2233 I(4) 4 scalar 2300,2302,2303,2304,2305 JB Local 2233 I(4) 4 scalar JS Dummy 2133 I(4) 4 1 4 ARG,INOUT,PRIV 2302,2303,2304,2305,2313,2314,2320 ,2322,2326,2328,2343,2351 K Local 2233 I(4) 4 scalar L Local 2233 I(4) 4 scalar 2307,2309,2310,2313,2314,2315,2320 ,2322,2326,2328,2332,2334,2336,234 3,2351 L360 Local 2234 L(4) 4 scalar 2264,2278,2333 LCLO Local 2234 L(4) 4 scalar 2263,2278,2333 LDBG Local 2232 L(4) 4 scalar 2254,2256,2284,2340,2345,2346,2349 LLG Local 2234 L(4) 4 scalar 2261,2276,2331,2345 LPLC Local 2232 L(4) 4 scalar 2345,2352 MOD Func 2277 scalar PRIV 2277,2315,2332 N Local 2233 I(4) 4 scalar NX Local 2236 I(4) 4 scalar 2266,2289,2291,2293,2309,2310,2315 NXC Local 2236 I(4) 4 scalar 2289,2291,2293,2299 NY Local 2236 I(4) 4 scalar 2266,2289,2291,2293,2313,2314 NYC Local 2236 I(4) 4 scalar 2289,2291,2293,2300 POLE Dummy 2133 L(4) 4 scalar ARG,OUT,PRIV 2352 PRESENT Func 2253 scalar PRIV 2253,2352 REAL Func 2277 scalar PRIV 2277,2332 W3GFCD_R4 Func 2133 L(4) 4 scalar PRIV XG4 Local 2237 R(4) 4 2 1 PTR 2268,2320,2326 XG8 Local 2238 R(8) 8 2 1 PTR 2270,2322,2328 XS Dummy 2133 R(4) 4 1 4 ARG,INOUT,PRIV 2320,2322,2326,2328,2332,2334,2336 ,2343,2345 XT Dummy 2133 R(4) 4 scalar ARG,INOUT,PRIV 2277,2279,2281,2284,2345 YG4 Local 2237 R(4) 4 2 1 PTR 2268,2320,2326 YG8 Local 2238 R(8) 8 2 1 PTR 2270,2322,2328 Page 57 Source Listing W3GFCD_R4 2014-11-12 21:37 Symbol Table w3gsrumd.f90 Name Object Declared Type Bytes Dimen Elements Attributes References YS Dummy 2133 R(4) 4 1 4 ARG,INOUT,PRIV 2320,2322,2326,2328,2343,2345 YT Dummy 2133 R(4) 4 scalar ARG,INOUT,PRIV 2284,2345 Page 58 Source Listing W3GFCD_R4 2014-11-12 21:37 w3gsrumd.f90 2361 !/ ------------------------------------------------------------------- / 2362 FUNCTION W3GFCD_R8(GSU, XT, YT, IS, JS, XS, YS, POLE, DEBUG) & 2363 RESULT(INGRID) 2364 !/ 2365 !/ +-----------------------------------+ 2366 !/ | WAVEWATCH III NOAA/NCEP | 2367 !/ | T. J. Campbell, NRL | 2368 !/ | FORTRAN 90 | 2369 !/ | Last update : 06-Dec-2010 | 2370 !/ +-----------------------------------+ 2371 !/ 2372 !/ 01-Dec-2010 : Origination. ( version 3.14 ) 2373 !/ 06-Dec-2010 : Remove restriction on longitude range. Change ICLO 2374 !/ to integer and remove JCLO. Implement support for 2375 !/ r4 and r8 source grids. ( version 3.14 ) 2376 !/ 2377 ! 1. Purpose : 2378 ! 2379 ! Find cell in grid, associated with the input grid-search-utility 2380 ! object (GSU), that encloses the target point (xt,yt), using direct 2381 ! grid search (i.e., no bucket search). 2382 ! Double precision interface. 2383 ! 2384 ! 2. Method : 2385 ! 2386 ! 3. Parameters : 2387 ! 2388 ! Return parameter 2389 ! ---------------------------------------------------------------- 2390 ! INGRID Log. O Logical flag indicating if target point lies 2391 ! within the source grid domain. 2392 ! ---------------------------------------------------------------- 2393 ! 2394 ! Parameter list 2395 ! ---------------------------------------------------------------- 2396 ! GSU Type I Grid-search-utility object. 2397 ! XT Real I X-coordinate of target point. 2398 ! YT Real I Y-coordinate of target point. 2399 ! IS,JS I.A. O (I,J) indices of vertices of enclosing grid cell. 2400 ! XS,YS R.A. O (X,Y) coord. of vertices of enclosing grid cell. 2401 ! POLE Log. O Optional logical flag to indicate whether or not 2402 ! the enclosing grid cell includes a pole. 2403 ! DEBUG Log. I Optional logical flag to turn on debug mode. 2404 ! Default is FALSE. 2405 ! ---------------------------------------------------------------- 2406 ! 2407 ! 4. Subroutines used : 2408 ! 2409 ! See module documentation. 2410 ! 2411 ! 5. Called by : 2412 ! 2413 ! 6. Error messages : 2414 ! 2415 ! - Check on previous creation of grid-search-utility object. 2416 ! 2417 ! 7. Remarks : Page 59 Source Listing W3GFCD_R8 2014-11-12 21:37 w3gsrumd.f90 2418 ! 2419 ! - The target point coordinates may be modified by this routine. 2420 ! - The target point longitude will be shifted to the source grid 2421 ! longitudinal range. 2422 ! - If enclosing cell includes a branch cut, then the coordinates of 2423 ! of the cell vertices AND the target point will be adjusted so 2424 ! that the branch cut is shifted 180 degrees. 2425 ! 2426 ! 8. Structure : 2427 ! 2428 ! ----------------------------------------------------------------- 2429 ! 1. Test input 2430 ! 2. Initialize search 2431 ! 3. Search for enclosing cell 2432 ! ----------------------------------------------------------------- 2433 ! 2434 ! 9. Switches : 2435 ! 2436 ! !/S Enable subroutine tracing. 2437 ! 2438 ! 10. Source code : 2439 ! 2440 !/ ------------------------------------------------------------------- / 2441 !/ 2442 !/ ------------------------------------------------------------------- / 2443 !/ Return parameter 2444 !/ 2445 LOGICAL :: INGRID 2446 !/ 2447 !/ ------------------------------------------------------------------- / 2448 !/ Parameter list 2449 !/ 2450 TYPE(T_GSU), INTENT(IN) :: GSU 2451 REAL(8), INTENT(INOUT) :: XT 2452 REAL(8), INTENT(INOUT) :: YT 2453 INTEGER, INTENT(INOUT) :: IS(4), JS(4) 2454 REAL(8), INTENT(INOUT) :: XS(4), YS(4) 2455 LOGICAL, INTENT(OUT),OPTIONAL :: POLE 2456 LOGICAL, INTENT(IN), OPTIONAL :: DEBUG 2457 !/ 2458 !/ ------------------------------------------------------------------- / 2459 !/ Local parameters 2460 !/ 2461 LOGICAL :: LDBG, LPLC 2462 INTEGER :: I, J, K, L, N, IB, JB 2463 LOGICAL :: IJG, LLG, LCLO, L360 2464 INTEGER :: ICLO, GKIND 2465 INTEGER :: NX, NY, NXC, NYC 2466 REAL(4), POINTER :: XG4(:,:), YG4(:,:) 2467 REAL(8), POINTER :: XG8(:,:), YG8(:,:) 2468 !/ 2469 ! 2470 ! -------------------------------------------------------------------- / 2471 ! 1. Test input 2472 ! 2473 IF ( .NOT.ASSOCIATED(GSU%PTR) ) THEN 2474 WRITE(*,'(/2A/)') 'W3GFCD_R8 ERROR -- ', & Page 60 Source Listing W3GFCD_R8 2014-11-12 21:37 w3gsrumd.f90 2475 'grid search utility object not created' 2476 CALL EXTCDE (1) 2477 END IF 2478 ! 2479 ! -------------------------------------------------------------------- / 2480 ! 2. Initialize search 2481 ! 2482 IF ( PRESENT(DEBUG) ) THEN 2483 LDBG = DEBUG 2484 ELSE 2485 LDBG = .FALSE. 2486 END IF 2487 ! 2488 ! Local pointers to grid search utility object data 2489 IJG = GSU%PTR%IJG 2490 LLG = GSU%PTR%LLG 2491 ICLO = GSU%PTR%ICLO 2492 LCLO = GSU%PTR%LCLO 2493 L360 = GSU%PTR%L360 2494 GKIND = GSU%PTR%GKIND 2495 NX = GSU%PTR%NX; NY = GSU%PTR%NY; 2496 IF ( GKIND.EQ.4 ) THEN 2497 XG4 => GSU%PTR%XG4; YG4 => GSU%PTR%YG4; 2498 ELSE 2499 XG8 => GSU%PTR%XG8; YG8 => GSU%PTR%YG8; 2500 END IF 2501 ! 2502 INGRID = .FALSE. 2503 ! 2504 ! Shift target to appropriate longitude range 2505 IF ( LLG ) THEN 2506 XT = MOD(XT,REAL(D360,8)) 2507 IF ( LCLO .OR. L360 ) THEN 2508 IF ( XT.LT.ZERO ) XT = XT + D360 2509 ELSE 2510 IF ( XT.GT.D180 ) XT = XT - D360 2511 END IF 2512 END IF 2513 IF ( LDBG ) WRITE(*,'(/A,2E14.6)') 'W3GFCD_R8 - TARGET POINT:',XT,YT 2514 2515 !-----number of cells 2516 SELECT CASE ( ICLO ) 2517 CASE ( ICLO_NONE ) 2518 NXC = NX-1; NYC = NY-1; 2519 CASE ( ICLO_SMPL ) 2520 NXC = NX; NYC = NY-1; 2521 CASE ( ICLO_TRPL ) 2522 NXC = NX; NYC = NY; 2523 END SELECT 2524 ! 2525 ! -------------------------------------------------------------------- / 2526 ! 3. Search for enclosing cell 2527 ! 2528 CELL_LOOP: DO I=1,NXC 2529 DO J=1,NYC 2530 !-------------create list of cell vertices 2531 IS(1) = I ; JS(1) = J ; Page 61 Source Listing W3GFCD_R8 2014-11-12 21:37 w3gsrumd.f90 2532 IS(2) = I+1; JS(2) = J ; 2533 IS(3) = I+1; JS(3) = J+1; 2534 IS(4) = I ; JS(4) = J+1; 2535 !-------------setup cell corner coordinates and adjust for periodicity 2536 DO L=1,4 2537 IF ( ICLO.NE.ICLO_NONE ) THEN 2538 IF ( IS(L) .LT. 1 ) IS(L) = IS(L) + NX 2539 IF ( IS(L) .GT. NX ) IS(L) = IS(L) - NX 2540 END IF 2541 IF ( ICLO.EQ.ICLO_TRPL ) THEN 2542 IF ( JS(L) .GT. NY ) THEN 2543 JS(L) = NY 2544 IS(L) = MOD(NX-IS(L)+1,NX) + 1 2545 END IF 2546 END IF 2547 IF ( IJG ) THEN 2548 IF ( GKIND.EQ.4 ) THEN 2549 XS(L) = XG4(IS(L),JS(L)); YS(L) = YG4(IS(L),JS(L)); 2550 ELSE 2551 XS(L) = XG8(IS(L),JS(L)); YS(L) = YG8(IS(L),JS(L)); 2552 END IF 2553 ELSE 2554 IF ( GKIND.EQ.4 ) THEN 2555 XS(L) = XG4(JS(L),IS(L)); YS(L) = YG4(JS(L),IS(L)); 2556 ELSE 2557 XS(L) = XG8(JS(L),IS(L)); YS(L) = YG8(JS(L),IS(L)); 2558 END IF 2559 END IF 2560 IF ( LLG ) THEN 2561 XS(L) = MOD(XS(L),REAL(D360,8)) 2562 IF ( LCLO .OR. L360 ) THEN 2563 IF ( XS(L).LT.ZERO ) XS(L) = XS(L) + D360 2564 ELSE 2565 IF ( XS(L).GT.D180 ) XS(L) = XS(L) - D360 2566 END IF 2567 END IF 2568 END DO !L 2569 IF ( LDBG ) & 2570 WRITE(*,'(A,4(/A,1I1,A,2I6,2E14.6))') & 2571 'W3GFCD_R8 - CHECK CELL:', & 2572 (' CORNER(',L,'):',IS(L),JS(L),XS(L),YS(L),L=1,4) 2573 !-------------check if point is enclosed in cell defined by xs(1:4) & ys(1:4) 2574 INGRID = W3CKCL(LLG,XT,YT,4,XS,YS,LPLC,LDBG) 2575 IF ( LDBG ) WRITE(*,'(A,1L2)')'W3GFCD_R8 - INGRID:',INGRID 2576 IF ( INGRID ) THEN 2577 !-----------------exit search 2578 IF ( LDBG ) & 2579 WRITE(*,'(A,4(2I6))') & 2580 'W3GFCD_R8 - ENCLOSING CELL:',(IS(L),JS(L),L=1,4) 2581 IF ( PRESENT(POLE) ) POLE = LPLC 2582 EXIT CELL_LOOP 2583 END IF !point in cell 2584 END DO !J 2585 END DO CELL_LOOP 2586 !/ 2587 !/ End of W3GFCD_R8--------------------------------------------------- / 2588 !/ Page 62 Source Listing W3GFCD_R8 2014-11-12 21:37 w3gsrumd.f90 2589 END FUNCTION W3GFCD_R8 ENTRY POINTS Name w3gsrumd_mp_w3gfcd_r8_ SYMBOL CROSS REFERENCE Name Object Declared Type Bytes Dimen Elements Attributes References ASSOCIATED Func 2473 scalar PRIV 2473 CELL_LOOP Label 2528 scalar 2582,2585 DEBUG Dummy 2362 L(4) 4 scalar ARG,IN,PRIV 2482,2483 GKIND Local 2464 I(4) 4 scalar 2494,2496,2548,2554 GSU Dummy 2362 T_GSU 8 scalar ARG,IN,PRIV 2473,2489,2490,2491,2492,2493,2494 ,2495,2497,2499 I Local 2462 I(4) 4 scalar 2528,2531,2532,2533,2534 IB Local 2462 I(4) 4 scalar ICLO Local 2464 I(4) 4 scalar 2491,2516,2537,2541 IJG Local 2463 L(4) 4 scalar 2489,2547 INGRID Local 2445 L(4) 4 scalar 2502,2574,2575,2576 IS Dummy 2362 I(4) 4 1 4 ARG,INOUT,PRIV 2531,2532,2533,2534,2538,2539,2544 ,2549,2551,2555,2557,2572,2580 J Local 2462 I(4) 4 scalar 2529,2531,2532,2533,2534 JB Local 2462 I(4) 4 scalar JS Dummy 2362 I(4) 4 1 4 ARG,INOUT,PRIV 2531,2532,2533,2534,2542,2543,2549 ,2551,2555,2557,2572,2580 K Local 2462 I(4) 4 scalar L Local 2462 I(4) 4 scalar 2536,2538,2539,2542,2543,2544,2549 ,2551,2555,2557,2561,2563,2565,257 2,2580 L360 Local 2463 L(4) 4 scalar 2493,2507,2562 LCLO Local 2463 L(4) 4 scalar 2492,2507,2562 LDBG Local 2461 L(4) 4 scalar 2483,2485,2513,2569,2574,2575,2578 LLG Local 2463 L(4) 4 scalar 2490,2505,2560,2574 LPLC Local 2461 L(4) 4 scalar 2574,2581 MOD Func 2506 scalar PRIV 2506,2544,2561 N Local 2462 I(4) 4 scalar NX Local 2465 I(4) 4 scalar 2495,2518,2520,2522,2538,2539,2544 NXC Local 2465 I(4) 4 scalar 2518,2520,2522,2528 NY Local 2465 I(4) 4 scalar 2495,2518,2520,2522,2542,2543 NYC Local 2465 I(4) 4 scalar 2518,2520,2522,2529 POLE Dummy 2362 L(4) 4 scalar ARG,OUT,PRIV 2581 PRESENT Func 2482 scalar PRIV 2482,2581 REAL Func 2506 scalar PRIV 2506,2561 W3GFCD_R8 Func 2362 L(4) 4 scalar PRIV XG4 Local 2466 R(4) 4 2 1 PTR 2497,2549,2555 XG8 Local 2467 R(8) 8 2 1 PTR 2499,2551,2557 XS Dummy 2362 R(8) 8 1 4 ARG,INOUT,PRIV 2549,2551,2555,2557,2561,2563,2565 ,2572,2574 XT Dummy 2362 R(8) 8 scalar ARG,INOUT,PRIV 2506,2508,2510,2513,2574 YG4 Local 2466 R(4) 4 2 1 PTR 2497,2549,2555 YG8 Local 2467 R(8) 8 2 1 PTR 2499,2551,2557 Page 63 Source Listing W3GFCD_R8 2014-11-12 21:37 Symbol Table w3gsrumd.f90 Name Object Declared Type Bytes Dimen Elements Attributes References YS Dummy 2362 R(8) 8 1 4 ARG,INOUT,PRIV 2549,2551,2555,2557,2572,2574 YT Dummy 2362 R(8) 8 scalar ARG,INOUT,PRIV 2513,2574 Page 64 Source Listing W3GFCD_R8 2014-11-12 21:37 w3gsrumd.f90 2590 !/ ------------------------------------------------------------------- / 2591 FUNCTION W3GFPT_R4(GSU, XTIN, YTIN, IX, IY, DEBUG) & 2592 RESULT(INGRID) 2593 !/ 2594 !/ +-----------------------------------+ 2595 !/ | WAVEWATCH III NOAA/NCEP | 2596 !/ | T. J. Campbell, NRL | 2597 !/ | FORTRAN 90 | 2598 !/ | Last update : 01-Dec-2010 | 2599 !/ +-----------------------------------+ 2600 !/ 2601 !/ 30-Oct-2009 : Origination. ( version 3.14 ) 2602 !/ 12-Nov-2010 : Implement r4 & r8 interfaces. ( version 3.14 ) 2603 !/ 01-Dec-2010 : Some cleanup. ( version 3.14 ) 2604 !/ 2605 ! 1. Purpose : 2606 ! 2607 ! Find point in grid, associated with the input grid-search-utility 2608 ! object (GSU), that is closest to the target point (xtin,ytin). 2609 ! Single precision interface. 2610 ! 2611 ! 2. Method : 2612 ! 2613 ! 3. Parameters : 2614 ! 2615 ! Return parameter 2616 ! ---------------------------------------------------------------- 2617 ! INGRID Log. O Logical flag indicating if target point lies 2618 ! within the source grid domain. 2619 ! ---------------------------------------------------------------- 2620 ! 2621 ! Parameter list 2622 ! ---------------------------------------------------------------- 2623 ! GSU Type I Grid-search-utility object. 2624 ! XTIN Real I X-coordinate of target point. 2625 ! YTIN Real I Y-coordinate of target point. 2626 ! IX,JX I.A. O (I,J) indices of nearest grid point. 2627 ! DEBUG Log. I Optional logical flag to turn on debug mode. 2628 ! Default is FALSE. 2629 ! ---------------------------------------------------------------- 2630 ! 2631 ! 4. Subroutines used : 2632 ! 2633 ! See module documentation. 2634 ! 2635 ! 5. Called by : 2636 ! 2637 ! 6. Error messages : 2638 ! 2639 ! - Check on previous initialization of grid search utility object. 2640 ! 2641 ! 7. Remarks : 2642 ! 2643 ! 8. Structure : 2644 ! 2645 ! ----------------------------------------------------------------- 2646 ! 1. Test input Page 65 Source Listing W3GFPT_R4 2014-11-12 21:37 w3gsrumd.f90 2647 ! 2. Initialize search 2648 ! 3. Find enclosing cell and compute closest point 2649 ! ----------------------------------------------------------------- 2650 ! 2651 ! 9. Switches : 2652 ! 2653 ! !/S Enable subroutine tracing. 2654 ! 2655 ! 10. Source code : 2656 ! 2657 !/ ------------------------------------------------------------------- / 2658 !/ 2659 !/ ------------------------------------------------------------------- / 2660 !/ Return parameter 2661 !/ 2662 LOGICAL :: INGRID 2663 !/ 2664 !/ ------------------------------------------------------------------- / 2665 !/ Parameter list 2666 !/ 2667 TYPE(T_GSU), INTENT(IN) :: GSU 2668 REAL(4), INTENT(IN) :: XTIN 2669 REAL(4), INTENT(IN) :: YTIN 2670 INTEGER, INTENT(OUT) :: IX, IY 2671 LOGICAL, INTENT(IN), OPTIONAL :: DEBUG 2672 !/ 2673 !/ ------------------------------------------------------------------- / 2674 !/ Local parameters 2675 !/ 2676 REAL(8), PARAMETER :: BIG = 1D16 2677 LOGICAL :: LDBG 2678 INTEGER :: I, J, K, L 2679 REAL(4) :: XT, YT 2680 INTEGER :: IS(4), JS(4) 2681 REAL(4) :: XS(4), YS(4) 2682 REAL(4) :: DD, DMIN 2683 LOGICAL :: IJG, LLG 2684 !/ 2685 ! 2686 ! -------------------------------------------------------------------- / 2687 ! 1. Test input 2688 ! 2689 IF ( .NOT.ASSOCIATED(GSU%PTR) ) THEN 2690 WRITE(*,'(/2A/)') 'W3GFPT_R4 ERROR -- ', & 2691 'grid search utility object not created' 2692 CALL EXTCDE (1) 2693 END IF 2694 ! 2695 ! -------------------------------------------------------------------- / 2696 ! 2. Initialize search 2697 ! 2698 IF ( PRESENT(DEBUG) ) THEN 2699 LDBG = DEBUG 2700 ELSE 2701 LDBG = .FALSE. 2702 END IF 2703 ! Page 66 Source Listing W3GFPT_R4 2014-11-12 21:37 w3gsrumd.f90 2704 ! Local pointers to grid search utility object data 2705 IJG = GSU%PTR%IJG 2706 LLG = GSU%PTR%LLG 2707 ! 2708 INGRID = .FALSE. 2709 ! 2710 XT = XTIN; YT = YTIN; 2711 IF ( LDBG ) WRITE(*,'(/A,2E14.6)') 'W3GFPT_R4 - TARGET POINT:',XT,YT 2712 ! 2713 ! -------------------------------------------------------------------- / 2714 ! 3. Find enclosing cell and compute closest point 2715 ! 2716 INGRID = W3GFCL(GSU,XT,YT,IS,JS,XS,YS,DEBUG=LDBG) 2717 IF ( INGRID ) THEN 2718 DMIN = BIG 2719 DO L=1,4 2720 DD = W3DIST(LLG,XT,YT,XS(L),YS(L)) 2721 IF ( DD .LT. DMIN ) THEN 2722 DMIN = DD; IX = IS(L); IY = JS(L); 2723 END IF 2724 END DO !L 2725 ELSE 2726 IX = 0; IY = 0; 2727 END IF 2728 !/ 2729 !/ End of W3GFPT_R4 -------------------------------------------------- / 2730 !/ 2731 END FUNCTION W3GFPT_R4 Page 67 Source Listing W3GFPT_R4 2014-11-12 21:37 Entry Points w3gsrumd.f90 ENTRY POINTS Name w3gsrumd_mp_w3gfpt_r4_ SYMBOL CROSS REFERENCE Name Object Declared Type Bytes Dimen Elements Attributes References ASSOCIATED Func 2689 scalar PRIV 2689 BIG Param 2676 R(8) 8 scalar 2718 DD Local 2682 R(4) 4 scalar 2720,2721,2722 DEBUG Dummy 2591 L(4) 4 scalar ARG,IN,PRIV 2698,2699 DMIN Local 2682 R(4) 4 scalar 2718,2721,2722 GSU Dummy 2591 T_GSU 8 scalar ARG,IN,PRIV 2689,2705,2706,2716 I Local 2678 I(4) 4 scalar IJG Local 2683 L(4) 4 scalar 2705 INGRID Local 2662 L(4) 4 scalar 2708,2716,2717 IS Local 2680 I(4) 4 1 4 2716,2722 IX Dummy 2591 I(4) 4 scalar ARG,OUT,PRIV 2722,2726 IY Dummy 2591 I(4) 4 scalar ARG,OUT,PRIV 2722,2726 J Local 2678 I(4) 4 scalar JS Local 2680 I(4) 4 1 4 2716,2722 K Local 2678 I(4) 4 scalar L Local 2678 I(4) 4 scalar 2719,2720,2722 LDBG Local 2677 L(4) 4 scalar 2699,2701,2711,2716 LLG Local 2683 L(4) 4 scalar 2706,2720 PRESENT Func 2698 scalar PRIV 2698 W3DIST Local 2720 scalar 196,2720,2862,3354,3416,3469,3726, 3788,3841 W3GFCL Local 2716 scalar 191,2716,2858,2993,3127,3337,3709 W3GFPT_R4 Func 2591 L(4) 4 scalar PRIV XS Local 2681 R(4) 4 1 4 2716,2720 XT Local 2679 R(4) 4 scalar 2710,2711,2716,2720 XTIN Dummy 2591 R(4) 4 scalar ARG,IN,PRIV 2710 YS Local 2681 R(4) 4 1 4 2716,2720 YT Local 2679 R(4) 4 scalar 2710,2711,2716,2720 YTIN Dummy 2591 R(4) 4 scalar ARG,IN,PRIV 2710 Page 68 Source Listing W3GFPT_R4 2014-11-12 21:37 w3gsrumd.f90 2732 !/ ------------------------------------------------------------------- / 2733 FUNCTION W3GFPT_R8(GSU, XTIN, YTIN, IX, IY, DEBUG) & 2734 RESULT(INGRID) 2735 !/ 2736 !/ +-----------------------------------+ 2737 !/ | WAVEWATCH III NOAA/NCEP | 2738 !/ | T. J. Campbell, NRL | 2739 !/ | FORTRAN 90 | 2740 !/ | Last update : 01-Dec-2010 | 2741 !/ +-----------------------------------+ 2742 !/ 2743 !/ 30-Oct-2009 : Origination. ( version 3.14 ) 2744 !/ 12-Nov-2010 : Implement r4 & r8 interfaces. ( version 3.14 ) 2745 !/ 01-Dec-2010 : Some cleanup. ( version 3.14 ) 2746 !/ 2747 ! 1. Purpose : 2748 ! 2749 ! Find point in grid, associated with the input grid-search-utility 2750 ! object (GSU), that is closest to the target point (xtin,ytin). 2751 ! Double precision interface. 2752 ! 2753 ! 2. Method : 2754 ! 2755 ! 3. Parameters : 2756 ! 2757 ! Return parameter 2758 ! ---------------------------------------------------------------- 2759 ! INGRID Log. O Logical flag indicating if target point lies 2760 ! within the source grid domain. 2761 ! ---------------------------------------------------------------- 2762 ! 2763 ! Parameter list 2764 ! ---------------------------------------------------------------- 2765 ! GSU Type I Grid-search-utility object. 2766 ! XTIN Real I X-coordinate of target point. 2767 ! YTIN Real I Y-coordinate of target point. 2768 ! IX,JX I.A. O (I,J) indices of nearest grid point. 2769 ! DEBUG Log. I Optional logical flag to turn on debug mode. 2770 ! Default is FALSE. 2771 ! ---------------------------------------------------------------- 2772 ! 2773 ! 4. Subroutines used : 2774 ! 2775 ! See module documentation. 2776 ! 2777 ! 5. Called by : 2778 ! 2779 ! 6. Error messages : 2780 ! 2781 ! - Check on previous initialization of grid search utility object. 2782 ! 2783 ! 7. Remarks : 2784 ! 2785 ! 8. Structure : 2786 ! 2787 ! ----------------------------------------------------------------- 2788 ! 1. Test input Page 69 Source Listing W3GFPT_R8 2014-11-12 21:37 w3gsrumd.f90 2789 ! 2. Initialize search 2790 ! 3. Find enclosing cell and compute closest point 2791 ! ----------------------------------------------------------------- 2792 ! 2793 ! 9. Switches : 2794 ! 2795 ! !/S Enable subroutine tracing. 2796 ! 2797 ! 10. Source code : 2798 ! 2799 !/ ------------------------------------------------------------------- / 2800 !/ 2801 !/ ------------------------------------------------------------------- / 2802 !/ Return parameter 2803 !/ 2804 LOGICAL :: INGRID 2805 !/ 2806 !/ ------------------------------------------------------------------- / 2807 !/ Parameter list 2808 !/ 2809 TYPE(T_GSU), INTENT(IN) :: GSU 2810 REAL(8), INTENT(IN) :: XTIN 2811 REAL(8), INTENT(IN) :: YTIN 2812 INTEGER, INTENT(OUT) :: IX, IY 2813 LOGICAL, INTENT(IN), OPTIONAL :: DEBUG 2814 !/ 2815 !/ ------------------------------------------------------------------- / 2816 !/ Local parameters 2817 !/ 2818 REAL(8), PARAMETER :: BIG = 1D16 2819 LOGICAL :: LDBG 2820 INTEGER :: I, J, K, L 2821 REAL(8) :: XT, YT 2822 INTEGER :: IS(4), JS(4) 2823 REAL(8) :: XS(4), YS(4) 2824 REAL(8) :: DD, DMIN 2825 LOGICAL :: IJG, LLG 2826 !/ 2827 ! 2828 ! -------------------------------------------------------------------- / 2829 ! 1. Test input 2830 ! 2831 IF ( .NOT.ASSOCIATED(GSU%PTR) ) THEN 2832 WRITE(*,'(/2A/)') 'W3GFPT_R8 ERROR -- ', & 2833 'grid search utility object not created' 2834 CALL EXTCDE (1) 2835 END IF 2836 ! 2837 ! -------------------------------------------------------------------- / 2838 ! 2. Initialize search 2839 ! 2840 IF ( PRESENT(DEBUG) ) THEN 2841 LDBG = DEBUG 2842 ELSE 2843 LDBG = .FALSE. 2844 END IF 2845 ! Page 70 Source Listing W3GFPT_R8 2014-11-12 21:37 w3gsrumd.f90 2846 ! Local pointers to grid search utility object data 2847 IJG = GSU%PTR%IJG 2848 LLG = GSU%PTR%LLG 2849 ! 2850 INGRID = .FALSE. 2851 ! 2852 XT = XTIN; YT = YTIN; 2853 IF ( LDBG ) WRITE(*,'(/A,2E14.6)') 'W3GFPT_R8 - TARGET POINT:',XT,YT 2854 ! 2855 ! -------------------------------------------------------------------- / 2856 ! 3. Find enclosing cell and compute closest point 2857 ! 2858 INGRID = W3GFCL(GSU,XT,YT,IS,JS,XS,YS,DEBUG=LDBG) 2859 IF ( INGRID ) THEN 2860 DMIN = BIG 2861 DO L=1,4 2862 DD = W3DIST(LLG,XT,YT,XS(L),YS(L)) 2863 IF ( DD .LT. DMIN ) THEN 2864 DMIN = DD; IX = IS(L); IY = JS(L); 2865 END IF 2866 END DO !L 2867 ELSE 2868 IX = 0; IY = 0; 2869 END IF 2870 !/ 2871 !/ End of W3GFPT_R8 -------------------------------------------------- / 2872 !/ 2873 END FUNCTION W3GFPT_R8 Page 71 Source Listing W3GFPT_R8 2014-11-12 21:37 Entry Points w3gsrumd.f90 ENTRY POINTS Name w3gsrumd_mp_w3gfpt_r8_ SYMBOL CROSS REFERENCE Name Object Declared Type Bytes Dimen Elements Attributes References ASSOCIATED Func 2831 scalar PRIV 2831 BIG Param 2818 R(8) 8 scalar 2860 DD Local 2824 R(8) 8 scalar 2862,2863,2864 DEBUG Dummy 2733 L(4) 4 scalar ARG,IN,PRIV 2840,2841 DMIN Local 2824 R(8) 8 scalar 2860,2863,2864 GSU Dummy 2733 T_GSU 8 scalar ARG,IN,PRIV 2831,2847,2848,2858 I Local 2820 I(4) 4 scalar IJG Local 2825 L(4) 4 scalar 2847 INGRID Local 2804 L(4) 4 scalar 2850,2858,2859 IS Local 2822 I(4) 4 1 4 2858,2864 IX Dummy 2733 I(4) 4 scalar ARG,OUT,PRIV 2864,2868 IY Dummy 2733 I(4) 4 scalar ARG,OUT,PRIV 2864,2868 J Local 2820 I(4) 4 scalar JS Local 2822 I(4) 4 1 4 2858,2864 K Local 2820 I(4) 4 scalar L Local 2820 I(4) 4 scalar 2861,2862,2864 LDBG Local 2819 L(4) 4 scalar 2841,2843,2853,2858 LLG Local 2825 L(4) 4 scalar 2848,2862 PRESENT Func 2840 scalar PRIV 2840 W3GFPT_R8 Func 2733 L(4) 4 scalar PRIV XS Local 2823 R(8) 8 1 4 2858,2862 XT Local 2821 R(8) 8 scalar 2852,2853,2858,2862 XTIN Dummy 2733 R(8) 8 scalar ARG,IN,PRIV 2852 YS Local 2823 R(8) 8 1 4 2858,2862 YT Local 2821 R(8) 8 scalar 2852,2853,2858,2862 YTIN Dummy 2733 R(8) 8 scalar ARG,IN,PRIV 2852 Page 72 Source Listing W3GFPT_R8 2014-11-12 21:37 w3gsrumd.f90 2874 !/ ------------------------------------------------------------------- / 2875 FUNCTION W3GFIJ_R4(GSU, XTIN, YTIN, IX, JX, DEBUG) RESULT(INGRID) 2876 !/ 2877 !/ +-----------------------------------+ 2878 !/ | WAVEWATCH III NOAA/NCEP | 2879 !/ | T. J. Campbell, NRL | 2880 !/ | FORTRAN 90 | 2881 !/ | Last update : 01-Dec-2010 | 2882 !/ +-----------------------------------+ 2883 !/ 2884 !/ 12-Nov-2010 : Origination. ( version 3.14 ) 2885 !/ 01-Dec-2010 : Some cleanup. ( version 3.14 ) 2886 !/ 2887 ! 1. Purpose : 2888 ! 2889 ! Compute coordinates ( ix, jx ) of target point ( xtin, ytin ) in 2890 ! source grid index space from source grid associated with the input 2891 ! grid search utility object (GSU). 2892 ! Single precision interface. 2893 ! 2894 ! 2. Method : 2895 ! 2896 ! 3. Parameters : 2897 ! 2898 ! Return parameter 2899 ! ---------------------------------------------------------------- 2900 ! INGRID Log. O Logical flag indicating if target point lies 2901 ! within the source grid domain. 2902 ! ---------------------------------------------------------------- 2903 ! 2904 ! Parameter list 2905 ! ---------------------------------------------------------------- 2906 ! GSU Type I Grid-search-utility object. 2907 ! XTIN Real I X-coordinate of target point. 2908 ! YTIN Real I Y-coordinate of target point. 2909 ! IX Real O X-coordinate of target point in source grid 2910 ! index space. 2911 ! JX Real O Y-coordinate of target point in source grid 2912 ! index space. 2913 ! DEBUG Log. I Optional logical flag to turn on debug mode. 2914 ! Default is FALSE. 2915 ! ---------------------------------------------------------------- 2916 ! 2917 ! 4. Subroutines used : 2918 ! 2919 ! See module documentation. 2920 ! 2921 ! 5. Called by : 2922 ! 2923 ! 6. Error messages : 2924 ! 2925 ! - Check on previous initialization of grid search utility object. 2926 ! - Check on appropriate input of optional arguments. 2927 ! 2928 ! 7. Remarks : 2929 ! 2930 ! 8. Structure : Page 73 Source Listing W3GFIJ_R4 2014-11-12 21:37 w3gsrumd.f90 2931 ! 2932 ! ----------------------------------------------------------------- 2933 ! 1. Test input 2934 ! 2. Initialize search 2935 ! 3. Find enclosing cell and compute relative coordinates 2936 ! ----------------------------------------------------------------- 2937 ! 2938 ! 9. Switches : 2939 ! 2940 ! !/S Enable subroutine tracing. 2941 ! 2942 ! 10. Source code : 2943 ! 2944 !/ ------------------------------------------------------------------- / 2945 !/ 2946 !/ ------------------------------------------------------------------- / 2947 !/ Return parameter 2948 !/ 2949 LOGICAL :: INGRID 2950 !/ 2951 !/ ------------------------------------------------------------------- / 2952 !/ Parameter list 2953 !/ 2954 TYPE(T_GSU), INTENT(IN) :: GSU 2955 REAL(4), INTENT(IN) :: XTIN 2956 REAL(4), INTENT(IN) :: YTIN 2957 REAL(4), INTENT(OUT) :: IX 2958 REAL(4), INTENT(OUT) :: JX 2959 LOGICAL, INTENT(IN) , OPTIONAL :: DEBUG 2960 !/ 2961 !/ ------------------------------------------------------------------- / 2962 !/ Local parameters 2963 !/ 2964 LOGICAL :: LDBG, POLE 2965 INTEGER :: IS(4), JS(4) 2966 REAL(4) :: XT, YT, XS(4), YS(4) 2967 !/ 2968 ! 2969 ! -------------------------------------------------------------------- / 2970 ! 1. Test input 2971 ! 2972 IF ( .NOT.ASSOCIATED(GSU%PTR) ) THEN 2973 WRITE(*,'(/2A/)') 'W3GFIJ_R4 ERROR -- ', & 2974 'grid search utility object not created' 2975 CALL EXTCDE (1) 2976 END IF 2977 ! 2978 ! -------------------------------------------------------------------- / 2979 ! 2. Initialize search 2980 ! 2981 IF ( PRESENT(DEBUG) ) THEN 2982 LDBG = DEBUG 2983 ELSE 2984 LDBG = .FALSE. 2985 END IF 2986 ! 2987 XT = XTIN; YT = YTIN; Page 74 Source Listing W3GFIJ_R4 2014-11-12 21:37 w3gsrumd.f90 2988 IF ( LDBG ) WRITE(*,'(/A,2E14.6)') 'W3GFIJ_R4 - TARGET POINT:',XT,YT 2989 ! 2990 ! -------------------------------------------------------------------- / 2991 ! 3. Find enclosing cell and compute point location 2992 ! 2993 INGRID = W3GFCL(GSU,XT,YT,IS,JS,XS,YS,POLE=POLE,DEBUG=LDBG) 2994 IF ( .NOT. INGRID ) RETURN 2995 ! 2996 IF ( .NOT.POLE ) THEN 2997 !---------non-pole cell: compute relative location 2998 CALL W3RMBL(XT,YT,XS,YS,IX=IX,JX=JX,DEBUG=LDBG) 2999 IX = REAL(IS(1),4)+IX; JX = REAL(JS(1),4)+JX; 3000 ELSE 3001 !---------pole cell: set to center of cell 3002 IX = REAL(IS(1),4)+HALF; JX = REAL(JS(1),4)+HALF; 3003 ENDIF 3004 !/ 3005 !/ End of W3GFIJ_R4 -------------------------------------------------- / 3006 !/ 3007 END FUNCTION W3GFIJ_R4 ENTRY POINTS Name w3gsrumd_mp_w3gfij_r4_ SYMBOL CROSS REFERENCE Name Object Declared Type Bytes Dimen Elements Attributes References ASSOCIATED Func 2972 scalar PRIV 2972 DEBUG Dummy 2875 L(4) 4 scalar ARG,IN,PRIV 2981,2982 GSU Dummy 2875 T_GSU 8 scalar ARG,IN,PRIV 2972,2993 HALF Param 3002 R(8) 8 scalar 3002,3136,4309,4310,4501,4502 INGRID Local 2949 L(4) 4 scalar 2993,2994 IS Local 2965 I(4) 4 1 4 2993,2999,3002 IX Dummy 2875 R(4) 4 scalar ARG,OUT,PRIV 2998,2999,3002 JS Local 2965 I(4) 4 1 4 2993,2999,3002 JX Dummy 2875 R(4) 4 scalar ARG,OUT,PRIV 2998,2999,3002 LDBG Local 2964 L(4) 4 scalar 2982,2984,2988,2993,2998 POLE Local 2964 L(4) 4 scalar 2993,2996 PRESENT Func 2981 scalar PRIV 2981 REAL Func 2999 scalar PRIV 2999,3002 W3GFIJ_R4 Func 2875 L(4) 4 scalar PRIV W3RMBL Local 2998 scalar 2998,3132,3342,3714 XS Local 2966 R(4) 4 1 4 2993,2998 XT Local 2966 R(4) 4 scalar 2987,2988,2993,2998 XTIN Dummy 2875 R(4) 4 scalar ARG,IN,PRIV 2987 YS Local 2966 R(4) 4 1 4 2993,2998 YT Local 2966 R(4) 4 scalar 2987,2988,2993,2998 YTIN Dummy 2875 R(4) 4 scalar ARG,IN,PRIV 2987 Page 75 Source Listing W3GFIJ_R4 2014-11-12 21:37 w3gsrumd.f90 3008 !/ ------------------------------------------------------------------- / 3009 FUNCTION W3GFIJ_R8(GSU, XTIN, YTIN, IX, JX, DEBUG) RESULT(INGRID) 3010 !/ 3011 !/ +-----------------------------------+ 3012 !/ | WAVEWATCH III NOAA/NCEP | 3013 !/ | T. J. Campbell, NRL | 3014 !/ | FORTRAN 90 | 3015 !/ | Last update : 01-Dec-2010 | 3016 !/ +-----------------------------------+ 3017 !/ 3018 !/ 12-Nov-2010 : Origination. ( version 3.14 ) 3019 !/ 01-Dec-2010 : Some cleanup. ( version 3.14 ) 3020 !/ 3021 ! 1. Purpose : 3022 ! 3023 ! Compute coordinates ( ix, jx ) of target point ( xtin, ytin ) in 3024 ! source grid index space from source grid associated with the input 3025 ! grid search utility object (GSU). 3026 ! Double precision interface. 3027 ! 3028 ! 2. Method : 3029 ! 3030 ! 3. Parameters : 3031 ! 3032 ! Return parameter 3033 ! ---------------------------------------------------------------- 3034 ! INGRID Log. O Logical flag indicating if target point lies 3035 ! within the source grid domain. 3036 ! ---------------------------------------------------------------- 3037 ! 3038 ! Parameter list 3039 ! ---------------------------------------------------------------- 3040 ! GSU Type I Grid-search-utility object. 3041 ! XTIN Real I X-coordinate of target point. 3042 ! YTIN Real I Y-coordinate of target point. 3043 ! IX Real O X-coordinate of target point in source grid 3044 ! index space. 3045 ! JX Real O Y-coordinate of target point in source grid 3046 ! index space. 3047 ! DEBUG Log. I Optional logical flag to turn on debug mode. 3048 ! Default is FALSE. 3049 ! ---------------------------------------------------------------- 3050 ! 3051 ! 4. Subroutines used : 3052 ! 3053 ! See module documentation. 3054 ! 3055 ! 5. Called by : 3056 ! 3057 ! 6. Error messages : 3058 ! 3059 ! - Check on previous initialization of grid search utility object. 3060 ! - Check on appropriate input of optional arguments. 3061 ! 3062 ! 7. Remarks : 3063 ! 3064 ! 8. Structure : Page 76 Source Listing W3GFIJ_R8 2014-11-12 21:37 w3gsrumd.f90 3065 ! 3066 ! ----------------------------------------------------------------- 3067 ! 1. Test input 3068 ! 2. Initialize search 3069 ! 3. Find enclosing cell and compute relative coordinates 3070 ! ----------------------------------------------------------------- 3071 ! 3072 ! 9. Switches : 3073 ! 3074 ! !/S Enable subroutine tracing. 3075 ! 3076 ! 10. Source code : 3077 ! 3078 !/ ------------------------------------------------------------------- / 3079 !/ 3080 !/ ------------------------------------------------------------------- / 3081 !/ Return parameter 3082 !/ 3083 LOGICAL :: INGRID 3084 !/ 3085 !/ ------------------------------------------------------------------- / 3086 !/ Parameter list 3087 !/ 3088 TYPE(T_GSU), INTENT(IN) :: GSU 3089 REAL(8), INTENT(IN) :: XTIN 3090 REAL(8), INTENT(IN) :: YTIN 3091 REAL(8), INTENT(OUT) :: IX 3092 REAL(8), INTENT(OUT) :: JX 3093 LOGICAL, INTENT(IN) , OPTIONAL :: DEBUG 3094 !/ 3095 !/ ------------------------------------------------------------------- / 3096 !/ Local parameters 3097 !/ 3098 LOGICAL :: LDBG, POLE 3099 INTEGER :: IS(4), JS(4) 3100 REAL(8) :: XT, YT, XS(4), YS(4) 3101 !/ 3102 ! 3103 ! -------------------------------------------------------------------- / 3104 ! 1. Test input 3105 ! 3106 IF ( .NOT.ASSOCIATED(GSU%PTR) ) THEN 3107 WRITE(*,'(/2A/)') 'W3GFIJ_R8 ERROR -- ', & 3108 'grid search utility object not created' 3109 CALL EXTCDE (1) 3110 END IF 3111 ! 3112 ! -------------------------------------------------------------------- / 3113 ! 2. Initialize search 3114 ! 3115 IF ( PRESENT(DEBUG) ) THEN 3116 LDBG = DEBUG 3117 ELSE 3118 LDBG = .FALSE. 3119 END IF 3120 ! 3121 XT = XTIN; YT = YTIN; Page 77 Source Listing W3GFIJ_R8 2014-11-12 21:37 w3gsrumd.f90 3122 IF ( LDBG ) WRITE(*,'(/A,2E14.6)') 'W3GFIJ_R8 - TARGET POINT:',XT,YT 3123 ! 3124 ! -------------------------------------------------------------------- / 3125 ! 3. Find enclosing cell and compute point location 3126 ! 3127 INGRID = W3GFCL(GSU,XT,YT,IS,JS,XS,YS,POLE=POLE,DEBUG=LDBG) 3128 IF ( .NOT. INGRID ) RETURN 3129 ! 3130 IF ( .NOT.POLE ) THEN 3131 !---------non-pole cell: compute relative location 3132 CALL W3RMBL(XT,YT,XS,YS,IX=IX,JX=JX,DEBUG=LDBG) 3133 IX = REAL(IS(1),8)+IX; JX = REAL(JS(1),8)+JX; 3134 ELSE 3135 !---------pole cell: set to center of cell 3136 IX = REAL(IS(1),8)+HALF; JX = REAL(JS(1),8)+HALF; 3137 ENDIF 3138 !/ 3139 !/ End of W3GFIJ_R8 -------------------------------------------------- / 3140 !/ 3141 END FUNCTION W3GFIJ_R8 ENTRY POINTS Name w3gsrumd_mp_w3gfij_r8_ SYMBOL CROSS REFERENCE Name Object Declared Type Bytes Dimen Elements Attributes References ASSOCIATED Func 3106 scalar PRIV 3106 DEBUG Dummy 3009 L(4) 4 scalar ARG,IN,PRIV 3115,3116 GSU Dummy 3009 T_GSU 8 scalar ARG,IN,PRIV 3106,3127 INGRID Local 3083 L(4) 4 scalar 3127,3128 IS Local 3099 I(4) 4 1 4 3127,3133,3136 IX Dummy 3009 R(8) 8 scalar ARG,OUT,PRIV 3132,3133,3136 JS Local 3099 I(4) 4 1 4 3127,3133,3136 JX Dummy 3009 R(8) 8 scalar ARG,OUT,PRIV 3132,3133,3136 LDBG Local 3098 L(4) 4 scalar 3116,3118,3122,3127,3132 POLE Local 3098 L(4) 4 scalar 3127,3130 PRESENT Func 3115 scalar PRIV 3115 REAL Func 3133 scalar PRIV 3133,3136 W3GFIJ_R8 Func 3009 L(4) 4 scalar PRIV XS Local 3100 R(8) 8 1 4 3127,3132 XT Local 3100 R(8) 8 scalar 3121,3122,3127,3132 XTIN Dummy 3009 R(8) 8 scalar ARG,IN,PRIV 3121 YS Local 3100 R(8) 8 1 4 3127,3132 YT Local 3100 R(8) 8 scalar 3121,3122,3127,3132 YTIN Dummy 3009 R(8) 8 scalar ARG,IN,PRIV 3121 Page 78 Source Listing W3GFIJ_R8 2014-11-12 21:37 w3gsrumd.f90 3142 !/ ------------------------------------------------------------------- / 3143 FUNCTION W3GRMP_R4(GSU, XTIN, YTIN, IS, JS, RW, & 3144 MASK, MSKC, NNBR, DEBUG) RESULT(INGRID) 3145 !/ 3146 !/ +-----------------------------------+ 3147 !/ | WAVEWATCH III NOAA/NCEP | 3148 !/ | T. J. Campbell, NRL | 3149 !/ | FORTRAN 90 | 3150 !/ | Last update : 15-Jun-2012 | 3151 !/ +-----------------------------------+ 3152 !/ 3153 !/ 30-Oct-2009 : Origination. ( version 3.14 ) 3154 !/ 12-Nov-2010 : Implement r4 & r8 interfaces. ( version 3.14 ) 3155 !/ 01-Dec-2010 : Some cleanup. ( version 3.14 ) 3156 !/ 06-Dec-2010 : Remove restriction on longitude range. Change ICLO 3157 !/ to integer and remove JCLO. Implement support for 3158 !/ r4 and r8 source grids. ( version 3.14 ) 3159 !/ 15-Jun-2012 : Fixing format statement that gave warning with 3160 !/ Intell compiler (H. L. Tolman). ( version 4.07 ) 3161 !/ 3162 ! 1. Purpose : 3163 ! 3164 ! Compute remapping for target point ( xtin, ytin ) from source grid 3165 ! associated with the input grid search utility object (GSU). 3166 ! The indices of the source points used for remapping are returned in 3167 ! is(1:4) and js(1:4). The remapping weights are returned in rw(1:4). 3168 ! Single precision interface. 3169 ! 3170 ! 2. Method : 3171 ! 3172 ! 3. Parameters : 3173 ! 3174 ! Return parameter 3175 ! ---------------------------------------------------------------- 3176 ! INGRID Log. O Logical flag indicating if target point lies 3177 ! within the source grid domain. 3178 ! ---------------------------------------------------------------- 3179 ! 3180 ! Parameter list 3181 ! ---------------------------------------------------------------- 3182 ! GSU Type I Grid-search-utility object. 3183 ! XTIN Real I X-coordinate of target point. 3184 ! YTIN Real I Y-coordinate of target point. 3185 ! IS,JS I.A. O (I,J) indices of vertices of enclosing grid cell. 3186 ! RW R.A. O Array of interpolation weights. 3187 ! MASK L.A. I Optional logical mask for source grid. 3188 ! MSKC Int. O Optional output integer parameter indicating how 3189 ! the enclosing cell is masked. Possible values 3190 ! are MSKC_NONE, MSKC_PART and MSKC_FULL. 3191 ! MSKC is required when MASK is specified. 3192 ! NNBR Int. I/O Optional integer parameter indicating the number 3193 ! of nearest-neighbor non-masked points used for 3194 ! distance-weighted averaging. 3195 ! Input: Requested number of nearest-neighbor 3196 ! non-masked points (0 < NNBR <= 4). 3197 ! Output: Actual number of nearest-neighbor 3198 ! non-masked points used. Page 79 Source Listing W3GRMP_R4 2014-11-12 21:37 w3gsrumd.f90 3199 ! DEBUG Log. I Optional logical flag to turn on debug mode. 3200 ! Default is FALSE. 3201 ! ---------------------------------------------------------------- 3202 ! 3203 ! 4. Subroutines used : 3204 ! 3205 ! See module documentation. 3206 ! 3207 ! 5. Called by : 3208 ! 3209 ! 6. Error messages : 3210 ! 3211 ! - Check on previous initialization of grid search utility object. 3212 ! - Check on appropriate input of optional arguments. 3213 ! 3214 ! 7. Remarks : 3215 ! 3216 ! 8. Structure : 3217 ! 3218 ! ----------------------------------------------------------------- 3219 ! 1. Test input 3220 ! 2. Initialize search 3221 ! 3. Find enclosing cell and compute remapping weights 3222 ! - if enclosing cell does not includes a pole, then 3223 ! compute bilinear remapping 3224 ! - if enclosing cell includes a pole, then 3225 ! compute distance weighted remapping 3226 ! 4. Handle case of target point located within a partially masked cell. 3227 ! 5. Handle case of target point located within a fully masked cell. 3228 ! ----------------------------------------------------------------- 3229 ! 3230 ! 9. Switches : 3231 ! 3232 ! !/S Enable subroutine tracing. 3233 ! 3234 ! 10. Source code : 3235 ! 3236 !/ ------------------------------------------------------------------- / 3237 !/ 3238 !/ ------------------------------------------------------------------- / 3239 !/ Return parameter 3240 !/ 3241 LOGICAL :: INGRID 3242 !/ 3243 !/ ------------------------------------------------------------------- / 3244 !/ Parameter list 3245 !/ 3246 TYPE(T_GSU), INTENT(IN) :: GSU 3247 REAL(4), INTENT(IN) :: XTIN 3248 REAL(4), INTENT(IN) :: YTIN 3249 INTEGER, INTENT(OUT) :: IS(4) 3250 INTEGER, INTENT(OUT) :: JS(4) 3251 REAL(4), INTENT(OUT) :: RW(4) 3252 LOGICAL, INTENT(IN) , OPTIONAL :: MASK(:,:) 3253 INTEGER, INTENT(OUT) , OPTIONAL :: MSKC 3254 INTEGER, INTENT(INOUT), OPTIONAL :: NNBR 3255 LOGICAL, INTENT(IN) , OPTIONAL :: DEBUG Page 80 Source Listing W3GRMP_R4 2014-11-12 21:37 w3gsrumd.f90 3256 !/ 3257 !/ ------------------------------------------------------------------- / 3258 !/ Local parameters 3259 !/ 3260 REAL(8), PARAMETER :: BIG = 1D16 3261 REAL(8), PARAMETER :: SMALL = 1D-6 3262 LOGICAL :: LDBG, POLE 3263 INTEGER :: I, J, K, L, IB, JB, IBC, JBC 3264 LOGICAL :: M, MSK(4) 3265 INTEGER :: LVL, N, NS, ICC, JCC 3266 REAL(4) :: XT, YT, XS(4), YS(4) 3267 REAL(4) :: X, Y, D(4), DD, DMIN, DSUM 3268 LOGICAL :: IJG, LLG, LCLO 3269 INTEGER :: ICLO, GKIND 3270 INTEGER :: NX, NY 3271 REAL(4), POINTER :: XG4(:,:), YG4(:,:) 3272 REAL(8), POINTER :: XG8(:,:), YG8(:,:) 3273 TYPE(T_NNS), POINTER :: NNP 3274 !/ 3275 ! 3276 ! -------------------------------------------------------------------- / 3277 ! 1. Test input 3278 ! 3279 IF ( .NOT.ASSOCIATED(GSU%PTR) ) THEN 3280 WRITE(*,'(/2A/)') 'W3GRMP_R4 ERROR -- ', & 3281 'grid search utility object not created' 3282 CALL EXTCDE (1) 3283 END IF 3284 ! 3285 IF ( PRESENT(MASK) ) THEN 3286 IF ( .NOT.PRESENT(MSKC) ) THEN 3287 WRITE(*,'(/2A/)') 'W3GRMP_R4 ERROR -- ', & 3288 'MSKC must be specified with MASK' 3289 CALL EXTCDE (1) 3290 END IF 3291 IF ( PRESENT(NNBR) ) THEN 3292 IF ( .NOT.ASSOCIATED(GSU%PTR%NNP) ) THEN 3293 WRITE(*,'(/3A/)') 'W3GRMP_R4 ERROR -- ', & 3294 'MASK and NNBR input specified, ', & 3295 'but grid point-search object not created' 3296 CALL EXTCDE (1) 3297 END IF 3298 IF ( NNBR .LE. 0 .OR. NNBR .GT. 4 ) THEN 3299 WRITE(*,'(/2A/)') 'W3GRMP_R4 ERROR -- ', & 3300 'NNBR must be >= 1 AND <= 4' 3301 CALL EXTCDE (1) 3302 END IF 3303 END IF 3304 END IF 3305 ! 3306 ! -------------------------------------------------------------------- / 3307 ! 2. Initialize search 3308 ! 3309 IF ( PRESENT(DEBUG) ) THEN 3310 LDBG = DEBUG 3311 ELSE 3312 LDBG = .FALSE. Page 81 Source Listing W3GRMP_R4 2014-11-12 21:37 w3gsrumd.f90 3313 END IF 3314 ! 3315 ! Local pointers to grid search utility object data 3316 IJG = GSU%PTR%IJG 3317 LLG = GSU%PTR%LLG 3318 ICLO = GSU%PTR%ICLO 3319 LCLO = GSU%PTR%LCLO 3320 GKIND = GSU%PTR%GKIND 3321 NX = GSU%PTR%NX; NY = GSU%PTR%NY; 3322 IF ( GKIND.EQ.4 ) THEN 3323 XG4 => GSU%PTR%XG4; YG4 => GSU%PTR%YG4; 3324 ELSE 3325 XG8 => GSU%PTR%XG8; YG8 => GSU%PTR%YG8; 3326 END IF 3327 NNP => GSU%PTR%NNP 3328 ! 3329 RW = ZERO; 3330 ! 3331 XT = XTIN; YT = YTIN; 3332 IF ( LDBG ) WRITE(*,'(/A,2E14.6)') 'W3GRMP_R4 - TARGET POINT:',XT,YT 3333 ! 3334 ! -------------------------------------------------------------------- / 3335 ! 3. Find enclosing cell and compute remapping 3336 ! 3337 INGRID = W3GFCL(GSU,XT,YT,IS,JS,XS,YS,POLE=POLE,DEBUG=LDBG) 3338 IF ( .NOT. INGRID ) RETURN 3339 ! 3340 IF ( .NOT.POLE ) THEN 3341 !---------non-pole cell: compute bilinear remapping 3342 CALL W3RMBL(XT,YT,XS,YS,RW=RW,DEBUG=LDBG) 3343 IF ( LDBG ) THEN 3344 WRITE(*,'(A,2E14.6)') 'W3GRMP_R4 - BILINEAR (TGT):',XT,YT 3345 DO L=1,4 3346 WRITE(*,'(A,3I6,E14.6)') 'W3GRMP_R4 - BILINEAR (SRC):', & 3347 L,IS(L),JS(L),RW(L) 3348 END DO 3349 END IF !LDBG 3350 ELSE 3351 !---------pole cell: compute distance-weighted remapping 3352 DSUM = ZERO 3353 DO L=1,4 3354 D(L) = W3DIST(LLG,XT,YT,XS(L),YS(L)) 3355 DSUM = DSUM + ONE/(D(L)+SMALL) 3356 END DO 3357 RW(1:4) = ONE/(D(1:4)+SMALL)/DSUM 3358 IF ( LDBG ) THEN 3359 WRITE(*,'(A,2E14.6)') 'W3GRMP_R4 - DISTWGHT (TGT):',XT,YT 3360 DO L=1,4 3361 WRITE(*,'(A,3I6,E14.6)') 'W3GRMP_R4 - DISTWGHT (SRC):', & 3362 L,IS(L),JS(L),RW(L) 3363 END DO 3364 END IF !LDBG 3365 ENDIF 3366 ! 3367 IF ( .NOT.PRESENT(MASK) ) RETURN 3368 ! 3369 ! -------------------------------------------------------------------- / Page 82 Source Listing W3GRMP_R4 2014-11-12 21:37 w3gsrumd.f90 3370 ! 4. Handle case of target point located within a partially masked cell. 3371 ! 3372 !-----copy cell mask values according to array ordering 3373 IF ( IJG ) THEN 3374 DO L=1,4 3375 MSK(L) = MASK(IS(L),JS(L)) 3376 END DO 3377 ELSE 3378 DO L=1,4 3379 MSK(L) = MASK(JS(L),IS(L)) 3380 END DO 3381 END IF 3382 ! 3383 !-----adjust weights for a partially masked cell 3384 DSUM = ZERO 3385 NS = 4 3386 DO L=1,4 3387 IF ( MSK(L) ) THEN 3388 NS = NS - 1 3389 RW(L) = ZERO 3390 END IF 3391 DSUM = DSUM + RW(L) 3392 END DO 3393 IF ( NS .EQ. 4 ) THEN 3394 MSKC = MSKC_NONE 3395 RETURN 3396 END IF 3397 IF ( NS .GT. 0 .AND. DSUM .GT. SMALL ) THEN 3398 RW = RW / DSUM 3399 IF ( LDBG ) & 3400 WRITE(*,'(A,2E14.6,4(2I6,E14.6))') & 3401 'W3GRMP_R4 - PARTIAL MASKED CELL:', & 3402 XT,YT,(IS(L),JS(L),RW(L),L=1,4) 3403 MSKC = MSKC_PART 3404 RETURN 3405 ELSE 3406 MSKC = MSKC_FULL 3407 IF ( .NOT.PRESENT(NNBR) ) RETURN 3408 END IF 3409 ! 3410 ! -------------------------------------------------------------------- / 3411 ! 5. Handle case of target point located within a fully masked cell. 3412 ! 3413 ! Choose closest point in enclosing land cell to be the central point 3414 DMIN = BIG 3415 DO L=1,4 3416 DD = W3DIST(LLG,XT,YT,XS(L),YS(L)) 3417 IF ( DD .LT. DMIN ) THEN 3418 DMIN = DD; ICC = IS(L); JCC = JS(L); 3419 END IF 3420 END DO !L 3421 ! 3422 ! Search nearest-neighbor source points for closest nnbr un-masked 3423 ! points and compute distance-weighted average remapping. 3424 IF ( LDBG ) & 3425 WRITE(*,'(A,2I6)') & 3426 'W3GRMP_R4 - BEGIN POINT NNBR SEARCH:',ICC,JCC Page 83 Source Listing W3GRMP_R4 2014-11-12 21:37 w3gsrumd.f90 3427 NS = 0; D(:) = BIG; 3428 LEVEL_LOOP: DO LVL=0,NNP%NLVL 3429 NNBR_LOOP: DO N=NNP%N1(LVL),NNP%N2(LVL) 3430 I = ICC + NNP%DI(N); J = JCC + NNP%DJ(N); 3431 IF ( ICLO.EQ.ICLO_NONE ) THEN 3432 IF ( I.LT.1 .OR. I.GT.NX ) CYCLE NNBR_LOOP 3433 IF ( J.LT.1 .OR. J.GT.NY ) CYCLE NNBR_LOOP 3434 END IF 3435 IF ( ICLO.NE.ICLO_NONE ) THEN 3436 IF ( I .LT. 1 ) I = I + NX 3437 IF ( I .GT. NX ) I = I - NX 3438 END IF 3439 IF ( ICLO.EQ.ICLO_TRPL ) THEN 3440 IF ( J .GT. NY ) THEN 3441 J = NY 3442 I = MOD(NX-I+1,NX) + 1 3443 END IF 3444 END IF 3445 IF ( IJG ) THEN 3446 M = MASK(I,J) 3447 ELSE 3448 M = MASK(J,I) 3449 END IF 3450 IF ( LDBG ) & 3451 WRITE(*,'(A,4I6,1L6)') & 3452 'W3GRMP_R4 - POINT NNBR SEARCH:',LVL,N,I,J,M 3453 !-------------if masked point, then skip 3454 IF ( M ) CYCLE NNBR_LOOP 3455 !-------------compute distance 3456 IF ( IJG ) THEN 3457 IF ( GKIND.EQ.4 ) THEN 3458 X = XG4(I,J); Y = YG4(I,J); 3459 ELSE 3460 X = XG8(I,J); Y = YG8(I,J); 3461 END IF 3462 ELSE 3463 IF ( GKIND.EQ.4 ) THEN 3464 X = XG4(J,I); Y = YG4(J,I); 3465 ELSE 3466 X = XG8(J,I); Y = YG8(J,I); 3467 END IF 3468 END IF 3469 DD = W3DIST(LLG,XT,YT,X,Y) 3470 !-------------still need nnbr points 3471 IF ( NS .LT. NNBR ) THEN 3472 !-----------------add to list 3473 NS = NS + 1 3474 IS(NS) = I; JS(NS) = J; D(NS) = DD; 3475 !-----------------once list is full sort according to increasing distance 3476 IF ( NS .EQ. NNBR ) CALL W3SORT(NS,IS,JS,D) 3477 !---------------we have found nnbr points 3478 ELSE !list is full 3479 !-----------------insert into list if the newest point is closer 3480 CALL W3ISRT(I,J,DD,NS,IS,JS,D) 3481 END IF !list is full 3482 IF ( LDBG ) & 3483 WRITE(*,'(A,I2,I3,I6,4(2I6,E14.6))') & Page 84 Source Listing W3GRMP_R4 2014-11-12 21:37 w3gsrumd.f90 3484 'W3GRMP_R4 - POINT NNBR LIST:', & 3485 LVL,N,NS,(IS(L),JS(L),D(L),L=1,NS) 3486 END DO NNBR_LOOP 3487 !---------if we have found nnbr_rqd points, then exit the search 3488 IF ( NS .EQ. NNBR ) EXIT LEVEL_LOOP 3489 END DO LEVEL_LOOP 3490 NNBR = NS 3491 ! 3492 ! If zero unmasked points found, then return nnbr=0 as error indicator 3493 IF ( NNBR .EQ. 0 ) RETURN 3494 ! 3495 ! Compute distance-weighted remapping for nnbr points 3496 DSUM = ZERO 3497 DO L=1,NNBR 3498 DSUM = DSUM + ONE/(D(L)+SMALL) 3499 END DO 3500 RW(1:NNBR) = ONE/(D(1:NNBR)+SMALL)/DSUM 3501 IF ( LDBG ) THEN 3502 WRITE(*,'(A,2E14.6,I6)') & 3503 'W3GRMP_R4 - FULLY MASKED CELL (TGT):',XT,YT,NNBR 3504 DO L=1,NNBR 3505 WRITE(*,'(A,3I6,E14.6)') & 3506 'W3GRMP_R4 - FULLY MASKED CELL (SRC):', & 3507 L,IS(L),JS(L),RW(L) 3508 END DO 3509 END IF !LDBG 3510 !/ 3511 !/ End of W3GRMP_R4 -------------------------------------------------- / 3512 !/ 3513 END FUNCTION W3GRMP_R4 Page 85 Source Listing W3GRMP_R4 2014-11-12 21:37 Entry Points w3gsrumd.f90 ENTRY POINTS Name w3gsrumd_mp_w3grmp_r4_ SYMBOL CROSS REFERENCE Name Object Declared Type Bytes Dimen Elements Attributes References ASSOCIATED Func 3279 scalar PRIV 3279,3292 BIG Param 3260 R(8) 8 scalar 3414,3427 D Local 3267 R(4) 4 1 4 3354,3355,3357,3427,3474,3476,3480 ,3485,3498,3500 DD Local 3267 R(4) 4 scalar 3416,3417,3418,3469,3474,3480 DEBUG Dummy 3144 L(4) 4 scalar ARG,IN,PRIV 3309,3310 DI Local 3430 I(4) 4 1 1 PTR 3430,3802,3979,3987,3996,4002,4008 ,4014,4086,4087,4168 DJ Local 3430 I(4) 4 1 1 PTR 3430,3802,3980,3987,3996,4002,4008 ,4014,4089,4090,4168 DMIN Local 3267 R(4) 4 scalar 3414,3417,3418 DSUM Local 3267 R(4) 4 scalar 3352,3355,3357,3384,3391,3397,3398 ,3496,3498,3500 GKIND Local 3269 I(4) 4 scalar 3320,3322,3457,3463 GSU Dummy 3143 T_GSU 8 scalar ARG,IN,PRIV 3279,3292,3316,3317,3318,3319,3320 ,3321,3323,3325,3327,3337 I Local 3263 I(4) 4 scalar 3430,3432,3436,3437,3442,3446,3448 ,3452,3458,3460,3464,3466,3474,348 0 IB Local 3263 I(4) 4 scalar IBC Local 3263 I(4) 4 scalar ICC Local 3265 I(4) 4 scalar 3418,3426,3430 ICLO Local 3269 I(4) 4 scalar 3318,3431,3435,3439 IJG Local 3268 L(4) 4 scalar 3316,3373,3445,3456 INGRID Local 3241 L(4) 4 scalar 3337,3338 IS Dummy 3143 I(4) 4 1 4 ARG,OUT,PRIV 3337,3347,3362,3375,3379,3402,3418 ,3474,3476,3480,3485,3507 J Local 3263 I(4) 4 scalar 3430,3433,3440,3441,3446,3448,3452 ,3458,3460,3464,3466,3474,3480 JB Local 3263 I(4) 4 scalar JBC Local 3263 I(4) 4 scalar JCC Local 3265 I(4) 4 scalar 3418,3426,3430 JS Dummy 3143 I(4) 4 1 4 ARG,OUT,PRIV 3337,3347,3362,3375,3379,3402,3418 ,3474,3476,3480,3485,3507 K Local 3263 I(4) 4 scalar L Local 3263 I(4) 4 scalar 3345,3347,3353,3354,3355,3360,3362 ,3374,3375,3378,3379,3386,3387,338 9,3391,3402,3415,3416,3418,3485,34 97,3498,3504,3507 LCLO Local 3268 L(4) 4 scalar 3319 LDBG Local 3262 L(4) 4 scalar 3310,3312,3332,3337,3342,3343,3358 ,3399,3424,3450,3482,3501 LEVEL_LOOP Label 3428 scalar 3488,3489 LLG Local 3268 L(4) 4 scalar 3317,3354,3416,3469 Page 86 Source Listing W3GRMP_R4 2014-11-12 21:37 Symbol Table w3gsrumd.f90 Name Object Declared Type Bytes Dimen Elements Attributes References LVL Local 3265 I(4) 4 scalar 3428,3429,3452,3485 M Local 3264 L(4) 4 scalar 3446,3448,3452,3454 MASK Dummy 3144 L(4) 4 2 1 ARG,IN,PRIV 3285,3367,3375,3379,3446,3448 MOD Func 3442 scalar PRIV 3442 MSK Local 3264 L(4) 4 1 4 3375,3379,3387 MSKC Dummy 3144 I(4) 4 scalar ARG,OUT,PRIV 3286,3394,3403,3406 MSKC_FULL Param 3406 I(4) 4 scalar 209,3406,3778 MSKC_NONE Param 3394 I(4) 4 scalar 207,3394,3766 MSKC_PART Param 3403 I(4) 4 scalar 208,3403,3775 N Local 3265 I(4) 4 scalar 3429,3430,3452,3485 N1 Local 3429 I(4) 4 1 1 PTR 3429,3801,3977,3986,3991,4080,4081 ,4167 N2 Local 3429 I(4) 4 1 1 PTR 3429,3801,3978,3986,3991,4083,4084 ,4167 NLVL Local 3428 I(4) 4 scalar 3428,3800,3973,3977,3978,3989,4078 ,4165,4166 NNBR Dummy 3144 I(4) 4 scalar ARG,INOUT,PRIV 3291,3298,3407,3471,3476,3488,3490 ,3493,3497,3500,3503,3504 NNBR_LOOP Label 3429 scalar 3432,3433,3454,3486 NNP Local 3273 T_NNS 296 scalar PTR 3327,3428,3429,3430 NS Local 3265 I(4) 4 scalar 3385,3388,3393,3397,3427,3471,3473 ,3474,3476,3480,3485,3488,3490 NX Local 3270 I(4) 4 scalar 3321,3432,3436,3437,3442 NY Local 3270 I(4) 4 scalar 3321,3433,3440,3441 ONE Param 3355 R(8) 8 scalar 3355,3357,3498,3500,3727,3729,3870 ,3872,4284,4286,4288,4294,4295,429 7,4343,4344,4346,4476,4478,4480,44 86,4487,4489,4535,4536,4538,4639,4 730,4934,4936,4999,5001,5209,5211, 5274,5276 POLE Local 3262 L(4) 4 scalar 3337,3340 PRESENT Func 3285 scalar PRIV 3285,3286,3291,3309,3367,3407 RW Dummy 3143 R(4) 4 1 4 ARG,OUT,PRIV 3329,3342,3347,3357,3362,3389,3391 ,3398,3402,3500,3507 SMALL Param 3261 R(8) 8 scalar 3355,3357,3397,3498,3500 T_NNS Type 3273 296 scalar 246,270,3273,3645,3954,4068,4148 W3GRMP_R4 Func 3143 L(4) 4 scalar PRIV W3ISRT Local 3480 scalar 202,3480,3852 W3SORT Local 3476 scalar 201,3476,3848 X Local 3267 R(4) 4 scalar 3458,3460,3464,3466,3469 XG4 Local 3271 R(4) 4 2 1 PTR 3323,3458,3464 XG8 Local 3272 R(8) 8 2 1 PTR 3325,3460,3466 XS Local 3266 R(4) 4 1 4 3337,3342,3354,3416 XT Local 3266 R(4) 4 scalar 3331,3332,3337,3342,3344,3354,3359 ,3402,3416,3469,3503 XTIN Dummy 3143 R(4) 4 scalar ARG,IN,PRIV 3331 Y Local 3267 R(4) 4 scalar 3458,3460,3464,3466,3469 YG4 Local 3271 R(4) 4 2 1 PTR 3323,3458,3464 YG8 Local 3272 R(8) 8 2 1 PTR 3325,3460,3466 YS Local 3266 R(4) 4 1 4 3337,3342,3354,3416 YT Local 3266 R(4) 4 scalar 3331,3332,3337,3342,3344,3354,3359 ,3402,3416,3469,3503 YTIN Dummy 3143 R(4) 4 scalar ARG,IN,PRIV 3331 Page 87 Source Listing W3GRMP_R4 2014-11-12 21:37 w3gsrumd.f90 3514 !/ ------------------------------------------------------------------- / 3515 FUNCTION W3GRMP_R8(GSU, XTIN, YTIN, IS, JS, RW, & 3516 MASK, MSKC, NNBR, DEBUG) RESULT(INGRID) 3517 !/ 3518 !/ +-----------------------------------+ 3519 !/ | WAVEWATCH III NOAA/NCEP | 3520 !/ | T. J. Campbell, NRL | 3521 !/ | FORTRAN 90 | 3522 !/ | Last update : 15-Jun-2012 | 3523 !/ +-----------------------------------+ 3524 !/ 3525 !/ 30-Oct-2009 : Origination. ( version 3.14 ) 3526 !/ 12-Nov-2010 : Implement r4 & r8 interfaces. ( version 3.14 ) 3527 !/ 01-Dec-2010 : Some cleanup. ( version 3.14 ) 3528 !/ 06-Dec-2010 : Remove restriction on longitude range. Change ICLO 3529 !/ to integer and remove JCLO. Implement support for 3530 !/ r4 and r8 source grids. ( version 3.14 ) 3531 !/ 15-Jun-2012 : Fixing format statement that gave warning with 3532 !/ Intell compiler (H. L. Tolman). ( version 4.07 ) 3533 !/ 3534 ! 1. Purpose : 3535 ! 3536 ! Compute remapping for target point ( xtin, ytin ) from source grid 3537 ! associated with the input grid search utility object (GSU). 3538 ! The indices of the source points used for remapping are returned in 3539 ! is(1:4) and js(1:4). The remapping weights are returned in rw(1:4). 3540 ! Double precision interface. 3541 ! 3542 ! 2. Method : 3543 ! 3544 ! 3. Parameters : 3545 ! 3546 ! Return parameter 3547 ! ---------------------------------------------------------------- 3548 ! INGRID Log. O Logical flag indicating if target point lies 3549 ! within the source grid domain. 3550 ! ---------------------------------------------------------------- 3551 ! 3552 ! Parameter list 3553 ! ---------------------------------------------------------------- 3554 ! GSU Type I Grid-search-utility object. 3555 ! XTIN Real I X-coordinate of target point. 3556 ! YTIN Real I Y-coordinate of target point. 3557 ! IS,JS I.A. O (I,J) indices of vertices of enclosing grid cell. 3558 ! RW R.A. O Array of interpolation weights. 3559 ! MASK L.A. I Optional logical mask for source grid. 3560 ! MSKC Int. O Optional output integer parameter indicating how 3561 ! the enclosing cell is masked. Possible values 3562 ! are MSKC_NONE, MSKC_PART and MSKC_FULL. 3563 ! MSKC is required when MASK is specified. 3564 ! NNBR Int. I/O Optional integer parameter indicating the number 3565 ! of nearest-neighbor non-masked points used for 3566 ! distance-weighted averaging. 3567 ! Input: Requested number of nearest-neighbor 3568 ! non-masked points (0 < NNBR <= 4). 3569 ! Output: Actual number of nearest-neighbor 3570 ! non-masked points used. Page 88 Source Listing W3GRMP_R8 2014-11-12 21:37 w3gsrumd.f90 3571 ! DEBUG Log. I Optional logical flag to turn on debug mode. 3572 ! Default is FALSE. 3573 ! ---------------------------------------------------------------- 3574 ! 3575 ! 4. Subroutines used : 3576 ! 3577 ! See module documentation. 3578 ! 3579 ! 5. Called by : 3580 ! 3581 ! 6. Error messages : 3582 ! 3583 ! - Check on previous initialization of grid search utility object. 3584 ! - Check on appropriate input of optional arguments. 3585 ! 3586 ! 7. Remarks : 3587 ! 3588 ! 8. Structure : 3589 ! 3590 ! ----------------------------------------------------------------- 3591 ! 1. Test input 3592 ! 2. Initialize search 3593 ! 3. Find enclosing cell and compute remapping weights 3594 ! - if enclosing cell does not includes a pole, then 3595 ! compute bilinear remapping 3596 ! - if enclosing cell includes a pole, then 3597 ! compute distance weighted remapping 3598 ! 4. Handle case of target point located within a partially masked cell. 3599 ! 5. Handle case of target point located within a fully masked cell. 3600 ! ----------------------------------------------------------------- 3601 ! 3602 ! 9. Switches : 3603 ! 3604 ! !/S Enable subroutine tracing. 3605 ! 3606 ! 10. Source code : 3607 ! 3608 !/ ------------------------------------------------------------------- / 3609 !/ 3610 !/ ------------------------------------------------------------------- / 3611 !/ Return parameter 3612 !/ 3613 LOGICAL :: INGRID 3614 !/ 3615 !/ ------------------------------------------------------------------- / 3616 !/ Parameter list 3617 !/ 3618 TYPE(T_GSU), INTENT(IN) :: GSU 3619 REAL(8), INTENT(IN) :: XTIN 3620 REAL(8), INTENT(IN) :: YTIN 3621 INTEGER, INTENT(OUT) :: IS(4) 3622 INTEGER, INTENT(OUT) :: JS(4) 3623 REAL(8), INTENT(OUT) :: RW(4) 3624 LOGICAL, INTENT(IN) , OPTIONAL :: MASK(:,:) 3625 INTEGER, INTENT(OUT) , OPTIONAL :: MSKC 3626 INTEGER, INTENT(INOUT), OPTIONAL :: NNBR 3627 LOGICAL, INTENT(IN) , OPTIONAL :: DEBUG Page 89 Source Listing W3GRMP_R8 2014-11-12 21:37 w3gsrumd.f90 3628 !/ 3629 !/ ------------------------------------------------------------------- / 3630 !/ Local parameters 3631 !/ 3632 REAL(8), PARAMETER :: BIG = 1D16 3633 REAL(8), PARAMETER :: SMALL = 1D-6 3634 LOGICAL :: LDBG, POLE 3635 INTEGER :: I, J, K, L, IB, JB, IBC, JBC 3636 LOGICAL :: M, MSK(4) 3637 INTEGER :: LVL, N, NS, ICC, JCC 3638 REAL(8) :: XT, YT, XS(4), YS(4) 3639 REAL(8) :: X, Y, D(4), DD, DMIN, DSUM 3640 LOGICAL :: IJG, LLG, LCLO 3641 INTEGER :: ICLO, GKIND 3642 INTEGER :: NX, NY 3643 REAL(4), POINTER :: XG4(:,:), YG4(:,:) 3644 REAL(8), POINTER :: XG8(:,:), YG8(:,:) 3645 TYPE(T_NNS), POINTER :: NNP 3646 !/ 3647 ! 3648 ! -------------------------------------------------------------------- / 3649 ! 1. Test input 3650 ! 3651 IF ( .NOT.ASSOCIATED(GSU%PTR) ) THEN 3652 WRITE(*,'(/2A/)') 'W3GRMP_R8 ERROR -- ', & 3653 'grid search utility object not created' 3654 CALL EXTCDE (1) 3655 END IF 3656 ! 3657 IF ( PRESENT(MASK) ) THEN 3658 IF ( .NOT.PRESENT(MSKC) ) THEN 3659 WRITE(*,'(/2A/)') 'W3GRMP_R8 ERROR -- ', & 3660 'MSKC must be specified with MASK' 3661 CALL EXTCDE (1) 3662 END IF 3663 IF ( PRESENT(NNBR) ) THEN 3664 IF ( .NOT.ASSOCIATED(GSU%PTR%NNP) ) THEN 3665 WRITE(*,'(/3A/)') 'W3GRMP_R8 ERROR -- ', & 3666 'MASK and NNBR input specified, ', & 3667 'but grid point-search object not created' 3668 CALL EXTCDE (1) 3669 END IF 3670 IF ( NNBR .LE. 0 .OR. NNBR .GT. 4 ) THEN 3671 WRITE(*,'(/2A/)') 'W3GRMP_R8 ERROR -- ', & 3672 'NNBR must be >= 1 AND <= 4' 3673 CALL EXTCDE (1) 3674 END IF 3675 END IF 3676 END IF 3677 ! 3678 ! -------------------------------------------------------------------- / 3679 ! 2. Initialize search 3680 ! 3681 IF ( PRESENT(DEBUG) ) THEN 3682 LDBG = DEBUG 3683 ELSE 3684 LDBG = .FALSE. Page 90 Source Listing W3GRMP_R8 2014-11-12 21:37 w3gsrumd.f90 3685 END IF 3686 ! 3687 ! Local pointers to grid search utility object data 3688 IJG = GSU%PTR%IJG 3689 LLG = GSU%PTR%LLG 3690 ICLO = GSU%PTR%ICLO 3691 LCLO = GSU%PTR%LCLO 3692 GKIND = GSU%PTR%GKIND 3693 NX = GSU%PTR%NX; NY = GSU%PTR%NY; 3694 IF ( GKIND.EQ.4 ) THEN 3695 XG4 => GSU%PTR%XG4; YG4 => GSU%PTR%YG4; 3696 ELSE 3697 XG8 => GSU%PTR%XG8; YG8 => GSU%PTR%YG8; 3698 END IF 3699 NNP => GSU%PTR%NNP 3700 ! 3701 RW = ZERO; 3702 ! 3703 XT = XTIN; YT = YTIN; 3704 IF ( LDBG ) WRITE(*,'(/A,2E14.6)') 'W3GRMP_R8 - TARGET POINT:',XT,YT 3705 ! 3706 ! -------------------------------------------------------------------- / 3707 ! 3. Find enclosing cell and compute remapping 3708 ! 3709 INGRID = W3GFCL(GSU,XT,YT,IS,JS,XS,YS,POLE=POLE,DEBUG=LDBG) 3710 IF ( .NOT. INGRID ) RETURN 3711 ! 3712 IF ( .NOT.POLE ) THEN 3713 !---------non-pole cell: compute bilinear remapping 3714 CALL W3RMBL(XT,YT,XS,YS,RW=RW,DEBUG=LDBG) 3715 IF ( LDBG ) THEN 3716 WRITE(*,'(A,2E14.6)') 'W3GRMP_R8 - BILINEAR (TGT):',XT,YT 3717 DO L=1,4 3718 WRITE(*,'(A,3I6,E14.6)') 'W3GRMP_R8 - BILINEAR (SRC):', & 3719 L,IS(L),JS(L),RW(L) 3720 END DO 3721 END IF !LDBG 3722 ELSE 3723 !---------pole cell: compute distance-weighted remapping 3724 DSUM = ZERO 3725 DO L=1,4 3726 D(L) = W3DIST(LLG,XT,YT,XS(L),YS(L)) 3727 DSUM = DSUM + ONE/(D(L)+SMALL) 3728 END DO 3729 RW(1:4) = ONE/(D(1:4)+SMALL)/DSUM 3730 IF ( LDBG ) THEN 3731 WRITE(*,'(A,2E14.6)') 'W3GRMP_R8 - DISTWGHT (TGT):',XT,YT 3732 DO L=1,4 3733 WRITE(*,'(A,3I6,E14.6)') 'W3GRMP_R8 - DISTWGHT (SRC):', & 3734 L,IS(L),JS(L),RW(L) 3735 END DO 3736 END IF !LDBG 3737 ENDIF 3738 ! 3739 IF ( .NOT.PRESENT(MASK) ) RETURN 3740 ! 3741 ! -------------------------------------------------------------------- / Page 91 Source Listing W3GRMP_R8 2014-11-12 21:37 w3gsrumd.f90 3742 ! 4. Handle case of target point located within a partially masked cell. 3743 ! 3744 !-----copy cell mask values according to array ordering 3745 IF ( IJG ) THEN 3746 DO L=1,4 3747 MSK(L) = MASK(IS(L),JS(L)) 3748 END DO 3749 ELSE 3750 DO L=1,4 3751 MSK(L) = MASK(JS(L),IS(L)) 3752 END DO 3753 END IF 3754 ! 3755 !-----adjust weights for a partially masked cell 3756 DSUM = ZERO 3757 NS = 4 3758 DO L=1,4 3759 IF ( MSK(L) ) THEN 3760 NS = NS - 1 3761 RW(L) = ZERO 3762 END IF 3763 DSUM = DSUM + RW(L) 3764 END DO 3765 IF ( NS .EQ. 4 ) THEN 3766 MSKC = MSKC_NONE 3767 RETURN 3768 END IF 3769 IF ( NS .GT. 0 .AND. DSUM .GT. SMALL ) THEN 3770 RW = RW / DSUM 3771 IF ( LDBG ) & 3772 WRITE(*,'(A,2E14.6,4(2I6,E14.6))') & 3773 'W3GRMP_R8 - PARTIAL MASKED CELL:', & 3774 XT,YT,(IS(L),JS(L),RW(L),L=1,4) 3775 MSKC = MSKC_PART 3776 RETURN 3777 ELSE 3778 MSKC = MSKC_FULL 3779 IF ( .NOT.PRESENT(NNBR) ) RETURN 3780 END IF 3781 ! 3782 ! -------------------------------------------------------------------- / 3783 ! 5. Handle case of target point located within a fully masked cell. 3784 ! 3785 ! Choose closest point in enclosing land cell to be the central point 3786 DMIN = BIG 3787 DO L=1,4 3788 DD = W3DIST(LLG,XT,YT,XS(L),YS(L)) 3789 IF ( DD .LT. DMIN ) THEN 3790 DMIN = DD; ICC = IS(L); JCC = JS(L); 3791 END IF 3792 END DO !L 3793 ! 3794 ! Search nearest-neighbor source points for closest nnbr un-masked 3795 ! points and compute distance-weighted average remapping. 3796 IF ( LDBG ) & 3797 WRITE(*,'(A,2I6)') & 3798 'W3GRMP_R8 - BEGIN POINT NNBR SEARCH:',ICC,JCC Page 92 Source Listing W3GRMP_R8 2014-11-12 21:37 w3gsrumd.f90 3799 NS = 0; D(:) = BIG; 3800 LEVEL_LOOP: DO LVL=0,NNP%NLVL 3801 NNBR_LOOP: DO N=NNP%N1(LVL),NNP%N2(LVL) 3802 I = ICC + NNP%DI(N); J = JCC + NNP%DJ(N); 3803 IF ( ICLO.EQ.ICLO_NONE ) THEN 3804 IF ( I.LT.1 .OR. I.GT.NX ) CYCLE NNBR_LOOP 3805 IF ( J.LT.1 .OR. J.GT.NY ) CYCLE NNBR_LOOP 3806 END IF 3807 IF ( ICLO.NE.ICLO_NONE ) THEN 3808 IF ( I .LT. 1 ) I = I + NX 3809 IF ( I .GT. NX ) I = I - NX 3810 END IF 3811 IF ( ICLO.EQ.ICLO_TRPL ) THEN 3812 IF ( J .GT. NY ) THEN 3813 J = NY 3814 I = MOD(NX-I+1,NX) + 1 3815 END IF 3816 END IF 3817 IF ( IJG ) THEN 3818 M = MASK(I,J) 3819 ELSE 3820 M = MASK(J,I) 3821 END IF 3822 IF ( LDBG ) & 3823 WRITE(*,'(A,4I6,1L6)') & 3824 'W3GRMP_R8 - POINT NNBR SEARCH:',LVL,N,I,J,M 3825 !-------------if masked point, then skip 3826 IF ( M ) CYCLE NNBR_LOOP 3827 !-------------compute distance 3828 IF ( IJG ) THEN 3829 IF ( GKIND.EQ.4 ) THEN 3830 X = XG4(I,J); Y = YG4(I,J); 3831 ELSE 3832 X = XG8(I,J); Y = YG8(I,J); 3833 END IF 3834 ELSE 3835 IF ( GKIND.EQ.4 ) THEN 3836 X = XG4(J,I); Y = YG4(J,I); 3837 ELSE 3838 X = XG8(J,I); Y = YG8(J,I); 3839 END IF 3840 END IF 3841 DD = W3DIST(LLG,XT,YT,X,Y) 3842 !-------------still need nnbr points 3843 IF ( NS .LT. NNBR ) THEN 3844 !-----------------add to list 3845 NS = NS + 1 3846 IS(NS) = I; JS(NS) = J; D(NS) = DD; 3847 !-----------------once list is full sort according to increasing distance 3848 IF ( NS .EQ. NNBR ) CALL W3SORT(NS,IS,JS,D) 3849 !---------------we have found nnbr points 3850 ELSE !list is full 3851 !-----------------insert into list if the newest point is closer 3852 CALL W3ISRT(I,J,DD,NS,IS,JS,D) 3853 END IF !list is full 3854 IF ( LDBG ) & 3855 WRITE(*,'(A,I2,I3,I6,4(2I6,E14.6))') & Page 93 Source Listing W3GRMP_R8 2014-11-12 21:37 w3gsrumd.f90 3856 'W3GRMP_R8 - POINT NNBR LIST:', & 3857 LVL,N,NS,(IS(L),JS(L),D(L),L=1,NS) 3858 END DO NNBR_LOOP 3859 !---------if we have found nnbr_rqd points, then exit the search 3860 IF ( NS .EQ. NNBR ) EXIT LEVEL_LOOP 3861 END DO LEVEL_LOOP 3862 NNBR = NS 3863 ! 3864 ! If zero unmasked points found, then return nnbr=0 as error indicator 3865 IF ( NNBR .EQ. 0 ) RETURN 3866 ! 3867 ! Compute distance-weighted remapping for nnbr points 3868 DSUM = ZERO 3869 DO L=1,NNBR 3870 DSUM = DSUM + ONE/(D(L)+SMALL) 3871 END DO 3872 RW(1:NNBR) = ONE/(D(1:NNBR)+SMALL)/DSUM 3873 IF ( LDBG ) THEN 3874 WRITE(*,'(A,2E14.6,I6)') & 3875 'W3GRMP_R8 - FULLY MASKED CELL (TGT):',XT,YT,NNBR 3876 DO L=1,NNBR 3877 WRITE(*,'(A,3I6,E14.6)') & 3878 'W3GRMP_R8 - FULLY MASKED CELL (SRC):', & 3879 L,IS(L),JS(L),RW(L) 3880 END DO 3881 END IF !LDBG 3882 !/ 3883 !/ End of W3GRMP_R8 -------------------------------------------------- / 3884 !/ 3885 END FUNCTION W3GRMP_R8 Page 94 Source Listing W3GRMP_R8 2014-11-12 21:37 Entry Points w3gsrumd.f90 ENTRY POINTS Name w3gsrumd_mp_w3grmp_r8_ SYMBOL CROSS REFERENCE Name Object Declared Type Bytes Dimen Elements Attributes References ASSOCIATED Func 3651 scalar PRIV 3651,3664 BIG Param 3632 R(8) 8 scalar 3786,3799 D Local 3639 R(8) 8 1 4 3726,3727,3729,3799,3846,3848,3852 ,3857,3870,3872 DD Local 3639 R(8) 8 scalar 3788,3789,3790,3841,3846,3852 DEBUG Dummy 3516 L(4) 4 scalar ARG,IN,PRIV 3681,3682 DMIN Local 3639 R(8) 8 scalar 3786,3789,3790 DSUM Local 3639 R(8) 8 scalar 3724,3727,3729,3756,3763,3769,3770 ,3868,3870,3872 GKIND Local 3641 I(4) 4 scalar 3692,3694,3829,3835 GSU Dummy 3515 T_GSU 8 scalar ARG,IN,PRIV 3651,3664,3688,3689,3690,3691,3692 ,3693,3695,3697,3699,3709 I Local 3635 I(4) 4 scalar 3802,3804,3808,3809,3814,3818,3820 ,3824,3830,3832,3836,3838,3846,385 2 IB Local 3635 I(4) 4 scalar IBC Local 3635 I(4) 4 scalar ICC Local 3637 I(4) 4 scalar 3790,3798,3802 ICLO Local 3641 I(4) 4 scalar 3690,3803,3807,3811 IJG Local 3640 L(4) 4 scalar 3688,3745,3817,3828 INGRID Local 3613 L(4) 4 scalar 3709,3710 IS Dummy 3515 I(4) 4 1 4 ARG,OUT,PRIV 3709,3719,3734,3747,3751,3774,3790 ,3846,3848,3852,3857,3879 J Local 3635 I(4) 4 scalar 3802,3805,3812,3813,3818,3820,3824 ,3830,3832,3836,3838,3846,3852 JB Local 3635 I(4) 4 scalar JBC Local 3635 I(4) 4 scalar JCC Local 3637 I(4) 4 scalar 3790,3798,3802 JS Dummy 3515 I(4) 4 1 4 ARG,OUT,PRIV 3709,3719,3734,3747,3751,3774,3790 ,3846,3848,3852,3857,3879 K Local 3635 I(4) 4 scalar L Local 3635 I(4) 4 scalar 3717,3719,3725,3726,3727,3732,3734 ,3746,3747,3750,3751,3758,3759,376 1,3763,3774,3787,3788,3790,3857,38 69,3870,3876,3879 LCLO Local 3640 L(4) 4 scalar 3691 LDBG Local 3634 L(4) 4 scalar 3682,3684,3704,3709,3714,3715,3730 ,3771,3796,3822,3854,3873 LEVEL_LOOP Label 3800 scalar 3860,3861 LLG Local 3640 L(4) 4 scalar 3689,3726,3788,3841 LVL Local 3637 I(4) 4 scalar 3800,3801,3824,3857 M Local 3636 L(4) 4 scalar 3818,3820,3824,3826 MASK Dummy 3516 L(4) 4 2 1 ARG,IN,PRIV 3657,3739,3747,3751,3818,3820 MOD Func 3814 scalar PRIV 3814 Page 95 Source Listing W3GRMP_R8 2014-11-12 21:37 Symbol Table w3gsrumd.f90 Name Object Declared Type Bytes Dimen Elements Attributes References MSK Local 3636 L(4) 4 1 4 3747,3751,3759 MSKC Dummy 3516 I(4) 4 scalar ARG,OUT,PRIV 3658,3766,3775,3778 N Local 3637 I(4) 4 scalar 3801,3802,3824,3857 NNBR Dummy 3516 I(4) 4 scalar ARG,INOUT,PRIV 3663,3670,3779,3843,3848,3860,3862 ,3865,3869,3872,3875,3876 NNBR_LOOP Label 3801 scalar 3804,3805,3826,3858 NNP Local 3645 T_NNS 296 scalar PTR 3699,3800,3801,3802 NS Local 3637 I(4) 4 scalar 3757,3760,3765,3769,3799,3843,3845 ,3846,3848,3852,3857,3860,3862 NX Local 3642 I(4) 4 scalar 3693,3804,3808,3809,3814 NY Local 3642 I(4) 4 scalar 3693,3805,3812,3813 POLE Local 3634 L(4) 4 scalar 3709,3712 PRESENT Func 3657 scalar PRIV 3657,3658,3663,3681,3739,3779 RW Dummy 3515 R(8) 8 1 4 ARG,OUT,PRIV 3701,3714,3719,3729,3734,3761,3763 ,3770,3774,3872,3879 SMALL Param 3633 R(8) 8 scalar 3727,3729,3769,3870,3872 W3GRMP_R8 Func 3515 L(4) 4 scalar PRIV X Local 3639 R(8) 8 scalar 3830,3832,3836,3838,3841 XG4 Local 3643 R(4) 4 2 1 PTR 3695,3830,3836 XG8 Local 3644 R(8) 8 2 1 PTR 3697,3832,3838 XS Local 3638 R(8) 8 1 4 3709,3714,3726,3788 XT Local 3638 R(8) 8 scalar 3703,3704,3709,3714,3716,3726,3731 ,3774,3788,3841,3875 XTIN Dummy 3515 R(8) 8 scalar ARG,IN,PRIV 3703 Y Local 3639 R(8) 8 scalar 3830,3832,3836,3838,3841 YG4 Local 3643 R(4) 4 2 1 PTR 3695,3830,3836 YG8 Local 3644 R(8) 8 2 1 PTR 3697,3832,3838 YS Local 3638 R(8) 8 1 4 3709,3714,3726,3788 YT Local 3638 R(8) 8 scalar 3703,3704,3709,3714,3716,3726,3731 ,3774,3788,3841,3875 YTIN Dummy 3515 R(8) 8 scalar ARG,IN,PRIV 3703 Page 96 Source Listing W3GRMP_R8 2014-11-12 21:37 w3gsrumd.f90 3886 !/ ------------------------------------------------------------------- / 3887 FUNCTION W3NNSC(NLVL) RESULT(NNS) 3888 !/ 3889 !/ +-----------------------------------+ 3890 !/ | WAVEWATCH III NOAA/NCEP | 3891 !/ | T. J. Campbell, NRL | 3892 !/ | FORTRAN 90 | 3893 !/ | Last update : 30-Oct-2009 | 3894 !/ +-----------------------------------+ 3895 !/ 3896 !/ 30-Oct-2009 : Origination. ( version 3.14 ) 3897 !/ 3898 ! 1. Purpose : 3899 ! 3900 ! Create nearest-neighbor (NNBR) search object. 3901 ! 3902 ! 2. Method : 3903 ! 3904 ! Notation 3905 ! ( L, N): L = NNBR level; N = NNBR sequential index 3906 ! {DI, DJ}: DI = I-index delta; DJ = J-index delta 3907 ! 3908 ! --------------------------------------------------- 3909 ! | ( 2,21) | ( 2,20) | ( 2,19) | ( 2,18) | ( 2,17) | 3910 ! | {-2,+2} | {-1,+2} | { 0,+2} | {+1,+2} | {+2,+2} | 3911 ! --------------------------------------------------- 3912 ! | ( 2,22) | ( 1, 7) | ( 1, 6) | ( 1, 5) | ( 2,16) | 3913 ! | {-2,+1} | {-1,+1} | { 0,+1} | {+1,+1} | {+2,+1} | 3914 ! --------------------------------------------------- 3915 ! | ( 2,23) | ( 1, 8) | ( 0, 0) | ( 1, 4) | ( 2,15) | 3916 ! | {-2, 0} | {-1, 0} | { 0, 0} | {+1, 0} | {+2, 0} | 3917 ! --------------------------------------------------- 3918 ! | ( 2,24) | ( 1, 1) | ( 1, 2) | ( 1, 3) | ( 2,14) | 3919 ! | {-2,-1} | {-1,-1} | { 0,-1} | {+1,-1} | {+2,-1} | 3920 ! --------------------------------------------------- 3921 ! | ( 2, 9) | ( 2,10) | ( 2,11) | ( 2,12) | ( 2,13) | 3922 ! | {-2,-2} | {-1,-2} | { 0,-2} | {+1,-2} | {+2,-2} | 3923 ! --------------------------------------------------- 3924 ! 3925 ! 3. Parameters : 3926 ! 3927 ! Parameter list 3928 ! ---------------------------------------------------------------- 3929 ! ---------------------------------------------------------------- 3930 ! 3931 ! 4. Subroutines used : 3932 ! 3933 ! See module documentation. 3934 ! 3935 ! 5. Called by : 3936 ! 3937 ! 6. Error messages : 3938 ! 3939 ! 7. Remarks : 3940 ! 3941 ! 8. Structure : 3942 ! Page 97 Source Listing W3NNSC 2014-11-12 21:37 w3gsrumd.f90 3943 ! 9. Switches : 3944 ! 3945 ! !/S Enable subroutine tracing. 3946 ! 3947 ! 10. Source code : 3948 ! 3949 !/ ------------------------------------------------------------------- / 3950 !/ 3951 !/ ------------------------------------------------------------------- / 3952 !/ Return parameter 3953 !/ 3954 TYPE(T_NNS), POINTER :: NNS 3955 !/ 3956 !/ ------------------------------------------------------------------- / 3957 !/ Parameter list 3958 !/ 3959 INTEGER, INTENT(IN) :: NLVL 3960 !/ 3961 !/ ------------------------------------------------------------------- / 3962 !/ Local parameters 3963 !/ 3964 INTEGER :: I, J, K, L, N 3965 !/ 3966 ! 3967 ! -------------------------------------------------------------------- / 3968 ! 3969 !-----allocate object 3970 ALLOCATE(NNS) 3971 3972 !-----initialize sizes 3973 NNS%NLVL = NLVL 3974 NNS%NNBR = (2*NLVL+1)**2 3975 3976 !-----allocate arrays 3977 ALLOCATE(NNS%N1(0:NNS%NLVL)) 3978 ALLOCATE(NNS%N2(0:NNS%NLVL)) 3979 ALLOCATE(NNS%DI(0:NNS%NNBR-1)) 3980 ALLOCATE(NNS%DJ(0:NNS%NNBR-1)) 3981 3982 !-----compute index deltas for nearest-neighbor searches 3983 N = 0 3984 !-----central point 3985 L = 0 3986 NNS%N1(L) = 0; NNS%N2(L) = (2*L+1)**2-1; 3987 NNS%DI(N) = 0; NNS%DJ(N) = 0; 3988 !-----loop over levels 3989 DO L=1,NNS%NLVL 3990 !---------nnbr loop bounds 3991 NNS%N1(L) = (2*L-1)**2; NNS%N2(L) = (2*L+1)**2-1; 3992 !---------bottom-layer 3993 J = -L 3994 DO I=-L,L-1 3995 N = N + 1 3996 NNS%DI(N) = I; NNS%DJ(N) = J; 3997 END DO 3998 !---------right-layer 3999 I = L Page 98 Source Listing W3NNSC 2014-11-12 21:37 w3gsrumd.f90 4000 DO J=-L,L-1 4001 N = N + 1 4002 NNS%DI(N) = I; NNS%DJ(N) = J; 4003 END DO 4004 !---------top-layer 4005 J = L 4006 DO I=L,-L+1,-1 4007 N = N + 1 4008 NNS%DI(N) = I; NNS%DJ(N) = J; 4009 END DO 4010 !---------left-layer 4011 I = -L 4012 DO J=L,-L+1,-1 4013 N = N + 1 4014 NNS%DI(N) = I; NNS%DJ(N) = J; 4015 END DO 4016 END DO !loop over levels 4017 !/ 4018 !/ End of W3NNSC ----------------------------------------------------- / 4019 !/ 4020 END FUNCTION W3NNSC ENTRY POINTS Name w3gsrumd_mp_w3nnsc_ Page 99 Source Listing W3NNSC 2014-11-12 21:37 Symbol Table w3gsrumd.f90 SYMBOL CROSS REFERENCE Name Object Declared Type Bytes Dimen Elements Attributes References I Local 3964 I(4) 4 scalar 3994,3996,3999,4002,4006,4008,4011 ,4014 J Local 3964 I(4) 4 scalar 3993,3996,4000,4002,4005,4008,4012 ,4014 K Local 3964 I(4) 4 scalar L Local 3964 I(4) 4 scalar 3985,3986,3989,3991,3993,3994,3999 ,4000,4005,4006,4011,4012 N Local 3964 I(4) 4 scalar 3983,3987,3995,3996,4001,4002,4007 ,4008,4013,4014 NLVL Dummy 3887 I(4) 4 scalar ARG,IN,PRIV 3973,3974 NNBR Local 3974 I(4) 4 scalar 3974,3979,3980,4079,4165 NNS Local 3954 T_NNS 296 scalar PTR 3970,3973,3974,3977,3978,3979,3980 ,3986,3987,3989,3991,3996,4002,400 8,4014 W3NNSC Func 3887 T_NNS 296 scalar PTR Page 100 Source Listing W3NNSC 2014-11-12 21:37 w3gsrumd.f90 4021 !/ ------------------------------------------------------------------- / 4022 SUBROUTINE W3NNSD(NNS) 4023 !/ 4024 !/ +-----------------------------------+ 4025 !/ | WAVEWATCH III NOAA/NCEP | 4026 !/ | T. J. Campbell, NRL | 4027 !/ | FORTRAN 90 | 4028 !/ | Last update : 30-Oct-2009 | 4029 !/ +-----------------------------------+ 4030 !/ 4031 !/ 30-Oct-2009 : Origination. ( version 3.14 ) 4032 !/ 4033 ! 1. Purpose : 4034 ! 4035 ! Destroy nearest-neighbor (NNBR) search object. 4036 ! 4037 ! 2. Method : 4038 ! 4039 ! 3. Parameters : 4040 ! 4041 ! Parameter list 4042 ! ---------------------------------------------------------------- 4043 ! ---------------------------------------------------------------- 4044 ! 4045 ! 4. Subroutines used : 4046 ! 4047 ! See module documentation. 4048 ! 4049 ! 5. Called by : 4050 ! 4051 ! 6. Error messages : 4052 ! 4053 ! 7. Remarks : 4054 ! 4055 ! 8. Structure : 4056 ! 4057 ! 9. Switches : 4058 ! 4059 ! !/S Enable subroutine tracing. 4060 ! 4061 ! 10. Source code : 4062 ! 4063 !/ ------------------------------------------------------------------- / 4064 !/ 4065 !/ ------------------------------------------------------------------- / 4066 !/ Parameter list 4067 !/ 4068 TYPE(T_NNS), POINTER :: NNS 4069 !/ 4070 !/ ------------------------------------------------------------------- / 4071 !/ Local parameters 4072 !/ 4073 !/ 4074 ! 4075 ! -------------------------------------------------------------------- / 4076 ! 4077 IF ( ASSOCIATED(NNS) ) THEN Page 101 Source Listing W3NNSD 2014-11-12 21:37 w3gsrumd.f90 4078 NNS%NLVL = 0 4079 NNS%NNBR = 0 4080 IF ( ASSOCIATED(NNS%N1) ) THEN 4081 DEALLOCATE(NNS%N1); NULLIFY(NNS%N1); 4082 END IF 4083 IF ( ASSOCIATED(NNS%N2) ) THEN 4084 DEALLOCATE(NNS%N2); NULLIFY(NNS%N2); 4085 END IF 4086 IF ( ASSOCIATED(NNS%DI) ) THEN 4087 DEALLOCATE(NNS%DI); NULLIFY(NNS%DI); 4088 END IF 4089 IF ( ASSOCIATED(NNS%DJ) ) THEN 4090 DEALLOCATE(NNS%DJ); NULLIFY(NNS%DJ); 4091 END IF 4092 DEALLOCATE(NNS) 4093 NULLIFY(NNS) 4094 END IF 4095 !/ 4096 !/ End of W3NNSD ----------------------------------------------------- / 4097 !/ 4098 END SUBROUTINE W3NNSD ENTRY POINTS Name w3gsrumd_mp_w3nnsd_ Page 102 Source Listing W3NNSD 2014-11-12 21:37 Symbol Table w3gsrumd.f90 SYMBOL CROSS REFERENCE Name Object Declared Type Bytes Dimen Elements Attributes References ASSOCIATED Func 4077 scalar PRIV 4077,4080,4083,4086,4089 NNS Dummy 4022 T_NNS 296 scalar ARG,PTR,INOUT 4077,4078,4079,4080,4081,4083,4084 PRIV ,4086,4087,4089,4090,4092,4093 W3NNSD Subr 4022 Page 103 Source Listing W3NNSD 2014-11-12 21:37 w3gsrumd.f90 4099 !/ ------------------------------------------------------------------- / 4100 SUBROUTINE W3NNSP(NNS, IUNIT) 4101 !/ 4102 !/ +-----------------------------------+ 4103 !/ | WAVEWATCH III NOAA/NCEP | 4104 !/ | T. J. Campbell, NRL | 4105 !/ | FORTRAN 90 | 4106 !/ | Last update : 30-Oct-2009 | 4107 !/ +-----------------------------------+ 4108 !/ 4109 !/ 30-Oct-2009 : Origination. ( version 3.14 ) 4110 !/ 4111 ! 1. Purpose : 4112 ! 4113 ! Print nearest-neighbor (NNBR) search object to IUNIT. 4114 ! 4115 ! 2. Method : 4116 ! 4117 ! 3. Parameters : 4118 ! 4119 ! Parameter list 4120 ! ---------------------------------------------------------------- 4121 ! NNBR Type I Nearest-neighbor search object. 4122 ! IUNIT Int. I Optional unit for output. Default is stdout. 4123 ! ---------------------------------------------------------------- 4124 ! 4125 ! 4. Subroutines used : 4126 ! 4127 ! See module documentation. 4128 ! 4129 ! 5. Called by : 4130 ! 4131 ! 6. Error messages : 4132 ! 4133 ! 7. Remarks : 4134 ! 4135 ! 8. Structure : 4136 ! 4137 ! 9. Switches : 4138 ! 4139 ! !/S Enable subroutine tracing. 4140 ! 4141 ! 10. Source code : 4142 ! 4143 !/ ------------------------------------------------------------------- / 4144 !/ 4145 !/ ------------------------------------------------------------------- / 4146 !/ Parameter list 4147 !/ 4148 TYPE(T_NNS), INTENT(IN) :: NNS 4149 INTEGER, OPTIONAL, INTENT(IN) :: IUNIT 4150 !/ 4151 !/ ------------------------------------------------------------------- / 4152 !/ Local parameters 4153 !/ 4154 INTEGER :: NDST, K, L, N 4155 !/ Page 104 Source Listing W3NNSP 2014-11-12 21:37 w3gsrumd.f90 4156 ! 4157 ! -------------------------------------------------------------------- / 4158 ! 4159 IF ( PRESENT(IUNIT) ) THEN 4160 NDST = IUNIT 4161 ELSE 4162 NDST = 6 4163 END IF 4164 ! 4165 WRITE(NDST,'(A,2I6)') 'nlvl,nnbr:',NNS%NLVL,NNS%NNBR 4166 DO L=0,NNS%NLVL 4167 DO N=NNS%N1(L),NNS%N2(L) 4168 WRITE(NDST,'(A,4I6)') 'l,n,di,dj:',L,N,NNS%DI(N),NNS%DJ(N) 4169 END DO 4170 END DO 4171 !/ 4172 !/ End of W3NNSP ----------------------------------------------------- / 4173 !/ 4174 END SUBROUTINE W3NNSP ENTRY POINTS Name w3gsrumd_mp_w3nnsp_ SYMBOL CROSS REFERENCE Name Object Declared Type Bytes Dimen Elements Attributes References IUNIT Dummy 4100 I(4) 4 scalar ARG,IN,PRIV 4159,4160 K Local 4154 I(4) 4 scalar L Local 4154 I(4) 4 scalar 4166,4167,4168 N Local 4154 I(4) 4 scalar 4167,4168 NDST Local 4154 I(4) 4 scalar 4160,4162,4165,4168 NNS Dummy 4100 T_NNS 296 scalar ARG,IN,PRIV 4165,4166,4167,4168 PRESENT Func 4159 scalar PRIV 4159 W3NNSP Subr 4100 Page 105 Source Listing W3NNSP 2014-11-12 21:37 w3gsrumd.f90 4175 !/ ------------------------------------------------------------------- / 4176 SUBROUTINE W3RMBL_R4(XT, YT, XS, YS, RW, IX, JX, DEBUG) 4177 !/ 4178 !/ +-----------------------------------+ 4179 !/ | WAVEWATCH III NOAA/NCEP | 4180 !/ | T. J. Campbell, NRL | 4181 !/ | FORTRAN 90 | 4182 !/ | Last update : 01-Dec-2010 | 4183 !/ +-----------------------------------+ 4184 !/ 4185 !/ 30-Oct-2009 : Origination. ( version 3.14 ) 4186 !/ 12-Nov-2010 : Add IX,IY optional arguments. 4187 !/ Implement r4 & r8 interfaces. ( version 3.14 ) 4188 !/ 01-Dec-2010 : Add check for target point coincident with a cell 4189 !/ vertex. Change to error exit when unable to 4190 !/ determine local (i,j). ( version 3.14 ) 4191 !/ 4192 ! 1. Purpose : 4193 ! 4194 ! Bilinear remapping for target point ( xt, yt ) in a cell defined 4195 ! by the source points ( xs(1:4), ys(1:4) ). Remapping weights are 4196 ! returned in rw(1:4). It is the caller's responsibility to ensure 4197 ! that the target point is located within the input cell and that the 4198 ! cell corner points are properly defined. 4199 ! 4200 ! (xs4,ys4) (xs3,ys3) 4201 ! _____________________ 4202 ! / / 4203 ! / x / 4204 ! / (xtin,ytin) / 4205 ! / / 4206 ! /____________________/ 4207 ! (xs1,ys1) (xs2,ys2) 4208 ! 4209 ! In spherical coordinates it is assumed that the longitude range of 4210 ! the target point is the same as that of the cell vertices. It is 4211 ! also assumed that the cell does not includes a branch cut. 4212 ! Single precision interface. 4213 ! 4214 ! 2. Method : 4215 ! 4216 ! 3. Parameters : 4217 ! 4218 ! Parameter list 4219 ! ---------------------------------------------------------------- 4220 ! ---------------------------------------------------------------- 4221 ! 4222 ! 4. Subroutines used : 4223 ! 4224 ! See module documentation. 4225 ! 4226 ! 5. Called by : 4227 ! 4228 ! 6. Error messages : 4229 ! 4230 ! 7. Remarks : 4231 ! Page 106 Source Listing W3RMBL_R4 2014-11-12 21:37 w3gsrumd.f90 4232 ! - Implementation is based on SCRIP. 4233 ! - In the case of spherical coordinates, the method results in 4234 ! bogus weights if enclosing cell contains a pole. 4235 ! 4236 ! 8. Structure : 4237 ! 4238 ! 9. Switches : 4239 ! 4240 ! !/S Enable subroutine tracing. 4241 ! 4242 ! 10. Source code : 4243 ! 4244 !/ ------------------------------------------------------------------- / 4245 !/ 4246 !/ ------------------------------------------------------------------- / 4247 !/ Parameter list 4248 !/ 4249 REAL(4), INTENT(IN) :: XT 4250 REAL(4), INTENT(IN) :: YT 4251 REAL(4), INTENT(IN) :: XS(4) 4252 REAL(4), INTENT(IN) :: YS(4) 4253 REAL(4), INTENT(OUT), OPTIONAL :: RW(4) 4254 REAL(4), INTENT(OUT), OPTIONAL :: IX 4255 REAL(4), INTENT(OUT), OPTIONAL :: JX 4256 LOGICAL, INTENT(IN) , OPTIONAL :: DEBUG 4257 !/ 4258 !/ ------------------------------------------------------------------- / 4259 !/ Local parameters 4260 !/ 4261 INTEGER, PARAMETER :: MAX_ITER = 10 4262 REAL(8), PARAMETER :: CONVERGE = 1D-6 4263 LOGICAL :: LDBG 4264 INTEGER :: K, ITER 4265 REAL(8) :: DXT, DX1, DX2, DX3, DXP, DYT, DY1, DY2, DY3, DYP 4266 REAL(8) :: IGUESS, JGUESS, MAT1, MAT2, MAT3, MAT4, DELI, DELJ, DET 4267 !/ 4268 ! 4269 ! -------------------------------------------------------------------- / 4270 ! 4271 IF ( PRESENT(DEBUG) ) THEN 4272 LDBG = DEBUG 4273 ELSE 4274 LDBG = .FALSE. 4275 END IF 4276 ! 4277 !-----handle point coincident with a cell vertex 4278 DO K=1,4 4279 IF ( XT.EQ.XS(K) .AND. YT.EQ.YS(K) ) THEN 4280 SELECT CASE ( K ) 4281 CASE ( 1 ) 4282 IGUESS = ZERO; JGUESS = ZERO; 4283 CASE ( 2 ) 4284 IGUESS = ONE; JGUESS = ZERO; 4285 CASE ( 3 ) 4286 IGUESS = ONE; JGUESS = ONE; 4287 CASE ( 4 ) 4288 IGUESS = ZERO; JGUESS = ONE; Page 107 Source Listing W3RMBL_R4 2014-11-12 21:37 w3gsrumd.f90 4289 END SELECT 4290 IF ( LDBG ) & 4291 WRITE(*,'(A,I3,2E14.6)') 'W3RMBL_R4 - COINCIDENT:', & 4292 K,IGUESS,JGUESS 4293 IF ( PRESENT(RW) ) THEN 4294 RW(1) = (ONE-IGUESS)*(ONE-JGUESS) 4295 RW(2) = IGUESS*(ONE-JGUESS) 4296 RW(3) = IGUESS*JGUESS 4297 RW(4) = (ONE-IGUESS)*JGUESS 4298 END IF 4299 IF ( PRESENT(IX) .AND. PRESENT(JX) ) THEN 4300 IX = IGUESS 4301 JX = JGUESS 4302 END IF 4303 RETURN 4304 END IF 4305 END DO 4306 ! 4307 !-----set iteration parameters and initial guess 4308 IF ( PRESENT(RW) ) RW = ZERO 4309 IGUESS = HALF 4310 JGUESS = HALF 4311 DYT = YT - YS(1) 4312 DY1 = YS(2) - YS(1) 4313 DY2 = YS(4) - YS(1) 4314 DY3 = YS(3) - YS(2) - DY2 4315 DXT = XT - XS(1) 4316 DX1 = XS(2) - XS(1) 4317 DX2 = XS(4) - XS(1) 4318 DX3 = XS(3) - XS(2) - DX2 4319 4320 !-----iterate to find (i,j) for bilinear approximation 4321 ITER_LOOP: DO ITER=1,MAX_ITER 4322 DYP = DYT - DY1*IGUESS - DY2*JGUESS - DY3*IGUESS*JGUESS 4323 DXP = DXT - DX1*IGUESS - DX2*JGUESS - DX3*IGUESS*JGUESS 4324 MAT1 = DY1 + DY3*JGUESS 4325 MAT2 = DY2 + DY3*IGUESS 4326 MAT3 = DX1 + DX3*JGUESS 4327 MAT4 = DX2 + DX3*IGUESS 4328 DET = MAT1*MAT4 - MAT2*MAT3 4329 DELI = (DYP*MAT4 - MAT2*DXP)/DET 4330 DELJ = (MAT1*DXP - DYP*MAT3)/DET 4331 IF ( LDBG ) & 4332 WRITE(*,'(A,I3,4E14.6)') 'W3RMBL_R4 - ITER:', & 4333 ITER,IGUESS,JGUESS,DELI,DELJ 4334 IF ( ABS(DELI) < CONVERGE .AND. & 4335 ABS(DELJ) < CONVERGE ) EXIT ITER_LOOP 4336 IGUESS = IGUESS + DELI 4337 JGUESS = JGUESS + DELJ 4338 END DO ITER_LOOP 4339 4340 !-----if successful in finding (i,j), then compute weights 4341 IF ( ITER .LE. MAX_ITER ) THEN 4342 IF ( PRESENT(RW) ) THEN 4343 RW(1) = (ONE-IGUESS)*(ONE-JGUESS) 4344 RW(2) = IGUESS*(ONE-JGUESS) 4345 RW(3) = IGUESS*JGUESS Page 108 Source Listing W3RMBL_R4 2014-11-12 21:37 w3gsrumd.f90 4346 RW(4) = (ONE-IGUESS)*JGUESS 4347 END IF 4348 IF ( PRESENT(IX) .AND. PRESENT(JX) ) THEN 4349 IX = IGUESS 4350 JX = JGUESS 4351 END IF 4352 ELSE 4353 WRITE(*,'(/A)') & 4354 'W3RMBL_R4 -- ERROR: exceeded max iteration count' 4355 WRITE(*,'(A,2E14.6)') 'W3RMBL_R4 - DEST POINT COORDS: ',XT,YT 4356 DO K=1,4 4357 WRITE(*,'(A,I1,A,2E14.6)') & 4358 'W3RMBL_R4 - SRC POINT ',K,': ',XS(K),YS(K) 4359 END DO 4360 WRITE(*,'(A,2E14.6)') 'W3RMBL_R4 - CURRENT I,J: ',IGUESS,JGUESS 4361 CALL EXTCDE (1) 4362 END IF !(ITER.LE.MAX_ITER) 4363 !/ 4364 !/ End of W3RMBL_R4 -------------------------------------------------- / 4365 !/ 4366 END SUBROUTINE W3RMBL_R4 ENTRY POINTS Name w3gsrumd_mp_w3rmbl_r4_ Page 109 Source Listing W3RMBL_R4 2014-11-12 21:37 Symbol Table w3gsrumd.f90 SYMBOL CROSS REFERENCE Name Object Declared Type Bytes Dimen Elements Attributes References ABS Func 4334 scalar 4334,4335 CONVERGE Param 4262 R(8) 8 scalar 4334,4335 DEBUG Dummy 4176 L(4) 4 scalar ARG,IN 4271,4272 DELI Local 4266 R(8) 8 scalar 4329,4333,4334,4336 DELJ Local 4266 R(8) 8 scalar 4330,4333,4335,4337 DET Local 4266 R(8) 8 scalar 4328,4329,4330 DX1 Local 4265 R(8) 8 scalar 4316,4323,4326 DX2 Local 4265 R(8) 8 scalar 4317,4318,4323,4327 DX3 Local 4265 R(8) 8 scalar 4318,4323,4326,4327 DXP Local 4265 R(8) 8 scalar 4323,4329,4330 DXT Local 4265 R(8) 8 scalar 4315,4323 DY1 Local 4265 R(8) 8 scalar 4312,4322,4324 DY2 Local 4265 R(8) 8 scalar 4313,4314,4322,4325 DY3 Local 4265 R(8) 8 scalar 4314,4322,4324,4325 DYP Local 4265 R(8) 8 scalar 4322,4329,4330 DYT Local 4265 R(8) 8 scalar 4311,4322 IGUESS Local 4266 R(8) 8 scalar 4282,4284,4286,4288,4292,4294,4295 ,4296,4297,4300,4309,4322,4323,432 5,4327,4333,4336,4343,4344,4345,43 46,4349,4360 ITER Local 4264 I(4) 4 scalar 4321,4333,4341 ITER_LOOP Label 4321 scalar 4335,4338 IX Dummy 4176 R(4) 4 scalar ARG,OUT 4299,4300,4348,4349 JGUESS Local 4266 R(8) 8 scalar 4282,4284,4286,4288,4292,4294,4295 ,4296,4297,4301,4310,4322,4323,432 4,4326,4333,4337,4343,4344,4345,43 46,4350,4360 JX Dummy 4176 R(4) 4 scalar ARG,OUT 4299,4301,4348,4350 K Local 4264 I(4) 4 scalar 4278,4279,4280,4292,4356,4358 LDBG Local 4263 L(4) 4 scalar 4272,4274,4290,4331 MAT1 Local 4266 R(8) 8 scalar 4324,4328,4330 MAT2 Local 4266 R(8) 8 scalar 4325,4328,4329 MAT3 Local 4266 R(8) 8 scalar 4326,4328,4330 MAT4 Local 4266 R(8) 8 scalar 4327,4328,4329 MAX_ITER Param 4261 I(4) 4 scalar 4321,4341 PRESENT Func 4271 scalar 4271,4293,4299,4308,4342,4348 RW Dummy 4176 R(4) 4 1 4 ARG,OUT 4293,4294,4295,4296,4297,4308,4342 ,4343,4344,4345,4346 W3RMBL_R4 Subr 4176 2998,3342 XS Dummy 4176 R(4) 4 1 4 ARG,IN 4279,4315,4316,4317,4318,4358 XT Dummy 4176 R(4) 4 scalar ARG,IN 4279,4315,4355 YS Dummy 4176 R(4) 4 1 4 ARG,IN 4279,4311,4312,4313,4314,4358 YT Dummy 4176 R(4) 4 scalar ARG,IN 4279,4311,4355 Page 110 Source Listing W3RMBL_R4 2014-11-12 21:37 w3gsrumd.f90 4367 !/ ------------------------------------------------------------------- / 4368 SUBROUTINE W3RMBL_R8(XT, YT, XS, YS, RW, IX, JX, DEBUG) 4369 !/ 4370 !/ +-----------------------------------+ 4371 !/ | WAVEWATCH III NOAA/NCEP | 4372 !/ | T. J. Campbell, NRL | 4373 !/ | FORTRAN 90 | 4374 !/ | Last update : 01-Dec-2010 | 4375 !/ +-----------------------------------+ 4376 !/ 4377 !/ 30-Oct-2009 : Origination. ( version 3.14 ) 4378 !/ 12-Nov-2010 : Add IX,IY optional arguments. 4379 !/ Implement r4 & r8 interfaces. ( version 3.14 ) 4380 !/ 01-Dec-2010 : Add check for target point coincident with a cell 4381 !/ vertex. Change to error exit when unable to 4382 !/ determine local (i,j). ( version 3.14 ) 4383 !/ 4384 ! 1. Purpose : 4385 ! 4386 ! Bilinear remapping for target point ( xt, yt ) in a cell defined 4387 ! by the source points ( xs(1:4), ys(1:4) ). Remapping weights are 4388 ! returned in rw(1:4). It is the caller's responsibility to ensure 4389 ! that the target point is located within the input cell and that the 4390 ! cell corner points are properly defined. 4391 ! 4392 ! (xs4,ys4) (xs3,ys3) 4393 ! _____________________ 4394 ! / / 4395 ! / x / 4396 ! / (xtin,ytin) / 4397 ! / / 4398 ! /____________________/ 4399 ! (xs1,ys1) (xs2,ys2) 4400 ! 4401 ! In spherical coordinates it is assumed that the longitude range of 4402 ! the target point is the same as that of the cell vertices. It is 4403 ! also assumed that the cell does not includes a branch cut. 4404 ! Double precision interface. 4405 ! 4406 ! 2. Method : 4407 ! 4408 ! 3. Parameters : 4409 ! 4410 ! Parameter list 4411 ! ---------------------------------------------------------------- 4412 ! ---------------------------------------------------------------- 4413 ! 4414 ! 4. Subroutines used : 4415 ! 4416 ! See module documentation. 4417 ! 4418 ! 5. Called by : 4419 ! 4420 ! 6. Error messages : 4421 ! 4422 ! 7. Remarks : 4423 ! Page 111 Source Listing W3RMBL_R8 2014-11-12 21:37 w3gsrumd.f90 4424 ! - Implementation is based on SCRIP. 4425 ! - In the case of spherical coordinates, the method results in 4426 ! bogus weights if enclosing cell contains a pole. 4427 ! 4428 ! 8. Structure : 4429 ! 4430 ! 9. Switches : 4431 ! 4432 ! !/S Enable subroutine tracing. 4433 ! 4434 ! 10. Source code : 4435 ! 4436 !/ ------------------------------------------------------------------- / 4437 !/ 4438 !/ ------------------------------------------------------------------- / 4439 !/ Parameter list 4440 !/ 4441 REAL(8), INTENT(IN) :: XT 4442 REAL(8), INTENT(IN) :: YT 4443 REAL(8), INTENT(IN) :: XS(4) 4444 REAL(8), INTENT(IN) :: YS(4) 4445 REAL(8), INTENT(OUT), OPTIONAL :: RW(4) 4446 REAL(8), INTENT(OUT), OPTIONAL :: IX 4447 REAL(8), INTENT(OUT), OPTIONAL :: JX 4448 LOGICAL, INTENT(IN) , OPTIONAL :: DEBUG 4449 !/ 4450 !/ ------------------------------------------------------------------- / 4451 !/ Local parameters 4452 !/ 4453 INTEGER, PARAMETER :: MAX_ITER = 10 4454 REAL(8), PARAMETER :: CONVERGE = 1D-6 4455 LOGICAL :: LDBG 4456 INTEGER :: K, ITER 4457 REAL(8) :: DXT, DX1, DX2, DX3, DXP, DYT, DY1, DY2, DY3, DYP 4458 REAL(8) :: IGUESS, JGUESS, MAT1, MAT2, MAT3, MAT4, DELI, DELJ, DET 4459 !/ 4460 ! 4461 ! -------------------------------------------------------------------- / 4462 ! 4463 IF ( PRESENT(DEBUG) ) THEN 4464 LDBG = DEBUG 4465 ELSE 4466 LDBG = .FALSE. 4467 END IF 4468 ! 4469 !-----handle point coincident with a cell vertex 4470 DO K=1,4 4471 IF ( XT.EQ.XS(K) .AND. YT.EQ.YS(K) ) THEN 4472 SELECT CASE ( K ) 4473 CASE ( 1 ) 4474 IGUESS = ZERO; JGUESS = ZERO; 4475 CASE ( 2 ) 4476 IGUESS = ONE; JGUESS = ZERO; 4477 CASE ( 3 ) 4478 IGUESS = ONE; JGUESS = ONE; 4479 CASE ( 4 ) 4480 IGUESS = ZERO; JGUESS = ONE; Page 112 Source Listing W3RMBL_R8 2014-11-12 21:37 w3gsrumd.f90 4481 END SELECT 4482 IF ( LDBG ) & 4483 WRITE(*,'(A,I3,2E14.6)') 'W3RMBL_R8 - COINCIDENT:', & 4484 K,IGUESS,JGUESS 4485 IF ( PRESENT(RW) ) THEN 4486 RW(1) = (ONE-IGUESS)*(ONE-JGUESS) 4487 RW(2) = IGUESS*(ONE-JGUESS) 4488 RW(3) = IGUESS*JGUESS 4489 RW(4) = (ONE-IGUESS)*JGUESS 4490 END IF 4491 IF ( PRESENT(IX) .AND. PRESENT(JX) ) THEN 4492 IX = IGUESS 4493 JX = JGUESS 4494 END IF 4495 RETURN 4496 END IF 4497 END DO 4498 ! 4499 !-----set iteration parameters and initial guess 4500 IF ( PRESENT(RW) ) RW = ZERO 4501 IGUESS = HALF 4502 JGUESS = HALF 4503 DYT = YT - YS(1) 4504 DY1 = YS(2) - YS(1) 4505 DY2 = YS(4) - YS(1) 4506 DY3 = YS(3) - YS(2) - DY2 4507 DXT = XT - XS(1) 4508 DX1 = XS(2) - XS(1) 4509 DX2 = XS(4) - XS(1) 4510 DX3 = XS(3) - XS(2) - DX2 4511 4512 !-----iterate to find (i,j) for bilinear approximation 4513 ITER_LOOP: DO ITER=1,MAX_ITER 4514 DYP = DYT - DY1*IGUESS - DY2*JGUESS - DY3*IGUESS*JGUESS 4515 DXP = DXT - DX1*IGUESS - DX2*JGUESS - DX3*IGUESS*JGUESS 4516 MAT1 = DY1 + DY3*JGUESS 4517 MAT2 = DY2 + DY3*IGUESS 4518 MAT3 = DX1 + DX3*JGUESS 4519 MAT4 = DX2 + DX3*IGUESS 4520 DET = MAT1*MAT4 - MAT2*MAT3 4521 DELI = (DYP*MAT4 - MAT2*DXP)/DET 4522 DELJ = (MAT1*DXP - DYP*MAT3)/DET 4523 IF ( LDBG ) & 4524 WRITE(*,'(A,I3,4E14.6)') 'W3RMBL_R8 - ITER:', & 4525 ITER,IGUESS,JGUESS,DELI,DELJ 4526 IF ( ABS(DELI) < CONVERGE .AND. & 4527 ABS(DELJ) < CONVERGE ) EXIT ITER_LOOP 4528 IGUESS = IGUESS + DELI 4529 JGUESS = JGUESS + DELJ 4530 END DO ITER_LOOP 4531 4532 !-----if successful in finding (i,j), then compute weights 4533 IF ( ITER .LE. MAX_ITER ) THEN 4534 IF ( PRESENT(RW) ) THEN 4535 RW(1) = (ONE-IGUESS)*(ONE-JGUESS) 4536 RW(2) = IGUESS*(ONE-JGUESS) 4537 RW(3) = IGUESS*JGUESS Page 113 Source Listing W3RMBL_R8 2014-11-12 21:37 w3gsrumd.f90 4538 RW(4) = (ONE-IGUESS)*JGUESS 4539 END IF 4540 IF ( PRESENT(IX) .AND. PRESENT(JX) ) THEN 4541 IX = IGUESS 4542 JX = JGUESS 4543 END IF 4544 ELSE 4545 WRITE(*,'(/A)') & 4546 'W3RMBL_R8 -- ERROR: exceeded max iteration count' 4547 WRITE(*,'(A,2E14.6)') 'W3RMBL_R8 - DEST POINT COORDS: ',XT,YT 4548 DO K=1,4 4549 WRITE(*,'(A,I1,A,2E14.6)') & 4550 'W3RMBL_R8 - SRC POINT ',K,': ',XS(K),YS(K) 4551 END DO 4552 WRITE(*,'(A,2E14.6)') 'W3RMBL_R8 - CURRENT I,J: ',IGUESS,JGUESS 4553 CALL EXTCDE (1) 4554 END IF !(ITER.LE.MAX_ITER) 4555 !/ 4556 !/ End of W3RMBL_R8 -------------------------------------------------- / 4557 !/ 4558 END SUBROUTINE W3RMBL_R8 ENTRY POINTS Name w3gsrumd_mp_w3rmbl_r8_ Page 114 Source Listing W3RMBL_R8 2014-11-12 21:37 Symbol Table w3gsrumd.f90 SYMBOL CROSS REFERENCE Name Object Declared Type Bytes Dimen Elements Attributes References ABS Func 4526 scalar 4526,4527 CONVERGE Param 4454 R(8) 8 scalar 4526,4527 DEBUG Dummy 4368 L(4) 4 scalar ARG,IN 4463,4464 DELI Local 4458 R(8) 8 scalar 4521,4525,4526,4528 DELJ Local 4458 R(8) 8 scalar 4522,4525,4527,4529 DET Local 4458 R(8) 8 scalar 4520,4521,4522 DX1 Local 4457 R(8) 8 scalar 4508,4515,4518 DX2 Local 4457 R(8) 8 scalar 4509,4510,4515,4519 DX3 Local 4457 R(8) 8 scalar 4510,4515,4518,4519 DXP Local 4457 R(8) 8 scalar 4515,4521,4522 DXT Local 4457 R(8) 8 scalar 4507,4515 DY1 Local 4457 R(8) 8 scalar 4504,4514,4516 DY2 Local 4457 R(8) 8 scalar 4505,4506,4514,4517 DY3 Local 4457 R(8) 8 scalar 4506,4514,4516,4517 DYP Local 4457 R(8) 8 scalar 4514,4521,4522 DYT Local 4457 R(8) 8 scalar 4503,4514 IGUESS Local 4458 R(8) 8 scalar 4474,4476,4478,4480,4484,4486,4487 ,4488,4489,4492,4501,4514,4515,451 7,4519,4525,4528,4535,4536,4537,45 38,4541,4552 ITER Local 4456 I(4) 4 scalar 4513,4525,4533 ITER_LOOP Label 4513 scalar 4527,4530 IX Dummy 4368 R(8) 8 scalar ARG,OUT 4491,4492,4540,4541 JGUESS Local 4458 R(8) 8 scalar 4474,4476,4478,4480,4484,4486,4487 ,4488,4489,4493,4502,4514,4515,451 6,4518,4525,4529,4535,4536,4537,45 38,4542,4552 JX Dummy 4368 R(8) 8 scalar ARG,OUT 4491,4493,4540,4542 K Local 4456 I(4) 4 scalar 4470,4471,4472,4484,4548,4550 LDBG Local 4455 L(4) 4 scalar 4464,4466,4482,4523 MAT1 Local 4458 R(8) 8 scalar 4516,4520,4522 MAT2 Local 4458 R(8) 8 scalar 4517,4520,4521 MAT3 Local 4458 R(8) 8 scalar 4518,4520,4522 MAT4 Local 4458 R(8) 8 scalar 4519,4520,4521 MAX_ITER Param 4453 I(4) 4 scalar 4513,4533 PRESENT Func 4463 scalar 4463,4485,4491,4500,4534,4540 RW Dummy 4368 R(8) 8 1 4 ARG,OUT 4485,4486,4487,4488,4489,4500,4534 ,4535,4536,4537,4538 W3RMBL_R8 Subr 4368 3132,3714 XS Dummy 4368 R(8) 8 1 4 ARG,IN 4471,4507,4508,4509,4510,4550 XT Dummy 4368 R(8) 8 scalar ARG,IN 4471,4507,4547 YS Dummy 4368 R(8) 8 1 4 ARG,IN 4471,4503,4504,4505,4506,4550 YT Dummy 4368 R(8) 8 scalar ARG,IN 4471,4503,4547 Page 115 Source Listing W3RMBL_R8 2014-11-12 21:37 w3gsrumd.f90 4559 !/ ------------------------------------------------------------------- / 4560 FUNCTION W3DIST_R4(LLG, XT, YT, XS, YS) RESULT(DIST) 4561 !/ 4562 !/ +-----------------------------------+ 4563 !/ | WAVEWATCH III NOAA/NCEP | 4564 !/ | T. J. Campbell, NRL | 4565 !/ | FORTRAN 90 | 4566 !/ | Last update : 12-Nov-2010 | 4567 !/ +-----------------------------------+ 4568 !/ 4569 !/ 30-Oct-2009 : Origination. ( version 3.14 ) 4570 !/ 14-Jun-2010 : Fix for ACOS argument > 1. ( version 3.14 ) 4571 !/ 12-Nov-2010 : Implement r4 & r8 interfaces. ( version 3.14 ) 4572 !/ 4573 ! 1. Purpose : 4574 ! 4575 ! Compute distance between two points. If spherical grid, then 4576 ! distance is the angle (in degrees) between the two points. 4577 ! Single precision interface. 4578 ! 4579 ! 2. Method : 4580 ! 4581 ! 3. Parameters : 4582 ! 4583 ! Parameter list 4584 ! ---------------------------------------------------------------- 4585 ! ---------------------------------------------------------------- 4586 ! 4587 ! 4. Subroutines used : 4588 ! 4589 ! See module documentation. 4590 ! 4591 ! 5. Called by : 4592 ! 4593 ! 6. Error messages : 4594 ! 4595 ! 7. Remarks : 4596 ! 4597 ! 8. Structure : 4598 ! 4599 ! 9. Switches : 4600 ! 4601 ! !/S Enable subroutine tracing. 4602 ! !/T8 Enables NaN check. 4603 ! 4604 ! 10. Source code : 4605 ! 4606 !/ ------------------------------------------------------------------- / 4607 !/ 4608 !/ ------------------------------------------------------------------- / 4609 !/ Return parameter 4610 !/ 4611 REAL(4) :: DIST 4612 !/ 4613 !/ ------------------------------------------------------------------- / 4614 !/ Parameter list 4615 !/ Page 116 Source Listing W3DIST_R4 2014-11-12 21:37 w3gsrumd.f90 4616 LOGICAL, INTENT(IN) :: LLG 4617 REAL(4), INTENT(IN) :: XT, YT 4618 REAL(4), INTENT(IN) :: XS, YS 4619 !/ 4620 !/ ------------------------------------------------------------------- / 4621 !/ Local parameters 4622 !/ 4623 REAL(8) :: DX, DY, ARGD 4624 !/ 4625 ! 4626 ! -------------------------------------------------------------------- / 4627 ! 4628 !-----compute displacements 4629 DX = XT - XS 4630 DY = YT - YS 4631 4632 IF ( LLG ) THEN !spherical coordinates 4633 !---------check for longitudinal branch cut crossing 4634 IF ( ABS(DX) .GT. D270 ) THEN 4635 DX = DX - SIGN(D360,DX) 4636 END IF 4637 !---------compute angular distance (min required for rare 4638 ! situation of acos(1+small) generating NaN) 4639 ARGD = MIN( ONE, COS(YT*D2R)*COS(YS*D2R)*COS(DX*D2R) & 4640 + SIN(YT*D2R)*SIN(YS*D2R) ) 4641 DIST = R2D*ACOS( ARGD ) 4642 ELSE !cartesian coordinates 4643 !---------compute cartesian distance 4644 DIST = SQRT( DX**2 + DY**2 ) 4645 END IF !cartesian coordinates 4646 !/ 4647 !/ End of W3DIST_R4 -------------------------------------------------- / 4648 !/ 4649 END FUNCTION W3DIST_R4 Page 117 Source Listing W3DIST_R4 2014-11-12 21:37 Entry Points w3gsrumd.f90 ENTRY POINTS Name w3gsrumd_mp_w3dist_r4_ SYMBOL CROSS REFERENCE Name Object Declared Type Bytes Dimen Elements Attributes References ABS Func 4634 scalar PRIV 4634 ACOS Func 4641 scalar PRIV 4641 ARGD Local 4623 R(8) 8 scalar 4639,4641 COS Func 4639 scalar PRIV 4639 D270 Param 4634 R(8) 8 scalar 4634,4725 D2R Param 4639 R(8) 8 scalar 278,4639,4640,4730,4731 DIST Local 4611 R(4) 4 scalar 4641,4644 DX Local 4623 R(8) 8 scalar 4629,4634,4635,4639,4644 DY Local 4623 R(8) 8 scalar 4630,4644 LLG Dummy 4560 L(4) 4 scalar ARG,IN,PRIV 4632 MIN Func 4639 scalar PRIV 4639 R2D Param 4641 R(8) 8 scalar 4641,4732 SIGN Func 4635 scalar PRIV 4635 SIN Func 4640 scalar PRIV 4640 SQRT Func 4644 scalar PRIV 4644 W3DIST_R4 Func 4560 R(4) 4 scalar PRIV 2720,3354,3416,3469 XS Dummy 4560 R(4) 4 scalar ARG,IN,PRIV 4629 XT Dummy 4560 R(4) 4 scalar ARG,IN,PRIV 4629 YS Dummy 4560 R(4) 4 scalar ARG,IN,PRIV 4630,4639,4640 YT Dummy 4560 R(4) 4 scalar ARG,IN,PRIV 4630,4639,4640 Page 118 Source Listing W3DIST_R4 2014-11-12 21:37 w3gsrumd.f90 4650 !/ ------------------------------------------------------------------- / 4651 FUNCTION W3DIST_R8(LLG, XT, YT, XS, YS) RESULT(DIST) 4652 !/ 4653 !/ +-----------------------------------+ 4654 !/ | WAVEWATCH III NOAA/NCEP | 4655 !/ | T. J. Campbell, NRL | 4656 !/ | FORTRAN 90 | 4657 !/ | Last update : 12-Nov-2010 | 4658 !/ +-----------------------------------+ 4659 !/ 4660 !/ 30-Oct-2009 : Origination. ( version 3.14 ) 4661 !/ 14-Jun-2010 : Fix for ACOS argument > 1. ( version 3.14 ) 4662 !/ 12-Nov-2010 : Implement r4 & r8 interfaces. ( version 3.14 ) 4663 !/ 4664 ! 1. Purpose : 4665 ! 4666 ! Compute distance between two points. If spherical grid, then 4667 ! distance is the angle (in degrees) between the two points. 4668 ! Double precision interface. 4669 ! 4670 ! 2. Method : 4671 ! 4672 ! 3. Parameters : 4673 ! 4674 ! Parameter list 4675 ! ---------------------------------------------------------------- 4676 ! ---------------------------------------------------------------- 4677 ! 4678 ! 4. Subroutines used : 4679 ! 4680 ! See module documentation. 4681 ! 4682 ! 5. Called by : 4683 ! 4684 ! 6. Error messages : 4685 ! 4686 ! 7. Remarks : 4687 ! 4688 ! 8. Structure : 4689 ! 4690 ! 9. Switches : 4691 ! 4692 ! !/S Enable subroutine tracing. 4693 ! !/T8 Enables NaN check. 4694 ! 4695 ! 10. Source code : 4696 ! 4697 !/ ------------------------------------------------------------------- / 4698 !/ 4699 !/ ------------------------------------------------------------------- / 4700 !/ Return parameter 4701 !/ 4702 REAL(8) :: DIST 4703 !/ 4704 !/ ------------------------------------------------------------------- / 4705 !/ Parameter list 4706 !/ Page 119 Source Listing W3DIST_R8 2014-11-12 21:37 w3gsrumd.f90 4707 LOGICAL, INTENT(IN) :: LLG 4708 REAL(8), INTENT(IN) :: XT, YT 4709 REAL(8), INTENT(IN) :: XS, YS 4710 !/ 4711 !/ ------------------------------------------------------------------- / 4712 !/ Local parameters 4713 !/ 4714 REAL(8) :: DX, DY, ARGD 4715 !/ 4716 ! 4717 ! -------------------------------------------------------------------- / 4718 ! 4719 !-----compute displacements 4720 DX = XT - XS 4721 DY = YT - YS 4722 4723 IF ( LLG ) THEN !spherical coordinates 4724 !---------check for longitudinal branch cut crossing 4725 IF ( ABS(DX) .GT. D270 ) THEN 4726 DX = DX - SIGN(D360,DX) 4727 END IF 4728 !---------compute angular distance (min required for rare 4729 ! situation of acos(1+small) generating NaN) 4730 ARGD = MIN( ONE, COS(YT*D2R)*COS(YS*D2R)*COS(DX*D2R) & 4731 + SIN(YT*D2R)*SIN(YS*D2R) ) 4732 DIST = R2D*ACOS( ARGD ) 4733 ELSE !cartesian coordinates 4734 !---------compute cartesian distance 4735 DIST = SQRT( DX**2 + DY**2 ) 4736 END IF !cartesian coordinates 4737 !/ 4738 !/ End of W3DIST_R8 -------------------------------------------------- / 4739 !/ 4740 END FUNCTION W3DIST_R8 Page 120 Source Listing W3DIST_R8 2014-11-12 21:37 Entry Points w3gsrumd.f90 ENTRY POINTS Name w3gsrumd_mp_w3dist_r8_ SYMBOL CROSS REFERENCE Name Object Declared Type Bytes Dimen Elements Attributes References ABS Func 4725 scalar PRIV 4725 ACOS Func 4732 scalar PRIV 4732 ARGD Local 4714 R(8) 8 scalar 4730,4732 COS Func 4730 scalar PRIV 4730 DIST Local 4702 R(8) 8 scalar 4732,4735 DX Local 4714 R(8) 8 scalar 4720,4725,4726,4730,4735 DY Local 4714 R(8) 8 scalar 4721,4735 LLG Dummy 4651 L(4) 4 scalar ARG,IN,PRIV 4723 MIN Func 4730 scalar PRIV 4730 SIGN Func 4726 scalar PRIV 4726 SIN Func 4731 scalar PRIV 4731 SQRT Func 4735 scalar PRIV 4735 W3DIST_R8 Func 4651 R(8) 8 scalar PRIV 2862,3726,3788,3841 XS Dummy 4651 R(8) 8 scalar ARG,IN,PRIV 4720 XT Dummy 4651 R(8) 8 scalar ARG,IN,PRIV 4720 YS Dummy 4651 R(8) 8 scalar ARG,IN,PRIV 4721,4730,4731 YT Dummy 4651 R(8) 8 scalar ARG,IN,PRIV 4721,4730,4731 Page 121 Source Listing W3DIST_R8 2014-11-12 21:37 w3gsrumd.f90 4741 !/ ------------------------------------------------------------------- / 4742 FUNCTION W3CKCL_R4(LLG, XT, YT, NS, XS, YS, POLE, DEBUG) & 4743 RESULT(INCELL) 4744 !/ 4745 !/ +-----------------------------------+ 4746 !/ | WAVEWATCH III NOAA/NCEP | 4747 !/ | T. J. Campbell, NRL | 4748 !/ | FORTRAN 90 | 4749 !/ | Last update : 06-Dec-2010 | 4750 !/ +-----------------------------------+ 4751 !/ 4752 !/ 30-Oct-2009 : Origination. ( version 3.14 ) 4753 !/ 12-Nov-2010 : Add subcell check for grid cell that includes a pole. 4754 !/ Implement r4 & r8 interfaces. ( version 3.14 ) 4755 !/ 06-Dec-2010 : Remove restriction on longitude range. Change ICLO 4756 !/ to integer and remove JCLO. ( version 3.14 ) 4757 !/ 4758 ! 1. Purpose : 4759 ! 4760 ! Check if point lies within grid cell. 4761 ! 4762 ! 2. Method : 4763 ! 4764 ! Calculates cross products for vertex to vertex (i.e. cell side) 4765 ! vs vertex to target. If all cross products have the same sign, 4766 ! the point is considered to be within the cell. Since they can 4767 ! be "all positive" *or* "all negative", there are no pre-conditions 4768 ! that the order of specification of the vertices be clockwise vs. 4769 ! counter-clockwise geographically. The logical variable POLE is 4770 ! set to true if the grid cell includes a pole. 4771 ! Single precision interface. 4772 ! 4773 ! 3. Parameters : 4774 ! 4775 ! Parameter list 4776 ! ---------------------------------------------------------------- 4777 ! ---------------------------------------------------------------- 4778 ! 4779 ! 4. Subroutines used : 4780 ! 4781 ! See module documentation. 4782 ! 4783 ! 5. Called by : 4784 ! 4785 ! 6. Error messages : 4786 ! 4787 ! 7. Remarks : 4788 ! 4789 ! - For LL grids, this method assumes that the longitudes of point 4790 ! and grid cell vertices lie in the same range (i.e., both in [0:360] 4791 ! or [-180:180]). If the longitudes are not in the same range, then 4792 ! this method may result in a false positive. The burden is upon the 4793 ! caller to ensure that the longitude range of the point is the same 4794 ! as that of the grid cell vertices. 4795 ! - If enclosing cell includes a branch cut, then the coordinates of 4796 ! of the cell vertices AND the target point will be adjusted so 4797 ! that the branch cut is shifted 180 degrees. Page 122 Source Listing W3CKCL_R4 2014-11-12 21:37 w3gsrumd.f90 4798 ! - If the enclosing cell includes a pole, then the cross-product check 4799 ! is performed for each quadrilateral subcell (with two cell 4800 ! vertices at the pole). 4801 ! 4802 ! 8. Structure : 4803 ! 4804 ! 9. Switches : 4805 ! 4806 ! !/S Enable subroutine tracing. 4807 ! 4808 ! 10. Source code : 4809 ! 4810 !/ ------------------------------------------------------------------- / 4811 !/ 4812 !/ ------------------------------------------------------------------- / 4813 !/ Return parameter 4814 !/ 4815 LOGICAL :: INCELL 4816 !/ 4817 !/ ------------------------------------------------------------------- / 4818 !/ Parameter list 4819 !/ 4820 LOGICAL, INTENT(IN) :: LLG 4821 REAL(4), INTENT(INOUT) :: XT, YT 4822 INTEGER, INTENT(IN) :: NS 4823 REAL(4), INTENT(INOUT) :: XS(NS), YS(NS) 4824 LOGICAL, INTENT(OUT):: POLE 4825 LOGICAL, INTENT(IN), OPTIONAL :: DEBUG 4826 !/ 4827 !/ ------------------------------------------------------------------- / 4828 !/ Local parameters 4829 !/ 4830 REAL(8), PARAMETER :: SMALL = 1D-6 4831 LOGICAL :: LDBG, LSBC, BCUT 4832 INTEGER :: I, J, K, N 4833 REAL(8) :: XXT, YYT, XXS(NS), YYS(NS) 4834 REAL(8) :: V1X, V1Y, V2X, V2Y, S90 4835 REAL(8) :: CROSS 4836 REAL(8) :: SIGN1 4837 !/ 4838 ! 4839 ! -------------------------------------------------------------------- / 4840 ! 4841 INCELL = .TRUE. 4842 ! 4843 !-----must have >= 3 points to be a cell 4844 IF ( NS .LT. 3 ) THEN 4845 INCELL = .FALSE. 4846 RETURN 4847 END IF 4848 ! 4849 IF ( PRESENT(DEBUG) ) THEN 4850 LDBG = DEBUG 4851 ELSE 4852 LDBG = .FALSE. 4853 END IF 4854 ! Page 123 Source Listing W3CKCL_R4 2014-11-12 21:37 w3gsrumd.f90 4855 !-----copy into locals 4856 XXT = XT; XXS = XS; 4857 YYT = YT; YYS = YS; 4858 ! 4859 !-----check if cell includes a pole or branch cut 4860 IF ( LLG ) THEN 4861 N = 0 4862 !---------count longitudinal branch cut crossings 4863 DO I=1,NS 4864 J = MOD(I,NS) + 1 4865 IF ( ABS(XXS(J)-XXS(I)) .GT. D180 ) N = N + 1 4866 END DO 4867 !---------multiple longitudinal branch cut crossing => cell includes branch cut 4868 BCUT = N.GT.1 4869 IF ( BCUT .AND. LDBG ) & 4870 WRITE(*,'(A)') 'W3CKCL_R4 - CELL INCLUDES A BRANCH CUT' 4871 !---------single longitudinal branch cut crossing 4872 ! or single vertex at 90 degrees => cell includes pole 4873 POLE = N.EQ.1 .OR. COUNT(ABS(YYS).EQ.D90).EQ.1 4874 IF ( POLE .AND. LDBG ) & 4875 WRITE(*,'(A)') 'W3CKCL_R4 - CELL INCLUDES A POLE' 4876 ELSE 4877 POLE = .FALSE. 4878 BCUT = .FALSE. 4879 END IF 4880 ! 4881 !-----handle cell that includes a pole 4882 IF ( POLE ) THEN 4883 S90 = D90; IF ( MAXVAL(YS).LT.ZERO ) S90 = -D90; 4884 !---------perform cross-product check for each subcell 4885 SUBCELL_LOOP: DO I=1,NS 4886 LSBC = .TRUE. 4887 J = MOD(I,NS) + 1 4888 DO K=1,4 4889 SELECT CASE (K) 4890 CASE (1) 4891 !---------------------vector from (xi,yi) to (xj,yj) 4892 V1X = XXS(J) - XXS(I) 4893 V1Y = YYS(J) - YYS(I) 4894 !---------------------vector from (xi,yi) to (xt,yt) 4895 V2X = XXT - XXS(I) 4896 V2Y = YYT - YYS(I) 4897 CASE (2) 4898 !---------------------vector from (xj,yj) to (xj,90) 4899 V1X = XXS(J) - XXS(J) 4900 V1Y = S90 - YYS(J) 4901 !---------------------vector from (xj,yj) to (xt,yt) 4902 V2X = XXT - XXS(J) 4903 V2Y = YYT - YYS(J) 4904 CASE (3) 4905 !---------------------vector from (xj,90) to (xi,90) 4906 V1X = XXS(I) - XXS(J) 4907 V1Y = S90 - S90 4908 !---------------------vector from (xj,90) to (xt,yt) 4909 V2X = XXT - XXS(J) 4910 V2Y = YYT - S90 4911 CASE (4) Page 124 Source Listing W3CKCL_R4 2014-11-12 21:37 w3gsrumd.f90 4912 !---------------------vector from (xi,90) to (xi,yi) 4913 V1X = XXS(I) - XXS(I) 4914 V1Y = YYS(I) - S90 4915 !---------------------vector from (xi,90) to (xt,yt) 4916 V2X = XXT - XXS(I) 4917 V2Y = YYT - S90 4918 END SELECT 4919 !-----------------check for longitudinal branch cut crossing 4920 IF ( ABS(V1X) .GT. D180 ) THEN 4921 V1X = V1X - SIGN(D360,V1X) 4922 END IF 4923 IF ( ABS(V2X) .GT. D180 ) THEN 4924 V2X = V2X - SIGN(D360,V2X) 4925 END IF 4926 !-----------------cross product 4927 CROSS = V1X*V2Y - V1Y*V2X 4928 IF ( LDBG ) & 4929 WRITE(*,'(A,3(I1,A),5E14.6)') 'W3CKCL_R4 - CROSS(', & 4930 I,',',J,',',K,'):',V1X,V1Y,V2X,V2Y,CROSS 4931 !-----------------if sign of cross product is not "unanimous" among the 4932 ! subcell sides, then target is outside the subcell 4933 IF ( K .EQ. 1 ) THEN 4934 SIGN1 = SIGN(ONE,CROSS) 4935 ELSE 4936 IF ( SIGN(ONE,CROSS) .NE. SIGN1 ) THEN 4937 LSBC = .FALSE. 4938 CYCLE SUBCELL_LOOP 4939 END IF 4940 END IF 4941 END DO !K 4942 IF ( LSBC ) RETURN 4943 END DO SUBCELL_LOOP 4944 INCELL = .FALSE. 4945 RETURN 4946 END IF !POLE 4947 ! 4948 !-----shift branch cut if necessary 4949 IF ( BCUT ) THEN 4950 IF ( MINVAL(XXS) .GE. ZERO ) THEN 4951 WHERE ( XXS .GT. D180 ) XXS = XXS - D360 4952 IF ( XXT .GT. D180 ) XXT = XXT - D360 4953 ELSE 4954 WHERE ( XXS .LT. ZERO ) XXS = XXS + D360 4955 IF ( XXT .LT. ZERO ) XXT = XXT + D360 4956 END IF 4957 IF ( LDBG ) THEN 4958 WRITE(*,'(A,2E14.6,4(/A,1I1,A,2E14.6))') & 4959 'W3CKCL_R4 - SHIFT BRANCH CUT:',XXT,YYT, & 4960 (' CORNER(',K,'):',XXS(K),YYS(K),K=1,4) 4961 END IF 4962 END IF 4963 ! 4964 !-----check if target point lies outside cell bounding box 4965 IF ( XXT.LT.MINVAL(XXS) .OR. XXT.GT.MAXVAL(XXS) .OR. & 4966 YYT.LT.MINVAL(YYS) .OR. YYT.GT.MAXVAL(YYS) ) THEN 4967 IF ( LDBG ) THEN 4968 WRITE(*,'(A)') & Page 125 Source Listing W3CKCL_R4 2014-11-12 21:37 w3gsrumd.f90 4969 'W3CKCL_R4 - TARGET POINT LIES OUTSIDE CELL BOUNDING BOX' 4970 WRITE(*,'(A,2E14.6)') 'W3CKCL_R4 - TARGET: ',XXT,YYT 4971 WRITE(*,'(A,4E14.6)') 'W3CKCL_R4 - SOURCE: ', & 4972 MINVAL(XXS),MAXVAL(XXS),MINVAL(YYS),MAXVAL(YYS) 4973 END IF 4974 INCELL = .FALSE. 4975 RETURN 4976 END IF 4977 ! 4978 !-----perform cross-product cell check 4979 CORNER_LOOP: DO I=1,NS 4980 J = MOD(I,NS) + 1 4981 !---------if target point is coincident a cell vertex, then 4982 ! exit cross-product check (flag as in cell) 4983 IF ( ABS(XXT-XXS(I)).LT.SMALL .AND. & 4984 & ABS(YYT-YYS(I)).LT.SMALL ) EXIT CORNER_LOOP 4985 !---------vector from (xi,yi) to (xj,yj) 4986 V1X = XXS(J) - XXS(I) 4987 V1Y = YYS(J) - YYS(I) 4988 !---------vector from (xi,yi) to (xt,yt) 4989 V2X = XXT - XXS(I) 4990 V2Y = YYT - YYS(I) 4991 !---------cross product 4992 CROSS = V1X*V2Y - V1Y*V2X 4993 IF ( LDBG ) & 4994 WRITE(*,'(A,2(I1,A),5E14.6)') 'W3CKCL_R4 - CROSS(', & 4995 I,',',J,'):',V1X,V1Y,V2X,V2Y,CROSS 4996 !---------if sign of cross product is not "unanimous" among the cell sides, 4997 ! then target is outside the cell 4998 IF ( I .EQ. 1 ) THEN 4999 SIGN1 = SIGN(ONE,CROSS) 5000 ELSE 5001 IF ( SIGN(ONE,CROSS) .NE. SIGN1 ) THEN 5002 INCELL = .FALSE. 5003 RETURN 5004 END IF 5005 END IF 5006 END DO CORNER_LOOP 5007 ! 5008 !-----return branch cut shifted coordinates 5009 IF ( BCUT ) THEN 5010 XT = XXT; XS = XXS; 5011 END IF 5012 !/ 5013 !/ End of W3CKCL_R4 -------------------------------------------------- / 5014 !/ 5015 END FUNCTION W3CKCL_R4 Page 126 Source Listing W3CKCL_R4 2014-11-12 21:37 Entry Points w3gsrumd.f90 ENTRY POINTS Name w3gsrumd_mp_w3ckcl_r4_ SYMBOL CROSS REFERENCE Name Object Declared Type Bytes Dimen Elements Attributes References ABS Func 4865 scalar PRIV 4865,4873,4920,4923,4983,4984 BCUT Local 4831 L(4) 4 scalar 4868,4869,4878,4949,5009 CORNER_LOOP Label 4979 scalar 4984,5006 COUNT Func 4873 scalar PRIV 4873 CROSS Local 4835 R(8) 8 scalar 4927,4930,4934,4936,4992,4995,4999 ,5001 DEBUG Dummy 4742 L(4) 4 scalar ARG,IN,PRIV 4849,4850 I Local 4832 I(4) 4 scalar 4863,4864,4865,4885,4887,4892,4893 ,4895,4896,4906,4913,4914,4916,493 0,4979,4980,4983,4984,4986,4987,49 89,4990,4995,4998 INCELL Local 4815 L(4) 4 scalar 4841,4845,4944,4974,5002 J Local 4832 I(4) 4 scalar 4864,4865,4887,4892,4893,4899,4900 ,4902,4903,4906,4909,4930,4980,498 6,4987,4995 K Local 4832 I(4) 4 scalar 4888,4889,4930,4933,4960 LDBG Local 4831 L(4) 4 scalar 4850,4852,4869,4874,4928,4957,4967 ,4993 LLG Dummy 4742 L(4) 4 scalar ARG,IN,PRIV 4860 LSBC Local 4831 L(4) 4 scalar 4886,4937,4942 MAXVAL Func 4883 scalar PRIV 4883,4965,4966,4972 MINVAL Func 4950 scalar PRIV 4950,4965,4966,4972 MOD Func 4864 scalar PRIV 4864,4887,4980 N Local 4832 I(4) 4 scalar 4861,4865,4868,4873 NS Dummy 4742 I(4) 4 scalar ARG,IN,PRIV 4823,4833,4844,4863,4864,4885,4887 ,4979,4980 POLE Dummy 4742 L(4) 4 scalar ARG,OUT,PRIV 4873,4874,4877,4882 PRESENT Func 4849 scalar PRIV 4849 S90 Local 4834 R(8) 8 scalar 4883,4900,4907,4910,4914,4917 SIGN Func 4921 scalar PRIV 4921,4924,4934,4936,4999,5001 SIGN1 Local 4836 R(8) 8 scalar 4934,4936,4999,5001 SMALL Param 4830 R(8) 8 scalar 4983,4984 SUBCELL_LOOP Label 4885 scalar 4938,4943 V1X Local 4834 R(8) 8 scalar 4892,4899,4906,4913,4920,4921,4927 ,4930,4986,4992,4995 V1Y Local 4834 R(8) 8 scalar 4893,4900,4907,4914,4927,4930,4987 ,4992,4995 V2X Local 4834 R(8) 8 scalar 4895,4902,4909,4916,4923,4924,4927 ,4930,4989,4992,4995 V2Y Local 4834 R(8) 8 scalar 4896,4903,4910,4917,4927,4930,4990 ,4992,4995 W3CKCL_R4 Func 4742 L(4) 4 scalar PRIV 1874,2345 XS Dummy 4742 R(4) 4 1 0 ARG,INOUT,PRIV 4856,5010 XT Dummy 4742 R(4) 4 scalar ARG,INOUT,PRIV 4856,5010 Page 127 Source Listing W3CKCL_R4 2014-11-12 21:37 Symbol Table w3gsrumd.f90 Name Object Declared Type Bytes Dimen Elements Attributes References XXS Local 4833 R(8) 8 1 0 4856,4865,4892,4895,4899,4902,4906 ,4909,4913,4916,4950,4951,4954,496 0,4965,4972,4983,4986,4989,5010 XXT Local 4833 R(8) 8 scalar 4856,4895,4902,4909,4916,4952,4955 ,4959,4965,4970,4983,4989,5010 YS Dummy 4742 R(4) 4 1 0 ARG,INOUT,PRIV 4857,4883 YT Dummy 4742 R(4) 4 scalar ARG,INOUT,PRIV 4857 YYS Local 4833 R(8) 8 1 0 4857,4873,4893,4896,4900,4903,4914 ,4960,4966,4972,4984,4987,4990 YYT Local 4833 R(8) 8 scalar 4857,4896,4903,4910,4917,4959,4966 ,4970,4984,4990 Page 128 Source Listing W3CKCL_R4 2014-11-12 21:37 w3gsrumd.f90 5016 !/ ------------------------------------------------------------------- / 5017 FUNCTION W3CKCL_R8(LLG, XT, YT, NS, XS, YS, POLE, DEBUG) & 5018 RESULT(INCELL) 5019 !/ 5020 !/ +-----------------------------------+ 5021 !/ | WAVEWATCH III NOAA/NCEP | 5022 !/ | T. J. Campbell, NRL | 5023 !/ | FORTRAN 90 | 5024 !/ | Last update : 06-Dec-2010 | 5025 !/ +-----------------------------------+ 5026 !/ 5027 !/ 30-Oct-2009 : Origination. ( version 3.14 ) 5028 !/ 12-Nov-2010 : Add subcell check for grid cell that includes a pole. 5029 !/ Implement r4 & r8 interfaces. ( version 3.14 ) 5030 !/ 06-Dec-2010 : Remove restriction on longitude range. Change ICLO 5031 !/ to integer and remove JCLO. ( version 3.14 ) 5032 !/ 5033 ! 1. Purpose : 5034 ! 5035 ! Check if point lies within grid cell. 5036 ! 5037 ! 2. Method : 5038 ! 5039 ! Calculates cross products for vertex to vertex (i.e. cell side) 5040 ! vs vertex to target. If all cross products have the same sign, 5041 ! the point is considered to be within the cell. Since they can 5042 ! be "all positive" *or* "all negative", there are no pre-conditions 5043 ! that the order of specification of the vertices be clockwise vs. 5044 ! counter-clockwise geographically. The logical variable POLE is 5045 ! set to true if the grid cell includes a pole. 5046 ! Double precision interface. 5047 ! 5048 ! 3. Parameters : 5049 ! 5050 ! Parameter list 5051 ! ---------------------------------------------------------------- 5052 ! ---------------------------------------------------------------- 5053 ! 5054 ! 4. Subroutines used : 5055 ! 5056 ! See module documentation. 5057 ! 5058 ! 5. Called by : 5059 ! 5060 ! 6. Error messages : 5061 ! 5062 ! 7. Remarks : 5063 ! 5064 ! - For LL grids, this method assumes that the longitudes of point 5065 ! and grid cell vertices lie in the same range (i.e., both in [0:360] 5066 ! or [-180:180]). If the longitudes are not in the same range, then 5067 ! this method may result in a false positive. The burden is upon the 5068 ! caller to ensure that the longitude range of the point is the same 5069 ! as that of the grid cell vertices. 5070 ! - If enclosing cell includes a branch cut, then the coordinates of 5071 ! of the cell vertices AND the target point will be adjusted so 5072 ! that the branch cut is shifted 180 degrees. Page 129 Source Listing W3CKCL_R8 2014-11-12 21:37 w3gsrumd.f90 5073 ! - If the enclosing cell includes a pole, then the cross-product check 5074 ! is performed for each quadrilateral subcell (with two cell 5075 ! vertices at the pole). 5076 ! 5077 ! 8. Structure : 5078 ! 5079 ! 9. Switches : 5080 ! 5081 ! !/S Enable subroutine tracing. 5082 ! 5083 ! 10. Source code : 5084 ! 5085 !/ ------------------------------------------------------------------- / 5086 !/ 5087 !/ ------------------------------------------------------------------- / 5088 !/ Return parameter 5089 !/ 5090 LOGICAL :: INCELL 5091 !/ 5092 !/ ------------------------------------------------------------------- / 5093 !/ Parameter list 5094 !/ 5095 LOGICAL, INTENT(IN) :: LLG 5096 REAL(8), INTENT(INOUT) :: XT, YT 5097 INTEGER, INTENT(IN) :: NS 5098 REAL(8), INTENT(INOUT) :: XS(NS), YS(NS) 5099 LOGICAL, INTENT(OUT):: POLE 5100 LOGICAL, INTENT(IN), OPTIONAL :: DEBUG 5101 !/ 5102 !/ ------------------------------------------------------------------- / 5103 !/ Local parameters 5104 !/ 5105 REAL(8), PARAMETER :: SMALL = 1D-6 5106 LOGICAL :: LDBG, LSBC, BCUT 5107 INTEGER :: I, J, K, N 5108 REAL(8) :: XXT, YYT, XXS(NS), YYS(NS) 5109 REAL(8) :: V1X, V1Y, V2X, V2Y, S90 5110 REAL(8) :: CROSS 5111 REAL(8) :: SIGN1 5112 !/ 5113 ! 5114 ! -------------------------------------------------------------------- / 5115 ! 5116 INCELL = .TRUE. 5117 ! 5118 !-----must have >= 3 points to be a cell 5119 IF ( NS .LT. 3 ) THEN 5120 INCELL = .FALSE. 5121 RETURN 5122 END IF 5123 ! 5124 IF ( PRESENT(DEBUG) ) THEN 5125 LDBG = DEBUG 5126 ELSE 5127 LDBG = .FALSE. 5128 END IF 5129 ! Page 130 Source Listing W3CKCL_R8 2014-11-12 21:37 w3gsrumd.f90 5130 !-----copy into locals 5131 XXT = XT; XXS = XS; 5132 YYT = YT; YYS = YS; 5133 ! 5134 !-----check if cell includes a pole or branch cut 5135 IF ( LLG ) THEN 5136 N = 0 5137 !---------count longitudinal branch cut crossings 5138 DO I=1,NS 5139 J = MOD(I,NS) + 1 5140 IF ( ABS(XXS(J)-XXS(I)) .GT. D180 ) N = N + 1 5141 END DO 5142 !---------multiple longitudinal branch cut crossing => cell includes branch cut 5143 BCUT = N.GT.1 5144 IF ( BCUT .AND. LDBG ) & 5145 WRITE(*,'(A)') 'W3CKCL_R8 - CELL INCLUDES A BRANCH CUT' 5146 !---------single longitudinal branch cut crossing 5147 ! or single vertex at 90 degrees => cell includes pole 5148 POLE = N.EQ.1 .OR. COUNT(ABS(YYS).EQ.D90).EQ.1 5149 IF ( POLE .AND. LDBG ) & 5150 WRITE(*,'(A)') 'W3CKCL_R8 - CELL INCLUDES A POLE' 5151 ELSE 5152 POLE = .FALSE. 5153 BCUT = .FALSE. 5154 END IF 5155 ! 5156 !-----handle cell that includes a pole 5157 IF ( POLE ) THEN 5158 S90 = D90; IF ( MAXVAL(YS).LT.ZERO ) S90 = -D90; 5159 !---------perform cross-product check for each subcell 5160 SUBCELL_LOOP: DO I=1,NS 5161 LSBC = .TRUE. 5162 J = MOD(I,NS) + 1 5163 DO K=1,4 5164 SELECT CASE (K) 5165 CASE (1) 5166 !---------------------vector from (xi,yi) to (xj,yj) 5167 V1X = XXS(J) - XXS(I) 5168 V1Y = YYS(J) - YYS(I) 5169 !---------------------vector from (xi,yi) to (xt,yt) 5170 V2X = XXT - XXS(I) 5171 V2Y = YYT - YYS(I) 5172 CASE (2) 5173 !---------------------vector from (xj,yj) to (xj,90) 5174 V1X = XXS(J) - XXS(J) 5175 V1Y = S90 - YYS(J) 5176 !---------------------vector from (xj,yj) to (xt,yt) 5177 V2X = XXT - XXS(J) 5178 V2Y = YYT - YYS(J) 5179 CASE (3) 5180 !---------------------vector from (xj,90) to (xi,90) 5181 V1X = XXS(I) - XXS(J) 5182 V1Y = S90 - S90 5183 !---------------------vector from (xj,90) to (xt,yt) 5184 V2X = XXT - XXS(J) 5185 V2Y = YYT - S90 5186 CASE (4) Page 131 Source Listing W3CKCL_R8 2014-11-12 21:37 w3gsrumd.f90 5187 !---------------------vector from (xi,90) to (xi,yi) 5188 V1X = XXS(I) - XXS(I) 5189 V1Y = YYS(I) - S90 5190 !---------------------vector from (xi,90) to (xt,yt) 5191 V2X = XXT - XXS(I) 5192 V2Y = YYT - S90 5193 END SELECT 5194 !-----------------check for longitudinal branch cut crossing 5195 IF ( ABS(V1X) .GT. D180 ) THEN 5196 V1X = V1X - SIGN(D360,V1X) 5197 END IF 5198 IF ( ABS(V2X) .GT. D180 ) THEN 5199 V2X = V2X - SIGN(D360,V2X) 5200 END IF 5201 !-----------------cross product 5202 CROSS = V1X*V2Y - V1Y*V2X 5203 IF ( LDBG ) & 5204 WRITE(*,'(A,3(I1,A),5E14.6)') 'W3CKCL_R4 - CROSS(', & 5205 I,',',J,',',K,'):',V1X,V1Y,V2X,V2Y,CROSS 5206 !-----------------if sign of cross product is not "unanimous" among the 5207 ! subcell sides, then target is outside the subcell 5208 IF ( K .EQ. 1 ) THEN 5209 SIGN1 = SIGN(ONE,CROSS) 5210 ELSE 5211 IF ( SIGN(ONE,CROSS) .NE. SIGN1 ) THEN 5212 LSBC = .FALSE. 5213 CYCLE SUBCELL_LOOP 5214 END IF 5215 END IF 5216 END DO !K 5217 IF ( LSBC ) RETURN 5218 END DO SUBCELL_LOOP 5219 INCELL = .FALSE. 5220 RETURN 5221 END IF !POLE 5222 ! 5223 !-----shift branch cut if necessary 5224 IF ( BCUT ) THEN 5225 IF ( MINVAL(XXS) .GE. ZERO ) THEN 5226 WHERE ( XXS .GT. D180 ) XXS = XXS - D360 5227 IF ( XXT .GT. D180 ) XXT = XXT - D360 5228 ELSE 5229 WHERE ( XXS .LT. ZERO ) XXS = XXS + D360 5230 IF ( XXT .LT. ZERO ) XXT = XXT + D360 5231 END IF 5232 IF ( LDBG ) THEN 5233 WRITE(*,'(A,2E14.6,4(/A,1I1,A,2E14.6))') & 5234 'W3CKCL_R8 - SHIFT BRANCH CUT:',XXT,YYT, & 5235 (' CORNER(',K,'):',XXS(K),YYS(K),K=1,4) 5236 END IF 5237 END IF 5238 ! 5239 !-----check if target point lies outside cell bounding box 5240 IF ( XXT.LT.MINVAL(XXS) .OR. XXT.GT.MAXVAL(XXS) .OR. & 5241 YYT.LT.MINVAL(YYS) .OR. YYT.GT.MAXVAL(YYS) ) THEN 5242 IF ( LDBG ) THEN 5243 WRITE(*,'(A)') & Page 132 Source Listing W3CKCL_R8 2014-11-12 21:37 w3gsrumd.f90 5244 'W3CKCL_R8 - TARGET POINT LIES OUTSIDE CELL BOUNDING BOX' 5245 WRITE(*,'(A,2E14.6)') 'W3CKCL_R8 - TARGET: ',XXT,YYT 5246 WRITE(*,'(A,4E14.6)') 'W3CKCL_R8 - SOURCE: ', & 5247 MINVAL(XXS),MAXVAL(XXS),MINVAL(YYS),MAXVAL(YYS) 5248 END IF 5249 INCELL = .FALSE. 5250 RETURN 5251 END IF 5252 ! 5253 !-----perform cross-product cell check 5254 CORNER_LOOP: DO I=1,NS 5255 J = MOD(I,NS) + 1 5256 !---------if target point is coincident a cell vertex, then 5257 ! exit cross-product check (flag as in cell) 5258 IF ( ABS(XXT-XXS(I)).LT.SMALL .AND. & 5259 & ABS(YYT-YYS(I)).LT.SMALL ) EXIT CORNER_LOOP 5260 !---------vector from (xi,yi) to (xj,yj) 5261 V1X = XXS(J) - XXS(I) 5262 V1Y = YYS(J) - YYS(I) 5263 !---------vector from (xi,yi) to (xt,yt) 5264 V2X = XXT - XXS(I) 5265 V2Y = YYT - YYS(I) 5266 !---------cross product 5267 CROSS = V1X*V2Y - V1Y*V2X 5268 IF ( LDBG ) & 5269 WRITE(*,'(A,2(I1,A),5E14.6)') 'W3CKCL_R8 - CROSS(', & 5270 I,',',J,'):',V1X,V1Y,V2X,V2Y,CROSS 5271 !---------if sign of cross product is not "unanimous" among the cell sides, 5272 ! then target is outside the cell 5273 IF ( I .EQ. 1 ) THEN 5274 SIGN1 = SIGN(ONE,CROSS) 5275 ELSE 5276 IF ( SIGN(ONE,CROSS) .NE. SIGN1 ) THEN 5277 INCELL = .FALSE. 5278 RETURN 5279 END IF 5280 END IF 5281 END DO CORNER_LOOP 5282 ! 5283 !-----return branch cut shifted coordinates 5284 IF ( BCUT ) THEN 5285 XT = XXT; XS = XXS; 5286 END IF 5287 !/ 5288 !/ End of W3CKCL_R8 -------------------------------------------------- / 5289 !/ 5290 END FUNCTION W3CKCL_R8 Page 133 Source Listing W3CKCL_R8 2014-11-12 21:37 Entry Points w3gsrumd.f90 ENTRY POINTS Name w3gsrumd_mp_w3ckcl_r8_ SYMBOL CROSS REFERENCE Name Object Declared Type Bytes Dimen Elements Attributes References ABS Func 5140 scalar PRIV 5140,5148,5195,5198,5258,5259 BCUT Local 5106 L(4) 4 scalar 5143,5144,5153,5224,5284 CORNER_LOOP Label 5254 scalar 5259,5281 COUNT Func 5148 scalar PRIV 5148 CROSS Local 5110 R(8) 8 scalar 5202,5205,5209,5211,5267,5270,5274 ,5276 DEBUG Dummy 5017 L(4) 4 scalar ARG,IN,PRIV 5124,5125 I Local 5107 I(4) 4 scalar 5138,5139,5140,5160,5162,5167,5168 ,5170,5171,5181,5188,5189,5191,520 5,5254,5255,5258,5259,5261,5262,52 64,5265,5270,5273 INCELL Local 5090 L(4) 4 scalar 5116,5120,5219,5249,5277 J Local 5107 I(4) 4 scalar 5139,5140,5162,5167,5168,5174,5175 ,5177,5178,5181,5184,5205,5255,526 1,5262,5270 K Local 5107 I(4) 4 scalar 5163,5164,5205,5208,5235 LDBG Local 5106 L(4) 4 scalar 5125,5127,5144,5149,5203,5232,5242 ,5268 LLG Dummy 5017 L(4) 4 scalar ARG,IN,PRIV 5135 LSBC Local 5106 L(4) 4 scalar 5161,5212,5217 MAXVAL Func 5158 scalar PRIV 5158,5240,5241,5247 MINVAL Func 5225 scalar PRIV 5225,5240,5241,5247 MOD Func 5139 scalar PRIV 5139,5162,5255 N Local 5107 I(4) 4 scalar 5136,5140,5143,5148 NS Dummy 5017 I(4) 4 scalar ARG,IN,PRIV 5098,5108,5119,5138,5139,5160,5162 ,5254,5255 POLE Dummy 5017 L(4) 4 scalar ARG,OUT,PRIV 5148,5149,5152,5157 PRESENT Func 5124 scalar PRIV 5124 S90 Local 5109 R(8) 8 scalar 5158,5175,5182,5185,5189,5192 SIGN Func 5196 scalar PRIV 5196,5199,5209,5211,5274,5276 SIGN1 Local 5111 R(8) 8 scalar 5209,5211,5274,5276 SMALL Param 5105 R(8) 8 scalar 5258,5259 SUBCELL_LOOP Label 5160 scalar 5213,5218 V1X Local 5109 R(8) 8 scalar 5167,5174,5181,5188,5195,5196,5202 ,5205,5261,5267,5270 V1Y Local 5109 R(8) 8 scalar 5168,5175,5182,5189,5202,5205,5262 ,5267,5270 V2X Local 5109 R(8) 8 scalar 5170,5177,5184,5191,5198,5199,5202 ,5205,5264,5267,5270 V2Y Local 5109 R(8) 8 scalar 5171,5178,5185,5192,5202,5205,5265 ,5267,5270 W3CKCL_R8 Func 5017 L(4) 4 scalar PRIV 2117,2574 XS Dummy 5017 R(8) 8 1 0 ARG,INOUT,PRIV 5131,5285 XT Dummy 5017 R(8) 8 scalar ARG,INOUT,PRIV 5131,5285 Page 134 Source Listing W3CKCL_R8 2014-11-12 21:37 Symbol Table w3gsrumd.f90 Name Object Declared Type Bytes Dimen Elements Attributes References XXS Local 5108 R(8) 8 1 0 5131,5140,5167,5170,5174,5177,5181 ,5184,5188,5191,5225,5226,5229,523 5,5240,5247,5258,5261,5264,5285 XXT Local 5108 R(8) 8 scalar 5131,5170,5177,5184,5191,5227,5230 ,5234,5240,5245,5258,5264,5285 YS Dummy 5017 R(8) 8 1 0 ARG,INOUT,PRIV 5132,5158 YT Dummy 5017 R(8) 8 scalar ARG,INOUT,PRIV 5132 YYS Local 5108 R(8) 8 1 0 5132,5148,5168,5171,5175,5178,5189 ,5235,5241,5247,5259,5262,5265 YYT Local 5108 R(8) 8 scalar 5132,5171,5178,5185,5192,5234,5241 ,5245,5259,5265 Page 135 Source Listing W3CKCL_R8 2014-11-12 21:37 w3gsrumd.f90 5291 !/ ------------------------------------------------------------------- / 5292 SUBROUTINE W3SORT_R4(N, I, J, D) 5293 !/ 5294 !/ +-----------------------------------+ 5295 !/ | WAVEWATCH III NOAA/NCEP | 5296 !/ | T. J. Campbell, NRL | 5297 !/ | FORTRAN 90 | 5298 !/ | Last update : 12-Nov-2010 | 5299 !/ +-----------------------------------+ 5300 !/ 5301 !/ 30-Oct-2009 : Origination. ( version 3.14 ) 5302 !/ 12-Nov-2010 : Implement r4 & r8 interfaces. ( version 3.14 ) 5303 !/ 5304 ! 1. Purpose : 5305 ! 5306 ! Sort input arrays in increasing order according to input array D. 5307 ! Single precision interface. 5308 ! 5309 ! 2. Method : 5310 ! 5311 ! 3. Parameters : 5312 ! 5313 ! Parameter list 5314 ! ---------------------------------------------------------------- 5315 ! ---------------------------------------------------------------- 5316 ! 5317 ! 4. Subroutines used : 5318 ! 5319 ! See module documentation. 5320 ! 5321 ! 5. Called by : 5322 ! 5323 ! 6. Error messages : 5324 ! 5325 ! 7. Remarks : 5326 ! 5327 ! 8. Structure : 5328 ! 5329 ! 9. Switches : 5330 ! 5331 ! !/S Enable subroutine tracing. 5332 ! 5333 ! 10. Source code : 5334 ! 5335 !/ ------------------------------------------------------------------- / 5336 !/ 5337 !/ ------------------------------------------------------------------- / 5338 !/ Parameter list 5339 !/ 5340 INTEGER, INTENT(IN) :: N 5341 INTEGER, INTENT(INOUT) :: I(N) 5342 INTEGER, INTENT(INOUT) :: J(N) 5343 REAL(4), INTENT(INOUT) :: D(N) 5344 !/ 5345 !/ ------------------------------------------------------------------- / 5346 !/ Local parameters 5347 !/ Page 136 Source Listing W3SORT_R4 2014-11-12 21:37 w3gsrumd.f90 5348 INTEGER :: K, L, IM, JM 5349 REAL(4) :: DM 5350 !/ 5351 ! 5352 ! -------------------------------------------------------------------- / 5353 ! 5354 DO K=1, N-1 5355 DO L=K+1, N 5356 IF ( D(L) .LT. D(K) ) THEN 5357 IM = I(K); JM = J(K); DM = D(K); 5358 I(K) = I(L); J(K) = J(L); D(K) = D(L); 5359 I(L) = IM; J(L) = JM; D(L) = DM; 5360 END IF 5361 END DO !L 5362 END DO !K 5363 !/ 5364 !/ End of W3SORT_R4 -------------------------------------------------- / 5365 !/ 5366 END SUBROUTINE W3SORT_R4 ENTRY POINTS Name w3gsrumd_mp_w3sort_r4_ SYMBOL CROSS REFERENCE Name Object Declared Type Bytes Dimen Elements Attributes References D Dummy 5292 R(4) 4 1 0 ARG,INOUT,PRIV 5356,5357,5358,5359 DM Local 5349 R(4) 4 scalar 5357,5359 I Dummy 5292 I(4) 4 1 0 ARG,INOUT,PRIV 5357,5358,5359 IM Local 5348 I(4) 4 scalar 5357,5359 J Dummy 5292 I(4) 4 1 0 ARG,INOUT,PRIV 5357,5358,5359 JM Local 5348 I(4) 4 scalar 5357,5359 K Local 5348 I(4) 4 scalar 5354,5355,5356,5357,5358 L Local 5348 I(4) 4 scalar 5355,5356,5358,5359 N Dummy 5292 I(4) 4 scalar ARG,IN,PRIV 5341,5342,5343,5354,5355 W3SORT_R4 Subr 5292 PRIV 3476 Page 137 Source Listing W3SORT_R4 2014-11-12 21:37 w3gsrumd.f90 5367 !/ ------------------------------------------------------------------- / 5368 SUBROUTINE W3SORT_R8(N, I, J, D) 5369 !/ 5370 !/ +-----------------------------------+ 5371 !/ | WAVEWATCH III NOAA/NCEP | 5372 !/ | T. J. Campbell, NRL | 5373 !/ | FORTRAN 90 | 5374 !/ | Last update : 12-Nov-2010 | 5375 !/ +-----------------------------------+ 5376 !/ 5377 !/ 30-Oct-2009 : Origination. ( version 3.14 ) 5378 !/ 12-Nov-2010 : Implement r4 & r8 interfaces. ( version 3.14 ) 5379 !/ 5380 ! 1. Purpose : 5381 ! 5382 ! Sort input arrays in increasing order according to input array D. 5383 ! Double precision interface. 5384 ! 5385 ! 2. Method : 5386 ! 5387 ! 3. Parameters : 5388 ! 5389 ! Parameter list 5390 ! ---------------------------------------------------------------- 5391 ! ---------------------------------------------------------------- 5392 ! 5393 ! 4. Subroutines used : 5394 ! 5395 ! See module documentation. 5396 ! 5397 ! 5. Called by : 5398 ! 5399 ! 6. Error messages : 5400 ! 5401 ! 7. Remarks : 5402 ! 5403 ! 8. Structure : 5404 ! 5405 ! 9. Switches : 5406 ! 5407 ! !/S Enable subroutine tracing. 5408 ! 5409 ! 10. Source code : 5410 ! 5411 !/ ------------------------------------------------------------------- / 5412 !/ 5413 !/ ------------------------------------------------------------------- / 5414 !/ Parameter list 5415 !/ 5416 INTEGER, INTENT(IN) :: N 5417 INTEGER, INTENT(INOUT) :: I(N) 5418 INTEGER, INTENT(INOUT) :: J(N) 5419 REAL(8), INTENT(INOUT) :: D(N) 5420 !/ 5421 !/ ------------------------------------------------------------------- / 5422 !/ Local parameters 5423 !/ Page 138 Source Listing W3SORT_R8 2014-11-12 21:37 w3gsrumd.f90 5424 INTEGER :: K, L, IM, JM 5425 REAL(8) :: DM 5426 !/ 5427 ! 5428 ! -------------------------------------------------------------------- / 5429 ! 5430 DO K=1, N-1 5431 DO L=K+1, N 5432 IF ( D(L) .LT. D(K) ) THEN 5433 IM = I(K); JM = J(K); DM = D(K); 5434 I(K) = I(L); J(K) = J(L); D(K) = D(L); 5435 I(L) = IM; J(L) = JM; D(L) = DM; 5436 END IF 5437 END DO !L 5438 END DO !K 5439 !/ 5440 !/ End of W3SORT_R8 -------------------------------------------------- / 5441 !/ 5442 END SUBROUTINE W3SORT_R8 ENTRY POINTS Name w3gsrumd_mp_w3sort_r8_ SYMBOL CROSS REFERENCE Name Object Declared Type Bytes Dimen Elements Attributes References D Dummy 5368 R(8) 8 1 0 ARG,INOUT,PRIV 5432,5433,5434,5435 DM Local 5425 R(8) 8 scalar 5433,5435 I Dummy 5368 I(4) 4 1 0 ARG,INOUT,PRIV 5433,5434,5435 IM Local 5424 I(4) 4 scalar 5433,5435 J Dummy 5368 I(4) 4 1 0 ARG,INOUT,PRIV 5433,5434,5435 JM Local 5424 I(4) 4 scalar 5433,5435 K Local 5424 I(4) 4 scalar 5430,5431,5432,5433,5434 L Local 5424 I(4) 4 scalar 5431,5432,5434,5435 N Dummy 5368 I(4) 4 scalar ARG,IN,PRIV 5417,5418,5419,5430,5431 W3SORT_R8 Subr 5368 PRIV 3848 Page 139 Source Listing W3SORT_R8 2014-11-12 21:37 w3gsrumd.f90 5443 !/ ------------------------------------------------------------------- / 5444 SUBROUTINE W3ISRT_R4(II, JJ, DD, N, I, J, D) 5445 !/ 5446 !/ +-----------------------------------+ 5447 !/ | WAVEWATCH III NOAA/NCEP | 5448 !/ | T. J. Campbell, NRL | 5449 !/ | FORTRAN 90 | 5450 !/ | Last update : 12-Nov-2010 | 5451 !/ +-----------------------------------+ 5452 !/ 5453 !/ 30-Oct-2009 : Origination. ( version 3.14 ) 5454 !/ 12-Nov-2010 : Implement r4 & r8 interfaces. ( version 3.14 ) 5455 !/ 5456 ! 1. Purpose : 5457 ! 5458 ! Insert DD data into D at location where DD < D(K). 5459 ! Single precision interface. 5460 ! 5461 ! 2. Method : 5462 ! 5463 ! 3. Parameters : 5464 ! 5465 ! Parameter list 5466 ! ---------------------------------------------------------------- 5467 ! ---------------------------------------------------------------- 5468 ! 5469 ! 4. Subroutines used : 5470 ! 5471 ! See module documentation. 5472 ! 5473 ! 5. Called by : 5474 ! 5475 ! 6. Error messages : 5476 ! 5477 ! 7. Remarks : 5478 ! 5479 ! 8. Structure : 5480 ! 5481 ! 9. Switches : 5482 ! 5483 ! !/S Enable subroutine tracing. 5484 ! 5485 ! 10. Source code : 5486 ! 5487 !/ ------------------------------------------------------------------- / 5488 !/ 5489 !/ ------------------------------------------------------------------- / 5490 !/ Parameter list 5491 !/ 5492 INTEGER, INTENT(IN) :: II 5493 INTEGER, INTENT(IN) :: JJ 5494 REAL(4), INTENT(IN) :: DD 5495 INTEGER, INTENT(IN) :: N 5496 INTEGER, INTENT(INOUT) :: I(N) 5497 INTEGER, INTENT(INOUT) :: J(N) 5498 REAL(4), INTENT(INOUT) :: D(N) 5499 !/ Page 140 Source Listing W3ISRT_R4 2014-11-12 21:37 w3gsrumd.f90 5500 !/ ------------------------------------------------------------------- / 5501 !/ Local parameters 5502 !/ 5503 INTEGER :: K, L 5504 !/ 5505 ! 5506 ! -------------------------------------------------------------------- / 5507 ! 5508 K_LOOP: DO K=1,N 5509 IF ( DD .LT. D(K) ) THEN 5510 !---------right-shift list (>= k) 5511 DO L=N,K+1,-1 5512 I(L) = I(L-1); J(L) = J(L-1); D(L) = D(L-1); 5513 END DO !L 5514 !---------insert point into list at k 5515 I(K) = II; J(K) = JJ; D(K) = DD; 5516 EXIT K_LOOP 5517 END IF !dd.lt.d(k) 5518 END DO K_LOOP 5519 !/ 5520 !/ End of W3ISRT_R4 -------------------------------------------------- / 5521 !/ 5522 END SUBROUTINE W3ISRT_R4 ENTRY POINTS Name w3gsrumd_mp_w3isrt_r4_ Page 141 Source Listing W3ISRT_R4 2014-11-12 21:37 Symbol Table w3gsrumd.f90 SYMBOL CROSS REFERENCE Name Object Declared Type Bytes Dimen Elements Attributes References D Dummy 5444 R(4) 4 1 0 ARG,INOUT,PRIV 5509,5512,5515 DD Dummy 5444 R(4) 4 scalar ARG,IN,PRIV 5509,5515 I Dummy 5444 I(4) 4 1 0 ARG,INOUT,PRIV 5512,5515 II Dummy 5444 I(4) 4 scalar ARG,IN,PRIV 5515 J Dummy 5444 I(4) 4 1 0 ARG,INOUT,PRIV 5512,5515 JJ Dummy 5444 I(4) 4 scalar ARG,IN,PRIV 5515 K Local 5503 I(4) 4 scalar 5508,5509,5511,5515 K_LOOP Label 5508 scalar 5516,5518 L Local 5503 I(4) 4 scalar 5511,5512 N Dummy 5444 I(4) 4 scalar ARG,IN,PRIV 5496,5497,5498,5508,5511 W3ISRT_R4 Subr 5444 PRIV 3480 Page 142 Source Listing W3ISRT_R4 2014-11-12 21:37 w3gsrumd.f90 5523 !/ ------------------------------------------------------------------- / 5524 SUBROUTINE W3ISRT_R8(II, JJ, DD, N, I, J, D) 5525 !/ 5526 !/ +-----------------------------------+ 5527 !/ | WAVEWATCH III NOAA/NCEP | 5528 !/ | T. J. Campbell, NRL | 5529 !/ | FORTRAN 90 | 5530 !/ | Last update : 12-Nov-2010 | 5531 !/ +-----------------------------------+ 5532 !/ 5533 !/ 30-Oct-2009 : Origination. ( version 3.14 ) 5534 !/ 12-Nov-2010 : Implement r4 & r8 interfaces. ( version 3.14 ) 5535 !/ 5536 ! 1. Purpose : 5537 ! 5538 ! Insert DD data into D at location where DD < D(K). 5539 ! Double precision interface. 5540 ! 5541 ! 2. Method : 5542 ! 5543 ! 3. Parameters : 5544 ! 5545 ! Parameter list 5546 ! ---------------------------------------------------------------- 5547 ! ---------------------------------------------------------------- 5548 ! 5549 ! 4. Subroutines used : 5550 ! 5551 ! See module documentation. 5552 ! 5553 ! 5. Called by : 5554 ! 5555 ! 6. Error messages : 5556 ! 5557 ! 7. Remarks : 5558 ! 5559 ! 8. Structure : 5560 ! 5561 ! 9. Switches : 5562 ! 5563 ! !/S Enable subroutine tracing. 5564 ! 5565 ! 10. Source code : 5566 ! 5567 !/ ------------------------------------------------------------------- / 5568 !/ 5569 !/ ------------------------------------------------------------------- / 5570 !/ Parameter list 5571 !/ 5572 INTEGER, INTENT(IN) :: II 5573 INTEGER, INTENT(IN) :: JJ 5574 REAL(8), INTENT(IN) :: DD 5575 INTEGER, INTENT(IN) :: N 5576 INTEGER, INTENT(INOUT) :: I(N) 5577 INTEGER, INTENT(INOUT) :: J(N) 5578 REAL(8), INTENT(INOUT) :: D(N) 5579 !/ Page 143 Source Listing W3ISRT_R8 2014-11-12 21:37 w3gsrumd.f90 5580 !/ ------------------------------------------------------------------- / 5581 !/ Local parameters 5582 !/ 5583 INTEGER :: K, L 5584 !/ 5585 ! 5586 ! -------------------------------------------------------------------- / 5587 ! 5588 K_LOOP: DO K=1,N 5589 IF ( DD .LT. D(K) ) THEN 5590 !---------right-shift list (>= k) 5591 DO L=N,K+1,-1 5592 I(L) = I(L-1); J(L) = J(L-1); D(L) = D(L-1); 5593 END DO !L 5594 !---------insert point into list at k 5595 I(K) = II; J(K) = JJ; D(K) = DD; 5596 EXIT K_LOOP 5597 END IF !dd.lt.d(k) 5598 END DO K_LOOP 5599 !/ 5600 !/ End of W3ISRT_R8 -------------------------------------------------- / 5601 !/ 5602 END SUBROUTINE W3ISRT_R8 ENTRY POINTS Name w3gsrumd_mp_w3isrt_r8_ Page 144 Source Listing W3ISRT_R8 2014-11-12 21:37 Symbol Table w3gsrumd.f90 SYMBOL CROSS REFERENCE Name Object Declared Type Bytes Dimen Elements Attributes References D Dummy 5524 R(8) 8 1 0 ARG,INOUT,PRIV 5589,5592,5595 DD Dummy 5524 R(8) 8 scalar ARG,IN,PRIV 5589,5595 I Dummy 5524 I(4) 4 1 0 ARG,INOUT,PRIV 5592,5595 II Dummy 5524 I(4) 4 scalar ARG,IN,PRIV 5595 J Dummy 5524 I(4) 4 1 0 ARG,INOUT,PRIV 5592,5595 JJ Dummy 5524 I(4) 4 scalar ARG,IN,PRIV 5595 K Local 5583 I(4) 4 scalar 5588,5589,5591,5595 K_LOOP Label 5588 scalar 5596,5598 L Local 5583 I(4) 4 scalar 5591,5592 N Dummy 5524 I(4) 4 scalar ARG,IN,PRIV 5576,5577,5578,5588,5591 W3ISRT_R8 Subr 5524 PRIV 3852 Page 145 Source Listing W3ISRT_R8 2014-11-12 21:37 w3gsrumd.f90 5603 !/ ------------------------------------------------------------------- / 5604 FUNCTION W3INAN_R4(X) RESULT(INAN) 5605 !/ 5606 !/ +-----------------------------------+ 5607 !/ | WAVEWATCH III NOAA/NCEP | 5608 !/ | T. J. Campbell, NRL | 5609 !/ | FORTRAN 90 | 5610 !/ | Last update : 14-Jun-2010 | 5611 !/ +-----------------------------------+ 5612 !/ 5613 !/ 14-Jun-2010 : Origination. ( version 3.14 ) 5614 !/ 5615 ! 1. Purpose : 5616 ! 5617 ! Return TRUE if input is infinite or NaN (not a number). 5618 ! Single precision interface. 5619 ! 5620 ! 2. Method : 5621 ! 5622 ! 3. Parameters : 5623 ! 5624 ! Parameter list 5625 ! ---------------------------------------------------------------- 5626 ! ---------------------------------------------------------------- 5627 ! 5628 ! 4. Subroutines used : 5629 ! 5630 ! See module documentation. 5631 ! 5632 ! 5. Called by : 5633 ! 5634 ! 6. Error messages : 5635 ! 5636 ! 7. Remarks : 5637 ! 5638 ! 8. Structure : 5639 ! 5640 ! 9. Switches : 5641 ! 5642 ! !/S Enable subroutine tracing. 5643 ! 5644 ! 10. Source code : 5645 ! 5646 !/ ------------------------------------------------------------------- / 5647 !/ 5648 !/ ------------------------------------------------------------------- / 5649 !/ Return parameter 5650 !/ 5651 LOGICAL :: INAN 5652 !/ 5653 !/ ------------------------------------------------------------------- / 5654 !/ Parameter list 5655 !/ 5656 REAL(4), INTENT(IN) :: X 5657 !/ 5658 !/ ------------------------------------------------------------------- / 5659 !/ Local parameters Page 146 Source Listing W3INAN_R4 2014-11-12 21:37 w3gsrumd.f90 5660 !/ 5661 ! 5662 ! -------------------------------------------------------------------- / 5663 ! 5664 !-----return true if X is NaN or +Inf or -Inf 5665 INAN = .NOT. ( X .GE. -HUGE(X) .AND. X .LE. HUGE(X) ) 5666 !/ 5667 !/ End of W3INAN_R4 -------------------------------------------------- / 5668 !/ 5669 END FUNCTION W3INAN_R4 ENTRY POINTS Name w3gsrumd_mp_w3inan_r4_ SYMBOL CROSS REFERENCE Name Object Declared Type Bytes Dimen Elements Attributes References HUGE Func 5665 scalar PRIV 5665 INAN Local 5651 L(4) 4 scalar 5665 W3INAN_R4 Func 5604 L(4) 4 scalar PRIV X Dummy 5604 R(4) 4 scalar ARG,IN,PRIV 5665 Page 147 Source Listing W3INAN_R4 2014-11-12 21:37 w3gsrumd.f90 5670 !/ ------------------------------------------------------------------- / 5671 FUNCTION W3INAN_R8(X) RESULT(INAN) 5672 !/ 5673 !/ +-----------------------------------+ 5674 !/ | WAVEWATCH III NOAA/NCEP | 5675 !/ | T. J. Campbell, NRL | 5676 !/ | FORTRAN 90 | 5677 !/ | Last update : 14-Jun-2010 | 5678 !/ +-----------------------------------+ 5679 !/ 5680 !/ 14-Jun-2010 : Origination. ( version 3.14 ) 5681 !/ 5682 ! 1. Purpose : 5683 ! 5684 ! Return TRUE if input is infinite or NaN (not a number). 5685 ! Double precision interface. 5686 ! 5687 ! 2. Method : 5688 ! 5689 ! 3. Parameters : 5690 ! 5691 ! Parameter list 5692 ! ---------------------------------------------------------------- 5693 ! ---------------------------------------------------------------- 5694 ! 5695 ! 4. Subroutines used : 5696 ! 5697 ! See module documentation. 5698 ! 5699 ! 5. Called by : 5700 ! 5701 ! 6. Error messages : 5702 ! 5703 ! 7. Remarks : 5704 ! 5705 ! 8. Structure : 5706 ! 5707 ! 9. Switches : 5708 ! 5709 ! !/S Enable subroutine tracing. 5710 ! 5711 ! 10. Source code : 5712 ! 5713 !/ ------------------------------------------------------------------- / 5714 !/ 5715 !/ ------------------------------------------------------------------- / 5716 !/ Return parameter 5717 !/ 5718 LOGICAL :: INAN 5719 !/ 5720 !/ ------------------------------------------------------------------- / 5721 !/ Parameter list 5722 !/ 5723 REAL(8), INTENT(IN) :: X 5724 !/ 5725 !/ ------------------------------------------------------------------- / 5726 !/ Local parameters Page 148 Source Listing W3INAN_R8 2014-11-12 21:37 w3gsrumd.f90 5727 !/ 5728 ! 5729 ! -------------------------------------------------------------------- / 5730 ! 5731 !-----return true if X is NaN or +Inf or -Inf 5732 INAN = .NOT. ( X .GE. -HUGE(X) .AND. X .LE. HUGE(X) ) 5733 !/ 5734 !/ End of W3INAN_R8 -------------------------------------------------- / 5735 !/ 5736 END FUNCTION W3INAN_R8 ENTRY POINTS Name w3gsrumd_mp_w3inan_r8_ SYMBOL CROSS REFERENCE Name Object Declared Type Bytes Dimen Elements Attributes References HUGE Func 5732 scalar PRIV 5732 INAN Local 5718 L(4) 4 scalar 5732 W3INAN_R8 Func 5671 L(4) 4 scalar PRIV X Dummy 5671 R(8) 8 scalar ARG,IN,PRIV 5732 Page 149 Source Listing W3INAN_R8 2014-11-12 21:37 w3gsrumd.f90 5737 !/ ------------------------------------------------------------------- / 5738 !/ 5739 !/ End of module W3GSRUMD -------------------------------------------- / 5740 !/ 5741 END MODULE W3GSRUMD SYMBOL CROSS REFERENCE Name Object Declared Type Bytes Dimen Elements Attributes References NULL Func 227 scalar PTR 227 PI Param 274 R(8) 8 scalar 275,276,277 PI2 Param 275 R(8) 8 scalar PI3H Param 276 R(8) 8 scalar W3GFCD Local 297 scalar 192 W3GFIJ Local 305 scalar 194 W3GFPT Local 301 scalar 193 W3GRMP Local 309 scalar 195 W3GSRUMD Module 2 W3GSUC Local 289 scalar 188 W3GSUD Subr 189 189 W3GSUP Subr 190 190 W3INAN Local 333 scalar 197 W3SERVMD Module 176 176 Page 150 Source Listing W3INAN_R8 2014-11-12 21:37 Subprograms/Common Blocks w3gsrumd.f90 SUBPROGRAMS/COMMON BLOCKS Name Object Declared Type Bytes Dimen Elements Attributes References W3CKCL_R4 Func 4742 L(4) 4 scalar PRIV 1874,2345 W3CKCL_R8 Func 5017 L(4) 4 scalar PRIV 2117,2574 W3DIST_R4 Func 4560 R(4) 4 scalar PRIV 2720,3354,3416,3469 W3DIST_R8 Func 4651 R(8) 8 scalar PRIV 2862,3726,3788,3841 W3GFCD_R4 Func 2133 L(4) 4 scalar PRIV W3GFCD_R8 Func 2362 L(4) 4 scalar PRIV W3GFCL_R4 Func 1648 L(4) 4 scalar PRIV 2716,2993,3337 W3GFCL_R8 Func 1890 L(4) 4 scalar PRIV 2858,3127,3709 W3GFIJ_R4 Func 2875 L(4) 4 scalar PRIV W3GFIJ_R8 Func 3009 L(4) 4 scalar PRIV W3GFPT_R4 Func 2591 L(4) 4 scalar PRIV W3GFPT_R8 Func 2733 L(4) 4 scalar PRIV W3GRMP_R4 Func 3143 L(4) 4 scalar PRIV W3GRMP_R8 Func 3515 L(4) 4 scalar PRIV W3GSRUMD Module 2 W3GSUC_R4 Func 341 RECORD 8 scalar PRIV W3GSUC_R8 Func 869 RECORD 8 scalar PRIV W3GSUD Subr 1397 W3GSUP Subr 1482 W3INAN_R4 Func 5604 L(4) 4 scalar PRIV W3INAN_R8 Func 5671 L(4) 4 scalar PRIV W3ISRT_R4 Subr 5444 PRIV 3480 W3ISRT_R8 Subr 5524 PRIV 3852 W3NNSC Func 3887 T_NNS 296 scalar PTR W3NNSD Subr 4022 W3NNSP Subr 4100 W3RMBL_R4 Subr 4176 2998,3342 W3RMBL_R8 Subr 4368 3132,3714 W3SORT_R4 Subr 5292 PRIV 3476 W3SORT_R8 Subr 5368 PRIV 3848 COMPILER OPTIONS BEING USED -align nocommons -align nodcommons -align noqcommons -align records -align nosequence -align norec1byte -align norec2byte -align norec4byte -align norec8byte -align norec16byte -altparam -assume accuracy_sensitive -assume nobscc -assume nobuffered_io -assume byterecl -assume nocc_omp -assume nocstring -assume nodummy_aliases -assume nofpe_summary -assume noieee_fpe_flags -assume nominus0 -assume noold_boz -assume old_unit_star -assume old_ldout_format -assume noold_logical_ldio -assume old_maxminloc -assume old_xor -assume protect_constants -assume noprotect_parens -assume split_common -assume source_include -assume nostd_intent_in -assume nostd_mod_proc_name -assume norealloc_lhs -assume underscore -assume no2underscores Page 151 Source Listing W3INAN_R8 2014-11-12 21:37 w3gsrumd.f90 -auto no -auto_scalar no -bintext -ccdefault default -check noargs -check noarg_temp_created -check nobounds -check noformat -check nooutput_conversion -check nooverflow -check nopointers -check power -check noshape -check nounderflow -check nouninitialized -coarray-num-procs 0 no -coarray-config-file -convert big_endian -cross_reference -D __INTEL_COMPILER=1210 -D __unix__ -D __unix -D __linux__ -D __linux -D __gnu_linux__ -D unix -D linux -D __ELF__ -D __x86_64 -D __x86_64__ -D _MT -D __INTEL_COMPILER_BUILD_DATE=20120612 -D __pentium4 -D __pentium4__ -D __tune_pentium4__ -D __SSE2__ -D __SSE3__ -D __SSSE3__ -D __SSE4_1__ -D __SSE4_2__ -D __SSE__ -D __MMX__ -D __AVX__ -double_size 64 no -d_lines no -Qdyncom -error_limit 30 no -f66 no -f77rtl no -fast -fpscomp nofilesfromcmd -fpscomp nogeneral -fpscomp noioformat -fpscomp noldio_spacing -fpscomp nologicals no -fpconstant -fpe3 -fprm nearest no -ftz -fp_model noprecise -fp_model fast -fp_model nostrict -fp_model nosource -fp_model nodouble -fp_model noextended -fp_model novery_fast -fp_model noexcept -fp_model nono_except -heap_arrays 0 no -threadprivate_compat -free -g0 -iface nomixed_str_len_arg -iface nono_mixed_str_len_arg no -intconstant -integer_size 32 no -mixed_str_len_arg no -module -names lowercase no -noinclude -O2 no -pad_source -real_size 32 no -recursive -reentrancy none no -sharable_localsaves -vec=simd -show noinclude -show map -show options no -syntax_only no -threadcom no -U no -vms -w noall -w nonone -w alignments -w noargument_checking -w nodeclarations -w general -w noignore_bounds -w noignore_loc -w nointerfaces -w notruncated_source -w uncalled -w uninitialized -w nounused -w usage -includepath : /gpfs/gp1/usrx/local/intel/composer_xe_2011_sp1.11.339/compiler/include/,.f,./.f,/usrx/local/intel/composerxe/mkl/include/.f, /usrx/local/intel/composerxe/tbb/include/.f,/gpfs/gp1/usrx/local/intel/composer_xe_2011_sp1.11.339/compiler/include/intel64/.f, Page 152 Source Listing W3INAN_R8 2014-11-12 21:37 w3gsrumd.f90 /gpfs/gp1/usrx/local/intel/composer_xe_2011_sp1.11.339/compiler/include/.f,/usr/local/include/.f,/usr/lib/gcc/x86_64-redhat-linux/4.4.7/include/.f, /usr/include/.f,/usr/include/.f -list filename : w3gsrumd.lst -o filename : none COMPILER: Intel(R) Fortran 12.1-2100