      subroutine ntuple(x,a,b,ii)
C--------------------------------------------------------------
c
c
c     This is a modified version for use with multi-pole integrations
c     it allows you to get the same set of random numbers several times
c     (1 for each configuration) jj tells it what configuration to use,
c     so if you always put jj=1, you basically get the old version of
c     ntuple out. It is currently configued to have maxconfig=25.
c     Modified by Tim Stelzer July 5 1995
c
c
c       Abstract:
c
c      ntuple - returns sequences of quasi-uniform random numbers
c               in the interval (a,b) using scrambled radical inverse
c               sequences. These numbers are designed for use in
c               Monte Carlo integration routines.
c
c  Author: Bill Long, UW-Madison Phenomenology Institute, 19-MAR-1991
c               Based on the algorithm for an earlier routine, htuple,
c               written by George Weller.
c
c               Original reference for this algorithm:
c
c         E. Braaten and G. Weller, J. Comp. Phys. 33,249-258 (1979)
c
c  References for radical inverse sequences (and Halton sequences)
c               are ck+^Z7ed in the above article.
c
c    Usage Notes:
c
c 1) Sequence numbers, i, range from 1 to 25 and correspond
c   to scrambled radical inverse sequences based on the first
c   25 primes (2..97).  In general, when performing a multi-dimensional
c   integral, a separate value of i should be used for the values
c   along each axis.
c
c 2) The basic algorithm generates values in the range (0,1). These
c    are rescaled to the range (a,b) in the final statement, so
c    it is not necessary to have a < b.  If a=b, the returned value, x,
c    will always be equal to a.
c
c 3) The sequences for different values of i are independent. They
c    cycle with different periods ranging from ~ 4M numbers
c    through 147M numbers, covering numbers of precision 23-27 bits
c    appropriate for the mantissa of a single precision real value.
c
c 4) Ntuple differs from htuple primarily in that ntuple sequences
c    cycle with periods that are roughly equal for each value of i.
c    Htuple sequences cycled too quickly for small i, and too
c    slowly for large i. Ntuple is also written in a more modern
c    style, and uses considerably less memory, helping execution
c    speed on cache-sensitive machines.
c
c
c--Argument Declarations
c
      real*8  x    !  OUT - quasi-random value returned
                   !        x is in the range (a,b)
      real*8  a    !  IN  - Lower bound of interval for x
      real*8  b    !  IN  - Upper bound of interval for x
      integer ii   !  IN  - Sequence number, restricted to 1 <= i <= MaxDim
      integer jconfig!IN  - Pole number, restricted to1<=jconfig<= MaxConfigs
c
c     Constants
c

c      include "genps.inc"
c      include 'maxconfigs.inc'

      integer ndim,kdim,mdim,maxconfig,ktot
      parameter (ndim =25, kdim = 181, mdim = 1060)
c      parameter (maxconfig=maxconfigs, ktot=kdim*maxconfig)
      parameter (maxconfig=4000, ktot=kdim*maxconfig)

c
c--Local Variable Declarations
c
      integer base_minus1(ndim),mix(mdim),k(kdim,maxconfig)
      double precision accum(kdim,maxconfig)
      double precision pbase(kdim)
      integer offset,koffset(ndim),mix_offset(ndim),maxj(ndim)
      integer jj
      logical first_time

