MINICERN/packlib/zebra/dzebra/dzforp.F

   1 *
   2 * $Id$
   3 *
   4 * $Log$
   5 * Revision 1.1.1.1  1996/03/06 10:47:06  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 DZFORP
  15       SAVE KFOTYP
  16 #include "zebra/mqsys.inc"
  17 #include "zebra/qequ.inc"
  18 #include "zebra/mzioc.inc"
  19 #include "zebra/zunit.inc"
  20 #include "zebra/dzc1.inc"
  21 #include "zebra/bkfoparq.inc"
  22
  23       CHARACTER   CHROUT*(*),CHSTAK*6,KFOTYP(0:11)*1
  24       PARAMETER (CHROUT = 'DZFORP')
  25       DATA KFOTYP /'U','B','I','F','D','H','*','S','*','N','*','L'/
  26 #if (defined(CERNLIB_DEBUGON))&&(defined(CERNLIB_VFORT))
  27 #include "zebra/debugvf2.inc"
  28 #endif
  29
  30
  31
  32
  33
  34       CHSTAK          = CQSTAK(MCQSIQ:)
  35       CQSTAK(MCQSIQ:) = CHROUT
  36
  37       IPOS = 38
  38
  39       DO 100 JFOCUR = 1,JFOEND,2
  40
  41
  42           IF (JFOCUR.EQ.JFOREP+1) THEN
  43               WRITE(CQLINE(IPOS:IPOS+1),'(''/ '')')
  44               IPOS = IPOS + 2
  45           ENDIF
  46           ITYPE  = MFO(JFOCUR)
  47           IF (ITYPE.EQ.IFOSEQ) THEN
  48               WRITE(CQLINE(IPOS:IPOS+1),'(''*'',A1)') KFOTYP(ITYPE)
  49               IPOS = IPOS + 3
  50                                                            GO TO 100
  51           ENDIF
  52           NWSEC  = MFO(JFOCUR+1)
  53           ITYPE  = MIN(ITYPE,8)
  54           IF (NWSEC.LT.0) THEN
  55               WRITE(CQLINE(IPOS:IPOS+1),'(''-'',A1)') KFOTYP(ITYPE)
  56               IPOS = IPOS + 3
  57           ELSEIF (NWSEC.EQ.0) THEN
  58               WRITE(CQLINE(IPOS:IPOS+1),'(''*'',A1)') KFOTYP(ITYPE)
  59               IPOS = IPOS + 3
  60           ELSE
  61               DO 10 I=1,100
  62                   IF(NWSEC.EQ.0)                           GO TO 20
  63                       IQUEST(I)=MOD(NWSEC,10)
  64                       NWSEC    = NWSEC/10
  65    10         CONTINUE
  66    20         DO 30 J=1,I-1
  67                   WRITE(CQLINE(IPOS:IPOS),'(I1)') IQUEST(I-J)
  68                   IPOS = IPOS + 1
  69    30         CONTINUE
  70               WRITE(CQLINE(IPOS:IPOS),'(A1)') KFOTYP(ITYPE)
  71               IPOS = IPOS + 2
  72           ENDIF
  73
  74           IF (IPOS.GT.100) THEN
  75               CALL DZTEXT(0,CDUMMQ,1)
  76               IPOS = 23
  77               CQLINE = ' '
  78           ENDIF
  79   100 CONTINUE
  80
  81       IF (IPOS.GT.23) CALL DZTEXT(0,CDUMMQ,1)
  82
  83   999 CQSTAK(MCQSIQ:) = CHSTAK
  84       END