NCEPLIBS-g2  3.4.7
pack_gp.f
Go to the documentation of this file.
1 
5 
114  SUBROUTINE pack_gp(KFILDO,IC,NXY,IS523,MINPK,INC,MISSP,MISSS,
115  1 JMIN,JMAX,LBIT,NOV,NDG,LX,IBIT,JBIT,KBIT,
116  2 NOVREF,LBITREF,IER)
117 
118  parameter(mallow=2**30+1)
119 C
120  CHARACTER*1 CFEED
121  LOGICAL ADDA
122 C
123  dimension ic(nxy)
124  dimension jmin(ndg),jmax(ndg),lbit(ndg),nov(ndg)
125  dimension misslx(ndg)
126 C MISSLX( ) IS AN AUTOMATIC ARRAY.
127  INTEGER, PARAMETER :: IBXX2(0:30) = (/ 1, 2, 4, 8, 16, 32, 64, &
128  & 128, 256, 512, 1024, 2048, 4096, 8192, 16384, 32768, 65536, &
129  & 131072, 262144, 524288, 1048576, 2097152, 4194304, 8388608, &
130  & 16777216, 33554432, 67108864, 134217728, 268435456, &
131  & 536870912, 1073741824 /)
132 C
133 
134  parameter(ifeed=12)
135 C
136  ier=0
137  iersav=0
138 C CALL TIMPR(KFILDO,KFILDO,'START PACK_GP ')
139  cfeed=char(ifeed)
140 C
141  ired=0
142 C IRED IS A FLAG. WHEN ZERO, REDUCE WILL BE CALLED.
143 C IF REDUCE ABORTS, IRED = 1 AND IS NOT CALLED. IN
144 C THIS CASE PACK_GP EXECUTES AGAIN EXCEPT FOR REDUCE.
145 C
146  IF(inc.LE.0)THEN
147  iersav=717
148 C WRITE(KFILDO,101)INC
149 C101 FORMAT(/' ****INC ='I8,' NOT CORRECT IN PACK_GP. 1 IS USED.')
150  ENDIF
151 C
152 C THERE WILL BE A RESTART OF PACK_GP IF SUBROUTINE REDUCE
153 C ABORTS. THIS SHOULD NOT HAPPEN, BUT IF IT DOES, PACK_GP
154 C WILL COMPLETE WITHOUT SUBROUTINE REDUCE. A NON FATAL
155 C DIAGNOSTIC RETURN IS PROVIDED.
156 C
157  102 kinc=max(inc,1)
158  lminpk=minpk
159 C
160 C THERE WILL BE A RESTART AT 105 IS NDG IS NOT LARGE ENOUGH.
161 C A NON FATAL DIAGNOSTIC RETURN IS PROVIDED.
162 C
163  105 kstart=1
164  ktotal=0
165  lx=0
166  adda=.false.
167  lmiss=0
168  IF(is523.EQ.1)lmiss=1
169  IF(is523.EQ.2)lmiss=2
170 C
171 C *************************************
172 C
173 C THIS SECTION COMPUTES STATISTICS FOR GROUP A. GROUP A IS
174 C A GROUP OF SIZE LMINPK.
175 C
176 C *************************************
177 C
178  ibita=0
179  mina=mallow
180  maxa=-mallow
181  minak=mallow
182  maxak=-mallow
183 C
184 C FIND THE MIN AND MAX OF GROUP A. THIS WILL INITIALLY BE OF
185 C SIZE LMINPK (IF THERE ARE STILL LMINPK VALUES IN IC( )), BUT
186 C WILL INCREASE IN SIZE IN INCREMENTS OF INC UNTIL A NEW
187 C GROUP IS STARTED. THE DEFINITION OF GROUP A IS DONE HERE
188 C ONLY ONCE (UPON INITIAL ENTRY), BECAUSE A GROUP B CAN ALWAYS
189 C BECOME A NEW GROUP A AFTER A IS PACKED, EXCEPT IF LMINPK
190 C HAS TO BE INCREASED BECAUSE NDG IS TOO SMALL. THEREFORE,
191 C THE SEPARATE LOOPS FOR MISSING AND NON-MISSING HERE BUYS
192 C ALMOST NOTHING.
193 C
194  nenda=min(kstart+lminpk-1,nxy)
195  IF(nxy-nenda.LE.lminpk/2)nenda=nxy
196 C ABOVE STATEMENT GUARANTEES THE LAST GROUP IS GT LMINPK/2 BY
197 C MAKING THE ACTUAL GROUP LARGER. IF A PROVISION LIKE THIS IS
198 C NOT INCLUDED, THERE WILL MANY TIMES BE A VERY SMALL GROUP
199 C AT THE END. USE SEPARATE LOOPS FOR MISSING AND NO MISSING
200 C VALUES FOR EFFICIENCY.
201 C
202 C DETERMINE WHETHER THERE IS A LONG STRING OF THE SAME VALUE
203 C UNLESS NENDA = NXY. THIS MAY ALLOW A LARGE GROUP A TO
204 C START WITH, AS WITH MISSING VALUES. SEPARATE LOOPS FOR
205 C MISSING OPTIONS. THIS SECTION IS ONLY EXECUTED ONCE,
206 C IN DETERMINING THE FIRST GROUP. IT HELPS FOR AN ARRAY
207 C OF MOSTLY MISSING VALUES OR OF ONE VALUE, SUCH AS
208 C RADAR OR PRECIP DATA.
209 C
210  IF(nenda.NE.nxy.AND.ic(kstart).EQ.ic(kstart+1))THEN
211 C NO NEED TO EXECUTE IF FIRST TWO VALUES ARE NOT EQUAL.
212 C
213  IF(is523.EQ.0)THEN
214 C THIS LOOP IS FOR NO MISSING VALUES.
215 C
216  DO 111 k=kstart+1,nxy
217 C
218  IF(ic(k).NE.ic(kstart))THEN
219  nenda=max(nenda,k-1)
220  GO TO 114
221  ENDIF
222 C
223  111 CONTINUE
224 C
225  nenda=nxy
226 C FALL THROUGH THE LOOP MEANS ALL VALUES ARE THE SAME.
227 C
228  ELSEIF(is523.EQ.1)THEN
229 C THIS LOOP IS FOR PRIMARY MISSING VALUES ONLY.
230 C
231  DO 112 k=kstart+1,nxy
232 C
233  IF(ic(k).NE.missp)THEN
234 C
235  IF(ic(k).NE.ic(kstart))THEN
236  nenda=max(nenda,k-1)
237  GO TO 114
238  ENDIF
239 C
240  ENDIF
241 C
242  112 CONTINUE
243 C
244  nenda=nxy
245 C FALL THROUGH THE LOOP MEANS ALL VALUES ARE THE SAME.
246 C
247  ELSE
248 C THIS LOOP IS FOR PRIMARY AND SECONDARY MISSING VALUES.
249 C
250  DO 113 k=kstart+1,nxy
251 C
252  IF(ic(k).NE.missp.AND.ic(k).NE.misss)THEN
253 C
254  IF(ic(k).NE.ic(kstart))THEN
255  nenda=max(nenda,k-1)
256  GO TO 114
257  ENDIF
258 C
259  ENDIF
260 C
261  113 CONTINUE
262 C
263  nenda=nxy
264 C FALL THROUGH THE LOOP MEANS ALL VALUES ARE THE SAME.
265  ENDIF
266 C
267  ENDIF
268 C
269  114 IF(is523.EQ.0)THEN
270 C
271  DO 115 k=kstart,nenda
272  IF(ic(k).LT.mina)THEN
273  mina=ic(k)
274  minak=k
275  ENDIF
276  IF(ic(k).GT.maxa)THEN
277  maxa=ic(k)
278  maxak=k
279  ENDIF
280  115 CONTINUE
281 C
282  ELSEIF(is523.EQ.1)THEN
283 C
284  DO 117 k=kstart,nenda
285  IF(ic(k).EQ.missp)GO TO 117
286  IF(ic(k).LT.mina)THEN
287  mina=ic(k)
288  minak=k
289  ENDIF
290  IF(ic(k).GT.maxa)THEN
291  maxa=ic(k)
292  maxak=k
293  ENDIF
294  117 CONTINUE
295 C
296  ELSE
297 C
298  DO 120 k=kstart,nenda
299  IF(ic(k).EQ.missp.OR.ic(k).EQ.misss)GO TO 120
300  IF(ic(k).LT.mina)THEN
301  mina=ic(k)
302  minak=k
303  ENDIF
304  IF(ic(k).GT.maxa)THEN
305  maxa=ic(k)
306  maxak=k
307  ENDIF
308  120 CONTINUE
309 C
310  ENDIF
311 C
312  kounta=nenda-kstart+1
313 C
314 C INCREMENT KTOTAL AND FIND THE BITS NEEDED TO PACK THE A GROUP.
315 C
316  ktotal=ktotal+kounta
317  mislla=0
318  IF(mina.NE.mallow)GO TO 125
319 C ALL MISSING VALUES MUST BE ACCOMMODATED.
320  mina=0
321  maxa=0
322  mislla=1
323  ibitb=0
324  IF(is523.NE.2)GO TO 130
325 C WHEN ALL VALUES ARE MISSING AND THERE ARE NO
326 C SECONDARY MISSING VALUES, IBITA = 0.
327 C OTHERWISE, IBITA MUST BE CALCULATED.
328 C
329  125 itest=maxa-mina+lmiss
330 C
331  DO 126 ibita=0,30
332  IF(itest.LT.ibxx2(ibita))GO TO 130
333 C*** THIS TEST IS THE SAME AS:
334 C*** IF(MAXA-MINA.LT.IBXX2(IBITA)-LMISS)GO TO 130
335  126 CONTINUE
336 C
337 C WRITE(KFILDO,127)MAXA,MINA
338 C127 FORMAT(' ****ERROR IN PACK_GP. VALUE WILL NOT PACK IN 30 BITS.',
339 C 1 ' MAXA ='I13,' MINA ='I13,'. ERROR AT 127.')
340  ier=706
341  GO TO 900
342 C
343  130 CONTINUE
344 C
345 C***D WRITE(KFILDO,131)KOUNTA,KTOTAL,MINA,MAXA,IBITA,MISLLA
346 C***D131 FORMAT(' AT 130, KOUNTA ='I8,' KTOTAL ='I8,' MINA ='I8,
347 C***D 1 ' MAXA ='I8,' IBITA ='I3,' MISLLA ='I3)
348 C
349  133 IF(ktotal.GE.nxy)GO TO 200
350 C
351 C *************************************
352 C
353 C THIS SECTION COMPUTES STATISTICS FOR GROUP B. GROUP B IS A
354 C GROUP OF SIZE LMINPK IMMEDIATELY FOLLOWING GROUP A.
355 C
356 C *************************************
357 C
358  140 minb=mallow
359  maxb=-mallow
360  minbk=mallow
361  maxbk=-mallow
362  ibitbs=0
363  mstart=ktotal+1
364 C
365 C DETERMINE WHETHER THERE IS A LONG STRING OF THE SAME VALUE.
366 C THIS WORKS WHEN THERE ARE NO MISSING VALUES.
367 C
368  nendb=1
369 C
370  IF(mstart.LT.nxy)THEN
371 C
372  IF(is523.EQ.0)THEN
373 C THIS LOOP IS FOR NO MISSING VALUES.
374 C
375  DO 145 k=mstart+1,nxy
376 C
377  IF(ic(k).NE.ic(mstart))THEN
378  nendb=k-1
379  GO TO 150
380  ENDIF
381 C
382  145 CONTINUE
383 C
384  nendb=nxy
385 C FALL THROUGH THE LOOP MEANS ALL REMAINING VALUES
386 C ARE THE SAME.
387  ENDIF
388 C
389  ENDIF
390 C
391  150 nendb=max(nendb,min(ktotal+lminpk,nxy))
392 C**** 150 NENDB=MIN(KTOTAL+LMINPK,NXY)
393 C
394  IF(nxy-nendb.LE.lminpk/2)nendb=nxy
395 C ABOVE STATEMENT GUARANTEES THE LAST GROUP IS GT LMINPK/2 BY
396 C MAKING THE ACTUAL GROUP LARGER. IF A PROVISION LIKE THIS IS
397 C NOT INCLUDED, THERE WILL MANY TIMES BE A VERY SMALL GROUP
398 C AT THE END. USE SEPARATE LOOPS FOR MISSING AND NO MISSING
399 C
400 C USE SEPARATE LOOPS FOR MISSING AND NO MISSING VALUES
401 C FOR EFFICIENCY.
402 C
403  IF(is523.EQ.0)THEN
404 C
405  DO 155 k=mstart,nendb
406  IF(ic(k).LE.minb)THEN
407  minb=ic(k)
408 C NOTE LE, NOT LT. LT COULD BE USED BUT THEN A
409 C RECOMPUTE OVER THE WHOLE GROUP WOULD BE NEEDED
410 C MORE OFTEN. SAME REASONING FOR GE AND OTHER
411 C LOOPS BELOW.
412  minbk=k
413  ENDIF
414  IF(ic(k).GE.maxb)THEN
415  maxb=ic(k)
416  maxbk=k
417  ENDIF
418  155 CONTINUE
419 C
420  ELSEIF(is523.EQ.1)THEN
421 C
422  DO 157 k=mstart,nendb
423  IF(ic(k).EQ.missp)GO TO 157
424  IF(ic(k).LE.minb)THEN
425  minb=ic(k)
426  minbk=k
427  ENDIF
428  IF(ic(k).GE.maxb)THEN
429  maxb=ic(k)
430  maxbk=k
431  ENDIF
432  157 CONTINUE
433 C
434  ELSE
435 C
436  DO 160 k=mstart,nendb
437  IF(ic(k).EQ.missp.OR.ic(k).EQ.misss)GO TO 160
438  IF(ic(k).LE.minb)THEN
439  minb=ic(k)
440  minbk=k
441  ENDIF
442  IF(ic(k).GE.maxb)THEN
443  maxb=ic(k)
444  maxbk=k
445  ENDIF
446  160 CONTINUE
447 C
448  ENDIF
449 C
450  kountb=nendb-ktotal
451  misllb=0
452  IF(minb.NE.mallow)GO TO 165
453 C ALL MISSING VALUES MUST BE ACCOMMODATED.
454  minb=0
455  maxb=0
456  misllb=1
457  ibitb=0
458 C
459  IF(is523.NE.2)GO TO 170
460 C WHEN ALL VALUES ARE MISSING AND THERE ARE NO SECONDARY
461 C MISSING VALUES, IBITB = 0. OTHERWISE, IBITB MUST BE
462 C CALCULATED.
463 C
464  165 DO 166 ibitb=ibitbs,30
465  IF(maxb-minb.LT.ibxx2(ibitb)-lmiss)GO TO 170
466  166 CONTINUE
467 C
468 C WRITE(KFILDO,167)MAXB,MINB
469 C167 FORMAT(' ****ERROR IN PACK_GP. VALUE WILL NOT PACK IN 30 BITS.',
470 C 1 ' MAXB ='I13,' MINB ='I13,'. ERROR AT 167.')
471  ier=706
472  GO TO 900
473 C
474 C COMPARE THE BITS NEEDED TO PACK GROUP B WITH THOSE NEEDED
475 C TO PACK GROUP A. IF IBITB GE IBITA, TRY TO ADD TO GROUP A.
476 C IF NOT, TRY TO ADD A'S POINTS TO B, UNLESS ADDITION TO A
477 C HAS BEEN DONE. THIS LATTER IS CONTROLLED WITH ADDA.
478 C
479  170 CONTINUE
480 C
481 C***D WRITE(KFILDO,171)KOUNTA,KTOTAL,MINA,MAXA,IBITA,MISLLA,
482 C***D 1 MINB,MAXB,IBITB,MISLLB
483 C***D171 FORMAT(' AT 171, KOUNTA ='I8,' KTOTAL ='I8,' MINA ='I8,
484 C***D 1 ' MAXA ='I8,' IBITA ='I3,' MISLLA ='I3,
485 C***D 2 ' MINB ='I8,' MAXB ='I8,' IBITB ='I3,' MISLLB ='I3)
486 C
487  IF(ibitb.GE.ibita)GO TO 180
488  IF(adda)GO TO 200
489 C
490 C *************************************
491 C
492 C GROUP B REQUIRES LESS BITS THAN GROUP A. PUT AS MANY OF A'S
493 C POINTS INTO B AS POSSIBLE WITHOUT EXCEEDING THE NUMBER OF
494 C BITS NECESSARY TO PACK GROUP B.
495 C
496 C *************************************
497 C
498  kounts=kounta
499 C KOUNTA REFERS TO THE PRESENT GROUP A.
500  mintst=minb
501  maxtst=maxb
502  mintstk=minbk
503  maxtstk=maxbk
504 C
505 C USE SEPARATE LOOPS FOR MISSING AND NO MISSING VALUES
506 C FOR EFFICIENCY.
507 C
508  IF(is523.EQ.0)THEN
509 C
510  DO 1715 k=ktotal,kstart,-1
511 C START WITH THE END OF THE GROUP AND WORK BACKWARDS.
512  IF(ic(k).LT.minb)THEN
513  mintst=ic(k)
514  mintstk=k
515  ELSEIF(ic(k).GT.maxb)THEN
516  maxtst=ic(k)
517  maxtstk=k
518  ENDIF
519  IF(maxtst-mintst.GE.ibxx2(ibitb))GO TO 174
520 C NOTE THAT FOR THIS LOOP, LMISS = 0.
521  minb=mintst
522  maxb=maxtst
523  minbk=mintstk
524  maxbk=maxtstk
525  kounta=kounta-1
526 C THERE IS ONE LESS POINT NOW IN A.
527  1715 CONTINUE
528 C
529  ELSEIF(is523.EQ.1)THEN
530 C
531  DO 1719 k=ktotal,kstart,-1
532 C START WITH THE END OF THE GROUP AND WORK BACKWARDS.
533  IF(ic(k).EQ.missp)GO TO 1718
534  IF(ic(k).LT.minb)THEN
535  mintst=ic(k)
536  mintstk=k
537  ELSEIF(ic(k).GT.maxb)THEN
538  maxtst=ic(k)
539  maxtstk=k
540  ENDIF
541  IF(maxtst-mintst.GE.ibxx2(ibitb)-lmiss)GO TO 174
542 C FOR THIS LOOP, LMISS = 1.
543  minb=mintst
544  maxb=maxtst
545  minbk=mintstk
546  maxbk=maxtstk
547  misllb=0
548 C WHEN THE POINT IS NON MISSING, MISLLB SET = 0.
549  1718 kounta=kounta-1
550 C THERE IS ONE LESS POINT NOW IN A.
551  1719 CONTINUE
552 C
553  ELSE
554 C
555  DO 173 k=ktotal,kstart,-1
556 C START WITH THE END OF THE GROUP AND WORK BACKWARDS.
557  IF(ic(k).EQ.missp.OR.ic(k).EQ.misss)GO TO 1729
558  IF(ic(k).LT.minb)THEN
559  mintst=ic(k)
560  mintstk=k
561  ELSEIF(ic(k).GT.maxb)THEN
562  maxtst=ic(k)
563  maxtstk=k
564  ENDIF
565  IF(maxtst-mintst.GE.ibxx2(ibitb)-lmiss)GO TO 174
566 C FOR THIS LOOP, LMISS = 2.
567  minb=mintst
568  maxb=maxtst
569  minbk=mintstk
570  maxbk=maxtstk
571  misllb=0
572 C WHEN THE POINT IS NON MISSING, MISLLB SET = 0.
573  1729 kounta=kounta-1
574 C THERE IS ONE LESS POINT NOW IN A.
575  173 CONTINUE
576 C
577  ENDIF
578 C
579 C AT THIS POINT, KOUNTA CONTAINS THE NUMBER OF POINTS TO CLOSE
580 C OUT GROUP A WITH. GROUP B NOW STARTS WITH KSTART+KOUNTA AND
581 C ENDS WITH NENDB. MINB AND MAXB HAVE BEEN ADJUSTED AS
582 C NECESSARY TO REFLECT GROUP B (EVEN THOUGH THE NUMBER OF BITS
583 C NEEDED TO PACK GROUP B HAVE NOT INCREASED, THE END POINTS
584 C OF THE RANGE MAY HAVE).
585 C
586  174 IF(kounta.EQ.kounts)GO TO 200
587 C ON TRANSFER, GROUP A WAS NOT CHANGED. CLOSE IT OUT.
588 C
589 C ONE OR MORE POINTS WERE TAKEN OUT OF A. RANGE AND IBITA
590 C MAY HAVE TO BE RECOMPUTED; IBITA COULD BE LESS THAN
591 C ORIGINALLY COMPUTED. IN FACT, GROUP A CAN NOW CONTAIN
592 C ONLY ONE POINT AND BE PACKED WITH ZERO BITS
593 C (UNLESS MISSS NE 0).
594 C
595  nouta=kounts-kounta
596  ktotal=ktotal-nouta
597  kountb=kountb+nouta
598  IF(nenda-nouta.GT.minak.AND.nenda-nouta.GT.maxak)GO TO 200
599 C WHEN THE ABOVE TEST IS MET, THE MIN AND MAX OF THE
600 C CURRENT GROUP A WERE WITHIN THE OLD GROUP A, SO THE
601 C RANGE AND IBITA DO NOT NEED TO BE RECOMPUTED.
602 C NOTE THAT MINAK AND MAXAK ARE NO LONGER NEEDED.
603  ibita=0
604  mina=mallow
605  maxa=-mallow
606 C
607 C USE SEPARATE LOOPS FOR MISSING AND NO MISSING VALUES
608 C FOR EFFICIENCY.
609 C
610  IF(is523.EQ.0)THEN
611 C
612  DO 1742 k=kstart,nenda-nouta
613  IF(ic(k).LT.mina)THEN
614  mina=ic(k)
615  ENDIF
616  IF(ic(k).GT.maxa)THEN
617  maxa=ic(k)
618  ENDIF
619  1742 CONTINUE
620 C
621  ELSEIF(is523.EQ.1)THEN
622 C
623  DO 1744 k=kstart,nenda-nouta
624  IF(ic(k).EQ.missp)GO TO 1744
625  IF(ic(k).LT.mina)THEN
626  mina=ic(k)
627  ENDIF
628  IF(ic(k).GT.maxa)THEN
629  maxa=ic(k)
630  ENDIF
631  1744 CONTINUE
632 C
633  ELSE
634 C
635  DO 175 k=kstart,nenda-nouta
636  IF(ic(k).EQ.missp.OR.ic(k).EQ.misss)GO TO 175
637  IF(ic(k).LT.mina)THEN
638  mina=ic(k)
639  ENDIF
640  IF(ic(k).GT.maxa)THEN
641  maxa=ic(k)
642  ENDIF
643  175 CONTINUE
644 C
645  ENDIF
646 C
647  mislla=0
648  IF(mina.NE.mallow)GO TO 1750
649 C ALL MISSING VALUES MUST BE ACCOMMODATED.
650  mina=0
651  maxa=0
652  mislla=1
653  IF(is523.NE.2)GO TO 177
654 C WHEN ALL VALUES ARE MISSING AND THERE ARE NO SECONDARY
655 C MISSING VALUES IBITA = 0 AS ORIGINALLY SET. OTHERWISE,
656 C IBITA MUST BE CALCULATED.
657 C
658  1750 itest=maxa-mina+lmiss
659 C
660  DO 176 ibita=0,30
661  IF(itest.LT.ibxx2(ibita))GO TO 177
662 C*** THIS TEST IS THE SAME AS:
663 C*** IF(MAXA-MINA.LT.IBXX2(IBITA)-LMISS)GO TO 177
664  176 CONTINUE
665 C
666 C WRITE(KFILDO,1760)MAXA,MINA
667 C1760 FORMAT(' ****ERROR IN PACK_GP. VALUE WILL NOT PACK IN 30 BITS.',
668 C 1 ' MAXA ='I13,' MINA ='I13,'. ERROR AT 1760.')
669  ier=706
670  GO TO 900
671 C
672  177 CONTINUE
673  GO TO 200
674 C
675 C *************************************
676 C
677 C AT THIS POINT, GROUP B REQUIRES AS MANY BITS TO PACK AS GROUPA.
678 C THEREFORE, TRY TO ADD INC POINTS TO GROUP A WITHOUT INCREASING
679 C IBITA. THIS AUGMENTED GROUP IS CALLED GROUP C.
680 C
681 C *************************************
682 C
683  180 IF(mislla.EQ.1)THEN
684  minc=mallow
685  minck=mallow
686  maxc=-mallow
687  maxck=-mallow
688  ELSE
689  minc=mina
690  maxc=maxa
691  minck=minak
692  maxck=minak
693  ENDIF
694 C
695  nount=0
696  IF(nxy-(ktotal+kinc).LE.lminpk/2)kinc=nxy-ktotal
697 C ABOVE STATEMENT CONSTRAINS THE LAST GROUP TO BE NOT LESS THAN
698 C LMINPK/2 IN SIZE. IF A PROVISION LIKE THIS IS NOT INCLUDED,
699 C THERE WILL MANY TIMES BE A VERY SMALL GROUP AT THE END.
700 C
701 C USE SEPARATE LOOPS FOR MISSING AND NO MISSING VALUES
702 C FOR EFFICIENCY. SINCE KINC IS USUALLY 1, USING SEPARATE
703 C LOOPS HERE DOESN'T BUY MUCH. A MISSING VALUE WILL ALWAYS
704 C TRANSFER BACK TO GROUP A.
705 C
706  IF(is523.EQ.0)THEN
707 C
708  DO 185 k=ktotal+1,min(ktotal+kinc,nxy)
709  IF(ic(k).LT.minc)THEN
710  minc=ic(k)
711  minck=k
712  ENDIF
713  IF(ic(k).GT.maxc)THEN
714  maxc=ic(k)
715  maxck=k
716  ENDIF
717  nount=nount+1
718  185 CONTINUE
719 C
720  ELSEIF(is523.EQ.1)THEN
721 C
722  DO 187 k=ktotal+1,min(ktotal+kinc,nxy)
723  IF(ic(k).EQ.missp)GO TO 186
724  IF(ic(k).LT.minc)THEN
725  minc=ic(k)
726  minck=k
727  ENDIF
728  IF(ic(k).GT.maxc)THEN
729  maxc=ic(k)
730  maxck=k
731  ENDIF
732  186 nount=nount+1
733  187 CONTINUE
734 C
735  ELSE
736 C
737  DO 190 k=ktotal+1,min(ktotal+kinc,nxy)
738  IF(ic(k).EQ.missp.OR.ic(k).EQ.misss)GO TO 189
739  IF(ic(k).LT.minc)THEN
740  minc=ic(k)
741  minck=k
742  ENDIF
743  IF(ic(k).GT.maxc)THEN
744  maxc=ic(k)
745  maxck=k
746  ENDIF
747  189 nount=nount+1
748  190 CONTINUE
749 C
750  ENDIF
751 C
752 C***D WRITE(KFILDO,191)KOUNTA,KTOTAL,MINA,MAXA,IBITA,MISLLA,
753 C***D 1 MINC,MAXC,NOUNT,IC(KTOTAL),IC(KTOTAL+1)
754 C***D191 FORMAT(' AT 191, KOUNTA ='I8,' KTOTAL ='I8,' MINA ='I8,
755 C***D 1 ' MAXA ='I8,' IBITA ='I3,' MISLLA ='I3,
756 C***D 2 ' MINC ='I8,' MAXC ='I8,
757 C***D 3 ' NOUNT ='I5,' IC(KTOTAL) ='I9,' IC(KTOTAL+1) =',I9)
758 C
759 C IF THE NUMBER OF BITS NEEDED FOR GROUP C IS GT IBITA,
760 C THEN THIS GROUP A IS A GROUP TO PACK.
761 C
762  IF(minc.EQ.mallow)THEN
763  minc=mina
764  maxc=maxa
765  minck=minak
766  maxck=maxak
767  misllc=1
768  GO TO 195
769 C WHEN THE NEW VALUE(S) ARE MISSING, THEY CAN ALWAYS
770 C BE ADDED.
771 C
772  ELSE
773  misllc=0
774  ENDIF
775 C
776  IF(maxc-minc.GE.ibxx2(ibita)-lmiss) GO TO 200
777 C
778 C THE BITS NECESSARY FOR GROUP C HAS NOT INCREASED FROM THE
779 C BITS NECESSARY FOR GROUP A. ADD THIS POINT(S) TO GROUP A.
780 C COMPUTE THE NEXT GROUP B, ETC., UNLESS ALL POINTS HAVE BEEN
781 C USED.
782 C
783  195 ktotal=ktotal+nount
784  kounta=kounta+nount
785  mina=minc
786  maxa=maxc
787  minak=minck
788  maxak=maxck
789  mislla=misllc
790  adda=.true.
791  IF(ktotal.GE.nxy)GO TO 200
792 C
793  IF(minbk.GT.ktotal.AND.maxbk.GT.ktotal)THEN
794  mstart=nendb+1
795 C THE MAX AND MIN OF GROUP B WERE NOT FROM THE POINTS
796 C REMOVED, SO THE WHOLE GROUP DOES NOT HAVE TO BE LOOKED
797 C AT TO DETERMINE THE NEW MAX AND MIN. RATHER START
798 C JUST BEYOND THE OLD NENDB.
799  ibitbs=ibitb
800  nendb=1
801  GO TO 150
802  ELSE
803  GO TO 140
804  ENDIF
805 C
806 C *************************************
807 C
808 C GROUP A IS TO BE PACKED. STORE VALUES IN JMIN( ), JMAX( ),
809 C LBIT( ), AND NOV( ).
810 C
811 C *************************************
812 C
813  200 lx=lx+1
814  IF(lx.LE.ndg)GO TO 205
815  lminpk=lminpk+lminpk/2
816 C WRITE(KFILDO,201)NDG,LMINPK,LX
817 C201 FORMAT(' ****NDG ='I5,' NOT LARGE ENOUGH.',
818 C 1 ' LMINPK IS INCREASED TO 'I3,' FOR THIS FIELD.'/
819 C 2 ' LX = 'I10)
820  iersav=716
821  GO TO 105
822 C
823  205 jmin(lx)=mina
824  jmax(lx)=maxa
825  lbit(lx)=ibita
826  nov(lx)=kounta
827  kstart=ktotal+1
828 C
829  IF(mislla.EQ.0)THEN
830  misslx(lx)=mallow
831  ELSE
832  misslx(lx)=ic(ktotal)
833 C IC(KTOTAL) WAS THE LAST VALUE PROCESSED. IF MISLLA NE 0,
834 C THIS MUST BE THE MISSING VALUE FOR THIS GROUP.
835  ENDIF
836 C
837 C***D WRITE(KFILDO,206)MISLLA,IC(KTOTAL),KTOTAL,LX,JMIN(LX),JMAX(LX),
838 C***D 1 LBIT(LX),NOV(LX),MISSLX(LX)
839 C***D206 FORMAT(' AT 206, MISLLA ='I2,' IC(KTOTAL) ='I5,' KTOTAL ='I8,
840 C***D 1 ' LX ='I6,' JMIN(LX) ='I8,' JMAX(LX) ='I8,
841 C***D 2 ' LBIT(LX) ='I5,' NOV(LX) ='I8,' MISSLX(LX) =',I7)
842 C
843  IF(ktotal.GE.nxy)GO TO 209
844 C
845 C THE NEW GROUP A WILL BE THE PREVIOUS GROUP B. SET LIMITS, ETC.
846 C
847  ibita=ibitb
848  mina=minb
849  maxa=maxb
850  minak=minbk
851  maxak=maxbk
852  mislla=misllb
853  nenda=nendb
854  kounta=kountb
855  ktotal=ktotal+kounta
856  adda=.false.
857  GO TO 133
858 C
859 C *************************************
860 C
861 C CALCULATE IBIT, THE NUMBER OF BITS NEEDED TO HOLD THE GROUP
862 C MINIMUM VALUES.
863 C
864 C *************************************
865 C
866  209 ibit=0
867 C
868  DO 220 l=1,lx
869  210 IF(jmin(l).LT.ibxx2(ibit))GO TO 220
870  ibit=ibit+1
871  GO TO 210
872  220 CONTINUE
873 C
874 C INSERT THE VALUE IN JMIN( ) TO BE USED FOR ALL MISSING
875 C VALUES WHEN LBIT( ) = 0. WHEN SECONDARY MISSING
876 C VALUES CAN BE PRESENT, LBIT(L) WILL NOT = 0.
877 C
878  IF(is523.EQ.1)THEN
879 C
880  DO 226 l=1,lx
881 C
882  IF(lbit(l).EQ.0)THEN
883 C
884  IF(misslx(l).EQ.missp)THEN
885  jmin(l)=ibxx2(ibit)-1
886  ENDIF
887 C
888  ENDIF
889 C
890  226 CONTINUE
891 C
892  ENDIF
893 C
894 C *************************************
895 C
896 C CALCULATE JBIT, THE NUMBER OF BITS NEEDED TO HOLD THE BITS
897 C NEEDED TO PACK THE VALUES IN THE GROUPS. BUT FIND AND
898 C REMOVE THE REFERENCE VALUE FIRST.
899 C
900 C *************************************
901 C
902 C WRITE(KFILDO,228)CFEED,LX
903 C228 FORMAT(A1,/' *****************************************'
904 C 1 /' THE GROUP WIDTHS LBIT( ) FOR ',I8,' GROUPS'
905 C 2 /' *****************************************')
906 C WRITE(KFILDO,229) (LBIT(J),J=1,MIN(LX,100))
907 C229 FORMAT(/' '20I6)
908 C
909  lbitref=lbit(1)
910 C
911  DO 230 k=1,lx
912  IF(lbit(k).LT.lbitref)lbitref=lbit(k)
913  230 CONTINUE
914 C
915  IF(lbitref.NE.0)THEN
916 C
917  DO 240 k=1,lx
918  lbit(k)=lbit(k)-lbitref
919  240 CONTINUE
920 C
921  ENDIF
922 C
923 C WRITE(KFILDO,241)CFEED,LBITREF
924 C241 FORMAT(A1,/' *****************************************'
925 C 1 /' THE GROUP WIDTHS LBIT( ) AFTER REMOVING REFERENCE ',
926 C 2 I8,
927 C 3 /' *****************************************')
928 C WRITE(KFILDO,242) (LBIT(J),J=1,MIN(LX,100))
929 C242 FORMAT(/' '20I6)
930 C
931  jbit=0
932 C
933  DO 320 k=1,lx
934  310 IF(lbit(k).LT.ibxx2(jbit))GO TO 320
935  jbit=jbit+1
936  GO TO 310
937  320 CONTINUE
938 C
939 C *************************************
940 C
941 C CALCULATE KBIT, THE NUMBER OF BITS NEEDED TO HOLD THE NUMBER
942 C OF VALUES IN THE GROUPS. BUT FIND AND REMOVE THE
943 C REFERENCE FIRST.
944 C
945 C *************************************
946 C
947 C WRITE(KFILDO,321)CFEED,LX
948 C321 FORMAT(A1,/' *****************************************'
949 C 1 /' THE GROUP SIZES NOV( ) FOR ',I8,' GROUPS'
950 C 2 /' *****************************************')
951 C WRITE(KFILDO,322) (NOV(J),J=1,MIN(LX,100))
952 C322 FORMAT(/' '20I6)
953 C
954  novref=nov(1)
955 C
956  DO 400 k=1,lx
957  IF(nov(k).LT.novref)novref=nov(k)
958  400 CONTINUE
959 C
960  IF(novref.GT.0)THEN
961 C
962  DO 405 k=1,lx
963  nov(k)=nov(k)-novref
964  405 CONTINUE
965 C
966  ENDIF
967 C
968 C WRITE(KFILDO,406)CFEED,NOVREF
969 C406 FORMAT(A1,/' *****************************************'
970 C 1 /' THE GROUP SIZES NOV( ) AFTER REMOVING REFERENCE ',I8,
971 C 2 /' *****************************************')
972 C WRITE(KFILDO,407) (NOV(J),J=1,MIN(LX,100))
973 C407 FORMAT(/' '20I6)
974 C WRITE(KFILDO,408)CFEED
975 C408 FORMAT(A1,/' *****************************************'
976 C 1 /' THE GROUP REFERENCES JMIN( )'
977 C 2 /' *****************************************')
978 C WRITE(KFILDO,409) (JMIN(J),J=1,MIN(LX,100))
979 C409 FORMAT(/' '20I6)
980 C
981  kbit=0
982 C
983  DO 420 k=1,lx
984  410 IF(nov(k).LT.ibxx2(kbit))GO TO 420
985  kbit=kbit+1
986  GO TO 410
987  420 CONTINUE
988 C
989 C DETERMINE WHETHER THE GROUP SIZES SHOULD BE REDUCED
990 C FOR SPACE EFFICIENCY.
991 C
992  IF(ired.EQ.0)THEN
993  CALL reduce(kfildo,jmin,jmax,lbit,nov,lx,ndg,ibit,jbit,kbit,
994  1 novref,ibxx2,ier)
995 C
996  IF(ier.EQ.714.OR.ier.EQ.715)THEN
997 C REDUCE HAS ABORTED. REEXECUTE PACK_GP WITHOUT REDUCE.
998 C PROVIDE FOR A NON FATAL RETURN FROM REDUCE.
999  iersav=ier
1000  ired=1
1001  ier=0
1002  GO TO 102
1003  ENDIF
1004 C
1005  ENDIF
1006 C
1007 C CALL TIMPR(KFILDO,KFILDO,'END PACK_GP ')
1008  IF(iersav.NE.0)THEN
1009  ier=iersav
1010  RETURN
1011  ENDIF
1012 C
1013 C 900 IF(IER.NE.0)RETURN1
1014 C
1015  900 RETURN
1016  END
pack_gp
subroutine pack_gp(KFILDO, IC, NXY, IS523, MINPK, INC, MISSP, MISSS, JMIN, JMAX, LBIT, NOV, NDG, LX, IBIT, JBIT, KBIT, NOVREF, LBITREF, IER)
This subroutine determines groups of variable size, but at least of size minpk, the associated max(JM...
Definition: pack_gp.f:117
reduce
subroutine reduce(KFILDO, JMIN, JMAX, LBIT, NOV, LX, NDG, IBIT, JBIT, KBIT, NOVREF, IBXX2, IER)
This subroutine determines whether the number of groups should be increased in order to reduce the si...
Definition: reduce.f:44