home *** CD-ROM | disk | FTP | other *** search
/ Liren Large Software Subsidy 9 / 09.iso / e / e001 / 1.ddi / TMP / ADPLOT1.FOR < prev    next >
Encoding:
Text File  |  1991-01-07  |  183.4 KB  |  5,994 lines
  1. C***ADD:CDC***  PLOTMAIN
  2. CDECK ADPLOT
  3. C     PROGRAM ADPLOT (INPUT=512/80,OUTPUT,TAPE1,TAPE5=INPUT,
  4. C    1                TAPE6=OUTPUT,TAPE50=512,TAPE60,TAPE61=512)
  5. C***END:CDC***
  6. C***VERSION  0.00 BASE,IBM,DPR***   DATE 82.06.04
  7. C
  8. C
  9. C
  10. C                      A D I N A - P L O T
  11. C
  12. C
  13. C          THIS PROGRAM IS IN ITS ENTIRETY PROPRIETARY TO
  14. C                AND IS SUPPORTED AND MAINTAINED BY
  15. C
  16. C                ADINA ENGINEERING AB   (SWEDEN)
  17. C                ADINA ENGINEERING INC  (USA)
  18. C
  19. C    ADINA ENGINEERING MAKES NO WARRANTY WHATSOEVER , EXPRESSED OR
  20. C    IMPLIED, THAT THE PROGRAM AND ITS DOCUMENTATION INCLUDING ANY
  21. C    MODIFICATIONS AND UPDATES ARE FREE FROM ERRORS AND DEFECTS.IN
  22. C    NO EVENT  SHALL  ADINA ENGINEERING  BECOME LIABLE TO THE USER
  23. C    OR ANY PARTY FOR ANY LOSS , INCLUDING BUT NOT LIMITED TO LOSS
  24. C    OF TIME , MONEY OR GOODWILL , WHICH MAY ARISE FROM THE USE OF
  25. C    THE PROGRAM AND ITS DOCUMENTATION INCLUDING ANY MODIFICATIONS
  26. C    AND UPDATES.
  27. C
  28. C
  29. C    ADINA ENGINEERING AB                    ADINA ENGINEERING INC
  30. C    MUNKGATAN 20D                           71 ELTON AVENUE
  31. C    S-722 12                                WATERTOWN
  32. C    VASTERAS  SWEDEN                        MASSACHUSETTS  USA
  33. C    TEL 021-14 40 50                        TEL (617) 926-5199
  34. C    TELEX 40630 ADINA S
  35. C
  36. C
  37. C
  38. C
  39.       DIMENSION IA(1),IDIM(1),NDIM(1),NCMDPL(15)
  40. C
  41.       COMMON /CNTRL/ IBATCH,NBSU,LSTC,LSTF,LSTDB,ISURL,ITWO,LINPAG,LINE
  42.       COMMON /EPS/ EPS
  43.       COMMON /FILES/ NFREAD,NFECHO,NFLOG,NFLIST,LUNODE,LUELEM
  44.       COMMON /PARAM/ REALV(100),NCMD,NLASTP,ITYPE(20),INTV(100),
  45.      1               IANUMV(160),LGHSTR,INTEG,IREAL,IANUM,ISTRIN,IOMIT
  46.       COMMON /CALLP/ NAMZON(8),NAMERC(8),
  47.      1               IBITZ,IWHOLE,ICALL,IXPAR
  48.       COMMON /SICODE/ I000,I111,I222,I333,I444,I555,I666,I777,I888,I999,
  49.      1              IBLANK,IAAA,IBBB,ICCC,IDDD,IEEE,IFFF,IGGG,IHHH,IIII,
  50.      2                IJJJ,IKKK,ILLL,IMMM,INNN,IOOO,IPPP,IQQQ,IRRR,ISSS,
  51.      3                ITTT,IUUU,IVVV,IWWW,IXXX,IYYY,IZZZ,IPOINT,ICOMMA,
  52.      4              IPLUS,IMINUS,IEQUAL,ILPAR,IRPAR,ISLASH,IASTER,IAPOST
  53.       COMMON /FIELDC/ REALI,INPREC(80),INPOS,ITYPEI,INTI,IANUMI(128),
  54.      1               KEYI(8),NPOSRE,INECHO,MXSIGI,MXSIGR,MXSIGE,MXSTRL,
  55.      2               ISTRIL,NFIELD,NPOSIN
  56.       COMMON /PLOTCO/ GSCALE,DSCALE,XPV,YPV,PUNIT,HEIGHT,PMARG,AXEDGE,
  57.      1              XSF,YSF,XFMAX,YFMAX,XF1,YF1,XPMAX,YPMAX,
  58.      3              XSMIN,XSMAX,YSMIN,YSMAX,XPSAVE,YPSAVE,VIEW(3,3),
  59.      2              NFPLOT,IONPLT,NSYSPL,NDEVPL,MORIGO,NGPTS
  60.       COMMON /ERROR/ IERROR
  61.       COMMON /MEMORY/ MTOT,LPROG,MEMPRT,MEMMAX,MEMNOW
  62.       COMMON /DB/ IOPEN,NFDB,INDXST,IXTNOW,LGP,NWRITS,NREADS,
  63.      1            LDBC,LDBCTR,LDBCTI,IPHCHK,INSTRI,INRUSE,INSTRU,
  64.      2            MSUBF,MVIEW,MAXIS,MLINEN,MLINEE,MVAR,MRES,LSKEW,MIDSPL
  65.       COMMON /DBC/ IHED(18),NDAREC,LDAREC,NRECS,NWORDS,NEXREC,NEXTIX,
  66.      1             LIX,LIXT,NSTRI,NSTRUC,NEGIT,NEGAT,NFREQ,
  67.      2             IXGP(50),MXSGP(50),
  68.      3             FILL1
  69.       COMMON /DIM/ I01,I02,I03,I04,I05,I06,I07,I08,I09,I010,I011,
  70.      1             I1,I2,I3,I4,I5,I6,I7,I8,I9,I10,I11,I12,I13,I14,I15,
  71.      2             I16,I17,I18,I19,I20,
  72.      3             N1,N2,N3,N4,N5,N6,N7,N8,N9,N10,N11,N12,N13,N14,N15,
  73.      4             N16,N17,N18,N19,N20
  74.       COMMON /DBCTRL/ DT    ,TSTART,NUMNP ,NEQT  ,NSUBST,IDOF(6),
  75.      1                NDOF  ,NEG   ,NMID  ,MODEX ,NSTE  ,NSTEN ,
  76.      2                NSTEE ,NSKEWS,NMIDSS,IEIG  ,NSREFB,NEQITB,
  77.      3                NPRIB ,NODSVB,LEMSVB,JDC   ,JAC   ,JVC   ,
  78.      4                ISTAT ,JTC   ,NDISCE,ITP96 ,MXITAB,MXIDER,MXERES,
  79.      5                NELPAR,MXNP  ,MXEG  ,MXEL  ,MXELNP,
  80.      6                NDOFSA(6),NOUSE(4),FILL2
  81.       COMMON /IGPNAM/ KDBC  ,KSUBGP,KDBCTR,KSTRI ,KRSDCO,KTMIDS,
  82.      1                KXYZ  ,KIDRN ,KICONA,KNZONE,KNPAR ,KTHICK,
  83.      2                KITABL,KNOD  ,KEDATA,KIEZON,KFRQ  ,KPHI  ,
  84.      3                KTIMEN,KDISP ,KVEL  ,KACC  ,KTEMP ,KTIMEE,
  85.      4                KERES ,KSUBF ,KVIEW ,KAXIS ,KNPOIN,KVARES,
  86.      5                KNAMEZ,KEPOIN,KSXYZ ,KX34  ,KX35  ,KX36  ,
  87.      6                KX37  ,KX38  ,KX39  ,KX40  ,KX41  ,KX42  ,
  88.      7                KX43  ,KX44  ,KX45  ,KX46  ,KX47  ,KX48  ,
  89.      8                KX49  ,KX50
  90. C***DEL:CDY,UDY***
  91. C*         FIX LENGTH OF BLANK COMMON
  92.       COMMON A(50000)
  93.       EQUIVALENCE (A(1),IA(1))
  94.       EQUIVALENCE (I1,IDIM(1)),(N1,NDIM(1))
  95.       MTOT = 50000
  96. C***END:CDY,UDY***
  97. C***ADD:CDY,UDY***
  98. C*         DYNAMIC INCREASE OF BLANK COMMON IN SUBROUTINE SIZE
  99. C     COMMON A(10)
  100. C     EQUIVALENCE (A(1),IA(1))
  101. C     EQUIVALENCE (I1,IDIM(1)),(N1,NDIM(1))
  102. C     MTOT = 0
  103. C***END:CDY,UDY***
  104.       DATA NCMDPL/18,19,21,22,23,25,27,40,41,99,99,99,99,99,99/
  105.       DATA IPLCLO,ISPACE/3,1H /
  106. C***ADD:IBMVS***
  107. C*
  108. C*         ACTIVATE THE FOLLOWING CARD ON IBM VS FORTRAN
  109. C*         TO IGNORE ERROR 187
  110. C*
  111.       CALL ERRSET (187,256,-1,1,0,0)
  112. C***END:IBMVS***
  113.       MEMNOW = 10
  114.       WRITE (NFLOG,2020)
  115. C
  116. C         READ COMMAND AND PARAMETERS
  117. C
  118.   100 CALL COMND
  119.       LINE = 32766
  120. C
  121. C          IF INPUT ERROR, JUST GO AND PRINT MESSAGE
  122. C
  123.       IF(IERROR.NE.0) GOTO 900
  124.       DO 101 I=1,8
  125.   101   NAMERC(I) = ISPACE
  126. C
  127. C          CHECK THAT DATABASE IS OPEN
  128. C
  129.       IF (IOPEN.EQ.1 .OR. NCMD.LT.12) GOTO 102
  130.         WRITE (NFLOG,2040)
  131.         GOTO 810
  132. C
  133. C          CHECK THAT FRAME IS GIVEN FOR PLOT COMMANDS
  134. C
  135.   102 IF (IONPLT.EQ.1) GOTO 105
  136.       DO 103 I=1,15
  137.         IF (NCMD.EQ.NCMDPL(I)) GOTO 104
  138.   103   CONTINUE
  139.       GOTO 105
  140.   104 WRITE (NFLOG,2050)
  141.       GOTO 810
  142. C
  143. C
  144. C          CALL ADINA-PLOT SUBROUTINE
  145. C
  146. C
  147.   105 IF(NCMD.GT.10) GOTO 110
  148. C
  149.       GOTO(401,402,403,404,405,406,407,408,409,410),NCMD
  150. C
  151.   401 CONTINUE
  152.   402 CONTINUE
  153.       GOTO 8000
  154.   403 CALL TEST
  155.       GOTO 800
  156.   404 CALL FILE
  157.       GOTO 800
  158.   405 CALL CONTRL
  159.       GOTO 800
  160.   406 CALL DATAB
  161.       GOTO 800
  162.   407 CONTINUE
  163.   408 CONTINUE
  164.   409 CONTINUE
  165.       GOTO 800
  166.   410 CALL EVECT1
  167.       GOTO 800
  168. C
  169.   110 IF(NCMD.GT.20) GOTO 120
  170. C
  171.       NCMD1=NCMD-10
  172.       GOTO (411,412,413,414,415,416,417,418,419,420), NCMD1
  173. C
  174.   411 CALL FRAME
  175.       GOTO 800
  176.   412 CALL SUBF (0)
  177.       GOTO 800
  178.   413 CALL VIEW1
  179.       GOTO 800
  180.   414 CONTINUE
  181.   415 CONTINUE
  182.   416 CONTINUE
  183.   417 CALL ZONE1
  184.       GOTO 800
  185.   418 CONTINUE
  186.   419 CALL MESH1
  187.       GOTO 800
  188.   420 CALL APAXIS
  189.       GOTO 800
  190. C
  191.   120 IF (NCMD.GT.35) GOTO 436
  192. C
  193.       NCMD2=NCMD-20
  194.       GOTO(421,422,423,424,425,426,427,428,429,430
  195.      1    ,431,432,433,434,435), NCMD2
  196. C
  197.   421 CALL TEXT
  198.       GOTO 800
  199.   422 CALL NHIST1 (IA(I08))
  200.       GOTO 800
  201.   423 CALL EHIST1
  202.       GOTO 800
  203.   424 CALL NPOIN1
  204.       GOTO 800
  205.   425  CALL NLINE1
  206.       GOTO 800
  207.   426 CALL EPOIN1
  208.       GOTO 800
  209.   427 CALL ELINE1
  210.       GOTO 800
  211.   432 CONTINUE
  212.   433 CONTINUE
  213.   428 CALL NLIST1
  214.       GOTO 800
  215.   429 CALL GLIST1
  216.       GOTO 800
  217.   430 CALL EINFO1
  218.       GOTO 800
  219.   434 CONTINUE
  220.   435 CONTINUE
  221.   431 CALL ELIST1
  222.       GOTO 800
  223. C
  224.   436 IF (NCMD.GT.44) GOTO 445
  225.       CALL VARES1
  226.       GOTO 800
  227.   445 IF (NCMD.GT.45) GOTO 800
  228.         CALL MLIST1
  229.         GOTO 800
  230. C
  231. C
  232.   800 CONTINUE
  233.       IF (LINE.NE.32766) WRITE (NFLIST,2070)
  234.       DO 805 I=2,20
  235.         IDIM(I) = 0
  236.   805   NDIM(I) = 0
  237.       IF (IOPEN.EQ.1) CALL SIZE(I1)
  238.       IF (IERROR.EQ.0) GOTO 100
  239.       IF (IERROR.EQ.2) WRITE (NFLOG,2060)
  240.       IF (IERROR.NE.0) WRITE (NFLOG,2080)
  241.       IERROR = 0
  242.   810 IF (IBATCH.LT.1) GOTO 100
  243. C
  244. C           READ REST OF INPUT FILE IF BATCH MODE FOR SYNTAX CHECK
  245. C          CONTROL IBATCH=0  WILL BE EXECUTED
  246. C
  247.       WRITE (NFLOG,2030)
  248.   820 CALL COMND
  249.       IF (NCMD.EQ.2) GOTO 8000
  250.       IF (NCMD.EQ.5.AND.ITYPE(1).EQ.INTEG.AND.INTV(1).EQ.0)
  251.      1         GOTO 105
  252.       GOTO 820
  253. C
  254.   900 WRITE (NFLOG,2010)
  255.       GOTO 800
  256. C
  257.  8000 CONTINUE
  258.       CALL CGRAPH (IPLCLO)
  259.       CALL DBCLOS
  260.       STOP
  261. C
  262.  2010 FORMAT(51H ***ACTION: COMMAND NOT EXECUTED - INPUT DATA ERROR)
  263.  2020 FORMAT(///28H    ADINA-PLOT  VERSION 0.00)
  264.  2030 FORMAT(49H ***ERROR ACTION IN BATCH MODE: READ INPUT TO END)
  265.  2050 FORMAT (26H ***ERROR: FRAME NOT GIVEN)
  266.  2040 FORMAT (28H ***ERROR: DATABASE NOT OPEN)
  267.  2060 FORMAT (34H ***ERROR: INVALID PARAMETER VALUE)
  268.  2070 FORMAT(///)
  269.  2080 FORMAT(1H )
  270.       END
  271. C***ADD:CDC***
  272. CDECK BLDATA
  273. C***END:CDC***
  274.       BLOCK DATA
  275.       COMMON /CNTRL/ IBATCH,NBSU,LSTC,LSTF,LSTDB,ISURL,ITWO,LINPAG,LINE
  276.       COMMON /EPS/ EPS
  277.       COMMON /FILES/ NFREAD,NFECHO,NFLOG,NFLIST,LUNODE,LUELEM
  278.       COMMON /PARAM/ REALV(100),NCMD,NLASTP,ITYPE(20),INTV(100),
  279.      1               IANUMV(160),LGHSTR,INTEG,IREAL,IANUM,ISTRIN,IOMIT
  280.       COMMON /CALLP/ NAMZON(8),NAMERC(8),
  281.      1               IBITZ,IWHOLE,ICALL,IXPAR
  282.       COMMON /SICODE/ ICODE(47)
  283.       COMMON /FIELDC/ REALI,INPREC(80),INPOS,ITYPEI,INTI,IANUMI(128),
  284.      1               KEYI(8),NPOSRE,INECHO,MXSIGI,MXSIGR,MXSIGE,MXSTRL,
  285.      2               ISTRIL,NFIELD,NPOSIN
  286.       COMMON /PLOTCO/ GSCALE,DSCALE,XPV,YPV,PUNIT,HEIGHT,PMARG,AXEDGE,
  287.      1              XSF,YSF,XFMAX,YFMAX,XF1,YF1,XPMAX,YPMAX,
  288.      3              XSMIN,XSMAX,YSMIN,YSMAX,XPSAVE,YPSAVE,VIEW(3,3),
  289.      2              NFPLOT,IONPLT,NSYSPL,NDEVPL,MORIGO,NGPTS
  290.       COMMON /ERROR/ IERROR
  291.       COMMON /MEMORY/ MTOT,LPROG,MEMPRT,MEMMAX,MEMNOW
  292.       COMMON /DB/ IOPEN,NFDB,INDXST,IXTNOW,LGP,NWRITS,NREADS,
  293.      1            LDBC,LDBCTR,LDBCTI,IPHCHK,INSTRI,INRUSE,INSTRU,
  294.      2            MSUBF,MVIEW,MAXIS,MLINEN,MLINEE,MVAR,MRES,LSKEW,MIDSPL
  295.       COMMON /IGPNAM/ IGPNA(50)
  296. C
  297.       DATA LINPAG/42/
  298.       DATA IBATCH/1/
  299.       DATA NFDB,NFREAD,NFECHO,NFLOG,NFLIST,NFPLOT,LUNODE,LUELEM
  300.      1     /  1,     5,     6,    6,     6,    50,    60,    60/
  301.       DATA NPOSRE/72/
  302.       DATA INECHO/1/
  303.       DATA MXSIGI,MXSIGR,MXSIGE/6,6,38/
  304.       DATA HEIGHT/0.25/
  305.       DATA PMARG/1.5/
  306.       DATA AXEDGE/1.5/
  307.       DATA XSMIN,XSMAX,YSMIN,YSMAX/0.,999.,0.,999./
  308.       DATA XSF,YSF,XFMAX,YFMAX/0.,0., 29.7, 21.0/
  309.       DATA MORIGO/0/
  310.       DATA NSYSPL/0/
  311.       DATA NDEVPL/0/
  312.       DATA MIDSPL/1/
  313.       DATA LSKEW/1/
  314.       DATA NBSU/30/
  315.       DATA MEMPRT/1/
  316. C
  317.       DATA MSUBF,MVIEW,MLINEN,MLINEE,MVAR,MRES
  318.      1   /   10,   10,   10,    10,     20,   5/
  319.       DATA EPS/1E-5/
  320.       DATA LSTC,LSTF/0,0/
  321. C
  322. C          ITWO=2 IF PORTHOLE FILE FROM ADINA IS IN DOUBLE PRECISION
  323. C          TO BE CONVERTED TO SINGLE PRECISION IN ADINA-PLOT
  324. C
  325. C***DEL:DPR***
  326. C     DATA ITWO/1/
  327. C***END:DPR***
  328. C***ADD:DPR***
  329.       DATA ITWO/2/
  330. C***END:DPR***
  331.       DATA LSTDB,IOPEN,ISURL,LDBC,LGP,LDBCTR,LDBCTI
  332.      1    /    0,    0,    1, 131, 50,     2,   49/
  333.       DATA NCMD,NLASTP,INPOS,ITYPEI
  334.      1/   -9999,     0, 9999,     5/
  335.       DATA MXSTRL,NPOSIN
  336.      1/       128,     2/
  337.       DATA MEMMAX,IONPLT,GSCALE,DSCALE,XPV,YPV
  338.      1/         0,     0,    1.,   1., 0., 0./
  339.       DATA ICODE/0,1,2,3,4,5,6,7,8,9,10,11,12,13,14,15,16,17,18,19,20,
  340.      1          21,22,23,24,25,26,27,28,29,30,31,32,33,34,35,36,37,38,
  341.      2          39,40,41,42,43,44,45,46/
  342.       DATA IGPNA  /1,2,3,4,5,6,7,8,9,10,11,12,13,14,15,16,17,18,19,20,
  343.      1          21,22,23,24,25,26,27,28,29,30,31,32,33,34,35,36,37,38,
  344.      2          39,40,41,42,43,44,45,46,47,48,49,50/
  345.       DATA INTEG,IREAL,IANUM,ISTRIN,IOMIT/1,2,3,7,4/
  346.       DATA IWHOLE/0/
  347.       END
  348. C***ADD:CDC***
  349. CDECK ALIGN
  350. C***END:CDC***
  351.       SUBROUTINE ALIGN(I)
  352. C          ALIGN START OF INTEGER ARRAY TO REAL WORD BOUNDARY
  353. C          ON COMPUTERS WHERE REAL WORD LENGTH IS A MULTIPLE OF
  354. C          INTEGER WORD LENGTH
  355. C
  356.       COMMON /CNTRL/ IBATCH,NBSU,LSTC,LSTF,LSTDB,ISURL,ITWO,LINPAG,LINE
  357. C
  358.       IALIGN = ISURL * ITWO
  359.       IF (IALIGN.EQ.1) GOTO 900
  360.       I = ((I - 1) / IALIGN + 1) * IALIGN
  361.   900 RETURN
  362.       END
  363. C***ADD:CDC***
  364. CDECK SIZE
  365. C***END:CDC***
  366. C
  367.       SUBROUTINE SIZE(N)
  368. C
  369.       DIMENSION IA(1)
  370. C          BLANK COMMON SIZE  LIMIT CHECK IF MTOT > 0 AT PROGRAM START
  371. C                             DYNAMIC MEMORY REQUEST IF MTOT = 0
  372. C          N = SIZE REQUIRED BY CALLING PROGRAM
  373. C          IERROR= RETURN CODE = 1 IF MEMORY IS NOT AVAILIBLE
  374. C          CDY = CDC DYNAMIC BLANK COMMON SIZE
  375. C          UDY = UNIVAC DYNAMIC BLANK COMMON SIZE
  376. C
  377.       COMMON /MEMORY/ MTOT,LPROG,MEMPRT,MEMMAX,MEMNOW
  378.       COMMON /ERROR/ IERROR
  379.       COMMON /FILES/ NFREAD,NFECHO,NFLOG,NFLIST,LUNODE,LUELEM
  380.       COMMON A(1)
  381.       EQUIVALENCE (A(1),IA(1))
  382. C
  383. C          CHECK THAT START AND CURRENT END OF BLANK COMMON IS NOT
  384. C          ACCIDENTALLY CHANGED
  385. C
  386.       IF (IA(1).EQ.-87878) GOTO 2
  387.         WRITE (NFLOG,2030)
  388.         GOTO 800
  389.   2   IF (IA(MEMNOW).NE.-87878) WRITE (NFLOG,2040)
  390. C
  391.       IF (N.GT.0) GOTO 5
  392.         WRITE (NFLOG,2020)
  393.         GOTO 800
  394.   5   CALL ALIGN(N)
  395.       MEMNOW = N + 10
  396. C***ADD:CDY***
  397. C*         CDC DYNAMIC INCREASE OF BLANK COMMON
  398. C*         THE USER MUST VERIFY THIS CODING FOR HIS SYSTEM
  399. C     IF (MTOT.NE.0) GOTO 10
  400. C     LPROG = LOCF(A)
  401. C 10  LCORE = LPROG + MEMNOW
  402. C     MTOT = MEMNOW
  403. C     CALL XRFL(LCORE)
  404. C***END:CDY***
  405. C***ADD:UDY***
  406. C*         UNIVAC DYNAMIC INCREASE OF BLANK COMMON
  407. C*         THE USER MUST VERIFY THIS CODING FOR HIS SYSTEM
  408. C     LRPOG= LOC(A)
  409. C     LCORE = LPROG + MEMNOW
  410. C     IF (MEMNOW.LT.MTOT) GOTO 80
  411. C     MTOT = MEMNOW
  412. C     CALL XRFL(LCORE)
  413. C***END:UDY***
  414. C***DEL:CDY,UDY***
  415. C*         FIX LENGTH OF BLANK COMMON
  416.       IF (MEMNOW.LT.MTOT) GOTO 80
  417.       WRITE (NFLOG,2010) MEMNOW, MTOT
  418.       GOTO 800
  419. C***END:CDY,UDY***
  420.   80  CONTINUE
  421.       IF (MEMPRT.EQ.2)  WRITE (NFLOG,2000) MEMNOW
  422.       IF (MEMNOW.GT.MEMMAX) MEMMAX = MEMNOW
  423.       IA(MEMNOW) = -87878
  424.   900 RETURN
  425.   800 IERROR = 1
  426.       GOTO 900
  427.  2000 FORMAT (27H ***MEMORY SIZE REQUESTED =,I6,12H IS OBTAINED)
  428.  2010 FORMAT (47H ***ERROR: BLANK COMMON MEMORY SIZE REQUESTED =,
  429.      1I6,26H IS NOT AVAILIBLE, MTOT = ,I6)
  430.  2020 FORMAT (32H ***ERROR: ZERO MEMORY REQUESTED)
  431.  2030 FORMAT (47H ***ERROR: BLANK COMMON LOCATION 1 IS DESTROYED)
  432.  2040 FORMAT (49H ***ERROR: BLANK COMMON END OF LAST USED AREA IS ,
  433.      1        9HDESTROYED)
  434.       END
  435. C***ADD:CDC***
  436. CDECK APCHAR
  437. C***END:CDC***
  438.       SUBROUTINE APCHAR(ICODE)
  439. C
  440.       DIMENSION ICHAR(47)
  441. C
  442.       DATA ICHAR /1H0,1H1,1H2,1H3,1H4,1H5,1H6,1H7,1H8,1H9,
  443.      1            1H ,1HA,1HB,1HC,1HD,1HE,1HF,1HG,1HH,1HI,
  444.      2            1HJ,1HK,1HL,1HM,1HN,1HO,1HP,1HQ,1HR,1HS,
  445.      3            1HT,1HU,1HV,1HW,1HX,1HY,1HZ,1H.,1H,,1H+,
  446.      4            1H-,1H=,1H(,1H),1H/,1H*,1H'/
  447. C
  448.       ICODE = ICHAR(ICODE+1)
  449.       RETURN
  450.       END
  451. C***ADD:CDC***
  452. CDECK DBWRIT
  453. C***END:CDC***
  454.       SUBROUTINE DBWRIT (AA,LREAL,LINT,IGP,ISGP,ITIME)
  455. C
  456.       DIMENSION IA(1),AA(1)
  457.       COMMON /ERROR/ IERROR
  458.       COMMON /CNTRL/ IBATCH,NBSU,LSTC,LSTF,LSTDB,ISURL,ITWO,LINPAG,LINE
  459.       COMMON /FILES/ NFREAD,NFECHO,NFLOG,NFLIST,LUNODE,LUELEM
  460.       COMMON /DB/ IOPEN,NFDB,INDXST,IXTNOW,LGP,NWRITS,NREADS,
  461.      1            LDBC,LDBCTR,LDBCTI,IPHCHK,INSTRI,INRUSE,INSTRU,
  462.      2            MSUBF,MVIEW,MAXIS,MLINEN,MLINEE,MVAR,MRES,LSKEW,MIDSPL
  463.       COMMON /DBC/ IHED(18),NDAREC,LDAREC,NRECS,NWORDS,NEXREC,NEXTIX,
  464.      1             LIX,LIXT,NSTRI,NSTRUC,NEGIT,NEGAT,NFREQ,
  465.      2             IXGP(50),MXSGP(50),
  466.      3             FILL1
  467.       COMMON /DIM/ I01,I02,I03,I04,I05,I06,I07,I08,I09,I010,I011,
  468.      1             I1,I2,I3,I4,I5,I6,I7,I8,I9,I10,I11,I12,I13,I14,I15,
  469.      2             I16,I17,I18,I19,I20,
  470.      3             N1,N2,N3,N4,N5,N6,N7,N8,N9,N10,N11,N12,N13,N14,N15,
  471.      4             N16,N17,N18,N19,N20
  472.       COMMON A(1)
  473.       EQUIVALENCE (A(1),IA(1))
  474. C
  475.       IF (IOPEN.EQ.1) GOTO 100
  476.       WRITE (NFLOG,2000)
  477.       GOTO 800
  478.   100 CONTINUE
  479. C
  480. C          CHECK INDEX KEYS IGP, ISGP, ITIME
  481. C
  482.       IF (IGP.LT.3.OR.IGP.GT.LGP) GOTO 150
  483.       IF (ISGP.LT.1.OR.ISGP.GT.MXSGP (IGP)) GOTO 150
  484.       IF (ITIME.LT.0.OR.ITIME.GE.LIXT) GOTO 150
  485.       GOTO 200
  486.   150 WRITE (NFLOG,2005)
  487.       GOTO 800
  488.   200 CONTINUE
  489. C
  490. C          INITIALIZE IF FIRST WRITE FOR THIS IGP
  491. C
  492.       IF (IXGP(IGP).GT.0) GOTO 300
  493.       IXGP(IGP) = NEXTIX
  494.       NEXTIX = NEXTIX + MXSGP (IGP)
  495.       IF (NEXTIX.LE.LIX) GOTO 300
  496.       WRITE (NFLOG,2010)
  497.       GOTO 800
  498.   300 CONTINUE
  499. C
  500. C          DIRECT ACCRESS INDEX IXSGP IS NOW USED
  501. C
  502. C
  503.       IXIX = IXGP(IGP) + ISGP - 1
  504.       I01NOW = I01 + IXIX
  505.       I02NOW = I02 + IXIX
  506.       I03NOW = I03 + IXIX
  507.       I04NOW = I04 + IXIX
  508.       CALL DBINDX (I03,LIX)
  509. C
  510. C          UPDATE OR CHECK LREAL LINT ARRAYS
  511. C
  512.       IF (IA(I01NOW).EQ.0)  IA(I01NOW) = LREAL
  513.       IF (IA(I02NOW).EQ.0)  IA(I02NOW) = LINT
  514.       IF (LREAL.NE.IA(I01NOW)) GOTO 350
  515.       IF (LINT .NE.IA(I02NOW)) GOTO 350
  516.       IF (LINT.LT.0.OR.LREAL.LT.0) GOTO 350
  517.       L = LREAL + LINT
  518.       IF (L.LE.0 .OR. L.GT.1000000) GOTO 350
  519.       IF (LSTDB.EQ.0) GOTO 390
  520.       IF (LSTDB.GT.2 .AND. LSTDB.NE.IGP) GOTO 390
  521.       WRITE (NFLOG,2090) IGP,ISGP,ITIME,LREAL,LINT
  522.       IF (LSTDB.NE.2) CALL DBLSTR (AA,LREAL,LINT)
  523.       GOTO 390
  524.   350 WRITE (NFLOG,2030)
  525.       GOTO 800
  526. C
  527. C          ITIME = 0
  528. C
  529.   390 CONTINUE
  530.       IF (ITIME.GT.0) GOTO 400
  531.       INDEX = IXIX
  532.       IF (IA(I04NOW).EQ.0) GOTO 700
  533.       WRITE (NFLOG,2020)
  534.       GOTO 150
  535. C
  536. C          ITIME .GT. 0 - USE INDEX IXTIME
  537. C          IF OUR IXTIME NOT NOW IN MEMORY
  538. C          - WRITE OLD IXTIME IF IT IS UPDATED (IXTNOW POSITIVE)
  539. C          - READ OR INITIALIZE NEW IXTIME
  540. C
  541.   400 CONTINUE
  542.       IF (IA(I04NOW).GT.0.OR.IA(I03NOW).EQ.0) GOTO 410
  543.       WRITE (NFLOG,2025)
  544.       GOTO 150
  545.   410 CONTINUE
  546.       IF (IABS(IXTNOW).EQ.IXIX) GOTO 500
  547.       IF (IXTNOW.GT.0)  CALL DBW (IA(I05),0,LIXT,IXTNOW)
  548.       IF (IERROR.NE.0) GOTO 900
  549.       IF (IA(I03NOW).GT.0) GOTO 450
  550.       DO 420 I=1,LIXT
  551.   420   IA(I05+I-1) = 0
  552.       CALL DBW (IA(I05),0,LIXT,IXIX)
  553.       IF (IERROR.NE.0) GOTO 900
  554.       GOTO 460
  555.   450 CALL DBR (IA(I05),0,LIXT,IXIX)
  556.       IF (IERROR.NE.0) GOTO 900
  557.   460 CONTINUE
  558.       IXTNOW = IXIX
  559.   500 CONTINUE
  560.       INDEX = ITIME
  561.       IF (IA(I04NOW).LT.ITIME) IA(I04NOW) = ITIME
  562.       CALL DBINDX (I05,LIXT)
  563. C
  564. C          WRITE
  565. C
  566.   700 CONTINUE
  567.       CALL DBW (AA,LREAL,LINT,INDEX)
  568.       GOTO 900
  569. C
  570.   800 IERROR = 1
  571.       WRITE (NFLOG,2090) IGP,ISGP,ITIME,LREAL,LINT
  572.   900 RETURN
  573. C
  574.  2000 FORMAT (28H ***ERROR: DATABASE NOT OPEN)
  575.  2005 FORMAT (29H ***ERROR: DBWRIT KEY INVALID
  576.      1          6H ISGP=,I5,7H ITIME=,I5)
  577.  2010 FORMAT (31H ***ERROR: DBWRIT LIX TOO SMALL)
  578.  2020 FORMAT (37H ***ERROR: DBWRIT ITIME MUST NOT BE 0)
  579.  2025 FORMAT (33H ***ERROR: DBWRIT ITIME MUST BE 0)
  580.  2030 FORMAT (34H ***ERROR: DBWRIT LINT LREAL CHECK)
  581.  2090 FORMAT (/16H ***DBWRIT: IGP=,I3,6H ISGP=,I4,
  582.      1        7H ITIME=,I6,7H LREAL=,I6,6H LINT=,I6)
  583.       END
  584. C***ADD:CDC***
  585. CDECK DBW
  586. C***END:CDC***
  587.       SUBROUTINE DBW (AA,LREAL,LINT,INDEX)
  588.       DIMENSION IA(1),AA(1)
  589.       COMMON /ERROR/ IERROR
  590.       COMMON /CNTRL/ IBATCH,NBSU,LSTC,LSTF,LSTDB,ISURL,ITWO,LINPAG,LINE
  591.       COMMON /FILES/ NFREAD,NFECHO,NFLOG,NFLIST,LUNODE,LUELEM
  592.       COMMON /DB/ IOPEN,NFDB,INDXST,IXTNOW,LGP,NWRITS,NREADS,
  593.      1            LDBC,LDBCTR,LDBCTI,IPHCHK,INSTRI,INRUSE,INSTRU,
  594.      2            MSUBF,MVIEW,MAXIS,MLINEN,MLINEE,MVAR,MRES,LSKEW,MIDSPL
  595.       COMMON /DBC/ IHED(18),NDAREC,LDAREC,NRECS,NWORDS,NEXREC,NEXTIX,
  596.      1             LIX,LIXT,NSTRI,NSTRUC,NEGIT,NEGAT,NFREQ,
  597.      2             IXGP(50),MXSGP(50),
  598.      3             FILL1
  599.       COMMON A(1)
  600.       EQUIVALENCE (A(1),IA(1))
  601. C
  602. C          COMPUTE LENGTH TO BE WRITTEN
  603. C          AND UPDATE STATISTICS IF NEW RECORD
  604. C
  605.       LTOTAL = LREAL + ((LINT - 1) / ISURL + 1)
  606.       I = INDXST + INDEX
  607.       IF  (IA(I).NE.0) GOTO 5
  608.         NRECS = NRECS + 1
  609.         NWORDS = NWORDS + LTOTAL
  610.         IF (INDXST.EQ.I05) IXTNOW = IABS(IXTNOW)
  611.   5   CONTINUE
  612. C
  613. C          CHECK INDEX VALUE
  614. C
  615.       IF (INDEX.GT.0.AND.INDXST.GT.0) GOTO 10
  616.       WRITE (NFLOG,2030)
  617.       IERROR = 1
  618.       GOTO 15
  619.   10  CONTINUE
  620.       IF (LSTDB.NE.2) GOTO 20
  621.    15 WRITE (NFLOG,2090) LREAL, LINT, INDXST, INDEX,IA(I),NEXREC
  622.       CALL DBLSTR (AA,LREAL,LINT)
  623.   20  CONTINUE
  624. C***ADD:CDC***
  625. C     CALL WRITMS (NFDB,AA,LTOTAL,INDEX,-1)
  626. C***END:CDC***
  627. C***ADD:IBM,BUR***
  628. C*         IF ADD SET RECORD ADDRESS IN INDEX ARRAY TO NEXT FREE RECORD
  629. C*         IF REPLACE PICK UP DISK RECORD ADDRESS FROM INDEX ARRAY
  630. C*         AND REWRITE IN SAME RECORD(S)
  631. C*
  632.       NEWREC = 0
  633.       IF (IA(I).NE.0) GOTO 100
  634.       IA(I) = NEXREC
  635.       NEWREC = 1
  636.  100  CONTINUE
  637.       IREC = IA(I)
  638. C*
  639. C*         SPLIT RECORD INTO ONE OR MORE DISK RECORDS OF FIX LENGTH
  640. C*         IF ADD AND NOT REPLACE - UPDATE NEXT FREE RECORD (NEXREC)
  641. C*
  642.       II = 1
  643.  200  JJ = II - 1 + LDAREC
  644.       IF (JJ.GT.LTOTAL) JJ = LTOTAL
  645.       IF (IREC.LE.NDAREC) GOTO 300
  646.       WRITE (NFLOG,2000) NDAREC, LDAREC
  647.       IERROR = 1
  648.       GOTO 900
  649.  300  IDUM = IREC
  650.       WRITE (NFDB'IDUM) (AA(I),I=II,JJ)
  651.       IREC = IREC + 1
  652.       IF (NEWREC .EQ.1) NEXREC = IREC
  653.       II = JJ + 1
  654.       IF (II.LE.LTOTAL) GOTO 200
  655. C***END:IBM,BUR***
  656. C
  657.   900 NWRITS = NWRITS + 1
  658.       RETURN
  659. C
  660.  2000 FORMAT (48H ***ERROR: DATABASE WRITE ATTEMPT TO STORE MORE ,
  661.      9      8HPHYSICAL,
  662.      1      /11X,33HRECORDS THAN THE MAX NO (NDAREC=,I6,10H) DEFINED
  663.      2  /11X,53HIN SUBROUTINE DBOPEN  - PLEASE INCREASE NDAREC VALUE
  664.      3  /11X,34HOR PHYSICAL RECORD LENGTH (LDAREC=,I6,14H AND RECOMPILE)
  665.  2030 FORMAT (38H ***ERROR: DBW INDEX OR INDXST INVALID)
  666.  2090 FORMAT (/15H ***DBW: LREAL=,I6,6H LINT=,I6,
  667.      1        8H INDXST=,I6,7H INDEX=,I6,7H DADDR=,I10,8H NEXREC=,I10)
  668.       END
  669. C***ADD:CDC***
  670. CDECK DBINDX
  671. C***END:CDC***
  672.       SUBROUTINE DBINDX (INDX,LINDX)
  673. C
  674.       DIMENSION IA(1)
  675.       COMMON /DB/ IOPEN,NFDB,INDXST,IXTNOW,LGP,NWRITS,NREADS,
  676.      1            LDBC,LDBCTR,LDBCTI,IPHCHK,INSTRI,INRUSE,INSTRU,
  677.      2            MSUBF,MVIEW,MAXIS,MLINEN,MLINEE,MVAR,MRES,LSKEW,MIDSPL
  678.       COMMON A(1)
  679.       EQUIVALENCE (A(1),IA(1))
  680. C***ADD:CDC***
  681. C     IF (INDX.NE.INDXST) CALL STINDX (NFDB,IA(INDX),LINDX,0)
  682. C***END:CDC***
  683.       INDXST = INDX
  684.       RETURN
  685.       END
  686. C***ADD:CDC***
  687. CDECK DBREAD
  688. C***END:CDC***
  689.       SUBROUTINE DBREAD (AA,IGP,ISGP,ITIME)
  690. C
  691.       DIMENSION IA(1),AA(1)
  692.       COMMON /ERROR/ IERROR
  693.       COMMON /CNTRL/ IBATCH,NBSU,LSTC,LSTF,LSTDB,ISURL,ITWO,LINPAG,LINE
  694.       COMMON /FILES/ NFREAD,NFECHO,NFLOG,NFLIST,LUNODE,LUELEM
  695.       COMMON /DB/ IOPEN,NFDB,INDXST,IXTNOW,LGP,NWRITS,NREADS,
  696.      1            LDBC,LDBCTR,LDBCTI,IPHCHK,INSTRI,INRUSE,INSTRU,
  697.      2            MSUBF,MVIEW,MAXIS,MLINEN,MLINEE,MVAR,MRES,LSKEW,MIDSPL
  698.       COMMON /DBC/ IHED(18),NDAREC,LDAREC,NRECS,NWORDS,NEXREC,NEXTIX,
  699.      1             LIX,LIXT,NSTRI,NSTRUC,NEGIT,NEGAT,NFREQ,
  700.      2             IXGP(50),MXSGP(50),
  701.      3             FILL1
  702.       COMMON /DIM/ I01,I02,I03,I04,I05,I06,I07,I08,I09,I010,I011,
  703.      1             I1,I2,I3,I4,I5,I6,I7,I8,I9,I10,I11,I12,I13,I14,I15,
  704.      2             I16,I17,I18,I19,I20,
  705.      3             N1,N2,N3,N4,N5,N6,N7,N8,N9,N10,N11,N12,N13,N14,N15,
  706.      4             N16,N17,N18,N19,N20
  707.       COMMON A(1)
  708.       EQUIVALENCE (A(1),IA(1))
  709. C
  710.       LREAL = 0
  711.       LINT  = 0
  712.       IF (IOPEN.EQ.1) GOTO 100
  713.       WRITE (NFLOG,2000)
  714.       GOTO 800
  715.   100 CONTINUE
  716. C
  717. C          CHECK RECORD KEYS IGP, ISGP, ITIME
  718. C
  719.       IF (IGP.LT.3.OR.IGP.GT.LGP) GOTO 150
  720.       IF (ISGP.LT.1.OR.ISGP.GT.MXSGP (IGP)) GOTO 150
  721.       IF (ITIME.LT.0.OR.ITIME.GE.LIXT) GOTO 150
  722.       GOTO 200
  723.   150 WRITE (NFLOG,2005)
  724.       GOTO 800
  725.   200 CONTINUE
  726. C
  727. C          DIRECT ACCRESS INDEX IXSGP IS NOW USED
  728. C
  729.       IF (IXGP(IGP).NE.0) GOTO 250
  730.       WRITE (NFLOG,2030)
  731.       GOTO 150
  732.   250 IXIX = IXGP(IGP) + ISGP - 1
  733.       I01NOW = I01 + IXIX
  734.       I02NOW = I02 + IXIX
  735.       I03NOW = I03 + IXIX
  736.       I04NOW = I04 + IXIX
  737.       IF (IA(I03NOW).NE.0) GOTO 260
  738.       WRITE (NFLOG,2040)
  739.       GOTO 150
  740.   260 CALL DBINDX (I03,LIX)
  741. C
  742. C          GET LREAL, LINT FROM SUBGROUP ARRAYS
  743. C
  744.       LREAL = IA(I01NOW)
  745.       LINT = IA(I02NOW)
  746.       IF (LSTDB.EQ.0) GOTO 300
  747.       IF (LSTDB.GT.2 .AND. LSTDB.NE.IGP) GOTO 300
  748.       WRITE (NFLOG,2090) IGP,ISGP,ITIME,LREAL,LINT
  749.   300 CONTINUE
  750. C
  751. C          ITIME = 0
  752. C
  753.       IF (ITIME.GT.0) GOTO 400
  754.       INDEX = IXIX
  755.       IF (IA(I04NOW).EQ.0) GOTO 600
  756.       WRITE (NFLOG,2020)
  757.       GOTO 150
  758. C
  759. C          ITIME .GT. 0 - USE DIRECT ACCESS INDEX ITIME
  760. C          IF OUR IXTIME NOT IN MEMORY NOW
  761. C          - WRITE OLD IXTIME IF UPDATED (IXTNOW POSITIVE)
  762. C          - READ OR INITIALIZE NEW IXTIME
  763. C
  764.   400 CONTINUE
  765.       IF (IA(I04NOW).GT.0) GOTO 410
  766.       WRITE (NFLOG,2025)
  767.       GOTO 150
  768.   410 IF (IABS(IXTNOW).EQ.IXIX) GOTO 500
  769.       IF (IXTNOW.GT.0) CALL DBW (IA(I05),0,LIXT,IXTNOW)
  770.       IF (IERROR.NE.0) GOTO 900
  771.       CALL DBR (IA(I05),0,LIXT,IXIX)
  772.       IF (IERROR.NE.0) GOTO 900
  773.       IXTNOW = -IXIX
  774.   500 INDEX = ITIME
  775.       IF (IA(I05+ITIME).NE.0) GOTO 510
  776.       WRITE (NFLOG,2050)
  777.       GOTO 150
  778.   510 CALL DBINDX (I05,LIXT)
  779.   600 CONTINUE
  780. C
  781. C          READ
  782. C
  783.        CALL DBR (AA,LREAL,LINT,INDEX)
  784.       IF (LSTDB.EQ.1 .OR. LSTDB.EQ.IGP) CALL DBLSTR (AA,LREAL,LINT)
  785.       GOTO 900
  786. C
  787.   800 IERROR = 1
  788.       WRITE (NFLOG,2090) IGP,ISGP,ITIME,LREAL,LINT
  789.   900 RETURN
  790. C
  791.  2000 FORMAT (28H ***ERROR: DATABASE NOT OPEN)
  792.  2005 FORMAT (29H ***ERROR: DBREAD KEY INVALID)
  793.  2020 FORMAT (37H ***ERROR: DBREAD ITIME MUST NOT BE 0)
  794.  2025 FORMAT (33H ***ERROR: DBREAD ITIME MUST BE 0)
  795.  2030 FORMAT (40H ***ERROR: DBREAD IGP NOT FOUND IN INDEX)
  796.  2040 FORMAT (41H ***ERROR: DBREAD ISGP NOT FOUND IN INDEX)
  797.  2050 FORMAT (42H ***ERROR: DBREAD ITIME NOT FOUND IN INDEX)
  798.  2090 FORMAT (/16H ***DBREAD: IGP=,I3,6H ISGP=,I5,
  799.      1        7H ITIME=,I6,7H LREAL=,I6,6H LINT=,I6)
  800.       END
  801. C***ADD:CDC***
  802. CDECK DBR
  803. C***END:CDC***
  804.       SUBROUTINE DBR (AA,LREAL,LINT,INDEX)
  805. C
  806.       DIMENSION IA(1),AA(1)
  807.       COMMON /ERROR/ IERROR
  808.       COMMON /CNTRL/ IBATCH,NBSU,LSTC,LSTF,LSTDB,ISURL,ITWO,LINPAG,LINE
  809.       COMMON /FILES/ NFREAD,NFECHO,NFLOG,NFLIST,LUNODE,LUELEM
  810.       COMMON /DB/ IOPEN,NFDB,INDXST,IXTNOW,LGP,NWRITS,NREADS,
  811.      1            LDBC,LDBCTR,LDBCTI,IPHCHK,INSTRI,INRUSE,INSTRU,
  812.      2            MSUBF,MVIEW,MAXIS,MLINEN,MLINEE,MVAR,MRES,LSKEW,MIDSPL
  813.       COMMON /DBC/ IHED(18),NDAREC,LDAREC,NRECS,NWORDS,NEXREC,NEXTIX,
  814.      1             LIX,LIXT,NSTRI,NSTRUC,NEGIT,NEGAT,NFREQ,
  815.      2             IXGP(50),MXSGP(50),
  816.      3             FILL1
  817.       COMMON A(1)
  818.       EQUIVALENCE (A(1),IA(1))
  819. C
  820. C          CHECK INDEX FOR VALIDITY
  821. C
  822.       I = INDXST + INDEX
  823.       IREC = IA(I)
  824.       IF (INDEX.GT.0 .AND. INDXST.GT.0 .AND. IREC.NE.0) GOTO 10
  825.       WRITE (NFLOG,2030)
  826.       IERROR = 1
  827.       GOTO 900
  828.   10  CONTINUE
  829.       IF (LSTDB.EQ.2) WRITE (NFLOG,2090) LREAL,LINT,INDXST,INDEX,IREC
  830. C
  831. C          COMPUTE LENGTH TO BE READ
  832. C
  833.       LTOTAL = LREAL + ((LINT - 1) / ISURL + 1)
  834. C
  835. C***ADD:CDC***
  836. C     CALL READMS (NFDB,AA,LTOTAL,INDEX)
  837. C***END:CDC***
  838. C***ADD:IBM,BUR***
  839. C*
  840. C*         READ ONE OR MORE DISK RECORDS OF FIX LENGTH TO FILL UP AA
  841. C*
  842.       II = 1
  843.  200  JJ = II - 1 + LDAREC
  844.       IF (JJ.GT.LTOTAL) JJ = LTOTAL
  845.       IDUM = IREC
  846.       READ (NFDB'IDUM) (AA(I),I=II,JJ)
  847.       IREC = IREC + 1
  848.       II = JJ + 1
  849.       IF (II.LE.LTOTAL) GOTO 200
  850. C***END:IBM,BUR***
  851. C
  852.       NREADS = NREADS + 1
  853.       IF (LSTDB.NE.2) GOTO 900
  854.       CALL DBLSTR (AA,LREAL,LINT)
  855.   900 RETURN
  856. C
  857.  2030 FORMAT (51H ***ERROR: DBR INDEX, INDXST OR ARRAY VALUE INVALID)
  858.  2090 FORMAT (/15H ***DBR: LREAL=,I6,6H LINT=,I6,
  859.      1        8H INDXST=,I6,7H INDEX=,I6,7H DADDR=,I10)
  860.       END
  861. C***ADD:CDC***
  862. CDECK DBLSTR
  863. C***END:CDC***
  864.       SUBROUTINE DBLSTR (AA,LREAL,LINT)
  865. C
  866.       DIMENSION AA(1)
  867.       COMMON /FILES/ NFREAD,NFECHO,NFLOG,NFLIST,LUNODE,LUELEM
  868. C
  869. C          WRITE REALS
  870. C
  871.       II = 1
  872.   600 IF (II.GT.LREAL) GOTO 690
  873.       JJ = II + 9
  874.       IF (JJ.GT.LREAL) JJ = LREAL
  875.       I = II
  876.   620 IF (I.EQ.LREAL) GOTO 630
  877.       IF (AA(I).NE.AA(I+1)) GOTO 630
  878.       I = I + 1
  879.       GOTO 620
  880.   630 IF (I.GT.JJ) GOTO 640
  881.       WRITE (NFLOG,2610) II, (AA(I),I=II,JJ)
  882.       II = JJ + 1
  883.       GOTO 600
  884.   640 WRITE (NFLOG,2620) II, AA(II)
  885.       II = I + 1
  886.       GOTO 600
  887.   690 CONTINUE
  888. C
  889.       CALL DBLSTI (AA(LREAL+1),LINT)
  890.       RETURN
  891.  2610 FORMAT (1H ,I4,1H:,10(1X,G9.3))
  892.  2620 FORMAT (1H ,I4,1H:,1X,G9.3,8H SAME...)
  893.       END
  894. C***ADD:CDC***
  895. CDECK DBLSTI
  896. C***END:CDC***
  897.       SUBROUTINE DBLSTI (IAA,LINT)
  898. C
  899.       DIMENSION IAA(1)
  900.       COMMON /FILES/ NFREAD,NFECHO,NFLOG,NFLIST,LUNODE,LUELEM
  901. C
  902. C
  903. C          WRITE INTEGERS
  904. C
  905.       II = 1
  906.   700 IF (II.GT.LINT) GOTO 900
  907.       JJ = II + 19
  908.       IF (JJ.GT.LINT) JJ = LINT
  909.       I = II
  910.   720 IF (I.EQ.LINT) GOTO 730
  911.       IF (IAA(I).NE.IAA(I+1)) GOTO 730
  912.       I = I + 1
  913.       GOTO 720
  914.   730 IF (I.GT.JJ) GOTO 740
  915.       WRITE (NFLOG,2630) II, (IAA(I),I=II,JJ)
  916.       II = JJ + 1
  917.       GOTO 700
  918.   740 WRITE (NFLOG,2640) II, IAA(II)
  919.       II = I + 1
  920.       GOTO 700
  921. C
  922.   900 RETURN
  923. C
  924.  2630 FORMAT (1H ,I4,1H:,20(1X,I4))
  925.  2640 FORMAT (1H ,I4,1H:,1X,I4,8H SAME...)
  926.       END
  927. C***ADD:CDC***
  928. CDECK DBOPEN
  929. C***END:CDC***
  930.       SUBROUTINE DBOPEN
  931. C
  932.       DIMENSION IA(1)
  933.       COMMON /ERROR/ IERROR
  934.       COMMON /FILES/ NFREAD,NFECHO,NFLOG,NFLIST,LUNODE,LUELEM
  935.       COMMON /MEMORY/ MTOT,LPROG,MEMPRT,MEMMAX
  936.       COMMON /DB/ IOPEN,NFDB,INDXST,IXTNOW,LGP,NWRITS,NREADS,
  937.      1            LDBC,LDBCTR,LDBCTI,IPHCHK,INSTRI,INRUSE,INSTRU,
  938.      2            MSUBF,MVIEW,MAXIS,MLINEN,MLINEE,MVAR,MRES,LSKEW,MIDSPL
  939.       COMMON /DBC/ IHED(18),NDAREC,LDAREC,NRECS,NWORDS,NEXREC,NEXTIX,
  940.      1             LIX,LIXT,NSTRI,NSTRUC,NEGIT,NEGAT,NFREQ,
  941.      2             IXGP(50),MXSGP(50),
  942.      3             FILL1
  943.       COMMON /DIM/ I01,I02,I03,I04,I05,I06,I07,I08,I09,I010,I011,
  944.      1             I1,I2,I3,I4,I5,I6,I7,I8,I9,I10,I11,I12,I13,I14,I15,
  945.      2             I16,I17,I18,I19,I20,
  946.      3             N1,N2,N3,N4,N5,N6,N7,N8,N9,N10,N11,N12,N13,N14,N15,
  947.      4             N16,N17,N18,N19,N20
  948.       COMMON A(1)
  949.       EQUIVALENCE (A(1),IA(1))
  950. C
  951. C***ADD:CDC***
  952. C     CALL OPENMS (NFDB,IA(2),3,0)
  953. C***END:CDC***
  954. C***ADD:IBM,BUR***
  955. C*
  956. C*         DATABASE FILE CONSTANTS ARE FIXED AT COMPILATION TIME:
  957. C*         LDAREC = LENGTH OF PHYSICAL RECORD IN NUMBER OF REAL WORDS
  958. C*         NDAREC = NUMBER OF PHYSICAL DISK RECORDS AVAILIBLE
  959. C*         NFDB   = FILE UNIT NUMBER
  960. C*         PLEASE CHANGE VALUES AND RECOMPILE IF REQUIRED
  961. C*
  962.       DEFINE FILE 1 (1000,500,U,NREC1)
  963.       NFDB = 1
  964. C***END:IBM,BUR***
  965.       NDAREC = 1000
  966.       LDAREC = 500
  967. C
  968. C
  969.       CALL DBINDX (2,3)
  970.       MEMMAX = 0
  971.       IOPEN = 1
  972.       RETURN
  973.       END
  974. C***ADD:CDC***
  975. CDECK DBCLOS
  976. C***END:CDC***
  977.       SUBROUTINE DBCLOS
  978. C
  979.       DIMENSION IA(1)
  980.       COMMON /ERROR/ IERROR
  981.       COMMON /FILES/ NFREAD,NFECHO,NFLOG,NFLIST,LUNODE,LUELEM
  982.       COMMON /MEMORY/ MTOT,LPROG,MEMPRT,MEMMAX,MEMNOW
  983.       COMMON /DB/ IOPEN,NFDB,INDXST,IXTNOW,LGP,NWRITS,NREADS,
  984.      1            LDBC,LDBCTR,LDBCTI,IPHCHK,INSTRI,INRUSE,INSTRU,
  985.      2            MSUBF,MVIEW,MAXIS,MLINEN,MLINEE,MVAR,MRES,LSKEW,MIDSPL
  986.       COMMON /DBC/ IHED(18),NDAREC,LDAREC,NRECS,NWORDS,NEXREC,NEXTIX,
  987.      1             LIX,LIXT,NSTRI,NSTRUC,NEGIT,NEGAT,NFREQ,
  988.      2             IXGP(50),MXSGP(50),
  989.      3             FILL1
  990.       COMMON /DIM/ I01,I02,I03,I04,I05,I06,I07,I08,I09,I010,I011,
  991.      1             I1,I2,I3,I4,I5,I6,I7,I8,I9,I10,I11,I12,I13,I14,I15,
  992.      2             I16,I17,I18,I19,I20,
  993.      3             N1,N2,N3,N4,N5,N6,N7,N8,N9,N10,N11,N12,N13,N14,N15,
  994.      4             N16,N17,N18,N19,N20
  995.       COMMON A(1)
  996.       EQUIVALENCE (A(1),IA(1))
  997.       IF (IOPEN.EQ.0) GOTO 900
  998. C
  999. C          WRITE IXTIME IF UPDATED (IXTNOW POSITIVE)
  1000. C
  1001.       IF (IXTNOW.LE.0) GOTO 200
  1002.       CALL DBINDX (I03,LIX)
  1003.       CALL DBW (IA(I05),0,LIXT,IXTNOW)
  1004.   200 CONTINUE
  1005. C
  1006. C          WRITE COMMON /DBC/ AND SUBGROUP ARRAYS
  1007. C
  1008.       CALL DBINDX (2,3)
  1009.       CALL DBW (IHED,0,LDBC,1)
  1010.       CALL DBW (IA(I01),0,(LIX*4),2)
  1011. C
  1012. C***ADD:CDC***
  1013. C     CALL CLOSMS (NFDB)
  1014. C***END:CDC***
  1015. C
  1016.       IOPEN = 0
  1017. C
  1018. C          WRITE MEMORY AND DATABASE STATISTICS
  1019. C
  1020.       IF (MEMPRT.EQ.0) GOTO 900
  1021.       N = NWORDS / NRECS + 1
  1022.       M = MTOT
  1023.       IF (MTOT.LT.MEMMAX) M = 0
  1024.       WRITE (NFLOG,2000) MEMMAX,M,NWRITS,NREADS,NRECS,N
  1025.       N = NEXREC - 1
  1026.       IF (NEXREC.GT.1) WRITE (NFLOG,2010) N,NDAREC,LDAREC
  1027. C
  1028.   900 RETURN
  1029. C
  1030.  2000 FORMAT(/47H    DATABASE CLOSED:  BLANK COMMON MEMORY USED=,I8,
  1031.      -  10H  OF MTOT=,I8/
  1032.      1  4X,7HWRITES=,I5,8H  READS=,I5,10H  RECORDS=,I6,
  1033.      2        16H AVERAGE LENGTH=,I4)
  1034.  2010 FORMAT (4X,47HDIRECT ACCESS FIX LENGTH PHYSICAL RECORDS USED=,I6,
  1035.      1        5H MAX=,I6,8H LENGTH=,I6)
  1036.       END
  1037. C***ADD:CDC***
  1038. CDECK BITGET
  1039. C***END:CDC***
  1040.       SUBROUTINE BITGET (IWORD,IBITZ,IOLD)
  1041. C
  1042.       COMMON /CNTRL/ IBATCH,NBSU,LSTC,LSTF,LSTDB,ISURL,ITWO,LINPAG,LINE
  1043.       IEXP = 2 ** (NBSU - IBITZ)
  1044.       IOLD = MOD (IWORD/IEXP,2)
  1045.       RETURN
  1046.       END
  1047. C***ADD:CDC***
  1048. CDECK ZGETNB
  1049. C***END:CDC***
  1050.       SUBROUTINE ZGETNB
  1051. C
  1052.       DIMENSION IA(1)
  1053.       COMMON /CNTRL/ IBATCH,NBSU,LSTC,LSTF,LSTDB,ISURL,ITWO,LINPAG,LINE
  1054.       COMMON /PARAM/ REALV(100),NCMD,NLASTP,ITYPE(20),INTV(100),
  1055.      1               IANUMV(8,20),LGHSTR,INTEG,IREAL,IANUM,ISTRIN,IOMIT
  1056.       COMMON /CALLP/ NAMZON(8),NAMERC(8),
  1057.      1               IBITZ,IWHOLE,ICALL,IXPAR
  1058.       COMMON /FILES/ NFREAD,NFECHO,NFLOG,NFLIST,LUNODE,LUELEM
  1059.       COMMON /ERROR/ IERROR
  1060.       COMMON /DBC/ IHED(18),NDAREC,LDAREC,NRECS,NWORDS,NEXREC,NEXTIX,
  1061.      1             LIX,LIXT,NSTRI,NSTRUC,NEGIT,NEGAT,NFREQ,
  1062.      2             IXGP(50),MXSGP(50),
  1063.      3             FILL1
  1064.       COMMON /DIM/ I01,I02,I03,I04,I05,I06,I07,I08,I09,I010,I011,
  1065.      1             I1,I2,I3,I4,I5,I6,I7,I8,I9,I10,I11,I12,I13,I14,I15,
  1066.      2             I16,I17,I18,I19,I20,
  1067.      3             N1,N2,N3,N4,N5,N6,N7,N8,N9,N10,N11,N12,N13,N14,N15,
  1068.      4             N16,N17,N18,N19,N20
  1069.       COMMON /IGPNAM/ KDBC  ,KSUBGP,KDBCTR,KSTRI ,KRSDCO,KTMIDS,
  1070.      1                KXYZ  ,KIDRN ,KICONA,KNZONE,KNPAR ,KTHICK,
  1071.      2                KITABL,KNOD  ,KEDATA,KIEZON,KFRQ  ,KPHI  ,
  1072.      3                KTIMEN,KDISP ,KVEL  ,KACC  ,KTEMP ,KTIMEE,
  1073.      4                KERES ,KSUBF ,KVIEW ,KAXIS ,KNPOIN,KVARES,
  1074.      5                KNAMEZ,KEPOIN,KSXYZ ,KX34  ,KX35  ,KX36  ,
  1075.      6                KX37  ,KX38  ,KX39  ,KX40  ,KX41  ,KX42  ,
  1076.      7                KX43  ,KX44  ,KX45  ,KX46  ,KX47  ,KX48  ,
  1077.      8                KX49  ,KX50
  1078.       COMMON A(1)
  1079.       EQUIVALENCE (A(1),IA(1))
  1080.       IBITZ = IWHOLE
  1081.       DO 100 I=1,8
  1082.         ICODE = IANUMV(I,1)
  1083.         CALL APCHAR (ICODE)
  1084.   100   NAMZON(I) = ICODE
  1085.       IF (ITYPE(1).EQ.IOMIT) GOTO 900
  1086. C
  1087. C          READ NAMEZ
  1088. C
  1089.       IF (IXGP(KNAMEZ).EQ.0) GOTO 700
  1090.       I2 = I1 + 8 * NBSU
  1091.       CALL SIZE (I2)
  1092.       IF (IERROR.NE.0) GOTO 900
  1093.       CALL DBREAD (IA(I1),KNAMEZ,1,0)
  1094.       IF (IERROR.NE.0) GOTO 900
  1095.       DO 200 I=1,NBSU
  1096.         DO 150 J=1,8
  1097.           K = I1 + (I-1) * 8 + J - 1
  1098.           IF (IA(K).NE.IANUMV(J,1)) GOTO 200
  1099.   150     CONTINUE
  1100.         IBITZ = I
  1101.         GOTO 900
  1102.   200 CONTINUE
  1103.   700 WRITE (NFLOG,2000)
  1104.   800 IERROR = 1
  1105.   900 RETURN
  1106.  2000 FORMAT (31H ***ERROR: ZONENAME NOT DEFINED)
  1107.       END
  1108. C***ADD:CDC***
  1109. CDECK KINDN
  1110. C***END:CDC***
  1111.       SUBROUTINE KINDN (NDIR,KIND,KINDHD)
  1112.       DIMENSION KINDHD(3)
  1113.       DIMENSION IHDCOV(69)
  1114.       DATA IHDCOV
  1115.      1  /4H  RE,4HSULT,4HANT ,4HX-DI,4HR DI,4HSPL.,4HY-DI,4HR DI,4HSPL.
  1116.      2                       ,4HZ-DI,4HR DI,4HSPL.,4HX-RO,4HT DI,4HSPL.
  1117.      3  ,4HY-RO,4HT DI,4HSPL.,4HZ-RO,4HT DI,4HSPL.,4HX-DI,4HR VE,4HLOC.
  1118.      4  ,4HY-DI,4HR VE,4HLOC.,4HZ-DI,4HR VE,4HLOC.,4HX-RO,4HT VE,4HLOC.
  1119.      5  ,4HY-RO,4HT VE,4HLOC.,4HZ-RO,4HT VE,4HLOC.,4HX-DI,4HR AC,4HCEL.
  1120.      6  ,4HY-DI,4HR AC,4HCEL.,4HZ-DI,4HR AC,4HCEL.,4HX-RO,4HT AC,4HCEL.
  1121.      7  ,4HY-RO,4HT AC,4HCEL.,4HZ-RO,4HT AC,4HCEL.,4H TEM,4HPERA,4HTURE
  1122.      8  ,4HX-CO,4HORDI,4HNATE,4HY-CO,4HORDI,4HNATE,4HZ-CO,4HORDI,4HNATE/
  1123. C
  1124.       J = ((KIND - 1) * 6 + NDIR) * 3
  1125.       IF (KIND.EQ.0) J = 0
  1126.       IF (KIND.EQ.4) J = 57
  1127.       IF (KIND.EQ.5) J = J - 15
  1128.       DO 10 I=1,3
  1129.   10    KINDHD(I) = IHDCOV(I+J)
  1130.       RETURN
  1131.       END
  1132. C***ADD:CDC***
  1133. CDECK KINDE
  1134. C***END:CDC***
  1135.       SUBROUTINE KINDE (IELTYP,INDNL,NTABLE,KIND,IHED)
  1136. C
  1137. C
  1138. C          ELEMENT RESULT KIND HEADLINES
  1139. C
  1140. C          NTYHED(2) = NUMBER OF KIND HEADLINES STORED FOR IELTYP=1=TRUS
  1141. C          NTYHED(3) = NUMBER OF KIND HEADLINES STORED FOR IELTYP=2=2DIM
  1142. C          ...
  1143. C          SHELL HAS SAME HEADLINES AS 3DIM
  1144. C
  1145. C
  1146.       DIMENSION IHED(1),NTYHED(16),KINHED(186),KINH1(114),KIN115(72)
  1147. C
  1148.       EQUIVALENCE (KINHED(1),KINH1(1)),(KINHED(115),KIN115(1))
  1149. C
  1150.       DATA ITRUSS,I2DIM,I3DIM,IBEAM,ISOBEA,IPLATE,ISHELL/1,2,3,4,5,6,7/
  1151.       DATA I2DIMF,I3DIMF/11,12/
  1152. C
  1153.       DATA NTYHED/1,3,8,12,0,12,12,6,0,0,0,4,4,0,0,0/
  1154. C
  1155.       DATA KINH1/
  1156.      1  4H  RE,4HSULT,4HANT ,4HAXIA,4HL FO,4HRCE ,
  1157.      2  4HAXIA,4HL ST,4HRESS,4HAXIA,4HL ST,4HRAIN,
  1158.      3  4HYY-S,4HTRES,4HS   ,4HZZ-S,4HTRES,4HS   ,
  1159.      4  4HYZ-S,4HTRES,4HS   ,4HXX-S,4HTRES,4HS   ,
  1160.      5  4HYY-S,4HTRAI,4HN   ,4HZZ-S,4HTRAI,4HN   ,
  1161.      6  4HYZ-S,4HTRAI,4HN   ,4HXX-S,4HTRAI,4HN   ,
  1162.      7  4HXX-S,4HTRES,4HS   ,4HYY-S,4HTRES,4HS   ,
  1163.      8  4HZZ-S,4HTRES,4HS   ,4HXY-S,4HTRES,4HS   ,
  1164.      9  4HXZ-S,4HTRES,4HS   ,4HYZ-S,4HTRES,4HS   ,
  1165.      -  4HXX-S,4HTRAI,4HN   ,4HYY-S,4HTRAI,4HN   ,
  1166.      1  4HZZ-S,4HTRAI,4HN   ,4HXY-S,4HTRAI,4HN   ,
  1167.      2  4HXZ-S,4HTRAI,4HN   ,4HYZ-S,4HTRAI,4HN   ,
  1168.      3  4HR-FO,4HRCE ,4H    ,4HS-FO,4HRCE ,4H    ,
  1169.      4  4HT-FO,4HRCE ,4H    ,4HR-MO,4HMENT,4H    ,
  1170.      5  4HS-MO,4HMENT,4H    ,4HT-MO,4HMENT,4H    ,
  1171.      6  4HRR-S,4HTRES,4HS   ,4HRS-S,4HTRES,4HS   ,
  1172.      7  4HRT-S,4HTRES,4HS   ,4HRR-S,4HTRAI,4HN   ,
  1173.      8  4HRS-S,4HTRAI,4HN   ,4HRT-S,4HTRAI,4HN   ,
  1174.      9  4HXL-F,4HORCE,4H    ,4HYL-F,4HORCE,4H    /
  1175.       DATA KIN115/
  1176.      1  4HXYL-,4HFORC,4HE   ,4HXL-M,4HOMEN,4HT   ,
  1177.      2  4HYL-M,4HOMEN,4HT   ,4HXYL-,4HMOME,4HNT  ,
  1178.      3  4HXXL-,4HSTRA,4HIN  ,4HYYL-,4HSTRA,4HIN  ,
  1179.      4  4HXYL-,4HSTRA,4HIN  ,4HXL-C,4HURVA,4HTURE,
  1180.      5  4HYL-C,4HURVA,4HTURE,4HXYL-,4HCURV,4H.   ,
  1181.      6  4HX-FO,4HRCE ,4H    ,4HY-FO,4HRCE ,4H    ,
  1182.      7  4HZ-FO,4HRCE ,4H    ,4HX-MO,4HMENT,4H    ,
  1183.      8  4HY-MO,4HMENT,4H    ,4HZ-MO,4HMENT,4H    ,
  1184.      9  4HPRES,4HSURE,4H    ,4HYY-S,4HTRAI,4HN   ,
  1185.      -  4HZZ-S,4HTRAI,4HN   ,4HXX-S,4HTRAI,4HN   ,
  1186.      1  4HPRES,4HSURE,4H    ,4HXX-S,4HTRAI,4HN   ,
  1187.      2  4HYY-S,4HTRAI,4HN   ,4HZZ-S,4HTRAI,4HN   /
  1188. C
  1189. C
  1190.       IELTY = IELTYP
  1191.       IF (IELTY.EQ.ISHELL .AND. NTABLE.GE.0) IELTY = I3DIM
  1192.       IX = KIND - 1
  1193.       DO 100 I=1,IELTY
  1194.   100   IX = IX + NTYHED(I)
  1195.       IF (IELTYP.EQ.IBEAM .AND. INDNL.NE.0 .AND. NTABLE.GE.0)
  1196.      1    IX = IX + 6
  1197.       IF (IELTYP.EQ.ISOBEA .AND. NTABLE.GE.0) IX = IX + 6
  1198.       IF (KIND.EQ.0) IX = 0
  1199.       DO 200 I=1,3
  1200.   200   IHED(I) = KINHED(IX*3+I)
  1201.       RETURN
  1202.       END
  1203. C***ADD:CDC***
  1204. CDECK SKEW
  1205. C***END:CDC***
  1206.       SUBROUTINE SKEW (VDIR,RSDCOS)
  1207. C
  1208. C          TRANSFORM DISPLACEMENTS AND ROTATIONS FROM
  1209. C          SKEW TO GLOBAL COORDINATE SYSTEM
  1210. C
  1211.       DIMENSION VDIR(6),RSDCOS(3,3)
  1212. C
  1213.       X = VDIR(1)
  1214.       Y = VDIR(2)
  1215.       Z = VDIR(3)
  1216. C
  1217.       DO 10 I=1,3
  1218.   10    VDIR(I) = X * RSDCOS(1,I) + Y * RSDCOS(2,I) + Z * RSDCOS(3,I)
  1219. C
  1220.       X = VDIR(4)
  1221.       Y = VDIR(5)
  1222.       Z = VDIR(6)
  1223. C
  1224.       DO 20 I=1,3
  1225.   20    VDIR(I+3) = X*RSDCOS(1,I) + Y*RSDCOS(2,I) + Z*RSDCOS(3,I)
  1226. C
  1227.       RETURN
  1228.       END
  1229. C***ADD:CDC***
  1230. CDECK ELRES
  1231. C***END:CDC***
  1232.       SUBROUTINE ELRES (IFUNC,NPAR,ETIME,IPS,ITABLE,NTABLE,
  1233.      1     IEGIT,ISEGIT,TIME,NERPTS,IDERPT,NERES,NERKI,LOCALE)
  1234. C
  1235. C
  1236. C          FIND IDENTIFICATIONS OF ELEMENT RESULTS AVAILIBLE ON PORTHOLE
  1237. C          FILE AND IN DATA BASE - AS A FUNCTION OF:
  1238. C
  1239. C          IPS = OUTPUT FLAG OR ITABLE
  1240. C          NPAR(4), ETIME = BIRTH AND DEATH OPTION
  1241. C          NPAR(1) = ELEMENT TYPE
  1242. C          NPAR(3) = TYPE OF ANALYSIS, LINEAR OR NONLINEAR
  1243. C          NPAR(7) = NUMBER OF ELEMENT NODES FOR ISOBEAM
  1244. C          NPAR(9)-NPAR(12) = INTEGRATION ORDER(S) FOR SOME ELEMENT TYPE
  1245. C          ITABLE = STRESS OUTPUT TABLE POINTED TO BY IPS
  1246. C          NPAR(13) = NTABLE = NUMBER OF STRESS OUTPUT TABLES
  1247. C
  1248. C
  1249. C          IFUNC = 1 - UPDATE ARRAYS OF ELEMENT RESULT IDS:
  1250. C
  1251. C              NERPTS(NUME) = NUMBER OF ELEMENT OUTPUT POINTS
  1252. C              IDERPT(NERES) = RESULT POINT IDENTIFICATIONS
  1253. C                          .LT.0 IF DEAD OR UNBORN ELEMENT
  1254. C
  1255. C
  1256. C          IFUNC = 2 -  UPDATE MXIDER, MXERES IN COMMON AREA
  1257. C
  1258. C
  1259. C
  1260. C          ALSO UPDATE LOCALE TO 0 IF RESULTS ARE MEASURED IN
  1261. C          GLOBAL SYSTEM  AND TO 1 IF RESULTS ARE MEASURED IN
  1262. C          LOCAL ELEMENT COORDINATE SYSTEM
  1263. C
  1264.       DIMENSION NPAR(1),ETIME(1),IPS(1),ITABLE(NTABLE,1),
  1265.      1          NERPTS(1),IDERPT(1),NERKIA(15)
  1266. C
  1267.       COMMON /ERROR/ IERROR
  1268.       COMMON /DBCTRL/ DT    ,TSTART,NUMNP ,NEQT  ,NSUBST,IDOF(6),
  1269.      1                NDOF  ,NEG   ,NMID  ,MODEX ,NSTE  ,NSTEN ,
  1270.      2                NSTEE ,NSKEWS,NMIDSS,IEIG  ,NSREFB,NEQITB,
  1271.      3                NPRIB ,NODSVB,LEMSVB,JDC   ,JAC   ,JVC   ,
  1272.      4                ISTAT ,JTC   ,NDISCE,ITP96 ,MXITAB,MXIDER,MXERES,
  1273.      5                NELPAR,MXNP  ,MXEG  ,MXEL  ,MXELNP,
  1274.      6                NDOFSA(6),NOUSE(4),FILL2
  1275.       COMMON /IGPNAM/ KDBC  ,KSUBGP,KDBCTR,KSTRI ,KRSDCO,KTMIDS,
  1276.      1                KXYZ  ,KIDRN ,KICONA,KNZONE,KNPAR ,KTHICK,
  1277.      2                KITABL,KNOD  ,KEDATA,KIEZON,KFRQ  ,KPHI  ,
  1278.      3                KTIMEN,KDISP ,KVEL  ,KACC  ,KTEMP ,KTIMEE,
  1279.      4                KERES ,KSUBF ,KVIEW ,KAXIS ,KNPOIN,KVARES,
  1280.      5                KNAMEZ,KEPOIN,KSXYZ ,KX34  ,KX35  ,KX36  ,
  1281.      6                KX37  ,KX38  ,KX39  ,KX40  ,KX41  ,KX42  ,
  1282.      7                KX43  ,KX44  ,KX45  ,KX46  ,KX47  ,KX48  ,
  1283.      8                KX49  ,KX50
  1284. C
  1285.       DATA ITRUSS,I2DIM,I3DIM,IBEAM,ISOBEA,IPLATE,ISHELL/1,2,3,4,5,6,7/
  1286.       DATA I2DIMF,I3DIMF/11,12/
  1287.       DATA NERKIA/3,8,12,6,6,12,12,0,0,0,4,4,0,0,0/
  1288. C
  1289.       IELTYP = NPAR(1)
  1290.       NUME   = NPAR(2)
  1291.       INDNL  = NPAR(3)
  1292.       IDEATH = NPAR(4)
  1293.       MODEL  = NPAR(15)
  1294. C
  1295. C          READ ETIME, IPS AND ITABLE IF NOT ALREADY DONE
  1296. C
  1297.       IF (ISEGIT.EQ.IEGIT) GOTO 100
  1298.       ISEGIT = IEGIT
  1299.       CALL DBREAD (ETIME,KEDATA,IEGIT,0)
  1300.       IF (IERROR.NE.0) GOTO 900
  1301.       IF (NTABLE.LE.0) GOTO 100
  1302.       CALL DBREAD (ITABLE,KITABL,IEGIT,0)
  1303.       IF (IERROR.NE.0) GOTO 900
  1304.   100 CONTINUE
  1305. C
  1306. C          DO FOR EVERY ELEMENT IN GROUP
  1307. C
  1308.       NERES = 0
  1309.       DO 700 IEL=1,NUME
  1310. C
  1311.       NERPT = 0
  1312.       IPSEL = IABS(IPS(IEL))
  1313.       IF (IPSEL.EQ.0) GOTO 600
  1314. C
  1315. C          FIND ELEMENT RESULT POINT IDS FOR THIS ELEMENT
  1316. C
  1317. C
  1318. C          TRUSS - RING ELEMENT: AT ONE NODE POINT
  1319. C                  2-NODE ELEMENT: AT ALL INTEGRATION POINTS
  1320. C
  1321.   200 IF (IELTYP.NE.ITRUSS) GOTO 210
  1322.       NERPT = 1
  1323.       IF (NPAR(5).EQ.1) GOTO 550
  1324.       NERPT = NPAR(10)
  1325.       GOTO 550
  1326. C
  1327. C          2DIM, 2DIMF - AT MAX 4 INTEGRATION POINT CORNERS
  1328. C                        OR AT ITABLE POINTS, MAX 9, END = 0
  1329.   210 IF (IELTYP.EQ.I2DIMF) GOTO 220
  1330.       IF (IELTYP.NE.I2DIM) GOTO 240
  1331.       IF (NTABLE.GT.0 .AND. MODEL.LE.2) GOTO 230
  1332.   220 NINT = NPAR(10)
  1333.       NERPT = NINT * NINT
  1334.       IF (NERPT.LT.4) GOTO 550
  1335.       NERPT = 4
  1336.       IF (IFUNC.EQ.2) GOTO 600
  1337.       IDERPT(NERES+1) = 1
  1338.       IDERPT(NERES+2) = NINT
  1339.       IDERPT(NERES+3) = NINT * (NINT - 1) + 1
  1340.       IDERPT(NERES+4) = NINT * NINT
  1341.       GOTO 600
  1342. C
  1343.   230 NTAB = 9
  1344.       GOTO 500
  1345. C
  1346. C          3DIM, 3DIMF - AT MAX 8 INTEGRATION POINT CORNERS
  1347. C                        OR AT ITABLE POINTS, MAX 16, 0 = END
  1348. C
  1349.   240 IF (IELTYP.EQ.I3DIMF) GOTO 250
  1350.       IF (IELTYP.NE.I3DIM) GOTO 280
  1351.       IF (NTABLE.GT.0 .AND. MODEL.LE.2) GOTO 270
  1352.   250 NINTR = NPAR(10)
  1353.       NINTS = NINTR
  1354.       NINTT = NPAR(11)
  1355. C          THIS CODING IS ALSO FOR SHELL ELEMENT TYPE
  1356.   260 NERPT = NINTR * NINTS * NINTT
  1357.       IF (NERPT.LT.8) GOTO 550
  1358.       NERPT = 8
  1359.       IF (IFUNC.EQ.2) GOTO 600
  1360.       IDERPT(NERES+1) = 1
  1361.       IDERPT(NERES+2) = NINTT
  1362.       IDERPT(NERES+3) = NINTT * (NINTS - 1) + 1
  1363.       IDERPT(NERES+4) = NINTS * NINTT
  1364.       I               = NINTS * NINTT * (NINTR - 1) + 1
  1365.       IDERPT(NERES+5) = I
  1366.       IDERPT(NERES+6) = I + NINTT - 1
  1367.       I               = I + NINTT * (NINTR - 1)
  1368.       IDERPT(NERES+7) = I
  1369.       IDERPT(NERES+8) = I + NINTT - 1
  1370.       GOTO 600
  1371. C
  1372.   270 NTAB = 16
  1373.       GOTO 500
  1374. C
  1375. C          BEAM - LINEAR ELEMENT: AT 2 NODES IN ONE RECORD ON PORTHOLE
  1376. C          NONLINEAR: AT ALL INTEGRATION POINTS
  1377. C                     OR AT ITABLE INTEG. POINTS, MAX NPAR(14), END=0
  1378. C
  1379.   280 IF (IELTYP.NE.IBEAM) GOTO 320
  1380.       IF (INDNL.NE.0 .AND. NTABLE.GE.0) GOTO 290
  1381.       NERPT = 2
  1382.       GOTO 550
  1383. C
  1384.   290 IF (NTABLE.GT.0) GOTO 310
  1385.       INTX = NPAR(9)
  1386.       INTY = NPAR(10)
  1387.       INTZ = NPAR(11)
  1388.       DO 300 I=1,INTX
  1389.       DO 300 J=1,INTZ
  1390.       DO 300 K=1,INTY
  1391.         NERPT = NERPT + 1
  1392.         IF (IFUNC.EQ.2) GOTO 300
  1393.         IDERPT(NERES+NERPT) = I*100 + K*10 + J
  1394.   300   CONTINUE
  1395.       GOTO 600
  1396. C
  1397.   310 NTAB = NPAR(14)
  1398.       GOTO 500
  1399. C
  1400. C          ISOBEAM - AT ALL INTEGRATION POINTS
  1401. C                    OR AT ITABLE INTEGRATION POINTS
  1402. C                    OR AT ELEMENT NODES (IN ONE PORTHOLE RECORD)
  1403. C
  1404.   320 IF (IELTYP.NE.ISOBEA) GOTO 370
  1405.       INR = IABS(NPAR(9))
  1406.       INS = IABS(NPAR(10))
  1407.       INT = IABS(NPAR(11))
  1408.       IF (NTABLE.NE.0) GOTO 340
  1409.       DO 330 I=1,INR
  1410.       DO 330 J=1,INS
  1411.       DO 330 K=1,INT
  1412.         NERPT = NERPT + 1
  1413.         IF (IFUNC.EQ.2) GOTO 330
  1414.         IDERPT(NERES+NERPT) = I*100 + J*10 + K
  1415.   330   CONTINUE
  1416.       GOTO 600
  1417. C
  1418.   340 IF (NTABLE.LT.0) GOTO 360
  1419.       NTAB = ITABLE(IPSEL,1) + 1
  1420.       DO 350 ITAB=2,NTAB
  1421.         NERPT = NERPT + 1
  1422.         IF (IFUNC.EQ.2) GOTO 350
  1423.         N = ITABLE(IPSEL,ITAB)
  1424.         IPT = 0
  1425.         DO 345 I=1,INR
  1426.         DO 345 J=1,INS
  1427.         DO 345 K=1,INT
  1428.           IPT = IPT + 1
  1429.           IF (IPT.EQ.N) GOTO 346
  1430.   345     CONTINUE
  1431.   346   CONTINUE
  1432.         IDERPT(NERES+NERPT) = I*100 + J*10 + K
  1433.   350   CONTINUE
  1434.       GOTO 600
  1435. C
  1436.   360 NERPT = NPAR(7)
  1437.       GOTO 550
  1438. C
  1439. C          PLATE - AT ALL INTEGRATION POINTS
  1440. C                  OR AT ITABLE POINTS, MAX 7, END = 0
  1441. C
  1442.   370 IF (IELTYP.NE.IPLATE) GOTO 390
  1443.       IF (NTABLE.GT.0 .AND. MODEL.LE.2) GOTO 380
  1444.       NINT = NPAR(10)
  1445.       NERPT = NINT
  1446.       IF (NINT.EQ.2) NERPT = 3
  1447.       IF (NINT.EQ.4) NERPT = 7
  1448.       GOTO 550
  1449. C
  1450.   380 NTAB = 7
  1451.       GOTO 500
  1452. C
  1453. C          SHELL - AT 8 INTEGRATION POINT CORNERS
  1454. C                  OR AT ITABLE POINTS, MAX 16, 0 = END
  1455. C
  1456.   390 IF (IELTYP.NE.ISHELL) GOTO 700
  1457.       IF (NTABLE.GT.0 .AND. MODEL.EQ.1) GOTO 400
  1458.       NINTR = NPAR(10)
  1459.       NINTS = NPAR(11)
  1460.       NINTT = NPAR(12)
  1461.       GOTO 260
  1462. C
  1463.   400 NTAB = 16
  1464.       GOTO 500
  1465. C
  1466. C          STRESS LOCATION TABLE IS USED, 0 = END
  1467. C
  1468.   500 DO 510 ITAB=1,NTAB
  1469.         N = ITABLE(IPSEL,ITAB)
  1470.         IF (N.EQ.0) GOTO 600
  1471.         NERPT = NERPT + 1
  1472.         IF (IFUNC.EQ.2) GOTO 510
  1473.         IDERPT(NERES+NERPT) = N
  1474.   510   CONTINUE
  1475.       GOTO 600
  1476. C
  1477. C          POINTS ARE NUMBERED 1 - NERPT
  1478. C
  1479.   550 IF (IFUNC.EQ.2) GOTO 600
  1480.       DO 560 I=1,NERPT
  1481.   560   IDERPT(NERES+I) = I
  1482.       GOTO 600
  1483. C
  1484. C          SAVE NUMBER OF RESULT POINTS FOR THIS ELEMENT
  1485. C
  1486.   600 IF (IFUNC.EQ.2) GOTO 650
  1487.       NERPTS(IEL) = NERPT
  1488.       IF (NERPT.EQ.0) GOTO 700
  1489. C
  1490. C          BIRTH AND DEATH OPTION CHECK
  1491. C
  1492.       IF (INDNL.EQ.0) GOTO 650
  1493.       IF (IDEATH.EQ.0) GOTO 650
  1494.       ETIMEL = ETIME(IEL)
  1495.       IF (IDEATH.EQ.2 .AND. TIME.GT.ETIMEL) GOTO 610
  1496.       IF (IDEATH.NE.2 .AND. TIME.LT.ETIMEL) GOTO 610
  1497.       GOTO 650
  1498.   610 DO 620 I=1,NERPT
  1499.   620   IDERPT(NERES+I) = - IDERPT(NERES+I)
  1500. C
  1501.   650 NERES = NERES + NERPT
  1502. C
  1503.   700 CONTINUE
  1504. C
  1505. C          FIND NERKI = NUMBER OF RESULTS KINDS AT EACH POINT
  1506. C
  1507.       NERKI = NERKIA(IELTYP)
  1508.       IF (IELTYP.EQ.IBEAM .AND. INDNL.GT.0 .AND.
  1509.      1  NTABLE.GE.0) NERKI = 3
  1510. C
  1511. C          UPDATE LOCALE, 0 = GLOBAL, 1 = LELEMENT COORD. SYSTEM
  1512. C
  1513.       LOCALE = 0
  1514.       IF (IELTYP.EQ.ITRUSS .OR. IELTYP.EQ.IBEAM) GOTO 710
  1515.       IF (IELTYP.EQ.ISOBEA .OR. IELTYP.EQ.IPLATE) GOTO 710
  1516.       IF (IELTYP.EQ.I2DIM .AND. NPAR(5).EQ.3) GOTO 710
  1517.       IF (IELTYP.EQ.ISHELL .AND. NPAR(5).EQ.1) GOTO 710
  1518.       GOTO 800
  1519.   710 LOCALE = 1
  1520. C
  1521. C          UPDATE COMMON AREA MXIDER,MXERES IF IFUNC = 2
  1522. C
  1523.   800 IF (IFUNC.NE.2) GOTO 900
  1524.         IF (MXIDER.LT.NERES) MXIDER = NERES
  1525.         I = NERKI * NERES
  1526.         IF (MXERES.LT.I) MXERES = I
  1527. C
  1528.   900 RETURN
  1529.       END
  1530. C***ADD:CDC***
  1531. CDECK VARES1
  1532. C***END:CDC***
  1533.       SUBROUTINE VARES1
  1534. C
  1535.       DIMENSION IA(1)
  1536. C
  1537.       COMMON /ERROR/ IERROR
  1538.       COMMON /PARAM/ REALV(100),NCMD,NLASTP,ITYPE(20),INTV(100),
  1539.      1               IANUMV(8,20),LGHSTR,INTEG,IREAL,IANUM,ISTRIN,IOMIT
  1540.       COMMON /CALLP/ NAMZON(8),NAMERC(8),
  1541.      1               IBITZ,IWHOLE,ICALL,IXPAR
  1542.       COMMON /DB/ IOPEN,NFDB,INDXST,IXTNOW,LGP,NWRITS,NREADS,
  1543.      1            LDBC,LDBCTR,LDBCTI,IPHCHK,INSTRI,INRUSE,INSTRU,
  1544.      2            MSUBF,MVIEW,MAXIS,MLINEN,MLINEE,MVAR,MRES,LSKEW,MIDSPL
  1545.       COMMON /DIM/ I01,I02,I03,I04,I05,I06,I07,I08,I09,I010,I011,
  1546.      1             I1,I2,I3,I4,I5,I6,I7,I8,I9,I10,I11,I12,I13,I14,I15,
  1547.      2             I16,I17,I18,I19,I20,
  1548.      3             N1,N2,N3,N4,N5,N6,N7,N8,N9,N10,N11,N12,N13,N14,N15,
  1549.      4             N16,N17,N18,N19,N20
  1550.       COMMON /CNTRL/ IBATCH,NBSU,LSTC,LSTF,LSTDB,ISURL,ITWO,LINPAG,LINE
  1551.       COMMON A(1)
  1552.       EQUIVALENCE (A(1),IA(1))
  1553. C
  1554.       DATA KRLIST,KRMAX,KREX,KRHIST,KRLINE/42,43,44,40,41/
  1555. C
  1556.       IBITZ = 0
  1557.       IF (NCMD.EQ.KRLIST.OR.NCMD.EQ.KRMAX.OR.NCMD.EQ.KREX)
  1558.      1          CALL ZGETNB
  1559.       IF (NCMD.EQ.KRHIST) CALL SUBF(11)
  1560.       IF (NCMD.EQ.KRLINE) CALL SUBF(9)
  1561.       IF (IERROR.NE.0) GOTO 900
  1562. C
  1563. C          BLANK COMMON LAYOUT FOR VARES2
  1564. C
  1565. C                                                VALUEV
  1566.       I2 = I1 + MVAR * ISURL
  1567. C                                                ITYPV
  1568.       I3 = I2 + MVAR
  1569. C                                                NDIRV
  1570.       I4 = I3 + MVAR
  1571. C                                                KINDV
  1572.       I5 = I4 + MVAR
  1573. C                                                IETYPV
  1574.       I6 = I5 + MVAR
  1575. C                                                IRPOL
  1576.       I7 = I6 + 100
  1577. C                                                IFORM
  1578.       I8 = I7 + MRES * 129
  1579. C                                                NAMEV
  1580.       I9 = I8 + MVAR * 8
  1581. C                                                NAMER
  1582.       I10 = I9 + MRES * 8
  1583. C                                                NEEDV
  1584.       I11 = I10 + MVAR
  1585.       CALL SIZE (I11)
  1586.       IF (IERROR.NE.0) GOTO 900
  1587. C
  1588. C          INITIATE VARES
  1589. C
  1590.       DO 10 I=1,MVAR
  1591.   10    A(N1+I-1) = 0.0
  1592.       DO 20 I=I2,I11
  1593.   20    IA(I) = 0
  1594. C
  1595.       I11 = I7
  1596.       CALL ALIGN (I11)
  1597.       N11 = I11 / ISURL
  1598.       CALL VARES2 (A(N1),IA(I2),IA(I3),IA(I4),IA(I5),
  1599.      1             IA(I6),IA(I7),IA(I8),IA(I9),IA(I10))
  1600.   900 RETURN
  1601.       END
  1602. C***ADD:CDC***
  1603. CDECK VARES2
  1604. C***END:CDC***
  1605.       SUBROUTINE VARES2 (VALUEV,ITYPV,NDIRV,KINDV,
  1606.      1                   IETYPV,IRPOL,IFORM,NAMEV,NAMER,NEEDV)
  1607. C
  1608.       DIMENSION IA(1),VALUEV(1),ITYPV(1),NDIRV(1),KINDV(1),IETYPV(1),
  1609.      1          IRPOL(1),IFORM(129,1),NAMEV(8,1),NAMER(8,1),NEEDV(1)
  1610.       DIMENSION KINDHD(7),KINDEL(15),ISTRIV(1)
  1611. C
  1612.       COMMON /CNTRL/ IBATCH,NBSU,LSTC,LSTF,LSTDB,ISURL,ITWO,LINPAG,LINE
  1613.       COMMON /FILES/ NFREAD,NFECHO,NFLOG,NFLIST,LUNODE,LUELEM
  1614.       COMMON /PARAM/ REALV(100),NCMD,NLASTP,ITYPE(20),INTV(100),
  1615.      1               IANUMV(8,20),LGHSTR,INTEG,IREAL,IANUM,ISTRIN,IOMIT
  1616.       COMMON /CALLP/ NAMZON(8),NAMERC(8),
  1617.      1               IBITZ,IWHOLE,ICALL,IXPAR
  1618.       COMMON /ERROR/ IERROR
  1619.       COMMON /DB/ IOPEN,NFDB,INDXST,IXTNOW,LGP,NWRITS,NREADS,
  1620.      1            LDBC,LDBCTR,LDBCTI,IPHCHK,INSTRI,INRUSE,INSTRU,
  1621.      2            MSUBF,MVIEW,MAXIS,MLINEN,MLINEE,MVAR,MRES,LSKEW,MIDSPL
  1622.       COMMON /DBC/ IHED(18),NDAREC,LDAREC,NRECS,NWORDS,NEXREC,NEXTIX,
  1623.      1             LIX,LIXT,NSTRI,NSTRUC,NEGIT,NEGAT,NFREQ,
  1624.      2             IXGP(50),MXSGP(50),
  1625.      3             FILL1
  1626.       COMMON /DIM/ I01,I02,I03,I04,I05,I06,I07,I08,I09,I010,I011,
  1627.      1             I1,I2,I3,I4,I5,I6,I7,I8,I9,I10,I11,I12,I13,I14,I15,
  1628.      2             I16,I17,I18,I19,I20,
  1629.      3             N1,N2,N3,N4,N5,N6,N7,N8,N9,N10,N11,N12,N13,N14,N15,
  1630.      4             N16,N17,N18,N19,N20
  1631.       COMMON /DBCTRL/ DT    ,TSTART,NUMNP ,NEQT  ,NSUBST,IDOF(6),
  1632.      1                NDOF  ,NEG   ,NMID  ,MODEX ,NSTE  ,NSTEN ,
  1633.      2                NSTEE ,NSKEWS,NMIDSS,IEIG  ,NSREFB,NEQITB,
  1634.      3                NPRIB ,NODSVB,LEMSVB,JDC   ,JAC   ,JVC   ,
  1635.      4                ISTAT ,JTC   ,NDISCE,ITP96 ,MXITAB,MXIDER,MXERES,
  1636.      5                NELPAR,MXNP  ,MXEG  ,MXEL  ,MXELNP,
  1637.      6                NDOFSA(6),NOUSE(4),FILL2
  1638.       COMMON /IGPNAM/ KDBC  ,KSUBGP,KDBCTR,KSTRI ,KRSDCO,KTMIDS,
  1639.      1                KXYZ  ,KIDRN ,KICONA,KNZONE,KNPAR ,KTHICK,
  1640.      2                KITABL,KNOD  ,KEDATA,KIEZON,KFRQ  ,KPHI  ,
  1641.      3                KTIMEN,KDISP ,KVEL  ,KACC  ,KTEMP ,KTIMEE,
  1642.      4                KERES ,KSUBF ,KVIEW ,KAXIS ,KNPOIN,KVARES,
  1643.      5                KNAMEZ,KEPOIN,KSXYZ ,KX34  ,KX35  ,KX36  ,
  1644.      6                KX37  ,KX38  ,KX39  ,KX40  ,KX41  ,KX42  ,
  1645.      7                KX43  ,KX44  ,KX45  ,KX46  ,KX47  ,KX48  ,
  1646.      8                KX49  ,KX50
  1647.       COMMON A(1)
  1648.       EQUIVALENCE (A(1),IA(1))
  1649.       EQUIVALENCE (IANUMV(1,2),ISTRIV(1))
  1650. C
  1651.       DATA KNVAR,KEVAR,KCONST,KRCOMB,KRHIST,KRLINE,KRLIST
  1652.      1     /  36,    37,    38,    39,    40,    41,    42/
  1653.       DATA KRMAX,KREX/43,44/
  1654.       DATA INODE,IELEM,ICONST/1,2,3/
  1655.       DATA ICALLR,KINDHD(4)/2,4H OR /
  1656.       DATA ITRUSS,I2DIM,I3DIM,IBEAM,ISOBEA,IPLATE,ISHELL/1,2,3,4,5,6,7/
  1657.       DATA I2DIMF,I3DIMF/11,12/
  1658.       DATA KINDEL/3,8,12,12,6,6,12,0,0,0,5,7,0,0,0/
  1659. C
  1660. C           READ VARES
  1661. C
  1662.       IF (IXGP(KVARES).NE.0) CALL DBREAD (VALUEV,KVARES,1,0)
  1663.         IF (IERROR.NE.0) GOTO 900
  1664. C
  1665. CCCCCCCCCCCCCCC   NVAR, EVAR, CONST
  1666. C
  1667.       IF (NCMD.GT.KCONST) GOTO 200
  1668. C
  1669. C          FIND FREE ARRAY ENTRY OR ENTRY WITH SAME NAME
  1670. C
  1671.       IF (ITYPE(1).EQ.IOMIT) GOTO 850
  1672.       IFREE = 0
  1673.       IVAR = MVAR
  1674.   30    IF (ITYPV(IVAR).EQ.0) IFREE = IVAR
  1675.         DO 40 I=1,8
  1676.           IF (IANUMV(I,1).NE.NAMEV(I,IVAR)) GOTO 50
  1677.   40      CONTINUE
  1678.         GOTO 60
  1679.   50    IVAR = IVAR - 1
  1680.       IF (IVAR.GT.1) GOTO 30
  1681.       IVAR = IFREE
  1682.       IF (IFREE.GT.0) GOTO 60
  1683.         I = MVAR - 1
  1684.         WRITE (NFLOG,2000) I
  1685.         GOTO 800
  1686. C
  1687. C          CONSTANT
  1688. C
  1689.   60  IF (NCMD.NE.KCONST) GOTO 80
  1690. C
  1691. C          IF PAR 2 IS OMITTED, DELETE VARIABLE/CONSTANT ENTRY
  1692. C
  1693.       IF (ITYPE(2).NE.IOMIT) GOTO 70
  1694.         NAMEV(1,IVAR) = 0
  1695.         ITYPV(IVAR) = 0
  1696.         GOTO 140
  1697.   70    ITYPV(IVAR) = ICONST
  1698.         VALUEV(IVAR) = REALV(2)
  1699.       GOTO 110
  1700. C
  1701. C          NVARIABLE
  1702. C
  1703.   80  IF (NCMD.NE.KNVAR) GOTO 100
  1704.         ITYPV(IVAR) = INODE
  1705.         NDIR = INTV(2)
  1706.         IF (ITYPE(2).EQ.IOMIT) NDIR = 1
  1707.       IF (NDIR.LT.1.OR.NDIR.GT.6) GOTO 850
  1708.         NDIRV(IVAR) = NDIR
  1709.         KIND = INTV(3)
  1710.         IF (ITYPE(3).EQ.IOMIT) KIND = 1
  1711.         IF (KIND.LT.0.OR.KIND.GT.4) GOTO 850
  1712.         IF (KIND.EQ.0 .AND. NDIR.GT.3) GOTO 850
  1713.         IF (KIND.EQ.0) KIND = 5
  1714.         KINDV(IVAR) = KIND
  1715.         GOTO 110
  1716. C
  1717. C          EVARIABLE
  1718. C
  1719.   100 ITYPV(IVAR) = IELEM
  1720.       IETYP = INTV(2)
  1721.       IF (IETYP.LT.1 .OR. IETYP.GT.15) GOTO 850
  1722.       IETYPV(IVAR) = IETYP
  1723.       KIND = INTV(3)
  1724.       IF (ITYPE(3).EQ.IOMIT) KIND = 1
  1725.       IF (KIND.LT.1 .OR. KIND.GT.KINDEL(IETYP)) GOTO 850
  1726.       KINDV(IVAR) = KIND
  1727. C
  1728. C          SAVE NAME AND WRITE TO DATABASE
  1729.   110 DO 120 I=1,8
  1730.   120   NAMEV(I,IVAR) = IANUMV(I,1)
  1731.   140 LREAL = MVAR
  1732.       LINT = I10 - I2
  1733.       CALL DBWRIT (IA(I1),LREAL,LINT,KVARES,1,0)
  1734.       GOTO 900
  1735. C
  1736. CCCCCCCCCCCCCC  RCOMB   CCCCCCCCCCCCCCCC
  1737. C
  1738.   200 IF (NCMD.NE.KRCOMB) GOTO 300
  1739. C
  1740. C          FIND FREE ARRAY ENTRY OR ENTRY WITH SAME NAME
  1741. C
  1742.       IF (ITYPE(1).EQ.IOMIT) GOTO 850
  1743.       IFREE = 0
  1744.       IRES = MRES
  1745.   210   IF (NAMER(1,IRES).EQ.0) IFREE = IRES
  1746.         DO 220 I=1,8
  1747.           IF (IANUMV(I,1).NE.NAMER(I,IRES)) GOTO 230
  1748.   220     CONTINUE
  1749.         GOTO 240
  1750.   230 IRES = IRES - 1
  1751.       IF (IRES.GT.0) GOTO 210
  1752. C
  1753.       IRES = IFREE
  1754.       IF (IFREE.GT.0) GOTO 240
  1755.         WRITE (NFLOG,2020) MRES
  1756.         GOTO 800
  1757. C
  1758. C          IF PAR 2 IS OMITTED, DELETE RESULTANT ENTRY
  1759. C
  1760.   240 IF (ITYPE(2).NE.IOMIT) GOTO 250
  1761.         NAMER(1,IRES) = 0
  1762.         GOTO 295
  1763. C
  1764. C          PARAM 2: FORMULASTRING
  1765. C
  1766.   250 IF (LGHSTR.EQ.0) GOTO 850
  1767.       IFORM(1,IRES) = LGHSTR
  1768.       DO 260 I=1,LGHSTR
  1769.   260   IFORM(I+1,IRES) = ISTRIV(I)
  1770. C
  1771. C          CHECK SYNTAX AND CONVERT TO REVERSE POLISH
  1772. C
  1773.       CALL FORMUL (NAMEV,ITYPV,NEEDV,IFORM(1,IRES),IRPOL,ITYCHK)
  1774.       IF (IERROR.NE.0) GOTO 900
  1775. C
  1776. C          EXECUTE FORMULA IF IT CONTAINS CONSTANTS ONLY
  1777. C
  1778.   265 IF (ITYCHK.NE.ICONST) GOTO 280
  1779.       CALL FORMEX (VALUEV,IRPOL)
  1780.       IF (IERROR.NE.0) GOTO 280
  1781.         WRITE (NFLOG,2030) VALUEV(1)
  1782. C
  1783. C          SAVE NAME AND UPDATE VARES IN DATABASE
  1784. C
  1785.   280 DO 290 I=1,8
  1786.   290   NAMER(I,IRES) = IANUMV(I,1)
  1787.   295 GOTO 140
  1788. C
  1789. CCCCCCCCCC  EXECUTING R-COMMAND - FIND RESULTANTSTRING
  1790. C
  1791.   300 DO 320 IRES=1,MRES
  1792.         DO 310 I=1,8
  1793.           ICODE = NAMER(I,IRES)
  1794.           IF (IANUMV(I,2).NE.ICODE) GOTO 320
  1795.           CALL APCHAR(ICODE)
  1796.           NAMERC(I) = ICODE
  1797.   310     CONTINUE
  1798.         GOTO 325
  1799.   320   CONTINUE
  1800.       WRITE (NFLOG,2050)
  1801.       GOTO 800
  1802. C
  1803. C          LIST FORMULASTRING
  1804. C
  1805.   325 WRITE (NFLIST,2070) NAMERC
  1806.       IEND = IFORM(1,IRES) + 1
  1807.       DO 330 I=1,IEND
  1808.         IFORM(I,1) = IFORM(I,IRES)
  1809.         IF (I.EQ.1) GOTO 330
  1810.         IFORM(I,2) = IFORM(I,1)
  1811.         CALL APCHAR (IFORM(I,2))
  1812.   330   CONTINUE
  1813.       WRITE (NFLIST,2100) (IFORM(I,2),I=2,IEND)
  1814.       WRITE (NFLIST,2110)
  1815. C
  1816. C          CHECK SYNTAX AND CONVERT TO REVERSE POLISH
  1817. C
  1818.       CALL FORMUL (NAMEV,ITYPV,NEEDV,IFORM,IRPOL,ITYCHK)
  1819.         IF (IERROR.NE.0) GOTO 900
  1820. C
  1821.       IF (ITYCHK.EQ.INODE .OR. ITYCHK.EQ.IELEM) GOTO 335
  1822.       WRITE (NFLOG,2060)
  1823.       GOTO 800
  1824. C
  1825. C          LIST NEEDED VARIABLES AND CONSTANTS
  1826. C
  1827.   335 DO 350 I=1,8
  1828.         DO 350 J=1,MVAR
  1829.   350     CALL APCHAR (NAMEV(I,J))
  1830.       IETYP = 0
  1831.       DO 380 IVAR=1,MVAR
  1832.         IF (NEEDV(IVAR).EQ.0) GOTO 370
  1833.         ITYVAR = ITYPV(IVAR)
  1834.         KIND  = KINDV(IVAR)
  1835.         IF (ITYVAR.EQ.ICONST) GOTO 360
  1836.           J = 3
  1837.           IF (ITYVAR.EQ.IELEM) GOTO 355
  1838.           NDIR = NDIRV(IVAR)
  1839.           CALL KINDN (NDIR,KIND,KINDHD)
  1840.   353     WRITE (NFLIST,2080) (NAMEV(I,IVAR),I=1,8),(KINDHD(I),I=1,J)
  1841.           GOTO 380
  1842. C
  1843.   355 IF (IETYP.EQ.0) IETYP = IETYPV(IVAR)
  1844.       IF (IETYP.EQ.IETYPV(IVAR)) GOTO 357
  1845.         WRITE (NFLOG,2120)
  1846.         GOTO 800
  1847.   357 INDNL = 1
  1848.       NTABLE = 0
  1849.       CALL KINDE (IETYP,INDNL,NTABLE,KIND,KINDHD)
  1850.       IF (IETYP.NE.IBEAM .AND. IETYP.NE.ISOBEA) GOTO 353
  1851.       IF (IETYP.EQ.IBEAM .AND. KIND.GT.3) GOTO 353
  1852.       INDNL = 0
  1853.       NTABLE = -1
  1854.       CALL KINDE (IETYP,INDNL,NTABLE,KIND,KINDHD(5))
  1855.       J = 7
  1856.       GOTO 353
  1857. C
  1858.   360   WRITE (NFLIST,2090) (NAMEV(I,IVAR),I=1,8),VALUEV(IVAR)
  1859.   370   KINDV(IVAR) = 0
  1860.   380   CONTINUE
  1861. C
  1862. CCCCCCCCCCCCCCCCCCC   NODAL RLIST, RMAX, REXCEED   CCCCCCCCCCCCCC
  1863. C
  1864.   400 IXPAR = 3
  1865.       ICALL = ICALLR
  1866.       IF (NCMD.LT.KRLIST) GOTO 500
  1867.       IF (ITYCHK.EQ.IELEM) GOTO 420
  1868. C
  1869. C          BLANK COMMON LAYOUT FOR NLIST2
  1870. C
  1871. C                                                TIMEN
  1872.       I12 = I11 + NSTEN * ISURL
  1873. C                                                NSTEPN
  1874.       I13 = I12 + NSTEN
  1875.       CALL ALIGN (I13)
  1876. C                                                NZONE
  1877.       I14 = I13 + MXNP
  1878. C                                                RSDCOS
  1879.       I15 = I14 + NSKEWS * 9 * ISURL
  1880. C                                                IDRN
  1881.       I16 = I15
  1882.       IF (NSKEWS.GT.0 .AND. LSKEW.EQ.0)
  1883.      1  I16 = I15 + (NDOF + 2) * MXNP
  1884.       CALL SIZE (I16)
  1885.       IF (IERROR.NE.0) GOTO 900
  1886. C
  1887.       NVAR = 1
  1888.         CALL NLIST2 (NVAR,
  1889.      1     VALUEV,NDIRV,KINDV,A(N11),IA(I12),IA(I13),IRPOL,
  1890.      2     IA(I06),IA(I08),IA(I14),IA(I15))
  1891.       GOTO 900
  1892. C
  1893. CCCCCCCCC    ELEMENT RLIST, RMAX, REXCEED    CCCCCCCCCCCCCCCC
  1894. C
  1895. C          BLANK COMMON FOR ELIST2
  1896. C                                                TIMEE
  1897.   420 I12 = I11 + NSTEE * ISURL
  1898. C                                                NSTEPE
  1899.       I13 = I12 + NSTEE
  1900.       CALL ALIGN (I13)
  1901. C                                                NPAR
  1902.       I14 = I13 + NELPAR * MXEG
  1903. C                                                EDATA
  1904.       I15 = I14 + (ISURL + 2) * MXEL
  1905. C                                                ITABLE
  1906.       I16 = I15 + MXITAB
  1907. C                                                IEZONE
  1908.       I17 = I16 + MXEL
  1909.       IF (IBITZ.EQ.IWHOLE) I17 = I16
  1910. C                                                ERES
  1911.       I18 = I17 + MXERES * ISURL
  1912. C                                                IXMAXA
  1913.       I19 = I18 + NEGAT * 9
  1914. C                                                NERPTS
  1915.       I20 = I19 + MXEL
  1916. C                                                IDERPT
  1917.       IXEND = I20 + MXIDER
  1918.       CALL SIZE (IXEND)
  1919.         IF (IERROR.NE.0) GOTO 900
  1920. C
  1921.       CALL ELIST2 (VALUEV,IETYP,KINDV,IRPOL,
  1922.      1  IA(I11),IA(I12),IA(I13),NELPAR,IA(I14),IA(I15),IA(I16),
  1923.      2  IA(I17),IA(I18),IA(I19),IA(I20),IXEND,IA(I06),IA(I07))
  1924.       GOTO 900
  1925. C
  1926. C
  1927. CCCCCCCC    NODAL RHIST   CCCCCCCCCCCCCCCCCC
  1928. C
  1929.   500 IF (NCMD.NE.KRHIST) GOTO 550
  1930.       IF (ITYCHK.EQ.IELEM) GOTO 520
  1931. C
  1932. C          BLANK COMMON FOR NHIST2
  1933. C
  1934. C                                                TIMEN
  1935.       N12 = N11 + NSTEN
  1936. C                                                TIMEPL (FOR PLOT)
  1937.       N13 = N12 + NSTEN + 2
  1938. C                                                VARPL (FOR PLOT)
  1939.       N14 = N13 + NSTEN + 2
  1940. C                                                RSDCOS
  1941.       I15 = (N14 + NSKEWS * 9) * ISURL
  1942. C                                                IDRN
  1943.       I16 = I15
  1944.       IF (NSKEWS.GT.0)
  1945.      1  I16 = I15 + (NDOF + 2) * MXNP
  1946. C                                                ISTRP
  1947.       I17 = I16 + MLINEN * 3
  1948. C                                                NODEP
  1949.       I18 = I17 + MLINEN * 99
  1950. C                                                NAMEP
  1951.       I19 = I18 + MLINEN * 9
  1952.       CALL SIZE(I19)
  1953.         IF (IERROR.NE.0) GOTO 900
  1954. C
  1955.       CALL NHIST2 (IDUM,NDIRV,KINDV,VALUEV,
  1956.      1             A(N11),A(N12),A(N13),IRPOL,A(N14),IA(I15),
  1957.      2             IA(I16),IA(I17),IA(I18))
  1958.       GOTO 900
  1959. C
  1960. C
  1961. CCCCCCCCCCC       ELEMENT RHIST    CCCCCCCCC
  1962. C
  1963. C          BLANK COMMON LAYOUT FOR EHIST2
  1964. C                                                TIMEE
  1965.   520 N12 = N11 + NSTEE
  1966. C                                                TIMEPL (FOR PLOT)
  1967.       N13 = N12 + NSTEE + 2
  1968. C                                                VARPL (FOR PLOT)
  1969.       N14 = N13 + NSTEE + 2
  1970. C                                                ERES
  1971.       I15 = (N14 + MXERES) * ISURL
  1972. C                                                EDATA
  1973.       I16 = I15 + (ISURL + 2) * MXEL
  1974. C                                                ITABLE
  1975.       I17 = I16 + MXITAB
  1976. C                                                NPAR
  1977.       I18 = I17 + NELPAR * MXEG
  1978. C                                                NERPTS
  1979.       I19 = I18 + MXEL
  1980. C                                                IDERPT
  1981.       I20 = I19 + MXIDER
  1982.       CALL ALIGN (I20)
  1983. C                                                LINEID
  1984.       I21 = I20 + MLINEE * 4
  1985. C                                                NELP
  1986.       I22 = I21 + MLINEE * 98
  1987. C                                                NAMEP
  1988.       I23 = I22 + MLINEE * 8
  1989. C
  1990.       CALL SIZE (I23)
  1991.         IF (IERROR.NE.0) GOTO 900
  1992. C
  1993.       CALL EHIST2 (KINDV,VALUEV,A(N11),A(N12),A(N13),
  1994.      1     A(N14),IA(I15),IA(I16),NELPAR,IA(I17),IA(I18),IA(I19),
  1995.      2     IA(I20),IA(I21),IA(I22),IA(I06),IA(I07),
  1996.      3     IRPOL,IETYP)
  1997.       GOTO 900
  1998. C
  1999. C
  2000. CCCCCC   NODAL RLINE    CCCCCCCCCCCCC
  2001. C
  2002. C          BLANK COMMON LAYOUT FOR NLINE2
  2003. C
  2004.   550 IF (ITYCHK.EQ.IELEM) GOTO 570
  2005. C                                                TIMEN, NSTEPN
  2006.       N12 = N11 + NSTEN + NSTEN / ISURL + 1
  2007. C                                                XPLOT
  2008.       N13 = N12 + 101
  2009. C                                                YPLOT
  2010.       N14 = N13 + 101
  2011. C                                                XYZ
  2012.       N15 = N14 + MXNP * 3
  2013. C                                                RSDCOS
  2014.       I16 = (N15 + NSKEWS * 9) * ISURL
  2015. C                                                IDRN
  2016.       I17 = I16
  2017.       IF (NSKEWS.GT.0 .AND. LSKEW.EQ.0)
  2018.      1  I17 = I16 + (NDOF + 2) * MXNP
  2019. C                                                ISTRP
  2020.       I18 = I17 + MLINEN * 3
  2021. C                                                NODEP
  2022.       I19 = I18 + MLINEN * 99
  2023. C                                                NAMEP
  2024.       I20 = I19 + MLINEN * 8
  2025.       CALL SIZE (I20)
  2026.         IF (IERROR.NE.0) GOTO 900
  2027. C
  2028.       CALL NLINE2 (NDIRV,KINDV,VALUEV,IRPOL,
  2029.      1     A(N11),A(N12),A(N13),A(N14),A(N15),IA(I16),IA(I17),
  2030.      2     IA(I18),IA(I19))
  2031.       GOTO 900
  2032. C
  2033. C
  2034. CCCCCC     ELEMENT RLINE    CCCCCCCCCCCCC
  2035. C
  2036. C          BLANK COMMON LAYOUT FOR ELINE2
  2037. C                                                TIMEE, NSTEPE
  2038.   570 N12 = N11 + NSTEE + NSTEE / ISURL + 1
  2039. C                                                XPLOT
  2040.       N13 = N12 + 51
  2041. C                                                YPLOT
  2042.       N14 = N13 + 51
  2043. C                                                ERES
  2044.       I15 = (N14 + MXERES) * ISURL
  2045. C                                                EDATA
  2046.       I16 = I15 + (ISURL + 2) * MXEL
  2047. C                                                ITABLE
  2048.       I17 = I16 + MXITAB
  2049. C                                                NPAR
  2050.       I18 = I17 + NELPAR * MXEG
  2051. C                                                NERPTS
  2052.       I19 = I18 + MXEL
  2053. C                                                IDERPT
  2054.       I20 = I19 + MXIDER
  2055.       CALL ALIGN (I20)
  2056. C                                                SXYZ
  2057.       I21 = I20 + 0
  2058. C                                                LINEID
  2059.       I22 = I21 + MLINEE * 4
  2060. C                                                NELP
  2061.       I23 = I22 + MLINEE * 98
  2062. C                                                NAMEP
  2063.       I24 = I23 + MLINEE * 8
  2064.       CALL SIZE (I24)
  2065.         IF (IERROR.NE.0) GOTO 900
  2066. C
  2067.       CALL ELINE2 (IA(I06),IA(I07),IETYP,KINDV,VALUEV,
  2068.      -     IRPOL,
  2069.      1     A(N1),A(N12),A(N13),A(N14),IA(I15),IA(I16),NELPAR,IA(I17),
  2070.      2     IA(I18),IA(I19),IA(I20),IA(I21),IA(I22),IA(I23))
  2071.       GOTO 900
  2072. C
  2073. C
  2074.   800 IERROR = 1
  2075.       GOTO 900
  2076.   850 IERROR = 2
  2077.   900 RETURN
  2078. C
  2079.  2000 FORMAT (44H ***ERROR: TOO MANY VARIABLES/CONSTANTS, MAX,I3)
  2080.  2020 FORMAT (35H ***ERROR: TOO MANY RESULTANTS, MAX,I3)
  2081.  2030 FORMAT (13H    RESULT = ,G12.6/)
  2082.  2050 FORMAT (36H ***ERROR: RESULTANTNAME NOT DEFINED)
  2083.  2060 FORMAT(27H ***ERROR: CHECK EXPRESSION)
  2084.  2070 FORMAT(///4X,12HRESULTANT = ,8A1,24H  ARITHMETIC EXPRESSION:)
  2085.  2080 FORMAT (4X,8A1,3H = ,7A4)
  2086.  2090 FORMAT (4X,8A1,3H = ,G12.6)
  2087.  2100 FORMAT (/4X,128A1)
  2088.  2120 FORMAT(50H ***ERROR: EVARIABLES OF DIFFERENT TYPE USED IN
  2089.      1  10HEXPRESSION)
  2090.  2110 FORMAT (1H )
  2091.       END
  2092. C***ADD:CDC***
  2093. CDECK FORMUL
  2094. C***END:CDC***
  2095.       SUBROUTINE FORMUL (NAMEV,ITYPV,NEEDV,IFORM,IRPOL,ITYCHK)
  2096. C
  2097. C          FORMULASTRING CHECK AND CONVERSION TO REVERSE POLISH
  2098. C
  2099.       COMMON /FILES/ NFREAD,NFECHO,NFLOG,NFLIST,LUNODE,LUELEM
  2100.       COMMON /ERROR/ IERROR
  2101.       COMMON /DB/ IOPEN,NFDB,INDXST,IXTNOW,LGP,NWRITS,NREADS,
  2102.      1            LDBC,LDBCTR,LDBCTI,IPHCHK,INSTRI,INRUSE,INSTRU,
  2103.      2            MSUBF,MVIEW,MAXIS,MLINEN,MLINEE,MVAR,MRES,LSKEW,MIDSPL
  2104.       COMMON /SICODE/ I000,I111,I222,I333,I444,I555,I666,I777,I888,I999,
  2105.      1              IBLANK,IAAA,IBBB,ICCC,IDDD,IEEE,IFFF,IGGG,IHHH,IIII,
  2106.      2                IJJJ,IKKK,ILLL,IMMM,INNN,IOOO,IPPP,IQQQ,IRRR,ISSS,
  2107.      3                ITTT,IUUU,IVVV,IWWW,IXXX,IYYY,IZZZ,IPOINT,ICOMMA,
  2108.      4              IPLUS,IMINUS,IEQUAL,ILPAR,IRPAR,ISLASH,IASTER,IAPOST
  2109. C
  2110.       DIMENSION NAMEV(1),ITYPV(1),NEEDV(1),IFORM(1),IRPOL(100)
  2111.       DIMENSION ICHARS(8),KLPRTS(8),NAMEIN(9),LFUNCS(133)
  2112. C
  2113.       DATA IXSEND,ICONST/100,3/
  2114.       DATA KVARIA,KLEFTP,KRIGHP,KCOMMA,KCOMMI,KEND,KFUNC/1,2,3,3,4,5,9/
  2115. C
  2116. C                   +  -  )  *  /  *  (  ,
  2117.       DATA ICHARS /39,40,43,45,44,45,42,38/
  2118.       DATA KLPRTS / 6, 6, 3, 7, 7, 8, 2, 4/
  2119. C
  2120. C          ARRAY LFUNCS CONTAINS FUNCTION NAMES AND -(NR OPERANDS-1)
  2121. C
  2122. C     ABS(X)              AINT(X)             ANINT(X)
  2123. C     MOD(X,Y)            MAX(X,Y,...)        MIN(X,Y,...)
  2124. C     SIGN(X,Y)           DIM(X,Y)            EXP(X)
  2125. C     LOG(X)              LOG10(X)            SIN(X)
  2126. C     COS(X)              TANH(X)             SQRT(X)
  2127. C     ATAN(X)             ATAN2(X,Y)          SINH(X)
  2128. C     COSH(X)             ASIN(X)             ACOS(X)
  2129. C     TAN(X)
  2130.       DATA LFUNCS/
  2131.      111,12,29,10,10,0,   11,19,24,30,10,0,   11,24,19,24,30,0,
  2132.      223,25,14,10,10,-1,  23,11,34,10,10,-19, 23,19,24,10,10,-19,
  2133.      329,19,17,24,10,-1,  14,19,23,10,10,-1,  15,34,26,10,10,0,
  2134.      422,25,17,10,10,0,   22,25,17,01,00,0,   29,19,24,10,10,0,
  2135.      513,25,29,10,10,0,   30,11,24,18,10,0,   29,27,28,30,10,0,
  2136.      611,30,11,24,10,0,   11,30,11,24,02,-1,  29,19,24,18,10,0,
  2137.      713,25,29,18,10,0,   11,29,19,24,10,0,   11,13,25,29,10,0,
  2138.      830,11,24,10,10,0,
  2139.      - 999/
  2140. C
  2141.       IXRPOL = 1
  2142.       IXSTAC = IXSEND
  2143.       IRPOL(IXSEND) = 0
  2144.       INSTAT = 1
  2145.       DO 10 I=1,MVAR
  2146.   10    NEEDV(I) = 0
  2147. C
  2148. CCCCCC     LEXICAL ANALYZER      CCCCCCCCCCCCC
  2149. C
  2150.       IFORML = IFORM(1) + 1
  2151.       IXFORM = 1
  2152.       NAMERR = 0
  2153.       ITYCHK = ICONST
  2154. C
  2155. C          FIND NEXT INPUT TOKEN
  2156. C
  2157.   100 IXFORM = IXFORM + 1
  2158.       IF (IXFORM.GT.IFORML) GOTO 190
  2159.       INCHAR = IFORM(IXFORM)
  2160.       IF (INCHAR.EQ.IBLANK) GOTO 100
  2161.       IF (INCHAR.GT.10.AND.INCHAR.LT.37) GOTO 130
  2162. C
  2163. C          TOKEN STARTS WITH NON-ALPHABETIC CHAR
  2164. C
  2165.       DO 110 ITOKEN=1,8
  2166.         IF (INCHAR.EQ.ICHARS(ITOKEN)) GOTO 120
  2167.   110 CONTINUE
  2168.       GOTO 900
  2169. C
  2170. C          ARITHMETIC OPERAND, PARENTHETIS OR COMMA FOUND
  2171. C
  2172.   120 IF (INCHAR.EQ.IASTER.AND.IFORM(IXFORM+1).EQ.IASTER) GOTO 124
  2173.   122 KLPRTY = KLPRTS(ITOKEN)
  2174.       NOPERA = -1
  2175.       GOTO 200
  2176. C
  2177. C          ** EXPONENTIATION FOUND
  2178. C
  2179.   124 IXFORM = IXFORM + 1
  2180.       ITOKEN = 6
  2181.       GOTO 122
  2182. C
  2183. C          ALPHABETIC FOUND, MUST BE VARIABLE OR FUNCTION NAME
  2184. C
  2185.   130 DO 131 I=1,9
  2186.   131   NAMEIN(I) = IBLANK
  2187.       DO 135 I=1,8
  2188.         NAMEIN(I) = INCHAR
  2189.         IXFORM = IXFORM + 1
  2190.         IF (IXFORM.GT.IFORML) GOTO 140
  2191.         INCHAR = IFORM(IXFORM)
  2192.         IF (INCHAR.GE.37.OR.INCHAR.EQ.IBLANK) GOTO 140
  2193.   135 CONTINUE
  2194.   140 IXFORM = IXFORM - 1
  2195. C
  2196. C          TEST IF FUNCTION NAME
  2197. C
  2198.       ITOKEN = 0
  2199.   141 ITOKEN = ITOKEN + 1
  2200.       I2 = ITOKEN * 6 - 5
  2201.       IF (LFUNCS(I2).EQ.999) GOTO 150
  2202.       DO 145 J=1,5
  2203.         IF (NAMEIN(J).NE.LFUNCS(I2)) GOTO 141
  2204.         I2 = I2 + 1
  2205.   145 CONTINUE
  2206.       IF (NAMEIN(6).NE.IBLANK) GOTO 141
  2207.       KLPRTY = KFUNC
  2208.       NOPERA = LFUNCS(ITOKEN*6)
  2209.       ITOKEN = ITOKEN + 6
  2210.       GOTO 200
  2211. C
  2212. C          TEST IF VARIBLE OR CONSTANT NAME
  2213. C
  2214.   150 KLPRTY = KVARIA
  2215.       NOPERA = 1
  2216.       DO 170 ITOKEN=2,MVAR
  2217.         I2 = ITOKEN * 8 - 8
  2218.         DO 160 J=1,8
  2219.           I2 = I2 + 1
  2220.           IF (NAMEIN(J).NE.NAMEV(I2)) GOTO 170
  2221.   160   CONTINUE
  2222. C
  2223. C          CHECK THAT NODAL- AND ELEMENT VARIABLES ARE NOT MIXED
  2224. C
  2225.         ITYNEW = ITYPV(ITOKEN)
  2226.         NEEDV(ITOKEN) = 1
  2227.         IF (ITYNEW.EQ.ICONST) GOTO 200
  2228.         IF (ITYCHK.EQ.ICONST) ITYCHK = ITYNEW
  2229.         IF (ITYNEW.NE.ITYCHK) GOTO 901
  2230.         GOTO 200
  2231.   170 CONTINUE
  2232.       NAMERR = 1
  2233.       GOTO 200
  2234. C
  2235. C          END OF FORMULA STRING
  2236. C
  2237.   190 KLPRTY = KEND
  2238. C
  2239. CCCCCC     PARSER - GRAMMAR CHECK     CCCCCCCCCCCCCCCC
  2240. C
  2241.   200 CONTINUE
  2242.       GOTO (210,220,230,240,270,260,270,270,290), KLPRTY
  2243. C
  2244. C          VARIABLE OR CONSTANT
  2245. C
  2246.   210 IF (INSTAT.GT.2) GOTO 900
  2247.       INSTAT = 4
  2248.       IXRPOL = IXRPOL + 2
  2249.       IF (IXRPOL.GE.IXSTAC) GOTO 903
  2250.       IRPOL(IXRPOL-1) = ITOKEN
  2251.       IRPOL(IXRPOL)   = NOPERA
  2252.       GOTO 100
  2253. C
  2254. C          (
  2255. C
  2256.   220 IF (INSTAT.EQ.4) GOTO 900
  2257.       INSTAT = 1
  2258.       GOTO 300
  2259. C
  2260. C          )
  2261. C
  2262.   230 IF (INSTAT.NE.4) GOTO 900
  2263.       GOTO 400
  2264. C
  2265. C          ,
  2266. C
  2267.   240 IF (INSTAT.NE.4) GOTO 900
  2268.       INSTAT = 1
  2269.       GOTO 400
  2270. C
  2271. C          + -
  2272. C
  2273.   260 GOTO (261,900,900,270), INSTAT
  2274.   261 INSTAT = 2
  2275.       IF (ITOKEN.NE.2) GOTO 100
  2276.       ITOKEN = 3
  2277.       NOPERA = 0
  2278.       GOTO 400
  2279. C
  2280. C          * / ** END
  2281. C
  2282.   270 IF (INSTAT.NE.4) GOTO 900
  2283.       INSTAT = 2
  2284.       GOTO 400
  2285. C
  2286. C          FUNCTION
  2287. C
  2288.   290 IF (INSTAT.GT.2) GOTO 900
  2289.       INSTAT = 3
  2290.       GOTO 300
  2291. C
  2292. C          STACK NEW OPERATOR, ( OR ,
  2293. C
  2294.   300 IXSTAC = IXSTAC - 3
  2295.       IF (IXRPOL.GE.IXSTAC) GOTO 903
  2296.       IF (KLPRTY.EQ.KCOMMI) KLPRTY = KCOMMA
  2297.       IRPOL(IXSTAC  ) = KLPRTY
  2298.       IRPOL(IXSTAC+1) = ITOKEN
  2299.       IRPOL(IXSTAC+2) = NOPERA
  2300.       GOTO 100
  2301. C
  2302. C          COMPARE KLPRTY AND STACK, UNSTACK IF NECESSARY
  2303. C
  2304.   400 NCOMMA = 0
  2305.   402 KLPRST = IRPOL(IXSTAC)
  2306.       IF (KLPRST.LT.KLPRTY) GOTO 420
  2307.       IF (KLPRST.EQ.KCOMMA) GOTO 410
  2308.       IXRPOL = IXRPOL + 2
  2309.       IRPOL(IXRPOL-1) = IRPOL(IXSTAC+1)
  2310.       IRPOL(IXRPOL  ) = IRPOL(IXSTAC+2)
  2311.   408 IXSTAC = IXSTAC + 3
  2312.       GOTO 402
  2313. C
  2314. C          COMMA IN STACK
  2315. C
  2316.   410 NCOMMA = NCOMMA - 1
  2317.       GOTO 408
  2318. C
  2319. C          UNSTACK LEFT PARENTHETIS
  2320. C
  2321.   420 IF (KLPRTY.NE.KRIGHP) GOTO 430
  2322.       IF (IRPOL(IXSTAC).NE.KLEFTP) GOTO 900
  2323.       IXSTAC = IXSTAC + 3
  2324. C
  2325. C          CHECK NUMBER OF JUST UNSTACKED COMMAS, ONLY VALID
  2326. C          BETWEEN FUNCTION ARGUMENTS
  2327. C
  2328.       IF (IRPOL(IXSTAC).NE.KFUNC) GOTO 430
  2329.       NOPERA = IRPOL (IXSTAC+2)
  2330.       IF (NOPERA.EQ.NCOMMA) GOTO 100
  2331.       IF (NOPERA.NE.-19.OR.NCOMMA.GT.-1) GOTO 900
  2332.       IRPOL(IXSTAC+2) = NCOMMA
  2333.       GOTO 100
  2334.   430 IF (NCOMMA.NE.0) GOTO 900
  2335.       IF (KLPRTY.EQ.KRIGHP) GOTO 100
  2336.       IF (KLPRTY.NE.KEND) GOTO 300
  2337. C
  2338. C          END
  2339. C
  2340.   800 IF (IXSTAC.NE.IXSEND.OR.IXRPOL.EQ.1) GOTO 900
  2341.       IF (NAMERR.EQ.1) GOTO 902
  2342.       IRPOL(1) = IXRPOL
  2343.   899 CONTINUE
  2344.       RETURN
  2345. C
  2346. C          ERROR MESSAGES
  2347. C
  2348.   900 WRITE (NFLOG,2900) IXFORM
  2349.       IERROR = 1
  2350.   980 ITYCHK = 0
  2351.       GOTO 899
  2352.   901 WRITE (NFLOG,2901)
  2353.       GOTO 900
  2354.   902 WRITE (NFLOG,2902)
  2355.       GOTO 980
  2356.   903 WRITE (NFLOG,2903)
  2357.       GOTO 900
  2358.  2900 FORMAT(46H ***ERROR: IN EXPRESSION AT OR BEFORE LOCATION,I4/)
  2359.  2901 FORMAT (45H ***ERROR: MIX OF NODAL AND ELEMENT VARIABLES)
  2360.  2902 FORMAT (50H *** PLEASE DEFINE MISSING VARIABLE(S)/CONSTANT(S)/)
  2361.  2903 FORMAT(29H ***ERROR: TOO BIG EXPRESSION)
  2362.       END
  2363. C***ADD:CDC***
  2364. CDECK FORMEX
  2365. C***END:CDC***
  2366.       SUBROUTINE FORMEX (VALUEV,IRPOL)
  2367. C
  2368. C          FORMULA EXPRESSION EXECUTION FROM REVERSE POLISH
  2369. C
  2370.       DIMENSION VALUEV(1),IRPOL(1),VSTACK(25)
  2371.       COMMON /ERROR/ IERROR
  2372.       COMMON /FILES/ NFREAD,NFECHO,NFLOG,NFLIST,LUNODE,LUELEM
  2373. C
  2374.       IXSTAC = 0
  2375.       IXRPOL = 0
  2376.       IRPOLL = IRPOL(1)
  2377.       GOTO 102
  2378. C
  2379. C          GET OPERAND VALUE
  2380. C
  2381.   101 VTOP = VALUEV(ITOKEN)
  2382.       IF (IXSTAC.GT.25) GOTO 99
  2383. C
  2384. C          STACK OPERAND OR COMPUTED VALUE IN TOP OF STACK
  2385. C
  2386.   100 VSTACK(IXSTAC) = VTOP
  2387. C
  2388. C          NEXT REVERSE POLISH ENTRY
  2389. C
  2390.   102 IXRPOL = IXRPOL + 2
  2391. C
  2392. C          CHECK IF END OF REVERSE POLISH STRING
  2393. C
  2394.       IF (IXRPOL.GT.IRPOLL) GOTO 800
  2395. C
  2396. C          GET TOKEN AND COMPUTE NEW INDEX TO TOP OF STACK
  2397. C
  2398.       ITOKEN = IRPOL(IXRPOL)
  2399.       NOPERA = IRPOL(IXRPOL+1)
  2400.       IXSTAC = IXSTAC + NOPERA
  2401. C
  2402. C          OPERAND
  2403. C
  2404.       IF (NOPERA.EQ.1) GOTO 101
  2405. C
  2406. C          OPERATOR
  2407. C
  2408.       VFIRST = VSTACK(IXSTAC)
  2409.       GOTO ( 1, 2, 3, 4, 5, 6, 7, 8, 9,10,
  2410.      1      11,12,13,14,15,16,17,18,19,20,
  2411.      2      21,22,23,24,25,26,27,28)
  2412.      9      , ITOKEN
  2413. C
  2414. C          VTOP   IS OPERATORS LAST OR ONLY OPERAND
  2415. C          VFIRST IS OPERATORS FIRST OPERAND
  2416. C
  2417.   1   VTOP = VFIRST + VTOP
  2418.       GOTO 100
  2419. C
  2420.   2   VTOP = VFIRST - VTOP
  2421.       GOTO 100
  2422. C
  2423.   3   VTOP = - VTOP
  2424.       GOTO 100
  2425. C
  2426.   4   VTOP = VFIRST * VTOP
  2427.       GOTO 100
  2428. C
  2429. C          DIVISION BY ZERO IS NOT ALLOWED
  2430. C
  2431.   5   IF (VTOP.EQ.0.0) GOTO 91
  2432.       VTOP = VFIRST / VTOP
  2433.       GOTO 100
  2434. C
  2435. C          QUANTITY RAISED MUST BE GREATER THAN ZERO
  2436. C
  2437.   6   IF (VFIRST.LE.0.0) GOTO 92
  2438.       VTOP = VFIRST ** VTOP
  2439.       GOTO 100
  2440. C
  2441.   7   VTOP = ABS(VTOP)
  2442.       GOTO 100
  2443. C
  2444.   8   VTOP = AINT(VTOP)
  2445.       GOTO 100
  2446. C
  2447.   9   VTOP = VTOP + 0.5
  2448.       IF (VTOP.GE.0.5) GOTO 8
  2449.       VTOP = VTOP - 1.0
  2450.       GOTO 8
  2451. C
  2452. C          DIVISION BY ZERO IS NOT ALLOWED
  2453. C
  2454.   10  IF (VTOP.EQ.0.0) GOTO 91
  2455.       VTOP = AMOD(VFIRST,VTOP)
  2456.       GOTO 100
  2457. C
  2458.   11  IX = IXSTAC
  2459.   211 VTOP = AMAX1(VSTACK(IX),VTOP)
  2460.       IX = IX + 1
  2461.       NOPERA = NOPERA + 1
  2462.       IF (NOPERA.LT.0) GOTO 211
  2463.       GOTO 100
  2464. C
  2465.   12  IX = IXSTAC
  2466.   212 VTOP = AMIN1(VSTACK(IX),VTOP)
  2467.       IX = IX + 1
  2468.       NOPERA = NOPERA + 1
  2469.       IF (NOPERA.LT.0) GOTO 212
  2470.       GOTO 100
  2471. C
  2472.   13  VTOP = SIGN(VFIRST,VTOP)
  2473.       GOTO 100
  2474. C
  2475.   14  VTOP = DIM(VFIRST,VTOP)
  2476.       GOTO 100
  2477. C
  2478.   15  VTOP = EXP(VTOP)
  2479.       GOTO 100
  2480. C
  2481. C          NATURAL LOGARITHM ARGUMENT MUST BE GREATER THAN ZERO
  2482. C
  2483.   16  IF (VTOP.LE.0.0) GOTO 93
  2484.       VTOP = ALOG(VTOP)
  2485.       GOTO 100
  2486. C
  2487. C          COMMON LOGARITHM ARGUMENT MUST BE GREATER THAN ZERO
  2488. C
  2489.   17  IF (VTOP.LE.0.0) GOTO 93
  2490.       VTOP = ALOG10(VTOP)
  2491.       GOTO 100
  2492. C
  2493.   18  VTOP = SIN(VTOP)
  2494.       GOTO 100
  2495. C
  2496.   19  VTOP = COS(VTOP)
  2497.       GOTO 100
  2498. C
  2499.   20  VTOP = TANH(VTOP)
  2500.       GOTO 100
  2501. C
  2502. C          SQUARE ROOT ARGUMENT MUST BE GREATER THAN OR EQUAL TO ZERO
  2503. C
  2504.   21  IF (VTOP.LT.0.0) GOTO 94
  2505.       VTOP = SQRT(VTOP)
  2506.       GOTO 100
  2507. C
  2508.   22  VTOP = ATAN(VTOP)
  2509.       GOTO 100
  2510. C
  2511.   23  VTOP = ATAN2(VFIRST,VTOP)
  2512.       GOTO 100
  2513. C
  2514.   24  VTOP = SINH(VTOP)
  2515.       GOTO 100
  2516. C
  2517.   25  VTOP = COSH(VTOP)
  2518.       GOTO 100
  2519. C
  2520. C          ARCSINE ARGUMENT ABSOLUTE VALUE MUST BE .LE. 1.0
  2521. C
  2522.   26  IF (ABS(VTOP).GT.1.0) GOTO 95
  2523.       VTOP = ASIN(VTOP)
  2524.       GOTO 100
  2525. C
  2526. C          ARCCOSINE ARGUMENT ABSOLUTE VALUE MUST BE .LE. 1.0
  2527. C
  2528.   27  IF (ABS(VTOP).GT.1.0) GOTO 95
  2529.       VTOP = ACOS(VTOP)
  2530.       GOTO 100
  2531. C
  2532.   28  VTOP = TAN(VTOP)
  2533.       GOTO 100
  2534. C
  2535.   91  WRITE (NFLOG,2091)
  2536.       GOTO 99
  2537.   92  WRITE (NFLOG,2092)
  2538.       GOTO 99
  2539.   93  WRITE (NFLOG,2093)
  2540.       GOTO 99
  2541.   94  WRITE (NFLOG,2094)
  2542.       GOTO 99
  2543.   95  WRITE (NFLOG,2095)
  2544.   99  IERROR = 1
  2545.       WRITE (NFLOG,2000)
  2546.       VSTACK(1) = 0.0
  2547. C
  2548.   800 VALUEV(1) = VSTACK(1)
  2549.       RETURN
  2550.  2000 FORMAT(52H ***ERROR: ARITHMETIC EXPRESSION RESULT IS UNDEFINED)
  2551.  2091 FORMAT(11X,16HDIVISION BY ZERO)
  2552.  2092 FORMAT(11X,32HQUANTITY RAISED NOT GREATER ZERO)
  2553.  2093 FORMAT(11X,30HLOGARITHM ARG NOT GREATER ZERO)
  2554.  2094 FORMAT(11X,25HSQUARE ROOT ARG LESS ZERO)
  2555.  2095 FORMAT(11X,21HARC ARG GREATER +-1.0)
  2556.       END
  2557. C*NEW FILE
  2558. C***END:IBM***
  2559.       SUBROUTINE COMND
  2560. C
  2561.       DIMENSION ICMDPA(20,50),KEYTYP(321),
  2562.      1          KEY(4),ICMDCH(8),KEYLAS(3),KEYLOW(4),KEYNOW(3),
  2563.      2          ICP001(200),ICP011(200),ICP021(200),ICP031(200),
  2564.      3          ICP041(200),
  2565.      5          KTY001(285),KTY286(36)
  2566. C
  2567.       COMMON /ERROR/ IERROR
  2568.       COMMON /CNTRL/ IBATCH,NBSU,LSTC,LSTF,LSTDB,ISURL,ITWO,LINPAG,LINE
  2569.       COMMON /FILES/ NFREAD,NFECHO,NFLOG,NFLIST,LUNODE,LUELEM
  2570.       COMMON /PARAM/ REALV(100),NCMD,NLASTP,ITYPE(20),INTV(100),
  2571.      1               IANUMV(160),LGHSTR,INTEG,IREAL,IANUM,ISTRIN,IOMIT
  2572.       COMMON /FIELDC/ REALI,INPREC(80),INPOS,ITYPEI,INTI,IANUMI(128),
  2573.      1               KEYI(8),NPOSRE,INECHO,MXSIGI,MXSIGR,MXSIGE,MXSTRL,
  2574.      2               ISTRIL,NFIELD,NPOSIN
  2575.       COMMON /SICODE/ I000,I111,I222,I333,I444,I555,I666,I777,I888,I999,
  2576.      1              IBLANK,IAAA,IBBB,ICCC,IDDD,IEEE,IFFF,IGGG,IHHH,IIII,
  2577.      2                IJJJ,IKKK,ILLL,IMMM,INNN,IOOO,IPPP,IQQQ,IRRR,ISSS,
  2578.      3                ITTT,IUUU,IVVV,IWWW,IXXX,IYYY,IZZZ,IPOINT,ICOMMA,
  2579.      4              IPLUS,IMINUS,IEQUAL,ILPAR,IRPAR,ISLASH,IASTER,IAPOST
  2580. C
  2581. C
  2582. C
  2583.       EQUIVALENCE (ICMDPA(1,01),ICP001(1)),
  2584.      1            (ICMDPA(1,11),ICP011(1)),
  2585.      2            (ICMDPA(1,21),ICP021(1)),
  2586.      3            (ICMDPA(1,31),ICP031(1)),
  2587.      4            (ICMDPA(1,41),ICP041(1)),
  2588.      6            (KEYTYP  (1),KTY001(1)),
  2589.      7            (KEYTYP(286),KTY286(1))
  2590. C
  2591.       DATA IEND,IERR,IUNSPE/5,6,8/
  2592.       DATA MAXANU,MAXPAR/20,100/
  2593. C
  2594. C
  2595. C          COMMAND AND PARAMETER ARRAYS
  2596. C
  2597. C          ARRAY ICMDPA CONTAINS COMMAND NAMES AND PARAMETER ADDRESSES
  2598. C
  2599.       DATA ICP001 /
  2600.      1 29,11,23,15,10, 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,
  2601.      2 15,24,14,10,10, 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,
  2602.      3 30,15,29,30,10, 4,7,10,13,16,19,22,25,1,0,0,0,0,0,0,
  2603.      4 16,19,22,15,10, 28,31,34,37,40,43,46,1,0,0,0,0,0,0,0,
  2604.      5 13,25,24,30,10, 49,31,52,55,58,61,37,64,67,70,
  2605.      -                      73,76,262,1,0,
  2606.      6 14,11,30,11,12, 79,82,40,85,1,0,0,0,0,0,0,0,0,0,0,
  2607.      7 34,00,07,10,10, 1,0,0,0,0,0,0,0,0,0,0,0,0,0,0,
  2608.      8 34,00,08,10,10, 1,0,0,0,0,0,0,0,0,0,0,0,0,0,0,
  2609.      9 34,00,09,10,10, 1,0,0,0,0,0,0,0,0,0,0,0,0,0,0,
  2610.      - 15,32,15,13,10, 163,211,169,274,85,271,0,0,0,0,0,0,0,0,0/
  2611. C
  2612.       DATA ICP011 /
  2613.      1 16,28,11,23,15, 88,91,94,97,100,0,0,0,0,0,0,0,0,0,0,
  2614.      2 29,31,12,16,10, 103,106,109,112,115,0,0,0,0,0,0,0,0,0,0,
  2615.      3 32,19,15,33,10, 103,118,121,124,127,0,0,0,0,0,0,0,0,0,0,
  2616.      4 12,36,10,10,10, 130,79,133,136,139,142,145,148,0,0,0,0,0,0,0,
  2617.      5 15,36,10,10,10, 130,79,151,154,0,0,0,0,0,0,0,0,0,0,0,
  2618.      6 15,17,36,10,10, 130,79,157,0,0,0,0,0,0,0,0,0,0,0,0,
  2619.      7 36,36,10,10,10, 130,79,160,0,0,0,0,0,0,0,0,0,0,0,0,
  2620.      8 23,15,29,18,10, 163,166,169,76,55,172,175,178,181,184,187,
  2621.      -                    118,121,37,190,
  2622.      9 23,25,14,15,10, 163,166,193,76,55,172,175,178,181,184,187,
  2623.      -                    118,121,37,190,
  2624.      - 11,34,19,29,10, 103,118,121,265,196,199,202,0,0,0,0,0,0,0,0/
  2625. C
  2626.       DATA ICP021 /
  2627.      1 30,15,34,30,10, 190,118,121,205,208,0,0,0,0,0,0,0,0,0,0,
  2628.      2 24,18,19,29,30, 178,55,211,214,217,220,223,226,229,232,85,190,
  2629.      -                      0,0,0,
  2630.      3 15,18,19,29,30, 151,181,40,211,214,217,220,223,226,229,
  2631.      -                     232,85,190,0,0,
  2632.      4 24,26,10,10,10, 130,235,0,0,0,0,0,0,0,0,0,0,0,0,0,
  2633.      5 24,22,19,24,15, 238,55,211,169,223,226,229,232,85,190,0,0,0,0,0,
  2634.      6 15,26,10,10,10, 130,151,241,244,0,0,0,0,0,0,0,0,0,0,0,
  2635.      7 15,22,19,24,15, 238,211,169,223,226,229,232,85,190,0,0,0,0,0,0,
  2636.      8 24,22,19,29,30, 163,55,211,214,217,220,0,0,0,0,0,0,0,0,0,
  2637.      9 17,22,19,29,30, 163,214,217,220,0,0,0,0,0,0,0,0,0,0,0,
  2638.      - 15,19,24,16,25, 163,178,40,0,0,0,0,0,0,0,0,0,0,0,0/
  2639. C
  2640.       DATA ICP031 /
  2641.      1 15,22,19,29,30, 163,214,217,220,190,0,0,0,0,0,0,0,0,0,0,
  2642.      2 24,23,11,34,10, 163,55,211,214,217,247,178,0,0,0,0,0,0,0,0,
  2643.      3 24,15,34,10,10, 163,55,211,214,217,247,250,0,0,0,0,0,0,0,0,
  2644.      4 15,23,11,34,10, 163,214,217,247,178,190,0,0,0,0,0,0,0,0,0,
  2645.      5 15,15,34,10,10, 163,214,217,247,250,190,0,0,0,0,0,0,0,0,0,
  2646.      6 24,32,10,10,10, 130,55,211,0,0,0,0,0,0,0,0,0,0,0,0,
  2647.      7 15,32,10,10,10, 130,247,211,0,0,0,0,0,0,0,0,0,0,0,0,
  2648.      8 13,10,10,10,10, 130,250,0,0,0,0,0,0,0,0,0,0,0,0,0,
  2649.      9 28,15,29,10,10, 130,208,0,0,0,0,0,0,0,0,0,0,0,0,0,
  2650.      - 28,18,19,29,30, 253,256,214,217,220,223,226,229,232,85,190,
  2651.      -                      0,0,0,0/
  2652. C
  2653.       DATA ICP041 /
  2654.      1 28,22,19,24,15, 238,256,169,223,226,229,232,85,190,0,0,0,0,0,0,
  2655.      2 28,22,19,29,30, 163,256,214,217,220,0,0,0,0,0,0,0,0,0,0,
  2656.      3 28,23,11,34,10, 163,256,214,217,247,178,0,0,0,0,0,0,0,0,0,
  2657.      4 28,15,34,10,10, 163,256,214,217,247,250,0,0,0,0,0,0,0,0,0,
  2658.      5 23,22,19,29,30, 163,55,259,61,0,0,0,0,0,0,0,0,0,0,0,
  2659.      6 34,04,06,10,10, 1,0,0,0,0,0,0,0,0,0,0,0,0,0,0,
  2660.      7 34,04,07,10,10, 1,0,0,0,0,0,0,0,0,0,0,0,0,0,0,
  2661.      8 34,04,08,10,10, 1,0,0,0,0,0,0,0,0,0,0,0,0,0,0,
  2662.      9 34,04,09,10,10, 1,0,0,0,0,0,0,0,0,0,0,0,0,0,0,
  2663.      - 34,05,00,10,10, 1,0,0,0,0,0,0,0,0,0,0,0,0,0,0/
  2664. C
  2665. C          ARRAY KEYTYP CONTAINS PARAMETER TYPE AND KEYNAME
  2666. C          LAST ENTRY MUST BE ZZZZ (3636,3636) FOR PRINT SORT
  2667. C          FREE ENTRY = 0000 (0000,0000)
  2668. C
  2669.       DATA KTY001/
  2670. C
  2671.      1-8,1010,1010, 1,2426,2529, 1,2412,2931, 1,2229,3011, 1,2229,3013,
  2672.      2 1,2229,3016, 1,2229,3014, 1,1929,3128, 1,1930,3325, 1,2810,1010,
  2673.      3 1,1513,1010, 1,2225,1010, 1,2219,1010, 1,2610,1010, 1,2231,2425,
  2674.      4 1,2231,1522, 1,1210,1010, 2,1810,1010, 1,1410,1010, 1,2935,1010,
  2675.      5 1,2315,1010, 1,2921,1010, 1,2429,3112, 1,2428,1531, 1,2319,1429,
  2676.      6 1,2510,1010, 3,2526,1010, 1,1610,1010, 1,2210,1010, 2,2910,1010,
  2677.      7 2,3416,1010, 2,3516,1010, 2,3429,1010, 2,3529,1010, 1,1910,1010,
  2678.      8 2,3416,0110, 2,3416,0210, 2,3516,0110, 2,3516,0210, 2,3410,1010,
  2679.      9 2,3510,1010, 2,3610,1010, 2,2810,1010, 3,2410,1010, 2,3423,1924,
  2680.      - 2,3423,1134, 2,3523,1924, 2,3523,1134, 2,3623,1924, 2,3623,1134,
  2681.      1 1,1517,1010,-1,1501,1010,-1,1517,0110,-3,3625,2401, 3,3610,1010,
  2682.      2 1,3210,1010, 2,3010,1010, 2,1729,1010, 2,1423,1010, 1,2410,1010,
  2683.      3 1,1510,1010, 1,3015,1010, 1,1134,1010, 1,2910,1010, 1,2310,1010,
  2684.      4 2,3223,1924, 2,3223,1134, 7,2211,1010, 2,1110,1010, 7,2930,1010,
  2685.      5 1,2110,1010, 2,3029,1010, 2,3015,1010, 1,3029,2110, 1,3410,1010,
  2686.      6 1,3510,1010, 1,2935,1010, 1,2929,2110,-1,2401,1010, 3,2219,2410,
  2687.      7 1,1501,1010,-1,2601,1010, 1,3035,1010, 2,3210,1010, 3,2610,1010,
  2688.      8 3,2810,1010, 1,2329,1010, 2,2311,1010, 2,2210,1010, 0,3636,3636,
  2689.      9 3,1610,1010, 2,2215,1010, 0,3636,3636, 0,3636,3636, 0,3636,3636/
  2690.       DATA KTY286/
  2691.      1 0,3636,3636, 0,3636,3636, 0,3636,3636, 0,3636,3636, 0,3636,3636,
  2692.      2 0,3636,3636, 0,3636,3636, 0,3636,3636, 0,3636,3636, 0,3636,3636,
  2693.      3 0,3636,3636, 0,3636,3636/
  2694. C
  2695. C
  2696. C          READ COMMAND
  2697. C
  2698.   100 NFIELD = -1
  2699.       CALL FIELD
  2700.       IF (ITYPEI.NE.IANUM) GOTO 810
  2701. C
  2702. C          TRY TO FIND COMMAND IN ICMDPA ARRAY
  2703. C
  2704.       NCMDIN = 0
  2705.       NPOSEQ = 0
  2706.       DO 150 ICMD=1,50
  2707.         IPOSEQ = 0
  2708.         DO 130 I=1,5
  2709.           ICHAR = ICMDPA(I,ICMD)
  2710.           IF (ICHAR.EQ.IBLANK) GOTO 140
  2711.           IF (ICHAR.NE.IANUMI(I)) GOTO 150
  2712.           IPOSEQ = I
  2713.   130     CONTINUE
  2714.   140   IF (IPOSEQ.LE.NPOSEQ) GOTO 150
  2715.           NCMDIN = ICMD
  2716.           NPOSEQ = IPOSEQ
  2717.   150   CONTINUE
  2718. C
  2719. C          TEST IF COMMAND NOT FOUND
  2720. C
  2721.   225 IF (NPOSEQ.EQ.0) GOTO 810
  2722. C
  2723. C
  2724. C          TEST IF COMMAND 'SAME'
  2725. C
  2726.       IF (NCMDIN.NE.1) GOTO 240
  2727.       IF (NCMD.GT.1) GOTO 290
  2728.       NCMD = IABS(NCMD)
  2729.       IF (NCMD.EQ.9999.OR.IBATCH.EQ.1) GOTO 810
  2730.       GOTO 290
  2731. C
  2732. C          NEW COMMAND, CLEAR INPUT ARRAYS
  2733. C
  2734.   240 NCMD = NCMDIN
  2735.       NLASTP = 0
  2736.       LGHSTR = 0
  2737.       DO 250 I=1,MAXANU
  2738.         ITYPE(I) = IOMIT
  2739.   250 CONTINUE
  2740.       DO 260 I=1,MAXPAR
  2741.         INTV(I) = 0
  2742.   260   REALV(I) = 0.0
  2743.       J = 8 * MAXANU
  2744.       DO 270 I=1,J
  2745.   270   IANUMV(I) = IBLANK
  2746. C
  2747. C          INITIALIZE PARAMETER READ
  2748. C
  2749.   290 NPAR = 0
  2750.       IPARNR = 0
  2751.       NFIELD = 0
  2752.       ICMD = IABS(NCMD)
  2753. C
  2754. C          READ NEXT PARAMETER
  2755. C
  2756. C
  2757.   300 CALL FIELD
  2758.       NFIELD = NFIELD + 1
  2759.       IF (ITYPEI.EQ.IEND) GOTO 8000
  2760.       IF (KEYI(1).EQ.IBLANK) GOTO 500
  2761. C
  2762. C          TRY TO FIND PARAMETER KEYNAME IN ARRAY
  2763. C
  2764.       NPOSEQ = 0
  2765.       DO 450 IPARNR = 1,15
  2766.         KTYAD = ICMDPA(IPARNR+5,ICMD)
  2767.         IF (KTYAD.EQ.0) GOTO 450
  2768.         I = KEYTYP(KTYAD+1)
  2769.         KEY(1) = I / 100
  2770.         KEY(2) = I - KEY(1) * 100
  2771.         I = KEYTYP(KTYAD+2)
  2772.         KEY(3) = I / 100
  2773.         KEY(4) = I - KEY(3) * 100
  2774.         IPOSEQ = 0
  2775.         DO 420 I=1,4
  2776.           IF (KEY(I).EQ.IBLANK) GOTO 430
  2777.           IF (KEY(I).NE.KEYI(I)) GOTO 450
  2778.           IPOSEQ = I
  2779.   420   CONTINUE
  2780.   430   IF (IPOSEQ.LT.NPOSEQ) GOTO 450
  2781.         NPOSEQ = IPOSEQ
  2782.         NPAR = IPARNR
  2783.   450 CONTINUE
  2784. C
  2785. C          TEST IF KEYNAME NOT FOUND IN ARRAY
  2786. C
  2787.       IPARNR = NPAR
  2788.       IF (NPOSEQ.GT.0) GOTO 600
  2789.       GOTO 820
  2790. C
  2791. C          NO KEYNAME GIVEN - CHECK IF TOO MANY PARAMETERS
  2792. C
  2793.   500 NPAR = NPAR + 1
  2794.       IF (NPAR.GT.MAXPAR) GOTO 830
  2795.       IF (IPARNR.EQ.0) GOTO 510
  2796.       KTYAD = ICMDPA(IPARNR+5,ICMD)
  2797.       ITYPAR = KEYTYP(KTYAD)
  2798.       IF (ITYPAR.LT.0) GOTO 600
  2799.   510 IPARNR = IPARNR + 1
  2800.       IF (IPARNR.GT.15) GOTO 830
  2801.       KTYAD = ICMDPA(IPARNR+5,ICMD)
  2802.       IF (KTYAD.EQ.0) GOTO 830
  2803. C
  2804. C          CHECK PARAMETER TYPE
  2805. C
  2806.   600 KTYAD = ICMDPA(IPARNR+5,ICMD)
  2807.       ITYPAR = IABS(KEYTYP(KTYAD))
  2808.       IF (ITYPEI.EQ.IERR) GOTO 840
  2809.       IF (ITYPEI.EQ.IOMIT) GOTO 300
  2810.       IF (ITYPAR.EQ.ISTRIN) GOTO 750
  2811.       IF (ITYPEI.EQ.ISTRIN) GOTO 650
  2812.       IF (ITYPAR.EQ.IUNSPE) GOTO 700
  2813.       IF (ITYPEI.EQ.INTEG.AND.ITYPAR.EQ.IREAL)  ITYPEI = IREAL
  2814.   650 IF (ITYPEI.NE.ITYPAR) GOTO 840
  2815. C
  2816. C          STORE PARAMETER VALUE IN INPUT ARRAYS
  2817. C
  2818.   700 INTV(NPAR)  = INTI
  2819.       REALV(NPAR) = REALI
  2820.       IF (NPAR.GT.MAXANU) GOTO 730
  2821.       I = NPAR * 8 - 8
  2822.       DO 710 J=1,8
  2823.         I = I + 1
  2824.   710   IANUMV(I) = IANUMI(J)
  2825. C
  2826.   720 IF (NPAR.LE.MAXANU) ITYPE(NPAR) = ITYPEI
  2827.       IF (NLASTP.LT.NPAR)  NLASTP = NPAR
  2828.       GOTO 300
  2829.   730 IF (ITYPEI.EQ.IANUM ) GOTO 830
  2830.       GOTO 720
  2831. C
  2832. C          STORE STRING PARAMETER
  2833. C
  2834.   750 IF (ITYPEI.NE.ISTRIN) GOTO 870
  2835.       I = NPAR * 8 - 8
  2836.       IF (I+ISTRIL.GT.(8*MAXANU)) GOTO 870
  2837.       LGHSTR = ISTRIL
  2838.       J = 0
  2839.   755 J = J + 1
  2840.       IF (J.GT.LGHSTR) GOTO 720
  2841.       I = I + 1
  2842.       IANUMV(I) = IANUMI (J)
  2843.       GOTO 755
  2844. C
  2845. C          WRITE ERROR MESSAGES TO NFLOG
  2846. C
  2847.   810 WRITE (NFLOG,2810)
  2848.       NCMD = -9999
  2849.       NLASTP = 0
  2850.       GOTO 900
  2851.   820 WRITE (NFLOG,2820)
  2852.       GOTO 890
  2853.   830 WRITE (NFLOG,2830)
  2854.       GOTO 890
  2855.   840 IF (ITYPAR.EQ.INTEG)  WRITE (NFLOG,2840)
  2856.       IF (ITYPAR.EQ.IREAL)  WRITE (NFLOG,2850)
  2857.       IF (ITYPAR.EQ.IANUM)  WRITE (NFLOG,2860)
  2858.       IRET = 300
  2859.       GOTO 895
  2860.   870 WRITE (NFLOG,2870)
  2861.   890 IRET = 900
  2862.   895 WRITE (NFLOG,2890)  NFIELD
  2863.       IF (NCMD.GT.0)  NCMD = -NCMD
  2864.       IF (IRET.EQ.300) GOTO 300
  2865. C
  2866. C          BYPASS REST OF PARAMETER LIST
  2867. C
  2868.   900 CONTINUE
  2869.       I = 0
  2870.   901 CONTINUE
  2871.       CALL FIELD
  2872.       IF (ITYPEI.EQ.IEND) GOTO 8000
  2873.       IF (I.EQ.0 .AND. IBATCH.EQ.0) WRITE (NFLOG,2901)
  2874.       I = 1
  2875.       GOTO 901
  2876. C
  2877. C          LIST COMMAND AND PARAMETER ARRAYS IF INOUT LSTA=1
  2878. C
  2879.   950 CONTINUE
  2880.       DO 959 ICMD=1,50
  2881.         DO 952 I=1,5
  2882.           ICMDCH(I) = ICMDPA(I,ICMD)
  2883.           CALL APCHAR (ICMDCH(I))
  2884.   952     CONTINUE
  2885.         WRITE (NFLOG,2952) (ICMDCH(I),I=1,5), ICMD
  2886.         DO 955 IPARNR=1,15
  2887.             KTYAD = ICMDPA(IPARNR+5,ICMD)
  2888.             IF (KTYAD.EQ.0) GOTO 955
  2889.             I = KEYTYP(KTYAD+1)
  2890.             KEY(1) = I / 100
  2891.             KEY(2) = I - KEY(1) * 100
  2892.             I = KEYTYP(KTYAD+2)
  2893.             KEY(3) = I / 100
  2894.             KEY(4) = I - KEY(3) * 100
  2895.             DO 954 I=1,4
  2896.   954       CALL APCHAR(KEY(I))
  2897.             WRITE (NFLOG,2953) KEY, KEYTYP(KTYAD), KTYAD
  2898.   955     CONTINUE
  2899.   959 CONTINUE
  2900. C
  2901. C          PRINT ARRAY KEYTYP IN SORTED SEQUENCE
  2902. C
  2903.   960 DO 962 I=1,3
  2904.   962   KEYLAS(I) = 0
  2905.   964 DO 966 I=1,3
  2906.   966   KEYLOW(I) = 9999
  2907.       KTYAD = -2
  2908.   968 KTYAD = KTYAD + 3
  2909.       KEYNOW(1) = KEYTYP(KTYAD+1)
  2910.       KEYNOW(2) = KEYTYP(KTYAD+2)
  2911.       KEYNOW(3) = KTYAD
  2912.       IF (KEYNOW(1).EQ.3636) GOTO 980
  2913.       DO 970 I=1,3
  2914.         IF (KEYNOW(I)-KEYLAS(I))  968,  970, 972
  2915.   970   CONTINUE
  2916.       GOTO 968
  2917.   972 DO 974 I=1,3
  2918.         IF (KEYNOW(I)-KEYLOW(I))  976, 974, 968
  2919.   974   CONTINUE
  2920.   976 DO 978 I=1,3
  2921.   978   KEYLOW(I) = KEYNOW(I)
  2922.       KEYLOW(4) = KEYTYP(KTYAD)
  2923.       GOTO 968
  2924.   980 IF(KEYLOW(1).EQ.9999) GOTO  8001
  2925.       I = KEYLOW(1)
  2926.       KEY(1) = I / 100
  2927.       KEY(2) = I - KEY(1) * 100
  2928.       I = KEYLOW(2)
  2929.       KEY(3) = I / 100
  2930.       KEY(4) = I - KEY(3) * 100
  2931.       DO 981 I=1,4
  2932.   981   CALL APCHAR(KEY(I))
  2933.       WRITE (NFLOG,2953) (KEY(I),I=1,4), KEYLOW(4), KEYLOW(3)
  2934.       DO 982 I=1,3
  2935.   982   KEYLAS(I) = KEYLOW(I)
  2936.       GOTO 964
  2937. C
  2938. C          WRITE INPUT ARRAYS FOR TEST PURPUSE IF LSTC IS SET
  2939. C
  2940.   990 WRITE (NFLOG,2990)  NCMD,NLASTP,LGHSTR
  2941.       IF (NLASTP.EQ.0) GOTO 8500
  2942.       J = NLASTP + (LGHSTR - 1) / 8
  2943.       DO 995 I=1,J
  2944.         IF (I.GT.MAXANU) GOTO 992
  2945.           J2 = I * 8
  2946.           J1 = J2 - 7
  2947.           WRITE (NFLOG,2991) I,INTV(I),REALV(I),ITYPE(I),
  2948.      1                  (IANUMV(J3),J3=J1,J2)
  2949.          GOTO 995
  2950.   992   WRITE (NFLOG,2991) I,INTV(I),REALV(I)
  2951.   995 CONTINUE
  2952.       GOTO 8500
  2953. C
  2954. C
  2955. C          RETURN TO CALLER, TEST FIRST IF ANY PRINTING IS REQUESTED
  2956. C
  2957.  8000 IF (NCMD.EQ.3.AND.INTV(3).GT.0) GOTO 950
  2958. C
  2959.  8001 IF (LSTC.GT.0) GOTO 990
  2960. C
  2961.  8500 IF (NCMD.LE.0) IERROR = 1
  2962.       RETURN
  2963. C
  2964. C
  2965.  2810 FORMAT (22H ***ERROR: BAD COMMAND)
  2966.  2820 FORMAT (26H ***ERROR: UNKNOWN KEYNAME)
  2967.  2830 FORMAT (30H ***ERROR: TOO MANY PARAMETERS)
  2968.  2840 FORMAT (26H ***ERROR: INVALID INTEGER)
  2969.  2850 FORMAT (23H ***ERROR: INVALID REAL)
  2970.  2860 FORMAT (31H ***ERROR: INVALID ALPHANUMERIC)
  2971.  2870 FORMAT (25H ***ERROR: INVALID STRING)
  2972.  2890 FORMAT (36H ***ERROR: AT SPECIFIED PARAMETER NR,I4)
  2973.  2901 FORMAT(11X,32HFOLLOWING PARAMETERS ARE IGNORED)
  2974.  2952 FORMAT (1H ,5A1,4X,I3)
  2975.  2953 FORMAT (5H     ,4A1,2X,I2,5X,I5)
  2976.  2990 FORMAT (12H COMND NCMD=,I5,9H  NLASTP=,I3,9H  LGHSTR=,I3)
  2977.  2991 FORMAT (1H ,8X,I3,I10,2X,E17.10,2X,I2,2X,8I2)
  2978.       END
  2979. C***ADD:CDC***
  2980. CDECK FIELD
  2981. C***END:CDC***
  2982.       SUBROUTINE FIELD
  2983.       DIMENSION ICLASV(47),ICHARV(47),ISMALL(47),IENDA(4)
  2984. C
  2985.       COMMON /CNTRL/ IBATCH,NBSU,LSTC,LSTF,LSTDB,ISURL,ITWO,LINPAG,LINE
  2986.       COMMON /FILES/ NFREAD,NFECHO,NFLOG,NFLIST,LUNODE,LUELEM
  2987.       COMMON /PARAM/ REALV(100),NCMD,NLASTP,ITYPE(20),INTV(100),
  2988.      1               IANUMV(160),LGHSTR,INTEG,IREAL,IANUM,ISTRIN,IOMIT
  2989.       COMMON /FIELDC/ REALI,INPREC(80),INPOS,ITYPEI,INTI,IANUMI(128),
  2990.      1               KEYI(8),NPOSRE,INECHO,MXSIGI,MXSIGR,MXSIGE,MXSTRL,
  2991.      2               ISTRIL,NFIELD,NPOSIN
  2992.       COMMON /SICODE/ I000,I111,I222,I333,I444,I555,I666,I777,I888,I999,
  2993.      1              IBLANK,IAAA,IBBB,ICCC,IDDD,IEEE,IFFF,IGGG,IHHH,IIII,
  2994.      2                IJJJ,IKKK,ILLL,IMMM,INNN,IOOO,IPPP,IQQQ,IRRR,ISSS,
  2995.      3                ITTT,IUUU,IVVV,IWWW,IXXX,IYYY,IZZZ,IPOINT,ICOMMA,
  2996.      4              IPLUS,IMINUS,IEQUAL,ILPAR,IRPAR,ISLASH,IASTER,IAPOST
  2997. C
  2998.       DATA IEND,IERR,IUNSPE/5,6,8/
  2999.       DATA IYES,ICHARB/1,1H /
  3000.       DATA IENDA/1H/,1HE,1HN,1HD/
  3001. C
  3002. C          ICLASV CONTAINS INPUT CHARACTER CLASS CODES
  3003. C
  3004.       DATA ICLASV/5,5,5,5,5,5,5,5,5,5,
  3005.      1            1,7,7,7,7,6,7,7,7,7,
  3006.      2            7,7,7,7,7,7,7,7,7,7,
  3007.      3            7,7,7,7,7,7,7,3,1,2,
  3008.      4            2,4,8,8,1,8,9/
  3009. C
  3010. C           ICHARV CONTAINS ALL 46 CHARATERS SORTED SO THAT THE MOST
  3011. C          FREQUENT COME FIRST, TO MINIMIZE SEARCH TIME.
  3012. C
  3013. C***ADD:BUR***
  3014. C        USE THE FOLLOWING DATA FOR ICHARV ON BURROUGHS MACHINES
  3015. C     DATA ICHARV/064,240,241,242,243,244,245,246,247,248,
  3016. C    1            249,197,213,214,211,201,193,075,126,096,
  3017. C    2            107,226,227,231,232,233,212,215,195,217,
  3018. C    3            198,199,200,229,230,196,194,228,209,210,
  3019. C    4            216,078,097,092,077,093,125/
  3020. C***END:BUR***
  3021. C
  3022. C***DEL:BUR***
  3023.       DATA ICHARV/1H ,1H0,1H1,1H2,1H3,1H4,1H5,1H6,1H7,1H8,
  3024.      1            1H9,1HE,1HN,1HO,1HL,1HI,1HA,1H.,1H=,1H-,
  3025.      2            1H,,1HS,1HT,1HX,1HY,1HZ,1HM,1HP,1HC,1HR,
  3026.      3            1HF,1HG,1HH,1HV,1HW,1HD,1HB,1HU,1HJ,1HK,
  3027.      4            1HQ,1H+,1H/,1H*,1H(,1H),1H'/
  3028. C***END:BUR***
  3029. C
  3030. C          ISMALL IS SORTED IN SAME ORDER AS ICHARV AND CONTAINS
  3031. C          THE CHARACTERS SMALL INTEGER CODE.
  3032. C
  3033.       DATA ISMALL/10,00,01,02,03,04,05,06,07,08,
  3034.      1            09,15,24,25,22,19,11,37,41,40,
  3035.      2            38,29,30,34,35,36,23,26,13,28,
  3036.      3            16,17,18,32,33,14,12,31,20,21,
  3037.      4            27,39,44,45,42,43,46/
  3038. C
  3039. C          INITIALIZE COMMON /FIELDC/ AND WORK VARIABLES
  3040. C
  3041.       INTI = 0
  3042.       REALI = 0.0
  3043.       DO 10 I=1,8
  3044.         IANUMI(I) = IBLANK
  3045.         KEYI(I)   = IBLANK
  3046.    10 CONTINUE
  3047.       ISTRIL = 0
  3048. C
  3049.       INSTAT = 1
  3050.       RVALUE = 0.0
  3051.       NDIGIT = 0
  3052.       NSDIG = 0
  3053.       NDECIM = 0
  3054.       IEXP = 0
  3055.       ISIGN = +1
  3056.       ISIGNE = +1
  3057.       IIANUM = 0
  3058.       LCOMMA = 0
  3059.       IFIRST = 0
  3060. C
  3061. C          LCOMMA = 1 IF LAST NON-BLANK CHAR IN RECORD SOFAR IS COMMA
  3062. C          IFIRST = 1 IF THIS IS FIRST FIELD IN A LIST
  3063. C
  3064. C
  3065. C          CHECK STATUS AFTER PREVIOUS CALL
  3066. C
  3067. C     TEST IF PREVIOUS CALL RESULTED IN END OF LIST
  3068. C
  3069.       IF (ITYPEI.NE.IEND)  GOTO 110
  3070.         IFIRST = 1
  3071.         LCOMMA = 1
  3072.         IF (INPOS.GT.NPOSIN)  GOTO 200
  3073.         GOTO 300
  3074.   110 ITYPEI = 0
  3075. C
  3076. C          TEST IF PREVIOUS FIELD ENDED BECAUSE OF / OR RECORD END
  3077. C
  3078.       IF (INPOS.GT.NPOSIN)  GOTO 444
  3079.         INCHAR = INPREC(INPOS)
  3080.         IF (INCHAR.EQ.ISLASH)  GOTO 444
  3081. C
  3082. C          TEST IF PREVIOUS FIELD ENDED BY COMMA
  3083. C
  3084.       IF (INCHAR.EQ.ICOMMA)  LCOMMA = 1
  3085. C
  3086.       GOTO 300
  3087. C
  3088. C          READ INPUT RECORD
  3089. C
  3090.   200 CONTINUE
  3091. C***ADD:BUR***
  3092. C     IF(IBATCH.NE.IYES) WRITE(NFLOG,2000)
  3093. C***END:BUR***
  3094. C***ADD:CDC***
  3095. C     READ (NFREAD,1001) (INPREC(I),I=1,NPOSRE)
  3096. C     IF (EOF(NFREAD)) 203, 207
  3097. C***END:CDC***
  3098. C***DEL:CDC***
  3099.       READ (NFREAD,1001,END=203) (INPREC(I),I=1,NPOSRE)
  3100.       GOTO 207
  3101. C***END:CDC***
  3102.   203 DO 205 I=1,4
  3103.   205   INPREC(I) = IENDA(I)
  3104.       NPOSIN = 4
  3105.       GOTO 250
  3106.   207 CONTINUE
  3107.       NPOSIN = NPOSRE
  3108.   210 IF (INPREC(NPOSIN).GT.0) GOTO 230
  3109.       IF (ICHARB.GT.0) GOTO 240
  3110.   220 IF (INPREC(NPOSIN).NE.ICHARB) GOTO 240
  3111.       NPOSIN = NPOSIN - 1
  3112.       IF (NPOSIN.GT.2) GOTO 210
  3113.   230 IF (ICHARB.GT.0) GOTO 220
  3114.   240 CONTINUE
  3115.       IF (INECHO.EQ.IYES)
  3116.      1WRITE (NFECHO,2001) (INPREC(I),I=1,NPOSIN)
  3117.   250 INPOS = 0
  3118.       IFIRST = 1
  3119.       LCOMMA = 1
  3120. C
  3121. C          NEXT INPUT CHARACTER
  3122. C
  3123.   300 INPOS = INPOS + 1
  3124.       IF (INPOS.LE.NPOSIN)  GOTO 310
  3125.       IF (ITYPEI.EQ.ISTRIN .AND. LAPOST.EQ.-1) GOTO 200
  3126.         INCHAR = ISLASH
  3127.         GOTO 350
  3128. C
  3129. C          CONVERT INPUT CHARACTER TO SMALL INTEGER CODE
  3130. C
  3131.   310 INCHAR = INPREC(INPOS)
  3132.       DO 330 I=1,47
  3133. C          COMPATIBLE FORTRAN TEST FOR
  3134. C            IF (INCHAR.EQ.ICHARV(I))  GOTO 340
  3135.         J = ICHARV(I)
  3136.         IF (INCHAR.LT.0)  GOTO 320
  3137.         IF (J     .LT.0)  GOTO 330
  3138.   315   IF (INCHAR.EQ.J)  GOTO 340
  3139.         GOTO 330
  3140.   320   IF (J     .LT.0)  GOTO 315
  3141.   330 CONTINUE
  3142. C
  3143. C          BAD INPUT CHARACTER
  3144. C
  3145.       GOTO 900
  3146. C
  3147. C          CHARACTER FOUND IN ICHARV ARRAY
  3148. C
  3149.   340 INCHAR = ISMALL(I)
  3150.       INPREC(INPOS) = INCHAR
  3151. C
  3152. C          GOTO ACTION CALL PROCEDURE DEPENDING ON INPUT CHAR CLASS
  3153. C
  3154.   350 ICLASS = ICLASV(INCHAR+1)
  3155.       IF (ITYPEI.EQ.ISTRIN) GOTO 711
  3156. C
  3157. C          TEST TO BYPASS REST OF FIELD IF ERROR STATUS
  3158. C
  3159.       IF (INSTAT.EQ.10 .AND. ICLASS.NE.1)  GOTO 300
  3160. C
  3161.       GOTO (400,520,530,540,550,560,570,900,700),  ICLASS
  3162. C
  3163. C          FIELD DELIMITER BLANK, COMMA, SLASH OR END OF RECORD
  3164. C
  3165.   400 GOTO (440,430,450,410,420,450,450,420,430,455),  INSTAT
  3166. C
  3167. C          RESULT FIELD IS INTEGER
  3168. C
  3169.   410 IF (NDIGIT.EQ.0)  GOTO 450
  3170.       IF (NDECIM.NE.0)  GOTO 420
  3171.       IF (NSDIG.GT.MXSIGI) GOTO 420
  3172.       RVALUE = RVALUE + 0.1
  3173.       INTI = INT(RVALUE) * ISIGN
  3174.       REALI = INTI
  3175.       ITYPEI = INTEG
  3176.       GOTO 8000
  3177. C
  3178. C          RESULT IS REAL
  3179. C
  3180.   420 IF (NDIGIT.EQ.0)  GOTO 450
  3181.       IF (ISIGN.EQ.-1) RVALUE = -RVALUE
  3182.       IEXP = IEXP * ISIGNE - NDECIM
  3183.       IF (IABS(IEXP + NSDIG) .GT. MXSIGE)  GOTO 920
  3184.       REALI = RVALUE * (10.0**IEXP)
  3185.       ITYPEI = IREAL
  3186.       GOTO 8000
  3187. C
  3188. C          RESULT IS ALPHANUMERIC
  3189. C
  3190.   430 ITYPEI = IANUM
  3191.       IF (IIANUM.LE.8 .OR. NFIELD.EQ.-1) GOTO 8000
  3192.       WRITE (NFLOG,2430)
  3193.       GOTO 450
  3194. C
  3195. C          FIELD HAS NOT STARTED
  3196. C
  3197.   440 IF (INCHAR.EQ.IBLANK)  GOTO 300
  3198. C
  3199.       IF (INCHAR.NE.ICOMMA)  GOTO 442
  3200.         IF (LCOMMA.EQ.1)  GOTO 441
  3201.           LCOMMA = 1
  3202.           GOTO 300
  3203.   441   ITYPEI = IOMIT
  3204.         GOTO 8000
  3205.   442 CONTINUE
  3206. C
  3207.       IF (INPOS.GT.NPOSIN .AND. (LCOMMA.EQ.1.OR.IFIRST.EQ.1))  GOTO 200
  3208.       IF (IFIRST.EQ.1)  GOTO 300
  3209.   444 ITYPEI = IEND
  3210.       GOTO 8000
  3211. C
  3212. C          ERROR FIELD IS NOT COMPLETED
  3213. C
  3214.   450 WRITE (NFLOG,2002)  INPOS
  3215.   455 ITYPEI = IERR
  3216.       GOTO 8000
  3217. C
  3218. C          FIELD CHARACTER CHECK
  3219. C
  3220. C          + AND - SIGN
  3221. C
  3222.   520 GOTO(640,900,640,900,900,670,900,900,900), INSTAT
  3223. C
  3224. C          . DECIMAL POINT
  3225. C
  3226.   530 GOTO (650,900,650,650,900,900,900,900,900), INSTAT
  3227. C
  3228. C          = EQUAL KEYNAME DELIMITOR
  3229. C
  3230.   540 IF (INSTAT.EQ.2)  GOTO 630
  3231.       GOTO 900
  3232. C
  3233. C          0 - 9 DIGIT
  3234. C
  3235.   550 GOTO (640,620,640,640,650,680,680,680,690), INSTAT
  3236. C
  3237. C          E FOR EXPONENT
  3238. C
  3239.   560 GOTO (620,620,690,660,660,900,900,900,690), INSTAT
  3240. C
  3241. C          A - Z BUT NOT E LETTER
  3242. C
  3243.   570 GOTO (620,620,690,900,900,900,900,900,690), INSTAT
  3244. C
  3245. C          REMEMBER ANUM KEY OR VALUE CHARACTER
  3246. C
  3247.   620 INSTAT = 2
  3248.   625 IIANUM = IIANUM + 1
  3249.       IF (IIANUM.LE.8) IANUMI(IIANUM) = INCHAR
  3250.       GOTO 300
  3251. C
  3252. C          REMEMBER = EQUAL KEYWORD DELIMITOR
  3253. C
  3254.   630 INSTAT = 3
  3255.       DO 635 I=1,8
  3256.         KEYI(I) = IANUMI(I)
  3257.         IANUMI(I) = IBLANK
  3258.   635 CONTINUE
  3259.       IIANUM = 0
  3260.       GOTO 300
  3261. C
  3262. C          REMEMBER PLUS, MINUS OR INTEGER DIGIT
  3263. C
  3264.   640 INSTAT = 4
  3265.       IF (INCHAR.EQ.IMINUS)  ISIGN = -1
  3266.       IF (ICLASS.EQ.2)  GOTO 300
  3267.   645 IF (INCHAR.GT.0 .OR. NSDIG.GT.0)  NSDIG = NSDIG + 1
  3268.       IF (NSDIG.GT.MXSIGR)  GOTO 648
  3269.       RVALUE = RVALUE * 10.0 + FLOAT(INCHAR)
  3270.   646 NDIGIT = NDIGIT + 1
  3271.       GOTO 300
  3272.   648 IF (INCHAR.NE.0)  GOTO 910
  3273.       NDECIM = NDECIM - 1
  3274.       GOTO 646
  3275. C
  3276. C          REMEMBER . DECIMAL POINT OR DIGIT
  3277. C
  3278.   650 INSTAT = 5
  3279.       IF (INCHAR.EQ.IPOINT)  GOTO 300
  3280.       NDECIM = NDECIM + 1
  3281.       GOTO 645
  3282. C
  3283. C          REMEMBER E FOR EXPONENT
  3284. C
  3285.   660 INSTAT = 6
  3286.       GOTO 300
  3287. C
  3288. C          REMEBER + OR - SIGN FOR EXPONENT
  3289. C
  3290.   670 INSTAT = 7
  3291.       IF (INCHAR.EQ.IMINUS)  ISIGNE = -1
  3292.       GOTO 300
  3293. C
  3294. C          REMEMBER EXPONENT DIGIT
  3295. C
  3296.   680 INSTAT = 8
  3297.       IEXP = IEXP * 10 + INCHAR
  3298.       IF (IEXP.GT.999)  GOTO 920
  3299.       GOTO 300
  3300. C
  3301. C          REMEMBER ANUM AFTER KEYNAME=
  3302. C
  3303.   690 INSTAT = 9
  3304.       GOTO 625
  3305. C
  3306. C          APOSTROPHE 'STRING' START
  3307. C
  3308.   700 IF (INSTAT.NE.1 .AND.INSTAT.NE.3) GOTO 900
  3309.       ITYPEI = ISTRIN
  3310.       ISTRIL = 0
  3311.       LAPOST = -1
  3312.       GOTO 300
  3313. C
  3314. C          STRING CHARACTER
  3315. C
  3316.   711 IF (ICLASS.EQ.9) GOTO 720
  3317.       IF (LAPOST.EQ.+1) GOTO 730
  3318.   712 ISTRIL = ISTRIL + 1
  3319.       IF (ISTRIL.GT.MXSTRL)  GOTO 719
  3320.       IANUMI(ISTRIL) = INCHAR
  3321.       GOTO 300
  3322.   719 WRITE (NFLOG,2719) MXSTRL
  3323.       GOTO 790
  3324. C
  3325. C          APOSTROPHE STRING END OR ''
  3326. C
  3327.   720 LAPOST = -LAPOST
  3328.       IF (LAPOST.EQ.-1) GOTO 712
  3329.       GOTO 300
  3330. C
  3331. C          STRING END
  3332. C
  3333.   730 IF (INSTAT.EQ.10) ITYPEI = IERR
  3334.       IF (ICLASS.EQ.1) GOTO 8000
  3335.   790 ITYPEI = 0
  3336.       GOTO 900
  3337. C
  3338. C          ERROR MESSAGES
  3339. C
  3340.   900 INSTAT = 10
  3341.       WRITE (NFLOG,2002)  INPOS
  3342.       GOTO 300
  3343.   910 WRITE (NFLOG,2003) MXSIGR
  3344.       GOTO 900
  3345.   920 WRITE (NFLOG,2004)  MXSIGE
  3346.       GOTO 450
  3347. C
  3348.   990 WRITE (NFLOG,2090) INPOS,ITYPEI,INTI,REALI,(IANUMI(I),I=1,8)
  3349.      1                   ,KEYI,ISTRIL
  3350.       GOTO 8500
  3351.  8000 IF (LSTF.EQ.IYES)  GOTO 990
  3352.  8500 RETURN
  3353. C
  3354. C***ADD:BUR***
  3355. C1001 FORMAT (80C1)
  3356. C2001 FORMAT (/1H ,80C1)
  3357. C***END:BUR***
  3358. C***DEL:BUR***
  3359.  1001 FORMAT (80A1)
  3360.  2001 FORMAT (/1H ,80A1)
  3361. C***END:BUR***
  3362.  2000 FORMAT (1H ,1H?)
  3363.  2002 FORMAT (48H ***ERROR: BAD INPUT DATA BEFORE OR AT LOCATION ,I4)
  3364.  2003 FORMAT (45H ***ERROR: TOO MANY SIGNIFICANT DIGITS, MAX= ,I3)
  3365.  2004 FORMAT (55H ***ERROR: TOO BIG OR LITTLE REAL NUMBER, EXPONENT MAX=
  3366.      1,I3)
  3367.  2090 FORMAT (7H FIELD ,I3,1X,I1,1X,I10,1X,E17.10,1X,8I2,1X,8I2,1X,I3)
  3368.  2430 FORMAT (46H ***ERROR: ALPHANUMERIC LENGTH EXCEEDED, MAX 8)
  3369.  2719 FORMAT (38H ***ERROR: STRING LENGTH EXCEEDED, MAX,I4)
  3370.       END
  3371. C*NEW FILE
  3372. C***END:IBM***
  3373.       SUBROUTINE DATAB
  3374. C
  3375. C          DATABASE CREATION FROM PORTHOLE OR DATABASE RE-OPEN
  3376. C
  3377.       DIMENSION IA(1)
  3378.       COMMON /ERROR/ IERROR
  3379.       COMMON /CNTRL/ IBATCH,NBSU,LSTC,LSTF,LSTDB,ISURL,ITWO,LINPAG,LINE
  3380.       COMMON /FILES/ NFREAD,NFECHO,NFLOG,NFLIST,LUNODE,LUELEM
  3381.       COMMON /PARAM/ REALV(100),NCMD,NLASTP,ITYPE(20),INTV(100),
  3382.      1               IANUMV(8,20),LGHSTR,INTEG,IREAL,IANUM,ISTRIN,IOMIT
  3383.       COMMON /SICODE/ I000,I111,I222,I333,I444,I555,I666,I777,I888,I999,
  3384.      1              IBLANK,IAAA,IBBB,ICCC,IDDD,IEEE,IFFF,IGGG,IHHH,IIII,
  3385.      2                IJJJ,IKKK,ILLL,IMMM,INNN,IOOO,IPPP,IQQQ,IRRR,ISSS,
  3386.      3                ITTT,IUUU,IVVV,IWWW,IXXX,IYYY,IZZZ,IPOINT,ICOMMA,
  3387.      4              IPLUS,IMINUS,IEQUAL,ILPAR,IRPAR,ISLASH,IASTER,IAPOST
  3388.       COMMON /DB/ IOPEN,NFDB,INDXST,IXTNOW,LGP,NWRITS,NREADS,
  3389.      1            LDBC,LDBCTR,LDBCTI,IPHCHK,INSTRI,INRUSE,INSTRU,
  3390.      2            MSUBF,MVIEW,MAXIS,MLINEN,MLINEE,MVAR,MRES,LSKEW,MIDSPL
  3391.       COMMON /DBC/ IHED(18),NDAREC,LDAREC,NRECS,NWORDS,NEXREC,NEXTIX,
  3392.      1             LIX,LIXT,NSTRI,NSTRUC,NEGIT,NEGAT,NFREQ,
  3393.      2             IXGP(50),MXSGP(50),
  3394.      3             FILL1
  3395.       COMMON /DIM/ I01,I02,I03,I04,I05,I06,I07,I08,I09,I010,I011,
  3396.      1             I1,I2,I3,I4,I5,I6,I7,I8,I9,I10,I11,I12,I13,I14,I15,
  3397.      2             I16,I17,I18,I19,I20,
  3398.      3             N1,N2,N3,N4,N5,N6,N7,N8,N9,N10,N11,N12,N13,N14,N15,
  3399.      4             N16,N17,N18,N19,N20
  3400.       COMMON /DBCTRL/ DT    ,TSTART,NUMNP ,NEQT  ,NSUBST,IDOF(6),
  3401.      1                NDOF  ,NEG   ,NMID  ,MODEX ,NSTE  ,NSTEN ,
  3402.      2                NSTEE ,NSKEWS,NMIDSS,IEIG  ,NSREFB,NEQITB,
  3403.      3                NPRIB ,NODSVB,LEMSVB,JDC   ,JAC   ,JVC   ,
  3404.      4                ISTAT ,JTC   ,NDISCE,ITP96 ,MXITAB,MXIDER,MXERES,
  3405.      5                NELPAR,MXNP  ,MXEG  ,MXEL  ,MXELNP,
  3406.      6                NDOFSA(6),NOUSE(4),FILL2
  3407.       COMMON /IGPNAM/ KDBC  ,KSUBGP,KDBCTR,KSTRI ,KRSDCO,KTMIDS,
  3408.      1                KXYZ  ,KIDRN ,KICONA,KNZONE,KNPAR ,KTHICK,
  3409.      2                KITABL,KNOD  ,KEDATA,KIEZON,KFRQ  ,KPHI  ,
  3410.      3                KTIMEN,KDISP ,KVEL  ,KACC  ,KTEMP ,KTIMEE,
  3411.      4                KERES ,KSUBF ,KVIEW ,KAXIS ,KNPOIN,KVARES,
  3412.      5                KNAMEZ,KEPOIN,KSXYZ ,KX34  ,KX35  ,KX36  ,
  3413.      6                KX37  ,KX38  ,KX39  ,KX40  ,KX41  ,KX42  ,
  3414.      7                KX43  ,KX44  ,KX45  ,KX46  ,KX47  ,KX48  ,
  3415.      8                KX49  ,KX50
  3416.       COMMON /MEMORY/ MTOT,LPROG,MEMPRT,MEMMAX,MEMNOW
  3417.       COMMON A(1)
  3418.       EQUIVALENCE (A(1),IA(1))
  3419.       DATA NCREAT,NOPEN/1,2/
  3420. C
  3421.       CALL DBCLOS
  3422.       IF (IERROR.NE.0) GOTO 900
  3423. C
  3424.       IF (ITYPE(2).EQ.INTEG)  NFDB = INTV(2)
  3425.       IPHCHK = INTV(3)
  3426. C          LSTLU IS PROCESSED IN PHSCAN
  3427. C
  3428.       NOPERA = NCREAT
  3429.       IF (IANUMV(1,1).EQ.ICCC.AND.IANUMV(2,1).EQ.IRRR) GOTO 100
  3430.       NOPERA = NOPEN
  3431.       IF (IANUMV(1,1).EQ.IOOO.AND.IANUMV(2,1).EQ.IPPP) GOTO 100
  3432.       WRITE (NFLOG,2000)
  3433.       IERROR = 1
  3434.       GOTO 900
  3435. C
  3436.   100 IA(1) = -87878
  3437.       IA(2) = 0
  3438.       IA(3) = 1
  3439.       IA(4) = 2
  3440.       IA(MEMNOW) = -87878
  3441.       NREADS = 0
  3442.       NWRITS = 0
  3443.       IXTNOW = 0
  3444.       INSTRI = 1
  3445.       INRUSE = 1
  3446.       INSTRU = 1
  3447.       NRECS  = 0
  3448.       NWORDS = 0
  3449. C
  3450. C          CREATE: SCAN LUNODE TO DETERMINE SIZE OF DB INDEX
  3451. C
  3452.       IF (NOPERA.NE.NCREAT) GOTO 500
  3453. C
  3454.       CALL PHSCAN
  3455.       IF (IERROR.NE.0) GOTO 800
  3456.       CALL DBOPEN
  3457.       IF (IERROR.NE.0) GOTO 900
  3458. C
  3459. C          INITIALIZE DATABASE ARRAYS AND CONTROL VARIABLES
  3460. C
  3461.       DO 400 IGP=1,LGP
  3462.         IXGP(IGP) = 0
  3463.   400   MXSGP (IGP) = 0
  3464. C
  3465.       MXSGP (KDBCTR) = 1
  3466.       MXSGP (KSTRI ) = 1
  3467.       IF (NSKEWS.NE.0) MXSGP (KRSDCO) = 1
  3468.       MXSGP (KTMIDS) = NSTRI
  3469.       MXSGP (KXYZ  ) = NSTRUC
  3470.       MXSGP (KIDRN ) = NSTRI
  3471.       MXSGP (KICONA) = NSTRUC - 1
  3472.       MXSGP (KNZONE) = NSTRUC
  3473.       MXSGP (KNPAR ) = NSTRI
  3474.       MXSGP (KTHICK) = NEGIT
  3475.       MXSGP (KITABL) = NEGIT
  3476.       MXSGP (KNOD  ) = NEGIT
  3477.       MXSGP (KEDATA) = NEGIT
  3478.       MXSGP (KIEZON) = NEGAT
  3479.       IF (IEIG.GT.0) MXSGP (KFRQ) = 1
  3480.       IF (IEIG.GT.0) MXSGP (KPHI) = NFREQ
  3481.       MXSGP (KTIMEN) = 1
  3482.       IF (JDC.NE.0) MXSGP (KDISP) = NSTRUC
  3483.       IF (JVC.NE.0.AND.ISTAT.NE.0) MXSGP (KVEL) = NSTRUC
  3484.       IF (JAC.NE.0.AND.ISTAT.NE.0) MXSGP (KACC) = NSTRUC
  3485.       IF (JTC.NE.0 .AND. ITP96.NE.0) MXSGP (KTEMP ) = 1
  3486.       MXSGP (KTIMEE) = 1
  3487.       IF (LEMSVB.NE.0) MXSGP (KERES) = NEGAT
  3488.       MXSGP (KSUBF ) = 1
  3489.       MXSGP (KVIEW ) = 1
  3490.       MXSGP (KAXIS ) = 1
  3491.       MXSGP (KNPOIN) = 1
  3492.       MXSGP (KVARES) = 1
  3493.       MXSGP (KNAMEZ) = 1
  3494.       MXSGP (KEPOIN) = 1
  3495.       MXSGP (KSXYZ ) = NEGAT
  3496. C
  3497.       LIX = 1
  3498.       DO 410 IGP=1,LGP
  3499.   410   LIX = LIX + MXSGP (IGP)
  3500. C
  3501.       NEXREC = 1
  3502.       NEXTIX = 1
  3503.       CALL ALIGN (LIX)
  3504.       LIXT = NSTE + 2
  3505.       CALL ALIGN (LIXT)
  3506.       GOTO 600
  3507. C
  3508. C          OPEN: READ COMMON /DBC/
  3509. C
  3510.   500 CONTINUE
  3511.       CALL DBOPEN
  3512.       IF (IERROR.NE.0) GOTO 900
  3513.       CALL DBR (IHED,0,LDBC,1)
  3514.       IF (IERROR.EQ.0 .AND. NRECS.GT.2 .AND. NWORDS.GT.100) GOTO 510
  3515.       WRITE (NFLOG,2020)
  3516.       IOPEN = 0
  3517.       IERROR = 1
  3518.       GOTO 900
  3519.   510 CONTINUE
  3520.       WRITE (NFLOG,2010) IHED
  3521. C
  3522. C          GET BLANK COMMON MEMORY FOR DATABASE SUBGROUP ARRAYS
  3523. C          AND TIME INDEX:  THESE AREAS ARE FIX AT START OF BLANK COMMON
  3524. C          INITIALIZE ALL ARRAYS TO ZERO
  3525. C
  3526.   600 CONTINUE
  3527. C                                                IXMAST
  3528.       I01 = 5
  3529. C                                                LREAL
  3530.       CALL ALIGN (I01)
  3531.       I02 = I01 + LIX
  3532. C                                                LINT
  3533.       I03 = I02 + LIX
  3534. C                                                IXSGP
  3535.       I04 = I03 + LIX
  3536. C                                                MXSGP
  3537.       I05 = I04 + LIX
  3538. C                                                IXTIME
  3539.       I06 = I05 + LIXT
  3540. C                                                NRUSES
  3541.       I07 = I06 + NSTRI
  3542. C                                                NEGS
  3543.       I08 = I07 + NSTRI
  3544. C                                                NUMNPS
  3545.       I09 = I08 + NSTRI
  3546. C                                                NEQTS
  3547.       I010 = I09 + NSTRI
  3548. C                                                MAXMSS
  3549.       I011 = I010 + NSTRI
  3550. C                                                NODRTS
  3551.       I1 = I011 + NSTRI
  3552.       CALL SIZE (I1)
  3553.       IF (IERROR.NE.0) GOTO 800
  3554.       N1 = I1 / ISURL
  3555.       DO 610 I=I01,I1
  3556.   610   IA(I) = 0
  3557. C
  3558. C          CREATE: WRITE COMMON /DBC/ AND SUBGROUP ARRAYS UNDER
  3559. C                  MASTER INDEX TO MAKE THEM FIRST IN DATABASE
  3560. C
  3561.       IF (NOPERA.NE.NCREAT) GOTO 700
  3562.       CALL DBW (IHED,0,LDBC,1)
  3563.       IF (IERROR.NE.0) GOTO 800
  3564.       CALL DBW (IA(I01),0,(LIX*4),2)
  3565.       IF (IERROR.NE.0) GOTO 800
  3566. C***DEL:CDC***
  3567.       NEXREC = (LIX * 4 - 1) / LDAREC + 3
  3568. C***END:CDC***
  3569. C
  3570. C          REREAD PORTHOLE FILES AND LOAD DATABASE
  3571. C
  3572.       NELPAR = 20
  3573.       CALL PHREAD (IA(I06),IA(I07),IA(I08),IA(I09),IA(I010),IA(I011)
  3574.      1             ,NELPAR,IA(I1))
  3575.       GOTO 900
  3576. C
  3577. C          OPEN: READ SUBGROUP ARRAYS AND COMMON AREAS
  3578. C
  3579.   700 CONTINUE
  3580.       CALL DBR (IA(I01),0,(LIX*4),2)
  3581.       IF (IERROR.NE.0) GOTO 800
  3582.       CALL DBREAD (DT,KDBCTR,1,0)
  3583.       IF (IERROR.NE.0) GOTO 800
  3584.       CALL DBREAD (IA(I06),KSTRI,1,0)
  3585.       IF (IERROR.NE.0) GOTO 800
  3586.       GOTO 900
  3587. C
  3588.   800 CALL DBCLOS
  3589.   900 RETURN
  3590.  2000 FORMAT (45H ***ERROR: DATABASE OPERATION CREATE OR OPEN?)
  3591.  2010 FORMAT(/4X,18A4/)
  3592.  2020 FORMAT(44H ***ERROR:  DATABASE FIRST RECORD IS INVALID)
  3593.       END
  3594. C***ADD:CDC***
  3595. CDECK PHSCAN
  3596. C***END:CDC***
  3597.       SUBROUTINE PHSCAN
  3598. C
  3599. C          SCAN OF PORTHOLE FILE TO ACCUMULATE VARIABLES FOR
  3600. C          DIMENSIONING THE DATA BASE INDEX
  3601. C
  3602. C***ADD:DPR***
  3603.       IMPLICIT REAL*8(D)
  3604.       REAL DT
  3605. C***END:DPR***
  3606.       DIMENSION IA(1),DA(1),IPNODE(3,1)
  3607.       COMMON /ERROR/ IERROR
  3608.       COMMON /CNTRL/ IBATCH,NBSU,LSTC,LSTF,LSTDB,ISURL,ITWO,LINPAG,LINE
  3609.       COMMON /FILES/ NFREAD,NFECHO,NFLOG,NFLIST,LUNODE,LUELEM
  3610.       COMMON /PARAM/ REALV(100),NCMD,NLASTP,ITYPE(20),INTV(100),
  3611.      1               IANUMV(8,20),LGHSTR,INTEG,IREAL,IANUM,ISTRIN,IOMIT
  3612.       COMMON /DB/ IOPEN,NFDB,INDXST,IXTNOW,LGP,NWRITS,NREADS,
  3613.      1            LDBC,LDBCTR,LDBCTI,IPHCHK,INSTRI,INRUSE,INSTRU,
  3614.      2            MSUBF,MVIEW,MAXIS,MLINEN,MLINEE,MVAR,MRES,LSKEW,MIDSPL
  3615.       COMMON /DBC/ IHED(18),NDAREC,LDAREC,NRECS,NWORDS,NEXREC,NEXTIX,
  3616.      1             LIX,LIXT,NSTRI,NSTRUC,NEGIT,NEGAT,NFREQ,
  3617.      2             IXGP(50),MXSGP(50),
  3618.      3             FILL1
  3619.       COMMON /DIM/ I01,I02,I03,I04,I05,I06,I07,I08,I09,I010,I011,
  3620.      1             I1,I2,I3,I4,I5,I6,I7,I8,I9,I10,I11,I12,I13,I14,I15,
  3621.      2             I16,I17,I18,I19,I20,
  3622.      3             N1,N2,N3,N4,N5,N6,N7,N8,N9,N10,N11,N12,N13,N14,N15,
  3623.      4             N16,N17,N18,N19,N20
  3624.       COMMON /DBCTRL/ DT    ,TSTART,NUMNP ,NEQT  ,NSUBST,IDOF(6),
  3625.      1                NDOF  ,NEG   ,NMID  ,MODEX ,NSTE  ,NSTEN ,
  3626.      2                NSTEE ,NSKEWS,NMIDSS,IEIG  ,NSREFB,NEQITB,
  3627.      3                NPRIB ,NODSVB,LEMSVB,JDC   ,JAC   ,JVC   ,
  3628.      4                ISTAT ,JTC   ,NDISCE,ITP96 ,MXITAB,MXIDER,MXERES,
  3629.      5                NELPAR,MXNP  ,MXEG  ,MXEL  ,MXELNP,
  3630.      6                NDOFSA(6),NOUSE(4),FILL2
  3631.       COMMON A(100)
  3632.       EQUIVALENCE (A(1),IA(1))
  3633.       EQUIVALENCE (A(1),DA(1))
  3634.       EQUIVALENCE (A(41),IPNODE(1,1))
  3635. C
  3636.       DATA DREOF/8HEND FILE/,DRANY/8HANY REC /
  3637.       DATA DRTYPX/8HTYPE - X/
  3638. C
  3639.       DATA DRMAST/8HMASTERCP/,DRSTIF/8HSTIFNESS/,
  3640.      1     DRITER/8HITERATON/,DRPRIN/8HPRINTOUT/,
  3641.      2     DRNODE/8HNODESAVE/,DRELMT/8HELMTSAVE/,
  3642.      3     DREQUA/8HEQUATONS/,DRNODC/8HNODECORD/,DRIDAR/8HID-ARRAY/,
  3643.      4     DRRSDC/8HRSDCOS  /,DRNSYS/8HNODESYST/,DRNMID/8HNODEMIDS/,
  3644.      5     DRNFMI/8HNODEFMID/
  3645.       DATA DRANY /8HANY REC /,DRSUBS/8HSUBSTRUC/,DREOF /8HEND FILE/
  3646. C
  3647. C          TEST PRINTING OF LUNODE RECORD LABELS
  3648. C
  3649.       IF (INTV(4).NE.1) GOTO 90
  3650.       REWIND LUNODE
  3651.       REWIND LUELEM
  3652.       WRITE (NFLOG,2000)
  3653.       LU = 1
  3654.       GOTO 5
  3655.   2   LU = 2
  3656.     5 DROLD = 0
  3657.       N = -1
  3658.   10  N = N + 1
  3659.       IF (DROLD.EQ.DREOF) GOTO 30
  3660.       DRECLB = DRANY
  3661.       IF (LU.EQ.1) CALL PHNCHK (DRECLB)
  3662.       IF (LU.EQ.2) CALL PHECHK (DRECLB)
  3663.       IF (DRECLB.EQ.DROLD) GOTO 10
  3664.   30  IF(N.GT.0) WRITE (NFLOG,2010) DROLD, N
  3665.       IF (DROLD.EQ.DREOF) GOTO 80
  3666.       DROLD = DRECLB
  3667.       N = 0
  3668.       GOTO 10
  3669.   80  IF (LUELEM.NE.LUNODE .AND. LU.EQ.1) GOTO 2
  3670.    90 REWIND LUNODE
  3671.       REWIND LUELEM
  3672. C
  3673. C          READ 'MASTERCP'
  3674. C
  3675.       I1 = 500
  3676.       CALL SIZE (I1)
  3677.       CALL PHNCHK (DRMAST)
  3678.       IF (IERROR.NE.0) GOTO 900
  3679.       BACKSPACE LUNODE
  3680.       READ (LUNODE)
  3681.      1     DRECLB,(IHED(I),I=1,18),NUMNP,(IDOF(I),I=1,6),
  3682.      2     NEGL,NEGNL,MODEX,NSTE,DA(15),DA(14),IDUM,NSKEWS,
  3683.      3     IDUM,ITP96,IDUM,IDUM,IDUM,IDUM,IDUM,IEIG,
  3684.      4     NSREFB,NEQITB,DUM,IDUM,IDUM,DUM,DUM,
  3685.      5     NPRIB,NODSVB,LEMSVB,LUNODE,LU1,LU2,LU3,
  3686.      6     NPB,IDUM,IDUM,IDUM,NPUTSV,JDC,JVC,JAC,
  3687.      7     ((IPNODE(I,J),I=1,3),J=1,NPB),
  3688.      8     NMIDSS,NDISCE,NSUBST,JTC,NFREQ,ISTAT
  3689.       WRITE (NFLOG,2040) IHED
  3690.       IF (NPUTSV.EQ.0) GOTO 790
  3691.       DT       = DA(15)
  3692.       TSTART   = DA(14)
  3693.       NSTRI  = NSUBST + 1
  3694.       ISTRI = 1
  3695.       NSTRUC = 1
  3696.       NEGIT = NEGL + NEGNL
  3697.       NEGAT = NEGIT
  3698.       NMID  = NMIDSS
  3699.       MXNP   = NUMNP
  3700.       NEG     = NEGL + NEGNL
  3701.       MXEG   = NEG
  3702.       IF (NSUBST.EQ.0 .AND. IPHCHK.EQ.0) GOTO 900
  3703. C
  3704. C          'STIFNESS',  'ITERATON',  'PRINTOUT'
  3705. C
  3706.       IF (NSREFB.NE.0)  CALL PHNCHK (DRSTIF)
  3707.       IF (NEQITB.NE.0)  CALL PHNCHK (DRITER)
  3708.       IF (NPRIB .NE.0)  CALL PHNCHK (DRPRIN)
  3709. C
  3710. C          'NODESAVE',  'ELMTSAVE',  'RSDCOS  '
  3711. C
  3712.       IF (NODSVB.NE.0)  CALL PHNCHK (DRNODE)
  3713.       IF (LEMSVB.NE.0)  CALL PHNCHK (DRELMT)
  3714.       IF (NSKEWS.NE.0)  CALL PHNCHK (DRRSDC)
  3715. C
  3716. C          'EQUATONS',  'NODECORD'
  3717. C
  3718.   100 CALL PHNCHK (DREQUA)
  3719.       CALL PHNCHK (DRNODC)
  3720. C
  3721. C          'NODESYST',  'NODEMIDS',  'NODEFMID',  'ID-ARRAY'
  3722. C
  3723.       IF (NSKEWS.NE.0)  CALL PHNCHK (DRNSYS)
  3724.       IF (NMID  .NE.0)  CALL PHNCHK (DRNMID)
  3725.       IF (NMID  .NE.0)  CALL PHNCHK (DRNFMI)
  3726.       IF (NDISCE.GE.1 .AND. ISTRI.EQ.1)  CALL PHNCHK (DRIDAR)
  3727. C
  3728.       IF (IERROR.NE.0) GOTO 900
  3729. C
  3730. C
  3731. C          IF SUBSTRUCTURES - READ ALL 'SUBSTRUC' TO FIND
  3732. C          NRUSE AND NEGLS AND ACCUMULATE APPROPRIATE VALUES
  3733. C          TO NSTRUC,NEGIT AND NEGAT
  3734. C
  3735.       ISTRI = ISTRI + 1
  3736.       IF (ISTRI.GT.NSTRI) GOTO 900
  3737. C
  3738.   300 DRECLB = DRANY
  3739.       CALL PHNCHK (DRECLB)
  3740.       IF (DRECLB.NE.DREOF) GOTO 310
  3741.         WRITE (NFLOG,2050) DRSUBS,DRECLB
  3742.         GOTO 800
  3743.   310 IF (DRECLB.NE.DRSUBS) GOTO 300
  3744. C
  3745.       BACKSPACE LUNODE
  3746.       READ (LUNODE) DRECLB,NS,NRUSE,NEGLS,NUMNPS,NODCON,NODRET,NSMIDS
  3747.       NSTRUC = NSTRUC + NRUSE
  3748.       NEGIT  = NEGIT  + NEGLS
  3749.       NEGAT  = NEGAT  + NEGLS * NRUSE
  3750.       NMID   = NSMIDS
  3751.       IF (MXNP.LT.NUMNPS) MXNP = NUMNPS
  3752.       IF (MXEG.LT.NEGLS) MXEG = NEGLS
  3753.       CALL ALIGN (MXNP)
  3754.       CALL ALIGN (MXEG)
  3755. C
  3756.       GOTO 100
  3757. C
  3758.   790 WRITE (NFLOG,2060)
  3759.   800 IERROR = 1
  3760.   900 RETURN
  3761. C
  3762.  2000 FORMAT(/36H    LUNODE AND LUELEM RECORD LABELS:)
  3763.  2010 FORMAT(4X,A8,1X,I5)
  3764.  2040 FORMAT (/34H    READING OF PORTHOLE STARTED - ,
  3765.      1  19HADINA HEADING CARD://4X,18A4/)
  3766.  2050 FORMAT (50H ***ERROR: PORTHOLE FILE SEQUENCE ERROR - EXPECTED,
  3767.      1         10H RECORD = ,A8/49X,15HFOUND RECORD = ,A8)
  3768.  2060 FORMAT (52H ***ERROR: CONTROL CARD 9 VARIABLE NPUTSV MUST BE SE,
  3769.      1        44HT TO 1 TO WRITE ADINA INPUT TO PORTHOLE FILE)
  3770.       END
  3771. C***ADD:CDC***
  3772. CDECK PHNCHK
  3773. C***END:CDC***
  3774.       SUBROUTINE PHNCHK (DRWANT)
  3775. C
  3776. C          READ NEXT LUNODE RECORD LABEL AND
  3777. C          IF  DRWANT.EQ.DRANY  RETURN LABEL OR 'END FILE'
  3778. C          ELSE                 CHECK THAT RECORD LABEL = DRWANT
  3779. C
  3780. C***ADD:DPR***
  3781.       IMPLICIT REAL*8(D)
  3782. C***END:DPR***
  3783.       COMMON /ERROR/ IERROR
  3784.       COMMON /FILES/ NFREAD,NFECHO,NFLOG,NFLIST,LUNODE,LUELEM
  3785.       DATA DREOF/8HEND FILE/,DRANY/8HANY REC /
  3786. C
  3787.       IF (IERROR.NE.0) GOTO 90
  3788. C***ADD:CDC***
  3789. C     READ (LUNODE) DRECLB
  3790. C     IF (EOF(LUNODE)) 30, 10
  3791. C***END:CDC***
  3792. C***DEL:CDC***
  3793.       READ (LUNODE,END=30) DRECLB
  3794. C***END:CDC***
  3795. C
  3796.   10  IF (DRWANT.EQ.DRANY)  DRWANT = DRECLB
  3797.       IF (DRECLB.EQ.DRWANT) GOTO 90
  3798.   20  IERROR = 1
  3799.       WRITE (NFLOG,2050) DRWANT, DRECLB
  3800.       GOTO 90
  3801.   30  DRECLB = DREOF
  3802.       GOTO 10
  3803.   90  RETURN
  3804.  2050 FORMAT (54H ***ERROR: PORTHOLE NODEFILE SEQUENCE ERROR - EXPECTED,
  3805.      1         10H RECORD = ,A8/49X,15HFOUND RECORD = ,A8)
  3806.       END
  3807. C***ADD:CDC***
  3808. CDECK PHECHK
  3809. C***END:CDC***
  3810.       SUBROUTINE PHECHK (DRWANT)
  3811. C
  3812. C          READ NEXT LUELEM RECORD LABEL AND
  3813. C          IF  DRWANT.EQ.DRANY  RETURN LABEL OR 'END FILE'
  3814. C          ELSE                 CHECK THAT RECORD LABEL = DRWANT
  3815. C
  3816. C***ADD:DPR***
  3817.       IMPLICIT REAL*8(D)
  3818. C***END:DPR***
  3819.       COMMON /ERROR/ IERROR
  3820.       COMMON /FILES/ NFREAD,NFECHO,NFLOG,NFLIST,LUNODE,LUELEM
  3821.       DATA DREOF/8HEND FILE/,DRANY/8HANY REC /
  3822. C
  3823.       IF (IERROR.NE.0) GOTO 90
  3824. C***ADD:CDC***
  3825. C     READ (LUELEM) DRECLB
  3826. C     IF (EOF(LUELEM)) 30, 10
  3827. C***END:CDC***
  3828. C***DEL:CDC***
  3829.       READ (LUELEM,END=30) DRECLB
  3830. C***END:CDC***
  3831. C
  3832.   10  IF (DRWANT.EQ.DRANY)  DRWANT = DRECLB
  3833.       IF (DRECLB.EQ.DRWANT) GOTO 90
  3834.   20  IERROR = 1
  3835.       WRITE (NFLOG,2050) DRWANT, DRECLB
  3836.       GOTO 90
  3837.   30  DRECLB = DREOF
  3838.       GOTO 10
  3839.   90  RETURN
  3840.  2050 FORMAT (54H ***ERROR: PORTHOLE ELEMFILE SEQUENCE ERROR - EXPECTED,
  3841.      1         10H RECORD = ,A8/49X,15HFOUND RECORD = ,A8)
  3842.       END
  3843. C***ADD:CDC***
  3844. CDECK PHREAD
  3845. C***END:CDC***
  3846.       SUBROUTINE PHREAD (NRUSES,NEGS,NUMNPS,NEQTS,MAXMSS,NODRTS,
  3847.      1                   NPARD,NPAR)
  3848. C
  3849. C          LOAD DATA BASE FROM PORTHOLE FILE
  3850. C
  3851. C***ADD:DPR***
  3852.       IMPLICIT REAL*8(D)
  3853.       REAL DT
  3854. C***END:DPR***
  3855.       DIMENSION IA(1),DA(1)
  3856.       DIMENSION NRUSES(1),NEGS(1),NUMNPS(1),NEQTS(1),MAXMSS(1),NODRTS(1)
  3857.      1          ,NPAR(NPARD,1),MXNODA(15),DRTYP(7),NTABSA(7)
  3858.       COMMON /ERROR/ IERROR
  3859.       COMMON /CNTRL/ IBATCH,NBSU,LSTC,LSTF,LSTDB,ISURL,ITWO,LINPAG,LINE
  3860.       COMMON /FILES/ NFREAD,NFECHO,NFLOG,NFLIST,LUNODE,LUELEM
  3861.       COMMON /DB/ IOPEN,NFDB,INDXST,IXTNOW,LGP,NWRITS,NREADS,
  3862.      1            LDBC,LDBCTR,LDBCTI,IPHCHK,INSTRI,INRUSE,INSTRU,
  3863.      2            MSUBF,MVIEW,MAXIS,MLINEN,MLINEE,MVAR,MRES,LSKEW,MIDSPL
  3864.       COMMON /DBC/ IHED(18),NDAREC,LDAREC,NRECS,NWORDS,NEXREC,NEXTIX,
  3865.      1             LIX,LIXT,NSTRI,NSTRUC,NEGIT,NEGAT,NFREQ,
  3866.      2             IXGP(50),MXSGP(50),
  3867.      3             FILL1
  3868.       COMMON /DIM/ I01,I02,I03,I04,I05,I06,I07,I08,I09,I010,I011,
  3869.      1             I1,I2,I3,I4,I5,I6,I7,I8,I9,I10,I11,I12,I13,I14,I15,
  3870.      2             I16,I17,I18,I19,I20,
  3871.      3             N1,N2,N3,N4,N5,N6,N7,N8,N9,N10,N11,N12,N13,N14,N15,
  3872.      4             N16,N17,N18,N19,N20
  3873.       COMMON /DBCTRL/ DT    ,TSTART,NUMNP ,NEQT  ,NSUBST,IDOF(6),
  3874.      1                NDOF  ,NEG   ,NMID  ,MODEX ,NSTE  ,NSTEN ,
  3875.      2                NSTEE ,NSKEWS,NMIDSS,IEIG  ,NSREFB,NEQITB,
  3876.      3                NPRIB ,NODSVB,LEMSVB,JDC   ,JAC   ,JVC   ,
  3877.      4                ISTAT ,JTC   ,NDISCE,ITP96 ,MXITAB,MXIDER,MXERES,
  3878.      5                NELPAR,MXNP  ,MXEG  ,MXEL  ,MXELNP,
  3879.      6                NDOFSA(6),NOUSE(4),FILL2
  3880.       COMMON /IGPNAM/ KDBC  ,KSUBGP,KDBCTR,KSTRI ,KRSDCO,KTMIDS,
  3881.      1                KXYZ  ,KIDRN ,KICONA,KNZONE,KNPAR ,KTHICK,
  3882.      2                KITABL,KNOD  ,KEDATA,KIEZON,KFRQ  ,KPHI  ,
  3883.      3                KTIMEN,KDISP ,KVEL  ,KACC  ,KTEMP ,KTIMEE,
  3884.      4                KERES ,KSUBF ,KVIEW ,KAXIS ,KNPOIN,KVARES,
  3885.      5                KNAMEZ,KEPOIN,KSXYZ ,KX34  ,KX35  ,KX36  ,
  3886.      6                KX37  ,KX38  ,KX39  ,KX40  ,KX41  ,KX42  ,
  3887.      7                KX43  ,KX44  ,KX45  ,KX46  ,KX47  ,KX48  ,
  3888.      8                KX49  ,KX50
  3889.       COMMON A(1)
  3890.       EQUIVALENCE (A(1),IA(1))
  3891.       EQUIVALENCE (A(1),DA(1))
  3892. C
  3893.       DATA DRMAST/8HMASTERCP/,DRSTIF/8HSTIFNESS/,
  3894.      1     DRITER/8HITERATON/,DRPRIN/8HPRINTOUT/,
  3895.      2     DRNODE/8HNODESAVE/,DRELMT/8HELMTSAVE/,
  3896.      3     DREQUA/8HEQUATONS/,DRNODC/8HNODECORD/,DRIDAR/8HID-ARRAY/,
  3897.      4     DRRSDC/8HRSDCOS  /,DRNSYS/8HNODESYST/,DRNMID/8HNODEMIDS/,
  3898.      5     DRNFMI/8HNODEFMID/,DRSUBS/8HSUBSTRUC/,DRICON/8HICONARAY/
  3899.       DATA DRINOR/8HINORMALS/,DRRNOR/8HRNORMALS/
  3900.       DATA DRTYP/8HTYPE-1  ,8HTYPE-2  ,8HTYPE-3  ,8HTYPE-4  ,
  3901.      1           8HTYPE-5  ,8HTYPE-6  ,8HTYPE-7  /
  3902.       DATA DREOF/8HEND FILE/,DRANY/8HANY REC /,DRTYPX/8HTYPE-X  /
  3903.       DATA MXNODA/4,8,21,3,5,3,32,0,0,0,8,21,0,0,0/
  3904.       DATA ITRUSS,I2DIM,I3DIM,IBEAM,ISOBEA,IPLATE,ISHELL/1,2,3,4,5,6,7/
  3905.       DATA I2DIMF,I3DIMF/11,12/
  3906.       DATA NTABSA/0,9,16,0,0,7,16/
  3907. C
  3908.       REWIND LUNODE
  3909.       MXEL = 0
  3910.       MXELNP = 0
  3911.       MXITAB = 0
  3912.       MXIDER = 0
  3913.       MXERES = 0
  3914.       IEGIT = 0
  3915.       IEGAT = 0
  3916.       ISTRI = 1
  3917.       ISTRUC = 1
  3918.       NRUSE  = 1
  3919.       NMID   = NMIDSS
  3920.       ND1 = N1 / ITWO
  3921. C
  3922. C          'MASTERCP'
  3923. C
  3924.       CALL PHNCHK (DRMAST)
  3925. C
  3926. C          'STIFNESS',  'ITERATON',  'PRINTOUT'
  3927. C
  3928.       IF (NSREFB.NE.0)  CALL PHNCHK (DRSTIF)
  3929.       IF (NEQITB.NE.0)  CALL PHNCHK (DRITER)
  3930.       IF (NPRIB .NE.0)  CALL PHNCHK (DRPRIN)
  3931. C
  3932. C          'NODESAVE',  'ELMTSAVE'
  3933. C
  3934.       IF (NODSVB.NE.0)  CALL PHNCHK (DRNODE)
  3935.       IF (LEMSVB.NE.0)  CALL PHNCHK (DRELMT)
  3936. C
  3937.       IF (IERROR.NE.0) GOTO 900
  3938. C
  3939. C          'RSDCOS  '
  3940. C
  3941.       IF (NSKEWS.EQ.0) GOTO 90
  3942.       LREAL = 9 * NSKEWS
  3943.       I2 = I1 + LREAL * ISURL * ITWO
  3944.       CALL SIZE (I2)
  3945.         IF (IERROR.NE.0) GOTO 900
  3946.       ND1END = ND1 + LREAL - 1
  3947.       DRWANT = DRRSDC
  3948.       READ (LUNODE) DRECLB,IDUM,(DA(I),I=ND1,ND1END)
  3949.       IF (DRECLB.NE.DRWANT) GOTO 790
  3950.       DO 80 I=1,LREAL
  3951.   80    A(N1+I-1) = DA(ND1+I-1)
  3952.       CALL DBWRIT (A(N1),LREAL,0,KRSDCO,1,0)
  3953.         IF (IERROR.NE.0) GOTO 900
  3954. C
  3955. C          SET NDOFSA ARRAY TO SAVED DEGREES OF FREEDOM
  3956. C
  3957.    90 NDOF = 0
  3958.       DO 95  I=1,6
  3959.         NDOFSA(I) = 0
  3960.         IF (IDOF(I).EQ.1) GOTO 95
  3961.         NDOF = NDOF + 1
  3962.         NDOFSA(I) = NDOF
  3963.   95    CONTINUE
  3964. C
  3965. C
  3966. C          SAVE STRUCTURE CONTROL VARIABLES
  3967. C
  3968.   100 NRUSES(ISTRI) = NRUSE
  3969.       NEGS  (ISTRI) = NEG
  3970.       NUMNPS(ISTRI) = NUMNP
  3971. C
  3972. C          BLANK COMMON LAYOUT FOR 'EQUATONS', 'NODECORD',
  3973. C          'NODESYST', 'NODEMIDS', 'NODEFMID'
  3974. C
  3975. C                                                XYZ, TMIDS
  3976.       I2 = I1 + NUMNP * 3 * ISURL * ITWO + 1
  3977. C                                                ID
  3978.       LINT = NUMNP * NDOF
  3979.       I3 = I2 + LINT
  3980. C                                                NRST
  3981.       I4 = I3 + NUMNP
  3982. C                                                MIDS
  3983.       I5 = I4 + NUMNP
  3984.       CALL SIZE (I5)
  3985.         IF (IERROR.NE.0) GOTO 900
  3986.       DO 110 I=I2,I5
  3987.   110   IA(I) = 0
  3988. C
  3989. C          'EQUATONS'
  3990. C
  3991.       IEND = I3 - 1
  3992.       DRWANT = DREQUA
  3993.       READ (LUNODE) DRECLB,IDUM,IDUM,IDUM,IDUM,IDUM,IDUM,IDUM,
  3994.      1              (IA(I),I=I2,IEND),NEQ
  3995.       NEQTS(ISTRI) = NEQ
  3996.       IF (DRECLB.NE.DREQUA) GOTO 790
  3997. C
  3998. C          'NODECORD'
  3999. C
  4000.       LREAL = 3 * NUMNP
  4001.       ND1END = ND1 + LREAL - 1
  4002.       DRWANT = DRNODC
  4003.       READ (LUNODE) DRECLB,IDUM,(DA(I),I=ND1,ND1END)
  4004.       IF (DRECLB.NE.DRNODC) GOTO 790
  4005.       DO 190 I=1,LREAL
  4006.   190   A(N1+I-1) = DA(ND1+I-1)
  4007.       CALL DBWRIT (A(N1),LREAL,0,KXYZ,ISTRUC,0)
  4008.       IF (IERROR.NE.0) GOTO 900
  4009. C
  4010. C          'NODESYST'
  4011. C
  4012.       IF (NSKEWS.GT.0 .OR. NMID.GT.0) LINT = LINT + NUMNP + NUMNP
  4013.       IF (NSKEWS.EQ.0) GOTO 200
  4014.       IEND = I4 - 1
  4015.       DRWANT = DRNSYS
  4016.       READ (LUNODE) DRECLB,IDUM,(IA(I),I=I3,IEND)
  4017.       IF (DRECLB.NE.DRNSYS) GOTO 790
  4018. C
  4019. C          'NODEMIDS'
  4020. C
  4021.   200 IF (NMID.EQ.0) GOTO 210
  4022. C
  4023.       IEND = I4+NUMNP-1
  4024.       DRWANT = DRNMID
  4025.       READ (LUNODE) DRECLB,IDUM,(IA(I),I=I4,IEND)
  4026.       IF (DRECLB.NE.DRNMID) GOTO 790
  4027. C
  4028. C          'NODEFMID'
  4029. C
  4030.   210 IF (NMID.EQ.0) GOTO 230
  4031.       DRWANT = DRNFMI
  4032.       READ (LUNODE) DRECLB,MAXMSI
  4033.       IF (DRECLB.NE.DRNFMI) GOTO 790
  4034.       IF (MAXMSI.EQ.0) GOTO 225
  4035.       BACKSPACE LUNODE
  4036.       LREAL = 3 * MAXMSI
  4037.       ND1END = ND1 + LREAL - 1
  4038.       READ (LUNODE) DRECLB,IDUM,(DA(I),I=ND1,ND1END)
  4039.       DO 220 I=1,LREAL
  4040.   220   A(N1+I-1) = DA(ND1+I-1)
  4041.       CALL DBWRIT (A(N1),LREAL,0,KTMIDS,ISTRI,0)
  4042.         IF (IERROR.NE.0) GOTO 900
  4043.   225 MAXMSS(ISTRI) = MAXMSI
  4044. C
  4045. C          'ID-ARRAY'
  4046. C
  4047.   230 IF (NDISCE.EQ.0 .OR.ISTRI.GT.1) GOTO 240
  4048.       IEND = I3 - 1
  4049.       DRWANT = DRIDAR
  4050.       READ (LUNODE) DRECLB,(IA(I),I=I2,IEND)
  4051.       IF (DRECLB.NE.DRIDAR) GOTO 790
  4052. C
  4053. C          WRITE IDRN RECORD TO DATABASE
  4054. C
  4055.   240 CALL DBWRIT (IA(I2),0,LINT,KIDRN,ISTRI,0)
  4056.         IF (IERROR.NE.0) GOTO 900
  4057. C
  4058. C          ELEMENT 'TYPE-X  '
  4059. C
  4060. C                                                NPAR
  4061.       I2 = I1 + NELPAR * NEG
  4062.       CALL SIZE (I2)
  4063.       IF (IERROR.NE.0) GOTO 900
  4064.       DO 300 I=I1,I2
  4065.   300   IA(I) = 0
  4066. C
  4067.       IF (NEG.EQ.0) GOTO 350
  4068.       DO 340 IEG=1,NEG
  4069.         IEGIT = IEGIT + 1
  4070.         IEGAT = IEGAT + 1
  4071.           DRWANT = DRTYPX
  4072.           DRECLB = DRANY
  4073.           CALL PHECHK (DRECLB)
  4074.           DO 305 IDRTYP=1,7
  4075.             IF (DRECLB.EQ.DRTYP(IDRTYP)) GOTO 310
  4076.   305       CONTINUE
  4077.           GOTO 790
  4078.   310     BACKSPACE LUELEM
  4079.         READ (LUELEM) DRECLB,IEGPH,(NPAR(I,IEG),I=1,20),NSUBPH
  4080.         IF (IEGPH.NE.IEG) GOTO 780
  4081.         IF (NSUBPH.NE.(ISTRI-1)) GOTO 780
  4082. C
  4083.       IELTYP = NPAR(1,IEG)
  4084.       IF (IELTYP.LT.1 .OR.IELTYP.GT.I3DIMF) GOTO 780
  4085. C
  4086.       IF (IELTYP.GT.ISHELL .AND. IELTYP.LT.I2DIMF) GOTO 780
  4087.       NUME = NPAR (2,IEG)
  4088.       IF (MXEL.LT.NUME) MXEL = NUME
  4089.       CALL ALIGN (MXEL)
  4090. C
  4091.       MXNODS = MXNODA(IELTYP)
  4092.       NODDIM = MXNODS * NUME
  4093.       CALL ALIGN (NODDIM)
  4094.       IF (MXELNP.LT.NODDIM) MXELNP = NODDIM
  4095. C
  4096. C          SET NTABLE = NPAR(13) TO ZERO IF ITABLES ARE PRESENT
  4097. C          BUT NOT USED
  4098. C
  4099.       INDNL = NPAR(3,IEG)
  4100.       MODEL = NPAR(15,IEG)
  4101.       IF (NPAR(13,IEG).LE.0) GOTO 320
  4102.       GOTO (319,312,312,314,320,312,316,780,780,780,319,319)
  4103.      1    ,IELTYP
  4104. C          2DIM, 3DIM, PLATE
  4105.   312 IF (MODEL.LE.2) GOTO 320
  4106.       GOTO 319
  4107. C          BEAM
  4108.   314 IF (INDNL.NE.0) GOTO 320
  4109.       GOTO 319
  4110. C          SHELL
  4111.   316 IF (MODEL.EQ.1) GOTO 320
  4112. C          TRUSS, 2DIMF, 3DIMF CANNOT HAVE ITABLES
  4113.   319 NPAR(13,IEG) = 0
  4114.   320 CONTINUE
  4115. C
  4116.       NTABLE = NPAR(13,IEG)
  4117.       NTABSP = NTABSA(IDRTYP)
  4118.       IF (IELTYP.EQ.IBEAM) NTABSP = NPAR(14,IEG)
  4119.       IF (IELTYP.EQ.ISOBEA) NTABSP = NPAR(14,IEG) + 1
  4120.       ITABD = NTABLE * NTABSP
  4121.       IF (MXITAB.LT.ITABD) MXITAB = ITABD
  4122.       CALL ALIGN (MXITAB)
  4123. C
  4124. C          BLANK COMMON LAYOUT FOR ELEMENT DATA
  4125. C
  4126. C                                                ITABLE
  4127.       I3 = I2 + MXITAB
  4128. C                                      NOD
  4129.         I4 = I3 + NODDIM
  4130. C                                      ETIME
  4131.         I5 = I4 + ISURL * NUME
  4132. C                                      IPS
  4133.         I7 = I5 + NUME
  4134. C                                      ITHICK
  4135.       I8 = I7 + NUME
  4136.       CALL ALIGN(I8)
  4137.       NTHDIM = 0
  4138.       IF (IELTYP.EQ.ISHELL)
  4139.      1  NTHDIM = NPAR(8,IEG) * NPAR(14,IEG)
  4140. C                                                THICK
  4141.       I9 = I8 + NTHDIM * ISURL
  4142.       CALL ALIGN (I9)
  4143. C                                                DTHICK
  4144.       I10 = I9 + NTHDIM * ISURL * ITWO
  4145. C                                                DXYZPH
  4146.       I11 = I10 + 392 * 3 * ISURL * ITWO
  4147. C                                                XYZ
  4148.       I12 = I11 + NUMNP * 3 * ISURL
  4149.         CALL SIZE (I12)
  4150.         IF (IERROR.NE.0) GOTO 900
  4151.         DO 325 I=I2,I8
  4152.   325     IA(I) = 0
  4153. C
  4154.       CALL DBREAD (IA(I11),KXYZ,ISTRUC,0)
  4155.       IF (IERROR.NE.0) GOTO 900
  4156. C
  4157.   330   CALL PHEDAT (IDRTYP,IELTYP,DRECLB,DRWANT,IEGIT,MXNODS,IA(I2),
  4158.      1           IA(I3),IA(I4),IA(I5),IA(I7),IA(I8),IA(I9),
  4159.      2           NTHDIM,ITABD,NPAR(1,IEG),IEGAT,NRUSE,
  4160.      3           IA(I11),IA(I10),IA(I12))
  4161.       IF (IERROR.EQ.780) GOTO 780
  4162.       IF (IERROR.EQ.790) GOTO 790
  4163.         IF (IERROR.NE.0) GOTO 900
  4164.   340   CONTINUE
  4165. C
  4166.       CALL DBWRIT (NPAR,0,NELPAR*NEG,KNPAR,ISTRI,0)
  4167.       IF (IERROR.NE.0) GOTO 900
  4168. C
  4169. C          BYPASS MIDSURFACE NORMAL RECORDS
  4170. C
  4171.   350 DRECLB = DRANY
  4172.       CALL PHNCHK (DRECLB)
  4173.       IF (DRECLB.EQ.DRINOR) GOTO 350
  4174.       IF (DRECLB.EQ.DRRNOR) GOTO 350
  4175.       IF (DRECLB.NE.DREOF) BACKSPACE LUNODE
  4176. C
  4177. C          SUBSTRUCTURE NODE CONNECTION TO MAIN STRUCTURE
  4178. C
  4179.       IF (ISTRI.EQ.1) GOTO 390
  4180. C
  4181. C                                                NPAR
  4182. C
  4183. C                                                ETIME
  4184.       I3 = I2 + MXEL * (ISURL + 2)
  4185. C
  4186.       N4 = I3 / ISURL
  4187. C                         XYZ FOR SUBSTRUCTURE IN LOCAL COORDINATES
  4188.       N5 = N4 + NUMNP
  4189.       N6 = N5 + NUMNP
  4190.       N7 = N6 + NUMNP
  4191. C                         XYZ FOR SUBSTRUCTURE IN GLOBAL COORDINATES
  4192.       N8 = N7 + NUMNP
  4193.       N9 = N8 + NUMNP
  4194.       N10 = N9 + NUMNP
  4195. C                                                XYZ FOR MAIN STRUCTURE
  4196.       N = NUMNPS(1)
  4197.       N11 = N10 + N
  4198.       N12 = N11 + N
  4199.       N13 = N12 + N
  4200. C                                                SXYZ
  4201.       I14 = (N13 + 3 * MXIDER) * ISURL
  4202. C                                                ITABLE
  4203.       I15 = I14 + MXITAB
  4204. C                                                ICONA
  4205.       I16 = I15 + NODRET
  4206.       CALL SIZE (I16)
  4207.         IF (IERROR.NE.0) GOTO 900
  4208.       CALL DBREAD (A(N10),KXYZ,1,0)
  4209.         IF (IERROR.NE.0) GOTO 900
  4210.       CALL DBREAD (A(N4),KXYZ,ISTRUC,0)
  4211.         IF (IERROR.NE.0) GOTO 900
  4212. C
  4213. C          'ICONARAY'
  4214. C
  4215.       IEGAT = IEGAT - NEG
  4216.       DO 380 IRUSE=1,NRUSE
  4217. C
  4218.       IF (IRUSE.GT.1)  ISTRUC = ISTRUC + 1
  4219.       DRWANT = DRICON
  4220.       IF (DRECLB.EQ.DREOF) GOTO 790
  4221.       IF (IPHCHK.EQ.0) GOTO 360
  4222.         CALL PHNCHK (DRICON)
  4223.           IF (IERROR.NE.0) GOTO 900
  4224.         BACKSPACE LUNODE
  4225.   360 IEND = I16 - 1
  4226.       READ (LUNODE) DRECLB,(IA(I),I=I15,IEND)
  4227.       IF (DRECLB.NE.DRICON) GOTO 790
  4228.       CALL DBWRIT (IA(I15),0,NODRET,KICONA,ISTRUC-1,0)
  4229.         IF (IERROR.NE.0) GOTO 900
  4230. C
  4231. C          TRANSLATE SUBSTRUCTURE XYZ-COORDINATES TO GLOBAL SYSTEM
  4232. C          BY EQUALIZING CONNECTION NODE 1
  4233. C
  4234.       NPMAIN = IA(I15) - 1
  4235.       XDIFF = A(N10+NPMAIN) - A(N4+NODCON)
  4236.       YDIFF = A(N11+NPMAIN) - A(N5+NODCON)
  4237.       ZDIFF = A(N12+NPMAIN) - A(N6+NODCON)
  4238.       DO 370 NP=1,NUMNP
  4239.       I = NP - 1
  4240.         A(N7+I) = A(N4+I) + XDIFF
  4241.         A(N8+I) = A(N5+I) + YDIFF
  4242.   370   A(N9+I) = A(N6+I) + ZDIFF
  4243. C
  4244. C          SAVE SUBSTRUCTURE REUSE XYZ GLOBAL COORDINATES
  4245. C
  4246.       CALL DBWRIT (A(N7),3*NUMNP,0,KXYZ,ISTRUC,0)
  4247.         IF (IERROR.NE.0) GOTO 900
  4248. C
  4249. C          TRANSLATE SUBSTRUCTURE ELEMENT RESULT POINT
  4250. C          COORDINATES TO GLOBAL SYSTEM
  4251. C
  4252.       IEGIT = IEGIT - NEG
  4253.       DO 375 IEG=1,NEG
  4254.       IEGIT = IEGIT + 1
  4255.       IEGAT = IEGAT + 1
  4256.       NTABLE = NPAR(13,IEG)
  4257.       NUME = NPAR(2,IEG)
  4258.       ISEGIT = 0
  4259.       I3 = I2 + ISURL * NUME
  4260.       CALL ELRES (2,NPAR(1,IEG),IA(I2),IA(I3),IA(I14),
  4261.      1  NTABLE,IEGIT,ISEGIT,0.,IA(I16),IA(I16),NERES,NERKI,LOCLAE)
  4262.       IF (IERROR.NE.0) GOTO 900
  4263.       IF (NERES.EQ.0) GOTO 375
  4264. C
  4265. C          READ SXYZ IN LOCAL COORDINATE SYSTEM AND
  4266. C          WRITE SXYZ IN GLOBAL COORDINATE SYSTEM
  4267. C
  4268.       CALL DBREAD (A(N13),KSXYZ,IEGAT,0)
  4269.       IF (IERROR.NE.0) GOTO 900
  4270.       I = N13
  4271.       DO 373 IERES=1,NERES
  4272.         IF (A(I).EQ.987654E32) GOTO 373
  4273.         A(I) = A(I) + XDIFF
  4274.         A(I+1) = A(I+1) + YDIFF
  4275.         A(I+2) = A(I+2) + ZDIFF
  4276.   373   I = I + 3
  4277.       CALL DBWRIT (A(N13),NERES*3,0,KSXYZ,IEGAT,0)
  4278.       IF (IERROR.NE.0) GOTO 900
  4279.   375 CONTINUE
  4280.   380 CONTINUE
  4281. C
  4282. C          INITIAL CONDITIONS FOR SUBSTRUCTURE IN STATIC ANALYSIS
  4283. C          ARE NOT AVAILIBLE FROM ADINA PORTHOLE FILE,
  4284. C          ZERO RECORDS ARE GENERATED HERE FOR KSTEP=0
  4285. C
  4286.       IF (JDC.EQ.0 .OR. ISTAT.NE.0) GOTO 390
  4287.       LREAL = NDOF * NUMNP
  4288.       IEND = N1 + LREAL - 1
  4289.       DO 383 I=N1,IEND
  4290.   383   A(I) = 0.0
  4291.       DO 385 IRUSE=1,NRUSE
  4292.         I = ISTRUC - NRUSE + IRUSE
  4293.         CALL DBWRIT (A(N1),LREAL,0,KDISP,I,1)
  4294.         IF (IERROR.NE.0) GOTO 900
  4295.   385   CONTINUE
  4296. C
  4297. C          'SUBSTRUC'
  4298. C
  4299.   390 ISTRI = ISTRI + 1
  4300.       ISTRUC = ISTRUC + 1
  4301.       IF (ISTRI.GT.NSTRI) GOTO 400
  4302.       DRWANT = DRSUBS
  4303.       IF (DRECLB.EQ.DREOF) GOTO 790
  4304.       IF (IPHCHK.EQ.0) GOTO 395
  4305.         CALL PHNCHK (DRSUBS)
  4306.         IF (IERROR.NE.0) GOTO 900
  4307.         BACKSPACE LUNODE
  4308.   395 CONTINUE
  4309.       READ (LUNODE) DRECLB,NS,NRUSE,NEG,NUMNP,NODCON,NODRET,NMID
  4310.       IF (DRECLB.NE.DRSUBS) GOTO 790
  4311.       IF (NS.NE.ISTRI-1) GOTO 780
  4312.       NODRTS(ISTRI) = NODRET
  4313.       GOTO 100
  4314. C
  4315. C          BLANK COMMON LAYOUT FOR INITIAL DEFORMATION AND
  4316. C          SOLUTION READING
  4317. C
  4318.   400 NEQTS(1) = NEQTS(1) + NDISCE
  4319.       MXSTEP = NSTE + 1
  4320.       CALL ALIGN(MXSTEP)
  4321. C                                                NPAR
  4322.       I2 = I1 + MXEG * NELPAR
  4323. C                                                TIMEN
  4324.       I3 = I2 + MXSTEP * ISURL
  4325. C                                                NSTEPN
  4326.       I4 = I3 + MXSTEP
  4327. C                                                TIMEE
  4328.       I5 = I4 + MXSTEP * ISURL
  4329. C                                                NSTEPE
  4330.       I6 = I5 + MXSTEP
  4331. C                                                ID,NRST,MIDS
  4332.       I7 = I6 + (NDOF + 2) * MXNP
  4333. C                                                ETIME,IPS,ITHICK
  4334.       I8 = I7 + MXEL * (ISURL + 2)
  4335. C                                                ITABLE
  4336.       I9 = I8 + MXITAB
  4337. C                                                NERPTS
  4338.       I10 = I9 + MXEL
  4339. C                                                IDERPT
  4340.       I18 = I10 + MXIDER
  4341. C                                                RES
  4342.       L = MAX0(NFREQ+100,(NDOF*MXNP),MXERES) * ISURL
  4343.       I19 = I18 + L
  4344.       CALL ALIGN (I19)
  4345. C                                                DINPH
  4346.       I20 = I19 + L * ITWO
  4347.       CALL SIZE (I20)
  4348. C
  4349.       CALL PHSOLU (NRUSES,NEGS,NUMNPS,NEQTS,MAXMSS,NELPAR,IA(I1),
  4350.      1            IA(I2),IA(I3),IA(I4),IA(I5),NDOF,IA(I6),IA(I7),
  4351.      2            IA(I8),IA(I9),IA(I10),IA(I18),IA(I19),DRECLB)
  4352.       GOTO 900
  4353. C
  4354.   780 WRITE (NFLOG,2020) DRECLB
  4355.       GOTO 800
  4356.   790 WRITE (NFLOG,2050) DRWANT,DRECLB
  4357.   800 IERROR = 1
  4358.   900 CONTINUE
  4359. C
  4360. C          WRITE DATABASE RECORDS DBCTRL, STRI
  4361. C
  4362.       CALL DBWRIT (DT,LDBCTR,LDBCTI,KDBCTR,1,0)
  4363.       CALL DBWRIT (IA(I06),0,6*NSTRI,KSTRI,1,0)
  4364.   990 RETURN
  4365. C
  4366.  2020 FORMAT (39H ***ERROR: BAD DATA IN PORTHOLE RECORD ,A8)
  4367.  2050 FORMAT (50H ***ERROR: PORTHOLE FILE SEQUENCE ERROR - EXPECTED,
  4368.      1  10H RECORD = ,A8/45X,15HFOUND RECORD = ,A8)
  4369.       END
  4370. C***ADD:CDC***
  4371. CDECK PHEDAT
  4372. C***END:CDC***
  4373.       SUBROUTINE PHEDAT (IDRTYP,IELTYP,DRECLB,DRWANT,IEGIT,MXNODS,
  4374.      1   ITABLE,NOD,ETIME,IPS,ITHICK,THICK,DTHICK,NTHDIM,ITABD,NPAR,
  4375.      2   IEGAT,NRUSE,XYZ,DXYZPH,SXYZ)
  4376. C
  4377. C          READ ELEMENT DATA FROM PORTHOLE AND LOAD TO DATABASE
  4378. C
  4379. C***ADD:DPR***
  4380.       IMPLICIT REAL*8(D)
  4381.       REAL DT
  4382. C***END:DPR***
  4383.       DIMENSION IA(1),DA(1),NOD(MXNODS,1),ETIME(1)
  4384.       DIMENSION IPS(1),ITHICK(1),DRMAT(7),THICK(1),DTHICK(1)
  4385.       DIMENSION ITABLE(1),DRTAB(7),NPAR(1),IDUMA(1),DRELE(7)
  4386.       DIMENSION DRPOIN(7),XYZ(1),DXYZPH(3,1),SXYZ(3,1)
  4387. C
  4388.       COMMON /CNTRL/ IBATCH,NBSU,LSTC,LSTF,LSTDB,ISURL,ITWO,LINPAG,LINE
  4389.       COMMON /ERROR/ IERROR
  4390.       COMMON /FILES/ NFREAD,NFECHO,NFLOG,NFLIST,LUNODE,LUELEM
  4391.       COMMON /DB/ IOPEN,NFDB,INDXST,IXTNOW,LGP,NWRITS,NREADS,
  4392.      1            LDBC,LDBCTR,LDBCTI,IPHCHK,INSTRI,INRUSE,INSTRU,
  4393.      2            MSUBF,MVIEW,MAXIS,MLINEN,MLINEE,MVAR,MRES,LSKEW,MIDSPL
  4394.       COMMON /DBC/ IHED(18),NDAREC,LDAREC,NRECS,NWORDS,NEXREC,NEXTIX,
  4395.      1             LIX,LIXT,NSTRI,NSTRUC,NEGIT,NEGAT,NFREQ,
  4396.      2             IXGP(50),MXSGP(50),
  4397.      3             FILL1
  4398.       COMMON /DIM/ I01,I02,I03,I04,I05,I06,I07,I08,I09,I010,I011,
  4399.      1             I1,I2,I3,I4,I5,I6,I7,I8,I9,I10,I11,I12,I13,I14,I15,
  4400.      2             I16,I17,I18,I19,I20,
  4401.      3             N1,N2,N3,N4,N5,N6,N7,N8,N9,N10,N11,N12,N13,N14,N15,
  4402.      4             N16,N17,N18,N19,N20
  4403.       COMMON /DBCTRL/ DT    ,TSTART,NUMNP ,NEQT  ,NSUBST,IDOF(6),
  4404.      1                NDOF  ,NEG   ,NMID  ,MODEX ,NSTE  ,NSTEN ,
  4405.      2                NSTEE ,NSKEWS,NMIDSS,IEIG  ,NSREFB,NEQITB,
  4406.      3                NPRIB ,NODSVB,LEMSVB,JDC   ,JAC   ,JVC   ,
  4407.      4                ISTAT ,JTC   ,NDISCE,ITP96 ,MXITAB,MXIDER,MXERES,
  4408.      5                NELPAR,MXNP  ,MXEG  ,MXEL  ,MXELNP,
  4409.      6                NDOFSA(6),NOUSE(4),FILL2
  4410.       COMMON /IGPNAM/ KDBC  ,KSUBGP,KDBCTR,KSTRI ,KRSDCO,KTMIDS,
  4411.      1                KXYZ  ,KIDRN ,KICONA,KNZONE,KNPAR ,KTHICK,
  4412.      2                KITABL,KNOD  ,KEDATA,KIEZON,KFRQ  ,KPHI  ,
  4413.      3                KTIMEN,KDISP ,KVEL  ,KACC  ,KTEMP ,KTIMEE,
  4414.      4                KERES ,KSUBF ,KVIEW ,KAXIS ,KNPOIN,KVARES,
  4415.      5                KNAMEZ,KEPOIN,KSXYZ ,KX34  ,KX35  ,KX36  ,
  4416.      6                KX37  ,KX38  ,KX39  ,KX40  ,KX41  ,KX42  ,
  4417.      7                KX43  ,KX44  ,KX45  ,KX46  ,KX47  ,KX48  ,
  4418.      8                KX49  ,KX50
  4419.       COMMON A(1)
  4420.       EQUIVALENCE (A(1),IA(1))
  4421.       EQUIVALENCE (A(1),DA(1))
  4422.       DATA DRMAT/8HMATERAL1,8HMATERAL2,8HMATERAL3,8HMATERAL4,
  4423.      1           8HMATERAL5,8HMATERAL6,8HMATERAL7/
  4424.       DATA DRTAB/8HOUTABLE1,8HOUTABLE2,8HOUTABLE3,8HOUTABLE4,
  4425.      1           8HOUTABLE5,8HOUTABLE6,8HOUTABLE7/
  4426.       DATA DRELE/8HELEMENT1,8HELEMENT2,8HELEMENT3,8HELEMENT4,
  4427.      1           8HELEMENT5,8HELEMENT6,8HELEMENT7/
  4428.       DATA DRPOIN/8HIPOINT-1,8HIPOINT-2,8HIPOINT-3,8HIPOINT-4,
  4429.      1            8HIPOINT-5,8HIPOINT-6,8HIPOINT-7/
  4430.       DATA DRANY/8HANY REC /
  4431.       DATA DRSEC4/8HSECTION4/,DRTHIC/8HTHICKNES/
  4432.       DATA ITRUSS,I2DIM,I3DIM,IBEAM,ISOBEA,IPLATE,ISHELL/1,2,3,4,5,6,7/
  4433.       DATA I2DIMF,I3DIMF/11,12/
  4434. C
  4435.       NUME = NPAR(2)
  4436.       NTABLE = NPAR(13)
  4437.       INDNL = NPAR(3)
  4438.       MODEL = NPAR(15)
  4439. C
  4440. C          'MATERALX'
  4441. C
  4442.       DRWANT = DRMAT(IDRTYP)
  4443.       NUMMAT = NPAR(16)
  4444.   50  CALL PHECHK(DRWANT)
  4445.       IF (IERROR.NE.0) GOTO 900
  4446.       NUMMAT = NUMMAT - 1
  4447.       IF (IELTYP.EQ.IBEAM .AND. INDNL.LE.0 .AND. NUMMAT.GT.0) GOTO 50
  4448. C
  4449. C          'SECTION4'
  4450. C
  4451.       IF (IELTYP.EQ.IBEAM) CALL PHECHK (DRSEC4)
  4452.       IF (IERROR.NE.0) GOTO 900
  4453. C
  4454. C          'OUTABLEX'
  4455. C
  4456.       IF (IELTYP.EQ.ITRUSS) GOTO 100
  4457.       DRWANT = DRTAB(IDRTYP)
  4458.       IF (NTABLE.LE.0 .OR. IPHCHK.EQ.1) CALL PHECHK (DRWANT)
  4459.         IF (IERROR.NE.0) GOTO 900
  4460.         IF (NTABLE.LE.0) GOTO 100
  4461.         IF (IPHCHK.EQ.1) BACKSPACE LUELEM
  4462.       READ (LUELEM) DRECLB,NTABS,(ITABLE(I),I=1,ITABD)
  4463.       IF (DRECLB.NE.DRWANT) GOTO 790
  4464.       IF (NTABS.NE.NTABLE) GOTO 780
  4465.       CALL DBWRIT (ITABLE,0,ITABD,KITABL,IEGIT,0)
  4466.       IF (IERROR.NE.0) GOTO 900
  4467. C
  4468. C
  4469. C          'THICKNES'
  4470. C
  4471.   100 IF (IELTYP.NE.ISHELL) GOTO 200
  4472.       DRWANT = DRTHIC
  4473.       IF (NTHDIM.EQ.0 .OR. IPHCHK.EQ.1) CALL PHECHK (DRWANT)
  4474.         IF (IERROR.NE.0) GOTO 900
  4475.         IF (NTHDIM.EQ.0) GOTO 200
  4476.         IF (IPHCHK.EQ.1) BACKSPACE LUELEM
  4477.       READ (LUELEM) DRECLB,NTHICK,MXMNOD,(DTHICK(I),I=1,NTHDIM)
  4478.       IF (DRECLB.NE.DRWANT) GOTO 790
  4479.       DO 110 I=1,NTHDIM
  4480.   110   THICK(I) = DTHICK(I)
  4481.       CALL DBWRIT (THICK,NTHDIM,0,KTHICK,IEGIT,0)
  4482.       IF (IERROR.NE.0) GOTO 900
  4483. C
  4484. C          'ELEMENTX'
  4485. C
  4486.   200 MXNPT = 0
  4487.       DO 520 IEL=1,NUME
  4488. C
  4489.       DRWANT = DRELE(IDRTYP)
  4490.       IF (IPHCHK.EQ.0) GOTO 300
  4491.         CALL PHECHK (DRWANT)
  4492.         IF (IERROR.NE.0) GOTO 900
  4493.         BACKSPACE LUELEM
  4494. C
  4495.   300 GOTO (310,320,330,340,350,360,370,780,780,780,410,420)
  4496.      1     ,IELTYP
  4497. C
  4498.   310 READ (LUELEM) DRECLB,IDUM,IELDPH,IPSPH,IDUM,IDUM,
  4499.      1                DDUM,DETIME,(NOD(I,IEL),I=1,IELDPH)
  4500.       GOTO 500
  4501.   320 READ (LUELEM) DRECLB,IDUM,IELDPH,IPSPH,IDUM,
  4502.      1               DDUM,DDUM,DETIME,IDUM,(NOD(I,IEL),I=1,8)
  4503.       GOTO 500
  4504.   330 READ (LUELEM) DRECLB,IDUM,IELDPH,IDUM,IPSPH,IDUM,
  4505.      1         IDUM,IDUM,DETIME,IDUM,IELN,(NOD(I,IEL),I=1,IELN)
  4506.       GOTO 500
  4507.   340 READ (LUELEM) DRECLB,IDUM,(NOD(I,IEL),I=1,3),IDUM,IPSPH
  4508.      1              ,DETIME
  4509.       GOTO 500
  4510.   350 READ (LUELEM) DRECLB,IDUM,IELDPH,IPSPH,IDUM,
  4511. C    1         DETIME,IDUM,NOD(5,IEL),(NOD(I,IEL),I=1,4)
  4512.      1         DETIME,IDUM,NOD(5,IEL),(NOD(I,IEL),I=1,IELDPH)
  4513.       GOTO 500
  4514.   360 READ (LUELEM) DRECLB,IDUM,IPSPH,IDUM,
  4515.      1         DDUM,DETIME,IDUM,(NOD(I,IEL),I=1,3)
  4516.       GOTO 500
  4517.   370 READ (LUELEM) DRECLB,IDUM,IELDPH,IPSPH,ITHICK(IEL),
  4518.      1   IDUM,IDUM,IDUM,DETIME,IDUM,IELN,(NOD(I,IEL),I=1,IELN)
  4519.       GOTO 500
  4520.   410 READ (LUELEM) DRECLB,IDUM,IELDPH,IPSPH,IDUM,
  4521.      1             DETIME,IDUM,(NOD(I,IEL),I=1,8)
  4522.       GOTO 500
  4523.   420 READ (LUELEM) DRECLB,IDUM,IELDPH,IDUM,IPSPH,IDUM,
  4524.      1         IDUM,DETIME,IDUM,IELN,(NOD(I,IEL),I=1,IELN)
  4525.       GOTO 500
  4526. C
  4527.   500 IF (DRECLB.NE.DRWANT) GOTO 790
  4528.       ETIME(IEL) = DETIME
  4529.       IPS  (IEL) = IPSPH
  4530. C
  4531. C          'IPOINT-X'
  4532. C
  4533.       IF (IELTYP.EQ.ITRUSS .AND. NPAR(5).EQ.1) GOTO 520
  4534.       IF (IELTYP.EQ.IBEAM .AND. NPAR(3).LE.0) GOTO 520
  4535.       DRWANT = DRPOIN(IDRTYP)
  4536.       IF (IPHCHK.EQ.0) GOTO 510
  4537.         CALL PHECHK (DRWANT)
  4538.         IF (IERROR.NE.0) GOTO 900
  4539.         BACKSPACE LUELEM
  4540.   510 READ (LUELEM) DRECLB, NPTPH
  4541.       IF (DRECLB.NE.DRWANT) GOTO 790
  4542.       IF (MXNPT.LT.NPTPH) MXNPT = NPTPH
  4543.       IF (NPTPH.LT.1 .OR. NPTPH.GT.392) GOTO 780
  4544.   520 CONTINUE
  4545. C
  4546. C          WRITE ELEMENT NODS AND DATA TO DATABASE
  4547. C
  4548.       CALL DBWRIT (NOD,0,MXNODS*NUME,KNOD,IEGIT,0)
  4549.       IF (IERROR.NE.0) GOTO 900
  4550.       CALL DBWRIT (ETIME,NUME,2*NUME,KEDATA,IEGIT,0)
  4551.       IF (IERROR.NE.0) GOTO 900
  4552. C
  4553. C          UPDATE MXIDER, MXERES
  4554. C
  4555.       CALL ELRES (2,NPAR,ETIME,IPS,ITABLE,NTABLE,
  4556.      1         IEGIT,IEGIT,0.,IDUMA,IDUMA,NERES,NERKI,LOCALE)
  4557.       IF (IERROR.NE.0) GOTO 900
  4558.       CALL ALIGN (MXIDER)
  4559.       CALL ALIGN (MXERES)
  4560. C
  4561. C
  4562. CCCCCCCCCC      READ 'IPOINT-X' AND LOAD SXYZ
  4563. C
  4564. C
  4565.       IF (NERES.EQ.0) GOTO 900
  4566. C
  4567. C          BACKSPACE TO FIRST 'ELEMENTX' RECORD FOR THIS EG
  4568. C
  4569.       J = NUME
  4570.       IF (MXNPT.GT.0) J = J + NUME
  4571.       DO 530 I=1,J
  4572.         BACKSPACE LUELEM
  4573.   530   CONTINUE
  4574. C
  4575. C                                                SXYZ
  4576.       I13 = I12 + NERES * 3 * ISURL
  4577. C                                                NERPTS
  4578.       I14 = I13 + NUME
  4579. C                                                IDERPT
  4580.       I15 = I14 + NERES
  4581. C
  4582.       CALL SIZE (I15)
  4583.       IF (IERROR.NE.0) GOTO 900
  4584. C
  4585.       DO 540 I=1,NERES
  4586.       DO 540 J=1,3
  4587.   540   SXYZ(J,I) = 987654E32
  4588. C
  4589.       CALL ELRES (1,NPAR,ETIME,IPS,ITABLE,NTABLE,
  4590.      1  IEGIT,IEGIT,0.,IA(I13),IA(I14),NERES,NERKI,LOCALE)
  4591.       IF (IERROR.NE.0) GOTO 900
  4592. C
  4593.       IXIDER = 1
  4594. C
  4595.       DO 700 IEL=1,NUME
  4596.       NERPT = IA(I13+IEL-1)
  4597. C
  4598. C          BYPASS 'ELEMENTX'
  4599. C
  4600.       DRWANT = DRELE(IDRTYP)
  4601.       CALL PHECHK (DRWANT)
  4602.       IF (IERROR.NE.0) GOTO 900
  4603. C
  4604. C          'IPOINT-X'
  4605. C
  4606.       DRWANT = DRPOIN(IDRTYP)
  4607.       DRECLB = DRWANT
  4608.       IF (MXNPT.GT.0)
  4609.      1  READ (LUELEM) DRECLB,NPTPH,((DXYZPH(L,I),L=1,3),I=1,NPTPH)
  4610.       IF (DRECLB.NE.DRWANT) GOTO 790
  4611.       IF (NERPT.EQ.0) GOTO 700
  4612. C
  4613.       GOTO (550,560,560,570,580,560,560,780,780,780,560,560)
  4614.      1  ,IELTYP
  4615. C
  4616. C          TRUSS - RING ELEMENT: ONE NODE POINT
  4617. C                  2-NODE ELEMENT: ALL INTEGRATION POINTS
  4618. C
  4619.   550 IF (NPAR(5).NE.1) GOTO 600
  4620.       GOTO 680
  4621. C
  4622. C          2DIM,3DIM,PLATE,SHELL,2DIMF,3DIMF:
  4623. C            NTABLE.GT.0 - STRESS OUTPUT TABLE NUMBERS
  4624. C            NTABLE.LE.0 - INTEGRATION POINTS (SOME OR ALL)
  4625. C
  4626.   560 IF (NTABLE.GT.0 ) GOTO 690
  4627.       GOTO 600
  4628. C
  4629. C          BEAM: AT INTEGRATION POINTS (ALL OR SELECTED BY ITABLE)
  4630. C                OR AT 2 NODE POINTS
  4631. C
  4632.   570 IF (INDNL.EQ.0 .OR. NTABLE.LT.0) GOTO 680
  4633.       GOTO 630
  4634. C
  4635. C          ISOBEAM: AT INTEGRATION POINTS (ALL OR SELECTED BY ITABLE)
  4636. C                   OR AT 2-4 NODE POINTS
  4637. C
  4638.   580 IF (NTABLE.LT.0) GOTO 680
  4639.       GOTO 630
  4640. C
  4641. C          INTEGRATION POINTS ARE NUMBERED FROM 1 AND UP
  4642. C          'IPOINT-X' CONTAINS COORDINATES FOR ALL INTEGRATION POINTS
  4643. C          PORTHOLE ELEMENT RESULTS ARE FOR ALL OR SOME OF THE POINTS
  4644. C
  4645.   600 DO 620 IERPT=1,NERPT
  4646.         IDERES = IABS(IA(I14+IXIDER-1))
  4647.         IF (IDERES.GT.NPTPH) GOTO 780
  4648.         DO 610 I=1,3
  4649.   610     SXYZ(I,IXIDER) = DXYZPH(I,IDERES)
  4650.   620   IXIDER = IXIDER + 1
  4651.       GOTO 700
  4652. C
  4653. C          INTEGRATION POINTS FOR BEAM AND ISOBEAM ARE DEFINED BY
  4654. C          A 3-DIGIT NUMBER
  4655. C          'IPOINT' CONTAINS COORDINATES FOR ALL INTEGRATION POINTS
  4656. C          PORTHOLE ELEMENT RESULTS ARE FOR ALL OR SOME OF THE POINTS
  4657. C          IN THE SAME OR A DIFFERENT SEQUENCE
  4658. C
  4659.   630 INTX = NPAR(9)
  4660.       INTY = NPAR(10)
  4661.       INTZ = NPAR(11)
  4662.       DO 670 IERPT=1,NERPT
  4663.         IDERES = IABS(IA(I14+IXIDER-1))
  4664.         IPT = 0
  4665.         DO 640 I=1,INTX
  4666.         DO 640 J=1,INTY
  4667.         DO 640 K=1,INTZ
  4668.           IPT = IPT + 1
  4669.           IF (IPT.GT.NPTPH) GOTO 780
  4670.           IDERWK = I*100 + J*10 + K
  4671.           IF (IDERES.EQ.IDERWK) GOTO 650
  4672.   640     CONTINUE
  4673.         GOTO 780
  4674.   650   DO 660 I=1,3
  4675.   660     SXYZ(I,IXIDER) = DXYZPH(I,IPT)
  4676.   670   IXIDER = IXIDER + 1
  4677.       GOTO 700
  4678. C
  4679. C          ELEMENT NODAL POINT NUMBERS
  4680. C
  4681.   680 DO 685 IERPT=1,NERPT
  4682.         INOD = NOD(IERPT,IEL)
  4683.         DO 682 I=1,3
  4684.           J = INOD + (I - 1) * NUMNP
  4685.           IF (INOD.GT.0) SXYZ(I,IXIDER) = XYZ(J)
  4686.   682     CONTINUE
  4687.   685   IXIDER = IXIDER + 1
  4688.       GOTO 700
  4689. C
  4690. C          STRESS OUTPUT TABLE NUMBERS AND NOT INTEGRATION POINT NUMBERS
  4691. C          COORDINATES ARE NOT CALCULATED
  4692. C
  4693.   690 IXIDER = IXIDER + NERPT
  4694. C
  4695.   700 CONTINUE
  4696. C
  4697. C          WRITE SXYZ, FOR SUBSTRUCTURE TO ALL REUSE IDS
  4698. C
  4699.       DO 710 IRUSE=1,NRUSE
  4700.         I = IEGAT + (IRUSE - 1) * NEG
  4701.         CALL DBWRIT (SXYZ,3*NERES,0,KSXYZ,I,0)
  4702.         IF (IERROR.NE.0) GOTO 900
  4703.   710   CONTINUE
  4704. C
  4705. C
  4706.       GOTO 900
  4707. C
  4708.   780 IERROR = 780
  4709.       GOTO 900
  4710.   790 IERROR = 790
  4711.   900 RETURN
  4712.       END
  4713. C***ADD:CDC***
  4714. CDECK PHSOLU
  4715. C***END:CDC***
  4716.       SUBROUTINE PHSOLU (NRUSES,NEGS,NUMNPS,NEQTS,MAXMSS,NPARD,NPAR,
  4717.      1                  TIMEN,NSTEPN,TIMEE,NSTEPE,NDOFD,ID,ETIME,
  4718.      2                  ITABLE,NERPTS,IDERPT,RES,DINPH,DRECLB)
  4719. C
  4720. C          READ RESULT FROM PORTHOLE FILE AND LOAD DATABASE
  4721. C
  4722. C
  4723. C***ADD:DPR***
  4724.       IMPLICIT REAL*8(D)
  4725.       REAL DT
  4726. C***END:DPR***
  4727.       DIMENSION IA(1),DA(1),NRUSES(1),NEGS(1),NUMNPS(1),NEQTS(1),
  4728.      1          MAXMSS(1),NPAR(NPARD,1),TIMEN(1),NSTEPN(1),TIMEE(1),
  4729.      2          NSTEPE(1),ID(NDOFD,1),ETIME(1),RES(1),DINPH(1),
  4730.      3          NPARPH(20),DRNEW(7),DROUT(7),ITABLE(1),NERPTS(1),
  4731.      4          IDERPT(1)
  4732. C
  4733.       COMMON /ERROR/ IERROR
  4734.       COMMON /CNTRL/ IBATCH,NBSU,LSTC,LSTF,LSTDB,ISURL,ITWO,LINPAG,LINE
  4735.       COMMON /FILES/ NFREAD,NFECHO,NFLOG,NFLIST,LUNODE,LUELEM
  4736.       COMMON /DB/ IOPEN,NFDB,INDXST,IXTNOW,LGP,NWRITS,NREADS,
  4737.      1            LDBC,LDBCTR,LDBCTI,IPHCHK,INSTRI,INRUSE,INSTRU,
  4738.      2            MSUBF,MVIEW,MAXIS,MLINEN,MLINEE,MVAR,MRES,LSKEW,MIDSPL
  4739.       COMMON /DBC/ IHED(18),NDAREC,LDAREC,NRECS,NWORDS,NEXREC,NEXTIX,
  4740.      1             LIX,LIXT,NSTRI,NSTRUC,NEGIT,NEGAT,NFREQ,
  4741.      2             IXGP(50),MXSGP(50),
  4742.      3             FILL1
  4743.       COMMON /DIM/ I01,I02,I03,I04,I05,I06,I07,I08,I09,I010,I011,
  4744.      1             I1,I2,I3,I4,I5,I6,I7,I8,I9,I10,I11,I12,I13,I14,I15,
  4745.      2             I16,I17,I18,I19,I20,
  4746.      3             N1,N2,N3,N4,N5,N6,N7,N8,N9,N10,N11,N12,N13,N14,N15,
  4747.      4             N16,N17,N18,N19,N20
  4748.       COMMON /DBCTRL/ DT    ,TSTART,NUMNP ,NEQT  ,NSUBST,IDOF(6),
  4749.      1                NDOF  ,NEG   ,NMID  ,MODEX ,NSTE  ,NSTEN ,
  4750.      2                NSTEE ,NSKEWS,NMIDSS,IEIG  ,NSREFB,NEQITB,
  4751.      3                NPRIB ,NODSVB,LEMSVB,JDC   ,JAC   ,JVC   ,
  4752.      4                ISTAT ,JTC   ,NDISCE,ITP96 ,MXITAB,MXIDER,MXERES,
  4753.      5                NELPAR,MXNP  ,MXEG  ,MXEL  ,MXELNP,
  4754.      6                NDOFSA(6),NOUSE(4),FILL2
  4755.       COMMON /IGPNAM/ KDBC  ,KSUBGP,KDBCTR,KSTRI ,KRSDCO,KTMIDS,
  4756.      1                KXYZ  ,KIDRN ,KICONA,KNZONE,KNPAR ,KTHICK,
  4757.      2                KITABL,KNOD  ,KEDATA,KIEZON,KFRQ  ,KPHI  ,
  4758.      3                KTIMEN,KDISP ,KVEL  ,KACC  ,KTEMP ,KTIMEE,
  4759.      4                KERES ,KSUBF ,KVIEW ,KAXIS ,KNPOIN,KVARES,
  4760.      5                KNAMEZ,KEPOIN,KSXYZ ,KX34  ,KX35  ,KX36  ,
  4761.      6                KX37  ,KX38  ,KX39  ,KX40  ,KX41  ,KX42  ,
  4762.      7                KX43  ,KX44  ,KX45  ,KX46  ,KX47  ,KX48  ,
  4763.      8                KX49  ,KX50
  4764.       COMMON A(1)
  4765.       EQUIVALENCE (A(1),IA(1))
  4766.       EQUIVALENCE (A(1),DA(1))
  4767. C
  4768.       DATA DRFREQ/8HFREQENCY/,DREIGN/8HEIGNVCTR/,DRNEWS/8HNEW STEP/
  4769.       DATA DRDISP/8HDISP-XYZ/,DRVELO/8HVELOCITY/,DRACCL/8HACCLERTN/
  4770.       DATA DRTEMP/8HTEMPERAT/,DRNEWN/8HNEWNORMS/
  4771.       DATA DRNEW/8HNEWSTEP1,8HNEWSTEP2,8HNEWSTEP3,8HNEWSTEP4,
  4772.      1           8HNEWSTEP5,8HNEWSTEP6,8HNEWSTEP7/
  4773.       DATA DROUT/8HOUTPUT-1,8HOUTPUT-2,8HOUTPUT-3,8HOUTPUT-4,
  4774.      1           8HOUTPUT-5,8HOUTPUT-6,8HOUTPUT-7/
  4775.       DATA DRMAST/8HMASTERCP/
  4776. C
  4777.       DATA DREOF/8HEND FILE/,DRANY/8HANY REC /,DRTYPX/8HTYPE-X  /
  4778.       DATA ITRUSS,I2DIM,I3DIM,IBEAM,ISOBEA,IPLATE,ISHELL/1,2,3,4,5,6,7/
  4779.       DATA I2DIMF,I3DIMF/11,12/
  4780. C
  4781. C          SOLUTION AND INITIAL DEFORMATION READING
  4782. C
  4783.       WRITE (NFLOG,2065)
  4784.       NOTOK = 0
  4785.       NSTEN = 0
  4786.       NSTEE = 0
  4787.       IIDRN = 0
  4788.       IIEDAT = 0
  4789.       IINPAR = 0
  4790.       ISUBFN = 0
  4791. C
  4792. C
  4793. C          READ NEXT NEWSTEP, FREQUENCE, TEMPERATURE RECORD
  4794. C
  4795.       LU = LUNODE
  4796.       IF (DRECLB.EQ.DREOF) GOTO 410
  4797.   400 DRECLB = DRANY
  4798.       IF (LU.EQ.LUNODE) CALL PHNCHK (DRECLB)
  4799.       IF (LU.NE.LUNODE) CALL PHECHK (DRECLB)
  4800.         IF (IERROR.NE.0) GOTO 900
  4801.       IF (DRECLB.EQ.DREOF) GOTO 410
  4802.       IF (DRECLB.EQ.DRMAST) GOTO 410
  4803.       IF (DRECLB.EQ.DRNEWN) GOTO 400
  4804.       IF (DRECLB.EQ.DREIGN) GOTO 400
  4805.       BACKSPACE LU
  4806. C
  4807. C
  4808.       IF (DRECLB.EQ.DRFREQ) GOTO 450
  4809.       IF (DRECLB.EQ.DRNEWS) GOTO 500
  4810.       IF (DRECLB.EQ.DRTEMP) GOTO 580
  4811.       DO 407 IDRTYP=1,7
  4812.         IF (DRECLB.EQ.DRNEW(IDRTYP)) GOTO 600
  4813.   407   CONTINUE
  4814.         WRITE (NFLOG,2000) DRECLB
  4815.         GOTO 419
  4816.   410 IF (LU.EQ.LUELEM) GOTO 420
  4817.         LU = LUELEM
  4818.         GOTO 400
  4819. C
  4820. C          END OF FILE CHECK THAT RESULTS ARE COMPLETE TIMESTEPS,
  4821. C          WRITE TIMESTEP RECORDS TO DATABASE
  4822. C
  4823.   419 NOTOK = 1
  4824.       IERROR = 0
  4825.   420 KSTEP = 999999
  4826.       IF (NSTEN.EQ.0) GOTO 435
  4827.       IF (NOTOK.EQ.1) GOTO 425
  4828.       IF (ISTAT.EQ.0 .AND. NSTEN.EQ.1) GOTO 425
  4829.       IF (ISTRUN.NE.NSTRUC .OR. ISTEN.NE.NSTEN) GOTO 505
  4830.   425 WRITE (NFLOG,2070) TIMEN(1)
  4831.       I = NSTEN - 1
  4832.       IF (I.GT.0) WRITE (NFLOG,2071) I,TIMEN(2),TIMEN(NSTEN)
  4833.       J = I2 + NSTEN * ISURL
  4834.       DO 430 I=1,NSTEN
  4835.   430   IA(J+I-1) = NSTEPN(I)
  4836.       CALL DBWRIT (TIMEN,NSTEN,NSTEN,KTIMEN,1,0)
  4837.       IF (IERROR.NE.0) GOTO 900
  4838. C
  4839.   435 IF (NSTEE.EQ.0) GOTO 445
  4840.       IF (NOTOK.EQ.1) GOTO 437
  4841.       IF (ISTEE.NE.NSTEE) GOTO 605
  4842.       IF (IEGCHK.NE.NEGS(NSTRI) .OR. IRUSEE.NE.NRUSES(NSTRI)) GOTO 605
  4843.   437 WRITE (NFLOG,2080) NSTEE,TIMEE(1),TIMEE(NSTEE)
  4844.       J = I4 + NSTEE * ISURL
  4845.       DO 440 I=1,NSTEE
  4846.   440   IA(J+I-1) = NSTEPE(I)
  4847.       CALL DBWRIT (TIMEE,NSTEE,NSTEE,KTIMEE,1,0)
  4848.   445 IF (NOTOK.EQ.1) WRITE (NFLOG,2090)
  4849.       GOTO 900
  4850. C
  4851. C
  4852. CCCCCCCCC  'FREQENCY'
  4853. C
  4854.   450 READ (LUNODE) DRECLB,IDUM,IDUM,IDUM,(DINPH(I),I=1,NFREQ)
  4855. C
  4856.       DO 460 IFREQ=1,NFREQ
  4857.   460   RES(IFREQ) = DINPH(IFREQ)
  4858.       CALL DBWRIT (RES,NFREQ,0,KFRQ,1,0)
  4859.         IF (IERROR.NE.0) GOTO 900
  4860.       IF (IIDRN.EQ.1) GOTO 465
  4861.         CALL DBREAD (ID,KIDRN,1,0)
  4862.           IF (IERROR.NE.0) GOTO 900
  4863.         IIDRN = 1
  4864. C
  4865. C          'EIGNVCTR'
  4866. C
  4867.   465 NUMNP = NUMNPS(1)
  4868.       NEQT   = NEQTS(1)
  4869.       DO 470 IFREQ=1,NFREQ
  4870.         CALL PHEQR (DREIGN,KPHI,IFREQ,0,NDOF,ID,RES,DINPH)
  4871.           IF (IERROR.NE.0) GOTO 900
  4872.   470   CONTINUE
  4873.       GOTO 400
  4874. C
  4875. C
  4876. CCCCCCCCC  NODAL SOLUTION OUTPUT
  4877. C          'NEW STEP'
  4878. C
  4879.   500 READ (LUNODE) DRECLB,KSTEP,DTIME,I,I,I,I,I,I,I,I,NSUBPH
  4880.       TIME = DTIME
  4881. C
  4882. C          PROCEDURE FOR NEW NODAL TIMESTEP - MAIN STRUCTURE
  4883. C
  4884.       IF (NSUBPH.GT.0) GOTO 502
  4885.         NSTEN = NSTEN + 1
  4886.         ISTEN = NSTEN
  4887.         TIMEN (NSTEN) = TIME
  4888.         NSTEPN(NSTEN) = KSTEP
  4889.         ISTRIN = 1
  4890.         IRUSEN = 1
  4891.         ISTRUN = 1
  4892.         ISUBFN = 0
  4893.         GOTO 530
  4894. C
  4895. C          CHECK FOR NEW SUBSTRUCTURE TIMESTEP
  4896. C
  4897.   502 IF (ISUBFN.EQ.1) GOTO 504
  4898.         ISUBFN = 1
  4899.         ISTEN = 1
  4900.         IF (KSTEP.GT.0) GOTO 510
  4901.           ISTEN = 1
  4902.           NSTEPN(ISTEN) = 0
  4903.           GOTO 511
  4904.   504 IF (KSTEP.EQ.NSTEPN(ISTEN)) GOTO 520
  4905.         IF (ISTRUN.EQ.NSTRUC) GOTO 510
  4906.   505     WRITE (NFLOG,2010) NSTEPN(ISTEN),ISTRUN,NSTRUC,KSTEP
  4907.      1                       ,ISTRIN,NSUBPH,DRECLB
  4908.           GOTO 419
  4909.   510 IF (ISTEN.GE.NSTEN) GOTO 505
  4910.       ISTEN = ISTEN + 1
  4911.   511 ISTRIN = 2
  4912.       IRUSEN = 0
  4913.       ISTRUN = 1
  4914. C
  4915. C          INCREMENT NODAL SUBSTRUCTURE AND REUSE IDENTIFICATION
  4916. C
  4917.   520 ISTRUN = ISTRUN + 1
  4918.       IRUSEN = IRUSEN + 1
  4919.       IF (IRUSEN.LE.NRUSES(ISTRIN)) GOTO 530
  4920.         ISTRIN = ISTRIN + 1
  4921.         IRUSEN = 1
  4922. C
  4923.   530 NUMNP = NUMNPS(ISTRIN)
  4924.       NEQT  = NEQTS(ISTRIN)
  4925.       IF (NSUBPH.NE.ISTRIN-1) GOTO 505
  4926. C
  4927. C          READ IDRN IF NOT ALREADY THERE
  4928. C
  4929.       IF (IIDRN.EQ.ISTRIN) GOTO 540
  4930.         CALL DBREAD (ID,KIDRN,ISTRIN,0)
  4931.         IF (IERROR.NE.0) GOTO 900
  4932.       IIDRN = ISTRIN
  4933. C
  4934. C          'DISP-XYZ'
  4935. C
  4936.   540 IF (JDC.EQ.0) GOTO 550
  4937.       CALL PHEQR (DRDISP,KDISP,ISTRUN,ISTEN,NDOF,ID,RES,DINPH)
  4938.       IF (IERROR.NE.0) GOTO 900
  4939. C
  4940. C          'VELOCITY'
  4941. C
  4942.   550 IF (ISTAT.EQ.0) GOTO 570
  4943.       IF (JVC.EQ.0) GOTO 560
  4944.       CALL PHEQR (DRVELO,KVEL,ISTRUN,ISTEN,NDOF,ID,RES,DINPH)
  4945.       IF (IERROR.NE.0) GOTO 900
  4946. C
  4947. C          'ACCLERTN'
  4948. C
  4949.   560 IF (JAC.EQ.0) GOTO 570
  4950.       CALL PHEQR (DRACCL,KACC,ISTRUN,ISTEN,NDOF,ID,RES,DINPH)
  4951.       IF (IERROR.NE.0) GOTO 900
  4952.   570 GOTO 400
  4953. C
  4954. C
  4955. C          'TEMPERAT'   ONLY FOR MAIN STRUCTURE
  4956. C                     COMES AFTER ELEMENT SOLUTION IN SEQUENCE
  4957. C
  4958.   580 READ (LUNODE) DRECLB,(DINPH(I),I=1,NUMNP)
  4959.       DO 590 NP=1,NUMNP
  4960.   590   RES(NP) = DINPH(NP)
  4961.       CALL DBWRIT (RES,NUMNP,0,KTEMP,1,ISTEN)
  4962.         IF (IERROR.NE.0) GOTO 900
  4963.       GOTO 400
  4964. C
  4965. C
  4966. CCCCCC     ELEMENT SOLUTION READING
  4967. C
  4968.   600 READ (LUELEM) DRECLB,IEGPH,(NPARPH(I),I=1,20),
  4969.      1              KSTEP,DTIME,NEGLPH,NSUBPH
  4970.       TIME = DTIME
  4971. C
  4972. C          PROCEDURE FOR NEW ELEMENT TIMESTEP - MAIN STRUCTURE
  4973. C
  4974.       IF (NSUBPH.GT.0) GOTO 603
  4975.       IF (NSTEE.EQ.0) GOTO 601
  4976.       IF (KSTEP.EQ.NSTEPE(NSTEE)) GOTO 602
  4977.   601   NSTEE = NSTEE + 1
  4978.         ISTEE = NSTEE
  4979.         TIMEE (NSTEE) = TIME
  4980.         NSTEPE(NSTEE) = KSTEP
  4981.         ISTRIE = 1
  4982.         IRUSEE = 1
  4983.         ISTRUE = 1
  4984.         IEGITE = 0
  4985.         IEGATE = 0
  4986.         ISUBFE = 0
  4987.         IEGCHK = 0
  4988.   602 IEGCHK = IEGCHK + 1
  4989.       GOTO 630
  4990. C
  4991. C          CHECK FOR NEW TIMESTEP FOR SUBSTRUCTURE
  4992. C
  4993.   603 IF (ISUBFE.EQ.1) GOTO 604
  4994.         ISUBFE = 1
  4995.         ISTEE = 0
  4996.         GOTO 610
  4997.   604 IF (KSTEP.EQ.NSTEPE(ISTEE)) GOTO 620
  4998.       IF (IEGCHK.EQ.NEGS(NSTRI) .AND. IRUSEE.EQ.NRUSES(NSTRI)) GOTO 610
  4999.   605     WRITE (NFLOG,2015) NSTEPE(ISTEE),NRUSES(NSTRI),IRUSEE,KSTEP
  5000.      1          ,ISTRIE,NSUBPH,NEGS(NSTRI),IEGCHK,IEGPH,DRECLB
  5001.           GOTO 419
  5002.   610   IF (ISTEE.GE.NSTEE) GOTO 605
  5003.         ISTEE = ISTEE + 1
  5004.         ISTRIE = 2
  5005.         IRUSEE = 1
  5006.         ISTRUE = 1
  5007.         IEGITE = NEGS(1)
  5008.         IEGATE = IEGITE
  5009.         IEGCHK = 0
  5010. C
  5011. C          INCREMENT ELEMENT SUBSTRUCTURE AND REUSE IDENTIFICATION
  5012. C
  5013.   620 IEGCHK = IEGCHK + 1
  5014.       NEG = NEGS(ISTRIE)
  5015.       IF (IEGCHK.LE.NEG) GOTO 630
  5016. C
  5017.       ISTRUE = ISTRUE + 1
  5018.       IRUSEE = IRUSEE + 1
  5019.       IEGATE = IEGATE + NEG
  5020.       IEGCHK = 1
  5021.       IF (IRUSEE.LE.NRUSES(ISTRIE)) GOTO 630
  5022. C
  5023.       IEGITE = IEGITE + NEG
  5024.       ISTRIE = ISTRIE + 1
  5025.       IRUSEE = 1
  5026. C
  5027.   630 IF (IEGPH.NE.IEGCHK) GOTO 605
  5028.       IF (NSUBPH.NE.ISTRIE-1) GOTO 605
  5029. C
  5030. C          READ NPAR IF NOT ALREADY THERE
  5031. C
  5032.       IF (IINPAR.NE.ISTRIE)
  5033.      1    CALL DBREAD (NPAR,KNPAR,ISTRIE,0)
  5034.           IF (IERROR.NE.0) GOTO 900
  5035.           IINPAR = ISTRIE
  5036. C
  5037. C          PORTHOLE ELEMENT GROUP NUMBERS DIFFER IN ADINA INPUT/
  5038. C          AND ADINA RESULT PRINTING IF UNLINEAR EL GROUP COMES BEFORE
  5039. C          LINEAR ELEMENT GROUP IN INPUT, RESULT HAS ALWAYS LINEAR
  5040. C          GROUPS BEFORE NONLINEAR
  5041. C          THROUGHOUT ADINA-PLOT THE ELEMENT GROUP NUMBER OF ADINA INPUT
  5042. C          IS USED TO IDENTIFY ELEMENT GROUPS
  5043. C
  5044. C          FIND INPUT ELEMENT GROUP NUMBER OF THIS RESULT
  5045. C
  5046.       IEGW = 0
  5047.       NEG = NEGS(ISTRIE)
  5048.       DO 633 IEG=1,NEG
  5049.         INDNL = NPAR(3,IEG)
  5050.         IF (INDNL.NE.0) GOTO 633
  5051.         IEGW = IEGW + 1
  5052.         IF (IEGW.EQ.IEGPH) GOTO 637
  5053.   633   CONTINUE
  5054.       DO 635 IEG=1,NEG
  5055.         INDNL = NPAR(3,IEG)
  5056.         IF (INDNL.EQ.0) GOTO 635
  5057.         IEGW = IEGW + 1
  5058.         IF (IEGW.EQ.IEGPH) GOTO 637
  5059.   635   CONTINUE
  5060.   637 IEGIT = IEGITE + IEG
  5061.       IEGAT = IEGATE + IEG
  5062. C
  5063.       IELTYP = NPAR(1,IEG)
  5064.       NUME = NPAR(2,IEG)
  5065.       NTABLE = NPAR(13,IEG)
  5066. C
  5067. C          UPDATE NERPTS, IDERPT ARRAYS AND NERES, NERKI
  5068. C
  5069.       CALL ELRES (1,NPAR(1,IEG),ETIME,ETIME(NUME+1),ITABLE,
  5070.      1 NTABLE,IEGIT,IIEDAT,TIME,NERPTS,IDERPT,NERES,NERKI,LOCALE)
  5071.       IF (IERROR.NE.0) GOTO 900
  5072.       IF (NERES.EQ.0) GOTO 720
  5073.       DO 639 I=1,MXERES
  5074.   639   RES(I) = 987654E32
  5075. C
  5076. C          READ ELEMENT RESULTS
  5077. C          FOR ALL ELEMENTS AND POINTS AVAILIBLE IN PORTHOLE
  5078. C          AS INDICATED IN ARRAYS NERPTS AND IDERPT
  5079. C
  5080.       DRWANT = DROUT(IDRTYP)
  5081.       IXIDER = 0
  5082.       IXERES = -NERKI
  5083. C
  5084.       DO 710 IEL=1,NUME
  5085. C
  5086.       NERPT = NERPTS(IEL)
  5087.       IF (NERPT.EQ.0) GOTO 710
  5088. C
  5089.       DO 700 IERPT=1,NERPT
  5090. C
  5091.       IXIDER = IXIDER + 1
  5092.       IXERES = IXERES + NERKI
  5093.       IDERES = IDERPT(IXIDER)
  5094.       IF (IDERES.LT.0) GOTO 700
  5095. C
  5096. C          'OUTPUT-X'
  5097. C
  5098.       IELPH = IEL
  5099.       IDERPH = IDERES
  5100.       IF (IELTYP.EQ.IBEAM) GOTO 645
  5101.       IF (IELTYP.EQ.ISOBEA) GOTO 660
  5102. C
  5103.       IF (IPHCHK.EQ.0) GOTO 640
  5104.         CALL PHECHK (DRWANT)
  5105.         IF (IERROR.NE.0) GOTO 605
  5106.         BACKSPACE LUELEM
  5107.   640 READ (LUELEM) DRECLB,IDERPH,(DINPH(I),I=1,NERKI)
  5108.       GOTO 670
  5109. C
  5110. C          BEAM
  5111. C
  5112.   645 ND = NERPT * NERKI
  5113.       IF (INDNL.EQ.0 .OR. NTABLE.LT.0) GOTO 662
  5114.   655 IF (IPHCHK.EQ.0) GOTO 656
  5115.         CALL PHECHK (DRWANT)
  5116.         IF (IERROR.NE.0) GOTO 605
  5117.         BACKSPACE LUELEM
  5118.   656 READ (LUELEM) DRECLB,IELPH,IR,IS,IT,(DINPH(I),I=1,NERKI)
  5119.       IDERPH = IR*100 + IS*10 + IT
  5120.       GOTO 670
  5121. C
  5122. C          ISOBEAM
  5123. C
  5124.   660 IF (NTABLE.GE.0) GOTO 655
  5125. C          NUMBER OF RESULT NODES ARE 2 - 4 IN SAME RECORD
  5126.   662 IF (IERPT.GT.1) GOTO 700
  5127.       IF (IPHCHK.EQ.0) GOTO 667
  5128.         CALL PHECHK (DRWANT)
  5129.         IF (IERROR.NE.0) GOTO 605
  5130.         BACKSPACE LUELEM
  5131.   667 IF (IELTYP.EQ.IBEAM) READ (LUELEM) DRECLB,IELPH,(DINPH(I),I=1,ND)
  5132.       IF (IELTYP.EQ.ISOBEA)
  5133.      1  READ (LUELEM) DRECLB,IELPH,ND,(DINPH(I),I=1,ND)
  5134.       IF (DRECLB.NE.DRWANT) GOTO 790
  5135.       IF (IEL.NE.IELPH) GOTO 670
  5136.       DO 668 I=1,ND
  5137.   668   RES(IXERES+I) = DINPH(I)
  5138.       GOTO 700
  5139. C
  5140. C          CHECK PORTHOLE RECORD
  5141. C
  5142.   670 IF (DRECLB.NE.DRWANT) GOTO 790
  5143.       IF (IELPH.EQ.IEL .AND. IDERPH.EQ.IDERES) GOTO 675
  5144.         WRITE (NFLOG,2060) IELPH,IDERPH,IEL,IDERES
  5145.         GOTO 605
  5146.   675 DO 680 I=1,NERKI
  5147.   680   RES(IXERES+I) = DINPH(I)
  5148. C
  5149.   700 CONTINUE
  5150.   710 CONTINUE
  5151. C
  5152. C          WRITE ERES TO DATABASE
  5153. C
  5154.       CALL DBWRIT (RES,NERES*NERKI,0,KERES,IEGAT,ISTEE)
  5155.         IF (IERROR.NE.0) GOTO 900
  5156.   720 GOTO 400
  5157. C
  5158.   790 WRITE (NFLOG,2050) DRWANT,DRECLB
  5159.       GOTO 605
  5160.   900 RETURN
  5161. C
  5162.  2000 FORMAT (42H ***ERROR: PORTHOLE FILE SEQUENCE ERROR - ,
  5163.      1        42HEXPECTING SOLUTION RECORD, FOUND RECORD = ,A8)
  5164.  2010 FORMAT (47H ***ERROR: NODAL RESULTS PORTHOLE READING CHECK ,
  5165.      1 13H, TIMESTEP = ,I4/11X,25HLAST STRUCTURE (REUSED) =,I4,
  5166.      2 35H, TOTAL NR OF STRUCTURES (REUSED) =,I4,16H, NEW TIMESTEP =,I4/
  5167.      3 11X,16HLAST STRUCTURE =,I4,29H, PORTHOLE RECORD STRUCTURE =,I4/
  5168.      4 11X,18HPORTHOLE RECORD = ,A8)
  5169.  2015 FORMAT (48H ***ERROR: ELEMENT RESULT PORTHOLE READING CHECK ,
  5170.      1 13H, TIMESTEP = ,I4/11X,21HEND STRUCTURE REUSE =,I4,
  5171.      2 23H LAST STRUCTURE REUSE =,I4 ,
  5172.      3 16H, NEW TIMESTEP =,I4/11X,16HLAST STRUCTURE =,I4,
  5173.      4 29H, PORTHOLE RECORD SUBSTRUC. =,I4,
  5174.      4 31H, END STRUCTURE ELEMENT GROUP =,I4/
  5175.      5 11X,24HELEMENT GROUP EXPECTED =,I4,
  5176.      6 33H, PORTHOLE RECORD ELEMENT GROUP =,I4/
  5177.      7 11X,18HPORTHOLE RECORD = ,A8)
  5178.  2020 FORMAT (41H ***ERROR: BAD DATA IN PORTHOLE RECORD = ,A8)
  5179.  2050 FORMAT (50H ***ERROR: PORTHOLE FILE SEQUENCE ERROR - EXPECTED,
  5180.      1  10H RECORD = ,A8/45X,15HFOUND RECORD = ,A8)
  5181.  2060 FORMAT(50H ***ERROR: UNEXPECTED ELEMENT RESULT ID, ELEMENT =,I5,
  5182.      1 8H POINT =,I4,20H, EXPECTED ELEMENT =,I5,8H POINT =,I4)
  5183.  2065 FORMAT(4X,31HLOADED:  NODAL AND ELEMENT DATA)
  5184.  2070 FORMAT(4X,42HLOADED:  NODAL INITIAL CONDITIONS AT TIME=,G12.5)
  5185.  2071 FORMAT(4X,34HLOADED:  NODAL   RESULT TIMESTEPS=,I5,
  5186.      1  12H  FROM TIME=,G12.5,10H  TO TIME=,G12.5)
  5187.  2080 FORMAT(4X,34HLOADED:  ELEMENT RESULT TIMESTEPS=,I5,
  5188.      1  12H  FROM TIME=,G12.5,10H  TO TIME=,G12.5)
  5189.  2090 FORMAT(/48H ***WARNING:  PROBLEM MAY ARISE WHEN PROCESSING ,
  5190.      1  51HADINA-PLOT COMMANDS WITH THE LAST TIMESTEP INCLUDED/)
  5191.       END
  5192. C***ADD:CDC***
  5193. CDECK PHEQR
  5194. C***END:CDC***
  5195.       SUBROUTINE PHEQR (DRWANT,IGP,ISGP,ITIME,NDOFD,ID,RESN,DINPH)
  5196. C
  5197. C
  5198. C          READ ONE NODAL RESULT RECORD AND LOAD TO DATABASE
  5199. C***ADD:DPR***
  5200.       IMPLICIT REAL*8(D)
  5201.       REAL DT
  5202. C***END:DPR***
  5203.       DIMENSION ID(NDOFD,1),RESN(NDOFD,1),DINPH(1)
  5204.       COMMON /FILES/ NFREAD,NFECHO,NFLOG,NFLIST,LUNODE,LUELEM
  5205.       COMMON /ERROR/ IERROR
  5206.       COMMON /DB/ IOPEN,NFDB,INDXST,IXTNOW,LGP,NWRITS,NREADS,
  5207.      1            LDBC,LDBCTR,LDBCTI,IPHCHK,INSTRI,INRUSE,INSTRU,
  5208.      2            MSUBF,MVIEW,MAXIS,MLINEN,MLINEE,MVAR,MRES,LSKEW,MIDSPL
  5209.       COMMON /DBCTRL/ DT    ,TSTART,NUMNP ,NEQT  ,NSUBST,IDOF(6),
  5210.      1                NDOF  ,NEG   ,NMID  ,MODEX ,NSTE  ,NSTEN ,
  5211.      2                NSTEE ,NSKEWS,NMIDSS,IEIG  ,NSREFB,NEQITB,
  5212.      3                NPRIB ,NODSVB,LEMSVB,JDC   ,JAC   ,JVC   ,
  5213.      4                ISTAT ,JTC   ,NDISCE,ITP96 ,MXITAB,MXIDER,MXERES,
  5214.      5                NELPAR,MXNP  ,MXEG  ,MXEL  ,MXELNP,
  5215.      6                NDOFSA(6),NOUSE(4),FILL2
  5216. C
  5217. C          READ NODAL RESULT ARRAY FROM PORTHOLE
  5218. C
  5219.       IF (IPHCHK.EQ.0) GOTO 100
  5220.         CALL PHNCHK (DRWANT)
  5221.         IF (IERROR.NE.0) GOTO 900
  5222.         BACKSPACE LUNODE
  5223.   100 IF (ITIME.EQ.0) GOTO 110
  5224.       READ (LUNODE) DRECLB,NEQTI,(DINPH(I),I=1,NEQT)
  5225.       IF (NEQTI.NE.NEQT) GOTO 700
  5226.       GOTO 120
  5227.   110 READ (LUNODE) DRECLB,(DINPH(I),I=1,NEQT)
  5228.   120 IF (DRECLB.NE.DRWANT) GOTO 700
  5229. C
  5230. C          CONVERT RESULT ARRAY FROM EQUATION NUMBER ORDER
  5231. C          TO NDOF-NODALPOINT ORDER
  5232. C
  5233.       DO 200 NP=1,NUMNP
  5234.         DO 200 INDOF = 1,NDOFD
  5235.           IEQ = ID (INDOF,NP)
  5236.           RESULT = 0.
  5237.           IF (IEQ.GT.0) RESULT = DINPH(IEQ)
  5238.           IF (IEQ.GE.0) GOTO 150
  5239.             NEQ = NEQT - NDISCE
  5240.             RESULT = DINPH(NEQ-IEQ)
  5241.   150     RESN(INDOF,NP) = RESULT
  5242.   200     CONTINUE
  5243. C
  5244. C          WRITE TO DATABASE
  5245. C
  5246.       CALL DBWRIT (RESN,NUMNP*NDOF,0,IGP,ISGP,ITIME)
  5247.       GOTO 900
  5248. C
  5249.   700 WRITE (NFLOG,2000) DRECLB
  5250.   800 IERROR = 1
  5251.   900 RETURN
  5252.  2000 FORMAT (45H ***ERROR: PORTHOLE FILE BAD DATA - RECORD = ,A8)
  5253.       END
  5254. C*NEW FILE
  5255. C***END:IBM***
  5256.       SUBROUTINE CGRAPH(IFLAG)
  5257. C
  5258. C        CONTROLS GRAPHICAL OUTPUT
  5259. C
  5260. C        IFLAG=1   INITIALIZATION OF A PLOT
  5261. C                  FILE NFPLOT OPENED AS PLOT FILE
  5262. C
  5263. C        IFLAG=2   DEFINITION OF NEW ORIGIN
  5264. C                  AT 0,0 OF PLOT SURFACE, -3 INDICATES PEN IS UP
  5265. C
  5266. C        IFLAG=3   TERMINATION OF PLOT
  5267. C
  5268. C        IFLAG=4   SWITCH TO TERMINAL
  5269. C
  5270. C
  5271. C        IFLAG=5   SWITCH TO PLOTTER
  5272. C
  5273.       COMMON /PLOTCO/ GSCALE,DSCALE,XPV,YPV,PUNIT,HEIGHT,PMARG,AXEDGE,
  5274.      1              XSF,YSF,XFMAX,YFMAX,XF1,YF1,XPMAX,YPMAX,
  5275.      3              XSMIN,XSMAX,YSMIN,YSMAX,XPSAVE,YPSAVE,VIEW(3,3),
  5276.      2              NFPLOT,IONPLT,NSYSPL,NDEVPL,MORIGO,NGPTS
  5277.       COMMON /FILES/ NFREAD,NFECHO,NFLOG,NFLIST,LUNODE,LUELEM
  5278. C
  5279. C
  5280.       GOTO(100,200,300,400,500),IFLAG
  5281. C
  5282.   100 IF(IONPLT.EQ.1) GOTO 900
  5283.       CALL PLOTS(0,0,NFPLOT)
  5284.       IONPLT=1
  5285. C***ADD:CDC***
  5286. C*         PLOT 10 SUPPORT
  5287. C     IF (NSYSPL.EQ.1) CALL PLINIT(NDEVPL)
  5288. C***END:CDC***
  5289.       GOTO 900
  5290. C
  5291.   200 CALL PLOT (0.0,0.0,-3)
  5292.       GOTO 900
  5293. C
  5294.   300 IF(IONPLT.EQ.0) GOTO 900
  5295.       CALL PLOT(0.,0.,999)
  5296.       IONPLT=0
  5297.       GOTO 900
  5298. C
  5299.   400 IF(IONPLT.EQ.0) GOTO 900
  5300. C
  5301. C          PLOT 10 SUPPORT
  5302. C
  5303.       IF (NSYSPL.NE.1) GOTO 410
  5304.       CALL PLOFF
  5305.       CALL TSEND
  5306. C***ADD:CDC***
  5307. C     CALL ANMODE
  5308. C     CALL ZZZP10X
  5309. C     IIN = 5LINPUT
  5310. C     REWIND IIN
  5311. C***END:CDC***
  5312.       GOTO 900
  5313. C
  5314. C
  5315.   410 GOTO 900
  5316. C
  5317.   500 IF(IONPLT.EQ.0) GOTO 900
  5318. C
  5319. C          PLOT 10 SUPPORT
  5320. C
  5321.       IF (NSYSPL.NE.1) GOTO 510
  5322. C***ADD:CDC***
  5323. C     IOUT = 6LOUTPUT
  5324. C     ENDFILE IOUT
  5325. C***END:CDC***
  5326.       CALL PLON
  5327.       CALL TSEND
  5328.       GOTO 900
  5329. C
  5330. C
  5331.   510 GOTO 900
  5332. C
  5333.   900 RETURN
  5334.       END
  5335. C***ADD:CDC***
  5336. CDECK AGRAPH
  5337. C***END:CDC***
  5338.       SUBROUTINE AGRAPH(X,Y,H,NBCD,FPN,ANGLE,IND,IFLAG)
  5339. C
  5340. C        PLOTS ALPHANUMERIC AND SPECIAL CHARACTERS AND DECIMAL
  5341. C        EQUIVALENTS
  5342. C
  5343. C        X AND Y ARE COORDINATES OF THE LOWER LEFT HAND CORNER
  5344. C                OF THE CHARACTER IN THE PLOTTING SUBFRAME
  5345. C                COORDINATE SYSTEM. IF X AND/OR Y EQUAL 999.0
  5346. C                THEN CONTINUATION FROM THE POSITION WHERE
  5347. C                THE LAST ANNOTATION ENDED.
  5348. C
  5349. C        H       IS THE HEIGHT OF THE CHARACTER
  5350. C
  5351. C        NBCD    IS THE ALPHANUMERIC CHARACTER STORED USING 1H-FORMAT
  5352. C                OR THE INTEGER EQUIVALENT TO THE DESIRED SYMBOL
  5353. C
  5354. C        FPN     IS THE FLOATING POINT NUMBER TO BE CONVERTED AND
  5355. C                PLOTTED
  5356. C
  5357. C        IFLAG=1:  PLOTS IND ALPHANUMERIC CHARACTERS
  5358. C
  5359. C        IFLAG=2:  PLOTS ONE SPECIAL SYMBOL
  5360. C                  IND.EQ.-1 PEN IS UP DURING MOVE TO X/Y
  5361. C                         -2 PEN IS DOWN DURING MOVE TO X/Y
  5362. C
  5363. C        IFLAG=3   PLOTS DECIMAL EQUIVALENT
  5364. C                  IND.GT.0  SPECIFIES THE NO OF DIGITS TO THE RIGHT OF
  5365. C                            DECIMAL POINT TO BE PLOTTED
  5366. C                     .EQ.0  ONLY INTEGER PORTION PLOTTED
  5367. C                     .EQ.-1 ONLY INTEGER PORTION PLOTTED AFTER
  5368. C                            ROUNDING
  5369. C                     .LT.-1 IABS(IND)-1 DIGITS ARE TRUNCATED FROM THE
  5370. C                            INTEGER PORTION AFTER ROUNDING
  5371. C
  5372.       DIMENSION IBCD(1)
  5373. C
  5374.       COMMON /PLOTCO/ GSCALE,DSCALE,XPV,YPV,PUNIT,HEIGHT,PMARG,AXEDGE,
  5375.      1              XSF,YSF,XFMAX,YFMAX,XF1,YF1,XPMAX,YPMAX,
  5376.      3              XSMIN,XSMAX,YSMIN,YSMAX,XPSAVE,YPSAVE,VIEW(3,3),
  5377.      2              NFPLOT,IONPLT,NSYSPL,NDEVPL,MORIGO,NGPTS
  5378. C
  5379. C          CHECK THAT DATA STARTS WITHIN SUBFRAME
  5380. C
  5381.       IF (X.NE.999.0) XPSAVE = X
  5382.       IF (Y.NE.999.0) YPSAVE = Y
  5383.       IF (XPSAVE.GT.XPMAX .OR. YPSAVE.GT.YPMAX) GOTO 900
  5384.       IF (XPSAVE.LT.0.0 .OR. YPSAVE.LT.0.0) GOTO 900
  5385. C
  5386. C          ROTATE IF ORIGIN IS TO BE UPPER LEFT CORNER OF SUBFRAME
  5387. C
  5388.       XS = X
  5389.       YS = Y
  5390.       ANG = ANGLE
  5391.       IF (MORIGO.EQ.0) GOTO 50
  5392.       XS = Y
  5393.       YS = XPMAX - X
  5394.       IF (X.EQ.999.0) YS = 999.0
  5395.       ANG = ANG - 90.0
  5396. C
  5397. C          COMPUTE PLOT SURFACE COORDINATES
  5398. C
  5399.   50  IF (XS.NE.999.0) XS = (XSF + XF1 + XS)
  5400.       IF (YS.NE.999.0) YS = (YSF + YF1 + YS)
  5401.       IF (Y.EQ.999.0) YS = Y
  5402. C
  5403.       GOTO(100,200,300),IFLAG
  5404. C
  5405.   100 IBCD(1) = NBCD
  5406.       CALL SYMBOL(XS,YS,H,IBCD,ANG,IND)
  5407.       GOTO 900
  5408. C
  5409. C
  5410.   200 IBCD(1)=NBCD
  5411.       CALL SYMBOL(XS,YS,H,IBCD,ANG,IND)
  5412.       GOTO 900
  5413. C
  5414.   300 CALL NUMBER(XS,YS,H,FPN,ANG,IND)
  5415. C
  5416.   900 RETURN
  5417.       END
  5418. C***ADD:CDC***
  5419. CDECK LGRAPH
  5420. C***END:CDC***
  5421.       SUBROUTINE LGRAPH(X,Y,IND)
  5422. C
  5423. C         MOVES PEN TO NEW POSITION
  5424. C
  5425. C         X AND Y ARE COORDINATES IN THE PLOTTING SUBFRAME COORDINATE
  5426. C         SYSTEM
  5427. C
  5428. C         IND = 2   PEN DOWN
  5429. C             = 3   PEN UP
  5430. C
  5431. C         XS AND YS ARE REAL PLOTTING SURFACE COORDINATES
  5432. C
  5433.       COMMON /PLOTCO/ GSCALE,DSCALE,XPV,YPV,PUNIT,HEIGHT,PMARG,AXEDGE,
  5434.      1              XSF,YSF,XFMAX,YFMAX,XF1,YF1,XPMAX,YPMAX,
  5435.      3              XSMIN,XSMAX,YSMIN,YSMAX,XPSAVE,YPSAVE,VIEW(3,3),
  5436.      2              NFPLOT,IONPLT,NSYSPL,NDEVPL,MORIGO,NGPTS
  5437. C
  5438. C
  5439. C          ROTATE IF ORIGIN IS TO BE UPPER LEFT CORNER OF SUBFRAME
  5440. C
  5441.       XS = X
  5442.       YS = Y
  5443.       IF (MORIGO.EQ.0) GOTO 100
  5444.       XS = Y
  5445.       YS = XPMAX - X
  5446. C
  5447.   100  XS = (XSF + XF1 + XS)
  5448.       YS = (YSF + YF1 + YS)
  5449. C
  5450.       CALL PLOT(XS,YS,IND)
  5451. C
  5452.       RETURN
  5453.       END
  5454. C***ADD:CDC***
  5455. CDECK LCLIP
  5456. C***END:CDC***
  5457.       SUBROUTINE LCLIP (X,Y,IND)
  5458. C
  5459. C          DRAW A LINE OR MOVE PEN TO NEW POSITION
  5460. C          AND CLIP LINE AT SUBFRAME LIMITS
  5461. C
  5462. C          X AND Y ARE SUBFRAME COORDINATES
  5463. C
  5464. C          IND = 2  PEN DOWN
  5465. C              = 3  PEN UP
  5466. C              = 4  DASHED LINE
  5467. C
  5468.       COMMON /PLOTCO/ GSCALE,DSCALE,XPV,YPV,PUNIT,HEIGHT,PMARG,AXEDGE,
  5469.      1              XSF,YSF,XFMAX,YFMAX,XF1,YF1,XPMAX,YPMAX,
  5470.      3              XSMIN,XSMAX,YSMIN,YSMAX,XPSAVE,YPSAVE,VIEW(3,3),
  5471.      2              NFPLOT,IONPLT,NSYSPL,NDEVPL,MORIGO,NGPTS
  5472.       COMMON /EPS/ EPS
  5473. C
  5474.       DATA IDOWN,IUP,IDASH/2,3,4/
  5475. C
  5476. C
  5477.       X1 = XPSAVE
  5478.       Y1 = YPSAVE
  5479.       XPSAVE = X
  5480.       YPSAVE = Y
  5481.       X2 = X
  5482.       Y2 = Y
  5483.       ICLIP = 0
  5484. C
  5485. C          CHECK IF LINE IS NOW ENTIRELY OUTSIDE SUBFRAME
  5486. C
  5487.   100 IF (X1.LT.0.0   .AND. X2.LT.0.0  ) GOTO 900
  5488.       IF (Y1.LT.0.0   .AND. Y2.LT.0.0  ) GOTO 900
  5489.       IF (X1.GT.XPMAX .AND. X2.GT.XPMAX) GOTO 900
  5490.       IF (Y1.GT.YPMAX .AND. Y2.GT.YPMAX) GOTO 900
  5491. C
  5492. C          CHECK IF ANY LINE ENDPOINT IS OUTSIDE OF ANY LIMIT,
  5493. C          IF SO MOVE ENDPOINT TO SUBFRAME LIMIT
  5494. C
  5495.       XDIFF = X2 - X1
  5496.       YDIFF = Y2 - Y1
  5497.       IF (ABS(XDIFF).LT.EPS) XDIFF = EPS
  5498.       IF (ABS(YDIFF).LT.EPS) YDIFF = EPS
  5499. C
  5500.       IF (X1.GE.0.0) GOTO 110
  5501.         Y1 = Y1 - YDIFF * X1 / XDIFF
  5502.         X1 = 0.0
  5503.         GOTO 135
  5504. C
  5505.   110 IF (X1.LE.XPMAX) GOTO 120
  5506.         Y1 = Y1 + YDIFF * (XPMAX - X1) / XDIFF
  5507.         X1 = XPMAX
  5508.         GOTO 135
  5509. C
  5510.   120 IF (Y1.GE.0.0) GOTO 130
  5511.         X1 = X1 - XDIFF * Y1 / YDIFF
  5512.         Y1 = 0.0
  5513.         GOTO 135
  5514. C
  5515.   130 IF (Y1.LE.YPMAX) GOTO 140
  5516.         X1 = X1 + XDIFF * (YPMAX - Y1) / YDIFF
  5517.         Y1 = YPMAX
  5518.   135   ICLIP = 1
  5519.         GOTO 100
  5520. C
  5521. C
  5522. C
  5523.   140 IF (X2.GE.0.0) GOTO 150
  5524.         Y2 = Y1 - YDIFF * X1 / XDIFF
  5525.         X2 = 0.0
  5526.         GOTO 100
  5527. C
  5528.   150 IF (X2.LE.XPMAX) GOTO 160
  5529.         Y2 = Y1 + YDIFF * (XPMAX - X1) / XDIFF
  5530.         X2 = XPMAX
  5531.         GOTO 100
  5532. C
  5533.   160 IF (Y2.GE.0.0) GOTO 170
  5534.         X2 = X1 - XDIFF * Y1 / YDIFF
  5535.         Y2 = 0.0
  5536.         GOTO 100
  5537. C
  5538.   170 IF (Y2.LE.YPMAX) GOTO 200
  5539.         X2 = X1 + XDIFF * (YPMAX - Y1) / YDIFF
  5540.         Y2 = YPMAX
  5541.         GOTO 100
  5542. C
  5543. C
  5544.   200 INDPEN = IND
  5545.       IF (INDPEN.EQ.IUP) GOTO 700
  5546. C
  5547. C          IF FIRST PART OF LINE IS TO BE CLIPPED,
  5548. C          MOVE PEN TO SUBFRAME LIMIT
  5549. C
  5550.       IF (ICLIP.EQ.1)  CALL LGRAPH (X1,Y1,IUP)
  5551. C
  5552. C          DASHED LINE
  5553. C
  5554.       IF (IND.NE.IDASH) GOTO 700
  5555.       INDPEN = IDOWN
  5556.       X1 = X1 + XDIFF * 0.25
  5557.       Y1 = Y1 + YDIFF * 0.25
  5558.       CALL LGRAPH (X1,Y1,IDOWN)
  5559.       X1 = X1 + XDIFF * 0.5
  5560.       Y1 = Y1 + YDIFF * 0.5
  5561.       CALL LGRAPH (X1,Y1,IUP)
  5562. C
  5563. C          PLOT OR MOVE TO NEW X,Y POSITION
  5564. C
  5565.   700 CALL LGRAPH (X2,Y2,INDPEN)
  5566. C
  5567.   900 RETURN
  5568.       END
  5569. C***ADD:CDC***
  5570. CDECK XYPLOT
  5571. C***END:CDC***
  5572.       SUBROUTINE XYPLOT (XARRAY,YARRAY,NPTS,NXAXIS,NYAXIS,ISYMBL,ISSKIP)
  5573. C
  5574.       DIMENSION XARRAY(1),YARRAY(1)
  5575.       DIMENSION AXREC(250),XPA(1),YPA(1),XL(1),VMIN(1),VMAX(1)
  5576.       DIMENSION NAMEAX(20,1)
  5577. C
  5578.       COMMON /FILES/ NFREAD,NFECHO,NFLOG,NFLIST,LUNODE,LUELEM
  5579.       COMMON /PLOTCO/ GSCALE,DSCALE,XPV,YPV,PUNIT,HEIGHT,PMARG,AXEDGE,
  5580.      1              XSF,YSF,XFMAX,YFMAX,XF1,YF1,XPMAX,YPMAX,
  5581.      3              XSMIN,XSMAX,YSMIN,YSMAX,XPSAVE,YPSAVE,VIEW(3,3),
  5582.      2              NFPLOT,IONPLT,NSYSPL,NDEVPL,MORIGO,NGPTS
  5583.       COMMON /ERROR/ IERROR
  5584.       COMMON /DB/ IOPEN,NFDB,INDXST,IXTNOW,LGP,NWRITS,NREADS,
  5585.      1            LDBC,LDBCTR,LDBCTI,IPHCHK,INSTRI,INRUSE,INSTRU,
  5586.      2            MSUBF,MVIEW,MAXIS,MLINEN,MLINEE,MVAR,MRES,LSKEW,MIDSPL
  5587.       COMMON /DBC/ IHED(18),NDAREC,LDAREC,NRECS,NWORDS,NEXREC,NEXTIX,
  5588.      1             LIX,LIXT,NSTRI,NSTRUC,NEGIT,NEGAT,NFREQ,
  5589.      2             IXGP(50),MXSGP(50),
  5590.      3             FILL1
  5591.       COMMON /IGPNAM/ KDBC  ,KSUBGP,KDBCTR,KSTRI ,KRSDCO,KTMIDS,
  5592.      1                KXYZ  ,KIDRN ,KICONA,KNZONE,KNPAR ,KTHICK,
  5593.      2                KITABL,KNOD  ,KEDATA,KIEZON,KFRQ  ,KPHI  ,
  5594.      3                KTIMEN,KDISP ,KVEL  ,KACC  ,KTEMP ,KTIMEE,
  5595.      4                KERES ,KSUBF ,KVIEW ,KAXIS ,KNPOIN,KVARES,
  5596.      5                KNAMEZ,KEPOIN,KSXYZ ,KX34  ,KX35  ,KX36  ,
  5597.      6                KX37  ,KX38  ,KX39  ,KX40  ,KX41  ,KX42  ,
  5598.      7                KX43  ,KX44  ,KX45  ,KX46  ,KX47  ,KX48  ,
  5599.      8                KX49  ,KX50
  5600. C
  5601.       EQUIVALENCE (AXREC(1),XPA(1)),
  5602.      1           (AXREC(11),YPA(1)),
  5603.      1           (AXREC(21),XL(1)),
  5604.      1           (AXREC(31),VMIN(1)),
  5605.      1           (AXREC(41),VMAX(1)),
  5606.      1           (AXREC(51),NAMEAX(1,1))
  5607. C
  5608.       DATA IUP,IDOWN/3,2/
  5609.       DATA XTEXT,YTEXT/1H ,1H /
  5610.       DATA IPLOFF,IPLON/4,5/
  5611. C
  5612. C
  5613. C          CHECK PARAMETERS NXAXIS, NYAXIS, ISYMBL, ISSKIP
  5614. C
  5615.       NXAX = IABS(NXAXIS)
  5616.       NYAX = IABS(NYAXIS)
  5617.       IF (NXAX.GT.MAXIS .OR. NYAX.GT.MAXIS) GOTO 850
  5618.       IF (NXAX.EQ.0 .AND. NYAX.EQ.0) GOTO 110
  5619. C
  5620. C          READ AXIS RECORD FROM DATABASE
  5621. C
  5622.       DO 50 I=1,MAXIS
  5623.   50    XL(I) = 0.0
  5624.       IF (IXGP(KAXIS).NE.0)
  5625.      1  CALL DBREAD (AXREC,KAXIS,1,0)
  5626.         IF (IERROR.NE.0) GOTO 900
  5627.       IF (NXAX.GT.0 .AND. XL(NXAX).EQ.0.0) GOTO 100
  5628.       IF (NYAX.EQ.0 .OR.  XL(NYAX).NE.0.0) GOTO 110
  5629.   100   WRITE (NFLOG,2000)
  5630.         GOTO 800
  5631.   110 IF (ISYMBL.LT.0) GOTO 850
  5632.       IF (ISSKIP.LT.0) GOTO 850
  5633. C
  5634. C          AUTOMATIC SCALING OF X-AXIS
  5635. C
  5636.       CALL CGRAPH (IPLON)
  5637.       IF (NXAX.GT.0) GOTO 210
  5638.       XX = PMARG + AXEDGE
  5639.       YX = XX
  5640.       AXLEN = XPMAX - XX - PMARG
  5641.       IF (AXLEN.LT.1.00) GOTO 750
  5642.         CALL SCALE (XARRAY,AXLEN,NPTS,1)
  5643.         FIRSTX = XARRAY(NPTS+1)
  5644.         DELTAX = XARRAY(NPTS+2)
  5645.         GOTO 230
  5646. C
  5647. C          USER SCALING OF X-AXIS
  5648. C
  5649.   210 XX = XPA(NXAX)
  5650.       YX = YPA(NXAX)
  5651.       AXLEN = XL(NXAX)
  5652.       IF (AXLEN.LT.1.00) GOTO 750
  5653.       FIRSTX = VMIN(NXAX)
  5654.       DELTAX = (VMAX(NXAX) - FIRSTX) / AINT(AXLEN)
  5655.       XP = XX
  5656.       YP = YX - AXEDGE
  5657.       IF (NXAXIS.LE.0) GOTO 230
  5658.       DO 220 I=1,20
  5659.         NBCD = NAMEAX(I,NXAX)
  5660.         CALL APCHAR(NBCD)
  5661.         CALL AGRAPH (XP,YP,HEIGHT,NBCD,0.,0.,1,1)
  5662.         XP = 999.0
  5663.         YP = 999.0
  5664.   220   CONTINUE
  5665. C
  5666. C          PLOT X-AXIS
  5667. C
  5668.   230 IF (DELTAX.NE.0.0) GOTO 235
  5669.   232   CALL CGRAPH (IPLOFF)
  5670.         WRITE (NFLOG,2010)
  5671.         GOTO 800
  5672.   235 XS = (XSF + XF1 + XX)
  5673.       YS = (YSF + YF1 + YX)
  5674.       ANGLE = 0.0
  5675.       IF (MORIGO.EQ.0) GOTO 237
  5676.         XS = XSF + XF1 + YX
  5677.         YS = YSF + YF1 + XPMAX - XX
  5678.         ANGLE = -90.0
  5679.   237 IF (NXAXIS.LT.0) GOTO 240
  5680.         CALL AXIS (XS,YS,XTEXT,-1,AXLEN,ANGLE,FIRSTX,DELTAX)
  5681.   240 CONTINUE
  5682. C
  5683. C          AUTOMATIC SCALING OF Y-AXIS
  5684. C
  5685.       IF (NYAX.GT.0) GOTO 310
  5686.       XY = PMARG + AXEDGE
  5687.       YY = XY
  5688.       AXLEN = YPMAX - YY - PMARG
  5689.       IF (AXLEN.LT.1.00) GOTO 750
  5690.         CALL SCALE (YARRAY,AXLEN,NPTS,1)
  5691.         FIRSTY = YARRAY(NPTS+1)
  5692.         DELTAY = YARRAY(NPTS+2)
  5693.         GOTO 330
  5694. C
  5695. C          USER SCALING OF Y-AXIS
  5696. C
  5697.   310 XY = XPA(NYAX)
  5698.       YY = YPA(NYAX)
  5699.       AXLEN = XL(NYAX)
  5700.       IF (AXLEN.LT.1.00) GOTO 750
  5701.       FIRSTY = VMIN(NYAX)
  5702.       DELTAY = (VMAX(NYAX) - FIRSTY) / AINT(AXLEN)
  5703.       XP = XY - AXEDGE + HEIGHT
  5704.       YP = YY
  5705.       IF (NYAXIS.LE.0) GOTO 330
  5706.       DO 320 I=1,20
  5707.         NBCD = NAMEAX(I,NYAX)
  5708.         CALL APCHAR(NBCD)
  5709.         CALL AGRAPH(XP,YP,HEIGHT,NBCD,0.,90.,1,1)
  5710.         XP = 999.0
  5711.         YP = 999.0
  5712.   320   CONTINUE
  5713. C
  5714. C          PLOT Y-AXIS
  5715. C
  5716.   330 IF (DELTAY.EQ.0.0) GOTO 232
  5717.       XS = (XSF + XF1 + XY)
  5718.       YS = (YSF + YF1 + YY)
  5719.       ANGLE = 90.0
  5720.       IF (MORIGO.EQ.0) GOTO 340
  5721.         XS = XSF + XF1 + YY
  5722.         YS = YSF + YF1 + XPMAX - XY
  5723.         ANGLE = 0.0
  5724.   340 IF (NYAXIS.GE.0) CALL AXIS (XS,YS,YTEXT,1,AXLEN,ANGLE,FIRSTY
  5725.      1                         ,DELTAY)
  5726. C
  5727. C          PLOT LINE
  5728. C
  5729.       XX = XX - FIRSTX / DELTAX
  5730.       YY = YY - FIRSTY / DELTAY
  5731.       INDPEN = IUP
  5732.       INDCNT = -1
  5733. C
  5734.       DO 590 I=1,NPTS
  5735.         XPLINE = (XARRAY(I) / DELTAX + XX)
  5736.         YPLINE = (YARRAY(I) / DELTAY + YY)
  5737.         CALL LCLIP (XPLINE,YPLINE,INDPEN)
  5738.         INDPEN = IDOWN
  5739. C
  5740. C          PLOT SPECIAL SYMBOL   IF REQUESTED
  5741. C
  5742.         IF (ISYMBL.EQ.0) GOTO 590
  5743.         IF (INDCNT.GE.0) GOTO 560
  5744.           CALL AGRAPH (XPLINE,YPLINE,HEIGHT,ISYMBL,0.0,0.0,-1,2)
  5745.           INDCNT = ISSKIP
  5746.   560   INDCNT = INDCNT - 1
  5747.   590   CONTINUE
  5748.       GOTO 900
  5749. C
  5750.   750 CALL CGRAPH (IPLOFF)
  5751.       WRITE (NFLOG,2750) AXLEN
  5752.   800 IERROR = 1
  5753.       GOTO 900
  5754.   850 IERROR = 2
  5755.   900 RETURN
  5756.  2000 FORMAT (39H ***ERROR: NXAXIS OR NYAXIS NOT DEFINED)
  5757.  2010 FORMAT(38H ***ERROR: DV FOR X- OR Y-AXIS IS ZERO)
  5758.  2750 FORMAT(36H ***ERROR: AXIS LENGTH TOO SMALL, = ,F5.2)
  5759.       END
  5760. C***ADD:CDC***
  5761. CDECK SUBF
  5762. C***END:CDC***
  5763.       SUBROUTINE SUBF (IXCALL)
  5764. C
  5765. C          UPDATE CURRENT SUBFRAME (XF1,XPMAX,YF1,YPMAX)
  5766. C          IF CALLED FROM MAIN ADPLOT (IXINTV=0) FOR COMMAND SUBF
  5767. C          ...UPDATE DATABASE A
  5768. C
  5769.       DIMENSION IA(1)
  5770.       COMMON /CNTRL/ IBATCH,NBSU,LSTC,LSTF,LSTDB,ISURL,ITWO,LINPAG,LINE
  5771.       COMMON /EPS/ EPS
  5772.       COMMON /FILES/ NFREAD,NFECHO,NFLOG,NFLIST,LUNODE,LUELEM
  5773.       COMMON /PARAM/ REALV(100),NCMD,NLASTP,ITYPE(20),INTV(100),
  5774.      1               IANUMV(8,20),LGHSTR,INTEG,IREAL,IANUM,ISTRIN,IOMIT
  5775.       COMMON /ERROR/ IERROR
  5776.       COMMON /DB/ IOPEN,NFDB,INDXST,IXTNOW,LGP,NWRITS,NREADS,
  5777.      1            LDBC,LDBCTR,LDBCTI,IPHCHK,INSTRI,INRUSE,INSTRU,
  5778.      2            MSUBF,MVIEW,MAXIS,MLINEN,MLINEE,MVAR,MRES,LSKEW,MIDSPL
  5779.       COMMON /DBC/ IHED(18),NDAREC,LDAREC,NRECS,NWORDS,NEXREC,NEXTIX,
  5780.      1             LIX,LIXT,NSTRI,NSTRUC,NEGIT,NEGAT,NFREQ,
  5781.      2             IXGP(50),MXSGP(50),
  5782.      3             FILL1
  5783.       COMMON /DIM/ I01,I02,I03,I04,I05,I06,I07,I08,I09,I010,I011,
  5784.      1             I1,I2,I3,I4,I5,I6,I7,I8,I9,I10,I11,I12,I13,I14,I15,
  5785.      2             I16,I17,I18,I19,I20,
  5786.      3             N1,N2,N3,N4,N5,N6,N7,N8,N9,N10,N11,N12,N13,N14,N15,
  5787.      4             N16,N17,N18,N19,N20
  5788.       COMMON /IGPNAM/ KDBC  ,KSUBGP,KDBCTR,KSTRI ,KRSDCO,KTMIDS,
  5789.      1                KXYZ  ,KIDRN ,KICONA,KNZONE,KNPAR ,KTHICK,
  5790.      2                KITABL,KNOD  ,KEDATA,KIEZON,KFRQ  ,KPHI  ,
  5791.      3                KTIMEN,KDISP ,KVEL  ,KACC  ,KTEMP ,KTIMEE,
  5792.      4                KERES ,KSUBF ,KVIEW ,KAXIS ,KNPOIN,KVARES,
  5793.      5                KNAMEZ,KEPOIN,KSXYZ ,KX34  ,KX35  ,KX36  ,
  5794.      6                KX37  ,KX38  ,KX39  ,KX40  ,KX41  ,KX42  ,
  5795.      7                KX43  ,KX44  ,KX45  ,KX46  ,KX47  ,KX48  ,
  5796.      8                KX49  ,KX50
  5797.       COMMON /PLOTCO/ GSCALE,DSCALE,XPV,YPV,PUNIT,HEIGHT,PMARG,AXEDGE,
  5798.      1              XSF,YSF,XFMAX,YFMAX,XF1,YF1,XPMAX,YPMAX,
  5799.      3              XSMIN,XSMAX,YSMIN,YSMAX,XPSAVE,YPSAVE,VIEW(3,3),
  5800.      2              NFPLOT,IONPLT,NSYSPL,NDEVPL,MORIGO,NGPTS
  5801.       COMMON A(1)
  5802.       EQUIVALENCE (A(1),IA(1))
  5803. C
  5804.       DATA ICOMND,ISUBR/1,0/
  5805. C
  5806.       IXINTV = IXCALL
  5807.       ICALL = ISUBR
  5808.       IF (IXINTV.NE.0) GOTO 10
  5809.         ICALL = ICOMND
  5810.         IXINTV = 1
  5811.   10  NSUBF = INTV(IXINTV)
  5812.       IF (ITYPE(IXINTV).EQ.IOMIT) GOTO 900
  5813. C
  5814. C          SUBFRAME MAY BE NSUBF=XXYY - AN EQUALSIZE SPLIT PART OF FRAME
  5815. C
  5816. C          DIGIT 1 = XPARTS = X-DIRECTION EQUAL-SIZE PARTS
  5817. C          DIGIT 2 = XSELEC = SELECTED X-DIRECTION PART
  5818. C          DIGIT 3 = YPARTS = Y-DIRECTION EQUAL-SIZE PARTS
  5819. C          DIGIT 4 = YSELEC = SELECTED Y-DIRECTION PART
  5820. C
  5821.       IF (NSUBF.EQ.0) NSUBF = 1111
  5822.       IF (NSUBF.LT.1111 .OR. NSUBF.GT.9999) GOTO 15
  5823.       XPARTS = FLOAT( MOD(NSUBF/1000,10))
  5824.       XSELEC = FLOAT( MOD(NSUBF/100,10))
  5825.       YPARTS = FLOAT( MOD(NSUBF/10,10))
  5826.       YSELEC = FLOAT( MOD(NSUBF,10))
  5827. C
  5828.       IF (XPARTS.LT.EPS .OR. YPARTS.LT.EPS) GOTO 20
  5829.       IF (XSELEC.LT.EPS .OR. YSELEC.LT.EPS) GOTO 20
  5830.       IF (XPARTS.LT.XSELEC-EPS) GOTO 20
  5831.       IF (YPARTS.LT.YSELEC-EPS) GOTO 20
  5832. C
  5833.       XPMAX = XFMAX / XPARTS
  5834.       YPMAX = YFMAX / YPARTS
  5835.       XF1 = XPMAX * (XSELEC - 1.0)
  5836.       YF1 = YPMAX * (YSELEC - 1.0)
  5837.       GOTO 750
  5838. C
  5839. C          USER-DEFINED SUBFRAME
  5840. C
  5841.   15  IF (NSUBF.GE.1 .AND. NSUBF.LE.MSUBF) GOTO 40
  5842.   20    WRITE (NFLOG,2000)  MSUBF
  5843.         GOTO 800
  5844. C
  5845. C          READ SUBFRAME RECORD FROM DATABASE
  5846. C
  5847.   40  LREAL = MSUBF * 4
  5848.       I2 = I1 + LREAL * ISURL
  5849.       CALL SIZE (I2)
  5850.         IF (IERROR.NE.0) GOTO 900
  5851.       N1END = N1 + LREAL - 1
  5852.       DO 50 I=N1,N1END
  5853.   50    A(I) = 0.
  5854.       IF (IXGP(KSUBF).NE.0) CALL DBREAD (A(N1),KSUBF,1,0)
  5855.       IF (IERROR.NE.0) GOTO 900
  5856.       IX = N1 + (NSUBF - 1) * 4
  5857. C
  5858. C          SUBFRAME COMMAND
  5859. C
  5860.       IF (ICALL.NE.ICOMND) GOTO 500
  5861.       X1  = REALV(2)
  5862.       XF2 = REALV(3)
  5863.       Y1  = REALV(4)
  5864.       YF2 = REALV(5)
  5865.       IF(X1.GE.-EPS.AND.X1.LT.XF2.AND.Y1.GE.-EPS.AND.Y1.LT.YF2) GOTO 210
  5866.         WRITE (NFLOG,2010)
  5867.         GOTO 800
  5868.   210 A(IX  ) = X1
  5869.       A(IX+1) = XF2
  5870.       A(IX+2) = Y1
  5871.       A(IX+3) = YF2
  5872.       CALL DBWRIT (A(N1),LREAL,0,KSUBF,1,0)
  5873.         IF (IERROR.NE.0) GOTO 900
  5874.       GOTO 700
  5875. C
  5876. C          CALL FROM OTHER COMMAND SUBROUTINE
  5877. C
  5878.   500 X1  = A(IX)
  5879.       XF2 = A(IX+1)
  5880.       Y1  = A(IX+2)
  5881.       YF2 = A(IX+3)
  5882.       IF (X1.NE.XF2) GOTO 700
  5883.         WRITE (NFLOG,2030)
  5884.         GOTO 800
  5885. C
  5886. C          UPDATE CURRENT SUBFRAME LIMIT
  5887. C
  5888.   700 IF (XF2.LE.XFMAX .AND. YF2.LE.YFMAX) GOTO 720
  5889.         IF (ICALL.EQ.ICOMND) GOTO 710
  5890.           WRITE (NFLOG,2040)
  5891.           GOTO 800
  5892.   710   WRITE (NFLOG,2020)
  5893.         GOTO 900
  5894. C
  5895.   720 XPMAX = XF2 - X1
  5896.       YPMAX = YF2 - Y1
  5897.       XF1 = X1
  5898.       YF1 = Y1
  5899.   750 IF (MORIGO.EQ.0) GOTO 900
  5900.         XF2   = XPMAX
  5901.         XPMAX = YPMAX
  5902.         YPMAX = XF2
  5903.       GOTO 900
  5904. C
  5905.   800 IERROR = 1
  5906.   900 RETURN
  5907.  2000 FORMAT (46H ***ERROR: SUBFRAME ID MUST BE 0, XXYY OR 1 - ,I3)
  5908.  2010 FORMAT (49H ***ERROR: 0 <= XF1 < XF2 OR 0 <= YF1 < YF2 CHECK)
  5909.  2020 FORMAT (46H ***WARNING: SUBFRAME NOT WITHIN CURRENT FRAME)
  5910.  2030 FORMAT (31H ***ERROR: SUBFRAME NOT DEFINED)
  5911.  2040 FORMAT (44H ***ERROR: SUBFRAME NOT WITHIN CURRENT FRAME)
  5912.       END
  5913. C***ADD:CDC***
  5914. CDECK FRAME
  5915. C***END:CDC***
  5916.       SUBROUTINE FRAME
  5917. C
  5918. C         COMMAND FRAME
  5919. C
  5920.       COMMON /PARAM/ REALV(100),NCMD,NLASTP,ITYPE(20),INTV(100),
  5921.      1               IANUMV(160),LGHSTR,INTEG,IREAL,IANUM,ISTRIN,IOMIT
  5922.       COMMON /ERROR/ IERROR
  5923.       COMMON /FILES/ NFREAD,NFECHO,NFLOG,NFLIST,LUNODE,LUELEM
  5924.       COMMON /PLOTCO/ GSCALE,DSCALE,XPV,YPV,PUNIT,HEIGHT,PMARG,AXEDGE,
  5925.      1              XSF,YSF,XFMAX,YFMAX,XF1,YF1,XPMAX,YPMAX,
  5926.      3              XSMIN,XSMAX,YSMIN,YSMAX,XPSAVE,YPSAVE,VIEW(3,3),
  5927.      2              NFPLOT,IONPLT,NSYSPL,NDEVPL,MORIGO,NGPTS
  5928. C
  5929.       DATA XFMAX0 /118.9/
  5930.       DATA IPLOPE,IPLNEW,IPLOFF,IPLON/1,2,4,5/
  5931. C
  5932. C         PARAMETER 1: SIZE
  5933. C
  5934.       IF (ITYPE(1).EQ.IOMIT) GOTO 30
  5935.       SIZE = REALV(1)
  5936.       ALFA = 0.0
  5937.       IF (SIZE.LT.0.0) ALFA = 1.0
  5938.       SIZE = ABS(SIZE)
  5939.       XFMAX = XFMAX0 / (1.414214 ** ( SIZE + ALFA ) )
  5940.       YFMAX = XFMAX0 / (1.414214 ** ( SIZE + 1. - ALFA ) )
  5941. C
  5942. C          PARAMETER 2,3:  XFMAX, YFMAX
  5943. C
  5944.   30  IF (ITYPE(2).NE.IOMIT) XFMAX = REALV(2)
  5945.       IF (ITYPE(3).NE.IOMIT) YFMAX = REALV(3)
  5946.       IF (XFMAX.LT.1.0) GOTO 850
  5947.       IF (YFMAX.LT.1.0) GOTO 850
  5948. C
  5949. C        PARAMETER 4,5: XSF, YSF
  5950. C
  5951.       IF (ITYPE(4).NE.IOMIT) XSF = REALV(4)
  5952.       IF (ITYPE(5).NE.IOMIT) YSF = REALV(5)
  5953. C
  5954. C          CHECK THAT FRAME IS WITHIN PLOT SURFACE
  5955. C
  5956.       IF (XSF.LT.XSMIN .OR. XSF+XFMAX.GT.XSMAX) GOTO 60
  5957.       IF (YSF.LT.YSMIN .OR. YSF+YFMAX.GT.YSMAX) GOTO 60
  5958.       GOTO 70
  5959.   60  WRITE (NFLOG,2000) XSMIN,XSMAX,YSMIN,YSMAX
  5960.       GOTO 800
  5961. C
  5962. C        INITIALIZE PLOT AND SET NEW ORIGIN
  5963. C
  5964.   70  CALL CGRAPH (IPLOPE)
  5965.       CALL CGRAPH (IPLNEW)
  5966.       CALL CGRAPH (IPLON)
  5967. C
  5968. C        PLOT FRAME
  5969. C
  5970.       XF1=0.
  5971.       YF1=0.
  5972.       XPMAX=XFMAX
  5973.       YPMAX=YFMAX
  5974.       IF (MORIGO.EQ.0) GOTO 200
  5975.         XPMAX = YFMAX
  5976.         YPMAX = XFMAX
  5977.   200 CALL LGRAPH(XF1,YF1,3)
  5978.       CALL LGRAPH(XPMAX,YF1,2)
  5979.       CALL LGRAPH(XPMAX,YPMAX,2)
  5980.       CALL LGRAPH(XF1,YPMAX,2)
  5981.       CALL LGRAPH(XF1,YF1,2)
  5982. C
  5983.       CALL CGRAPH (IPLOFF)
  5984. C
  5985.       GOTO 900
  5986.   800 IERROR = 1
  5987.       GOTO 900
  5988.   850 IERROR = 2
  5989.   900 RETURN
  5990. C
  5991.  2000 FORMAT(56H ***ERROR: FRAME NOT WITHIN PLOT SURFACE LIMITS:  XSMIN=
  5992.      1 F7.2,7H XSMAX=,F7.2,8H  YSMIN=,F7.2,7H YSMAX=,F7.2)
  5993.       END
  5994.