      SUBROUTINE CFFT (IS, M, U, X, Y, NQ)

      IMPLICIT REAL*8 (A-H, O-Z)
      PARAMETER (PI = 3.141592653589793238D0)
      COMMON /COUNT/ KTTRANS(256)
      DIMENSION U(1), X(1), Y(1)

C     Synthesize preconditions
      if(is.lt.-1.or.is.gt.1
     & .or.m.lt.5.or.m.gt.6
     & .or.nq.lt.1.or.nq.gt.64) stop

C
      IF (IS .EQ. 0)  THEN
C
C     Initialize the U array with sines and cosines in a manner that
C     permits stride one access at each FFT iteration.
C
        N = 2 ** M
        NU = N
        U(1) = 64 * N + M
        KU = 2
        KN = KU + NU
        LN = 1
C
        DO 110 J = 1, M
          T = PI / LN
C
C   This loop is vectorizable.
C
          DO 100 I = 0, LN - 1
            TI = I * T
            U(I+KU) = COS (TI)
            U(I+KN) = SIN (TI)
 100      CONTINUE
C
          KU = KU + LN
          KN = KU + NU
          LN = 2 * LN
 110    CONTINUE
C
        RETURN
      ENDIF
C
C   Check if input parameters are invalid.
C
      K = U(1)
      MX = MOD (K, 64)
      IF ((IS .NE. 1 .AND. IS .NE. -1) .OR. M .LT. 1 .OR. M .GT. MX)
     $  THEN
C       WRITE (6, 1)  IS, M, MX
 1      FORMAT ('CFFTZ: EITHER U HAS NOT BEEN INITIALIZED, OR ELSE'/
     $    'ONE OF THE INPUT PARAMETERS IS INVALID', 3I5)
C       STOP
      ENDIF
C>> A normal call to CFFTZ starts here.  M1 is the number of the first
C     variant radix-2 Stockham iterations to be performed.  The second
C     variant is faster on most computers after the first few
C     iterations, since in the second variant it is not necessary to
C     access roots of unity in the inner DO loop.  Thus it is most
C     efficient to limit M1 to some value.  For many vector computers,
C     the optimum limit of M1 is 6.  For scalar systems, M1 should
C     probably be limited to 2.
C
      N = 2 ** M
C      M1 = MIN (M / 2, 6)
      M1 = MIN (M / 2, 2)
      M2 = M - M1
      N2 = 2 ** M1
      N1 = 2 ** M2
C
C   Perform one variant of the Stockham FFT.
C
      DO 120 L = 1, M1, 2
        CALL FFTZ1 (IS, L, M, U, X, Y)
        IF (L .EQ. M1) GOTO 140
        CALL FFTZ1 (IS, L + 1, M, U, Y, X)
 120  CONTINUE
C
C   Perform a transposition of X treated as a N2 x N1 x 2 matrix.
C
      CALL TRANS (N1, N2, X, Y)
      KTTRANS(NQ) = KTTRANS(NQ) + 1
C
C   Perform second variant of the Stockham FFT from Y to X and X to Y.
C
      DO 130 L = M1 + 1, M, 2
        CALL FFTZ2 (IS, L, M, U, Y, X)
        IF (L .EQ. M) GOTO 180
        CALL FFTZ2 (IS, L + 1, M, U, X, Y)
 130  CONTINUE
C
      GOTO 160
C
C   Perform a transposition of Y treated as a N2 x N1 x 2 matrix.
C
 140  CALL TRANS (N1, N2, Y, X)
      KTTRANS(NQ) = KTTRANS(NQ) + 1
C
C   Perform second variant of the Stockham FFT from X to Y and Y to X.
C
      DO 150 L = M1 + 1, M, 2
        CALL FFTZ2 (IS, L, M, U, X, Y)
        IF (L .EQ. M) GOTO 160
        CALL FFTZ2 (IS, L + 1, M, U, Y, X)
 150  CONTINUE
C
      GOTO 180
C
C   Copy Y to X.
C
 160  CONTINUE
      DO 170 I = 1, 2 * N
        X(I) = Y(I)
 170  CONTINUE
C
 180  CONTINUE
      RETURN
      END
      SUBROUTINE FFTZ2 (IS, L, M, U, X, Y)

      IMPLICIT REAL*8 (A-H, O-Z)
      DIMENSION U(1), X(1), Y(1)
C
      N = 2 ** M
      K = U(1)
      NU = K / 64
      N1 = N / 2
      LK = 2 ** (L - 1)
      LI = 2 ** (M - L)
      LJ = 2 * LK
      KU = LI + 1
C
      DO 100 I = 0, LI - 1
        I11 = I * LK + 1
        I12 = I11 + N1
        I21 = I * LJ + 1
        I22 = I21 + LK
        U1 = U(KU+I)
        U2 = IS * U(KU+I+NU)
C
C   This loop is vectorizable.
C
        DO 100 K = 0, LK - 1
          X11 = X(I11+K)
          X12 = X(I11+K+N)
          X21 = X(I12+K)
          X22 = X(I12+K+N)
          T1 = X11 - X21
          T2 = X12 - X22
          Y(I21+K) = X11 + X21
          Y(I21+K+N) = X12 + X22
          Y(I22+K) = U1 * T1 - U2 * T2
          Y(I22+K+N) = U1 * T2 + U2 * T1
 100  CONTINUE
C
      RETURN
      END
C
      SUBROUTINE TRANS (N1, N2, X, Y)
C
      IMPLICIT REAL*8 (A-H, O-Z)
      DIMENSION X(1), Y(1)
C
      N = N1 * N2

C      IF (N1 .LT. 32 .OR. N2 .LT. 32) THEN
      IF (N1 .GE. N2) THEN
        GOTO 100
      ELSE
        GOTO 120
      ENDIF
C      ELSE
C        GOTO 140
C      ENDIF
C
 100  DO 110 J = 0, N2 - 1
C
C   This loop is vectorizable.
C
        DO 110 I = 0, N1 - 1
          Y(I*N2+J+1) = X(I+J*N1+1)
          Y(I*N2+J+1+N) = X(I+J*N1+1+N)
 110  CONTINUE
C
      GOTO 180
C

 120  DO 130 I = 0, N1 - 1
C
C   This loop is vectorizable.
C
        DO 130 J = 0, N2 - 1
          Y(J+I*N2+1) = X(J*N1+I+1)
          Y(J+I*N2+1+N) = X(J*N1+I+1+N)
 130  CONTINUE
C
      GOTO 180

 140  N11 = N1 + 1
      N21 = N2 + 1
      IF (N1 .GE. N2) THEN
        K1 = N1
        K2 = N2
        I11 = N1
        I12 = 1
        I21 = 1
        I22 = N2
      ELSE
        K1 = N2
        K2 = N1
        I11 = 1
        I12 = N2
        I21 = N1
        I22 = 1
      ENDIF
C
      DO 150 J = 0, K2 - 1
        J1 = J * I11 + 1
        J2 = J * I12 + 1
C
C   This loop is vectorizable.
C
        DO 150 I = 0, K2 - 1 - J
          Y(N21*I+J2) = X(N11*I+J1)
          Y(N21*I+J2+N) = X(N11*I+J1+N)
 150  CONTINUE
C
      DO 160 J = 1, K1 - K2 - 1
        J1 = J * I21 + 1
        J2 = J * I22 + 1
C
C   This loop is vectorizable.
C
        DO 160 I = 0, K2 - 1
          Y(N21*I+J2) = X(N11*I+J1)
          Y(N21*I+J2+N) = X(N11*I+J1+N)
 160  CONTINUE
C
      DO 170 J = K1 - K2, K1 - 1
        J1 = J * I21 + 1
        J2 = J * I22 + 1
C
C   This loop is vectorizable.
C
        DO 170 I = 0, K1 - 1 - J
          Y(N21*I+J2) = X(N11*I+J1)
          Y(N21*I+J2+N) = X(N11*I+J1+N)
 170  CONTINUE
C
 180  RETURN
      END
      SUBROUTINE FFTZ1 (IS, L, M, U, X, Y)

      IMPLICIT REAL*8 (A-H, O-Z)
      DIMENSION U(1), X(1), Y(1)
C
C   Set initial parameters.
C
      N = 2 ** M
      K = U(1)
      NU = K / 64
      N1 = N / 2
      LK = 2 ** (L - 1)
      LI = 2 ** (M - L)
      LJ = 2 * LI
      KU = LI + 1
      KN = KU + NU
C
      DO 100 K = 0, LK - 1
        I11 = K * LJ + 1
        I12 = I11 + LI
        I21 = K * LI + 1
        I22 = I21 + N1
C
C   This loop is vectorizable.
C
        DO 100 I = 0, LI - 1
          U1 = U(KU+I)
          U2 = IS * U(KN+I)
          X11 = X(I11+I)
          X12 = X(I11+I+N)
          X21 = X(I12+I)
          X22 = X(I12+I+N)
          T1 = X11 - X21
          T2 = X12 - X22
          Y(I21+I) = X11 + X21
          Y(I21+I+N) = X12 + X22
          Y(I22+I) = U1 * T1 - U2 * T2
          Y(I22+I+N) = U1 * T2 + U2 * T1
 100  CONTINUE
C
      RETURN
      END


!----------------------------------------------------------------------
!----------------------------------------------------------------------
!   stw :         Sharp traveling waves
!----------------------------------------------------------------------
!----------------------------------------------------------------------
! Parameter assignment: ( Components of PAR(.) )
!
!      PAR :             (1)  : homotopy parameter
!                   (2)  (3)  : A0, A1, A2      (problem parameters)
!              (4)  (5)  (6)  : B0, B1, B2      (problem parameters)
!              (7)  (8)  (9)  : C0, C1, C2      (problem parameters)
!                       (10)  :         c       (wave speed)
!                       (11)  :         T       (period)
!                  (12) (13)  : eps-0, eps-1    (radii)
!                  (14) (15)  : mu-0 , mu-1     (eigenvalues)
!                  (16) (17)  : v-0(1), v-0(2)  (eigenvector)
!                  (18) (19)  : v-1(1), v-1(2)  (eigenvector)
!-----------------------------------------------------------------------
!-----------------------------------------------------------------------

      SUBROUTINE FUNC(NDIM,U,ICP,PAR,IJAC,F,DFDU,DFDP)
!     ---------- ----

      IMPLICIT NONE
      INTEGER, INTENT(IN) :: NDIM, ICP(*), IJAC
      DOUBLE PRECISION, INTENT(IN) :: U(NDIM), PAR(*)
      DOUBLE PRECISION, INTENT(OUT) :: F(NDIM)
      DOUBLE PRECISION, INTENT(INOUT) :: DFDU(NDIM,NDIM), DFDP(NDIM,*)

      DOUBLE PRECISION PERIOD

       PERIOD=PAR(11)
       CALL FFFF(NDIM,U,ICP,PAR,IJAC,F,DFDU)
       F(1)=PERIOD*F(1)
       F(2)=PERIOD*F(2)

      END SUBROUTINE FUNC

      SUBROUTINE FFFF(NDIM,U,ICP,PAR,IJAC,F,DFDU)
!     ---------- ----
!
! The reduced system for traveling waves is defined here. A separate subroutine
! is used because the system and the Jacobian are also needed in the subroutines
! BCND and ICND below. The computation should be done with JAC=0. The derivatives
! below are for use in BCND and ICND only.

      IMPLICIT NONE
      INTEGER, INTENT(IN) :: NDIM, ICP(*), IJAC
      DOUBLE PRECISION, INTENT(IN) :: U(NDIM), PAR(*)
      DOUBLE PRECISION, INTENT(OUT) :: F(NDIM)
      DOUBLE PRECISION, INTENT(INOUT) :: DFDU(NDIM,NDIM)

      DOUBLE PRECISION FA,FB,FC,C,DFA,DFB,DFC,P(2:9)

! A0, A1, A2:
       P(2)= (1-PAR(1))* 2   + PAR(1)* 2
       P(3)= (1-PAR(1))* 0   + PAR(1)* 1

! B0, B1, B2:
       P(4)= (1-PAR(1))* 2   + PAR(1)* 0
       P(5)= (1-PAR(1))* 0   + PAR(1)* 1
       P(6)= (1-PAR(1))* 0   + PAR(1)* 0

! C0, C1, C2:
       P(7)= (1-PAR(1))* 0   + PAR(1)* 0
       P(8)= (1-PAR(1))* 1   + PAR(1)* 1
       P(9)= (1-PAR(1))*(-1) + PAR(1)*(-1)

      FA     =        P(2)*U(1) + P(3)*U(1)**2
      FB     = P(4) + P(5)*U(1) + P(6)*U(1)**2
      FC     = P(7) + P(8)*U(1) + P(9)*U(1)**2

      C      = PAR(10)

       F(1)= FA * U(2)
       F(2)= -C * U(2)  -  FB * U(2)**2  -  FC

      IF(IJAC.EQ.0)RETURN

      DFA    = P(2) + 2*P(3)*U(1)
      DFB    = P(5) + 2*P(6)*U(1)
      DFC    = P(8) + 2*P(9)*U(1)

       DFDU(1,1)= DFA*U(2)
       DFDU(1,2)= FA

       DFDU(2,1)= -DFB*U(2)**2 - DFC
       DFDU(2,2)= -C - 2*FB*U(2)

      END SUBROUTINE FFFF

      SUBROUTINE STPNT(NDIM,U,PAR,T)
!     ---------- -----

      IMPLICIT NONE
      INTEGER, INTENT(IN) :: NDIM
      DOUBLE PRECISION, INTENT(INOUT) :: U(NDIM),PAR(*)
      DOUBLE PRECISION, INTENT(IN) :: T

      DOUBLE PRECISION PERIOD, TSC, E

! homotopy parameter :
       PAR(1)= 0

! starting period
       PERIOD=100.

! c, T:
       PAR(10)= 1
       PAR(11)= PERIOD

