      SUBROUTINE FBSF (ZS,ZD)
C
C     GIVEN A LOWER TRIANGULAR FACTOR WITH DIAGONAL SUPERIMPOSED, AND
C     WRITTEN WITH TRAILING STRING DEFINITION WORDS, FBS WILL PERFORM
C     THE FORWARD-BACKWARD SUBSTITUTION NECESSARY TO SOLVE A LINEAR
C     SYSTEM OF EQUATIONS.
C
C     OPEN CORE IS DEFINED AS FOLLOWS
C
C     ZS(   1         ) - FIRST RIGHT HAND VECTOR ON FILE DBB
C                         (SIZE = NCOL*NWDS)
C                         NCOL = NUMBER OF COLUMNS (ROWS) IN LOWER  
C                                TRIANGULAR MATRIX
C                         NWDS = 1, IF MATRICES ARE REAL SINGLE
C                              = 2, IF MATRICES ARE REAL DOUBLE OR 
C                                COMPLEX SINGLE
C                              = 4, IF MATRICES ARE COMPLEX DOUBLE
C     ZS( NCOL*NWDS+1 ) - NEXT RIGHT HAND VECTOR
C         .
C         .               ( "KN" RIGHT HAND VECTORS WILL BE LOADED INTO 
C         .               MEMORY)
C         .
C     ZS( BUF1        ) - BUFFER FOR FILE WITH RIGHT HAND VECTORS
C                         AND FOR SOLUTION VECTORS
C     ZS( BUF2        ) - BUFFER FOR FILE WITH TRIANGULAR MATRIX
C
      IMPLICIT INTEGER (A-Z)
      LOGICAL         IDENT
      INTEGER         SUBNAM(2) ,BLOCK(15),BEGN     ,END
      REAL            ZS(1)    ,XS(4)    ,YS(4)
      DOUBLE  PRECISION          ZD(1)    ,XD       ,YD
      CHARACTER       UFM*23    ,UWM*25   ,UIM*29
      COMMON /LOGOUT/ LOUT
      COMMON /XMSSG / UFM       ,UWM      ,UIM
      COMMON /FBSX  / DBL(7)    ,DBU(7)   ,DBB(7)   ,DBX(7)   ,LCORE   ,
     1                PREC      ,SIGN     ,SCRX
      COMMON /SYSTEM/ SYSBUF    ,NOUT     ,SKIP(91) ,KSYS94
      COMMON /NAMES / RD        ,RDREW    ,WRT      ,WRTREW   ,REW     ,
     1                NOREW     ,EOFNRW   ,RSP      ,RDP      ,CSP     ,
     2                CDP
      COMMON /TYPE  / PRC(2)    ,WORDS(4) ,RLCMPX(4)
      COMMON /PACKX / ITYPE1    ,ITYPE2   ,I1       ,J1       ,INCR1
      COMMON /UNPAKX/ ITYPE3    ,I2       ,J2       ,INCR2
      COMMON /ZNTPKX/ XD(2)     ,IX       ,EOL
      COMMON /ZBLPKX/ YD(2)     ,IY
      EQUIVALENCE     (DBL(2),NL),   (DBB(5),TYPEB), (DBX(5),TYPEX),
     1                (XD(1),XS(1)), (YD(1),YS(1))
      DATA    SUBNAM/ 4HFBSF,4H    /  
      DATA    BEGN  / 4HBEGN/
      DATA    END   / 4HEND /
