      SUBROUTINE FBSI4 (BLOCK, Y, MEM, DMEM, IBUFF)
C
C     FBSI4 EXECUTES THE FORWARD/BACKWARD PASS FOR FBSI IN CDP
C
      INTEGER          BLOCK(8), DBL, BUF(2), SUBNAM, BEGN, END
      INTEGER          IBUFF(2), DBU, DBB, DBC
      INTEGER          RD, RDREW, WRT, WRTREW, REW, MEM(2)
      DOUBLE PRECISION L, DMEM(2)
      DOUBLE COMPLEX   Y(1), YJK, SUM, ZERO, LJJ
      CHARACTER        UFM*23, UWM*25, UIM*29, SFM*25
      COMMON /NAMES /  RD, RDREW, WRT, WRTREW, REW
      COMMON /XMSSG /  UFM, UWM, UIM, SFM
      COMMON /ZZZZZZ/  L(2)
      COMMON /SYSTEM/  SYSBUF, NOUT
      COMMON /FBSX  /  DBL(7), DBU(7), DBB(7), DBC(7)
      COMMON /FBSM  /  NVEC  , NVECSZ, NWDS  , LASIND, IPOS(7)
      DATA             ZERO / (0.0D+0, 0.0D+0 )    /
      DATA    SUBNAM, BEGN, END / 4HFBS4, 4HBEGN, 4HEND /
C
      NCOL   = DBL(2)
      BUF(1) = SUBNAM
      BUF(2) = BEGN
      IOPEN  = 0
      CALL CONMSG (BUF,2,0)
      LAST   = NVEC * NVECSZ
      NIDLT  = 1
      LCOL   = IPOS( 1 )
      DO 1000 J = 1,LCOL
C      PRINT *,' FORWARD, PROCESSING COLUMN J=',J
      J1 = J - 1
C
C CHECK IF THIS ROW VALUE IS ZERO FOR ALL RIGHT HAND VECTORS
C
      DO 10 K = J,LAST,NVECSZ
      IF (Y(K) .NE. ZERO) GO TO 100
10    CONTINUE
C
C ALL VALUES FOR THIS ROW ARE ZERO, SKIP TO NEXT ROW OF RIGHT HAND VECTORS
C
      IF ( NIDLT .GE. LASIND ) GO TO 1005
      KCOL   = MEM( NIDLT )
      IF ( KCOL .NE. J ) GO TO 7001
40    NROWS  = MEM( NIDLT+1 )
      NIDLT  = NIDLT + NROWS*NWDS + 4
      IF ( NIDLT .GE. LASIND ) GO TO 1005
      KCOL = MEM( NIDLT )
      IF ( KCOL .NE. J ) GO TO 1000
      GO TO 40
C
C     GET 1ST STRING FOR COLUMN AND SAVE DIAGONAL ELEMENT
C
100   CONTINUE
      KCOL   = MEM( NIDLT )
      IF ( KCOL .NE. J ) GO TO 7001
      NROWS  = MEM( NIDLT + 1 )    
      IROW   = MEM( NIDLT + NROWS*NWDS + 2 )
      INDXI  = ( NIDLT + 3 ) / 2
      INDXL  = INDXI + NROWS*2 - 1
      LJJ   = 1.0D+0 / DCMPLX( DMEM( INDXI ), DMEM( INDXI+1 ) )
      IF (NROWS .EQ. 1) GO TO 600
      INDXI = INDXI + 2
      IROW  = IROW + 1
C
C     PROCESS CURRENT STRING IN TRIANGULAR FACTOR AGAINST EACH
C     LOAD VECTOR IN CORE -- Y(I,K) = Y(I,K) + L(I,J)*Y(J,K)
C
300   DO 500 K   = 1, LAST, NVECSZ
      YJK        = Y( J1+K )
      IF ( YJK .EQ. ZERO ) GO TO 500
      IYROW      = IROW + K - 1
      DO 400 IJ  = INDXI, INDXL, 2
      Y( IYROW ) = Y( IYROW ) + DCMPLX( DMEM(IJ), DMEM(IJ+1) ) * YJK