! eps-0, eps-1:
       PAR(12)= 0.5*DSQRT(5.D0)/(1+EXP(0.5*PERIOD))
       PAR(13)= PAR(12)

!  mu-0,  mu-1:
       PAR(14)= 1
       PAR(15)= -1

! v-0(1), v-0(2):
       PAR(16)= 2/DSQRT(5.D0)
       PAR(17)= 1/DSQRT(5.D0)

! v-1(1), v-1(2):
       PAR(18)= 1
       PAR(19)= 0

! Exact solution
       TSC=PERIOD*(T-0.5)
       E=EXP(TSC)
       U(1)=1/(1+E)
       U(2)=-0.5*E/(1+E)

      END SUBROUTINE STPNT

      SUBROUTINE BCND(NDIM,PAR,ICP,NBC,U0,U1,FB,IJAC,DBC)
!     ---------- ----

      IMPLICIT NONE

      INTEGER, INTENT(IN) :: NDIM, ICP(*), NBC, IJAC
      DOUBLE PRECISION, INTENT(IN) :: PAR(*), U0(NDIM), U1(NDIM)
      DOUBLE PRECISION, INTENT(OUT) :: FB(NBC)
      DOUBLE PRECISION, INTENT(INOUT) :: DBC(NBC,*)
! Local
      DOUBLE PRECISION V0(2),V1(2),G0(2),G1(2),DGDU0(2,2),DGDU1(2,2)

      V0(1)=U0(1) - PAR(12)*PAR(16)
      V0(2)=U0(2) - PAR(12)*PAR(17)
      V1(1)=U1(1) - PAR(13)*PAR(18)
      V1(2)=U1(2) - PAR(13)*PAR(19)

      CALL FFFF(NDIM,V0,ICP,PAR,1,G0,DGDU0)
      CALL FFFF(NDIM,V1,ICP,PAR,1,G1,DGDU1)

! Define eigenvalues and eigenvectors at t=0:
      FB(1)= DGDU0(1,1)*PAR(16) + DGDU0(1,2)*PAR(17) - PAR(14)*PAR(16)
      FB(2)= DGDU0(2,1)*PAR(16) + DGDU0(2,2)*PAR(17) - PAR(14)*PAR(17)

! Define eigenvalues and eigenvectors at t=1:
      FB(3)= DGDU1(1,1)*PAR(18) + DGDU1(1,2)*PAR(19) - PAR(15)*PAR(18)
      FB(4)= DGDU1(2,1)*PAR(18) + DGDU1(2,2)*PAR(19) - PAR(15)*PAR(19)

! Normalize the eigenvectors:
      FB(5)= PAR(16)**2 + PAR(17)**2 -1
      FB(6)= PAR(18)**2 + PAR(19)**2 -1

! Boundary condition at t=0:
      FB(7)= G0(1)
      FB(8)= G0(2)

! Boundary condition at t=1:
      FB(9)= G1(1)
      FB(10)=G1(2)

      END SUBROUTINE BCND

      SUBROUTINE ICND(NDIM,PAR,ICP,NINT,U,UOLD,UDOT,UPOLD,FI,IJAC,DINT)
!     ---------- ----

      IMPLICIT NONE

      INTEGER, INTENT(IN) :: NDIM, ICP(*), NINT, IJAC
      DOUBLE PRECISION, INTENT(IN) :: PAR(*)
      DOUBLE PRECISION, INTENT(IN) :: U(NDIM), UOLD(NDIM), UDOT(NDIM), UPOLD(NDIM)
      DOUBLE PRECISION, INTENT(OUT) :: FI(NINT)
      DOUBLE PRECISION, INTENT(INOUT) :: DINT(NINT,*)
! Local
      DOUBLE PRECISION DFDU(2,2),F(2),F0(2),DGDU0(1)

      CALL FFFF(NDIM,U   ,ICP,PAR,1,F ,DFDU )
      CALL FFFF(NDIM,UOLD,ICP,PAR,0,F0,DGDU0)

! The integral phase condition is defined here:
       FI(1)= ( F(1) - F0(1) ) * ( DFDU(1,1)*F(1) + DFDU(1,2)*F(2) ) &
            + ( F(2) - F0(2) ) * ( DFDU(2,1)*F(1) + DFDU(2,2)*F(2) )

      END SUBROUTINE ICND

      SUBROUTINE FOPT
      END SUBROUTINE FOPT

      SUBROUTINE PVLS
      END SUBROUTINE PVLS


! ==============================================================================
!  Regions Module
!   Module containing data structures and setup routines for region refinement.
!
! ==============================================================================
module regions_module

    implicit none
    save

    ! Region type definition (old style rectangles still supported for now)
    type region_type
        integer :: min_level,max_level
        real(kind=8) :: x_low,y_low,x_hi,y_hi,t_low,t_hi
    end type region_type

    ! New flag regions specified as Ruled Rectangles
    type ruled_region_type
        integer :: min_level,max_level, ixy, method, nrules
        real(kind=8) :: t_low,t_hi,ds
        real(kind=8) :: x1bb,x2bb,y1bb,y2bb  ! bounding box
        real(kind=8), allocatable, dimension(:) :: s, lower, upper
        character(len=200) :: file_name, name
    end type ruled_region_type

    logical, private :: module_setup

    ! old style regions:
    integer :: num_regions
    type(region_type), allocatable  :: regions(:)

    ! new style flagregions
    integer :: num_rregions
    type(ruled_region_type), target, allocatable :: rregions(:)

contains

    subroutine set_regions(fname)

        ! Read old-style rectangular regions from regions.data

        use amr_module

        implicit none

        ! Function Arguments
        character(len=*), optional, intent(in) :: fname

        ! Locals
        integer, parameter :: unit = 7
        integer :: i

        if (.not. module_setup) then

            write(parmunit,*) ' '
            write(parmunit,*) '--------------------------------------------'
            write(parmunit,*) 'REGIONS:'
            write(parmunit,*) '-----------'

            if (present(fname)) then
                call opendatafile(unit,fname)
            else
                call opendatafile(unit,'regions.data')
            endif

            read(unit,"(i2)") num_regions
            if (num_regions == 0) then
                write(parmunit,*) '  No regions specified for refinement'

            else
                ! Refinement region data
                allocate(regions(num_regions))
                do i=1,num_regions
                    read(unit,*) regions(i)%min_level, regions(i)%max_level, &
                                 regions(i)%t_low, regions(i)%t_hi, &
                                 regions(i)%x_low, regions(i)%x_hi, &
                                 regions(i)%y_low, regions(i)%y_hi
                enddo
            endif
            close(unit)

            call set_rregions()

            module_setup = .true.
        end if

    end subroutine set_regions

    subroutine set_rregions(fname)

        ! Read new-style Ruled Rectangles from flagregions.data

        use amr_module

        implicit none

        ! Function Arguments
        character(len=*), optional, intent(in) :: fname

        ! Locals
        integer, parameter :: unit = 7
        integer, parameter :: unit2 = 45
        integer :: i,j,nrules1, spatial_region_type
        logical :: foundFile
        type(ruled_region_type), pointer :: rr
        real(kind=8) :: rr_x1,rr_x2,rr_y1,rr_y2

        write(parmunit,*) ' '
        write(parmunit,*) '--------------------------------------------'
        write(parmunit,*) 'RULED REGIONS:'
        write(parmunit,*) '-----------'

        if (present(fname)) then
            call opendatafile(unit,fname)
        else
            call opendatafile(unit,'flagregions.data')
        endif

        read(unit,"(i2)") num_rregions
        if (num_rregions == 0) then
            write(parmunit,*) '  No ruled regions specified for refinement'

        else
            ! Refinement region data
            allocate(rregions(num_rregions))
            do i=1,num_rregions
                rr => rregions(i)
                read(unit,*) rr%name
                rr%name = trim(rr%name)
                read(unit,*) rr%min_level
                read(unit,*) rr%max_level
                read(unit,*) rr%t_low
                read(unit,*) rr%t_hi
                read(unit,*) spatial_region_type

                if (spatial_region_type == 1) then
                    ! read rectangle extent:
                    read(unit,*) rr_x1,rr_x2,rr_y1,rr_y2
                    ! turn into ruled rectangle:
                    rr%ixy = 1
                    rr%method = 0
                    rr%nrules = 2
                    allocate(rr%s(rr%nrules), rr%lower(rr%nrules), &
                             rr%upper(rr%nrules))
                    rr%s(1) = rr_x1
                    rr%s(2) = rr_x2
                    rr%ds = rr_x2 - rr_x1
                    rr%lower(1) = rr_y1
                    rr%upper(1) = rr_y2
                    rr%lower(2) = rr_y1
                    rr%upper(2) = rr_y2

                else if (spatial_region_type == 2) then
                    read(unit,*) rr%file_name
                    write(6,*) '+++ Ruled region name: ', rr%name
                    write(6,*) '+++ Ruled region file_name: ', rr%file_name
                    inquire(file=trim(rr%file_name),exist=foundFile)
                    if (.not. foundFile) then
                      write(*,*) 'Missing rregions file...'
                      write(*,*) 'Looking for: ',trim(rr%file_name)
                      stop
                      endif

                    open(unit=unit2,file=trim(rr%file_name),status='old')
                    read(unit2,*) rr%ixy
                    read(unit2,*) rr%method
                    read(unit2,*) rr%ds
                    read(unit2,*) rr%nrules
                    allocate(rr%s(rr%nrules), rr%lower(rr%nrules), &
                             rr%upper(rr%nrules))
                    do j=1,rr%nrules
                        read(unit2,*) rr%s(j), rr%lower(j), rr%upper(j)
                        enddo

                else
                    write(6,*) '*** Error: unexpected spatial_region_type'
                endif

                ! compute bounding box:

                if (rr%method == 0) then
                    nrules1 = rr%nrules - 1
                else
                    nrules1 = rr%nrules
                    endif

                if (rr%ixy == 1) then
                    rr%x1bb = rr%s(1)
                    rr%x2bb = rr%s(rr%nrules)
                    rr%y1bb = minval(rr%lower(1:nrules1))
                    rr%y2bb = maxval(rr%upper(1:nrules1))
                else
                    rr%y1bb = rr%s(1)
                    rr%y2bb = rr%s(rr%nrules)
                    rr%x1bb = minval(rr%lower(1:nrules1))
                    rr%x2bb = maxval(rr%upper(1:nrules1))
                    endif

                write(6,*) '+++ rregion bounding box: '
                write(6,*) rr%x1bb,rr%x2bb,rr%y1bb,rr%y2bb

                write(6,*) '+++ i, rr%s(1), rr%ds: ',i, rr%s(1), rr%ds
                enddo

            endif
            close(unit)

    end subroutine set_rregions

end module regions_module


!   Obtain conditional probabilities for distractors.
!   choices provides the number of choices for each item.
!   data provides item data.
!   distdat provides distractor data.
!   numcatobs provides the number of categories for item scores.
!   obsweight gives observation weights.
!   distfreq provides distractor frequencies.
!   distmap maps distractors to item scores.
!   distprob provides conditional distractor probabilities.
!   scorefreq provides item score frequencies.
subroutine getfreq(choices,dat,distdat,numcatobs,obsweight,&
    distmap,distfreq,distprob,scorefreq)
implicit none
integer,intent(in)::choices(:),dat(:,:),distdat(:,:),numcatobs(:)
real(kind=8),intent(in)::obsweight(:)
integer,intent(out)::distmap(:)
real(kind=8),intent(out)::distfreq(:),distprob(:),scorefreq(:)
!   item counts items.

!   obs counts observations.
!   position locates scored response data.
!   positiondist locates distractor data.
!   resp is a score.
!   respdist is a distractor value.
integer::item,obs,position,positiondist,resp(size(choices)),respdist(size(choices))
distmap=-1
distfreq=0.0_8
scorefreq=0.0_8

positiondist=1
do item=1,size(numcatobs)
    distprob(positiondist:positiondist+choices(item)-1)=1.0_8/choices(item)
    positiondist=positiondist+choices(item)
end do

!   Check observations.
do obs=1,size(obsweight)
    if(obsweight(obs)<=0.0_8)cycle
    resp=dat(:,obs)
    respdist=distdat(:,obs)
    position=1
    positiondist=1
!   Iterate by items.

    do item=1,size(numcatobs)

!   Check for missing responses.
        if(resp(item)>=0.and.resp(item)<numcatobs(item))then
            scorefreq(position+resp(item))=scorefreq(position+resp(item))&
                +obsweight(obs)

            if(respdist(item)>=0.and.respdist(item)<choices(item))then
                distfreq(positiondist+respdist(item))=&
                    distfreq(positiondist+respdist(item))+obsweight(obs)
            else
                stop "Defective distractor input."
            end if
            if(distmap(positiondist+respdist(item))<0)then
                distmap(positiondist+respdist(item))=resp(item)+position
            else
                if(distmap(positiondist+respdist(item))/=resp(item)+position) &
                    stop "Inconsistent combination of item score and distractor."

            end if
        end if
        position=position+numcatobs(item)
        positiondist=positiondist+choices(item)
    end do
end do

do positiondist=1,sum(choices)
    if(distmap(positiondist)>=0)then
        if(scorefreq(distmap(positiondist))>0.0_8)distprob(positiondist)=&
            distfreq(positiondist)/scorefreq(distmap(positiondist))

    end if

end do

return
end subroutine getfreq


      FUNCTION ROFUNC(B)
      PARAMETER (NMAX=1000)
      COMMON /ARRAYS/ NDATA,X(NMAX),Y(NMAX),ARR(NMAX),AA,ABDEV
      N1=NDATA+1
      NML=N1/2
      NMH=N1-NML
      DO 11 J=1,NDATA
        ARR(J)=Y(J)-B*X(J)
11    CONTINUE
      CALL SORT(NDATA,ARR)
      AA=0.5*(ARR(NML)+ARR(NMH))
      SUM=0.
      ABDEV=0.
      DO 12 J=1,NDATA
        D=Y(J)-(B*X(J)+AA)
        ABDEV=ABDEV+ABS(D)
        SUM=SUM+X(J)*SIGN(1.0,D)