C
C     GENERAL INITIALIZATION
C
      BUF2   = LCORE - SYSBUF
      BUF1   = BUF2  - SYSBUF
      RC     = RLCMPX(TYPEB)
      TYPEL  = DBL(5)
      WDS    = WORDS(TYPEL)
      NWDS   = WDS*NL
      NBRLOD = DBB(2)
      IDENT  = .FALSE.
      IF (DBB(4) .EQ. 8) IDENT = .TRUE.
      IF (IDENT) NBRLOD = NL
      SWITCH = 1
      IF (TYPEL.EQ.RSP .AND. RC.EQ.2) SWITCH = 2
      IF (TYPEL.EQ.RDP .AND. RC.EQ.2) SWITCH = 3
      DBL1   = DBL(1)
      NNN    = BUF1 - 1
      NVECS  = NNN/NWDS
      IF (NVECS .EQ. 0) CALL MESAGE (-8,NWDS-NNN,SUBNAM)
      IF (SWITCH .NE. 1) NVECS = NVECS/2
      NPASS  = (NBRLOD+NVECS-1)/NVECS
      SUBNAM(2) = BEGN
      CALL CONMSG (SUBNAM,2,0)
   40 NPASS  = (NBRLOD+NVECS-1)/NVECS
      IF ( NPASS .EQ. 1 ) GO TO 50
      NEED = NWDS*NBRLOD + 2*SYSBUF
      WRITE ( LOUT, 9001 ) NPASS, NEED
9001  FORMAT(I4,' PASSES REQUIRED, OPEN CORE NEEDS TO BE ',I7
     &,' TO ELIMINATE THIS')
   50 CONTINUE
      I2     = 1
      J2     = NL
      INCR2  = 1
      I1     = 1
      J1     = NL
      INCR1  = 1
      ITYPE1 = TYPEL
      ITYPE2 = TYPEX
      ITYPE3 = SIGN*TYPEL
      DBX(2) = 0
      DBX(6) = 0
      DBX(7) = 0
      NNNDBL = NNN/2
      NTERMS = RLCMPX(TYPEL)*NL
      K1     = 1
      OPRD   = RDREW
      OPWRT  = WRTREW
      BLOCK(1) = DBL(1)
C
C     OPEN LOWER TRIANGULAR FACTOR FILE (DBL1)
C
      CALL GOPEN (DBL1,ZS(BUF2),RDREW)
C
C     OPEN RIGHT HAND VECTORS FILE (DBB) AND COMPUTE EXTENT OF THIS PASS
C
  100 KN    = MIN0(K1+NVECS-1,NBRLOD)
      LAST  = (KN-K1+1)*NWDS
      OPCLS = NOREW
      IF (KN .EQ. NBRLOD) OPCLS = REW
      IF (IDENT) GO TO 280
      CALL GOPEN (DBB,ZS(BUF1),OPRD)
      GO TO (140,180,230), SWITCH
C
C     NORMAL CASE - FILL CORE WITH RIGHT HAND VECTORS
C
  140 DO 170 L = 1,LAST,NWDS
      CALL UNPACK (*150,DBB,ZS(L))
      GO TO 170
  150 LN = L + NWDS - 1
      DO 160 LL = L,LN
  160 ZS(LL) = 0.
  170 CONTINUE
      GO TO 390
C
C     SPECIAL CASE - FACTOR IS RSP AND VECTORS ARE CSP
C
  180 LAST = 2*(KN-K1+1)*NWDS
      L = 0
      DO 190 K = 1,NNNDBL
  190 ZD(K) = 0.0D+0
      DO 220 K = K1,KN
      ICSPSG = CSP*SIGN
      CALL INTPK (*210,DBB,0,ICSPSG,0)
  200 CALL ZNTPKI
      ZS(L+IX   ) = XS(1)
      ZS(L+IX+NL) = XS(2)
      IF (EOL .EQ. 0) GO TO 200
  210 L = L + 2*NL
  220 CONTINUE
      GO TO 390
C
C     SPECIAL CASE - FACTOR IS RDP AND VECTORS ARE CDP
C
  230 LAST = 2*(KN-K1+1)*NWDS
      L = 0
      DO 240 K = 1,NNNDBL
  240 ZD(K) = 0.0D+0
      DO 270 K = K1,KN
      ICDPSG = CDP*SIGN
      CALL INTPK (*260,DBB,0,ICDPSG,0)
  250 CALL ZNTPKI
      ZD(L+IX   ) = XD(1)
      ZD(L+IX+NL) = XD(2)
      IF (EOL .EQ. 0) GO TO 250
  260 L = L + 2*NL
  270 CONTINUE
      GO TO 390