c
c--Fixed Data Initializations
c
      data (pbase(i), i = 1, 146)
     .     /2d0,4d0,8d0,16d0,32d0,64d0,128d0,256d0,512d0,1024d0,
     .     2048d0,4096d0,8192d0,16384d0,32768d0,65536d0,131072d0,
     .     262144d0,524288d0,1048576d0,2097152d0,4194304d0,8388608d0,
     .     16777216d0,0d0,3d0,9d0,27d0,81d0,243d0,729d0,2187d0,6561d0,
     .     19683d0,59049d0,177147d0,531441d0,1594323d0,4782969d0,
     .     14348907d0,0d0,5d0,25d0,125d0,625d0,3125d0,15625d0,78125d0,
     .     390625d0,1953125d0,9765625d0,0d0,7d0,49d0,343d0,2401d0,
     .     16807d0,117649d0,823543d0,5764801d0,0d0,11d0,121d0,1331d0,
     .     14641d0,161051d0,1771561d0,19487171d0,0d0,13d0,169d0,2197d0,
     .     28561d0,371293d0,4826809d0,0d0,17d0,289d0,4913d0,83521d0,
     .     1419857d0,24137569d0,0d0,19d0,361d0,6859d0,130321d0,
     .     2476099d0,47045881d0,0d0,23d0,529d0,12167d0,279841d0,
     .     6436343d0,0d0,29d0,841d0,24389d0,707281d0,20511149d0,0d0,
     .     31d0,961d0,29791d0,923521d0,28629151d0,0d0,37d0,1369d0,
     .     50653d0,1874161d0,69343957d0,0d0,41d0,1681d0,68921d0,
     .     2825761d0,115856201d0,0d0,43d0,1849d0,79507d0,3418801d0,
     .     147008443d0,0d0,47d0,2209d0,103823d0,4879681d0,0d0,53d0,
     .     2809d0,148877d0,7890481d0,0d0,59d0,3481d0,205379d0,
     .     12117361d0,0d0,61d0,3721d0,226981d0,13845841d0,0d0/
      data (pbase(i), i=147, 181)
     .     /67d0,4489d0,300763d0,20151121d0,0d0,71d0,5041d0,357911d0,
     .     25411681d0,0d0,73d0,5329d0,389017d0,28398241d0,0d0,79d0,
     .     6241d0,493039d0,38950081d0,0d0,83d0,6889d0,571787d0,
     .     47458321d0,0d0,89d0,7921d0,704969d0,62742241d0,0d0,97d0,
     .     9409d0,912673d0,88529281d0, 0d0/

      data base_minus1/
     .      1,    2,    4,    6,   10,   12,   16,   18,   22,   28,
     .     30,   36,   40,   42,   46,   52,   58,   60,   66,   70,
     .     72,   78,   82,   88,   96/

      data maxj/ 24, 15, 10, 8,    7,    6,    6,    6,    5,    5,
     .     5,    5,    5,    5,    4,    4,    4,    4,    4,    4,
     .     4,    4,    4,    4,    4/

      data koffset/
     .     0,   25,   41,   52,   61,   69,   76,   83,   90,   96,
     .     102,  108,  114,  120,  126,  131,  136,  141,  146,  151,
     .     156,  161,  166,  171,  176/

      data mix_offset/
     .     0,    2,    5,   10,   17,   28,   41,   58,   77,  100,
     .     129,  160,  197,  238,  281,  328,  381,  440,  501,  568,
     .     639,  712,  791,  874,  963/

      data (mix(i), i = 1, 412)
     .     /1,0, 1,2,0, 3,1,4,2,0, 4,2,6,1,5,3,0, 5,8,2,10,3,6,1,9,
     .     7,4,0, 6,10,2,8,4,12,1,9,5,11,3,7,0, 8,13,3,11,5,16,1,10,7,
     .     14,4,12,2,15,6,9,0, 9,14,3,17,6,11,1,15,7,12,4,18,8,2,16,10,
     .     5,13,0, 11,17,4,20,7,13,2,22,9,15,5,18,1,14,10,21,6,16,3,19,
     .     8,12,0, 15,7,24,11,20,2,27,9,18,4,22,13,26,5,16,10,23,1,19,
     .     28,6,14,17,3,25,12,8,21,0,  15,23,5,27,9,18,2,29,12,20,7,25,
     .     11,17,3,30,14,22,1,21,8,26,10,16,28,4,19,6,24,13,0, 18,28,6,
     .     23,11,34,3,25,14,31,8,20,36,1,16,27,10,22,13,32,4,29,17,7,
     .     35,19,2,26,12,30,9,24,15,33,5,21,0, 20,31,7,26,12,38,3,23,
     .     34,14,17,29,5,40,10,24,1,35,18,28,9,33,15,21,4,37,13,30,8,
     .     39,22,2,27,16,32,11,25,6,36,19,0, 21,32,7,38,13,25,3,35,17,
     .     28,10,41,5,23,30,15,37,1,19,33,11,26,42,8,18,29,4,39,14,22,
     .     34,6,24,12,40,2,31,20,27,9,36,16,0, 24,12,39,6,33,20,44,3,
     .     29,16,36,10,42,22,8,31,26,14,46,1,35,18,28,5,40,19,37,11,25,
     .     43,4,30,15,34,9,45,21,2,32,17,41,13,27,7,38,23,0,
     .     26,40,9,33,16,49,4,36,21,45,12,29,6,51,23,38,14,43,1,30,19,
     .     47,10,34,24,42,3,27,52,15,18,39,7,46,31,11,35,20,48,2,28,41,
     .     8,22,50,13,32,17,44,5,37,25,0, 29,44,10,52,18,34,4,48,23,38,
     .     13,57,7,32,41,20,54,2,26,46,15,36,24,50,8,40,16,56,5,30,43/
      data (mix(i), i = 413, 803)
     .     /21,51,11,33,1,58,27,37,14,47,19,28,45,6,53,12,35,22,42,3,
     .     55,25,31,9,49,17,39,0,30,46,10,38,18,56,4,42,24,52,14,33,21,
     .     59,6,40,27,49,2,35,16,54,12,44,26,50,8,32,58,19,1,41,29,48,
     .     13,36,22,60,7,45,23,53,9,34,17,55,3,39,28,47,15,37,20,57,5,
     .     43,25,51,11,31,0, 33,50,11,59,20,39,5,54,26,44,15,64,23,36,
     .     2,57,30,47,9,62,18,41,13,52,28,37,4,66,24,46,8,55,31,17,60,
     .     34,1,48,21,43,63,12,38,25,53,7,49,16,58,29,6,42,65,19,35,10,
     .     51,27,56,3,40,32,61,14,45,22,0, 35,53,12,62,21,41,5,67,28,
     .     46,16,56,25,8,50,38,65,2,32,59,19,44,14,70,30,48,7,39,58,22,
     .     10,63,33,26,52,1,55,18,43,68,13,36,47,4,61,24,40,29,66,9,51,
     .     17,57,23,37,3,69,31,45,15,60,11,49,34,20,64,6,54,27,42,0,
     .     36,55,12,46,22,67,5,41,61,18,30,52,8,70,27,43,15,59,33,2,64,
     .     38,24,50,10,72,20,48,31,57,4,63,25,40,14,54,35,68,7,45,17,
     .     60,28,1,66,39,21,51,11,71,32,47,13,56,26,44,3,65,34,19,58,9,
     .     49,37,69,16,29,53,6,62,23,42,0, 39,59,13,69,24,46,6,74,31,
     .     51,18,63,9,42,55,27,77,2,35,65,21,48,15,71,33,53,4,61,29,43,
     .     17,75,37,10,67,49,22,57,7,72,26,40,56,1,64,30,45,14,78,20,
     .     52,34,11,68,41,60,5,36,73,23,50,16,62,28,3,76,44,25,58,12,
     .     66,38,19,54,32,70,8,47,0,41,62,14,73,25,48,6,67,32,54,19,80/
      data (mix(i), i = 804, 1060)
     .     /10,44,58,29,76,2,37,64,22,51,16,71,35,56,8,82,27,46,12,69,
     .     39,60,4,50,24,78,31,65,17,42,74,1,53,21,61,34,11,79,43,28,
     .     68,7,55,38,75,15,47,20,70,5,57,33,81,26,49,9,63,36,66,18,45,
     .     3,77,30,59,23,52,13,72,40,0, 44,67,15,56,27,82,6,50,74,22,
     .     36,63,10,86,33,53,18,77,40,2,70,47,29,80,12,60,38,65,20,88,
     .     4,51,31,72,24,58,8,78,42,46,16,84,34,62,1,69,26,55,19,76,41,
     .     11,83,49,30,66,7,59,37,87,14,54,25,73,21,68,43,3,79,35,57,
     .     13,81,45,28,64,5,75,32,52,17,85,39,9,61,71,23,48,0, 48,73,
     .     16,61,29,89,7,55,81,34,22,69,41,94,3,52,77,19,38,85,12,64,
     .     44,26,91,58,9,71,32,79,14,50,66,24,96,1,46,83,36,59,18,75,
     .     30,87,5,54,42,68,21,92,10,62,39,80,27,56,6,86,47,72,15,35,
     .     93,43,65,2,76,25,53,84,17,37,67,11,90,49,31,74,20,60,95,4,
     .     45,63,28,82,13,57,40,78,8,88,33,51,23,70,0/
c
c--Variable Data Initializations
c
      data accum /ktot*0d0/

      data k /ktot*0d0/
      data first_time /.true./
c
c--Code:
c
      jconfig=1
      if (first_time) then
c         write(*,*) 'Warning htuple modified for 1 configuration only'
c         write(*,*) 'Using htuple configuration ',jconfig
         first_time=.false.
c
c        to use multiple configurations need to use line
        jj = jconfig
c
      endif
      jj = jconfig
c      jj=1      !use jj=jconfig for multiconfiguraion mode
      if (jj .lt. 1 .or. jj .gt. maxconfig) then
         print*,'Error in ntuple.  Invalid pole choice',jj
         stop
      endif
      i=ii
      i = ii+jj                   !This keeps us from generating same ran #'s
      do while (i .gt. ndim)
         i=i-ndim
      enddo
c      if (i .gt. ndim) i=i-ndim   !For different configurations
      j = 1
      offset = koffset(i)
      do while (k(offset+j,jj) .eq. base_minus1(i))
         k(offset+j,jj)=0
         j=j+1
         if (j.gt.maxj(i)) then
            do j=1,maxj(i)
               k(offset+j,jj)=0
               accum(offset+j,jj)=0d0
            end do
            j=1
         end if
      end do

      k(offset+j,jj)=k(offset+j,jj)+1
      accum(offset+j,jj) = accum(offset+j+1,jj) +
     .     mix(mix_offset(i)+k(offset+j,jj))/pbase(offset+j)
      do  jjj=2,j-1
         accum(offset+jjj,jj) = accum(offset+j,jj)
      end do
      x = a + (b-a) * accum(offset+j,jj)
c      write(*,'(2i6,1f15.8)') jj,i,x
      end