12    CONTINUE
      ROFUNC=SUM
      RETURN
      END


!==============================================================================!
  subroutine Turb_Mod_Vis_T_Dynamic(turb, sol)
!------------------------------------------------------------------------------!
!   Calculates Smagorinsky constant with dynamic procedure                     !
!------------------------------------------------------------------------------!
!----------------------------------[Modules]-----------------------------------!
  use Work_Mod, only: u_f        => r_cell_01,  &
                      v_f        => r_cell_02,  &
                      w_f        => r_cell_03,  &
                      uu_f       => r_cell_04,  &
                      vv_f       => r_cell_05,  &
                      ww_f       => r_cell_06,  &
                      uv_f       => r_cell_07,  &
                      uw_f       => r_cell_08,  &
                      vw_f       => r_cell_09,  &
                      m_11_f     => r_cell_10,  &
                      m_22_f     => r_cell_11,  &
                      m_33_f     => r_cell_12,  &
                      m_12_f     => r_cell_13,  &
                      m_13_f     => r_cell_14,  &
                      m_23_f     => r_cell_15,  &
                      shear_test => r_cell_16
!------------------------------------------------------------------------------!
  implicit none
!---------------------------------[Arguments]----------------------------------!
  type(Turb_Type),   target :: turb
  type(Solver_Type), target :: sol
!-----------------------------------[Locals]-----------------------------------!
  type(Field_Type),  pointer :: flow
  type(Grid_Type),   pointer :: grid
  type(Matrix_Type), pointer :: a
  real,              pointer :: b(:)
  type(Var_Type),    pointer :: u, v, w
  integer                    :: c, j, cj, nc, nb
  real                       :: u_a, v_a, w_a
  real                       :: uu_a, vv_a, ww_a, uv_a, uw_a, vw_a
  real                       :: m_11_a, m_22_a, m_33_a, m_12_a, m_13_a, m_23_a
  real                       :: l_11, l_22, l_33, l_12, l_13, l_23
  real                       :: m_11, m_22, m_33, m_12, m_13, m_23
  real                       :: m_dot_m, l_dot_m, l_g, l_f, vol_e
!==============================================================================!
!                                                                              !
!   C is derived from:    Lij_res = Lij_mod                                    !
!                                                                              !
!   res - resolved, mod - modeled                                              !
!                                                                              !
!   Lij_res = <UiUj> - <Ui><Uj>,                                               !
!                                                                              !
!   where <> denote test filter                                                !
!                                                                              !
!   Lij_mod = 2 * C * Mij, C = Csmag ** 2.0                                    !
!                                                                              !
!   where Mij is:  Mij = <delta**2.0>|<Sij>|<Sij> - <delta |Sij| Sij>          !
!                                                                              !
!   Finaly C is :                                                              !
!                                                                              !
!   C = 0.5 * Lij:Mij / Mij:Mij                                                !
!                                                                              !
!   Aij : Bij = A11 * B11 + A22 * B22 + A33 * B33                              !
!             + 2.0 * A12 * B12 + 2.0 A13 * B13 + 2.0 * A23 * B23              !
!                                                                              !
!------------------------------------------------------------------------------!

  ! Take aliases
  flow => turb % pnt_flow
  grid => flow % pnt_grid
  nc   =  grid % n_cells
  nb   =  grid % n_bnd_cells
  call Field_Mod_Alias_Momentum(flow, u, v, w)
  call Solver_Mod_Alias_System (sol, a, b)

  call Grid_Mod_Exchange_Cells_Real(grid, u % n)
  call Grid_Mod_Exchange_Cells_Real(grid, v % n)
  call Grid_Mod_Exchange_Cells_Real(grid, w % n)
  call Grid_Mod_Exchange_Cells_Real(grid, flow % shear)

  do c =1, grid % n_cells
    u_a   = 0.0
    v_a   = 0.0
    w_a   = 0.0
    vol_e = 0.0

    uu_a  = 0.0
    vv_a  = 0.0
    ww_a  = 0.0
    uv_a  = 0.0
    uw_a  = 0.0
    vw_a  = 0.0

    m_11_a = 0.0
    m_22_a = 0.0
    m_33_a = 0.0
    m_12_a = 0.0
    m_13_a = 0.0
    m_23_a = 0.0

    do j = a % row(c), a % row(c + 1) - 1
      cj = a % col(j)
      if(cj .ne. c) then

        ! Test velocities
        u_a = u_a + grid % vol(cj) * u % n(cj)
        v_a = v_a + grid % vol(cj) * v % n(cj)
        w_a = w_a + grid % vol(cj) * w % n(cj)

        ! Test stresses
        uu_a = uu_a + grid % vol(cj) * u % n(cj) * u % n(cj)
        vv_a = vv_a + grid % vol(cj) * v % n(cj) * v % n(cj)
        ww_a = ww_a + grid % vol(cj) * w % n(cj) * w % n(cj)
        uv_a = uv_a + grid % vol(cj) * u % n(cj) * v % n(cj)
        uw_a = uw_a + grid % vol(cj) * u % n(cj) * w % n(cj)
        vw_a = vw_a + grid % vol(cj) * v % n(cj) * w % n(cj)

        ! Test Mija
        m_11_a = m_11_a + grid % vol(cj) * flow % shear(cj) * u % x(cj)
        m_22_a = m_22_a + grid % vol(cj) * flow % shear(cj) * v % y(cj)
        m_33_a = m_33_a + grid % vol(cj) * flow % shear(cj) * w % z(cj)
        m_12_a = m_12_a + grid % vol(cj) * flow % shear(cj)              &
               * 0.5 * ( u % y(cj) + v % x(cj) )
        m_13_a = m_13_a + grid % vol(cj) * flow % shear(cj)              &
               * 0.5 * ( u % z(cj) + w % x(cj) )
        m_23_a = m_23_a + grid % vol(cj) * flow % shear(cj)              &
               * 0.5 * ( v % z(cj) + w % y(cj) )

        ! Test volume
        vol_e = vol_e + grid % vol(cj)
      end if
    end do

    ! Take into account influence of central cell within test molecule
    vol_e = vol_e + grid % vol(c)

    u_a = u_a + grid % vol(c) * u % n(c)
    v_a = v_a + grid % vol(c) * v % n(c)
    w_a = w_a + grid % vol(c) * w % n(c)

    uu_a = uu_a + grid % vol(c) * u % n(c) * u % n(c)
    vv_a = vv_a + grid % vol(c) * v % n(c) * v % n(c)
    ww_a = ww_a + grid % vol(c) * w % n(c) * w % n(c)
    uv_a = uv_a + grid % vol(c) * u % n(c) * v % n(c)
    uw_a = uw_a + grid % vol(c) * u % n(c) * w % n(c)
    vw_a = vw_a + grid % vol(c) * v % n(c) * w % n(c)

    m_11_a = m_11_a + grid % vol(c) * flow % shear(c) * u % x(c)
    m_22_a = m_22_a + grid % vol(c) * flow % shear(c) * v % y(c)
    m_33_a = m_33_a + grid % vol(c) * flow % shear(c) * w % z(c)
    m_12_a = m_12_a + grid % vol(c) * flow % shear(c) * .5*(u % y(c) + v % x(c))
    m_13_a = m_13_a + grid % vol(c) * flow % shear(c) * .5*(u % z(c) + w % x(c))
    m_23_a = m_23_a + grid % vol(c) * flow % shear(c) * .5*(v % z(c) + w % y(c))

    ! Now calculating test values
    u_f(c) = u_a / vol_e
    v_f(c) = v_a / vol_e
    w_f(c) = w_a / vol_e

    uu_f(c)  = uu_a / vol_e
    vv_f(c)  = vv_a / vol_e
    ww_f(c)  = ww_a / vol_e
    uv_f(c)  = uv_a / vol_e
    uw_f(c)  = uw_a / vol_e
    vw_f(c)  = vw_a / vol_e

    m_11_f(c) = m_11_a / vol_e
    m_22_f(c) = m_22_a / vol_e
    m_33_f(c) = m_33_a / vol_e
    m_12_f(c) = m_12_a / vol_e
    m_13_f(c) = m_13_a / vol_e
    m_23_f(c) = m_23_a / vol_e
  end do

  call Field_Mod_Grad_Component(flow, u_f(-nb:nc), 1, u % x)  ! dU/dx
  call Field_Mod_Grad_Component(flow, u_f(-nb:nc), 2, u % y)  ! dU/dy
  call Field_Mod_Grad_Component(flow, u_f(-nb:nc), 3, u % z)  ! dU/dz
  call Field_Mod_Grad_Component(flow, v_f(-nb:nc), 1, v % x)  ! dV/dx
  call Field_Mod_Grad_Component(flow, v_f(-nb:nc), 2, v % y)  ! dV/dy
  call Field_Mod_Grad_Component(flow, v_f(-nb:nc), 3, v % z)  ! dV/dz
  call Field_Mod_Grad_Component(flow, w_f(-nb:nc), 1, w % x)  ! dW/dx
  call Field_Mod_Grad_Component(flow, w_f(-nb:nc), 2, w % y)  ! dW/dy
  call Field_Mod_Grad_Component(flow, w_f(-nb:nc), 3, w % z)  ! dW/dz

  do c = 1, grid % n_cells
    l_g  = grid % vol(c)**ONE_THIRD
    l_f  = 2.0 * l_g

    shear_test(c) = sqrt(2.0*(  u % x(c)*u % x(c)                            &
                              + v % y(c)*v % y(c)                            &
                              + w % z(c)*w % z(c) +                          &
                         0.5*(v % z(c) + w % y(c))*(v % z(c) + w % y(c)) +   &
                         0.5*(u % z(c) + w % x(c))*(u % z(c) + w % x(c)) +   &
                         0.5*(v % x(c) + u % y(c))*(v % x(c) + u % y(c))))

    l_11 = uu_f(c) - u_f(c) * u_f(c)
    l_22 = vv_f(c) - v_f(c) * v_f(c)
    l_33 = ww_f(c) - w_f(c) * w_f(c)
    l_12 = uv_f(c) - u_f(c) * v_f(c)
    l_13 = uw_f(c) - u_f(c) * w_f(c)
    l_23 = vw_f(c) - v_f(c) * w_f(c)

    m_11 = l_f**2 * shear_test(c) * u % x(c) - l_g**2 * m_11_f(c)
    m_22 = l_f**2 * shear_test(c) * v % y(c) - l_g**2 * m_22_f(c)
    m_33 = l_f**2 * shear_test(c) * w % z(c) - l_g**2 * m_33_f(c)

    m_12 = l_f**2 * shear_test(c) * .5*(u % y(c)+v % x(c)) - l_g**2 * m_12_f(c)
    m_13 = l_f**2 * shear_test(c) * .5*(u % z(c)+w % x(c)) - l_g**2 * m_13_f(c)
    m_23 = l_f**2 * shear_test(c) * .5*(v % z(c)+w % y(c)) - l_g**2 * m_23_f(c)

    m_dot_m = m_11**2 + m_22**2 + m_33**2 + 2.0 * (m_12**2 + m_13**2 + m_23**2)

    l_dot_m =        l_11 * m_11 + l_22 * m_22 + l_33 * m_33   &
            + 2.0 * (l_12 * m_12 + l_13 * m_13 + l_23 * m_23)

    turb % c_dyn(c)  =  -0.5 * l_dot_m / (m_dot_m + TINY)

    ! Set lower and upper limiter on c_dyn
    if(turb % c_dyn(c) < 0.0) then
      turb % c_dyn(c) = 0.0
    else if(turb % c_dyn(c) > 0.04) then
      turb % c_dyn(c) = 0.04
    end if
  end do

  end subroutine


!***********************************************************************
!   Copyright (c) 2019 D. de Vries
!   Original Copyright (c) 2000 Mark Drela
!
!   This file is part of XFoil.
!
!   XFoil is free software: you can redistribute it and/or modify
!   it under the terms of the GNU General Public License as published by
!   the Free Software Foundation, either version 3 of the License, or
!   (at your option) any later version.
!
!   XFoil is distributed in the hope that it will be useful,
!   but WITHOUT ANY WARRANTY; without even the implied warranty of
!   MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
!   GNU General Public License for more details.
!
!   You should have received a copy of the GNU General Public License
!   along with XFoil.  If not, see <https://www.gnu.org/licenses/>.
!***********************************************************************

