module fcn_scalar_adv_diff_bl_solution
#include <messenger.h>
    use mod_kinds,      only: rk,ik
    use mod_constants,  only: ZERO, ONE, TWO, THREE, FIVE
    use type_point,     only: point_t
    use type_point_ad,  only: point_ad_t
    use type_function,  only: function_t
    use DNAD_D
    implicit none

    !>  scalar_adv_diff_bl_solution function.
    !!
    !!  Three 1D scalar_adv_diff_bl_solution functions are computed; one for each dimension. They are multiplied
    !!  together to create a 3D version of the function.
    !!
    !!  \f$  f_x(t,\vec{x}) = a e^{- \frac{(x-b_x)^2}{2c^2} }    \\
    !!       f_y(t,\vec{x}) = a e^{- \frac{(y-b_y)^2}{2c^2} }    \\
    !!       f_z(t,\vec{x}) = a e^{- \frac{(z-b_z)^2}{2c^2} }    \\
    !!       f(t,\vec{x}) = f_x * f_y * f_z                      \f$
    !!
    !!  Function parameters:
    !!
    !!  \f$ a   -   \text{Amplitude of the distribution}   \\
    !!      b_i -   \text{Offset in coordinate 'i'}        \\
    !!      c   -   \text{Width of the distribution}   \f$
    !!
    !!  @author Nathan A. Wukie
    !!  @date   2/1/2016
    !!
    !-------------------------------------------------------------------------------------
    type, extends(function_t), public :: scalar_adv_diff_bl_solution_f

    contains

        procedure   :: init
        procedure   :: compute

    end type scalar_adv_diff_bl_solution_f
    !*************************************************************************************

contains

    !>
    !!
    !!  @author Nathan A. Wukie
    !!  @date   2/2/2016
    !!
    !-------------------------------------------------------------------------
    subroutine init(self)
        class(scalar_adv_diff_bl_solution_f),  intent(inout)   :: self

        !
        ! Set function name
        !
        call self%set_name("scalar_adv_diff_bl_solution")

        !
        ! Set function options to default settings
        !
        call self%add_option('mu',0.05_rk)
        call self%add_option('cx',1._rk)

    end subroutine init
    !*************************************************************************

    !>
    !!
    !!  @author Nathan A. Wukie
    !!  @date   2/2/2016
    !!
    !----------------------------------------------------------------------------------
    impure elemental function compute(self,time,coord) result(val)
        class(scalar_adv_diff_bl_solution_f),  intent(inout)  :: self
        real(rk),           intent(in)  :: time
        type(point_ad_t),   intent(in)  :: coord

        type(AD_D)                      :: val

        integer(ik) :: fcn_dim
        type(AD_D)  :: x, y, z
        real(rk)    :: mu, cx

        !
        ! Get inputs and function parameters
        !
        x = coord%c1_
        y = coord%c2_
        z = coord%c3_

        mu = self%get_option_value('mu')
        cx = self%get_option_value('cx')

        val = (ONE-exp((x-ONE)*(cx/mu)))/(ONE-exp(-cx/mu))
    end function compute
    !***********************************************************************************

end module fcn_scalar_adv_diff_bl_solution


      subroutine jacobi(a,v,n)
c
c***********************************************************************
c
c     diagonalisation of real symmetric matices by jacobi method
c
c     input parameters:
c
c     a(n,n) is the matrix to be diagonalised
c     v(n,n) is the eigenvector matrix
c     n   is the dimension of the matrices
c
c     jacobi processes lower triangle only (upper triangle unchanged)
c
c     variable rho sets absolute tolerance on convergence
c     variable tes is a moving tolerance that diminishes
c     on each pass until at true convergence tes<rho
c
c     copyright daresbury laboratory 1993
c     author w.smith 1993
c
c***********************************************************************
c
      implicit real*8(a-h,o-z)
      logical pass
      dimension a(n,n),v(n,n)
      rho=1.0d-16
      tes=0.0d0
      scl=0.0d0
c
c     initialize eigenvectors
      do i=1,n
         do j=1,n
            v(i,j)=0.0d0
         enddo
         v(i,i)=1.0d0
      enddo
c
c     rescale matrix for optimal accuracy
      do i=1,n
         if(abs(a(i,i)).gt.scl)scl=abs(a(i,i))
      enddo
      do i=1,n
         do j=1,i
            a(i,j)=a(i,j)/scl
         enddo
      enddo
c
c     set initial value of moving tolerance
      do i=2,n
         do j=1,i-1
            tes=tes+2.0d0*a(i,j)*a(i,j)
         enddo
      enddo
      tes=sqrt(tes)
  100 tes=tes/dble(n)
      if(tes.lt.rho)tes=rho
c
c     jacobi diagonalisation
  200 pass=.false.
      do i=2,n
         do j=1,i-1
            if(abs(a(i,j)).ge.tes)then
               pass=.true.
               v1=a(j,j)
               v2=a(i,j)
               v3=a(i,i)
               u=0.5d0*(v1-v3)
               if(abs(u).lt.rho)then
                  omg=-1.0d0
               else
                  omg=-v2/sqrt(v2*v2+u*u)
                  if(u.lt.0.0d0)omg=-omg
               endif
               s=omg/sqrt(2.0d0*(1.0d0+sqrt(1.0d0-omg*omg)))
               c=sqrt(1.0d0-s*s)
               do k=1,n
                  if(k.ge.i)then
                     tem=a(k,j)*c-a(k,i)*s
                     a(k,i)=a(k,j)*s+a(k,i)*c
                     a(k,j)=tem
                  else if(k.lt.j)then
                     tem=a(j,k)*c-a(i,k)*s
                     a(i,k)=a(j,k)*s+a(i,k)*c
                     a(j,k)=tem
                  else
                     tem=a(k,j)*c-a(i,k)*s
                     a(i,k)=a(k,j)*s+a(i,k)*c
                     a(k,j)=tem
                  endif
                  tem=v(k,j)*c-v(k,i)*s
                  v(k,i)=v(k,j)*s+v(k,i)*c
                  v(k,j)=tem
               enddo
               a(j,j)=v1*c*c+v3*s*s-2.0d0*v2*s*c
               a(i,i)=v1*s*s+v3*c*c+2.0d0*v2*s*c
               a(i,j)=(v1-v3)*s*c+v2*(c*c-s*s)
            endif
         enddo
      enddo
c
c     recycle until moving tolerance satisfied
      if(pass)go to 200
c
c     recycle until absolute tolerance satisfied
      if(tes.gt.rho)go to 100
c
c     rescale matrix
      do i=1,n
         do j=1,i
            a(i,j)=scl*a(i,j)
         enddo
      enddo
      return
      end


program problem60
  use euler
  implicit none
  integer, parameter          :: limit=10000
  logical, dimension(limit)   :: primesl
  integer*8, dimension(limit) :: primes
  integer*8                   :: i,a,b,c,d,e
  integer                     :: count
  logical, dimension(4)       :: ps

  count=0
  do i=1,limit
     if (is_prime(i) .and. (mod(i,3)/=2)) then
        count=count+1
        primes(count)=i
        primesl(i)=.true.
     else
        primesl(i)=.false.
     end if
  end do

  do a=1,count
     do b=a+1,count
        ps(1)=predicate(primes(a),primes(b))
        if (.not. ps(1)) cycle
        do c=b+1,count
           ps(1)=predicate(primes(a),primes(c))
           ps(2)=predicate(primes(b),primes(c))
           if (.not. (ps(1) .and. ps(2))) cycle
           do d=c+1,count
              ps(1)=predicate(primes(a),primes(d))
              ps(2)=predicate(primes(b),primes(d))
              ps(3)=predicate(primes(c),primes(d))
              if (.not. (ps(1) .and. ps(2) .and. ps(3))) cycle
              do e=d+1,count
                 ps(1)=predicate(primes(a),primes(e))
                 ps(2)=predicate(primes(b),primes(e))
                 ps(3)=predicate(primes(c),primes(e))
                 ps(4)=predicate(primes(d),primes(e))
                 if (.not. (ps(1) .and. ps(2) .and. ps(3) .and. ps(4))) cycle
                 go to 100
              end do
           end do
        end do
     end do
  end do

100 continue
  print *, primes(a)+primes(b)+primes(c)+primes(d)+primes(e)

contains

  pure function predicate(p1,p2)
    implicit none
    integer*8, intent(in) :: p1,p2
    integer*8             :: temp1,temp2,len1,len2
    logical               :: predicate

    len1=int8(ceiling(log10(dble(p1))))
    len2=int8(ceiling(log10(dble(p2))))
    temp1=p1+p2*(10**(len1))
    temp2=p2+p1*(10**(len2))

    predicate = is_prime(temp1) .and. is_prime(temp2)

  end function predicate

end program problem60


*DECK CBIRY
      SUBROUTINE CBIRY (Z, ID, KODE, BI, IERR)
