*DECK DQAWO
      SUBROUTINE DQAWO (F, A, B, OMEGA, INTEGR, EPSABS, EPSREL, RESULT,
     +   ABSERR, NEVAL, IER, LENIW, MAXP1, LENW, LAST, IWORK, WORK)
C***BEGIN PROLOGUE  DQAWO
C***PURPOSE  Calculate an approximation to a given definite integral
C            I= Integral of F(X)*W(X) over (A,B), where
C                   W(X) = COS(OMEGA*X)
C               or  W(X) = SIN(OMEGA*X),
C            hopefully satisfying the following claim for accuracy
C                ABS(I-RESULT).LE.MAX(EPSABS,EPSREL*ABS(I)).
C***LIBRARY   SLATEC (QUADPACK)
C***CATEGORY  H2A2A1
C***TYPE      DOUBLE PRECISION (QAWO-S, DQAWO-D)
C***KEYWORDS  AUTOMATIC INTEGRATOR, CLENSHAW-CURTIS METHOD,
C             EXTRAPOLATION, GLOBALLY ADAPTIVE,
C             INTEGRAND WITH OSCILLATORY COS OR SIN FACTOR, QUADPACK,
C             QUADRATURE, SPECIAL-PURPOSE
C***AUTHOR  Piessens, Robert
C             Applied Mathematics and Programming Division
C             K. U. Leuven
C           de Doncker, Elise
C             Applied Mathematics and Programming Division
C             K. U. Leuven
C***DESCRIPTION
C
C        Computation of oscillatory integrals
C        Standard fortran subroutine
C        Double precision version
C
C        PARAMETERS
C         ON ENTRY
C            F      - Double precision
C                     Function subprogram defining the function
C                     F(X).  The actual name for F needs to be
C                     declared E X T E R N A L in the driver program.
C
C            A      - Double precision
C                     Lower limit of integration
C
C            B      - Double precision
C                     Upper limit of integration
C
C            OMEGA  - Double precision
C                     Parameter in the integrand weight function
C
C            INTEGR - Integer
C                     Indicates which of the weight functions is used
C                     INTEGR = 1      W(X) = COS(OMEGA*X)
C                     INTEGR = 2      W(X) = SIN(OMEGA*X)
C                     If INTEGR.NE.1.AND.INTEGR.NE.2, the routine will
C                     end with IER = 6.
C
C            EPSABS - Double precision
C                     Absolute accuracy requested
C            EPSREL - Double precision
C                     Relative accuracy requested
C                     If EPSABS.LE.0 and
C                     EPSREL.LT.MAX(50*REL.MACH.ACC.,0.5D-28),
C                     the routine will end with IER = 6.
C
C         ON RETURN
C            RESULT - Double precision
C                     Approximation to the integral
C
C            ABSERR - Double precision
C                     Estimate of the modulus of the absolute error,
C                     which should equal or exceed ABS(I-RESULT)
C
C            NEVAL  - Integer
C                     Number of integrand evaluations
C
C            IER    - Integer
C                     IER = 0 Normal and reliable termination of the
C                             routine. It is assumed that the requested
C                             accuracy has been achieved.
C                   - IER.GT.0 Abnormal termination of the routine.
C                             The estimates for integral and error are
C                             less reliable. It is assumed that the
C                             requested accuracy has not been achieved.
C            ERROR MESSAGES
C                     IER = 1 Maximum number of subdivisions allowed
C                             has been achieved (= LENIW/2). One can
C                             allow more subdivisions by increasing the
C                             value of LENIW (and taking the according
C                             dimension adjustments into account).
C                             However, if this yields no improvement it
C                             is advised to analyze the integrand in
C                             order to determine the integration
C                             difficulties. If the position of a local
C                             difficulty can be determined (e.g.
C                             SINGULARITY, DISCONTINUITY within the
C                             interval) one will probably gain from
C                             splitting up the interval at this point
C                             and calling the integrator on the
C                             subranges. If possible, an appropriate
C                             special-purpose integrator should be used
C                             which is designed for handling the type of
C                             difficulty involved.
C                         = 2 The occurrence of roundoff error is
C                             detected, which prevents the requested
C                             tolerance from being achieved.
C                             The error may be under-estimated.
C                         = 3 Extremely bad integrand behaviour occurs
C                             at some interior points of the
C                             integration interval.
C                         = 4 The algorithm does not converge.
C                             Roundoff error is detected in the
C                             extrapolation table. It is presumed that
C                             the requested tolerance cannot be achieved
C                             due to roundoff in the extrapolation
C                             table, and that the returned result is
C                             the best which can be obtained.
C                         = 5 The integral is probably divergent, or
C                             slowly convergent. It must be noted that
C                             divergence can occur with any other value
C                             of IER.
C                         = 6 The input is invalid, because
C                             (EPSABS.LE.0 and
C                              EPSREL.LT.MAX(50*REL.MACH.ACC.,0.5D-28))
C                             or (INTEGR.NE.1 AND INTEGR.NE.2),
C                             or LENIW.LT.2 OR MAXP1.LT.1 or
C                             LENW.LT.LENIW*2+MAXP1*25.
C                             RESULT, ABSERR, NEVAL, LAST are set to
C                             zero. Except when LENIW, MAXP1 or LENW are
C                             invalid, WORK(LIMIT*2+1), WORK(LIMIT*3+1),
C                             IWORK(1), IWORK(LIMIT+1) are set to zero,
C                             WORK(1) is set to A and WORK(LIMIT+1) to
C                             B.
C
C         DIMENSIONING PARAMETERS
C            LENIW  - Integer
C                     Dimensioning parameter for IWORK.
C                     LENIW/2 equals the maximum number of subintervals
C                     allowed in the partition of the given integration
C                     interval (A,B), LENIW.GE.2.
C                     If LENIW.LT.2, the routine will end with IER = 6.
C
C            MAXP1  - Integer
C                     Gives an upper bound on the number of Chebyshev
C                     moments which can be stored, i.e. for the
C                     intervals of lengths ABS(B-A)*2**(-L),
C                     L=0,1, ..., MAXP1-2, MAXP1.GE.1
C                     If MAXP1.LT.1, the routine will end with IER = 6.
C
C            LENW   - Integer
C                     Dimensioning parameter for WORK
C                     LENW must be at least LENIW*2+MAXP1*25.
C                     If LENW.LT.(LENIW*2+MAXP1*25), the routine will
C                     end with IER = 6.
C
C            LAST   - Integer
C                     On return, LAST equals the number of subintervals
C                     produced in the subdivision process, which
C                     determines the number of significant elements
C                     actually in the WORK ARRAYS.
C
C         WORK ARRAYS
C            IWORK  - Integer
C                     Vector of dimension at least LENIW
C                     on return, the first K elements of which contain
C                     pointers to the error estimates over the
C                     subintervals, such that WORK(LIMIT*3+IWORK(1)), ..
C                     WORK(LIMIT*3+IWORK(K)) form a decreasing
C                     sequence, with LIMIT = LENW/2 , and K = LAST
C                     if LAST.LE.(LIMIT/2+2), and K = LIMIT+1-LAST
C                     otherwise.
C                     Furthermore, IWORK(LIMIT+1), ..., IWORK(LIMIT+
C                     LAST) indicate the subdivision levels of the
C                     subintervals, such that IWORK(LIMIT+I) = L means
C                     that the subinterval numbered I is of length
C                     ABS(B-A)*2**(1-L).
C
C            WORK   - Double precision
C                     Vector of dimension at least LENW
C                     On return
C                     WORK(1), ..., WORK(LAST) contain the left
C                      end points of the subintervals in the
C                      partition of (A,B),
C                     WORK(LIMIT+1), ..., WORK(LIMIT+LAST) contain
C                      the right end points,
C                     WORK(LIMIT*2+1), ..., WORK(LIMIT*2+LAST) contain
C                      the integral approximations over the
C                      subintervals,
C                     WORK(LIMIT*3+1), ..., WORK(LIMIT*3+LAST)
C                      contain the error estimates.
C                     WORK(LIMIT*4+1), ..., WORK(LIMIT*4+MAXP1*25)
C                      Provide space for storing the Chebyshev moments.
C                     Note that LIMIT = LENW/2.
C
C***REFERENCES  (NONE)
C***ROUTINES CALLED  DQAWOE, XERMSG
C***REVISION HISTORY  (YYMMDD)
C   800101  DATE WRITTEN
C   890831  Modified array declarations.  (WRB)
C   890831  REVISION DATE from Version 3.2
C   891214  Prologue converted to Version 4.0 format.  (BAB)
C   900315  CALLs to XERROR changed to CALLs to XERMSG.  (THJ)
C***END PROLOGUE  DQAWO
C
       DOUBLE PRECISION A,ABSERR,B,EPSABS,EPSREL,F,OMEGA,RESULT,WORK
       INTEGER IER,INTEGR,IWORK,LAST,LIMIT,LENW,LENIW,LVL,L1,L2,L3,L4,
     1  MAXP1,MOMCOM,NEVAL
C
       DIMENSION IWORK(*),WORK(*)
C
       EXTERNAL F
C
C         CHECK VALIDITY OF LENIW, MAXP1 AND LENW.
C
C***FIRST EXECUTABLE STATEMENT  DQAWO
      IER = 6
      NEVAL = 0
      LAST = 0
      RESULT = 0.0D+00
      ABSERR = 0.0D+00
      IF(LENIW.LT.2.OR.MAXP1.LT.1.OR.LENW.LT.(LENIW*2+MAXP1*25))
     1  GO TO 10
C
C         PREPARE CALL FOR DQAWOE
C
      LIMIT = LENIW/2
      L1 = LIMIT+1
      L2 = LIMIT+L1
      L3 = LIMIT+L2
      L4 = LIMIT+L3
      CALL DQAWOE(F,A,B,OMEGA,INTEGR,EPSABS,EPSREL,LIMIT,1,MAXP1,RESULT,
     1   ABSERR,NEVAL,IER,LAST,WORK(1),WORK(L1),WORK(L2),WORK(L3),
     2   IWORK(1),IWORK(L1),MOMCOM,WORK(L4))
C
C         CALL ERROR HANDLER IF NECESSARY
C
      LVL = 0
10    IF(IER.EQ.6) LVL = 0
      IF (IER .NE. 0) CALL XERMSG ('SLATEC', 'DQAWO',
     +   'ABNORMAL RETURN', IER, LVL)
      RETURN
      END


      FUNCTION zriddr(func,x1,x2,xacc)
      INTEGER MAXIT
      REAL zriddr,x1,x2,xacc,func,UNUSED
      PARAMETER (MAXIT=60,UNUSED=-1.11E30)
      EXTERNAL func
CU    USES func
      INTEGER j
      REAL fh,fl,fm,fnew,s,xh,xl,xm,xnew
      fl=func(x1)
      fh=func(x2)
      if((fl.gt.0..and.fh.lt.0.).or.(fl.lt.0..and.fh.gt.0.))then
        xl=x1
        xh=x2
        zriddr=UNUSED
        do 11 j=1,MAXIT
          xm=0.5*(xl+xh)
          fm=func(xm)
          s=sqrt(fm**2-fl*fh)
          if(s.eq.0.)return
          xnew=xm+(xm-xl)*(sign(1.,fl-fh)*fm/s)
          if (abs(xnew-zriddr).le.xacc) return
          zriddr=xnew
          fnew=func(zriddr)
          if (fnew.eq.0.) return
          if(sign(fm,fnew).ne.fm) then
            xl=xm
            fl=fm
            xh=zriddr
            fh=fnew
          else if(sign(fl,fnew).ne.fl) then
            xh=zriddr
            fh=fnew
          else if(sign(fh,fnew).ne.fh) then
            xl=zriddr
            fl=fnew
          else
            pause 'never get here in zriddr'
          endif
          if(abs(xh-xl).le.xacc) return
11      continue
        pause 'zriddr exceed maximum iterations'
      else if (fl.eq.0.) then
        zriddr=x1
      else if (fh.eq.0.) then
        zriddr=x2
      else
        pause 'root must be bracketed in zriddr'
      endif
      return
      END

NR-Functions/Numerical Recipes- Example & Functions/Functions/zriddr.for


program solution
    integer :: result1,noun,verb
    call work(12,2,result1)
    print *, 'part 1 result: ',result1
    fidlar: do noun = 0, 100
        do verb = 0, 100
            call work(noun,verb,result1)

            if (result1 == 19690720) then
                print *, 'part 2 result:', (100*noun + verb)
                exit fidlar
            end if
        end do
    end do fidlar

end program solution

subroutine work(noun,verb,result)
    integer, dimension(165) :: input
    integer :: desitionation, noun, verb, result

    ! https://stackoverflow.com/questions/34194589/line-truncated-syntax-error-in-argument-list
    input = (/ 1,0,0,3,&
    1,1,2,3&
    ,1,3,4,3,1,5,0,3,2,1,10,19,1,9,19,23,1,13,23,27,1,5,&
    27,31,2,31,6,35,1,35,5,39,1,9,39,43,1,43,5,47,1,47,5,51,2,10,51,55,1,5,55,59,&
    1,59,5,63,2,63,9,67,1,67,5,71,2,9,71,75,1,75,5,79,1,10,79,83,1,83,10,87,1,10,&
    87,91,1,6,91,95,2,95,6,99,2,99,9,103,1,103,6,107,1,13,107,111,1,13,111,115,2,&
    115,9,119,1,119,6,123,2,9,123,127,1,127,5,131,1,131,5,135,1,135,5,139,2,10,&
    139,143,2,143,10,147,1,147,5,151,1,151,2,155,1,155,13,0,99,2,14,0,0 /)
    input(2) = noun
    input(3) = verb

    loop: do index=1,size(input) ,4

        command = input(index)
        a = input(input(index+1)+1)
        b = input(input(index+2)+1)
        desitionation = input(index+3)+1
        if (command == 99) then
            exit loop ! labelled loop breaks supper cool. eat poopies typescript
        else if (command == 1) then
            input(desitionation) = int(a + b)
        else if (command == 2) then
            input(desitionation) = int(a * b)
        else
            Print *, 'shit'
        end if
    end do loop
    result = input(1)
