! RUN: %S/test_errors.sh %s %t %flang_fc1
! Fortran syntax considers signed int literals in complex literals
! to be a distinct production, not an application of unary +/- to
! an unsigned int literal, so they're used here to test overflow
! on signed int literal constants.  The literals are tested here
! as part of expressions that name resolution must analyze.

complex, parameter :: okj1 = 127_1, okz1 = (+127_1, -128_1)
!ERROR: Integer literal is too large for INTEGER(KIND=1)
complex, parameter :: badj1 = 128_1
!ERROR: Integer literal is too large for INTEGER(KIND=1)
complex, parameter :: badz1 = (+128_1, 0)
complex, parameter :: okj1a = 128_2
complex, parameter :: okz1a = (+128_2, 0)

complex, parameter :: okj2 = 32767_2, okz2 = (+32767_2, -32768_2)
!ERROR: Integer literal is too large for INTEGER(KIND=2)
complex, parameter :: badj2 = 32768_2
!ERROR: Integer literal is too large for INTEGER(KIND=2)
complex, parameter :: badz2 = (+32768_2, 0)
complex, parameter :: okj2a = 32768_4
complex, parameter :: okz2a = (+32768_4, 0)

complex, parameter :: okj4 = 2147483647_4, okz4 = (+2147483647_4, -2147483648_4)
!ERROR: Integer literal is too large for INTEGER(KIND=4)
complex, parameter :: badj4 = 2147483648_4
!ERROR: Integer literal is too large for INTEGER(KIND=4)
complex, parameter :: badz4 = (+2147483648_4, 0)
complex, parameter :: okj4a = 2147483648_8
complex, parameter :: okz4a = (+2147483648_8, 0)

complex, parameter :: okj4d = 2147483647, okz4d = (+2147483647, -2147483648)
!WARNING: Integer literal is too large for default INTEGER(KIND=4); assuming INTEGER(KIND=8)
complex, parameter :: badj4dext = 2147483648
!WARNING: Integer literal is too large for default INTEGER(KIND=4); assuming INTEGER(KIND=8)
complex, parameter :: badz4dext = (+2147483648, 0)

complex, parameter :: okj8 = 9223372036854775807_8, okz8 = (+9223372036854775807_8, -9223372036854775808_8)
!ERROR: Integer literal is too large for INTEGER(KIND=8)
complex, parameter :: badj8 = 9223372036854775808_8
!ERROR: Integer literal is too large for INTEGER(KIND=8)
complex, parameter :: badz8 = (+9223372036854775808_8, 0)
complex, parameter :: okj8a = 9223372036854775808_16
complex, parameter :: okz8a = (+9223372036854775808_16, 0)

complex, parameter :: okj16 = 170141183460469231731687303715884105727_16
complex, parameter :: okz16 = (+170141183460469231731687303715884105727_16, -170141183460469231731687303715884105728_16)
!ERROR: Integer literal is too large for INTEGER(KIND=16)
complex, parameter :: badj16 = 170141183460469231731687303715884105728_16
!ERROR: Integer literal is too large for INTEGER(KIND=16)
complex, parameter :: badz16 = (+170141183460469231731687303715884105728_16, 0)

end


*DECK DROOTS
      SUBROUTINE DROOTS (NG, HMIN, JFLAG, X0, X1, G0, G1, GX, X, JROOT)
      INTEGER NG, JFLAG, JROOT
      DOUBLE PRECISION HMIN, X0, X1, G0, G1, GX, X
      DIMENSION G0(NG), G1(NG), GX(NG), JROOT(NG)
      INTEGER IOWND3, IMAX, LAST, IDUM3
      DOUBLE PRECISION ALPHA, X2, RDUM3
      COMMON /DLSR01/ ALPHA, X2, RDUM3(3),
     1   IOWND3(3), IMAX, LAST, IDUM3(4)
C-----------------------------------------------------------------------
C This subroutine finds the leftmost root of a set of arbitrary
C functions gi(x) (i = 1,...,NG) in an interval (X0,X1).  Only roots
C of odd multiplicity (i.e. changes of sign of the gi) are found.
C Here the sign of X1 - X0 is arbitrary, but is constant for a given
C problem, and -leftmost- means nearest to X0.
C The values of the vector-valued function g(x) = (gi, i=1...NG)
C are communicated through the call sequence of DROOTS.
C The method used is the Illinois algorithm.
C
C Reference:
C Kathie L. Hiebert and Lawrence F. Shampine, Implicitly Defined
C Output Points for Solutions of ODEs, Sandia Report SAND80-0180,
C February 1980.
C
C Description of parameters.
C
C NG     = number of functions gi, or the number of components of
C          the vector valued function g(x).  Input only.
C
C HMIN   = resolution parameter in X.  Input only.  When a root is
C          found, it is located only to within an error of HMIN in X.
C          Typically, HMIN should be set to something on the order of
C               100 * UROUND * MAX(ABS(X0),ABS(X1)),
C          where UROUND is the unit roundoff of the machine.
C
C JFLAG  = integer flag for input and output communication.
C
C          On input, set JFLAG = 0 on the first call for the problem,
C          and leave it unchanged until the problem is completed.
C          (The problem is completed when JFLAG .ge. 2 on return.)
C
C          On output, JFLAG has the following values and meanings:
C          JFLAG = 1 means DROOTS needs a value of g(x).  Set GX = g(X)
C                    and call DROOTS again.
C          JFLAG = 2 means a root has been found.  The root is
C                    at X, and GX contains g(X).  (Actually, X is the
C                    rightmost approximation to the root on an interval
C                    (X0,X1) of size HMIN or less.)
C          JFLAG = 3 means X = X1 is a root, with one or more of the gi
C                    being zero at X1 and no sign changes in (X0,X1).
C                    GX contains g(X) on output.
C          JFLAG = 4 means no roots (of odd multiplicity) were
C                    found in (X0,X1) (no sign changes).
C
C X0,X1  = endpoints of the interval where roots are sought.
C          X1 and X0 are input when JFLAG = 0 (first call), and
C          must be left unchanged between calls until the problem is
C          completed.  X0 and X1 must be distinct, but X1 - X0 may be
C          of either sign.  However, the notion of -left- and -right-
C          will be used to mean nearer to X0 or X1, respectively.
C          When JFLAG .ge. 2 on return, X0 and X1 are output, and
C          are the endpoints of the relevant interval.
C
C G0,G1  = arrays of length NG containing the vectors g(X0) and g(X1),
C          respectively.  When JFLAG = 0, G0 and G1 are input and
C          none of the G0(i) should be zero.
C          When JFLAG .ge. 2 on return, G0 and G1 are output.
C
C GX     = array of length NG containing g(X).  GX is input
C          when JFLAG = 1, and output when JFLAG .ge. 2.
C
C X      = independent variable value.  Output only.
C          When JFLAG = 1 on output, X is the point at which g(x)
C          is to be evaluated and loaded into GX.
C          When JFLAG = 2 or 3, X is the root.
C          When JFLAG = 4, X is the right endpoint of the interval, X1.
C
C JROOT  = integer array of length NG.  Output only.
C          When JFLAG = 2 or 3, JROOT indicates which components
C          of g(x) have a root at X.  JROOT(i) is 1 if the i-th
C          component has a root, and JROOT(i) = 0 otherwise.
C-----------------------------------------------------------------------
      INTEGER I, IMXOLD, NXLAST
      DOUBLE PRECISION T2, TMAX, ZERO
      LOGICAL ZROOT, SGNCHG, XROOT
      SAVE ZERO
      DATA ZERO/0.0D0/
C
      IF (JFLAG .EQ. 1) GO TO 200
C JFLAG .ne. 1.  Check for change in sign of g or zero at X1. ----------
      IMAX = 0
      TMAX = ZERO
      ZROOT = .FALSE.
      DO 120 I = 1,NG
        IF (ABS(G1(I)) .GT. ZERO) GO TO 110
        ZROOT = .TRUE.
        GO TO 120
C At this point, G0(i) has been checked and cannot be zero. ------------
 110    IF (SIGN(1.0D0,G0(I)) .EQ. SIGN(1.0D0,G1(I))) GO TO 120
          T2 = ABS(G1(I)/(G1(I)-G0(I)))
          IF (T2 .LE. TMAX) GO TO 120
            TMAX = T2
            IMAX = I
 120    CONTINUE
      IF (IMAX .GT. 0) GO TO 130
      SGNCHG = .FALSE.
      GO TO 140
 130  SGNCHG = .TRUE.
 140  IF (.NOT. SGNCHG) GO TO 400
C There is a sign change.  Find the first root in the interval. --------
      XROOT = .FALSE.
      NXLAST = 0
      LAST = 1
C
C Repeat until the first root in the interval is found.  Loop point. ---
 150  CONTINUE
      IF (XROOT) GO TO 300
      IF (NXLAST .EQ. LAST) GO TO 160
      ALPHA = 1.0D0
      GO TO 180
 160  IF (LAST .EQ. 0) GO TO 170
      ALPHA = 0.5D0*ALPHA
      GO TO 180
 170  ALPHA = 2.0D0*ALPHA
 180  X2 = X1 - (X1-X0)*G1(IMAX)/(G1(IMAX) - ALPHA*G0(IMAX))
      IF ((ABS(X2-X0) .LT. HMIN) .AND.
     1   (ABS(X1-X0) .GT. 10.0D0*HMIN)) X2 = X0 + 0.1D0*(X1-X0)
      JFLAG = 1
      X = X2
C Return to the calling routine to get a value of GX = g(X). -----------
      RETURN
C Check to see in which interval g changes sign. -----------------------
 200  IMXOLD = IMAX
      IMAX = 0
      TMAX = ZERO
      ZROOT = .FALSE.
      DO 220 I = 1,NG
        IF (ABS(GX(I)) .GT. ZERO) GO TO 210
        ZROOT = .TRUE.
        GO TO 220
C Neither G0(i) nor GX(i) can be zero at this point. -------------------
 210    IF (SIGN(1.0D0,G0(I)) .EQ. SIGN(1.0D0,GX(I))) GO TO 220
          T2 = ABS(GX(I)/(GX(I) - G0(I)))
          IF (T2 .LE. TMAX) GO TO 220
            TMAX = T2
            IMAX = I
 220    CONTINUE
      IF (IMAX .GT. 0) GO TO 230
      SGNCHG = .FALSE.
      IMAX = IMXOLD
      GO TO 240
 230  SGNCHG = .TRUE.
 240  NXLAST = LAST
      IF (.NOT. SGNCHG) GO TO 250
