      SUBROUTINE TRD1C2 (IC,PD,NGROUP,NLFTP,UDV,ILOOP,SCR1,DIT,NLFT,
CRLBR SPR94003 9/94
CRLBR1                   NOUE,MODAL,PNL)
     1                   NOUE,MODAL,PNL,ISKIP)
C
C     THIS ROUTINE STEPS INTEGRATION PROCEDURE
C
C     THIS ROUTINE IS SUITABLE FOR DOUBLE PRECISION OPERATION
C
      LOGICAL         NOPD
      INTEGER         DIT1,PNL1,PNL,PD,UDV,SCR1,DIT,SYSBUF,FILE,IZ(1),
CRLBR SPR94003 9/94
CRLBR1                MCB(7),IPNL(7),SUBNAM(2)
     1                MCB(7),IPNL(7),SUBNAM(2),MOUTPU(7)
      DOUBLE PRECISION Z,H
      DIMENSION       RZ(1)
      COMMON /BLANK / DUMMY(4),NCOL
CRLBR SPR94003 9/94
CRLBR COMMON /SYSTEM/ SYSBUF
      COMMON /SYSTEM/ SYSBUF, NNOUT, ISYSTM(79), ICPFLG
      COMMON /ZZZZZZ/ Z(1)
      COMMON /PACKX / IT1,IT2,II,JJ,INCR
      COMMON /TRDXX / IK(7),IDUM(14),ISCR1,ISCR2,ISCR3,ISCR4,ISCR5,
     1                ISCR6,IOPEN,ISYM,TO,NOPD,ISPNL
      COMMON /UNPAKX/ IT3,III,JJJ,INCR1
      COMMON /TRDD1 / NLFT1,DIT1,NLFTP1,NOUT,ICOUNT,ILOOP1,MODAL1,NZ,
     1                ICORE,IU2,IP4,IPNL,NMODES,NSTEP,PNL1,IST,IU1,
     2                DELTAT
      EQUIVALENCE     (Z(1),RZ(1),IZ(1))
      DATA    SUBNAM/ 4HTRD1,2HC2/
CRLBNB SPR94003 9/94
      DATA  IOUTPU, ISCR9 /203, 309/
CRLBNE
C
C     INITIALIZE
C
      NROW  = IK(3)
      NNROW = 2*NROW
      IT1   = 2
      IT2   = 2
      II    = 1
      JJ    = NROW
      INCR  = 1
      IT3   = 2
      III   = 1
      JJJ   = NROW
      INCR1 = 1
      NZ    = KORSZ(Z)
      IGROUP= NZ - 3*NGROUP + 1
      IBUF1 = IGROUP- SYSBUF
      IBUF2 = IBUF1 - SYSBUF
      IBUF3 = IBUF2 - SYSBUF
      IBUF4 = IBUF3 - SYSBUF
      IBUF5 = IBUF4 - SYSBUF
      IBUF6 = IBUF5 - SYSBUF
      IBUF7 = IBUF6 - SYSBUF
      IBUF8 = IBUF7 - SYSBUF
CRLBNB SPR94003 9/94
      IF (NLFTP .EQ. 0) IBUF8 = IBUF7
      IBUF9 = IBUF8 - SYSBUF
      IBUFA = IBUF9 - SYSBUF
      IF (ICPFLG .EQ. 0) IBUFA = IBUF8
      IF (ICPFLG .NE. 0 .AND. ISKIP .EQ. 1) IBUFA = IBUF9
      NZ = IBUFA - 1
CRLBNE
CRLBD SPR94003 9/94 NZ = IBUF7-1
CRLBD SPR94003 9/94 IF(NLFTP .NE. 0) NZ = IBUF8-1
      IOPEN = 0
CRLBR SPR94003 9/94 ICRQ = 14*NROW + 1 - NZ
      ICRQ = 14*(NROW+1) + 1 - NZ
      IF(ICRQ.GT.0) GO TO 430
CRLBR SPR94003 9/94 IU1=0
      IU1=1
