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 BUENS4(KSEC3,KSEC4,KELEM,KVALS,VALUES,CVALS,
12     1                  KBUFL,KBUFF,KERR)
13C
14C**** *BUENS4*
15C
16C
17C     PURPOSE.
18C     --------
19C          PACK PRELIMINARY ITEMS AND DATA OF SECTION 4 OF BUFR MESSAGE.
20C
21C
22C**   INTERFACE.
23C     ----------
24C
25C          *CALL* *BUENS4(KSEC3,KSEC4,KELEM,KVALS,VALUES,CVALS,
26C                         KBUFL,KBUFF,KERR)*
27C
28C        INPUT :
29C               *KSEC3*   -  ARRAY CONTAINING SECTION 3 INFORMATION
30C                            KSEC3( 1)-- LENGTH OF SECTION 3 (BYTES)
31C                            KSEC3( 2)-- RESERVED
32C                            KSEC3( 3)-- NUMBER OF SUBSETS
33C                            KSEC3( 4)-- FLAG (DATA TYPE,DATA COMPRESSION)
34C               *KSEC4*   -  ARRAY CONTAINING SECTION 4 INFORMATION
35C                            KSEC4( 1)-- LENGTH OF SECTION 4 (BYTES)
36C                            KSEC4( 2)-- RESERVED
37C               *KELEM*   -  NUMBER OF ELEMENTS IN BUFR TEMPLATE
38C               *KVALS*   -  DIMENSION OF VALUES ARRAY
39C               *VALUES*  -  REAL ARRAY (EXPANDED DATA VALUES)
40C
41C        OUTPUT :
42C               *KBUFL*   -  LENGTH OF BUFR MESSAGE (WORDS)
43C               *KBUFF*   -  ARRAY CONTAINING BUFR MESSAGE
44C               *KERR*    -  RETURNED ERROR CODE
45C
46C     METHOD.
47C     -------
48C
49C           NONE.
50C
51C
52C     EXTERNALS.
53C     ----------
54C
55C          BUPCK          -  PACK BIT PATHERN
56C          BUPKS          -  PACK BIT PATHERN IN REPEATED WAY,
57C                            POINTER ADJUSTMENT
58C          BUOCTN         -  SET LENGTH OF SECTION
59C
60C
61C     REFERENCE.
62C     ----------
63C
64C          NONE.
65C
66C     AUTHOR.
67C     -------
68C
69C          M. DRAGOSAVAC    *ECMWF*       17/01/91.
70C
71C
72C     MODIFICATIONS.
73C     --------------
74C
75C          NONE.
76C
77C
78      IMPLICIT LOGICAL(L,O,G), CHARACTER*8(C,H,Y)
79C
80C
81#     include "parameter.F"
82#     include "bcomunit.F"
83#     include "bcmwork.F"
84#     include "bcmwt.F"
85#     include "bcmwtc.F"
86#     include "bcmbef.F"
87#     include "bcprq.F"
88#     include "bcmoff.F"
89C
90      CHARACTER*64 CWTEN
91      CHARACTER*24 CWTU
92C
93      DIMENSION KBUFF(KBUFL)
94C
95      DIMENSION KSEC3(JSEC3),KSEC4(JSEC4)
96#ifndef R_4
97      REAL*8 VALUES(KVALS)
98      REAL*8 RVIND
99      REAL*8 EPS
100      REAL*8 VAL,VAL8S
101      REAL*8 VCHECK
102      REAL*8 RVALS(JWORK)
103#else
104      REAL   VALUES(KVALS)
105      REAL   RVIND
106      REAL   EPS
107      REAL   VAL
108      REAL   VCHECK
109      REAL   RVALS(JWORK)
110#endif
111C
112      REAL*4 RVALS4(JWORK)
113      REAL*4 VAL4,VAL4S
114      INTEGER*4 I4
115      REAL*8 R8
116      REAL*4 R4
117      LOGICAL OBIG, OEQUAL
118      LOGICAL BIG_ENDIAN
119C
120      DIMENSION IVALS(JWORK),INC(JELEM),ILOCVAL(JELEM)
121      DIMENSION IIVALS(JELEM)
122C
123      CHARACTER*80 CVALS(KVALS)
124      CHARACTER*80 YVAL
125C
126      DIMENSION IMASK(8),IMAXV(32)
127      DATA IMASK/1,2,4,8,16,32,64,128/
128C     DATA ILOCVAL/JELEM*0/
129C
130      DATA IMAXV/1,3,7,15,31,63,127,255,511,1023,2047,4095,8191,
131     1  16383,32767,65535,131071,262143,524287,1048575,2097151,
132     2  4194305,8388607,16777215,33554431,671108863,134217727,
133     3  268435455,536870911,1073741823,2147483647,2147483647/
134C
135      SAVE IWPTB,IBPTB
136C     ------------------------------------------------------------------
137C*          1.  PACK PRELIMINARY ITEMS OF SECTION 4.
138C               ------------------------------------
139 100  CONTINUE
140C
141      IF(KERR.GT.0) RETURN
142C
143#if defined(gfortran)
144      R4=HUGE(R4)
145      R8=HUGE(R8)
146#else
147      R4=3.4028235e+38
148      R8=1.7976931348623157D+308
149#endif
150C
151C*          1.1  KEEP POINTERS TO THE BEGINING OF THE SECTION.
152C                ---------------------------------------------
153 110  CONTINUE
154C
155      IF(OMULTI) THEN
156        IF(NSUBSET.EQ.1) THEN
157           IWPTB = NWPT
158           IBPTB = NBPT
159        END IF
160      ELSE
161         IWPTB = NWPT
162         IBPTB = NBPT
163      END IF
164
165c     IF(OMULTI.AND.NSUBSET.EQ.1) THEN
166      IF(NSUBSET.EQ.1) THEN
167C
168C*          1.2  PACK LENGTH OF SECTION 4.
169C                -------------------------
170 120  CONTINUE
171C
172         CALL BUPCK(NBPW,KBUFF(NWPT),0,NWPT,NBPT,24,KERR)
173         IF(KERR.GT.0) THEN
174            WRITE(KNTN,*) 'ERROR PACKING LENGTH OF SECTION 4.'
175            RETURN
176         END IF
177C
178C*          1.4  PACK RESERVED BYTE.
179C                -------------------
180 140     CONTINUE
181C
182         CALL BUPCK(NBPW,KBUFF(NWPT),0,NWPT,NBPT, 8,KERR)
183         IF(KERR.GT.0) THEN
184            WRITE(KNTN,*)'ERROR PACKING RESERVED BYTE IN SECTION 4.'
185            RETURN
186         END IF
187C
188      END IF
189C     -----------------------------------------------------------------
190C*          2. PACK DATA.
191C              ----------
192 200  CONTINUE
193C
194C      IKK=KELEM*KSEC3(3)
195C      IF(IKK.GT.JWORK) THEN
196C         KERR=17
197C         CALL BUERR(KERR)
198C         WRITE(KNTN,*)'CHECK VALUES OF KELEM AND NUMBER OF SUBSETS KSEC3(3).'
199C         RETURN
200C      END IF
201C      IF(IKK.GT.KVALS) THEN
202C         KERR=14
203C         CALL BUERR(KERR)
204C         WRITE(KNTN,*)'KVALS MUST BE GREATER THAN KELEM*KSEC3(3).'
205C         RETURN
206C      END IF
207C
208C*          2.1  CHECK IF DATA HAS TO BE COMRESSED.
209C                ----------------------------------
210 210  CONTINUE
211C
212      IB=0
213      IF(IAND(KSEC3(4),IMASK(7)).NE.0) IB=1
214C
215C
216C     ------------------------------------------------------------------
217C
218C*          3.  UNCOMPRESSED DATA.
219C               ------------------
220 300  CONTINUE
221C
222      IF(IB.EQ.0) THEN
223C
224         N=KSEC3(3)
225         IF(OMULTI) N=1
226
227         DO 301 I=1,N
228C
229         IF(OMULTI) THEN
230            IM1K=(NSUBSET-1)*KELEM
231         ELSE
232            IM1K=(I-1)*KELEM
233         END IF
234C
235         DO 302 J=1,M
236C
237
238C        IF(NWTR(J).EQ.31011.OR.NWTR(J).EQ.31012) THEN
239C           IRP=VALUES(J+IM1K)
240C           DO III=J+2,J+IRP
241C            NWTDW(iii)=0
242C           END DO
243C        END IF
244C
245         IF(NWTDW(J).EQ.0) GO TO 302
246C
247
248         IREF  =NWTRV(J)
249         ISCALE=NWTS (J)
250         IBDW  =NWTDW(J)
251C
252         JI=J+IM1K
253C
254         VAL=VALUES(JI)
255         IF(NWTEN(J).EQ.-999) THEN
256            IBYTES=NWTDW(J)/8
257            IF(ABS(VAL-RVIND)/RVIND.LE.EPS) THEN
258               IF(IBYTES.EQ.4) VAL=R4
259               IF(IBYTES.EQ.8) VAL=R8
260            END IF
261            IF(IBYTES.EQ.4) THEN
262               VAL4=VAL
263               OBIG=BIG_ENDIAN()
264               IF(.NOT.OBIG) THEN
265                  CALL SWAP_BYTES4(VAL4,VAL4S)
266                  VAL4=VAL4S
267               END IF
268               CALL BUGBYTESR4(VAL4,ILOCVAL,0,8,0,IBYTES)
269            ELSE
270               OBIG=BIG_ENDIAN()
271               IF(.NOT.OBIG) THEN
272                  CALL SWAP_BYTES8(VAL,VAL8S)
273                  VAL=VAL8S
274               END IF
275               CALL BUGBYTESR8(VAL,ILOCVAL,0,8,0,IBYTES)
276            END IF
277            ISKIP=0
278            CALL BUPKS(NBPW,KBUFF(NWPT),ILOCVAL,NWPT,NBPT,8,
279     1                ISKIP,IBYTES,KERR)
280            IF(KERR.GT.0) THEN
281               WRITE(KNTN,*)'BUENS4 :'
282               WRITE(KNTN,*)'ERROR PACKING REAL IEEE'
283               CALL BUERR(KERR)
284               RETURN
285            END IF
286            GO TO 302
287         END IF
288C
289         IF(NWTEN(J).EQ.836970) THEN
290            IF(VAL.LT.0) THEN
291               IPACK=ABS(NINT(VAL))
292               IBDW1=1
293               CALL BUPCK(NBPW,KBUFF(NWPT),1,NWPT,NBPT,IBDW1,KERR)
294               IBDWM1=IBDW-1
295               CALL BUPCK(NBPW,KBUFF(NWPT),IPACK,NWPT,NBPT,IBDWM1,KERR)
296            ELSE
297               IPACK=NINT(VAL)
298               CALL BUPCK(NBPW,KBUFF(NWPT),IPACK,NWPT,NBPT,IBDW,KERR)
299            END IF
300            GO TO 302
301         END IF
302C
303         IF(NWTEN(J).EQ.658367) THEN
304            IF(ABS(VAL-RVIND)/RVIND.LE.EPS) THEN
305              YVAL=' '
306              NCHAR=NWTDW(J)
307              DO 3031 II=1,NCHAR/8
308C             IPACK=ICHAR(YVAL(II:II))
309              IPACK=255
310              IF(IPACK.GT.IMAXV(8)) IPACK=IMAXV(8)
311              CALL BUPCK(NBPW,KBUFF(NWPT),IPACK,NWPT,NBPT,8,KERR)
312              IF(KERR.GT.0) THEN
313                 WRITE(KNTN,*)'ERROR PACKING ',JI,' VALUE FOR ',J,
314     1                        ' ELEMENT.'
315                 RETURN
316              END IF
317 3031         CONTINUE
318              GO TO 302
319
320            ELSE
321              IST=NINT(VAL)/1000
322              YVAL=CVALS(IST)
323              NCHAR=NWTDW(J)/8
324              DO 303 II=1,NCHAR
325              IPACK=ICHAR(YVAL(II:II))
326              IF(IPACK.GT.IMAXV(8)) IPACK=IMAXV(8)
327              CALL BUPCK(NBPW,KBUFF(NWPT),IPACK,NWPT,NBPT,8,KERR)
328              IF(KERR.GT.0) THEN
329                 WRITE(KNTN,*)'ERROR PACKING ',JI,' VALUE FOR ',J,
330     1                        ' ELEMENT.'
331                 RETURN
332              END IF
333 303          CONTINUE
334              GO TO 302
335            END IF
336         END IF
337C
338         IF(ABS(VAL-RVIND)/RVIND.LE.EPS) THEN
339            CALL BUPCK(NBPW,KBUFF(NWPT),NMASK(IBDW),NWPT,NBPT,IBDW,KERR)
340            IF(KERR.GT.0) THEN
341               WRITE(KNTN,*)'ERROR PACKING ',JI,' VALUE FOR ',J,
342     1                      ' ELEMENT.'
343               RETURN
344            END IF
345         ELSE
346C
347C        CHECK VAL VALUE FOR POSSIBLE OVERFLOW
348C
349
350            IF(NOFL.EQ.1) THEN
351               IF(ABS(VAL).LT.EPS) VAL = 0.0
352               IF(VAL.GE.0) THEN
353                  ICHECK=IMAXV(IBDW)
354                  ICHECK=ICHECK+IREF
355                  VCHECK=ICHECK*10.**(-ISCALE)
356C
357                  IF(VAL .GT. VCHECK) THEN
358                     WRITE(KNTN,*) 'VALUE=',VAL,'TOO BIG FOR ',
359     1                      J,' ELEMENT ',I,' SUBSET.'
360                     VAL=VCHECK+1.
361                  END IF
362               ELSE
363                  VCHECK=IREF/10.**ISCALE
364                  IF(VAL.LT.VCHECK) THEN
365                WRITE(KNTN,*)'VALUE=',VAL,'TOO BIG NEGATIVE FOR ',
366     1                      J,' ELEMENT ',I,' SUBSET.'
367                     VAL=IREF/10.**ISCALE-1.
368                  END IF
369               END IF
370            END IF
371
372            IF(ISCALE.LT.0) THEN
373               ISCALE=IABS(ISCALE)
374               IPACK=NINT(VAL/10.**ISCALE) - IREF
375            ELSE
376               IPACK=NINT(VAL*10.**ISCALE) - IREF
377            END IF
378C
379C           CHECK IF VALUE TO BE PACKED NEGATIVE
380C
381            IF(IPACK.LT.0) THEN
382               KERR=-33
383               WRITE(KNTN,*)'BUENS4:'
384               WRITE(KNTN,*)'VALUE ',IPACK,' IS NEGATIVE'
385               WRITE(KNTN,*)'PROBABLY REFERENCE VALUE TOO BIG.'
386               WRITE(KNTN,*)J,' ELEMENT = ',NWTR(J),
387     1               ' REFERENCE VALUE = ',IREF
388               IPACK=0
389               WRITE(KNTN,*)'ELEMENT VALUE PACKED AS',IREF
390            END IF
391C
392C*          CHECK IF VALUE TO BE PACKED TOO BIG.
393C
394            IF(IPACK.GT.IMAXV(IBDW)) THEN
395C
396               IF(NPMISS.EQ.0) THEN
397                KERR=-28
398                WRITE(KNTN,*)'VALUE ',IPACK,' TOO BIG.'
399                WRITE(KNTN,*)'VALUE FOR ',J,' ELEMENT AND ',I,
400     1                       ' SUBSET'
401                WRITE(KNTN,*)'PACKED AS MISSING VALUE FOR',
402     1                         ' DATA WIDTH -1.'
403                IPACK=IMAXV(IBDW)-1
404               ELSE
405C
406C                 ALL ELEMENTS IN CLASS 1 TO 9 MUST BE CORRECT
407C
408                  IF(NWTR(J).GE.31000.AND.NWTR(J).LE.31012) THEN
409                     WRITE(KNTN,*)'VALUE ',IPACK,' TOO BIG.'
410                     WRITE(KNTN,*)'VALUE FOR ',J,' ELEMENT AND ',I,
411     1                           ' SUBSET'
412                     KERR=28
413                     CALL BUERR(KERR)
414                     RETURN
415                  END IF
416C
417                  KERR=-28
418                  WRITE(KNTN,*)'VALUE ',IPACK,' TOO BIG.'
419                  WRITE(KNTN,*)'VALUE FOR ',J,' ELEMENT AND ',I,
420     1                         ' SUBSET'
421                  WRITE(KNTN,*)'PACKED AS MISSING VALUE FOR',
422     1                         '  DATA WIDTH.'
423                  IPACK=IMAXV(IBDW)
424               END IF
425            END IF
426            CALL BUPCK(NBPW,KBUFF(NWPT),IPACK,NWPT,NBPT,IBDW,KERR)
427            IF(KERR.GT.0) THEN
428               WRITE(KNTN,*)'ERROR PACKING ',JI,' VALUE FOR ',J,
429     1         ' ELEMENT.'
430               WRITE(KNTN,*)'VALUE ',IPACK,' DATA WIDTH ',IBDW,
431     1         ' BITS'
432               RETURN
433            END IF
434         END IF
435C
436 302     CONTINUE
437 301     CONTINUE
438C
439         NWP=NWPT
440         NBP=NBPT
441      END IF
442C
443C*          4.  COMPRESS DATA.
444C               --------------
445 400  CONTINUE
446C
447      IF(IB.EQ.1) THEN
448         DO 402 J=1,M
449C
450         IF(NWTDW(J).EQ.0) GO TO 402
451C
452         IREF  =NWTRV(J)
453         ISCALE=NWTS (J)
454         IBDW  =NWTDW(J)
455C
456         DO 401 I=1,KSEC3(3)
457C
458         JI=J+(I-1)*KELEM
459C
460         IF(NWTEN(J).EQ.658367) THEN
461            IVALS(JI)=VALUES(JI)
462            GO TO 401
463         END IF
464C
465         IF(NWTEN(J).EQ.-999) THEN
466            IF(NWTDW(J).EQ.32) THEN
467               IF(ABS(VALUES(JI)-RVIND)/RVIND.LT.EPS) THEN
468                  RVALS4(JI)=R4
469               ELSE
470                  RVALS4(JI)=VALUES(JI)
471               END IF
472            ELSE
473              IF(ABS(VALUES(JI)-RVIND)/RVIND.LT.EPS) THEN
474                 RVALS(JI)=R8
475               ELSE
476                 RVALS(JI)=VALUES(JI)
477               END IF
478            END IF
479            GO TO 401
480         END IF
481C
482         IF(NWTEN(J).EQ.836970) THEN
483            ISG_REF=0
484            IF(VALUES(JI).LT.0) ISG_REF=1
485            IVALS(JI)=IABS(NINT(VALUES(JI)))
486            GO TO 401
487         END IF
488C
489         IF(ABS(VALUES(JI)-RVIND)/RVIND.LE.EPS) THEN
490            IVALS(JI)=NMASK(IBDW)
491         ELSE
492            IF(NOFL.EQ.1) THEN
493               IF(VALUES(JI).GE.0) THEN
494                  ICHECK=IMAXV(IBDW)
495                  ICHECK=ICHECK+IREF
496                  VCHECK=ICHECK*10.**(-ISCALE)
497C
498                  IF(VALUES(JI) .GT. VCHECK) THEN
499                     WRITE(KNTN,*) 'VALUE=',VALUES(JI),'TOO BIG FOR ',
500     1                      J,' ELEMENT AND ',I,' SUBSET.'
501                     VALUES(JI)=VCHECK+1.
502                  END IF
503               ELSE
504                  VCHECK=IREF/10.**ISCALE
505                  IF(VALUES(JI).LT.VCHECK) THEN
506                     WRITE(KNTN,*) 'VALUE=',VALUES(JI),
507     1                      'TOO BIG NEGATIVE FOR ',
508     1                      J,' ELEMENT AND ',I,' SUBSET.'
509                     VALUES(JI)=IREF/10.**ISCALE-1.
510                  END IF
511               END IF
512            END IF
513C
514            IF(ISCALE.LT.0) THEN
515               ISCAL=IABS(ISCALE)
516               IPACK=NINT(VALUES(JI)/10.**ISCAL ) - IREF
517            ELSE
518               IPACK=NINT(VALUES(JI)*10.**ISCALE) - IREF
519            END IF
520C
521            IF(IPACK.LT.0) THEN
522               WRITE(KNTN,*)'BUENS4 :'
523               KERR=-33
524               WRITE(KNTN,*)'VALUE ',IPACK,' IS NEGATIVE'
525               WRITE(KNTN,*)'PROBABLY REFERENCE VALUE TOO BIG.'
526               WRITE(KNTN,*)J,'ELEMENT = ',NWTR(J),
527     1                    ' REFERENCE VALUE = ',IREF
528               IPACK=0
529               WRITE(KNTN,*)'ELEMENT PACKED AS',IREF
530            END IF
531C
532C           REPLACE IPACK VALUE WITH MISSING VALUE FOR IBDW -1
533C           IF GREATER THEN MAXIMUM ALLOWED.
534C
535            IF(IPACK.GT.IMAXV(IBDW)) THEN
536C
537               IF(NPMISS.EQ.0) THEN
538                  KERR=-28
539                  WRITE(KNTN,*)'VALUE ',IPACK,' TOO BIG.'
540                  WRITE(KNTN,*)'VALUE FOR ',J,' ELEMENT AND ',I,
541     1            ' SUBSET'
542                  WRITE(KNTN,*)'PACKED AS MISSING VALUE FOR DATA ',
543     1                         'WIDTH -1.'
544                  IPACK=IMAXV(IBDW)-1
545               ELSE
546C
547C                 ALL ELEMENTS IN CLASS 1 TO 9 MUST BE CORRECT
548C
549                  IF(NWTR(J).GE.31000.AND.NWTR(J).LE.31012) THEN
550                     KERR=28
551                     CALL BUERR(KERR)
552                     WRITE(KNTN,*)'VALUE ',IPACK,' TOO BIG.'
553                     WRITE(KNTN,*)'VALUE FOR ',J,' ELEMENT AND ',I,
554     1               ' SUBSET'
555                     RETURN
556                  END IF
557C
558                  KERR=-28
559                  WRITE(KNTN,*)'VALUE ',IPACK,' TOO BIG.'
560                  WRITE(KNTN,*)'VALUE FOR ',J,' ELEMENT AND ',I,
561     1            ' SUBSET'
562                  WRITE(KNTN,*)'PACKED AS MISSING VALUE.'
563                  IPACK=IMAXV(IBDW)
564               END IF
565            END IF
566            IVALS(JI)=IPACK
567C
568         END IF
569C
570 401     CONTINUE
571 402     CONTINUE
572C
573C*          4.1  CHECK IF ALL VALUES ARE MISSING.
574C
575 410  CONTINUE
576C
577         DO 411 I=1,M
578C
579         IF(NWTDW(I).EQ.0) GO TO 411
580         IBDW  =NWTDW(I)
581C
582         OMIS=.TRUE.
583         IF(NWTEN(I).EQ.658367) THEN
584            OMIS=.FALSE.
585         ELSEIF(NWTEN(I).EQ.-999) THEN
586            OMIS=.FALSE.
587         ELSE
588            DO 412 J=1,KSEC3(3)
589            IJ=I+(J-1)*KELEM
590            IF(IVALS(IJ).NE.NMASK(IBDW)) THEN
591               OMIS=.FALSE.
592            END IF
593 412        CONTINUE
594         END IF
595C
596         IF(.NOT.OMIS) THEN
597C
598            IF(NWTEN(I).NE.658367.AND.NWTEN(I).NE.-999) THEN
599C
600C              FIND MINIMUM VALUE FOR ELEMENT
601C
602               MIN=IVALS(I)
603               DO 413 J=1,KSEC3(3)
604               IJ=I+(J-1)*KELEM
605               IF(IVALS(IJ).LT.MIN) MIN=IVALS(IJ)
606 413           CONTINUE
607C
608C              FIND INCREMENTS
609C
610               DO 414 J=1,KSEC3(3)
611               IJ=I+(J-1)*KELEM
612               INC(J)=IVALS(IJ)-MIN
613               IF(IVALS(IJ).EQ.NMASK(IBDW)) INC(J)=NVIND
614 414           CONTINUE
615C
616C              FIND NUMBER OF BITS NEEDED FOR MAX VALUE OF INCREMENT
617C
618               MAX=0
619               DO 415 J=1,KSEC3(3)
620               IF(INC(J).NE.NVIND.AND.INC(J).GT.MAX) MAX=INC(J)
621 415           CONTINUE
622C
623C              CHECK IF ALL INCREMENTS ARE ZERO
624C
625               INC0=0
626               DO 419 J=1,KSEC3(3)
627               IF(INC(J).NE.0) INC0=1
628 419           CONTINUE
629C
630C              FIND NUMBER OF BITS NEEDED
631C
632               IF(INC0.NE.0) THEN
633                  MAX=MAX+1
634                  DO 416 J=1,32
635                  IR=MAX/2
636                  IF(IR.EQ.0) GO TO 417
637                  MAX=IR
638 416              CONTINUE
639C
640               END IF
641C
642 417           CONTINUE
643C
644               INCBIT=0
645               IF(INC0.NE.0) INCBIT=J
646C
647C              REPLACE MISSING VALUES FOR INCREMENT BY ALL BITS SET TO 1.
648C
649               DO 418 J=1,KSEC3(3)
650               IF(INC(J).EQ.NVIND) INC(J)=NMASK(INCBIT)
651 418           CONTINUE
652            END IF
653         END IF
654C
655C*          4.2  PACK DATA IN COMPRESSED FORM.
656C                -----------------------------
657 420  CONTINUE
658C
659         IF(NWTEN(I).EQ.658367) THEN
660C
661            OSTRING=.TRUE.
662            JI1=I
663            IST1=IVALS(JI1)/1000
664            ICS=NWTDW(I)/8
665C           ICS=NINT(VALUES(JI1))-IST1*1000
666            NCSMAX=ICS
667            DO  IX=ICS,1,-1
668            IF(CVALS(IST1)(IX:IX).NE.' ') THEN
669               NCS=IX
670               GO TO 522
671            END IF
672            END DO
673
674 522        NCSMAX=NCS
675            DO J=2,KSEC3(3)
676            JI=I+(J-1)*KELEM
677            IST=VALUES(JI)/1000
678            IF(CVALS(IST1).NE.CVALS(IST)) OSTRING=.FALSE.
679C           FIND MAX SIZE OF STRINGS
680            ICS=NWTDW(I)/8
681C           ICS=NINT(VALUES(JI))-IST*1000
682            DO  IX=ICS,1,-1
683            IF(CVALS(IST)(IX:IX).NE.' ') THEN
684               NCS=IX
685               GO TO 521
686            END IF
687            END DO
688 521        CONTINUE
689            IF(NCS.GT.NCSMAX) NCSMAX=NCS
690            END DO
691
692C
693            IF(OSTRING) THEN
694C
695              INCHAR=NWTDW(I)/8
696              ISKIP=0
697              DO II=1,INCHAR
698              IPACK=ICHAR(CVALS(IST1)(II:II))
699              CALL BUPCK(NBPW,KBUFF(NWPT),IPACK,NWPT,NBPT,8,KERR)
700              IF(KERR.GT.0) THEN
701                 WRITE(KNTN,*)'BUENS4 :'
702                 CALL BUERR(KERR)
703                 RETURN
704              END IF
705              END DO
706              IPACK=0
707              CALL BUPCK(NBPW,KBUFF(NWPT),IPACK,NWPT,NBPT,6,KERR)
708              IF(KERR.GT.0) THEN
709                 WRITE(KNTN,*)'BUENS4 :'
710                 CALL BUERR(KERR)
711                 RETURN
712              END IF
713            ELSE
714C
715C           PACK LOCAL REFERENCE VALUE FOR ELEMENT
716C
717            INCHAR=NWTDW(I)/8
718            ISKIP=0
719            CALL BUPKS(NBPW,KBUFF(NWPT),ILOCVAL,NWPT,NBPT,8,
720     1                ISKIP,INCHAR,KERR)
721            IF(KERR.GT.0) THEN
722               WRITE(KNTN,*)'BUENS4 :'
723               WRITE(KNTN,*)'ERROR PACKING LOCAL REFERENCE VALUE'
724               CALL BUERR(KERR)
725               RETURN
726            END IF
727C
728C           PACK NUMBER OF BITS FOR INCREMENTS/NUMBER OF CHARACTERS
729C
730C           CALL BUPCK(NBPW,KBUFF(NWPT),INCHAR,NWPT,NBPT,6,KERR)
731            CALL BUPCK(NBPW,KBUFF(NWPT),NCSMAX,NWPT,NBPT,6,KERR)
732            IF(KERR.GT.0) THEN
733              WRITE(KNTN,*)'BUENS4 :'
734              WRITE(KNTN,*)'ERROR PACKING NUMBER OF BITS FOR INCREMENTS'
735              CALL BUERR(KERR)
736              RETURN
737            END IF
738C
739C           PACK INCREMENTS
740C
741            DO 421 J=1,KSEC3(3)
742C
743            JI=I+(J-1)*KELEM
744C
745            IST=IVALS(JI)/1000
746            YVAL=CVALS(IST)
747C
748            DO 423 II=1,NCSMAX
749            IPACK=ICHAR(YVAL(II:II))
750            CALL BUPCK(NBPW,KBUFF(NWPT),IPACK,NWPT,NBPT,8,KERR)
751            IF(KERR.GT.0) THEN
752               WRITE(KNTN,*)'BUENS4 :'
753               CALL BUERR(KERR)
754               RETURN
755            END IF
756 423        CONTINUE
757C
758 421        CONTINUE
759C
760            END IF
761         ELSEIF(NWTEN(I).EQ.-999) THEN
762C
763            OEQUAL=.TRUE.
764            DO J=1,KSEC3(3)-1
765            JI=I+(J-1)*KELEM
766            JII=I+J*KELEM
767            IF(NWTDW(I).EQ.32) THEN
768               IF(ABS(RVALS4(JI)-RVALS4(JII))/RVALS4(JII).GT.EPS) THEN
769                  OEQUAL=.FALSE.
770                  GO TO 4444
771               END IF
772
773            ELSE
774               IF(ABS(RVALS(JI)-RVALS(JII))/RVALS(JII).GT.EPS) THEN
775                  OEQUAL=.FALSE.
776                  GO TO 4444
777               END IF
778            END IF
779            END DO
780C
781C           PACK LOCAL REFERENCE VALUE FOR ELEMENT
782C
7834444        INCHAR=NWTDW(I)/8
784            ISKIP=0
785
786            IF(.NOT.OEQUAL) THEN
787C
788              CALL BUPKS(NBPW,KBUFF(NWPT),ILOCVAL,NWPT,NBPT,8,
789     1                  ISKIP,INCHAR,KERR)
790              IF(KERR.GT.0) THEN
791                 WRITE(KNTN,*)'BUENS4 :'
792                 WRITE(KNTN,*)'ERROR PACKING LOCAL REFERENCE VALUE'
793                 CALL BUERR(KERR)
794                 RETURN
795              END IF
796C
797C             PACK NUMBER OF BITS FOR INCREMENTS/NUMBER OF CHARACTERS
798C
799              CALL BUPCK(NBPW,KBUFF(NWPT),INCHAR,NWPT,NBPT,6,KERR)
800              IF(KERR.GT.0) THEN
801                 WRITE(KNTN,*)'BUENS4 :'
802                 WRITE(KNTN,*)'ERROR PACKING NUMBER OF BITS
803     1                         FOR INCREMENTS'
804                 CALL BUERR(KERR)
805                 RETURN
806              END IF
807C
808C             PACK INCREMENTS
809C
810              DO J=1,KSEC3(3)
811C
812              JI=I+(J-1)*KELEM
813C
814              IF(NWTDW(I).EQ.32) THEN
815                 VAL4=RVALS4(JI)
816                 CALL BUGBYTESR4(VAL4,IIVALS,0,8,0,INCHAR)
817              ELSE
818                 VAL=RVALS(JI)
819                 CALL BUGBYTESR8(VAL,IIVALS,0,8,0,INCHAR)
820              END IF
821C
822              DO IZ=1,INCHAR
823               IPACK=IIVALS(IZ)
824               CALL BUPCK(NBPW,KBUFF(NWPT),IPACK,NWPT,NBPT,8,KERR)
825              END DO
826C
827              END DO
828
829            ELSE
830
831              IBYTES=NWTDW(I)/8
832              IF(IBYTES.EQ.4) THEN
833                 VAL4=RVALS4(I)
834                 OBIG=BIG_ENDIAN()
835                 IF(.NOT.OBIG) THEN
836                    CALL SWAP_BYTES4(VAL4,VAL4S)
837                    VAL4=VAL4S
838                 END IF
839                 CALL BUGBYTESR4(VAL4,ILOCVAL,0,8,0,IBYTES)
840              ELSE
841                 VAL=RVALS(I)
842                 OBIG=BIG_ENDIAN()
843                 IF(.NOT.OBIG) THEN
844                    CALL SWAP_BYTES8(VAL,VAL8S)
845                    VAL=VAL8S
846                 END IF
847                 CALL BUGBYTESR8(VAL,ILOCVAL,0,8,0,IBYTES)
848              END IF
849              ISKIP=0
850              CALL BUPKS(NBPW,KBUFF(NWPT),ILOCVAL,NWPT,NBPT,8,
851     1                  ISKIP,IBYTES,KERR)
852              IF(KERR.GT.0) THEN
853                 WRITE(KNTN,*)'BUENS4 :'
854                 WRITE(KNTN,*)'ERROR PACKING REAL IEEE'
855                 CALL BUERR(KERR)
856                 RETURN
857              END IF
858C
859              CALL BUPCK(NBPW,KBUFF(NWPT),0,NWPT,NBPT,6,KERR)
860              IF(KERR.GT.0) THEN
861                 WRITE(KNTN,*)'BUENS4 :'
862                 WRITE(KNTN,*)'ERROR PACKING NUMBER OF BITS FOR'
863                 WRITE(KNTN,*)'INCREMENTS FOR ',I,' ELEMENT.'
864                 RETURN
865              END IF
866
867            END IF
868C
869 4211       CONTINUE
870C
871         ELSE
872             IF(OMIS) THEN
873C
874C               PACK LOCAL REFERENCE VALUE FOR ELEMENT SET TO MISSING VALUE.
875C
876                CALL BUPCK(NBPW,KBUFF(NWPT),NMASK(IBDW),NWPT,NBPT,
877     1                     IBDW,KERR)
878                IF(KERR.GT.0) THEN
879                   WRITE(KNTN,*)'BUENS4 :'
880                   WRITE(KNTN,*)'ERROR PACKING LOCAL REFERENCE VALUE '
881                   WRITE(KNTN,*)I,' ELEMENT.'
882                   RETURN
883                END IF
884C
885C               PACK NUMBER OF BITS FOR INCREMENTS (SET TO ZERO)
886C
887                CALL BUPCK(NBPW,KBUFF(NWPT),0,NWPT,NBPT,6,KERR)
888                IF(KERR.GT.0) THEN
889                   WRITE(KNTN,*)'BUENS4 :'
890                   WRITE(KNTN,*)'ERROR PACKING NUMBER OF BITS FOR'
891                   WRITE(KNTN,*)'INCREMENTS FOR ',I,' ELEMENT.'
892                   RETURN
893                END IF
894C
895             ELSE
896C
897                IF(INCBIT.EQ.0) THEN
898C
899C
900C                  PACK LOCAL REFERENCE VALUE FOR ELEMENT
901C
902                 IF(NWTEN(I).EQ.836970) THEN
903                  IF(ISG_REF.EQ.1) THEN
904                    CALL BUPCK(NBPW,KBUFF(NWPT),1,NWPT,NBPT,1,KERR)
905                    CALL BUPCK(NBPW,KBUFF(NWPT),MIN,NWPT,NBPT,IBDW-1,
906     1                         KERR)
907                  ELSE
908                    CALL BUPCK(NBPW,KBUFF(NWPT),MIN,NWPT,NBPT,IBDW,
909     1                         KERR)
910                    IF(KERR.GT.0) THEN
911                      WRITE(KNTN,*)'BUENS4 :'
912                      WRITE(KNTN,*)'ERROR PACKING LOCAL REFERENCE VALUE'
913                      WRITE(KNTN,*)'FOR ',I,' ELEMENT IN ',IBDW,' BITS.'
914                      RETURN
915                    END IF
916                  END IF
917                 ELSE
918                   CALL BUPCK(NBPW,KBUFF(NWPT),MIN,NWPT,NBPT,IBDW,KERR)
919                   IF(KERR.GT.0) THEN
920                      WRITE(KNTN,*)'BUENS4 :'
921                      WRITE(KNTN,*)'ERROR PACKING LOCAL REFERENCE VALUE'
922                      WRITE(KNTN,*)'FOR ',I,' ELEMENT IN ',IBDW,' BITS.'
923                      RETURN
924                   END IF
925                 ENDIF
926C
927C                  PACK NUMBER OF BITS FOR INCREMENTS
928C
929                   CALL BUPCK(NBPW,KBUFF(NWPT),INCBIT,NWPT,NBPT,6,KERR)
930                   IF(KERR.GT.0) THEN
931                      WRITE(KNTN,*)'BUENS4 :'
932                      WRITE(KNTN,*)'ERROR PACKING NUMBER OF BITS FOR'
933                      WRITE(KNTN,*)'INCREMENTS FOR ',I,' ELEMENT.'
934                      RETURN
935                   END IF
936C
937                ELSE
938C
939C                  PACK LOCAL REFERENCE VALUE FOR ELEMENT
940C
941                   IF(NWTEN(I).EQ.836970) THEN
942                      IF(ISG_REF.EQ.1) THEN
943                         CALL BUPCK(NBPW,KBUFF(NWPT),1,NWPT,NBPT,1,KERR)
944                         CALL BUPCK(NBPW,KBUFF(NWPT),MIN,NWPT,NBPT,
945     1                              IBDW-1,KERR)
946                      ELSE
947                         CALL BUPCK(NBPW,KBUFF(NWPT),MIN,NWPT,NBPT,IBDW,
948     1                              KERR)
949                         IF(KERR.GT.0) THEN
950                            WRITE(KNTN,*)'BUENS4 :'
951                      WRITE(KNTN,*)'ERROR PACKING LOCAL REFERENCE VALUE'
952                      WRITE(KNTN,*)'FOR ',I,' ELEMENT IN ',IBDW,' BITS.'
953                            RETURN
954                         END IF
955                      END IF
956                   ELSE
957                     CALL BUPCK(NBPW,KBUFF(NWPT),MIN,NWPT,NBPT,IBDW,
958     1                          KERR)
959                      IF(KERR.GT.0) THEN
960                         WRITE(KNTN,*)'BUENS4 :'
961                      WRITE(KNTN,*)'ERROR PACKING LOCAL REFERENCE VALUE'
962                      WRITE(KNTN,*)'FOR ',I,' ELEMENT IN ',IBDW,' BITS.'
963                         RETURN
964                      END IF
965                   ENDIF
966
967C
968C                  PACK NUMBER OF BITS FOR INCREMENTS
969C
970                   CALL BUPCK(NBPW,KBUFF(NWPT),INCBIT,NWPT,NBPT,6,KERR)
971                   IF(KERR.GT.0) THEN
972                      WRITE(KNTN,*)'BUENS4 :'
973                      WRITE(KNTN,*)'ERROR PACKING NUMBER OF BITS FOR'
974                      WRITE(KNTN,*)  'INCREMENTS FOR ',I,' ELEMENT.'
975                      RETURN
976                   END IF
977C
978C                  PACK INCREMENTS
979C
980                   CALL BUPKS(NBPW,KBUFF(NWPT),INC,NWPT,NBPT,
981     1                        INCBIT,0,KSEC3(3),KERR)
982                   IF(KERR.GT.0) THEN
983                      WRITE(KNTN,*)  'BUENS4 :'
984                      WRITE(KNTN,*)  'ERROR PACKING INCREMENTS FOR',I,
985     1                ' ELEMENT'
986                      RETURN
987                   END IF
988C
989                END IF
990             END IF
991          END IF
992C
993 411     CONTINUE
994C
995      END IF
996C
997C*          5.  SET UP LENGTH OF THE SECTION 4.
998C               --------------------------------
999 500  CONTINUE
1000C
1001      IF(OMULTI) THEN
1002         IF(NSUBSET.EQ.KSEC3(3)) THEN
1003            CALL BUOCTN(IWPTB,IBPTB,KBUFL,KBUFF,KERR)
1004            IF(KERR.GT.0) THEN
1005               CALL BUERR(KERR)
1006               RETURN
1007            END IF
1008         END IF
1009      ELSE
1010         CALL BUOCTN(IWPTB,IBPTB,KBUFL,KBUFF,KERR)
1011         IF(KERR.GT.0) THEN
1012            CALL BUERR(KERR)
1013            RETURN
1014         END IF
1015      END IF
1016C
1017C     ------------------------------------------------------------------
1018      RETURN
1019      END
1020