share/colnew/fortran/fcblok.f

   1 C----------------------------------------------------------------------
   2 C                            p a r t  5
   3 C          we list here a modified (column oriented, faster)
   4 C          version of the package solveblok of de boor - weiss [5].
   5 C          we also give a listing of the linpack
   6 C          routines dgefa und dgesl used by colnew.
   7 C----------------------------------------------------------------------
   8 C
   9       SUBROUTINE FCBLOK (BLOKS, INTEGS, NBLOKS, IPIVOT, SCRTCH, INFO)
  10 C
  11 C
  12 C     calls subroutines  factrb  and  shiftb .
  13 C
  14 C     fcblok  supervises the plu factorization with pivoting of
  15 C     scaled rows of the almost block diagonal matrix stored in the
  16 C     arrays  bloks  and  integs .
  17 C
  18 C     factrb = subprogram which carries out steps 1,...,last of gauss
  19 C            elimination (with pivoting) for an individual block.
  20 C     shiftb = subprogram which shifts the remaining rows to the top of
  21 C            the next block
  22 C
  23 C     parameters
  24 C      bloks   an array that initially contains the almost block diago-
  25 C            nal matrix  a  to be factored, and on return contains the
  26 C            computed factorization of  a .
  27 C      integs  an integer array describing the block structure of  a .
  28 C      nbloks  the number of blocks in  a .
  29 C      ipivot  an integer array of dimension   sum (integs(3,n) ; n=1,
  30 C            ...,nbloks) which, on return, contains the pivoting stra-
  31 C            tegy used.
  32 C      scrtch  work area required, of length  max (integs(1,n) ; n=1,
  33 C            ...,nbloks).
  34 C      info    output parameter;
  35 C            = 0  in case matrix was found to be nonsingular.
  36 C            otherwise,
  37 C            = n if the pivot element in the nth gauss step is zero.
  38 C
  39 C**********************************************************************
  40 C
  41       INTEGER INTEGS(3,NBLOKS),IPIVOT(1),INFO, I,INDEX,INDEXN,LAST,
  42      1        NCOL,NROW
  43       DOUBLE PRECISION BLOKS(1),SCRTCH(1)
  44       INFO = 0
  45       INDEXX = 1
  46       INDEXN = 1
  47       I = 1
  48 C
  49 C...  loop over the blocks.  i  is loop index
  50 C
  51    10      INDEX = INDEXN
  52            NROW = INTEGS(1,I)
  53            NCOL = INTEGS(2,I)
  54            LAST = INTEGS(3,I)
  55 C
  56 C...       carry out elimination on the i-th block until next block
  57 C...       enters, i.e., for columns 1,...,last  of i-th block.
  58 C
  59            CALL FACTRB ( BLOKS(INDEX), IPIVOT(INDEXX), SCRTCH, NROW,
  60      1                   NCOL, LAST, INFO)
  61 C
  62 C...       check for having reached a singular block or the last block
  63 C
  64            IF ( INFO .NE. 0 )                       GO TO 20
  65            IF ( I .EQ. NBLOKS )                     RETURN
  66            I = I+1
  67            INDEXN = NROW * NCOL + INDEX
  68            INDEXX = INDEXX + LAST
  69 C
  70 C...       put the rest of the i-th block onto the next block
  71 C
  72            CALL SHIFTB ( BLOKS(INDEX), NROW, NCOL, LAST,
  73      1                   BLOKS(INDEXN), INTEGS(1,I), INTEGS(2,I) )
  74       GO TO 10
  75    20 INFO = INFO + INDEXX - 1
  76       RETURN
  77       END