C***BEGIN PROLOGUE  CBIRY
C***PURPOSE  Compute the Airy function Bi(z) or its derivative dBi/dz
C            for complex argument z.  A scaling option is available
C            to help avoid overflow.
C***LIBRARY   SLATEC
C***CATEGORY  C10D
C***TYPE      COMPLEX (CBIRY-C, ZBIRY-C)
C***KEYWORDS  AIRY FUNCTION, BESSEL FUNCTION OF ORDER ONE THIRD,
C             BESSEL FUNCTION OF ORDER TWO THIRDS
C***AUTHOR  Amos, D. E., (SNL)
C***DESCRIPTION
C
C         On KODE=1, CBIRY computes the complex Airy function Bi(z)
C         or its derivative dBi/dz on ID=0 or ID=1 respectively.
C         On KODE=2, a scaling option exp(abs(Re(zeta)))*Bi(z) or
C         exp(abs(Re(zeta)))*dBi/dz is provided to remove the
C         exponential behavior in both the left and right half planes
C         where zeta=(2/3)*z**(3/2).
C
C         The Airy functions Bi(z) and dBi/dz are analytic in the
C         whole z-plane, and the scaling option does not destroy this
C         property.
C
C         Input
C           Z      - Argument of type COMPLEX
C           ID     - Order of derivative, ID=0 or ID=1
C           KODE   - A parameter to indicate the scaling option
C                    KODE=1  returns
C                            BI=Bi(z)  on ID=0
C                            BI=dBi/dz on ID=1
C                            at z=Z
C                        =2  returns
C                            BI=exp(abs(Re(zeta)))*Bi(z)  on ID=0
C                            BI=exp(abs(Re(zeta)))*dBi/dz on ID=1
C                            at z=Z where zeta=(2/3)*z**(3/2)
C
C         Output
C           BI     - Result of type COMPLEX
C           IERR   - Error flag
C                    IERR=0  Normal return     - COMPUTATION COMPLETED
C                    IERR=1  Input error       - NO COMPUTATION
C                    IERR=2  Overflow          - NO COMPUTATION
C                            (Re(Z) too large with KODE=1)
C                    IERR=3  Precision warning - COMPUTATION COMPLETED
C                            (Result has less than half precision)
C                    IERR=4  Precision error   - NO COMPUTATION
C                            (Result has no precision)
C                    IERR=5  Algorithmic error - NO COMPUTATION
C                            (Termination condition not met)
C
C *Long Description:
C
C         Bi(z) and dBi/dz are computed from I Bessel functions by
C
C                Bi(z) =  c*sqrt(z)*( I(-1/3,zeta) + I(1/3,zeta) )
C               dBi/dz =  c*   z   *( I(-2/3,zeta) + I(2/3,zeta) )
C                    c =  1/sqrt(3)
C                 zeta =  (2/3)*z**(3/2)
C
C         when abs(z)>1 and from power series when abs(z)<=1.
C
C         In most complex variable computation, one must evaluate ele-
C         mentary functions.  When the magnitude of Z is large, losses
C         of significance by argument reduction occur.  Consequently, if
C         the magnitude of ZETA=(2/3)*Z**(3/2) exceeds U1=SQRT(0.5/UR),
C         then losses exceeding half precision are likely and an error
C         flag IERR=3 is triggered where UR=R1MACH(4)=UNIT ROUNDOFF.
C         Also, if the magnitude of ZETA is larger than U2=0.5/UR, then
C         all significance is lost and IERR=4.  In order to use the INT
C         function, ZETA must be further restricted not to exceed
C         U3=I1MACH(9)=LARGEST INTEGER.  Thus, the magnitude of ZETA
C         must be restricted by MIN(U2,U3).  In IEEE arithmetic, U1,U2,
C         and U3 are approximately 2.0E+3, 4.2E+6, 2.1E+9 in single
C         precision and 4.7E+7, 2.3E+15, 2.1E+9 in double precision.
C         This makes U2 limiting is single precision and U3 limiting
C         in double precision.  This means that the magnitude of Z
C         cannot exceed approximately 3.4E+4 in single precision and
C         2.1E+6 in double precision.  This also means that one can
C         expect to retain, in the worst cases on 32-bit machines,
C         no digits in single precision and only 6 digits in double
C         precision.
C
C         The approximate relative error in the magnitude of a complex
C         Bessel function can be expressed as P*10**S where P=MAX(UNIT
C         ROUNDOFF,1.0E-18) is the nominal precision and 10**S repre-
C         sents the increase in error due to argument reduction in the
C         elementary functions.  Here, S=MAX(1,ABS(LOG10(ABS(Z))),
C         ABS(LOG10(FNU))) approximately (i.e., S=MAX(1,ABS(EXPONENT OF
C         ABS(Z),ABS(EXPONENT OF FNU)) ).  However, the phase angle may
C         have only absolute accuracy.  This is most likely to occur
C         when one component (in magnitude) is larger than the other by
C         several orders of magnitude.  If one component is 10**K larger
C         than the other, then one can expect only MAX(ABS(LOG10(P))-K,
C         0) significant digits; or, stated another way, when K exceeds
C         the exponent of P, no significant digits remain in the smaller
C         component.  However, the phase angle retains absolute accuracy
C         because, in complex arithmetic with precision P, the smaller
C         component will not (as a rule) decrease below P times the
C         magnitude of the larger component. In these extreme cases,
C         the principal phase angle is on the order of +P, -P, PI/2-P,
C         or -PI/2+P.
C
C***REFERENCES  1. M. Abramowitz and I. A. Stegun, Handbook of Mathe-
C                 matical Functions, National Bureau of Standards
C                 Applied Mathematics Series 55, U. S. Department
C                 of Commerce, Tenth Printing (1972) or later.
C               2. D. E. Amos, Computation of Bessel Functions of
C                 Complex Argument and Large Order, Report SAND83-0643,
C                 Sandia National Laboratories, Albuquerque, NM, May
C                 1983.
C               3. D. E. Amos, A Subroutine Package for Bessel Functions
C                 of a Complex Argument and Nonnegative Order, Report
C                 SAND85-1018, Sandia National Laboratory, Albuquerque,
C                 NM, May 1985.
C               4. D. E. Amos, A portable package for Bessel functions
C                 of a complex argument and nonnegative order, ACM
C                 Transactions on Mathematical Software, 12 (September
C                 1986), pp. 265-273.
C
C***ROUTINES CALLED  CBINU, I1MACH, R1MACH
C***REVISION HISTORY  (YYMMDD)
C   830501  DATE WRITTEN
C   890801  REVISION DATE from Version 3.2
C   910415  Prologue converted to Version 4.0 format.  (BAB)
C   920128  Category corrected.  (WRB)
C   920811  Prologue revised.  (DWL)
C***END PROLOGUE  CBIRY
      COMPLEX BI, CONE, CSQ, CY, S1, S2, TRM1, TRM2, Z, ZTA, Z3
      REAL AA, AD, AK, ALIM, ATRM, AZ, AZ3, BB, BK, CK, COEF, C1, C2,
     * DIG, DK, D1, D2, ELIM, FID, FMR, FNU, FNUL, PI, RL, R1M5, SFAC,
     * TOL, TTH, ZI, ZR, Z3I, Z3R, R1MACH
      INTEGER ID, IERR, K, KODE, K1, K2, NZ, I1MACH
      DIMENSION CY(2)
      DATA TTH, C1, C2, COEF, PI /6.66666666666666667E-01,
     * 6.14926627446000736E-01,4.48288357353826359E-01,
     * 5.77350269189625765E-01,3.14159265358979324E+00/
      DATA  CONE / (1.0E0,0.0E0) /
C***FIRST EXECUTABLE STATEMENT  CBIRY
      IERR = 0
      NZ=0
      IF (ID.LT.0 .OR. ID.GT.1) IERR=1
      IF (KODE.LT.1 .OR. KODE.GT.2) IERR=1
      IF (IERR.NE.0) RETURN
      AZ = ABS(Z)
      TOL = MAX(R1MACH(4),1.0E-18)
      FID = ID
      IF (AZ.GT.1.0E0) GO TO 60
C-----------------------------------------------------------------------
C     POWER SERIES FOR ABS(Z).LE.1.
C-----------------------------------------------------------------------
      S1 = CONE
      S2 = CONE
      IF (AZ.LT.TOL) GO TO 110
      AA = AZ*AZ
      IF (AA.LT.TOL/AZ) GO TO 40
      TRM1 = CONE
      TRM2 = CONE
      ATRM = 1.0E0
      Z3 = Z*Z*Z
      AZ3 = AZ*AA
      AK = 2.0E0 + FID
      BK = 3.0E0 - FID - FID
      CK = 4.0E0 - FID
      DK = 3.0E0 + FID + FID
      D1 = AK*DK
      D2 = BK*CK
      AD = MIN(D1,D2)
      AK = 24.0E0 + 9.0E0*FID
      BK = 30.0E0 - 9.0E0*FID
      Z3R = REAL(Z3)
      Z3I = AIMAG(Z3)
      DO 30 K=1,25
        TRM1 = TRM1*CMPLX(Z3R/D1,Z3I/D1)
        S1 = S1 + TRM1
        TRM2 = TRM2*CMPLX(Z3R/D2,Z3I/D2)
        S2 = S2 + TRM2
        ATRM = ATRM*AZ3/AD
        D1 = D1 + AK
        D2 = D2 + BK
        AD = MIN(D1,D2)
        IF (ATRM.LT.TOL*AD) GO TO 40
        AK = AK + 18.0E0
        BK = BK + 18.0E0
   30 CONTINUE
   40 CONTINUE
      IF (ID.EQ.1) GO TO 50
      BI = S1*CMPLX(C1,0.0E0) + Z*S2*CMPLX(C2,0.0E0)
      IF (KODE.EQ.1) RETURN
      ZTA = Z*CSQRT(Z)*CMPLX(TTH,0.0E0)
      AA = REAL(ZTA)
      AA = -ABS(AA)
      BI = BI*CMPLX(EXP(AA),0.0E0)
      RETURN
   50 CONTINUE
      BI = S2*CMPLX(C2,0.0E0)
      IF (AZ.GT.TOL) BI = BI + Z*Z*S1*CMPLX(C1/(1.0E0+FID),0.0E0)
      IF (KODE.EQ.1) RETURN
      ZTA = Z*CSQRT(Z)*CMPLX(TTH,0.0E0)
      AA = REAL(ZTA)
      AA = -ABS(AA)
      BI = BI*CMPLX(EXP(AA),0.0E0)
      RETURN
C-----------------------------------------------------------------------
C     CASE FOR ABS(Z).GT.1.0
C-----------------------------------------------------------------------
   60 CONTINUE
      FNU = (1.0E0+FID)/3.0E0
C-----------------------------------------------------------------------
C     SET PARAMETERS RELATED TO MACHINE CONSTANTS.
C     TOL IS THE APPROXIMATE UNIT ROUNDOFF LIMITED TO 1.0E-18.
C     ELIM IS THE APPROXIMATE EXPONENTIAL OVER- AND UNDERFLOW LIMIT.
C     EXP(-ELIM).LT.EXP(-ALIM)=EXP(-ELIM)/TOL    AND
C     EXP(ELIM).GT.EXP(ALIM)=EXP(ELIM)*TOL       ARE INTERVALS NEAR
C     UNDERFLOW AND OVERFLOW LIMITS WHERE SCALED ARITHMETIC IS DONE.
C     RL IS THE LOWER BOUNDARY OF THE ASYMPTOTIC EXPANSION FOR LARGE Z.
C     DIG = NUMBER OF BASE 10 DIGITS IN TOL = 10**(-DIG).
C     FNUL IS THE LOWER BOUNDARY OF THE ASYMPTOTIC SERIES FOR LARGE FNU.
C-----------------------------------------------------------------------
      K1 = I1MACH(12)
      K2 = I1MACH(13)
      R1M5 = R1MACH(5)
      K = MIN(ABS(K1),ABS(K2))
      ELIM = 2.303E0*(K*R1M5-3.0E0)
      K1 = I1MACH(11) - 1
      AA = R1M5*K1
      DIG = MIN(AA,18.0E0)
      AA = AA*2.303E0
      ALIM = ELIM + MAX(-AA,-41.45E0)
      RL = 1.2E0*DIG + 3.0E0
      FNUL = 10.0E0 + 6.0E0*(DIG-3.0E0)
C-----------------------------------------------------------------------
C     TEST FOR RANGE
C-----------------------------------------------------------------------
      AA=0.5E0/TOL
      BB=I1MACH(9)*0.5E0
      AA=MIN(AA,BB)
      AA=AA**TTH
      IF (AZ.GT.AA) GO TO 190
      AA=SQRT(AA)
      IF (AZ.GT.AA) IERR=3
      CSQ=CSQRT(Z)
      ZTA=Z*CSQ*CMPLX(TTH,0.0E0)
C-----------------------------------------------------------------------
C     RE(ZTA).LE.0 WHEN RE(Z).LT.0, ESPECIALLY WHEN IM(Z) IS SMALL
C-----------------------------------------------------------------------
      SFAC = 1.0E0
      ZI = AIMAG(Z)
      ZR = REAL(Z)
      AK = AIMAG(ZTA)
      IF (ZR.GE.0.0E0) GO TO 70
      BK = REAL(ZTA)
      CK = -ABS(BK)
      ZTA = CMPLX(CK,AK)
   70 CONTINUE
      IF (ZI.EQ.0.0E0 .AND. ZR.LE.0.0E0) ZTA = CMPLX(0.0E0,AK)
      AA = REAL(ZTA)
      IF (KODE.EQ.2) GO TO 80
C-----------------------------------------------------------------------
C     OVERFLOW TEST
C-----------------------------------------------------------------------
      BB = ABS(AA)
      IF (BB.LT.ALIM) GO TO 80
      BB = BB + 0.25E0*ALOG(AZ)
      SFAC = TOL
      IF (BB.GT.ELIM) GO TO 170
   80 CONTINUE
      FMR = 0.0E0
      IF (AA.GE.0.0E0 .AND. ZR.GT.0.0E0) GO TO 90
      FMR = PI
      IF (ZI.LT.0.0E0) FMR = -PI
      ZTA = -ZTA
   90 CONTINUE
C-----------------------------------------------------------------------
C     AA=FACTOR FOR ANALYTIC CONTINUATION OF I(FNU,ZTA)
C     KODE=2 RETURNS EXP(-ABS(XZTA))*I(FNU,ZTA) FROM CBINU
C-----------------------------------------------------------------------
      CALL CBINU(ZTA, FNU, KODE, 1, CY, NZ, RL, FNUL, TOL, ELIM, ALIM)
      IF (NZ.LT.0) GO TO 180
      AA = FMR*FNU
      Z3 = CMPLX(SFAC,0.0E0)
      S1 = CY(1)*CMPLX(COS(AA),SIN(AA))*Z3
      FNU = (2.0E0-FID)/3.0E0
      CALL CBINU(ZTA, FNU, KODE, 2, CY, NZ, RL, FNUL, TOL, ELIM, ALIM)
      CY(1) = CY(1)*Z3
      CY(2) = CY(2)*Z3
C-----------------------------------------------------------------------
C     BACKWARD RECUR ONE STEP FOR ORDERS -1/3 OR -2/3
C-----------------------------------------------------------------------
      S2 = CY(1)*CMPLX(FNU+FNU,0.0E0)/ZTA + CY(2)
      AA = FMR*(FNU-1.0E0)
      S1 = (S1+S2*CMPLX(COS(AA),SIN(AA)))*CMPLX(COEF,0.0E0)
      IF (ID.EQ.1) GO TO 100
      S1 = CSQ*S1
      BI = S1*CMPLX(1.0E0/SFAC,0.0E0)
      RETURN
  100 CONTINUE
      S1 = Z*S1
      BI = S1*CMPLX(1.0E0/SFAC,0.0E0)
      RETURN
  110 CONTINUE
      AA = C1*(1.0E0-FID) + FID*C2
      BI = CMPLX(AA,0.0E0)
      RETURN
  170 CONTINUE
      NZ=0
      IERR=2
      RETURN
  180 CONTINUE
      IF(NZ.EQ.(-1)) GO TO 170
      NZ=0
      IERR=5
      RETURN
  190 CONTINUE
      IERR=4
      NZ=0
      RETURN
      END


!     .................................................
!             ____  _       _   ____  _____   _
!            |  _ \| |     |_| |  _ \|  ___| |_|
!            | |_) | |___   _  | |_) | |___   _
!            |  _ /|  _  | | | |  _ /|___  | | |
!            | |   | | | | | | | |    ___| | | |
!            |_|   |_| |_| |_| |_|   |_____| |_|
!     .................................................
!     PhiPsi:     a general-purpose computational
!                 mechanics program written in Fortran.
!     Website:    http://phipsi.top
!     Author:     Shi Fang from Huaiyin Institute of
!                 Technology, HuaiAn, JiangSu, China
!     Contact me: shifang@hyit.edu.cn
!     ------------------------------------------------
!     Please cite the following papers:
!     (1)Shi F, Wang X L, Liu C, Liu H, Wu H A. An
!        XFEM-based method with reduction technique
!        for modeling hydraulic fracture propagation
!        in formations containing frictional natural
!        fractures. Engineering Fracture Mechanics,
!        2017, 173: 64-90.
!     (2)Shi F, Wang X L, Liu C, Liu H, Wu H A. A
!        coupled extended finite element approach
!        for modeling hydraulic fracturing in
!        consideration of proppant. Journal of
!        Natural Gas Science and Engineering, 2016,
!        33: 885-897.
!     (3)Shi F, Wang X L, Liu C, Liu H, Wu H A. An
!        XFEM-based numerical model to calculate
!        conductivity of propped fracture considering
!        proppant transport, embedment and crushing.
!        Journal of Petroleum Science and Engineering,
!        2018, 167: 615-626..

      subroutine Tool_Cal_Intersection(A,B,C,D,X,Y,Yes_Cross)
C     get intersection point of two line segments

c     A: Coordinates of point A of line segment AB;
c     B: Coordinates of point B of line segment AB;
c     C: Coordinates of point C of line segment CD;
c     D: Coordinates of point D of line segment CD.

      use Global_Elem_Area

      implicit none
      double precision,intent(in)::A(2),B(2),C(2),D(2)
      double precision,intent(out)::X,Y
      logical,intent(out)::Yes_Cross

      double precision L_AB,L_CD,tem,k2,k1,b1,b2
      double precision L_AX,L_BX,L_CX,L_DX
      logical Yes_in_AB,Yes_in_CD
      double precision minX_AB,maxX_AB,minY_AB,maxY_AB,
     &                 minX_CD,maxX_CD,minY_CD,maxY_CD

c     The length of AB.
      L_AB = sqrt((A(1)-B(1))**2+(A(2)-B(2))**2)
c     The length of CD.
      L_CD = sqrt((C(1)-D(1))**2+(C(2)-D(2))**2)

      if (A(1).eq.B(1)) then
          X=A(1)
          tem = D(1)-C(1)
          k2=(D(2)-C(2))/tem
          b2=C(2)-k2*C(1)
          Y=k2*X+b2;
      end if

      if (C(1).eq.D(1)) then
          X=C(1)
          tem =B(1)-A(1)
          k1=(B(2)-A(2))/tem
          b1=A(2)-k1*A(1)
          Y=k1*X+b1
      end if

      if ((A(1).ne.B(1)) .and. (C(1).ne.D(1))) then
          k1=(B(2)-A(2))/(B(1)-A(1))
          k2=(D(2)-C(2))/(D(1)-C(1))
          b1=A(2)-k1*A(1)
          b2=C(2)-k2*C(1)
          if (k1.eq.k2) then
              X=1.0D9
              Y=1.0D9
          else
              X=(b2-b1)/(k1-k2)
              Y=k1*X+b1
          end if
      end if

      minX_AB = min(A(1),B(1))
      maxX_AB = max(A(1),B(1))
      minY_AB = min(A(2),B(2))
      maxY_AB = max(A(2),B(2))
      minX_CD = min(C(1),D(1))
      maxX_CD = max(C(1),D(1))
      minY_CD = min(C(2),D(2))
      maxY_CD = max(C(2),D(2))

      Yes_Cross = .False.
      Yes_in_AB = .False.
      Yes_in_CD = .False.