C Sign change between X0 and X2, so replace X1 with X2. ----------------
      X1 = X2
      CALL DCOPY (NG, GX, 1, G1, 1)
      LAST = 1
      XROOT = .FALSE.
      GO TO 270
 250  IF (.NOT. ZROOT) GO TO 260
C Zero value at X2 and no sign change in (X0,X2), so X2 is a root. -----
      X1 = X2
      CALL DCOPY (NG, GX, 1, G1, 1)
      XROOT = .TRUE.
      GO TO 270
C No sign change between X0 and X2.  Replace X0 with X2. ---------------
 260  CONTINUE
      CALL DCOPY (NG, GX, 1, G0, 1)
      X0 = X2
      LAST = 0
      XROOT = .FALSE.
 270  IF (ABS(X1-X0) .LE. HMIN) XROOT = .TRUE.
      GO TO 150
C
C Return with X1 as the root.  Set JROOT.  Set X = X1 and GX = G1. -----
 300  JFLAG = 2
      X = X1
      CALL DCOPY (NG, G1, 1, GX, 1)
      DO 320 I = 1,NG
        JROOT(I) = 0
        IF (ABS(G1(I)) .GT. ZERO) GO TO 310
          JROOT(I) = 1
          GO TO 320
 310    IF (SIGN(1.0D0,G0(I)) .NE. SIGN(1.0D0,G1(I))) JROOT(I) = 1
 320    CONTINUE
      RETURN
C
C No sign change in the interval.  Check for zero at right endpoint. ---
 400  IF (.NOT. ZROOT) GO TO 420
C
C Zero value at X1 and no sign change in (X0,X1).  Return JFLAG = 3. ---
      X = X1
      CALL DCOPY (NG, G1, 1, GX, 1)
      DO 410 I = 1,NG
        JROOT(I) = 0
        IF (ABS(G1(I)) .LE. ZERO) JROOT (I) = 1
 410  CONTINUE
      JFLAG = 3
      RETURN
C
C No sign changes in this interval.  Set X = X1, return JFLAG = 4. -----
 420  CALL DCOPY (NG, G1, 1, GX, 1)
      X = X1
      JFLAG = 4
      RETURN
C----------------------- End of Subroutine DROOTS ----------------------
      END


Module err_func

    Public erf

Contains

Pure Function erf(x) Result(fn_val)
!-----------------------------------------------------------------------
!             EVALUATION OF THE REAL ERROR FUNCTION
! Based upon a Fortran 66 routine in the Naval Surface Warfare Center's
! Mathematics Library (1993 version).
! Adapted by Alan.Miller @ vic.cmis.csiro.au
! Adapted for DIM by Seth Morton
!-----------------------------------------------------------------------
!    use constants
    Implicit None
#include "dimqm_constants.fh"
    Real (KINDR), Intent(In) :: x
    Real (KINDR)             :: fn_val

!   Local variables
    Real (KINDR), Parameter :: c = .564189583547756_KINDR
    Real (KINDR), Parameter ::  &
        a(5) = (/ .771058495001320E-04_KINDR, -.133733772997339E-02_KINDR,    &
                  .323076579225834E-01_KINDR,  .479137145607681E-01_KINDR,    &
                  .128379167095513E+00_KINDR /),                              &
        b(3) = (/ .301048631703895E-02_KINDR,  .538971687740286E-01_KINDR,    &
                  .375795757275549E+00_KINDR /),                              &
        p(8) = (/ -1.36864857382717E-07_KINDR, 5.64195517478974E-01_KINDR,    &
                   7.21175825088309E+00_KINDR, 4.31622272220567E+01_KINDR,    &
                   1.52989285046940E+02_KINDR, 3.39320816734344E+02_KINDR,    &
                   4.51918953711873E+02_KINDR, 3.00459261020162E+02_KINDR /), &
        q(8) = (/  1.00000000000000E+00_KINDR, 1.27827273196294E+01_KINDR,    &
                   7.70001529352295E+01_KINDR, 2.77585444743988E+02_KINDR,    &
                   6.38980264465631E+02_KINDR, 9.31354094850610E+02_KINDR,    &
                   7.90950925327898E+02_KINDR, 3.00459260956983E+02_KINDR /), &
        r(5) = (/  2.10144126479064E+00_KINDR, 2.62370141675169E+01_KINDR,    &
                   2.13688200555087E+01_KINDR, 4.65807828718470E+00_KINDR,    &
                   2.82094791773523E-01_KINDR /),                             &
        s(4) = (/  9.41537750555460E+01_KINDR, 1.87114811799590E+02_KINDR,    &
                   9.90191814623914E+01_KINDR, 1.80124575948747E+01_KINDR /)
    Real (KINDR) :: ax, bot, t, top, x2

    ax = ABS(x)

    if (ax <= HALF) then
        t = x*x
        top = ((((a(1)*t + a(2))*t + a(3))*t + a(4))*t + a(5)) + ONE
        bot = ((b(1)*t + b(2))*t + b(3))*t + ONE
        fn_val = x*(top/bot)
        return
    end if

    if (ax <= FOUR) then
        top = ((((((p(1)*ax + p(2))*ax + p(3))*ax + p(4))*ax + p(5))*ax  &
            + p(6))*ax + p(7))*ax + p(8)
        bot = ((((((q(1)*ax + q(2))*ax + q(3))*ax + q(4))*ax + q(5))*ax  &
            + q(6))*ax + q(7))*ax + q(8)
        fn_val = HALF + (HALF - EXP(-x*x)*top/bot)
        if (x < ZERO) fn_val = -fn_val
        return
    end if

    if (ax < 5.8_KINDR) then
        x2 = x*x
        t = ONE / x2
        top = (((r(1)*t + r(2))*t + r(3))*t + r(4))*t + r(5)
        bot = (((s(1)*t + s(2))*t + s(3))*t + s(4))*t + ONE
        fn_val = (c - top/(x2*bot)) / ax
        fn_val = HALF + (HALF - EXP(-x2)*fn_val)
        if (x < ZERO) fn_val = -fn_val
        return
    end if

    fn_val = SIGN(ONE, x)
    return
End Function erf

End Module err_func


C++::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::
C       PROGRAM POTEN2
C
C  This program computes different triaxial models of elliptical
C  galaxies in the principal planes. Axis ratios :   X:P Y:Q Z:1.
C
C  PHI3(*,*,1),RHO3(*,*,1) : XY plane
C  PHI3(*,*,2),RHO3(*,*,2) : YZ plane
C  PHI3(*,*,3),RHO3(*,*,3) : ZX plane
C   To link with @SLINK1
C
C JLP
C Version 20-06-90
C--::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::
        PROGRAM POTEN2
	IMPLICIT DOUBLE PRECISION (A-H,O-Z)
	PARAMETER (IDIM=1000)
	PARAMETER (IDIM1=400)
	REAL*8 PHI3(0:IDIM1,0:IDIM1,3)
	REAL*8 RHO3(0:IDIM1,0:IDIM1,3)
	REAL*4 IMAGE(IDIM,IDIM)
	CHARACTER NAME*40,COMMENTS*80,ANS*1,AGAIN*1,TITLE*40
	COMMON/POT1/PI,QQ1,PP1,PASX1,PASY1,PASZ1,NPTS

	PI=3.14159265358979323846

10	FORMAT(A)

	PRINT 338
338	FORMAT(' PROGRAM POTEN2  -Version 20-06-90')

C Inquire the format :
	CALL INQUIFMT

	OPEN(1,FILE='poten2.log',STATUS='unknown',
     1	ACCESS='SEQUENTIAL')
	WRITE(1,338)
C---------------------------------------------------------------

80	PRINT 84
84	FORMAT(' MENU :',/,
     1	' 1,IPLANE: DE ZEEUW AND MERRIT (1983)',/,
     1	' 2,IPLANE: RICHSTONE (1981)',/,
     1	' 3,IPLANE: "PSEUDO-HUBBLE"',/,
c     1	' 4,IPLANE: KING',/,
     1	' 5,IPLANE: "PERFECT ELLIPSOID"',/,
     1	' 6,IPLANE: "PERFECT ELLIPSOID" (MODIFIED)',/,
     1	'    ( IPLANE=1 FOR XY, 2 FOR YZ AND 3 FOR ZX)',/,
     1	' ENTER THE NUMBERS YOU WANT : ',$)
	READ(5,*) IMODEL,IPLANE

	IF(IPLANE.GT.3.AND.IPLANE.LT.1) GO TO 80
C
C  Input of the parameters
C

	PRINT *,' NUMBER OF POINTS FOR THE IMAGES (LESS THAN 400)?'
	READ(5,*) NPTS
1000	WRITE (6,335)
335	FORMAT(' Enter P and Q   (P > Q) : ',$)
	READ (5,*) PP1,QQ1
	PRINT *,' ENTER PASX, PASY, PASZ :'
	READ(5,*) PASX1,PASY1,PASZ1

	WRITE(1,340),PP1,QQ1,PASX1,PASY1,PASZ1
340	FORMAT(4X,'P =',F8.3,'  Q =',F8.3,5X,'PASX, PASY, PASZ :',
     1	3(F9.3,2X),/)

C--------------------------------------------------------------------
C Schwarzschild's model

	IF(IMODEL.EQ.1)THEN
	WRITE(1,101)IPLANE
101	FORMAT(/,'********** SCHWARZSCHILD MODEL:*********',/,
     1	' IPLANE =',I3,/)
	CALL SCHWARZ(PHI3,RHO3,IPLANE)
	ENDIF

C--------------------------------------------------------------------
C Richstone's model

	IF(IMODEL.EQ.2)THEN
	WRITE(1,201)IPLANE
201	FORMAT(/,'********** RICHSTONE MODEL:*********',/,
     1	' IPLANE =',I3,/)
	WRITE(1,902)
902	FORMAT(9X,'I',13X,'J',14X,'PHI',9X,'RHO',/)
	CALL RICHSTONE(PHI3,RHO3,IPLANE)
	ENDIF

C-------------------------------------------------------------------
C Pseudo-Hubble model

	IF(IMODEL.EQ.3)THEN
	WRITE(1,301)IPLANE
