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