C CERNLIB routines
C
      DOUBLE PRECISION FUNCTION DDILOG(X)

      DOUBLE PRECISION X,Y,T,S,A,PI3,PI6,ZERO,ONE,HALF,MALF,MONE,MTWO
      DOUBLE PRECISION C(0:18),H,ALFA,B0,B1,B2

      DATA ZERO /0.0D0/, ONE /1.0D0/
      DATA HALF /0.5D0/, MALF /-0.5D0/, MONE /-1.0D0/, MTWO /-2.0D0/
      DATA PI3 /3.28986 81336 96453D0/, PI6 /1.64493 40668 48226D0/

      DATA C( 0) / 0.42996 69356 08137 0D0/
      DATA C( 1) / 0.40975 98753 30771 1D0/
      DATA C( 2) /-0.01858 84366 50146 0D0/
      DATA C( 3) / 0.00145 75108 40622 7D0/
      DATA C( 4) /-0.00014 30418 44423 4D0/
      DATA C( 5) / 0.00001 58841 55418 8D0/
      DATA C( 6) /-0.00000 19078 49593 9D0/
      DATA C( 7) / 0.00000 02419 51808 5D0/
      DATA C( 8) /-0.00000 00319 33412 7D0/
      DATA C( 9) / 0.00000 00043 45450 6D0/
      DATA C(10) /-0.00000 00006 05784 8D0/
      DATA C(11) / 0.00000 00000 86121 0D0/
      DATA C(12) /-0.00000 00000 12443 3D0/
      DATA C(13) / 0.00000 00000 01822 6D0/
      DATA C(14) /-0.00000 00000 00270 1D0/
      DATA C(15) / 0.00000 00000 00040 4D0/
      DATA C(16) /-0.00000 00000 00006 1D0/
      DATA C(17) / 0.00000 00000 00000 9D0/
      DATA C(18) /-0.00000 00000 00000 1D0/

      IF(X .EQ. ONE) THEN
       DDILOG=PI6
       RETURN
      ELSE IF(X .EQ. MONE) THEN
       DDILOG=MALF*PI6
       RETURN
      END IF
      T=-X
      IF(T .LE. MTWO) THEN
       Y=MONE/(ONE+T)
       S=ONE
       A=-PI3+HALF*(LOG(-T)**2-LOG(ONE+ONE/T)**2)
      ELSE IF(T .LT. MONE) THEN
       Y=MONE-T
       S=MONE
       A=LOG(-T)
       A=-PI6+A*(A+LOG(ONE+ONE/T))
      ELSE IF(T .LE. MALF) THEN
       Y=(MONE-T)/T
       S=ONE
       A=LOG(-T)
       A=-PI6+A*(MALF*A+LOG(ONE+T))
      ELSE IF(T .LT. ZERO) THEN
       Y=-T/(ONE+T)
       S=MONE
       A=HALF*LOG(ONE+T)**2
      ELSE IF(T .LE. ONE) THEN
       Y=T
       S=ONE
       A=ZERO
      ELSE
       Y=ONE/T
       S=MONE
       A=PI6+HALF*LOG(T)**2
      END IF

      H=Y+Y-ONE
      ALFA=H+H
      B1=ZERO
      B2=ZERO
      DO 1 I = 18,0,-1
      B0=C(I)+ALFA*B1-B2
      B2=B1
    1 B1=B0
      DDILOG=-(S*(B0-H*B2)+A)
      RETURN
      END
          FUNCTION FINT_FK88(NARG,ARG,NENT,ENT,TABLE)
C
C   INTERPOLATION ROUTINE. AUTHOR C. LETERTRE.
C   MODIFIED BY B. SCHORR, 1.07.1982.
C
          INTEGER   NENT(9)
          REAL      ARG(9),   ENT(9),   TABLE(9)
          INTEGER   INDEX(32)
          REAL      WEIGHT(32)
          LOGICAL   MFLAG,    RFLAG
          FINT_FK88  =  0.
          IF(NARG .LT. 1  .OR.  NARG .GT. 5)  GOTO 300
          LMAX      =  0
          ISTEP     =  1
          KNOTS     =  1
          INDEX(1)  =  1
          WEIGHT(1) =  1.
          DO 100    N  =  1, NARG
             X     =  ARG(N)
             NDIM  =  NENT(N)
             LOCA  =  LMAX
             LMIN  =  LMAX + 1
             LMAX  =  LMAX + NDIM
             IF(NDIM .GT. 2)  GOTO 10
             IF(NDIM .EQ. 1)  GOTO 100
             H  =  X - ENT(LMIN)
             IF(H .EQ. 0.)  GOTO 90
             ISHIFT  =  ISTEP
             IF(X-ENT(LMIN+1) .EQ. 0.)  GOTO 21
             ISHIFT  =  0
             ETA     =  H / (ENT(LMIN+1) - ENT(LMIN))
             GOTO 30
  10         LOCB  =  LMAX + 1
  11         LOCC  =  (LOCA+LOCB) / 2
             IF(X-ENT(LOCC))  12, 20, 13
  12         LOCB  =  LOCC
             GOTO 14
  13         LOCA  =  LOCC
  14         IF(LOCB-LOCA .GT. 1)  GOTO 11
             LOCA    =  MIN0( MAX0(LOCA,LMIN), LMAX-1 )
             ISHIFT  =  (LOCA - LMIN) * ISTEP
             ETA     =  (X - ENT(LOCA)) / (ENT(LOCA+1) - ENT(LOCA))
             GOTO 30
  20         ISHIFT  =  (LOCC - LMIN) * ISTEP
  21         DO 22  K  =  1, KNOTS
                INDEX(K)  =  INDEX(K) + ISHIFT
  22            CONTINUE
             GOTO 90
  30         DO 31  K  =  1, KNOTS
                INDEX(K)         =  INDEX(K) + ISHIFT
                INDEX(K+KNOTS)   =  INDEX(K) + ISTEP
                WEIGHT(K+KNOTS)  =  WEIGHT(K) * ETA
                WEIGHT(K)        =  WEIGHT(K) - WEIGHT(K+KNOTS)
  31            CONTINUE
             KNOTS  =  2*KNOTS
  90         ISTEP  =  ISTEP * NDIM
 100         CONTINUE
          DO 200    K  =  1, KNOTS
             I  =  INDEX(K)
             FINT_FK88  =  FINT_FK88 + WEIGHT(K) * TABLE(I)
 200         CONTINUE
          RETURN
 300      CALL KERMTR('E104.1',LGFILE,MFLAG,RFLAG)
          IF(MFLAG) THEN
             IF(LGFILE .EQ. 0) THEN
                WRITE(*,1000) NARG
             ELSE
                WRITE(LGFILE,1000) NARG
             ENDIF
          ENDIF
          IF(.NOT. RFLAG) CALL ABEND
          RETURN
1000      FORMAT( 7X, 29HFUNCTION FINT_FK88 ... NARG =,I6,
     +              17H NOT WITHIN RANGE)
          END
      FUNCTION DIVDIF(F,A,NN,X,MM)
      DIMENSION A(NN),F(NN),T(20),D(20)
      LOGICAL EXTRA
      LOGICAL MFLAG,RFLAG
      DATA MMAX/10/
C
C  TABULAR INTERPOLATION USING SYMMETRICALLY PLACED ARGUMENT POINTS.
C
C  START.  FIND SUBSCRIPT IX OF X IN ARRAY A.
      IF( (NN.LT.2) .OR. (MM.LT.1) ) GO TO 20
      N=NN
      M=MIN0(MM,MMAX,N-1)
      MPLUS=M+1
      IX=0
      IY=N+1
      IF(A(1).GT.A(N)) GO TO 4
C     (SEARCH INCREASING ARGUMENTS.)
    1    MID=(IX+IY)/2
         IF(X.GE.A(MID)) GO TO 2
            IY=MID
            GO TO 3
C        (IF TRUE.)
    2       IX=MID
    3    IF(IY-IX.GT.1) GO TO 1
         GO TO 7
C     (SEARCH DECREASING ARGUMENTS.)
    4    MID=(IX+IY)/2
         IF(X.LE.A(MID)) GO TO 5
            IY=MID
            GO TO 6
C        (IF TRUE.)
    5       IX=MID
    6    IF(IY-IX.GT.1) GO TO 4
C
C  COPY REORDERED INTERPOLATION POINTS INTO (T(I),D(I)), SETTING
C  *EXTRA* TO TRUE IF M+2 POINTS TO BE USED.
    7 NPTS=M+2-MOD(M,2)
      IP=0
      L=0
      GO TO 9
    8    L=-L
         IF(L.GE.0) L=L+1
    9    ISUB=IX+L
         IF((1.LE.ISUB).AND.(ISUB.LE.N)) GO TO 10
C        (SKIP POINT.)
            NPTS=MPLUS
            GO TO 11