400   IYROW      = IYROW + 1
500   CONTINUE
C
C     GET NEXT STRING IN TRIANGULAR FACTOR
C
600   CONTINUE
      NIDLT  = NIDLT + 4 + NROWS*NWDS
      IF ( NIDLT .GE. LASIND ) GO TO 800
      KCOL   = MEM( NIDLT )
      IF ( KCOL .NE. J ) GO TO 800
      NROWS  = MEM( NIDLT + 1 )
      IROW   = MEM( NIDLT + NROWS*NWDS + 2 )
      INDXI  = ( NIDLT + 3 ) / 2
      INDXL  = INDXI + NROWS*2 - 1
      GO TO 300
C
C     END-OF-COLUMN ON TRIANGULAR FACTOR -- DIVIDE BY DIAGONAL
C
800   DO 900 K = J,LAST,NVECSZ
      Y(K) = Y(K)*LJJ
900   CONTINUE
C
1000  CONTINUE
1005  CONTINUE
      IF ( LCOL .EQ. NCOL ) GO TO 2005
      IFCOL = LCOL + 1
      CALL GOPEN  ( DBL, IBUFF, RDREW ) 
C
C POSITION FILE TO APPROPRIATE COLUMN TO BE READ 
C
      CALL DSSPOS ( DBL, IPOS(2), IPOS(3), IPOS(4) )
      DO 2000 J = IFCOL, NCOL
      J1 = J - 1
C
C CHECK IF THIS ROW VALUE IS ZERO FOR ALL RIGHT HAND VECTORS
C
      DO 1010 K = J,LAST,NVECSZ
      IF (Y(K) .NE. ZERO) GO TO 1100
1010  CONTINUE
C
C ALL VALUES FOR THIS ROW ARE ZERO, SKIP TO NEXT ROW OF RIGHT HAND VECTORS
C
      CALL SKPREC ( DBL, 1 )
      GO TO 2000
C
C     GET 1ST STRING FOR COLUMN AND SAVE DIAGONAL ELEMENT
C
1100  CONTINUE
      BLOCK(8) = -1
      CALL GETSTR ( *7002, BLOCK )
      IF (BLOCK(4) .NE. J) GO TO 7002
      IROW  = BLOCK(4)  
      INDXI = BLOCK(5)
      NROWS = BLOCK(6)
      INDXL = INDXI + NROWS*2 - 1  
1200  CONTINUE
      LJJ   = 1.0D+0 / DCMPLX( L( INDXI ), L( INDXI+1 ) )
      IF (NROWS .EQ. 1) GO TO 1600
      INDXI = INDXI + 2
      IROW  = IROW + 1
C
C     PROCESS CURRENT STRING IN TRIANGULAR FACTOR AGAINST EACH
C     LOAD VECTOR IN CORE -- Y(I,K) = Y(I,K) + L(I,J)*Y(J,K)
C
1300  DO 1500 K   = 1, LAST, NVECSZ
      YJK        = Y( J1+K )
      IF ( YJK .EQ. ZERO ) GO TO 1500
      IYROW      = IROW + K - 1
      DO 1400 IJ  = INDXI, INDXL, 2
      Y( IYROW ) = Y( IYROW ) + DCMPLX( L(IJ), L(IJ+1) ) * YJK
1400  IYROW      = IYROW + 1
1500  CONTINUE
C
C     GET NEXT STRING IN TRIANGULAR FACTOR
C
1600  CONTINUE
      CALL ENDGET ( BLOCK )
      CALL GETSTR ( *1800, BLOCK )
      IROW  = BLOCK(4)  
      INDXI = BLOCK(5)
      NROWS = BLOCK(6)
      INDXL = INDXI + NROWS*2 - 1  
      GO TO 1300
C
C     END-OF-COLUMN ON TRIANGULAR FACTOR -- DIVIDE BY DIAGONAL
C
1800  DO 1900 K = J,LAST,NVECSZ
      Y(K) = Y(K)*LJJ
1900  CONTINUE
2000  CONTINUE
2005  CONTINUE
      IF ( NCOL  .EQ. 1 ) GO TO 7000    
      J = NCOL - 1   
      IF ( LCOL .EQ. NCOL ) GO TO 3000
C
C     INITIALIZE FOR BACKWARD PASS BY SKIPPING THE NTH COLUMN
C
      CALL BCKREC (BLOCK)
C
C     GET A STRING IN CURRENT COLUMN. IF THIS STRING INCLUDES DIAGONAL,
C     ADJUST STRING TO SKIP IT.
C
2200  J1 = J - 1
      BLOCK(8) = -1
