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
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
|
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
SUBROUTINE JMEMHAN( KFLAG, KZOUTBF, KSIZE, KOPT, KRET)
C
C---->
C**** JMEMHAN
C
C PURPOSE
C _______
C
C This routine handles memory allocation for jintll.F and jintgg.F
C
C INTERFACE
C _________
C
C CALL JMEMHAN( KFLAG, KZOUTBF, KSIZE, KOPT, KRET)
C
C Input parameters
C ________________
C
C KFLAG - Flag to select lat/long or gaussian allocation
C = 1 for grid to grid interpolation (igalloc)
C = 2 for grid to grid interpolation (igalloc)
C = 3 for scratch space
C = 4 for vorticity and divergence scratch space
C = 5 for even more scratch space (!?)
C = 6 for latitude/longitude interpolation coefficients
C on Fujitsu
C = 7 for gaussian interpolation coefficients on Fujitsu
C = 8 unused
C = 9 for FFT work space
C = 10 for output (partial) grid point field workspace
C = 11 for work space for rotating fields (see intfap.F)
C = 12 for raw land-sea mask (see iglsmst.F)
C = 13 for 10 minute land-sea mask (see iglsm01.F)
C = 14 for reading legendre coefficents line by line
C = 15 more work space for rotating fields (see intfap.F)
C = 16 more work space intfbu.F
C = 17 more work space ??
C = 18 for rotation of gaussian grids (ggrotat and tatorgg)
C = 19 for dynamic allocation of znfeldi (intf)
C = 20 to 22, coefficients for rotating spectral fields (jacobif)
C
C KSIZE - Size of memory required in words
C KOPT - Memory option
C = 0 to deallocate
C = 1 to allocate
C
C
C Output parameters
C ________________
C
C KZOUTBF - Pointer to memory (if allocating)
C KRET - Return status code
C 0 = OK
C
C
C Common block usage
C __________________
C
C JDCNDGB
C JMEMCOM
C
C
C Method
C ______
C
C None.
C
C
C Externals
C _________
C
C JDEBUG - Checks environment variable to switch on/off debug
#ifdef CRAY
C HPALLOC - Allocate heap space
C HPDEALLC - Deallocate heap space
#else
C JMALLOC - Allocate heap space
C JFREE - Deallocate heap space
#endif
C INTLOG - Output log message
C IAFREE - Deallocate heap space used by grid-pt to grid-pt
C interpolation
C
C
C Reference
C _________
C
C None.
C
C
C Comments
C ________
C
C None.
C
C
C AUTHOR
C ______
C
C J.D.Chambers *ECMWF* May 1994
C
C MODIFICATIONS
C _____________
C
C J.D.Chambers *ECMWF* Jan 1995
C Add scratch for vorticity and divergence (flag = 4)
C
C J.D.Chambers *ECMWF* Jan 1995
C Add space for interpolation coefficents (flag = 6)
C
C J.D.Chambers *ECMWF* Sep 1996
C Split space for interpolation coefficents (flag = 6 and 7)
C
C J.D.Chambers ECMWF Feb 1997
C Allow for 64-bit pointers
C
C J.D.Chambers ECMWF Mar 1998
C Allow memory flushing
C
C----<
C -------------------------------------------------------
C* Section 0. Definition of variables.
C -------------------------------------------------------
C
IMPLICIT NONE
#include "jparams.h"
#include "jparam2.h"
#include "parim.h"
C
C Parameters
C
INTEGER JPROUTINE, JPOPTMX
PARAMETER ( JPROUTINE = 30600 )
PARAMETER ( JPOPTMX = 22 )
C
C Subroutine arguments
C
#ifdef POINTER_64
INTEGER*8 KZOUTBF
#else
INTEGER KZOUTBF
#endif
INTEGER KSIZE, KOPT, KRET, KFLAG
C
C Local variables
C
LOGICAL LDEBUG, LDEBUG1
INTEGER ITOTAL, LOOP
#ifdef POINTER_64
INTEGER*8 IZOUTBF
#else
INTEGER IZOUTBF
#endif
INTEGER IEXIST
DIMENSION IEXIST(JPOPTMX)
DIMENSION IZOUTBF(JPOPTMX)
DATA IEXIST/ JPOPTMX * -1/
DATA IZOUTBF/ JPOPTMX * 0/
C
SAVE IEXIST, IZOUTBF
C
C Externals
C
#ifdef POINTER_64
INTEGER*8 JMALLOC
#else
INTEGER JMALLOC
#endif
INTEGER IAFREE
EXTERNAL JMALLOC, IAFREE
C
C -------------------------------------------------------
C* Section 1. Initialisation.
C -------------------------------------------------------
C
100 CONTINUE
C
KRET = 0
CALL JDEBUG( )
LDEBUG = ( NDBG.GT.0 )
LDEBUG1 = ( NDBG.EQ.1 )
C
C Check that a valid option has been chosen
C
IF( ( KFLAG.LT.1 ).OR.( KFLAG.GT.JPOPTMX ) ) THEN
CALL INTLOG(JP_ERROR,'JMEMHAN: Invalid flag = ', KFLAG)
KRET = JPROUTINE + 1
GOTO 900
ENDIF
C
C Display diagnostics if required
C
IF( LDEBUG ) THEN
C
CALL INTLOG(JP_DEBUG,'JMEMHAN: Input parameters:',JPQUIET)
CALL INTLOG(JP_DEBUG, 'JMEMHAN: Memory type flag = ', KFLAG)
C
IF( ( KFLAG.EQ.1 ).OR.( KFLAG.EQ.2 ) ) CALL INTLOG(JP_DEBUG,
X 'JMEMHAN: 1 = grid to grid interpolation', JPQUIET)
C
IF( ( KFLAG.EQ.3 ).OR.( KFLAG.EQ.4 ).OR.( KFLAG.EQ.5 ) )
X CALL INTLOG(JP_DEBUG,
X 'JMEMHAN: 3->5 = scratch,',JPQUIET)
C
IF( KFLAG.EQ.6 ) CALL INTLOG(JP_DEBUG,
X 'JMEMHAN: 6 = coeffs for spectral to lat/long interp',JPQUIET)
C
IF( KFLAG.EQ.7 ) CALL INTLOG(JP_DEBUG,
X 'JMEMHAN: 7 = coefs for spectral to gaussian interp,',JPQUIET)
C
IF( KFLAG.EQ.8 ) CALL INTLOG(JP_DEBUG,
X 'JMEMHAN: 8 = coefficients for rotating SH fields',JPQUIET)
C
IF( KFLAG.EQ.9 ) CALL INTLOG(JP_DEBUG,
X 'JMEMHAN: 9 = FFT workspace,',JPQUIET)
C
IF( KFLAG.EQ.10 ) CALL INTLOG(JP_DEBUG,
X 'JMEMHAN: 10 = output (partial) grid pt field,',JPQUIET)
C
IF( KFLAG.EQ.11 ) CALL INTLOG(JP_DEBUG,
X 'JMEMHAN: 11 = work space for rotating fields,',JPQUIET)
C
IF( KFLAG.EQ.12 ) CALL INTLOG(JP_DEBUG,
X 'JMEMHAN: 12 = raw land-sea mask,',JPQUIET)
C
IF( KFLAG.EQ.13 ) CALL INTLOG(JP_DEBUG,
X 'JMEMHAN: 13 = 10 minute land-sea mask.',JPQUIET)
C
IF( KFLAG.EQ.14 ) CALL INTLOG(JP_DEBUG,
X 'JMEMHAN: 14 = legendre coefficents line by line.',JPQUIET)
C
IF( KFLAG.EQ.15 ) CALL INTLOG(JP_DEBUG,
X 'JMEMHAN: 15 = more work space for rotating fields.',JPQUIET)
C
IF( KFLAG.EQ.16 ) CALL INTLOG(JP_DEBUG,
X 'JMEMHAN: 16 = more work space for intfbu.F.',JPQUIET)
C
IF( KFLAG.EQ.17 ) CALL INTLOG(JP_DEBUG,
X 'JMEMHAN: 17 = more work space for ??.',JPQUIET)
C
IF( KFLAG.EQ.18 ) CALL INTLOG(JP_DEBUG,
X 'JMEMHAN: 18 = space for rotating gaussian fields.',JPQUIET)
C
IF( KFLAG.EQ.19 ) CALL INTLOG(JP_DEBUG,
X 'JMEMHAN: 19 = for dynamic allocation of znfeldi.',JPQUIET)
C
IF( KFLAG.EQ.20 ) CALL INTLOG(JP_DEBUG,
X 'JMEMHAN: 20 = coefficients for rotating SH fields',JPQUIET)
C
IF( KFLAG.EQ.21 ) CALL INTLOG(JP_DEBUG,
X 'JMEMHAN: 21 = coefficients for rotating SH fields',JPQUIET)
C
IF( KFLAG.EQ.22 ) CALL INTLOG(JP_DEBUG,
X 'JMEMHAN: 22 = coefficients for rotating SH fields',JPQUIET)
C
CALL INTLOG(JP_DEBUG,'JMEMHAN: Memory reqd in words = ', KSIZE)
CALL INTLOG(JP_DEBUG,'JMEMHAN: Option (1 = allocate) = ', KOPT)
ENDIF
C
C -------------------------------------------------------
C* Section 2. Allocate memory
C -------------------------------------------------------
C
200 CONTINUE
C
IF( KOPT.EQ.1 ) THEN
C
IF( LDEBUG ) THEN
CALL INTLOG(JP_DEBUG,
X 'JMEMHAN: Requested allocation = ', KSIZE)
CALL INTLOG(JP_DEBUG,
X 'JMEMHAN: Previous allocation = ', IEXIST(KFLAG))
ENDIF
C
C See if more memory required than already allocated
C
IF( KSIZE.GT.IEXIST(KFLAG) ) THEN
C
C Special cases (sigh)
C
C If allocating memory for spectral to lat/long or gaussian
C interpolation, first deallocate heap space used by grid-pt
C to grid-pt interpolation.
C
IF( ( KFLAG.EQ.1 ).OR.( KFLAG.EQ.2 ) ) THEN
IF( LDEBUG ) THEN
KRET = IAFREE(1,1)
ELSE
KRET = IAFREE(0,-1)
ENDIF
ENDIF
C
C If allocating memory on VPP for spectral to grid interpolation
C coefficients, first deallocate memory used by other type of
C spectral to gaussian interpolation if this option has been
C requested.
C
IF( LFREECF ) THEN
IF( LDEBUG ) CALL INTLOG(JP_DEBUG,
X 'JMEMHAN: Free coefficients option exercised', JPQUIET)
C
C Spectral -> lat/long
C
IF( KFLAG.EQ.6 ) THEN
IF( IEXIST(7).NE.-1 ) THEN
IF( LDEBUG ) CALL INTLOG(JP_DEBUG,
X 'JMEMHAN: Free spect->gaussn coeff memory',IZOUTBF(7))
#ifdef CRAY
CALL HPDEALLC( IZOUTBF(7), KRET, 0)
IF( KRET .LT. 0 ) THEN
CALL INTLOG(JP_ERROR,
X 'JMEMHAN: Memory de-allocation failed',KRET)
KRET = JPROUTINE + 2
ENDIF
#else
CALL JFREE( IZOUTBF(7) )
#endif
IZOUTBF(7) = 0
IEXIST(7) = -1
NISIZE7 = 0
YOLDGG = 'xxxxxxxxxxxxxxx'
ENDIF
ENDIF
C
C Spectral -> gaussian
C
IF( KFLAG.EQ.7 ) THEN
IF( IEXIST(6).NE.-1 ) THEN
IF( LDEBUG ) CALL INTLOG(JP_DEBUG,
X 'JMEMHAN: Free spec->lat/lon coeff memory',IZOUTBF(6))
#ifdef CRAY
CALL HPDEALLC( IZOUTBF(6), KRET, 0)
IF( KRET .LT. 0 ) THEN
CALL INTLOG(JP_ERROR,
X 'JMEMHAN: Memory de-allocation failed',KRET)
KRET = JPROUTINE + 3
ENDIF
#else
CALL JFREE( IZOUTBF(6) )
#endif
IZOUTBF(6) = 0
IEXIST(6) = -1
NISIZE6 = 0
YOLDLL = 'xxxxxxxxxxxxxxxxxxx'
ENDIF
ENDIF
ENDIF
C
IF( LDEBUG ) CALL INTLOG(JP_DEBUG,
X 'JMEMHAN: Request greater than previous allocation', KSIZE)
C
C If memory already allocated, deallocate existing memory
C
IF( IEXIST(KFLAG).GE.0 ) THEN
C
IF( LDEBUG ) CALL INTLOG(JP_DEBUG,
X 'JMEMHAN: Deallocate existing memory',IEXIST(KFLAG))
#ifdef CRAY
CALL HPDEALLC( IZOUTBF(KFLAG), KRET, 0)
IF( KRET .LT. 0 ) THEN
CALL INTLOG(JP_ERROR,
X 'JMEMHAN: Memory de-allocation failed',KRET)
KRET = JPROUTINE + 4
ENDIF
#else
CALL JFREE( IZOUTBF(KFLAG) )
#endif
ENDIF
C
C Allocate heap memory
C
IF( LDEBUG ) CALL INTLOG(JP_DEBUG,
X 'JMEMHAN: Allocate new memory ',KSIZE)
C
IEXIST(KFLAG) = KSIZE
#ifdef CRAY
CALL HPALLOC( IZOUTBF(KFLAG), IEXIST(KFLAG), KRET, 0 )
IF( KRET.LT.0 ) THEN
CALL INTLOG(JP_ERROR,
X 'JMEMHAN: Memory allocation failed',KRET)
#else
#if (defined REAL_8)
IZOUTBF(KFLAG) = JMALLOC( IEXIST(KFLAG) * 8 )
#else
IZOUTBF(KFLAG) = JMALLOC( IEXIST(KFLAG) * 4 )
#endif
#ifdef hpR64
IZOUTBF(KFLAG) = IZOUTBF(KFLAG)/(1024*1024*1024*4)
#endif
IF( IZOUTBF(KFLAG).EQ.0 ) THEN
CALL INTLOG(JP_ERROR,
X 'JMEMHAN: Memory allocation failed',IZOUTBF(KFLAG))
#endif
IEXIST(KFLAG) = -1
KRET = JPROUTINE + 5
GOTO 900
ENDIF
ENDIF
C
IF( LFREECF ) THEN
C
C Spectral -> lat/long
C
IF( KFLAG.EQ.6 ) NISIZE6 = IEXIST(6)
C
C Spectral -> gaussian
C
IF( KFLAG.EQ.7 ) NISIZE7 = IEXIST(7)
C
ENDIF
C
C -------------------------------------------------------
C* Section 3. Deallocate memory
C -------------------------------------------------------
C
300 CONTINUE
C
ELSE
C
IF( LDEBUG ) CALL INTLOG(JP_DEBUG,
X 'JMEMHAN: Deallocate memory address = ',IZOUTBF(KFLAG))
C
IF( IZOUTBF(KFLAG).GT.0 ) THEN
C
#ifdef CRAY
CALL HPDEALLC( IZOUTBF(KFLAG), KRET, 0)
IF( KRET .LT. 0 ) THEN
CALL INTLOG(JP_ERROR,
X 'JMEMHAN: Memory deallocation failed',KRET)
KRET = JPROUTINE + 6
ENDIF
#else
CALL JFREE( IZOUTBF(KFLAG) )
#endif
IZOUTBF(KFLAG) = 0
IEXIST(KFLAG) = -1
C
ELSE
CALL INTLOG(JP_DEBUG,'JMEMHAN: Deallocation ignored',JPQUIET)
ENDIF
ENDIF
C
C _______________________________________________________
C
C* Section 9. Return to calling routine.
C _______________________________________________________
C
900 CONTINUE
IF( KRET.EQ.0 ) KZOUTBF = IZOUTBF(KFLAG)
C
IF( LDEBUG.AND.(.NOT.LDEBUG1) ) THEN
ITOTAL = 0
DO LOOP = 1, JPOPTMX
IF( IEXIST(LOOP).GT.0 ) THEN
CALL INTLOG(JP_DEBUG, 'JMEMHAN: For type ', LOOP)
#if (defined REAL_8)
CALL INTLOG(JP_DEBUG,
X 'JMEMHAN: bytes allocated = ', IEXIST(LOOP)*8 )
ITOTAL = ITOTAL + (IEXIST(LOOP) * 8)
#else
CALL INTLOG(JP_DEBUG,
X 'JMEMHAN: bytes allocated = ', IEXIST(LOOP)*4 )
ITOTAL = ITOTAL + (IEXIST(LOOP) * 4)
#endif
ENDIF
ENDDO
CALL INTLOG(JP_DEBUG,'JMEMHAN: Total bytes allocated=', ITOTAL)
CALL INTLOG(JP_DEBUG,'JMEMHAN: Return status code = ', KRET)
ENDIF
C
RETURN
END
|