C        (INSERT POINT.)
   10       IP=IP+1
            T(IP)=A(ISUB)
            D(IP)=F(ISUB)
   11    IF(IP.LT.NPTS) GO TO 8
      EXTRA=NPTS.NE.MPLUS
C
C  REPLACE D BY THE LEADING DIAGONAL OF A DIVIDED-DIFFERENCE TABLE, SUP-
C  PLEMENTED BY AN EXTRA LINE IF *EXTRA* IS TRUE.
      DO 14 L=1,M
         IF(.NOT.EXTRA) GO TO 12
            ISUB=MPLUS-L
            D(M+2)=(D(M+2)-D(M))/(T(M+2)-T(ISUB))
   12    I=MPLUS
         DO 13 J=L,M
            ISUB=I-L
            D(I)=(D(I)-D(I-1))/(T(I)-T(ISUB))
            I=I-1
   13    CONTINUE
   14 CONTINUE
C
C  EVALUATE THE NEWTON INTERPOLATION FORMULA AT X, AVERAGING TWO VALUES
C  OF LAST DIFFERENCE IF *EXTRA* IS TRUE.
      SUM=D(MPLUS)
      IF(EXTRA) SUM=0.5*(SUM+D(M+2))
      J=M
      DO 15 L=1,M
         SUM=D(J)+(X-T(J))*SUM
         J=J-1
   15 CONTINUE
      DIVDIF=SUM
      RETURN
C
   20 CALL KERMTR('E105.1',LGFILE,MFLAG,RFLAG)
      IF(MFLAG) THEN
         IF(LGFILE.EQ.0) THEN
            IF(MM.LT.1) WRITE(*,101) MM
            IF(NN.LT.2) WRITE(*,102) NN
         ELSE
            IF(MM.LT.1) WRITE(LGFILE,101) MM
            IF(NN.LT.2) WRITE(LGFILE,102) NN
         ENDIF
      ENDIF
      IF(.NOT.RFLAG) CALL ABEND
      RETURN
  101 FORMAT( 7X, 'FUNCTION DIVDIF ... M =',I6,' IS LESS THAN 1')
  102 FORMAT( 7X, 'FUNCTION DIVDIF ... N =',I6,' IS LESS THAN 2')
      END
          SUBROUTINE KERSET(ERCODE,LGFILE,LIMITM,LIMITR)
                    PARAMETER(KOUNTE  =  28)
          CHARACTER*6         ERCODE,   CODE(KOUNTE)
          LOGICAL             MFLAG,    RFLAG
          INTEGER             KNTM(KOUNTE),       KNTR(KOUNTE)
          DATA      LOGF      /  0  /
          DATA      CODE(1), KNTM(1), KNTR(1)  / 'C204.1', 100, 100 /
          DATA      CODE(2), KNTM(2), KNTR(2)  / 'C204.2', 100, 100 /
          DATA      CODE(3), KNTM(3), KNTR(3)  / 'C204.3', 100, 100 /
          DATA      CODE(4), KNTM(4), KNTR(4)  / 'C205.1', 100, 100 /
          DATA      CODE(5), KNTM(5), KNTR(5)  / 'C205.2', 100, 100 /
          DATA      CODE(6), KNTM(6), KNTR(6)  / 'C205.3', 100, 100 /
          DATA      CODE(7), KNTM(7), KNTR(7)  / 'C305.1', 100, 100 /
          DATA      CODE(8), KNTM(8), KNTR(8)  / 'C308.1', 100, 100 /
          DATA      CODE(9), KNTM(9), KNTR(9)  / 'C312.1', 100, 100 /
          DATA      CODE(10),KNTM(10),KNTR(10) / 'C313.1', 100, 100 /
          DATA      CODE(11),KNTM(11),KNTR(11) / 'C336.1', 100, 100 /
          DATA      CODE(12),KNTM(12),KNTR(12) / 'C337.1', 100, 100 /
          DATA      CODE(13),KNTM(13),KNTR(13) / 'C341.1', 100, 100 /
          DATA      CODE(14),KNTM(14),KNTR(14) / 'D103.1', 100, 100 /
          DATA      CODE(15),KNTM(15),KNTR(15) / 'D106.1', 100, 100 /
          DATA      CODE(16),KNTM(16),KNTR(16) / 'D209.1', 100, 100 /
          DATA      CODE(17),KNTM(17),KNTR(17) / 'D509.1', 100, 100 /
          DATA      CODE(18),KNTM(18),KNTR(18) / 'E100.1', 100, 100 /
          DATA      CODE(19),KNTM(19),KNTR(19) / 'E104.1', 100, 100 /
          DATA      CODE(20),KNTM(20),KNTR(20) / 'E105.1', 100, 100 /
          DATA      CODE(21),KNTM(21),KNTR(21) / 'E208.1', 100, 100 /
          DATA      CODE(22),KNTM(22),KNTR(22) / 'E208.2', 100, 100 /
          DATA      CODE(23),KNTM(23),KNTR(23) / 'F010.1', 100,   0 /
          DATA      CODE(24),KNTM(24),KNTR(24) / 'F011.1', 100,   0 /
          DATA      CODE(25),KNTM(25),KNTR(25) / 'F012.1', 100,   0 /
          DATA      CODE(26),KNTM(26),KNTR(26) / 'F406.1', 100,   0 /
          DATA      CODE(27),KNTM(27),KNTR(27) / 'G100.1', 100, 100 /
          DATA      CODE(28),KNTM(28),KNTR(28) / 'G100.2', 100, 100 /
          LOGF  =  LGFILE
          IF(ERCODE .EQ. ' ')  THEN
             L  =  0
          ELSE
             DO 10  L = 1, 6
                IF(ERCODE(1:L) .EQ. ERCODE)  GOTO 12
  10            CONTINUE
  12         CONTINUE
          ENDIF
          DO 14     I  =  1, KOUNTE
             IF(L .EQ. 0)  GOTO 13
             IF(CODE(I)(1:L) .NE. ERCODE(1:L))  GOTO 14
  13         KNTM(I)  =  LIMITM
             KNTR(I)  =  LIMITR
  14         CONTINUE
          RETURN
          ENTRY KERMTR(ERCODE,LOG,MFLAG,RFLAG)
          LOG  =  LOGF
          DO 20     I  =  1, KOUNTE
             IF(ERCODE .EQ. CODE(I))  GOTO 21
  20         CONTINUE
          WRITE(*,1000)  ERCODE
          CALL ABEND
          RETURN
  21      RFLAG  =  KNTR(I) .GE. 1
          IF(RFLAG  .AND.  (KNTR(I) .LT. 100))  KNTR(I)  =  KNTR(I) - 1
          MFLAG  =  KNTM(I) .GE. 1
          IF(MFLAG  .AND.  (KNTM(I) .LT. 100))  KNTM(I)  =  KNTM(I) - 1
          IF(.NOT. RFLAG)  THEN
             IF(LOGF .LT. 1)  THEN
                WRITE(*,1001)  CODE(I)
             ELSE
                WRITE(LOGF,1001)  CODE(I)
             ENDIF
          ENDIF
          IF(MFLAG .AND. RFLAG)  THEN
             IF(LOGF .LT. 1)  THEN
                WRITE(*,1002)  CODE(I)
             ELSE
                WRITE(LOGF,1002)  CODE(I)
             ENDIF
          ENDIF
          RETURN
1000      FORMAT(' KERNLIB LIBRARY ERROR. ' /
     +           ' ERROR CODE ',A6,' NOT RECOGNIZED BY KERMTR',
     +           ' ERROR MONITOR. RUN ABORTED.')
1001      FORMAT(/' ***** RUN TERMINATED BY CERN LIBRARY ERROR ',
     +           'CONDITION ',A6)