301	FORMAT(/,'********** PSEUDO-HUBBLE MODEL:*********',/,
     1	' IPLANE =',I3,/)
	WRITE(1,902)
	CALL HUBBLE_3D(PHI3,RHO3,IPLANE)
	ENDIF

C------------------------------------------------------------------------------
C Computation of  King's model : not finished yet...
C
	IF(IMODEL.EQ.4)THEN
	WRITE(1,401)IPLANE
401	FORMAT(/,'********** KING MODEL:*********',/,
     1	' IPLANE =',I3,/)
	WRITE(1,902)
	CALL  KING_3D(PHI3,RHO3,IPLANE)
	ENDIF

C-------------------------------------------------------------------
C Perfect ellipsoid (Hernquist and Quinn 1986)

	IF(IMODEL.EQ.5)THEN
	WRITE(1,501)IPLANE
501	FORMAT(/,'****** PERFECT ELLIPSOID MODEL: *******',/,
     1	' IPLANE =',I3,/)
	CALL ELLIPSOID1_3D(PHI3,RHO3,IPLANE)
	ENDIF

C-------------------------------------------------------------------
C Modified perfect ellipsoid (Hernquist and Quinn 1986)

	IF(IMODEL.EQ.6)THEN
	WRITE(1,601)IPLANE
601	FORMAT(/,'*** MODIFIED PERFECT ELLIPSOID MODEL: ****',/,
     1	' IPLANE =',I3,/)
	CALL ELLIPSOID2_3D(PHI3,RHO3,IPLANE)
	ENDIF

C---------------------------------------------------------------------
C Now output of the images :

	NPL=2*NPTS+1
	NL=2*NPTS+1

900	PRINT 901
901	FORMAT(' SECOND MENU :',/,
     1	' 1 : STORING DENSITY IMAGE',/,
     1	' 2 : STORING POTENTIAL IMAGE',/,
     1	' 3 : RETURN TO THE FIRST MENU',/,
     1	' 10 : EXIT',/,
     1	' ENTER THE OPTION YOU WANT : ',$)
	READ(5,*) IOPT9

	IF(IOPT9.EQ.3)GO TO 80

C-------------------------------------------------------------------
C Storing the density images :
	IF(IOPT9.EQ.1) THEN
	PRINT *,' MULTIPLYING FACTOR  (FACT=1000. ?)'
	READ(5,10) FACT
	FACT=1.E+03
	CALL PLANE(RHO3,IMAGE,FACT,IPLANE)
        WRITE(6,*) 'Output density image: '
        READ(5,10) NAME
	COMMENTS=' '
	CALL JLP_WRITEIMAG(IMAGE,NPL,NL,IDIM,NAME,COMMENTS)
	GO TO 900
	ENDIF

C-------------------------------------------------------------------
C Storing the potential images :
	IF(IOPT9.EQ.2) THEN
	PRINT *,' MULTIPLYING FACTOR  (FACT=100. ?)'
	READ(5,10) FACT
	FACT=1.E+03
	CALL PLANE(PHI3,IMAGE,FACT,IPLANE)
        WRITE(6,*) 'Output potential image: '
        READ(5,10) NAME
	COMMENTS=' '
	CALL JLP_WRITEIMAG(IMAGE,NPL,NL,IDIM,NAME,COMMENTS)
	GO TO 900
	ENDIF

999	CLOSE(1)
	PRINT *,' Output in "poten2.log".'
	END
C------------------------------------------------------------------------
C
	SUBROUTINE PLANE(PHI3,IMAGE,FACT,IPLANE)
C****************************************************
C	Subroutine PLANE to create an image of the potential
C	or the density in the plane chosen by the user.
C	 If IPLANE=1 plane X,Y
C	 If IPLANE=2 plane Y,Z
C	 If IPLANE=3 plane Z,X
C
C********************************************************
	PARAMETER (IDIM=1000)
	PARAMETER (IDIM1=400)
	IMPLICIT DOUBLE PRECISION (A-H,O-Z)
	REAL*8 PHI3(0:IDIM1,0:IDIM1,3)
	REAL*4 IMAGE(IDIM,IDIM)
	COMMON/POT1/PI,QQ1,PP1,PASX1,PASY1,PASZ1,NPTS

C Loading the image :
	DO 101 IX=0,NPTS
	DO 101 IY=0,NPTS
	RRR=FACT*PHI3(IX,IY,IPLANE)

	IXX=NPTS+IX+1
	IYY=NPTS+IY+1
	IMAGE(IXX,IYY)=SNGL(RRR)
	IXX=NPTS-IX+1
	IYY=IY+NPTS+1
	IMAGE(IXX,IYY)=SNGL(RRR)
	IXX=NPTS-IX+1
	IYY=NPTS-IY+1
	IMAGE(IXX,IYY)=SNGL(RRR)
	IXX=NPTS+IX+1
	IYY=NPTS-IY+1
	IMAGE(IXX,IYY)=SNGL(RRR)

101	CONTINUE

	RETURN
	END
C***************************************************************
C	Subroutine RICHSTONE (Ap.J. 1984 281,100)
C**************************************************************
	SUBROUTINE RICHSTONE(PHI3,RHO3,IPLANE)
	PARAMETER (IDIM=1000)
	PARAMETER (IDIM1=400)
	IMPLICIT DOUBLE PRECISION (A-H,O-Z)
	REAL*8 PHI3(0:IDIM1,0:IDIM1,3)
	REAL*8 RHO3(0:IDIM1,0:IDIM1,3)
	COMMON/POT1/PI,QQ1,PP1,PASX1,PASY1,PASZ1,NPTS

	C1=1.D0+(1.D0/(PP1*PP1))+(1.D0/(QQ1*QQ1))

C XY PLANE --------------------------------------------------------
	IF(IPLANE.EQ.1)THEN
	PP=PP1
	QQ=QQ1
	PASX=PASX1
	PASY=PASY1
	ENDIF

C YZ PLANE --------------------------------------------------------
	IF(IPLANE.EQ.2)THEN
	PP=QQ1
	QQ=1.
	PASX=PASY1
	PASY=PASZ1
	ENDIF

C ZX PLANE --------------------------------------------------------
	IF(IPLANE.EQ.3)THEN
	PP=1.
	QQ=PP1
	PASX=PASZ1
	PASY=PASX1
	ENDIF

C Calculates some constants :

	PP2=PP*PP
	QQ2=QQ*QQ
	PP4=PP2*PP2
	QQ4=QQ2*QQ2

	DO 101 IX=0,NPTS
	X=FLOAT(IX)*PASX
	X2=X*X

	DO 101 IY=0,NPTS
	Y=FLOAT(IY)*PASY
	Y2=Y*Y

	S2=(X2/PP2)+(Y2/QQ2)

C Avoids trouble in the center :
	IF(S2.LT.4.) S2=4.
	S=DSQRT(S2)

	PHI3(IX,IY,IPLANE)=DLOG(S)
	RHO3(IX,IY,IPLANE)=(C1-(2.D0*((X2/PP4)+(Y2/QQ4))/S2))/S2

	IF(IY.EQ.0)THEN
	WRITE(1,342)X,Y,PHI3(IX,IY,IPLANE),RHO3(IX,IY,IPLANE)
	ENDIF
342	FORMAT(2X,2(F12.3,2X),4X,E12.5,4X,E12.5)

101	CONTINUE
	WRITE(1,343)
343	FORMAT(/)

	RETURN
	END
C*************************************************************************
C	SUBROUTINE SCHWARZSCHILD
C  This subroutine calculates Schwarzschild's model
C  of a triaxial galaxy using De Zeeuw and Merrit's approximation (1983)
C  on the principal planes
C  PHI3(*,*,1),RHO3(*,*,1) : XY plane
C  PHI3(*,*,2),RHO3(*,*,2) : YZ plane
C  PHI3(*,*,3),RHO3(*,*,3) : ZX plane
C:::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::
	SUBROUTINE SCHWARZ(PHI3,RHO3,IPLANE)
	PARAMETER (IDIM=1000)
	PARAMETER (IDIM1=400)
	IMPLICIT DOUBLE PRECISION (A-H,O-Z)
	REAL*8 PHI3(0:IDIM1,0:IDIM1,3)
	REAL*8 RHO3(0:IDIM1,0:IDIM1,3)
	COMMON/POT1/PI,QQ,PP,PASX,PASY,PASZ,NPTS

C Calculates C1 and C3

	PP2=PP*PP
	QQ2=QQ*QQ
	PP3=PP2*PP
	QQ3=QQ2*QQ
	ASYM2=2.D0*PP2*QQ2-PP2-QQ2
	SYM2=PP2*QQ2+PP2+QQ2
	SYM3=1.D0+PP3+QQ3

	D1=ASYM2/(14.D0*SYM2)
	D2=(1.D0-(3.D0/SYM3))/6.D0
	D3=(PP2-QQ2)/(28.D0*SYM2)
	D4=(PP3-QQ3)/(12.D0*SYM3)

C	C1=(4.D0/35.D0)*ASYM2/RRR
C	C3=(2.D0/35.D0)*(PP2-QQ2)/RRR

	C1=(D1**0.6)*(D2**0.4)
	C2=(D1/D2)**0.4
	C3=(D3**0.6)*(D4**0.4)
	C4=(D3/D4)**0.4

	WRITE(1,341) C1,C2,C3,C4
341	FORMAT(4X,'C1 =',E12.5,'   C2 =',E12.5,
     1	'  C3 =',E12.5,'   C4 =',E12.5,/,/,11X,'X',
     1	13X,'Y',13X,'Z',10X,'PHI3(X,Y,Z)',6X,'RHO3(X,Y,Z)',/)

C XY Plane ----------------------------------------------------------
	IF(IPLANE.EQ.1)THEN

	DO 101 IX=0,NPTS
	X=FLOAT(IX)*PASX
	X2=X*X

	DO 101 IY=0,NPTS
	Y=FLOAT(IY)*PASY
	Y2=Y*Y

	Z=0.D0
	Z2=0.D0

	RAD2=X2+Y2+Z2
	IF(RAD2.EQ.0.) RAD2=1.E-3
	RAD=DSQRT(RAD2)

