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 JOPNLL( PLEG, PINTVL, KTRUNC, KUNIT, PBUILD, KRET) 12C 13C----> 14C**** JOPNLL 15C 16C Purpose 17C _______ 18C 19C This routine finds a file of legendre polynomials corresponding 20C to a given grid interval and truncation and returns a unit number. 21C 22C Interface 23C _________ 24C 25C CALL JOPNLL( PLEG, PINTVL, KTRUNC, KUNIT, PBUILD, KRET) 26C 27C Input parameters 28C ________________ 29C 30C PLEG - Array for legendre function 31C PINTVL - Grid interval in degrees 32C KTRUNC - Spherical truncation 33C 34C Output parameters 35C _________________ 36C 37C KUNIT - Unit number from PBOPEN 38C 0 , open failed 39C PBUILD - Grid interval used to build the legendre 40C coefficients file (degrees) 41C KRET - Return status code 42C 0 = OK 43C 44C Common block usage 45C __________________ 46C 47C None 48C 49C Method 50C ______ 51C 52C Builds a file name from the truncation and grid interval and 53C tries to open a file of that name. 54C 55C If the file is already open (from a previous call), the 56C previous unit number is returned. 57C If a different file is already open (from a previous call), the 58C existing file is closed first. 59C 60C If no file can be located, a file is created. 61C 62C Externals 63C _________ 64C 65C PBOPEN - Open binary file and return unit number 66C PBCLOSE - Close binary file 67C JFINDIR - Find the file of legendre coefficients 68C JMAKLL - Makes a file of legendre coefficients 69C INTLOG - Output log message 70C JCHMOD - Change file permissions 71C RENAME - Rename file 72C 73C Reference 74C _________ 75C 76C NONE 77C 78C Comments 79C ________ 80C 81C The Legendre polynomials for the transforms may be held in 82C a ready-made file whose name is held in an environment variable: 83C cf_txxxx_raabbbbb Txxx aa.bbbbb degrees 84C For example, 85C cf_t0213_r0050000 T213 0.5 degrees 86C cf_t0106_r0250000 T106 2.5 degrees 87C 88C On the C90, the file of polynomials may be cached in /owrk/marsint 89C 90C Otherwise the file is located in (or will be created in) the first 91C directory given by one of the following (in the order listed, if 92C they exist): 93C environment variable PPDIR 94C or 95C the current working directory. 96C 97C Author 98C ______ 99C 100C J.D.Chambers *ECMWF* Nov 1993 101C 102C Modifications 103C _____________ 104C 105C J.D.Chambers *ECMWF* Mar 1996 106C Standardise the search order for the environment variables. 107C 108C----< 109C _______________________________________________________ 110C 111 IMPLICIT NONE 112C 113#include "parim.h" 114C 115C Parameters 116C 117 INTEGER JPROUTINE 118 PARAMETER( JPROUTINE = 30900 ) 119C 120C Subroutine arguments 121C 122 REAL PLEG, PINTVL, PBUILD 123 DIMENSION PLEG(*) 124 INTEGER KTRUNC, KUNIT, KRET 125C 126C Local variables 127C 128 INTEGER IRET, IOFFSET 129 LOGICAL LFOUND 130 CHARACTER*256 DIRNAME 131 CHARACTER*256 FILENAME, FILEDUM 132 CHARACTER*512 FULLPATH 133 CHARACTER*20 YPFN 134 CHARACTER*20 YOLD 135#ifdef REAL_8 136 DATA YPFN/'CF_Txxxx_Raabbbbb'/ 137#else 138 DATA YPFN/'cf_txxxx_raabbbbb'/ 139#endif 140 DATA YOLD/'xxxxxxxxxxxxxxxxxxxx'/ 141 INTEGER NUNIT 142 DATA NUNIT/0/ 143C 144 SAVE NUNIT, YOLD 145C 146C Externals 147C 148 LOGICAL JFINDIR 149 LOGICAL JFINDFN 150 INTEGER JCHMOD, RENAME 151C 152C _______________________________________________________ 153C 154C* Section 1. See if required file already in use. 155C _______________________________________________________ 156C 157 100 CONTINUE 158C 159C Setup the file name 160C 161 WRITE(YPFN(5:8),'(I4.4)') KTRUNC 162 WRITE(YPFN(11:17),'(I7.7)') NINT(PINTVL*JPMULT) 163 CALL INTLOG(JP_DEBUG, 164 X 'JOPNLL: Coefficients file to open is:', JPQUIET) 165 CALL INTLOG(JP_DEBUG, YPFN, JPQUIET) 166 PBUILD = PINTVL 167C 168C If file already open, return the existing unit number 169C 170 IF( YPFN.EQ.YOLD ) THEN 171 CALL INTLOG(JP_DEBUG,'JOPNLL: File already open.',JPQUIET) 172 KUNIT = NUNIT 173 GOTO 900 174 ENDIF 175C 176C Otherwise, close the existing file 177C 178 IF( NUNIT.NE.0 ) THEN 179 CALL PBCLOSE(NUNIT, IRET) 180 IF( IRET.NE.0 ) THEN 181 CALL INTLOG(JP_ERROR,'JOPNLL: PBCLOSE error',IRET) 182 KRET = JPROUTINE + 1 183 GOTO 990 184 ENDIF 185 NUNIT = 0 186 ENDIF 187C _______________________________________________________ 188C 189C* Section 2. See if the file has already been created. 190C _______________________________________________________ 191C 192 200 CONTINUE 193C 194C Set appropriate build inteval 195C 196 WRITE(YPFN(11:17),'(I7.7)') NINT(PBUILD*JPMULT) 197C 198 IOFFSET = INDEX(YPFN,' ') - 1 199 FILENAME = YPFN(1:IOFFSET) 200C 201 LFOUND = JFINDIR('PPDIR', DIRNAME) 202 IF( LFOUND ) THEN 203 LFOUND = JFINDFN(DIRNAME,FILENAME,IOFFSET,NUNIT) 204 IF( LFOUND ) GOTO 500 205 ENDIF 206C 207C Try present working directory 208C 209 IOFFSET = INDEX(YPFN, ' ') - 1 210 FILENAME = YPFN(1:IOFFSET) 211 CALL PBOPEN( NUNIT, FILENAME(1:IOFFSET), 'r', IRET) 212 IF( IRET.EQ.0 ) GOTO 500 213C _______________________________________________________ 214C 215C* Section 3. File doesn't exist, find a suitable directory for it. 216C _______________________________________________________ 217C 218 300 CONTINUE 219C 220 LFOUND = JFINDIR('PPDIR', DIRNAME) 221 IF ( LFOUND ) THEN 222 IOFFSET = INDEX(DIRNAME, ' ') - 1 223 FULLPATH = DIRNAME(1:IOFFSET) // '/' // FILENAME 224 IOFFSET = INDEX(FULLPATH, ' ') - 1 225 FILENAME(1:IOFFSET) = FULLPATH(1:IOFFSET) 226 FILEDUM(1:IOFFSET) = FILENAME(1:IOFFSET) 227#ifdef REAL_8 228 FILEDUM(IOFFSET-16:IOFFSET-15) = 'XX' 229#else 230 FILEDUM(IOFFSET-16:IOFFSET-15) = 'xx' 231#endif 232 CALL PBOPEN(NUNIT, FILEDUM(1:IOFFSET), 'w', IRET) 233 IF( IRET.EQ.0 ) GOTO 400 234 ENDIF 235C 236C Try present working directory 237C 238 IOFFSET = INDEX(YPFN,' ') - 1 239 FILENAME = YPFN(1:IOFFSET) 240 FILEDUM(1:IOFFSET) = FILENAME(1:IOFFSET) 241#ifdef REAL_8 242 FILEDUM(IOFFSET-16:IOFFSET-15) = 'XX' 243#else 244 FILEDUM(IOFFSET-16:IOFFSET-15) = 'xx' 245#endif 246 CALL PBOPEN(NUNIT, FILEDUM(1:IOFFSET), 'w', IRET) 247 IF( IRET.NE.0 ) THEN 248 CALL INTLOG(JP_FATAL,'JOPNLL: PBOPEN error.',IRET) 249 KRET = JPROUTINE + 2 250 GOTO 990 251 ENDIF 252C _______________________________________________________ 253C 254C* Section 4. Create the coefficients file. 255C _______________________________________________________ 256C 257 400 CONTINUE 258C 259C Let user know that a new file is being created. 260C 261 IOFFSET = INDEX(FILENAME, ' ') - 1 262 CALL INTLOG(JP_DEBUG,'JOPNLL: Creating new coefficients file:', 263 X JPQUIET) 264 CALL INTLOG(JP_DEBUG,FILENAME(1:IOFFSET), JPQUIET) 265C 266C Change access mode to 'read only' for all users. 267C 268 IRET = JCHMOD(FILEDUM(1:IOFFSET),'0444') 269 IF( IRET.NE.0 ) THEN 270 CALL INTLOG(JP_FATAL,'JOPNLL: JCHMOD error.',IRET) 271 KRET = JPROUTINE + 3 272 GOTO 990 273 ENDIF 274C 275C Make coefficients file 276C 277 CALL JMAKLL( NUNIT, KTRUNC, PBUILD, 0.0, PLEG, KRET) 278 IF( KRET.NE.0 ) GOTO 990 279C 280C Close it, rename it, re-open for reading, leave it open. 281C 282 CALL PBCLOSE(NUNIT, IRET) 283 IF( IRET.NE.0 ) THEN 284 CALL INTLOG(JP_ERROR,'JOPNLL: PBCLOSE error.',IRET) 285 KRET = JPROUTINE + 4 286 GOTO 990 287 ENDIF 288C 289 FILEDUM(IOFFSET+1:IOFFSET+1) = CHAR(0) 290 FILENAME(IOFFSET+1:IOFFSET+1) = CHAR(0) 291 IRET = RENAME(FILEDUM(1:IOFFSET),FILENAME(1:IOFFSET)) 292#ifndef hpR64 293 IF( IRET.NE.0 ) THEN 294 CALL INTLOG(JP_FATAL,'JOPNLL: RENAME of file failed',JPQUIET) 295 KRET = JPROUTINE + 5 296 GOTO 990 297 ENDIF 298#endif 299C 300 CALL PBOPEN(NUNIT, FILENAME(1:IOFFSET), 'r', IRET) 301 IF( IRET.NE.0 ) THEN 302 CALL INTLOG(JP_FATAL,'JOPNLL: PBOPEN error.',IRET) 303 KRET = JPROUTINE + 6 304 GOTO 990 305 ENDIF 306C _______________________________________________________ 307C 308C* Section 5. File now open with read access. 309C _______________________________________________________ 310C 311 500 CONTINUE 312C 313 KUNIT = NUNIT 314 YOLD = YPFN 315C 316C _______________________________________________________ 317C 318C* Section 9. Return to calling routine. Format statements 319C _______________________________________________________ 320C 321 900 CONTINUE 322C 323 KRET = 0 324C 325 990 CONTINUE 326C 327 RETURN 328 END 329