      SUBROUTINE FBSI3 (BLOCK, Y, MEM, DMEM, IBUFF)
C
C     FBSI3 EXECUTES THE FORWARD/BACKWARD PASS FOR FBSI IN CSP
C
      INTEGER          BLOCK(8), DBL, BUF(2), SUBNAM, BEGN, END
      INTEGER          IBUFF(2), DBU, DBB, DBC
      INTEGER          RD, RDREW, WRT, WRTREW, REW, MEM(2)
      REAL             L, DMEM(2)
      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.0, 0.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 + 2
      INDXL  = INDXI + NROWS*2 - 1
      LJJ   = 1.0 / CMPLX( 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 ) + CMPLX( 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 + 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.0 / CMPLX( 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 ) + CMPLX( 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.0, 0.0)
      DO 2600 II = 1,NROWS
      JI = JI - 2
      IK = IK - 1
      SUM = SUM + CMPLX( 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 + 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.0
      DO 3600 II = 1,NROWS
      JI = JI - 2
      IK = IK - 1
      SUM = SUM + CMPLX( 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
