Page 1 Source Listing W3MAP3 2014-09-16 16:49 w3pro3md.f90 1 !/ ------------------------------------------------------------------- / 2 MODULE W3PRO3MD 3 !/ 4 !/ +-----------------------------------+ 5 !/ | WAVEWATCH III NOAA/NCEP | 6 !/ | H. L. Tolman | 7 !/ | FORTRAN 90 | 8 !/ | Last update : 12-Sep-2013 | 9 !/ +-----------------------------------+ 10 !/ 11 !/ 27-Feb-2000 : Origination. ( version 2.08 ) 12 !/ 17-Sep-2000 : Clean-up. ( version 2.13 ) 13 !/ 10-Dec-2001 : Sub-grid obstructions. ( version 2.14 ) 14 !/ 16-Oct-2002 : Change INTENT for ATRN in W3XYP3. ( version 3.00 ) 15 !/ 26-Dec-2002 : Moving grid version. ( version 3.02 ) 16 !/ 01-Aug-2003 : Moving grid GSE correction. ( version 3.03 ) 17 !/ 17-Dec-2004 : Multiple grid version. ( version 3.06 ) 18 !/ 07-Sep-2005 : Upgrade XY boundary conditions. ( version 3.08 ) 19 !/ 09-Nov-2005 : Removing soft boundary option. ( version 3.08 ) 20 !/ 05-Mar-2008 : Added NEC sxf90 compiler directives. 21 !/ (Chris Bunney, UK Met Office) ( version 3.13 ) 22 !/ 01-Apr-2008 : Bug fix W3MAP3 MAPSTA range check. ( version 3.13 ) 23 !/ 29-May-2009 : Preparing distribution version. ( version 3.14 ) 24 !/ 30-Oct-2009 : Implement curvilinear grid type. ( version 3.14 ) 25 !/ (W. E. Rogers & T. J. Campbell, NRL) 26 !/ 17-Aug-2010 : Add test output W3XYP3. ( version 3.14.5 ) 27 !/ 06-Dec-2010 : Change from GLOBAL (logical) to ICLOSE (integer) to 28 !/ specify index closure for a grid. ( version 3.14 ) 29 !/ (T. J. Campbell, NRL) 30 !/ 26-Dec-2012 : More initializations. ( version 4.11 ) 31 !/ 01-Jul-2013 : Adding UQ and UNO switches to chose between third 32 !/ and second order schemes. ( version 4.12 ) 33 !/ 12-Sep-2013 : Add documentation for global clos. ( version 4.12 ) 34 !/ 35 !/ Copyright 2009-2013 National Weather Service (NWS), 36 !/ National Oceanic and Atmospheric Administration. All rights 37 !/ reserved. WAVEWATCH III is a trademark of the NWS. 38 !/ No unauthorized use without permission. 39 !/ 40 ! 1. Purpose : 41 ! 42 ! Bundles routines for third order porpagation scheme in single 43 ! module. 44 ! 45 ! 2. Variables and types : 46 ! 47 ! Name Type Scope Description 48 ! ---------------------------------------------------------------- 49 ! TRNMIN R.P. Private Minimum transparancy for local 50 ! switching off of averaging. 51 ! ---------------------------------------------------------------- 52 ! 53 ! Also work arrays for W3KTP3 (private). 54 ! 55 ! 3. Subroutines and functions : 56 ! 57 ! Name Type Scope Description Page 2 Source Listing W3MAP3 2014-09-16 16:49 w3pro3md.f90 58 ! ---------------------------------------------------------------- 59 ! W3MAP3 Subr. Public Set up auxiliary maps. 60 ! W3MAPT Subr. Public Set up transparency map for GSE. 61 ! W3XYP3 Subr. Public Third order spatial propagation. 62 ! W3KTP3 Subr. Public Third order spectral propagation. 63 ! ---------------------------------------------------------------- 64 ! 65 ! 4. Subroutines and functions used : 66 ! 67 ! Name Type Module Description 68 ! ---------------------------------------------------------------- 69 ! STRACE Subr. W3SERVMD Subroutine tracing. 70 ! W3QCK1 Subr. W3UQCKMD Regular grid UQ scheme. 71 ! W3QCK2 Subr. Id. Irregular grid UQ scheme. 72 ! W3QCK3 Subr. Id. Regular grid UQ scheme + obstructions. 73 ! W3UNO2 Subr. W3UNO2MD UNO2 scheme for irregular grid. 74 ! W3UNO2r Subr. Id. UNO2 scheme reduced to regular grid. 75 ! W3UNO2s Subr. Id. UNO2 regular grid with subgrid 76 ! obstruction. 77 ! ---------------------------------------------------------------- 78 ! 79 ! 5. Remarks : 80 ! 81 ! - The averaging is not performed around semi-transparent grid 82 ! points to avoid that leaking through barriers occurs. 83 ! 84 ! 6. Switches : 85 ! 86 ! !/UQ 3rd order UQ propagation scheme. 87 ! !/UNO 2nd order UNO propagation scheme. 88 ! 89 ! !/C90 Cray FORTRAN 90 compiler directives. 90 ! !/NEC NEC SXF90 compiler directives. 91 ! 92 ! !/MGP Moving grid corrections. 93 ! !/MGG Moving grid corrections. 94 ! 95 ! !/S Enable subroutine tracing. 96 ! !/Tn Enable test output. 97 ! 98 ! 7. Source code : 99 ! 100 !/ ------------------------------------------------------------------- / 101 !/ 102 !/ Public variables 103 !/ 104 PUBLIC 105 !/ 106 !/ Private data 107 !/ 108 REAL, PRIVATE, PARAMETER:: TRNMIN = 0.95 109 !/ 110 CONTAINS 111 !/ ------------------------------------------------------------------- / 112 SUBROUTINE W3MAP3 113 !/ 114 !/ +-----------------------------------+ Page 3 Source Listing W3MAP3 2014-09-16 16:49 w3pro3md.f90 115 !/ | WAVEWATCH III NOAA/NCEP | 116 !/ | H. L. Tolman | 117 !/ | FORTRAN 90 | 118 !/ | Last update : 01-Apr-2008 | 119 !/ +-----------------------------------+ 120 !/ 121 !/ 27-Feb-2000 : Origination. ( version 2.08 ) 122 !/ 10-Dec-2001 : Sub-grid obstructions. ( version 2.14 ) 123 !/ (array allocation only.) 124 !/ 17-Dec-2004 : Multiple grid version. ( version 3.06 ) 125 !/ 09-Nov-2005 : Removing soft boundary option. ( version 3.08 ) 126 !/ 01-Apr-2008 : Bug fix sec. 4 MAPSTA range check. ( version 3.13 ) 127 !/ 128 ! 1. Purpose : 129 ! 130 ! Generate 'map' arrays for the ULTIMATE QUICKEST scheme. 131 ! 132 ! 2. Method : 133 ! 134 ! MAPX2, MAPY2, MAPTH2 and MAPWN2 contain consecutive 1-D spatial 135 ! grid counters (e.g., IXY = (IX-1)*MY + IY). The arrays are 136 ! devided in three parts. For MAPX2, these ranges are : 137 ! 138 ! 1 - NMX0 Counters IXY for which grid point (IX,IY) and 139 ! (IX+1,IY) both are active grid points. 140 ! NMX0+1 - NMX1 Id. only (IX,IY) active. 141 ! NMX1+1 - NMX2 Id. only (IX+1,IY) active. 142 ! 143 ! The array MAPY2 has a similar layout varying IY instead of IX. 144 ! 145 ! 3. Parameters : 146 ! 147 ! Parameter list 148 ! ---------------------------------------------------------------- 149 ! ---------------------------------------------------------------- 150 ! 151 ! 4. Subroutines used : 152 ! 153 ! See module documentation. 154 ! 155 ! 5. Called by : 156 ! 157 ! Name Type Module Description 158 ! ---------------------------------------------------------------- 159 ! W3WAVE Subr. W3WAVEMD Wave model routine. 160 ! ---------------------------------------------------------------- 161 ! 162 ! 6. Error messages : 163 ! 164 ! 7. Remarks : 165 ! 166 ! 8. Structure : 167 ! 168 ! ------------------------------------------------------ 169 ! 1. Map MAPX2 170 ! a Range 1 to NMX0 171 ! b Range NMX0+1 to NMX1 Page 4 Source Listing W3MAP3 2014-09-16 16:49 w3pro3md.f90 172 ! c Range NMX1+1 to NMX2 173 ! 2. Map MAPY2 174 ! a Range 1 to NMY0 175 ! b Range NMY0+1 to NMY1 176 ! c Range NMY1+1 to NMY2 177 ! 3. Map MAPAXY 178 ! 4. Map MAPCXY 179 ! 5. Maps for intra-spectral propagation 180 ! a MAPTH2, MAPATK 181 ! b MAPWN2 182 ! ------------------------------------------------------ 183 ! 184 ! 9. Switches : 185 ! 186 ! !/S Enable subroutine tracing. 187 ! !/T Enable test output. 188 ! 189 ! 10. Source code : 190 !/ ------------------------------------------------------------------- / 191 USE W3GDATMD, ONLY: NK, NTH, NSPEC, NX, NY, NSEA, MAPSTA, MAPSF,& 192 GTYPE 193 USE W3ADATMD, ONLY: NMX0, NMX1, NMX2, NMY0, NMY1, NMY2, NACT, & 194 NCENT, MAPX2, MAPY2, MAPAXY, MAPCXY, & 195 MAPTH2, MAPWN2 196 USE W3ODATMD, ONLY: NDST 197 !/ 198 IMPLICIT NONE 199 !/ 200 !/ ------------------------------------------------------------------- / 201 !/ Parameter list 202 !/ 203 !/ ------------------------------------------------------------------- / 204 !/ Local parameters 205 !/ 206 INTEGER :: IX, IY, IXY0, IX2, IY2, IX0, IY0, & 207 ISEA, IK, ITH, ISP, ISP0, ISP2, NCENTC 208 !/ 209 !/ ------------------------------------------------------------------- / 210 !/ 211 ! 212 IF (GTYPE .LT. 3) THEN 213 ! 1. Map MAPX2 ------------------------------------------------------ * 214 ! 1.a Range 1 to NMX0 215 ! 216 NMX0 = 0 217 DO IX=1, NX 218 IXY0 = (IX-1)*NY 219 IX2 = 1 + MOD(IX,NX) 220 DO IY=2, NY-1 221 IF ( MAPSTA(IY,IX).EQ.1 .AND. MAPSTA(IY,IX2).EQ.1 ) THEN 222 NMX0 = NMX0 + 1 223 MAPX2(NMX0) = IXY0 + IY 224 END IF 225 END DO 226 END DO 227 ! 228 ! 1.b Range NMX0+1 to NMX1 Page 5 Source Listing W3MAP3 2014-09-16 16:49 w3pro3md.f90 229 ! 230 NMX1 = NMX0 231 DO IX=1, NX 232 IXY0 = (IX-1)*NY 233 IX2 = 1 + MOD(IX,NX) 234 DO IY=2, NY-1 235 IF ( MAPSTA(IY,IX).EQ.1 .AND. MAPSTA(IY,IX2).NE.1 ) THEN 236 NMX1 = NMX1 + 1 237 MAPX2(NMX1) = IXY0 + IY 238 END IF 239 END DO 240 END DO 241 ! 242 ! 1.c Range NMX1+1 to NMX2 243 ! 244 NMX2 = NMX1 245 DO IX=1, NX 246 IXY0 = (IX-1)*NY 247 IX2 = 1 + MOD(IX,NX) 248 DO IY=2, NY-1 249 IF ( MAPSTA(IY,IX).NE.1 .AND. MAPSTA(IY,IX2).EQ.1 ) THEN 250 NMX2 = NMX2 + 1 251 MAPX2(NMX2) = IXY0 + IY 252 END IF 253 END DO 254 END DO 255 ! 256 ! 2. Map MAPY2 ------------------------------------------------------ * 257 ! 2.a Range 1 to NMY0 258 ! 259 NMY0 = 0 260 DO IX=1, NX 261 IXY0 = (IX-1)*NY 262 DO IY=1, NY-1 263 IY2 = IY + 1 264 IF ( MAPSTA(IY,IX).EQ.1 .AND. MAPSTA(IY2,IX).EQ.1 ) THEN 265 NMY0 = NMY0 + 1 266 MAPY2(NMY0) = IXY0 + IY 267 END IF 268 END DO 269 END DO 270 ! 271 ! 2.b Range NMY0+1 to NMY1 272 ! 273 NMY1 = NMY0 274 DO IX=1, NX 275 IXY0 = (IX-1)*NY 276 DO IY=1, NY-1 277 IY2 = IY + 1 278 IF ( MAPSTA(IY,IX).EQ.1 .AND. MAPSTA(IY2,IX).NE.1 ) THEN 279 NMY1 = NMY1 + 1 280 MAPY2(NMY1) = IXY0 + IY 281 END IF 282 END DO 283 END DO 284 ! 285 ! 2.c Range NMY1+1 to NMY2 Page 6 Source Listing W3MAP3 2014-09-16 16:49 w3pro3md.f90 286 ! 287 NMY2 = NMY1 288 DO IX=1, NX 289 IXY0 = (IX-1)*NY 290 DO IY=1, NY-1 291 IY2 = IY + 1 292 IF ( MAPSTA(IY,IX).NE.1 .AND. MAPSTA(IY2,IX).EQ.1 ) THEN 293 NMY2 = NMY2 + 1 294 MAPY2(NMY2) = IXY0 + IY 295 END IF 296 END DO 297 END DO 298 ! 299 ! 3. Map MAPAXY ----------------------------------------------------- * 300 ! 301 NACT = 0 302 DO IX=1, NX 303 IY0 = (IX-1)*NY 304 DO IY=2, NY-1 305 IF ( MAPSTA(IY,IX).EQ.1 ) THEN 306 NACT = NACT + 1 307 MAPAXY(NACT) = IY0 + IY 308 END IF 309 END DO 310 END DO 311 ! 312 ! 4. Map MAPCXY ----------------------------------------------------- * 313 ! 314 NCENT = 0 315 NCENTC = NSEA 316 MAPCXY = 0 317 ! 318 DO ISEA=1, NSEA 319 IX = MAPSF(ISEA,1) 320 IX0 = IX-1 321 IX2 = IX+1 322 IY = MAPSF(ISEA,2) 323 IY0 = IY-1 324 IY2 = IY+1 325 IF ( IX .EQ. NX ) IX2 = 1 326 IF ( IX .EQ. 1 ) IX0 = NX 327 IF ( MAPSTA(IY,IX).EQ.2 .OR. MAPSTA(IY,IX).LT.0 ) THEN 328 MAPCXY(NCENTC) = ISEA 329 NCENTC = NCENTC - 1 330 ELSE IF ( MAPSTA(IY0,IX0).GE.1 .AND. & 331 MAPSTA(IY0,IX ).GE.1 .AND. & 332 MAPSTA(IY0,IX2).GE.1 .AND. & 333 MAPSTA(IY ,IX0).GE.1 .AND. & 334 MAPSTA(IY ,IX2).GE.1 .AND. & 335 MAPSTA(IY2,IX0).GE.1 .AND. & 336 MAPSTA(IY2,IX ).GE.1 .AND. & 337 MAPSTA(IY2,IX2).GE.1 ) THEN 338 NCENT = NCENT + 1 339 MAPCXY(NCENT) = ISEA 340 ELSE 341 MAPCXY(NCENTC) = ISEA 342 NCENTC = NCENTC - 1 Page 7 Source Listing W3MAP3 2014-09-16 16:49 w3pro3md.f90 343 END IF 344 END DO 345 END IF 346 ! 347 ! 5. Maps for intra-spectral propagation ---------------------------- * 348 ! 349 IF ( MAPTH2(1) .NE. 0 ) RETURN 350 ! 351 ! 5.a MAPTH2 and MAPBTK 352 ! 353 DO IK=1, NK 354 DO ITH=1, NTH 355 ISP = ITH + (IK-1)*NTH 356 ISP2 = (IK+1) + (ITH-1)*(NK+2) 357 MAPTH2(ISP) = ISP2 358 END DO 359 END DO 360 ! 361 ! 5.b MAPWN2 362 ! 363 ISP0 = 0 364 DO IK=1, NK-1 365 DO ITH=1, NTH 366 ISP0 = ISP0 + 1 367 ISP2 = (IK+1) + (ITH-1)*(NK+2) 368 MAPWN2(ISP0) = ISP2 369 END DO 370 END DO 371 ! 372 DO ITH=1, NTH 373 ISP0 = ISP0 + 1 374 ISP2 = NK+1 + (ITH-1)*(NK+2) 375 MAPWN2(ISP0) = ISP2 376 END DO 377 ! 378 DO ITH=1, NTH 379 ISP0 = ISP0 + 1 380 ISP2 = 1 + (ITH-1)*(NK+2) 381 MAPWN2(ISP0) = ISP2 382 END DO 383 ! 384 RETURN 385 ! 386 ! Formats 387 ! 388 !/ 389 !/ End of W3MAP3 ----------------------------------------------------- / 390 !/ 391 END SUBROUTINE W3MAP3 Page 8 Source Listing W3MAP3 2014-09-16 16:49 Entry Points w3pro3md.f90 ENTRY POINTS Name w3pro3md_mp_w3map3_ SYMBOL CROSS REFERENCE Name Object Declared Type Bytes Dimen Elements Attributes References GTYPE Local 192 I(4) 4 scalar PTR 192,212 IK Local 207 I(4) 4 scalar 353,355,356,364,367 ISEA Local 207 I(4) 4 scalar 318,319,322,328,339,341 ISP Local 207 I(4) 4 scalar 355,357 ISP0 Local 207 I(4) 4 scalar 363,366,368,373,375,379,381 ISP2 Local 207 I(4) 4 scalar 356,357,367,368,374,375,380,381 ITH Local 207 I(4) 4 scalar 354,355,356,365,367,372,374,378,38 0 IX Local 206 I(4) 4 scalar 217,218,219,221,231,232,233,235,24 5,246,247,249,260,261,264,274,275, 278,288,289,292,302,303,305,319,32 0,321,325,326,327,331,336 IX0 Local 206 I(4) 4 scalar 320,326,330,333,335 IX2 Local 206 I(4) 4 scalar 219,221,233,235,247,249,321,325,33 2,334,337 IXY0 Local 206 I(4) 4 scalar 218,223,232,237,246,251,261,266,27 5,280,289,294 IY Local 206 I(4) 4 scalar 220,221,223,234,235,237,248,249,25 1,262,263,264,266,276,277,278,280, 290,291,292,294,304,305,307,322,32 3,324,327,333,334 IY0 Local 206 I(4) 4 scalar 303,307,323,330,331,332 IY2 Local 206 I(4) 4 scalar 263,264,277,278,291,292,324,335,33 6,337 MAPAXY Local 194 I(4) 4 1 1 PTR 194,307 MAPCXY Local 194 I(4) 4 1 1 PTR 194,316,328,339,341 MAPSF Local 191 I(4) 4 2 1 PTR 191,319,322 MAPSTA Local 191 I(4) 4 2 1 PTR 191,221,235,249,264,278,292,305,32 7,330,331,332,333,334,335,336,337 MAPTH2 Local 195 I(4) 4 1 1 PTR 195,349,357 MAPWN2 Local 195 I(4) 4 1 1 PTR 195,368,375,381 MAPX2 Local 194 I(4) 4 1 1 PTR 194,223,237,251 MAPY2 Local 194 I(4) 4 1 1 PTR 194,266,280,294 MOD Func 219 scalar 219,233,247 NACT Local 193 I(4) 4 scalar PTR 193,301,306,307 NCENT Local 194 I(4) 4 scalar PTR 194,314,338,339 NCENTC Local 207 I(4) 4 scalar 315,328,329,341,342 NDST Local 196 I(4) 4 scalar PTR 196 NK Local 191 I(4) 4 scalar PTR 191,353,356,364,367,374,380 NMX0 Local 193 I(4) 4 scalar PTR 193,216,222,223,230 NMX1 Local 193 I(4) 4 scalar PTR 193,230,236,237,244 NMX2 Local 193 I(4) 4 scalar PTR 193,244,250,251 NMY0 Local 193 I(4) 4 scalar PTR 193,259,265,266,273 NMY1 Local 193 I(4) 4 scalar PTR 193,273,279,280,287 Page 9 Source Listing W3MAP3 2014-09-16 16:49 Symbol Table w3pro3md.f90 Name Object Declared Type Bytes Dimen Elements Attributes References NMY2 Local 193 I(4) 4 scalar PTR 193,287,293,294 NSEA Local 191 I(4) 4 scalar PTR 191,315,318 NSPEC Local 191 I(4) 4 scalar PTR 191 NTH Local 191 I(4) 4 scalar PTR 191,354,355,365,372,378 NX Local 191 I(4) 4 scalar PTR 191,217,219,231,233,245,247,260,27 4,288,302,325,326 NY Local 191 I(4) 4 scalar PTR 191,218,220,232,234,246,248,261,26 2,275,276,289,290,303,304 W3ADATMD Module 193 193 W3GDATMD Module 191 191 W3MAP3 Subr 112 W3ODATMD Module 196 196 Page 10 Source Listing W3MAP3 2014-09-16 16:49 w3pro3md.f90 392 !/ ------------------------------------------------------------------- / 393 SUBROUTINE W3MAPT 394 !/ 395 !/ +-----------------------------------+ 396 !/ | WAVEWATCH III NOAA/NCEP | 397 !/ | H. L. Tolman | 398 !/ | FORTRAN 90 | 399 !/ | Last update : 17-Dec-2004 | 400 !/ +-----------------------------------+ 401 !/ 402 !/ 10-Dec-2001 : Origination. ( version 2.14 ) 403 !/ 17-Dec-2004 : Multiple grid version. ( version 3.06 ) 404 !/ 405 ! 1. Purpose : 406 ! 407 ! Generate 'map' arrays for the ULTIMATE QUICKEST scheme to combine 408 ! GSE alleviation with obstructions. 409 ! 410 ! 2. Method : 411 ! 412 ! 3. Parameters : 413 ! 414 ! Parameter list 415 ! ---------------------------------------------------------------- 416 ! ---------------------------------------------------------------- 417 ! 418 ! 4. Subroutines used : 419 ! 420 ! See module documentation. 421 ! 422 ! 5. Called by : 423 ! 424 ! Name Type Module Description 425 ! ---------------------------------------------------------------- 426 ! W3WAVE Subr. W3WAVEMD Wave model routine. 427 ! ---------------------------------------------------------------- 428 ! 429 ! 6. Error messages : 430 ! 431 ! 7. Remarks : 432 ! 433 ! 8. Structure : 434 ! 435 ! See source code. 436 ! 437 ! 9. Switches : 438 ! 439 ! !/S Enable subroutine tracing. 440 ! 441 ! 10. Source code : 442 !/ ------------------------------------------------------------------- / 443 USE W3GDATMD, ONLY: NX, NY, NSEA, MAPSF 444 USE W3ADATMD, ONLY: ATRNX, ATRNY, MAPTRN 445 !/ 446 IMPLICIT NONE 447 !/ 448 !/ ------------------------------------------------------------------- / Page 11 Source Listing W3MAPT 2014-09-16 16:49 w3pro3md.f90 449 !/ Parameter list 450 !/ 451 !/ ------------------------------------------------------------------- / 452 !/ Local parameters 453 !/ 454 INTEGER :: ISEA, IXY 455 !/ 456 !/ ------------------------------------------------------------------- / 457 !/ 458 ! 459 ! 1. Map MAPTRN ----------------------------------------------------- * 460 ! 461 DO ISEA=1, NSEA 462 IXY = MAPSF(ISEA,3) 463 464 !notes: Oct 22 2012: I changed this because it *looks* like a bug. 465 ! I have not confirmed that it is a bug. 466 ! Old code is given (2 lines). Only the first line is 467 ! changed. 468 469 !old MAPTRN(IXY) = MIN( ATRNX(IXY,1) ,ATRNY(IXY,-1) , & 470 !old ATRNY(IXY,1), ATRNY(IXY,-1) ) .LT. TRNMIN 471 472 MAPTRN(IXY) = MIN( ATRNX(IXY,1) ,ATRNX(IXY,-1) , & 473 ATRNY(IXY,1), ATRNY(IXY,-1) ) .LT. TRNMIN 474 END DO 475 ! 476 RETURN 477 ! 478 ! Formats 479 !/ 480 !/ End of W3MAPT ----------------------------------------------------- / 481 !/ 482 END SUBROUTINE W3MAPT Page 12 Source Listing W3MAPT 2014-09-16 16:49 Entry Points w3pro3md.f90 ENTRY POINTS Name w3pro3md_mp_w3mapt_ SYMBOL CROSS REFERENCE Name Object Declared Type Bytes Dimen Elements Attributes References ATRNX Local 444 R(4) 4 2 1 PTR 444,472 ATRNY Local 444 R(4) 4 2 1 PTR 444,473 ISEA Local 454 I(4) 4 scalar 461,462 IXY Local 454 I(4) 4 scalar 462,472,473 MAPSF Local 443 I(4) 4 2 1 PTR 443,462 MAPTRN Local 444 L(4) 4 1 1 PTR 444,472 MIN Func 472 scalar 472 NSEA Local 443 I(4) 4 scalar PTR 443,461 NX Local 443 I(4) 4 scalar PTR 443 NY Local 443 I(4) 4 scalar PTR 443 TRNMIN Param 473 R(4) 4 scalar PRIV 108,473 W3ADATMD Module 444 444 W3GDATMD Module 443 443 W3MAPT Subr 393 Page 13 Source Listing W3MAPT 2014-09-16 16:49 w3pro3md.f90 483 !/ ------------------------------------------------------------------- / 484 SUBROUTINE W3XYP3 ( ISP, DTG, MAPSTA, MAPFS, VQ, VGX, VGY ) 485 !/ 486 !/ +-----------------------------------+ 487 !/ | WAVEWATCH III NOAA/NCEP | 488 !/ | H. L. Tolman | 489 !/ | FORTRAN 90 | 490 !/ | Last update : 12-Sep-2013 | 491 !/ +-----------------------------------+ 492 !/ 493 !/ 27-Feb-2000 : Origination. ( version 2.08 ) 494 !/ 17-Sep-2000 : Clean-up. ( version 2.13 ) 495 !/ 10-Dec-2001 : Sub-grid obstructions. ( version 2.14 ) 496 !/ 16-Oct-2002 : Change INTENT for ATRNRX/Y. ( version 3.00 ) 497 !/ 26-Dec-2002 : Moving grid version. ( version 3.02 ) 498 !/ 01-Aug-2003 : Moving grid GSE correction. ( version 3.03 ) 499 !/ 17-Dec-2004 : Multiple grid version. ( version 3.06 ) 500 !/ 07-Sep-2005 : Upgrade XY boundary conditions. ( version 3.08 ) 501 !/ 09-Nov-2005 : Removing soft boundary option. ( version 3.08 ) 502 !/ 05-Mar-2008 : Added NEC sxf90 compiler directives. 503 !/ (Chris Bunney, UK Met Office) ( version 3.13 ) 504 !/ 30-Oct-2009 : Implement curvilinear grid type. ( version 3.14 ) 505 !/ (W. E. Rogers & T. J. Campbell, NRL) 506 !/ 17-Aug-2010 : Add test output. ( version 3.14.5 ) 507 !/ 30-Oct-2010 : Implement unstructured grid ( version 3.14 ) 508 !/ 06-Dec-2010 : Change from GLOBAL (logical) to ICLOSE (integer) to 509 !/ specify index closure for a grid. ( version 3.14 ) 510 !/ (T. J. Campbell, NRL) 511 !/ 01-Jul-2013 : Adding UQ and UNO switches to chose between third 512 !/ and second order schemes. ( version 4.12 ) 513 !/ 12-Sep-2013 : Add documentation for global clos. ( version 4.12 ) 514 !/ 515 ! 1. Purpose : 516 ! 517 ! Propagation in phyiscal space for a given spectral component. 518 ! 519 ! 2. Method : 520 ! 521 ! Third-order ULTIMATE QUICKEST scheme with averaging. 522 ! Curvilinear grid implementation: Fluxes are computed in index space 523 ! and then transformed back into physical space. The diffusion term 524 ! is handled in physical space. The averaging scheme is adapted for 525 ! curvilinear grids by applying the appropriate local rotations and 526 ! adjustments to interpolation weights which control the strength of 527 ! the averaging in axial directions. 528 ! 529 ! 3. Parameters : 530 ! 531 ! Parameter list 532 ! ---------------------------------------------------------------- 533 ! ISP Int. I Number of spectral bin (IK-1)*NTH+ITH 534 ! DTG Real I Total time step. 535 ! MAPSTA I.A. I Grid point status map. 536 ! MAPFS I.A. I Storage map. 537 ! VQ R.A. I/O Field to propagate. 538 ! VGX/Y Real I Speed of grid. 539 ! ---------------------------------------------------------------- Page 14 Source Listing W3XYP3 2014-09-16 16:49 w3pro3md.f90 540 ! 541 ! Local variables. 542 ! ---------------------------------------------------------------- 543 ! NTLOC Int Number of local time steps. 544 ! DTLOC Real Local propagation time step. 545 ! VCFL0X R.A. Local courant numbers for absolute group vel. 546 ! using local X-grid step. 547 ! VCFL0Y R.A. Id. in Y. 548 ! ---------------------------------------------------------------- 549 ! 550 ! 4. Subroutines used : 551 ! 552 ! W3QCK3 Actual propagation algorithm 553 ! 554 ! STRACE Service routine. 555 ! 556 ! 5. Called by : 557 ! 558 ! W3WAVE Wave model routine. 559 ! 560 ! 6. Error messages : 561 ! 562 ! None. 563 ! 564 ! 7. Remarks : 565 ! 566 ! - Note that the ULTIMATE limiter does not guarantee non-zero 567 ! energies. 568 ! - The present scheme shows a strong distorsion when propaga- 569 ! ting a field under an angle with the grid in a truly 2-D 570 ! fashion. Propagation is therefore split along the two 571 ! axes. 572 ! - Two boundary treatments are available. The first uses real 573 ! boundaries in each space. In this case waves will not 574 ! penetrate in narrow straights under an angle with the grid. 575 ! This behavior is improved by using a 'soft' option, in 576 ! which the 'X' or 'Y' sweep allows for energy to go onto 577 ! the land. This improves the above behavior, but implies 578 ! that X-Y connenctions are required in barriers for them 579 ! to become inpenetrable. 580 ! - Note that unlike in W3XYP2, isotropic diffusion is never 581 ! used for growth. 582 ! - Curvilinear grid implementation. Variables FACX, FACY, CCOS, CSIN, 583 ! CCURX, CCURY are not needed and have been removed. FACX is accounted 584 ! for as approriate in this subroutine. FACX is also accounted for in 585 ! the case of .NOT.FLCX. Since FACX is removed, there is now a check for 586 ! .NOT.FLCX in this subroutine. In CFL calcs dx and dy are omitted, 587 ! since dx=dy=1 in index space. Curvilinear grid derivatives 588 ! (DPDY, DQDX, etc.) and metric (GSQRT) are brought in via W3GDATMD. 589 ! - The strength of the averaging scheme is dependent on grid resolution. 590 ! Since grid resolution is non-uniform for curvilinear grids, this means 591 ! that the strength of the averaging is also non-uniform. This may not be 592 ! a desirable effect. A potential future upgrade would be to add an 593 ! additional term/factor that balances the effect of the spatial 594 ! variation of grid resolution. 595 ! 596 ! 8. Structure : Page 15 Source Listing W3XYP3 2014-09-16 16:49 w3pro3md.f90 597 ! 598 ! --------------------------------------------- 599 ! 1. Preparations 600 ! a Set constants 601 ! b Initialize arrays 602 ! 2. Prepare arrays 603 ! a Velocities and 'Q' 604 ! 3. Loop over sub-steps 605 ! ---------------------------------------- 606 ! a Average 607 ! b Propagate 608 ! c Update boundaries. 609 ! ---------------------------------------- 610 ! 4. Store Q field in spectra 611 ! --------------------------------------------- 612 ! 613 ! 9. Switches : 614 ! 615 ! !/NEC Enable NEC SXF90 compiler directives. 616 ! 617 ! !/S Enable subroutine tracing. 618 ! 619 ! !/MGP Moving grid corrections. 620 ! !/MGG Moving grid corrections. 621 ! 622 ! !/T Enable general test output. 623 ! !/T0 Dump of precalcaulted interpolation data. 624 ! !/T1 Dump of input field and fluxes. 625 ! !/T2 Dump of output field (before boundary update). 626 ! !/T3 Dump of output field (final). 627 ! 628 ! 10. Source code : 629 ! 630 !/ ------------------------------------------------------------------- / 631 USE CONSTANTS 632 ! 633 USE W3TIMEMD, ONLY: DSEC21 634 ! 635 USE W3GDATMD, ONLY: NX, NY, NSEA, MAPSF, DTCFL, CLATS, & 636 ICLOSE, FLCX, FLCY, NK, NTH, DTH, XFR, & 637 ICLOSE_NONE, ICLOSE_SMPL, ICLOSE_TRPL, & 638 ECOS, ESIN, SIG, WDCG, WDTH, PFMOVE, & 639 FLAGLL, DPDX, DPDY, DQDX, DQDY, GSQRT 640 USE W3WDATMD, ONLY: TIME 641 USE W3ADATMD, ONLY: NMX0, NMX1, NMX2, NMY0, NMY1, NMY2, NACT, & 642 NCENT, MAPX2, MAPY2, MAPAXY, MAPCXY, & 643 MAPTRN, CG, CX, CY, ATRNX, ATRNY, ITIME 644 USE W3IDATMD, ONLY: FLCUR 645 USE W3ODATMD, ONLY: NDSE, NDST, FLBPI, NBI, TBPI0, TBPIN, & 646 ISBPI, BBPI0, BBPIN 647 USE W3UQCKMD 648 !/ 649 IMPLICIT NONE 650 !/ 651 !/ ------------------------------------------------------------------- / 652 !/ Parameter list 653 !/ Page 16 Source Listing W3XYP3 2014-09-16 16:49 w3pro3md.f90 654 INTEGER, INTENT(IN) :: ISP, MAPSTA(NY*NX), MAPFS(NY*NX) 655 REAL, INTENT(IN) :: DTG, VGX, VGY 656 REAL, INTENT(INOUT) :: VQ(1-NY:NY*(NX+2)) 657 !/ 658 !/ ------------------------------------------------------------------- / 659 !/ Local parameters 660 !/ 661 INTEGER :: ITH, IK, NTLOC, ITLOC, ISEA, IXY, IP 662 INTEGER :: IX, IY, IXC, IYC, IBI 663 INTEGER :: IIXY1(NSEA), IIXY2(NSEA), & 664 IIXY3(NSEA), IIXY4(NSEA) 665 REAL :: CG0, CGA, CGN, CGX, CGY, CXC, CYC, & 666 CXMIN, CXMAX, CYMIN, CYMAX 667 REAL :: CGC, FGSE = 1. 668 REAL :: FTH, FTHX, FTHY, FCG, FCGX, FCGY 669 REAL :: DTLOC, DTRAD, & 670 DXCGN, DYCGN, DXCGS, DYCGS, DXCGC, & 671 DYCGC 672 REAL :: RDI1(NSEA), RDI2(NSEA), & 673 RDI3(NSEA), RDI4(NSEA) 674 REAL :: TMPX, TMPY, RD1, RD2, RD3, RD4 675 LOGICAL :: YFIRST 676 LOGICAL :: GLOBAL 677 REAL :: CP, CQ 678 !/ 679 !/ Automatic work arrays 680 !/ 681 INTEGER :: MAPSTX(1-2*NY:NY*(NX+2)) 682 REAL :: VLCFLX((NX+1)*NY), VLCFLY((NX+1)*NY),& 683 AQ(1-NY:NY*(NX+2)) 684 REAL :: CXTOT((NX+1)*NY), CYTOT(NX*NY) 685 !/ 686 !/ ------------------------------------------------------------------- / 687 !/ 688 ! 689 ! 1. Preparations --------------------------------------------------- * 690 ! 1.a Set constants 691 ! 692 GLOBAL = ICLOSE.NE.ICLOSE_NONE 693 ITH = 1 + MOD(ISP-1,NTH) 694 IK = 1 + (ISP-1)/NTH 695 ! 696 CG0 = 0.575 * GRAV / SIG(1) 697 CGA = 0.575 * GRAV / SIG(IK) 698 CGX = CGA * ECOS(ITH) 699 CGY = CGA * ESIN(ITH) 700 CGC = SQRT ( CGX**2 + CGY**2 ) 701 ! 702 IF ( FLCUR ) THEN 703 CXMIN = MINVAL ( CX(1:NSEA) ) 704 CXMAX = MAXVAL ( CX(1:NSEA) ) 705 CYMIN = MINVAL ( CY(1:NSEA) ) 706 CYMAX = MAXVAL ( CY(1:NSEA) ) 707 IF ( ABS(CGX+CXMIN) .GT. ABS(CGX+CXMAX) ) THEN 708 CGX = CGX + CXMIN 709 ELSE 710 CGX = CGX + CXMAX Page 17 Source Listing W3XYP3 2014-09-16 16:49 w3pro3md.f90 711 END IF 712 IF ( ABS(CGY+CYMIN) .GT. ABS(CGY+CYMAX) ) THEN 713 CGY = CGY + CYMIN 714 ELSE 715 CGY = CGY + CYMAX 716 END IF 717 CXC = MAX ( ABS(CXMIN) , ABS(CXMAX) ) 718 CYC = MAX ( ABS(CYMIN) , ABS(CYMAX) ) 719 ELSE 720 CXC = 0. 721 CYC = 0. 722 END IF 723 ! 724 CGN = MAX ( ABS(CGX) , ABS(CGY) , CXC, CYC, 0.001*CG0 ) 725 ! 726 NTLOC = 1 + INT(DTG/(DTCFL*CG0/CGN)) 727 DTLOC = DTG / REAL(NTLOC) 728 DTRAD = DTLOC 729 IF ( FLAGLL ) DTRAD=DTRAD/(DERA*RADIUS) 730 ! 731 YFIRST = MOD(ITIME,2) .EQ. 0 732 ! 733 ! 1.b Initialize arrays 734 ! 735 VLCFLX = 0. 736 VLCFLY = 0. 737 CXTOT = 0. 738 CYTOT = 0. 739 ! 740 MAPSTX(1:NX*NY) = MAPSTA(1:NX*NY) 741 ! 742 IF ( GLOBAL ) THEN 743 MAPSTX(1-2*NY:0) = MAPSTA((NX-2)*NY+1:NX*NY) 744 MAPSTX(NX*NY+1:NX*NY+2*NY) = MAPSTA(1:2*NY) 745 ELSE 746 MAPSTX(1-2*NY:0) = 0 747 MAPSTX(NX*NY+1:NX*NY+2*NY) = 0 748 END IF 749 ! 750 ! 1.c Pre-calculate interpolation info 751 ! 752 FTH = FGSE * WDTH * DTH * DTLOC 753 FCG = FGSE * WDCG * 0.5 * (XFR-1./XFR) * DTLOC 754 IF ( FLAGLL ) THEN 755 FTH = FTH / RADIUS / DERA 756 FCG = FCG / RADIUS / DERA 757 END IF 758 FCG = FCG / REAL(NTLOC) !TJC: required to match original (is this correct?) 759 FTHX = - FTH * ESIN(ITH) 760 FTHY = FTH * ECOS(ITH) 761 FCGX = FCG * ECOS(ITH) 762 FCGY = FCG * ESIN(ITH) 763 ! 764 !$OMP PARALLEL DO PRIVATE (ISEA, IX, IY, TMPX, TMPY, & 765 !$OMP& DXCGN, DYCGN, DXCGS, DYCGS, DXCGC, DYCGC, & 766 !$OMP& IXC, IYC) 767 DO ISEA=1, NSEA Page 18 Source Listing W3XYP3 2014-09-16 16:49 w3pro3md.f90 768 ! 769 IX = MAPSF(ISEA,1) 770 IY = MAPSF(ISEA,2) 771 ! 772 ! 1.c.1 Normal and parallel width ... 773 ! 774 TMPX = FTHX / CLATS(ISEA) 775 TMPY = FTHY 776 DXCGN = DPDX(IY,IX)*TMPX + DPDY(IY,IX)*TMPY 777 DYCGN = DQDX(IY,IX)*TMPX + DQDY(IY,IX)*TMPY 778 TMPX = FCGX / CLATS(ISEA) 779 TMPY = FCGY 780 DXCGS = DPDX(IY,IX)*TMPX + DPDY(IY,IX)*TMPY 781 DYCGS = DQDX(IY,IX)*TMPX + DQDY(IY,IX)*TMPY 782 ! 783 ! 1.c.2 "Sum" corner (and mirror image) ... 784 ! 785 DXCGC = DXCGN + DXCGS 786 DYCGC = DYCGN + DYCGS 787 ! 788 IXC = NY 789 IF ( DXCGC .LT. 0. ) IXC = - IXC 790 IYC = 1 791 IF ( DYCGC .LT. 0. ) IYC = - IYC 792 ! 793 IIXY1(ISEA) = IXC + IYC 794 IF ( ABS(DXCGC) .GT. ABS(DYCGC) ) THEN 795 IIXY2(ISEA) = IXC 796 RDI1 (ISEA) = ABS(DYCGC/DXCGC) 797 RDI2 (ISEA) = ABS(DXCGC) 798 ELSE 799 IIXY2(ISEA) = IYC 800 IF ( ABS(DYCGC) .GT. 1.E-5 ) THEN 801 RDI1(ISEA) = ABS(DXCGC/DYCGC) 802 ELSE 803 RDI1(ISEA) = 1. 804 END IF 805 RDI2(ISEA) = ABS(DYCGC) 806 END IF 807 ! 808 ! 1.c.2 "Difference" corner (and mirror image) ... 809 ! 810 DXCGC = DXCGN - DXCGS 811 DYCGC = DYCGN - DYCGS 812 ! 813 IXC = NY 814 IF ( DXCGC .LT. 0. ) IXC = - IXC 815 IYC = 1 816 IF ( DYCGC .LT. 0. ) IYC = - IYC 817 ! 818 IIXY3(ISEA) = IXC + IYC 819 IF ( ABS(DXCGC) .GT. ABS(DYCGC) ) THEN 820 IIXY4(ISEA) = IXC 821 RDI3 (ISEA) = ABS(DYCGC/DXCGC) 822 RDI4 (ISEA) = ABS(DXCGC) 823 ELSE 824 IIXY4(ISEA) = IYC Page 19 Source Listing W3XYP3 2014-09-16 16:49 w3pro3md.f90 825 IF ( ABS(DYCGC) .GT. 1.E-5 ) THEN 826 RDI3(ISEA) = ABS(DXCGC/DYCGC) 827 ELSE 828 RDI3(ISEA) = 1. 829 END IF 830 RDI4(ISEA) = ABS(DYCGC) 831 END IF 832 ! 833 END DO 834 ! 835 ! 2. Calculate velocities and diffusion coefficients ---------------- * 836 ! 2.a Velocities 837 ! 838 ! Q = ( A / CG * CLATS ) 839 ! LCFLX = ( COS*CG / CLATS ) * DT / DX 840 ! LCFLY = ( SIN*CG ) * DT / DY 841 ! 842 !$OMP PARALLEL DO PRIVATE (ISEA, IXY) 843 DO ISEA=1, NSEA 844 IXY = MAPSF(ISEA,3) 845 VQ (IXY) = VQ(IXY) / CG(IK,ISEA) * CLATS(ISEA) 846 CXTOT(IXY) = ECOS(ITH) * CG(IK,ISEA) / CLATS(ISEA) 847 CYTOT(IXY) = ESIN(ITH) * CG(IK,ISEA) 848 END DO 849 850 851 IF ( FLCUR ) THEN 852 DO ISEA=1, NSEA 853 IXY = MAPSF(ISEA,3) 854 CXTOT(IXY) = CXTOT(IXY) + CX(ISEA)/CLATS(ISEA) 855 CYTOT(IXY) = CYTOT(IXY) + CY(ISEA) 856 END DO 857 END IF 858 !$OMP PARALLEL DO PRIVATE (IX, IY, IXY, CP, CQ) 859 DO ISEA=1, NSEA 860 IX = MAPSF(ISEA,1) 861 IY = MAPSF(ISEA,2) 862 IXY = MAPSF(ISEA,3) 863 CP = CXTOT(IXY)*DPDX(IY,IX) + CYTOT(IXY)*DPDY(IY,IX) 864 CQ = CXTOT(IXY)*DQDX(IY,IX) + CYTOT(IXY)*DQDY(IY,IX) 865 VLCFLX(IXY) = CP*DTRAD 866 VLCFLY(IXY) = CQ*DTRAD 867 END DO 868 869 ! 870 ! 3. Loop over sub-steps -------------------------------------------- * 871 ! 872 DO ITLOC=1, NTLOC 873 ! 874 ! 3.a Average 875 ! 876 AQ = VQ 877 VQ = 0. 878 ! 879 ! 3.a.1 Central points 880 ! 881 DO IP=1, NCENT Page 20 Source Listing W3XYP3 2014-09-16 16:49 w3pro3md.f90 882 ISEA = MAPCXY(IP) 883 IXY = MAPSF(ISEA,3) 884 IF ( MAPTRN(IXY) ) THEN 885 VQ(IXY) = AQ(IXY) 886 ELSE 887 RD1 = RDI1(ISEA) 888 RD2 = MIN ( 1. , RDI2(ISEA) * CG(IK,ISEA) ) 889 RD3 = RDI3(ISEA) 890 RD4 = MIN ( 1. , RDI4(ISEA) * CG(IK,ISEA) ) 891 VQ(IXY ) = VQ(IXY ) & 892 + AQ(IXY) * (3.-RD2-RD4)/3. 893 VQ(IXY+IIXY1(ISEA)) = VQ(IXY+IIXY1(ISEA)) & 894 + AQ(IXY) * RD2*RD1/6. 895 VQ(IXY+IIXY2(ISEA)) = VQ(IXY+IIXY2(ISEA)) & 896 + AQ(IXY) * (1.-RD1)*RD2/6. 897 VQ(IXY+IIXY3(ISEA)) = VQ(IXY+IIXY3(ISEA)) & 898 + AQ(IXY) * RD4*RD3/6. 899 VQ(IXY+IIXY4(ISEA)) = VQ(IXY+IIXY4(ISEA)) & 900 + AQ(IXY) * (1.-RD3)*RD4/6. 901 VQ(IXY-IIXY1(ISEA)) = VQ(IXY-IIXY1(ISEA)) & 902 + AQ(IXY) * RD2*RD1/6. 903 VQ(IXY-IIXY2(ISEA)) = VQ(IXY-IIXY2(ISEA)) & 904 + AQ(IXY) * (1.-RD1)*RD2/6. 905 VQ(IXY-IIXY3(ISEA)) = VQ(IXY-IIXY3(ISEA)) & 906 + AQ(IXY) * RD4*RD3/6. 907 VQ(IXY-IIXY4(ISEA)) = VQ(IXY-IIXY4(ISEA)) & 908 + AQ(IXY) * (1.-RD3)*RD4/6. 909 END IF 910 END DO 911 ! 912 ! 3.a.2 Near-coast points 913 ! 914 DO IP=NCENT+1, NSEA 915 ISEA = MAPCXY(IP) 916 IX = MAPSF(ISEA,1) 917 IXY = MAPSF(ISEA,3) 918 IF ( MAPSTA(IXY) .LE. 0 ) CYCLE 919 IF ( MAPTRN(IXY) ) THEN 920 VQ(IXY) = AQ(IXY) 921 ELSE 922 RD1 = RDI1(ISEA) 923 RD3 = RDI3(ISEA) 924 RD2 = MIN ( 1. , RDI2(ISEA) * CG(IK,ISEA) ) 925 RD4 = MIN ( 1. , RDI4(ISEA) * CG(IK,ISEA) ) 926 VQ(IXY ) = VQ(IXY ) & 927 + AQ(IXY) * (3.-RD2-RD4)/3. 928 ! 929 IXC = SIGN(NY,IIXY1(ISEA)) 930 IYC = IIXY1(ISEA) - IXC 931 IF ( MAPSTX(IXY+IIXY1(ISEA)) .GE. 1 .AND. & 932 .NOT. ( MAPSTX(IXY+IXC).LE.0 .AND. & 933 MAPSTX(IXY+IYC).LE.0 ) ) THEN 934 VQ(IXY+IIXY1(ISEA)) = VQ(IXY+IIXY1(ISEA)) & 935 + AQ(IXY) * RD2*RD1/6. 936 ELSE 937 VQ(IXY ) = VQ(IXY ) & 938 + AQ(IXY) * RD2*RD1/6. Page 21 Source Listing W3XYP3 2014-09-16 16:49 w3pro3md.f90 939 END IF 940 IF ( MAPSTX(IXY-IIXY1(ISEA)) .GE. 1 .AND. & 941 .NOT. ( MAPSTX(IXY-IXC).LE.0 .AND. & 942 MAPSTX(IXY-IYC).LE.0 ) ) THEN 943 VQ(IXY-IIXY1(ISEA)) = VQ(IXY-IIXY1(ISEA)) & 944 + AQ(IXY) * RD2*RD1/6. 945 ELSE 946 VQ(IXY ) = VQ(IXY ) & 947 + AQ(IXY) * RD2*RD1/6. 948 END IF 949 950 IF ( MAPSTX(IXY+IIXY2(ISEA)) .GE. 1 ) THEN 951 VQ(IXY+IIXY2(ISEA)) = VQ(IXY+IIXY2(ISEA)) & 952 + AQ(IXY) * (1.-RD1)*RD2/6. 953 ELSE 954 VQ(IXY ) = VQ(IXY ) & 955 + AQ(IXY) * (1.-RD1)*RD2/6. 956 END IF 957 IF ( MAPSTX(IXY-IIXY2(ISEA)) .GE. 1 ) THEN 958 VQ(IXY-IIXY2(ISEA)) = VQ(IXY-IIXY2(ISEA)) & 959 + AQ(IXY) * (1.-RD1)*RD2/6. 960 ELSE 961 VQ(IXY ) = VQ(IXY ) & 962 + AQ(IXY) * (1.-RD1)*RD2/6. 963 END IF 964 ! 965 IXC = SIGN(NY,IIXY3(ISEA)) 966 IYC = IIXY3(ISEA) - IXC 967 IF ( MAPSTX(IXY+IIXY3(ISEA)) .GE. 1 .AND. & 968 .NOT. ( MAPSTX(IXY+IXC).LE.0 .AND. & 969 MAPSTX(IXY+IYC).LE.0 ) ) THEN 970 VQ(IXY+IIXY3(ISEA)) = VQ(IXY+IIXY3(ISEA)) & 971 + AQ(IXY) * RD4*RD3/6. 972 ELSE 973 VQ(IXY ) = VQ(IXY ) & 974 + AQ(IXY) * RD4*RD3/6. 975 END IF 976 IF ( MAPSTX(IXY-IIXY3(ISEA)) .GE. 1 .AND. & 977 .NOT. ( MAPSTX(IXY-IXC).LE.0 .AND. & 978 MAPSTX(IXY-IYC).LE.0 ) ) THEN 979 VQ(IXY-IIXY3(ISEA)) = VQ(IXY-IIXY3(ISEA)) & 980 + AQ(IXY) * RD4*RD3/6. 981 ELSE 982 VQ(IXY ) = VQ(IXY ) & 983 + AQ(IXY) * RD4*RD3/6. 984 END IF 985 ! 986 IF ( MAPSTX(IXY+IIXY4(ISEA)) .GE. 1 ) THEN 987 VQ(IXY+IIXY4(ISEA)) = VQ(IXY+IIXY4(ISEA)) & 988 + AQ(IXY) * (1.-RD3)*RD4/6. 989 ELSE 990 VQ(IXY ) = VQ(IXY ) & 991 + AQ(IXY) * (1.-RD3)*RD4/6. 992 END IF 993 IF ( MAPSTX(IXY-IIXY4(ISEA)) .GE. 1 ) THEN 994 VQ(IXY-IIXY4(ISEA)) = VQ(IXY-IIXY4(ISEA)) & 995 + AQ(IXY) * (1.-RD3)*RD4/6. Page 22 Source Listing W3XYP3 2014-09-16 16:49 w3pro3md.f90 996 ELSE 997 VQ(IXY ) = VQ(IXY ) & 998 + AQ(IXY) * (1.-RD3)*RD4/6. 999 END IF 1000 ! 1001 END IF 1002 END DO 1003 ! 1004 ! 3.a.3 Restore boundary data 1005 ! 1006 DO IXY=1, NX*NY 1007 IF ( MAPSTA(IXY).EQ.2 ) VQ(IXY) = AQ(IXY) 1008 END DO 1009 ! 1010 ! 3.a.4 Global closure (averaging only, propagation is closed in W3QCK3). 1011 ! 1012 IF ( GLOBAL ) THEN 1013 DO IY=1, NY 1014 VQ(IY ) = VQ(IY ) + VQ(NX*NY+IY) 1015 VQ((NX-1)*NY+IY) = VQ((NX-1)*NY+IY) + VQ(IY-NY) 1016 END DO 1017 END IF 1018 ! 1019 ! 3.b Propagate fields 1020 ! 1021 1022 ! Transform VQ to straightened space 1023 !$OMP PARALLEL DO PRIVATE (ISEA, IX, IY, IXY) 1024 DO ISEA=1, NSEA 1025 IX = MAPSF(ISEA,1) 1026 IY = MAPSF(ISEA,2) 1027 IXY = MAPSF(ISEA,3) 1028 VQ(IXY)= VQ(IXY) * GSQRT(IY,IX) 1029 END DO 1030 1031 IF ( YFIRST ) THEN 1032 ! 1033 IF ( FLCY ) CALL W3QCK3 & 1034 (NX, NY, NX, NY, VLCFLY, ATRNY, VQ, & 1035 .FALSE., 1, MAPAXY, NACT, MAPY2, NMY0, & 1036 NMY1, NMY2, NDSE, NDST ) 1037 IF ( FLCX ) CALL W3QCK3 & 1038 (NX, NY, NX, NY, VLCFLX, ATRNX, VQ, & 1039 GLOBAL, NY, MAPAXY, NACT, MAPX2, NMX0, & 1040 NMX1, NMX2, NDSE, NDST ) 1041 ! 1042 ELSE 1043 ! 1044 IF ( FLCX ) CALL W3QCK3 & 1045 (NX, NY, NX, NY, VLCFLX, ATRNX, VQ, & 1046 GLOBAL, NY, MAPAXY, NACT, MAPX2, NMX0, & 1047 NMX1, NMX2, NDSE, NDST ) 1048 IF ( FLCY ) CALL W3QCK3 & 1049 (NX, NY, NX, NY, VLCFLY, ATRNY, VQ, & 1050 .FALSE., 1, MAPAXY, NACT, MAPY2, NMY0, & 1051 NMY1, NMY2, NDSE, NDST ) 1052 ! Page 23 Source Listing W3XYP3 2014-09-16 16:49 w3pro3md.f90 1053 END IF 1054 1055 ! Transform VQ back to normal space 1056 !$OMP PARALLEL DO PRIVATE (ISEA, IX, IY, IXY) 1057 DO ISEA=1, NSEA 1058 IX = MAPSF(ISEA,1) 1059 IY = MAPSF(ISEA,2) 1060 IXY = MAPSF(ISEA,3) 1061 VQ(IXY)= VQ(IXY) / GSQRT(IY,IX) 1062 END DO 1063 1064 ! 1065 ! 3.c Update boundaries 1066 ! 1067 IF ( FLBPI ) THEN 1068 RD1 = DSEC21 ( TBPI0, TIME ) - DTG * & 1069 REAL(NTLOC-ITLOC)/REAL(NTLOC) 1070 RD2 = DSEC21 ( TBPI0, TBPIN ) 1071 IF ( RD2 .GT. 0.001 ) THEN 1072 RD2 = MIN(1.,MAX(0.,RD1/RD2)) 1073 RD1 = 1. - RD2 1074 ELSE 1075 RD1 = 0. 1076 RD2 = 1. 1077 END IF 1078 DO IBI=1, NBI 1079 IXY = MAPSF(ISBPI(IBI),3) 1080 VQ(IXY) = ( RD1*BBPI0(ISP,IBI) + RD2*BBPIN(ISP,IBI) ) & 1081 / CG(IK,ISBPI(IBI)) * CLATS(ISBPI(IBI)) 1082 END DO 1083 END IF 1084 ! 1085 YFIRST = .NOT. YFIRST 1086 END DO 1087 ! 1088 ! 4. Store results in VQ in proper format --------------------------- * 1089 ! 1090 !$OMP PARALLEL DO PRIVATE (ISEA, IXY) 1091 DO ISEA=1, NSEA 1092 IXY = MAPSF(ISEA,3) 1093 IF ( MAPSTA(IXY) .GT. 0 ) THEN 1094 VQ(IXY) = MAX ( 0. , CG(IK,ISEA)/CLATS(ISEA)*VQ(IXY) ) 1095 END IF 1096 END DO 1097 ! 1098 RETURN 1099 ! 1100 ! Formats 1101 ! 1102 !/ 1103 !/ End of W3XYP3 ----------------------------------------------------- / 1104 !/ 1105 END SUBROUTINE W3XYP3 Page 24 Source Listing W3XYP3 2014-09-16 16:49 Entry Points w3pro3md.f90 ENTRY POINTS Name w3pro3md_mp_w3xyp3_ SYMBOL CROSS REFERENCE Name Object Declared Type Bytes Dimen Elements Attributes References ABS Func 707 scalar 707,712,717,718,724,794,796,797,80 0,801,805,819,821,822,825,826,830 AQ Local 683 R(4) 4 1 0 876,885,892,894,896,898,900,902,90 4,906,908,920,927,935,938,944,947, 952,955,959,962,971,974,980,983,98 8,991,995,998,1007 ATRNX Local 643 R(4) 4 2 1 PTR 643,1038,1045 ATRNY Local 643 R(4) 4 2 1 PTR 643,1034,1049 BBPI0 Local 646 R(4) 4 2 1 PTR 646,1080 BBPIN Local 646 R(4) 4 2 1 PTR 646,1080 CG Local 643 R(4) 4 2 1 PTR 643,845,846,847,888,890,924,925,10 81,1094 CG0 Local 665 R(4) 4 scalar 696,724,726 CGA Local 665 R(4) 4 scalar 697,698,699 CGC Local 667 R(4) 4 scalar 700 CGN Local 665 R(4) 4 scalar 724,726 CGX Local 665 R(4) 4 scalar 698,700,707,708,710,724 CGY Local 665 R(4) 4 scalar 699,700,712,713,715,724 CLATS Local 635 R(4) 4 1 1 PTR 635,774,778,845,846,854,1081,1094 CONSTANTS Module 631 631 CP Local 677 R(4) 4 scalar 858,863,865 CQ Local 677 R(4) 4 scalar 858,864,866 CX Local 643 R(4) 4 1 1 PTR 643,703,704,854 CXC Local 665 R(4) 4 scalar 717,720,724 CXMAX Local 666 R(4) 4 scalar 704,707,710,717 CXMIN Local 666 R(4) 4 scalar 703,707,708,717 CXTOT Local 684 R(4) 4 1 0 737,846,854,863,864 CY Local 643 R(4) 4 1 1 PTR 643,705,706,855 CYC Local 665 R(4) 4 scalar 718,721,724 CYMAX Local 666 R(4) 4 scalar 706,712,715,718 CYMIN Local 666 R(4) 4 scalar 705,712,713,718 CYTOT Local 684 R(4) 4 1 0 738,847,855,863,864 DERA Param 729 R(4) 4 scalar 729,755,756 DPDX Local 639 R(4) 4 2 1 PTR 639,776,780,863 DPDY Local 639 R(4) 4 2 1 PTR 639,776,780,863 DQDX Local 639 R(4) 4 2 1 PTR 639,777,781,864 DQDY Local 639 R(4) 4 2 1 PTR 639,777,781,864 DSEC21 Func 633 R(4) 4 scalar 633,1068,1070 DTCFL Local 635 R(4) 4 scalar PTR 635,726 DTG Dummy 484 R(4) 4 scalar ARG,IN 726,727,1068 DTH Local 636 R(4) 4 scalar PTR 636,752 DTLOC Local 669 R(4) 4 scalar 727,728,752,753 DTRAD Local 669 R(4) 4 scalar 728,729,865,866 DXCGC Local 670 R(4) 4 scalar 765,785,789,794,796,797,801,810,81 Page 25 Source Listing W3XYP3 2014-09-16 16:49 Symbol Table w3pro3md.f90 Name Object Declared Type Bytes Dimen Elements Attributes References 4,819,821,822,826 DXCGN Local 670 R(4) 4 scalar 765,776,785,810 DXCGS Local 670 R(4) 4 scalar 765,780,785,810 DYCGC Local 671 R(4) 4 scalar 765,786,791,794,796,800,801,805,81 1,816,819,821,825,826,830 DYCGN Local 670 R(4) 4 scalar 765,777,786,811 DYCGS Local 670 R(4) 4 scalar 765,781,786,811 ECOS Local 638 R(4) 4 1 1 PTR 638,698,760,761,846 ESIN Local 638 R(4) 4 1 1 PTR 638,699,759,762,847 FCG Local 668 R(4) 4 scalar 753,756,758,761,762 FCGX Local 668 R(4) 4 scalar 761,778 FCGY Local 668 R(4) 4 scalar 762,779 FGSE Local 667 R(4) 4 scalar 667,752,753 FLAGLL Local 639 L(4) 4 scalar 639,729,754 FLBPI Local 645 L(4) 4 scalar PTR 645,1067 FLCUR Local 644 L(4) 4 scalar PTR 644,702,851 FLCX Local 636 L(4) 4 scalar PTR 636,1037,1044 FLCY Local 636 L(4) 4 scalar PTR 636,1033,1048 FTH Local 668 R(4) 4 scalar 752,755,759,760 FTHX Local 668 R(4) 4 scalar 759,774 FTHY Local 668 R(4) 4 scalar 760,775 GLOBAL Local 676 L(4) 4 scalar 692,742,1012,1039,1046 GRAV Param 696 R(4) 4 scalar 696,697 GSQRT Local 639 R(4) 4 2 1 PTR 639,1028,1061 IBI Local 662 I(4) 4 scalar 1078,1079,1080,1081 ICLOSE Local 636 I(4) 4 scalar PTR 636,692 ICLOSE_NONE Param 637 I(4) 4 scalar 637,692 ICLOSE_SMPL Param 637 I(4) 4 scalar 637 ICLOSE_TRPL Param 637 I(4) 4 scalar 637 IIXY1 Local 663 I(4) 4 1 0 793,893,901,929,930,931,934,940,94 3 IIXY2 Local 663 I(4) 4 1 0 795,799,895,903,950,951,957,958 IIXY3 Local 664 I(4) 4 1 0 818,897,905,965,966,967,970,976,97 9 IIXY4 Local 664 I(4) 4 1 0 820,824,899,907,986,987,993,994 IK Local 661 I(4) 4 scalar 694,697,845,846,847,888,890,924,92 5,1081,1094 INT Func 726 scalar 726 IP Local 661 I(4) 4 scalar 881,882,914,915 ISBPI Local 646 I(4) 4 1 1 PTR 646,1079,1081 ISEA Local 661 I(4) 4 scalar 764,767,769,770,774,778,793,795,79 6,797,799,801,803,805,818,820,821, 822,824,826,828,830,842,843,844,84 5,846,847,852,853,854,855,859,860, 861,862,882,883,887,888,889,890,89 3,895,897,899,901,903,905,907,915, 916,917,922,923,924,925,929,930,93 1,934,940,943,950,951,957,958,965, 966,967,970,976,979,986,987,993,99 4,1023,1024,1025,1026,1027,1056,10 57,1058,1059,1060,1090,1091,1092,1 094 ISP Dummy 484 I(4) 4 scalar ARG,IN 693,694,1080 ITH Local 661 I(4) 4 scalar 693,698,699,759,760,761,762,846,84 7 Page 26 Source Listing W3XYP3 2014-09-16 16:49 Symbol Table w3pro3md.f90 Name Object Declared Type Bytes Dimen Elements Attributes References ITIME Local 643 I(4) 4 scalar PTR 643,731 ITLOC Local 661 I(4) 4 scalar 872,1069 IX Local 662 I(4) 4 scalar 764,769,776,777,780,781,858,860,86 3,864,916,1023,1025,1028,1056,1058 ,1061 IXC Local 662 I(4) 4 scalar 766,788,789,793,795,813,814,818,82 0,929,930,932,941,965,966,968,977 IXY Local 661 I(4) 4 scalar 842,844,845,846,847,853,854,855,85 8,862,863,864,865,866,883,884,885, 891,892,893,894,895,896,897,898,89 9,900,901,902,903,904,905,906,907, 908,917,918,919,920,926,927,931,93 2,933,934,935,937,938,940,941,942, 943,944,946,947,950,951,952,954,95 5,957,958,959,961,962,967,968,969, 970,971,973,974,976,977,978,979,98 0,982,983,986,987,988,990,991,993, 994,995,997,998,1006,1007,1023,102 7,1028,1056,1060,1061,1079,1080,10 90,1092,1093,1094 IY Local 662 I(4) 4 scalar 764,770,776,777,780,781,858,861,86 3,864,1013,1014,1015,1023,1026,102 8,1056,1059,1061 IYC Local 662 I(4) 4 scalar 766,790,791,793,799,815,816,818,82 4,930,933,942,966,969,978 MAPAXY Local 642 I(4) 4 1 1 PTR 642,1035,1039,1046,1050 MAPCXY Local 642 I(4) 4 1 1 PTR 642,882,915 MAPFS Dummy 484 I(4) 4 1 0 ARG,IN MAPSF Local 635 I(4) 4 2 1 PTR 635,769,770,844,853,860,861,862,88 3,916,917,1025,1026,1027,1058,1059 ,1060,1079,1092 MAPSTA Dummy 484 I(4) 4 1 0 ARG,IN 740,743,744,918,1007,1093 MAPSTX Local 681 I(4) 4 1 0 740,743,744,746,747,931,932,933,94 0,941,942,950,957,967,968,969,976, 977,978,986,993 MAPTRN Local 643 L(4) 4 1 1 PTR 643,884,919 MAPX2 Local 642 I(4) 4 1 1 PTR 642,1039,1046 MAPY2 Local 642 I(4) 4 1 1 PTR 642,1035,1050 MAX Func 717 scalar 717,718,724,1072,1094 MAXVAL Func 704 scalar 704,706 MIN Func 888 scalar 888,890,924,925,1072 MINVAL Func 703 scalar 703,705 MOD Func 693 scalar 693,731 NACT Local 641 I(4) 4 scalar PTR 641,1035,1039,1046,1050 NBI Local 645 I(4) 4 scalar PTR 645,1078 NCENT Local 642 I(4) 4 scalar PTR 642,881,914 NDSE Local 645 I(4) 4 scalar PTR 645,1036,1040,1047,1051 NDST Local 645 I(4) 4 scalar PTR 645,1036,1040,1047,1051 NK Local 636 I(4) 4 scalar PTR 636 NMX0 Local 641 I(4) 4 scalar PTR 641,1039,1046 NMX1 Local 641 I(4) 4 scalar PTR 641,1040,1047 NMX2 Local 641 I(4) 4 scalar PTR 641,1040,1047 NMY0 Local 641 I(4) 4 scalar PTR 641,1035,1050 NMY1 Local 641 I(4) 4 scalar PTR 641,1036,1051 NMY2 Local 641 I(4) 4 scalar PTR 641,1036,1051 Page 27 Source Listing W3XYP3 2014-09-16 16:49 Symbol Table w3pro3md.f90 Name Object Declared Type Bytes Dimen Elements Attributes References NSEA Local 635 I(4) 4 scalar PTR 635,663,664,672,673,703,704,705,70 6,767,843,852,859,914,1024,1057,10 91 NTH Local 636 I(4) 4 scalar PTR 636,693,694 NTLOC Local 661 I(4) 4 scalar 726,727,758,872,1069 NX Local 635 I(4) 4 scalar PTR 635,654,656,681,682,683,684,740,74 3,744,747,1006,1014,1015,1034,1038 ,1045,1049 NY Local 635 I(4) 4 scalar PTR 635,654,656,681,682,683,684,740,74 3,744,746,747,788,813,929,965,1006 ,1013,1014,1015,1034,1038,1039,104 5,1046,1049 PFMOVE Local 638 R(4) 4 scalar PTR 638 RADIUS Param 729 R(4) 4 scalar 729,755,756 RD1 Local 674 R(4) 4 scalar 887,894,896,902,904,922,935,938,94 4,947,952,955,959,962,1068,1072,10 73,1075,1080 RD2 Local 674 R(4) 4 scalar 888,892,894,896,902,904,924,927,93 5,938,944,947,952,955,959,962,1070 ,1071,1072,1073,1076,1080 RD3 Local 674 R(4) 4 scalar 889,898,900,906,908,923,971,974,98 0,983,988,991,995,998 RD4 Local 674 R(4) 4 scalar 890,892,898,900,906,908,925,927,97 1,974,980,983,988,991,995,998 RDI1 Local 672 R(4) 4 1 0 796,801,803,887,922 RDI2 Local 672 R(4) 4 1 0 797,805,888,924 RDI3 Local 673 R(4) 4 1 0 821,826,828,889,923 RDI4 Local 673 R(4) 4 1 0 822,830,890,925 REAL Func 727 scalar 727,758,1069 SIG Local 638 R(4) 4 1 1 PTR 638,696,697 SIGN Func 929 scalar 929,965 SQRT Func 700 scalar 700 TBPI0 Local 645 I(4) 4 1 1 PTR 645,1068,1070 TBPIN Local 645 I(4) 4 1 1 PTR 645,1070 TIME Local 640 I(4) 4 1 1 PTR 640,1068 TMPX Local 674 R(4) 4 scalar 764,774,776,777,778,780,781 TMPY Local 674 R(4) 4 scalar 764,775,776,777,779,780,781 VGX Dummy 484 R(4) 4 scalar ARG,IN VGY Dummy 484 R(4) 4 scalar ARG,IN VLCFLX Local 682 R(4) 4 1 0 735,865,1038,1045 VLCFLY Local 682 R(4) 4 1 0 736,866,1034,1049 VQ Dummy 484 R(4) 4 1 0 ARG,INOUT 845,876,877,885,891,893,895,897,89 9,901,903,905,907,920,926,934,937, 943,946,951,954,958,961,970,973,97 9,982,987,990,994,997,1007,1014,10 15,1028,1034,1038,1045,1049,1061,1 080,1094 W3ADATMD Module 641 641 W3GDATMD Module 635 635 W3IDATMD Module 644 644 W3ODATMD Module 645 645 W3QCK3 Subr 1033 1033,1037,1044,1048 W3TIMEMD Module 633 633 W3UQCKMD Module 647 647 W3WDATMD Module 640 640 Page 28 Source Listing W3XYP3 2014-09-16 16:49 Symbol Table w3pro3md.f90 Name Object Declared Type Bytes Dimen Elements Attributes References W3XYP3 Subr 484 WDCG Local 638 R(4) 4 scalar PTR 638,753 WDTH Local 638 R(4) 4 scalar PTR 638,752 XFR Local 636 R(4) 4 scalar PTR 636,753 YFIRST Local 675 L(4) 4 scalar 731,1031,1085 Page 29 Source Listing W3XYP3 2014-09-16 16:49 w3pro3md.f90 1106 !/ ------------------------------------------------------------------- / 1107 SUBROUTINE W3KTP3 ( ISEA, FACTH, FACK, CTHG0, CG, WN, DW, & 1108 DDDX, DDDY, CX, CY, DCXDX, DCXDY, & 1109 DCYDX, DCYDY, DCDX, DCDY, VA, CFLTHMAX, CFLKMAX ) 1110 !/ 1111 !/ *** THIS ROUTINE SHOULD BE IDENTICAL TO W3KTP2 *** 1112 !/ 1113 !/ +-----------------------------------+ 1114 !/ | WAVEWATCH III NOAA/NCEP | 1115 !/ | H. L. Tolman | 1116 !/ | FORTRAN 90 | 1117 !/ | Last update : 01-Jul-2013 | 1118 !/ +-----------------------------------+ 1119 !/ 1120 !/ 14-Feb-2000 : Origination. ( version 2.08 ) 1121 !/ 17-Dec-2004 : Multiple grid version. ( version 3.06 ) 1122 !/ 06-Mar-2011 : Output of maximum CFL (F. Ardhuin) ( version 3.14 ) 1123 !/ 24-Aug-2011 : Limiter on k advection (F. Ardhuin) ( version 4.04 ) 1124 !/ 25-Aug-2011 : DEPTH = MAX ( DMIN, DW(ISEA) ) ( version 4.04 ) 1125 !/ 26-Dec-2012 : More initializations. ( version 4.11 ) 1126 !/ 01-Jul-2013 : Adding UQ and UNO switches to chose between third 1127 !/ and second order schemes. ( version 4.12 ) 1128 !/ 1129 ! 1. Purpose : 1130 ! 1131 ! Propagation in spectral space. 1132 ! 1133 ! 2. Method : 1134 ! 1135 ! Third order QUICKEST scheme with ULTIMATE limiter. 1136 ! 1137 ! As with the spatial propagation, the two spaces are considered 1138 ! independently, but the propagation is performed in a 2-D space. 1139 ! Compared to the propagation in physical space, the directions 1140 ! rerpesent a closed space and are therefore comparable to the 1141 ! longitudinal or 'X' propagation. The wavenumber space has to be 1142 ! extended to allow for boundary treatment. Using a simple first 1143 ! order boundary treatment at both sided, two points need to 1144 ! be added. This implies that the spectrum needs to be extended, 1145 ! shifted and rotated, as is performed using MAPTH2 as set 1146 ! in W3MAP3. 1147 ! 1148 ! 3. Parameters : 1149 ! 1150 ! Parameter list 1151 ! ---------------------------------------------------------------- 1152 ! ISEA Int. I Number of sea point. 1153 ! FACTH/K Real I Factor in propagation velocity. 1154 ! CTHG0 Real I Factor in great circle refracftion term. 1155 ! MAPxx2 I.A. I Propagation and storage maps. 1156 ! CG R.A. I Local group velocities. 1157 ! WN R.A. I Local wavenumbers. 1158 ! DW R.A. I Depth. 1159 ! DDDx Real I Depth gradients. 1160 ! CX/Y Real I Current components. 1161 ! DCxDx Real I Current gradients. 1162 ! DCDX-Y Real I Phase speed gradients. Page 30 Source Listing W3KTP3 2014-09-16 16:49 w3pro3md.f90 1163 ! VA R.A. I/O Spectrum. 1164 ! ---------------------------------------------------------------- 1165 ! 1166 ! Local variables. 1167 ! ---------------------------------------------------------------- 1168 ! DSDD R.A. Partial derivative of sigma for depth. 1169 ! FDD, FDU, FDG, FCD, FCU 1170 ! R.A. Directionally varying part of depth, current and 1171 ! great-circle refraction terms and of consit. 1172 ! of Ck term. 1173 ! CFLT-K R.A. Propagation velocities of local fluxes. 1174 ! DB R.A. Wavenumber band widths at cell centers. 1175 ! DM R.A. Wavenumber band widths between cell centers and 1176 ! next cell center. 1177 ! Q R.A. Extracted spectrum 1178 ! ---------------------------------------------------------------- 1179 ! 1180 ! 4. Subroutines used : 1181 ! 1182 ! W3QCK1 Actual propagation routine. 1183 ! W3QCK2 Actual propagation routine. 1184 ! STRACE Service routine. 1185 ! 1186 ! 5. Called by : 1187 ! 1188 ! W3WAVE Wave model routine. 1189 ! 1190 ! 6. Error messages : 1191 ! 1192 ! None. 1193 ! 1194 ! 8. Structure : 1195 ! 1196 ! ----------------------------------------------------------------- 1197 ! 1. Preparations 1198 ! a Initialize arrays 1199 ! b Set constants and counters 1200 ! 2. Point preparations 1201 ! a Calculate DSDD 1202 ! b Extract spectrum 1203 ! 3. Refraction velocities 1204 ! a Filter level depth reffraction. 1205 ! b Depth refratcion velocity. 1206 ! c Current refraction velocity. 1207 ! 4. Wavenumber shift velocities 1208 ! a Prepare directional arrays 1209 ! b Calcuate velocity. 1210 ! 5. Propagate. 1211 ! 6. Store results. 1212 ! ----------------------------------------------------------------- 1213 ! 1214 ! 9. Switches : 1215 ! 1216 ! !/S Enable subroutine tracing. 1217 ! !/T Enable general test output. 1218 ! 1219 ! 10. Source code : Page 31 Source Listing W3KTP3 2014-09-16 16:49 w3pro3md.f90 1220 ! 1221 !/ ------------------------------------------------------------------- / 1222 USE CONSTANTS 1223 USE W3GDATMD, ONLY: NK, NK2, NTH, NSPEC, SIG, DSIP, ECOS, ESIN, & 1224 EC2, ESC, ES2, FACHFA, MAPWN, FLCTH, FLCK, & 1225 CTMAX, DMIN 1226 USE W3ADATMD, ONLY: MAPTH2, MAPWN2, ITIME 1227 USE W3IDATMD, ONLY: FLCUR 1228 USE W3ODATMD, ONLY: NDSE, NDST 1229 USE W3UQCKMD 1230 !/ 1231 IMPLICIT NONE 1232 !/ 1233 !/ ------------------------------------------------------------------- / 1234 !/ Parameter list 1235 !/ 1236 INTEGER, INTENT(IN) :: ISEA 1237 REAL, INTENT(IN) :: FACTH, FACK, CTHG0, CG(0:NK+1), & 1238 WN(0:NK+1), DW, DDDX, DDDY, & 1239 CX, CY, DCXDX, DCXDY, DCYDX, DCYDY 1240 REAL, INTENT(IN) :: DCDX(0:NK+1), DCDY(0:NK+1) 1241 REAL, INTENT(INOUT) :: VA(NSPEC) 1242 REAL, INTENT(OUT) :: CFLTHMAX, CFLKMAX 1243 !/ 1244 !/ ------------------------------------------------------------------- / 1245 !/ Local parameters 1246 !/ 1247 INTEGER :: ITH, IK, ISP 1248 REAL :: FDDMAX, FDG, FKD, FKD0, DCYX, & 1249 DCXXYY, DCXY, DCXX, DCXYYX, DCYY, & 1250 VELNOFILT, VELFAC, DEPTH 1251 REAL :: DSDD(0:NK+1), FRK(NK), FRG(NK), & 1252 FKC(NTH), VQ(-NK-1:NK2*(NTH+2)), & 1253 DB(NK2,NTH+1), DM(NK2,0:NTH+1), & 1254 VCFLT(NK2*(NTH+1)), CFLK(NK2,NTH) 1255 !/ 1256 !/ ------------------------------------------------------------------- / 1257 !/ 1258 ! 1259 ! 1. Preparations --------------------------------------------------- * 1260 ! 1.a Initialize arrays 1261 ! 1262 DEPTH = MAX ( DMIN, DW ) 1263 VQ = 0. 1264 IF ( FLCTH ) VCFLT = 0. 1265 IF ( FLCK ) CFLK = 0. 1266 CFLTHMAX = 0. 1267 CFLKMAX = 0. 1268 ! 1269 ! 2. Preparation for point ------------------------------------------ * 1270 ! 2.a Array with partial derivative of sigma versus depth 1271 ! 1272 DO IK=0, NK+1 1273 IF ( DEPTH*WN(IK) .LT. 5. ) THEN 1274 DSDD(IK) = MAX ( 0. , & 1275 CG(IK)*WN(IK)-0.5*SIG(IK) ) / DEPTH 1276 ELSE Page 32 Source Listing W3KTP3 2014-09-16 16:49 w3pro3md.f90 1277 DSDD(IK) = 0. 1278 END IF 1279 END DO 1280 ! 1281 ! 2.b Extract spectrum 1282 ! 1283 DO ISP=1, NSPEC 1284 VQ(MAPTH2(ISP)) = VA(ISP) 1285 END DO 1286 ! 1287 ! 3. Refraction velocities ------------------------------------------ * 1288 ! 1289 IF ( FLCTH ) THEN 1290 ! 1291 ! 3.a Set slope filter for depth refraction 1292 ! 1293 ! N.B.: FACTH = DTG / DTH / REAL(NTLOC) (value set in w3wavemd) 1294 ! namely, FACTH*VC=1 corresponds to CFL=1 1295 ! 1296 FDDMAX = 0. 1297 FDG = FACTH * CTHG0 1298 ! 1299 DO ITH=1, NTH/2 1300 FDDMAX = MAX(FDDMAX,ABS(ESIN(ITH)*DDDX-ECOS(ITH)*DDDY)) 1301 END DO 1302 ! 1303 DO IK=1, NK 1304 FRK(IK) = FACTH * DSDD(IK) / WN(IK) 1305 ! 1306 ! Removes the filtering that was done at that stage (F. Ardhuin 2011/03/06) 1307 ! 1308 ! FRK(IK) = FRK(IK) / MAX ( 1. , FRK(IK)*FDDMAX/CTMAX ) 1309 FRG(IK) = FDG * CG(IK) 1310 END DO 1311 ! 1312 ! 3.b Current refraction 1313 ! 1314 IF ( FLCUR ) THEN 1315 ! 1316 DCYX = FACTH * DCYDX 1317 DCXXYY = FACTH * ( DCXDX - DCYDY ) 1318 DCXY = FACTH * DCXDY 1319 ! 1320 DO ISP=1, NSPEC 1321 VCFLT(MAPTH2(ISP)) = ES2(ISP)*DCYX + & 1322 ESC(ISP)*DCXXYY - EC2(ISP)*DCXY 1323 END DO 1324 ! 1325 ELSE 1326 VCFLT(:)=0. 1327 END IF 1328 ! 1329 ! 3.c Depth refraction and great-circle propagation 1330 ! 1331 DO ISP=1, NSPEC 1332 VELNOFILT = VCFLT(MAPTH2(ISP)) & 1333 + FRG(MAPWN(ISP)) * ECOS(ISP) & Page 33 Source Listing W3KTP3 2014-09-16 16:49 w3pro3md.f90 1334 + FRK(MAPWN(ISP)) * ( ESIN(ISP)*DDDX - ECOS(ISP)*DDDY ) 1335 ! 1336 CFLTHMAX = MAX(CFLTHMAX, ABS(VELNOFILT)) 1337 ! 1338 ! Puts filtering on total velocity (including currents and great circle effects) 1339 ! the filtering limits VCFLT to be less than CTMAX 1340 ! this modification was proposed by F. Ardhuin 2011/03/06 1341 ! 1342 VCFLT(MAPTH2(ISP))=SIGN(MIN(ABS(VELNOFILT),CTMAX),VELNOFILT) 1343 END DO 1344 END IF 1345 ! 1346 ! 4. Wavenumber shift velocities ------------------------------------ * 1347 ! N.B.: FACK = DTG / REAL(NTLOC) (value set in w3wavemd) 1348 ! namely, FACK*VC/DK=1 corresponds to CFL=1 1349 ! 1350 IF ( FLCK ) THEN 1351 ! 1352 ! 4.a Directionally dependent part 1353 ! 1354 DCXX = - DCXDX 1355 DCXYYX = - ( DCXDY + DCYDX ) 1356 DCYY = - DCYDY 1357 FKD = ( CX*DDDX + CY*DDDY ) 1358 ! 1359 DO ITH=1, NTH 1360 FKC(ITH) = EC2(ITH)*DCXX + & 1361 ESC(ITH)*DCXYYX + ES2(ITH)*DCYY 1362 END DO 1363 ! 1364 ! 4.b Band widths 1365 ! 1366 DO IK=0, NK 1367 DB(IK+1,1) = DSIP(IK) / CG(IK) 1368 DM(IK+1,1) = WN(IK+1) - WN(IK) 1369 END DO 1370 DB(NK+2,1) = DSIP(NK+1) / CG(NK+1) 1371 DM(NK+2,1) = 0. 1372 ! 1373 DO ITH=2, NTH 1374 DO IK=1, NK+2 1375 DB(IK,ITH) = DB(IK,1) 1376 DM(IK,ITH) = DM(IK,1) 1377 END DO 1378 END DO 1379 ! 1380 ! 4.c Velocities 1381 ! 1382 DO IK=0, NK+1 1383 FKD0 = FKD / CG(IK) * DSDD(IK) 1384 VELFAC = FACK/DB(IK+1,1) 1385 DO ITH=1, NTH 1386 ! 1387 ! Puts filtering on velocity (needs the band widths) 1388 ! 1389 VELNOFILT = ( FKD0 + WN(IK)*FKC(ITH) ) * VELFAC ! this is velocity * DT / DK 1390 CFLKMAX = MAX(CFLKMAX, ABS(VELNOFILT)) Page 34 Source Listing W3KTP3 2014-09-16 16:49 w3pro3md.f90 1391 CFLK(IK+1,ITH) = SIGN(MIN(ABS(VELNOFILT),CTMAX),VELNOFILT)/VELFAC 1392 !CFLK(IK+1,ITH) = FKD0 + WN(IK)*FKC(ITH) ! this was without the limiter ... 1393 END DO 1394 END DO 1395 ! 1396 END IF 1397 ! 1398 ! 5. Propagate ------------------------------------------------------ * 1399 ! 1400 IF ( MOD(ITIME,2) .EQ. 0 ) THEN 1401 IF ( FLCK ) THEN 1402 DO ITH=1, NTH 1403 VQ(NK+2+(ITH-1)*NK2) = FACHFA * VQ(NK+1+(ITH-1)*NK2) 1404 END DO 1405 ! 1406 CALL W3QCK2 ( NTH, NK2, NTH, NK2, CFLK, FACK, DB, DM, & 1407 VQ, .FALSE., 1, MAPTH2, NSPEC, & 1408 MAPWN2, NSPEC-NTH, NSPEC, NSPEC+NTH, & 1409 NDSE, NDST ) 1410 ! 1411 END IF 1412 IF ( FLCTH ) THEN 1413 ! 1414 CALL W3QCK1 ( NTH, NK2, NTH, NK2, VCFLT, VQ, .TRUE., & 1415 NK2, MAPTH2, NSPEC, MAPTH2, NSPEC, NSPEC, & 1416 NSPEC, NDSE, NDST ) 1417 ! 1418 END IF 1419 ELSE 1420 IF ( FLCTH ) THEN 1421 ! 1422 CALL W3QCK1 ( NTH, NK2, NTH, NK2, VCFLT, VQ, .TRUE., & 1423 NK2, MAPTH2, NSPEC, MAPTH2, NSPEC, NSPEC, & 1424 NSPEC, NDSE, NDST ) 1425 ! 1426 END IF 1427 IF ( FLCK ) THEN 1428 DO ITH=1, NTH 1429 VQ(NK+2+(ITH-1)*NK2) = FACHFA * VQ(NK+1+(ITH-1)*NK2) 1430 END DO 1431 ! 1432 CALL W3QCK2 ( NTH, NK2, NTH, NK2, CFLK, FACK, DB, DM, & 1433 VQ, .FALSE., 1, MAPTH2, NSPEC, & 1434 MAPWN2, NSPEC-NTH, NSPEC, NSPEC+NTH, & 1435 NDSE, NDST ) 1436 ! 1437 END IF 1438 END IF 1439 ! 1440 ! 6. Store reults --------------------------------------------------- * 1441 ! 1442 DO ISP=1, NSPEC 1443 VA(ISP) = VQ(MAPTH2(ISP)) 1444 END DO 1445 ! 1446 RETURN 1447 ! Page 35 Source Listing W3KTP3 2014-09-16 16:49 w3pro3md.f90 1448 ! Formats 1449 ! 1450 !/ 1451 !/ End of W3KTP3 ----------------------------------------------------- / 1452 !/ 1453 END SUBROUTINE W3KTP3 ENTRY POINTS Name w3pro3md_mp_w3ktp3_ SYMBOL CROSS REFERENCE Name Object Declared Type Bytes Dimen Elements Attributes References ABS Func 1300 scalar 1300,1336,1342,1390,1391 CFLK Local 1254 R(4) 4 2 0 1265,1391,1406,1432 CFLKMAX Dummy 1109 R(4) 4 scalar ARG,OUT 1267,1390 CFLTHMAX Dummy 1109 R(4) 4 scalar ARG,OUT 1266,1336 CG Dummy 1107 R(4) 4 1 0 ARG,IN 1275,1309,1367,1370,1383 CONSTANTS Module 1222 1222 CTHG0 Dummy 1107 R(4) 4 scalar ARG,IN 1297 CTMAX Local 1225 R(4) 4 scalar PTR 1225,1342,1391 CX Dummy 1108 R(4) 4 scalar ARG,IN 1357 CY Dummy 1108 R(4) 4 scalar ARG,IN 1357 DB Local 1253 R(4) 4 2 0 1367,1370,1375,1384,1406,1432 DCDX Dummy 1109 R(4) 4 1 0 ARG,IN DCDY Dummy 1109 R(4) 4 1 0 ARG,IN DCXDX Dummy 1108 R(4) 4 scalar ARG,IN 1317,1354 DCXDY Dummy 1108 R(4) 4 scalar ARG,IN 1318,1355 DCXX Local 1249 R(4) 4 scalar 1354,1360 DCXXYY Local 1249 R(4) 4 scalar 1317,1322 DCXY Local 1249 R(4) 4 scalar 1318,1322 DCXYYX Local 1249 R(4) 4 scalar 1355,1361 DCYDX Dummy 1109 R(4) 4 scalar ARG,IN 1316,1355 DCYDY Dummy 1109 R(4) 4 scalar ARG,IN 1317,1356 DCYX Local 1248 R(4) 4 scalar 1316,1321 DCYY Local 1249 R(4) 4 scalar 1356,1361 DDDX Dummy 1108 R(4) 4 scalar ARG,IN 1300,1334,1357 DDDY Dummy 1108 R(4) 4 scalar ARG,IN 1300,1334,1357 DEPTH Local 1250 R(4) 4 scalar 1262,1273,1275 DM Local 1253 R(4) 4 2 0 1368,1371,1376,1406,1432 DMIN Local 1225 R(4) 4 scalar PTR 1225,1262 DSDD Local 1251 R(4) 4 1 0 1274,1277,1304,1383 DSIP Local 1223 R(4) 4 1 1 PTR 1223,1367,1370 DW Dummy 1107 R(4) 4 scalar ARG,IN 1262 EC2 Local 1224 R(4) 4 1 1 PTR 1224,1322,1360 ECOS Local 1223 R(4) 4 1 1 PTR 1223,1300,1333,1334 ES2 Local 1224 R(4) 4 1 1 PTR 1224,1321,1361 ESC Local 1224 R(4) 4 1 1 PTR 1224,1322,1361 ESIN Local 1223 R(4) 4 1 1 PTR 1223,1300,1334 FACHFA Local 1224 R(4) 4 scalar PTR 1224,1403,1429 FACK Dummy 1107 R(4) 4 scalar ARG,IN 1384,1406,1432 Page 36 Source Listing W3KTP3 2014-09-16 16:49 Symbol Table w3pro3md.f90 Name Object Declared Type Bytes Dimen Elements Attributes References FACTH Dummy 1107 R(4) 4 scalar ARG,IN 1297,1304,1316,1317,1318 FDDMAX Local 1248 R(4) 4 scalar 1296,1300 FDG Local 1248 R(4) 4 scalar 1297,1309 FKC Local 1252 R(4) 4 1 0 1360,1389 FKD Local 1248 R(4) 4 scalar 1357,1383 FKD0 Local 1248 R(4) 4 scalar 1383,1389 FLCK Local 1224 L(4) 4 scalar PTR 1224,1265,1350,1401,1427 FLCTH Local 1224 L(4) 4 scalar PTR 1224,1264,1289,1412,1420 FLCUR Local 1227 L(4) 4 scalar PTR 1227,1314 FRG Local 1251 R(4) 4 1 0 1309,1333 FRK Local 1251 R(4) 4 1 0 1304,1334 IK Local 1247 I(4) 4 scalar 1272,1273,1274,1275,1277,1303,1304 ,1309,1366,1367,1368,1374,1375,137 6,1382,1383,1384,1389,1391 ISEA Dummy 1107 I(4) 4 scalar ARG,IN ISP Local 1247 I(4) 4 scalar 1283,1284,1320,1321,1322,1331,1332 ,1333,1334,1342,1442,1443 ITH Local 1247 I(4) 4 scalar 1299,1300,1359,1360,1361,1373,1375 ,1376,1385,1389,1391,1402,1403,142 8,1429 ITIME Local 1226 I(4) 4 scalar PTR 1226,1400 MAPTH2 Local 1226 I(4) 4 1 1 PTR 1226,1284,1321,1332,1342,1407,1415 ,1423,1433,1443 MAPWN Local 1224 I(4) 4 1 1 PTR 1224,1333,1334 MAPWN2 Local 1226 I(4) 4 1 1 PTR 1226,1408,1434 MAX Func 1262 scalar 1262,1274,1300,1336,1390 MIN Func 1342 scalar 1342,1391 MOD Func 1400 scalar 1400 NDSE Local 1228 I(4) 4 scalar PTR 1228,1409,1416,1424,1435 NDST Local 1228 I(4) 4 scalar PTR 1228,1409,1416,1424,1435 NK Local 1223 I(4) 4 scalar PTR 1223,1237,1238,1240,1251,1252,1272 ,1303,1366,1370,1371,1374,1382,140 3,1429 NK2 Local 1223 I(4) 4 scalar PTR 1223,1252,1253,1254,1403,1406,1414 ,1415,1422,1423,1429,1432 NSPEC Local 1223 I(4) 4 scalar PTR 1223,1241,1283,1320,1331,1407,1408 ,1415,1416,1423,1424,1433,1434,144 2 NTH Local 1223 I(4) 4 scalar PTR 1223,1252,1253,1254,1299,1359,1373 ,1385,1402,1406,1408,1414,1422,142 8,1432,1434 SIG Local 1223 R(4) 4 1 1 PTR 1223,1275 SIGN Func 1342 scalar 1342,1391 VA Dummy 1109 R(4) 4 1 0 ARG,INOUT 1284,1443 VCFLT Local 1254 R(4) 4 1 0 1264,1321,1326,1332,1342,1414,1422 VELFAC Local 1250 R(4) 4 scalar 1384,1389,1391 VELNOFILT Local 1250 R(4) 4 scalar 1332,1336,1342,1389,1390,1391 VQ Local 1252 R(4) 4 1 0 1263,1284,1403,1407,1414,1422,1429 ,1433,1443 W3ADATMD Module 1226 1226 W3GDATMD Module 1223 1223 W3IDATMD Module 1227 1227 W3KTP3 Subr 1107 W3ODATMD Module 1228 1228 W3QCK1 Subr 1414 1414,1422 Page 37 Source Listing W3KTP3 2014-09-16 16:49 Symbol Table w3pro3md.f90 Name Object Declared Type Bytes Dimen Elements Attributes References W3QCK2 Subr 1406 1406,1432 W3UQCKMD Module 1229 1229 WN Dummy 1107 R(4) 4 1 0 ARG,IN 1273,1275,1304,1368,1389 Page 38 Source Listing W3KTP3 2014-09-16 16:49 w3pro3md.f90 1454 !/ ------------------------------------------------------------------- / 1455 SUBROUTINE W3CFLXY ( ISEA, DTG, MAPSTA, MAPFS, CFLXYMAX, VGX, VGY ) 1456 !/ 1457 !/ +-----------------------------------+ 1458 !/ | WAVEWATCH III NOAA/NCEP | 1459 !/ | F. Ardhuin | 1460 !/ | FORTRAN 90 | 1461 !/ | Last update : 31-Oct-2010 | 1462 !/ +-----------------------------------+ 1463 !/ 1464 !/ 07-Mar-2011 : Origination. ( version 3.14 ) 1465 !/ 1466 ! 1. Purpose : 1467 ! 1468 ! Computes the maximum CFL number for spatial advection. Used for diagnostic 1469 ! purposes. (Could be used to define a local time step ...) 1470 ! 1471 ! 2. Method : 1472 ! 1473 ! 3. Parameters : 1474 ! 1475 ! Parameter list 1476 ! ---------------------------------------------------------------- 1477 ! ISEA Int. I Index of grid point. 1478 ! DTG Real I Total time step. 1479 ! MAPSTA I.A. I Grid point status map. 1480 ! MAPFS I.A. I Storage map. 1481 ! CFLXYMAX Real O Maximum CFL number for XY propagation. 1482 ! VGX/Y Real I Speed of grid. 1483 ! ---------------------------------------------------------------- 1484 ! 1485 ! Local variables. 1486 ! ---------------------------------------------------------------- 1487 ! NTLOC Int Number of local time steps. 1488 ! DTLOC Real Local propagation time step. 1489 ! VCFL0X R.A. Local courant numbers for absolute group vel. 1490 ! using local X-grid step. 1491 ! VCFL0Y R.A. Id. in Y. 1492 ! ---------------------------------------------------------------- 1493 ! 1494 ! 4. Subroutines used : 1495 ! 1496 ! STRACE Service routine. 1497 ! 1498 ! 5. Called by : 1499 ! 1500 ! W3WAVE Wave model routine. 1501 ! 1502 ! 6. Error messages : 1503 ! 1504 ! None. 1505 ! 1506 ! 7. Remarks : 1507 ! 1508 ! - Curvilinear grid implementation. Variables FACX, FACY, CCOS, CSIN, 1509 ! CCURX, CCURY are not needed and have been removed. FACX is accounted 1510 ! for as approriate in this subroutine. FACX is also accounted for in Page 39 Source Listing W3CFLXY 2014-09-16 16:49 w3pro3md.f90 1511 ! the case of .NOT.FLCX. Since FACX is removed, there is now a check for 1512 ! .NOT.FLCX in this subroutine. In CFL calcs dx and dy are omitted, 1513 ! since dx=dy=1 in index space. Curvilinear grid derivatives 1514 ! (DPDY, DQDX, etc.) and metric (GSQRT) are brought in via W3GDATMD. 1515 ! 1516 ! 8. Structure : 1517 ! 1518 ! --------------------------------------------- 1519 ! --------------------------------------------- 1520 ! 1521 ! 9. Switches : 1522 ! 1523 ! !/S Enable subroutine tracing. 1524 ! 1525 ! !/MGP Moving grid corrections. 1526 ! !/MGG Moving grid corrections. 1527 ! 1528 ! !/T Enable general test output. 1529 ! 1530 ! 10. Source code : 1531 ! 1532 !/ ------------------------------------------------------------------- / 1533 USE CONSTANTS 1534 ! 1535 USE W3TIMEMD, ONLY: DSEC21 1536 ! 1537 USE W3GDATMD, ONLY: NX, NY, NSEA, MAPSF, DTCFL, CLATS, & 1538 FLCX, FLCY, NK, NTH, DTH, XFR, & 1539 ECOS, ESIN, SIG, WDCG, WDTH, PFMOVE, & 1540 FLAGLL, DPDX, DPDY, DQDX, DQDY, GSQRT 1541 USE W3WDATMD, ONLY: TIME 1542 USE W3ADATMD, ONLY: NMX0, NMX1, NMX2, NMY0, NMY1, NMY2, NACT, & 1543 NCENT, MAPX2, MAPY2, MAPAXY, MAPCXY, & 1544 MAPTRN, CG, CX, CY, ATRNX, ATRNY, ITIME 1545 USE W3IDATMD, ONLY: FLCUR 1546 USE W3ODATMD, ONLY: NDSE, NDST, FLBPI, NBI, TBPI0, TBPIN, & 1547 ISBPI, BBPI0, BBPIN 1548 !/ 1549 IMPLICIT NONE 1550 !/ 1551 !/ ------------------------------------------------------------------- / 1552 !/ Parameter list 1553 !/ 1554 INTEGER, INTENT(IN) :: ISEA, MAPSTA(NY*NX), MAPFS(NY*NX) 1555 REAL, INTENT(IN) :: DTG, VGX, VGY 1556 REAL, INTENT(INOUT) :: CFLXYMAX 1557 !/ 1558 !/ ------------------------------------------------------------------- / 1559 !/ Local parameters 1560 !/ 1561 INTEGER :: ITH, IK, IXY, IP 1562 INTEGER :: IX, IY, IXC, IYC, IBI 1563 REAL :: CG0, CGA, CGN, CGX, CGY, CXC, CYC, & 1564 CXMIN, CXMAX, CYMIN, CYMAX 1565 REAL :: CGC, FGSE = 1. 1566 REAL :: FTH, FTHX, FTHY, FCG, FCGX, FCGY 1567 REAL :: CP, CQ Page 40 Source Listing W3CFLXY 2014-09-16 16:49 w3pro3md.f90 1568 !/ 1569 !/ Automatic work arrays 1570 !/ 1571 REAL :: VLCFLX, VLCFLY 1572 REAL :: CXTOT, CYTOT 1573 !/ 1574 !/ ------------------------------------------------------------------- / 1575 !/ 1576 ! 1577 ! 1. Preparations --------------------------------------------------- * 1578 ! 1.a Set constants 1579 ! 1580 CFLXYMAX=0. 1581 IX = MAPSF(ISEA,1) 1582 IY = MAPSF(ISEA,2) 1583 IXY = MAPSF(ISEA,3) 1584 DO IK=1,NK 1585 DO ITH=1,NTH 1586 CXTOT = ECOS(ITH) * CG(IK,ISEA) / CLATS(ISEA) 1587 CYTOT = ESIN(ITH) * CG(IK,ISEA) 1588 1589 1590 IF ( FLCUR ) THEN 1591 CXTOT = CXTOT + CX(ISEA)/CLATS(ISEA) 1592 CYTOT = CYTOT + CY(ISEA) 1593 END IF 1594 1595 CP = CXTOT*DPDX(IY,IX) + CYTOT*DPDY(IY,IX) 1596 CQ = CXTOT*DQDX(IY,IX) + CYTOT*DQDY(IY,IX) 1597 VLCFLX = CP*DTG 1598 VLCFLY = CQ*DTG 1599 CFLXYMAX = MAX(VLCFLX,VLCFLY,CFLXYMAX) 1600 END DO 1601 END DO 1602 1603 RETURN 1604 !/ 1605 !/ End of W3XYCFL ----------------------------------------------------- / 1606 !/ 1607 END SUBROUTINE W3CFLXY Page 41 Source Listing W3CFLXY 2014-09-16 16:49 Entry Points w3pro3md.f90 ENTRY POINTS Name w3pro3md_mp_w3cflxy_ SYMBOL CROSS REFERENCE Name Object Declared Type Bytes Dimen Elements Attributes References ATRNX Local 1544 R(4) 4 2 1 PTR 1544 ATRNY Local 1544 R(4) 4 2 1 PTR 1544 BBPI0 Local 1547 R(4) 4 2 1 PTR 1547 BBPIN Local 1547 R(4) 4 2 1 PTR 1547 CFLXYMAX Dummy 1455 R(4) 4 scalar ARG,INOUT 1580,1599 CG Local 1544 R(4) 4 2 1 PTR 1544,1586,1587 CG0 Local 1563 R(4) 4 scalar CGA Local 1563 R(4) 4 scalar CGC Local 1565 R(4) 4 scalar CGN Local 1563 R(4) 4 scalar CGX Local 1563 R(4) 4 scalar CGY Local 1563 R(4) 4 scalar CLATS Local 1537 R(4) 4 1 1 PTR 1537,1586,1591 CONSTANTS Module 1533 1533 CP Local 1567 R(4) 4 scalar 1595,1597 CQ Local 1567 R(4) 4 scalar 1596,1598 CX Local 1544 R(4) 4 1 1 PTR 1544,1591 CXC Local 1563 R(4) 4 scalar CXMAX Local 1564 R(4) 4 scalar CXMIN Local 1564 R(4) 4 scalar CXTOT Local 1572 R(4) 4 scalar 1586,1591,1595,1596 CY Local 1544 R(4) 4 1 1 PTR 1544,1592 CYC Local 1563 R(4) 4 scalar CYMAX Local 1564 R(4) 4 scalar CYMIN Local 1564 R(4) 4 scalar CYTOT Local 1572 R(4) 4 scalar 1587,1592,1595,1596 DPDX Local 1540 R(4) 4 2 1 PTR 1540,1595 DPDY Local 1540 R(4) 4 2 1 PTR 1540,1595 DQDX Local 1540 R(4) 4 2 1 PTR 1540,1596 DQDY Local 1540 R(4) 4 2 1 PTR 1540,1596 DSEC21 Func 1535 R(4) 4 scalar 1535 DTCFL Local 1537 R(4) 4 scalar PTR 1537 DTG Dummy 1455 R(4) 4 scalar ARG,IN 1597,1598 DTH Local 1538 R(4) 4 scalar PTR 1538 ECOS Local 1539 R(4) 4 1 1 PTR 1539,1586 ESIN Local 1539 R(4) 4 1 1 PTR 1539,1587 FCG Local 1566 R(4) 4 scalar FCGX Local 1566 R(4) 4 scalar FCGY Local 1566 R(4) 4 scalar FGSE Local 1565 R(4) 4 scalar 1565 FLAGLL Local 1540 L(4) 4 scalar 1540 FLBPI Local 1546 L(4) 4 scalar PTR 1546 FLCUR Local 1545 L(4) 4 scalar PTR 1545,1590 FLCX Local 1538 L(4) 4 scalar PTR 1538 Page 42 Source Listing W3CFLXY 2014-09-16 16:49 Symbol Table w3pro3md.f90 Name Object Declared Type Bytes Dimen Elements Attributes References FLCY Local 1538 L(4) 4 scalar PTR 1538 FTH Local 1566 R(4) 4 scalar FTHX Local 1566 R(4) 4 scalar FTHY Local 1566 R(4) 4 scalar GSQRT Local 1540 R(4) 4 2 1 PTR 1540 IBI Local 1562 I(4) 4 scalar IK Local 1561 I(4) 4 scalar 1584,1586,1587 IP Local 1561 I(4) 4 scalar ISBPI Local 1547 I(4) 4 1 1 PTR 1547 ISEA Dummy 1455 I(4) 4 scalar ARG,IN 1581,1582,1583,1586,1587,1591,1592 ITH Local 1561 I(4) 4 scalar 1585,1586,1587 ITIME Local 1544 I(4) 4 scalar PTR 1544 IX Local 1562 I(4) 4 scalar 1581,1595,1596 IXC Local 1562 I(4) 4 scalar IXY Local 1561 I(4) 4 scalar 1583 IY Local 1562 I(4) 4 scalar 1582,1595,1596 IYC Local 1562 I(4) 4 scalar MAPAXY Local 1543 I(4) 4 1 1 PTR 1543 MAPCXY Local 1543 I(4) 4 1 1 PTR 1543 MAPFS Dummy 1455 I(4) 4 1 0 ARG,IN MAPSF Local 1537 I(4) 4 2 1 PTR 1537,1581,1582,1583 MAPSTA Dummy 1455 I(4) 4 1 0 ARG,IN MAPTRN Local 1544 L(4) 4 1 1 PTR 1544 MAPX2 Local 1543 I(4) 4 1 1 PTR 1543 MAPY2 Local 1543 I(4) 4 1 1 PTR 1543 MAX Func 1599 scalar 1599 NACT Local 1542 I(4) 4 scalar PTR 1542 NBI Local 1546 I(4) 4 scalar PTR 1546 NCENT Local 1543 I(4) 4 scalar PTR 1543 NDSE Local 1546 I(4) 4 scalar PTR 1546 NDST Local 1546 I(4) 4 scalar PTR 1546 NK Local 1538 I(4) 4 scalar PTR 1538,1584 NMX0 Local 1542 I(4) 4 scalar PTR 1542 NMX1 Local 1542 I(4) 4 scalar PTR 1542 NMX2 Local 1542 I(4) 4 scalar PTR 1542 NMY0 Local 1542 I(4) 4 scalar PTR 1542 NMY1 Local 1542 I(4) 4 scalar PTR 1542 NMY2 Local 1542 I(4) 4 scalar PTR 1542 NSEA Local 1537 I(4) 4 scalar PTR 1537 NTH Local 1538 I(4) 4 scalar PTR 1538,1585 NX Local 1537 I(4) 4 scalar PTR 1537,1554 NY Local 1537 I(4) 4 scalar PTR 1537,1554 PFMOVE Local 1539 R(4) 4 scalar PTR 1539 SIG Local 1539 R(4) 4 1 1 PTR 1539 TBPI0 Local 1546 I(4) 4 1 1 PTR 1546 TBPIN Local 1546 I(4) 4 1 1 PTR 1546 TIME Local 1541 I(4) 4 1 1 PTR 1541 VGX Dummy 1455 R(4) 4 scalar ARG,IN VGY Dummy 1455 R(4) 4 scalar ARG,IN VLCFLX Local 1571 R(4) 4 scalar 1597,1599 VLCFLY Local 1571 R(4) 4 scalar 1598,1599 W3ADATMD Module 1542 1542 W3CFLXY Subr 1455 W3GDATMD Module 1537 1537 W3IDATMD Module 1545 1545 Page 43 Source Listing W3CFLXY 2014-09-16 16:49 Symbol Table w3pro3md.f90 Name Object Declared Type Bytes Dimen Elements Attributes References W3ODATMD Module 1546 1546 W3TIMEMD Module 1535 1535 W3WDATMD Module 1541 1541 WDCG Local 1539 R(4) 4 scalar PTR 1539 WDTH Local 1539 R(4) 4 scalar PTR 1539 XFR Local 1538 R(4) 4 scalar PTR 1538 Page 44 Source Listing W3CFLXY 2014-09-16 16:49 w3pro3md.f90 1608 1609 !/ 1610 !/ End of module W3PRO3MD -------------------------------------------- / 1611 !/ 1612 END MODULE W3PRO3MD SYMBOL CROSS REFERENCE Name Object Declared Type Bytes Dimen Elements Attributes References W3PRO3MD Module 2 Page 45 Source Listing W3CFLXY 2014-09-16 16:49 Subprograms/Common Blocks w3pro3md.f90 SUBPROGRAMS/COMMON BLOCKS Name Object Declared Type Bytes Dimen Elements Attributes References W3CFLXY Subr 1455 W3KTP3 Subr 1107 W3MAP3 Subr 112 W3MAPT Subr 393 W3PRO3MD Module 2 W3XYP3 Subr 484 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 cc_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 _OPENMP=201107 -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 Page 46 Source Listing W3CFLXY 2014-09-16 16:49 w3pro3md.f90 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 -openmp -O2 no -pad_source -real_size 32 no -recursive -reentrancy threaded 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 : /usrx/local/intel/composerxe/tbb/include/,/usr/include/,./,/usrx/local/intel/impi/4.0.3.008/intel64/include/, /usrx/local/intel/impi/4.0.3.008/intel64/include/,/usrx/local/intel/composerxe/mkl/include/,/usrx/local/intel/composerxe/tbb/include/, /gpfs/gp1/usrx/local/intel/composer_xe_2011_sp1.11.339/compiler/include/intel64/,/gpfs/gp1/usrx/local/intel/composer_xe_2011_sp1.11.339/compiler/include/, /usr/local/include/,/usr/lib/gcc/x86_64-redhat-linux/4.4.7/include/,/usr/include/,/usr/include/ -list filename : w3pro3md.lst -o filename : none COMPILER: Intel(R) Fortran 12.1-2100