end subroutine work


      SUBROUTINE slDCMF (COEFFS,XZ,YZ,XS,YS,PERP,ORIENT)
*+
*     - - - - - -
*      D C M F
*     - - - - - -
*
*  Decompose an [X,Y] linear fit into its constituent parameters:
*  zero points, scales, nonperpendicularity and orientation.
*
*  Given:
*     COEFFS  d(6)      transformation coefficients (see note)
*
*  Returned:
*     XZ       d        x zero point
*     YZ       d        y zero point
*     XS       d        x scale
*     YS       d        y scale
*     PERP     d        nonperpendicularity (radians)
*     ORIENT   d        orientation (radians)
*
*  Called:  slDA1P
*
*  The model relates two sets of [X,Y] coordinates as follows.
*  Naming the elements of COEFFS:
*
*     COEFFS(1) = A
*     COEFFS(2) = B
*     COEFFS(3) = C
*     COEFFS(4) = D
*     COEFFS(5) = E
*     COEFFS(6) = F
*
*  the model transforms coordinates [X1,Y1] into coordinates
*  [X2,Y2] as follows:
*
*     X2 = A + B*X1 + C*Y1
*     Y2 = D + E*X1 + F*Y1
*
*  The transformation can be decomposed into four steps:
*
*     1)  Zero points:
*
*             x' = XZ + X1
*             y' = YZ + Y1
*
*     2)  Scales:
*
*             x'' = XS*x'
*             y'' = YS*y'
*
*     3)  Nonperpendicularity:
*
*             x''' = cos(PERP/2)*x'' + sin(PERP/2)*y''
*             y''' = sin(PERP/2)*x'' + cos(PERP/2)*y''
*
*     4)  Orientation:
*
*             X2 = cos(ORIENT)*x''' + sin(ORIENT)*y'''
*             Y2 =-sin(ORIENT)*y''' + cos(ORIENT)*y'''
*
*  See also slFTXY, slPXY, slINVF, slXYXY
*
*  P.T.Wallace   Starlink   19 December 2001
*
*  Copyright (C) 2001 Rutherford Appleton Laboratory
*
*  License:
*    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 2 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 GNU General Public License
*    along with this program (see SLA_CONDITIONS); if not, write to the
*    Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
*    Boston, MA  02110-1301  USA
*
*  Copyright (C) 1995 Association of Universities for Research in Astronomy Inc.
*-

      IMPLICIT NONE

      DOUBLE PRECISION COEFFS(6),XZ,YZ,XS,YS,PERP,ORIENT

      DOUBLE PRECISION A,B,C,D,E,F,RB2E2,RC2F2,XSC,YSC,P1,P2,P,WS,WC,
     :                 OR,HP,SHP,CHP,SOR,COR,DET,X0,Y0,slDA1P

*  Copy the six coefficients.
      A = COEFFS(1)
      B = COEFFS(2)
      C = COEFFS(3)
      D = COEFFS(4)
      E = COEFFS(5)
      F = COEFFS(6)

*  Scales.
      RB2E2 = SQRT(B*B+E*E)
      RC2F2 = SQRT(C*C+F*F)
      IF (B*F-C*E.GE.0D0) THEN
         XSC = RB2E2
      ELSE
         B = -B
         E = -E
         XSC = -RB2E2
      END IF
      YSC = RC2F2

*  Non-perpendicularity.
      IF (C.NE.0D0.OR.F.NE.0D0) THEN
         P1 = ATAN2(C,F)
      ELSE
         P1 = 0D0
      END IF
      IF (E.NE.0D0.OR.B.NE.0D0) THEN
         P2 = ATAN2(E,B)
      ELSE
         P2 = 0D0
      END IF
      P = slDA1P(P1+P2)

*  Orientation.
      WS = C*RB2E2-E*RC2F2
      WC = B*RC2F2+F*RB2E2
      IF (WS.NE.0D0.OR.WC.NE.0D0) THEN
         OR = ATAN2(WS,WC)
      ELSE
         OR = 0D0
      END IF

*  Zero points.
      HP = P/2D0
      SHP = SIN(HP)
      CHP = COS(HP)
      SOR = SIN(OR)
      COR = COS(OR)
      DET = XSC*YSC*(CHP+SHP)*(CHP-SHP)
      IF (ABS(DET).GT.0D0) THEN
         X0 = YSC*(A*(CHP*COR-SHP*SOR)-D*(CHP*SOR+SHP*COR))/DET
         Y0 = XSC*(A*(CHP*SOR-SHP*COR)+D*(CHP*COR+SHP*SOR))/DET
      ELSE
         X0 = 0D0
         Y0 = 0D0
      END IF

*  Results.
      XZ = X0
      YZ = Y0
      XS = XSC
      YS = YSC
      PERP = P
      ORIENT = OR

      END


 SUBROUTINE CGELSX_F95( A, B, RANK, JPVT, RCOND, INFO )
!
!  -- LAPACK95 interface driver routine (version 3.0) --
!     UNI-C, Denmark; Univ. of Tennessee, USA; NAG Ltd., UK
!     September, 2000
!
!   .. USE STATEMENTS ..
    USE LA_PRECISION, ONLY: WP => SP
    USE LA_AUXMOD, ONLY: ERINFO
    USE F77_LAPACK, ONLY: GELSX_F77 => LA_GELSX
!   .. IMPLICIT STATEMENT ..
    IMPLICIT NONE
!   .. SCALAR ARGUMENTS ..
    INTEGER, INTENT(OUT), OPTIONAL :: RANK
    INTEGER, INTENT(OUT), OPTIONAL :: INFO
    REAL(WP), INTENT(IN), OPTIONAL :: RCOND
!   .. ARRAY ARGUMENTS ..
    INTEGER, INTENT(INOUT), OPTIONAL, TARGET :: JPVT(:)
    COMPLEX(WP), INTENT(INOUT) :: A(:,:), B(:,:)
!-----------------------------------------------------------------
!
! Purpose
! =======
!
! LA_GELSX computes the minimum-norm solution to a real linear least
! squares problem:
!     minimize || A * X - B ||
! using a complete orthogonal factorization of A.  A is an m-by-n
! matrix which may be rank-deficient.
! Several right hand side vectors b and solution vectors x can be
! handled in a single call; they are stored as the columns of the
! M-by-NRHS right hand side matrix B and the n-by-nrhs solution
! matrix X.
! The routine first computes a QR factorization with column pivoting:
!     A * P = Q * [ R11 R12 ]
!                 [  0  R22 ]
! with R11 defined as the largest leading submatrix whose estimated
! condition number is less than 1/RCOND.  The order of R11, RANK,
! is the effective rank of A.
! Then, R22 is considered to be negligible, and R12 is annihilated
! by orthogonal transformations from the right, arriving at the
! complete orthogonal factorization:
!    A * P = Q * [ T11 0 ] * Z
!                [  0  0 ]
! The minimum-norm solution is then
!    X = P * Z' [ inv(T11)*Q1'*B ]
!               [        0       ]
! where Q1 consists of the first RANK columns of Q.
!
!
! Arguments
! =========
!
!  SUBROUTINE LA_GELSX( A, B, RANK, JPVT, RCOND, INFO )
!    <type>(<wp>), INTENT( INOUT ) :: A( :, : ), <rhs>
!    INTEGER, INTENT(IN), OPTIONAL :: RANK
!    INTEGER, INTENT(OUT), OPTIONAL :: JPVT(:)
!    REAL(<wp>), INTENT(IN), OPTIONAL :: RCOND
!    INTEGER, INTENT(OUT), OPTIONAL :: INFO
!    <type> ::= REAL | COMPLEX
!    <wp>   ::= KIND(1.0) | KIND(1.0D0)
!    <rhs>  ::= B(:,:) | B(:)
!
! =====================
!
! A    (input/output) Deither REAL or COMPLEX array, shape (:,:),
!      SIZE(A,1) == m, SIZE(A,2) == n.
!      On entry, the m-by-n matrix A.
!      On exit, A has been overwritten by details of its
!      complete orthogonal factorization.
!      INFO = -1 if SIZE(A,1) < 0 or SIZE(A,2) < 0
!
! B    Optional (input/output) either REAL or COMPLEX array, shape either
!      (:,:) or (:), size(B,1) or size(B) == size(A,1). SIZE(B,2) == nrhs.
!      On entry, the m-by-nrhs right hand side matrix B.
!      On exit, the n-by-nrhs solution matrix X.
!      If m >= n and RANK = n, the residual sum-of-squares for
!      the solution in the i-th column is given by the sum of
!      squares of elements n+1:m in that column.
!      INFO = -2 if SIZE(B,1) /= max(SIZE(A,1), SIZE(A,2)) or SIZE(B,2) < 0
!                    and if shape of B is (:,:) or
!                if SIZE(B) /= max(SIZE(A,1), SIZE(A,2)) or SIZE(B,2) < 0
!                   and if shape of B is (:)
!
! RANK Optional (output) INTEGER
!      The effective rank of A, i.e., the order of the submatrix
!      R11.  This is the same as the order of the submatrix T11
!      in the complete orthogonal factorization of A.
!
! JPVT Optional (input/output) INTEGER array, shape (:), SIZE(JPVT) == n
!      On entry, if JPVT(i) .ne. 0, the i-th column of A is an
!      initial column, otherwise it is a free column.  Before
!      the QR factorization of A, all initial columns are
!      permuted to the leading positions; only the remaining
!      free columns are moved as a result of column pivoting
!      during the factorization.
!      On exit, if JPVT(i) = k, then the i-th column of A*P
!      was the k-th column of A.
!      INFO = -4 if SIZE(S) /= SIZE(A,2)
!
! RCOND Optional (input) REAL
!      RCOND is used to determine the effective rank of A, which
!      is defined as the order of the largest leading triangular
!      submatrix R11 in the QR factorization with pivoting of A,
!      whose estimated condition number < 1/RCOND.
!
! INFO    (output) INTEGER
!      = 0:  successful exit
!      < 0:  if INFO = -i, the i-th argument had an illegal value
!      If INFO is not present and an error occurs, then the program is
!         terminated with an error message.
!--------------------------------------
!   .. PARAMETERS ..
    CHARACTER(LEN=8), PARAMETER :: SRNAME = 'LA_GELSX'
!   .. LOCAL SCALARS ..
    INTEGER :: LINFO, ISTAT, ISTAT1, LWORK, N, M, MN, NRHS, LRANK, SJPVT
    REAL(WP) :: LRCOND
!   .. LOCAL POINTERS ..
    INTEGER, POINTER :: LJPVT(:)
    COMPLEX(WP), POINTER :: WORK(:)
    REAL(WP), POINTER :: RWORK(:)
!   .. INTRINSIC FUNCTIONS ..
    INTRINSIC SIZE, PRESENT, MAX, MIN, EPSILON
!   .. EXECUTABLE STATEMENTS ..
    LINFO = 0; ISTAT = 0; M = SIZE(A,1); N = SIZE(A,2); NRHS = SIZE(B,2)
    MN = MIN(M,N)
    IF( PRESENT(RCOND) )THEN; LRCOND = RCOND; ELSE
       LRCOND = 100*EPSILON(1.0_WP) ; ENDIF
    IF( PRESENT(JPVT) )THEN; SJPVT = SIZE(JPVT); ELSE; SJPVT = N; ENDIF
!   .. TEST THE ARGUMENTS
    IF( M < 0 .OR. N < 0 ) THEN; LINFO = -1
    ELSE IF( SIZE( B, 1 ) /= MAX(1,M,N) .OR. NRHS < 0 ) THEN; LINFO = -2
    ELSE IF( SJPVT /= N ) THEN; LINFO = -4
    ELSE IF( LRCOND <= 0.0_WP ) THEN; LINFO = -5
    ELSE
        IF( PRESENT(JPVT) )THEN; LJPVT => JPVT
       ELSE
         ALLOCATE( LJPVT(N), STAT = ISTAT )
         IF( ISTAT /= 0 ) THEN; LINFO = -200; GOTO 100; END IF
         LJPVT = 0
       END IF
       LWORK = 2*MAX( 1, MIN(M,N) + MAX( N,2*MIN(M,N) + NRHS ) )
       ALLOCATE( WORK(LWORK), STAT = ISTAT )
       IF( ISTAT /= 0 ) THEN; LINFO = -200; GOTO 200; END IF
       ALLOCATE( RWORK(MAX(1,2*N)), STAT = ISTAT )
       IF( ISTAT /= 0 ) THEN; LINFO = -200; GOTO 300; END IF

       CALL GELSX_F77( M, N, NRHS, A, MAX(1,M), B, MAX(1,M,N), &
                      LJPVT, LRCOND, LRANK, WORK, RWORK, LINFO )

       IF( PRESENT(RANK) ) RANK = LRANK
!       IF( PRESENT(JPVT) ) JPVT = LJPVT
       DEALLOCATE(RWORK, STAT = ISTAT1 )
300    DEALLOCATE(WORK, STAT = ISTAT1 )
200    IF (.NOT. PRESENT(JPVT)) DEALLOCATE(LJPVT, STAT = ISTAT1 )
     END IF
