      SUBROUTINE TRD1C(IC,PD,NGROUP,NLFTP,UDV,ILOOP,SCR1,DIT,NLFT,NOUE,
CRLBR SPR94003 9/94
CRLBR1                 MODAL,PNL)
     1                 MODAL,PNL,ISKIP)
C
C     THIS ROUTINE STEPS INTEGRATION PROCEDURE
C
C     THIS ROUTINE IS SUITABLE FOR SINGLE PRECISION OPERATION
C
      LOGICAL NOPD
C
      INTEGER DIT1,PNL1,PNL
      INTEGER PD,UDV,SCR1,DIT,SYSBUF,FILE,IZ(1),MCB(7),IPNL(7)
CRLBR SPR94003 9/94      
CRLBR INTEGER SUBNAM(2)
      INTEGER SUBNAM(2), MOUTPU(7)
C
      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,ISCR6,
     1               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,IFRST
C
      EQUIVALENCE    (Z(1),IZ(1))
C
      DATA   SUBNAM /4HTRD1,1HC/
CRLBNB SPR94003 9/94
      DATA  IOUTPU, ISCR9 /203, 309/
CRLBNE
C
C ----------------------------------------------------------------------
C
C     INITIALIZE
C
      NROW  = IK(3)
      IT1   = 1
      IT2   = 1
      II    = 1
      JJ    = NROW
      INCR  = 1
      IT3   = 1
      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
      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 = IP4 +NROW
      NMODES= NROW- NOUE
      PNL1  = PNL
      ASSIGN 60 TO IRET1
      NSTEP = IZ(IGROUP) + 1
      DELTAT= Z(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,1)
   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= Z(IGROUP+1)
      NOUT  = IZ(IGROUP+2)
C
C     FORM  U=1, PO, P-1
C
      CALL FORM1( Z(IU2+1),Z(IU3+1),Z(IU1+1),Z(IP2+1),Z(IP1+1),DELTAT,
     1  Z(IBUF1))
C
C     START TIME STEP COUNT
C
   50 CONTINUE
      ICOUNT = 1
CRLBNB SPR94003 9/94   
      MCOL = 1
CRLBNE
   60 CONTINUE
      IF (NLFTP .EQ. 0) GO TO 62
      IFRST=0
      CALL TRD1D
      IFRST=1
   62 CONTINUE
C
C     OPEN FBS FILES
C
      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.0
   80 CONTINUE
      IF(NLFTP .EQ. 0) GO TO 90
C
C     FORM NON-LINEAR LOADS
C
      CALL TRD1D
      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.0
  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 STEP  (Z(IU3 + 1), Z(IU2 + 1), Z(IU1 + 1), Z(IP4 + 1),
     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.0/(2.0*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.0/(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.0*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) GO TO 190
      IF (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),NROW,1)
      CALL WRITE(SCR1,Z(IU1+1),NROW,1)
      CALL WRITE(SCR1,Z(IU2+1),NROW,1)
CRLBR SPR94003 9/94
CRLBR CALL WRITE (SCR1,Z(IP1+1),NROW,1)
      CALL WRITE (SCR1,Z(IP2+1),NROW,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 = Z(IGROUP-2)
      NSTEP  = IZ(IGROUP)
      DELTAT = Z(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),NROW,1)
      CALL FREAD(SCR1,Z(IU3+1),NROW,1)
      CALL FREAD(SCR1,Z(IU2+1),NROW,1)
      CALL FREAD(SCR1,Z(IP2+1),NROW,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.0/(DELTA1*DELTA1)
      DO 240 I=1,NROW
      K = IP4+ I
      L = IU2+ I
      M = IU3+ I
      J = IU1+ I
      Z(K) = (Z(L)- 2.0*Z(M) +Z(J))*H
  240 CONTINUE
CRLBD SPR94003 9/94   250 CONTINUE
C
C     COMPUTE UI PRIME
C
      H = DELTAT*DELTAT/2.0
      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.0
  280 CONTINUE
      CALL FORM2(Z(IP4+1),Z(IU3+1),Z(IU1+1),Z(IP1+1),Z(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.0
  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, 1)
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.0
CRLBD   380 CONTINUE
CRLBD       CALL FORM2(Z(IP4+1),Z(IP1+1),Z(IU2+1),Z(IP2+1),Z(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
  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
