MINICERN/packlib/kernlib/kerngen/tcgen/lnxgs/utrans.F

   1 *
   2 * $Id$
   3 *
   4 * $Log$
   5 * Revision 1.1.1.1  1996/02/15 17:49:58  mclareni
   6 * Kernlib
   7 *
   8 *
   9       SUBROUTINE UTRANS (AI,AJ,NCH,IP,JP)
  10 C
  11 C CERN PROGLIB# M409    UTRANS          .VERSION KERNLNX  1.00  930507
  12 C ORIG. 15/09/78 JZ
  13 C
  14       COMMON /SLATE/ NI, NJ, MM(38)
  15 C
  16       INTEGER    AI(9), AJ(9), NCH(9), IP(9), JP(9)
  17 C
  18       PARAMETER   (NCHAPW=4)
  19 C
  20       NI   = 0
  21       NJ   = 0
  22       NCHL = NCH(1)
  23       IF (NCHL.LE.0)         RETURN
  24       NCHI = MIN (IP(1), NCHAPW)
  25       NCHJ = MIN (JP(1), NCHAPW)
  26       IF (NCHI-NCHJ)         31,41,21
  27 C
  28 C----              DISPERSION TO A1
  29 C
  30    21 IF (NCHJ.NE.1)         GO TO 41
  31 C
  32    24 N  = MIN (NCHL, NCHI)
  33       NI = NI + 1
  34       CALL UBLOW (AI(NI),AJ(NJ+1),N)
  35       NJ   = NJ   + N
  36       NCHL = NCHL - N
  37       IF (NCHL.NE.0)         GO TO 24
  38       RETURN
  39 C
  40 C----              CONCENTRATION FROM A1
  41 C
  42    31 IF (NCHI.NE.1)         GO TO 41
  43 C
  44    34 N  = MIN (NCHL, NCHJ)
  45       NJ = NJ + 1
  46       CALL UBUNCH (AI(NI+1),AJ(NJ),N)
  47       NI   = NI   + N
  48       NCHL = NCHL - N
  49       IF (NCHL.NE.0)         GO TO 34
  50       RETURN
  51 C
  52 C----              TRANSFORMATION AI TO AJ
  53 C
  54    41 JA = 0
  55       JE = 0
  56    42 N  = MIN (NCHL, NCHJ)
  57       IF (JA+N.LE.JE)        GO TO 47
  58       IF (JA.NE.JE)          GO TO 43
  59       JA = 1
  60       JE = 1
  61       GO TO 44
  62 C
  63    43 IF (JE+NCHI.LT.40)     GO TO 44
  64       NT = JE - JA
  65       CALL UCOPY (MM(JA),MM(1),NT)
  66       JA = 1
  67       JE = NT + 1
  68 C
  69    44 NI = NI + 1
  70       CALL UBLOW (AI(NI),MM(JE),NCHI)
  71       JE = JE + NCHI
  72       IF (JA+N.GT.JE)        GO TO 43
  73 C
  74    47 NJ = NJ + 1
  75       CALL UBUNCH (MM(JA),AJ(NJ),N)
  76       JA   = JA   + N
  77       NCHL = NCHL - N
  78       IF (NCHL.NE.0)         GO TO 42
  79       RETURN
  80       END