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 IRLSMB (OISTAND, HIFILE, KIREC, KIGRID, KILINE,
12     X   OOSTAND, HOFILE, KOREC, KOGRID, KOLINE, KPR, KERR)
13C
14C---->
15C**** *IRLSMB*
16C
17C     Purpose
18C     -------
19C
20C     Calculate the effects of the land-sea masks on the unnormalised
21C     interpolation weights for a quasi regular input field and a
22C     regular output field.
23C
24C
25C     Interface
26C     ---------
27C
28C     IERR = IRLSMB (OISTAND, HIFILE, KIREC, KIGRID, KILINE,
29C    X   OOSTAND, HOFILE, KOREC, KOGRID, KOLINE, KPR, KERR)
30C
31C
32C     Input parameters
33C     ----------------
34C
35C     OISTAND - Flag indicating whether the input land-sea mask
36C               is a pre-stored "standard" field.
37C
38C     HIFILE  - The filename for the input land-sea mask.
39C
40C     KIREC   - The length of one latitude record in the input file.
41C
42C     KIGRID  - An array of length 2 giving the row and column
43C               strides in a pre-stored land sea mask file for the
44C               input grid.
45C
46C     KILINE  - An array of length 2 giving the offsets of the
47C               Northern and Western starting points in a
48C               pre-stored land sea mask file for the input grid.
49C
50C     OOSTAND - Flag indicating whether the output land-sea mask
51C               is a prestored "standard" field.
52C
53C     HOFILE  - The filename for the output land-sea mask.
54C
55C     KOREC   - The length of one latitude record in the output file.
56C
57C     KOGRID  - An array of length 2 giving the row and column
58C               strides in a pre-stored land sea mask file for the
59C               output grid.
60C
61C     KOLINE  - An array of length 2 giving the offsets of the
62C               Northern and Western starting points in a
63C               pre-stored land sea mask file for the output grid.
64C
65C     KPR     - The debug print switch.
66C               0  , No debugging output.
67C               1  , Produce debugging output.
68C
69C     KERR    - The error control flag.
70C               -ve, No error message. Return error code.
71C               0  , Hard failure with error message.
72C               +ve, Print error message. Return error code.
73C
74C
75C     Output parameters
76C     -----------------
77C
78C     The common variable WFACT is modified by this routine.
79C
80C     An error indicator
81C
82C     23401 An error exit was returned from the I/O routine PBOPEN.
83C     23402 An error exit was returned from the I/O routine PBCLOSE.
84C
85C
86C     Common block usage
87C     ------------------
88C
89C     nifld.common - This file contains all the input field
90C                    definition variables.
91C
92C     NINS         - Number of grid points in NS direction for input
93C                    field (used in grspace.h).
94C     NIWE         - Number of grid points in WE direction for input
95C                    field (used in grspace.h).
96C
97C     nofld.common - This file contains all the output field
98C                    definition variables.
99C
100C     NONS         - Number of grid points in NS direction for output
101C                    field is used.
102C     NOWE         - Number of grid points in WE direction for output
103C                    field is used.
104C
105C     grspace.h    - This file contains all the work space array
106C                    definitions for grid point to grid point
107C                    interpolation.
108C
109C     MEXPAND      - Array used to expand one latitude line of the
110C                    10 minute land sea mask file to have one word
111C                    per bit for improved efficiency.
112C     MILLEN       - Array containing a quasi regular line length
113C                    definition.
114C     MWORK        - Array used to read one latitude line of a
115C                    standard land sea mask file.
116C
117C     MILATG       - The input field latitudes.
118C     MILONG       - The input field longitudes.
119C     MILSM        - Work array used in calculating the effects of
120C                    the land sea mask on interpolation.
121C     MISTRT       - The array offsets of the start of each latitude
122C                    line for a quasi regular Gaussian input field.
123C     MNSIND       - The latitude line numbers (array offset) of the
124C                    input field associated with each line of
125C                    latitude in the output field.
126C     MOLATG       - The output field latitudes.
127C     MOLONG       - The output field longitudes.
128C     MOLSM        - Work array used in calculating the effects of
129C                    the land sea mask on interpolation.
130C     MWEIND       - This array holds the longitude points (array
131C                    offset) from the input field associated with
132C                    each longitude point in the output field.
133C     WFACT        - The interpolation weights for each point in the
134C                    output field.
135C
136C
137C     Externals
138C     ---------
139C
140C     IGLSM01   - Read and process one latitude row from the 10
141C                 minute land sea mask.
142C     IGLSMR    - Calculate the effects of the land-sea masks for
143C                 one line of latitude on the unnormalised
144C                 interpolation weights.
145C     IGLSMST   - Read and process one line of latitude from a
146C                 standard land sea mask file.
147C     PBCLOSE   - Close a land sea mask file after processing.
148C     PBOPEN    - Open a land sea mask file for processing.
149C     INTLOG(R) - Log messages.
150C     JINDEX    - Returns length of character string
151C
152C
153C     Method
154C     ------
155C
156C     All the land sea mask data is in (0-1) form. If a point in the
157C     input field has a different land sea mask value from the
158C     corresponding point in the output field then its interpolating
159C     weight is multiplied by a scaling factor. This scaling factor
160C     is currently 0.2 so that the effect of such points in the final
161C     interpolation is reduced.
162C
163C     The land-sea mask files are kept open between calls to this
164C     routine.
165C
166C
167C     Reference
168C     ---------
169C
170C     None
171C
172C
173C     Comments
174C     --------
175C
176C     None
177C
178C
179C     Author
180C     ------
181C     K. Fielding      *ECMWF*      Nov 1993
182C
183C     Modifications
184C     -------------
185C
186C     J.D.Chambers      ECMWF       Oct 1996
187C     Reduced number of parameters in call to IGLSMST and IGLSM01
188C
189C----<
190C     -----------------------------------------------------------------|
191C*    Section 0. Definition of variables.
192C     -----------------------------------------------------------------|
193C
194      IMPLICIT NONE
195C
196#include "parim.h"
197#include "nifld.common"
198#include "nofld.common"
199#include "grspace.h"
200C
201C     Function arguments
202C
203      LOGICAL OISTAND, OOSTAND
204      CHARACTER *(*) HIFILE, HOFILE
205      INTEGER KIREC, KOREC, KPR, KERR
206      INTEGER KIGRID (2), KILINE (2), KOGRID (2), KOLINE (2)
207C
208C     Local variables
209C
210      INTEGER IIUNIT, IOUNIT, IIFILE, IOFILE
211      INTEGER ILATN, ILATS, ILINEN, ILINES, ISTRIDEN, ISTRIDES
212      INTEGER IOSTRIDE, INDEXN, INDEXS, IZERO, IOFF, IPR, IERR
213      INTEGER JLON, JOLAT
214      CHARACTER*256 XHIFILE, XHOFILE
215      CHARACTER*2 NEWFILE, MSKFILE
216      INTEGER XIIUNIT, XIOUNIT, II
217      DATA XIIUNIT/0/
218      DATA XIOUNIT/0/
219      SAVE  XHIFILE, XHOFILE, XIIUNIT, XIOUNIT
220C
221      INTEGER JPROUTINE
222      PARAMETER (JPROUTINE = 23400)
223C
224C     External functions
225C
226      INTEGER IGLSMR, IGLSMST, IGLSM01, JINDEX
227C
228C     -----------------------------------------------------------------|
229C*    Section 1. Initialisation
230C     -----------------------------------------------------------------|
231C
232  100 CONTINUE
233C
234      IF( KPR.GE.1 ) CALL INTLOG(JP_DEBUG,'IRLSMB: Section 1.',JPQUIET)
235C
236      IRLSMB = 0
237C
238      IIFILE = JINDEX(HIFILE)
239      IOFILE = JINDEX(HOFILE)
240C
241      IF( KPR.GE.1 ) THEN
242        CALL INTLOG(JP_DEBUG,'IRLSMB: Input field parameters.',JPQUIET)
243        CALL INTLOG(JP_DEBUG,'IRLSMB: LSM filename is.',JPQUIET)
244        CALL INTLOG(JP_DEBUG, HIFILE(1:IIFILE), JPQUIET)
245        IF( OISTAND ) THEN
246            CALL INTLOG(JP_DEBUG,'IRLSMB: Standard fld: TRUE',JPQUIET)
247        ELSE
248            CALL INTLOG(JP_DEBUG,'IRLSMB: Standard fld: FALSE',JPQUIET)
249        ENDIF
250        CALL INTLOG(JP_DEBUG,'IRLSMB: LSM file rec len = ',KIREC)
251        CALL INTLOG(JP_DEBUG,'IRLSMB: Grid stride WE = ',KIGRID(1))
252        CALL INTLOG(JP_DEBUG,'IRLSMB: Grid stride NS = ',KIGRID(2))
253        CALL INTLOG(JP_DEBUG,'IRLSMB: Grid start N = ',KILINE(1))
254        CALL INTLOG(JP_DEBUG,'IRLSMB: Grid start W = ',KILINE(2))
255C
256        CALL INTLOG(JP_DEBUG,'IRLSMB: Output field parameters.',JPQUIET)
257        CALL INTLOG(JP_DEBUG, HOFILE(1:IOFILE),JPQUIET)
258        IF( OOSTAND ) THEN
259            CALL INTLOG(JP_DEBUG,'IRLSMB: Standard fld: TRUE',JPQUIET)
260        ELSE
261            CALL INTLOG(JP_DEBUG,'IRLSMB: Standard fld: FALSE',JPQUIET)
262        ENDIF
263        CALL INTLOG(JP_DEBUG,'IRLSMB: LSM file rec len = ',KOREC)
264        CALL INTLOG(JP_DEBUG,'IRLSMB: Grid stride WE = ',KOGRID(1))
265        CALL INTLOG(JP_DEBUG,'IRLSMB: Grid stride NS = ',KOGRID(2))
266        CALL INTLOG(JP_DEBUG,'IRLSMB: Grid start N = ',KOLINE(1))
267        CALL INTLOG(JP_DEBUG,'IRLSMB: Grid start W = ',KOLINE(2))
268      ENDIF
269C
270      IF( MOLONG(2).GE.MOLONG(1) ) THEN
271         IOSTRIDE = MOLONG(2) - MOLONG(1)
272      ELSE
273         IOSTRIDE = MOLONG(2) + JP360 - MOLONG(1)
274      ENDIF
275C
276C     -----------------------------------------------------------------|
277C*    Section 2. Open files for input and output land sea masks
278C     -----------------------------------------------------------------|
279C
280  200 CONTINUE
281C
282      IF( KPR.GE.1 ) CALL INTLOG(JP_DEBUG,'IRLSMB: Section 2.',JPQUIET)
283C
284C     See if first time through or input land sea mask filename has
285C     changed since last access
286C
287      II = JINDEX(HIFILE)
288      IF( XHIFILE(1:II).NE.HIFILE(1:II) ) THEN
289C
290C       Open input land sea mask file
291C
292        IF(XIIUNIT.NE.0) CALL PBCLOSE(XIIUNIT,IERR)
293        CALL PBOPEN(IIUNIT, HIFILE, 'r', IERR)
294        IF( IERR.NE.0 ) THEN
295          IRLSMB = JPROUTINE + 1
296C
297          IF( KERR.GE.0 ) THEN
298            CALL INTLOG(JP_ERROR,'IRLSMB: PBOPEN return code = ',IERR)
299            CALL INTLOG(JP_ERROR,'IRLSMB: trying to open file',JPQUIET)
300            CALL INTLOG(JP_ERROR, HIFILE(1:IIFILE),JPQUIET)
301          ENDIF
302C
303          IF( KERR.EQ.0 ) CALL INTLOG(JP_FATAL,
304     X      'IRLSMB: Interpolation failed.',JPQUIET)
305          GOTO 900
306        ENDIF
307        XIIUNIT = IIUNIT
308        XHIFILE(1:II) = HIFILE(1:II)
309        NEWFILE(1:1) = 'Y'
310C
311C     Just rewind if same file still in use
312C
313      ELSE
314        IIUNIT = XIIUNIT
315        NEWFILE(1:1) = 'N'
316      ENDIF
317C
318C     See if first time through or output land sea mask filename has
319C     changed since last access
320C
321      II = JINDEX(HOFILE)
322      IF( XHOFILE(1:II).NE.HOFILE(1:II) ) THEN
323C
324C       Open output land sea mask file
325C
326        IF(XIOUNIT.NE.0) CALL PBCLOSE(XIOUNIT,IERR)
327        CALL PBOPEN(IOUNIT, HOFILE, 'r', IERR)
328        IF( IERR.NE.0 ) THEN
329          IRLSMB = JPROUTINE + 1
330C
331          IF( KERR.GE.0 ) THEN
332            CALL INTLOG(JP_ERROR,'IRLSMB: PBOPEN return code = ',IERR)
333            CALL INTLOG(JP_ERROR,'IRLSMB: trying to open file',JPQUIET)
334            CALL INTLOG(JP_ERROR, HOFILE(1:IOFILE),JPQUIET)
335          ENDIF
336C
337          IF( KERR.EQ.0 ) CALL INTLOG(JP_FATAL,
338     X      'IRLSMB: Interpolation failed.',JPQUIET)
339          GOTO 900
340        ENDIF
341        XIOUNIT = IOUNIT
342        XHOFILE(1:II) = HOFILE(1:II)
343        NEWFILE(2:2) = 'Y'
344C
345C     Just rewind if same file still in use
346C
347      ELSE
348        IOUNIT = XIOUNIT
349        NEWFILE(2:2) = 'N'
350      ENDIF
351C
352C     -----------------------------------------------------------------|
353C*    Section 3. Calculate arrays of weights
354C     -----------------------------------------------------------------|
355C
356  300 CONTINUE
357C
358      IF( KPR.GE.1 ) CALL INTLOG(JP_DEBUG,'IRLSMB: Section 3.',JPQUIET)
359C
360      IPR = KPR
361C
362      DO JOLAT = 1, NONS
363C
364        INDEXN = ( (JOLAT - 1) * 2 + JP_I_N - 1) * NOWE + 1
365        INDEXS = ( (JOLAT - 1) * 2 + JP_I_S - 1) * NOWE + 1
366C
367C       Get line for output array
368C
369        IF( OOSTAND ) THEN
370C
371          IOFF = (KOLINE(JPNORTH) + (JOLAT - 1) * KOGRID(JPNSSTEP)
372     X         - 1) * KOREC
373C
374          MSKFILE(2:2) = 'O'
375          MSKFILE(1:1) = NEWFILE(2:2)
376          IERR = IGLSMST(IOUNIT, IOFF, NOWE, KOLINE(JPWEST),
377     X         KOGRID(JPWESTEP), KOREC, MOLSM, MSKFILE)
378          NEWFILE(2:2) = 'N'
379C
380        ELSE
381          IERR = IGLSM01(IOUNIT, NOWE, MOLONG, MOLATG(JOLAT),
382     X         MEXPAND, KOREC, MOLSM)
383        ENDIF
384C
385        IF( IERR.GT.0 ) THEN
386          IRLSMB = IERR
387          GOTO 900
388        ENDIF
389C
390        ILATN = MNSIND(JP_I_N, JOLAT)
391        ILATS = MNSIND(JP_I_S, JOLAT)
392C
393        ILINEN = MILLEN(ILATN)
394        ISTRIDEN = JP360 / ILINEN
395C
396        ILINES = MILLEN(ILATS)
397        ISTRIDES = JP360 / ILINES
398C
399        IZERO = 0
400C
401C       Get lines for input array
402C
403        IF( OISTAND ) THEN
404C
405          MSKFILE(2:2) = 'I'
406          MSKFILE(1:1) = NEWFILE(1:1)
407          IERR = IGLSMST(IIUNIT, MISTRT(ILATN) - 1, ILINEN,
408     X         KILINE(JPWEST), KIGRID(JPWESTEP), ILINEN,
409     X         MILSM(1, JP_I_N), MSKFILE)
410          NEWFILE(1:1) = 'N'
411C
412          IF( IERR.GT.0 ) THEN
413            IRLSMB = IERR
414            GOTO 900
415          ENDIF
416C
417          MSKFILE(2:2) = 'I'
418          MSKFILE(1:1) = NEWFILE(1:1)
419          IERR = IGLSMST(IIUNIT, MISTRT(ILATS) - 1, ILINES,
420     X         KILINE(JPWEST), KIGRID(JPWESTEP), ILINES,
421     X         MILSM(1, JP_I_S), MSKFILE)
422          NEWFILE(1:1) = 'N'
423C
424        ELSE
425C
426          DO JLON = 0, ILINEN - 1
427            MILONG(JLON + 1) = ISTRIDEN * JLON
428          ENDDO
429C
430          IERR = IGLSM01(IIUNIT, ILINEN, MILONG, MILATG(ILATN),
431     X         MEXPAND, KIREC, MILSM(1, JP_I_N))
432C
433          IF( IERR.GT.0 ) THEN
434            IRLSMB = IERR
435            GOTO 900
436          ENDIF
437C
438          DO JLON = 0, ILINES - 1
439            MILONG(JLON + 1) = ISTRIDES * JLON
440          ENDDO
441C
442          IERR = IGLSM01(IIUNIT, ILINES, MILONG, MILATG(ILATS),
443     X         MEXPAND, KIREC, MILSM(1, JP_I_S))
444C
445        ENDIF
446C
447        IF( IERR.GT.0 ) THEN
448          IRLSMB = IERR
449          GOTO 900
450        ENDIF
451C
452C       Now modify the unormalised weight for land-sea mask
453C
454        IERR = IGLSMR(MILSM(1, JP_I_N), MILSM(1, JP_I_S),
455     X      MOLSM, MWEIND(1, INDEXN), MWEIND(1, INDEXS), NOWE,
456     X      WFACT(1,(JOLAT - 1) * NOWE + 1), IPR, KERR)
457C
458        IF( IERR.GT.0 ) THEN
459          IRLSMB = IERR
460          GOTO 900
461        ENDIF
462C
463        IPR = KPR - 1
464C
465      ENDDO
466C
467C     -----------------------------------------------------------------|
468C*    Section 9. Return to calling routine. Format statements
469C     -----------------------------------------------------------------|
470C
471  900 CONTINUE
472C
473      IF( KPR.GE.1 ) CALL INTLOG(JP_DEBUG,'IRLSMB: Section 9.',JPQUIET)
474C
475      RETURN
476      END
477