1002      FORMAT(/' ***** CERN LIBRARY ERROR CONDITION ',A6)
          END
      SUBROUTINE ABEND
C
C CERN PROGLIB# Z035    ABEND           .VERSION KERNVAX  1.10  811126

      STOP '*** ABEND ***'
      END


SUBROUTINE GaussSeidelARRAYback(x,b,GridLevel,GhostGridX,GhostGridY,GhostGridZ, alpha, beta, gamma)
! By Allan P. Engsig-Karup.
!
! Tailored routine to apply the Gauss-Seidel method explicitly
! for solving A x = b
!
! FIXME: IMPLEMENT FOR 2D YZ PROBLEMS, AND 3D
!
USE Precision
USE Constants
USE DataTypes
IMPLICIT NONE
INTEGER :: GhostGridX,GhostGridY,GhostGridZ, i, j, k, Gidx, alpha, beta, gamma, diff, qqq
INTEGER :: Nz
TYPE (Level_def), INTENT(IN) :: GridLevel ! Grid information, stencils, etc.
REAL(KIND=long), DIMENSION(GridLevel%Nx*GridLevel%Ny*(GridLevel%Nz+GhostGridZ)), INTENT(INOUT) :: x
REAL(KIND=long), DIMENSION(GridLevel%Nx*GridLevel%Ny*(GridLevel%Nz+GhostGridZ)), INTENT(IN) :: b
REAL(KIND=long) :: diagcoef, coef, ddpdxx, ddpdyy, ddpdss, dpds, ddpdsdx, ddpdsdy, dpdx, dpdy, rhs
REAL(KIND=long) :: tmpstencil8(8), tmpstencil2(2), STENCILX(2), STENCILY(2)
INTEGER, DIMENSION(3) :: idx, tmpidx

DO i = -1, 1
	idx(i+2) = i
END DO

Nz = GridLevel%Nz+GhostGridZ

IF (GridLevel%Ny==1) THEN
  ! UPDATE FREE SURFACE VALUES
  k = Nz
  j = 1
  DO i = 1, GridLevel%Nx
    x(GridLevel%FullRankStencilsNEW%Indexesnew(k,i,j,1)) = b(GridLevel%FullRankStencilsNEW%Indexesnew(k,i,j,1))
  END DO

  j = 1
  ! Then update interior points above ghost layer and below free surface
  DO i = 1, GridLevel%Nx
    STENCILX = GridLevel%FullRankStencilsNEW%StencilX(i,2:3,2)
	DO k = 2, Nz-1 ! ONLY INTERIOR POINTS IN DOMAIN ARE UPDATED
	  ! UPDATE TRANSFORMED LAPLACE EQUATIONS - DIAGONAL TERM NOT INCLUDED
	  ! ASSUMED FIRST ORDER STENCIL IN EACH CARTESIAN DIRECTION -> r^2 = 3*3 = 9
      ddpdxx  = DOT_PRODUCT(STENCILX , x(GridLevel%FullRankStencilsNEW%IndexesX(k,i,j,2:3)) )
	  ddpdss  = DOT_PRODUCT(GridLevel%FullRankStencilsNEW%StencilZ(k,2:3,2) , &
	            x(GridLevel%FullRankStencilsNEW%IndexesZ(k,i,j,2:3)) )
	  dpds    = DOT_PRODUCT(GridLevel%FullRankStencilsNEW%StencilZ(k,2:3,1) , &
	            x(GridLevel%FullRankStencilsNEW%IndexesZ(k,i,j,2:3)) )
	  ddpdsdx = DOT_PRODUCT(GridLevel%FullRankStencilsNEW%StencilXZorYZnew(k,i,j,2:9,1) , &
	            x(GridLevel%FullRankStencilsNEW%Indexesnew(k,i,j,2:9)) )
	  rhs     = ddpdxx + GridLevel%dsigmanew(k,i,j,3)*dpds + two*(GridLevel%dsigmanew(k,i,j,2)*ddpdsdx ) + &
	            (GridLevel%dsigmanew(k,i,j,2)**2+GridLevel%dsigmanew(k,i,j,5)**2)*ddpdss
	  diagcoef = GridLevel%FullRankStencilsNEW%StencilX(i,1,2) + &
	            GridLevel%dsigmanew(k,i,j,3)*GridLevel%FullRankStencilsNEW%StencilZ(k,1,1) + &
				two*(GridLevel%dsigmanew(k,i,j,2)*GridLevel%FullRankStencilsNEW%StencilXZorYZnew(k,i,j,1,1) ) + &
				(GridLevel%dsigmanew(k,i,j,2)**2+GridLevel%dsigmanew(k,i,j,5)**2)*GridLevel%FullRankStencilsNEW%StencilZ(k,1,2)
	  x(GridLevel%FullRankStencilsNEW%Indexesnew(k,i,j,1)) = (-rhs + &
	            b(GridLevel%FullRankStencilsNEW%Indexesnew(k,i,j,1)) )/diagcoef
	END DO
  END DO

  ! UPDATE GHOST POINT VALUES
  ! AND SCALE WITH DIAGONAL VALUE TO RETURN GHOST POINT VALUES EXPLICITLY
  k = 1
  tmpstencil2 = GridLevel%DiffStencils%StencilZ(k+GhostGridZ,2:3,1) ! FOR dpds
  DO i = 1, GridLevel%Nx
    ! UPDATE GHOST POINT VALUES
    ! AND SCALE WITH DIAGONAL VALUE TO RETURN GHOST POINT VALUES EXPLICITLY
    coef = GridLevel%dsigmanew(k,i,j,5) + GridLevel%hx(i,j)*GridLevel%dsigmanew(k,i,j,2)
    diagcoef = coef*GridLevel%DiffStencils%StencilZ(k+GhostGridZ,1,1) ! diagonal coefficient for the ghost point in kinematic boundary condition
    dpds = DOT_PRODUCT( tmpstencil2 , x(GridLevel%FullRankStencilsNEW%IndexesZ(k,i,j,2:3)) ) ! ASSUMED 3-POINT STENCIL HERE (SINCE IT IS LOW-ORDER)
    dpdx = DOT_PRODUCT( GridLevel%FullRankStencilsNEW%StencilX(i,2:3,1) , &
	       x(GridLevel%FullRankStencilsNEW%IndexesX(k+GhostGridZ,i,j,2:3)) )
	x(GridLevel%FullRankStencilsNEW%Indexesnew(k,i,j,1)) = -( coef*dpds+GridLevel%hx(i,j)*dpdx - &
	       b(GridLevel%FullRankStencilsNEW%Indexesnew(k,i,j,1))) / diagcoef
  END DO

