! ##################################################################################################################################
! Begin MIT license text.
! _______________________________________________________________________________________________________

! Copyright 2019 Dr William R Case, Jr (dbcase29@gmail.com)

! Permission is hereby granted, free of charge, to any person obtaining a copy of this software and
! associated documentation files (the "Software"), to deal in the Software without restriction, including
! without limitation the rights to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
! copies of the Software, and to permit persons to whom the Software is furnished to do so, subject to
! the following conditions:

! The above copyright notice and this permission notice shall be included in all copies or substantial
! portions of the Software and documentation.

! THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS
! OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
! FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
! AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
! LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
! OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN
! THE SOFTWARE.
! _______________________________________________________________________________________________________

! End MIT license text.

      SUBROUTINE SURFACE_FIT ( NUM_FITS, NUM_COEFFS, XI, YI, WI, XO, YO, WO, DEB, MESSAGE, OUNT, POLY_PCT_ERR, PCT_ERR_MAX, IERR )

! Fits a 2D surface polynomial to a set of input values. The subroutine is coded to fit a surface of up to 2nd order:

!              WF(X,Y) = B(0) + B(1)*X + B(2)*Y + B(3)*XY + B(4)*X^2 + B(5)*Y^2

      USE PENTIUM_II_KIND, ONLY       :  BYTE, LONG, DOUBLE
      USE IOUNT1, ONLY                :  ERR, F04, F06, WRT_LOG
      USE SCONTR, ONLY                :  BLNK_SUB_NAM, FATAL_ERR
      USE TIMDAT, ONLY                :  TSEC
      USE CONSTANTS_1, ONLY           :  ZERO, ONE
      USE SUBR_BEGEND_LEVELS, ONLY    :  SURFACE_FIT_BEGEND
      USE LSQ_MYSTRAN

      USE SURFACE_FIT_USE_IFs

      IMPLICIT NONE

      CHARACTER(LEN=LEN(BLNK_SUB_NAM)):: SUBR_NAME = 'SURFACE_FIT'
      CHARACTER(LEN=*), INTENT(IN)    :: MESSAGE               ! Message printed if debug output is printed

      INTEGER(LONG), INTENT(IN)       :: DEB                   ! If > 0 then DEB_SURFACE_FIT will be run
      INTEGER(LONG), INTENT(IN)       :: NUM_FITS              ! Number of data points to fit
      INTEGER(LONG), INTENT(IN)       :: NUM_COEFFS            ! Number of coefficients in the fitting polynomial
      INTEGER(LONG), INTENT(IN)       :: OUNT(2)               ! Output units for SURFACE_FIT
      INTEGER(LONG), INTENT(OUT)      :: IERR                  ! Error indicator
      INTEGER(LONG)                   :: I,J                   ! DO loop indices
      INTEGER(LONG)                   :: IFAULT                ! Return code from subr REGCF
      INTEGER(LONG), PARAMETER        :: MAX_COEFFS = 6        ! Maximum number of coefficients coded for ther polynomial fit
      INTEGER(LONG), PARAMETER        :: SUBR_BEGEND = SURFACE_FIT_BEGEND

      LOGICAL                         :: LINDEP(MAX_COEFFS)

      REAL(DOUBLE), INTENT(IN)        :: WI(NUM_FITS)          ! Values of the function to fit at the input data points
      REAL(DOUBLE), INTENT(IN)        :: XI(NUM_FITS)          ! X coords of the input  data points
      REAL(DOUBLE), INTENT(IN)        :: YI(NUM_FITS)          ! Y coords of the input  data points
      REAL(DOUBLE), INTENT(IN)        :: XO(NUM_FITS)          ! X coords of the output data points
      REAL(DOUBLE), INTENT(IN)        :: YO(NUM_FITS)          ! Y coords of the output data points
      REAL(DOUBLE), INTENT(OUT)       :: POLY_PCT_ERR(NUM_FITS)! % difference between fitted & actual data (norm'd to max act data)
      REAL(DOUBLE), INTENT(OUT)       :: PCT_ERR_MAX           ! Max value from array POLY_PCT_ERR (max error at any input data pt)
      REAL(DOUBLE), INTENT(OUT)       :: WO(NUM_FITS)          ! Values of the function to fit at the output data points
      REAL(DOUBLE)                    :: DEN                   ! Intermediate value in a calculation
      REAL(DOUBLE)                    :: B(0:MAX_COEFFS-1)     ! Coefficients in the polynomial fit
      REAL(DOUBLE)                    :: RES(NUM_FITS)         ! Actual minus fitted data
      REAL(DOUBLE)                    :: RES_ABS               ! Max abs of the residual
      REAL(DOUBLE)                    :: WF(NUM_FITS)          ! Values at the input XI, YI coords of the fitted polynomial
      REAL(DOUBLE)                    :: WI_MAX                ! Max abs value of WI

      REAL(DOUBLE)                    :: XROW(0:MAX_COEFFS-1)! Array of XYI values for one data point

                                                             ! Values of XI, YI and their products to go into the poly fit eqn
      REAL(DOUBLE)                    :: XYI(NUM_FITS,0:MAX_COEFFS-1)

                                                             ! Values of XO, YO and their products to go into the poly fit eqn
      REAL(DOUBLE)                    :: XYO(NUM_FITS,0:MAX_COEFFS-1)

      REAL(DOUBLE), PARAMETER         :: WT = ONE            ! Parameter

! **********************************************************************************************************************************
      IF (WRT_LOG >= SUBR_BEGEND) THEN
         CALL OURTIM
         WRITE(F04,9001) SUBR_NAME,TSEC
 9001    FORMAT(1X,A,' BEGN ',F10.3)
      ENDIF

! **********************************************************************************************************************************
      IERR = 0

! Make sure that we have not requested an impossible situation with NUM_COEFFS

      IF ((NUM_COEFFS < 1) .OR. (NUM_COEFFS > MAX_COEFFS)) THEN
         FATAL_ERR = FATAL_ERR + 1
         WRITE(OUNT(1),958) SUBR_NAME, NUM_COEFFS, MAX_COEFFS
         IF (OUNT(2) /= OUNT(1)) THEN
            WRITE(OUNT(2),958) SUBR_NAME, NUM_COEFFS, MAX_COEFFS
         ENDIF
         IERR = 1
         RETURN
      ENDIF

! Initialize

      DO I=1,NUM_FITS
         DO J=1,MAX_COEFFS
            XYI(I,J-1) = ZERO
            XROW(J-1)  = ZERO
            LINDEP(J) = .FALSE.
         ENDDO
      ENDDO

! Calc polynomial fit to the input WI at its coords, XI, YI

      CALL STARTUP (NUM_COEFFS-1, .TRUE.)

      WI_MAX = ZERO
      DO I=1,NUM_FITS
         IF (DABS(WI(I)) > WI_MAX) WI_MAX = WI(I)
         IF (NUM_COEFFS >= 1) THEN
            XYI(I,0) = ONE
         ENDIF
         IF (NUM_COEFFS >= 2) THEN
            XYI(I,1) = XI(I)
         ENDIF
         IF (NUM_COEFFS >= 3) THEN
            XYI(I,2) = YI(I)
         ENDIF
         IF (NUM_COEFFS >= 4) THEN
            XYI(I,3) = XI(I)*XI(I)
         ENDIF
         IF (NUM_COEFFS >= 5) THEN
            XYI(I,4) = XI(I)*YI(I)
         ENDIF
         IF (NUM_COEFFS >= 6) THEN
            XYI(I,5) = YI(I)*YI(I)
         ENDIF
         XROW(1:NUM_COEFFS-1) = XYI(I,1:NUM_COEFFS-1)
         XROW(0) = ONE
         CALL INCLUD ( WT, XROW, WI(I) )
      ENDDO

      CALL TOLSET ()

      CALL SING ( LINDEP, IFAULT )

      CALL REGCF ( B, NUM_COEFFS, IFAULT )

! Calc percent errors in polynomial fit to input data

      RES_ABS = ZERO
      DO I=1,NUM_FITS
         WF(I) = ZERO
         DO J=0,NUM_COEFFS-1
            WF(I) = WF(I) + B(J)*XYI(I,J)
         ENDDO
         RES(I) = WI(I) - WF(I)
         IF (DABS(RES(I)) > RES_ABS) THEN
            RES_ABS = DABS(RES(I))
         ENDIF
      ENDDO

      PCT_ERR_MAX = ZERO
      DO I=1,NUM_FITS
         IF (DABS(WI_MAX) > 0.0) THEN
            DEN = DABS(WI_MAX)
         ELSE
            DEN = ONE
         ENDIF
         POLY_PCT_ERR(I) = 100*RES(I)/DEN
         IF (DABS(PCT_ERR_MAX) < DABS(POLY_PCT_ERR(I))) THEN
            PCT_ERR_MAX = POLY_PCT_ERR(I)
         ENDIF
      ENDDO

! Calc fit to output coords, XO, YO

      DO I=1,NUM_FITS
         IF (NUM_COEFFS >= 1) THEN
            XYO(I,0)   = ONE
         ENDIF
         IF (NUM_COEFFS >= 2) THEN
            XYO(I,1)   = XO(I)
         ENDIF
         IF (NUM_COEFFS >= 3) THEN
            XYO(I,2)   = YO(I)
         ENDIF
         IF (NUM_COEFFS >= 4) THEN
            XYO(I,3)   = XO(I)*XO(I)
         ENDIF
         IF (NUM_COEFFS >= 5) THEN
            XYO(I,4)   = XO(I)*YO(I)
         ENDIF
         IF (NUM_COEFFS >= 6) THEN
            XYO(I,5)   = YO(I)*YO(I)
         ENDIF
         WO(I) = ZERO
         DO J=0,NUM_COEFFS-1
            WO(I) = WO(I) + B(J)*XYO(I,J)
         ENDDO
      ENDDO

      IF (DEB > 0) CALL DEB_SURFACE_FIT

! **********************************************************************************************************************************
      IF (WRT_LOG >= SUBR_BEGEND) THEN
         CALL OURTIM
         WRITE(F04,9002) SUBR_NAME,TSEC
 9002    FORMAT(1X,A,' END  ',F10.3)
      ENDIF

      RETURN

! **********************************************************************************************************************************
  958 FORMAT(' *ERROR   958: PROGRAMMING ERROR IN SUBROUTINE ',A                                                                   &
                    ,/,14X,' THE VX VECTOR FOR ',A,' ELEMENT ',I8,' WAS LEFT UNSORTED. IT MUST BE SORTED TO DETERMINE VY, VZ')

! ##################################################################################################################################

      CONTAINS

! ##################################################################################################################################

      SUBROUTINE DEB_SURFACE_FIT

      IMPLICIT NONE

      INTEGER(LONG)                   :: II                ! DO loop index

! **********************************************************************************************************************************
      WRITE(OUNT(2),2000)
      WRITE(OUNT(2),'(A)') ' DEBUG 175 results from subr SURFACE_FIT'//MESSAGE//':'
      WRITE(OUNT(2),*)     ' --------------------------------------'
      WRITE(OUNT(2),2001) IFAULT
      WRITE(OUNT(2),'(A,1ES10.2,A)') ' PCT_ERR_MAX = ',PCT_ERR_MAX,'%'
      WRITE(OUNT(2),*)

      IF      (NUM_COEFFS == 1) THEN
         WRITE(OUNT(2),2011) NUM_FITS, NUM_COEFFS
         WRITE(OUNT(2),2021) (B(I), I=0,NUM_COEFFS-1)
      ELSE IF (NUM_COEFFS == 2) THEN
         WRITE(OUNT(2),2012) NUM_FITS, NUM_COEFFS
         WRITE(OUNT(2),2022) (B(I), I=0,NUM_COEFFS-1)
      ELSE IF (NUM_COEFFS == 3) THEN
         WRITE(OUNT(2),2013) NUM_FITS, NUM_COEFFS
         WRITE(OUNT(2),2023) (B(I), I=0,NUM_COEFFS-1)
      ELSE IF (NUM_COEFFS == 4) THEN
         WRITE(OUNT(2),2014) NUM_FITS, NUM_COEFFS
         WRITE(OUNT(2),2024) (B(I), I=0,NUM_COEFFS-1)
      ELSE IF (NUM_COEFFS == 5) THEN
         WRITE(OUNT(2),2014) NUM_FITS, NUM_COEFFS
         WRITE(OUNT(2),2025) (B(I), I=0,NUM_COEFFS-1)
      ELSE IF (NUM_COEFFS == 6) THEN
         WRITE(OUNT(2),2014) NUM_FITS, NUM_COEFFS
         WRITE(OUNT(2),2026) (B(I), I=0,NUM_COEFFS-1)
      ENDIF
      WRITE(OUNT(2),*)

      IF (RES_ABS > 0) THEN
         WRITE(OUNT(2),2031)
      ELSE
         WRITE(OUNT(2),2032)
      ENDIF

      DO II=1,NUM_FITS
         IF (DABS(WI_MAX) > 0.0) THEN
            WRITE(OUNT(2),2051) II, XI(II), YI(II), WI(II), WF(II), RES(II), POLY_PCT_ERR(II)
         ELSE
            WRITE(OUNT(2),2052) II, XI(II), YI(II), WI(II), WF(II), RES(II)
         ENDIF
      ENDDO

      WRITE(OUNT(2),*)
      WRITE(OUNT(2),2061)
      DO II=1,NUM_FITS
         WRITE(OUNT(2),2062) II, XO(II), YO(II), WO(II)
      ENDDO

! **********************************************************************************************************************************
 2000 FORMAT(' ******************************************************************************************************************',&
             '******************')

 2001 FORMAT(' Return code from polynomial fit: IFAULT = ',I3,/)

 2011 FORMAT(' Fitted quadratic surface for ',I2,' data points using a ',I2,'st order polynomial:',/,                              &
             ' -------------------------------------------------------------------------')

 2012 FORMAT(' Fitted quadratic surface for ',I2,' data points using a ',I2,'nd order polynomial:',/,                              &
             ' -------------------------------------------------------------------------')

 2013 FORMAT(' Fitted quadratic surface for ',I2,' data points using a ',I2,'rd order polynomial:',/,                              &
             ' -------------------------------------------------------------------------')

 2014 FORMAT(' Fitted quadratic surface for ',I2,' data points using a ',I2,'th order polynomial:',/,                              &
             ' -------------------------------------------------------------------------')

 2021 FORMAT('  Y = B0                                              ',//,                                                          &
             '      where: B0 = ',1ES14.6,/)

 2022 FORMAT('  Y = B0 + B1*X1                                      ',//,                                                          &
             '      where: B0 = ',1ES14.6,/,                                                                                &
             '             B1 = ',1ES14.6,/)

 2023 FORMAT('  Y = B0 + B1*X1 + B2*X2                              ',//,                                                          &
             '      where: B0 = ',1ES14.6,/,                                                                                &
             '             B1 = ',1ES14.6,/,                                                                                &
             '             B2 = ',1ES14.6,/)

 2024 FORMAT('  Y = B0 + B1*X1 + B2*X2 + B3*X1^2                    ',//,                                                          &
             '      where: B0 = ',1ES14.6,/,                                                                                &
             '             B1 = ',1ES14.6,/,                                                                                &
             '             B2 = ',1ES14.6,/,                                                                                &
             '             B3 = ',1ES14.6,/)

 2025 FORMAT('  Y = B0 + B1*X1 + B2*X2 + B3*X1^2 +B4*X1*Y1          ',//,                                                          &
             '      where: B0 = ',1ES14.6,/,                                                                                &
             '             B1 = ',1ES14.6,/,                                                                                &
             '             B2 = ',1ES14.6,/,                                                                                &
             '             B3 = ',1ES14.6,/,                                                                                &
             '             B4 = ',1ES14.6,/)

 2026 FORMAT('  Y = B0 + B1*X1 + B2*X2 +B3*X1^2 + B4*X1*Y1 + B5*Y2^2',//,                                                          &
             '      where: B0 = ',1ES14.6,/,                                                                                &
             '             B1 = ',1ES14.6,/,                                                                                &
             '             B2 = ',1ES14.6,/,                                                                                &
             '             B3 = ',1ES14.6,/,                                                                                &
             '             B4 = ',1ES14.6,/,                                                                                &
             '             B5 = ',1ES14.6,/)

 2031 FORMAT(' Comparison of actual data to fitted curve:',/,' -----------------------------------------',/,                       &
             '     I      XI(I)         YI(I)         WI(I)         WF(I)       WI - WF       Err')

 2032 FORMAT(' Comparison of actual data to fitted curve:',/,' -----------------------------------------',/,                       &
             '     I      XI(I)         YI(I)         WI(I)         WF(I)       WI - WF')

 2051 FORMAT(I6,5(1ES14.6),F8.3,'%')

 2052 FORMAT(I6,5(1ES14.6))

 2061 FORMAT(' Polynomial values at output data points:',/,' -----------------------------------------',/,                       &
             '     I      XO(I)         YO(I)         WO(I)')

 2062 FORMAT(I6,3(1ES14.6))

! **********************************************************************************************************************************

      END SUBROUTINE DEB_SURFACE_FIT

      END SUBROUTINE SURFACE_FIT


!*****************************************************************************************
!> author: Jacob Williams
!
!  Time conversion routines.

    module time_module

    use kind_module

    implicit none

    private

    !parameters:
    real(wp),parameter :: jd_j2000 = 2451545.0_wp  !! julian date of J2000 epoch

    interface julian_date
        !! calendar date to julian date
        module procedure :: julian_date_realsec, &
                            julian_date_intsec
    end interface

    !public routines:
    public :: julian_day
    public :: julian_date
    public :: et_to_jd
    public :: jd_to_et
    public :: jd_to_mjd
    public :: mjd_to_jd

    !test routine:
    public :: time_module_test

    contains
!*****************************************************************************************

!*****************************************************************************************
!> author: Jacob Williams
!  date: 2/3/2015
!
!  Convert ephemeris time (seconds from J2000 epoch) to Julian date.

    pure function et_to_jd(et) result(jd)

    use conversion_module, only: sec2day

    implicit none

    real(wp),intent(in) :: et   !! ephemeris time [sec from J2000 epoch]
    real(wp)            :: jd   !! Julian date [days]

    jd = jd_j2000 + et*sec2day

    end function et_to_jd
!*****************************************************************************************

!*****************************************************************************************
!> author: Jacob Williams
!  date: 3/19/2016
!
!  Convert Julian date to ephemeris time (seconds from J2000 epoch).

    pure function jd_to_et(jd) result(et)

    use conversion_module, only: day2sec

    implicit none

    real(wp),intent(in) :: jd   !! Julian date [days]
    real(wp)            :: et   !! ephemeris time [sec from J2000 epoch]

    et = (jd - jd_j2000) * day2sec

    end function jd_to_et
!*****************************************************************************************

!*****************************************************************************************
!> author: Jacob Williams
!  date: 3/15/2015
!
!  Converts Julian date to Modified Julian date.
!
!### Reference
!   * [USNO](http://tycho.usno.navy.mil/mjd.html)

    pure function jd_to_mjd(jd) result(mjd)

    implicit none

    real(wp)            :: mjd  !! modified julian date
    real(wp),intent(in) :: jd   !! julian date

    mjd = jd - 2400000.5_wp

    end function jd_to_mjd
!*****************************************************************************************

!*****************************************************************************************
!> author: Jacob Williams
!  date: 3/15/2015
!
!  Converts Modified Julian date to Julian date.
!
!### Reference
!   * [USNO](http://tycho.usno.navy.mil/mjd.html)

    pure function mjd_to_jd(mjd) result(jd)

    implicit none

    real(wp)            :: jd   !! julian date
    real(wp),intent(in) :: mjd  !! modified julian date

    jd = mjd + 2400000.5_wp

    end function mjd_to_jd
!*****************************************************************************************

!*****************************************************************************************
!> author: Jacob Williams
!
!  Returns the Julian day number (i.e., the Julian date at Greenwich noon)
!  on the specified YEAR, MONTH, and DAY.
!
!  Valid for any Gregorian calendar date producing a
!  Julian date greater than zero.
!
!### Reference
!   * [USNO](http://aa.usno.navy.mil/faq/docs/JD_Formula.php)

    pure integer function julian_day(y,m,d)

    implicit none

    integer,intent(in) :: y   !! year (YYYY)
    integer,intent(in) :: m   !! month (MM)
    integer,intent(in) :: d   !! day (DD)

    julian_day = d-32075+1461*(y+4800+(m-14)/12)/4+367*&
                 (m-2-(m-14)/12*12)/12-3*((y+4900+(m-14)/12)/100)/4

    end function julian_day
!*****************************************************************************************

!*****************************************************************************************
!> author: Jacob Williams
!  date: 1/21/2015
!
!  Returns the Julian date for the specified YEAR, MONTH, DAY, HR, MIN, SEC.
!
!  Valid for any Gregorian calendar date producing a
!  Julian date greater than zero.
!
!### History
!  * JW : 10/4/2017 : moved main code to [[julian_date_realsec]] routine.

    pure function julian_date_intsec(y,m,d,hour,minute,second) result(julian_date)

    implicit none

    real(wp)           :: julian_date
    integer,intent(in) :: y
    integer,intent(in) :: m
    integer,intent(in) :: d
    integer,intent(in) :: hour
    integer,intent(in) :: minute
    integer,intent(in) :: second

    ! call the other routine:
    julian_date = julian_date_realsec(y,m,d,hour,minute,real(second,wp))

    end function julian_date_intsec
!*****************************************************************************************

!*****************************************************************************************
!> author: Jacob Williams
!  date: 1/21/2015
!
!  Returns the Julian date for the specified YEAR, MONTH, DAY, HR, MIN, SEC.
!
!  Valid for any Gregorian calendar date producing a
!  Julian date greater than zero.
!
!### History
!  * JW : 10/4/2017 : made `second` a real value & renamed routine.

    pure function julian_date_realsec(y,m,d,hour,minute,second) result(julian_date)

    implicit none

    real(wp)            :: julian_date
    integer,intent(in)  :: y
    integer,intent(in)  :: m
    integer,intent(in)  :: d
    integer,intent(in)  :: hour
    integer,intent(in)  :: minute
    real(wp),intent(in) :: second

    integer :: julian_day_number

    julian_day_number = julian_day(y,m,d)

    julian_date = real(julian_day_number,wp) + &
                    (hour-12.0_wp)/24.0_wp + &
                    minute/1440.0_wp + &
                    second/86400.0_wp

    end function julian_date_realsec
!*****************************************************************************************

!*****************************************************************************************
!> author: Jacob Williams
!  date: 1/21/2015
!
!  Test routine for the Julian date routines.

    subroutine time_module_test()

    implicit none

    write(*,*) ''
    write(*,*) '---------------'
    write(*,*) ' time_module_test'
    write(*,*) '---------------'
    write(*,*) ''

    ! JD = 2451545.0
    write(*,*) julian_date(2000,1,1,12,0,0)

    end subroutine time_module_test
!*****************************************************************************************

!*****************************************************************************************
    end module time_module
!*****************************************************************************************


! Interface routine for uni-dimensional optimization through
! polynomial approximation.
! Igor Lopes, February 2015
SUBROUTINE POLYINT
    IMPLICIT NONE

    REAL(8) R0 /0.0D0/
    REAL(8) R1 /1.0D0/
    REAL(8) R2 /2.0D0/
    REAL(8) R5 /5.0D0/

    REAL(8),DIMENSION(4) ::  X,F
    REAL(8) ::  XMIN, FMIN
    INTEGER ::  NPOLY
    CHARACTER STRING*256

    ! Innititalization
    X=R0; F=R0

101 FORMAT('Linear approximation: F=a0+a1*X')
102 FORMAT('Quadratic approximation: F=a0+a1*X+a2*X^2')
103 FORMAT('Cubic approximation: F=a0+a1*X+a2*X^2+a3*X^3')
110 FORMAT("Insert derivative F'_1")
111 FORMAT('Insert point X_1,F_1')
112 FORMAT('Insert point X_2,F_2')
113 FORMAT('Insert point X_3,F_3')
114 FORMAT('Insert point X_4,F_4')
120 FORMAT("F'_1=",F10.5)
121 FORMAT('X_1=',F10.5,2X,'F_1=',F10.5)
122 FORMAT('X_2=',F10.5,2X,'F_2=',F10.5)
123 FORMAT('X_3=',F10.5,2X,'F_3=',F10.5)
124 FORMAT('X_4=',F10.5,2X,'F_4=',F10.5)
    ! Begin algorithm
10  WRITE(*,*)'Choose kind of polynomial approximation:'
    WRITE(*,*)'1 - Linear 1-point'
    WRITE(*,*)'2 - Linear 2-point'
    WRITE(*,*)'3 - Quadratic 2-point'
    WRITE(*,*)'4 - Quadratic 3-point'
    WRITE(*,*)'5 - Cubic 3-point'
    WRITE(*,*)'6 - Cubic 4-point'
    WRITE(*,*)'0 - QUIT'
    READ(*,*) NPOLY

    SELECT CASE(NPOLY)
    CASE(0)
        WRITE(*,*)'CLOSING...'
        STOP
    CASE(1)
        STRING='linear1.res'
        CALL RESULTFILE(STRING)
        WRITE(11,101)
        WRITE(*,101)
        WRITE(*,111);READ(*,*)X(1),F(1)
        WRITE(*,110);READ(*,*)F(2)
        WRITE(11,121)X(1),F(1)
        WRITE(11,120)F(2)
        CALL POLYLIN(1,X,F)
    CASE(2)
        STRING='linear2.res'
        CALL RESULTFILE(STRING)
        WRITE(11,101)
        WRITE(*,101)
        WRITE(*,111);READ(*,*)X(1),F(1)
        WRITE(*,112);READ(*,*)X(2),F(2)
        WRITE(11,121)X(1),F(1)
        WRITE(11,122)X(2),F(2)
        CALL POLYLIN(2,X,F)
    CASE(3)
        STRING='quadratic2.res'
        CALL RESULTFILE(STRING)
        WRITE(11,102)
        WRITE(*,102)
        WRITE(*,111);READ(*,*)X(1),F(1)
        WRITE(*,110);READ(*,*)F(3)
        WRITE(*,112);READ(*,*)X(2),F(2)
        WRITE(11,121)X(1),F(1)
        WRITE(11,120)F(3)
        WRITE(11,122)X(2),F(2)
        CALL POLYQUAD(2,X,F,XMIN,FMIN)
    CASE(4)
        STRING='quadratic3.res'
        CALL RESULTFILE(STRING)
        WRITE(11,102)
        WRITE(*,102)
        WRITE(*,111);READ(*,*)X(1),F(1)
        WRITE(*,112);READ(*,*)X(2),F(2)
        WRITE(*,113);READ(*,*)X(3),F(3)
        WRITE(11,121)X(1),F(1)
        WRITE(11,122)X(2),F(2)
        WRITE(11,123)X(3),F(3)
        CALL POLYQUAD(3,X,F,XMIN,FMIN)
    CASE(5)
        STRING='cubic3.res'
        CALL RESULTFILE(STRING)
        WRITE(11,103)
        WRITE(*,103)
        WRITE(*,110);READ(*,*)F(4)
        WRITE(*,111);READ(*,*)X(1),F(1)
        WRITE(*,112);READ(*,*)X(2),F(2)
        WRITE(*,113);READ(*,*)X(3),F(3)
        WRITE(11,121)X(1),F(1)
        WRITE(11,120)F(4)
        WRITE(11,122)X(2),F(2)
        WRITE(11,123)X(3),F(3)
        CALL POLYCUBIC(3,X,F,XMIN,FMIN)
    CASE(6)
        STRING='cubic4.res'
        CALL RESULTFILE(STRING)
        WRITE(11,103)
        WRITE(*,103)
        WRITE(*,111);READ(*,*)X(1),F(1)
        WRITE(*,112);READ(*,*)X(2),F(2)
        WRITE(*,113);READ(*,*)X(3),F(3)
        WRITE(*,114);READ(*,*)X(4),F(4)
        WRITE(11,121)X(1),F(1)
        WRITE(11,122)X(2),F(2)
        WRITE(11,123)X(3),F(3)
        WRITE(11,124)X(4),F(4)
        CALL POLYCUBIC(4,X,F,XMIN,FMIN)
    CASE DEFAULT
        WRITE(*,*)'Invalid option!'
        GOTO 10
    END SELECT
    CLOSE(UNIT=11)
END SUBROUTINE


      program main
      use timers
      type(TimerType) :: gbTime

      integer maxn,n,i
      parameter (n=20000)
      integer numpairs(n)
C
      call TimerCreate(gbTime,"goldbach")
C
      do i=1,n
         numpairs(i) = 0
      end do
C
C FIND NO. OF GOLDBACH PAIRS FOR THE FIRST n EVEN NUMBERS
C
      call TimerOn(gbTime)
!$omp parallel do default (none) private (i)
!$omp+  shared (numpairs) schedule(static)
      do i=1,n
         call goldbach(2*i,numpairs(i))
      end do
      call TimerOff(gbTime)
C
C  OUTPUT SELECTED RESULTS
C
      do i=1,n,n/10
         print *, 2*i, numpairs(i)
      end do
C
C  OUTPUT TIMING DATA
C
      call TimerPrint(gbTime)
C
      stop
      end
C
      subroutine goldbach(evenno,numpairs)
c
      integer evenno,numpairs,j
      logical isprime
c
C
C TEST ALL PAIRS WHICH SUM TO evenno FOR PRIMALITY
C
      do j=2,evenno/2
         if (isprime(j).and.isprime(evenno-j)) numpairs = numpairs+1
      end do
c
      return
      end
c
c
c
      logical function isprime(num)
c
      integer num,i
c
C
C CRUDE PRIMALITY TEST: CHECK ALL INTEGERS LESS THAN SQARE ROOT
C OF NUMBER
C
      isprime = .true.
      i=2
      do while ( (i.le.(int(sqrt(real(num)))) ) .and. isprime)
         isprime = mod(num,i).ne.0
         i=i+1
      end do
c
      return
      end


c----------------------------------------------------------------
c----------------------------------------------------------------
c--- The root model example of lsodar
c----------------------------------------------------------------
c----------------------------------------------------------------

c -------- lsodarfor.f -> lsodarfor.dll ------
c compile in R with: system("g77 -shared -o lsodarfor.dll lsodarfor.f")
c or with system("R CMD SHLIB lsodarfor.f")

c----------------------------------------------------------------
c Initialiser for parameter common block
c----------------------------------------------------------------
      subroutine lsodarfor(odeparms)

      external odeparms
      integer, parameter :: N = 3
      double precision parms(N)
      common /myparms/parms

      call odeparms(N, parms)
      return
      end

c----------------------------------------------------------------
c rate of change and 1 output variable
c----------------------------------------------------------------
      subroutine modfor(neq, t, y, ydot,out,IP)
      integer          neq, IP(*)
      double precision t, y(neq), ydot(neq), out(*), aa, bb, cc
      common /myparms/aa,bb,cc

      if(IP(1) < 1) call rexit("nout should be at least 1")
      ydot(1) = aa*y(1) + bb*y(2)*y(3)
      ydot(3) = cc*y(2)*y(2)
      ydot(2) = -ydot(1) - ydot(3)
      out(1)=y(1)+y(2)+y(3)

      return
      end

c----------------------------------------------------------------
c The root function
c----------------------------------------------------------------
      subroutine myroot(neq, t, y, ng, gout)
      integer :: neq, ng
      double precision :: t, y(neq), gout(ng)

      gout(1) = y(1) - 1.e-4
      gout(2) = y(3) - 1e-2

      return
      end


SUBROUTINE initialdata(Nx,Ny,Nz,x,y,z,u,v,decomp)
	!--------------------------------------------------------------------
	!
	!
	! PURPOSE
	!
	! This subroutine gets initial data for Brusselator equation
	! in 3 dimensions
	! u_t = a + u^2v - (b+1)u + Du u_xx
    ! v_t = bu - u^2v + Dv v_xx
	!
	! The boundary conditions are u(x=-Lx*\pi,y,z)=u(x=Lx*\pi,y,z),
	!	u(x,y=-Ly*\pi,z)=u(x,y=Ly*\pi,z),u(x,y,z=-Ly*\pi)=u(x,y,z=Ly*\pi)
	! The initial condition is
	! u=0.5+exp(-1.0-(x**2+y**2+z**2))
    ! v=0.1+exp(-1.0-(x**2+y**2+z**2))
	!
	! INPUT
	!
	! .. Parameters ..
	!  Nx				= number of modes in x - power of 2 for FFT
	!  Ny				= number of modes in y - power of 2 for FFT
	!  Nz				= number of modes in z - power of 2 for FFT
	! .. Vectors ..
	!  x				= x locations
	!  y				= y locations
	!  z				= z locations
	! .. Special Structures ..
	!  decomp			= contains information on domain decomposition
	!					see http://www.2decomp.org/ for more information
	! OUTPUT
	!
	! .. Arrays ..
	!  u 				= initial solution
	!  uold 			= approximate solution based on time derivative of
	!					initial solution
	!
	! LOCAL VARIABLES
	!
	! .. Scalars ..
	!  i				= loop counter in x direction
	!  j				= loop counter in y direction
	!  k				= loop counter in z direction
	!
	! REFERENCES
	!
	! ACKNOWLEDGEMENTS
	!
	! ACCURACY
	!
	! ERROR INDICATORS AND WARNINGS
	!
	! FURTHER COMMENTS
	! Check that the initial iterate is consistent with the
	! boundary conditions for the domain specified
	!--------------------------------------------------------------------
	! External routines required
	!
	! External libraries required
	! 2DECOMP&FFT	 -- Domain decomposition and Fast Fourier Library
	!			(http://www.2decomp.org/index.html)
	! MPI library
	USE decomp_2d
	IMPLICIT NONE
	INCLUDE 'mpif.h'
	! Declare variables
	INTEGER(KIND=4), INTENT(IN)							:: Nx,Ny,Nz
	TYPE(DECOMP_INFO), INTENT(IN)						::  decomp
	REAL(KIND=8), DIMENSION(decomp%xst(1):decomp%xen(1)), INTENT(IN) :: x
	REAL(KIND=8), DIMENSION(decomp%xst(2):decomp%xen(2)), INTENT(IN) :: y
	REAL(KIND=8), DIMENSION(decomp%xst(3):decomp%xen(3)), INTENT(IN) :: z
	COMPLEX(KIND=8), DIMENSION(decomp%xst(1):decomp%xen(1),&
   							decomp%xst(2):decomp%xen(2),&
   							decomp%xst(3):decomp%xen(3)),&
   											INTENT(OUT) :: u,v
	INTEGER(kind=4)										:: i,j,k

    DO k=decomp%xst(3),decomp%xen(3); DO j=decomp%xst(2),decomp%xen(2); DO i=decomp%xst(1),decomp%xen(1)
	 u(i,j,k)=15.0d0+8.0d0*sin(2.0*x(i))*cos(2.0*y(j)) !*exp(-4.0*(x(i)**2+y(j)**2+0.0d0*z(k)**2))
     v(i,j,k)=0.10d0 +0.75d0*exp(-4.0d0*(x(i)**2+y(j)**2+0.0d0*z(k)**2))
    END DO; END DO; END DO
	END SUBROUTINE initialdata


module qutraj_precision
  ! Module for setting working precision

  implicit none

  !integer, parameter :: sp = kind(1.0e0) ! single precision
  !integer, parameter :: dp = kind(1.0d0) ! double precision
  integer, parameter :: sp = selected_real_kind(6,37) ! single precision
  integer, parameter :: dp = selected_real_kind(15,307) ! double precision
  integer, parameter :: wp = dp ! working precision

  ! small and large number
  real, parameter :: epsi=5*epsilon(1.0)
  real, parameter :: huge1=0.2*huge(1.0)

end module


subroutine array_sqrt(n, a_in, a_out)

  implicit none
  integer, intent(in) :: n
  real, dimension(n), intent(in)  :: a_in
  real, dimension(n), intent(out) :: a_out

  integer :: i

  do i = 1, n
     a_out(i) = sqrt(a_in(i))
  end do

  return

end subroutine array_sqrt


lambda x:<a:Bool,b:Bool>. x;

unit;
lambda x:Nat. succ x;
(lambda x:Nat. succ (succ x)) (succ 0);
timesfloat 2.0 3.14159;

{x=true, y=false};
{x=true, y=false}.x;
{true, false};
{true, false}.1;
({{"00","11"},{"22","33"}}.2 as {String, String}).1;

PhysicalAddr = {firstlast:String, addr:String};
VirtualAddr= {name:String, email:String};
Addr = <physical:PhysicalAddr, virtual:VirtualAddr>;
pa = {firstlast="Mike", addr="Unknown"}: PhysicalAddr;
a = <physical= pa> as Addr;

getName = \a:Addr.
case a of
	<physical=x> => x.firstlast
	| <virtual=y> => y.name;
    a;
{hell= a, c=getName a};
getName a;

equal = fix (
    \eq:Nat->Nat->Bool m:Nat n:Nat.
        if iszero m
            then iszero n
        else if iszero n
            then false
        else
            eq (pred m) (pred n)
    );

OptionalNat = <none:Unit, some:Nat>;
Table = Nat -> OptionalNat;
emptyTable =\n:Nat . <none=()> as OptionalNat: Table;
extendTable = \t:Table m:Nat v:Nat n:Nat.
    if equal n m
        then <some=v> as OptionalNat
        else t n
    : Table -> Nat -> Nat -> Table;

emptyTable 10;
ta = extendTable emptyTable 10 5;
ta 10;


PROGRAM TEST
! Driver code for computing the list of Delaunay neighbors of a given vertex.
! Reads a file containing a list of N vertices in R^D and constructs the
! umbrella neighbourhood of some vertex in that file.
!
! Author: Tyler Chang
! Last Update: August, 2017
!
! Usage :$ ./delneighbors D N V FILENAME
!
! D is an integer specifying the dimension of problem.
! N is an integer specifying the number of lines (vertices) in the file.
! V is an integer specifying the index of vertex to compute the umbrella
!    neighbourhood about.
! FILENAME gives the input file path (32 chars max).
USE DELAUNAYNEIGHBORS_MOD
IMPLICIT NONE

! Variables and input data.
INTEGER :: D, N, V, ERROR
REAL(KIND=R8), ALLOCATABLE :: PTS(:,:), WEIGHTS(:,:), WORK(:)
REAL(KIND=R8) :: START, FINISH
INTEGER, ALLOCATABLE :: NEIGHBORS(:)
INTEGER :: I, J
CHARACTER(LEN=80) :: ARG

! Read the values of D, N, V, and FILENAME from the command line.
CALL GET_COMMAND_ARGUMENT(1, ARG)
READ(ARG, *) D
CALL GET_COMMAND_ARGUMENT(2, ARG)
READ(ARG, *) N
CALL GET_COMMAND_ARGUMENT(3, ARG)
READ(ARG, *) V
CALL GET_COMMAND_ARGUMENT(4, ARG)

! Allocate memory to store inputs.
ALLOCATE(PTS(D,N), WORK(5*D), STAT=I)
IF (I .NE. 0) PRINT *, 'Warning: Malloc Fail!'

! Read data from input file.
OPEN(1, FILE=TRIM(ARG))
DO I = 1, N
   READ(1, *) PTS(:, I)
END DO
CLOSE(1)

! Get the results and record the computation time.
CALL CPU_TIME(START)
CALL DELAUNAYNEIGHBORS(D, N, PTS, V, NEIGHBORS, ERROR, IBUDGET=10000)
CALL CPU_TIME(FINISH)
FINISH = FINISH - START
! Print the timing results.
IF(ERROR .LE. 1) THEN
   PRINT *, 'Neighbor List: '
   PRINT *, NEIGHBORS(:)
   PRINT *, ''
   IF (ERROR .EQ. 1) PRINT *, 'Vertex ', V, ' is a vertex of the convex hull.'
   PRINT *, ''
ELSE
   PRINT *, 'Error. Code = ', ERROR
END IF
PRINT *, 'Neighborhood of ', SIZE(NEIGHBORS,1), ' neighbors found in ', &
       & FINISH, ' seconds.'

! Free the heap memory.
DEALLOCATE(PTS, NEIGHBORS, WORK, STAT=ERROR)
IF (ERROR .NE. 0) PRINT *, 'There was an error freeing memory.'
RETURN
END PROGRAM TEST


          program demo_bit_size
          use,intrinsic :: iso_fortran_env, only : int8, int16, int32, int64
          implicit none
          integer(kind=int64)          :: answer
          integer                      :: ilen
             write(*,'(i0)')bit_size(bit_size(0_int8))
             write(*,'(i0)')bit_size(bit_size(0_int16))
             write(*,'(i0)')bit_size(bit_size(0_int32))
             write(*,'(i0)')bit_size(bit_size(0_int64))
             answer=0_int64
             ilen=999
             ! notice use of INT(3f)
             ilen=min(ilen,int(bit_size(answer)))
             ! arguments to MIN(3f) would be of different TYPES
             !ilen=min(ilen,bit_size(answer))
             write(*,'(i0)')ilen
          end program demo_bit_size


#include "eiscor.h"
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!
! DOFTDB (Double Orthogonal hessenberg Factored Two by two Diagonal Block)
!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!
! This routine computes a two by two diagonal block of an orthogonal
! upper hessenberg matrix that is stored as a product of givens
! rotations and a diagonal matrix.
!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!
! INPUT VARIABLES:
!
!  N               INTEGER
!                    dimension of matrix
!
!  K               INTEGER
!                    index of the diagonal block
!
!  Q               REAL(8) array of dimension (2*(N-1))
!                    array of generators for givens rotations
!                    generators must be orthogonal to working precision
!
!  D               REAL(8) array of dimension (2*N)
!                    array of generators for complex diagonal matrix
!                    on output contains the eigenvalues
!
! OUTPUT VARIABLES:
!
!  H               COMPLEX(8) array of dimension (2,2)
!                    on exit contains the desired 2x2 block
!
!  INFO            INTEGER
!                    INFO = 0 implies successful computation
!                    INFO = -1 implies N is invalid
!                    INFO = -2 implies K is invalid
!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
subroutine DOFTDB(N,K,Q,D,H,INFO)

  implicit none

  ! input variables
  integer, intent(in) :: N, K
  integer, intent(inout) :: INFO
  real(8), intent(in) :: Q(2*(N-1)), D(2*N)
  real(8), intent(inout) :: H(2,2)

  ! compute variables
  integer :: strt

  ! initialize INFO
  INFO = 0

  ! check input in debug mode
  if (DEBUG) then

    ! check N
    if (N < 2) then
      INFO = -1
      call UARERR(__FILE__,__LINE__,"N must be at least 2",INFO,INFO)
      return
    end if

    ! check K
    if ((K < 1).OR.(K > N-1)) then
      INFO = -2
      call UARERR(__FILE__,__LINE__,"K must be 1 <= K <= N-1",INFO,INFO)
      return
    end if

  end if

  ! set index
  strt = 2*(K-1)

  ! initialize H
  H(1,1) = Q(strt+1)
  H(2,1) = Q(strt+2)
  H(1,2) = -H(2,1)
  H(2,2) = H(1,1)

  ! apply lower rotation
  if(K < (N-1))then
      H(:,2) = H(:,2)*Q(strt+3)
  end if

  ! apply upper rotation
  if (K > 1) then
    H(1,:) = H(1,:)*Q(strt-1)
  end if

  ! apply diagonal
  H(:,1) = H(:,1)*D(strt+1)
  H(:,2) = H(:,2)*D(strt+3)

end subroutine DOFTDB


      INTEGER FUNCTION ignpoi(mu)
C**********************************************************************
C
C     INTEGER FUNCTION IGNPOI( MU )
C
C                    GENerate POIsson random deviate
C
C
C                              Function
C
C
C     Generates a single random deviate from a Poisson
C     distribution with mean MU.
C
C
C                              Arguments
C
C
C     MU --> The mean of the Poisson distribution from which
C            a random deviate is to be generated.
C                              DOUBLE PRECISION MU
C     JJV                    (MU >= 0.0)
C
C     IGNPOI <-- The random deviate.
C                              INTEGER IGNPOI (non-negative)
C
C
C                              Method
C
C
C     Renames KPOIS from TOMS as slightly modified by BWB to use RANF
C     instead of SUNIF.
C
C     For details see:
C
C               Ahrens, J.H. and Dieter, U.
C               Computer Generation of Poisson Deviates
C               From Modified Normal Distributions.
C               ACM Trans. Math. Software, 8, 2
C               (June 1982),163-179
C
C**********************************************************************
C**********************************************************************C
C**********************************************************************C
C                                                                      C
C                                                                      C
C     P O I S S O N  DISTRIBUTION                                      C
C                                                                      C
C                                                                      C
C**********************************************************************C
C**********************************************************************C
C                                                                      C
C     FOR DETAILS SEE:                                                 C
C                                                                      C
C               AHRENS, J.H. AND DIETER, U.                            C
C               COMPUTER GENERATION OF POISSON DEVIATES                C
C               FROM MODIFIED NORMAL DISTRIBUTIONS.                    C
C               ACM TRANS. MATH. SOFTWARE, 8,2 (JUNE 1982), 163 - 179. C
C                                                                      C
C     (SLIGHTLY MODIFIED VERSION OF THE PROGRAM IN THE ABOVE ARTICLE)  C
C                                                                      C
C**********************************************************************C
C
C      INTEGER FUNCTION IGNPOI(IR,MU)
C
C     INPUT:  IR=CURRENT STATE OF BASIC RANDOM NUMBER GENERATOR
C             MU=MEAN MU OF THE POISSON DISTRIBUTION
C     OUTPUT: IGNPOI=SAMPLE FROM THE POISSON-(MU)-DISTRIBUTION
C
C
C
C     MUPREV=PREVIOUS MU, MUOLD=MU AT LAST EXECUTION OF STEP P OR CASE B
C     TABLES: COEFFICIENTS A0-A7 FOR STEP F. FACTORIALS FACT
C     COEFFICIENTS A(K) - FOR PX = FK*V*V*SUM(A(K)*V**K)-DEL
C
C
C
C     SEPARATION OF CASES A AND B
C
C     .. Scalar Arguments ..
      DOUBLE PRECISION mu
C     ..
C     .. Local Scalars ..
      DOUBLE PRECISION a0,a1,a2,a3,a4,a5,a6,a7,b1,b2,c,c0,c1,c2,c3,
     $     d,del,difmuk,e,
     $     fk,fx,fy,g,muold,muprev,omega,p,p0,px,py,q,s,t,u,v,x,xx
C     JJV I added a variable 'll' here - it is the 'l' for CASE A
      INTEGER j,k,kflag,l,ll,m
C     ..
C     .. Local Arrays ..
      DOUBLE PRECISION fact(10),pp(35)
C     ..
C     .. External Functions ..
      DOUBLE PRECISION ranf,sexpo,snorm
      EXTERNAL ranf,sexpo,snorm
C     ..
C     .. Intrinsic Functions ..
      INTRINSIC abs,log,exp,float,idint,max0,min0,dsign,sqrt
C     ..
C     JJV added this for case: mu unchanged
C     .. Save statement ..
      SAVE s, d, l, ll, omega, c3, c2, c1, c0, c, m, p, q, p0,
     +     a0, a1, a2, a3, a4, a5, a6, a7, fact, muprev, muold
C     ..
C     JJV end addition - I am including vars in Data statements
C     .. Data statements ..
C     JJV changed initial values of MUPREV and MUOLD to -1.0E37
C     JJV if no one calls IGNPOI with MU = -1.0E37 the first time,
C     JJV the code shouldn't break
      DATA muprev,muold/-1.0E37,-1.0E37/
      DATA a0,a1,a2,a3,a4,a5,a6,a7/-.5,.3333333,-.2500068,.2000118,
     +     -.1661269,.1421878,-.1384794,.1250060/
      DATA fact/1.,1.,2.,6.,24.,120.,720.,5040.,40320.,362880./
C     ..
C     .. Executable Statements ..

      IF (mu.EQ.muprev) GO TO 10
      IF (mu.LT.10.0) GO TO 120
C
C     C A S E  A. (RECALCULATION OF S,D,LL IF MU HAS CHANGED)
C
C     JJV This is the case where I changed 'l' to 'll'
C     JJV Here 'll' is set once and used in a comparison once

      muprev = mu
      s = sqrt(mu)
      d = 6.0*mu*mu
C
C             THE POISSON PROBABILITIES PK EXCEED THE DISCRETE NORMAL
C             PROBABILITIES FK WHENEVER K >= M(MU). LL=IDINT(MU-1.1484)
C             IS AN UPPER BOUND TO M(MU) FOR ALL MU >= 10 .
C
      ll = idint(mu-1.1484)
C
C     STEP N. NORMAL SAMPLE - SNORM(IR) FOR STANDARD NORMAL DEVIATE
C
   10 g = mu + s*snorm()
      IF (g.LT.0.0) GO TO 20
      ignpoi = idint(g)
C
C     STEP I. IMMEDIATE ACCEPTANCE IF IGNPOI IS LARGE ENOUGH
C
      IF (ignpoi.GE.ll) RETURN
C
C     STEP S. SQUEEZE ACCEPTANCE - SUNIF(IR) FOR (0,1)-SAMPLE U
C
      fk = dble(ignpoi)
      difmuk = mu - fk
      u = ranf()
      IF (d*u.GE.difmuk*difmuk*difmuk) RETURN
C
C     STEP P. PREPARATIONS FOR STEPS Q AND H.
C             (RECALCULATIONS OF PARAMETERS IF NECESSARY)
C             .3989423=(2*PI)**(-.5)  .416667E-1=1./24.  .1428571=1./7.
C             THE QUANTITIES B1, B2, C3, C2, C1, C0 ARE FOR THE HERMITE
C             APPROXIMATIONS TO THE DISCRETE NORMAL PROBABILITIES FK.
C             C=.1069/MU GUARANTEES MAJORIZATION BY THE 'HAT'-FUNCTION.
C
   20 IF (mu.EQ.muold) GO TO 30
      muold = mu
      omega = .3989423/s
      b1 = .4166667E-1/mu
      b2 = .3*b1*b1
      c3 = .1428571*b1*b2
      c2 = b2 - 15.*c3
      c1 = b1 - 6.*b2 + 45.*c3
      c0 = 1. - b1 + 3.*b2 - 15.*c3
      c = .1069/mu
   30 IF (g.LT.0.0) GO TO 50
C
C             'SUBROUTINE' F IS CALLED (KFLAG=0 FOR CORRECT RETURN)
C
      kflag = 0
      GO TO 70
C
C     STEP Q. QUOTIENT ACCEPTANCE (RARE CASE)
C
   40 IF (fy-u*fy.LE.py*exp(px-fx)) RETURN
C
C     STEP E. EXPONENTIAL SAMPLE - SEXPO(IR) FOR STANDARD EXPONENTIAL
C             DEVIATE E AND SAMPLE T FROM THE LAPLACE 'HAT'
C             (IF T <= -.6744 THEN PK < FK FOR ALL MU >= 10.)
C
   50 e = sexpo()
      u = ranf()
      u = u + u - 1.0
      t = 1.8d0 + dsign(e,u)
      IF (t.LE. (-.6744)) GO TO 50
      ignpoi = idint(mu+s*t)
      fk = dble(ignpoi)
      difmuk = mu - fk
C
C             'SUBROUTINE' F IS CALLED (KFLAG=1 FOR CORRECT RETURN)
C
      kflag = 1
      GO TO 70
C
C     STEP H. HAT ACCEPTANCE (E IS REPEATED ON REJECTION)
C
   60 IF (c*abs(u).GT.py*exp(px+e)-fy*exp(fx+e)) GO TO 50
      RETURN
C
C     STEP F. 'SUBROUTINE' F. CALCULATION OF PX,PY,FX,FY.
C             CASE IGNPOI .LT. 10 USES FACTORIALS FROM TABLE FACT
C
   70 IF (ignpoi.GE.10) GO TO 80
      px = -mu
      py = mu**ignpoi/fact(ignpoi+1)
      GO TO 110
C
C             CASE IGNPOI .GE. 10 USES POLYNOMIAL APPROXIMATION
C             A0-A7 FOR ACCURACY WHEN ADVISABLE
C             .8333333E-1=1./12.  .3989423=(2*PI)**(-.5)
C
   80 del = .8333333E-1/fk
      del = del - 4.8*del*del*del
      v = difmuk/fk
      IF (abs(v).LE.0.25) GO TO 90
      px = fk*log(1.0+v) - difmuk - del
      GO TO 100

   90 px = fk*v*v* (((((((a7*v+a6)*v+a5)*v+a4)*v+a3)*v+a2)*v+a1)*v+a0) -
     +     del
  100 py = .3989423/sqrt(fk)
  110 x = (0.5-difmuk)/s
      xx = x*x
      fx = -0.5*xx
      fy = omega* (((c3*xx+c2)*xx+c1)*xx+c0)
      IF (kflag) 40,40,60
C
C     C A S E  B. (START NEW TABLE AND CALCULATE P0 IF NECESSARY)
C
C     JJV changed MUPREV assignment from 0.0 to initial value
  120 muprev = -1.0E37
C     Jpc 1999: the next lines seams to produce a bug
C     and I finaly commented them out
C     IF (mu.EQ.muold) GO TO 130
C     JJV added argument checker here
C     JJV added line label here
C 125  muold = mu
      m = max0(1,idint(mu))
      l = 0
      p = exp(-mu)
      q = p
      p0 = p
C
C     STEP U. UNIFORM SAMPLE FOR INVERSION METHOD
C
  130 u = ranf()
      ignpoi = 0
      IF (u.LE.p0) RETURN
C
C     STEP T. TABLE COMPARISON UNTIL THE END PP(L) OF THE
C             PP-TABLE OF CUMULATIVE POISSON PROBABILITIES
C             (0.458=PP(9) FOR MU=10)
C
      IF (l.EQ.0) GO TO 150
      j = 1
      IF (u.GT.0.458) j = min0(l,m)
      DO 140 k = j,l
          IF (u.LE.pp(k)) GO TO 180
  140 CONTINUE
      IF (l.EQ.35) GO TO 130
C
C     STEP C. CREATION OF NEW POISSON PROBABILITIES P
C             AND THEIR CUMULATIVES Q=PP(K)
C
  150 l = l + 1
      DO 160 k = l,35
          p = p*mu/float(k)
          q = q + p
          pp(k) = q
          IF (u.LE.q) GO TO 170
  160 CONTINUE
      l = 35
      GO TO 130

  170 l = k
  180 ignpoi = k
      RETURN

      END


      SUBROUTINE fft99(a, work, trigs, ifax, inc, jump, n, lot, isign)
      USE stel_kinds
      IMPLICIT NONE
C-----------------------------------------------
C   D u m m y   A r g u m e n t s
C-----------------------------------------------
      INTEGER inc, jump, n, lot, isign
      INTEGER :: ifax(13)
      REAL(rprec) :: a(lot*(n+2)), work(lot*(n+1)), trigs(3*n/2+1)
C-----------------------------------------------
C   L o c a l   V a r i a b l e s
C-----------------------------------------------
      INTEGER::nfax,nx,nh,ink,igo,ibase,jbase,l,i,j,m,ia,la,k,ib
C-----------------------------------------------
c
c purpose      performs multiple fast fourier transforms.  this package
c              will perform a number of simultaneous REAL/half-complex
c              periodic fourier transforms or corresponding inverse
c              transforms, i.e.  given a set of REAL data vectors, the
c              package returns a set of "half-complex" fourier
c              coefficient vectors, or vice versa.  the length of the
c              transforms must be an even number greater than 4 that has
c              no other factors except possibly powers of 2, 3, and 5.
c              this is an ALL fortran version of the craylib package
c              that is mostly written in cal.
c
c              the package fft99f CONTAINS several user-level routines:
c
c            SUBROUTINE fftfax
c                an initialization routine that must be called once
c                before a sequence of calls to the fft routines
c                (provided that n is not changed).
c
c            SUBROUTINEs fft99 and fft991
c                two fft routines that RETURN slightly different
c                arrangements of the data in gridpoint space.
c
c
c access       this fortran version may be accessed with
c
c                   *fortran,p=xlib,sn=fft99f
c
c              to access the cray object code, CALLing the user ENTRY
c              points from a cray PROGRAM is sufficient.  the source
c              fortran and cal code for the craylib version may be
c              accessed using
c
c                   fetch p=craylib,sn=fft99
c
c usage        let n be of the form 2**p * 3**q * 5**r, WHERE p .ge. 1,
c              q .ge. 0, and r .ge. 0.  THEN a typical sequence of
c              calls to transform a given set of REAL vectors of length
c              n to a set of "half-complex" fourier coefficient vectors
c              of length n is
c
c                   DIMENSION ifax(13),trigs(3*n/2+1),a(m*(n+2)),
c                  +          work(m*(n+1))
c
c                   CALL fftfax (n, ifax, trigs)
c                   CALL fft99 (a,work,trigs,ifax,inc,jump,n,m,isign)
c
c              see the individual WRITE-ups for fftfax, fft99, and
c              fft991 below, for a detailed description of the
c              arguments.
c
c history      the package was written by clive temperton at ecmwf in
c              november, 1978.  it was modified, documented, and tested
c              for ncar by russ rew in september, 1980.
c
c-----------------------------------------------------------------------
c
c SUBROUTINE fftfax (n,ifax,trigs)
c
c purpose      a set-up routine for fft99 and fft991.  it need ONLY be
c              called once before a sequence of calls to the fft
c              routines (provided that n is not changed).
c
c argument     ifax(13),trigs(3*n/2+1)
c dimensions
c
c arguments
c
c on input     n
c               an even number greater than 4 that has no prime factor
c               greater than 5.  n is the length of the transforms (see
c               the documentation for fft99 and fft991 for the
c               definitions of the transforms).
c
c              ifax
c               an INTEGER array.  the number of elements actually used
c               will depend on the factorization of n.  dimensioning
c               ifax for 13 suffices for ALL n less than a million.
c
c              trigs
c               a floating point array of DIMENSION 3*n/2 IF n/2 is
c               even, or 3*n/2+1 IF n/2 is odd.
c
c on output    ifax
c               CONTAINS the factorization of n/2.  ifax(1) is the
c               number of factors, and the factors themselves are stored
c               in ifax(2),ifax(3),...  IF fftfax is called with n odd,
c               or IF n has ANY prime factors greater than 5, ifax(1)
c               is set to -99.
c
c              trigs
c               an array of trignomentric FUNCTION values subsequently
c               used by the fft routines.
c
c-----------------------------------------------------------------------
c
c SUBROUTINE fft991 (a,work,trigs,ifax,inc,jump,n,m,isign)
c                       and
c SUBROUTINE fft99 (a,work,trigs,ifax,inc,jump,n,m,isign)
c
c purpose      perform a number of simultaneous REAL/half-complex
c              periodic fourier transforms or corresponding inverse
c              transforms, using ordinary spatial order of gridpoint
c              values (fft991) or explicit cyclic continuity in the
c              gridpoint values (fft99).  given a set
c              of REAL data vectors, the package returns a set of
c              "half-complex" fourier coefficient vectors, or vice
c              versa.  the length of the transforms must be an even
c              number that has no other factors except possibly powers
c              of 2, 3, and 5.  these version of fft991 and fft99 are
c              optimized for USE on the cray-1.
c
c argument     a(m*(n+2)), work(m*(n+1)), trigs(3*n/2+1), ifax(13)
c dimensions
c
c arguments
c
c on input     a
c               an array of length m*(n+2) containing the input data
c               or coefficient vectors.  this array is overwritten by
c               the results.
c
c              work
c               a work array of DIMENSION m*(n+1)
c
c              trigs
c               an array set up by fftfax, which must be called first.
c
c              ifax
c               an array set up by fftfax, which must be called first.
c
c              inc
c               the increment (in words) between successive elements of
c               each data or coefficient vector (e.g.  inc=1 for
c               consecutively stored data).
c
c              jump
c               the increment (in words) between the first elements of
c               successive data or coefficient vectors.  on the cray-1,
c               try to arrange data so that jump is not a multiple of 8
c               (to avoid memory bank conflicts).  for clarification of
c               inc and jump, see the examples below.
c
c              n
c               the length of each transform (see definition of
c               transforms, below).
c
c              m
c               the number of transforms to be done simultaneously.
c
c              isign
c               = +1 for a transform from fourier coefficients to
c                    gridpoint values.
c               = -1 for a transform from gridpoint values to fourier
c                    coefficients.
c
c on output    a
c               IF isign = +1, and m coefficient vectors are supplied
c               each containing the sequence:
c
c               a(0),b(0),a(1),b(1),...,a(n/2),b(n/2)  (n+2 values)
c
c               THEN the result consists of m data vectors each
c               containing the corresponding n+2 gridpoint values:
c
c               for fft991, x(0), x(1), x(2),...,x(n-1),0,0.
c               for fft99, x(n-1),x(0),x(1),x(2),...,x(n-1),x(0).
c                   (explicit cyclic continuity)
c
c               when isign = +1, the transform is defined by:
c                 x(j)=SUM(k=0,...,n-1)(c(k)*EXP(2*i*j*k*pi/n))
c                 WHERE c(k)=a(k)+i*b(k) and c(n-k)=a(k)-i*b(k)
c                 and i=SQRT (-1)
c
c               IF isign = -1, and m data vectors are supplied each
c               containing a sequence of gridpoint values x(j) as
c               defined above, THEN the result consists of m vectors
c               each containing the corresponding fourier cofficients
c               a(k), b(k), 0 .le. k .le n/2.
c
c               when isign = -1, the inverse transform is defined by:
c                 c(k)=(1/n)*SUM(j=0,...,n-1)(x(j)*EXP(-2*i*j*k*pi/n))
c                 WHERE c(k)=a(k)+i*b(k) and i=SQRT(-1)
c
c               a CALL with isign=+1 followed by a CALL with isign=-1
c               (or vice versa) returns the original data.
c
c               note: the fact that the gridpoint values x(j) are REAL
c               implies that b(0)=b(n/2)=0.  for a CALL with isign=+1,
c               it is not actually necessary to supply these zeros.
c
c examples      given 19 data vectors each of length 64 (+2 for explicit
c               cyclic continuity), compute the corresponding vectors of
c               fourier coefficients.  the data may, for example, be
c               arranged like this:
c
c first data   a(1)=    . . .                a(66)=             a(70)
c vector       x(63) x(0) x(1) x(2) ... x(63) x(0)  (4 empty locations)
c
c second data  a(71)=   . . .                                  a(140)
c vector       x(63) x(0) x(1) x(2) ... x(63) x(0)  (4 empty locations)
c
c               and so on.  here inc=1, jump=70, n=64, m=19, isign=-1,
c               and fft99 should be used (because of the explicit cyclic
c               continuity).
c
c               alternatively the data may be arranged like this:
c
c                first         second                          last
c                data          data                            data
c                vector        vector                          vector
c
c                 a(1)=         a(2)=                           a(19)=
c
c                 x(63)         x(63)       . . .               x(63)
c        a(20)=   x(0)          x(0)        . . .               x(0)
c        a(39)=   x(1)          x(1)        . . .               x(1)
c                  .             .                               .
c                  .             .                               .
c                  .             .                               .
c
c               in which CASE we have inc=19, jump=1, and the remaining
c               parameters are the same as before.  in either CASE, each
c               coefficient vector overwrites the corresponding input
c               data vector.
c
c-----------------------------------------------------------------------
c
c     SUBROUTINE 'fft99' - multiple fast REAL periodic transform
c     corresponding to old scalar routine fft9
c     PROCEDURE used to convert to half-length complex transform
c     is given by cooley, lewis and welch (j. sound vib., vol. 12
c     (1970), 315-337)
c
c     a is the array containing input and output data
c     work is an area of SIZE (n+1)*lot
c     trigs is a previously prepared list of trig FUNCTION values
c     ifax is a previously prepared list of factors of n/2
c     inc is the increment within each data "vector"
c         (e.g. inc=1 for consecutively stored data)
c     jump is the increment between the start of each data vector
c     n is the length of the data vectors
c     lot is the number of data vectors
c     isign = +1 for transform from spectral to gridpoint
c           = -1 for transform from gridpoint to spectral
c
c     ordering of coefficients:
c         a(0),b(0),a(1),b(1),a(2),b(2),...,a(n/2),b(n/2)
c         WHERE b(0)=b(n/2)=0; (n+2) locations required
c
c     ordering of data:
c         x(n-1),x(0),x(1),x(2),...,x(n),x(0)
c         i.e. explicit cyclic continuity; (n+2) locations required
c
c     vectorization is achieved on cray by DOing the transforms in
c     parallel
c
c     *** n.b. n is assumed to be an even number
c
c     definition of transforms:
c     -------------------------
c
c     isign=+1: x(j)=SUM(k=0,...,n-1)(c(k)*EXP(2*i*j*k*pi/n))
c         WHERE c(k)=a(k)+i*b(k) and c(n-k)=a(k)-i*b(k)
c
c     isign=-1: a(k)=(1/n)*SUM(j=0,...,n-1)(x(j)*COS(2*j*k*pi/n))
c               b(k)=-(1/n)*SUM(j=0,...,n-1)(x(j)*SIN(2*j*k*pi/n))
c
      nfax=ifax(1)
      nx=n+1
      nh=n/2
      ink=inc+inc
      IF (isign.eq.+1) GOTO 30
c
c     IF necessary, transfer data to work area
      igo=50
      IF (MOD(nfax,2).eq.1) GOTO 40
      ibase=inc+1
      jbase=1
      DO 20 l=1,lot
      i=ibase
      j=jbase
cdir$ ivdep
      DO 10 m=1,n
      work(j)=a(i)
      i=i+inc
      j=j+1
   10 CONTINUE
      ibase=ibase+jump
      jbase=jbase+nx
   20 CONTINUE
c
      igo=60
      GOTO 40
c
c     preprocessing (isign=+1)
c     ------------------------
c
   30 CONTINUE
      CALL fft99a(a,work,trigs,inc,jump,n,lot)
      igo=60
c
c     complex transform
c     -----------------
c
   40 CONTINUE
      ia=inc+1
      la=1
      DO 80 k=1,nfax
      IF (igo.eq.60) GOTO 60
   50 CONTINUE
      CALL vpassm(a(ia),a(ia+inc),work(1),work(2),trigs,
     *   ink,2,jump,nx,lot,nh,ifax(k+1),la)
      igo=60
      GOTO 70
   60 CONTINUE
      CALL vpassm(work(1),work(2),a(ia),a(ia+inc),trigs,
     *    2,ink,nx,jump,lot,nh,ifax(k+1),la)
      igo=50
   70 CONTINUE
      la=la*ifax(k+1)
   80 CONTINUE
c
      IF (isign.eq.-1) GOTO 130
c
c     IF necessary, transfer data from work area
      IF (MOD(nfax,2).eq.1) GOTO 110
      ibase=1
      jbase=ia
      DO 100 l=1,lot
      i=ibase
      j=jbase
cdir$ ivdep
      DO 90 m=1,n
      a(j)=work(i)
      i=i+1
      j=j+inc
   90 CONTINUE
      ibase=ibase+nx
      jbase=jbase+jump
  100 CONTINUE
c
c     fill in cyclic boundary points
  110 CONTINUE
      ia=1
      ib=n*inc+1
cdir$ ivdep
      DO 120 l=1,lot
      a(ia)=a(ib)
      a(ib+inc)=a(ia+inc)
      ia=ia+jump
      ib=ib+jump
  120 CONTINUE
      GOTO 140
c
c     postprocessing (isign=-1):
c     --------------------------
c
  130 CONTINUE
      CALL fft99b(work,a,trigs,inc,jump,n,lot)
c
  140 CONTINUE

      END SUBROUTINE fft99


      SUBROUTINE HQRII(A,N,M,E,V)
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      INCLUDE 'SIZES/NOLIST'
      DIMENSION A(*), E(N), V(N,M)
*************************************************************
*
* HQRII IS A DIAGONALISATION ROUTINE, WRITTEN BY YOSHITAKA BEPPU OF
*       NAGOYA UNIVERSITY, JAPAN.
*       FOR DETAILS SEE 'COMPUTERS & CHEMISTRY' VOL.6 1982. PAGE 000.
*
* ON INPUT    A       = MATRIX TO BE DIAGONALISED
*             N       = SIZE OF MATRIX TO BE DIAGONALISED.
*             M       = NUMBER OF EIGENVECTORS NEEDED.
*             E       = ARRAY OF SIZE AT LEAST N
*             V       = ARRAY OF SIZE AT LEAST NMAX*M
*
* ON OUTPUT   E       = EIGENVALUES
*             V       = EIGENVECTORS IN ARRAY OF SIZE NMAX*M
*
************************************************************************
      DIMENSION W(5,MAXPAR)
      IF(N.LE.1 .OR. M .LE.1 .OR. M .GT. N) THEN
          IF(N.EQ.1 .AND. M.EQ.1) THEN
              E(1)=A(1)
              V(1,1)=1.D0
              RETURN
          ENDIF
          WRITE(6,'(////10X,''IN HQRII, N ='',I4,'' M ='',I4)')N,M
          STOP
      ENDIF
      EPS3=1.D-30
      ZERO=0.D0
      LL=(N*(N+1))/2+1
      EPS=1.D-8
      IORD=-1
      NM1=N-1
      IF(N.EQ.2) GOTO 80
      NM2=N-2
C     HOUSEHOLDER TRANSFORMATION
      DO 70 K=1,NM2
      KP1=K+1
      W(2,K)=A((K*(K+1))/2)
      SUM=0.
      DO 10 J=KP1,N
          W(2,J)=A((J*(J-1))/2+K)
  10      SUM=W(2,J)**2+SUM
      S=SIGN(SQRT(SUM),W(2,KP1))
      W(1,K)=-S
      W(2,KP1)=W(2,KP1)+S
      A(K+(KP1*(KP1-1))/2)=W(2,KP1)
      H=W(2,KP1)*S
      IF(H.EQ.ZERO) GOTO 70
      SUMM=0.D0
      DO 50 I=KP1,N
      SUM=0.D0
      DO 20 J=KP1,I
  20  SUM=SUM+A(J+(I*(I-1))/2)*W(2,J)
      IF(I.GE.N) GOTO 40
      IP1=I+1
      DO 30 J=IP1,N
  30  SUM=SUM+A(I+(J*(J-1))/2)*W(2,J)
  40  W(1,I)=SUM/H
  50  SUMM=W(1,I)*W(2,I)+SUMM
      U=SUMM*0.5D0/H
      DO 60 J=KP1,N
      W(1,J)=W(2,J)*U-W(1,J)
      DO 60 I=KP1,J
  60  A(I+(J*(J-1))/2)=W(1,I)*W(2,J)+W(1,J)*W(2,I)+A(I+(J*(J-1))/2)
  70  A((K*(K+1))/2)=H
  80  W(2,NM1)=A((NM1*(NM1+1))/2)
      W(2,N)=A((N*(N+1))/2)
      W(1,NM1)=A(NM1+(N*(N-1))/2)
      W(1,N)=0.D0
      GERSCH=ABS(W(2,1))+ABS(W(1,1))
      DO 90 I=1,NM1
  90  GERSCH=MAX(ABS(W(2,I+1))+ABS(W(1,I))+ABS(W(1,I+1)),GERSCH)
      DEL=EPS*GERSCH
      DO 100 I=1,N
      W(3,I)=W(1,I)
      E(I)=W(2,I)
  100 V(I,M)=E(I)
      IF(DEL.EQ.ZERO)  GOTO  210
C     QR-METHOD WITH ORIGIN SHIFT
      K=N
  110 L=K
  120 IF(ABS(W(3,L-1)).LT.DEL) GOTO 130
      L=L-1
      IF(L.GT.1)  GOTO 120
  130 IF(L.EQ.K)  GOTO 160
      WW=(E(K-1)+E(K))*0.5D0
      R=E(K)-WW
      Z=SIGN(SQRT(W(3,K-1)**2+R*R),R)+WW
      EE=E(L)-Z
      E(L)=EE
      FF=W(3,L)
      R=SQRT(EE*EE+FF*FF)
      J=L
      GOTO 150
  140 R=SQRT(E(J)**2+W(3,J)**2)
      W(3,J-1)=S*R
      EE=E(J)*C
      FF=W(3,J)*C
  150 C=E(J)/R
      S=W(3,J)/R
      WW=E(J+1)-Z
      E(J)=(FF*C+WW*S)*S+EE+Z
      E(J+1)=C*WW-S*FF
      J=J+1
      IF(J.LT.K) GOTO 140
      W(3,K-1)=E(K)*S
      E(K)=E(K)*C+Z
      GOTO 110
  160 K=K-1
      IF(K.GT.1) GOTO 110
*    *    *    *    *    *    *    *    *    *    *    *    *
*
*   AT THIS POINT THE ARRAY 'E' CONTAINS THE UN-ORDERED EIGENVALUES
*
*    *    *    *    *    *    *    *    *    *    *    *    *
C     STRAIGHT SELECTION SORT OF EIGENVALUES
      SORTER=1.D0
      IF(IORD.LT.0) SORTER=-1.D0
      J=N
  170  L=1
      II=1
      LL=1
      DO 190 I=2,J
      IF((E(I)-E(L))*SORTER .GT. 0.D0) GOTO 180
      L=I
      GOTO 190
  180 II=I
      LL=L
  190 CONTINUE
      IF(II.EQ.LL) GOTO 200
      WW=E(LL)
      E(LL)=E(II)
      E(II)=WW
  200 J=II-1
      IF(J.GE.2) GOTO 170
  210 IF(M.EQ.0) RETURN
***************
*  ORDERING OF EIGENVALUES COMPLETE.
***************
C      INVERSE-ITERATION FOR EIGENVECTORS
      FN=FLOAT(N)
      EPS1=1.D-5
      SEPS=SQRT(EPS)
      EPS2=0.05D0
      RN=0.D0
      RA=EPS*0.6180339887485D0
C    0.618... IS THE FIBONACCI NUMBER (-1+SQRT(5))/2.
      IG=1
      DO 430 I=1,M
      IM1=I-1
      DO 220 J=1,N
      W(3,J)=0.D0
      W(4,J)=W(1,J)
      W(5,J)=V(J,M)-E(I)
      RN=RN+RA
      IF(RN.GE.EPS) RN=RN-EPS
  220 V(J,I)=RN
      DO 250 J=1,NM1
      IF(ABS(W(5,J)).GE.ABS(W(1,J))) GOTO 230
      W(2,J)=-W(5,J)/W(1,J)
      W(5,J)=W(1,J)
      T=W(5,J+1)
      W(5,J+1)=W(4,J)
      W(4,J)=T
      W(3,J)=W(4,J+1)
      IF(W(3,J).EQ.ZERO) W(3,J)=DEL
      W(4,J+1)=0.D0
      GOTO 240
  230 IF(W(5,J).EQ.ZERO) W(5,J)=DEL
      W(2,J)=-W(1,J)/W(5,J)
  240 W(4,J+1)=W(3,J)*W(2,J)+W(4,J+1)
  250 W(5,J+1)=W(4,J)*W(2,J)+W(5,J+1)
      IF(ABS(W(5,N)) .LT. EPS3) W(5,N)=DEL
      DO 310 ITERE=1,5
      IF(ITERE.EQ.1) GOTO 270
      DO 260 J=1,NM1
      IF(W(3,J).EQ.ZERO) GOTO 260
      T=V(J,I)
      V(J,I)=V(J+1,I)
      V(J+1,I)=T
  260 V(J+1,I)=V(J,I)*W(2,J)+V(J+1,I)
  270 V(N,I)=V(N,I)/W(5,N)
      V(NM1,I)=(V(NM1,I)-V(N,I)*W(4,NM1))/W(5,NM1)
      VN=MAX(ABS(V(N,I)),ABS(V(NM1,I)))
      IF(N.EQ.2) GOTO 290
      K=NM2
  280 V(K,I)=(V(K,I)-V(K+1,I)*W(4,K)-V(K+2,I)*W(3,K))/W(5,K)
      VN=MAX(ABS(V(K,I)),VN)
      K=K-1
      IF(K.GE.1) GOTO 280
  290 S=EPS1/VN
      DO 300 J=1,N
  300 V(J,I)=V(J,I)*S
      IF(ITERE.GT.1 .AND. VN.GT.1) GOTO 320
  310 CONTINUE
C     TRANSFORMATION OF EIGENVECTORS
  320 IF(N.EQ.2) GOTO 360
      DO 350 J=1,NM2
      K=N-J-1
      IF(A((K*(K+1))/2).EQ.ZERO) GOTO 350
      KP1=K+1
      SUM=0.D0
      DO 330 KK=KP1,N
  330 SUM=SUM+A(K+(KK*(KK-1))/2)*V(KK,I)
      S=-SUM/A((K*(K+1))/2)
      DO 340 KK=KP1,N
  340 V(KK,I)=A(K+(KK*(KK-1))/2)*S+V(KK,I)
  350 CONTINUE
  360 DO 370 J=IG,I
      IF(ABS(E(J)-E(I)) .LT. EPS2) GOTO 380
  370 CONTINUE
      J=I
  380 IG=J
      IF(IG .EQ. I) GOTO 410
C     RE-ORTHOGONALISATION
      DO 400 K=IG,IM1
      SUM=0.D0
      DO 390 J=1,N
  390 SUM=V(J,K)*V(J,I)+SUM
      S=-SUM
      DO 400 J=1,N
  400 V(J,I)=V(J,K)*S+V(J,I)
C     NORMALISATION
  410 SUM=1.D-24
      DO 420 J=1,N
  420 SUM=SUM+V(J,I)**2
      SINV=1.D0/SQRT(SUM)
      DO 430 J=1,N
  430 V(J,I)=V(J,I)*SINV
      RETURN
      END


      subroutine SGECO(A,LDA,N,IPVT,RCOND,Z)
c Copyright (c) 1996 California Institute of Technology, Pasadena, CA.
c ALL RIGHTS RESERVED.
c Based on Government Sponsored Research NAS7-03001.
c>> 1996-03-30 SGECO  Krogh  Added external statement.
C>> 1994-10-20 SGECO  Krogh  Changes to use M77CON
C>> 1987-08-18 SGECO  Lawson  Initial code.
c--S replaces "?": ?GECO, ?GEFA, ?AXPY,?DOT,?SCAL,?ASUM
C
c     Given an Nth order matrix, A, this subroutine does the following
c     three steps:
c     1. Compute a norm of A for internal use at Step 3.
c     2. Call _GEFA to compute an LU factorization of A that overwrites
c        A in the array A().
c     3. Compute RCOND, an estimate of the reciprocal of the condition
c        number of A.
C     The total computing time for Steps 1 and 3 is relatively
c     economical, being about (9/N) times the time needed for Step 2.
c     ------------------------------------------------------------------
c                        Subroutine arguments
C
C     A(,)  [inout]  An array of size at least N x N.  On entry must
c            contain an N x N matrix, A, to be factored.  On return will
c            contain the LU factors of A.
C
C     LDA  [in]  Leading dimensioning parameter for the array A(,).
C
C     N  [in]  The order of the matrix, A.
C
C     IPVT()  [out]  An integer array of length at least N, into which
c           will be stored a record of the row interchanges made during
c           factorization of A.
c
C     RCOND  [out]  An estimate of the reciprocal of the condition
c           number of the matrix, A.
c           Will satisfy ZERO .le. RCOND .le. ONE.
C           For the system  A*X = B , relative perturmations
C           in  A  and  B  of size  EPSILON  may cause
C           relative perturbations in  X  of size  EPSILON/RCOND .
C           If RCOND is so small that the expression
C                           ONE + RCOND
c           truncated to working precision is not distinguishable from
c           ONE, then A is singular to working precision.
C           In particular, RCOND will be returned as ZERO if  exact
c           singularity is detected or if the estimate underflows.
C
C     Z()  [out]  An array of length at least N.  Needed in this
c           subroutine as work space.  On return will contain a vector
c           Z satisfying NORM(A*Z) = RCOND * NORM(A) * NORM(Z) .
C           If A is close to a singular matrix, then Z will be
C           an approximate null vector.
c     ------------------------------------------------------------------
C     LINPACK. THIS VERSION DATED 08/14/78 .
C     CLEVE MOLER, UNIVERSITY OF NEW MEXICO, ARGONNE NATIONAL LAB.
c     Ref: LINPACK Users' Guide, by J. J. Dongarra, C. B. Moler,
c     J. R. Bunch, and G. W. Stewart, publ by Soc. for Indust. and Appl.
c     Math, Philadelphia, 1979.
c     Adapted from LINPACK for the JPL Math77 library by
c     C. L. Lawson, JPL, Aug 1987.
c     ------------------------------------------------------------------
C     Subprograms referenced directly:  SGEFA, SAXPY,SDOT,SSCAL,SASUM
c     ------------------------------------------------------------------
      external SASUM, SDOT
      integer LDA,N,IPVT(N)
      integer J,K,KB,KP1,L, INFO
      real             A(LDA,N),Z(N), RCOND
      real             SDOT, SASUM
      real             EK,T,WK,WKM, ANORM,S,SM,YNORM,ZERO,ONE
      parameter(ZERO = 0.0E0, ONE = 1.0E0)
c     ------------------------------------------------------------------
C     COMPUTE 1-NORM OF A
C
      ANORM = ZERO
      do 10 J = 1, N
         ANORM = max(ANORM,SASUM(N,A(1,J),1))
   10 continue
c
c                      Replace A by its LU factorization
c
      call SGEFA(A, LDA, N, IPVT, INFO)
C
C     RCOND = 1/(NORM(A)*(ESTIMATE OF NORM(INVERSE(A)))) .
C     ESTIMATE = NORM(Z)/NORM(Y) WHERE  A*Z = Y  AND  TRANS(A)*Y = E .
C     TRANS(A)  IS THE TRANSPOSE OF A .  THE COMPONENTS OF  E  ARE
C     CHOSEN TO CAUSE MAXIMUM LOCAL GROWTH IN THE ELEMENTS OF W  WHERE
C     TRANS(U)*W = E .  THE VECTORS ARE FREQUENTLY RESCALED TO AVOID
C     OVERFLOW.
C
C     SOLVE TRANS(U)*W = E
C
      EK = ONE
      do 20 J = 1, N
         Z(J) = ZERO
   20 continue
      do 100 K = 1, N
         if (Z(K) .ne. ZERO) EK = sign(EK,-Z(K))
         if (abs(EK-Z(K)) .gt. abs(A(K,K))) then
            S = abs(A(K,K))/abs(EK-Z(K))
            CALL SSCAL(N,S,Z,1)
            EK = S*EK
         endif
         WK = EK - Z(K)
         WKM = -EK - Z(K)
         S = abs(WK)
         SM = abs(WKM)
         if (A(K,K) .ne. ZERO) then
            WK = WK/A(K,K)
            WKM = WKM/A(K,K)
         else
            WK = ONE
            WKM = ONE
         endif
         KP1 = K + 1
            do 60 J = KP1, N
               SM = SM + abs(Z(J)+WKM*A(K,J))
               Z(J) = Z(J) + WK*A(K,J)
               S = S + abs(Z(J))
   60       continue
            if (S .lt. SM) then
               T = WKM - WK
               WK = WKM
               do 70 J = KP1, N
               Z(J) = Z(J) + T*A(K,J)
   70          continue
            endif
         Z(K) = WK
  100 continue
      S = ONE/SASUM(N,Z,1)
      CALL SSCAL(N,S,Z,1)
C
C     SOLVE TRANS(L)*Y = W
C
      do 120 KB = 1, N
         K = N + 1 - KB
         if (K .lt. N) Z(K) = Z(K) + SDOT(N-K,A(K+1,K),1,Z(K+1),1)
         if (abs(Z(K)) .gt. ONE) then
            S = ONE/abs(Z(K))
            CALL SSCAL(N,S,Z,1)
         endif
         L = IPVT(K)
         T = Z(L)
         Z(L) = Z(K)
         Z(K) = T
  120 continue
      S = ONE/SASUM(N,Z,1)
      CALL SSCAL(N,S,Z,1)
C
      YNORM = ONE
C
C     SOLVE L*V = Y
C
      do 140 K = 1, N
         L = IPVT(K)
         T = Z(L)
         Z(L) = Z(K)
         Z(K) = T
         if (K .lt. N) CALL SAXPY(N-K,T,A(K+1,K),1,Z(K+1),1)
         if (abs(Z(K)) .gt. ONE) then
            S = ONE/abs(Z(K))
            CALL SSCAL(N,S,Z,1)
            YNORM = S*YNORM
         endif
  140 continue
      S = ONE/SASUM(N,Z,1)
      CALL SSCAL(N,S,Z,1)
      YNORM = S*YNORM
C
C     SOLVE  U*Z = V
C
      do 160 KB = 1, N
         K = N + 1 - KB
         if (abs(Z(K)) .gt. abs(A(K,K))) then
            S = abs(A(K,K))/abs(Z(K))
            CALL SSCAL(N,S,Z,1)
            YNORM = S*YNORM
         endif
         if (A(K,K) .ne. ZERO) then
            Z(K) = Z(K)/A(K,K)
         else
            Z(K) = ONE
         endif
         T = -Z(K)
         CALL SAXPY(K-1,T,A(1,K),1,Z(1),1)
  160 continue
C                              MAKE ZNORM = 1.0
      S = ONE/SASUM(N,Z,1)
      CALL SSCAL(N,S,Z,1)
      YNORM = S*YNORM
C
      if (ANORM .eq. ZERO) THEN
        RCOND = ZERO
      else
        RCOND = YNORM/ANORM
      endif
      return
      end