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 JOPNLLF( IALEG, PINTVL, KTRUNC, KUNIT, PBUILD, KRET) 12C 13C----> 14C**** JOPNLLF 15C 16C Purpose 17C _______ 18C 19C This routine finds a file of legendre polynomials corresponding 20C to a given grid interval and truncation, allocates memory, reads 21C the coefficients into the memory and returns a unit number. 22C 23C Interface 24C _________ 25C 26C CALL JOPNLLF( IALEG, PINTVL, KTRUNC, KUNIT, PBUILD, KRET) 27C 28C Input parameters 29C ________________ 30C 31C PINTVL - Grid interval in degrees 32C KTRUNC - Spherical truncation 33C 34C Output parameters 35C _________________ 36C 37C IALEG - Pointer for memory array for legendre coefficients 38C KUNIT - Unit number from PBOPEN 39C 0 , open failed 40C PBUILD - Grid interval used to build the legendre 41C coefficients file (degrees) 42C KRET - Return status code 43C 0 = OK 44C 45C Common block usage 46C __________________ 47C 48C Uses common JDCSPGP for size NISIZE6 49C 50C Method 51C ______ 52C 53C Builds a file name from the truncation and grid interval and 54C tries to open a file of that name. 55C 56C If the file is already open (from a previous call), the 57C previous unit number is returned. 58C If a different file is already open (from a previous call), the 59C the existing file is closed. 60C 61C If no file can be located, a file is created. Memory is dynamically 62C allocted and the coefficients are read into the memory array. 63C 64C Externals 65C _________ 66C 67C PBOPEN3 - Open binary file and return unit number 68C PBREAD3 - Read binary file 69C PBCLOSE3 - Close binary file 70C JFINDIR - Find the file of legendre coefficients 71C JMAKLL - Makes a file of legendre coefficients 72C INTLOG - Output log message 73C JCHMOD - Change file permissions 74C RENAME - Rename file 75C 76C Reference 77C _________ 78C 79C NONE 80C 81C Comments 82C ________ 83C 84C The Legendre polynomials for the transforms may be held in 85C a ready-made file whose name is held in an environment variable: 86C cf_txxxx_raabbbbb Txxxx aa.bbbbb degrees 87C For example, 88C cf_t0213_r0050000 T213 0.5 degrees 89C cf_t0106_r0250000 T106 2.5 degrees 90C 91C On the C90, the file of polynomials may be cached in /owrk/marsint 92C 93C Otherwise the file is located in (or will be created in) the first 94C directory given by one of the following (in the order listed, if 95C they exist): 96C environment variable PPDIR 97C or 98C the current working directory. 99C 100C Author 101C ______ 102C 103C J.D.Chambers *ECMWF* Jun 1996 104C 105C Modifications 106C _____________ 107C 108C J.D.Chambers ECMWF Feb 1997 109C Allow for 64-bit pointers 110C 111C----< 112C _______________________________________________________ 113C 114 IMPLICIT NONE 115C 116#include "parim.h" 117#include "jparams.h" 118#include "jparam2.h" 119C 120C Parameters 121C 122 INTEGER JPROUTINE 123 PARAMETER ( JPROUTINE = 30910 ) 124C 125C Subroutine arguments 126C 127 REAL PINTVL, PBUILD 128 INTEGER KTRUNC, KUNIT, KRET 129C 130C Local variables 131C 132 INTEGER IRET, IOFFSET, ISIZE, NPBYTES 133 INTEGER*8 IRET1, ITEMP 134 CHARACTER*12 YFLAG 135#ifdef REAL_8 136 DATA NPBYTES/8/ 137#else 138 DATA NPBYTES/4/ 139#endif 140 LOGICAL LFOUND 141 CHARACTER*256 DIRNAME 142 CHARACTER*256 FILENAME, FILEDUM 143 CHARACTER*512 FULLPATH 144 CHARACTER*20 YPFN 145#ifdef REAL_8 146 DATA YPFN/'CF_Txxxx_Raabbbbb'/ 147#else 148 DATA YPFN/'cf_txxxx_raabbbbb'/ 149#endif 150 INTEGER NUNIT 151 DATA NUNIT/0/ 152#ifndef _CRAYFTN 153#ifdef POINTER_64 154 INTEGER*8 IALEG 155#endif 156#endif 157 REAL ALEG 158 DIMENSION ALEG(1) 159 POINTER ( IALEG, ALEG ) 160C 161 SAVE NUNIT 162C 163C Externals 164C 165 LOGICAL JFINDIR 166 LOGICAL JFINDFN3 167 INTEGER JCHMOD, RENAME 168C 169C _______________________________________________________ 170C 171C* Section 1. See if required file already in use. 172C _______________________________________________________ 173C 174 100 CONTINUE 175C 176C Setup the filename: cf_txxxx_raabbbbb 177C 178 WRITE(YPFN(5:8),'(I4.4)') KTRUNC 179 WRITE(YPFN(11:17),'(I7.7)') NINT(PINTVL*JPMULT) 180 CALL INTLOG(JP_DEBUG, 181 X 'JOPNLLF: Coefficients file to open is:', JPQUIET) 182 CALL INTLOG(JP_DEBUG, YPFN, JPQUIET) 183 PBUILD = PINTVL 184C 185C If file already open, return the existing unit number 186C 187 IF( YPFN.EQ.YOLDLL ) THEN 188 CALL INTLOG(JP_DEBUG,'JOPNLLF: File already open.',JPQUIET) 189 KUNIT = NUNIT 190 GOTO 900 191 ENDIF 192C 193C Otherwise, ensure existing unit is closed 194C 195 IF( NUNIT.NE.0 ) THEN 196 CALL PBCLOSE3(NUNIT, IRET) 197 IF( IRET.NE.0 ) THEN 198 CALL INTLOG(JP_ERROR,'JOPNLLF: PBCLOSE3 error',IRET) 199 KRET = JPROUTINE + 1 200 GOTO 990 201 ENDIF 202 NUNIT = 0 203 ENDIF 204C _______________________________________________________ 205C 206C* Section 2. See if the file has already been created. 207C _______________________________________________________ 208C 209 200 CONTINUE 210C 211C Set appropriate build inteval 212C 213 WRITE(YPFN(11:17),'(I7.7)') NINT(PBUILD*JPMULT) 214C 215 IOFFSET = INDEX(YPFN,' ') - 1 216 FILENAME = YPFN(1:IOFFSET) 217C 218 LFOUND = JFINDIR('PPDIR', DIRNAME) 219 IF( LFOUND ) THEN 220 LFOUND = JFINDFN3(DIRNAME,FILENAME,IOFFSET,NUNIT) 221 IF( LFOUND ) GOTO 500 222 ENDIF 223C 224C Try present working directory 225C 226 IOFFSET = INDEX(YPFN, ' ') - 1 227 FILENAME = YPFN(1:IOFFSET) 228 CALL PBOPEN3( NUNIT, FILENAME(1:IOFFSET), 'r', IRET) 229 IF( IRET.EQ.0 ) GOTO 500 230C _______________________________________________________ 231C 232C* Section 3. File doesn't exist, find a suitable directory for it. 233C _______________________________________________________ 234C 235 300 CONTINUE 236C 237 LFOUND = JFINDIR('PPDIR', DIRNAME) 238 IF ( LFOUND ) THEN 239 IOFFSET = INDEX(DIRNAME, ' ') - 1 240 FULLPATH = DIRNAME(1:IOFFSET) // '/' // FILENAME 241 IOFFSET = INDEX(FULLPATH, ' ') - 1 242 FILENAME(1:IOFFSET) = FULLPATH(1:IOFFSET) 243 FILEDUM(1:IOFFSET) = FILENAME(1:IOFFSET) 244#ifdef REAL_8 245 FILEDUM(IOFFSET-16:IOFFSET-15) = 'XX' 246#else 247 FILEDUM(IOFFSET-16:IOFFSET-15) = 'xx' 248#endif 249 CALL PBOPEN3(NUNIT, FILEDUM(1:IOFFSET), 'w', IRET) 250 IF( IRET.EQ.0 ) GOTO 400 251 ENDIF 252C 253C Try present working directory 254C 255 IOFFSET = INDEX(YPFN,' ') - 1 256 FILENAME = YPFN(1:IOFFSET) 257 FILEDUM(1:IOFFSET) = FILENAME(1:IOFFSET) 258#ifdef REAL_8 259 FILEDUM(IOFFSET-16:IOFFSET-15) = 'XX' 260#else 261 FILEDUM(IOFFSET-16:IOFFSET-15) = 'xx' 262#endif 263 CALL PBOPEN3(NUNIT, FILEDUM(1:IOFFSET), 'w', IRET) 264 IF( IRET.NE.0 ) THEN 265 CALL INTLOG(JP_FATAL,'JOPNLLF: PBOPEN3 error.',IRET) 266 KRET = JPROUTINE + 2 267 GOTO 990 268 ENDIF 269C _______________________________________________________ 270C 271C* Section 4. Create the coefficients file. 272C _______________________________________________________ 273C 274 400 CONTINUE 275C 276C Let user know that a new file is being created. 277C 278 IOFFSET = INDEX(FILENAME, ' ') - 1 279 CALL INTLOG(JP_DEBUG,'JOPNLLF: Creating new coefficients file:', 280 X JPQUIET) 281 CALL INTLOG(JP_DEBUG,FILENAME(1:IOFFSET), JPQUIET) 282C 283C Change access mode to 'read only' for all users. 284C 285 IRET = JCHMOD(FILEDUM(1:IOFFSET),'0444') 286 IF( IRET.NE.0 ) THEN 287 CALL INTLOG(JP_FATAL,'JOPNLLF: JCHMOD error.',IRET) 288 KRET = JPROUTINE + 3 289 GOTO 990 290 ENDIF 291C 292C Allocate memory for the array used in making the file 293C 294 ISIZE = (KTRUNC+1)*(KTRUNC+4)*(NINT(90.0/PBUILD)+1)/2 295 IF( ISIZE.GT.NISIZE6 ) THEN 296 CALL JMEMHAN( 6, IALEG, ISIZE, 1, KRET) 297 IF( KRET.NE.0 ) THEN 298 CALL INTLOG(JP_FATAL,'JOPNLLF: memory allocation error',IALEG) 299 KRET = JPROUTINE + 3 300 GOTO 990 301 ENDIF 302 NISIZE6 = ISIZE 303 ENDIF 304C 305C Make coefficients file 306C 307 CALL JMAKLL3( NUNIT, KTRUNC, PBUILD, 0.0, ALEG, KRET) 308 IF ( KRET .NE. 0 ) GOTO 990 309C 310C De-allocate memory for the array used in making the file 311C 312 CALL JMEMHAN( 6, IALEG, ISIZE, 0, KRET) 313 IF( KRET.NE.0 ) THEN 314 CALL INTLOG(JP_FATAL,'JOPNLLF: memory dealloc error',IALEG) 315 KRET = JPROUTINE + 4 316 GOTO 990 317 ENDIF 318 NISIZE6 = 0 319C 320C Close rename it, re-open for reading, leave it open. 321C 322 CALL PBCLOSE3( NUNIT, IRET) 323 IF( IRET.NE.0 ) THEN 324 CALL INTLOG(JP_FATAL,'JOPNLLF: PBCLOSE3 error.',IRET) 325 KRET = JPROUTINE + 5 326 GOTO 990 327 ENDIF 328 NUNIT=0 329C 330 IRET = RENAME(FILEDUM(1:IOFFSET),FILENAME(1:IOFFSET)) 331 IF( IRET.NE.0 ) THEN 332 CALL INTLOG(JP_FATAL,'JOPNLLF: RENAME of file failed',JPQUIET) 333 KRET = JPROUTINE + 5 334 GOTO 990 335 ENDIF 336C 337 CALL PBOPEN3( NUNIT, FILENAME(1:IOFFSET), 'r', IRET) 338 IF( IRET.NE.0 ) THEN 339 CALL INTLOG(JP_FATAL,'JOPNLLF: PBOPEN3 error.',IRET) 340 KRET = JPROUTINE + 6 341 GOTO 990 342 ENDIF 343C _______________________________________________________ 344C 345C* Section 5. File now open with read access. 346C _______________________________________________________ 347C 348 500 CONTINUE 349C 350C Allocate memory for the file and read it into memory 351C 352 ISIZE = (KTRUNC+1)*(KTRUNC+4)*(NINT(90.0/PBUILD)+1)/2 353 IF( ISIZE.GT.NISIZE6 ) THEN 354 CALL JMEMHAN2( 6, IALEG, ISIZE, 1, KRET) 355cs CALL JMEMHAN( 6, IALEG, ISIZE, 1, KRET) 356 IF( KRET.NE.0 ) THEN 357 CALL INTLOG(JP_FATAL,'JOPNLLF: memory allocation error',IALEG) 358 KRET = JPROUTINE + 7 359 GOTO 990 360 ENDIF 361 NISIZE6 = ISIZE 362 ENDIF 363 ITEMP = ISIZE 364 ITEMP = ITEMP*8 365C 366 CALL GETENV('USE_PBREAD4', YFLAG) 367 IF(YFLAG(1:1).EQ.'1') THEN 368 CALL PBREAD4(NUNIT, ALEG, ITEMP, IRET1) 369 ELSE 370 print*,'PBREAD5 ',ITEMP 371 CALL PBREAD5(NUNIT, ALEG, ITEMP, IRET1) 372 ENDIF 373C 374 IF( IRET1.NE.ITEMP ) THEN 375 CALL INTLOG(JP_FATAL,'JOPNLLF: PBREAD5 error.',IRET1) 376 KRET = JPROUTINE + 8 377 GOTO 990 378 ENDIF 379cs CALL PBREAD3(NUNIT, ALEG, (ISIZE*NPBYTES), IRET) 380cs IF( IRET.NE.(ISIZE*NPBYTES) ) THEN 381cs CALL INTLOG(JP_FATAL,'JOPNLLF: PBREAD3 error.',IRET) 382cs KRET = JPROUTINE + 8 383cs GOTO 990 384cs ENDIF 385C 386C The file is no longer required 387C 388 CALL PBCLOSE3( NUNIT, IRET) 389 IF ( IRET .NE. 0 ) THEN 390 CALL INTLOG(JP_FATAL,'JOPNLLF: PBCLOSE3 error.',IRET) 391 NUNIT = 0 392 KRET = JPROUTINE + 9 393 GOTO 990 394 ENDIF 395 NUNIT=0 396C 397 KUNIT = NUNIT 398 YOLDLL = YPFN 399C 400C _______________________________________________________ 401C 402C* Section 9. Return to calling routine. Format statements 403C _______________________________________________________ 404C 405 900 CONTINUE 406C 407 KRET = 0 408C 409 990 CONTINUE 410C 411 RETURN 412 END 413