CRLBR SPR94003 9/94 IU2= IU1+NROW
      IU2= IU1+NROW + 1
CRLBR SPR94003 9/94 IU3= IU2+ NROW
      IU3= IU2+ NROW + 1
CRLBR SPR94003 9/94 IP1= IU3+ NROW
      IP1= IU3+ NROW + 1
CRLBR SPR94003 9/94 IP2= IP1+ NROW
      IP2= IP1+ NROW + 1
      IP3   = IP2 + NROW
      IP4   = IP3 + NROW
      NLFT1 = NLFT
      DIT1  = DIT
      NLFTP1= NLFTP
      ILOOP1= ILOOP
      MODAL1= MODAL
      IST   = 0
CRLBR SPR94003 9/94 NZ    = NZ - 14*NROW - 1
      NZ    = NZ - 14*(NROW+1) - 1
      ICORE = 2*(IP4 + NROW)
      NMODES= NROW - NOUE
      PNL1  = PNL
      ASSIGN 60 TO IRET1
      NSTEP = IZ(IGROUP) + 1
      DELTAT= RZ(IGROUP+1)
      NOUT  = IZ(IGROUP+2)
      IF (ILOOP .NE. 1) GO TO 210
C
C     FIRST ENTRY INITIALIZE STUFF
C
      IST  =-1
      FILE = PD
C
C     PUT P0 IN IP2
C
      IPNT = IP2
      NOPD =.TRUE.
      ASSIGN 5 TO IRETN
      CALL OPEN (*310,PD,IZ(IBUF2),0)
      CALL SKPREC (PD,1)
      NOPD = .FALSE.
      GO TO 290
CRLBD SPR94003 9/94     5 FILE = UDV
CRLBD SPR94003 9/94       IAPEND = 0
CRLBR SPR94003 9/94       IF (NCOL .LE. 0) GO TO 8
    5 IF (NCOL .GT. 2) GO TO 325
CRLBD SPR94003 9/94      MCB(1) = UDV
CRLBD SPR94003 9/94      CALL RDTRL (MCB)
CRLBD SPR94003 9/94      IF (MCB(2) .NE. 0) GO TO 330
CRLBR SPR94003 9/94    8 CALL GOPEN (UDV,IZ(IBUF3),1)
      CALL GOPEN (UDV, IZ(IBUF3), 1)
      CALL MAKMCB (MCB,UDV,NROW,2,2)
CRLBNB SPR94003 9/94 
    8 IF (ICPFLG .EQ. 0) GO TO 10
      CALL MAKMCB (MOUTPU, IOUTPU, NROW+1, ISKIP, 2)
      CALL GOPEN (IOUTPU, IZ(IBUF9), 1)
      IF (ISKIP .EQ. 0) CALL GOPEN (ISCR9, IZ(IBUFA), 1)
CRLBNE
   10 IF (NLFTP .EQ. 0) GO TO 20
C
C     CHECK TO SEE IF PNL HAS BEEN PRE-PURGED.
C
      IPNL(1) = PNL1
      CALL RDTRL (IPNL)
      ISPNL = 0
      IF (IPNL(1) .LE. 0) GO TO 20
      ISPNL = 1
      CALL GOPEN (PNL1,IZ(IBUF8),1)
      CALL MAKMCB (IPNL,PNL1,NROW,2,2)
   20 CONTINUE
CRLBR SPR94003 9/94      IF (IAPEND .EQ. 1) GO TO 50
      IF (NCOL .GT. 2) GO TO 50
      FILE = IC
      CALL GOPEN (IC,IZ(IBUF1),0)
      ASSIGN 30 TO IRETN
      IPNT = IU2
      GO TO 290
   30 ASSIGN 40 TO IRETN
      IPNT = IU3
      GO TO 290
   40 CALL CLOSE (IC,1)
      NSTEP  = IZ(IGROUP) + 1
      DELTAT = RZ(IGROUP+1)
      NOUT   = IZ(IGROUP+2)
