MINICERN/packlib/zebra/tq/tzinit.F

   1 *
   2 * $Id$
   3 *
   4 * $Log$
   5 * Revision 1.3  1996/04/24 17:27:35  mclareni
   6 * Extend the include file cleanup to dzebra, rz and tq, and also add
   7 * dependencies in some cases.
   8 *
   9 * Revision 1.2  1996/04/18 16:14:53  mclareni
  10 * Incorporate changes from J.Zoll for version 3.77
  11 *
  12 * Revision 1.1.1.1  1996/03/06 10:47:27  mclareni
  13 * Zebra
  14 *
  15 *
  16 #include "zebra/pilot.h"
  17       SUBROUTINE TZINIT (LUNP,IXDIV)
  18
  19 C--   Master routine for title input
  20
  21 #include "zebra/zmach.inc"
  22 #include "zebra/zstate.inc"
  23 #include "zebra/zunit.inc"
  24 #include "zebra/mqsys.inc"
  25 #include "zebra/eqlqt.inc"
  26 #include "zebra/mzcwk.inc"
  27 #include "zebra/tzuc.inc"
  28 #include "zebra/tzc1.inc"
  29 C--------------    END CDE                             -----------------
  30       COMMON /SLATE/ NDSLAT,NESLAT,NFSLAT,NGSLAT,DUMMY(36)
  31       CHARACTER    COL(LGL)*1
  32       EQUIVALENCE (COL(1), LINE(1:1))
  33       CHARACTER    CHWORK*8
  34 #if defined(CERNLIB_EQUHOLCH)
  35       INTEGER      IWORK(2)
  36       EQUIVALENCE (CHWORK,IWORK)
  37 #endif
  38
  39       DIMENSION    LUNP(1)
  40       DIMENSION    IFLAGS(5)
  41       EQUIVALENCE (IFLAGS(1),IFLLOG)
  42
  43       PARAMETER    (NCC = 7)
  44       CHARACTER    CCTEXT(NCC)*6
  45
  46 #if (defined(CERNLIB_QTRHOLL))&&(!defined(CERNLIB_A6M))
  47       DIMENSION    NAMESR(2)
  48       DATA  NAMESR / 4HTZIN, 4HIT   /
  49 #endif
  50 #if (defined(CERNLIB_QTRHOLL))&&(defined(CERNLIB_A6M))
  51       DATA  NAMESR / 6HTZINIT /
  52 #endif
  53 #if !defined(CERNLIB_QTRHOLL)
  54       CHARACTER    NAMESR*8
  55       PARAMETER   (NAMESR = 'TZINIT  ')
  56 #endif
  57       DATA CCTEXT  / 'LOG   ', 'PR*INT', 'US*ER ', 'KI*LL '
  58      +,              'ANY*WA', 'DO    ', 'FIN*IS' /
  59
  60 #include "zebra/q_sbyt.inc"
  61
  62
  63 #include "zebra/qtraceq.inc"
  64
  65 C--       decide division
  66
  67       CALL MZSDIV (IXDIV,7)
  68       L = LQT(KQT+1)
  69       IF (L.NE.0)  JQDIVI = MZFDIV (-7, L)
  70       IF (JQDIVI.EQ.0)  JQDIVI = 2
  71       JSTOR  = JQSTOR
  72       IXTITL = MSBYT (JQSTOR,JQDIVI,27,4)
  73
  74 C--       invert the order of the title banks,
  75 C-        so that the new ones can be created at the beginning
  76
  77       IF (L.NE.0)  CALL ZTOPSY (IXTITL,L)
  78
  79       CALL VZERO (NPARA,23)
  80       CALL VZERO (NREADY,12)
  81       IF (NQLOGL.GE.-1)  IFLLOG = 1
  82       BLANK = ' '
  83
  84 C--       get the input unit
  85
  86       LUNTQ = LUNP(1)
  87       IF (LUNTQ.LT.0)   LUNTQ = IQTTIN
  88       IF (LUNTQ.EQ.0)   LUNTQ = IQREAD
  89 #if defined(CERNLIB_QPRINT)
  90       IF (IFLLOG.NE.0)  THEN
  91           JDV = JQDIVI
  92           IF (JDV.EQ.JQDVSY)  JDV = 24
  93           WRITE (IQLOG,9000) LUNTQ,JQSTOR,JDV
  94         ENDIF
  95  9000 FORMAT (1X/' TZINIT.  Read title banks from LUNTQ = ',I3/
  96      F10X,'for store',I3,' into division',I3/1X)
  97 #endif
  98
  99 C----              Look for next control line
 100
 101    12 IF (NREADY.NE.0)             GO TO 14
 102
 103 #include "zebra/tzread1.inc"
 104
 105    14 NREADY = 0
 106       IF (NCHORG.EQ.0)             GO TO 12
 107       IF (LINE(1:2).EQ.'*.')       GO TO 12
 108       IF (LINE(1:4).EQ.'*CMZ')     GO TO 12
 109
 110       NCHLN  = NCHORG
 111       J = INDEX (LINE(1:NCHLN),' #.')
 112       IF (J.NE.0)  NCHLN = LNBLNK (LINE(1:J))
 113       IF (NCHLN.EQ.0)              GO TO 12
 114
 115       IF (COL(1).NE.'*')           GO TO 91
 116       IF (IFLLOG.NE.0)  WRITE (IQLOG,9012) LINE(1:NCHORG)
 117  9012 FORMAT ('    > ',A)
 118
 119       IF (LINE(1:2).EQ.'*-')       GO TO 12
 120
 121       NHEAD = MIN (NCHORG,80)
 122       LHEAD(1:NHEAD) = LINE(1:NHEAD)
 123       CALL CLTOU (LINE(1:NCHLN))
 124       IGNORE = 0
 125
 126 C----              Analyse control line
 127
 128       JA  = ICNEXT (LINE,1,NCHLN) + 1
 129       JE  = NESLAT - 1
 130       NN  = NDSLAT
 131
 132       IF (NN.LT.3)                 GO TO 92
 133       JCC = ICNTH (LINE(2:NN),CCTEXT,NCC)
 134
 135 C-        log   print user  kill  anyw  do    finis
 136 C-        1     2     3     4     5     6     7
 137
 138       IF (JCC.EQ.0)                GO TO 92
 139       IF (JCC.EQ.NCC)              GO TO 78
 140
 141       JA = ICNEXT (LINE,JE+1,NCHLN)
 142       JE = NESLAT - 1
 143       NN = NDSLAT
 144       IF (JCC.EQ.NCC-1)            GO TO 21
 145
 146 C--          *LOG, *PRINT, *USER, *KILL, *ANYWAY (OFF)
 147
 148       IF (NN.EQ.0)  THEN
 149           IFLAGS(JCC) = 1
 150           IF (JCC.EQ.2)  IFLLOG = 1
 151           GO TO 12
 152         ENDIF
 153
 154       IF (NN.NE.3)                 GO TO 92
 155       CHWORK = LINE(JA:JA+2)
 156       IF (CHWORK(1:3).NE.'OFF')    GO TO 92
 157       IFLAGS(JCC) = 0
 158       IF (JCC.EQ.1)  IFLPRI = 0
 159       GO TO 12
 160
 161 C--------          Analyse  *DO idh idn -opt x       --------
 162
 163    21 IF (NN.EQ.0)                 GO TO 92
 164       NN = MIN(NN,4)
 165       CHWORK = ' '
 166       CHWORK(1:NN) = LINE(JA:JA+NN-1)
 167       CALL VZERO (NAME,5)
 168       CALL VZERO (IFLEXA,16)
 169 #if defined(CERNLIB_EQUHOLCH)
 170       NAME(1) = IWORK(1)
 171 #endif
 172 #if !defined(CERNLIB_EQUHOLCH)
 173       CALL UCTOH (CHWORK,NAME,4,4)
 174 #endif
 175       IDNUM   = -1
 176
 177    24 JA = ICNEXT (LINE,JE+1,NCHLN)
 178       IF (JA.GT.NCHLN)             GO TO 61
 179       JE = NESLAT - 1
 180       NN = NDSLAT
 181
 182       IF (COL(JA).NE.'-')  THEN
 183           IF (IDNUM.GE.0)          GO TO 92
 184           IDNUM = ICDECI (LINE,JA,JE)
 185           IF (IDNUM.LT.0)          GO TO 92
 186           IF (NGSLAT.NE.0)         GO TO 92
 187           GO TO 24
 188         ENDIF
 189
 190       IDNUM = MAX (IDNUM,0)
 191       IF (NN.EQ.1)                 GO TO 92
 192
 193       JA = JA + 1
 194       JOPT = INDEX ('FISENUCA',COL(JA))
 195       IF (JOPT.EQ.0)               GO TO 92
 196
 197       JA = JA + 1
 198       NN = NN - 2
 199       GO TO (31, 34, 36, 37, 39, 41, 44, 47), JOPT
 200 C-            F   I   S   E   N   U   C   A
 201 C-            1   2   3   4   5   6   7   8
 202
 203 C--       option  -F(format), Fortran FORMAT
 204
 205    31 IF (COL(JA).NE.'(')          GO TO 92
 206       IF (COL(JE).NE.')')          GO TO 92
 207       JFMTC1 = JA
 208       JFMTC2 = JE
 209       GO TO 24
 210
 211 C--       option -Ii or -If ... or -I(text), I/O characteristic
 212
 213    34 JOPT = INDEX ('(BIFD', COL(JA))
 214 C-                   12345
 215       IF (JOPT.EQ.0)               GO TO 92
 216       IF (JOPT.NE.1)  THEN
 217           IF (NN.NE.1)             GO TO 92
 218           NAME(5) = JOPT - 1
 219           GO TO 24
 220         ENDIF
 221
 222       JE = ICFIND (')', LINE,JA,NCHLN)
 223       IF (NGSLAT.EQ.0)             GO TO 92
 224
 225       CALL MZIOBK (NAME,20, LINE(JA+1:JE-1))
 226       GO TO 24
 227
 228 C--       option -S[n], true size of the bank
 229
 230    36 IFLSIZ = 1
 231       IF (NN.EQ.0)                 GO TO 24
 232       GO TO 39
 233
 234 C--       option -E[n], exact number of data words
 235
 236    37 IFLEXA = 1
 237       IF (NN.EQ.0)                 GO TO 24
 238
 239 C--       option -Nn, bank size
 240
 241    39 N  = ICDECI (LINE,JA,JE)
 242       IF (NGSLAT.NE.0)             GO TO 92
 243       IF (N.LE.0)                  GO TO 92
 244       IF (NAME(4).NE.0)  THEN
 245           IF (NAME(4).NE.N)        GO TO 94
 246         ENDIF
 247       NAME(4) = N
 248       GO TO 24
 249
 250 C--       option -U[n], call TZUSER
 251
 252    41 IFLTZU = 1
 253       IF (NN.EQ.0)                 GO TO 24
 254       IVALUS = ICDECI (LINE,JA,JE)
 255       IF (NGSLAT.NE.0)             GO TO 92
 256       GO TO 24
 257
 258 C--       option -C[a][/e], column usage
 259
 260    44 JCOLA = 1
 261       IF (COL(JA).EQ.'/')          GO TO 45
 262       JCOLA = ICDECI (LINE,JA,JE)
 263       IF (JCOLA.LE.0)              GO TO 92
 264       IF (JCOLA.GE.LGL-3)          GO TO 92
 265       IF (NGSLAT.EQ.0)             GO TO 24
 266       JA = NESLAT
 267       IF (COL(JA).NE.'/')          GO TO 92
 268    45 JCOLE = ICDECI (LINE,JA+1,JE)
 269       IF (NGSLAT.NE.0)             GO TO 92
 270       JCOLE = MIN (JCOLE,LGL)
 271       IF (JCOLE.LT.JCOLA+2)        GO TO 92
 272       GO TO 24
 273
 274 C--       option -A[n][C][W]
 275
 276    47 CALL TZACW (LINE(JA-1:JE))
 277       IF (NCHPW.GE.0)              GO TO 24
 278       NCHPW = 0
 279       GO TO 92
 280
 281 C--------          Read data of next title bank      --------
 282
 283    61 IDNUM = MAX (IDNUM,0)
 284       IF (NAME(4).NE.0)            GO TO 63
 285
 286 C--                read the data through the scratch area
 287
 288       IF (JFMTC1.NE.0)             GO TO 93
 289       LPUTA = LQWKFZ
 290       LPUTE = LPUTA + NQWKTT
 291       GO TO 66
 292
 293 C--                pre-lift the bank for filling
 294
 295    63 IFLPRE = 7
 296       CALL MZLIFT (IXTITL,LOLD,LQT(KQT+1),1,NAME,-1)
 297       LPUTA = KQS + LOLD + 9
 298       LPUTE = LPUTA + NAME(4)
 299       IF (JFMTC1.EQ.0)             GO TO 66
 300
 301 C--                Read data en block with Fortran FORMAT
 302
 303       NWOCC = NAME(4)
 304 #include "zebra/tzread2.inc"
 305       GO TO 68
 306
 307 C--                Read data in free-field format
 308
 309    66 CALL TZFREE
 310       IF (NFAULT.NE.0)  THEN
 311           NFATAL = NFATAL + NFAULT
 312           IF (IFLPRE.EQ.0)         GO TO 77
 313           LNEW = -1
 314           GO TO 69
 315         ENDIF
 316       NWOCC = LPUTX - LPUTA
 317
 318 C--       lift the bank and copy the data
 319
 320       IF (IFLPRE.EQ.0)  THEN
 321           NAME(4) = NWOCC
 322           CALL MZLIFT (IXTITL,LOLD,LQT(KQT+1),1,NAME,-1)
 323           CALL UCOPY (LQ(LPUTA),IQ(KQS+LOLD+1),NAME(4))
 324         ENDIF
 325
 326 C--       handle 'exact' or 'size'
 327
 328       IF (IFLEXA.NE.0)  THEN
 329           IF (NWOCC.NE.NAME(4))    GO TO 97
 330         ENDIF
 331
 332       IF (IFLSIZ.EQ.0)             GO TO 68
 333       N = NAME(4) - NWOCC
 334       IF (N.NE.0)  CALL VZERO (IQ(KQS+LOLD+1+NWOCC),N)
 335       NWOCC = NAME(4)
 336
 337 C--       calling TZUSER
 338
 339    68 IQ(KQS+LOLD-5) = IDNUM
 340       IF (IFLTZU+IFLUSE.EQ.0)      GO TO 71
 341       NPARA = IVALUS
 342
 343       LNEW = 0
 344       CALL TZUSER (LQT(KQT+1))
 345       IF (LNEW.LT.-1)              GO TO 98
 346       IF (LNEW.EQ.0)               GO TO 71
 347       NWOCC = NAME(4)
 348    69 CALL MZDROP (IXTITL, LQT(KQT+1), '.')
 349       IF (LNEW.EQ.-1)              GO TO 77
 350
 351 C--       possibly reduce the bank
 352
 353    71 N = NAME(4) - NWOCC
 354       IF (N.GT.0)  THEN
 355           L = LQT(KQT+1)
 356           CALL MZPUSH (IXTITL,L,0,-N,'I')
 357         ENDIF
 358
 359    77 IF (NREADY.GE.0)             GO TO 12
 360
 361 C-------           Finished
 362
 363    78 L = LQT(KQT+1)
 364       CALL ZTOPSY (IXTITL,L)
 365       IQUEST(1) = NFATAL
 366       IF (NFATAL.NE.0)  THEN
 367           IF (IFLANY.EQ.0)  CALL ZFATAM ('TZINIT fails.')
 368         ENDIF
 369 #include "zebra/qtrace99.inc"
 370       RETURN
 371
 372 C----              Error handling
 373
 374 C--       unheaded data line
 375    91 IF (IGNORE.NE.0)             GO TO 12
 376       WRITE (IQLOG,9091) LINE(1:NCHORG)
 377  9091 FORMAT (' !!i> ',A)
 378       IF (IFLKIL.GT.0)  NFATAL = NFATAL + 1
 379       GO TO 12
 380
 381 C--       faulty control line *xxx
 382    92 IF (IFLLOG.EQ.0)  WRITE (IQLOG,9012) LHEAD(1:NHEAD)
 383       WRITE (IQLOG,9092) BLANK(1:JA)
 384  9092 FORMAT (' !!f ',A,'^->  !!! fault')
 385       IGNORE = 7
 386       NFATAL = NFATAL + 1
 387       GO TO 12
 388
 389 C--       faults with *DO
 390    93 IF (IFLLOG.EQ.0)  WRITE (IQLOG,9012) LHEAD(1:NHEAD)
 391       WRITE (IQLOG,9093)
 392  9093 FORMAT (' !!f   fault :  -F(...) requires -Nn')
 393       IGNORE = 7
 394       NFATAL = NFATAL + 1
 395       GO TO 12
 396
 397    94 IF (IFLLOG.EQ.0)  WRITE (IQLOG,9012) LHEAD(1:NHEAD)
 398       WRITE (IQLOG,9094)
 399  9094 FORMAT (' !!f   fault :  contradictory bank sizes')
 400       IGNORE = 7
 401       NFATAL = NFATAL + 1
 402       GO TO 12
 403
 404 C--       premature EoF
 405    96 IF (IFLLOG.EQ.0)  WRITE (IQLOG,9012) LHEAD(1:NHEAD)
 406       WRITE (IQLOG,9096)
 407  9096 FORMAT (' !!f   fault :  premature EoF')
 408       NFATAL = NFATAL + 1
 409       GO TO 78
 410
 411 C--       exact fault
 412    97 IF (IFLLOG.EQ.0)  WRITE (IQLOG,9012) LHEAD(1:NHEAD)
 413       WRITE (IQLOG,9097) NAME(4),NWOCC
 414  9097 FORMAT (' !!f   fault :  # of words expected / read=',2I6)
 415       NFATAL = NFATAL + 1
 416       GO TO 77
 417
 418 C--       user kill
 419    98 IF (IFLLOG.EQ.0)  WRITE (IQLOG,9012) LHEAD(1:NHEAD)
 420       WRITE (IQLOG,9098)
 421  9098 FORMAT (' !!f   fault :  kill requested by TZUSER')
 422       NFATAL = NFATAL + 1
 423       GO TO 77
 424       END
 425 *      ==================================================
 426 #include "zebra/qcardl.inc"