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