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 INTEGER FUNCTION PDDEFS() 12C 13C----> 14C** PDDEFS 15C 16C Purpose 17C ------- 18C 19C Adjust the interpolation parameters according to parameter 20C dependent requirements. 21C 22C Interface 23C --------- 24C 25C IRET = PDDEFS() 26C 27C Input 28C ----- 29C 30C Input file format: 31C 32C Param lsm wind prec lsm interp ) First 2 lines 33C ----- --- ---- ---- ---------- ) are ignored 34C 131 n y n n ) 35C 132 n y n n ) 36C 140 y n n n ) 37C 141 y n n n ) I3,4(5X,A1) 38C 142 n n y n ) 39C 143 n n y n ) 40C 144 n n y n ) 41C 165 n y n n ) 42C : 43C : 44C 45C Output 46C ------ 47C 48C IRET = 0 if OK. 49C 50C 51C Method 52C ------ 53C 54C Values are taken from a (text) file in a directory defined 55C by the environment variable: 56C 57C "PARAMETER_PROCESSING_DEFAULTS" (if defined), 58C 59C or from the directory: 60C 61C /owrk/marsint/new (CRAY) 62C /mrfs/postproc (Fujitsu) 63C /usr/local/lib/metaps/tables/interpol 64C /usr/local/apps/libemos/tables/ (since version 000394) 65C 66C or from an internal default array. 67C 68C The file used has name defaults_for_table_nnn, where 69C nnn is the 3-digit local code table number (eg 128 for 70C ECMWF, 001 for WMO, etc ). 71C 72C 73C Externals 74C --------- 75C 76C INTLOG - Logs messages. 77C GETENV - Gets environment variable information. 78C INDEX - Locates a character in a character variable. 79C PRECIP - Says if field is to have 'precipitation' treatment 80C 81C 82C Author 83C ------ 84C 85C J.D.Chambers ECMWF August 1994. 86C 87C----< 88C 89 IMPLICIT NONE 90C 91C Parameters 92C 93 INTEGER JPROUTINE, JPNUMDF, JPND001, JPND128, JPND129 94 PARAMETER (JPROUTINE = 28000) 95 PARAMETER (JPNUMDF = 100) 96 PARAMETER (JPND001 = 9) 97 PARAMETER (JPND128 = 13) 98 PARAMETER (JPND129 = 12) 99C 100#include "parim.h" 101#include "nifld.common" 102C 103C Local variables 104C 105 CHARACTER*256 FILENAME 106 CHARACTER*256 HLINE 107 INTEGER IPARAM, INEXT, NUMDFS, LOOP, INDX, IOTABLE 108 CHARACTER*1 HLSM, HWIND, HPREC, HLSMI 109 LOGICAL LNLSM, LNWIND, LNPREC, LNSMPAR 110 DATA IOTABLE/0/ 111C 112C Default array 113C 114 CHARACTER*27 HDEFS(JPNUMDF) 115C 116C External functions 117C 118 INTEGER DPATH_TABLES_INTERPOL 119 EXTERNAL DPATH_TABLES_INTERPOL 120C 121C Specified defaults 122C 123C WMO table 1 124C 125 CHARACTER*27 TAB001(JPND001) 126 DATA TAB001/ 127 X '002 n n n n', 128 X '033 y y n n', 129 X '034 y y n n', 130 X '061 y n y n', 131 X '062 y n y n', 132 X '063 y n y n', 133 X '064 y n y n', 134 X '065 y n y n', 135 X '081 n n n y' 136 X / 137C 138C ECMWF table 128 139C 140 CHARACTER*27 TAB128(JPND128) 141 DATA TAB128/ 142 X '131 y y n n', 143 X '132 y y n n', 144 X '142 y n y n', 145 X '143 y n y n', 146 X '144 y n y n', 147 X '151 n n n n', 148 X '165 y y n n', 149 X '166 y y n n', 150 X '169 y n n n', 151 X '172 n n n y', 152 X '228 y n y n', 153 X '239 y n y n', 154 X '240 y n y n' 155 X / 156C 157C ECMWF table 129 158C 159 CHARACTER*27 TAB129(JPND129) 160 DATA TAB129/ 161 X '131 y y n n', 162 X '132 y y n n', 163 X '142 y n y n', 164 X '143 y n y n', 165 X '144 y n y n', 166 X '151 n n n n', 167 X '165 y y n n', 168 X '166 y y n n', 169 X '172 n n n y', 170 X '228 y n y n', 171 X '239 y n y n', 172 X '240 y n y n' 173 X / 174C 175 SAVE HDEFS, NUMDFS, IOTABLE, FILENAME 176C 177C External functions 178C 179 LOGICAL PRECIP 180 EXTERNAL PRECIP 181C 182C Statement function 183C 184 LOGICAL NOTSAME, A, B 185C 186C XOR or NE for logicals 187C 188 NOTSAME(A,B) = ((A).AND.(.NOT.(B))).OR.((B).AND.(.NOT.(A))) 189C 190C ------------------------------------------------------------------ 191C* Section 1. Initialise 192C ------------------------------------------------------------------ 193C 194 100 CONTINUE 195C 196 PDDEFS = 0 197C 198C Start with the generic settings. 199C 200 LNLSM = .TRUE. 201 LNWIND = .FALSE. 202 LNPREC = .FALSE. 203 LNSMPAR = .FALSE. 204C 205C ------------------------------------------------------------------ 206C* Section 2. If parameter table has changed, treat as first time 207C through: open and read the file of default values. 208C ------------------------------------------------------------------ 209C 210 200 CONTINUE 211C 212 IF( IOTABLE.NE.NITABLE ) THEN 213C 214 FILENAME(:) = ' ' 215C 216 CALL INTLOG(JP_DEBUG, 217 X 'PDDEFS: Try to get processing defaults file.',JPQUIET) 218C 219C Get the directory name 220C 221 CALL GETENV( 'PARAMETER_PROCESSING_DEFAULTS', FILENAME) 222 IF( FILENAME(1:1).EQ.' ' ) THEN 223 INDX = DPATH_TABLES_INTERPOL(FILENAME) 224 IF( INDX.EQ.0 ) THEN 225 CALL INTLOG(JP_ERROR, 226 X 'PDDEFS: unable to build LSM directory path.',JPQUIET) 227 PDDEFS = JPROUTINE + 2 228 GOTO 900 229 ENDIF 230 ENDIF 231C 232C Build the complete file pathname 233C 234 INDX = INDEX(FILENAME, ' ') 235 FILENAME(INDX:) = 'defaults_for_table_' 236 INDX = INDEX(FILENAME, ' ') 237 WRITE(FILENAME(INDX:),'(I3.3)') NITABLE 238 INDX = INDX + 2 239 CALL INTLOG(JP_DEBUG, FILENAME(1:INDX), JPQUIET) 240 IOTABLE = NITABLE 241C 242 OPEN( UNIT = 1, 243 X FILE = FILENAME(1:INDX), 244 X STATUS = 'OLD', 245 X FORM = 'FORMATTED', 246 X ERR = 300) 247C 248C Skip first 2 lines in the file 249C 250 READ(1,'(A)', END = 900) HLINE 251 READ(1,'(A)', END = 900) HLINE 252C 253C Read the file into the defaults array 254C 255 NUMDFS = 1 256 DO LOOP = 1, JPNUMDF 257 READ(1,'(A)', END = 220) HDEFS(NUMDFS) 258 NUMDFS = NUMDFS + 1 259 ENDDO 260C 261 220 CONTINUE 262C 263C Close the file. 264C 265 NUMDFS = NUMDFS - 1 266 CLOSE(1, ERR = 920) 267C 268 GOTO 400 269C 270C ------------------------------------------------------------------ 271C* Section 3. If file problem, use default arrays. 272C ------------------------------------------------------------------ 273C 274 300 CONTINUE 275C 276 CALL INTLOG(JP_DEBUG, 277 X 'PDDEFS: No parameter processing defaults file found.',JPQUIET) 278C 279C Use appropriate table 280C 1 = WMO table 1 281C 128 = ECMWF local code table 128 282C 129 = ECMWF local code table 129 283C 284 IF( NITABLE.EQ.1 ) THEN 285C 286 DO LOOP = 1, JPND001 287 HDEFS(LOOP) = TAB001(LOOP) 288 ENDDO 289 NUMDFS = JPND001 290C 291 ELSE IF( NITABLE.EQ.128 ) THEN 292C 293 DO LOOP = 1, JPND128 294 HDEFS(LOOP) = TAB128(LOOP) 295 ENDDO 296 NUMDFS = JPND128 297C 298C 299 ELSE IF( NITABLE.EQ.129 ) THEN 300C 301 DO LOOP = 1, JPND129 302 HDEFS(LOOP) = TAB129(LOOP) 303 ENDDO 304 NUMDFS = JPND129 305C 306 ELSE 307C 308C .. other (unspecified) 309C 310 NUMDFS = 0 311C 312 ENDIF 313C 314 ENDIF 315C 316C ------------------------------------------------------------------ 317C* Section 4. Read lines in file to see if current parameter 318C is mentioned. 319C ------------------------------------------------------------------ 320C 321 400 CONTINUE 322C 323 CALL INTLOG(JP_DEBUG,'PDDEFS: Table number = ', NITABLE) 324 CALL INTLOG(JP_DEBUG,'PDDEFS: Number of definitions = ', NUMDFS) 325 CALL INTLOG(JP_DEBUG,'PDDEFS: Parameter number = ', NIPARAM) 326 INEXT = 0 327C 328 410 CONTINUE 329C 330 INEXT = INEXT + 1 331 IF( INEXT.GT.NUMDFS ) GOTO 900 332 READ(HDEFS(INEXT), 9000) IPARAM, HLSM, HWIND, HPREC, HLSMI 333C 334C If the current parameter, use the values defined in the table. 335C 336 IF( IPARAM.EQ.NIPARAM ) THEN 337C 338 IF( HLSM .EQ.'n' ) LNLSM = .FALSE. 339 IF( HWIND.EQ.'y' ) LNWIND = .TRUE. 340 IF( HPREC.EQ.'y' ) LNPREC = .TRUE. 341 IF( HLSMI.EQ.'y' ) LNSMPAR = .TRUE. 342 GOTO 900 343C 344 ENDIF 345C 346C Go back for next line in the array 347C 348 GOTO 410 349C 350C ------------------------------------------------------------------ 351C* Section 9. Closedown. 352C ------------------------------------------------------------------ 353C 354 900 CONTINUE 355C 356C Only change the value if the user has not already set it. 357C 358 IF( .NOT. LSMSET ) THEN 359 IF( NOTSAME(LNLSM,LSM) ) THEN 360 LCHANGE = .TRUE. 361 LSMCHNG = .TRUE. 362 LSM = LNLSM 363 ENDIF 364 ENDIF 365C 366 IF( .NOT. LWINDSET ) THEN 367 IF( NOTSAME(LNWIND,LWIND) ) LCHANGE = .TRUE. 368 LWIND = LNWIND 369 ENDIF 370C 371 IF( .NOT. LPRECSET ) THEN 372 IF( NOTSAME(LNPREC,LPREC) ) LCHANGE = .TRUE. 373 LPREC = LNPREC 374 ENDIF 375C 376 IF( .NOT. LSMPARSET ) THEN 377 IF( NOTSAME(LNSMPAR,LSMPAR) ) LCHANGE = .TRUE. 378 LSMPAR = LNSMPAR 379 ENDIF 380C 381 LPREC = PRECIP() 382C 383 RETURN 384C 385 920 CONTINUE 386C 387 PDDEFS = JPROUTINE + 1 388 CALL INTLOG(JP_ERROR,'PDDEFS: Error closing file:',JPQUIET) 389 CALL INTLOG(JP_ERROR,FILENAME,JPQUIET) 390 RETURN 391C 3929000 FORMAT( I3,4(5X,A1)) 3939001 FORMAT( 1X,I3,4(5X,A1)) 394C 395 END 396