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 IGALLOC (KLEVEL, KREQUEST, KADDR, KPR, KERR) 12C 13C----> 14C**** *IGALLOC* 15C 16C PURPOSE 17C _______ 18C 19C This routine allocates heap space. 20C 21C INTERFACE 22C _________ 23C 24C IERR = IGALLOC (KLEVEL, KREQUEST, KADDR, KPR, KERR) 25C 26C Input parameters 27C ________________ 28C 29C KLEVEL - The heap block number. 30C 31C KREQUEST - The amount of heap space required. 32C 33C KPR - The debug print switch. 34C 0 , No debugging output. 35C 1 , Produce debugging output. 36C 37C KERR - The error control flag. 38C -ve, No error message. Return error code. 39C 0 , Hard failure with error message. 40C +ve, Print error message. Return error code. 41C 42C Output parameters 43C ________________ 44C 45C KADDR - The base address of the heap space allocated. 46C 47C Return value 48C ____________ 49C 50C The error indicator (INTEGER). 51C 52C Error and Warning Return Values 53C _______________________________ 54C 55C Cray error codes 56C 57Cray -1 HPDEALLC block is already free (Warning only). 58Cray 59Cray 24301 HPDEALLC attempt to free block at address outside the 60Cray bounds of the heap. 61Cray 24302 HPDEALLC attempt to free block at address which was not 62Cray the beginning of a block. 63Cray 24303 HPDEALLC returning any other non zero code. 64Cray 24304 HPALLOC request was not greater than 0 words. 65Cray 24305 HPALLOC called and not enough memory was available. 66Cray 24306 HPALLOC The memory arena has been truncated by a user 67Cray ssbreak(2) call. 68Cray 24307 HPALLOC returning any other non zero code. 69Cray 70Cray Errors 24301, 24302 and 24304 should not occur and any occurrence 71Cray of one of these errors should be reported to Meteorological 72Cray Applications. 73C 74C Sun and SGI error codes 75C 76C 24301 MALLOC memory allocation failed. 77C 78C Common block usage 79C __________________ 80C 81C memreq.h - This file contains the memory request definition 82C variables. 83C 84C MADDR - The base addresses of the currently allocated 85C memory segments are modified. 86C MREQUEST - The sizes of the current memory requests are modified. 87C 88C EXTERNALS 89C _________ 90C 91C INTLOG(R) - Logs messages. 92C 93C Cray externals 94C 95Cray HPALLOC - Cray library routine to allocate heap space. 96Cray HPDEALLC - Cray library routine to de-allocate heap space. 97C 98C Sun and SGI externals 99C 100C JFREE - Unix routine to free heap space. 101C JMALLOC - Unix routine to acquire heap space. 102C 103C METHOD 104C ______ 105C 106C The heap block number is used to indicate which heap is being 107C modified. Currently heap 1 is used to acquire space for 108C expanding GRIB arrays into real arrays and heap 2 is used for 109C internal space during the interpolation process. 110C 111C REFERENCE 112C _________ 113C 114C None 115C 116C COMMENTS 117C ________ 118C 119C Program contains sections 0 to 2 and 9 120C 121C AUTHOR 122C ______ 123C 124C K. Fielding *ECMWF* Jan 1994 125C 126C MODIFICATIONS 127C _____________ 128C 129C J.D.Chambers ECMWF Feb 1997 130C Allow for 64-bit pointers 131C 132C----< 133C -----------------------------------------------------------------| 134C* Section 0. Definition of variables. 135C -----------------------------------------------------------------| 136C 137 IMPLICIT NONE 138C 139#include "parim.h" 140#include "memreq.h" 141C 142C Function arguments 143C 144 INTEGER KLEVEL, KREQUEST, KPR, KERR 145#if (defined POINTER_64) 146 INTEGER*8 KADDR 147#else 148 INTEGER KADDR 149#endif 150C 151C Local variables 152C 153 INTEGER IABORT, IERROR 154#ifdef POINTER_64 155 INTEGER*8 IDUMMY 156#else 157 INTEGER IDUMMY 158#endif 159 DATA IDUMMY/0/ 160 INTEGER JPROUTINE 161 PARAMETER (JPROUTINE = 24300) 162C 163C External functions 164C 165#ifdef POINTER_64 166 INTEGER*8 JMALLOC 167#else 168 INTEGER JMALLOC 169#endif 170 EXTERNAL JMALLOC 171C 172C -----------------------------------------------------------------| 173C* Section 1. Initialisation 174C -----------------------------------------------------------------| 175C 176 100 CONTINUE 177C 178 IGALLOC = 0 179C 180 IF( KPR.GE.1 ) THEN 181 CALL INTLOG(JP_DEBUG,'IGALLOC: Input parameters.',JPQUIET) 182 CALL INTLOG(JP_DEBUG,'IGALLOC: Heap number = ',KLEVEL) 183 CALL INTLOG(JP_DEBUG,'IGALLOC: Heap request = ',KREQUEST) 184 CALL INTLOG(JP_DEBUG,'IGALLOC: Current heap =',MREQUEST(KLEVEL)) 185 ENDIF 186C 187C -----------------------------------------------------------------| 188C* Section 2. Calculate arrays of weights 189C -----------------------------------------------------------------| 190C 191 200 CONTINUE 192C 193 IABORT = 0 194 IERROR = 0 195C 196 IF( MREQUEST(KLEVEL).LT.KREQUEST.AND.MREQUEST(KLEVEL).GT.0) THEN 197C 198C Memory required is greater than that currently allocated 199C 200C Return any heap in use for spectral -> grid point operations 201C 202 CALL JMEMHAN(1,IDUMMY,IDUMMY,0,IERROR) 203 CALL JMEMHAN(2,IDUMMY,IDUMMY,0,IERROR) 204C 205 CALL JFREE (MADDR (KLEVEL) ) 206 ENDIF 207C 208C First request for memory. 209C 210 IF( MREQUEST(KLEVEL).LT.KREQUEST ) THEN 211C 212C Return any heap in use for spectral -> grid point operations 213C 214 CALL JMEMHAN(1,IDUMMY,IDUMMY,0,IERROR) 215 CALL JMEMHAN(2,IDUMMY,IDUMMY,0,IERROR) 216C 217 MADDR(KLEVEL) = JMALLOC(KREQUEST) 218#ifdef hpR64 219 MADDR(KLEVEL) = MADDR(KLEVEL)/(1024*1024*1024*4) 220#endif 221 IF( MADDR(KLEVEL).EQ.0 ) THEN 222C 223 IGALLOC = JPROUTINE + 8 224 CALL INTLOG(JP_ERROR,'IGALLOC: Memory requested = ',KREQUEST) 225 CALL INTLOG(JP_ERROR, 226 X 'IGALLOC: No more memory available from system.',JPQUIET) 227 IF( KERR.EQ.0 ) CALL INTLOG(JP_FATAL, 228 X 'IGALLOC: Interpolation failed.',IGALLOC) 229 GOTO 900 230 ENDIF 231C 232 KADDR = MADDR(KLEVEL) 233 MREQUEST(KLEVEL) = KREQUEST 234C 235 ELSE 236C 237C Memory required is <= to that already allocated 238C 239 KADDR = MADDR(KLEVEL) 240C 241 ENDIF 242C 243 IF( KPR.GE.1 ) THEN 244 CALL INTLOG(JP_DEBUG,'IGALLOC: Return heap address = ',KADDR) 245 ENDIF 246C 247C -----------------------------------------------------------------| 248C* Section 9. Return to calling routine. Format statements 249C -----------------------------------------------------------------| 250C 251 900 CONTINUE 252C 253 IF( KPR.GE.1 ) CALL INTLOG(JP_DEBUG,'IGALLOC: Section 9.',JPQUIET) 254 255 RETURN 256 END 257