MINICERN/packlib/zebra/jz91/jzlift.F

   1 *
   2 * $Id$
   3 *
   4 * $Log$
   5 * Revision 1.1.1.1  1996/03/06 10:47:17  mclareni
   6 * Zebra
   7 *
   8 *
   9 #include "zebra/pilot.h"
  10       SUBROUTINE JZLIFT
  11
  12 C-    Initialize processor SV bank for support variables
  13
  14 C-    Parameters in /JZC/ :
  15 C-    IAM(1)  IAMID  = processor ID in A4
  16 C-        2   IAFLDW = down-call flag
  17 C-             0  no further down transfer
  18 C-             1  with down transfer, level JQMLEV must not be reached
  19 C-        3   IANAN  = number of processor constants
  20 C-        4   IANCR  = number of conditions to be recorded
  21 C-        5   IANLSV = number of wsp links to be saved
  22 C-        6   IANDSV = number of wsp data words to be saved
  23
  24 #include "zebra/zstate.inc"
  25 #include "zebra/zunit.inc"
  26 #include "zebra/mqsysh.inc"
  27 #include "zebra/jzuc.inc"
  28 #include "zebra/jzc.inc"
  29 C--------------    END CDE                             -----------------  ------
  30       DIMENSION    IDPR(7)
  31       EQUIVALENCE (IDPR(1),IAMID)
  32
  33       DIMENSION    MMSV(5)
  34 #if (defined(CERNLIB_QTRHOLL))&&(!defined(CERNLIB_A6M))
  35       DIMENSION    NAMESR(2)
  36       DATA  NAMESR / 4HJZLI, 4HFT   /
  37 #endif
  38 #if (defined(CERNLIB_QTRHOLL))&&(defined(CERNLIB_A6M))
  39       DATA  NAMESR / 6HJZLIFT /
  40 #endif
  41 #if !defined(CERNLIB_QTRHOLL)
  42       CHARACTER    NAMESR*8
  43       PARAMETER   (NAMESR = 'JZLIFT  ')
  44 #endif
  45       DATA  MMSV   / 4HJZSV, -7, 0, -7, 0 /
  46
  47 #include "zebra/q_jbit.inc"
  48
  49 #include "zebra/qtraceq.inc"
  50
  51 C----              Create SV bank
  52
  53       IANCR   = MAX (IANCR,1)
  54       MMSV(4) = JQNACC + IANCR + IANAN + IANDSV + 2
  55       IANFL   = 0
  56 #if defined(CERNLIB_QDEBUG)
  57       LTFL   = LZFIND (IXSTJZ,LQ(KQS+LQJZ-2), IAMID,1)
  58       IF (LTFL.NE.0)  IANFL = IQ(KQS+LTFL-1) - 1
  59       MMSV(4) = MMSV(4) + IANFL
  60 #endif
  61       MMSV(2) = IANLSV + 3
  62       CALL MZLIFT (IXDVJZ,LSV,LQJZ,-3,MMSV,0)
  63       LCR = LSV + JQNACC
  64       LAN = LCR + IANCR + 1
  65 #if defined(CERNLIB_QDEBUG)
  66       LFL = LAN + IANAN + 1 + IANDSV
  67 #endif
  68       CALL SBYT (JQLEV+1, IQ(KQS+LSV),1,8)
  69       IQ(KQS+LSV+1) = IAMID
  70       IQ(KQS+LSV+3) = IANLSV
  71       IQ(KQS+LSV+4) = IANDSV
  72
  73       IQ(KQS+LCR) = IANCR
  74       IQ(KQS+LAN) = IANAN
  75       NANTL    = IANAN
  76
  77 C----              Find and copy JQAN title, if any
  78
  79       LTAN = LZFIND (IXSTJZ,LQ(KQS+LQJZ-1), IAMID,1)
  80       IF (LTAN.NE.0)  THEN
  81           NANTL = IQ(KQS+LTAN-1) - 1
  82           N     = MIN (NANTL,IANAN)
  83           CALL UCOPY (IQ(KQS+LTAN+2),IQ(KQS+LAN+1),N)
  84           CALL SBIT1 (IQ(KQS+LSV),17)
  85           CALL MZDROP (IXSTJZ,LTAN, '.')
  86         ENDIF
  87
  88 C----              Find and copy JQFL flag titles, if any
  89
  90 #if defined(CERNLIB_QDEBUG)
  91       IF (LTFL.NE.0)  THEN
  92           LTFL = LZFIND (IXSTJZ,LQ(KQS+LQJZ-2), IAMID,1)
  93           IF (IANFL.NE.0)
  94      +      CALL UCOPY (IQ(KQS+LTFL+2),IQ(KQS+LFL+1),IANFL)
  95           IQ(KQS+LFL) = IANFL
  96           CALL MZDROP (IXSTJZ,LTFL, '.')
  97         ENDIF
  98 #endif
  99
 100 C----              Print and check discrepancies
 101
 102       LEV = JQLLEV
 103       IF (IANAN.NE.NANTL)  LEV = LEV + 1
 104
 105       IF (LEV.GE.2)  WRITE (IQLOG,9042) IDPR
 106  9042 FORMAT (/' JZLIFT.  Init of "',A4,
 107      F ' with  IFDW,NAN,NCD,NLSV,NDSV,NFL =',6I4)
 108
 109       IF (IANAN.EQ.NANTL)          GO TO 47
 110
 111       IF (LEV.GE.2)  WRITE (IQLOG,9043) NANTL
 112  9043 FORMAT (10X,'!!! NAN from title =',I8,' !!!')
 113
 114 C----              Exit
 115
 116    47 IQUEST(1) = -7
 117       IQUEST(2) = LSV
 118       IF (JBIT(IQ(KQS+LSV),17).EQ.0)  GO TO 999
 119       IF (JQLLEV.GE.2)  WRITE (IQLOG,9048)
 120  9048 FORMAT (10X,'with title.')
 121       IQUEST(1) = 0
 122 #include "zebra/qtrace99.inc"
 123       RETURN
 124       END
 125 *      ==================================================
 126 #include "zebra/qcardl.inc"