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