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