LU :
+ LU(:,:) = A(:,:)
+ CALL LU_factor(LU(:,:), indx, error)
+ IF (LEN_TRIM(error) /= 0) THEN
+ error = " -> linal : matinv : LU factorization unsuccessful." // &
+ TRIM(error)
+ DEALLOCATE(LU, stat=err)
+ DEALLOCATE(indx, stat=err)
+ RETURN
+ END IF
+
+ ! Initialize the identity matrix:
+ matinv_r8(:,:) = 0.0_rprec8
+ FORALL(i=1:n)
+ matinv_r8(i,i) = 1.0_rprec8
+ END FORALL
+
+ ! Solve b from LUb = e_i and put A(:,i) = b:
+ DO i=1,n
+ CALL LU_solve(LU, indx, matinv_r8(1:n,i))
+ END DO
+
+ DEALLOCATE(LU, indx, stat=err)
+ IF (err /= 0) THEN
+ error = " -> linal : matinv : Could not deallocate memory." // &
+ TRIM(error)
+ DEALLOCATE(LU, stat=err)
+ DEALLOCATE(indx, stat=err)
+ RETURN
+ END IF
+
+ ELSE IF (method_ == "Cholesky") THEN
+
+ ALLOCATE(L(n,n), p(n), stat=err)
+ IF (err /= 0) THEN
+ error = " -> linal : matinv : Could not allocate memory." // &
+ TRIM(error)
+ DEALLOCATE(L, stat=err)
+ DEALLOCATE(p, stat=err)
+ RETURN
+ END IF
+
+ L(:,:) = A(:,:)
+ CALL cholesky_decomposition(L, p, error)
+ IF (LEN_TRIM(error) /= 0) THEN
+ error = " -> linal : matinv : ." // &
+ TRIM(error)
+ DEALLOCATE(L, stat=err)
+ DEALLOCATE(p, stat=err)
+ RETURN
+ END IF
+
+ ! Initialize the identity matrix:
+ matinv_r8(:,:) = 0.0_rprec8
+ FORALL(i=1:n)
+ matinv_r8(i,i) = 1.0_rprec8
+ END FORALL
+
+ ! Solve b from L * Transpose(L) * b = e_i and put A(:,i) = b:
+ DO i=1,n
+ CALL cholesky_solve(L, p, matinv_r8(1:n,i), matinv_r8(1:n,i), error)
+ IF (LEN_TRIM(error) /= 0) THEN
+ error = " -> linal : matinv : ." // &
+ TRIM(error)
+ DEALLOCATE(L, stat=err)
+ DEALLOCATE(p, stat=err)
+ RETURN
+ END IF
+ END DO
+
+ DEALLOCATE(L, p, stat=err)
+ IF (err /= 0) THEN
+ error = " -> linal : matinv : Could not deallocate memory." // &
+ TRIM(error)
+ DEALLOCATE(L, stat=err)
+ DEALLOCATE(p, stat=err)
+ RETURN
+ END IF
+
+ ELSE
+
+ ! No such option...
+ error = " -> linal : matinv : No such option." // &
+ TRIM(error)
+
+ END IF
+
+ END FUNCTION matinv_r8
+
+
+
+
+
+ FUNCTION matinv_r16(A, error)
+
+ !! Returns the inverse matrix of square matrix.
+ !!
+ !! Input: - Square matrix A(n,n)
+ !! - Inverse square matrix inv_A(n,n)
+ !! Output: - Error (.false., if ok) error
+
+ IMPLICIT NONE
+ REAL(rprec16), DIMENSION(:,:), INTENT(in) :: A
+ REAL(rprec16), DIMENSION(SIZE(A,dim=2),SIZE(A,dim=1)) :: matinv_r16
+ CHARACTER(len=*), INTENT(inout) :: error
+
+ REAL(rprec16), DIMENSION(:,:), ALLOCATABLE :: LU
+ INTEGER, DIMENSION(:), ALLOCATABLE :: indx
+ INTEGER :: i, n, err
+
+ n = SIZE(A,dim=1)
+ IF (n /= SIZE(A,dim=2)) THEN
+ error = " -> linal : matinv : Input not a square matrix." // &
+ TRIM(error)
+ RETURN
+ END IF
+
+ ALLOCATE(LU(n,n), indx(n), stat=err)
+ IF (err /= 0) THEN
+ error = " -> linal : matinv : Could not allocate memory." // &
+ TRIM(error)
+ DEALLOCATE(LU, stat=err)
+ DEALLOCATE(indx, stat=err)
+ RETURN
+ END IF
+
+ ! A => LU :
+ LU(:,:) = A(:,:)
+ CALL LU_factor(LU(:,:), indx, error)
+ IF (LEN_TRIM(error) /= 0) THEN
+ error = " -> linal : matinv : LU factorization unsuccessful." // &
+ TRIM(error)
+ DEALLOCATE(LU, stat=err)
+ DEALLOCATE(indx, stat=err)
+ RETURN
+ END IF
+
+ ! Initialize the identity matrix:
+ matinv_r16(:,:) = 0.0_rprec16
+ FORALL(i=1:n)
+ matinv_r16(i,i) = 1.0_rprec16
+ END FORALL
+
+ ! Solve b from LUb = e_i and put A(:,i) = b:
+ DO i=1,n
+ CALL LU_solve(LU, indx, matinv_r16(1:n,i))
+ END DO
+
+ DEALLOCATE(LU, indx, stat=err)
+ IF (err /= 0) THEN
+ error = " -> linal : matinv : Could not deallocate memory." // &
+ TRIM(error)
+ DEALLOCATE(LU, stat=err)
+ DEALLOCATE(indx, stat=err)
+ RETURN
+ END IF
+
+ END FUNCTION matinv_r16
+
+
+
+
+
+ SUBROUTINE Gauss_elimination(A, b, error)
+
+ !! Solves a linear system by means of the Gauss elimination
+ !! procedure.
+ !!
+ !! Input: - Square matrix A(n,n)
+ !! - Ax=b b(n)
+ !! - Number of columns/rows n
+ !! Output: - Ax=b => solve x => b=x b(n)
+ !! - Error (.false., if ok) error
+
+ IMPLICIT NONE
+ REAL(rprec8), DIMENSION(:,:), INTENT(in) :: A
+ REAL(rprec8), DIMENSION(:), INTENT(inout) :: b
+ CHARACTER(len=*), INTENT(inout) :: error
+ REAL(rprec8), DIMENSION(SIZE(A,dim=1),SIZE(A,dim=2)) :: AA
+ REAL(rprec8), DIMENSION(SIZE(b)) :: help_b
+ INTEGER, DIMENSION(SIZE(b)) :: ind
+ REAL(rprec8) :: smax, s, c
+ INTEGER :: i, ii, j, k, kk, l, m, n
+
+ n = SIZE(A,dim=1)
+
+ AA = A
+ ! Initialize the row permutation vector ind:
+ FORALL(i=1:n)
+ ind(i) = i
+ END FORALL
+
+ DO i=1, n
+ m = i
+ ! Find maximum element among the remaining
+ ! elements of this column.
+ smax = AA(ind(i),i)
+ DO k=i+1, n
+ s = ABS(AA(ind(k),i))
+ IF (s > smax) THEN
+ smax = s
+ m = k
+ END IF
+ END DO
+ l = ind(i)
+ ind(i) = ind(m)
+ ind(m) = l
+ ii = ind(i)
+ IF (ABS(AA(ii,i)) < EPSILON(AA(ii,i))) THEN
+ error = " -> linal : Gauss_elimination : Attempted division by zero." // &
+ TRIM(error)
+ RETURN
+ END IF
+ ! Calculate the upper triangular matrix by
+ ! means of the Gauss procedure:
+ DO k=i+1, n
+ kk = ind(k)
+ c = AA(kk,i) / AA(ii,i)
+ DO j=i, n
+ AA(kk,j) = AA(kk,j) - c * AA(ii,j)
+ END DO
+ b(kk) = b(kk) - c * b(ii)
+ END DO
+ END DO
+
+ ! Solve the upper triangular matrix by means
+ ! of backsubstitution:
+ DO i=n, 1, -1
+ ii = ind(i)
+ b(ii) = b(ii) / AA(ii,i)
+ DO k=i-1, 1, -1
+ kk = ind(k)
+ b(kk) = b(kk) - AA(kk,i) * b(ii)
+ END DO
+ END DO
+
+ ! "Unpermutate" the solution in order to get
+ ! a solution, which corresponds to the original,
+ ! given matrix:
+ help_b = b
+ FORALL(i=1:n)
+ b(i) = help_b(ind(i))
+ END FORALL
+
+ END SUBROUTINE Gauss_elimination
+
+
+
+
+
+ SUBROUTINE gauss_jordan(a, b, error)
+
+ IMPLICIT NONE
+ REAL(rprec8), DIMENSION(:,:), INTENT(inout) :: a,b
+ CHARACTER(len=*), INTENT(inout) :: error
+ INTEGER, DIMENSION(SIZE(a,1)) :: ipiv,indxr,indxc
+ LOGICAL, DIMENSION(SIZE(a,1)) :: lpiv
+ REAL(rprec8) :: pivinv
+ REAL(rprec8), DIMENSION(SIZE(a,1)) :: dumc
+ INTEGER, DIMENSION(2), TARGET :: irc
+ INTEGER :: i,l,n
+ INTEGER, POINTER :: irow,icol
+
+ n = SIZE(a,dim=1)
+ irow => irc(1)
+ icol => irc(2)
+ ipiv = 0
+ DO i=1,n
+ lpiv = (ipiv == 0)
+ irc = MAXLOC(ABS(a),outerand(lpiv,lpiv))
+ ipiv(icol) = ipiv(icol) + 1
+ IF (ipiv(icol) > 1) THEN
+ error = " -> linal : gauss_jordan : Singular matrix (1)." // &
+ TRIM(error)
+ RETURN
+ END IF
+ IF (irow /= icol) THEN
+ CALL swap(a(irow,:),a(icol,:))
+ CALL swap(b(irow,:),b(icol,:))
+ END IF
+ indxr(i) = irow
+ indxc(i) = icol
+ IF (a(icol,icol) == 0.0) THEN
+ error = " -> linal : gauss_jordan : Singular matrix (2)." // &
+ TRIM(error)
+ RETURN
+ END IF
+ pivinv = 1.0_rprec8/a(icol,icol)
+ a(icol,icol) = 1.0_rprec8
+ a(icol,:) = a(icol,:)*pivinv
+ b(icol,:) = b(icol,:)*pivinv
+ dumc = a(:,icol)
+ a(:,icol) = 0.0
+ a(icol,icol) = pivinv
+ a(1:icol-1,:) = a(1:icol-1,:) - outer_product(dumc(1:icol-1),a(icol,:))
+ b(1:icol-1,:) = b(1:icol-1,:) - outer_product(dumc(1:icol-1),b(icol,:))
+ a(icol+1:,:) = a(icol+1:,:) - outer_product(dumc(icol+1:),a(icol,:))
+ b(icol+1:,:) = b(icol+1:,:) - outer_product(dumc(icol+1:),b(icol,:))
+ END DO
+ DO l=n,1,-1
+ CALL swap(a(:,indxr(l)),a(:,indxc(l)))
+ END DO
+
+ END SUBROUTINE gauss_jordan
+
+
+
+
+
+ SUBROUTINE tridiagonal_solve(A, b, error)
+
+ !! Solves a tridiagonal linear system.
+ !!
+ !! Input: - Tridigonal matrix (the non-null diagonals) A(n,3)
+ !! - Ax=b b(n)
+ !! Output: - Ax=b => x=bA^(-1) => b=x b(n)
+ !! - Error (.false., if ok) error
+
+ IMPLICIT NONE
+ REAL(rprec8), DIMENSION(:,:), INTENT(in) :: A
+ REAL(rprec8), DIMENSION(:), INTENT(inout) :: b
+ CHARACTER(len=*), INTENT(inout) :: error
+ REAL(rprec8), DIMENSION(SIZE(A,dim=1),3) :: AA
+ INTEGER :: i, n
+
+ n = SIZE(A,dim=1)
+ AA = A
+
+ DO i=2, n
+ IF (ABS(AA(i-1,2)) < EPSILON(AA(i-1,2))) THEN
+ error = " -> linal : tridiagonal_solve : Attempted division by almost zero." // &
+ TRIM(error)
+ RETURN
+ END IF
+ AA(i,2) = AA(i,2) - (AA(i,1) * AA(i-1,3)) / AA(i-1,2)
+ b(i) = b(i) - (AA(i,1) * b(i-1)) / AA(i-1,2)
+ END DO
+
+ b(n) = b(n) / AA(n,2)
+ DO i=n-1, 1, -1
+ b(i) = (b(i) - AA(i,3) * b(i+1)) / AA(i,2)
+ END DO
+
+ END SUBROUTINE tridiagonal_solve
+
+
+
+
+
+ SUBROUTINE Jacobi_iteration(A, b, error)
+
+ !! Solves a linear system by means of the Jacobi iteration
+ !! procedure.
+ !!
+ !! Input: - Square matrix A(n,n)
+ !! - Ax=b b(n)
+ !! Output: - Ax=b => solve x => b=x b(n)
+ !! - Error (.false., if ok) error
+ !!
+ !! Other: - Old solution vector x(n)
+ !! - New solution vector y(n)
+ !! - Difference between solution vectors diff
+ !! - Old difference between solution vectors old_diff
+
+ IMPLICIT NONE
+ REAL(rprec8), PARAMETER :: iteration_factor = 1.0_rprec8
+ REAL(rprec8), DIMENSION(:,:), INTENT(in) :: A
+ REAL(rprec8), DIMENSION(:), INTENT(inout) :: b
+ CHARACTER(len=*), INTENT(inout) :: error
+ REAL(rprec8), DIMENSION(SIZE(A,dim=1),SIZE(A,dim=2)) :: LU
+ REAL(rprec8), DIMENSION(SIZE(b)) :: D, x, y
+ REAL(rprec8) :: diff, old_diff
+ INTEGER :: iter, i, n
+
+ n = SIZE(A,dim=1)
+
+ ! A = L + U + D = (L + U) + D :
+ LU = A
+ FORALL(i=1:n)
+ D(i) = LU(i,i)
+ LU(i,i) = 0.0_rprec8
+ END FORALL
+ x = 0.0_rprec8
+ diff = HUGE(diff)
+ iter = 1
+
+ DO WHILE (diff > iteration_factor*EPSILON(diff))
+ DO i=1, n
+ IF (ABS(D(i)) < EPSILON(D(i))) THEN
+ error = " -> linal : Jacobi_iteration : Attempted division by almost zero." // &
+ TRIM(error)
+ RETURN
+ END IF
+ y(i) = (b(i) - DOT_PRODUCT(LU(i,:), x)) / D(i)
+ END DO
+ old_diff = diff
+ diff = SQRT(DOT_PRODUCT(x-y, x-y))
+ IF (diff > old_diff) THEN
+ error = " -> linal : Jacobi_iteration : Iteration divergent." // &
+ TRIM(error)
+ RETURN
+ END IF
+ x = y
+ iter = iter + 1
+ IF (iter > max_iter) THEN
+ error = " -> linal : Jacobi_iteration : Reached maximum number of iterations." // &
+ TRIM(error)
+ RETURN
+ END IF
+ END DO
+
+ b = x
+
+ END SUBROUTINE Jacobi_iteration
+
+
+
+
+ SUBROUTINE Gauss_Seidel_iteration(A, b, error)
+
+ !! Solves a linear system by means of the Gauss-Seidel iteration
+ !! procedure.
+ !!
+ !! Input: - Square matrix A(n,n)
+ !! - Ax=b b(n)
+ !! Output: - Ax=b => solve x => b=x b(n)
+ !! - Error (.false., if ok) error
+ !!
+ !! Other: - Old solution vector x(n)
+ !! - New solution vector y(n)
+ !! - Difference between solution vectors diff
+ !! - Old difference between solution vectors old_diff
+
+ IMPLICIT NONE
+ REAL(rprec8), PARAMETER :: iteration_factor = 1.0_rprec8
+ REAL(rprec8), DIMENSION(:,:), INTENT(in) :: A
+ REAL(rprec8), DIMENSION(SIZE(A,dim=1)), INTENT(inout) :: b
+ CHARACTER(len=*), INTENT(inout) :: error
+ REAL(rprec8), DIMENSION(SIZE(A,dim=1),SIZE(A,dim=2)) :: LU
+ REAL(rprec8), DIMENSION(SIZE(b)) :: D, x, y
+ REAL(rprec8) :: diff, old_diff
+ INTEGER :: n, iter, i
+ INTRINSIC sqrt
+
+ n = SIZE(A,dim=1)
+
+ ! A = L + U + D = (L + U) + D :
+ LU = A
+ FORALL(i=1:n)
+ D(i) = LU(i,i)
+ LU(i,i) = 0.0_rprec8
+ END FORALL
+
+ x = 0.0_rprec8
+ y = 0.0_rprec8
+ diff = HUGE(diff)
+ iter = 1
+
+ DO WHILE (diff > iteration_factor*EPSILON(diff))
+ DO i=1, n
+ IF (ABS(D(i)) < EPSILON(D(i))) THEN
+ error = " -> linal : Gauss_Seidel_iteration : Attempted division by almost zero." // &
+ TRIM(error)
+ RETURN
+ END IF
+ y(i) = (b(i) - DOT_PRODUCT(LU(i,1:i-1), y(1:i-1)) - &
+ DOT_PRODUCT(LU(i,i+1:n), x(i+1:n))) / D(i)
+ END DO
+ old_diff = diff
+ diff = SQRT(DOT_PRODUCT(x - y, x - y))
+ IF (diff > old_diff) THEN
+ error = " -> linal : Gauss_Seidel_iteration : Iteration divergent." // &
+ TRIM(error)
+ RETURN
+ END IF
+ x = y
+ iter = iter + 1
+ IF (iter > max_iter) THEN
+ error = " -> linal : Gauss_Seidel_iteration : Reached maximum number of iterations." // &
+ TRIM(error)
+ RETURN
+ END IF
+ END DO
+
+ b = x
+
+ END SUBROUTINE Gauss_Seidel_iteration
+
+
+
+
+
+ REAL(rprec8) FUNCTION determinant(A, error)
+
+ !! Returns the determinant of a square matrix.
+ !!
+ !! Input: - Square matrix A(n,n)
+ !! Output: - Error message (.false., if ok) error
+
+ IMPLICIT NONE
+ REAL(rprec8), DIMENSION(:,:), INTENT(in) :: A
+ CHARACTER(len=*), INTENT(inout) :: error
+ REAL(rprec8), DIMENSION(SIZE(A,dim=1),SIZE(A,dim=2)) :: B
+ INTEGER, DIMENSION(SIZE(A,dim=1)) :: indx
+ INTEGER :: i
+
+ B = A
+
+ ! A => LU :
+ CALL LU_factor(B, indx, error)
+ IF (LEN_TRIM(error) /= 0) THEN
+ error = " -> linal : determinant : ." // TRIM(error)
+ determinant = 0.0_rprec8
+ RETURN
+ END IF
+ ! det = U(1,1)*U(2,2)*U(3,3)*...*U(n,n)
+ determinant = 1.0_rprec8
+ DO i=1, SIZE(B,dim=1)
+ determinant = determinant * B(i,i)
+ END DO
+
+ END FUNCTION determinant
+
+
+
+
+
+ REAL(rprec8) FUNCTION cond_nr(A, error)
+
+ !! Finds the condition number of a given matrix. A failure in the
+ !! matrix inversion results in a huge condition number.
+ !!
+ !! Input: - Square matrix A(n,n)
+ !! Output: - Error (.false., if ok) error
+ !!
+ !! Other: - Matrix norm of A A_norm
+ !! - Matrix norm of A^(-1) inv_A_norm
+
+ IMPLICIT NONE
+ REAL(rprec8), DIMENSION(:,:), INTENT(in) :: A
+ CHARACTER(len=*), INTENT(inout) :: error
+ REAL(rprec8), DIMENSION(SIZE(A,dim=2),SIZE(A,dim=1)) :: inv_A
+ REAL(rprec8) :: A_norm, inv_A_norm
+
+ A_norm = matnorm(A)
+ inv_A = matinv(A, error)
+ IF (LEN_TRIM(error) /= 0) THEN
+ error = " -> linal : cond_nr : ." // TRIM(error)
+ cond_nr = HUGE(cond_nr)
+ RETURN
+ END IF
+ inv_A_norm = matnorm(inv_A)
+ cond_nr = A_norm * inv_A_norm
+
+ END FUNCTION cond_nr
+
+
+
+
+
+ REAL(rprec8) FUNCTION matnorm(A)
+
+ !! Finds the matrix norm of a given matrix.
+ !!
+ !! Input: - Matrix A(:,:)
+
+ IMPLICIT NONE
+ REAL(rprec8), DIMENSION(:,:), INTENT(in) :: A
+ REAL(rprec8), DIMENSION(SIZE(A,dim=1)) :: s
+ INTEGER :: i
+
+ ! Find the sum of each row:
+ FORALL(i=1:SIZE(A,dim=1))
+ s(i) = SUM(ABS(A(i,1:SIZE(A,dim=2))))
+ END FORALL
+ ! Matrix norm is equal to the greatest sum:
+ matnorm = MAXVAL(s)
+
+ END FUNCTION matnorm
+
+
+
+
+ SUBROUTINE matrix_print_r8(A, lu, error, frmt, row_indx, column_indx)
+
+ !! Writes the given matrix to the given i/o-unit using a nice
+ !! layout.
+ !!
+ !! Input: - Square matrix A(n,n)
+ !! - I/O-unit iounit
+
+ IMPLICIT NONE
+ REAL(rprec8), DIMENSION(:,:), INTENT(in) :: A
+ INTEGER, INTENT(in) :: lu
+ CHARACTER(len=*), INTENT(inout) :: error
+ CHARACTER(len=*), INTENT(in), OPTIONAL :: frmt
+ INTEGER, DIMENSION(:), INTENT(in), OPTIONAL :: row_indx
+ INTEGER, DIMENSION(:), INTENT(in), OPTIONAL :: column_indx
+ CHARACTER(len=32) :: form
+ INTEGER, DIMENSION(:), ALLOCATABLE :: indx1, indx2
+ INTEGER :: i, j, siz1, siz2, err
+
+ siz1 = SIZE(A, dim=1)
+ siz2 = SIZE(A, dim=2)
+ ALLOCATE(indx1(siz1), indx2(siz2), stat=err)
+ IF (err /= 0) THEN
+ error = " -> linal : matrix_print : Could not allocate memory." // &
+ TRIM(error)
+ RETURN
+ END IF
+
+ IF (PRESENT(frmt)) THEN
+ form = TRIM(frmt)
+ ELSE
+ form = TRIM(frmt_default)
+ END IF
+ IF (PRESENT(row_indx)) THEN
+ indx1 = row_indx
+ ELSE
+ DO i=1,siz1
+ indx1(i) = i
+ END DO
+ END IF
+ IF (PRESENT(column_indx)) THEN
+ indx2 = column_indx
+ ELSE
+ DO i=1,siz2
+ indx2(i) = i
+ END DO
+ END IF
+
+ ! Write the matrix row-wise:
+ DO i=1,siz1
+ DO j=1,siz2
+ WRITE(lu,TRIM(form),advance='no') A(indx1(i),indx2(j))
+ END DO
+ WRITE(lu,*)
+ END DO
+
+ DEALLOCATE(indx1, indx2, stat=err)
+ IF (err /= 0) THEN
+ error = " -> linal : matrix_print : Could not deallocate memory." // &
+ TRIM(error)
+ DEALLOCATE(indx1, stat=err)
+ DEALLOCATE(indx2, stat=err)
+ RETURN
+ END IF
+
+ END SUBROUTINE matrix_print_r8
+
+
+
+
+
+ SUBROUTINE matrix_print_r16(A, lu, error, frmt)
+
+ !! Writes the given matrix to the given i/o-unit using a nice
+ !! layout.
+ !!
+ !! Input: - Square matrix A(n,n)
+ !! - I/O-unit lu
+
+ IMPLICIT NONE
+ REAL(rprec16), DIMENSION(:,:), INTENT(in) :: A
+ INTEGER, INTENT(in) :: lu
+ CHARACTER(len=*), INTENT(inout) :: error
+ CHARACTER(len=*), INTENT(in), OPTIONAL :: frmt
+ REAL(rprec16), DIMENSION(:,:), ALLOCATABLE :: AA
+ CHARACTER(len=30) :: form, c
+ REAL :: x, y
+ INTEGER, DIMENSION(2) :: lo_bound, up_bound
+ INTEGER :: i, n, p, err
+
+ INTRINSIC lbound, ubound, fraction, nint, char, trim
+
+ lo_bound = LBOUND(A)
+ up_bound = UBOUND(A)
+ ALLOCATE(AA(lo_bound(1):up_bound(1),lo_bound(2):up_bound(2)), stat=err)
+ IF (err /= 0) THEN
+ error = " -> linal : matrix_print : Could not allocate memory." // &
+ TRIM(error)
+ RETURN
+ END IF
+ AA = A
+
+ ! Change integer n to character c (= n):
+ n = up_bound(2) - lo_bound(2) + 1
+ c = ''
+ DO WHILE (n > 0)
+ x = n / 10.0
+ y = FRACTION(x)
+ n = NINT(x - y)
+ p = NINT(10 * y)
+ c = CHAR(48 + p) // TRIM(c)
+ END DO
+
+ IF (PRESENT(frmt)) THEN
+ form = '(' // TRIM(c) // TRIM(frmt) // ')'
+ ELSE
+ form = '(' // TRIM(c) // TRIM(frmt_default) // ')'
+ END IF
+
+ ! Write the matrix row-wise:
+ DO i=lo_bound(1), up_bound(1)
+ WRITE(lu,TRIM(form)) AA(i,:)
+ END DO
+
+ DEALLOCATE(AA, stat=err)
+ IF (err /= 0) THEN
+ error = " -> linal : matrix_print : Could not deallocate memory." // &
+ TRIM(error)
+ RETURN
+ END IF
+
+ END SUBROUTINE matrix_print_r16
+
+
+
+
+
+ !! *Description*:
+ !!
+ !! Ref. Numerical Recipes for Fortran 90, Sect. 23.5
+ !!
+ FUNCTION outer_product_r4(a, b)
+
+ IMPLICIT NONE
+ REAL(rprec4), DIMENSION(:), INTENT(in) :: a, b
+ REAL(rprec4), DIMENSION(SIZE(a),SIZE(b)) :: outer_product_r4
+
+ outer_product_r4 = SPREAD(a,dim=2,ncopies=SIZE(b)) * &
+ SPREAD(b,dim=1,ncopies=SIZE(a))
+
+ END FUNCTION outer_product_r4
+
+
+
+
+
+ !! *Description*:
+ !!
+ !! Ref. Numerical Recipes for Fortran 90, Sect. 23.5
+ !!
+ FUNCTION outer_product_r8(a, b)
+
+ IMPLICIT NONE
+ REAL(rprec8), DIMENSION(:), INTENT(in) :: a, b
+ REAL(rprec8), DIMENSION(SIZE(a),SIZE(b)) :: outer_product_r8
+
+ outer_product_r8 = SPREAD(a,dim=2,ncopies=SIZE(b)) * &
+ SPREAD(b,dim=1,ncopies=SIZE(a))
+
+ END FUNCTION outer_product_r8
+
+
+
+
+
+ !! *Description*:
+ !!
+ !! Ref. Numerical Recipes for Fortran 90, Sect. 23.5
+ !!
+ FUNCTION outer_product_r16(a, b)
+
+ IMPLICIT NONE
+ REAL(rprec16), DIMENSION(:), INTENT(in) :: a, b
+ REAL(rprec16), DIMENSION(SIZE(a),SIZE(b)) :: outer_product_r16
+
+ outer_product_r16 = SPREAD(a,dim=2,ncopies=SIZE(b)) * &
+ SPREAD(b,dim=1,ncopies=SIZE(a))
+
+ END FUNCTION outer_product_r16
+
+
+
+
+
+ !! *Description*:
+ !!
+ !! Returns the triple product (x dot (y cross z)) of three vectors
+ !! with three elements.
+ !!
+ REAL(rprec8) FUNCTION triple_product_r8(x,y,z)
+
+ IMPLICIT NONE
+ REAL(rprec8), DIMENSION(3), INTENT(in) :: x, y, z
+
+ triple_product_r8 = DOT_PRODUCT(x,cross_product(y,z))
+
+ END FUNCTION triple_product_r8
+
+
+
+
+
+ !! *Description*:
+ !!
+ !! Returns cross product of two 3-vectors.
+ !!
+ FUNCTION cross_product_r8(x,y) RESULT(cross_prod)
+
+ IMPLICIT NONE
+ REAL(rprec8), DIMENSION(3), INTENT(in) :: x, y
+ REAL(rprec8), DIMENSION(3) :: cross_prod
+
+ cross_prod(1) = x(2)*y(3) - x(3)*y(2)
+ cross_prod(2) = x(3)*y(1) - x(1)*y(3)
+ cross_prod(3) = x(1)*y(2) - x(2)*y(1)
+
+ END FUNCTION cross_product_r8
+
+
+
+
+
+ SUBROUTINE vector_print(b, lu, column, error, frmt)
+
+ !! Writes the given vector to the given i/o-unit using a nice
+ !! layout.
+ !!
+ !! Input: - Vector b(n)
+ !! - Column = .true., row = .false. column
+ !! - I/O-unit lu
+
+ IMPLICIT NONE
+ REAL(rprec8), DIMENSION(:), INTENT(in) :: b
+ INTEGER, INTENT(in) :: lu
+ LOGICAL, INTENT(in) :: column
+ CHARACTER(len=*), INTENT(inout) :: error
+ CHARACTER(len=*), INTENT(in), OPTIONAL :: frmt
+ REAL(rprec8), DIMENSION(:), ALLOCATABLE :: bb
+ CHARACTER(len=30) :: form, c
+ REAL :: x, y
+ INTEGER, DIMENSION(1) :: lo_bound, up_bound
+ INTEGER :: i, n, p, indx, err
+
+ INTRINSIC lbound, ubound, fraction, nint, char, trim
+
+ lo_bound = LBOUND(b)
+ up_bound = UBOUND(b)
+ ALLOCATE(bb(lo_bound(1):up_bound(1)), stat=err)
+ IF (err /= 0) THEN
+ error = " -> linal : vector_print : Could not allocate memory." // &
+ TRIM(error)
+ RETURN
+ END IF
+ bb = b
+
+ WHERE (ABS(bb) < EPSILON(bb)) bb = 0
+
+ IF (column) THEN
+ ! Writes a column vector:
+ IF (PRESENT(frmt)) THEN
+ ! Remove empty spaces:
+ indx = INDEX(frmt,',',back=.TRUE.)
+ form = '(' // frmt(1:indx-1) // '))'
+ ELSE
+ indx = INDEX(frmt_default,',',back=.TRUE.)
+ form = '(' // frmt_default(1:indx-1) // '))'
+ END IF
+ DO i=lo_bound(1), up_bound(1)
+ WRITE(lu,TRIM(form)) bb(i)
+ END DO
+ ELSE
+ ! Writes a row vector:
+ ! Change integer n to character c (= n):
+ n = up_bound(1) - lo_bound(1) + 1
+ c = ''
+ DO WHILE (n > 0)
+ x = n / 10.0
+ y = FRACTION(x)
+ n = NINT(x - y)
+ p = NINT(10 * y)
+ c = CHAR(48 + p) // TRIM(c)
+ END DO
+ IF (PRESENT(frmt)) THEN
+ form = '(' // TRIM(c) // TRIM(frmt) // ')'
+ ELSE
+ form = '(' // TRIM(c) // TRIM(frmt_default) // ')'
+ END IF
+ WRITE(lu,TRIM(form)) bb
+ END IF
+
+ DEALLOCATE(bb, stat=err)
+ IF (err /= 0) THEN
+ error = " -> linal : vector_print : Could not deallocate memory." // &
+ TRIM(error)
+ RETURN
+ END IF
+
+ END SUBROUTINE vector_print
+
+
+
+END MODULE linal
Index: trunk/mops/oorb/modules/parameters.f90
===================================================================
--- trunk/mops/oorb/modules/parameters.f90 (revision 34646)
+++ trunk/mops/oorb/modules/parameters.f90 (revision 34646)
@@ -0,0 +1,41 @@
+!====================================================================!
+! !
+! Copyright 2002,2003,2004,2005,2006,2007,2008,2009 !
+! Mikael Granvik, Jenni Virtanen, Karri Muinonen, Teemu Laakso, !
+! Dagmara Oszkiewicz !
+! !
+! This file is part of OpenOrb. !
+! !
+! OpenOrb 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. !
+! !
+! OpenOrb 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 OpenOrb. If not, see . !
+! !
+!====================================================================!
+!
+!! *Module*description*:
+!!
+!! Parameters for modules.
+!!
+!! @author MG
+!! @version 2009-04-17
+!!
+MODULE parameters
+
+ IMPLICIT NONE
+ INTEGER, PARAMETER :: iprec1 = SELECTED_INT_KIND(2)
+ INTEGER, PARAMETER :: iprec4 = SELECTED_INT_KIND(7)
+ INTEGER, PARAMETER :: iprec8 = SELECTED_INT_KIND(12)
+ INTEGER, PARAMETER :: rprec4 = SELECTED_REAL_KIND(p=6)
+ INTEGER, PARAMETER :: rprec8 = SELECTED_REAL_KIND(p=12)
+ INTEGER, PARAMETER :: rprec16 = SELECTED_REAL_KIND(p=18)
+
+END MODULE parameters
Index: trunk/mops/oorb/modules/planetary_data.f90
===================================================================
--- trunk/mops/oorb/modules/planetary_data.f90 (revision 34646)
+++ trunk/mops/oorb/modules/planetary_data.f90 (revision 34646)
@@ -0,0 +1,1419 @@
+!====================================================================!
+! !
+! Copyright 2002,2003,2004,2005,2006,2007,2008,2009,2010,2011,2012 !
+! Mikael Granvik, Jenni Virtanen, Karri Muinonen, Teemu Laakso, !
+! Dagmara Oszkiewicz !
+! !
+! This file is part of OpenOrb. !
+! !
+! OpenOrb 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. !
+! !
+! OpenOrb 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 OpenOrb. If not, see . !
+! !
+!====================================================================!
+!
+!! *Module*description*:
+!!
+!! Defines parameters relating to planets and minor planets in the
+!! solar system, and contains the routines for using planetary
+!! ephemeris provided by the Jet Propulsion Laboratory.
+!!
+!! This software is partly based on jplsub.f (by JPL) and a
+!! Fortran 90 compilation of the same software by Hannu Karttunen
+!! (Tuorla Observatory, Turku, Finland).
+!!
+!! *Example*:
+!!
+!!
+!!program myprog
+!!
+!! use planetary_data
+!! implicit none
+!! real(8), dimension(6) :: crtcrd
+!! real(8) :: t
+!! logical :: error
+!!
+!! crtcrd = JPL_ephemeris(t, 3, 11, error)
+!! if (error) stop 'Error 2'
+!!
+!!end program myprog
+!!
+!!
+!! @author MG, TL
+!! @version 2012-01-09
+!!
+MODULE planetary_data
+
+ USE parameters
+ USE linal
+ IMPLICIT NONE
+ PRIVATE
+ CHARACTER(len=256), PARAMETER :: EPH_FNAME = 'de405.dat'
+ INTEGER, PARAMETER :: RECORD_LENGTH = 4
+ INTEGER, PARAMETER :: RECORD_SIZE_405 = 2036
+ INTEGER, PARAMETER :: RECORD_SIZE_406 = 1456
+ INTEGER, PARAMETER :: NCOEFF_405 = 1018
+ INTEGER, PARAMETER :: NCOEFF_406 = 728
+ INTEGER, PARAMETER :: NRECORD_MAX = 35000 ! Fits all of de405 and de406
+ REAL(rprec8), PARAMETER :: ggc = 0.01720209895_rprec8
+ REAL(rprec8), PARAMETER :: kgm3_smau3 = (1.4959787066e8_rprec8)**3/1.989100e30
+
+
+ CHARACTER(len=23), DIMENSION(13), PARAMETER, PUBLIC :: planetary_locations = (/ &
+ "Mercury ", &
+ "Venus ", &
+ "Earth ", &
+ "Mars ", &
+ "Jupiter ", &
+ "Saturn ", &
+ "Uranus ", &
+ "Neptune ", &
+ "Pluto ", &
+ "Moon ", &
+ "Sun ", &
+ "solar-system_barycenter", &
+ "Earth-Moon_barycenter " /)
+
+ ! Unit: AU
+ REAL(rprec8), DIMENSION(17), PARAMETER, PUBLIC :: planetary_radii = (/ &
+ 1.63037e-5_rprec8, & !! (1) Mercury,
+ 4.04551e-5_rprec8, & !! (2) Venus,
+ 4.25641e-5_rprec8, & !! (3) Earth,
+ 2.26491e-5_rprec8, & !! (4) Mars,
+ 4.62908e-4_rprec8, & !! (5) Jupiter,
+ 3.81021e-4_rprec8, & !! (6) Saturn,
+ 1.72128e-4_rprec8, & !! (7) Uranus,
+ 1.60096e-4_rprec8, & !! (8) Neptune,
+ 8.17191e-6_rprec8, & !! (9) Pluto,
+ 1.16178e-5_rprec8, & !! (10) Moon,
+ 4.65424e-3_rprec8, & !! (11) Sun,
+ 0.e0_rprec8, & !! (12) solar system barycenter,
+ 0.e0_rprec8, & !! (13) Earth-Moon barycenter,
+ 0.e0_rprec8, & !! (14) Asteroid,
+ 3.05151e-6_rprec8, & !! (15) Ceres,
+ 1.74802e-6_rprec8, & !! (16) Pallas,
+ 1.67449e-6_rprec8 /) !! (17) Vesta
+
+ ! Data from http://ssd.jpl.nasa.gov/
+ ! Unit: M_sol
+ REAL(rprec8), DIMENSION(17), PARAMETER, PUBLIC :: planetary_masses = (/ &
+ 1.0_rprec8/6023600.0_rprec8, & !! (1) Mercury,
+ 1.0_rprec8/408523.71_rprec8, & !! (2) Venus,
+ 1.0_rprec8/(328900.56_rprec8*(1.0_rprec8+0.012300033739_rprec8)), & !! (3) Earth,
+ 1.0_rprec8/3098708.0_rprec8, & !! (4) Mars,
+ 1.0_rprec8/1047.3486_rprec8, & !! (5) Jupiter,
+ 1.0_rprec8/3497.898_rprec8, & !! (6) Saturn,
+ 1.0_rprec8/22902.98_rprec8, & !! (7) Uranus,
+ 1.0_rprec8/19412.24_rprec8, & !! (8) Neptune,
+ 1.0_rprec8/1.35e8_rprec8, & !! (9) Pluto,
+ 1.0_rprec8/(328900.56_rprec8*(1.0_rprec8+81.30059_rprec8)), & !! (10) Moon,
+ 1.0_rprec8, & !! (11) Sun,
+ 0.0_rprec8, & !! (12) solar system barycenter,
+ 1.0_rprec8/328900.56_rprec8, & !! (13) Earth-Moon barycenter,
+ 0.0_rprec8, & !! (14) Asteroid,
+ 1.0_rprec8/2099880378.8_rprec8, & !! (15) Ceres, GM=63.2
+ 1.0_rprec8/9280590205.59_rprec8, & !! (16) Pallas, GM=14.3
+ 1.0_rprec8/7455755052.81_rprec8 /) !! (17) Vesta GM=17.8
+
+ ! Data from http://nssdc.gsfc.nasa.gov/planetary/planetfact.html
+ ! Unit: M_sol AU^(-3)
+ REAL(rprec8), DIMENSION(17), PARAMETER, PUBLIC :: planetary_densities = (/ &
+ 5427.0_rprec8*kgm3_smau3, & !! (1) Mercury,
+ 5243.0_rprec8*kgm3_smau3, & !! (2) Venus,
+ 5515.0_rprec8*kgm3_smau3, & !! (3) Earth,
+ 3933.0_rprec8*kgm3_smau3, & !! (4) Mars,
+ 1326.0_rprec8*kgm3_smau3, & !! (5) Jupiter,
+ 687.0_rprec8*kgm3_smau3, & !! (6) Saturn,
+ 1270.0_rprec8*kgm3_smau3, & !! (7) Uranus,
+ 1632.0_rprec8*kgm3_smau3, & !! (8) Neptune,
+ 1750.0_rprec8*kgm3_smau3, & !! (9) Pluto,
+ 3340.0_rprec8*kgm3_smau3, & !! (10) Moon,
+ 1408.0_rprec8*kgm3_smau3, & !! (11) Sun,
+ -1.0_rprec8, & !! (12) solar system barycenter,
+ -1.0_rprec8, & !! (13) Earth-Moon barycenter,
+ 2500.0_rprec8*kgm3_smau3, & !! (14) Asteroid,
+ 0.0_rprec8, & !! (15) Ceres,
+ 0.0_rprec8, & !! (16) Pallas,
+ 0.0_rprec8 /) !! (17) Vesta
+
+ ! Constants of gravitation (G*M)
+ ! Unit: AU^3 day^(-2)
+ REAL(rprec8), DIMENSION(14), PARAMETER, PUBLIC :: planetary_mu = (/ &
+ ggc**2*planetary_masses(1), & !! (1) Mercury,
+ ggc**2*planetary_masses(2), & !! (2) Venus,
+ !8.887692691e-10_rprec8, & !! (3) Earth, in SI: 398600.4415e9_bp (IAU'94)
+ ggc**2*planetary_masses(3), & !! (3) Earth,
+ ggc**2*planetary_masses(4), & !! (4) Mars,
+ ggc**2*planetary_masses(5), & !! (5) Jupiter,
+ ggc**2*planetary_masses(6), & !! (6) Saturn,
+ ggc**2*planetary_masses(7), & !! (7) Uranus,
+ ggc**2*planetary_masses(8), & !! (8) Neptune,
+ ggc**2*planetary_masses(9), & !! (9) Pluto,
+ ggc**2*planetary_masses(10), & !! (10) Moon,
+ ggc**2*planetary_masses(11), & !! (11) Sun; ggc**2 * 1
+ ggc**2*planetary_masses(12), & !! (12) solar system barycenter,
+ ggc**2*planetary_masses(13), & !! (13) Earth-Moon barycenter,
+ 0.0_rprec8 /) !! (14) Asteroid
+
+ CHARACTER(len=6), DIMENSION(14,3) :: ttl
+ CHARACTER(len=6), DIMENSION(400) :: cnam
+ REAL(rprec8), DIMENSION(:,:), ALLOCATABLE :: buf
+ REAL(rprec8), DIMENSION(400) :: cval
+ REAL(rprec8), DIMENSION(3) :: ss
+ REAL(rprec8) :: au, emrat
+ INTEGER, DIMENSION(3,13) :: ipt
+ INTEGER :: numde, ncon, rec_size, eph_size
+ LOGICAL :: first = .TRUE.
+ LOGICAL :: kilometres = .FALSE.
+ LOGICAL :: barycenter = .TRUE.
+
+ PUBLIC :: JPL_ephemeris_init
+ PUBLIC :: JPL_ephemeris
+ PUBLIC :: JPL_ephemeris_nullify
+ PUBLIC :: Hill_radius
+
+ INTERFACE JPL_ephemeris
+ MODULE PROCEDURE JPL_ephemeris_r8
+ MODULE PROCEDURE JPL_ephemeris_perturbers_r8
+ MODULE PROCEDURE JPL_ephemeris_r16
+ MODULE PROCEDURE JPL_ephemeris_perturbers_r16
+ END INTERFACE JPL_ephemeris
+
+CONTAINS
+
+
+
+
+
+ !! *Description*:
+ !!
+ !! Returns the radius of the Hill sphere
+ !!
+ !! r_H ~ a_1(1-e_1) * (mass_1/3mass_2)^(1/3))
+ !!
+ !! where M_1 and M_2 are the masses of the object whose Hill-sphere
+ !! radius is sought (e.g., the Earth) and the object around which
+ !! the previous revolves (e.g., the Sun), respectively. The
+ !! semimajor axis a_1 and eccentricity e_1 refer to the previous
+ !! object. The default values for a_1 (= 1.0 AU) and e_1 (= 0) will
+ !! be used if they are not explicitly given.
+ !!
+ REAL(rprec8) FUNCTION Hill_radius(mass_1, mass_2, a_1, e_1)
+
+ IMPLICIT NONE
+ REAL(rprec8), INTENT(in) :: mass_1, mass_2
+ REAL(rprec8), OPTIONAL, INTENT(in) :: a_1, e_1
+
+ REAL(rprec8) :: a_, e_
+
+ IF (PRESENT(a_1)) THEN
+ a_ = a_1
+ ELSE
+ a_ = 1.0_rprec8
+ END IF
+ IF (PRESENT(e_1)) THEN
+ e_ = e_1
+ ELSE
+ e_ = 0.0_rprec8
+ END IF
+
+ Hill_radius = a_*(1.0_rprec8-e_) * (mass_1/(3*mass_2))**(1.0_rprec8/3)
+
+ END FUNCTION Hill_radius
+
+
+
+
+
+ !! *Description*:
+ !!
+ !! If used for the first time during execution, this routine reads
+ !! the JPL Planetary Ephemerides from a given file (known as
+ !! de405.dat at JPL) and stores the data in an array.
+ !!
+ !! Returns error.
+ !!
+ SUBROUTINE JPL_ephemeris_init(error, filename)
+
+ IMPLICIT NONE
+ LOGICAL, INTENT(inout) :: error
+ CHARACTER(len=*), OPTIONAL, INTENT(in) :: filename
+ INTEGER, PARAMETER :: min_lu = 10
+ INTEGER, PARAMETER :: max_lu = 99
+ CHARACTER(len=256) :: fname, OORB_DATA_DIR
+ REAL(rprec8), DIMENSION(:,:), ALLOCATABLE :: tmp
+ INTEGER :: err, i, lu, count
+ LOGICAL :: done, used
+
+ ! Make sure this is the first call to this routine
+ IF (.NOT.first) THEN
+ RETURN
+ END IF
+
+ IF (PRESENT(filename) .AND. LEN_TRIM(filename) <= 256) THEN
+ fname = TRIM(filename)
+ ELSE
+ ! only use with gfortran
+ !CALL get_environment_variable("OORB_DATA", OORB_DATA_DIR)
+ ! only use with g95
+ CALL getenv("OORB_DATA", OORB_DATA_DIR)
+ IF (LEN_TRIM(OORB_DATA_DIR) == 0) THEN
+ OORB_DATA_DIR = "."
+ END IF
+ fname = TRIM(OORB_DATA_DIR) // "/" // TRIM(EPH_FNAME)
+ END IF
+
+ ! Find a free logical unit:
+ done = .FALSE.
+ count = min_lu
+ lu = min_lu
+ DO WHILE (.NOT. done)
+ ! Figure out whether this unit is taken or not:
+ INQUIRE(unit=lu, opened=used, iostat=err)
+ IF (err /= 0) THEN
+ error = .TRUE.
+ WRITE(0,*) "JPL_ephemeris_init(): Error when inquiring for status of logical unit."
+ RETURN
+ END IF
+ IF (used) THEN
+ count = count + 1
+ ! If more than max_lu units have been tried,
+ ! every available unit has been tried at least once.
+ ! A free unit could not be found:
+ IF (count > max_lu) THEN
+ error = .TRUE.
+ WRITE(0,*) "JPL_ephemeris_init(): Could not find a free logical unit."
+ RETURN
+ END IF
+ lu = lu + 1
+ ! Back to beginning if top is reached:
+ IF (lu > max_lu) lu = min_lu
+ ELSE
+ done = .TRUE.
+ END IF
+ END DO
+
+ ! Read deXXX.dat (or whatever you call the JPL Planetary Ephemeris file):
+ !WRITE(0,"(A,1X,A)") "Using ephemeris file ", TRIM(fname)
+ IF (INDEX(fname,"405") /= 0) THEN
+ OPEN(unit=lu, file=TRIM(fname), status='OLD', access='DIRECT', &
+ recl=RECORD_LENGTH*RECORD_SIZE_405, action='READ', iostat=err)
+ ELSE IF (INDEX(fname,"406") /= 0) THEN
+ OPEN(unit=lu, file=TRIM(fname), status='OLD', access='DIRECT', &
+ recl=RECORD_LENGTH*RECORD_SIZE_406, action='READ', iostat=err)
+ END IF
+ IF (err /= 0) THEN
+ error = .TRUE.
+ WRITE(0,*) "JPL_ephemeris_init(): Could not open file '" // TRIM(fname) // "'."
+ RETURN
+ END IF
+
+ READ(lu, rec=1, iostat=err) ttl, cnam, ss, ncon, &
+ au, emrat, ipt(1:3,1:12), numde, ipt(1:3,13)
+ IF (err /= 0) THEN
+ error = .TRUE.
+ WRITE(0,*) "JPL_ephemeris_init(): Could not read record #1."
+ RETURN
+ END IF
+
+ READ(lu, rec=2, iostat=err) cval
+ IF (err /= 0) THEN
+ error = .TRUE.
+ WRITE(0,*) "JPL_ephemeris_init(): Could not read record #2."
+ RETURN
+ END IF
+
+ IF (INDEX(fname,"405") /= 0) THEN
+ ALLOCATE(tmp(NCOEFF_405,NRECORD_MAX), stat=err)
+ ELSE IF (INDEX(fname,"406") /= 0) THEN
+ ALLOCATE(tmp(NCOEFF_406,NRECORD_MAX), stat=err)
+ END IF
+ IF (err /= 0) THEN
+ error = .TRUE.
+ WRITE(0,*) "JPL_ephemeris_init(): Could not allocate memory (5)."
+ DEALLOCATE(tmp, stat=err)
+ RETURN
+ END IF
+ i = 1
+ DO
+ READ(lu, rec=i+2, iostat=err) tmp(:,i)
+ IF (err /= 0) THEN
+ i = i - 1
+ EXIT
+ ELSE
+ i = i + 1
+ IF (i+2 > NRECORD_MAX) THEN
+ error = .TRUE.
+ WRITE(0,*) "JPL_ephemeris_init(): NRECORD_MAX too small."
+ DEALLOCATE(tmp, stat=err)
+ RETURN
+ END IF
+ END IF
+ END DO
+ ALLOCATE(buf(SIZE(tmp,dim=1),i), stat=err)
+ IF (err /= 0) THEN
+ error = .TRUE.
+ WRITE(0,*) "JPL_ephemeris_init(): Could not allocate memory (10)."
+ DEALLOCATE(tmp, stat=err)
+ RETURN
+ END IF
+ buf(1:SIZE(tmp,dim=1),1:i) = tmp(1:SIZE(tmp,dim=1),1:i)
+ DEALLOCATE(tmp, stat=err)
+ IF (err /= 0) THEN
+ error = .TRUE.
+ WRITE(0,*) "JPL_ephemeris_init(): Could not deallocate memory."
+ RETURN
+ END IF
+ CLOSE(lu)
+ first = .FALSE.
+
+ END SUBROUTINE JPL_ephemeris_init
+
+
+
+
+
+ !! *Description*:
+ !!
+ !! Deallocates memory used by the planetary ephemerides. Should be
+ !! used at the very end of an executable.
+ !!
+ !! Returns error.
+ !!
+ SUBROUTINE JPL_ephemeris_nullify()
+
+ IMPLICIT NONE
+ INTEGER :: err
+
+ DEALLOCATE(buf, stat=err)
+
+ END SUBROUTINE JPL_ephemeris_nullify
+
+
+
+
+
+ !! *Description*:
+ !!
+ !! Reads the JPL Planetary Ephemeris and gives the position and
+ !! velocity of the point 'ntarget' with respect to 'ncenter'.
+ !!
+ !! ntarget = integer number of target point.
+ !!
+ !! ncentet = integer number of center point.
+ !!
+ !! The numbering convention for 'ntarget' and 'ncenter' is:
+ !!
+ !!
+ !! 1 = Mercury 8 = Neptune
+ !! 2 = Venus 9 = Pluto
+ !! 3 = Earth 10 = Moon
+ !! 4 = Mars 11 = Sun
+ !! 5 = Jupiter (12 = solar-system barycenter)
+ !! 6 = Saturn (13 = earth-moon barycenter)
+ !! 7 = Uranus (14 = nutations (longitude and obliq))
+ !! (15 = librations, if on eph file)
+ !!
+ !! Additional: -10 = 9 planets + Moon
+ !!
+ !! If nutations are wanted, set ntarget = 14, and for librations,
+ !! set ntarget = 15. Set ncenter = 0.
+ !!
+ !! Output is a 6-vector containing position and velocity of point
+ !! 'ntarget' relative to 'ncenter' in an equatorial reference
+ !! frame. The units are AU and AU/day. For librations the units are
+ !! radians and radians per day.
+ !!
+ !! Returns error.
+ !!
+ !! ntarget=-10 and ncenter=11 tested to produce correct results.
+ !! ntarget=-10 and ncenter=12 tested to produce correct results.
+ !!
+ ! In the case
+ ! of nutations the first four words of rrd will be set to nutations and
+ ! rates, having units of radians and radians/day.
+ !!
+ !! Known errors:
+ !!
+ !! ntarget ncenter
+ !! 13 11 (note that 11 13 works?!?)
+ !! -9 11
+ !! -9 12
+ !!
+ FUNCTION JPL_ephemeris_r8(mjd_tt, ntarget, ncenter, error, km)
+
+ IMPLICIT NONE
+ REAL(rprec8), INTENT(in) :: mjd_tt
+ INTEGER, INTENT(in) :: ntarget, ncenter
+ LOGICAL, INTENT(inout) :: error
+ LOGICAL, OPTIONAL, INTENT(in) :: km
+ REAL(rprec8), DIMENSION(:,:), POINTER :: JPL_ephemeris_r8
+
+ REAL(rprec8), DIMENSION(13,6) :: celements
+ REAL(rprec8), DIMENSION(6) :: celements_
+ REAL(rprec8), DIMENSION(2) :: tt2
+ INTEGER, DIMENSION(12) :: list
+ INTEGER :: i, k, err
+ LOGICAL :: tmp_barycenter
+
+ celements = 0.0_rprec8
+
+ IF (first) THEN
+ CALL JPL_ephemeris_init(error)
+ IF (error) THEN
+ WRITE(0,*) "JPL_ephemeris_r8(): Error when calling JPL_ephemeris_init()."
+ RETURN
+ END IF
+ END IF
+
+ IF (ntarget == ncenter) THEN
+ ALLOCATE(JPL_ephemeris_r8(1,6), stat=err)
+ IF (err /= 0) THEN
+ error = .TRUE.
+ WRITE(0,*) "JPL_ephemeris_r8(): Could not allocate memory for output (1)."
+ RETURN
+ END IF
+ JPL_ephemeris_r8(1,1:6) = 0.0_rprec8
+ RETURN
+ END IF
+
+ IF (PRESENT(km)) THEN
+ kilometres = km
+ END IF
+
+ tt2(1) = mjd_tt + 2400000.5_rprec8 ! convert to Julian date
+ tt2 = split(tt2(1))
+ IF (tt2(2) < 0.5_rprec8) THEN
+ tt2(1) = tt2(1) - 0.5_rprec8
+ tt2(2) = tt2(2) + 0.5_rprec8
+ ELSE
+ tt2(1) = tt2(1) + 0.5_rprec8
+ tt2(2) = tt2(2) - 0.5_rprec8
+ END IF
+ list = 0
+
+ ! check for librations
+ IF (ntarget == 15) THEN
+ IF (ipt(2,13) > 0) THEN
+ list(12) = 2
+ celements(1:12,1:6) = states(tt2, list, error)
+ IF (error) THEN
+ WRITE(0,*) 'JPL_ephemeris_r8(): Target object and center object are the same.'
+ RETURN
+ ELSE
+ !state = celements(11,:)
+ RETURN
+ END IF
+ ELSE
+ error = .TRUE.
+ WRITE(0,*) 'JPL_ephemeris_r8(): No librations available on the ephemeris file.'
+ RETURN
+ END IF
+ END IF
+
+ ! Force barycentric output from states()
+ tmp_barycenter = barycenter
+ barycenter = .TRUE.
+
+ ! set up proper entries in 'list' array for state call
+ IF (ntarget > 0) THEN
+ DO i=1, 2
+ IF (i == 1) THEN
+ k = ntarget
+ ELSE IF (i == 2) THEN
+ k = ncenter
+ END IF
+ IF (k <= 10) THEN
+ list(k) = 2 ! If k:th planet wanted, k:th is needed
+ END IF
+ IF (k == 3) THEN
+ list(10) = 2 ! If Earth wanted, Moon is needed
+ END IF
+ IF (k == 10) THEN
+ list(3) = 2 ! If Moon wanted, Earth is needed
+ END IF
+ IF (k == 13) THEN
+ list(3) = 2 ! If barycentric Earth-Moon wanted, Earth is needed
+ END IF
+ END DO
+ ELSE IF (ntarget == -9 .OR. ntarget == -10) THEN
+ list(1:10) = 2
+ END IF
+
+ ! make call to state
+ celements(1:12,1:6) = states(tt2, list, error)
+ IF (error) THEN
+ WRITE(0,*) 'JPL_ephemeris_r8(): Error when calling states() (1).'
+ RETURN
+ END IF
+
+ ! If the target or the center is the Sun,
+ ! change it to the Solar System barycenter:
+ IF (ntarget == 11 .OR. ncenter == 11 .OR. ntarget < 0) THEN
+ celements(11,:) = celements(12,1:6)
+ END IF
+
+ ! If the target or the center is the Solar System barycenter,
+ ! set its coordinates to zero:
+ IF (ntarget == 12 .OR. ncenter == 12) THEN
+ celements(12,:) = 0.0_rprec8
+ END IF
+
+ ! If the target or the center is the Earth-Moon barycenter,
+ ! set it initially equal to the coordinates of the Earth:
+ IF (ntarget == 13 .OR. ncenter == 13 .OR. ntarget == -9) THEN
+ celements(13,:) = celements(3,:)
+ END IF
+
+ ! If Earth to Moon (or vice versa) coordinates are needed, use
+ ! geocentric coordinates for the Moon:
+ IF (ntarget * ncenter == 30 .AND. ntarget + ncenter == 13) THEN
+ celements(3,:) = 0.0_rprec8
+ celements(ntarget,:) = celements(ntarget,:) - celements(ncenter,:)
+ ALLOCATE(JPL_ephemeris_r8(1,6), stat=err)
+ IF (err /= 0) THEN
+ error = .TRUE.
+ WRITE(0,*) "JPL_ephemeris_r8(): Could not allocate memory for output (2)."
+ RETURN
+ END IF
+ JPL_ephemeris_r8(1,1:6) = celements(ntarget,1:6)
+ barycenter = tmp_barycenter
+ RETURN
+ END IF
+
+ ! If the target or the center is the Moon or the Earth-Moon barycenter,
+ ! compute Earth coordinates using coordinates for the barycentric Earth-Moon
+ ! system and geocentric coordinates for the Moon:
+ IF (list(3) == 2) THEN
+ celements(3,:) = celements(3,:) - celements(10,:)/(1.0_rprec8 + emrat)
+ END IF
+
+ ! If the target or the center is the Moon, compute Moon's
+ ! coordinates using coordinates for the Earth and geocentric
+ ! coordinates for the Moon:
+ IF (list(10) == 2) THEN
+ celements(10,:) = celements(3,:) + celements(10,:)
+ END IF
+
+ celements_ = celements(ncenter,1:6)
+ barycenter = tmp_barycenter
+ DO i=1,12
+ celements(i,1:6) = celements(i,1:6) - celements_
+ END DO
+ IF (ntarget == -9) THEN ! use Earth-Moon barycenter
+ ALLOCATE(JPL_ephemeris_r8(9,6), stat=err)
+ IF (err /= 0) THEN
+ error = .TRUE.
+ WRITE(0,*) "JPL_ephemeris_r8(): Could not allocate memory for output (3)."
+ RETURN
+ END IF
+ DO i=1,9
+ JPL_ephemeris_r8(i,1:6) = celements(i,1:6)
+ END DO
+ !JPL_ephemeris_r8(3,1:6) = celements(13,1:6)
+ ELSE IF (ntarget == -10) THEN ! separate Earth and Moon
+ ALLOCATE(JPL_ephemeris_r8(10,6), stat=err)
+ IF (err /= 0) THEN
+ error = .TRUE.
+ WRITE(0,*) "JPL_ephemeris_r8(): Could not allocate memory for output (4)."
+ RETURN
+ END IF
+ DO i=1,10
+ JPL_ephemeris_r8(i,1:6) = celements(i,1:6)
+ END DO
+ ELSE IF (ntarget >= 1 .AND. ntarget <= 13) THEN
+ ALLOCATE(JPL_ephemeris_r8(1,6), stat=err)
+ IF (err /= 0) THEN
+ error = .TRUE.
+ WRITE(0,*) "JPL_ephemeris_r8(): Could not allocate memory for output (5)."
+ RETURN
+ END IF
+ JPL_ephemeris_r8(1,1:6) = celements(ntarget,1:6)
+ ELSE
+ error = .TRUE.
+ WRITE(0,*) "JPL_ephemeris_r8(): Could not decide what kind of output caller requested."
+ RETURN
+ END IF
+
+ END FUNCTION JPL_ephemeris_r8
+
+
+
+
+
+ !! *Description*:
+ !!
+ !! Same as JPL_ephemeris_r8, but with digits allowing greater
+ !! numerical accuracy, i.e., the accuracy of values is the same
+ !! as for JPL_ephemeris_r8.
+ !!
+ FUNCTION JPL_ephemeris_r16(mjd_tt, ntarget, ncenter, error, km)
+
+ IMPLICIT NONE
+ REAL(rprec16), INTENT(in) :: mjd_tt
+ INTEGER, INTENT(in) :: ntarget, ncenter
+ LOGICAL, INTENT(inout) :: error
+ LOGICAL, OPTIONAL, INTENT(in) :: km
+ REAL(rprec16), DIMENSION(:,:), POINTER :: JPL_ephemeris_r16
+ REAL(rprec8), DIMENSION(:,:), POINTER :: tmp
+ INTEGER :: err
+
+ IF (PRESENT(km)) THEN
+ tmp => JPL_ephemeris(REAL(mjd_tt,rprec8), ntarget, ncenter, error, km)
+ ELSE
+ tmp => JPL_ephemeris(REAL(mjd_tt,rprec8), ntarget, ncenter, error)
+ END IF
+ IF (error) THEN
+ WRITE(0,*) "JPL_ephemeris_r16(): Error when calling JPL_ephemeris_r8()."
+ RETURN
+ END IF
+ ALLOCATE(JPL_ephemeris_r16(SIZE(tmp,dim=1),SIZE(tmp,dim=2)), stat=err)
+ IF (err /= 0) THEN
+ error = .TRUE.
+ WRITE(0,*) "JPL_ephemeris_r16(): Could not allocate memory."
+ DEALLOCATE(tmp, stat=err)
+ RETURN
+ END IF
+ JPL_ephemeris_r16 = REAL(tmp,rprec16)
+ DEALLOCATE(tmp, stat=err)
+ IF (err /= 0) THEN
+ error = .TRUE.
+ WRITE(0,*) "JPL_ephemeris_r16(): Could not deallocate memory."
+ RETURN
+ END IF
+
+ END FUNCTION JPL_ephemeris_r16
+
+
+
+
+
+ !! *Description*:
+ !!
+ !! Reads the JPL Planetary Ephemeris and gives the position and
+ !! velocity of the point 'ntarget' with respect to 'ncenter'.
+ !!
+ !! ntarget = integer number of target point.
+ !!
+ !! ncentet = integer number of center point.
+ !!
+ !! The numbering convention for 'ntarget' and 'ncenter' is:
+ !!
+ !!
+ !! 1 = Mercury 8 = Neptune
+ !! 2 = Venus 9 = Pluto
+ !! 3 = Earth 10 = Moon
+ !! 4 = Mars 11 = Sun
+ !! 5 = Jupiter (12 = solar-system barycenter)
+ !! 6 = Saturn (13 = earth-moon barycenter)
+ !! 7 = Uranus (14 = nutations (longitude and obliq))
+ !! (15 = librations, if on eph file)
+ !!
+ !! Additional: -10 = 9 planets + Moon
+ !!
+ !! If nutations are wanted, set ntarget = 14, and for librations,
+ !! set ntarget = 15. Set ncenter = 0.
+ !!
+ !! Output is a CartesianCoordinates object (crtcrd) containing position and velocity
+ !! of point 'ntarget' relative to 'ncenter'. the units are AU and AU/day.
+ !! For librations the units are radians and radians per day.
+ !!
+ !! Returns error.
+ !!
+ !! ntarget=-10 and ncenter=11 tested to produce correct results.
+ !! ntarget=-10 and ncenter=12 tested to produce correct results.
+ !!
+ ! In the case
+ ! of nutations the first four words of rrd will be set to nutations and
+ ! rates, having units of radians and radians/day.
+ !!
+ !! Known errors:
+ !!
+ !! ntarget ncenter
+ !! 13 11
+ !! -9 11
+ !! -9 12
+ !!
+ FUNCTION JPL_ephemeris_perturbers_r8(mjd_tt, ntargets, ncenter, error, km)
+
+ IMPLICIT NONE
+ REAL(rprec8), INTENT(in) :: mjd_tt
+ LOGICAL, DIMENSION(:), INTENT(in) :: ntargets
+ INTEGER, INTENT(in) :: ncenter
+ LOGICAL, INTENT(inout) :: error
+ LOGICAL, OPTIONAL, INTENT(in) :: km
+ REAL(rprec8), DIMENSION(:,:), POINTER :: JPL_ephemeris_perturbers_r8
+
+ REAL(rprec8), DIMENSION(13,6) :: celements
+ REAL(rprec8), DIMENSION(6) :: celements_
+ REAL(rprec8), DIMENSION(2) :: tt2
+ INTEGER, DIMENSION(12) :: list
+ INTEGER :: i, j, err
+ LOGICAL :: tmp_barycenter
+
+ IF (first) THEN
+ CALL JPL_ephemeris_init(error)
+ IF (error) THEN
+ WRITE(0,*) "JPL_ephemeris_perturbers_r8(): Could not initialize ephemerides."
+ RETURN
+ END IF
+ END IF
+
+ IF (PRESENT(km)) THEN
+ kilometres = km
+ END IF
+
+ tt2(1) = mjd_tt + 2400000.5_rprec8 ! convert to Julian date
+ tt2 = split(tt2(1))
+ IF (tt2(2) < 0.5_rprec8) THEN
+ tt2(1) = tt2(1) - 0.5_rprec8
+ tt2(2) = tt2(2) + 0.5_rprec8
+ ELSE
+ tt2(1) = tt2(1) + 0.5_rprec8
+ tt2(2) = tt2(2) - 0.5_rprec8
+ END IF
+ list = 0
+
+ ! Force barycentric output from states()
+ tmp_barycenter = barycenter
+ barycenter = .TRUE.
+
+ ! set up proper entries in 'list' array for state call
+ list(1:10) = 2
+
+ ! make call to state
+ celements(1:12,1:6) = states(tt2, list, error)
+ IF (error) THEN
+ WRITE(0,*) "JPL_ephemeris_perturbers_r8(): Error when calling states() (1)."
+ RETURN
+ END IF
+
+ ! If the target or the center is the Sun,
+ ! change it to the Solar System barycenter:
+ celements(11,:) = celements(12,1:6)
+
+ ! If the target or the center is the Earth-Moon barycenter,
+ ! set it initially equal to the coordinates of the Earth:
+ IF (ntargets(3) .AND. .NOT.ntargets(10)) THEN
+ celements(13,:) = celements(3,:)
+ END IF
+
+ ! If the target or the center is the Moon or the Earth-Moon barycenter,
+ ! compute Earth coordinates using coordinates for the barycentric Earth-Moon
+ ! system and geocentric coordinates for the Moon:
+ celements(3,:) = celements(3,:) - celements(10,:)/(1.0_rprec8 + emrat)
+
+ ! If the target or the center is the Moon, compute Moon's
+ ! coordinates using coordinates for the Earth and geocentric
+ ! coordinates for the Moon:
+ celements(10,:) = celements(3,:) + celements(10,:)
+
+ celements_ = celements(ncenter,1:6)
+ barycenter = tmp_barycenter
+ DO i=1,12
+ celements(i,1:6) = celements(i,1:6) - celements_
+ END DO
+ ALLOCATE(JPL_ephemeris_perturbers_r8(COUNT(ntargets),6), stat=err)
+ IF (err /= 0) THEN
+ error = .TRUE.
+ WRITE(0,*) "JPL_ephemeris_perturbers_r8(): Could not allocate memory."
+ RETURN
+ END IF
+ j = 0
+ DO i=1,10
+ IF (ntargets(i)) THEN
+ j = j + 1
+ JPL_ephemeris_perturbers_r8(j,1:6) = celements(i,1:6)
+ END IF
+ END DO
+
+ END FUNCTION JPL_ephemeris_perturbers_r8
+
+
+
+
+
+ !! *Description*:
+ !!
+ !! Same as JPL_ephemeris_r8, but with digits allowing greater
+ !! numerical accuracy, i.e., the accuracy of values is the same
+ !! as for JPL_ephemeris_r8.
+ !!
+ FUNCTION JPL_ephemeris_perturbers_r16(mjd_tt, ntargets, ncenter, error, km)
+
+ IMPLICIT NONE
+ REAL(rprec16), INTENT(in) :: mjd_tt
+ LOGICAL, DIMENSION(:), INTENT(in) :: ntargets
+ INTEGER, INTENT(in) :: ncenter
+ LOGICAL, INTENT(inout) :: error
+ LOGICAL, OPTIONAL, INTENT(in) :: km
+ REAL(rprec16), DIMENSION(:,:), POINTER :: JPL_ephemeris_perturbers_r16
+ REAL(rprec8), DIMENSION(:,:), POINTER :: tmp
+ INTEGER :: err
+
+ IF (PRESENT(km)) THEN
+ tmp => JPL_ephemeris(REAL(mjd_tt,rprec8), ntargets, ncenter, error, km)
+ ELSE
+ tmp => JPL_ephemeris(REAL(mjd_tt,rprec8), ntargets, ncenter, error)
+ END IF
+ IF (error) THEN
+ WRITE(0,*) "JPL_ephemeris_perturbers_r16(): Error when calling JPL_ephemeris_perturbers_r8()."
+ RETURN
+ END IF
+ ALLOCATE(JPL_ephemeris_perturbers_r16(SIZE(tmp,dim=1),SIZE(tmp,dim=2)), stat=err)
+ IF (err /= 0) THEN
+ error = .TRUE.
+ WRITE(0,*) "JPL_ephemeris_perturbers_r16(): Could not allocate memory."
+ DEALLOCATE(tmp, stat=err)
+ RETURN
+ END IF
+ JPL_ephemeris_perturbers_r16 = REAL(tmp,rprec16)
+ DEALLOCATE(tmp, stat=err)
+ IF (err /= 0) THEN
+ error = .TRUE.
+ WRITE(0,*) "JPL_ephemeris_perturbers_r16(): Could not deallocate memory."
+ RETURN
+ END IF
+
+ END FUNCTION JPL_ephemeris_perturbers_r16
+
+
+
+
+
+ !! *Description*:
+ !!
+ !! Reads the jpl planetary ephemeris and gives the position and
+ !! velocity of the point 'ntarget' with respect to 'ncenter'.
+ !!
+ !! ntarget = integer number of target point.
+ !!
+ !! ncentet = integer number of center point.
+ !!
+ !! The numbering convention for 'ntarget' and 'ncenter' is:
+ !!
+ !!
+ !! 1 = mercury 8 = neptune
+ !! 2 = venus 9 = pluto
+ !! 3 = earth 10 = moon
+ !! 4 = mars 11 = sun
+ !! 5 = jupiter (12 = solar-system barycenter)
+ !! 6 = saturn (13 = earth-moon barycenter)
+ !! 7 = uranus (14 = nutations (longitude and obliq))
+ !! (15 = librations, if on eph file)
+ !!
+ !!
+ !! If nutations are wanted, set ntarget = 14, and for librations,
+ !! set ntarget = 15. Set ncenter = 0.
+ !!
+ !! Output is a CartesianCoordinates object (crtcrd) containing position and velocity
+ !! of point 'ntarget' relative to 'ncenter'. the units are AU and AU/day.
+ !! For librations the units are radians and radians per day.
+ !!
+ !! Returns error.
+ !!
+ ! In the case
+ ! of nutations the first four words of rrd will be set to nutations and
+ ! rates, having units of radians and radians/day.
+ !!
+ FUNCTION nutations(t, error)
+
+ IMPLICIT NONE
+ REAL(rprec8), INTENT(in) :: t
+ LOGICAL, INTENT(inout) :: error
+ REAL(rprec8), DIMENSION(4) :: nutations
+ REAL(rprec8), DIMENSION(6) :: tmp
+ REAL(rprec8), DIMENSION(4) :: pjd
+ REAL(rprec8), DIMENSION(2) :: tt2, tt
+ REAL(rprec8) :: s
+ INTEGER, DIMENSION(12) :: list
+ INTEGER :: record_nr
+
+ IF (first) THEN
+ CALL JPL_ephemeris_init(error)
+ IF (error) THEN
+ WRITE(0,*) "nutations(): Could not initialize ephemerides."
+ RETURN
+ END IF
+ END IF
+
+ tt2(1) = t
+ tt2 = split(tt2(1))
+ IF (tt2(2) < 0.5_rprec8) THEN
+ tt2(1) = tt2(1) - 0.5_rprec8
+ tt2(2) = tt2(2) + 0.5_rprec8
+ ELSE
+ tt2(1) = tt2(1) + 0.5_rprec8
+ tt2(2) = tt2(2) - 0.5_rprec8
+ END IF
+ list = 0
+
+ IF (ipt(2,12) > 0) THEN
+ list(11) = 2
+
+ IF (tt2(1) == 0.0_rprec8) THEN
+ error = .TRUE.
+ WRITE(0,*) 'nutations(): Input Julian date is zero.'
+ RETURN
+ END IF
+
+ s = tt2(1) - 0.5_rprec8
+ pjd(1:2) = split(s)
+ pjd(3:4) = split(tt2(2))
+ pjd(1) = pjd(1) + pjd(3) + 0.5_rprec8
+ pjd(2) = pjd(2) + pjd(4)
+ pjd(3:4) = split(pjd(2))
+ pjd(1) = pjd(1) + pjd(3)
+
+ IF (pjd(1) + pjd(4) < ss(1) .OR. &
+ pjd(1) + pjd(4) > ss(2)) THEN
+ error = .TRUE.
+ WRITE(0,*) 'nutations(): Requested Julian ET not within limits.'
+ RETURN
+ END IF
+
+ ! Calculate record number and relative time in interval:
+ record_nr = INT((pjd(1) - ss(1))/ss(3)) + 1
+ IF (pjd(1) == ss(2)) record_nr = record_nr - 1
+ tt(1) = ((pjd(1) - (REAL(record_nr-1, rprec8) * ss(3) + ss(1))) + &
+ pjd(4)) / ss(3)
+
+ ! Read correct record if not in core:
+ !IF (record_nr < 1 .OR. record_nr > SIZE(buf,dim=1)) THEN
+ IF (record_nr < 1 .OR. record_nr > SIZE(buf,dim=2)) THEN
+ error = .TRUE.
+ WRITE(0,*) 'Requested Julian ET not within limits.'
+ RETURN
+ END IF
+
+ ! Do nutations if requested (and if on file)
+ IF (list(11) > 0 .AND. ipt(2,12) > 0) THEN
+ !CALL interpolate(buf(record_nr,:), ipt(1,12), tt, &
+ ! ipt(2,12), 2, ipt(3,12), tmp, error)
+ CALL interpolate(buf(:,record_nr), ipt(1,12), tt, &
+ ipt(2,12), 2, ipt(3,12), tmp, error)
+ IF (error) THEN
+ RETURN
+ END IF
+ nutations = tmp(1:4)
+ ELSE
+ nutations = 0.0_rprec8
+ END IF
+ IF (error) THEN
+ WRITE(0,*) 'nutations(): No nutations on the ephemeris file.'
+ RETURN
+ END IF
+ END IF
+
+ END FUNCTION nutations
+
+
+
+
+
+ !!
+ !! Returns error.
+ !!
+ FUNCTION states(tt2, list, error)
+
+ ! this subroutine reads and interpolates the jpl planetary ephemeris file
+ !
+ ! calling sequence parameters:
+ !
+ ! input:
+ !
+ ! tt2 rprec8 2-word julian ephemeris epoch at which interpolation
+ ! is wanted. any combination of tt2(1)+tt2(2) which falls
+ ! within the time span on the file is a permissible epoch.
+ !
+ ! a. for ease in programming, the user may put the
+ ! entire epoch in tt2(1) and set tt2(2)=0.
+ !
+ ! b. for maximum interpolation accuracy, set tt2(1) =
+ ! the most recent midnight at or before interpolation
+ ! epoch and set tt2(2) = fractional part of a day
+ ! elapsed between tt2(1) and epoch.
+ !
+ ! c. as an alternative, it may prove convenient to set
+ ! tt2(1) = some fixed epoch, such as start of integration,
+ ! and tt2(2) = elapsed interval between then and epoch.
+ !
+ ! list 12-word integer array specifying what interpolation
+ ! is wanted for each of the bodies on the file.
+ !
+ ! list(i)=0, no interpolation for body i
+ ! =1, position only
+ ! =2, position and velocity
+ !
+ ! the designation of the astronomical bodies by i is:
+ !
+ ! i = 1: mercury
+ ! = 2: venus
+ ! = 3: earth-moon barycenter
+ ! = 4: mars
+ ! = 5: jupiter
+ ! = 6: saturn
+ ! = 7: uranus
+ ! = 8: neptune
+ ! = 9: pluto
+ ! = 10: geocentric moon
+ ! = 11: nutations in longitude and obliquity
+ ! = 12: lunar librations (if on file)
+ !
+ !
+ ! output:
+ !
+ ! s_array rprec8 6 x 11 array that will contain requested interpolated
+ ! quantities. the body specified by list(i) will have its
+ ! state in the array starting at s_array(1,i). (on any given
+ ! call, only those words in 's_array' which are affected by the
+ ! first 10 'list' entries (and by list(12) if librations are
+ ! on the file) are set. the rest of the 's_array' array
+ ! is untouched.) the order of components starting in
+ ! s_array(1,i) is: x,y,z,dx,dy,dz.
+ !
+ ! all output vectors are referenced to the earth mean
+ ! equator and equinox of j2000 if the de number is 200 or
+ ! greater; of b1950 if the de number is less than 200.
+ !
+ ! the moon state is always geocentric; the other nine states
+ ! are either heliocentric or solar-system barycentric,
+ ! depending on the setting of common flags (see below).
+ !
+ ! lunar librations, if on file, are put into s_array(k,11) if
+ ! list(12) is 1 or 2.
+ !
+ ! nut rprec8 4-word array that will contain nutations and rates,
+ ! depending on the setting of list(11). the order of
+ ! quantities in nut is:
+ !
+ ! d psi (nutation in longitude)
+ ! d epsilon (nutation in obliquity)
+ ! d psi dot
+ ! d epsilon dot
+ !
+ ! * statement # for error return, in case of epoch out of
+ ! range or i/o errors.
+ !
+ !
+ ! common area stcomx:
+ !
+ ! kilometres logical flag defining physical units of the output
+ ! states. kilometres = .true., km and km/sec
+ ! = .false., au and au/day
+ ! default value = .false. (kilometres determines time unit
+ ! for nutations and librations. angle unit is always radians.)
+ !
+ ! bary logical flag defining output center.
+ ! only the 9 planets are affected.
+ ! bary = .true. =\ center is solar-system barycenter
+ ! = .false. =\ center is sun
+ ! default value = .false.
+ !
+ ! celements(1:6,12) rprec8 6-word array containing the barycentric position and
+ ! velocity of the sun.
+
+ IMPLICIT NONE
+ REAL(rprec8), DIMENSION(2), INTENT(in) :: tt2
+ INTEGER, DIMENSION(12), INTENT(in) :: list
+ LOGICAL, INTENT(inout) :: error
+ REAL(rprec8), DIMENSION(12,6) :: states
+ REAL(rprec8), DIMENSION(2) :: t
+ REAL(rprec8), DIMENSION(4) :: pjd
+ REAL(rprec8) :: s, aufac
+ INTEGER :: record_nr, i
+
+ states = 0.0_rprec8
+
+ IF (ABS(tt2(1)) < EPSILON(tt2(1))) THEN
+ error = .TRUE.
+ WRITE(0,*) 'states(): Input Julian date is zero.'
+ RETURN
+ END IF
+
+ s = tt2(1) - 0.5_rprec8
+ pjd(1:2) = split(s)
+ pjd(3:4) = split(tt2(2))
+ pjd(1) = pjd(1) + pjd(3) + 0.5_rprec8
+ pjd(2) = pjd(2) + pjd(4)
+ pjd(3:4) = split(pjd(2))
+ pjd(1) = pjd(1) + pjd(3)
+
+ IF (pjd(1) + pjd(4) < ss(1) .OR. &
+ pjd(1) + pjd(4) > ss(2)) THEN
+ error = .TRUE.
+ WRITE(0,*) 'states(): Requested Julian ET not within limits:'
+ WRITE(0,*) tt2, ss
+ RETURN
+ END IF
+
+ ! Calculate record number and relative time in interval:
+ record_nr = INT((pjd(1) - ss(1))/ss(3)) + 1
+ IF (pjd(1) == ss(2)) THEN
+ record_nr = record_nr - 1
+ END IF
+ t(1) = ((pjd(1) - (REAL(record_nr-1, rprec8) * ss(3) + ss(1))) + &
+ pjd(4)) / ss(3)
+
+ ! Read correct record if not in core:
+ IF (record_nr < 1 .OR. record_nr > SIZE(buf,dim=2)) THEN
+ error = .TRUE.
+ WRITE(0,*) 'states(): Requested Julian ephemeris date not within limits.'
+ RETURN
+ END IF
+
+ IF (kilometres) THEN
+ t(2) = ss(3)*86400.0_rprec8
+ aufac = 1.0_rprec8
+ ELSE
+ t(2) = ss(3)
+ aufac = 1.0_rprec8/au
+ ENDIF
+
+ ! Interpolate ssbary sun:
+ CALL interpolate(buf(:,record_nr), ipt(1,11), t, ipt(2,11), &
+ 3, ipt(3,11), states(12,1:6), error)
+ IF (error) THEN
+ WRITE(0,*) "states(): Error when calling interpolate() (1)."
+ RETURN
+ END IF
+ states(12,1:6) = states(12,1:6)*aufac
+ ! Check and interpolate whichever bodies are requested:
+ DO i=1, 10
+ IF (list(i) == 0) CYCLE
+ CALL interpolate(buf(:,record_nr), ipt(1,i), t, ipt(2,i), &
+ 3, ipt(3,i), states(i,:), error)
+ IF (error) THEN
+ WRITE(0,*) "states(): Error when calling interpolate() (2)."
+ RETURN
+ END IF
+ IF (i <= 9 .AND. .NOT.barycenter) THEN
+ states(i,:) = states(i,:) * aufac - states(12,:)
+ ELSE
+ states(i,:) = states(i,:) * aufac
+ END IF
+ END DO
+ ! Get librations if requested (and if on file)
+ IF (list(12) > 0 .AND. ipt(2,13) > 0) THEN
+ CALL interpolate(buf(:,record_nr), ipt(1,13), t, ipt(2,13), &
+ 3, ipt(3,13), states(11,:), error)
+ IF (error) THEN
+ WRITE(0,*) "states(): Error when calling interpolate() (3)."
+ RETURN
+ END IF
+ ELSE
+ states(11,1) = 0.0_rprec8
+ END IF
+
+ END FUNCTION states
+
+
+
+
+
+ !!
+ !! Returns error.
+ !!
+ SUBROUTINE interpolate(inbuf, ind, time, ncf, ncm, na, svector, error)
+
+ ! this subroutine differentiates and interpolates a
+ ! set of chebyshev coefficients to give position and velocity
+ !
+ ! calling sequence parameters:
+ !
+ ! input:
+ !
+ ! buf 1st location of array of d.p. chebyshev coefficients of position
+ !
+ ! t t(1) is rprec8 fractional time in interval covered by
+ ! coefficients at which interpolation is wanted
+ ! (0 <= t(1) <= 1). t(2) is rprec8 length of whole
+ ! interval in input time units.
+ !
+ ! ncf # of coefficients per component
+ !
+ ! ncm # of components per set of coefficients
+ !
+ ! na # of sets of coefficients in full array
+ ! (i.e., # of sub-intervals in full interval)
+ !
+ ! flag integer flag: =1 for positions only
+ ! =2 for pos and vel
+ !
+ !
+ ! output:
+ !
+ ! svector interpolated quantities requested. dimension
+ ! expected is svector(ncm,flag), rprec8.
+ !
+ IMPLICIT NONE
+ INTEGER, INTENT(in) :: ncf, ncm, na, ind
+ SAVE
+ REAL(rprec8), DIMENSION(:), INTENT(in) :: inbuf
+ REAL(rprec8), DIMENSION(2), INTENT(in) :: time
+ REAL(rprec8), DIMENSION(6), INTENT(out) :: svector
+ LOGICAL, INTENT(inout) :: error
+ REAL(rprec8), DIMENSION(ncf,ncm,na) :: buf
+ REAL(rprec8), DIMENSION(18) :: pc, vc
+ REAL(rprec8), DIMENSION(6) :: pos, vel
+ REAL(rprec8) :: twot, tmp, tc, vfac, dna
+ INTEGER :: npos, nvel, dt1, i, j, k, l
+
+ npos = 2
+ nvel = 3
+ twot = 0.0_rprec8
+ pc(1:2) = (/ 1.0_rprec8, 0.0_rprec8 /)
+ vc(2) = 1.0_rprec8
+
+ l = ind
+ buf = 0.0
+ DO k=1,na
+ DO j=1,ncm
+ DO i=1,ncf
+ buf(i,j,k) = inbuf(l)
+ l = l + 1
+ END DO
+ END DO
+ END DO
+
+ ! Get correct sub-interval number for this set of coefficients and
+ ! then get normalized Chebyshev time within that subinterval.
+ dna = REAL(na,rprec8)
+ dt1 = INT(time(1))
+ tmp = dna * time(1)
+ l = INT(tmp - dt1) + 1
+
+ ! tc is the normalized chebyshev time (-1 <= tc <= 1)
+ tc = 2.0_rprec8 * (MOD(tmp,1.0_rprec8) + dt1) - 1.0_rprec8
+
+ ! check to see whether chebyshev time has changed,
+ ! and compute new polynomial values if it has.
+ ! (the element pc(2) is the value of t1(tc) and hence
+ ! contains the value of tc on the previous call.)
+ IF(tc /= pc(2)) THEN
+ npos = 2
+ nvel = 3
+ pc(2) = tc
+ twot = tc + tc
+ END IF
+
+ ! be sure that at least 'ncf' polynomials have been evaluated
+ ! and are stored in the array 'pc'.
+ IF(npos < ncf) THEN
+ DO i=npos+1,ncf
+ pc(i) = twot * pc(i-1) - pc(i-2)
+ END DO
+ npos = ncf
+ END IF
+
+ ! interpolate to get position for each component
+ DO i=1,ncm
+ pos(i) = 0.0_rprec8
+ DO j=ncf,1,-1
+ pos(i) = pos(i) + pc(j) * buf(j,i,l)
+ END DO
+ END DO
+
+ ! if velocity interpolation is wanted, be sure enough
+ ! derivative polynomials have been generated and stored.
+ IF (ABS(time(2)) < EPSILON(time(2))) THEN
+ error = .TRUE.
+ WRITE(0,*) 'interpolate(): Attempted division by zero.'
+ RETURN
+ END IF
+ vfac = (dna + dna)/time(2)
+ vc(3) = twot + twot
+ IF (nvel < ncf) THEN
+ DO i=nvel+1, ncf
+ vc(i) = twot * vc(i-1) + pc(i-1) + pc(i-1) - vc(i-2)
+ END DO
+ nvel = ncf
+ ENDIF
+
+ ! interpolate to get velocity for each component
+ DO i=1, ncm
+ vel(i) = 0.0_rprec8
+ DO j=ncf,2,-1
+ vel(i) = vel(i) + vc(j) * buf(j,i,l)
+ END DO
+ vel(i) = vel(i) * vfac
+ END DO
+
+ svector = (/ pos(1:3), vel(1:3) /)
+
+ END SUBROUTINE interpolate
+
+
+
+
+
+ !!
+ !!
+ FUNCTION split(in)
+
+ ! this subroutine breaks a rprec8 number into a rprec8 integer
+ ! and a rprec8 fractional part.
+ !
+ ! calling sequence parameters:
+ !
+ ! in = input number
+ !
+ ! out = output array.
+ ! split(1) contains integer part
+ ! split(2) contains fractional part
+ !
+ ! for negative input numbers, split(1) contains the next
+ ! more negative integer; split(2) contains a positive fraction.
+
+ IMPLICIT NONE
+ REAL(rprec8), INTENT(in) :: in
+ REAL(rprec8), DIMENSION(2) :: split
+
+ ! main entry -- get integer and fractional parts
+ split(1) = 1.0_rprec8*AINT(in)
+ split(2) = 1.0_rprec8*in - 1.0_rprec8*split(1)
+
+ IF (in < 0.0_rprec8 .AND. split(2) /= 0.0_rprec8) THEN
+ ! make adjustments for negative input number
+ split(1) = 1.0_rprec8*split(1) - 1.0_rprec8
+ split(2) = 1.0_rprec8*split(2) + 1.0_rprec8
+ END IF
+
+ END FUNCTION split
+
+
+
+
+
+ !! *Description*:
+ !!
+ !! The Roche limit 'd' for a fluid satellite where
+ !!
+ !! d ~ 2.44 * r_planet * (rho_planet/rho_satellite)^(1/3))
+ !!
+ !! and r_planet and rho_planet are the radius and bulk density of
+ !! the planet, and rho_satellite is the bulk density of the
+ !! satellite.
+ !!
+ REAL(rprec8) FUNCTION Roche_limit(radius_1, density_1, density_2)
+
+ IMPLICIT NONE
+ REAL(rprec8), INTENT(in) :: radius_1, density_1, density_2
+
+ Roche_limit = 2.44_rprec8 * radius_1 * (density_1/density_2)**(1.0_rprec8/3)
+
+ END FUNCTION Roche_limit
+
+
+
+
+END MODULE planetary_data
Index: trunk/mops/oorb/modules/random.f90
===================================================================
--- trunk/mops/oorb/modules/random.f90 (revision 34646)
+++ trunk/mops/oorb/modules/random.f90 (revision 34646)
@@ -0,0 +1,593 @@
+!====================================================================!
+! !
+! Copyright 2002-2011,2012 !
+! Mikael Granvik, Jenni Virtanen, Karri Muinonen, Teemu Laakso, !
+! Dagmara Oszkiewicz !
+! !
+! This file is part of OpenOrb. !
+! !
+! OpenOrb 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. !
+! !
+! OpenOrb 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 OpenOrb. If not, see . !
+! !
+!====================================================================!
+!
+!! *Module*description*:
+!!
+!! Random number generators.
+!!
+!! @see SphericalCoordinates_class
+!!
+!! @author MG
+!! @version 2012-02-15
+!!
+MODULE random
+
+ USE parameters
+ IMPLICIT NONE
+ PRIVATE
+ INTEGER, PARAMETER :: IA=16807, IM=2147483647, IQ=127773, IR=2836
+ INTEGER, DIMENSION(:), ALLOCATABLE :: seed
+ INTEGER :: idum_prm = -1
+ INTEGER :: idum
+ LOGICAL :: first_ran = .TRUE.
+
+ PUBLIC :: initializeRandomNumberGenerator
+ PUBLIC :: randomNumber
+ PUBLIC :: randomGaussian
+
+ INTERFACE ran_pmm
+ MODULE PROCEDURE ran_pmm_r4
+ MODULE PROCEDURE ran_pmm_r8
+ MODULE PROCEDURE ran_pmm_r16
+ END INTERFACE ran_pmm
+
+ INTERFACE randomNumber
+ MODULE PROCEDURE randomNumber_single_r4
+ MODULE PROCEDURE randomNumber_single_r8
+ MODULE PROCEDURE randomNumber_single_r16
+ MODULE PROCEDURE randomNumber_array_r4
+ MODULE PROCEDURE randomNumber_2array_r4
+ MODULE PROCEDURE randomNumber_array_r8
+ MODULE PROCEDURE randomNumber_2array_r8
+ MODULE PROCEDURE randomNumber_array_r16
+ END INTERFACE randomNumber
+
+ INTERFACE randomGaussian
+ MODULE PROCEDURE randomGaussian_single_r4
+ MODULE PROCEDURE randomGaussian_single_r8
+ MODULE PROCEDURE randomGaussian_single_r16
+ MODULE PROCEDURE randomGaussian_array_r4
+ MODULE PROCEDURE randomGaussian_array_r8
+ MODULE PROCEDURE randomGaussian_array_r16
+ END INTERFACE randomGaussian
+
+
+CONTAINS
+
+
+
+ SUBROUTINE initializeRandomNumberGenerator(idum)
+
+ IMPLICIT NONE
+ INTEGER, INTENT(in) :: idum
+
+ idum_prm = idum
+
+ END SUBROUTINE initializeRandomNumberGenerator
+
+
+
+
+
+!!$ subroutine devroyeRandomMultinormalValues(covariance, ran)
+!!$
+!!$ implicit none
+!!$ real(prec8), dimension(:,:), intent(in)
+!!$
+!!$ ! From Devroye: "Non-Uniform Random Variate Generation", 1986,
+!!$ ! chapter 11
+!!$
+!!$ A = 0.0_bp
+!!$ DO i=1,6
+!!$ DO j=1,i
+!!$ IF (j == 1) THEN
+!!$ A(i,1) = cov(i,1)/SQRT(cov(1,1))
+!!$ ELSE IF (i == j) THEN
+!!$ IF (cov(i,i) - SUM(A(i,1:i-1)**2) < -1E-7_bp) THEN
+!!$ CALL toString(i, str1, error)
+!!$ CALL toString(cov(i,i) - SUM(A(i,1:i-1)**2), str2, error, frmt=efrmt)
+!!$ error = .TRUE.
+!!$ CALL errorMessage("StochasticOrbit / covarianceSampling", &
+!!$ "Square of element (" // TRIM(str1) // "," // TRIM(str1) // &
+!!$ ") of Devroye's matrix A is negative (" // TRIM(str2) // ").", 1)
+!!$ RETURN
+!!$ END IF
+!!$ A(i,i) = SQRT(ABS(cov(i,i) - SUM(A(i,1:i-1)**2)))
+!!$ ELSE IF (j < i) THEN
+!!$ A(i,j) = (cov(i,j) - SUM(A(i,1:j-1)*A(j,1:j-1)))/A(j,j)
+!!$ END IF
+!!$ END DO
+!!$ END DO
+
+
+
+
+
+ !! Minimal random number generator of Park and Miller combined with a
+ !! Marsaglia shift sequence. Returns a uniform random deviate between
+ !! 0.0 and 1.0 (exclusive of the endpoint values). This fully portable,
+ !! scalar generator has the traditional (not Fortran 90)
+ !! calling sequence with a random deviate as the returned function value:
+ !! call with idum a negative integer to initialize; thereafter, do not
+ !! alter idum except to reinitialize. The period of this generator is
+ !! about 3.1 × 10^18.
+ !!
+ SUBROUTINE ran_pmm_r4(idum, ran)
+
+ IMPLICIT NONE
+ INTEGER, INTENT(inout) :: idum
+ REAL(rprec4), INTENT(out) :: ran
+ REAL(rprec4), SAVE :: am
+ INTEGER, SAVE :: ix=-1, iy=-1, k
+
+ IF (idum <= 0 .OR. iy < 0) THEN
+ ! Initialize.
+ am=NEAREST(1.0_rprec4,-1.0_rprec4)/IM
+ iy=IOR(IEOR(888889999,ABS(idum)),1)
+ ix=IEOR(777755555,ABS(idum))
+ ! Set idum positive.
+ idum=ABS(idum)+1
+ END IF
+
+ ! Marsaglia shift sequence with period 2^32 - 1.
+ ix=IEOR(ix,ISHFT(ix,13))
+ ix=IEOR(ix,ISHFT(ix,-17))
+ ix=IEOR(ix,ISHFT(ix,5))
+
+ ! Park-Miller sequence by Schrage's method, period 2^31 - 2
+ k=iy/IQ
+ iy=IA*(iy-k*IQ)-IR*k
+ IF (iy < 0) THEN
+ iy=iy+IM
+ END IF
+
+ !Combine the two generators with masking to ensure nonzero value
+ ran = am*IOR(IAND(IM,IEOR(ix,iy)),1)
+
+ END SUBROUTINE ran_pmm_r4
+
+
+
+
+
+ !! Minimal random number generator of Park and Miller combined with a
+ !! Marsaglia shift sequence. Returns a uniform random deviate between
+ !! 0.0 and 1.0 (exclusive of the endpoint values). This fully portable,
+ !! scalar generator has the traditional (not Fortran 90)
+ !! calling sequence with a random deviate as the returned function value:
+ !! call with idum a negative integer to initialize; thereafter, do not
+ !! alter idum except to reinitialize. The period of this generator is
+ !! about 3.1 × 10^18.
+ !!
+ SUBROUTINE ran_pmm_r8(idum, ran)
+
+ IMPLICIT NONE
+ INTEGER, INTENT(inout) :: idum
+ REAL(rprec8), INTENT(out) :: ran
+ REAL(rprec8), SAVE :: am
+ INTEGER, SAVE :: ix=-1, iy=-1, k
+
+ IF (idum <= 0 .OR. iy < 0) THEN
+ ! Initialize.
+ am=NEAREST(1.0_rprec8,-1.0_rprec8)/IM
+ iy=IOR(IEOR(888889999,ABS(idum)),1)
+ ix=IEOR(777755555,ABS(idum))
+ ! Set idum positive.
+ idum=ABS(idum)+1
+ END IF
+
+ ! Marsaglia shift sequence with period 2^32 - 1.
+ ix=IEOR(ix,ISHFT(ix,13))
+ ix=IEOR(ix,ISHFT(ix,-17))
+ ix=IEOR(ix,ISHFT(ix,5))
+
+ ! Park-Miller sequence by Schrage's method, period 2^31 - 2
+ k=iy/IQ
+ iy=IA*(iy-k*IQ)-IR*k
+ IF (iy < 0) THEN
+ iy=iy+IM
+ END IF
+
+ !Combine the two generators with masking to ensure nonzero value
+ ran = am*IOR(IAND(IM,IEOR(ix,iy)),1)
+
+ END SUBROUTINE ran_pmm_r8
+
+
+
+
+ !! Minimal random number generator of Park and Miller combined with a
+ !! Marsaglia shift sequence. Returns a uniform random deviate between
+ !! 0.0 and 1.0 (exclusive of the endpoint values). This fully portable,
+ !! scalar generator has the traditional (not Fortran 90)
+ !! calling sequence with a random deviate as the returned function value:
+ !! call with idum a negative integer to initialize; thereafter, do not
+ !! alter idum except to reinitialize. The period of this generator is
+ !! about 3.1 × 10^18.
+ !!
+ SUBROUTINE ran_pmm_r16(idum, ran)
+
+ IMPLICIT NONE
+ INTEGER, INTENT(inout) :: idum
+ REAL(rprec16), INTENT(out) :: ran
+ REAL(rprec16), SAVE :: am
+ INTEGER, SAVE :: ix=-1, iy=-1, k
+
+ IF (idum <= 0 .OR. iy < 0) THEN
+ ! Initialize.
+ am=NEAREST(1.0_rprec16,-1.0_rprec16)/IM
+ iy=IOR(IEOR(888889999,ABS(idum)),1)
+ ix=IEOR(777755555,ABS(idum))
+ ! Set idum positive.
+ idum=ABS(idum)+1
+ END IF
+
+ ! Marsaglia shift sequence with period 2^32 - 1.
+ ix=IEOR(ix,ISHFT(ix,13))
+ ix=IEOR(ix,ISHFT(ix,-17))
+ ix=IEOR(ix,ISHFT(ix,5))
+
+ ! Park-Miller sequence by Schrage's method, period 2^31 - 2
+ k=iy/IQ
+ iy=IA*(iy-k*IQ)-IR*k
+ IF (iy < 0) THEN
+ iy=iy+IM
+ END IF
+
+ !Combine the two generators with masking to ensure nonzero value
+ ran = am*IOR(IAND(IM,IEOR(ix,iy)),1)
+
+ END SUBROUTINE ran_pmm_r16
+
+
+
+
+
+ SUBROUTINE randomNumber_single_r4(ran)
+
+ IMPLICIT NONE
+ REAL(rprec4), INTENT(out) :: ran
+
+ IF (first_ran) THEN
+ idum = idum_prm
+ first_ran = .FALSE.
+ END IF
+ CALL ran_pmm(idum, ran)
+
+ END SUBROUTINE randomNumber_single_r4
+
+
+
+
+
+ SUBROUTINE randomNumber_single_r8(ran)
+
+ IMPLICIT NONE
+ REAL(rprec8), INTENT(out) :: ran
+
+ IF (first_ran) THEN
+ idum = idum_prm
+ first_ran = .FALSE.
+ END IF
+ CALL ran_pmm(idum, ran)
+
+ END SUBROUTINE randomNumber_single_r8
+
+
+
+
+
+ SUBROUTINE randomNumber_single_r16(ran)
+
+ IMPLICIT NONE
+ REAL(rprec16), INTENT(out) :: ran
+
+ IF (first_ran) THEN
+ idum = idum_prm
+ first_ran = .FALSE.
+ END IF
+ CALL ran_pmm(idum, ran)
+
+ END SUBROUTINE randomNumber_single_r16
+
+
+
+
+
+ SUBROUTINE randomNumber_array_r4(ran)
+
+ IMPLICIT NONE
+ REAL(rprec4), DIMENSION(:), INTENT(out) :: ran
+ INTEGER :: i
+
+ DO i=1,SIZE(ran)
+ CALL randomNumber(ran(i))
+ END DO
+
+ END SUBROUTINE randomNumber_array_r4
+
+
+
+
+
+ SUBROUTINE randomNumber_2array_r4(ran)
+
+ IMPLICIT NONE
+ REAL(rprec4), DIMENSION(:,:), INTENT(out) :: ran
+ INTEGER :: i, j
+
+ DO i=1,SIZE(ran,dim=1)
+ DO j=1,SIZE(ran,dim=2)
+ CALL randomNumber(ran(i,j))
+ END DO
+ END DO
+
+ END SUBROUTINE randomNumber_2array_r4
+
+
+
+
+
+ SUBROUTINE randomNumber_array_r8(ran)
+
+ IMPLICIT NONE
+ REAL(rprec8), DIMENSION(:), INTENT(out) :: ran
+ INTEGER :: i
+
+ DO i=1,SIZE(ran)
+ CALL randomNumber(ran(i))
+ END DO
+
+ END SUBROUTINE randomNumber_array_r8
+
+
+
+
+
+ SUBROUTINE randomNumber_2array_r8(ran)
+
+ IMPLICIT NONE
+ REAL(rprec8), DIMENSION(:,:), INTENT(out) :: ran
+ INTEGER :: i, j
+
+ DO i=1,SIZE(ran,dim=1)
+ DO j=1,SIZE(ran,dim=2)
+ CALL randomNumber(ran(i,j))
+ END DO
+ END DO
+
+ END SUBROUTINE randomNumber_2array_r8
+
+
+
+
+
+ SUBROUTINE randomNumber_array_r16(ran)
+
+ IMPLICIT NONE
+ REAL(rprec16), DIMENSION(:), INTENT(out) :: ran
+ INTEGER :: i
+
+ DO i=1,SIZE(ran)
+ CALL randomNumber(ran(i))
+ END DO
+
+ END SUBROUTINE randomNumber_array_r16
+
+
+
+
+
+ SUBROUTINE randomGaussian_single_r4(rangauss)
+
+ IMPLICIT NONE
+ INTEGER, PARAMETER :: nran = 12
+ REAL(rprec4), INTENT(out) :: rangauss
+ REAL(rprec4), DIMENSION(nran) :: ran
+ REAL(rprec4) :: x1, sum
+ REAL(rprec4), SAVE :: x2, sln
+ LOGICAL, SAVE :: second = .FALSE.
+
+ IF (second) THEN
+ ! Use the second random number generated on last call:
+ rangauss = x2*sln
+ second = .FALSE.
+ ELSE
+ ! Generate a pair of random normals:
+ second = .TRUE.
+ sum = HUGE(sum)
+ DO WHILE (sum >= 1.0_rprec4)
+ CALL randomNumber(ran)
+ x1 = 2.0_rprec4 * ran(1) - 1.0_rprec4
+ ! Because congruential algorithms do not strictly speaking
+ ! produce independent random numbers, more randomness has
+ ! been created by not taking the two first numbers, but the
+ ! first and one of the numbers coming after the two first
+ ! numbers.
+ x2 = 2.0_rprec4 * ran(2+CEILING((nran-2)*ran(2))) - 1.0_rprec4
+ ! Tiny added to prevent LOG(zero)/zero:
+ sum = x1**2.0_rprec4 + x2**2.0_rprec4 + TINY(sum)
+ END DO
+ sln = SQRT((-2.0_rprec4*LOG(sum))/sum)
+ rangauss = x1 * sln
+ END IF
+
+ END SUBROUTINE randomGaussian_single_r4
+
+
+
+
+
+ SUBROUTINE randomGaussian_single_r8(rangauss)
+
+ IMPLICIT NONE
+ INTEGER, PARAMETER :: nran = 12
+ REAL(rprec8), INTENT(out) :: rangauss
+ REAL(rprec8), DIMENSION(nran) :: ran
+ REAL(rprec8) :: x1, sum
+ REAL(rprec8), SAVE :: x2, sln
+ LOGICAL, SAVE :: second = .FALSE.
+
+ IF (second) THEN
+ ! Use the second random number generated on last call:
+ rangauss = x2*sln
+ second = .FALSE.
+ ELSE
+ ! Generate a pair of random normals:
+ second = .TRUE.
+ sum = HUGE(sum)
+ DO WHILE (sum >= 1.0_rprec8)
+ CALL randomNumber(ran)
+ x1 = 2.0_rprec8 * ran(1) - 1.0_rprec8
+ ! Because congruential algorithms do not strictly speaking
+ ! produce independent random numbers, more randomness has
+ ! been created by not taking the two first numbers, but the
+ ! first and one of the numbers coming after the two first
+ ! numbers.
+ x2 = 2.0_rprec8 * ran(2+CEILING((nran-2)*ran(2))) - 1.0_rprec8
+ ! Tiny added to prevent LOG(zero)/zero:
+ sum = x1**2.0_rprec8 + x2**2.0_rprec8 + TINY(sum)
+ END DO
+ sln = SQRT((-2.0_rprec8*LOG(sum))/sum)
+ rangauss = x1 * sln
+ END IF
+
+ END SUBROUTINE randomGaussian_single_r8
+
+
+
+
+
+ SUBROUTINE randomGaussian_single_r16(rangauss)
+
+ IMPLICIT NONE
+ INTEGER, PARAMETER :: nran = 12
+ REAL(rprec16), INTENT(out) :: rangauss
+ REAL(rprec16), DIMENSION(nran) :: ran
+ REAL(rprec16) :: x1, sum
+ REAL(rprec16), SAVE :: x2, sln
+ LOGICAL, SAVE :: second = .FALSE.
+
+ IF (second) THEN
+ ! Use the second random number generated on last call:
+ rangauss = x2*sln
+ second = .FALSE.
+ ELSE
+ ! Generate a pair of random normals:
+ second = .TRUE.
+ sum = HUGE(sum)
+ DO WHILE (sum >= 1.0_rprec16)
+ CALL randomNumber(ran)
+ x1 = 2.0_rprec16 * ran(1) - 1.0_rprec16
+ ! Because congruential algorithms do not strictly speaking
+ ! produce independent random numbers, more randomness has
+ ! been created by not taking the two first numbers, but the
+ ! first and one of the numbers coming after the two first
+ ! numbers.
+ x2 = 2.0_rprec16 * ran(2+CEILING((nran-2)*ran(2))) - 1.0_rprec16
+ ! Tiny added to prevent LOG(zero)/zero:
+ sum = x1**2.0_rprec16 + x2**2.0_rprec16 + TINY(sum)
+ END DO
+ sln = SQRT((-2.0_rprec16*LOG(sum))/sum)
+ rangauss = x1 * sln
+ END IF
+
+ END SUBROUTINE randomGaussian_single_r16
+
+
+
+
+
+ SUBROUTINE randomGaussian_array_r4(rangauss)
+
+ IMPLICIT NONE
+ REAL(rprec4), DIMENSION(:), INTENT(out) :: rangauss
+ INTEGER :: i
+
+ DO i=1,SIZE(rangauss)
+ CALL randomGaussian(rangauss(i))
+ END DO
+
+ END SUBROUTINE randomGaussian_array_r4
+
+
+
+
+
+ SUBROUTINE randomGaussian_array_r8(rangauss)
+
+ IMPLICIT NONE
+ REAL(rprec8), DIMENSION(:), INTENT(out) :: rangauss
+ INTEGER :: i
+
+ DO i=1,SIZE(rangauss)
+ CALL randomGaussian(rangauss(i))
+ END DO
+
+ END SUBROUTINE randomGaussian_array_r8
+
+
+
+
+
+ SUBROUTINE randomGaussian_array_r16(rangauss)
+
+ IMPLICIT NONE
+ REAL(rprec16), DIMENSION(:), INTENT(out) :: rangauss
+ INTEGER :: i
+
+ DO i=1,SIZE(rangauss)
+ CALL randomGaussian(rangauss(i))
+ END DO
+
+ END SUBROUTINE randomGaussian_array_r16
+
+
+
+
+
+ SUBROUTINE setRandomSeed(seed)
+
+ IMPLICIT NONE
+ INTEGER, OPTIONAL, INTENT(in) :: seed
+ INTEGER, DIMENSION(8) :: dt
+ INTEGER, DIMENSION(1) :: seed_array
+ INTEGER :: k
+
+ CALL RANDOM_SEED(size=k)
+ IF (PRESENT(seed)) THEN
+ seed_array = seed
+ CALL RANDOM_SEED(put=seed_array(1:k))
+ ELSE
+ CALL DATE_AND_TIME(values=dt)
+ seed_array = dt(8)
+ CALL RANDOM_SEED(put=seed_array(1:k))
+ END IF
+
+ END SUBROUTINE setRandomSeed
+
+
+
+
+
+END MODULE random
Index: trunk/mops/oorb/modules/sort.f90
===================================================================
--- trunk/mops/oorb/modules/sort.f90 (revision 34646)
+++ trunk/mops/oorb/modules/sort.f90 (revision 34646)
@@ -0,0 +1,1416 @@
+!====================================================================!
+! !
+! Copyright 2002,2003,2004,2005,2006,2007,2008,2009,2010 !
+! Mikael Granvik, Jenni Virtanen, Karri Muinonen, Teemu Laakso, !
+! Dagmara Oszkiewicz !
+! !
+! This file is part of OpenOrb. !
+! !
+! OpenOrb 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. !
+! !
+! OpenOrb 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 OpenOrb. If not, see . !
+! !
+!====================================================================!
+!
+!! *Module*description*:
+!!
+!! Contains sorting and searching routines.
+!!
+!! @author MG
+!! @version 2010-03-02
+!!
+MODULE sort
+
+ USE parameters
+ USE utilities
+
+ IMPLICIT NONE
+ INTEGER, PARAMETER :: NN = 15, NSTACK = 100
+
+ INTERFACE insertionSort
+ MODULE PROCEDURE insertionSort_i8
+ MODULE PROCEDURE insertionSort_r16
+ MODULE PROCEDURE insertionSort_ch
+ END INTERFACE
+
+ INTERFACE quickSort
+ MODULE PROCEDURE quickSort_i4
+ MODULE PROCEDURE quickSort_i4_index
+ MODULE PROCEDURE quickSort_i8
+ MODULE PROCEDURE quickSort_i8_index
+ MODULE PROCEDURE quickSort_r8
+ MODULE PROCEDURE quickSort_r8_index
+ MODULE PROCEDURE quickSort_r16
+ MODULE PROCEDURE quickSort_ch
+ MODULE PROCEDURE quickSort_ch_index
+ END INTERFACE
+
+ INTERFACE binarySearch
+ MODULE PROCEDURE binarySearch_i8
+ MODULE PROCEDURE binarySearch_r8
+ MODULE PROCEDURE binarySearch_r16
+ MODULE PROCEDURE binarySearch_ch
+ MODULE PROCEDURE binarySearch_ch_index
+ END INTERFACE
+
+ INTERFACE findLocation
+ MODULE PROCEDURE findLocation_r8
+ MODULE PROCEDURE findLocation_r8_indx
+ MODULE PROCEDURE findLocation_r16
+ END INTERFACE
+
+
+
+
+
+CONTAINS
+
+
+
+
+
+ !! *Description*:
+ !!
+ !! The insertion sort technique is the same as the one used for
+ !! sorting cards: Pick out the second card and put it in order with
+ !! the first card. Then pick out the third card and put it into the
+ !! sequence among the first two. Continue until the last card has
+ !! been picked out and inserted. In a random situation the algorithm
+ !! scales as N**2, but assuming an almost sorted array it can even
+ !! reach N. Generally, the insertion sort should not be used
+ !! for N >= 100. This implementation is an in-place sort.
+ !!
+ SUBROUTINE insertionSort_i8(array)
+
+ IMPLICIT NONE
+ INTEGER(iprec8), DIMENSION(:), INTENT(inout) :: array
+ INTEGER(iprec8) :: element
+ INTEGER :: i, j
+
+ DO i=2, SIZE(array)
+ element = array(i)
+ j = i
+ DO WHILE (j > 1)
+ IF (array(j-1) <= element) THEN
+ EXIT
+ END IF
+ array(j) = array(j-1)
+ j = j - 1
+ END DO
+ array(j) = element
+ END DO
+
+ END SUBROUTINE insertionSort_i8
+
+
+
+
+
+ !! *Description*:
+ !!
+ !! The insertion sort technique is the same as the one used for
+ !! sorting cards: Pick out the second card and put it in order with
+ !! the first card. Then pick out the third card and put it into the
+ !! sequence among the first two. Continue until the last card has
+ !! been picked out and inserted. In a random situation the algorithm
+ !! scales as N**2, but assuming an almost sorted array it can even
+ !! reach N. Generally, the insertion sort should not be used
+ !! for N >= 100. This implementation is an in-place sort.
+ !!
+ SUBROUTINE insertionSort_ch(array)
+
+ IMPLICIT NONE
+ CHARACTER(len=*), DIMENSION(:), INTENT(inout) :: array
+ CHARACTER(len=LEN(array(1))) :: element
+ INTEGER :: i, j
+
+ DO i=2,SIZE(array)
+ element = array(i)
+ j = i
+ DO WHILE (j > 1)
+ IF (array(j-1) <= element) THEN
+ EXIT
+ END IF
+ array(j) = array(j-1)
+ j = j - 1
+ END DO
+ array(j) = element
+ END DO
+
+ END SUBROUTINE insertionSort_ch
+
+
+
+
+
+ !! *Description*:
+ !!
+ !! The insertion sort technique is the same as the one used for
+ !! sorting cards: Pick out the second card and put it in order with
+ !! the first card. Then pick out the third card and put it into the
+ !! sequence among the first two. Continue until the last card has
+ !! been picked out and inserted. In a random situation the algorithm
+ !! scales as N**2, but assuming an almost sorted array it can even
+ !! reach N. Generally, the insertion sort should not be used
+ !! for N >= 100. This implementation is an in-place sort.
+ !!
+ SUBROUTINE insertionSort_r16(array)
+
+ IMPLICIT NONE
+ REAL(rprec16), DIMENSION(:), INTENT(inout) :: array
+ REAL(rprec16) :: element
+ INTEGER :: i, j
+
+ DO i=2, SIZE(array)
+ element = array(i)
+ j = i
+ DO WHILE (j > 1)
+ IF (array(j-1) <= element) THEN
+ EXIT
+ END IF
+ array(j) = array(j-1)
+ j = j - 1
+ END DO
+ array(j) = element
+ END DO
+
+ END SUBROUTINE insertionSort_r16
+
+
+
+
+
+ SUBROUTINE quickSort_i4(array, error)
+
+ IMPLICIT NONE
+ INTEGER(iprec4), DIMENSION(:), INTENT(inout) :: array
+ CHARACTER(len=*), INTENT(inout) :: error
+ INTEGER(iprec4) :: element
+ INTEGER, DIMENSION(NSTACK) :: stack
+ INTEGER :: i, j, center, left, right, n, istack
+
+ n = SIZE(array)
+ istack = 0
+ left = 1
+ right = n
+
+ DO
+ IF (right-left < NN) THEN
+ DO i=left+1,right
+ element = array(i)
+ DO j=i-1,left,-1
+ IF (array(j) <= element) EXIT
+ array(j+1) = array(j)
+ END DO
+ array(j+1) = element
+ END DO
+ IF (istack == 0) RETURN
+ right = stack(istack)
+ left = stack(istack-1)
+ istack = istack - 2
+ ELSE
+ center = (left + right)/2
+ CALL swap(array(center),array(left+1))
+ CALL swap(array(left),array(right),array(left)>array(right))
+ CALL swap(array(left+1),array(right),array(left+1)>array(right))
+ CALL swap(array(left),array(left+1),array(left)>array(left+1))
+ i = left + 1
+ j = right
+ element = array(left+1)
+ DO
+ DO
+ i = i + 1
+ IF (array(i) >= element) EXIT
+ END DO
+ DO
+ j = j - 1
+ IF (array(j) <= element) EXIT
+ END DO
+ IF (j < i) EXIT
+ CALL swap(array(i), array(j))
+ END DO
+ array(left+1) = array(j)
+ array(j) = element
+ istack = istack + 2
+ IF (istack > NSTACK) THEN
+ error = " -> sort : quickSort : NSTACK too small." // TRIM(error)
+ RETURN
+ END IF
+ IF (right-i+1 >= j-1) THEN
+ stack(istack) = right
+ stack(istack-1) = i
+ right = j - 1
+ ELSE
+ stack(istack) = j - 1
+ stack(istack-1) = left
+ left = i
+ END IF
+ END IF
+ END DO
+
+ END SUBROUTINE quickSort_i4
+
+
+
+
+
+ SUBROUTINE quickSort_i4_index(array, ind, error)
+
+ IMPLICIT NONE
+ INTEGER(iprec4), DIMENSION(:), INTENT(in) :: array
+ INTEGER, DIMENSION(SIZE(array)), INTENT(out) :: ind
+ CHARACTER(len=*), INTENT(inout) :: error
+ INTEGER(iprec4) :: element
+ INTEGER, DIMENSION(NSTACK) :: stack
+ INTEGER :: i, j, center, left, right, n, istack, tmp
+
+ n = SIZE(array)
+ istack = 0
+ left = 1
+ right = n
+ DO i=1,SIZE(ind)
+ ind(i) = i
+ END DO
+
+ DO
+ IF (right-left < NN) THEN
+ DO i=left+1,right
+ element = array(ind(i))
+ tmp = ind(i)
+ DO j=i-1,left,-1
+ IF (array(ind(j)) <= element) THEN
+ EXIT
+ END IF
+ ind(j+1) = ind(j)
+ END DO
+ ind(j+1) = tmp
+ END DO
+ IF (istack == 0) RETURN
+ right = stack(istack)
+ left = stack(istack-1)
+ istack = istack - 2
+ ELSE
+ center = (left + right)/2
+ CALL swap(ind(center),ind(left+1))
+ CALL swap(ind(left),ind(right),array(ind(left))>array(ind(right)))
+ CALL swap(ind(left+1),ind(right),array(ind(left+1))>array(ind(right)))
+ CALL swap(ind(left),ind(left+1),array(ind(left))>array(ind(left+1)))
+ i = left + 1
+ j = right
+ element = array(ind(left+1))
+ tmp = ind(left+1)
+ DO
+ DO
+ i = i + 1
+ IF (array(ind(i)) >= element) EXIT
+ END DO
+ DO
+ j = j - 1
+ IF (array(ind(j)) <= element) EXIT
+ END DO
+ IF (j < i) EXIT
+ CALL swap(ind(i), ind(j))
+ END DO
+ ind(left+1) = ind(j)
+ ind(j) = tmp
+ istack = istack + 2
+ IF (istack > NSTACK) THEN
+ error = " -> sort : quickSort : NSTACK too small." // TRIM(error)
+ RETURN
+ END IF
+ IF (right-i+1 >= j-1) THEN
+ stack(istack) = right
+ stack(istack-1) = i
+ right = j - 1
+ ELSE
+ stack(istack) = j - 1
+ stack(istack-1) = left
+ left = i
+ END IF
+ END IF
+ END DO
+
+ END SUBROUTINE quickSort_i4_index
+
+
+
+
+
+ SUBROUTINE quickSort_i8(array, error)
+
+ IMPLICIT NONE
+ INTEGER(rprec8), DIMENSION(:), INTENT(inout) :: array
+ CHARACTER(len=*), INTENT(inout) :: error
+ INTEGER(rprec8) :: element
+ INTEGER, DIMENSION(NSTACK) :: stack
+ INTEGER :: i, j, center, left, right, n, istack
+
+ n = SIZE(array)
+ istack = 0
+ left = 1
+ right = n
+
+ DO
+ IF (right-left < NN) THEN
+ DO i=left+1,right
+ element = array(i)
+ DO j=i-1,left,-1
+ IF (array(j) <= element) EXIT
+ array(j+1) = array(j)
+ END DO
+ array(j+1) = element
+ END DO
+ IF (istack == 0) RETURN
+ right = stack(istack)
+ left = stack(istack-1)
+ istack = istack - 2
+ ELSE
+ center = (left + right)/2
+ CALL swap(array(center), array(left+1))
+ CALL swap(array(left), array(right), array(left) > array(right))
+ CALL swap(array(left+1), array(right), array(left+1) > array(right))
+ CALL swap(array(left), array(left+1), array(left) > array(left+1))
+ i = left + 1
+ j = right
+ element = array(left+1)
+ DO
+ DO
+ i = i + 1
+ IF (array(i) >= element) EXIT
+ END DO
+ DO
+ j = j - 1
+ IF (array(j) <= element) EXIT
+ END DO
+ IF (j < i) EXIT
+ CALL swap(array(i), array(j))
+ END DO
+ array(left+1) = array(j)
+ array(j) = element
+ istack = istack + 2
+ IF (istack > NSTACK) THEN
+ error = " -> sort : quickSort : NSTACK too small." // TRIM(error)
+ RETURN
+ END IF
+ IF (right-i+1 >= j-1) THEN
+ stack(istack) = right
+ stack(istack-1) = i
+ right = j - 1
+ ELSE
+ stack(istack) = j - 1
+ stack(istack-1) = left
+ left = i
+ END IF
+ END IF
+ END DO
+
+ END SUBROUTINE quickSort_i8
+
+
+
+
+
+ SUBROUTINE quickSort_i8_index(array, ind, error)
+
+ IMPLICIT NONE
+ INTEGER(rprec8), DIMENSION(:), INTENT(in) :: array
+ INTEGER, DIMENSION(SIZE(array)), INTENT(out) :: ind
+ CHARACTER(len=*), INTENT(inout) :: error
+ INTEGER(rprec8) :: element
+ INTEGER, DIMENSION(NSTACK) :: stack
+ INTEGER :: i, j, center, left, right, n, istack, tmp
+
+ n = SIZE(array)
+ istack = 0
+ left = 1
+ right = n
+ DO i=1,SIZE(ind)
+ ind(i) = i
+ END DO
+
+ DO
+ IF (right-left < NN) THEN
+ DO i=left+1,right
+ element = array(ind(i))
+ tmp = ind(i)
+ DO j=i-1,left,-1
+ IF (array(ind(j)) <= element) THEN
+ EXIT
+ END IF
+ ind(j+1) = ind(j)
+ END DO
+ ind(j+1) = tmp
+ END DO
+ IF (istack == 0) RETURN
+ right = stack(istack)
+ left = stack(istack-1)
+ istack = istack - 2
+ ELSE
+ center = (left + right)/2
+ CALL swap(ind(center),ind(left+1))
+ CALL swap(ind(left),ind(right),array(ind(left))>array(ind(right)))
+ CALL swap(ind(left+1),ind(right),array(ind(left+1))>array(ind(right)))
+ CALL swap(ind(left),ind(left+1),array(ind(left))>array(ind(left+1)))
+ i = left + 1
+ j = right
+ element = array(ind(left+1))
+ tmp = ind(left+1)
+ DO
+ DO
+ i = i + 1
+ IF (array(ind(i)) >= element) EXIT
+ END DO
+ DO
+ j = j - 1
+ IF (array(ind(j)) <= element) EXIT
+ END DO
+ IF (j < i) EXIT
+ CALL swap(ind(i), ind(j))
+ END DO
+ ind(left+1) = ind(j)
+ ind(j) = tmp
+ istack = istack + 2
+ IF (istack > NSTACK) THEN
+ error = " -> sort : quickSort : NSTACK too small." // TRIM(error)
+ RETURN
+ END IF
+ IF (right-i+1 >= j-1) THEN
+ stack(istack) = right
+ stack(istack-1) = i
+ right = j - 1
+ ELSE
+ stack(istack) = j - 1
+ stack(istack-1) = left
+ left = i
+ END IF
+ END IF
+ END DO
+
+ END SUBROUTINE quickSort_i8_index
+
+
+
+
+
+ SUBROUTINE quickSort_r8(array, error)
+
+ IMPLICIT NONE
+ REAL(rprec8), DIMENSION(:), INTENT(inout) :: array
+ CHARACTER(len=*), INTENT(inout) :: error
+ REAL(rprec8) :: element
+ INTEGER, DIMENSION(NSTACK) :: stack
+ INTEGER :: i, j, center, left, right, n, istack
+
+ n = SIZE(array)
+ istack = 0
+ left = 1
+ right = n
+
+ DO
+ IF (right-left < NN) THEN
+ DO i=left+1,right
+ element = array(i)
+ DO j=i-1,left,-1
+ IF (array(j) <= element) EXIT
+ array(j+1) = array(j)
+ END DO
+ array(j+1) = element
+ END DO
+ IF (istack == 0) RETURN
+ right = stack(istack)
+ left = stack(istack-1)
+ istack = istack - 2
+ ELSE
+ center = (left + right)/2
+ CALL swap(array(center),array(left+1))
+ CALL swap(array(left),array(right),array(left)>array(right))
+ CALL swap(array(left+1),array(right),array(left+1)>array(right))
+ CALL swap(array(left),array(left+1),array(left)>array(left+1))
+ i = left + 1
+ j = right
+ element = array(left+1)
+ DO
+ DO
+ i = i + 1
+ IF (array(i) >= element) EXIT
+ END DO
+ DO
+ j = j - 1
+ IF (array(j) <= element) EXIT
+ END DO
+ IF (j < i) EXIT
+ CALL swap(array(i), array(j))
+ END DO
+ array(left+1) = array(j)
+ array(j) = element
+ istack = istack + 2
+ IF (istack > NSTACK) THEN
+ error = " -> sort : quickSort : NSTACK too small." // TRIM(error)
+ RETURN
+ END IF
+ IF (right-i+1 >= j-1) THEN
+ stack(istack) = right
+ stack(istack-1) = i
+ right = j - 1
+ ELSE
+ stack(istack) = j - 1
+ stack(istack-1) = left
+ left = i
+ END IF
+ END IF
+ END DO
+
+ END SUBROUTINE quickSort_r8
+
+
+
+
+
+ SUBROUTINE quickSort_r8_index(array, ind, error)
+
+ IMPLICIT NONE
+ REAL(rprec8), DIMENSION(:), INTENT(in) :: array
+ INTEGER, DIMENSION(SIZE(array)), INTENT(out) :: ind
+ CHARACTER(len=*), INTENT(inout) :: error
+ REAL(rprec8) :: element
+ INTEGER, DIMENSION(NSTACK) :: stack
+ INTEGER :: i, j, center, left, right, n, istack, tmp
+
+ n = SIZE(array)
+ istack = 0
+ left = 1
+ right = n
+ DO i=1,SIZE(ind)
+ ind(i) = i
+ END DO
+
+ DO
+ IF (right-left < NN) THEN
+ DO i=left+1,right
+ element = array(ind(i))
+ tmp = ind(i)
+ DO j=i-1,left,-1
+ IF (array(ind(j)) <= element) THEN
+ EXIT
+ END IF
+ ind(j+1) = ind(j)
+ END DO
+ ind(j+1) = tmp
+ END DO
+ IF (istack == 0) RETURN
+ right = stack(istack)
+ left = stack(istack-1)
+ istack = istack - 2
+ ELSE
+ center = (left + right)/2
+ CALL swap(ind(center),ind(left+1))
+ CALL swap(ind(left),ind(right),array(ind(left))>array(ind(right)))
+ CALL swap(ind(left+1),ind(right),array(ind(left+1))>array(ind(right)))
+ CALL swap(ind(left),ind(left+1),array(ind(left))>array(ind(left+1)))
+ i = left + 1
+ j = right
+ element = array(ind(left+1))
+ tmp = ind(left+1)
+ DO
+ DO
+ i = i + 1
+ IF (array(ind(i)) >= element) EXIT
+ END DO
+ DO
+ j = j - 1
+ IF (array(ind(j)) <= element) EXIT
+ END DO
+ IF (j < i) EXIT
+ CALL swap(ind(i), ind(j))
+ END DO
+ ind(left+1) = ind(j)
+ ind(j) = tmp
+ istack = istack + 2
+ IF (istack > NSTACK) THEN
+ error = " -> sort : quickSort : NSTACK too small." // TRIM(error)
+ RETURN
+ END IF
+ IF (right-i+1 >= j-1) THEN
+ stack(istack) = right
+ stack(istack-1) = i
+ right = j - 1
+ ELSE
+ stack(istack) = j - 1
+ stack(istack-1) = left
+ left = i
+ END IF
+ END IF
+ END DO
+
+ END SUBROUTINE quickSort_r8_index
+
+
+
+
+
+ SUBROUTINE quickSort_r16(array, error)
+
+ IMPLICIT NONE
+ REAL(rprec16), DIMENSION(:), INTENT(inout) :: array
+ CHARACTER(len=*), INTENT(inout) :: error
+ REAL(rprec16) :: element
+ INTEGER, DIMENSION(NSTACK) :: stack
+ INTEGER :: i, j, center, left, right, n, istack
+
+ n = SIZE(array)
+ istack = 0
+ left = 1
+ right = n
+
+ DO
+ IF (right-left < NN) THEN
+ DO i=left+1,right
+ element = array(i)
+ DO j=i-1,left,-1
+ IF (array(j) <= element) EXIT
+ array(j+1) = array(j)
+ END DO
+ array(j+1) = element
+ END DO
+ IF (istack == 0) RETURN
+ right = stack(istack)
+ left = stack(istack-1)
+ istack = istack - 2
+ ELSE
+ center = (left + right)/2
+ CALL swap(array(center),array(left+1))
+ CALL swap(array(left),array(right),array(left)>array(right))
+ CALL swap(array(left+1),array(right),array(left+1)>array(right))
+ CALL swap(array(left),array(left+1),array(left)>array(left+1))
+ i = left + 1
+ j = right
+ element = array(left+1)
+ DO
+ DO
+ i = i + 1
+ IF (array(i) >= element) EXIT
+ END DO
+ DO
+ j = j - 1
+ IF (array(j) <= element) EXIT
+ END DO
+ IF (j < i) EXIT
+ CALL swap(array(i), array(j))
+ END DO
+ array(left+1) = array(j)
+ array(j) = element
+ istack = istack + 2
+ IF (istack > NSTACK) THEN
+ error = " -> sort : quickSort : NSTACK too small." // TRIM(error)
+ RETURN
+ END IF
+ IF (right-i+1 >= j-1) THEN
+ stack(istack) = right
+ stack(istack-1) = i
+ right = j - 1
+ ELSE
+ stack(istack) = j - 1
+ stack(istack-1) = left
+ left = i
+ END IF
+ END IF
+ END DO
+
+ END SUBROUTINE quickSort_r16
+
+
+
+
+
+ SUBROUTINE quickSort_ch(array, error)
+
+ IMPLICIT NONE
+ CHARACTER(len=*), DIMENSION(:), INTENT(inout) :: array
+ CHARACTER(len=*), INTENT(inout) :: error
+ CHARACTER(len=LEN(array(1))) :: element
+ INTEGER, DIMENSION(NSTACK) :: stack
+ INTEGER :: i, j, center, left, right, n, istack
+
+ n = SIZE(array,dim=1)
+ istack = 0
+ left = 1
+ right = n
+
+ DO
+ IF (right-left < NN) THEN
+ DO i=left+1,right
+ element = array(i)
+ DO j=i-1,left,-1
+ IF (array(j) <= element) EXIT
+ array(j+1) = array(j)
+ END DO
+ array(j+1) = element
+ END DO
+ IF (istack == 0) RETURN
+ right = stack(istack)
+ left = stack(istack-1)
+ istack = istack - 2
+ ELSE
+ center = (left + right)/2
+ CALL swap(array(center),array(left+1))
+ CALL swap(array(left),array(right),array(left)>array(right))
+ CALL swap(array(left+1),array(right),array(left+1)>array(right))
+ CALL swap(array(left),array(left+1),array(left)>array(left+1))
+ i = left + 1
+ j = right
+ element = array(left+1)
+ DO
+ DO
+ i = i + 1
+ IF (array(i) >= element) EXIT
+ END DO
+ DO
+ j = j - 1
+ IF (array(j) <= element) EXIT
+ END DO
+ IF (j < i) EXIT
+ CALL swap(array(i), array(j))
+ END DO
+ array(left+1) = array(j)
+ array(j) = element
+ istack = istack + 2
+ IF (istack > NSTACK) THEN
+ error = " -> sort : quickSort : NSTACK too small." // TRIM(error)
+ RETURN
+ END IF
+ IF (right-i+1 >= j-1) THEN
+ stack(istack) = right
+ stack(istack-1) = i
+ right = j - 1
+ ELSE
+ stack(istack) = j - 1
+ stack(istack-1) = left
+ left = i
+ END IF
+ END IF
+ END DO
+
+ END SUBROUTINE quickSort_ch
+
+
+
+
+
+ SUBROUTINE quickSort_ch_index(array, ind, error)
+
+ IMPLICIT NONE
+ CHARACTER(len=*), DIMENSION(:), INTENT(inout) :: array
+ INTEGER, DIMENSION(SIZE(array)), INTENT(out) :: ind
+ CHARACTER(len=*), INTENT(inout) :: error
+ CHARACTER(len=LEN(array(1))) :: element
+ INTEGER, DIMENSION(NSTACK) :: stack
+ INTEGER :: i, j, center, left, right, n, istack, tmp
+
+ n = SIZE(array)
+ istack = 0
+ left = 1
+ right = n
+ DO i=1,SIZE(ind)
+ ind(i) = i
+ END DO
+
+ DO
+ IF (right-left < NN) THEN
+ DO i=left+1,right
+ element = array(ind(i))
+ tmp = ind(i)
+ DO j=i-1,left,-1
+ IF (array(ind(j)) <= element) THEN
+ EXIT
+ END IF
+ ind(j+1) = ind(j)
+ END DO
+ ind(j+1) = tmp
+ END DO
+ IF (istack == 0) RETURN
+ right = stack(istack)
+ left = stack(istack-1)
+ istack = istack - 2
+ ELSE
+ center = (left + right)/2
+ CALL swap(ind(center),ind(left+1))
+ CALL swap(ind(left),ind(right),array(ind(left))>array(ind(right)))
+ CALL swap(ind(left+1),ind(right),array(ind(left+1))>array(ind(right)))
+ CALL swap(ind(left),ind(left+1),array(ind(left))>array(ind(left+1)))
+ i = left + 1
+ j = right
+ element = array(ind(left+1))
+ tmp = ind(left+1)
+ DO
+ DO
+ i = i + 1
+ IF (array(ind(i)) >= element) EXIT
+ END DO
+ DO
+ j = j - 1
+ IF (array(ind(j)) <= element) EXIT
+ END DO
+ IF (j < i) EXIT
+ CALL swap(ind(i), ind(j))
+ END DO
+ ind(left+1) = ind(j)
+ ind(j) = tmp
+ istack = istack + 2
+ IF (istack > NSTACK) THEN
+ error = " -> sort : quickSort : NSTACK too small." // TRIM(error)
+ RETURN
+ END IF
+ IF (right-i+1 >= j-1) THEN
+ stack(istack) = right
+ stack(istack-1) = i
+ right = j - 1
+ ELSE
+ stack(istack) = j - 1
+ stack(istack-1) = left
+ left = i
+ END IF
+ END IF
+ END DO
+
+ END SUBROUTINE quickSort_ch_index
+
+
+
+
+
+ !! *Description*:
+ !!
+ !! Binary search routine. Returns the position of the search key in
+ !! the one-dimensional input array. If the search key is not found,
+ !! it returns -1.
+ !!
+ !! As a prerequisite, the array which is to be scanned has to be sorted
+ !! in ascending order. The algorithm searches for the search
+ !! key by repeatedly dividing the search interval in half. Initially
+ !! the interval covers the whole array. If the item in the middle of
+ !! the interval is larger than the key, the interval is narrowed to
+ !! the lower half. Otherwise it is narrowed to the upper half. The
+ !! procedure is continued until the value is found, or the interval
+ !! is empty.
+ !!
+ INTEGER FUNCTION binarySearch_i8(key, array, error)
+
+ ! The input array needs to be sorted in ascending order.
+
+ IMPLICIT NONE
+ INTEGER(iprec8), INTENT(in) :: key
+ INTEGER(iprec8), DIMENSION(:), INTENT(in) :: array
+ CHARACTER(len=*), INTENT(inout) :: error
+ INTEGER :: n, left, right, center, i
+
+ n = SIZE(array, dim=1)
+ ! Return immediately
+ ! - if the length of the array is zero:
+ IF (n == 0) THEN
+ binarySearch_i8 = -1
+ RETURN
+ END IF
+ ! - if the key (value to be searched for) is smaller or
+ ! larger than the minimum or maximum values of
+ ! the array:
+ IF (key < array(1) .OR. key > array(n)) THEN
+ binarySearch_i8 = -1
+ RETURN
+ END IF
+
+ i = 1
+ left = 1
+ right = n
+ DO WHILE (left <= right .AND. i<=n+2)
+ i = i + 1
+ center = CEILING((left+right)/2.0)
+ IF (key == array(center)) THEN
+ binarySearch_i8 = center
+ RETURN
+ ELSE IF (key < array(center)) THEN
+ right = center - 1
+ ELSE IF (key > array(center)) THEN
+ left = center + 1
+ END IF
+ END DO
+
+ IF (i == n+2) THEN
+ error = " -> sort : binarySearch : Search stuck in a loop." // TRIM(error)
+ END IF
+
+ ! The key could not be found in the array.
+ ! Return a negative index:
+ binarySearch_i8 = -1
+
+ END FUNCTION binarySearch_i8
+
+
+
+
+
+ !! *Description*:
+ !!
+ !! Binary search routine. Returns the position of the search key in
+ !! the one-dimensional input array. If the search key is not found,
+ !! it returns -1.
+ !!
+ !! As a prerequisite, the array which is to be scanned has to be sorted
+ !! in ascending order. The algorithm searches for the search
+ !! key by repeatedly dividing the search interval in half. Initially
+ !! the interval covers the whole array. If the item in the middle of
+ !! the interval is larger than the key, the interval is narrowed to
+ !! the lower half. Otherwise it is narrowed to the upper half. The
+ !! procedure is continued until the value is found, or the interval
+ !! is empty.
+ !!
+ INTEGER FUNCTION binarySearch_r8(key, array, error)
+
+ ! The input array needs to be sorted in ascending order.
+
+ IMPLICIT NONE
+ REAL(rprec8), INTENT(in) :: key
+ REAL(rprec8), DIMENSION(:), INTENT(in) :: array
+ CHARACTER(len=*), INTENT(inout) :: error
+ INTEGER :: n, left, right, center, i
+
+ n = SIZE(array, dim=1)
+ ! Return immediately
+ ! - if the length of the array is zero:
+ IF (n == 0) THEN
+ binarySearch_r8 = -1
+ RETURN
+ END IF
+ ! - if the key (value to be searched for) is smaller or
+ ! larger than the minimum or maximum values of
+ ! the array:
+ IF (key < array(1) .OR. key > array(n)) THEN
+ binarySearch_r8 = -1
+ RETURN
+ END IF
+
+ i = 1
+ left = 1
+ right = n
+ DO WHILE (left <= right .AND. i<=n+2)
+ i = i + 1
+ center = CEILING((left+right)/2.0)
+ IF (ABS(key - array(center)) < 10.0_rprec8*EPSILON(key)) THEN
+ binarySearch_r8 = center
+ RETURN
+ ELSE IF (key < array(center)) THEN
+ right = center - 1
+ ELSE IF (key > array(center)) THEN
+ left = center + 1
+ END IF
+ END DO
+
+ IF (i == n+2) THEN
+ error = " -> sort : binarySearch : Search stuck in a loop." // TRIM(error)
+ END IF
+
+ ! The key could not be found in the array.
+ ! Return a negative index:
+ binarySearch_r8 = -1
+
+ END FUNCTION binarySearch_r8
+
+
+
+
+
+ !! *Description*:
+ !!
+ !! Binary search routine. Returns the position of the search key in
+ !! the one-dimensional input array. If the search key is not found,
+ !! it returns -1.
+ !!
+ !! As a prerequisite, the array which is to be scanned has to be sorted
+ !! in ascending order. The algorithm searches for the search
+ !! key by repeatedly dividing the search interval in half. Initially
+ !! the interval covers the whole array. If the item in the middle of
+ !! the interval is larger than the key, the interval is narrowed to
+ !! the lower half. Otherwise it is narrowed to the upper half. The
+ !! procedure is continued until the value is found, or the interval
+ !! is empty.
+ !!
+ INTEGER FUNCTION binarySearch_r16(key, array, error)
+
+ ! The input array needs to be sorted in ascending order.
+
+ IMPLICIT NONE
+ REAL(rprec16), INTENT(in) :: key
+ REAL(rprec16), DIMENSION(:), INTENT(in) :: array
+ CHARACTER(len=*), INTENT(inout) :: error
+ INTEGER :: n, left, right, center, i
+
+ n = SIZE(array, dim=1)
+ ! Return immediately
+ ! - if the length of the array is zero:
+ IF (n == 0) THEN
+ binarySearch_r16 = -1
+ RETURN
+ END IF
+ ! - if the key (value to be searched for) is smaller or
+ ! larger than the minimum or maximum values of
+ ! the array:
+ IF (key < array(1) .OR. key > array(n)) THEN
+ binarySearch_r16 = -1
+ RETURN
+ END IF
+
+ i = 1
+ left = 1
+ right = n
+ DO WHILE (left <= right .AND. i<=n+2)
+ i = i + 1
+ center = CEILING((left+right)/2.0)
+ IF (ABS(key - array(center)) < 10.0_rprec16*EPSILON(key)) THEN
+ binarySearch_r16 = center
+ RETURN
+ ELSE IF (key < array(center)) THEN
+ right = center - 1
+ ELSE IF (key > array(center)) THEN
+ left = center + 1
+ END IF
+ END DO
+
+ IF (i == n+2) THEN
+ error = " -> sort : binarySearch : Search stuck in a loop." // TRIM(error)
+ END IF
+
+ ! The key could not be found in the array.
+ ! Return a negative index:
+ binarySearch_r16 = -1
+
+ END FUNCTION binarySearch_r16
+
+
+
+
+
+ !! *Description*:
+ !!
+ !! Binary search routine. Returns the position of the search key in
+ !! the one-dimensional input array. If the search key is not found,
+ !! it returns -1.
+ !!
+ !! As a prerequisite, the array which is to be scanned has to be sorted
+ !! in ascending order. The algorithm searches for the search
+ !! key by repeatedly dividing the search interval in half. Initially
+ !! the interval covers the whole array. If the item in the middle of
+ !! the interval is larger than the key, the interval is narrowed to
+ !! the lower half. Otherwise it is narrowed to the upper half. The
+ !! procedure is continued until the value is found, or the interval
+ !! is empty.
+ !!
+ INTEGER FUNCTION binarySearch_ch(key, array, error)
+
+ ! The input array needs to be sorted in ascending order.
+
+ IMPLICIT NONE
+ CHARACTER(len=*), INTENT(in) :: key
+ CHARACTER(len=*), DIMENSION(:), INTENT(in) :: array
+ CHARACTER(len=*), INTENT(inout) :: error
+
+ INTEGER :: n, left, right, center, i
+
+ n = SIZE(array, dim=1)
+ ! Return immediately
+ ! - if the length of the array is zero:
+ IF (n == 0) THEN
+ binarySearch_ch = -1
+ RETURN
+ END IF
+ ! - if the key (value to be searched for) is smaller or
+ ! larger than the minimum or maximum values of
+ ! the array:
+ IF (key < array(1) .OR. key > array(n)) THEN
+ binarySearch_ch = -1
+ RETURN
+ END IF
+
+ i = 1
+ left = 1
+ right = n
+ DO WHILE (left <= right .AND. i<=n+2)
+ i = i + 1
+ center = CEILING((left+right)/2.0)
+ IF (key == array(center)) THEN
+ binarySearch_ch = center
+ RETURN
+ ELSE IF (key < array(center)) THEN
+ right = center - 1
+ ELSE IF (key > array(center)) THEN
+ left = center + 1
+ END IF
+ END DO
+
+ IF (i == n+2) THEN
+ error = " -> sort : binarySearch : Search stuck in a loop." // TRIM(error)
+ END IF
+
+ ! The key could not be found in the array.
+ ! Return a negative index:
+ binarySearch_ch = -1
+
+ END FUNCTION binarySearch_ch
+
+
+
+
+
+ !! *Description*:
+ !!
+ !! Binary search routine. Returns the position of the search key in
+ !! the one-dimensional input array. If the search key is not found,
+ !! it returns -1.
+ !!
+ !! As a prerequisite, the array which is to be scanned has to be sorted
+ !! in ascending order. The algorithm searches for the search
+ !! key by repeatedly dividing the search interval in half. Initially
+ !! the interval covers the whole array. If the item in the middle of
+ !! the interval is larger than the key, the interval is narrowed to
+ !! the lower half. Otherwise it is narrowed to the upper half. The
+ !! procedure is continued until the value is found, or the interval
+ !! is empty.
+ !!
+ INTEGER FUNCTION binarySearch_ch_index(key, array, indx, error)
+
+ ! The input array needs to be sorted in ascending order.
+
+ IMPLICIT NONE
+ CHARACTER(len=*), INTENT(in) :: key
+ CHARACTER(len=*), DIMENSION(:), INTENT(in) :: array
+ INTEGER, DIMENSION(:), INTENT(in) :: indx
+ CHARACTER(len=*), INTENT(inout) :: error
+ INTEGER :: n, left, right, center, i
+
+ n = SIZE(array, dim=1)
+ ! Return immediately
+ ! - if the length of the array is zero:
+ IF (n == 0) THEN
+ binarySearch_ch_index = -1
+ RETURN
+ END IF
+ ! - if the key (value to be searched for) is smaller or
+ ! larger than the minimum or maximum values of
+ ! the array:
+ IF (key < array(indx(1)) .OR. key > array(indx(n))) THEN
+ binarySearch_ch_index = -1
+ RETURN
+ END IF
+
+ i = 1
+ left = 1
+ right = n
+ DO WHILE (left <= right .AND. i<=n+2)
+ i = i + 1
+ center = CEILING((left+right)/2.0)
+ IF (key == array(indx(center))) THEN
+ binarySearch_ch_index = indx(center)
+ RETURN
+ ELSE IF (key < array(indx(center))) THEN
+ right = center - 1
+ ELSE IF (key > array(indx(center))) THEN
+ left = center + 1
+ END IF
+ END DO
+
+ IF (i == n+2) THEN
+ error = " -> sort : binarySearch : Search stuck in a loop." // TRIM(error)
+ END IF
+
+ ! The key could not be found in the array.
+ ! Return a negative index:
+ binarySearch_ch_index = -1
+
+ END FUNCTION binarySearch_ch_index
+
+
+
+
+
+ !! *Description*:
+ !!
+ !! Binary search routine. Returns the position where the value
+ !! should be found (starting from left) in the one-dimensional input
+ !! array, if the array is sorted in ascending order.
+ !!
+ !! As a prerequisite, the array which is to be scanned has to be sorted
+ !! in ascending order. The algorithm searches for the value by
+ !! repeatedly dividing the search interval in half. Initially
+ !! the interval covers the whole array. If the item in the middle of
+ !! the interval is larger than the value, the interval is narrowed to
+ !! the lower half. Otherwise it is narrowed to the upper half. The
+ !! procedure is continued until the interval is empty.
+ !!
+ INTEGER FUNCTION findLocation_r8(VALUE, array)
+
+ ! The input array needs to be sorted in ascending order.
+
+ IMPLICIT NONE
+ REAL(rprec8), INTENT(in) :: VALUE
+ REAL(rprec8), DIMENSION(:), INTENT(in) :: array
+ INTEGER :: n, left, right, center
+
+ n = SIZE(array)
+ ! Return immediately, if the value is smaller or larger than the
+ ! minimum or maximum values of the array:
+ IF (VALUE < array(1)) THEN
+ findLocation_r8 = 1
+ RETURN
+ ELSE IF (VALUE >= array(n)) THEN
+ findLocation_r8 = n+1
+ RETURN
+ END IF
+
+ left = 1
+ right = n
+ center = CEILING((left+right)/2.0)
+ DO WHILE (right-left > 1)
+ center = CEILING((left+right)/2.0)
+ IF (VALUE < array(center)) THEN
+ right = center
+ ELSE IF (VALUE >= array(center)) THEN
+ left = center
+ END IF
+ END DO
+ IF (VALUE < array(center)) THEN
+ findLocation_r8 = center
+ ELSE
+ findLocation_r8 = center + 1
+ END IF
+
+ END FUNCTION findLocation_r8
+
+
+
+
+
+ !! *Description*:
+ !!
+ !! Binary search routine. Returns the position where the value
+ !! should be found (starting from left) in the one-dimensional input
+ !! array, given an index array providing the ascending order of the
+ !! array elements.
+ !!
+ !! As a prerequisite, the array which is to be scanned has to be sorted
+ !! in ascending order. The algorithm searches for the value by
+ !! repeatedly dividing the search interval in half. Initially
+ !! the interval covers the whole array. If the item in the middle of
+ !! the interval is larger than the value, the interval is narrowed to
+ !! the lower half. Otherwise it is narrowed to the upper half. The
+ !! procedure is continued until the interval is empty.
+ !!
+ INTEGER FUNCTION findLocation_r8_indx(VALUE, array, indx_array)
+
+ ! The input array needs to be sorted in ascending order.
+
+ IMPLICIT NONE
+ INTEGER, PARAMETER :: prec = 8
+ REAL(rprec8), INTENT(in) :: VALUE
+ REAL(rprec8), DIMENSION(:), INTENT(in) :: array
+ INTEGER, DIMENSION(:), INTENT(in) :: indx_array
+ INTEGER :: n, left, right, center
+
+ n = SIZE(array)
+ ! Return immediately, if the value is smaller or larger than the
+ ! minimum or maximum values of the array:
+ IF (VALUE < array(indx_array(1))) THEN
+ findLocation_r8_indx = 1
+ RETURN
+ ELSE IF (VALUE >= array(indx_array(n))) THEN
+ findLocation_r8_indx = n+1
+ RETURN
+ END IF
+
+ left = 1
+ right = n
+ center = CEILING((left+right)/2.0)
+ DO WHILE (right-left > 1)
+ center = CEILING((left+right)/2.0)
+ IF (VALUE < array(indx_array(center))) THEN
+ right = center
+ ELSE IF (VALUE >= array(indx_array(center))) THEN
+ left = center
+ END IF
+ END DO
+ IF (VALUE < array(indx_array(center))) THEN
+ findLocation_r8_indx = center
+ ELSE
+ findLocation_r8_indx = center + 1
+ END IF
+
+ END FUNCTION findLocation_r8_indx
+
+
+
+
+
+ !! *Description*:
+ !!
+ !! Binary search routine. Returns the position where the value
+ !! should be found (starting from left) in the one-dimensional input
+ !! array, if the array is sorted in ascending order.
+ !!
+ !! As a prerequisite, the array which is to be scanned has to be sorted
+ !! in ascending order. The algorithm searches for the value by
+ !! repeatedly dividing the search interval in half. Initially
+ !! the interval covers the whole array. If the item in the middle of
+ !! the interval is larger than the value, the interval is narrowed to
+ !! the lower half. Otherwise it is narrowed to the upper half. The
+ !! procedure is continued until the interval is empty.
+ !!
+ INTEGER FUNCTION findLocation_r16(VALUE, array)
+
+ ! The input array needs to be sorted in ascending order.
+
+ IMPLICIT NONE
+ REAL(rprec16), INTENT(in) :: VALUE
+ REAL(rprec16), DIMENSION(:), INTENT(in) :: array
+ INTEGER :: n, left, right, center
+
+ n = SIZE(array)
+ ! Return immediately, if the value is smaller or larger than the
+ ! minimum or maximum values of the array:
+ IF (VALUE < array(1)) THEN
+ findLocation_r16 = 1
+ RETURN
+ ELSE IF (VALUE >= array(n)) THEN
+ findLocation_r16 = n+1
+ RETURN
+ END IF
+
+ left = 1
+ right = n
+ center = CEILING((left+right)/2.0)
+ DO WHILE (right-left > 1)
+ center = CEILING((left+right)/2.0)
+ IF (VALUE < array(center)) THEN
+ right = center
+ ELSE IF (VALUE >= array(center)) THEN
+ left = center
+ END IF
+ END DO
+ IF (VALUE < array(center)) THEN
+ findLocation_r16 = center
+ ELSE
+ findLocation_r16 = center + 1
+ END IF
+
+ END FUNCTION findLocation_r16
+
+
+
+
+
+END MODULE sort
Index: trunk/mops/oorb/modules/statistics.f90
===================================================================
--- trunk/mops/oorb/modules/statistics.f90 (revision 34646)
+++ trunk/mops/oorb/modules/statistics.f90 (revision 34646)
@@ -0,0 +1,621 @@
+!====================================================================!
+! !
+! Copyright 2002,2003,2004,2005,2006,2007,2008,2009,2010,2011 !
+! Mikael Granvik, Jenni Virtanen, Karri Muinonen, Teemu Laakso, !
+! Dagmara Oszkiewicz !
+! !
+! This file is part of OpenOrb. !
+! !
+! OpenOrb 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. !
+! !
+! OpenOrb 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 OpenOrb. If not, see . !
+! !
+!====================================================================!
+!
+!! *Module*description*:
+!!
+!! Tools for statistics.
+!!
+!! @author MG
+!! @version 2011-11-30
+!!
+MODULE statistics
+
+ USE parameters
+ USE utilities
+ USE sort
+
+ IMPLICIT NONE
+
+ PRIVATE :: chi_square_blockdiag
+ PRIVATE :: moments_r8
+ PRIVATE :: confidence_limits_hist_r8
+ PRIVATE :: confidence_limits_sample_r8
+
+ INTERFACE chi_square
+ MODULE PROCEDURE chi_square_blockdiag
+ END INTERFACE chi_square
+
+ INTERFACE moments
+ MODULE PROCEDURE moments_r8
+ END INTERFACE moments
+
+ INTERFACE confidence_limits
+ MODULE PROCEDURE confidence_limits_hist_r8
+ MODULE PROCEDURE confidence_limits_sample_r8
+ END INTERFACE confidence_limits
+
+CONTAINS
+
+
+
+
+ !! *Description*:
+ !!
+ !! Tested.
+ !!
+ !! @author MG
+ !! @version 2009-10-13
+ !!
+ REAL(rprec8) FUNCTION chi_square_blockdiag(residuals, information_matrix, mask, errstr)
+
+ IMPLICIT NONE
+ REAL(rprec8), DIMENSION(:,:), INTENT(in) :: residuals
+ REAL(rprec8), DIMENSION(:,:,:), INTENT(in) :: information_matrix
+ LOGICAL, DIMENSION(:,:), INTENT(in), OPTIONAL :: mask
+ CHARACTER(len=*), INTENT(inout) :: errstr
+
+ REAL(rprec8), DIMENSION(:,:), ALLOCATABLE :: residuals_
+ REAL(rprec8), DIMENSION(1) :: chi_square_blockdiag_
+ INTEGER :: i, nobs, nmulti, err
+
+ chi_square_blockdiag = 0.0_rprec8
+ chi_square_blockdiag_ = 0.0_rprec8
+ nobs = SIZE(residuals,dim=1)
+ nmulti = SIZE(residuals,dim=2)
+
+ IF (SIZE(information_matrix,dim=1) /= nobs .OR. &
+ SIZE(information_matrix,dim=2) /= nmulti .OR. &
+ SIZE(information_matrix,dim=3) /= nmulti) THEN
+ errstr = " -> statistics : chi_square : Shape of input matrices do not conform." // &
+ TRIM(errstr)
+ RETURN
+ END IF
+
+ ALLOCATE(residuals_(nobs,nmulti), stat=err)
+ IF (err /= 0) THEN
+ errstr = " -> statistics : chi_square : Could not allocate memory." // &
+ TRIM(errstr)
+ RETURN
+ END IF
+ residuals_ = residuals
+ IF (PRESENT(mask)) THEN
+ WHERE (.NOT. mask)
+ residuals_ = 0.0_rprec8
+ END WHERE
+ END IF
+ DO i=1,nobs
+ chi_square_blockdiag_ = chi_square_blockdiag_ + &
+ MATMUL(MATMUL(residuals_(i,1:nmulti), &
+ information_matrix(i,1:nmulti,1:nmulti)), &
+ TRANSPOSE(residuals_(i:i,1:nmulti)))
+ END DO
+ chi_square_blockdiag = chi_square_blockdiag_(1)
+ DEALLOCATE(residuals_, stat=err)
+ IF (err /= 0) THEN
+ WRITE(0,*) "chi_square" // &
+ "Could not deallocate memory."
+ RETURN
+ END IF
+
+ END FUNCTION chi_square_blockdiag
+
+
+
+
+
+ !! *Description*:
+ !!
+ !! Computes a histogram (histo) for given data (indata) either as
+ !! number density (without pdf) or from pdf (with pdf).
+ !!
+ SUBROUTINE histogram(indata, histo, xmin_in, xmax_in, pdf, xmax, dx)
+
+ IMPLICIT NONE
+ REAL(rprec8), DIMENSION(:), INTENT(in) :: indata
+ REAL(rprec8), DIMENSION(:,:), INTENT(out) :: histo
+ REAL(rprec8), INTENT(in), OPTIONAL :: xmin_in
+ REAL(rprec8), INTENT(in), OPTIONAL :: xmax_in
+ REAL(rprec8), DIMENSION(SIZE(indata)), INTENT(in), OPTIONAL :: pdf
+ REAL(rprec8), INTENT(out), OPTIONAL :: xmax
+ REAL(rprec8), INTENT(out), OPTIONAL :: dx
+
+ REAL(rprec8), DIMENSION(SIZE(indata)) :: pdf_
+ REAL(rprec8) :: dx_, x_min, x_max
+ INTEGER :: ngrid, nvalue, i, j
+
+ ngrid = SIZE(histo,dim=1)
+ nvalue = SIZE(indata)
+ IF (PRESENT(xmin_in)) THEN
+ x_min = xmin_in
+ ELSE
+ x_min = MINVAL(indata)
+ END IF
+ IF (PRESENT(xmax_in)) THEN
+ x_max = xmax_in
+ ELSE
+ x_max = MAXVAL(indata)
+ END IF
+ dx_ = (x_max-x_min) / ngrid
+ DO i=1, ngrid
+ histo(i,1) = x_min + 0.5_rprec8*dx_ + dx_*(i-1)
+ END DO
+
+ IF (PRESENT(pdf)) THEN
+ ! Use given pdf the sum of which is normalized to unity:
+ pdf_ = pdf/SUM(pdf)
+ ELSE
+ ! Use number density:
+ pdf_ = 1.0_rprec8
+ END IF
+
+ histo(:,2) = 0.0_rprec8
+ DO i=1,nvalue
+ DO j=1,ngrid
+ IF (ABS(indata(i)-histo(j,1)) < 0.5_rprec8*dx_) THEN
+ histo(j,2) = histo(j,2) + pdf_(i)
+ EXIT
+ END IF
+ END DO
+ END DO
+ IF (PRESENT(xmax)) THEN
+ xmax = histo(MAXLOC(histo(:,2),dim=1),1)
+ END IF
+ IF (PRESENT(dx)) THEN
+ dx = dx_
+ END IF
+
+ END SUBROUTINE histogram
+
+
+
+
+
+ !! *Description*:
+ !!
+ !! Computes various statistical quantities for a given data set.
+ !! Current output: arithmetic mean, standard deviation, skewness,
+ !! and kurtosis.
+ !!
+ SUBROUTINE moments_r8(indata, pdf, mask, mean, std_dev, skew, kurt, errstr)
+
+ IMPLICIT NONE
+ REAL(rprec8), DIMENSION(:), INTENT(in) :: indata
+ REAL(rprec8), DIMENSION(:), INTENT(in), OPTIONAL :: pdf
+ LOGICAL, DIMENSION(:), OPTIONAL, INTENT(in) :: mask
+ REAL(rprec8), OPTIONAL, INTENT(out) :: mean, std_dev, skew, kurt
+ CHARACTER(len=*), INTENT(inout) :: errstr
+
+ REAL(rprec8), DIMENSION(:), ALLOCATABLE :: pdf_
+ REAL(rprec8) :: mean_, std_dev_
+ INTEGER :: ndata, err
+ LOGICAL, DIMENSION(:), ALLOCATABLE :: mask_
+
+ ndata = SIZE(indata)
+ ALLOCATE(mask_(ndata), pdf_(ndata), stat=err)
+ IF (err /= 0) THEN
+ RETURN
+ END IF
+ mask_ = .TRUE.
+ IF (PRESENT(mask)) THEN
+ mask_ = mask
+ END IF
+ ndata = COUNT(mask_)
+ IF (PRESENT(pdf)) THEN
+ ! Make sure the distribution is normalized:
+ pdf_ = pdf/SUM(pdf, mask=mask_)
+ END IF
+
+ ! Lowest moments:
+ ! Mean:
+ IF (PRESENT(pdf)) THEN
+ mean_ = SUM(indata*pdf_, mask=mask_)
+ ELSE
+ mean_ = SUM(indata, mask=mask_)/ndata
+ END IF
+ IF (PRESENT(mean)) THEN
+ mean = mean_
+ END IF
+
+ ! Standard deviation:
+ IF (PRESENT(std_dev) .OR. PRESENT(skew) .OR. PRESENT(kurt)) THEN
+ IF (PRESENT(pdf)) THEN
+ std_dev_ = SQRT(SUM(((indata - &
+ indata(MAXLOC(pdf_,dim=1)))**2.0_rprec8)*pdf_, &
+ mask=mask_))
+ ELSE
+ std_dev_ = SQRT(SUM(((indata - mean_)**2.0_rprec8), &
+ mask=mask_) / (ndata-1))
+ END IF
+ IF (PRESENT(std_dev)) THEN
+ std_dev = std_dev_
+ END IF
+ END IF
+
+ ! Skewness:
+ IF (PRESENT(skew)) THEN
+ IF (PRESENT(pdf)) THEN
+ skew = SUM(((indata - indata(MAXLOC(pdf_,dim=1)))**3.0_rprec8)*pdf_, &
+ mask=mask_) / std_dev_
+ ELSE
+ skew = SUM(((indata - mean_)**3.0_rprec8), &
+ mask=mask_) / (std_dev_*ndata)
+ END IF
+ END IF
+
+ ! Kurtosis:
+ IF (PRESENT(kurt)) THEN
+ IF (PRESENT(pdf)) THEN
+ kurt = SUM(((indata - indata(MAXLOC(pdf_,dim=1)))**4.0_rprec8)*pdf_, &
+ mask=mask_) / std_dev_
+ ELSE
+ kurt = SUM(((indata - mean_)**4.0_rprec8), &
+ mask=mask_) / (std_dev_*ndata)
+ END IF
+ END IF
+
+ !r = sum((data_set-mean_)*(data_set)
+
+ DEALLOCATE(pdf_, mask_, stat=err)
+ IF (err /= 0) THEN
+ DEALLOCATE(pdf_, stat=err)
+ DEALLOCATE(mask_, stat=err)
+ RETURN
+ END IF
+
+ END SUBROUTINE moments_r8
+
+
+
+
+
+ !! *Description*:
+ !!
+ !! This routine calculates the end points of the confidence interval
+ !! (or credible interval) by incorporating bins of a histogram until
+ !! the sum of normalized weights is larger than the requested
+ !! probability mass.
+ !!
+ SUBROUTINE confidence_limits_hist_r8(indata, pdf, nhist, &
+ mask, probability_mass, peak, bounds, errstr)
+
+ IMPLICIT NONE
+ REAL(rprec8), DIMENSION(:), INTENT(in) :: indata
+ REAL(rprec8), DIMENSION(:), INTENT(in) :: pdf
+ INTEGER, INTENT(in) :: nhist
+ REAL(rprec8), INTENT(in), OPTIONAL :: probability_mass
+ LOGICAL, DIMENSION(:), OPTIONAL, INTENT(in) :: mask
+ REAL(rprec8), OPTIONAL, INTENT(out) :: peak
+ REAL(rprec8), DIMENSION(2), OPTIONAL, INTENT(out) :: bounds
+ CHARACTER(len=*), INTENT(inout) :: errstr
+
+ REAL(rprec8), DIMENSION(:,:), ALLOCATABLE :: histo, histo_
+ REAL(rprec8) :: probability_mass_
+ INTEGER :: ndata, err, imax, ilo, ihi
+ LOGICAL, DIMENSION(:), ALLOCATABLE :: mask_
+
+ ndata = SIZE(indata)
+ ALLOCATE(mask_(ndata), histo(nhist,2), histo_(nhist,2), stat=err)
+ IF (err /= 0) THEN
+ errstr = " -> statistics : confidence_limits : Could not allocate memory." // &
+ TRIM(errstr)
+ DEALLOCATE(histo, stat=err)
+ DEALLOCATE(mask_, stat=err)
+ RETURN
+ END IF
+ mask_ = .TRUE.
+ IF (PRESENT(mask)) THEN
+ mask_ = mask
+ ELSE
+ mask_ = .TRUE.
+ END IF
+
+ IF (PRESENT(bounds) .AND. .NOT.PRESENT(probability_mass)) THEN
+ errstr = " -> statistics : confidence_limits : Probability mass not given." // &
+ TRIM(errstr)
+ DEALLOCATE(histo, stat=err)
+ DEALLOCATE(mask_, stat=err)
+ RETURN
+ END IF
+
+ ! Produce histogram based on pdf:
+ CALL histogram(indata, histo, pdf=pdf)
+ IF (PRESENT(peak)) THEN
+ ! ML solution
+ imax = imaxloc(histo(:,2))
+ peak = histo(imax,1)
+ END IF
+
+ IF (PRESENT(bounds)) THEN
+ histo(:,2) = histo(:,2)/SUM(histo(:,2))
+ histo_ = histo
+ bounds(1) = HUGE(bounds(1))
+ bounds(2) = -HUGE(bounds(2))
+ ilo = nhist
+ ihi = 1
+ probability_mass_ = 0.0_rprec8
+ DO WHILE (probability_mass_ < probability_mass)
+ imax = imaxloc(histo_(:,2))
+ IF (imax < ilo) THEN
+ ilo = imax
+ END IF
+ IF (imax > ihi) THEN
+ ihi = imax
+ END IF
+ probability_mass_ = SUM(histo(ilo:ihi,2))
+ IF (histo(imax,1) < bounds(1)) THEN
+ bounds(1) = histo(imax,1)
+ END IF
+ IF (histo(imax,1) > bounds(2)) THEN
+ bounds(2) = histo(imax,1)
+ END IF
+ histo_(imax,2) = 0.0_rprec8
+ END DO
+ END IF
+
+ DEALLOCATE(histo, histo_, mask_, stat=err)
+ IF (err /= 0) THEN
+ errstr = " -> statistics : confidence_limits : Could not deallocate memory." // &
+ TRIM(errstr)
+ DEALLOCATE(histo, stat=err)
+ DEALLOCATE(histo_, stat=err)
+ DEALLOCATE(mask_, stat=err)
+ RETURN
+ END IF
+
+ END SUBROUTINE confidence_limits_hist_r8
+
+
+
+
+
+ !! *Description*:
+ !!
+ !! This routine calculates the end points of the confidence interval
+ !! (or credible interval) by descending from the ML solution until
+ !! the sum of normalized weights is larger than the requested
+ !! probability mass.
+ !!
+ SUBROUTINE confidence_limits_sample_r8(indata, pdf, mask, &
+ probability_mass, peak, bounds, errstr)
+
+ IMPLICIT NONE
+ REAL(rprec8), DIMENSION(:), INTENT(in) :: indata
+ REAL(rprec8), DIMENSION(:), INTENT(in) :: pdf
+ REAL(rprec8), INTENT(in), OPTIONAL :: probability_mass
+ LOGICAL, DIMENSION(:), OPTIONAL, INTENT(in) :: mask
+ REAL(rprec8), OPTIONAL, INTENT(out) :: peak
+ REAL(rprec8), DIMENSION(2), OPTIONAL, INTENT(out) :: bounds
+ CHARACTER(len=*), INTENT(inout) :: errstr
+
+ REAL(rprec8), DIMENSION(:), ALLOCATABLE :: pdf_
+ REAL(rprec8) :: probability_mass_
+ INTEGER, DIMENSION(:), ALLOCATABLE :: indx_arr
+ INTEGER :: ndata, imax, i, err
+ LOGICAL, DIMENSION(:), ALLOCATABLE :: mask_
+
+ ndata = SIZE(indata)
+ IF (ndata /= SIZE(pdf)) THEN
+ errstr = " -> statistics : confidence_limits : Size of vectors does not conform." // &
+ TRIM(errstr)
+ RETURN
+ END IF
+ ALLOCATE(pdf_(ndata), mask_(ndata), stat=err)
+ IF (err /= 0) THEN
+ errstr = " -> statistics : confidence_limits : Could not allocate memory." // &
+ TRIM(errstr)
+ DEALLOCATE(pdf_, stat=err)
+ DEALLOCATE(mask_, stat=err)
+ RETURN
+ END IF
+ mask_ = .TRUE.
+ IF (PRESENT(mask)) THEN
+ IF (ndata /= SIZE(mask)) THEN
+ errstr = " -> statistics : confidence_limits : Size of mask does not conform with data." // &
+ TRIM(errstr)
+ DEALLOCATE(pdf_, stat=err)
+ DEALLOCATE(mask_, stat=err)
+ RETURN
+ END IF
+ mask_ = mask
+ ELSE
+ mask_ = .TRUE.
+ END IF
+ pdf_ = pdf
+ WHERE (.NOT.mask_)
+ pdf_ = 0.0_rprec8
+ END WHERE
+ pdf_ = pdf_/SUM(pdf_)
+
+ IF (PRESENT(bounds) .AND. .NOT.PRESENT(probability_mass)) THEN
+ errstr = " -> statistics : confidence_limits : Probability mass not given." // &
+ TRIM(errstr)
+ DEALLOCATE(pdf_, stat=err)
+ DEALLOCATE(mask_, stat=err)
+ RETURN
+ END IF
+
+ IF (PRESENT(peak)) THEN
+ ! Find peak of phase angle histogram:
+ imax = imaxloc(pdf_)
+ peak = indata(imax)
+ END IF
+ IF (PRESENT(bounds)) THEN
+ ALLOCATE(indx_arr(ndata), stat=err)
+ IF (err /= 0) THEN
+ errstr = " -> statistics : confidence_limits : Caould not allocate memory." // &
+ TRIM(errstr)
+ DEALLOCATE(pdf_, stat=err)
+ DEALLOCATE(mask_, stat=err)
+ DEALLOCATE(indx_arr, stat=err)
+ RETURN
+ END IF
+ CALL quicksort(pdf_, indx_arr, errstr)
+ IF (LEN_TRIM(errstr) /= 0) THEN
+ errstr = " -> statistics : confidence_limits : ." // &
+ TRIM(errstr)
+ DEALLOCATE(pdf_, stat=err)
+ DEALLOCATE(mask_, stat=err)
+ DEALLOCATE(indx_arr, stat=err)
+ RETURN
+ END IF
+ pdf_ = pdf_/SUM(pdf_)
+ bounds(1) = HUGE(bounds(1))
+ bounds(2) = -HUGE(bounds(2))
+ probability_mass_ = 0.0_rprec8
+ DO i=ndata,1,-1
+ IF (mask_(indx_arr(i))) THEN
+ probability_mass_ = probability_mass_ + pdf_(indx_arr(i))
+ IF (indata(indx_arr(i)) < bounds(1)) THEN
+ bounds(1) = indata(indx_arr(i))
+ ELSE IF (indata(indx_arr(i)) > bounds(2)) THEN
+ bounds(2) = indata(indx_arr(i))
+ END IF
+ IF (probability_mass_ >= probability_mass) THEN
+ EXIT
+ END IF
+ END IF
+ END DO
+ DEALLOCATE(indx_arr, stat=err)
+ IF (err /= 0) THEN
+ errstr = " -> statistics : confidence_limits : Could not deallocate memory (1)." // &
+ TRIM(errstr)
+ DEALLOCATE(pdf_, stat=err)
+ DEALLOCATE(mask_, stat=err)
+ DEALLOCATE(indx_arr, stat=err)
+ RETURN
+ END IF
+ END IF
+
+ DEALLOCATE(pdf_, mask_, stat=err)
+ IF (err /= 0) THEN
+ errstr = " -> statistics : confidence_limits : Could not deallocate memory (2)." // &
+ TRIM(errstr)
+ DEALLOCATE(pdf_, stat=err)
+ DEALLOCATE(mask_, stat=err)
+ RETURN
+ END IF
+
+ END SUBROUTINE confidence_limits_sample_r8
+
+
+
+
+
+ SUBROUTINE credible_region(pdf_arr, probability_mass, indx_arr, errstr, repetition_arr)
+
+ IMPLICIT NONE
+ REAL(rprec8), DIMENSION(:), INTENT(in) :: pdf_arr
+ REAL(rprec8), INTENT(in) :: probability_mass
+ INTEGER, DIMENSION(:), INTENT(out) :: indx_arr
+ CHARACTER(len=*), INTENT(inout) :: errstr
+ INTEGER, DIMENSION(:), INTENT(in), OPTIONAL :: repetition_arr
+
+ REAL(rprec8), DIMENSION(:), ALLOCATABLE :: pdf_arr_
+ REAL(rprec8) :: probability_mass_
+ INTEGER :: i, j, irepet, nrepet
+
+ ! Sort the pdf in ascending order:
+ CALL quickSort(pdf_arr, indx_arr, errstr)
+ IF (LEN_TRIM(errstr) /= 0) THEN
+ errstr = " -> statistics : credible_region : TRACE BACK." // &
+ TRIM(errstr)
+ RETURN
+ END IF
+ ! Start from the largest pdf value
+ i = SIZE(pdf_arr)
+ IF (PRESENT(repetition_arr)) THEN
+ ! MCMC
+ ! Which number of repetitions corresponds to the wanted
+ ! probability mass?
+ nrepet = CEILING(SUM(repetition_arr)*probability_mass)
+ ! Add distinct sampling points until reaching the desired
+ ! number of (typically non-unique) sample points:
+ irepet = 0
+ DO WHILE (irepet < nrepet)
+ irepet = irepet + repetition_arr(indx_arr(i))
+ i = i - 1
+ END DO
+ ELSE
+ ! MC
+ ALLOCATE(pdf_arr_(SIZE(pdf_arr)))
+ ! Normalize the pdf distribution
+ pdf_arr_ = pdf_arr/SUM(pdf_arr)
+ ! Add sample points until the desired probability mass is
+ ! reached:
+ probability_mass_ = 0.0_rprec8
+ DO WHILE (probability_mass_ < probability_mass)
+ probability_mass_ = probability_mass_ + pdf_arr_(indx_arr(i))
+ i = i - 1
+ END DO
+ DEALLOCATE(pdf_arr_)
+ END IF
+ ! Fill the resulting index array with negative values for the
+ ! sample points that do not fit within the desired probability
+ ! mass:
+ DO j=i,1,-1
+ indx_arr(j) = -1
+ END DO
+
+ END SUBROUTINE credible_region
+
+
+
+
+
+ SUBROUTINE population_covariance(indata, covariance, mean, mask)
+
+ IMPLICIT NONE
+ REAL(rprec8), DIMENSION(:,:), INTENT(in) :: indata
+ REAL(rprec8), DIMENSION(:,:), INTENT(out) :: covariance
+ REAL(rprec8), DIMENSION(:), INTENT(out) :: mean
+ LOGICAL, DIMENSION(:), INTENT(in), OPTIONAL :: mask
+
+ INTEGER :: i, j
+ LOGICAL,DIMENSION(SIZE(indata,dim=2)) :: mask_
+
+ IF (PRESENT(mask)) THEN
+ mask_ = mask
+ covariance = 0.0_rprec8
+ ELSE
+ mask_ = .TRUE.
+ END IF
+
+ DO i=1,SIZE(indata,dim=2)
+ ! Compute mean for variable i
+ mean(i) = SUM(indata(:,i))/SIZE(indata,dim=1)
+ ! Compute elements of covariance matrix from 1,1 to i,i
+ DO j=1,i
+ IF (mask_(i) .AND. mask_(j)) THEN
+ covariance(i,j) = SUM((indata(:,i)-mean(i)) * (indata(:,j)-mean(j))) / &
+ SIZE(indata,dim=1)
+ covariance(j,i) = covariance(i,j)
+ END IF
+ END DO
+ END DO
+
+ END SUBROUTINE population_covariance
+
+
+
+
+END MODULE statistics
Index: trunk/mops/oorb/modules/utilities.f90
===================================================================
--- trunk/mops/oorb/modules/utilities.f90 (revision 34646)
+++ trunk/mops/oorb/modules/utilities.f90 (revision 34646)
@@ -0,0 +1,1609 @@
+!====================================================================!
+! !
+! Copyright 2002,2003,2004,2005,2006,2007,2008,2009,2010,2011 !
+! Mikael Granvik, Jenni Virtanen, Karri Muinonen, Teemu Laakso, !
+! Dagmara Oszkiewicz !
+! !
+! This file is part of OpenOrb. !
+! !
+! OpenOrb 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. !
+! !
+! OpenOrb 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 OpenOrb. If not, see . !
+! !
+!====================================================================!
+!
+!! *Module*description*:
+!!
+!! Independent utilities.
+!!
+!! @author MG
+!! @version 2010-01-26
+!!
+MODULE utilities
+
+ USE parameters
+
+ IMPLICIT NONE
+
+ PRIVATE :: integerToArray_ri8
+ PRIVATE :: arrayToInteger_r8i8
+ PRIVATE :: arrayToReal_r8r16
+ PRIVATE :: realToArray_r16r8
+ PRIVATE :: reallocate_ch_1
+ PRIVATE :: reallocate_ch_2
+ PRIVATE :: reallocate_r4_1
+ PRIVATE :: reallocate_r4_2
+ PRIVATE :: reallocate_r8_1
+ PRIVATE :: reallocate_r8_2
+ PRIVATE :: reallocate_r8_3
+ PRIVATE :: reallocate_r16_1
+ PRIVATE :: reallocate_r16_2
+ PRIVATE :: reallocate_i1_1
+ PRIVATE :: reallocate_i4_1
+ PRIVATE :: reallocate_i4_2
+ PRIVATE :: reallocate_i8_1
+ PRIVATE :: reallocate_i8_2
+ PRIVATE :: reallocate_l_1
+ PRIVATE :: reallocate_l_2
+ PRIVATE :: secToHMS_r4
+ PRIVATE :: secToHMS_r8
+ PRIVATE :: toInt_4
+ PRIVATE :: toReal_8
+ PRIVATE :: toReal_16
+ PRIVATE :: toString_i4
+ PRIVATE :: toString_i8
+ PRIVATE :: toString_r4
+ PRIVATE :: toString_r8
+
+ INTERFACE arrayToInteger
+ MODULE PROCEDURE arrayToInteger_r8i8
+ END INTERFACE arrayToInteger
+
+ INTERFACE arrayToReal
+ MODULE PROCEDURE arrayToReal_r8r16
+ END INTERFACE arrayToReal
+
+ INTERFACE integerToArray
+ MODULE PROCEDURE integerToArray_ri8
+ END INTERFACE integerToArray
+
+ INTERFACE imaxloc
+ MODULE PROCEDURE imaxloc_i4
+ MODULE PROCEDURE imaxloc_i8
+ MODULE PROCEDURE imaxloc_r4
+ MODULE PROCEDURE imaxloc_r8
+ MODULE PROCEDURE imaxloc_r16
+ END INTERFACE imaxloc
+
+ INTERFACE iminloc
+ MODULE PROCEDURE iminloc_i4
+ MODULE PROCEDURE iminloc_i8
+ MODULE PROCEDURE iminloc_r4
+ MODULE PROCEDURE iminloc_r8
+ MODULE PROCEDURE iminloc_r16
+ END INTERFACE iminloc
+
+ INTERFACE realToArray
+ MODULE PROCEDURE realToArray_r16r8
+ END INTERFACE realToArray
+
+ INTERFACE reallocate
+ MODULE PROCEDURE reallocate_ch_1
+ MODULE PROCEDURE reallocate_ch_2
+ MODULE PROCEDURE reallocate_r4_1
+ MODULE PROCEDURE reallocate_r4_2
+ MODULE PROCEDURE reallocate_r8_1
+ MODULE PROCEDURE reallocate_r8_2
+ MODULE PROCEDURE reallocate_r8_3
+ MODULE PROCEDURE reallocate_r16_1
+ MODULE PROCEDURE reallocate_r16_2
+ MODULE PROCEDURE reallocate_i1_1
+ MODULE PROCEDURE reallocate_i4_1
+ MODULE PROCEDURE reallocate_i4_2
+ MODULE PROCEDURE reallocate_i8_1
+ MODULE PROCEDURE reallocate_i8_2
+ MODULE PROCEDURE reallocate_l_1
+ MODULE PROCEDURE reallocate_l_2
+ END INTERFACE reallocate
+
+ INTERFACE swap
+ MODULE PROCEDURE swap_i4
+ MODULE PROCEDURE swap_i8
+ MODULE PROCEDURE swap_scalar_r8
+ MODULE PROCEDURE swap_vector_r8
+ MODULE PROCEDURE swap_r16
+ MODULE PROCEDURE swap_ch
+ END INTERFACE swap
+
+ INTERFACE toInt
+ MODULE PROCEDURE toInt_4
+ END INTERFACE toInt
+
+ INTERFACE secToHMS
+ MODULE PROCEDURE secToHMS_r4
+ MODULE PROCEDURE secToHMS_r8
+ END INTERFACE secToHMS
+
+ INTERFACE toReal
+ MODULE PROCEDURE toReal_8
+ MODULE PROCEDURE toReal_16
+ END INTERFACE toReal
+
+ INTERFACE toString
+ MODULE PROCEDURE toString_i4
+ MODULE PROCEDURE toString_i8
+ MODULE PROCEDURE toString_r4
+ MODULE PROCEDURE toString_r8
+ END INTERFACE toString
+
+
+
+CONTAINS
+
+
+
+
+
+ INTEGER(iprec8) FUNCTION arrayToInteger_r8i8(array, elements, bin_size, nbins, bounds, error)
+
+ IMPLICIT NONE
+ REAL(rprec8), DIMENSION(:), INTENT(in) :: array ! input array
+ LOGICAL, DIMENSION(:), INTENT(in) :: elements ! used elements
+ REAL(rprec8), DIMENSION(:), INTENT(in) :: bin_size ! bin sizes
+ INTEGER, DIMENSION(:), INTENT(in) :: nbins ! number of bins
+ REAL(rprec8), DIMENSION(:,:), INTENT(in) :: bounds ! variable bounds
+ LOGICAL, INTENT(out) :: error
+ INTEGER(iprec8), DIMENSION(:), ALLOCATABLE :: kp
+ INTEGER, DIMENSION(:), ALLOCATABLE :: help, nbins_
+ INTEGER(iprec8) :: bins_coeff, intgr
+ INTEGER :: ncolumn, i, j, err
+
+ ! Make an index (help) of the elements that are used:
+ ncolumn = COUNT(elements)
+ ALLOCATE(kp(ncolumn), help(ncolumn), nbins_(ncolumn), stat=err)
+ IF (err /= 0) THEN
+ error = .TRUE.
+ DEALLOCATE(kp, stat=err)
+ DEALLOCATE(help, stat=err)
+ DEALLOCATE(nbins_, stat=err)
+ RETURN
+ END IF
+ j = 0
+ DO i=1,SIZE(elements)
+ IF (elements(i)) THEN
+ j = j + 1
+ help(j) = i
+ nbins_(j) = nbins(i)
+ END IF
+ END DO
+
+ ! Compute coordinates of the bin:
+ DO i=1,SIZE(kp)
+ ! Compute a value describing a single elements position:
+ kp(i) = INT((array(help(i)) - bounds(help(i),1)) / &
+ bin_size(help(i)),4) + 1
+ END DO
+
+ ! If one or more of the elements are out of bounds, skip the
+ ! array:
+ IF (ANY(kp>nbins_) .OR. ANY(kp<0)) THEN
+ arrayToInteger_r8i8 = 0_iprec8
+ DEALLOCATE(kp, stat=err)
+ DEALLOCATE(help, stat=err)
+ DEALLOCATE(nbins_, stat=err)
+ RETURN
+ END IF
+
+ ! Transform bin coordinates to a single integer value
+ ! (size(kp) == size(help)):
+ intgr = 0_iprec8
+ DO i=1,SIZE(kp)
+ bins_coeff = 1_iprec8
+ DO j=2,i
+ bins_coeff = bins_coeff*INT(nbins_(j-1),iprec8)
+ END DO
+ intgr = intgr + INT((kp(i) - 1),iprec8)*bins_coeff
+ END DO
+ intgr = intgr + 1_iprec8
+
+ DEALLOCATE(kp, help, nbins_, stat=err)
+ IF (err /= 0) THEN
+ DEALLOCATE(kp, stat=err)
+ DEALLOCATE(help, stat=err)
+ DEALLOCATE(nbins_, stat=err)
+ END IF
+ arrayToInteger_r8i8 = intgr
+
+ END FUNCTION arrayToInteger_r8i8
+
+
+
+
+
+ REAL(rprec16) FUNCTION arrayToReal_r8r16(array, elements, bin_size, nbins, bounds, error)
+
+ IMPLICIT NONE
+ REAL(rprec8), DIMENSION(:), INTENT(in) :: array ! input array
+ LOGICAL, DIMENSION(:), INTENT(in) :: elements ! used elements
+ REAL(rprec8), DIMENSION(:), INTENT(in) :: bin_size ! bin sizes
+ INTEGER, DIMENSION(:), INTENT(in) :: nbins ! number of bins
+ REAL(rprec8), DIMENSION(:,:), INTENT(in) :: bounds ! variable bounds
+ LOGICAL, INTENT(out) :: error
+ INTEGER(iprec8), DIMENSION(:), ALLOCATABLE :: kp
+ INTEGER, DIMENSION(:), ALLOCATABLE :: help, nbins_
+ REAL(rprec16) :: bins_coeff, rreal
+ REAL(rprec8) :: tmp
+ INTEGER :: ncolumn, i, j, err
+
+ ! Make an index (help) of the elements that are used:
+ ncolumn = COUNT(elements)
+ ALLOCATE(kp(ncolumn), help(ncolumn), nbins_(ncolumn), stat=err)
+ IF (err /= 0) THEN
+ error = .TRUE.
+ DEALLOCATE(kp, stat=err)
+ DEALLOCATE(help, stat=err)
+ DEALLOCATE(nbins_, stat=err)
+ RETURN
+ END IF
+ j = 0
+ DO i=1,SIZE(elements,dim=1)
+ IF (elements(i)) THEN
+ j = j + 1
+ help(j) = i
+ nbins_(j) = nbins(i)
+ END IF
+ END DO
+
+ ! Compute coordinates of the bin:
+ DO i=1,SIZE(kp,dim=1)
+ ! Compute a value describing a single elements position:
+ tmp = array(help(i)) - bounds(help(i),1)
+ tmp = tmp / bin_size(help(i))
+ kp(i) = INT(tmp,4) + 1
+ END DO
+
+ ! If one or more of the elements are out of bounds, skip the
+ ! array:
+ IF (ANY(kp > nbins_) .OR. ANY(kp < 0)) THEN
+ arrayToReal_r8r16 = 0.0_rprec16
+ DEALLOCATE(kp, stat=err)
+ DEALLOCATE(help, stat=err)
+ DEALLOCATE(nbins_, stat=err)
+ RETURN
+ END IF
+
+ ! Transform bin coordinates to a single integer value
+ ! (size(kp) == size(help)):
+ rreal = 0.0_rprec16
+ DO i=1,SIZE(kp,dim=1)
+ bins_coeff = 1.0_rprec16
+ DO j=2,i
+ bins_coeff = bins_coeff*REAL(nbins_(j-1),rprec16)
+ END DO
+ rreal = rreal + REAL((kp(i) - 1),rprec16)*bins_coeff
+ END DO
+ rreal = rreal + 1.0_rprec16
+
+ DEALLOCATE(kp, help, nbins_, stat=err)
+ IF (err /= 0) THEN
+ DEALLOCATE(kp, stat=err)
+ DEALLOCATE(help, stat=err)
+ DEALLOCATE(nbins_, stat=err)
+ END IF
+ arrayToReal_r8r16 = rreal
+
+ END FUNCTION arrayToReal_r8r16
+
+
+
+
+
+ INTEGER FUNCTION imaxloc_i4(array)
+
+ IMPLICIT NONE
+ INTEGER(iprec4), DIMENSION(:), INTENT(in) :: array
+ INTEGER, DIMENSION(1) :: imax
+
+ imax = MAXLOC(array)
+ imaxloc_i4 = imax(1)
+
+ END FUNCTION imaxloc_i4
+
+
+
+
+
+ INTEGER FUNCTION imaxloc_i8(array)
+
+ IMPLICIT NONE
+ INTEGER(iprec8), DIMENSION(:), INTENT(in) :: array
+ INTEGER, DIMENSION(1) :: imax
+
+ imax = MAXLOC(array)
+ imaxloc_i8 = imax(1)
+
+ END FUNCTION imaxloc_i8
+
+
+
+
+
+ INTEGER FUNCTION imaxloc_r4(array)
+
+ IMPLICIT NONE
+ REAL(rprec4), DIMENSION(:), INTENT(in) :: array
+ INTEGER, DIMENSION(1) :: imax
+
+ imax = MAXLOC(array)
+ imaxloc_r4 = imax(1)
+
+ END FUNCTION imaxloc_r4
+
+
+
+
+
+ INTEGER FUNCTION imaxloc_r8(array)
+
+ IMPLICIT NONE
+ REAL(rprec8), DIMENSION(:), INTENT(in) :: array
+ INTEGER, DIMENSION(1) :: imax
+
+ imax = MAXLOC(array)
+ imaxloc_r8 = imax(1)
+
+ END FUNCTION imaxloc_r8
+
+
+
+
+
+ INTEGER FUNCTION imaxloc_r16(array)
+
+ IMPLICIT NONE
+ REAL(rprec16), DIMENSION(:), INTENT(in) :: array
+ INTEGER, DIMENSION(1) :: imax
+
+ imax = MAXLOC(array)
+ imaxloc_r16 = imax(1)
+
+ END FUNCTION imaxloc_r16
+
+
+
+
+
+ INTEGER FUNCTION iminloc_i4(array)
+
+ IMPLICIT NONE
+ INTEGER(iprec4), DIMENSION(:), INTENT(in) :: array
+ INTEGER, DIMENSION(1) :: imin
+
+ imin = MINLOC(array)
+ iminloc_i4 = imin(1)
+
+ END FUNCTION iminloc_i4
+
+
+
+
+
+ INTEGER FUNCTION iminloc_i8(array)
+
+ IMPLICIT NONE
+ INTEGER(iprec8), DIMENSION(:), INTENT(in) :: array
+ INTEGER, DIMENSION(1) :: imin
+
+ imin = MINLOC(array)
+ iminloc_i8 = imin(1)
+
+ END FUNCTION iminloc_i8
+
+
+
+
+
+ INTEGER FUNCTION iminloc_r4(array)
+
+ IMPLICIT NONE
+ REAL(rprec4), DIMENSION(:), INTENT(in) :: array
+ INTEGER, DIMENSION(1) :: imin
+
+ imin = MINLOC(array)
+ iminloc_r4 = imin(1)
+
+ END FUNCTION iminloc_r4
+
+
+
+
+
+ INTEGER FUNCTION iminloc_r8(array)
+
+ IMPLICIT NONE
+ REAL(rprec8), DIMENSION(:), INTENT(in) :: array
+ INTEGER, DIMENSION(1) :: imin
+
+ imin = MINLOC(array)
+ iminloc_r8 = imin(1)
+
+ END FUNCTION iminloc_r8
+
+
+
+
+
+ INTEGER FUNCTION iminloc_r16(array)
+
+ IMPLICIT NONE
+ REAL(rprec16), DIMENSION(:), INTENT(in) :: array
+ INTEGER, DIMENSION(1) :: imin
+
+ imin = MINLOC(array)
+ iminloc_r16 = imin(1)
+
+ END FUNCTION iminloc_r16
+
+
+
+
+
+ FUNCTION integerToArray_ri8(intgr, elements, bin_size, nbins, bounds, error)
+
+ IMPLICIT NONE
+ INTEGER(iprec8), INTENT(in) :: intgr ! input integer
+ LOGICAL, DIMENSION(:), INTENT(in) :: elements ! used elements
+ REAL(rprec8), DIMENSION(:), INTENT(in) :: bin_size ! bin sizes
+ INTEGER, DIMENSION(:), INTENT(in) :: nbins ! number of bins
+ REAL(rprec8), DIMENSION(:,:), INTENT(in) :: bounds ! variable bounds
+ LOGICAL, INTENT(out) :: error
+ REAL(rprec8), DIMENSION(SIZE(elements)) :: integerToArray_ri8
+
+ INTEGER(iprec8) :: intgr_coeff, bins_coeff
+ INTEGER, DIMENSION(:), ALLOCATABLE :: kp, nbins_
+ INTEGER :: ncolumn, i, j, k, err
+
+ ! Make an index (help) of the elements that are used:
+ ncolumn = COUNT(elements)
+ ALLOCATE(kp(ncolumn), nbins_(ncolumn), stat=err)
+ IF (err /= 0) THEN
+ error = .TRUE.
+ DEALLOCATE(kp, stat=err)
+ DEALLOCATE(nbins_, stat=err)
+ RETURN
+ END IF
+ j = 0
+ DO i=1,SIZE(elements)
+ IF (elements(i)) THEN
+ j = j + 1
+ nbins_(j) = nbins(i)
+ END IF
+ END DO
+
+ ! Transform integer to bin coordinates
+ ! (size(kp) == size(help)):
+ bins_coeff = 1_rprec8
+ DO i=ncolumn, 1, -1
+ intgr_coeff = intgr
+ DO j=i+1, ncolumn
+ bins_coeff = 1_rprec8
+ DO k=1,j-1
+ bins_coeff = bins_coeff*INT(nbins_(k),rprec8)
+ END DO
+ intgr_coeff = intgr_coeff - INT((kp(j)-1)*bins_coeff,rprec8)
+ END DO
+ bins_coeff = 1_rprec8
+ DO j=1,i-1
+ bins_coeff = bins_coeff*INT(nbins_(j),rprec8)
+ END DO
+ kp(i) = 1 + INT(intgr_coeff/REAL(bins_coeff),iprec4)
+ END DO
+ kp(1) = kp(1) - 1
+
+ ! Transform bin coordinates to real values:
+ j = 0
+ DO i=1,SIZE(elements)
+ IF (elements(i)) THEN
+ j = j + 1
+ integerToArray_ri8(i) = bounds(i,1) + kp(j)*bin_size(i)
+ ELSE
+ integerToArray_ri8(i) = -1.0_rprec8
+ END IF
+ END DO
+
+ DEALLOCATE(kp, nbins_, stat=err)
+ IF (err /= 0) THEN
+ DEALLOCATE(kp, stat=err)
+ DEALLOCATE(nbins_, stat=err)
+ END IF
+
+ END FUNCTION integerToArray_ri8
+
+
+
+
+
+ LOGICAL FUNCTION is_downcase(d)
+
+ ! Description:
+ !
+ ! This function returns TRUE if the character 'd' is a lowercase letter.
+ ! It returns FALSE otherwise.
+ !
+ ! Programming interface:
+ !
+ ! Name In/out Type Structure Meaning
+ !
+ ! is_downcase out logical scalar TRUE if d is lowercase letter
+ ! FALSE otherwise
+ ! d in character(1) scalar The character to be examined
+ !
+ ! Errors:
+ !
+ ! No errors should occur and none are trapped.
+ ! This routine assumes the ASCII character set.
+
+ IMPLICIT NONE
+ CHARACTER(len=1) :: d
+
+ is_downcase = ((d >= 'a') .AND. (d <= 'z'))
+
+ END FUNCTION is_downcase
+
+
+
+
+
+ FUNCTION outerand(a,b)
+
+ IMPLICIT NONE
+ LOGICAL, DIMENSION(:), INTENT(IN) :: a,b
+ LOGICAL, DIMENSION(SIZE(a),SIZE(b)) :: outerand
+
+ outerand = SPREAD(a,dim=2,ncopies=SIZE(b)) .AND. &
+ SPREAD(b,dim=1,ncopies=SIZE(a))
+
+ END FUNCTION outerand
+
+
+
+
+
+ FUNCTION realToArray_r16r8(rreal, elements, bin_size, nbins, bounds, error)
+
+ IMPLICIT NONE
+ REAL(rprec16), INTENT(in) :: rreal ! input integer (real)
+ LOGICAL, DIMENSION(:), INTENT(in) :: elements ! used elements
+ REAL(rprec8), DIMENSION(:), INTENT(in) :: bin_size ! bin sizes
+ INTEGER, DIMENSION(:), INTENT(in) :: nbins ! number of bins
+ REAL(rprec8), DIMENSION(:,:), INTENT(in) :: bounds ! variable bounds
+ LOGICAL, INTENT(out) :: error
+ REAL(rprec8), DIMENSION(:), POINTER :: realToArray_r16r8
+ REAL(rprec16) :: rreal_coeff, bins_coeff
+ INTEGER, DIMENSION(:), ALLOCATABLE :: kp, nbins_
+ INTEGER :: ncolumn, i, j, k, err
+
+ ! Make an index (help) of the elements that are used:
+ ncolumn = COUNT(elements)
+ ALLOCATE(realToArray_r16r8(SIZE(elements)), kp(ncolumn), &
+ nbins_(ncolumn), stat=err)
+ IF (err /= 0) THEN
+ error = .TRUE.
+ DEALLOCATE(realToArray_r16r8, stat=err)
+ DEALLOCATE(kp, stat=err)
+ DEALLOCATE(nbins_, stat=err)
+ RETURN
+ END IF
+ j = 0
+ DO i=1,SIZE(elements)
+ IF (elements(i)) THEN
+ j = j + 1
+ nbins_(j) = nbins(i)
+ END IF
+ END DO
+
+ ! Transform integer to bin coordinates
+ ! (size(kp) == size(help)):
+ bins_coeff = 1.0_rprec16
+ DO i=ncolumn, 1, -1
+ rreal_coeff = rreal
+ DO j=i+1, ncolumn
+ bins_coeff = 1.0_rprec16
+ DO k=1,j-1
+ bins_coeff = bins_coeff*REAL(nbins_(k),rprec16)
+ END DO
+ rreal_coeff = rreal_coeff - REAL((kp(j)-1)*bins_coeff,rprec16)
+ END DO
+ bins_coeff = 1.0_rprec16
+ DO j=1,i-1
+ bins_coeff = bins_coeff*REAL(nbins_(j),rprec16)
+ END DO
+ kp(i) = 1 + INT(rreal_coeff/bins_coeff,iprec4)
+ END DO
+ kp(1) = kp(1) - 1
+
+ ! Transform bin coordinates to real values:
+ j = 0
+ DO i=1,SIZE(elements)
+ IF (elements(i)) THEN
+ j = j + 1
+ realToArray_r16r8(i) = bounds(i,1) + kp(j)*bin_size(i)
+ ELSE
+ realToArray_r16r8(i) = -1.0_rprec8
+ END IF
+ END DO
+
+ DEALLOCATE(kp, nbins_, stat=err)
+ IF (err /= 0) THEN
+ DEALLOCATE(kp, stat=err)
+ DEALLOCATE(nbins_, stat=err)
+ END IF
+
+ END FUNCTION realToArray_r16r8
+
+
+
+
+
+ FUNCTION reallocate_ch_1(array,n)
+
+ IMPLICIT NONE
+ CHARACTER(len=*), DIMENSION(:), POINTER :: array
+ CHARACTER(len=LEN(array(1))), DIMENSION(:), POINTER :: reallocate_ch_1
+ INTEGER, INTENT(in) :: n
+ INTEGER :: nold
+
+ ALLOCATE(reallocate_ch_1(n))
+ reallocate_ch_1 = " "
+ IF (ASSOCIATED(array)) THEN
+ nold = SIZE(array, dim=1)
+ reallocate_ch_1(1:MIN(n,nold)) = array(1:MIN(n,nold))
+ DEALLOCATE(array)
+ END IF
+
+ END FUNCTION reallocate_ch_1
+
+
+
+
+
+ FUNCTION reallocate_ch_2(array,n,m)
+
+ IMPLICIT NONE
+ CHARACTER(len=*), DIMENSION(:,:), POINTER :: array
+ CHARACTER(len=LEN(array(1,1))), DIMENSION(:,:), POINTER :: reallocate_ch_2
+ INTEGER, INTENT(in) :: n, m
+ INTEGER :: nold, mold, i, j
+
+ ALLOCATE(reallocate_ch_2(n,m))
+ reallocate_ch_2 = " "
+ IF (.NOT. ASSOCIATED(array)) THEN
+ RETURN
+ END IF
+ nold = SIZE(array, dim=1)
+ mold = SIZE(array, dim=2)
+ DO i=1,MIN(n,nold)
+ DO j=1,MIN(m,mold)
+ reallocate_ch_2(i,j) = array(i,j)
+ END DO
+ END DO
+ DEALLOCATE(array)
+
+ END FUNCTION reallocate_ch_2
+
+
+
+
+
+ FUNCTION reallocate_ch18_1(array,n)
+
+ IMPLICIT NONE
+ CHARACTER(len=18), DIMENSION(:), POINTER :: reallocate_ch18_1, array
+ INTEGER, INTENT(in) :: n
+ INTEGER :: nold
+
+ ALLOCATE(reallocate_ch18_1(n))
+ IF (.NOT. ASSOCIATED(array)) RETURN
+ nold = SIZE(array, dim=1)
+ reallocate_ch18_1(1:MIN(n,nold)) = array(1:MIN(n,nold))
+ DEALLOCATE(array)
+
+ END FUNCTION reallocate_ch18_1
+
+
+
+
+
+ FUNCTION reallocate_ch24_1(array,n)
+
+ IMPLICIT NONE
+ CHARACTER(len=24), DIMENSION(:), POINTER :: reallocate_ch24_1, array
+ INTEGER, INTENT(in) :: n
+ INTEGER :: nold
+
+ ALLOCATE(reallocate_ch24_1(n))
+ IF (.NOT. ASSOCIATED(array)) RETURN
+ nold = SIZE(array, dim=1)
+ reallocate_ch24_1(1:MIN(n,nold)) = array(1:MIN(n,nold))
+ DEALLOCATE(array)
+
+ END FUNCTION reallocate_ch24_1
+
+
+
+
+
+ FUNCTION reallocate_i1_1(array,n)
+
+ IMPLICIT NONE
+ INTEGER(iprec1), DIMENSION(:), POINTER :: reallocate_i1_1, array
+ INTEGER, INTENT(in) :: n
+ INTEGER :: nold
+
+ ALLOCATE(reallocate_i1_1(n))
+ IF (ASSOCIATED(array)) THEN
+ nold = SIZE(array, dim=1)
+ reallocate_i1_1(1:MIN(n,nold)) = array(1:MIN(n,nold))
+ DEALLOCATE(array)
+ END IF
+
+ END FUNCTION reallocate_i1_1
+
+
+
+
+
+ FUNCTION reallocate_i4_1(array,n)
+
+ IMPLICIT NONE
+ INTEGER(iprec4), DIMENSION(:), POINTER :: reallocate_i4_1, array
+ INTEGER, INTENT(in) :: n
+ INTEGER :: nold
+
+ ALLOCATE(reallocate_i4_1(n))
+ IF (ASSOCIATED(array)) THEN
+ nold = SIZE(array, dim=1)
+ reallocate_i4_1(1:MIN(n,nold)) = array(1:MIN(n,nold))
+ DEALLOCATE(array)
+ END IF
+
+ END FUNCTION reallocate_i4_1
+
+
+
+
+
+ FUNCTION reallocate_i4_2(array,n,m)
+
+ IMPLICIT NONE
+ INTEGER(iprec4), DIMENSION(:,:), POINTER :: reallocate_i4_2, array
+ INTEGER, INTENT(in) :: n, m
+ INTEGER :: nold, mold
+
+ ALLOCATE(reallocate_i4_2(n,m))
+ IF (.NOT. ASSOCIATED(array)) RETURN
+ nold = SIZE(array,1)
+ mold = SIZE(array,2)
+ reallocate_i4_2(1:MIN(n,nold),1:MIN(m,mold)) = &
+ array(1:MIN(n,nold),1:MIN(m,mold))
+ DEALLOCATE(array)
+
+ END FUNCTION reallocate_i4_2
+
+
+
+
+
+ FUNCTION reallocate_i8_1(array,n)
+
+ IMPLICIT NONE
+ INTEGER(rprec8), DIMENSION(:), POINTER :: reallocate_i8_1, array
+ INTEGER, INTENT(in) :: n
+ INTEGER :: nold
+
+ ALLOCATE(reallocate_i8_1(n))
+ IF (.NOT. ASSOCIATED(array)) RETURN
+ nold = SIZE(array)
+ reallocate_i8_1(1:MIN(n,nold)) = array(1:MIN(n,nold))
+ DEALLOCATE(array)
+
+ END FUNCTION reallocate_i8_1
+
+
+
+
+
+ FUNCTION reallocate_i8_2(array,n,m)
+
+ IMPLICIT NONE
+ INTEGER(rprec8), DIMENSION(:,:), POINTER :: reallocate_i8_2, array
+ INTEGER, INTENT(in) :: n, m
+ INTEGER :: nold, mold
+
+ ALLOCATE(reallocate_i8_2(n,m))
+ IF (.NOT. ASSOCIATED(array)) RETURN
+ nold = SIZE(array,1)
+ mold = SIZE(array,2)
+ reallocate_i8_2(1:MIN(n,nold),1:MIN(m,mold)) = &
+ array(1:MIN(n,nold),1:MIN(m,mold))
+ DEALLOCATE(array)
+
+ END FUNCTION reallocate_i8_2
+
+
+
+
+
+ FUNCTION reallocate_r4_1(array,n)
+
+ IMPLICIT NONE
+ REAL(rprec4), DIMENSION(:), POINTER :: reallocate_r4_1, array
+ INTEGER, INTENT(in) :: n
+ INTEGER :: nold
+
+ ALLOCATE(reallocate_r4_1(n))
+ IF (.NOT. ASSOCIATED(array)) RETURN
+ nold = SIZE(array)
+ reallocate_r4_1(1:MIN(n,nold)) = array(1:MIN(n,nold))
+ DEALLOCATE(array)
+
+ END FUNCTION reallocate_r4_1
+
+
+
+
+
+ FUNCTION reallocate_r4_2(array,n,m)
+
+ IMPLICIT NONE
+ REAL(rprec4), DIMENSION(:,:), POINTER :: reallocate_r4_2, array
+ INTEGER, INTENT(in) :: n, m
+ INTEGER :: nold, mold
+
+ ALLOCATE(reallocate_r4_2(n,m))
+ IF (.NOT. ASSOCIATED(array)) RETURN
+ nold = SIZE(array,1)
+ mold = SIZE(array,2)
+ reallocate_r4_2(1:MIN(n,nold),1:MIN(m,mold)) = &
+ array(1:MIN(n,nold),1:MIN(m,mold))
+ DEALLOCATE(array)
+
+ END FUNCTION reallocate_r4_2
+
+
+
+
+
+ FUNCTION reallocate_r8_1(array,n)
+
+ IMPLICIT NONE
+ REAL(rprec8), DIMENSION(:), POINTER :: reallocate_r8_1, array
+ INTEGER, INTENT(in) :: n
+ INTEGER :: nold
+
+ ALLOCATE(reallocate_r8_1(n))
+ IF (.NOT. ASSOCIATED(array)) RETURN
+ nold = SIZE(array)
+ reallocate_r8_1(1:MIN(n,nold)) = array(1:MIN(n,nold))
+ DEALLOCATE(array)
+
+ END FUNCTION reallocate_r8_1
+
+
+
+
+
+ FUNCTION reallocate_r8_2(array,n,m,nmask)
+
+ IMPLICIT NONE
+ REAL(rprec8), DIMENSION(:,:), POINTER :: reallocate_r8_2, array
+ INTEGER, INTENT(in) :: n, m
+ LOGICAL, DIMENSION(:), INTENT(in), OPTIONAL :: nmask
+ INTEGER :: i, in, nold, mold
+
+ ALLOCATE(reallocate_r8_2(n,m))
+ IF (ASSOCIATED(array) .AND. .NOT.PRESENT(nmask)) THEN
+ nold = SIZE(array,1)
+ mold = SIZE(array,2)
+ reallocate_r8_2(1:MIN(n,nold),1:MIN(m,mold)) = &
+ array(1:MIN(n,nold),1:MIN(m,mold))
+ DEALLOCATE(array)
+ ELSE IF (ASSOCIATED(array) .AND. PRESENT(nmask)) THEN
+ in = 0
+ DO i=1,nold
+ IF (in == n) THEN
+ EXIT
+ END IF
+ IF (nmask(i)) THEN
+ in = in + 1
+ reallocate_r8_2(in,1:MIN(m,mold)) = array(i,1:MIN(m,mold))
+ END IF
+ END DO
+ DEALLOCATE(array)
+ END IF
+
+ END FUNCTION reallocate_r8_2
+
+
+
+
+
+ FUNCTION reallocate_r8_3(array,n,m,o)
+
+ IMPLICIT NONE
+ REAL(rprec8), DIMENSION(:,:,:), POINTER :: reallocate_r8_3, array
+ INTEGER, INTENT(in) :: n, m, o
+ INTEGER :: nold, mold, oold
+
+ ALLOCATE(reallocate_r8_3(n,m,o))
+ IF (ASSOCIATED(array)) THEN
+ nold = SIZE(array,1)
+ mold = SIZE(array,2)
+ oold = SIZE(array,3)
+ reallocate_r8_3(1:MIN(n,nold),1:MIN(m,mold),1:MIN(o,oold)) = &
+ array(1:MIN(n,nold),1:MIN(m,mold),1:MIN(o,oold))
+ DEALLOCATE(array)
+ END IF
+
+ END FUNCTION reallocate_r8_3
+
+
+
+
+
+ FUNCTION reallocate_r16_1(array,n)
+
+ IMPLICIT NONE
+ REAL(rprec16), DIMENSION(:), POINTER :: reallocate_r16_1, array
+ INTEGER, INTENT(in) :: n
+ INTEGER :: nold
+
+ ALLOCATE(reallocate_r16_1(n))
+ IF (.NOT. ASSOCIATED(array)) RETURN
+ nold = SIZE(array)
+ reallocate_r16_1(1:MIN(n,nold)) = array(1:MIN(n,nold))
+ DEALLOCATE(array)
+
+ END FUNCTION reallocate_r16_1
+
+
+
+
+
+ FUNCTION reallocate_r16_2(array,n,m)
+
+ IMPLICIT NONE
+ REAL(rprec16), DIMENSION(:,:), POINTER :: reallocate_r16_2, array
+ INTEGER, INTENT(in) :: n, m
+ INTEGER :: nold, mold
+
+ ALLOCATE(reallocate_r16_2(n,m))
+ IF (.NOT. ASSOCIATED(array)) RETURN
+ nold = SIZE(array,1)
+ mold = SIZE(array,2)
+ reallocate_r16_2(1:MIN(n,nold),1:MIN(m,mold)) = &
+ array(1:MIN(n,nold),1:MIN(m,mold))
+ DEALLOCATE(array)
+
+ END FUNCTION reallocate_r16_2
+
+
+
+
+
+ FUNCTION reallocate_l_1(array,n)
+
+ IMPLICIT NONE
+ LOGICAL, DIMENSION(:), POINTER :: reallocate_l_1, array
+ INTEGER, INTENT(in) :: n
+ INTEGER :: nold
+
+ ALLOCATE(reallocate_l_1(n))
+ IF (.NOT. ASSOCIATED(array)) RETURN
+ nold = SIZE(array)
+ reallocate_l_1(1:MIN(n,nold)) = &
+ array(1:MIN(n,nold))
+ DEALLOCATE(array)
+
+ END FUNCTION reallocate_l_1
+
+
+
+
+
+ FUNCTION reallocate_l_2(array,n,m)
+
+ IMPLICIT NONE
+ LOGICAL, DIMENSION(:,:), POINTER :: reallocate_l_2, array
+ INTEGER, INTENT(in) :: n, m
+ INTEGER :: nold, mold
+
+ ALLOCATE(reallocate_l_2(n,m))
+ IF (.NOT. ASSOCIATED(array)) RETURN
+ nold = SIZE(array,dim=1)
+ mold = SIZE(array,dim=2)
+ reallocate_l_2(1:MIN(n,nold),1:MIN(m,mold)) = &
+ array(1:MIN(n,nold),1:MIN(m,mold))
+ DEALLOCATE(array)
+
+ END FUNCTION reallocate_l_2
+
+
+
+
+
+ SUBROUTINE removeLeadingBlanks(str)
+
+ IMPLICIT NONE
+ CHARACTER(len=*), INTENT(inout) :: str
+
+ DO WHILE (INDEX(TRIM(str),CHAR(0)) == 1 .OR. &
+ INDEX(TRIM(str),CHAR(32)) == 1)
+ str(1:LEN_TRIM(str)) = str(2:LEN_TRIM(str)) // CHAR(32)
+ END DO
+
+ END SUBROUTINE removeLeadingBlanks
+
+
+
+
+
+!!$ FUNCTION TRIM(str_in) RESULT(str_out)
+!!$
+!!$ IMPLICIT NONE
+!!$ CHARACTER(len=*), INTENT(in) :: str_in
+!!$ CHARACTER(len=LEN_TRIM(str_in)) :: str_out
+!!$
+!!$ str_out = str_in(1:LEN_TRIM(str_in))
+!!$
+!!$ END FUNCTION trim
+
+
+
+
+
+ CHARACTER(len=64) FUNCTION secToHMS_r4(sec, error)
+
+ IMPLICIT NONE
+ REAL(rprec4), INTENT(in) :: sec
+ LOGICAL, INTENT(inout) :: error
+ CHARACTER(len=16) :: str
+ INTEGER :: h, min, ind
+
+ secToHMS_r4 = ' '
+ ! Hours:
+ h = FLOOR(sec/3600.0_4)
+ IF (h /= 0) THEN
+ CALL toString(h, str, error)
+ secToHMS_r4 = TRIM(secToHMS_r4) // TRIM(str) // 'h '
+ END IF
+ ! Minutes:
+ min = FLOOR((sec - h*3600.0_4)/60.0_4)
+ IF (min /= 0 .OR. h /= 0) THEN
+ CALL toString(min, str, error)
+ secToHMS_r4 = TRIM(secToHMS_r4) // TRIM(str) // 'min '
+ END IF
+ ! Seconds with 3 decimals:
+ CALL toString((sec-h*3600.0_4-min*60.0_4), str, error)
+ ind = INDEX(str,'.') + 6
+ secToHMS_r4 = TRIM(secToHMS_r4) // str(1:ind) // 'sec'
+
+ END FUNCTION secToHMS_r4
+
+
+
+
+
+ CHARACTER(len=64) FUNCTION secToHMS_r8(sec, error)
+
+ IMPLICIT NONE
+ REAL(rprec8), INTENT(in) :: sec
+ LOGICAL, INTENT(inout) :: error
+ CHARACTER(len=32) :: str
+ INTEGER :: h, min, ind
+
+ secToHMS_r8 = ' '
+ ! Hours:
+ h = FLOOR(sec/3600.0_rprec8)
+ IF (h /= 0) THEN
+ CALL toString(h, str, error)
+ secToHMS_r8 = TRIM(secToHMS_r8) // TRIM(str) // 'h '
+ END IF
+ ! Minutes:
+ min = FLOOR((sec - h*3600.0_rprec8)/60.0_rprec8)
+ IF (min /= 0 .OR. h /= 0) THEN
+ CALL toString(min, str, error)
+ secToHMS_r8 = TRIM(secToHMS_r8) // TRIM(str) // 'min '
+ END IF
+ ! Seconds with 3 decimals:
+ CALL toString((sec-h*3600.0_rprec8-min*60.0_rprec8), str, error)
+ ind = INDEX(str,'.') + 6
+ secToHMS_r8 = TRIM(secToHMS_r8) // str(1:ind) // 'sec'
+
+ END FUNCTION secToHMS_r8
+
+
+
+
+
+ SUBROUTINE swap_i4(first, second, mask)
+
+ IMPLICIT NONE
+ INTEGER(iprec4), INTENT(inout) :: first, second
+ LOGICAL, OPTIONAL, INTENT(in) :: mask
+ INTEGER(iprec4) :: dum
+
+ IF (PRESENT(mask)) THEN
+ IF (mask) THEN
+ dum = first
+ first = second
+ second = dum
+ END IF
+ ELSE
+ dum = first
+ first = second
+ second = dum
+ END IF
+
+ END SUBROUTINE swap_i4
+
+
+
+
+
+ SUBROUTINE swap_i8(first, second, mask)
+
+ IMPLICIT NONE
+ INTEGER(iprec8), INTENT(inout) :: first, second
+ LOGICAL, OPTIONAL, INTENT(in) :: mask
+ INTEGER(iprec8) :: dum
+
+ IF (PRESENT(mask)) THEN
+ IF (mask) THEN
+ dum = first
+ first = second
+ second = dum
+ END IF
+ ELSE
+ dum = first
+ first = second
+ second = dum
+ END IF
+
+ END SUBROUTINE swap_i8
+
+
+
+
+
+ SUBROUTINE swap_scalar_r8(first, second, mask)
+
+ IMPLICIT NONE
+ REAL(rprec8), INTENT(inout) :: first, second
+ LOGICAL, OPTIONAL, INTENT(in) :: mask
+ REAL(rprec8) :: dum
+
+ IF (PRESENT(mask)) THEN
+ IF (mask) THEN
+ dum = first
+ first = second
+ second = dum
+ END IF
+ ELSE
+ dum = first
+ first = second
+ second = dum
+ END IF
+
+ END SUBROUTINE swap_scalar_r8
+
+
+
+
+
+ SUBROUTINE swap_vector_r8(first, second, mask)
+
+ IMPLICIT NONE
+ REAL(rprec8), DIMENSION(:), INTENT(inout) :: first, second
+ LOGICAL, OPTIONAL, INTENT(in) :: mask
+ REAL(rprec8), DIMENSION(SIZE(first,dim=1)) :: dum
+
+ IF (PRESENT(mask)) THEN
+ IF (mask) THEN
+ dum = first
+ first = second
+ second = dum
+ END IF
+ ELSE
+ dum = first
+ first = second
+ second = dum
+ END IF
+
+ END SUBROUTINE swap_vector_r8
+
+
+
+
+
+ SUBROUTINE swap_r16(first, second, mask)
+
+ IMPLICIT NONE
+ REAL(rprec16), INTENT(inout) :: first, second
+ LOGICAL, OPTIONAL, INTENT(in) :: mask
+ REAL(rprec16) :: dum
+
+ IF (PRESENT(mask)) THEN
+ IF (mask) THEN
+ dum = first
+ first = second
+ second = dum
+ END IF
+ ELSE
+ dum = first
+ first = second
+ second = dum
+ END IF
+
+ END SUBROUTINE swap_r16
+
+
+
+
+
+ SUBROUTINE swap_ch(first, second, mask)
+
+ IMPLICIT NONE
+ CHARACTER(len=*), INTENT(inout) :: first, second
+ LOGICAL, OPTIONAL, INTENT(in) :: mask
+ CHARACTER(len=MAX(LEN(first),LEN(second))) :: dum
+
+ IF (PRESENT(mask)) THEN
+ IF (mask) THEN
+ dum = first
+ first = second
+ second = dum
+ END IF
+ ELSE
+ dum = first
+ first = second
+ second = dum
+ END IF
+
+ END SUBROUTINE swap_ch
+
+
+
+
+
+ !! *Description*:
+ !!
+ !! Converts a string to a integer(4) number. An error is reported if
+ !! the string cannot be converted to number.
+ !!
+ SUBROUTINE toInt_4(str, k, error)
+
+ IMPLICIT NONE
+ CHARACTER(len=*), INTENT(in) :: str
+ INTEGER(iprec4), INTENT(out) :: k
+ LOGICAL, INTENT(inout) :: error
+ INTEGER :: err
+
+ READ(str,'(I30)',iostat=err) k
+ IF (err /= 0) THEN
+ error = .TRUE.
+ END IF
+
+ END SUBROUTINE toInt_4
+
+
+
+
+
+ !! *Description*:
+ !!
+ !! Converts a string to a real(prec8) number. An error is reported if
+ !! the string cannot be converted to number.
+ !!
+ SUBROUTINE toReal_8(str, r, error)
+
+ IMPLICIT NONE
+ CHARACTER(len=*), INTENT(in) :: str
+ REAL(rprec8), INTENT(out) :: r
+ LOGICAL, INTENT(inout) :: error
+ CHARACTER(len=LEN_TRIM(str)+2) :: lstr
+ REAL(rprec8) :: plusminus
+ INTEGER :: err
+
+ plusminus = 1.0_rprec8
+
+ lstr = TRIM(str)
+ IF (INDEX(lstr, '+') == 1) THEN
+ lstr = lstr(2:LEN_TRIM(lstr))
+ ELSE IF (INDEX(lstr, '-') == 1) THEN
+ plusminus = -1.0_rprec8
+ lstr = lstr(2:LEN_TRIM(lstr))
+ END IF
+ IF (INDEX(str, '.') == 0) lstr = TRIM(str) // '.0'
+ READ(lstr, '(F35.16)', iostat=err) r
+ IF (err /= 0) THEN
+ error = .TRUE.
+ END IF
+ r = plusminus * r
+
+ END SUBROUTINE toReal_8
+
+
+
+
+
+ !! *Description*:
+ !!
+ !! Converts a string to a real(16) number. An error is reported if
+ !! the string cannot be converted to number.
+ !!
+ SUBROUTINE toReal_16(str, r, error)
+
+ IMPLICIT NONE
+ CHARACTER(len=*), INTENT(in) :: str
+ REAL(rprec16), INTENT(out) :: r
+ LOGICAL, INTENT(inout) :: error
+ CHARACTER(len=LEN_TRIM(str)+2) :: lstr
+ REAL(rprec16) :: plusminus
+ INTEGER :: err
+
+ plusminus = 1.0_rprec16
+
+ lstr = TRIM(str)
+ IF (INDEX(lstr, '+') == 1) THEN
+ lstr = lstr(2:LEN_TRIM(lstr))
+ ELSE IF (INDEX(lstr, '-') == 1) THEN
+ plusminus = -1.0_rprec16
+ lstr = lstr(2:LEN_TRIM(lstr))
+ END IF
+ IF (INDEX(str, '.') == 0) lstr = TRIM(str) // '.0'
+ READ(lstr, '(F64.32)', iostat=err) r
+ IF (err /= 0) THEN
+ error = .TRUE.
+ END IF
+ r = plusminus * r
+
+ END SUBROUTINE toReal_16
+
+
+
+
+
+ !! *Description*:
+ !!
+ !! This subroutine returns the input string with all the lowercase
+ !! letters converted to uppercase letters.
+ !!
+ SUBROUTINE upcase(str)
+
+ IMPLICIT NONE
+ CHARACTER(len=*), INTENT(inout) :: str
+ INTEGER :: i, limit
+
+ limit = LEN_TRIM(str)
+ DO i=1,limit
+ IF ((str(i:i) >= 'a') .AND. (str(i:i) <= 'z')) THEN
+ str(i:i) = CHAR(ICHAR(str(i:i))-32)
+ END IF
+ END DO
+
+ END SUBROUTINE upcase
+
+
+
+
+
+ !! *Description*:
+ !!
+ !! This subroutine returns the input string with all the uppercase
+ !! letters converted to lowercase letters.
+ !!
+ SUBROUTINE locase(str, error)
+
+ IMPLICIT NONE
+ CHARACTER(len=*), INTENT(inout) :: str
+ LOGICAL, INTENT(inout) :: error
+ INTEGER :: i, limit, ilo, ihi
+
+ limit = LEN(str)
+ ilo = IACHAR('A')
+ ihi = IACHAR('Z')
+ DO i=1,limit
+ IF (IACHAR(str(i:i)) > 127 .OR. IACHAR(str(i:i)) < 0) THEN
+ error = .TRUE.
+ RETURN
+ END IF
+ IF (IACHAR(str(i:i)) >= ilo .AND. IACHAR(str(i:i)) <= ihi) THEN
+ str(i:i) = CHAR(ICHAR(str(i:i))+32)
+ END IF
+ END DO
+
+ END SUBROUTINE locase
+
+
+
+
+
+ !!
+ !!
+ SUBROUTINE toString_i4(k, str, error)
+
+ ! Description:
+ !
+ ! This routine converts an integer number to a string.
+ !
+ ! Programming interface:
+ !
+ ! Name In/Out Type Structure Meaning
+ !
+ ! str out character Scalar The string
+ ! k in integer(4) Scalar The integer number to be converted
+ ! error inout logical Scalar Set TRUE if an error occurs
+ !
+ ! Errors:
+ !
+ ! An error is reported if the number cannot be converted to an integer.
+
+ IMPLICIT NONE
+ INTEGER(iprec4), INTENT(in) :: k
+ CHARACTER(len=*), INTENT(out) :: str
+ LOGICAL, INTENT(inout) :: error
+ INTEGER :: err
+
+ WRITE(str,'(I0)',iostat=err) k
+ IF (err /= 0) THEN
+ error = .TRUE.
+ str = '***** Error in utilities / toString *****'
+ END IF
+
+ END SUBROUTINE toString_i4
+
+
+
+
+
+ !!
+ !!
+ SUBROUTINE toString_i8(k, str, error)
+
+ ! Description:
+ !
+ ! This routine converts an integer number to a string.
+ !
+ ! Programming interface:
+ !
+ ! Name In/Out Type Structure Meaning
+ !
+ ! str out character Scalar The string
+ ! k in integer(4) Scalar The integer number to be converted
+ ! error inout logical Scalar Set TRUE if an error occurs
+ !
+ ! Errors:
+ !
+ ! An error is reported if the number cannot be converted to an integer.
+
+ IMPLICIT NONE
+ INTEGER(iprec8), INTENT(in) :: k
+ CHARACTER(len=*), INTENT(out) :: str
+ LOGICAL, INTENT(inout) :: error
+ INTEGER :: err
+
+ WRITE(str,'(I0)',iostat=err) k
+ IF (err /= 0) THEN
+ error = .TRUE.
+ str = '***** Error in utilities / toString *****'
+ END IF
+
+ END SUBROUTINE toString_i8
+
+
+
+
+
+ !!
+ !!
+ SUBROUTINE toString_r4(r, str, error, frmt)
+
+ ! Description:
+ !
+ ! This routine converts a real number to a string.
+ !
+ ! Programming interface:
+ !
+ ! Name In/Out Type Structure Meaning
+ !
+ ! str out character Scalar The string
+ ! r4 in real(4) Scalar The real number to be converted
+ ! error inout logical Scalar Set TRUE if an error occurs
+ !
+ ! Errors:
+ !
+ ! An error message is written to the output string, if the number
+ ! cannot be converted to an integer.
+
+ IMPLICIT NONE
+ REAL(rprec4), INTENT(in) :: r
+ CHARACTER(len=*), INTENT(in), OPTIONAL :: frmt
+ CHARACTER(len=*), INTENT(out) :: str
+ LOGICAL, INTENT(inout) :: error
+
+ INTEGER :: err
+
+ IF (PRESENT(frmt)) THEN
+ WRITE(str,TRIM(frmt),iostat=err) r
+ ELSE
+ WRITE(str,'(F0.8)',iostat=err) r
+ END IF
+ IF (err /= 0) THEN
+ error = .TRUE.
+ str = '***** Error in utilities / toString *****'
+ END IF
+ CALL removeLeadingBlanks(str)
+
+ END SUBROUTINE toString_r4
+
+
+
+
+
+ !!
+ !!
+ SUBROUTINE toString_r8(r, str, error, frmt)
+
+ ! Description:
+ !
+ ! This routine converts a real number to a string.
+ !
+ ! Programming interface:
+ !
+ ! Name In/Out Type Structure Meaning
+ !
+ ! str out character Scalar The string (len > 19)
+ ! r4 in real(8) Scalar The real number to be converted
+ ! error inout logical Scalar Set TRUE if an error occurs
+ !
+ ! Errors:
+ !
+ ! An error message is written to the output string, if the number
+ ! cannot be converted to an integer.
+
+ IMPLICIT NONE
+ REAL(rprec8), INTENT(in) :: r
+ CHARACTER(len=*), INTENT(out) :: str
+ CHARACTER(len=*), INTENT(in), OPTIONAL :: frmt
+ LOGICAL, INTENT(inout) :: error
+
+ INTEGER :: err
+
+ IF (PRESENT(frmt)) THEN
+ WRITE(str,TRIM(frmt),iostat=err) r
+ ELSE
+ WRITE(str,'(F0.16)',iostat=err) r
+ END IF
+ IF (err /= 0) THEN
+ error = .TRUE.
+ str = '***** Error in utilities / toString *****'
+ END IF
+ str = ADJUSTL(str)
+
+ END SUBROUTINE toString_r8
+
+
+
+
+
+END MODULE utilities
Index: trunk/mops/oorb/python/Makefile
===================================================================
--- trunk/mops/oorb/python/Makefile (revision 34646)
+++ trunk/mops/oorb/python/Makefile (revision 34646)
@@ -0,0 +1,79 @@
+#
+# LSST Data Management System
+# Copyright 2008, 2009 LSST Corporation.
+#
+# This product includes software developed by the
+# LSST Project (http://www.lsst.org/).
+#
+# This program 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.
+#
+# This program 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 LSST License Statement and
+# the GNU General Public License along with this program. If not,
+# see .
+#
+# F. Pierfederici
+# M. Granvik
+
+include ../make.config
+include ../Makefile.include
+
+all: liboorb.$(LIBEXT)
+
+liboorb.o: liboorb.f90
+ $(FC) -c $(FCOPTIONS) $(FC_INC)../$(CLASSPATH) \
+ $(FC_INC)../$(MODULEPATH) $(FC_INC)../main liboorb.f90
+
+wrapper.o: wrapper.f90 liboorb.o
+ $(FC) -c $(FCOPTIONS) $(FC_INC)../$(CLASSPATH) \
+ $(FC_INC)../$(MODULEPATH) \
+ $(FC_INC)../main \
+ wrapper.f90
+
+liboorb.$(LIBEXT): modules classes main wrapper.o liboorb.o
+ $(FC) $(FCOPTIONS) -shared -o liboorb.$(LIBEXT) \
+ $(FC_INC)../$(CLASSPATH) $(FC_INC)../$(MODULEPATH) \
+ liboorb.o wrapper.o \
+ ../main/io.o \
+ ../$(CLASSPATH)/*.o \
+ ../$(MODULEPATH)/*.o
+
+pyoorb: liboorb
+ f2py2.6 -m pyoorb pyoorb.f90 --build-dir ./build -c --noarch -loorb -L../lib \
+ --f90exec=$(FC) --f90flags="$(FC_INC)../$(CLASSPATH) $(FC_INC)../$(MODULEPATH)"
+
+pyoorb.o: liboorb
+ $(FC) -c $(FCOPTIONS) pyoorb.f90 $(FC_INC)../$(MAINPATH) \
+ $(FC_INC)../$(CLASSPATH) $(FC_INC)../$(MODULEPATH)
+
+liboorb:
+ cd ../$(LIBPATH) ; make
+
+test: test.f90 pyoorb.o
+ $(FC) $(FCOPTIONS) pyoorb.o -loorb -L../lib test.f90 -o test
+
+
+
+main:
+ cd ../main/ ; make io.o
+
+classes:
+ cd ../$(CLASSPATH) ; $(MAKE) all
+
+modules:
+ cd ../$(MODULEPATH) ; $(MAKE) all
+
+
+# Remove library and modules:
+clean:
+ rm -fr build *~ *.mod *.o \
+ *.so *.dylib *.$(LIBEXT) *.pyc *.pyc.$(OS) \
+ test
+
Index: trunk/mops/oorb/python/README
===================================================================
--- trunk/mops/oorb/python/README (revision 34646)
+++ trunk/mops/oorb/python/README (revision 34646)
@@ -0,0 +1,43 @@
+#
+# LSST Data Management System
+# Copyright 2008, 2009 LSST Corporation.
+#
+# This product includes software developed by the
+# LSST Project (http://www.lsst.org/).
+#
+# This program 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.
+#
+# This program 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 LSST License Statement and
+# the GNU General Public License along with this program. If not,
+# see .
+#
+# F. Pierfederici
+
+OpenOrb Python wrappers.
+
+
+To build, cd into this directory and then
+ shell> make clean
+ shell> make
+ shell> python setup.py install
+
+Test by running
+ shell> python api.py
+
+If you get an error from python saying that liboorb cannot be found, copy
+liboorb.so (or liboorb.dylib if you are on a Mac) somewhere in your
+LD_LIBRARY_PATH (or DYLD_LIBRARY_PATH if you are on a Mac).
+
+
+Tested on a Mac OS X system running OSX 10.5.x and gfortran 4.4.x
+
+These wrappers are not in their final version and so they should not be used in
+production software. You have been warned!
Index: trunk/mops/oorb/python/__init__.py
===================================================================
--- trunk/mops/oorb/python/__init__.py (revision 34646)
+++ trunk/mops/oorb/python/__init__.py (revision 34646)
@@ -0,0 +1,65 @@
+#
+# LSST Data Management System
+# Copyright 2008, 2009 LSST Corporation.
+#
+# This product includes software developed by the
+# LSST Project (http://www.lsst.org/).
+#
+# This program 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.
+#
+# This program 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 LSST License Statement and
+# the GNU General Public License along with this program. If not,
+# see .
+#
+# F. Pierfederici
+"""
+OpenOrb Python Module
+"""
+import os
+
+from api import *
+import constants
+import defaults
+import utils
+
+
+
+# Constants
+__verbosity__ = 0
+__version__ = '1.0a1'
+__author__ = 'F. Pierfederici '
+__all__ = ('calendardate_to_mjd',
+ 'ranging_fast',
+ 'ranging',
+ 'lsl_fast',
+ 'lsl',
+ 'propagate_orbit_fast',
+ 'propagate_orbit',
+ 'ephemeris_fast',
+ 'ephemeris',
+ 'moid',
+ 'classification')
+
+
+# Get the path to the data dir and infer the JPL ephemeris location.
+dataDir = os.environ.get('OORB_DATA', None)
+if(not dataDir):
+ raise(Exception('Please point $OORB_DATA to the OpenOrb data directory.'))
+ephemFilePath = os.path.join(dataDir, 'JPL_ephemeris', 'de405.dat')
+
+# Init the module.
+err = init(ephemFilePath, __verbosity__)
+if(err):
+ raise(Exception('OpenOrb initialization failed with error code %d' %(err)))
+
+
+
+
Index: trunk/mops/oorb/python/api.py
===================================================================
--- trunk/mops/oorb/python/api.py (revision 34646)
+++ trunk/mops/oorb/python/api.py (revision 34646)
@@ -0,0 +1,955 @@
+# LSST Data Management System
+# Copyright 2008, 2009 LSST Corporation, Mikael Granvik.
+#
+# This product includes software developed by the
+# LSST Project (http://www.lsst.org/).
+#
+# This program 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.
+#
+# This program 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 LSST License Statement and
+# the GNU General Public License along with this program. If not,
+# see .
+#
+# F. Pierfederici
+# M. Granvik
+#
+import os
+import ctypes
+import ctypes.util
+import numpy
+
+from constants import *
+import utils
+
+
+# Find the oorb library
+libPath = utils.findLibrary('oorb')
+if(not libPath):
+ raise(Exception('Could not find liboorb!'))
+ffi = ctypes.CDLL(libPath)
+
+
+
+
+
+def init(ephemFile, verbosity=0):
+ """
+ Init the oorb module.
+
+ @param ephemFile: full path of the JPL ephemeris de405.dat file
+ @param verbosity: integer indicating verbosity level. 0=quiet.
+
+ Return
+ None
+ """
+ # Init the error code.
+ err = ctypes.c_int(0)
+
+ # Do a simple sanity check in the input.
+ if(not ephemFile):
+ raise(Exception('Bad input.'))
+ if(verbosity < 0):
+ verbosity = 0
+ elif(verbosity > 5):
+ verbosity = 5
+
+ # Invoke the fortran init function.
+ ffi.oorb_init_(ctypes.c_char_p(ephemFile),
+ ctypes.byref(ctypes.c_int(verbosity)),
+ ctypes.byref(err),
+ ctypes.c_int(len(ephemFile)))
+ if(err.value):
+ raise(Exception('Error: oorb_init failed (error=%d)' \
+ %(err.value)))
+ return
+
+
+
+def calendardate_to_mjd(y, m, d, timescale='TT'):
+ """
+ Convert a calendar date expressed as year, month, day.fraction to MJD.
+ timescale is either UTC, UT1 or TT. Output MJD is TAI
+
+ @param y: year number
+ @param m: month number
+ @param d: day number
+ @param timescale: either "UTC", "UT1", "TT" or "TAI"
+
+ Return
+ MJD TAI
+ """
+ # Init.
+ mjd = ctypes.c_double(0.)
+ err = ctypes.c_int(0)
+
+ # Simple sanity check.
+ if(y < MIN_YEAR or m < 0 or m > 12 or d < 0 or d >= 32 or not timescale):
+ raise(Exception('Bad input.'))
+
+ # Enter Fortran land.
+ ffi.oorb_calendardate_to_mjd_(ctypes.byref(ctypes.c_int(y)),
+ ctypes.byref(ctypes.c_int(m)),
+ ctypes.byref(ctypes.c_double(d)),
+ ctypes.byref(mjd),
+ ctypes.c_char_p(timescale),
+ ctypes.byref(err),
+ ctypes.c_int(len(timescale)))
+ if(err.value):
+ raise(Exception('Error: oorb_calendardate_to_mjd failed (error=%d)' \
+ %(err.value)))
+ return(mjd.value)
+
+
+
+def mjdutc_to_mjdtai(mjdIn):
+ """
+ Convert a calendar date expressed as MJD UTC to MJD TAI.
+
+ @param mjdIn: MJD UTC
+
+ Return
+ MJD TAI
+ """
+ return(_convertTimescale(mjdIn, fctn=ffi.oorb_mjdutc_to_mjdtai_))
+
+
+
+def mjdtai_to_mjdutc(mjdIn):
+ """
+ Convert a calendar date expressed as MJD TAI to MJD UTC.
+
+ @param mjdIn: MJD TAI
+
+ Return
+ MJD UTC
+ """
+ return(_convertTimescale(mjdIn, fctn=ffi.oorb_mjdtai_to_mjdutc_))
+
+
+
+def mjdtt_to_mjdtai(mjdIn):
+ """
+ Convert a calendar date expressed as MJD TT to MJD TAI. Remember that, in
+ first approximation, TT = TAI + 32.184 seconds.
+
+ @param mjdIn: MJD TT
+
+ Return
+ MJD TAI
+ """
+ return(_convertTimescale(mjdIn, fctn=ffi.oorb_mjdtt_to_mjdtai_))
+
+
+
+def mjdtai_to_mjdtt(mjdIn):
+ """
+ Convert a calendar date expressed as MJD TAI to MJD TT. Remember that, in
+ first approximation, TT = TAI + 32.184 seconds.
+
+ @param mjdIn: MJD TAI
+
+ Return
+ MJD TT
+ """
+ return(_convertTimescale(mjdIn, fctn=ffi.oorb_mjdtai_to_mjdtt_))
+
+
+
+def ranging_fast(trackId, coords, mjds, mags, obscodes, filters, elementType,
+ numOrbits):
+ """
+ Statistical ranging. Given a track (meaning an ID, coordinates, times, mags,
+ filters, obscodes), produce an orbit cloud of the given size.
+
+ Use a 2-body dynamical model.
+
+
+ @param trackId: track ID. Just a number, really.
+ @param coords: RA, Dec array. RA and Dec in decimal degrees.
+ @param mjds: MJD TAI array
+ @param mags: mag array
+ @param obscodes: obscode array. Obscodes are strings of length 4
+ @param filters: filter array. Filters are strings of length 1
+ @param elementType: desired type of orbital elements: keplerian or cartesian
+ @param numOrbits: number of ranging orbits to generate.
+
+ Return
+ List of numOrbits flattened orbits. Each orbits is a 15-element array of the
+ form
+ [trackId, *elements, epochMJD, Un-normalized p.d.f., Reduced chi2,
+ Regularized apr, *Jacobian, elementTypeIdx]
+ where
+ elements is the 6-element orbital element array.
+ Jacobian is the 3-element Jacobian array (diagonal of the 3x3 matrix).
+ """
+ return(_ranging(trackId,
+ coords,
+ mjds,
+ mags,
+ obscodes,
+ filters,
+ elementType,
+ numOrbits,
+ fctn=ffi.oorb_ranging_fast_))
+
+
+
+def ranging(trackId, coords, mjds, mags, obscodes, filters, elementType,
+ numOrbits):
+ """
+ Statistical ranging. Given a track (meaning an ID, coordinates, times, mags,
+ filters, obscodes), produce an orbit cloud of the given size.
+
+ Use the full n-body dynamical model.
+
+
+ @param trackId: track ID. Just a number, really.
+ @param coords: RA, Dec array. RA and Dec in decimal degrees.
+ @param mjds: MJD TAI array
+ @param mags: mag array
+ @param obscodes: obscode array. Obscodes are strings of length 4
+ @param filters: filter array. Filters are strings of length 1
+ @param elementType: desired type of orbital elements: keplerian or cartesian
+ @param numOrbits: number of ranging orbits to generate.
+
+ Return
+ List of numOrbits flattened orbits. Each orbits is a 15-element array of the
+ form
+ [trackId, *elements, epochMJD, Un-normalized p.d.f., Reduced chi2,
+ Regularized apr, *Jacobian, elementTypeIdx]
+ where
+ elements is the 6-element orbital element array.
+ Jacobian is the 3-element Jacobian array (diagonal of the 3x3 matrix).
+ """
+ return(_ranging(trackId,
+ coords,
+ mjds,
+ mags,
+ obscodes,
+ filters,
+ elementType,
+ numOrbits,
+ fctn=ffi.oorb_ranging_))
+
+
+
+def lsl_fast(trackId, coords, mjds, mags, obscodes, filters, rangingOrbits):
+ """
+ Orbital inversion using least squares with linearized covariances, that is,
+ fixing the resulting shape of the orbital-element pdf to a Gaussian.
+
+ Given a track (meaning an ID, coordinates, times, mags, filters, obscodes)
+ and a cloud of ranging orbits, produce a single orbit. The orbit cloud is a
+ list of lists of the same form as the output of the ranging routines.
+
+ Use a 2-body dynamical model.
+
+
+ @param trackId: track ID. Just a number, really.
+ @param coords: RA, Dec array. RA and Dec in decimal degrees.
+ @param mjds: MJD TAI array
+ @param mags: mag array
+ @param obscodes: obscode array. Obscodes are strings of length 4
+ @param filters: filter array. Filters are strings of length 1
+ @param rangingOrbits: orbit cloud generated by statistical ranging.
+
+ Return
+ Tuple of the form
+ (orb, cov)
+ where
+ orb is a single flatted orbit of the form
+ [track_id, *elements, epoch, H, G, el_type_index]
+ cov is the 6x6 covariance matrix
+ elements is the 6-element orbital element array of the same type as the
+ ranging orbit cloud elements.
+ el_type_index is an internal index. Leave it alone, unless you know what
+ you are doing.
+ """
+ return(_lsl(trackId,
+ coords,
+ mjds,
+ mags,
+ obscodes,
+ filters,
+ rangingOrbits,
+ fctn=ffi.oorb_lsl_fast_))
+
+
+
+def lsl(trackId, coords, mjds, mags, obscodes, filters, rangingOrbits):
+ """
+ Orbital inversion using least squares with linearized covariances, that is,
+ fixing the resulting shape of the orbital-element pdf to a Gaussian.
+
+ Given a track (meaning an ID, coordinates, times, mags, filters, obscodes)
+ and a cloud of ranging orbits, produce a single orbit. The orbit cloud is a
+ list of lists of the same form as the output of the ranging routines.
+
+ Use the full n-body dynamical model.
+
+
+ @param trackId: track ID. Just a number, really.
+ @param coords: RA, Dec array. RA and Dec in decimal degrees.
+ @param mjds: MJD TAI array
+ @param mags: mag array
+ @param obscodes: obscode array. Obscodes are strings of length 4
+ @param filters: filter array. Filters are strings of length 1
+ @param rangingOrbits: orbit cloud generated by statistical ranging.
+
+ Return
+ Tuple of the form
+ (orb, cov)
+ where
+ orb is a single flatted orbit of the form
+ [track_id, *elements, epoch, H, G, el_type_index]
+ cov is the 6x6 covariance matrix
+ elements is the 6-element orbital element array of the same type as the
+ ranging orbit cloud elements.
+ el_type_index is an internal index. Leave it alone, unless you know what
+ you are doing.
+ """
+ return(_lsl(trackId,
+ coords,
+ mjds,
+ mags,
+ obscodes,
+ filters,
+ rangingOrbits,
+ fctn=ffi.oorb_lsl_))
+
+
+
+def propagate_orbit_fast(orb, cov, mjd):
+ """
+ Propagate a single orbit to a given MJD TAI.
+
+ Use a 2-body dynamical model.
+
+
+ @param orb: flattened orbit in the same format as the output of lsl
+ @param cov: covariance 6x6 matrix (same format as lsl)
+ @param mjd: MJD TAI to propagate the input orbit to
+
+ Return
+ Tuple of the form
+ (newOrb, newCov)
+ where
+ newOrb is the new propagated orbit
+ newCov is the new propagated 6x6 covariance matrix
+ """
+ return(_propagate_orbit(orb,
+ cov,
+ mjd,
+ fctn=ffi.oorb_propagate_orbit_fast_))
+
+
+
+def propagate_orbit(orb, cov, mjd):
+ """
+ Propagate a single orbit to a given MJD TAI.
+
+ Use the full n-body dynamical model.
+
+
+ @param orb: flattened orbit in the same format as the output of lsl
+ @param cov: covariance 6x6 matrix (same format as lsl)
+ @param mjd: MJD TAI to propagate the input orbit to
+
+ Return
+ Tuple of the form
+ (newOrb, newCov)
+ where
+ newOrb is the new propagated orbit
+ newCov is the new propagated 6x6 covariance matrix
+ """
+ return(_propagate_orbit(orb,
+ cov,
+ mjd,
+ fctn=ffi.oorb_propagate_orbit_))
+
+
+
+def ephemeris_fast(orb, cov, obscode, n, step):
+ """
+ Compute n ephemeris step (fractional) days apart for the given orbit and
+ covariance matrix at the orbit epoch. To compute ephemeris from an arbitrary
+ MJD, propagate the orbit to that MJD first.
+
+ Use a 2-body dynamical model.
+
+
+ @param orb: flattened orbit in the same format as the output of lsl
+ @param cov: covariance 6x6 matrix (same format as lsl)
+ @param obscode: 4-letter MPC observatory code
+ @param n: number of ephemeris to compute
+ @param step: time separation in fractional days for successive ephemeris
+
+ Return
+ A list of n ephemeris. Each ephemeris is a list of the form
+ [dist, ra, dec, mag, mjd, raErr, decErr, smaa, smia, pa]
+ where
+ dist is the distance from Earth in AU
+ ra is RA in decimal degrees
+ dec is Dec in decimal degrees
+ mag is the predicted magnitude (NOT COMPUTED YET)
+ mjd is the MJD TAI of the ephemeris
+ raErr is the error on RA (NOT COMPUTED YET)
+ decErr is the error on Dec (NOT COMPUTED YET)
+ smaa is the positional error ellipse semi major axis (NOT COMPUTED YET)
+ smia is the positional error ellipse semi minor axis (NOT COMPUTED YET)
+ pa is the positional error ellipse position angle (NOT COMPUTED YET)
+ """
+ return(_ephemeris(orb,
+ cov,
+ obscode,
+ n,
+ step,
+ fctn=ffi.oorb_ephemeris_fast_))
+
+
+
+def ephemeris(orb, cov, obscode, n, step):
+ """
+ Compute n ephemeris step (fractional) days apart for the given orbit and
+ covariance matrix at the orbit epoch. To compute ephemeris from an arbitrary
+ MJD, propagate the orbit to that MJD first.
+
+ Use the full n-body dynamical model.
+
+
+ @param orb: flattened orbit in the same format as the output of lsl
+ @param cov: covariance 6x6 matrix (same format as lsl)
+ @param obscode: 4-letter MPC observatory code
+ @param n: number of ephemeris to compute
+ @param step: time separation in fractional days for successive ephemeris
+
+ Return
+ A list of n ephemeris. Each ephemeris is a list of the form
+ [dist, ra, dec, mag, mjd, raErr, decErr, smaa, smia, pa]
+ where
+ dist is the distance from Earth in AU
+ ra is RA in decimal degrees
+ dec is Dec in decimal degrees
+ mag is the predicted magnitude (NOT COMPUTED YET)
+ mjd is the MJD TAI of the ephemeris
+ raErr is the error on RA (NOT COMPUTED YET)
+ decErr is the error on Dec (NOT COMPUTED YET)
+ smaa is the positional error ellipse semi major axis (NOT COMPUTED YET)
+ smia is the positional error ellipse semi minor axis (NOT COMPUTED YET)
+ pa is the positional error ellipse position angle (NOT COMPUTED YET)
+ """
+ return(_ephemeris(orb,
+ cov,
+ obscode,
+ n,
+ step,
+ fctn=ffi.oorb_ephemeris_))
+
+
+
+def moid(orb, cov):
+ """
+ Compute the MOID given an orbit and its covariance matrix.
+
+
+ @param orb: flattened orbit in the same format as the output of lsl
+ @param cov: covariance 6x6 matrix (same format as lsl)
+
+ Return
+ moid
+ """
+ # Init.
+ err = ctypes.c_int(0)
+
+ # Simple sanity check.
+ if(orb == None or cov == None):
+ raise(Exception('Bad input.'))
+
+ # Allocate space for the output moid: a simple float.
+ moid = ctypes.c_double(-1.)
+
+ # Enter Fortran land.
+ ffi.oorb_moid_(orb.ctypes.data_as(ctypes.c_void_p),
+ cov.ctypes.data_as(ctypes.c_void_p),
+ ctypes.byref(moid),
+ ctypes.byref(err))
+ if(err.value):
+ raise(Exception('Error: oorb_moid failed (error=%d)' \
+ %(err.value)))
+ return(moid.value)
+
+
+
+def classification(rangingOrbits):
+ """
+ Compute the likelihood that a given ranging orbit cloud could represent a
+ given asteroid class.
+
+
+ @param rangingOrbits: orbit cloud generated by statistical ranging.
+
+ Return
+ Tuple of the form
+ (asteroid_classes, likelihoods)
+ where
+ asteroid_classes is a list of asteroid class names
+ likelihoods is a list of probability values
+ both lists are ordered so that likelihoods[j] corresponds to
+ asteroid_classes[j]
+ """
+ # Init.
+ err = ctypes.c_int(0)
+
+ # Simple sanity check.
+ if(rangingOrbits == None):
+ raise(Exception('Bad input.'))
+
+ # Allocate space for the output weights: a 1-d array of 17 doubles.
+ weights = numpy.zeros(shape=(17,), dtype='d', order='Fortran')
+
+ # Enter Fortran land.
+ ffi.priv_classification_(rangingOrbits.ctypes.data_as(ctypes.c_void_p),
+ ctypes.byref(ctypes.c_int(len(rangingOrbits))),
+ weights.ctypes.data_as(ctypes.c_void_p),
+ ctypes.byref(err))
+ return(ASTEROID_CLASSES, weights)
+
+
+
+# Internal routines.
+def _ranging(trackId, coords, mjds, mags, obscodes, filters, elementType,
+ numOrbits, fctn):
+ # Init.
+ err = ctypes.c_int(0)
+
+ # Simple sanity check.
+ if(coords == None or obscodes == None or filters == None or
+ elementType == None):
+ raise(Exception('Bad input.'))
+
+ # Make sure that each obscode element is indeed 4-char long and that filters
+ # are 1-char long.
+ obscodes = ['%-4s' %(o[:4]) for o in obscodes]
+ filters = ['%s' %(f[:1]) for f in filters]
+ # And make sure that elementType is 11 char long.
+ elementType = '%-11s' %(elementType[:11])
+
+ # Allocate space for the output orbits: an array of the form
+ # [[id, elements(0:5), epoch, Un-normalized p.d.f., Reduced chi2,
+ # Regularized apr, Jacobian det(0:2), elementTypeIdx], ] with numOrbits elements.
+ rawOrbits = numpy.zeros(shape=(numOrbits, 15), dtype='d', order='Fortran')
+ # orbits = numpy.zeros(shape=(15, numOrbits), dtype='d')
+ mjds = numpy.array(mjds, dtype='d', order='Fortran')
+ mags = numpy.array(mags, dtype='d', order='Fortran')
+ coords = numpy.array(coords, dtype='d', order='Fortran')
+ numCoords = len(mjds)
+
+ # Enter Fortran land.
+ fctn(ctypes.c_char_p(''.join(obscodes)),
+ ctypes.c_char_p(''.join(filters)),
+ ctypes.byref(ctypes.c_int(trackId)),
+ ctypes.byref(ctypes.c_int(numCoords)),
+ coords.ctypes.data_as(ctypes.c_void_p),
+ mjds.ctypes.data_as(ctypes.c_void_p),
+ mags.ctypes.data_as(ctypes.c_void_p),
+ ctypes.c_char_p(elementType),
+ ctypes.byref(ctypes.c_int(numOrbits)),
+ rawOrbits.ctypes.data_as(ctypes.c_void_p),
+ ctypes.byref(err),
+ ctypes.c_int(len(elementType)))
+ if(err.value):
+ raise(Exception('Error: %s failed (error=%d)' \
+ %(fctn.__name__[5:-1], err.value)))
+
+ # Now transpose the array and create a matrix.
+# for j in range(numOrbits):
+# for k in range(15):
+# orbits[j][k] = rawOrbits[numOrbits*k + j]
+ return(rawOrbits)
+
+
+
+def _lsl(trackId, coords, mjds, mags, obscodes, filters, rangingOrbits, fctn):
+ # Init.
+ err = ctypes.c_int(0)
+
+ # Simple sanity check.
+ if(coords == None or obscodes == None or filters == None or
+ rangingOrbits == None):
+ raise(Exception('Bad input.'))
+
+ # Make sure that each obscode element is indeed 4-char long and that filters
+ # are 1-char long.
+ obscodes = ['%-4s' %(o[:4]) for o in obscodes]
+ filters = ['%-1s' %(f[:1]) for f in filters]
+
+ # Allocate space for the output orbit: a 1-d array of the form
+ # [track_id, elements(1:6), epoch, H, G, el_type_index]
+ orbit = numpy.zeros(shape=(11,), dtype='d', order='Fortran')
+ # covariance is a 6x6 matrix of doubles:
+ cov = numpy.zeros(shape=(6, 6), dtype='d', order='Fortran')
+ sigmas = numpy.zeros(shape=(6,), dtype='d', order='Fortran')
+ corr = numpy.zeros(shape=(6, 6), dtype='d', order='Fortran')
+ mjds = numpy.array(mjds, dtype='d', order='Fortran')
+ mags = numpy.array(mags, dtype='d', order='Fortran')
+ coords = numpy.array(coords, dtype='d', order='Fortran')
+ numCoords = len(mjds)
+ numOrbits = len(rangingOrbits)
+
+ # Enter Fortran land.
+ fctn(ctypes.c_char_p(''.join(obscodes)),
+ ctypes.c_char_p(''.join(filters)),
+ ctypes.byref(ctypes.c_int(trackId)),
+ ctypes.byref(ctypes.c_int(numCoords)),
+ coords.ctypes.data_as(ctypes.c_void_p),
+ mjds.ctypes.data_as(ctypes.c_void_p),
+ mags.ctypes.data_as(ctypes.c_void_p),
+ rangingOrbits.ctypes.data_as(ctypes.c_void_p),
+ ctypes.byref(ctypes.c_int(numOrbits)),
+ orbit.ctypes.data_as(ctypes.c_void_p),
+ cov.ctypes.data_as(ctypes.c_void_p),
+ sigmas.ctypes.data_as(ctypes.c_void_p),
+ corr.ctypes.data_as(ctypes.c_void_p),
+ ctypes.byref(err))
+ if(err.value):
+ raise(Exception('Error: %s failed (error=%d)' \
+ %(fctn.__name__[5:-1], err.value)))
+ return(orbit, cov)
+
+
+
+def _propagate_orbit(orb, cov, mjd, fctn):
+ # Init.
+ err = ctypes.c_int(0)
+
+ # Simple sanity check.
+ if(orb == None or cov == None or not mjd):
+ raise(Exception('Bad input.'))
+
+ # Allocate space for the output orbit: a 1-d array of the form
+ # [track_id, elements(1:6), epoch, H, G, el_type_index]
+ newOrbit = numpy.zeros(shape=(11,), dtype='d', order='Fortran')
+ # covariance is a 6x6 matrix of doubles:
+ newCov = numpy.zeros(shape=(6, 6), dtype='d', order='Fortran')
+ newSigmas = numpy.zeros(shape=(6,), dtype='d', order='Fortran')
+ newCorr = numpy.zeros(shape=(6, 6), dtype='d', order='Fortran')
+
+ # Enter Fortran land.
+ fctn(orb.ctypes.data_as(ctypes.c_void_p),
+ cov.ctypes.data_as(ctypes.c_void_p),
+ ctypes.byref(ctypes.c_double(mjd)),
+ newOrbit.ctypes.data_as(ctypes.c_void_p),
+ newCov.ctypes.data_as(ctypes.c_void_p),
+ newSigmas.ctypes.data_as(ctypes.c_void_p),
+ newCorr.ctypes.data_as(ctypes.c_void_p),
+ ctypes.byref(err))
+ if(err.value):
+ raise(Exception('Error: %s failed (error=%d)' \
+ %(fctn.__name__[5:-1], err.value)))
+ return(newOrbit, newCov)
+
+
+
+def _ephemeris(orb, cov, obscode, n, step, fctn):
+ # Init.
+ err = ctypes.c_int(0)
+
+ # Simple sanity check.
+ if(orb == None or cov == None or not n or not step):
+ raise(Exception('Bad input.'))
+
+ # Allocate space for the output ephems: a n-d array of the form
+ # [[dist, ra, dec, mag, mjd, raErr, decErr, smaa, smia, pa], ]
+ ephems = numpy.zeros(shape=(n, 10), dtype='d', order='Fortran')
+
+ # Make sure obscode is 4-char long.
+ obscode = '%-4s' %(obscode[:4])
+
+ # Enter Fortran land.
+ fctn(orb.ctypes.data_as(ctypes.c_void_p),
+ cov.ctypes.data_as(ctypes.c_void_p),
+ ctypes.c_char_p(obscode),
+ ctypes.byref(ctypes.c_int(n)),
+ ctypes.byref(ctypes.c_double(step)),
+ ephems.ctypes.data_as(ctypes.c_void_p),
+ ctypes.byref(err),
+ ctypes.c_int(len(obscode)))
+ if(err.value):
+ raise(Exception('Error: %s failed (error=%d)' \
+ %(fctn.__name__[5:-1], err.value)))
+ return(ephems)
+
+
+
+def _convertTimescale(mjdIn, fctn):
+ # Init.
+ mjdOut = ctypes.c_double(-1.)
+ err = ctypes.c_int(0)
+
+ # Simple sanity check.
+ if(not mjdIn):
+ raise(Exception('Bad input.'))
+
+ # Enter Fortran land.
+ fctn(ctypes.byref(ctypes.c_double(mjdIn)),
+ ctypes.byref(mjdOut),
+ ctypes.byref(err))
+ if(err.value):
+ raise(Exception('Error: oorb_calendardate_to_mjd failed (error=%d)' \
+ %(err.value)))
+ return(mjdOut.value)
+
+
+
+
+
+
+
+
+if(__name__ == '__main__'):
+ import sys
+ # Do not use sys.stdout.write|flush because it confuses the fortran code :-)
+ # print is OK.
+
+ # All times in/out need to be TAI. The MJD constants used below are UTC and
+ # therefore need to be converted...
+
+ sys.stdout.write('oorb.init: ')
+ ef = os.path.join(os.environ['OORB_DATA'], 'de405.dat')
+ init(ef, verbosity=2)
+ sys.stdout.write('.')
+ sys.stdout.write(' (all tests ok)\n')
+
+ sys.stdout.write('oorb.calendardate_to_mjd: ')
+ mjd = calendardate_to_mjd(2008, 5, 31.35234, 'UTC')
+ assert(mjd == mjdtt_to_mjdtai(54617.353094444443))
+ sys.stdout.write('.')
+ mjd = calendardate_to_mjd(2008, 5, 31.39302, 'UTC')
+ assert(mjd == mjdtt_to_mjdtai(54617.393774444448))
+ sys.stdout.write('.')
+ mjd = calendardate_to_mjd(2008, 5, 31.43442, 'UTC')
+ assert(mjd == mjdtt_to_mjdtai(54617.435174444443))
+ sys.stdout.write('.')
+ sys.stdout.write(' (all tests ok)\n')
+
+ coords = [[253.64316666666659, 8.33333333333333306E-05, 19.381388888888889, 8.33333333333333306E-05],
+ [253.64175000000000, 8.33333333333333306E-05, 19.381833333333333, 8.33333333333333306E-05],
+ [253.64033333333330, 8.33333333333333306E-05, 19.382222222222218, 8.33333333333333306E-05]]
+ mjds = [mjdtt_to_mjdtai(54617.353094444443),
+ mjdtt_to_mjdtai(54617.393774444448),
+ mjdtt_to_mjdtai(54617.435174444443)]
+ mags = [23.699999999999999,
+ 23.699999999999999,
+ 23.800000000000001]
+ obscodes = ['568', ] * len(mags)
+ filters = ['r', ] * len(mags)
+
+
+
+ try:
+ rangingOrbits = ranging_fast(0, coords, mjds, mags, obscodes, filters,
+ 'keplerian', 5000)
+ for i in range(10):
+ print(rangingOrbits[i])
+ except:
+ print('ranging failed (which is normal for this data set).')
+
+
+
+ rangingOrbits = ranging_fast(0, coords, mjds, mags, obscodes, filters,
+ 'keplerian', 5000)
+ for i in range(10):
+ print(rangingOrbits[i])
+
+
+
+
+
+ coords = [[253.64316666666659, 8.3333333333333331e-05, 19.381388888888889, 8.3333333333333331e-05],
+ [253.64175000000000, 8.3333333333333331e-05, 19.381833333333333, 8.3333333333333331e-05],
+ [253.64033333333330, 8.3333333333333331e-05, 19.382222222222222, 8.3333333333333331e-05],
+ [253.37720833333330, 8.3333333333333331e-05, 19.449750000000002, 8.3333333333333331e-05],
+ [253.37575000000001, 8.3333333333333331e-05, 19.450166666666664, 8.3333333333333331e-05],
+ [253.34449999999998, 8.3333333333333331e-05, 19.456777777777777, 8.3333333333333331e-05],
+ [252.87362500000003, 8.3333333333333331e-05, 19.518361111111112, 8.3333333333333331e-05],
+ [252.87212500000004, 8.3333333333333331e-05, 19.518388888888889, 8.3333333333333331e-05],
+ [252.84200000000004, 8.3333333333333331e-05, 19.519861111111108, 8.3333333333333331e-05],
+ [252.84029166666667, 8.3333333333333331e-05, 19.519944444444445, 8.3333333333333331e-05],
+ [252.42179166666665, 8.3333333333333331e-05, 19.507138888888889, 8.3333333333333331e-05],
+ [252.42158333333333, 8.3333333333333331e-05, 19.507111111111112, 8.3333333333333331e-05],
+ [252.42124999999999, 8.3333333333333331e-05, 19.507055555555556, 8.3333333333333331e-05],
+ [252.42108333333331, 8.3333333333333331e-05, 19.507055555555556, 8.3333333333333331e-05],
+ [252.42091666666667, 8.3333333333333331e-05, 19.507027777777779, 8.3333333333333331e-05]]
+ mjds = [mjdtt_to_mjdtai(54617.353094444443),
+ mjdtt_to_mjdtai(54617.393774444448),
+ mjdtt_to_mjdtai(54617.435174444443),
+ mjdtt_to_mjdtai(54625.212504444447),
+ mjdtt_to_mjdtai(54625.256664444445),
+ mjdtt_to_mjdtai(54626.181794444448),
+ mjdtt_to_mjdtai(54640.367084444442),
+ mjdtt_to_mjdtai(54640.414734444443),
+ mjdtt_to_mjdtai(54641.353904444448),
+ mjdtt_to_mjdtai(54641.406674444443),
+ mjdtt_to_mjdtai(54655.124204444444),
+ mjdtt_to_mjdtai(54655.131814444445),
+ mjdtt_to_mjdtai(54655.145554444447),
+ mjdtt_to_mjdtai(54655.150364444446),
+ mjdtt_to_mjdtai(54655.155144444449)]
+ mags = [23.699999999999999,
+ 23.699999999999999,
+ 23.800000000000001,
+ 99.900000000000006,
+ 99.900000000000006,
+ 99.900000000000006,
+ 99.900000000000006,
+ 99.900000000000006,
+ 99.900000000000006,
+ 99.900000000000006,
+ 99.900000000000006,
+ 99.900000000000006,
+ 99.900000000000006,
+ 99.900000000000006,
+ 99.900000000000006]
+ obscodes = ['568',
+ '568',
+ '568',
+ '807',
+ '807',
+ '807',
+ '696',
+ '696',
+ '696',
+ '696',
+ '807',
+ '807',
+ '807',
+ '807',
+ '807']
+ filters = ['r',
+ 'r',
+ 'r',
+ '',
+ '',
+ '',
+ '',
+ '',
+ '',
+ '',
+ '',
+ '',
+ '',
+ '',
+ '']
+
+
+
+ sys.stdout.write('oorb.lsl: ')
+ sys.stdout.write('\n')
+ orb, cov = lsl(0, coords, mjds, mags, obscodes, filters, rangingOrbits)
+
+
+
+
+
+ sys.stdout.write('oorb.lsl_fast: ')
+ sys.stdout.write('\n')
+ orb, cov = lsl_fast(0, coords, mjds, mags, obscodes, filters, rangingOrbits)
+ # print(orb)
+ # print(cov)
+
+
+
+
+
+ mjd = mjdtt_to_mjdtai(54994.)
+ sys.stdout.write('oorb.propagate_orbit: ')
+ sys.stdout.write('\n')
+ newOrb, newCov = propagate_orbit(orb, cov, mjd)
+ # print(orb)
+ # print(cov)
+
+
+
+
+
+ mjd = mjdtt_to_mjdtai(54994.)
+ sys.stdout.write('oorb.propagate_orbit_fast: ')
+ sys.stdout.write('\n')
+ newOrb, newCov = propagate_orbit_fast(orb, cov, mjd)
+ # print(orb)
+ # print(cov)
+
+
+
+
+
+
+ obscode = '500'
+ n = 10
+ step = 1.
+ sys.stdout.write('oorb.ephemeris ')
+ sys.stdout.write('\n')
+ ephems = ephemeris(newOrb, newCov, obscode, n, step)
+ print(ephems)
+
+
+
+
+
+ obscode = '500'
+ n = 10
+ step = 1.
+ sys.stdout.write('oorb.ephemeris_fast ')
+ sys.stdout.write('\n')
+ ephems = ephemeris_fast(newOrb, newCov, obscode, n, step)
+ print(ephems)
+
+
+
+
+
+ moid = moid(newOrb, newCov)
+ print('moid: %.6f' %(moid))
+
+
+
+
+
+
+ classes, weights = classification(rangingOrbits)
+ # Write classification out.
+ print("Class Probability")
+ for j in range(len(weights)):
+ print(" %s %f" %(classes[j], weights[j]))
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
Index: trunk/mops/oorb/python/constants.py
===================================================================
--- trunk/mops/oorb/python/constants.py (revision 34646)
+++ trunk/mops/oorb/python/constants.py (revision 34646)
@@ -0,0 +1,49 @@
+#
+# LSST Data Management System
+# Copyright 2008, 2009 LSST Corporation.
+#
+# This product includes software developed by the
+# LSST Project (http://www.lsst.org/).
+#
+# This program 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.
+#
+# This program 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 LSST License Statement and
+# the GNU General Public License along with this program. If not,
+# see .
+#
+# F. Pierfederici
+arcsec_to_deg = 1. / 3600.
+ASTEROID_CLASSES = ("Apohele",
+ "NEO/Aten",
+ "NEO/Apollo",
+ "NEO/Amor",
+ "Aethra",
+ "Hungaria",
+ "MBO/Phocaea",
+ "MBO exc. Phocaea",
+ "Hilda",
+ "Jupiter Trojan",
+ "Centaur",
+ "TNO/Inner belt",
+ "TNO/Plutino",
+ "TNO/Classical",
+ "TNO/Outer belt",
+ "TNO/Scattered",
+ "The rest")
+
+# Other constants.
+MIN_YEAR = 0
+
+# Error codes.
+ERROR_INTERNAL = -100
+ERROR_BADINPUT = -1
+ERROR_BADEBV = -2
+
Index: trunk/mops/oorb/python/defaults.py
===================================================================
--- trunk/mops/oorb/python/defaults.py (revision 34646)
+++ trunk/mops/oorb/python/defaults.py (revision 34646)
@@ -0,0 +1,75 @@
+#
+# LSST Data Management System
+# Copyright 2008, 2009 LSST Corporation.
+#
+# This product includes software developed by the
+# LSST Project (http://www.lsst.org/).
+#
+# This program 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.
+#
+# This program 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 LSST License Statement and
+# the GNU General Public License along with this program. If not,
+# see .
+#
+# F. Pierfederici
+from constants import *
+
+
+
+initModel = "n-body"
+fullModel = "n-body"
+method = "continued fraction"
+method_sw = "continued fraction"
+step = 5.0
+initStep = 5.0
+a_max = 1000.0
+a_min = 0.00465424
+periapsis_max = -1.0
+periapsis_min = -1.0
+apoapsis_max = -1.0
+apoapsis_min = -1.0
+rho_max = -1.0
+rho_min = -1.0
+sor_type = 2
+norb = 5000
+norb_sw = 500
+ntrial = 10000000
+ntrial_sw = 200000
+niter = 3
+genwin_mult = 6.0
+accwin_mult = 4.0
+i = 0
+j = 0
+elementMask = True
+outlierRejection = False
+uniform = False
+regularized = False
+random_obs = False
+gaussian_rho = False
+pdf_ml_init = -1.0
+ephemStep = 0.0
+obscode = "500"
+timespan = 10.0
+mjd = 54994.0
+moid = -1.0
+sor_rho_init = [1.79769313486231571E+308, ] * 4
+sor_genwin_offset = [0.0, ] * 4
+stdev_arr = [0.3 * arcsec_to_deg, ] * 6
+outlierMultiplier = 3.0
+elementType = "keplerian"
+sor_norb = 5000
+sor_ntrial = 10000000
+sor_norb_sw = 500
+sor_ntrial_sw = 200000
+correctionFactor = 0.2
+niterMajorMax = 20
+niterMajorMin = 2
+niterMinor = 100
Index: trunk/mops/oorb/python/liboorb.f90
===================================================================
--- trunk/mops/oorb/python/liboorb.f90 (revision 34646)
+++ trunk/mops/oorb/python/liboorb.f90 (revision 34646)
@@ -0,0 +1,2611 @@
+!
+! LSST Data Management System
+! Copyright 2008, 2009 LSST Corporation, Mikael Granvik
+!
+! This product includes software developed by the
+! LSST Project (http://www.lsst.org/).
+!
+! This program 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.
+!
+! This program 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 LSST License Statement and
+! the GNU General Public License along with this program. If not,
+! see .
+!
+!
+! OpenOrb library
+! F. Pierfederici
+! M. Granvik
+!
+! Description
+!
+! Notes
+! error is a boolean global and is defined somewhere in liboorb.so!
+!
+!
+!
+! -------------------------------- IMPORTANT -----------------------------------
+! All angles coming in and out are in radians.
+! All times coming in and out in MJD TAI
+! -------------------------------- IMPORTANT -----------------------------------
+!
+!
+! The way I find out the max value used for errorCodes is:
+! $NF is the number of fields in the record and so it points to the last column.
+! awk '/errorCode = / { if (x < $NF) x = $NF} END { print x }' *.f90
+
+MODULE liboorb
+
+ USE Base_cl
+ ! use File_cl
+ ! use PhysicalParameters_cl
+ USE Time_cl
+ USE CartesianCoordinates_cl
+ USE SphericalCoordinates_cl
+ USE Observatories_cl
+ USE Orbit_cl
+ USE Observation_cl
+ USE Observations_cl
+ USE StochasticOrbit_cl
+ USE planetary_data
+ USE utilities
+ USE io
+
+ IMPLICIT NONE
+ SAVE
+ PRIVATE
+ TYPE (Observatories), PUBLIC :: obsies
+ ! Orbital elements that we support.
+ CHARACTER(len=11), DIMENSION(4), PUBLIC :: ORBITAL_ELEMENTS = (/ &
+ "keplerian ",&
+ "delaunay ",&
+ "poincare ",&
+ "equinoctial" &
+ /)
+ ! One can change the internal timescale to something other than TAI but let's
+ ! be quiet about it ;-)
+ CHARACTER(len=3), PARAMETER, PUBLIC :: internal_timescale = "TAI"
+
+ ! Public API
+ PUBLIC :: &
+ ! These are the functions we provide here.
+ init, &
+ propagateOrbit, &
+ ranging, &
+ ! mcmc, &
+ lsl, &
+ ephemeris, &
+ classification, &
+ computeMoid, &
+ dumpRangingOrbits, &
+ dumpLslOrbit, &
+ dumpEphemeris, &
+ readOpenOrbOrbit, &
+ readObsFile, &
+ obssFromCoords, &
+ exportRangingOrbits, &
+ exportLslOrbit, &
+ calendarDateToMjd, &
+ mjdConvert, &
+ rangingOrbitsToStochasticOrbit, &
+ lslOrbitToStochasticOrbit, &
+ exportEphemeris
+
+
+
+ ! Constants and global variables.
+
+
+ ! Code!
+CONTAINS
+
+
+ SUBROUTINE init(ephemFileName, verbosity, errorCode)
+ ! Initialize the OpenOrb module.
+ !
+ ! @param ephemFileName: full path of the JPL ephem file (usually
+ ! $OORB_DATA/JPL_ephemeris/de405.dat).
+ ! @param verbosity: verbosity level for OpenOrb calls [0, 5] (default 0)
+ ! @return errorCode: int error code. 0 = success, otherwise, failure.
+
+ ! Input/Output variables.
+ CHARACTER(len=*), INTENT(IN) :: ephemFileName
+ INTEGER, OPTIONAL, INTENT(in) :: verbosity
+ INTEGER, INTENT(OUT) :: errorCode
+
+ ! Variable declaration.
+ LOGICAL :: error = .FALSE.
+ TYPE (Time) :: t
+
+
+ ! Defaults.
+ error = .FALSE.
+ errorCode = 0
+
+ ! Verbosity levels.
+ IF(PRESENT(verbosity) .AND. verbosity >= 0 .AND. verbosity <= 5) THEN
+ info_verb = verbosity
+ err_verb = verbosity
+ ELSE
+ info_verb = 0
+ err_verb = 0
+ END IF
+
+ ! Init global variable OORB_DATA.
+ CALL setAccessToDataFiles()
+ IF(error) THEN
+ ! CALL errorMessage("oorb / init", "TRACE BACK (1)", 1)
+ errorCode = 1
+ RETURN
+ END IF
+
+ ! Init JPL ephemeris.
+ CALL JPL_ephemeris_init(error, filename=TRIM(ephemFileName))
+ IF(error) THEN
+ ! Error Could not initialize planetary ephemerides.
+ CALL errorMessage("oorb / init", "TRACE BACK (2)", 1)
+ errorCode = 1
+ RETURN
+ END IF
+
+ ! Read data from ET-UT.dat, TAI-UTC.dat, OBSCODE.dat
+ CALL NEW(t)
+ CALL NULLIFY(t)
+ CALL NEW(obsies)
+ IF(error) THEN
+ ! Error Could not initialize observatory codes.
+ errorCode = 45
+ RETURN
+ END IF
+
+ END SUBROUTINE init
+
+
+ SUBROUTINE ranging(obs_in, &
+ element_type, &
+ epoch_mjd, &
+ dyn_model, &
+ ! From here below it is either config file params or output
+ integration_step, &
+ perturbers, &
+ apriori_a_max, &
+ apriori_a_min, &
+ apriori_periapsis_max, &
+ apriori_periapsis_min, &
+ apriori_apoapsis_max, &
+ apriori_apoapsis_min, &
+ apriori_rho_max, &
+ apriori_rho_min, &
+ outlier_rejection, &
+ outlier_multiplier, &
+ sor_type_prm, &
+ sor_2point_method, &
+ sor_2point_method_sw, &
+ sor_norb, &
+ sor_norb_sw, &
+ sor_ntrial, &
+ sor_ntrial_sw, &
+ sor_niter, &
+ sor_rho_init, &
+ sor_genwin_multiplier, &
+ sor_genwin_offset, &
+ accwin_multiplier, &
+ gaussian_rho, &
+ pdf_ml_init, &
+ uniform, &
+ regularized, &
+ random_obs, &
+ outOrbit, &
+ errorCode)
+ ! Orbital inversion using statistical orbital ranging, that is,
+ ! without making any assumptions on the shape of the resulting
+ ! orbital-element pdf.
+
+ ! Input/Output variables.
+ ! Observations (i.e. DiASources) to be used as input.
+ TYPE (Observations), INTENT(inout) :: obs_in
+ ! Element type used in the orbit computation (default keplerian)
+ CHARACTER(len=*), OPTIONAL, INTENT(in) :: element_type
+ ! Computation epoch TAI (MJD)
+ ! If left unspecified and doing inversion, the midnight closest to the
+ ! observational mid-epoch will be used.
+ REAL(bp), OPTIONAL, INTENT(in) :: epoch_mjd
+ ! Dynamical model [ "2-body" | "n-body" ]. Defaults to "2-body".
+ CHARACTER(len=6), OPTIONAL, INTENT(in) :: dyn_model
+ ! Integrator step length (in days)
+ REAL(bp), INTENT(in) :: integration_step
+ LOGICAL, DIMENSION(:), POINTER :: perturbers
+ ! BAYESIAN (INFORMATIVE) A PRIORI PARAMETERS
+ ! Upper limit for semimajor axis in AU
+ REAL(bp), OPTIONAL, INTENT(in) :: apriori_a_max
+ ! Lower limit for semimajor axis in AU (default: r_Sun = 0.00465424 AU)
+ REAL(bp), OPTIONAL, INTENT(in) :: apriori_a_min
+ ! Upper limit for perihelion distance in AU
+ REAL(bp), OPTIONAL, INTENT(in) :: apriori_periapsis_max
+ ! Lower limit for perihelion distance in AU
+ REAL(bp), OPTIONAL, INTENT(in) :: apriori_periapsis_min
+ ! Upper limit for aphelion distance in AU
+ REAL(bp), OPTIONAL, INTENT(in) :: apriori_apoapsis_max
+ ! Lower limit for aphelion distance in AU
+ REAL(bp), OPTIONAL, INTENT(in) :: apriori_apoapsis_min
+ ! Upper limit for rho in AU (default: not defined)
+ REAL(bp), OPTIONAL, INTENT(in) :: apriori_rho_max
+ ! Lower limit for rho in AU (default: 10*r_Earth = 0.000425641 AU)
+ REAL(bp), OPTIONAL, INTENT(in) :: apriori_rho_min
+ ! Toggle outlier rejection (default false)
+ LOGICAL, OPTIONAL, INTENT(in) :: outlier_rejection
+ ! Outlier criterion (sigma multiplier) (default 3.0)
+ REAL(bp), OPTIONAL, INTENT(in) :: outlier_multiplier
+ ! Type of ranging (1=basic, 2=automatic, 3=stepwise)
+ INTEGER, INTENT(in) :: sor_type_prm
+ ! Method used for 2-point boundary-value problem.
+ ! [ continued fraction | p-iteration | n-body amoeba ]
+ CHARACTER(len=*),INTENT(in) :: sor_2point_method
+ ! Method for solving the two-point boundary-value problem during the
+ ! preliminary steps of stepwise Ranging
+ ! [ continued fraction | p-iteration | n-body amoeba ]
+ CHARACTER(len=*),INTENT(in) :: sor_2point_method_sw
+ ! Number of requested sample orbits
+ INTEGER, INTENT(in) :: sor_norb
+ ! Number of requested sample orbits for the preliminary steps of stepwise
+ ! ranging
+ INTEGER, INTENT(in) :: sor_norb_sw
+ ! Maximum number of trial orbits
+ INTEGER, INTENT(in) :: sor_ntrial
+ ! Maximum number of trial orbits for the preliminary steps of stepwise
+ ! ranging
+ INTEGER, INTENT(in) :: sor_ntrial_sw
+ ! Maximum number of iterations in automatic/stepwise Ranging
+ INTEGER, INTENT(in) :: sor_niter
+ ! [Lower topocentric range bound corresponding to the first date
+ ! (observer -> target) [AU],
+ ! Upper topocentric range bound corresponding to the first date
+ ! (observer -> target) [AU],
+ ! Lower topocentric range bound of the second date relative to the
+ ! generated range of the first date [AU],
+ ! Upper topocentric range bound of the second date relative to the
+ ! generated range of the first date [AU]]
+ ! (observer -> target) [AU]
+ REAL(bp), DIMENSION(4), INTENT(inout) :: sor_rho_init
+ ! Sigma multiplier for generation windows
+ REAL(bp), INTENT(in) :: sor_genwin_multiplier
+ ! Offset for generation windows RA1, Dec1, RA2, Dec2 [asec]
+ REAL(bp), DIMENSION(4), INTENT(in) :: sor_genwin_offset
+ ! Sigma multiplier for acceptance windows
+ REAL(bp), INTENT(in) :: accwin_multiplier
+ ! sor.rho.gauss
+ LOGICAL, OPTIONAL, INTENT(in) :: gaussian_rho
+ ! pdf.init (default -1.0)
+ REAL(bp), OPTIONAL, INTENT(in) :: pdf_ml_init
+ ! Toggle use of a uniform p.d.f. (default off)
+ LOGICAL, OPTIONAL, INTENT(in) :: uniform
+ ! Toggle use of regularization (default off)
+ LOGICAL, OPTIONAL, INTENT(in) :: regularized
+ ! Toggle use of random observation pair. Default is off, that is, use fixed
+ ! pair (cronologically first and last) (default false)
+ LOGICAL, OPTIONAL, INTENT(in) :: random_obs
+ ! Output Sthocastic orbit.
+ TYPE (StochasticOrbit), INTENT(out) :: outOrbit
+ ! Output error code
+ INTEGER, INTENT(out) :: errorCode
+
+ ! Internal variables.
+ ! Integrator (only used if dynamical model is different from 2-body).
+ ! [ "bulirsch-stoer" ]
+ CHARACTER(len=INTEGRATOR_LEN) :: integrator = "bulirsch-stoer"!
+ CHARACTER(len=DESIGNATION_LEN) :: id
+ REAL(bp) :: dt
+ TYPE (Time) :: t
+ ! Element type to be used in computations.
+ CHARACTER(len=ELEMENT_TYPE_LEN) :: elementType = "keplerian"
+ INTEGER :: j = 0
+ ! Bounds to be iterated in automatical versions
+ ! (rho1_lo, rho1_hi, rho2_lo, rho2_hi)
+ LOGICAL, DIMENSION(4) :: sor_iterate_bounds
+ TYPE (Time) :: epoch
+ CHARACTER(len=6) :: dynModel = "2-body"
+ REAL(bp) :: aprioriAMax = -1.0_bp
+ REAL(bp) :: aprioriAMin = 0.00465424_bp
+ REAL(bp) :: aprioriPeriapsisMax = -1.0_bp
+ REAL(bp) :: aprioriPeriapsisMin = -1.0_bp
+ REAL(bp) :: aprioriApoapsisMax = -1.0_bp
+ REAL(bp) :: aprioriApoapsisMin = -1.0_bp
+ REAL(bp) :: aprioriRhoMax = -1.0_bp
+ REAL(bp) :: aprioriRhoMin = -1.0_bp
+ LOGICAL :: outlierRejection = .FALSE.
+ REAL(bp) :: outlierMultiplier = 3.0_bp
+ LOGICAL :: gaussianRho = .FALSE.
+ REAL(bp) :: pdfMLInit = -1.0_bp
+ LOGICAL :: uniformPDF = .FALSE.
+ LOGICAL :: regularizedPDF = .FALSE.
+ LOGICAL :: randomObs = .FALSE.
+
+ ! TYPE (SphericalCoordinates), DIMENSION(:), POINTER :: scoords
+ ! REAL(8), DIMENSION(:,:,:), POINTER :: cov_matrices
+ ! integer :: i = 0
+ ! type (Time) :: scoords_t
+ ! CHARACTER(len=DESIGNATION_LEN) :: obsId = " "
+ ! type (Observation) :: obs_in_i
+ ! type (Time) :: obs_t
+
+
+ ! cov_matrices => getCovarianceMatrices(obs_in)
+ ! scoords => getObservationSCoords(obs_in)
+ ! obsId = getID(obs_in)
+ !
+ ! write(*, *) "ID: ", obsId
+ ! DO i=1,size(scoords)
+ ! obs_in_i = getObservation(obs_in, i)
+ ! scoords_t = getTime(scoords(i))
+ ! if(error) then
+ ! write(*, *) "Error getting Time object from SphCoords."
+ ! end if
+ ! obs_t = getTime(obs_in_i)
+ !
+ ! write(*, *) "mag: ", getMagnitude(obs_in_i)
+ ! write(*, *) "RA: ", getRA(obs_in_i)
+ ! write(*, *) "Dec: ", getDec(obs_in_i)
+ ! write(*, *) "MJD: ", getMJD(obs_t, internal_timescale)
+ ! write(*, *) "RA: ", getLongitude(scoords(i))
+ ! write(*, *) "Dec: ", getLatitude(scoords(i))
+ ! write(*, *) "MJD: ", getMJD(scoords_t, internal_timescale)
+ ! write(*, *) "COV: ", cov_matrices(i,:,:)
+ ! call nullify(scoords_t)
+ ! END DO
+ ! write(*, *) "element_type: ", element_type
+ ! write(*, *) "dyn_model: ", dyn_model
+ ! write(*, *) "integration_step: ", integration_step
+ ! write(*, *) "perturbers: ", perturbers
+ ! write(*, *) "apriori_a_max: ", apriori_a_max
+ ! write(*, *) "apriori_a_min: ", apriori_a_min
+ ! write(*, *) "apriori_rho_min: ", apriori_rho_min
+ ! write(*, *) "apriori_rho_max: ", apriori_rho_max
+ ! write(*, *) "outlier_rejection: ", outlier_rejection
+ ! write(*, *) "outlier_multiplier: ", outlier_multiplier
+ ! write(*, *) "sor_type_prm: ", sor_type_prm
+ ! write(*, *) "sor_2point_method: ", sor_2point_method
+ ! write(*, *) "sor_2point_method_sw: ", sor_2point_method_sw
+ ! write(*, *) "sor_norb: ", sor_norb
+ ! write(*, *) "sor_norb_sw: ", sor_norb_sw
+ ! write(*, *) "sor_ntrial: ", sor_ntrial
+ ! write(*, *) "sor_ntrial_sw: ", sor_ntrial_sw
+ ! write(*, *) "sor_niter: ", sor_niter
+ ! write(*, *) "sor_rho_init: ", sor_rho_init
+ ! write(*, *) "sor_genwin_multiplier: ", sor_genwin_multiplier
+ ! write(*, *) "sor_genwin_offset: ", sor_genwin_offset
+ ! write(*, *) "accwin_multiplier: ", accwin_multiplier
+ ! write(*, *) "gaussian_rho: ", gaussian_rho
+ ! write(*, *) "pdf_ml_init: ", pdf_ml_init
+ ! write(*, *) "uniform: ", uniform
+ ! write(*, *) "regularized: ", regularized
+ ! write(*, *) "random_obs: ", random_obs
+
+ ! Init optional and output vars.
+ errorCode = 0
+ error = .FALSE.
+ IF(PRESENT(element_type)) THEN
+ elementType = element_type
+ END IF
+ IF(.NOT.PRESENT(epoch_mjd)) THEN
+ CALL NULLIFY(epoch)
+ ELSE
+ CALL NEW(epoch, epoch_mjd, internal_timescale)
+ END IF
+ IF(PRESENT(dyn_model) .AND. &
+ dyn_model .NE. "2-body" .AND. &
+ dyn_model .NE. "n-body") THEN
+ ! Error: unsupported dynamical model.
+ errorCode = 21
+ RETURN
+ ELSEIF(dyn_model .EQ. "n-body") THEN
+ dynModel = "n-body"
+ END IF
+ IF(PRESENT(apriori_a_max)) THEN
+ aprioriAMax = apriori_a_max
+ END IF
+ IF(PRESENT(apriori_a_min)) THEN
+ aprioriAMin = apriori_a_min
+ END IF
+ IF(PRESENT(apriori_periapsis_max)) THEN
+ aprioriPeriapsisMax = apriori_periapsis_max
+ END IF
+ IF(PRESENT(apriori_periapsis_min)) THEN
+ aprioriPeriapsisMin = apriori_periapsis_min
+ END IF
+ IF(PRESENT(apriori_apoapsis_max)) THEN
+ aprioriApoapsisMax = apriori_apoapsis_max
+ END IF
+ IF(PRESENT(apriori_apoapsis_min)) THEN
+ aprioriApoapsisMin = apriori_apoapsis_min
+ END IF
+ IF(PRESENT(apriori_rho_max)) THEN
+ aprioriRhoMax = apriori_rho_max
+ END IF
+ IF(PRESENT(apriori_rho_min)) THEN
+ aprioriRhoMin = apriori_rho_min
+ END IF
+ IF(PRESENT(outlier_rejection)) THEN
+ outlierRejection = outlier_rejection
+ END IF
+ IF(PRESENT(outlier_multiplier)) THEN
+ outlierMultiplier = outlier_multiplier
+ END IF
+ IF(PRESENT(gaussian_rho)) THEN
+ gaussianRho = gaussian_rho
+ END IF
+ IF(PRESENT(pdf_ml_init)) THEN
+ pdfMLInit = pdf_ml_init
+ END IF
+ IF(PRESENT(uniform)) THEN
+ uniformPDF = uniform
+ END IF
+ IF(PRESENT(regularized)) THEN
+ regularizedPDF = regularized
+ END IF
+ IF(PRESENT(random_obs)) THEN
+ randomObs = random_obs
+ END IF
+
+ ! Init global error variables.
+ error = .FALSE.
+
+ ! Init other variables.
+ j = 0
+
+ ! sor_iterate_bounds
+ sor_iterate_bounds(1) = .TRUE.
+ sor_iterate_bounds(2) = .TRUE.
+ sor_iterate_bounds(3) = .TRUE.
+ sor_iterate_bounds(4) = .TRUE.
+
+ id = getID(obs_in)
+ IF (error) THEN
+ ! Error in getID()
+ errorCode = 2
+ RETURN
+ END IF
+
+ dt = getObservationalTimespan(obs_in)
+ IF (error) THEN
+ ! Error in getObservationalTimeInterval()
+ errorCode = 3
+ RETURN
+ END IF
+
+ ! write(*, *) "dt: ", dt
+
+
+ IF (sor_rho_init(3) > HUGE(sor_rho_init(3))/2) THEN
+ ! Initialize the rho2-rho1 range based on the observational timespan.
+ IF (dt > 10) THEN
+ sor_rho_init(3) = -0.5_bp
+ ELSE
+ sor_rho_init(3) = -0.05_bp*dt
+ END IF
+ sor_rho_init(4) = -sor_rho_init(3)
+ END IF
+
+ ! write(*, *) "sor_rho_init: ", sor_rho_init
+
+
+ IF (.NOT.exist(epoch)) THEN
+ CALL epochFromObservations(obs_in, t, errorCode)
+ IF(errorCode /= 0) THEN
+ RETURN
+ END IF
+ ELSE
+ CALL NULLIFY(t)
+ t = copy(epoch)
+ END IF
+ CALL NEW(outOrbit, obs_in)
+ IF (error) THEN
+ ! Error in new(outOrbit)
+ errorCode = 8
+ RETURN
+ END IF
+ CALL setParameters(outOrbit, dyn_model=dynModel, perturbers=perturbers, &
+ integrator=integrator, integration_step=integration_step, &
+ outlier_rejection=outlierRejection, &
+ outlier_multiplier=outlierMultiplier, t_inv=t, &
+ element_type=elementType, &
+ regularized_pdf=regularizedPDF, uniform_pdf=uniformPDF, &
+ pdf_ml=pdfMLInit, accept_multiplier=accwin_multiplier, &
+ apriori_a_max=aprioriAMax, apriori_a_min=aprioriAMin, &
+ apriori_periapsis_max=aprioriPeriapsisMax, &
+ apriori_periapsis_min=aprioriPeriapsisMin, &
+ apriori_apoapsis_max=aprioriApoapsisMax, &
+ apriori_apoapsis_min=aprioriApoapsisMin, &
+ apriori_rho_min=aprioriRhoMin, &
+ sor_2point_method=sor_2point_method, &
+ sor_2point_method_sw=sor_2point_method_sw, sor_norb=sor_norb, &
+ sor_ntrial=sor_ntrial, sor_rho1_l=sor_rho_init(1), &
+ sor_rho1_u=sor_rho_init(2), sor_rho2_l=sor_rho_init(3), &
+ sor_rho2_u=sor_rho_init(4), sor_iterate_bounds=sor_iterate_bounds, &
+ sor_random_obs_selection=randomObs, gaussian_pdf=gaussianRho, &
+ sor_generat_multiplier=sor_genwin_multiplier, &
+ sor_generat_offset=sor_genwin_offset)
+ IF (error) THEN
+ ! Error in setParameters()
+ errorCode = 9
+ RETURN
+ END IF
+
+ ! write(*, *) "dynModel: ", dynModel
+ ! write(*, *) "perturbers: ", perturbers
+ ! write(*, *) "integrator: ", integrator
+ ! write(*, *) "integration_step: ", integration_step
+ ! write(*, *) "outlierRejection: ", outlierRejection
+ ! write(*, *) "outlierMultiplier: ", outlierMultiplier
+ ! write(*, *) "t (MJD TAI): ", getMjd(t, internal_timescale)
+ ! write(*, *) "elementType: ", elementType
+ ! write(*, *) "regularizedPDF: ", regularizedPDF
+ ! write(*, *) "uniformPDF: ", uniformPDF
+ ! write(*, *) "pdfMLInit: ", pdfMLInit
+ ! write(*, *) "accwin_multiplier: ", accwin_multiplier
+ ! write(*, *) "aprioriAMax: ", aprioriAMax
+ ! write(*, *) "aprioriAMin: ", aprioriAMin
+ ! write(*, *) "aprioriPeriapsisMax: ", aprioriPeriapsisMax
+ ! write(*, *) "aprioriPeriapsisMin: ", aprioriPeriapsisMin
+ ! write(*, *) "aprioriApoapsisMax: ", aprioriApoapsisMax
+ ! write(*, *) "aprioriApoapsisMin: ", aprioriApoapsisMin
+ ! write(*, *) "aprioriRhoMin: ", aprioriRhoMin
+ ! write(*, *) "sor_2point_method: ", sor_2point_method
+ ! write(*, *) "sor_2point_method_sw: ", sor_2point_method_sw
+ ! write(*, *) "sor_norb: ", sor_norb
+ ! write(*, *) "sor_ntrial: ", sor_ntrial
+ ! write(*, *) "sor_rho_init(1): ", sor_rho_init(1)
+ ! write(*, *) "sor_rho_init(2): ", sor_rho_init(2)
+ ! write(*, *) "sor_rho_init(3): ", sor_rho_init(3)
+ ! write(*, *) "sor_rho_init(4): ", sor_rho_init(4)
+ ! write(*, *) "sor_iterate_bounds: ", sor_iterate_bounds
+ ! write(*, *) "randomObs: ", randomObs
+ ! write(*, *) "gaussianRho: ", gaussianRho
+ ! write(*, *) "sor_genwin_multiplier: ", sor_genwin_multiplier
+ ! write(*, *) "sor_genwin_offset: ", sor_genwin_offset
+
+
+
+ SELECT CASE (sor_type_prm)
+ CASE (1)
+ CALL statisticalRanging(outOrbit)
+ CASE (2)
+ CALL setParameters(outOrbit, sor_niter=sor_niter)
+ IF (error) THEN
+ ! Error in setParameters()
+ errorCode = 10
+ RETURN
+ END IF
+ CALL autoStatisticalRanging(outOrbit)
+ CASE (3)
+ CALL setParameters(outOrbit, &
+ sor_norb_sw=sor_norb_sw, &
+ sor_ntrial_sw=sor_ntrial_sw, &
+ sor_niter=sor_niter)
+ IF (error) THEN
+ ! Error in setParameters()
+ errorCode = 11
+ RETURN
+ END IF
+ CALL stepwiseRanging(outOrbit, nobs_max=-1)
+ CASE default
+ ! Error: unknown type of ranging
+ errorCode = 12
+ RETURN
+ END SELECT
+
+ ! Did we get any error?
+ IF (error) THEN
+ ! Error
+ errorCode = 13
+ error = .FALSE.
+ CALL NULLIFY(outOrbit)
+ RETURN
+ END IF
+
+ ! Cleanup everything
+ RETURN
+ END SUBROUTINE ranging
+
+
+ SUBROUTINE mcmc
+ WRITE (*,*) "mcmc"
+ RETURN
+ END SUBROUTINE mcmc
+
+
+ SUBROUTINE lsl(obs_in, &
+ element_type, &
+ epoch_mjd, &
+ dyn_model, &
+ dyn_model_init, &
+ ! From here below it is either config file params or output
+ integration_step, &
+ integration_step_init, &
+ perturbers, &
+ ls_correction_factor, &
+ ls_element_mask, &
+ ls_niter_major_max, &
+ ls_niter_major_min, &
+ ls_niter_minor, &
+ outlier_rejection, &
+ outlier_multiplier, &
+ accwin_multiplier, &
+ inStochOrbit, &
+ outStochOrbit, &
+ errorCode)
+ ! Orbital inversion using least squares with linearized
+ ! covariances, that is, fixing the resulting shape of
+ ! the orbital-element pdf to a Gaussian.
+
+ ! Input/Output variables.
+ ! Observations (i.e. DiASources) to be used as input.
+ TYPE (Observations), INTENT(inout) :: obs_in
+ ! Element type used in the orbit computation (default keplerian)
+ CHARACTER(len=*), OPTIONAL, INTENT(in) :: element_type
+ ! Computation epoch TAI (MJD)
+ ! If left unspecified and doing inversion, the midnight closest to the
+ ! observational mid-epoch will be used.
+ REAL(bp), OPTIONAL, INTENT(in) :: epoch_mjd
+ ! Dynamical model [ "2-body" | "n-body" ]. Defaults to "n-body".
+ CHARACTER(len=6), OPTIONAL, INTENT(in) :: dyn_model
+ ! Dynamical model for initial orbit [ "2-body" | "n-body" ]. Defaults to
+ ! "2-body".
+ CHARACTER(len=6), OPTIONAL, INTENT(in) :: dyn_model_init
+ ! Integrator step length (in days)
+ REAL(bp), INTENT(in) :: integration_step
+ ! Integrator step length (in days) for initial orbit
+ REAL(bp), INTENT(in) :: integration_step_init
+ ! Perturbers array (planets and moon).
+ LOGICAL, DIMENSION(:), POINTER :: perturbers
+ ! Correction factor for the iterative solution of the least-squares
+ ! problem [0:1] (default 0.2)
+ REAL(bp), OPTIONAL, INTENT(in) :: ls_correction_factor
+ ! Elements to included in the correction process (indicated with T). Fixed
+ ! elements should be marked with F. (default all true)
+ LOGICAL, DIMENSION(6), OPTIONAL, INTENT(in) :: ls_element_mask
+ ! Maximum number of major iterations (default 20)
+ INTEGER, OPTIONAL, INTENT(in) :: ls_niter_major_max
+ ! Minimum number of major iterations (default 2)
+ INTEGER, OPTIONAL, INTENT(in) :: ls_niter_major_min
+ ! Number of iterations per scheme (default 10)
+ INTEGER, OPTIONAL, INTENT(in) :: ls_niter_minor
+ ! Toggle outlier rejection (default false)
+ LOGICAL, OPTIONAL, INTENT(in) :: outlier_rejection
+ ! Outlier criterion (sigma multiplier) (default 3.0)
+ REAL(bp), OPTIONAL, INTENT(in) :: outlier_multiplier
+ ! Sigma multiplier for acceptance windows
+ REAL(bp), INTENT(in) :: accwin_multiplier
+ ! Input Sthocastic orbit from ranging.
+ TYPE (StochasticOrbit), INTENT(in) :: inStochOrbit
+ ! Output Stichastic Orbit.
+ TYPE (StochasticOrbit), INTENT(out) :: outStochOrbit
+ ! Output error code
+ INTEGER, INTENT(out) :: errorCode
+
+ ! Internal variables.
+ INTEGER :: nobs = 0
+ INTEGER :: norb = 0
+ TYPE (Orbit), DIMENSION(:), POINTER :: orb_arr
+ TYPE (Time) :: t
+ ! Internal variables.
+ ! Integrator (only used if dynamical model is different from 2-body).
+ ! [ "bulirsch-stoer" ]
+ CHARACTER(len=INTEGRATOR_LEN) :: integrator = "bulirsch-stoer"
+ CHARACTER(len=INTEGRATOR_LEN) :: integratorInit = "bulirsch-stoer"
+ INTEGER :: err = 0
+ ! Element type to be used in computations.
+ CHARACTER(len=ELEMENT_TYPE_LEN) :: elementType = "keplerian"
+ INTEGER :: j = 0
+ TYPE (Time) :: epoch
+ CHARACTER(len=6) :: dynModel = "n-body"
+ CHARACTER(len=6) :: dynModelInit = "2-body"
+ LOGICAL :: outlierRejection = .FALSE.
+ REAL(bp) :: outlierMultiplier = 3.0_bp
+ LOGICAL, DIMENSION(6) :: lsElementMask = .TRUE.
+ INTEGER :: lsNIterMajorMax = 20
+ INTEGER :: lsNIterMajorMin = 2
+ INTEGER :: lsNIterMinor = 10
+ REAL(bp) :: lsCorrectionFactor = 0.2_bp
+
+ ! Init
+ CALL NULLIFY(t)
+ errorCode = 0
+ error = .FALSE.
+ IF(PRESENT(element_type)) THEN
+ elementType = element_type
+ END IF
+ IF(.NOT.PRESENT(epoch_mjd)) THEN
+ CALL NULLIFY(epoch)
+ ELSE
+ CALL NEW(epoch, epoch_mjd, internal_timescale)
+ END IF
+ IF(PRESENT(dyn_model) .AND. &
+ dyn_model .NE. "2-body" .AND. &
+ dyn_model .NE. "n-body") THEN
+ ! Error: unsupported dynamical model.
+ errorCode = 21
+ RETURN
+ ELSEIF(dyn_model .EQ. "2-body") THEN
+ dynModel = "2-body"
+ END IF
+ IF(PRESENT(dyn_model_init) .AND. &
+ dyn_model_init .NE. "2-body" .AND. &
+ dyn_model_init .NE. "n-body") THEN
+ ! Error: unsupported dynamical model.
+ errorCode = 21
+ RETURN
+ ELSEIF(dyn_model_init .EQ. "n-body") THEN
+ dynModelInit = "n-body"
+ END IF
+ IF(PRESENT(ls_correction_factor)) THEN
+ lsCorrectionFactor = ls_correction_factor
+ END IF
+ IF(PRESENT(ls_element_mask)) THEN
+ lsElementMask = ls_element_mask
+ END IF
+ IF(PRESENT(ls_niter_major_max)) THEN
+ lsNIterMajorMax = ls_niter_major_max
+ END IF
+ IF(PRESENT(ls_niter_major_min)) THEN
+ lsNIterMajorMin = ls_niter_major_min
+ END IF
+ IF(PRESENT(ls_niter_minor)) THEN
+ lsNIterMinor = ls_niter_minor
+ END IF
+ IF(PRESENT(outlier_rejection)) THEN
+ outlierRejection = outlier_rejection
+ END IF
+ IF(PRESENT(outlier_multiplier)) THEN
+ outlierMultiplier = outlier_multiplier
+ END IF
+
+ ! Make sure that we have at least 4 observations!
+ nobs = getNrOfObservations(obs_in)
+ IF (error) THEN
+ ! Error in getNrOfObservations()
+ errorCode = 22
+ RETURN
+ END IF
+ IF (nobs < 4) THEN
+ ! Error: Too few observations!
+ errorCode = 23
+ RETURN
+ END IF
+
+ ! Get the sample orbits from ranging.
+ IF (containsSampledPDF(inStochOrbit)) THEN
+ orb_arr => getSampleOrbits(inStochOrbit)
+ IF (error) THEN
+ ! Error in getSampleOrbits()
+ errorCode = 16
+ RETURN
+ END IF
+ norb = SIZE(orb_arr)
+ ELSE
+ ALLOCATE(orb_arr(1))
+ orb_arr(1) = getNominalOrbit(inStochOrbit)
+ IF (error) THEN
+ ! Error in getNominalOrbit()
+ errorCode = 24
+ RETURN
+ END IF
+ norb = 1
+ END IF
+ IF (norb == 0) THEN
+ CALL errorMessage("oorb4mops / lsl", &
+ "Initial orbit not available.", 1)
+ STOP
+ END IF
+
+ IF (.NOT.exist(epoch)) THEN
+ CALL epochFromObservations(obs_in, t, errorCode)
+ IF(errorCode /= 0) THEN
+ RETURN
+ END IF
+ ELSE
+ t = copy(epoch)
+ END IF
+
+
+
+ ! write(*, *) "element_type: ", elementType
+ ! write(*, *) "dyn_model: ", dynModel
+ ! write(*, *) "dyn_model_init: ", dynModelInit
+ ! write(*, *) "integration_step: ", integration_step
+ ! write(*, *) "integration_step_init: ", integration_step_init
+ ! write(*, *) "perturbers: ", perturbers
+ ! write(*, *) "ls_correction_factor: ", lsCorrectionFactor
+ ! write(*, *) "ls_element_mask: ", lsElementMask
+ ! write(*, *) "ls_niter_major_max: ", lsNIterMajorMax
+ ! write(*, *) "ls_niter_major_min: ", lsNIterMajorMin
+ ! write(*, *) "ls_niter_minor: ", lsNiterMinor
+ ! write(*, *) "outlier_rejection: ", outlierRejection
+ ! write(*, *) "outlier_multiplier: ", outlierMultiplier
+ ! write(*, *) "accwin_multiplier: ", accwin_multiplier
+
+
+
+ ! Create the output Stochastic Orbit.
+ CALL NEW(outStochOrbit, obs_in)
+ IF (error) THEN
+ ! Error in createing a new Stochasic Orbit
+ errorCode = 8
+ RETURN
+ END IF
+ CALL setParameters(outStochOrbit, &
+ dyn_model=dynModel, &
+ perturbers=perturbers, &
+ integrator=integrator, &
+ integration_step=integration_step, &
+ outlier_rejection=outlierRejection, &
+ outlier_multiplier=outlierMultiplier, &
+ t_inv=t, &
+ element_type=elementType, &
+ accept_multiplier=accwin_multiplier, &
+ ls_correction_factor=lsCorrectionFactor, &
+ ls_element_mask=lsElementMask, &
+ ls_niter_major_max=lsNIterMajorMax, &
+ ls_niter_major_min=lsNIterMajorMin, &
+ ls_niter_minor=lsNiterMinor)
+ IF (error) THEN
+ ! Error in setParameters()
+ errorCode = 9
+ RETURN
+ END IF
+
+ DO j=1,SIZE(orb_arr,dim=1)
+ CALL setParameters(orb_arr(j), &
+ dyn_model=dynModelInit, &
+ perturbers=perturbers, &
+ integrator=integratorInit, &
+ integration_step=integration_step_init)
+ IF (error) THEN
+ ! Error in setParameters()
+ errorCode = 9
+ RETURN
+ END IF
+
+ CALL propagate(orb_arr(j), t)
+ IF (error) THEN
+ ! Error in propagate()
+ errorCode = 25
+ RETURN
+ END IF
+ CALL setParameters(orb_arr(j), &
+ dyn_model=dynModel, &
+ perturbers=perturbers, &
+ integrator=integrator, &
+ integration_step=integration_step)
+ IF (error) THEN
+ ! Error in setParameters()
+ errorCode = 9
+ RETURN
+ END IF
+
+ CALL levenbergMarquardt(outStochOrbit, orb_arr(j))
+ IF (.NOT.error) THEN
+ EXIT
+ ELSE IF (j < norb) THEN
+ error = .FALSE.
+ END IF
+ END DO
+ IF (error) THEN
+ ! Error: least squares fit failed.
+ errorCode = 26
+ RETURN
+ END IF
+
+ ! Cleanup and quit.
+ DEALLOCATE(orb_arr, stat=err)
+ IF (err /= 0) THEN
+ ! Error in deallocating orbit array.
+ errorCode = 27
+ END IF
+
+ END SUBROUTINE lsl
+
+
+ SUBROUTINE propagateOrbit(storb, &
+ dyn_model, &
+ integration_step, &
+ perturbers, &
+ epoch_mjd, &
+ errorCode)
+ ! Input/Output variables.
+ TYPE(StochasticOrbit), INTENT(inout) :: storb
+ ! Dynamical model [ "2-body" | "n-body" ]. Defaults to "2-body".
+ CHARACTER(len=6), OPTIONAL, INTENT(in) :: dyn_model
+ ! Integrator step length (in days)
+ REAL(bp), INTENT(in) :: integration_step
+ LOGICAL, DIMENSION(:), POINTER :: perturbers
+ ! Propagate the orbit to epoch_mjd (TAI)
+ REAL(bp), INTENT(in) :: epoch_mjd
+ ! Output error code
+ INTEGER, INTENT(out) :: errorCode
+
+ ! Internal variables.
+ ! Integrator (only used if dynamical model is different from 2-body).
+ ! [ "bulirsch-stoer" ]
+ CHARACTER(len=INTEGRATOR_LEN) :: integrator = "bulirsch-stoer"!
+ TYPE(Time) :: epoch
+ CHARACTER(len=6) :: dynModel = "2-body"
+
+
+ ! Init vars
+ error = .FALSE.
+ errorCode = 0
+ CALL NULLIFY(epoch)
+ IF (epoch_mjd > 0.0_bp) THEN
+ CALL NEW(epoch, epoch_mjd, internal_timescale)
+ IF (error) THEN
+ ! Error in creating a new epoch
+ errorCode = 39
+ RETURN
+ END IF
+ END IF
+ IF (.NOT.exist(epoch)) THEN
+ ! Error creating a viable epoch.
+ errorCode = 40
+ RETURN
+ END IF
+ IF(PRESENT(dyn_model) .AND. &
+ dyn_model .NE. "2-body" .AND. &
+ dyn_model .NE. "n-body") THEN
+ ! Error: unsupported dynamical model.
+ errorCode = 21
+ RETURN
+ ELSEIF(dyn_model .EQ. "n-body") THEN
+ dynModel = "n-body"
+ END IF
+
+ ! Set integration parameters
+ CALL setParameters(storb, &
+ dyn_model=dynModel, &
+ perturbers=perturbers, &
+ integrator=integrator, &
+ integration_step=integration_step)
+ IF (error) THEN
+ ! Error in setParameters()
+ errorCode = 37
+ RETURN
+ END IF
+
+ ! Compute topocentric ephemerides
+ CALL propagate(storb, epoch)
+ IF (error) THEN
+ ! Error in propagate()
+ errorCode = 41
+ RETURN
+ END IF
+
+ END SUBROUTINE propagateOrbit
+
+
+ SUBROUTINE ephemeris(storb, &
+ element_type, &
+ dyn_model, &
+ integration_step, &
+ perturbers, &
+ obsy_code, &
+ timespan, &
+ step, &
+ ephemerides, &
+ cov_arr, &
+ pdfs_arr, &
+ observers, &
+ errorCode)
+ ! Input/Output variables.
+ TYPE(StochasticOrbit), INTENT(inout) :: storb
+ ! Element type used in the orbit computation (default keplerian)
+ CHARACTER(len=*), OPTIONAL, INTENT(in) :: element_type
+ ! Dynamical model [ "2-body" | "n-body" ]. Defaults to "2-body".
+ CHARACTER(len=6), OPTIONAL, INTENT(in) :: dyn_model
+ ! Integrator step length (in days)
+ REAL(bp), INTENT(inout) :: integration_step
+ LOGICAL, DIMENSION(:), POINTER, OPTIONAL :: perturbers
+ ! IAU/MPC designated observatory code.
+ CHARACTER(len=OBSY_CODE_LEN), INTENT(in) :: obsy_code
+ ! Range in days for ephemeris production.
+ REAL(bp), INTENT(in) :: timespan
+ ! Step in days for ephemeris production.
+ REAL(bp), INTENT(inout) :: step
+ ! Output ephem array (intent(inout)).
+ TYPE (SphericalCoordinates), DIMENSION(:,:),POINTER :: ephemerides
+ ! Ephem uncertainty matrices (intent(inout)).
+ REAL(bp), DIMENSION(:,:,:), POINTER :: cov_arr
+ REAL(bp), DIMENSION(:,:), POINTER :: pdfs_arr
+ ! observatory coordinates and ephem time array (intent(inout)).
+ TYPE (CartesianCoordinates), DIMENSION(:), POINTER :: observers
+ ! Output error code
+ INTEGER, INTENT(out) :: errorCode
+
+ ! Internal variables.
+ ! Integrator (only used if dynamical model is different from 2-body).
+ ! [ "bulirsch-stoer" ]
+ CHARACTER(len=INTEGRATOR_LEN) :: integrator = "bulirsch-stoer"!
+ TYPE (Time) :: t
+ ! Element type to be used in computations.
+ CHARACTER(len=ELEMENT_TYPE_LEN) :: elementType = "keplerian"
+ INTEGER :: j = 0
+ CHARACTER(len=6) :: dynModel = "2-body"
+ INTEGER :: nstep = 0
+ REAL(bp) :: mjd_tai
+
+
+ ! Init vars
+ error = .FALSE.
+ errorCode = 0
+ IF (step <= 0.0_bp) THEN
+ nstep = 1
+ ELSE
+ step = SIGN(ABS(step),timespan)
+ IF (ABS(timespan) > 10.0_bp*EPSILON(timespan) .AND. &
+ ABS(timespan) < ABS(step)) THEN
+ step = timespan
+ END IF
+ nstep = NINT(timespan/step) + 1
+ END IF
+ integration_step = MIN(ABS(step),integration_step)
+
+ IF(PRESENT(element_type)) THEN
+ elementType = element_type
+ END IF
+ IF(PRESENT(dyn_model) .AND. &
+ dyn_model .NE. "2-body" .AND. &
+ dyn_model .NE. "n-body") THEN
+ ! Error: unsupported dynamical model.
+ errorCode = 21
+ RETURN
+ ELSEIF(dyn_model .EQ. "n-body") THEN
+ dynModel = "n-body"
+ END IF
+
+ ! Use equatorial coordinates:
+ CALL toCartesian(storb, "equatorial")
+
+ ! Get orbit epoch at the observatory.
+ t = getTime(storb)
+ mjd_tai = getMJD(t, internal_timescale)
+ CALL NULLIFY(t)
+ ALLOCATE(observers(nstep))
+ DO j=1,nstep
+ CALL NEW(t, mjd_tai+(j-1)*step, internal_timescale)
+ IF (error) THEN
+ ! Error in creating a new Time object.
+ errorCode = 35
+ RETURN
+ END IF
+ ! Compute heliocentric observatory coordinates
+ observers(j) = getObservatoryCCoord(obsies, obsy_code, t)
+ IF (error) THEN
+ ! Error in getObservatoryCCoord()
+ errorCode = 36
+ RETURN
+ END IF
+ CALL rotateToEquatorial(observers(j))
+ CALL NULLIFY(t)
+ END DO
+
+ ! Set integration parameters
+ IF (dynModel == "n-body") THEN
+ CALL setParameters(storb, &
+ dyn_model=dynModel, &
+ perturbers=perturbers, &
+ integrator=integrator, &
+ integration_step=integration_step)
+ ELSE
+ CALL setParameters(storb, &
+ dyn_model=dynModel)
+ END IF
+ IF (error) THEN
+ ! Error in setParameters()
+ errorCode = 37
+ RETURN
+ END IF
+
+ ! Compute topocentric ephemerides
+ CALL getEphemerides(storb, &
+ observers, &
+ ephemerides, &
+ cov_arr=cov_arr, &
+ pdfs_arr=pdfs_arr)
+ IF (error) THEN
+ ! Error in getEphemerides()
+ errorCode = 38
+ RETURN
+ END IF
+
+ END SUBROUTINE ephemeris
+
+
+ SUBROUTINE classification(storb, group_name_arr, weight_arr, errorCode)
+ ! Compute probability for an object with the input
+ ! orbital-element pdf to belong to a group of asteroids. Caveat:
+ ! an, ap, M are not currently taken into account, that is,
+ ! e.g. Jupiter Trojans not correctly accounted for.
+ ! Input/Output variables.
+ TYPE(StochasticOrbit), INTENT(inout) :: storb
+ ! Class names and probability arrays.
+ REAL(bp), DIMENSION(:), POINTER :: weight_arr
+ CHARACTER(len=DESIGNATION_LEN), DIMENSION(:), POINTER :: group_name_arr
+ INTEGER, INTENT(out) :: errorCode
+
+
+ ! Init
+ error = .FALSE.
+ errorCode = 0
+
+ IF (.NOT.containsSampledPDF(storb)) THEN
+ ! Error: we need sampled uncertainty information required for this task.
+ errorCode = 44
+ RETURN
+ END IF
+
+ ! Propagate input orbital-element pdf to Keplerian-element pdf:
+ CALL toKeplerian(storb)
+ ! Compute weights for each class that has been defined:
+ CALL getGroupWeights(storb, weight_arr, group_name_arr)
+
+ END SUBROUTINE classification
+
+
+ SUBROUTINE computeMoid(storb, moid, errorCode)
+ ! Compute Earth MOID (w/o uncertainty) for the input orbit.
+ ! Input/Output variables.
+ TYPE(StochasticOrbit), INTENT(in) :: storb
+ REAL(bp), INTENT(out) :: moid
+ INTEGER, INTENT(out) :: errorCode
+
+ ! Internal variables.
+ REAL(bp), DIMENSION(6) :: elements
+ TYPE(Orbit) :: orb
+ TYPE(Orbit) :: ref_orb
+ TYPE(Time) :: epoch
+ REAL(bp) :: mjd_tai
+ INTEGER :: err = 0
+ REAL(bp), DIMENSION(:,:), POINTER :: planeph
+
+
+ ! Init
+ error = .FALSE.
+ errorCode = 0
+ moid = -1.0_bp
+
+ ! Get the nominal orbit.
+ orb = getNominalOrbit(storb)
+ elements = getElements(orb, "cometary")
+ IF (elements(2) > 1.0_bp) THEN
+ ! Error: MOID for hyperbolic orbits currently not computed...
+ errorCode = 42
+ moid = -1.0_bp
+ RETURN
+ END IF
+
+ ! Epoch of the asteroid orbit:
+ epoch = getTime(orb)
+ mjd_tai = getMJD(epoch, internal_timescale)
+ ! Earth's osculating elements for the epoch of the asteroid orbit:
+ planeph => JPL_ephemeris(mjd_tai, 3, 11, error)
+ CALL NEW(ref_orb, planeph(1,:), "cartesian", "equatorial", epoch)
+ ! MOID between Earth and asteroid orbits:
+ moid = getMOID(orb, ref_orb)
+ IF (error) THEN
+ ! Error in getMOID()
+ moid = -1.0_bp
+ error = .FALSE.
+ errorCode = 43
+ END IF
+
+ ! Cleanup.
+ CALL NULLIFY(epoch)
+ CALL NULLIFY(ref_orb)
+ CALL NULLIFY(orb)
+ DEALLOCATE(planeph, stat=err)
+
+ END SUBROUTINE computeMoid
+
+
+ SUBROUTINE epochFromObservations(obs_in, t, errorCode)
+ TYPE (Observations), INTENT(in) :: obs_in
+ TYPE (Time), INTENT(out) :: t
+ INTEGER, INTENT(OUT) :: errorCode
+
+ ! Internal variables.
+ REAL(bp) :: dt = 0
+ REAL(bp) :: mjd = 0
+ TYPE (Observation) :: obs
+
+
+ ! init
+ errorCode = 0
+ error = .FALSE.
+ CALL NULLIFY(t)
+ CALL NULLIFY(obs)
+ dt = getObservationalTimespan(obs_in)
+ IF (error) THEN
+ ! Error in getObservationalTimeInterval()
+ errorCode = 3
+ RETURN
+ END IF
+ obs = getObservation(obs_in,1)
+ IF (error) THEN
+ ! Error in getObservation()
+ errorCode = 4
+ RETURN
+ END IF
+ t = getTime(obs)
+ IF (error) THEN
+ ! Error in getTime()
+ errorCode = 5
+ RETURN
+ END IF
+ CALL NULLIFY(obs)
+ mjd = getMJD(t, internal_timescale)
+ IF (error) THEN
+ ! Error in getMJD()
+ errorCode = 6
+ RETURN
+ END IF
+ CALL NULLIFY(t)
+ mjd = REAL(NINT(mjd+dt/2.0_bp),bp)
+ CALL NEW(t, mjd, internal_timescale)
+ IF (error) THEN
+ ! Error in new(t)
+ errorCode = 7
+ RETURN
+ END IF
+
+ END SUBROUTINE epochFromObservations
+
+
+ SUBROUTINE dumpRangingOrbits(storb, element_type, errorCode)
+ TYPE (StochasticOrbit), INTENT(in) :: storb
+ CHARACTER(len=*), OPTIONAL, INTENT(in) :: element_type
+ INTEGER, INTENT(out) :: errorCode
+
+ ! Internal variables.
+ REAL(bp), DIMENSION(2,2) :: sor_rho_cmp
+ TYPE (Orbit), DIMENSION(:), POINTER :: orb_arr_cmp
+ REAL(bp), DIMENSION(:), POINTER :: pdf_arr_cmp
+ REAL(bp), DIMENSION(:), POINTER :: rchi2_arr_cmp
+ REAL(bp), DIMENSION(:), POINTER :: reg_apr_arr_cmp
+ REAL(bp), DIMENSION(:,:), POINTER :: jac_arr_cmp
+ INTEGER :: numOutOrbits
+ REAL(bp), DIMENSION(6) :: elements
+ CHARACTER(len=ELEMENT_TYPE_LEN) :: elementType = "keplerian"
+ TYPE (Time) :: t0
+ REAL(bp) :: orbMjd
+ INTEGER :: j = 0
+ INTEGER :: err = 0
+ CHARACTER(len=85) :: fmt
+
+ INTEGER :: year
+ INTEGER :: month
+ REAL(bp) :: day
+ CHARACTER(len=9) :: id = "K08K0042V"
+
+ ! Init
+ errorCode = 0
+ error = .FALSE.
+ fmt = "(A16,6(1X,E21.14),1X,I4,1X,I2,1X,F8.5,1X,A12,1X,E18.10,1X,E18.10,1X,E18.10,1X,E18.10)"
+ IF(PRESENT(element_type)) THEN
+ elementType = element_type
+ END IF
+
+ CALL getResults(storb, sor_rho_cmp=sor_rho_cmp)
+ IF (error) THEN
+ WRITE(*, *) "Error in getResults()"
+ errorCode = 15
+ RETURN
+ END IF
+ ! Get ORBITAL-ELEMENT PDF
+ orb_arr_cmp => getSampleOrbits(storb)
+ IF (error) THEN
+ WRITE(*, *) "Error in getSampleOrbits()"
+ errorCode = 16
+ RETURN
+ END IF
+ pdf_arr_cmp => getPDFValues(storb)
+ IF (error) THEN
+ WRITE(*, *) "Error in getPDFValues()"
+ errorCode = 17
+ RETURN
+ END IF
+ rchi2_arr_cmp => getReducedChi2Distribution(storb)
+ IF (error) THEN
+ WRITE(*, *) "Error in getReducedChi2Distribution()"
+ errorCode = 17
+ RETURN
+ END IF
+ CALL getResults(storb, &
+ reg_apr_arr=reg_apr_arr_cmp, &
+ jac_arr=jac_arr_cmp)
+ IF (error) THEN
+ WRITE(*, *) "Error in getResults()"
+ numOutOrbits = 0
+ errorCode = 18
+ RETURN
+ END IF
+
+ ! This is where we wrere originally writing the .orb file(s) out.
+ numOutOrbits = SIZE(orb_arr_cmp,dim=1)
+ DO j=1,numOutOrbits
+ elements = getElements(orb_arr_cmp(j), &
+ elementType, &
+ frame="ecliptic")
+ IF (error) THEN
+ WRITE(*, *) "Error in fetching the orbit"
+ errorCode = 19
+ RETURN
+ END IF
+ IF (elementType == "keplerian") THEN
+ elements(3:6) = elements(3:6)/rad_deg
+ ELSE IF (elementType == "delaunay") THEN
+ elements(1:3) = elements(1:3)/rad_deg
+ ELSE IF (elementType == "poincare") THEN
+ elements(4) = elements(4)/rad_deg
+ ELSE IF (elementType == "equinoctial") THEN
+ elements(6) = elements(6)/rad_deg
+ END IF
+
+ t0 = getTime(orb_arr_cmp(j))
+ CALL getCalendarDate(t0, "tdt", year, month, day)
+ orbMjd = getMjd(t0, internal_timescale)
+ CALL NULLIFY(t0)
+ IF (error) THEN
+ WRITE(*, *) "Error in getTime/getMjd"
+ errorCode = 5
+ RETURN
+ END IF
+
+
+ WRITE(*, fmt) id, elements(1:6), year, month, day, elementType, &
+ pdf_arr_cmp(j), rchi2_arr_cmp(j), reg_apr_arr_cmp(j), &
+ jac_arr_cmp(j, 1:3)
+
+ ! write(*, *) "elements: ", elements(1:6)
+ ! write(*, *) "epoch: ", orbMjd
+ ! write(*, *) "Un-normalized p.d.f.: ", pdf_arr_cmp(j)
+ ! write(*, *) "Reduced chi2: ", rchi2_arr_cmp(j)
+ ! write(*, *) "Regularized apr: ", reg_apr_arr_cmp(j)
+ ! write(*, *) "Jacobian det: ", jac_arr_cmp(j, 1:3)
+ END DO
+ ! WRITE RESIDUALS
+
+ ! This is where we were originally writing out the .res file.
+ ! CALL writeResiduals(storb, obs_in, getUnit(out_file))
+
+ ! Cleanup everything
+ DO j=1,SIZE(orb_arr_cmp)
+ CALL NULLIFY(orb_arr_cmp(j))
+ END DO
+ DEALLOCATE(orb_arr_cmp, stat=err)
+ DEALLOCATE(pdf_arr_cmp, stat=err)
+ DEALLOCATE(rchi2_arr_cmp, stat=err)
+ DEALLOCATE(reg_apr_arr_cmp, stat=err)
+ DEALLOCATE(jac_arr_cmp, stat=err)
+ IF (err /= 0) THEN
+ WRITE(*, *) "Error: Could not deallocate memory"
+ errorCode = 19
+ RETURN
+ END IF
+
+ END SUBROUTINE dumpRangingOrbits
+
+
+ SUBROUTINE dumpLslOrbit(storb, element_type, errorCode)
+ TYPE (StochasticOrbit), INTENT(in) :: storb
+ CHARACTER(len=*), OPTIONAL, INTENT(in) :: element_type
+ INTEGER, INTENT(out) :: errorCode
+
+ ! Internal variables.
+ REAL(bp), DIMENSION(6) :: elements
+ CHARACTER(len=ELEMENT_TYPE_LEN) :: elementType = "keplerian"
+ TYPE (Time) :: t0
+ REAL(bp) :: orbMjd
+ INTEGER :: j = 0
+ INTEGER :: k = 0
+ TYPE (Orbit) :: orb
+ REAL(bp), DIMENSION(6,6) :: cov
+ REAL(bp), DIMENSION(6,6) :: corr
+ REAL(bp), DIMENSION(6) :: sigmas
+
+
+
+ ! Init
+ errorCode = 0
+ error = .FALSE.
+ IF(PRESENT(element_type)) THEN
+ elementType = element_type
+ END IF
+
+ ! Get the nominal orbit out.
+ orb = getNominalOrbit(storb)
+ IF (error) THEN
+ WRITE(*, *) "Error in getNominalOrbit()"
+ errorCode = 28
+ RETURN
+ END IF
+
+ ! Get the orbital elements.
+ elements = getElements(orb, elementType, frame="ecliptic")
+ IF (error) THEN
+ WRITE(*, *) "Error in fetching the orbit"
+ errorCode = 19
+ RETURN
+ END IF
+ IF (elementType == "keplerian") THEN
+ elements(3:6) = elements(3:6)/rad_deg
+ ELSE IF (elementType == "delaunay") THEN
+ elements(1:3) = elements(1:3)/rad_deg
+ ELSE IF (elementType == "poincare") THEN
+ elements(4) = elements(4)/rad_deg
+ ELSE IF (elementType == "equinoctial") THEN
+ elements(6) = elements(6)/rad_deg
+ END IF
+
+ ! Get orbit epoch.
+ t0 = getTime(orb)
+ orbMjd = getMjd(t0, internal_timescale)
+ CALL NULLIFY(t0)
+ IF (error) THEN
+ WRITE(*, *) "Error in getTime/getMjd"
+ errorCode = 5
+ RETURN
+ END IF
+
+ ! Covariance matrix.
+ cov = getCovarianceMatrix(storb, elementType, "ecliptic")
+ IF (error) THEN
+ WRITE(*, *) "Error in getCovarianceMatrix"
+ errorCode = 29
+ RETURN
+ END IF
+ DO j=1,6
+ sigmas(j) = SQRT(cov(j, j))
+ IF (elementType == "keplerian" .AND. j >= 3) THEN
+ sigmas(j) = sigmas(j) / rad_deg
+ END IF
+ END DO
+
+ ! Correlations.
+ DO j=1,6
+ DO k=1,6
+ corr(j,k) = cov(j,k) / (sigmas(j)*sigmas(k))
+ END DO
+ END DO
+
+
+ WRITE(*, *) "elements: ", elements(1:6)
+ WRITE(*, *) "epoch: ", orbMjd
+ WRITE(*, *) "Covariance: ", cov
+ WRITE(*, *) "Sigmas: ", sigmas
+ WRITE(*, *) "Correlation: ", corr
+
+ ! Cleanup everything
+ CALL NULLIFY(orb)
+
+ END SUBROUTINE dumpLslOrbit
+
+
+ SUBROUTINE dumpEphemeris(storb, ephemerides, cov, pdfs, observers, &
+ obscode, errorCode)
+ ! Input/Output variables.
+ TYPE(StochasticOrbit), INTENT(inout) :: storb
+ ! Output ephem array (intent(inout)).
+ TYPE (SphericalCoordinates), DIMENSION(:,:),POINTER :: ephemerides
+ ! Ephem uncertainty matrices (intent(inout)).
+ REAL(bp), DIMENSION(:,:,:), POINTER :: cov
+ REAL(bp), DIMENSION(:,:), POINTER :: pdfs
+ ! observatory coordinates and ephem time array (intent(inout)).
+ TYPE (CartesianCoordinates), DIMENSION(:), POINTER :: observers
+ ! Observatory code.
+ CHARACTER(len=*), INTENT(in) :: obscode
+ ! Output error code
+ INTEGER, INTENT(out) :: errorCode
+
+ ! Internal vars.
+ TYPE (Time) :: t
+ INTEGER :: j = 0
+ INTEGER :: k = 0
+ INTEGER :: l = 0
+ REAL(bp) :: mjd_tai = 0.0_bp
+ REAL(bp), DIMENSION(6) :: coordinates
+ REAL(bp), DIMENSION(6) :: stdev
+ REAL(bp), DIMENSION(6,6) :: corr
+
+
+ ! Init
+ error = .FALSE.
+ errorCode = 0
+
+
+ DO j=1,SIZE(observers)
+ t = getTime(observers(j))
+ mjd_tai = getMJD(t, internal_timescale)
+ CALL NULLIFY(t)
+ IF (containsSampledPDF(storb)) THEN
+ ! Input orbits correspond to one or more sampled pdfs.
+ ! Loop over sampled orbits:
+ DO k=1,SIZE(ephemerides, dim=1)
+ ! Make sure that the ephemeris is equatorial:
+ CALL rotateToEquatorial(ephemerides(k,j))
+ coordinates = getCoordinates(ephemerides(k,j))
+ WRITE(*, *) TRIM(obscode), &
+ mjd_tai, coordinates(1), &
+ coordinates(2:3)/rad_deg, coordinates(4), &
+ coordinates(5:6)/rad_deg, pdfs(k,j)
+ END DO
+ ELSE
+ ! Input orbits correspond to one or more single-point estimates of the pdf.
+ ! Make sure that the ephemeris is equatorial:
+ CALL rotateToEquatorial(ephemerides(1,j))
+ coordinates = getCoordinates(ephemerides(1,j))
+ DO k=1,6
+ stdev(k) = SQRT(cov(k,k,j))
+ END DO
+ DO k=1,6
+ DO l=1,6
+ corr(k,l) = cov(k,l,j) / &
+ (stdev(k)*stdev(l))
+ END DO
+ END DO
+ WRITE(*, "(A18,28(1X,F18.10))") TRIM(obscode), mjd_tai, &
+ coordinates(1), &
+ coordinates(2:3)/rad_deg, coordinates(4), &
+ coordinates(5:6)/rad_deg, stdev(1), &
+ stdev(2:3)/rad_deg, stdev(4), &
+ stdev(5:6)/rad_deg, corr(1,2:6), &
+ corr(2,3:6), corr(3,4:6), corr(4,5:6), corr(5,6)
+ END IF
+ END DO
+
+ END SUBROUTINE dumpEphemeris
+
+
+ SUBROUTINE readOpenOrbOrbit(fileName, storb, errorCode)
+ CHARACTER(len=*), INTENT(in) :: fileName
+ TYPE (StochasticOrbit), INTENT(out) :: storb
+ INTEGER, INTENT(out) :: errorCode
+
+ ! Internal vars.
+ INTEGER :: norb = 0
+ TYPE (File) :: orb_in_file
+ CHARACTER(len=1024), DIMENSION(4) :: header
+ REAL(bp), DIMENSION(:,:), POINTER :: HG_arr_in
+ INTEGER :: j = 0
+ CHARACTER(len=DESIGNATION_LEN), DIMENSION(:), POINTER :: id_arr_in
+ CHARACTER(len=ELEMENT_TYPE_LEN), DIMENSION(:), ALLOCATABLE :: element_type_pdf_arr_in
+ REAL(bp), DIMENSION(:,:), ALLOCATABLE :: jac_arr_in
+ REAL(bp), DIMENSION(:,:,:), POINTER :: cov_arr_in
+ REAL(bp), DIMENSION(:), ALLOCATABLE :: rchi2_arr_in, &
+ pdf_arr_in, &
+ reg_apr_arr_in
+ CHARACTER(len=ELEMENT_TYPE_LEN) :: element_type_in
+ CHARACTER(len=DESIGNATION_LEN) :: id
+ TYPE (Orbit), DIMENSION(:), POINTER :: orb_arr_in
+
+ ! Init vars.
+ error = .FALSE.
+ errorCode = 0
+
+ CALL NEW(orb_in_file, fileName)
+ IF (error) THEN
+ ! Error in creating input file instance
+ errorCode = 30
+ RETURN
+ END IF
+ CALL setStatusOld(orb_in_file)
+ CALL OPEN(orb_in_file)
+ IF (error) THEN
+ ! Error in opeining input file.
+ errorCode = 31
+ RETURN
+ END IF
+ ! 4 header lines are not taken into account.
+ norb = getNrOfLines(orb_in_file) - 4
+ IF (error) THEN
+ ! Error in getNrOfLines()
+ errorCode = 32
+ RETURN
+ END IF
+ ALLOCATE(id_arr_in(norb), orb_arr_in(norb), &
+ element_type_pdf_arr_in(norb), cov_arr_in(norb,6,6), &
+ HG_arr_in(norb,2), pdf_arr_in(norb), &
+ rchi2_arr_in(norb), jac_arr_in(norb,3), &
+ reg_apr_arr_in(norb), stat=errorCode)
+ IF (errorCode /= 0) THEN
+ ! Error in memory allocation
+ errorCode = 33
+ RETURN
+ END IF
+ jac_arr_in = -1.0_bp
+ pdf_arr_in = -1.0_bp
+ cov_arr_in = -1.0_bp
+ id_arr_in = " "
+ element_type_pdf_arr_in = " "
+ header(1:4)(:) = " "
+ FORALL (j=1:norb)
+ HG_arr_in(j,1:2) = (/ 99.0_bp, 9.9_bp /)
+ END FORALL
+ DO j=1,norb
+ CALL readOpenOrbOrbitFile(getUnit(orb_in_file), header, &
+ element_type_in=element_type_in, id=id_arr_in(j), &
+ orb=orb_arr_in(j), &
+ element_type_pdf=element_type_pdf_arr_in(j), &
+ cov=cov_arr_in(j,:,:), H=HG_arr_in(j,1), &
+ G=HG_arr_in(j,2), pdf=pdf_arr_in(j), &
+ rchi2=rchi2_arr_in(j), reg_apr=reg_apr_arr_in(j), &
+ jac_sph_inv=jac_arr_in(j,1), &
+ jac_car_kep=jac_arr_in(j,2), &
+ jac_equ_kep=jac_arr_in(j,3))
+ IF (error) THEN
+ ! Error in readOpenOrbOrbitFile()
+ errorCode = 34
+ RETURN
+ END IF
+ END DO
+ CALL NULLIFY(orb_in_file)
+
+ ! Initialize stochasticorbits if uncertainty information available:
+ IF (norb > 1 .AND. &
+ ALL(pdf_arr_in > 0.0_bp) .AND. &
+ ALL(jac_arr_in > 0.0_bp)) THEN
+ CALL NULLIFY(storb)
+ CALL NEW(storb, orb_arr_in, pdf_arr_in, &
+ element_type_pdf_arr_in(1), jac_arr=jac_arr_in, &
+ reg_apr_arr=reg_apr_arr_in, &
+ rchi2_arr=rchi2_arr_in)
+ id = id_arr_in(1)
+ DEALLOCATE(id_arr_in)
+ ALLOCATE(id_arr_in(1))
+ id_arr_in(1) = id
+ ELSE IF (norb == 1 .AND. ALL(cov_arr_in(:,1,1) > 0.0_bp)) THEN
+ CALL NEW(storb, orb_arr_in(1), cov_arr_in(1,:,:), &
+ cov_type=element_type_in, element_type=element_type_in)
+ ELSE
+ ! Error in StochasticOrbit instantiation
+ errorCode = 34
+ RETURN
+ END IF
+
+ ! Cleanup.
+ DO j=1,norb
+ CALL NULLIFY(orb_arr_in(j))
+ END DO
+ DEALLOCATE(orb_arr_in, pdf_arr_in, rchi2_arr_in, jac_arr_in, &
+ reg_apr_arr_in, element_type_pdf_arr_in)
+
+ END SUBROUTINE readOpenOrbOrbit
+
+
+ SUBROUTINE rangingOrbitsToStochasticOrbit(orbits, norb, storb, errorCode)
+ ! Flattened orbit array. Each elememnt is
+ ! (id, elements(1:6), epoch_mjd, Un-normalized p.d.f., Reduced chi2,
+ ! Regularized apr, Jacobian det(1:3), element_type_index)
+ INTEGER, INTENT(in) :: norb
+ REAL(bp), DIMENSION(norb, 15), INTENT(in) :: orbits
+ TYPE (StochasticOrbit), INTENT(out) :: storb
+ INTEGER, INTENT(out) :: errorCode
+
+ ! Internal vars.
+ REAL(bp), DIMENSION(:,:), POINTER :: HG_arr_in
+ INTEGER :: j = 0
+ INTEGER :: i = 0
+ CHARACTER(len=DESIGNATION_LEN), DIMENSION(:), POINTER :: id_arr_in
+ CHARACTER(len=ELEMENT_TYPE_LEN), DIMENSION(:), ALLOCATABLE :: element_type_pdf_arr_in
+ REAL(bp), DIMENSION(:,:), ALLOCATABLE :: jac_arr_in
+ REAL(bp), DIMENSION(:,:,:), POINTER :: cov_arr_in
+ REAL(bp), DIMENSION(:), ALLOCATABLE :: rchi2_arr_in, &
+ pdf_arr_in, &
+ reg_apr_arr_in
+ CHARACTER(len=DESIGNATION_LEN) :: id
+ TYPE (Orbit), DIMENSION(:), POINTER :: orb_arr_in
+ REAL(bp), DIMENSION(15) :: correlation
+ REAL(bp), DIMENSION(6) :: stdev
+ REAL(bp), DIMENSION(6) :: elements
+ TYPE(Time) :: t
+ CHARACTER(len=11) :: element_type
+ INTEGER :: element_type_index = -1
+
+
+ ! Init vars.
+ error = .FALSE.
+ errorCode = 0
+
+ ! Get the element type from the input flattened orbits (the are supposed
+ ! be all the same).
+ element_type_index = orbits(1, 15)
+ IF(element_type_index .LE. 0 .OR. &
+ element_type_index .GT. SIZE(ORBITAL_ELEMENTS)) THEN
+ ! Error: unsupported orbital elements.
+ errorCode = 58
+ RETURN
+ END IF
+ element_type = ORBITAL_ELEMENTS(element_type_index)
+
+ ! Allocate memory for the orbit arrays.
+ ALLOCATE(id_arr_in(norb), orb_arr_in(norb), &
+ element_type_pdf_arr_in(norb), cov_arr_in(norb,6,6), &
+ HG_arr_in(norb,2), pdf_arr_in(norb), &
+ rchi2_arr_in(norb), jac_arr_in(norb,3), &
+ reg_apr_arr_in(norb), stat=errorCode)
+ IF (errorCode /= 0) THEN
+ ! Error in memory allocation
+ errorCode = 33
+ RETURN
+ END IF
+ jac_arr_in = -1.0_bp
+ pdf_arr_in = -1.0_bp
+ cov_arr_in = 0.0_bp
+ id_arr_in = " "
+ ! There are no H/G in the input orbits.
+ FORALL (j=1:norb)
+ HG_arr_in(j,1:2) = (/ 99.0_bp, 9.9_bp /)
+ END FORALL
+ stdev = -1.0_bp
+ correlation = 2.0_bp
+ element_type_pdf_arr_in = element_type
+
+ ! Get each flattened orbit and create an Orbit instance.
+ DO j=1,norb
+ ! Just to beat on a dead horse:
+ ! orbits(j,1): id
+ ! orbits(j,2:7): elements(1:6)
+ ! orbits(j,8): epoch_mjd
+ ! orbits(j,9): Un-normalized p.d.f.
+ ! orbits(j,10): Reduced chi2
+ ! orbits(j,11): Regularized apr
+ ! orbits(j,12:14): Jacobian det(1:3)
+ ! orbits(j,15): element_type_index
+ ! Convert angles to radians, if needed.
+ WRITE(id_arr_in(j), fmt="(A,I10.10)") "TRK", IDINT(orbits(j, 1))
+
+ elements(1:6) = orbits(j,2:7)
+ IF (element_type == "keplerian") THEN
+ elements(3:6) = elements(3:6) * rad_deg
+ ELSE IF (element_type == "delaunay") THEN
+ elements(1:3) = elements(1:3) * rad_deg
+ ELSE IF (element_type == "poincare") THEN
+ elements(4) = elements(4) * rad_deg
+ ELSE IF (element_type == "equinoctial") THEN
+ elements(6) = elements(6) * rad_deg
+ END IF
+
+ ! Create a Time instance.
+ CALL NEW(t, orbits(j, 8), internal_timescale)
+ IF(error) THEN
+ ! Error in creating a Time instance.
+ errorCode = 57
+ RETURN
+ END IF
+
+ ! Now create an Orbit instance.
+ CALL NEW(orb_arr_in(j), &
+ elements(1:6), &
+ element_type, &
+ "ecliptic", &
+ copy(t))
+ CALL NULLIFY(t)
+
+ ! Covariance: we fake it since we do not have it.
+ cov_arr_in(j,:,:) = 0.0_bp
+ DO i=1,6
+ cov_arr_in(j,i,i) = -1.0_bp
+ END DO
+
+ ! Populate the uncertinty arrays.
+ pdf_arr_in(j) = orbits(j, 9)
+ rchi2_arr_in(j) = orbits(j, 10)
+ reg_apr_arr_in(j) = orbits(j, 11)
+ jac_arr_in(j,1:3) = orbits(j, 12:14)
+ END DO
+
+ ! Initialize stochasticorbits if uncertainty information available:
+ IF (norb > 1 .AND. &
+ ALL(pdf_arr_in > 0.0_bp) .AND. &
+ ALL(jac_arr_in > 0.0_bp)) THEN
+ CALL NULLIFY(storb)
+ CALL NEW(storb, orb_arr_in, pdf_arr_in, &
+ element_type_pdf_arr_in(1), jac_arr=jac_arr_in, &
+ reg_apr_arr=reg_apr_arr_in, &
+ rchi2_arr=rchi2_arr_in)
+ id = id_arr_in(1)
+ DEALLOCATE(id_arr_in)
+ ALLOCATE(id_arr_in(1))
+ id_arr_in(1) = id
+ ELSE IF (norb == 1 .AND. ALL(cov_arr_in(:,1,1) > 0.0_bp)) THEN
+ CALL NEW(storb, orb_arr_in(1), cov_arr_in(1,:,:), &
+ cov_type=element_type, element_type=element_type)
+ ELSE
+ ! Error in StochasticOrbit instantiation
+ errorCode = 34
+ RETURN
+ END IF
+
+ ! Cleanup.
+ DO j=1,norb
+ CALL NULLIFY(orb_arr_in(j))
+ END DO
+ DEALLOCATE(orb_arr_in, pdf_arr_in, rchi2_arr_in, jac_arr_in, &
+ reg_apr_arr_in, element_type_pdf_arr_in)
+
+ END SUBROUTINE rangingOrbitsToStochasticOrbit
+
+
+ SUBROUTINE lslOrbitToStochasticOrbit(in_orbit, &
+ in_covariance, &
+ storb, &
+ errorCode)
+ ! Input/Output variables.
+ ! Input flattened orbit:
+ ! (track_id, elements(1:6), epoch, H, G, element_type_index)
+ ! FIXME: H and G are not currently computed.
+ REAL(8),DIMENSION(11), INTENT(in) :: in_orbit
+ ! Uncertainty matrices:
+ REAL(8), DIMENSION(6,6), INTENT(in) :: in_covariance
+ TYPE(StochasticOrbit), INTENT(out) :: storb
+ INTEGER, INTENT(out) :: errorCode
+
+ ! Internal vars.
+ REAL(bp), DIMENSION(:,:), POINTER :: HG_arr_in
+ INTEGER :: j = 0
+ CHARACTER(len=DESIGNATION_LEN), DIMENSION(:), POINTER :: id_arr_in
+ CHARACTER(len=ELEMENT_TYPE_LEN), DIMENSION(:), ALLOCATABLE :: element_type_pdf_arr_in
+ REAL(bp), DIMENSION(:,:), ALLOCATABLE :: jac_arr_in
+ REAL(bp), DIMENSION(:,:,:), POINTER :: cov_arr_in
+ REAL(bp), DIMENSION(:), ALLOCATABLE :: rchi2_arr_in, &
+ pdf_arr_in, &
+ reg_apr_arr_in
+ CHARACTER(len=DESIGNATION_LEN) :: id
+ TYPE (Orbit), DIMENSION(:), POINTER :: orb_arr_in
+ REAL(bp), DIMENSION(6) :: elements
+ TYPE(Time) :: t
+ CHARACTER(len=11) :: element_type
+ INTEGER :: element_type_index = -1
+ INTEGER :: norb = 1
+
+
+ ! Init vars.
+ error = .FALSE.
+ errorCode = 0
+ ! We try to keep these two subroutines similar so that we can merge in
+ ! the future, hence the norb = 1 thing here.
+ norb = 1
+
+ ! Get the element type from the input flattened in_orbit.
+ element_type_index = in_orbit(11)
+ IF(element_type_index .LE. 0 .OR. &
+ element_type_index .GT. SIZE(ORBITAL_ELEMENTS)) THEN
+ ! Error: unsupported orbital elements.
+ errorCode = 58
+ RETURN
+ END IF
+ element_type = ORBITAL_ELEMENTS(element_type_index)
+
+ ! Allocate memory for the orbit arrays.
+ ALLOCATE(id_arr_in(norb), orb_arr_in(norb), &
+ element_type_pdf_arr_in(norb), cov_arr_in(norb,6,6), &
+ HG_arr_in(norb,2), pdf_arr_in(norb), &
+ rchi2_arr_in(norb), jac_arr_in(norb,3), &
+ reg_apr_arr_in(norb), stat=errorCode)
+ IF (errorCode /= 0) THEN
+ ! Error in memory allocation
+ errorCode = 33
+ RETURN
+ END IF
+ jac_arr_in = -1.0_bp
+ pdf_arr_in = -1.0_bp
+ cov_arr_in = 0.0_bp
+ id_arr_in = " "
+ ! There are no H/G in the input in_orbit.
+ FORALL (j=1:norb)
+ HG_arr_in(j,1:2) = (/ 99.0_bp, 9.9_bp /)
+ END FORALL
+ element_type_pdf_arr_in = element_type
+
+ ! Get each flattened orbit and create an Orbit instance.
+ DO j=1,norb
+ ! Just to beat on a dead horse:
+ ! in_orbit(1): id
+ ! in_orbit(2:7): elements(1:6)
+ ! in_orbit(8): epoch_mjd
+ ! in_orbit(9): H
+ ! in_orbit(10): G
+ ! in_orbit(j,11): element_type_index
+ ! Convert angles to radians, if needed.
+ WRITE(id_arr_in(j), fmt="(A,I10.10)") "TRK", IDINT(in_orbit(1))
+
+ elements(1:6) = in_orbit(2:7)
+ IF (element_type == "keplerian") THEN
+ elements(3:6) = elements(3:6) * rad_deg
+ ELSE IF (element_type == "delaunay") THEN
+ elements(1:3) = elements(1:3) * rad_deg
+ ELSE IF (element_type == "poincare") THEN
+ elements(4) = elements(4) * rad_deg
+ ELSE IF (element_type == "equinoctial") THEN
+ elements(6) = elements(6) * rad_deg
+ END IF
+
+ ! Create a Time instance.
+ CALL NEW(t, in_orbit(8), internal_timescale)
+ IF(error) THEN
+ ! Error in creating a Time instance.
+ errorCode = 57
+ RETURN
+ END IF
+
+ ! Now create an Orbit instance.
+ CALL NEW(orb_arr_in(j), &
+ elements(1:6), &
+ element_type, &
+ "ecliptic", &
+ copy(t))
+ CALL NULLIFY(t)
+
+ ! Covariance. We do not need to re-compute it since we already have
+ ! it.
+ cov_arr_in(j,:,:) = in_covariance(:,:)
+ END DO
+
+ ! Initialize stochasticorbits if uncertainty information available:
+ IF (norb > 1 .AND. &
+ ALL(pdf_arr_in > 0.0_bp) .AND. &
+ ALL(jac_arr_in > 0.0_bp)) THEN
+ CALL NULLIFY(storb)
+ CALL NEW(storb, orb_arr_in, pdf_arr_in, &
+ element_type_pdf_arr_in(1), jac_arr=jac_arr_in, &
+ reg_apr_arr=reg_apr_arr_in, &
+ rchi2_arr=rchi2_arr_in)
+ id = id_arr_in(1)
+ DEALLOCATE(id_arr_in)
+ ALLOCATE(id_arr_in(1))
+ id_arr_in(1) = id
+ ELSE IF (norb == 1 .AND. ALL(cov_arr_in(:,1,1) > 0.0_bp)) THEN
+ CALL NEW(storb, orb_arr_in(1), cov_arr_in(1,:,:), &
+ cov_type=element_type, element_type=element_type)
+ ELSE
+ ! Error in StochasticOrbit instantiation
+ errorCode = 34
+ RETURN
+ END IF
+
+ ! Cleanup.
+ DO j=1,norb
+ CALL NULLIFY(orb_arr_in(j))
+ END DO
+ DEALLOCATE(orb_arr_in, pdf_arr_in, rchi2_arr_in, jac_arr_in, &
+ reg_apr_arr_in, element_type_pdf_arr_in)
+
+ END SUBROUTINE lslOrbitToStochasticOrbit
+
+
+
+ SUBROUTINE readObsFile(fileName, stdev, obss, errorCode)
+ ! Input/output vars
+ CHARACTER(len=*), INTENT(in) :: fileName
+ ! This most likely comes from a config file. If not, remember that all
+ ! angles are in radians and that stdev(2) = RAErr and stdev(3) = DecErr.
+ REAL(bp), DIMENSION(6), OPTIONAL, INTENT(in) :: stdev
+ ! Remember pointers need to be intent(inout), which is the default.
+ TYPE (Observations), DIMENSION(:), POINTER :: obss
+ INTEGER, INTENT(out) :: errorCode
+
+ ! Internal vars
+ REAL(bp), DIMENSION(6) :: stdevArray
+ TYPE(File) :: obs_file
+ TYPE(Observations) :: rawObss
+
+
+ ! Init
+ error = .FALSE.
+ errorCode = 0
+ stdevArray = 0.3_bp * rad_asec
+ IF(PRESENT(stdev)) THEN
+ stdevArray = stdev
+ END IF
+
+ ! Open the file.
+ CALL NEW(obs_file, TRIM(fileName))
+ CALL setStatusOld(obs_file)
+ CALL OPEN(obs_file)
+ IF (error) THEN
+ ! Error in opening observation file.
+ errorCode = 46
+ RETURN
+ END IF
+ CALL NEW(rawObss, obs_file, stdev=stdevArray)
+ CALL NULLIFY(obs_file)
+
+ ! Split the raw observations into sets.
+ obss => getSeparatedSets(rawObss)
+ CALL NULLIFY(rawObss)
+
+ END SUBROUTINE readObsFile
+
+
+ SUBROUTINE obssFromCoords(trackId, n, coords, mjds, mags, filters, &
+ obscodes, obss, errorCode)
+ ! obssFromCoords
+ !
+ ! Create a list of Observations instances from the input coordinate
+ ! array.
+ ! @param trackId: object ID. IDs are used to group observations of the
+ ! same object together (equivalent to track IDs in PS-MOPS). IDs
+ ! are numbers.
+ ! @param n: number of coordinates to process.
+ ! @param coords: array of [(ra, ra_err, dec, dec_err), ] coordinates in
+ ! radians.
+ ! @param mjds: array of MJDs (TAI), one per coords element. These are
+ ! the MJDs of the input observations/DiaSources/Detections.
+ ! @param mags: array of observed magnitudes, one per coords element.
+ ! mags are floats.
+ ! @param filters: array of filter names, one per coords element.
+ ! Filters are (usually 1 or 2-letter) strings
+ ! @param obscodes: array of MPC observatory codes, one per coords
+ ! element. Observatory codes are (up to 4 letter) strings.
+ !
+ ! @param obss: array of Observations instances, one element per unique
+ ! input ID.
+ ! @param errorCode: error code. Anything other than 0 signals an error.
+ INTEGER, INTENT(in) :: trackId
+ INTEGER, INTENT(in) :: n
+ REAL(bp), DIMENSION(n,4), INTENT(in) :: coords
+ REAL(bp), DIMENSION(n), INTENT(in) :: mjds
+ REAL(bp), DIMENSION(n), INTENT(in) :: mags
+ CHARACTER(len=*), DIMENSION(n), INTENT(in) :: filters
+ CHARACTER(len=OBSY_CODE_LEN), DIMENSION(n),INTENT(in) :: obscodes
+ ! Pointers have to be intent(inout)!
+ TYPE (Observations), DIMENSION(:), POINTER :: obss
+ INTEGER, INTENT(out) :: errorCode
+
+ ! Internal variables.
+ TYPE(Observations) :: rawObss
+ LOGICAL, DIMENSION(6) :: obs_mask
+ INTEGER :: i = 0
+ TYPE(Time) :: t
+ TYPE (SphericalCoordinates) :: obs_scoord
+ REAL(bp), DIMENSION(6,6) :: covariance
+ REAL(bp) :: ra = 0.0_bp
+ REAL(bp) :: dec = 0.0_bp
+ REAL(bp) :: raErr=0.0_bp
+ REAL(bp) :: decErr=0.0_bp
+ TYPE (Observatory) :: obsy
+ TYPE (CartesianCoordinates) :: obsy_ccoord
+ TYPE(Observation) :: obs
+ CHARACTER(len=255) :: designation
+
+
+ ! Init
+ error = .FALSE.
+ errorCode = 0
+ designation = " "
+ ! We only have RA and Dec and obs_mask is
+ ! (radial distance, longitude, latitude + their time derivatives), so:
+ obs_mask = (/ .FALSE., .TRUE., .TRUE., .FALSE., .FALSE., .FALSE. /)
+ CALL NEW(rawObss)
+ IF(n .LE. 0) THEN
+ ! Now enough data!
+ errorCode = 50
+ RETURN
+ END IF
+
+ ! Loop through the input arrays and create Observations!
+ DO i=1,n
+ ! Extract RA/Dec etc from coords.
+ ra = coords(i, 1)
+ raErr = coords(i, 2)
+ dec = coords(i, 3)
+ decErr = coords(i, 4)
+
+ ! Create a Time instance using the input mjd.
+ CALL NEW(t, mjds(i), internal_timescale)
+ IF(error) THEN
+ ! Error in creating Time instnce.
+ errorCode = 51
+ RETURN
+ END IF
+
+ ! Create SphericalCoordinates object containing R.A. Dec. epoch.
+ CALL NEW(obs_scoord, ra, dec, t)
+ IF (error) THEN
+ ! Error in creating a neSphericalCoordinates instance.
+ errorCode = 52
+ RETURN
+ END IF
+
+ ! Now set the covariance matrix.
+ covariance = 0.0_bp
+ covariance(2,2) = raErr**2.0_bp
+ covariance(3,3) = decErr**2.0_bp
+
+ ! write(*, *) "cov: ", covariance
+
+ ! Compute the heliocentric position of the observer at epoch t:
+ obsy = getObservatory(obsies, TRIM(obscodes(i)))
+ IF (error) THEN
+ ! Error in deriving the observatory location!
+ errorCode = 48
+ RETURN
+ END IF
+ obsy_ccoord = getObservatoryCCoord(obsies, obsy, t)
+
+ ! Create observation object:
+ CALL NULLIFY(obs)
+ WRITE(designation, fmt="(A,I10.10)") "TRK", trackId
+ CALL NEW(obs, &
+ number=trackId, &
+ designation=TRIM(designation), &
+ discovery=.FALSE., &
+ note1=" ", &
+ note2=" ", &
+ obs_scoord=obs_scoord, &
+ covariance=covariance, &
+ obs_mask=obs_mask, &
+ mag=mags(i), &
+ filter=TRIM(filters(i)), &
+ obsy=obsy, &
+ obsy_ccoord=obsy_ccoord)
+ IF (error) THEN
+ ! Error in creating a new Observation instance.
+ errorCode = 49
+ RETURN
+ END IF
+
+ CALL addObservation(rawObss, obs, sort=.TRUE.)
+ IF(error) THEN
+ ! Error in adding a new observation.
+ errorCode = 53
+ RETURN
+ END IF
+
+ CALL NULLIFY(obs)
+ CALL NULLIFY(obs_scoord)
+ CALL NULLIFY(t)
+ CALL NULLIFY(obsy)
+ CALL NULLIFY(obsy_ccoord)
+ END DO
+
+ ! Split the raw observatikons into one list per ID.
+ obss => getSeparatedSets(rawObss)
+ CALL NULLIFY(rawObss)
+
+ END SUBROUTINE obssFromCoords
+
+
+ SUBROUTINE exportRangingOrbits(storb, element_type, track_id, outOrbits, &
+ errorCode)
+ TYPE (StochasticOrbit), INTENT(in) :: storb
+ CHARACTER(len=*), OPTIONAL, INTENT(in) :: element_type
+ INTEGER, INTENT(in) :: track_id
+ ! outOrbits has the form ((id, elements(1:6), epoch, Un-normalized pdf,
+ ! Reduced chi2, Regularized apr, Jacobian det(1:3), el_type_index), )
+ REAL(bp),DIMENSION(:,:),INTENT(out) :: outOrbits
+ INTEGER, INTENT(out) :: errorCode
+
+ ! Internal variables.
+ REAL(bp), DIMENSION(2,2) :: sor_rho_cmp
+ TYPE (Orbit), DIMENSION(:), POINTER :: orb_arr_cmp
+ REAL(bp), DIMENSION(:), POINTER :: pdf_arr_cmp
+ REAL(bp), DIMENSION(:), POINTER :: rchi2_arr_cmp
+ REAL(bp), DIMENSION(:), POINTER :: reg_apr_arr_cmp
+ REAL(bp), DIMENSION(:,:), POINTER :: jac_arr_cmp
+ INTEGER :: numOutOrbits
+ REAL(bp), DIMENSION(6) :: elements
+ CHARACTER(len=ELEMENT_TYPE_LEN) :: elementType = "keplerian"
+ TYPE (Time) :: t0
+ REAL(bp) :: orbMjd
+ INTEGER :: j = 0
+ INTEGER :: err = 0
+ INTEGER :: element_type_index = -1
+
+ ! Init
+ error = .FALSE.
+ errorCode = 0
+ IF(PRESENT(element_type)) THEN
+ elementType = element_type
+ END IF
+ ! Figure out the element_type_index
+ DO j=1,SIZE(ORBITAL_ELEMENTS)
+ IF(elementType == ORBITAL_ELEMENTS(j)) THEN
+ element_type_index = j
+ EXIT
+ END IF
+ END DO
+ IF(element_type_index .LE. 0) THEN
+ ! Error: unsupported element type!
+ errorCode = 58
+ RETURN
+ END IF
+
+ CALL getResults(storb, sor_rho_cmp=sor_rho_cmp)
+ IF (error) THEN
+ ! write(*, *) "Error in getResults()"
+ errorCode = 15
+ RETURN
+ END IF
+ ! Get ORBITAL-ELEMENT PDF
+ orb_arr_cmp => getSampleOrbits(storb)
+ IF (error) THEN
+ ! write(*, *) "Error in getSampleOrbits()"
+ errorCode = 16
+ RETURN
+ END IF
+ pdf_arr_cmp => getPDFValues(storb)
+ IF (error) THEN
+ ! write(*, *) "Error in getPDFValues()"
+ errorCode = 17
+ RETURN
+ END IF
+ rchi2_arr_cmp => getReducedChi2Distribution(storb)
+ IF (error) THEN
+ ! write(*, *) "Error in getReducedChi2Distribution()"
+ errorCode = 17
+ RETURN
+ END IF
+ CALL getResults(storb, &
+ reg_apr_arr=reg_apr_arr_cmp, &
+ jac_arr=jac_arr_cmp)
+ IF (error) THEN
+ ! write(*, *) "Error in getResults()"
+ numOutOrbits = 0
+ errorCode = 18
+ RETURN
+ END IF
+
+ ! This is where we wrere originally writing the .orb file(s) out.
+ numOutOrbits = SIZE(orb_arr_cmp,dim=1)
+ ! if(.not. allocated(outOrbits)) then
+ ! allocate(outOrbits(numOutOrbits, 14), stat=err)
+ ! end if
+ ! if(err /= 0) then
+ ! ! Error in allocating memory.
+ ! errorCode = 54
+ ! return
+ ! end if
+ DO j=1,numOutOrbits
+ elements = getElements(orb_arr_cmp(j), &
+ elementType, &
+ frame="ecliptic")
+ IF (error) THEN
+ ! write(*, *) "Error in fetching the orbit"
+ errorCode = 19
+ RETURN
+ END IF
+ IF (elementType == "keplerian") THEN
+ elements(3:6) = elements(3:6)/rad_deg
+ ELSE IF (elementType == "delaunay") THEN
+ elements(1:3) = elements(1:3)/rad_deg
+ ELSE IF (elementType == "poincare") THEN
+ elements(4) = elements(4)/rad_deg
+ ELSE IF (elementType == "equinoctial") THEN
+ elements(6) = elements(6)/rad_deg
+ END IF
+
+ t0 = getTime(orb_arr_cmp(j))
+ orbMjd = getMjd(t0, internal_timescale)
+ CALL NULLIFY(t0)
+ IF (error) THEN
+ ! write(*, *) "Error in getTime/getMjd"
+ errorCode = 5
+ RETURN
+ END IF
+
+ ! Add the values to outOrbits.
+ ! outOrbits has the form (elements(1:6), epoch, Un-normalized p.d.f.,
+ ! Reduced chi2, Regularized apr, Jacobian det(1:3))
+ outOrbits(j, 1) = track_id
+ outOrbits(j, 2:7) = elements(1:6)
+ outOrbits(j, 8) = orbMjd
+ outOrbits(j, 9) = pdf_arr_cmp(j)
+ outOrbits(j, 10) = rchi2_arr_cmp(j)
+ outOrbits(j, 11) = reg_apr_arr_cmp(j)
+ outOrbits(j, 12:14) = jac_arr_cmp(j, 1:3)
+ outOrbits(j, 15) = element_type_index
+
+ ! write(*, *) "elements: ", elements(1:6)
+ ! write(*, *) "epoch: ", orbMjd
+ ! write(*, *) "Un-normalized p.d.f.: ", pdf_arr_cmp(j)
+ ! write(*, *) "Reduced chi2: ", rchi2_arr_cmp(j)
+ ! write(*, *) "Regularized apr: ", reg_apr_arr_cmp(j)
+ ! write(*, *) "Jacobian det: ", jac_arr_cmp(j, 1:3)
+ END DO
+
+ ! Cleanup everything
+ DO j=1,numOutOrbits
+ CALL NULLIFY(orb_arr_cmp(j))
+ END DO
+ DEALLOCATE(orb_arr_cmp, stat=err)
+ DEALLOCATE(pdf_arr_cmp, stat=err)
+ DEALLOCATE(rchi2_arr_cmp, stat=err)
+ DEALLOCATE(reg_apr_arr_cmp, stat=err)
+ DEALLOCATE(jac_arr_cmp, stat=err)
+ IF (err /= 0) THEN
+ ! write(*, *) "Error: Could not deallocate memory"
+ errorCode = 19
+ RETURN
+ END IF
+
+ END SUBROUTINE exportRangingOrbits
+
+
+ SUBROUTINE exportLslOrbit(storb, element_type, track_id, outOrbit, &
+ outCovariance, outSigmas, outCorrelation, &
+ errorCode)
+ TYPE (StochasticOrbit), INTENT(in) :: storb
+ CHARACTER(len=*), OPTIONAL, INTENT(in) :: element_type
+ INTEGER, INTENT(in) :: track_id
+ ! outOrbit has the form (track_id, elements(1:6), epoch, H, G)
+ REAL(bp), DIMENSION(11), INTENT(out) :: outOrbit
+ REAL(bp), DIMENSION(6,6), INTENT(out) :: outCovariance
+ REAL(bp), DIMENSION(6) :: outSigmas
+ REAL(bp), DIMENSION(6,6) :: outCorrelation
+ INTEGER, INTENT(out) :: errorCode
+
+ ! Internal variables.
+ REAL(bp), DIMENSION(6) :: elements
+ CHARACTER(len=ELEMENT_TYPE_LEN) :: elementType = "keplerian"
+ TYPE (Time) :: t0
+ REAL(bp) :: orbMjd
+ INTEGER :: j = 0
+ INTEGER :: k = 0
+ TYPE (Orbit) :: orb
+ INTEGER :: element_type_index = -1
+
+
+ ! Init
+ errorCode = 0
+ error = .FALSE.
+ IF(PRESENT(element_type)) THEN
+ elementType = element_type
+ END IF
+ ! Figure out the element_type_index
+ DO j=1,SIZE(ORBITAL_ELEMENTS)
+ IF(elementType == ORBITAL_ELEMENTS(j)) THEN
+ element_type_index = j
+ EXIT
+ END IF
+ END DO
+ IF(element_type_index .LE. 0) THEN
+ ! Error: unsupported element type!
+ errorCode = 58
+ RETURN
+ END IF
+
+ ! Get the nominal orbit out.
+ orb = getNominalOrbit(storb)
+ IF (error) THEN
+ ! write(*, *) "Error in getNominalOrbit()"
+ errorCode = 28
+ RETURN
+ END IF
+
+ ! Get the orbital elements.
+ elements = getElements(orb, elementType, frame="ecliptic")
+ IF (error) THEN
+ ! write(*, *) "Error in fetching the orbit"
+ errorCode = 19
+ RETURN
+ END IF
+ IF (elementType == "keplerian") THEN
+ elements(3:6) = elements(3:6)/rad_deg
+ ELSE IF (elementType == "delaunay") THEN
+ elements(1:3) = elements(1:3)/rad_deg
+ ELSE IF (elementType == "poincare") THEN
+ elements(4) = elements(4)/rad_deg
+ ELSE IF (elementType == "equinoctial") THEN
+ elements(6) = elements(6)/rad_deg
+ END IF
+
+ ! Get orbit epoch.
+ t0 = getTime(orb)
+ orbMjd = getMjd(t0, internal_timescale)
+ CALL NULLIFY(t0)
+ IF (error) THEN
+ ! write(*, *) "Error in getTime/getMjd"
+ errorCode = 5
+ RETURN
+ END IF
+
+ ! FIXME: compute H and G.
+ outOrbit(1) = track_id
+ outOrbit(2:7) = elements(1:6)
+ outOrbit(8) = orbMjd
+ outOrbit(9) = 99.0_bp ! FIXME: compute H
+ outOrbit(10) = 9.9_bp ! FIXME: compute G
+ outOrbit(11) = element_type_index
+
+ ! Covariance matrix.
+ outCovariance = getCovarianceMatrix(storb, elementType, "ecliptic")
+ IF (error) THEN
+ ! write(*, *) "Error in getCovarianceMatrix"
+ errorCode = 29
+ RETURN
+ END IF
+ DO j=1,6
+ outSigmas(j) = SQRT(outCovariance(j, j))
+ IF (elementType == "keplerian" .AND. j >= 3) THEN
+ outSigmas(j) = outSigmas(j) / rad_deg
+ END IF
+ END DO
+
+ ! Correlations.
+ DO j=1,6
+ DO k=1,6
+ outCorrelation(j,k) = outCovariance(j,k) / &
+ (outSigmas(j) * outSigmas(k))
+ END DO
+ END DO
+
+ ! write(*, *) "elements: ", elements(1:6)
+ ! write(*, *) "epoch: ", orbMjd
+ ! write(*, *) "Covariance: ", outCovariance
+ ! write(*, *) "Sigmas: ", outSigmas
+ ! write(*, *) "Correlation: ", outCorrelation
+
+ ! Cleanup everything
+ CALL NULLIFY(orb)
+
+ END SUBROUTINE exportLslOrbit
+
+
+ SUBROUTINE exportEphemeris(storb, ephemerides, cov, observers, &
+ outEphems, errorCode)
+ ! Input/Output variables.
+ TYPE(StochasticOrbit), INTENT(inout) :: storb
+ ! Output ephem array (intent(inout)).
+ TYPE (SphericalCoordinates), DIMENSION(:,:),POINTER :: ephemerides
+ ! Ephem uncertainty matrices (intent(inout)).
+ REAL(bp), DIMENSION(:,:,:), POINTER :: cov
+ ! observatory coordinates and ephem time array (intent(inout)).
+ TYPE (CartesianCoordinates), DIMENSION(:), POINTER :: observers
+ ! Output ephems:
+ ! ((dist, ra, dec, mag, mjd, raErr, decErr, smia, smaa, pa), )
+ REAL(bp), DIMENSION(SIZE(observers),10),INTENT(out) :: outEphems
+ ! Output error code
+ INTEGER, INTENT(out) :: errorCode
+
+ ! Internal vars.
+ TYPE (Time) :: t
+ INTEGER :: j = 0
+ INTEGER :: k = 0
+ INTEGER :: l = 0
+ REAL(bp) :: mjd = 0.0_bp
+ REAL(bp), DIMENSION(6) :: coordinates
+ REAL(bp), DIMENSION(6) :: stdev
+ REAL(bp), DIMENSION(6,6) :: corr
+
+
+ ! Init
+ error = .FALSE.
+ errorCode = 0
+
+
+ DO j=1,SIZE(observers)
+ t = getTime(observers(j))
+ mjd = getMJD(t, internal_timescale)
+ CALL NULLIFY(t)
+ IF (containsSampledPDF(storb)) THEN
+ ! We do not support exporting ephems from ranging orbits yet.
+ ! FIXME: support ephems from ranging orbits?
+ errorCode = 59
+ RETURN
+ END IF
+
+ ! Input orbits correspond to one or more single-point estimates of the pdf.
+ ! Make sure that the ephemeris is equatorial:
+ CALL rotateToEquatorial(ephemerides(1,j))
+ coordinates = getCoordinates(ephemerides(1,j))
+ DO k=1,6
+ stdev(k) = SQRT(cov(k,k,j))
+ END DO
+ DO k=1,6
+ DO l=1,6
+ corr(k,l) = cov(k,l,j) / &
+ (stdev(k)*stdev(l))
+ END DO
+ END DO
+
+ ! Write the output ephem array.
+ outEphems(j, 1) = coordinates(1) ! distance
+ outEphems(j, 2:3) = coordinates(2:3)/rad_deg ! ra/dec
+ ! FIXME: compute predicted magnitude!
+ outEphems(j, 4) = 99.0_bp ! mag
+ outEphems(j, 5) = mjd ! ephem mjd
+ ! FIXME: compute positional uncertainties.
+ outEphems(j, 6) = 99.0_bp ! raErr
+ outEphems(j, 7) = 99.0_bp ! decErr
+ outEphems(j, 8) = 99.0_bp ! semi-major axis
+ outEphems(j, 9) = 99.0_bp ! semi-minor axis
+ outEphems(j, 10) = 99.0_bp ! position angle
+ END DO
+
+ END SUBROUTINE exportEphemeris
+
+
+
+ SUBROUTINE calendarDateToMjd(year, month, day, mjd, timescale, errorCode)
+ INTEGER, INTENT(in) :: year
+ INTEGER, INTENT(in) :: month
+ ! day + time in fractional days.
+ REAL(bp), INTENT(in) :: day
+ CHARACTER(len=*), INTENT(in) :: timescale
+ REAL(bp), INTENT(out) :: mjd
+ INTEGER, INTENT(out) :: errorCode
+
+ ! Internal vars.
+ TYPE(Time) :: t
+
+
+ ! Init
+ error = .FALSE.
+ errorCode = 0
+
+ ! Create a Time instance.
+ CALL NEW(t, year, month, day, TRIM(timescale))
+ IF(error) THEN
+ ! Error in creating a Time object.
+ errorCode = 55
+ RETURN
+ END IF
+
+ ! Convert to MJD TAI
+ mjd = getMjd(t, internal_timescale)
+ IF(error) THEN
+ ! Error in converting to MJD.
+ errorCode = 56
+ RETURN
+ END IF
+
+ ! Cleanup.
+ CALL NULLIFY(t)
+
+ END SUBROUTINE calendarDateToMjd
+
+
+ SUBROUTINE mjdConvert(mjdIn, timescaleIn, mjdOut, timescaleOut, errorCode)
+ ! Input variables
+ REAL(bp), INTENT(in) :: mjdIn
+ CHARACTER(len=*), INTENT(in) :: timescaleIn
+ REAL(bp), INTENT(out) :: mjdOut
+ CHARACTER(len=*), INTENT(in) :: timescaleOut
+ INTEGER, INTENT(out) :: errorCode
+
+ ! Internal vars.
+ TYPE(Time) :: t
+
+
+ ! Init
+ error = .FALSE.
+ errorCode = 0
+ mjdOut = -1.0_bp
+
+ ! Create a Time instance.
+ CALL NEW(t, mjdIn, TRIM(timescaleIn))
+ IF(error) THEN
+ ! Error in creating a Time object.
+ errorCode = 55
+ RETURN
+ END IF
+
+ ! Convert to the desired timescale.
+ mjdOut = getMjd(t, TRIM(timescaleOut))
+ IF(error) THEN
+ ! Error in converting to MJD.
+ errorCode = 56
+ RETURN
+ END IF
+
+ ! Cleanup.
+ CALL NULLIFY(t)
+
+ END SUBROUTINE mjdConvert
+
+END MODULE liboorb
Index: trunk/mops/oorb/python/pyoorb.f90
===================================================================
--- trunk/mops/oorb/python/pyoorb.f90 (revision 34646)
+++ trunk/mops/oorb/python/pyoorb.f90 (revision 34646)
@@ -0,0 +1,918 @@
+!====================================================================!
+! !
+! Copyright 2002,2003,2004,2005,2006,2007,2008,2009 !
+! Mikael Granvik, Jenni Virtanen, Karri Muinonen, Teemu Laakso, !
+! Dagmara Oszkiewicz !
+! !
+! This file is part of OpenOrb. !
+! !
+! OpenOrb 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. !
+! !
+! OpenOrb 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 OpenOrb. If not, see . !
+! !
+!====================================================================!
+!
+!! Module for which f2py builds Python wrappers.
+!!
+!! @author MG, FP
+!! @version 2009-12-11
+!!
+MODULE pyoorb
+
+ USE planetary_data
+ USE Base_cl
+ USE Time_cl
+ USE SphericalCoordinates_cl
+ USE Observatories_cl
+ USE Orbit_cl
+ USE StochasticOrbit_cl
+ USE PhysicalParameters_cl
+ IMPLICIT NONE
+ TYPE (Observatories), SAVE, PRIVATE :: obsies
+ CHARACTER(len=11), DIMENSION(6), PUBLIC :: element_types = (/ &
+ "cartesian ",&
+ "cometary ",&
+ "keplerian ",&
+ "delaunay ",&
+ "poincare ",&
+ "equinoctial" &
+ /)
+ CHARACTER(len=3), DIMENSION(4), PUBLIC :: timescales = (/ &
+ "UTC",&
+ "UT1",&
+ "TT ",&
+ "TAI" &
+ /)
+
+CONTAINS
+
+
+
+ SUBROUTINE oorb_init(ephemeris_fname, error_verbosity, &
+ info_verbosity, error_code)
+
+ IMPLICIT NONE
+ CHARACTER(len=*), INTENT(in), OPTIONAL :: ephemeris_fname
+ INTEGER, INTENT(in), OPTIONAL :: error_verbosity
+ INTEGER, INTENT(in), OPTIONAL :: info_verbosity
+ INTEGER, INTENT(out) :: error_code
+
+ TYPE (Time) :: t
+
+ ! Set path to data files by reading env parameter OORB_DATA_DIR:
+ CALL setAccessToDataFiles()
+
+ ! Read OBSCODE.dat
+ CALL NEW(obsies)
+ IF (error) THEN
+ error_code = 1
+ error = .FALSE.
+ RETURN
+ END IF
+
+ ! Read TAI-UTC.dat and ET-UT.dat
+ CALL NEW(t)
+ IF (error) THEN
+ error_code = 2
+ error = .FALSE.
+ RETURN
+ END IF
+
+ ! Read de405.dat
+ IF (PRESENT(ephemeris_fname)) THEN
+ CALL JPL_ephemeris_init(error, ephemeris_fname)
+ IF (error) THEN
+ error_code = 3
+ error = .FALSE.
+ RETURN
+ END IF
+ ELSE
+ CALL JPL_ephemeris_init(error, &
+ filename=TRIM(OORB_DATA_DIR) // "/" // TRIM(EPH_FNAME))
+ IF (error) THEN
+ error_code = 4
+ error = .FALSE.
+ RETURN
+ END IF
+ END IF
+
+ ! Set verbosity of error messages (0=nothing,5=everything,1=default)
+ IF (PRESENT(error_verbosity)) THEN
+ err_verb = error_verbosity
+ ELSE
+ err_verb = 1
+ END IF
+
+ ! Set verbosity of info messages (0=nothing,5=everything,1=default)
+ IF (PRESENT(info_verbosity)) THEN
+ info_verb = info_verbosity
+ ELSE
+ info_verb = 1
+ END IF
+
+ END SUBROUTINE oorb_init
+
+
+
+
+
+ SUBROUTINE oorb_memfree()
+
+ IMPLICIT NONE
+
+ CALL nullifyTime()
+ CALL NULLIFY(obsies)
+ CALL JPL_ephemeris_nullify()
+
+ END SUBROUTINE oorb_memfree
+
+
+
+
+
+ SUBROUTINE oorb_element_transformation(in_norb, &
+ in_orbits, &
+ in_element_type, &
+ out_orbits, &
+ error_code)
+
+ ! Input/Output variables.
+ INTEGER, INTENT(in) :: in_norb
+ ! Input flattened orbit:
+ ! (track_id, elements(1:6), element_type_index, epoch, timescale, H, G)
+ REAL(8),DIMENSION(in_norb,12), INTENT(in) :: in_orbits ! (1:norb,1:12)
+ ! Type of output elements
+ INTEGER, INTENT(in) :: in_element_type
+ ! Output flattened orbit:
+ ! (track_id, elements(1:6), element_type_index, epoch, timescale, H, G)
+ REAL(8),DIMENSION(in_norb,12), INTENT(out) :: out_orbits ! (1:norb,1:12)
+ ! Output error code
+ INTEGER, INTENT(out) :: error_code
+
+ TYPE (Time) :: t
+ TYPE (Orbit) :: orb
+ INTEGER :: i
+
+ ! Loop over orbits:
+ DO i=1,SIZE(in_orbits,dim=1)
+
+ ! Get the element type from the input flattened orbit.
+ IF(NINT(in_orbits(i,8)) < 0 .OR. &
+ NINT(in_orbits(i,8)) > SIZE(element_types)) THEN
+ ! Error: unsupported orbital elements.
+ error_code = 58
+ RETURN
+ END IF
+
+ ! Get each flattened orbit and create an Orbit instance. First
+ ! create a Time instance:
+ CALL NEW(t, in_orbits(i,9), timescales(NINT(in_orbits(i,10))))
+ IF (error) THEN
+ ! Error in creating a Time instance.
+ error_code = 57
+ RETURN
+ END IF
+
+ ! Now create an Orbit instance:
+ CALL NEW(orb, &
+ in_orbits(i,2:7), &
+ element_types(NINT(in_orbits(i,8))), &
+ "ecliptic", &
+ copy(t))
+ CALL NULLIFY(t)
+
+ out_orbits(i,1) = in_orbits(i,1)
+ out_orbits(i,2:7) = getElements(orb, element_types(in_element_type), &
+ "ecliptic")
+ IF (error) THEN
+ ! Error in transformation
+ error_code = 58
+ RETURN
+ END IF
+ out_orbits(i,8) = REAL(in_element_type,8)
+ out_orbits(i,9:) = in_orbits(i,9:)
+ CALL NULLIFY(orb)
+
+ END DO
+
+ END SUBROUTINE oorb_element_transformation
+
+
+
+
+
+ SUBROUTINE oorb_propagation_2b(in_norb, &
+ in_orbits, &
+ in_epoch, &
+ out_orbits, &
+ error_code)
+
+ ! Input/Output variables.
+ INTEGER, INTENT(in) :: in_norb
+ ! Input flattened orbit:
+ ! (track_id, elements(1:6), element_type_index, epoch, timescale, H, G)
+ REAL(8),DIMENSION(in_norb,12), INTENT(in) :: in_orbits ! (1:norb,1:12)
+ ! Epoch and timescale of output orbits
+ REAL(8), DIMENSION(2), INTENT(in) :: in_epoch
+ ! Output flattened orbit:
+ ! (track_id, elements(1:6), element_type_index, epoch, timescale, H, G)
+ REAL(8),DIMENSION(in_norb,12), INTENT(out) :: out_orbits ! (1:norb,1:12)
+ ! Output error code
+ INTEGER, INTENT(out) :: error_code
+
+ TYPE (Orbit) :: orb
+ TYPE (Time) :: t0, t1
+ CHARACTER(len=INTEGRATOR_LEN) :: integrator
+ CHARACTER(len=6) :: dyn_model
+ REAL(8) :: integration_step
+ INTEGER :: i
+ LOGICAL, DIMENSION(10) :: perturbers
+
+ ! Init
+ errstr = ""
+ error_code = 0
+ dyn_model = "2-body"
+ integrator = "bulirsch-stoer"
+ integration_step = 5.0_8
+ perturbers = .TRUE.
+
+ ! Loop over orbits:
+ DO i=1,SIZE(in_orbits,dim=1)
+
+ ! Get the element type from the input flattened orbit.
+ IF(NINT(in_orbits(i,8)) < 0 .OR. &
+ NINT(in_orbits(i,8)) > SIZE(element_types)) THEN
+ ! Error: unsupported orbital elements.
+ error_code = 58
+ RETURN
+ END IF
+
+ ! Get each flattened orbit and create an Orbit instance.
+ ! First create a Time instance corresponding to the orbit epoch.
+ CALL NEW(t0, in_orbits(i,9), timescales(NINT(in_orbits(i,10))))
+ IF(error) THEN
+ ! Error in creating a Time instance.
+ error_code = 57
+ RETURN
+ END IF
+
+ ! Now create an Orbit instance.
+ CALL NEW(orb, &
+ in_orbits(i,2:7), &
+ element_types(NINT(in_orbits(i,8))), &
+ "ecliptic", &
+ copy(t0))
+ CALL NULLIFY(t0)
+ CALL setParameters(orb, &
+ dyn_model=dyn_model, &
+ perturbers=perturbers, &
+ integrator=integrator, &
+ integration_step=integration_step)
+ IF (error) THEN
+ error_code = 37
+ RETURN
+ END IF
+ ! Create a Time instance based on the requested output epoch
+ CALL NEW(t1, in_epoch(1), timescales(NINT(in_epoch(2))))
+ IF (error) THEN
+ ! Error in transformation
+ error_code = 58
+ RETURN
+ END IF
+ ! Compute topocentric ephemerides
+ CALL propagate(orb, &
+ t1)
+ IF (error) THEN
+ ! Error in getEphemerides()
+ error_code = 40
+ RETURN
+ END IF
+ out_orbits(i,1) = in_orbits(i,1)
+ out_orbits(i,2:7) = getElements(orb, element_types(NINT(in_orbits(i,8))), &
+ "ecliptic")
+ IF (error) THEN
+ ! Error in transformation
+ error_code = 58
+ RETURN
+ END IF
+ out_orbits(i,8:) = in_orbits(i,8:)
+ CALL NULLIFY(orb)
+ END DO
+
+ END SUBROUTINE oorb_propagation_2b
+
+
+
+
+
+ SUBROUTINE oorb_propagation_nb(in_norb, &
+ in_orbits, &
+ in_epoch, &
+ out_orbits, &
+ error_code)
+
+ ! Input/Output variables.
+ INTEGER, INTENT(in) :: in_norb
+ ! Input flattened orbit:
+ ! (track_id, elements(1:6), element_type_index, epoch, timescale, H, G)
+ REAL(8),DIMENSION(in_norb,12), INTENT(in) :: in_orbits ! (1:norb,1:12)
+ ! Epoch and timescale of output orbits
+ REAL(8), DIMENSION(2), INTENT(in) :: in_epoch
+ ! Output flattened orbit:
+ ! (track_id, elements(1:6), element_type_index, epoch, timescale, H, G)
+ REAL(8),DIMENSION(in_norb,12), INTENT(out) :: out_orbits ! (1:norb,1:12)
+ ! Output error code
+ INTEGER, INTENT(out) :: error_code
+
+ TYPE (Orbit) :: orb
+ TYPE (Time) :: t0, t1
+ CHARACTER(len=INTEGRATOR_LEN) :: integrator
+ CHARACTER(len=6) :: dyn_model
+ REAL(8) :: integration_step
+ INTEGER :: i
+ LOGICAL, DIMENSION(10) :: perturbers
+
+ ! Init
+ errstr = ""
+ error_code = 0
+ dyn_model = "n-body"
+ integrator = "bulirsch-stoer"
+ integration_step = 5.0_8
+ perturbers = .TRUE.
+
+ ! Loop over orbits:
+ DO i=1,SIZE(in_orbits,dim=1)
+
+ ! Get the element type from the input flattened orbit.
+ IF(NINT(in_orbits(i,8)) < 0 .OR. &
+ NINT(in_orbits(i,8)) > SIZE(element_types)) THEN
+ ! Error: unsupported orbital elements.
+ error_code = 58
+ RETURN
+ END IF
+
+ ! Get each flattened orbit and create an Orbit instance.
+ ! First create a Time instance corresponding to the orbit epoch.
+ CALL NEW(t0, in_orbits(i,9), timescales(NINT(in_orbits(i,10))))
+ IF(error) THEN
+ ! Error in creating a Time instance.
+ error_code = 57
+ RETURN
+ END IF
+
+ ! Now create an Orbit instance.
+ CALL NEW(orb, &
+ in_orbits(i,2:7), &
+ element_types(NINT(in_orbits(i,8))), &
+ "ecliptic", &
+ copy(t0))
+ CALL NULLIFY(t0)
+ CALL setParameters(orb, &
+ dyn_model=dyn_model, &
+ perturbers=perturbers, &
+ integrator=integrator, &
+ integration_step=integration_step)
+ IF (error) THEN
+ error_code = 37
+ RETURN
+ END IF
+ ! Create a Time instance based on the requested output epoch
+ CALL NEW(t1, in_epoch(1), timescales(NINT(in_epoch(2))))
+ IF (error) THEN
+ ! Error in transformation
+ error_code = 58
+ RETURN
+ END IF
+ ! Compute topocentric ephemerides
+ CALL propagate(orb, &
+ t1)
+ IF (error) THEN
+ ! Error in getEphemerides()
+ error_code = 40
+ RETURN
+ END IF
+ out_orbits(i,1) = in_orbits(i,1)
+ out_orbits(i,2:7) = getElements(orb, element_types(NINT(in_orbits(i,8))), &
+ "ecliptic")
+ IF (error) THEN
+ ! Error in transformation
+ error_code = 58
+ RETURN
+ END IF
+ out_orbits(i,8:) = in_orbits(i,8:)
+ CALL NULLIFY(orb)
+ END DO
+
+ END SUBROUTINE oorb_propagation_nb
+
+
+
+
+
+ SUBROUTINE oorb_ephemeris(in_norb, &
+ in_orbits, &
+ in_obscode, &
+ in_ndate, &
+ in_date_ephems, &
+ out_ephems, &
+ error_code)
+
+ ! Input/Output variables.
+ INTEGER, INTENT(in) :: in_norb
+ ! Input flattened orbit:
+ ! (track_id, elements(1:6), element_type_index, epoch, timescale, H, G)
+ REAL(8),DIMENSION(in_norb,12), INTENT(in) :: in_orbits ! (1:norb,1:12)
+ ! Observatory code as defined by the Minor Planet Center
+ CHARACTER(len=*), INTENT(in) :: in_obscode
+ INTEGER, INTENT(in) :: in_ndate
+ ! Ephemeris dates.
+ ! (mjd, timescale)
+ REAL(8), DIMENSION(in_ndate,2), INTENT(in) :: in_date_ephems ! (1:ndate,1:2)
+ ! Output ephemeris
+ ! out_ephems = ((dist, ra, dec, mag, mjd, timescale, dra/dt, ddec/dt), )
+ REAL(8), DIMENSION(in_norb,in_ndate,8), INTENT(out) :: out_ephems ! (1:norb,1:ndate,1:8)
+ ! Output error code
+ INTEGER, INTENT(out) :: error_code
+
+ ! Internal variables.
+ TYPE (Orbit), DIMENSION(:,:), POINTER :: orb_lt_corr_arr
+ TYPE (Orbit), DIMENSION(1) :: orb_arr
+ TYPE (CartesianCoordinates), DIMENSION(:), ALLOCATABLE :: observers
+ TYPE (CartesianCoordinates) :: ccoord
+ TYPE (SphericalCoordinates), DIMENSION(:,:), POINTER :: ephemerides
+ TYPE (Time) :: t
+ CHARACTER(len=INTEGRATOR_LEN) :: integrator
+ CHARACTER(len=6) :: dyn_model
+ REAL(8), DIMENSION(6) :: coordinates, &
+ elements
+ REAL(8), DIMENSION(3) :: obsy_obj, &
+ obsy_pos, &
+ pos
+ REAL(8) :: cos_phase, &
+ ephemeris_r2, &
+ heliocentric_r2, &
+ integration_step, &
+ mjd, &
+ observer_r2, &
+ phase, &
+ vmag
+ INTEGER :: i, &
+ j
+ LOGICAL, DIMENSION(10) :: perturbers
+
+ ! Init
+ errstr = ""
+ error_code = 0
+ dyn_model = "n-body"
+ integrator = "bulirsch-stoer"
+ integration_step = 5.0_8
+ perturbers = .TRUE.
+ ALLOCATE(observers(SIZE(in_date_ephems,dim=1)))
+ DO i=1,SIZE(in_date_ephems,dim=1)
+ CALL NEW(t, in_date_ephems(i,1), timescales(NINT(in_date_ephems(i,2))))
+ IF (error) THEN
+ ! Error in creating a new Time object.
+ error_code = 35
+ RETURN
+ END IF
+ ! Compute heliocentric observatory coordinates
+ observers(i) = getObservatoryCCoord(obsies, in_obscode, t)
+ IF (error) THEN
+ ! Error in getObservatoryCCoord()
+ error_code = 36
+ RETURN
+ END IF
+ CALL rotateToEquatorial(observers(i))
+ CALL NULLIFY(t)
+ END DO
+
+ ! Loop over orbits:
+ DO i=1,SIZE(in_orbits,dim=1)
+
+ ! Get the element type from the input flattened orbit.
+ IF(NINT(in_orbits(i,8)) < 0 .OR. &
+ NINT(in_orbits(i,8)) > SIZE(element_types)) THEN
+ ! Error: unsupported orbital elements.
+ error_code = 58
+ RETURN
+ END IF
+
+ ! Get each flattened orbit and create an Orbit instance.
+ elements(1:6) = in_orbits(i,2:7)
+ ! Create a Time instance.
+ CALL NEW(t, in_orbits(i,9), timescales(NINT(in_orbits(i,10))))
+ IF(error) THEN
+ ! Error in creating a Time instance.
+ error_code = 57
+ RETURN
+ END IF
+
+ ! Now create an instant of StochasticOrbit via an Orbit instance.
+ CALL NEW(orb_arr(1), &
+ elements(1:6), &
+ element_types(NINT(in_orbits(i,8))), &
+ "ecliptic", &
+ copy(t))
+ CALL NULLIFY(t)
+ CALL setParameters(orb_arr(1), &
+ dyn_model=dyn_model, &
+ perturbers=perturbers, &
+ integrator=integrator, &
+ integration_step=integration_step)
+ IF (error) THEN
+ error_code = 37
+ RETURN
+ END IF
+ ! Use cartesian equatorial coordinates:
+ CALL toCartesian(orb_arr(1), "equatorial")
+ !CALL toCometary(orb_arr(1))
+ IF (error) THEN
+ ! Error in setParameters()
+ error_code = 39
+ RETURN
+ END IF
+ ! Compute topocentric ephemerides
+ CALL getEphemerides(orb_arr, &
+ observers, &
+ ephemerides, &
+ this_lt_corr_arr=orb_lt_corr_arr)
+ IF (error) THEN
+ ! Error in getEphemerides()
+ error_code = 40
+ RETURN
+ END IF
+ CALL NULLIFY(orb_arr(1))
+
+ ! Now export the ephem_arr to a flat array.
+ DO j=1,SIZE(observers)
+
+ ! Make sure that the ephemeris is equatorial:
+ CALL rotateToEquatorial(ephemerides(1,j))
+ ! Extract RA & Dec
+ coordinates = getCoordinates(ephemerides(1,j))
+
+ ! Calculate apparent brightness
+ CALL NEW(ccoord, ephemerides(1,j))
+ IF (error) THEN
+ CALL errorMessage('oorb / ephemeris', &
+ 'TRACE BACK (50)',1)
+ STOP
+ END IF
+ CALL rotateToEquatorial(ccoord)
+ obsy_obj = getPosition(ccoord)
+ IF (error) THEN
+ CALL errorMessage('oorb / ephemeris', &
+ 'TRACE BACK (55)',1)
+ STOP
+ END IF
+ CALL NULLIFY(ccoord)
+ ephemeris_r2 = DOT_PRODUCT(obsy_obj,obsy_obj)
+ CALL toCartesian(orb_lt_corr_arr(1,j), frame='equatorial')
+ pos = getPosition(orb_lt_corr_arr(1,j))
+ IF (error) THEN
+ CALL errorMessage('oorb / ephemeris', &
+ 'TRACE BACK (60)',1)
+ STOP
+ END IF
+ heliocentric_r2 = DOT_PRODUCT(pos,pos)
+ obsy_pos = getPosition(observers(j))
+ IF (error) THEN
+ CALL errorMessage('oorb / ephemeris', &
+ 'TRACE BACK (65)',1)
+ STOP
+ END IF
+ observer_r2 = DOT_PRODUCT(obsy_pos,obsy_pos)
+ cos_phase = 0.5_bp * (heliocentric_r2 + ephemeris_r2 - &
+ observer_r2) / (SQRT(heliocentric_r2) * &
+ SQRT(ephemeris_r2))
+ phase = ACOS(cos_phase)
+ vmag = getApparentMagnitude(H=in_orbits(i,11), &
+ G=in_orbits(i,12), r=SQRT(heliocentric_r2), &
+ Delta=coordinates(1), phase_angle=phase)
+ IF (error) THEN
+ CALL errorMessage('oorb / ephemeris', &
+ 'TRACE BACK (70)',1)
+ STOP
+ END IF
+
+ ! ephem date
+ t = getTime(observers(j))
+ mjd = getMJD(t, timescales(NINT(in_date_ephems(j,2))))
+ CALL NULLIFY(t)
+
+ ! Write the output ephem array.
+ out_ephems(i,j,1) = coordinates(1) ! distance
+ out_ephems(i,j,2) = coordinates(2)/rad_deg ! ra
+ out_ephems(i,j,3) = coordinates(3)/rad_deg ! dec
+ out_ephems(i,j,4) = vmag ! mag
+ out_ephems(i,j,5) = mjd ! ephem mjd
+ out_ephems(i,j,6) = NINT(in_date_ephems(j,2)) ! ephem mjd timescale
+ out_ephems(i,j,7) = coordinates(5)*COS(coordinates(3))/rad_deg ! dra/dt sky-motion
+ out_ephems(i,j,8) = coordinates(6)/rad_deg ! ddec/dt sky-motion
+
+ CALL NULLIFY(ephemerides(1,j))
+ CALL NULLIFY(orb_lt_corr_arr(1,j))
+
+ END DO
+
+ DEALLOCATE(ephemerides, orb_lt_corr_arr)
+
+ END DO
+ DO i=1,SIZE(observers)
+ CALL NULLIFY(observers(i))
+ END DO
+ DEALLOCATE(observers)
+
+ END SUBROUTINE oorb_ephemeris
+
+
+
+
+
+ SUBROUTINE oorb_ephemeris_covariance(in_norb, &
+ in_orbits, &
+ in_covariances, &
+ in_obscode, &
+ in_ndate, &
+ in_date_ephems, &
+ out_ephems, &
+ error_code)
+
+ ! Input/Output variables.
+ INTEGER, INTENT(in) :: in_norb
+ ! Input flattened orbit:
+ ! (track_id, elements(1:6), element_type_index, epoch, timescale, H, G)
+ REAL(8),DIMENSION(in_norb,12), INTENT(in) :: in_orbits ! (1:norb,1:12)
+ ! Covariance matrices:
+ REAL(8), DIMENSION(in_norb,6,6), INTENT(in) :: in_covariances ! (1:norb,1:6,1:6)
+ ! Observatory code as defined by the Minor Planet Center
+ CHARACTER(len=*), INTENT(in) :: in_obscode
+ INTEGER, INTENT(in) :: in_ndate
+ ! Ephemeris dates.
+ ! (mjd, timescale)
+ REAL(8), DIMENSION(in_ndate,2), INTENT(in) :: in_date_ephems ! (1:ndate,1:2)
+ ! Output ephemeris
+ ! out_ephems = ((dist, ra, dec, mag, mjd, timescale, dra/dt, ddec/dt, raErr, decErr, smaa, smia, pa), )
+ REAL(8), DIMENSION(in_norb,in_ndate,13), INTENT(out) :: out_ephems ! (1:norb,1:ndate,1:13)
+ ! Output error code
+ INTEGER, INTENT(out) :: error_code
+
+ ! Internal variables.
+ TYPE (StochasticOrbit) :: storb
+ TYPE (Orbit), DIMENSION(:,:), POINTER :: orb_lt_corr_arr
+ TYPE (Orbit), DIMENSION(1) :: orb_arr
+ TYPE (CartesianCoordinates), DIMENSION(:), ALLOCATABLE :: observers
+ TYPE (CartesianCoordinates) :: ccoord
+ TYPE (SphericalCoordinates), DIMENSION(:,:), POINTER :: ephemerides
+ TYPE (Time) :: t
+ CHARACTER(len=INTEGRATOR_LEN) :: integrator
+ CHARACTER(len=6) :: dyn_model
+ REAL(8), DIMENSION(:,:,:), POINTER :: cov_arr
+ REAL(8), DIMENSION(6,6) :: eigenvec
+ REAL(8), DIMENSION(6) :: coordinates, &
+ eigenval, &
+ elements
+ REAL(8), DIMENSION(3) :: obsy_obj, &
+ obsy_pos, &
+ pos
+ REAL(8) :: cos_phase, &
+ ephemeris_r2, &
+ heliocentric_r2, &
+ integration_step, &
+ mjd, &
+ observer_r2, &
+ pa, &
+ phase, &
+ sigma_dec, &
+ sigma_ra, &
+ smaa, &
+ smia, &
+ vmag
+ INTEGER :: ismaa, &
+ ismia, &
+ i, &
+ j, &
+ nrot
+ LOGICAL, DIMENSION(10) :: perturbers
+
+ ! Init
+ errstr = ""
+ error_code = 0
+ eigenval = 0.0_8
+ eigenvec = 0.0_8
+ dyn_model = "n-body"
+ integrator = "bulirsch-stoer"
+ integration_step = 5.0_8
+ perturbers = .TRUE.
+ ALLOCATE(observers(SIZE(in_date_ephems,dim=1)))
+ DO i=1,SIZE(in_date_ephems,dim=1)
+ CALL NEW(t, in_date_ephems(i,1), timescales(NINT(in_date_ephems(i,2))))
+ IF (error) THEN
+ ! Error in creating a new Time object.
+ error_code = 35
+ RETURN
+ END IF
+ ! Compute heliocentric observatory coordinates
+ observers(i) = getObservatoryCCoord(obsies, in_obscode, t)
+ IF (error) THEN
+ ! Error in getObservatoryCCoord()
+ error_code = 36
+ RETURN
+ END IF
+ CALL rotateToEquatorial(observers(i))
+ CALL NULLIFY(t)
+ END DO
+
+ ! Loop over orbits:
+ DO i=1,SIZE(in_orbits,dim=1)
+
+ ! Get the element type from the input flattened orbit.
+ IF(NINT(in_orbits(i,8)) < 0 .OR. &
+ NINT(in_orbits(i,8)) > SIZE(element_types)) THEN
+ ! Error: unsupported orbital elements.
+ error_code = 58
+ RETURN
+ END IF
+
+ ! Get each flattened orbit and create an Orbit instance.
+ elements(1:6) = in_orbits(i,2:7)
+ ! Create a Time instance.
+ CALL NEW(t, in_orbits(i,9), timescales(NINT(in_orbits(i,10))))
+ IF(error) THEN
+ ! Error in creating a Time instance.
+ error_code = 57
+ RETURN
+ END IF
+
+ ! Now create an instant of StochasticOrbit via an Orbit instance.
+ CALL NEW(orb_arr(1), &
+ elements(1:6), &
+ element_types(NINT(in_orbits(i,8))), &
+ "ecliptic", &
+ copy(t))
+ CALL NULLIFY(t)
+ CALL setParameters(orb_arr(1), &
+ dyn_model=dyn_model, &
+ perturbers=perturbers, &
+ integrator=integrator, &
+ integration_step=integration_step)
+ IF (error) THEN
+ error_code = 37
+ RETURN
+ END IF
+ CALL NEW(storb, orb_arr(1), in_covariances(i,:,:), &
+ cov_type=element_types(NINT(in_orbits(i,8))), &
+ element_type=element_types(NINT(in_orbits(i,8))))
+ IF (error) THEN
+ error_code = 34
+ RETURN
+ END IF
+ ! Use cartesian equatorial coordinates:
+ CALL toCartesian(storb, "equatorial")
+ !CALL toCometary(storb)
+ IF (error) THEN
+ ! Error in setParameters()
+ error_code = 36
+ RETURN
+ END IF
+
+ ! Set integration parameters
+ CALL setParameters(storb, &
+ dyn_model=dyn_model, &
+ perturbers=perturbers, &
+ integrator=integrator, &
+ integration_step=integration_step)
+ IF (error) THEN
+ ! Error in setParameters()
+ error_code = 37
+ RETURN
+ END IF
+
+ ! Compute topocentric ephemerides
+ CALL getEphemerides(storb, &
+ observers, &
+ ephemerides, &
+ cov_arr=cov_arr, &
+ this_lt_corr_arr=orb_lt_corr_arr)
+ IF (error) THEN
+ ! Error in getEphemerides()
+ error_code = 38
+ RETURN
+ END IF
+ CALL NULLIFY(storb)
+ CALL NULLIFY(orb_arr(1))
+
+ ! Now export the ephem_arr to a flat array.
+ DO j=1,SIZE(observers)
+
+ ! Make sure that the ephemeris is equatorial:
+ CALL rotateToEquatorial(ephemerides(1,j))
+ ! Extract RA & Dec
+ coordinates = getCoordinates(ephemerides(1,j))
+
+ ! Calculate apparent brightness
+ CALL NEW(ccoord, ephemerides(1,j))
+ IF (error) THEN
+ CALL errorMessage('oorb / ephemeris', &
+ 'TRACE BACK (50)',1)
+ STOP
+ END IF
+ CALL rotateToEquatorial(ccoord)
+ obsy_obj = getPosition(ccoord)
+ IF (error) THEN
+ CALL errorMessage('oorb / ephemeris', &
+ 'TRACE BACK (55)',1)
+ STOP
+ END IF
+ CALL NULLIFY(ccoord)
+ ephemeris_r2 = DOT_PRODUCT(obsy_obj,obsy_obj)
+ CALL toCartesian(orb_lt_corr_arr(1,j), frame='equatorial')
+ pos = getPosition(orb_lt_corr_arr(1,j))
+ IF (error) THEN
+ CALL errorMessage('oorb / ephemeris', &
+ 'TRACE BACK (60)',1)
+ STOP
+ END IF
+ heliocentric_r2 = DOT_PRODUCT(pos,pos)
+ obsy_pos = getPosition(observers(j))
+ IF (error) THEN
+ CALL errorMessage('oorb / ephemeris', &
+ 'TRACE BACK (65)',1)
+ STOP
+ END IF
+ observer_r2 = DOT_PRODUCT(obsy_pos,obsy_pos)
+ cos_phase = 0.5_bp * (heliocentric_r2 + ephemeris_r2 - &
+ observer_r2) / (SQRT(heliocentric_r2) * &
+ SQRT(ephemeris_r2))
+ phase = ACOS(cos_phase)
+ vmag = getApparentMagnitude(H=in_orbits(i,11), &
+ G=in_orbits(i,12), r=SQRT(heliocentric_r2), &
+ Delta=coordinates(1), phase_angle=phase)
+ IF (error) THEN
+ CALL errorMessage('oorb / ephemeris', &
+ 'TRACE BACK (70)',1)
+ STOP
+ END IF
+
+ ! ephem date
+ t = getTime(observers(j))
+ mjd = getMJD(t, timescales(NINT(in_date_ephems(j,2))))
+ CALL NULLIFY(t)
+
+ cov_arr(:,:,j) = SIGN(SQRT(ABS(cov_arr(:,:,j))),cov_arr(:,:,j))
+ sigma_ra = cov_arr(2,2,j)/rad_asec
+ sigma_dec = cov_arr(3,3,j)/rad_asec
+ CALL eigen_decomposition_jacobi(cov_arr(2:3,2:3,j), &
+ eigenval(2:3), eigenvec(2:3,2:3), nrot, errstr)
+ IF (LEN_TRIM(errstr) /= 0) THEN
+ error_code = 7
+ WRITE(*,*) TRIM(errstr)
+ RETURN
+ END IF
+ ismaa = 1 + MAXLOC(ABS(eigenval(2:3)),dim=1)
+ ismia = 1 + MINLOC(ABS(eigenval(2:3)),dim=1)
+ smaa = ABS(eigenval(ismaa))/rad_amin
+ smia = ABS(eigenval(ismia))/rad_amin
+ pa = ATAN2(eigenvec(3,ismaa),eigenvec(2,ismaa))/rad_deg
+ ! Write the output ephem array.
+ out_ephems(i,j,1) = coordinates(1) ! distance
+ out_ephems(i,j,2) = coordinates(2)/rad_deg ! ra
+ out_ephems(i,j,3) = coordinates(3)/rad_deg ! dec
+ out_ephems(i,j,4) = vmag ! mag
+ out_ephems(i,j,5) = mjd ! ephem mjd
+ out_ephems(i,j,6) = NINT(in_date_ephems(j,2)) ! ephem mjd timescale
+ out_ephems(i,j,7) = coordinates(5)*COS(coordinates(3))/rad_deg ! dra/dt sky-motion
+ out_ephems(i,j,8) = coordinates(6)/rad_deg ! ddec/dt sky-motion
+ out_ephems(i,j,9) = sigma_ra ! raErr
+ out_ephems(i,j,10) = sigma_dec ! decErr
+ out_ephems(i,j,11) = smaa ! semi-major axis
+ out_ephems(i,j,12) = smia ! semi-minor axis
+ out_ephems(i,j,13) = pa ! position angle
+
+ CALL NULLIFY(ephemerides(1,j))
+ CALL NULLIFY(orb_lt_corr_arr(1,j))
+
+ END DO
+
+ DEALLOCATE(ephemerides, orb_lt_corr_arr, cov_arr)
+
+ END DO
+ DO i=1,SIZE(observers)
+ CALL NULLIFY(observers(i))
+ END DO
+ DEALLOCATE(observers)
+
+ END SUBROUTINE oorb_ephemeris_covariance
+
+
+
+END MODULE pyoorb
Index: trunk/mops/oorb/python/setup.py
===================================================================
--- trunk/mops/oorb/python/setup.py (revision 34646)
+++ trunk/mops/oorb/python/setup.py (revision 34646)
@@ -0,0 +1,36 @@
+#!/usr/bin/env python
+#
+# LSST Data Management System
+# Copyright 2008, 2009 LSST Corporation.
+#
+# This product includes software developed by the
+# LSST Project (http://www.lsst.org/).
+#
+# This program 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.
+#
+# This program 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 LSST License Statement and
+# the GNU General Public License along with this program. If not,
+# see .
+#
+# F. Pierfederici
+from distutils.core import setup
+
+
+
+if __name__ == "__main__":
+ setup(name = 'oorb',
+ description = "OpenOrb module",
+ author = "Francesco Pierfederici",
+ author_email = "fpierfed@lsst.org",
+ version='1.0a1',
+ package_dir={'oorb': '.'},
+ packages=['oorb', ],
+)
Index: trunk/mops/oorb/python/test.f90
===================================================================
--- trunk/mops/oorb/python/test.f90 (revision 34646)
+++ trunk/mops/oorb/python/test.f90 (revision 34646)
@@ -0,0 +1,167 @@
+!====================================================================!
+! !
+! Copyright 2002,2003,2004,2005,2006,2007,2008,2009 !
+! Mikael Granvik, Jenni Virtanen, Karri Muinonen, Teemu Laakso, !
+! Dagmara Oszkiewicz !
+! !
+! This file is part of OpenOrb. !
+! !
+! OpenOrb 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. !
+! !
+! OpenOrb 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 OpenOrb. If not, see . !
+! !
+!====================================================================!
+!
+!! Test program for pyoorb module.
+!!
+!! @author MG, JM
+!! @version 2009-12-08
+!!
+PROGRAM test
+
+ USE pyoorb
+ IMPLICIT NONE
+ CHARACTER(len=4) :: in_obscode
+ INTEGER, PARAMETER :: in_norb = 3
+ INTEGER, PARAMETER :: in_ndate = 2
+ REAL(8), DIMENSION(in_norb,6,6) :: in_covariances
+ REAL(8), DIMENSION(in_norb,12) :: in_orbits
+ REAL(8), DIMENSION(in_norb,in_ndate,13) :: out_ephems
+ REAL(8), DIMENSION(in_ndate,2) :: in_date_ephems
+ INTEGER :: error_code, i, j
+
+ ! Initialize
+ error_code = 0
+ CALL oorb_init(error_code=error_code, info_verbosity=1)
+ IF (error_code /= 0) THEN
+ WRITE(stderr,*) "Error in oorb_init. Code: ", error_code
+ STOP
+ END IF
+
+ ! 2009 TL4 on 2009-11-12 (74 obs in 2009) from (Horizons & AstDyS)
+ in_orbits(1,1) = 1.0_8
+ in_orbits(1,2:7) = (/ &
+ 1.853233422926951E+00_8, &
+ 3.871022198610788E-01_8, &
+ 6.474397461946572E+00_8, &
+ 2.122138159851688E+02_8, &
+ 1.602711715213041E+02_8, &
+ 3.372535412461616E+01_8 /)
+ in_orbits(1,4:7) = in_orbits(1,4:7)*rad_deg
+ in_orbits(1,8) = 3.0_8
+ in_orbits(1,9) = 55200.0_8
+ in_orbits(1,10) = 3.0_8
+ in_orbits(1,11:12) = (/ 21.541_8, 0.15_8 /)
+ ! Copy the same orbit for testing purposes
+ in_orbits(2,:) = in_orbits(1,:)
+ in_orbits(2,1) = 2.0_8
+ in_orbits(3,:) = in_orbits(1,:)
+ in_orbits(3,1) = 3.0_8
+
+ ! From AstDyS
+ in_covariances(1,1,1:6) = (/ 1.59357530E-06_8, 4.54646999E-07_8, 5.59222797E-06_8, &
+ -3.87304158E-06_8, -3.54135866E-07_8, -4.31574921E-05_8 /)
+ in_covariances(1,2,1:6) = (/ 4.54646999E-07_8, 1.29710940E-07_8, 1.59544037E-06_8, &
+ -1.10495903E-06_8, -1.00707885E-07_8, -1.23129696E-05_8 /)
+ in_covariances(1,3,1:6) = (/ 5.59222797E-06_8, 1.59544037E-06_8, 1.96320645E-05_8, &
+ -1.36008250E-05_8, -1.34577989E-06_8, -1.51404682E-04_8 /)
+ in_covariances(1,4,1:6) = (/ -3.87304158E-06_8, -1.10495903E-06_8, -1.36008250E-05_8, &
+ 9.42766927E-06_8, 9.60529697E-07_8, 1.04844563E-04_8 /)
+ in_covariances(1,5,1:6) = (/ -3.54135866E-07_8, -1.00707885E-07_8, -1.34577989E-06_8, &
+ 9.60529697E-07_8, 2.72099434E-06_8, 8.49016456E-06_8 /)
+ in_covariances(1,6,1:6) = (/ -4.31574921E-05_8, -1.23129696E-05_8, -1.51404682E-04_8, &
+ 1.04844563E-04_8, 8.49016456E-06_8, 1.16925907E-03_8 /)
+ DO i=1,6
+ IF (i >= 3) THEN
+ in_covariances(1,i,:) = in_covariances(1,i,:)*rad_deg
+ in_covariances(1,:,i) = in_covariances(1,:,i)*rad_deg
+ END IF
+ END DO
+ ! Copy the covariance matrix for testing purposes
+ DO i=2,3
+ in_covariances(i,:,:) = in_covariances(1,:,:)
+ END DO
+
+ ! Observatory code
+ in_obscode = "500"
+
+ ! Dates for output ephemerides
+ in_date_ephems(1,1:2) = (/ 55148.0_8, 1.0_8 /)
+ in_date_ephems(2,1:2) = (/ 55150.0_8, 1.0_8 /)
+
+ ! Compute ephemerides with covariance
+ CALL oorb_ephemeris_covariance(in_norb, &
+ in_orbits, &
+ in_covariances, &
+ in_obscode, &
+ in_ndate, &
+ in_date_ephems, &
+ out_ephems, &
+ error_code)
+ IF (error_code /= 0) THEN
+ WRITE(stderr,*) "Error in oorb_ephemeris. Code: ", error_code
+ STOP
+ END IF
+ WRITE(stdout,"(14(2X,A12))") "ID", "Delta", "RA", "Dec", &
+ "Mag", "MJD", "Timescale", "dRA/dt", "dDec/dt", &
+ "sigma_RA", "sigma_Dec", "Uncert smaa", "Uncert smia", &
+ "Uncert PA"
+ DO i=1,SIZE(out_ephems,dim=1)
+ DO j=1,SIZE(out_ephems,dim=2)
+ WRITE(stdout,"(14(2X,E12.5))") in_orbits(i,1), out_ephems(i,j,:)
+ END DO
+ END DO
+
+ ! Compute ephemerides without covariance
+ out_ephems = -1.0_8
+ CALL oorb_ephemeris(in_norb, &
+ in_orbits, &
+ in_obscode, &
+ in_ndate, &
+ in_date_ephems, &
+ out_ephems(:,:,1:8), &
+ error_code)
+ IF (error_code /= 0) THEN
+ WRITE(stderr,*) "Error in oorb_ephemeris. Code: ", error_code
+ STOP
+ END IF
+ WRITE(stdout,"(9(2X,A12))") "ID", "Delta", "RA", "Dec", &
+ "Mag", "MJD", "Timescale", "dRA/dt", "dDec/dt"
+ DO i=1,SIZE(out_ephems,dim=1)
+ DO j=1,SIZE(out_ephems,dim=2)
+ WRITE(stdout,"(9(2X,E12.5))") in_orbits(i,1), out_ephems(i,j,1:8)
+ END DO
+ END DO
+
+!!$ Ephemeris for 2009 TL4 at epoch 55148 MJD (from AstDyS)
+!!$ Right Ascension: 17.801 deg
+!!$ Declination: -0.08723 deg
+!!$ V Magnitude: 19.98 mag
+!!$ Solar Elongation: -145.14 deg
+!!$ Phase: 28.48 deg
+!!$ Galactic Latitude: -62.54 deg
+!!$ Distance from Earth: 0.23 AU
+!!$ Distance from Sun: 1.186 AU
+!!$ Apparent motion
+!!$ Rate: 0.848 deg/day
+!!$ Direction: 95.121 deg
+!!$ Uncertainty Ellipse
+!!$ Semimajor axis: 0.021 arcmin
+!!$ Semiminor axis: 0.017 arcmin
+!!$ Orientation: -161.75 deg
+!!$ From JPL:
+!!$ RA 3sigma unc: 3.097 arcsec
+!!$ Dec 3sigma unc: 3.672 arcsec
+
+ CALL oorb_memfree()
+
+END PROGRAM test
Index: trunk/mops/oorb/python/test.py
===================================================================
--- trunk/mops/oorb/python/test.py (revision 34646)
+++ trunk/mops/oorb/python/test.py (revision 34646)
@@ -0,0 +1,117 @@
+#====================================================================#
+# #
+# Copyright 2002,2003,2004,2005,2006,2007,2008,2009 #
+# Mikael Granvik, Jenni Virtanen, Karri Muinonen, Teemu Laakso, #
+# Dagmara Oszkiewicz #
+# #
+# This file is part of OpenOrb. #
+# #
+# OpenOrb 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. #
+# #
+# OpenOrb 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 OpenOrb. If not, see . #
+# #
+#====================================================================#
+#
+# Script for testing pyoorb library using Python. The results should
+# be identical to the results by test.f90 if everything is okay.
+#
+# @author MG, JM
+# @version 2009-12-01
+#
+
+#!/usr/bin/env python
+
+import pyoorb
+import numpy
+
+if __name__ == "__main__":
+ print "starting..."
+ print "calling oorb_init():"
+ pyoorb.pyoorb.oorb_init(error_verbosity=5, info_verbosity=5)
+ #orb is id, 6 elements, epoch_mjd, H, G, element type index
+ #keplerian appears to be element type index 3
+ #orbits = numpy.array([0.,1.,2.,3.,4.,5.,6.,5373.,1.,1.,3.])
+ #using the first item in PS-SSM, 1/100th density, s1.01 file.
+ orbits = numpy.zeros([3,12], dtype=numpy.double, order='F')
+ orbits[0][0] = 1.0
+ orbits[0][1] = 1.853233422926951E+00
+ orbits[0][2] = 3.871022198610788E-01
+ orbits[0][3] = 6.474397461946572E+00
+ orbits[0][4] = 2.122138159851688E+02
+ orbits[0][5] = 1.602711715213041E+02
+ orbits[0][6] = 3.372535412461616E+01
+ for i in range(3,7):
+ orbits[0][i] = numpy.radians(orbits[0][i])
+ orbits[0][7] = 3.0
+ orbits[0][8] = 55200.0
+ orbits[0][9] = 3.0
+ orbits[0][10]= 21.541
+ orbits[0][11]= .15
+
+ orbits[1][0] = 2.0
+ orbits[2][0] = 3.0
+ for i in range(1,12):
+ orbits[1][i] = orbits[0][i]
+ orbits[2][i] = orbits[0][i]
+ print orbits[0]
+ print orbits[1]
+ print orbits[2]
+
+ covariances = numpy.zeros([3,6,6], order='F') #zero covariance is okay for now...
+
+ covariances[0][0][:] = [ 1.59357530E-06, 4.54646999E-07, 5.59222797E-06, \
+ -3.87304158E-06, -3.54135866E-07, -4.31574921E-05 ]
+
+ covariances[0][1][:] = [ 4.54646999E-07, 1.29710940E-07, 1.59544037E-06, \
+ -1.10495903E-06, -1.00707885E-07, -1.23129696E-05 ]
+
+ covariances[0][2][:] = [ 5.59222797E-06, 1.59544037E-06, 1.96320645E-05, \
+ -1.36008250E-05, -1.34577989E-06, -1.51404682E-04 ]
+
+ covariances[0][3][:] = [ -3.87304158E-06, -1.10495903E-06, -1.36008250E-05, \
+ 9.42766927E-06, 9.60529697E-07, 1.04844563E-04 ]
+
+ covariances[0][4][:] = [ -3.54135866E-07, -1.00707885E-07, -1.34577989E-06, \
+ 9.60529697E-07, 2.72099434E-06, 8.49016456E-06 ]
+
+ covariances[0][5][:] = [ -4.31574921E-05, -1.23129696E-05, -1.51404682E-04, \
+ 1.04844563E-04, 8.49016456E-06, 1.16925907E-03 ]
+
+ for i in range(0,6):
+ for j in range(0,6):
+ covariances[1][i][j] = covariances[0][i][j]
+ covariances[2][i][j] = covariances[0][i][j]
+
+
+ obscode = "500"
+ ephem_dates=numpy.zeros([2,2], dtype=numpy.double, order='F')
+ ephem_dates[0][:] = [ 55148.0, 1.0 ]
+ ephem_dates[1][:] = [ 55150.0, 1.0 ]
+
+ print "calling oorb_ephemeris_covariance"
+ eph, err = pyoorb.pyoorb.oorb_ephemeris_covariance(orbits, \
+ covariances, \
+ obscode, \
+ ephem_dates)
+ print "error code:", err
+ for i in range(0,3):
+ for j in range(0,2):
+ print eph[i][j]
+
+ print "calling oorb_ephemeris"
+ eph, err = pyoorb.pyoorb.oorb_ephemeris(in_orbits=orbits, \
+ in_obscode=obscode, \
+ in_date_ephems=ephem_dates)
+ print "error code:", err
+ for i in range(0,3):
+ for j in range(0,2):
+ print eph[i][j]
Index: trunk/mops/oorb/python/utils.py
===================================================================
--- trunk/mops/oorb/python/utils.py (revision 34646)
+++ trunk/mops/oorb/python/utils.py (revision 34646)
@@ -0,0 +1,274 @@
+#
+# LSST Data Management System
+# Copyright 2008, 2009 LSST Corporation.
+#
+# This product includes software developed by the
+# LSST Project (http://www.lsst.org/).
+#
+# This program 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.
+#
+# This program 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 LSST License Statement and
+# the GNU General Public License along with this program. If not,
+# see .
+#
+# F. Pierfederici
+from constants import *
+# from api import *
+
+
+
+
+def findLibrary(root):
+ import ctypes
+ import os
+ import sys
+
+
+ # ctypes.util.find_library works just fine on OSX.
+ if(sys.platform.startswith('darwin')):
+ return(ctypes.util.find_library(root))
+
+ # It does not on Linux/Solaris etc. (IMHO).
+ libPath = ctypes.util.find_library(root)
+ if(libPath):
+ return(libPath)
+
+ # Now we are in trouble. Try and see if we find it somewhere in the user
+ # LD_LIBRARY_PATH.
+ if(sys.platform.startswith('linux')):
+ dirPaths = os.environ.get('LD_LIBRARY_PATH', '').split(':')
+ for dirPath in dirPaths:
+ path = os.path.join(dirPath, 'lib%s.so' %(root))
+ if(os.path.exists(path)):
+ return(path)
+ return(None)
+
+
+def sexagesimalHoursToDecimalDegrees(h, m, s):
+ """
+ Convert an angle given in sexagesimal hour form to decimal degrees.
+ """
+ return(15. * sexagesimalDegreesToDecimalDegrees(h, m, s))
+
+
+def sexagesimalDegreesToDecimalDegrees(d, m, s):
+ """
+ Convert an angle given in sexagesimal degree form to decimal degrees.
+ """
+ if(d >= 0.):
+ return(float(d) + float(m) / 60. + float(s) / 3600.)
+ return(float(d) - float(m) / 60. - float(s) / 3600.)
+
+
+def _updateConfig(config, var, val):
+ if(config.has_key(var) and not isinstance(config[var], list)):
+ config[var] = [config[var], val]
+ elif(config.has_key(var)):
+ config[var].append(val)
+ else:
+ config[var] = val
+ return(config)
+
+
+def _guessType(val):
+ # remove any comments.
+ val = val.split('#', 1)[0]
+ val = val.strip()
+ if(not val):
+ return(None)
+
+ # Is it an array or a simple type (including strings)? Arrays are space
+ # separated and are homogeneus collections.
+ tokens = val.split()
+ if(len(tokens) == 1):
+ # Nope: single value.
+ return(_guessSingleType(val))
+ # Either a string with spaces of an array of int/float/Bool.
+ # Guess the type of the first token and assume that if it is not a string,
+ # we have an array (not that safe, actually).
+ # TODO: Improve array parsing.
+ typedToken = _guessSingleType(tokens[0])
+ if(isinstance(typedToken, str)):
+ return(val)
+ # We have an array!
+ typedVal = [_guessSingleType(t) for t in tokens]
+ # Simple sanity check.
+ for v in typedVal:
+ if(not isinstance(v, typedToken.__class__)):
+ # Ops! We made a mistake in assuming that val was an array.
+ return(val)
+ return(typedVal)
+
+
+def _guessSingleType(val):
+ if(not val):
+ return(None)
+ if(val.upper() == 'T'):
+ return(True)
+ elif(val.upper() == 'F'):
+ return(False)
+
+ try:
+ return(float(val))
+ except:
+ pass
+ try:
+ return(int(val))
+ except:
+ pass
+ return(val)
+
+
+def readConfigurationFile(fileName):
+ config = {}
+
+ f = open(fileName)
+ for line in f:
+ line = line.split('#', 1)[0]
+ line = line.strip()
+ if(not line):
+ continue
+
+ try:
+ (var, val) = line.split(':', 1)
+ except:
+ raise(SyntaxError('Unable to parse line "%s"' %(line)))
+ val = _guessType(val)
+ config = _updateConfig(config, var, val)
+ f.close()
+ return(config)
+
+
+def _parseMPCLine(line, defaultStdDev):
+ # Remove comments and leading/trailing blank spaces.
+ line = line.split('#', 1)[0]
+ line = line.strip()
+ if(not line or line.startswith("#")):
+ return
+
+ tokens = line.split()
+ # FIXME: Improve MPC format parsing.
+ if(len(tokens) not in (13, 11)):
+ raise(NotImplementedError("FIXME: Improve MPC format parsing."))
+
+ objName = tokens[0]
+ if(objName.endswith('*')):
+ objName = objName[:-1]
+
+ obsTypeYear = tokens[1]
+ if(len(obsTypeYear) >= 5):
+ obsType = obsTypeYear[0]
+ year = obsTypeYear[1:]
+ else:
+ year = obsTypeYear
+ year = int(year)
+
+ month = int(tokens[2])
+ day = float(tokens[3])
+
+ # The timescale used by MPC prior to year 1972 is UT1 and since then UTC has
+ # been used.
+ if(year < 1972):
+ timescale = "UT1"
+ else:
+ timescale = "UTC"
+ mjd = calendardate_to_mjd(year, month, day, timescale)
+
+ h = int(tokens[4])
+ m = int(tokens[5])
+ s = float(tokens[6])
+ ra = sexagesimalHoursToDecimalDegrees(h, m, s)
+ raErr = defaultStdDev[1]
+
+ d = int(tokens[7])
+ m = int(tokens[8])
+ s = float(tokens[9])
+ dec = sexagesimalDegreesToDecimalDegrees(d, m, s)
+ decErr = defaultStdDev[2]
+
+ # Filters need to be 1-character long.
+ if(len(tokens) == 13):
+ # We have mag and filter info.
+ mag = float(tokens[10])
+ filter = tokens[11]
+ else:
+ # No mag/filter info.
+ mag = 99.9
+ filter = ' '
+
+ # The obscode are the last 3 characters from the last token. We need to pad
+ # them to 4 character lomg.
+ obscode = tokens[-1][-3:] + ' '
+ return((objName, mjd, ra, raErr, dec, decErr, mag, filter, obscode))
+
+
+
+def readObsFile(fileName, defaultStdDev):
+ """
+ Parse a detection file in the (old) MPC format. If no coordinate uncertainty
+ is profided use the input defaultStdDev values.
+
+ @param fileName: full path of the file to parse.
+ @param defaultStdDev: 6 element array with uncertainties on distance, ra,
+ dec and their time derivatives. Since we typically only measure ra
+ and dec, defaultStdDev has the form:
+ [None, raErr, decErr, None, None, None]
+ Return
+ [(objectName, MJD, RA, RAErr, Dec, DecErr, mag, filterName, obscode), ]
+
+ Angles in decimal degrees. Times in TT.
+ """
+ data = []
+
+ f = open(fileName)
+ for line in f:
+ values = _parseMPCLine(line, defaultStdDev)
+ if(not values):
+ continue
+ data.append(values)
+ f.close()
+ return(data)
+
+
+def splitObservations(obs):
+ """
+ Group observations per object name.
+
+ @param obs: list of the form [(objectName, MJD, RA, Dec, mag, filterName), ]
+
+ Return
+ [obs1, obs2, ...]
+ Where
+ obsi = [(objectNamei, MJD, RA, Dec, mag, filterName), ]
+ """
+ if(not obs):
+ return(obs)
+
+ refName = obs[0][0]
+ currentObs = []
+ separatedObs = []
+ for o in obs:
+ name = o[0]
+ if(name == refName):
+ # Another observation from the current group.
+ currentObs.append(o)
+ continue
+ else:
+ # Another group.
+ separatedObs.append(currentObs)
+ refName = name
+ currentObs = [o, ]
+ # Make sure that we got all groups.
+ if(currentObs not in separatedObs):
+ separatedObs.append(currentObs)
+ return(separatedObs)
+
+
Index: trunk/mops/oorb/python/wrapper.f90
===================================================================
--- trunk/mops/oorb/python/wrapper.f90 (revision 34646)
+++ trunk/mops/oorb/python/wrapper.f90 (revision 34646)
@@ -0,0 +1,1598 @@
+!
+! LSST Data Management System
+! Copyright 2008, 2009 LSST Corporation.
+!
+! This product includes software developed by the
+! LSST Project (http://www.lsst.org/).
+!
+! This program 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.
+!
+! This program 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 LSST License Statement and
+! the GNU General Public License along with this program. If not,
+! see .
+!
+!
+! OpenOrb library
+! F. Pierfederici
+!
+! Description
+!
+! Notes
+! error is a boolean global and is defined somewhere in liboorb.so!
+!
+!
+! Implementation notes:
+! 1. both oorb_ranging_fast and oorb_lsl_fast have a useless loop in them:
+! either clean them up or make them useful!
+!
+!
+
+! Orbital elements that we support.
+! ORBITAL_ELEMENTS = (/ "keplerian", "delaunay", "poincare", "equinoctial" /)
+
+
+
+
+
+subroutine oorb_init(ephemFileName, verbosity, error_code)
+ ! Initialize the OpenOrb module.
+ !
+ ! @param ephemFileName: full path of the JPL ephem file (usually
+ ! $OORB_DATA/JPL_ephemeris/de405.dat).
+ ! @param verbosity: verbosity level for OpenOrb calls [0, 5] (default 0)
+ ! @return error_code: int error code. 0 = success, otherwise, failure.
+ use liboorb, only: init
+ ! Input/Output variables.
+ character(len=*), intent(IN) :: ephemFileName
+ integer, intent(in) :: verbosity
+ integer, intent(OUT) :: error_code
+
+
+ call init(trim(ephemFileName), verbosity, error_code)
+ return
+end subroutine oorb_init
+
+
+
+subroutine oorb_ranging_fast(obscodes, &
+ filters, &
+ track_id, &
+ num_coords, &
+ coords, &
+ mjds, &
+ mags, &
+ element_type, &
+ num_orbits, &
+ out_orbits, &
+ error_code)
+ use liboorb
+ use Observations_cl
+ use StochasticOrbit_cl
+ ! Orbital inversion using statistical orbital ranging, that is,
+ ! without making any assumptions on the shape of the resulting
+ ! orbital-element pdf.
+
+ ! All angles coming in are in decimal degrees. All times in MJD TAI.
+
+ ! Input/Output variables.
+ ! Observations (i.e. DiASources) to be used as input. It is assumed that
+ ! they all belong to the same track.
+ ! We have to use separate arrays since they are of different type.
+ integer, intent(in) :: track_id
+ integer, intent(in) :: num_coords
+ real(8), dimension(num_coords), intent(in) :: mjds
+ real(8), dimension(num_coords, 4), intent(in) :: coords
+ real(8), dimension(num_coords), intent(in) :: mags
+ ! FIXME: f2py bug that only passes the first char of element of an array of
+ ! strings.
+ character(len=1), dimension(num_coords), intent(in) :: filters
+ ! FIXME: f2py bug that only passes the first char of element of an array of
+ ! strings.
+ character(len=4), dimension(num_coords), intent(in) :: obscodes
+ ! Element type used in the orbit computation (default keplerian)
+ CHARACTER(len=11), intent(in) :: element_type
+ ! How may orbits do we want out?
+ integer, intent(in) :: num_orbits
+ ! Output flattened orbits.
+ ! out_orbits has the form (id, (elements(1:6), epoch, Un-normalized p.d.f.,
+ ! Reduced chi2, Regularized apr, Jacobian det(1:3), element_type_index), )
+ real(8),dimension(num_orbits,15),intent(out) :: out_orbits
+ ! Output error code
+ integer, intent(out) :: error_code
+
+
+ ! Internal variables.
+ character(len=6) :: dyn_model
+ real(8) :: integration_step
+ LOGICAL, DIMENSION(:), pointer :: perturbers
+ real(8) :: apriori_a_max
+ real(8) :: apriori_a_min
+ real(8) :: apriori_rho_max
+ real(8) :: apriori_rho_min
+ logical :: outlier_rejection
+ real(8) :: outlier_multiplier
+ integer :: sor_type_prm
+ character(len=80) :: sor_2point_method
+ character(len=80) :: sor_2point_method_sw
+ integer :: sor_norb
+ integer :: sor_norb_sw
+ integer :: sor_ntrial
+ integer :: sor_ntrial_sw
+ integer :: sor_niter
+ REAL(8), DIMENSION(4) :: sor_rho_init
+ real(8) :: sor_genwin_multiplier
+ REAL(8), DIMENSION(4) :: sor_genwin_offset
+ real(8) :: accwin_multiplier
+ logical :: gaussian_rho
+ real(8) :: pdf_ml_init
+ logical :: uniform
+ logical :: regularized
+ logical :: random_obs
+ TYPE (Observations), DIMENSION(:), POINTER :: obss
+ TYPE (StochasticOrbit) :: storb
+ integer :: j
+ integer :: element_type_index
+
+ ! REAL(8), DIMENSION(:,:,:), POINTER :: cov_matrices
+ ! integer :: nobs = 0
+ ! integer :: i = 0
+ ! TYPE (SphericalCoordinates), DIMENSION(:), POINTER :: scoords
+
+ ! do j=1,num_coords
+ ! write(*, *) "obscodes: ", obscodes(j)
+ ! end do
+
+
+
+ ! write(*, *) "obscodes(1) ", obscodes(1)
+ ! write(*, *) "obscodes(2) ", obscodes(2)
+ ! write(*, *) "obscodes(3) ", obscodes(3)
+ ! write(*, *) "filters(1) ", filters(1)
+ ! write(*, *) "filters(2) ", filters(2)
+ ! write(*, *) "filters(3) ", filters(3)
+ ! write(*, *) "track_id ", track_id
+ ! write(*, *) "num_coords ", num_coords
+ ! write(*, *) "coords(1) ", coords(1, :)
+ ! write(*, *) "coords(2) ", coords(2, :)
+ ! write(*, *) "coords(3) ", coords(3, :)
+ ! write(*, *) "mjds ", mjds
+ ! write(*, *) "mags ", mags
+ ! write(*, *) "element_type '", element_type, "'"
+ ! write(*, *) "num_orbits ", num_orbits
+
+ ! Init (these values come from best practices and default OpenOrb values).
+ error_code = 0
+ dyn_model = "2-body"
+ integration_step = 5.0_8
+ apriori_a_max = 1000.0_8
+ apriori_a_min = 4.65423999999999959E-003_8
+ apriori_rho_max = -1.0_8
+ apriori_rho_min = -1.0_8
+ outlier_rejection = .false.
+ outlier_multiplier = 4.0_8
+ sor_type_prm = 2
+ sor_2point_method = "continued fraction"
+ sor_2point_method_sw = "continued fraction"
+ sor_norb = num_orbits
+ sor_norb_sw = sor_norb / 10
+ sor_ntrial = sor_norb * 2000
+ sor_ntrial_sw = sor_norb_sw * 400
+ sor_niter = 3
+ sor_rho_init = huge(sor_rho_init)
+ sor_rho_init(1) = 0.0_8
+ sor_rho_init(2) = 100.0_8
+ sor_genwin_multiplier = 3.0_8
+ sor_genwin_offset = 0.0_8
+ accwin_multiplier = 3.0_8
+ gaussian_rho = .false.
+ pdf_ml_init = -1.0_8
+ uniform = .false.
+ regularized = .true.
+ random_obs = .false.
+ obss => null()
+ call nullify(storb)
+ j = 0
+ allocate(perturbers(10), stat=error_code)
+ if(error_code /= 0) then
+ ! Error in allocating memory!
+ error_code = 57
+ return
+ end if
+ perturbers = .true.
+
+ ! Figure out the element_type_index
+ element_type_index = -1
+ do j=1,size(ORBITAL_ELEMENTS)
+ if(trim(element_type) == trim(ORBITAL_ELEMENTS(j))) then
+ element_type_index = j
+ exit
+ ! else
+ ! write(*, *) "'" // trim(element_type) // "' =/ '" // trim(ORBITAL_ELEMENTS(j)) // "'"
+ ! write(*, *) " ", len(trim(element_type)), " =/ ", len(trim(ORBITAL_ELEMENTS(j)))
+ end if
+ end do
+ if(element_type_index .le. 0) then
+ ! Error: unsupported element type!
+ error_code = 58
+ return
+ end if
+
+ ! Convert the input observation array into a list of Observations instances.
+ ! Input coordinates (and their uncertainties) are in decimal degrees.
+ ! We need them in radians.
+ call obssFromCoords(track_id, num_coords, coords*rad_deg, mjds, mags, &
+ filters, obscodes, obss, error_code)
+ if(error_code /= 0) then
+ return
+ end if
+
+ ! do j=1,size(obss)
+ ! cov_matrices => getCovarianceMatrices(obss(j))
+ ! nobs = getNrOfObservations(obss(j))
+ ! DO i=1,nobs
+ ! write(*, *) "COV: ", cov_matrices(i,:,:)
+ ! END DO
+ ! end do
+
+ ! Now that we have a set of Observations, pass them to the ranging routine.
+ ! obss has already been separated into tracks, pass one track at the time.
+ ! We clearly expect one track only, so this loop is here only so that we can
+ ! support multiple track processing later on. But it could just as well be
+ ! eliminated...
+ do j=1,size(obss)
+ call nullify(storb)
+
+ ! scoords => getObservationSCoords(obss(j))
+ ! do i=1,size(scoords)
+ ! write(*, *) "RA: ", getLongitude(scoords(i))
+ ! write(*, *) "Dec: ", getLatitude(scoords(i))
+ ! end do
+
+
+ call ranging(obs_in=obss(j), element_type=trim(element_type), &
+ dyn_model=trim(dyn_model), &
+ integration_step=integration_step, &
+ perturbers=perturbers, apriori_a_max=apriori_a_max, &
+ apriori_a_min=apriori_a_min, &
+ apriori_rho_max=apriori_rho_max, &
+ apriori_rho_min=apriori_rho_min, &
+ outlier_rejection=outlier_rejection, &
+ outlier_multiplier=outlier_multiplier, &
+ sor_type_prm=sor_type_prm, &
+ sor_2point_method=trim(sor_2point_method), &
+ sor_2point_method_sw=trim(sor_2point_method_sw), &
+ sor_norb=sor_norb, sor_norb_sw=sor_norb_sw, &
+ sor_ntrial=sor_ntrial, sor_ntrial_sw=sor_ntrial_sw, &
+ sor_niter=sor_niter, sor_rho_init=sor_rho_init, &
+ sor_genwin_multiplier=sor_genwin_multiplier, &
+ sor_genwin_offset=sor_genwin_offset, &
+ accwin_multiplier=accwin_multiplier, &
+ gaussian_rho=gaussian_rho, &
+ pdf_ml_init=pdf_ml_init, uniform=uniform, &
+ regularized=regularized, random_obs=random_obs, &
+ outOrbit=storb, errorCode=error_code)
+ if(error_code /= 0) then
+ return
+ end if
+
+ ! Dump the storb orbit.
+ ! call dumpRangingOrbits(storb, errorCode=error_code)
+
+ ! Now flatten the ranging orbits.
+ call exportRangingOrbits(storb, element_type, track_id, out_orbits, &
+ error_code)
+ call nullify(storb)
+ if(error_code /= 0) then
+ return
+ end if
+ end do
+
+ deallocate(perturbers)
+ return
+end subroutine oorb_ranging_fast
+
+
+
+subroutine oorb_ranging(obscodes, &
+ filters, &
+ track_id, &
+ num_coords, &
+ coords, &
+ mjds, &
+ mags, &
+ element_type, &
+ num_orbits, &
+ out_orbits, &
+ error_code)
+ use liboorb
+ use Observations_cl
+ use StochasticOrbit_cl
+ ! Orbital inversion using statistical orbital ranging, that is,
+ ! without making any assumptions on the shape of the resulting
+ ! orbital-element pdf.
+
+ ! All angles coming in are in decimal degrees. All times in MJD TAI.
+
+ ! Input/Output variables.
+ ! Observations (i.e. DiASources) to be used as input. It is assumed that
+ ! they all belong to the same track.
+ ! We have to use separate arrays since they are of different type.
+ integer, intent(in) :: track_id
+ integer, intent(in) :: num_coords
+ real(8), dimension(num_coords), intent(in) :: mjds
+ real(8), dimension(num_coords, 4), intent(in) :: coords
+ real(8), dimension(num_coords), intent(in) :: mags
+ ! FIXME: f2py bug that only passes the first char of element of an array of
+ ! strings.
+ character(len=1), dimension(num_coords), intent(in) :: filters
+ ! FIXME: f2py bug that only passes the first char of element of an array of
+ ! strings.
+ character(len=4), dimension(num_coords), intent(in) :: obscodes
+ ! Element type used in the orbit computation (default keplerian)
+ CHARACTER(len=11), intent(in) :: element_type
+ ! How may orbits do we want out?
+ integer, intent(in) :: num_orbits
+ ! Output flattened orbits.
+ ! out_orbits has the form (id, (elements(1:6), epoch, Un-normalized p.d.f.,
+ ! Reduced chi2, Regularized apr, Jacobian det(1:3), element_type_index), )
+ real(8),dimension(num_orbits,15),intent(out) :: out_orbits
+ ! Output error code
+ integer, intent(out) :: error_code
+
+
+ ! Internal variables.
+ character(len=6) :: dyn_model
+ real(8) :: integration_step
+ LOGICAL, DIMENSION(:), pointer :: perturbers
+ real(8) :: apriori_a_max
+ real(8) :: apriori_a_min
+ real(8) :: apriori_rho_max
+ real(8) :: apriori_rho_min
+ logical :: outlier_rejection
+ real(8) :: outlier_multiplier
+ integer :: sor_type_prm
+ character(len=80) :: sor_2point_method
+ character(len=80) :: sor_2point_method_sw
+ integer :: sor_norb
+ integer :: sor_norb_sw
+ integer :: sor_ntrial
+ integer :: sor_ntrial_sw
+ integer :: sor_niter
+ REAL(8), DIMENSION(4) :: sor_rho_init
+ real(8) :: sor_genwin_multiplier
+ REAL(8), DIMENSION(4) :: sor_genwin_offset
+ real(8) :: accwin_multiplier
+ logical :: gaussian_rho
+ real(8) :: pdf_ml_init
+ logical :: uniform
+ logical :: regularized
+ logical :: random_obs
+ TYPE (Observations), DIMENSION(:), POINTER :: obss
+ TYPE (StochasticOrbit) :: storb
+ integer :: j
+ integer :: element_type_index
+
+ ! REAL(8), DIMENSION(:,:,:), POINTER :: cov_matrices
+ ! integer :: nobs = 0
+ ! integer :: i = 0
+ ! TYPE (SphericalCoordinates), DIMENSION(:), POINTER :: scoords
+
+ ! do j=1,num_coords
+ ! write(*, *) "obscodes: ", obscodes(j)
+ ! end do
+
+
+
+ ! write(*, *) "obscodes(1) ", obscodes(1)
+ ! write(*, *) "obscodes(2) ", obscodes(2)
+ ! write(*, *) "obscodes(3) ", obscodes(3)
+ ! write(*, *) "filters(1) ", filters(1)
+ ! write(*, *) "filters(2) ", filters(2)
+ ! write(*, *) "filters(3) ", filters(3)
+ ! write(*, *) "track_id ", track_id
+ ! write(*, *) "num_coords ", num_coords
+ ! write(*, *) "coords(1) ", coords(1, :)
+ ! write(*, *) "coords(2) ", coords(2, :)
+ ! write(*, *) "coords(3) ", coords(3, :)
+ ! write(*, *) "mjds ", mjds
+ ! write(*, *) "mags ", mags
+ ! write(*, *) "element_type '", element_type, "'"
+ ! write(*, *) "num_orbits ", num_orbits
+
+ ! Init (these values come from best practices and default OpenOrb values).
+ error_code = 0
+ dyn_model = "n-body"
+ integration_step = 5.0_8
+ apriori_a_max = 1000.0_8
+ apriori_a_min = 4.65423999999999959E-003_8
+ apriori_rho_max = -1.0_8
+ apriori_rho_min = -1.0_8
+ outlier_rejection = .false.
+ outlier_multiplier = 4.0_8
+ sor_type_prm = 2
+ sor_2point_method = "continued fraction"
+ sor_2point_method_sw = "continued fraction"
+ sor_norb = num_orbits
+ sor_norb_sw = sor_norb / 10
+ sor_ntrial = sor_norb * 2000
+ sor_ntrial_sw = sor_norb_sw * 400
+ sor_niter = 3
+ sor_rho_init = huge(sor_rho_init)
+ sor_rho_init(1) = 0.0_8
+ sor_rho_init(2) = 100.0_8
+ sor_genwin_multiplier = 3.0_8
+ sor_genwin_offset = 0.0_8
+ accwin_multiplier = 3.0_8
+ gaussian_rho = .false.
+ pdf_ml_init = -1.0_8
+ uniform = .false.
+ regularized = .true.
+ random_obs = .false.
+ obss => null()
+ call nullify(storb)
+ j = 0
+ allocate(perturbers(10), stat=error_code)
+ if(error_code /= 0) then
+ ! Error in allocating memory!
+ error_code = 57
+ return
+ end if
+ perturbers = .true.
+
+ ! Figure out the element_type_index
+ element_type_index = -1
+ do j=1,size(ORBITAL_ELEMENTS)
+ if(trim(element_type) == trim(ORBITAL_ELEMENTS(j))) then
+ element_type_index = j
+ exit
+ ! else
+ ! write(*, *) "'" // trim(element_type) // "' =/ '" // trim(ORBITAL_ELEMENTS(j)) // "'"
+ ! write(*, *) " ", len(trim(element_type)), " =/ ", len(trim(ORBITAL_ELEMENTS(j)))
+ end if
+ end do
+ if(element_type_index .le. 0) then
+ ! Error: unsupported element type!
+ error_code = 58
+ return
+ end if
+
+ ! Convert the input observation array into a list of Observations instances.
+ ! Input coordinates (and their uncertainties) are in decimal degrees.
+ ! We need them in radians.
+ call obssFromCoords(track_id, num_coords, coords*rad_deg, mjds, mags, &
+ filters, obscodes, obss, error_code)
+ if(error_code /= 0) then
+ return
+ end if
+
+ ! do j=1,size(obss)
+ ! cov_matrices => getCovarianceMatrices(obss(j))
+ ! nobs = getNrOfObservations(obss(j))
+ ! DO i=1,nobs
+ ! write(*, *) "COV: ", cov_matrices(i,:,:)
+ ! END DO
+ ! end do
+
+ ! Now that we have a set of Observations, pass them to the ranging routine.
+ ! obss has already been separated into tracks, pass one track at the time.
+ ! We clearly expect one track only, so this loop is here only so that we can
+ ! support multiple track processing later on. But it could just as well be
+ ! eliminated...
+ do j=1,size(obss)
+ call nullify(storb)
+
+ ! scoords => getObservationSCoords(obss(j))
+ ! do i=1,size(scoords)
+ ! write(*, *) "RA: ", getLongitude(scoords(i))
+ ! write(*, *) "Dec: ", getLatitude(scoords(i))
+ ! end do
+
+
+ call ranging(obs_in=obss(j), element_type=trim(element_type), &
+ dyn_model=trim(dyn_model), &
+ integration_step=integration_step, &
+ perturbers=perturbers, apriori_a_max=apriori_a_max, &
+ apriori_a_min=apriori_a_min, &
+ apriori_rho_max=apriori_rho_max, &
+ apriori_rho_min=apriori_rho_min, &
+ outlier_rejection=outlier_rejection, &
+ outlier_multiplier=outlier_multiplier, &
+ sor_type_prm=sor_type_prm, &
+ sor_2point_method=trim(sor_2point_method), &
+ sor_2point_method_sw=trim(sor_2point_method_sw), &
+ sor_norb=sor_norb, sor_norb_sw=sor_norb_sw, &
+ sor_ntrial=sor_ntrial, sor_ntrial_sw=sor_ntrial_sw, &
+ sor_niter=sor_niter, sor_rho_init=sor_rho_init, &
+ sor_genwin_multiplier=sor_genwin_multiplier, &
+ sor_genwin_offset=sor_genwin_offset, &
+ accwin_multiplier=accwin_multiplier, &
+ gaussian_rho=gaussian_rho, &
+ pdf_ml_init=pdf_ml_init, uniform=uniform, &
+ regularized=regularized, random_obs=random_obs, &
+ outOrbit=storb, errorCode=error_code)
+ if(error_code /= 0) then
+ return
+ end if
+
+ ! Dump the storb orbit.
+ ! call dumpRangingOrbits(storb, errorCode=error_code)
+
+ ! Now flatten the ranging orbits.
+ call exportRangingOrbits(storb, element_type, track_id, out_orbits, &
+ error_code)
+ call nullify(storb)
+ if(error_code /= 0) then
+ return
+ end if
+ end do
+
+ deallocate(perturbers)
+ return
+end subroutine oorb_ranging
+
+
+
+subroutine oorb_lsl_fast(obscodes, &
+ filters, &
+ track_id, &
+ num_coords, &
+ coords, &
+ mjds, &
+ mags, &
+ in_orbits, &
+ num_orbits, &
+ out_orbit, &
+ out_covariance, &
+ out_sigmas, &
+ out_correlation, &
+ error_code)
+ use liboorb
+ use StochasticOrbit_cl
+ ! Orbital inversion using statistical orbital ranging, that is,
+ ! without making any assumptions on the shape of the resulting
+ ! orbital-element pdf.
+
+ ! All angles coming in are in decimal degrees. All times in MJD TAI.
+
+ ! Input/Output variables.
+ ! Observations (i.e. DiASources) to be used as input. It is assumed that
+ ! they all belong to the same track.
+ ! We have to use separate arrays since they are of different type.
+ integer, intent(in) :: track_id
+ integer, intent(in) :: num_coords
+ real(8), dimension(num_coords), intent(in) :: mjds
+ real(8), dimension(num_coords, 4), intent(in) :: coords
+ real(8), dimension(num_coords), intent(in) :: mags
+ ! FIXME: f2py bug that only passes the first char of element of an array of
+ ! strings.
+ character(len=1), dimension(num_coords), intent(in) :: filters
+ ! FIXME: f2py bug that only passes the first char of element of an array of
+ ! strings.
+ character(len=4), dimension(num_coords), intent(in) :: obscodes
+ integer, intent(in) :: num_orbits
+ ! Input flattened orbits.
+ ! in_orbits has the form ((id, elements(1:6), epoch, Un-normalized p.d.f.,
+ ! Reduced chi2, Regularized apr, Jacobian det(1:3), el_type_index), )
+ real(8),dimension(num_orbits,15),intent(in) :: in_orbits
+ ! Output flattened orbit:
+ ! (track_id, elements(1:6), epoch, H, G, el_type_index)
+ ! FIXME: H and G are not currently computed.
+ real(8),dimension(11), intent(out) :: out_orbit
+ ! Uncertainty matrices:
+ REAL(8), DIMENSION(6,6), intent(out) :: out_covariance
+ REAL(8), DIMENSION(6), intent(out) :: out_sigmas
+ REAL(8), DIMENSION(6,6), intent(out) :: out_correlation
+ ! Output error code
+ integer, intent(out) :: error_code
+
+ ! Internal variables.
+ character(len=6) :: dyn_model
+ character(len=6) :: dyn_model_init
+ real(8) :: integration_step
+ real(8) :: integration_step_init
+ real(8) :: ls_correction_factor
+ LOGICAL, DIMENSION(6) :: ls_element_mask
+ integer :: ls_niter_major_max
+ integer :: ls_niter_major_min
+ integer :: ls_niter_minor
+ logical :: outlier_rejection
+ real(8) :: outlier_multiplier
+ real(8) :: accwin_multiplier
+ LOGICAL, DIMENSION(:), pointer :: perturbers
+ TYPE (Observations), DIMENSION(:), POINTER :: obss
+ TYPE (StochasticOrbit) :: storb
+ TYPE (StochasticOrbit) :: in_storb
+ integer :: j
+ character(len=11) :: element_type
+ integer :: element_type_index
+
+
+
+
+ ! do j=1,num_coords
+ ! write(*, *) "obscodes(", j, ") ", obscodes(j)
+ ! end do
+ ! do j=1,num_coords
+ ! write(*, *) "filters(", j, ") ", filters(j)
+ ! end do
+ ! write(*, *) "track_id ", track_id
+ ! write(*, *) "num_coords ", num_coords
+ ! do j=1,num_coords
+ ! write(*, *) "coords(", j, ") ", coords(j,:)
+ ! end do
+ ! write(*, *) "mjds ", mjds
+ ! write(*, *) "mags ", mags
+ ! write(*, *) "num_orbits ", num_orbits
+
+ ! Init variables (from OpenOrb config file and best practices).
+ error_code = 0
+ dyn_model = "2-body"
+ dyn_model_init = "2-body"
+ integration_step = 5.0_8
+ integration_step_init = 5.0_8
+ ls_correction_factor = 0.2_8
+ ls_element_mask = .true.
+ ls_niter_major_max = 20
+ ls_niter_major_min = 2
+ ls_niter_minor = 10
+ outlier_rejection = .false.
+ outlier_multiplier = 3.0_8
+ accwin_multiplier = 3.0_8
+
+ ! Quick sanity check.
+ if(size(in_orbits) .le. 0) then
+ ! Nothing to do.
+ return
+ end if
+
+ allocate(perturbers(10), stat=error_code)
+ if(error_code /= 0) then
+ ! Error in allocating memory!
+ error_code = 57
+ return
+ end if
+ perturbers = .true.
+
+ ! Get the element type from the input flattened orbits (the are supposed to
+ ! be all the same).
+ element_type_index = in_orbits(1, 15)
+ if(element_type_index .le. 0 .or. &
+ element_type_index .gt. size(ORBITAL_ELEMENTS)) then
+ ! Error: unsupported orbital elements.
+ error_code = 58
+ return
+ end if
+ element_type = ORBITAL_ELEMENTS(element_type_index)
+
+
+ ! Convert the input observation array into a list of Observations instances.
+ ! Input coordinates (and their uncertainties) are in decimal degrees.
+ ! We need them in radians.
+ call obssFromCoords(track_id, num_coords, coords*rad_deg, mjds, mags, &
+ filters, obscodes, obss, error_code)
+ if(error_code /= 0) then
+ return
+ end if
+
+ ! do j=1,size(obss)
+ ! cov_matrices => getCovarianceMatrices(obss(j))
+ ! nobs = getNrOfObservations(obss(j))
+ ! DO i=1,nobs
+ ! write(*, *) "COV: ", cov_matrices(i,:,:)
+ ! END DO
+ ! end do
+
+ ! Convert the input orbits (which come from the ranging routine) into a
+ ! StochasticOrbit instance.
+ call nullify(in_storb)
+ call rangingOrbitsToStochasticOrbit(in_orbits, &
+ num_orbits, &
+ in_storb, &
+ error_code)
+ if(error_code /= 0) then
+ return
+ end if
+
+
+ ! Now that we have a set of Observations, pass them to the lsl routine.
+ ! obss has already been separated into tracks, pass one track at the time.
+ do j=1,size(obss)
+ call nullify(storb)
+
+ ! Do the LSL thing!
+ call lsl(obs_in=obss(j), &
+ element_type=element_type, &
+ dyn_model=dyn_model, &
+ dyn_model_init=dyn_model_init, &
+ integration_step=integration_step, &
+ integration_step_init=integration_step_init, &
+ perturbers=perturbers, &
+ ls_correction_factor=ls_correction_factor, &
+ ls_element_mask=ls_element_mask, &
+ ls_niter_major_max=ls_niter_major_max, &
+ ls_niter_major_min=ls_niter_major_min, &
+ ls_niter_minor=ls_niter_minor, &
+ outlier_rejection=outlier_rejection, &
+ outlier_multiplier=outlier_multiplier, &
+ accwin_multiplier=accwin_multiplier, &
+ inStochOrbit=in_storb, &
+ outStochOrbit=storb, &
+ errorCode=error_code)
+ if(error_code /= 0) then
+ return
+ end if
+
+ ! Now flatten the lsl orbit.
+ call exportLslOrbit(storb, element_type, track_id, out_orbit, &
+ out_covariance, out_sigmas, out_correlation, &
+ error_code)
+ call nullify(storb)
+ if(error_code /= 0) then
+ return
+ end if
+ end do
+ deallocate(perturbers)
+end subroutine oorb_lsl_fast
+
+
+
+subroutine oorb_lsl(obscodes, &
+ filters, &
+ track_id, &
+ num_coords, &
+ coords, &
+ mjds, &
+ mags, &
+ in_orbits, &
+ num_orbits, &
+ out_orbit, &
+ out_covariance, &
+ out_sigmas, &
+ out_correlation, &
+ error_code)
+ use liboorb
+ use StochasticOrbit_cl
+ ! Orbital inversion using statistical orbital ranging, that is,
+ ! without making any assumptions on the shape of the resulting
+ ! orbital-element pdf.
+
+ ! All angles coming in are in decimal degrees. All times in MJD TAI.
+
+ ! Input/Output variables.
+ ! Observations (i.e. DiASources) to be used as input. It is assumed that
+ ! they all belong to the same track.
+ ! We have to use separate arrays since they are of different type.
+ integer, intent(in) :: track_id
+ integer, intent(in) :: num_coords
+ real(8), dimension(num_coords), intent(in) :: mjds
+ real(8), dimension(num_coords, 4), intent(in) :: coords
+ real(8), dimension(num_coords), intent(in) :: mags
+ ! FIXME: f2py bug that only passes the first char of element of an array of
+ ! strings.
+ character(len=1), dimension(num_coords), intent(in) :: filters
+ ! FIXME: f2py bug that only passes the first char of element of an array of
+ ! strings.
+ character(len=4), dimension(num_coords), intent(in) :: obscodes
+ integer, intent(in) :: num_orbits
+ ! Input flattened orbits.
+ ! in_orbits has the form ((id, elements(1:6), epoch, Un-normalized p.d.f.,
+ ! Reduced chi2, Regularized apr, Jacobian det(1:3), el_type_index), )
+ real(8),dimension(num_orbits,15),intent(in) :: in_orbits
+ ! Output flattened orbit:
+ ! (track_id, elements(1:6), epoch, H, G, el_type_index)
+ ! FIXME: H and G are not currently computed.
+ real(8),dimension(11), intent(out) :: out_orbit
+ ! Uncertainty matrices:
+ REAL(8), DIMENSION(6,6), intent(out) :: out_covariance
+ REAL(8), DIMENSION(6), intent(out) :: out_sigmas
+ REAL(8), DIMENSION(6,6), intent(out) :: out_correlation
+ ! Output error code
+ integer, intent(out) :: error_code
+
+ ! Internal variables.
+ character(len=6) :: dyn_model
+ character(len=6) :: dyn_model_init
+ real(8) :: integration_step
+ real(8) :: integration_step_init
+ real(8) :: ls_correction_factor
+ LOGICAL, DIMENSION(6) :: ls_element_mask
+ integer :: ls_niter_major_max
+ integer :: ls_niter_major_min
+ integer :: ls_niter_minor
+ logical :: outlier_rejection
+ real(8) :: outlier_multiplier
+ real(8) :: accwin_multiplier
+ LOGICAL, DIMENSION(:), pointer :: perturbers
+ TYPE (Observations), DIMENSION(:), POINTER :: obss
+ TYPE (StochasticOrbit) :: storb
+ TYPE (StochasticOrbit) :: in_storb
+ integer :: j
+ character(len=11) :: element_type
+ integer :: element_type_index
+
+
+
+
+ ! do j=1,num_coords
+ ! write(*, *) "obscodes(", j, ") ", obscodes(j)
+ ! end do
+ ! do j=1,num_coords
+ ! write(*, *) "filters(", j, ") ", filters(j)
+ ! end do
+ ! write(*, *) "track_id ", track_id
+ ! write(*, *) "num_coords ", num_coords
+ ! do j=1,num_coords
+ ! write(*, *) "coords(", j, ") ", coords(j,:)
+ ! end do
+ ! write(*, *) "mjds ", mjds
+ ! write(*, *) "mags ", mags
+ ! write(*, *) "num_orbits ", num_orbits
+
+ ! Init variables (from OpenOrb config file and best practices).
+ error_code = 0
+ dyn_model = "n-body"
+ dyn_model_init = "2-body"
+ integration_step = 5.0_8
+ integration_step_init = 5.0_8
+ ls_correction_factor = 0.2_8
+ ls_element_mask = .true.
+ ls_niter_major_max = 20
+ ls_niter_major_min = 2
+ ls_niter_minor = 10
+ outlier_rejection = .false.
+ outlier_multiplier = 3.0_8
+ accwin_multiplier = 3.0_8
+
+ ! Quick sanity check.
+ if(size(in_orbits) .le. 0) then
+ ! Nothing to do.
+ return
+ end if
+
+ allocate(perturbers(10), stat=error_code)
+ if(error_code /= 0) then
+ ! Error in allocating memory!
+ error_code = 57
+ return
+ end if
+ perturbers = .true.
+
+ ! Get the element type from the input flattened orbits (the are supposed to
+ ! be all the same).
+ element_type_index = in_orbits(1, 15)
+ if(element_type_index .le. 0 .or. &
+ element_type_index .gt. size(ORBITAL_ELEMENTS)) then
+ ! Error: unsupported orbital elements.
+ error_code = 58
+ return
+ end if
+ element_type = ORBITAL_ELEMENTS(element_type_index)
+
+
+ ! Convert the input observation array into a list of Observations instances.
+ ! Input coordinates (and their uncertainties) are in decimal degrees.
+ ! We need them in radians.
+ call obssFromCoords(track_id, num_coords, coords*rad_deg, mjds, mags, &
+ filters, obscodes, obss, error_code)
+ if(error_code /= 0) then
+ return
+ end if
+
+ ! do j=1,size(obss)
+ ! cov_matrices => getCovarianceMatrices(obss(j))
+ ! nobs = getNrOfObservations(obss(j))
+ ! DO i=1,nobs
+ ! write(*, *) "COV: ", cov_matrices(i,:,:)
+ ! END DO
+ ! end do
+
+ ! Convert the input orbits (which come from the ranging routine) into a
+ ! StochasticOrbit instance.
+ call nullify(in_storb)
+ call rangingOrbitsToStochasticOrbit(in_orbits, &
+ num_orbits, &
+ in_storb, &
+ error_code)
+ if(error_code /= 0) then
+ return
+ end if
+
+
+ ! Now that we have a set of Observations, pass them to the lsl routine.
+ ! obss has already been separated into tracks, pass one track at the time.
+ do j=1,size(obss)
+ call nullify(storb)
+
+ ! Do the LSL thing!
+ call lsl(obs_in=obss(j), &
+ element_type=element_type, &
+ dyn_model=dyn_model, &
+ dyn_model_init=dyn_model_init, &
+ integration_step=integration_step, &
+ integration_step_init=integration_step_init, &
+ perturbers=perturbers, &
+ ls_correction_factor=ls_correction_factor, &
+ ls_element_mask=ls_element_mask, &
+ ls_niter_major_max=ls_niter_major_max, &
+ ls_niter_major_min=ls_niter_major_min, &
+ ls_niter_minor=ls_niter_minor, &
+ outlier_rejection=outlier_rejection, &
+ outlier_multiplier=outlier_multiplier, &
+ accwin_multiplier=accwin_multiplier, &
+ inStochOrbit=in_storb, &
+ outStochOrbit=storb, &
+ errorCode=error_code)
+ if(error_code /= 0) then
+ return
+ end if
+
+ ! Now flatten the lsl orbit.
+ call exportLslOrbit(storb, element_type, track_id, out_orbit, &
+ out_covariance, out_sigmas, out_correlation, &
+ error_code)
+ call nullify(storb)
+ if(error_code /= 0) then
+ return
+ end if
+ end do
+ deallocate(perturbers)
+end subroutine oorb_lsl
+
+
+
+subroutine oorb_propagate_orbit_fast(in_orbit, in_covariance, in_mjd, &
+ out_orbit, out_covariance, out_sigmas, &
+ out_correlation, error_code)
+ use liboorb
+ use StochasticOrbit_cl
+
+ ! Input/Output variables.
+ ! Input flattened orbit:
+ ! (track_id, elements(1:6), epoch, H, G, element_type_index)
+ ! FIXME: H and G are not currently computed.
+ real(8),dimension(11), intent(in) :: in_orbit
+ ! Uncertainty matrices:
+ REAL(8), DIMENSION(6,6), intent(in) :: in_covariance
+ ! The epoch (MJD TAI) we want to propagate to.
+ real(8), intent(in) :: in_mjd
+ ! Output flattened orbit:
+ ! (track_id, elements(1:6), epoch, H, G, element_type_index)
+ ! FIXME: H and G are not currently computed.
+ real(8),dimension(11), intent(out) :: out_orbit
+ ! Uncertainty matrices:
+ REAL(8), DIMENSION(6,6), intent(out) :: out_covariance
+ REAL(8), DIMENSION(6), intent(out) :: out_sigmas
+ REAL(8), DIMENSION(6,6), intent(out) :: out_correlation
+ ! Output error code
+ integer, intent(out) :: error_code
+
+ ! Internal variables.
+ TYPE (StochasticOrbit) :: storb
+ character(len=6) :: dyn_model
+ real(8) :: integration_step
+ LOGICAL, DIMENSION(:), pointer :: perturbers
+ integer :: track_id
+ character(len=11) :: element_type
+ integer :: element_type_index
+
+
+ ! Init
+ error_code = 0
+ dyn_model = "2-body"
+ integration_step = 5.0_8
+ allocate(perturbers(10), stat=error_code)
+ if(error_code /= 0) then
+ ! Error in allocating memory!
+ error_code = 57
+ return
+ end if
+ perturbers = .true.
+
+ ! Get the element type from the input flattened orbit.
+ element_type_index = in_orbit(11)
+ if(element_type_index .le. 0 .or. &
+ element_type_index .gt. size(ORBITAL_ELEMENTS)) then
+ ! Error: unsupported orbital elements.
+ error_code = 58
+ return
+ end if
+ element_type = ORBITAL_ELEMENTS(element_type_index)
+
+
+ ! Create a StochastisOrbit instance form the flattened input orbit.
+ call lslOrbitToStochasticOrbit(in_orbit, &
+ in_covariance, &
+ storb, &
+ error_code)
+ if(error_code /= 0) then
+ return
+ end if
+
+ ! Now call the orbit propagation routine.
+ call propagateOrbit(storb, dyn_model, integration_step, perturbers, &
+ in_mjd, error_code)
+ if(error_code /= 0) then
+ return
+ end if
+
+ ! And now re-flatten the StochasticOrbit.
+ track_id = IDINT(in_orbit(1))
+ call exportLslOrbit(storb, element_type, track_id, out_orbit, &
+ out_covariance, out_sigmas, out_correlation, &
+ error_code)
+ if(error_code /= 0) then
+ return
+ end if
+ call nullify(storb)
+ deallocate(perturbers)
+ return
+end subroutine oorb_propagate_orbit_fast
+
+
+
+subroutine oorb_propagate_orbit(in_orbit, in_covariance, in_mjd, out_orbit, &
+ out_covariance, out_sigmas, &
+ out_correlation, error_code)
+ use liboorb
+ use StochasticOrbit_cl
+
+ ! Input/Output variables.
+ ! Input flattened orbit:
+ ! (track_id, elements(1:6), epoch, H, G, element_type_index)
+ ! FIXME: H and G are not currently computed.
+ real(8),dimension(11), intent(in) :: in_orbit
+ ! Uncertainty matrices:
+ REAL(8), DIMENSION(6,6), intent(in) :: in_covariance
+ ! The epoch (MJD TAI) we want to propagate to.
+ real(8), intent(in) :: in_mjd
+ ! Output flattened orbit:
+ ! (track_id, elements(1:6), epoch, H, G, element_type_index)
+ ! FIXME: H and G are not currently computed.
+ real(8),dimension(11), intent(out) :: out_orbit
+ ! Uncertainty matrices:
+ REAL(8), DIMENSION(6,6), intent(out) :: out_covariance
+ REAL(8), DIMENSION(6), intent(out) :: out_sigmas
+ REAL(8), DIMENSION(6,6), intent(out) :: out_correlation
+ ! Output error code
+ integer, intent(out) :: error_code
+
+ ! Internal variables.
+ TYPE (StochasticOrbit) :: storb
+ character(len=6) :: dyn_model
+ real(8) :: integration_step
+ LOGICAL, DIMENSION(:), pointer :: perturbers
+ integer :: track_id
+ character(len=11) :: element_type
+ integer :: element_type_index
+
+
+ ! Init
+ error_code = 0
+ dyn_model = "n-body"
+ integration_step = 5.0_8
+ allocate(perturbers(10), stat=error_code)
+ if(error_code /= 0) then
+ ! Error in allocating memory!
+ error_code = 57
+ return
+ end if
+ perturbers = .true.
+
+ ! Get the element type from the input flattened orbit.
+ element_type_index = in_orbit(11)
+ if(element_type_index .le. 0 .or. &
+ element_type_index .gt. size(ORBITAL_ELEMENTS)) then
+ ! Error: unsupported orbital elements.
+ error_code = 58
+ return
+ end if
+ element_type = ORBITAL_ELEMENTS(element_type_index)
+
+
+ ! Create a StochastisOrbit instance form the flattened input orbit.
+ call lslOrbitToStochasticOrbit(in_orbit, &
+ in_covariance, &
+ storb, &
+ error_code)
+ if(error_code /= 0) then
+ return
+ end if
+
+ ! Now call the orbit propagation routine.
+ call propagateOrbit(storb, dyn_model, integration_step, perturbers, &
+ in_mjd, error_code)
+ if(error_code /= 0) then
+ return
+ end if
+
+ ! And now re-flatten the StochasticOrbit.
+ track_id = IDINT(in_orbit(1))
+ call exportLslOrbit(storb, element_type, track_id, out_orbit, &
+ out_covariance, out_sigmas, out_correlation, &
+ error_code)
+ if(error_code /= 0) then
+ return
+ end if
+ call nullify(storb)
+ deallocate(perturbers)
+ return
+end subroutine oorb_propagate_orbit
+
+
+
+subroutine oorb_ephemeris_fast(in_orbit, &
+ in_covariance, &
+ in_obscode, &
+ in_num_ephems, &
+ in_step, &
+ out_ephems, &
+ error_code)
+ use liboorb
+ use StochasticOrbit_cl
+
+ ! Input/Output variables.
+ ! Input flattened orbit:
+ ! (track_id, elements(1:6), epoch, H, G, element_type_index)
+ ! FIXME: H and G are not currently computed.
+ real(8),dimension(11), intent(in) :: in_orbit
+ ! Uncertainty matrices:
+ REAL(8), DIMENSION(6,6), intent(in) :: in_covariance
+ character(len=4), intent(in) :: in_obscode
+ ! Compute epehemeris from the orbit epoch to epoch+in_step*in_num_ephems
+ ! Number of ephemeris to compute.
+ integer, intent(in) :: in_num_ephems
+ ! Ephemeris step in fractional days.
+ real(8), intent(in) :: in_step
+ ! Output ephemeris
+ ! out_ephems = ((dist, ra, dec, mag, mjd, raErr, decErr, smaa, smia, pa), )
+ real(8), dimension(in_num_ephems,10), intent(out) :: out_ephems
+ ! Output error code
+ integer, intent(out) :: error_code
+
+ ! Internal variables.
+ TYPE (StochasticOrbit) :: storb
+ character(len=6) :: dyn_model
+ real(8) :: integration_step
+ LOGICAL, DIMENSION(:), pointer :: perturbers
+ character(len=11) :: element_type
+ integer :: element_type_index
+ TYPE (SphericalCoordinates), DIMENSION(:,:),POINTER :: ephem_arr
+ REAL(8), DIMENSION(:,:,:), POINTER :: cov_arr
+ REAL(8), DIMENSION(:,:), POINTER :: pdfs_arr
+ TYPE (CartesianCoordinates), DIMENSION(:), POINTER :: observers
+ real(8) :: timespan
+ real(8) :: step
+
+
+ ! Init
+ error_code = 0
+ dyn_model = "2-body"
+ integration_step = 5.0_8
+ allocate(perturbers(10), stat=error_code)
+ if(error_code /= 0) then
+ ! Error in allocating memory!
+ error_code = 57
+ return
+ end if
+ perturbers = .true.
+
+ ! Get the element type from the input flattened orbit.
+ element_type_index = in_orbit(11)
+ if(element_type_index .le. 0 .or. &
+ element_type_index .gt. size(ORBITAL_ELEMENTS)) then
+ ! Error: unsupported orbital elements.
+ error_code = 58
+ return
+ end if
+ element_type = ORBITAL_ELEMENTS(element_type_index)
+
+ ! Compute timespan given step and num_ephems.
+ timespan = in_step * in_num_ephems
+ step = in_step ! Might be modified by the code below.
+
+ ! Create a StochastisOrbit instance form the flattened input orbit.
+ call lslOrbitToStochasticOrbit(in_orbit, &
+ in_covariance, &
+ storb, &
+ error_code)
+ if(error_code /= 0) then
+ return
+ end if
+
+ ! Now call the orbit propagation routine.
+ call ephemeris(storb, &
+ element_type, &
+ dyn_model, &
+ integration_step, &
+ perturbers, &
+ in_obscode, &
+ timespan, &
+ step, &
+ ephem_arr, &
+ cov_arr, &
+ pdfs_arr, &
+ observers, &
+ error_code)
+ if(error_code /= 0) then
+ return
+ end if
+
+ ! Now Export the ephem_arr to a flar array.
+ call exportEphemeris(storb, ephem_arr, cov_arr, observers, out_ephems, &
+ error_code)
+ if(error_code /= 0) then
+ return
+ end if
+ return
+end subroutine oorb_ephemeris_fast
+
+
+
+subroutine oorb_ephemeris(in_orbit, &
+ in_covariance, &
+ in_obscode, &
+ in_num_ephems, &
+ in_step, &
+ out_ephems, &
+ error_code)
+ use liboorb
+ use StochasticOrbit_cl
+
+ ! Input/Output variables.
+ ! Input flattened orbit:
+ ! (track_id, elements(1:6), epoch, H, G, element_type_index)
+ ! FIXME: H and G are not currently computed.
+ real(8),dimension(11), intent(in) :: in_orbit
+ ! Uncertainty matrices:
+ REAL(8), DIMENSION(6,6), intent(in) :: in_covariance
+ character(len=4), intent(in) :: in_obscode
+ ! Compute epehemeris from the orbit epoch to epoch+in_step*in_num_ephems
+ ! Number of ephemeris to compute.
+ integer, intent(in) :: in_num_ephems
+ ! Ephemeris step in fractional days.
+ real(8), intent(in) :: in_step
+ ! Output ephemeris
+ ! out_ephems = ((dist, ra, dec, mag, mjd, raErr, decErr, smaa, smia, pa), )
+ real(8), dimension(in_num_ephems,10), intent(out) :: out_ephems
+ ! Output error code
+ integer, intent(out) :: error_code
+
+ ! Internal variables.
+ TYPE (StochasticOrbit) :: storb
+ character(len=6) :: dyn_model
+ real(8) :: integration_step
+ LOGICAL, DIMENSION(:), pointer :: perturbers
+ character(len=11) :: element_type
+ integer :: element_type_index
+ TYPE (SphericalCoordinates), DIMENSION(:,:),POINTER :: ephem_arr
+ REAL(8), DIMENSION(:,:,:), POINTER :: cov_arr
+ REAL(8), DIMENSION(:,:), POINTER :: pdfs_arr
+ TYPE (CartesianCoordinates), DIMENSION(:), POINTER :: observers
+ real(8) :: timespan
+ real(8) :: step
+
+
+ ! Init
+ error_code = 0
+ dyn_model = "n-body"
+ integration_step = 5.0_8
+ allocate(perturbers(10), stat=error_code)
+ if(error_code /= 0) then
+ ! Error in allocating memory!
+ error_code = 57
+ return
+ end if
+ perturbers = .true.
+
+ ! Get the element type from the input flattened orbit.
+ element_type_index = in_orbit(11)
+ if(element_type_index .le. 0 .or. &
+ element_type_index .gt. size(ORBITAL_ELEMENTS)) then
+ ! Error: unsupported orbital elements.
+ error_code = 58
+ return
+ end if
+ element_type = ORBITAL_ELEMENTS(element_type_index)
+
+ ! Compute timespan given step and num_ephems.
+ timespan = in_step * in_num_ephems
+ step = in_step ! Might be modified by the code below.
+
+ ! Create a StochastisOrbit instance form the flattened input orbit.
+ call lslOrbitToStochasticOrbit(in_orbit, &
+ in_covariance, &
+ storb, &
+ error_code)
+ if(error_code /= 0) then
+ return
+ end if
+
+ ! Now call the orbit propagation routine.
+ call ephemeris(storb, &
+ element_type, &
+ dyn_model, &
+ integration_step, &
+ perturbers, &
+ in_obscode, &
+ timespan, &
+ step, &
+ ephem_arr, &
+ cov_arr, &
+ pdfs_arr, &
+ observers, &
+ error_code)
+ if(error_code /= 0) then
+ return
+ end if
+
+ ! Now Export the ephem_arr to a flar array.
+ call exportEphemeris(storb, ephem_arr, cov_arr, observers, out_ephems, &
+ error_code)
+ if(error_code /= 0) then
+ return
+ end if
+ return
+end subroutine oorb_ephemeris
+
+
+
+subroutine oorb_moid(in_orbit, in_covariance, moid, error_code)
+ use liboorb
+ use StochasticOrbit_cl
+
+ ! Input/Output variables.
+ ! Input flattened orbit:
+ ! (track_id, elements(1:6), epoch, H, G, element_type_index)
+ ! FIXME: H and G are not currently computed.
+ real(8),dimension(11), intent(in) :: in_orbit
+ ! Uncertainty matrices:
+ REAL(8), DIMENSION(6,6), intent(in) :: in_covariance
+ ! Output MOID
+ real(8), intent(out) :: moid
+ ! Output error code
+ integer, intent(out) :: error_code
+
+ ! Internal vars
+ TYPE (StochasticOrbit) :: storb
+ character(len=11) :: element_type
+ integer :: element_type_index
+
+
+ ! Init
+ error_code = 0
+
+ ! Get the element type from the input flattened orbit.
+ element_type_index = in_orbit(11)
+ if(element_type_index .le. 0 .or. &
+ element_type_index .gt. size(ORBITAL_ELEMENTS)) then
+ ! Error: unsupported orbital elements.
+ error_code = 58
+ return
+ end if
+ element_type = ORBITAL_ELEMENTS(element_type_index)
+
+ ! Create a StochastisOrbit instance form the flattened input orbit.
+ call lslOrbitToStochasticOrbit(in_orbit, &
+ in_covariance, &
+ storb, &
+ error_code)
+ if(error_code /= 0) then
+ return
+ end if
+
+ ! Now call the orbit propagation routine.
+ call computeMoid(storb, moid, error_code)
+ if(error_code /= 0) then
+ return
+ end if
+ return
+end subroutine oorb_moid
+
+
+
+subroutine priv_classification(in_orbits, num_orbits, weights, error_code)
+ use liboorb
+ use StochasticOrbit_cl
+
+ ! Input/Output variables.
+ ! Input flattened orbit:
+ ! (track_id, elements(1:6), epoch, H, G, element_type_index)
+ ! FIXME: H and G are not currently computed.
+ integer, intent(in) :: num_orbits
+ ! Input flattened orbits.
+ ! in_orbits has the form ((id, elements(1:6), epoch, Un-normalized p.d.f.,
+ ! Reduced chi2, Regularized apr, Jacobian det(1:3), el_type_index), )
+ real(8),dimension(num_orbits,15),intent(in) :: in_orbits
+ ! Class names and probability arrays.
+ ! CHARACTER(len=16), DIMENSION(17), intent(out) :: classes
+ REAL(8), DIMENSION(17), intent(out) :: weights
+ ! Output error code
+ integer, intent(out) :: error_code
+
+ ! Internal vars
+ TYPE (StochasticOrbit) :: storb
+ integer :: j = 0
+ REAL(bp), DIMENSION(:), POINTER :: weight_arr
+ CHARACTER(len=16), DIMENSION(:), POINTER :: group_name_arr
+
+
+ ! Init
+ error_code = 0
+
+ ! Create a StochastisOrbit instance form the flattened input orbits.
+ call nullify(storb)
+ call rangingOrbitsToStochasticOrbit(in_orbits, &
+ num_orbits, &
+ storb, &
+ error_code)
+ if(error_code /= 0) then
+ return
+ end if
+
+ ! Now call the orbit propagation routine.
+ call classification(storb, group_name_arr, weight_arr, error_code)
+ if(error_code /= 0) then
+ return
+ end if
+ call nullify(storb)
+
+ ! Copy values from the pointers to the regular arrays.
+ do j=1,min(size(weights), size(weight_arr))
+ ! classes(j) = group_name_arr(j)
+ weights(j) = weight_arr(j)
+ ! write(*, *) "classes(j): ", classes(j)
+ ! write(*, *) "weights(j): ", weights(j)
+ end do
+ deallocate(group_name_arr)
+ deallocate(weight_arr)
+ return
+end subroutine priv_classification
+
+
+
+subroutine oorb_calendardate_to_mjd(year, month, day, mjd, timescale, &
+ error_code)
+ use liboorb, only: calendarDateToMjd
+
+ ! Input: year, month, fractional days in whatever timescale they are
+ ! (usually UTC or UT1). Output MJD TAI.
+
+ integer, intent(in) :: year
+ integer, intent(in) :: month
+ ! day + time in fractional days.
+ real(8), intent(in) :: day
+ CHARACTER(len=*), intent(in) :: timescale
+ real(8), intent(out) :: mjd
+ integer, intent(out) :: error_code
+
+
+ call calendarDateToMjd(year, month, day, mjd, trim(timescale), error_code)
+ return
+end subroutine oorb_calendardate_to_mjd
+
+
+
+subroutine oorb_mjdutc_to_mjdtai(mjd_utc, mjd_tai, error_code)
+ use liboorb, only: mjdConvert
+
+ ! Input: MJD UTC
+ ! Output: MJD TAI
+ real(8), intent(in) :: mjd_utc
+ real(8), intent(out) :: mjd_tai
+ integer, intent(out) :: error_code
+
+
+ call mjdConvert(mjd_utc, "UTC", mjd_tai, "TAI", error_code)
+ return
+end subroutine oorb_mjdutc_to_mjdtai
+
+
+
+subroutine oorb_mjdtai_to_mjdutc(mjd_tai, mjd_utc, error_code)
+ use liboorb, only: mjdConvert
+
+ ! Input: MJD UTC
+ ! Output: MJD TAI
+ real(8), intent(in) :: mjd_tai
+ real(8), intent(out) :: mjd_utc
+ integer, intent(out) :: error_code
+
+
+ call mjdConvert(mjd_tai, "TAI", mjd_utc, "UTC", error_code)
+ return
+end subroutine oorb_mjdtai_to_mjdutc
+
+
+
+subroutine oorb_mjdtt_to_mjdtai(mjd_tt, mjd_tai, error_code)
+ use liboorb, only: mjdConvert
+
+ ! Input: MJD TT = MJD TAI + 32.184 seconds
+ ! Output: MJD TAI
+ real(8), intent(in) :: mjd_tt
+ real(8), intent(out) :: mjd_tai
+ integer, intent(out) :: error_code
+
+
+ call mjdConvert(mjd_tt, "TT", mjd_tai, "TAI", error_code)
+ return
+end subroutine oorb_mjdtt_to_mjdtai
+
+
+
+subroutine oorb_mjdtai_to_mjdtt(mjd_tai, mjd_tt, error_code)
+ use liboorb, only: mjdConvert
+
+ ! Input: MJD TAI
+ ! Output: MJD TT = MJD TAI + 32.184 seconds
+ real(8), intent(in) :: mjd_tai
+ real(8), intent(out) :: mjd_tt
+ integer, intent(out) :: error_code
+
+
+ call mjdConvert(mjd_tai, "TAI", mjd_tt, "TT", error_code)
+ return
+end subroutine oorb_mjdtai_to_mjdtt
+
+
+
+subroutine sexagesimal_hours_to_deci_deg(h, m, s, deg, error_code)
+ integer, intent(in) :: h
+ integer, intent(in) :: m
+ real(8), intent(in) :: s
+ real(8), intent(out) :: deg
+ integer, intent(out) :: error_code
+
+
+ error_code = 0
+ call sexagesimal_deg_to_deci_deg(h, m, s, deg, error_code)
+ deg = deg * 15.0_8
+ return
+end subroutine sexagesimal_hours_to_deci_deg
+
+
+
+subroutine sexagesimal_deg_to_deci_deg(d, m, s, deg, error_code)
+ integer, intent(in) :: d
+ integer, intent(in) :: m
+ real(8), intent(in) :: s
+ real(8), intent(out) :: deg
+ integer, intent(out) :: error_code
+
+
+ error_code = 0
+ if(d .ge. 0.0_8) then
+ deg = d + m / 60.0_8 + s / 3600.0_8
+ else
+ deg = d - m / 60.0_8 - s / 3600.0_8
+ end if
+ return
+end subroutine sexagesimal_deg_to_deci_deg
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
Index: trunk/mops/oorb/python/wrapper4mops.f90
===================================================================
--- trunk/mops/oorb/python/wrapper4mops.f90 (revision 34646)
+++ trunk/mops/oorb/python/wrapper4mops.f90 (revision 34646)
@@ -0,0 +1,1564 @@
+!
+! LSST Data Management System
+! Copyright 2008, 2009 LSST Corporation.
+!
+! This product includes software developed by the
+! LSST Project (http://www.lsst.org/).
+!
+! This program 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.
+!
+! This program 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 LSST License Statement and
+! the GNU General Public License along with this program. If not,
+! see .
+!
+!
+! OpenOrb library
+! F. Pierfederici
+!
+! Description
+!
+! Notes
+! error is a boolean global and is defined somewhere in liboorb.so!
+!
+!
+! Implementation notes:
+! 1. both oorb_ranging_fast and oorb_lsl_fast have a useless loop in them:
+! either clean them up or make them useful!
+!
+!
+
+! Orbital elements that we support.
+! ORBITAL_ELEMENTS = (/ "keplerian", "delaunay", "poincare", "equinoctial" /)
+
+
+
+
+
+subroutine oorb_init(ephemFileName, verbosity, error_code)
+ ! Initialize the OpenOrb module.
+ !
+ ! @param ephemFileName: full path of the JPL ephem file (usually
+ ! $OORB_DATA/JPL_ephemeris/de405.dat).
+ ! @param verbosity: verbosity level for OpenOrb calls [0, 5] (default 0)
+ ! @return error_code: int error code. 0 = success, otherwise, failure.
+ use liboorb, only: init
+ ! Input/Output variables.
+ character(len=*), intent(IN) :: ephemFileName
+ integer, intent(in) :: verbosity
+ integer, intent(OUT) :: error_code
+
+
+ call init(trim(ephemFileName), verbosity, error_code)
+
+end subroutine oorb_init
+
+
+
+subroutine oorb_ranging_fast(obscodes, &
+ filters, &
+ track_id, &
+ num_coords, &
+ coords, &
+ mjds, &
+ mags, &
+ element_type, &
+ num_orbits, &
+ out_orbits, &
+ error_code)
+ use liboorb
+ use Observations_cl
+ use StochasticOrbit_cl
+ ! Orbital inversion using statistical orbital ranging, that is,
+ ! without making any assumptions on the shape of the resulting
+ ! orbital-element pdf.
+
+ ! All angles coming in are in decimal degrees. All times in MJD TAI.
+
+ ! Input/Output variables.
+ ! Observations (i.e. DiASources) to be used as input. It is assumed that
+ ! they all belong to the same track.
+ ! We have to use separate arrays since they are of different type.
+ integer, intent(in) :: track_id
+ integer, intent(in) :: num_coords
+ real(8), dimension(num_coords), intent(in) :: mjds
+ real(8), dimension(num_coords, 4), intent(in) :: coords
+ real(8), dimension(num_coords), intent(in) :: mags
+ ! FIXME: f2py bug that only passes the first char of element of an array of
+ ! strings.
+ character(len=1), dimension(num_coords), intent(in) :: filters
+ ! FIXME: f2py bug that only passes the first char of element of an array of
+ ! strings.
+ character(len=4), dimension(num_coords), intent(in) :: obscodes
+ ! Element type used in the orbit computation (default keplerian)
+ CHARACTER(len=11), intent(in) :: element_type
+ ! How may orbits do we want out?
+ integer, intent(in) :: num_orbits
+ ! Output flattened orbits.
+ ! out_orbits has the form (id, (elements(1:6), epoch, Un-normalized p.d.f.,
+ ! Reduced chi2, Regularized apr, Jacobian det(1:3), element_type_index), )
+ real(8),dimension(num_orbits,15),intent(out) :: out_orbits
+ ! Output error code
+ integer, intent(out) :: error_code
+
+
+ ! Internal variables.
+ character(len=6) :: dyn_model
+ real(8) :: integration_step
+ LOGICAL, DIMENSION(:), pointer :: perturbers
+ real(8) :: apriori_a_max
+ real(8) :: apriori_a_min
+ real(8) :: apriori_rho_max
+ real(8) :: apriori_rho_min
+ logical :: outlier_rejection
+ real(8) :: outlier_multiplier
+ integer :: sor_type_prm
+ character(len=80) :: sor_2point_method
+ character(len=80) :: sor_2point_method_sw
+ integer :: sor_norb
+ integer :: sor_norb_sw
+ integer :: sor_ntrial
+ integer :: sor_ntrial_sw
+ integer :: sor_niter
+ REAL(8), DIMENSION(4) :: sor_rho_init
+ real(8) :: sor_genwin_multiplier
+ REAL(8), DIMENSION(4) :: sor_genwin_offset
+ real(8) :: accwin_multiplier
+ logical :: gaussian_rho
+ real(8) :: pdf_ml_init
+ logical :: uniform
+ logical :: regularized
+ logical :: random_obs
+ TYPE (Observations), DIMENSION(:), POINTER :: obss
+ TYPE (StochasticOrbit) :: storb
+ integer :: j
+ integer :: element_type_index
+
+ ! REAL(8), DIMENSION(:,:,:), POINTER :: cov_matrices
+ ! integer :: nobs = 0
+ ! integer :: i = 0
+ ! TYPE (SphericalCoordinates), DIMENSION(:), POINTER :: scoords
+
+ ! do j=1,num_coords
+ ! write(*, *) "obscodes: ", obscodes(j)
+ ! end do
+
+
+
+ ! write(*, *) "obscodes(1) ", obscodes(1)
+ ! write(*, *) "obscodes(2) ", obscodes(2)
+ ! write(*, *) "obscodes(3) ", obscodes(3)
+ ! write(*, *) "filters(1) ", filters(1)
+ ! write(*, *) "filters(2) ", filters(2)
+ ! write(*, *) "filters(3) ", filters(3)
+ ! write(*, *) "track_id ", track_id
+ ! write(*, *) "num_coords ", num_coords
+ ! write(*, *) "coords(1) ", coords(1, :)
+ ! write(*, *) "coords(2) ", coords(2, :)
+ ! write(*, *) "coords(3) ", coords(3, :)
+ ! write(*, *) "mjds ", mjds
+ ! write(*, *) "mags ", mags
+ ! write(*, *) "element_type '", element_type, "'"
+ ! write(*, *) "num_orbits ", num_orbits
+
+ ! Init (these values come from best practices and default OpenOrb values).
+ error_code = 0
+ dyn_model = "2-body"
+ integration_step = 5.0_8
+ apriori_a_max = 1000.0_8
+ apriori_a_min = 4.65423999999999959E-003_8
+ apriori_rho_max = -1.0_8
+ apriori_rho_min = -1.0_8
+ outlier_rejection = .false.
+ outlier_multiplier = 4.0_8
+ sor_type_prm = 2
+ sor_2point_method = "continued fraction"
+ sor_2point_method_sw = "continued fraction"
+ sor_norb = num_orbits
+ sor_norb_sw = sor_norb / 10
+ sor_ntrial = sor_norb * 2000
+ sor_ntrial_sw = sor_norb_sw * 400
+ sor_niter = 3
+ sor_rho_init = huge(sor_rho_init)
+ sor_rho_init(1) = 0.0_8
+ sor_rho_init(2) = 100.0_8
+ sor_genwin_multiplier = 3.0_8
+ sor_genwin_offset = 0.0_8
+ accwin_multiplier = 3.0_8
+ gaussian_rho = .false.
+ pdf_ml_init = -1.0_8
+ uniform = .false.
+ regularized = .true.
+ random_obs = .false.
+ obss => null()
+ call nullify(storb)
+ j = 0
+ allocate(perturbers(10), stat=error_code)
+ if(error_code /= 0) then
+ ! Error in allocating memory!
+ error_code = 57
+ return
+ end if
+ perturbers = .true.
+
+ ! Figure out the element_type_index
+ element_type_index = -1
+ do j=1,size(ORBITAL_ELEMENTS)
+ if(trim(element_type) == trim(ORBITAL_ELEMENTS(j))) then
+ element_type_index = j
+ exit
+ ! else
+ ! write(*, *) "'" // trim(element_type) // "' =/ '" // trim(ORBITAL_ELEMENTS(j)) // "'"
+ ! write(*, *) " ", len(trim(element_type)), " =/ ", len(trim(ORBITAL_ELEMENTS(j)))
+ end if
+ end do
+ if(element_type_index .le. 0) then
+ ! Error: unsupported element type!
+ error_code = 58
+ return
+ end if
+
+ ! Convert the input observation array into a list of Observations instances.
+ ! Input coordinates (and their uncertainties) are in decimal degrees.
+ ! We need them in radians.
+ call obssFromCoords(track_id, num_coords, coords*rad_deg, mjds, mags, &
+ filters, obscodes, obss, error_code)
+ if(error_code /= 0) then
+ return
+ end if
+
+ ! do j=1,size(obss)
+ ! cov_matrices => getCovarianceMatrices(obss(j))
+ ! nobs = getNrOfObservations(obss(j))
+ ! DO i=1,nobs
+ ! write(*, *) "COV: ", cov_matrices(i,:,:)
+ ! END DO
+ ! end do
+
+ ! Now that we have a set of Observations, pass them to the ranging routine.
+ ! obss has already been separated into tracks, pass one track at the time.
+ ! We clearly expect one track only, so this loop is here only so that we can
+ ! support multiple track processing later on. But it could just as well be
+ ! eliminated...
+ do j=1,size(obss)
+ call nullify(storb)
+
+ ! scoords => getObservationSCoords(obss(j))
+ ! do i=1,size(scoords)
+ ! write(*, *) "RA: ", getLongitude(scoords(i))
+ ! write(*, *) "Dec: ", getLatitude(scoords(i))
+ ! end do
+
+
+ call ranging(obs_in=obss(j), element_type=trim(element_type), &
+ dyn_model=trim(dyn_model), &
+ integration_step=integration_step, &
+ perturbers=perturbers, apriori_a_max=apriori_a_max, &
+ apriori_a_min=apriori_a_min, &
+ apriori_rho_max=apriori_rho_max, &
+ apriori_rho_min=apriori_rho_min, &
+ outlier_rejection=outlier_rejection, &
+ outlier_multiplier=outlier_multiplier, &
+ sor_type_prm=sor_type_prm, &
+ sor_2point_method=trim(sor_2point_method), &
+ sor_2point_method_sw=trim(sor_2point_method_sw), &
+ sor_norb=sor_norb, sor_norb_sw=sor_norb_sw, &
+ sor_ntrial=sor_ntrial, sor_ntrial_sw=sor_ntrial_sw, &
+ sor_niter=sor_niter, sor_rho_init=sor_rho_init, &
+ sor_genwin_multiplier=sor_genwin_multiplier, &
+ sor_genwin_offset=sor_genwin_offset, &
+ accwin_multiplier=accwin_multiplier, &
+ gaussian_rho=gaussian_rho, &
+ pdf_ml_init=pdf_ml_init, uniform=uniform, &
+ regularized=regularized, random_obs=random_obs, &
+ outOrbit=storb, errorCode=error_code)
+ if(error_code /= 0) then
+ return
+ end if
+
+ ! Dump the storb orbit.
+ ! call dumpRangingOrbits(storb, errorCode=error_code)
+
+ ! Now flatten the ranging orbits.
+ call exportRangingOrbits(storb, element_type, track_id, out_orbits, &
+ error_code)
+ call nullify(storb)
+ if(error_code /= 0) then
+ return
+ end if
+ end do
+
+ deallocate(perturbers)
+
+end subroutine oorb_ranging_fast
+
+
+
+subroutine oorb_ranging(obscodes, &
+ filters, &
+ track_id, &
+ num_coords, &
+ coords, &
+ mjds, &
+ mags, &
+ element_type, &
+ num_orbits, &
+ out_orbits, &
+ error_code)
+ use liboorb
+ use Observations_cl
+ use StochasticOrbit_cl
+ ! Orbital inversion using statistical orbital ranging, that is,
+ ! without making any assumptions on the shape of the resulting
+ ! orbital-element pdf.
+
+ ! All angles coming in are in decimal degrees. All times in MJD TAI.
+
+ ! Input/Output variables.
+ ! Observations (i.e. DiASources) to be used as input. It is assumed that
+ ! they all belong to the same track.
+ ! We have to use separate arrays since they are of different type.
+ integer, intent(in) :: track_id
+ integer, intent(in) :: num_coords
+ real(8), dimension(num_coords), intent(in) :: mjds
+ real(8), dimension(num_coords, 4), intent(in) :: coords
+ real(8), dimension(num_coords), intent(in) :: mags
+ ! FIXME: f2py bug that only passes the first char of element of an array of
+ ! strings.
+ character(len=1), dimension(num_coords), intent(in) :: filters
+ ! FIXME: f2py bug that only passes the first char of element of an array of
+ ! strings.
+ character(len=4), dimension(num_coords), intent(in) :: obscodes
+ ! Element type used in the orbit computation (default keplerian)
+ CHARACTER(len=11), intent(in) :: element_type
+ ! How may orbits do we want out?
+ integer, intent(in) :: num_orbits
+ ! Output flattened orbits.
+ ! out_orbits has the form (id, (elements(1:6), epoch, Un-normalized p.d.f.,
+ ! Reduced chi2, Regularized apr, Jacobian det(1:3), element_type_index), )
+ real(8),dimension(num_orbits,15),intent(out) :: out_orbits
+ ! Output error code
+ integer, intent(out) :: error_code
+
+
+ ! Internal variables.
+ character(len=6) :: dyn_model
+ real(8) :: integration_step
+ LOGICAL, DIMENSION(:), pointer :: perturbers
+ real(8) :: apriori_a_max
+ real(8) :: apriori_a_min
+ real(8) :: apriori_rho_max
+ real(8) :: apriori_rho_min
+ logical :: outlier_rejection
+ real(8) :: outlier_multiplier
+ integer :: sor_type_prm
+ character(len=80) :: sor_2point_method
+ character(len=80) :: sor_2point_method_sw
+ integer :: sor_norb
+ integer :: sor_norb_sw
+ integer :: sor_ntrial
+ integer :: sor_ntrial_sw
+ integer :: sor_niter
+ REAL(8), DIMENSION(4) :: sor_rho_init
+ real(8) :: sor_genwin_multiplier
+ REAL(8), DIMENSION(4) :: sor_genwin_offset
+ real(8) :: accwin_multiplier
+ logical :: gaussian_rho
+ real(8) :: pdf_ml_init
+ logical :: uniform
+ logical :: regularized
+ logical :: random_obs
+ TYPE (Observations), DIMENSION(:), POINTER :: obss
+ TYPE (StochasticOrbit) :: storb
+ integer :: j
+ integer :: element_type_index
+
+ ! REAL(8), DIMENSION(:,:,:), POINTER :: cov_matrices
+ ! integer :: nobs = 0
+ ! integer :: i = 0
+ ! TYPE (SphericalCoordinates), DIMENSION(:), POINTER :: scoords
+
+ ! do j=1,num_coords
+ ! write(*, *) "obscodes: ", obscodes(j)
+ ! end do
+
+
+
+ ! write(*, *) "obscodes(1) ", obscodes(1)
+ ! write(*, *) "obscodes(2) ", obscodes(2)
+ ! write(*, *) "obscodes(3) ", obscodes(3)
+ ! write(*, *) "filters(1) ", filters(1)
+ ! write(*, *) "filters(2) ", filters(2)
+ ! write(*, *) "filters(3) ", filters(3)
+ ! write(*, *) "track_id ", track_id
+ ! write(*, *) "num_coords ", num_coords
+ ! write(*, *) "coords(1) ", coords(1, :)
+ ! write(*, *) "coords(2) ", coords(2, :)
+ ! write(*, *) "coords(3) ", coords(3, :)
+ ! write(*, *) "mjds ", mjds
+ ! write(*, *) "mags ", mags
+ ! write(*, *) "element_type '", element_type, "'"
+ ! write(*, *) "num_orbits ", num_orbits
+
+ ! Init (these values come from best practices and default OpenOrb values).
+ error_code = 0
+ dyn_model = "n-body"
+ integration_step = 5.0_8
+ apriori_a_max = 1000.0_8
+ apriori_a_min = 4.65423999999999959E-003_8
+ apriori_rho_max = -1.0_8
+ apriori_rho_min = -1.0_8
+ outlier_rejection = .false.
+ outlier_multiplier = 4.0_8
+ sor_type_prm = 2
+ sor_2point_method = "continued fraction"
+ sor_2point_method_sw = "continued fraction"
+ sor_norb = num_orbits
+ sor_norb_sw = sor_norb / 10
+ sor_ntrial = sor_norb * 2000
+ sor_ntrial_sw = sor_norb_sw * 400
+ sor_niter = 3
+ sor_rho_init = huge(sor_rho_init)
+ sor_rho_init(1) = 0.0_8
+ sor_rho_init(2) = 100.0_8
+ sor_genwin_multiplier = 3.0_8
+ sor_genwin_offset = 0.0_8
+ accwin_multiplier = 3.0_8
+ gaussian_rho = .false.
+ pdf_ml_init = -1.0_8
+ uniform = .false.
+ regularized = .true.
+ random_obs = .false.
+ obss => null()
+ call nullify(storb)
+ j = 0
+ allocate(perturbers(10), stat=error_code)
+ if(error_code /= 0) then
+ ! Error in allocating memory!
+ error_code = 57
+ return
+ end if
+ perturbers = .true.
+
+ ! Figure out the element_type_index
+ element_type_index = -1
+ do j=1,size(ORBITAL_ELEMENTS)
+ if(trim(element_type) == trim(ORBITAL_ELEMENTS(j))) then
+ element_type_index = j
+ exit
+ ! else
+ ! write(*, *) "'" // trim(element_type) // "' =/ '" // trim(ORBITAL_ELEMENTS(j)) // "'"
+ ! write(*, *) " ", len(trim(element_type)), " =/ ", len(trim(ORBITAL_ELEMENTS(j)))
+ end if
+ end do
+ if(element_type_index .le. 0) then
+ ! Error: unsupported element type!
+ error_code = 58
+ return
+ end if
+
+ ! Convert the input observation array into a list of Observations instances.
+ ! Input coordinates (and their uncertainties) are in decimal degrees.
+ ! We need them in radians.
+ call obssFromCoords(track_id, num_coords, coords*rad_deg, mjds, mags, &
+ filters, obscodes, obss, error_code)
+ if(error_code /= 0) then
+ return
+ end if
+
+ ! do j=1,size(obss)
+ ! cov_matrices => getCovarianceMatrices(obss(j))
+ ! nobs = getNrOfObservations(obss(j))
+ ! DO i=1,nobs
+ ! write(*, *) "COV: ", cov_matrices(i,:,:)
+ ! END DO
+ ! end do
+
+ ! Now that we have a set of Observations, pass them to the ranging routine.
+ ! obss has already been separated into tracks, pass one track at the time.
+ ! We clearly expect one track only, so this loop is here only so that we can
+ ! support multiple track processing later on. But it could just as well be
+ ! eliminated...
+ do j=1,size(obss)
+ call nullify(storb)
+
+ ! scoords => getObservationSCoords(obss(j))
+ ! do i=1,size(scoords)
+ ! write(*, *) "RA: ", getLongitude(scoords(i))
+ ! write(*, *) "Dec: ", getLatitude(scoords(i))
+ ! end do
+
+
+ call ranging(obs_in=obss(j), element_type=trim(element_type), &
+ dyn_model=trim(dyn_model), &
+ integration_step=integration_step, &
+ perturbers=perturbers, apriori_a_max=apriori_a_max, &
+ apriori_a_min=apriori_a_min, &
+ apriori_rho_max=apriori_rho_max, &
+ apriori_rho_min=apriori_rho_min, &
+ outlier_rejection=outlier_rejection, &
+ outlier_multiplier=outlier_multiplier, &
+ sor_type_prm=sor_type_prm, &
+ sor_2point_method=trim(sor_2point_method), &
+ sor_2point_method_sw=trim(sor_2point_method_sw), &
+ sor_norb=sor_norb, sor_norb_sw=sor_norb_sw, &
+ sor_ntrial=sor_ntrial, sor_ntrial_sw=sor_ntrial_sw, &
+ sor_niter=sor_niter, sor_rho_init=sor_rho_init, &
+ sor_genwin_multiplier=sor_genwin_multiplier, &
+ sor_genwin_offset=sor_genwin_offset, &
+ accwin_multiplier=accwin_multiplier, &
+ gaussian_rho=gaussian_rho, &
+ pdf_ml_init=pdf_ml_init, uniform=uniform, &
+ regularized=regularized, random_obs=random_obs, &
+ outOrbit=storb, errorCode=error_code)
+ if(error_code /= 0) then
+ return
+ end if
+
+ ! Dump the storb orbit.
+ ! call dumpRangingOrbits(storb, errorCode=error_code)
+
+ ! Now flatten the ranging orbits.
+ call exportRangingOrbits(storb, element_type, track_id, out_orbits, &
+ error_code)
+ call nullify(storb)
+ if(error_code /= 0) then
+ return
+ end if
+ end do
+
+ deallocate(perturbers)
+
+end subroutine oorb_ranging
+
+
+
+subroutine oorb_lsl_fast(obscodes, &
+ filters, &
+ track_id, &
+ num_coords, &
+ coords, &
+ mjds, &
+ mags, &
+ in_orbits, &
+ num_orbits, &
+ out_orbit, &
+ out_covariance, &
+ out_sigmas, &
+ out_correlation, &
+ error_code)
+ use liboorb
+ use StochasticOrbit_cl
+ ! Orbital inversion using statistical orbital ranging, that is,
+ ! without making any assumptions on the shape of the resulting
+ ! orbital-element pdf.
+
+ ! All angles coming in are in decimal degrees. All times in MJD TAI.
+
+ ! Input/Output variables.
+ ! Observations (i.e. DiASources) to be used as input. It is assumed that
+ ! they all belong to the same track.
+ ! We have to use separate arrays since they are of different type.
+ integer, intent(in) :: track_id
+ integer, intent(in) :: num_coords
+ real(8), dimension(num_coords), intent(in) :: mjds
+ real(8), dimension(num_coords, 4), intent(in) :: coords
+ real(8), dimension(num_coords), intent(in) :: mags
+ ! FIXME: f2py bug that only passes the first char of element of an array of
+ ! strings.
+ character(len=1), dimension(num_coords), intent(in) :: filters
+ ! FIXME: f2py bug that only passes the first char of element of an array of
+ ! strings.
+ character(len=4), dimension(num_coords), intent(in) :: obscodes
+ integer, intent(in) :: num_orbits
+ ! Input flattened orbits.
+ ! in_orbits has the form ((id, elements(1:6), epoch, Un-normalized p.d.f.,
+ ! Reduced chi2, Regularized apr, Jacobian det(1:3), el_type_index), )
+ real(8),dimension(num_orbits,15),intent(in) :: in_orbits
+ ! Output flattened orbit:
+ ! (track_id, elements(1:6), epoch, H, G, el_type_index)
+ ! FIXME: H and G are not currently computed.
+ real(8),dimension(11), intent(out) :: out_orbit
+ ! Uncertainty matrices:
+ REAL(8), DIMENSION(6,6), intent(out) :: out_covariance
+ REAL(8), DIMENSION(6), intent(out) :: out_sigmas
+ REAL(8), DIMENSION(6,6), intent(out) :: out_correlation
+ ! Output error code
+ integer, intent(out) :: error_code
+
+ ! Internal variables.
+ character(len=6) :: dyn_model
+ character(len=6) :: dyn_model_init
+ real(8) :: integration_step
+ real(8) :: integration_step_init
+ real(8) :: ls_correction_factor
+ LOGICAL, DIMENSION(6) :: ls_element_mask
+ integer :: ls_niter_major_max
+ integer :: ls_niter_major_min
+ integer :: ls_niter_minor
+ logical :: outlier_rejection
+ real(8) :: outlier_multiplier
+ real(8) :: accwin_multiplier
+ LOGICAL, DIMENSION(:), pointer :: perturbers
+ TYPE (Observations), DIMENSION(:), POINTER :: obss
+ TYPE (StochasticOrbit) :: storb
+ TYPE (StochasticOrbit) :: in_storb
+ integer :: j
+ character(len=11) :: element_type
+ integer :: element_type_index
+
+
+
+
+ ! do j=1,num_coords
+ ! write(*, *) "obscodes(", j, ") ", obscodes(j)
+ ! end do
+ ! do j=1,num_coords
+ ! write(*, *) "filters(", j, ") ", filters(j)
+ ! end do
+ ! write(*, *) "track_id ", track_id
+ ! write(*, *) "num_coords ", num_coords
+ ! do j=1,num_coords
+ ! write(*, *) "coords(", j, ") ", coords(j,:)
+ ! end do
+ ! write(*, *) "mjds ", mjds
+ ! write(*, *) "mags ", mags
+ ! write(*, *) "num_orbits ", num_orbits
+
+ ! Init variables (from OpenOrb config file and best practices).
+ error_code = 0
+ dyn_model = "2-body"
+ dyn_model_init = "2-body"
+ integration_step = 5.0_8
+ integration_step_init = 5.0_8
+ ls_correction_factor = 0.2_8
+ ls_element_mask = .true.
+ ls_niter_major_max = 20
+ ls_niter_major_min = 2
+ ls_niter_minor = 10
+ outlier_rejection = .false.
+ outlier_multiplier = 3.0_8
+ accwin_multiplier = 3.0_8
+
+ ! Quick sanity check.
+ if(size(in_orbits) .le. 0) then
+ ! Nothing to do.
+ return
+ end if
+
+ allocate(perturbers(10), stat=error_code)
+ if(error_code /= 0) then
+ ! Error in allocating memory!
+ error_code = 57
+ return
+ end if
+ perturbers = .true.
+
+ ! Get the element type from the input flattened orbits (the are supposed to
+ ! be all the same).
+ element_type_index = in_orbits(1, 15)
+ if(element_type_index .le. 0 .or. &
+ element_type_index .gt. size(ORBITAL_ELEMENTS)) then
+ ! Error: unsupported orbital elements.
+ error_code = 58
+ return
+ end if
+ element_type = ORBITAL_ELEMENTS(element_type_index)
+
+
+ ! Convert the input observation array into a list of Observations instances.
+ ! Input coordinates (and their uncertainties) are in decimal degrees.
+ ! We need them in radians.
+ call obssFromCoords(track_id, num_coords, coords*rad_deg, mjds, mags, &
+ filters, obscodes, obss, error_code)
+ if(error_code /= 0) then
+ return
+ end if
+
+ ! do j=1,size(obss)
+ ! cov_matrices => getCovarianceMatrices(obss(j))
+ ! nobs = getNrOfObservations(obss(j))
+ ! DO i=1,nobs
+ ! write(*, *) "COV: ", cov_matrices(i,:,:)
+ ! END DO
+ ! end do
+
+ ! Convert the input orbits (which come from the ranging routine) into a
+ ! StochasticOrbit instance.
+ call nullify(in_storb)
+ call rangingOrbitsToStochasticOrbit(in_orbits, &
+ num_orbits, &
+ in_storb, &
+ error_code)
+ if(error_code /= 0) then
+ return
+ end if
+
+
+ ! Now that we have a set of Observations, pass them to the lsl routine.
+ ! obss has already been separated into tracks, pass one track at the time.
+ do j=1,size(obss)
+ call nullify(storb)
+
+ ! Do the LSL thing!
+ call lsl(obs_in=obss(j), &
+ element_type=element_type, &
+ dyn_model=dyn_model, &
+ dyn_model_init=dyn_model_init, &
+ integration_step=integration_step, &
+ integration_step_init=integration_step_init, &
+ perturbers=perturbers, &
+ ls_correction_factor=ls_correction_factor, &
+ ls_element_mask=ls_element_mask, &
+ ls_niter_major_max=ls_niter_major_max, &
+ ls_niter_major_min=ls_niter_major_min, &
+ ls_niter_minor=ls_niter_minor, &
+ outlier_rejection=outlier_rejection, &
+ outlier_multiplier=outlier_multiplier, &
+ accwin_multiplier=accwin_multiplier, &
+ inStochOrbit=in_storb, &
+ outStochOrbit=storb, &
+ errorCode=error_code)
+ if(error_code /= 0) then
+ return
+ end if
+
+ ! Now flatten the lsl orbit.
+ call exportLslOrbit(storb, element_type, track_id, out_orbit, &
+ out_covariance, out_sigmas, out_correlation, &
+ error_code)
+ call nullify(storb)
+ if(error_code /= 0) then
+ return
+ end if
+ end do
+ deallocate(perturbers)
+end subroutine oorb_lsl_fast
+
+
+
+subroutine oorb_lsl(obscodes, &
+ filters, &
+ track_id, &
+ num_coords, &
+ coords, &
+ mjds, &
+ mags, &
+ in_orbits, &
+ num_orbits, &
+ out_orbit, &
+ out_covariance, &
+ out_sigmas, &
+ out_correlation, &
+ error_code)
+ use liboorb
+ use StochasticOrbit_cl
+ ! Orbital inversion using statistical orbital ranging, that is,
+ ! without making any assumptions on the shape of the resulting
+ ! orbital-element pdf.
+
+ ! All angles coming in are in decimal degrees. All times in MJD TAI.
+
+ ! Input/Output variables.
+ ! Observations (i.e. DiASources) to be used as input. It is assumed that
+ ! they all belong to the same track.
+ ! We have to use separate arrays since they are of different type.
+ integer, intent(in) :: track_id
+ integer, intent(in) :: num_coords
+ real(8), dimension(num_coords), intent(in) :: mjds
+ real(8), dimension(num_coords, 4), intent(in) :: coords
+ real(8), dimension(num_coords), intent(in) :: mags
+ ! FIXME: f2py bug that only passes the first char of element of an array of
+ ! strings.
+ character(len=1), dimension(num_coords), intent(in) :: filters
+ ! FIXME: f2py bug that only passes the first char of element of an array of
+ ! strings.
+ character(len=4), dimension(num_coords), intent(in) :: obscodes
+ integer, intent(in) :: num_orbits
+ ! Input flattened orbits.
+ ! in_orbits has the form ((id, elements(1:6), epoch, Un-normalized p.d.f.,
+ ! Reduced chi2, Regularized apr, Jacobian det(1:3), el_type_index), )
+ real(8),dimension(num_orbits,15),intent(in) :: in_orbits
+ ! Output flattened orbit:
+ ! (track_id, elements(1:6), epoch, H, G, el_type_index)
+ ! FIXME: H and G are not currently computed.
+ real(8),dimension(11), intent(out) :: out_orbit
+ ! Uncertainty matrices:
+ REAL(8), DIMENSION(6,6), intent(out) :: out_covariance
+ REAL(8), DIMENSION(6), intent(out) :: out_sigmas
+ REAL(8), DIMENSION(6,6), intent(out) :: out_correlation
+ ! Output error code
+ integer, intent(out) :: error_code
+
+ ! Internal variables.
+ character(len=6) :: dyn_model
+ character(len=6) :: dyn_model_init
+ real(8) :: integration_step
+ real(8) :: integration_step_init
+ real(8) :: ls_correction_factor
+ LOGICAL, DIMENSION(6) :: ls_element_mask
+ integer :: ls_niter_major_max
+ integer :: ls_niter_major_min
+ integer :: ls_niter_minor
+ logical :: outlier_rejection
+ real(8) :: outlier_multiplier
+ real(8) :: accwin_multiplier
+ LOGICAL, DIMENSION(:), pointer :: perturbers
+ TYPE (Observations), DIMENSION(:), POINTER :: obss
+ TYPE (StochasticOrbit) :: storb
+ TYPE (StochasticOrbit) :: in_storb
+ integer :: j
+ character(len=11) :: element_type
+ integer :: element_type_index
+
+
+
+
+ ! do j=1,num_coords
+ ! write(*, *) "obscodes(", j, ") ", obscodes(j)
+ ! end do
+ ! do j=1,num_coords
+ ! write(*, *) "filters(", j, ") ", filters(j)
+ ! end do
+ ! write(*, *) "track_id ", track_id
+ ! write(*, *) "num_coords ", num_coords
+ ! do j=1,num_coords
+ ! write(*, *) "coords(", j, ") ", coords(j,:)
+ ! end do
+ ! write(*, *) "mjds ", mjds
+ ! write(*, *) "mags ", mags
+ ! write(*, *) "num_orbits ", num_orbits
+
+ ! Init variables (from OpenOrb config file and best practices).
+ error_code = 0
+ dyn_model = "n-body"
+ dyn_model_init = "2-body"
+ integration_step = 5.0_8
+ integration_step_init = 5.0_8
+ ls_correction_factor = 0.2_8
+ ls_element_mask = .true.
+ ls_niter_major_max = 20
+ ls_niter_major_min = 2
+ ls_niter_minor = 10
+ outlier_rejection = .false.
+ outlier_multiplier = 3.0_8
+ accwin_multiplier = 3.0_8
+
+ ! Quick sanity check.
+ if(size(in_orbits) .le. 0) then
+ ! Nothing to do.
+ return
+ end if
+
+ allocate(perturbers(10), stat=error_code)
+ if(error_code /= 0) then
+ ! Error in allocating memory!
+ error_code = 57
+ return
+ end if
+ perturbers = .true.
+
+ ! Get the element type from the input flattened orbits (the are supposed to
+ ! be all the same).
+ element_type_index = in_orbits(1, 15)
+ if(element_type_index .le. 0 .or. &
+ element_type_index .gt. size(ORBITAL_ELEMENTS)) then
+ ! Error: unsupported orbital elements.
+ error_code = 58
+ return
+ end if
+ element_type = ORBITAL_ELEMENTS(element_type_index)
+
+
+ ! Convert the input observation array into a list of Observations instances.
+ ! Input coordinates (and their uncertainties) are in decimal degrees.
+ ! We need them in radians.
+ call obssFromCoords(track_id, num_coords, coords*rad_deg, mjds, mags, &
+ filters, obscodes, obss, error_code)
+ if(error_code /= 0) then
+ return
+ end if
+
+ ! do j=1,size(obss)
+ ! cov_matrices => getCovarianceMatrices(obss(j))
+ ! nobs = getNrOfObservations(obss(j))
+ ! DO i=1,nobs
+ ! write(*, *) "COV: ", cov_matrices(i,:,:)
+ ! END DO
+ ! end do
+
+ ! Convert the input orbits (which come from the ranging routine) into a
+ ! StochasticOrbit instance.
+ call nullify(in_storb)
+ call rangingOrbitsToStochasticOrbit(in_orbits, &
+ num_orbits, &
+ in_storb, &
+ error_code)
+ if(error_code /= 0) then
+ return
+ end if
+
+
+ ! Now that we have a set of Observations, pass them to the lsl routine.
+ ! obss has already been separated into tracks, pass one track at the time.
+ do j=1,size(obss)
+ call nullify(storb)
+
+ ! Do the LSL thing!
+ call lsl(obs_in=obss(j), &
+ element_type=element_type, &
+ dyn_model=dyn_model, &
+ dyn_model_init=dyn_model_init, &
+ integration_step=integration_step, &
+ integration_step_init=integration_step_init, &
+ perturbers=perturbers, &
+ ls_correction_factor=ls_correction_factor, &
+ ls_element_mask=ls_element_mask, &
+ ls_niter_major_max=ls_niter_major_max, &
+ ls_niter_major_min=ls_niter_major_min, &
+ ls_niter_minor=ls_niter_minor, &
+ outlier_rejection=outlier_rejection, &
+ outlier_multiplier=outlier_multiplier, &
+ accwin_multiplier=accwin_multiplier, &
+ inStochOrbit=in_storb, &
+ outStochOrbit=storb, &
+ errorCode=error_code)
+ if(error_code /= 0) then
+ return
+ end if
+
+ ! Now flatten the lsl orbit.
+ call exportLslOrbit(storb, element_type, track_id, out_orbit, &
+ out_covariance, out_sigmas, out_correlation, &
+ error_code)
+ call nullify(storb)
+ if(error_code /= 0) then
+ return
+ end if
+ end do
+ deallocate(perturbers)
+end subroutine oorb_lsl
+
+
+
+subroutine oorb_propagate_orbit_fast(in_orbit, in_covariance, in_mjd, &
+ out_orbit, out_covariance, out_sigmas, &
+ out_correlation, error_code)
+ use liboorb
+ use StochasticOrbit_cl
+
+ ! Input/Output variables.
+ ! Input flattened orbit:
+ ! (track_id, elements(1:6), epoch, H, G, element_type_index)
+ ! FIXME: H and G are not currently computed.
+ real(8),dimension(11), intent(in) :: in_orbit
+ ! Uncertainty matrices:
+ REAL(8), DIMENSION(6,6), intent(in) :: in_covariance
+ ! The epoch (MJD TAI) we want to propagate to.
+ real(8), intent(in) :: in_mjd
+ ! Output flattened orbit:
+ ! (track_id, elements(1:6), epoch, H, G, element_type_index)
+ ! FIXME: H and G are not currently computed.
+ real(8),dimension(11), intent(out) :: out_orbit
+ ! Uncertainty matrices:
+ REAL(8), DIMENSION(6,6), intent(out) :: out_covariance
+ REAL(8), DIMENSION(6), intent(out) :: out_sigmas
+ REAL(8), DIMENSION(6,6), intent(out) :: out_correlation
+ ! Output error code
+ integer, intent(out) :: error_code
+
+ ! Internal variables.
+ TYPE (StochasticOrbit) :: storb
+ character(len=6) :: dyn_model
+ real(8) :: integration_step
+ LOGICAL, DIMENSION(:), pointer :: perturbers
+ integer :: track_id
+ character(len=11) :: element_type
+ integer :: element_type_index
+
+
+ ! Init
+ error_code = 0
+ dyn_model = "2-body"
+ integration_step = 5.0_8
+ allocate(perturbers(10), stat=error_code)
+ if(error_code /= 0) then
+ ! Error in allocating memory!
+ error_code = 57
+ return
+ end if
+ perturbers = .true.
+
+ ! Get the element type from the input flattened orbit.
+ element_type_index = in_orbit(11)
+ if(element_type_index .le. 0 .or. &
+ element_type_index .gt. size(ORBITAL_ELEMENTS)) then
+ ! Error: unsupported orbital elements.
+ error_code = 58
+ return
+ end if
+ element_type = ORBITAL_ELEMENTS(element_type_index)
+
+
+ ! Create a StochastisOrbit instance form the flattened input orbit.
+ call lslOrbitToStochasticOrbit(in_orbit, &
+ in_covariance, &
+ storb, &
+ error_code)
+ if(error_code /= 0) then
+ return
+ end if
+
+ ! Now call the orbit propagation routine.
+ call propagateOrbit(storb, dyn_model, integration_step, perturbers, &
+ in_mjd, error_code)
+ if(error_code /= 0) then
+ return
+ end if
+
+ ! And now re-flatten the StochasticOrbit.
+ track_id = IDINT(in_orbit(1))
+ call exportLslOrbit(storb, element_type, track_id, out_orbit, &
+ out_covariance, out_sigmas, out_correlation, &
+ error_code)
+ if(error_code /= 0) then
+ return
+ end if
+ call nullify(storb)
+ deallocate(perturbers)
+ return
+end subroutine oorb_propagate_orbit_fast
+
+
+
+subroutine oorb_propagate_orbit(in_orbit, in_covariance, in_mjd, out_orbit, &
+ out_covariance, out_sigmas, &
+ out_correlation, error_code)
+ use liboorb
+ use StochasticOrbit_cl
+
+ ! Input/Output variables.
+ ! Input flattened orbit:
+ ! (track_id, elements(1:6), epoch, H, G, element_type_index)
+ ! FIXME: H and G are not currently computed.
+ real(8),dimension(11), intent(in) :: in_orbit
+ ! Uncertainty matrices:
+ REAL(8), DIMENSION(6,6), intent(in) :: in_covariance
+ ! The epoch (MJD TAI) we want to propagate to.
+ real(8), intent(in) :: in_mjd
+ ! Output flattened orbit:
+ ! (track_id, elements(1:6), epoch, H, G, element_type_index)
+ ! FIXME: H and G are not currently computed.
+ real(8),dimension(11), intent(out) :: out_orbit
+ ! Uncertainty matrices:
+ REAL(8), DIMENSION(6,6), intent(out) :: out_covariance
+ REAL(8), DIMENSION(6), intent(out) :: out_sigmas
+ REAL(8), DIMENSION(6,6), intent(out) :: out_correlation
+ ! Output error code
+ integer, intent(out) :: error_code
+
+ ! Internal variables.
+ TYPE (StochasticOrbit) :: storb
+ character(len=6) :: dyn_model
+ real(8) :: integration_step
+ LOGICAL, DIMENSION(:), pointer :: perturbers
+ integer :: track_id
+ character(len=11) :: element_type
+ integer :: element_type_index
+
+
+ ! Init
+ error_code = 0
+ dyn_model = "n-body"
+ integration_step = 5.0_8
+ allocate(perturbers(10), stat=error_code)
+ if(error_code /= 0) then
+ ! Error in allocating memory!
+ error_code = 57
+ return
+ end if
+ perturbers = .true.
+
+ ! Get the element type from the input flattened orbit.
+ element_type_index = in_orbit(11)
+ if(element_type_index .le. 0 .or. &
+ element_type_index .gt. size(ORBITAL_ELEMENTS)) then
+ ! Error: unsupported orbital elements.
+ error_code = 58
+ return
+ end if
+ element_type = ORBITAL_ELEMENTS(element_type_index)
+
+
+ ! Create a StochastisOrbit instance form the flattened input orbit.
+ call lslOrbitToStochasticOrbit(in_orbit, &
+ in_covariance, &
+ storb, &
+ error_code)
+ if(error_code /= 0) then
+ return
+ end if
+
+ ! Now call the orbit propagation routine.
+ call propagateOrbit(storb, dyn_model, integration_step, perturbers, &
+ in_mjd, error_code)
+ if(error_code /= 0) then
+ return
+ end if
+
+ ! And now re-flatten the StochasticOrbit.
+ track_id = IDINT(in_orbit(1))
+ call exportLslOrbit(storb, element_type, track_id, out_orbit, &
+ out_covariance, out_sigmas, out_correlation, &
+ error_code)
+ if(error_code /= 0) then
+ return
+ end if
+ call nullify(storb)
+ deallocate(perturbers)
+ return
+end subroutine oorb_propagate_orbit
+
+
+
+subroutine oorb_ephemeris_fast(in_orbit, &
+ in_covariance, &
+ in_obscode, &
+ in_num_ephems, &
+ in_step, &
+ out_ephems, &
+ error_code)
+ use liboorb
+ use StochasticOrbit_cl
+
+ ! Input/Output variables.
+ ! Input flattened orbit:
+ ! (track_id, elements(1:6), epoch, H, G, element_type_index)
+ ! FIXME: H and G are not currently computed.
+ real(8),dimension(11), intent(in) :: in_orbit
+ ! Uncertainty matrices:
+ REAL(8), DIMENSION(6,6), intent(in) :: in_covariance
+ character(len=4), intent(in) :: in_obscode
+ ! Compute epehemeris from the orbit epoch to epoch+in_step*in_num_ephems
+ ! Number of ephemeris to compute.
+ integer, intent(in) :: in_num_ephems
+ ! Ephemeris step in fractional days.
+ real(8), intent(in) :: in_step
+ ! Output ephemeris
+ ! out_ephems = ((dist, ra, dec, mag, mjd, raErr, decErr, smaa, smia, pa), )
+ real(8), dimension(in_num_ephems,10), intent(out) :: out_ephems
+ ! Output error code
+ integer, intent(out) :: error_code
+
+ ! Internal variables.
+ TYPE (StochasticOrbit) :: storb
+ character(len=6) :: dyn_model
+ real(8) :: integration_step
+ LOGICAL, DIMENSION(:), pointer :: perturbers
+ character(len=11) :: element_type
+ integer :: element_type_index
+ TYPE (SphericalCoordinates), DIMENSION(:,:),POINTER :: ephem_arr
+ REAL(8), DIMENSION(:,:,:), POINTER :: cov_arr
+ REAL(8), DIMENSION(:,:), POINTER :: pdfs_arr
+ TYPE (CartesianCoordinates), DIMENSION(:), POINTER :: observers
+ real(8) :: timespan
+ real(8) :: step
+
+
+ ! Init
+ error_code = 0
+ dyn_model = "2-body"
+ integration_step = 5.0_8
+ allocate(perturbers(10), stat=error_code)
+ if(error_code /= 0) then
+ ! Error in allocating memory!
+ error_code = 57
+ return
+ end if
+ perturbers = .true.
+
+ ! Get the element type from the input flattened orbit.
+ element_type_index = in_orbit(11)
+ if(element_type_index .le. 0 .or. &
+ element_type_index .gt. size(ORBITAL_ELEMENTS)) then
+ ! Error: unsupported orbital elements.
+ error_code = 58
+ return
+ end if
+ element_type = ORBITAL_ELEMENTS(element_type_index)
+
+ ! Compute timespan given step and num_ephems.
+ timespan = in_step * in_num_ephems
+ step = in_step ! Might be modified by the code below.
+
+ ! Create a StochastisOrbit instance form the flattened input orbit.
+ call lslOrbitToStochasticOrbit(in_orbit, &
+ in_covariance, &
+ storb, &
+ error_code)
+ if(error_code /= 0) then
+ return
+ end if
+
+ ! Now call the orbit propagation routine.
+ call ephemeris(storb, &
+ element_type, &
+ dyn_model, &
+ integration_step, &
+ perturbers, &
+ in_obscode, &
+ timespan, &
+ step, &
+ ephem_arr, &
+ cov_arr, &
+ pdfs_arr, &
+ observers, &
+ error_code)
+ if(error_code /= 0) then
+ return
+ end if
+
+ ! Now Export the ephem_arr to a flar array.
+ call exportEphemeris(storb, ephem_arr, cov_arr, observers, out_ephems, &
+ error_code)
+ if(error_code /= 0) then
+ return
+ end if
+
+end subroutine oorb_ephemeris_fast
+
+
+subroutine oorb_ephemeris(in_orbit, &
+ in_covariance, &
+ in_obscode, &
+ in_num_ephems, &
+ in_step, &
+ out_ephems, &
+ error_code)
+ use liboorb
+ use StochasticOrbit_cl
+
+ ! Input/Output variables.
+ ! Input flattened orbit:
+ ! (track_id, elements(1:6), epoch, H, G, element_type_index)
+ ! FIXME: H and G are not currently computed.
+ real(8),dimension(11), intent(in) :: in_orbit
+ ! Uncertainty matrices:
+ REAL(8), DIMENSION(6,6), intent(in) :: in_covariance
+ character(len=4), intent(in) :: in_obscode
+ ! Compute epehemeris from the orbit epoch to epoch+in_step*in_num_ephems
+ ! Number of ephemeris to compute.
+ integer, intent(in) :: in_num_ephems
+ ! Ephemeris step in fractional days.
+ real(8), intent(in) :: in_step
+ ! Output ephemeris
+ ! out_ephems = ((dist, ra, dec, mag, mjd, raErr, decErr, smaa, smia, pa), )
+ real(8), dimension(in_num_ephems,10), intent(out) :: out_ephems
+ ! Output error code
+ integer, intent(out) :: error_code
+
+ ! Internal variables.
+ TYPE (StochasticOrbit) :: storb
+ character(len=6) :: dyn_model
+ real(8) :: integration_step
+ LOGICAL, DIMENSION(:), pointer :: perturbers
+ character(len=11) :: element_type
+ integer :: element_type_index
+ TYPE (SphericalCoordinates), DIMENSION(:,:),POINTER :: ephem_arr
+ REAL(8), DIMENSION(:,:,:), POINTER :: cov_arr
+ REAL(8), DIMENSION(:,:), POINTER :: pdfs_arr
+ TYPE (CartesianCoordinates), DIMENSION(:), POINTER :: observers
+ real(8) :: timespan
+ real(8) :: step
+
+
+ ! Init
+ error_code = 0
+ dyn_model = "n-body"
+ integration_step = 5.0_8
+ allocate(perturbers(10), stat=error_code)
+ if(error_code /= 0) then
+ ! Error in allocating memory!
+ error_code = 57
+ return
+ end if
+ perturbers = .true.
+
+ ! Get the element type from the input flattened orbit.
+ element_type_index = in_orbit(11)
+ if(element_type_index .le. 0 .or. &
+ element_type_index .gt. size(ORBITAL_ELEMENTS)) then
+ ! Error: unsupported orbital elements.
+ error_code = 58
+ return
+ end if
+ element_type = ORBITAL_ELEMENTS(element_type_index)
+
+ ! Compute timespan given step and num_ephems.
+ timespan = in_step * in_num_ephems
+ step = in_step ! Might be modified by the code below.
+
+ ! Create a StochastisOrbit instance form the flattened input orbit.
+ call lslOrbitToStochasticOrbit(in_orbit, &
+ in_covariance, &
+ storb, &
+ error_code)
+ if(error_code /= 0) then
+ return
+ end if
+
+ ! Now call the orbit propagation routine.
+ call ephemeris(storb, &
+ element_type, &
+ dyn_model, &
+ integration_step, &
+ perturbers, &
+ in_obscode, &
+ timespan, &
+ step, &
+ ephem_arr, &
+ cov_arr, &
+ pdfs_arr, &
+ observers, &
+ error_code)
+ if(error_code /= 0) then
+ return
+ end if
+
+ ! Now Export the ephem_arr to a flar array.
+ call exportEphemeris(storb, ephem_arr, cov_arr, observers, out_ephems, &
+ error_code)
+ if(error_code /= 0) then
+ return
+ end if
+
+end subroutine oorb_ephemeris
+
+
+
+subroutine oorb_moid(in_orbit, in_covariance, moid, error_code)
+ use liboorb
+ use StochasticOrbit_cl
+
+ ! Input/Output variables.
+ ! Input flattened orbit:
+ ! (track_id, elements(1:6), epoch, H, G, element_type_index)
+ ! FIXME: H and G are not currently computed.
+ real(8),dimension(11), intent(in) :: in_orbit
+ ! Uncertainty matrices:
+ REAL(8), DIMENSION(6,6), intent(in) :: in_covariance
+ ! Output MOID
+ real(8), intent(out) :: moid
+ ! Output error code
+ integer, intent(out) :: error_code
+
+ ! Internal vars
+ TYPE (StochasticOrbit) :: storb
+ character(len=11) :: element_type
+ integer :: element_type_index
+
+
+ ! Init
+ error_code = 0
+
+ ! Get the element type from the input flattened orbit.
+ element_type_index = in_orbit(11)
+ if(element_type_index .le. 0 .or. &
+ element_type_index .gt. size(ORBITAL_ELEMENTS)) then
+ ! Error: unsupported orbital elements.
+ error_code = 58
+ return
+ end if
+ element_type = ORBITAL_ELEMENTS(element_type_index)
+
+ ! Create a StochastisOrbit instance form the flattened input orbit.
+ call lslOrbitToStochasticOrbit(in_orbit, &
+ in_covariance, &
+ storb, &
+ error_code)
+ if(error_code /= 0) then
+ return
+ end if
+
+ ! Now call the orbit propagation routine.
+ call computeMoid(storb, moid, error_code)
+ if(error_code /= 0) then
+ return
+ end if
+
+end subroutine oorb_moid
+
+
+
+subroutine priv_classification(in_orbits, num_orbits, weights, error_code)
+ use liboorb
+ use StochasticOrbit_cl
+
+ ! Input/Output variables.
+ ! Input flattened orbit:
+ ! (track_id, elements(1:6), epoch, H, G, element_type_index)
+ ! FIXME: H and G are not currently computed.
+ integer, intent(in) :: num_orbits
+ ! Input flattened orbits.
+ ! in_orbits has the form ((id, elements(1:6), epoch, Un-normalized p.d.f.,
+ ! Reduced chi2, Regularized apr, Jacobian det(1:3), el_type_index), )
+ real(8),dimension(num_orbits,15),intent(in) :: in_orbits
+ ! Class names and probability arrays.
+ ! CHARACTER(len=16), DIMENSION(17), intent(out) :: classes
+ REAL(8), DIMENSION(17), intent(out) :: weights
+ ! Output error code
+ integer, intent(out) :: error_code
+
+ ! Internal vars
+ TYPE (StochasticOrbit) :: storb
+ integer :: j = 0
+ REAL(bp), DIMENSION(:), POINTER :: weight_arr
+ CHARACTER(len=16), DIMENSION(:), POINTER :: group_name_arr
+
+
+ ! Init
+ error_code = 0
+
+ ! Create a StochastisOrbit instance form the flattened input orbits.
+ call nullify(storb)
+ call rangingOrbitsToStochasticOrbit(in_orbits, &
+ num_orbits, &
+ storb, &
+ error_code)
+ if(error_code /= 0) then
+ return
+ end if
+
+ ! Now call the orbit propagation routine.
+ call classification(storb, group_name_arr, weight_arr, error_code)
+ if(error_code /= 0) then
+ return
+ end if
+ call nullify(storb)
+
+ ! Copy values from the pointers to the regular arrays.
+ do j=1,min(size(weights), size(weight_arr))
+ ! classes(j) = group_name_arr(j)
+ weights(j) = weight_arr(j)
+ ! write(*, *) "classes(j): ", classes(j)
+ ! write(*, *) "weights(j): ", weights(j)
+ end do
+ deallocate(group_name_arr)
+ deallocate(weight_arr)
+
+end subroutine priv_classification
+
+
+
+subroutine oorb_calendardate_to_mjd(year, month, day, mjd, timescale, &
+ error_code)
+ use liboorb, only: calendarDateToMjd
+
+ ! Input: year, month, fractional days in whatever timescale they are
+ ! (usually UTC or UT1). Output MJD TAI.
+
+ integer, intent(in) :: year
+ integer, intent(in) :: month
+ ! day + time in fractional days.
+ real(8), intent(in) :: day
+ CHARACTER(len=*), intent(in) :: timescale
+ real(8), intent(out) :: mjd
+ integer, intent(out) :: error_code
+
+
+ call calendarDateToMjd(year, month, day, mjd, timescale, error_code)
+
+end subroutine oorb_calendardate_to_mjd
+
+
+
+subroutine oorb_mjdutc_to_mjdtai(mjd_utc, mjd_tai, error_code)
+ use liboorb, only: mjdConvert
+
+ ! Input: MJD UTC
+ ! Output: MJD TAI
+ real(8), intent(in) :: mjd_utc
+ real(8), intent(out) :: mjd_tai
+ integer, intent(out) :: error_code
+
+
+ call mjdConvert(mjd_utc, "UTC", mjd_tai, "TAI", error_code)
+
+end subroutine oorb_mjdutc_to_mjdtai
+
+
+
+subroutine oorb_mjdtai_to_mjdutc(mjd_tai, mjd_utc, error_code)
+ use liboorb, only: mjdConvert
+
+ ! Input: MJD UTC
+ ! Output: MJD TAI
+ real(8), intent(in) :: mjd_tai
+ real(8), intent(out) :: mjd_utc
+ integer, intent(out) :: error_code
+
+
+ call mjdConvert(mjd_tai, "TAI", mjd_utc, "UTC", error_code)
+
+end subroutine oorb_mjdtai_to_mjdutc
+
+
+
+subroutine oorb_mjdtt_to_mjdtai(mjd_tt, mjd_tai, error_code)
+ use liboorb, only: mjdConvert
+
+ ! Input: MJD TT = MJD TAI + 32.184 seconds
+ ! Output: MJD TAI
+ real(8), intent(in) :: mjd_tt
+ real(8), intent(out) :: mjd_tai
+ integer, intent(out) :: error_code
+
+
+ call mjdConvert(mjd_tt, "TT", mjd_tai, "TAI", error_code)
+
+end subroutine oorb_mjdtt_to_mjdtai
+
+
+
+subroutine oorb_mjdtai_to_mjdtt(mjd_tai, mjd_tt, error_code)
+ use liboorb, only: mjdConvert
+
+ ! Input: MJD TAI
+ ! Output: MJD TT = MJD TAI + 32.184 seconds
+ real(8), intent(in) :: mjd_tai
+ real(8), intent(out) :: mjd_tt
+ integer, intent(out) :: error_code
+
+
+ call mjdConvert(mjd_tai, "TAI", mjd_tt, "TT", error_code)
+
+end subroutine oorb_mjdtai_to_mjdtt
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
Index: trunk/mops/oorb/test/K08K42V_lsl.mpc
===================================================================
--- trunk/mops/oorb/test/K08K42V_lsl.mpc (revision 34646)
+++ trunk/mops/oorb/test/K08K42V_lsl.mpc (revision 34646)
@@ -0,0 +1,16 @@
+ K08K42V* C2008 05 31.35234 16 54 34.36 +19 22 53.0 23.7 r EO002568
+ K08K42V C2008 05 31.39302 16 54 34.02 +19 22 54.6 23.7 r EO002568
+ K08K42V C2008 05 31.43442 16 54 33.68 +19 22 56.0 23.8 r EO002568
+ K08K42V C2008 06 08.21175 16 53 30.53 +19 26 59.1 EO002807
+ K08K42V C2008 06 08.25591 16 53 30.18 +19 27 00.6 EO002807
+ K08K42V C2008 06 09.18104 16 53 22.68 +19 27 24.4 EO002807
+ K08K42V C2008 06 23.36633 16 51 29.67 +19 31 06.1 EO002696
+ K08K42V C2008 06 23.41398 16 51 29.31 +19 31 06.2 EO002696
+ K08K42V C2008 06 24.35315 16 51 22.08 +19 31 11.5 EO002696
+ K08K42V C2008 06 24.40592 16 51 21.67 +19 31 11.8 EO002696
+ K08K42V C2008 07 08.12345 16 49 41.23 +19 30 25.7 EO002807
+ K08K42V C2008 07 08.13106 16 49 41.18 +19 30 25.6 EO002807
+ K08K42V C2008 07 08.14480 16 49 41.10 +19 30 25.4 EO002807
+ K08K42V C2008 07 08.14961 16 49 41.06 +19 30 25.4 EO002807
+ K08K42V C2008 07 08.15439 16 49 41.02 +19 30 25.3 EO002807
+
Index: trunk/mops/oorb/test/K08K42V_ranging.mpc
===================================================================
--- trunk/mops/oorb/test/K08K42V_ranging.mpc (revision 34646)
+++ trunk/mops/oorb/test/K08K42V_ranging.mpc (revision 34646)
@@ -0,0 +1,16 @@
+ K08K42V* C2008 05 31.35234 16 54 34.36 +19 22 53.0 23.7 r EO002568
+ K08K42V C2008 05 31.39302 16 54 34.02 +19 22 54.6 23.7 r EO002568
+ K08K42V C2008 05 31.43442 16 54 33.68 +19 22 56.0 23.8 r EO002568
+# K08K42V C2008 06 08.21175 16 53 30.53 +19 26 59.1 EO002807
+# K08K42V C2008 06 08.25591 16 53 30.18 +19 27 00.6 EO002807
+# K08K42V C2008 06 09.18104 16 53 22.68 +19 27 24.4 EO002807
+# K08K42V C2008 06 23.36633 16 51 29.67 +19 31 06.1 EO002696
+# K08K42V C2008 06 23.41398 16 51 29.31 +19 31 06.2 EO002696
+# K08K42V C2008 06 24.35315 16 51 22.08 +19 31 11.5 EO002696
+# K08K42V C2008 06 24.40592 16 51 21.67 +19 31 11.8 EO002696
+# K08K42V C2008 07 08.12345 16 49 41.23 +19 30 25.7 EO002807
+# K08K42V C2008 07 08.13106 16 49 41.18 +19 30 25.6 EO002807
+# K08K42V C2008 07 08.14480 16 49 41.10 +19 30 25.4 EO002807
+# K08K42V C2008 07 08.14961 16 49 41.06 +19 30 25.4 EO002807
+# K08K42V C2008 07 08.15439 16 49 41.02 +19 30 25.3 EO002807
+