MINICERN/packlib/kernlib/kerngen/tcgen/csqmbl.F

   1 *
   2 * $Id$
   3 *
   4 * $Log$
   5 * Revision 1.1.1.1  1996/02/15 17:49:43  mclareni
   6 * Kernlib
   7 *
   8 *
   9 #include "kerngen/pilot.h"
  10       SUBROUTINE CSQMBL (CHV,JLP,JRP)
  11 C
  12 C CERN PROGLIB# M432    CSQMBL          .VERSION KERNFOR  4.22  890913
  13 C ORIG. 28/06/89, JZ
  14 C
  15 C-    Squeeze multiple blanks in CHV(JL:JR), shifting left
  16
  17       DIMENSION    JLP(9), JRP(9)
  18
  19       COMMON /SLATE/ NDSLAT,NESLAT, DUMMY(38)
  20       CHARACTER    CHV*(*)
  21
  22 C----              Find the first blank
  23
  24       JL = JLP(1)
  25       JR = JRP(1)
  26
  27       JP = JR + 1
  28       JJ = JL
  29    12 IF (JJ.GE.JP)                GO TO 99
  30       IF (CHV(JJ:JJ).NE.' ')   THEN
  31           JJ = JJ + 1
  32           GO TO 12
  33         ENDIF
  34
  35 C--       is it multiple ?
  36
  37       JJ = JJ + 1
  38       IF (JJ.GE.JP)                GO TO 99
  39       IF (CHV(JJ:JJ).NE.' ')       GO TO 12
  40
  41       JP = JJ
  42       JJ = JJ + 1
  43    16 IF (JJ.GT.JR)                GO TO 99
  44       IF (CHV(JJ:JJ).EQ.' ')   THEN
  45           JJ = JJ + 1
  46           GO TO 16
  47         ENDIF
  48
  49 C----              Copy shifted
  50
  51    24 CHV(JP:JP) = CHV(JJ:JJ)
  52       JP = JP + 1
  53       JJ = JJ + 1
  54       IF (JJ.GT.JR)                GO TO 91
  55       IF (CHV(JJ:JJ).NE.' ')       GO TO 24
  56
  57       IF (JJ.EQ.JR)                GO TO 91
  58       IF (CHV(JJ+1:JJ+1).NE.' ')   GO TO 24
  59       CHV(JP:JP) = ' '
  60       JP = JP + 1
  61       JJ = JJ + 1
  62
  63    26 IF (JJ.GT.JR)                GO TO 91
  64       IF (CHV(JJ:JJ).NE.' ')       GO TO 24
  65       JJ = JJ + 1
  66       GO TO 26
  67
  68    91 CHV(JP:JR) = ' '
  69    99 IF (CHV(JP-1:JP-1).EQ.' ')  JP = JP - 1
  70       NESLAT = JP
  71       NDSLAT = JP - JL
  72       RETURN
  73       END