!*==NACA4.f90  processed by SPAG 7.21DC at 11:25 on 11 Jan 2019
! POLREF
module m_naca
contains
    subroutine naca4(Ides, Xx, Yt, Yc, Nside, Xb, Yb, Nb, Name)
        implicit none
        !
        !*** Start of declarations rewritten by SPAG
        !
        ! Dummy arguments
        !
        integer :: Ides, Nb, Nside
        character(*) :: Name
        real, dimension(2 * Nside) :: Xb, Yb
        real, dimension(Nside) :: Xx, Yc, Yt
        intent (in) Ides, Nside
        intent (out) Name, Nb, Xb, Yb
        intent (inout) Xx, Yc, Yt
        !
        ! Local variables
        !
        real, save :: an
        real :: anp, frac, m, p, t
        character(10), save :: digits
        integer :: i, ib, n1, n2, n3, n4
        !
        !*** End of declarations rewritten by SPAG
        !
        !
        !*** Start of declarations rewritten by SPAG
        !
        ! Dummy arguments
        !
        !
        ! Local variables
        !
        !
        !*** End of declarations rewritten by SPAG
        !
        !
        data digits/'0123456789'/
        !
        !---- TE point bunching parameter
        data an/1.5/
        !
        n4 = Ides / 1000
        n3 = (Ides - n4 * 1000) / 100
        n2 = (Ides - n4 * 1000 - n3 * 100) / 10
        n1 = (Ides - n4 * 1000 - n3 * 100 - n2 * 10)
        !
        m = float(n4) / 100.0
        p = float(n3) / 10.0
        t = float(n2 * 10 + n1) / 100.0
        !
        anp = an + 1.0
        do i = 1, Nside
            frac = float(i - 1) / float(Nside - 1)
            if (i==Nside) then
                Xx(i) = 1.0
            else
                Xx(i) = 1.0 - anp * frac * (1.0 - frac)**an - (1.0 - frac)**anp
            endif
            Yt(i) = (0.29690 * sqrt(Xx(i)) - 0.12600 * Xx(i) &
                    - 0.35160 * Xx(i)**2 + 0.28430 * Xx(i)**3 - 0.10150 * Xx(i)**4) * t / 0.20
            if (Xx(i)<p) then
                Yc(i) = m / p**2 * (2.0 * p * Xx(i) - Xx(i)**2)
            else
                Yc(i) = m / (1.0 - p)**2 * ((1.0 - 2.0 * p) + 2.0 * p * Xx(i) - Xx(i)**2)
            endif
        enddo
        !
        ib = 0
        do i = Nside, 1, -1
            ib = ib + 1
            Xb(ib) = Xx(i)
            Yb(ib) = Yc(i) + Yt(i)
        enddo
        do i = 2, Nside
            ib = ib + 1
            Xb(ib) = Xx(i)
            Yb(ib) = Yc(i) - Yt(i)
        enddo
        Nb = ib
        !
        Name = 'NACA'
        Name(6:9) = digits(n4 + 1:n4 + 1) // digits(n3 + 1:n3 + 1) // digits(n2 + 1:n2 + 1) // digits(n1 + 1:n1 + 1)
        !
    end subroutine naca4
    !*==NACA5.f90  processed by SPAG 7.21DC at 11:25 on 11 Jan 2019

    subroutine naca5(Ides, Xx, Yt, Yc, Nside, Xb, Yb, Nb, Name)
        use i_xfoil, only: show_output
        implicit none
        !
        !*** Start of declarations rewritten by SPAG
        !
        ! Dummy arguments
        !
        integer :: Ides, Nb, Nside
        character(*) :: Name
        real, dimension(2 * Nside) :: Xb, Yb
        real, dimension(Nside) :: Xx, Yc, Yt
        intent (in) Nside
        intent (out) Name, Nb, Xb, Yb
        intent (inout) Ides, Xx, Yc, Yt
        !
        ! Local variables
        !
        real, save :: an
        real :: anp, c, frac, m, t
        character(10), save :: digits
        integer :: i, ib, n1, n2, n3, n4, n5, n543
        !
        !*** End of declarations rewritten by SPAG
        !
        !
        !*** Start of declarations rewritten by SPAG
        !
        ! Dummy arguments
        !
        !
        ! Local variables
        !
        !
        !*** End of declarations rewritten by SPAG
        !
        !
        !
        data digits/'0123456789'/
        !
        !---- TE point bunching parameter
        data an/1.5/
        !
        n5 = Ides / 10000
        n4 = (Ides - n5 * 10000) / 1000
        n3 = (Ides - n5 * 10000 - n4 * 1000) / 100
        n2 = (Ides - n5 * 10000 - n4 * 1000 - n3 * 100) / 10
        n1 = (Ides - n5 * 10000 - n4 * 1000 - n3 * 100 - n2 * 10)
        !
        n543 = 100 * n5 + 10 * n4 + n3
        !
        if (n543==210) then
            !c     P = 0.05
            m = 0.0580
            c = 361.4
        elseif (n543==220) then
            !c     P = 0.10
            m = 0.1260
            c = 51.64
        elseif (n543==230) then
            !c     P = 0.15
            m = 0.2025
            c = 15.957
        elseif (n543==240) then
            !c     P = 0.20
            m = 0.2900
            c = 6.643
        elseif (n543==250) then
            !c     P = 0.25
            m = 0.3910
            c = 3.230
        else
            if (show_output) then
                write (*, *) 'Illegal 5-digit designation'
                write (*, *) 'First three digits must be 210, 220, ... 250'
            endif
            Ides = 0
            return
        endif
        !
        !
        t = float(n2 * 10 + n1) / 100.0
        !
        anp = an + 1.0
        do i = 1, Nside
            frac = float(i - 1) / float(Nside - 1)
            if (i==Nside) then
                Xx(i) = 1.0
            else
                Xx(i) = 1.0 - anp * frac * (1.0 - frac)**an - (1.0 - frac)**anp
            endif
            !
            Yt(i) = (0.29690 * sqrt(Xx(i)) - 0.12600 * Xx(i) - 0.35160 * Xx(i)**2 &
                    + 0.28430 * Xx(i)**3 - 0.10150 * Xx(i)**4) * t / 0.20
            if (Xx(i)<m) then
                Yc(i) = (c / 6.0) * (Xx(i)**3 - 3.0 * m * Xx(i)**2 + m * m * (3.0 - m) * Xx(i))
            else
                Yc(i) = (c / 6.0) * m**3 * (1.0 - Xx(i))
            endif
        enddo
        !
        ib = 0
        do i = Nside, 1, -1
            ib = ib + 1
            Xb(ib) = Xx(i)
            Yb(ib) = Yc(i) + Yt(i)
        enddo
        do i = 2, Nside
            ib = ib + 1
            Xb(ib) = Xx(i)
            Yb(ib) = Yc(i) - Yt(i)
        enddo
        Nb = ib
        !
        Name = 'NACA'
        Name(6:10) = digits(n5 + 1:n5 + 1) // &
                digits(n4 + 1:n4 + 1) // &
                digits(n3 + 1:n3 + 1) // &
                digits(n2 + 1:n2 + 1) // &
                digits(n1 + 1:n1 + 1)
        !
    end subroutine naca5

end module m_naca


\ Simple but efficient 32bits Pseudo-Random generator
\ XorShift https://en.wikipedia.org/wiki/Xorshift

WINAPI: GetTickCount KERNEL32.DLL

variable seed
GetTickCount seed !

: Random    ( -- x )  \ return a 32-bit random number x
    seed @
    dup 13 lshift xor
    dup 17 rshift xor
    dup 5  lshift xor
    dup seed !
    um* nip
;


! -*- F90 -*-

! $Log$
! Revision 1.3  2005/12/02 14:50:54  whalley
! Changes for new CTEQ code/AB sets
!
! Revision 1.2  2005/10/18 10:34:52  whalley
! small changes from cdf/d0 comments - renamubg conflicting name
! adding pftopdg, etc.
!
! Revision 1.1.1.1  2005/05/06 14:54:44  whalley
! Initial CVS import of the LHAPDF code and data sets
!
! Revision 1.1.1.1  1996/04/01 15:02:05  mclareni
! Mathlib gen
!
!
      FUNCTION DDILOG_LHA(X)
      implicit real*8 (a-h,o-z)
      DIMENSION C(0:19)
      PARAMETER (Z1 = 1d0, HF = Z1/2d0)
      PARAMETER (PI = 3.14159265358979324D0)
      PARAMETER (PI3 = PI**2/3, PI6 = PI**2/6, PI12 = PI**2/12)

      DATA C( 0) / 0.42996693560813697D0/
      DATA C( 1) / 0.40975987533077105D0/
      DATA C( 2) /-0.01858843665014592D0/
      DATA C( 3) / 0.00145751084062268D0/
      DATA C( 4) /-0.00014304184442340D0/
      DATA C( 5) / 0.00001588415541880D0/
      DATA C( 6) /-0.00000190784959387D0/
      DATA C( 7) / 0.00000024195180854D0/
      DATA C( 8) /-0.00000003193341274D0/
      DATA C( 9) / 0.00000000434545063D0/
      DATA C(10) /-0.00000000060578480D0/
      DATA C(11) / 0.00000000008612098D0/
      DATA C(12) /-0.00000000001244332D0/
      DATA C(13) / 0.00000000000182256D0/
      DATA C(14) /-0.00000000000027007D0/
      DATA C(15) / 0.00000000000004042D0/
      DATA C(16) /-0.00000000000000610D0/
      DATA C(17) / 0.00000000000000093D0/
      DATA C(18) /-0.00000000000000014D0/
      DATA C(19) /+0.00000000000000002D0/

      IF(X .EQ. 1d0) THEN
       H=PI6
      ELSEIF(X .EQ. -1d0) THEN
       H=-PI12
      ELSE
       T=-X
       IF(T .LE. -2d0) THEN
        Y=-1/(1d0+T)
        S=1d0
        A=-PI3+HF*(LOG(-T)**2-LOG(1d0+1d0/T)**2)
       ELSEIF(T .LT. -1d0) THEN
        Y=-1d0-T
        S=-1d0
        A=LOG(-T)
        A=-PI6+A*(A+LOG(1d0+1d0/T))
       ELSE IF(T .LE. -HF) THEN
        Y=-(1d0+T)/T
        S=1d0
        A=LOG(-T)
        A=-PI6+A*(-HF*A+LOG(1d0+T))
       ELSE IF(T .LT. 0) THEN
        Y=-T/(1d0+T)
        S=-1d0
        A=HF*LOG(1d0+T)**2
       ELSE IF(T .LE. 1d0) THEN
        Y=T
        S=1d0
        A=0d0
       ELSE
        Y=1d0/T
        S=-1d0
        A=PI6+HF*LOG(T)**2
       ENDIF
       H=Y+Y-1
       ALFA=H+H
       B1=0
       B2=0
       DO 1 I = 19,0,-1
       B0=C(I)+ALFA*B1-B2
       B2=B1
    1  B1=B0
       H=-(S*(B0-H*B2)+A)
      ENDIF
      DDILOG_LHA=H
      RETURN
      END
!
! $Id: Sqcdnum.f 443 2009-02-10 15:39:06Z buckley $
!
! $Log$
! Revision 1.3  2005/12/02 14:50:54  whalley
! Changes for new CTEQ code/AB sets
!
! Revision 1.2  2005/10/18 10:34:52  whalley
! small changes from cdf/d0 comments - renamubg conflicting name
! adding pftopdg, etc.
!
! Revision 1.1.1.1  2005/05/06 14:54:44  whalley
! Initial CVS import of the LHAPDF code and data sets
!
! Revision 1.1.1.1  1996/04/01 15:02:13  mclareni
! Mathlib gen
!
!
      FUNCTION DGAUSS_LHA(F,A,B,EPS)

      implicit real*8 (a-h,o-z)
      CHARACTER NAME*(*)
      PARAMETER (NAME = 'DGAUSS_LHA')
      DIMENSION W(12),X(12)
      PARAMETER (Z1 = 1d0, HF = Z1/2d0, CST = 5d0*Z1/1000d0)
      DATA X                                                            &
     &        /0.96028985649753623168356086856947D0,              &
     &         0.79666647741362673959155393647583D0,              &
     &         0.52553240991632898581773904918925D0,              &
     &         0.18343464249564980493947614236018D0,              &
     &         0.98940093499164993259615417345033D0,              &
     &         0.94457502307323257607798841553461D0,              &
     &         0.86563120238783174388046789771239D0,              &
     &         0.75540440835500303389510119484744D0,              &
     &         0.61787624440264374844667176404879D0,              &
     &         0.45801677765722738634241944298358D0,              &
     &         0.28160355077925891323046050146050D0,              &
     &         0.95012509837637440185319335424958D-1/

      DATA W                                                      &
     &        /0.10122853629037625915253135430996D0,              &
     &         0.22238103445337447054435599442624D0,              &
     &         0.31370664587788728733796220198660D0,              &
     &         0.36268378337836198296515044927720D0,              &
     &         0.27152459411754094851780572456018D-1,             &
     &         0.62253523938647892862843836994378D-1,             &
     &         0.95158511682492784809925107602246D-1,             &
     &         0.12462897125553387205247628219202D0,              &
     &         0.14959598881657673208150173054748D0,              &
     &         0.16915651939500253818931207903036D0,              &
     &         0.18260341504492358886676366796922D0,              &
     &         0.18945061045506849628539672320828D0/

      H=0
      IF(B .EQ. A) GOTO 99
      CONST=CST/ABS(B-A)
      BB=A
    1 AA=BB
      BB=B
    2 C1=HF*(BB+AA)
      C2=HF*(BB-AA)
      S8=0
      DO 3 I = 1,4
      U=C2*X(I)
    3 S8=S8+W(I)*(F(C1+U)+F(C1-U))
      S16=0
      DO 4 I = 5,12
      U=C2*X(I)
    4 S16=S16+W(I)*(F(C1+U)+F(C1-U))
      S16=C2*S16
      IF(ABS(S16-C2*S8) .LE. EPS*(1+ABS(S16))) THEN
       H=H+S16
       IF(BB .NE. B) GOTO 1
      ELSE
       BB=C1
       IF(1+CONST*ABS(C2) .NE. 1) GOTO 2
       H=0
       write(*,*) NAME,'D103.1','TOO HIGH ACCURACY REQUIRED'
       GOTO 99
      END IF
   99 DGAUSS_LHA=H
      RETURN
      END

      SUBROUTINE VZERO_LHA (A,N)
!
! CERN PROGLIB# F121    VZERO           .VERSION KERNFOR  4.40  940929
! ORIG. 01/07/71, modif. 24/05/87 to set integer zero
!                 modif. 25/05/94 to depend on QINTZERO
!
      DIMENSION A(*)
      IF (N.LE.0)  RETURN
      DO 9 I= 1,N
    9 A(I)= 0d0
      RETURN
      END

!
! $Id: Sqcdnum.f 443 2009-02-10 15:39:06Z buckley $
!
! $Log$
! Revision 1.3  2005/12/02 14:50:54  whalley
! Changes for new CTEQ code/AB sets
!
! Revision 1.2  2005/10/18 10:34:52  whalley
! small changes from cdf/d0 comments - renamubg conflicting name
! adding pftopdg, etc.
!
! Revision 1.1.1.1  2005/05/06 14:54:44  whalley
! Initial CVS import of the LHAPDF code and data sets
!
! Revision 1.1.1.1  1996/02/15 17:49:49  mclareni
! Kernlib
!
!
      FUNCTION LENOCC_LHA (CHV)