c     Check if (X,Y) is in AB.
c     The length of AX.
      L_AX = sqrt((A(1)-X)**2+(A(2)-Y)**2)
c     The length of BX.
      L_BX = sqrt((B(1)-X)**2+(B(2)-Y)**2)
      if (((L_AX + L_BX)-L_AB) .le. 1.0D-6*sqrt(Ave_Elem_Area)) then
          Yes_in_AB = .True.
      end if

c     Check if (X,Y) is in CD.
c     The length of CX.
      L_CX = sqrt((C(1)-X)**2+(C(2)-Y)**2)
c     The length of DX.
      L_DX = sqrt((D(1)-X)**2+(D(2)-Y)**2)
      if (((L_CX + L_DX) - L_CD) .le. 1.0D-6*sqrt(Ave_Elem_Area)) then
          Yes_in_CD = .True.
      end if

c     if (X,Y) is in both AB and CD, then YesCross = 1.
      if ((Yes_in_AB .eqv..True.).and.(Yes_in_CD.eqv..True.)) then
          Yes_Cross = .True.
      else
          Yes_Cross = .False.
      end if

      return
      end SUBROUTINE Tool_Cal_Intersection


c subroutine lfim (init,theta,l,n,nm,pb,id,wlfim)
c
c dimension of           theta(l),  pb(id,nm+1),  wlfim(4*l*(nm+1))
c arguments
c
c purpose                given n and l, routine lfim calculates
c                        the normalized associated legendre functions
c                        pbar(n,m,theta) for m=0,...,n and theta(i)
c                        for i=1,...,l where
c
c                        pbar(m,n,theta) = sqrt((2*n+1)*factorial(n-m)
c                        /(2*factorial(n+m)))*sin(theta)**m/(2**n*
c                        factorial(n)) times the (n+m)th derivative of
c                        (x**2-1)**n with respect to x=cos(theta)
c
c usage                  call lfim (init,theta,l,n,nm,pb,id,wlfim)
c
c arguments
c on input               init
c                        = 0
c                            initialization only - using parameters
c                            l, nm and array theta, subroutine lfim
c                            initializes array wlfim for subsequent
c                            use in the computation of the associated
c                            legendre functions pb. initialization
c                            does not have to be repeated unless
c                            l, nm, or array theta are changed.
c                        = 1
c                            subroutine lfim uses the array wlfim that
c                            was computed with init = 0 to compute pb.
c
c                        theta
c                          an array that contains the colatitudes
c                          at which the associated legendre functions
c                          will be computed. the colatitudes must be
c                          specified in radians.
c
c                        l
c                          the length of the theta array. lfim is
c                          vectorized with vector length l.
c
c                        n
c                          nonnegative integer, less than nm, specifying
c                          degree of pbar(n,m,theta). subroutine lfim
c                          must be called starting with n=0. n must be
c                          incremented by one in subsequent calls and
c                          must not exceed nm.
c
c                        nm
c                          the maximum value of n and m
c
c                        id
c                          the first dimension of the two dimensional
c                          array pb as it appears in the program that
c                          calls lfim. (see output parameter pb)
c
c                        wlfim
c                          an array with length 4*l*(nm+1) which
c                          must be initialized by calling lfim
c                          with init=0 (see parameter init)  it
c                          must not be altered between calls to
c                          lfim.
c
c
c on output              pb
c                          a two dimensional array with first
c                          dimension id in the program that calls
c                          lfim. the second dimension of pb must
c                          be at least nm+1. starting with n=0
c                          lfim is called repeatedly with n being
c                          increased by one between calls. on each
c                          call, subroutine lfim computes
c                          = pbar(m,n,theta(i)) for m=0,...,n and
c                          i=1,...l.
c
c                        wlfim
c                          array containing values which must not
c                          be altered unless l, nm or the array theta
c                          are changed in which case lfim must be
c                          called with init=0 to reinitialize the
c                          wlfim array.
c
c special conditions     n must be increased by one between calls
c                        of lfim in which n is not zero.
c
c precision              single
c
c
c algorithm              routine lfim calculates pbar(n,m,theta) using
c                        a four term recurrence relation. (unpublished
c                        notes by paul n. swarztrauber)
c
      subroutine lfim (init,theta,l,n,nm,pb,id,wlfim)
      dimension       pb(1)        ,wlfim(1)
c
c     total length of wlfim is 4*l*(nm+1)
c
      lnx = l*(nm+1)
      iw1 = lnx+1
      iw2 = iw1+lnx
      iw3 = iw2+lnx
      call lfim1(init,theta,l,n,nm,id,pb,wlfim,wlfim(iw1),
     1                wlfim(iw2),wlfim(iw3),wlfim(iw2))
      return
      end
      subroutine lfim1(init,theta,l,n,nm,id,p3,phz,ph1,p1,p2,cp)
      dimension       p1(l,1)    ,p2(l,1)    ,p3(id,1)   ,phz(l,1)   ,
     1                ph1(l,1)   ,cp(1)      ,theta(1)
      nmp1 = nm+1
      if(init .ne. 0) go to 5
      ssqrt2 = 1./sqrt(2.)
      do 10 i=1,l
      phz(i,1) = ssqrt2
   10 continue
      do 15 np1=2,nmp1
      nh = np1-1
      call alfk(nh,0,cp)
      do 16 i=1,l
      call lfpt(nh,0,theta(i),cp,phz(i,np1))
   16 continue
      call alfk(nh,1,cp)
      do 17 i=1,l
      call lfpt(nh,1,theta(i),cp,ph1(i,np1))
   17 continue
   15 continue
      return
    5 if(n .gt. 2) go to 60
      if(n-1)25,30,35
   25 do 45 i=1,l
      p3(i,1)=phz(i,1)
   45 continue
      return
   30 do 50 i=1,l
      p3(i,1) = phz(i,2)
      p3(i,2) = ph1(i,2)
   50 continue
      return
   35 sq5s6 = sqrt(5./6.)
      sq1s6 = sqrt(1./6.)
      do 55 i=1,l
      p3(i,1) = phz(i,3)
      p3(i,2) = ph1(i,3)
      p3(i,3) = sq5s6*phz(i,1)-sq1s6*p3(i,1)
      p1(i,1) = phz(i,2)
      p1(i,2) = ph1(i,2)
      p2(i,1) = phz(i,3)
      p2(i,2) = ph1(i,3)
      p2(i,3) = p3(i,3)
   55 continue
      return
   60 nm1 = n-1
      np1 = n+1
      fn = float(n)
      tn = fn+fn
      cn = (tn+1.)/(tn-3.)
      do 65 i=1,l
      p3(i,1) = phz(i,np1)
      p3(i,2) = ph1(i,np1)
   65 continue
      if(nm1 .lt. 3) go to 71
      do 70 mp1=3,nm1
      m = mp1-1
      fm = float(m)
      fnpm = fn+fm
      fnmm = fn-fm
      temp = fnpm*(fnpm-1.)
      cc = sqrt(cn*(fnpm-3.)*(fnpm-2.)/temp)
      dd = sqrt(cn*fnmm*(fnmm-1.)/temp)
      ee = sqrt((fnmm+1.)*(fnmm+2.)/temp)
      do 70 i=1,l
      p3(i,mp1) = cc*p1(i,mp1-2)+dd*p1(i,mp1)-ee*p3(i,mp1-2)
   70 continue
   71 fnpm = fn+fn-1.
      temp = fnpm*(fnpm-1.)
      cc = sqrt(cn*(fnpm-3.)*(fnpm-2.)/temp)
      ee = sqrt(6./temp)
      do 75 i=1,l
      p3(i,n) = cc*p1(i,n-2)-ee*p3(i,n-2)
   75 continue
      fnpm = fn+fn
      temp = fnpm*(fnpm-1.)
      cc = sqrt(cn*(fnpm-3.)*(fnpm-2.)/temp)
      ee = sqrt(2./temp)
      do 80 i=1,l
      p3(i,n+1) = cc*p1(i,n-1)-ee*p3(i,n-1)
   80 continue
      do 90 mp1=1,np1
      do 90 i=1,l
      p1(i,mp1) = p2(i,mp1)
      p2(i,mp1) = p3(i,mp1)
   90 continue
      return
      end


      subroutine get_a_not_hex(xc,anot)

      include "common.h"

      dimension xc(npro,nenl,nsd), anot(npro,nenl,nsd)

      do i = 1, nsd

         anot(:,1,i) = pt125*(xc(:,1,i)+xc(:,2,i)+xc(:,3,i)+xc(:,4,i)
     &        +xc(:,5,i)+xc(:,6,i)+xc(:,7,i)+xc(:,8,i))

         anot(:,2,i) = pt125*(-xc(:,1,i)+xc(:,2,i)+xc(:,3,i)-xc(:,4,i)
     &        -xc(:,5,i)+xc(:,6,i)+xc(:,7,i)-xc(:,8,i))

         anot(:,3,i) = pt125*(-xc(:,1,i)-xc(:,2,i)+xc(:,3,i)+xc(:,4,i)
     &        -xc(:,5,i)-xc(:,6,i)+xc(:,7,i)+xc(:,8,i))

         anot(:,4,i) = pt125*(-xc(:,1,i)-xc(:,2,i)-xc(:,3,i)-xc(:,4,i)
     &        +xc(:,5,i)+xc(:,6,i)+xc(:,7,i)+xc(:,8,i))

         anot(:,5,i) = pt125*(xc(:,1,i)-xc(:,2,i)+xc(:,3,i)-xc(:,4,i)
     &        +xc(:,5,i)-xc(:,6,i)+xc(:,7,i)-xc(:,8,i))

         anot(:,6,i) = pt125*(xc(:,1,i)+xc(:,2,i)-xc(:,3,i)-xc(:,4,i)
     &        -xc(:,5,i)-xc(:,6,i)+xc(:,7,i)+xc(:,8,i))

         anot(:,7,i) = pt125*(xc(:,1,i)-xc(:,2,i)-xc(:,3,i)+xc(:,4,i)
     &        -xc(:,5,i)+xc(:,6,i)+xc(:,7,i)-xc(:,8,i))

         anot(:,8,i) = pt125*(-xc(:,1,i)+xc(:,2,i)-xc(:,3,i)+xc(:,4,i)
     &        +xc(:,5,i)-xc(:,6,i)+xc(:,7,i)-xc(:,8,i))

      enddo

      return
      end

      subroutine get_a_not_tet(xc,anot)

      include "common.h"

      dimension xc(npro,nenl,nsd), anot(npro,nenl,nsd)

      do i = 1, nsd

         anot(:,1,i) = xc(:,4,i)
         anot(:,2,i) = xc(:,1,i)-xc(:,4,i)
         anot(:,3,i) = xc(:,2,i)-xc(:,4,i)
         anot(:,4,i) = xc(:,3,i)-xc(:,4,i)

      enddo

      return
      end


submodule(gas_interface) gas_implementation
  use assertions_interface, only : assert, max_errmsg_len
  use kind_parameters, only : rkind
  implicit none

contains

  module procedure define
    real(rkind) :: c_p_, MW_
    namelist/gas_list/ c_p_, MW_

    block
      character(len=max_errmsg_len) error_message
      integer :: io_status, file_unit
      integer, parameter :: success = 0
      open(newunit=file_unit, file=input_file, status="old", iostat=io_status, iomsg=error_message)
      call assert(io_status == success, "gas%define: io_status == success", diagnostic_data=error_message)
      read(file_unit, nml=gas_list)
      close(file_unit)
    end block

    this%c_p_ = c_p_
    this%MW_ = MW_
  end procedure

  module procedure T
    T = energy/(this%c_v()*mass)
  end procedure

  module procedure R_gas
    real(rkind), parameter :: R_universal = 8314._rkind ! 8.31446261815324_rkind
    R_gas = R_universal/this%MW_
  end procedure

  module procedure c_v
    c_v = this%c_p_ - this%R_gas()
  end procedure

  module procedure g
    g = this%c_p_/this%c_v()
  end procedure

  module procedure c_p
    c_p = this%c_p_
  end procedure

  module procedure p
    associate(M => (mass), R_gas => this%R_gas(), T => energy/(mass*this%c_v()), V => (volume))
      p = M*R_gas*T/V
    end associate
  end procedure

