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