C Calculating U, V and W

	URAD=(-1.D0/RAD)*DLOG(RAD+DSQRT(1+RAD2))+1.D0
	VRAD=(-1.D0*C1*RAD2)/((1.D0+C2*RAD2)**1.5)
	WRAD=(-1.D0*C3*RAD2)/((1.D0+C4*RAD2)**1.5)

	FRAD=1.D0/((1.D0+RAD2)**1.5)
	GRAD=3.D0*C1*C2*(7.D0+2.D0*C2*RAD2)*RAD2/
     1	((1.D0+C2*RAD2)**3.5)
	HRAD=3.D0*C3*C4*(7.D0+2.D0*C4*RAD2)*RAD2/
     1	((1.D0+C4*RAD2)**3.5)

	AA=(2.D0*Z2-X2-Y2)/(2.D0*RAD2)
	BB=3.D0*(X2-Y2)/RAD2

C
	PHI3(IX,IY,1)=URAD-AA*VRAD+BB*WRAD
	RHO3(IX,IY,1)=FRAD-AA*GRAD+BB*HRAD

	IF(IY.EQ.0)THEN
	WRITE(1,342)X,Y,Z,PHI3(IX,IY,1),RHO3(IX,IY,1)
	ENDIF
342	FORMAT(2X,3(F12.3,2X),4X,E12.5,4X,E12.5)

101	CONTINUE
	WRITE(1,343)
343	FORMAT(/)
	RETURN
	ENDIF

C YZ Plane ----------------------------------------------------------
	IF(IPLANE.EQ.2)THEN

	DO 102 IY=0,NPTS
	Y=FLOAT(IY)*PASY
	Y2=Y*Y

	DO 102 IZ=0,NPTS
	Z=FLOAT(IZ)*PASZ
	Z2=Z*Z

	X=0.D0
	X2=0.D0
	RAD2=X2+Y2+Z2
	IF(RAD2.EQ.0.) RAD2=1.E-3
	RAD=DSQRT(RAD2)

C Calculating U, V and W

	URAD=(-1.D0/RAD)*DLOG(RAD+DSQRT(1+RAD2))+1.D0
	VRAD=(-1.D0*C1*RAD2)/((1.D0+C2*RAD2)**1.5)
	WRAD=(-1.D0*C3*RAD2)/((1.D0+C4*RAD2)**1.5)

	FRAD=1.D0/((1.D0+RAD2)**1.5)
	GRAD=3.D0*C1*C2*(7.D0+2.D0*C2*RAD2)*RAD2/
     1	((1.D0+C2*RAD2)**3.5)
	HRAD=3.D0*C3*C4*(7.D0+2.D0*C4*RAD2)*RAD2/
     1	((1.D0+C4*RAD2)**3.5)

	AA=(2.D0*Z2-X2-Y2)/(2.D0*RAD2)
	BB=3.D0*(X2-Y2)/RAD2

C
	PHI3(IY,IZ,2)=URAD-AA*VRAD+BB*WRAD
	RHO3(IY,IZ,2)=FRAD-AA*GRAD+BB*HRAD

	IF(IZ.EQ.0)THEN
	WRITE(1,342)X,Y,Z,PHI3(IY,IZ,2),RHO3(IY,IZ,2)
	ENDIF

102	CONTINUE
	WRITE(1,343)
	RETURN
	ENDIF

C ZX Plane ---------------------------------------------------------
C
	IF(IPLANE.EQ.3)THEN

	DO 103 IZ=0,NPTS
	Z=FLOAT(IZ)*PASZ
	Z2=Z*Z

	DO 103 IX=0,NPTS
	X=FLOAT(IX)*PASX
	X2=X*X

	Y=0.D0
	Y2=0.D0
	RAD2=X2+Y2+Z2
	IF(RAD2.EQ.0.) RAD2=1.E-3
	RAD=DSQRT(RAD2)

C Calculating U, V and W

	URAD=(-1.D0/RAD)*DLOG(RAD+DSQRT(1+RAD2))+1.D0
	VRAD=(-1.D0*C1*RAD2)/((1.D0+C2*RAD2)**1.5)
	WRAD=(-1.D0*C3*RAD2)/((1.D0+C4*RAD2)**1.5)

	FRAD=1.D0/((1.D0+RAD2)**1.5)
	GRAD=3.D0*C1*C2*(7.D0+2.D0*C2*RAD2)*RAD2/
     1	((1.D0+C2*RAD2)**3.5)
	HRAD=3.D0*C3*C4*(7.D0+2.D0*C4*RAD2)*RAD2/
     1	((1.D0+C4*RAD2)**3.5)

	AA=(2.D0*Z2-X2-Y2)/(2.D0*RAD2)
	BB=3.D0*(X2-Y2)/RAD2

C
	PHI3(IZ,IX,3)=URAD-AA*VRAD+BB*WRAD
	RHO3(IZ,IX,3)=FRAD-AA*GRAD+BB*HRAD

	IF(IX.EQ.0)THEN
	WRITE(1,342)X,Y,Z,PHI3(IZ,IX,3),RHO3(IZ,IX,3)
	ENDIF

103	CONTINUE
	RETURN
	ENDIF

	RETURN
	END
C*************************************************************************
C	SUBROUTINE ELLIPSOID1_3D
C  This subroutine computes a "perfect ellipsoid" model
C  of a triaxial galaxy using Hernquist and Quinn's approximation (1986)
C  on the principal planes
C:::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::
	SUBROUTINE ELLIPSOID1_3D(PHI3,RHO3,IPLANE)
	PARAMETER (IDIM=1000)
	PARAMETER (IDIM1=400)
	IMPLICIT DOUBLE PRECISION (A-H,O-Z)
	REAL*8 PHI3(0:IDIM1,0:IDIM1,3)
	REAL*8 RHO3(0:IDIM1,0:IDIM1,3)
	COMMON/POT1/PI,QQ,PP,PASX,PASY,PASZ,NPTS

C Computes some constants :

	PP2=PP*PP
	QQ2=QQ*QQ
	PP4=PP2*PP2
	QQ4=QQ2*QQ2
	ASYM2=2.D0*PP2*QQ2-PP2-QQ2
	SYM2=PP2*QQ2+PP2+QQ2
	SYM4=1.D0+PP4+QQ4

	C1=((PP4+QQ4-2.D0)*ASYM2*ASYM2
     1	/(98.D0*SYM4*SYM2*SYM2))**.3333333
	print *,' c1 =',c1
	C2=((2.D0/7.D0)*SYM4*ASYM2
     1	/((PP4+QQ4-2.D0)*SYM2))**.3333333
	print *,' c2 =',c2
	C3=0.5D0*((PP2-QQ2)*(PP2-QQ2)*(PP4-QQ4)
     1	/(98.D0*SYM4*SYM2*SYM2))**.3333333
	print *,' c3 =',c3
	C4=((2.D0/7.D0)*SYM4
     1	/((PP2+QQ2)*SYM2))**.333333
	print *,' c4 =',c4

	WRITE(1,341) C1,C2,C3,C4
341	FORMAT(4X,'C1 =',E12.5,'   C2 =',E12.5,
     1	'  C3 =',E12.5,'   C4 =',E12.5,/,/,11X,'X',
     1	13X,'Y',13X,'Z',10X,'PHI3(X,Y,Z)',6X,'RHO3(X,Y,Z)',/)

C XY Plane ----------------------------------------------------------
	IF(IPLANE.EQ.1)THEN

	DO 101 IX=0,NPTS
	X=FLOAT(IX)*PASX
	X2=X*X

	DO 101 IY=0,NPTS
	Y=FLOAT(IY)*PASY
	Y2=Y*Y

	Z=0.D0
	Z2=0.D0

	RAD2=X2+Y2+Z2
	IF(RAD2.EQ.0.) RAD2=1.E-3
	RAD=DSQRT(RAD2)

C Calculating U, V and W

	URAD=(-1.D0*DATAN(RAD))/RAD
	VRAD=(-1.D0*C1*RAD2)/((1.D0+C2*RAD2)**2)
	WRAD=(-1.D0*C3*RAD2)/((1.D0+C4*RAD2)**2)

	FRAD=1.D0/((1.D0+RAD2)**2)
	GRAD=4.D0*C1*C2*(7.D0+C2*RAD2)*RAD2/
     1	((1.D0+C2*RAD2)**4)
	HRAD=4.D0*C3*C4*(7.D0+C4*RAD2)*RAD2/
     1	((1.D0+C4*RAD2)**4)

	AA=(2.D0*Z2-X2-Y2)/(2.D0*RAD2)
	BB=3.D0*(X2-Y2)/RAD2
C
	PHI3(IX,IY,1)=URAD-AA*VRAD+BB*WRAD
	RHO3(IX,IY,1)=FRAD-AA*GRAD+BB*HRAD

	IF(IY.EQ.0)THEN
	WRITE(1,342)X,Y,Z,PHI3(IX,IY,1),RHO3(IX,IY,1)
	ENDIF
342	FORMAT(2X,3(F12.3,2X),4X,E12.5,4X,E12.5)

101	CONTINUE
	WRITE(1,343)
343	FORMAT(/)
	RETURN
	ENDIF

C YZ Plane ----------------------------------------------------------
	IF(IPLANE.EQ.2)THEN

	DO 102 IY=0,NPTS
	Y=FLOAT(IY)*PASY
	Y2=Y*Y

	DO 102 IZ=0,NPTS
	Z=FLOAT(IZ)*PASZ
	Z2=Z*Z

	X=0.D0
	X2=0.D0
	RAD2=X2+Y2+Z2
	IF(RAD2.EQ.0.) RAD2=1.E-3
	RAD=DSQRT(RAD2)

C Calculating U, V and W

	URAD=(-1.D0*DATAN(RAD))/RAD
	VRAD=(-1.D0*C1*RAD2)/((1.D0+C2*RAD2)**2)
	WRAD=(-1.D0*C3*RAD2)/((1.D0+C4*RAD2)**2)

	FRAD=1.D0/((1.D0+RAD2)**2)
	GRAD=4.D0*C1*C2*(7.D0+C2*RAD2)*RAD2/
     1	((1.D0+C2*RAD2)**4)
	HRAD=4.D0*C3*C4*(7.D0+C4*RAD2)*RAD2/
     1	((1.D0+C4*RAD2)**4)

	AA=(2.D0*Z2-X2-Y2)/(2.D0*RAD2)
	BB=3.D0*(X2-Y2)/RAD2
C
	PHI3(IY,IZ,2)=URAD-AA*VRAD+BB*WRAD
	RHO3(IY,IZ,2)=FRAD-AA*GRAD+BB*HRAD

	IF(IZ.EQ.0)THEN
	WRITE(1,342)X,Y,Z,PHI3(IY,IZ,2),RHO3(IY,IZ,2)
	ENDIF

