1C Copyright 1981-2016 ECMWF. 2C 3C This software is licensed under the terms of the Apache Licence 4C Version 2.0 which can be obtained at http://www.apache.org/licenses/LICENSE-2.0. 5C 6C In applying this licence, ECMWF does not waive the privileges and immunities 7C granted to it by virtue of its status as an intergovernmental organisation 8C nor does it submit to any jurisdiction. 9C 10 11 INTEGER FUNCTION INTUVU( PVYIN, PDVIN, INLEN, 12 X PUOUT, PVOUT, OUTLEN) 13C 14C----> 15C**** INTUVU 16C 17C Purpose 18C ------- 19C 20C Interpolate unpacked input vorticity and divergence field to 21C unpacked U and V fields. 22C 23C 24C Interface 25C --------- 26C 27C IERR = INTUVU( PVYIN, PDVIN, INLEN, PUOUT,PVOUT,OUTLEN) 28C 29C Input 30C ----- 31C 32C PVYIN - Input vorticity field (unpacked array). 33C PDVIN - Input divergence field (unpacked array). 34C INLEN - Input field length (words). 35C 36C 37C Output 38C ------ 39C 40C PUOUT - Output U field (unpacked array). 41C PVOUT - Output V field (unpacked array). 42C OUTLEN - Output field length (words). 43C 44C 45C Method 46C ------ 47C 48C Convert spectral vorticity/divergence to spectral U/V and then 49C interpolate U and V to output fields. 50C 51C 52C Externals 53C --------- 54C 55C JVOD2UV - Converts spectral vorticity/divergence to spectral U/V. 56C JMEMHAN - Allocate scratch memory. 57C INTFAU - Prepare to interpolate unpacked input field. 58C INTFBU - Interpolate unpacked input field. 59C INTLOG - Log error message. 60C 61C 62C Author 63C ------ 64C 65C J.D.Chambers ECMWF Feb 1995 66C 67C J.D.Chambers ECMWF Feb 1997 68C Allow for 64-bit pointers 69C 70C----< 71C 72 IMPLICIT NONE 73C 74#include "parim.h" 75#include "nifld.common" 76#include "nofld.common" 77#include "grfixed.h" 78#include "intf.h" 79#include "current.h" 80C 81C Parameters 82C 83 INTEGER JPROUTINE, JPALLOC, JPSCR3, JPSCR5 84 PARAMETER (JPROUTINE = 27000) 85 PARAMETER (JPALLOC = 1) 86 PARAMETER (JPSCR3 = 3) 87 PARAMETER (JPSCR5 = 5) 88C 89C Function arguments 90C 91 INTEGER INLEN, OUTLEN 92 REAL PVYIN(INLEN), PDVIN(INLEN), PUOUT(*), PVOUT(*) 93C 94C Local variables 95C 96 CHARACTER*1 HOLDTYP 97 CHARACTER*1 HTYPE 98 INTEGER IDIVOFF 99 INTEGER IERR 100 INTEGER IOHOLD(4) 101 INTEGER IPVORT 102 INTEGER ISIZE 103 INTEGER ISZUV 104 INTEGER KK 105 INTEGER KPR 106 INTEGER KPTS(JPGTRUNC*2) 107 INTEGER LOOP 108 INTEGER MTRUNC 109 INTEGER NCOUNT 110 INTEGER NGAUSS 111 INTEGER NLAT 112 INTEGER NLON 113 INTEGER NOLD 114 INTEGER NTROLD 115 INTEGER NTROLD2 116 INTEGER NTRUNC 117 INTEGER NUMPTS 118 INTEGER NUVFLAG 119 LOGICAL LFRAME 120 LOGICAL LOLDWIND 121 LOGICAL LSFCUVI 122 LOGICAL LSPCUVI 123 LOGICAL LSPECUV 124 LOGICAL LSTYLE 125 REAL AREA(4) 126 REAL EAST 127 REAL EW 128 REAL GLATS(JPGTRUNC*2) 129 REAL GRID(2) 130 REAL NORTH 131 REAL NS 132 REAL OLDGRID(2) 133 REAL POLE(2) 134 REAL SOUTH 135 REAL WEST 136C 137 LOGICAL LFIRST, LNEWUV 138 CHARACTER*3 EXTRA 139 DATA LFIRST/.TRUE./, LNEWUV/.TRUE./, EXTRA/'NO '/ 140 SAVE LFIRST, LNEWUV 141C 142 DATA NTROLD/-1/, NTROLD2/-1/ 143 SAVE NTROLD, NTROLD2 144 INTEGER IP_U, IP_V 145 146 REAL RGGRID, SWORK 147 POINTER (IRGGRID, RGGRID(1) ) 148 POINTER (ISWORK, SWORK(1) ) 149#ifndef _CRAYFTN 150#ifdef POINTER_64 151 INTEGER*8 IZNFLDO 152#endif 153#endif 154 REAL ZNFLDO 155 POINTER ( IZNFLDO, ZNFLDO ) 156 DIMENSION ZNFLDO( 1 ) 157#ifndef _CRAYFTN 158#ifdef POINTER_64 159 INTEGER*8 IUV 160#endif 161#endif 162 REAL UV 163 POINTER ( IUV, UV ) 164 DIMENSION UV( 1 ) 165C 166C Externals 167C 168 INTEGER INTFAU, INTFBU, AURESOL, DSSAREA, FIXAREA 169 INTEGER HIRLAMW, HSH2GG 170 INTEGER HRG2GGW, HLL2LLW 171 EXTERNAL INTFAU, INTFBU, AURESOL, DSSAREA, FIXAREA 172 EXTERNAL HIRLAMW, HSH2GG 173 EXTERNAL HRG2GGW, HLL2LLW 174C 175C -----------------------------------------------------------------| 176C* Section 1. Initialise 177C -----------------------------------------------------------------| 178C 179 100 CONTINUE 180 IERR = 0 181 KPR = 0 182 LOLDWIND = .FALSE. 183 INTUVU = 0 184C 185C 186C Save output area definitions 187C 188 DO 110 LOOP = 1, 4 189 IOHOLD(LOOP) = NOAREA(LOOP) 190 110 CONTINUE 191 192 LFRAME = LNOFRAME.AND. 193 X ((NOREPR.EQ.JPREGULAR).OR.(NOREPR.EQ.JPGAUSSIAN).OR. 194 X (NOREPR.EQ.JPREGROT ).OR.(NOREPR.EQ.JPFGGROT ) ) 195 196 IF( LFIRST ) THEN 197 CALL GETENV('IGNORE_UV_EXTRA_MODE', EXTRA) 198 IF((EXTRA(1:1).EQ.'Y').OR.(EXTRA(1:1).EQ.'y')) LNEWUV = .FALSE. 199 IF( LNEWUV ) THEN 200 CALL INTLOG(JP_DEBUG, 201 X 'INTUVU: IGNORE_UV_EXTRA_MODE not turned on',JPQUIET) 202 ELSE 203 CALL INTLOG(JP_DEBUG, 204 X 'INTUVU: IGNORE_UV_EXTRA_MODE turned on',JPQUIET) 205 ENDIF 206 LFIRST = .FALSE. 207 ENDIF 208C 209 NOLD = NIRESO 210C 211 LSPECUV = (NOREPR.EQ.JPSPHERE).OR.(NOREPR.EQ.JPSPHROT) 212 LSPCUVI = (NIREPR.EQ.JPSPHERE).OR.(NIREPR.EQ.JPSPHROT) 213 LSFCUVI = (.NOT.LSPCUVI).AND.LNOROTA 214 215C 216CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC 217cs Regular Gaussian has to be set here 218 IF( NOREPR.EQ.JPNOTYPE ) THEN 219 IF( (NOGAUSO.NE.NOGAUSS).OR.(HOGAUST.NE.'F') ) THEN 220 HTYPE = 'F' 221 CALL JGETGG(NOGAUSS,HTYPE,ROGAUSS,NOLPTS,IERR) 222 IF( IERR.NE.0 ) THEN 223 CALL INTLOG(JP_ERROR, 224 X 'INTUVU: JGETGG failed, NOGAUSS = ',NOGAUSS) 225 INTUVU = IERR 226 GOTO 900 227 ENDIF 228 NOGAUSO = NOGAUSS 229 HOGAUST = HTYPE 230 ENDIF 231 NOREPR = JPGAUSSIAN 232 ENDIF 233CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC 234C 235C -----------------------------------------------------------------| 236C* Section 2. Convert spectral vorticity/divergence to spectral U/V 237C -----------------------------------------------------------------| 238C 239 200 CONTINUE 240C 241 IF( LSPECUV ) THEN 242C 243C Spectral U and V for Tn are to be generated from vorticity 244C and divergence spectral T(n-1) 245C 246 IF( LARESOL.AND.LNEWUV ) THEN 247 IF( (NOGRID(1).NE.0).AND.(NOGRID(2).NE.0) ) THEN 248 EW = FLOAT(NOGRID(1))/PPMULT 249 NS = FLOAT(NOGRID(2))/PPMULT 250 NTRUNC = AURESOL(NS,EW) - 1 251 ELSE IF( NOGAUSS.NE.0 ) THEN 252 EW = 90.0/FLOAT(NOGAUSS) 253 NS = EW 254 NTRUNC = AURESOL(NS,EW) - 1 255 ELSE IF( LNORESO ) THEN 256 NTRUNC = NORESO - 1 257 ELSE 258 NTRUNC = NIRESO - 1 259 ENDIF 260 IF( NTRUNC.GT.(NIRESO-1) ) NTRUNC = NIRESO - 1 261C 262 ELSE IF( LNORESO ) THEN 263 NTRUNC = NORESO - 1 264 ELSE 265 NTRUNC = NIRESO - 1 266 ENDIF 267C 268 IF( LNEWUV ) THEN 269 MTRUNC = NTRUNC + 1 270 ELSE 271 NTRUNC = NTRUNC + 1 272 MTRUNC = NTRUNC 273 ENDIF 274C 275C -----------------------------------------------------------------| 276C Use old-style processing if IGNORE_UV_EXTRA_MODE = Y 277C -----------------------------------------------------------------| 278C 279 IF( .NOT.LNEWUV ) THEN 280C 281 CALL INTLOG(JP_DEBUG,'INTUVU: vo/div truncation = ', NIRESO) 282C 283C Get scratch memory for U and V spectral fields. 284C U and V memory areas are adjacent. 285C 286 ISZUV = (NIRESO+1)*(NIRESO+2) 287 IP_U = 1 288 IP_V = 1 + ISZUV 289 CALL JMEMHAN( JPSCR3, IUV, ISZUV*2, JPALLOC, IERR) 290 IF ( IERR .NE. 0 ) THEN 291 CALL INTLOG(JP_ERROR,'INTUVU: Memory allocn fail',JPQUIET) 292 INTUVU = IERR 293 GOTO 900 294 ENDIF 295C 296C Generate U and V with same truncation as input fields. 297C 298 CALL INTLOG(JP_DEBUG, 299 X 'INTUVU: Make intermediate U/V with truncation = ', NIRESO) 300C 301 CALL JVOD2UV(PVYIN,PDVIN,NIRESO,UV(IP_U),UV(IP_V),NIRESO) 302C 303C Is the output a truncated spectral field? 304C 305 IF( LNORESO ) THEN 306C 307 CALL INTLOG(JP_DEBUG, 308 X 'INTUVU: Produce spectral output with truncation',NORESO) 309C 310 ISIZE = (NORESO+1)*(NORESO+2) 311 CALL JMEMHAN( JPSCR5, IZNFLDO, ISIZE, JPALLOC, IERR) 312 IF( IERR.NE.0 ) THEN 313 CALL INTLOG(JP_FATAL,'INTUVU: Get scratch fail',JPQUIET) 314 INTUVU = JPROUTINE + 2 315 GOTO 900 316 ENDIF 317C 318 CALL SH2SH( UV(IP_U), NIRESO, ZNFLDO, NORESO ) 319 DO LOOP = 1, ISIZE 320 PUOUT(LOOP) = ZNFLDO(LOOP) 321 ENDDO 322C 323 CALL SH2SH( UV(IP_V), NIRESO, ZNFLDO, NORESO ) 324 DO LOOP = 1, ISIZE 325 PVOUT(LOOP) = ZNFLDO(LOOP) 326 ENDDO 327C 328 NIRESO = NORESO 329C 330 OUTLEN = ISZUV 331 332 GOTO 900 333C 334 ENDIF 335C 336C -----------------------------------------------------------------| 337C Use new-style processing if IGNORE_UV_EXTRA_MODE not set 338C -----------------------------------------------------------------| 339C 340 ELSE 341C 342 CALL INTLOG(JP_DEBUG,'INTUVU: vo/div truncation = ', NTRUNC) 343 CALL INTLOG(JP_DEBUG,'INTUVU: U/V truncation = ', MTRUNC) 344C 345C Truncate vorticity and divergence to correspond to U/V 346C 347 ISIZE = (MTRUNC+1)*(MTRUNC+2) 348 CALL JMEMHAN( JPSCR5, IZNFLDO, ISIZE*2, JPALLOC, IERR) 349 IF( IERR.NE.0 ) THEN 350 CALL INTLOG(JP_ERROR, 351 X 'INTUVU: Scratch memory type 5 allocn failed.',JPQUIET) 352 INTUVU = JPROUTINE + 2 353 GOTO 900 354 ENDIF 355C 356 IPVORT = 1 357 CALL SH2SH( PVYIN, NIRESO, ZNFLDO, NTRUNC ) 358C 359 IDIVOFF = 1 + (NTRUNC+1)*(NTRUNC+2) 360 CALL SH2SH( PDVIN, NIRESO, ZNFLDO(IDIVOFF), NTRUNC ) 361C 362C Get scratch memory for U and V spectral fields. 363C U and V memory areas are adjacent. 364C 365 ISZUV = (MTRUNC+1)*(MTRUNC+2) 366 IP_U = 1 367 IP_V = 1 + ISZUV 368C 369 ISIZE = ISZUV*2 370 CALL JMEMHAN( JPSCR3, IUV, ISIZE, JPALLOC, IERR) 371 IF ( IERR .NE. 0 ) THEN 372 CALL INTLOG(JP_ERROR, 373 X 'INTUVU: Scratch memory type 3 allocation failed.',JPQUIET) 374 INTUVU = IERR 375 GOTO 900 376 ENDIF 377C 378C Generate U and V spectral fields 379C 380 CALL JVOD2UV(ZNFLDO(IPVORT),ZNFLDO(IDIVOFF),NTRUNC, 381 X UV(IP_U),UV(IP_V),MTRUNC) 382C 383 DO LOOP = 1, ISZUV 384 PUOUT(LOOP) = UV(LOOP) 385 PVOUT(LOOP) = UV(LOOP+ISZUV) 386 ENDDO 387C 388C 389 OUTLEN = ISZUV 390cs added in case of packing after conversion 391 NORESO = MTRUNC 392C 393 GOTO 900 394C 395 ENDIF 396C 397 ENDIF 398C 399C -----------------------------------------------------------------| 400C* Section 3. Generate grid point GRIB format U and V fields. 401C -----------------------------------------------------------------| 402C 403 300 CONTINUE 404C 405cs this is for merging with grib_api 406 LUVCOMP = .FALSE. 407C Spectral U and V for Tn are to be generated from vorticity 408C and divergence spectral T(n-1) 409C 410C See whether or not the 'autoresol' flag is set. 411C If not, use the input truncation. 412C 413 IF( LARESOL ) THEN 414 IF( (NOREPR.EQ.JPREGULAR).OR.(NOREPR.EQ.JPREGROT) ) THEN 415 EW = FLOAT(NOGRID(1))/PPMULT 416 NS = FLOAT(NOGRID(2))/PPMULT 417 ELSE 418 EW = 90.0/FLOAT(NOGAUSS) 419 NS = EW 420 ENDIF 421 NTRUNC = AURESOL(EW,NS) 422 IF( NTRUNC.NE.NTROLD ) THEN 423 NTROLD = NTRUNC 424 CALL INTLOG(JP_WARN, 425 X 'INTUVU: Resolution automatically set to ', NTRUNC) 426 ENDIF 427 ELSE IF( LNORESO ) THEN 428 NTRUNC = NORESO 429 ELSE 430 NTRUNC = NIRESO 431 ENDIF 432C 433C Check whether the output resolution is greater than the input 434C 435 IF( NTRUNC.GT.NIRESO ) THEN 436C 437C Issue warning if the output resolution was user-supplied 438C 439 IF( .NOT.LARESOL ) THEN 440C 441C Revert to the input truncation 442C 443 IF( NIRESO.NE.NTROLD2 ) THEN 444 CALL INTLOG(JP_WARN, 445 X 'INTUVU: spectral -> grid point interpolation',JPQUIET) 446 CALL INTLOG(JP_WARN, 447 X 'INTUVU: User supplied resolution = ',NTRUNC) 448 CALL INTLOG(JP_WARN, 449 X 'INTUVU: Input field resolution = ',NIRESO) 450 CALL INTLOG(JP_WARN, 451 X 'INTUVU: User supplied resolution ignored',JPQUIET) 452 CALL INTLOG(JP_WARN, 453 X 'INTUVU: Input field resolution has been used',JPQUIET) 454 NTROLD2 = NIRESO 455 ENDIF 456 NTRUNC = NIRESO 457C 458 ELSE 459C 460C Revert to the input truncation 461C 462 NTRUNC = NIRESO 463 IF( NTRUNC.NE.NTROLD2 ) THEN 464 NTROLD2 = NTRUNC 465 CALL INTLOG(JP_WARN, 466 X 'INTUVU: Automatic resolution selectn too high',JPQUIET) 467 CALL INTLOG(JP_WARN, 468 X 'INTUVU: Resolution reset to input resolution: ',NTRUNC) 469 ENDIF 470C 471 ENDIF 472 ENDIF 473C 474C IF extra mode is in use, adjust the calculated truncation. 475C 476 MTRUNC = NTRUNC 477 IF( LNEWUV ) NTRUNC = MTRUNC - 1 478C 479 CALL INTLOG(JP_DEBUG,'INTUVU: vo/div truncation = ', NTRUNC) 480 CALL INTLOG(JP_DEBUG,'INTUVU: U/V truncation = ', MTRUNC) 481C 482 ISIZE = (MTRUNC+1)*(MTRUNC+2) 483 CALL JMEMHAN( JPSCR5, IZNFLDO, ISIZE*2, JPALLOC, IERR) 484 IF( IERR.NE.0 ) THEN 485 CALL INTLOG(JP_FATAL, 486 X 'INTUVU: Get scratch space failed',JPQUIET) 487 INTUVU = JPROUTINE + 3 488 GOTO 900 489 ENDIF 490C 491C Adjust the vorticity and divergence by one wave number before 492C conversion to U and V 493C 494 IPVORT = 1 495 IDIVOFF = 1 + (NTRUNC+1)*(NTRUNC+2) 496C 497 CALL SH2SH( PVYIN, NIRESO, ZNFLDO, NTRUNC ) 498C 499 CALL SH2SH( PDVIN, NIRESO, ZNFLDO(IDIVOFF), NTRUNC ) 500C 501C Get scratch memory for U and V spectral fields. 502C U and V memory areas are adjacent. 503C 504 ISZUV = (MTRUNC+1)*(MTRUNC+2) 505 IP_U = 1 506 IP_V = IP_U + ISZUV 507C 508 ISIZE = ISZUV*2 509 CALL JMEMHAN( JPSCR3, IUV, ISIZE, JPALLOC, IERR) 510 IF( IERR.NE.0 ) THEN 511 CALL INTLOG(JP_ERROR, 512 X 'INTUVU: Scratch memory type 3 allocation failed.',JPQUIET) 513 INTUVU = IERR 514 GOTO 900 515 ENDIF 516C 517C Generate U and V spectral fields 518C 519 CALL JVOD2UV(ZNFLDO(IPVORT),ZNFLDO(IDIVOFF),NTRUNC, 520 X UV(IP_U),UV(IP_V),MTRUNC) 521C 522 NIRESO = MTRUNC 523C 524C 525 LSTYLE = LNOSTYLE.AND. 526 X (NOSTYLE.EQ.JPSDISM).AND. 527 X (NOREPR.EQ.JPREGULAR) 528C 529 IF( LSTYLE ) THEN 530 EW = NOGRID(1) / PPMULT 531 NS = NOGRID(2) / PPMULT 532 NORTH = REAL(NOAREA(1)) / PPMULT 533 WEST = REAL(NOAREA(2)) / PPMULT 534 SOUTH = REAL(NOAREA(3)) / PPMULT 535 EAST = REAL(NOAREA(4)) / PPMULT 536C 537 IERR = DSSAREA( EW, NS, NORTH, WEST, SOUTH, EAST) 538 IF( IERR.NE.0 ) THEN 539 CALL INTLOG(JP_ERROR,'INTUVU: DSSAREA failed:',IERR) 540 INTUVU = JPROUTINE + 3 541 GOTO 900 542 ENDIF 543C 544 NOAREA(1) = NINT(NORTH * PPMULT) 545 NOAREA(2) = NINT(WEST * PPMULT) 546 NOAREA(3) = NINT(SOUTH * PPMULT) 547 NOAREA(4) = NINT(EAST * PPMULT) 548 ELSE 549C Fixup area definition to correspond to grid definitions 550 IERR = FIXAREA() 551 IF ( IERR .NE. 0 ) THEN 552 CALL INTLOG(JP_ERROR, 553 X 'INTUVU: Fixup area definition failed.',JPQUIET) 554 INTUVU = IERR 555 GOTO 900 556 ENDIF 557 ENDIF 558 DO KK = 1,4 559 NOAAPI(KK) = NOAREA(KK) 560 ENDDO 561 562 NIFORM = 0 563 NIPARAM = JP_U 564 LWIND = .TRUE. 565 LOLDWIND = LWINDSET 566 LWINDSET = .TRUE. 567C 568 IF(LSFCUVI) GOTO 850 569 IF( LNOROTA ) GOTO 700 570 571C -----------------------------------------------------------------| 572C* Section 4. Interpolate U field. 573C -----------------------------------------------------------------| 574C 575 400 CONTINUE 576C 577 IERR = INTFAU( UV(IP_U), ISZUV, PUOUT, OUTLEN) 578 IF ( IERR .NE. 0 ) THEN 579 CALL INTLOG(JP_ERROR, 580 X 'INTUVU: Prepare to interpolate failed.',JPQUIET) 581 INTUVU = IERR 582 GOTO 900 583 ENDIF 584C 585 IERR = INTFBU( UV(IP_U), ISZUV, PUOUT, OUTLEN) 586C 587 IF ( IERR .NE. 0 ) THEN 588 CALL INTLOG(JP_ERROR,'INTUVU: Interpolation failed.',JPQUIET) 589 INTUVU = IERR 590 GOTO 900 591 ENDIF 592C 593C -----------------------------------------------------------------| 594C* Section 5. Interpolate V field. 595C -----------------------------------------------------------------| 596C 597 500 CONTINUE 598C 599 NIPARAM = JP_V 600 IERR = INTFAU( UV(IP_V), ISZUV, PVOUT, OUTLEN) 601 IF ( IERR .NE. 0 ) THEN 602 CALL INTLOG(JP_ERROR, 603 X 'INTUVU: Prepare to interpolate failed.',JPQUIET) 604 INTUVU = IERR 605 GOTO 900 606 ENDIF 607C 608 IERR = INTFBU( UV(IP_V), ISZUV, PVOUT, OUTLEN) 609C 610 IF ( IERR .NE. 0 ) THEN 611 CALL INTLOG(JP_ERROR, 612 X 'INTUVU: INTFBU interpolate failed.',JPQUIET) 613 INTUVU = IERR 614 GOTO 900 615 ENDIF 616 617cs GOTO 900 618 GOTO 890 619C 620C -----------------------------------------------------------------| 621C* Section 6. Initialise spectral to grid-point with rotation 622C -----------------------------------------------------------------| 623C 624 700 CONTINUE 625 IF( .NOT.LUSEHIR ) THEN 626 CALL INTLOG(JP_ERROR, 627 X 'INTUVU: Unable to rotate spectral U or V:',JPQUIET) 628 INTUVU = JPROUTINE + 6 629 GOTO 900 630 ENDIF 631C 632 IF( (NOREPR.NE.JPREGROT).AND.(NOREPR.NE.JPREGULAR) ) THEN 633 CALL INTLOG(JP_ERROR, 634 X 'INTUVU: For U/V, only regular lat/long',JPQUIET) 635 CALL INTLOG(JP_ERROR, 636 X 'INTUVU: output rotated grids allowed',JPQUIET) 637 INTUVU = JPROUTINE + 6 638 GOTO 900 639 ENDIF 640C 641cs this is for merging with grib_api 642 LUVCOMP = .TRUE. 643 CALL INTLOG(JP_DEBUG,'INTUVU: Rotate the U & V fields',JPQUIET) 644 CALL INTLOG(JP_DEBUG,'INTUVU: South pole lat ',NOROTA(1)) 645 CALL INTLOG(JP_DEBUG,'INTUVU: South pole long ',NOROTA(2)) 646C 647C Fill area limits (handles case when default 0/0/0/0 given) 648C 649cssssssssss 650cs IERR = FIXAREA() 651cs IF( IERR.NE.0 ) THEN 652cs CALL INTLOG(JP_ERROR,'INTUVU: area fixup failed',JPQUIET) 653cs INTUVU = JPROUTINE + 6 654cs GOTO 900 655cs ENDIF 656C 657 AREA(1) = REAL(NOAREA(1))/PPMULT 658 AREA(2) = REAL(NOAREA(2))/PPMULT 659 AREA(3) = REAL(NOAREA(3))/PPMULT 660 AREA(4) = REAL(NOAREA(4))/PPMULT 661C 662 GRID(1) = REAL(NOGRID(1))/PPMULT 663 GRID(2) = REAL(NOGRID(2))/PPMULT 664C 665 POLE(1) = REAL(NOROTA(1))/PPMULT 666 POLE(2) = REAL(NOROTA(2))/PPMULT 667C 668C -----------------------------------------------------------------| 669C* Section 7. Convert spectral to suitable global reduced gaussian 670C -----------------------------------------------------------------| 671C 672 800 CONTINUE 673C 674 NTRUNC = NIRESO 675 NGAUSS = 0 676 HTYPE = '' 677 NS = 0. 678 EW = 0. 679 IERR = HSH2GG(NS,EW,NTRUNC,NGAUSS,HTYPE,KPTS,GLATS,ISIZE) 680 IF( IERR.NE.0 ) THEN 681 CALL INTLOG(JP_ERROR, 682 X 'INTUVU: problem getting data for reduced grid',NTRUNC) 683 INTUVU = JPROUTINE + 7 684 GOTO 900 685 ENDIF 686 NCOUNT = ISIZE 687C 688C Dynamically allocate memory for global reduced gaussian grid 689C 690 CALL JMEMHAN( 18, IRGGRID, (NCOUNT*2), 1, IERR) 691 IF( IERR.NE.0 ) THEN 692 CALL INTLOG(JP_ERROR, 693 X 'INTUVU: memory alloc for reduced grid fail',JPQUIET) 694 INTUVU = JPROUTINE + 7 695 GOTO 900 696 ENDIF 697C 698C Set flag to show field is a wind component 699C 700 NUVFLAG = 1 701C 702C Create the reduced gaussian grid 703C 704 HOLDTYP = HOGAUST 705 WEST = 0.0 706 EAST = 360.0 - (360.0/FLOAT(KPTS(NGAUSS))) 707C 708C U component 709C 710 CALL JAGGGP(UV(IP_U),NTRUNC,GLATS(1),GLATS(NGAUSS*2),WEST, 711 X EAST,NGAUSS,HTYPE,KPTS,RGGRID,NUVFLAG,IERR) 712 IF( IERR.NE.0 ) THEN 713 CALL INTLOG(JP_ERROR, 714 X 'INTUVU: spectral to reduced gaussian failed',JPQUIET) 715 INTUVU = JPROUTINE + 7 716 GOTO 900 717 ENDIF 718C 719 HOGAUST = HOLDTYP 720C 721C V component 722C 723 CALL JAGGGP(UV(IP_V),NTRUNC,GLATS(1),GLATS(NGAUSS*2),WEST, 724 X EAST,NGAUSS,HTYPE,KPTS,RGGRID(1+NCOUNT),NUVFLAG,IERR) 725 IF( IERR.NE.0 ) THEN 726 CALL INTLOG(JP_ERROR, 727 X 'INTUVU: spectral to reduced gaussian failed',JPQUIET) 728 INTUVU = JPROUTINE + 7 729 GOTO 900 730 ENDIF 731 732 HOGAUST = HOLDTYP 733 734 735C -----------------------------------------------------------------| 736C* Section 8. Rotate using 12-point horizontal interpolation 737C -----------------------------------------------------------------| 738C 739 810 CONTINUE 740C 741C Dynamically allocate memory for rotated lat/long grid 742C 743 NLON = 1 + NINT(FLOAT(NOAREA(JPEAST) - NOAREA(JPWEST)) / 744 X NOGRID(JPWESTEP)) 745 NLAT = 1 + NINT(FLOAT(NOAREA(JPNORTH) - NOAREA(JPSOUTH)) / 746 X NOGRID(JPNSSTEP)) 747C 748 NUMPTS = NLON * NLAT 749 ISIZE = NUMPTS * 2 750 CALL JMEMHAN( 11, ISWORK, ISIZE, 1, IERR) 751 IF( IERR.NE.0 ) THEN 752 CALL INTLOG(JP_ERROR, 753 X 'INTUVU: memory alloc for lat/long grid fail',JPQUIET) 754 INTUVU = JPROUTINE + 8 755 GOTO 900 756 ENDIF 757C 758 IERR = HIRLAMW(LO12PT,RGGRID,RGGRID(1+NCOUNT),NCOUNT,NGAUSS,HTYPE, 759 X AREA,POLE,GRID,SWORK,SWORK(1+NUMPTS),NUMPTS,NLON,NLAT) 760C 761 IF( IERR.NE.0 ) THEN 762 CALL INTLOG(JP_ERROR, 763 X 'INTUVU: HIRLAMW rotation failed',JPQUIET) 764 INTUVU = JPROUTINE + 8 765 GOTO 900 766 ENDIF 767c 768 DO LOOP = 1, NUMPTS 769 PUOUT(LOOP) = SWORK(LOOP) 770 PVOUT(LOOP) = SWORK(LOOP+NUMPTS) 771 ENDDO 772 773 OUTLEN = NUMPTS 774 775cs GOTO 900 776 GOTO 890 777c -----------------------------------------------------------------| 778C* Section 8.1 Grid to rotated grid point 779C -----------------------------------------------------------------| 780 850 CONTINUE 781C* 8.1a Generate interpolated lat/long U and V fields. 782C -----------------------------------------------------------------| 783C 784cs this is for merging with grib_api 785 LUVCOMP = .TRUE. 786C 787 IF( (NOREPR.EQ.JPREGULAR).OR.(NOREPR.EQ.JPREGROT) ) THEN 788C 789C Dynamically allocate scrath space for rotated lat/long grid 790C 791 NLON = 1 + NINT(FLOAT(NOAREA(JPEAST) - NOAREA(JPWEST)) / 792 X NOGRID(JPWESTEP)) 793 NLAT = 1 + NINT(FLOAT(NOAREA(JPNORTH) - NOAREA(JPSOUTH)) / 794 X NOGRID(JPNSSTEP)) 795C 796 NOWE = NLON 797 NONS = NLAT 798 OUTLEN = NLON * NLAT 799C 800C Rotate reduced gaussian to lat/long 801C 802 IF( (NIREPR.EQ.JPGAUSSIAN).OR.(NIREPR.EQ.JPQUASI) ) THEN 803 CALL INTLOG(JP_DEBUG, 804 X 'INTUVU: Rotate reduced gaussian to lat/long',JPQUIET) 805 IERR = HIRLAMW(LO12PT, 806 X PVYIN,PDVIN,INLEN, 807 X NOGAUSS,HTYPE,AREA,POLE,GRID, 808 X PUOUT,PVOUT,OUTLEN,NLON,NLAT) 809 IF( IERR.NE.0 ) THEN 810 CALL INTLOG(JP_ERROR, 811 X 'INTUVU: HIRLAMW rotation failed',JPQUIET) 812 INTUVU = JPROUTINE + 8 813 GOTO 900 814 ENDIF 815C 816C Rotate lat/long to lat/long 817C 818 ELSE 819 CALL INTLOG(JP_DEBUG, 820 X 'INTUVU: Rotate lat/long to lat/long',JPQUIET) 821 OLDGRID(1) = REAL(NIGRID(1)) / PPMULT 822 OLDGRID(2) = REAL(NIGRID(2)) / PPMULT 823 IERR = HLL2LLW(LO12PT,PVYIN,PDVIN, 824 X OLDGRID,AREA,POLE,GRID, 825 X PUOUT,PVOUT,OUTLEN,NLON,NLAT) 826 IF( IERR.NE.0 ) THEN 827 CALL INTLOG(JP_ERROR, 828 X 'INTUVU: HLL2LLW rotation failed',JPQUIET) 829 INTUVU = JPROUTINE + 8 830 GOTO 900 831 ENDIF 832 ENDIF 833C 834 ELSE 835 836* Section 8.1b Generate interpolated gaussian U and V fields. 837C -----------------------------------------------------------------| 838C 839C 840 CALL INTLOG(JP_DEBUG, 841 X 'INTUVU: Rotate gaussian to gaussian',JPQUIET) 842C 843C Dynamically allocate memory for rotated gaussian grids 844C 845 NUMPTS = NOGAUSS * NOGAUSS 846 OUTLEN = 2 * NUMPTS * 8 847C 848cs NGAUSS = ISEC2(10) 849 IERR = HRG2GGW(LO12PT, 850 X PVYIN,PDVIN,INLEN, 851 X NIGAUSS,AREA,POLE,NOGAUSS,HOGAUST, 852 X PUOUT,PVOUT,OUTLEN,NUMPTS) 853 IF( IERR.NE.0 ) THEN 854 CALL INTLOG(JP_ERROR, 855 X 'INTUVU: HRG2GGW rotation failed',JPQUIET) 856 INTUVU = JPROUTINE + 8 857 GOTO 900 858 ENDIF 859C 860 ENDIF 861C 862 890 CONTINUE 863 IF( LFRAME ) THEN 864 NLON = 1 + NINT(FLOAT(NOAREA(JPEAST) - NOAREA(JPWEST)) / 865 X NOGRID(JPWESTEP)) 866 NLAT = 1 + NINT(FLOAT(NOAREA(JPNORTH) - NOAREA(JPSOUTH)) / 867 X NOGRID(JPNSSTEP)) 868 ISEC1(5) = 192 869 ISEC3(2) = NINT(RMISSGV) 870 ZSEC3(2) = RMISSGV 871 LIMISSV = .TRUE. 872 CALL MKFRAME(NLON,NLAT,PUOUT,RMISSGV,NOFRAME) 873 CALL MKFRAME(NLON,NLAT,PVOUT,RMISSGV,NOFRAME) 874 ENDIF 875 876C 877C 878C -----------------------------------------------------------------| 879C* Section 9. Closedown. 880C -----------------------------------------------------------------| 881C 882 900 CONTINUE 883C 884C Clear change flags for next product processing 885 LCHANGE = .FALSE. 886 LSMCHNG = .FALSE. 887 LWINDSET = LOLDWIND 888 DO 910 LOOP = 1, 4 889 NOAREA(LOOP) = IOHOLD(LOOP) 890 910 CONTINUE 891C 892 NIRESO = NOLD 893C 894 RETURN 895 END 896