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