ELSE IF (GridLevel%Nx==1) THEN
  ! UPDATE FREE SURFACE VALUES
  k = Nz
  i = 1
  DO j = 1, GridLevel%Ny
    x(GridLevel%FullRankStencilsNEW%Indexesnew(k,i,j,1)) = b(GridLevel%FullRankStencilsNEW%Indexesnew(k,i,j,1))
  END DO

  i = 1
  ! Then update interior points above ghost layer and below free surface
  DO j = 1, GridLevel%Ny
    STENCILY = GridLevel%FullRankStencilsNEW%StencilY(j,2:3,2)
	DO k = 2, Nz-1 ! ONLY INTERIOR POINTS IN DOMAIN ARE UPDATED
	  ! UPDATE TRANSFORMED LAPLACE EQUATIONS - DIAGONAL TERM NOT INCLUDED
	  ! ASSUMED FIRST ORDER STENCIL IN EACH CARTESIAN DIRECTION -> r^2 = 3*3 = 9
      ddpdyy  = DOT_PRODUCT(STENCILY , x(GridLevel%FullRankStencilsNEW%IndexesY(k,i,j,2:3)) )
	  ddpdss  = DOT_PRODUCT(GridLevel%FullRankStencilsNEW%StencilZ(k,2:3,2) , &
	            x(GridLevel%FullRankStencilsNEW%IndexesZ(k,i,j,2:3)) )
	  dpds    = DOT_PRODUCT(GridLevel%FullRankStencilsNEW%StencilZ(k,2:3,1) , &
	            x(GridLevel%FullRankStencilsNEW%IndexesZ(k,i,j,2:3)) )
	  ddpdsdy = DOT_PRODUCT(GridLevel%FullRankStencilsNEW%StencilXZorYZnew(k,i,j,2:9,2) , &
	            x(GridLevel%FullRankStencilsNEW%Indexesnew(k,i,j,2:9)) )
	  rhs     = ddpdyy + GridLevel%dsigmanew(k,i,j,3)*dpds + two*(GridLevel%dsigmanew(k,i,j,4)*ddpdsdy ) + &
	            (GridLevel%dsigmanew(k,i,j,4)**2+GridLevel%dsigmanew(k,i,j,5)**2)*ddpdss
	  diagcoef = GridLevel%FullRankStencilsNEW%StencilY(j,1,2) + &
	            GridLevel%dsigmanew(k,i,j,3)*GridLevel%FullRankStencilsNEW%StencilZ(k,1,1) + &
				two*(GridLevel%dsigmanew(k,i,j,4)*GridLevel%FullRankStencilsNEW%StencilXZorYZnew(k,i,j,1,2) ) + &
				(GridLevel%dsigmanew(k,i,j,4)**2+GridLevel%dsigmanew(k,i,j,5)**2)*GridLevel%FullRankStencilsNEW%StencilZ(k,1,2)
	  x(GridLevel%FullRankStencilsNEW%Indexesnew(k,i,j,1)) = (-rhs + &
	            b(GridLevel%FullRankStencilsNEW%Indexesnew(k,i,j,1)) )/diagcoef

!print*,'Gidx=',GridLevel%FullRankStencilsNEW%Indexesnew(k,i,j,1)
!print*,'ddpdyy=',ddpdyy
!print*,'stencilYY=',
!print*,'ddpdss=',ddpdss
!print*,'dpds=',dpds
!print*,'ddpdsdy=',ddpdsdy
!print*,'rhs=',rhs
!print*,'diagcoef=',diagcoef
!print*,'x(Gidx)=',x(GridLevel%FullRankStencilsNEW%Indexesnew(k,i,j,1))
!read*

	END DO
  END DO

  ! UPDATE GHOST POINT VALUES
  ! AND SCALE WITH DIAGONAL VALUE TO RETURN GHOST POINT VALUES EXPLICITLY
  k = 1
  tmpstencil2 = GridLevel%DiffStencils%StencilZ(k+GhostGridZ,2:3,1) ! FOR dpds
  DO j = 1, GridLevel%Ny
    ! UPDATE GHOST POINT VALUES
    ! AND SCALE WITH DIAGONAL VALUE TO RETURN GHOST POINT VALUES EXPLICITLY
    coef = GridLevel%dsigmanew(k,i,j,5) + GridLevel%hy(i,j)*GridLevel%dsigmanew(k,i,j,4)
    diagcoef = coef*GridLevel%DiffStencils%StencilZ(k+GhostGridZ,1,1) ! diagonal coefficient for the ghost point in kinematic boundary condition
    dpds = DOT_PRODUCT( tmpstencil2 , x(GridLevel%FullRankStencilsNEW%IndexesZ(k,i,j,2:3)) ) ! ASSUMED 3-POINT STENCIL HERE (SINCE IT IS LOW-ORDER)
    dpdy = DOT_PRODUCT( GridLevel%FullRankStencilsNEW%StencilY(j,2:3,1) , &
	       x(GridLevel%FullRankStencilsNEW%IndexesY(k+GhostGridZ,i,j,2:3)) )
	x(GridLevel%FullRankStencilsNEW%Indexesnew(k,i,j,1)) = -( coef*dpds+GridLevel%hy(i,j)*dpdy - &
	       b(GridLevel%FullRankStencilsNEW%Indexesnew(k,i,j,1))) / diagcoef
  END DO

ELSE ! 3D
  ! UPDATE FREE SURFACE VALUES
  k = Nz
  DO j = 1, GridLevel%Ny
    DO i = 1, GridLevel%Nx
      x(GridLevel%FullRankStencilsNEW%Indexesnew(k,i,j,1)) = b(GridLevel%FullRankStencilsNEW%Indexesnew(k,i,j,1))
    END DO
  END DO

  ! Then update interior points above ghost layer and below free surface
  DO j = 1, GridLevel%Ny
   STENCILY = GridLevel%FullRankStencilsNEW%StencilY(j,2:3,2)
   DO i = 1, GridLevel%Nx
    STENCILX = GridLevel%FullRankStencilsNEW%StencilX(i,2:3,2)
	DO k = 2, Nz-1 ! ONLY INTERIOR POINTS IN DOMAIN ARE UPDATED
	  ! UPDATE TRANSFORMED LAPLACE EQUATIONS - DIAGONAL TERM NOT INCLUDED
	  ! ASSUMED FIRST ORDER STENCIL IN EACH CARTESIAN DIRECTION -> r^2 = 3*3 = 9
      ddpdxx  = DOT_PRODUCT(STENCILX , x(GridLevel%FullRankStencilsNEW%IndexesX(k,i,j,2:3)) )
      ddpdyy  = DOT_PRODUCT(STENCILY , x(GridLevel%FullRankStencilsNEW%IndexesY(k,i,j,2:3)) )
	  ddpdss  = DOT_PRODUCT(GridLevel%FullRankStencilsNEW%StencilZ(k,2:3,2) , &
	            x(GridLevel%FullRankStencilsNEW%IndexesZ(k,i,j,2:3)) )
	  dpds    = DOT_PRODUCT(GridLevel%FullRankStencilsNEW%StencilZ(k,2:3,1) , &
	            x(GridLevel%FullRankStencilsNEW%IndexesZ(k,i,j,2:3)) )
	  ddpdsdx = DOT_PRODUCT(GridLevel%FullRankStencilsNEW%StencilXZorYZnew(k,i,j,2:9,1) , &
	            x(GridLevel%FullRankStencilsNEW%IndexesnewXZ(k,i,j,2:9)) )
	  ddpdsdy = DOT_PRODUCT(GridLevel%FullRankStencilsNEW%StencilXZorYZnew(k,i,j,2:9,2) , &
	            x(GridLevel%FullRankStencilsNEW%IndexesnewYZ(k,i,j,2:9)) )
	  rhs     = ddpdxx + ddpdyy + GridLevel%dsigmanew(k,i,j,3)*dpds + two*(GridLevel%dsigmanew(k,i,j,2)*ddpdsdx + &
	            GridLevel%dsigmanew(k,i,j,4)*ddpdsdy ) + (GridLevel%dsigmanew(k,i,j,2)**2+&
				GridLevel%dsigmanew(k,i,j,4)**2+GridLevel%dsigmanew(k,i,j,5)**2)*ddpdss
	  diagcoef = GridLevel%FullRankStencilsNEW%StencilX(i,1,2) + GridLevel%FullRankStencilsNEW%StencilY(j,1,2) + &
	            GridLevel%dsigmanew(k,i,j,3)*GridLevel%FullRankStencilsNEW%StencilZ(k,1,1) + &
				two*(GridLevel%dsigmanew(k,i,j,2)*GridLevel%FullRankStencilsNEW%StencilXZorYZnew(k,i,j,1,1)+&
				GridLevel%dsigmanew(k,i,j,4)*GridLevel%FullRankStencilsNEW%StencilXZorYZnew(k,i,j,1,2) ) + &
				(GridLevel%dsigmanew(k,i,j,2)**2+GridLevel%dsigmanew(k,i,j,4)**2+&
				GridLevel%dsigmanew(k,i,j,5)**2)*GridLevel%FullRankStencilsNEW%StencilZ(k,1,2) ! FIXME: always constant on each grid!
	  x(GridLevel%FullRankStencilsNEW%Indexesnew(k,i,j,1)) = (-rhs + &
	            b(GridLevel%FullRankStencilsNEW%Indexesnew(k,i,j,1)) )/diagcoef
	END DO
   END DO
  END DO

  ! UPDATE GHOST POINT VALUES
  ! AND SCALE WITH DIAGONAL VALUE TO RETURN GHOST POINT VALUES EXPLICITLY
  k = 1
  tmpstencil2 = GridLevel%DiffStencils%StencilZ(k+GhostGridZ,2:3,1) ! FOR dpds
  DO j = 1, GridLevel%Ny
   STENCILY = GridLevel%FullRankStencilsNEW%StencilY(j,2:3,1)
   DO i = 1, GridLevel%Nx
    ! UPDATE GHOST POINT VALUES
    ! AND SCALE WITH DIAGONAL VALUE TO RETURN GHOST POINT VALUES EXPLICITLY
    coef = GridLevel%dsigmanew(k,i,j,5) + GridLevel%hx(i,j)*GridLevel%dsigmanew(k,i,j,2) + &
	       GridLevel%hy(i,j)*GridLevel%dsigmanew(k,i,j,4)
    diagcoef = coef*GridLevel%DiffStencils%StencilZ(k+GhostGridZ,1,1) ! diagonal coefficient for the ghost point in kinematic boundary condition
    dpds = DOT_PRODUCT( tmpstencil2 , x(GridLevel%FullRankStencilsNEW%IndexesZ(k,i,j,2:3)) ) ! ASSUMED 3-POINT STENCIL HERE (SINCE IT IS LOW-ORDER)
    dpdx = DOT_PRODUCT( GridLevel%FullRankStencilsNEW%StencilX(i,2:3,1) , &
	        x(GridLevel%FullRankStencilsNEW%IndexesX(k+GhostGridZ,i,j,2:3)) )
    dpdy = DOT_PRODUCT( STENCILY , x(GridLevel%FullRankStencilsNEW%IndexesY(k+GhostGridZ,i,j,2:3)) )
	x(GridLevel%FullRankStencilsNEW%Indexesnew(k,i,j,1)) = -( coef*dpds+GridLevel%hx(i,j)*dpdx+GridLevel%hy(i,j)*dpdy - &
	       b(GridLevel%FullRankStencilsNEW%Indexesnew(k,i,j,1))) / diagcoef
   END DO
  END DO

