PageRenderTime 61ms CodeModel.GetById 32ms RepoModel.GetById 0ms app.codeStats 0ms

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

http://github.com/jbeezley/wrf-fire
FORTRAN Legacy | 455 lines | 171 code | 0 blank | 284 comment | 0 complexity | 3ddf182ea3573e5ec7fba2ef0a134fa7 MD5 | raw file
Possible License(s): AGPL-1.0
  1. SUBROUTINE W3FI72(ITYPE,FLD,IFLD,IBITL,
  2. & IPFLAG,ID,PDS,
  3. & IGFLAG,IGRID,IGDS,ICOMP,
  4. & IBFLAG,IBMAP,IBLEN,IBDSFL,
  5. & NPTS,KBUF,ITOT,JERR)
  6. C $$ SUBPROGRAM DOCUMENTATION BLOCK
  7. C . . . .
  8. C SUBPROGRAM: W3FI72 MAKE A COMPLETE GRIB MESSAGE
  9. C PRGMMR: FARLEY ORG: NMC421 DATE:94-11-22
  10. C
  11. C ABSTRACT: MAKES A COMPLETE GRIB MESSAGE FROM A USER SUPPLIED
  12. C ARRAY OF FLOATING POINT OR INTEGER DATA. THE USER HAS THE
  13. C OPTION OF SUPPLYING THE PDS OR AN INTEGER ARRAY THAT WILL BE
  14. C USED TO CREATE A PDS (WITH W3FI68). THE USER MUST ALSO
  15. C SUPPLY OTHER NECESSARY INFO; SEE USAGE SECTION BELOW.
  16. C
  17. C PROGRAM HISTORY LOG:
  18. C 91-05-08 R.E.JONES
  19. C 92-07-01 M. FARLEY ADDED GDS AND BMS LOGIC. PLACED EXISTING
  20. C LOGIC FOR BDS IN A ROUTINE.
  21. C 92-10-02 R.E.JONES ADD ERROR EXIT FOR W3FI73
  22. C 93-04-30 R.E.JONES REPLACE DO LOOPS TO MOVE CHARACTER DATA
  23. C WITH XMOVEX, USE XSTORE TO ZERO CHARACTER
  24. C ARRAY. MAKE CHANGE SO FLAT FIELD WILL PACK.
  25. C 93-08-06 CAVANAUGH MODIFIED CALL TO W3FI75
  26. C 93-10-26 CAVANAUGH ADDED CODE TO RESTORE INPUT FIELD TO ORIGINAL
  27. C VALUES IF D-SCALE NOT 0
  28. C 94-01-27 CAVANAUGH ADDED IGDS ARRAY IN CALL TO W3FI75 TO PROVIDE
  29. C INFORMATION FOR BOUSTROPHEDONIC PROCESSING
  30. C 94-03-03 CAVANAUGH INCREASED SIZE OF GDS ARRAY FOR THIN GRIDS
  31. C 94-05-16 FARLEY CLEANED UP DOCUMENTATION
  32. C 94-11-10 FARLEY INCREASED SIZE OF PFLD/IFLD ARRARYS FROM
  33. C 100K TO 260K FOR .5 DEGREE SST ANAL FIELDS
  34. C 94-12-04 R.E.JONES CHANGE DOCUMENT FOR IPFLAG.
  35. C 95-10-31 IREDELL REMOVED SAVES AND PRINTS
  36. C 98-05-19 Gilbert Increased array dimensions to handle grids
  37. C of up to 500,000 grid points.
  38. C 95-10-31 IREDELL GENERALIZED WORD SIZE
  39. C 98-12-21 Gilbert Replaced Function ICHAR with mov_a2i.
  40. C 99-02-01 Gilbert Changed the method of zeroing out array KBUF.
  41. C the old method, using W3FI01 and XSTORE was
  42. C incorrect with 4-byte integers and 8-byte reals.
  43. C 2001-06-07 Gilbert Removed calls to xmovex.
  44. C changed IPFLD from integer to character.
  45. C 10-02-19 GAYNO FIX ALLOCATION OF ARRAY BMS
  46. C
  47. C USAGE: CALL W3FI72(ITYPE,FLD,IFLD,IBITL,
  48. C & IPFLAG,ID,PDS,
  49. C & IGFLAG,IGRID,IGDS,ICOMP,
  50. C & IBFLAG,IBMAP,IBLEN,IBDSFL,
  51. C & IBDSFL,
  52. C & NPTS,KBUF,ITOT,JERR)
  53. C
  54. C INPUT ARGUMENT LIST:
  55. C ITYPE - 0 = FLOATING POINT DATA SUPPLIED IN ARRAY 'FLD'
  56. C 1 = INTEGER DATA SUPPLIED IN ARRAY 'IFLD'
  57. C FLD - REAL ARRAY OF DATA (AT PROPER GRIDPOINTS) TO BE
  58. C CONVERTED TO GRIB FORMAT IF ITYPE=0.
  59. C SEE REMARKS #1 & 2.
  60. C IFLD - INTEGER ARRAY OF DATA (AT PROPER GRIDPOINTS) TO BE
  61. C CONVERTED TO GRIB FORMAT IF ITYPE=1.
  62. C SEE REMARKS #1 & 2.
  63. C IBITL - 0 = COMPUTER COMPUTES LENGTH FOR PACKING DATA FROM
  64. C POWER OF 2 (NUMBER OF BITS) BEST FIT OF DATA
  65. C USING 'VARIABLE' BIT PACKER W3FI58.
  66. C 8, 12, ETC. COMPUTER RESCALES DATA TO FIT INTO THAT
  67. C 'FIXED' NUMBER OF BITS USING W3FI59.
  68. C SEE REMARKS #3.
  69. C
  70. C IPFLAG - 0 = MAKE PDS FROM USER SUPPLIED ARRAY (ID)
  71. C 1 = USER SUPPLYING PDS
  72. C NOTE: IF PDS IS GREATER THAN 30, USE IPLFAG=1.
  73. C THE USER COULD CALL W3FI68 BEFORE HE CALLS
  74. C W3FI72. THIS WOULD MAKE THE FIRST 30 BYTES OF
  75. C THE PDS, USER THEN WOULD MAKE BYTES AFTER 30.
  76. C ID - INTEGER ARRAY OF VALUES THAT W3FI68 WILL USE
  77. C TO MAKE AN EDITION 1 PDS IF IPFLAG=0. (SEE THE
  78. C DOCBLOCK FOR W3FI68 FOR LAYOUT OF ARRAY)
  79. C PDS - CHARACTER ARRAY OF VALUES (VALID PDS SUPPLIED
  80. C BY USER) IF IPFLAG=1. LENGTH MAY EXCEED 28 BYTES
  81. C (CONTENTS OF BYTES BEYOND 28 ARE PASSED
  82. C THROUGH UNCHANGED).
  83. C
  84. C IGFLAG - 0 = MAKE GDS BASED ON 'IGRID' VALUE.
  85. C 1 = MAKE GDS FROM USER SUPPLIED INFO IN 'IGDS'
  86. C AND 'IGRID' VALUE.
  87. C SEE REMARKS #4.
  88. C IGRID - # = GRID IDENTIFICATION (TABLE B)
  89. C 255 = IF USER DEFINED GRID; IGDS MUST BE SUPPLIED
  90. C AND IGFLAG MUST =1.
  91. C IGDS - INTEGER ARRAY CONTAINING USER GDS INFO (SAME
  92. C FORMAT AS SUPPLIED BY W3FI71 - SEE DOCKBLOCK FOR
  93. C LAYOUT) IF IGFLAG=1.
  94. C ICOMP - RESOLUTION AND COMPONENT FLAG FOR BIT 5 OF GDS(17)
  95. C 0 = EARTH ORIENTED WINDS
  96. C 1 = GRID ORIENTED WINDS
  97. C
  98. C IBFLAG - 0 = MAKE BIT MAP FROM USER SUPPLIED DATA
  99. C # = BIT MAP PREDEFINED BY CENTER
  100. C SEE REMARKS #5.
  101. C IBMAP - INTEGER ARRAY CONTAINING BIT MAP
  102. C IBLEN - LENGTH OF BIT MAP WILL BE USED TO VERIFY LENGTH
  103. C OF FIELD (ERROR IF IT DOESN'T MATCH).
  104. C
  105. C IBDSFL - INTEGER ARRAY CONTAINING TABLE 11 FLAG INFO
  106. C BDS OCTET 4:
  107. C (1) 0 = GRID POINT DATA
  108. C 1 = SPHERICAL HARMONIC COEFFICIENTS
  109. C (2) 0 = SIMPLE PACKING
  110. C 1 = SECOND ORDER PACKING
  111. C (3) ... SAME VALUE AS 'ITYPE'
  112. C 0 = ORIGINAL DATA WERE FLOATING POINT VALUES
  113. C 1 = ORIGINAL DATA WERE INTEGER VALUES
  114. C (4) 0 = NO ADDITIONAL FLAGS AT OCTET 14
  115. C 1 = OCTET 14 CONTAINS FLAG BITS 5-12
  116. C (5) 0 = RESERVED - ALWAYS SET TO 0
  117. C BYTE 6 OPTION 1 NOT AVAILABLE (AS OF 5-16-93)
  118. C (6) 0 = SINGLE DATUM AT EACH GRID POINT
  119. C 1 = MATRIX OF VALUES AT EACH GRID POINT
  120. C BYTE 7 OPTION 0 WITH SECOND ORDER PACKING N/A (AS OF 5-16-93)
  121. C (7) 0 = NO SECONDARY BIT MAPS
  122. C 1 = SECONDARY BIT MAPS PRESENT
  123. C (8) 0 = SECOND ORDER VALUES HAVE CONSTANT WIDTH
  124. C 1 = SECOND ORDER VALUES HAVE DIFFERENT WIDTHS
  125. C
  126. C OUTPUT ARGUMENT LIST:
  127. C NPTS - NUMBER OF GRIDPOINTS IN ARRAY FLD OR IFLD
  128. C KBUF - ENTIRE GRIB MESSAGE ('GRIB' TO '7777')
  129. C EQUIVALENCE TO INTEGER ARRAY TO MAKE SURE IT
  130. C IS ON WORD BOUNARY.
  131. C ITOT - TOTAL LENGTH OF GRIB MESSAGE IN BYTES
  132. C JERR - = 0, COMPLETED MAKING GRIB FIELD WITHOUT ERROR
  133. C 1, IPFLAG NOT 0 OR 1
  134. C 2, IGFLAG NOT 0 OR 1
  135. C 3, ERROR CONVERTING IEEE F.P. NUMBER TO IBM370 F.P.
  136. C 4, W3FI71 ERROR/IGRID NOT DEFINED
  137. C 5, W3FK74 ERROR/GRID REPRESENTATION TYPE NOT VALID
  138. C 6, GRID TOO LARGE FOR PACKER DIMENSION ARRAYS
  139. C SEE AUTOMATION DIVISION FOR REVISION!
  140. C 7, LENGTH OF BIT MAP NOT EQUAL TO SIZE OF FLD/IFLD
  141. C 8, W3FI73 ERROR, ALL VALUES IN IBMAP ARE ZERO
  142. C
  143. C OUTPUT FILES:
  144. C FT06F001 - STANDARD FORTRAN OUTPUT PRINT FILE
  145. C
  146. C SUBPROGRAMS CALLED:
  147. C LIBRARY:
  148. C W3LIB - W3FI58, W3FI59, W3FI68, W3FI71, W3FI73, W3FI74
  149. C W3FI75, W3FI76
  150. C FORTRAN 90 INTRINSIC - BIT_SIZE
  151. C
  152. C REMARKS:
  153. C 1) IF BIT MAP TO BE INCLUDED IN MESSAGE, NULL DATA SHOULD
  154. C BE INCLUDED IN FLD OR IFLD. THIS ROUTINE WILL TAKE CARE
  155. C OF 'DISCARDING' ANY NULL DATA BASED ON THE BIT MAP.
  156. C 2) UNITS MUST BE THOSE IN GRIB DOCUMENTATION: NMC O.N. 388
  157. C OR WMO PUBLICATION 306.
  158. C 3) IN EITHER CASE, INPUT NUMBERS WILL BE MULTIPLIED BY
  159. C '10 TO THE NTH' POWER FOUND IN ID(25) OR PDS(27-28),
  160. C THE D-SCALING FACTOR, PRIOR TO BINARY PACKING.
  161. C 4) ALL NMC PRODUCED GRIB FIELDS WILL HAVE A GRID DEFINITION
  162. C SECTION INCLUDED IN THE GRIB MESSAGE. ID(6) WILL BE
  163. C SET TO '1'.
  164. C - GDS WILL BE BUILT BASED ON GRID NUMBER (IGRID), UNLESS
  165. C IGFLAG=1 (USER SUPPLYING IGDS). USER MUST STILL SUPPLY
  166. C IGRID EVEN IF IGDS PROVIDED.
  167. C 5) IF BIT MAP USED THEN ID(7) OR PDS(8) MUST INDICATE THE
  168. C PRESENCE OF A BIT MAP.
  169. C 6) ARRAY KBUF SHOULD BE EQUIVALENCED TO AN INTEGER VALUE OR
  170. C ARRAY TO MAKE SURE IT IS ON A WORD BOUNDARY.
  171. C 7) SUBPROGRAM CAN BE CALLED FROM A MULTIPROCESSING ENVIRONMENT.
  172. C
  173. C ATTRIBUTES:
  174. C LANGUAGE: FORTRAN 90
  175. C
  176. C $$
  177. C
  178. REAL FLD(*)
  179. C
  180. INTEGER IBDSFL(*)
  181. INTEGER IBMAP(*)
  182. INTEGER ID(*)
  183. INTEGER IFLD(*)
  184. INTEGER IGDS(*)
  185. INTEGER IB(4)
  186. INTEGER NLEFT, NUMBMS
  187. C
  188. CHARACTER * 1 BDS11(11)
  189. CHARACTER * 1 KBUF(*)
  190. CHARACTER * 1 PDS(*)
  191. CHARACTER * 1 GDS(200)
  192. CHARACTER(1),ALLOCATABLE:: BMS(:)
  193. CHARACTER(1),ALLOCATABLE:: PFLD(:)
  194. CHARACTER(1),ALLOCATABLE:: IPFLD(:)
  195. CHARACTER * 1 SEVEN
  196. CHARACTER * 1 ZERO
  197. C
  198. C
  199. C ASCII REP OF /'G', 'R', 'I', 'B'/
  200. C
  201. DATA IB / 71, 82, 73, 66/
  202. C
  203. IER = 0
  204. IBERR = 0
  205. JERR = 0
  206. IGRIBL = 8
  207. IPDSL = 0
  208. LENGDS = 0
  209. LENBMS = 0
  210. LENBDS = 0
  211. ITOSS = 0
  212. C
  213. C 1.0 PRODUCT DEFINITION SECTION(PDS).
  214. C
  215. C SET ID(6) TO 1 ...OR... MODIFY PDS(8) ...
  216. C REGARDLESS OF USER SPECIFICATION...
  217. C NMC GRIB FIELDS WILL ALWAYS HAVE A GDS
  218. C
  219. IF (IPFLAG .EQ.0) THEN
  220. ID(6) = 1
  221. CALL W3FI68(ID,PDS)
  222. ELSE IF (IPFLAG .EQ. 1) THEN
  223. IF (IAND(mov_a2i(PDS(8)),64) .EQ. 64) THEN
  224. C BOTH GDS AND BMS
  225. PDS(8) = CHAR(192)
  226. ELSE IF (mov_a2i(PDS(8)) .EQ. 0) THEN
  227. C GDS ONLY
  228. PDS(8) = CHAR(128)
  229. END IF
  230. CONTINUE
  231. ELSE
  232. C PRINT *,' W3FI72 ERROR, IPFLAG IS NOT 0 OR 1 IPFLAG = ',IPFLAG
  233. JERR = 1
  234. GO TO 900
  235. END IF
  236. C
  237. C GET LENGTH OF PDS
  238. C
  239. IPDSL = mov_a2i(PDS(1)) * 65536 + mov_a2i(PDS(2)) * 256 +
  240. & mov_a2i(PDS(3))
  241. C
  242. C 2.0 GRID DEFINITION SECTION (GDS).
  243. C
  244. C IF IGFLAG=1 THEN USER IS SUPPLYING THE IGDS INFORMATION
  245. C
  246. IF (IGFLAG .EQ. 0) THEN
  247. CALL W3FI71(IGRID,IGDS,IGERR)
  248. IF (IGERR .EQ. 1) THEN
  249. C PRINT *,' W3FI71 ERROR, GRID TYPE NOT DEFINED...',IGRID
  250. JERR = 4
  251. GO TO 900
  252. END IF
  253. END IF
  254. IF (IGFLAG .EQ. 0 .OR. IGFLAG .EQ.1) THEN
  255. CALL W3FI74(IGDS,ICOMP,GDS,LENGDS,NPTS,IGERR)
  256. IF (IGERR .EQ. 1) THEN
  257. C PRINT *,' W3FI74 ERROR, GRID REP TYPE NOT VALID...',IGDS(3)
  258. JERR = 5
  259. GO TO 900
  260. ELSE
  261. END IF
  262. ELSE
  263. C PRINT *,' W3FI72 ERROR, IGFLAG IS NOT 0 OR 1 IGFLAG = ',IGFLAG
  264. JERR = 2
  265. GO TO 900
  266. END IF
  267. C
  268. C 3.0 BIT MAP SECTION (BMS).
  269. C
  270. C SET ITOSS=1 IF BITMAP BEING USED. W3FI75 WILL TOSS DATA
  271. C PRIOR TO PACKING. LATER CODING WILL BE NEEDED WHEN THE
  272. C 'PREDEFINED' GRIDS ARE FINALLY 'DEFINED'.
  273. C
  274. IF (mov_a2i(PDS(8)) .EQ. 64 .OR.
  275. & mov_a2i(PDS(8)) .EQ. 192) THEN
  276. ITOSS = 1
  277. IF (IBFLAG .EQ. 0) THEN
  278. IF (IBLEN .NE. NPTS) THEN
  279. C PRINT *,' W3FI72 ERROR, IBLEN .NE. NPTS = ',IBLEN,NPTS
  280. JERR = 7
  281. GO TO 900
  282. END IF
  283. IF (MOD(IBLEN,16).NE.0) THEN
  284. NLEFT = 16 - MOD(IBLEN,16)
  285. ELSE
  286. NLEFT = 0
  287. END IF
  288. NUMBMS = 6 + (IBLEN+NLEFT) / 8
  289. ALLOCATE(BMS(NUMBMS))
  290. ZERO = CHAR(00)
  291. BMS = ZERO
  292. CALL W3FI73(IBFLAG,IBMAP,IBLEN,BMS,LENBMS,IER)
  293. IF (IER .NE. 0) THEN
  294. C PRINT *,' W3FI73 ERROR, IBMAP VALUES ARE ALL ZERO'
  295. JERR = 8
  296. GO TO 900
  297. END IF
  298. ELSE
  299. C PRINT *,' BIT MAP PREDEFINED BY CENTER, IBFLAG = ',IBFLAG
  300. END IF
  301. END IF
  302. C
  303. C 4.0 BINARY DATA SECTION (BDS).
  304. C
  305. C 4.1 SCALE THE DATA WITH D-SCALE FROM PDS(27-28)
  306. C
  307. JSCALE = mov_a2i(PDS(27)) * 256 + mov_a2i(PDS(28))
  308. IF (IAND(JSCALE,32768).NE.0) THEN
  309. JSCALE = - IAND(JSCALE,32767)
  310. END IF
  311. SCALE = 10.0 ** JSCALE
  312. IF (ITYPE .EQ. 0) THEN
  313. DO 410 I = 1,NPTS
  314. FLD(I) = FLD(I) * SCALE
  315. 410 CONTINUE
  316. ELSE
  317. DO 411 I = 1,NPTS
  318. IFLD(I) = NINT(FLOAT(IFLD(I)) * SCALE)
  319. 411 CONTINUE
  320. END IF
  321. C
  322. C 4.2 CALL W3FI75 TO PACK DATA AND MAKE BDS.
  323. C
  324. ALLOCATE(PFLD(NPTS*4))
  325. C
  326. IF(IBDSFL(2).NE.0) THEN
  327. ALLOCATE(IPFLD(NPTS*4))
  328. IPFLD=char(0)
  329. ELSE
  330. ALLOCATE(IPFLD(1))
  331. ENDIF
  332. C
  333. CALL W3FI75(IBITL,ITYPE,ITOSS,FLD,IFLD,IBMAP,IBDSFL,
  334. & NPTS,BDS11,IPFLD,PFLD,LEN,LENBDS,IBERR,PDS,IGDS)
  335. C
  336. IF(IBDSFL(2).NE.0) THEN
  337. C CALL XMOVEX(PFLD,IPFLD,NPTS*4)
  338. do ii = 1, NPTS*4
  339. PFLD(ii) = IPFLD(ii)
  340. enddo
  341. ENDIF
  342. DEALLOCATE(IPFLD)
  343. C
  344. IF (IBERR .EQ. 1) THEN
  345. JERR = 3
  346. GO TO 900
  347. END IF
  348. C 4.3 IF D-SCALE NOT 0, RESCALE INPUT FIELD TO
  349. C ORIGINAL VALUE
  350. C
  351. IF (JSCALE.NE.0) THEN
  352. DSCALE = 1.0 / SCALE
  353. IF (ITYPE.EQ.0) THEN
  354. DO 412 I = 1, NPTS
  355. FLD(I) = FLD(I) * DSCALE
  356. 412 CONTINUE
  357. ELSE
  358. DO 413 I = 1, NPTS
  359. FLD(I) = NINT(FLOAT(IFLD(I)) * DSCALE)
  360. 413 CONTINUE
  361. END IF
  362. END IF
  363. C
  364. C 5.0 OUTPUT SECTION.
  365. C
  366. C 5.1 ZERO OUT THE OUTPUT ARRAY KBUF.
  367. C
  368. ZERO = CHAR(00)
  369. ITOT = IGRIBL + IPDSL + LENGDS + LENBMS + LENBDS + 4
  370. C PRINT *,'IGRIBL =',IGRIBL
  371. C PRINT *,'IPDSL =',IPDSL
  372. C PRINT *,'LENGDS =',LENGDS
  373. C PRINT *,'LENBMS =',LENBMS
  374. C PRINT *,'LENBDS =',LENBDS
  375. C PRINT *,'ITOT =',ITOT
  376. KBUF(1:ITOT)=ZERO
  377. C
  378. C 5.2 MOVE SECTION 0 - 'IS' INTO KBUF (8 BYTES).
  379. C
  380. ISTART = 0
  381. DO 520 I = 1,4
  382. KBUF(I) = CHAR(IB(I))
  383. 520 CONTINUE
  384. C
  385. KBUF(5) = CHAR(MOD(ITOT / 65536,256))
  386. KBUF(6) = CHAR(MOD(ITOT / 256,256))
  387. KBUF(7) = CHAR(MOD(ITOT ,256))
  388. KBUF(8) = CHAR(1)
  389. C
  390. C 5.3 MOVE SECTION 1 - 'PDS' INTO KBUF (28 BYTES).
  391. C
  392. ISTART = ISTART + IGRIBL
  393. IF (IPDSL.GT.0) THEN
  394. C CALL XMOVEX(KBUF(ISTART+1),PDS,IPDSL)
  395. do ii = 1, IPDSL
  396. KBUF(ISTART+ii) = PDS(ii)
  397. enddo
  398. ELSE
  399. C PRINT *,'LENGTH OF PDS LESS OR EQUAL 0, IPDSL = ',IPDSL
  400. END IF
  401. C
  402. C 5.4 MOVE SECTION 2 - 'GDS' INTO KBUF.
  403. C
  404. ISTART = ISTART + IPDSL
  405. IF (LENGDS .GT. 0) THEN
  406. C CALL XMOVEX(KBUF(ISTART+1),GDS,LENGDS)
  407. do ii = 1, LENGDS
  408. KBUF(ISTART+ii) = GDS(ii)
  409. enddo
  410. END IF
  411. C
  412. C 5.5 MOVE SECTION 3 - 'BMS' INTO KBUF.
  413. C
  414. ISTART = ISTART + LENGDS
  415. IF (LENBMS .GT. 0) THEN
  416. C CALL XMOVEX(KBUF(ISTART+1),BMS,LENBMS)
  417. do ii = 1, LENBMS
  418. KBUF(ISTART+ii) = BMS(ii)
  419. enddo
  420. END IF
  421. C
  422. C 5.6 MOVE SECTION 4 - 'BDS' INTO KBUF.
  423. C
  424. C MOVE THE FIRST 11 OCTETS OF THE BDS INTO KBUF.
  425. C
  426. ISTART = ISTART + LENBMS
  427. C CALL XMOVEX(KBUF(ISTART+1),BDS11,11)
  428. do ii = 1, 11
  429. KBUF(ISTART+ii) = BDS11(ii)
  430. enddo
  431. C
  432. C MOVE THE PACKED DATA INTO THE KBUF
  433. C
  434. ISTART = ISTART + 11
  435. IF (LEN.GT.0) THEN
  436. C CALL XMOVEX(KBUF(ISTART+1),PFLD,LEN)
  437. do ii = 1, LEN
  438. KBUF(ISTART+ii) = PFLD(ii)
  439. enddo
  440. END IF
  441. C
  442. C ADD '7777' TO END OFF KBUF
  443. C NOTE THAT THESE 4 OCTETS NOT INCLUDED IN ACTUAL SIZE OF BDS.
  444. C
  445. SEVEN = CHAR(55)
  446. ISTART = ITOT - 4
  447. DO 562 I = 1,4
  448. KBUF(ISTART+I) = SEVEN
  449. 562 CONTINUE
  450. C
  451. 900 CONTINUE
  452. IF(ALLOCATED(BMS)) DEALLOCATE(BMS)
  453. IF(ALLOCATED(PFLD)) DEALLOCATE(PFLD)
  454. RETURN
  455. END