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 KRG2RGZ(OLDFLD, NEWFLD, NUMGGO, NUMGGN)
12C
13C---->
14C**** KRG2RGZ
15C
16C     Purpose
17C     -------
18C
19C     Interpolate a field based on one reduced gaussian grid to a
20C     field based on a different reduced gaussian grid.
21C
22C
23C     Interface
24C     ---------
25C
26C     IRET = KRG2RGZ(OLDFLD, NEWFLD, NUMGGO, NUMGGN)
27C
28C     Input
29C     -----
30C
31C     OLDFLD - Old field as array of values
32C     NUMGGO - Number of the old gaussian field
33C     NUMGGN - Number of the new gaussian field
34C
35C
36C     Output
37C     ------
38C
39C     NEWFLD - New field as array of values
40C
41C     Function returns:
42C       - the size in bytes of the new GRIB product if all is well
43C       - -1, otherwise.
44C
45C
46C     Method
47C     ------
48C
49C     Create new field and leave it unpacked.
50C
51C
52C     Externals
53C     ---------
54C
55C     KINTRG  - Interpolate reduced gaussian field to reduced gaussian
56C     INTLOG  - Log messages
57C
58C
59C     Author
60C     ------
61C
62C     J.D.Chambers     ECMWF     February 2002
63C
64C----<
65C
66      IMPLICIT NONE
67C
68C     Function arguments
69C
70      INTEGER NUMGGO, NUMGGN
71      REAL OLDFLD(*), NEWFLD(*)
72C
73#include "parim.h"
74#include "nifld.common"
75#include "nofld.common"
76#include "grfixed.h"
77C
78C     Parameters
79C
80      INTEGER JPINTB
81      INTEGER JSEC2
82      PARAMETER (JSEC2 = 5000)
83#ifdef INTEGER_8
84      PARAMETER (JPINTB = 8)
85#else
86      PARAMETER (JPINTB = 4)
87#endif
88C
89C     Local variables
90C
91      INTEGER OLDGEO(JSEC2), NEWGEO(JSEC2)
92      INTEGER LOOP
93      CHARACTER*1 HTYPE
94      REAL PLAT(JPMAXNG)
95C
96      INTEGER IRET
97C
98C     Externals
99C
100      INTEGER KINTRG
101      EXTERNAL KINTRG
102C
103C     -----------------------------------------------------------------|
104C*    Section 1.   Initialise
105C     -----------------------------------------------------------------|
106C
107  100 CONTINUE
108C
109      KRG2RGZ = 0
110C
111      IF( (NUMGGN*2).GT.JPMAXNG ) THEN
112        CALL INTLOG(JP_ERROR,'KRG2RGZ: Gaussian N too big = ',NUMGGN)
113        CALL INTLOG(JP_ERROR,'KRG2RGZ: Maximum handled = ',(JPMAXNG/2))
114        KRG2RGZ = -1
115        GOTO 900
116      ENDIF
117C
118C     -----------------------------------------------------------------|
119C*    Section 2.   Create new field.
120C     -----------------------------------------------------------------|
121C
122  200 CONTINUE
123C
124      DO LOOP = 1, JPMAXNG
125cs        OLDGEO(LOOP) = 0
126        OLDGEO(LOOP+22) = MILLEN(LOOP)
127      ENDDO
128cs      HTYPE = 'R'
129cs      CALL JGETGG(NUMGGO,HTYPE,PLAT,OLDGEO(23),IRET)
130cs      IF( IRET.NE.0 ) THEN
131cs        WRITE(*,*) 'KRG2RGZ: Problem calling JGETGG, status = ',IRET
132cs        KRG2RGZ = -1
133cs      RETURN
134cs      ENDIF
135
136C
137      OLDGEO(3)  = NUMGGO * 2
138      OLDGEO(4)  = NINT(PLAT(1)*1000.0)
139      OLDGEO(5)  = 0
140      OLDGEO(7)  = NINT(PLAT(NUMGGO*2)*1000.0)
141c     EMOS-199: adjusted for reduced_gg/octahedral
142c     OLDGEO(8)  = NINT((360.0-(360.0/REAL(NUMGGO*4)))*1000.0)
143      OLDGEO(8)  = NINT((360.0-(360.0/REAL(OLDGEO(23+NUMGGO))))*1000.0)
144      OLDGEO(10) = NUMGGO
145C
146      DO LOOP = 1, JPMAXNG
147        NEWGEO(LOOP) = 0
148      ENDDO
149      HTYPE = 'R'
150      IF( LOCTAHEDRAL ) HTYPE = 'O'
151      CALL JGETGG(NUMGGN,HTYPE,PLAT,NEWGEO(23),IRET)
152      IF( IRET.NE.0 ) THEN
153        WRITE(*,*) 'KRG2RGZ: Problem calling JGETGG, status = ',IRET
154        KRG2RGZ = -1
155        RETURN
156      ENDIF
157      NEWGEO(3)  = NUMGGN * 2
158      NEWGEO(4)  = NINT(PLAT(1)*1000.0)
159      NEWGEO(5)  = 0
160      NEWGEO(7)  = NINT(PLAT(NUMGGN*2)*1000.0)
161c     EMOS-199: adjusted for reduced_gg/octahedral
162c     NEWGEO(8)  = NINT((360.0-(360.0/REAL(NUMGGN*4)))*1000.0)
163      NEWGEO(8)  = NINT((360.0-(360.0/REAL(NEWGEO(23+NUMGGN))))*1000.0)
164      NEWGEO(10) = NUMGGN
165C
166      IRET = KINTRG(OLDGEO, NEWGEO, OLDFLD, NEWFLD)
167C
168      IF( IRET.LE.0 ) THEN
169        WRITE(*,*) 'KRG2RGZ: New field creation failed'
170        KRG2RGZ = -1
171        RETURN
172      ENDIF
173C
174cs      KRG2RGZ = IRET * JPINTB
175cs this is the outlen
176      KRG2RGZ = IRET
177
178      IF( LDOUBLE ) THEN
179c filing of millen for double interpolation
180         DO LOOP = 1, JPMAXNG
181           MILLEN(LOOP) = NEWGEO(LOOP+22)
182         ENDDO
183         CALL INTLOG(JP_DEBUG,
184     X   'KRG2RGZ: Set NIAREA - double interpolation',JPQUIET)
185         NIAREA(1)  = 0
186         NIAREA(2)  = 0
187         NIAREA(3)  = 0
188         NIAREA(4)  = 0
189         NIGAUSS    = NUMGGN
190cs        DO LOOP = 1, NINS
191cs          RIGAUSS(LOOP) = 0
192cs          MILLEN(LOOP) = 0
193cs        ENDDO
194         NINS       = NUMGGN*2
195      ELSE
196c sinisa for merging with grib_api
197         NONS      = 2 * NUMGGN
198         NOWE      = 0
199         NOAAPI(1) = NEWGEO(4)*JPMICRO
200         NOAAPI(2) = NEWGEO(5)*JPMICRO
201         NOAAPI(3) = NEWGEO(7)*JPMICRO
202         NOAAPI(4) = NEWGEO(8)*JPMICRO
203         NOAREA(1) = NEWGEO(4)*JPMICRO
204         NOAREA(2) = NEWGEO(5)*JPMICRO
205         NOAREA(3) = NEWGEO(7)*JPMICRO
206         NOAREA(4) = NEWGEO(8)*JPMICRO
207      ENDIF
208C
209C     -----------------------------------------------------------------|
210C*    Section 9.   Return
211C     -----------------------------------------------------------------|
212C
213  900 CONTINUE
214C
215      RETURN
216      END
217