ENDIF

END SUBROUTINE GaussSeidelARRAYback


	FUNCTION DISMOD(H0,Q0,Z)

c	Returns cosmological distance modulus

c	H0 = Ho in km/sec/Mpc
c	Q0 = qo
c	DL = Luminosity distance in Mpc

	dismod = 5*alog10(dl(h0,q0,z)*1.E6/10.)

	return
	end


!=======================================================================
   SUBROUTINE bhwf(n, l, z, coef)
!=======================================================================
!
!  computes the spline expansion coefficients for hydrogenic radial
!  function for quantum numbers (n,l) and effective nuclear charge z.
!
!  SUBROUTINES called:
!       vhwf, vinty, and dpbsl (from LINPACK)
!
!  Calling sequence:
!
!            bhwf
!           ------
!          /  |   \
!       vhwf vinty dpbsl
!        ||        /   \
!       hnorm    daxpy ddot
!
!-----------------------------------------------------------------------
!
!   on entry
!   --------
!       n,l     orbital quantum numbers
!       z       effective nuclear charge
!
!   on exit
!   -------
!       coef    the spline coefficients defining the expansion of
!               the radial function P(nl;r)
!
!-----------------------------------------------------------------------

      USE spline_param
      USE spline_grid
      USE spline_galerkin

      IMPLICIT NONE

      INTEGER, INTENT(IN) :: n, l
      REAL(KIND=8), INTENT(IN) :: z
      REAL(KIND=8), DIMENSION(ns), INTENT(OUT) :: coef

      ! .. Local variables

      INTEGER :: m, ierr
      REAL(8), DIMENSION(nv, ks) :: yr, bsl(ks, ns)

      ! .. obtain the values of the radial function
      !    at all the gaussian points
      ! .. and multiply by the gaussian weights

      do m = 1, ks

         CALL vhwf(n, l, z, nv, gr(1, m), yr(1, m))

         yr(:, m) = yr(:, m)*grw(:, m)

      end do

      ! .. form the vector of inner products of the radial function and the
      ! .. spline basis functions

      CALL vinty(yr, coef)

      ! .. apply the boundary condition at the origin

      Call zfacsb(bsl, l)

      coef(1:l + 1) = 0.d0

      ! .. solve the system of equations bs coef = vy for coef

      Call dpbtrs('U', ns, ks - 1, 1, bsl, ks, coef, ns, ierr)
      if (ierr .ne. 0) Stop 'bhwf:  dpbtrs (LAPACK) failed'

   END SUBROUTINE bhwf

!====================================================================
   SUBROUTINE zfacsb(bsl, l)
!====================================================================
!
!   Sets up the overlap bs which is a transpose of sb, <B_i,B_j>,
!   with the correct boundary condition at r=0 and factorizes bs.
!
!   SUBROUTINES called:
!       dpbfa (from LINPACK)
!
!--------------------------------------------------------------------

      USE spline_param
      USE spline_galerkin

      IMPLICIT NONE

      INTEGER, INTENT(in) :: l
      REAL(KIND=8), DIMENSION(ks, ns), INTENT(out) :: bsl

      ! .. local variables

      INTEGER :: i, j, ierr

      ! .. copy the array, converting to row oriented band storage mode

      bsl = TRANSPOSE(sb)

      ! .. apply boundary condition at r=0

      do i = 1, l + 1
         bsl(ks, i) = 1.d0
         do j = 1, ks - 1
            bsl(j, ks - j + i) = 0.d0
         end do
      end do

!    CALL dpbfa(bsl,ks,ns,ks-1,ierr)
!    if (ierr /= 0 ) STOP 'facsb: dpbfa (LINPACK) failed'

      Call DPBTRF('U', ns, ks - 1, bsl, ks, ierr)
      if (ierr .ne. 0) Stop 'facsb: dpbtrf (LAPACK) failed'

   END SUBROUTINE zfacsb

!=======================================================================
   SUBROUTINE vhwf(n, l, z, nr, r, vh)