C
C     FORM  U=1, PO, P-1
C
      CALL FORM12 (Z(IU2+1),Z(IU3+1),Z(IU1+1),Z(IP2+1),Z(IP1+1),DELTAT,
     1             RZ(IBUF1))
C
C     START TIME STEP COUNT
C
   50 CONTINUE
      ICOUNT = 1
CRLBNB SPR94003 9/94   
      MCOL = 1
CRLBNE
C
C     OPEN FBS FILES
C
   60 FILE = ISCR1
      CALL OPEN (*390,ISCR1,IZ(IBUF4),0)
      FILE = ISCR2
      CALL OPEN (*390,ISCR2,IZ(IBUF5),0)
      FILE = ISCR3
CIBMR 5/95      
C     CALL OPEN (*390,ISCR3,IZ(IBUF6),0) 
      IF ( ISYM .EQ. 1 ) CALL OPEN (*390,ISCR3,IZ(IBUF6),0) 
      FILE = ISCR4
      CALL OPEN (*390,ISCR4,IZ(IBUF7),0)
C
C     ZERO P*
C
   70 CALL TMTOGO (ITLEFT)
      IF (ITLEFT .LE. 0) GO TO 170
      DO 80 I = 1,NROW
      K = IP4 + I
      Z(K) = 0.0D0
   80 CONTINUE
      IF (NLFTP .EQ. 0) GO TO 90
C
C     FORM NON-LINEAR LOADS
C
      CALL TRD1D2
      IF (ICOUNT.EQ.1 .OR. ICOUNT.EQ.NSTEP .OR. MOD(ICOUNT+IST,NOUT)
     1   .EQ.0) GO TO 85
      GO TO 90
   85 IF (ISPNL .GT. 0) CALL PACK (Z(IP4+1),PNL,IPNL)
C
C     BRING IN NEXT P
C
   90 IPNT = IP3
      FILE = PD
      ASSIGN 100 TO IRETN
      IF (NOPD) GO TO 310
      GO TO 290
C
C     ADD P-S TO FORM P*
C
  100 DO 110 I = 1,NROW
      K = IP4 + I
      L = IP1 + I
      M = IP2 + I
      J = IP3 + I
      Z(K) = Z(K) + (Z(L) + Z(M) + Z(J))/3.0D0
  110 CONTINUE
      IF (ILOOP.NE.1 .OR. ICOUNT.NE.1) GO TO 115
CRLBR SPR94003 9/94      IF (IAPEND .EQ. 1) GO TO 115
      IF (NCOL .GT. 2) GO TO 113
C
C     OUTPUT INITIAL DISPLACEMENT
C
      CALL PACK (Z(IU2+1),UDV,MCB(1))
C
C     OUTPUT INITIAL VELOCITY
C
      CALL PACK (Z(IU3+1),UDV,MCB(1))
CRLBNB SPR94003 9/94 
  113 IF (ICPFLG .EQ. 0) GO TO 115
      IF (ISKIP .EQ. 0) CALL WRITE (ISCR9, MCOL, 1, 0)
CRLBNE
C
C     SOLVE FOR NEXT SOLUTION
C
  115 CALL STEP2 (Z(IU3+1),Z(IU2+1),Z(IU1+1),Z(IP4+1),IZ(IBUF1))
CRLBNB SPR94003 9/94      
      IF (ICPFLG .EQ. 0) GO TO 118
      JJ = NROW + 1
      Z(IP2) = DELTAT
      IF (ILOOP.NE.1 .AND. ICOUNT.EQ.0) Z(IP2) = DELTA1
      CALL PACK (Z(IP2), IOUTPU, MOUTPU)
      IF (ISKIP .EQ. 1) GO TO 117
      Z(IU2) = MCOL + 0.1
      CALL PACK (Z(IU2), IOUTPU, MOUTPU)
  117 JJ = NROW
  118 CONTINUE
CRLBNE
      IF (ILOOP.EQ.1 .AND. ICOUNT.EQ.1) GO TO 145
      IF (ICOUNT.EQ.NSTEP .OR. MOD(ICOUNT+IST,NOUT).EQ.0) GO TO 130
      IF (ICOUNT .EQ. 1) GO TO 130
