Page 1 Source Listing W3PART 2014-09-16 17:02 w3partmd.f90 1 !/ ------------------------------------------------------------------- / 2 MODULE W3PARTMD 3 !/ 4 !/ +-----------------------------------+ 5 !/ | WAVEWATCH III USACE/NOAA | 6 !/ | Barbara Tracy | 7 !/ | H. L. Tolman | 8 !/ | FORTRAN 90 | 9 !/ | Last update : 15-Apr-2008 | 10 !/ +-----------------------------------+ 11 !/ 12 !/ 01-Nov-2006 : Origination. ( version 3.10 ) 13 !/ 02-Nov-2006 : Adding tail to integration. ( version 3.10 ) 14 !/ 24-Mar-2007 : Bug fix IMI, adding overall field ( version 3.11 ) 15 !/ and sorting. 16 !/ 15-Apr-2008 : Clean up for distribution. ( version 3.14 ) 17 !/ 02-Dec-2010 : Adding a mapping PMAP between ( version 3.14 ) 18 !/ original and combined partitions 19 !/ ( M. Szyszka ) 20 !/ 21 ! 1. Purpose : 22 ! 23 ! Spectral partitioning according to the watershed method. 24 ! 25 ! 2. Variables and types : 26 ! 27 ! Name Type Scope Description 28 ! ---------------------------------------------------------------- 29 ! MK, MTH Int. Private Dimensions of stored neighour array. 30 ! NEIGH I.A. Private Nearest Neighbor array. 31 ! ---------------------------------------------------------------- 32 ! Note: IHMAX, HSPMIN, WSMULT, WSCUT and FLCOMB used from W3ODATMD. 33 ! 34 ! 3. Subroutines and functions : 35 ! 36 ! Name Type Scope Description 37 ! ---------------------------------------------------------------- 38 ! W3PART Subr. Public Interface to watershed routines. 39 ! PTSORT Subr. Public Sort discretized image. 40 ! PTNGHB Subr. Public Defeine nearest neighbours. 41 ! PT_FLD Subr. Public Incremental flooding algorithm. 42 ! FIFO_ADD, FIFO_EMPTY, FIFO_FIRST 43 ! Subr. PT_FLD Queue management. 44 ! PTMEAN Subr. Public Compute mean parameters. 45 ! ---------------------------------------------------------------- 46 ! 47 ! 4. Subroutines and functions used : 48 ! 49 ! Name Type Module Description 50 ! ---------------------------------------------------------------- 51 ! STRACE Subr. W3SERVMD Subroutine traceing. 52 ! WAVNU1 Subr. W3DISPMD Wavenumber computation. 53 ! ---------------------------------------------------------------- 54 ! 55 ! 5. Remarks : 56 ! 57 ! 6. Switches : Page 2 Source Listing W3PART 2014-09-16 17:02 w3partmd.f90 58 ! 59 ! !/S Enable subroutine tracing. 60 ! !/T Enable test output 61 ! 62 ! 7. Source code : 63 ! 64 !/ ------------------------------------------------------------------- / 65 ! 66 USE W3ODATMD, ONLY: IHMAX, HSPMIN, WSMULT 67 ! 68 PUBLIC 69 ! 70 INTEGER, PRIVATE :: MK = -1, MTH = -1 71 INTEGER, ALLOCATABLE, PRIVATE :: NEIGH(:,:) 72 !/ 73 CONTAINS 74 !/ ------------------------------------------------------------------- / 75 SUBROUTINE W3PART ( SPEC, UABS, UDIR, DEPTH, WN, NP, XP, DIMXP ) 76 !/ 77 !/ +-----------------------------------+ 78 !/ | WAVEWATCH III USACE/NOAA | 79 !/ | Barbara Tracy | 80 !/ | H. L. Tolman | 81 !/ | FORTRAN 90 | 82 !/ | Last update : 28-Oct-2006 ! 83 !/ +-----------------------------------+ 84 !/ 85 !/ 28-Oct-2006 : Origination. ( version 3.10 ) 86 !/ 02-Dec-2010 : Adding a mapping PMAP between ( version 3.14 ) 87 !/ original and combined partitions 88 !/ ( M. Szyszka ) 89 !/ 90 ! 1. Purpose : 91 ! 92 ! Interface to watershed partitioning routines. 93 ! 94 ! 2. Method : 95 ! 96 ! Watershed Algorithm of Vincent and Soille, 1991, implemented by 97 ! Barbara Tracy (USACE/ERDC) for NOAA/NCEP. 98 ! 99 ! 3. Parameters : 100 ! 101 ! Parameter list 102 ! ---------------------------------------------------------------- 103 ! SPEC R.A. I 2-D spectrum E(f,theta). 104 ! UABS Real I Wind speed. 105 ! UDIR Real I Wind direction. 106 ! DEPTH Real I Water depth. 107 ! WN R.A. I Wavenumebers for each frequency. 108 ! NP Int. O Number of partitions. 109 ! -1 : Spectrum without minumum energy. 110 ! 0 : Spectrum with minumum energy. 111 ! but no partitions. 112 ! XP R.A. O Parameters describing partitions. 113 ! Entry '0' contains entire spectrum. 114 ! DIMXP Int. I Second dimension of XP. Page 3 Source Listing W3PART 2014-09-16 17:02 w3partmd.f90 115 ! ---------------------------------------------------------------- 116 ! 117 ! 4. Subroutines used : 118 ! 119 ! Name Type Module Description 120 ! ---------------------------------------------------------------- 121 ! STRACE Sur. W3SERVMD Subroutine tracing. 122 ! ---------------------------------------------------------------- 123 ! 124 ! 5. Called by : 125 ! 126 ! 6. Error messages : 127 ! 128 ! 7. Remarks : 129 ! 130 ! - To achieve minimum storage but guaranteed storage of all 131 ! partitions DIMXP = ((NK+1)/2) * ((NTH-1)/2) 132 ! 133 ! 8. Structure : 134 ! 135 ! 9. Switches : 136 ! 137 ! !/S Enable subroutine tracing. 138 ! !/T Enable test output 139 ! 140 ! 10. Source code : 141 ! 142 !/ ------------------------------------------------------------------- / 143 !/ 144 USE CONSTANTS 145 ! 146 USE W3GDATMD, ONLY: NK, NTH, NSPEC 147 USE W3ODATMD, ONLY: WSCUT, FLCOMB 148 ! 149 IMPLICIT NONE 150 !/ 151 !/ ------------------------------------------------------------------- / 152 !/ Parameter list 153 !/ 154 INTEGER, INTENT(OUT) :: NP 155 INTEGER, INTENT(IN) :: DIMXP 156 REAL, INTENT(IN) :: SPEC(NK,NTH), WN(NK), UABS, & 157 UDIR, DEPTH 158 REAL, INTENT(OUT) :: XP(6,0:DIMXP) 159 !/ 160 !/ ------------------------------------------------------------------- / 161 !/ Local parameters 162 !/ 163 INTEGER :: ITH, IMI(NSPEC), IMD(NSPEC), & 164 IMO(NSPEC), IND(NSPEC), NP_MAX, & 165 IP, IT(1), INDEX(DIMXP), NWS, & 166 IPW, IPT, ISP 167 INTEGER :: PMAP(DIMXP) 168 REAL :: ZP(NSPEC), ZMIN, ZMAX, Z(NSPEC), & 169 FACT, WSMAX, HSMAX 170 REAL :: TP(6,DIMXP) 171 !/ Page 4 Source Listing W3PART 2014-09-16 17:02 w3partmd.f90 172 !/ ------------------------------------------------------------------- / 173 ! 0. Initializations 174 ! 175 NP = 0 176 XP = 0. 177 ! 178 ! -------------------------------------------------------------------- / 179 ! 1. Process input spectrum 180 ! 1.a 2-D to 1-D spectrum 181 ! 182 DO ITH=1, NTH 183 ZP(1+(ITH-1)*NK:ITH*NK) = SPEC(:,ITH) 184 END DO 185 ! 186 ! 1.b Invert spectrum and 'digitize' 187 ! 188 ZMIN = MINVAL ( ZP ) 189 ZMAX = MAXVAL ( ZP ) 190 IF ( ZMAX-ZMIN .LT. 1.E-9 ) RETURN 191 ! 192 Z = ZMAX - ZP 193 ! 194 FACT = REAL(IHMAX-1) / ( ZMAX - ZMIN ) 195 IMI = MAX ( 1 , MIN ( IHMAX , NINT ( 1. + Z*FACT ) ) ) 196 ! 197 ! 1.c Sort digitized image 198 ! 199 CALL PTSORT ( IMI, IND, IHMAX ) 200 ! 201 ! -------------------------------------------------------------------- / 202 ! 2. Perform partitioning 203 ! 2.a Update nearest neighbor info as needed. 204 ! 205 CALL PTNGHB 206 ! 207 ! 2.b Incremental flooding 208 ! 209 CALL PT_FLD ( IMI, IND, IMO, ZP, NP_MAX ) 210 ! 211 ! 2.c Compute parameters per partition 212 ! NP and NX initialized inside routine. 213 ! 214 CALL PTMEAN ( NP_MAX, IMO, ZP, DEPTH, UABS, UDIR, WN, & 215 NP, XP, DIMXP, PMAP ) 216 ! 217 ! -------------------------------------------------------------------- / 218 ! 3. Sort and recombine wind seas as needed 219 ! 3.a Sort by wind sea fraction 220 ! 221 IF ( NP .LE. 1 ) RETURN 222 ! 223 TP(:,1:NP) = XP(:,1:NP) 224 XP(:,1:NP) = 0. 225 INDEX(1:NP) = 0 226 NWS = 0 227 ! 228 DO IP=1, NP Page 5 Source Listing W3PART 2014-09-16 17:02 w3partmd.f90 229 IT = MAXLOC(TP(6,1:NP)) 230 INDEX(IP) = IT(1) 231 XP(:,IP) = TP(:,INDEX(IP)) 232 IF ( TP(6,IT(1)) .GE. WSCUT ) NWS = NWS + 1 233 TP(6,IT(1)) = -1. 234 END DO 235 ! 236 ! 3.b Combine wind seas as needed and resort 237 ! 238 IF ( NWS.GT.1 .AND. FLCOMB ) THEN 239 IPW = PMAP(INDEX(1)) 240 DO IP=2, NWS 241 IPT = PMAP(INDEX(IP)) 242 DO ISP=1, NSPEC 243 IF ( IMO(ISP) .EQ. IPT ) IMO(ISP) = IPW 244 END DO 245 END DO 246 ! 247 CALL PTMEAN ( NP_MAX, IMO, ZP, DEPTH, UABS, UDIR, WN, & 248 NP, XP, DIMXP, PMAP ) 249 IF ( NP .LE. 1 ) RETURN 250 ! 251 TP(:,1:NP) = XP(:,1:NP) 252 XP(:,1:NP) = 0. 253 INDEX(1:NP) = 0 254 NWS = 0 255 ! 256 DO IP=1, NP 257 IT = MAXLOC(TP(6,1:NP)) 258 INDEX(IP) = IT(1) 259 XP(:,IP) = TP(:,INDEX(IP)) 260 IF ( TP(6,IT(1)) .GE. WSCUT ) NWS = NWS + 1 261 TP(6,IT(1)) = -1. 262 END DO 263 ! 264 END IF 265 ! 266 ! 3.c Sort remaining fields by wave height 267 ! 268 NWS = MIN ( 1 , NWS ) 269 ! 270 TP(:,1:NP) = XP(:,1:NP) 271 XP(:,1:NP) = 0. 272 ! 273 IF ( NWS .GT. 0 ) THEN 274 XP(:,1) = TP(:,1) 275 TP(1,1) = -1. 276 NWS = 1 277 END IF 278 ! 279 DO IP=NWS+1, NP 280 IT = MAXLOC(TP(1,1:NP)) 281 XP(:,IP) = TP(:,IT(1)) 282 TP(1,IT(1)) = -1. 283 END DO 284 ! 285 ! -------------------------------------------------------------------- / Page 6 Source Listing W3PART 2014-09-16 17:02 w3partmd.f90 286 ! 4. End of routine 287 ! 288 RETURN 289 !/ 290 !/ End of W3PART ----------------------------------------------------- / 291 !/ 292 END SUBROUTINE W3PART ENTRY POINTS Name w3partmd_mp_w3part_ SYMBOL CROSS REFERENCE Name Object Declared Type Bytes Dimen Elements Attributes References CONSTANTS Module 144 144 DEPTH Dummy 75 R(4) 4 scalar ARG,IN 214,247 DIMXP Dummy 75 I(4) 4 scalar ARG,IN 158,165,167,170,215,248 FACT Local 169 R(4) 4 scalar 194,195 FLCOMB Local 147 L(4) 4 scalar PTR 147,238 HSMAX Local 169 R(4) 4 scalar IHMAX Local 194 I(4) 4 scalar PTR 66,194,195,199,654 IMD Local 163 I(4) 4 1 0 IMI Local 163 I(4) 4 1 0 195,199,209 IMO Local 164 I(4) 4 1 0 209,214,243,247 IND Local 164 I(4) 4 1 0 199,209 INDEX Local 165 I(4) 4 1 0 225,230,231,239,241,253,258,259 IP Local 165 I(4) 4 scalar 228,230,231,240,241,256,258,259,27 9,281 IPT Local 166 I(4) 4 scalar 241,243 IPW Local 166 I(4) 4 scalar 239,243 ISP Local 166 I(4) 4 scalar 242,243 IT Local 165 I(4) 4 1 1 229,230,232,233,257,258,260,261,28 0,281,282 ITH Local 163 I(4) 4 scalar 182,183 MAX Func 195 scalar 195 MAXLOC Func 229 scalar 229,257,280 MAXVAL Func 189 scalar 189 MIN Func 195 scalar 195,268 MINVAL Func 188 scalar 188 NINT Func 195 scalar 195 NK Local 146 I(4) 4 scalar PTR 146,156,183 NP Dummy 75 I(4) 4 scalar ARG,OUT 175,215,221,223,224,225,228,229,24 8,249,251,252,253,256,257,270,271, 279,280 NP_MAX Local 164 I(4) 4 scalar 209,214,247 NSPEC Local 146 I(4) 4 scalar PTR 146,163,164,168,242 NTH Local 146 I(4) 4 scalar PTR 146,156,182 NWS Local 165 I(4) 4 scalar 226,232,238,240,254,260,268,273,27 6,279 PMAP Local 167 I(4) 4 1 0 215,239,241,248 REAL Func 194 scalar 194 Page 7 Source Listing W3PART 2014-09-16 17:02 Symbol Table w3partmd.f90 Name Object Declared Type Bytes Dimen Elements Attributes References SPEC Dummy 75 R(4) 4 2 0 ARG,IN 183 TP Local 170 R(4) 4 2 0 223,229,231,232,233,251,257,259,26 0,261,270,274,275,280,281,282 UABS Dummy 75 R(4) 4 scalar ARG,IN 214,247 UDIR Dummy 75 R(4) 4 scalar ARG,IN 214,247 W3GDATMD Module 146 146 W3ODATMD Module 147 147 W3PART Subr 75 WN Dummy 75 R(4) 4 1 0 ARG,IN 214,247 WSCUT Local 147 R(4) 4 scalar PTR 147,232,260 WSMAX Local 169 R(4) 4 scalar XP Dummy 75 R(4) 4 2 0 ARG,OUT 176,215,223,224,231,248,251,252,25 9,270,271,274,281 Z Local 168 R(4) 4 1 0 192,195 ZMAX Local 168 R(4) 4 scalar 189,190,192,194 ZMIN Local 168 R(4) 4 scalar 188,190,194 ZP Local 168 R(4) 4 1 0 183,188,189,192,209,214,247 Page 8 Source Listing W3PART 2014-09-16 17:02 w3partmd.f90 293 !/ ------------------------------------------------------------------- / 294 SUBROUTINE PTSORT ( IMI, IND, IHMAX ) 295 !/ 296 !/ +-----------------------------------+ 297 !/ | WAVEWATCH III USACE/NOAA | 298 !/ | Barbara Tracy | 299 !/ | H. L. Tolman | 300 !/ | FORTRAN 90 | 301 !/ | Last update : 19-Oct-2006 ! 302 !/ +-----------------------------------+ 303 !/ 304 !/ 19-Oct-2006 : Origination. ( version 3.10 ) 305 !/ 306 ! 1. Purpose : 307 ! 308 ! This subroutine sorts the image data in ascending order. 309 ! This sort original to F.T.Tracy (2006) 310 ! 311 ! 3. Parameters : 312 ! 313 ! Parameter list 314 ! ---------------------------------------------------------------- 315 ! IMI I.A. I Input discretized spectrum. 316 ! IND I.A. O Sorted data. 317 ! IHMAX Int. I Number of integer levels. 318 ! ---------------------------------------------------------------- 319 ! 320 ! 4. Subroutines used : 321 ! 322 ! Name Type Module Description 323 ! ---------------------------------------------------------------- 324 ! STRACE Sur. W3SERVMD Subroutine tracing. 325 ! ---------------------------------------------------------------- 326 ! 327 ! 10. Source code : 328 ! 329 !/ ------------------------------------------------------------------- / 330 ! 331 USE W3GDATMD, ONLY: NSPEC 332 ! 333 IMPLICIT NONE 334 !/ 335 !/ ------------------------------------------------------------------- / 336 !/ Parameter list 337 !/ 338 INTEGER, INTENT(IN) :: IHMAX, IMI(NSPEC) 339 INTEGER, INTENT(OUT) :: IND(NSPEC) 340 !/ 341 !/ ------------------------------------------------------------------- / 342 !/ Local parameters 343 !/ 344 INTEGER :: I, IN, IV 345 INTEGER :: NUMV(IHMAX), IADDR(IHMAX), & 346 IORDER(NSPEC) 347 !/ 348 ! 349 ! -------------------------------------------------------------------- / Page 9 Source Listing PTSORT 2014-09-16 17:02 w3partmd.f90 350 ! 1. Occurences per height 351 ! 352 NUMV = 0 353 DO I=1, NSPEC 354 NUMV(IMI(I)) = NUMV(IMI(I)) + 1 355 END DO 356 ! 357 ! -------------------------------------------------------------------- / 358 ! 2. Starting address per height 359 ! 360 IADDR(1) = 1 361 DO I=1, IHMAX-1 362 IADDR(I+1) = IADDR(I) + NUMV(I) 363 END DO 364 ! 365 ! -------------------------------------------------------------------- / 366 ! 3. Order points 367 ! 368 DO I=1, NSPEC 369 IV = IMI(I) 370 IN = IADDR(IV) 371 IORDER(I) = IN 372 IADDR(IV) = IN + 1 373 END DO 374 ! 375 ! -------------------------------------------------------------------- / 376 ! 4. Sort points 377 ! 378 DO I=1, NSPEC 379 IND(IORDER(I)) = I 380 END DO 381 ! 382 RETURN 383 !/ 384 !/ End of PTSORT ----------------------------------------------------- / 385 !/ 386 END SUBROUTINE PTSORT Page 10 Source Listing PTSORT 2014-09-16 17:02 Entry Points w3partmd.f90 ENTRY POINTS Name w3partmd_mp_ptsort_ SYMBOL CROSS REFERENCE Name Object Declared Type Bytes Dimen Elements Attributes References I Local 344 I(4) 4 scalar 353,354,361,362,368,369,371,378,37 9 IADDR Local 345 I(4) 4 1 0 360,362,370,372 IHMAX Dummy 294 I(4) 4 scalar ARG,IN 345,361 IMI Dummy 294 I(4) 4 1 0 ARG,IN 354,369 IN Local 344 I(4) 4 scalar 370,371,372 IND Dummy 294 I(4) 4 1 0 ARG,OUT 379 IORDER Local 346 I(4) 4 1 0 371,379 IV Local 344 I(4) 4 scalar 369,370,372 NSPEC Local 331 I(4) 4 scalar PTR 331,338,339,346,353,368,378 NUMV Local 345 I(4) 4 1 0 352,354,362 PTSORT Subr 294 199 W3GDATMD Module 331 331 Page 11 Source Listing PTSORT 2014-09-16 17:02 w3partmd.f90 387 !/ ------------------------------------------------------------------- / 388 SUBROUTINE PTNGHB 389 !/ 390 !/ +-----------------------------------+ 391 !/ | WAVEWATCH III USACE/NOAA | 392 !/ | Barbara Tracy | 393 !/ | H. L. Tolman | 394 !/ | FORTRAN 90 | 395 !/ | Last update : 20-Oct-2006 ! 396 !/ +-----------------------------------+ 397 !/ 398 !/ 20-Oct-2006 : Origination. ( version 3.10 ) 399 !/ 400 ! 1. Purpose : 401 ! 402 ! This subroutine computes the nearest neighbors for each grid 403 ! point. Wrapping of directional distribution (0 to 360)is taken 404 ! care of using the nearest neighbor system 405 ! 406 ! 3. Parameters : 407 ! 408 ! Parameter list 409 ! ---------------------------------------------------------------- 410 ! IMI I.A. I Input discretized spectrum. 411 ! IMD I.A. O Sorted data. 412 ! IHMAX Int. I Number of integer levels. 413 ! ---------------------------------------------------------------- 414 ! 415 ! 4. Subroutines used : 416 ! 417 ! Name Type Module Description 418 ! ---------------------------------------------------------------- 419 ! STRACE Sur. W3SERVMD Subroutine tracing. 420 ! ---------------------------------------------------------------- 421 ! 422 ! 10. Source code : 423 ! 424 !/ ------------------------------------------------------------------- / 425 ! 426 USE W3GDATMD, ONLY: NK, NTH, NSPEC 427 ! 428 IMPLICIT NONE 429 !/ 430 !/ ------------------------------------------------------------------- / 431 !/ Parameter list 432 !/ 433 ! INTEGER, INTENT(IN) :: IHMAX, IMI(NSPEC) 434 ! INTEGER, INTENT(IN) :: IMD(NSPEC) 435 !/ 436 !/ ------------------------------------------------------------------- / 437 !/ Local parameters 438 !/ 439 INTEGER :: N, J, I, K 440 !/ 441 ! 442 ! -------------------------------------------------------------------- / 443 ! 1. Check on need of processing Page 12 Source Listing PTNGHB 2014-09-16 17:02 w3partmd.f90 444 ! 445 IF ( MK.EQ.NK .AND. MTH.EQ.NTH ) RETURN 446 ! 447 IF ( MK.GT.0 ) DEALLOCATE ( NEIGH ) 448 ALLOCATE ( NEIGH(9,NSPEC) ) 449 MK = NK 450 MTH = NTH 451 ! 452 ! -------------------------------------------------------------------- / 453 ! 2. Build map 454 ! 455 NEIGH = 0 456 ! 457 ! ... Base loop 458 ! 459 DO N = 1, NSPEC 460 ! 461 J = (N-1) / NK + 1 462 I = N - (J-1) * NK 463 K = 0 464 ! 465 ! ... Point at the left(1) 466 ! 467 IF ( I .NE. 1 ) THEN 468 K = K + 1 469 NEIGH(K, N) = N - 1 470 END IF 471 ! 472 ! ... Point at the right (2) 473 ! 474 IF ( I .NE. NK ) THEN 475 K = K + 1 476 NEIGH(K, N) = N + 1 477 END IF 478 ! 479 ! ... Point at the bottom(3) 480 ! 481 IF ( J .NE. 1 ) THEN 482 K = K + 1 483 NEIGH(K, N) = N - NK 484 END IF 485 ! 486 ! ... ADD Point at bottom_wrap to top 487 ! 488 IF ( J .EQ. 1 ) THEN 489 K = K + 1 490 NEIGH(K,N) = NSPEC - (NK-I) 491 END IF 492 ! 493 ! ... Point at the top(4) 494 ! 495 IF ( J .NE. NTH ) THEN 496 K = K + 1 497 NEIGH(K, N) = N + NK 498 END IF 499 ! 500 ! ... ADD Point to top_wrap to bottom Page 13 Source Listing PTNGHB 2014-09-16 17:02 w3partmd.f90 501 ! 502 IF ( J .EQ. NTH ) THEN 503 K = K + 1 504 NEIGH(K,N) = N - (NTH-1) * NK 505 END IF 506 ! 507 ! ... Point at the bottom, left(5) 508 ! 509 IF ( (I.NE.1) .AND. (J.NE.1) ) THEN 510 K = K + 1 511 NEIGH(K, N) = N - NK - 1 512 END IF 513 ! 514 ! ... Point at the bottom, left with wrap. 515 ! 516 IF ( (I.NE.1) .AND. (J.EQ.1) ) THEN 517 K = K + 1 518 NEIGH(K,N) = N - 1 + NK * (NTH-1) 519 END IF 520 ! 521 ! ... Point at the bottom, right(6) 522 ! 523 IF ( (I.NE.NK) .AND. (J.NE.1) ) THEN 524 K = K + 1 525 NEIGH(K, N) = N - NK + 1 526 END IF 527 ! 528 ! ... Point at the bottom, right with wrap 529 ! 530 IF ( (I.NE.NK) .AND. (J.EQ.1) ) THEN 531 K = K + 1 532 NEIGH(K,N) = N + 1 + NK * (NTH - 1) 533 END IF 534 ! 535 ! ... Point at the top, left(7) 536 ! 537 IF ( (I.NE.1) .AND. (J.NE.NTH) ) THEN 538 K = K + 1 539 NEIGH(K, N) = N + NK - 1 540 END IF 541 ! 542 ! ... Point at the top, left with wrap 543 ! 544 IF ( (I.NE.1) .AND. (J.EQ.NTH) ) THEN 545 K = K + 1 546 NEIGH(K,N) = N - 1 - (NK) * (NTH-1) 547 END IF 548 ! 549 ! ... Point at the top, right(8) 550 ! 551 IF ( (I.NE.NK) .AND. (J.NE.NTH) ) THEN 552 K = K + 1 553 NEIGH(K, N) = N + NK + 1 554 END IF 555 ! 556 ! ... Point at top, right with wrap 557 ! Page 14 Source Listing PTNGHB 2014-09-16 17:02 w3partmd.f90 558 IF ( (I.NE.NK) .AND. (J.EQ.NTH) ) THEN 559 K = K + 1 560 NEIGH(K,N) = N + 1 - (NK) * (NTH-1) 561 END IF 562 ! 563 NEIGH(9,N) = K 564 ! 565 END DO 566 ! 567 RETURN 568 !/ 569 !/ End of PTNGHB ----------------------------------------------------- / 570 !/ 571 END SUBROUTINE PTNGHB ENTRY POINTS Name w3partmd_mp_ptnghb_ SYMBOL CROSS REFERENCE Name Object Declared Type Bytes Dimen Elements Attributes References I Local 439 I(4) 4 scalar 462,467,474,490,509,516,523,530,53 7,544,551,558 J Local 439 I(4) 4 scalar 461,462,481,488,495,502,509,516,52 3,530,537,544,551,558 K Local 439 I(4) 4 scalar 463,468,469,475,476,482,483,489,49 0,496,497,503,504,510,511,517,518, 524,525,531,532,538,539,545,546,55 2,553,559,560,563 MK Local 445 I(4) 4 scalar PRIV 70,445,447,449 MTH Local 445 I(4) 4 scalar PRIV 70,445,450 N Local 439 I(4) 4 scalar 459,461,462,469,476,483,490,497,50 4,511,518,525,532,539,546,553,560, 563 NEIGH Local 447 I(4) 4 2 1 ALC,PRIV 71,447,448,455,469,476,483,490,497 ,504,511,518,525,532,539,546,553,5 60,563,670,671,710,711,768,769,801 ,802,803,808 NK Local 426 I(4) 4 scalar PTR 426,445,449,461,462,474,483,490,49 7,504,511,518,523,525,530,532,539, 546,551,553,558,560 NSPEC Local 426 I(4) 4 scalar PTR 426,448,459,490 NTH Local 426 I(4) 4 scalar PTR 426,445,450,495,502,504,518,532,53 7,544,546,551,558,560 PTNGHB Subr 388 205 W3GDATMD Module 426 426 Page 15 Source Listing PTNGHB 2014-09-16 17:02 w3partmd.f90 572 !/ ------------------------------------------------------------------- / 573 SUBROUTINE PT_FLD ( IMI, IND, IMO, ZP, NPART ) 574 !/ 575 !/ +-----------------------------------+ 576 !/ | WAVEWATCH III NOAA/NCEP | 577 !/ | H. L. Tolman | 578 !/ | FORTRAN 90 | 579 !/ | Last update : 01-Nov-2006 ! 580 !/ +-----------------------------------+ 581 !/ 582 !/ 01-Nov-2006 : Origination. ( version 3.10 ) 583 !/ 584 ! 1. Purpose : 585 ! 586 ! This subroutine does incremental flooding of the image to 587 ! determine the watershed image. 588 ! 589 ! 3. Parameters : 590 ! 591 ! Parameter list 592 ! ---------------------------------------------------------------- 593 ! IMI I.A. I Input discretized spectrum. 594 ! IND I.A. I Sorted addresses. 595 ! IMO I.A. O Output partitioned spectrum. 596 ! ZP R.A. I Spectral array. 597 ! NPART Int. O Number of partitions found. 598 ! ---------------------------------------------------------------- 599 ! 600 ! 4. Subroutines used : 601 ! 602 ! Name Type Module Description 603 ! ---------------------------------------------------------------- 604 ! STRACE Sur. W3SERVMD Subroutine tracing. 605 ! ---------------------------------------------------------------- 606 ! 607 ! 10. Source code : 608 ! 609 !/ ------------------------------------------------------------------- / 610 ! 611 USE W3GDATMD, ONLY: NSPEC 612 ! 613 IMPLICIT NONE 614 !/ 615 !/ ------------------------------------------------------------------- / 616 !/ Parameter list 617 !/ 618 INTEGER, INTENT(IN) :: IMI(NSPEC), IND(NSPEC) 619 INTEGER, INTENT(OUT) :: IMO(NSPEC), NPART 620 REAL, INTENT(IN) :: ZP(NSPEC) 621 !/ 622 !/ ------------------------------------------------------------------- / 623 !/ Local parameters 624 !/ 625 INTEGER :: MASK, INIT, IWSHED, IMD(NSPEC), & 626 IC_LABEL, IFICT_PIXEL, M, IH, MSAVE, & 627 IP, I, IPP, IC_DIST, IEMPTY, IPPP, & 628 JL, JN, IPT, J Page 16 Source Listing FIFO_FIRST 2014-09-16 17:02 w3partmd.f90 629 INTEGER :: IQ(NSPEC), IQ_START, IQ_END 630 REAL :: ZPMAX, EP1, DIFF 631 !/ 632 ! 633 ! -------------------------------------------------------------------- / 634 ! 0. Initializations 635 ! 636 MASK = -2 637 INIT = -1 638 IWSHED = 0 639 IMO = INIT 640 IC_LABEL = 0 641 IMD = 0 642 IFICT_PIXEL = -100 643 ! 644 IQ_START = 1 645 IQ_END = 1 646 ! 647 ZPMAX = MAXVAL ( ZP ) 648 ! 649 ! -------------------------------------------------------------------- / 650 ! 1. Loop over levels 651 ! 652 M = 1 653 ! 654 DO IH=1, IHMAX 655 MSAVE = M 656 ! 657 ! 1.a Pixels at level IH 658 ! 659 DO 660 IP = IND(M) 661 IF ( IMI(IP) .NE. IH ) EXIT 662 ! 663 ! Flag the point, if it stays flagge, it is a separate minimum. 664 ! 665 IMO(IP) = MASK 666 ! 667 ! Consider neighbors. If there is neighbor, set distance and add 668 ! to queue. 669 ! 670 DO I=1, NEIGH(9,IP) 671 IPP = NEIGH(I,IP) 672 IF ( (IMO(IPP).GT.0) .OR. (IMO(IPP).EQ.IWSHED) ) THEN 673 IMD(IP) = 1 674 CALL FIFO_ADD (IP) 675 EXIT 676 END IF 677 END DO 678 ! 679 IF ( M+1 .GT. NSPEC ) THEN 680 EXIT 681 ELSE 682 M = M + 1 683 END IF 684 ! 685 END DO Page 17 Source Listing FIFO_FIRST 2014-09-16 17:02 w3partmd.f90 686 ! 687 ! 1.b Process the queue 688 ! 689 IC_DIST = 1 690 CALL FIFO_ADD (IFICT_PIXEL) 691 ! 692 DO 693 CALL FIFO_FIRST (IP) 694 ! 695 ! Check for end of processing 696 ! 697 IF ( IP .EQ. IFICT_PIXEL ) THEN 698 CALL FIFO_EMPTY (IEMPTY) 699 IF ( IEMPTY .EQ. 1 ) THEN 700 EXIT 701 ELSE 702 CALL FIFO_ADD (IFICT_PIXEL) 703 IC_DIST = IC_DIST + 1 704 CALL FIFO_FIRST (IP) 705 END IF 706 END IF 707 ! 708 ! Process queue 709 ! 710 DO I=1, NEIGH(9,IP) 711 IPP = NEIGH(I,IP) 712 ! 713 ! Check for labeled watersheds or basins 714 ! 715 IF ( (IMD(IPP).LT.IC_DIST) .AND. ( (IMO(IPP).GT.0) .OR. & 716 (IMO(IPP).EQ.IWSHED))) THEN 717 ! 718 IF ( IMO(IPP) .GT. 0 ) THEN 719 ! 720 IF ((IMO(IP) .EQ. MASK) .OR. (IMO(IP) .EQ. & 721 IWSHED)) THEN 722 IMO(IP) = IMO(IPP) 723 ELSE IF (IMO(IP) .NE. IMO(IPP)) THEN 724 IMO(IP) = IWSHED 725 END IF 726 ! 727 ELSE IF (IMO(IP) .EQ. MASK) THEN 728 ! 729 IMO(IP) = IWSHED 730 ! 731 END IF 732 ! 733 ELSE IF ( (IMO(IPP).EQ.MASK) .AND. (IMD(IPP).EQ.0) ) THEN 734 ! 735 IMD(IPP) = IC_DIST + 1 736 CALL FIFO_ADD (IPP) 737 ! 738 END IF 739 ! 740 END DO 741 ! 742 END DO Page 18 Source Listing FIFO_FIRST 2014-09-16 17:02 w3partmd.f90 743 ! 744 ! 1.c Check for mask values in IMO to identify new basins 745 ! 746 M = MSAVE 747 ! 748 DO 749 IP = IND(M) 750 IF ( IMI(IP) .NE. IH ) EXIT 751 IMD(IP) = 0 752 ! 753 IF (IMO(IP) .EQ. MASK) THEN 754 ! 755 ! ... New label for pixel 756 ! 757 IC_LABEL = IC_LABEL + 1 758 CALL FIFO_ADD (IP) 759 IMO(IP) = IC_LABEL 760 ! 761 ! ... and all connected to it ... 762 ! 763 DO 764 CALL FIFO_EMPTY (IEMPTY) 765 IF ( IEMPTY .EQ. 1 ) EXIT 766 CALL FIFO_FIRST (IPP) 767 ! 768 DO I=1, NEIGH(9,IPP) 769 IPPP = NEIGH(I,IPP) 770 IF ( IMO(IPPP) .EQ. MASK ) THEN 771 CALL FIFO_ADD (IPPP) 772 IMO(IPPP) = IC_LABEL 773 END IF 774 END DO 775 ! 776 END DO 777 ! 778 END IF 779 ! 780 IF ( M + 1 .GT. NSPEC ) THEN 781 EXIT 782 ELSE 783 M = M + 1 784 END IF 785 ! 786 END DO 787 ! 788 END DO 789 ! 790 ! -------------------------------------------------------------------- / 791 ! 2. Find nearest neighbor of 0 watershed points and replace 792 ! use original input to check which group to affiliate with 0 793 ! Soring changes first in IMD to assure symetry in adjustment. 794 ! 795 DO J=1, 5 796 IMD = IMO 797 DO JL=1 , NSPEC 798 IPT = -1 799 IF ( IMO(JL) .EQ. 0 ) THEN Page 19 Source Listing FIFO_FIRST 2014-09-16 17:02 w3partmd.f90 800 EP1 = ZPMAX 801 DO JN=1, NEIGH (9,JL) 802 DIFF = ABS ( ZP(JL) - ZP(NEIGH(JN,JL))) 803 IF ( (DIFF.LE.EP1) .AND. (IMO(NEIGH(JN,JL)).NE.0) ) THEN 804 EP1 = DIFF 805 IPT = JN 806 END IF 807 END DO 808 IF ( IPT .GT. 0 ) IMD(JL) = IMO(NEIGH(IPT,JL)) 809 END IF 810 END DO 811 IMO = IMD 812 IF ( MINVAL(IMO) .GT. 0 ) EXIT 813 END DO 814 ! 815 NPART = IC_LABEL 816 ! 817 RETURN 818 ! 819 CONTAINS 820 !/ ------------------------------------------------------------------- / 821 SUBROUTINE FIFO_ADD ( IV ) 822 ! 823 ! Add point to FIFO queue. 824 ! 825 INTEGER, INTENT(IN) :: IV 826 ! 827 IQ(IQ_END) = IV 828 ! 829 IQ_END = IQ_END + 1 830 IF ( IQ_END .GT. NSPEC ) IQ_END = 1 831 ! 832 RETURN 833 END SUBROUTINE Page 20 Source Listing FIFO_ADD 2014-09-16 17:02 Entry Points w3partmd.f90 ENTRY POINTS Name w3partmdpt_fld_mp_fifo_add_ SYMBOL CROSS REFERENCE Name Object Declared Type Bytes Dimen Elements Attributes References FIFO_ADD Subr 821 674,690,702,736,758,771 IQ Local 827 I(4) 4 1 0 827,856 IQ_END Local 827 I(4) 4 scalar 645,827,829,830,841 IV Dummy 821 I(4) 4 scalar ARG,IN 827 NSPEC Local 830 I(4) 4 scalar PTR 611,618,619,620,625,629,679,780,79 7,830,859 Page 21 Source Listing FIFO_ADD 2014-09-16 17:02 w3partmd.f90 834 !/ ------------------------------------------------------------------- / 835 SUBROUTINE FIFO_EMPTY ( IEMPTY ) 836 ! 837 ! Check if queue is empty. 838 ! 839 INTEGER, INTENT(OUT) :: IEMPTY 840 ! 841 IF ( IQ_START .NE. IQ_END ) THEN 842 IEMPTY = 0 843 ELSE 844 IEMPTY = 1 845 END IF 846 ! 847 RETURN 848 END SUBROUTINE ENTRY POINTS Name w3partmdpt_fld_mp_fifo_empty_ SYMBOL CROSS REFERENCE Name Object Declared Type Bytes Dimen Elements Attributes References FIFO_EMPTY Subr 835 698,764 IEMPTY Dummy 835 I(4) 4 scalar ARG,OUT 842,844 IQ_START Local 841 I(4) 4 scalar 644,841,856,858,859 Page 22 Source Listing FIFO_EMPTY 2014-09-16 17:02 w3partmd.f90 849 !/ ------------------------------------------------------------------- / 850 SUBROUTINE FIFO_FIRST ( IV ) 851 ! 852 ! Get point out of queue. 853 ! 854 INTEGER, INTENT(OUT) :: IV 855 ! 856 IV = IQ(IQ_START) 857 ! 858 IQ_START = IQ_START + 1 859 IF ( IQ_START .GT. NSPEC ) IQ_START = 1 860 ! 861 RETURN 862 END SUBROUTINE ENTRY POINTS Name w3partmdpt_fld_mp_fifo_first_ SYMBOL CROSS REFERENCE Name Object Declared Type Bytes Dimen Elements Attributes References FIFO_FIRST Subr 850 693,704,766 IV Dummy 850 I(4) 4 scalar ARG,OUT 856 Page 23 Source Listing FIFO_FIRST 2014-09-16 17:02 w3partmd.f90 863 !/ 864 !/ End of PT_FLD ----------------------------------------------------- / 865 !/ 866 END SUBROUTINE PT_FLD ENTRY POINTS Name w3partmd_mp_pt_fld_ SYMBOL CROSS REFERENCE Name Object Declared Type Bytes Dimen Elements Attributes References ABS Func 802 scalar 802 DIFF Local 630 R(4) 4 scalar 802,803,804 EP1 Local 630 R(4) 4 scalar 800,803,804 I Local 627 I(4) 4 scalar 670,671,710,711,768,769 IC_DIST Local 627 I(4) 4 scalar 689,703,715,735 IC_LABEL Local 626 I(4) 4 scalar 640,757,759,772,815 IEMPTY Local 627 I(4) 4 scalar 698,699,764,765 IFICT_PIXEL Local 626 I(4) 4 scalar 642,690,697,702 IH Local 626 I(4) 4 scalar 654,661,750 IMD Local 625 I(4) 4 1 0 641,673,715,733,735,751,796,808,81 1 IMI Dummy 573 I(4) 4 1 0 ARG,IN 661,750 IMO Dummy 573 I(4) 4 1 0 ARG,OUT 639,665,672,715,716,718,720,722,72 3,724,727,729,733,753,759,770,772, 796,799,803,808,811,812 IND Dummy 573 I(4) 4 1 0 ARG,IN 660,749 INIT Local 625 I(4) 4 scalar 637,639 IP Local 627 I(4) 4 scalar 660,661,665,670,671,673,674,693,69 7,704,710,711,720,722,723,724,727, 729,749,750,751,753,758,759 IPP Local 627 I(4) 4 scalar 671,672,711,715,716,718,722,723,73 3,735,736,766,768,769 IPPP Local 627 I(4) 4 scalar 769,770,771,772 IPT Local 628 I(4) 4 scalar 798,805,808 IWSHED Local 625 I(4) 4 scalar 638,672,716,721,724,729 J Local 628 I(4) 4 scalar 795 JL Local 628 I(4) 4 scalar 797,799,801,802,803,808 JN Local 628 I(4) 4 scalar 801,802,803,805 M Local 626 I(4) 4 scalar 652,655,660,679,682,746,749,780,78 3 MASK Local 625 I(4) 4 scalar 636,665,720,727,733,753,770 MAXVAL Func 647 scalar 647 MINVAL Func 812 scalar 812 MSAVE Local 626 I(4) 4 scalar 655,746 NPART Dummy 573 I(4) 4 scalar ARG,OUT 815 PT_FLD Subr 573 209 W3GDATMD Module 611 611 ZP Dummy 573 R(4) 4 1 0 ARG,IN 647,802 ZPMAX Local 630 R(4) 4 scalar 647,800 Page 24 Source Listing FIFO_FIRST 2014-09-16 17:02 w3partmd.f90 867 !/ ------------------------------------------------------------------- / 868 SUBROUTINE PTMEAN ( NPI, IMO, ZP, DEPTH, UABS, UDIR, WN, & 869 NPO, XP, DIMXP, PMAP ) 870 !/ 871 !/ +-----------------------------------+ 872 !/ | WAVEWATCH III USACE/NOAA | 873 !/ | Barbara Tracy | 874 !/ | H. L. Tolman | 875 !/ | FORTRAN 90 | 876 !/ | Last update : 24-Mar-2007 ! 877 !/ +-----------------------------------+ 878 !/ 879 !/ 28-Oct-2006 : Origination. ( version 3.10 ) 880 !/ 02-Nov-2006 : Adding tail to integration. ( version 3.10 ) 881 !/ 24-Mar-2007 : Adding overall field. ( version 3.11 ) 882 !/ 02-Dec-2010 : Adding a mapping PMAP between ( version 3.14 ) 883 !/ original and combined partitions 884 !/ ( M. Szyszka ) 885 !/ 886 ! 1. Purpose : 887 ! 888 ! Compute mean parameters per partition. 889 ! 890 ! 3. Parameters : 891 ! 892 ! Parameter list 893 ! ---------------------------------------------------------------- 894 ! NPI Int. I Number of partitions found. 895 ! IMO I.A. I Partition map. 896 ! ZP R.A. I Input spectrum. 897 ! DEPTH Real I Water depth. 898 ! UABS Real I Wind speed. 899 ! UDIR Real I Wind direction. 900 ! WN R.A. I Wavenumebers for each frequency. 901 ! NPO Int. O Number of partitions with mean parameters. 902 ! XP R.A. O Array with output parameters. 903 ! DIMXP int. I Second dimesion of XP. 904 ! PMAP I.A. O Mapping between orig. and combined partitions 905 ! ---------------------------------------------------------------- 906 ! 907 ! 4. Subroutines used : 908 ! 909 ! Name Type Module Description 910 ! ---------------------------------------------------------------- 911 ! STRACE Sur. W3SERVMD Subroutine tracing. 912 ! WAVNU1 Subr. W3DISPMD Wavenumber computation. 913 ! ---------------------------------------------------------------- 914 ! 915 ! 10. Source code : 916 ! 917 !/ ------------------------------------------------------------------- / 918 ! 919 USE CONSTANTS 920 USE W3DISPMD, ONLY: WAVNU1 921 ! 922 USE W3GDATMD, ONLY: NK, NTH, NSPEC, DTH, SIG, DSII, DSIP, & 923 ECOS, ESIN, XFR, FACHFE, TH, FTE Page 25 Source Listing PTMEAN 2014-09-16 17:02 w3partmd.f90 924 USE W3ODATMD, ONLY: IAPROC, NAPERR, NDSE, NDST 925 ! 926 IMPLICIT NONE 927 !/ 928 !/ ------------------------------------------------------------------- / 929 !/ Parameter list 930 !/ 931 INTEGER, INTENT(IN) :: NPI, IMO(NSPEC), DIMXP 932 INTEGER, INTENT(OUT) :: NPO, PMAP(DIMXP) 933 REAL, INTENT(IN) :: ZP(NSPEC), DEPTH, UABS, UDIR, WN(NK) 934 REAL, INTENT(OUT) :: XP(6,0:DIMXP) 935 !/ 936 !/ ------------------------------------------------------------------- / 937 !/ Local parameters 938 !/ 939 INTEGER :: IK, ITH, ISP, IP, IFPMAX(0:NPI) 940 REAL :: SUMF(0:NK+1,0:NPI), SUMFW(NK,0:NPI), & 941 SUMFX(NK,0:NPI), SUMFY(NK,0:NPI), & 942 SUME(0:NPI), SUMEW(0:NPI), & 943 SUMEX(0:NPI), SUMEY(0:NPI), & 944 EFPMAX(0:NPI), FCDIR(NTH) 945 REAL :: HS, XL, XH, XL2, XH2, EL, EH, DENOM, & 946 SIGP, WNP, CGP, UPAR, C(NK), RD, FACT 947 !/ 948 ! 949 ! -------------------------------------------------------------------- / 950 ! 1. Check on need of processing 951 ! 952 NPO = 0 953 XP = 0. 954 ! 955 IF ( NPI .EQ. 0 ) RETURN 956 ! 957 ! -------------------------------------------------------------------- / 958 ! 2. Initialize arrays 959 ! 960 SUMF = 0. 961 SUMFW = 0. 962 SUMFX = 0. 963 SUMFY = 0. 964 SUME = 0. 965 SUMEW = 0. 966 SUMEX = 0. 967 SUMEY = 0. 968 IFPMAX = 0 969 EFPMAX = 0. 970 ! 971 DO IK=1, NK 972 C(IK) = SIG(IK) / WN(IK) 973 END DO 974 ! 975 DO ITH=1, NTH 976 UPAR = WSMULT * UABS * MAX(0.,COS(TH(ITH)-DERA*UDIR)) 977 IF ( UPAR .LT. C(NK) ) THEN 978 FCDIR(ITH) = SIG(NK+1) 979 ELSE 980 DO IK=NK-1, 2, -1 Page 26 Source Listing PTMEAN 2014-09-16 17:02 w3partmd.f90 981 IF ( UPAR .LT. C(IK) ) EXIT 982 END DO 983 RD = (C(IK)-UPAR) / (C(IK)-C(IK+1)) 984 IF ( RD .LT. 0 ) THEN 985 IK = 0 986 RD = MAX ( 0., RD+1. ) 987 END IF 988 FCDIR(ITH) = RD*SIG(IK+1) + (1.-RD)*SIG(IK) 989 END IF 990 END DO 991 ! 992 ! -------------------------------------------------------------------- / 993 ! 3. Spectral integrals and preps 994 ! 3.a Integrals 995 ! NOTE: Factor DTH only used in Hs computation. 996 ! 997 DO IK=1, NK 998 DO ITH=1, NTH 999 ISP = IK + (ITH-1)*NK 1000 IP = IMO(ISP) 1001 FACT = MAX ( 0. , MIN ( 1. , & 1002 1. - ( FCDIR(ITH) - 0.5*(SIG(IK-1)+SIG(IK)) ) / DSIP(IK) ) ) 1003 SUMF (IK, 0) = SUMF (IK, 0) + ZP(ISP) 1004 SUMFW(IK, 0) = SUMFW(IK, 0) + ZP(ISP) * FACT 1005 SUMFX(IK, 0) = SUMFX(IK, 0) + ZP(ISP) * ECOS(ITH) 1006 SUMFY(IK, 0) = SUMFY(IK, 0) + ZP(ISP) * ESIN(ITH) 1007 IF ( IP .EQ. 0 ) CYCLE 1008 SUMF (IK,IP) = SUMF (IK,IP) + ZP(ISP) 1009 SUMFW(IK,IP) = SUMFW(IK,IP) + ZP(ISP) * FACT 1010 SUMFX(IK,IP) = SUMFX(IK,IP) + ZP(ISP) * ECOS(ITH) 1011 SUMFY(IK,IP) = SUMFY(IK,IP) + ZP(ISP) * ESIN(ITH) 1012 END DO 1013 END DO 1014 SUMF(NK+1,:) = SUMF(NK,:) * FACHFE 1015 ! 1016 DO IP=0, NPI 1017 DO IK=1, NK 1018 SUME (IP) = SUME (IP) + SUMF (IK,IP) * DSII(IK) 1019 SUMEW(IP) = SUMEW(IP) + SUMFW(IK,IP) * DSII(IK) 1020 SUMEX(IP) = SUMEX(IP) + SUMFX(IK,IP) * DSII(IK) 1021 SUMEY(IP) = SUMEY(IP) + SUMFY(IK,IP) * DSII(IK) 1022 IF ( SUMF(IK,IP) .GT. EFPMAX(IP) ) THEN 1023 IFPMAX(IP) = IK 1024 EFPMAX(IP) = SUMF(IK,IP) 1025 END IF 1026 END DO 1027 SUME (IP) = SUME (IP) + SUMF (NK,IP) * FTE 1028 SUMEW(IP) = SUMEW(IP) + SUMFW(NK,IP) * FTE 1029 SUMEX(IP) = SUMEX(IP) + SUMFX(NK,IP) * FTE 1030 SUMEY(IP) = SUMEY(IP) + SUMFY(NK,IP) * FTE 1031 END DO 1032 ! 1033 ! -------------------------------------------------------------------- / 1034 ! 4. Compute pars 1035 ! 1036 NPO = -1 1037 ! Page 27 Source Listing PTMEAN 2014-09-16 17:02 w3partmd.f90 1038 DO IP=0, NPI 1039 ! 1040 HS = 4. * SQRT ( MAX(SUME(IP) * DTH * TPIINV,0.) ) 1041 IF ( HS .LT. HSPMIN ) CYCLE 1042 ! 1043 XL = 1./XFR - 1. 1044 XH = XFR - 1. 1045 XL2 = XL**2 1046 XH2 = XH**2 1047 EL = SUMF(IFPMAX(IP)-1,IP) - SUMF(IFPMAX(IP),IP) 1048 EH = SUMF(IFPMAX(IP)+1,IP) - SUMF(IFPMAX(IP),IP) 1049 DENOM = XL*EH - XH*EL 1050 SIGP = SIG(IFPMAX(IP)) * ( 1. + 0.5 * ( XL2*EH - XH2*EL ) & 1051 / SIGN ( MAX(ABS(DENOM),1.E-15) , DENOM ) ) 1052 CALL WAVNU1 ( SIGP, DEPTH, WNP, CGP ) 1053 ! 1054 IF ( NPO .GE. DIMXP ) GOTO 2000 1055 NPO = NPO + 1 1056 IF (IP.GT.0)THEN 1057 IF(NPO.LT.1)CYCLE 1058 PMAP(NPO) = IP 1059 ENDIF 1060 XP(1,NPO) = HS 1061 XP(2,NPO) = TPI / SIGP 1062 XP(3,NPO) = TPI / WNP 1063 XP(4,NPO) = MOD( 630.-ATAN2(SUMEY(IP),SUMEX(IP))*RADE , 360. ) 1064 XP(5,NPO) = RADE * SQRT ( MAX ( 0. , 2. * ( 1. - SQRT ( & 1065 MAX(0.,(SUMEX(IP)**2+SUMEY(IP)**2)/SUME(IP)**2) ) ) ) ) 1066 1067 XP(6,NPO) = SUMEW(IP) / SUME(IP) 1068 ! 1069 END DO 1070 ! 1071 RETURN 1072 ! 1073 ! Escape locations read errors --------------------------------------- * 1074 ! 1075 2000 CONTINUE 1076 IF ( IAPROC .EQ. NAPERR ) WRITE (NDSE,1000) NPO+1 1077 RETURN 1078 ! 1079 ! Formats 1080 ! 1081 1000 FORMAT (/' *** WAVEWATCH III ERROR IN PTMEAN :'/ & 1082 ' XP ARRAY TOO SMALL AT PARTITION',I6/) 1083 !/ 1084 !/ End of PTMEAN ----------------------------------------------------- / 1085 !/ 1086 END SUBROUTINE PTMEAN Page 28 Source Listing PTMEAN 2014-09-16 17:02 Entry Points w3partmd.f90 ENTRY POINTS Name w3partmd_mp_ptmean_ SYMBOL CROSS REFERENCE Name Object Declared Type Bytes Dimen Elements Attributes References 1000 Label 1081 1076 2000 Label 1075 1054 ABS Func 1051 scalar 1051 ATAN2 Func 1063 scalar 1063 C Local 946 R(4) 4 1 0 972,977,981,983 CGP Local 946 R(4) 4 scalar 1052 CONSTANTS Module 919 919 COS Func 976 scalar 976 DENOM Local 945 R(4) 4 scalar 1049,1051 DEPTH Dummy 868 R(4) 4 scalar ARG,IN 1052 DERA Param 976 R(4) 4 scalar 976 DIMXP Dummy 869 I(4) 4 scalar ARG,IN 932,934,1054 DSII Local 922 R(4) 4 1 1 PTR 922,1018,1019,1020,1021 DSIP Local 922 R(4) 4 1 1 PTR 922,1002 DTH Local 922 R(4) 4 scalar PTR 922,1040 ECOS Local 923 R(4) 4 1 1 PTR 923,1005,1010 EFPMAX Local 944 R(4) 4 1 0 969,1022,1024 EH Local 945 R(4) 4 scalar 1048,1049,1050 EL Local 945 R(4) 4 scalar 1047,1049,1050 ESIN Local 923 R(4) 4 1 1 PTR 923,1006,1011 FACHFE Local 923 R(4) 4 scalar PTR 923,1014 FACT Local 946 R(4) 4 scalar 1001,1004,1009 FCDIR Local 944 R(4) 4 1 0 978,988,1002 FTE Local 923 R(4) 4 scalar PTR 923,1027,1028,1029,1030 HS Local 945 R(4) 4 scalar 1040,1041,1060 HSPMIN Local 1041 R(4) 4 scalar PTR 66,1041 IAPROC Local 924 I(4) 4 scalar PTR 924,1076 IFPMAX Local 939 I(4) 4 1 0 968,1023,1047,1048,1050 IK Local 939 I(4) 4 scalar 971,972,980,981,983,985,988,997,99 9,1002,1003,1004,1005,1006,1008,10 09,1010,1011,1017,1018,1019,1020,1 021,1022,1023,1024 IMO Dummy 868 I(4) 4 1 0 ARG,IN 1000 IP Local 939 I(4) 4 scalar 1000,1007,1008,1009,1010,1011,1016 ,1018,1019,1020,1021,1022,1023,102 4,1027,1028,1029,1030,1038,1040,10 47,1048,1050,1056,1058,1063,1065,1 067 ISP Local 939 I(4) 4 scalar 999,1000,1003,1004,1005,1006,1008, 1009,1010,1011 ITH Local 939 I(4) 4 scalar 975,976,978,988,998,999,1002,1005, 1006,1010,1011 MAX Func 976 scalar 976,986,1001,1040,1051,1064,1065 MIN Func 1001 scalar 1001 Page 29 Source Listing PTMEAN 2014-09-16 17:02 Symbol Table w3partmd.f90 Name Object Declared Type Bytes Dimen Elements Attributes References MOD Func 1063 scalar 1063 NAPERR Local 924 I(4) 4 scalar PTR 924,1076 NDSE Local 924 I(4) 4 scalar PTR 924,1076 NDST Local 924 I(4) 4 scalar PTR 924 NK Local 922 I(4) 4 scalar PTR 922,933,940,941,946,971,977,978,98 0,997,999,1014,1017,1027,1028,1029 ,1030 NPI Dummy 868 I(4) 4 scalar ARG,IN 939,940,941,942,943,944,955,1016,1 038 NPO Dummy 869 I(4) 4 scalar ARG,OUT 952,1036,1054,1055,1057,1058,1060, 1061,1062,1063,1064,1067,1076 NSPEC Local 922 I(4) 4 scalar PTR 922,931,933 NTH Local 922 I(4) 4 scalar PTR 922,944,975,998 PMAP Dummy 869 I(4) 4 1 0 ARG,OUT 1058 PTMEAN Subr 868 214,247 RADE Param 1063 R(4) 4 scalar 1063,1064 RD Local 946 R(4) 4 scalar 983,984,986,988 SIG Local 922 R(4) 4 1 1 PTR 922,972,978,988,1002,1050 SIGN Func 1051 scalar 1051 SIGP Local 946 R(4) 4 scalar 1050,1052,1061 SQRT Func 1040 scalar 1040,1064 SUME Local 942 R(4) 4 1 0 964,1018,1027,1040,1065,1067 SUMEW Local 942 R(4) 4 1 0 965,1019,1028,1067 SUMEX Local 943 R(4) 4 1 0 966,1020,1029,1063,1065 SUMEY Local 943 R(4) 4 1 0 967,1021,1030,1063,1065 SUMF Local 940 R(4) 4 2 0 960,1003,1008,1014,1018,1022,1024, 1027,1047,1048 SUMFW Local 940 R(4) 4 2 0 961,1004,1009,1019,1028 SUMFX Local 941 R(4) 4 2 0 962,1005,1010,1020,1029 SUMFY Local 941 R(4) 4 2 0 963,1006,1011,1021,1030 TH Local 923 R(4) 4 1 1 PTR 923,976 TPI Param 1061 R(4) 4 scalar 1061,1062 TPIINV Param 1040 R(4) 4 scalar 1040 UABS Dummy 868 R(4) 4 scalar ARG,IN 976 UDIR Dummy 868 R(4) 4 scalar ARG,IN 976 UPAR Local 946 R(4) 4 scalar 976,977,981,983 W3DISPMD Module 920 920 W3GDATMD Module 922 922 W3ODATMD Module 924 924 WAVNU1 Subr 920 920,1052 WN Dummy 868 R(4) 4 1 0 ARG,IN 972 WNP Local 946 R(4) 4 scalar 1052,1062 WSMULT Local 976 R(4) 4 scalar PTR 66,976 XFR Local 923 R(4) 4 scalar PTR 923,1043,1044 XH Local 945 R(4) 4 scalar 1044,1046,1049 XH2 Local 945 R(4) 4 scalar 1046,1050 XL Local 945 R(4) 4 scalar 1043,1045,1049 XL2 Local 945 R(4) 4 scalar 1045,1050 XP Dummy 869 R(4) 4 2 0 ARG,OUT 953,1060,1061,1062,1063,1064,1067 ZP Dummy 868 R(4) 4 1 0 ARG,IN 1003,1004,1005,1006,1008,1009,1010 ,1011 Page 30 Source Listing PTMEAN 2014-09-16 17:02 w3partmd.f90 1087 !/ 1088 !/ End of module W3PARTMD -------------------------------------------- / 1089 !/ 1090 END MODULE W3PARTMD SYMBOL CROSS REFERENCE Name Object Declared Type Bytes Dimen Elements Attributes References W3ODATMD Module 66 66 W3PARTMD Module 2 Page 31 Source Listing PTMEAN 2014-09-16 17:02 Subprograms/Common Blocks w3partmd.f90 SUBPROGRAMS/COMMON BLOCKS Name Object Declared Type Bytes Dimen Elements Attributes References FIFO_ADD Subr 821 674,690,702,736,758,771 FIFO_EMPTY Subr 835 698,764 FIFO_FIRST Subr 850 693,704,766 PTMEAN Subr 868 214,247 PTNGHB Subr 388 205 PTSORT Subr 294 199 PT_FLD Subr 573 209 W3PART Subr 75 W3PARTMD Module 2 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 -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__ Page 32 Source Listing PTMEAN 2014-09-16 17:02 w3partmd.f90 -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, /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 : w3partmd.lst -o filename : none COMPILER: Intel(R) Fortran 12.1-2100