C***ADD:CDC***  PLOTMAIN
CDECK ADPLOT
C     PROGRAM ADPLOT (INPUT=512/80,OUTPUT,TAPE1,TAPE5=INPUT,
C    1                TAPE6=OUTPUT,TAPE50=512,TAPE60,TAPE61=512)
C***END:CDC***
C***VERSION  0.00 BASE,IBM,DPR***   DATE 82.06.04
C
C
C
C                      A D I N A - P L O T
C
C
C          THIS PROGRAM IS IN ITS ENTIRETY PROPRIETARY TO
C                AND IS SUPPORTED AND MAINTAINED BY
C
C                ADINA ENGINEERING AB   (SWEDEN)
C                ADINA ENGINEERING INC  (USA)
C
C    ADINA ENGINEERING MAKES NO WARRANTY WHATSOEVER , EXPRESSED OR
C    IMPLIED, THAT THE PROGRAM AND ITS DOCUMENTATION INCLUDING ANY
C    MODIFICATIONS AND UPDATES ARE FREE FROM ERRORS AND DEFECTS.IN
C    NO EVENT  SHALL  ADINA ENGINEERING  BECOME LIABLE TO THE USER
C    OR ANY PARTY FOR ANY LOSS , INCLUDING BUT NOT LIMITED TO LOSS
C    OF TIME , MONEY OR GOODWILL , WHICH MAY ARISE FROM THE USE OF
C    THE PROGRAM AND ITS DOCUMENTATION INCLUDING ANY MODIFICATIONS
C    AND UPDATES.
C
C
C    ADINA ENGINEERING AB                    ADINA ENGINEERING INC
C    MUNKGATAN 20D                           71 ELTON AVENUE
C    S-722 12                                WATERTOWN
C    VASTERAS  SWEDEN                        MASSACHUSETTS  USA
C    TEL 021-14 40 50                        TEL (617) 926-5199
C    TELEX 40630 ADINA S
C
C
C
C
      DIMENSION IA(1),IDIM(1),NDIM(1),NCMDPL(15)
C
      COMMON /CNTRL/ IBATCH,NBSU,LSTC,LSTF,LSTDB,ISURL,ITWO,LINPAG,LINE
      COMMON /EPS/ EPS
      COMMON /FILES/ NFREAD,NFECHO,NFLOG,NFLIST,LUNODE,LUELEM
      COMMON /PARAM/ REALV(100),NCMD,NLASTP,ITYPE(20),INTV(100),
     1               IANUMV(160),LGHSTR,INTEG,IREAL,IANUM,ISTRIN,IOMIT
      COMMON /CALLP/ NAMZON(8),NAMERC(8),
     1               IBITZ,IWHOLE,ICALL,IXPAR
      COMMON /SICODE/ I000,I111,I222,I333,I444,I555,I666,I777,I888,I999,
     1              IBLANK,IAAA,IBBB,ICCC,IDDD,IEEE,IFFF,IGGG,IHHH,IIII,
     2                IJJJ,IKKK,ILLL,IMMM,INNN,IOOO,IPPP,IQQQ,IRRR,ISSS,
     3                ITTT,IUUU,IVVV,IWWW,IXXX,IYYY,IZZZ,IPOINT,ICOMMA,
     4              IPLUS,IMINUS,IEQUAL,ILPAR,IRPAR,ISLASH,IASTER,IAPOST
      COMMON /FIELDC/ REALI,INPREC(80),INPOS,ITYPEI,INTI,IANUMI(128),
     1               KEYI(8),NPOSRE,INECHO,MXSIGI,MXSIGR,MXSIGE,MXSTRL,
     2               ISTRIL,NFIELD,NPOSIN
      COMMON /PLOTCO/ GSCALE,DSCALE,XPV,YPV,PUNIT,HEIGHT,PMARG,AXEDGE,
     1              XSF,YSF,XFMAX,YFMAX,XF1,YF1,XPMAX,YPMAX,
     3              XSMIN,XSMAX,YSMIN,YSMAX,XPSAVE,YPSAVE,VIEW(3,3),
     2              NFPLOT,IONPLT,NSYSPL,NDEVPL,MORIGO,NGPTS
      COMMON /ERROR/ IERROR
      COMMON /MEMORY/ MTOT,LPROG,MEMPRT,MEMMAX,MEMNOW
      COMMON /DB/ IOPEN,NFDB,INDXST,IXTNOW,LGP,NWRITS,NREADS,
     1            LDBC,LDBCTR,LDBCTI,IPHCHK,INSTRI,INRUSE,INSTRU,
     2            MSUBF,MVIEW,MAXIS,MLINEN,MLINEE,MVAR,MRES,LSKEW,MIDSPL
      COMMON /DBC/ IHED(18),NDAREC,LDAREC,NRECS,NWORDS,NEXREC,NEXTIX,
     1             LIX,LIXT,NSTRI,NSTRUC,NEGIT,NEGAT,NFREQ,
     2             IXGP(50),MXSGP(50),
     3             FILL1
      COMMON /DIM/ I01,I02,I03,I04,I05,I06,I07,I08,I09,I010,I011,
     1             I1,I2,I3,I4,I5,I6,I7,I8,I9,I10,I11,I12,I13,I14,I15,
     2             I16,I17,I18,I19,I20,
     3             N1,N2,N3,N4,N5,N6,N7,N8,N9,N10,N11,N12,N13,N14,N15,
     4             N16,N17,N18,N19,N20
      COMMON /DBCTRL/ DT    ,TSTART,NUMNP ,NEQT  ,NSUBST,IDOF(6),
     1                NDOF  ,NEG   ,NMID  ,MODEX ,NSTE  ,NSTEN ,
     2                NSTEE ,NSKEWS,NMIDSS,IEIG  ,NSREFB,NEQITB,
     3                NPRIB ,NODSVB,LEMSVB,JDC   ,JAC   ,JVC   ,
     4                ISTAT ,JTC   ,NDISCE,ITP96 ,MXITAB,MXIDER,MXERES,
     5                NELPAR,MXNP  ,MXEG  ,MXEL  ,MXELNP,
     6                NDOFSA(6),NOUSE(4),FILL2
      COMMON /IGPNAM/ KDBC  ,KSUBGP,KDBCTR,KSTRI ,KRSDCO,KTMIDS,
     1                KXYZ  ,KIDRN ,KICONA,KNZONE,KNPAR ,KTHICK,
     2                KITABL,KNOD  ,KEDATA,KIEZON,KFRQ  ,KPHI  ,
     3                KTIMEN,KDISP ,KVEL  ,KACC  ,KTEMP ,KTIMEE,
     4                KERES ,KSUBF ,KVIEW ,KAXIS ,KNPOIN,KVARES,
     5                KNAMEZ,KEPOIN,KSXYZ ,KX34  ,KX35  ,KX36  ,
     6                KX37  ,KX38  ,KX39  ,KX40  ,KX41  ,KX42  ,
     7                KX43  ,KX44  ,KX45  ,KX46  ,KX47  ,KX48  ,
     8                KX49  ,KX50
C***DEL:CDY,UDY***
C*         FIX LENGTH OF BLANK COMMON
      COMMON A(50000)
      EQUIVALENCE (A(1),IA(1))
      EQUIVALENCE (I1,IDIM(1)),(N1,NDIM(1))
      MTOT = 50000
C***END:CDY,UDY***
C***ADD:CDY,UDY***
C*         DYNAMIC INCREASE OF BLANK COMMON IN SUBROUTINE SIZE
C     COMMON A(10)
C     EQUIVALENCE (A(1),IA(1))
C     EQUIVALENCE (I1,IDIM(1)),(N1,NDIM(1))
C     MTOT = 0
C***END:CDY,UDY***
      DATA NCMDPL/18,19,21,22,23,25,27,40,41,99,99,99,99,99,99/
      DATA IPLCLO,ISPACE/3,1H /
C***ADD:IBMVS***
C*
C*         ACTIVATE THE FOLLOWING CARD ON IBM VS FORTRAN
C*         TO IGNORE ERROR 187
C*
      CALL ERRSET (187,256,-1,1,0,0)
C***END:IBMVS***
      MEMNOW = 10
      WRITE (NFLOG,2020)
C
C         READ COMMAND AND PARAMETERS
C
  100 CALL COMND
      LINE = 32766
C
C          IF INPUT ERROR, JUST GO AND PRINT MESSAGE
C
      IF(IERROR.NE.0) GOTO 900
      DO 101 I=1,8
  101   NAMERC(I) = ISPACE
C
C          CHECK THAT DATABASE IS OPEN
C
      IF (IOPEN.EQ.1 .OR. NCMD.LT.12) GOTO 102
        WRITE (NFLOG,2040)
        GOTO 810
C
C          CHECK THAT FRAME IS GIVEN FOR PLOT COMMANDS
C
  102 IF (IONPLT.EQ.1) GOTO 105
      DO 103 I=1,15
        IF (NCMD.EQ.NCMDPL(I)) GOTO 104
  103   CONTINUE
      GOTO 105
  104 WRITE (NFLOG,2050)
      GOTO 810
C
C
C          CALL ADINA-PLOT SUBROUTINE
C
C
  105 IF(NCMD.GT.10) GOTO 110
C
      GOTO(401,402,403,404,405,406,407,408,409,410),NCMD
C
  401 CONTINUE
  402 CONTINUE
      GOTO 8000
  403 CALL TEST
      GOTO 800
  404 CALL FILE
      GOTO 800
  405 CALL CONTRL
      GOTO 800
  406 CALL DATAB
      GOTO 800
  407 CONTINUE
  408 CONTINUE
  409 CONTINUE
      GOTO 800
  410 CALL EVECT1
      GOTO 800
C
  110 IF(NCMD.GT.20) GOTO 120
C
      NCMD1=NCMD-10
      GOTO (411,412,413,414,415,416,417,418,419,420), NCMD1
C
  411 CALL FRAME
      GOTO 800
  412 CALL SUBF (0)
      GOTO 800
  413 CALL VIEW1
      GOTO 800
  414 CONTINUE
  415 CONTINUE
  416 CONTINUE
  417 CALL ZONE1
      GOTO 800
  418 CONTINUE
  419 CALL MESH1
      GOTO 800
  420 CALL APAXIS
      GOTO 800
C
  120 IF (NCMD.GT.35) GOTO 436
C
      NCMD2=NCMD-20
      GOTO(421,422,423,424,425,426,427,428,429,430
     1    ,431,432,433,434,435), NCMD2
C
  421 CALL TEXT
      GOTO 800
  422 CALL NHIST1 (IA(I08))
      GOTO 800
  423 CALL EHIST1
      GOTO 800
  424 CALL NPOIN1
      GOTO 800
  425  CALL NLINE1
      GOTO 800
  426 CALL EPOIN1
      GOTO 800
  427 CALL ELINE1
      GOTO 800
  432 CONTINUE
  433 CONTINUE
  428 CALL NLIST1
      GOTO 800
  429 CALL GLIST1
      GOTO 800
  430 CALL EINFO1
      GOTO 800
  434 CONTINUE
  435 CONTINUE
  431 CALL ELIST1
      GOTO 800
C
  436 IF (NCMD.GT.44) GOTO 445
      CALL VARES1
      GOTO 800
  445 IF (NCMD.GT.45) GOTO 800
        CALL MLIST1
        GOTO 800
C
C
  800 CONTINUE
      IF (LINE.NE.32766) WRITE (NFLIST,2070)
      DO 805 I=2,20
        IDIM(I) = 0
  805   NDIM(I) = 0
      IF (IOPEN.EQ.1) CALL SIZE(I1)
      IF (IERROR.EQ.0) GOTO 100
      IF (IERROR.EQ.2) WRITE (NFLOG,2060)
      IF (IERROR.NE.0) WRITE (NFLOG,2080)
      IERROR = 0
  810 IF (IBATCH.LT.1) GOTO 100
C
C           READ REST OF INPUT FILE IF BATCH MODE FOR SYNTAX CHECK
C          CONTROL IBATCH=0  WILL BE EXECUTED
C
      WRITE (NFLOG,2030)
  820 CALL COMND
      IF (NCMD.EQ.2) GOTO 8000
      IF (NCMD.EQ.5.AND.ITYPE(1).EQ.INTEG.AND.INTV(1).EQ.0)
     1         GOTO 105
      GOTO 820
C
  900 WRITE (NFLOG,2010)
      GOTO 800
C
 8000 CONTINUE
      CALL CGRAPH (IPLCLO)
      CALL DBCLOS
      STOP