102	CONTINUE
	WRITE(1,343)
	RETURN
	ENDIF

C ZX Plane ---------------------------------------------------------
C
	IF(IPLANE.EQ.3)THEN

	DO 103 IZ=0,NPTS
	Z=FLOAT(IZ)*PASZ
	Z2=Z*Z

	DO 103 IX=0,NPTS
	X=FLOAT(IX)*PASX
	X2=X*X

	Y=0.D0
	Y2=0.D0
	RAD2=X2+Y2+Z2
	IF(RAD2.EQ.0.) RAD2=1.E-3
	RAD=DSQRT(RAD2)

C Calculating U, V and W

	URAD=(-1.D0*DATAN(RAD))/RAD
	VRAD=(-1.D0*C1*RAD2)/((1.D0+C2*RAD2)**2)
	WRAD=(-1.D0*C3*RAD2)/((1.D0+C4*RAD2)**2)

	FRAD=1.D0/((1.D0+RAD2)**2)
	GRAD=4.D0*C1*C2*(7.D0+C2*RAD2)*RAD2/
     1	((1.D0+C2*RAD2)**4)
	HRAD=4.D0*C3*C4*(7.D0+C4*RAD2)*RAD2/
     1	((1.D0+C4*RAD2)**4)
C
	AA=(2.D0*Z2-X2-Y2)/(2.D0*RAD2)
	BB=3.D0*(X2-Y2)/RAD2

	PHI3(IZ,IX,3)=URAD-AA*VRAD+BB*WRAD
	RHO3(IZ,IX,3)=FRAD-AA*GRAD+BB*HRAD

	IF(IX.EQ.0)THEN
	WRITE(1,342)X,Y,Z,PHI3(IZ,IX,3),RHO3(IZ,IX,3)
	ENDIF

103	CONTINUE
	RETURN
	ENDIF

	RETURN
	END
C*************************************************************************
C	SUBROUTINE ELLIPSOID2_3D
C  This subroutine computes a "modified perfect ellipsoid" model
C  of a triaxial galaxy using Hernquist and Quinn's approximation (1986)
C  on the principal planes
C:::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::
	SUBROUTINE ELLIPSOID2_3D(PHI3,RHO3,IPLANE)
	PARAMETER (IDIM=1000)
	PARAMETER (IDIM1=400)
	IMPLICIT DOUBLE PRECISION (A-H,O-Z)
	REAL*8 PHI3(0:IDIM1,0:IDIM1,3)
	REAL*8 RHO3(0:IDIM1,0:IDIM1,3)
	COMMON/POT1/PI,QQ,PP,PASX,PASY,PASZ,NPTS

C Computes some constants :

	PP2=PP*PP
	QQ2=QQ*QQ
	ASYM2=2.D0*PP2*QQ2-PP2-QQ2
	SYM2=PP2*QQ2+PP2+QQ2

	C1=(4.D0/35.D0)*ASYM2/SYM2
	C3=(2.D0/35.D0)*(PP2-QQ2)/SYM2

	WRITE(1,341) C1,C2,C3,C4
341	FORMAT(4X,'C1 =',E12.5,'   C2 =',E12.5,
     1	'  C3 =',E12.5,'   C4 =',E12.5,/,/,11X,'X',
     1	13X,'Y',13X,'Z',10X,'PHI3(X,Y,Z)',6X,'RHO3(X,Y,Z)',/)

C XY Plane ----------------------------------------------------------
	IF(IPLANE.EQ.1)THEN

	DO 101 IX=0,NPTS
	X=FLOAT(IX)*PASX
	X2=X*X

	DO 101 IY=0,NPTS
	Y=FLOAT(IY)*PASY
	Y2=Y*Y

	Z=0.D0
	Z2=0.D0

	RAD2=X2+Y2+Z2
	IF(RAD2.EQ.0.) RAD2=1.E-3
	RAD=DSQRT(RAD2)

C Calculating U, V and W

	URAD=(-1.D0*DATAN(RAD))/RAD
	VRAD=(-1.D0*C1*RAD2)/((1.D0+RAD2)**2.5)
	WRAD=(-1.D0*C3*RAD2)/((1.D0+RAD2)**2.5)

	FRAD=1.D0/((1.D0+RAD2)**2)
	GRAD=35.D0*C1*RAD2/
     1	((1.D0+RAD2)**4.5)
	HRAD=35.D0*C3*RAD2/
     1	((1.D0+RAD2)**4.5)

	AA=(2.D0*Z2-X2-Y2)/(2.D0*RAD2)
	BB=3.D0*(X2-Y2)/RAD2
C
	PHI3(IX,IY,1)=URAD-AA*VRAD+BB*WRAD
	RHO3(IX,IY,1)=FRAD-AA*GRAD+BB*HRAD

	IF(IY.EQ.0)THEN
	WRITE(1,342)X,Y,Z,PHI3(IX,IY,1),RHO3(IX,IY,1)
	ENDIF
342	FORMAT(2X,3(F12.3,2X),4X,E12.5,4X,E12.5)

101	CONTINUE
	WRITE(1,343)
343	FORMAT(/)
	RETURN
	ENDIF

C YZ Plane ----------------------------------------------------------
	IF(IPLANE.EQ.2)THEN

	DO 102 IY=0,NPTS
	Y=FLOAT(IY)*PASY
	Y2=Y*Y

	DO 102 IZ=0,NPTS
	Z=FLOAT(IZ)*PASZ
	Z2=Z*Z

	X=0.D0
	X2=0.D0
	RAD2=X2+Y2+Z2
	IF(RAD2.EQ.0.) RAD2=1.E-3
	RAD=DSQRT(RAD2)

C Calculating U, V and W

	URAD=(-1.D0*DATAN(RAD))/RAD
	VRAD=(-1.D0*C1*RAD2)/((1.D0+RAD2)**2.5)
	WRAD=(-1.D0*C3*RAD2)/((1.D0+RAD2)**2.5)

	FRAD=1.D0/((1.D0+RAD2)**2)
	GRAD=35.D0*C1*RAD2/
     1	((1.D0+RAD2)**4.5)
	HRAD=35.D0*C3*RAD2/
     1	((1.D0+RAD2)**4.5)

	AA=(2.D0*Z2-X2-Y2)/(2.D0*RAD2)
	BB=3.D0*(X2-Y2)/RAD2
C
	PHI3(IY,IZ,2)=URAD-AA*VRAD+BB*WRAD
	RHO3(IY,IZ,2)=FRAD-AA*GRAD+BB*HRAD

	IF(IZ.EQ.0)THEN
	WRITE(1,342)X,Y,Z,PHI3(IY,IZ,2),RHO3(IY,IZ,2)
	ENDIF

102	CONTINUE
	WRITE(1,343)
	RETURN
	ENDIF

C ZX Plane ---------------------------------------------------------
C
	IF(IPLANE.EQ.3)THEN

	DO 103 IZ=0,NPTS
	Z=FLOAT(IZ)*PASZ
	Z2=Z*Z

	DO 103 IX=0,NPTS
	X=FLOAT(IX)*PASX
	X2=X*X

	Y=0.D0
	Y2=0.D0
	RAD2=X2+Y2+Z2
	IF(RAD2.EQ.0.) RAD2=1.E-3
	RAD=DSQRT(RAD2)

C Calculating U, V and W

	URAD=(-1.D0*DATAN(RAD))/RAD
	VRAD=(-1.D0*C1*RAD2)/((1.D0+RAD2)**2.5)
	WRAD=(-1.D0*C3*RAD2)/((1.D0+RAD2)**2.5)

	FRAD=1.D0/((1.D0+RAD2)**2)
	GRAD=35.D0*C1*RAD2/
     1	((1.D0+RAD2)**4.5)
	HRAD=35.D0*C3*RAD2/
     1	((1.D0+RAD2)**4.5)
C
	AA=(2.D0*Z2-X2-Y2)/(2.D0*RAD2)
	BB=3.D0*(X2-Y2)/RAD2

	PHI3(IZ,IX,3)=URAD-AA*VRAD+BB*WRAD
	RHO3(IZ,IX,3)=FRAD-AA*GRAD+BB*HRAD

	IF(IX.EQ.0)THEN
	WRITE(1,342)X,Y,Z,PHI3(IZ,IX,3),RHO3(IZ,IX,3)
	ENDIF

103	CONTINUE
	RETURN
	ENDIF

	RETURN
	END
C--------------------------------------------------------------------
C Subroutine KING_3D to compute King's models
C----------------------------------------------------------------------
	SUBROUTINE KING_3D(PHI3,RHO3,IPLANE)

	IMPLICIT DOUBLE PRECISION (A-H,O-Z)
	PARAMETER (IDIM2=10000)
	PARAMETER (IDIM1=400)
	REAL*8 SPLINE_PHI(IDIM2),K_PHI(IDIM2),S(5)
	REAL*8 SPLINE_RHO(IDIM2),K_RHO(IDIM2)
	REAL*8 RHO(IDIM2),RAD(IDIM2),
     1	PHI(IDIM2),DPHI(IDIM2)
	REAL*8 PHI3(0:IDIM1,0:IDIM1,3)
	REAL*8 RHO3(0:IDIM1,0:IDIM1,3)

	COMMON/SPLINE_PHI/SPLINE_PHI,NCAP7_PHI,K_PHI
	COMMON/SPLINE_RHO/SPLINE_RHO,NCAP7_RHO,K_RHO
	COMMON/POT1/PI,QQ1,PP1,PASX1,PASY1,PASZ1,NPTS

C Common blocks with KING_MODEL :
	COMMON/KING/RHO,PHI,RAD,NINDEX,DPHI
	COMMON/KING3/W0,RTIDAL,RHO0

10	FORMAT(A)

	WRITE (6,301)
301	FORMAT(' ENTER W0 (CENTRAL POTENTIAL) AND RCORE (KPC) : ',$)
	READ (5,*) W0,RCORE

C Number of points calculated for the model
	WRITE (6,302)
302	FORMAT(' Number of points for King model:(max 10000) :',$)
	READ (5,*) NPTK
	WRITE (1,306)W0,RCORE,NPTK
306	FORMAT(' CALCULATING KING''S MODEL',/,
     1	' W0=',F10.4,'  RCORE=',F12.3,'  NPTK =',I5)