C
C     ROTATE P POINTERS
C
  120 J   = IP1
      IP1 = IP2
      IP2 = IP3
      IP3 = J
C
C     ROTATE U POINTERS
C
      J   = IU1
      IU1 = IU2
      IU2 = IU3
      IU3 = J
      ICOUNT = ICOUNT + 1
CRLBNB SPR94003 9/94      
      MCOL = MCOL + 1
CRLBNE
      IF (ICOUNT-NSTEP) 70,160,170
C
C     IT-S OUTPUT TIME -- LUCKY FELLOW
C
  130 CALL PACK (Z(IU2+1),UDV,MCB(1))
C
C     COMPUTE U DOT
C
      H = 1.0D0/(2.0D0*DELTAT)
      DO 140 I = 1,NROW
      K = IP4 + I
      L = IU3 + I
      M = IU1 + I
      Z(K) = (Z(L)-Z(M))*H
  140 CONTINUE
      CALL PACK (Z(IP4+1),UDV,MCB(1))
CRLBNB SPR94003 9/94      
      IF (ICPFLG .EQ. 0) GO TO 145
      IF (ISKIP .EQ. 0) CALL WRITE (ISCR9, MCOL, 1, 0)
CRLBNE
C
C     COMPUTE U DOT DOT
C
  145 H = 1.0D0/(DELTAT*DELTAT)
      DO 150 I = 1,NROW
      K = IP4 + I
      L = IU3 + I
      M = IU1 + I
      J = IU2 + I
      Z(K) = (Z(L)+Z(M)-2.0D0*Z(J))*H
  150 CONTINUE
      CALL PACK (Z(IP4+1),UDV,MCB(1))
      GO TO 120
C
C     END OF 1 GROUP
C
  160 IF (ILOOP .NE. NGROUP) GO TO 200
      GO TO 70
  170 J = 1
  180 CALL CLOSE (UDV,J)
      CALL CLOSE (PD ,J)
CRLBNB SPR94003 9/94
      IF (ICPFLG .EQ. 0) GO TO 188
      IF (J.NE.1 .OR. ISKIP.EQ.1) GO TO 186
      CALL CLOSE (ISCR9, 1)
C
C     COPY THE SINGLE RECORD IN FILE ISCR9 AS THE
C     LAST RECORD IN FILE IOUTPU
C
      CALL GOPEN (ISCR9, IZ(IBUFA), 0)
      FILE = ISCR9
  183 CALL READ (*410, *184, ISCR9, Z(IU2+1), NROW, 0, IFLAG)
      CALL WRITE (IOUTPU, Z(IU2+1), NROW, 0)
      GO TO 183
  184 CALL WRITE (IOUTPU, Z(IU2+1), IFLAG, 1)
      CALL CLOSE (ISCR9, 1)
  186 CALL CLOSE (IOUTPU, J)
      CALL WRTTRL (MOUTPU)
  188 CONTINUE
CRLBNE
      CALL CLOSE (ISCR1,1)
      CALL CLOSE (ISCR2,1)
CIBMR 5/95       
C     CALL CLOSE (ISCR3,1)      
      IF ( ISYM .EQ. 1 ) CALL CLOSE (ISCR3,1)      
      CALL CLOSE (ISCR4,1)
      CALL WRTTRL (MCB)
      IF (NLFTP.EQ.0 .OR. ISPNL.EQ.0) GO TO 190
      CALL CLOSE (PNL,J)
      CALL WRTTRL (IPNL)
  190 RETURN
C
C     MORE GROUPS TO COME SAVE STUFF
C
  200 J = 2
      FILE = SCR1
      CALL OPEN  (*390,SCR1,IZ(IBUF1),1)
      CALL WRITE (SCR1,Z(IU3+1),NNROW,1)
      CALL WRITE (SCR1,Z(IU1+1),NNROW,1)
      CALL WRITE (SCR1,Z(IU2+1),NNROW,1)