!
! CERN PROGLIB# M507    LENOCC          .VERSION KERNFOR  4.21  890323
! ORIG. March 85, A.Petrilli, re-write 21/02/89, JZ
!
!-    Find last non-blank character in CHV

      CHARACTER    CHV*(*)

      N = LEN(CHV)

      DO 17  JJ= N,1,-1
      IF (CHV(JJ:JJ).NE.' ') GOTO 99
   17 END DO
      JJ = 0

   99 LENOCC_LHA = JJ
      RETURN
      END
!
! $Id: Sqcdnum.f 443 2009-02-10 15:39:06Z buckley $
!
! $Log$
! Revision 1.3  2005/12/02 14:50:54  whalley
! Changes for new CTEQ code/AB sets
!
! Revision 1.2  2005/10/18 10:34:52  whalley
! small changes from cdf/d0 comments - renamubg conflicting name
! adding pftopdg, etc.
!
! Revision 1.1.1.1  2005/05/06 14:54:44  whalley
! Initial CVS import of the LHAPDF code and data sets
!
! Revision 1.1.1.1  1996/02/15 17:49:43  mclareni
! Kernlib
!
!
      SUBROUTINE CLTOU_LHA (CHV)
!
! CERN PROGLIB# M432    CLTOU           .VERSION KERNFOR  4.21  890323
! ORIG. 11/02/86 A. PETRILLI
! NEW    9/02/89 JZ, for speed
!
!-    Convert character string CHV from lower to upper case.

      CHARACTER    CHV*(*)
      DO 19  JJ=1,LEN(CHV)
          J = ICHAR(CHV(JJ:JJ))
          IF (J.LT.97) EXIT
          IF (J.GE.123) EXIT
          CHV(JJ:JJ) = CHAR(J-32)
   19 END DO
      END
!
      SUBROUTINE TIMEX_LHA (T)
!
! CERN PROGLIB# Z007    TIMEX   DUMMY   .VERSION KERNFOR  4.05  821202
!
!-    DUMMY FOR NON-ESSENTIAL ROUTINE STILL MISSING ON YOUR MACHINE

      T = 9.
      RETURN
      END
!
! $Id: Sqcdnum.f 443 2009-02-10 15:39:06Z buckley $
!
! $Log$
! Revision 1.3  2005/12/02 14:50:54  whalley
! Changes for new CTEQ code/AB sets
!
! Revision 1.2  2005/10/18 10:34:52  whalley
! small changes from cdf/d0 comments - renamubg conflicting name
! adding pftopdg, etc.
!
! Revision 1.1.1.1  2005/05/06 14:54:44  whalley
! Initial CVS import of the LHAPDF code and data sets
!
! Revision 1.1.1.1  1996/02/15 17:49:44  mclareni
! Kernlib
!
!
      SUBROUTINE FLPSOR_LHA(A,N)
!
! CERN PROGLIB# M103    FLPSOR          .VERSION KERNFOR  3.15  820113
! ORIG. 29/04/78
!
!   SORT THE ONE-DIMENSIONAL FLOATING POINT ARRAY A(1),...,A(N) BY
!   INCREASING VALUES
!
!-    PROGRAM  M103  TAKEN FROM CERN PROGRAM LIBRARY,  29-APR-78
!
      DIMENSION A(N)
      COMMON /SLATE/ LT(20),RT(20)
      INTEGER R,RT
!
      LEVEL=1
      LT(1)=1
      RT(1)=N
   10 L=LT(LEVEL)
      R=RT(LEVEL)
      LEVEL=LEVEL-1
   20 IF(R.GT.L) GOTO 200
      IF(LEVEL.LE.0) THEN
        GOTO 50
      ELSE
        GOTO 10
      ENDIF
!
!   SUBDIVIDE THE INTERVAL L,R
!     L : LOWER LIMIT OF THE INTERVAL (INPUT)
!     R : UPPER LIMIT OF THE INTERVAL (INPUT)
!     J : UPPER LIMIT OF LOWER SUB-INTERVAL (OUTPUT)
!     I : LOWER LIMIT OF UPPER SUB-INTERVAL (OUTPUT)
!
  200 I=L
      J=R
      M=(L+R)/2
      X=A(M)
  220 IF(A(I).GE.X) GOTO 230
      I=I+1
      GOTO 220
  230 IF(A(J).LE.X) GOTO 231
      J=J-1
      GOTO 230
!
  231 IF(I.GT.J) GOTO 232
      W=A(I)
      A(I)=A(J)
      A(J)=W
      I=I+1
      J=J-1
      IF(I.LE.J) GOTO 220
!
  232 LEVEL=LEVEL+1
      IF((R-I).GE.(J-L)) GOTO 30
      LT(LEVEL)=L
      RT(LEVEL)=J
      L=I
      GOTO 20
   30 LT(LEVEL)=I
      RT(LEVEL)=R
      R=J
      GOTO 20
   50 RETURN
      END

      SUBROUTINE DATIMH_LHA (ND,NT)
!
! CERN PROGLIB# Z007    DATIMH  DUMMY   .VERSION KERNFOR  4.03  821008
!
!-    DUMMY FOR NON-ESSENTIAL ROUTINE STILL MISSING ON YOUR MACHINE

      DIMENSION ND(9), NT(9)
!      DIMENSION M(8)

      do i=1,9
         ND(i)=0
         NT(i)=0
      enddo
!      CALL UBLOW (8H29/09/79,M,8)
!      CALL UBUNCH           (M,ND,8)
!      CALL UBLOW (8H12.00.00,M,8)
!      CALL UBUNCH           (M,NT,8)
      RETURN
      END
!***********************************************************************
! these next added from CERNLIB to allow some photon and pion sets to wo
! nothing to do with QCDNUM mrw 9/12/2004
!***********************************************************************
!*
! $Id: Sqcdnum.f 443 2009-02-10 15:39:06Z buckley $
!
! $Log$
! Revision 1.3  2005/12/02 14:50:54  whalley
! Changes for new CTEQ code/AB sets
!
! Revision 1.2  2005/10/18 10:34:52  whalley
! small changes from cdf/d0 comments - renamubg conflicting name
! adding pftopdg, etc.
!
! Revision 1.1.1.1  2005/05/06 14:54:44  whalley
! Initial CVS import of the LHAPDF code and data sets
!
! Revision 1.1.1.1  1996/02/15 17:48:17  mclareni
! Kernlib
!
!
      DOUBLE PRECISION FUNCTION DGAMMA_LHA(X)
      LOGICAL MFLAG,RFLAG
      REAL SX
      DOUBLE PRECISION X,U,F,ZERO,ONE,THREE,FOUR,PI
      DOUBLE PRECISION C(0:24),H,ALFA,B0,B1,B2
      DATA ZERO /0.0D0/, ONE /1.0D0/, THREE /3.0D0/, FOUR /4.0D0/
!#if defined(CERNLIB_NUMHIPRE)
!      DATA NC /24/
!      DATA PI    /3.14159 26535 89793 23846 26433 83D0/
!      DATA C( 0) /3.65738 77250 83382 43849 88068 39D0/
!      DATA C( 1) /1.95754 34566 61268 26928 33742 26D0/
!      DATA C( 2) / .33829 71138 26160 38915 58510 73D0/
!      DATA C( 3) / .04208 95127 65575 49198 51083 97D0/
!      DATA C( 4) / .00428 76504 82129 08770 04289 08D0/
!      DATA C( 5) / .00036 52121 69294 61767 02198 22D0/
!      DATA C( 6) / .00002 74006 42226 42200 27170 66D0/
!      DATA C( 7) / .00000 18124 02333 65124 44603 05D0/
!      DATA C( 8) / .00000 01096 57758 65997 06993 06D0/
!      DATA C( 9) / .00000 00059 87184 04552 00046 95D0/
!      DATA C(10) / .00000 00003 07690 80535 24777 71D0/
!      DATA C(11) / .00000 00000 14317 93029 61915 76D0/
!      DATA C(12) / .00000 00000 00651 08773 34803 70D0/
!      DATA C(13) / .00000 00000 00025 95849 89822 28D0/
!      DATA C(14) / .00000 00000 00001 10789 38922 59D0/
!      DATA C(15) / .00000 00000 00000 03547 43620 17D0/
!      DATA C(16) / .00000 00000 00000 00168 86075 04D0/
!      DATA C(17) / .00000 00000 00000 00002 73543 58D0/
!      DATA C(18) / .00000 00000 00000 00000 30297 74D0/
!      DATA C(19) /-.00000 00000 00000 00000 00571 22D0/
!      DATA C(20) / .00000 00000 00000 00000 00090 77D0/
!      DATA C(21) /-.00000 00000 00000 00000 00005 05D0/
!      DATA C(22) / .00000 00000 00000 00000 00000 41D0/
!      DATA C(23) /-.00000 00000 00000 00000 00000 03D0/
!      DATA C(24) / .00000 00000 00000 00000 00000 01D0/
!#endif
!#if defined(CERNLIB_NUMLOPRE)
      DATA NC /15/
      DATA PI    /3.14159265358979324D0/
      DATA C( 0) /3.65738772508338244D0/
      DATA C( 1) /1.95754345666126827D0/
      DATA C( 2) / .33829711382616039D0/
      DATA C( 3) / .04208951276557549D0/
      DATA C( 4) / .00428765048212909D0/
      DATA C( 5) / .00036521216929462D0/
      DATA C( 6) / .00002740064222642D0/
      DATA C( 7) / .00000181240233365D0/
      DATA C( 8) / .00000010965775866D0/
      DATA C( 9) / .00000000598718405D0/
      DATA C(10) / .00000000030769081D0/
      DATA C(11) / .00000000001431793D0/
      DATA C(12) / .00000000000065109D0/
      DATA C(13) / .00000000000002596D0/
      DATA C(14) / .00000000000000111D0/
      DATA C(15) / .00000000000000004D0/
!#endif
      U=X
      IF(X .LE. ZERO) THEN
       IF(X .EQ. INT(X)) THEN
        CALL KERMTR_LHA('C305.1',LGFILE,MFLAG,RFLAG)
        IF(MFLAG) THEN
         SX=X
         IF(LGFILE .EQ. 0) THEN
          WRITE(*,100) SX
         ELSE
          WRITE(LGFILE,100) SX
         END IF
        END IF
        IF(.NOT.RFLAG) CALL ABEND_LHA
        DGAMMA_LHA=ZERO
        RETURN
       ELSE
        U=ONE-U
       END IF
      END IF
      F=ONE
      IF(U .LT. THREE) THEN
       DO 1 I = 1,INT(FOUR-U)
       F=F/U
    1  U=U+ONE
      ELSE
       DO 2 I = 1,INT(U-THREE)
       U=U-ONE
    2  F=F*U
      END IF
      U=U-THREE
      H=U+U-ONE
      ALFA=H+H
      B1=ZERO
      B2=ZERO
      DO 3 I = NC,0,-1
      B0=C(I)+ALFA*B1-B2
      B2=B1
    3 B1=B0
      U=F*(B0-H*B2)
      IF(X .LT. ZERO) U=PI/(SIN(PI*X)*U)
      DGAMMA_LHA=U
      RETURN
  100 FORMAT(1X,'DGAMMA ... ARGUMENT IS NON-POSITIVE INTEGER = ',E15.1)
      END
