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