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 KRG2RGU(OLDFLD, NEWFLD, NUMGGO, NUMGGN) 12C 13C----> 14C**** KRG2RGU 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 = KRG2RGU(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 Modifications 65C ------------- 66C 67C Use grid definition from input GRIB header to 68C cater for octahedral grid 69C S.Siemen ECMWF April 2015 70C 71C----< 72C 73 IMPLICIT NONE 74C 75C Function arguments 76C 77 INTEGER NUMGGO, NUMGGN 78 REAL OLDFLD(*), NEWFLD(*) 79C 80#include "parim.h" 81#include "nofld.common" 82#include "grfixed.h" 83C 84C Parameters 85C 86 INTEGER JPINTB 87 INTEGER JSEC2 88 PARAMETER (JSEC2 = 5000) 89#ifdef INTEGER_8 90 PARAMETER (JPINTB = 8) 91#else 92 PARAMETER (JPINTB = 4) 93#endif 94C 95C Local variables 96C 97 INTEGER OLDGEO(JSEC2), NEWGEO(JSEC2) 98 INTEGER LOOP 99 CHARACTER*1 HTYPE 100 REAL PLAT(JPMAXNG) 101C 102 INTEGER IRET 103C 104C Externals 105C 106 INTEGER KINTRG 107 EXTERNAL KINTRG 108C 109C -----------------------------------------------------------------| 110C* Section 1. Initialise 111C -----------------------------------------------------------------| 112C 113 100 CONTINUE 114C 115 KRG2RGU = 0 116C 117 IF( (NUMGGN*2).GT.JPMAXNG ) THEN 118 CALL INTLOG(JP_ERROR,'KRG2RGU: Gaussian N too big = ',NUMGGN) 119 CALL INTLOG(JP_ERROR,'KRG2RGU: Maximum handled = ',(JPMAXNG/2)) 120 KRG2RGU = -1 121 GOTO 900 122 ENDIF 123C 124C -----------------------------------------------------------------| 125C* Section 2. Create input and new field. 126C -----------------------------------------------------------------| 127C 128 200 CONTINUE 129C 130 OLDGEO(1:JPMAXNG) = 0 131 DO LOOP = 1, 2*NUMGGO 132 OLDGEO(22+LOOP) = MILLEN(LOOP) 133 ENDDO 134 HTYPE = 'U' 135 CALL JGETGG(NUMGGO,HTYPE,PLAT,OLDGEO(23),IRET) 136 IF( IRET.NE.0 ) THEN 137 WRITE(*,*) 'KRG2RGU: Problem calling JGETGG, status = ',IRET 138 KRG2RGU = -1 139 RETURN 140 ENDIF 141 142C 143 OLDGEO(3) = NUMGGO * 2 144 OLDGEO(4) = NINT(PLAT(1)*1000.0) 145 OLDGEO(5) = 0 146 OLDGEO(7) = NINT(PLAT(NUMGGO*2)*1000.0) 147c EMOS-199: adjusted for reduced_gg/octahedral 148c OLDGEO(8) = NINT((360.0-(360.0/REAL(NUMGGO*4)))*1000.0) 149 OLDGEO(8) = NINT((360.0-(360.0/REAL(OLDGEO(23+NUMGGO))))*1000.0) 150 OLDGEO(10) = NUMGGO 151C 152 DO LOOP = 1, JPMAXNG 153 NEWGEO(LOOP) = 0 154 ENDDO 155 HTYPE = 'R' 156 IF( LOCTAHEDRAL ) HTYPE = 'O' 157 CALL JGETGG(NUMGGN,HTYPE,PLAT,NEWGEO(23),IRET) 158 IF( IRET.NE.0 ) THEN 159 WRITE(*,*) 'KRG2RGU: Problem calling JGETGG, status = ',IRET 160 KRG2RGU = -1 161 RETURN 162 ENDIF 163 NEWGEO(3) = NUMGGN * 2 164 NEWGEO(4) = NINT(PLAT(1)*1000.0) 165 NEWGEO(5) = 0 166 NEWGEO(7) = NINT(PLAT(NUMGGN*2)*1000.0) 167c EMOS-199: adjusted for reduced_gg/octahedral 168c NEWGEO(8) = NINT((360.0-(360.0/REAL(NUMGGN*4)))*1000.0) 169 NEWGEO(8) = NINT((360.0-(360.0/REAL(NEWGEO(23+NUMGGN))))*1000.0) 170 NEWGEO(10) = NUMGGN 171C 172 IRET = KINTRG(OLDGEO, NEWGEO, OLDFLD, NEWFLD) 173C 174 IF( IRET.LE.0 ) THEN 175 WRITE(*,*) 'KRG2RGU: New field creation failed' 176 KRG2RGU = -1 177 RETURN 178 ENDIF 179c sinisa for merging with grib_api 180 NONS = 2*NOGAUSS 181 NOAAPI(1) = NOAREA(1) 182 NOAAPI(2) = NOAREA(2) 183 NOAAPI(3) = NOAREA(3) 184 NOAAPI(4) = NOAREA(4) 185C 186cs KRG2RGU = IRET * JPINTB 187cs this is the outlen 188 KRG2RGU = IRET 189C 190C -----------------------------------------------------------------| 191C* Section 9. Return 192C -----------------------------------------------------------------| 193C 194 900 CONTINUE 195C 196 RETURN 197 END 198