!=======================================================================
      SUBROUTINE KERSET_LHA(ERCODE,LGFILE,LIMITM,LIMITR)
      PARAMETER(KOUNTE  =  28)
      CHARACTER*6          ERCODE,    CODE(KOUNTE)
      LOGICAL          MFLAG,    RFLAG
      INTEGER          KNTM(KOUNTE),      KNTR(KOUNTE)
      DATA      LOGF      /  0  /
      DATA      CODE(1), KNTM(1), KNTR(1)  / 'C204.1', 100, 100 /
      DATA      CODE(2), KNTM(2), KNTR(2)  / 'C204.2', 100, 100 /
      DATA      CODE(3), KNTM(3), KNTR(3)  / 'C204.3', 100, 100 /
      DATA      CODE(4), KNTM(4), KNTR(4)  / 'C205.1', 100, 100 /
      DATA      CODE(5), KNTM(5), KNTR(5)  / 'C205.2', 100, 100 /
      DATA      CODE(6), KNTM(6), KNTR(6)  / 'C205.3', 100, 100 /
      DATA      CODE(7), KNTM(7), KNTR(7)  / 'C305.1', 100, 100 /
      DATA      CODE(8), KNTM(8), KNTR(8)  / 'C308.1', 100, 100 /
      DATA      CODE(9), KNTM(9), KNTR(9)  / 'C312.1', 100, 100 /
      DATA      CODE(10),KNTM(10),KNTR(10) / 'C313.1', 100, 100 /
      DATA      CODE(11),KNTM(11),KNTR(11) / 'C336.1', 100, 100 /
      DATA      CODE(12),KNTM(12),KNTR(12) / 'C337.1', 100, 100 /
      DATA      CODE(13),KNTM(13),KNTR(13) / 'C341.1', 100, 100 /
      DATA      CODE(14),KNTM(14),KNTR(14) / 'D103.1', 100, 100 /
      DATA      CODE(15),KNTM(15),KNTR(15) / 'D106.1', 100, 100 /
      DATA      CODE(16),KNTM(16),KNTR(16) / 'D209.1', 100, 100 /
      DATA      CODE(17),KNTM(17),KNTR(17) / 'D509.1', 100, 100 /
      DATA      CODE(18),KNTM(18),KNTR(18) / 'E100.1', 100, 100 /
      DATA      CODE(19),KNTM(19),KNTR(19) / 'E104.1', 100, 100 /
      DATA      CODE(20),KNTM(20),KNTR(20) / 'E105.1', 100, 100 /
      DATA      CODE(21),KNTM(21),KNTR(21) / 'E208.1', 100, 100 /
      DATA      CODE(22),KNTM(22),KNTR(22) / 'E208.2', 100, 100 /
      DATA      CODE(23),KNTM(23),KNTR(23) / 'F010.1', 100,   0 /
      DATA      CODE(24),KNTM(24),KNTR(24) / 'F011.1', 100,   0 /
      DATA      CODE(25),KNTM(25),KNTR(25) / 'F012.1', 100,   0 /
      DATA      CODE(26),KNTM(26),KNTR(26) / 'F406.1', 100,   0 /
      DATA      CODE(27),KNTM(27),KNTR(27) / 'G100.1', 100, 100 /
      DATA      CODE(28),KNTM(28),KNTR(28) / 'G100.2', 100, 100 /
      LOGF  =  LGFILE
      IF(ERCODE .EQ. ' ')  THEN
         L  =  0
      ELSE
         DO 10  L = 1, 6
        IF(ERCODE(1:L) .EQ. ERCODE)  GOTO 12
   10       CONTINUE
   12        CONTINUE
      ENDIF
      DO 14     I  =  1, KOUNTE
         IF(L .EQ. 0)  GOTO 13
         IF(CODE(I)(1:L) .NE. ERCODE(1:L))  GOTO 14
   13        KNTM(I)  =  LIMITM
         KNTR(I)  =  LIMITR
   14        CONTINUE
      RETURN
      ENTRY KERMTR_LHA(ERCODE,LOG,MFLAG,RFLAG)
      LOG  =  LOGF
      DO 20     I  =  1, KOUNTE
         IF(ERCODE .EQ. CODE(I))  GOTO 21
   20        CONTINUE
      WRITE(*,1000)  ERCODE
      CALL ABEND_LHA
      RETURN
   21     RFLAG  =  KNTR(I) .GE. 1
      IF(RFLAG  .AND.  (KNTR(I) .LT. 100))  KNTR(I)  =  KNTR(I) - 1
      MFLAG  =  KNTM(I) .GE. 1
      IF(MFLAG  .AND.  (KNTM(I) .LT. 100))  KNTM(I)  =  KNTM(I) - 1
      IF(.NOT. RFLAG)  THEN
         IF(LOGF .LT. 1)  THEN
        WRITE(*,1001)  CODE(I)
         ELSE
        WRITE(LOGF,1001)  CODE(I)
         ENDIF
      ENDIF
      IF(MFLAG .AND. RFLAG)  THEN
         IF(LOGF .LT. 1)  THEN
        WRITE(*,1002)  CODE(I)
         ELSE
        WRITE(LOGF,1002)  CODE(I)
         ENDIF
      ENDIF
      RETURN
 1000     FORMAT(' KERNLIB LIBRARY ERROR. ' /                           &
     &       ' ERROR CODE ',A6,' NOT RECOGNIZED BY KERMTR',             &
     &       ' ERROR MONITOR. RUN ABORTED.')
 1001     FORMAT(/' ***** RUN TERMINATED BY CERN LIBRARY ERROR ',       &
     &       'CONDITION ',A6)
 1002     FORMAT(/' ***** CERN LIBRARY ERROR CONDITION ',A6)
      END
!=======================================================================
      SUBROUTINE ABEND_LHA
!
! CERN PROGLIB# Z035    ABEND        .VERSION KERNVAX  1.10  811126

      STOP '*** ABEND ***'
      END


*DECK SGEDI
      SUBROUTINE SGEDI (A, LDA, N, IPVT, DET, WORK, JOB)
C***BEGIN PROLOGUE  SGEDI
C***PURPOSE  Compute the determinant and inverse of a matrix using the
C            factors computed by SGECO or SGEFA.
C***LIBRARY   SLATEC (LINPACK)
C***CATEGORY  D2A1, D3A1
C***TYPE      SINGLE PRECISION (SGEDI-S, DGEDI-D, CGEDI-C)
C***KEYWORDS  DETERMINANT, INVERSE, LINEAR ALGEBRA, LINPACK, MATRIX
C***AUTHOR  Moler, C. B., (U. of New Mexico)
C***DESCRIPTION
C
C     SGEDI computes the determinant and inverse of a matrix
C     using the factors computed by SGECO or SGEFA.
C
C     On Entry
C
C        A       REAL(LDA, N)
C                the output from SGECO or SGEFA.
C
C        LDA     INTEGER
C                the leading dimension of the array  A .
C
C        N       INTEGER
C                the order of the matrix  A .
C
C        IPVT    INTEGER(N)
C                the pivot vector from SGECO or SGEFA.
C
C        WORK    REAL(N)
C                work vector.  Contents destroyed.
C
C        JOB     INTEGER
C                = 11   both determinant and inverse.
C                = 01   inverse only.
C                = 10   determinant only.
C
C     On Return
C
C        A       inverse of original matrix if requested.
C                Otherwise unchanged.
C
C        DET     REAL(2)
C                determinant of original matrix if requested.
C                Otherwise not referenced.
C                Determinant = DET(1) * 10.0**DET(2)
C                with  1.0 .LE. ABS(DET(1)) .LT. 10.0
C                or  DET(1) .EQ. 0.0 .
C
C     Error Condition
C
C        A division by zero will occur if the input factor contains
C        a zero on the diagonal and the inverse is requested.
C        It will not occur if the subroutines are called correctly
C        and if SGECO has set RCOND .GT. 0.0 or SGEFA has set
C        INFO .EQ. 0 .
C
C***REFERENCES  J. J. Dongarra, J. R. Bunch, C. B. Moler, and G. W.
C                 Stewart, LINPACK Users' Guide, SIAM, 1979.
C***ROUTINES CALLED  SAXPY, SSCAL, SSWAP
C***REVISION HISTORY  (YYMMDD)
C   780814  DATE WRITTEN
C   890831  Modified array declarations.  (WRB)
C   890831  REVISION DATE from Version 3.2
C   891214  Prologue converted to Version 4.0 format.  (BAB)
C   900326  Removed duplicate information from DESCRIPTION section.
C           (WRB)
C   920501  Reformatted the REFERENCES section.  (WRB)
C***END PROLOGUE  SGEDI
      INTEGER LDA,N,IPVT(*),JOB
      REAL A(LDA,*),DET(2),WORK(*)
C
      REAL T
      REAL TEN
      INTEGER I,J,K,KB,KP1,L,NM1
C***FIRST EXECUTABLE STATEMENT  SGEDI
C
C     COMPUTE DETERMINANT
C
      IF (JOB/10 .EQ. 0) GO TO 70
         DET(1) = 1.0E0
         DET(2) = 0.0E0
         TEN = 10.0E0
         DO 50 I = 1, N
            IF (IPVT(I) .NE. I) DET(1) = -DET(1)
            DET(1) = A(I,I)*DET(1)
            IF (DET(1) .EQ. 0.0E0) GO TO 60
   10       IF (ABS(DET(1)) .GE. 1.0E0) GO TO 20
               DET(1) = TEN*DET(1)
               DET(2) = DET(2) - 1.0E0
            GO TO 10
   20       CONTINUE
   30       IF (ABS(DET(1)) .LT. TEN) GO TO 40
               DET(1) = DET(1)/TEN
               DET(2) = DET(2) + 1.0E0
            GO TO 30
   40       CONTINUE
   50    CONTINUE
   60    CONTINUE
   70 CONTINUE
C
C     COMPUTE INVERSE(U)
C
      IF (MOD(JOB,10) .EQ. 0) GO TO 150
         DO 100 K = 1, N
            A(K,K) = 1.0E0/A(K,K)
            T = -A(K,K)
            CALL SSCAL(K-1,T,A(1,K),1)
            KP1 = K + 1
            IF (N .LT. KP1) GO TO 90
            DO 80 J = KP1, N
               T = A(K,J)
               A(K,J) = 0.0E0
               CALL SAXPY(K,T,A(1,K),1,A(1,J),1)
   80       CONTINUE
   90       CONTINUE
  100    CONTINUE
C
C        FORM INVERSE(U)*INVERSE(L)
C
         NM1 = N - 1
         IF (NM1 .LT. 1) GO TO 140
         DO 130 KB = 1, NM1
            K = N - KB
            KP1 = K + 1
            DO 110 I = KP1, N
               WORK(I) = A(I,K)
               A(I,K) = 0.0E0
  110       CONTINUE
            DO 120 J = KP1, N
               T = WORK(J)
               CALL SAXPY(N,T,A(1,J),1,A(1,K),1)
  120       CONTINUE
            L = IPVT(K)
            IF (L .NE. K) CALL SSWAP(N,A(1,K),1,A(1,L),1)
  130    CONTINUE
  140    CONTINUE
  150 CONTINUE
      RETURN
      END


// @author David Han
//
// @kind function
//
// @fileOverview Create a basic line chart.
//
// @example Create and render a line chart specification:
// .qp.go[600;400;] .line.basic.f03[]
//
// @returns {table} a GG specification (for example, ``.qp.point[t; `x; `y; ::]``)

