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

   1 *
   2 * $Id$
   3 *
   4 * $Log$
   5 * Revision 1.1.1.1  1996/02/15 17:49:45  mclareni
   6 * Kernlib
   7 *
   8 *
   9 #include "kerngen/pilot.h"
  10       FUNCTION ICINQL (TEXT,POSS,NPOSS)
  11 C
  12 C CERN PROGLIB# M432    ICINQL          .VERSION KERNFOR  4.36  930602
  13 C ORIG. 24/05/93, JZ
  14 C
  15 C-    Match TEXT against lower case POSS(NPOSS), case insensitive
  16
  17       CHARACTER*(*)  TEXT, POSS(99)
  18       CHARACTER*1    CHT,  CHP
  19
  20 #include "kerngen/qnatch.inc"
  21 * Ignoring t=pass
  22
  23       NTX = LEN(TEXT)
  24       NPO = LEN(POSS(1))
  25
  26       JPOSS = 0
  27    11 JPOSS = JPOSS + 1
  28       IF (JPOSS.GT.NPOSS)    GO TO 98
  29       CHP = POSS(JPOSS)(1:1)
  30       CHT = TEXT(1:1)
  31       JC  = 1
  32    12 IF (CHT.NE.CHP)  THEN
  33           IVT = ICHAR(CHT)
  34           IVP = ICHAR(CHP)
  35 #if defined(CERNLIB_QASCII)
  36           IF (IVP-IVT.NE.32) GO TO 11
  37           IF (IVT.LT.65)     GO TO 11
  38           IF (IVT.GT.90)     GO TO 11
  39 #endif
  40 #if defined(CERNLIB_QEBCDIC)
  41           IF (IVT-IVP.NE.64)      GO TO 11
  42           IF (NATCH(IVT+1).NE.4)  GO TO 11
  43 #endif
  44         ENDIF
  45       JC = JC + 1
  46       IF (JC.GT.NPO)         GO TO 99
  47       CHP = POSS(JPOSS)(JC:JC)
  48       IF (CHP.EQ.' ')        GO TO 71
  49       IF (JC.GT.NTX)         GO TO 11
  50       CHT = TEXT(JC:JC)
  51       IF (CHT.NE.'*')        GO TO 12
  52
  53 C----         First '*' seen on TEXT
  54
  55    61 JC = JC + 1
  56       IF (JC.GT.NTX)         GO TO 99
  57       CHT = TEXT(JC:JC)
  58       IF (CHT.EQ.'*')        GO TO 99
  59       IF (CHT.EQ.' ')        GO TO 99
  60       IF (CHP.NE.CHT)  THEN
  61           IVT = ICHAR(CHT)
  62           IVP = ICHAR(CHP)
  63 #if defined(CERNLIB_QASCII)
  64           IF (IVP-IVT.NE.32) GO TO 11
  65           IF (IVT.LT.65)     GO TO 11
  66           IF (IVT.GT.90)     GO TO 11
  67 #endif
  68 #if defined(CERNLIB_QEBCDIC)
  69           IF (IVT-IVP.NE.64)     GO TO 11
  70           IF (NATCH(IVT+1).NE.4) GO TO 11
  71 #endif
  72         ENDIF
  73       IF (JC.GT.NPO)         GO TO 99
  74       CHP = POSS(JPOSS)(JC:JC)
  75       IF (CHP.NE.' ')        GO TO 61
  76       GO TO 99
  77
  78 C----         POSS blank terminated
  79
  80    71 IF (JC.GT.NTX)         GO TO 99
  81       CHT = TEXT(JC:JC)
  82       IF (CHT.EQ.' ')        GO TO 99
  83       IF (CHT.EQ.'*')        GO TO 99
  84       GO TO 11
  85
  86    98 JPOSS = 0
  87    99 ICINQL = JPOSS
  88       RETURN
  89       END