Page 1 Source Listing W3UCUR 2014-09-16 16:49 w3updtmd.f90 1 !/ ------------------------------------------------------------------- / 2 MODULE W3UPDTMD 3 !/ 4 !/ +-----------------------------------+ 5 !/ | WAVEWATCH III NOAA/NCEP | 6 !/ | H. L. Tolman | 7 !/ | FORTRAN 90 | 8 !/ | Last update : 13-Nov-2013 | 9 !/ +-----------------------------------+ 10 !/ 11 !/ 21-Jan-2000 : Origination. ( version 2.00 ) 12 !/ 24-Jan-2001 : Flat grid version. ( version 2.06 ) 13 !/ 02-Apr-2001 : Adding sub-grid obstacles. ( version 2.10 ) 14 !/ 18-May-2001 : Clean up and bug fixes. ( version 2.11 ) 15 !/ 11-Jan-2002 : Sub-grid ice. ( version 2.15 ) 16 !/ 30-Apr-2002 : Water level fixes. ( version 2.20 ) 17 !/ 13-Nov-2002 : Add stress vector. ( version 3.00 ) 18 !/ 26-Dec-2002 : Moving grid wind correction. ( version 3.02 ) 19 !/ 15-Dec-2004 : Multiple grid version. ( version 3.06 ) 20 !/ 15-Jul-2005 : Adding MAPST2. ( version 3.07 ) 21 !/ 07-Sep-2005 : Upgrading W3UBPT. ( version 3.08 ) 22 !/ 04-Jul-2006 : Consolidate stress arrays. ( version 3.09 ) 23 !/ 11-Jan-2007 : Clean-up W3UTRN boundary points. ( version 3.10 ) 24 !/ 11-May-2007 : Adding NTPROC/NAPROC separation. ( version 3.11 ) 25 !/ 29-May-2009 : Preparing distribution version. ( version 3.14 ) 26 !/ 30-Oct-2009 : Implement run-time grid selection. ( version 3.14 ) 27 !/ (W. E. Rogers & T. J. Campbell, NRL) 28 !/ 30-Oct-2009 : Implement curvilinear grid type. ( version 3.14 ) 29 !/ (W. E. Rogers & T. J. Campbell, NRL) 30 !/ 17-Aug-2010 : ABPI0-N(:,0) init. bug fix. ( version 3.14 ) 31 !/ 06-Dec-2010 : Change from GLOBAL (logical) to ICLOSE (integer) to 32 !/ specify index closure for a grid. ( version 3.14 ) 33 !/ (T. J. Campbell, NRL) 34 !/ 05-Apr-2011 : Place holder for XGR in UNGTYPE ( version 4.04 ) 35 !/ (A. Roland/F. Ardhuin) 36 !/ 13-Mar-2012 : Add initialization of UST on re- ( version 4.07 ) 37 !/ activation of grid point. 38 !/ 06-Jun-2012 : Porting bugfixes from 3.14 to 4.07 ( version 4.07 ) 39 !/ 12-Jun-2012 : Add /RTD option or rotated grid option. 40 !/ (Jian-Guo Li) ( version 4.07 ) 41 !/ 26-Sep-2012 : Adding update from tidal analysis ( version 4.08 ) 42 !/ (F. Ardhuin) 43 !/ 16-Sep-2013 : Add Arctic part for SMC grid. ( version 4.11 ) 44 !/ 11-Nov-2013 : SMC and rotated grid incorporated in the main 45 !/ trunk ( version 4.13 ) 46 !/ 13-Nov-2013 : Moved reflection from ww3_grid.ftn ( version 4.13 ) 47 !/ 48 !/ Copyright 2009-2013 National Weather Service (NWS), 49 !/ National Oceanic and Atmospheric Administration. All rights 50 !/ reserved. WAVEWATCH III is a trademark of the NWS. 51 !/ No unauthorized use without permission. 52 !/ 53 ! 1. Purpose : 54 ! 55 ! Bundles all input updating routines for WAVEWATCH III. 56 ! 57 ! 2. Variables and types : Page 2 Source Listing W3UCUR 2014-09-16 16:49 w3updtmd.f90 58 ! 59 ! 3. Subroutines and functions : 60 ! 61 ! Name Type Scope Description 62 ! ---------------------------------------------------------------- 63 ! W3UCUR Subr. Public Update current fields. 64 ! W3UWND Subr. Public Update wind fields. 65 ! W3UINI Subr. Public Update initial conditions. 66 ! W3UBPT Subr. Public Update boundary conditions. 67 ! W3UICE Subr. Public Update ice concentrations. 68 ! W3ULEV Subr. Public Update water levels. 69 ! W3UTRN Subr. Public Update cell boundary transparancies. 70 ! W3DZXY Subr. Public Calculate derivatives of a field. 71 ! ---------------------------------------------------------------- 72 ! 73 ! 4. Subroutines and functions used : 74 ! 75 ! Name Type Module Description 76 ! ---------------------------------------------------------------- 77 ! DSEC21 Func. W3TIMEMD Difference in time. 78 ! STRACE Subr. W3SERVMD Subroutine tracing. 79 ! EXTCDE Subr. W3SERVMD Exit program with error code. 80 ! PRTBLK Subr. W3ARRYMD Print plot output. 81 ! PRT2DS Subr. W3ARRYMD Print plot output. 82 ! ---------------------------------------------------------------- 83 ! 84 ! 5. Remarks : 85 ! 86 ! 6. Switches : 87 ! 88 ! !/SHRD Switch for shared / distributed memory architecture. 89 ! !/DIST Id. 90 ! 91 ! !/OMP1 OpenMP compiler directives. 92 ! 93 ! !/CRT1 Linear current interpolation. 94 ! !/CRT2 Quasi-quadratic current interpolation. 95 ! 96 ! !/WNT0 No wind interpolation. 97 ! !/WNT1 Linear wind interpolation. 98 ! !/WNT2 Energy conservation in wind interpolation. 99 ! 100 ! !/RWND Use wind speeds relative to currents. 101 ! 102 ! !/STAB2 Calculate effective wind speed factor for stability 103 ! to be used with !/ST2. 104 ! 105 ! !/S Enable subroutine tracing. 106 ! !/Tn Test output 107 ! 108 ! 7. Source code : 109 ! 110 !/ ------------------------------------------------------------------- / 111 USE CONSTANTS 112 USE W3ODATMD, ONLY: NDSE, NDST, NAPROC, IAPROC, NAPERR 113 USE W3TIMEMD, ONLY: DSEC21 114 !/ Page 3 Source Listing W3UCUR 2014-09-16 16:49 w3updtmd.f90 115 !/ ------------------------------------------------------------------- / 116 !/ 117 CONTAINS 118 !/ ------------------------------------------------------------------- / 119 SUBROUTINE W3UCUR ( FLFRST ) 120 !/ 121 !/ +-----------------------------------+ 122 !/ | WAVEWATCH III NOAA/NCEP | 123 !/ | H. L. Tolman | 124 !/ | FORTRAN 90 | 125 !/ | Last update : 15-Dec-2004 | 126 !/ +-----------------------------------+ 127 !/ 128 !/ 09-Dec-1996 : Final FORTRAN 77 ( version 1.18 ) 129 !/ 20-Dec-1999 : Upgrade to FORTRAN 90 ( version 2.00 ) 130 !/ 15-Dec-2004 : Multiple grid version. ( version 3.06 ) 131 !/ 132 ! 1. Purpose : 133 ! 134 ! Interpolate the current field to the present time. 135 ! 136 ! 2. Method : 137 ! 138 ! Linear interpolation of speed and direction, with optionally 139 ! a correction to get approximate quadratic interpolation of speed 140 ! only. 141 ! 142 ! 3. Parameters : 143 ! 144 ! Parameter list 145 ! ---------------------------------------------------------------- 146 ! FLFRST Log. I Flag for first pass through routine. 147 ! ---------------------------------------------------------------- 148 ! 149 ! 4. Subroutines used : 150 ! 151 ! See module documentation. 152 ! 153 ! 5. Called by : 154 ! 155 ! Name Type Module Description 156 ! ---------------------------------------------------------------- 157 ! W3WAVE Subr. W3WAVEMD Actual wave model routine. 158 ! ---------------------------------------------------------------- 159 ! 160 ! 6. Error messages : 161 ! 162 ! None. 163 ! 164 ! 7. Remarks : 165 ! 166 ! - Only currents at sea points are considered. 167 ! - Time ranges checked in W3WAVE. 168 ! - Currents are stored by components to save on the use of 169 ! SIN and COS functions. The actual interpolations, however 170 ! are by absolute value and direction. 171 ! Page 4 Source Listing W3UCUR 2014-09-16 16:49 w3updtmd.f90 172 ! 8. Structure : 173 ! 174 ! -------------------------------------- 175 ! 1. Prepare auxiliary arrays. 176 ! 2. Calculate interpolation factors. 177 ! 3. Get actual winds. 178 ! -------------------------------------- 179 ! 180 ! 9. Switches : 181 ! 182 ! !/CRT1 Linear current interpolation. 183 ! !/CRT2 Quasi-quadratic current interpolation. 184 ! 185 ! !/S Enable subroutine tracing. 186 ! !/T Test output. 187 ! 188 ! 10. Source code : 189 ! 190 !/ ------------------------------------------------------------------- / 191 USE W3GDATMD, ONLY: NX, NY, NSEA, MAPSF 192 USE W3WDATMD, ONLY: TIME 193 USE W3ADATMD, ONLY: CX, CY, CA0, CAI, CD0, CDI 194 USE W3IDATMD, ONLY: TC0, CX0, CY0, TCN, CXN, CYN 195 ! 196 IMPLICIT NONE 197 !/ 198 !/ ------------------------------------------------------------------- / 199 !/ Parameter list 200 !/ 201 LOGICAL, INTENT(IN) :: FLFRST 202 !/ 203 !/ ------------------------------------------------------------------- / 204 !/ 205 INTEGER :: ISEA, IX, IY 206 REAL :: D0, DN, DD, DTT, DT0, RD, CABS, CDIR 207 !/ 208 !/ ------------------------------------------------------------------- / 209 !/ 210 ! 211 ! 1. Prepare auxiliary arrays 212 ! 213 IF ( FLFRST ) THEN 214 DO ISEA=1, NSEA 215 IX = MAPSF(ISEA,1) 216 IY = MAPSF(ISEA,2) 217 CA0(ISEA) = SQRT ( CX0(IX,IY)**2 + CY0(IX,IY)**2 ) 218 CAI(ISEA) = SQRT ( CXN(IX,IY)**2 + CYN(IX,IY)**2 ) 219 IF ( CA0(ISEA) .GT. 1.E-7) THEN 220 D0 = MOD ( TPI+ATAN2(CY0(IX,IY),CX0(IX,IY)) , TPI ) 221 ELSE 222 D0 = 0 223 END IF 224 IF ( CAI(ISEA) .GT. 1.E-7) THEN 225 DN = MOD ( TPI+ATAN2(CYN(IX,IY),CXN(IX,IY)) , TPI ) 226 ELSE 227 DN = D0 228 END IF Page 5 Source Listing W3UCUR 2014-09-16 16:49 w3updtmd.f90 229 IF ( CA0(ISEA) .GT. 1.E-7) THEN 230 CD0(ISEA) = D0 231 ELSE 232 CD0(ISEA) = DN 233 END IF 234 DD = DN - CD0(ISEA) 235 IF (ABS(DD).GT.PI) DD = DD - TPI*SIGN(1.,DD) 236 CDI(ISEA) = DD 237 CAI(ISEA) = CAI(ISEA) - CA0(ISEA) 238 END DO 239 END IF 240 ! 241 ! 2. Calculate interpolation factor 242 ! 243 DTT = DSEC21 ( TC0, TCN ) 244 DT0 = DSEC21 ( TC0, TIME ) 245 ! 246 RD = DT0 / MAX ( 1.E-7 , DTT ) 247 ! 248 249 250 ! 251 ! 3. Actual currents for all grid points 252 ! 253 DO ISEA=1, NSEA 254 255 256 CABS = CA0(ISEA) + RD * CAI(ISEA) 257 CDIR = CD0(ISEA) + RD * CDI(ISEA) 258 CX(ISEA) = CABS * COS(CDIR) 259 CY(ISEA) = CABS * SIN(CDIR) 260 ! 261 END DO 262 ! 263 RETURN 264 ! 265 ! Formats 266 ! 267 !/ 268 !/ End of W3UCUR ----------------------------------------------------- / 269 !/ 270 END SUBROUTINE W3UCUR Page 6 Source Listing W3UCUR 2014-09-16 16:49 Entry Points w3updtmd.f90 ENTRY POINTS Name w3updtmd_mp_w3ucur_ SYMBOL CROSS REFERENCE Name Object Declared Type Bytes Dimen Elements Attributes References ABS Func 235 scalar 235 ATAN2 Func 220 scalar 220,225 CA0 Local 193 R(4) 4 1 1 PTR 193,217,219,229,237,256 CABS Local 206 R(4) 4 scalar 256,258,259 CAI Local 193 R(4) 4 1 1 PTR 193,218,224,237,256 CD0 Local 193 R(4) 4 1 1 PTR 193,230,232,234,257 CDI Local 193 R(4) 4 1 1 PTR 193,236,257 CDIR Local 206 R(4) 4 scalar 257,258,259 COS Func 258 scalar 258 CX Local 193 R(4) 4 1 1 PTR 193,258 CX0 Local 194 R(4) 4 2 1 PTR 194,217,220 CXN Local 194 R(4) 4 2 1 PTR 194,218,225 CY Local 193 R(4) 4 1 1 PTR 193,259 CY0 Local 194 R(4) 4 2 1 PTR 194,217,220 CYN Local 194 R(4) 4 2 1 PTR 194,218,225 D0 Local 206 R(4) 4 scalar 220,222,227,230 DD Local 206 R(4) 4 scalar 234,235,236 DN Local 206 R(4) 4 scalar 225,227,232,234 DSEC21 Func 243 R(4) 4 scalar 113,243,244,414,415 DT0 Local 206 R(4) 4 scalar 244,246 DTT Local 206 R(4) 4 scalar 243,246 FLFRST Dummy 119 L(4) 4 scalar ARG,IN 213 ISEA Local 205 I(4) 4 scalar 214,215,216,217,218,219,224,229,23 0,232,234,236,237,253,256,257,258, 259 IX Local 205 I(4) 4 scalar 215,217,218,220,225 IY Local 205 I(4) 4 scalar 216,217,218,220,225 MAPSF Local 191 I(4) 4 2 1 PTR 191,215,216 MAX Func 246 scalar 246 MOD Func 220 scalar 220,225 NSEA Local 191 I(4) 4 scalar PTR 191,214,253 NX Local 191 I(4) 4 scalar PTR 191 NY Local 191 I(4) 4 scalar PTR 191 PI Param 235 R(4) 4 scalar 235,404 RD Local 206 R(4) 4 scalar 246,256,257 SIGN Func 235 scalar 235 SIN Func 259 scalar 259 SQRT Func 217 scalar 217,218 TC0 Local 194 I(4) 4 1 1 PTR 194,243,244 TCN Local 194 I(4) 4 1 1 PTR 194,243 TIME Local 192 I(4) 4 1 1 PTR 192,244 TPI Param 220 R(4) 4 scalar 220,225,235,389,394,404 W3ADATMD Module 193 193 W3GDATMD Module 191 191 Page 7 Source Listing W3UCUR 2014-09-16 16:49 Symbol Table w3updtmd.f90 Name Object Declared Type Bytes Dimen Elements Attributes References W3IDATMD Module 194 194 W3UCUR Subr 119 W3WDATMD Module 192 192 Page 8 Source Listing W3UCUR 2014-09-16 16:49 w3updtmd.f90 271 !/ ------------------------------------------------------------------- / 272 SUBROUTINE W3UWND ( FLFRST, VGX, VGY ) 273 !/ 274 !/ +-----------------------------------+ 275 !/ | WAVEWATCH III NOAA/NCEP | 276 !/ | H. L. Tolman | 277 !/ | FORTRAN 90 | 278 !/ | Last update : 04-Jul-2006 | 279 !/ +-----------------------------------+ 280 !/ 281 !/ 03-Dec-1998 : Final FORTRAN 77 ( version 1.18 ) 282 !/ 20-Dec-1999 : Upgrade to FORTRAN 90 ( version 2.00 ) 283 !/ 13-Nov-2002 : Add stress vector. ( version 3.00 ) 284 !/ 26-Dec-2002 : Moving grid wind correction. ( version 3.02 ) 285 !/ 15-Dec-2004 : Multiple grid version. ( version 3.06 ) 286 !/ 04-Jul-2006 : Consolidate stress arrays. ( version 3.09 ) 287 !/ 16-Sep-2013 : Rotating wind for Arctic part. ( version 4.11 ) 288 !/ 289 ! 1. Purpose : 290 ! 291 ! Interpolate wind fields to the given time. 292 ! 293 ! 2. Method : 294 ! 295 ! Linear interpolation of wind speed and direction, with a simple 296 ! correction to obtain quasi-conservation of energy. 297 ! 298 ! 3. Parameters : 299 ! 300 ! Parameter list 301 ! ---------------------------------------------------------------- 302 ! FLFRST Log. I Flag for first pass through routine. 303 ! VGX/Y Real I Grid velocity (!/MGW) 304 ! ---------------------------------------------------------------- 305 ! 306 ! 4. Subroutines used : 307 ! 308 ! See module documentation. 309 ! 310 ! 5. Called by : 311 ! 312 ! Name Type Module Description 313 ! ---------------------------------------------------------------- 314 ! W3WAVE Subr. W3WAVEMD Actual wave model routine. 315 ! ---------------------------------------------------------------- 316 ! 317 ! 6. Error messages : 318 ! 319 ! None. 320 ! 321 ! 7. Remarks : 322 ! 323 ! - Only winds over sea points are considered. 324 ! - Time ranges checked in W3WAVE. 325 ! 326 ! 8. Structure : 327 ! Page 9 Source Listing W3UWND 2014-09-16 16:49 w3updtmd.f90 328 ! -------------------------------------- 329 ! 1. Prepare auxiliary arrays. 330 ! 2. Calculate interpolation factors 331 ! 3. Get actual winds 332 ! 4. Correct for currents 333 ! 5. Convert to stresses 334 ! 6. Stability correction 335 ! -------------------------------------- 336 ! 337 ! 9. Switches : 338 ! 339 ! !/OMP1 OpenMP compiler directives. 340 ! 341 ! !/WNT0 No wind interpolation. 342 ! !/WNT1 Linear wind interpolation. 343 ! !/WNT2 Energy conservation in wind interpolation. 344 ! 345 ! !/RWND Use wind speeds relative to currents. 346 ! !/MGW Moving grid wind correction. 347 ! 348 ! !/STAB2 Calculate effective wind speed factor for stability 349 ! to be used with !/ST2. 350 ! 351 ! !/S Enable subroutine tracing. 352 ! !/T Test output. 353 ! 354 ! 10. Source code : 355 ! 356 !/ ------------------------------------------------------------------- / 357 USE W3GDATMD, ONLY: NX, NY, NSEA, MAPSF 358 USE W3WDATMD, ONLY: TIME, ASF 359 USE W3ADATMD, ONLY: DW, CX, CY, UA, UD, U10, U10D, AS, & 360 UA0, UAI, UD0, UDI, AS0, ASI 361 USE W3IDATMD, ONLY: TW0, WX0, WY0, DT0, TWN, WXN, WYN, DTN, FLCUR 362 !/ 363 IMPLICIT NONE 364 !/ 365 !/ ------------------------------------------------------------------- / 366 !/ Parameter list 367 !/ 368 REAL, INTENT(IN) :: VGX, VGY 369 LOGICAL, INTENT(IN) :: FLFRST 370 !/ 371 !/ ------------------------------------------------------------------- / 372 !/ 373 INTEGER :: ISEA, IX, IY 374 REAL :: D0, DN, DD, DTT, DT00, RD, UI2, & 375 UXR, UYR 376 !/ 377 !/ ------------------------------------------------------------------- / 378 !/ 379 ! 380 ! 1. Prepare auxiliary arrays 381 ! 382 IF ( FLFRST ) THEN 383 DO ISEA=1, NSEA 384 IX = MAPSF(ISEA,1) Page 10 Source Listing W3UWND 2014-09-16 16:49 w3updtmd.f90 385 IY = MAPSF(ISEA,2) 386 UA0(ISEA) = SQRT ( WX0(IX,IY)**2 + WY0(IX,IY)**2 ) 387 UAI(ISEA) = SQRT ( WXN(IX,IY)**2 + WYN(IX,IY)**2 ) 388 IF ( UA0(ISEA) .GT. 1.E-7) THEN 389 D0 = MOD ( TPI+ATAN2(WY0(IX,IY),WX0(IX,IY)) , TPI ) 390 ELSE 391 D0 = 0 392 END IF 393 IF ( UAI(ISEA) .GT. 1.E-7) THEN 394 DN = MOD ( TPI+ATAN2(WYN(IX,IY),WXN(IX,IY)) , TPI ) 395 ELSE 396 DN = D0 397 END IF 398 IF ( UA0(ISEA) .GT. 1.E-7) THEN 399 UD0(ISEA) = D0 400 ELSE 401 UD0(ISEA) = DN 402 END IF 403 DD = DN - UD0(ISEA) 404 IF (ABS(DD).GT.PI) DD = DD - TPI*SIGN(1.,DD) 405 UDI(ISEA) = DD 406 UAI(ISEA) = UAI(ISEA) - UA0(ISEA) 407 AS0(ISEA) = DT0(IX,IY) 408 ASI(ISEA) = DTN(IX,IY) - DT0(IX,IY) 409 END DO 410 END IF 411 ! 412 ! 2. Calculate interpolation factor 413 ! 414 DTT = DSEC21 ( TW0, TWN ) 415 DT00 = DSEC21 ( TW0, TIME ) 416 ! 417 RD = DT00 / MAX ( 1.E-7 , DTT ) 418 ! 419 ! 3. Actual wind for all grid points 420 ! 421 DO ISEA=1, NSEA 422 ! 423 UA(ISEA) = UA0(ISEA) + RD * UAI(ISEA) 424 UD(ISEA) = UD0(ISEA) + RD * UDI(ISEA) 425 ! 426 AS(ISEA) = AS0(ISEA) + RD * ASI(ISEA) 427 ! IF (UA(ISEA).NE.UA(ISEA)) WRITE(6,*) 'BUG WIND:',ISEA,UA(ISEA),MAPSF(ISEA,1), MAPSF(ISEA,2),UA0(ISEA),RD,UAI(ISEA) 428 ! IF (UD(ISEA).NE.UD(ISEA)) WRITE(6,*) 'BUG WIN2:',ISEA,UD(ISEA),MAPSF(ISEA,1), MAPSF(ISEA,2) 429 ! 430 END DO 431 ! 432 ! 4. Correct for currents and grid motion 433 ! 434 DO ISEA=1, NSEA 435 U10 (ISEA) = MAX ( UA(ISEA) , 0.001 ) 436 U10D(ISEA) = UD(ISEA) 437 END DO 438 ! 439 ! 5. Stability correction ( !/STAB2 ) 440 ! Original settings : 441 ! Page 11 Source Listing W3UWND 2014-09-16 16:49 w3updtmd.f90 442 ! SHSTAB = 1.4 443 ! OFSTAB = -0.01 444 ! CCNG = -0.1 445 ! CCPS = 0.1 446 ! FFNG = -150. 447 ! FFPS = 150. 448 ! 449 RETURN 450 ! 451 ! Formats 452 ! 453 !/ 454 !/ End of W3UWND ----------------------------------------------------- / 455 !/ 456 END SUBROUTINE W3UWND ENTRY POINTS Name w3updtmd_mp_w3uwnd_ SYMBOL CROSS REFERENCE Name Object Declared Type Bytes Dimen Elements Attributes References ABS Func 404 scalar 404 AS Local 359 R(4) 4 1 1 PTR 359,426 AS0 Local 360 R(4) 4 1 1 PTR 360,407,426 ASF Local 358 R(4) 4 1 1 PTR 358 ASI Local 360 R(4) 4 1 1 PTR 360,408,426 ATAN2 Func 389 scalar 389,394 CX Local 359 R(4) 4 1 1 PTR 359 CY Local 359 R(4) 4 1 1 PTR 359 D0 Local 374 R(4) 4 scalar 389,391,396,399 DD Local 374 R(4) 4 scalar 403,404,405 DN Local 374 R(4) 4 scalar 394,396,401,403 DT0 Local 361 R(4) 4 2 1 PTR 361,407,408 DT00 Local 374 R(4) 4 scalar 415,417 DTN Local 361 R(4) 4 2 1 PTR 361,408 DTT Local 374 R(4) 4 scalar 414,417 DW Local 359 R(4) 4 1 1 PTR 359 FLCUR Local 361 L(4) 4 scalar PTR 361 FLFRST Dummy 272 L(4) 4 scalar ARG,IN 382 ISEA Local 373 I(4) 4 scalar 383,384,385,386,387,388,393,398,39 9,401,403,405,406,407,408,421,423, 424,426,434,435,436 IX Local 373 I(4) 4 scalar 384,386,387,389,394,407,408 IY Local 373 I(4) 4 scalar 385,386,387,389,394,407,408 MAPSF Local 357 I(4) 4 2 1 PTR 357,384,385 MAX Func 417 scalar 417,435 MOD Func 389 scalar 389,394 NSEA Local 357 I(4) 4 scalar PTR 357,383,421,434 NX Local 357 I(4) 4 scalar PTR 357 NY Local 357 I(4) 4 scalar PTR 357 Page 12 Source Listing W3UWND 2014-09-16 16:49 Symbol Table w3updtmd.f90 Name Object Declared Type Bytes Dimen Elements Attributes References RD Local 374 R(4) 4 scalar 417,423,424,426 SIGN Func 404 scalar 404 SQRT Func 386 scalar 386,387 TIME Local 358 I(4) 4 1 1 PTR 358,415 TW0 Local 361 I(4) 4 1 1 PTR 361,414,415 TWN Local 361 I(4) 4 1 1 PTR 361,414 U10 Local 359 R(4) 4 1 1 PTR 359,435 U10D Local 359 R(4) 4 1 1 PTR 359,436 UA Local 359 R(4) 4 1 1 PTR 359,423,435 UA0 Local 360 R(4) 4 1 1 PTR 360,386,388,398,406,423 UAI Local 360 R(4) 4 1 1 PTR 360,387,393,406,423 UD Local 359 R(4) 4 1 1 PTR 359,424,436 UD0 Local 360 R(4) 4 1 1 PTR 360,399,401,403,424 UDI Local 360 R(4) 4 1 1 PTR 360,405,424 UI2 Local 374 R(4) 4 scalar UXR Local 375 R(4) 4 scalar UYR Local 375 R(4) 4 scalar VGX Dummy 272 R(4) 4 scalar ARG,IN VGY Dummy 272 R(4) 4 scalar ARG,IN W3ADATMD Module 359 359 W3GDATMD Module 357 357 W3IDATMD Module 361 361 W3UWND Subr 272 W3WDATMD Module 358 358 WX0 Local 361 R(4) 4 2 1 PTR 361,386,389 WXN Local 361 R(4) 4 2 1 PTR 361,387,394 WY0 Local 361 R(4) 4 2 1 PTR 361,386,389 WYN Local 361 R(4) 4 2 1 PTR 361,387,394 Page 13 Source Listing W3UWND 2014-09-16 16:49 w3updtmd.f90 457 !/ ------------------------------------------------------------------- / 458 SUBROUTINE W3UINI ( A ) 459 !/ 460 !/ +-----------------------------------+ 461 !/ | WAVEWATCH III NOAA/NCEP | 462 !/ | H. L. Tolman | 463 !/ | FORTRAN 90 | 464 !/ | Last update : 05-Apr-2011 | 465 !/ +-----------------------------------+ 466 !/ 467 !/ 19-Oct-1998 : Final FORTRAN 77 ( version 1.18 ) 468 !/ 20-Dec-1999 : Upgrade to FORTRAN 90 ( version 2.00 ) 469 !/ 24-Jan-2001 : Flat grid version. ( version 2.06 ) 470 !/ 18-May-2001 : Fix CG declaration. ( version 2.11 ) 471 !/ 15-Dec-2004 : Multiple grid version. ( version 3.06 ) 472 !/ 30-Oct-2009 : Implement run-time grid selection. ( version 3.14 ) 473 !/ (W. E. Rogers & T. J. Campbell, NRL) 474 !/ 30-Oct-2009 : Implement curvilinear grid type. ( version 3.14 ) 475 !/ (W. E. Rogers & T. J. Campbell, NRL) 476 !/ 30-Oct-2009 : Implement curvilinear grid type. ( version 3.14 ) 477 !/ 478 ! 1. Purpose : 479 ! 480 ! Initialize the wave field with fetch-limited spectra before the 481 ! actual calculation start. (Named as an update routine due to 482 ! placement in code.) 483 ! 484 ! 2. Method : 485 ! 486 ! Fetch-limited JONSWAP spectra with a cosine^2 directional 487 ! distribution and a mean direction taken from the wind. 488 ! 489 ! 3. Parameters : 490 ! 491 ! Parameter list 492 ! ---------------------------------------------------------------- 493 ! A R.A. O Action density spectra. 494 ! ---------------------------------------------------------------- 495 ! 496 ! 4. Subroutines used : 497 ! 498 ! See module documentation. 499 ! 500 ! 5. Called by : 501 ! 502 ! Name Type Module Description 503 ! ---------------------------------------------------------------- 504 ! W3WAVE Subr. W3WAVEMD Actual wave model routine. 505 ! ---------------------------------------------------------------- 506 ! 507 ! 6. Error messages : 508 ! 509 ! None. 510 ! 511 ! 7. Remarks : 512 ! 513 ! - Wind speeds filtered by U10MIN and U10MAX (DATA statements) Page 14 Source Listing W3UINI 2014-09-16 16:49 w3updtmd.f90 514 ! 515 ! 8. Structure : 516 ! 517 ! See source code. 518 ! 519 ! 9. Switches : 520 ! 521 ! !/SHRD Switch for shared / distributed memory architecture. 522 ! !/DIST Id. 523 ! 524 ! !/S Enable subroutine tracing. 525 ! !/T General test output. 526 ! !/T1 Parameters at grid points. 527 ! 528 ! 10. Source code : 529 ! 530 !/ ------------------------------------------------------------------- / 531 USE W3GDATMD, ONLY: NX, NY, NSEA, NSEAL, MAPSF, & 532 NK, NTH, TH, SIG, DTH, DSIP, UNGTYPE, & 533 RLGTYPE, CLGTYPE, GTYPE, FLAGLL, & 534 HPFAC, HQFAC 535 USE W3ADATMD, ONLY: U10, U10D, CG 536 ! 537 IMPLICIT NONE 538 !/ 539 !/ ------------------------------------------------------------------- / 540 !/ Parameter list 541 !/ 542 REAL, INTENT(OUT) :: A(NTH,NK,0:NSEAL) 543 !/ 544 !/ ------------------------------------------------------------------- / 545 !/ Local variables 546 !/ 547 INTEGER :: IX, IY, ISEA, JSEA, IK, ITH 548 REAL :: ALFA(NSEAL), FP(NSEAL), YLN(NSEAL), & 549 AA, BB, CC 550 REAL :: XGR, U10C, U10DIR, XSTAR, FSTAR, & 551 GAMMA, FR, D1(NTH), D1INT, F1, F2 552 REAL :: ETOT, E1I 553 REAL :: U10MIN = 1. 554 REAL :: U10MAX = 20. 555 !/ 556 !/ ------------------------------------------------------------------- / 557 !/ 558 ! 559 ! Pre-process JONSWAP data for all grid points ----------------------- * 560 ! 561 ! this is not clear what is going on betwen w3init and this ... 562 A(:,:,:)=0 563 DO JSEA=1, NSEAL 564 ISEA = IAPROC + (JSEA-1)*NAPROC 565 ! 566 IF (GTYPE.EQ.UNGTYPE) THEN 567 XGR=1. ! to be fixed later 568 ELSE 569 IX = MAPSF(ISEA,1) 570 IY = MAPSF(ISEA,2) Page 15 Source Listing W3UINI 2014-09-16 16:49 w3updtmd.f90 571 XGR = 0.5 * SQRT(HPFAC(IY,IX)**2+HQFAC(IY,IX)**2) 572 END IF 573 IF ( FLAGLL ) THEN 574 XGR = XGR * RADIUS * DERA 575 END IF 576 ! 577 U10C = MAX ( MIN(U10(ISEA),U10MAX) , U10MIN ) 578 ! 579 XSTAR = GRAV * XGR / U10C**2 580 FSTAR = 3.5 / XSTAR**(0.33) 581 GAMMA = MAX ( 1. , 7.0 / XSTAR**(0.143) ) 582 ! 583 ALFA(JSEA) = 0.076 / XSTAR**(0.22) 584 FP (JSEA) = FSTAR * GRAV / U10C 585 YLN (JSEA) = LOG ( GAMMA ) 586 ! 587 END DO 588 ! 589 ! 1-D spectrum at location ITH = NTH --------------------------------- * 590 ! 591 DO IK=1, NK 592 FR = SIG(IK) * TPIINV 593 DO JSEA=1, NSEAL 594 ! 595 !/ ----- INLINED EJ5P (REDUCED) -------------------------------------- / 596 ! 597 AA = ALFA(JSEA) * 0.06175/FR**5 598 BB = MAX( -50. , -1.25*(FP(JSEA)/FR)**4 ) 599 CC = MAX( -50. , -0.5*((FR-FP(JSEA))/(0.07*FP(JSEA)))**2 ) 600 A(NTH,IK,JSEA) & 601 = AA * EXP(BB + EXP(CC) * YLN(JSEA)) 602 ! 603 !/ ----- INLINED EJ5P (END) ------------------------------------------ / 604 ! 605 END DO 606 END DO 607 ! 608 ! Apply directional distribution ------------------------------------- * 609 ! 610 DO JSEA=1, NSEAL 611 ISEA = IAPROC + (JSEA-1)*NAPROC 612 ! 613 U10DIR = U10D(ISEA) 614 D1INT = 0. 615 ! 616 DO ITH=1, NTH 617 D1(ITH) = ( MAX ( 0. , COS(TH(ITH)-U10DIR) ) )**2 618 D1INT = D1INT + D1(ITH) 619 END DO 620 ! 621 D1INT = D1INT * DTH 622 F1 = TPIINV / D1INT 623 ! 624 DO IK=1, NK 625 F2 = F1 * A(NTH,IK,JSEA) * CG(IK,ISEA) / SIG(IK) 626 DO ITH=1, NTH 627 A(ITH,IK,JSEA) = F2 * D1(ITH) Page 16 Source Listing W3UINI 2014-09-16 16:49 w3updtmd.f90 628 END DO 629 END DO 630 ! 631 END DO 632 ! 633 ! Test output -------------------------------------------------------- * 634 ! 635 RETURN 636 ! 637 ! Formats 638 ! 639 !/ 640 !/ End of W3UINI ----------------------------------------------------- / 641 !/ 642 END SUBROUTINE W3UINI ENTRY POINTS Name w3updtmd_mp_w3uini_ SYMBOL CROSS REFERENCE Name Object Declared Type Bytes Dimen Elements Attributes References A Dummy 458 R(4) 4 3 0 ARG,OUT 562,600,625,627 AA Local 549 R(4) 4 scalar 597,601 ALFA Local 548 R(4) 4 1 0 583,597 BB Local 549 R(4) 4 scalar 598,601 CC Local 549 R(4) 4 scalar 599,601 CG Local 535 R(4) 4 2 1 PTR 535,625 CLGTYPE Param 533 I(4) 4 scalar 533 COS Func 617 scalar 617 D1 Local 551 R(4) 4 1 0 617,618,627 D1INT Local 551 R(4) 4 scalar 614,618,621,622 DERA Param 574 R(4) 4 scalar 574,1496,1497,1716 DSIP Local 532 R(4) 4 1 1 PTR 532 DTH Local 532 R(4) 4 scalar PTR 532,621 E1I Local 552 R(4) 4 scalar ETOT Local 552 R(4) 4 scalar EXP Func 601 scalar 601 F1 Local 551 R(4) 4 scalar 622,625 F2 Local 551 R(4) 4 scalar 625,627 FLAGLL Local 533 L(4) 4 scalar 533,573 FP Local 548 R(4) 4 1 0 584,598,599 FR Local 551 R(4) 4 scalar 592,597,598,599 FSTAR Local 550 R(4) 4 scalar 580,584 GAMMA Local 551 R(4) 4 scalar 581,585 GRAV Param 579 R(4) 4 scalar 579,584 GTYPE Local 533 I(4) 4 scalar PTR 533,566 HPFAC Local 534 R(4) 4 2 1 PTR 534,571 HQFAC Local 534 R(4) 4 2 1 PTR 534,571 IAPROC Local 564 I(4) 4 scalar PTR 112,564,611,880,909,926,1073,1079, 1139,1156,1173 Page 17 Source Listing W3UINI 2014-09-16 16:49 Symbol Table w3updtmd.f90 Name Object Declared Type Bytes Dimen Elements Attributes References IK Local 547 I(4) 4 scalar 591,592,600,624,625,627 ISEA Local 547 I(4) 4 scalar 564,569,570,577,611,613,625 ITH Local 547 I(4) 4 scalar 616,617,618,626,627 IX Local 547 I(4) 4 scalar 569,571 IY Local 547 I(4) 4 scalar 570,571 JSEA Local 547 I(4) 4 scalar 563,564,583,584,585,593,597,598,59 9,600,601,610,611,625,627 LOG Func 585 scalar 585 MAPSF Local 531 I(4) 4 2 1 PTR 531,569,570 MAX Func 577 scalar 577,581,598,599,617 MIN Func 577 scalar 577 NAPROC Local 564 I(4) 4 scalar PTR 112,564,611,880,909,910,926,927,10 73,1139,1140,1156,1157,1173,1174 NK Local 532 I(4) 4 scalar PTR 532,542,591,624 NSEA Local 531 I(4) 4 scalar PTR 531 NSEAL Local 531 I(4) 4 scalar PTR 531,542,548,563,593,610 NTH Local 532 I(4) 4 scalar PTR 532,542,551,600,616,625,626 NX Local 531 I(4) 4 scalar PTR 531 NY Local 531 I(4) 4 scalar PTR 531 RADIUS Param 574 R(4) 4 scalar 574,1496,1497,1716 RLGTYPE Param 533 I(4) 4 scalar 533 SIG Local 532 R(4) 4 1 1 PTR 532,592,625 SQRT Func 571 scalar 571 TH Local 532 R(4) 4 1 1 PTR 532,617 TPIINV Param 592 R(4) 4 scalar 592,622 U10 Local 535 R(4) 4 1 1 PTR 535,577 U10C Local 550 R(4) 4 scalar 577,579,584 U10D Local 535 R(4) 4 1 1 PTR 535,613 U10DIR Local 550 R(4) 4 scalar 613,617 U10MAX Local 554 R(4) 4 scalar 554,577 U10MIN Local 553 R(4) 4 scalar 553,577 UNGTYPE Param 532 I(4) 4 scalar 532,566 W3ADATMD Module 535 535 W3GDATMD Module 531 531 W3UINI Subr 458 XGR Local 550 R(4) 4 scalar 567,571,574,579 XSTAR Local 550 R(4) 4 scalar 579,580,581,583 YLN Local 548 R(4) 4 1 0 585,601 Page 18 Source Listing W3UINI 2014-09-16 16:49 w3updtmd.f90 643 !/ ------------------------------------------------------------------- / 644 SUBROUTINE W3UBPT 645 !/ 646 !/ +-----------------------------------+ 647 !/ | WAVEWATCH III NOAA/NCEP | 648 !/ | H. L. Tolman | 649 !/ | FORTRAN 90 | 650 !/ | Last update : 17-Aug-2010 | 651 !/ +-----------------------------------+ 652 !/ 653 !/ 19-Oct-1998 : Final FORTRAN 77 ( version 1.18 ) 654 !/ 20-Dec-1999 : Upgrade to FORTRAN 90 ( version 2.00 ) 655 !/ 15-Dec-2004 : Multiple grid version. ( version 3.06 ) 656 !/ 07-Sep-2005 : Moving update to end of time step. ( version 3.08 ) 657 !/ 17-Aug-2010 : Add initialization ABPI0-N(:,0). ( version 3.14.5 ) 658 !/ 12-Jun-2012 : Add /RTD option or rotated grid option. 659 !/ (Jian-Guo Li) ( version 4.06 ) 660 !/ 661 ! 1. Purpose : 662 ! 663 ! Update spectra at the active boundary points. 664 ! 665 ! 2. Method : 666 ! 667 ! Spectra are read and interpolated in space and time from the 668 ! data read by W3IOBC. 669 ! 670 ! 3. Parameters : 671 ! 672 ! Parameter list 673 ! ---------------------------------------------------------------- 674 ! ---------------------------------------------------------------- 675 ! 676 ! 4. Subroutines used : 677 ! 678 ! See module documentation. 679 ! 680 ! 5. Called by : 681 ! 682 ! Name Type Module Description 683 ! ---------------------------------------------------------------- 684 ! W3WAVE Subr. W3WAVEMD Actual wave model routine. 685 ! ---------------------------------------------------------------- 686 ! STRACE, DSEC21 687 ! Service routines. 688 ! 689 ! 6. Error messages : 690 ! 691 ! None. 692 ! 693 ! 7. Remarks : 694 ! 695 ! - The data arrays contain sigma spectra to assure conservation 696 ! when changing grids. 697 ! 698 ! 8. Structure : 699 ! Page 19 Source Listing W3UBPT 2014-09-16 16:49 w3updtmd.f90 700 ! See source code. 701 ! 702 ! 9. Switches : 703 ! 704 ! !/S Enable subroutine tracing. 705 ! !/T0 Test output of wave heights. 706 ! 707 ! 10. Source code : 708 ! 709 !/ ------------------------------------------------------------------- / 710 USE W3GDATMD, ONLY: NSPEC, MAPWN, SIG2, DDEN 711 USE W3ADATMD, ONLY: CG 712 USE W3ODATMD, ONLY: NBI, ABPI0, ABPIN, ISBPI, IPBPI, RDBPI, & 713 BBPI0, BBPIN 714 !/ 715 IMPLICIT NONE 716 !/ 717 !/ ------------------------------------------------------------------- / 718 !/ Parameter list 719 !/ 720 !/ ------------------------------------------------------------------- / 721 !/ 722 INTEGER :: IBI, ISP, ISEA 723 !/ 724 !/ ------------------------------------------------------------------- / 725 !/ 726 ! 727 ! 1. Process BBPI0 -------------------------------------------------- * 728 ! 1.a First intialization 729 ! 730 IF ( BBPI0(1,0) .EQ. -1. ) THEN 731 ! 732 BBPI0(:,0) = 0. 733 BBPIN(:,0) = 0. 734 ABPI0(:,0) = 0. 735 ABPIN(:,0) = 0. 736 ! 737 DO IBI=1, NBI 738 ISEA = ISBPI(IBI) 739 DO ISP=1, NSPEC 740 BBPI0(ISP,IBI) = CG(MAPWN(ISP),ISEA) / SIG2(ISP) * & 741 ( RDBPI(IBI,1) * ABPI0(ISP,IPBPI(IBI,1)) & 742 + RDBPI(IBI,2) * ABPI0(ISP,IPBPI(IBI,2)) & 743 + RDBPI(IBI,3) * ABPI0(ISP,IPBPI(IBI,3)) & 744 + RDBPI(IBI,4) * ABPI0(ISP,IPBPI(IBI,4)) ) 745 END DO 746 END DO 747 ! 748 ! 1.b Shift BBPIN 749 ! 750 ELSE 751 BBPI0 = BBPIN 752 END IF 753 ! 754 ! 2. Process BBPIN -------------------------------------------------- * 755 ! 756 DO IBI=1, NBI Page 20 Source Listing W3UBPT 2014-09-16 16:49 w3updtmd.f90 757 ISEA = ISBPI(IBI) 758 DO ISP=1, NSPEC 759 BBPIN(ISP,IBI) = CG(MAPWN(ISP),ISEA) / SIG2(ISP) * & 760 ( RDBPI(IBI,1) * ABPIN(ISP,IPBPI(IBI,1)) & 761 + RDBPI(IBI,2) * ABPIN(ISP,IPBPI(IBI,2)) & 762 + RDBPI(IBI,3) * ABPIN(ISP,IPBPI(IBI,3)) & 763 + RDBPI(IBI,4) * ABPIN(ISP,IPBPI(IBI,4)) ) 764 END DO 765 ! 766 END DO 767 768 ! 3. Wave height test output ---------------------------------------- * 769 ! 770 RETURN 771 ! 772 ! Formats 773 ! 774 775 !/ 776 !/ End of W3UBPT ----------------------------------------------------- / 777 !/ 778 END SUBROUTINE W3UBPT ENTRY POINTS Name w3updtmd_mp_w3ubpt_ Page 21 Source Listing W3UBPT 2014-09-16 16:49 Symbol Table w3updtmd.f90 SYMBOL CROSS REFERENCE Name Object Declared Type Bytes Dimen Elements Attributes References ABPI0 Local 712 R(4) 4 2 1 PTR 712,734,741,742,743,744 ABPIN Local 712 R(4) 4 2 1 PTR 712,735,760,761,762,763 BBPI0 Local 713 R(4) 4 2 1 PTR 713,730,732,740,751 BBPIN Local 713 R(4) 4 2 1 PTR 713,733,751,759 CG Local 711 R(4) 4 2 1 PTR 711,740,759 DDEN Local 710 R(4) 4 1 1 PTR 710 IBI Local 722 I(4) 4 scalar 737,738,740,741,742,743,744,756,75 7,759,760,761,762,763 IPBPI Local 712 I(4) 4 2 1 PTR 712,741,742,743,744,760,761,762,76 3 ISBPI Local 712 I(4) 4 1 1 PTR 712,738,757 ISEA Local 722 I(4) 4 scalar 738,740,757,759 ISP Local 722 I(4) 4 scalar 739,740,741,742,743,744,758,759,76 0,761,762,763 MAPWN Local 710 I(4) 4 1 1 PTR 710,740,759 NBI Local 712 I(4) 4 scalar PTR 712,737,756 NSPEC Local 710 I(4) 4 scalar PTR 710,739,758 RDBPI Local 712 R(4) 4 2 1 PTR 712,741,742,743,744,760,761,762,76 3 SIG2 Local 710 R(4) 4 1 1 PTR 710,740,759 W3ADATMD Module 711 711 W3GDATMD Module 710 710 W3ODATMD Module 712 712 W3UBPT Subr 644 Page 22 Source Listing W3UBPT 2014-09-16 16:49 w3updtmd.f90 779 !/ ------------------------------------------------------------------- / 780 SUBROUTINE W3UICE ( A, VA ) 781 !/ 782 !/ +-----------------------------------+ 783 !/ | WAVEWATCH III NOAA/NCEP | 784 !/ | H. L. Tolman | 785 !/ | FORTRAN 90 | 786 !/ | Last update : 06-Jun-2012 | 787 !/ +-----------------------------------+ 788 !/ 789 !/ 19-Oct-1998 : Final FORTRAN 77 ( version 1.18 ) 790 !/ 20-Dec-1999 : Upgrade to FORTRAN 90 ( version 2.00 ) 791 !/ 11-Jan-2002 : Sub-grid ice. ( version 2.15 ) 792 !/ 15-Dec-2004 : Multiple grid version. ( version 3.06 ) 793 !/ 28-Jun-2005 : Adding MAPST2. ( version 3.07 ) 794 !/ Taking out initilization. 795 !/ 11-May-2007 : Adding NTPROC/NAPROC separation. ( version 3.11 ) 796 !/ 15-May-2010 : Adding second field for icebergs ( version 3.14 ) 797 !/ 13-Mar-2012 : Add initialization of UST on re- ( version 4.07 ) 798 !/ activation of grid point. 799 !/ 06-Jun-2012 : Porting bugfixes from 3.14 to 4.07 ( version 4.07 ) 800 !/ 801 ! 1. Purpose : 802 ! 803 ! Update ice map in the wave model. 804 ! 805 ! 2. Method : 806 ! 807 ! Points with an ice concentration larger than FICEN are removed 808 ! from the sea map in the wave model. Such points are identified 809 ! by negative numbers is the grid status map MAPSTA. For ice 810 ! points spectra are set to zero. Points from wich ice disappears 811 ! are initialized with a "small" JONSWAP spectrum, based on the 812 ! frequency SIG(NK-1) and the local wind direction. 813 ! 814 ! In the case of icebergs, the iceberg attenuation coefficient is 815 ! added to the subgrid obstruction map. 816 ! 817 ! 3. Parameters : 818 ! 819 ! Parameter list 820 ! ---------------------------------------------------------------- 821 ! (V)A R.A. I/O Spectra in 1-D or 2-D representation 822 ! (points to same address). 823 ! ---------------------------------------------------------------- 824 ! 825 ! 4. Subroutines used : 826 ! 827 ! See module documentation. 828 ! 829 ! 5. Called by : 830 ! 831 ! Name Type Module Description 832 ! ---------------------------------------------------------------- 833 ! W3WAVE Subr. W3WAVEMD Actual wave model routine. 834 ! ---------------------------------------------------------------- 835 ! Page 23 Source Listing W3UICE 2014-09-16 16:49 w3updtmd.f90 836 ! 6. Error messages : 837 ! 838 ! None. 839 ! 840 ! 7. Remarks : 841 ! 842 ! 8. Structure : 843 ! 844 ! See source code. 845 ! 846 ! 9. Switches : 847 ! 848 ! !/SHRD Switch for shared / distributed memory architecture. 849 ! !/DIST Id. 850 ! 851 ! !/S Enable subroutine tracing. 852 ! !/T Enable test output. 853 ! 854 ! 10. Source code : 855 ! 856 !/ ------------------------------------------------------------------- / 857 USE W3GDATMD, ONLY: NX, NY, NSEA, NSEAL, MAPSF, MAPSTA, MAPST2, & 858 NTH, NK, NSPEC, SIG, TH, DTH, FICEN 859 USE W3WDATMD, ONLY: TIME, TICE, ICE, BERG, UST 860 !! USE W3ADATMD, ONLY: U10, U10D, CG 861 USE W3ADATMD, ONLY: CG 862 USE W3IDATMD, ONLY: TIN, ICEI, BERGI 863 !/ 864 IMPLICIT NONE 865 !/ 866 !/ ------------------------------------------------------------------- / 867 !/ Parameter list 868 !/ 869 REAL, INTENT(INOUT) :: A(NTH,NK,0:NSEAL), VA(NSPEC,0:NSEAL) 870 !/ 871 !/ ------------------------------------------------------------------- / 872 !/ 873 INTEGER :: IK, ITH, ISEA, JSEA, IX, IY, ISP 874 INTEGER :: MAPICE(NY,NX) 875 LOGICAL :: LOCAL 876 !/ 877 !/ ------------------------------------------------------------------- / 878 !/ 879 ! 880 LOCAL = IAPROC .LE. NAPROC 881 ! 882 ! 1. Preparations --------------------------------------------------- * 883 ! 1.a Update times 884 ! 885 TICE(1) = TIN(1) 886 TICE(2) = TIN(2) 887 ! 888 ! 1.b Process maps 889 ! 890 MAPICE = MOD(MAPST2,2) 891 MAPST2 = MAPST2 - MAPICE 892 ! Page 24 Source Listing W3UICE 2014-09-16 16:49 w3updtmd.f90 893 ! 2. Main loop over sea points -------------------------------------- * 894 ! 895 DO ISEA=1, NSEA 896 ! 897 ! 2.a Get grid counters 898 ! 899 IX = MAPSF(ISEA,1) 900 IY = MAPSF(ISEA,2) 901 ICE(ISEA) = ICEI(IX,IY) 902 BERG(ISEA)= BERGI(IX,IY) 903 ! 904 ! 2.b Sea point to be de-activated.. 905 ! 906 IF ( ICEI(IX,IY).GE.FICEN .AND. MAPICE(IY,IX).EQ.0 ) THEN 907 MAPSTA(IY,IX) = - ABS(MAPSTA(IY,IX)) 908 MAPICE(IY,IX) = 1 909 IF ( LOCAL .AND. MOD(ISEA-IAPROC,NAPROC) .EQ. 0 ) THEN 910 JSEA = 1 + (ISEA-1)/NAPROC 911 VA(:,JSEA) = 0. 912 END IF 913 ! 914 END IF 915 ! 916 ! 2.b Ice point to be re-activated. 917 ! 918 IF ( ICEI(IX,IY).LT.FICEN .AND. MAPICE(IY,IX).EQ.1 ) THEN 919 ! 920 MAPICE(IY,IX) = 0 921 UST(ISEA) = 0.05 922 ! 923 IF ( MAPST2(IY,IX) .EQ. 0 ) THEN 924 MAPSTA(IY,IX) = ABS(MAPSTA(IY,IX)) 925 ! 926 IF ( LOCAL .AND. MOD(ISEA-IAPROC,NAPROC) .EQ. 0 ) THEN 927 JSEA = 1 + (ISEA-1)/NAPROC 928 VA(:,JSEA) = 0. 929 ! 930 END IF 931 ! 932 END IF 933 ! 934 END IF 935 ! 936 END DO 937 ! 938 ! 3. Update MAPST2 -------------------------------------------------- * 939 ! 940 MAPST2 = MAPST2 + MAPICE 941 ! 942 RETURN 943 ! 944 ! Formats 945 ! 946 !/ 947 !/ End of W3UICE ----------------------------------------------------- / 948 !/ 949 END SUBROUTINE W3UICE Page 25 Source Listing W3UICE 2014-09-16 16:49 Entry Points w3updtmd.f90 ENTRY POINTS Name w3updtmd_mp_w3uice_ SYMBOL CROSS REFERENCE Name Object Declared Type Bytes Dimen Elements Attributes References A Dummy 780 R(4) 4 3 0 ARG,INOUT ABS Func 907 scalar 907,924 BERG Local 859 R(4) 4 1 1 PTR 859,902 BERGI Local 862 R(4) 4 2 1 PTR 862,902 CG Local 861 R(4) 4 2 1 PTR 861 DTH Local 858 R(4) 4 scalar PTR 858 FICEN Local 858 R(4) 4 scalar PTR 858,906,918 ICE Local 859 R(4) 4 1 1 PTR 859,901 ICEI Local 862 R(4) 4 2 1 PTR 862,901,906,918 IK Local 873 I(4) 4 scalar ISEA Local 873 I(4) 4 scalar 895,899,900,901,902,909,910,921,92 6,927 ISP Local 873 I(4) 4 scalar ITH Local 873 I(4) 4 scalar IX Local 873 I(4) 4 scalar 899,901,902,906,907,908,918,920,92 3,924 IY Local 873 I(4) 4 scalar 900,901,902,906,907,908,918,920,92 3,924 JSEA Local 873 I(4) 4 scalar 910,911,927,928 LOCAL Local 875 L(4) 4 scalar 880,909,926 MAPICE Local 874 I(4) 4 2 0 890,891,906,908,918,920,940 MAPSF Local 857 I(4) 4 2 1 PTR 857,899,900 MAPST2 Local 857 I(4) 4 2 1 PTR 857,890,891,923,940 MAPSTA Local 857 I(4) 4 2 1 PTR 857,907,924 MOD Func 890 scalar 890,909,926 NK Local 858 I(4) 4 scalar PTR 858,869 NSEA Local 857 I(4) 4 scalar PTR 857,895 NSEAL Local 857 I(4) 4 scalar PTR 857,869 NSPEC Local 858 I(4) 4 scalar PTR 858,869 NTH Local 858 I(4) 4 scalar PTR 858,869 NX Local 857 I(4) 4 scalar PTR 857,874 NY Local 857 I(4) 4 scalar PTR 857,874 SIG Local 858 R(4) 4 1 1 PTR 858 TH Local 858 R(4) 4 1 1 PTR 858 TICE Local 859 I(4) 4 1 1 PTR 859,885,886 TIME Local 859 I(4) 4 1 1 PTR 859 TIN Local 862 I(4) 4 1 1 PTR 862,885,886 UST Local 859 R(4) 4 1 1 PTR 859,921 VA Dummy 780 R(4) 4 2 0 ARG,INOUT 911,928 W3ADATMD Module 861 861 W3GDATMD Module 857 857 W3IDATMD Module 862 862 W3UICE Subr 780 W3WDATMD Module 859 859 Page 26 Source Listing W3UICE 2014-09-16 16:49 w3updtmd.f90 950 !/ ------------------------------------------------------------------- / 951 SUBROUTINE W3ULEV ( A, VA ) 952 !/ 953 !/ +-----------------------------------+ 954 !/ | WAVEWATCH III NOAA/NCEP | 955 !/ | H. L. Tolman | 956 !/ | FORTRAN 90 | 957 !/ | Last update : 06-Jun-2012 | 958 !/ +-----------------------------------+ 959 !/ 960 !/ 15-Jan-1998 : Final FORTRAN 77 ( version 1.18 ) 961 !/ 21-Jan-2000 : Upgrade to FORTRAN 90 ( version 2.00 ) 962 !/ 30-Apr-2002 : Water level fixes. ( version 2.20 ) 963 !/ 15-Dec-2004 : Multiple grid version. ( version 3.06 ) 964 !/ 15-Jul-2005 : Adding drying out of points. ( version 3.07 ) 965 !/ 11-May-2007 : Adding NTPROC/NAPROC separation. ( version 3.11 ) 966 !/ 23-Aug-2011 : Bug fix for UG grids : new boundary ( version 4.04 ) 967 !/ 13-Mar-2012 : Add initialization of UST on re- ( version 4.07 ) 968 !/ activation of grid point. 969 !/ 06-Jun-2012 : Porting bugfixes from 3.14 to 4.07 ( version 4.07 ) 970 !/ 26-Sep-2012 : Adding update from tidal analysis ( version 4.08 ) 971 !/ 972 ! 1. Purpose : 973 ! 974 ! Update the water level. 975 ! 976 ! 2. Method : 977 ! 978 ! The wavenumber grid is modified without modyfying the spectrum 979 ! (conservative linear interpolation to new grid). 980 ! 981 ! 3. Parameters : 982 ! 983 ! Parameter list 984 ! ---------------------------------------------------------------- 985 ! (V)A R.A. I/O 2-D and 1-D represetation of the spectra. 986 ! ---------------------------------------------------------------- 987 ! 988 ! Local variables 989 ! ---------------------------------------------------------------- 990 ! KDMAX Real Deep water cut-off for kd. 991 ! WNO R.A. Old wavenumbers. 992 ! CGO R.A. Old group velocities. 993 ! OWN R.A. Old wavenumber band width. 994 ! DWN R.A. New wavenumber band width. 995 ! TA R.A. Auxiliary spectrum. 996 ! ---------------------------------------------------------------- 997 ! 998 ! 4. Subroutines used : 999 ! 1000 ! See module documentation. 1001 ! 1002 ! 5. Called by : 1003 ! 1004 ! Name Type Module Description 1005 ! ---------------------------------------------------------------- 1006 ! W3WAVE Subr. W3WAVEMD Actual wave model routine. Page 27 Source Listing W3ULEV 2014-09-16 16:49 w3updtmd.f90 1007 ! ---------------------------------------------------------------- 1008 ! 1009 ! 6. Error messages : 1010 ! 1011 ! None. 1012 ! 1013 ! 7. Remarks : 1014 ! 1015 ! - The grid is updated only if KDmin > KDMAX. 1016 ! - The grid is updated for inactive points too. 1017 ! - The local wavenumber bandwidth is DSIGMA/CG. 1018 ! - The local spectrum is updated only if the grid is updated, 1019 ! the grid point is not disabled (MAPST2) and if the change of 1020 ! the lowest wavenumber exceeds RDKMIN times the band width. 1021 ! - No spectral initialization for newly wet points. 1022 ! 1023 ! 8. Structure : 1024 ! 1025 ! See source code. 1026 ! 1027 ! 9. Switches : 1028 ! 1029 ! !/S Enable subroutine tracing. 1030 ! !/T Basic test output. 1031 ! !/T2 Output of minimum relative depth per grid point. 1032 ! !/T3 Spectra before and after 1033 ! 1034 ! 10. Source code : 1035 ! 1036 !/ ------------------------------------------------------------------- / 1037 USE W3GDATMD, ONLY: NX, NY, NSEA, NSEAL, MAPSF, MAPSTA, MAPST2, & 1038 ZB, DMIN, NK, NTH, NSPEC, SIG, DSIP, & 1039 MAPWN, MAPTH, FACHFA, GTYPE, UNGTYPE, W3SETREF 1040 USE W3WDATMD, ONLY: TIME, TLEV, WLV, UST 1041 USE W3ADATMD, ONLY: CG, WN, DW 1042 USE W3IDATMD, ONLY: TLN, WLEV 1043 USE W3SERVMD, ONLY: EXTCDE 1044 USE W3DISPMD, ONLY: WAVNU1 1045 USE W3TRIAMD, ONLY: SETUGIOBP 1046 USE W3TIMEMD 1047 1048 !/ 1049 IMPLICIT NONE 1050 !/ 1051 !/ ------------------------------------------------------------------- / 1052 !/ Parameter list 1053 !/ 1054 REAL, INTENT(INOUT) :: A(NTH,NK,0:NSEAL), VA(NSPEC,0:NSEAL) 1055 !/ 1056 !/ ------------------------------------------------------------------- / 1057 !/ 1058 INTEGER :: ISEA, JSEA, IX, IY, IK, I1, I2, & 1059 ISPEC, IK0, ITH 1060 INTEGER :: MAPDRY(NY,NX) 1061 REAL :: DWO(NSEA), KDCHCK, WNO(0:NK+1), & 1062 CGO(0:NK+1), DEPTH, & 1063 RDK, RD1, RD2, TA(NTH,NK), & Page 28 Source Listing W3ULEV 2014-09-16 16:49 w3updtmd.f90 1064 OWN(NK), DWN(NK) 1065 REAL :: KDMAX = 4., RDKMIN = 0.05 1066 LOGICAL :: LOCAL 1067 ! 1068 1069 !/ 1070 !/ ------------------------------------------------------------------- / 1071 !/ 1072 ! 1073 LOCAL = IAPROC .LE. NAPROC 1074 ! 1075 ! 1. Preparations --------------------------------------------------- * 1076 ! 1.a Check NK 1077 ! 1078 IF ( NK .LT. 2 ) THEN 1079 IF ( IAPROC .EQ. NAPERR ) WRITE (NDSE,1000) 1080 CALL EXTCDE ( 1 ) 1081 END IF 1082 ! 1083 ! 1.b Update times 1084 ! 1085 TLEV = TLN 1086 ! 1087 ! 1.c Extract dry point map, and residual MAPST2 1088 ! 1089 MAPDRY = MOD(MAPST2/2,2) 1090 MAPST2 = MAPST2 - 2*MAPDRY 1091 ! 1092 ! 1.d Update water levels and save old 1093 ! 1094 DO ISEA=1, NSEA 1095 IX = MAPSF(ISEA,1) 1096 IY = MAPSF(ISEA,2) 1097 DWO(ISEA) = DW(ISEA) 1098 ! 1099 1100 ! 1101 WLV(ISEA) = WLEV(IX,IY) 1102 DW (ISEA) = MAX ( 0. , WLV(ISEA)-ZB(ISEA) ) 1103 END DO 1104 ! 1105 ! 2. Loop over all sea points --------------------------------------- * 1106 ! 1107 DO ISEA=1, NSEA 1108 ! 1109 IX = MAPSF(ISEA,1) 1110 IY = MAPSF(ISEA,2) 1111 ! 1112 ! 2.a Check if deep water 1113 ! 1114 KDCHCK = WN(1,ISEA) * MIN( DWO(ISEA) , DW(ISEA) ) 1115 IF ( KDCHCK .LT. KDMAX ) THEN 1116 ! 1117 ! 2.b Update grid and save old grid 1118 ! 1119 DEPTH = MAX ( DMIN, DW(ISEA) ) 1120 ! Page 29 Source Listing W3ULEV 2014-09-16 16:49 w3updtmd.f90 1121 DO IK=0, NK+1 1122 WNO(IK) = WN(IK,ISEA) 1123 CGO(IK) = CG(IK,ISEA) 1124 ! 1125 ! Calculate wavenumbers and group velocities. 1126 CALL WAVNU1(SIG(IK),DEPTH,WN(IK,ISEA),CG(IK,ISEA)) 1127 ! 1128 END DO 1129 ! 1130 DO IK=1, NK 1131 OWN(IK) = DSIP(IK) / CGO(IK) 1132 DWN(IK) = DSIP(IK) / CG(IK,ISEA) 1133 END DO 1134 ! 1135 ! 2.c Process dry points 1136 ! 1137 IF ( WLV(ISEA)-ZB(ISEA) .LE.0. ) THEN 1138 IF ( MAPDRY(IY,IX) .EQ. 0 ) THEN 1139 IF ( LOCAL .AND. MOD(ISEA-IAPROC,NAPROC).EQ.0 ) THEN 1140 JSEA = 1 + (ISEA-1)/NAPROC 1141 VA(:,JSEA) = 0. 1142 END IF 1143 MAPDRY(IY,IX) = 1 1144 MAPSTA(IY,IX) = -ABS(MAPSTA(IY,IX)) 1145 ENDIF 1146 CYCLE 1147 END IF 1148 ! 1149 ! 2.d Process new wet point 1150 ! 1151 IF (WLV(ISEA)-ZB(ISEA).GT.0. .AND. MAPDRY(IY,IX).EQ.1) THEN 1152 MAPDRY(IY,IX) = 0 1153 ! 1154 ! Resets the spectrum to zero 1155 ! 1156 IF ( LOCAL .AND. MOD(ISEA-IAPROC,NAPROC).EQ.0 ) THEN 1157 JSEA = 1 + (ISEA-1)/NAPROC 1158 VA(:,JSEA) = 0. 1159 END IF 1160 ! 1161 UST(ISEA) = 0.05 1162 IF ( MAPST2(IY,IX) .EQ. 0 ) THEN 1163 MAPSTA(IY,IX) = ABS(MAPSTA(IY,IX)) 1164 END IF 1165 CYCLE 1166 END IF 1167 ! 1168 ! 2.e Check if ice on grid point, or if grid changes negligible 1169 ! 1170 RDK = ABS(WNO(1)-WN(1,ISEA)) / DWN(1) 1171 ! 1172 IF ( RDK.LT.RDKMIN .OR. MAPSTA(IY,IX).LT.0 ) CYCLE 1173 IF ( MOD(ISEA-IAPROC,NAPROC) .NE. 0 ) CYCLE 1174 JSEA = 1 + (ISEA-1)/NAPROC 1175 ! 1176 IF ( .NOT. LOCAL ) CYCLE 1177 ! Page 30 Source Listing W3ULEV 2014-09-16 16:49 w3updtmd.f90 1178 ! 2.d Save discrete actions and clean spectrum 1179 ! 1180 DO IK=1, NK 1181 DO ITH=1, NTH 1182 TA(ITH,IK) = A(ITH,IK,JSEA) * OWN(IK) 1183 END DO 1184 END DO 1185 ! 1186 VA(:,JSEA) = 0. 1187 ! 1188 ! 2.e Redistribute discrete action density 1189 ! 1190 IF ( WNO(1) .LT. WN(1,ISEA) ) THEN 1191 IK0 = 1 1192 I1 = 0 1193 I2 = 1 1194 220 CONTINUE 1195 IK0 = IK0 + 1 1196 IF ( IK0 .GT. NK+1 ) GOTO 251 1197 IF ( WNO(IK0) .GE. WN(1,ISEA) ) THEN 1198 IK0 = IK0 - 1 1199 ELSE 1200 GOTO 220 1201 END IF 1202 ELSE 1203 IK0 = 1 1204 I1 = 1 1205 I2 = 2 1206 END IF 1207 ! 1208 DO 250, IK=IK0, NK 1209 ! 1210 230 CONTINUE 1211 IF ( WNO(IK) .GT. WN(I2,ISEA) ) THEN 1212 I1 = I1 + 1 1213 IF ( I1 .GT. NK ) GOTO 250 1214 I2 = I1 + 1 1215 GOTO 230 1216 END IF 1217 ! 1218 IF ( I1 .EQ. 0 ) THEN 1219 RD1 = ( WN(1,ISEA) - WNO(IK) ) / DWN(1) 1220 RD2 = 1. - RD1 1221 ELSE 1222 RD1 = ( WN(I2,ISEA) - WNO(IK) ) / & 1223 ( WN(I2,ISEA) - WN(I1,ISEA) ) 1224 RD2 = 1. - RD1 1225 END IF 1226 ! 1227 IF ( I1 .GE. 1 ) THEN 1228 DO ITH=1, NTH 1229 A(ITH,I1,JSEA) = A(ITH,I1,JSEA) + RD1*TA(ITH,IK) 1230 END DO 1231 END IF 1232 ! 1233 IF ( I2 .LE. NK ) THEN 1234 DO ITH=1, NTH Page 31 Source Listing W3ULEV 2014-09-16 16:49 w3updtmd.f90 1235 A(ITH,I2,JSEA) = A(ITH,I2,JSEA) + RD2*TA(ITH,IK) 1236 END DO 1237 END IF 1238 ! 1239 250 CONTINUE 1240 251 CONTINUE 1241 ! 1242 ! 2.f Convert discrete action densities to spectrum 1243 ! 1244 DO ISPEC=1, NSPEC 1245 VA(ISPEC,JSEA) = VA(ISPEC,JSEA) / DWN(MAPWN(ISPEC)) 1246 END DO 1247 ! 1248 ! 2.f Add tail if necessary 1249 ! 1250 IF ( I2.LE.NK .AND. RD2.LE.0.95 ) THEN 1251 DO IK=MAX(I2,2), NK 1252 DO ITH=1, NTH 1253 A(ITH,IK,JSEA) = FACHFA * A(ITH,IK-1,JSEA) 1254 END DO 1255 END DO 1256 END IF 1257 ! 1258 END IF 1259 ! 1260 END DO 1261 ! 1262 ! 3. Reconstruct new MAPST2 ----------------------------------------- * 1263 ! 1264 MAPST2 = MAPST2 + 2*MAPDRY 1265 ! 1266 ! 4. Re-generates the boundary data ---------------------------------- * 1267 ! 1268 IF (GTYPE.EQ.UNGTYPE) THEN 1269 CALL SETUGIOBP 1270 ENDIF 1271 ! 1272 RETURN 1273 ! 1274 ! Formats 1275 ! 1276 1000 FORMAT (/' *** ERROR W3ULEV *** '/ & 1277 ' THIS ROUTINE REQUIRES NK > 1 '/) 1278 ! 1279 !/ 1280 !/ End of W3ULEV ----------------------------------------------------- / 1281 !/ 1282 END SUBROUTINE W3ULEV Page 32 Source Listing W3ULEV 2014-09-16 16:49 Entry Points w3updtmd.f90 ENTRY POINTS Name w3updtmd_mp_w3ulev_ SYMBOL CROSS REFERENCE Name Object Declared Type Bytes Dimen Elements Attributes References 1000 Label 1276 1079 220 Label 1194 1200 230 Label 1210 1215 250 Label 1239 1208,1213 251 Label 1240 1196 A Dummy 951 R(4) 4 3 0 ARG,INOUT 1182,1229,1235,1253 ABS Func 1144 scalar 1144,1163,1170 CG Local 1041 R(4) 4 2 1 PTR 1041,1123,1126,1132 CGO Local 1062 R(4) 4 1 0 1123,1131 DEPTH Local 1062 R(4) 4 scalar 1119,1126 DMIN Local 1038 R(4) 4 scalar PTR 1038,1119 DSIP Local 1038 R(4) 4 1 1 PTR 1038,1131,1132 DW Local 1041 R(4) 4 1 1 PTR 1041,1097,1102,1114,1119 DWN Local 1064 R(4) 4 1 0 1132,1170,1219,1245 DWO Local 1061 R(4) 4 1 0 1097,1114 EXTCDE Subr 1043 1043,1080 FACHFA Local 1039 R(4) 4 scalar PTR 1039,1253 GTYPE Local 1039 I(4) 4 scalar PTR 1039,1268 I1 Local 1058 I(4) 4 scalar 1192,1204,1212,1213,1214,1218,1223 ,1227,1229 I2 Local 1058 I(4) 4 scalar 1193,1205,1211,1214,1222,1223,1233 ,1235,1250,1251 IK Local 1058 I(4) 4 scalar 1121,1122,1123,1126,1130,1131,1132 ,1180,1182,1208,1211,1219,1222,122 9,1235,1251,1253 IK0 Local 1059 I(4) 4 scalar 1191,1195,1196,1197,1198,1203,1208 ISEA Local 1058 I(4) 4 scalar 1094,1095,1096,1097,1101,1102,1107 ,1109,1110,1114,1119,1122,1123,112 6,1132,1137,1139,1140,1151,1156,11 57,1161,1170,1173,1174,1190,1197,1 211,1219,1222,1223 ISPEC Local 1059 I(4) 4 scalar 1244,1245 ITH Local 1059 I(4) 4 scalar 1181,1182,1228,1229,1234,1235,1252 ,1253 IX Local 1058 I(4) 4 scalar 1095,1101,1109,1138,1143,1144,1151 ,1152,1162,1163,1172 IY Local 1058 I(4) 4 scalar 1096,1101,1110,1138,1143,1144,1151 ,1152,1162,1163,1172 JSEA Local 1058 I(4) 4 scalar 1140,1141,1157,1158,1174,1182,1186 ,1229,1235,1245,1253 KDCHCK Local 1061 R(4) 4 scalar 1114,1115 KDMAX Local 1065 R(4) 4 scalar 1065,1115 LOCAL Local 1066 L(4) 4 scalar 1073,1139,1156,1176 MAPDRY Local 1060 I(4) 4 2 0 1089,1090,1138,1143,1151,1152,1264 Page 33 Source Listing W3ULEV 2014-09-16 16:49 Symbol Table w3updtmd.f90 Name Object Declared Type Bytes Dimen Elements Attributes References MAPSF Local 1037 I(4) 4 2 1 PTR 1037,1095,1096,1109,1110 MAPST2 Local 1037 I(4) 4 2 1 PTR 1037,1089,1090,1162,1264 MAPSTA Local 1037 I(4) 4 2 1 PTR 1037,1144,1163,1172 MAPTH Local 1039 I(4) 4 1 1 PTR 1039 MAPWN Local 1039 I(4) 4 1 1 PTR 1039,1245 MAX Func 1102 scalar 1102,1119,1251 MIN Func 1114 scalar 1114 MOD Func 1089 scalar 1089,1139,1156,1173 NAPERR Local 1079 I(4) 4 scalar PTR 112,1079 NDSE Local 1079 I(4) 4 scalar PTR 112,1079 NK Local 1038 I(4) 4 scalar PTR 1038,1054,1061,1062,1063,1064,1078 ,1121,1130,1180,1196,1208,1213,123 3,1250,1251 NSEA Local 1037 I(4) 4 scalar PTR 1037,1061,1094,1107 NSEAL Local 1037 I(4) 4 scalar PTR 1037,1054 NSPEC Local 1038 I(4) 4 scalar PTR 1038,1054,1244 NTH Local 1038 I(4) 4 scalar PTR 1038,1054,1063,1181,1228,1234,1252 NX Local 1037 I(4) 4 scalar PTR 1037,1060 NY Local 1037 I(4) 4 scalar PTR 1037,1060 OWN Local 1064 R(4) 4 1 0 1131,1182 RD1 Local 1063 R(4) 4 scalar 1219,1220,1222,1224,1229 RD2 Local 1063 R(4) 4 scalar 1220,1224,1235,1250 RDK Local 1063 R(4) 4 scalar 1170,1172 RDKMIN Local 1065 R(4) 4 scalar 1065,1172 SETUGIOBP Subr 1045 1045,1269 SIG Local 1038 R(4) 4 1 1 PTR 1038,1126 TA Local 1063 R(4) 4 2 0 1182,1229,1235 TIME Local 1040 I(4) 4 1 1 PTR 1040 TLEV Local 1040 I(4) 4 1 1 PTR 1040,1085 TLN Local 1042 I(4) 4 1 1 PTR 1042,1085 UNGTYPE Param 1039 I(4) 4 scalar 1039,1268 UST Local 1040 R(4) 4 1 1 PTR 1040,1161 VA Dummy 951 R(4) 4 2 0 ARG,INOUT 1141,1158,1186,1245 W3ADATMD Module 1041 1041 W3DISPMD Module 1044 1044 W3GDATMD Module 1037 1037 W3IDATMD Module 1042 1042 W3SERVMD Module 1043 1043 W3SETREF Subr 1039 1039 W3TIMEMD Module 1046 1046 W3TRIAMD Module 1045 1045 W3ULEV Subr 951 W3WDATMD Module 1040 1040 WAVNU1 Subr 1044 1044,1126 WLEV Local 1042 R(4) 4 2 1 PTR 1042,1101 WLV Local 1040 R(4) 4 1 1 PTR 1040,1101,1102,1137,1151 WN Local 1041 R(4) 4 2 1 PTR 1041,1114,1122,1126,1170,1190,1197 ,1211,1219,1222,1223 WNO Local 1061 R(4) 4 1 0 1122,1170,1190,1197,1211,1219,1222 ZB Local 1038 R(4) 4 1 1 PTR 1038,1102,1137,1151 Page 34 Source Listing W3ULEV 2014-09-16 16:49 w3updtmd.f90 1283 !/ ------------------------------------------------------------------- / 1284 SUBROUTINE W3UTRN ( TRNX, TRNY ) 1285 !/ 1286 !/ +-----------------------------------+ 1287 !/ | WAVEWATCH III NOAA/NCEP | 1288 !/ | H. L. Tolman | 1289 !/ | FORTRAN 90 | 1290 !/ | Last update : 30-Oct-2009 | 1291 !/ +-----------------------------------+ 1292 !/ 1293 !/ 02-Apr-2001 : Origination. ( version 2.10 ) 1294 !/ 11-Jan-2002 : Sub-grid ice. ( version 2.15 ) 1295 !/ 30-Apr-2002 : Change to ICE on storage grid. ( version 2.20 ) 1296 !/ 15-Dec-2004 : Multiple grid version. ( version 3.06 ) 1297 !/ 11-Jan-2007 : Clean-up for boundary points. ( version 3.10 ) 1298 !/ 30-Oct-2009 : Implement run-time grid selection. ( version 3.14 ) 1299 !/ (W. E. Rogers & T. J. Campbell, NRL) 1300 !/ 30-Oct-2009 : Implement curvilinear grid type. ( version 3.14 ) 1301 !/ (W. E. Rogers & T. J. Campbell, NRL) 1302 !/ 1303 ! 1. Purpose : 1304 ! 1305 ! Update cell boundary transparencies for general use in propagation 1306 ! routines. 1307 ! 1308 ! 2. Method : 1309 ! 1310 ! Two arrays are generated with the size (NY*NX,-1:1). The value 1311 ! at (IXY,-1) indicates the transparency to be used if the lower 1312 ! or left boundary is an inflow boundary. (IXY,1) is used if the 1313 ! upper or right boundary is an inflow boundary. (IXY,0) is used 1314 ! for all other cases (by definition full transparency). 1315 ! 1316 ! 3. Parameters : 1317 ! 1318 ! Parameter list 1319 ! ---------------------------------------------------------------- 1320 ! TRNX/Y R.A. I Transparencies from model defintion file. 1321 ! ---------------------------------------------------------------- 1322 ! 1323 ! 4. Subroutines used : 1324 ! 1325 ! See module documentation. 1326 ! 1327 ! 5. Called by : 1328 ! 1329 ! Name Type Module Description 1330 ! ---------------------------------------------------------------- 1331 ! W3WAVE Subr. W3WAVEMD Actual wave model routine. 1332 ! ---------------------------------------------------------------- 1333 ! 1334 ! 6. Error messages : 1335 ! 1336 ! None. 1337 ! 1338 ! 7. Remarks : 1339 ! Page 35 Source Listing W3UTRN 2014-09-16 16:49 w3updtmd.f90 1340 ! 8. Structure : 1341 ! 1342 ! See source code. 1343 ! 1344 ! 9. Switches : 1345 ! 1346 ! !/S Enable subroutine tracing. 1347 ! !/T Basic test output. 1348 ! 1349 ! 10. Source code : 1350 ! 1351 !/ ------------------------------------------------------------------- / 1352 USE W3GDATMD, ONLY: NX, NY, NSEA, MAPSTA, MAPSF, & 1353 TRFLAG, FICE0, FICEN, FICEL, & 1354 RLGTYPE, CLGTYPE, GTYPE, FLAGLL, & 1355 HPFAC, HQFAC, FFACBERG 1356 USE W3WDATMD, ONLY: ICE, BERG 1357 USE W3ADATMD, ONLY: ATRNX, ATRNY 1358 ! 1359 IMPLICIT NONE 1360 !/ 1361 !/ ------------------------------------------------------------------- / 1362 !/ Parameter list 1363 !/ 1364 REAL, INTENT(IN) :: TRNX(NY*NX), TRNY(NY*NX) 1365 !/ 1366 !/ ------------------------------------------------------------------- / 1367 !/ 1368 INTEGER :: ISEA, IX, IY, IXY, IXN, IXP, IYN, IYP 1369 1370 REAL :: TRIX(NY*NX), TRIY(NY*NX), DX, DY, & 1371 LICE0, LICEN 1372 !/ 1373 !/ ------------------------------------------------------------------- / 1374 !/ 1375 ! 1376 ! 1. Preparations --------------------------------------------------- * 1377 ! 1378 ATRNX = 1. 1379 ATRNY = 1. 1380 ! 1381 ! 2. Filling arrays from TRNX/Y for obstructions -------------------- * 1382 ! 2.a TRFLAG = 0, no action needed 1383 IF ( TRFLAG .EQ. 0 ) THEN 1384 RETURN 1385 ! 1386 ! 2.b TRFLAG = 1,3: TRNX/Y defined at boundaries 1387 ! 1388 ELSE IF ( TRFLAG.EQ.1 .OR. TRFLAG.EQ.3 .OR. TRFLAG.EQ.5 ) THEN 1389 ! 1390 DO ISEA=1, NSEA 1391 ! 1392 IX = MAPSF(ISEA,1) 1393 IY = MAPSF(ISEA,2) 1394 IXY = MAPSF(ISEA,3) 1395 IF ( IX .EQ. 1 ) THEN 1396 ATRNX(IXY,-1) = TRNX(IY+(NX-1)*NY) Page 36 Source Listing W3UTRN 2014-09-16 16:49 w3updtmd.f90 1397 ATRNX(IXY, 1) = TRNX(IXY) 1398 ELSE IF ( IX .EQ. NX ) THEN 1399 ATRNX(IXY,-1) = TRNX(IXY-NY) 1400 ATRNX(IXY, 1) = TRNX(IY) 1401 ELSE 1402 ATRNX(IXY,-1) = TRNX(IXY-NY) 1403 ATRNX(IXY, 1) = TRNX(IXY) 1404 END IF 1405 ATRNY(IXY,-1) = TRNY(IXY-1) 1406 ATRNY(IXY, 1) = TRNY(IXY) 1407 ! 1408 END DO 1409 ! 1410 ! 2.c TRFLAG = 2,4,6: TRNX/Y defined at cell centers 1411 ! 1412 ELSE 1413 ! 1414 DO ISEA=1, NSEA 1415 ! 1416 IX = MAPSF(ISEA,1) 1417 IY = MAPSF(ISEA,2) 1418 IXY = MAPSF(ISEA,3) 1419 ! 1420 IF ( IX .EQ. 1 ) THEN 1421 IXN = IY + (NX-1)*NY 1422 IXP = IY + IX *NY 1423 ELSE IF ( IX .EQ. NX ) THEN 1424 IXN = IY + (IX-2)*NY 1425 IXP = IY 1426 ELSE 1427 IXN = IY + (IX-2)*NY 1428 IXP = IY + IX *NY 1429 END IF 1430 ! 1431 IF ( IY .EQ. 1 ) THEN 1432 IYN = IXY 1433 IYP = IXY + 1 1434 ELSE IF ( IY .EQ. NY ) THEN 1435 IYN = IXY - 1 1436 IYP = IXY 1437 ELSE 1438 IYN = IXY - 1 1439 IYP = IXY + 1 1440 END IF 1441 ! 1442 ! factors 0.5 in first term and 2. in second term cancel 1443 ! 1444 ATRNX(IXY,-1) = (1.+TRNX(IXY)) * TRNX(IXN)/(1.+TRNX(IXN)) 1445 ATRNX(IXY, 1) = (1.+TRNX(IXY)) * TRNX(IXP)/(1.+TRNX(IXP)) 1446 ATRNY(IXY,-1) = (1.+TRNY(IXY)) * TRNY(IYN)/(1.+TRNY(IYN)) 1447 ATRNY(IXY, 1) = (1.+TRNY(IXY)) * TRNY(IYP)/(1.+TRNY(IYP)) 1448 ! 1449 IF ( MAPSTA(IY,IX) .EQ. 2 ) THEN 1450 IF ( IX .EQ. 1 ) THEN 1451 ATRNX(IXY,-1) = 1. 1452 ELSE IF ( MAPSTA( IY ,IX-1) .LE. 0 ) THEN 1453 ATRNX(IXY,-1) = 1. Page 37 Source Listing W3UTRN 2014-09-16 16:49 w3updtmd.f90 1454 END IF 1455 IF ( IX .EQ. NX ) THEN 1456 ATRNX(IXY, 1) = 1. 1457 ELSE IF ( MAPSTA( IY ,IX+1) .LE. 0 ) THEN 1458 ATRNX(IXY, 1) = 1. 1459 END IF 1460 IF ( IY .EQ. 1 ) THEN 1461 ATRNY(IXY,-1) = 1. 1462 ELSE IF ( MAPSTA(IY-1, IX ) .LE. 0 ) THEN 1463 ATRNY(IXY,-1) = 1. 1464 END IF 1465 IF ( IY .EQ. NY ) THEN 1466 ATRNY(IXY, 1) = 1. 1467 ELSE IF ( MAPSTA(IY+1, IX ) .LE. 0 ) THEN 1468 ATRNY(IXY, 1) = 1. 1469 END IF 1470 END IF 1471 ! 1472 END DO 1473 END IF 1474 ! 1475 ! 3. Adding ice to obstructions ------------------------------------- * 1476 ! 3.a TRFLAG < 3, no action needed 1477 ! 1478 IF ( TRFLAG.LT.3 .OR. FICEN-FICE0.LT.1.E-6 ) THEN 1479 RETURN 1480 ! 1481 ! 3.b TRFLAG = 3,4,5,6: Calculate ice transparencies 1482 ! 1483 ELSE 1484 TRIX = 1. 1485 TRIY = 1. 1486 ! 1487 DO ISEA=1, NSEA 1488 ! 1489 IX = MAPSF(ISEA,1) 1490 IY = MAPSF(ISEA,2) 1491 IXY = MAPSF(ISEA,3) 1492 ! 1493 DX = HPFAC(IY,IX) 1494 DY = HQFAC(IY,IX) 1495 IF ( FLAGLL ) THEN 1496 DX = DX * RADIUS * DERA 1497 DY = DY * RADIUS * DERA 1498 END IF 1499 1500 ! 1501 IF (TRFLAG.GT.4) THEN 1502 ! 1503 ! Added by F. Ardhuin for iceberg tests ... 1504 ! Case in which the ice file contains the transparencies / 10*(dx or dy) with dx in km 1505 ! 1506 IF (BERG(ISEA).GT.0) THEN 1507 TRIX(IXY) = EXP(-BERG(ISEA)*DX*0.0001) 1508 TRIY(IXY) = EXP(-BERG(ISEA)*DY*0.0001) 1509 ELSE 1510 TRIX(IXY)=1. Page 38 Source Listing W3UTRN 2014-09-16 16:49 w3updtmd.f90 1511 TRIY(IXY)=1. 1512 END IF 1513 ELSE 1514 1515 ! begin temporary notes to document method of 3.14 public release: 1516 ! LICE0 = FICE0*MIN(DX,DY) ...................................... changed 1517 ! LICEN = FICEN*MIN(DX,DY) ...................................... changed 1518 ! TRIX(IXY) = ( LICEN - ICE(ISEA)*DX ) / ( LICEN - LICE0 ) ..... unchanged 1519 ! TRIX(IXY) = MAX ( 0. , MIN ( 1. , TRIX(IXY) ) ) .............. unchanged 1520 ! TRIY(IXY) = ( LICEN - ICE(ISEA)*DY ) / ( LICEN - LICE0 ) ..... unchanged 1521 ! TRIY(IXY) = MAX ( 0. , MIN ( 1. , TRIY(IXY) ) ) .............. unchanged 1522 ! end temporary notes to document method of 3.14 public release: 1523 1524 ! LICE0 = FICE0*MIN(DX,DY) 1525 ! LICEN = FICEN*MIN(DX,DY) 1526 IF (FICEL.GT.0.) THEN 1527 TRIX(IXY) = EXP(-ICE(ISEA)*DX/FICEL) 1528 TRIY(IXY) = EXP(-ICE(ISEA)*DY/FICEL) 1529 ELSE 1530 ! Otherwise: original Tolman expression (Tolman 2003) 1531 LICE0 = FICE0*DX 1532 LICEN = FICEN*DX 1533 TRIX(IXY) = ( LICEN - ICE(ISEA)*DX ) / ( LICEN - LICE0 ) 1534 1535 ! begin temporary notes 1536 ! TRIX = ( LICEN - ICE(ISEA)*DX ) / ( LICEN - LICE0 ) 1537 ! thus, it is TRIX= ( (FICEN*DX) - ICE(ISEA)*DX ) / ( (FICEN*DX) - (FICE0*DX) ) 1538 ! thus, it is TRIX= ( FICEN - ICE(ISEA) ) / ( FICEN - FICE0 ) 1539 ! in other words, the variables DX DY are not used 1540 ! and the variables LICE0 LICEN are not necessary. 1541 ! end temporary notes 1542 1543 LICE0 = FICE0*DY 1544 LICEN = FICEN*DY 1545 TRIY(IXY) = ( LICEN - ICE(ISEA)*DY ) / ( LICEN - LICE0 ) 1546 END IF 1547 TRIX(IXY) = MAX ( 0. , MIN ( 1. , TRIX(IXY) ) ) 1548 TRIY(IXY) = MAX ( 0. , MIN ( 1. , TRIY(IXY) ) ) 1549 ! 1550 ! Adding iceberg attenuation 1551 ! 1552 IF (BERG(ISEA).GT.0) THEN 1553 TRIX(IXY) = TRIX(IXY)*EXP(-BERG(ISEA)*FFACBERG *DX*0.0001) 1554 TRIY(IXY) = TRIY(IXY)*EXP(-BERG(ISEA)*FFACBERG *DY*0.0001) 1555 END IF 1556 END IF 1557 ! 1558 END DO 1559 ! 1560 ! 3.c Combine transparencies, ice always defined at cell center ! 1561 ! 1562 DO ISEA=1, NSEA 1563 ! 1564 IX = MAPSF(ISEA,1) 1565 IY = MAPSF(ISEA,2) 1566 IXY = MAPSF(ISEA,3) 1567 ! Page 39 Source Listing W3UTRN 2014-09-16 16:49 w3updtmd.f90 1568 IF ( IX .EQ. 1 ) THEN 1569 IXN = IY + (NX-1)*NY 1570 IXP = IY + IX *NY 1571 ELSE IF ( IX .EQ. NX ) THEN 1572 IXN = IY + (IX-2)*NY 1573 IXP = IY 1574 ELSE 1575 IXN = IY + (IX-2)*NY 1576 IXP = IY + IX *NY 1577 END IF 1578 ! 1579 IF ( IY .EQ. 1 ) THEN 1580 IYN = IXY 1581 IYP = IXY + 1 1582 ELSE IF ( IY .EQ. NY ) THEN 1583 IYN = IXY - 1 1584 IYP = IXY 1585 ELSE 1586 IYN = IXY - 1 1587 IYP = IXY + 1 1588 END IF 1589 ! 1590 ATRNX(IXY,-1) = ATRNX(IXY,-1) & 1591 * (1.+TRIX(IXY)) * TRIX(IXN)/(1.+TRIX(IXN)) 1592 ATRNX(IXY, 1) = ATRNX(IXY, 1) & 1593 * (1.+TRIX(IXY)) * TRIX(IXP)/(1.+TRIX(IXP)) 1594 ATRNY(IXY,-1) = ATRNY(IXY,-1) & 1595 * (1.+TRIY(IXY)) * TRIY(IYN)/(1.+TRIY(IYN)) 1596 ATRNY(IXY, 1) = ATRNY(IXY, 1) & 1597 * (1.+TRIY(IXY)) * TRIY(IYP)/(1.+TRIY(IYP)) 1598 ! 1599 END DO 1600 ! 1601 END IF 1602 ! 1603 RETURN 1604 ! 1605 ! Formats 1606 ! 1607 !/ 1608 !/ End of W3UTRN ----------------------------------------------------- / 1609 !/ 1610 END SUBROUTINE W3UTRN Page 40 Source Listing W3UTRN 2014-09-16 16:49 Entry Points w3updtmd.f90 ENTRY POINTS Name w3updtmd_mp_w3utrn_ SYMBOL CROSS REFERENCE Name Object Declared Type Bytes Dimen Elements Attributes References ATRNX Local 1357 R(4) 4 2 1 PTR 1357,1378,1396,1397,1399,1400,1402 ,1403,1444,1445,1451,1453,1456,145 8,1590,1592 ATRNY Local 1357 R(4) 4 2 1 PTR 1357,1379,1405,1406,1446,1447,1461 ,1463,1466,1468,1594,1596 BERG Local 1356 R(4) 4 1 1 PTR 1356,1506,1507,1508,1552,1553,1554 CLGTYPE Param 1354 I(4) 4 scalar 1354 DX Local 1370 R(4) 4 scalar 1493,1496,1507,1527,1531,1532,1533 ,1553 DY Local 1370 R(4) 4 scalar 1494,1497,1508,1528,1543,1544,1545 ,1554 EXP Func 1507 scalar 1507,1508,1527,1528,1553,1554 FFACBERG Local 1355 R(4) 4 scalar PTR 1355,1553,1554 FICE0 Local 1353 R(4) 4 scalar PTR 1353,1478,1531,1543 FICEL Local 1353 R(4) 4 scalar PTR 1353,1526,1527,1528 FICEN Local 1353 R(4) 4 scalar PTR 1353,1478,1532,1544 FLAGLL Local 1354 L(4) 4 scalar 1354,1495 GTYPE Local 1354 I(4) 4 scalar PTR 1354 HPFAC Local 1355 R(4) 4 2 1 PTR 1355,1493 HQFAC Local 1355 R(4) 4 2 1 PTR 1355,1494 ICE Local 1356 R(4) 4 1 1 PTR 1356,1527,1528,1533,1545 ISEA Local 1368 I(4) 4 scalar 1390,1392,1393,1394,1414,1416,1417 ,1418,1487,1489,1490,1491,1506,150 7,1508,1527,1528,1533,1545,1552,15 53,1554,1562,1564,1565,1566 IX Local 1368 I(4) 4 scalar 1392,1395,1398,1416,1420,1422,1423 ,1424,1427,1428,1449,1450,1452,145 5,1457,1462,1467,1489,1493,1494,15 64,1568,1570,1571,1572,1575,1576 IXN Local 1368 I(4) 4 scalar 1421,1424,1427,1444,1569,1572,1575 ,1591 IXP Local 1368 I(4) 4 scalar 1422,1425,1428,1445,1570,1573,1576 ,1593 IXY Local 1368 I(4) 4 scalar 1394,1396,1397,1399,1400,1402,1403 ,1405,1406,1418,1432,1433,1435,143 6,1438,1439,1444,1445,1446,1447,14 51,1453,1456,1458,1461,1463,1466,1 468,1491,1507,1508,1510,1511,1527, 1528,1533,1545,1547,1548,1553,1554 ,1566,1580,1581,1583,1584,1586,158 7,1590,1591,1592,1593,1594,1595,15 96,1597 IY Local 1368 I(4) 4 scalar 1393,1396,1400,1417,1421,1422,1424 ,1425,1427,1428,1431,1434,1449,145 Page 41 Source Listing W3UTRN 2014-09-16 16:49 Symbol Table w3updtmd.f90 Name Object Declared Type Bytes Dimen Elements Attributes References 2,1457,1460,1462,1465,1467,1490,14 93,1494,1565,1569,1570,1572,1573,1 575,1576,1579,1582 IYN Local 1368 I(4) 4 scalar 1432,1435,1438,1446,1580,1583,1586 ,1595 IYP Local 1368 I(4) 4 scalar 1433,1436,1439,1447,1581,1584,1587 ,1597 LICE0 Local 1371 R(4) 4 scalar 1531,1533,1543,1545 LICEN Local 1371 R(4) 4 scalar 1532,1533,1544,1545 MAPSF Local 1352 I(4) 4 2 1 PTR 1352,1392,1393,1394,1416,1417,1418 ,1489,1490,1491,1564,1565,1566 MAPSTA Local 1352 I(4) 4 2 1 PTR 1352,1449,1452,1457,1462,1467 MAX Func 1547 scalar 1547,1548 MIN Func 1547 scalar 1547,1548 NSEA Local 1352 I(4) 4 scalar PTR 1352,1390,1414,1487,1562 NX Local 1352 I(4) 4 scalar PTR 1352,1364,1370,1396,1398,1421,1423 ,1455,1569,1571 NY Local 1352 I(4) 4 scalar PTR 1352,1364,1370,1396,1399,1402,1421 ,1422,1424,1427,1428,1434,1465,156 9,1570,1572,1575,1576,1582 RLGTYPE Param 1354 I(4) 4 scalar 1354 TRFLAG Local 1353 I(4) 4 scalar PTR 1353,1383,1388,1478,1501 TRIX Local 1370 R(4) 4 1 0 1484,1507,1510,1527,1533,1547,1553 ,1591,1593 TRIY Local 1370 R(4) 4 1 0 1485,1508,1511,1528,1545,1548,1554 ,1595,1597 TRNX Dummy 1284 R(4) 4 1 0 ARG,IN 1396,1397,1399,1400,1402,1403,1444 ,1445 TRNY Dummy 1284 R(4) 4 1 0 ARG,IN 1405,1406,1446,1447 W3ADATMD Module 1357 1357 W3GDATMD Module 1352 1352 W3UTRN Subr 1284 W3WDATMD Module 1356 1356 Page 42 Source Listing W3UTRN 2014-09-16 16:49 w3updtmd.f90 1611 !/ ------------------------------------------------------------------- / 1612 SUBROUTINE W3DZXY( ZZ, ZUNIT, DZZDX, DZZDY ) 1613 !/ 1614 !/ +-----------------------------------+ 1615 !/ | WAVEWATCH III NOAA/NCEP | 1616 !/ | W. E. Rogers, NRL | 1617 !/ | FORTRAN 90 | 1618 !/ | Last update : 06-Dec-2010 | 1619 !/ +-----------------------------------+ 1620 !/ 1621 !/ 30-Oct-2009 : Origination. ( version 3.14 ) 1622 !/ 06-Dec-2010 : Change from GLOBAL (logical) to ICLOSE (integer) to 1623 !/ specify index closure for a grid. ( version 3.14 ) 1624 !/ (T. J. Campbell, NRL) 1625 !/ 1626 ! 1. Purpose : 1627 ! 1628 ! Calculate derivatives of a field. 1629 ! 1630 ! 2. Method : 1631 ! 1632 ! Derivatives are calculated in m/m from the longitude/latitude 1633 ! grid, central in space for iternal points, one-sided for 1634 ! coastal points. 1635 ! 1636 ! 3. Parameters : 1637 ! 1638 ! Parameter list 1639 ! ---------------------------------------------------------------- 1640 ! ZZ R.A. I Field to calculate derivatives of. 1641 ! ZUNIT R.A. I Units of ZZ (used for test output). 1642 ! DZZDX R.A. O Derivative in X-direction (W-E). 1643 ! DZZDY R.A. O Derivative in Y-direction (S-N). 1644 ! ---------------------------------------------------------------- 1645 ! 1646 ! 4. Subroutines used : 1647 ! 1648 ! See module documentation. 1649 ! 1650 ! 5. Called by : 1651 ! 1652 ! Name Type Module Description 1653 ! ---------------------------------------------------------------- 1654 ! W3WAVE Subr. W3WAVEMD Actual wave model routine. 1655 ! ---------------------------------------------------------------- 1656 ! 1657 ! 6. Error messages : 1658 ! 1659 ! None. 1660 ! 1661 ! 7. Remarks : 1662 ! 1663 ! This routine replaces the functionality of W3DDXY and W3DCXY. 1664 ! 1665 ! Output arrays are always initialized to zero. 1666 ! 1667 ! 8. Structure : Page 43 Source Listing W3DZXY 2014-09-16 16:49 w3updtmd.f90 1668 ! 1669 ! ---------------------------------------- 1670 ! 1. Preparations 1671 ! a Initialize arrays 1672 ! b Set constants 1673 ! 2. Derivatives in X-direction (W-E). 1674 ! 3. Derivatives in Y-direction (S-N). 1675 ! ---------------------------------------- 1676 ! 1677 ! 9. Switches : 1678 ! 1679 ! !/S Enable subroutine tracing. 1680 ! !/T Enable test output. 1681 ! 1682 ! 10. Source code : 1683 ! 1684 !/ ------------------------------------------------------------------- / 1685 USE W3GDATMD, ONLY: NX, NY, NSEA, MAPSTA, MAPFS, MAPFS, & 1686 DPDX, DPDY, DQDX, DQDY, FLAGLL, ICLOSE, & 1687 ICLOSE_NONE, ICLOSE_SMPL, ICLOSE_TRPL 1688 !/ 1689 IMPLICIT NONE 1690 !/ 1691 !/ ------------------------------------------------------------------- / 1692 !/ Parameter list 1693 !/ 1694 !/ ------------------------------------------------------------------- / 1695 !/ Local parameters 1696 !/ 1697 REAL, INTENT(IN) :: ZZ(NSEA) 1698 CHARACTER, INTENT(IN) :: ZUNIT*(*) 1699 REAL, INTENT(OUT) :: DZZDX(NY,NX), DZZDY(NY,NX) 1700 INTEGER :: ISEA, IX, IY, IXP, IXM, IYP, IYM 1701 REAL :: DFAC , STX, STY 1702 !/ 1703 !/ ------------------------------------------------------------------- / 1704 !/ 1705 ! 1706 ! 1. Preparations --------------------------------------------------- * 1707 ! 1.a Initialize arrays 1708 ! 1709 DZZDX = 0. 1710 DZZDY = 0. 1711 ! 1712 ! 1.b Set constants 1713 ! 1714 1715 IF ( FLAGLL ) THEN 1716 DFAC = 1. / ( DERA * RADIUS ) 1717 ELSE 1718 DFAC = 1. 1719 END IF 1720 1721 ! 1722 ! 2. Derivatives in X-direction (W-E) and Y-direction (S-N) ----- * 1723 ! 1724 Page 44 Source Listing W3DZXY 2014-09-16 16:49 w3updtmd.f90 1725 ! 2a. Interior points 1726 DO IY=2, NY-1 1727 DO IX=2, NX-1 1728 IF ( MAPSTA(IY,IX) .NE. 0 ) THEN 1729 STX = 0.5 1730 IF (MAPSTA(IY,IX+1).EQ.0) THEN 1731 IXP = IX 1732 STX = 1.0 1733 ELSE 1734 IXP = IX + 1 1735 END IF 1736 IF (MAPSTA(IY,IX-1).EQ.0) THEN 1737 IXM = IX 1738 STX = 1.0 1739 ELSE 1740 IXM = IX - 1 1741 END IF 1742 1743 STY = 0.5 1744 IF (MAPSTA(IY+1,IX).EQ.0) THEN 1745 IYP = IY 1746 STY = 1.0 1747 ELSE 1748 IYP = IY + 1 1749 END IF 1750 IF (MAPSTA(IY-1,IX).EQ.0) THEN 1751 IYM = IY 1752 STY = 1.0 1753 ELSE 1754 IYM = IY - 1 1755 END IF 1756 1757 DZZDX(IY,IX) = (ZZ(MAPFS(IY ,IXP))-ZZ(MAPFS(IY ,IXM))) * STX * DPDX(IY,IX) & 1758 + (ZZ(MAPFS(IYP,IX ))-ZZ(MAPFS(IYM,IX ))) * STY * DQDX(IY,IX) 1759 1760 DZZDY(IY,IX) = (ZZ(MAPFS(IY ,IXP))-ZZ(MAPFS(IY ,IXM))) * STX * DPDY(IY,IX) & 1761 + (ZZ(MAPFS(IYP,IX ))-ZZ(MAPFS(IYM,IX ))) * STY * DQDY(IY,IX) 1762 1763 DZZDX(IY,IX) = DZZDX(IY,IX) * DFAC 1764 DZZDY(IY,IX) = DZZDY(IY,IX) * DFAC 1765 1766 END IF 1767 1768 END DO 1769 END DO 1770 1771 IF ( ICLOSE.NE.ICLOSE_NONE ) THEN 1772 1773 ! 2b. column IX=1 for global case 1774 IX=1 1775 DO IY=2, NY-1 1776 1777 IF ( MAPSTA(IY,IX) .NE. 0 ) THEN 1778 STX = 0.5 1779 IF (MAPSTA(IY,IX+1).EQ.0) THEN 1780 IXP = IX 1781 STX = 1.0 Page 45 Source Listing W3DZXY 2014-09-16 16:49 w3updtmd.f90 1782 ELSE 1783 IXP = IX+1 1784 END IF 1785 IF (MAPSTA(IY,NX).EQ.0) THEN 1786 IXM = IX 1787 STX = 1.0 1788 ELSE 1789 IXM = NX 1790 END IF 1791 1792 STY = 0.5 1793 IF (MAPSTA(IY+1,IX).EQ.0) THEN 1794 IYP = IY 1795 STY = 1.0 1796 ELSE 1797 IYP = IY + 1 1798 END IF 1799 IF (MAPSTA(IY-1,IX).EQ.0) THEN 1800 IYM = IY 1801 STY = 1.0 1802 ELSE 1803 IYM = IY - 1 1804 END IF 1805 1806 DZZDX(IY,IX) = (ZZ(MAPFS(IY ,IXP))-ZZ(MAPFS(IY ,IXM))) * STX * DPDX(IY,IX) & 1807 + (ZZ(MAPFS(IYP,IX ))-ZZ(MAPFS(IYM,IX ))) * STY * DQDX(IY,IX) 1808 1809 DZZDY(IY,IX) = (ZZ(MAPFS(IY ,IXP))-ZZ(MAPFS(IY ,IXM))) * STX * DPDY(IY,IX) & 1810 + (ZZ(MAPFS(IYP,IX ))-ZZ(MAPFS(IYM,IX ))) * STY * DQDY(IY,IX) 1811 1812 DZZDX(IY,IX) = DZZDX(IY,IX) * DFAC 1813 DZZDY(IY,IX) = DZZDY(IY,IX) * DFAC 1814 1815 END IF 1816 1817 END DO 1818 1819 1820 ! 2c. column IX=NX for global case 1821 IX=NX 1822 DO IY=2, NY-1 1823 1824 IF ( MAPSTA(IY,IX) .NE. 0 ) THEN 1825 STX = 0.5 1826 IF (MAPSTA(IY,1).EQ.0) THEN 1827 IXP = IX 1828 STX = 1.0 1829 ELSE 1830 IXP = 1 1831 END IF 1832 IF (MAPSTA(IY,IX-1).EQ.0) THEN 1833 IXM = IX 1834 STX = 1.0 1835 ELSE 1836 IXM = IX-1 1837 END IF 1838 Page 46 Source Listing W3DZXY 2014-09-16 16:49 w3updtmd.f90 1839 STY = 0.5 1840 IF (MAPSTA(IY+1,IX).EQ.0) THEN 1841 IYP = IY 1842 STY = 1.0 1843 ELSE 1844 IYP = IY + 1 1845 END IF 1846 IF (MAPSTA(IY-1,IX).EQ.0) THEN 1847 IYM = IY 1848 STY = 1.0 1849 ELSE 1850 IYM = IY - 1 1851 END IF 1852 1853 DZZDX(IY,IX) = (ZZ(MAPFS(IY ,IXP))-ZZ(MAPFS(IY ,IXM))) * STX * DPDX(IY,IX) & 1854 + (ZZ(MAPFS(IYP,IX ))-ZZ(MAPFS(IYM,IX ))) * STY * DQDX(IY,IX) 1855 1856 DZZDY(IY,IX) = (ZZ(MAPFS(IY ,IXP))-ZZ(MAPFS(IY ,IXM))) * STX * DPDY(IY,IX) & 1857 + (ZZ(MAPFS(IYP,IX ))-ZZ(MAPFS(IYM,IX ))) * STY * DQDY(IY,IX) 1858 1859 DZZDX(IY,IX) = DZZDX(IY,IX) * DFAC 1860 DZZDY(IY,IX) = DZZDY(IY,IX) * DFAC 1861 1862 END IF 1863 END DO 1864 1865 END IF 1866 ! 1867 ! 3. Test output of fields ------------------------------------------ * 1868 ! 1869 RETURN 1870 ! 1871 ! Formats 1872 ! 1873 !/ 1874 !/ End of W3DZXY ----------------------------------------------------- / 1875 !/ 1876 END SUBROUTINE W3DZXY Page 47 Source Listing W3DZXY 2014-09-16 16:49 Entry Points w3updtmd.f90 ENTRY POINTS Name w3updtmd_mp_w3dzxy_ SYMBOL CROSS REFERENCE Name Object Declared Type Bytes Dimen Elements Attributes References DFAC Local 1701 R(4) 4 scalar 1716,1718,1763,1764,1812,1813,1859 ,1860 DPDX Local 1686 R(4) 4 2 1 PTR 1686,1757,1806,1853 DPDY Local 1686 R(4) 4 2 1 PTR 1686,1760,1809,1856 DQDX Local 1686 R(4) 4 2 1 PTR 1686,1758,1807,1854 DQDY Local 1686 R(4) 4 2 1 PTR 1686,1761,1810,1857 DZZDX Dummy 1612 R(4) 4 2 0 ARG,OUT 1709,1757,1763,1806,1812,1853,1859 DZZDY Dummy 1612 R(4) 4 2 0 ARG,OUT 1710,1760,1764,1809,1813,1856,1860 FLAGLL Local 1686 L(4) 4 scalar 1686,1715 ICLOSE Local 1686 I(4) 4 scalar PTR 1686,1771 ICLOSE_NONE Param 1687 I(4) 4 scalar 1687,1771 ICLOSE_SMPL Param 1687 I(4) 4 scalar 1687 ICLOSE_TRPL Param 1687 I(4) 4 scalar 1687 ISEA Local 1700 I(4) 4 scalar IX Local 1700 I(4) 4 scalar 1727,1728,1730,1731,1734,1736,1737 ,1740,1744,1750,1757,1758,1760,176 1,1763,1764,1774,1777,1779,1780,17 83,1786,1793,1799,1806,1807,1809,1 810,1812,1813,1821,1824,1827,1832, 1833,1836,1840,1846,1853,1854,1856 ,1857,1859,1860 IXM Local 1700 I(4) 4 scalar 1737,1740,1757,1760,1786,1789,1806 ,1809,1833,1836,1853,1856 IXP Local 1700 I(4) 4 scalar 1731,1734,1757,1760,1780,1783,1806 ,1809,1827,1830,1853,1856 IY Local 1700 I(4) 4 scalar 1726,1728,1730,1736,1744,1745,1748 ,1750,1751,1754,1757,1758,1760,176 1,1763,1764,1775,1777,1779,1785,17 93,1794,1797,1799,1800,1803,1806,1 807,1809,1810,1812,1813,1822,1824, 1826,1832,1840,1841,1844,1846,1847 ,1850,1853,1854,1856,1857,1859,186 0 IYM Local 1700 I(4) 4 scalar 1751,1754,1758,1761,1800,1803,1807 ,1810,1847,1850,1854,1857 IYP Local 1700 I(4) 4 scalar 1745,1748,1758,1761,1794,1797,1807 ,1810,1841,1844,1854,1857 MAPFS Local 1685 I(4) 4 2 1 PTR 1685,1757,1758,1760,1761,1806,1807 ,1809,1810,1853,1854,1856,1857 MAPSTA Local 1685 I(4) 4 2 1 PTR 1685,1728,1730,1736,1744,1750,1777 ,1779,1785,1793,1799,1824,1826,183 2,1840,1846 NSEA Local 1685 I(4) 4 scalar PTR 1685,1697 NX Local 1685 I(4) 4 scalar PTR 1685,1699,1727,1785,1789,1821 Page 48 Source Listing W3DZXY 2014-09-16 16:49 Symbol Table w3updtmd.f90 Name Object Declared Type Bytes Dimen Elements Attributes References NY Local 1685 I(4) 4 scalar PTR 1685,1699,1726,1775,1822 STX Local 1701 R(4) 4 scalar 1729,1732,1738,1757,1760,1778,1781 ,1787,1806,1809,1825,1828,1834,185 3,1856 STY Local 1701 R(4) 4 scalar 1743,1746,1752,1758,1761,1792,1795 ,1801,1807,1810,1839,1842,1848,185 4,1857 W3DZXY Subr 1612 W3GDATMD Module 1685 1685 ZUNIT Dummy 1612 CHAR scalar ARG,IN ZZ Dummy 1612 R(4) 4 1 0 ARG,IN 1757,1758,1760,1761,1806,1807,1809 ,1810,1853,1854,1856,1857 Page 49 Source Listing W3DZXY 2014-09-16 16:49 w3updtmd.f90 1877 !/ ------------------------------------------------------------------- / 1878 !/ End of module W3UPDTMD -------------------------------------------- / 1879 !/ 1880 END MODULE W3UPDTMD SYMBOL CROSS REFERENCE Name Object Declared Type Bytes Dimen Elements Attributes References CONSTANTS Module 111 111 NDST Local 112 I(4) 4 scalar PTR 112 W3ODATMD Module 112 112 W3TIMEMD Module 113 113 W3UPDTMD Module 2 Page 50 Source Listing W3DZXY 2014-09-16 16:49 Subprograms/Common Blocks w3updtmd.f90 SUBPROGRAMS/COMMON BLOCKS Name Object Declared Type Bytes Dimen Elements Attributes References W3DZXY Subr 1612 W3UBPT Subr 644 W3UCUR Subr 119 W3UICE Subr 780 W3UINI Subr 458 W3ULEV Subr 951 W3UPDTMD Module 2 W3UTRN Subr 1284 W3UWND Subr 272 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__ Page 51 Source Listing W3DZXY 2014-09-16 16:49 w3updtmd.f90 -D __MMX__ -D __AVX__ -double_size 64 no -d_lines no -Qdyncom -error_limit 30 no -f66 no -f77rtl no -fast -fpscomp nofilesfromcmd -fpscomp nogeneral -fpscomp noioformat -fpscomp noldio_spacing -fpscomp nologicals no -fpconstant -fpe3 -fprm nearest no -ftz -fp_model noprecise -fp_model fast -fp_model nostrict -fp_model nosource -fp_model nodouble -fp_model noextended -fp_model novery_fast -fp_model noexcept -fp_model nono_except -heap_arrays 0 no -threadprivate_compat -free -g0 -iface nomixed_str_len_arg -iface nono_mixed_str_len_arg no -intconstant -integer_size 32 no -mixed_str_len_arg no -module -names lowercase no -noinclude -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 : w3updtmd.lst -o filename : none COMPILER: Intel(R) Fortran 12.1-2100