PageRenderTime 59ms CodeModel.GetById 19ms RepoModel.GetById 0ms app.codeStats 0ms

/WPS/ungrib/src/ngl/w3/w3fi75.f

http://github.com/jbeezley/wrf-fire
FORTRAN Legacy | 1596 lines | 559 code | 1 blank | 1036 comment | 0 complexity | 724b1026278950ea32cb72d76d8fd9c5 MD5 | raw file
Possible License(s): AGPL-1.0

Large files files are truncated, but you can click here to view the full file

    

  1.       SUBROUTINE W3FI75 (IBITL,ITYPE,ITOSS,FLD,IFLD,IBMAP,IBDSFL,
    2. 

  2.      &  NPTS,BDS11,IPFLD,PFLD,LEN,LENBDS,IBERR,PDS,IGDS)
    3. 

  3. C $$  SUBPROGRAM DOCUMENTATION BLOCK
    4. 

  4. C                .      .    .                                       .
    5. 

  5. C SUBPROGRAM:  W3FI75        GRIB PACK DATA AND FORM BDS OCTETS(1-11)
    6. 

  6. C   PRGMMR: FARLEY           ORG: NMC421      DATE:94-11-22
    7. 

  7. C
    8. 

  8. C ABSTRACT: THIS ROUTINE PACKS A GRIB FIELD AND FORMS OCTETS(1-11)
    9. 

  9. C   OF THE BINARY DATA SECTION (BDS).
    10. 

  10. C
    11. 

  11. C PROGRAM HISTORY LOG:
    12. 

  12. C   92-07-10  M. FARLEY   ORIGINAL AUTHOR
    13. 

  13. C   92-10-01  R.E.JONES   CORRECTION FOR FIELD OF CONSTANT DATA
    14. 

  14. C   92-10-16  R.E.JONES   GET RID OF ARRAYS FP AND INT
    15. 

  15. C   93-08-06  CAVANAUGH   ADDED ROUTINES FI7501, FI7502, FI7503
    16. 

  16. C                         TO ALLOW SECOND ORDER PACKING IN PDS.
    17. 

  17. C   93-07-21 STACKPOLE    ASSORTED REPAIRS TO GET 2ND DIFF PACK IN
    18. 

  18. C   93-10-28 CAVANAUGH    COMMENTED OUT NONOPERATIONAL PRINTS AND
    19. 

  19. C                         WRITE STATEMENTS
    20. 

  20. C   93-12-15  CAVANAUGH   CORRECTED LOCATION OF START OF FIRST ORDER
    21. 

  21. C                         VALUES AND START OF SECOND ORDER VALUES TO
    22. 

  22. C                         REFLECT A BYTE LOCATION IN THE BDS INSTEAD
    23. 

  23. C                         OF AN OFFSET IN SUBROUTINE FI7501.
    24. 

  24. C   94-01-27  CAVANAUGH   ADDED IGDS AS INPUT ARGUMENT TO THIS ROUTINE
    25. 

  25. C                         AND ADDED PDS AND IGDS ARRAYS TO THE CALL TO
    26. 

  26. C                         W3FI82 TO PROVIDE INFORMATION NEEDED FOR
    27. 

  27. C                         BOUSTROPHEDONIC PROCESSING.
    28. 

  28. C   94-05-25  CAVANAUGH   SUBROUTINE FI7503 HAS BEEN ADDED TO PROVIDE
    29. 

  29. C                         FOR ROW BY ROW OR COLUMN BY COLUMN SECOND
    30. 

  30. C                         ORDER PACKING.  THIS FEATURE CAN BE ACTIVATED
    31. 

  31. C                         BY SETTING IBDSFL(7) TO ZERO.
    32. 

  32. C   94-07-08  CAVANAUGH   COMMENTED OUT PRINT STATEMENTS USED FOR DEBUG
    33. 

  33. C   94-11-22  FARLEY      ENLARGED WORK ARRAYS TO HANDLE .5DEGREE GRIDS
    34. 

  34. C   95-06-01  R.E.JONES   CORRECTION FOR NUMBER OF UNUSED BITS AT END
    35. 

  35. C                         OF SECTION 4, IN BDS BYTE 4, BITS 5-8.
    36. 

  36. C   95-10-31  IREDELL     REMOVED SAVES AND PRINTS
    37. 

  37. C
    38. 

  38. C USAGE:    CALL W3FI75 (IBITL,ITYPE,ITOSS,FLD,IFLD,IBMAP,IBDSFL,
    39. 

  39. C    &              NPTS,BDS11,IPFLD,PFLD,LEN,LENBDS,IBERR,PDS,IGDS)
    40. 

  40. C   INPUT ARGUMENT LIST:
    41. 

  41. C     IBITL     - 0, COMPUTER COMPUTES PACKING LENGTH FROM POWER
    42. 

  42. C                    OF 2 THAT BEST FITS THE DATA.
    43. 

  43. C                 8, 12, ETC. COMPUTER RESCALES DATA TO FIT INTO
    44. 

  44. C                    SET NUMBER OF BITS.
    45. 

  45. C     ITYPE     - 0 = IF INPUT DATA IS FLOATING POINT (FLD)
    46. 

  46. C                 1 = IF INPUT DATA IS INTEGER (IFLD)
    47. 

  47. C     ITOSS     - 0 = NO BIT MAP IS INCLUDED (DON'T TOSS DATA)
    48. 

  48. C                 1 = TOSS NULL DATA ACCORDING TO IBMAP
    49. 

  49. C     FLD       - REAL ARRAY OF DATA TO BE PACKED IF ITYPE=0
    50. 

  50. C     IFLD      - INTEGER ARRAY TO BE PACKED IF ITYPE=1
    51. 

  51. C     IBMAP     - BIT MAP SUPPLIED FROM USER
    52. 

  52. C     IBDSFL    - INTEGER ARRAY CONTAINING TABLE 11 FLAG INFO
    53. 

  53. C                 BDS OCTET 4:
    54. 

  54. C                 (1) 0 = GRID POINT DATA
    55. 

  55. C                     1 = SPHERICAL HARMONIC COEFFICIENTS
    56. 

  56. C                 (2) 0 = SIMPLE PACKING
    57. 

  57. C                     1 = SECOND ORDER PACKING
    58. 

  58. C                 (3) 0 = ORIGINAL DATA WERE FLOATING POINT VALUES
    59. 

  59. C                     1 = ORIGINAL DATA WERE INTEGER VALUES
    60. 

  60. C                 (4) 0 = NO ADDITIONAL FLAGS AT OCTET 14
    61. 

  61. C                     1 = OCTET 14 CONTAINS FLAG BITS 5-12
    62. 

  62. C                 (5) 0 = RESERVED - ALWAYS SET TO 0
    63. 

  63. C                 (6) 0 = SINGLE DATUM AT EACH GRID POINT
    64. 

  64. C                     1 = MATRIX OF VALUES AT EACH GRID POINT
    65. 

  65. C                 (7) 0 = NO SECONDARY BIT MAPS
    66. 

  66. C                     1 = SECONDARY BIT MAPS PRESENT
    67. 

  67. C                 (8) 0 = SECOND ORDER VALUES HAVE CONSTANT WIDTH
    68. 

  68. C                     1 = SECOND ORDER VALUES HAVE DIFFERENT WIDTHS
    69. 

  69. C     NPTS      - NUMBER OF GRIDPOINTS IN ARRAY TO BE PACKED
    70. 

  70. C     IGDS      - ARRAY OF GDS INFORMATION
    71. 

  71. C
    72. 

  72. C   OUTPUT ARGUMENT LIST:
    73. 

  73. C     BDS11     - FIRST 11 OCTETS OF BDS
    74. 

  74. C     PFLD      - PACKED GRIB FIELD
    75. 

  75. C     LEN       - LENGTH OF PFLD
    76. 

  76. C     LENBDS    - LENGTH OF BDS
    77. 

  77. C     IBERR     - 1, ERROR CONVERTING IEEE F.P. NUMBER TO IBM370 F.P.
    78. 

  78. C
    79. 

  79. C REMARKS: SUBPROGRAM CAN BE CALLED FROM A MULTIPROCESSING ENVIRONMENT.
    80. 

  80. C
    81. 

  81. C ATTRIBUTES:
    82. 

  82. C   LANGUAGE: IBM VS FORTRAN 77, CRAY CFT77 FORTRAN
    83. 

  83. C   MACHINE:  HDS, CRAY C916/256, Y-MP8/64, Y-MP EL92/256
    84. 

  84. C
    85. 

  85. C $$
    86. 

  86. C
    87. 

  87.       REAL            FLD(*)
    88. 

  88. C     REAL            FWORK(260000)
    89. 

  89. C
    90. 

  90. C     FWORK CAN USE DYNAMIC ALLOCATION OF MEMORY ON CRAY
    91. 

  91. C
    92. 

  92.       REAL            FWORK(NPTS)
    93. 

  93.       REAL            RMIN,REFNCE
    94. 

  94. C
    95. 

  95.       INTEGER         IPFLD(*)
    96. 

  96.       INTEGER         IBDSFL(*)
    97. 

  97.       INTEGER         IBMAP(*)
    98. 

  98.       INTEGER         IFLD(*),IGDS(*)
    99. 

  99. C     INTEGER         IWORK(260000)
    100. 

  100. C
    101. 

  101. C     IWORK CAN USE DYNAMIC ALLOCATION OF MEMORY ON CRAY
    102. 

  102. C
    103. 

  103.       INTEGER         IWORK(NPTS)
    104. 

  104. C
    105. 

  105.       LOGICAL         CONST
    106. 

  106. C
    107. 

  107.       CHARACTER * 1   BDS11(11),PDS(*)
    108. 

  108.       CHARACTER * 1   PFLD(*)
    109. 

  109.       CHARACTER * 1   CIEXP(8)
    110. 

  110.       CHARACTER * 1   CIMANT(8)
    111. 

  111. C
    112. 

  112.       EQUIVALENCE     (IEXP,CIEXP(1))
    113. 

  113.       EQUIVALENCE     (IMANT,CIMANT(1))
    114. 

  114. C
    115. 

  115. C            1.0   PACK THE FIELD.
    116. 

  116. C
    117. 

  117. C            1.1   TOSS DATA IF BITMAP BEING USED,
    118. 

  118. C                  MOVING 'DATA' TO WORK AREA...
    119. 

  119. C
    120. 

  120.       CONST = .FALSE.
    121. 

  121.       IBERR = 0
    122. 

  122.       IW    = 0
    123. 

  123. C
    124. 

  124.       IF (ITOSS .EQ. 1) THEN
    125. 

  125.         IF (ITYPE .EQ. 0) THEN
    126. 

  126.           DO 110 IT=1,NPTS
    127. 

  127.             IF (IBMAP(IT) .EQ. 1) THEN
    128. 

  128.               IW = IW + 1
    129. 

  129.               FWORK(IW) = FLD(IT)
    130. 

  130.             ENDIF
    131. 

  131.   110     CONTINUE
    132. 

  132.           NPTS = IW
    133. 

  133.         ELSE IF (ITYPE .EQ. 1) THEN
    134. 

  134.           DO 111 IT=1,NPTS
    135. 

  135.             IF (IBMAP(IT) .EQ. 1) THEN
    136. 

  136.               IW = IW + 1
    137. 

  137.               IWORK(IW) = IFLD(IT)
    138. 

  138.             ENDIF
    139. 

  139.   111     CONTINUE
    140. 

  140.           NPTS = IW
    141. 

  141.         ENDIF
    142. 

  142. C
    143. 

  143. C             ELSE, JUST MOVE DATA TO WORK ARRAY
    144. 

  144. C
    145. 

  145.       ELSE IF (ITOSS .EQ. 0) THEN
    146. 

  146.         IF (ITYPE .EQ. 0) THEN
    147. 

  147.           DO 112 IT=1,NPTS
    148. 

  148.             FWORK(IT) = FLD(IT)
    149. 

  149.   112     CONTINUE
    150. 

  150.         ELSE IF (ITYPE .EQ. 1) THEN
    151. 

  151.           DO 113 IT=1,NPTS
    152. 

  152.             IWORK(IT) = IFLD(IT)
    153. 

  153.   113     CONTINUE
    154. 

  154.         ENDIF
    155. 

  155.       ENDIF
    156. 

  156. C
    157. 

  157. C            1.2   CONVERT DATA IF NEEDED PRIOR TO PACKING.
    158. 

  158. C                  (INTEGER TO F.P. OR F.P. TO INTEGER)
    159. 

  159. C     ITYPE = 0...FLOATING POINT DATA
    160. 

  160. C       IBITL = 0...PACK IN LEAST # BITS...CONVERT TO INTEGER
    161. 

  161. C     ITYPE = 1...INTEGER DATA
    162. 

  162. C       IBITL > 0...PACK IN FIXED # BITS...CONVERT TO FLOATING POINT
    163. 

  163. C
    164. 

  164.       IF (ITYPE .EQ. 0 .AND. IBITL .EQ. 0) THEN
    165. 

  165.         DO 120 IF=1,NPTS
    166. 

  166.           IWORK(IF) = NINT(FWORK(IF))
    167. 

  167.   120   CONTINUE
    168. 

  168.       ELSE IF (ITYPE .EQ. 1 .AND. IBITL .NE. 0) THEN
    169. 

  169.         DO 123 IF=1,NPTS
    170. 

  170.           FWORK(IF) = FLOAT(IWORK(IF))
    171. 

  171.   123   CONTINUE
    172. 

  172.       ENDIF
    173. 

  173. C
    174. 

  174. C            1.3   PACK THE DATA.
    175. 

  175. C
    176. 

  176.       IF (IBDSFL(2).NE.0) THEN
    177. 

  177. C                                    SECOND ORDER PACKING
    178. 

  178. C
    179. 

  179. C            PRINT*,'  DOING SECOND ORDER PACKING...'
    180. 

  180.           IF (IBITL.EQ.0) THEN
    181. 

  181. C
    182. 

  182. C             PRINT*,'    AND VARIABLE BIT PACKING'
    183. 

  183. C
    184. 

  184. C                           WORKING WITH INTEGER VALUES
    185. 

  185. C                           SINCE DOING VARIABLE BIT PACKING
    186. 

  186. C
    187. 

  187.               MAX  = IWORK(1)
    188. 

  188.               MIN  = IWORK(1)
    189. 

  189.               DO 300 I = 2, NPTS
    190. 

  190.                   IF (IWORK(I).LT.MIN) THEN
    191. 

  191.                       MIN  = IWORK(I)
    192. 

  192.                   ELSE IF (IWORK(I).GT.MAX) THEN
    193. 

  193.                       MAX  = IWORK(I)
    194. 

  194.                   END IF
    195. 

  195.   300         CONTINUE
    196. 

  196. C                           EXTRACT MINIMA
    197. 

  197.               DO 400 I = 1, NPTS
    198. 

  198. C                 IF (IWORK(I).LT.0) THEN
    199. 

  199. C                     PRINT *,'MINIMA 400',I,IWORK(I),NPTS
    200. 

  200. C                 END IF
    201. 

  201.                   IWORK(I)  = IWORK(I) - MIN
    202. 

  202.   400         CONTINUE
    203. 

  203.               REFNCE  = MIN
    204. 

  204.               IDIFF   = MAX - MIN
    205. 

  205. C             PRINT *,'REFERENCE VALUE',REFNCE
    206. 

  206. C
    207. 

  207. C             WRITE (6,FMT='(''  MINIMA REMOVED      = '',/,
    208. 

  208. C    &              10(3X,10I10,/))') (IWORK(I),I=1,6)
    209. 

  209. C             WRITE (6,FMT='(''  END OF ARRAY  = '',/,
    210. 

  210. C    &              10(3X,10I10,/))') (IWORK(I),I=NPTS-5,NPTS)
    211. 

  211. C
    212. 

  212. C                      FIND BIT WIDTH OF IDIFF
    213. 

  213. C
    214. 

  214.               CALL FI7505 (IDIFF,KWIDE)
    215. 

  215. C             PRINT*,'  BIT WIDTH FOR ORIGINAL DATA', KWIDE
    216. 

  216.               ISCAL2 = 0
    217. 

  217. C
    218. 

  218. C             MULTIPLICATIVE SCALE FACTOR SET TO 1
    219. 

  219. C             IN ANTICIPATION OF POSSIBLE USE IN GLAHN 2DN DIFF
    220. 

  220. C
    221. 

  221.               SCAL2 = 1.
    222. 

  222. C
    223. 

  223.           ELSE
    224. 

  224. C
    225. 

  225. C             PRINT*,'   AND FIXED BIT PACKING, IBITL = ', IBITL
    226. 

  226. C                               FIXED BIT PACKING
    227. 

  227. C                               - LENGTH OF FIELD IN IBITL
    228. 

  228. C                               - MUST BE REAL DATA
    229. 

  229. C                            FLOATING POINT INPUT
    230. 

  230. C
    231. 

  231.               RMAX  = FWORK(1)
    232. 

  232.               RMIN  = FWORK(1)
    233. 

  233.               DO 100 I = 2, NPTS
    234. 

  234.                   IF (FWORK(I).LT.RMIN) THEN
    235. 

  235.                       RMIN  = FWORK(I)
    236. 

  236.                   ELSE IF (FWORK(I).GT.RMAX) THEN
    237. 

  237.                       RMAX  = FWORK(I)
    238. 

  238.                   END IF
    239. 

  239.   100         CONTINUE
    240. 

  240.               REFNCE  = RMIN
    241. 

  241. C             PRINT *,'100 REFERENCE',REFNCE
    242. 

  242. C                             EXTRACT MINIMA
    243. 

  243.               DO 200 I = 1, NPTS
    244. 

  244.                   FWORK(I)  = FWORK(I) - RMIN
    245. 

  245.   200         CONTINUE
    246. 

  246. C             PRINT *,'REFERENCE VALUE',REFNCE
    247. 

  247. C             WRITE (6,FMT='(''  MINIMA REMOVED      = '',/,
    248. 

  248. C    &              10(3X,10F8.2,/))') (FWORK(I),I=1,6)
    249. 

  249. C             WRITE (6,FMT='(''  END OF ARRAY  = '',/,
    250. 

  250. C    &              10(3X,10F8.2,/))') (FWORK(I),I=NPTS-5,NPTS)
    251. 

  251. C                                FIND LARGEST DELTA
    252. 

  252.               IDELT  = NINT(RMAX - RMIN)
    253. 

  253. C                                DO BINARY SCALING
    254. 

  254. C                                   FIND OUT WHAT BINARY SCALE FACTOR
    255. 

  255. C                                       PERMITS CONTAINMENT OF
    256. 

  256. C                                       LARGEST DELTA
    257. 

  257.               CALL FI7505 (IDELT,IWIDE)
    258. 

  258. C
    259. 

  259. C                                   BINARY SCALING
    260. 

  260. C
    261. 

  261.               ISCAL2  = IWIDE - IBITL
    262. 

  262. C             PRINT *,'SCALING NEEDED TO FIT =',ISCAL2
    263. 

  263. C             PRINT*,'  RANGE OF  = ',IDELT
    264. 

  264. C
    265. 

  265. C                                EXPAND DATA WITH BINARY SCALING
    266. 

  266. C                                CONVERT TO INTEGER
    267. 

  267.               SCAL2  = 2.0**ISCAL2
    268. 

  268.               SCAL2  = 1./ SCAL2
    269. 

  269.               DO 600 I = 1, NPTS
    270. 

  270.                   IWORK(I)  = NINT(FWORK(I) * SCAL2)
    271. 

  271.   600         CONTINUE
    272. 

  272.               KWIDE = IBITL
    273. 

  273.           END IF
    274. 

  274. C
    275. 

  275. C  *****************************************************************
    276. 

  276. C
    277. 

  277. C           FOLLOWING IS FOR GLAHN SECOND DIFFERENCING
    278. 

  278. C           NOT STANDARD GRIB
    279. 

  279. C
    280. 

  280. C            TEST FOR SECOND DIFFERENCE PACKING
    281. 

  281. C            BASED OF SIZE OF PDS - SIZE IN FIRST 3 BYTES
    282. 

  282. C
    283. 

  283.           CALL GBYTE (PDS,IPDSIZ,0,24)
    284. 

  284.           IF (IPDSIZ.EQ.50) THEN
    285. 

  285. C             PRINT*,'  DO SECOND DIFFERENCE PACKING '
    286. 

  286. C
    287. 

  287. C                   GLAHN PACKING TO 2ND DIFFS
    288. 

  288. C
    289. 

  289. C             WRITE (6,FMT='(''  CALL TO W3FI82 WITH = '',/,
    290. 

  290. C    &                  10(3X,10I6,/))') (IWORK(I),I=1,NPTS)
    291. 

  291. C
    292. 

  292.                CALL W3FI82 (IWORK,FVAL1,FDIFF1,NPTS,PDS,IGDS)
    293. 

  293. C
    294. 

  294. C             PRINT *,'GLAHN',FVAL1,FDIFF1
    295. 

  295. C             WRITE (6,FMT='(''  OUT FROM W3FI82 WITH = '',/,
    296. 

  296. C    &                  10(3X,10I6,/))') (IWORK(I),I=1,NPTS)
    297. 

  297. C
    298. 

  298. C             MUST NOW RE-REMOVE THE MINIMUM VALUE
    299. 

  299. C             OF THE SECOND DIFFERENCES TO ASSURE
    300. 

  300. C             ALL POSITIVE NUMBERS FOR SECOND ORDER GRIB PACKING
    301. 

  301. C
    302. 

  302. C             ORIGINAL REFERENCE VALUE ADDED TO FIRST POINT
    303. 

  303. C             VALUE FROM THE 2ND DIFF PACKER TO BE ADDED
    304. 

  304. C             BACK IN WHEN THE 2ND DIFF VALUES ARE
    305. 

  305. C             RECONSTRUCTED BACK TO THE BASIC VALUES
    306. 

  306. C
    307. 

  307. C             ALSO, THE REFERENCE VALUE IS
    308. 

  308. C             POWER-OF-TWO SCALED TO MATCH
    309. 

  309. C             FVAL1.  ALL OF THIS SCALING
    310. 

  310. C             WILL BE REMOVED AFTER THE
    311. 

  311. C             GLAHN SECOND DIFFERENCING IS UNDONE.
    312. 

  312. C             THE SCALING FACTOR NEEDED TO DO THAT
    313. 

  313. C             IS SAVED IN THE PDS AS A SIGNED POSITIVE
    314. 

  314. C             TWO BYTE INTEGER
    315. 

  315. C
    316. 

  316. C             THE SCALING FOR THE 2ND DIF PACKED
    317. 

  317. C             VALUES IS PROPERLY SET TO ZERO
    318. 

  318. C
    319. 

  319.               FVAL1 = FVAL1 + REFNCE*SCAL2
    320. 

  320. C                                          FIRST TEST TO SEE IF
    321. 

  321. C                                          ON 32 OR 64 BIT COMPUTER
    322. 

  322.               CALL W3FI01(LW)
    323. 

  323.               IF (LW.EQ.4) THEN
    324. 

  324.                   CALL W3FI76 (FVAL1,IEXP,IMANT,32)
    325. 

  325.               ELSE
    326. 

  326.                   CALL W3FI76 (FVAL1,IEXP,IMANT,64)
    327. 

  327.               END IF
    328. 

  328.               CALL SBYTE (PDS,IEXP,320,8)
    329. 

  329.               CALL SBYTE (PDS,IMANT,328,24)
    330. 

  330. C
    331. 

  331.               IF (LW.EQ.4) THEN
    332. 

  332.                   CALL W3FI76 (FDIFF1,IEXP,IMANT,32)
    333. 

  333.               ELSE
    334. 

  334.                   CALL W3FI76 (FDIFF1,IEXP,IMANT,64)
    335. 

  335.               END IF
    336. 

  336.               CALL SBYTE (PDS,IEXP,352,8)
    337. 

  337.               CALL SBYTE (PDS,IMANT,360,24)
    338. 

  338. C
    339. 

  339. C             TURN ISCAL2 INTO SIGNED POSITIVE INTEGER
    340. 

  340. C             AND STORE IN TWO BYTES
    341. 

  341. C
    342. 

  342.               IF(ISCAL2.GE.0)  THEN
    343. 

  343.                 CALL SBYTE (PDS,ISCAL2,384,16)
    344. 

  344.               ELSE
    345. 

  345.                 CALL SBYTE (PDS,1,384,1)
    346. 

  346.                 ISCAL2 = - ISCAL2
    347. 

  347.                 CALL SBYTE( PDS,ISCAL2,385,15)
    348. 

  348.               ENDIF
    349. 

  349. C
    350. 

  350.               MAX  = IWORK(1)
    351. 

  351.               MIN  = IWORK(1)
    352. 

  352.               DO 700 I = 2, NPTS
    353. 

  353.                   IF (IWORK(I).LT.MIN) THEN
    354. 

  354.                       MIN  = IWORK(I)
    355. 

  355.                   ELSE IF (IWORK(I).GT.MAX) THEN
    356. 

  356.                       MAX  = IWORK(I)
    357. 

  357.                   END IF
    358. 

  358.   700         CONTINUE
    359. 

  359. C                           EXTRACT MINIMA
    360. 

  360.               DO 710 I = 1, NPTS
    361. 

  361.                   IWORK(I)  = IWORK(I) - MIN
    362. 

  362.   710         CONTINUE
    363. 

  363.               REFNCE  = MIN
    364. 

  364. C             PRINT *,'710 REFERENCE',REFNCE
    365. 

  365.               ISCAL2 = 0
    366. 

  366. C
    367. 

  367. C             AND RESET VALUE OF KWIDE - THE BIT WIDTH
    368. 

  368. C             FOR THE RANGE OF THE VALUES
    369. 

  369. C
    370. 

  370.               IDIFF = MAX - MIN
    371. 

  371.               CALL FI7505 (IDIFF,KWIDE)
    372. 

  372. C
    373. 

  373. C             PRINT*,'BIT WIDTH (KWIDE) OF 2ND DIFFS', KWIDE
    374. 

  374. C
    375. 

  375. C  **************************** END OF GLAHN PACKING  ************
    376. 

  376.           ELSE IF (IBDSFL(2).EQ.1.AND.IBDSFL(7).EQ.0) THEN
    377. 

  377. C                        HAVE SECOND ORDER PACKING WITH NO SECOND ORDER
    378. 

  378. C                        BIT MAP. ERGO ROW BY ROW - COL BY COL
    379. 

  379.               CALL FI7503 (IWORK,IPFLD,NPTS,IBDSFL,BDS11,
    380. 

  380.      *              LEN,LENBDS,PDS,REFNCE,ISCAL2,KWIDE,IGDS)
    381. 

  381.               RETURN
    382. 

  382.           END IF
    383. 

  383. C         WRITE (6,FMT='(''  CALL TO FI7501 WITH = '',/,
    384. 

  384. C    &                  10(3X,10I6,/))') (IWORK(I),I=1,NPTS)
    385. 

  385. C         WRITE (6,FMT='(''  END OF ARRAY = '',/,
    386. 

  386. C    &                  10(3X,10I6,/))') (IWORK(I),I=NPTS-5,NPTS)
    387. 

  387. C         PRINT*,' REFNCE,ISCAL2, KWIDE AT CALL TO FI7501',
    388. 

  388. C    &             REFNCE, ISCAL2,KWIDE
    389. 

  389. C
    390. 

  390. C                         SECOND ORDER PACKING
    391. 

  391. C
    392. 

  392.           CALL FI7501 (IWORK,IPFLD,NPTS,IBDSFL,BDS11,
    393. 

  393.      *             LEN,LENBDS,PDS,REFNCE,ISCAL2,KWIDE)
    394. 

  394. C
    395. 

  395. C              BDS COMPLETELY ASSEMBLED IN FI7501 FOR SECOND ORDER
    396. 

  396. C              PACKING.
    397. 

  397. C
    398. 

  398.       ELSE
    399. 

  399. C                                      SIMPLE PACKING
    400. 

  400. C
    401. 

  401. C                PRINT*,'  SIMPLE FIRST ORDER PACKING...'
    402. 

  402.           IF (IBITL.EQ.0) THEN
    403. 

  403. C                PRINT*,' WITH VARIABLE BIT LENGTH'
    404. 

  404. C
    405. 

  405. C                  WITH VARIABLE BIT LENGTH, ADJUSTED
    406. 

  406. C                  TO ACCOMMODATE LARGEST VALUE
    407. 

  407. C                  BINARY SCALING ALWAYS = 0
    408. 

  408. C
    409. 

  409.               CALL W3FI58(IWORK,NPTS,IWORK,PFLD,NBITS,LEN,KMIN)
    410. 

  410.               RMIN   = KMIN
    411. 

  411.               REFNCE  = RMIN
    412. 

  412.               ISCALE = 0
    413. 

  413. C             PRINT*,'  BIT LENGTH CAME OUT AT ...',NBITS
    414. 

  414. C
    415. 

  415. C           SET CONST .TRUE. IF ALL VALUES ARE THE SAME
    416. 

  416. C
    417. 

  417.               IF (LEN.EQ.0.AND.NBITS.EQ.0) CONST = .TRUE.
    418. 

  418. C
    419. 

  419.           ELSE
    420. 

  420. C           PRINT*,' FIXED BIT LENGTH, IBITL = ', IBITL
    421. 

  421. C
    422. 

  422. C             FIXED BIT LENGTH PACKING (VARIABLE PRECISION)
    423. 

  423. C             VALUES SCALED BY POWER OF 2 (ISCALE) TO
    424. 

  424. C             FIT LARGEST VALUE INTO GIVEN BIT LENGTH (IBITL)
    425. 

  425. C
    426. 

  426.               CALL W3FI59(FWORK,NPTS,IBITL,IWORK,PFLD,ISCALE,LEN,RMIN)
    427. 

  427.               REFNCE = RMIN
    428. 

  428. C             PRINT *,' SCALING NEEDED TO FIT IS ...', ISCALE
    429. 

  429.               NBITS = IBITL
    430. 

  430. C
    431. 

  431. C           SET CONST .TRUE. IF ALL VALUES ARE THE SAME
    432. 

  432. C
    433. 

  433.               IF (LEN.EQ.0) THEN
    434. 

  434.                   CONST = .TRUE.
    435. 

  435.                   NBITS = 0
    436. 

  436.               END IF
    437. 

  437.           END IF
    438. 

  438. C
    439. 

  439. C         COMPUTE LENGTH OF BDS IN OCTETS
    440. 

  440. C
    441. 

  441.           INUM  = NPTS * NBITS + 88
    442. 

  442. C         PRINT *,'NUMBER OF BITS BEFORE FILL ADDED',INUM
    443. 

  443. C
    444. 

  444. C                  NUMBER OF FILL BITS
    445. 

  445.           NFILL  = 0
    446. 

  446.           NLEFT  = MOD(INUM,16)
    447. 

  447.           IF (NLEFT.NE.0) THEN
    448. 

  448.               INUM  = INUM + 16 - NLEFT
    449. 

  449.               NFILL = 16 - NLEFT
    450. 

  450.           END IF
    451. 

  451. C         PRINT *,'NUMBER OF BITS AFTER FILL ADDED',INUM
    452. 

  452. C                  LENGTH OF BDS IN BYTES
    453. 

  453.           LENBDS = INUM / 8
    454. 

  454. C
    455. 

  455. C                2.0   FORM THE BINARY DATA SECTION (BDS).
    456. 

  456. C
    457. 

  457. C                 CONCANTENATE ALL FIELDS FOR BDS
    458. 

  458. C
    459. 

  459. C                               BYTES 1-3
    460. 

  460.           CALL SBYTE (BDS11,LENBDS,0,24)
    461. 

  461. C
    462. 

  462. C                               BYTE  4
    463. 

  463. C                                       FLAGS
    464. 

  464.           CALL SBYTE (BDS11,IBDSFL(1),24,1)
    465. 

  465.           CALL SBYTE (BDS11,IBDSFL(2),25,1)
    466. 

  466.           CALL SBYTE (BDS11,IBDSFL(3),26,1)
    467. 

  467.           CALL SBYTE (BDS11,IBDSFL(4),27,1)
    468. 

  468. C                                        NR OF FILL BITS
    469. 

  469.           CALL SBYTE (BDS11,NFILL,28,4)
    470. 

  470. C
    471. 

  471. C       FILL OCTETS 5-6 WITH THE SCALE FACTOR.
    472. 

  472. C
    473. 

  473. C                               BYTE  5-6
    474. 

  474.           IF (ISCALE.LT.0) THEN
    475. 

  475.               CALL SBYTE (BDS11,1,32,1)
    476. 

  476.               ISCALE  = - ISCALE
    477. 

  477.               CALL SBYTE (BDS11,ISCALE,33,15)
    478. 

  478.           ELSE
    479. 

  479.               CALL SBYTE (BDS11,ISCALE,32,16)
    480. 

  480.           END IF
    481. 

  481. C
    482. 

  482. C   FILL OCTET 7-10 WITH THE REFERENCE VALUE
    483. 

  483. C   CONVERT THE FLOATING POINT OF YOUR MACHINE TO IBM370 32 BIT
    484. 

  484. C   FLOATING POINT NUMBER
    485. 

  485. C
    486. 

  486. C                               BYTE  7-10
    487. 

  487. C                                        REFERENCE VALUE
    488. 

  488. C                                          FIRST TEST TO SEE IF
    489. 

  489. C                                          ON 32 OR 64 BIT COMPUTER
    490. 

  490.           CALL W3FI01(LW)
    491. 

  491.           IF (LW.EQ.4) THEN
    492. 

  492.               CALL W3FI76 (REFNCE,IEXP,IMANT,32)
    493. 

  493.           ELSE
    494. 

  494.               CALL W3FI76 (REFNCE,IEXP,IMANT,64)
    495. 

  495.           END IF
    496. 

  496.           CALL SBYTE (BDS11,IEXP,48,8)
    497. 

  497.           CALL SBYTE (BDS11,IMANT,56,24)
    498. 

  498. C
    499. 

  499. C
    500. 

  500. C                         FILL OCTET 11 WITH THE NUMBER OF BITS.
    501. 

  501. C
    502. 

  502. C                               BYTE  11
    503. 

  503.           CALL SBYTE (BDS11,NBITS,80,8)
    504. 

  504.       END IF
    505. 

  505. C
    506. 

  506.       RETURN
    507. 

  507.       END
    508. 

  508.       SUBROUTINE FI7501 (IWORK,IPFLD,NPTS,IBDSFL,BDS11,
    509. 

  509.      *           LEN,LENBDS,PDS,REFNCE,ISCAL2,KWIDE)
    510. 

  510. C $$  SUBPROGRAM DOCUMENTATION BLOCK
    511. 

  511. C                .      .    .                                       .
    512. 

  512. C SUBPROGRAM:    FI7501      BDS SECOND ORDER PACKING
    513. 

  513. C   PRGMMR: CAVANAUGH        ORG: W/NMC42    DATE: 93-08-06
    514. 

  514. C
    515. 

  515. C ABSTRACT: PERFORM SECONDARY PACKING ON GRID POINT DATA,
    516. 

  516. C   GENERATING ALL BDS INFORMATION.
    517. 

  517. C
    518. 

  518. C PROGRAM HISTORY LOG:
    519. 

  519. C   93-08-06  CAVANAUGH
    520. 

  520. C   93-12-15  CAVANAUGH   CORRECTED LOCATION OF START OF FIRST ORDER
    521. 

  521. C                         VALUES AND START OF SECOND ORDER VALUES TO
    522. 

  522. C                         REFLECT A BYTE LOCATION IN THE BDS INSTEAD
    523. 

  523. C                         OF AN OFFSET.
    524. 

  524. C   95-10-31  IREDELL     REMOVED SAVES AND PRINTS
    525. 

  525. C
    526. 

  526. C USAGE:    CALL FI7501 (IWORK,IPFLD,NPTS,IBDSFL,BDS11,
    527. 

  527. C    *           LEN,LENBDS,PDS,REFNCE,ISCAL2,KWIDE)
    528. 

  528. C   INPUT ARGUMENT LIST:
    529. 

  529. C     IWORK    - INTEGER SOURCE ARRAY
    530. 

  530. C     NPTS     - NUMBER OF POINTS IN IWORK
    531. 

  531. C     IBDSFL   - FLAGS
    532. 

  532. C
    533. 

  533. C   OUTPUT ARGUMENT LIST:      (INCLUDING WORK ARRAYS)
    534. 

  534. C     IPFLD    - CONTAINS BDS FROM BYTE 12 ON
    535. 

  535. C     BDS11    - CONTAINS FIRST 11 BYTES FOR BDS
    536. 

  536. C     LEN      - NUMBER OF BYTES FROM 12 ON
    537. 

  537. C     LENBDS   - TOTAL LENGTH OF BDS
    538. 

  538. C
    539. 

  539. C REMARKS: SUBPROGRAM CAN BE CALLED FROM A MULTIPROCESSING ENVIRONMENT.
    540. 

  540. C
    541. 

  541. C ATTRIBUTES:
    542. 

  542. C   LANGUAGE: IBM VS FORTRAN 77, CRAY CFT77 FORTRAN
    543. 

  543. C   MACHINE:  HDS, CRAY C916/256, Y-MP8/64, Y-MP EL92/256
    544. 

  544. C
    545. 

  545. C $$
    546. 

  546.       CHARACTER*1     BDS11(*),PDS(*)
    547. 

  547. C
    548. 

  548.       REAL            REFNCE
    549. 

  549. C
    550. 

  550.       INTEGER         ISCAL2,KWIDE
    551. 

  551.       INTEGER         LENBDS
    552. 

  552.       INTEGER         IPFLD(*)
    553. 

  553.       INTEGER         LEN,KBDS(22)
    554. 

  554.       INTEGER         IWORK(*)
    555. 

  555. C                        OCTET NUMBER IN SECTION, FIRST ORDER PACKING
    556. 

  556. C     INTEGER         KBDS(12)
    557. 

  557. C                        FLAGS
    558. 

  558.       INTEGER         IBDSFL(*)
    559. 

  559. C                        EXTENDED FLAGS
    560. 

  560. C     INTEGER         KBDS(14)
    561. 

  561. C                        OCTET NUMBER FOR SECOND ORDER PACKING
    562. 

  562. C     INTEGER         KBDS(15)
    563. 

  563. C                        NUMBER OF FIRST ORDER VALUES
    564. 

  564. C     INTEGER         KBDS(17)
    565. 

  565. C                        NUMBER OF SECOND ORDER PACKED VALUES
    566. 

  566. C     INTEGER         KBDS(19)
    567. 

  567. C                        WIDTH OF SECOND ORDER PACKING
    568. 

  568.       INTEGER         ISOWID(50000)
    569. 

  569. C                        SECONDARY BIT MAP
    570. 

  570.       INTEGER         ISOBMP(8200)
    571. 

  571. C                        FIRST ORDER PACKED VALUES
    572. 

  572.       INTEGER         IFOVAL(50000)
    573. 

  573. C                        SECOND ORDER PACKED VALUES
    574. 

  574.       INTEGER         ISOVAL(100000)
    575. 

  575. C
    576. 

  576. C     INTEGER         KBDS(11)
    577. 

  577. C                        BIT WIDTH TABLE
    578. 

  578.       INTEGER         IBITS(31)
    579. 

  579. C
    580. 

  580.       DATA            IBITS/1,3,7,15,31,63,127,255,511,1023,
    581. 

  581.      *                      2047,4095,8191,16383,32767,65535,131072,
    582. 

  582.      *                      262143,524287,1048575,2097151,4194303,
    583. 

  583.      *                      8388607,16777215,33554431,67108863,
    584. 

  584.      *                      134217727,268435455,536870911,
    585. 

  585.      *                      1073741823,2147483647/
    586. 

  586. C  ----------------------------------
    587. 

  587. C                       INITIALIZE ARRAYS
    588. 

  588.       DO 100 I = 1, 50000
    589. 

  589.           ISOWID(I)  = 0
    590. 

  590.           IFOVAL(I)  = 0
    591. 

  591.   100 CONTINUE
    592. 

  592. C
    593. 

  593.       DO 101 I = 1, 8200
    594. 

  594.           ISOBMP(I)  = 0
    595. 

  595.   101 CONTINUE
    596. 

  596.       DO 102 I = 1, 100000
    597. 

  597.           ISOVAL(I)  = 0
    598. 

  598.   102 CONTINUE
    599. 

  599. C                      INITIALIZE POINTERS
    600. 

  600. C                            SECONDARY BIT WIDTH POINTER
    601. 

  601.       IWDPTR  = 0
    602. 

  602. C                            SECONDARY BIT MAP POINTER
    603. 

  603.       IBMP2P  = 0
    604. 

  604. C                            FIRST ORDER VALUE POINTER
    605. 

  605.       IFOPTR  = 0
    606. 

  606. C                            BYTE POINTER TO START OF 1ST ORDER VALUES
    607. 

  607.       KBDS(12)  = 0
    608. 

  608. C                            BYTE POINTER TO START OF 2ND ORDER VALUES
    609. 

  609.       KBDS(15)  = 0
    610. 

  610. C                            TO CONTAIN NUMBER OF FIRST ORDER VALUES
    611. 

  611.       KBDS(17)  = 0
    612. 

  612. C                            TO CONTAIN NUMBER OF SECOND ORDER VALUES
    613. 

  613.       KBDS(19)  = 0
    614. 

  614. C                            SECOND ORDER PACKED VALUE POINTER
    615. 

  615.       ISOPTR  = 0
    616. 

  616. C  =======================================================
    617. 

  617. C
    618. 

  618. C                         DATA IS IN IWORK
    619. 

  619. C
    620. 

  620.       KBDS(11)  = KWIDE
    621. 

  621. C
    622. 

  622. C       DATA PACKING
    623. 

  623. C
    624. 

  624.       ITER    = 0
    625. 

  625.       INEXT   = 1
    626. 

  626.       ISTART  = 1
    627. 

  627. C  -----------------------------------------------------------
    628. 

  628.       KOUNT = 0
    629. 

  629. C     DO 1 I = 1, NPTS, 10
    630. 

  630. C         PRINT *,I,(IWORK(K),K=I, I+9)
    631. 

  631. C   1 CONTINUE
    632. 

  632.  2000 CONTINUE
    633. 

  633.       ITER  = ITER + 1
    634. 

  634. C     PRINT *,'NEXT ITERATION STARTS AT',ISTART
    635. 

  635.        IF (ISTART.GT.NPTS) THEN
    636. 

  636.            GO TO 4000
    637. 

  637.        ELSE IF (ISTART.EQ.NPTS) THEN
    638. 

  638.            KPTS    = 1
    639. 

  639.            MXDIFF  = 0
    640. 

  640.            GO TO 2200
    641. 

  641.        END IF
    642. 

  642. C
    643. 

  643. C                     LOOK FOR REPITITIONS OF A SINGLE VALUE
    644. 

  644.        CALL FI7502 (IWORK,ISTART,NPTS,ISAME)
    645. 

  645.        IF (ISAME.GE.15) THEN
    646. 

  646.            KOUNT = KOUNT + 1
    647. 

  647. C          PRINT *,'FI7501 - FOUND IDENTICAL SET OF ',ISAME
    648. 

  648.            MXDIFF  = 0
    649. 

  649.            KPTS    = ISAME
    650. 

  650.        ELSE
    651. 

  651. C
    652. 

  652. C                     LOOK FOR SETS OF VALUES IN TREND SELECTED RANGE
    653. 

  653.            CALL FI7513 (IWORK,ISTART,NPTS,NMAX,NMIN,INRNGE)
    654. 

  654. C          PRINT *,'ISTART  ',ISTART,' INRNGE',INRNGE,NMAX,NMIN
    655. 

  655.            IEND  = ISTART + INRNGE - 1
    656. 

  656. C          DO 2199 NM = ISTART, IEND, 10
    657. 

  657. C              PRINT *,'  ',(IWORK(NM+JK),JK=0,9)
    658. 

  658. C2199      CONTINUE
    659. 

  659.            MXDIFF  = NMAX - NMIN
    660. 

  660.            KPTS    = INRNGE
    661. 

  661.        END IF
    662. 

  662.  2200 CONTINUE
    663. 

  663. C     PRINT *,'                 RANGE ',MXDIFF,' MAX',NMAX,' MIN',NMIN
    664. 

  664. C                 INCREMENT NUMBER OF FIRST ORDER VALUES
    665. 

  665.       KBDS(17)  = KBDS(17) + 1
    666. 

  666. C                 ENTER FIRST ORDER VALUE
    667. 

  667.       IF (MXDIFF.GT.0) THEN
    668. 

  668.           DO 2220 LK = 0, KPTS-1
    669. 

  669.               IWORK(ISTART+LK)  = IWORK(ISTART+LK) - NMIN
    670. 

  670.  2220     CONTINUE
    671. 

  671.           CALL SBYTE (IFOVAL,NMIN,IFOPTR,KBDS(11))
    672. 

  672.       ELSE
    673. 

  673.           CALL SBYTE (IFOVAL,IWORK(ISTART),IFOPTR,KBDS(11))
    674. 

  674.       END IF
    675. 

  675.       IFOPTR  = IFOPTR + KBDS(11)
    676. 

  676. C                  PROCESS SECOND ORDER BIT WIDTH
    677. 

  677.       IF (MXDIFF.GT.0) THEN
    678. 

  678.           DO 2330 KWIDE = 1, 31
    679. 

  679.               IF (MXDIFF.LE.IBITS(KWIDE)) THEN
    680. 

  680.                   GO TO 2331
    681. 

  681.               END IF
    682. 

  682.  2330     CONTINUE
    683. 

  683.  2331     CONTINUE
    684. 

  684.       ELSE
    685. 

  685.           KWIDE  = 0
    686. 

  686.       END IF
    687. 

  687.       CALL SBYTE (ISOWID,KWIDE,IWDPTR,8)
    688. 

  688.       IWDPTR  = IWDPTR + 8
    689. 

  689. C         PRINT *,KWIDE,' IFOVAL=',NMIN,IWORK(ISTART),KPTS
    690. 

  690. C               IF KWIDE NE 0, SAVE SECOND ORDER VALUE
    691. 

  691.       IF (KWIDE.GT.0) THEN
    692. 

  692.           CALL SBYTES (ISOVAL,IWORK(ISTART),ISOPTR,KWIDE,0,KPTS)
    693. 

  693.           ISOPTR  = ISOPTR + KPTS * KWIDE
    694. 

  694.           KBDS(19)  = KBDS(19) + KPTS
    695. 

  695. C         PRINT *,'            SECOND ORDER VALUES'
    696. 

  696. C         PRINT *,(IWORK(ISTART+I),I=0,KPTS-1)
    697. 

  697.       END IF
    698. 

  698. C                 ADD TO SECOND ORDER BITMAP
    699. 

  699.       CALL SBYTE (ISOBMP,1,IBMP2P,1)
    700. 

  700.       IBMP2P  = IBMP2P + KPTS
    701. 

  701.       ISTART  = ISTART + KPTS
    702. 

  702.       GO TO 2000
    703. 

  703. C  --------------------------------------------------------------
    704. 

  704.  4000 CONTINUE
    705. 

  705. C     PRINT *,'THERE WERE ',ITER,' SECOND ORDER GROUPS'
    706. 

  706. C     PRINT *,'THERE WERE ',KOUNT,' STRINGS OF CONSTANTS'
    707. 

  707. C                 CONCANTENATE ALL FIELDS FOR BDS
    708. 

  708. C
    709. 

  709. C                   REMAINDER GOES INTO IPFLD
    710. 

  710.       IPTR  = 0
    711. 

  711. C                               BYTES 12-13
    712. 

  712. C                                          VALUE FOR N1
    713. 

  713. C                                          LEAVE SPACE FOR THIS
    714. 

  714.       IPTR   = IPTR + 16
    715. 

  715. C                               BYTE 14
    716. 

  716. C                                          EXTENDED FLAGS
    717. 

  717.       CALL SBYTE (IPFLD,IBDSFL(5),IPTR,1)
    718. 

  718.       IPTR  = IPTR + 1
    719. 

  719.       CALL SBYTE (IPFLD,IBDSFL(6),IPTR,1)
    720. 

  720.       IPTR  = IPTR + 1
    721. 

  721.       CALL SBYTE (IPFLD,IBDSFL(7),IPTR,1)
    722. 

  722.       IPTR  = IPTR + 1
    723. 

  723.       CALL SBYTE (IPFLD,IBDSFL(8),IPTR,1)
    724. 

  724.       IPTR  = IPTR + 1
    725. 

  725.       CALL SBYTE (IPFLD,IBDSFL(9),IPTR,1)
    726. 

  726.       IPTR  = IPTR + 1
    727. 

  727.       CALL SBYTE (IPFLD,IBDSFL(10),IPTR,1)
    728. 

  728.       IPTR  = IPTR + 1
    729. 

  729.       CALL SBYTE (IPFLD,IBDSFL(11),IPTR,1)
    730. 

  730.       IPTR  = IPTR + 1
    731. 

  731.       CALL SBYTE (IPFLD,IBDSFL(12),IPTR,1)
    732. 

  732.       IPTR  = IPTR + 1
    733. 

  733. C                               BYTES 15-16
    734. 

  734. C                 SKIP OVER VALUE  FOR N2
    735. 

  735.       IPTR  = IPTR + 16
    736. 

  736. C                               BYTES 17-18
    737. 

  737. C                                     P1
    738. 

  738.       CALL SBYTE (IPFLD,KBDS(17),IPTR,16)
    739. 

  739.       IPTR  = IPTR + 16
    740. 

  740. C                               BYTES 19-20
    741. 

  741. C                                   P2
    742. 

  742.       CALL SBYTE (IPFLD,KBDS(19),IPTR,16)
    743. 

  743.       IPTR  = IPTR + 16
    744. 

  744. C                               BYTE 21 - RESERVED LOCATION
    745. 

  745.       CALL SBYTE (IPFLD,0,IPTR,8)
    746. 

  746.       IPTR  = IPTR + 8
    747. 

  747. C                               BYTES 22 - ?
    748. 

  748. C                                      WIDTHS OF SECOND ORDER PACKING
    749. 

  749.       IX    = (IWDPTR + 32) / 32
    750. 

  750.       CALL SBYTES (IPFLD,ISOWID,IPTR,32,0,IX)
    751. 

  751.       IPTR  = IPTR + IWDPTR
    752. 

  752. C                                      SECONDARY BIT MAP
    753. 

  753.       IJ    = (IBMP2P + 32) / 32
    754. 

  754.       CALL SBYTES (IPFLD,ISOBMP,IPTR,32,0,IJ)
    755. 

  755.       IPTR  = IPTR + IBMP2P
    756. 

  756.       IF (MOD(IPTR,8).NE.0) THEN
    757. 

  757.           IPTR  = IPTR + 8 - MOD(IPTR,8)
    758. 

  758.       END IF
    759. 

  759. C                                         DETERMINE LOCATION FOR START
    760. 

  760. C                                         OF FIRST ORDER PACKED VALUES
    761. 

  761.       KBDS(12)  = IPTR / 8 + 12
    762. 

  762. C                                        STORE LOCATION
    763. 

  763.       CALL SBYTE (IPFLD,KBDS(12),0,16)
    764. 

  764. C                                     MOVE IN FIRST ORDER PACKED VALUES
    765. 

  765.       IPASS   = (IFOPTR + 32) / 32
    766. 

  766.       CALL SBYTES (IPFLD,IFOVAL,IPTR,32,0,IPASS)
    767. 

  767.       IPTR  = IPTR + IFOPTR
    768. 

  768.       IF (MOD(IPTR,8).NE.0) THEN
    769. 

  769.           IPTR  = IPTR + 8 - MOD(IPTR,8)
    770. 

  770.       END IF
    771. 

  771. C     PRINT *,'IFOPTR =',IFOPTR,' ISOPTR =',ISOPTR
    772. 

  772. C                DETERMINE LOCATION FOR START
    773. 

  773. C                     OF SECOND ORDER VALUES
    774. 

  774.       KBDS(15)  = IPTR / 8 + 12
    775. 

  775. C                                   SAVE LOCATION OF SECOND ORDER VALUES
    776. 

  776.       CALL SBYTE (IPFLD,KBDS(15),24,16)
    777. 

  777. C                  MOVE IN SECOND ORDER PACKED VALUES
    778. 

  778.       IX    = (ISOPTR + 32) / 32
    779. 

  779.       CALL SBYTES (IPFLD,ISOVAL,IPTR,32,0,IX)
    780. 

  780.       IPTR  = IPTR + ISOPTR
    781. 

  781.       NLEFT  = MOD(IPTR+88,16)
    782. 

  782.       IF (NLEFT.NE.0) THEN
    783. 

  783.           NLEFT  = 16 - NLEFT
    784. 

  784.           IPTR   = IPTR + NLEFT
    785. 

  785.       END IF
    786. 

  786. C                                COMPUTE LENGTH OF DATA PORTION
    787. 

  787.       LEN     = IPTR / 8
    788. 

  788. C                                    COMPUTE LENGTH OF BDS
    789. 

  789.       LENBDS  = LEN + 11
    790. 

  790. C  -----------------------------------
    791. 

  791. C                               BYTES 1-3
    792. 

  792. C                                   THIS FUNCTION COMPLETED BELOW
    793. 

  793. C                                   WHEN LENGTH OF BDS IS KNOWN
    794. 

  794.       CALL SBYTE (BDS11,LENBDS,0,24)
    795. 

  795. C                               BYTE  4
    796. 

  796.       CALL SBYTE (BDS11,IBDSFL(1),24,1)
    797. 

  797.       CALL SBYTE (BDS11,IBDSFL(2),25,1)
    798. 

  798.       CALL SBYTE (BDS11,IBDSFL(3),26,1)
    799. 

  799.       CALL SBYTE (BDS11,IBDSFL(4),27,1)
    800. 

  800. C                              ENTER NUMBER OF FILL BITS
    801. 

  801.       CALL SBYTE (BDS11,NLEFT,28,4)
    802. 

  802. C                               BYTE  5-6
    803. 

  803.       IF (ISCAL2.LT.0) THEN
    804. 

  804.           CALL SBYTE (BDS11,1,32,1)
    805. 

  805.           ISCAL2 = - ISCAL2
    806. 

  806.       ELSE
    807. 

  807.           CALL SBYTE (BDS11,0,32,1)
    808. 

  808.       END IF
    809. 

  809.       CALL SBYTE (BDS11,ISCAL2,33,15)
    810. 

  810. C
    811. 

  811. C   FILL OCTET 7-10 WITH THE REFERENCE VALUE
    812. 

  812. C   CONVERT THE FLOATING POINT OF YOUR MACHINE TO IBM370 32 BIT
    813. 

  813. C   FLOATING POINT NUMBER
    814. 

  814. C                                        REFERENCE VALUE
    815. 

  815. C                                          FIRST TEST TO SEE IF
    816. 

  816. C                                          ON 32 OR 64 BIT COMPUTER
    817. 

  817.           CALL W3FI01(LW)
    818. 

  818.           IF (LW.EQ.4) THEN
    819. 

  819.               CALL W3FI76 (REFNCE,IEXP,IMANT,32)
    820. 

  820.           ELSE
    821. 

  821.               CALL W3FI76 (REFNCE,IEXP,IMANT,64)
    822. 

  822.           END IF
    823. 

  823.           CALL SBYTE (BDS11,IEXP,48,8)
    824. 

  824.           CALL SBYTE (BDS11,IMANT,56,24)
    825. 

  825. C
    826. 

  826. C                               BYTE  11
    827. 

  827. C
    828. 

  828.       CALL SBYTE (BDS11,KBDS(11),80,8)
    829. 

  829. C
    830. 

  830.       RETURN
    831. 

  831.       END
    832. 

  832.       SUBROUTINE FI7502 (IWORK,ISTART,NPTS,ISAME)
    833. 

  833. C $$  SUBPROGRAM DOCUMENTATION BLOCK
    834. 

  834. C                .      .    .                                       .
    835. 

  835. C SUBPROGRAM:    FI7502      SECOND ORDER SAME VALUE COLLECTION
    836. 

  836. C   PRGMMR: CAVANAUGH        ORG: W/NMC42    DATE: 93-06-23
    837. 

  837. C
    838. 

  838. C ABSTRACT: COLLECT SEQUENTIAL SAME VALUES FOR PROCESSING
    839. 

  839. C   AS SECOND ORDER VALUE FOR GRIB MESSAGES.
    840. 

  840. C
    841. 

  841. C PROGRAM HISTORY LOG:
    842. 

  842. C   93-06-23  CAVANAUGH
    843. 

  843. C   95-10-31  IREDELL     REMOVED SAVES AND PRINTS
    844. 

  844. C
    845. 

  845. C USAGE:    CALL FI7502 (IWORK,ISTART,NPTS,ISAME)
    846. 

  846. C   INPUT ARGUMENT LIST:
    847. 

  847. C     IWORK    - ARRAY CONTAINING SOURCE DATA
    848. 

  848. C     ISTART   - STARTING LOCATION FOR THIS TEST
    849. 

  849. C     NPTS     - NUMBER OF POINTS IN IWORK
    850. 

  850. C
    851. 

  851. C   OUTPUT ARGUMENT LIST:      (INCLUDING WORK ARRAYS)
    852. 

  852. C     ISAME    - NUMBER OF SEQUENTIAL POINTS HAVING THE SAME VALUE
    853. 

  853. C
    854. 

  854. C REMARKS: SUBPROGRAM CAN BE CALLED FROM A MULTIPROCESSING ENVIRONMENT.
    855. 

  855. C
    856. 

  856. C ATTRIBUTES:
    857. 

  857. C   LANGUAGE: IBM VS FORTRAN 77, CRAY CFT77 FORTRAN
    858. 

  858. C   MACHINE:  HDS, CRAY C916/256, Y-MP8/64, Y-MP EL92/256
    859. 

  859. C
    860. 

  860. C $$
    861. 

  861.       INTEGER        IWORK(*)
    862. 

  862.       INTEGER        ISTART
    863. 

  863.       INTEGER        ISAME
    864. 

  864.       INTEGER        K
    865. 

  865.       INTEGER        NPTS
    866. 

  866. C  -------------------------------------------------------------
    867. 

  867.       ISAME  = 0
    868. 

  868.       DO 100 K = ISTART, NPTS
    869. 

  869.           IF (IWORK(K).NE.IWORK(ISTART)) THEN
    870. 

  870.               RETURN
    871. 

  871.           END IF
    872. 

  872.           ISAME  = ISAME + 1
    873. 

  873.   100 CONTINUE
    874. 

  874.       RETURN
    875. 

  875.       END
    876. 

  876.       SUBROUTINE FI7503 (IWORK,IPFLD,NPTS,IBDSFL,BDS11,
    877. 

  877.      *           LEN,LENBDS,PDS,REFNCE,ISCAL2,KWIDE,IGDS)
    878. 

  878. C $$  SUBPROGRAM DOCUMENTATION BLOCK
    879. 

  879. C                .      .    .                                       .
    880. 

  880. C SUBPROGRAM:    FI7501      ROW BY ROW, COL BY COL PACKING
    881. 

  881. C   PRGMMR: CAVANAUGH        ORG: W/NMC42    DATE: 94-05-20
    882. 

  882. C
    883. 

  883. C ABSTRACT: PERFORM ROW BY ROW OR COLUMN BY COLUMN PACKING
    884. 

  884. C   GENERATING ALL BDS INFORMATION.
    885. 

  885. C
    886. 

  886. C PROGRAM HISTORY LOG:
    887. 

  887. C   93-08-06  CAVANAUGH
    888. 

  888. C   95-10-31  IREDELL     REMOVED SAVES AND PRINTS
    889. 

  889. C
    890. 

  890. C USAGE:    CALL FI7503 (IWORK,IPFLD,NPTS,IBDSFL,BDS11,
    891. 

  891. C    *           LEN,LENBDS,PDS,REFNCE,ISCAL2,KWIDE,IGDS)
    892. 

  892. C   INPUT ARGUMENT LIST:
    893. 

  893. C     IWORK    - INTEGER SOURCE ARRAY
    894. 

  894. C     NPTS     - NUMBER OF POINTS IN IWORK
    895. 

  895. C     IBDSFL   - FLAGS
    896. 

  896. C
    897. 

  897. C   OUTPUT ARGUMENT LIST:      (INCLUDING WORK ARRAYS)
    898. 

  898. C     IPFLD    - CONTAINS BDS FROM BYTE 12 ON
    899. 

  899. C     BDS11    - CONTAINS FIRST 11 BYTES FOR BDS
    900. 

  900. C     LEN      - NUMBER OF BYTES FROM 12 ON
    901. 

  901. C     LENBDS   - TOTAL LENGTH OF BDS
    902. 

  902. C
    903. 

  903. C REMARKS: SUBPROGRAM CAN BE CALLED FROM A MULTIPROCESSING ENVIRONMENT.
    904. 

  904. C
    905. 

  905. C ATTRIBUTES:
    906. 

  906. C   LANGUAGE: IBM VS FORTRAN 77, CRAY CFT77 FORTRAN
    907. 

  907. C   MACHINE:  HDS, CRAY C916/256, Y-MP8/64, Y-MP EL92/256
    908. 

  908. C
    909. 

  909. C $$
    910. 

  910.       CHARACTER*1     BDS11(*),PDS(*)
    911. 

  911. C
    912. 

  912.       REAL            REFNCE
    913. 

  913. C
    914. 

  914.       INTEGER         ISCAL2,KWIDE
    915. 

  915.       INTEGER         LENBDS
    916. 

  916.       INTEGER         IPFLD(*),IGDS(*)
    917. 

  917.       INTEGER         LEN,KBDS(22)
    918. 

  918.       INTEGER         IWORK(*)
    919. 

  919. C                        OCTET NUMBER IN SECTION, FIRST ORDER PACKING
    920. 

  920. C     INTEGER         KBDS(12)
    921. 

  921. C                        FLAGS
    922. 

  922.       INTEGER         IBDSFL(*)
    923. 

  923. C                        EXTENDED FLAGS
    924. 

  924. C     INTEGER         KBDS(14)
    925. 

  925. C                        OCTET NUMBER FOR SECOND ORDER PACKING
    926. 

  926. C     INTEGER         KBDS(15)
    927. 

  927. C                        NUMBER OF FIRST ORDER VALUES
    928. 

  928. C     INTEGER         KBDS(17)
    929. 

  929. C                        NUMBER OF SECOND ORDER PACKED VALUES
    930. 

  930. C     INTEGER         KBDS(19)
    931. 

  931. C                        WIDTH OF SECOND ORDER PACKING
    932. 

  932.       INTEGER         ISOWID(50000)
    933. 

  933. C                        SECONDARY BIT MAP
    934. 

  934.       INTEGER         ISOBMP(8200)
    935. 

  935. C                        FIRST ORDER PACKED VALUES
    936. 

  936.       INTEGER         IFOVAL(50000)
    937. 

  937. C                        SECOND ORDER PACKED VALUES
    938. 

  938.       INTEGER         ISOVAL(100000)
    939. 

  939. C
    940. 

  940. C     INTEGER         KBDS(11)
    941. 

  941. C  ----------------------------------
    942. 

  942. C                       INITIALIZE ARRAYS
    943. 

  943.       DO 100 I = 1, 50000
    944. 

  944.           ISOWID(I)  = 0
    945. 

  945.           IFOVAL(I)  = 0
    946. 

  946.   100 CONTINUE
    947. 

  947. C
    948. 

  948.       DO 101 I = 1, 8200
    949. 

  949.           ISOBMP(I)  = 0
    950. 

  950.   101 CONTINUE
    951. 

  951.       DO 102 I = 1, 100000
    952. 

  952.           ISOVAL(I)  = 0
    953. 

  953.   102 CONTINUE
    954. 

  954. C                      INITIALIZE POINTERS
    955. 

  955. C                            SECONDARY BIT WIDTH POINTER
    956. 

  956.       IWDPTR  = 0
    957. 

  957. C                            SECONDARY BIT MAP POINTER
    958. 

  958.       IBMP2P  = 0
    959. 

  959. C                            FIRST ORDER VALUE POINTER
    960. 

  960.       IFOPTR  = 0
    961. 

  961. C                            BYTE POINTER TO START OF 1ST ORDER VALUES
    962. 

  962.       KBDS(12)  = 0
    963. 

  963. C                            BYTE POINTER TO START OF 2ND ORDER VALUES
    964. 

  964.       KBDS(15)  = 0
    965. 

  965. C                            TO CONTAIN NUMBER OF FIRST ORDER VALUES
    966. 

  966.       KBDS(17)  = 0
    967. 

  967. C                            TO CONTAIN NUMBER OF SECOND ORDER VALUES
    968. 

  968.       KBDS(19)  = 0
    969. 

  969. C                            SECOND ORDER PACKED VALUE POINTER
    970. 

  970.       ISOPTR  = 0
    971. 

  971. C  =======================================================
    972. 

  972. C                         BUILD SECOND ORDER BIT MAP IN EITHER
    973. 

  973. C                         ROW BY ROW OR COL BY COL FORMAT
    974. 

  974.       IF (IAND(IGDS(13),32).NE.0) THEN
    975. 

  975. C                              COLUMN BY COLUMN
    976. 

  976.           KOUT  = IGDS(4)
    977. 

  977.           KIN   = IGDS(5)
    978. 

  978. C         PRINT *,'COLUMN BY COLUMN',KOUT,KIN
    979. 

  979.       ELSE
    980. 

  980. C                              ROW BY ROW
    981. 

  981.           KOUT  = IGDS(5)
    982. 

  982.           KIN   = IGDS(4)
    983. 

  983. C         PRINT *,'ROW BY ROW',KOUT,KIN
    984. 

  984.       END IF
    985. 

  985.       KBDS(17)  = KOUT
    986. 

  986.       KBDS(19)  = NPTS
    987. 

  987. C
    988. 

  988. C     DO 4100 J = 1, NPTS, 53
    989. 

  989. C         WRITE (6,4101) (IWORK(K),K=J,J+52)
    990. 

  990.  4101     FORMAT (1X,25I4)
    991. 

  991. C         PRINT *,' '
    992. 

  992. C4100 CONTINUE
    993. 

  993. C
    994. 

  994. C                             INITIALIZE BIT MAP POINTER
    995. 

  995.       IBMP2P = 0
    996. 

  996. C                             CONSTRUCT WORKING BIT MAP
    997. 

  997.       DO 2000 I = 1, KOUT
    998. 

  998.           DO 1000 J = 1, KIN
    999. 

  999.               IF (J.EQ.1) THEN
    1000. 

  1000.                   CALL SBYTE (ISOBMP,1,IBMP2P,1)
    1001. 

  1001.               ELSE
    1002. 

  1002.                   CALL SBYTE (ISOBMP,0,IBMP2P,1)
    1003. 

  1003.               END IF
    1004. 

  1004.               IBMP2P  = IBMP2P + 1
    1005. 

  1005.  1000     CONTINUE
    1006. 

  1006.  2000 CONTINUE
    1007. 

  1007.       LEN  = IBMP2P / 32 + 1
    1008. 

  1008. C     CALL BINARY(ISOBMP,LEN)
    1009. 

  1009. C
    1010. 

  1010. C                       PROCESS OUTER LOOP OF ROW BY ROW OR COL BY COL
    1011. 

  1011. C
    1012. 

  1012.       KPTR  = 1
    1013. 

  1013.       KBDS(11)  = KWIDE
    1014. 

  1014.       DO 6000 I = 1, KOUT
    1015. 

  1015. C                       IN CURRENT ROW OR COL
    1016. 

  1016. C                              FIND FIRST ORDER VALUE
    1017. 

  1017.           JPTR  = KPTR
    1018. 

  1018.           LOWEST  = IWORK(JPTR)
    1019. 

  1019.           DO 4000 J = 1, KIN
    1020. 

  1020.               IF (IWORK(JPTR).LT.LOWEST) THEN
    1021. 

  1021.                   LOWEST = IWORK(JPTR)
    1022. 

  1022.               END IF
    1023. 

  1023.               JPTR  = JPTR + 1
    1024. 

  1024.  4000     CONTINUE
    1025. 

  1025. C                            SAVE FIRST ORDER VALUE
    1026. 

  1026.           CALL SBYTE (IFOVAL,LOWEST,IFOPTR,KWIDE)
    1027. 

  1027.           IFOPTR  = IFOPTR + KWIDE
    1028. 

  1028. C         PRINT *,'FOVAL',I,LOWEST,KWIDE
    1029. 

  1029. C                            SUBTRACT FIRST ORDER VALUE FROM OTHER VALS
    1030. 

  1030. C                                         GETTING SECOND ORDER VALUES
    1031. 

  1031.           JPTR  = KPTR
    1032. 

  1032.           IBIG  = IWORK(JPTR) - LOWEST
    1033. 

  1033.           DO 4200 J = 1, KIN
    1034. 

  1034.               IWORK(JPTR)  = IWORK(JPTR) - LOWEST
    1035. 

  1035.               IF (IWORK(JPTR).GT.IBIG) THEN
    1036. 

  1036.                   IBIG  = IWORK(JPTR)
    1037. 

  1037.               END IF
    1038. 

  1038.               JPTR  = JPTR + 1
    1039. 

  1039.  4200     CONTINUE
    1040. 

  1040. C                            HOW MANY BITS TO CONTAIN LARGEST SECOND
    1041. 

  1041. C                                         ORDER VALUE IN SEGMENT
    1042. 

  1042.           CALL FI7505 (IBIG,NWIDE)
    1043. 

  1043. C                            SAVE BIT WIDTH
    1044. 

  1044.           CALL SBYTE (ISOWID,NWIDE,IWDPTR,8)
    1045. 

  1045.           IWDPTR  = IWDPTR + 8
    1046. 

  1046. C         PRINT *,I,'SOVAL',IBIG,' IN',NWIDE,' BITS'
    1047. 

  1047. C         WRITE (6,4101) (IWORK(K),K=KPTR,KPTR+52)
    1048. 

  1048. C                            SAVE SECOND ORDER VALUES OF THIS SEGMENT
    1049. 

  1049.           DO 5000 J = 0, KIN-1
    1050. 

  1050.               CALL SBYTE (ISOVAL,IWORK(KPTR+J),ISOPTR,NWIDE)
    1051. 

  1051.               ISOPTR  = ISOPTR + NWIDE
    1052. 

  1052.  5000     CONTINUE
    1053. 

  1053.           KPTR    = KPTR + KIN
    1054. 

  1054.  6000 CONTINUE
    1055. 

  1055. C  =======================================================
    1056. 

  1056. C                 CONCANTENATE ALL FIELDS FOR BDS
    1057. 

  1057. C
    1058. 

  1058. C                   REMAINDER GOES INTO IPFLD
    1059. 

  1059.       IPTR  = 0
    1060. 

  1060. C                               BYTES 12-13
    1061. 

  1061. C                                          VALUE FOR N1
    1062. 

  1062. C                                          LEAVE SPACE FOR THIS
    1063. 

  1063.       IPTR   = IPTR + 16
    1064. 

  1064. C                               BYTE 14
    1065. 

  1065. C                                          EXTENDED FLAGS
    1066. 

  1066.       CALL SBYTE (IPFLD,IBDSFL(5),IPTR,1)
    1067. 

  1067.       IPTR  = IPTR + 1
    1068. 

  1068.       CALL SBYTE (IPFLD,IBDSFL(6),IPTR,1)
    1069. 

  1069.       IPTR  = IPTR + 1
    1070. 

  1070.       CALL SBYTE (IPFLD,IBDSFL(7),IPTR,1)
    1071. 

  1071.       IPTR  = IPTR + 1
    1072. 

  1072.       CALL SBYTE (IPFLD,IBDSFL(8),IPTR,1)
    1073. 

  1073.       IPTR  = IPTR + 1
    1074. 

  1074.       CALL SBYTE (IPFLD,IBDSFL(9),IPTR,1)
    1075. 

  1075.       IPTR  = IPTR + 1
    1076. 

  1076.       CALL SBYTE (IPFLD,IBDSFL(10),IPTR,1)
    1077. 

  1077.       IPTR  = IPTR + 1
    1078. 

  1078.       CALL SBYTE (IPFLD,IBDSFL(11),IPTR,1)
    1079. 

  1079.       IPTR  = IPTR + 1
    1080. 

  1080.       CALL SBYTE (IPFLD,IBDSFL(12),IPTR,1)
    1081. 

  1081.       IPTR  = IPTR + 1
    1082. 

  1082. C                               BYTES 15-16
    1083. 

  1083. C                 SKIP OVER VALUE  FOR N2
    1084. 

  1084.       IPTR  = IPTR + 16
    1085. 

  1085. C                               BYTES 17-18
    1086. 

  1086. C                                     P1
    1087. 

  1087.       CALL SBYTE (IPFLD,KBDS(17),IPTR,16)
    1088. 

  1088.       IPTR  = IPTR + 16
    1089. 

  1089. C                               BYTES 19-20
    1090. 

  1090. C                                   P2
    1091. 

  1091.       CALL SBYTE (IPFLD,KBDS(19),IPTR,16)
    1092. 

  1092.       IPTR  = IPTR + 16
    1093. 

  1093. C                               BYTE 21 - RESERVED LOCATION
    1094. 

  1094.       CALL SBYTE (IPFLD,0,IPTR,8)
    1095. 

  1095.       IPTR  = IPTR + 8
    1096. 

  1096. C                               BYTES 22 - ?
    1097. 

  1097. C                                      WIDTHS OF SECOND ORDER PACKING
    1098. 

  1098.       IX    = (IWDPTR + 32) / 32
    1099. 

  1099.       CALL SBYTES (IPFLD,ISOWID,IPTR,32,0,IX)
    1100. 

  1100.       IPTR  = IPTR + IWDPTR
    1101. 

  1101. C     PRINT *,'ISOWID',IWDPTR,IX
    1102. 

  1102. C     CALL BINARY (ISOWID,IX)
    1103. 

  1103. C
    1104. 

  1104. C                     NO SECONDARY BIT MAP
    1105. 

  1105. 

  1106. C                                         DETERMINE LOCATION FOR START
    1107. 

  1107. C                                         OF FIRST ORDER PACKED VALUES
    1108. 

  1108.       KBDS(12)  = IPTR / 8 + 12
    1109. 

  1109. C                                        STORE LOCATION
    1110. 

  1110.       CALL SBYTE (IPFLD,KBDS(12),0,16)
    1111. 

  1111. C                                     MOVE IN FIRST ORDER PACKED VALUES
    1112. 

  1112.       IPASS   = (IFOPTR + 32) / 32
    1113. 

  1113.       CALL SBYTES (IPFLD,IFOVAL,IPTR,32,0,IPASS)
    1114. 

  1114.       IPTR  = IPTR + IFOPTR
    1115. 

  1115. C     PRINT *,'IFOVAL',IFOPTR,IPASS,KWIDE
    1116. 

  1116. C     CALL BINARY (IFOVAL,IPASS)
    1117. 

  1117.       IF (MOD(IPTR,8).NE.0) THEN
    1118. 

  1118.           IPTR  = IPTR + 8 - MOD(IPTR,8)
    1119. 

  1119.       END IF
    1120. 

  1120. C     PRINT *,'IFOPTR =',IFOPTR,' ISOPTR =',ISOPTR
    1121. 

  1121. C                DETERMINE LOCATION FOR START
    1122. 

  1122. C                     OF SECOND ORDER VALUES
    1123. 

  1123.       KBDS(15)  = IPTR / 8 + 12
    1124. 

  1124. C                                   SAVE LOCATION OF SECOND ORDER VALUES
    1125. 

  1125.       CALL SBYTE (IPFLD,KBDS(15),24,16)
    1126. 

  1126. C                  MOVE IN SECOND ORDER PACKED VALUES
    1127. 

  1127.       IX    = (ISOPTR + 32) / 32
    1128. 

  1128.       CALL SBYTES (IPFLD,ISOVAL,IPTR,32,0,IX)
    1129. 

  1129.       IPTR  = IPTR + ISOPTR
    1130. 

  1130. C     PRINT *,'ISOVAL',ISOPTR,IX
    1131. 

  1131. C     CALL BINARY (ISOVAL,IX)
    1132. 

  1132.       NLEFT  = MOD(IPTR+88,16)
    1133. 

  1133.       IF (NLEFT.NE.0) THEN
    1134. 

  1134.           NLEFT  = 16 - NLEFT
    1135. 

  1135.           IPTR   = IPTR + NLEFT
    1136. 

  1136.       END IF
    1137. 

  1137. C                                COMPUTE LENGTH OF DATA PORTION
    1138. 

  1138.       LEN     = IPTR / 8
    1139. 

  1139. C                                    COMPUTE LENGTH OF BDS
    1140. 

  1140.       LENBDS  = LEN + 11
    1141. 

  1141. C  -----------------------------------
    1142. 

  1142. C                               BYTES 1-3
    1143. 

  1143. C                                   THIS FUNCTION COMPLETED BELOW
    1144. 

  1144. C                                   WHEN LENGTH OF BDS IS KNOWN
    1145. 

  1145.       CALL SBYTE (BDS11,LENBDS,0,24)
    1146. 

  1146. C                               BYTE  4
    1147. 

  1147.       CALL SBYTE (BDS11,IBDSFL(1),24,1)
    1148. 

  1148.       CALL SBYTE (BDS11,IBDSFL(2),25,1)
    1149. 

  1149.       CALL SBYTE (BDS11,IBDSFL(3),26,1)
    1150. 

  1150.       CALL SBYTE (BDS11,IBDSFL(4),27,1)
    1151. 

  1151. C                              ENTER NUMBER OF FILL BITS
    1152. 

  1152.       CALL SBYTE (BDS11,NLEFT,28,4)
    1153. 

  1153. C                               BYTE  5-6
    1154. 

  1154.       IF (ISCAL2.LT.0) THEN
    1155. 

  1155.           CALL SBYTE (BDS11,1,32,1)
    1156. 

  1156.           ISCAL2 = - ISCAL2
    1157. 

  1157.       ELSE
    1158. 

  1158.           CALL SBYTE (BDS11,0,32,1)
    1159. 

  1159.       END IF
    1160. 

  1160.       CALL SBYTE (BDS11,ISCAL2,33,15)
    1161. 

  1161. C
    1162. 

  1162. C   FILL OCTET 7-10 WITH THE REFERENCE VALUE
    1163. 

  1163. C   CONVERT THE FLOATING POINT OF YOUR MACHINE TO IBM370 32 BIT
    1164. 

  1164. C   FLOATING POINT NUMBER
    1165. 

  1165. C                                        REFERENCE VALUE
    1166. 

  1166. C                                          FIRST TEST TO SEE IF
    1167. 

  1167. C                                          ON 32 OR 64 BIT COMPUTER
    1168. 

  1168.       CALL W3FI01(LW)
    1169. 

  1169.       IF (LW.EQ.4) THEN
    1170. 

  1170.           CALL W3FI76 (REFNCE,IEXP,IMANT,32)
    1171. 

  1171.       ELSE
    1172. 

  1172.           CALL W3FI76 (REFNCE,IEXP,IMANT,64)
    1173. 

  1173.       END IF
    1174. 

  1174.       CALL SBYTE (BDS11,IEXP,48,8)
    1175. 

  1175.       CALL SBYTE (BDS11,IMANT,56,24)
    1176. 

  1176. C
    1177. 

  1177. C                               BYTE  11
    1178. 

  1178. C
    1179. 

  1179.       CALL SBYTE (BDS11,KBDS(11),80,8)
    1180. 

  1180. C
    1181. 

  1181.       KLEN  = LENBDS / 4 + 1
    1182. 

  1182. C     PRINT *,'BDS11 LISTING',4,LENBDS
    1183. 

  1183. C     CALL BINARY (BDS11,4)
    1184. 

  1184. C     PRINT *,'IPFLD LISTING'
    1185. 

  1185. C     CALL BINARY (IPFLD,KLEN)
    1186. 

  1186.       RETURN
    1187. 

  1187.       END
    1188. 

  1188.       SUBROUTINE FI7505 (N,NBITS)
    1189. 

  1189. C $$  SUBPROGRAM DOCUMENTATION BLOCK
    1190. 

  1190. C                .      .    .                                       .
    1191. 

  1191. C SUBPROGRAM:    FI7505      DETERMINE NUMBER OF BITS TO CONTAIN VALUE
    1192. 

  1192. C   PRGMMR: CAVANAUGH        ORG: W/NMC42    DATE: 93-06-23
    1193. 

  1193. C
    1194. 

  1194. C ABSTRACT: CALCULATE NUMBER OF BITS TO CONTAIN VALUE N, WITH A
    1195. 

  1195. C            MAXIMUM OF 32 BITS.
    1196. 

  1196. C
    1197. 

  1197. C PROGRAM HISTORY LOG:
    1198. 

  1198. C   93-06-23  CAVANAUGH
    1199. 

  1199. C   95-10-31  IREDELL     REMOVED SAVES AND PRINTS
    1200. 

  1200. C
    1201. 

  1201. C USAGE:    CALL FI7505 (N,NBITS)
    1202. 

  1202. C   INPUT ARGUMENT LIST:
    1203. 

  1203. C     N        - INTEGER VALUE
    1204. 

  1204. C
    1205. 

  1205. C   OUTPUT ARGUMENT LIST:      (INCLUDING WORK ARRAYS)
    1206. 

  1206. C     NBITS    - NUMBER OF BITS TO CONTAIN N
    1207. 

  1207. C
    1208. 

  1208. C REMARKS: SUBPROGRAM CAN BE CALLED FROM A MULTIPROCESSING ENVIRONMENT.
    1209. 

  1209. C
    1210. 

  1210. C ATTRIBUTES:
    1211. 

  1211. C   LANGUAGE: IBM VS FORTRAN 77, CRAY CFT77 FORTRAN
    1212. 

  1212. C   MACHINE:  HDS, CRAY C916/256, Y-MP8/64, Y-MP EL92/256
    1213. 

  1213. C
    1214. 

  1214. C $$
    1215. 

  1215.       INTEGER        N,NBITS
    1216. 

  1216.       INTEGER        IBITS(31)
    1217. 

  1217. C
    1218. 

  1218.       DATA           IBITS/1,3,7,15,31,63,127,255,511,1023,2047,
    1219. 

  1219.      *               4095,8191,16383,32767,65535,131071,262143,
    1220. 

  1220.      *               524287,1048575,2097151,4194303,8388607,
    1221. 

  1221.      *               16777215,33554431,67108863,134217727,268435455,
    1222. 

  1222.      *               536870911,1073741823,2147483647/
    1223. 

  1223. C  ----------------------------------------------------------------
    1224. 

  1224. C
    1225. 

  1225.       DO 1000 NBITS = 1, 31
    1226. 

  1226.           IF (N.LE.IBITS(NBITS)) THEN
    1227. 

  1227.               RETURN
    1228. 

  1228.           END IF
    1229. 

  1229.  1000 CONTINUE
    1230. 

  1230.       RETURN
    1231. 

  1231.       END
    1232. 

  1232.       SUBROUTINE FI7513 (IWORK,ISTART,NPTS,MAX,MIN,INRNGE)
    1233. 

  1233. C $$  SUBPROGRAM DOCUMENTATION BLOCK
    1234. 

  1234. C                .      .    .                                       .
    1235. 

  1235. C SUBPROGRAM:    FI7513      SELECT BLOCK OF DATA FOR PACKING
    1236. 

  1236. C   PRGMMR: CAVANAUGH        ORG: W/NMC42    DATE: 94-01-21
    1237. 

  1237. C
    1238. 

  1238. C ABSTRACT: SELECT A BLOCK OF DATA FOR PACKING
    1239. 

  1239. C
    1240. 

  1240. C PROGRAM HISTORY LOG:
    1241. 

  1241. C   94-01-21  CAVANAUGH
    1242. 

  1242. C   95-10-31  IREDELL     REMOVED SAVES AND PRINTS
    1243. 

  1243. C
    1244. 

  1244. C USAGE:    CALL FI7513 (IWORK,ISTART,NPTS,MAX,MIN,INRNGE)
    1245. 

  1245. C   INPUT ARGUMENT LIST:
    1246. 

  1246. C     *        - RETURN ADDRESS IF ENCOUNTER SET OF SAME VALUES
    1247. 

  1247. C     IWORK    -
    1248. 

  1248. C     ISTART   -
    1249. 

  1249. C     NPTS     -
    1250. 

  1250. C
    1251. 

  1251. C   OUTPUT ARGUMENT LIST:      (INCLUDING WORK ARRAYS)
    1252. 

  1252. C     MAX      -
    1253. 

  1253. C     MIN      -
    1254. 

  1254. C     INRNGE   -
    1255. 

  1255. C
    1256. 

  1256. C REMARKS: SUBPROGRAM CAN BE CALLED FROM A MULTIPROCESSING ENVIRONMENT.
    1257. 

  1257. C
    1258. 

  1258. C ATTRIBUTES:
    1259. 

  1259. C   LANGUAGE: IBM VS FORTRAN 77, CRAY CFT77 FORTRAN
    1260. 

  1260. C   MACHINE:  HDS, CRAY C916/256, Y-MP8/64, Y-MP EL92/256
    1261. 

  1261. C
    1262. 

  1262. C $$
    1263. 

  1263.       INTEGER        IWORK(*),NPTS,ISTART,INRNGE,INRNGA,INRNGB
    1264. 

  1264.       INTEGER        MAX,MIN,MXVAL,MAXB,MINB,MXVALB
    1265. 

  1265.       INTEGER        IBITS(31)
    1266. 

  1266. C
    1267. 

  1267.       DATA           IBITS/1,3,7,15,31,63,127,255,511,1023,2047,
    1268. 

  1268.      *               4095,8191,16383,32767,65535,131071,262143,
    1269. 

  1269.      *               524287,1048575,2097151,4194303,8388607,
    1270. 

  1270.      *               16777215,33554431,67108863,134217727,268435455,
    1271. 

  1271.      *               536870911,1073741823,2147483647/
    1272. 

  1272. C  ----------------------------------------------------------------
    1273. 

  1273. C                        IDENTIFY NEXT BLOCK OF DATA FOR PACKING AND
    1274. 

  1274. C                           RETURN TO CALLER
    1275. 

  1275. C  ********************************************************************
    1276. 

  1276.       ISTRTA  = ISTART
    1277. 

  1277. C
    1278. 

  1278. C                     GET BLOCK A
    1279. 

  1279.       CALL FI7516 (IWORK,NPTS,INRNGA,ISTRTA,
    1280. 

  1280.      *                                  MAX,MIN,MXVAL,LWIDE)
    1281. 

  1281. C  ********************************************************************
    1282. 

  1282. C
    1283. 

  1283.       ISTRTB  = ISTRTA + INRNGA
    1284. 

  1284.  2000 CONTINUE
    1285. 

  1285. C                         IF HAVE PROCESSED ALL DATA, RETURN
    1286. 

  1286.       IF (ISTRTB.GT.NPTS) THEN
    1287. 

  1287. C                         NO MORE DATA TO LOOK AT
    1288. 

  1288.           INRNGE  = INRNGA
    1289. 

  1289.           RETURN
    1290. 

  1290.       END IF
    1291. 

  1291. C                     GET BLOCK B
    1292. 

  1292.       CALL FI7502 (IWORK,ISTRTB,NPTS,ISAME)
    1293. 

  1293.       IF (ISAME.GE.15) THEN
    1294. 

  1294. C         PRINT *,'BLOCK B HAS ALL IDENTICAL VALUES'
    1295. 

  1295. C         PRINT *,'BLOCK A HAS INRNGE =',INRNGA
    1296. 

  1296. C                     BLOCK B CONTAINS ALL IDENTICAL VALUES
    1297. 

  1297.           INRNGE  = INRNGA
    1298. 

  1298. C                     EXIT WITH BLOCK A
    1299. 

  1299.           RETURN
    1300. 

  1300.       END IF
    1301. 

  1301. C                     GET BLOCK B
    1302. 

  1302. C
    1303. 

  1303.       ISTRTB  = ISTRTA + INRNGA
    1304. 

  1304.       CALL FI7516 (IWORK,NPTS,INRNGB,ISTRTB,
    1305. 

  1305.      *                                  MAXB,MINB,MXVALB,LWIDEB)
    1306. 

  1306. C     PRINT *,'BLOCK A',INRNGA,' BLOCK B',INRNGB
    1307. 

  1307. C  ********************************************************************
    1308. 

  1308. C                     PERFORM TREND ANALYSIS TO DETERMINE
    1309. 

  1309. C                     IF DATA COLLECTION CAN BE IMPROVED
    1310. 

  1310. C
    1311. 

  1311.       KTRND  = LWIDE - LWIDEB
    1312. 

  1312. C     PRINT *,'TREND',LWIDE,LWIDEB
    1313. 

  1313.       IF (KTRND.LE.0) THEN
    1314. 

  1314. C         PRINT *,'BLOCK A - SMALLER, SHOULD EXTEND INTO BLOCK B'
    1315. 

  1315.           MXVAL   = IBITS(LWIDE)
    1316. 

  1316. C
    1317. 

  1317. C                     IF BLOCK A REQUIRES THE SAME OR FEWER BITS
    1318. 

  1318. C                             LOOK AHEAD
    1319. 

  1319. C                        AND GATHER THOSE DATA POINTS THAT CAN
    1320. 

  1320. C                        BE RETAINED IN BLOCK A
    1321. 

  1321. C                        BECAUSE THIS BLOCK OF DATA
    1322. 

  1322. C                            USES FEWER BITS
    1323. 

  1323. C
    1324. 

  1324.           CALL FI7518 (IRET,IWORK,NPTS,ISTRTA,INRNGA,INRNGB,
    1325. 

  1325.      *                          MAX,MIN,LWIDE,MXVAL)
    1326. 

  1326.           IF(IRET.EQ.1) GO TO 8000
    1327. 

  1327. C         PRINT *,'18 INRNGA IS NOW ',INRNGA
    1328. 

  1328.           IF (INRNGB.LT.20) THEN
    1329. 

  1329.               RETURN
    1330. 

  1330.           ELSE
    1331. 

  1331.               GO TO 2000
    1332. 

  1332.           END IF
    1333. 

  1333.       ELSE
    1334. 

  1334. C         PRINT *,'BLOCK A - LARGER, B SHOULD EXTEND BACK INTO A'
    1335. 

  1335.           MXVALB  = IBITS(LWIDEB)
    1336. 

  1336. C
    1337. 

  1337. C                     IF BLOCK B REQUIRES FEWER BITS
    1338. 

  1338. C                             LOOK BACK
    1339. 

  1339. C                            SHORTEN BLOCK A BECAUSE NEXT BLOCK OF DATA
    1340. 

  1340. C                            USES FEWER BITS
    1341. 

  1341. C
    1342. 

  1342.           CALL FI7517 (IRET,IWORK,NPTS,ISTRTB,INRNGA,
    1343. 

  1343.      *                               MAXB,MINB,LWIDEB,MXVALB)
    1344. 

  1344.           IF(IRET.EQ.1) GO TO 8000
    1345. 

  1345. C         PRINT *,'17 INRNGA IS NOW ',INRNGA
    1346. 

  1346.       END IF
    1347. 

  1347. C
    1348. 

  1348. C                           PACK UP BLOCK A
    1349. 

  1349. C                           UPDATA POINTERS
    1350. 

  1350.  8000 CONTINUE
    1351. 

  1351.       INRNGE  = INRNGA
    1352. 

  1352. C                           GET NEXT BLOCK A
    1353. 

  1353.  9000 CONTINUE
    1354. 

  1354.       RETURN
    1355. 

  1355.       END
    1356. 

  1356.       SUBROUTINE FI7516 (IWORK,NPTS,INRNG,ISTART,MAX,MIN,MXVAL,LWIDTH)
    1357. 

  1357. C $$  SUBPROGRAM DOCUMENTATION BLOCK
    1358. 

  1358. C                .      .    .                                       .
    1359. 

  1359. C SUBPROGRAM:    FI7516      SCAN NUMBER OF POINTS
    1360. 

  1360. C   PRGMMR: CAVANAUGH        ORG: W/NMC42    DATE: 94-01-21
    1361. 

  1361. C
    1362. 

  1362. C ABSTRACT: SCAN FORWARD FROM CURRENT POSITION. COLLECT POINTS AND
    1363. 

  1363. C           DETERMINE MAXIMUM AND MINIMUM VALUES AND THE NUMBER
    1364. 

  1364. C           OF POINTS THAT ARE INCLUDED. FORWARD SEARCH IS TERMINATED
    1365. 

  1365. C           BY ENCOUNTERING A SET OF IDENTICAL VALUES, BY REACHING
    1366. 

  1366. C           THE NUMBER OF POINTS SELECTED OR BY REACHING THE END
    1367. 

  1367. C           OF DATA.
    1368. 

  1368. C
    1369. 

  1369. C PROGRAM HISTORY LOG:
    1370. 

  1370. C   94-01-21  CAVANAUGH
    1371. 

  1371. C   95-10-31  IREDELL     REMOVED SAVES AND PRINTS
    1372. 

  1372. C
    1373. 

  1373. C USAGE:    CALL FI7516 (IWORK,NPTS,INRNG,ISTART,MAX,MIN,MXVAL,LWIDTH)
    1374. 

  1374. C   INPUT ARGUMENT LIST:
    1375. 

  1375. C     *        - RETURN ADDRESS IF ENCOUNTER SET OF SAME VALUES
    1376. 

  1376. C     IWORK    - DATA ARRAY
    1377. 

  1377. C     NPTS     - NUMBER OF POINTS IN DATA ARRAY
    1378. 

  1378. C     ISTART   - STARTING LOCATION IN DATA
    1379. 

  1379. C
    1380. 

  1380. C   OUTPUT ARGUMENT LIST:      (INCLUDING WORK ARRAYS)
    1381. 

  1381. C     INRNG    - NUMBER OF POINTS SELECTED
    1382. 

  1382. C     MAX      - MAXIMUM VALUE OF POINTS
    1383. 

  1383. C     MIN      - MINIMUM VALUE OF POINTS
    1384. 

  1384. C     MXVAL    - MAXIMUM VALUE THAT CAN BE CONTAINED IN LWIDTH BITS
    1385. 

  1385. C     LWIDTH   - NUMBER OF BITS TO CONTAIN MAX DIFF
    1386. 

  1386. C
    1387. 

  1387. C REMARKS: SUBPROGRAM CAN BE CALLED FROM A MULTIPROCESSING ENVIRONMENT.
    1388. 

  1388. C
    1389. 

  1389. C ATTRIBUT…
    1390.

Large files files are truncated, but you can click here to view the full file