C
C     SPECIAL CASE - GENERATE IDENTITY MATRIX
C
  280 DO 290 K = 1,NNNDBL
  290 ZD(K) = 0.0D+0
      L = 0
      GO TO (300,320,340,360), TYPEL
  300 DO 310 K = K1,KN
      ZS(L+K) = 1.0
  310 L = L + NTERMS
      GO TO 400
  320 DO 330 K = K1,KN
      ZD(L+K) = 1.0D+0
  330 L = L + NTERMS
      GO TO 400
  340 DO 350 K = K1,KN
      ZS(L+2*K-1) = 1.0
  350 L = L + NTERMS
      GO TO 400
  360 DO 370 K = K1,KN
      ZD(L+2*K-1) = 1.0D+0
  370 L = L + NTERMS
      GO TO 400
C
C    CLOSE RIGHT HAND VECTORS FILE (DBB).
C    START FORWARD-BACKWARD SUBSTITUTION ON RIGHT HAND VECTORS NOW IN CORE
C
  390 CALL CLOSE  (DBB,OPCLS)
  400 CALL REWIND (DBL1)
      CALL FWDREC (*610,DBL1)
C
      J = TYPEL 
      GO TO (410,420,430,440), J
  410 CALL FBS1 (BLOCK,ZS,ZS(LAST),NWDS)
      GO TO 500
  420 CALL FBS2 (BLOCK,ZS,ZS(LAST),NWDS)
      GO TO 500
  430 CALL FBS3 (BLOCK,ZS,ZS(LAST),NWDS)
      GO TO 500
  440 CALL FBS4 (BLOCK,ZS,ZS(LAST),NWDS)
      GO TO 500
C
C     OPEN AND PACK SOLUTION VECTORS ONTO OUTPUT FILE (DBX)
C
  500 CALL GOPEN (DBX,ZS(BUF1),OPWRT)
      GO TO (510,530,560), SWITCH
C
C     NORMAL CASE - CALL PACK
C
  510 DO 520 L = 1,LAST,NWDS
      CALL PACK (ZS(L),DBX,DBX)
  520 CONTINUE
      GO TO 600
C
C     SPECIAL CASE - FACTOR IS RSP AND VECTORS ARE CSP, CALL BLDPK
C
  530 L = 0
      DO 550 K = K1,KN
      CALL BLDPK (CSP,TYPEX,DBX,0,0)
      DO 540 I = 1,NL
      YS(1) = ZS(L+I   )
      YS(2) = ZS(L+I+NL)
      IY = I
      CALL ZBLPKI
  540 CONTINUE
      CALL BLDPKN (DBX,0,DBX)
      L = L + 2*NL
  550 CONTINUE
      GO TO 600
C
C     SPECIAL CASE - FACTOR IS RDP AND VECTORS ARE CDP, CALL BLDPK
C
  560 L = 0
      DO 580 K = K1,KN
      CALL BLDPK (CDP,TYPEX,DBX,0,0)
      DO 570 I = 1,NL
      YD(1) = ZD(L+I   )
      YD(2) = ZD(L+I+NL)
      IY = I
      CALL ZBLPKI
  570 CONTINUE
      CALL BLDPKN (DBX,0,DBX)
      L = L + 2*NL
  580 CONTINUE
C
C     CLOSE OUTPUT FILE, AND TEST FOR MORE PASSES
C
  600 CALL CLOSE (DBX,OPCLS)
      IF (KN .EQ. NBRLOD) GO TO 620
      K1   = KN + 1
      OPRD = RD
      OPWRT= WRT
      GO TO 100
C
C     ERROR
C
  610 CALL MESAGE (-2,DBL1,SUBNAM)
C
C     JOB DONE. CLOSE TRIANGULAR FACTOR FILE.
C
  620 CALL CLOSE (DBL1,REW)
      SUBNAM(2) = END
      CALL CONMSG (SUBNAM,2,0)
      RETURN
      END
