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