{[]
  xfmt:{n:`long$last string x;$[0=n mod 2;x;`]};
  yfmt:{`$string[0.1*floor 0.5+1000*x],"%"};

  .qp.line[.line.iexMktShare;`quarter;`mktshr;]
     .qp.s.labels[`x`y!(`Quarter;`$"Market Share (%)")]
    ,.qp.s.scale[`x;.gg.scale.format[xfmt;.gg.scale.categorical[]]]
    ,.qp.s.scale[`y;.gg.scale.format[yfmt;] .gg.scale.linear]
  }


!
! Module for normal score transform related routines
! Author: John Manchuk, 2010
!
! Module Dependencies:
!   NORMALDIST - used to compute inverse normal distribution
!   QUICKSORT  - for sorting transform tables
!   ACORN_RNG  - random number generator for breaking ties
!
module normalscore
    use normaldist, ONLY : snorm_inv, snorm_cdf, locate, powint
    use quicksort
    use acorn_rng
    implicit none

    !These are general functions.  All other functions in this module are
    !called from these depending on the inputs.
    public :: build_transtable, normal_score

    type :: transtable !used for jagged arrays
        integer :: n
        real*8 :: sumw
        real*8 :: mint
        real*8, allocatable :: table(:,:)
    end type transtable
    public :: transtable

    !Machine precision
    real*8, parameter :: MACHP = sqrt(epsilon(real(1,8)))

    !Random number generator for breaking ties
    integer, parameter :: seed = 69069
    logical :: isacorninit = .false.
    type(acorn_type) :: rng

    !Work array
    real*8, allocatable :: rwork(:,:)

    contains

    !Compute the normal scores
    subroutine normal_score ( data_, colvr, colct, ct, numq, tmin, tmax, ptt, nsvr, test )
        real*8, pointer :: data_(:,:), nsvr(:)
        integer, intent (in) :: colvr, colct !variable and category columns
        integer, intent (in) :: ct !the category of interest
        integer, intent (in) :: numq
        real*8, intent (in) :: tmin, tmax !trimming limits
        type(transtable), target, intent(in) :: ptt
        logical, intent(out) :: test
        integer :: ncol, nrow, nq
        integer :: i, j, maxiter
        real*8, pointer :: pvr(:),pvrns(:)

        !Initialize RNG
        if(.not.isacorninit)then
            call acorninit(rng,seed)
            isacorninit = .true.
        endif

        !Choose the version based on inputs
        if( colct < 1 ) then
            ncol = ubound(data_,1)
            nrow = ubound(data_,2)
            nq = ptt%n
            pvr => ptt%table(1,:)
            pvrns => ptt%table(2,:)
            do i = 1, nrow
                if(data_(colvr,i) < tmin .or. data_(colvr,i) >= tmax) then
                    nsvr(i) = -999.
                else
                    nsvr(i) = data_(colvr,i) + acorni(rng)*MACHP
                    maxiter = 0; test = .true.
                    do while ( nsvr(i) < pvr(1) .or. nsvr(i) > pvr(nq) )
                        nsvr(i) = data_(colvr,i) + acorni(rng)*MACHP
                        maxiter = maxiter + 1
                        if(maxiter > 1E7)then
                            test = .false.
                            return
                        endif
                    enddo
                    call locate(pvr,nq,1,nq,nsvr(i),j)
                    j = min(max(1,j),(nq-1))
                    nsvr(i) = powint(pvr(j),pvr(j+1),pvrns(j),pvrns(j+1),nsvr(i),1.D0)
                endif
            enddo
        else
            call normal_score_by_category ( data_, colvr, colct, ct, &
                numq, tmin, tmax, ptt, nsvr )
            test = .true.
        endif
        return
    end subroutine normal_score

    !Compute the normal scores of a category
    subroutine normal_score_by_category ( data_, colvr, colct, ct, numq, tmin, tmax, ptt, nsvr )
        real*8, pointer :: data_(:,:), nsvr(:)
        integer, intent (in) :: colvr, colct !variable and category columns
        integer, intent (in) :: ct !the category of interest
        real*8, intent (in) :: tmin, tmax !trimming limits
        type(transtable), target, intent(in) :: ptt
        integer :: ncol, nrow, numq
        integer :: i, j
        real*8, pointer :: pvr(:),pvrns(:)

        ncol = ubound(data_,1)
        nrow = ubound(data_,2)
        numq = ptt%n
        pvr => ptt%table(1,:)
        pvrns => ptt%table(2,:)

        do i = 1, nrow
            if(data_(colvr,i) < tmin .or. data_(colvr,i) >= tmax) then
                nsvr(i) = -999.
            else
                if(floor(data_(colct,i)+0.1) == ct)then
                    nsvr(i) = data_(colvr,i) + acorni(rng)*MACHP
                    call locate(pvr,numq,1,numq,nsvr(i),j)
                    j = min(max(1,j),(numq-1))
                    nsvr(i) = powint(pvr(j),pvr(j+1),pvrns(j),pvrns(j+1),nsvr(i),1.D0)
                endif
            endif
        enddo
        return
    end subroutine normal_score_by_category

    !build a transformation table
    logical function build_transtable ( data_, colvr, colwt, colct, ct, numq, tmin, tmax, ptt )
        real*8, pointer :: data_(:,:) !a block of data for the table, must be ncol by nrows
        integer, intent (in) :: colvr, colwt, colct !variable, weight, and category columns
        integer, intent (in) :: ct !the category of interest
        integer, intent (in) :: numq !number of quantiles
        real*8, intent (in) :: tmin, tmax !trimming limits
        type(transtable), intent(out) :: ptt !Transform table to be built
        integer :: ncol, nrow
        integer :: i, j, test
        integer :: numdata
        real*8 :: mindat

        !Some initial checks
        build_transtable = .false.
        ncol = ubound(data_,1)
        nrow = ubound(data_,2)
        if(colvr < 1)then
            write(*,'(a)') 'ERROR BUILDING TRANSTABLE, INVALID VARIABLE COLUMN'
            return
        endif
        if(colvr > ncol)then
            write(*,'(a)') 'ERROR BUILDING TRANSTABLE, REQUESTED VARIABLE COLUMN TOO LARGE'
            return
        endif
        if(colwt > ncol)then
            write(*,'(a)') 'ERROR BUILDING TRANSTABLE, REQUESTED WEIGHT COLUMN TOO LARGE'
            return
        endif
        if(colct > ncol)then
            write(*,'(a)') 'ERROR BUILDING TRANSTABLE, REQUESTED CATEGORY COLUMN TOO LARGE'
            return
        endif
        if(numq > 0 .and. numq < 3)then
            write(*,'(a)') 'ERROR BUILDING TRANSTABLE, NUMBER OF QUANTILES MUST BE > 2'
            return
        endif
        if(nrow < 2)then
            write(*,'(a)') 'ERROR BUILDING TRANSTABLE, NOT ENOUGH DATA'
            return
        endif
        if(allocated(ptt%table)) deallocate(ptt%table)

        call acorninit(rng,seed)
        numdata = 0

        !Choose the version of this routine depending on the inputs
        if(colwt < 1 .and. colct < 1)then
            !Count the data
            do i = 1, nrow
                if(data_(colvr,i) >= tmin .and. data_(colvr,i) < tmax)then
                    numdata = numdata + 1
                endif
            enddo
            if(numdata < 2) return

            !Fill in the transform table
            allocate(ptt%table(2,numdata), stat = test)
            if(test /= 0)then
                write(*,'(/,a,/)') 'ERROR BUILDING TRANSTABLE, ALLOCATION FAILED'
                return
            endif
            j = 0
            mindat = huge(mindat)
            do i = 1, nrow
                if(data_(colvr,i) >= tmin .and. data_(colvr,i) < tmax)then
                    j = j + 1
                    if(data_(colvr,i) < mindat) mindat = data_(colvr,i)
                    ptt%table(1,j) = data_(colvr,i) + acorni(rng)*MACHP
                    ptt%table(2,j) = 1.
                endif
            enddo
            ptt%mint = mindat

            !define size of the table
            ptt%n = numdata
            ptt%sumw = real(numdata,8)

            ! Compute nscores
            call nscore_transtable ( ptt, numq )

            build_transtable = .true.
        else
            if(colwt < 1)then !colct > 0
                build_transtable = build_transtable_by_category ( data_, &
                             colvr, colct, ct, numq, tmin, tmax, ptt )
            elseif(colct < 1)then !colwt > 0
                build_transtable = build_transtablew ( data_, &
                             colvr, colwt, numq, tmin, tmax, ptt )
            else !colwt and colct > 0
                build_transtable = build_transtablew_by_category ( data_, &
                             colvr, colwt, colct, ct, numq, tmin, tmax, ptt )
            endif
        endif

        return
    end function build_transtable

    !Build a weighted transform table
    ! this routine is called from build_transtable so error checking is not needed
    logical function build_transtablew ( data_, colvr, colwt, numq, tmin, tmax, ptt )
        real*8, pointer :: data_(:,:) !a block of data for the table, must be ncol by nrows
        integer, intent (in) :: colvr, colwt !variable and category columns
        integer, intent (in) :: numq !number of quantiles
        real*8, intent (in) :: tmin, tmax !trimming limits
        type(transtable), intent(inout) :: ptt !pointer to the transform table to be built
        integer :: ncol, nrow
        integer :: i, j, test
        integer :: numdata
        real*8 :: sumweight

        build_transtablew = .false.
        ncol = ubound(data_,1)
        nrow = ubound(data_,2)
        numdata = 0
        sumweight = 0.

        !Count the data
        do i = 1, nrow
            if(data_(colvr,i) >= tmin .and. data_(colvr,i) < tmax)then
                numdata = numdata + 1
            endif
        enddo
        if(numdata < 2) return

        !Fill in the transform table
        allocate(ptt%table(2,numdata), stat = test)
        if(test /= 0)then
            write(*,'(/,a,/)') 'ERROR BUILDING TRANSTABLE, ALLOCATION FAILED'
            return
        endif
        j = 0
        do i = 1, nrow
            if(data_(colvr,i) >= tmin .and. data_(colvr,i) < tmax )then
                j = j + 1
                ptt%table(1,j) = data_(colvr,i) + acorni(rng)*MACHP
                ptt%table(2,j) = data_(colwt,i)
                if(ptt%table(2,j) < MACHP )then ! Check if the weight is numerically small
                    ptt%table(2,j) = MACHP
                endif
                sumweight = sumweight + ptt%table(2,j)
            endif
        enddo

        !define size of the table
        ptt%n = numdata
        ptt%sumw = sumweight

        ! Compute nscores
        call nscore_transtable ( ptt, numq )

        build_transtablew = .true.
        return
    end function build_transtablew

    !Build a transform table by category
    ! this routine is called from build_transtable so error checking is not needed
    logical function build_transtable_by_category ( data_, colvr, colct, ct, numq, tmin, tmax, ptt )
        real*8, pointer :: data_(:,:) !a block of data for the table, must be ncol by nrows
        integer, intent (in) :: colvr, colct !variable and category columns
        integer, intent (in) :: ct !category of interest
        integer, intent (in) :: numq !number of quantiles
        real*8, intent (in) :: tmin, tmax !trimming limits
        type(transtable), intent(inout) :: ptt !pointer to the transform table to be built
        integer :: ncol, nrow
        integer :: i, j, test
        integer :: numdata

        build_transtable_by_category = .false.
        ncol = ubound(data_,1)
        nrow = ubound(data_,2)
        numdata = 0

        !Count the data
        do i = 1, nrow
            if(data_(colvr,i) >= tmin .and. data_(colvr,i) < tmax .and. &
               floor(data_(colct,i)+0.1) == ct)then
                numdata = numdata + 1
            endif
        enddo
        if(numdata < 2) return

        !Fill in the transform table
        allocate(ptt%table(2,numdata), stat = test)
        if(test /= 0)then
            write(*,'(/,a,/)') 'ERROR BUILDING TRANSTABLE, ALLOCATION FAILED'
            return
        endif
        j = 0
        do i = 1, nrow
            if(data_(colvr,i) >= tmin .and. data_(colvr,i) < tmax .and. &
               floor(data_(colct,i)+0.1) == ct)then
                j = j + 1
                ptt%table(1,j) = data_(colvr,i) + acorni(rng)*MACHP
                ptt%table(2,j) = 1.
            endif
        enddo

        !define size of the table
        ptt%n = numdata
        ptt%sumw = real(numdata,8)

        ! Compute nscores
        call nscore_transtable ( ptt, numq )

        build_transtable_by_category = .true.
        return
    end function build_transtable_by_category

    !Build a weighted transform table by category
    ! this routine is called from build_transtable so error checking is not needed
    logical function build_transtablew_by_category ( data_, colvr, colwt, colct, ct, numq, tmin, tmax, ptt )
        real*8, pointer :: data_(:,:) !a block of data for the table, must be ncol by nrows
        integer, intent (in) :: colvr, colwt, colct !variable and category columns
        integer, intent (in) :: ct !category of interest
        integer, intent (in) :: numq !number of quantiles
        real*8, intent (in) :: tmin, tmax !trimming limits
        type(transtable), intent(inout) :: ptt !pointer to the transform table to be built
        integer :: ncol, nrow
        integer :: i, j, test
        integer :: numdata
        real*8 :: sumweight

        build_transtablew_by_category = .false.
        ncol = ubound(data_,1)
        nrow = ubound(data_,2)
        numdata = 0
        sumweight = 0.

        !Count the data
        do i = 1, nrow
            if(data_(colvr,i) >= tmin .and. data_(colvr,i) < tmax .and. &
               floor(data_(colct,i)+0.1) == ct)then
                numdata = numdata + 1
            endif
        enddo
        if(numdata < 2) return

        !Fill in the transform table
        allocate(ptt%table(2,numdata), stat = test)
        if(test /= 0)then
            write(*,'(/,a,/)') 'ERROR BUILDING TRANSTABLE, ALLOCATION FAILED'
            return
        endif
        j = 0
        do i = 1, nrow
            if(data_(colvr,i) >= tmin .and. data_(colvr,i) < tmax .and. &
               floor(data_(colct,i)+0.1) == ct)then
                j = j + 1
                ptt%table(1,j) = data_(colvr,i) + acorni(rng)*MACHP
                ptt%table(2,j) = data_(colwt,i)
                if(ptt%table(2,j) < MACHP )then ! Check if the weight is numerically small
                    ptt%table(2,j) = MACHP
                endif
                sumweight = sumweight + ptt%table(2,j)
            endif
        enddo

        !define size of the table
        ptt%n = numdata
        ptt%sumw = sumweight

        ! Compute nscores
        call nscore_transtable ( ptt, numq )

        build_transtablew_by_category = .true.
        return
    end function build_transtablew_by_category

    ! Compute the normal scores for a transform table
    ! The table contains the number of data and total weight needed.
    ! If numq is passed in > 0, then the size of the table is
    ! cut back.
    subroutine nscore_transtable ( ptt, numq )
        type(transtable), target, intent(inout) :: ptt
        integer, intent (in) :: numq
        real*8 :: w, wf, cp0, cp1
        real*8, pointer :: z(:),q(:)
        integer :: i, j, n

        ! Sort data by value (this sort call sorts trtab by column 1)
        n = ptt%n
        i = qsort(ptt%table,1,n,(/1/))
        wf = 1. / ptt%sumw
        cp0 = 0.
        cp1 = 0.

        if(n > numq .and. numq > 0)then ! Resize for specified numq
            !Compute CDF
            do i = 1, n
                w =  wf * ptt%table(2,i)
                cp1 = cp1 + w
                ptt%table(2,i) = (cp1 + cp0) / 2.
                cp0 = cp1
            enddo

            !Generate a set of equally spaced normal values covering
            !the range of quantiles in the full size transform table
            !cp0 and cp1 are reused for miny and maxy and w as the diff
            allocate(rwork(2,numq))
            z => ptt%table(1,:)
            q => ptt%table(2,:)
            cp0 = snorm_inv(q(1))
            cp1 = snorm_inv(q(n))
            w = (cp1 - cp0) / real(numq-1,8)

            do i = 1, numq
                rwork(2,i) = snorm_cdf(cp0+real(i-1,8)*w)
                call locate(q,n,1,n,rwork(2,i),j)
                j = min(max(1,j),(n-1))
                rwork(1,i) = powint(q(j),q(j+1),z(j),z(j+1),rwork(2,i),1.D0)
                rwork(2,i) = snorm_inv ( rwork(2,i) )
            enddo
            rwork(1,numq) = ptt%table(1,n)

            deallocate(ptt%table)
            allocate(ptt%table(2,numq))
            ptt%n = numq
            ptt%table(1,:) = rwork(1,:)
            ptt%table(2,:) = rwork(2,:)

            !Add small number to max so there is room for breaking ties
            ptt%table(1,1) = ptt%mint
            ptt%table(1,numq) = ptt%table(1,numq) + MACHP

            nullify(z)
            nullify(q)
            deallocate(rwork)
        else
            ! Compute the cumulative probabilities and nscore values
            do i = 1, n
                w =  wf * ptt%table(2,i)
                cp1 = cp1 + w
                ptt%table(2,i) = snorm_inv ( (cp1 + cp0) / 2. )
                cp0 = cp1
            enddo

            !Add small number to max so there is room for breaking ties
            ptt%table(1,n) = ptt%table(1,n) + MACHP

        endif

        return
    end subroutine nscore_transtable

end module normalscore


! FOBOS-binaries.f90 takes two epochs of observation of a two body system and fits
    ! the orbital parameters (semi-major axis, eccentricity, inclination, orientation, and
    ! mean anomaly). The code is currently set up to read two separations (in milliarcseconds,
    ! column 2) and two position angles (in degrees, column 4), plus their associated respective
    ! errors (columns 3 and 5) from a text file called "input". The input file will have the format

    ! t1 (yrs)  sep1 (mas)  sep_err1 (mas)  pa1 (deg)   pa_err1 (deg)
    ! t2 (yrs)  sep2 (mas)  sep_err2 (mas)  pa2 (deg)   pa_err2 (deg)

    ! The value for t1 will typically be zero and t2 the number of years between
    ! the first and second epochs of observation.

    ! The target name, which affects the name of the output files, is given in a text file
    ! called "sys-name". The masses and distance to the objects are contained in the file
    ! "mass-dist", which has the format

    ! M1 M1_err  M2  M2_err  d   d_err

    ! All masses will be given in solar masses and distances in parsecs

PROGRAM binaries
    IMPLICIT NONE
    INCLUDE "omp_lib.h"

    INTEGER:: n,i,idum,kdum,match,nmatch
    INTEGER:: nt,my_id,count,loop
    REAL:: M(1:2),M_err(1:2),dtobs,amin,amax,vobs,d,d_err,er
    REAL:: obs(1:3),err(1:3),params(1:5),sep(1:3)
    REAL:: seps(1:2),sep_err(1:2),pa(1:2),pa_err(1:2)
    REAL:: pi,au,year,msun,G,d2r,dmoved
    REAL:: t_run,ran3
    INTEGER,ALLOCATABLE:: rinit(:)
    !Parameters to read in from file
    REAL:: obsdata(1:5,1:2)
    REAL:: properties(1:6)
    CHARACTER(len=1024):: name

    !Date and time and filenames
    CHARACTER(len=1024):: fname
    CHARACTER(*), PARAMETER:: fpath="./"
    CHARACTER(10):: dat,tim
    INTEGER(8) :: dt(1:8)

    !Required to make ran3 parallelisable
    INTEGER :: iff,inext,inextp,ma(55)
    COMMON /ranvar/ iff,inext,inextp,ma
    !$OMP THREADPRIVATE(/ranvar/)

    OPEN(unit=1,file=fpath//"input",status="old")
    OPEN(unit=2,file=fpath//"mass-dist",status="old")
    OPEN(unit=3,file=fpath//"sys-name",status="old")

    !Read the values into their arrays
    READ(1,*) obsdata
    READ(2,*) properties
    READ(3,*) name
    !Close files after reading
    CLOSE(1)
    CLOSE(2)
    CLOSE(3)

    !Simulation parameters
    n     = 1e9                 !Number of iterations of the main do loop before checking for matches
    kdum  = 625                 !Random seed
    nmatch= 5000                !Number of required matches before terminating the simulation
    nt=omp_get_max_threads()    !Number of threads to use (set to run on all)

    !Constants
    pi  = 4.*ATAN(1.)
    au  = 1.5E11
    year= 365.25*24.*3600.
    msun= 1.989E30
    G   = 6.67E-11
    d2r = pi/180.

    !Counters
    count=0
    loop=0

    !Unpacking the input data (separations and position angles)
    seps    = obsdata(2,:)
    sep_err = obsdata(3,:)
    pa      = obsdata(4,:)*d2r
    pa_err  = obsdata(5,:)*d2r

    !Masses and distance
    M(1)    = properties(1)
    M_err(1)= properties(2)
    M(2)    = properties(3)
    M_err(2)= properties(4)
    d       = properties(5)
    d_err   = properties(6)

    !Converting separations into au
    obs(1) = seps(1)*(1.E-3)*d
    obs(2) = seps(2)*(1.E-3)*d

    !Calculaing the change in position angle between observations
    obs(3) = pa(2)-pa(1)

    !Factor to multiply the errors by (er=1. means use 1 sigma errors,
    !er=2. would use 2 sigma errors, etc.)
    er = 1.

    !Errors on separation and position angles (in au and radians)
    err(1) = obs(1) * SQRT((sep_err(1)/seps(1))**2. + (d_err/d)**2.)*er
    err(2) = obs(2) * SQRT((sep_err(2)/seps(2))**2. + (d_err/d)**2.)*er
    err(3) = (pa_err(1)+pa_err(2))*er

    !Time between observations
    dtobs = obsdata(1,2)-obsdata(1,1)

    !Calculating on sky velocity
    CALL cosine(obs(1),obs(2),obs(3),dmoved)
    vobs = (dmoved*au)/(dtobs*year)

    !Minimum and maximum semi-major axes
    amin = MIN(obs(1),obs(2))*0.5
    amax = 100.*G*(M(1)+M(2))*msun/(vobs*vobs*au)

    !Creating output file
    WRITE(fname,"(A,A100)") "params-",name
    OPEN(unit=1,file=fpath//trim(fname),status="new")

    !File preamble
        CALL DATE_AND_TIME(DATE=dat,TIME=tim,VALUES=dt)
        WRITE(1,'(A)') "This file contains the results of testing the FOBOS code (Houghton & Goodwin, in prep)"
        WRITE(1,'(A)') "using two astrometric data points on the binary/exoplanetary system: ",trim(name)
        WRITE(1,'(A,I2,A,I2,A,I4,A,I2,A,I2,A,I2)') "This simulation ran on ",dt(3),"/",dt(2),"/",dt(1), &
        " at ",dt(5),":",dt(6),":",dt(7)
        WRITE(1,'(A,F4.2,A,F4.2,A,F4.2)') "Object masses: m1=",M(1),", m2=",M(2)
        WRITE(1,'(A,F4.2,A)') "Time between observations: ",dtobs," years"
        WRITE(1,'(A,E8.1,A,I2,A)') "Tested ",REAL(n),"fake systems per loop using across ",nt," threads."
        WRITE(1,'(A,I3)') "The random seed value was ",kdum
        WRITE(1,'(A,F3.1)') "The error multiplication factor for this run was:",er
    !End file preamble

    !Random seeds for different threads
    CALL omp_set_num_threads(nt)
    ALLOCATE(rinit(nt))
    do i=1,nt
        rinit(i)=int(ran3(kdum)*1000000)
    end do

    !Main do loop
1   CONTINUE
    !$OMP PARALLEL PRIVATE(my_id,idum,params,match,sep)
    if (loop==0) then
        my_id= omp_get_thread_num()+1
        idum = rinit(my_id)
    end if
    !$OMP DO
    do i=1,n
        CALL fakesystem(amin,amax,dtobs,vobs,M,obs,err,idum,params,match,sep)
        if (match==1) then
            !$OMP CRITICAL
            WRITE(1,*) params
            count=count+1
            !$OMP END CRITICAL
        end if
    end do
    !$OMP END DO
    !$OMP END PARALLEL

    loop = loop + 1
    WRITE(6,*) "Loop:",loop,", Matches:",count
    call cpu_time(t_run)

    if (count<nmatch) goto 1

    !End of program admin
    DEALLOCATE(rinit)
    WRITE(1,"(A,F8.2,A)") "Run time =", t_run/nt, "s"
    WRITE(1,*) "Number of loops:",loop, " and final number of matches:",count

    !Close files
    CLOSE(1)

END PROGRAM binaries

!----------------------------------------------------------------
!Projects the binary randomly on the sky
SUBROUTINE makeobsbinary(a,ecc,inc,phi,mean,sky)
    IMPLICIT NONE

    REAL, INTENT(in) :: a,ecc,inc,phi,mean
    REAL, INTENT(out):: sky(1:2)
    REAL:: pi,Ee,old,theta,rt,r(1:3),x,y

    pi=4.*ATAN(1.)

    !Calculate eccentric anomaly with Newton-Raphson
    Ee=mean
    old=mean
    do
        old=Ee
        Ee=Ee-(Ee-ecc*SIN(Ee)-mean)/(1.-ecc*COS(Ee))
        if (old-Ee<1.E-6) exit
    end do

    !Calculate true anomaly and true distance
    theta=2.*ATAN(SQRT((1.+ecc)/(1.-ecc))*TAN(0.5*Ee))
    rt = a*(1.-ecc*ecc)/(1.+ecc*COS(theta))

    !Get x and y positions
    r(1:3)=0.
    r(1)=rt*COS(theta)
    r(2)=rt*SIN(theta)
    !Orientation around z axis
    x=r(1);y=r(2)
    r(1)=x*COS(phi)-y*SIN(phi)
    r(2)=x*SIN(phi)+y*COS(phi)
    !Modify inclination
    x=r(1);y=r(2)
    r(1)=x
    r(2)=y*COS(inc)
    r(3)=y*SIN(inc)
    !Positions on the sky
    sky(1)=r(1)
    sky(2)=r(3)

END SUBROUTINE makeobsbinary

!----------------------------------------------------------------
SUBROUTINE fakesystem(amin,amax,dtobs,vobs,M,obs,err,idum,params,match,sep)
    IMPLICIT NONE

    REAL, INTENT(in) :: amin,amax,dtobs,vobs,M(1:2),obs(1:3),err(1:3)
    REAL, INTENT(out):: params(1:5),sep(1:3)
    INTEGER, INTENT(in) :: idum
    INTEGER, INTENT(out):: match
    INTEGER:: i
    REAL:: a,ecc,inc,phi,mean1,mean2
    REAL:: sky1(1:2),sky2(1:2),rt
    REAL:: pi,G,au,msun,v,T,dM,f(1:2)
    REAL:: ran3
    EXTERNAL:: ran3

    !Constants
    pi=4.*ATAN(1.)
    G=6.67E-11
    msun=1.989E30
    au=1.496E11

    !Set match-0
    match=0

    !Generate system parameters
    a=amin+(ran3(idum)*amax)
    ecc=ran3(idum)*0.99
    inc=ASIN(ran3(idum))
    phi=ran3(idum)*2.*pi
    mean1=ran3(idum)*2.*pi
    params=(/a,ecc,inc,phi,mean1/)

    !Period
    T=SQRT((a*a*a)/(M(1)+M(2)))

    !Fraction of orbit moved
    dM=(dtobs/T)*2.*pi

    !Project on to the sky
    CALL skyproject(a,ecc,inc,phi,mean1,rt,sky1)
    sep(1)=SQRT(sky1(1)*sky1(1)+sky1(2)*sky1(2))

    !Orbital velocity
    v=G*(M(1)+M(2))*msun*((2./(rt*au))-(1./(a*au)))

    !Throw away systems where v<vobs, true distance<separation
    !or the separation doesn't match observation within errors
    if (v<vobs) goto 10
    if (rt<obs(1)) goto 10
    if (ABS(obs(1)-sep(1))>err(1)) goto 10

    rt=0.
    f=(/1.,-1./)

    !Do loop checking orbit moving both ways
    do i=1,2
        mean2=mean1+f(i)*dM
        CALL skyproject(a,ecc,inc,phi,mean2,rt,sky2)
        if (rt<obs(2)) cycle
        v=G*(M(1)+M(2))*msun*((2./(rt*au))-(1./(a*au)))
        if (v<vobs) goto 10
        sep(2)=SQRT(sky2(1)*sky2(1)+sky2(2)*sky2(2))
        if (ABS(obs(2)-sep(2))>err(2)) cycle
        sep(3)=ATAN2(sky2(2),sky2(1))-ATAN2(sky1(2),sky1(1))
        if (ABS(ABS(obs(3))-ABS(sep(3)))>err(3)) cycle
        match=1
        exit
    end do

    !End sub with match=0 if no match or match=1 if match

10  CONTINUE

CONTAINS
SUBROUTINE skyproject(a,ecc,inc,phi,mean,rt,sky)
    IMPLICIT NONE

    REAL, INTENT(in) :: a,ecc,inc,phi,mean
    REAL, INTENT(out):: rt,sky(1:2)
    REAL:: Ee,old,theta,r(1:3),x,y

    !Calculate eccentric anomaly with Newton-Raphson
    Ee=mean
    old=mean
    do
        old=Ee
        Ee=Ee-(Ee-ecc*SIN(Ee)-mean)/(1.-ecc*COS(Ee))
        if (old-Ee<1.e-6) exit
    end do

    !Calculate true anomaly and true distance
    theta=2.*ATAN(SQRT((1.+ecc)/(1.-ecc))*TAN(0.5*Ee))
    rt = a*(1.-ecc*ecc)/(1.+ecc*COS(theta))

    !Get x and y positions
    r(1:3)=0.
    r(1)=rt*COS(theta)
    r(2)=rt*SIN(theta)
    !Orientation around z axis
    x=r(1);y=r(2)
    r(1)=x*COS(phi)-y*SIN(phi)
    r(2)=x*SIN(phi)+y*COS(phi)
    !Modify inclination
    x=r(1);y=r(2)
    r(1)=x
    r(2)=y*COS(inc)
    r(3)=y*SIN(inc)
    !Positions on the sky
    sky(1)=r(1)
    sky(2)=r(3)

END SUBROUTINE skyproject

END SUBROUTINE fakesystem

!----------------------------------------------------------------
SUBROUTINE cosine(a,b,theta,c)
    IMPLICIT NONE

    REAL, INTENT(in) :: a,b,theta
    REAL, INTENT(out):: c

    c=SQRT(a*a + b*b - 2.*a*b*COS(theta))

END SUBROUTINE cosine

!======================================================
!--------------------RAN3------------------------------
!Random number generator from Numerical Recipes in Fortran
REAL FUNCTION ran3(idum)
    INTEGER :: idum
    INTEGER :: MBIG,MSEED,MZ
    REAL :: FAC
    PARAMETER (MBIG=1000000000,MSEED=161803398,MZ=0,FAC=1./MBIG)
    INTEGER :: i,iff,ii,inext,inextp,k
    INTEGER :: mj,mk,ma(55)
    !SAVE iff,inext,inextp,ma
    COMMON /ranvar/ iff,inext,inextp,ma
    !$OMP THREADPRIVATE(/ranvar/)
    DATA iff /0/
    IF(idum.LT.0.OR.iff.EQ.0)THEN
      iff=1
      mj=MSEED-iabs(idum)
      mj=MOD(mj,MBIG)
      ma(55)=mj
      mk=1
      DO 11 i=1,54
        ii=MOD(21*i,55)
        ma(ii)=mk
        mk=mj-mk
        IF(mk.LT.MZ)mk=mk+MBIG
        mj=ma(ii)
    11      CONTINUE
      DO 13 k=1,4
        DO 12 i=1,55
          ma(i)=ma(i)-ma(1+MOD(i+30,55))
          IF(ma(i).LT.MZ)ma(i)=ma(i)+MBIG
    12        CONTINUE
    13      CONTINUE
      inext=0
      inextp=31
      idum=1
    ENDIF
    inext=inext+1
    IF(inext.EQ.56)inext=1
    inextp=inextp+1
    IF(inextp.EQ.56)inextp=1
    mj=ma(inext)-ma(inextp)
    IF(mj.LT.MZ)mj=mj+MBIG
    ma(inext)=mj
    ran3=mj*FAC
    RETURN
END FUNCTION ran3

FUNCTION ran_normal(mu,sigma,idum)
    REAL:: ran3,ran_normal
    REAL:: pi
    EXTERNAL:: ran3
    pi=4.*ATAN(1.)
    ran_normal=(1./(sigma*SQRT(2*pi))*EXP(-0.5*((ran3(idum)-mu)/sigma)**2.))
    return
END FUNCTION ran_normal