C
 2010 FORMAT(51H ***ACTION: COMMAND NOT EXECUTED - INPUT DATA ERROR)
 2020 FORMAT(///28H    ADINA-PLOT  VERSION 0.00)
 2030 FORMAT(49H ***ERROR ACTION IN BATCH MODE: READ INPUT TO END)
 2050 FORMAT (26H ***ERROR: FRAME NOT GIVEN)
 2040 FORMAT (28H ***ERROR: DATABASE NOT OPEN)
 2060 FORMAT (34H ***ERROR: INVALID PARAMETER VALUE)
 2070 FORMAT(///)
 2080 FORMAT(1H )
      END
C***ADD:CDC***
CDECK BLDATA
C***END:CDC***
      BLOCK DATA
      COMMON /CNTRL/ IBATCH,NBSU,LSTC,LSTF,LSTDB,ISURL,ITWO,LINPAG,LINE
      COMMON /EPS/ EPS
      COMMON /FILES/ NFREAD,NFECHO,NFLOG,NFLIST,LUNODE,LUELEM
      COMMON /PARAM/ REALV(100),NCMD,NLASTP,ITYPE(20),INTV(100),
     1               IANUMV(160),LGHSTR,INTEG,IREAL,IANUM,ISTRIN,IOMIT
      COMMON /CALLP/ NAMZON(8),NAMERC(8),
     1               IBITZ,IWHOLE,ICALL,IXPAR
      COMMON /SICODE/ ICODE(47)
      COMMON /FIELDC/ REALI,INPREC(80),INPOS,ITYPEI,INTI,IANUMI(128),
     1               KEYI(8),NPOSRE,INECHO,MXSIGI,MXSIGR,MXSIGE,MXSTRL,
     2               ISTRIL,NFIELD,NPOSIN
      COMMON /PLOTCO/ GSCALE,DSCALE,XPV,YPV,PUNIT,HEIGHT,PMARG,AXEDGE,
     1              XSF,YSF,XFMAX,YFMAX,XF1,YF1,XPMAX,YPMAX,
     3              XSMIN,XSMAX,YSMIN,YSMAX,XPSAVE,YPSAVE,VIEW(3,3),
     2              NFPLOT,IONPLT,NSYSPL,NDEVPL,MORIGO,NGPTS
      COMMON /ERROR/ IERROR
      COMMON /MEMORY/ MTOT,LPROG,MEMPRT,MEMMAX,MEMNOW
      COMMON /DB/ IOPEN,NFDB,INDXST,IXTNOW,LGP,NWRITS,NREADS,
     1            LDBC,LDBCTR,LDBCTI,IPHCHK,INSTRI,INRUSE,INSTRU,
     2            MSUBF,MVIEW,MAXIS,MLINEN,MLINEE,MVAR,MRES,LSKEW,MIDSPL
      COMMON /IGPNAM/ IGPNA(50)
C
      DATA LINPAG/42/
      DATA IBATCH/1/
      DATA NFDB,NFREAD,NFECHO,NFLOG,NFLIST,NFPLOT,LUNODE,LUELEM
     1     /  1,     5,     6,    6,     6,    50,    60,    60/
      DATA NPOSRE/72/
      DATA INECHO/1/
      DATA MXSIGI,MXSIGR,MXSIGE/6,6,38/
      DATA HEIGHT/0.25/
      DATA PMARG/1.5/
      DATA AXEDGE/1.5/
      DATA XSMIN,XSMAX,YSMIN,YSMAX/0.,999.,0.,999./
      DATA XSF,YSF,XFMAX,YFMAX/0.,0., 29.7, 21.0/
      DATA MORIGO/0/
      DATA NSYSPL/0/
      DATA NDEVPL/0/
      DATA MIDSPL/1/
      DATA LSKEW/1/
      DATA NBSU/30/
      DATA MEMPRT/1/
C
      DATA MSUBF,MVIEW,MLINEN,MLINEE,MVAR,MRES
     1   /   10,   10,   10,    10,     20,   5/
      DATA EPS/1E-5/
      DATA LSTC,LSTF/0,0/
C
C          ITWO=2 IF PORTHOLE FILE FROM ADINA IS IN DOUBLE PRECISION
C          TO BE CONVERTED TO SINGLE PRECISION IN ADINA-PLOT
C
C***DEL:DPR***
C     DATA ITWO/1/
C***END:DPR***
C***ADD:DPR***
      DATA ITWO/2/
C***END:DPR***
      DATA LSTDB,IOPEN,ISURL,LDBC,LGP,LDBCTR,LDBCTI
     1    /    0,    0,    1, 131, 50,     2,   49/
      DATA NCMD,NLASTP,INPOS,ITYPEI
     1/   -9999,     0, 9999,     5/
      DATA MXSTRL,NPOSIN
     1/       128,     2/
      DATA MEMMAX,IONPLT,GSCALE,DSCALE,XPV,YPV
     1/         0,     0,    1.,   1., 0., 0./
      DATA ICODE/0,1,2,3,4,5,6,7,8,9,10,11,12,13,14,15,16,17,18,19,20,
     1          21,22,23,24,25,26,27,28,29,30,31,32,33,34,35,36,37,38,
     2          39,40,41,42,43,44,45,46/
      DATA IGPNA  /1,2,3,4,5,6,7,8,9,10,11,12,13,14,15,16,17,18,19,20,
     1          21,22,23,24,25,26,27,28,29,30,31,32,33,34,35,36,37,38,
     2          39,40,41,42,43,44,45,46,47,48,49,50/
      DATA INTEG,IREAL,IANUM,ISTRIN,IOMIT/1,2,3,7,4/
      DATA IWHOLE/0/
      END
C***ADD:CDC***
CDECK ALIGN
C***END:CDC***
      SUBROUTINE ALIGN(I)
C          ALIGN START OF INTEGER ARRAY TO REAL WORD BOUNDARY
C          ON COMPUTERS WHERE REAL WORD LENGTH IS A MULTIPLE OF
C          INTEGER WORD LENGTH
C
      COMMON /CNTRL/ IBATCH,NBSU,LSTC,LSTF,LSTDB,ISURL,ITWO,LINPAG,LINE
C
      IALIGN = ISURL * ITWO
      IF (IALIGN.EQ.1) GOTO 900
      I = ((I - 1) / IALIGN + 1) * IALIGN
  900 RETURN
      END
C***ADD:CDC***
CDECK SIZE
C***END:CDC***
C
      SUBROUTINE SIZE(N)
C
      DIMENSION IA(1)
C          BLANK COMMON SIZE  LIMIT CHECK IF MTOT > 0 AT PROGRAM START
C                             DYNAMIC MEMORY REQUEST IF MTOT = 0
C          N = SIZE REQUIRED BY CALLING PROGRAM
C          IERROR= RETURN CODE = 1 IF MEMORY IS NOT AVAILIBLE
C          CDY = CDC DYNAMIC BLANK COMMON SIZE
C          UDY = UNIVAC DYNAMIC BLANK COMMON SIZE
C
      COMMON /MEMORY/ MTOT,LPROG,MEMPRT,MEMMAX,MEMNOW
      COMMON /ERROR/ IERROR
      COMMON /FILES/ NFREAD,NFECHO,NFLOG,NFLIST,LUNODE,LUELEM
      COMMON A(1)
      EQUIVALENCE (A(1),IA(1))
C
C          CHECK THAT START AND CURRENT END OF BLANK COMMON IS NOT
C          ACCIDENTALLY CHANGED
C
      IF (IA(1).EQ.-87878) GOTO 2
        WRITE (NFLOG,2030)
        GOTO 800
  2   IF (IA(MEMNOW).NE.-87878) WRITE (NFLOG,2040)
C
      IF (N.GT.0) GOTO 5
        WRITE (NFLOG,2020)
        GOTO 800
  5   CALL ALIGN(N)
      MEMNOW = N + 10
C***ADD:CDY***
C*         CDC DYNAMIC INCREASE OF BLANK COMMON
C*         THE USER MUST VERIFY THIS CODING FOR HIS SYSTEM
C     IF (MTOT.NE.0) GOTO 10
C     LPROG = LOCF(A)
C 10  LCORE = LPROG + MEMNOW
C     MTOT = MEMNOW
C     CALL XRFL(LCORE)
C***END:CDY***
C***ADD:UDY***
C*         UNIVAC DYNAMIC INCREASE OF BLANK COMMON
C*         THE USER MUST VERIFY THIS CODING FOR HIS SYSTEM
C     LRPOG= LOC(A)
C     LCORE = LPROG + MEMNOW
C     IF (MEMNOW.LT.MTOT) GOTO 80
C     MTOT = MEMNOW
C     CALL XRFL(LCORE)
C***END:UDY***
C***DEL:CDY,UDY***
C*         FIX LENGTH OF BLANK COMMON
      IF (MEMNOW.LT.MTOT) GOTO 80
      WRITE (NFLOG,2010) MEMNOW, MTOT
      GOTO 800
C***END:CDY,UDY***
  80  CONTINUE
      IF (MEMPRT.EQ.2)  WRITE (NFLOG,2000) MEMNOW
      IF (MEMNOW.GT.MEMMAX) MEMMAX = MEMNOW
      IA(MEMNOW) = -87878
  900 RETURN
  800 IERROR = 1
      GOTO 900
 2000 FORMAT (27H ***MEMORY SIZE REQUESTED =,I6,12H IS OBTAINED)
 2010 FORMAT (47H ***ERROR: BLANK COMMON MEMORY SIZE REQUESTED =,
     1I6,26H IS NOT AVAILIBLE, MTOT = ,I6)
 2020 FORMAT (32H ***ERROR: ZERO MEMORY REQUESTED)
 2030 FORMAT (47H ***ERROR: BLANK COMMON LOCATION 1 IS DESTROYED)
 2040 FORMAT (49H ***ERROR: BLANK COMMON END OF LAST USED AREA IS ,
     1        9HDESTROYED)
      END
C***ADD:CDC***
CDECK APCHAR
C***END:CDC***
      SUBROUTINE APCHAR(ICODE)
C
      DIMENSION ICHAR(47)
C
      DATA ICHAR /1H0,1H1,1H2,1H3,1H4,1H5,1H6,1H7,1H8,1H9,
     1            1H ,1HA,1HB,1HC,1HD,1HE,1HF,1HG,1HH,1HI,
     2            1HJ,1HK,1HL,1HM,1HN,1HO,1HP,1HQ,1HR,1HS,
     3            1HT,1HU,1HV,1HW,1HX,1HY,1HZ,1H.,1H,,1H+,
     4            1H-,1H=,1H(,1H),1H/,1H*,1H'/
C
      ICODE = ICHAR(ICODE+1)
      RETURN
      END
C***ADD:CDC***
CDECK DBWRIT
C***END:CDC***
      SUBROUTINE DBWRIT (AA,LREAL,LINT,IGP,ISGP,ITIME)
C
      DIMENSION IA(1),AA(1)
      COMMON /ERROR/ IERROR
      COMMON /CNTRL/ IBATCH,NBSU,LSTC,LSTF,LSTDB,ISURL,ITWO,LINPAG,LINE
      COMMON /FILES/ NFREAD,NFECHO,NFLOG,NFLIST,LUNODE,LUELEM
      COMMON /DB/ IOPEN,NFDB,INDXST,IXTNOW,LGP,NWRITS,NREADS,
     1            LDBC,LDBCTR,LDBCTI,IPHCHK,INSTRI,INRUSE,INSTRU,
     2            MSUBF,MVIEW,MAXIS,MLINEN,MLINEE,MVAR,MRES,LSKEW,MIDSPL
      COMMON /DBC/ IHED(18),NDAREC,LDAREC,NRECS,NWORDS,NEXREC,NEXTIX,
     1             LIX,LIXT,NSTRI,NSTRUC,NEGIT,NEGAT,NFREQ,
     2             IXGP(50),MXSGP(50),
     3             FILL1
      COMMON /DIM/ I01,I02,I03,I04,I05,I06,I07,I08,I09,I010,I011,
     1             I1,I2,I3,I4,I5,I6,I7,I8,I9,I10,I11,I12,I13,I14,I15,
     2             I16,I17,I18,I19,I20,
     3             N1,N2,N3,N4,N5,N6,N7,N8,N9,N10,N11,N12,N13,N14,N15,
     4             N16,N17,N18,N19,N20
      COMMON A(1)
      EQUIVALENCE (A(1),IA(1))
C
      IF (IOPEN.EQ.1) GOTO 100
      WRITE (NFLOG,2000)
      GOTO 800
  100 CONTINUE
C
C          CHECK INDEX KEYS IGP, ISGP, ITIME
C
      IF (IGP.LT.3.OR.IGP.GT.LGP) GOTO 150
      IF (ISGP.LT.1.OR.ISGP.GT.MXSGP (IGP)) GOTO 150
      IF (ITIME.LT.0.OR.ITIME.GE.LIXT) GOTO 150
      GOTO 200
  150 WRITE (NFLOG,2005)
      GOTO 800
  200 CONTINUE
C
C          INITIALIZE IF FIRST WRITE FOR THIS IGP
C
      IF (IXGP(IGP).GT.0) GOTO 300
      IXGP(IGP) = NEXTIX
      NEXTIX = NEXTIX + MXSGP (IGP)
      IF (NEXTIX.LE.LIX) GOTO 300
      WRITE (NFLOG,2010)
      GOTO 800
  300 CONTINUE
C
C          DIRECT ACCRESS INDEX IXSGP IS NOW USED
C
C
      IXIX = IXGP(IGP) + ISGP - 1
      I01NOW = I01 + IXIX
      I02NOW = I02 + IXIX
      I03NOW = I03 + IXIX
      I04NOW = I04 + IXIX
      CALL DBINDX (I03,LIX)
C
C          UPDATE OR CHECK LREAL LINT ARRAYS
C
      IF (IA(I01NOW).EQ.0)  IA(I01NOW) = LREAL
      IF (IA(I02NOW).EQ.0)  IA(I02NOW) = LINT
      IF (LREAL.NE.IA(I01NOW)) GOTO 350
      IF (LINT .NE.IA(I02NOW)) GOTO 350
      IF (LINT.LT.0.OR.LREAL.LT.0) GOTO 350
      L = LREAL + LINT
      IF (L.LE.0 .OR. L.GT.1000000) GOTO 350
      IF (LSTDB.EQ.0) GOTO 390
      IF (LSTDB.GT.2 .AND. LSTDB.NE.IGP) GOTO 390
      WRITE (NFLOG,2090) IGP,ISGP,ITIME,LREAL,LINT
      IF (LSTDB.NE.2) CALL DBLSTR (AA,LREAL,LINT)
      GOTO 390
  350 WRITE (NFLOG,2030)
      GOTO 800
C
C          ITIME = 0
C
  390 CONTINUE
      IF (ITIME.GT.0) GOTO 400
      INDEX = IXIX
      IF (IA(I04NOW).EQ.0) GOTO 700
      WRITE (NFLOG,2020)
      GOTO 150
C
C          ITIME .GT. 0 - USE INDEX IXTIME
C          IF OUR IXTIME NOT NOW IN MEMORY
C          - WRITE OLD IXTIME IF IT IS UPDATED (IXTNOW POSITIVE)
C          - READ OR INITIALIZE NEW IXTIME
C
  400 CONTINUE
      IF (IA(I04NOW).GT.0.OR.IA(I03NOW).EQ.0) GOTO 410
      WRITE (NFLOG,2025)
      GOTO 150
  410 CONTINUE
      IF (IABS(IXTNOW).EQ.IXIX) GOTO 500
      IF (IXTNOW.GT.0)  CALL DBW (IA(I05),0,LIXT,IXTNOW)
      IF (IERROR.NE.0) GOTO 900
      IF (IA(I03NOW).GT.0) GOTO 450
      DO 420 I=1,LIXT
  420   IA(I05+I-1) = 0
      CALL DBW (IA(I05),0,LIXT,IXIX)
      IF (IERROR.NE.0) GOTO 900
      GOTO 460
  450 CALL DBR (IA(I05),0,LIXT,IXIX)
      IF (IERROR.NE.0) GOTO 900
  460 CONTINUE
      IXTNOW = IXIX
  500 CONTINUE
      INDEX = ITIME
      IF (IA(I04NOW).LT.ITIME) IA(I04NOW) = ITIME
      CALL DBINDX (I05,LIXT)
C
C          WRITE
C
  700 CONTINUE
      CALL DBW (AA,LREAL,LINT,INDEX)
      GOTO 900
C
  800 IERROR = 1
      WRITE (NFLOG,2090) IGP,ISGP,ITIME,LREAL,LINT
  900 RETURN
C
 2000 FORMAT (28H ***ERROR: DATABASE NOT OPEN)
 2005 FORMAT (29H ***ERROR: DBWRIT KEY INVALID
     1          6H ISGP=,I5,7H ITIME=,I5)
 2010 FORMAT (31H ***ERROR: DBWRIT LIX TOO SMALL)
 2020 FORMAT (37H ***ERROR: DBWRIT ITIME MUST NOT BE 0)
 2025 FORMAT (33H ***ERROR: DBWRIT ITIME MUST BE 0)
 2030 FORMAT (34H ***ERROR: DBWRIT LINT LREAL CHECK)
 2090 FORMAT (/16H ***DBWRIT: IGP=,I3,6H ISGP=,I4,
     1        7H ITIME=,I6,7H LREAL=,I6,6H LINT=,I6)
      END
C***ADD:CDC***
CDECK DBW
C***END:CDC***
      SUBROUTINE DBW (AA,LREAL,LINT,INDEX)
      DIMENSION IA(1),AA(1)
      COMMON /ERROR/ IERROR
      COMMON /CNTRL/ IBATCH,NBSU,LSTC,LSTF,LSTDB,ISURL,ITWO,LINPAG,LINE
      COMMON /FILES/ NFREAD,NFECHO,NFLOG,NFLIST,LUNODE,LUELEM
      COMMON /DB/ IOPEN,NFDB,INDXST,IXTNOW,LGP,NWRITS,NREADS,
     1            LDBC,LDBCTR,LDBCTI,IPHCHK,INSTRI,INRUSE,INSTRU,
     2            MSUBF,MVIEW,MAXIS,MLINEN,MLINEE,MVAR,MRES,LSKEW,MIDSPL
      COMMON /DBC/ IHED(18),NDAREC,LDAREC,NRECS,NWORDS,NEXREC,NEXTIX,
     1             LIX,LIXT,NSTRI,NSTRUC,NEGIT,NEGAT,NFREQ,
     2             IXGP(50),MXSGP(50),
     3             FILL1
      COMMON A(1)
      EQUIVALENCE (A(1),IA(1))
C
C          COMPUTE LENGTH TO BE WRITTEN
C          AND UPDATE STATISTICS IF NEW RECORD
C
      LTOTAL = LREAL + ((LINT - 1) / ISURL + 1)
      I = INDXST + INDEX
      IF  (IA(I).NE.0) GOTO 5
        NRECS = NRECS + 1
        NWORDS = NWORDS + LTOTAL
        IF (INDXST.EQ.I05) IXTNOW = IABS(IXTNOW)
  5   CONTINUE
C
C          CHECK INDEX VALUE
C
      IF (INDEX.GT.0.AND.INDXST.GT.0) GOTO 10
      WRITE (NFLOG,2030)
      IERROR = 1
      GOTO 15
  10  CONTINUE
      IF (LSTDB.NE.2) GOTO 20
   15 WRITE (NFLOG,2090) LREAL, LINT, INDXST, INDEX,IA(I),NEXREC
      CALL DBLSTR (AA,LREAL,LINT)
  20  CONTINUE
C***ADD:CDC***
C     CALL WRITMS (NFDB,AA,LTOTAL,INDEX,-1)
C***END:CDC***
C***ADD:IBM,BUR***
C*         IF ADD SET RECORD ADDRESS IN INDEX ARRAY TO NEXT FREE RECORD
C*         IF REPLACE PICK UP DISK RECORD ADDRESS FROM INDEX ARRAY
C*         AND REWRITE IN SAME RECORD(S)
C*
      NEWREC = 0
      IF (IA(I).NE.0) GOTO 100
      IA(I) = NEXREC
      NEWREC = 1
 100  CONTINUE
      IREC = IA(I)
C*
C*         SPLIT RECORD INTO ONE OR MORE DISK RECORDS OF FIX LENGTH
C*         IF ADD AND NOT REPLACE - UPDATE NEXT FREE RECORD (NEXREC)
C*
      II = 1
 200  JJ = II - 1 + LDAREC
      IF (JJ.GT.LTOTAL) JJ = LTOTAL
      IF (IREC.LE.NDAREC) GOTO 300
      WRITE (NFLOG,2000) NDAREC, LDAREC
      IERROR = 1
      GOTO 900
 300  IDUM = IREC
      WRITE (NFDB'IDUM) (AA(I),I=II,JJ)
      IREC = IREC + 1
      IF (NEWREC .EQ.1) NEXREC = IREC
      II = JJ + 1
      IF (II.LE.LTOTAL) GOTO 200
C***END:IBM,BUR***
C
  900 NWRITS = NWRITS + 1
      RETURN
C
 2000 FORMAT (48H ***ERROR: DATABASE WRITE ATTEMPT TO STORE MORE ,
     9      8HPHYSICAL,
     1      /11X,33HRECORDS THAN THE MAX NO (NDAREC=,I6,10H) DEFINED
     2  /11X,53HIN SUBROUTINE DBOPEN  - PLEASE INCREASE NDAREC VALUE
     3  /11X,34HOR PHYSICAL RECORD LENGTH (LDAREC=,I6,14H AND RECOMPILE)
 2030 FORMAT (38H ***ERROR: DBW INDEX OR INDXST INVALID)
 2090 FORMAT (/15H ***DBW: LREAL=,I6,6H LINT=,I6,
     1        8H INDXST=,I6,7H INDEX=,I6,7H DADDR=,I10,8H NEXREC=,I10)
      END
C***ADD:CDC***
CDECK DBINDX
C***END:CDC***
      SUBROUTINE DBINDX (INDX,LINDX)
C
      DIMENSION IA(1)
      COMMON /DB/ IOPEN,NFDB,INDXST,IXTNOW,LGP,NWRITS,NREADS,
     1            LDBC,LDBCTR,LDBCTI,IPHCHK,INSTRI,INRUSE,INSTRU,
     2            MSUBF,MVIEW,MAXIS,MLINEN,MLINEE,MVAR,MRES,LSKEW,MIDSPL
      COMMON A(1)
      EQUIVALENCE (A(1),IA(1))
C***ADD:CDC***
C     IF (INDX.NE.INDXST) CALL STINDX (NFDB,IA(INDX),LINDX,0)
C***END:CDC***
      INDXST = INDX
      RETURN
      END
C***ADD:CDC***
CDECK DBREAD
C***END:CDC***
      SUBROUTINE DBREAD (AA,IGP,ISGP,ITIME)
C
      DIMENSION IA(1),AA(1)
      COMMON /ERROR/ IERROR
      COMMON /CNTRL/ IBATCH,NBSU,LSTC,LSTF,LSTDB,ISURL,ITWO,LINPAG,LINE
      COMMON /FILES/ NFREAD,NFECHO,NFLOG,NFLIST,LUNODE,LUELEM
      COMMON /DB/ IOPEN,NFDB,INDXST,IXTNOW,LGP,NWRITS,NREADS,
     1            LDBC,LDBCTR,LDBCTI,IPHCHK,INSTRI,INRUSE,INSTRU,
     2            MSUBF,MVIEW,MAXIS,MLINEN,MLINEE,MVAR,MRES,LSKEW,MIDSPL
      COMMON /DBC/ IHED(18),NDAREC,LDAREC,NRECS,NWORDS,NEXREC,NEXTIX,
     1             LIX,LIXT,NSTRI,NSTRUC,NEGIT,NEGAT,NFREQ,
     2             IXGP(50),MXSGP(50),
     3             FILL1
      COMMON /DIM/ I01,I02,I03,I04,I05,I06,I07,I08,I09,I010,I011,
     1             I1,I2,I3,I4,I5,I6,I7,I8,I9,I10,I11,I12,I13,I14,I15,
     2             I16,I17,I18,I19,I20,
     3             N1,N2,N3,N4,N5,N6,N7,N8,N9,N10,N11,N12,N13,N14,N15,
     4             N16,N17,N18,N19,N20
      COMMON A(1)
      EQUIVALENCE (A(1),IA(1))
C
      LREAL = 0
      LINT  = 0
      IF (IOPEN.EQ.1) GOTO 100
      WRITE (NFLOG,2000)
      GOTO 800
  100 CONTINUE
C
C          CHECK RECORD KEYS IGP, ISGP, ITIME
C
      IF (IGP.LT.3.OR.IGP.GT.LGP) GOTO 150
      IF (ISGP.LT.1.OR.ISGP.GT.MXSGP (IGP)) GOTO 150
      IF (ITIME.LT.0.OR.ITIME.GE.LIXT) GOTO 150
      GOTO 200
  150 WRITE (NFLOG,2005)
      GOTO 800
  200 CONTINUE
C
C          DIRECT ACCRESS INDEX IXSGP IS NOW USED
C
      IF (IXGP(IGP).NE.0) GOTO 250
      WRITE (NFLOG,2030)
      GOTO 150
  250 IXIX = IXGP(IGP) + ISGP - 1
      I01NOW = I01 + IXIX
      I02NOW = I02 + IXIX
      I03NOW = I03 + IXIX
      I04NOW = I04 + IXIX
      IF (IA(I03NOW).NE.0) GOTO 260
      WRITE (NFLOG,2040)
      GOTO 150
  260 CALL DBINDX (I03,LIX)
C
C          GET LREAL, LINT FROM SUBGROUP ARRAYS
C
      LREAL = IA(I01NOW)
      LINT = IA(I02NOW)
      IF (LSTDB.EQ.0) GOTO 300
      IF (LSTDB.GT.2 .AND. LSTDB.NE.IGP) GOTO 300
      WRITE (NFLOG,2090) IGP,ISGP,ITIME,LREAL,LINT
  300 CONTINUE
C
C          ITIME = 0
C
      IF (ITIME.GT.0) GOTO 400
      INDEX = IXIX
      IF (IA(I04NOW).EQ.0) GOTO 600
      WRITE (NFLOG,2020)
      GOTO 150
C
C          ITIME .GT. 0 - USE DIRECT ACCESS INDEX ITIME
C          IF OUR IXTIME NOT IN MEMORY NOW
C          - WRITE OLD IXTIME IF UPDATED (IXTNOW POSITIVE)
C          - READ OR INITIALIZE NEW IXTIME
C
  400 CONTINUE
      IF (IA(I04NOW).GT.0) GOTO 410
      WRITE (NFLOG,2025)
      GOTO 150
  410 IF (IABS(IXTNOW).EQ.IXIX) GOTO 500
      IF (IXTNOW.GT.0) CALL DBW (IA(I05),0,LIXT,IXTNOW)
      IF (IERROR.NE.0) GOTO 900
      CALL DBR (IA(I05),0,LIXT,IXIX)
      IF (IERROR.NE.0) GOTO 900
      IXTNOW = -IXIX
  500 INDEX = ITIME
      IF (IA(I05+ITIME).NE.0) GOTO 510
      WRITE (NFLOG,2050)
      GOTO 150
  510 CALL DBINDX (I05,LIXT)
  600 CONTINUE
C
C          READ
C
       CALL DBR (AA,LREAL,LINT,INDEX)
      IF (LSTDB.EQ.1 .OR. LSTDB.EQ.IGP) CALL DBLSTR (AA,LREAL,LINT)
      GOTO 900
C
  800 IERROR = 1
      WRITE (NFLOG,2090) IGP,ISGP,ITIME,LREAL,LINT
  900 RETURN
C
 2000 FORMAT (28H ***ERROR: DATABASE NOT OPEN)
 2005 FORMAT (29H ***ERROR: DBREAD KEY INVALID)
 2020 FORMAT (37H ***ERROR: DBREAD ITIME MUST NOT BE 0)
 2025 FORMAT (33H ***ERROR: DBREAD ITIME MUST BE 0)
 2030 FORMAT (40H ***ERROR: DBREAD IGP NOT FOUND IN INDEX)
 2040 FORMAT (41H ***ERROR: DBREAD ISGP NOT FOUND IN INDEX)
 2050 FORMAT (42H ***ERROR: DBREAD ITIME NOT FOUND IN INDEX)
 2090 FORMAT (/16H ***DBREAD: IGP=,I3,6H ISGP=,I5,
     1        7H ITIME=,I6,7H LREAL=,I6,6H LINT=,I6)
      END
C***ADD:CDC***
CDECK DBR
C***END:CDC***
      SUBROUTINE DBR (AA,LREAL,LINT,INDEX)
C
      DIMENSION IA(1),AA(1)
      COMMON /ERROR/ IERROR
      COMMON /CNTRL/ IBATCH,NBSU,LSTC,LSTF,LSTDB,ISURL,ITWO,LINPAG,LINE
      COMMON /FILES/ NFREAD,NFECHO,NFLOG,NFLIST,LUNODE,LUELEM
      COMMON /DB/ IOPEN,NFDB,INDXST,IXTNOW,LGP,NWRITS,NREADS,
     1            LDBC,LDBCTR,LDBCTI,IPHCHK,INSTRI,INRUSE,INSTRU,
     2            MSUBF,MVIEW,MAXIS,MLINEN,MLINEE,MVAR,MRES,LSKEW,MIDSPL
      COMMON /DBC/ IHED(18),NDAREC,LDAREC,NRECS,NWORDS,NEXREC,NEXTIX,
     1             LIX,LIXT,NSTRI,NSTRUC,NEGIT,NEGAT,NFREQ,
     2             IXGP(50),MXSGP(50),
     3             FILL1
      COMMON A(1)
      EQUIVALENCE (A(1),IA(1))
C
C          CHECK INDEX FOR VALIDITY
C
      I = INDXST + INDEX
      IREC = IA(I)
      IF (INDEX.GT.0 .AND. INDXST.GT.0 .AND. IREC.NE.0) GOTO 10
      WRITE (NFLOG,2030)
      IERROR = 1
      GOTO 900
  10  CONTINUE
      IF (LSTDB.EQ.2) WRITE (NFLOG,2090) LREAL,LINT,INDXST,INDEX,IREC
C
C          COMPUTE LENGTH TO BE READ
C
      LTOTAL = LREAL + ((LINT - 1) / ISURL + 1)
C
C***ADD:CDC***
C     CALL READMS (NFDB,AA,LTOTAL,INDEX)
C***END:CDC***
C***ADD:IBM,BUR***
C*
C*         READ ONE OR MORE DISK RECORDS OF FIX LENGTH TO FILL UP AA
C*
      II = 1
 200  JJ = II - 1 + LDAREC
      IF (JJ.GT.LTOTAL) JJ = LTOTAL
      IDUM = IREC
      READ (NFDB'IDUM) (AA(I),I=II,JJ)
      IREC = IREC + 1
      II = JJ + 1
      IF (II.LE.LTOTAL) GOTO 200
C***END:IBM,BUR***
C
      NREADS = NREADS + 1
      IF (LSTDB.NE.2) GOTO 900
      CALL DBLSTR (AA,LREAL,LINT)
  900 RETURN
C
 2030 FORMAT (51H ***ERROR: DBR INDEX, INDXST OR ARRAY VALUE INVALID)
 2090 FORMAT (/15H ***DBR: LREAL=,I6,6H LINT=,I6,
     1        8H INDXST=,I6,7H INDEX=,I6,7H DADDR=,I10)
      END
C***ADD:CDC***
CDECK DBLSTR
C***END:CDC***
      SUBROUTINE DBLSTR (AA,LREAL,LINT)
C
      DIMENSION AA(1)
      COMMON /FILES/ NFREAD,NFECHO,NFLOG,NFLIST,LUNODE,LUELEM
C
C          WRITE REALS
C
      II = 1
  600 IF (II.GT.LREAL) GOTO 690
      JJ = II + 9
      IF (JJ.GT.LREAL) JJ = LREAL
      I = II
  620 IF (I.EQ.LREAL) GOTO 630
      IF (AA(I).NE.AA(I+1)) GOTO 630
      I = I + 1
      GOTO 620
  630 IF (I.GT.JJ) GOTO 640
      WRITE (NFLOG,2610) II, (AA(I),I=II,JJ)
      II = JJ + 1
      GOTO 600
  640 WRITE (NFLOG,2620) II, AA(II)
      II = I + 1
      GOTO 600
  690 CONTINUE
C
      CALL DBLSTI (AA(LREAL+1),LINT)
      RETURN
 2610 FORMAT (1H ,I4,1H:,10(1X,G9.3))
 2620 FORMAT (1H ,I4,1H:,1X,G9.3,8H SAME...)
      END
C***ADD:CDC***
CDECK DBLSTI
C***END:CDC***
      SUBROUTINE DBLSTI (IAA,LINT)
C
      DIMENSION IAA(1)
      COMMON /FILES/ NFREAD,NFECHO,NFLOG,NFLIST,LUNODE,LUELEM
C
C
C          WRITE INTEGERS
C
      II = 1
  700 IF (II.GT.LINT) GOTO 900
      JJ = II + 19
      IF (JJ.GT.LINT) JJ = LINT
      I = II
  720 IF (I.EQ.LINT) GOTO 730
      IF (IAA(I).NE.IAA(I+1)) GOTO 730
      I = I + 1
      GOTO 720
  730 IF (I.GT.JJ) GOTO 740
      WRITE (NFLOG,2630) II, (IAA(I),I=II,JJ)
      II = JJ + 1
      GOTO 700
  740 WRITE (NFLOG,2640) II, IAA(II)
      II = I + 1
      GOTO 700
C
  900 RETURN
C
 2630 FORMAT (1H ,I4,1H:,20(1X,I4))
 2640 FORMAT (1H ,I4,1H:,1X,I4,8H SAME...)
      END
C***ADD:CDC***
CDECK DBOPEN
C***END:CDC***
      SUBROUTINE DBOPEN
C
      DIMENSION IA(1)
      COMMON /ERROR/ IERROR
      COMMON /FILES/ NFREAD,NFECHO,NFLOG,NFLIST,LUNODE,LUELEM
      COMMON /MEMORY/ MTOT,LPROG,MEMPRT,MEMMAX
      COMMON /DB/ IOPEN,NFDB,INDXST,IXTNOW,LGP,NWRITS,NREADS,
     1            LDBC,LDBCTR,LDBCTI,IPHCHK,INSTRI,INRUSE,INSTRU,
     2            MSUBF,MVIEW,MAXIS,MLINEN,MLINEE,MVAR,MRES,LSKEW,MIDSPL
      COMMON /DBC/ IHED(18),NDAREC,LDAREC,NRECS,NWORDS,NEXREC,NEXTIX,
     1             LIX,LIXT,NSTRI,NSTRUC,NEGIT,NEGAT,NFREQ,
     2             IXGP(50),MXSGP(50),
     3             FILL1
      COMMON /DIM/ I01,I02,I03,I04,I05,I06,I07,I08,I09,I010,I011,
     1             I1,I2,I3,I4,I5,I6,I7,I8,I9,I10,I11,I12,I13,I14,I15,
     2             I16,I17,I18,I19,I20,
     3             N1,N2,N3,N4,N5,N6,N7,N8,N9,N10,N11,N12,N13,N14,N15,
     4             N16,N17,N18,N19,N20
      COMMON A(1)
      EQUIVALENCE (A(1),IA(1))
C
C***ADD:CDC***
C     CALL OPENMS (NFDB,IA(2),3,0)
C***END:CDC***
C***ADD:IBM,BUR***
C*
C*         DATABASE FILE CONSTANTS ARE FIXED AT COMPILATION TIME:
C*         LDAREC = LENGTH OF PHYSICAL RECORD IN NUMBER OF REAL WORDS
C*         NDAREC = NUMBER OF PHYSICAL DISK RECORDS AVAILIBLE
C*         NFDB   = FILE UNIT NUMBER
C*         PLEASE CHANGE VALUES AND RECOMPILE IF REQUIRED
C*
      DEFINE FILE 1 (1000,500,U,NREC1)
      NFDB = 1
C***END:IBM,BUR***
      NDAREC = 1000
      LDAREC = 500
C
C
      CALL DBINDX (2,3)
      MEMMAX = 0
      IOPEN = 1
      RETURN
      END
C***ADD:CDC***
CDECK DBCLOS
C***END:CDC***
      SUBROUTINE DBCLOS
C
      DIMENSION IA(1)
      COMMON /ERROR/ IERROR
      COMMON /FILES/ NFREAD,NFECHO,NFLOG,NFLIST,LUNODE,LUELEM
      COMMON /MEMORY/ MTOT,LPROG,MEMPRT,MEMMAX,MEMNOW
      COMMON /DB/ IOPEN,NFDB,INDXST,IXTNOW,LGP,NWRITS,NREADS,
     1            LDBC,LDBCTR,LDBCTI,IPHCHK,INSTRI,INRUSE,INSTRU,
     2            MSUBF,MVIEW,MAXIS,MLINEN,MLINEE,MVAR,MRES,LSKEW,MIDSPL
      COMMON /DBC/ IHED(18),NDAREC,LDAREC,NRECS,NWORDS,NEXREC,NEXTIX,
     1             LIX,LIXT,NSTRI,NSTRUC,NEGIT,NEGAT,NFREQ,
     2             IXGP(50),MXSGP(50),
     3             FILL1
      COMMON /DIM/ I01,I02,I03,I04,I05,I06,I07,I08,I09,I010,I011,
     1             I1,I2,I3,I4,I5,I6,I7,I8,I9,I10,I11,I12,I13,I14,I15,
     2             I16,I17,I18,I19,I20,
     3             N1,N2,N3,N4,N5,N6,N7,N8,N9,N10,N11,N12,N13,N14,N15,
     4             N16,N17,N18,N19,N20
      COMMON A(1)
      EQUIVALENCE (A(1),IA(1))
      IF (IOPEN.EQ.0) GOTO 900
C
C          WRITE IXTIME IF UPDATED (IXTNOW POSITIVE)
C
      IF (IXTNOW.LE.0) GOTO 200
      CALL DBINDX (I03,LIX)
      CALL DBW (IA(I05),0,LIXT,IXTNOW)
  200 CONTINUE
C
C          WRITE COMMON /DBC/ AND SUBGROUP ARRAYS
C
      CALL DBINDX (2,3)
      CALL DBW (IHED,0,LDBC,1)
      CALL DBW (IA(I01),0,(LIX*4),2)
C
C***ADD:CDC***
C     CALL CLOSMS (NFDB)
C***END:CDC***
C
      IOPEN = 0
C
C          WRITE MEMORY AND DATABASE STATISTICS
C
      IF (MEMPRT.EQ.0) GOTO 900
      N = NWORDS / NRECS + 1
      M = MTOT
      IF (MTOT.LT.MEMMAX) M = 0
      WRITE (NFLOG,2000) MEMMAX,M,NWRITS,NREADS,NRECS,N
      N = NEXREC - 1
      IF (NEXREC.GT.1) WRITE (NFLOG,2010) N,NDAREC,LDAREC
C
  900 RETURN
C
 2000 FORMAT(/47H    DATABASE CLOSED:  BLANK COMMON MEMORY USED=,I8,
     -  10H  OF MTOT=,I8/
     1  4X,7HWRITES=,I5,8H  READS=,I5,10H  RECORDS=,I6,
     2        16H AVERAGE LENGTH=,I4)
 2010 FORMAT (4X,47HDIRECT ACCESS FIX LENGTH PHYSICAL RECORDS USED=,I6,
     1        5H MAX=,I6,8H LENGTH=,I6)
      END
C***ADD:CDC***
CDECK BITGET
C***END:CDC***
      SUBROUTINE BITGET (IWORD,IBITZ,IOLD)
C
      COMMON /CNTRL/ IBATCH,NBSU,LSTC,LSTF,LSTDB,ISURL,ITWO,LINPAG,LINE
      IEXP = 2 ** (NBSU - IBITZ)
      IOLD = MOD (IWORD/IEXP,2)
      RETURN
      END
C***ADD:CDC***
CDECK ZGETNB
C***END:CDC***
      SUBROUTINE ZGETNB
C
      DIMENSION IA(1)
      COMMON /CNTRL/ IBATCH,NBSU,LSTC,LSTF,LSTDB,ISURL,ITWO,LINPAG,LINE
      COMMON /PARAM/ REALV(100),NCMD,NLASTP,ITYPE(20),INTV(100),
     1               IANUMV(8,20),LGHSTR,INTEG,IREAL,IANUM,ISTRIN,IOMIT
      COMMON /CALLP/ NAMZON(8),NAMERC(8),
     1               IBITZ,IWHOLE,ICALL,IXPAR
      COMMON /FILES/ NFREAD,NFECHO,NFLOG,NFLIST,LUNODE,LUELEM
      COMMON /ERROR/ IERROR
      COMMON /DBC/ IHED(18),NDAREC,LDAREC,NRECS,NWORDS,NEXREC,NEXTIX,
     1             LIX,LIXT,NSTRI,NSTRUC,NEGIT,NEGAT,NFREQ,
     2             IXGP(50),MXSGP(50),
     3             FILL1
      COMMON /DIM/ I01,I02,I03,I04,I05,I06,I07,I08,I09,I010,I011,
     1             I1,I2,I3,I4,I5,I6,I7,I8,I9,I10,I11,I12,I13,I14,I15,
     2             I16,I17,I18,I19,I20,
     3             N1,N2,N3,N4,N5,N6,N7,N8,N9,N10,N11,N12,N13,N14,N15,
     4             N16,N17,N18,N19,N20
      COMMON /IGPNAM/ KDBC  ,KSUBGP,KDBCTR,KSTRI ,KRSDCO,KTMIDS,
     1                KXYZ  ,KIDRN ,KICONA,KNZONE,KNPAR ,KTHICK,
     2                KITABL,KNOD  ,KEDATA,KIEZON,KFRQ  ,KPHI  ,
     3                KTIMEN,KDISP ,KVEL  ,KACC  ,KTEMP ,KTIMEE,
     4                KERES ,KSUBF ,KVIEW ,KAXIS ,KNPOIN,KVARES,
     5                KNAMEZ,KEPOIN,KSXYZ ,KX34  ,KX35  ,KX36  ,
     6                KX37  ,KX38  ,KX39  ,KX40  ,KX41  ,KX42  ,
     7                KX43  ,KX44  ,KX45  ,KX46  ,KX47  ,KX48  ,
     8                KX49  ,KX50
      COMMON A(1)
      EQUIVALENCE (A(1),IA(1))
      IBITZ = IWHOLE
      DO 100 I=1,8
        ICODE = IANUMV(I,1)
        CALL APCHAR (ICODE)
  100   NAMZON(I) = ICODE
      IF (ITYPE(1).EQ.IOMIT) GOTO 900
C
C          READ NAMEZ
C
      IF (IXGP(KNAMEZ).EQ.0) GOTO 700
      I2 = I1 + 8 * NBSU
      CALL SIZE (I2)
      IF (IERROR.NE.0) GOTO 900
      CALL DBREAD (IA(I1),KNAMEZ,1,0)
      IF (IERROR.NE.0) GOTO 900
      DO 200 I=1,NBSU
        DO 150 J=1,8
          K = I1 + (I-1) * 8 + J - 1
          IF (IA(K).NE.IANUMV(J,1)) GOTO 200
  150     CONTINUE
        IBITZ = I
        GOTO 900
  200 CONTINUE
  700 WRITE (NFLOG,2000)
  800 IERROR = 1
  900 RETURN
 2000 FORMAT (31H ***ERROR: ZONENAME NOT DEFINED)
      END
C***ADD:CDC***
CDECK KINDN
C***END:CDC***
      SUBROUTINE KINDN (NDIR,KIND,KINDHD)
      DIMENSION KINDHD(3)
      DIMENSION IHDCOV(69)
      DATA IHDCOV
     1  /4H  RE,4HSULT,4HANT ,4HX-DI,4HR DI,4HSPL.,4HY-DI,4HR DI,4HSPL.
     2                       ,4HZ-DI,4HR DI,4HSPL.,4HX-RO,4HT DI,4HSPL.
     3  ,4HY-RO,4HT DI,4HSPL.,4HZ-RO,4HT DI,4HSPL.,4HX-DI,4HR VE,4HLOC.
     4  ,4HY-DI,4HR VE,4HLOC.,4HZ-DI,4HR VE,4HLOC.,4HX-RO,4HT VE,4HLOC.
     5  ,4HY-RO,4HT VE,4HLOC.,4HZ-RO,4HT VE,4HLOC.,4HX-DI,4HR AC,4HCEL.
     6  ,4HY-DI,4HR AC,4HCEL.,4HZ-DI,4HR AC,4HCEL.,4HX-RO,4HT AC,4HCEL.
     7  ,4HY-RO,4HT AC,4HCEL.,4HZ-RO,4HT AC,4HCEL.,4H TEM,4HPERA,4HTURE
     8  ,4HX-CO,4HORDI,4HNATE,4HY-CO,4HORDI,4HNATE,4HZ-CO,4HORDI,4HNATE/
C
      J = ((KIND - 1) * 6 + NDIR) * 3
      IF (KIND.EQ.0) J = 0
      IF (KIND.EQ.4) J = 57
      IF (KIND.EQ.5) J = J - 15
      DO 10 I=1,3
  10    KINDHD(I) = IHDCOV(I+J)
      RETURN
      END
C***ADD:CDC***
CDECK KINDE
C***END:CDC***
      SUBROUTINE KINDE (IELTYP,INDNL,NTABLE,KIND,IHED)
C
C
C          ELEMENT RESULT KIND HEADLINES
C
C          NTYHED(2) = NUMBER OF KIND HEADLINES STORED FOR IELTYP=1=TRUS
C          NTYHED(3) = NUMBER OF KIND HEADLINES STORED FOR IELTYP=2=2DIM
C          ...
C          SHELL HAS SAME HEADLINES AS 3DIM
C
C
      DIMENSION IHED(1),NTYHED(16),KINHED(186),KINH1(114),KIN115(72)
C
      EQUIVALENCE (KINHED(1),KINH1(1)),(KINHED(115),KIN115(1))
C
      DATA ITRUSS,I2DIM,I3DIM,IBEAM,ISOBEA,IPLATE,ISHELL/1,2,3,4,5,6,7/
      DATA I2DIMF,I3DIMF/11,12/
C
      DATA NTYHED/1,3,8,12,0,12,12,6,0,0,0,4,4,0,0,0/
C
      DATA KINH1/
     1  4H  RE,4HSULT,4HANT ,4HAXIA,4HL FO,4HRCE ,
     2  4HAXIA,4HL ST,4HRESS,4HAXIA,4HL ST,4HRAIN,
     3  4HYY-S,4HTRES,4HS   ,4HZZ-S,4HTRES,4HS   ,
     4  4HYZ-S,4HTRES,4HS   ,4HXX-S,4HTRES,4HS   ,
     5  4HYY-S,4HTRAI,4HN   ,4HZZ-S,4HTRAI,4HN   ,
     6  4HYZ-S,4HTRAI,4HN   ,4HXX-S,4HTRAI,4HN   ,
     7  4HXX-S,4HTRES,4HS   ,4HYY-S,4HTRES,4HS   ,
     8  4HZZ-S,4HTRES,4HS   ,4HXY-S,4HTRES,4HS   ,
     9  4HXZ-S,4HTRES,4HS   ,4HYZ-S,4HTRES,4HS   ,
     -  4HXX-S,4HTRAI,4HN   ,4HYY-S,4HTRAI,4HN   ,
     1  4HZZ-S,4HTRAI,4HN   ,4HXY-S,4HTRAI,4HN   ,
     2  4HXZ-S,4HTRAI,4HN   ,4HYZ-S,4HTRAI,4HN   ,
     3  4HR-FO,4HRCE ,4H    ,4HS-FO,4HRCE ,4H    ,
     4  4HT-FO,4HRCE ,4H    ,4HR-MO,4HMENT,4H    ,
     5  4HS-MO,4HMENT,4H    ,4HT-MO,4HMENT,4H    ,
     6  4HRR-S,4HTRES,4HS   ,4HRS-S,4HTRES,4HS   ,
     7  4HRT-S,4HTRES,4HS   ,4HRR-S,4HTRAI,4HN   ,
     8  4HRS-S,4HTRAI,4HN   ,4HRT-S,4HTRAI,4HN   ,
     9  4HXL-F,4HORCE,4H    ,4HYL-F,4HORCE,4H    /
      DATA KIN115/
     1  4HXYL-,4HFORC,4HE   ,4HXL-M,4HOMEN,4HT   ,
     2  4HYL-M,4HOMEN,4HT   ,4HXYL-,4HMOME,4HNT  ,
     3  4HXXL-,4HSTRA,4HIN  ,4HYYL-,4HSTRA,4HIN  ,
     4  4HXYL-,4HSTRA,4HIN  ,4HXL-C,4HURVA,4HTURE,
     5  4HYL-C,4HURVA,4HTURE,4HXYL-,4HCURV,4H.   ,
     6  4HX-FO,4HRCE ,4H    ,4HY-FO,4HRCE ,4H    ,
     7  4HZ-FO,4HRCE ,4H    ,4HX-MO,4HMENT,4H    ,
     8  4HY-MO,4HMENT,4H    ,4HZ-MO,4HMENT,4H    ,
     9  4HPRES,4HSURE,4H    ,4HYY-S,4HTRAI,4HN   ,
     -  4HZZ-S,4HTRAI,4HN   ,4HXX-S,4HTRAI,4HN   ,
     1  4HPRES,4HSURE,4H    ,4HXX-S,4HTRAI,4HN   ,
     2  4HYY-S,4HTRAI,4HN   ,4HZZ-S,4HTRAI,4HN   /
C
C
      IELTY = IELTYP
      IF (IELTY.EQ.ISHELL .AND. NTABLE.GE.0) IELTY = I3DIM
      IX = KIND - 1
      DO 100 I=1,IELTY
  100   IX = IX + NTYHED(I)
      IF (IELTYP.EQ.IBEAM .AND. INDNL.NE.0 .AND. NTABLE.GE.0)
     1    IX = IX + 6
      IF (IELTYP.EQ.ISOBEA .AND. NTABLE.GE.0) IX = IX + 6
      IF (KIND.EQ.0) IX = 0
      DO 200 I=1,3
  200   IHED(I) = KINHED(IX*3+I)
      RETURN
      END
C***ADD:CDC***
CDECK SKEW
C***END:CDC***
      SUBROUTINE SKEW (VDIR,RSDCOS)
C
C          TRANSFORM DISPLACEMENTS AND ROTATIONS FROM
C          SKEW TO GLOBAL COORDINATE SYSTEM
C
      DIMENSION VDIR(6),RSDCOS(3,3)
C
      X = VDIR(1)
      Y = VDIR(2)
      Z = VDIR(3)
C
      DO 10 I=1,3
  10    VDIR(I) = X * RSDCOS(1,I) + Y * RSDCOS(2,I) + Z * RSDCOS(3,I)
C
      X = VDIR(4)
      Y = VDIR(5)
      Z = VDIR(6)
C
      DO 20 I=1,3
  20    VDIR(I+3) = X*RSDCOS(1,I) + Y*RSDCOS(2,I) + Z*RSDCOS(3,I)
C
      RETURN
      END
C***ADD:CDC***
CDECK ELRES
C***END:CDC***
      SUBROUTINE ELRES (IFUNC,NPAR,ETIME,IPS,ITABLE,NTABLE,
     1     IEGIT,ISEGIT,TIME,NERPTS,IDERPT,NERES,NERKI,LOCALE)
C
C
C          FIND IDENTIFICATIONS OF ELEMENT RESULTS AVAILIBLE ON PORTHOLE
C          FILE AND IN DATA BASE - AS A FUNCTION OF:
C
C          IPS = OUTPUT FLAG OR ITABLE
C          NPAR(4), ETIME = BIRTH AND DEATH OPTION
C          NPAR(1) = ELEMENT TYPE
C          NPAR(3) = TYPE OF ANALYSIS, LINEAR OR NONLINEAR
C          NPAR(7) = NUMBER OF ELEMENT NODES FOR ISOBEAM
C          NPAR(9)-NPAR(12) = INTEGRATION ORDER(S) FOR SOME ELEMENT TYPE
C          ITABLE = STRESS OUTPUT TABLE POINTED TO BY IPS
C          NPAR(13) = NTABLE = NUMBER OF STRESS OUTPUT TABLES
C
C
C          IFUNC = 1 - UPDATE ARRAYS OF ELEMENT RESULT IDS:
C
C              NERPTS(NUME) = NUMBER OF ELEMENT OUTPUT POINTS
C              IDERPT(NERES) = RESULT POINT IDENTIFICATIONS
C                          .LT.0 IF DEAD OR UNBORN ELEMENT
C
C
C          IFUNC = 2 -  UPDATE MXIDER, MXERES IN COMMON AREA
C
C
C
C          ALSO UPDATE LOCALE TO 0 IF RESULTS ARE MEASURED IN
C          GLOBAL SYSTEM  AND TO 1 IF RESULTS ARE MEASURED IN
C          LOCAL ELEMENT COORDINATE SYSTEM
C
      DIMENSION NPAR(1),ETIME(1),IPS(1),ITABLE(NTABLE,1),
     1          NERPTS(1),IDERPT(1),NERKIA(15)
C
      COMMON /ERROR/ IERROR
      COMMON /DBCTRL/ DT    ,TSTART,NUMNP ,NEQT  ,NSUBST,IDOF(6),
     1                NDOF  ,NEG   ,NMID  ,MODEX ,NSTE  ,NSTEN ,
     2                NSTEE ,NSKEWS,NMIDSS,IEIG  ,NSREFB,NEQITB,
     3                NPRIB ,NODSVB,LEMSVB,JDC   ,JAC   ,JVC   ,
     4                ISTAT ,JTC   ,NDISCE,ITP96 ,MXITAB,MXIDER,MXERES,
     5                NELPAR,MXNP  ,MXEG  ,MXEL  ,MXELNP,
     6                NDOFSA(6),NOUSE(4),FILL2
      COMMON /IGPNAM/ KDBC  ,KSUBGP,KDBCTR,KSTRI ,KRSDCO,KTMIDS,
     1                KXYZ  ,KIDRN ,KICONA,KNZONE,KNPAR ,KTHICK,
     2                KITABL,KNOD  ,KEDATA,KIEZON,KFRQ  ,KPHI  ,
     3                KTIMEN,KDISP ,KVEL  ,KACC  ,KTEMP ,KTIMEE,
     4                KERES ,KSUBF ,KVIEW ,KAXIS ,KNPOIN,KVARES,
     5                KNAMEZ,KEPOIN,KSXYZ ,KX34  ,KX35  ,KX36  ,
     6                KX37  ,KX38  ,KX39  ,KX40  ,KX41  ,KX42  ,
     7                KX43  ,KX44  ,KX45  ,KX46  ,KX47  ,KX48  ,
     8                KX49  ,KX50
C
      DATA ITRUSS,I2DIM,I3DIM,IBEAM,ISOBEA,IPLATE,ISHELL/1,2,3,4,5,6,7/
      DATA I2DIMF,I3DIMF/11,12/
      DATA NERKIA/3,8,12,6,6,12,12,0,0,0,4,4,0,0,0/
C
      IELTYP = NPAR(1)
      NUME   = NPAR(2)
      INDNL  = NPAR(3)
      IDEATH = NPAR(4)
      MODEL  = NPAR(15)
C
C          READ ETIME, IPS AND ITABLE IF NOT ALREADY DONE
C
      IF (ISEGIT.EQ.IEGIT) GOTO 100
      ISEGIT = IEGIT
      CALL DBREAD (ETIME,KEDATA,IEGIT,0)
      IF (IERROR.NE.0) GOTO 900
      IF (NTABLE.LE.0) GOTO 100
      CALL DBREAD (ITABLE,KITABL,IEGIT,0)
      IF (IERROR.NE.0) GOTO 900
  100 CONTINUE
C
C          DO FOR EVERY ELEMENT IN GROUP
C
      NERES = 0
      DO 700 IEL=1,NUME
C
      NERPT = 0
      IPSEL = IABS(IPS(IEL))
      IF (IPSEL.EQ.0) GOTO 600
C
C          FIND ELEMENT RESULT POINT IDS FOR THIS ELEMENT
C
C
C          TRUSS - RING ELEMENT: AT ONE NODE POINT
C                  2-NODE ELEMENT: AT ALL INTEGRATION POINTS
C
  200 IF (IELTYP.NE.ITRUSS) GOTO 210
      NERPT = 1
      IF (NPAR(5).EQ.1) GOTO 550
      NERPT = NPAR(10)
      GOTO 550
C
C          2DIM, 2DIMF - AT MAX 4 INTEGRATION POINT CORNERS
C                        OR AT ITABLE POINTS, MAX 9, END = 0
  210 IF (IELTYP.EQ.I2DIMF) GOTO 220
      IF (IELTYP.NE.I2DIM) GOTO 240
      IF (NTABLE.GT.0 .AND. MODEL.LE.2) GOTO 230
  220 NINT = NPAR(10)
      NERPT = NINT * NINT
      IF (NERPT.LT.4) GOTO 550
      NERPT = 4
      IF (IFUNC.EQ.2) GOTO 600
      IDERPT(NERES+1) = 1
      IDERPT(NERES+2) = NINT
      IDERPT(NERES+3) = NINT * (NINT - 1) + 1
      IDERPT(NERES+4) = NINT * NINT
      GOTO 600
C
  230 NTAB = 9
      GOTO 500
C
C          3DIM, 3DIMF - AT MAX 8 INTEGRATION POINT CORNERS
C                        OR AT ITABLE POINTS, MAX 16, 0 = END
C
  240 IF (IELTYP.EQ.I3DIMF) GOTO 250
      IF (IELTYP.NE.I3DIM) GOTO 280
      IF (NTABLE.GT.0 .AND. MODEL.LE.2) GOTO 270
  250 NINTR = NPAR(10)
      NINTS = NINTR
      NINTT = NPAR(11)
C          THIS CODING IS ALSO FOR SHELL ELEMENT TYPE
  260 NERPT = NINTR * NINTS * NINTT
      IF (NERPT.LT.8) GOTO 550
      NERPT = 8
      IF (IFUNC.EQ.2) GOTO 600
      IDERPT(NERES+1) = 1
      IDERPT(NERES+2) = NINTT
      IDERPT(NERES+3) = NINTT * (NINTS - 1) + 1
      IDERPT(NERES+4) = NINTS * NINTT
      I               = NINTS * NINTT * (NINTR - 1) + 1
      IDERPT(NERES+5) = I
      IDERPT(NERES+6) = I + NINTT - 1
      I               = I + NINTT * (NINTR - 1)
      IDERPT(NERES+7) = I
      IDERPT(NERES+8) = I + NINTT - 1
      GOTO 600
C
  270 NTAB = 16
      GOTO 500
C
C          BEAM - LINEAR ELEMENT: AT 2 NODES IN ONE RECORD ON PORTHOLE
C          NONLINEAR: AT ALL INTEGRATION POINTS
C                     OR AT ITABLE INTEG. POINTS, MAX NPAR(14), END=0
C
  280 IF (IELTYP.NE.IBEAM) GOTO 320
      IF (INDNL.NE.0 .AND. NTABLE.GE.0) GOTO 290
      NERPT = 2
      GOTO 550
C
  290 IF (NTABLE.GT.0) GOTO 310
      INTX = NPAR(9)
      INTY = NPAR(10)
      INTZ = NPAR(11)
      DO 300 I=1,INTX
      DO 300 J=1,INTZ
      DO 300 K=1,INTY
        NERPT = NERPT + 1
        IF (IFUNC.EQ.2) GOTO 300
        IDERPT(NERES+NERPT) = I*100 + K*10 + J
  300   CONTINUE
      GOTO 600
C
  310 NTAB = NPAR(14)
      GOTO 500
C
C          ISOBEAM - AT ALL INTEGRATION POINTS
C                    OR AT ITABLE INTEGRATION POINTS
C                    OR AT ELEMENT NODES (IN ONE PORTHOLE RECORD)
C
  320 IF (IELTYP.NE.ISOBEA) GOTO 370
      INR = IABS(NPAR(9))
      INS = IABS(NPAR(10))
      INT = IABS(NPAR(11))
      IF (NTABLE.NE.0) GOTO 340
      DO 330 I=1,INR
      DO 330 J=1,INS
      DO 330 K=1,INT
        NERPT = NERPT + 1
        IF (IFUNC.EQ.2) GOTO 330
        IDERPT(NERES+NERPT) = I*100 + J*10 + K
  330   CONTINUE
      GOTO 600
C
  340 IF (NTABLE.LT.0) GOTO 360
      NTAB = ITABLE(IPSEL,1) + 1
      DO 350 ITAB=2,NTAB
        NERPT = NERPT + 1
        IF (IFUNC.EQ.2) GOTO 350
        N = ITABLE(IPSEL,ITAB)
        IPT = 0
        DO 345 I=1,INR
        DO 345 J=1,INS
        DO 345 K=1,INT
          IPT = IPT + 1
          IF (IPT.EQ.N) GOTO 346
  345     CONTINUE
  346   CONTINUE
        IDERPT(NERES+NERPT) = I*100 + J*10 + K
  350   CONTINUE
      GOTO 600
C
  360 NERPT = NPAR(7)
      GOTO 550
C
C          PLATE - AT ALL INTEGRATION POINTS
C                  OR AT ITABLE POINTS, MAX 7, END = 0
C
  370 IF (IELTYP.NE.IPLATE) GOTO 390
      IF (NTABLE.GT.0 .AND. MODEL.LE.2) GOTO 380
      NINT = NPAR(10)
      NERPT = NINT
      IF (NINT.EQ.2) NERPT = 3
      IF (NINT.EQ.4) NERPT = 7
      GOTO 550
C
  380 NTAB = 7
      GOTO 500
C
C          SHELL - AT 8 INTEGRATION POINT CORNERS
C                  OR AT ITABLE POINTS, MAX 16, 0 = END
C
  390 IF (IELTYP.NE.ISHELL) GOTO 700
      IF (NTABLE.GT.0 .AND. MODEL.EQ.1) GOTO 400
      NINTR = NPAR(10)
      NINTS = NPAR(11)
      NINTT = NPAR(12)
      GOTO 260
C
  400 NTAB = 16
      GOTO 500
C
C          STRESS LOCATION TABLE IS USED, 0 = END
C
  500 DO 510 ITAB=1,NTAB
        N = ITABLE(IPSEL,ITAB)
        IF (N.EQ.0) GOTO 600
        NERPT = NERPT + 1
        IF (IFUNC.EQ.2) GOTO 510
        IDERPT(NERES+NERPT) = N
  510   CONTINUE
      GOTO 600
C
C          POINTS ARE NUMBERED 1 - NERPT
C
  550 IF (IFUNC.EQ.2) GOTO 600
      DO 560 I=1,NERPT
  560   IDERPT(NERES+I) = I
      GOTO 600
C
C          SAVE NUMBER OF RESULT POINTS FOR THIS ELEMENT
C
  600 IF (IFUNC.EQ.2) GOTO 650
      NERPTS(IEL) = NERPT
      IF (NERPT.EQ.0) GOTO 700
C
C          BIRTH AND DEATH OPTION CHECK
C
      IF (INDNL.EQ.0) GOTO 650
      IF (IDEATH.EQ.0) GOTO 650
      ETIMEL = ETIME(IEL)
      IF (IDEATH.EQ.2 .AND. TIME.GT.ETIMEL) GOTO 610
      IF (IDEATH.NE.2 .AND. TIME.LT.ETIMEL) GOTO 610
      GOTO 650
  610 DO 620 I=1,NERPT
  620   IDERPT(NERES+I) = - IDERPT(NERES+I)
C
  650 NERES = NERES + NERPT
C
  700 CONTINUE
C
C          FIND NERKI = NUMBER OF RESULTS KINDS AT EACH POINT
C
      NERKI = NERKIA(IELTYP)
      IF (IELTYP.EQ.IBEAM .AND. INDNL.GT.0 .AND.
     1  NTABLE.GE.0) NERKI = 3
C
C          UPDATE LOCALE, 0 = GLOBAL, 1 = LELEMENT COORD. SYSTEM
C
      LOCALE = 0
      IF (IELTYP.EQ.ITRUSS .OR. IELTYP.EQ.IBEAM) GOTO 710
      IF (IELTYP.EQ.ISOBEA .OR. IELTYP.EQ.IPLATE) GOTO 710
      IF (IELTYP.EQ.I2DIM .AND. NPAR(5).EQ.3) GOTO 710
      IF (IELTYP.EQ.ISHELL .AND. NPAR(5).EQ.1) GOTO 710
      GOTO 800
  710 LOCALE = 1
C
C          UPDATE COMMON AREA MXIDER,MXERES IF IFUNC = 2
C
  800 IF (IFUNC.NE.2) GOTO 900
        IF (MXIDER.LT.NERES) MXIDER = NERES
        I = NERKI * NERES
        IF (MXERES.LT.I) MXERES = I
C
  900 RETURN
      END
C***ADD:CDC***
CDECK VARES1
C***END:CDC***
      SUBROUTINE VARES1
C
      DIMENSION IA(1)
C
      COMMON /ERROR/ IERROR
      COMMON /PARAM/ REALV(100),NCMD,NLASTP,ITYPE(20),INTV(100),
     1               IANUMV(8,20),LGHSTR,INTEG,IREAL,IANUM,ISTRIN,IOMIT
      COMMON /CALLP/ NAMZON(8),NAMERC(8),
     1               IBITZ,IWHOLE,ICALL,IXPAR
      COMMON /DB/ IOPEN,NFDB,INDXST,IXTNOW,LGP,NWRITS,NREADS,
     1            LDBC,LDBCTR,LDBCTI,IPHCHK,INSTRI,INRUSE,INSTRU,
     2            MSUBF,MVIEW,MAXIS,MLINEN,MLINEE,MVAR,MRES,LSKEW,MIDSPL
      COMMON /DIM/ I01,I02,I03,I04,I05,I06,I07,I08,I09,I010,I011,
     1             I1,I2,I3,I4,I5,I6,I7,I8,I9,I10,I11,I12,I13,I14,I15,
     2             I16,I17,I18,I19,I20,
     3             N1,N2,N3,N4,N5,N6,N7,N8,N9,N10,N11,N12,N13,N14,N15,
     4             N16,N17,N18,N19,N20
      COMMON /CNTRL/ IBATCH,NBSU,LSTC,LSTF,LSTDB,ISURL,ITWO,LINPAG,LINE
      COMMON A(1)
      EQUIVALENCE (A(1),IA(1))
C
      DATA KRLIST,KRMAX,KREX,KRHIST,KRLINE/42,43,44,40,41/
C
      IBITZ = 0
      IF (NCMD.EQ.KRLIST.OR.NCMD.EQ.KRMAX.OR.NCMD.EQ.KREX)
     1          CALL ZGETNB
      IF (NCMD.EQ.KRHIST) CALL SUBF(11)
      IF (NCMD.EQ.KRLINE) CALL SUBF(9)
      IF (IERROR.NE.0) GOTO 900
C
C          BLANK COMMON LAYOUT FOR VARES2
C
C                                                VALUEV
      I2 = I1 + MVAR * ISURL
C                                                ITYPV
      I3 = I2 + MVAR
C                                                NDIRV
      I4 = I3 + MVAR
C                                                KINDV
      I5 = I4 + MVAR
C                                                IETYPV
      I6 = I5 + MVAR
C                                                IRPOL
      I7 = I6 + 100
C                                                IFORM
      I8 = I7 + MRES * 129
C                                                NAMEV
      I9 = I8 + MVAR * 8
C                                                NAMER
      I10 = I9 + MRES * 8
C                                                NEEDV
      I11 = I10 + MVAR
      CALL SIZE (I11)
      IF (IERROR.NE.0) GOTO 900
C
C          INITIATE VARES
C
      DO 10 I=1,MVAR
  10    A(N1+I-1) = 0.0
      DO 20 I=I2,I11
  20    IA(I) = 0
C
      I11 = I7
      CALL ALIGN (I11)
      N11 = I11 / ISURL
      CALL VARES2 (A(N1),IA(I2),IA(I3),IA(I4),IA(I5),
     1             IA(I6),IA(I7),IA(I8),IA(I9),IA(I10))
  900 RETURN
      END
C***ADD:CDC***
CDECK VARES2
C***END:CDC***
      SUBROUTINE VARES2 (VALUEV,ITYPV,NDIRV,KINDV,
     1                   IETYPV,IRPOL,IFORM,NAMEV,NAMER,NEEDV)
C
      DIMENSION IA(1),VALUEV(1),ITYPV(1),NDIRV(1),KINDV(1),IETYPV(1),
     1          IRPOL(1),IFORM(129,1),NAMEV(8,1),NAMER(8,1),NEEDV(1)
      DIMENSION KINDHD(7),KINDEL(15),ISTRIV(1)
C
      COMMON /CNTRL/ IBATCH,NBSU,LSTC,LSTF,LSTDB,ISURL,ITWO,LINPAG,LINE
      COMMON /FILES/ NFREAD,NFECHO,NFLOG,NFLIST,LUNODE,LUELEM
      COMMON /PARAM/ REALV(100),NCMD,NLASTP,ITYPE(20),INTV(100),
     1               IANUMV(8,20),LGHSTR,INTEG,IREAL,IANUM,ISTRIN,IOMIT
      COMMON /CALLP/ NAMZON(8),NAMERC(8),
     1               IBITZ,IWHOLE,ICALL,IXPAR
      COMMON /ERROR/ IERROR
      COMMON /DB/ IOPEN,NFDB,INDXST,IXTNOW,LGP,NWRITS,NREADS,
     1            LDBC,LDBCTR,LDBCTI,IPHCHK,INSTRI,INRUSE,INSTRU,
     2            MSUBF,MVIEW,MAXIS,MLINEN,MLINEE,MVAR,MRES,LSKEW,MIDSPL
      COMMON /DBC/ IHED(18),NDAREC,LDAREC,NRECS,NWORDS,NEXREC,NEXTIX,
     1             LIX,LIXT,NSTRI,NSTRUC,NEGIT,NEGAT,NFREQ,
     2             IXGP(50),MXSGP(50),
     3             FILL1
      COMMON /DIM/ I01,I02,I03,I04,I05,I06,I07,I08,I09,I010,I011,
     1             I1,I2,I3,I4,I5,I6,I7,I8,I9,I10,I11,I12,I13,I14,I15,
     2             I16,I17,I18,I19,I20,
     3             N1,N2,N3,N4,N5,N6,N7,N8,N9,N10,N11,N12,N13,N14,N15,
     4             N16,N17,N18,N19,N20
      COMMON /DBCTRL/ DT    ,TSTART,NUMNP ,NEQT  ,NSUBST,IDOF(6),
     1                NDOF  ,NEG   ,NMID  ,MODEX ,NSTE  ,NSTEN ,
     2                NSTEE ,NSKEWS,NMIDSS,IEIG  ,NSREFB,NEQITB,
     3                NPRIB ,NODSVB,LEMSVB,JDC   ,JAC   ,JVC   ,
     4                ISTAT ,JTC   ,NDISCE,ITP96 ,MXITAB,MXIDER,MXERES,
     5                NELPAR,MXNP  ,MXEG  ,MXEL  ,MXELNP,
     6                NDOFSA(6),NOUSE(4),FILL2
      COMMON /IGPNAM/ KDBC  ,KSUBGP,KDBCTR,KSTRI ,KRSDCO,KTMIDS,
     1                KXYZ  ,KIDRN ,KICONA,KNZONE,KNPAR ,KTHICK,
     2                KITABL,KNOD  ,KEDATA,KIEZON,KFRQ  ,KPHI  ,
     3                KTIMEN,KDISP ,KVEL  ,KACC  ,KTEMP ,KTIMEE,
     4                KERES ,KSUBF ,KVIEW ,KAXIS ,KNPOIN,KVARES,
     5                KNAMEZ,KEPOIN,KSXYZ ,KX34  ,KX35  ,KX36  ,
     6                KX37  ,KX38  ,KX39  ,KX40  ,KX41  ,KX42  ,
     7                KX43  ,KX44  ,KX45  ,KX46  ,KX47  ,KX48  ,
     8                KX49  ,KX50
      COMMON A(1)
      EQUIVALENCE (A(1),IA(1))
      EQUIVALENCE (IANUMV(1,2),ISTRIV(1))
C
      DATA KNVAR,KEVAR,KCONST,KRCOMB,KRHIST,KRLINE,KRLIST
     1     /  36,    37,    38,    39,    40,    41,    42/
      DATA KRMAX,KREX/43,44/
      DATA INODE,IELEM,ICONST/1,2,3/
      DATA ICALLR,KINDHD(4)/2,4H OR /
      DATA ITRUSS,I2DIM,I3DIM,IBEAM,ISOBEA,IPLATE,ISHELL/1,2,3,4,5,6,7/
      DATA I2DIMF,I3DIMF/11,12/
      DATA KINDEL/3,8,12,12,6,6,12,0,0,0,5,7,0,0,0/
C
C           READ VARES
C
      IF (IXGP(KVARES).NE.0) CALL DBREAD (VALUEV,KVARES,1,0)
        IF (IERROR.NE.0) GOTO 900
C
CCCCCCCCCCCCCCC   NVAR, EVAR, CONST
C
      IF (NCMD.GT.KCONST) GOTO 200
C
C          FIND FREE ARRAY ENTRY OR ENTRY WITH SAME NAME
C
      IF (ITYPE(1).EQ.IOMIT) GOTO 850
      IFREE = 0
      IVAR = MVAR
  30    IF (ITYPV(IVAR).EQ.0) IFREE = IVAR
        DO 40 I=1,8
          IF (IANUMV(I,1).NE.NAMEV(I,IVAR)) GOTO 50
  40      CONTINUE
        GOTO 60
  50    IVAR = IVAR - 1
      IF (IVAR.GT.1) GOTO 30
      IVAR = IFREE
      IF (IFREE.GT.0) GOTO 60
        I = MVAR - 1
        WRITE (NFLOG,2000) I
        GOTO 800
C
C          CONSTANT
C
  60  IF (NCMD.NE.KCONST) GOTO 80
C
C          IF PAR 2 IS OMITTED, DELETE VARIABLE/CONSTANT ENTRY
C
      IF (ITYPE(2).NE.IOMIT) GOTO 70
        NAMEV(1,IVAR) = 0
        ITYPV(IVAR) = 0
        GOTO 140
  70    ITYPV(IVAR) = ICONST
        VALUEV(IVAR) = REALV(2)
      GOTO 110
C
C          NVARIABLE
C
  80  IF (NCMD.NE.KNVAR) GOTO 100
        ITYPV(IVAR) = INODE
        NDIR = INTV(2)
        IF (ITYPE(2).EQ.IOMIT) NDIR = 1
      IF (NDIR.LT.1.OR.NDIR.GT.6) GOTO 850
        NDIRV(IVAR) = NDIR
        KIND = INTV(3)
        IF (ITYPE(3).EQ.IOMIT) KIND = 1
        IF (KIND.LT.0.OR.KIND.GT.4) GOTO 850
        IF (KIND.EQ.0 .AND. NDIR.GT.3) GOTO 850
        IF (KIND.EQ.0) KIND = 5
        KINDV(IVAR) = KIND
        GOTO 110
C
C          EVARIABLE
C
  100 ITYPV(IVAR) = IELEM
      IETYP = INTV(2)
      IF (IETYP.LT.1 .OR. IETYP.GT.15) GOTO 850
      IETYPV(IVAR) = IETYP
      KIND = INTV(3)
      IF (ITYPE(3).EQ.IOMIT) KIND = 1
      IF (KIND.LT.1 .OR. KIND.GT.KINDEL(IETYP)) GOTO 850
      KINDV(IVAR) = KIND
C
C          SAVE NAME AND WRITE TO DATABASE
  110 DO 120 I=1,8
  120   NAMEV(I,IVAR) = IANUMV(I,1)
  140 LREAL = MVAR
      LINT = I10 - I2
      CALL DBWRIT (IA(I1),LREAL,LINT,KVARES,1,0)
      GOTO 900
C
CCCCCCCCCCCCCC  RCOMB   CCCCCCCCCCCCCCCC
C
  200 IF (NCMD.NE.KRCOMB) GOTO 300
C
C          FIND FREE ARRAY ENTRY OR ENTRY WITH SAME NAME
C
      IF (ITYPE(1).EQ.IOMIT) GOTO 850
      IFREE = 0
      IRES = MRES
  210   IF (NAMER(1,IRES).EQ.0) IFREE = IRES
        DO 220 I=1,8
          IF (IANUMV(I,1).NE.NAMER(I,IRES)) GOTO 230
  220     CONTINUE
        GOTO 240
  230 IRES = IRES - 1
      IF (IRES.GT.0) GOTO 210
C
      IRES = IFREE
      IF (IFREE.GT.0) GOTO 240
        WRITE (NFLOG,2020) MRES
        GOTO 800
C
C          IF PAR 2 IS OMITTED, DELETE RESULTANT ENTRY
C
  240 IF (ITYPE(2).NE.IOMIT) GOTO 250
        NAMER(1,IRES) = 0
        GOTO 295
C
C          PARAM 2: FORMULASTRING
C
  250 IF (LGHSTR.EQ.0) GOTO 850
      IFORM(1,IRES) = LGHSTR
      DO 260 I=1,LGHSTR
  260   IFORM(I+1,IRES) = ISTRIV(I)
C
C          CHECK SYNTAX AND CONVERT TO REVERSE POLISH
C
      CALL FORMUL (NAMEV,ITYPV,NEEDV,IFORM(1,IRES),IRPOL,ITYCHK)
      IF (IERROR.NE.0) GOTO 900
C
C          EXECUTE FORMULA IF IT CONTAINS CONSTANTS ONLY
C
  265 IF (ITYCHK.NE.ICONST) GOTO 280
      CALL FORMEX (VALUEV,IRPOL)
      IF (IERROR.NE.0) GOTO 280
        WRITE (NFLOG,2030) VALUEV(1)
C
C          SAVE NAME AND UPDATE VARES IN DATABASE
C
  280 DO 290 I=1,8
  290   NAMER(I,IRES) = IANUMV(I,1)
  295 GOTO 140
C
CCCCCCCCCC  EXECUTING R-COMMAND - FIND RESULTANTSTRING
C
  300 DO 320 IRES=1,MRES
        DO 310 I=1,8
          ICODE = NAMER(I,IRES)
          IF (IANUMV(I,2).NE.ICODE) GOTO 320
          CALL APCHAR(ICODE)
          NAMERC(I) = ICODE
  310     CONTINUE
        GOTO 325
  320   CONTINUE
      WRITE (NFLOG,2050)
      GOTO 800
C
C          LIST FORMULASTRING
C
  325 WRITE (NFLIST,2070) NAMERC
      IEND = IFORM(1,IRES) + 1
      DO 330 I=1,IEND
        IFORM(I,1) = IFORM(I,IRES)
        IF (I.EQ.1) GOTO 330
        IFORM(I,2) = IFORM(I,1)
        CALL APCHAR (IFORM(I,2))
  330   CONTINUE
      WRITE (NFLIST,2100) (IFORM(I,2),I=2,IEND)
      WRITE (NFLIST,2110)
C
C          CHECK SYNTAX AND CONVERT TO REVERSE POLISH
C
      CALL FORMUL (NAMEV,ITYPV,NEEDV,IFORM,IRPOL,ITYCHK)
        IF (IERROR.NE.0) GOTO 900
C
      IF (ITYCHK.EQ.INODE .OR. ITYCHK.EQ.IELEM) GOTO 335
      WRITE (NFLOG,2060)
      GOTO 800
C
C          LIST NEEDED VARIABLES AND CONSTANTS
C
  335 DO 350 I=1,8
        DO 350 J=1,MVAR
  350     CALL APCHAR (NAMEV(I,J))
      IETYP = 0
      DO 380 IVAR=1,MVAR
        IF (NEEDV(IVAR).EQ.0) GOTO 370
        ITYVAR = ITYPV(IVAR)
        KIND  = KINDV(IVAR)
        IF (ITYVAR.EQ.ICONST) GOTO 360
          J = 3
          IF (ITYVAR.EQ.IELEM) GOTO 355
          NDIR = NDIRV(IVAR)
          CALL KINDN (NDIR,KIND,KINDHD)
  353     WRITE (NFLIST,2080) (NAMEV(I,IVAR),I=1,8),(KINDHD(I),I=1,J)
          GOTO 380
C
  355 IF (IETYP.EQ.0) IETYP = IETYPV(IVAR)
      IF (IETYP.EQ.IETYPV(IVAR)) GOTO 357
        WRITE (NFLOG,2120)
        GOTO 800
  357 INDNL = 1
      NTABLE = 0
      CALL KINDE (IETYP,INDNL,NTABLE,KIND,KINDHD)
      IF (IETYP.NE.IBEAM .AND. IETYP.NE.ISOBEA) GOTO 353
      IF (IETYP.EQ.IBEAM .AND. KIND.GT.3) GOTO 353
      INDNL = 0
      NTABLE = -1
      CALL KINDE (IETYP,INDNL,NTABLE,KIND,KINDHD(5))
      J = 7
      GOTO 353
C
  360   WRITE (NFLIST,2090) (NAMEV(I,IVAR),I=1,8),VALUEV(IVAR)
  370   KINDV(IVAR) = 0
  380   CONTINUE
C
CCCCCCCCCCCCCCCCCCC   NODAL RLIST, RMAX, REXCEED   CCCCCCCCCCCCCC
C
  400 IXPAR = 3
      ICALL = ICALLR
      IF (NCMD.LT.KRLIST) GOTO 500
      IF (ITYCHK.EQ.IELEM) GOTO 420
C
C          BLANK COMMON LAYOUT FOR NLIST2
C
C                                                TIMEN
      I12 = I11 + NSTEN * ISURL
C                                                NSTEPN
      I13 = I12 + NSTEN
      CALL ALIGN (I13)
C                                                NZONE
      I14 = I13 + MXNP
C                                                RSDCOS
      I15 = I14 + NSKEWS * 9 * ISURL
C                                                IDRN
      I16 = I15
      IF (NSKEWS.GT.0 .AND. LSKEW.EQ.0)
     1  I16 = I15 + (NDOF + 2) * MXNP
      CALL SIZE (I16)
      IF (IERROR.NE.0) GOTO 900
C
      NVAR = 1
        CALL NLIST2 (NVAR,
     1     VALUEV,NDIRV,KINDV,A(N11),IA(I12),IA(I13),IRPOL,
     2     IA(I06),IA(I08),IA(I14),IA(I15))
      GOTO 900
C
CCCCCCCCC    ELEMENT RLIST, RMAX, REXCEED    CCCCCCCCCCCCCCCC
C
C          BLANK COMMON FOR ELIST2
C                                                TIMEE
  420 I12 = I11 + NSTEE * ISURL
C                                                NSTEPE
      I13 = I12 + NSTEE
      CALL ALIGN (I13)
C                                                NPAR
      I14 = I13 + NELPAR * MXEG
C                                                EDATA
      I15 = I14 + (ISURL + 2) * MXEL
C                                                ITABLE
      I16 = I15 + MXITAB
C                                                IEZONE
      I17 = I16 + MXEL
      IF (IBITZ.EQ.IWHOLE) I17 = I16
C                                                ERES
      I18 = I17 + MXERES * ISURL
C                                                IXMAXA
      I19 = I18 + NEGAT * 9
C                                                NERPTS
      I20 = I19 + MXEL
C                                                IDERPT
      IXEND = I20 + MXIDER
      CALL SIZE (IXEND)
        IF (IERROR.NE.0) GOTO 900
C
      CALL ELIST2 (VALUEV,IETYP,KINDV,IRPOL,
     1  IA(I11),IA(I12),IA(I13),NELPAR,IA(I14),IA(I15),IA(I16),
     2  IA(I17),IA(I18),IA(I19),IA(I20),IXEND,IA(I06),IA(I07))
      GOTO 900
C
C
CCCCCCCC    NODAL RHIST   CCCCCCCCCCCCCCCCCC
C
  500 IF (NCMD.NE.KRHIST) GOTO 550
      IF (ITYCHK.EQ.IELEM) GOTO 520
C
C          BLANK COMMON FOR NHIST2
C
C                                                TIMEN
      N12 = N11 + NSTEN
C                                                TIMEPL (FOR PLOT)
      N13 = N12 + NSTEN + 2
C                                                VARPL (FOR PLOT)
      N14 = N13 + NSTEN + 2
C                                                RSDCOS
      I15 = (N14 + NSKEWS * 9) * ISURL
C                                                IDRN
      I16 = I15
      IF (NSKEWS.GT.0)
     1  I16 = I15 + (NDOF + 2) * MXNP
C                                                ISTRP
      I17 = I16 + MLINEN * 3
C                                                NODEP
      I18 = I17 + MLINEN * 99
C                                                NAMEP
      I19 = I18 + MLINEN * 9
      CALL SIZE(I19)
        IF (IERROR.NE.0) GOTO 900
C
      CALL NHIST2 (IDUM,NDIRV,KINDV,VALUEV,
     1             A(N11),A(N12),A(N13),IRPOL,A(N14),IA(I15),
     2             IA(I16),IA(I17),IA(I18))
      GOTO 900
C
C
CCCCCCCCCCC       ELEMENT RHIST    CCCCCCCCC
C
C          BLANK COMMON LAYOUT FOR EHIST2
C                                                TIMEE
  520 N12 = N11 + NSTEE
C                                                TIMEPL (FOR PLOT)
      N13 = N12 + NSTEE + 2
C                                                VARPL (FOR PLOT)
      N14 = N13 + NSTEE + 2
C                                                ERES
      I15 = (N14 + MXERES) * ISURL
C                                                EDATA
      I16 = I15 + (ISURL + 2) * MXEL
C                                                ITABLE
      I17 = I16 + MXITAB
C                                                NPAR
      I18 = I17 + NELPAR * MXEG
C                                                NERPTS
      I19 = I18 + MXEL
C                                                IDERPT
      I20 = I19 + MXIDER
      CALL ALIGN (I20)
C                                                LINEID
      I21 = I20 + MLINEE * 4
C                                                NELP
      I22 = I21 + MLINEE * 98
C                                                NAMEP
      I23 = I22 + MLINEE * 8
C
      CALL SIZE (I23)
        IF (IERROR.NE.0) GOTO 900
C
      CALL EHIST2 (KINDV,VALUEV,A(N11),A(N12),A(N13),
     1     A(N14),IA(I15),IA(I16),NELPAR,IA(I17),IA(I18),IA(I19),
     2     IA(I20),IA(I21),IA(I22),IA(I06),IA(I07),
     3     IRPOL,IETYP)
      GOTO 900
C
C
CCCCCC   NODAL RLINE    CCCCCCCCCCCCC
C
C          BLANK COMMON LAYOUT FOR NLINE2
C
  550 IF (ITYCHK.EQ.IELEM) GOTO 570
C                                                TIMEN, NSTEPN
      N12 = N11 + NSTEN + NSTEN / ISURL + 1
C                                                XPLOT
      N13 = N12 + 101
C                                                YPLOT
      N14 = N13 + 101
C                                                XYZ
      N15 = N14 + MXNP * 3
C                                                RSDCOS
      I16 = (N15 + NSKEWS * 9) * ISURL
C                                                IDRN
      I17 = I16
      IF (NSKEWS.GT.0 .AND. LSKEW.EQ.0)
     1  I17 = I16 + (NDOF + 2) * MXNP
C                                                ISTRP
      I18 = I17 + MLINEN * 3
C                                                NODEP
      I19 = I18 + MLINEN * 99
C                                                NAMEP
      I20 = I19 + MLINEN * 8
      CALL SIZE (I20)
        IF (IERROR.NE.0) GOTO 900
C
      CALL NLINE2 (NDIRV,KINDV,VALUEV,IRPOL,
     1     A(N11),A(N12),A(N13),A(N14),A(N15),IA(I16),IA(I17),
     2     IA(I18),IA(I19))
      GOTO 900
C
C
CCCCCC     ELEMENT RLINE    CCCCCCCCCCCCC
C
C          BLANK COMMON LAYOUT FOR ELINE2
C                                                TIMEE, NSTEPE
  570 N12 = N11 + NSTEE + NSTEE / ISURL + 1
C                                                XPLOT
      N13 = N12 + 51
C                                                YPLOT
      N14 = N13 + 51
C                                                ERES
      I15 = (N14 + MXERES) * ISURL
C                                                EDATA
      I16 = I15 + (ISURL + 2) * MXEL
C                                                ITABLE
      I17 = I16 + MXITAB
C                                                NPAR
      I18 = I17 + NELPAR * MXEG
C                                                NERPTS
      I19 = I18 + MXEL
C                                                IDERPT
      I20 = I19 + MXIDER
      CALL ALIGN (I20)
C                                                SXYZ
      I21 = I20 + 0
C                                                LINEID
      I22 = I21 + MLINEE * 4
C                                                NELP
      I23 = I22 + MLINEE * 98
C                                                NAMEP
      I24 = I23 + MLINEE * 8
      CALL SIZE (I24)
        IF (IERROR.NE.0) GOTO 900
C
      CALL ELINE2 (IA(I06),IA(I07),IETYP,KINDV,VALUEV,
     -     IRPOL,
     1     A(N1),A(N12),A(N13),A(N14),IA(I15),IA(I16),NELPAR,IA(I17),
     2     IA(I18),IA(I19),IA(I20),IA(I21),IA(I22),IA(I23))
      GOTO 900
C
C
  800 IERROR = 1
      GOTO 900
  850 IERROR = 2
  900 RETURN
C
 2000 FORMAT (44H ***ERROR: TOO MANY VARIABLES/CONSTANTS, MAX,I3)
 2020 FORMAT (35H ***ERROR: TOO MANY RESULTANTS, MAX,I3)
 2030 FORMAT (13H    RESULT = ,G12.6/)
 2050 FORMAT (36H ***ERROR: RESULTANTNAME NOT DEFINED)
 2060 FORMAT(27H ***ERROR: CHECK EXPRESSION)
 2070 FORMAT(///4X,12HRESULTANT = ,8A1,24H  ARITHMETIC EXPRESSION:)
 2080 FORMAT (4X,8A1,3H = ,7A4)
 2090 FORMAT (4X,8A1,3H = ,G12.6)
 2100 FORMAT (/4X,128A1)
 2120 FORMAT(50H ***ERROR: EVARIABLES OF DIFFERENT TYPE USED IN
     1  10HEXPRESSION)
 2110 FORMAT (1H )
      END
C***ADD:CDC***
CDECK FORMUL
C***END:CDC***
      SUBROUTINE FORMUL (NAMEV,ITYPV,NEEDV,IFORM,IRPOL,ITYCHK)
C
C          FORMULASTRING CHECK AND CONVERSION TO REVERSE POLISH
C
      COMMON /FILES/ NFREAD,NFECHO,NFLOG,NFLIST,LUNODE,LUELEM
      COMMON /ERROR/ IERROR
      COMMON /DB/ IOPEN,NFDB,INDXST,IXTNOW,LGP,NWRITS,NREADS,
     1            LDBC,LDBCTR,LDBCTI,IPHCHK,INSTRI,INRUSE,INSTRU,
     2            MSUBF,MVIEW,MAXIS,MLINEN,MLINEE,MVAR,MRES,LSKEW,MIDSPL
      COMMON /SICODE/ I000,I111,I222,I333,I444,I555,I666,I777,I888,I999,
     1              IBLANK,IAAA,IBBB,ICCC,IDDD,IEEE,IFFF,IGGG,IHHH,IIII,
     2                IJJJ,IKKK,ILLL,IMMM,INNN,IOOO,IPPP,IQQQ,IRRR,ISSS,
     3                ITTT,IUUU,IVVV,IWWW,IXXX,IYYY,IZZZ,IPOINT,ICOMMA,
     4              IPLUS,IMINUS,IEQUAL,ILPAR,IRPAR,ISLASH,IASTER,IAPOST
C
      DIMENSION NAMEV(1),ITYPV(1),NEEDV(1),IFORM(1),IRPOL(100)
      DIMENSION ICHARS(8),KLPRTS(8),NAMEIN(9),LFUNCS(133)
C
      DATA IXSEND,ICONST/100,3/
      DATA KVARIA,KLEFTP,KRIGHP,KCOMMA,KCOMMI,KEND,KFUNC/1,2,3,3,4,5,9/
C
C                   +  -  )  *  /  *  (  ,
      DATA ICHARS /39,40,43,45,44,45,42,38/
      DATA KLPRTS / 6, 6, 3, 7, 7, 8, 2, 4/
C
C          ARRAY LFUNCS CONTAINS FUNCTION NAMES AND -(NR OPERANDS-1)
C
C     ABS(X)              AINT(X)             ANINT(X)
C     MOD(X,Y)            MAX(X,Y,...)        MIN(X,Y,...)
C     SIGN(X,Y)           DIM(X,Y)            EXP(X)
C     LOG(X)              LOG10(X)            SIN(X)
C     COS(X)              TANH(X)             SQRT(X)
C     ATAN(X)             ATAN2(X,Y)          SINH(X)
C     COSH(X)             ASIN(X)             ACOS(X)
C     TAN(X)
      DATA LFUNCS/
     111,12,29,10,10,0,   11,19,24,30,10,0,   11,24,19,24,30,0,
     223,25,14,10,10,-1,  23,11,34,10,10,-19, 23,19,24,10,10,-19,
     329,19,17,24,10,-1,  14,19,23,10,10,-1,  15,34,26,10,10,0,
     422,25,17,10,10,0,   22,25,17,01,00,0,   29,19,24,10,10,0,
     513,25,29,10,10,0,   30,11,24,18,10,0,   29,27,28,30,10,0,
     611,30,11,24,10,0,   11,30,11,24,02,-1,  29,19,24,18,10,0,
     713,25,29,18,10,0,   11,29,19,24,10,0,   11,13,25,29,10,0,
     830,11,24,10,10,0,
     - 999/
C
      IXRPOL = 1
      IXSTAC = IXSEND
      IRPOL(IXSEND) = 0
      INSTAT = 1
      DO 10 I=1,MVAR
  10    NEEDV(I) = 0
C
CCCCCC     LEXICAL ANALYZER      CCCCCCCCCCCCC
C
      IFORML = IFORM(1) + 1
      IXFORM = 1
      NAMERR = 0
      ITYCHK = ICONST
C
C          FIND NEXT INPUT TOKEN
C
  100 IXFORM = IXFORM + 1
      IF (IXFORM.GT.IFORML) GOTO 190
      INCHAR = IFORM(IXFORM)
      IF (INCHAR.EQ.IBLANK) GOTO 100
      IF (INCHAR.GT.10.AND.INCHAR.LT.37) GOTO 130
C
C          TOKEN STARTS WITH NON-ALPHABETIC CHAR
C
      DO 110 ITOKEN=1,8
        IF (INCHAR.EQ.ICHARS(ITOKEN)) GOTO 120
  110 CONTINUE
      GOTO 900
C
C          ARITHMETIC OPERAND, PARENTHETIS OR COMMA FOUND
C
  120 IF (INCHAR.EQ.IASTER.AND.IFORM(IXFORM+1).EQ.IASTER) GOTO 124
  122 KLPRTY = KLPRTS(ITOKEN)
      NOPERA = -1
      GOTO 200
C
C          ** EXPONENTIATION FOUND
C
  124 IXFORM = IXFORM + 1
      ITOKEN = 6
      GOTO 122
C
C          ALPHABETIC FOUND, MUST BE VARIABLE OR FUNCTION NAME
C
  130 DO 131 I=1,9
  131   NAMEIN(I) = IBLANK
      DO 135 I=1,8
        NAMEIN(I) = INCHAR
        IXFORM = IXFORM + 1
        IF (IXFORM.GT.IFORML) GOTO 140
        INCHAR = IFORM(IXFORM)
        IF (INCHAR.GE.37.OR.INCHAR.EQ.IBLANK) GOTO 140
  135 CONTINUE
  140 IXFORM = IXFORM - 1
C
C          TEST IF FUNCTION NAME
C
      ITOKEN = 0
  141 ITOKEN = ITOKEN + 1
      I2 = ITOKEN * 6 - 5
      IF (LFUNCS(I2).EQ.999) GOTO 150
      DO 145 J=1,5
        IF (NAMEIN(J).NE.LFUNCS(I2)) GOTO 141
        I2 = I2 + 1
  145 CONTINUE
      IF (NAMEIN(6).NE.IBLANK) GOTO 141
      KLPRTY = KFUNC
      NOPERA = LFUNCS(ITOKEN*6)
      ITOKEN = ITOKEN + 6
      GOTO 200
C
C          TEST IF VARIBLE OR CONSTANT NAME
C
  150 KLPRTY = KVARIA
      NOPERA = 1
      DO 170 ITOKEN=2,MVAR
        I2 = ITOKEN * 8 - 8
        DO 160 J=1,8
          I2 = I2 + 1
          IF (NAMEIN(J).NE.NAMEV(I2)) GOTO 170
  160   CONTINUE
C
C          CHECK THAT NODAL- AND ELEMENT VARIABLES ARE NOT MIXED
C
        ITYNEW = ITYPV(ITOKEN)
        NEEDV(ITOKEN) = 1
        IF (ITYNEW.EQ.ICONST) GOTO 200
        IF (ITYCHK.EQ.ICONST) ITYCHK = ITYNEW
        IF (ITYNEW.NE.ITYCHK) GOTO 901
        GOTO 200
  170 CONTINUE
      NAMERR = 1
      GOTO 200
C
C          END OF FORMULA STRING
C
  190 KLPRTY = KEND
C
CCCCCC     PARSER - GRAMMAR CHECK     CCCCCCCCCCCCCCCC
C
  200 CONTINUE
      GOTO (210,220,230,240,270,260,270,270,290), KLPRTY
C
C          VARIABLE OR CONSTANT
C
  210 IF (INSTAT.GT.2) GOTO 900
      INSTAT = 4
      IXRPOL = IXRPOL + 2
      IF (IXRPOL.GE.IXSTAC) GOTO 903
      IRPOL(IXRPOL-1) = ITOKEN
      IRPOL(IXRPOL)   = NOPERA
      GOTO 100
C
C          (
C
  220 IF (INSTAT.EQ.4) GOTO 900
      INSTAT = 1
      GOTO 300
C
C          )
C
  230 IF (INSTAT.NE.4) GOTO 900
      GOTO 400
C
C          ,
C
  240 IF (INSTAT.NE.4) GOTO 900
      INSTAT = 1
      GOTO 400
C
C          + -
C
  260 GOTO (261,900,900,270), INSTAT
  261 INSTAT = 2
      IF (ITOKEN.NE.2) GOTO 100
      ITOKEN = 3
      NOPERA = 0
      GOTO 400
C
C          * / ** END
C
  270 IF (INSTAT.NE.4) GOTO 900
      INSTAT = 2
      GOTO 400
C
C          FUNCTION
C
  290 IF (INSTAT.GT.2) GOTO 900
      INSTAT = 3
      GOTO 300
C
C          STACK NEW OPERATOR, ( OR ,
C
  300 IXSTAC = IXSTAC - 3
      IF (IXRPOL.GE.IXSTAC) GOTO 903
      IF (KLPRTY.EQ.KCOMMI) KLPRTY = KCOMMA
      IRPOL(IXSTAC  ) = KLPRTY
      IRPOL(IXSTAC+1) = ITOKEN
      IRPOL(IXSTAC+2) = NOPERA
      GOTO 100
C
C          COMPARE KLPRTY AND STACK, UNSTACK IF NECESSARY
C
  400 NCOMMA = 0
  402 KLPRST = IRPOL(IXSTAC)
      IF (KLPRST.LT.KLPRTY) GOTO 420
      IF (KLPRST.EQ.KCOMMA) GOTO 410
      IXRPOL = IXRPOL + 2
      IRPOL(IXRPOL-1) = IRPOL(IXSTAC+1)
      IRPOL(IXRPOL  ) = IRPOL(IXSTAC+2)
  408 IXSTAC = IXSTAC + 3
      GOTO 402
C
C          COMMA IN STACK
C
  410 NCOMMA = NCOMMA - 1
      GOTO 408
C
C          UNSTACK LEFT PARENTHETIS
C
  420 IF (KLPRTY.NE.KRIGHP) GOTO 430
      IF (IRPOL(IXSTAC).NE.KLEFTP) GOTO 900
      IXSTAC = IXSTAC + 3
C
C          CHECK NUMBER OF JUST UNSTACKED COMMAS, ONLY VALID
C          BETWEEN FUNCTION ARGUMENTS
C
      IF (IRPOL(IXSTAC).NE.KFUNC) GOTO 430
      NOPERA = IRPOL (IXSTAC+2)
      IF (NOPERA.EQ.NCOMMA) GOTO 100
      IF (NOPERA.NE.-19.OR.NCOMMA.GT.-1) GOTO 900
      IRPOL(IXSTAC+2) = NCOMMA
      GOTO 100
  430 IF (NCOMMA.NE.0) GOTO 900
      IF (KLPRTY.EQ.KRIGHP) GOTO 100
      IF (KLPRTY.NE.KEND) GOTO 300
C
C          END
C
  800 IF (IXSTAC.NE.IXSEND.OR.IXRPOL.EQ.1) GOTO 900
      IF (NAMERR.EQ.1) GOTO 902
      IRPOL(1) = IXRPOL
  899 CONTINUE
      RETURN
C
C          ERROR MESSAGES
C
  900 WRITE (NFLOG,2900) IXFORM
      IERROR = 1
  980 ITYCHK = 0
      GOTO 899
  901 WRITE (NFLOG,2901)
      GOTO 900
  902 WRITE (NFLOG,2902)
      GOTO 980
  903 WRITE (NFLOG,2903)
      GOTO 900
 2900 FORMAT(46H ***ERROR: IN EXPRESSION AT OR BEFORE LOCATION,I4/)
 2901 FORMAT (45H ***ERROR: MIX OF NODAL AND ELEMENT VARIABLES)
 2902 FORMAT (50H *** PLEASE DEFINE MISSING VARIABLE(S)/CONSTANT(S)/)
 2903 FORMAT(29H ***ERROR: TOO BIG EXPRESSION)
      END
C***ADD:CDC***
CDECK FORMEX
C***END:CDC***
      SUBROUTINE FORMEX (VALUEV,IRPOL)
C
C          FORMULA EXPRESSION EXECUTION FROM REVERSE POLISH
C
      DIMENSION VALUEV(1),IRPOL(1),VSTACK(25)
      COMMON /ERROR/ IERROR
      COMMON /FILES/ NFREAD,NFECHO,NFLOG,NFLIST,LUNODE,LUELEM
C
      IXSTAC = 0
      IXRPOL = 0
      IRPOLL = IRPOL(1)
      GOTO 102
C
C          GET OPERAND VALUE
C
  101 VTOP = VALUEV(ITOKEN)
      IF (IXSTAC.GT.25) GOTO 99
C
C          STACK OPERAND OR COMPUTED VALUE IN TOP OF STACK
C
  100 VSTACK(IXSTAC) = VTOP
C
C          NEXT REVERSE POLISH ENTRY
C
  102 IXRPOL = IXRPOL + 2
C
C          CHECK IF END OF REVERSE POLISH STRING
C
      IF (IXRPOL.GT.IRPOLL) GOTO 800
C
C          GET TOKEN AND COMPUTE NEW INDEX TO TOP OF STACK
C
      ITOKEN = IRPOL(IXRPOL)
      NOPERA = IRPOL(IXRPOL+1)
      IXSTAC = IXSTAC + NOPERA
C
C          OPERAND
C
      IF (NOPERA.EQ.1) GOTO 101
C
C          OPERATOR
C
      VFIRST = VSTACK(IXSTAC)
      GOTO ( 1, 2, 3, 4, 5, 6, 7, 8, 9,10,
     1      11,12,13,14,15,16,17,18,19,20,
     2      21,22,23,24,25,26,27,28)
     9      , ITOKEN
C
C          VTOP   IS OPERATORS LAST OR ONLY OPERAND
C          VFIRST IS OPERATORS FIRST OPERAND
C
  1   VTOP = VFIRST + VTOP
      GOTO 100
C
  2   VTOP = VFIRST - VTOP
      GOTO 100
C
  3   VTOP = - VTOP
      GOTO 100
C
  4   VTOP = VFIRST * VTOP
      GOTO 100
C
C          DIVISION BY ZERO IS NOT ALLOWED
C
  5   IF (VTOP.EQ.0.0) GOTO 91
      VTOP = VFIRST / VTOP
      GOTO 100
C
C          QUANTITY RAISED MUST BE GREATER THAN ZERO
C
  6   IF (VFIRST.LE.0.0) GOTO 92
      VTOP = VFIRST ** VTOP
      GOTO 100
C
  7   VTOP = ABS(VTOP)
      GOTO 100
C
  8   VTOP = AINT(VTOP)
      GOTO 100
C
  9   VTOP = VTOP + 0.5
      IF (VTOP.GE.0.5) GOTO 8
      VTOP = VTOP - 1.0
      GOTO 8
C
C          DIVISION BY ZERO IS NOT ALLOWED
C
  10  IF (VTOP.EQ.0.0) GOTO 91
      VTOP = AMOD(VFIRST,VTOP)
      GOTO 100
C
  11  IX = IXSTAC
  211 VTOP = AMAX1(VSTACK(IX),VTOP)
      IX = IX + 1
      NOPERA = NOPERA + 1
      IF (NOPERA.LT.0) GOTO 211
      GOTO 100
C
  12  IX = IXSTAC
  212 VTOP = AMIN1(VSTACK(IX),VTOP)
      IX = IX + 1
      NOPERA = NOPERA + 1
      IF (NOPERA.LT.0) GOTO 212
      GOTO 100
C
  13  VTOP = SIGN(VFIRST,VTOP)
      GOTO 100
C
  14  VTOP = DIM(VFIRST,VTOP)
      GOTO 100
C
  15  VTOP = EXP(VTOP)
      GOTO 100
C
C          NATURAL LOGARITHM ARGUMENT MUST BE GREATER THAN ZERO
C
  16  IF (VTOP.LE.0.0) GOTO 93
      VTOP = ALOG(VTOP)
      GOTO 100
C
C          COMMON LOGARITHM ARGUMENT MUST BE GREATER THAN ZERO
C
  17  IF (VTOP.LE.0.0) GOTO 93
      VTOP = ALOG10(VTOP)
      GOTO 100
C
  18  VTOP = SIN(VTOP)
      GOTO 100
C
  19  VTOP = COS(VTOP)
      GOTO 100
C
  20  VTOP = TANH(VTOP)
      GOTO 100
C
C          SQUARE ROOT ARGUMENT MUST BE GREATER THAN OR EQUAL TO ZERO
C
  21  IF (VTOP.LT.0.0) GOTO 94
      VTOP = SQRT(VTOP)
      GOTO 100
C
  22  VTOP = ATAN(VTOP)
      GOTO 100
C
  23  VTOP = ATAN2(VFIRST,VTOP)
      GOTO 100
C
  24  VTOP = SINH(VTOP)
      GOTO 100
C
  25  VTOP = COSH(VTOP)
      GOTO 100
C
C          ARCSINE ARGUMENT ABSOLUTE VALUE MUST BE .LE. 1.0
C
  26  IF (ABS(VTOP).GT.1.0) GOTO 95
      VTOP = ASIN(VTOP)
      GOTO 100
C
C          ARCCOSINE ARGUMENT ABSOLUTE VALUE MUST BE .LE. 1.0
C
  27  IF (ABS(VTOP).GT.1.0) GOTO 95
      VTOP = ACOS(VTOP)
      GOTO 100
C
  28  VTOP = TAN(VTOP)
      GOTO 100
C
  91  WRITE (NFLOG,2091)
      GOTO 99
  92  WRITE (NFLOG,2092)
      GOTO 99
  93  WRITE (NFLOG,2093)
      GOTO 99
  94  WRITE (NFLOG,2094)
      GOTO 99
  95  WRITE (NFLOG,2095)
  99  IERROR = 1
      WRITE (NFLOG,2000)
      VSTACK(1) = 0.0
C
  800 VALUEV(1) = VSTACK(1)
      RETURN
 2000 FORMAT(52H ***ERROR: ARITHMETIC EXPRESSION RESULT IS UNDEFINED)
 2091 FORMAT(11X,16HDIVISION BY ZERO)
 2092 FORMAT(11X,32HQUANTITY RAISED NOT GREATER ZERO)
 2093 FORMAT(11X,30HLOGARITHM ARG NOT GREATER ZERO)
 2094 FORMAT(11X,25HSQUARE ROOT ARG LESS ZERO)
 2095 FORMAT(11X,21HARC ARG GREATER +-1.0)
      END
C*NEW FILE
C***END:IBM***
      SUBROUTINE COMND
C
      DIMENSION ICMDPA(20,50),KEYTYP(321),
     1          KEY(4),ICMDCH(8),KEYLAS(3),KEYLOW(4),KEYNOW(3),
     2          ICP001(200),ICP011(200),ICP021(200),ICP031(200),
     3          ICP041(200),
     5          KTY001(285),KTY286(36)
C
      COMMON /ERROR/ IERROR
      COMMON /CNTRL/ IBATCH,NBSU,LSTC,LSTF,LSTDB,ISURL,ITWO,LINPAG,LINE
      COMMON /FILES/ NFREAD,NFECHO,NFLOG,NFLIST,LUNODE,LUELEM
      COMMON /PARAM/ REALV(100),NCMD,NLASTP,ITYPE(20),INTV(100),
     1               IANUMV(160),LGHSTR,INTEG,IREAL,IANUM,ISTRIN,IOMIT
      COMMON /FIELDC/ REALI,INPREC(80),INPOS,ITYPEI,INTI,IANUMI(128),
     1               KEYI(8),NPOSRE,INECHO,MXSIGI,MXSIGR,MXSIGE,MXSTRL,
     2               ISTRIL,NFIELD,NPOSIN
      COMMON /SICODE/ I000,I111,I222,I333,I444,I555,I666,I777,I888,I999,
     1              IBLANK,IAAA,IBBB,ICCC,IDDD,IEEE,IFFF,IGGG,IHHH,IIII,
     2                IJJJ,IKKK,ILLL,IMMM,INNN,IOOO,IPPP,IQQQ,IRRR,ISSS,
     3                ITTT,IUUU,IVVV,IWWW,IXXX,IYYY,IZZZ,IPOINT,ICOMMA,
     4              IPLUS,IMINUS,IEQUAL,ILPAR,IRPAR,ISLASH,IASTER,IAPOST
C
C
C
      EQUIVALENCE (ICMDPA(1,01),ICP001(1)),
     1            (ICMDPA(1,11),ICP011(1)),
     2            (ICMDPA(1,21),ICP021(1)),
     3            (ICMDPA(1,31),ICP031(1)),
     4            (ICMDPA(1,41),ICP041(1)),
     6            (KEYTYP  (1),KTY001(1)),
     7            (KEYTYP(286),KTY286(1))
C
      DATA IEND,IERR,IUNSPE/5,6,8/
      DATA MAXANU,MAXPAR/20,100/
C
C
C          COMMAND AND PARAMETER ARRAYS
C
C          ARRAY ICMDPA CONTAINS COMMAND NAMES AND PARAMETER ADDRESSES
C
      DATA ICP001 /
     1 29,11,23,15,10, 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,
     2 15,24,14,10,10, 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,
     3 30,15,29,30,10, 4,7,10,13,16,19,22,25,1,0,0,0,0,0,0,
     4 16,19,22,15,10, 28,31,34,37,40,43,46,1,0,0,0,0,0,0,0,
     5 13,25,24,30,10, 49,31,52,55,58,61,37,64,67,70,
     -                      73,76,262,1,0,
     6 14,11,30,11,12, 79,82,40,85,1,0,0,0,0,0,0,0,0,0,0,
     7 34,00,07,10,10, 1,0,0,0,0,0,0,0,0,0,0,0,0,0,0,
     8 34,00,08,10,10, 1,0,0,0,0,0,0,0,0,0,0,0,0,0,0,
     9 34,00,09,10,10, 1,0,0,0,0,0,0,0,0,0,0,0,0,0,0,
     - 15,32,15,13,10, 163,211,169,274,85,271,0,0,0,0,0,0,0,0,0/
C
      DATA ICP011 /
     1 16,28,11,23,15, 88,91,94,97,100,0,0,0,0,0,0,0,0,0,0,
     2 29,31,12,16,10, 103,106,109,112,115,0,0,0,0,0,0,0,0,0,0,
     3 32,19,15,33,10, 103,118,121,124,127,0,0,0,0,0,0,0,0,0,0,
     4 12,36,10,10,10, 130,79,133,136,139,142,145,148,0,0,0,0,0,0,0,
     5 15,36,10,10,10, 130,79,151,154,0,0,0,0,0,0,0,0,0,0,0,
     6 15,17,36,10,10, 130,79,157,0,0,0,0,0,0,0,0,0,0,0,0,
     7 36,36,10,10,10, 130,79,160,0,0,0,0,0,0,0,0,0,0,0,0,
     8 23,15,29,18,10, 163,166,169,76,55,172,175,178,181,184,187,
     -                    118,121,37,190,
     9 23,25,14,15,10, 163,166,193,76,55,172,175,178,181,184,187,
     -                    118,121,37,190,
     - 11,34,19,29,10, 103,118,121,265,196,199,202,0,0,0,0,0,0,0,0/
C
      DATA ICP021 /
     1 30,15,34,30,10, 190,118,121,205,208,0,0,0,0,0,0,0,0,0,0,
     2 24,18,19,29,30, 178,55,211,214,217,220,223,226,229,232,85,190,
     -                      0,0,0,
     3 15,18,19,29,30, 151,181,40,211,214,217,220,223,226,229,
     -                     232,85,190,0,0,
     4 24,26,10,10,10, 130,235,0,0,0,0,0,0,0,0,0,0,0,0,0,
     5 24,22,19,24,15, 238,55,211,169,223,226,229,232,85,190,0,0,0,0,0,
     6 15,26,10,10,10, 130,151,241,244,0,0,0,0,0,0,0,0,0,0,0,
     7 15,22,19,24,15, 238,211,169,223,226,229,232,85,190,0,0,0,0,0,0,
     8 24,22,19,29,30, 163,55,211,214,217,220,0,0,0,0,0,0,0,0,0,
     9 17,22,19,29,30, 163,214,217,220,0,0,0,0,0,0,0,0,0,0,0,
     - 15,19,24,16,25, 163,178,40,0,0,0,0,0,0,0,0,0,0,0,0/
C
      DATA ICP031 /
     1 15,22,19,29,30, 163,214,217,220,190,0,0,0,0,0,0,0,0,0,0,
     2 24,23,11,34,10, 163,55,211,214,217,247,178,0,0,0,0,0,0,0,0,
     3 24,15,34,10,10, 163,55,211,214,217,247,250,0,0,0,0,0,0,0,0,
     4 15,23,11,34,10, 163,214,217,247,178,190,0,0,0,0,0,0,0,0,0,
     5 15,15,34,10,10, 163,214,217,247,250,190,0,0,0,0,0,0,0,0,0,
     6 24,32,10,10,10, 130,55,211,0,0,0,0,0,0,0,0,0,0,0,0,
     7 15,32,10,10,10, 130,247,211,0,0,0,0,0,0,0,0,0,0,0,0,
     8 13,10,10,10,10, 130,250,0,0,0,0,0,0,0,0,0,0,0,0,0,
     9 28,15,29,10,10, 130,208,0,0,0,0,0,0,0,0,0,0,0,0,0,
     - 28,18,19,29,30, 253,256,214,217,220,223,226,229,232,85,190,
     -                      0,0,0,0/
C
      DATA ICP041 /
     1 28,22,19,24,15, 238,256,169,223,226,229,232,85,190,0,0,0,0,0,0,
     2 28,22,19,29,30, 163,256,214,217,220,0,0,0,0,0,0,0,0,0,0,
     3 28,23,11,34,10, 163,256,214,217,247,178,0,0,0,0,0,0,0,0,0,
     4 28,15,34,10,10, 163,256,214,217,247,250,0,0,0,0,0,0,0,0,0,
     5 23,22,19,29,30, 163,55,259,61,0,0,0,0,0,0,0,0,0,0,0,
     6 34,04,06,10,10, 1,0,0,0,0,0,0,0,0,0,0,0,0,0,0,
     7 34,04,07,10,10, 1,0,0,0,0,0,0,0,0,0,0,0,0,0,0,
     8 34,04,08,10,10, 1,0,0,0,0,0,0,0,0,0,0,0,0,0,0,
     9 34,04,09,10,10, 1,0,0,0,0,0,0,0,0,0,0,0,0,0,0,
     - 34,05,00,10,10, 1,0,0,0,0,0,0,0,0,0,0,0,0,0,0/
C
C          ARRAY KEYTYP CONTAINS PARAMETER TYPE AND KEYNAME
C          LAST ENTRY MUST BE ZZZZ (3636,3636) FOR PRINT SORT
C          FREE ENTRY = 0000 (0000,0000)
C
      DATA KTY001/
C
     1-8,1010,1010, 1,2426,2529, 1,2412,2931, 1,2229,3011, 1,2229,3013,
     2 1,2229,3016, 1,2229,3014, 1,1929,3128, 1,1930,3325, 1,2810,1010,
     3 1,1513,1010, 1,2225,1010, 1,2219,1010, 1,2610,1010, 1,2231,2425,
     4 1,2231,1522, 1,1210,1010, 2,1810,1010, 1,1410,1010, 1,2935,1010,
     5 1,2315,1010, 1,2921,1010, 1,2429,3112, 1,2428,1531, 1,2319,1429,
     6 1,2510,1010, 3,2526,1010, 1,1610,1010, 1,2210,1010, 2,2910,1010,
     7 2,3416,1010, 2,3516,1010, 2,3429,1010, 2,3529,1010, 1,1910,1010,
     8 2,3416,0110, 2,3416,0210, 2,3516,0110, 2,3516,0210, 2,3410,1010,
     9 2,3510,1010, 2,3610,1010, 2,2810,1010, 3,2410,1010, 2,3423,1924,
     - 2,3423,1134, 2,3523,1924, 2,3523,1134, 2,3623,1924, 2,3623,1134,
     1 1,1517,1010,-1,1501,1010,-1,1517,0110,-3,3625,2401, 3,3610,1010,
     2 1,3210,1010, 2,3010,1010, 2,1729,1010, 2,1423,1010, 1,2410,1010,
     3 1,1510,1010, 1,3015,1010, 1,1134,1010, 1,2910,1010, 1,2310,1010,
     4 2,3223,1924, 2,3223,1134, 7,2211,1010, 2,1110,1010, 7,2930,1010,
     5 1,2110,1010, 2,3029,1010, 2,3015,1010, 1,3029,2110, 1,3410,1010,
     6 1,3510,1010, 1,2935,1010, 1,2929,2110,-1,2401,1010, 3,2219,2410,
     7 1,1501,1010,-1,2601,1010, 1,3035,1010, 2,3210,1010, 3,2610,1010,
     8 3,2810,1010, 1,2329,1010, 2,2311,1010, 2,2210,1010, 0,3636,3636,
     9 3,1610,1010, 2,2215,1010, 0,3636,3636, 0,3636,3636, 0,3636,3636/
      DATA KTY286/
     1 0,3636,3636, 0,3636,3636, 0,3636,3636, 0,3636,3636, 0,3636,3636,
     2 0,3636,3636, 0,3636,3636, 0,3636,3636, 0,3636,3636, 0,3636,3636,
     3 0,3636,3636, 0,3636,3636/
C
C
C          READ COMMAND
C
  100 NFIELD = -1
      CALL FIELD
      IF (ITYPEI.NE.IANUM) GOTO 810
C
C          TRY TO FIND COMMAND IN ICMDPA ARRAY
C
      NCMDIN = 0
      NPOSEQ = 0
      DO 150 ICMD=1,50
        IPOSEQ = 0
        DO 130 I=1,5
          ICHAR = ICMDPA(I,ICMD)
          IF (ICHAR.EQ.IBLANK) GOTO 140
          IF (ICHAR.NE.IANUMI(I)) GOTO 150
          IPOSEQ = I
  130     CONTINUE
  140   IF (IPOSEQ.LE.NPOSEQ) GOTO 150
          NCMDIN = ICMD
          NPOSEQ = IPOSEQ
  150   CONTINUE
C
C          TEST IF COMMAND NOT FOUND
C
  225 IF (NPOSEQ.EQ.0) GOTO 810
C
C
C          TEST IF COMMAND 'SAME'
C
      IF (NCMDIN.NE.1) GOTO 240
      IF (NCMD.GT.1) GOTO 290
      NCMD = IABS(NCMD)
      IF (NCMD.EQ.9999.OR.IBATCH.EQ.1) GOTO 810
      GOTO 290
C
C          NEW COMMAND, CLEAR INPUT ARRAYS
C
  240 NCMD = NCMDIN
      NLASTP = 0
      LGHSTR = 0
      DO 250 I=1,MAXANU
        ITYPE(I) = IOMIT
  250 CONTINUE
      DO 260 I=1,MAXPAR
        INTV(I) = 0
  260   REALV(I) = 0.0
      J = 8 * MAXANU
      DO 270 I=1,J
  270   IANUMV(I) = IBLANK
C
C          INITIALIZE PARAMETER READ
C
  290 NPAR = 0
      IPARNR = 0
      NFIELD = 0
      ICMD = IABS(NCMD)
C
C          READ NEXT PARAMETER
C
C
  300 CALL FIELD
      NFIELD = NFIELD + 1
      IF (ITYPEI.EQ.IEND) GOTO 8000
      IF (KEYI(1).EQ.IBLANK) GOTO 500
C
C          TRY TO FIND PARAMETER KEYNAME IN ARRAY
C
      NPOSEQ = 0
      DO 450 IPARNR = 1,15
        KTYAD = ICMDPA(IPARNR+5,ICMD)
        IF (KTYAD.EQ.0) GOTO 450
        I = KEYTYP(KTYAD+1)
        KEY(1) = I / 100
        KEY(2) = I - KEY(1) * 100
        I = KEYTYP(KTYAD+2)
        KEY(3) = I / 100
        KEY(4) = I - KEY(3) * 100
        IPOSEQ = 0
        DO 420 I=1,4
          IF (KEY(I).EQ.IBLANK) GOTO 430
          IF (KEY(I).NE.KEYI(I)) GOTO 450
          IPOSEQ = I
  420   CONTINUE
  430   IF (IPOSEQ.LT.NPOSEQ) GOTO 450
        NPOSEQ = IPOSEQ
        NPAR = IPARNR
  450 CONTINUE
C
C          TEST IF KEYNAME NOT FOUND IN ARRAY
C
      IPARNR = NPAR
      IF (NPOSEQ.GT.0) GOTO 600
      GOTO 820
C
C          NO KEYNAME GIVEN - CHECK IF TOO MANY PARAMETERS
C
  500 NPAR = NPAR + 1
      IF (NPAR.GT.MAXPAR) GOTO 830
      IF (IPARNR.EQ.0) GOTO 510
      KTYAD = ICMDPA(IPARNR+5,ICMD)
      ITYPAR = KEYTYP(KTYAD)
      IF (ITYPAR.LT.0) GOTO 600
  510 IPARNR = IPARNR + 1
      IF (IPARNR.GT.15) GOTO 830
      KTYAD = ICMDPA(IPARNR+5,ICMD)
      IF (KTYAD.EQ.0) GOTO 830
C
C          CHECK PARAMETER TYPE
C
  600 KTYAD = ICMDPA(IPARNR+5,ICMD)
      ITYPAR = IABS(KEYTYP(KTYAD))
      IF (ITYPEI.EQ.IERR) GOTO 840
      IF (ITYPEI.EQ.IOMIT) GOTO 300
      IF (ITYPAR.EQ.ISTRIN) GOTO 750
      IF (ITYPEI.EQ.ISTRIN) GOTO 650
      IF (ITYPAR.EQ.IUNSPE) GOTO 700
      IF (ITYPEI.EQ.INTEG.AND.ITYPAR.EQ.IREAL)  ITYPEI = IREAL
  650 IF (ITYPEI.NE.ITYPAR) GOTO 840
C
C          STORE PARAMETER VALUE IN INPUT ARRAYS
C
  700 INTV(NPAR)  = INTI
      REALV(NPAR) = REALI
      IF (NPAR.GT.MAXANU) GOTO 730
      I = NPAR * 8 - 8
      DO 710 J=1,8
        I = I + 1
  710   IANUMV(I) = IANUMI(J)
C
  720 IF (NPAR.LE.MAXANU) ITYPE(NPAR) = ITYPEI
      IF (NLASTP.LT.NPAR)  NLASTP = NPAR
      GOTO 300
  730 IF (ITYPEI.EQ.IANUM ) GOTO 830
      GOTO 720
C
C          STORE STRING PARAMETER
C
  750 IF (ITYPEI.NE.ISTRIN) GOTO 870
      I = NPAR * 8 - 8
      IF (I+ISTRIL.GT.(8*MAXANU)) GOTO 870
      LGHSTR = ISTRIL
      J = 0
  755 J = J + 1
      IF (J.GT.LGHSTR) GOTO 720
      I = I + 1
      IANUMV(I) = IANUMI (J)
      GOTO 755
C
C          WRITE ERROR MESSAGES TO NFLOG
C
  810 WRITE (NFLOG,2810)
      NCMD = -9999
      NLASTP = 0
      GOTO 900
  820 WRITE (NFLOG,2820)
      GOTO 890
  830 WRITE (NFLOG,2830)
      GOTO 890
  840 IF (ITYPAR.EQ.INTEG)  WRITE (NFLOG,2840)
      IF (ITYPAR.EQ.IREAL)  WRITE (NFLOG,2850)
      IF (ITYPAR.EQ.IANUM)  WRITE (NFLOG,2860)
      IRET = 300
      GOTO 895
  870 WRITE (NFLOG,2870)
  890 IRET = 900
  895 WRITE (NFLOG,2890)  NFIELD
      IF (NCMD.GT.0)  NCMD = -NCMD
      IF (IRET.EQ.300) GOTO 300
C
C          BYPASS REST OF PARAMETER LIST
C
  900 CONTINUE
      I = 0
  901 CONTINUE
      CALL FIELD
      IF (ITYPEI.EQ.IEND) GOTO 8000
      IF (I.EQ.0 .AND. IBATCH.EQ.0) WRITE (NFLOG,2901)
      I = 1
      GOTO 901
C
C          LIST COMMAND AND PARAMETER ARRAYS IF INOUT LSTA=1
C
  950 CONTINUE
      DO 959 ICMD=1,50
        DO 952 I=1,5
          ICMDCH(I) = ICMDPA(I,ICMD)
          CALL APCHAR (ICMDCH(I))
  952     CONTINUE
        WRITE (NFLOG,2952) (ICMDCH(I),I=1,5), ICMD
        DO 955 IPARNR=1,15
            KTYAD = ICMDPA(IPARNR+5,ICMD)
            IF (KTYAD.EQ.0) GOTO 955
            I = KEYTYP(KTYAD+1)
            KEY(1) = I / 100
            KEY(2) = I - KEY(1) * 100
            I = KEYTYP(KTYAD+2)
            KEY(3) = I / 100
            KEY(4) = I - KEY(3) * 100
            DO 954 I=1,4
  954       CALL APCHAR(KEY(I))
            WRITE (NFLOG,2953) KEY, KEYTYP(KTYAD), KTYAD
  955     CONTINUE
  959 CONTINUE
C
C          PRINT ARRAY KEYTYP IN SORTED SEQUENCE
C
  960 DO 962 I=1,3
  962   KEYLAS(I) = 0
  964 DO 966 I=1,3
  966   KEYLOW(I) = 9999
      KTYAD = -2
  968 KTYAD = KTYAD + 3
      KEYNOW(1) = KEYTYP(KTYAD+1)
      KEYNOW(2) = KEYTYP(KTYAD+2)
      KEYNOW(3) = KTYAD
      IF (KEYNOW(1).EQ.3636) GOTO 980
      DO 970 I=1,3
        IF (KEYNOW(I)-KEYLAS(I))  968,  970, 972
  970   CONTINUE
      GOTO 968
  972 DO 974 I=1,3
        IF (KEYNOW(I)-KEYLOW(I))  976, 974, 968
  974   CONTINUE
  976 DO 978 I=1,3
  978   KEYLOW(I) = KEYNOW(I)
      KEYLOW(4) = KEYTYP(KTYAD)
      GOTO 968
  980 IF(KEYLOW(1).EQ.9999) GOTO  8001
      I = KEYLOW(1)
      KEY(1) = I / 100
      KEY(2) = I - KEY(1) * 100
      I = KEYLOW(2)
      KEY(3) = I / 100
      KEY(4) = I - KEY(3) * 100
      DO 981 I=1,4
  981   CALL APCHAR(KEY(I))
      WRITE (NFLOG,2953) (KEY(I),I=1,4), KEYLOW(4), KEYLOW(3)
      DO 982 I=1,3
  982   KEYLAS(I) = KEYLOW(I)
      GOTO 964
C
C          WRITE INPUT ARRAYS FOR TEST PURPUSE IF LSTC IS SET
C
  990 WRITE (NFLOG,2990)  NCMD,NLASTP,LGHSTR
      IF (NLASTP.EQ.0) GOTO 8500
      J = NLASTP + (LGHSTR - 1) / 8
      DO 995 I=1,J
        IF (I.GT.MAXANU) GOTO 992
          J2 = I * 8
          J1 = J2 - 7
          WRITE (NFLOG,2991) I,INTV(I),REALV(I),ITYPE(I),
     1                  (IANUMV(J3),J3=J1,J2)
         GOTO 995
  992   WRITE (NFLOG,2991) I,INTV(I),REALV(I)
  995 CONTINUE
      GOTO 8500
C
C
C          RETURN TO CALLER, TEST FIRST IF ANY PRINTING IS REQUESTED
C
 8000 IF (NCMD.EQ.3.AND.INTV(3).GT.0) GOTO 950
C
 8001 IF (LSTC.GT.0) GOTO 990
C
 8500 IF (NCMD.LE.0) IERROR = 1
      RETURN
C
C
 2810 FORMAT (22H ***ERROR: BAD COMMAND)
 2820 FORMAT (26H ***ERROR: UNKNOWN KEYNAME)
 2830 FORMAT (30H ***ERROR: TOO MANY PARAMETERS)
 2840 FORMAT (26H ***ERROR: INVALID INTEGER)
 2850 FORMAT (23H ***ERROR: INVALID REAL)
 2860 FORMAT (31H ***ERROR: INVALID ALPHANUMERIC)
 2870 FORMAT (25H ***ERROR: INVALID STRING)
 2890 FORMAT (36H ***ERROR: AT SPECIFIED PARAMETER NR,I4)
 2901 FORMAT(11X,32HFOLLOWING PARAMETERS ARE IGNORED)
 2952 FORMAT (1H ,5A1,4X,I3)
 2953 FORMAT (5H     ,4A1,2X,I2,5X,I5)
 2990 FORMAT (12H COMND NCMD=,I5,9H  NLASTP=,I3,9H  LGHSTR=,I3)
 2991 FORMAT (1H ,8X,I3,I10,2X,E17.10,2X,I2,2X,8I2)
      END
C***ADD:CDC***
CDECK FIELD
C***END:CDC***
      SUBROUTINE FIELD
      DIMENSION ICLASV(47),ICHARV(47),ISMALL(47),IENDA(4)
C
      COMMON /CNTRL/ IBATCH,NBSU,LSTC,LSTF,LSTDB,ISURL,ITWO,LINPAG,LINE
      COMMON /FILES/ NFREAD,NFECHO,NFLOG,NFLIST,LUNODE,LUELEM
      COMMON /PARAM/ REALV(100),NCMD,NLASTP,ITYPE(20),INTV(100),
     1               IANUMV(160),LGHSTR,INTEG,IREAL,IANUM,ISTRIN,IOMIT
      COMMON /FIELDC/ REALI,INPREC(80),INPOS,ITYPEI,INTI,IANUMI(128),
     1               KEYI(8),NPOSRE,INECHO,MXSIGI,MXSIGR,MXSIGE,MXSTRL,
     2               ISTRIL,NFIELD,NPOSIN
      COMMON /SICODE/ I000,I111,I222,I333,I444,I555,I666,I777,I888,I999,
     1              IBLANK,IAAA,IBBB,ICCC,IDDD,IEEE,IFFF,IGGG,IHHH,IIII,
     2                IJJJ,IKKK,ILLL,IMMM,INNN,IOOO,IPPP,IQQQ,IRRR,ISSS,
     3                ITTT,IUUU,IVVV,IWWW,IXXX,IYYY,IZZZ,IPOINT,ICOMMA,
     4              IPLUS,IMINUS,IEQUAL,ILPAR,IRPAR,ISLASH,IASTER,IAPOST
C
      DATA IEND,IERR,IUNSPE/5,6,8/
      DATA IYES,ICHARB/1,1H /
      DATA IENDA/1H/,1HE,1HN,1HD/
C
C          ICLASV CONTAINS INPUT CHARACTER CLASS CODES
C
      DATA ICLASV/5,5,5,5,5,5,5,5,5,5,
     1            1,7,7,7,7,6,7,7,7,7,
     2            7,7,7,7,7,7,7,7,7,7,
     3            7,7,7,7,7,7,7,3,1,2,
     4            2,4,8,8,1,8,9/
C
C           ICHARV CONTAINS ALL 46 CHARATERS SORTED SO THAT THE MOST
C          FREQUENT COME FIRST, TO MINIMIZE SEARCH TIME.
C
C***ADD:BUR***
C        USE THE FOLLOWING DATA FOR ICHARV ON BURROUGHS MACHINES
C     DATA ICHARV/064,240,241,242,243,244,245,246,247,248,
C    1            249,197,213,214,211,201,193,075,126,096,
C    2            107,226,227,231,232,233,212,215,195,217,
C    3            198,199,200,229,230,196,194,228,209,210,
C    4            216,078,097,092,077,093,125/
C***END:BUR***
C
C***DEL:BUR***
      DATA ICHARV/1H ,1H0,1H1,1H2,1H3,1H4,1H5,1H6,1H7,1H8,
     1            1H9,1HE,1HN,1HO,1HL,1HI,1HA,1H.,1H=,1H-,
     2            1H,,1HS,1HT,1HX,1HY,1HZ,1HM,1HP,1HC,1HR,
     3            1HF,1HG,1HH,1HV,1HW,1HD,1HB,1HU,1HJ,1HK,
     4            1HQ,1H+,1H/,1H*,1H(,1H),1H'/
C***END:BUR***
C
C          ISMALL IS SORTED IN SAME ORDER AS ICHARV AND CONTAINS
C          THE CHARACTERS SMALL INTEGER CODE.
C
      DATA ISMALL/10,00,01,02,03,04,05,06,07,08,
     1            09,15,24,25,22,19,11,37,41,40,
     2            38,29,30,34,35,36,23,26,13,28,
     3            16,17,18,32,33,14,12,31,20,21,
     4            27,39,44,45,42,43,46/
C
C          INITIALIZE COMMON /FIELDC/ AND WORK VARIABLES
C
      INTI = 0
      REALI = 0.0
      DO 10 I=1,8
        IANUMI(I) = IBLANK
        KEYI(I)   = IBLANK
   10 CONTINUE
      ISTRIL = 0
C
      INSTAT = 1
      RVALUE = 0.0
      NDIGIT = 0
      NSDIG = 0
      NDECIM = 0
      IEXP = 0
      ISIGN = +1
      ISIGNE = +1
      IIANUM = 0
      LCOMMA = 0
      IFIRST = 0
C
C          LCOMMA = 1 IF LAST NON-BLANK CHAR IN RECORD SOFAR IS COMMA
C          IFIRST = 1 IF THIS IS FIRST FIELD IN A LIST
C
C
C          CHECK STATUS AFTER PREVIOUS CALL
C
C     TEST IF PREVIOUS CALL RESULTED IN END OF LIST
C
      IF (ITYPEI.NE.IEND)  GOTO 110
        IFIRST = 1
        LCOMMA = 1
        IF (INPOS.GT.NPOSIN)  GOTO 200
        GOTO 300
  110 ITYPEI = 0
C
C          TEST IF PREVIOUS FIELD ENDED BECAUSE OF / OR RECORD END
C
      IF (INPOS.GT.NPOSIN)  GOTO 444
        INCHAR = INPREC(INPOS)
        IF (INCHAR.EQ.ISLASH)  GOTO 444
C
C          TEST IF PREVIOUS FIELD ENDED BY COMMA
C
      IF (INCHAR.EQ.ICOMMA)  LCOMMA = 1
C
      GOTO 300
C
C          READ INPUT RECORD
C
  200 CONTINUE
C***ADD:BUR***
C     IF(IBATCH.NE.IYES) WRITE(NFLOG,2000)
C***END:BUR***
C***ADD:CDC***
C     READ (NFREAD,1001) (INPREC(I),I=1,NPOSRE)
C     IF (EOF(NFREAD)) 203, 207
C***END:CDC***
C***DEL:CDC***
      READ (NFREAD,1001,END=203) (INPREC(I),I=1,NPOSRE)
      GOTO 207
C***END:CDC***
  203 DO 205 I=1,4
  205   INPREC(I) = IENDA(I)
      NPOSIN = 4
      GOTO 250
  207 CONTINUE
      NPOSIN = NPOSRE
  210 IF (INPREC(NPOSIN).GT.0) GOTO 230
      IF (ICHARB.GT.0) GOTO 240
  220 IF (INPREC(NPOSIN).NE.ICHARB) GOTO 240
      NPOSIN = NPOSIN - 1
      IF (NPOSIN.GT.2) GOTO 210
  230 IF (ICHARB.GT.0) GOTO 220
  240 CONTINUE
      IF (INECHO.EQ.IYES)
     1WRITE (NFECHO,2001) (INPREC(I),I=1,NPOSIN)
  250 INPOS = 0
      IFIRST = 1
      LCOMMA = 1
C
C          NEXT INPUT CHARACTER
C
  300 INPOS = INPOS + 1
      IF (INPOS.LE.NPOSIN)  GOTO 310
      IF (ITYPEI.EQ.ISTRIN .AND. LAPOST.EQ.-1) GOTO 200
        INCHAR = ISLASH
        GOTO 350
C
C          CONVERT INPUT CHARACTER TO SMALL INTEGER CODE
C
  310 INCHAR = INPREC(INPOS)
      DO 330 I=1,47
C          COMPATIBLE FORTRAN TEST FOR
C            IF (INCHAR.EQ.ICHARV(I))  GOTO 340
        J = ICHARV(I)
        IF (INCHAR.LT.0)  GOTO 320
        IF (J     .LT.0)  GOTO 330
  315   IF (INCHAR.EQ.J)  GOTO 340
        GOTO 330
  320   IF (J     .LT.0)  GOTO 315
  330 CONTINUE
C
C          BAD INPUT CHARACTER
C
      GOTO 900
C
C          CHARACTER FOUND IN ICHARV ARRAY
C
  340 INCHAR = ISMALL(I)
      INPREC(INPOS) = INCHAR
C
C          GOTO ACTION CALL PROCEDURE DEPENDING ON INPUT CHAR CLASS
C
  350 ICLASS = ICLASV(INCHAR+1)
      IF (ITYPEI.EQ.ISTRIN) GOTO 711
C
C          TEST TO BYPASS REST OF FIELD IF ERROR STATUS
C
      IF (INSTAT.EQ.10 .AND. ICLASS.NE.1)  GOTO 300
C
      GOTO (400,520,530,540,550,560,570,900,700),  ICLASS
C
C          FIELD DELIMITER BLANK, COMMA, SLASH OR END OF RECORD
C
  400 GOTO (440,430,450,410,420,450,450,420,430,455),  INSTAT
C
C          RESULT FIELD IS INTEGER
C
  410 IF (NDIGIT.EQ.0)  GOTO 450
      IF (NDECIM.NE.0)  GOTO 420
      IF (NSDIG.GT.MXSIGI) GOTO 420
      RVALUE = RVALUE + 0.1
      INTI = INT(RVALUE) * ISIGN
      REALI = INTI
      ITYPEI = INTEG
      GOTO 8000
C
C          RESULT IS REAL
C
  420 IF (NDIGIT.EQ.0)  GOTO 450
      IF (ISIGN.EQ.-1) RVALUE = -RVALUE
      IEXP = IEXP * ISIGNE - NDECIM
      IF (IABS(IEXP + NSDIG) .GT. MXSIGE)  GOTO 920
      REALI = RVALUE * (10.0**IEXP)
      ITYPEI = IREAL
      GOTO 8000
C
C          RESULT IS ALPHANUMERIC
C
  430 ITYPEI = IANUM
      IF (IIANUM.LE.8 .OR. NFIELD.EQ.-1) GOTO 8000
      WRITE (NFLOG,2430)
      GOTO 450
C
C          FIELD HAS NOT STARTED
C
  440 IF (INCHAR.EQ.IBLANK)  GOTO 300
C
      IF (INCHAR.NE.ICOMMA)  GOTO 442
        IF (LCOMMA.EQ.1)  GOTO 441
          LCOMMA = 1
          GOTO 300
  441   ITYPEI = IOMIT
        GOTO 8000
  442 CONTINUE
C
      IF (INPOS.GT.NPOSIN .AND. (LCOMMA.EQ.1.OR.IFIRST.EQ.1))  GOTO 200
      IF (IFIRST.EQ.1)  GOTO 300
  444 ITYPEI = IEND
      GOTO 8000
C
C          ERROR FIELD IS NOT COMPLETED
C
  450 WRITE (NFLOG,2002)  INPOS
  455 ITYPEI = IERR
      GOTO 8000
C
C          FIELD CHARACTER CHECK
C
C          + AND - SIGN
C
  520 GOTO(640,900,640,900,900,670,900,900,900), INSTAT
C
C          . DECIMAL POINT
C
  530 GOTO (650,900,650,650,900,900,900,900,900), INSTAT
C
C          = EQUAL KEYNAME DELIMITOR
C
  540 IF (INSTAT.EQ.2)  GOTO 630
      GOTO 900
C
C          0 - 9 DIGIT
C
  550 GOTO (640,620,640,640,650,680,680,680,690), INSTAT
C
C          E FOR EXPONENT
C
  560 GOTO (620,620,690,660,660,900,900,900,690), INSTAT
C
C          A - Z BUT NOT E LETTER
C
  570 GOTO (620,620,690,900,900,900,900,900,690), INSTAT
C
C          REMEMBER ANUM KEY OR VALUE CHARACTER
C
  620 INSTAT = 2
  625 IIANUM = IIANUM + 1
      IF (IIANUM.LE.8) IANUMI(IIANUM) = INCHAR
      GOTO 300
C
C          REMEMBER = EQUAL KEYWORD DELIMITOR
C
  630 INSTAT = 3
      DO 635 I=1,8
        KEYI(I) = IANUMI(I)
        IANUMI(I) = IBLANK
  635 CONTINUE
      IIANUM = 0
      GOTO 300
C
C          REMEMBER PLUS, MINUS OR INTEGER DIGIT
C
  640 INSTAT = 4
      IF (INCHAR.EQ.IMINUS)  ISIGN = -1
      IF (ICLASS.EQ.2)  GOTO 300
  645 IF (INCHAR.GT.0 .OR. NSDIG.GT.0)  NSDIG = NSDIG + 1
      IF (NSDIG.GT.MXSIGR)  GOTO 648
      RVALUE = RVALUE * 10.0 + FLOAT(INCHAR)
  646 NDIGIT = NDIGIT + 1
      GOTO 300
  648 IF (INCHAR.NE.0)  GOTO 910
      NDECIM = NDECIM - 1
      GOTO 646
C
C          REMEMBER . DECIMAL POINT OR DIGIT
C
  650 INSTAT = 5
      IF (INCHAR.EQ.IPOINT)  GOTO 300
      NDECIM = NDECIM + 1
      GOTO 645
C
C          REMEMBER E FOR EXPONENT
C
  660 INSTAT = 6
      GOTO 300
C
C          REMEBER + OR - SIGN FOR EXPONENT
C
  670 INSTAT = 7
      IF (INCHAR.EQ.IMINUS)  ISIGNE = -1
      GOTO 300
C
C          REMEMBER EXPONENT DIGIT
C
  680 INSTAT = 8
      IEXP = IEXP * 10 + INCHAR
      IF (IEXP.GT.999)  GOTO 920
      GOTO 300
C
C          REMEMBER ANUM AFTER KEYNAME=
C
  690 INSTAT = 9
      GOTO 625
C
C          APOSTROPHE 'STRING' START
C
  700 IF (INSTAT.NE.1 .AND.INSTAT.NE.3) GOTO 900
      ITYPEI = ISTRIN
      ISTRIL = 0
      LAPOST = -1
      GOTO 300
C
C          STRING CHARACTER
C
  711 IF (ICLASS.EQ.9) GOTO 720
      IF (LAPOST.EQ.+1) GOTO 730
  712 ISTRIL = ISTRIL + 1
      IF (ISTRIL.GT.MXSTRL)  GOTO 719
      IANUMI(ISTRIL) = INCHAR
      GOTO 300
  719 WRITE (NFLOG,2719) MXSTRL
      GOTO 790
C
C          APOSTROPHE STRING END OR ''
C
  720 LAPOST = -LAPOST
      IF (LAPOST.EQ.-1) GOTO 712
      GOTO 300
C
C          STRING END
C
  730 IF (INSTAT.EQ.10) ITYPEI = IERR
      IF (ICLASS.EQ.1) GOTO 8000
  790 ITYPEI = 0
      GOTO 900
C
C          ERROR MESSAGES
C
  900 INSTAT = 10
      WRITE (NFLOG,2002)  INPOS
      GOTO 300
  910 WRITE (NFLOG,2003) MXSIGR
      GOTO 900
  920 WRITE (NFLOG,2004)  MXSIGE
      GOTO 450
C
  990 WRITE (NFLOG,2090) INPOS,ITYPEI,INTI,REALI,(IANUMI(I),I=1,8)
     1                   ,KEYI,ISTRIL
      GOTO 8500
 8000 IF (LSTF.EQ.IYES)  GOTO 990
 8500 RETURN
C
C***ADD:BUR***
C1001 FORMAT (80C1)
C2001 FORMAT (/1H ,80C1)
C***END:BUR***
C***DEL:BUR***
 1001 FORMAT (80A1)
 2001 FORMAT (/1H ,80A1)
C***END:BUR***
 2000 FORMAT (1H ,1H?)
 2002 FORMAT (48H ***ERROR: BAD INPUT DATA BEFORE OR AT LOCATION ,I4)
 2003 FORMAT (45H ***ERROR: TOO MANY SIGNIFICANT DIGITS, MAX= ,I3)
 2004 FORMAT (55H ***ERROR: TOO BIG OR LITTLE REAL NUMBER, EXPONENT MAX=
     1,I3)
 2090 FORMAT (7H FIELD ,I3,1X,I1,1X,I10,1X,E17.10,1X,8I2,1X,8I2,1X,I3)
 2430 FORMAT (46H ***ERROR: ALPHANUMERIC LENGTH EXCEEDED, MAX 8)
 2719 FORMAT (38H ***ERROR: STRING LENGTH EXCEEDED, MAX,I4)
      END
C*NEW FILE
C***END:IBM***
      SUBROUTINE DATAB
C
C          DATABASE CREATION FROM PORTHOLE OR DATABASE RE-OPEN
C
      DIMENSION IA(1)
      COMMON /ERROR/ IERROR
      COMMON /CNTRL/ IBATCH,NBSU,LSTC,LSTF,LSTDB,ISURL,ITWO,LINPAG,LINE
      COMMON /FILES/ NFREAD,NFECHO,NFLOG,NFLIST,LUNODE,LUELEM
      COMMON /PARAM/ REALV(100),NCMD,NLASTP,ITYPE(20),INTV(100),
     1               IANUMV(8,20),LGHSTR,INTEG,IREAL,IANUM,ISTRIN,IOMIT
      COMMON /SICODE/ I000,I111,I222,I333,I444,I555,I666,I777,I888,I999,
     1              IBLANK,IAAA,IBBB,ICCC,IDDD,IEEE,IFFF,IGGG,IHHH,IIII,
     2                IJJJ,IKKK,ILLL,IMMM,INNN,IOOO,IPPP,IQQQ,IRRR,ISSS,
     3                ITTT,IUUU,IVVV,IWWW,IXXX,IYYY,IZZZ,IPOINT,ICOMMA,
     4              IPLUS,IMINUS,IEQUAL,ILPAR,IRPAR,ISLASH,IASTER,IAPOST
      COMMON /DB/ IOPEN,NFDB,INDXST,IXTNOW,LGP,NWRITS,NREADS,
     1            LDBC,LDBCTR,LDBCTI,IPHCHK,INSTRI,INRUSE,INSTRU,
     2            MSUBF,MVIEW,MAXIS,MLINEN,MLINEE,MVAR,MRES,LSKEW,MIDSPL
      COMMON /DBC/ IHED(18),NDAREC,LDAREC,NRECS,NWORDS,NEXREC,NEXTIX,
     1             LIX,LIXT,NSTRI,NSTRUC,NEGIT,NEGAT,NFREQ,
     2             IXGP(50),MXSGP(50),
     3             FILL1
      COMMON /DIM/ I01,I02,I03,I04,I05,I06,I07,I08,I09,I010,I011,
     1             I1,I2,I3,I4,I5,I6,I7,I8,I9,I10,I11,I12,I13,I14,I15,
     2             I16,I17,I18,I19,I20,
     3             N1,N2,N3,N4,N5,N6,N7,N8,N9,N10,N11,N12,N13,N14,N15,
     4             N16,N17,N18,N19,N20
      COMMON /DBCTRL/ DT    ,TSTART,NUMNP ,NEQT  ,NSUBST,IDOF(6),
     1                NDOF  ,NEG   ,NMID  ,MODEX ,NSTE  ,NSTEN ,
     2                NSTEE ,NSKEWS,NMIDSS,IEIG  ,NSREFB,NEQITB,
     3                NPRIB ,NODSVB,LEMSVB,JDC   ,JAC   ,JVC   ,
     4                ISTAT ,JTC   ,NDISCE,ITP96 ,MXITAB,MXIDER,MXERES,
     5                NELPAR,MXNP  ,MXEG  ,MXEL  ,MXELNP,
     6                NDOFSA(6),NOUSE(4),FILL2
      COMMON /IGPNAM/ KDBC  ,KSUBGP,KDBCTR,KSTRI ,KRSDCO,KTMIDS,
     1                KXYZ  ,KIDRN ,KICONA,KNZONE,KNPAR ,KTHICK,
     2                KITABL,KNOD  ,KEDATA,KIEZON,KFRQ  ,KPHI  ,
     3                KTIMEN,KDISP ,KVEL  ,KACC  ,KTEMP ,KTIMEE,
     4                KERES ,KSUBF ,KVIEW ,KAXIS ,KNPOIN,KVARES,
     5                KNAMEZ,KEPOIN,KSXYZ ,KX34  ,KX35  ,KX36  ,
     6                KX37  ,KX38  ,KX39  ,KX40  ,KX41  ,KX42  ,
     7                KX43  ,KX44  ,KX45  ,KX46  ,KX47  ,KX48  ,
     8                KX49  ,KX50
      COMMON /MEMORY/ MTOT,LPROG,MEMPRT,MEMMAX,MEMNOW
      COMMON A(1)
      EQUIVALENCE (A(1),IA(1))
      DATA NCREAT,NOPEN/1,2/
C
      CALL DBCLOS
      IF (IERROR.NE.0) GOTO 900
C
      IF (ITYPE(2).EQ.INTEG)  NFDB = INTV(2)
      IPHCHK = INTV(3)
C          LSTLU IS PROCESSED IN PHSCAN
C
      NOPERA = NCREAT
      IF (IANUMV(1,1).EQ.ICCC.AND.IANUMV(2,1).EQ.IRRR) GOTO 100
      NOPERA = NOPEN
      IF (IANUMV(1,1).EQ.IOOO.AND.IANUMV(2,1).EQ.IPPP) GOTO 100
      WRITE (NFLOG,2000)
      IERROR = 1
      GOTO 900
C
  100 IA(1) = -87878
      IA(2) = 0
      IA(3) = 1
      IA(4) = 2
      IA(MEMNOW) = -87878
      NREADS = 0
      NWRITS = 0
      IXTNOW = 0
      INSTRI = 1
      INRUSE = 1
      INSTRU = 1
      NRECS  = 0
      NWORDS = 0
C
C          CREATE: SCAN LUNODE TO DETERMINE SIZE OF DB INDEX
C
      IF (NOPERA.NE.NCREAT) GOTO 500
C
      CALL PHSCAN
      IF (IERROR.NE.0) GOTO 800
      CALL DBOPEN
      IF (IERROR.NE.0) GOTO 900
C
C          INITIALIZE DATABASE ARRAYS AND CONTROL VARIABLES
C
      DO 400 IGP=1,LGP
        IXGP(IGP) = 0
  400   MXSGP (IGP) = 0
C
      MXSGP (KDBCTR) = 1
      MXSGP (KSTRI ) = 1
      IF (NSKEWS.NE.0) MXSGP (KRSDCO) = 1
      MXSGP (KTMIDS) = NSTRI
      MXSGP (KXYZ  ) = NSTRUC
      MXSGP (KIDRN ) = NSTRI
      MXSGP (KICONA) = NSTRUC - 1
      MXSGP (KNZONE) = NSTRUC
      MXSGP (KNPAR ) = NSTRI
      MXSGP (KTHICK) = NEGIT
      MXSGP (KITABL) = NEGIT
      MXSGP (KNOD  ) = NEGIT
      MXSGP (KEDATA) = NEGIT
      MXSGP (KIEZON) = NEGAT
      IF (IEIG.GT.0) MXSGP (KFRQ) = 1
      IF (IEIG.GT.0) MXSGP (KPHI) = NFREQ
      MXSGP (KTIMEN) = 1
      IF (JDC.NE.0) MXSGP (KDISP) = NSTRUC
      IF (JVC.NE.0.AND.ISTAT.NE.0) MXSGP (KVEL) = NSTRUC
      IF (JAC.NE.0.AND.ISTAT.NE.0) MXSGP (KACC) = NSTRUC
      IF (JTC.NE.0 .AND. ITP96.NE.0) MXSGP (KTEMP ) = 1
      MXSGP (KTIMEE) = 1
      IF (LEMSVB.NE.0) MXSGP (KERES) = NEGAT
      MXSGP (KSUBF ) = 1
      MXSGP (KVIEW ) = 1
      MXSGP (KAXIS ) = 1
      MXSGP (KNPOIN) = 1
      MXSGP (KVARES) = 1
      MXSGP (KNAMEZ) = 1
      MXSGP (KEPOIN) = 1
      MXSGP (KSXYZ ) = NEGAT
C
      LIX = 1
      DO 410 IGP=1,LGP
  410   LIX = LIX + MXSGP (IGP)
C
      NEXREC = 1
      NEXTIX = 1
      CALL ALIGN (LIX)
      LIXT = NSTE + 2
      CALL ALIGN (LIXT)
      GOTO 600
C
C          OPEN: READ COMMON /DBC/
C
  500 CONTINUE
      CALL DBOPEN
      IF (IERROR.NE.0) GOTO 900
      CALL DBR (IHED,0,LDBC,1)
      IF (IERROR.EQ.0 .AND. NRECS.GT.2 .AND. NWORDS.GT.100) GOTO 510
      WRITE (NFLOG,2020)
      IOPEN = 0
      IERROR = 1
      GOTO 900
  510 CONTINUE
      WRITE (NFLOG,2010) IHED
C
C          GET BLANK COMMON MEMORY FOR DATABASE SUBGROUP ARRAYS
C          AND TIME INDEX:  THESE AREAS ARE FIX AT START OF BLANK COMMON
C          INITIALIZE ALL ARRAYS TO ZERO
C
  600 CONTINUE
C                                                IXMAST
      I01 = 5
C                                                LREAL
      CALL ALIGN (I01)
      I02 = I01 + LIX
C                                                LINT
      I03 = I02 + LIX
C                                                IXSGP
      I04 = I03 + LIX
C                                                MXSGP
      I05 = I04 + LIX
C                                                IXTIME
      I06 = I05 + LIXT
C                                                NRUSES
      I07 = I06 + NSTRI
C                                                NEGS
      I08 = I07 + NSTRI
C                                                NUMNPS
      I09 = I08 + NSTRI
C                                                NEQTS
      I010 = I09 + NSTRI
C                                                MAXMSS
      I011 = I010 + NSTRI
C                                                NODRTS
      I1 = I011 + NSTRI
      CALL SIZE (I1)
      IF (IERROR.NE.0) GOTO 800
      N1 = I1 / ISURL
      DO 610 I=I01,I1
  610   IA(I) = 0
C
C          CREATE: WRITE COMMON /DBC/ AND SUBGROUP ARRAYS UNDER
C                  MASTER INDEX TO MAKE THEM FIRST IN DATABASE
C
      IF (NOPERA.NE.NCREAT) GOTO 700
      CALL DBW (IHED,0,LDBC,1)
      IF (IERROR.NE.0) GOTO 800
      CALL DBW (IA(I01),0,(LIX*4),2)
      IF (IERROR.NE.0) GOTO 800
C***DEL:CDC***
      NEXREC = (LIX * 4 - 1) / LDAREC + 3
C***END:CDC***
C
C          REREAD PORTHOLE FILES AND LOAD DATABASE
C
      NELPAR = 20
      CALL PHREAD (IA(I06),IA(I07),IA(I08),IA(I09),IA(I010),IA(I011)
     1             ,NELPAR,IA(I1))
      GOTO 900
C
C          OPEN: READ SUBGROUP ARRAYS AND COMMON AREAS
C
  700 CONTINUE
      CALL DBR (IA(I01),0,(LIX*4),2)
      IF (IERROR.NE.0) GOTO 800
      CALL DBREAD (DT,KDBCTR,1,0)
      IF (IERROR.NE.0) GOTO 800
      CALL DBREAD (IA(I06),KSTRI,1,0)
      IF (IERROR.NE.0) GOTO 800
      GOTO 900
C
  800 CALL DBCLOS
  900 RETURN
 2000 FORMAT (45H ***ERROR: DATABASE OPERATION CREATE OR OPEN?)
 2010 FORMAT(/4X,18A4/)
 2020 FORMAT(44H ***ERROR:  DATABASE FIRST RECORD IS INVALID)
      END
C***ADD:CDC***
CDECK PHSCAN
C***END:CDC***
      SUBROUTINE PHSCAN
C
C          SCAN OF PORTHOLE FILE TO ACCUMULATE VARIABLES FOR
C          DIMENSIONING THE DATA BASE INDEX
C
C***ADD:DPR***
      IMPLICIT REAL*8(D)
      REAL DT
C***END:DPR***
      DIMENSION IA(1),DA(1),IPNODE(3,1)
      COMMON /ERROR/ IERROR
      COMMON /CNTRL/ IBATCH,NBSU,LSTC,LSTF,LSTDB,ISURL,ITWO,LINPAG,LINE
      COMMON /FILES/ NFREAD,NFECHO,NFLOG,NFLIST,LUNODE,LUELEM
      COMMON /PARAM/ REALV(100),NCMD,NLASTP,ITYPE(20),INTV(100),
     1               IANUMV(8,20),LGHSTR,INTEG,IREAL,IANUM,ISTRIN,IOMIT
      COMMON /DB/ IOPEN,NFDB,INDXST,IXTNOW,LGP,NWRITS,NREADS,
     1            LDBC,LDBCTR,LDBCTI,IPHCHK,INSTRI,INRUSE,INSTRU,
     2            MSUBF,MVIEW,MAXIS,MLINEN,MLINEE,MVAR,MRES,LSKEW,MIDSPL
      COMMON /DBC/ IHED(18),NDAREC,LDAREC,NRECS,NWORDS,NEXREC,NEXTIX,
     1             LIX,LIXT,NSTRI,NSTRUC,NEGIT,NEGAT,NFREQ,
     2             IXGP(50),MXSGP(50),
     3             FILL1
      COMMON /DIM/ I01,I02,I03,I04,I05,I06,I07,I08,I09,I010,I011,
     1             I1,I2,I3,I4,I5,I6,I7,I8,I9,I10,I11,I12,I13,I14,I15,
     2             I16,I17,I18,I19,I20,
     3             N1,N2,N3,N4,N5,N6,N7,N8,N9,N10,N11,N12,N13,N14,N15,
     4             N16,N17,N18,N19,N20
      COMMON /DBCTRL/ DT    ,TSTART,NUMNP ,NEQT  ,NSUBST,IDOF(6),
     1                NDOF  ,NEG   ,NMID  ,MODEX ,NSTE  ,NSTEN ,
     2                NSTEE ,NSKEWS,NMIDSS,IEIG  ,NSREFB,NEQITB,
     3                NPRIB ,NODSVB,LEMSVB,JDC   ,JAC   ,JVC   ,
     4                ISTAT ,JTC   ,NDISCE,ITP96 ,MXITAB,MXIDER,MXERES,
     5                NELPAR,MXNP  ,MXEG  ,MXEL  ,MXELNP,
     6                NDOFSA(6),NOUSE(4),FILL2
      COMMON A(100)
      EQUIVALENCE (A(1),IA(1))
      EQUIVALENCE (A(1),DA(1))
      EQUIVALENCE (A(41),IPNODE(1,1))
C
      DATA DREOF/8HEND FILE/,DRANY/8HANY REC /
      DATA DRTYPX/8HTYPE - X/
C
      DATA DRMAST/8HMASTERCP/,DRSTIF/8HSTIFNESS/,
     1     DRITER/8HITERATON/,DRPRIN/8HPRINTOUT/,
     2     DRNODE/8HNODESAVE/,DRELMT/8HELMTSAVE/,
     3     DREQUA/8HEQUATONS/,DRNODC/8HNODECORD/,DRIDAR/8HID-ARRAY/,
     4     DRRSDC/8HRSDCOS  /,DRNSYS/8HNODESYST/,DRNMID/8HNODEMIDS/,
     5     DRNFMI/8HNODEFMID/
      DATA DRANY /8HANY REC /,DRSUBS/8HSUBSTRUC/,DREOF /8HEND FILE/
C
C          TEST PRINTING OF LUNODE RECORD LABELS
C
      IF (INTV(4).NE.1) GOTO 90
      REWIND LUNODE
      REWIND LUELEM
      WRITE (NFLOG,2000)
      LU = 1
      GOTO 5
  2   LU = 2
    5 DROLD = 0
      N = -1
  10  N = N + 1
      IF (DROLD.EQ.DREOF) GOTO 30
      DRECLB = DRANY
      IF (LU.EQ.1) CALL PHNCHK (DRECLB)
      IF (LU.EQ.2) CALL PHECHK (DRECLB)
      IF (DRECLB.EQ.DROLD) GOTO 10
  30  IF(N.GT.0) WRITE (NFLOG,2010) DROLD, N
      IF (DROLD.EQ.DREOF) GOTO 80
      DROLD = DRECLB
      N = 0
      GOTO 10
  80  IF (LUELEM.NE.LUNODE .AND. LU.EQ.1) GOTO 2
   90 REWIND LUNODE
      REWIND LUELEM
C
C          READ 'MASTERCP'
C
      I1 = 500
      CALL SIZE (I1)
      CALL PHNCHK (DRMAST)
      IF (IERROR.NE.0) GOTO 900
      BACKSPACE LUNODE
      READ (LUNODE)
     1     DRECLB,(IHED(I),I=1,18),NUMNP,(IDOF(I),I=1,6),
     2     NEGL,NEGNL,MODEX,NSTE,DA(15),DA(14),IDUM,NSKEWS,
     3     IDUM,ITP96,IDUM,IDUM,IDUM,IDUM,IDUM,IEIG,
     4     NSREFB,NEQITB,DUM,IDUM,IDUM,DUM,DUM,
     5     NPRIB,NODSVB,LEMSVB,LUNODE,LU1,LU2,LU3,
     6     NPB,IDUM,IDUM,IDUM,NPUTSV,JDC,JVC,JAC,
     7     ((IPNODE(I,J),I=1,3),J=1,NPB),
     8     NMIDSS,NDISCE,NSUBST,JTC,NFREQ,ISTAT
      WRITE (NFLOG,2040) IHED
      IF (NPUTSV.EQ.0) GOTO 790
      DT       = DA(15)
      TSTART   = DA(14)
      NSTRI  = NSUBST + 1
      ISTRI = 1
      NSTRUC = 1
      NEGIT = NEGL + NEGNL
      NEGAT = NEGIT
      NMID  = NMIDSS
      MXNP   = NUMNP
      NEG     = NEGL + NEGNL
      MXEG   = NEG
      IF (NSUBST.EQ.0 .AND. IPHCHK.EQ.0) GOTO 900
C
C          'STIFNESS',  'ITERATON',  'PRINTOUT'
C
      IF (NSREFB.NE.0)  CALL PHNCHK (DRSTIF)
      IF (NEQITB.NE.0)  CALL PHNCHK (DRITER)
      IF (NPRIB .NE.0)  CALL PHNCHK (DRPRIN)
C
C          'NODESAVE',  'ELMTSAVE',  'RSDCOS  '
C
      IF (NODSVB.NE.0)  CALL PHNCHK (DRNODE)
      IF (LEMSVB.NE.0)  CALL PHNCHK (DRELMT)
      IF (NSKEWS.NE.0)  CALL PHNCHK (DRRSDC)
C
C          'EQUATONS',  'NODECORD'
C
  100 CALL PHNCHK (DREQUA)
      CALL PHNCHK (DRNODC)
C
C          'NODESYST',  'NODEMIDS',  'NODEFMID',  'ID-ARRAY'
C
      IF (NSKEWS.NE.0)  CALL PHNCHK (DRNSYS)
      IF (NMID  .NE.0)  CALL PHNCHK (DRNMID)
      IF (NMID  .NE.0)  CALL PHNCHK (DRNFMI)
      IF (NDISCE.GE.1 .AND. ISTRI.EQ.1)  CALL PHNCHK (DRIDAR)
C
      IF (IERROR.NE.0) GOTO 900
C
C
C          IF SUBSTRUCTURES - READ ALL 'SUBSTRUC' TO FIND
C          NRUSE AND NEGLS AND ACCUMULATE APPROPRIATE VALUES
C          TO NSTRUC,NEGIT AND NEGAT
C
      ISTRI = ISTRI + 1
      IF (ISTRI.GT.NSTRI) GOTO 900
C
  300 DRECLB = DRANY
      CALL PHNCHK (DRECLB)
      IF (DRECLB.NE.DREOF) GOTO 310
        WRITE (NFLOG,2050) DRSUBS,DRECLB
        GOTO 800
  310 IF (DRECLB.NE.DRSUBS) GOTO 300
C
      BACKSPACE LUNODE
      READ (LUNODE) DRECLB,NS,NRUSE,NEGLS,NUMNPS,NODCON,NODRET,NSMIDS
      NSTRUC = NSTRUC + NRUSE
      NEGIT  = NEGIT  + NEGLS
      NEGAT  = NEGAT  + NEGLS * NRUSE
      NMID   = NSMIDS
      IF (MXNP.LT.NUMNPS) MXNP = NUMNPS
      IF (MXEG.LT.NEGLS) MXEG = NEGLS
      CALL ALIGN (MXNP)
      CALL ALIGN (MXEG)
C
      GOTO 100
C
  790 WRITE (NFLOG,2060)
  800 IERROR = 1
  900 RETURN
C
 2000 FORMAT(/36H    LUNODE AND LUELEM RECORD LABELS:)
 2010 FORMAT(4X,A8,1X,I5)
 2040 FORMAT (/34H    READING OF PORTHOLE STARTED - ,
     1  19HADINA HEADING CARD://4X,18A4/)
 2050 FORMAT (50H ***ERROR: PORTHOLE FILE SEQUENCE ERROR - EXPECTED,
     1         10H RECORD = ,A8/49X,15HFOUND RECORD = ,A8)
 2060 FORMAT (52H ***ERROR: CONTROL CARD 9 VARIABLE NPUTSV MUST BE SE,
     1        44HT TO 1 TO WRITE ADINA INPUT TO PORTHOLE FILE)
      END
C***ADD:CDC***
CDECK PHNCHK
C***END:CDC***
      SUBROUTINE PHNCHK (DRWANT)
C
C          READ NEXT LUNODE RECORD LABEL AND
C          IF  DRWANT.EQ.DRANY  RETURN LABEL OR 'END FILE'
C          ELSE                 CHECK THAT RECORD LABEL = DRWANT
C
C***ADD:DPR***
      IMPLICIT REAL*8(D)
C***END:DPR***
      COMMON /ERROR/ IERROR
      COMMON /FILES/ NFREAD,NFECHO,NFLOG,NFLIST,LUNODE,LUELEM
      DATA DREOF/8HEND FILE/,DRANY/8HANY REC /
C
      IF (IERROR.NE.0) GOTO 90
C***ADD:CDC***
C     READ (LUNODE) DRECLB
C     IF (EOF(LUNODE)) 30, 10
C***END:CDC***
C***DEL:CDC***
      READ (LUNODE,END=30) DRECLB
C***END:CDC***
C
  10  IF (DRWANT.EQ.DRANY)  DRWANT = DRECLB
      IF (DRECLB.EQ.DRWANT) GOTO 90
  20  IERROR = 1
      WRITE (NFLOG,2050) DRWANT, DRECLB
      GOTO 90
  30  DRECLB = DREOF
      GOTO 10
  90  RETURN
 2050 FORMAT (54H ***ERROR: PORTHOLE NODEFILE SEQUENCE ERROR - EXPECTED,
     1         10H RECORD = ,A8/49X,15HFOUND RECORD = ,A8)
      END
C***ADD:CDC***
CDECK PHECHK
C***END:CDC***
      SUBROUTINE PHECHK (DRWANT)
C
C          READ NEXT LUELEM RECORD LABEL AND
C          IF  DRWANT.EQ.DRANY  RETURN LABEL OR 'END FILE'
C          ELSE                 CHECK THAT RECORD LABEL = DRWANT
C
C***ADD:DPR***
      IMPLICIT REAL*8(D)
C***END:DPR***
      COMMON /ERROR/ IERROR
      COMMON /FILES/ NFREAD,NFECHO,NFLOG,NFLIST,LUNODE,LUELEM
      DATA DREOF/8HEND FILE/,DRANY/8HANY REC /
C
      IF (IERROR.NE.0) GOTO 90
C***ADD:CDC***
C     READ (LUELEM) DRECLB
C     IF (EOF(LUELEM)) 30, 10
C***END:CDC***
C***DEL:CDC***
      READ (LUELEM,END=30) DRECLB
C***END:CDC***
C
  10  IF (DRWANT.EQ.DRANY)  DRWANT = DRECLB
      IF (DRECLB.EQ.DRWANT) GOTO 90
  20  IERROR = 1
      WRITE (NFLOG,2050) DRWANT, DRECLB
      GOTO 90
  30  DRECLB = DREOF
      GOTO 10
  90  RETURN
 2050 FORMAT (54H ***ERROR: PORTHOLE ELEMFILE SEQUENCE ERROR - EXPECTED,
     1         10H RECORD = ,A8/49X,15HFOUND RECORD = ,A8)
      END
C***ADD:CDC***
CDECK PHREAD
C***END:CDC***
      SUBROUTINE PHREAD (NRUSES,NEGS,NUMNPS,NEQTS,MAXMSS,NODRTS,
     1                   NPARD,NPAR)
C
C          LOAD DATA BASE FROM PORTHOLE FILE
C
C***ADD:DPR***
      IMPLICIT REAL*8(D)
      REAL DT
C***END:DPR***
      DIMENSION IA(1),DA(1)
      DIMENSION NRUSES(1),NEGS(1),NUMNPS(1),NEQTS(1),MAXMSS(1),NODRTS(1)
     1          ,NPAR(NPARD,1),MXNODA(15),DRTYP(7),NTABSA(7)
      COMMON /ERROR/ IERROR
      COMMON /CNTRL/ IBATCH,NBSU,LSTC,LSTF,LSTDB,ISURL,ITWO,LINPAG,LINE
      COMMON /FILES/ NFREAD,NFECHO,NFLOG,NFLIST,LUNODE,LUELEM
      COMMON /DB/ IOPEN,NFDB,INDXST,IXTNOW,LGP,NWRITS,NREADS,
     1            LDBC,LDBCTR,LDBCTI,IPHCHK,INSTRI,INRUSE,INSTRU,
     2            MSUBF,MVIEW,MAXIS,MLINEN,MLINEE,MVAR,MRES,LSKEW,MIDSPL
      COMMON /DBC/ IHED(18),NDAREC,LDAREC,NRECS,NWORDS,NEXREC,NEXTIX,
     1             LIX,LIXT,NSTRI,NSTRUC,NEGIT,NEGAT,NFREQ,
     2             IXGP(50),MXSGP(50),
     3             FILL1
      COMMON /DIM/ I01,I02,I03,I04,I05,I06,I07,I08,I09,I010,I011,
     1             I1,I2,I3,I4,I5,I6,I7,I8,I9,I10,I11,I12,I13,I14,I15,
     2             I16,I17,I18,I19,I20,
     3             N1,N2,N3,N4,N5,N6,N7,N8,N9,N10,N11,N12,N13,N14,N15,
     4             N16,N17,N18,N19,N20
      COMMON /DBCTRL/ DT    ,TSTART,NUMNP ,NEQT  ,NSUBST,IDOF(6),
     1                NDOF  ,NEG   ,NMID  ,MODEX ,NSTE  ,NSTEN ,
     2                NSTEE ,NSKEWS,NMIDSS,IEIG  ,NSREFB,NEQITB,
     3                NPRIB ,NODSVB,LEMSVB,JDC   ,JAC   ,JVC   ,
     4                ISTAT ,JTC   ,NDISCE,ITP96 ,MXITAB,MXIDER,MXERES,
     5                NELPAR,MXNP  ,MXEG  ,MXEL  ,MXELNP,
     6                NDOFSA(6),NOUSE(4),FILL2
      COMMON /IGPNAM/ KDBC  ,KSUBGP,KDBCTR,KSTRI ,KRSDCO,KTMIDS,
     1                KXYZ  ,KIDRN ,KICONA,KNZONE,KNPAR ,KTHICK,
     2                KITABL,KNOD  ,KEDATA,KIEZON,KFRQ  ,KPHI  ,
     3                KTIMEN,KDISP ,KVEL  ,KACC  ,KTEMP ,KTIMEE,
     4                KERES ,KSUBF ,KVIEW ,KAXIS ,KNPOIN,KVARES,
     5                KNAMEZ,KEPOIN,KSXYZ ,KX34  ,KX35  ,KX36  ,
     6                KX37  ,KX38  ,KX39  ,KX40  ,KX41  ,KX42  ,
     7                KX43  ,KX44  ,KX45  ,KX46  ,KX47  ,KX48  ,
     8                KX49  ,KX50
      COMMON A(1)
      EQUIVALENCE (A(1),IA(1))
      EQUIVALENCE (A(1),DA(1))
C
      DATA DRMAST/8HMASTERCP/,DRSTIF/8HSTIFNESS/,
     1     DRITER/8HITERATON/,DRPRIN/8HPRINTOUT/,
     2     DRNODE/8HNODESAVE/,DRELMT/8HELMTSAVE/,
     3     DREQUA/8HEQUATONS/,DRNODC/8HNODECORD/,DRIDAR/8HID-ARRAY/,
     4     DRRSDC/8HRSDCOS  /,DRNSYS/8HNODESYST/,DRNMID/8HNODEMIDS/,
     5     DRNFMI/8HNODEFMID/,DRSUBS/8HSUBSTRUC/,DRICON/8HICONARAY/
      DATA DRINOR/8HINORMALS/,DRRNOR/8HRNORMALS/
      DATA DRTYP/8HTYPE-1  ,8HTYPE-2  ,8HTYPE-3  ,8HTYPE-4  ,
     1           8HTYPE-5  ,8HTYPE-6  ,8HTYPE-7  /
      DATA DREOF/8HEND FILE/,DRANY/8HANY REC /,DRTYPX/8HTYPE-X  /
      DATA MXNODA/4,8,21,3,5,3,32,0,0,0,8,21,0,0,0/
      DATA ITRUSS,I2DIM,I3DIM,IBEAM,ISOBEA,IPLATE,ISHELL/1,2,3,4,5,6,7/
      DATA I2DIMF,I3DIMF/11,12/
      DATA NTABSA/0,9,16,0,0,7,16/
C
      REWIND LUNODE
      MXEL = 0
      MXELNP = 0
      MXITAB = 0
      MXIDER = 0
      MXERES = 0
      IEGIT = 0
      IEGAT = 0
      ISTRI = 1
      ISTRUC = 1
      NRUSE  = 1
      NMID   = NMIDSS
      ND1 = N1 / ITWO
C
C          'MASTERCP'
C
      CALL PHNCHK (DRMAST)
C
C          'STIFNESS',  'ITERATON',  'PRINTOUT'
C
      IF (NSREFB.NE.0)  CALL PHNCHK (DRSTIF)
      IF (NEQITB.NE.0)  CALL PHNCHK (DRITER)
      IF (NPRIB .NE.0)  CALL PHNCHK (DRPRIN)
C
C          'NODESAVE',  'ELMTSAVE'
C
      IF (NODSVB.NE.0)  CALL PHNCHK (DRNODE)
      IF (LEMSVB.NE.0)  CALL PHNCHK (DRELMT)
C
      IF (IERROR.NE.0) GOTO 900
C
C          'RSDCOS  '
C
      IF (NSKEWS.EQ.0) GOTO 90
      LREAL = 9 * NSKEWS
      I2 = I1 + LREAL * ISURL * ITWO
      CALL SIZE (I2)
        IF (IERROR.NE.0) GOTO 900
      ND1END = ND1 + LREAL - 1
      DRWANT = DRRSDC
      READ (LUNODE) DRECLB,IDUM,(DA(I),I=ND1,ND1END)
      IF (DRECLB.NE.DRWANT) GOTO 790
      DO 80 I=1,LREAL
  80    A(N1+I-1) = DA(ND1+I-1)
      CALL DBWRIT (A(N1),LREAL,0,KRSDCO,1,0)
        IF (IERROR.NE.0) GOTO 900
C
C          SET NDOFSA ARRAY TO SAVED DEGREES OF FREEDOM
C
   90 NDOF = 0
      DO 95  I=1,6
        NDOFSA(I) = 0
        IF (IDOF(I).EQ.1) GOTO 95
        NDOF = NDOF + 1
        NDOFSA(I) = NDOF
  95    CONTINUE
C
C
C          SAVE STRUCTURE CONTROL VARIABLES
C
  100 NRUSES(ISTRI) = NRUSE
      NEGS  (ISTRI) = NEG
      NUMNPS(ISTRI) = NUMNP
C
C          BLANK COMMON LAYOUT FOR 'EQUATONS', 'NODECORD',
C          'NODESYST', 'NODEMIDS', 'NODEFMID'
C
C                                                XYZ, TMIDS
      I2 = I1 + NUMNP * 3 * ISURL * ITWO + 1
C                                                ID
      LINT = NUMNP * NDOF
      I3 = I2 + LINT
C                                                NRST
      I4 = I3 + NUMNP
C                                                MIDS
      I5 = I4 + NUMNP
      CALL SIZE (I5)
        IF (IERROR.NE.0) GOTO 900
      DO 110 I=I2,I5
  110   IA(I) = 0
C
C          'EQUATONS'
C
      IEND = I3 - 1
      DRWANT = DREQUA
      READ (LUNODE) DRECLB,IDUM,IDUM,IDUM,IDUM,IDUM,IDUM,IDUM,
     1              (IA(I),I=I2,IEND),NEQ
      NEQTS(ISTRI) = NEQ
      IF (DRECLB.NE.DREQUA) GOTO 790
C
C          'NODECORD'
C
      LREAL = 3 * NUMNP
      ND1END = ND1 + LREAL - 1
      DRWANT = DRNODC
      READ (LUNODE) DRECLB,IDUM,(DA(I),I=ND1,ND1END)
      IF (DRECLB.NE.DRNODC) GOTO 790
      DO 190 I=1,LREAL
  190   A(N1+I-1) = DA(ND1+I-1)
      CALL DBWRIT (A(N1),LREAL,0,KXYZ,ISTRUC,0)
      IF (IERROR.NE.0) GOTO 900
C
C          'NODESYST'
C
      IF (NSKEWS.GT.0 .OR. NMID.GT.0) LINT = LINT + NUMNP + NUMNP
      IF (NSKEWS.EQ.0) GOTO 200
      IEND = I4 - 1
      DRWANT = DRNSYS
      READ (LUNODE) DRECLB,IDUM,(IA(I),I=I3,IEND)
      IF (DRECLB.NE.DRNSYS) GOTO 790
C
C          'NODEMIDS'
C
  200 IF (NMID.EQ.0) GOTO 210
C
      IEND = I4+NUMNP-1
      DRWANT = DRNMID
      READ (LUNODE) DRECLB,IDUM,(IA(I),I=I4,IEND)
      IF (DRECLB.NE.DRNMID) GOTO 790
C
C          'NODEFMID'
C
  210 IF (NMID.EQ.0) GOTO 230
      DRWANT = DRNFMI
      READ (LUNODE) DRECLB,MAXMSI
      IF (DRECLB.NE.DRNFMI) GOTO 790
      IF (MAXMSI.EQ.0) GOTO 225
      BACKSPACE LUNODE
      LREAL = 3 * MAXMSI
      ND1END = ND1 + LREAL - 1
      READ (LUNODE) DRECLB,IDUM,(DA(I),I=ND1,ND1END)
      DO 220 I=1,LREAL
  220   A(N1+I-1) = DA(ND1+I-1)
      CALL DBWRIT (A(N1),LREAL,0,KTMIDS,ISTRI,0)
        IF (IERROR.NE.0) GOTO 900
  225 MAXMSS(ISTRI) = MAXMSI
C
C          'ID-ARRAY'
C
  230 IF (NDISCE.EQ.0 .OR.ISTRI.GT.1) GOTO 240
      IEND = I3 - 1
      DRWANT = DRIDAR
      READ (LUNODE) DRECLB,(IA(I),I=I2,IEND)
      IF (DRECLB.NE.DRIDAR) GOTO 790
C
C          WRITE IDRN RECORD TO DATABASE
C
  240 CALL DBWRIT (IA(I2),0,LINT,KIDRN,ISTRI,0)
        IF (IERROR.NE.0) GOTO 900
C
C          ELEMENT 'TYPE-X  '
C
C                                                NPAR
      I2 = I1 + NELPAR * NEG
      CALL SIZE (I2)
      IF (IERROR.NE.0) GOTO 900
      DO 300 I=I1,I2
  300   IA(I) = 0
C
      IF (NEG.EQ.0) GOTO 350
      DO 340 IEG=1,NEG
        IEGIT = IEGIT + 1
        IEGAT = IEGAT + 1
          DRWANT = DRTYPX
          DRECLB = DRANY
          CALL PHECHK (DRECLB)
          DO 305 IDRTYP=1,7
            IF (DRECLB.EQ.DRTYP(IDRTYP)) GOTO 310
  305       CONTINUE
          GOTO 790
  310     BACKSPACE LUELEM
        READ (LUELEM) DRECLB,IEGPH,(NPAR(I,IEG),I=1,20),NSUBPH
        IF (IEGPH.NE.IEG) GOTO 780
        IF (NSUBPH.NE.(ISTRI-1)) GOTO 780
C
      IELTYP = NPAR(1,IEG)
      IF (IELTYP.LT.1 .OR.IELTYP.GT.I3DIMF) GOTO 780
C
      IF (IELTYP.GT.ISHELL .AND. IELTYP.LT.I2DIMF) GOTO 780
      NUME = NPAR (2,IEG)
      IF (MXEL.LT.NUME) MXEL = NUME
      CALL ALIGN (MXEL)
C
      MXNODS = MXNODA(IELTYP)
      NODDIM = MXNODS * NUME
      CALL ALIGN (NODDIM)
      IF (MXELNP.LT.NODDIM) MXELNP = NODDIM
C
C          SET NTABLE = NPAR(13) TO ZERO IF ITABLES ARE PRESENT
C          BUT NOT USED
C
      INDNL = NPAR(3,IEG)
      MODEL = NPAR(15,IEG)
      IF (NPAR(13,IEG).LE.0) GOTO 320
      GOTO (319,312,312,314,320,312,316,780,780,780,319,319)
     1    ,IELTYP
C          2DIM, 3DIM, PLATE
  312 IF (MODEL.LE.2) GOTO 320
      GOTO 319
C          BEAM
  314 IF (INDNL.NE.0) GOTO 320
      GOTO 319
C          SHELL
  316 IF (MODEL.EQ.1) GOTO 320
C          TRUSS, 2DIMF, 3DIMF CANNOT HAVE ITABLES
  319 NPAR(13,IEG) = 0
  320 CONTINUE
C
      NTABLE = NPAR(13,IEG)
      NTABSP = NTABSA(IDRTYP)
      IF (IELTYP.EQ.IBEAM) NTABSP = NPAR(14,IEG)
      IF (IELTYP.EQ.ISOBEA) NTABSP = NPAR(14,IEG) + 1
      ITABD = NTABLE * NTABSP
      IF (MXITAB.LT.ITABD) MXITAB = ITABD
      CALL ALIGN (MXITAB)
C
C          BLANK COMMON LAYOUT FOR ELEMENT DATA
C
C                                                ITABLE
      I3 = I2 + MXITAB
C                                      NOD
        I4 = I3 + NODDIM
C                                      ETIME
        I5 = I4 + ISURL * NUME
C                                      IPS
        I7 = I5 + NUME
C                                      ITHICK
      I8 = I7 + NUME
      CALL ALIGN(I8)
      NTHDIM = 0
      IF (IELTYP.EQ.ISHELL)
     1  NTHDIM = NPAR(8,IEG) * NPAR(14,IEG)
C                                                THICK
      I9 = I8 + NTHDIM * ISURL
      CALL ALIGN (I9)
C                                                DTHICK
      I10 = I9 + NTHDIM * ISURL * ITWO
C                                                DXYZPH
      I11 = I10 + 392 * 3 * ISURL * ITWO
C                                                XYZ
      I12 = I11 + NUMNP * 3 * ISURL
        CALL SIZE (I12)
        IF (IERROR.NE.0) GOTO 900
        DO 325 I=I2,I8
  325     IA(I) = 0
C
      CALL DBREAD (IA(I11),KXYZ,ISTRUC,0)
      IF (IERROR.NE.0) GOTO 900
C
  330   CALL PHEDAT (IDRTYP,IELTYP,DRECLB,DRWANT,IEGIT,MXNODS,IA(I2),
     1           IA(I3),IA(I4),IA(I5),IA(I7),IA(I8),IA(I9),
     2           NTHDIM,ITABD,NPAR(1,IEG),IEGAT,NRUSE,
     3           IA(I11),IA(I10),IA(I12))
      IF (IERROR.EQ.780) GOTO 780
      IF (IERROR.EQ.790) GOTO 790
        IF (IERROR.NE.0) GOTO 900
  340   CONTINUE
C
      CALL DBWRIT (NPAR,0,NELPAR*NEG,KNPAR,ISTRI,0)
      IF (IERROR.NE.0) GOTO 900
C
C          BYPASS MIDSURFACE NORMAL RECORDS
C
  350 DRECLB = DRANY
      CALL PHNCHK (DRECLB)
      IF (DRECLB.EQ.DRINOR) GOTO 350
      IF (DRECLB.EQ.DRRNOR) GOTO 350
      IF (DRECLB.NE.DREOF) BACKSPACE LUNODE
C
C          SUBSTRUCTURE NODE CONNECTION TO MAIN STRUCTURE
C
      IF (ISTRI.EQ.1) GOTO 390
C
C                                                NPAR
C
C                                                ETIME
      I3 = I2 + MXEL * (ISURL + 2)
C
      N4 = I3 / ISURL
C                         XYZ FOR SUBSTRUCTURE IN LOCAL COORDINATES
      N5 = N4 + NUMNP
      N6 = N5 + NUMNP
      N7 = N6 + NUMNP
C                         XYZ FOR SUBSTRUCTURE IN GLOBAL COORDINATES
      N8 = N7 + NUMNP
      N9 = N8 + NUMNP
      N10 = N9 + NUMNP
C                                                XYZ FOR MAIN STRUCTURE
      N = NUMNPS(1)
      N11 = N10 + N
      N12 = N11 + N
      N13 = N12 + N
C                                                SXYZ
      I14 = (N13 + 3 * MXIDER) * ISURL
C                                                ITABLE
      I15 = I14 + MXITAB
C                                                ICONA
      I16 = I15 + NODRET
      CALL SIZE (I16)
        IF (IERROR.NE.0) GOTO 900
      CALL DBREAD (A(N10),KXYZ,1,0)
        IF (IERROR.NE.0) GOTO 900
      CALL DBREAD (A(N4),KXYZ,ISTRUC,0)
        IF (IERROR.NE.0) GOTO 900
C
C          'ICONARAY'
C
      IEGAT = IEGAT - NEG
      DO 380 IRUSE=1,NRUSE
C
      IF (IRUSE.GT.1)  ISTRUC = ISTRUC + 1
      DRWANT = DRICON
      IF (DRECLB.EQ.DREOF) GOTO 790
      IF (IPHCHK.EQ.0) GOTO 360
        CALL PHNCHK (DRICON)
          IF (IERROR.NE.0) GOTO 900
        BACKSPACE LUNODE
  360 IEND = I16 - 1
      READ (LUNODE) DRECLB,(IA(I),I=I15,IEND)
      IF (DRECLB.NE.DRICON) GOTO 790
      CALL DBWRIT (IA(I15),0,NODRET,KICONA,ISTRUC-1,0)
        IF (IERROR.NE.0) GOTO 900
C
C          TRANSLATE SUBSTRUCTURE XYZ-COORDINATES TO GLOBAL SYSTEM
C          BY EQUALIZING CONNECTION NODE 1
C
      NPMAIN = IA(I15) - 1
      XDIFF = A(N10+NPMAIN) - A(N4+NODCON)
      YDIFF = A(N11+NPMAIN) - A(N5+NODCON)
      ZDIFF = A(N12+NPMAIN) - A(N6+NODCON)
      DO 370 NP=1,NUMNP
      I = NP - 1
        A(N7+I) = A(N4+I) + XDIFF
        A(N8+I) = A(N5+I) + YDIFF
  370   A(N9+I) = A(N6+I) + ZDIFF
C
C          SAVE SUBSTRUCTURE REUSE XYZ GLOBAL COORDINATES
C
      CALL DBWRIT (A(N7),3*NUMNP,0,KXYZ,ISTRUC,0)
        IF (IERROR.NE.0) GOTO 900
C
C          TRANSLATE SUBSTRUCTURE ELEMENT RESULT POINT
C          COORDINATES TO GLOBAL SYSTEM
C
      IEGIT = IEGIT - NEG
      DO 375 IEG=1,NEG
      IEGIT = IEGIT + 1
      IEGAT = IEGAT + 1
      NTABLE = NPAR(13,IEG)
      NUME = NPAR(2,IEG)
      ISEGIT = 0
      I3 = I2 + ISURL * NUME
      CALL ELRES (2,NPAR(1,IEG),IA(I2),IA(I3),IA(I14),
     1  NTABLE,IEGIT,ISEGIT,0.,IA(I16),IA(I16),NERES,NERKI,LOCLAE)
      IF (IERROR.NE.0) GOTO 900
      IF (NERES.EQ.0) GOTO 375
C
C          READ SXYZ IN LOCAL COORDINATE SYSTEM AND
C          WRITE SXYZ IN GLOBAL COORDINATE SYSTEM
C
      CALL DBREAD (A(N13),KSXYZ,IEGAT,0)
      IF (IERROR.NE.0) GOTO 900
      I = N13
      DO 373 IERES=1,NERES
        IF (A(I).EQ.987654E32) GOTO 373
        A(I) = A(I) + XDIFF
        A(I+1) = A(I+1) + YDIFF
        A(I+2) = A(I+2) + ZDIFF
  373   I = I + 3
      CALL DBWRIT (A(N13),NERES*3,0,KSXYZ,IEGAT,0)
      IF (IERROR.NE.0) GOTO 900
  375 CONTINUE
  380 CONTINUE
C
C          INITIAL CONDITIONS FOR SUBSTRUCTURE IN STATIC ANALYSIS
C          ARE NOT AVAILIBLE FROM ADINA PORTHOLE FILE,
C          ZERO RECORDS ARE GENERATED HERE FOR KSTEP=0
C
      IF (JDC.EQ.0 .OR. ISTAT.NE.0) GOTO 390
      LREAL = NDOF * NUMNP
      IEND = N1 + LREAL - 1
      DO 383 I=N1,IEND
  383   A(I) = 0.0
      DO 385 IRUSE=1,NRUSE
        I = ISTRUC - NRUSE + IRUSE
        CALL DBWRIT (A(N1),LREAL,0,KDISP,I,1)
        IF (IERROR.NE.0) GOTO 900
  385   CONTINUE
C
C          'SUBSTRUC'
C
  390 ISTRI = ISTRI + 1
      ISTRUC = ISTRUC + 1
      IF (ISTRI.GT.NSTRI) GOTO 400
      DRWANT = DRSUBS
      IF (DRECLB.EQ.DREOF) GOTO 790
      IF (IPHCHK.EQ.0) GOTO 395
        CALL PHNCHK (DRSUBS)
        IF (IERROR.NE.0) GOTO 900
        BACKSPACE LUNODE
  395 CONTINUE
      READ (LUNODE) DRECLB,NS,NRUSE,NEG,NUMNP,NODCON,NODRET,NMID
      IF (DRECLB.NE.DRSUBS) GOTO 790
      IF (NS.NE.ISTRI-1) GOTO 780
      NODRTS(ISTRI) = NODRET
      GOTO 100
C
C          BLANK COMMON LAYOUT FOR INITIAL DEFORMATION AND
C          SOLUTION READING
C
  400 NEQTS(1) = NEQTS(1) + NDISCE
      MXSTEP = NSTE + 1
      CALL ALIGN(MXSTEP)
C                                                NPAR
      I2 = I1 + MXEG * NELPAR
C                                                TIMEN
      I3 = I2 + MXSTEP * ISURL
C                                                NSTEPN
      I4 = I3 + MXSTEP
C                                                TIMEE
      I5 = I4 + MXSTEP * ISURL
C                                                NSTEPE
      I6 = I5 + MXSTEP
C                                                ID,NRST,MIDS
      I7 = I6 + (NDOF + 2) * MXNP
C                                                ETIME,IPS,ITHICK
      I8 = I7 + MXEL * (ISURL + 2)
C                                                ITABLE
      I9 = I8 + MXITAB
C                                                NERPTS
      I10 = I9 + MXEL
C                                                IDERPT
      I18 = I10 + MXIDER
C                                                RES
      L = MAX0(NFREQ+100,(NDOF*MXNP),MXERES) * ISURL
      I19 = I18 + L
      CALL ALIGN (I19)
C                                                DINPH
      I20 = I19 + L * ITWO
      CALL SIZE (I20)
C
      CALL PHSOLU (NRUSES,NEGS,NUMNPS,NEQTS,MAXMSS,NELPAR,IA(I1),
     1            IA(I2),IA(I3),IA(I4),IA(I5),NDOF,IA(I6),IA(I7),
     2            IA(I8),IA(I9),IA(I10),IA(I18),IA(I19),DRECLB)
      GOTO 900
C
  780 WRITE (NFLOG,2020) DRECLB
      GOTO 800
  790 WRITE (NFLOG,2050) DRWANT,DRECLB
  800 IERROR = 1
  900 CONTINUE
C
C          WRITE DATABASE RECORDS DBCTRL, STRI
C
      CALL DBWRIT (DT,LDBCTR,LDBCTI,KDBCTR,1,0)
      CALL DBWRIT (IA(I06),0,6*NSTRI,KSTRI,1,0)
  990 RETURN
C
 2020 FORMAT (39H ***ERROR: BAD DATA IN PORTHOLE RECORD ,A8)
 2050 FORMAT (50H ***ERROR: PORTHOLE FILE SEQUENCE ERROR - EXPECTED,
     1  10H RECORD = ,A8/45X,15HFOUND RECORD = ,A8)
      END
C***ADD:CDC***
CDECK PHEDAT
C***END:CDC***
      SUBROUTINE PHEDAT (IDRTYP,IELTYP,DRECLB,DRWANT,IEGIT,MXNODS,
     1   ITABLE,NOD,ETIME,IPS,ITHICK,THICK,DTHICK,NTHDIM,ITABD,NPAR,
     2   IEGAT,NRUSE,XYZ,DXYZPH,SXYZ)
C
C          READ ELEMENT DATA FROM PORTHOLE AND LOAD TO DATABASE
C
C***ADD:DPR***
      IMPLICIT REAL*8(D)
      REAL DT
C***END:DPR***
      DIMENSION IA(1),DA(1),NOD(MXNODS,1),ETIME(1)
      DIMENSION IPS(1),ITHICK(1),DRMAT(7),THICK(1),DTHICK(1)
      DIMENSION ITABLE(1),DRTAB(7),NPAR(1),IDUMA(1),DRELE(7)
      DIMENSION DRPOIN(7),XYZ(1),DXYZPH(3,1),SXYZ(3,1)
C
      COMMON /CNTRL/ IBATCH,NBSU,LSTC,LSTF,LSTDB,ISURL,ITWO,LINPAG,LINE
      COMMON /ERROR/ IERROR
      COMMON /FILES/ NFREAD,NFECHO,NFLOG,NFLIST,LUNODE,LUELEM
      COMMON /DB/ IOPEN,NFDB,INDXST,IXTNOW,LGP,NWRITS,NREADS,
     1            LDBC,LDBCTR,LDBCTI,IPHCHK,INSTRI,INRUSE,INSTRU,
     2            MSUBF,MVIEW,MAXIS,MLINEN,MLINEE,MVAR,MRES,LSKEW,MIDSPL
      COMMON /DBC/ IHED(18),NDAREC,LDAREC,NRECS,NWORDS,NEXREC,NEXTIX,
     1             LIX,LIXT,NSTRI,NSTRUC,NEGIT,NEGAT,NFREQ,
     2             IXGP(50),MXSGP(50),
     3             FILL1
      COMMON /DIM/ I01,I02,I03,I04,I05,I06,I07,I08,I09,I010,I011,
     1             I1,I2,I3,I4,I5,I6,I7,I8,I9,I10,I11,I12,I13,I14,I15,
     2             I16,I17,I18,I19,I20,
     3             N1,N2,N3,N4,N5,N6,N7,N8,N9,N10,N11,N12,N13,N14,N15,
     4             N16,N17,N18,N19,N20
      COMMON /DBCTRL/ DT    ,TSTART,NUMNP ,NEQT  ,NSUBST,IDOF(6),
     1                NDOF  ,NEG   ,NMID  ,MODEX ,NSTE  ,NSTEN ,
     2                NSTEE ,NSKEWS,NMIDSS,IEIG  ,NSREFB,NEQITB,
     3                NPRIB ,NODSVB,LEMSVB,JDC   ,JAC   ,JVC   ,
     4                ISTAT ,JTC   ,NDISCE,ITP96 ,MXITAB,MXIDER,MXERES,
     5                NELPAR,MXNP  ,MXEG  ,MXEL  ,MXELNP,
     6                NDOFSA(6),NOUSE(4),FILL2
      COMMON /IGPNAM/ KDBC  ,KSUBGP,KDBCTR,KSTRI ,KRSDCO,KTMIDS,
     1                KXYZ  ,KIDRN ,KICONA,KNZONE,KNPAR ,KTHICK,
     2                KITABL,KNOD  ,KEDATA,KIEZON,KFRQ  ,KPHI  ,
     3                KTIMEN,KDISP ,KVEL  ,KACC  ,KTEMP ,KTIMEE,
     4                KERES ,KSUBF ,KVIEW ,KAXIS ,KNPOIN,KVARES,
     5                KNAMEZ,KEPOIN,KSXYZ ,KX34  ,KX35  ,KX36  ,
     6                KX37  ,KX38  ,KX39  ,KX40  ,KX41  ,KX42  ,
     7                KX43  ,KX44  ,KX45  ,KX46  ,KX47  ,KX48  ,
     8                KX49  ,KX50
      COMMON A(1)
      EQUIVALENCE (A(1),IA(1))
      EQUIVALENCE (A(1),DA(1))
      DATA DRMAT/8HMATERAL1,8HMATERAL2,8HMATERAL3,8HMATERAL4,
     1           8HMATERAL5,8HMATERAL6,8HMATERAL7/
      DATA DRTAB/8HOUTABLE1,8HOUTABLE2,8HOUTABLE3,8HOUTABLE4,
     1           8HOUTABLE5,8HOUTABLE6,8HOUTABLE7/
      DATA DRELE/8HELEMENT1,8HELEMENT2,8HELEMENT3,8HELEMENT4,
     1           8HELEMENT5,8HELEMENT6,8HELEMENT7/
      DATA DRPOIN/8HIPOINT-1,8HIPOINT-2,8HIPOINT-3,8HIPOINT-4,
     1            8HIPOINT-5,8HIPOINT-6,8HIPOINT-7/
      DATA DRANY/8HANY REC /
      DATA DRSEC4/8HSECTION4/,DRTHIC/8HTHICKNES/
      DATA ITRUSS,I2DIM,I3DIM,IBEAM,ISOBEA,IPLATE,ISHELL/1,2,3,4,5,6,7/
      DATA I2DIMF,I3DIMF/11,12/
C
      NUME = NPAR(2)
      NTABLE = NPAR(13)
      INDNL = NPAR(3)
      MODEL = NPAR(15)
C
C          'MATERALX'
C
      DRWANT = DRMAT(IDRTYP)
      NUMMAT = NPAR(16)
  50  CALL PHECHK(DRWANT)
      IF (IERROR.NE.0) GOTO 900
      NUMMAT = NUMMAT - 1
      IF (IELTYP.EQ.IBEAM .AND. INDNL.LE.0 .AND. NUMMAT.GT.0) GOTO 50
C
C          'SECTION4'
C
      IF (IELTYP.EQ.IBEAM) CALL PHECHK (DRSEC4)
      IF (IERROR.NE.0) GOTO 900
C
C          'OUTABLEX'
C
      IF (IELTYP.EQ.ITRUSS) GOTO 100
      DRWANT = DRTAB(IDRTYP)
      IF (NTABLE.LE.0 .OR. IPHCHK.EQ.1) CALL PHECHK (DRWANT)
        IF (IERROR.NE.0) GOTO 900
        IF (NTABLE.LE.0) GOTO 100
        IF (IPHCHK.EQ.1) BACKSPACE LUELEM
      READ (LUELEM) DRECLB,NTABS,(ITABLE(I),I=1,ITABD)
      IF (DRECLB.NE.DRWANT) GOTO 790
      IF (NTABS.NE.NTABLE) GOTO 780
      CALL DBWRIT (ITABLE,0,ITABD,KITABL,IEGIT,0)
      IF (IERROR.NE.0) GOTO 900
C
C
C          'THICKNES'
C
  100 IF (IELTYP.NE.ISHELL) GOTO 200
      DRWANT = DRTHIC
      IF (NTHDIM.EQ.0 .OR. IPHCHK.EQ.1) CALL PHECHK (DRWANT)
        IF (IERROR.NE.0) GOTO 900
        IF (NTHDIM.EQ.0) GOTO 200
        IF (IPHCHK.EQ.1) BACKSPACE LUELEM
      READ (LUELEM) DRECLB,NTHICK,MXMNOD,(DTHICK(I),I=1,NTHDIM)
      IF (DRECLB.NE.DRWANT) GOTO 790
      DO 110 I=1,NTHDIM
  110   THICK(I) = DTHICK(I)
      CALL DBWRIT (THICK,NTHDIM,0,KTHICK,IEGIT,0)
      IF (IERROR.NE.0) GOTO 900
C
C          'ELEMENTX'
C
  200 MXNPT = 0
      DO 520 IEL=1,NUME
C
      DRWANT = DRELE(IDRTYP)
      IF (IPHCHK.EQ.0) GOTO 300
        CALL PHECHK (DRWANT)
        IF (IERROR.NE.0) GOTO 900
        BACKSPACE LUELEM
C
  300 GOTO (310,320,330,340,350,360,370,780,780,780,410,420)
     1     ,IELTYP
C
  310 READ (LUELEM) DRECLB,IDUM,IELDPH,IPSPH,IDUM,IDUM,
     1                DDUM,DETIME,(NOD(I,IEL),I=1,IELDPH)
      GOTO 500
  320 READ (LUELEM) DRECLB,IDUM,IELDPH,IPSPH,IDUM,
     1               DDUM,DDUM,DETIME,IDUM,(NOD(I,IEL),I=1,8)
      GOTO 500
  330 READ (LUELEM) DRECLB,IDUM,IELDPH,IDUM,IPSPH,IDUM,
     1         IDUM,IDUM,DETIME,IDUM,IELN,(NOD(I,IEL),I=1,IELN)
      GOTO 500
  340 READ (LUELEM) DRECLB,IDUM,(NOD(I,IEL),I=1,3),IDUM,IPSPH
     1              ,DETIME
      GOTO 500
  350 READ (LUELEM) DRECLB,IDUM,IELDPH,IPSPH,IDUM,
C    1         DETIME,IDUM,NOD(5,IEL),(NOD(I,IEL),I=1,4)
     1         DETIME,IDUM,NOD(5,IEL),(NOD(I,IEL),I=1,IELDPH)
      GOTO 500
  360 READ (LUELEM) DRECLB,IDUM,IPSPH,IDUM,
     1         DDUM,DETIME,IDUM,(NOD(I,IEL),I=1,3)
      GOTO 500
  370 READ (LUELEM) DRECLB,IDUM,IELDPH,IPSPH,ITHICK(IEL),
     1   IDUM,IDUM,IDUM,DETIME,IDUM,IELN,(NOD(I,IEL),I=1,IELN)
      GOTO 500
  410 READ (LUELEM) DRECLB,IDUM,IELDPH,IPSPH,IDUM,
     1             DETIME,IDUM,(NOD(I,IEL),I=1,8)
      GOTO 500
  420 READ (LUELEM) DRECLB,IDUM,IELDPH,IDUM,IPSPH,IDUM,
     1         IDUM,DETIME,IDUM,IELN,(NOD(I,IEL),I=1,IELN)
      GOTO 500
C
  500 IF (DRECLB.NE.DRWANT) GOTO 790
      ETIME(IEL) = DETIME
      IPS  (IEL) = IPSPH
C
C          'IPOINT-X'
C
      IF (IELTYP.EQ.ITRUSS .AND. NPAR(5).EQ.1) GOTO 520
      IF (IELTYP.EQ.IBEAM .AND. NPAR(3).LE.0) GOTO 520
      DRWANT = DRPOIN(IDRTYP)
      IF (IPHCHK.EQ.0) GOTO 510
        CALL PHECHK (DRWANT)
        IF (IERROR.NE.0) GOTO 900
        BACKSPACE LUELEM
  510 READ (LUELEM) DRECLB, NPTPH
      IF (DRECLB.NE.DRWANT) GOTO 790
      IF (MXNPT.LT.NPTPH) MXNPT = NPTPH
      IF (NPTPH.LT.1 .OR. NPTPH.GT.392) GOTO 780
  520 CONTINUE
C
C          WRITE ELEMENT NODS AND DATA TO DATABASE
C
      CALL DBWRIT (NOD,0,MXNODS*NUME,KNOD,IEGIT,0)
      IF (IERROR.NE.0) GOTO 900
      CALL DBWRIT (ETIME,NUME,2*NUME,KEDATA,IEGIT,0)
      IF (IERROR.NE.0) GOTO 900
C
C          UPDATE MXIDER, MXERES
C
      CALL ELRES (2,NPAR,ETIME,IPS,ITABLE,NTABLE,
     1         IEGIT,IEGIT,0.,IDUMA,IDUMA,NERES,NERKI,LOCALE)
      IF (IERROR.NE.0) GOTO 900
      CALL ALIGN (MXIDER)
      CALL ALIGN (MXERES)
C
C
CCCCCCCCCC      READ 'IPOINT-X' AND LOAD SXYZ
C
C
      IF (NERES.EQ.0) GOTO 900
C
C          BACKSPACE TO FIRST 'ELEMENTX' RECORD FOR THIS EG
C
      J = NUME
      IF (MXNPT.GT.0) J = J + NUME
      DO 530 I=1,J
        BACKSPACE LUELEM
  530   CONTINUE
C
C                                                SXYZ
      I13 = I12 + NERES * 3 * ISURL
C                                                NERPTS
      I14 = I13 + NUME
C                                                IDERPT
      I15 = I14 + NERES
C
      CALL SIZE (I15)
      IF (IERROR.NE.0) GOTO 900
C
      DO 540 I=1,NERES
      DO 540 J=1,3
  540   SXYZ(J,I) = 987654E32
C
      CALL ELRES (1,NPAR,ETIME,IPS,ITABLE,NTABLE,
     1  IEGIT,IEGIT,0.,IA(I13),IA(I14),NERES,NERKI,LOCALE)
      IF (IERROR.NE.0) GOTO 900
C
      IXIDER = 1
C
      DO 700 IEL=1,NUME
      NERPT = IA(I13+IEL-1)
C
C          BYPASS 'ELEMENTX'
C
      DRWANT = DRELE(IDRTYP)
      CALL PHECHK (DRWANT)
      IF (IERROR.NE.0) GOTO 900
C
C          'IPOINT-X'
C
      DRWANT = DRPOIN(IDRTYP)
      DRECLB = DRWANT
      IF (MXNPT.GT.0)
     1  READ (LUELEM) DRECLB,NPTPH,((DXYZPH(L,I),L=1,3),I=1,NPTPH)
      IF (DRECLB.NE.DRWANT) GOTO 790
      IF (NERPT.EQ.0) GOTO 700
C
      GOTO (550,560,560,570,580,560,560,780,780,780,560,560)
     1  ,IELTYP
C
C          TRUSS - RING ELEMENT: ONE NODE POINT
C                  2-NODE ELEMENT: ALL INTEGRATION POINTS
C
  550 IF (NPAR(5).NE.1) GOTO 600
      GOTO 680
C
C          2DIM,3DIM,PLATE,SHELL,2DIMF,3DIMF:
C            NTABLE.GT.0 - STRESS OUTPUT TABLE NUMBERS
C            NTABLE.LE.0 - INTEGRATION POINTS (SOME OR ALL)
C
  560 IF (NTABLE.GT.0 ) GOTO 690
      GOTO 600
C
C          BEAM: AT INTEGRATION POINTS (ALL OR SELECTED BY ITABLE)
C                OR AT 2 NODE POINTS
C
  570 IF (INDNL.EQ.0 .OR. NTABLE.LT.0) GOTO 680
      GOTO 630
C
C          ISOBEAM: AT INTEGRATION POINTS (ALL OR SELECTED BY ITABLE)
C                   OR AT 2-4 NODE POINTS
C
  580 IF (NTABLE.LT.0) GOTO 680
      GOTO 630
C
C          INTEGRATION POINTS ARE NUMBERED FROM 1 AND UP
C          'IPOINT-X' CONTAINS COORDINATES FOR ALL INTEGRATION POINTS
C          PORTHOLE ELEMENT RESULTS ARE FOR ALL OR SOME OF THE POINTS
C
  600 DO 620 IERPT=1,NERPT
        IDERES = IABS(IA(I14+IXIDER-1))
        IF (IDERES.GT.NPTPH) GOTO 780
        DO 610 I=1,3
  610     SXYZ(I,IXIDER) = DXYZPH(I,IDERES)
  620   IXIDER = IXIDER + 1
      GOTO 700
C
C          INTEGRATION POINTS FOR BEAM AND ISOBEAM ARE DEFINED BY
C          A 3-DIGIT NUMBER
C          'IPOINT' CONTAINS COORDINATES FOR ALL INTEGRATION POINTS
C          PORTHOLE ELEMENT RESULTS ARE FOR ALL OR SOME OF THE POINTS
C          IN THE SAME OR A DIFFERENT SEQUENCE
C
  630 INTX = NPAR(9)
      INTY = NPAR(10)
      INTZ = NPAR(11)
      DO 670 IERPT=1,NERPT
        IDERES = IABS(IA(I14+IXIDER-1))
        IPT = 0
        DO 640 I=1,INTX
        DO 640 J=1,INTY
        DO 640 K=1,INTZ
          IPT = IPT + 1
          IF (IPT.GT.NPTPH) GOTO 780
          IDERWK = I*100 + J*10 + K
          IF (IDERES.EQ.IDERWK) GOTO 650
  640     CONTINUE
        GOTO 780
  650   DO 660 I=1,3
  660     SXYZ(I,IXIDER) = DXYZPH(I,IPT)
  670   IXIDER = IXIDER + 1
      GOTO 700
C
C          ELEMENT NODAL POINT NUMBERS
C
  680 DO 685 IERPT=1,NERPT
        INOD = NOD(IERPT,IEL)
        DO 682 I=1,3
          J = INOD + (I - 1) * NUMNP
          IF (INOD.GT.0) SXYZ(I,IXIDER) = XYZ(J)
  682     CONTINUE
  685   IXIDER = IXIDER + 1
      GOTO 700
C
C          STRESS OUTPUT TABLE NUMBERS AND NOT INTEGRATION POINT NUMBERS
C          COORDINATES ARE NOT CALCULATED
C
  690 IXIDER = IXIDER + NERPT
C
  700 CONTINUE
C
C          WRITE SXYZ, FOR SUBSTRUCTURE TO ALL REUSE IDS
C
      DO 710 IRUSE=1,NRUSE
        I = IEGAT + (IRUSE - 1) * NEG
        CALL DBWRIT (SXYZ,3*NERES,0,KSXYZ,I,0)
        IF (IERROR.NE.0) GOTO 900
  710   CONTINUE
C
C
      GOTO 900
C
  780 IERROR = 780
      GOTO 900
  790 IERROR = 790
  900 RETURN
      END
C***ADD:CDC***
CDECK PHSOLU
C***END:CDC***
      SUBROUTINE PHSOLU (NRUSES,NEGS,NUMNPS,NEQTS,MAXMSS,NPARD,NPAR,
     1                  TIMEN,NSTEPN,TIMEE,NSTEPE,NDOFD,ID,ETIME,
     2                  ITABLE,NERPTS,IDERPT,RES,DINPH,DRECLB)
C
C          READ RESULT FROM PORTHOLE FILE AND LOAD DATABASE
C
C
C***ADD:DPR***
      IMPLICIT REAL*8(D)
      REAL DT
C***END:DPR***
      DIMENSION IA(1),DA(1),NRUSES(1),NEGS(1),NUMNPS(1),NEQTS(1),
     1          MAXMSS(1),NPAR(NPARD,1),TIMEN(1),NSTEPN(1),TIMEE(1),
     2          NSTEPE(1),ID(NDOFD,1),ETIME(1),RES(1),DINPH(1),
     3          NPARPH(20),DRNEW(7),DROUT(7),ITABLE(1),NERPTS(1),
     4          IDERPT(1)
C
      COMMON /ERROR/ IERROR
      COMMON /CNTRL/ IBATCH,NBSU,LSTC,LSTF,LSTDB,ISURL,ITWO,LINPAG,LINE
      COMMON /FILES/ NFREAD,NFECHO,NFLOG,NFLIST,LUNODE,LUELEM
      COMMON /DB/ IOPEN,NFDB,INDXST,IXTNOW,LGP,NWRITS,NREADS,
     1            LDBC,LDBCTR,LDBCTI,IPHCHK,INSTRI,INRUSE,INSTRU,
     2            MSUBF,MVIEW,MAXIS,MLINEN,MLINEE,MVAR,MRES,LSKEW,MIDSPL
      COMMON /DBC/ IHED(18),NDAREC,LDAREC,NRECS,NWORDS,NEXREC,NEXTIX,
     1             LIX,LIXT,NSTRI,NSTRUC,NEGIT,NEGAT,NFREQ,
     2             IXGP(50),MXSGP(50),
     3             FILL1
      COMMON /DIM/ I01,I02,I03,I04,I05,I06,I07,I08,I09,I010,I011,
     1             I1,I2,I3,I4,I5,I6,I7,I8,I9,I10,I11,I12,I13,I14,I15,
     2             I16,I17,I18,I19,I20,
     3             N1,N2,N3,N4,N5,N6,N7,N8,N9,N10,N11,N12,N13,N14,N15,
     4             N16,N17,N18,N19,N20
      COMMON /DBCTRL/ DT    ,TSTART,NUMNP ,NEQT  ,NSUBST,IDOF(6),
     1                NDOF  ,NEG   ,NMID  ,MODEX ,NSTE  ,NSTEN ,
     2                NSTEE ,NSKEWS,NMIDSS,IEIG  ,NSREFB,NEQITB,
     3                NPRIB ,NODSVB,LEMSVB,JDC   ,JAC   ,JVC   ,
     4                ISTAT ,JTC   ,NDISCE,ITP96 ,MXITAB,MXIDER,MXERES,
     5                NELPAR,MXNP  ,MXEG  ,MXEL  ,MXELNP,
     6                NDOFSA(6),NOUSE(4),FILL2
      COMMON /IGPNAM/ KDBC  ,KSUBGP,KDBCTR,KSTRI ,KRSDCO,KTMIDS,
     1                KXYZ  ,KIDRN ,KICONA,KNZONE,KNPAR ,KTHICK,
     2                KITABL,KNOD  ,KEDATA,KIEZON,KFRQ  ,KPHI  ,
     3                KTIMEN,KDISP ,KVEL  ,KACC  ,KTEMP ,KTIMEE,
     4                KERES ,KSUBF ,KVIEW ,KAXIS ,KNPOIN,KVARES,
     5                KNAMEZ,KEPOIN,KSXYZ ,KX34  ,KX35  ,KX36  ,
     6                KX37  ,KX38  ,KX39  ,KX40  ,KX41  ,KX42  ,
     7                KX43  ,KX44  ,KX45  ,KX46  ,KX47  ,KX48  ,
     8                KX49  ,KX50
      COMMON A(1)
      EQUIVALENCE (A(1),IA(1))
      EQUIVALENCE (A(1),DA(1))
C
      DATA DRFREQ/8HFREQENCY/,DREIGN/8HEIGNVCTR/,DRNEWS/8HNEW STEP/
      DATA DRDISP/8HDISP-XYZ/,DRVELO/8HVELOCITY/,DRACCL/8HACCLERTN/
      DATA DRTEMP/8HTEMPERAT/,DRNEWN/8HNEWNORMS/
      DATA DRNEW/8HNEWSTEP1,8HNEWSTEP2,8HNEWSTEP3,8HNEWSTEP4,
     1           8HNEWSTEP5,8HNEWSTEP6,8HNEWSTEP7/
      DATA DROUT/8HOUTPUT-1,8HOUTPUT-2,8HOUTPUT-3,8HOUTPUT-4,
     1           8HOUTPUT-5,8HOUTPUT-6,8HOUTPUT-7/
      DATA DRMAST/8HMASTERCP/
C
      DATA DREOF/8HEND FILE/,DRANY/8HANY REC /,DRTYPX/8HTYPE-X  /
      DATA ITRUSS,I2DIM,I3DIM,IBEAM,ISOBEA,IPLATE,ISHELL/1,2,3,4,5,6,7/
      DATA I2DIMF,I3DIMF/11,12/
C
C          SOLUTION AND INITIAL DEFORMATION READING
C
      WRITE (NFLOG,2065)
      NOTOK = 0
      NSTEN = 0
      NSTEE = 0
      IIDRN = 0
      IIEDAT = 0
      IINPAR = 0
      ISUBFN = 0
C
C
C          READ NEXT NEWSTEP, FREQUENCE, TEMPERATURE RECORD
C
      LU = LUNODE
      IF (DRECLB.EQ.DREOF) GOTO 410
  400 DRECLB = DRANY
      IF (LU.EQ.LUNODE) CALL PHNCHK (DRECLB)
      IF (LU.NE.LUNODE) CALL PHECHK (DRECLB)
        IF (IERROR.NE.0) GOTO 900
      IF (DRECLB.EQ.DREOF) GOTO 410
      IF (DRECLB.EQ.DRMAST) GOTO 410
      IF (DRECLB.EQ.DRNEWN) GOTO 400
      IF (DRECLB.EQ.DREIGN) GOTO 400
      BACKSPACE LU
C
C
      IF (DRECLB.EQ.DRFREQ) GOTO 450
      IF (DRECLB.EQ.DRNEWS) GOTO 500
      IF (DRECLB.EQ.DRTEMP) GOTO 580
      DO 407 IDRTYP=1,7
        IF (DRECLB.EQ.DRNEW(IDRTYP)) GOTO 600
  407   CONTINUE
        WRITE (NFLOG,2000) DRECLB
        GOTO 419
  410 IF (LU.EQ.LUELEM) GOTO 420
        LU = LUELEM
        GOTO 400
C
C          END OF FILE CHECK THAT RESULTS ARE COMPLETE TIMESTEPS,
C          WRITE TIMESTEP RECORDS TO DATABASE
C
  419 NOTOK = 1
      IERROR = 0
  420 KSTEP = 999999
      IF (NSTEN.EQ.0) GOTO 435
      IF (NOTOK.EQ.1) GOTO 425
      IF (ISTAT.EQ.0 .AND. NSTEN.EQ.1) GOTO 425
      IF (ISTRUN.NE.NSTRUC .OR. ISTEN.NE.NSTEN) GOTO 505
  425 WRITE (NFLOG,2070) TIMEN(1)
      I = NSTEN - 1
      IF (I.GT.0) WRITE (NFLOG,2071) I,TIMEN(2),TIMEN(NSTEN)
      J = I2 + NSTEN * ISURL
      DO 430 I=1,NSTEN
  430   IA(J+I-1) = NSTEPN(I)
      CALL DBWRIT (TIMEN,NSTEN,NSTEN,KTIMEN,1,0)
      IF (IERROR.NE.0) GOTO 900
C
  435 IF (NSTEE.EQ.0) GOTO 445
      IF (NOTOK.EQ.1) GOTO 437
      IF (ISTEE.NE.NSTEE) GOTO 605
      IF (IEGCHK.NE.NEGS(NSTRI) .OR. IRUSEE.NE.NRUSES(NSTRI)) GOTO 605
  437 WRITE (NFLOG,2080) NSTEE,TIMEE(1),TIMEE(NSTEE)
      J = I4 + NSTEE * ISURL
      DO 440 I=1,NSTEE
  440   IA(J+I-1) = NSTEPE(I)
      CALL DBWRIT (TIMEE,NSTEE,NSTEE,KTIMEE,1,0)
  445 IF (NOTOK.EQ.1) WRITE (NFLOG,2090)
      GOTO 900
C
C
CCCCCCCCC  'FREQENCY'
C
  450 READ (LUNODE) DRECLB,IDUM,IDUM,IDUM,(DINPH(I),I=1,NFREQ)
C
      DO 460 IFREQ=1,NFREQ
  460   RES(IFREQ) = DINPH(IFREQ)
      CALL DBWRIT (RES,NFREQ,0,KFRQ,1,0)
        IF (IERROR.NE.0) GOTO 900
      IF (IIDRN.EQ.1) GOTO 465
        CALL DBREAD (ID,KIDRN,1,0)
          IF (IERROR.NE.0) GOTO 900
        IIDRN = 1
C
C          'EIGNVCTR'
C
  465 NUMNP = NUMNPS(1)
      NEQT   = NEQTS(1)
      DO 470 IFREQ=1,NFREQ
        CALL PHEQR (DREIGN,KPHI,IFREQ,0,NDOF,ID,RES,DINPH)
          IF (IERROR.NE.0) GOTO 900
  470   CONTINUE
      GOTO 400
C
C
CCCCCCCCC  NODAL SOLUTION OUTPUT
C          'NEW STEP'
C
  500 READ (LUNODE) DRECLB,KSTEP,DTIME,I,I,I,I,I,I,I,I,NSUBPH
      TIME = DTIME
C
C          PROCEDURE FOR NEW NODAL TIMESTEP - MAIN STRUCTURE
C
      IF (NSUBPH.GT.0) GOTO 502
        NSTEN = NSTEN + 1
        ISTEN = NSTEN
        TIMEN (NSTEN) = TIME
        NSTEPN(NSTEN) = KSTEP
        ISTRIN = 1
        IRUSEN = 1
        ISTRUN = 1
        ISUBFN = 0
        GOTO 530
C
C          CHECK FOR NEW SUBSTRUCTURE TIMESTEP
C
  502 IF (ISUBFN.EQ.1) GOTO 504
        ISUBFN = 1
        ISTEN = 1
        IF (KSTEP.GT.0) GOTO 510
          ISTEN = 1
          NSTEPN(ISTEN) = 0
          GOTO 511
  504 IF (KSTEP.EQ.NSTEPN(ISTEN)) GOTO 520
        IF (ISTRUN.EQ.NSTRUC) GOTO 510
  505     WRITE (NFLOG,2010) NSTEPN(ISTEN),ISTRUN,NSTRUC,KSTEP
     1                       ,ISTRIN,NSUBPH,DRECLB
          GOTO 419
  510 IF (ISTEN.GE.NSTEN) GOTO 505
      ISTEN = ISTEN + 1
  511 ISTRIN = 2
      IRUSEN = 0
      ISTRUN = 1
C
C          INCREMENT NODAL SUBSTRUCTURE AND REUSE IDENTIFICATION
C
  520 ISTRUN = ISTRUN + 1
      IRUSEN = IRUSEN + 1
      IF (IRUSEN.LE.NRUSES(ISTRIN)) GOTO 530
        ISTRIN = ISTRIN + 1
        IRUSEN = 1
C
  530 NUMNP = NUMNPS(ISTRIN)
      NEQT  = NEQTS(ISTRIN)
      IF (NSUBPH.NE.ISTRIN-1) GOTO 505
C
C          READ IDRN IF NOT ALREADY THERE
C
      IF (IIDRN.EQ.ISTRIN) GOTO 540
        CALL DBREAD (ID,KIDRN,ISTRIN,0)
        IF (IERROR.NE.0) GOTO 900
      IIDRN = ISTRIN
C
C          'DISP-XYZ'
C
  540 IF (JDC.EQ.0) GOTO 550
      CALL PHEQR (DRDISP,KDISP,ISTRUN,ISTEN,NDOF,ID,RES,DINPH)
      IF (IERROR.NE.0) GOTO 900
C
C          'VELOCITY'
C
  550 IF (ISTAT.EQ.0) GOTO 570
      IF (JVC.EQ.0) GOTO 560
      CALL PHEQR (DRVELO,KVEL,ISTRUN,ISTEN,NDOF,ID,RES,DINPH)
      IF (IERROR.NE.0) GOTO 900
C
C          'ACCLERTN'
C
  560 IF (JAC.EQ.0) GOTO 570
      CALL PHEQR (DRACCL,KACC,ISTRUN,ISTEN,NDOF,ID,RES,DINPH)
      IF (IERROR.NE.0) GOTO 900
  570 GOTO 400
C
C
C          'TEMPERAT'   ONLY FOR MAIN STRUCTURE
C                     COMES AFTER ELEMENT SOLUTION IN SEQUENCE
C
  580 READ (LUNODE) DRECLB,(DINPH(I),I=1,NUMNP)
      DO 590 NP=1,NUMNP
  590   RES(NP) = DINPH(NP)
      CALL DBWRIT (RES,NUMNP,0,KTEMP,1,ISTEN)
        IF (IERROR.NE.0) GOTO 900
      GOTO 400
C
C
CCCCCC     ELEMENT SOLUTION READING
C
  600 READ (LUELEM) DRECLB,IEGPH,(NPARPH(I),I=1,20),
     1              KSTEP,DTIME,NEGLPH,NSUBPH
      TIME = DTIME
C
C          PROCEDURE FOR NEW ELEMENT TIMESTEP - MAIN STRUCTURE
C
      IF (NSUBPH.GT.0) GOTO 603
      IF (NSTEE.EQ.0) GOTO 601
      IF (KSTEP.EQ.NSTEPE(NSTEE)) GOTO 602
  601   NSTEE = NSTEE + 1
        ISTEE = NSTEE
        TIMEE (NSTEE) = TIME
        NSTEPE(NSTEE) = KSTEP
        ISTRIE = 1
        IRUSEE = 1
        ISTRUE = 1
        IEGITE = 0
        IEGATE = 0
        ISUBFE = 0
        IEGCHK = 0
  602 IEGCHK = IEGCHK + 1
      GOTO 630
C
C          CHECK FOR NEW TIMESTEP FOR SUBSTRUCTURE
C
  603 IF (ISUBFE.EQ.1) GOTO 604
        ISUBFE = 1
        ISTEE = 0
        GOTO 610
  604 IF (KSTEP.EQ.NSTEPE(ISTEE)) GOTO 620
      IF (IEGCHK.EQ.NEGS(NSTRI) .AND. IRUSEE.EQ.NRUSES(NSTRI)) GOTO 610
  605     WRITE (NFLOG,2015) NSTEPE(ISTEE),NRUSES(NSTRI),IRUSEE,KSTEP
     1          ,ISTRIE,NSUBPH,NEGS(NSTRI),IEGCHK,IEGPH,DRECLB
          GOTO 419
  610   IF (ISTEE.GE.NSTEE) GOTO 605
        ISTEE = ISTEE + 1
        ISTRIE = 2
        IRUSEE = 1
        ISTRUE = 1
        IEGITE = NEGS(1)
        IEGATE = IEGITE
        IEGCHK = 0
C
C          INCREMENT ELEMENT SUBSTRUCTURE AND REUSE IDENTIFICATION
C
  620 IEGCHK = IEGCHK + 1
      NEG = NEGS(ISTRIE)
      IF (IEGCHK.LE.NEG) GOTO 630
C
      ISTRUE = ISTRUE + 1
      IRUSEE = IRUSEE + 1
      IEGATE = IEGATE + NEG
      IEGCHK = 1
      IF (IRUSEE.LE.NRUSES(ISTRIE)) GOTO 630
C
      IEGITE = IEGITE + NEG
      ISTRIE = ISTRIE + 1
      IRUSEE = 1
C
  630 IF (IEGPH.NE.IEGCHK) GOTO 605
      IF (NSUBPH.NE.ISTRIE-1) GOTO 605
C
C          READ NPAR IF NOT ALREADY THERE
C
      IF (IINPAR.NE.ISTRIE)
     1    CALL DBREAD (NPAR,KNPAR,ISTRIE,0)
          IF (IERROR.NE.0) GOTO 900
          IINPAR = ISTRIE
C
C          PORTHOLE ELEMENT GROUP NUMBERS DIFFER IN ADINA INPUT/
C          AND ADINA RESULT PRINTING IF UNLINEAR EL GROUP COMES BEFORE
C          LINEAR ELEMENT GROUP IN INPUT, RESULT HAS ALWAYS LINEAR
C          GROUPS BEFORE NONLINEAR
C          THROUGHOUT ADINA-PLOT THE ELEMENT GROUP NUMBER OF ADINA INPUT
C          IS USED TO IDENTIFY ELEMENT GROUPS
C
C          FIND INPUT ELEMENT GROUP NUMBER OF THIS RESULT
C
      IEGW = 0
      NEG = NEGS(ISTRIE)
      DO 633 IEG=1,NEG
        INDNL = NPAR(3,IEG)
        IF (INDNL.NE.0) GOTO 633
        IEGW = IEGW + 1
        IF (IEGW.EQ.IEGPH) GOTO 637
  633   CONTINUE
      DO 635 IEG=1,NEG
        INDNL = NPAR(3,IEG)
        IF (INDNL.EQ.0) GOTO 635
        IEGW = IEGW + 1
        IF (IEGW.EQ.IEGPH) GOTO 637
  635   CONTINUE
  637 IEGIT = IEGITE + IEG
      IEGAT = IEGATE + IEG
C
      IELTYP = NPAR(1,IEG)
      NUME = NPAR(2,IEG)
      NTABLE = NPAR(13,IEG)
C
C          UPDATE NERPTS, IDERPT ARRAYS AND NERES, NERKI
C
      CALL ELRES (1,NPAR(1,IEG),ETIME,ETIME(NUME+1),ITABLE,
     1 NTABLE,IEGIT,IIEDAT,TIME,NERPTS,IDERPT,NERES,NERKI,LOCALE)
      IF (IERROR.NE.0) GOTO 900
      IF (NERES.EQ.0) GOTO 720
      DO 639 I=1,MXERES
  639   RES(I) = 987654E32
C
C          READ ELEMENT RESULTS
C          FOR ALL ELEMENTS AND POINTS AVAILIBLE IN PORTHOLE
C          AS INDICATED IN ARRAYS NERPTS AND IDERPT
C
      DRWANT = DROUT(IDRTYP)
      IXIDER = 0
      IXERES = -NERKI
C
      DO 710 IEL=1,NUME
C
      NERPT = NERPTS(IEL)
      IF (NERPT.EQ.0) GOTO 710
C
      DO 700 IERPT=1,NERPT
C
      IXIDER = IXIDER + 1
      IXERES = IXERES + NERKI
      IDERES = IDERPT(IXIDER)
      IF (IDERES.LT.0) GOTO 700
C
C          'OUTPUT-X'
C
      IELPH = IEL
      IDERPH = IDERES
      IF (IELTYP.EQ.IBEAM) GOTO 645
      IF (IELTYP.EQ.ISOBEA) GOTO 660
C
      IF (IPHCHK.EQ.0) GOTO 640
        CALL PHECHK (DRWANT)
        IF (IERROR.NE.0) GOTO 605
        BACKSPACE LUELEM
  640 READ (LUELEM) DRECLB,IDERPH,(DINPH(I),I=1,NERKI)
      GOTO 670
C
C          BEAM
C
  645 ND = NERPT * NERKI
      IF (INDNL.EQ.0 .OR. NTABLE.LT.0) GOTO 662
  655 IF (IPHCHK.EQ.0) GOTO 656
        CALL PHECHK (DRWANT)
        IF (IERROR.NE.0) GOTO 605
        BACKSPACE LUELEM
  656 READ (LUELEM) DRECLB,IELPH,IR,IS,IT,(DINPH(I),I=1,NERKI)
      IDERPH = IR*100 + IS*10 + IT
      GOTO 670
C
C          ISOBEAM
C
  660 IF (NTABLE.GE.0) GOTO 655
C          NUMBER OF RESULT NODES ARE 2 - 4 IN SAME RECORD
  662 IF (IERPT.GT.1) GOTO 700
      IF (IPHCHK.EQ.0) GOTO 667
        CALL PHECHK (DRWANT)
        IF (IERROR.NE.0) GOTO 605
        BACKSPACE LUELEM
  667 IF (IELTYP.EQ.IBEAM) READ (LUELEM) DRECLB,IELPH,(DINPH(I),I=1,ND)
      IF (IELTYP.EQ.ISOBEA)
     1  READ (LUELEM) DRECLB,IELPH,ND,(DINPH(I),I=1,ND)
      IF (DRECLB.NE.DRWANT) GOTO 790
      IF (IEL.NE.IELPH) GOTO 670
      DO 668 I=1,ND
  668   RES(IXERES+I) = DINPH(I)
      GOTO 700
C
C          CHECK PORTHOLE RECORD
C
  670 IF (DRECLB.NE.DRWANT) GOTO 790
      IF (IELPH.EQ.IEL .AND. IDERPH.EQ.IDERES) GOTO 675
        WRITE (NFLOG,2060) IELPH,IDERPH,IEL,IDERES
        GOTO 605
  675 DO 680 I=1,NERKI
  680   RES(IXERES+I) = DINPH(I)
C
  700 CONTINUE
  710 CONTINUE
C
C          WRITE ERES TO DATABASE
C
      CALL DBWRIT (RES,NERES*NERKI,0,KERES,IEGAT,ISTEE)
        IF (IERROR.NE.0) GOTO 900
  720 GOTO 400
C
  790 WRITE (NFLOG,2050) DRWANT,DRECLB
      GOTO 605
  900 RETURN
C
 2000 FORMAT (42H ***ERROR: PORTHOLE FILE SEQUENCE ERROR - ,
     1        42HEXPECTING SOLUTION RECORD, FOUND RECORD = ,A8)
 2010 FORMAT (47H ***ERROR: NODAL RESULTS PORTHOLE READING CHECK ,
     1 13H, TIMESTEP = ,I4/11X,25HLAST STRUCTURE (REUSED) =,I4,
     2 35H, TOTAL NR OF STRUCTURES (REUSED) =,I4,16H, NEW TIMESTEP =,I4/
     3 11X,16HLAST STRUCTURE =,I4,29H, PORTHOLE RECORD STRUCTURE =,I4/
     4 11X,18HPORTHOLE RECORD = ,A8)
 2015 FORMAT (48H ***ERROR: ELEMENT RESULT PORTHOLE READING CHECK ,
     1 13H, TIMESTEP = ,I4/11X,21HEND STRUCTURE REUSE =,I4,
     2 23H LAST STRUCTURE REUSE =,I4 ,
     3 16H, NEW TIMESTEP =,I4/11X,16HLAST STRUCTURE =,I4,
     4 29H, PORTHOLE RECORD SUBSTRUC. =,I4,
     4 31H, END STRUCTURE ELEMENT GROUP =,I4/
     5 11X,24HELEMENT GROUP EXPECTED =,I4,
     6 33H, PORTHOLE RECORD ELEMENT GROUP =,I4/
     7 11X,18HPORTHOLE RECORD = ,A8)
 2020 FORMAT (41H ***ERROR: BAD DATA IN PORTHOLE RECORD = ,A8)
 2050 FORMAT (50H ***ERROR: PORTHOLE FILE SEQUENCE ERROR - EXPECTED,
     1  10H RECORD = ,A8/45X,15HFOUND RECORD = ,A8)
 2060 FORMAT(50H ***ERROR: UNEXPECTED ELEMENT RESULT ID, ELEMENT =,I5,
     1 8H POINT =,I4,20H, EXPECTED ELEMENT =,I5,8H POINT =,I4)
 2065 FORMAT(4X,31HLOADED:  NODAL AND ELEMENT DATA)
 2070 FORMAT(4X,42HLOADED:  NODAL INITIAL CONDITIONS AT TIME=,G12.5)
 2071 FORMAT(4X,34HLOADED:  NODAL   RESULT TIMESTEPS=,I5,
     1  12H  FROM TIME=,G12.5,10H  TO TIME=,G12.5)
 2080 FORMAT(4X,34HLOADED:  ELEMENT RESULT TIMESTEPS=,I5,
     1  12H  FROM TIME=,G12.5,10H  TO TIME=,G12.5)
 2090 FORMAT(/48H ***WARNING:  PROBLEM MAY ARISE WHEN PROCESSING ,
     1  51HADINA-PLOT COMMANDS WITH THE LAST TIMESTEP INCLUDED/)
      END
C***ADD:CDC***
CDECK PHEQR
C***END:CDC***
      SUBROUTINE PHEQR (DRWANT,IGP,ISGP,ITIME,NDOFD,ID,RESN,DINPH)
C
C
C          READ ONE NODAL RESULT RECORD AND LOAD TO DATABASE
C***ADD:DPR***
      IMPLICIT REAL*8(D)
      REAL DT
C***END:DPR***
      DIMENSION ID(NDOFD,1),RESN(NDOFD,1),DINPH(1)
      COMMON /FILES/ NFREAD,NFECHO,NFLOG,NFLIST,LUNODE,LUELEM
      COMMON /ERROR/ IERROR
      COMMON /DB/ IOPEN,NFDB,INDXST,IXTNOW,LGP,NWRITS,NREADS,
     1            LDBC,LDBCTR,LDBCTI,IPHCHK,INSTRI,INRUSE,INSTRU,
     2            MSUBF,MVIEW,MAXIS,MLINEN,MLINEE,MVAR,MRES,LSKEW,MIDSPL
      COMMON /DBCTRL/ DT    ,TSTART,NUMNP ,NEQT  ,NSUBST,IDOF(6),
     1                NDOF  ,NEG   ,NMID  ,MODEX ,NSTE  ,NSTEN ,
     2                NSTEE ,NSKEWS,NMIDSS,IEIG  ,NSREFB,NEQITB,
     3                NPRIB ,NODSVB,LEMSVB,JDC   ,JAC   ,JVC   ,
     4                ISTAT ,JTC   ,NDISCE,ITP96 ,MXITAB,MXIDER,MXERES,
     5                NELPAR,MXNP  ,MXEG  ,MXEL  ,MXELNP,
     6                NDOFSA(6),NOUSE(4),FILL2
C
C          READ NODAL RESULT ARRAY FROM PORTHOLE
C
      IF (IPHCHK.EQ.0) GOTO 100
        CALL PHNCHK (DRWANT)
        IF (IERROR.NE.0) GOTO 900
        BACKSPACE LUNODE
  100 IF (ITIME.EQ.0) GOTO 110
      READ (LUNODE) DRECLB,NEQTI,(DINPH(I),I=1,NEQT)
      IF (NEQTI.NE.NEQT) GOTO 700
      GOTO 120
  110 READ (LUNODE) DRECLB,(DINPH(I),I=1,NEQT)
  120 IF (DRECLB.NE.DRWANT) GOTO 700
C
C          CONVERT RESULT ARRAY FROM EQUATION NUMBER ORDER
C          TO NDOF-NODALPOINT ORDER
C
      DO 200 NP=1,NUMNP
        DO 200 INDOF = 1,NDOFD
          IEQ = ID (INDOF,NP)
          RESULT = 0.
          IF (IEQ.GT.0) RESULT = DINPH(IEQ)
          IF (IEQ.GE.0) GOTO 150
            NEQ = NEQT - NDISCE
            RESULT = DINPH(NEQ-IEQ)
  150     RESN(INDOF,NP) = RESULT
  200     CONTINUE
C
C          WRITE TO DATABASE
C
      CALL DBWRIT (RESN,NUMNP*NDOF,0,IGP,ISGP,ITIME)
      GOTO 900
C
  700 WRITE (NFLOG,2000) DRECLB
  800 IERROR = 1
  900 RETURN
 2000 FORMAT (45H ***ERROR: PORTHOLE FILE BAD DATA - RECORD = ,A8)
      END
C*NEW FILE
C***END:IBM***
      SUBROUTINE CGRAPH(IFLAG)
C
C        CONTROLS GRAPHICAL OUTPUT
C
C        IFLAG=1   INITIALIZATION OF A PLOT
C                  FILE NFPLOT OPENED AS PLOT FILE
C
C        IFLAG=2   DEFINITION OF NEW ORIGIN
C                  AT 0,0 OF PLOT SURFACE, -3 INDICATES PEN IS UP
C
C        IFLAG=3   TERMINATION OF PLOT
C
C        IFLAG=4   SWITCH TO TERMINAL
C
C
C        IFLAG=5   SWITCH TO PLOTTER
C
      COMMON /PLOTCO/ GSCALE,DSCALE,XPV,YPV,PUNIT,HEIGHT,PMARG,AXEDGE,
     1              XSF,YSF,XFMAX,YFMAX,XF1,YF1,XPMAX,YPMAX,
     3              XSMIN,XSMAX,YSMIN,YSMAX,XPSAVE,YPSAVE,VIEW(3,3),
     2              NFPLOT,IONPLT,NSYSPL,NDEVPL,MORIGO,NGPTS
      COMMON /FILES/ NFREAD,NFECHO,NFLOG,NFLIST,LUNODE,LUELEM
C
C
      GOTO(100,200,300,400,500),IFLAG
C
  100 IF(IONPLT.EQ.1) GOTO 900
      CALL PLOTS(0,0,NFPLOT)
      IONPLT=1
C***ADD:CDC***
C*         PLOT 10 SUPPORT
C     IF (NSYSPL.EQ.1) CALL PLINIT(NDEVPL)
C***END:CDC***
      GOTO 900
C
  200 CALL PLOT (0.0,0.0,-3)
      GOTO 900
C
  300 IF(IONPLT.EQ.0) GOTO 900
      CALL PLOT(0.,0.,999)
      IONPLT=0
      GOTO 900
C
  400 IF(IONPLT.EQ.0) GOTO 900
C
C          PLOT 10 SUPPORT
C
      IF (NSYSPL.NE.1) GOTO 410
      CALL PLOFF
      CALL TSEND
C***ADD:CDC***
C     CALL ANMODE
C     CALL ZZZP10X
C     IIN = 5LINPUT
C     REWIND IIN
C***END:CDC***
      GOTO 900
C
C
  410 GOTO 900
C
  500 IF(IONPLT.EQ.0) GOTO 900
C
C          PLOT 10 SUPPORT
C
      IF (NSYSPL.NE.1) GOTO 510
C***ADD:CDC***
C     IOUT = 6LOUTPUT
C     ENDFILE IOUT
C***END:CDC***
      CALL PLON
      CALL TSEND
      GOTO 900
C
C
  510 GOTO 900
C
  900 RETURN
      END
C***ADD:CDC***
CDECK AGRAPH
C***END:CDC***
      SUBROUTINE AGRAPH(X,Y,H,NBCD,FPN,ANGLE,IND,IFLAG)
C
C        PLOTS ALPHANUMERIC AND SPECIAL CHARACTERS AND DECIMAL
C        EQUIVALENTS
C
C        X AND Y ARE COORDINATES OF THE LOWER LEFT HAND CORNER
C                OF THE CHARACTER IN THE PLOTTING SUBFRAME
C                COORDINATE SYSTEM. IF X AND/OR Y EQUAL 999.0
C                THEN CONTINUATION FROM THE POSITION WHERE
C                THE LAST ANNOTATION ENDED.
C
C        H       IS THE HEIGHT OF THE CHARACTER
C
C        NBCD    IS THE ALPHANUMERIC CHARACTER STORED USING 1H-FORMAT
C                OR THE INTEGER EQUIVALENT TO THE DESIRED SYMBOL
C
C        FPN     IS THE FLOATING POINT NUMBER TO BE CONVERTED AND
C                PLOTTED
C
C        IFLAG=1:  PLOTS IND ALPHANUMERIC CHARACTERS
C
C        IFLAG=2:  PLOTS ONE SPECIAL SYMBOL
C                  IND.EQ.-1 PEN IS UP DURING MOVE TO X/Y
C                         -2 PEN IS DOWN DURING MOVE TO X/Y
C
C        IFLAG=3   PLOTS DECIMAL EQUIVALENT
C                  IND.GT.0  SPECIFIES THE NO OF DIGITS TO THE RIGHT OF
C                            DECIMAL POINT TO BE PLOTTED
C                     .EQ.0  ONLY INTEGER PORTION PLOTTED
C                     .EQ.-1 ONLY INTEGER PORTION PLOTTED AFTER
C                            ROUNDING
C                     .LT.-1 IABS(IND)-1 DIGITS ARE TRUNCATED FROM THE
C                            INTEGER PORTION AFTER ROUNDING
C
      DIMENSION IBCD(1)
C
      COMMON /PLOTCO/ GSCALE,DSCALE,XPV,YPV,PUNIT,HEIGHT,PMARG,AXEDGE,
     1              XSF,YSF,XFMAX,YFMAX,XF1,YF1,XPMAX,YPMAX,
     3              XSMIN,XSMAX,YSMIN,YSMAX,XPSAVE,YPSAVE,VIEW(3,3),
     2              NFPLOT,IONPLT,NSYSPL,NDEVPL,MORIGO,NGPTS
C
C          CHECK THAT DATA STARTS WITHIN SUBFRAME
C
      IF (X.NE.999.0) XPSAVE = X
      IF (Y.NE.999.0) YPSAVE = Y
      IF (XPSAVE.GT.XPMAX .OR. YPSAVE.GT.YPMAX) GOTO 900
      IF (XPSAVE.LT.0.0 .OR. YPSAVE.LT.0.0) GOTO 900
C
C          ROTATE IF ORIGIN IS TO BE UPPER LEFT CORNER OF SUBFRAME
C
      XS = X
      YS = Y
      ANG = ANGLE
      IF (MORIGO.EQ.0) GOTO 50
      XS = Y
      YS = XPMAX - X
      IF (X.EQ.999.0) YS = 999.0
      ANG = ANG - 90.0
C
C          COMPUTE PLOT SURFACE COORDINATES
C
  50  IF (XS.NE.999.0) XS = (XSF + XF1 + XS)
      IF (YS.NE.999.0) YS = (YSF + YF1 + YS)
      IF (Y.EQ.999.0) YS = Y
C
      GOTO(100,200,300),IFLAG
C
  100 IBCD(1) = NBCD
      CALL SYMBOL(XS,YS,H,IBCD,ANG,IND)
      GOTO 900
C
C
  200 IBCD(1)=NBCD
      CALL SYMBOL(XS,YS,H,IBCD,ANG,IND)
      GOTO 900
C
  300 CALL NUMBER(XS,YS,H,FPN,ANG,IND)
C
  900 RETURN
      END
C***ADD:CDC***
CDECK LGRAPH
C***END:CDC***
      SUBROUTINE LGRAPH(X,Y,IND)
C
C         MOVES PEN TO NEW POSITION
C
C         X AND Y ARE COORDINATES IN THE PLOTTING SUBFRAME COORDINATE
C         SYSTEM
C
C         IND = 2   PEN DOWN
C             = 3   PEN UP
C
C         XS AND YS ARE REAL PLOTTING SURFACE COORDINATES
C
      COMMON /PLOTCO/ GSCALE,DSCALE,XPV,YPV,PUNIT,HEIGHT,PMARG,AXEDGE,
     1              XSF,YSF,XFMAX,YFMAX,XF1,YF1,XPMAX,YPMAX,
     3              XSMIN,XSMAX,YSMIN,YSMAX,XPSAVE,YPSAVE,VIEW(3,3),
     2              NFPLOT,IONPLT,NSYSPL,NDEVPL,MORIGO,NGPTS
C
C
C          ROTATE IF ORIGIN IS TO BE UPPER LEFT CORNER OF SUBFRAME
C
      XS = X
      YS = Y
      IF (MORIGO.EQ.0) GOTO 100
      XS = Y
      YS = XPMAX - X
C
  100  XS = (XSF + XF1 + XS)
      YS = (YSF + YF1 + YS)
C
      CALL PLOT(XS,YS,IND)
C
      RETURN
      END
C***ADD:CDC***
CDECK LCLIP
C***END:CDC***
      SUBROUTINE LCLIP (X,Y,IND)
C
C          DRAW A LINE OR MOVE PEN TO NEW POSITION
C          AND CLIP LINE AT SUBFRAME LIMITS
C
C          X AND Y ARE SUBFRAME COORDINATES
C
C          IND = 2  PEN DOWN
C              = 3  PEN UP
C              = 4  DASHED LINE
C
      COMMON /PLOTCO/ GSCALE,DSCALE,XPV,YPV,PUNIT,HEIGHT,PMARG,AXEDGE,
     1              XSF,YSF,XFMAX,YFMAX,XF1,YF1,XPMAX,YPMAX,
     3              XSMIN,XSMAX,YSMIN,YSMAX,XPSAVE,YPSAVE,VIEW(3,3),
     2              NFPLOT,IONPLT,NSYSPL,NDEVPL,MORIGO,NGPTS
      COMMON /EPS/ EPS
C
      DATA IDOWN,IUP,IDASH/2,3,4/
C
C
      X1 = XPSAVE
      Y1 = YPSAVE
      XPSAVE = X
      YPSAVE = Y
      X2 = X
      Y2 = Y
      ICLIP = 0
C
C          CHECK IF LINE IS NOW ENTIRELY OUTSIDE SUBFRAME
C
  100 IF (X1.LT.0.0   .AND. X2.LT.0.0  ) GOTO 900
      IF (Y1.LT.0.0   .AND. Y2.LT.0.0  ) GOTO 900
      IF (X1.GT.XPMAX .AND. X2.GT.XPMAX) GOTO 900
      IF (Y1.GT.YPMAX .AND. Y2.GT.YPMAX) GOTO 900
C
C          CHECK IF ANY LINE ENDPOINT IS OUTSIDE OF ANY LIMIT,
C          IF SO MOVE ENDPOINT TO SUBFRAME LIMIT
C
      XDIFF = X2 - X1
      YDIFF = Y2 - Y1
      IF (ABS(XDIFF).LT.EPS) XDIFF = EPS
      IF (ABS(YDIFF).LT.EPS) YDIFF = EPS
C
      IF (X1.GE.0.0) GOTO 110
        Y1 = Y1 - YDIFF * X1 / XDIFF
        X1 = 0.0
        GOTO 135
C
  110 IF (X1.LE.XPMAX) GOTO 120
        Y1 = Y1 + YDIFF * (XPMAX - X1) / XDIFF
        X1 = XPMAX
        GOTO 135
C
  120 IF (Y1.GE.0.0) GOTO 130
        X1 = X1 - XDIFF * Y1 / YDIFF
        Y1 = 0.0
        GOTO 135
C
  130 IF (Y1.LE.YPMAX) GOTO 140
        X1 = X1 + XDIFF * (YPMAX - Y1) / YDIFF
        Y1 = YPMAX
  135   ICLIP = 1
        GOTO 100
C
C
C
  140 IF (X2.GE.0.0) GOTO 150
        Y2 = Y1 - YDIFF * X1 / XDIFF
        X2 = 0.0
        GOTO 100
C
  150 IF (X2.LE.XPMAX) GOTO 160
        Y2 = Y1 + YDIFF * (XPMAX - X1) / XDIFF
        X2 = XPMAX
        GOTO 100
C
  160 IF (Y2.GE.0.0) GOTO 170
        X2 = X1 - XDIFF * Y1 / YDIFF
        Y2 = 0.0
        GOTO 100
C
  170 IF (Y2.LE.YPMAX) GOTO 200
        X2 = X1 + XDIFF * (YPMAX - Y1) / YDIFF
        Y2 = YPMAX
        GOTO 100
C
C
  200 INDPEN = IND
      IF (INDPEN.EQ.IUP) GOTO 700
C
C          IF FIRST PART OF LINE IS TO BE CLIPPED,
C          MOVE PEN TO SUBFRAME LIMIT
C
      IF (ICLIP.EQ.1)  CALL LGRAPH (X1,Y1,IUP)
C
C          DASHED LINE
C
      IF (IND.NE.IDASH) GOTO 700
      INDPEN = IDOWN
      X1 = X1 + XDIFF * 0.25
      Y1 = Y1 + YDIFF * 0.25
      CALL LGRAPH (X1,Y1,IDOWN)
      X1 = X1 + XDIFF * 0.5
      Y1 = Y1 + YDIFF * 0.5
      CALL LGRAPH (X1,Y1,IUP)
C
C          PLOT OR MOVE TO NEW X,Y POSITION
C
  700 CALL LGRAPH (X2,Y2,INDPEN)
C
  900 RETURN
      END
C***ADD:CDC***
CDECK XYPLOT
C***END:CDC***
      SUBROUTINE XYPLOT (XARRAY,YARRAY,NPTS,NXAXIS,NYAXIS,ISYMBL,ISSKIP)
C
      DIMENSION XARRAY(1),YARRAY(1)
      DIMENSION AXREC(250),XPA(1),YPA(1),XL(1),VMIN(1),VMAX(1)
      DIMENSION NAMEAX(20,1)
C
      COMMON /FILES/ NFREAD,NFECHO,NFLOG,NFLIST,LUNODE,LUELEM
      COMMON /PLOTCO/ GSCALE,DSCALE,XPV,YPV,PUNIT,HEIGHT,PMARG,AXEDGE,
     1              XSF,YSF,XFMAX,YFMAX,XF1,YF1,XPMAX,YPMAX,
     3              XSMIN,XSMAX,YSMIN,YSMAX,XPSAVE,YPSAVE,VIEW(3,3),
     2              NFPLOT,IONPLT,NSYSPL,NDEVPL,MORIGO,NGPTS
      COMMON /ERROR/ IERROR
      COMMON /DB/ IOPEN,NFDB,INDXST,IXTNOW,LGP,NWRITS,NREADS,
     1            LDBC,LDBCTR,LDBCTI,IPHCHK,INSTRI,INRUSE,INSTRU,
     2            MSUBF,MVIEW,MAXIS,MLINEN,MLINEE,MVAR,MRES,LSKEW,MIDSPL
      COMMON /DBC/ IHED(18),NDAREC,LDAREC,NRECS,NWORDS,NEXREC,NEXTIX,
     1             LIX,LIXT,NSTRI,NSTRUC,NEGIT,NEGAT,NFREQ,
     2             IXGP(50),MXSGP(50),
     3             FILL1
      COMMON /IGPNAM/ KDBC  ,KSUBGP,KDBCTR,KSTRI ,KRSDCO,KTMIDS,
     1                KXYZ  ,KIDRN ,KICONA,KNZONE,KNPAR ,KTHICK,
     2                KITABL,KNOD  ,KEDATA,KIEZON,KFRQ  ,KPHI  ,
     3                KTIMEN,KDISP ,KVEL  ,KACC  ,KTEMP ,KTIMEE,
     4                KERES ,KSUBF ,KVIEW ,KAXIS ,KNPOIN,KVARES,
     5                KNAMEZ,KEPOIN,KSXYZ ,KX34  ,KX35  ,KX36  ,
     6                KX37  ,KX38  ,KX39  ,KX40  ,KX41  ,KX42  ,
     7                KX43  ,KX44  ,KX45  ,KX46  ,KX47  ,KX48  ,
     8                KX49  ,KX50
C
      EQUIVALENCE (AXREC(1),XPA(1)),
     1           (AXREC(11),YPA(1)),
     1           (AXREC(21),XL(1)),
     1           (AXREC(31),VMIN(1)),
     1           (AXREC(41),VMAX(1)),
     1           (AXREC(51),NAMEAX(1,1))
C
      DATA IUP,IDOWN/3,2/
      DATA XTEXT,YTEXT/1H ,1H /
      DATA IPLOFF,IPLON/4,5/
C
C
C          CHECK PARAMETERS NXAXIS, NYAXIS, ISYMBL, ISSKIP
C
      NXAX = IABS(NXAXIS)
      NYAX = IABS(NYAXIS)
      IF (NXAX.GT.MAXIS .OR. NYAX.GT.MAXIS) GOTO 850
      IF (NXAX.EQ.0 .AND. NYAX.EQ.0) GOTO 110
C
C          READ AXIS RECORD FROM DATABASE
C
      DO 50 I=1,MAXIS
  50    XL(I) = 0.0
      IF (IXGP(KAXIS).NE.0)
     1  CALL DBREAD (AXREC,KAXIS,1,0)
        IF (IERROR.NE.0) GOTO 900
      IF (NXAX.GT.0 .AND. XL(NXAX).EQ.0.0) GOTO 100
      IF (NYAX.EQ.0 .OR.  XL(NYAX).NE.0.0) GOTO 110
  100   WRITE (NFLOG,2000)
        GOTO 800
  110 IF (ISYMBL.LT.0) GOTO 850
      IF (ISSKIP.LT.0) GOTO 850
C
C          AUTOMATIC SCALING OF X-AXIS
C
      CALL CGRAPH (IPLON)
      IF (NXAX.GT.0) GOTO 210
      XX = PMARG + AXEDGE
      YX = XX
      AXLEN = XPMAX - XX - PMARG
      IF (AXLEN.LT.1.00) GOTO 750
        CALL SCALE (XARRAY,AXLEN,NPTS,1)
        FIRSTX = XARRAY(NPTS+1)
        DELTAX = XARRAY(NPTS+2)
        GOTO 230
C
C          USER SCALING OF X-AXIS
C
  210 XX = XPA(NXAX)
      YX = YPA(NXAX)
      AXLEN = XL(NXAX)
      IF (AXLEN.LT.1.00) GOTO 750
      FIRSTX = VMIN(NXAX)
      DELTAX = (VMAX(NXAX) - FIRSTX) / AINT(AXLEN)
      XP = XX
      YP = YX - AXEDGE
      IF (NXAXIS.LE.0) GOTO 230
      DO 220 I=1,20
        NBCD = NAMEAX(I,NXAX)
        CALL APCHAR(NBCD)
        CALL AGRAPH (XP,YP,HEIGHT,NBCD,0.,0.,1,1)
        XP = 999.0
        YP = 999.0
  220   CONTINUE
C
C          PLOT X-AXIS
C
  230 IF (DELTAX.NE.0.0) GOTO 235
  232   CALL CGRAPH (IPLOFF)
        WRITE (NFLOG,2010)
        GOTO 800
  235 XS = (XSF + XF1 + XX)
      YS = (YSF + YF1 + YX)
      ANGLE = 0.0
      IF (MORIGO.EQ.0) GOTO 237
        XS = XSF + XF1 + YX
        YS = YSF + YF1 + XPMAX - XX
        ANGLE = -90.0
  237 IF (NXAXIS.LT.0) GOTO 240
        CALL AXIS (XS,YS,XTEXT,-1,AXLEN,ANGLE,FIRSTX,DELTAX)
  240 CONTINUE
C
C          AUTOMATIC SCALING OF Y-AXIS
C
      IF (NYAX.GT.0) GOTO 310
      XY = PMARG + AXEDGE
      YY = XY
      AXLEN = YPMAX - YY - PMARG
      IF (AXLEN.LT.1.00) GOTO 750
        CALL SCALE (YARRAY,AXLEN,NPTS,1)
        FIRSTY = YARRAY(NPTS+1)
        DELTAY = YARRAY(NPTS+2)
        GOTO 330
C
C          USER SCALING OF Y-AXIS
C
  310 XY = XPA(NYAX)
      YY = YPA(NYAX)
      AXLEN = XL(NYAX)
      IF (AXLEN.LT.1.00) GOTO 750
      FIRSTY = VMIN(NYAX)
      DELTAY = (VMAX(NYAX) - FIRSTY) / AINT(AXLEN)
      XP = XY - AXEDGE + HEIGHT
      YP = YY
      IF (NYAXIS.LE.0) GOTO 330
      DO 320 I=1,20
        NBCD = NAMEAX(I,NYAX)
        CALL APCHAR(NBCD)
        CALL AGRAPH(XP,YP,HEIGHT,NBCD,0.,90.,1,1)
        XP = 999.0
        YP = 999.0
  320   CONTINUE
C
C          PLOT Y-AXIS
C
  330 IF (DELTAY.EQ.0.0) GOTO 232
      XS = (XSF + XF1 + XY)
      YS = (YSF + YF1 + YY)
      ANGLE = 90.0
      IF (MORIGO.EQ.0) GOTO 340
        XS = XSF + XF1 + YY
        YS = YSF + YF1 + XPMAX - XY
        ANGLE = 0.0
  340 IF (NYAXIS.GE.0) CALL AXIS (XS,YS,YTEXT,1,AXLEN,ANGLE,FIRSTY
     1                         ,DELTAY)
C
C          PLOT LINE
C
      XX = XX - FIRSTX / DELTAX
      YY = YY - FIRSTY / DELTAY
      INDPEN = IUP
      INDCNT = -1
C
      DO 590 I=1,NPTS
        XPLINE = (XARRAY(I) / DELTAX + XX)
        YPLINE = (YARRAY(I) / DELTAY + YY)
        CALL LCLIP (XPLINE,YPLINE,INDPEN)
        INDPEN = IDOWN
C
C          PLOT SPECIAL SYMBOL   IF REQUESTED
C
        IF (ISYMBL.EQ.0) GOTO 590
        IF (INDCNT.GE.0) GOTO 560
          CALL AGRAPH (XPLINE,YPLINE,HEIGHT,ISYMBL,0.0,0.0,-1,2)
          INDCNT = ISSKIP
  560   INDCNT = INDCNT - 1
  590   CONTINUE
      GOTO 900
C
  750 CALL CGRAPH (IPLOFF)
      WRITE (NFLOG,2750) AXLEN
  800 IERROR = 1
      GOTO 900
  850 IERROR = 2
  900 RETURN
 2000 FORMAT (39H ***ERROR: NXAXIS OR NYAXIS NOT DEFINED)
 2010 FORMAT(38H ***ERROR: DV FOR X- OR Y-AXIS IS ZERO)
 2750 FORMAT(36H ***ERROR: AXIS LENGTH TOO SMALL, = ,F5.2)
      END
C***ADD:CDC***
CDECK SUBF
C***END:CDC***
      SUBROUTINE SUBF (IXCALL)
C
C          UPDATE CURRENT SUBFRAME (XF1,XPMAX,YF1,YPMAX)
C          IF CALLED FROM MAIN ADPLOT (IXINTV=0) FOR COMMAND SUBF
C          ...UPDATE DATABASE A
C
      DIMENSION IA(1)
      COMMON /CNTRL/ IBATCH,NBSU,LSTC,LSTF,LSTDB,ISURL,ITWO,LINPAG,LINE
      COMMON /EPS/ EPS
      COMMON /FILES/ NFREAD,NFECHO,NFLOG,NFLIST,LUNODE,LUELEM
      COMMON /PARAM/ REALV(100),NCMD,NLASTP,ITYPE(20),INTV(100),
     1               IANUMV(8,20),LGHSTR,INTEG,IREAL,IANUM,ISTRIN,IOMIT
      COMMON /ERROR/ IERROR
      COMMON /DB/ IOPEN,NFDB,INDXST,IXTNOW,LGP,NWRITS,NREADS,
     1            LDBC,LDBCTR,LDBCTI,IPHCHK,INSTRI,INRUSE,INSTRU,
     2            MSUBF,MVIEW,MAXIS,MLINEN,MLINEE,MVAR,MRES,LSKEW,MIDSPL
      COMMON /DBC/ IHED(18),NDAREC,LDAREC,NRECS,NWORDS,NEXREC,NEXTIX,
     1             LIX,LIXT,NSTRI,NSTRUC,NEGIT,NEGAT,NFREQ,
     2             IXGP(50),MXSGP(50),
     3             FILL1
      COMMON /DIM/ I01,I02,I03,I04,I05,I06,I07,I08,I09,I010,I011,
     1             I1,I2,I3,I4,I5,I6,I7,I8,I9,I10,I11,I12,I13,I14,I15,
     2             I16,I17,I18,I19,I20,
     3             N1,N2,N3,N4,N5,N6,N7,N8,N9,N10,N11,N12,N13,N14,N15,
     4             N16,N17,N18,N19,N20
      COMMON /IGPNAM/ KDBC  ,KSUBGP,KDBCTR,KSTRI ,KRSDCO,KTMIDS,
     1                KXYZ  ,KIDRN ,KICONA,KNZONE,KNPAR ,KTHICK,
     2                KITABL,KNOD  ,KEDATA,KIEZON,KFRQ  ,KPHI  ,
     3                KTIMEN,KDISP ,KVEL  ,KACC  ,KTEMP ,KTIMEE,
     4                KERES ,KSUBF ,KVIEW ,KAXIS ,KNPOIN,KVARES,
     5                KNAMEZ,KEPOIN,KSXYZ ,KX34  ,KX35  ,KX36  ,
     6                KX37  ,KX38  ,KX39  ,KX40  ,KX41  ,KX42  ,
     7                KX43  ,KX44  ,KX45  ,KX46  ,KX47  ,KX48  ,
     8                KX49  ,KX50
      COMMON /PLOTCO/ GSCALE,DSCALE,XPV,YPV,PUNIT,HEIGHT,PMARG,AXEDGE,
     1              XSF,YSF,XFMAX,YFMAX,XF1,YF1,XPMAX,YPMAX,
     3              XSMIN,XSMAX,YSMIN,YSMAX,XPSAVE,YPSAVE,VIEW(3,3),
     2              NFPLOT,IONPLT,NSYSPL,NDEVPL,MORIGO,NGPTS
      COMMON A(1)
      EQUIVALENCE (A(1),IA(1))
C
      DATA ICOMND,ISUBR/1,0/
C
      IXINTV = IXCALL
      ICALL = ISUBR
      IF (IXINTV.NE.0) GOTO 10
        ICALL = ICOMND
        IXINTV = 1
  10  NSUBF = INTV(IXINTV)
      IF (ITYPE(IXINTV).EQ.IOMIT) GOTO 900
C
C          SUBFRAME MAY BE NSUBF=XXYY - AN EQUALSIZE SPLIT PART OF FRAME
C
C          DIGIT 1 = XPARTS = X-DIRECTION EQUAL-SIZE PARTS
C          DIGIT 2 = XSELEC = SELECTED X-DIRECTION PART
C          DIGIT 3 = YPARTS = Y-DIRECTION EQUAL-SIZE PARTS
C          DIGIT 4 = YSELEC = SELECTED Y-DIRECTION PART
C
      IF (NSUBF.EQ.0) NSUBF = 1111
      IF (NSUBF.LT.1111 .OR. NSUBF.GT.9999) GOTO 15
      XPARTS = FLOAT( MOD(NSUBF/1000,10))
      XSELEC = FLOAT( MOD(NSUBF/100,10))
      YPARTS = FLOAT( MOD(NSUBF/10,10))
      YSELEC = FLOAT( MOD(NSUBF,10))
C
      IF (XPARTS.LT.EPS .OR. YPARTS.LT.EPS) GOTO 20
      IF (XSELEC.LT.EPS .OR. YSELEC.LT.EPS) GOTO 20
      IF (XPARTS.LT.XSELEC-EPS) GOTO 20
      IF (YPARTS.LT.YSELEC-EPS) GOTO 20
C
      XPMAX = XFMAX / XPARTS
      YPMAX = YFMAX / YPARTS
      XF1 = XPMAX * (XSELEC - 1.0)
      YF1 = YPMAX * (YSELEC - 1.0)
      GOTO 750
C
C          USER-DEFINED SUBFRAME
C
  15  IF (NSUBF.GE.1 .AND. NSUBF.LE.MSUBF) GOTO 40
  20    WRITE (NFLOG,2000)  MSUBF
        GOTO 800
C
C          READ SUBFRAME RECORD FROM DATABASE
C
  40  LREAL = MSUBF * 4
      I2 = I1 + LREAL * ISURL
      CALL SIZE (I2)
        IF (IERROR.NE.0) GOTO 900
      N1END = N1 + LREAL - 1
      DO 50 I=N1,N1END
  50    A(I) = 0.
      IF (IXGP(KSUBF).NE.0) CALL DBREAD (A(N1),KSUBF,1,0)
      IF (IERROR.NE.0) GOTO 900
      IX = N1 + (NSUBF - 1) * 4
C
C          SUBFRAME COMMAND
C
      IF (ICALL.NE.ICOMND) GOTO 500
      X1  = REALV(2)
      XF2 = REALV(3)
      Y1  = REALV(4)
      YF2 = REALV(5)
      IF(X1.GE.-EPS.AND.X1.LT.XF2.AND.Y1.GE.-EPS.AND.Y1.LT.YF2) GOTO 210
        WRITE (NFLOG,2010)
        GOTO 800
  210 A(IX  ) = X1
      A(IX+1) = XF2
      A(IX+2) = Y1
      A(IX+3) = YF2
      CALL DBWRIT (A(N1),LREAL,0,KSUBF,1,0)
        IF (IERROR.NE.0) GOTO 900
      GOTO 700
C
C          CALL FROM OTHER COMMAND SUBROUTINE
C
  500 X1  = A(IX)
      XF2 = A(IX+1)
      Y1  = A(IX+2)
      YF2 = A(IX+3)
      IF (X1.NE.XF2) GOTO 700
        WRITE (NFLOG,2030)
        GOTO 800
C
C          UPDATE CURRENT SUBFRAME LIMIT
C
  700 IF (XF2.LE.XFMAX .AND. YF2.LE.YFMAX) GOTO 720
        IF (ICALL.EQ.ICOMND) GOTO 710
          WRITE (NFLOG,2040)
          GOTO 800
  710   WRITE (NFLOG,2020)
        GOTO 900
C
  720 XPMAX = XF2 - X1
      YPMAX = YF2 - Y1
      XF1 = X1
      YF1 = Y1
  750 IF (MORIGO.EQ.0) GOTO 900
        XF2   = XPMAX
        XPMAX = YPMAX
        YPMAX = XF2
      GOTO 900
C
  800 IERROR = 1
  900 RETURN
 2000 FORMAT (46H ***ERROR: SUBFRAME ID MUST BE 0, XXYY OR 1 - ,I3)
 2010 FORMAT (49H ***ERROR: 0 <= XF1 < XF2 OR 0 <= YF1 < YF2 CHECK)
 2020 FORMAT (46H ***WARNING: SUBFRAME NOT WITHIN CURRENT FRAME)
 2030 FORMAT (31H ***ERROR: SUBFRAME NOT DEFINED)
 2040 FORMAT (44H ***ERROR: SUBFRAME NOT WITHIN CURRENT FRAME)
      END
C***ADD:CDC***
CDECK FRAME
C***END:CDC***
      SUBROUTINE FRAME
C
C         COMMAND FRAME
C
      COMMON /PARAM/ REALV(100),NCMD,NLASTP,ITYPE(20),INTV(100),
     1               IANUMV(160),LGHSTR,INTEG,IREAL,IANUM,ISTRIN,IOMIT
      COMMON /ERROR/ IERROR
      COMMON /FILES/ NFREAD,NFECHO,NFLOG,NFLIST,LUNODE,LUELEM
      COMMON /PLOTCO/ GSCALE,DSCALE,XPV,YPV,PUNIT,HEIGHT,PMARG,AXEDGE,
     1              XSF,YSF,XFMAX,YFMAX,XF1,YF1,XPMAX,YPMAX,
     3              XSMIN,XSMAX,YSMIN,YSMAX,XPSAVE,YPSAVE,VIEW(3,3),
     2              NFPLOT,IONPLT,NSYSPL,NDEVPL,MORIGO,NGPTS
C
      DATA XFMAX0 /118.9/
      DATA IPLOPE,IPLNEW,IPLOFF,IPLON/1,2,4,5/
C
C         PARAMETER 1: SIZE
C
      IF (ITYPE(1).EQ.IOMIT) GOTO 30
      SIZE = REALV(1)
      ALFA = 0.0
      IF (SIZE.LT.0.0) ALFA = 1.0
      SIZE = ABS(SIZE)
      XFMAX = XFMAX0 / (1.414214 ** ( SIZE + ALFA ) )
      YFMAX = XFMAX0 / (1.414214 ** ( SIZE + 1. - ALFA ) )
C
C          PARAMETER 2,3:  XFMAX, YFMAX
C
  30  IF (ITYPE(2).NE.IOMIT) XFMAX = REALV(2)
      IF (ITYPE(3).NE.IOMIT) YFMAX = REALV(3)
      IF (XFMAX.LT.1.0) GOTO 850
      IF (YFMAX.LT.1.0) GOTO 850
C
C        PARAMETER 4,5: XSF, YSF
C
      IF (ITYPE(4).NE.IOMIT) XSF = REALV(4)
      IF (ITYPE(5).NE.IOMIT) YSF = REALV(5)
C
C          CHECK THAT FRAME IS WITHIN PLOT SURFACE
C
      IF (XSF.LT.XSMIN .OR. XSF+XFMAX.GT.XSMAX) GOTO 60
      IF (YSF.LT.YSMIN .OR. YSF+YFMAX.GT.YSMAX) GOTO 60
      GOTO 70
  60  WRITE (NFLOG,2000) XSMIN,XSMAX,YSMIN,YSMAX
      GOTO 800
C
C        INITIALIZE PLOT AND SET NEW ORIGIN
C
  70  CALL CGRAPH (IPLOPE)
      CALL CGRAPH (IPLNEW)
      CALL CGRAPH (IPLON)
C
C        PLOT FRAME
C
      XF1=0.
      YF1=0.
      XPMAX=XFMAX
      YPMAX=YFMAX
      IF (MORIGO.EQ.0) GOTO 200
        XPMAX = YFMAX
        YPMAX = XFMAX
  200 CALL LGRAPH(XF1,YF1,3)
      CALL LGRAPH(XPMAX,YF1,2)
      CALL LGRAPH(XPMAX,YPMAX,2)
      CALL LGRAPH(XF1,YPMAX,2)
      CALL LGRAPH(XF1,YF1,2)
C
      CALL CGRAPH (IPLOFF)
C
      GOTO 900
  800 IERROR = 1
      GOTO 900
  850 IERROR = 2
  900 RETURN
C
 2000 FORMAT(56H ***ERROR: FRAME NOT WITHIN PLOT SURFACE LIMITS:  XSMIN=
     1 F7.2,7H XSMAX=,F7.2,8H  YSMIN=,F7.2,7H YSMAX=,F7.2)
      END