CRLBR SPR94003 9/94
CRLBR CALL WRITE (SCR1,Z(IP1+1),NNROW,1)
      CALL WRITE (SCR1,Z(IP2+1),NNROW,1)
      CALL CLOSE (SCR1,1)
      GO TO 180
C
C     CHANGE OF TIME STEP--RESTORE POINTERS ETC
C
  210 IGROUP = IGROUP + (ILOOP-1)*3
      DELTA1 = RZ(IGROUP-2)
      NSTEP  = IZ(IGROUP  )
      DELTAT = RZ(IGROUP+1)
      NOUT   = IZ(IGROUP+2)
      IF (.NOT.NOPD) CALL GOPEN (PD,IZ(IBUF2),2)
      CALL GOPEN (UDV,IZ(IBUF3),3)
      MCB(1) = UDV
      CALL RDTRL (MCB)
CRLBNB SPR94003 9/94  
      IF (ICPFLG .EQ. 0) GO TO 217
      CALL GOPEN (IOUTPU, IZ(IBUF9), 3)
      MOUTPU(1) = IOUTPU
      CALL RDTRL (MOUTPU)
  217 CONTINUE
CRLBNE
      IF (NLFTP .EQ. 0) GO TO 220
      IF (ISPNL .GT. 0) CALL GOPEN (PNL1,IZ(IBUF8),3)
  220 CONTINUE
C
C     RESTORE STUFF SAVED
C
      FILE = SCR1
      CALL OPEN  (*390,SCR1,IZ(IBUF1),0)
      CALL FREAD (SCR1,Z(IU1+1),NNROW,1)
      CALL FREAD (SCR1,Z(IU3+1),NNROW,1)
      CALL FREAD (SCR1,Z(IU2+1),NNROW,1)
      CALL FREAD (SCR1,Z(IP2+1),NNROW,1)
      CALL CLOSE (SCR1,1)
C
C     COMPUTE U DOT
C
CRLBR SPR94003 9/94      H = 1.0D0/DELTA1
  225 H = 1.0D0/DELTA1
      DO 230 I = 1,NROW
      K = IP1 + I
      L = IU2 + I
      M = IU3 + I
      Z(K) = (Z(L)-Z(M))*H
  230 CONTINUE
C
C     COMPUTE U DOT DOT
C
      H = 1.0D0/(DELTA1*DELTA1)
      DO 240 I = 1,NROW
      K = IP4 + I
      L = IU2 + I
      M = IU3 + I
      J = IU1 + I
      Z(K) = (Z(L)-2.0D0*Z(M)+Z(J))*H
  240 CONTINUE
CRLBD SPR94003 9/94   250 CONTINUE
C
C     COMPUTE UI PRIME
C
      H = DELTAT*DELTAT/2.0D0
      DO 260 I = 1,NROW
      K = IU1 + I
      L = IU2 + I
      M = IP1 + I
      J = IP4 + I
      Z(K) = Z(L) - DELTAT*Z(M) + H*Z(J)
  260 CONTINUE
C
C     COMPUTE U DOT PRIME
C
      DO 270 I = 1,NROW
      K = IU3 + I
      L = IP1 + I
      M = IP4 + I
      Z(K) = Z(L) - DELTAT*Z(M)
  270 CONTINUE
C
C     COMPUTE PI PRIME
C
      DO 280 I = 1,NROW
      K = IP1 + I
      Z(K) = 0.0D0
  280 CONTINUE
      CALL FORM22 (Z(IP4+1),Z(IU3+1),Z(IU1+1),Z(IP1+1),RZ(IBUF1))
      ICOUNT = 0
CRLBR SPR94003 9/94      GO TO IRET1, (60,10)
      GO TO IRET1, (60,8)
C
C     INTERNAL ROUTINE TO UNPACK VECTORS
C
  290 CALL UNPACK (*310,FILE,Z(IPNT+1))
