MINICERN/packlib/zebra/jz91/jzsetf.F

   1 *
   2 * $Id$
   3 *
   4 * $Log$
   5 * Revision 1.2  1996/04/18 16:11:08  mclareni
   6 * Incorporate changes from J.Zoll for version 3.77
   7 *
   8 * Revision 1.1.1.1  1996/03/06 10:47:17  mclareni
   9 * Zebra
  10 *
  11 *
  12 #include "zebra/pilot.h"
  13       SUBROUTINE JZSETF (CHPA1,IPA2,IPA3)
  14
  15 C-    Set flag word JFL for processor IAM
  16
  17 #include "zebra/mqsysh.inc"
  18 #include "zebra/jzuc.inc"
  19 #include "zebra/jzc.inc"
  20 C--------------    END CDE                             -----------------  ------
  21       DIMENSION    IPA2(7),IPA3(7)
  22       CHARACTER    CHPA1*4
  23 #if defined(CERNLIB_A4)
  24       CHARACTER    CHIAM*4
  25 #endif
  26 #if defined(CERNLIB_A8)
  27       CHARACTER    CHIAM*8
  28 #endif
  29 #if defined(CERNLIB_EQUHOLCH)
  30       EQUIVALENCE (CHIAM, IAMID)
  31 #endif
  32 #if (defined(CERNLIB_QTRHOLL))&&(!defined(CERNLIB_A6M))
  33       DIMENSION    NAMESR(2)
  34       DATA  NAMESR / 4HJZSE, 4HTF   /
  35 #endif
  36 #if (defined(CERNLIB_QTRHOLL))&&(defined(CERNLIB_A6M))
  37       DATA  NAMESR / 6HJZSETF /
  38 #endif
  39 #if !defined(CERNLIB_QTRHOLL)
  40       CHARACTER    NAMESR*8
  41       PARAMETER   (NAMESR = 'JZSETF  ')
  42 #endif
  43
  44
  45 #include "zebra/qtraceq.inc"
  46
  47 #if defined(CERNLIB_QDEBUG)
  48 #include "zebra/qstorjz.inc"
  49       CHIAM = CHPA1
  50 #endif
  51 #if (defined(CERNLIB_QDEBUG))&&(!defined(CERNLIB_EQUHOLCH))
  52       CALL UCTOH (CHIAM, IAMID,4,4)
  53 #endif
  54 #if defined(CERNLIB_QDEBUG)
  55       JFL   = IPA2(1)
  56       IVAL  = IPA3(1)
  57
  58 C----              Find SV bank
  59
  60    21 L = LQ(KQS+LQJZ-4)
  61       IF (L.EQ.0)                  GO TO 24
  62       J = IUCOMP (IAMID,IQ(KQS+L+2),IQ(KQS+L+1))
  63       IF (J.EQ.0)                  GO TO 24
  64       LSV = LQ(KQS+L-J)
  65       GO TO 25
  66
  67    24 LSV   = LZFIND (IXSTJZ,LQ(KQS+LQJZ-3), IAMID,1)
  68       IF (LSV.EQ.0)                GO TO 41
  69    25 LFL = LSV + JQNACC
  70       LFL = LFL + IQ(KQS+LFL) + 1
  71       LFL = LFL + IQ(KQS+LFL) + 1 + IQ(KQS+LSV+4)
  72       NFL = IQ(KQS+LFL)
  73
  74 C----              Set flag value
  75
  76    31 IF (JFL.GT.NFL)              GO TO 81
  77       IF (JFL.LE.0)                GO TO 91
  78       IQUEST(3) = IQ(KQS+LFL+JFL)
  79       IQ(KQS+LFL+JFL) = IVAL
  80       GO TO 82
  81
  82 C----              Find flag bank if processor not yet init.
  83
  84    41 LFL = LZFIND (IXSTJZ,LQ(KQS+LQJZ-2), IAMID,1)
  85       IF (LFL.EQ.0)                GO TO 81
  86       NFL = IQ(KQS+LFL-1) - 1
  87       LFL = LFL + 1
  88       GO TO 31
  89
  90 #endif
  91 C----              Flag not available
  92
  93    81 LFL = 0
  94    82 IQUEST(1) = LFL
  95       IQUEST(2) = NFL
  96 #include "zebra/qtrace99.inc"
  97       RETURN
  98
  99 C----              Negative flag number
 100
 101    91 NQCASE = 1
 102       NQFATA = 3
 103       IQUEST(11) = NQME(1)
 104       IQUEST(12) = IAMID
 105       IQUEST(13) = JFL
 106 #include "zebra/qtofatal.inc"
 107       END
 108 *      ==================================================
 109 #include "zebra/qcardl.inc"