*DECK ALPRTB
      SUBROUTINE ALPRTB(NOR,IINI,DEMT,IER,WEIGHT,BASEPT)
*
*-----------------------------------------------------------------------
*
* COMPUTE A PROBABILITY TABLE PRESERVING 2*NOR MOMENTS OF A FUNCTION
* USING THE MODIFIED RIBON APPROACH.
*
* INPUT PARAMETERS:
*  NOR    : THE NUMBER OF MOMENTS TO PRESERVE IS 2*NOR.
*  IINI   : MINIMUM ORDER OF THE MOMENT WE WANT TO PRESERVE. WE MUST
*           HAVE 2-2*NOR <= IINI <= 0 (ORDER 0 AND 1 MOMENTS ARE ALWAYS
*           PRESERVED).
*  DEMT   : MOMENTS. DOUBLE PRECISION DEMT(IINI:2*NOR+IINI-1)
*
* OUTPUT PARAMETERS:
*  IER    : =0/=1 SUCCESS/FAILURE OF THE ALGORITHM.
*  WEIGHT : WEIGHTS OF THE PROBABILITY TABLE. REAL WEIGHT(NOR)
*  BASEPT : BASE POINTS OF THE PROBABILITY TABLE. REAL BASEPT(NOR)
*
*----------------------------------------------- AUTHOR: A. HEBERT -----
*
      PARAMETER (MAXNOR=20)
      DOUBLE PRECISION DEMT(IINI:2*NOR+IINI-1),DS(MAXNOR+1,MAXNOR+1),
     1 DDA(0:MAXNOR),DD,DSIGX
      REAL WEIGHT(NOR),BASEPT(NOR)
      COMPLEX*16 ROOTS(MAXNOR),CCC,DCC,XCC
      COMPLEX CGAR
      LOGICAL LFAIL
*
      IF(NOR.GT.MAXNOR) CALL XABORT('ALPRTB: STORAGE OVERFLOW.')
      IF(NOR.LE.0) CALL XABORT('ALPRTB: NEGATIVE OR ZERO VALUE OF NOR.')
      IF((2-2*NOR.GT.IINI).OR.(IINI.GT.0)) CALL XABORT('ALPRTB: INCONSI'
     1 //'STENT VALUE OF IINI.')
*
* BUILD THE MATRIX.
      DO 10 IOR=1,NOR
      DS(IOR,NOR+1)=-DEMT(NOR+IOR+IINI-1)
      DO 10 JOR=1,IOR
      DS(IOR,JOR)=DEMT(IOR+JOR+IINI-2)
   10 DS(JOR,IOR)=DEMT(IOR+JOR+IINI-2)
*
* L-D-L(T) FACTORIZATION OF THE MATRIX.
      DO 40 I=1,NOR
      DO 30 J=1,I-1
      DS(J,I)=DS(I,J)
      DO 20 K=1,J-1
   20 DS(J,I)=DS(J,I)-DS(K,I)*DS(J,K)
      DS(I,J)=DS(J,I)*DS(J,J)
   30 DS(I,I)=DS(I,I)-DS(J,I)*DS(I,J)
      IF(DS(I,I).EQ.0.D0) THEN
         IER=1
         RETURN
      ENDIF
   40 DS(I,I)=1.D0/DS(I,I)
*
* SOLUTION OF THE FACTORIZED SYSTEM TO OBTAIN THE DENOMINATOR OF THE
* PADE APPROXIMATION.
      DO 50 I=1,NOR
      DO 50 K=1,I-1
   50 DS(I,NOR+1)=DS(I,NOR+1)-DS(I,K)*DS(K,NOR+1)
      DO 60 I=1,NOR
   60 DS(I,NOR+1)=DS(I,NOR+1)*DS(I,I)
      DO 70 I=NOR,1,-1
      DO 70 K=I+1,NOR
   70 DS(I,NOR+1)=DS(I,NOR+1)-DS(K,I)*DS(K,NOR+1)
      DS(NOR+1,NOR+1)=1.0D0
*
* COMPUTE THE BASE POINTS AS THE ROOTS OF THE DENOMINATOR.
      CALL ALROOT(DS(1,NOR+1),NOR,ROOTS,LFAIL)
      IF(LFAIL) CALL XABORT('ALPRTB: POLYNOMIAL ROOT FINDING FAILURE.')
      DO 80 I=1,NOR
*
*     NEWTON IMPROVEMENT OF THE ROOTS.
      CCC=0.0D0
      XCC=1.0D0
      DO 74 J=0,NOR
      CCC=CCC+DS(J+1,NOR+1)*XCC
   74 XCC=XCC*ROOTS(I)
      DCC=0.0D0
      XCC=1.0D0
      DO 75 J=1,NOR
      DCC=DCC+DS(J+1,NOR+1)*XCC*REAL(J)
   75 XCC=XCC*ROOTS(I)
      ROOTS(I)=ROOTS(I)-CCC/DCC
*
      CGAR=CMPLX(ROOTS(I))
      IF(ABS(AIMAG(CGAR)).GT.1.0E-4*ABS(REAL(CGAR))) THEN
         IER=1
         RETURN
      ELSE
         BASEPT(I)=REAL(CMPLX(ROOTS(I)))
      ENDIF
   80 CONTINUE
*
* COMPUTE THE WEIGHTS.
      DO 130 I=1,NOR
      DSIGX=DBLE(ROOTS(I))
      DDA(0)=1.0D0
      J0=0
      DO 100 J=1,NOR
      IF(J.EQ.I) GO TO 100
      J0=J0+1
      DDA(J0)=DDA(J0-1)
      DO 90 K=1,J0-1
   90 DDA(J0-K)=DDA(J0-K-1)-DDA(J0-K)*DBLE(ROOTS(J))
      DDA(0)=-DDA(0)*DBLE(ROOTS(J))
  100 CONTINUE
      DD=0.0D0
      DO 110 J=0,NOR-1
  110 DD=DD+DDA(J)*DEMT((IINI-1)/2+J)
      DO 120 J=1,NOR
      IF(J.NE.I) DD=DD/(DBLE(ROOTS(J))-DSIGX)
  120 CONTINUE
  130 WEIGHT(I)=REAL(((-1.0D0)**(NOR-1))*DD*DSIGX**((1-IINI)/2))
*
* TEST THE CONSISTENCY OF THE SOLUTION.
      DO 140 I=1,NOR
      IF((WEIGHT(I).LE.0.0).OR.(BASEPT(I).LE.0.0)) THEN
         IER=1
         RETURN
      ENDIF
  140 CONTINUE
      IER=0
      RETURN
      END
