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