C Setting up the radius array for the model (From 1.E-1 to 1.E+3)
	RAD(1)=0.D0
	DO I=2,NPTK
	WORK=-1.D0 +4.D0*FLOAT(I)/FLOAT(NPTK)
	RAD(I)=10.D0**WORK
	END DO

	PRINT *,' CALCULATING THE MODEL... '
	CALL KING(NPTK)
	NPTS=JMIN0(NPTK,NPTS)
	PRINT *,' NPTK =',NPTK
	PRINT *,' NPTS =',NPTS

C Computing the total mass :
	RADMAX=RTIDAL+10.D0
	CALL MASS_KING(RADMAX,XMU1,NPTK)
	XMU=RHO0*XMU1
	XMASS1=XMU*RCORE*RCORE*RCORE
	PRINT *,' MU =',XMU,'MASS1 =',XMASS1

C
	PRINT *,' TOTAL MASS YOU WANT FOR THIS MODEL ?',
     1	' (UNITS: 10.D+10 SOLAR MASS)'
	READ(5,*) XMASS
	XRHO0=RHO0*XMASS/XMASS1
	PRINT *,' NEW RHO0 :',XRHO0
	WRITE(1,307)XMU,XRHO0,XMASS1,XMASS
307	FORMAT(' XMU =',E12.4,' NEW RHO0 =',E12.4,
     1	'  XMASS1 = ',E12.4,/,
     1	' TOTAL MASS = ',E12.4,' IN 1.E+10 SOLAR MASS')

C Normalization of the potential to get the correct mass :
C (Potential energy is proportional to mass)
C PHI is shifted of G.M/RT because in King's model, it is assumed PHI=0.
C when RAD=RT. We take a positive form for the potential (-1.* true pot)
	GRAV=4.497D-02
	DO I=1,NPTK
	PHI(I)=(GRAV*XMASS/RTIDAL)-XMASS*PHI(I)/XMASS1
	IF(PHI(I).LE.0.D0)PRINT *,'I,PHI(I)',I,PHI(I)
	END DO

C Transformation of the computed radii in physical radii
	DO I=1,NPTK
	RAD(I)=RCORE*RAD(I)
	END DO

C Possibility of a Keplerian extension :
C	PRINT *,' DO YOU WANT AN EXTENSION TO THE OUTER PARTS ?'
C	READ(5,10) ANS
	ANS='N'
	IF(ANS.EQ.'Y')THEN
	PRINT *,' MAX. RADIUS AND NUMBER OF POINTS ?'
	READ(5,*) RADMAX,NUMBER
C	CALL KEPLER_EXTENSION(RAD,PHI,NPTK,XMASS,
C     1	RADMAX,NUMBER)
	WRITE(1,308)RADMAX,NUMBER
308	FORMAT(' KEPLERIAN EXTENSION IN THE OUTER PARTS',/,
     1	' UNTIL ',F12.3,' ARCSECONDS',/,
     1	' WITH ',I5,' MORE POINTS')
	ENDIF

C Fits a spline to the logarithm of PHI
	PRINT *,' FIT OF THE POTENTIAL :'
	CALL SPLINELOGFIT(RAD,PHI,NPTK,SPLINE_PHI,NCAP7_PHI,K_PHI)

C Fits a spline to the logarithm of RHO
	PRINT *,' FIT OF THE DENSITY :'
	CALL SPLINELOGFIT(RAD,RHO,NPTK,SPLINE_RHO,NCAP7_RHO,K_RHO)

C Puts the model into a triaxial shape
	CALL KING_3D_PRO(PHI3,RHO3,IPLANE)

	RETURN
	END
C-------------------------------------------------------------------------
C Subroutine KING_3D_PRO
C To project the potential and the density onto 3 planes in a triaxial
C geometry.
C-------------------------------------------------------------------------
	SUBROUTINE KING_3D_PRO(PHI3,RHO3,IPLANE)

	IMPLICIT DOUBLE PRECISION (A-H,O-Z)
	PARAMETER (IDIM2=10000)
	PARAMETER (IDIM1=400)
	REAL*8 SPLINE_PHI(IDIM2),K_PHI(IDIM2),S(5)
	REAL*8 SPLINE_RHO(IDIM2),K_RHO(IDIM2)
	REAL*8 RHO(IDIM2),RAD(IDIM2),
     1	PHI(IDIM2),DPHI(IDIM2)
	REAL*8 PHI3(0:IDIM1,0:IDIM1,3)
	REAL*8 RHO3(0:IDIM1,0:IDIM1,3)

	COMMON/SPLINE_PHI/SPLINE_PHI,NCAP7_PHI,K_PHI
	COMMON/SPLINE_RHO/SPLINE_RHO,NCAP7_RHO,K_RHO
	COMMON/POT1/PI,QQ,PP,PASX,PASY,PASZ,NPTS

C Common blocks with KING_MODEL :
	COMMON/KING/RHO,PHI,RAD,NINDEX,DPHI
	COMMON/KING3/W0,RTIDAL,RHO0

	PP2=PP*PP
	QQ2=QQ*QQ

C XY PLANE -------------------------------------------------------------
	IF(IPLANE.EQ.1)THEN

	DO 101 IX=0,NPTS
	X=FLOAT(IX)*PASX
	X2=X*X

	DO 101 IY=0,NPTS
	Y=FLOAT(IY)*PASY
	Y2=Y*Y

	Z=0.D0
	Z2=0.D0

	S2=(X2/PP2)+(Y2/QQ2)+Z2
	IF(S2.EQ.0.) S2=1.E-3
C We take sqrt(s2) but in LOG10 since the spline fit was in log10/log10
	SS=0.5D0*DLOG10(S2)

C Calling NAG routine E02BCF:
	LEFT=0
	IFAIL=1
	CALL E02BCF(NCAP7_PHI,K_PHI,SPLINE_PHI,SS,LEFT,S,IFAIL)
	IF(IFAIL.NE.0)PRINT 989,IFAIL
	PHI3(IX,IY,1)=10.D0**S(1)

C Calling NAG routine E02BCF:
	LEFT=0
	IFAIL=1
	CALL E02BCF(NCAP7_RHO,K_RHO,SPLINE_RHO,SS,LEFT,S,IFAIL)
	IF(IFAIL.NE.0)PRINT 989,IFAIL
	RHO3(IX,IY,1)=10.D0**S(1)

989	FORMAT(' WARNING : PROBLEM IN E02BCF.    IFAIL=',I4)

	IF(IY.EQ.0)THEN
	WRITE(1,342)X,Y,Z,PHI3(IX,IY,1),RHO3(IX,IY,1)
	ENDIF
342	FORMAT(2X,3(F12.3,2X),4X,E12.5,4X,E12.5)

101	CONTINUE
	WRITE(1,343)
343	FORMAT(/)
	RETURN
	ENDIF

C YZ Plane ------------------------------------------------------------

	IF(IPLANE.EQ.2)THEN

	DO 102 IY=0,NPTS
	Y=FLOAT(IY)*PASY
	Y2=Y*Y

	DO 102 IZ=0,NPTS
	Z=FLOAT(IZ)*PASZ
	Z2=Z*Z

	X=0.D0
	X2=0.D0

	S2=(X2/PP2)+(Y2/QQ2)+Z2
	IF(S2.EQ.0.) S2=1.E-3
C We take sqrt(s2) but in LOG10 since the spline fit was in log10/log10
	SS=0.5D0*DLOG10(S2)

C Calling NAG routine E02BCF:
	LEFT=0
	IFAIL=1
	CALL E02BCF(NCAP7_PHI,K_PHI,SPLINE_PHI,SS,LEFT,S,IFAIL)
	IF(IFAIL.NE.0)PRINT 989,IFAIL
	PHI3(IY,IZ,2)=10.D0**S(1)

C Calling NAG routine E02BCF:
	LEFT=0
	IFAIL=1
	CALL E02BCF(NCAP7_RHO,K_RHO,SPLINE_RHO,SS,LEFT,S,IFAIL)
	IF(IFAIL.NE.0)PRINT 989,IFAIL
	RHO3(IY,IZ,2)=10.D0**S(1)

	IF(IZ.EQ.0)THEN
	WRITE(1,342)X,Y,Z,PHI3(IY,IZ,2),RHO3(IY,IZ,2)
	ENDIF

102	CONTINUE
	WRITE(1,343)
	RETURN
	ENDIF

C ZX Plane --------------------------------------------------------------

	IF(IPLANE.EQ.3)THEN

	DO 103 IZ=0,NPTS
	Z=FLOAT(IZ)*PASZ
	Z2=Z*Z

	DO 103 IX=0,NPTS
	X=FLOAT(IX)*PASX
	X2=X*X

	Y=0.D0
	Y2=0.D0

	S2=(X2/PP2)+(Y2/QQ2)+Z2
	IF(S2.EQ.0.) S2=1.E-3
C We take sqrt(s2) but in LOG10 since the spline fit was in log10/log10
	SS=0.5D0*DLOG10(S2)

C Calling NAG routine E02BCF:
	LEFT=0
	IFAIL=1
	CALL E02BCF(NCAP7_PHI,K_PHI,SPLINE_PHI,SS,LEFT,S,IFAIL)
	IF(IFAIL.NE.0)PRINT 989,IFAIL
	PHI3(IZ,IX,3)=10.D0**S(1)

C Calling NAG routine E02BCF:
	LEFT=0
	IFAIL=1
	CALL E02BCF(NCAP7_RHO,K_RHO,SPLINE_RHO,SS,LEFT,S,IFAIL)
	IF(IFAIL.NE.0)PRINT 989,IFAIL
	RHO3(IZ,IX,3)=10.D0**S(1)

	IF(IX.EQ.0)THEN
	WRITE(1,342)X,Y,Z,PHI3(IZ,IX,3),RHO3(IZ,IX,3)
	ENDIF

103	CONTINUE
	RETURN
	ENDIF

	RETURN
	END
C***************************************************************
C	Subroutine HUBBLE_3D
C	PHI(S)=1/(1+S)**ALPHA
C OR	PHI(S)=1/(1+S**2)**ALPHA
C**************************************************************
	SUBROUTINE HUBBLE_3D(PHI3,RHO3,IPLANE)
	PARAMETER (IDIM=1000)
	PARAMETER (IDIM1=400)
	IMPLICIT DOUBLE PRECISION (A-H,O-Z)
	REAL*4 ALPHA
	REAL*8 PHI3(0:IDIM1,0:IDIM1,3)
	REAL*8 RHO3(0:IDIM1,0:IDIM1,3)
	COMMON/POT1/PI,QQ1,PP1,PASX1,PASY1,PASZ1,NPTS

	C1=1.D0+(1.D0/(PP1*PP1))+(1.D0/(QQ1*QQ1))