2300  CALL GETSTB (*2900,BLOCK)
      IROW  = BLOCK( 4 )
      NROWS = BLOCK( 6 )
      IF (IROW-NROWS .EQ. J1) NROWS = NROWS - 1
      IF (NROWS .EQ. 0) GO TO 2800
      INDXI = BLOCK( 5 )
C
C     PROCESS CURRENT STRING IN TRIANGULAR FACTOR AGAINST EACH
C     LOAD VECTOR IN CORE -- Y(J,K) = Y(J,K) + L(J,I)*Y(I,K)
C
      DO 2700 K = 1,LAST,NVECSZ
      JI  = INDXI + 2
      IK  = IROW  + K
      SUM = (0.0D+0, 0.0D+0)
      DO 2600 II = 1,NROWS
      JI = JI - 2
      IK = IK - 1
      SUM = SUM + DCMPLX( L(JI),L(JI+1) ) * Y(IK)
2600  CONTINUE
      Y(J1+K) = Y(J1+K) + SUM
2700  CONTINUE
C
C     TERMINATE CURRENT STRING AND GET NEXT STRING
C
2800  CONTINUE
      CALL ENDGTB (BLOCK)
      GO TO 2300
C
C     END-OF-COLUMN -- TEST FOR COMPLETION
C
2900  IF (J .EQ. 1) GO TO 7000
      J = J - 1
      IF ( J .EQ. LCOL ) GO TO 3010
      GO TO 2200
C
3000  CONTINUE
C
C     INITIALIZE FOR BACKWARD PASS BY SKIPPING THE NTH COLUMN
C
3005  CONTINUE
      NIDLT = NIDLT - 1          
      NROWS = MEM( NIDLT )
      NIDLT = NIDLT - NROWS*NWDS - 3
      KCOL  = MEM( NIDLT )
      IF ( KCOL .EQ. NCOL ) GO TO 3005
      NIDLT = NIDLT + NROWS*NWDS + 4
3010  CONTINUE
C
C     GET A STRING IN CURRENT COLUMN. IF THIS STRING INCLUDES DIAGONAL,
C     ADJUST STRING TO SKIP IT.
C
3200  J1 = J - 1
C      print *,' processing column in backward step, j=',j
3250  NIDLT = NIDLT - 1
      IF ( NIDLT .LE. 1 ) GO TO 3900
      NROWS = MEM( NIDLT )
      IROW  = MEM( NIDLT-1 )
      NIDLT = NIDLT - NROWS*NWDS - 3
      KCOL  = MEM( NIDLT )
3260  CONTINUE     
      IF ( KCOL .NE. J ) GO TO 3900
      INDXI = NIDLT/2  + NROWS*2 
      IROW  = IROW + NROWS - 1
      IF ( (IROW-NROWS) .EQ. J1 ) NROWS = NROWS - 1   
C
C     PROCESS CURRENT STRING IN TRIANGULAR FACTOR AGAINST EACH
C     LOAD VECTOR IN CORE -- Y(J,K) = Y(J,K) + L(J,I)*Y(I,K)
C
      DO 3700 K = 1,LAST,NVECSZ
      JI  = INDXI + 2
      IK  = IROW  + K
      SUM = 0.0D+0
      DO 3600 II = 1,NROWS
      JI = JI - 2
      IK = IK - 1
      SUM = SUM + DCMPLX( DMEM(JI),DMEM(JI+1) ) * Y(IK)
3600  CONTINUE
      Y(J1+K) = Y(J1+K) + SUM
3700  CONTINUE
C
C     TERMINATE CURRENT STRING AND GET NEXT STRING
C
      GO TO 3250
C
C     END-OF-COLUMN -- TEST FOR COMPLETION
C
3900  IF (J .EQ. 1) GO TO 7000
      J  = J - 1
      J1 = J - 1
      GO TO 3260
C
7000  BUF(2) = END
      CALL CONMSG (BUF,2,0)
      CALL CLOSE ( DBL, REW )
      RETURN
C
C     FATAL ERROR MESSAGE
C
7001  CONTINUE
7002  CONTINUE
      WRITE  (NOUT,9001) SFM,SUBNAM
9001  FORMAT (A25,' 2149, SUBROUTINE ',A4,/5X,'FIRST ELEMENT OF A COLU',
     1      'MN OF LOWER TRIANGULAR MATRIX IS NOT THE DIAGONAL ELEMENT')
      CALL MESAGE (-61,0,0)
      RETURN
      END
