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