CRLBR SPR94003 9/94  300 GO TO IRETN, (5,30,40,100,350,360,370)
  300 GO TO IRETN, (5,30,40,100,340,350,360,370,385,387)
CRLBR SPR94003 9/94  310 DO 320 INL = 1,NROW
  310 DO 320 INL = III, JJJ
      K = IPNT + INL
      Z(K) = 0.0D0
  320 CONTINUE
      GO TO 300
CRLBNB SPR94003 9/94
C     THE FOLLOWING LINES (UNTIL CRPKNE) REPRESENT
C     REPLACEMENTS FOR THE OLD CODE WHICH HAS BEEN
C     DELETED BELOW
C
C     RETRIEVE REQUIRED INFORMATION FROM
C     THE CHECKPOINT RUN
C
  325 MCOL = NCOL
      CALL GOPEN (IOUTPU, IZ(IBUF4), 0)
      MOUTPU(1) = IOUTPU
      CALL RDTRL (MOUTPU)
      JSKIP = 1
      IF (MOUTPU(4) .EQ. 1) GO TO 335
      JSKIP = 2
      CALL SKPREC (IOUTPU, MOUTPU(2))
      FILE = IOUTPU
      NWDS = NCOL - 1
  327 CALL READ (*410, *330, IOUTPU, MCOL, -NWDS, 0, IFLAG)
      GO TO 333
  330 NWDS = NWDS - IFLAG
      GO TO 327
  333 CALL READ (*410, *333, IOUTPU, MCOL, 1, 0, IFLAG)
      CALL REWIND (IOUTPU)
      CALL SKPREC (IOUTPU, 1)
C
  335 CALL SKPREC (IOUTPU, JSKIP*(MCOL-1))
      FILE = IOUTPU
      JJJ = NROW + 1
C
C     GET P SUB I+1
C
      IPNT = IP2 - 1
      ASSIGN 340 TO IRETN
      GO TO 290
  340 ITYPE = 1
      DELTA1 = Z(IP2)
      IF (DELTA1 .EQ. DELTAT) GO TO 345
      ITYPE = 2
      GO TO 350
  345 CALL SKPREC (IOUTPU, -(JSKIP+1))
C
C     GET P SUB I
C
      IPNT = IP1 - 1
      ASSIGN 350 TO IRETN
      GO TO 290
  350 CALL CLOSE (IOUTPU, 1)
C
      FILE = UDV
      CALL GOPEN (UDV, IZ(IBUF3), 0)
      K = 3*(NCOL - 1)
      KK = 5
      KKK = 4
      KKP = 0
      JJJ = NROW
      CALL SKPREC (UDV, K)
C
C     GET U SUB I+1
C
      IPNT = IU2
      ASSIGN 360 TO IRETN
      GO TO 290
C
C     GET U DOT SUB I+1
C
  360 IPNT = IP3
      ASSIGN 370 TO IRETN
      GO TO 290
C
  370 IF (MCOL .EQ. NCOL) GO TO 380
      CALL CLOSE (UDV, 1)
      FILE = IOUTPU
      CALL GOPEN (IOUTPU, IZ(IBUF4), 0)
      K = 2*MCOL - 3
      KK = 0
      KKK = 3
      KKP = 1
      JJJ = NROW + 1
      CALL SKPREC (IOUTPU, K)
C
C     GET U SUB I
C
  380 IPNT = IU1 - KKP
      IF (ITYPE .EQ. 2) IPNT = IU3 - KKP
      CALL SKPREC (FILE, -KK)
      ASSIGN 385 TO IRETN
      GO TO 290
  385 IF (ITYPE .EQ. 1) GO TO 388
      IF (MCOL .EQ. NCOL) GO TO 386
      ITEST = Z(IPNT+1)
      IF (MCOL .EQ. ITEST+1) GO TO 386
      WRITE (NNOUT, 500)
      CALL MESAGE (-61, 0, 0)
  386 CALL SKPREC (FILE, -KKK)
