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      SUBROUTINE JMEMHAN( KFLAG, KZOUTBF, KSIZE, KOPT, KRET)
12C
13C---->
14C**** JMEMHAN
15C
16C     PURPOSE
17C     _______
18C
19C     This routine handles memory allocation for jintll.F and jintgg.F
20C
21C     INTERFACE
22C     _________
23C
24C     CALL JMEMHAN( KFLAG, KZOUTBF, KSIZE, KOPT, KRET)
25C
26C     Input parameters
27C     ________________
28C
29C     KFLAG   - Flag to select lat/long or gaussian allocation
30C               = 1  for grid to grid interpolation (igalloc)
31C               = 2  for grid to grid interpolation (igalloc)
32C               = 3  for scratch space
33C               = 4  for vorticity and divergence scratch space
34C               = 5  for even more scratch space (!?)
35C               = 6  for latitude/longitude interpolation coefficients
36C                    on Fujitsu
37C               = 7  for gaussian interpolation coefficients on Fujitsu
38C               = 8  unused
39C               = 9  for FFT work space
40C               = 10 for output (partial) grid point field workspace
41C               = 11 for work space for rotating fields (see intfap.F)
42C               = 12 for raw land-sea mask (see iglsmst.F)
43C               = 13 for 10 minute land-sea mask (see iglsm01.F)
44C               = 14 for reading legendre coefficents line by line
45C               = 15 more work space for rotating fields (see intfap.F)
46C               = 16 more work space intfbu.F
47C               = 17 more work space ??
48C               = 18 for rotation of gaussian grids (ggrotat and tatorgg)
49C               = 19 for dynamic allocation of znfeldi (intf)
50C               = 20 to 22, coefficients for rotating spectral fields (jacobif)
51C
52C     KSIZE   - Size of memory required in words
53C     KOPT    - Memory option
54C               = 0 to deallocate
55C               = 1 to allocate
56C
57C
58C     Output parameters
59C     ________________
60C
61C     KZOUTBF - Pointer to memory (if allocating)
62C     KRET    - Return status code
63C               0 = OK
64C
65C
66C     Common block usage
67C     __________________
68C
69C     JDCNDGB
70C     JMEMCOM
71C
72C
73C     Method
74C     ______
75C
76C     None.
77C
78C
79C     Externals
80C     _________
81C
82C     JDEBUG    - Checks environment variable to switch on/off debug
83C     JMALLOC   - Allocate heap space
84C     JFREE     - Deallocate heap space
85C     INTLOG    - Output log message
86C     IAFREE    - Deallocate heap space used by grid-pt to grid-pt
87C                 interpolation
88C
89C
90C     Reference
91C     _________
92C
93C     None.
94C
95C
96C     Comments
97C     ________
98C
99C     None.
100C
101C
102C     AUTHOR
103C     ______
104C
105C     J.D.Chambers      *ECMWF*      May 1994
106C
107C     MODIFICATIONS
108C     _____________
109C
110C     J.D.Chambers      *ECMWF*      Jan 1995
111C     Add scratch for vorticity and divergence (flag = 4)
112C
113C     J.D.Chambers      *ECMWF*      Jan 1995
114C     Add space for interpolation coefficents (flag = 6)
115C
116C     J.D.Chambers      *ECMWF*      Sep 1996
117C     Split space for interpolation coefficents (flag = 6 and 7)
118C
119C     J.D.Chambers     ECMWF        Feb 1997
120C     Allow for 64-bit pointers
121C
122C     J.D.Chambers     ECMWF        Mar 1998
123C     Allow memory flushing
124C
125C----<
126C     -------------------------------------------------------
127C*    Section 0. Definition of variables.
128C     -------------------------------------------------------
129C
130      IMPLICIT NONE
131#include "jparams.h"
132#include "jparam2.h"
133#include "parim.h"
134C
135C     Parameters
136C
137      INTEGER JPROUTINE, JPOPTMX
138      PARAMETER ( JPROUTINE = 30600 )
139      PARAMETER ( JPOPTMX = 22 )
140C
141C     Subroutine arguments
142C
143#ifdef POINTER_64
144      INTEGER*8 KZOUTBF
145#else
146      INTEGER KZOUTBF
147#endif
148      INTEGER KSIZE, KOPT, KRET, KFLAG
149C
150C     Local variables
151C
152      LOGICAL LDEBUG, LDEBUG1
153      INTEGER ITOTAL, LOOP
154#ifdef POINTER_64
155      INTEGER*8 IZOUTBF
156#else
157      INTEGER IZOUTBF
158#endif
159      INTEGER IEXIST
160      DIMENSION IEXIST(JPOPTMX)
161      DIMENSION IZOUTBF(JPOPTMX)
162      DATA IEXIST/ JPOPTMX * -1/
163      DATA IZOUTBF/ JPOPTMX * 0/
164C
165      SAVE IEXIST, IZOUTBF
166C
167C     Externals
168C
169#ifdef POINTER_64
170      INTEGER*8 JMALLOC
171#else
172      INTEGER JMALLOC
173#endif
174      INTEGER IAFREE
175      EXTERNAL JMALLOC, IAFREE
176C
177C     -------------------------------------------------------
178C*    Section 1.    Initialisation.
179C     -------------------------------------------------------
180C
181  100 CONTINUE
182C
183      KRET = 0
184      CALL JDEBUG( )
185      LDEBUG  = ( NDBG.GT.0 )
186      LDEBUG1 = ( NDBG.EQ.1 )
187C
188C     Check that a  valid option has been chosen
189C
190      IF( ( KFLAG.LT.1 ).OR.( KFLAG.GT.JPOPTMX ) ) THEN
191        CALL INTLOG(JP_ERROR,'JMEMHAN: Invalid flag = ', KFLAG)
192        KRET = JPROUTINE + 1
193        GOTO 900
194      ENDIF
195C
196C     Display diagnostics if required
197C
198      IF( LDEBUG ) THEN
199C
200        CALL INTLOG(JP_DEBUG,'JMEMHAN: Input parameters:',JPQUIET)
201        CALL INTLOG(JP_DEBUG, 'JMEMHAN: Memory type flag = ', KFLAG)
202C
203        IF( ( KFLAG.EQ.1 ).OR.( KFLAG.EQ.2 ) ) CALL INTLOG(JP_DEBUG,
204     X    'JMEMHAN: 1 = grid to grid interpolation', JPQUIET)
205C
206        IF( ( KFLAG.EQ.3 ).OR.( KFLAG.EQ.4 ).OR.( KFLAG.EQ.5 ) )
207     X    CALL INTLOG(JP_DEBUG,
208     X    'JMEMHAN: 3->5 = scratch,',JPQUIET)
209C
210        IF( KFLAG.EQ.6 ) CALL INTLOG(JP_DEBUG,
211     X    'JMEMHAN: 6 = coeffs for spectral to lat/long interp',JPQUIET)
212C
213        IF( KFLAG.EQ.7 ) CALL INTLOG(JP_DEBUG,
214     X    'JMEMHAN: 7 = coefs for spectral to gaussian interp,',JPQUIET)
215C
216        IF( KFLAG.EQ.8 ) CALL INTLOG(JP_DEBUG,
217     X    'JMEMHAN: 8 = coefficients for rotating SH fields',JPQUIET)
218C
219        IF( KFLAG.EQ.9 ) CALL INTLOG(JP_DEBUG,
220     X    'JMEMHAN: 9 = FFT workspace,',JPQUIET)
221C
222        IF( KFLAG.EQ.10 ) CALL INTLOG(JP_DEBUG,
223     X    'JMEMHAN: 10 = output (partial) grid pt field,',JPQUIET)
224C
225        IF( KFLAG.EQ.11 ) CALL INTLOG(JP_DEBUG,
226     X    'JMEMHAN: 11 = work space for rotating fields,',JPQUIET)
227C
228        IF( KFLAG.EQ.12 ) CALL INTLOG(JP_DEBUG,
229     X    'JMEMHAN: 12 = raw land-sea mask,',JPQUIET)
230C
231        IF( KFLAG.EQ.13 ) CALL INTLOG(JP_DEBUG,
232     X    'JMEMHAN: 13 = 10 minute land-sea mask.',JPQUIET)
233C
234        IF( KFLAG.EQ.14 ) CALL INTLOG(JP_DEBUG,
235     X    'JMEMHAN: 14 = legendre coefficents line by line.',JPQUIET)
236C
237        IF( KFLAG.EQ.15 ) CALL INTLOG(JP_DEBUG,
238     X    'JMEMHAN: 15 = more work space for rotating fields.',JPQUIET)
239C
240        IF( KFLAG.EQ.16 ) CALL INTLOG(JP_DEBUG,
241     X    'JMEMHAN: 16 = more work space for intfbu.F.',JPQUIET)
242C
243        IF( KFLAG.EQ.17 ) CALL INTLOG(JP_DEBUG,
244     X    'JMEMHAN: 17 = more work space for ??.',JPQUIET)
245C
246        IF( KFLAG.EQ.18 ) CALL INTLOG(JP_DEBUG,
247     X    'JMEMHAN: 18 = space for rotating gaussian fields.',JPQUIET)
248C
249        IF( KFLAG.EQ.19 ) CALL INTLOG(JP_DEBUG,
250     X    'JMEMHAN: 19 = for dynamic allocation of znfeldi.',JPQUIET)
251C
252        IF( KFLAG.EQ.20 ) CALL INTLOG(JP_DEBUG,
253     X    'JMEMHAN: 20 = coefficients for rotating SH fields',JPQUIET)
254C
255        IF( KFLAG.EQ.21 ) CALL INTLOG(JP_DEBUG,
256     X    'JMEMHAN: 21 = coefficients for rotating SH fields',JPQUIET)
257C
258        IF( KFLAG.EQ.22 ) CALL INTLOG(JP_DEBUG,
259     X    'JMEMHAN: 22 = coefficients for rotating SH fields',JPQUIET)
260C
261        CALL INTLOG(JP_DEBUG,'JMEMHAN: Memory reqd in words = ', KSIZE)
262        CALL INTLOG(JP_DEBUG,'JMEMHAN: Option (1 = allocate) = ', KOPT)
263      ENDIF
264C
265C     -------------------------------------------------------
266C*    Section 2.    Allocate memory
267C     -------------------------------------------------------
268C
269  200 CONTINUE
270C
271      IF( KOPT.EQ.1 ) THEN
272C
273        IF( LDEBUG ) THEN
274          CALL INTLOG(JP_DEBUG,
275     X      'JMEMHAN: Requested allocation = ', KSIZE)
276          CALL INTLOG(JP_DEBUG,
277     X      'JMEMHAN: Previous allocation  = ', IEXIST(KFLAG))
278        ENDIF
279C
280C       See if more memory required than already allocated
281C
282        IF( KSIZE.GT.IEXIST(KFLAG) ) THEN
283C
284C         Special cases (sigh)
285C
286C         If allocating memory for spectral to lat/long or gaussian
287C         interpolation, first deallocate heap space used by grid-pt
288C         to grid-pt interpolation.
289C
290          IF( ( KFLAG.EQ.1 ).OR.( KFLAG.EQ.2 ) ) THEN
291            IF( LDEBUG ) THEN
292              KRET = IAFREE(1,1)
293            ELSE
294              KRET = IAFREE(0,-1)
295            ENDIF
296          ENDIF
297C
298C         If allocating memory on VPP for spectral to grid interpolation
299C         coefficients, first deallocate memory used by other type of
300C         spectral to gaussian interpolation if this option has been
301C         requested.
302C
303          IF( LFREECF ) THEN
304            IF( LDEBUG ) CALL INTLOG(JP_DEBUG,
305     X        'JMEMHAN: Free coefficients option exercised', JPQUIET)
306C
307C           Spectral -> lat/long
308C
309            IF( KFLAG.EQ.6 ) THEN
310              IF( IEXIST(7).NE.-1 ) THEN
311                IF( LDEBUG ) CALL INTLOG(JP_DEBUG,
312     X            'JMEMHAN: Free spect->gaussn coeff memory',IZOUTBF(7))
313                CALL JFREE( IZOUTBF(7) )
314                IZOUTBF(7) = 0
315                IEXIST(7) = -1
316                NISIZE7 = 0
317                YOLDGG = 'xxxxxxxxxxxxxxxxxxxx'
318              ENDIF
319            ENDIF
320C
321C           Spectral -> gaussian
322C
323            IF( KFLAG.EQ.7 ) THEN
324              IF( IEXIST(6).NE.-1 ) THEN
325                IF( LDEBUG ) CALL INTLOG(JP_DEBUG,
326     X            'JMEMHAN: Free spec->lat/lon coeff memory',IZOUTBF(6))
327                CALL JFREE( IZOUTBF(6) )
328                IZOUTBF(6) = 0
329                IEXIST(6) = -1
330                NISIZE6 = 0
331                YOLDLL = 'xxxxxxxxxxxxxxxxxxxx'
332              ENDIF
333            ENDIF
334          ENDIF
335C
336          IF( LDEBUG ) CALL INTLOG(JP_DEBUG,
337     X      'JMEMHAN: Request greater than previous allocation', KSIZE)
338C
339C         If memory already allocated, deallocate existing memory
340C
341          IF( IEXIST(KFLAG).GE.0 ) THEN
342C
343            IF( LDEBUG ) CALL INTLOG(JP_DEBUG,
344     X          'JMEMHAN: Deallocate existing memory',IEXIST(KFLAG))
345            CALL JFREE( IZOUTBF(KFLAG) )
346          ENDIF
347C
348C         Allocate heap memory
349C
350          IF( LDEBUG ) CALL INTLOG(JP_DEBUG,
351     X      'JMEMHAN: Allocate new memory ',KSIZE)
352C
353          IEXIST(KFLAG) = KSIZE
354#if (defined REAL_8)
355          IZOUTBF(KFLAG) = JMALLOC( IEXIST(KFLAG) * 8 )
356#else
357          IZOUTBF(KFLAG) = JMALLOC( IEXIST(KFLAG) * 4 )
358#endif
359#ifdef hpR64
360          IZOUTBF(KFLAG) = IZOUTBF(KFLAG)/(1024*1024*1024*4)
361#endif
362          IF( IZOUTBF(KFLAG).EQ.0 ) THEN
363            CALL INTLOG(JP_ERROR,
364     X        'JMEMHAN: Memory allocation failed',IZOUTBF(KFLAG))
365            IEXIST(KFLAG) = -1
366            KRET = JPROUTINE + 5
367            GOTO 900
368          ENDIF
369        ENDIF
370C
371        IF( LFREECF ) THEN
372C
373C         Spectral -> lat/long
374C
375          IF( KFLAG.EQ.6 ) NISIZE6 = IEXIST(6)
376C
377C         Spectral -> gaussian
378C
379          IF( KFLAG.EQ.7 ) NISIZE7 = IEXIST(7)
380C
381        ENDIF
382C
383C     -------------------------------------------------------
384C*    Section 3.    Deallocate memory
385C     -------------------------------------------------------
386C
387  300 CONTINUE
388C
389      ELSE
390C
391        IF( LDEBUG ) CALL INTLOG(JP_DEBUG,
392     X    'JMEMHAN: Deallocate memory address = ',IZOUTBF(KFLAG))
393C
394        IF( IZOUTBF(KFLAG).GT.0 ) THEN
395C
396          CALL JFREE( IZOUTBF(KFLAG) )
397          IZOUTBF(KFLAG) = 0
398          IEXIST(KFLAG) = -1
399C
400        ELSE
401          CALL INTLOG(JP_DEBUG,'JMEMHAN: Deallocation ignored',JPQUIET)
402        ENDIF
403      ENDIF
404C
405C     _______________________________________________________
406C
407C*    Section 9. Return to calling routine.
408C     _______________________________________________________
409C
410 900  CONTINUE
411      IF( KRET.EQ.0 ) KZOUTBF = IZOUTBF(KFLAG)
412C
413      IF( LDEBUG.AND.(.NOT.LDEBUG1) ) THEN
414        ITOTAL = 0
415        DO LOOP = 1, JPOPTMX
416          IF( IEXIST(LOOP).GT.0 ) THEN
417            CALL INTLOG(JP_DEBUG, 'JMEMHAN: For type ', LOOP)
418#if (defined REAL_8)
419            CALL INTLOG(JP_DEBUG,
420     X        'JMEMHAN: bytes allocated = ', IEXIST(LOOP)*8 )
421            ITOTAL = ITOTAL + (IEXIST(LOOP) * 8)
422#else
423            CALL INTLOG(JP_DEBUG,
424     X        'JMEMHAN: bytes allocated = ', IEXIST(LOOP)*4 )
425            ITOTAL = ITOTAL + (IEXIST(LOOP) * 4)
426#endif
427          ENDIF
428        ENDDO
429        CALL INTLOG(JP_DEBUG,'JMEMHAN: Total bytes allocated=', ITOTAL)
430        CALL INTLOG(JP_DEBUG,'JMEMHAN: Return status code = ', KRET)
431      ENDIF
432C
433      RETURN
434      END
435