MINICERN/packlib/kernlib/kerngen/tcgens/pkchar.F

   1 *
   2 * $Id$
   3 *
   4 * $Log$
   5 * Revision 1.1.1.1  1996/02/15 17:50:13  mclareni
   6 * Kernlib
   7 *
   8 *
   9 #include "kerngen/pilot.h"
  10       SUBROUTINE PKCHAR (IGV,ICHV,NN,IPAR)
  11 C
  12 C CERN PROGLIB# M427    PKCHAR          .VERSION KERNFOR  4.20  881028
  13 C ORIG. 07/07/72 JZ
  14 C
  15       COMMON /SLATE/ JCH,N,NBITS,NCHAR,NZONE,IGNOR,JIN,NBDONE,NBEND
  16      +,              JGO,JBT,NLEFT,NRIGH,DUMMY(27)
  17       DIMENSION ICHV(*),IGV(*),IPAR(9)
  18 C                .
  19 C
  20 #include "kerngen/wordsize.inc"
  21 C
  22 C
  23       N = NN
  24       IF (N.EQ.0)  RETURN
  25       NBITS = IPAR(1)
  26       NCHAR = IPAR(2)
  27       NZONE = IPAR(3)
  28       IGNOR = IPAR(4)
  29       NFILL = IPAR(5)
  30       JIN = 1
  31       JCH = 1
  32       ICHV(1)= NFILL
  33       IF (NZONE.NE.0)  GO TO 41
  34 C
  35 C----              ZONE = WORD
  36 C
  37    21 JGO  = NBITPW+1 - IGNOR
  38       NBEND= NBITS + 1
  39       IF (NCHAR.EQ.0)  GO TO 22
  40       NBEND = MAX (NBEND,JGO-NBITS*(NCHAR-1))
  41 C
  42    22 JBT = JGO
  43 C
  44    24 JBT = JBT - NBITS
  45       CALL SBYT (IGV(JIN),ICHV(JCH),JBT,NBITS)
  46       IF (JIN.EQ.N)  RETURN
  47       JIN = JIN + 1
  48       IF (JBT.GE.NBEND)  GO TO 24
  49       JCH = JCH + 1
  50       ICHV(JCH)= NFILL
  51       GO TO 22
  52 C
  53 C----              ZONE NOT EQUALS A WORD
  54 C
  55    41 IF (NZONE.EQ.NBITPW)  GO TO 21
  56       JBT   = NBITPW - IGNOR
  57       NBEND = NZONE+1 - NBITS
  58       IF (NCHAR.EQ.0)  GO TO 42
  59       NBEND = MIN (NBEND, IGNOR+NCHAR*NBITS)
  60 C
  61    42 NBDONE= IGNOR
  62    43 IF (JBT.GE.0)  GO TO 44
  63       JBT= JBT + NBITPW
  64       JCH= JCH + 1
  65       ICHV(JCH)= NFILL
  66       GO TO 43
  67 C
  68    44 JBT = JBT - NBITS
  69       IF (JBT.LT.0)  GO TO 51
  70       CALL SBYT (IGV(JIN),ICHV(JCH),JBT+1,NBITS)
  71       GO TO 58
  72 C
  73 C--                CHARACTER ACROSS WORD BOUNDARY
  74    51 NLEFT= NBITS + JBT
  75       NRIGH= -JBT
  76       JBT  = JBT + NBITPW
  77       IF (NLEFT.EQ.0)  GO TO 54
  78       CALL CBYT (IGV(JIN),NRIGH+1,ICHV(JCH),1,NLEFT)
  79    54 JCH= JCH + 1
  80       ICHV(JCH)= NFILL
  81       CALL SBYT (IGV(JIN),ICHV(JCH),JBT+1,NRIGH)
  82 C
  83    58 IF (JIN.EQ.N)  RETURN
  84       JIN= JIN + 1
  85       NBDONE= NBDONE + NBITS
  86       IF (NBDONE.LT.NBEND)  GO TO 44
  87       JBT = JBT - (NZONE-NBDONE) - IGNOR
  88       GO TO 42
  89       END