100 CALL ERINFO( LINFO, SRNAME, INFO, ISTAT )
END SUBROUTINE CGELSX_F95


       module bessel
         implicit none

       interface besselk0
          module procedure besselk0
       end interface

       interface besselk1
          module procedure besselk1
       end interface

       interface besselk
          module procedure besselk
       end interface

       contains

         function besselk(n,x)
           integer, intent(in) :: n
           real(8), dimension(:), intent(in) :: x
           real(8), dimension(size(x)) :: besselk
           integer :: j
           real(8), dimension(size(x)) :: bk,bkm,bkp,tox
           tox=2d0/x
           bkm=besselk0(x)
           bk=besselk1(x)
!           if(n.eq.0) then
!           besselk=bkm
!           else if(n.eq.1) then
!              besselk=bk
!           else
           do j=1,n-1
              bkp=bkm+j*tox*bk
              bkm=bk
              bk=bkp
           end do
           besselk=bk
!           end if
         end function besselk

         function besselk0(x)
           real(8), dimension(:), intent(in) :: x
           real(8), dimension(size(x)) :: besselk0
           real(8), dimension(size(x)) :: y
           logical, dimension(size(x)) :: mask
           real(8), dimension(7) :: p = (/-0.57721566d0,0.42278420d0,&
                0.23069756d0,0.3488590d-1,0.262698d-2,0.10750d-3,&
                0.74d-5/)
           real(8), dimension(7) :: q = (/1.25331414d0,-0.7832358d-1,&
                0.2189568d-1,-0.1062446d-1,0.587872d-2,&
                -0.251540d-2,0.53208d-3/)
!           write(6,*) 'bessel k0 before mask'
           mask = (x <= 2.0d0)
!           write(6,*) 'before where mask'
           where (mask)
              y=x*x/4.0d0
              besselk0=(-log(x/2.0d0)*besseli0(x))+poly_msk(y,p,mask)
           elsewhere
              y=(2.0d0/x)
              besselk0=(exp(-x)/sqrt(x))*poly_msk(y,q,.not.mask)
           end where
         end function besselk0

         function besselk1(x)
           real(8), dimension(:), intent(in) :: x
           real(8), dimension(size(x)) :: besselk1
           real(8), dimension(size(x)) :: y
           logical, dimension(size(x)) :: mask
           real(8), dimension(7) :: p = (/1.0d0,0.15443144d0,&
                -0.67278579d0,-0.18156897d0,-0.1919402d-1,&
                -0.110404d-2,-0.4686d-4/)
           real(8), dimension(7) :: q = (/1.25331414d0,0.23498619d0,&
                -0.3655620d-1,0.1504268d-1,-0.780353d-2,&
                0.325614d-2,-0.68245d-3/)
!           write(6,*) 'bessel k1 before mask'
           mask = (x <= 2.0d0)
!           write(6,*) 'bessel k1 after mask'
           where (mask)
              y=x*x/4.0d0
              besselk1=(log(x/2.0d0)*besseli1(x))+(1.0d0/x)*poly_msk(y,p,mask)
           elsewhere
              y=2.0d0/x
              besselk1=(exp(-x)/sqrt(x))*poly_msk(y,q,.not.mask)
           end where
         end function besselk1

         function besseli0(x)
           real(8), dimension(:), intent(in) :: x
           real(8), dimension(size(x)) :: besseli0
           real(8), dimension(size(x)) :: ax
           real(8), dimension(size(x)) :: y
           logical, dimension(size(x)) :: mask
           real(8), dimension(7) :: p = (/1.00d0,3.51562290d0,&
                3.08994240d0,1.20674920d0,0.26597320d0,0.360768d-10,&
                0.45813d-20/)
           real(8), dimension(9) :: q = (/0.398942280d0,0.1328592d-10,&
                0.225319d-20,-0.157565d-20,0.916281d-20,&
                -0.2057706d-10,0.2635537d-10,-0.1647633d-10,&
                0.392377d-20/)
           ax=abs(x)
           mask = (ax < 3.75d0)
           where (mask)
              besseli0=poly_msk((x/3.750d0)**2,p,mask)
           elsewhere
            y=3.750d0/ax
            besseli0=(exp(ax)/sqrt(ax))*poly_msk(y,q,.not.mask)
         end where
       end function besseli0

       function besseli1(x)
         real(8), dimension(:), intent(in) :: x
         real(8), dimension(size(x)) :: besseli1
         real(8), dimension(size(x)) :: ax
         real(8), dimension(size(x)) :: y
         logical, dimension(size(x)) :: mask
         real(8), dimension(7) :: p = (/0.50d0,0.878905940d0,&
              0.514988690d0,0.150849340d0,0.2658733d-10,&
              0.301532d-20,0.32411d-30/)
          real(8), dimension(9) :: q = (/0.398942280d0,-0.3988024d-10,&
               -0.362018d-20,0.163801d-20,-0.1031555d-10,&
               0.2282967d-10,-0.2895312d-10,0.1787654d-10,&
               -0.420059d-20/)
          ax=abs(x)
          mask = (ax < 3.75d0)
          where (mask)
             besseli1=ax*poly_msk((x/3.750d0)**2,p,mask)
          elsewhere
             y=3.750d0/ax
             besseli1=(exp(ax)/sqrt(ax))*poly_msk(y,q,.not.mask)
          end where
          where (x < 0.0d0) besseli1=-besseli1
        end function besseli1

        function poly_msk(x,coeffs,mask)
          real(8), dimension(:), intent(in) :: coeffs,x
          logical, dimension(:), intent(in) :: mask
          real(8), dimension(size(x)) :: poly_msk
          poly_msk=unpack(poly(pack(x,mask),coeffs),mask,0.0d0)
        end function poly_msk

        function poly(x,coeffs)
          real(8), dimension(:), intent(in) :: coeffs,x
          real(8), dimension(size(x)) :: poly
          integer :: i,m
          m=size(coeffs)
!          n=size(x)
          if (m <= 0) then
             poly=0.0d0
          else !if (m < n .or. m < NPAR_POLY) then
             poly=coeffs(m)
             do i=m-1,1,-1
                poly=x*poly+coeffs(i)
             end do
          endif!else
!             do i=1,n
!                poly(i)=poly_rr(x(i),coeffs)
!             end do
!          end if
        end function poly

        end module bessel