!=======================================================================
!
!   This program returns the vector of values, vh(i), of a normalized
!   hydrogenic function with nuclear charge z and quantum numbers (n,l)
!   at values of the radius, r(i),  i=1,nr.
!
!   Calls:  hnorm
!
!-----------------------------------------------------------------------
!
!   on entry
!   --------
!       n     principal quantum number
!       l     angular quantum number
!       z     Nuclear charge
!       nr    number of points in the vector
!       r     values at which radial function is to be evaluated, in
!             increasing order
!
!   on exit
!   -------
!       vh    values of the hydrogenic radial functions
!
!-----------------------------------------------------------------------

      IMPLICIT NONE

      INTEGER, INTENT(IN) :: n, l, nr
      REAL(KIND=8), INTENT(IN) :: z
      REAL(KIND=8), DIMENSION(nr), INTENT(IN) :: r
      REAL(KIND=8), DIMENSION(nr), INTENT(OUT) :: vh

      ! .. Local variables

      INTEGER :: k, i, nm
      REAL(KIND=8) :: a, b, c, factor
      REAL(KIND=8), DIMENSION(nr) :: w, p
      REAL(KIND=8), EXTERNAL :: hnorm

      k = n - l - 1
      if (k .lt. 0) Stop ' vhwf:  n < l+1 '

      factor = hnorm(n, l, z)       ! .. gets the normalization 'factor'

      w = -2.D0*z*r/n  ! .. store the argument of the exponential factor

      ! .. to avoid underlow, determine point at which function will be zero
      ! .. Note that exp(-150) = 0.7175 10**-65

      nm = nr
      do
         if (w(nm) < -150.D0 .AND. nm /= -1) then
            vh(nm) = 0.D0
            nm = nm - 1
         else
            EXIT
         end if
      end do

      ! .. Initialize the recurrence relation for each value of r(i)

      p(1:nm) = 1.D0

      a = 1.D0
      b = k
      c = n + l

      ! .. Apply the recurrence relation when k is positive

      do i = 1, k
         p(1:nm) = 1.D0 + a/b*p(1:nm)/c*w(1:nm)
         a = a + 1.D0
         b = b - 1.D0
         c = c - 1.D0
      end do

      ! .. Multiply the factor by the exponential

      vh(1:nm) = factor*p(1:nm)*EXP(w(1:nm)/2.D0)*(-w(1:nm))**(l + 1)

   END SUBROUTINE vhwf

!====================================================================
   FUNCTION hnorm(n, l, Z)
!====================================================================
!
!   returns the value of the normalization constant for an
!   hydrogenic function with nuclear charge z, and orbital
!   quantum numbers (n,l)
!
!--------------------------------------------------------------------

      IMPLICIT NONE

      REAL(KIND=8) :: hnorm
      INTEGER, INTENT(in) :: n, l
      REAL(KIND=8), INTENT(in) :: z

      ! .. local variables

      INTEGER :: m, i
      REAL(KIND=8) :: a, b, d, t

      m = l + l + 1
      a = n + l
      b = m
      t = a
      d = b
      m = m - 1

      if (m > 0) then
         do i = 1, m
            a = a - 1.d0
            b = b - 1.d0
            t = t*a
            d = d*b
         end do
      end if

      hnorm = SQRT(z*t)/(n*d)

   END FUNCTION hnorm


	SUBROUTINE IM_NCDF  ( imgfil, iret )
C************************************************************************
C* IM_NCDF								*
C*									*
C* This subroutine reads the header information from an AWIPS style	*
C* NetCDF file, and sets the navigation.				*
C*									*
C* IM_NCDF  ( IMGFIL, IRET )						*
C*									*
C* Input parameters:							*
C*	IMGFIL		CHAR*		Image file			*
C*									*
C* Output parameters:							*
C*	IRET		INTEGER		Return code			*
C*					  0 = normal return		*
C*					 -2 = Error opening/reading file*
C**									*
C* Log:									*
C* S. Jacobs/NCEP	 6/99	Created					*
C* R. Curtis		 8/00   Updated and implemented in GEMPAK       *
C* T. Piper/SAIC	07/06	Put () around -sign to eliminate warning*
C* S. Chiswell/Unidata	 9/06	Added check for qpesums grids		*
C************************************************************************
	INCLUDE		'GEMPRM.PRM'
	INCLUDE		'IMGDEF.CMN'
C*
	CHARACTER*(*)	imgfil
C*
	CHARACTER	filnam*160, proj*4
C------------------------------------------------------------------------
	iret = 0
C
C*	Add a NULL to the end of the file name.
C
	CALL ST_NULL ( imgfil, filnam, lenf, ier )
C
C*	Read the NetCDF header and get necessary information.
C
C*	See if this is a QPESUMS product
C
	CALL IM_RQPE ( filnam, imnpix, imnlin, imsorc, imtype,
     +			imdate, imtime, iproj, clat, clon,
     +			xll, xur, yll, yur, ier )
	IF ( ier .eq. 0 ) THEN
	    imradf = 1
	ELSE
	    CALL IM_RCDF ( filnam, imnpix, imnlin, imsorc, imtype,
     +			imdate, imtime, iproj, clat, clon,
     +			xll, xur, yll, yur, ier )
	    imradf = 0
	END IF
C
	IF  ( ier .ne. 0 )  THEN
	    iret = -2
	    RETURN
	END IF
C
C*	Set the remaining image definition common variables.
C
	imldat = imnpix * imnlin
	rmxysc = 1.0
	imdpth = 1
	imradf = 0
	imleft = 1
	imtop  = 1
	imrght = imnpix
	imbot  = imnlin
C
C*	Get the projection name from the NetCDF projection number.
C
	IF  ( iproj .eq. 1 )  THEN
C
C*      ***************************
C*      *** Polar Stereographic ***
C*      ***************************
C
	    proj  = 'STR'
	    angl1 = clat
	    angl2 = clon
	    angl3 = 0.0
C
C*	    Compute the lat/lon of the lower left point.
C
	    alat = RTD * ( HALFPI -
     +		     2 * ATAN ( SQRT ((xll*xll)+(yll*yll)) ) )
	    alon = clon + ( ATAN2 ( xll, -yll ) ) * RTD
	    CALL PRNLON ( 1, alon, ier )
C
C*	    Compute the lat/lon of the upper right point.
C
	    blat = RTD * ( HALFPI -
     +		     2 * ATAN ( SQRT ((xur*xur)+(yur*yur)) ) )
	    blon =  clon + ( ATAN2 ( xur, -yur ) ) * RTD
	    CALL PRNLON ( 1, blon, ier )

	ELSE IF (iproj .eq. 3 ) THEN
C
C*	    *************************
C*	    *** Lambert Conformal ***
C*	    *************************
C
	    IF ( clat .gt. 0.0 ) THEN
	        proj = 'LCC'
		sign = 1.0
	    ELSE
	        proj = 'SCC'
		sign = -1.0
	    ENDIF
	    angl1 = clat
	    angl2 = clon
	    angl3 = angl1
C
C*	    Compute the constant of the tangent cone.
C
C*	    Compute the co-latitude.
C
	    psi    = HALFPI -  ABS (clat) * DTR
C
C*	    The following assumes that standard latitude 1
C*		equals standard latitude 2.
C
	    ccone  = COS ( psi )
	    rearth = RADIUS / ccone
C
C*	    Compute the map corners.
C
	    xll = xll * rearth
	    xur = xur * rearth
	    yll = yll * rearth
	    yur = yur * rearth
C
C*          Compute the lat/lon of the lower left point.
C
	    alat = sign * (HALFPI - 2. * ATAN ( ( SQRT( (xll*xll) +
     +			(yll*yll) ) / rearth ) ** (1./ccone))) * RTD
	    alon = clon + (ATAN2 (xll,(-sign)*yll) * (1./ccone)) * RTD
	    CALL PRNLON (1, alon, ier)
C
C*          Compute the lat/lon of the upper right point.
C
	    blat = sign * (HALFPI - 2. * ATAN ( ( SQRT( (xur*xur) +
     +			(yur*yur) ) / rearth ) ** (1./ccone))) * RTD
	    blon = clon + (ATAN2 (xur,(-sign)*yur) * (1./ccone)) * RTD
	    CALL PRNLON (1, blon, ier)

	ELSE IF ( iproj .eq. 8 ) THEN
C
C*	    **************
C*	    *** LATLON ***
C*	    **************
C
	    proj = 'CED'
	    angl1 = 0.
	    angl2 = 0.
	    angl3 = 0.
	    alat = yll
	    alon = xll
	    blat = yur
	    blon = xur

	END IF
C
C*	Set the map projection.
C
	CALL GSMPRJ ( proj, angl1, angl2, angl3,
     +		      alat, alon, blat, blon, ier )
C*
	RETURN
	END