MINICERN/packlib/zebra/dzebra/dztyp.F

   1 *
   2 * $Id$
   3 *
   4 * $Log$
   5 * Revision 1.1.1.1  1996/03/06 10:47:07  mclareni
   6 * Zebra
   7 *
   8 *
   9 *------------------------------------------------------------
  10 #include "zebra/pilot.h"
  11 #if (defined(CERNLIB_DEBUGON))&&(defined(CERNLIB_VFORT))
  12 #include "zebra/debugvf1.inc"
  13 #endif
  14       SUBROUTINE DZTYP
  15       SAVE ALOW,AUP,BLOW,BUP,ILIM
  16 #include "zebra/mqsys.inc"
  17 #include "zebra/qequ.inc"
  18 #include "zebra/zbcd.inc"
  19 #include "zebra/zbcdk.inc"
  20 #include "zebra/zmach.inc"
  21 #include "zebra/dzc1.inc"
  22
  23       PARAMETER (IUMOIQ = 0)
  24
  25       INTEGER IA,IWORD
  26       REAL     A, WORD
  27       EQUIVALENCE (WORD,IWORD), (A,IA)
  28
  29       CHARACTER CHROUT*(*),CHSTAK*6
  30       PARAMETER (CHROUT = 'DZTYP' )
  31
  32 #if (defined(CERNLIB_DEBUGON))&&(defined(CERNLIB_VFORT))
  33 #include "zebra/debugvf2.inc"
  34 #endif
  35
  36       DATA ILIM/10000000/,ALOW,AUP/.001,1.0E6/,BLOW,BUP/1.0E-20,1.0E20/
  37
  38
  39
  40       CHSTAK          = CQSTAK(MCQSIQ:)
  41       CQSTAK(MCQSIQ:) = CHROUT
  42
  43       J      = LBASE + JD
  44       IWORD  = LQ(KQS+J)
  45       JTYP   = 1
  46       IF (IWORD.EQ.IQNIL.OR.IWORD.EQ.IQNIL+J)              GO TO 999
  47
  48       IDLINK = JD+1 - JDFD
  49
  50       IIUMOD = IUMODE(WORD)
  51
  52       IF (IDLINK.LE.0)           THEN
  53           IF (IIUMOD.NE.IUMOIQ)                            GO TO 999
  54           IF (IWORD.EQ.LNULL)              THEN
  55               JTYP   = 2
  56           ELSE
  57               CALL MZCHLS(NCHEKQ,IWORD)
  58               JTYP = -1
  59           ENDIF
  60                                                            GO TO 999
  61       ENDIF
  62
  63
  64
  65       IF (IFLOPT(MPOSZQ).NE.0)                             GO TO 100
  66
  67
  68       ITYPE  = 0
  69
  70       IF(IIUMOD.EQ.IUMOIQ)                                 GO TO 300
  71       IF (IWORD.EQ.IQBLAN)                                 GO TO 200
  72       IF (WORD.EQ.0.) THEN
  73                                                            GO TO 400
  74       ELSEIF (WORD.LT.0.) THEN
  75           IF (WORD.LT.-BLOW.AND.WORD.GT.-BUP)              GO TO 400
  76       ELSE
  77           IF (WORD.GT.BLOW.AND.WORD.LT.BUP)                GO TO 400
  78       ENDIF
  79       CALL UBLOW(WORD,IQUEST,NQCHAW)
  80       DO 90 J=1,NQCHAW
  81           IF (IZBCD(IQUEST(J)).GE.48)                      GO TO 100
  82    90 CONTINUE
  83                                                            GO TO 200
  84
  85
  86  100  JTYP   = 1
  87                                                            GO TO 999
  88
  89
  90   200 JTYP   = 7
  91                                                            GO TO 999
  92
  93
  94   300 IF ((IWORD.GE.0.AND.IWORD.LT.ILIM).OR.
  95      X    (IWORD.LT.0.AND.IWORD.GT.-ILIM)   ) THEN
  96           JTYP   = 2
  97       ENDIF
  98                                                            GO TO 999
  99
 100
 101   400 A      = ABS(WORD)
 102       JTYP   = 6
 103       IF     (A.EQ.0.)                            THEN
 104           JTYP   = 3
 105       ELSEIF (A.LT.AUP.AND.A.GT.ALOW)             THEN
 106           JTYP   = 4
 107           IF (A.EQ.AINT(A))                           THEN
 108               JTYP   = 3
 109           ELSEIF (A.LT.100.)                          THEN
 110               JTYP   = 5
 111           ENDIF
 112       ENDIF
 113
 114   999 CQSTAK(MCQSIQ:) = CHSTAK
 115       END