!##############################################################################
! MODULE globals
!
! This code is published under the GNU General Public License v3
!                         (https://www.gnu.org/licenses/gpl-3.0.en.html)
!
! Authors: Hans Fehr and Fabian Kindermann
!          contact@ce-fortran.com
!
! #VC# VERSION: 1.0  (23 January 2018)
!
!##############################################################################
module globals

    implicit none
    real*8, parameter :: p(2) = (/1d0, 2d0/)
    real*8, parameter :: W = 1d0

contains

    ! the utility function
    function utility(x)

        implicit none
        real*8, intent(in) :: x
        real*8 :: utility

        utility = -(((W-p(2)*x)/p(1))**0.4d0+(1d0+x)**0.5d0)

    end function

end module globals


      SUBROUTINE UL_DECOMP(DIM, A, B, L, U, Y, X)
        INTEGER DIM
        REAL A, B, U, L, Y, X
        DIMENSION A(DIM,DIM), B(DIM),
     &    U(DIM,DIM), L(DIM,DIM), Y(DIM), X(DIM)

        DO 10 I = 1, DIM
C         Fill L matrix diag with 1
          L(I, I) = 1
C         Fill U matrix first row
          U(1, I) = A(1, I)

C         Fill L matrix first column
          IF (I.GT.1)
     &      L(I, 1) = A(I, 1) / U(1, 1)
10      CONTINUE

        DO 50 I = 2, DIM
          DO 40 J = I, DIM

C           Fill U row cell by cell
            S = 0
            DO 20 K = 1, I - 1
              S = S + L(I, K) * U(K, J)
20          CONTINUE
            U(I, J) = A(I, J) - S

C           Fill L column cell by cell & use previously calculated cell
            IF (J.GT.I) THEN
              S = 0
              DO 30 K = 1, I - 1
                S = S + L(J, K) * U(K, I)
30            CONTINUE
              L(J, I) = (1 / U(I, I)) * (A(J, I) - S)
            END IF

40        CONTINUE
50      CONTINUE

C       y: Ly = b
        DO 70 I = 1, DIM
          S = 0
          DO 60 K = 1, I - 1
            S = S + L(I, K) * Y(K)
60        CONTINUE

          Y(I) = B(I) - S
70      CONTINUE

C       x: Ux = y
        DO 90 I = DIM, 1, -1
          S = 0
          DO 80 K = 1, I - 1
            S = S + U(I, K) * X(K)
80        CONTINUE

          X(I) = Y(I) - S
90      CONTINUE
      END


subroutine calc_OBJPOT
	use params
	implicit none
	integer :: i,j,k
	OBJPOT = 0.0d0

	!Normal potential and Trap
	if (enablePot) then
		if(potType .eq. 0) then
			call calc_OBJPOT_obj
		end if
		if(potType .eq. 2) then
			call calc_OBJPOT_cyl
		end if
		if(potType .eq. 3) then
			call calc_OBJPOT_afm
		end if
		if(potType .eq. 4) then
			call calc_OBJPOT_img
		end if
		if(potType .eq. 5) then
			call calc_OBJPOT_obj_with_floor
		end if
		if(potType .eq. 6) then
			call calc_OBJPOT_obj_with_floor_dip
		end if
		if(potType .eq. 7) then
			call calc_OBJPOT_obj_with_floor_sin
		end if
	end if
	if (enableTrap) then
	if (trapType .eq. 0) then
		!$OMP PARALLEL DO
		do i = -NX/2,NX/2
		do j = -NY/2,NY/2
		do k = -NZ/2,NZ/2
			OBJPOT(i,j,k) = OBJPOT(i,j,k)&
				+0.5d0*((TXSCALE*dble(i)*DSPACE+TXDASH)*(TXSCALE*dble(i)*DSPACE+TXDASH)&
				+(TYSCALE*dble(j)*DSPACE+TYDASH)*(TYSCALE*dble(j)*DSPACE+TYDASH)&
				+(TZSCALE*dble(k)*DSPACE+TZDASH)*(TZSCALE*dble(k)*DSPACE+TZDASH))
		end do
		end do
		end do
		!$OMP END PARALLEL DO
	else if (trapType .eq. 1) then
		!$OMP PARALLEL DO
        do i = -NX/2,NX/2
        do j = -NY/2,NY/2
        do k = -NZ/2,NZ/2
            OBJPOT(i,j,k) = OBJPOT(i,j,k)&
               +0.5d0*((TXSCALE**2.0d0)*((sqrt((dble(i)*DSPACE+TXDASH)**2.0d0+(dble(j)*DSPACE+TYDASH)**2.0d0)-TR0)**2.0d0)&
               +(TZSCALE**2.0d0)*((dble(k)*DSPACE+TXDASH)**2.0d0))
        end do
        end do
        end do
        !$OMP END PARALLEL DO
	end if
	end if

end subroutine

subroutine calc_OBJPOT_obj
	use params
	implicit none
	integer :: i,j,k,obj
	double precision :: rx,ry,rz,r2
	!$OMP PARALLEL DO
	do i = -NX/2,NX/2
		do j = -NY/2,NY/2
			do k = -NZ/2,NZ/2
				rx = (dble(i)*DSPACE)-OBJXDASH
				ry = (dble(j)*DSPACE)-OBJYDASH
				rz = (dble(k)*DSPACE)-OBJZDASH
				OBJPOT(i,j,k) = OBJHEIGHT*&
					EXP(-(1.0d0/RRX**2.0d0)*(rx**2.0d0)&
						-(1.0d0/RRY**2.0d0)*(ry**2.0d0)&
						-(1.0d0/RRZ**2.0d0)*(rz**2.0d0))
			end do
		end do
	end do
	!$OMP END PARALLEL DO
end subroutine

subroutine calc_OBJPOT_cyl
	use params
	implicit none
	integer :: i,j,k,obj
	double precision :: rx,ry,r2
	!$OMP PARALLEL DO
	do i = -NX/2,NX/2
		do j = -NY/2,NY/2
			do k = -NZ/2,NZ/2
				rx = (dble(i)*DSPACE)-OBJXDASH
				ry = (dble(j)*DSPACE)-OBJYDASH
				OBJPOT(i,j,k) = OBJHEIGHT*&
				EXP(-(1.0d0/RRX**2.0d0)*(rx**2.0d0)&
				-(1.0d0/RRY**2.0d0)*(ry**2.0d0))
			end do
		end do
	end do
	!$OMP END PARALLEL DO
end subroutine

subroutine calc_OBJPOT_obj_with_floor
	use params
	implicit none
	integer :: i,j,k,obj
	double precision :: rx,ry,rz,r2
	!$OMP PARALLEL DO
	do i = -NX/2,NX/2
		do j = -NY/2,NY/2
			do k = -NZ/2,NZ/2
				rx = (dble(i)*DSPACE)-OBJXDASH
				ry = (dble(j)*DSPACE)-OBJYDASH
				rz = (dble(k)*DSPACE)-OBJZDASH
				OBJPOT(i,j,k) = OBJHEIGHT*&
					EXP(-(1.0d0/RRX**2.0d0)*(rx**2.0d0)&
						-(1.0d0/RRY**2.0d0)*(ry**2.0d0)&
						-(1.0d0/RRZ**2.0d0)*(rz**2.0d0))
			end do
		end do
	end do
	!$OMP END PARALLEL DO
	!$OMP PARALLEL DO
	do i = -NX/2,NX/2
		do j = -NY/2,NY/2
			do k = -NZ/2,-NZ/2+10
				OBJPOT(i,j,k) = OBJHEIGHT
			end do
		end do
	end do
	!$OMP END PARALLEL DO
end subroutine

subroutine calc_OBJPOT_obj_with_floor_dip
	use params
	implicit none
	integer :: i,j,k,l,obj
	double precision :: rx,ry,rz,r2
	!$OMP PARALLEL DO
	do i = -NX/2,NX/2
		do j = -NY/2,NY/2
			do k = -NZ/2,-NZ/2+20
				l = (i*DSPACE)*cos(FLR) - (j*DSPACE)*sin(FLR)
				if(k*DSPACE < min(5.0d0,5.0d0*(l/10.0d0)**2.0d0)-26.0d0) then
					OBJPOT(i,j,k) = OBJHEIGHT
				end if
			end do
		end do
	end do
	!$OMP END PARALLEL DO
end subroutine

subroutine calc_OBJPOT_obj_with_floor_sin
	use params
	implicit none
	integer :: i,j,k,l,obj
	double precision :: rx,ry,rz,r2
	!$OMP PARALLEL DO
	do i = -NX/2,NX/2
		do j = -NY/2,NY/2
			do k = -NZ/2,-NZ/2+20
				l = (i*DSPACE)*cos(FLR) - (j*DSPACE)*sin(FLR)
				if (abs(l) > 30) then
					l = 9.86
				end if
				if(k*DSPACE < 5.0*cos(3.1415+l/6.28)-21.0) then
					OBJPOT(i,j,k) = OBJHEIGHT
				end if
			end do
		end do
	end do
	!$OMP END PARALLEL DO
end subroutine

subroutine calc_OBJPOT_afm
	use params
	implicit none
	integer :: i,j,k,obj
	double precision :: di,dj,dk,ith,xtt,ytt,ztt
	double precision, dimension(afmRES) :: xdat,ydat
	double precision, dimension(afmRES,afmRES) :: hdat

	open (unit = 5, file = TRIM(afm_filename))
	do j = 1,afmRES
	do i = 1,afmRES
		read (5,*) xtt,ytt,ztt !in um, um, nm - x,y between 0 and 1
			xdat(i) = ((xtt-0.5d0)*afmXScale)
			ydat(j) = ((ytt-0.5d0)*afmYScale)
			hdat(i,j) = (ztt*afmZScale)
	end do
	end do
	hdat= hdat - MINVAL(hdat(3:afmRES-3,3:afmRES-3)) - (NZ/2)*DSPACE
	OBJPOT = 0.0d0

	do k = -NZ/2,NZ/2
		dk = k*DSPACE
		do j = -NY/2,NY/2
			dj = j*DSPACE
			do i = -NX/2,NX/2
				di = i*DSPACE

				if(di>maxval(xdat(1:afmRES-3))) then
					di = xdat(afmRES-3)
				end if
				if(dj>maxval(ydat(1:afmRES-3))) then
					dj = ydat(afmRES-3)
				end if

				if(dk < hdat(2*i+afmRES/2,2*j+afmRES/2)) then
					OBJPOT(i,j,k) = OBJHEIGHT
				end if

			end do
		end do
	end do
	close(5)

	OBJPOT(:,:,-NZ/2+NINT(NZ/TRUNCPARAM):NZ/2) = 0.0d0

end subroutine

subroutine calc_OBJPOT_img
	use params
	use bitmap
	implicit none
	integer :: i,j,k,obj
	double precision :: gs

	CALL load_bmp
	!$OMP PARALLEL DO
	do i = -NX/2,NX/2
		do j = -NY/2,NY/2
			do k = -NZ/2,NZ/2
				if(k < (NZ*Img(i,j)/255)-NZ/2) then
					OBJPOT(i,j,k) = OBJHEIGHT
				end if
			end do
		end do
	end do
	!$OMP END PARALLEL DO
end subroutine

subroutine interp3D(xloc,yloc,xdat,ydat,hdat,reth)
	use params
	implicit none
	integer :: iterC
	double precision :: xloc,yloc,reth
	double precision, dimension(afmRES) :: xdat,ydat
	double precision, dimension(afmRES,afmRES) :: hdat

	!TODO: Finish
	reth = iterC(0,0)
end subroutine

integer function iterC(i,j)
	implicit none
	integer :: i,j
	INTEGER, DIMENSION(64, 64) :: cArray

	!cArray = transpose(reshape((/ 1, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 1, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,-3, 3, 0, 0, 0, 0, 0, 0,-2,-1, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 2,-2, 0, 0, 0, 0, 0, 0, 1, 1, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 1, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 1, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,-3, 3, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,-2,-1, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 2,-2, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 1, 1, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,-3, 0, 3, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,-2, 0,-1, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,-3, 0, 3, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,-2, 0,-1, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 9,-9,-9, 9, 0, 0, 0, 0, 6, 3,-6,-3, 0, 0, 0, 0, 6,-6, 3,-3, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 4, 2, 2, 1, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,-6, 6, 6,-6, 0, 0, 0, 0,-3,-3, 3, 3, 0, 0, 0, 0,-4, 4,-2, 2, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,-2,-2,-1,-1, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 2, 0,-2, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 1, 0, 1, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 2, 0,-2, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 1, 0, 1, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,-6, 6, 6,-6, 0, 0, 0, 0,-4,-2, 4, 2, 0, 0, 0, 0,-3, 3,-3, 3, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,-2,-1,-2,-1, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 4,-4,-4, 4, 0, 0, 0, 0, 2, 2,-2,-2, 0, 0, 0, 0, 2,-2, 2,-2, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 1, 1, 1, 1, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 1, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 1, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,-3, 3, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,-2,-1, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 2,-2, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 1, 1, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 1, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 1, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,-3, 3, 0, 0, 0, 0, 0, 0,-2,-1, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 2,-2, 0, 0, 0, 0, 0, 0, 1, 1, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,-3, 0, 3, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,-2, 0,-1, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,-3, 0, 3, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,-2, 0,-1, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 9,-9,-9, 9, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 6, 3,-6,-3, 0, 0, 0, 0, 6,-6, 3,-3, 0, 0, 0, 0, 4, 2, 2, 1, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,-6, 6, 6,-6, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,-3,-3, 3, 3, 0, 0, 0, 0,-4, 4,-2, 2, 0, 0, 0, 0,-2,-2,-1,-1, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 2, 0,-2, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 1, 0, 1, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 2, 0,-2, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 1, 0, 1, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,-6, 6, 6,-6, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,-4,-2, 4, 2, 0, 0, 0, 0,-3, 3,-3, 3, 0, 0, 0, 0,-2,-1,-2,-1, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 4,-4,-4, 4, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 2, 2,-2,-2, 0, 0, 0, 0, 2,-2, 2,-2, 0, 0, 0, 0, 1, 1, 1, 1, 0, 0, 0, 0,-3, 0, 0, 0, 3, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,-2, 0, 0, 0,-1, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,-3, 0, 0, 0, 3, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,-2, 0, 0, 0,-1, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 9,-9, 0, 0,-9, 9, 0, 0, 6, 3, 0, 0,-6,-3, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 6,-6, 0, 0, 3,-3, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 4, 2, 0, 0, 2, 1, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,-6, 6, 0, 0, 6,-6, 0, 0,-3,-3, 0, 0, 3, 3, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,-4, 4, 0, 0,-2, 2, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,-2,-2, 0, 0,-1,-1, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,-3, 0, 0, 0, 3, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,-2, 0, 0, 0,-1, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,-3, 0, 0, 0, 3, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,-2, 0, 0, 0,-1, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 9,-9, 0, 0,-9, 9, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 6, 3, 0, 0,-6,-3, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 6,-6, 0, 0, 3,-3, 0, 0, 4, 2, 0, 0, 2, 1, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,-6, 6, 0, 0, 6,-6, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,-3,-3, 0, 0, 3, 3, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,-4, 4, 0, 0,-2, 2, 0, 0,-2,-2, 0, 0,-1,-1, 0, 0, 9, 0,-9, 0,-9, 0, 9, 0, 0, 0, 0, 0, 0, 0, 0, 0, 6, 0, 3, 0,-6, 0,-3, 0, 6, 0,-6, 0, 3, 0,-3, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 4, 0, 2, 0, 2, 0, 1, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 9, 0,-9, 0,-9, 0, 9, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 6, 0, 3, 0,-6, 0,-3, 0, 6, 0,-6, 0, 3, 0,-3, 0, 0, 0, 0, 0, 0, 0, 0, 0, 4, 0, 2, 0, 2, 0, 1, 0,-27,27,27,-27,27,-27,-27,27,-18,-9,18, 9,18, 9,-18,-9,-18,18,-9, 9,18,-18, 9,-9,-18,18,18,-18,-9, 9, 9,-9,-12,-6,-6,-3,12, 6, 6, 3,-12,-6,12, 6,-6,-3, 6, 3,-12,12,-6, 6,-6, 6,-3, 3,-8,-4,-4,-2,-4,-2,-2,-1,18,-18,-18,18,-18,18,18,-18, 9, 9,-9,-9,-9,-9, 9, 9,12,-12, 6,-6,-12,12,-6, 6,12,-12,-12,12, 6,-6,-6, 6, 6, 6, 3, 3,-6,-6,-3,-3, 6, 6,-6,-6, 3, 3,-3,-3, 8,-8, 4,-4, 4,-4, 2,-2, 4, 4, 2, 2, 2, 2, 1, 1,-6, 0, 6, 0, 6, 0,-6, 0, 0, 0, 0, 0, 0, 0, 0, 0,-3, 0,-3, 0, 3, 0, 3, 0,-4, 0, 4, 0,-2, 0, 2, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,-2, 0,-2, 0,-1, 0,-1, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,-6, 0, 6, 0, 6, 0,-6, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,-3, 0,-3, 0, 3, 0, 3, 0,-4, 0, 4, 0,-2, 0, 2, 0, 0, 0, 0, 0, 0, 0, 0, 0,-2, 0,-2, 0,-1, 0,-1, 0,18,-18,-18,18,-18,18,18,-18,12, 6,-12,-6,-12,-6,12, 6, 9,-9, 9,-9,-9, 9,-9, 9,12,-12,-12,12, 6,-6,-6, 6, 6, 3, 6, 3,-6,-3,-6,-3, 8, 4,-8,-4, 4, 2,-4,-2, 6,-6, 6,-6, 3,-3, 3,-3, 4, 2, 4, 2, 2, 1, 2, 1,-12,12,12,-12,12,-12,-12,12,-6,-6, 6, 6, 6, 6,-6,-6,-6, 6,-6, 6, 6,-6, 6,-6,-8, 8, 8,-8,-4, 4, 4,-4,-3,-3,-3,-3, 3, 3, 3, 3,-4,-4, 4, 4,-2,-2, 2, 2,-4, 4,-4, 4,-2, 2,-2, 2,-2,-2,-2,-2,-1,-1,-1,-1, 2, 0, 0, 0,-2, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 1, 0, 0, 0, 1, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 2, 0, 0, 0,-2, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 1, 0, 0, 0, 1, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,-6, 6, 0, 0, 6,-6, 0, 0,-4,-2, 0, 0, 4, 2, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,-3, 3, 0, 0,-3, 3, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,-2,-1, 0, 0,-2,-1, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 4,-4, 0, 0,-4, 4, 0, 0, 2, 2, 0, 0,-2,-2, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 2,-2, 0, 0, 2,-2, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 1, 1, 0, 0, 1, 1, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 2, 0, 0, 0,-2, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 1, 0, 0, 0, 1, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 2, 0, 0, 0,-2, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 1, 0, 0, 0, 1, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,-6, 6, 0, 0, 6,-6, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,-4,-2, 0, 0, 4, 2, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,-3, 3, 0, 0,-3, 3, 0, 0,-2,-1, 0, 0,-2,-1, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 4,-4, 0, 0,-4, 4, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 2, 2, 0, 0,-2,-2, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 2,-2, 0, 0, 2,-2, 0, 0, 1, 1, 0, 0, 1, 1, 0, 0,-6, 0, 6, 0, 6, 0,-6, 0, 0, 0, 0, 0, 0, 0, 0, 0,-4, 0,-2, 0, 4, 0, 2, 0,-3, 0, 3, 0,-3, 0, 3, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,-2, 0,-1, 0,-2, 0,-1, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,-6, 0, 6, 0, 6, 0,-6, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,-4, 0,-2, 0, 4, 0, 2, 0,-3, 0, 3, 0,-3, 0, 3, 0, 0, 0, 0, 0, 0, 0, 0, 0,-2, 0,-1, 0,-2, 0,-1, 0,18,-18,-18,18,-18,18,18,-18,12, 6,-12,-6,-12,-6,12, 6,12,-12, 6,-6,-12,12,-6, 6, 9,-9,-9, 9, 9,-9,-9, 9, 8, 4, 4, 2,-8,-4,-4,-2, 6, 3,-6,-3, 6, 3,-6,-3, 6,-6, 3,-3, 6,-6, 3,-3, 4, 2, 2, 1, 4, 2, 2, 1,-12,12,12,-12,12,-12,-12,12,-6,-6, 6, 6, 6, 6,-6,-6,-8, 8,-4, 4, 8,-8, 4,-4,-6, 6, 6,-6,-6, 6, 6,-6,-4,-4,-2,-2, 4, 4, 2, 2,-3,-3, 3, 3,-3,-3, 3, 3,-4, 4,-2, 2,-4, 4,-2, 2,-2,-2,-1,-1,-2,-2,-1,-1, 4, 0,-4, 0,-4, 0, 4, 0, 0, 0, 0, 0, 0, 0, 0, 0, 2, 0, 2, 0,-2, 0,-2, 0, 2, 0,-2, 0, 2, 0,-2, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 1, 0, 1, 0, 1, 0, 1, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 4, 0,-4, 0,-4, 0, 4, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 2, 0, 2, 0,-2, 0,-2, 0, 2, 0,-2, 0, 2, 0,-2, 0, 0, 0, 0, 0, 0, 0, 0, 0, 1, 0, 1, 0, 1, 0, 1, 0,-12,12,12,-12,12,-12,-12,12,-8,-4, 8, 4, 8, 4,-8,-4,-6, 6,-6, 6, 6,-6, 6,-6,-6, 6, 6,-6,-6, 6, 6,-6,-4,-2,-4,-2, 4, 2, 4, 2,-4,-2, 4, 2,-4,-2, 4, 2,-3, 3,-3, 3,-3, 3,-3, 3,-2,-1,-2,-1,-2,-1,-2,-1, 8,-8,-8, 8,-8, 8, 8,-8, 4, 4,-4,-4,-4,-4, 4, 4, 4,-4, 4,-4,-4, 4,-4, 4, 4,-4,-4, 4, 4,-4,-4, 4, 2, 2, 2, 2,-2,-2,-2,-2, 2, 2,-2,-2, 2, 2,-2,-2, 2,-2, 2,-2, 2,-2, 2,-2, 1, 1, 1, 1, 1, 1, 1, 1 /), shape(cArray)))
	iterC = 0
end function


subroutine refit_1fc(spec, freqs, fc, omega, n, oo, ff, nf, res)
    implicit none
    ! Argument declarations
    integer :: ff, oo, nf

    double precision, intent(in) :: omega(oo), fc(ff), n(ff), spec(nf), freqs(nf)
    double precision, intent(out) :: res(3)

    ! Variable declarations
    double precision :: synth(nf), best_ssq, ssq, weights(nf)
    integer :: i, k
    best_ssq = HUGE(ssq)
    weights = 1!/freqs
    do i = 1, ff
        do k = 1, oo
            synth = omega(k) / (1 + (freqs/fc(i))**n(i))
            ssq = sum(((synth-spec)*weights)**2)
            if (ssq < best_ssq) then
                best_ssq = ssq
                res(1) = fc(i)
                res(2) = omega(k)
                res(3) = n(i)
            end if
        end do
    end do
end subroutine refit_1fc

subroutine refit_2fc(spec, freqs, fc1, fc2, omega, n, oo, ff, gg, nf, res)
    implicit none
    ! Argument declarations
    integer :: ff, oo, nf, gg
    double precision, intent(in) :: omega(oo), n(ff), spec(nf), freqs(nf)
    double precision, intent(in) :: fc1(ff), fc2(gg)
    double precision, intent(out) :: res(4)

    ! Variable declarations
    double precision :: synth(nf), best_ssq, ssq, weights(nf)
    integer :: i, k, l
    best_ssq = HUGE(ssq)
    do i = 1, ff
        do k = 1, oo
            do l = 1, gg
                !synth = log10(omega(k)) + log10(1 + (freqs/fc2(l))**n(i))
                !synth = synth - log10(1 + (freqs/fc1(i))**n(i))
                synth = (1 + (freqs/fc2(l))**n(i))
                synth = synth / (1 + (freqs/fc1(i))**n(i))
                synth = synth * omega(k)
                ssq = sum((synth-spec)**2)
                if (ssq < best_ssq) then
                    best_ssq = ssq
                    res(1) = fc1(i)
                    res(2) = omega(k)
                    res(3) = n(i)
                    res(4) = fc2(l)
                end if
            end do
        end do
    end do

end subroutine refit_2fc

subroutine fit_1fc(spec, freqs, fc, omega, n, oo, nn, ff, nf, res)
    implicit none
    ! Argument declarations
    integer :: ff, nn, oo, nf
    double precision, intent(in) :: omega(oo), fc(ff), n(nn), spec(nf), freqs(nf)
    double precision, intent(out) :: res(3)

    ! Variable declarations
    double precision :: synth(nf), best_ssq, ssq, weights(nf)
    integer :: i, j, k
    best_ssq = HUGE(ssq)
    weights = 1/freqs
    do i = 1, ff
        do j = 1, nn
            do k = 1, oo
                synth = omega(k) / (1 + (freqs/fc(i))**n(j))
                ssq = sum(((synth-spec))**2)
                if (ssq < best_ssq) then
                    best_ssq = ssq
                    res(1) = fc(i)
                    res(2) = omega(k)
                    res(3) = n(j)
                end if
            end do
        end do
    end do

end subroutine fit_1fc

subroutine fit_2fc(spec, freqs, fc1, fc2, omega, n, oo, nn, ff, nf, res, gg, Y)
    implicit none
    ! Argument declarations
    integer :: ff, nn, oo, nf, gg
    double precision, intent(in) :: omega(oo), n(nn), spec(nf), freqs(nf)
    double precision, intent(in) :: fc1(ff), fc2(gg), Y
    double precision, intent(out) :: res(4)

    ! Variable declarations
    double precision :: synth(nf), best_ssq, ssq, weights(nf)
    integer :: i, j, k, l
    best_ssq = HUGE(ssq)
    do i = 1, ff
        do j = 1, nn
            do k = 1, oo
                do l = 1, gg
                    synth = log10(omega(k)) + (1./Y)*log10(1 + &
                    (freqs/fc2(l))**(n(j)*Y))
                    synth = synth - (1./Y)*log10(1 + (freqs/fc1(i))**(Y*n(j)))
                   ! synth = (1 + (freqs/fc2(l))**n(j))
                   ! synth = synth / (1 + (freqs/fc1(i))**n(j))
                   ! synth = synth * omega(k)
                    ssq = sum((synth-spec)**2)
                    if (ssq < best_ssq) then
                        best_ssq = ssq
                        res(1) = fc1(i)
                        res(2) = omega(k)
                        res(3) = n(j)
                        res(4) = fc2(l)
                    end if
                end do
            end do
        end do
    end do

end subroutine fit_2fc


    Program zpstrf_example

!     ZPSTRF Example Program Text

!     Copyright (c) 2018, Numerical Algorithms Group (NAG Ltd.)
!     For licence see
!       https://github.com/numericalalgorithmsgroup/LAPACK_Examples/blob/master/LICENCE.md

!     .. Use Statements ..
      Use lapack_example_aux, Only: nagf_file_print_matrix_complex_gen_comp, &
        nagf_file_print_matrix_integer_comp
      Use lapack_interfaces, Only: zpstrf
      Use lapack_precision, Only: dp
!     .. Implicit None Statement ..
      Implicit None
!     .. Parameters ..
      Complex (Kind=dp), Parameter :: zero = (0.0E0_dp, 0.0E0_dp)
      Integer, Parameter :: nin = 5, nout = 6
!     .. Local Scalars ..
      Real (Kind=dp) :: tol
      Integer :: i, ifail, info, j, lda, n, rank
      Character (1) :: uplo
!     .. Local Arrays ..
      Complex (Kind=dp), Allocatable :: a(:, :)
      Real (Kind=dp), Allocatable :: work(:)
      Integer, Allocatable :: piv(:)
      Character (1) :: clabs(1), rlabs(1)
!     .. Executable Statements ..
      Write (nout, *) 'ZPSTRF Example Program Results'
!     Skip heading in data file
      Read (nin, *)
      Read (nin, *) n, uplo
      lda = n
      Allocate (a(lda,n), piv(n), work(2*n))

!     Read A from data file
      If (uplo=='U') Then
        Read (nin, *)(a(i,i:n), i=1, n)
      Else If (uplo=='L') Then
        Read (nin, *)(a(i,1:i), i=1, n)
      End If
      tol = -1.0_dp

!     Factorize A
      Call zpstrf(uplo, n, a, lda, piv, rank, tol, work, info)

!     Zero out columns rank+1 to n
      If (uplo=='U') Then
        Do j = rank + 1, n
          a(rank+1:j, j) = zero
        End Do
      Else If (uplo=='L') Then
        Do j = rank + 1, n
          a(j:n, j) = zero
        End Do
      End If

!     Print rank
      Write (nout, *)
      Write (nout, '(1X,A15,I3)') 'Computed rank: ', rank

!     Print factor
      Write (nout, *)
      Flush (nout)
      ifail = 0
      Call nagf_file_print_matrix_complex_gen_comp(uplo, 'Nonunit', n, n, a, &
        lda, 'Bracketed', 'F5.2', 'Factor', 'Integer', rlabs, 'Integer', &
        clabs, 80, 0, ifail)

!     Print pivot indices
      Write (nout, *)
      Write (nout, *) 'PIV'
      Flush (nout)
      ifail = 0
      Call nagf_file_print_matrix_integer_comp('General', 'Non-unit', 1, n, &
        piv, 1, 'I14', ' ', 'No', rlabs, 'No', clabs, 80, 1, ifail)

    End Program


      module MOD_SEQUIN

      contains

      SUBROUTINE SEQUIN(NDIM, N, X, K, XNEW)
C***  X(K) MUST BE A STRICKTLY MONOTONIC SEQUENCE
C***   THIS SUBROUTINE INSERTS THE POINT XNEW AT SUITABLE POSITION K
C***  NO INSERTION IN CASE OF EXACT COINCIDENCE (K:= NEGATIVE INDEX )

      IMPLICIT REAL*8(A-H,O-Z)
      integer,intent(in) :: NDIM
      integer,intent(inout) ::N,K
      real*8,intent(in) :: XNEW
      real*8,intent(inout) :: X
      DIMENSION X(NDIM)

C***  INDEX ESTIMATE BY BISECTION
      NA=1
      A=X(1)
      NB=N
      B=X(N)
      IF (XNEW.EQ.A) GOTO 9
      IF (XNEW.EQ.B) GOTO 10
      IF((XNEW-A)*(XNEW-B).GE..0) GOTO 4
    1 IF(NB-NA .EQ. 1) GOTO 2
      NH=(NA+NB)/2
      H=X(NH)
C      IF (XNEW.EQ.H) GOTO 11
C***  ONLY INSERT A POINT IF IT IS NOT TOO CLOSE TO ANOTHER ONE
      IF (ABS(XNEW-H)/H.LT.0.00005) GOTO 11
      IF((XNEW-A)*(XNEW-H).GT..0) GOTO 3
      NB=NH
      B=H
      GOTO 1
    3 NA=NH
      A=H
      GOTO 1

C***  CASES OF EXACT COINCIDENCE
    9 K=-1
      RETURN
   10 K=-N
      RETURN
   11 K=-NH
      IF (XNEW.LT.H) X(NH)=XNEW
      RETURN

      ENTRY SEQUINE(NDIM, N, X, K, XNEW)
C***  ENTRY POINT IF THE INSERTION INDEX K IS GIVEN *********************
      IF (K.EQ.N+1) GOTO 8
      ! CALL ASSERT(K .gt. 0 .and. K .le. N,'ENTRY SEQUINE: WRONG INDEX GIVEN')
      IF (K.LE.0 .OR. K.GT.N) THEN
            WRITE(6,*) 'ENTRY SEQUINE: WRONG INDEX GIVEN'
            STOP 'ERROR'
            ENDIF
      NB=K

C***  INSERTION OF XNEW AT INDEX NB
    2 IF(N+1 .GT. NDIM) THEN
            WRITE(6,*) 'ARRAY DIMENSION TOO SMALL'
            STOP 'ERROR'
            ENDIF
      K=NB
    7 DO 5 J=K,N
      I=N+K-J
    5 X(I+1)=X(I)
    8 X(K)=XNEW
      N = N + 1
      RETURN

C***  XNEW LIES OUTSIDE X(1) ... X(N)
    4 IF(N+1 .GT. NDIM) THEN
            WRITE(6,*) 'ARRAY DIMENSION TOO SMALL'
            STOP 'ERROR'
            ENDIF
      IF((XNEW-A)*(B-A).GT..0) GOTO 6

      GOTO 7
    6 N=N+1
      K=N
      X(N)=XNEW

      RETURN

      END subroutine

      end module


      subroutine spgrid(iopt,ider,mu,u,mv,v,r,r0,r1,s,nuest,nvest,
     * nu,tu,nv,tv,c,fp,wrk,lwrk,iwrk,kwrk,ier)
c  given the function values r(i,j) on the latitude-longitude grid
c  (u(i),v(j)), i=1,...,mu ; j=1,...,mv , spgrid determines a smooth
c  bicubic spline approximation on the rectangular domain 0<=u<=pi,
c  vb<=v<=ve (vb = v(1), ve=vb+2*pi).
c  this approximation s(u,v) will satisfy the properties
c
c    (1) s(0,v) = s(0,0) = dr(1)
c
c        d s(0,v)           d s(0,0)           d s(0,pi/2)
c    (2) -------- = cos(v)* -------- + sin(v)* -----------
c        d u                d u                d u
c
c                 = cos(v)*dr(2)+sin(v)*dr(3)
c                                                     vb <= v <= ve
c    (3) s(pi,v) = s(pi,0) = dr(4)
c
c        d s(pi,v)           d s(pi,0)           d s(pi,pi/2)
c    (4) -------- = cos(v)*  --------- + sin(v)* ------------
c        d u                 d u                 d u
c
c                 = cos(v)*dr(5)+sin(v)*dr(6)
c
c  and will be periodic in the variable v, i.e.
c
c         j           j
c        d s(u,vb)   d s(u,ve)
c    (5) --------- = ---------   0 <=u<= pi , j=0,1,2
c           j           j
c        d v         d v
c
c  the number of knots of s(u,v) and their position tu(i),i=1,2,...,nu;
c  tv(j),j=1,2,...,nv, is chosen automatically by the routine. the
c  smoothness of s(u,v) is achieved by minimalizing the discontinuity
c  jumps of the derivatives of the spline at the knots. the amount of
c  smoothness of s(u,v) is determined by the condition that
c  fp=sumi=1,mu(sumj=1,mv((r(i,j)-s(u(i),v(j)))**2))+(r0-s(0,v))**2
c  + (r1-s(pi,v))**2 <= s, with s a given non-negative constant.
c  the fit s(u,v) is given in its b-spline representation and can be
c  evaluated by means of routine bispev
c
c calling sequence:
c     call spgrid(iopt,ider,mu,u,mv,v,r,r0,r1,s,nuest,nvest,nu,tu,
c    *  ,nv,tv,c,fp,wrk,lwrk,iwrk,kwrk,ier)
c
c parameters:
c  iopt  : integer array of dimension 3, specifying different options.
c          unchanged on exit.
c  iopt(1):on entry iopt(1) must specify whether a least-squares spline
c          (iopt(1)=-1) or a smoothing spline (iopt(1)=0 or 1) must be
c          determined.
c          if iopt(1)=0 the routine will start with an initial set of
c          knots tu(i)=0,tu(i+4)=pi,i=1,...,4;tv(i)=v(1)+(i-4)*2*pi,
c          i=1,...,8.
c          if iopt(1)=1 the routine will continue with the set of knots
c          found at the last call of the routine.
c          attention: a call with iopt(1)=1 must always be immediately
c          preceded by another call with iopt(1) = 1 or iopt(1) = 0.
c  iopt(2):on entry iopt(2) must specify the requested order of conti-
c          nuity at the pole u=0.
c          if iopt(2)=0 only condition (1) must be fulfilled and
c          if iopt(2)=1 conditions (1)+(2) must be fulfilled.
c  iopt(3):on entry iopt(3) must specify the requested order of conti-
c          nuity at the pole u=pi.
c          if iopt(3)=0 only condition (3) must be fulfilled and
c          if iopt(3)=1 conditions (3)+(4) must be fulfilled.
c  ider  : integer array of dimension 4, specifying different options.
c          unchanged on exit.
c  ider(1):on entry ider(1) must specify whether (ider(1)=0 or 1) or not
c          (ider(1)=-1) there is a data value r0 at the pole u=0.
c          if ider(1)=1, r0 will be considered to be the right function
c          value, and it will be fitted exactly (s(0,v)=r0).
c          if ider(1)=0, r0 will be considered to be a data value just
c          like the other data values r(i,j).
c  ider(2):on entry ider(2) must specify whether (ider(2)=1) or not
c          (ider(2)=0) the approximation has vanishing derivatives
c          dr(2) and dr(3) at the pole u=0  (in case iopt(2)=1)
c  ider(3):on entry ider(3) must specify whether (ider(3)=0 or 1) or not
c          (ider(3)=-1) there is a data value r1 at the pole u=pi.
c          if ider(3)=1, r1 will be considered to be the right function
c          value, and it will be fitted exactly (s(pi,v)=r1).
c          if ider(3)=0, r1 will be considered to be a data value just
c          like the other data values r(i,j).
c  ider(4):on entry ider(4) must specify whether (ider(4)=1) or not
c          (ider(4)=0) the approximation has vanishing derivatives
c          dr(5) and dr(6) at the pole u=pi (in case iopt(3)=1)
c  mu    : integer. on entry mu must specify the number of grid points
c          along the u-axis. unchanged on exit.
c          mu >= 1, mu >=mumin=4-i0-i1-ider(2)-ider(4) with
c            i0=min(1,ider(1)+1), i1=min(1,ider(3)+1)
c  u     : real array of dimension at least (mu). before entry, u(i)
c          must be set to the u-co-ordinate of the i-th grid point
c          along the u-axis, for i=1,2,...,mu. these values must be
c          supplied in strictly ascending order. unchanged on exit.
c          0 < u(i) < pi.
c  mv    : integer. on entry mv must specify the number of grid points
c          along the v-axis. mv > 3 . unchanged on exit.
c  v     : real array of dimension at least (mv). before entry, v(j)
c          must be set to the v-co-ordinate of the j-th grid point
c          along the v-axis, for j=1,2,...,mv. these values must be
c          supplied in strictly ascending order. unchanged on exit.
c          -pi <= v(1) < pi , v(mv) < v(1)+2*pi.
c  r     : real array of dimension at least (mu*mv).
c          before entry, r(mv*(i-1)+j) must be set to the data value at
c          the grid point (u(i),v(j)) for i=1,...,mu and j=1,...,mv.
c          unchanged on exit.
c  r0    : real value. on entry (if ider(1) >=0 ) r0 must specify the
c          data value at the pole u=0. unchanged on exit.
c  r1    : real value. on entry (if ider(1) >=0 ) r1 must specify the
c          data value at the pole u=pi. unchanged on exit.
c  s     : real. on entry (if iopt(1)>=0) s must specify the smoothing
c          factor. s >=0. unchanged on exit.
c          for advice on the choice of s see further comments
c  nuest : integer. unchanged on exit.
c  nvest : integer. unchanged on exit.
c          on entry, nuest and nvest must specify an upper bound for the
c          number of knots required in the u- and v-directions respect.
c          these numbers will also determine the storage space needed by
c          the routine. nuest >= 8, nvest >= 8.
c          in most practical situation nuest = mu/2, nvest=mv/2, will
c          be sufficient. always large enough are nuest=mu+6+iopt(2)+
c          iopt(3), nvest = mv+7, the number of knots needed for
c          interpolation (s=0). see also further comments.
c  nu    : integer.
c          unless ier=10 (in case iopt(1)>=0), nu will contain the total
c          number of knots with respect to the u-variable, of the spline
c          approximation returned. if the computation mode iopt(1)=1 is
c          used, the value of nu should be left unchanged between sub-
c          sequent calls. in case iopt(1)=-1, the value of nu should be
c          specified on entry.
c  tu    : real array of dimension at least (nuest).
c          on succesful exit, this array will contain the knots of the
c          spline with respect to the u-variable, i.e. the position of
c          the interior knots tu(5),...,tu(nu-4) as well as the position
c          of the additional knots tu(1)=...=tu(4)=0 and tu(nu-3)=...=
c          tu(nu)=pi needed for the b-spline representation.
c          if the computation mode iopt(1)=1 is used,the values of tu(1)
c          ...,tu(nu) should be left unchanged between subsequent calls.
c          if the computation mode iopt(1)=-1 is used, the values tu(5),
c          ...tu(nu-4) must be supplied by the user, before entry.
c          see also the restrictions (ier=10).
c  nv    : integer.
c          unless ier=10 (in case iopt(1)>=0), nv will contain the total
c          number of knots with respect to the v-variable, of the spline
c          approximation returned. if the computation mode iopt(1)=1 is
c          used, the value of nv should be left unchanged between sub-
c          sequent calls. in case iopt(1) = -1, the value of nv should
c          be specified on entry.
c  tv    : real array of dimension at least (nvest).
c          on succesful exit, this array will contain the knots of the
c          spline with respect to the v-variable, i.e. the position of
c          the interior knots tv(5),...,tv(nv-4) as well as the position
c          of the additional knots tv(1),...,tv(4) and tv(nv-3),...,
c          tv(nv) needed for the b-spline representation.
c          if the computation mode iopt(1)=1 is used,the values of tv(1)
c          ...,tv(nv) should be left unchanged between subsequent calls.
c          if the computation mode iopt(1)=-1 is used, the values tv(5),
c          ...tv(nv-4) must be supplied by the user, before entry.
c          see also the restrictions (ier=10).
c  c     : real array of dimension at least (nuest-4)*(nvest-4).
c          on succesful exit, c contains the coefficients of the spline
c          approximation s(u,v)
c  fp    : real. unless ier=10, fp contains the sum of squared
c          residuals of the spline approximation returned.
c  wrk   : real array of dimension (lwrk). used as workspace.
c          if the computation mode iopt(1)=1 is used the values of
c          wrk(1),..,wrk(12) should be left unchanged between subsequent
c          calls.
c  lwrk  : integer. on entry lwrk must specify the actual dimension of
c          the array wrk as declared in the calling (sub)program.
c          lwrk must not be too small.
c           lwrk >= 12+nuest*(mv+nvest+3)+nvest*24+4*mu+8*mv+q
c           where q is the larger of (mv+nvest) and nuest.
c  iwrk  : integer array of dimension (kwrk). used as workspace.
c          if the computation mode iopt(1)=1 is used the values of
c          iwrk(1),.,iwrk(5) should be left unchanged between subsequent
c          calls.
c  kwrk  : integer. on entry kwrk must specify the actual dimension of
c          the array iwrk as declared in the calling (sub)program.
c          kwrk >= 5+mu+mv+nuest+nvest.
c  ier   : integer. unless the routine detects an error, ier contains a
c          non-positive value on exit, i.e.
c   ier=0  : normal return. the spline returned has a residual sum of
c            squares fp such that abs(fp-s)/s <= tol with tol a relat-
c            ive tolerance set to 0.001 by the program.
c   ier=-1 : normal return. the spline returned is an interpolating
c            spline (fp=0).
c   ier=-2 : normal return. the spline returned is the least-squares
c            constrained polynomial. in this extreme case fp gives the
c            upper bound for the smoothing factor s.
c   ier=1  : error. the required storage space exceeds the available
c            storage space, as specified by the parameters nuest and
c            nvest.
c            probably causes : nuest or nvest too small. if these param-
c            eters are already large, it may also indicate that s is
c            too small
c            the approximation returned is the least-squares spline
c            according to the current set of knots. the parameter fp
c            gives the corresponding sum of squared residuals (fp>s).
c   ier=2  : error. a theoretically impossible result was found during
c            the iteration proces for finding a smoothing spline with
c            fp = s. probably causes : s too small.
c            there is an approximation returned but the corresponding
c            sum of squared residuals does not satisfy the condition
c            abs(fp-s)/s < tol.
c   ier=3  : error. the maximal number of iterations maxit (set to 20
c            by the program) allowed for finding a smoothing spline
c            with fp=s has been reached. probably causes : s too small
c            there is an approximation returned but the corresponding
c            sum of squared residuals does not satisfy the condition
c            abs(fp-s)/s < tol.
c   ier=10 : error. on entry, the input data are controlled on validity
c            the following restrictions must be satisfied.
c            -1<=iopt(1)<=1, 0<=iopt(2)<=1, 0<=iopt(3)<=1,
c            -1<=ider(1)<=1, 0<=ider(2)<=1, ider(2)=0 if iopt(2)=0.
c            -1<=ider(3)<=1, 0<=ider(4)<=1, ider(4)=0 if iopt(3)=0.
c            mu >= mumin (see above), mv >= 4, nuest >=8, nvest >= 8,
c            kwrk>=5+mu+mv+nuest+nvest,
c            lwrk >= 12+nuest*(mv+nvest+3)+nvest*24+4*mu+8*mv+
c             max(nuest,mv+nvest)
c            0< u(i-1)<u(i)< pi,i=2,..,mu,
c            -pi<=v(1)< pi, v(1)<v(i-1)<v(i)<v(1)+2*pi, i=3,...,mv
c            if iopt(1)=-1: 8<=nu<=min(nuest,mu+6+iopt(2)+iopt(3))
c                           0<tu(5)<tu(6)<...<tu(nu-4)< pi
c                           8<=nv<=min(nvest,mv+7)
c                           v(1)<tv(5)<tv(6)<...<tv(nv-4)<v(1)+2*pi
c                    the schoenberg-whitney conditions, i.e. there must
c                    be subset of grid co-ordinates uu(p) and vv(q) such
c                    that   tu(p) < uu(p) < tu(p+4) ,p=1,...,nu-4
c                     (iopt(2)=1 and iopt(3)=1 also count for a uu-value
c                           tv(q) < vv(q) < tv(q+4) ,q=1,...,nv-4
c                     (vv(q) is either a value v(j) or v(j)+2*pi)
c            if iopt(1)>=0: s>=0
c                       if s=0: nuest>=mu+6+iopt(2)+iopt(3), nvest>=mv+7
c            if one of these conditions is found to be violated,control
c            is immediately repassed to the calling program. in that
c            case there is no approximation returned.
c
c further comments:
c   spgrid does not allow individual weighting of the data-values.
c   so, if these were determined to widely different accuracies, then
c   perhaps the general data set routine sphere should rather be used
c   in spite of efficiency.
c   by means of the parameter s, the user can control the tradeoff
c   between closeness of fit and smoothness of fit of the approximation.
c   if s is too large, the spline will be too smooth and signal will be
c   lost ; if s is too small the spline will pick up too much noise. in
c   the extreme cases the program will return an interpolating spline if
c   s=0 and the constrained least-squares polynomial(degrees 3,0)if s is
c   very large. between these extremes, a properly chosen s will result
c   in a good compromise between closeness of fit and smoothness of fit.
c   to decide whether an approximation, corresponding to a certain s is
c   satisfactory the user is highly recommended to inspect the fits
c   graphically.
c   recommended values for s depend on the accuracy of the data values.
c   if the user has an idea of the statistical errors on the data, he
c   can also find a proper estimate for s. for, by assuming that, if he
c   specifies the right s, spgrid will return a spline s(u,v) which
c   exactly reproduces the function underlying the data he can evaluate
c   the sum((r(i,j)-s(u(i),v(j)))**2) to find a good estimate for this s
c   for example, if he knows that the statistical errors on his r(i,j)-
c   values is not greater than 0.1, he may expect that a good s should
c   have a value not larger than mu*mv*(0.1)**2.
c   if nothing is known about the statistical error in r(i,j), s must
c   be determined by trial and error, taking account of the comments
c   above. the best is then to start with a very large value of s (to
c   determine the least-squares polynomial and the corresponding upper
c   bound fp0 for s) and then to progressively decrease the value of s
c   ( say by a factor 10 in the beginning, i.e. s=fp0/10,fp0/100,...
c   and more carefully as the approximation shows more detail) to
c   obtain closer fits.
c   to economize the search for a good s-value the program provides with
c   different modes of computation. at the first call of the routine, or
c   whenever he wants to restart with the initial set of knots the user
c   must set iopt(1)=0.
c   if iopt(1) = 1 the program will continue with the knots found at
c   the last call of the routine. this will save a lot of computation
c   time if spgrid is called repeatedly for different values of s.
c   the number of knots of the spline returned and their location will
c   depend on the value of s and on the complexity of the shape of the
c   function underlying the data. if the computation mode iopt(1) = 1
c   is used, the knots returned may also depend on the s-values at
c   previous calls (if these were smaller). therefore, if after a number
c   of trials with different s-values and iopt(1)=1,the user can finally
c   accept a fit as satisfactory, it may be worthwhile for him to call
c   spgrid once more with the chosen value for s but now with iopt(1)=0.
c   indeed, spgrid may then return an approximation of the same quality
c   of fit but with fewer knots and therefore better if data reduction
c   is also an important objective for the user.
c   the number of knots may also depend on the upper bounds nuest and
c   nvest. indeed, if at a certain stage in spgrid the number of knots
c   in one direction (say nu) has reached the value of its upper bound
c   (nuest), then from that moment on all subsequent knots are added
c   in the other (v) direction. this may indicate that the value of
c   nuest is too small. on the other hand, it gives the user the option
c   of limiting the number of knots the routine locates in any direction
c   for example, by setting nuest=8 (the lowest allowable value for
c   nuest), the user can indicate that he wants an approximation which
c   is a simple cubic polynomial in the variable u.
c
c  other subroutines required:
c    fpspgr,fpchec,fpchep,fpknot,fpopsp,fprati,fpgrsp,fpsysy,fpback,
c    fpbacp,fpbspl,fpcyt1,fpcyt2,fpdisc,fpgivs,fprota
c
c  references:
c   dierckx p. : fast algorithms for smoothing data over a disc or a
c                sphere using tensor product splines, in "algorithms
c                for approximation", ed. j.c.mason and m.g.cox,
c                clarendon press oxford, 1987, pp. 51-65
c   dierckx p. : fast algorithms for smoothing data over a disc or a
c                sphere using tensor product splines, report tw73, dept.
c                computer science,k.u.leuven, 1985.
c   dierckx p. : curve and surface fitting with splines, monographs on
c                numerical analysis, oxford university press, 1993.
c
c  author:
c    p.dierckx
c    dept. computer science, k.u. leuven
c    celestijnenlaan 200a, b-3001 heverlee, belgium.
c    e-mail : Paul.Dierckx@cs.kuleuven.ac.be
c
c  creation date : july 1985
c  latest update : march 1989
c
c  ..
c  ..scalar arguments..
      real r0,r1,s,fp
      integer mu,mv,nuest,nvest,nu,nv,lwrk,kwrk,ier
c  ..array arguments..
      integer iopt(3),ider(4),iwrk(kwrk)
      real u(mu),v(mv),r(mu*mv),c((nuest-4)*(nvest-4)),tu(nuest),
     * tv(nvest),wrk(lwrk)
c  ..local scalars..
      real per,pi,tol,uu,ve,rmax,rmin,one,half,rn,rb,re
      integer i,i1,i2,j,jwrk,j1,j2,kndu,kndv,knru,knrv,kwest,l,
     * ldr,lfpu,lfpv,lwest,lww,m,maxit,mumin,muu,nc
c  ..function references..
      real atan2
      integer max0
c  ..subroutine references..
c    fpchec,fpchep,fpspgr
c  ..
c  set constants
      one = 1
      half = 0.5e0
      pi = atan2(0.,-one)
      per = pi+pi
      ve = v(1)+per
c  we set up the parameters tol and maxit.
      maxit = 20
      tol = 0.1e-02
c  before starting computations, a data check is made. if the input data
c  are invalid, control is immediately repassed to the calling program.
      ier = 10
      if(iopt(1).lt.(-1) .or. iopt(1).gt.1) go to 200
      if(iopt(2).lt.0 .or. iopt(2).gt.1) go to 200
      if(iopt(3).lt.0 .or. iopt(3).gt.1) go to 200
      if(ider(1).lt.(-1) .or. ider(1).gt.1) go to 200
      if(ider(2).lt.0 .or. ider(2).gt.1) go to 200
      if(ider(2).eq.1 .and. iopt(2).eq.0) go to 200
      if(ider(3).lt.(-1) .or. ider(3).gt.1) go to 200
      if(ider(4).lt.0 .or. ider(4).gt.1) go to 200
      if(ider(4).eq.1 .and. iopt(3).eq.0) go to 200
      mumin = 4
      if(ider(1).ge.0) mumin = mumin-1
      if(iopt(2).eq.1 .and. ider(2).eq.1) mumin = mumin-1
      if(ider(3).ge.0) mumin = mumin-1
      if(iopt(3).eq.1 .and. ider(4).eq.1) mumin = mumin-1
      if(mumin.eq.0) mumin = 1
      if(mu.lt.mumin .or. mv.lt.4) go to 200
      if(nuest.lt.8 .or. nvest.lt.8) go to 200
      m = mu*mv
      nc = (nuest-4)*(nvest-4)
      lwest = 12+nuest*(mv+nvest+3)+24*nvest+4*mu+8*mv+
     * max0(nuest,mv+nvest)
      kwest = 5+mu+mv+nuest+nvest
      if(lwrk.lt.lwest .or. kwrk.lt.kwest) go to 200
      if(u(1).le.0. .or. u(mu).ge.pi) go to 200
      if(mu.eq.1) go to 30
      do 20 i=2,mu
        if(u(i-1).ge.u(i)) go to 200
  20  continue
  30  if(v(1).lt. (-pi) .or. v(1).ge.pi ) go to 200
      if(v(mv).ge.v(1)+per) go to 200
      do 40 i=2,mv
        if(v(i-1).ge.v(i)) go to 200
  40  continue
      if(iopt(1).gt.0) go to 140
c  if not given, we compute an estimate for r0.
      rn = mv
      if(ider(1).lt.0) go to 45
      rb = r0
      go to 55
  45  rb = 0.
      do 50 i=1,mv
         rb = rb+r(i)
  50  continue
      rb = rb/rn
c  if not given, we compute an estimate for r1.
  55  if(ider(3).lt.0) go to 60
      re = r1
      go to 70
  60  re = 0.
      j = m
      do 65 i=1,mv
         re = re+r(j)
         j = j-1
  65  continue
      re = re/rn
c  we determine the range of r-values.
  70  rmin = rb
      rmax = re
      do 80 i=1,m
         if(r(i).lt.rmin) rmin = r(i)
         if(r(i).gt.rmax) rmax = r(i)
  80  continue
      wrk(5) = rb
      wrk(6) = 0.
      wrk(7) = 0.
      wrk(8) = re
      wrk(9) = 0.
      wrk(10) = 0.
      wrk(11) = rmax -rmin
      wrk(12) = wrk(11)
      iwrk(4) = mu
      iwrk(5) = mu
      if(iopt(1).eq.0) go to 140
      if(nu.lt.8 .or. nu.gt.nuest) go to 200
      if(nv.lt.11 .or. nv.gt.nvest) go to 200
      j = nu
      do 90 i=1,4
        tu(i) = 0.
        tu(j) = pi
        j = j-1
  90  continue
      l = 13
      wrk(l) = 0.
      if(iopt(2).eq.0) go to 100
      l = l+1
      uu = u(1)
      if(uu.gt.tu(5)) uu = tu(5)
      wrk(l) = uu*half
 100  do 110 i=1,mu
        l = l+1
        wrk(l) = u(i)
 110  continue
      if(iopt(3).eq.0) go to 120
      l = l+1
      uu = u(mu)
      if(uu.lt.tu(nu-4)) uu = tu(nu-4)
      wrk(l) = uu+(pi-uu)*half
 120  l = l+1
      wrk(l) = pi
      muu = l-12
      call fpchec(wrk(13),muu,tu,nu,3,ier)
      if(ier.ne.0) go to 200
      j1 = 4
      tv(j1) = v(1)
      i1 = nv-3
      tv(i1) = ve
      j2 = j1
      i2 = i1
      do 130 i=1,3
        i1 = i1+1
        i2 = i2-1
        j1 = j1+1
        j2 = j2-1
        tv(j2) = tv(i2)-per
        tv(i1) = tv(j1)+per
 130  continue
      l = 13
      do 135 i=1,mv
        wrk(l) = v(i)
        l = l+1
 135  continue
      wrk(l) = ve
      call fpchep(wrk(13),mv+1,tv,nv,3,ier)
      if(ier) 200,150,200
 140  if(s.lt.0.) go to 200
      if(s.eq.0. .and. (nuest.lt.(mu+6+iopt(2)+iopt(3)) .or.
     * nvest.lt.(mv+7)) ) go to 200
c  we partition the working space and determine the spline approximation
 150  ldr = 5
      lfpu = 13
      lfpv = lfpu+nuest
      lww = lfpv+nvest
      jwrk = lwrk-12-nuest-nvest
      knru = 6
      knrv = knru+mu
      kndu = knrv+mv
      kndv = kndu+nuest
      call fpspgr(iopt,ider,u,mu,v,mv,r,m,rb,re,s,nuest,nvest,tol,maxit,
     * nc,nu,tu,nv,tv,c,fp,wrk(1),wrk(2),wrk(3),wrk(4),wrk(lfpu),
     * wrk(lfpv),wrk(ldr),wrk(11),iwrk(1),iwrk(2),iwrk(3),iwrk(4),
     * iwrk(5),iwrk(knru),iwrk(knrv),iwrk(kndu),iwrk(kndv),wrk(lww),
     * jwrk,ier)
 200  return
      end


module constants

    integer, parameter :: sgl = selected_real_kind ( p=6)
    integer, parameter :: dbl = selected_real_kind ( p=13 )
    integer, parameter :: long = selected_real_kind ( p=9 )
    real(kind=dbl), parameter :: eOverAmu = 9.58084d7
    real(kind=dbl), parameter :: mpc2 = 938271998.38
    real(kind=dbl), parameter :: c = 2.99792458d8
    real(kind=dbl), parameter :: pi = 3.141592653597932384
    real(kind=dbl), parameter :: q = 1.60217646d-19
    real(kind=dbl), parameter :: xme = 9.10938188d-31
    real(kind=dbl), parameter :: xmh = 1.67262158d-27
    real(kind=dbl), parameter :: const_amu = 1.66053904d-27
    real(kind=dbl), parameter :: eps0 = 8.854187817d-12
    complex, parameter :: zi = cmplx ( 0.0, 1.0 )
    real(kind=dbl), parameter :: mu0 = 1.2566370614d-06
    real(kind=dbl), parameter ::  clight = 299792458.0
    complex :: metal = ( 1e8,1e8 )

end module constants


      DOUBLE PRECISION FUNCTION norm2(score,size1,size2)
*     .. Scalar Arguments ..
      DOUBLE PRECISION score
      INTEGER size1
      INTEGER size2
*     ..
*     .. Array Arguments ..
*     ..
*
*  Purpose
*  =======
*
*     Compute size normalization (norm2 of Pelta et al. (2008)) of
*     tableau matching score
*
*     norm2(struct1, struct2) = 2*score / (#sses(struct1) + #sses(struct2))
*
*   Parmeters:
*        score - tableau matching score
*        size1 - number of SSEs in struccture 1
*        size2 - number of SSEs in structure 2
*
*  Return value: norm2 as above.
*
*     $Id: drecip.F 2969 2009-11-22 01:29:39Z astivala $
*
      intrinsic dble
      norm2 = 2.0d0 * score / dble(size1 + size2)
      END


SUBROUTINE rel_LenseThirring (Zsat, Zearth,  GMearth, gama, clight , a_LenseThirring)

! ----------------------------------------------------------------------
! SUBROUTINE: rel_LenseThirring.f90
! ----------------------------------------------------------------------
! Purpose:
! Relativistic effects : Lense-Thirring
!  Relativistic corrections (Lense-Thirring term) to the acceleration of an
!  Earth artificial satellite according to the formula adopted by the IERS
!  Conventions 2010.
! ----------------------------------------------------------------------
! Input arguments:
! - Zsat     : 		Satellite's state vector with respect to the Earth
! - Zearth   : 		Earth's state vector with respect to the Sun
!   				z = [x y z Vx Vy Vz]'
! - GMearth : 		Gravitational coefficient of Earth
! - GMsun   : 		Gravitational coefficient of Sun
! - clight	: 		Speed of light
! - gama 	: 		PPN (parameterized post-Newtonian) parameters
!
!
! Output arguments:
! - a_LenseThirring:	Satellite acceleration vector of relativistic corrections
!               		a_relativ = [ax; ay; az]
! ----------------------------------------------------------------------
! Author :	Dr. Thomas Papanikolaou, Cooperative Research Centre for Spatial Information, Australia
! Created:	24 November 2015
! ----------------------------------------------------------------------

      USE mdl_precision
      !USE mdl_num
      IMPLICIT NONE

! ---------------------------------------------------------------------------
! Dummy arguments declaration
! ---------------------------------------------------------------------------
! IN
      REAL (KIND = prec_q), INTENT(IN), DIMENSION(6) :: Zsat,Zearth
      REAL (KIND = prec_q), INTENT(IN) :: GMearth
      REAL (KIND = prec_q), INTENT(IN) :: gama
      REAL (KIND = prec_q), INTENT(IN) :: clight

! OUT
      REAL (KIND = prec_q), INTENT(OUT), DIMENSION(3) :: a_LenseThirring
! ---------------------------------------------------------------------------

! ---------------------------------------------------------------------------
! Local variables declaration
! ---------------------------------------------------------------------------
      REAL (KIND = prec_q), DIMENSION(3) :: rsat,vsat , rearth,vearth , Jearth
      REAL (KIND = prec_q), DIMENSION(3) :: prodc_rv , prodc_vJ
      REAL (KIND = prec_q) :: prodd_rJ
!      REAL (KIND = prec_q) :: GMearth, GMsun
      REAL (KIND = prec_q) :: lsat, learth
! ---------------------------------------------------------------------------

! ---------------------------------------------------------------------------
! Satellite vectors
rsat = (/Zsat(1), Zsat(2), Zsat(3) /)
vsat = (/ Zsat(4), Zsat(5), Zsat(6) /)

! Earth-Satellite distance
lsat = sqrt( rsat(1)**2 + rsat(2)**2 + rsat(3)**2 )
! ---------------------------------------------------------------------------

! ---------------------------------------------------------------------------
! Earth vectors
rearth = (/ Zearth(1), Zearth(2), Zearth(3) /)
vearth = (/ Zearth(4), Zearth(5), Zearth(6) /)

! Earth's angular momentum per unit mass
CALL productcross (rearth,vearth , Jearth)
!print *,"|Jearth|", sqrt(Jearth(1)**2 + Jearth(2)**2 + Jearth(3)**2)

! Sun-Earth distance
learth = sqrt(rearth(1)**2 + rearth(2)**2 + rearth(3)**2)
! ---------------------------------------------------------------------------

CALL productcross(rsat,vsat , prodc_rv)
CALL productdot(rsat,Jearth , prodd_rJ)
CALL productcross(vsat,Jearth , prodc_vJ)

! ---------------------------------------------------------------------------
! Relativistic effects: Lense-Thirring term
! ---------------------------------------------------------------------------
! Lense-Thirring (precession,frame-dragging) terms
a_LenseThirring = (1.0D0 + gama) * (GMearth / (clight**2 * lsat**3)) * 	&
                  ( (3.0D0/lsat**2) * prodc_rv * prodd_rJ + prodc_vJ )
! ---------------------------------------------------------------------------

END


CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C BenchIT - Performance Measurement for Scientific Applications
C Contact: developer@benchit.org
C
C $Id: matmul.f 1 2009-09-11 12:26:19Z william $
C $URL: svn+ssh://william@rupert.zih.tu-dresden.de/svn-base/benchit-root/BenchITv6/kernel/numerical/matmul/F77/MPI/0/MPI_C/matmul.f $
C For license details see COPYING in the package base directory
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C Kernel: Matrix multiply (Fortran 77) with MPI
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC

      subroutine tstcas( n, m, itype, a, b, c)
      Integer n, m, itype
      Real*8 a( n, n ), b( n, n ), c( n, n ), temp

      Integer i11 ,j1 ,j2 , i, j

C     **** Initialization
      i11 = 0
      j1 = 0
      j2 = 0
      i = 0
      j = 0

      if ( itype.eq.1 ) then
         Do i11 = 1, m
            do j = 1, n
               do i = 1, n
                  do k = 1, n
                     c( i, j ) = c( i, j ) + a( i, k ) * b( k ,j )
                  enddo
               end do
            end do
         enddo
      else
         if ( itype.eq.2 ) then
            do i11 = 1, m
               do j = 1, n
                  do i = 1, n
                     temp = c( i, j )
                     do k = 1, n
                        temp = temp + a( i, k ) * b( k, j )
                     enddo
                     c( i, j ) = temp
                  enddo
               end do
            end do
         elseif ( itype.eq.3 ) then
            do i11 = 1, m
               do j = 1, n
                  do k = 1, n
                     do i = 1, n
                        c( i, j ) = c( i, j ) + a( i, k ) * b( k, j )
                     enddo
                  enddo
               end do
            end do
         elseif ( itype.eq.4 ) then
            do i11 = 1, m
               do k = 1, n
                  do j = 1, n
                     do i = 1, n
                        c( i, j ) = c( i, j ) + a( i, k ) * b( k, j )
                     enddo
                  enddo
               end do
            end do
         elseif ( itype.eq.5 ) then
            do i11 = 1, m
               do k = 1, n
                  do i = 1, n
                     do j = 1, n
                        c( i, j ) = c( i, j ) + a( i, k ) * b( k, j )
                     enddo
                  enddo
               end do
            end do
         elseif ( itype.eq.6 ) then
            do i11 = 1, m
               do i = 1, n
                  do k = 1, n
                     do j = 1, n
                        c( i, j ) = c( i, j ) + a( i, k ) * b( k, j )
                     enddo
                  enddo
               end do
            end do
         elseif ( itype.eq.7 ) then
            do i11 = 1, m
               do i = 1, n
                  do j = 1, n
                     do k = 1, n
                        c( i, j ) = c( i, j ) + a( i, k ) * b( k, j )
                     enddo
                  enddo
               end do
            end do
         endif
      endif

C      sum = 0
C      Do j=1,n
C         do i=1,n
C            sum = sum + c(i,j)
C         enddo
C      enddo
      end


module mod_define_embedded_RK_methods
! Module containing subroutines and functions defining the Runge-Kutta-Fehlberg (RKF45) embedded method and
! the Dormand-Prince (DP54) embedded method
    use mod_kinds,      only: rk,ik
    use mod_constants,  only: ZERO
    implicit none

   !!
   !! Embedded Runge-Kutta (RK) methods use two different Runge-Kutta methods of different orders, p and p' (can be p + 1/p - 1)
   !! to estimate the local truncation error in the method being used to advance the solution and the estimate is then used to
   !! adjust the time step size which leads to faster convergence
   !!
   !! In the RKF45 method, a 5th order RK method is used to estimate the error in a 4th order RK method
   !!
   !! In the DP54 method, a 4th order RK method is used to estimate the local error in a 5th order RK method
   !!
   !! Both the methods are defined by their Butcher tableaus (see the reference below for more information on the Butcher tableau
   !! and both the methods)
   !!
   !! Reference: Hairer, E., Norsett, S.P., Wanner, G., Solving Ordinary Differential Equations I, Vol. 8,
   !!            Springer Series in Computational Mathematics, Springer-Verlag, 1991
   !!
   !! The subroutines in this module return the number of stages and the coefficients (as defined in the Butecher tableau) for
   !! both methods
   !!
contains

    !> Define the Runge-Kutta-Fehlberg method (RKF45 with 6 stages)
    !!
    !! @author Mayank Sharma
    !! @date   1/20/2017
    !!
    !! @param[out]  nstage - Number of stages in the RKF45 method
    !! @param[out]  p      - Order of the solution advancing Runge-Kutta method
    !! @param[out]  a      - Array of coefficients for calculating stagewise updates
    !! @param[out]  b      - Array of coefficients for summing stagewise updates to get final update (4th order)
    !! @param[out]  b_app  - Array of coefficients for summing stagewise updates for 5th order solution
    !!
    !------------------------------------------------------------------------------------------------------------------
    subroutine RKF45(nstage,p,a,b,b_app)
        integer(ik),             intent(inout)      :: nstage, p
        real(rk),   allocatable, intent(inout)      :: a(:,:)
        real(rk),   allocatable, intent(inout)      :: b(:)
        real(rk),   allocatable, intent(inout)      :: b_app(:)

        !
        ! Set number of stages
        !
        nstage = 6

        p = 4

        if (allocated(a) .and. allocated(b) .and. allocated(b_app)) deallocate(a,b,b_app)
        allocate(a(nstage,nstage),b(nstage),b_app(nstage))

        !
        ! a is a lower triangular matrix
        !
        a = ZERO

        !
        ! Set the values of the remaining coefficients in a
        !
        a(2,1) = 1._rk/4._rk
        a(3,1) = 3._rk/32._rk; a(3,2) = 9._rk/32._rk
        a(4,1) = 1932._rk/2197._rk; a(4,2) = -7200._rk/2197._rk; a(4,3) = 7296._rk/2197._rk
        a(5,1) = 439._rk/216._rk; a(5,2) = -8._rk; a(5,3) = 3680._rk/513._rk; a(5,4) = -845._rk/4104._rk
        a(6,1) = -8._rk/27._rk; a(6,2) = 2._rk; a(6,3) = -3544._rk/2565._rk; a(6,4) = 1859._rk/4104._rk; a(6,5) = -11._rk/40._rk

        !
        ! Set the values of the coefficients in b
        !
        b = [25.0_rk/216.0_rk, 0._rk, 1408._rk/2565._rk, 2197._rk/4104._rk, -1._rk/5._rk, 0._rk]

        !
        ! Set the values of the coefficients in b_app
        !
        b_app = [16._rk/135._rk, 0._rk, 6656._rk/12825._rk, 28561._rk/56430._rk, -9._rk/50._rk, 2._rk/55._rk]

    end subroutine RKF45
    !******************************************************************************************************************

    !> Define the Dormand-Prince method (DP54 with 7 stages)
    !!
    !! @author Mayank Sharma
    !! @date   1/20/2017
    !!
    !! @param[out]  nstage - Number of stages in the DP54 method
    !! @param[out]  p      - Order of the solution advancing Runge-Kutta method
    !! @param[out]  a      - Array of coefficients for calculating stagewise updates
    !! @param[out]  b      - Array of coefficients for summing stagewise updates to get final update (5th order)
    !! @param[out]  b_app  - Array of coefficients for summing stagewise updates for 4th order method
    !!
    !------------------------------------------------------------------------------------------------------------------
    subroutine DP54(nstage,p,a,b,b_app)
        integer(ik),             intent(inout)      :: nstage, p
        real(rk),   allocatable, intent(inout)      :: a(:,:)
        real(rk),   allocatable, intent(inout)      :: b(:)
        real(rk),   allocatable, intent(inout)      :: b_app(:)

        !
        ! Set number of stages
        !
        nstage = 7

        p = 5

        if (allocated(a) .and. allocated(b) .and. allocated(b_app)) deallocate(a,b,b_app)
        allocate(a(nstage,nstage),b(nstage),b_app(nstage))

        !
        ! a is a lower triangular matrix
        !
        a = ZERO

        !
        ! Set the values of the remaining coefficients in a
        !
        a(2,1) = 1._rk/5._rk
        a(3,1) = 3._rk/40._rk; a(3,2) = 9._rk/40._rk
        a(4,1) = 44._rk/45._rk; a(4,2) = -56._rk/15._rk; a(4,3) = 32._rk/9._rk
        a(5,1) = 19372._rk/6561._rk; a(5,2) = -25360._rk/2187._rk; a(5,3) = 64448._rk/6561._rk; a(5,4) = -212._rk/729._rk
        a(6,1) = 9017._rk/3168._rk; a(6,2) = -355._rk/33._rk; a(6,3) = 46732._rk/5247._rk; a(6,4) = 49._rk/176._rk
        a(6,5) = -5103._rk/18656._rk
        a(7,1) = 35._rk/384._rk; a(7,2) = 0._rk; a(7,3) = 500._rk/1113._rk; a(7,4) = 125._rk/192._rk; a(7,5) = -2187._rk/6784._rk
        a(7,6) = 11._rk/84._rk

        !
        ! Set the values of the coefficient in b
        ! Note that DP54 uses the FSAL (first same as last) strategy where the new solution is added as the 7th stage
        !
        b = [35._rk/384._rk, 0._rk, 500._rk/1113._rk, 125._rk/192._rk, -2187._rk/6784._rk, 11._rk/84._rk, 0._rk]

        !
        ! Set the values of the coefficients in b_app
        !
        b_app = [5179._rk/57600._rk, 0._rk, 7571._rk/16695._rk, 393._rk/640._rk, -92097._rk/339200._rk, 187._rk/2100._rk, 1._rk/40._rk]

    end subroutine DP54
    !******************************************************************************************************************

    !> Select embedded Runge_kutta method based on input
    !!
    !! @author Mayank Sharma
    !! @date   1/23/2017
    !!
    !! @param[in]   time_scheme - String denoting the embedded method to be used from user input
    !1 @param[out]  nstage      - Number of stages in the selected embedded method
    !! @param[out]  p           - Order of the solution advancing Runge-Kutta method
    !! @param[out]  a           - Array of coefficients for calculating stagewise updates
    !! @param[out]  b           - Array of coefficients for summing stagewise updates of solutiona dvancing method
    !! @param[out]  b_app       - Array of coefficients for summing stagewise updates of error estimating method
    !!
    !------------------------------------------------------------------------------------------------------------------
    subroutine method_selector(time_scheme,nstage,p,a,b,b_app)
        character(len = :), allocatable, intent(in)     :: time_scheme
        integer(ik),                     intent(inout)  :: nstage, p
        real(rk),           allocatable, intent(inout)  :: a(:,:)
        real(rk),           allocatable, intent(inout)  :: b(:)
        real(rk),           allocatable, intent(inout)  :: b_app(:)

        select case(time_scheme)

            case('Runge-Kutta-Fehlberg Method', 'RKF', 'RKF45')
                call RKF45(nstage,p,a,b,b_app)

            case('Dormand-Prince Method', 'DP54')
                call DP54(nstage,p,a,b,b_app)

        end select

    end subroutine method_selector
    !******************************************************************************************************************

end module mod_define_embedded_RK_methods