C Setting the options :
	PRINT 77
77	FORMAT(' 2 POSSIBILITIES :',/,
     1	' 1. PHI(S)=1/(1+S)**ALPHA ',/,
     1	' 2. PHI(S)=1/(1+S**2)**ALPHA ',/,
     1	' ENTER THE OPTION YOU WANT : ',$)
	READ(5,*) IOPT

	PRINT *,' VALUE FOR ALPHA ?'
	READ(5,*) ALPHA
	WRITE(1,78)ALPHA
78	FORMAT(' ALPHA = ',F8.4)
	ALPHAM=-1.*ALPHA

C XY PLANE --------------------------------------------------------
	IF(IPLANE.EQ.1)THEN
	PP=PP1
	QQ=QQ1
	PASX=PASX1
	PASY=PASY1
	ENDIF

C YZ PLANE --------------------------------------------------------
	IF(IPLANE.EQ.2)THEN
	PP=QQ1
	QQ=1.
	PASX=PASY1
	PASY=PASZ1
	ENDIF

C ZX PLANE --------------------------------------------------------
	IF(IPLANE.EQ.3)THEN
	PP=1.
	QQ=PP1
	PASX=PASZ1
	PASY=PASX1
	ENDIF

C Calculates some constants :

	PP2=PP*PP
	QQ2=QQ*QQ
	PP4=PP2*PP2
	QQ4=QQ2*QQ2

C Computing the model :

C Option 1:
	IF(IOPT.EQ.1)THEN

	DO 101 IX=0,NPTS
	X=FLOAT(IX)*PASX
	X2=X*X

	DO 101 IY=0,NPTS
	Y=FLOAT(IY)*PASY
	Y2=Y*Y

	S2=(X2/PP2)+(Y2/QQ2)

C Avoids trouble in the center :
	IF(S2.LT.4.) S2=4.
	SS=DSQRT(S2)
	SSP1=1.D0+SS
	PHI3(IX,IY,IPLANE)=SSP1**ALPHAM
	RHO3(IX,IY,IPLANE)=(ALPHA/SS)*(SSP1**(-2.-ALPHA))*
     1	(C1*SSP1-(1.D0+(2.D0+ALPHA)*SS)*((X2/PP4)+(Y2/QQ4))/
     1	S2)

	IF(IY.EQ.0)THEN
	WRITE(1,342)X,Y,PHI3(IX,IY,IPLANE),RHO3(IX,IY,IPLANE)
	ENDIF
342	FORMAT(2X,2(F12.3,2X),4X,E12.5,4X,E12.5)

101	CONTINUE
	WRITE(1,343)
343	FORMAT(/)
	ENDIF

C---------------------------------------------------------------
C Option 2:
	IF(IOPT.EQ.2)THEN

	DO 201 IX=0,NPTS
	X=FLOAT(IX)*PASX
	X2=X*X

	DO 201 IY=0,NPTS
	Y=FLOAT(IY)*PASY
	Y2=Y*Y

	S2=(X2/PP2)+(Y2/QQ2)

	IF(S2.LT.1.D-06) S2=1.D-06
	SS=DSQRT(S2)
	SSP1=1.D0+SS*SS
	PHI3(IX,IY,IPLANE)=SSP1**ALPHAM
	RHO3(IX,IY,IPLANE)=2.D0*ALPHA*(SSP1**(-2.-ALPHA))*
     1	(C1*SSP1-2.D0*(1.D0+ALPHA)*((X2/PP4)+(Y2/QQ4)))

	IF(IY.EQ.0)THEN
	WRITE(1,342)X,Y,PHI3(IX,IY,IPLANE),RHO3(IX,IY,IPLANE)
	ENDIF

201	CONTINUE
	WRITE(1,343)
	ENDIF

	RETURN
	END
C-----------------------------------------------------------------------
	include 'jlpsub:project.for'
	include 'jlpsub:king_model.for'


#ifndef DEF_KIND
#define DEF_KIND 8
#endif

module utils
implicit none

integer, parameter :: iKIND = DEF_KIND

contains

  subroutine print_diagonal(A, n)
    implicit none
    integer :: i
    integer, intent(in) :: n
    real(kind = iKIND), intent(inout) :: A(0:n, 0:n)
    do i = 0, n
      print *, A(i, i)
    end do
  end subroutine print_diagonal

  subroutine print_rows(A, n)
    implicit none
    integer :: i
    integer, intent(in) :: n
    real(kind = iKIND), intent(inout) :: A(0:n, 0:n)
    do i = 0, n
      print *, i, ": ", A(:, i)
    end do
  end subroutine print_rows

end module utils


*DECK BESKNU
      SUBROUTINE BESKNU (X, FNU, KODE, N, Y, NZ)
C***BEGIN PROLOGUE  BESKNU
C***SUBSIDIARY
C***PURPOSE  Subsidiary to BESK
C***LIBRARY   SLATEC
C***TYPE      SINGLE PRECISION (BESKNU-S, DBSKNU-D)
C***AUTHOR  Amos, D. E., (SNLA)
C***DESCRIPTION
C
C     Abstract
C         BESKNU computes N member sequences of K Bessel functions
C         K/SUB(FNU+I-1)/(X), I=1,N for non-negative orders FNU and
C         positive X. Equations of the references are implemented on
C         small orders DNU for K/SUB(DNU)/(X) and K/SUB(DNU+1)/(X).
C         Forward recursion with the three term recursion relation
C         generates higher orders FNU+I-1, I=1,...,N. The parameter
C         KODE permits K/SUB(FNU+I-1)/(X) values or scaled values
C         EXP(X)*K/SUB(FNU+I-1)/(X), I=1,N to be returned.
C
C         To start the recursion FNU is normalized to the interval
C         -0.5.LE.DNU.LT.0.5. A special form of the power series is
C         implemented on 0.LT.X.LE.X1 while the Miller algorithm for the
C         K Bessel function in terms of the confluent hypergeometric
C         function U(FNU+0.5,2*FNU+1,X) is implemented on X1.LT.X.LE.X2.
C         For X.GT.X2, the asymptotic expansion for large X is used.
C         When FNU is a half odd integer, a special formula for
C         DNU=-0.5 and DNU+1.0=0.5 is used to start the recursion.
C
C         BESKNU assumes that a significant digit SINH(X) function is
C         available.
C
C     Description of Arguments
C
C         Input
C           X      - X.GT.0.0E0
C           FNU    - Order of initial K function, FNU.GE.0.0E0
C           N      - Number of members of the sequence, N.GE.1
C           KODE   - A parameter to indicate the scaling option
C                    KODE= 1  returns
C                             Y(I)=       K/SUB(FNU+I-1)/(X)
C                                  I=1,...,N
C                        = 2  returns
C                             Y(I)=EXP(X)*K/SUB(FNU+I-1)/(X)
C                                  I=1,...,N
C
C         Output
C           Y      - A vector whose first N components contain values
C                    for the sequence
C                    Y(I)=       K/SUB(FNU+I-1)/(X), I=1,...,N or
C                    Y(I)=EXP(X)*K/SUB(FNU+I-1)/(X), I=1,...,N
C                    depending on KODE
C           NZ     - Number of components set to zero due to
C                    underflow,
C                    NZ= 0   , Normal return
C                    NZ.NE.0 , First NZ components of Y set to zero
C                              due to underflow, Y(I)=0.0E0,I=1,...,NZ
C
C     Error Conditions
C         Improper input arguments - a fatal error
C         Overflow - a fatal error
C         Underflow with KODE=1 - a non-fatal error (NZ.NE.0)
C
C***SEE ALSO  BESK
C***REFERENCES  N. M. Temme, On the numerical evaluation of the modified
C                 Bessel function of the third kind, Journal of
C                 Computational Physics 19, (1975), pp. 324-337.
C***ROUTINES CALLED  GAMMA, I1MACH, R1MACH, XERMSG
C***REVISION HISTORY  (YYMMDD)
C   790201  DATE WRITTEN
C   890531  Changed all specific intrinsics to generic.  (WRB)
C   891214  Prologue converted to Version 4.0 format.  (BAB)
C   900315  CALLs to XERROR changed to CALLs to XERMSG.  (THJ)
C   900326  Removed duplicate information from DESCRIPTION section.
C           (WRB)
C   900328  Added TYPE section.  (WRB)
C   900727  Added EXTERNAL statement.  (WRB)
C   910408  Updated the AUTHOR and REFERENCES sections.  (WRB)
C   920501  Reformatted the REFERENCES section.  (WRB)
C***END PROLOGUE  BESKNU
C
      INTEGER I, IFLAG, INU, J, K, KK, KODE, KODED, N, NN, NZ
      INTEGER I1MACH
      REAL A, AK, A1, A2, B, BK, CC, CK, COEF, CX, DK, DNU, DNU2, ELIM,
     1 ETEST, EX, F, FC, FHS, FK, FKS, FLRX, FMU, FNU, G1, G2, P, PI,
     2 PT, P1, P2, Q, RTHPI, RX, S, SMU, SQK, ST, S1, S2, TM, TOL, T1,
     3 T2, X, X1, X2, Y
      REAL GAMMA, R1MACH
      DIMENSION A(160), B(160), Y(*), CC(8)
      EXTERNAL GAMMA
      SAVE X1, X2, PI, RTHPI, CC
      DATA X1, X2 / 2.0E0, 17.0E0 /
      DATA PI,RTHPI        / 3.14159265358979E+00, 1.25331413731550E+00/
      DATA CC(1), CC(2), CC(3), CC(4), CC(5), CC(6), CC(7), CC(8)
     1                     / 5.77215664901533E-01,-4.20026350340952E-02,
     2-4.21977345555443E-02, 7.21894324666300E-03,-2.15241674114900E-04,
     3-2.01348547807000E-05, 1.13302723200000E-06, 6.11609500000000E-09/