end submodule gas_implementation


      subroutine evol_alphakd(n_K,n_alpha,np1_K,np1_alpha,x,Nx,ck,epsal,
     &ht,myzero,phys_bdy,res)
      implicit none
      integer i
      integer Nx
      real*8 ck
      real*8 epsal
      real*8 ht
      real*8 myzero
      real*8 n_K(Nx)
      real*8 n_alpha(Nx)
      real*8 np1_K(Nx)
      real*8 np1_alpha(Nx)
      real*8 x(Nx)
      integer phys_bdy(2)
      real*8 res(Nx)
      real*8 qb
      if (phys_bdy(1) .eq. 1) then
      do i=1, 1, 1
      qb = np1_alpha(i) - 0.1D1 * ht * ((-0.1D1 * n_alpha(i) + np1_alpha
     #(i)) / ht + epsal * (-0.1D1 * n_K(i) + np1_K(i)) / ht + 0.50000000
     #00000000D0 * epsal * ck * np1_K(i) + 0.5000000000000000D0 * epsal
     #* ck * n_K(i))
      res(i)=qb
      end do
      endif
      do i=2, Nx-1, 1
      qb = np1_alpha(i) - 0.1D1 * ht * ((-0.1D1 * n_alpha(i) + np1_alpha
     #(i)) / ht + epsal * (-0.1D1 * n_K(i) + np1_K(i)) / ht + 0.50000000
     #00000000D0 * epsal * ck * np1_K(i) + 0.5000000000000000D0 * epsal
     #* ck * n_K(i))
      res(i)=qb
      end do
      if (phys_bdy(2) .eq. 1) then
      do i=Nx, Nx, 1
      qb = -0.1D1 * myzero * x(i) + 0.1D1
      res(i)=qb
      end do
      endif
      END


      SUBROUTINE MB03DZ( A, LDA, B, LDB, CO1, SI1, CO2, SI2 )
C
C     SLICOT RELEASE 5.7.
C
C     Copyright (c) 2002-2020 NICONET e.V.
C
C     PURPOSE
C
C     To compute unitary matrices Q1 and Q2 for a complex 2-by-2 regular
C     pencil aA - bB with A, B upper triangular, such that
C     Q2' (aA - bB) Q1 is still upper triangular but the eigenvalues are
C     in reversed order. The matrices Q1 and Q2 are represented by
C
C          (  CO1  SI1  )       (  CO2  SI2  )
C     Q1 = (            ), Q2 = (            ).
C          ( -SI1' CO1  )       ( -SI2' CO2  )
C
C     The notation M' denotes the conjugate transpose of the matrix M.
C
C     ARGUMENTS
C
C     Input/Output Parameters
C
C     A       (input) COMPLEX*16 array, dimension (LDA, 2)
C             On entry, the leading 2-by-2 upper triangular part of
C             this array must contain the matrix A of the pencil.
C             The (2,1) entry is not referenced.
C
C     LDA     INTEGER
C             The leading dimension of the array A.  LDA >= 2.
C
C     B       (input) COMPLEX*16 array, dimension (LDB, 2)
C             On entry, the leading 2-by-2 upper triangular part of
C             this array must contain the matrix B of the pencil.
C             The (2,1) entry is not referenced.
C
C     LDB     INTEGER
C             The leading dimension of the array B.  LDB >= 2.
C
C     CO1     (output) DOUBLE PRECISION
C             The upper left element of the unitary matrix Q1.
C
C     SI1     (output) COMPLEX*16
C             The upper right element of the unitary matrix Q1.
C
C     CO2     (output) DOUBLE PRECISION
C             The upper left element of the unitary matrix Q2.
C
C     SI2     (output) COMPLEX*16
C             The upper right element of the unitary matrix Q2.
C
C     METHOD
C
C     The algorithm uses unitary transformations as described on page 42
C     in [1].
C
C     REFERENCES
C
C     [1] Benner, P., Byers, R., Mehrmann, V. and Xu, H.
C         Numerical Computation of Deflating Subspaces of Embedded
C         Hamiltonian Pencils.
C         Tech. Rep. SFB393/99-15, Technical University Chemnitz,
C         Germany, June 1999.
C
C     NUMERICAL ASPECTS
C
C     The algorithm is numerically backward stable.
C
C     CONTRIBUTOR
C
C     Matthias Voigt, Fakultaet fuer Mathematik, Technische Universitaet
C     Chemnitz, January 26, 2009.
C
C     REVISIONS
C
C     V. Sima, Aug. 2009 (SLICOT version of the routine ZBTUEX).
C     V. Sima, Nov. 2009, Nov. 2010, Dec. 2010.
C     M. Voigt, Jan. 2012.
C
C     KEYWORDS
C
C     Eigenvalue exchange, matrix pencil, upper triangular matrix.
C
C     ******************************************************************
C
C     .. Scalar Arguments ..
      INTEGER            LDA, LDB
      DOUBLE PRECISION   CO1, CO2
      COMPLEX*16         SI1, SI2
C
C     .. Array Arguments ..
      COMPLEX*16         A( LDA, * ), B( LDB, * )
C
C     .. Local Scalars ..
      COMPLEX*16         D, G, TMP
C
C     .. External Subroutines ..
      EXTERNAL           ZLARTG
C
C     .. Executable Statements ..
C
C     For efficiency, the input arguments are not tested.
C
C     Computations.
C
      G = A( 1, 1 )*B( 2, 2 ) - A( 2, 2 )*B( 1, 1 )
      D = A( 1, 2 )*B( 2, 2 ) - A( 2, 2 )*B( 1, 2 )
      CALL ZLARTG( D, G, CO1, SI1, TMP )
      D = A( 1, 2 )*B( 1, 1 ) - A( 1, 1 )*B( 1, 2 )
      CALL ZLARTG( D, G, CO2, SI2, TMP )
C
      RETURN
C *** Last line of MB03DZ ***
      END


c     program DRSRANUS
c>> 1995-10-23 DRSRANUS Krogh  Reduced N to work on PC in D.P.
c>> 1994-10-19 DRSRANUS Krogh  Changes to use M77CON
c>> 1992-03-13 DRSRANUS CLL
c
c     Driver to demonstrate use of SRANUS to generate random numbers
c     from the uniform distribution between A and A+B.
c     Program computes histogram for N numbers
c     ------------------------------------------------------------------
c--S replaces "?": DR?RANUS, ?RANUS, ?STAT1, ?STAT2
c     ------------------------------------------------------------------
      integer N, NCELLS
      parameter(N = 8000, NCELLS = 10+2)
      real             A, B, STATS(5), YTAB(N)
      integer IHIST(NCELLS)
      data A, B / 20.0e0, 10.0e0/
c     ------------------------------------------------------------------
      STATS(1) = 0.0e0
c                          Get array of scaled random numbers.
c
      call SRANUS(YTAB, N, A, B)
c
c                          Compute statistics and histogram.
c
        call SSTAT1(YTAB, N, STATS, IHIST, NCELLS, A, A+B)
c
c                          Print the statistics and histogram.
c
      write(*,'(13x,a//)') 'Uniform random numbers from SRANUS'
      call SSTAT2(STATS, IHIST, NCELLS, A, A+B)
      end


      SUBROUTINE MB02YD( COND, N, R, LDR, IPVT, DIAG, QTB, RANK, X, TOL,
     $                   DWORK, LDWORK, INFO )
C
C     SLICOT RELEASE 5.7.
C
C     Copyright (c) 2002-2020 NICONET e.V.
C
C     PURPOSE
C
C     To determine a vector x which solves the system of linear
C     equations
C
C           A*x = b ,     D*x = 0 ,
C
C     in the least squares sense, where A is an m-by-n matrix,
C     D is an n-by-n diagonal matrix, and b is an m-vector.
C     It is assumed that a QR factorization, with column pivoting, of A
C     is available, that is, A*P = Q*R, where P is a permutation matrix,
C     Q has orthogonal columns, and R is an upper triangular matrix
C     with diagonal elements of nonincreasing magnitude.
C     The routine needs the full upper triangle of R, the permutation
C     matrix P, and the first n components of Q'*b (' denotes the
C     transpose). The system A*x = b, D*x = 0, is then equivalent to
C
C           R*z = Q'*b ,  P'*D*P*z = 0 ,                             (1)
C
C     where x = P*z. If this system does not have full rank, then a
C     least squares solution is obtained. On output, MB02YD also
C     provides an upper triangular matrix S such that
C
C           P'*(A'*A + D*D)*P = S'*S .
C
C     The system (1) is equivalent to S*z = c , where c contains the
C     first n components of the vector obtained by applying to
C     [ (Q'*b)'  0 ]' the transformations which triangularized
C     [ R'  P'*D*P ]', getting S.
C
C     ARGUMENTS
C
C     Mode Parameters
C
C     COND    CHARACTER*1
C             Specifies whether the condition of the matrix S should be
C             estimated, as follows:
C             = 'E' :  use incremental condition estimation and store
C                      the numerical rank of S in RANK;
C             = 'N' :  do not use condition estimation, but check the
C                      diagonal entries of S for zero values;
C             = 'U' :  use the rank already stored in RANK.
C
C     Input/Output Parameters
C
C     N       (input) INTEGER
C             The order of the matrix R.  N >= 0.
C
C     R       (input/output) DOUBLE PRECISION array, dimension (LDR, N)
C             On entry, the leading N-by-N upper triangular part of this
C             array must contain the upper triangular matrix R.
C             On exit, the full upper triangle is unaltered, and the
C             strict lower triangle contains the strict upper triangle
C             (transposed) of the upper triangular matrix S.
C
C     LDR     INTEGER
C             The leading dimension of array R.  LDR >= MAX(1,N).
C
C     IPVT    (input) INTEGER array, dimension (N)
C             This array must define the permutation matrix P such that
C             A*P = Q*R. Column j of P is column IPVT(j) of the identity
C             matrix.
C
C     DIAG    (input) DOUBLE PRECISION array, dimension (N)
C             This array must contain the diagonal elements of the
C             matrix D.
C
C     QTB     (input) DOUBLE PRECISION array, dimension (N)
C             This array must contain the first n elements of the
C             vector Q'*b.
C
C     RANK    (input or output) INTEGER
C             On entry, if COND = 'U', this parameter must contain the
C             (numerical) rank of the matrix S.
C             On exit, if COND = 'E' or 'N', this parameter contains
C             the numerical rank of the matrix S, estimated according
C             to the value of COND.
C
C     X       (output) DOUBLE PRECISION array, dimension (N)
C             This array contains the least squares solution of the
C             system A*x = b, D*x = 0.
C
C     Tolerances
C
C     TOL     DOUBLE PRECISION
C             If COND = 'E', the tolerance to be used for finding the
C             rank of the matrix S. If the user sets TOL > 0, then the
C             given value of TOL is used as a lower bound for the
C             reciprocal condition number;  a (sub)matrix whose
C             estimated condition number is less than 1/TOL is
C             considered to be of full rank.  If the user sets TOL <= 0,
C             then an implicitly computed, default tolerance, defined by
C             TOLDEF = N*EPS,  is used instead, where EPS is the machine
C             precision (see LAPACK Library routine DLAMCH).
C             This parameter is not relevant if COND = 'U' or 'N'.
C
C     Workspace
C
C     DWORK   DOUBLE PRECISION array, dimension (LDWORK)
C             On exit, the first N elements of this array contain the
C             diagonal elements of the upper triangular matrix S, and
C             the next N elements contain the solution z.
C
C     LDWORK  INTEGER
C             The length of the array DWORK.
C             LDWORK >= 4*N, if COND =  'E';
C             LDWORK >= 2*N, if COND <> 'E'.
C
C     Error Indicator
C
C     INFO    INTEGER
C             = 0:  successful exit;
C             < 0:  if INFO = -i, the i-th argument had an illegal
C                   value.
C
C     METHOD
C
C     Standard plane rotations are used to annihilate the elements of
C     the diagonal matrix D, updating the upper triangular matrix R
C     and the first n elements of the vector Q'*b. A basic least squares
C     solution is computed.
C
C     REFERENCES
C
C     [1] More, J.J., Garbow, B.S, and Hillstrom, K.E.
C         User's Guide for MINPACK-1.
C         Applied Math. Division, Argonne National Laboratory, Argonne,
C         Illinois, Report ANL-80-74, 1980.
C
C     NUMERICAL ASPECTS
C                               2
C     The algorithm requires 0(N ) operations and is backward stable.
C
C     FURTHER COMMENTS
C
C     This routine is a LAPACK-based modification of QRSOLV from the
C     MINPACK package [1], and with optional condition estimation.
C     The option COND = 'U' is useful when dealing with several
C     right-hand side vectors.
C
C     CONTRIBUTORS
C
C     V. Sima, Research Institute for Informatics, Bucharest, Dec. 2001.
C
C     REVISIONS
C
C     V. Sima, Research Institute for Informatics, Bucharest, Mar. 2005.
C
C     KEYWORDS
C
C     Linear system of equations, matrix operations, plane rotations.
C
C     ******************************************************************
C
C     .. Parameters ..
      DOUBLE PRECISION  ZERO, SVLMAX
      PARAMETER         ( ZERO = 0.0D0, SVLMAX = 0.0D0 )
C     .. Scalar Arguments ..
      CHARACTER         COND
      INTEGER           INFO, LDR, LDWORK, N, RANK
      DOUBLE PRECISION  TOL
C     .. Array Arguments ..
      INTEGER           IPVT(*)
      DOUBLE PRECISION  DIAG(*), DWORK(*), QTB(*), R(LDR,*), X(*)
C     .. Local Scalars ..
      DOUBLE PRECISION  CS, QTBPJ, SN, TEMP, TOLDEF
      INTEGER           I, J, K, L
      LOGICAL           ECOND, NCOND, UCOND
C     .. Local Arrays ..
      DOUBLE PRECISION  DUM(3)
C     .. External Functions ..
      DOUBLE PRECISION  DLAMCH
      LOGICAL           LSAME
      EXTERNAL          DLAMCH, LSAME
C     .. External Subroutines ..
      EXTERNAL          DCOPY, DLARTG, DROT, DSWAP, MB03OD, XERBLA
C     .. Intrinsic Functions ..
      INTRINSIC         DBLE, MAX
C     ..
C     .. Executable Statements ..
C
C     Check the scalar input parameters.
C
      ECOND = LSAME( COND, 'E' )
      NCOND = LSAME( COND, 'N' )
      UCOND = LSAME( COND, 'U' )
      INFO  = 0
      IF( .NOT.( ECOND .OR. NCOND .OR. UCOND ) ) THEN
         INFO = -1
      ELSEIF( N.LT.0 ) THEN
         INFO = -2
      ELSEIF ( LDR.LT.MAX( 1, N ) ) THEN
         INFO = -4
      ELSEIF ( UCOND .AND. ( RANK.LT.0 .OR. RANK.GT.N ) ) THEN
         INFO = -8
      ELSEIF ( LDWORK.LT.2*N .OR. ( ECOND .AND. LDWORK.LT.4*N ) ) THEN
         INFO = -12
      ENDIF
C
C     Return if there are illegal arguments.
C
      IF( INFO.NE.0 ) THEN
         CALL XERBLA( 'MB02YD', -INFO )
         RETURN
      ENDIF
C
C     Quick return if possible.
C
      IF ( N.EQ.0 ) THEN
         IF ( .NOT.UCOND )
     $      RANK = 0
         RETURN
      END IF
C
C     Copy R and Q'*b to preserve input and initialize S.
C     In particular, save the diagonal elements of R in X.
C
      DO 20 J = 1, N
         X(J) = R(J,J)
         DO 10 I = J, N
            R(I,J) = R(J,I)
   10    CONTINUE
   20 CONTINUE
C
      CALL DCOPY( N, QTB, 1, DWORK(N+1), 1 )
C
C     Eliminate the diagonal matrix D using Givens rotations.
C
      DO 50 J = 1, N
C
C        Prepare the row of D to be eliminated, locating the
C        diagonal element using P from the QR factorization.
C
         L = IPVT(J)
         IF ( DIAG(L).NE.ZERO ) THEN
            QTBPJ = ZERO
            DWORK(J) = DIAG(L)
C
            DO 30 K = J + 1, N
               DWORK(K) = ZERO
   30       CONTINUE
C
C           The transformations to eliminate the row of D modify only
C           a single element of Q'*b beyond the first n, which is
C           initially zero.
C
            DO 40 K = J, N
C
C              Determine a Givens rotation which eliminates the
C              appropriate element in the current row of D.
C
               IF ( DWORK(K).NE.ZERO ) THEN
C
                  CALL DLARTG( R(K,K), DWORK(K), CS, SN, TEMP )
C
C                 Compute the modified diagonal element of R and
C                 the modified elements of (Q'*b,0).
C                 Accumulate the tranformation in the row of S.
C
                  TEMP  =  CS*DWORK(N+K) + SN*QTBPJ
                  QTBPJ = -SN*DWORK(N+K) + CS*QTBPJ
                  DWORK(N+K) = TEMP
                  CALL DROT( N-K+1, R(K,K), 1, DWORK(K), 1, CS, SN )
C
               END IF
   40       CONTINUE
C
         END IF
C
C        Store the diagonal element of S and, if COND <> 'E', restore
C        the corresponding diagonal element of R.
C
         DWORK(J) = R(J,J)
         IF ( .NOT.ECOND )
     $      R(J,J) = X(J)
   50 CONTINUE
C
C     Solve the triangular system for z. If the system is singular,
C     then obtain a least squares solution.
C
      IF ( ECOND ) THEN
         TOLDEF = TOL
         IF ( TOLDEF.LE.ZERO ) THEN
C
C           Use the default tolerance in rank determination.
C
            TOLDEF = DBLE( N )*DLAMCH( 'Epsilon' )
         END IF
C
C        Interchange the strict upper and lower triangular parts of R.
C
         DO 60 J = 2, N
            CALL DSWAP( J-1, R(1,J), 1, R(J,1), LDR )
   60    CONTINUE
C
C        Estimate the reciprocal condition number of S and set the rank.
C        Additional workspace: 2*N.
C
         CALL MB03OD( 'No QR', N, N, R, LDR, IPVT, TOLDEF, SVLMAX,
     $                DWORK, RANK, DUM, DWORK(2*N+1), LDWORK-2*N,
     $                INFO )
         R(1,1) = X(1)
C
C        Restore the strict upper and lower triangular parts of R.
C
         DO 70 J = 2, N
            CALL DSWAP( J-1, R(1,J), 1, R(J,1), LDR )
            R(J,J) = X(J)
   70    CONTINUE
C
      ELSEIF ( NCOND ) THEN
C
C        Determine rank(S) by checking zero diagonal entries.
C
         RANK = N
C
         DO 80 J = 1, N
            IF ( DWORK(J).EQ.ZERO .AND. RANK.EQ.N )
     $         RANK = J - 1
   80    CONTINUE
C
      END IF
C
      DUM(1) = ZERO
      IF ( RANK.LT.N )
     $   CALL DCOPY( N-RANK, DUM, 0, DWORK(N+RANK+1), 1 )
C
C     Solve S*z = c using back substitution.
C
      DO 100 J = RANK, 1, -1
         TEMP = ZERO
C
         DO 90 I = J + 1, RANK
            TEMP = TEMP + R(I,J)*DWORK(N+I)
   90    CONTINUE
C
         DWORK(N+J) = ( DWORK(N+J) - TEMP )/DWORK(J)
  100 CONTINUE
C
C     Permute the components of z back to components of x.
C
      DO 110 J = 1, N
         L    = IPVT(J)
         X(L) = DWORK(N+J)
  110 CONTINUE
C
      RETURN
C
C *** Last line of MB02YD ***
      END


program modcor

! calcul de la fonction de correlation des scintillations
implicit none

integer	:: i, j, k, nb_int 	! nombre de pas pour le calcul de l'integrale
real 	:: Pi, epo, pasf, pasp, lambda, arhm, rhoi, arho
real	:: coef, xj, yj, zj, resint, restot, bessj0
real, dimension(5)	:: hm, Jt, rescint
real, dimension(5000)  	:: fk

 Pi = 4.0*atan(1.0)
 epo = -8/3.
 nb_int = 5000
 pasf = 0.02
 pasp = 7.63e-3
 lambda = 0.53e-6 	! longueur d'onde, en metre

 coef = 0.243*4*Pi*Pi/lambda/lambda
 coef = coef*3.0e-14	! soit un r_{0} de 0.7 m a 0.53 \mu m

open (11, file = 'modcor.dat')

hm(1)=5000; hm(2)=10000; hm(3)=15000; hm(4)=20000; hm(5)=25000
! hm(1)=17200; hm(2)=13400; hm(3)=9600; hm(4)=4250	! distance de la couche en m
! Jt(1)=0.25  ; Jt(2)=0.25 ; Jt(3)=0.5; Jt(4)=1.0	! contenu de turbulence

do i=-50,50
	rhoi = pasp*i	! rho en metre
	arho = 2*Pi*rhoi
	restot = 0.

  do k=1,5
 	arhm = Pi*lambda*hm(k)

	do j=1,nb_int
		xj = pasf*j
		yj = arhm*xj*xj
		zj = arho*xj
		fk(j) = xj**epo*sin(yj)*sin(yj)*bessj0(zj)
	enddo

	resint = coef*pasf*( 0.5*(fk(1) + fk(nb_int)) + &
		 sum( (/(fk(j), j=2,nb_int-1)/)) )
	rescint(k) = resint

	restot = restot + rescint(k)
  enddo

  write (11, '(i5, 7(f10.6))') i, rhoi, rescint, restot
enddo

end program modcor


program test_fluid
  use fluid
  implicit none
  ! Fluid solver class.
  type(FluidSlv) :: FldSlv2D, FldSlv3D
  ! Names of variables.
  character(len=:), dimension(:), allocatable :: names2D, names3D
  ! Dimensions of the simulation domains.
  integer :: whd2D(2), whd3D(3)
  ! Simulation parameters.
  real(dp) :: scale, safety
  ! Density.
  real(dp) :: rho, timestep
  ! Add in flow coordinates.
  type(Vec2D2) :: xi2D
  real(dp) :: initial_cond(3)
  ! Time
  real(dp) :: t
  ! Timers
  integer :: startvalues(8), endvalues(8), startcount, endcount
  real(4) :: countrate
  ! Counter
  integer :: i, j
  ! Arrays
  real(dp), allocatable :: u(:,:), prhs(:)
  real(dp) :: celsiz

  ! Initialise names.
  allocate(character(len=8) :: names2D(4))

  ! Test 2D.1: Initialise Fluid.
  ! Safety factor.
  safety = 1._dp
  ! Grid scale.
  scale = 1._dp
  ! 3x3 2D grid with sides of length 3 (each box is of size 1x1).
  whd2D = 3
  ! Density.
  rho = 0.1_dp
  ! Initial timestep.
  timestep = 0.005
  ! Names
  names2D(1)(:) = "Density."
  names2D(2)(:) = "Vx."
  names2D(3)(:) = "Vy."
  call FldSlv2D % Init(names2D, whd2D, rho, timestep, scale, safety)

  print*, " rho % name = ", FldSlv2D % rho % name, &
          new_line(" "), " Expected rho % name = ", names2D(1)(1:len(names2D(1)))
  print*, " u(1) % name = ", FldSlv2D % u(1) % name, &
          new_line(" "), " Expected u(1) % name = ", names2D(2)(1:len(names2D(2)))
  print*, " u(2) % name = ", FldSlv2D % u(2) % name, &
          new_line(" "), " Expected u(2) % name = ", names2D(3)(1:len(names2D(3)))

  print*, " Box Width = ", FldSlv2D % whd(1), &
          new_line(" "), " Expected width = ", whd2D(1)
  print*, " Box Height = ", FldSlv2D % whd(2), &
          new_line(" "), " Expected height = ", whd2D(2)

  print*, " Density = ", FldSlv2D % srho, &
          new_line(" "), " Expected Density = ", rho

  print*, " Cell size = ", FldSlv2D % celsiz, &
          new_line(" "), " Expected Cell size = ", scale/minval(whd2D)

  print*, " Safety factor = ", FldSlv2D % safety, &
          new_line(" "), " Expected Safety factor = ", safety

  print*, new_line(new_line(" ")), " FldSlv2D % prhs = ", FldSlv2D % prhs, &
          new_line(new_line(" ")), " Expected FldSlv2D % prhs = ", [(real(i)*0._dp, i = 1, product(whd2D))]

  print*, new_line(new_line(" ")), " FldSlv2D % p = ", FldSlv2D % prhs, &
          new_line(new_line(" ")), " Expected FldSlv2D % p = ", [(real(i)*0._dp, i = 1, product(whd2D))]

  print*, new_line(new_line(" ")), " FldSlv2D % u(1) % old = ", FldSlv2D % u(1) % old, &
          new_line(new_line(" ")), " Expected FldSlv2D % u(1) % old = ", [(real(i)*0._dp, i = 1, (whd2D(1) + 1)*whd2D(2))]

  print*, new_line(new_line(" ")), " FldSlv2D % u(1) % new = ", FldSlv2D % u(1) % new, &
          new_line(new_line(" ")), " Expected FldSlv2D % u(1) % new = ", [(real(i)*0._dp, i = 1, (whd2D(1) + 1)*whd2D(2))]

  print*, " Size(FldSlv2D % u(1) % old) = ", size(FldSlv2D % u(1) % old), &
          new_line(" "), " Expected Size(FldSlv2D % u(1) % old) = ", (whd2D(1) + 1)*whd2D(2)

  print*, " Size(FldSlv2D % u(1) % new) = ", size(FldSlv2D % u(1) % new), &
          new_line(" "), " Expected Size(FldSlv2D % u(1) % new) = ", (whd2D(1) + 1)*whd2D(2)

  print*, " FldSlv2D % u(1) % ost = ", FldSlv2D % u(1) % ost, &
          new_line(" "), " Expected FldSlv2D % u(1) % ost = ", [0._dp, 0.5_dp]

  print*, " FldSlv2D % u(1) % whd = ", FldSlv2D % u(1) % whd, &
          new_line(" "), " Expected FldSlv2D % u(1) % whd = ", [whd2D(1) + 1, whd2D(2)]

  print*, " FldSlv2D % u(1) % celsiz = ", FldSlv2D % u(1) % celsiz, &
          new_line(" "), " Expected FldSlv2D % u(1) % celsiz = ", scale/minval(whd2D)

  print*, new_line(new_line(" ")), " FldSlv2D % u(2) % old = ", FldSlv2D % u(2) % old, &
          new_line(new_line(" ")), " Expected FldSlv2D % u(2) % old = ", [(real(i)*0._dp, i = 1, (whd2D(2) + 1)*whd2D(1))]

  print*, new_line(new_line(" ")), " FldSlv2D % u(2) % new = ", FldSlv2D % u(2) % new, &
          new_line(new_line(" ")), " Expected FldSlv2D % u(2) % new = ", [(real(i)*0._dp, i = 1, (whd2D(2) + 1)*whd2D(1))]

  print*, " Size(FldSlv2D % u(2) % old) = ", size(FldSlv2D % u(2) % old), &
          new_line(" "), " Expected Size(FldSlv2D % u(2) % old) = ", (whd2D(2) + 1)*whd2D(1)

  print*, " Size(FldSlv2D % u(2) % new) = ", size(FldSlv2D % u(2) % new), &
          new_line(" "), " Expected Size(FldSlv2D % u(2) % new) = ", (whd2D(2) + 1)*whd2D(2)

  print*,  " FldSlv2D % u(2) % ost = ", FldSlv2D % u(2) % ost, &
          new_line(" "), " Expected FldSlv2D % u(2) % ost = ", [0.5_dp, 0._dp]

  print*, " FldSlv2D % u(2) % whd = ", FldSlv2D % u(2) % whd, &
          new_line(" "), " Expected FldSlv2D % u(2) % whd = ", [whd2D(1), whd2D(2) + 1]

  print*, " FldSlv2D % u(2) % celsiz = ", FldSlv2D % u(2) % celsiz, &
          new_line(" "), " Expected FldSlv2D % celsiz = ", scale/minval(whd2D)

  print*, new_line(new_line(" ")), " FldSlv2D % rho % new = ", FldSlv2D % rho % new, &
          new_line(new_line(" ")), " Expected FldSlv2D % rho % new = ", [(real(i)*0._dp, i = 1, product(whd2D))]

  print*, " Size(FldSlv2D % rho % old) = ", size(FldSlv2D % rho % old), &
          new_line(" "), " Expected Size(FldSlv2D % rho % old) = ", product(whd2D)

  print*, " Size(FldSlv2D % rho % new) = ", size(FldSlv2D % rho % new), &
          new_line(" "), " Expected Size(FldSlv2D % rho % new) = ", product(whd2D)

  print*,  " FldSlv2D % rho % ost = ", FldSlv2D % rho % ost, &
          new_line(" "), " Expected FldSlv2D % rho % ost = ", [0.5_dp, 0.5_dp]

  print*, " FldSlv2D % rho % whd = ", FldSlv2D % rho % whd, &
          new_line(" "), " Expected FldSlv2D % rho % whd = ", [whd2D(1), whd2D(2)]

  print*, " FldSlv2D % rho % celsiz = ", FldSlv2D % rho % celsiz, &
          new_line(" "), " Expected FldSlv2D % rho % celsiz = ", scale/minval(whd2D), new_line(new_line(" "))

  xi2D % x = [0._dp, 1._dp, 0._dp, 1._dp]
  initial_cond = [1.0_dp, 2.0_dp, 3.0_dp]

  CALL SYSTEM_CLOCK(startcount, countrate)
  do i = 1, 1
    call FldSlv2D % AddFlow(xi2D, initial_cond)
  end do
  CALL SYSTEM_CLOCK(endcount, countrate)
  print*, "ADDFLOW: It took me", endcount - startcount, "clicks (", (endcount - startcount)/countrate*1000," ms)"

  print*, new_line(new_line(" ")), "FldSlv2D % rho % old = ", new_line(" "), FldSlv2D % rho % old

  print*, new_line(new_line(" ")), "FldSlv2D % u(1) % old = ", new_line(" "), FldSlv2D % u(1) % old

  print*, new_line(new_line(" ")), "FldSlv2D % u(2) % old = ", new_line(" "), FldSlv2D % u(2) % old, new_line(new_line(" "))

  t = 0._dp
  CALL SYSTEM_CLOCK(startcount, countrate)
  do i = 1, 1
    call FldSlv2D % MaxTimeStep2D(t)
  end do
  CALL SYSTEM_CLOCK(endcount, countrate)
  print*, "MAXTIMESTEP: It took me", endcount - startcount, "clicks (", (endcount - startcount)/countrate*1000," ms)"
  print*, new_line(new_line(" ")), FldSlv2D % TimeStep

  CALL SYSTEM_CLOCK(startcount, countrate)
  do i = 1, 1
    call FldSlv2D % BuildRhs2D()
  end do
  CALL SYSTEM_CLOCK(endcount, countrate)
  print*, "BUILDRHS: It took me", endcount - startcount, "clicks (", (endcount - startcount)/countrate*1000," ms)"
  print*, new_line(new_line(" ")), " FldSlv2D % prhs = ", FldSlv2D % prhs

  CALL SYSTEM_CLOCK(startcount, countrate)
  call FldSlv2D % GSPSlv2D(60, 1d-5)
  CALL SYSTEM_CLOCK(endcount, countrate)
  !print*, endvalues - startvalues
  print*, "Gauss-Seidel: It took me", endcount - startcount, "clicks (", (endcount - startcount)/countrate*1000," ms)"

  call FldSlv2D % ApplyPressure2D()
  do j = 0, 2
    do i = 0, 2
      write(*,"(A,A,I2,A,I2,A,A,F5.3,A,F5.3,A)"), "(Vx(i,j), Vy(i,j) = ", "(", i,",", j, "), ", "(", FldSlv2D % u(1) % ReadVal(i,j)&
      ,", ", FldSlv2D % u(2) % ReadVal(i,j), ")"
    end do
  end do

  call FldSlv2D % rho % Advect2D(FluidQty2D([FldSlv2D % u]), FldSlv2D%timestep(1))
  call FldSlv2D % u(1) % Advect2D(FluidQty2D([FldSlv2D % u]), FldSlv2D%timestep(1))
  call FldSlv2D % u(2) % Advect2D(FluidQty2D([FldSlv2D % u]), FldSlv2D%timestep(1))
  !do i = 0, 8
  !  print*, FldSlv2D % rho % new(i)
  !end do

end program test_fluid


SUBROUTINE lpest(n, p, x, y, maxit, a, b, sd, r, rate, it, npo, ifault)

! Code converted using TO_F90 by Alan Miller
! Date: 2003-12-17  Time: 15:07:09

! FORMAL PARAMETERS
!    N     INTEGER        input : the number of points
!    P     REAL           input : p in the Lp norm
!    X     REAL ARRAY (N) input : the observed values x(i)
!    Y     REAL ARRAY (N) input : the observed values y(i)
!    MAXIT INTEGER        input : maximum allowable number of iterations
!    A     REAL           output : the estimate of alfa
!    B     REAL           output : the estimate of beta
!    SD    REAL           output : the Lp norm
!    R     REAL ARRAY (N) output : the signed residuals
!    RATE  REAL           output : abs(S(k+1)-S(k))/S(k+1), where S(k) is
!                                  the Lp norm of the fit on the kth iteration
!    IT    INTEGER        output : the number of iterations
!    NPO   INTEGER        output : the number of the points on the line
!   IFAULT INTEGER        output :
!                 IFAULT = 0 if the routine converged.
!                        = 1 if return was due to an increase in the norm.
!                        = 2 if the maximum iterations
!                            specified was less than 2.
!                        = 3 if the weighted sample variance of x is 0.
!                        = 4 if N given less than 2.
!                        = 5 if convergence has not be achieved within
!                            the maximum number of iterations specified.

!  ALGORITHM AS 110 APPL. STATIST. (1977), VOL.26, NO.1

!  Lp-NORM FIT OF STRAIGHT LINE BY EXTENSION OF SCHLOSSMACHER,
!  particularly for 1 <= p <= 2.

IMPLICIT NONE
INTEGER, INTENT(IN)   :: n
REAL, INTENT(IN)      :: p
REAL, INTENT(IN)      :: x(n)
REAL, INTENT(IN)      :: y(n)
INTEGER, INTENT(IN)   :: maxit
REAL, INTENT(OUT)     :: a
REAL, INTENT(OUT)     :: b
REAL, INTENT(OUT)     :: sd
REAL, INTENT(OUT)     :: r(n)
REAL, INTENT(OUT)     :: rate
INTEGER, INTENT(OUT)  :: it
INTEGER, INTENT(OUT)  :: npo
INTEGER, INTENT(OUT)  :: ifault

INTEGER  :: i, isw
REAL     :: absri, a2, b2, div, dx, dxy, eps2,   &
    res, sd2, sw, ssx, spxy, w, xiw, xmean, wp, xi, yi, ymean
REAL, PARAMETER  :: eps = 1.0E-6

IF(maxit < 2) GO TO 9
IF(n < 2) GO TO 10
ifault = 0
wp = p - 2.0
eps2 = 2.0 * eps
sd = 0.0
r(1:n) = 1.0

DO  it = 1, maxit
  npo = 0

!          CALCULATE A AND B BY LEAST SQUARES ON WEIGHTED DATA,
!          USING THE HERRAMAN ALGORITHM.
!          OMIT OBSERVATIONS WITH SMALL RESIDUALS.

  sw = 0.0
  xmean = 0.0
  ymean = 0.0
  ssx = 0.0
  spxy = 0.0
  DO  i = 1, n
    absri = ABS(r(i))
    IF(absri <= eps) GO TO 2
    w = absri ** wp
    sw = sw + w
    div = w / sw
    xi = x(i) - xmean
    yi = y(i) - ymean
    xiw = xi * w
    dx = xi * xiw
    dxy = yi * xiw
    ssx = ssx + dx - dx * div
    spxy = spxy + dxy - dxy * div
    xmean = xmean + xi * div
    ymean = ymean + yi * div
    CYCLE
    2 npo = npo + 1
  END DO
  IF(ssx < eps) GO TO 11
  b = spxy / ssx
  a = ymean - b * xmean

!          FORM RESIDUALS AND TEST CONVERGENCE

  sd2 = 0.0
  isw = 0
  DO  i = 1, n
    res = y(i) - a - b * x(i)
    absri = ABS(res)
    IF(ABS(absri - ABS(r(i))) > eps2) isw = 1
    sd2 = sd2 + absri ** p
    r(i) = res
  END DO
  rate = ABS(sd2 - sd) / sd2
  IF(isw == 0) RETURN
  IF(it == 1) GO TO 5

!        TEST FOR INCREASE IN NORM

  IF(sd2 > sd) GO TO 7
  5 sd = sd2
  a2 = a
  b2 = b
END DO
!     FAILED TO CONVERGE IN MAXIT ITERATIONS

ifault = 5
RETURN

!      NORM INCREASED, RESTORE A, B, AND R, THEN RETURN

7 ifault = 1
a = a2
b = b2
DO  i = 1, n
  r(i) = y(i) - a - b * x(i)
END DO
RETURN

!      MAXIT SPECIFIED LESS THAN 2

9 ifault = 2
RETURN

!      N LESS THAN 2

10 ifault = 4
RETURN

!      VARIANCE OF WEIGHTED X IS ZERO

11 ifault = 3
RETURN
END SUBROUTINE lpest


! MD5 of template: 4487f0f616ecccd76ea2b91ab000241b
! 3D angle related routines
!
! ------------------------------------------------------------------------------
! Copyright (c) 2009-13, Thomas P. Robitaille
!
! All rights reserved.
!
! Redistribution and use in source and binary forms, with or without
! modification, are permitted provided that the following conditions are met:
!
!  * Redistributions of source code must retain the above copyright notice, this
!    list of conditions and the following disclaimer.
!
!  * Redistributions in binary form must reproduce the above copyright notice,
!    this list of conditions and the following disclaimer in the documentation
!    and/or other materials provided with the distribution.
!
! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
! AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
! IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE
! DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE
! FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
! DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR
! SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER
! CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY,
! OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
! OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
! ------------------------------------------------------------------------------

module type_angle3d

  implicit none
  save

  private

  integer,parameter :: sp = selected_real_kind(p=6,r=37)
  integer,parameter :: dp = selected_real_kind(p=15,r=307)

  real(dp),parameter  :: pi = 3.14159265358979323846_dp
  real(dp),parameter  :: deg2rad = pi / 180._dp
  real(dp),parameter  :: rad2deg = 180._dp / pi

  public :: angle3d_sp
  type angle3d_sp
     real(sp) :: cost,sint,cosp,sinp
  end type angle3d_sp

  public :: angle3d_dp
  type angle3d_dp
     real(dp) :: cost,sint,cosp,sinp
  end type angle3d_dp

  public :: operator(.eq.)
  interface operator(.eq.)
     module procedure equal_sp
     module procedure equal_dp
  end interface operator(.eq.)

  public :: angle3d_deg
  interface angle3d_deg
     module procedure angle3d_deg_sp
     module procedure angle3d_deg_dp
  end interface angle3d_deg

  public :: display_angle
  interface display_angle
     module procedure display_angle_sp
     module procedure display_angle_dp
  end interface display_angle

  public :: operator(.dot.)
  interface operator(.dot.)
     module procedure dot_product_sp
     module procedure dot_product_dp
  end interface operator(.dot.)

  public :: rotate_angle3d
  interface rotate_angle3d
     module procedure rotate_angle3d_sp
     module procedure rotate_angle3d_dp
  end interface rotate_angle3d

  public :: difference_angle3d
  interface difference_angle3d
     module procedure difference_angle3d_sp
     module procedure difference_angle3d_dp
  end interface difference_angle3d

  public :: random_sphere_angle3d
  interface random_sphere_angle3d
     module procedure random_sphere_angle3d_sp
     module procedure random_sphere_angle3d_dp
  end interface random_sphere_angle3d

  public :: operator(-)
  interface operator(-)
     module procedure minus_angle_sp
     module procedure minus_angle_dp
  end interface operator(-)

  interface sin2cos
     module procedure sin2cos_sp
     module procedure sin2cos_dp
  end interface sin2cos

  interface cos2sin
     module procedure sin2cos_sp
     module procedure sin2cos_dp
  end interface cos2sin

contains

  logical function equal_dp(a, b) result(e)

    implicit none

    type(angle3d_dp),intent(in) :: a, b

    e = a%cost == b%cost .and. a%sint == b%sint .and. a%cosp == b%cosp .and. a%sinp == b%sinp

  end function equal_dp

  type(angle3d_dp) function angle3d_deg_dp(theta,phi) result(a)

    implicit none

    real(dp),intent(in) :: theta,phi

    a%cost = cos(theta*deg2rad)
    a%sint = sin(theta*deg2rad)
    a%cosp = cos(phi*deg2rad)
    a%sinp = sin(phi*deg2rad)

  end function angle3d_deg_dp

  subroutine display_angle_dp(a)
    implicit none
    type(angle3d_dp),intent(in) :: a
    print '("Theta = ",F8.4," degrees")',atan2(a%sint,a%cost)*rad2deg
    print '("Phi   = ",F8.4," degrees")',atan2(a%sinp,a%cosp)*rad2deg
  end subroutine display_angle_dp

  real(dp) function dot_product_dp(a, b) result(p)

    implicit none

    type(angle3d_dp),intent(in) :: a, b

    p = a%sint*a%cosp*b%sint*b%cosp + a%sint*a%sinp*b%sint*b%sinp + a%cost * b%cost

  end function dot_product_dp

  subroutine rotate_angle3d_dp(a_local,a_coord,a_final)

    ! This subroutine is used to add a local angle, such as as
    ! photon emission angle on the surface of a star, or a photon
    ! scattering angle, to an already existing position angle.
    ! The former is given by a_local, the latter, by a_coord, and
    ! the final angle by a_angle. We solve this using spherical
    ! trigonometry. Consider a spherical triangle with corner angles
    ! (A,B,C) and side angles (a,b,c). The angle B is attached to the
    ! z axis, and the sides a and c are on the great circles passing
    ! through the z-axis. The meaning of the angles is as follows:

    ! a =   old theta angle (initial direction angle)
    ! b = local theta angle (scattering or emission angle)
    ! c =   new theta angle (final direction angle)

    ! A = no meaning (but useful for scattering)
    ! B = new phi - old phi
    ! C = local phi angle (scattering or emission angle)

    implicit none

    type(angle3d_dp),intent(in) :: a_local
    type(angle3d_dp),intent(in) :: a_coord
    type(angle3d_dp),intent(out) :: a_final

    real(dp) :: cos_a,sin_a
    real(dp) :: cos_b,sin_b
    real(dp) :: cos_c,sin_c

    real(dp) :: cos_big_b,sin_big_b
    real(dp) :: cos_big_c,sin_big_c

    real(dp) :: delta
    logical :: same_sign

    ! Special case - if coord%theta is 0, then final = local
    if(abs(a_coord%sint) < 1.e-10_dp) then
       if(a_coord%cost > 0._dp) then
          a_final = a_local
          a_final%cosp = + a_local%cosp * a_coord%cosp + a_local%sinp * a_coord%sinp
          a_final%sinp = + a_local%cosp * a_coord%sinp - a_local%sinp * a_coord%cosp
       else
          a_final = a_local
          a_final%cost = - a_local%cost
          a_final%cosp = + a_local%cosp * a_coord%cosp - a_local%sinp * a_coord%sinp
          a_final%sinp = + a_local%cosp * a_coord%sinp + a_local%sinp * a_coord%cosp
       end if
       return
    end if

    ! --- Assign spherical triangle angles values --- !

    ! The angles in the spherical triangle are as follows:

    cos_a = a_coord%cost
    sin_a = a_coord%sint

    cos_b = a_local%cost
    sin_b = a_local%sint

    if(a_local%sinp < 0._dp) then ! the angle in the triangle is then actually 2*pi - local phi
       cos_big_C = + a_local%cosp
       sin_big_C = - a_local%sinp
    else ! the angle is local phi
       cos_big_C = + a_local%cosp
       sin_big_C = + a_local%sinp
    end if

    ! --- Solve the spherical triangle --- !

    if (abs(sin_a) > abs(cos_a)) then
       same_sign = sin_a > 0._dp .eqv. sin_b > 0._dp
       delta = cos_b - cos_a
    else
       same_sign = cos_a > 0._dp .eqv. cos_b > 0._dp
       delta = sin_b - sin_a
    end if

    if(same_sign .and. abs(delta) < 1.e-5_dp .and. sin_big_C < 1.e-5_dp .and. cos_big_c > 0._dp) then
       if (abs(sin_a) > abs(cos_a)) then
          sin_c = sqrt(delta * delta * (1._dp + (cos_a/sin_a)**2) + sin_a * sin_b * sin_big_C * sin_big_C)
       else
          sin_c = sqrt(delta * delta * (1._dp + (sin_a/cos_a)**2) + sin_a * sin_b * sin_big_C * sin_big_C)
       end if
       cos_c = sin2cos(sin_c)
    else
       cos_c = cos_a * cos_b + sin_a * sin_b * cos_big_c
       sin_c = cos2sin(cos_c)
    end if

    ! Special case - if local and coord theta are the same and C = 0, return
    ! vertical vector. We can't do better than that because we are limited by
    ! numerical precision, in particular for delta (above) which will be limited
    ! in precision
    if(abs(sin_c) < 1.e-10_dp) then
       write(*,'(" WARNING: final angle is vertical, and phi is undetermined (set to 0) [rotate_angle3d]")')
       if(cos_c > 0._dp) then
          a_final = angle3d_deg(0._dp,0._dp)
       else
          a_final = angle3d_deg(180._dp,0._dp)
       end if
       return
    end if

    cos_big_b = ( cos_b - cos_a * cos_c ) / ( sin_a * sin_c )
    sin_big_b = + sin_big_c * sin_b / sin_c

    ! --- Find final theta and phi values --- !

    a_final%cost = cos_c
    a_final%sint = sin_c

    if(a_local%sinp < 0._dp) then ! the top angle is old phi - new phi
       a_final%cosp = + cos_big_b * a_coord%cosp + sin_big_b * a_coord%sinp
       a_final%sinp = + cos_big_b * a_coord%sinp - sin_big_b * a_coord%cosp
    else ! the top angle is new phi - old phi
       a_final%cosp = + cos_big_b * a_coord%cosp - sin_big_b * a_coord%sinp
       a_final%sinp = + cos_big_b * a_coord%sinp + sin_big_b * a_coord%cosp
    end if

  end subroutine rotate_angle3d_dp

  subroutine difference_angle3d_dp(a_coord,a_final,a_local)

    ! This subroutine is used to find the local angle by which
    ! a coordinate angle would have to be rotated to give the
    ! final angle specified. This is complementary to the rotate_
    ! angle3d routine.

    ! We solve this using spherical
    ! trigonometry. Consider a spherical triangle with corner angles
    ! (A,B,C) and side angles (a,b,c). The angle B is attached to the
    ! z axis, and the sides a and c are on the great circles passing
    ! through the z-axis. The meaning of the angles is as follows:

    ! a =   old theta angle (initial direction angle)
    ! b = local theta angle (scattering or emission angle)
    ! c =   new theta angle (final direction angle)

    ! A = no meaning (but useful for scattering)
    ! B = new phi - old phi
    ! C = local phi angle (scattering or emission angle)

    implicit none

    type(angle3d_dp),intent(out) :: a_local
    type(angle3d_dp),intent(in) :: a_coord
    type(angle3d_dp),intent(in) :: a_final

    real(dp) :: cos_a,sin_a
    real(dp) :: cos_b,sin_b
    real(dp) :: cos_c,sin_c

    real(dp) :: cos_big_b,sin_big_b
    real(dp) :: cos_big_c,sin_big_c

    real(dp) :: delta,diff
    logical :: same_sign

    ! Special case - if coord%theta is 0, then final = local
    if(abs(a_coord%sint) < 1.e-10_dp) then
       if(a_coord%cost > 0._dp) then
          a_local = a_final
          a_local%cosp = + a_coord%cosp * a_final%cosp + a_coord%sinp * a_final%sinp
          a_local%sinp = - a_coord%cosp * a_final%sinp + a_coord%sinp * a_final%cosp
       else
          a_local = a_final
          a_local%cost = - a_local%cost
          a_local%cosp = + a_coord%cosp * a_final%cosp + a_coord%sinp * a_final%sinp
          a_local%sinp = + a_coord%cosp * a_final%sinp - a_coord%sinp * a_final%cosp
       end if
       return
    end if

    ! --- Assign spherical triangle angles values --- !

    ! The angles in the spherical triangle are as follows:

    cos_a = a_coord%cost
    sin_a = a_coord%sint

    cos_c = a_final%cost
    sin_c = a_final%sint

    cos_big_B = a_coord%cosp * a_final%cosp + a_coord%sinp * a_final%sinp
    sin_big_B = a_coord%sinp * a_final%cosp - a_coord%cosp * a_final%sinp

    ! --- Solve the spherical triangle --- !

    cos_b = cos_a * cos_c + sin_a * sin_c * cos_big_B
    sin_b = cos2sin(cos_b)

    ! If cos_b is -1, then the angles are opposite and phi is undefined
    if(abs(cos_b + 1._dp) < 1.e-10_dp) then
       a_local = angle3d_deg(180._dp,0._dp)
       return
    end if

    ! If cos_b is +1, then the angles are the same and phi is undefined
    if(abs(cos_b - 1._dp) < 1.e-10_dp) then
       a_local = angle3d_deg(0._dp,0._dp)
       return
    end if

    same_sign = cos_a > 0._dp .eqv. cos_b > 0._dp .and. sin_a > 0._dp .eqv. sin_b > 0._dp
    if(abs(sin_a) > abs(cos_a)) then
       delta = cos_b - cos_a
    else
       delta = sin_b - sin_a
    end if

    if(same_sign .and. abs(delta) < 1.e-5_dp .and. sin_c < 1.e-5_dp) then

       if (abs(sin_a) > abs(cos_a)) then
          diff = (sin_c * sin_c - delta * delta * (1._dp + (cos_a / sin_a)**2)) / (sin_a * sin_b)
       else
          diff = (sin_c * sin_c - delta * delta * (1._dp + (sin_a / cos_a)**2)) / (sin_a * sin_b)
       end if

       if(diff >= 0._dp) then
          sin_big_c = sqrt(diff)
       else
          sin_big_c = 0._dp
       end if

       if(cos_c > 0._dp) then
          cos_big_c = sin2cos(sin_big_c)
       else
          cos_big_c = - sin2cos(sin_big_c)
       end if

    else
       sin_big_c = + abs(sin_big_b) * sin_c / sin_b
       cos_big_c = ( cos_c - cos_a * cos_b ) / ( sin_a * sin_b )
    end if

    ! If sin_big_c is zero, this can cause issues in other routines, so we
    ! make it the next floating point, which should have no effect on
    ! calculations but prevents issues.
    if(sin_big_c == 0._dp) sin_big_c = tiny(1._dp)

    ! --- Find final theta and phi values --- !

    a_local%cost = cos_b
    a_local%sint = sin_b

    if(sin_big_b < 0._dp) then

       a_local%cosp = cos_big_C
       a_local%sinp = sin_big_C

    else

       a_local%cosp = cos_big_C
       a_local%sinp = - sin_big_C

    end if

  end subroutine difference_angle3d_dp

  real(dp) function sin2cos_dp(x) result(y)
    implicit none
    real(dp), intent(in) :: x
    if(x * x < 1._dp) then
       y = sqrt(1._dp - x * x)
    else
       y = 0._dp
    end if
  end function sin2cos_dp

  subroutine random_sphere_angle3d_dp(a)
    ! Random position on a unit sphere
    use lib_random
    implicit none
    type(angle3d_dp),intent(out) :: a
    real(dp) :: phi
    call random_sphere(a%cost,phi)
    a%sint = sqrt(1._dp - a%cost * a%cost)
    a%cosp = cos(phi)
    a%sinp = sin(phi)
  end subroutine random_sphere_angle3d_dp

  type(angle3d_dp) function minus_angle_dp(a) result(b)
    implicit none
    type(angle3d_dp),intent(in) :: a
    b = angle3d_dp(-a%cost, a%sint, -a%cosp, -a%sinp)
  end function minus_angle_dp

  logical function equal_sp(a, b) result(e)

    implicit none

    type(angle3d_sp),intent(in) :: a, b

    e = a%cost == b%cost .and. a%sint == b%sint .and. a%cosp == b%cosp .and. a%sinp == b%sinp

  end function equal_sp

  type(angle3d_sp) function angle3d_deg_sp(theta,phi) result(a)

    implicit none

    real(sp),intent(in) :: theta,phi

    a%cost = cos(theta*deg2rad)
    a%sint = sin(theta*deg2rad)
    a%cosp = cos(phi*deg2rad)
    a%sinp = sin(phi*deg2rad)

  end function angle3d_deg_sp

  subroutine display_angle_sp(a)
    implicit none
    type(angle3d_sp),intent(in) :: a
    print '("Theta = ",F8.4," degrees")',atan2(a%sint,a%cost)*rad2deg
    print '("Phi   = ",F8.4," degrees")',atan2(a%sinp,a%cosp)*rad2deg
  end subroutine display_angle_sp

  real(sp) function dot_product_sp(a, b) result(p)

    implicit none

    type(angle3d_sp),intent(in) :: a, b

    p = a%sint*a%cosp*b%sint*b%cosp + a%sint*a%sinp*b%sint*b%sinp + a%cost * b%cost

  end function dot_product_sp

  subroutine rotate_angle3d_sp(a_local,a_coord,a_final)

    ! This subroutine is used to add a local angle, such as as
    ! photon emission angle on the surface of a star, or a photon
    ! scattering angle, to an already existing position angle.
    ! The former is given by a_local, the latter, by a_coord, and
    ! the final angle by a_angle. We solve this using spherical
    ! trigonometry. Consider a spherical triangle with corner angles
    ! (A,B,C) and side angles (a,b,c). The angle B is attached to the
    ! z axis, and the sides a and c are on the great circles passing
    ! through the z-axis. The meaning of the angles is as follows:

    ! a =   old theta angle (initial direction angle)
    ! b = local theta angle (scattering or emission angle)
    ! c =   new theta angle (final direction angle)

    ! A = no meaning (but useful for scattering)
    ! B = new phi - old phi
    ! C = local phi angle (scattering or emission angle)

    implicit none

    type(angle3d_sp),intent(in) :: a_local
    type(angle3d_sp),intent(in) :: a_coord
    type(angle3d_sp),intent(out) :: a_final

    real(sp) :: cos_a,sin_a
    real(sp) :: cos_b,sin_b
    real(sp) :: cos_c,sin_c

    real(sp) :: cos_big_b,sin_big_b
    real(sp) :: cos_big_c,sin_big_c

    real(sp) :: delta
    logical :: same_sign

    ! Special case - if coord%theta is 0, then final = local
    if(abs(a_coord%sint) < 1.e-10_sp) then
       if(a_coord%cost > 0._sp) then
          a_final = a_local
          a_final%cosp = + a_local%cosp * a_coord%cosp + a_local%sinp * a_coord%sinp
          a_final%sinp = + a_local%cosp * a_coord%sinp - a_local%sinp * a_coord%cosp
       else
          a_final = a_local
          a_final%cost = - a_local%cost
          a_final%cosp = + a_local%cosp * a_coord%cosp - a_local%sinp * a_coord%sinp
          a_final%sinp = + a_local%cosp * a_coord%sinp + a_local%sinp * a_coord%cosp
       end if
       return
    end if

    ! --- Assign spherical triangle angles values --- !

    ! The angles in the spherical triangle are as follows:

    cos_a = a_coord%cost
    sin_a = a_coord%sint

    cos_b = a_local%cost
    sin_b = a_local%sint

    if(a_local%sinp < 0._sp) then ! the angle in the triangle is then actually 2*pi - local phi
       cos_big_C = + a_local%cosp
       sin_big_C = - a_local%sinp
    else ! the angle is local phi
       cos_big_C = + a_local%cosp
       sin_big_C = + a_local%sinp
    end if

    ! --- Solve the spherical triangle --- !

    if (abs(sin_a) > abs(cos_a)) then
       same_sign = sin_a > 0._sp .eqv. sin_b > 0._sp
       delta = cos_b - cos_a
    else
       same_sign = cos_a > 0._sp .eqv. cos_b > 0._sp
       delta = sin_b - sin_a
    end if

    if(same_sign .and. abs(delta) < 1.e-5_sp .and. sin_big_C < 1.e-5_sp .and. cos_big_c > 0._sp) then
       if (abs(sin_a) > abs(cos_a)) then
          sin_c = sqrt(delta * delta * (1._sp + (cos_a/sin_a)**2) + sin_a * sin_b * sin_big_C * sin_big_C)
       else
          sin_c = sqrt(delta * delta * (1._sp + (sin_a/cos_a)**2) + sin_a * sin_b * sin_big_C * sin_big_C)
       end if
       cos_c = sin2cos(sin_c)
    else
       cos_c = cos_a * cos_b + sin_a * sin_b * cos_big_c
       sin_c = cos2sin(cos_c)
    end if

    ! Special case - if local and coord theta are the same and C = 0, return
    ! vertical vector. We can't do better than that because we are limited by
    ! numerical precision, in particular for delta (above) which will be limited
    ! in precision
    if(abs(sin_c) < 1.e-10_sp) then
       write(*,'(" WARNING: final angle is vertical, and phi is undetermined (set to 0) [rotate_angle3d]")')
       if(cos_c > 0._sp) then
          a_final = angle3d_deg(0._sp,0._sp)
       else
          a_final = angle3d_deg(180._sp,0._sp)
       end if
       return
    end if

    cos_big_b = ( cos_b - cos_a * cos_c ) / ( sin_a * sin_c )
    sin_big_b = + sin_big_c * sin_b / sin_c

    ! --- Find final theta and phi values --- !

    a_final%cost = cos_c
    a_final%sint = sin_c

    if(a_local%sinp < 0._sp) then ! the top angle is old phi - new phi
       a_final%cosp = + cos_big_b * a_coord%cosp + sin_big_b * a_coord%sinp
       a_final%sinp = + cos_big_b * a_coord%sinp - sin_big_b * a_coord%cosp
    else ! the top angle is new phi - old phi
       a_final%cosp = + cos_big_b * a_coord%cosp - sin_big_b * a_coord%sinp
       a_final%sinp = + cos_big_b * a_coord%sinp + sin_big_b * a_coord%cosp
    end if

  end subroutine rotate_angle3d_sp

  subroutine difference_angle3d_sp(a_coord,a_final,a_local)

    ! This subroutine is used to find the local angle by which
    ! a coordinate angle would have to be rotated to give the
    ! final angle specified. This is complementary to the rotate_
    ! angle3d routine.

    ! We solve this using spherical
    ! trigonometry. Consider a spherical triangle with corner angles
    ! (A,B,C) and side angles (a,b,c). The angle B is attached to the
    ! z axis, and the sides a and c are on the great circles passing
    ! through the z-axis. The meaning of the angles is as follows:

    ! a =   old theta angle (initial direction angle)
    ! b = local theta angle (scattering or emission angle)
    ! c =   new theta angle (final direction angle)

    ! A = no meaning (but useful for scattering)
    ! B = new phi - old phi
    ! C = local phi angle (scattering or emission angle)

    implicit none

    type(angle3d_sp),intent(out) :: a_local
    type(angle3d_sp),intent(in) :: a_coord
    type(angle3d_sp),intent(in) :: a_final

    real(sp) :: cos_a,sin_a
    real(sp) :: cos_b,sin_b
    real(sp) :: cos_c,sin_c

    real(sp) :: cos_big_b,sin_big_b
    real(sp) :: cos_big_c,sin_big_c

    real(dp) :: delta,diff
    logical :: same_sign

    ! Special case - if coord%theta is 0, then final = local
    if(abs(a_coord%sint) < 1.e-10_sp) then
       if(a_coord%cost > 0._sp) then
          a_local = a_final
          a_local%cosp = + a_coord%cosp * a_final%cosp + a_coord%sinp * a_final%sinp
          a_local%sinp = - a_coord%cosp * a_final%sinp + a_coord%sinp * a_final%cosp
       else
          a_local = a_final
          a_local%cost = - a_local%cost
          a_local%cosp = + a_coord%cosp * a_final%cosp + a_coord%sinp * a_final%sinp
          a_local%sinp = + a_coord%cosp * a_final%sinp - a_coord%sinp * a_final%cosp
       end if
       return
    end if

    ! --- Assign spherical triangle angles values --- !

    ! The angles in the spherical triangle are as follows:

    cos_a = a_coord%cost
    sin_a = a_coord%sint

    cos_c = a_final%cost
    sin_c = a_final%sint

    cos_big_B = a_coord%cosp * a_final%cosp + a_coord%sinp * a_final%sinp
    sin_big_B = a_coord%sinp * a_final%cosp - a_coord%cosp * a_final%sinp

    ! --- Solve the spherical triangle --- !

    cos_b = cos_a * cos_c + sin_a * sin_c * cos_big_B
    sin_b = cos2sin(cos_b)

    ! If cos_b is -1, then the angles are opposite and phi is undefined
    if(abs(cos_b + 1._sp) < 1.e-10_sp) then
       a_local = angle3d_deg(180._sp,0._sp)
       return
    end if

    ! If cos_b is +1, then the angles are the same and phi is undefined
    if(abs(cos_b - 1._sp) < 1.e-10_sp) then
       a_local = angle3d_deg(0._sp,0._sp)
       return
    end if

    same_sign = cos_a > 0._sp .eqv. cos_b > 0._sp .and. sin_a > 0._sp .eqv. sin_b > 0._sp
    if(abs(sin_a) > abs(cos_a)) then
       delta = cos_b - cos_a
    else
       delta = sin_b - sin_a
    end if

    if(same_sign .and. abs(delta) < 1.e-5_sp .and. sin_c < 1.e-5_sp) then

       if (abs(sin_a) > abs(cos_a)) then
          diff = (sin_c * sin_c - delta * delta * (1._sp + (cos_a / sin_a)**2)) / (sin_a * sin_b)
       else
          diff = (sin_c * sin_c - delta * delta * (1._sp + (sin_a / cos_a)**2)) / (sin_a * sin_b)
       end if

       if(diff >= 0._sp) then
          sin_big_c = sqrt(diff)
       else
          sin_big_c = 0._sp
       end if

       if(cos_c > 0._sp) then
          cos_big_c = sin2cos(sin_big_c)
       else
          cos_big_c = - sin2cos(sin_big_c)
       end if

    else
       sin_big_c = + abs(sin_big_b) * sin_c / sin_b
       cos_big_c = ( cos_c - cos_a * cos_b ) / ( sin_a * sin_b )
    end if

    ! If sin_big_c is zero, this can cause issues in other routines, so we
    ! make it the next floating point, which should have no effect on
    ! calculations but prevents issues.
    if(sin_big_c == 0._sp) sin_big_c = tiny(1._sp)

    ! --- Find final theta and phi values --- !

    a_local%cost = cos_b
    a_local%sint = sin_b

    if(sin_big_b < 0._sp) then

       a_local%cosp = cos_big_C
       a_local%sinp = sin_big_C

    else

       a_local%cosp = cos_big_C
       a_local%sinp = - sin_big_C

    end if

  end subroutine difference_angle3d_sp

  real(sp) function sin2cos_sp(x) result(y)
    implicit none
    real(sp), intent(in) :: x
    if(x * x < 1._sp) then
       y = sqrt(1._sp - x * x)
    else
       y = 0._sp
    end if
  end function sin2cos_sp

  subroutine random_sphere_angle3d_sp(a)
    ! Random position on a unit sphere
    use lib_random
    implicit none
    type(angle3d_sp),intent(out) :: a
    real(sp) :: phi
    call random_sphere(a%cost,phi)
    a%sint = sqrt(1._sp - a%cost * a%cost)
    a%cosp = cos(phi)
    a%sinp = sin(phi)
  end subroutine random_sphere_angle3d_sp

  type(angle3d_sp) function minus_angle_sp(a) result(b)
    implicit none
    type(angle3d_sp),intent(in) :: a
    b = angle3d_sp(-a%cost, a%sint, -a%cosp, -a%sinp)
  end function minus_angle_sp

end module type_angle3d


PROGRAM complex
    implicit none
    real, parameter :: pi = 3.141592 ! Declaration of a constant like a #define in c++
    ! real:: a = 5.90, b = 7.2
    complex :: cpm
    ! cpm = a + (0, 1)*b  ! Assigning 2 real number to a complex number
    read(*, *) cpm ! In the console give input as ------>  (1.56, -8.3)
    print *, cpm, real(cpm), aimag(cpm)
        cpm = cpm*(0., 1.)
    print *, cpm
END


program array_op_3
implicit none

logical, allocatable :: a(:, :, :), b(:, :, :)
logical, allocatable :: c(:, :, :)
integer :: i, j, k, dim1 = 10, dim2 = 100, dim3 = 1

allocate(a(dim1, dim2, dim3), b(dim1, dim2, dim3), c(dim1, dim2, dim3))

do i = 1, dim1
    do j = 1, dim2
        do k = 1, dim3
            a(i, j, k) = modulo2(i + j + k)
            b(i, j, k) = modulo2(i*j + j*k + k*j)
        end do
    end do
end do

c = a .and. b
call verify(c, 0)

c = a .or. b
call verify(c, 1)

c = a .eqv. b
call verify(c, 2)

c = b .neqv. a
call verify(c, 3)

contains

    logical function modulo2(x) result(r)
    integer, intent(in) :: x
    r = (x - 2*(x/2) == 1)
    end function modulo2

    subroutine verify(c, op_code)
    implicit none

    logical, allocatable, intent(in) :: c(:, :, :)
    integer, intent(in) :: op_code

    integer :: i, j, k
    logical :: x, y

    do i = lbound(c, 1), ubound(c, 1)
        do j = lbound(c, 2), ubound(c, 2)
            do k = lbound(c, 3), ubound(c, 3)
                x = modulo2(i + j + k)
                y = modulo2(i*j + j*k + k*j)
                select case(op_code)
                case (0)
                    if(c(i, j, k) .neqv. (x .and. y)) error stop
                case (1)
                    if(c(i, j, k) .neqv. (x .or. y)) error stop
                case (2)
                    if(c(i, j, k) .neqv. (x .eqv. y)) error stop
                case (3)
                    if(c(i, j, k) .neqv. (x .neqv. y)) error stop
                end select
            end do
        end do
    end do

    end subroutine verify

end program


SUBROUTINE kepler_k2z (kepler, GM , r,v)

! ----------------------------------------------------------------------
! SUBROUTINE: kepler_k2z.f90
! ----------------------------------------------------------------------
! Purpose:
!  Conversion of Keplerian elements (a,e,i,Omega,omega,E) to Position and
!  Velocity vectors (Cartesian coordinates)
! ----------------------------------------------------------------------
! Input arguments:
! - kepler:		Kepler elements | Array with rank 6
!   a:       	semi-major axis  (m)
!   e:      	eccentricity
!   i:      	inclination (degrees)
!   Omega:  	right ascension of the ascending node (degrees)
!   omega:  	argument of perigee (degrees)
!   E:      	eccentric anomaly (degrees)
! - GM: 		Earth gravity constant,  m^3/sec^2
!
! Output arguments:
! - r:  		position (m)
! - v:  		velocity (m/sec)
! ----------------------------------------------------------------------
! Dr. Thomas Papanikolaou, Geoscience Australia            26 April 2016
! ----------------------------------------------------------------------

      USE mdl_precision
      USE mdl_num
      IMPLICIT NONE

! ----------------------------------------------------------------------
! Dummy arguments declaration
! ----------------------------------------------------------------------
! IN
      REAL (KIND = prec_q), INTENT(IN) :: kepler(6), GM
! OUT
      REAL (KIND = prec_q), INTENT(OUT) :: r(3), v(3)
! ----------------------------------------------------------------------

! ----------------------------------------------------------------------
! Local variables declaration
! ----------------------------------------------------------------------
      REAL (KIND = prec_q) :: a, e, i_rad, Omega_asc_rad, omega_per_rad, E_rad
      REAL (KIND = prec_q) :: n
      REAL (KIND = prec_q) :: P(3), Q(3), W(3), Rmatrix(3,3), r_orbplane(3), v_orbplane(3)
! ----------------------------------------------------------------------

! ----------------------------------------------------------------------
! Keplerian elements
! ----------------------------------------------------------------------
! semi-major axis
      a = kepler(1)

! Eccentricity
      e = kepler(2)

! Inclination
      !i_deg = kepler(3)
      i_rad = kepler(3) * (PI_global / 180D0)

! Omega : right ascension of the ascending node (degrees)
      !Omega_asc_deg = kepler(4)
      Omega_asc_rad = kepler(4) * (PI_global / 180D0)

! omega : argument of perigee (degrees)
      !omega_per_deg = kepler(5)
      omega_per_rad = kepler(5) * (PI_global / 180D0)

! E : eccentric anomaly (degrees)
      !E_deg = kepler(6)
      E_rad = kepler(6) * (PI_global / 180D0)
! ----------------------------------------------------------------------

! ----------------------------------------------------------------------
! Mean motion
      n = sqrt( GM / a**3 )
! ----------------------------------------------------------------------

! ----------------------------------------------------------------------
! Rotation matrix : Rmatrix = [P Q W]

!P = [cos(omega)*cos(Omega)-sin(omega)*cos(i)*sin(Omega)
!     cos(omega)*sin(Omega)+sin(omega)*cos(i)*cos(Omega)
!     sin(omega)*sin(i)];
      P(1) = cos(omega_per_rad) * cos(Omega_asc_rad) - sin(omega_per_rad) * cos(i_rad) * sin(Omega_asc_rad)
      P(2) = cos(omega_per_rad) * sin(Omega_asc_rad) + sin(omega_per_rad) * cos(i_rad) * cos(Omega_asc_rad)
      P(3) = sin(omega_per_rad) * sin(i_rad)

!Q = [-sin(omega)*cos(Omega)-cos(omega)*cos(i)*sin(Omega)
!     -sin(omega)*sin(Omega)+cos(omega)*cos(i)*cos(Omega)
!      cos(omega)*sin(i)];
      Q(1) = -1.0D0 * sin(omega_per_rad) * cos(Omega_asc_rad) - cos(omega_per_rad) * cos(i_rad) * sin(Omega_asc_rad)
      Q(2) = -1.0D0 * sin(omega_per_rad) * sin(Omega_asc_rad) + cos(omega_per_rad) * cos(i_rad) * cos(Omega_asc_rad)
      Q(3) = cos(omega_per_rad) * sin(i_rad)

!W = [sin(i)*sin(Omega)
!    -sin(i)*cos(Omega)
!    cos(i)];
      W(1) = sin(i_rad) * sin(Omega_asc_rad)
      W(2) = -1.0D0 * sin(i_rad) * cos(Omega_asc_rad)
      W(3) = cos(i_rad)

! Rmatrix = [P Q W]
      Rmatrix(1,1:3) = (/ P(1), Q(1), W(1) /)
      Rmatrix(2,1:3) = (/ P(2), Q(2), W(2) /)
      Rmatrix(3,1:3) = (/ P(3), Q(3), W(3) /)
! ----------------------------------------------------------------------

! ----------------------------------------------------------------------
! Coordinates in the orbital plane
      r_orbplane(1) = a * (cos(E_rad) - e)
	  r_orbplane(2) = a * sqrt(1.0D0 - e**2) * sin(E_rad)
      r_orbplane(3) = 0.0D0

! Derivatives of the coordinates in the orbital plane
      !dX = ( (n*a) / ( 1-e*cos(E) ) ) * [-sin(E); sqrt(1-e^2)*cos(E); 0;] ;
      v_orbplane(1) = ( (n * a) / (1.D0 - e * cos(E_rad)) ) * (-1.0D0 * sin(E_rad) )
	  v_orbplane(2) = ( (n * a) / (1.D0 - e * cos(E_rad)) ) * sqrt(1.0D0 - e**2) * cos(E_rad)
      v_orbplane(3) = 0.0D0
! ----------------------------------------------------------------------

! ----------------------------------------------------------------------
! Position vector
      !r = R * r_orbplane
      CALL matrix_Rr (Rmatrix, r_orbplane , r)

! Velocity vector
      !v = R * v_orbplane
      CALL matrix_Rr (Rmatrix, v_orbplane , v)
! ----------------------------------------------------------------------

end