Page 1 Source Listing ITRACE 2014-09-16 17:00 w3servmd.f90 1 !/ ------------------------------------------------------------------- / 2 MODULE W3SERVMD 3 !/ 4 !/ +-----------------------------------+ 5 !/ | WAVEWATCH III NOAA/NCEP | 6 !/ | H. L. Tolman | 7 !/ | FORTRAN 90 | 8 !/ | Last update : 11-Nov-2013 | 9 !/ +-----------------------------------+ 10 !/ 11 !/ For update log see individual subroutines. 12 !/ 12-Jun-2012 : Add /RTD option or rotated grid option. 13 !/ (Jian-Guo Li) ( version 4.06 ) 14 !/ 11-Nov-2013 : SMC and rotated grid incorporated in the main 15 !/ trunk ( version 4.13 ) 16 !/ 17 !/ Copyright 2009-2012 National Weather Service (NWS), 18 !/ National Oceanic and Atmospheric Administration. All rights 19 !/ reserved. WAVEWATCH III is a trademark of the NWS. 20 !/ No unauthorized use without permission. 21 !/ 22 ! 1. Purpose : 23 ! 24 ! In this module all WAVEWATCH specific service routines have 25 ! been gathered. 26 ! 27 ! 2. Variables and types : 28 ! 29 ! Name Type Scope Description 30 ! ---------------------------------------------------------------- 31 ! NDSTRC Int. Private Data set number for output of STRACE 32 ! (set in ITRACE). 33 ! NTRACE Int. Private Maximum number of trace prints in 34 ! strace (set in ITRACE). 35 ! 36 ! PRFTB Int. Private Base time for profiling. 37 ! FLPROF Log. Private Flag for profiling initialization. 38 ! ---------------------------------------------------------------- 39 ! 40 ! 3. Subroutines and functions : 41 ! 42 ! Name Type Scope Description 43 ! ---------------------------------------------------------------- 44 ! ITRACE Subr. Public (Re-) Initialization for STRACE. 45 ! STRACE Subr. Public Enable subroutine tracing, usually 46 ! activated with the !/S switch. 47 ! NEXTLN Subr. Public Get to next line in input command file. 48 ! W3S2XY Subr. Public Grid conversion routine. 49 ! EJ5P R.F. Public Five parameter JONSWAP spectrum. 50 ! WWDATE Subr. Public Get system date. 51 ! WWTIME Subr. Public Get system time. 52 ! EXTCDE Subr. Public Abort program with exit code. 53 ! PRINIT Subr. Public Initialize profiling. 54 ! PRTIME Subr. Public Get profiling time. 55 ! Four subs for rotated grid are appended to this module. As they 56 ! are shared with SMC grid, they are not quoted by option /RTD but 57 ! are available for general use. JGLi12Jun2012 Page 2 Source Listing ITRACE 2014-09-16 17:00 w3servmd.f90 58 ! W3SPECTN turns wave spectrum anti-clockwise by AnglD 59 ! W3ACTURN turns wave action(k,nth) anti-clockwise by AnglD. 60 ! W3LLTOEQ convert standard into rotated lat/lon, plus AnglD 61 ! W3EQTOLL revers of the LLTOEQ, but AnglD unchanged. 62 ! 63 ! ---------------------------------------------------------------- 64 ! 65 ! 4. Subroutines and functions used : 66 ! 67 ! None. 68 ! 69 ! 5. Remarks : 70 ! 71 ! 6. Switches 72 ! 73 ! !/S Enable subroutine tracing using STRACE in this module. 74 ! 75 ! !/F90 FORTRAN 90 specific switches. 76 ! 77 ! 7. Source code : 78 ! 79 !/ ------------------------------------------------------------------- / 80 PUBLIC 81 ! 82 INTEGER, PRIVATE :: NDSTRC = 6, NTRACE = 0, PRFTB 83 LOGICAL, PRIVATE :: FLPROF = .FALSE. 84 ! 85 CONTAINS 86 !/ ------------------------------------------------------------------- / 87 SUBROUTINE ITRACE (NDS, NMAX) 88 !/ 89 !/ +-----------------------------------+ 90 !/ | WAVEWATCH III NOAA/NCEP | 91 !/ | H. L. Tolman | 92 !/ | FORTRAN 90 | 93 !/ | Last update : 23-Nov-1999 | 94 !/ +-----------------------------------+ 95 !/ 96 !/ 23-Nov-1999 : First version of routine. ( version 2.00 ) 97 !/ 98 ! 1. Purpose : 99 ! 100 ! (Re-) initialization for module version of STRACE. 101 ! 102 ! 3. Parameter list 103 ! ---------------------------------------------------------------- 104 ! NDS Int. I Data set number ofr trace file. 105 ! NMAX Int. I Maximum number of traces per routine. 106 ! ---------------------------------------------------------------- 107 ! 108 ! Private to module : 109 ! ---------------------------------------------------------------- 110 ! NDSTRC Int. Output unit number for trace. ( from NDS ) 111 ! NTRACE Int. Maximum number of trace prints. ( from NMAX ) 112 ! ---------------------------------------------------------------- 113 ! 114 ! 4. Subroutines used : Page 3 Source Listing ITRACE 2014-09-16 17:00 w3servmd.f90 115 ! 116 ! None. 117 ! 118 ! 5. Called by : 119 ! 120 ! Any program, multiple calls allowed. 121 ! 122 ! 9. Switches : 123 ! 124 ! 10. Source code : 125 ! 126 !/ ------------------------------------------------------------------- / 127 IMPLICIT NONE 128 !/ 129 !/ ------------------------------------------------------------------- / 130 !/ Parameter list 131 !/ 132 INTEGER, INTENT(IN) :: NDS, NMAX 133 !/ 134 !/ ------------------------------------------------------------------- / 135 !/ 136 NTRACE = MAX ( 0 , NMAX ) 137 NDSTRC = NDS 138 ! 139 RETURN 140 !/ 141 !/ End of ITRACE ----------------------------------------------------- / 142 !/ 143 END SUBROUTINE ITRACE Page 4 Source Listing ITRACE 2014-09-16 17:00 Entry Points w3servmd.f90 ENTRY POINTS Name w3servmd_mp_itrace_ SYMBOL CROSS REFERENCE Name Object Declared Type Bytes Dimen Elements Attributes References ITRACE Subr 87 MAX Func 136 scalar 136 NDS Dummy 87 I(4) 4 scalar ARG,IN 137 NDSTRC Local 137 I(4) 4 scalar PRIV 82,137,204,206 NMAX Dummy 87 I(4) 4 scalar ARG,IN 136 NTRACE Local 136 I(4) 4 scalar PRIV 82,136,200 Page 5 Source Listing ITRACE 2014-09-16 17:00 w3servmd.f90 144 !/ ------------------------------------------------------------------- / 145 SUBROUTINE STRACE (IENT, SNAME) 146 !/ 147 !/ +-----------------------------------+ 148 !/ | WAVEWATCH III NOAA/NCEP | 149 !/ | H. L. Tolman | 150 !/ | FORTRAN 90 | 151 !/ | Last update : 25-Jan-2000 | 152 !/ +-----------------------------------+ 153 !/ Original version by N. Booij, DUT 154 !/ 155 !/ 30-Mar-1993 : Final FORTRAN 77 ( version 1.18 ) 156 !/ 23-Nov-1999 : Upgrade to FORTRAN 90 ( version 2.00 ) 157 !/ 25-Jan-2000 : Force flushing of uniit. ( version 2.00 ) 158 !/ This was taken out around version 3.01. 159 !/ 160 ! 1. Purpose : 161 ! 162 ! Keep track of entered subroutines. 163 ! 164 ! 3. Parameter list 165 ! ---------------------------------------------------------------- 166 ! IENT Int. I/O Number of times that STRACE has been 167 ! called by the routine. 168 ! SNAME Char. I Name of the subroutine (max. 6 characters) 169 ! ---------------------------------------------------------------- 170 ! 171 ! Private to module : 172 ! ---------------------------------------------------------------- 173 ! NDSTRC Int. Output unit number for trace. 174 ! NTRACE Int. Maximum number of trace prints. 175 ! ---------------------------------------------------------------- 176 ! 177 ! 4. Subroutines used : 178 ! 179 ! None. 180 ! 181 ! 5. Called by : 182 ! 183 ! Any program, after private variables have been set by NTRACE. 184 ! 185 ! 9. Switches : 186 ! 187 ! 10. Source code : 188 ! 189 !/ ------------------------------------------------------------------- / 190 IMPLICIT NONE 191 !/ 192 !/ ------------------------------------------------------------------- / 193 !/ Parameter list 194 !/ 195 INTEGER, INTENT(INOUT) :: IENT 196 CHARACTER, INTENT(IN) :: SNAME*(*) 197 !/ 198 !/ ------------------------------------------------------------------- / 199 !/ 200 IF (NTRACE.EQ.0 .OR. IENT.GE.NTRACE) RETURN Page 6 Source Listing STRACE 2014-09-16 17:00 w3servmd.f90 201 ! 202 IENT = IENT + 1 203 IF (IENT.EQ.1) THEN 204 WRITE (NDSTRC,10) SNAME 205 ELSE 206 WRITE (NDSTRC,11) SNAME, IENT 207 END IF 208 ! 209 RETURN 210 ! 211 ! Formats 212 ! 213 10 FORMAT (' ---> TRACE SUBR : ',A6) 214 11 FORMAT (' ---> TRACE SUBR : ',A6,' ENTRY: ',I6) 215 !/ 216 !/ End of STRACE ----------------------------------------------------- / 217 !/ 218 END SUBROUTINE STRACE ENTRY POINTS Name w3servmd_mp_strace_ SYMBOL CROSS REFERENCE Name Object Declared Type Bytes Dimen Elements Attributes References 10 Label 213 204 11 Label 214 206 IENT Dummy 145 I(4) 4 scalar ARG,INOUT 200,202,203,206 SNAME Dummy 145 CHAR scalar ARG,IN 204,206 STRACE Subr 145 Page 7 Source Listing STRACE 2014-09-16 17:00 w3servmd.f90 219 !/ ------------------------------------------------------------------- / 220 SUBROUTINE NEXTLN ( CHCKC , NDSI , NDSE ) 221 !/ 222 !/ +-----------------------------------+ 223 !/ | WAVEWATCH III NOAA/NCEP | 224 !/ | H. L. Tolman | 225 !/ | FORTRAN 90 | 226 !/ | Last update : 18-Nov-1999 | 227 !/ +-----------------------------------+ 228 !/ 229 !/ 15-Jan-1999 : Final FORTRAN 77 ( version 1.18 ) 230 !/ 18-Nov-1999 : Upgrade to FORTRAN 90 ( version 2.00 ) 231 !/ 232 ! 1. Purpose : 233 ! 234 ! Sets file pointer to next active line of input file, by skipping 235 ! lines starting with the character CHCKC. 236 ! 237 ! 3. Parameters : 238 ! 239 ! Parameter list 240 ! ---------------------------------------------------------------- 241 ! CHCKC C*1 I Check character for defining comment line. 242 ! NDSI Int. I Input dataset number. 243 ! NDSE Int. I Error output dataset number. 244 ! (No output if NDSE < 0). 245 ! ---------------------------------------------------------------- 246 ! 247 ! 4. Subroutines used : 248 ! 249 ! STRACE ( !/S switch ) 250 ! 251 ! 5. Called by : 252 ! 253 ! Any routine. 254 ! 255 ! 6. Error messages : 256 ! 257 ! - On EOF or error in input file. 258 ! 259 ! 9. Switches : 260 ! 261 ! !/S Enable subroutine tracing. 262 ! 263 ! 10. Source code : 264 ! 265 !/ ------------------------------------------------------------------- / 266 IMPLICIT NONE 267 !/ 268 !/ ------------------------------------------------------------------- / 269 !/ Parameter list 270 !/ 271 INTEGER, INTENT(IN) :: NDSI, NDSE 272 CHARACTER, INTENT(IN) :: CHCKC*1 273 !/ 274 !/ ------------------------------------------------------------------- / 275 !/ Local parameters Page 8 Source Listing NEXTLN 2014-09-16 17:00 w3servmd.f90 276 !/ 277 INTEGER :: IERR 278 CHARACTER :: TEST*1 279 !/ 280 !/ ------------------------------------------------------------------- / 281 !/ 282 ! 283 100 CONTINUE 284 READ (NDSI,900,END=800,ERR=801,IOSTAT=IERR) TEST 285 IF (TEST.EQ.CHCKC) THEN 286 GOTO 100 287 ELSE 288 BACKSPACE (NDSI,ERR=802,IOSTAT=IERR) 289 ENDIF 290 RETURN 291 ! 292 800 CONTINUE 293 IF ( NDSE .GE. 0 ) WRITE (NDSE,910) 294 CALL EXTCDE ( 1 ) 295 ! 296 801 CONTINUE 297 IF ( NDSE .GE. 0 ) WRITE (NDSE,911) IERR 298 CALL EXTCDE ( 2 ) 299 ! 300 802 CONTINUE 301 IF ( NDSE .GE. 0 ) WRITE (NDSE,911) IERR 302 CALL EXTCDE ( 3 ) 303 ! 304 ! Formats 305 ! 306 900 FORMAT (A) 307 910 FORMAT (/' *** WAVEWATCH III ERROR IN NEXTLN : '/ & 308 ' PREMATURE END OF INPUT FILE'/) 309 911 FORMAT (/' *** WAVEWATCH III ERROR IN NEXTLN : '/ & 310 ' ERROR IN READING FROM FILE'/ & 311 ' IOSTAT =',I5/) 312 912 FORMAT (/' *** WAVEWATCH III ERROR IN NEXTLN : '/ & 313 ' ERROR ON BACKSPACE'/ & 314 ' IOSTAT =',I5/) 315 !/ 316 !/ End of NEXTLN ----------------------------------------------------- / 317 !/ 318 END SUBROUTINE NEXTLN Page 9 Source Listing NEXTLN 2014-09-16 17:00 Entry Points w3servmd.f90 ENTRY POINTS Name w3servmd_mp_nextln_ SYMBOL CROSS REFERENCE Name Object Declared Type Bytes Dimen Elements Attributes References 100 Label 283 286 800 Label 292 284 801 Label 296 284 802 Label 300 288 900 Label 306 284 910 Label 307 293 911 Label 309 297,301 912 Label 312 CHCKC Dummy 220 CHAR 1 scalar ARG,IN 285 IERR Local 277 I(4) 4 scalar 284,288,297,301 NDSE Dummy 220 I(4) 4 scalar ARG,IN 293,297,301 NDSI Dummy 220 I(4) 4 scalar ARG,IN 284,288 NEXTLN Subr 220 TEST Local 278 CHAR 1 scalar 284,285 Page 10 Source Listing NEXTLN 2014-09-16 17:00 w3servmd.f90 319 !/ ------------------------------------------------------------------- / 320 SUBROUTINE W3S2XY ( NSEA, MSEA, MX, MY, S, MAPSF, XY ) 321 !/ 322 !/ +-----------------------------------+ 323 !/ | WAVEWATCH III NOAA/NMC | 324 !/ | H. L. Tolman | 325 !/ | FORTRAN 90 | 326 !/ | Last update : 23-Nov-1999 | 327 !/ +-----------------------------------+ 328 !/ 329 !/ 11-Dec-1996 : Final FORTRAN 77 ( version 1.18 ) 330 !/ 23-Nov-1999 : Upgrade to FORTRAN 90 ( version 2.00 ) 331 !/ 332 ! 1. Purpose : 333 ! 334 ! Convert a data array on the storage grid to a data array on the 335 ! full spatial grid. Land and ice points in the full grid are 336 ! not touched. Output array of conventional type XY(IX,IY). 337 ! 338 ! 3. Parameters : 339 ! 340 ! Parameter list 341 ! ---------------------------------------------------------------- 342 ! NSEA Int. I Number of sea points. 343 ! MSEA, MX, MY 344 ! Int. I Array dimensions. 345 ! S R.A. I Data on storage grid. 346 ! MAPSF I.A. I Storage map for IX and IY, resp. 347 ! XY R.A. O Data on XY grid. 348 ! ---------------------------------------------------------------- 349 ! 350 ! 4. Subroutines used : 351 ! 352 ! None. 353 ! 354 ! 5. Called by : 355 ! 356 ! Any WAVEWATCH III routine. 357 ! 358 ! 9. Switches : 359 ! 360 ! None. 361 ! 362 ! 10. Source code : 363 ! 364 !/ ------------------------------------------------------------------- / 365 IMPLICIT NONE 366 !/ 367 !/ ------------------------------------------------------------------- / 368 !/ Parameter list 369 !/ 370 INTEGER, INTENT(IN) :: MSEA, NSEA, MX, MY, MAPSF(MSEA,2) 371 REAL, INTENT(IN) :: S(MSEA) 372 REAL, INTENT(OUT) :: XY(MX,MY) 373 !/ 374 !/ ------------------------------------------------------------------- / 375 !/ Local parameters Page 11 Source Listing W3S2XY 2014-09-16 17:00 w3servmd.f90 376 !/ 377 INTEGER :: ISEA, IX, IY 378 !/ 379 !/ ------------------------------------------------------------------- / 380 !/ 381 DO 100, ISEA=1, NSEA 382 IX = MAPSF(ISEA,1) 383 IY = MAPSF(ISEA,2) 384 XY(IX,IY) = S(ISEA) 385 100 CONTINUE 386 !/ 387 !/ End of W3S2XY ----------------------------------------------------- / 388 !/ 389 END SUBROUTINE W3S2XY ENTRY POINTS Name w3servmd_mp_w3s2xy_ SYMBOL CROSS REFERENCE Name Object Declared Type Bytes Dimen Elements Attributes References 100 Label 385 381 ISEA Local 377 I(4) 4 scalar 381,382,383,384 IX Local 377 I(4) 4 scalar 382,384 IY Local 377 I(4) 4 scalar 383,384 MAPSF Dummy 320 I(4) 4 2 0 ARG,IN 382,383 MSEA Dummy 320 I(4) 4 scalar ARG,IN 370,371 MX Dummy 320 I(4) 4 scalar ARG,IN 372 MY Dummy 320 I(4) 4 scalar ARG,IN 372 NSEA Dummy 320 I(4) 4 scalar ARG,IN 381 S Dummy 320 R(4) 4 1 0 ARG,IN 384 W3S2XY Subr 320 XY Dummy 320 R(4) 4 2 0 ARG,OUT 384 Page 12 Source Listing W3S2XY 2014-09-16 17:00 w3servmd.f90 390 !/ ------------------------------------------------------------------- / 391 REAL FUNCTION EJ5P ( F, ALFA, FP, YLN, SIGA, SIGB ) 392 !/ 393 !/ +-----------------------------------+ 394 !/ | WAVEWATCH III NOAA/NCEP | 395 !/ | H. L. Tolman | 396 !/ | FORTRAN 90 | 397 !/ | Last update : 23-Nov-1999 | 398 !/ +-----------------------------------+ 399 !/ 400 !/ 23-AMy-1985 : Original by G. Ph. van Vledder. 401 !/ 23-Nov-1999 : Upgrade to FORTRAN 90 ( version 2.00 ) 402 !/ 403 ! 1. Purpose : 404 ! 405 ! Computation of spectral density using a 5-parameter 406 ! JONSWAP-spectrum 407 ! 408 ! 2. Method 409 ! 410 ! EJ5P(F) = A.EXP(B + LN(Y).EXP(C)) 411 ! 412 ! where: A = ALFA * 0.06175 * F**(-5) 413 ! B = -1.25*(FP/F)**4 414 ! C = -0.5 * ((F - FP)/(SIG * FP))**2 415 ! and 416 ! GRAV**2/(2.PI)**4 = 0.06175 417 ! 418 ! 3. Parameters : 419 ! 420 ! Parameter list 421 ! 422 ! ---------------------------------------------------------------- 423 ! F Real I Frequency in Hz 424 ! ALFA Real I Energy scaling factor 425 ! FP Real I Peak frequency in Hz 426 ! YLN Real I Peak overshoot factor, given by LN-value 427 ! SIGA Real I Spectral width, for F < FP 428 ! SIGB Real I Spectral width, FOR F > FP 429 ! ---------------------------------------------------------------- 430 ! 431 ! 4. Subroutines used : 432 ! 433 ! None. 434 ! 435 ! 5. Called by : 436 ! 437 ! Any. 438 ! 439 ! 6. Error messages : 440 ! 441 ! 7. Remarks : 442 ! 443 ! EXPMIN is a machine dependant constant such that 444 ! EXP(EXPMIN) can be successfully evaluated without 445 ! underflow by the compiler supllied EXP routine. 446 ! Page 13 Source Listing EJ5P 2014-09-16 17:00 w3servmd.f90 447 ! 8. Structure : 448 ! 449 ! See source code. 450 ! 451 ! 9. Switches : 452 ! 453 ! None. 454 ! 455 ! 10. Source code : 456 ! 457 !/ ------------------------------------------------------------------- / 458 IMPLICIT NONE 459 !/ 460 !/ ------------------------------------------------------------------- / 461 !/ Parameter list 462 !/ 463 REAL, INTENT(IN) :: F, ALFA, FP, YLN, SIGA, SIGB 464 !/ 465 !/ ------------------------------------------------------------------- / 466 !/ Local parameters 467 !/ 468 REAL :: SIG, A, B, C 469 REAL, SAVE :: EPS=1.E-4, EXPMIN=-180. 470 !/ 471 !/ ------------------------------------------------------------------- / 472 !/ 473 IF(F.LT.EPS) THEN 474 EJ5P = 0.0 475 RETURN 476 END IF 477 ! 478 A = ALFA * 0.06175 / F**5 479 B = -1.25 * (FP/F)**4 480 B = MAX(B,EXPMIN) 481 ! 482 IF (YLN.LT.EPS) THEN 483 EJ5P = A * EXP(B) 484 ELSE 485 IF( F.LE.FP) THEN 486 SIG = SIGA 487 ELSE 488 SIG = SIGB 489 END IF 490 C = -0.5 * ((F - FP)/(SIG * FP))**2 491 C = MAX(C,EXPMIN) 492 EJ5P = A * EXP(B + EXP(C) * YLN) 493 END IF 494 ! 495 RETURN 496 !/ 497 !/ End of NEXTLN ----------------------------------------------------- / 498 !/ 499 END FUNCTION Page 14 Source Listing EJ5P 2014-09-16 17:00 Entry Points w3servmd.f90 ENTRY POINTS Name w3servmd_mp_ej5p_ SYMBOL CROSS REFERENCE Name Object Declared Type Bytes Dimen Elements Attributes References A Local 468 R(4) 4 scalar 478,483,492 ALFA Dummy 391 R(4) 4 scalar ARG,IN 478 B Local 468 R(4) 4 scalar 479,480,483,492 C Local 468 R(4) 4 scalar 490,491,492 EJ5P Func 391 R(4) 4 scalar 474,483,492 EPS Local 469 R(4) 4 scalar 469,473,482 EXP Func 483 scalar 483,492 EXPMIN Local 469 R(4) 4 scalar 469,480,491 F Dummy 391 R(4) 4 scalar ARG,IN 473,478,479,485,490 FP Dummy 391 R(4) 4 scalar ARG,IN 479,485,490 MAX Func 480 scalar 480,491 SIG Local 468 R(4) 4 scalar 486,488,490 SIGA Dummy 391 R(4) 4 scalar ARG,IN 486 SIGB Dummy 391 R(4) 4 scalar ARG,IN 488 YLN Dummy 391 R(4) 4 scalar ARG,IN 482,492 Page 15 Source Listing EJ5P 2014-09-16 17:00 w3servmd.f90 500 !/ ------------------------------------------------------------------- / 501 SUBROUTINE WWDATE (STRNG) 502 !/ 503 !/ +-----------------------------------+ 504 !/ | WAVEWATCH III NOAA/NCEP | 505 !/ | H. L. Tolman | 506 !/ | FORTRAN 90 | 507 !/ | Last update : 26-Dec-2012 | 508 !/ +-----------------------------------+ 509 !/ 510 !/ 23-Dec-1998 : Final FORTRAN 77 ( version 1.18 ) 511 !/ 23-Nov-1999 : Upgrade to FORTRAN 90 ( version 2.00 ) 512 !/ 18-Sep-2000 : PGI switch added ( version 2.04 ) 513 !/ 13-Mar-2001 : LF95 switch added ( version 2.09 ) 514 !/ 08-May-2002 : Replace obsolete switches with F90 ( version 2.21 ) 515 !/ 26-Dec-2012 : Modified obsolete declarations. ( version 4.11 ) 516 !/ 517 ! 1. Purpose : 518 ! 519 ! Get date from machine dependent routine. 520 ! 521 ! 3. Parameters : 522 ! 523 ! Parameter list 524 ! ---------------------------------------------------------------- 525 ! STRNG C*10 O String with date in format YYYY/MM/DD 526 ! ---------------------------------------------------------------- 527 ! 528 ! 4. Subroutines used : 529 ! 530 ! Machine dependent. 531 ! 532 ! 5. Called by : 533 ! 534 ! Any routine. 535 ! 536 ! 9. Switches : 537 ! 538 ! !/DUM Dummy. 539 ! !/F90 FORTRAN 90 standard. 540 ! 541 ! 10. Source code : 542 ! 543 !/ ------------------------------------------------------------------- / 544 IMPLICIT NONE 545 !/ 546 !/ ------------------------------------------------------------------- / 547 !/ Parameter list 548 !/ 549 CHARACTER, INTENT(OUT) :: STRNG*10 550 !/ 551 !/ ------------------------------------------------------------------- / 552 !/ Local parameters 553 !/ 554 CHARACTER(LEN=8) :: DATE 555 CHARACTER(LEN=10) :: TIME 556 CHARACTER(LEN=5) :: ZONE Page 16 Source Listing WWDATE 2014-09-16 17:00 w3servmd.f90 557 INTEGER :: VALUES(8) 558 !/ 559 !/ ------------------------------------------------------------------- / 560 !/ 561 ! This is supposed to be standard F90 562 ! 563 STRNG = '----/--/--' 564 CALL DATE_AND_TIME ( DATE, TIME, ZONE, VALUES ) 565 STRNG(1:4) = DATE(1:4) 566 STRNG(6:7) = DATE(5:6) 567 STRNG(9:10) = DATE(7:8) 568 ! 569 ! Dummy alternative 570 ! 571 RETURN 572 !/ 573 !/ End of WWDATE ----------------------------------------------------- / 574 !/ 575 END SUBROUTINE WWDATE ENTRY POINTS Name w3servmd_mp_wwdate_ SYMBOL CROSS REFERENCE Name Object Declared Type Bytes Dimen Elements Attributes References DATE Local 554 CHAR 8 scalar 564,565,566,567 DATE_AND_TIME Intrin 564 564 STRNG Dummy 501 CHAR 10 scalar ARG,OUT 563,565,566,567 TIME Local 555 CHAR 10 scalar 564 VALUES Local 557 I(4) 4 1 8 564 WWDATE Subr 501 ZONE Local 556 CHAR 5 scalar 564 Page 17 Source Listing WWDATE 2014-09-16 17:00 w3servmd.f90 576 !/ ------------------------------------------------------------------- / 577 SUBROUTINE WWTIME (STRNG) 578 !/ 579 !/ +-----------------------------------+ 580 !/ | WAVEWATCH III NOAA/NCEP | 581 !/ | H. L. Tolman | 582 !/ | FORTRAN 90 | 583 !/ | Last update : 26-Dec-2012 | 584 !/ +-----------------------------------+ 585 !/ 586 !/ 23-Dec-1998 : Final FORTRAN 77 ( version 1.18 ) 587 !/ 23-Nov-1999 : Upgrade to FORTRAN 90 ( version 2.00 ) 588 !/ 18-Sep-2000 : PGI switch added ( version 2.04 ) 589 !/ 13-Mar-2001 : LF95 switch added ( version 2.09 ) 590 !/ 08-May-2002 : Replace obsolete switches with F90 ( version 2.21 ) 591 !/ 26-Dec-2012 : Modified obsolete declarations. ( version 4.11 ) 592 !/ 593 ! 1. Purpose : 594 ! 595 ! Get time from machine dependent routine. 596 ! 597 ! 2. Method : 598 ! 599 ! 3. Parameters : 600 ! 601 ! Parameter list 602 ! ---------------------------------------------------------------- 603 ! STRNG C*8 O String with time in format hh:mm:ss 604 ! ---------------------------------------------------------------- 605 ! 606 ! 4. Subroutines used : 607 ! 608 ! Machine dependent. 609 ! 610 ! 5. Called by : 611 ! 612 ! Any routine. 613 ! 614 ! 9. Switches : 615 ! 616 ! !/DUM Dummy. 617 ! !/F90 FORTRAN 90 standard. 618 ! 619 ! 10. Source code : 620 ! 621 !/ ------------------------------------------------------------------- / 622 IMPLICIT NONE 623 !/ 624 !/ ------------------------------------------------------------------- / 625 !/ Parameter list 626 !/ 627 CHARACTER, INTENT(OUT) :: STRNG*8 628 !/ 629 !/ ------------------------------------------------------------------- / 630 !/ Local parameters 631 !/ 632 CHARACTER(LEN=8) :: DATE Page 18 Source Listing WWTIME 2014-09-16 17:00 w3servmd.f90 633 CHARACTER(LEN=10) :: TIME 634 CHARACTER(LEN=5) :: ZONE 635 INTEGER :: VALUES(8) 636 !/ 637 !/ ------------------------------------------------------------------- / 638 !/ 639 ! This is supposed to be standard F90 640 ! 641 STRNG = '--:--:--' 642 CALL DATE_AND_TIME ( DATE, TIME, ZONE, VALUES ) 643 STRNG(1:2) = TIME(1:2) 644 STRNG(4:5) = TIME(3:4) 645 STRNG(7:8) = TIME(5:6) 646 ! 647 ! Dummy alternative 648 ! 649 RETURN 650 !/ 651 !/ End of WWTIME ----------------------------------------------------- / 652 !/ 653 END SUBROUTINE WWTIME ENTRY POINTS Name w3servmd_mp_wwtime_ Page 19 Source Listing WWTIME 2014-09-16 17:00 Symbol Table w3servmd.f90 SYMBOL CROSS REFERENCE Name Object Declared Type Bytes Dimen Elements Attributes References DATE Local 632 CHAR 8 scalar 642 DATE_AND_TIME Intrin 642 642 STRNG Dummy 577 CHAR 8 scalar ARG,OUT 641,643,644,645 TIME Local 633 CHAR 10 scalar 642,643,644,645 VALUES Local 635 I(4) 4 1 8 642 WWTIME Subr 577 ZONE Local 634 CHAR 5 scalar 642 Page 20 Source Listing WWTIME 2014-09-16 17:00 w3servmd.f90 654 !/ ------------------------------------------------------------------- / 655 SUBROUTINE EXTCDE ( IEXIT ) 656 !/ 657 !/ +-----------------------------------+ 658 !/ | WAVEWATCH III NOAA/NCEP | 659 !/ | H. L. Tolman | 660 !/ | FORTRAN 90 | 661 !/ | Last update : 06-Jan-1999 | 662 !/ +-----------------------------------+ 663 !/ 664 !/ 06-Jan-1998 : Final FORTRAN 77 ( version 1.18 ) 665 !/ 23-Nov-1999 : Upgrade to FORTRAN 90 ( version 2.00 ) 666 !/ 667 ! 1. Purpose : 668 ! 669 ! Perfor a program stop with an exit code. 670 ! 671 ! 2. Method : 672 ! 673 ! Machine dependent. 674 ! 675 ! 3. Parameters : 676 ! 677 ! Parameter list 678 ! ---------------------------------------------------------------- 679 ! IEXIT Int. I Exit code to be used. 680 ! ---------------------------------------------------------------- 681 ! 682 ! 4. Subroutines used : 683 ! 684 ! 5. Called by : 685 ! 686 ! Any. 687 ! 688 ! 9. Switches : 689 ! 690 ! !/MPI MPI finalize interface if active 691 ! 692 ! 10. Source code : 693 ! 694 !/ ------------------------------------------------------------------- / 695 IMPLICIT NONE 696 ! 697 !/ 698 !/ ------------------------------------------------------------------- / 699 !/ Parameter list 700 !/ 701 INTEGER, INTENT(IN) :: IEXIT 702 !/ 703 !/ ------------------------------------------------------------------- / 704 !/ 705 !/ 706 !/ Test if MPI needs to be closed 707 !/ 708 ! 709 CALL EXIT ( IEXIT ) 710 !/ Page 21 Source Listing EXTCDE 2014-09-16 17:00 w3servmd.f90 711 !/ End of EXTCDE ----------------------------------------------------- / 712 !/ 713 END SUBROUTINE EXTCDE ENTRY POINTS Name w3servmd_mp_extcde_ SYMBOL CROSS REFERENCE Name Object Declared Type Bytes Dimen Elements Attributes References EXIT Intrin 709 709 EXTCDE Subr 655 294,298,302 IEXIT Dummy 655 I(4) 4 scalar ARG,IN 709 Page 22 Source Listing EXTCDE 2014-09-16 17:00 w3servmd.f90 714 !/ ------------------------------------------------------------------- / 715 SUBROUTINE PRINIT 716 !/ 717 !/ +-----------------------------------+ 718 !/ | WAVEWATCH III NOAA/NCEP | 719 !/ | H. L. Tolman | 720 !/ | FORTRAN 90 | 721 !/ | Last update : 06-May-2005 ! 722 !/ +-----------------------------------+ 723 !/ 724 !/ 06-May-2005 : Origination. ( version 3.07 ) 725 !/ 726 ! 1. Purpose : 727 ! 728 ! Initialize profilinf routine PRTIME. 729 ! 730 ! 2. Method : 731 ! 732 ! FORTRAN 90 SYSTEM_CLOCK intrinsic routine. 733 ! 734 ! 3. Parameters : 735 ! 736 ! Parameter list 737 ! ---------------------------------------------------------------- 738 ! ---------------------------------------------------------------- 739 ! 740 ! 4. Subroutines used : 741 ! 742 ! Name Type Module Description 743 ! ---------------------------------------------------------------- 744 ! SYSTEM_CLOCK 745 ! Sur. n/a Get system time ( !/F90 ) 746 ! ---------------------------------------------------------------- 747 ! 748 ! 5. Called by : 749 ! 750 ! 6. Error messages : 751 ! 752 ! 7. Remarks : 753 ! 754 ! 8. Structure : 755 ! 756 ! 9. Switches : 757 ! 758 ! !/F90 FORTRAN 90 specific calls. 759 ! 760 ! 10. Source code : 761 ! 762 !/ ------------------------------------------------------------------- / 763 IMPLICIT NONE 764 !/ 765 ! -------------------------------------------------------------------- / 766 ! 767 CALL SYSTEM_CLOCK ( PRFTB ) 768 ! 769 FLPROF = .TRUE. 770 ! Page 23 Source Listing PRINIT 2014-09-16 17:00 w3servmd.f90 771 RETURN 772 !/ 773 !/ End of PRINIT ----------------------------------------------------- / 774 !/ 775 END SUBROUTINE PRINIT ENTRY POINTS Name w3servmd_mp_prinit_ SYMBOL CROSS REFERENCE Name Object Declared Type Bytes Dimen Elements Attributes References FLPROF Local 769 L(4) 4 scalar PRIV 83,769,847 PRFTB Local 767 I(4) 4 scalar PRIV 82,767,851,852,854 PRINIT Subr 715 SYSTEM_CLOCK Intrin 767 767 Page 24 Source Listing PRINIT 2014-09-16 17:00 w3servmd.f90 776 !/ ------------------------------------------------------------------- / 777 SUBROUTINE PRTIME ( PTIME ) 778 !/ 779 !/ +-----------------------------------+ 780 !/ | WAVEWATCH III NOAA/NCEP | 781 !/ | H. L. Tolman | 782 !/ | FORTRAN 90 | 783 !/ | Last update : 06-May-2005 ! 784 !/ +-----------------------------------+ 785 !/ 786 !/ 06-May-2005 : Origination. ( version 3.07 ) 787 !/ 788 ! 1. Purpose : 789 ! 790 ! Get wallclock time for profiling purposes. 791 ! 792 ! 2. Method : 793 ! 794 ! FORTRAN 90 SYSTEM_CLOCK intrinsic routine. 795 ! 796 ! 3. Parameters : 797 ! 798 ! Parameter list 799 ! ---------------------------------------------------------------- 800 ! PTIME Real O Time retrieced from system. 801 ! ---------------------------------------------------------------- 802 ! 803 ! 4. Subroutines used : 804 ! 805 ! Name Type Module Description 806 ! ---------------------------------------------------------------- 807 ! SYSTEM_CLOCK 808 ! Sur. n/a Get system time ( !/F90 ) 809 ! ---------------------------------------------------------------- 810 ! 811 ! 5. Called by : 812 ! 813 ! Any, after PRINIT has been called. 814 ! 815 ! 6. Error messages : 816 ! 817 ! - If no initialization, returned time equals -1. 818 ! - If no system clock, returned time equals -1. 819 ! 820 ! 7. Remarks : 821 ! 822 ! 8. Structure : 823 ! 824 ! 9. Switches : 825 ! 826 ! !/F90 FORTRAN 90 specific calls. 827 ! 828 ! 10. Source code : 829 ! 830 !/ ------------------------------------------------------------------- / 831 IMPLICIT NONE 832 !/ Page 25 Source Listing PRTIME 2014-09-16 17:00 w3servmd.f90 833 !/ ------------------------------------------------------------------- / 834 !/ Parameter list 835 !/ 836 REAL, INTENT(OUT) :: PTIME 837 !/ 838 !/ ------------------------------------------------------------------- / 839 !/ Local parameters 840 !/ 841 INTEGER :: PRFTA, PRFINC, PRFMAX, PRFDT 842 ! 843 ! -------------------------------------------------------------------- / 844 ! 845 PTIME = -1. 846 ! 847 IF ( .NOT. FLPROF ) RETURN 848 ! 849 CALL SYSTEM_CLOCK ( PRFTA, PRFINC, PRFMAX ) 850 IF ( PRFMAX .NE. 0 ) THEN 851 IF ( PRFTA-PRFTB .GE. 0 ) THEN 852 PRFDT = PRFTA-PRFTB 853 ELSE 854 PRFDT = PRFTA-PRFTB + PRFMAX 855 END IF 856 PTIME = REAL(PRFDT)/REAL(PRFINC) 857 END IF 858 ! 859 RETURN 860 !/ 861 !/ End of PRTIME ----------------------------------------------------- / 862 !/ 863 END SUBROUTINE PRTIME Page 26 Source Listing PRTIME 2014-09-16 17:00 Entry Points w3servmd.f90 ENTRY POINTS Name w3servmd_mp_prtime_ SYMBOL CROSS REFERENCE Name Object Declared Type Bytes Dimen Elements Attributes References PRFDT Local 841 I(4) 4 scalar 852,854,856 PRFINC Local 841 I(4) 4 scalar 849,856 PRFMAX Local 841 I(4) 4 scalar 849,850,854 PRFTA Local 841 I(4) 4 scalar 849,851,852,854 PRTIME Subr 777 PTIME Dummy 777 R(4) 4 scalar ARG,OUT 845,856 REAL Func 856 scalar 856 SYSTEM_CLOCK Intrin 849 849 Page 27 Source Listing PRTIME 2014-09-16 17:00 w3servmd.f90 864 !/ ------------------------------------------------------------------- / 865 ! +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ 866 ! This subroutine turn the wave spectrum by an fixed angle anti-clockwise 867 ! so that it may be used in the rotated or stanadard system. 868 ! First created: 26 Aug 2005 Jian-Guo Li 869 ! Last modified: 21 Feb 2008 Jian-Guo Li 870 ! 871 ! Subroutine Interface: 872 873 Subroutine w3spectn( NFreq, NDirc, Alpha, Spectr ) 874 875 ! Description: 876 ! Rotates wave spectrum anticlockwise by angle alpha in degree 877 ! 878 ! Subroutine arguments 879 IMPLICIT NONE 880 INTEGER, INTENT(IN) :: NFreq, NDirc ! No. frequ and direc bins 881 REAL, INTENT(IN) :: Alpha ! Turning angle in degree 882 REAL, INTENT(INOUT) :: Spectr(NFreq,NDirc) ! Wave spectrum in and out 883 884 ! Local variables 885 INTEGER :: ii, jj, kk, nsft 886 REAL :: Ddirc, frac, CNST 887 REAL, Dimension(NFreq) :: Wrkfrq, Tmpfrq 888 REAL, Dimension(NFreq,NDirc):: Wrkspc 889 890 ! Check input bin numbers 891 IF( (NFreq .LT. 0) .OR. (NDirc .LT. 0) ) THEN 892 PRINT*, " Invalid bin number NF or ND", NFreq, NDirc 893 RETURN 894 ELSE 895 Ddirc=360.0/FLOAT(NDirc) 896 ENDIF 897 898 ! Work out shift bin number and fraction 899 900 CNST=Alpha/Ddirc 901 nsft=INT( CNST ) 902 frac= CNST - FLOAT( nsft ) 903 ! PRINT*, ' nsft and frac =', nsft, frac 904 905 ! Shift nsft bins if >=1 906 IF( ABS(nsft) .GE. 1 ) THEN 907 DO ii=1, NDirc 908 909 ! Wave spectral direction bin number is assumed to increase Anti-clockwise from EAST 910 ! So shift nsft bins anticlockwise results in local bin number Decreases by nsft 911 jj=ii - nsft 912 913 ! As nsft may be either positive or negative depends on alpha, wrapping may 914 ! happen in either ends of the bin number train 915 IF( jj > NDirc ) jj=jj - NDirc 916 IF( jj < 1 ) jj=jj + NDirc 917 918 ! Copy the selected bin to the loop bin number 919 Wrkspc(:,ii)=Spectr(:,jj) 920 Page 28 Source Listing W3SPECTN 2014-09-16 17:00 w3servmd.f90 921 Enddo 922 923 ! If nsft=0, no need to shift, simply copy 924 ELSE 925 Wrkspc = Spectr 926 ENDIF 927 928 ! Pass fraction of wave energy in frac direction 929 ! Wave spectral direction bin number is assumed to increase Anti-clockwise from EAST 930 ! So Positive frac or anticlock case, smaller bin upstream 931 IF( frac > 0.0 ) THEN 932 Tmpfrq=Wrkspc(:,NDirc)*frac 933 DO kk=1, NDirc 934 Wrkfrq=Wrkspc(:,kk)*frac 935 Spectr(:,kk)=Wrkspc(:,kk) - Wrkfrq + Tmpfrq 936 Tmpfrq=Wrkfrq 937 ENDDO 938 ELSE 939 ! Negative or clockwise case, larger bin upstream 940 Tmpfrq=Wrkspc(:,1)*frac 941 DO kk=NDirc, 1, -1 942 Wrkfrq=Wrkspc(:,kk)*frac 943 Spectr(:,kk)=Wrkspc(:,kk) + Wrkfrq - Tmpfrq 944 Tmpfrq=Wrkfrq 945 ENDDO 946 ENDIF 947 948 ! Speasturn completed 949 950 Return 951 End Subroutine w3spectn Page 29 Source Listing W3SPECTN 2014-09-16 17:00 Entry Points w3servmd.f90 ENTRY POINTS Name w3servmd_mp_w3spectn_ SYMBOL CROSS REFERENCE Name Object Declared Type Bytes Dimen Elements Attributes References ABS Func 906 scalar 906 ALPHA Dummy 873 R(4) 4 scalar ARG,IN 900 CNST Local 886 R(4) 4 scalar 900,901,902 DDIRC Local 886 R(4) 4 scalar 895,900 FLOAT Func 895 scalar 895,902 FRAC Local 886 R(4) 4 scalar 902,931,932,934,940,942 II Local 885 I(4) 4 scalar 907,911,919 INT Func 901 scalar 901 JJ Local 885 I(4) 4 scalar 911,915,916,919 KK Local 885 I(4) 4 scalar 933,934,935,941,942,943 NDIRC Dummy 873 I(4) 4 scalar ARG,IN 882,888,891,892,895,907,915,916,93 2,933,941 NFREQ Dummy 873 I(4) 4 scalar ARG,IN 882,887,888,891,892 NSFT Local 885 I(4) 4 scalar 901,902,906,911 SPECTR Dummy 873 R(4) 4 2 0 ARG,INOUT 919,925,935,943 TMPFRQ Local 887 R(4) 4 1 0 932,935,936,940,943,944 W3SPECTN Subr 873 WRKFRQ Local 887 R(4) 4 1 0 934,935,936,942,943,944 WRKSPC Local 888 R(4) 4 2 0 919,925,932,934,935,940,942,943 Page 30 Source Listing W3SPECTN 2014-09-16 17:00 w3servmd.f90 952 ! 953 ! +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ 954 ! This subroutine turn the wave action by an angle (deg) anti-clockwise 955 ! so that it may be used in the rotated or stanadard system. 956 ! First created: 26 Aug 2005 Jian-Guo Li 957 ! Last modified: 9 Oct 2008 Jian-Guo Li 958 ! 959 ! Subroutine Interface: 960 961 Subroutine w3acturn( NDirc, NFreq, Alpha, Spectr ) 962 963 ! Description: 964 ! Rotates wave spectrum anticlockwise by angle alpha 965 ! 966 ! Subroutine arguments 967 IMPLICIT NONE 968 INTEGER, INTENT(IN) :: NFreq, NDirc ! No. frequ and direc bins 969 REAL, INTENT(IN) :: Alpha ! Turning angle in degree 970 REAL, INTENT(INOUT) :: Spectr(NDirc, NFreq) ! Wave action in and out 971 972 ! Local variables 973 INTEGER :: ii, jj, kk, nsft 974 REAL :: Ddirc, frac, CNST 975 REAL, Dimension(NFreq) :: Wrkfrq, Tmpfrq 976 REAL, Dimension(NDirc,NFreq):: Wrkspc 977 978 ! Check input bin numbers 979 IF( (NFreq .LT. 0) .OR. (NDirc .LT. 0) ) THEN 980 PRINT*, " Invalid bin number NF or ND", NFreq, NDirc 981 RETURN 982 ELSE 983 Ddirc=360.0/FLOAT(NDirc) 984 ENDIF 985 986 ! Work out shift bin number and fraction 987 988 CNST=Alpha/Ddirc 989 nsft=INT( CNST ) 990 frac= CNST - FLOAT( nsft ) 991 ! PRINT*, ' nsft and frac =', nsft, frac 992 993 ! Shift nsft bins if >=1 994 IF( ABS(nsft) .GE. 1 ) THEN 995 DO ii=1, NDirc 996 997 ! Wave spectral direction bin number is assumed to increase Anti-clockwise from EAST 998 ! So shift nsft bins anticlockwise results in local bin number Decreases by nsft 999 jj=ii - nsft 1000 1001 ! As nsft may be either positive or negative depends on alpha, wrapping may 1002 ! happen in either ends of the bin number train 1003 IF( jj > NDirc ) jj=jj - NDirc 1004 IF( jj < 1 ) jj=jj + NDirc 1005 1006 ! Copy the selected bin to the loop bin number 1007 Wrkspc(ii,:)=Spectr(jj,:) 1008 Page 31 Source Listing W3ACTURN 2014-09-16 17:00 w3servmd.f90 1009 Enddo 1010 1011 ! If nsft=0, no need to shift, simply copy 1012 ELSE 1013 Wrkspc = Spectr 1014 ENDIF 1015 1016 ! Pass fraction of wave energy in frac direction 1017 ! Wave spectral direction bin number is assumed to increase Anti-clockwise from EAST 1018 ! So Positive frac or anticlock case, smaller bin upstream 1019 IF( frac > 0.0 ) THEN 1020 Tmpfrq=Wrkspc(NDirc,:)*frac 1021 DO kk=1, NDirc 1022 Wrkfrq=Wrkspc(kk,:)*frac 1023 Spectr(kk,:)=Wrkspc(kk,:) - Wrkfrq + Tmpfrq 1024 Tmpfrq=Wrkfrq 1025 ENDDO 1026 ELSE 1027 ! Negative or clockwise case, larger bin upstream 1028 Tmpfrq=Wrkspc(1,:)*frac 1029 DO kk=NDirc, 1, -1 1030 Wrkfrq=Wrkspc(kk,:)*frac 1031 Spectr(kk,:)=Wrkspc(kk,:) + Wrkfrq - Tmpfrq 1032 Tmpfrq=Wrkfrq 1033 ENDDO 1034 ENDIF 1035 1036 ! Spectral turning completed 1037 1038 Return 1039 End Subroutine w3acturn Page 32 Source Listing W3ACTURN 2014-09-16 17:00 Entry Points w3servmd.f90 ENTRY POINTS Name w3servmd_mp_w3acturn_ SYMBOL CROSS REFERENCE Name Object Declared Type Bytes Dimen Elements Attributes References ABS Func 994 scalar 994 ALPHA Dummy 961 R(4) 4 scalar ARG,IN 988 CNST Local 974 R(4) 4 scalar 988,989,990 DDIRC Local 974 R(4) 4 scalar 983,988 FLOAT Func 983 scalar 983,990 FRAC Local 974 R(4) 4 scalar 990,1019,1020,1022,1028,1030 II Local 973 I(4) 4 scalar 995,999,1007 INT Func 989 scalar 989 JJ Local 973 I(4) 4 scalar 999,1003,1004,1007 KK Local 973 I(4) 4 scalar 1021,1022,1023,1029,1030,1031 NDIRC Dummy 961 I(4) 4 scalar ARG,IN 970,976,979,980,983,995,1003,1004, 1020,1021,1029 NFREQ Dummy 961 I(4) 4 scalar ARG,IN 970,975,976,979,980 NSFT Local 973 I(4) 4 scalar 989,990,994,999 SPECTR Dummy 961 R(4) 4 2 0 ARG,INOUT 1007,1013,1023,1031 TMPFRQ Local 975 R(4) 4 1 0 1020,1023,1024,1028,1031,1032 W3ACTURN Subr 961 WRKFRQ Local 975 R(4) 4 1 0 1022,1023,1024,1030,1031,1032 WRKSPC Local 976 R(4) 4 2 0 1007,1013,1020,1022,1023,1028,1030 ,1031 Page 33 Source Listing W3ACTURN 2014-09-16 17:00 w3servmd.f90 1040 ! 1041 !Li +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ 1042 !Li 1043 !Li Merged UM source code for rotated grid, consisting the following 1044 !Li original subroutines in UM 6.1 1045 !Li LLTOEQ1A WCOEFF1A and LBCROTWINDS1 1046 !Li The last subroutine is modified to process only one level winds 1047 !Li cpp directives are removed and required header C_Pi.h inserted. 1048 !Li Jian-Guo Li 26 May 2005 1049 !Li 1050 !Li The WCOEFF1A subroutine is merged into LLTOEQ to reduce repetition 1051 !Li of the same calculations. Subroutine interface changed to 1052 !Li LLTOEQANGLE 1053 !Li Jian-GUo Li 23 Aug 2005 1054 !Li 1055 !Li Subroutine W3LLTOEQ -------------------------------------------- 1056 !Li 1057 !Li Purpose: Calculates latitude and longitude on equatorial 1058 !Li latitude-longitude (eq) grid used in regional 1059 !Li models from input arrays of latitude and 1060 !Li longitude on standard grid. Both input and output 1061 !Li latitudes and longitudes are in degrees. 1062 !Li Also calculate rotation angle in degree to tranform 1063 !Li standard wind velocity into equatorial wind. 1064 !Li Valid for 0= 0.0) THEN 1108 SIN_PHI_POLE = SIN(PI_OVER_180*PHI_POLE) 1109 COS_PHI_POLE = COS(PI_OVER_180*PHI_POLE) 1110 ELSE 1111 SIN_PHI_POLE = -SIN(PI_OVER_180*PHI_POLE) 1112 COS_PHI_POLE = -COS(PI_OVER_180*PHI_POLE) 1113 ENDIF 1114 1115 ! 2. Transform from standard to equatorial latitude-longitude 1116 1117 DO 200 I= 1, POINTS 1118 1119 ! Scale longitude to range -180 to +180 degs 1120 1121 A_LAMBDA=LAMBDA(I)-LAMBDA_ZERO 1122 IF(A_LAMBDA.GT. 180.0) A_LAMBDA=A_LAMBDA-360. 1123 IF(A_LAMBDA.LE.-180.0) A_LAMBDA=A_LAMBDA+360. 1124 1125 ! Convert latitude & longitude to radians 1126 1127 A_LAMBDA=PI_OVER_180*A_LAMBDA 1128 A_PHI=PI_OVER_180*PHI(I) 1129 1130 ! Compute eq latitude using equation (4.4) 1131 1132 ARG=-COS_PHI_POLE*COS(A_PHI)*COS(A_LAMBDA) & 1133 & +SIN_PHI_POLE*SIN(A_PHI) 1134 ARG=MIN(ARG, 1.0) 1135 ARG=MAX(ARG,-1.0) 1136 E_PHI=ASIN(ARG) 1137 PHI_EQ(I)=RECIP_PI_OVER_180*E_PHI 1138 1139 ! Compute eq longitude using equation (4.6) 1140 1141 TERM1 = SIN_PHI_POLE*COS(A_PHI)*COS(A_LAMBDA) & 1142 & +COS_PHI_POLE*SIN(A_PHI) 1143 TERM2 = COS(E_PHI) 1144 IF(TERM2 .LT. SMALL) THEN 1145 E_LAMBDA=0.0 1146 ELSE 1147 ARG=TERM1/TERM2 1148 ARG=MIN(ARG, 1.0) 1149 ARG=MAX(ARG,-1.0) 1150 E_LAMBDA=RECIP_PI_OVER_180*ACOS(ARG) 1151 E_LAMBDA=SIGN(E_LAMBDA,A_LAMBDA) 1152 ENDIF 1153 Page 35 Source Listing W3LLTOEQ 2014-09-16 17:00 w3servmd.f90 1154 ! Scale longitude to range 0 to 360 degs 1155 1156 IF(E_LAMBDA.GE.360.0) E_LAMBDA=E_LAMBDA-360.0 1157 IF(E_LAMBDA.LT. 0.0) E_LAMBDA=E_LAMBDA+360.0 1158 LAMBDA_EQ(I)=E_LAMBDA 1159 1160 !Li Calculate turning angle for standard wind velocity 1161 1162 E_LAMBDA=PI_OVER_180*LAMBDA_EQ(I) 1163 1164 ! Formulae used are from eqs (4.19) and (4.21) 1165 1166 TERM2=SIN(E_LAMBDA) 1167 ARG= SIN(A_LAMBDA)*TERM2*SIN_PHI_POLE & 1168 & +COS(A_LAMBDA)*COS(E_LAMBDA) 1169 ARG=MIN(ARG, 1.0) 1170 ARG=MAX(ARG,-1.0) 1171 TERM1=RECIP_PI_OVER_180*ACOS(ARG) 1172 ANGLED(I)=SIGN(TERM1,TERM2) 1173 !Li 1174 1175 200 CONTINUE 1176 1177 ! Reset Lambda pole to the setting on entry to subroutine 1178 LAMBDA_POLE=LAMBDA_POLE_KEEP 1179 1180 RETURN 1181 END SUBROUTINE W3LLTOEQ Page 36 Source Listing W3LLTOEQ 2014-09-16 17:00 Entry Points w3servmd.f90 ENTRY POINTS Name w3servmd_mp_w3lltoeq_ SYMBOL CROSS REFERENCE Name Object Declared Type Bytes Dimen Elements Attributes References 200 Label 1175 1117 ACOS Func 1150 scalar 1150,1171 ANGLED Dummy 1068 R(4) 4 1 0 ARG,INOUT 1172 ARG Local 1086 R(4) 4 scalar 1132,1134,1135,1136,1147,1148,1149 ,1150,1167,1169,1170,1171 ASIN Func 1136 scalar 1136 A_LAMBDA Local 1085 R(4) 4 scalar 1121,1122,1123,1127,1132,1141,1151 ,1167,1168 A_PHI Local 1085 R(4) 4 scalar 1128,1132,1133,1141,1142 COS Func 1109 scalar 1109,1112,1132,1141,1143,1168 COS_PHI_POLE Local 1085 R(4) 4 scalar 1109,1112,1132,1142 E_LAMBDA Local 1085 R(4) 4 scalar 1145,1150,1151,1156,1157,1158,1162 ,1166,1168 E_PHI Local 1085 R(4) 4 scalar 1136,1137,1143 I Local 1087 I(4) 4 scalar 1117,1121,1128,1137,1158,1162,1172 LAMBDA Dummy 1067 R(4) 4 1 0 ARG,INOUT 1121 LAMBDA_EQ Dummy 1067 R(4) 4 1 0 ARG,INOUT 1158,1162 LAMBDA_POLE Dummy 1068 R(4) 4 scalar ARG,INOUT 1100,1101,1102,1105,1178 LAMBDA_POLE_KEEP Local 1086 R(4) 4 scalar 1100,1178 LAMBDA_ZERO Local 1086 R(4) 4 scalar 1105,1121 MAX Func 1135 scalar 1135,1149,1170 MIN Func 1134 scalar 1134,1148,1169 PHI Dummy 1067 R(4) 4 1 0 ARG,INOUT 1128 PHI_EQ Dummy 1067 R(4) 4 1 0 ARG,INOUT 1137 PHI_POLE Dummy 1068 R(4) 4 scalar ARG,INOUT 1107,1108,1109,1111,1112 PI Param 1092 R(4) 4 scalar 1093,1094 PI_OVER_180 Param 1093 R(4) 4 scalar 1108,1109,1111,1112,1127,1128,1162 POINTS Dummy 1068 I(4) 4 scalar ARG,INOUT 1078,1079,1080,1081,1082,1117 RECIP_PI_OVER_180 Param 1094 R(4) 4 scalar 1137,1150,1171 SIGN Func 1151 scalar 1151,1172 SIN Func 1108 scalar 1108,1111,1133,1142,1166,1167 SIN_PHI_POLE Local 1085 R(4) 4 scalar 1108,1111,1133,1141,1167 SMALL Param 1088 R(4) 4 scalar 1144 TERM1 Local 1086 R(4) 4 scalar 1141,1147,1171,1172 TERM2 Local 1086 R(4) 4 scalar 1143,1144,1147,1166,1167,1172 W3LLTOEQ Subr 1067 Page 37 Source Listing W3LLTOEQ 2014-09-16 17:00 w3servmd.f90 1182 ! 1183 !Li +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ 1184 !Li 1185 !Li Merged UM source code for rotated grid, consiting the following 1186 !Li original subroutines in UM 6.1 1187 !Li EQTOLL1A WCOEFF1A and LBCROTWINDS1 1188 !Li The last subroutine is modified to process only one level winds 1189 !Li cpp directives are removed and required header C_Pi.h inserted. 1190 !Li Jian-Guo Li 26 May 2005 1191 !Li 1192 !Li The WCOEFF1A subroutine is merged into EQTOLL to reduce repetition 1193 !Li of the same calculations. Subroutine interface changed to 1194 !Li EQTOLLANGLE 1195 !Li First created: Jian-GUo Li 23 Aug 2005 1196 !Li Last modified: Jian-GUo Li 25 Feb 2008 1197 !Li 1198 !Li Subroutine W3EQTOLL -------------------------------------------- 1199 !Li 1200 !Li Purpose: Calculates latitude and longitude on standard grid 1201 !Li from input arrays of latitude and longitude on 1202 !Li equatorial latitude-longitude (eq) grid used 1203 !Li in regional models. Both input and output latitudes 1204 !Li and longitudes are in degrees. 1205 !Li Also calculate rotation angle in degree to tranform 1206 !Li standard wind velocity into equatorial wind. 1207 !Li Valid for 0= 0.0) THEN 1250 SIN_PHI_POLE = SIN(PI_OVER_180*PHI_POLE) 1251 COS_PHI_POLE = COS(PI_OVER_180*PHI_POLE) 1252 ELSE 1253 SIN_PHI_POLE = -SIN(PI_OVER_180*PHI_POLE) 1254 COS_PHI_POLE = -COS(PI_OVER_180*PHI_POLE) 1255 ENDIF 1256 1257 ! 2. Transform from equatorial to standard latitude-longitude 1258 1259 DO 200 I= 1, POINTS 1260 1261 ! Scale eq longitude to range -180 to +180 degs 1262 1263 E_LAMBDA=LAMBDA_EQ(I) 1264 IF(E_LAMBDA.GT. 180.0) E_LAMBDA=E_LAMBDA-360.0 1265 IF(E_LAMBDA.LT.-180.0) E_LAMBDA=E_LAMBDA+360.0 1266 1267 ! Convert eq latitude & longitude to radians 1268 1269 E_LAMBDA=PI_OVER_180*E_LAMBDA 1270 E_PHI=PI_OVER_180*PHI_EQ(I) 1271 1272 ! Compute latitude using equation (4.7) 1273 1274 ARG=COS_PHI_POLE*COS(E_PHI)*COS(E_LAMBDA) & 1275 & +SIN_PHI_POLE*SIN(E_PHI) 1276 ARG=MIN(ARG, 1.0) 1277 ARG=MAX(ARG,-1.0) 1278 A_PHI=ASIN(ARG) 1279 PHI(I)=RECIP_PI_OVER_180*A_PHI 1280 1281 ! Compute longitude using equation (4.8) 1282 1283 TERM1 = COS(E_PHI)*SIN_PHI_POLE*COS(E_LAMBDA) & 1284 & -SIN(E_PHI)*COS_PHI_POLE 1285 TERM2 = COS(A_PHI) 1286 IF(TERM2.LT.SMALL) THEN 1287 A_LAMBDA=0.0 1288 ELSE 1289 ARG=TERM1/TERM2 1290 ARG=MIN(ARG, 1.0) 1291 ARG=MAX(ARG,-1.0) 1292 A_LAMBDA=RECIP_PI_OVER_180*ACOS(ARG) 1293 A_LAMBDA=SIGN(A_LAMBDA,E_LAMBDA) 1294 A_LAMBDA=A_LAMBDA+LAMBDA_ZERO 1295 END IF Page 39 Source Listing W3EQTOLL 2014-09-16 17:00 w3servmd.f90 1296 1297 ! Scale longitude to range 0 to 360 degs 1298 1299 IF(A_LAMBDA.GE.360.0) A_LAMBDA=A_LAMBDA-360.0 1300 IF(A_LAMBDA.LT. 0.0) A_LAMBDA=A_LAMBDA+360.0 1301 LAMBDA(I)=A_LAMBDA 1302 1303 !Li Calculate turning angle for standard wind velocity 1304 1305 A_LAMBDA=PI_OVER_180*(LAMBDA(I)-LAMBDA_ZERO) 1306 1307 ! Formulae used are from eqs (4.19) and (4.21) 1308 1309 TERM2=SIN(E_LAMBDA) 1310 ARG=SIN(A_LAMBDA)*TERM2*SIN_PHI_POLE & 1311 & +COS(A_LAMBDA)*COS(E_LAMBDA) 1312 ARG=MIN(ARG, 1.0) 1313 ARG=MAX(ARG,-1.0) 1314 TERM1=RECIP_PI_OVER_180*ACOS(ARG) 1315 ANGLED(I)=SIGN(TERM1,TERM2) 1316 !Li 1317 1318 200 CONTINUE 1319 1320 RETURN 1321 END SUBROUTINE W3EQTOLL ENTRY POINTS Name w3servmd_mp_w3eqtoll_ Page 40 Source Listing W3EQTOLL 2014-09-16 17:00 Symbol Table w3servmd.f90 SYMBOL CROSS REFERENCE Name Object Declared Type Bytes Dimen Elements Attributes References 200 Label 1318 1259 ACOS Func 1292 scalar 1292,1314 ANGLED Dummy 1212 R(4) 4 1 0 ARG,INOUT 1315 ARG Local 1231 R(4) 4 scalar 1274,1276,1277,1278,1289,1290,1291 ,1292,1310,1312,1313,1314 ASIN Func 1278 scalar 1278 A_LAMBDA Local 1229 R(4) 4 scalar 1287,1292,1293,1294,1299,1300,1301 ,1305,1310,1311 A_PHI Local 1229 R(4) 4 scalar 1278,1279,1285 COS Func 1251 scalar 1251,1254,1274,1283,1285,1311 COS_PHI_POLE Local 1230 R(4) 4 scalar 1251,1254,1274,1284 E_LAMBDA Local 1229 R(4) 4 scalar 1263,1264,1265,1269,1274,1283,1293 ,1309,1311 E_PHI Local 1229 R(4) 4 scalar 1270,1274,1275,1283,1284 I Local 1232 I(4) 4 scalar 1259,1263,1270,1279,1301,1305,1315 LAMBDA Dummy 1211 R(4) 4 1 0 ARG,INOUT 1301,1305 LAMBDA_EQ Dummy 1211 R(4) 4 1 0 ARG,INOUT 1263 LAMBDA_POLE Dummy 1212 R(4) 4 scalar ARG,INOUT 1247 LAMBDA_ZERO Local 1231 R(4) 4 scalar 1247,1294,1305 MAX Func 1277 scalar 1277,1291,1313 MIN Func 1276 scalar 1276,1290,1312 PHI Dummy 1211 R(4) 4 1 0 ARG,INOUT 1279 PHI_EQ Dummy 1211 R(4) 4 1 0 ARG,INOUT 1270 PHI_POLE Dummy 1212 R(4) 4 scalar ARG,INOUT 1249,1250,1251,1253,1254 PI Param 1238 R(4) 4 scalar 1239,1240 PI_OVER_180 Param 1239 R(4) 4 scalar 1250,1251,1253,1254,1269,1270,1305 POINTS Dummy 1212 I(4) 4 scalar ARG,INOUT 1222,1223,1224,1225,1226,1259 RECIP_PI_OVER_180 Param 1240 R(4) 4 scalar 1279,1292,1314 SIGN Func 1293 scalar 1293,1315 SIN Func 1250 scalar 1250,1253,1275,1284,1309,1310 SIN_PHI_POLE Local 1230 R(4) 4 scalar 1250,1253,1275,1283,1310 SMALL Param 1234 R(4) 4 scalar 1286 TERM1 Local 1231 R(4) 4 scalar 1283,1289,1314,1315 TERM2 Local 1231 R(4) 4 scalar 1285,1286,1289,1309,1310,1315 W3EQTOLL Subr 1211 Page 41 Source Listing W3EQTOLL 2014-09-16 17:00 w3servmd.f90 1322 1323 !Li 1324 !/ 1325 SUBROUTINE STRSPLIT(STRING,TAB) 1326 !/ 1327 !/ +-----------------------------------+ 1328 !/ | WAVEWATCH III NOAA/NCEP | 1329 !/ | M. Accensi | 1330 !/ | FORTRAN 90 | 1331 !/ | Last update : 29-Apr-2013 ! 1332 !/ +-----------------------------------+ 1333 !/ 1334 !/ 29-Mar-2013 : Origination. ( version 4.10 ) 1335 !/ 1336 ! 1. Purpose : 1337 ! 1338 ! Splits string into words 1339 ! 1340 ! 2. Method : 1341 ! 1342 ! finds spaces and loops 1343 ! 1344 ! 3. Parameters : 1345 ! 1346 ! Parameter list 1347 ! ---------------------------------------------------------------- 1348 ! STRING Str O String to be splitted 1349 ! TAB Str O Array of strings 1350 ! ---------------------------------------------------------------- 1351 ! 1352 1353 IMPLICIT NONE 1354 1355 1356 1357 CHARACTER(LEN=1024), intent(IN) :: STRING 1358 CHARACTER(LEN=100), intent(INOUT) :: TAB(*) 1359 INTEGER :: cnt, I 1360 CHARACTER(LEN=1024) :: tmp_str, ori_str 1361 1362 ! initializes arrays 1363 ori_str=ADJUSTL(TRIM(STRING)) 1364 tmp_str=ori_str 1365 cnt=0 1366 1367 ! counts the number of substrings 1368 DO WHILE ((INDEX(tmp_str,' ').NE.0) .AND. (len_trim(tmp_str).NE.0)) 1369 tmp_str=ADJUSTL(tmp_str(INDEX(tmp_str,' ')+1:)) 1370 cnt=cnt+1 1371 ENDDO 1372 ! 1373 ! reinitializes arrays 1374 ! 1375 tmp_str=ori_str 1376 ! loops on each substring 1377 DO I=1,cnt 1378 TAB(I)=tmp_str(:INDEX(tmp_str,' ')) Page 42 Source Listing STRSPLIT 2014-09-16 17:00 w3servmd.f90 1379 tmp_str=ADJUSTL(tmp_str(INDEX(tmp_str,' ')+1:)) 1380 END DO 1381 1382 RETURN 1383 !/ 1384 !/ End of STRSPLIT ----------------------------------------------------- / 1385 !/ 1386 END SUBROUTINE STRSPLIT ENTRY POINTS Name w3servmd_mp_strsplit_ SYMBOL CROSS REFERENCE Name Object Declared Type Bytes Dimen Elements Attributes References ADJUSTL Func 1363 scalar 1363,1369,1379 CNT Local 1359 I(4) 4 scalar 1365,1370,1377 I Local 1359 I(4) 4 scalar 1377,1378 INDEX Func 1368 scalar 1368,1369,1378,1379 LEN_TRIM Func 1368 scalar 1368 ORI_STR Local 1360 CHAR 1024 scalar 1363,1364,1375 STRING Dummy 1325 CHAR 1024 scalar ARG,IN 1363 STRSPLIT Subr 1325 TAB Dummy 1325 CHAR 100 1 0 ARG,INOUT 1378 TMP_STR Local 1360 CHAR 1024 scalar 1364,1368,1369,1375,1378,1379 TRIM Func 1363 scalar 1363 Page 43 Source Listing STRSPLIT 2014-09-16 17:00 w3servmd.f90 1387 !/ 1388 1389 !/ ------------------------------------------------------------------- / 1390 SUBROUTINE STR_TO_UPPER(STR) 1391 character(*), intent(inout) :: str 1392 integer :: i 1393 1394 DO i = 1, len(str) 1395 select case(str(i:i)) 1396 case("a":"z") 1397 str(i:i) = achar(iachar(str(i:i))-32) 1398 end select 1399 END DO 1400 !/ End of STR_TO_UPPER 1401 !/ ------------------------------------------------------------------- / 1402 END SUBROUTINE STR_TO_UPPER ENTRY POINTS Name w3servmd_mp_str_to_upper_ SYMBOL CROSS REFERENCE Name Object Declared Type Bytes Dimen Elements Attributes References ACHAR Func 1397 scalar 1397 I Local 1392 I(4) 4 scalar 1394,1395,1397 IACHAR Func 1397 scalar 1397 LEN Func 1394 scalar 1394 STR Dummy 1390 CHAR scalar ARG,INOUT 1394,1395,1397 STR_TO_UPPER Subr 1390 Page 44 Source Listing STR_TO_UPPER 2014-09-16 17:00 w3servmd.f90 1403 1404 !********************************************************************** 1405 !* * 1406 !********************************************************************** 1407 SUBROUTINE SSORT1 (X, Y, N, KFLAG) 1408 !***BEGIN PROLOGUE SSORT 1409 !***PURPOSE Sort an array and optionally make the same interchanges in 1410 ! an auxiliary array. The array may be sorted in increasing 1411 ! or decreasing order. A slightly modified QUICKSORT 1412 ! algorithm is used. 1413 !***LIBRARY SLATEC 1414 !***CATEGORY N6A2B 1415 !***TYPE SINGLE PRECISION (SSORT-S, DSORT-D, ISORT-I) 1416 !***KEYWORDS SINGLETON QUICKSORT, SORT, SORTING 1417 !***AUTHOR Jones, R. E., (SNLA) 1418 ! Wisniewski, J. A., (SNLA) 1419 !***DESCRIPTION 1420 ! 1421 ! SSORT sorts array X and optionally makes the same interchanges in 1422 ! array Y. The array X may be sorted in increasing order or 1423 ! decreasing order. A slightly modified quicksort algorithm is used. 1424 ! 1425 ! Description of Parameters 1426 ! X - array of values to be sorted (usually abscissas) 1427 ! Y - array to be (optionally) carried along 1428 ! N - number of values in array X to be sorted 1429 ! KFLAG - control parameter 1430 ! = 2 means sort X in increasing order and carry Y along. 1431 ! = 1 means sort X in increasing order (ignoring Y) 1432 ! = -1 means sort X in decreasing order (ignoring Y) 1433 ! = -2 means sort X in decreasing order and carry Y along. 1434 ! 1435 !***REFERENCES R. C. Singleton, Algorithm 347, An efficient algorithm 1436 ! for sorting with minimal storage, Communications of 1437 ! the ACM, 12, 3 (1969), pp. 185-187. 1438 !***REVISION HISTORY (YYMMDD) 1439 ! 761101 DATE WRITTEN 1440 ! 761118 Modified to use the Singleton quicksort algorithm. (JAW) 1441 ! 890531 Changed all specific intrinsics to generic. (WRB) 1442 ! 890831 Modified array declarations. (WRB) 1443 ! 891009 Removed unreferenced statement labels. (WRB) 1444 ! 891024 Changed category. (WRB) 1445 ! 891024 REVISION DATE from Version 3.2 1446 ! 891214 Prologue converted to Version 4.0 format. (BAB) 1447 ! 900315 CALLs to XERROR changed to CALLs to XERMSG. (THJ) 1448 ! 901012 Declared all variables; changed X,Y to SX,SY. (M. McClain) 1449 ! 920501 Reformatted the REFERENCES section. (DWL, WRB) 1450 ! 920519 Clarified error messages. (DWL) 1451 ! 920801 Declarations section rebuilt and code restructured to use 1452 ! IF-THEN-ELSE-ENDIF. (RWC, WRB) 1453 !***END PROLOGUE SSORT 1454 ! .. Scalar Arguments .. 1455 INTEGER KFLAG, N 1456 ! .. Array Arguments .. 1457 REAL*4 X(*), Y(*) 1458 ! .. Local Scalars .. 1459 REAL*4 R, T, TT, TTY, TY Page 45 Source Listing SSORT1 2014-09-16 17:00 w3servmd.f90 1460 INTEGER I, IJ, J, K, KK, L, M, NN 1461 ! .. Local Arrays .. 1462 INTEGER IL(21), IU(21) 1463 ! .. External Subroutines .. 1464 ! None 1465 ! .. Intrinsic Functions .. 1466 INTRINSIC ABS, INT 1467 !***FIRST EXECUTABLE STATEMENT SSORT 1468 NN = N 1469 IF (NN .LT. 1) THEN 1470 WRITE (*,*) 'The number of values to be sorted is not positive.' 1471 RETURN 1472 ENDIF 1473 ! 1474 KK = ABS(KFLAG) 1475 IF (KK.NE.1 .AND. KK.NE.2) THEN 1476 WRITE (*,*) 'The sort control parameter, K, is not 2, 1, -1, or -2.' 1477 RETURN 1478 ENDIF 1479 ! 1480 ! Alter array X to get decreasing order if needed 1481 ! 1482 IF (KFLAG .LE. -1) THEN 1483 DO 10 I=1,NN 1484 X(I) = -X(I) 1485 10 CONTINUE 1486 ENDIF 1487 ! 1488 IF (KK .EQ. 2) GO TO 100 1489 ! 1490 ! Sort X only 1491 ! 1492 M = 1 1493 I = 1 1494 J = NN 1495 R = 0.375E0 1496 ! 1497 20 IF (I .EQ. J) GO TO 60 1498 IF (R .LE. 0.5898437E0) THEN 1499 R = R+3.90625E-2 1500 ELSE 1501 R = R-0.21875E0 1502 ENDIF 1503 ! 1504 30 K = I 1505 ! 1506 ! Select a central element of the array and save it in location T 1507 ! 1508 IJ = I + INT((J-I)*R) 1509 T = X(IJ) 1510 ! 1511 ! If first element of array is greater than T, interchange with T 1512 ! 1513 IF (X(I) .GT. T) THEN 1514 X(IJ) = X(I) 1515 X(I) = T 1516 T = X(IJ) Page 46 Source Listing SSORT1 2014-09-16 17:00 w3servmd.f90 1517 ENDIF 1518 L = J 1519 ! 1520 ! If last element of array is less than than T, interchange with T 1521 ! 1522 IF (X(J) .LT. T) THEN 1523 X(IJ) = X(J) 1524 X(J) = T 1525 T = X(IJ) 1526 ! 1527 ! If first element of array is greater than T, interchange with T 1528 ! 1529 IF (X(I) .GT. T) THEN 1530 X(IJ) = X(I) 1531 X(I) = T 1532 T = X(IJ) 1533 ENDIF 1534 ENDIF 1535 ! 1536 ! Find an element in the second half of the array which is smaller 1537 ! than T 1538 ! 1539 40 L = L-1 1540 IF (X(L) .GT. T) GO TO 40 1541 ! 1542 ! Find an element in the first half of the array which is greater 1543 ! than T 1544 ! 1545 50 K = K+1 1546 IF (X(K) .LT. T) GO TO 50 1547 ! 1548 ! Interchange these elements 1549 ! 1550 IF (K .LE. L) THEN 1551 TT = X(L) 1552 X(L) = X(K) 1553 X(K) = TT 1554 GO TO 40 1555 ENDIF 1556 ! 1557 ! Save upper and lower subscripts of the array yet to be sorted 1558 ! 1559 IF (L-I .GT. J-K) THEN 1560 IL(M) = I 1561 IU(M) = L 1562 I = K 1563 M = M+1 1564 ELSE 1565 IL(M) = K 1566 IU(M) = J 1567 J = L 1568 M = M+1 1569 ENDIF 1570 GO TO 70 1571 ! 1572 ! Begin again on another portion of the unsorted array 1573 ! Page 47 Source Listing SSORT1 2014-09-16 17:00 w3servmd.f90 1574 60 M = M-1 1575 IF (M .EQ. 0) GO TO 190 1576 I = IL(M) 1577 J = IU(M) 1578 ! 1579 70 IF (J-I .GE. 1) GO TO 30 1580 IF (I .EQ. 1) GO TO 20 1581 I = I-1 1582 ! 1583 80 I = I+1 1584 IF (I .EQ. J) GO TO 60 1585 T = X(I+1) 1586 IF (X(I) .LE. T) GO TO 80 1587 K = I 1588 ! 1589 90 X(K+1) = X(K) 1590 K = K-1 1591 IF (T .LT. X(K)) GO TO 90 1592 X(K+1) = T 1593 GO TO 80 1594 ! 1595 ! Sort X and carry Y along 1596 ! 1597 100 M = 1 1598 I = 1 1599 J = NN 1600 R = 0.375E0 1601 ! 1602 110 IF (I .EQ. J) GO TO 150 1603 IF (R .LE. 0.5898437E0) THEN 1604 R = R+3.90625E-2 1605 ELSE 1606 R = R-0.21875E0 1607 ENDIF 1608 ! 1609 120 K = I 1610 ! 1611 ! Select a central element of the array and save it in location T 1612 ! 1613 IJ = I + INT((J-I)*R) 1614 T = X(IJ) 1615 TY = Y(IJ) 1616 ! 1617 ! If first element of array is greater than T, interchange with T 1618 ! 1619 IF (X(I) .GT. T) THEN 1620 X(IJ) = X(I) 1621 X(I) = T 1622 T = X(IJ) 1623 Y(IJ) = Y(I) 1624 Y(I) = TY 1625 TY = Y(IJ) 1626 ENDIF 1627 L = J 1628 ! 1629 ! If last element of array is less than T, interchange with T 1630 ! Page 48 Source Listing SSORT1 2014-09-16 17:00 w3servmd.f90 1631 IF (X(J) .LT. T) THEN 1632 X(IJ) = X(J) 1633 X(J) = T 1634 T = X(IJ) 1635 Y(IJ) = Y(J) 1636 Y(J) = TY 1637 TY = Y(IJ) 1638 ! 1639 ! If first element of array is greater than T, interchange with T 1640 ! 1641 IF (X(I) .GT. T) THEN 1642 X(IJ) = X(I) 1643 X(I) = T 1644 T = X(IJ) 1645 Y(IJ) = Y(I) 1646 Y(I) = TY 1647 TY = Y(IJ) 1648 ENDIF 1649 ENDIF 1650 ! 1651 ! Find an element in the second half of the array which is smaller 1652 ! than T 1653 ! 1654 130 L = L-1 1655 IF (X(L) .GT. T) GO TO 130 1656 ! 1657 ! Find an element in the first half of the array which is greater 1658 ! than T 1659 ! 1660 140 K = K+1 1661 IF (X(K) .LT. T) GO TO 140 1662 ! 1663 ! Interchange these elements 1664 ! 1665 IF (K .LE. L) THEN 1666 TT = X(L) 1667 X(L) = X(K) 1668 X(K) = TT 1669 TTY = Y(L) 1670 Y(L) = Y(K) 1671 Y(K) = TTY 1672 GO TO 130 1673 ENDIF 1674 ! 1675 ! Save upper and lower subscripts of the array yet to be sorted 1676 ! 1677 IF (L-I .GT. J-K) THEN 1678 IL(M) = I 1679 IU(M) = L 1680 I = K 1681 M = M+1 1682 ELSE 1683 IL(M) = K 1684 IU(M) = J 1685 J = L 1686 M = M+1 1687 ENDIF Page 49 Source Listing SSORT1 2014-09-16 17:00 w3servmd.f90 1688 GO TO 160 1689 ! 1690 ! Begin again on another portion of the unsorted array 1691 ! 1692 150 M = M-1 1693 IF (M .EQ. 0) GO TO 190 1694 I = IL(M) 1695 J = IU(M) 1696 ! 1697 160 IF (J-I .GE. 1) GO TO 120 1698 IF (I .EQ. 1) GO TO 110 1699 I = I-1 1700 ! 1701 170 I = I+1 1702 IF (I .EQ. J) GO TO 150 1703 T = X(I+1) 1704 TY = Y(I+1) 1705 IF (X(I) .LE. T) GO TO 170 1706 K = I 1707 ! 1708 180 X(K+1) = X(K) 1709 Y(K+1) = Y(K) 1710 K = K-1 1711 IF (T .LT. X(K)) GO TO 180 1712 X(K+1) = T 1713 Y(K+1) = TY 1714 GO TO 170 1715 ! 1716 ! Clean up 1717 ! 1718 190 IF (KFLAG .LE. -1) THEN 1719 DO 200 I=1,NN 1720 X(I) = -X(I) 1721 200 CONTINUE 1722 ENDIF 1723 RETURN 1724 END SUBROUTINE SSORT1 Page 50 Source Listing SSORT1 2014-09-16 17:00 Entry Points w3servmd.f90 ENTRY POINTS Name w3servmd_mp_ssort1_ SYMBOL CROSS REFERENCE Name Object Declared Type Bytes Dimen Elements Attributes References 10 Label 1485 1483 100 Label 1597 1488 110 Label 1602 1698 120 Label 1609 1697 130 Label 1654 1655,1672 140 Label 1660 1661 150 Label 1692 1602,1702 160 Label 1697 1688 170 Label 1701 1705,1714 180 Label 1708 1711 190 Label 1718 1575,1693 20 Label 1497 1580 200 Label 1721 1719 30 Label 1504 1579 40 Label 1539 1540,1554 50 Label 1545 1546 60 Label 1574 1497,1584 70 Label 1579 1570 80 Label 1583 1586,1593 90 Label 1589 1591 ABS Func 1466 scalar 1474 I Local 1460 I(4) 4 scalar 1483,1484,1493,1497,1504,1508,1513 ,1514,1515,1529,1530,1531,1559,156 0,1562,1576,1579,1580,1581,1583,15 84,1585,1586,1587,1598,1602,1609,1 613,1619,1620,1621,1623,1624,1641, 1642,1643,1645,1646,1677,1678,1680 ,1694,1697,1698,1699,1701,1702,170 3,1704,1705,1706,1719,1720 IJ Local 1460 I(4) 4 scalar 1508,1509,1514,1516,1523,1525,1530 ,1532,1613,1614,1615,1620,1622,162 3,1625,1632,1634,1635,1637,1642,16 44,1645,1647 IL Local 1462 I(4) 4 1 21 1560,1565,1576,1678,1683,1694 INT Func 1466 scalar 1508,1613 IU Local 1462 I(4) 4 1 21 1561,1566,1577,1679,1684,1695 J Local 1460 I(4) 4 scalar 1494,1497,1508,1518,1522,1523,1524 ,1559,1566,1567,1577,1579,1584,159 9,1602,1613,1627,1631,1632,1633,16 35,1636,1677,1684,1685,1695,1697,1 702 K Local 1460 I(4) 4 scalar 1504,1545,1546,1550,1552,1553,1559 ,1562,1565,1587,1589,1590,1591,159 2,1609,1660,1661,1665,1667,1668,16 Page 51 Source Listing SSORT1 2014-09-16 17:00 Symbol Table w3servmd.f90 Name Object Declared Type Bytes Dimen Elements Attributes References 70,1671,1677,1680,1683,1706,1708,1 709,1710,1711,1712,1713 KFLAG Dummy 1407 I(4) 4 scalar ARG,INOUT 1474,1482,1718 KK Local 1460 I(4) 4 scalar 1474,1475,1488 L Local 1460 I(4) 4 scalar 1518,1539,1540,1550,1551,1552,1559 ,1561,1567,1627,1654,1655,1665,166 6,1667,1669,1670,1677,1679,1685 M Local 1460 I(4) 4 scalar 1492,1560,1561,1563,1565,1566,1568 ,1574,1575,1576,1577,1597,1678,167 9,1681,1683,1684,1686,1692,1693,16 94,1695 N Dummy 1407 I(4) 4 scalar ARG,INOUT 1468 NN Local 1460 I(4) 4 scalar 1468,1469,1483,1494,1599,1719 R Local 1459 R(4) 4 scalar 1495,1498,1499,1501,1508,1600,1603 ,1604,1606,1613 SSORT1 Subr 1407 T Local 1459 R(4) 4 scalar 1509,1513,1515,1516,1522,1524,1525 ,1529,1531,1532,1540,1546,1585,158 6,1591,1592,1614,1619,1621,1622,16 31,1633,1634,1641,1643,1644,1655,1 661,1703,1705,1711,1712 TT Local 1459 R(4) 4 scalar 1551,1553,1666,1668 TTY Local 1459 R(4) 4 scalar 1669,1671 TY Local 1459 R(4) 4 scalar 1615,1624,1625,1636,1637,1646,1647 ,1704,1713 X Dummy 1407 R(4) 4 1 0 ARG,INOUT 1484,1509,1513,1514,1515,1516,1522 ,1523,1524,1525,1529,1530,1531,153 2,1540,1546,1551,1552,1553,1585,15 86,1589,1591,1592,1614,1619,1620,1 621,1622,1631,1632,1633,1634,1641, 1642,1643,1644,1655,1661,1666,1667 ,1668,1703,1705,1708,1711,1712,172 0 Y Dummy 1407 R(4) 4 1 0 ARG,INOUT 1615,1623,1624,1625,1635,1636,1637 ,1645,1646,1647,1669,1670,1671,170 4,1709,1713 Page 52 Source Listing SSORT1 2014-09-16 17:00 w3servmd.f90 1725 !/ 1726 !/ End of module W3SERVMD -------------------------------------------- / 1727 !/ 1728 END MODULE W3SERVMD SYMBOL CROSS REFERENCE Name Object Declared Type Bytes Dimen Elements Attributes References EJ5P@0 Local 391 R(4) 4 scalar W3SERVMD Module 2 Page 53 Source Listing SSORT1 2014-09-16 17:00 Subprograms/Common Blocks w3servmd.f90 SUBPROGRAMS/COMMON BLOCKS Name Object Declared Type Bytes Dimen Elements Attributes References EJ5P Func 391 R(4) 4 scalar 474,483,492 EXTCDE Subr 655 294,298,302 ITRACE Subr 87 NEXTLN Subr 220 PRINIT Subr 715 PRTIME Subr 777 SSORT1 Subr 1407 STRACE Subr 145 STRSPLIT Subr 1325 STR_TO_UPPER Subr 1390 W3ACTURN Subr 961 W3EQTOLL Subr 1211 W3LLTOEQ Subr 1067 W3S2XY Subr 320 W3SERVMD Module 2 W3SPECTN Subr 873 WWDATE Subr 501 WWTIME Subr 577 COMPILER OPTIONS BEING USED -align nocommons -align nodcommons -align noqcommons -align records -align nosequence -align norec1byte -align norec2byte -align norec4byte -align norec8byte -align norec16byte -altparam -assume accuracy_sensitive -assume nobscc -assume nobuffered_io -assume byterecl -assume nocc_omp -assume nocstring -assume nodummy_aliases -assume nofpe_summary -assume noieee_fpe_flags -assume nominus0 -assume noold_boz -assume old_unit_star -assume old_ldout_format -assume noold_logical_ldio -assume old_maxminloc -assume old_xor -assume protect_constants -assume noprotect_parens -assume split_common -assume source_include -assume nostd_intent_in -assume nostd_mod_proc_name -assume norealloc_lhs -assume underscore -assume no2underscores -auto no -auto_scalar no -bintext -ccdefault default -check noargs -check noarg_temp_created -check nobounds -check noformat -check nooutput_conversion -check nooverflow -check nopointers -check power -check noshape -check nounderflow -check nouninitialized -coarray-num-procs 0 no -coarray-config-file -convert big_endian -cross_reference -D __INTEL_COMPILER=1210 -D __unix__ -D __unix -D __linux__ -D __linux Page 54 Source Listing SSORT1 2014-09-16 17:00 w3servmd.f90 -D __gnu_linux__ -D unix -D linux -D __ELF__ -D __x86_64 -D __x86_64__ -D _MT -D __INTEL_COMPILER_BUILD_DATE=20120612 -D __pentium4 -D __pentium4__ -D __tune_pentium4__ -D __SSE2__ -D __SSE3__ -D __SSSE3__ -D __SSE4_1__ -D __SSE4_2__ -D __SSE__ -D __MMX__ -D __AVX__ -double_size 64 no -d_lines no -Qdyncom -error_limit 30 no -f66 no -f77rtl no -fast -fpscomp nofilesfromcmd -fpscomp nogeneral -fpscomp noioformat -fpscomp noldio_spacing -fpscomp nologicals no -fpconstant -fpe3 -fprm nearest no -ftz -fp_model noprecise -fp_model fast -fp_model nostrict -fp_model nosource -fp_model nodouble -fp_model noextended -fp_model novery_fast -fp_model noexcept -fp_model nono_except -heap_arrays 0 no -threadprivate_compat -free -g0 -iface nomixed_str_len_arg -iface nono_mixed_str_len_arg no -intconstant -integer_size 32 no -mixed_str_len_arg no -module -names lowercase no -noinclude -O2 no -pad_source -real_size 32 no -recursive -reentrancy none no -sharable_localsaves -vec=simd -show noinclude -show map -show options no -syntax_only no -threadcom no -U no -vms -w noall -w nonone -w alignments -w noargument_checking -w nodeclarations -w general -w noignore_bounds -w noignore_loc -w nointerfaces -w notruncated_source -w uncalled -w uninitialized -w nounused -w usage -includepath : /gpfs/gp1/usrx/local/intel/composer_xe_2011_sp1.11.339/compiler/include/,.f,./.f,/usrx/local/intel/composerxe/mkl/include/.f, /usrx/local/intel/composerxe/tbb/include/.f,/gpfs/gp1/usrx/local/intel/composer_xe_2011_sp1.11.339/compiler/include/intel64/.f, /gpfs/gp1/usrx/local/intel/composer_xe_2011_sp1.11.339/compiler/include/.f,/usr/local/include/.f,/usr/lib/gcc/x86_64-redhat-linux/4.4.7/include/.f, /usr/include/.f,/usr/include/.f -list filename : w3servmd.lst -o filename : none COMPILER: Intel(R) Fortran 12.1-2100