C***FIRST EXECUTABLE STATEMENT  BESKNU
      KK = -I1MACH(12)
      ELIM = 2.303E0*(KK*R1MACH(5)-3.0E0)
      AK = R1MACH(3)
      TOL = MAX(AK,1.0E-15)
      IF (X.LE.0.0E0) GO TO 350
      IF (FNU.LT.0.0E0) GO TO 360
      IF (KODE.LT.1 .OR. KODE.GT.2) GO TO 370
      IF (N.LT.1) GO TO 380
      NZ = 0
      IFLAG = 0
      KODED = KODE
      RX = 2.0E0/X
      INU = INT(FNU+0.5E0)
      DNU = FNU - INU
      IF (ABS(DNU).EQ.0.5E0) GO TO 120
      DNU2 = 0.0E0
      IF (ABS(DNU).LT.TOL) GO TO 10
      DNU2 = DNU*DNU
   10 CONTINUE
      IF (X.GT.X1) GO TO 120
C
C     SERIES FOR X.LE.X1
C
      A1 = 1.0E0 - DNU
      A2 = 1.0E0 + DNU
      T1 = 1.0E0/GAMMA(A1)
      T2 = 1.0E0/GAMMA(A2)
      IF (ABS(DNU).GT.0.1E0) GO TO 40
C     SERIES FOR F0 TO RESOLVE INDETERMINACY FOR SMALL ABS(DNU)
      S = CC(1)
      AK = 1.0E0
      DO 20 K=2,8
        AK = AK*DNU2
        TM = CC(K)*AK
        S = S + TM
        IF (ABS(TM).LT.TOL) GO TO 30
   20 CONTINUE
   30 G1 = -S
      GO TO 50
   40 CONTINUE
      G1 = (T1-T2)/(DNU+DNU)
   50 CONTINUE
      G2 = (T1+T2)*0.5E0
      SMU = 1.0E0
      FC = 1.0E0
      FLRX = LOG(RX)
      FMU = DNU*FLRX
      IF (DNU.EQ.0.0E0) GO TO 60
      FC = DNU*PI
      FC = FC/SIN(FC)
      IF (FMU.NE.0.0E0) SMU = SINH(FMU)/FMU
   60 CONTINUE
      F = FC*(G1*COSH(FMU)+G2*FLRX*SMU)
      FC = EXP(FMU)
      P = 0.5E0*FC/T2
      Q = 0.5E0/(FC*T1)
      AK = 1.0E0
      CK = 1.0E0
      BK = 1.0E0
      S1 = F
      S2 = P
      IF (INU.GT.0 .OR. N.GT.1) GO TO 90
      IF (X.LT.TOL) GO TO 80
      CX = X*X*0.25E0
   70 CONTINUE
      F = (AK*F+P+Q)/(BK-DNU2)
      P = P/(AK-DNU)
      Q = Q/(AK+DNU)
      CK = CK*CX/AK
      T1 = CK*F
      S1 = S1 + T1
      BK = BK + AK + AK + 1.0E0
      AK = AK + 1.0E0
      S = ABS(T1)/(1.0E0+ABS(S1))
      IF (S.GT.TOL) GO TO 70
   80 CONTINUE
      Y(1) = S1
      IF (KODED.EQ.1) RETURN
      Y(1) = S1*EXP(X)
      RETURN
   90 CONTINUE
      IF (X.LT.TOL) GO TO 110
      CX = X*X*0.25E0
  100 CONTINUE
      F = (AK*F+P+Q)/(BK-DNU2)
      P = P/(AK-DNU)
      Q = Q/(AK+DNU)
      CK = CK*CX/AK
      T1 = CK*F
      S1 = S1 + T1
      T2 = CK*(P-AK*F)
      S2 = S2 + T2
      BK = BK + AK + AK + 1.0E0
      AK = AK + 1.0E0
      S = ABS(T1)/(1.0E0+ABS(S1)) + ABS(T2)/(1.0E0+ABS(S2))
      IF (S.GT.TOL) GO TO 100
  110 CONTINUE
      S2 = S2*RX
      IF (KODED.EQ.1) GO TO 170
      F = EXP(X)
      S1 = S1*F
      S2 = S2*F
      GO TO 170
  120 CONTINUE
      COEF = RTHPI/SQRT(X)
      IF (KODED.EQ.2) GO TO 130
      IF (X.GT.ELIM) GO TO 330
      COEF = COEF*EXP(-X)
  130 CONTINUE
      IF (ABS(DNU).EQ.0.5E0) GO TO 340
      IF (X.GT.X2) GO TO 280
C
C     MILLER ALGORITHM FOR X1.LT.X.LE.X2
C
      ETEST = COS(PI*DNU)/(PI*X*TOL)
      FKS = 1.0E0
      FHS = 0.25E0
      FK = 0.0E0
      CK = X + X + 2.0E0
      P1 = 0.0E0
      P2 = 1.0E0
      K = 0
  140 CONTINUE
      K = K + 1
      FK = FK + 1.0E0
      AK = (FHS-DNU2)/(FKS+FK)
      BK = CK/(FK+1.0E0)
      PT = P2
      P2 = BK*P2 - AK*P1
      P1 = PT
      A(K) = AK
      B(K) = BK
      CK = CK + 2.0E0
      FKS = FKS + FK + FK + 1.0E0
      FHS = FHS + FK + FK
      IF (ETEST.GT.FK*P1) GO TO 140
      KK = K
      S = 1.0E0
      P1 = 0.0E0
      P2 = 1.0E0
      DO 150 I=1,K
        PT = P2
        P2 = (B(KK)*P2-P1)/A(KK)
        P1 = PT
        S = S + P2
        KK = KK - 1
  150 CONTINUE
      S1 = COEF*(P2/S)
      IF (INU.GT.0 .OR. N.GT.1) GO TO 160
      GO TO 200
  160 CONTINUE
      S2 = S1*(X+DNU+0.5E0-P1/P2)/X
C
C     FORWARD RECURSION ON THE THREE TERM RECURSION RELATION
C
  170 CONTINUE
      CK = (DNU+DNU+2.0E0)/X
      IF (N.EQ.1) INU = INU - 1
      IF (INU.GT.0) GO TO 180
      IF (N.GT.1) GO TO 200
      S1 = S2
      GO TO 200
  180 CONTINUE
      DO 190 I=1,INU
        ST = S2
        S2 = CK*S2 + S1
        S1 = ST
        CK = CK + RX
  190 CONTINUE
      IF (N.EQ.1) S1 = S2
  200 CONTINUE
      IF (IFLAG.EQ.1) GO TO 220
      Y(1) = S1
      IF (N.EQ.1) RETURN
      Y(2) = S2
      IF (N.EQ.2) RETURN
      DO 210 I=3,N
        Y(I) = CK*Y(I-1) + Y(I-2)
        CK = CK + RX
  210 CONTINUE
      RETURN
C     IFLAG=1 CASES
  220 CONTINUE
      S = -X + LOG(S1)
      Y(1) = 0.0E0
      NZ = 1
      IF (S.LT.-ELIM) GO TO 230
      Y(1) = EXP(S)
      NZ = 0
  230 CONTINUE
      IF (N.EQ.1) RETURN
      S = -X + LOG(S2)
      Y(2) = 0.0E0
      NZ = NZ + 1
      IF (S.LT.-ELIM) GO TO 240
      NZ = NZ - 1
      Y(2) = EXP(S)
  240 CONTINUE
      IF (N.EQ.2) RETURN
      KK = 2
      IF (NZ.LT.2) GO TO 260
      DO 250 I=3,N
        KK = I
        ST = S2
        S2 = CK*S2 + S1
        S1 = ST
        CK = CK + RX
        S = -X + LOG(S2)
        NZ = NZ + 1
        Y(I) = 0.0E0
        IF (S.LT.-ELIM) GO TO 250
        Y(I) = EXP(S)
        NZ = NZ - 1
        GO TO 260
  250 CONTINUE
      RETURN
  260 CONTINUE
      IF (KK.EQ.N) RETURN
      S2 = S2*CK + S1
      CK = CK + RX
      KK = KK + 1
      Y(KK) = EXP(-X+LOG(S2))
      IF (KK.EQ.N) RETURN
      KK = KK + 1
      DO 270 I=KK,N
        Y(I) = CK*Y(I-1) + Y(I-2)
        CK = CK + RX
  270 CONTINUE
      RETURN
C
C     ASYMPTOTIC EXPANSION FOR LARGE X, X.GT.X2
C
C     IFLAG=0 MEANS NO UNDERFLOW OCCURRED
C     IFLAG=1 MEANS AN UNDERFLOW OCCURRED- COMPUTATION PROCEEDS WITH
C     KODED=2 AND A TEST FOR ON SCALE VALUES IS MADE DURING FORWARD
C     RECURSION
  280 CONTINUE
      NN = 2
      IF (INU.EQ.0 .AND. N.EQ.1) NN = 1
      DNU2 = DNU + DNU
      FMU = 0.0E0
      IF (ABS(DNU2).LT.TOL) GO TO 290
      FMU = DNU2*DNU2
  290 CONTINUE
      EX = X*8.0E0
      S2 = 0.0E0
      DO 320 K=1,NN
        S1 = S2
        S = 1.0E0
        AK = 0.0E0
        CK = 1.0E0
        SQK = 1.0E0
        DK = EX
        DO 300 J=1,30
          CK = CK*(FMU-SQK)/DK
          S = S + CK
          DK = DK + EX
          AK = AK + 8.0E0
          SQK = SQK + AK
          IF (ABS(CK).LT.TOL) GO TO 310
  300   CONTINUE
  310   S2 = S*COEF
        FMU = FMU + 8.0E0*DNU + 4.0E0
  320 CONTINUE
      IF (NN.GT.1) GO TO 170
      S1 = S2
      GO TO 200
  330 CONTINUE
      KODED = 2
      IFLAG = 1
      GO TO 120
C
C     FNU=HALF ODD INTEGER CASE
C
  340 CONTINUE
      S1 = COEF
      S2 = COEF
      GO TO 170
C
C
  350 CALL XERMSG ('SLATEC', 'BESKNU', 'X NOT GREATER THAN ZERO', 2, 1)
      RETURN
  360 CALL XERMSG ('SLATEC', 'BESKNU', 'FNU NOT ZERO OR POSITIVE', 2,
     +   1)
      RETURN
  370 CALL XERMSG ('SLATEC', 'BESKNU', 'KODE NOT 1 OR 2', 2, 1)
      RETURN
  380 CALL XERMSG ('SLATEC', 'BESKNU', 'N NOT GREATER THAN 0', 2, 1)
      RETURN
      END