C
C     GET U SUB I-1
C
      IPNT = IU1 - KKP
      ASSIGN 387 TO IRETN
      GO TO 290
  387 IF (MCOL .EQ. NCOL) GO TO 388
      ITEST = Z(IPNT+1)
      IF (MCOL .EQ. ITEST+2) GO TO 388
      WRITE (NNOUT, 600)
      CALL MESAGE (-61, 0, 0)
  388 CALL CLOSE (FILE, 1)
      JJJ = NROW
      CALL GOPEN (UDV, IZ(IBUF3), 1)
      CALL MAKMCB(MCB,UDV,NROW,2,1)
C
C     OUTPUT INITIAL DISPLACEMENT
C
      CALL PACK (Z(IU2 + 1), UDV, MCB(1))
C
C     OUTPUT INITIAL VELOCITY
C
      CALL PACK (Z(IP3 + 1), UDV, MCB(1))
      IF (ITYPE .EQ. 1) GO TO 8
      ASSIGN 8 TO IRET1
      GO TO 225
CRLBNE
CRLBDB SPR94003 9/94
CRLBD C
CRLBD C     RETRIEVE LAST VECTOR
CRLBD C
CRLBD   330 CALL GOPEN (UDV,IZ(IBUF3),0)
CRLBD       K = 3*(NCOL-1)
CRLBD       IAPEND = 1
CRLBD       CALL SKPREC (UDV,K)
CRLBD C
CRLBD C     GET U SUB I+1
CRLBD C
CRLBD       IPNT = IU2
CRLBD       ASSIGN 350 TO IRETN
CRLBD       GO TO 290
CRLBD CP
CRLBD C     GET U SUB I+1 DOT
CRLBD C
CRLBD   350 IPNT = IP1
CRLBD       ASSIGN 360 TO IRETN
CRLBD       GO TO 290
CRLBD C
CRLBD C     GET U SUB I+1 DOT DOT
CRLBD C
CRLBD   360 IPNT = IP4
CRLBD       ASSIGN 370 TO IRETN
CRLBD       GO TO 290
CRLBD   370 CONTINUE
CRLBD       CALL CLOSE (UDV,1)
CRLBD       CALL GOPEN (UDV,IZ(IBUF3),1)
CRLBD       CALL MAKMCB (MCB,UDV,NROW,2,2)
CRLBD C
CRLBD C     OUTPUT INITIAL DISPLACEMENT
CRLBD C
CRLBD       CALL PACK (Z(IU2+1),UDV,MCB(1))
CRLBD C
CRLBD C     OUTPUT INITIAL VELOCITY
CRLBD C
CRLBD       CALL PACK (Z(IP1+1),UDV,MCB(1))
CRLBD C
CRLBD C     FORM P SUB I+1
CRLBD C
CRLBD       DO 380 I = 1,NROW
CRLBD       K = IP2 + I
CRLBD       Z(K) = 0.0D0
CRLBD   380 CONTINUE
CRLBD       CALL FORM22 (Z(IP4+1),Z(IP1+1),Z(IU2+1),Z(IP2+1),RZ(IBUF1))
CRLBD       ASSIGN 10 TO IRET1
CRLBD       GO TO 250
CRLBDE
C
C     ERROR MESAGES
C
  390 IP1 = -1
  400 CALL MESAGE (IP1,FILE,SUBNAM)
      RETURN
CRLBNB SPR94003 9/94
  410 IP1 = -2
      GO TO 400
CRLBNE
C
  430 IP1  = -8
      FILE = ICRQ
      GO TO 400
CRLBNB SPR94003 9/94
  500 FORMAT ('0*** SYSTEM FATAL MESSAGE, LOGIC ERROR 1 IN ',
     *        'SUBROUTINE TRD1C2 WHILE PROCESSING THE RESTART ',
     *        'INFORMATION')
  600 FORMAT ('0*** SYSTEM FATAL MESSAGE, LOGIC ERROR 2 IN ',
     *        'SUBROUTINE TRD1C2 WHILE PROCESSING THE RESTART ',
     *        'INFORMATION')
CRLBNE
      END
