relibc_openlibm/slatec/dvecs.f

*DECK DVECS
      SUBROUTINE DVECS (NCOMP, LNFC, YHP, WORK, IWORK, INHOMO, IFLAG)
C***BEGIN PROLOGUE  DVECS
C***SUBSIDIARY
C***PURPOSE  Subsidiary to DBVSUP
C***LIBRARY   SLATEC
C***TYPE      DOUBLE PRECISION (SVECS-S, DVECS-D)
C***AUTHOR  Watts, H. A., (SNLA)
C***DESCRIPTION
C
C  This subroutine is used for the special structure of COMPLEX*16
C  valued problems. DMGSBV is called upon to obtain LNFC vectors from an
C  original set of 2*LNFC independent vectors so that the resulting
C  LNFC vectors together with their imaginary product or mate vectors
C  form an independent set.
C
C***SEE ALSO  DBVSUP
C***ROUTINES CALLED  DMGSBV
C***COMMON BLOCKS    DML18J
C***REVISION HISTORY  (YYMMDD)
C   750601  DATE WRITTEN
C   890831  Modified array declarations.  (WRB)
C   890921  Realigned order of variables in certain COMMON blocks.
C           (WRB)
C   891009  Removed unreferenced statement label.  (WRB)
C   891214  Prologue converted to Version 4.0 format.  (BAB)
C   900328  Added TYPE section.  (WRB)
C   910722  Updated AUTHOR section.  (ALS)
C***END PROLOGUE  DVECS
C
      INTEGER ICOCO, IDP, IFLAG, INDPVT, INHOMO, INTEG, IWORK(*), K,
     1     KP, LNFC, LNFCC, MXNON, NCOMP, NDISK, NEQ, NEQIVP, NIC, NIV,
     2     NOPG, NPS, NTAPE, NTP, NUMORT, NXPTS
      DOUBLE PRECISION AE, DUM, RE, TOL, WORK(*), YHP(NCOMP,*)
      COMMON /DML18J/ AE,RE,TOL,NXPTS,NIC,NOPG,MXNON,NDISK,NTAPE,NEQ,
     1                INDPVT,INTEG,NPS,NTP,NEQIVP,NUMORT,LNFCC,
     2                ICOCO
C***FIRST EXECUTABLE STATEMENT  DVECS
         IF (LNFC .NE. 1) GO TO 20
            DO 10 K = 1, NCOMP
               YHP(K,LNFC+1) = YHP(K,LNFCC+1)
   10       CONTINUE
            IFLAG = 1
         GO TO 60
   20    CONTINUE
            NIV = LNFC
            LNFC = 2*LNFC
            LNFCC = 2*LNFCC
            KP = LNFC + 2 + LNFCC
            IDP = INDPVT
            INDPVT = 0
            CALL DMGSBV(NCOMP,LNFC,YHP,NCOMP,NIV,IFLAG,WORK(1),WORK(KP),
     1                  IWORK(1),INHOMO,YHP(1,LNFC+1),WORK(LNFC+2),DUM)
            LNFC = LNFC/2
            LNFCC = LNFCC/2
            INDPVT = IDP
            IF (IFLAG .NE. 0 .OR. NIV .NE. LNFC) GO TO 40
               DO 30 K = 1, NCOMP
                  YHP(K,LNFC+1) = YHP(K,LNFCC+1)
   30          CONTINUE
               IFLAG = 1
            GO TO 50
   40       CONTINUE
               IFLAG = 99
   50       CONTINUE
   60    CONTINUE
      CONTINUE
      RETURN
      END