!----------------------------------------------------------------------
!Module: num_rec
!---------------------------------------------------------------------
!> Code to compute the regular and irregular Coulomb wave functions.
!! See source code for detailed documentation
!!
!! @author A. R. Barnett
!---------------------------------------------------------------------
module coulombwf
  contains
! C----------------------------------------------------------------------
      SUBROUTINE COUL90(X, ETA, XLMIN,LRANGE, FC,GC,FCP,GCP, KFN,IFAIL)
! C----------------------------------------------------------------------
! C
! C  COULOMB & BESSEL FUNCTION PROGRAM-- COUL90 -- USING STEED'S METHOD
! C
! C  COUL90 RETURNS ARRAYS FC = F, GC = G, FCP = (D/DX) F, GCP = (D/DX) G
! C   FOR REAL X .GT. 0. ,REAL ETA (INCLUDING 0.), AND REAL XLMIN .GT.-1.
! C   FOR (LRANGE+1) INTEGER-SPACED LAMBDA VALUES.
! C   IT HENCE GIVES POSITIVE-ENERGY SOLUTIONS TO THE COULOMB SCHRODINGER
! C   EQUATION, TO THE KLEIN-GORDON EQUATION AND TO SUITABLE FORMS OF
! C   THE DIRAC EQUATION.    BY SETTING ETA = 0.0 AND RENORMALISING
! C   SPHERICAL & CYLINDRICAL BESSEL FUNCTIONS ARE COMPUTED INSTEAD.
! C----------------------------------------------------------------------
! C   CALLING VARIABLES; ALL REALS ARE DOUBLE PRECISION (REAL*8)
! C
! C   X       - REAL ARGUMENT FOR COULOMB FUNCTIONS > 0.0
! C             [ X > SQRT(ACCUR) : ACCUR IS TARGET ACCURACY 1.0D-14 ]
! C   ETA     - REAL SOMMERFELD PARAMETER, UNRESTRICTED > = < 0.0
! C   XLMIN   - REAL MINIMUM LAMBDA-VALUE (L-VALUE OR ORDER),
! C             GENERALLY IN RANGE 0.0 - 1.0 AND MOST USUALLY 0.0
! C   LRANGE  - INTEGER NUMBER OF ADDITIONAL L-VALUES : RESULTS RETURNED
! C             FOR L-VALUES XLMIN TO XLMIN + LRANGE INCLUSIVE
! C   FC ,GC  - REAL VECTORS F,G OF REGULAR, IRREGULAR COULOMB FUNCTIONS
! C   FCP,GCP - REAL VECTORS FOR THE X-DERIVATIVES OF  F,G
! C             THESE VECTORS TO BE OF LENGTH AT LEAST MINL + LRANGE
! C             STARTING ELEMENT MINL = MAX0( IDINT(XLMIN+ACCUR),0 )
! C   KFN     - INTEGER CHOICE OF FUNCTIONS TO BE COMPUTED :
! C           = 0         REAL COULOMB FUNCTIONS AND DERIVATIVES F & G
! C           = 1    SPHERICAL BESSEL      "      "     "        j & y
! C           = 2  CYLINDRICAL BESSEL      "      "     "        J & Y
! C
! C   PRECISION:  RESULTS TO WITHIN 2-3 DECIMALS OF "MACHINE ACCURACY"
! C   IN OSCILLATING REGION X .GE. [ETA + SQRT{ETA**2 + XLM*(XLM+1)}]
! C   I.E. THE TARGET ACCURACY ACCUR SHOULD BE 100 * ACC8 WHERE ACC8 IS
! C   THE SMALLEST NUMBER WITH 1.+ACC8.NE.1. FOR OUR WORKING PRECISION.
! C   THIS RANGES BETWEEN 4E-15 AND 2D-17 ON CRAY, VAX, SUN, PC FORTRANS
! C   SO CHOOSE A SENSIBLE  ACCUR = 1.0D-14
! C   IF X IS SMALLER THAN [ ] ABOVE THE ACCURACY BECOMES STEADILY WORSE:
! C   THE VARIABLE PACCQ IN COMMON /STEED/ HAS AN ESTIMATE OF ACCURACY.
! C----------------------------------------------------------------------
! C   ERROR RETURNS                THE USER SHOULD TEST IFAIL ON EXIT
! C
! C   IFAIL ON INPUT IS SET TO 0                        LIMIT = 20000
! C   IFAIL IN OUTPUT =  0 : CALCULATIONS SATISFACTORY
! C                   =  1 : CF1 DID NOT CONVERGE AFTER LIMIT ITERATIONS
! C                   =  2 : CF2 DID NOT CONVERGE AFTER LIMIT ITERATIONS
! C                   = -1 : X < 1D-7 = SQRT(ACCUR)
! C                   = -2 : INCONSISTENCY IN ORDER VALUES (L-VALUES)
! C----------------------------------------------------------------------
! C  MACHINE-DEPENDENT PARAMETERS:    ACCUR - SEE ABOVE
! C           SMALL - OFFSET FOR RECURSION = APPROX SQRT(MIN REAL NO.)
! C           IE 1D-30 FOR IBM REAL*8,    1D-150 FOR DOUBLE PRECISION
! C----------------------------------------------------------------------
! C  PROGRAMMING HISTORY AND BACKGROUND: CPC IS COMPUTER PHYSICS COMMUN.
! C  ORIGINAL PROGRAM  RCWFN       IN    CPC  8 (1974) 377-395
! C                 +  RCWFF       IN    CPC 11 (1976) 141-142
! C  FULL DESCRIPTION OF ALGORITHM IN    CPC 21 (1981) 297-314
! C  REVISED STANDARD  COULFG      IN    CPC 27 (1982) 147-166
! C  BACKGROUND MATERIAL IN J. COMP. PHYSICS 46 (1982) 171-188
! C  CURRENT PROGRAM   COUL90  (FORTRAN77) SUPERCEDES THESE EARLIER ONES
! C  (WHICH WERE WRITTEN IN FORTRAN 4) AND ALSO BY INCORPORATING THE NEW
! C  LENTZ-THOMPSON ALGORITHM FOR EVALUATING THE FIRST CONTINUED FRACTION
! C  ..SEE ALSO APPENDIX TO J. COMP. PHYSICS 64 (1986) 490-509     1.4.94
! C----------------------------------------------------------------------
! C  AUTHOR: A. R. BARNETT           MANCHESTER  MARCH   1981/95
! C                                  AUCKLAND    MARCH   1991
! C----------------------------------------------------------------------
      IMPLICIT         NONE
      INTEGER          LRANGE, KFN, IFAIL
      DOUBLE PRECISION X, ETA, XLMIN
      DOUBLE PRECISION FC (0:*), GC (0:*), FCP(0:*), GCP(0:*)
! C----- ARRAYS INDEXED FROM 0 INSIDE SUBROUTINE: STORAGE FROM MINL
      DOUBLE PRECISION ACCUR,ACCH,SMALL, ONE,ZERO,HALF,TWO,TEN2, RT2DPI
      DOUBLE PRECISION XINV,PK,CF1,C,D,PK1,ETAK,RK2,TK,DCF1,DEN,XLM,XLL
      DOUBLE PRECISION EL,XL,RL,SL, F,FCMAXL,FCMINL,GCMINL,OMEGA,WRONSK
      DOUBLE PRECISION WI, A,B, AR,AI,BR,BI,DR,DI,DP,DQ, ALPHA,BETA
      DOUBLE PRECISION E2MM1, FJWKB,GJWKB, P,Q,PACCQ, GAMMA,GAMMAI
      INTEGER          IEXP, NFP, NPQ, L, MINL,MAXL, LIMIT
      LOGICAL          ETANE0, XLTURN
      PARAMETER      ( LIMIT = 20000, SMALL = 1.0D-150 )
      !COMMON  /STEED/  PACCQ,NFP,NPQ,IEXP,MINL    !not required in code
      !COMMON  /DESET/  CF1,P,Q,F,GAMMA,WRONSK     !information only
! C----------------------------------------------------------------------
! C     COUL90 HAS CALLS TO: DSQRT,DABS,MAX0,IDINT,DSIGN,DFLOAT,DMIN1
! C----------------------------------------------------------------------
      DATA ZERO,ONE,TWO,TEN2,HALF /0.0D0, 1.0D0, 2.0D0, 1.0D2, 0.5D0/
      DATA RT2DPI /0.797884560802865D0/
! CQ    DATA RT2DPI /0.79788 45608 02865 35587 98921 19868 76373 Q0/
! C-----THIS CONSTANT IS  DSQRT(TWO / PI):
! C-----USE Q0 FOR IBM REAL*16: D0 FOR REAL*8 AND DOUBLE PRECISION
! C----------------CHANGE ACCUR TO SUIT MACHINE AND PRECISION REQUIRED
                        ACCUR = 1.0D-14
      IFAIL = 0
      IEXP  = 1
      NPQ   = 0
      GJWKB = ZERO
      PACCQ = ONE
      IF(KFN .NE. 0) ETA = ZERO
                 ETANE0  = ETA .NE. ZERO
      ACCH  = DSQRT(ACCUR)
! C-----   TEST RANGE OF X, EXIT IF.LE.DSQRT(ACCUR) OR IF NEGATIVE
                IF( X .LE. ACCH )                GO TO 100
      IF( KFN.EQ.2 )   THEN
         XLM = XLMIN - HALF
        ELSE
         XLM = XLMIN
        ENDIF
      IF( XLM.LE.-ONE .OR. LRANGE.LT.0 )         GO TO 105
      E2MM1  = XLM * XLM + XLM
      XLTURN = X * (X -  TWO * ETA) .LT. E2MM1
      E2MM1  = E2MM1  +  ETA * ETA
      XLL    = XLM + FLOAT(LRANGE)
! C-----  LRANGE IS NUMBER OF ADDITIONAL LAMBDA VALUES TO BE COMPUTED
! C-----  XLL  IS MAX LAMBDA VALUE [ OR 0.5 SMALLER FOR J,Y BESSELS ]
! C-----  DETERMINE STARTING ARRAY ELEMENT (MINL) FROM XLMIN
      MINL  = MAX0( IDINT(XLMIN + ACCUR),0 )     ! index from 0
      MAXL  = MINL + LRANGE
! C-----   EVALUATE CF1  =  F   =  DF(L,ETA,X)/DX   /   F(L,ETA,X)
      XINV = ONE / X
      DEN  = ONE                       ! unnormalised F(MAXL,ETA,X)
      PK   = XLL + ONE
      CF1  = ETA / PK  +  PK * XINV
           IF( DABS(CF1).LT.SMALL )    CF1 = SMALL
      RK2  = ONE
         D = ZERO
         C = CF1
! C----- BEGIN CF1 LOOP ON PK = K STARTING AT LAMBDA + 1: LENTZ-THOMPSON
      DO 10 L =  1 , LIMIT             ! abort if reach LIMIT (20000)
          PK1 = PK + ONE
          IF( ETANE0 ) THEN
                ETAK = ETA / PK
                RK2  = ONE + ETAK * ETAK
                 TK  = (PK + PK1) * (XINV + ETAK / PK1)
             ELSE
                 TK  = (PK + PK1) * XINV
             ENDIF
          D   =  TK - RK2 * D          ! direct  ratio of B convergents
          C   =  TK - RK2 / C          ! inverse ratio of A convergents
            IF( DABS(C).LT.SMALL ) C = SMALL
            IF( DABS(D).LT.SMALL ) D = SMALL
          D   = ONE / D
          DCF1=   D * C
          CF1 = CF1 * DCF1
              IF( D.LT.ZERO )    DEN = -DEN
          PK  = PK1
          IF( DABS(DCF1-ONE).LT.ACCUR )     GO TO  20 ! proper exit
   10 CONTINUE
                                            GO TO 110 ! error exit
   20       NFP = INT(PK - XLL - 1)                   ! number of steps
              F = CF1                                 ! need DEN later
! C----DOWNWARD RECURRENCE TO LAMBDA = XLM; ARRAYS GC, GCP STORE RL, SL
      IF( LRANGE.GT.0 )       THEN
          FCMAXL    = SMALL  * DEN
          FCP(MAXL) = FCMAXL * CF1
          FC (MAXL) = FCMAXL
                    XL = XLL
                    RL = ONE
          DO 30 L =  MAXL, MINL+1, -1
             IF( ETANE0 )  THEN
                    EL = ETA / XL
                    RL = DSQRT( ONE + EL * EL )
                    SL = XL * XINV  + EL
                    GC (L) = RL                  ! storage
                    GCP(L) = SL
                ELSE
                    SL = XL * XINV
                ENDIF
             FC (L-1)  = ( FC(L)   * SL  +  FCP(L) ) / RL
             FCP(L-1)  =   FC(L-1) * SL  -  FC (L) * RL
             XL    =  XL - ONE                   ! end value is XLM
   30     CONTINUE
         IF( DABS(FC(MINL)).LT.ACCUR*SMALL )  FC(MINL) = ACCUR * SMALL
          F   = FCP(MINL) / FC(MINL)             ! F'/F at min L-value
          DEN = FC (MINL)                        ! normalisation
      ENDIF
! C---------------------------------------------------------------------
! C-----   NOW WE HAVE REACHED LAMBDA = XLMIN = XLM
! C-----   EVALUATE CF2 = P + I.Q  USING STEED'S ALGORITHM (NO ZEROS)
! C---------------------------------------------------------------------
      IF( XLTURN ) CALL JWKB( X,ETA,DMAX1(XLM,ZERO),FJWKB,GJWKB,IEXP )
      IF( IEXP.GT.1 .OR. GJWKB.GT.(ONE / (ACCH*TEN2)) ) THEN
          OMEGA = FJWKB
          GAMMA = GJWKB * OMEGA
          P     = F
          Q     = ONE
        ELSE                                     ! find cf2
          XLTURN = .FALSE.
          PK =  ZERO
          WI =  ETA + ETA
          P  =  ZERO
          Q  =  ONE - ETA * XINV
          AR = -E2MM1
          AI =  ETA
          BR =  TWO * (X - ETA)
          BI =  TWO
          DR =  BR / (BR * BR + BI * BI)
          DI = -BI / (BR * BR + BI * BI)
          DP = -XINV * (AR * DI + AI * DR)
          DQ =  XINV * (AR * DR - AI * DI)
          DO 40 L = 1, LIMIT
             P  = P  + DP
             Q  = Q  + DQ
             PK = PK + TWO
             AR = AR + PK
             AI = AI + WI
             BI = BI + TWO
             D  = AR * DR - AI * DI + BR
             DI = AI * DR + AR * DI + BI
             C  = ONE / (D * D + DI * DI)
             DR =  C * D
             DI = -C * DI
             A  = BR * DR - BI * DI - ONE
             B  = BI * DR + BR * DI
             C  = DP * A  - DQ * B
             DQ = DP * B  + DQ * A
             DP = C
      IF( DABS(DP)+DABS(DQ).LT.(DABS(P)+DABS(Q)) * ACCUR ) GO TO 50
   40     CONTINUE
                                              GO TO 120 ! error exit
   50     NPQ   = INT(PK / TWO)                         ! proper exit
          PACCQ = HALF * ACCUR / DMIN1( DABS(Q),ONE )
          IF( DABS(P).GT.DABS(Q) ) PACCQ = PACCQ * DABS(P)
! C---------------------------------------------------------------------
! C    SOLVE FOR FCMINL = F AT LAMBDA = XLM AND NORMALISING FACTOR OMEGA
! C---------------------------------------------------------------------
          GAMMA   = (F - P) / Q
          GAMMAI  = ONE / GAMMA
          IF( DABS(GAMMA) .LE. ONE )  THEN
                 OMEGA  = DSQRT( ONE  +  GAMMA * GAMMA )
            ELSE
                 OMEGA  = DSQRT( ONE  +  GAMMAI* GAMMAI) * DABS(GAMMA)
            ENDIF
          OMEGA  = ONE / ( OMEGA * DSQRT(Q) )
          WRONSK = OMEGA
        ENDIF
! C---------------------------------------------------------------------
! C    RENORMALISE IF SPHERICAL OR CYLINDRICAL BESSEL FUNCTIONS
! C---------------------------------------------------------------------
      IF( KFN.EQ.1 )       THEN         !   spherical Bessel functions
                 ALPHA = XINV
                 BETA  = XINV
        ELSEIF( KFN.EQ.2 ) THEN         ! cylindrical Bessel functions
                 ALPHA = HALF * XINV
                 BETA  = DSQRT( XINV ) * RT2DPI
        ELSE                            ! kfn = 0,   Coulomb functions
                 ALPHA = ZERO
                 BETA  = ONE
        ENDIF
      FCMINL = DSIGN( OMEGA,DEN ) * BETA
      IF( XLTURN )   THEN
                        GCMINL =   GJWKB * BETA
        ELSE
                        GCMINL =  FCMINL * GAMMA
        ENDIF
      IF( KFN.NE.0 )    GCMINL = -GCMINL         ! Bessel sign differs
      FC (MINL) = FCMINL
      GC (MINL) = GCMINL
      GCP(MINL) = GCMINL * (P - Q / GAMMA - ALPHA)
      FCP(MINL) = FCMINL * (F - ALPHA)
      IF( LRANGE.EQ.0 )                          RETURN
! C---------------------------------------------------------------------
! C    UPWARD RECURRENCE FROM GC(MINL),GCP(MINL) STORED VALUES ARE RL,SL
! C    RENORMALISE FC,FCP AT EACH LAMBDA AND CORRECT REGULAR DERIVATIVE
! C      XL   = XLM HERE  AND RL = ONE , EL = ZERO FOR BESSELS
! C---------------------------------------------------------------------
      OMEGA = BETA * OMEGA / DABS(DEN)
                 XL = XLM
                 RL = ONE
      DO 60  L = MINL+1 , MAXL                   ! indexed from 0
                 XL = XL + ONE
          IF( ETANE0 ) THEN
                 RL = GC (L)
                 SL = GCP(L)
            ELSE
                 SL =  XL * XINV
            ENDIF
          GC (L)  = ( (SL - ALPHA) * GC(L-1) - GCP(L-1) ) / RL
          GCP(L)  =    RL *  GC(L-1)  -  (SL + ALPHA) * GC(L)
          FCP(L)  = OMEGA * ( FCP(L)  -  ALPHA * FC(L) )
          FC (L)  = OMEGA *   FC (L)
   60 CONTINUE
      RETURN
! C------------------   ERROR MESSAGES
  100 IFAIL = -1
      WRITE(6,1000) X,ACCH
 1000 FORMAT(' FOR X = ',1PD12.3,'     TRY SMALL-X  SOLUTIONS,'&
           ' OR X IS NEGATIVE'/ ,' SQUARE ROOT (ACCURACY) =  ',D12.3/)
                     RETURN
  105 IFAIL = -2
      WRITE (6,1005) LRANGE,XLMIN,XLM
 1005 FORMAT(/' PROBLEM WITH INPUT ORDER VALUES: LRANGE, XLMIN, XLM = ',&
           I10,1P2D15.6/)
                     RETURN
  110 IFAIL =  1
      WRITE (6,1010) LIMIT, CF1,DCF1, PK,ACCUR
 1010 FORMAT(' CF1 HAS FAILED TO CONVERGE AFTER ',I10,' ITERATIONS',/&
           ' CF1,DCF1,PK,ACCUR =  ',1P4D12.3/)
                     RETURN
  120 IFAIL =  2
      WRITE (6,1020) LIMIT,P,Q,DP,DQ,ACCUR
 1020 FORMAT(' CF2 HAS FAILED TO CONVERGE AFTER ',I7,' ITERATIONS',/&
           ' P,Q,DP,DQ,ACCUR =  ',1P4D17.7,D12.3/)
                     RETURN
    END SUBROUTINE COUL90
! C---------------------------------------------------------------------
    SUBROUTINE  JWKB   (X,ETA,XL, FJWKB,GJWKB, IEXP)
      DOUBLE PRECISION    X,ETA,XL, FJWKB,GJWKB, DZERO
! C----------------------------------------------------------------------
! C-----COMPUTES JWKB APPROXIMATIONS TO COULOMB FUNCTIONS  FOR XL .GE. 0.
! C-----AS MODIFIED BY BIEDENHARN ET AL. PHYS REV 97 (1955) 542-554
! C-----CALCULATED IN SINGLE, RETURNED IN DOUBLE PRECISION VARIABLES
! C-----CALLS DMAX1, SQRT, ALOG, EXP, ATAN2, FLOAT, INT
! C     AUTHOR:    A.R.BARNETT   FEB 1981    LAST UPDATE MARCH 1991
! C----------------------------------------------------------------------
      DOUBLE PRECISION    ZERO,HALF,ONE,SIX,TEN,RL35,ALOGE
      DOUBLE PRECISION    GH2,XLL1,HLL,HL,SL,RL2,GH,PHI,PHI10
      INTEGER IEXP, MAXEXP
      PARAMETER  ( MAXEXP = 300 )
      DATA  ZERO,HALF,ONE,SIX,TEN  /0.0E0, 0.5E0, 1.0E0, 6.0E0, 1.0E1/
      DATA DZERO,RL35,ALOGE /0.0D0, 35.0E0, 0.4342945E0 /
! C----------------------------------------------------------------------
! CHOOSE MAXEXP NEAR MAX EXPONENT RANGE E.G. 1.D300 FOR DOUBLE PRECISION
! C----------------------------------------------------------------------
      GH2   =  X * (ETA + ETA - X)
      XLL1  = DMAX1( XL * XL + XL, DZERO )
      IF( GH2 + XLL1 .LE. ZERO )                 RETURN
      HLL  = XLL1 + SIX / RL35
      HL   = SQRT(HLL)
      SL   = ETA / HL + HL / X
      RL2  = ONE + ETA * ETA / HLL
      GH   = SQRT(GH2 + HLL) / X
      PHI  = X*GH - HALF*( HL*LOG((GH + SL)**2 / RL2) - LOG(GH) )
      IF ( ETA.NE.ZERO ) PHI = PHI - ETA * ATAN2(X*GH,X - ETA)
      PHI10 = -PHI * ALOGE
      IEXP  =  INT(PHI10)
      IF ( IEXP.GT.MAXEXP ) THEN
           GJWKB = TEN**(PHI10 - FLOAT(IEXP))
      ELSE
           GJWKB = EXP(-PHI)
           IEXP  = 0
      ENDIF
      FJWKB = HALF / (GH * GJWKB)
      RETURN
    END SUBROUTINE JWKB
! C---------------------------------------------------------------------
! C     END OF CONTINUED-FRACTION COULOMB & BESSEL PROGRAM  COUL90
! C---------------------------------------------------------------------
end module coulombwf


subroutine trapz(x,v,n,F)
    implicit none;
 integer*4 i,n;
 real*8,dimension(n):: x,v;
 real*8:: F;
F=.5*(v(1)*(x(2)-x(1))+v(n)*(x(n)-x(n-1))&
&+DOT_PRODUCT(v(2:n-1),x(3:n)-x(1:n-2)));
   return;
end subroutine


!-*- mode: compilation; default-directory: "/tmp/" -*-
!Compilation started at Thu Jun  6 23:29:06
!
!a=./f && make $a && echo -2 | OMP_NUM_THREADS=2 $a
!gfortran -std=f2008 -Wall -fopenmp -ffree-form -fall-intrinsics -fimplicit-none f.f08 -o f
! assert           1 = */           1
! assert           2 = */           2
! assert           3 = */           3
! assert           4 = */           2           2
! assert           5 = */           5
! assert           6 = */           2           3
! assert           7 = */           7
! assert           8 = */           2           2           2
! assert           9 = */           3           3
! assert          10 = */           2           5
! assert          11 = */          11
! assert          12 = */           3           2           2
! assert          13 = */          13
! assert          14 = */           2           7
! assert          15 = */           3           5
! assert          16 = */           2           2           2           2
! assert          17 = */          17
! assert          18 = */           3           2           3
! assert          19 = */          19
! assert          20 = */           2           2           5
! assert          21 = */           3           7
! assert          22 = */           2          11
! assert          23 = */          23
! assert          24 = */           3           2           2           2
! assert          25 = */           5           5
! assert          26 = */           2          13
! assert          27 = */           3           3           3
! assert          28 = */           2           2           7
! assert          29 = */          29
! assert          30 = */           5           2           3
! assert          31 = */          31
! assert          32 = */           2           2           2           2           2
! assert          33 = */           3          11
! assert          34 = */           2          17
! assert          35 = */           5           7
! assert          36 = */           3           3           2           2
! assert          37 = */          37
! assert          38 = */           2          19
! assert          39 = */           3          13
! assert          40 = */           5           2           2           2

module prime_mod

  ! sieve_table stores 0 in prime numbers, and a prime factor in composites.
  integer, dimension(:), allocatable :: sieve_table
  private :: PrimeQ

contains

  ! setup routine must be called first!
  subroutine sieve(n) ! populate sieve_table.  If n is 0 it deallocates storage, invalidating sieve_table.
    integer, intent(in) :: n
    integer :: status, i, j
    if ((n .lt. 1) .or. allocated(sieve_table)) deallocate(sieve_table)
    if (n .lt. 1) return
    allocate(sieve_table(n), stat=status)
    if (status .ne. 0) stop 'cannot allocate space'
    sieve_table(1) = 1
    do i=2,int(sqrt(real(n)))+1
       if (sieve_table(i) .eq. 0) then
          do j = i*i, n, i
             sieve_table(j) = i
          end do
       end if
    end do
  end subroutine sieve

  subroutine check_sieve(n)
    integer, intent(in) :: n
    if (.not. (allocated(sieve_table) .and. ((1 .le. n) .and. (n .le. size(sieve_table))))) stop 'Call sieve first'
  end subroutine check_sieve

  logical function isPrime(p)
    integer, intent(in) :: p
    call check_sieve(p)
    isPrime = PrimeQ(p)
  end function isPrime

  logical function isComposite(p)
    integer, intent(in) :: p
    isComposite = .not. isPrime(p)
  end function isComposite

  logical function PrimeQ(p)
    integer, intent(in) :: p
    PrimeQ = sieve_table(p) .eq. 0
  end function PrimeQ

  subroutine prime_factors(p, rv, n)
    integer, intent(in) :: p ! number to factor
    integer, dimension(:), intent(out) :: rv ! the prime factors
    integer, intent(out) :: n ! number of factors returned
    integer :: i, m
    call check_sieve(p)
    m = p
    i = 1
    if (p .ne. 1) then
       do while ((.not. PrimeQ(m)) .and. (i .lt. size(rv)))
          rv(i) = sieve_table(m)
          m = m/rv(i)
          i = i+1
       end do
    end if
    if (i .le. size(rv)) rv(i) = m
    n = i
  end subroutine prime_factors

end module prime_mod

program count_in_factors
  use prime_mod
  integer :: i, n
  integer, dimension(8) :: factors
  call sieve(40)                ! setup
  do i=1,40
     factors = 0
     call prime_factors(i, factors, n)
     write(6,*)'assert',i,'= */',factors(:n)
  end do
  call sieve(0)                 ! release memory
end program count_in_factors


program serialpi
  integer, parameter:: dp = kind(1.0d0)
  real(dp), parameter :: pi25 = 3.141592653589793238462643_dp
  integer :: n, i
  real(dp) :: pi, h, sum, x
  logical :: done

  done = .false.

  do while ( .not.done)
     write(*,'("Enter the number of intervals: (0 quits) ")')
     read(*,*) n

     if (n == 0) exit

     h = 1.0_dp/dble(n)
     sum = 0.0_dp

     do i = 1, n
        x = h * (i - 0.5_dp)
        sum = sum + 4.0_dp/(1.0_dp + x*x)
     enddo

     pi = h * sum

     write(*,'(" pi is approximately ",f16.13," Error is ",f16.13)') &
          pi, abs(pi - pi25)

  end do

end program serialpi


!-------------------------------------------------------------------------------
! Copyright (c) 2016 The University of Tokyo
! This software is released under the MIT License, see LICENSE.txt
!-------------------------------------------------------------------------------
!> \brief  This module contains functions for interpolation in 6 node
!!    prism element  (Langrange  interpolation)
module shape_prism6n
  integer, parameter, private :: kreal = kind(0.0d0)

contains
  subroutine ShapeFunc_prism6n(ncoord,func)
    use shape_tri3n
    real(kind=kreal), intent(in)  :: ncoord(3)
    real(kind=kreal) :: func(6)
    real(kind=kreal) :: xi, et, a, ze
    xi=ncoord(1); et=ncoord(2); ze=ncoord(3)
    a=1.d0-xi-et
    func(1)=0.5d0*a *(1.d0-ze)
    func(2)=0.5d0*xi*(1.d0-ze)
    func(3)=0.5d0*et*(1.d0-ze)
    func(4)=0.5d0*a *(1.d0+ze)
    func(5)=0.5d0*xi*(1.d0+ze)
    func(6)=0.5d0*et*(1.d0+ze)
  end subroutine

  subroutine ShapeDeriv_prism6n(ncoord,func)
    real(kind=kreal), intent(in)  :: ncoord(3)
    real(kind=kreal) :: func(6,3)
    real(kind=kreal) :: xi, et, a, ze
    xi=ncoord(1); et=ncoord(2); ze=ncoord(3)
    a=1.d0-xi-et

    !      func(1,1) = 0.5d0*(1.d0-ncoord(3))
    !     func(2,1) = 0.d0
    !    func(3,1) = -0.5d0*(1.d0-ncoord(3))
    !   func(4,1) = 0.5d0*(1.d0+ncoord(3))
    !    func(5,1) = 0.d0
    !    func(6,1) = -0.5d0*(1.d0+ncoord(3))

    !    func(1,2) = 0.d0
    !    func(2,2) = 0.5d0*(1.d0-ncoord(3))
    !    func(3,2) = -0.5d0*(1.d0-ncoord(3))
    !    func(4,2) = 0.d0
    !    func(5,2) = 0.5d0*(1.d0+ncoord(3))
    !    func(6,2) = -0.5d0*(1.d0+ncoord(3))

    !    func(1,3) = -0.5d0*ncoord(1)
    !    func(2,3) = -0.5d0*ncoord(2)
    !    func(3,3) = -0.5d0*(1.d0-ncoord(1)-ncoord(2))
    !    func(4,3) = 0.5d0*ncoord(1)
    !    func(5,3) = 0.5d0*ncoord(2)
    !    func(6,3) = 0.5d0*(1.d0-ncoord(1)-ncoord(2))
    !
    !     local derivatives of the shape functions: xi-derivative
    !
    func(1,1)=-0.5d0*(1.d0-ze)
    func(2,1)= 0.5d0*(1.d0-ze)
    func(3,1)= 0.d0
    func(4,1)=-0.5d0*(1.d0+ze)
    func(5,1)= 0.5d0*(1.d0+ze)
    func(6,1)= 0.d0
    !
    !     local derivatives of the shape functions: eta-derivative
    !
    func(1,2)=-0.5d0*(1.d0-ze)
    func(2,2)= 0.d0
    func(3,2)= 0.5d0*(1.d0-ze)
    func(4,2)=-0.5d0*(1.d0+ze)
    func(5,2)= 0.d0
    func(6,2)= 0.5d0*(1.d0+ze)

    !
    !     local derivatives of the shape functions: zeta-derivative
    !
    func(1,3)=-0.5d0*a
    func(2,3)=-0.5d0*xi
    func(3,3)=-0.5d0*et
    func(4,3)= 0.5d0*a
    func(5,3)= 0.5d0*xi
    func(6,3)= 0.5d0*et
  end subroutine

end module


SUBROUTINE indirectJ2(C20,Re,GMmoon,rMoon,GMsun,rSun , a_iJ2)

! ----------------------------------------------------------------------
! SUBROUTINE: indirectJ2.f90
! ----------------------------------------------------------------------
! Purpose:
!  Computation of the so-called indirect J2 effect of Sun and Moon.
! ----------------------------------------------------------------------
! Input arguments
! - C20     : fully normalized second zonal harmonic coefficient of Earth gravity field
! - Re      : Earth radius (meters)
! - GMmoon  : Moon gravity constant  (m^3/sec^2)
! - rMoon   : Moon body-fixed geocentric position vector (meters)
! - GMsun   : Sun gravity constant  (m^3/sec^2)
! - rSun    : Sun body-fixed geocentric position vector (meters)
!
! Output arguments:
! - a_iJ2   : Acceleration in Body-fixed system (m/s/s)
! ----------------------------------------------------------------------
! Dr. Thomas Papanikolaou, Geoscience Australia         23 November 2015
! ----------------------------------------------------------------------

      USE mdl_precision
      USE mdl_num
      IMPLICIT NONE

! ---------------------------------------------------------------------------
! Dummy arguments declaration
! ---------------------------------------------------------------------------
! IN
      REAL (KIND = prec_q), INTENT(IN), DIMENSION(3) :: rMoon, rSun
      REAL (KIND = prec_q), INTENT(IN) :: GMmoon, GMsun, C20, Re
! OUT
      REAL (KIND = prec_q), INTENT(OUT), DIMENSION(3) :: a_iJ2
! ---------------------------------------------------------------------------

! ---------------------------------------------------------------------------
! Local variables declaration
! ---------------------------------------------------------------------------
      REAL (KIND = prec_q) :: xMoon,yMoon,zMoon,l_Moon , xSun,ySun,zSun,l_Sun
      REAL (KIND = prec_q) :: termMoon,termMoon_x,termMoon_y,termMoon_z , termSun,termSun_x,termSun_y,termSun_z
      REAL (KIND = prec_q) :: indirectJ2_coef
      REAL (KIND = prec_q) :: ax,ay,az
! ---------------------------------------------------------------------------

! ---------------------------------------------------------------------------
! Celestial bodies Earth-centered coordinates and distance from Earth
! ---------------------------------------------------------------------------
! Moon
xMoon = rMoon(1)
yMoon = rMoon(2)
zMoon = rMoon(3)
l_Moon = sqrt(rMoon(1)**2 + rMoon(2)**2 + rMoon(3)**2)

! Sun
xSun = rSun(1)
ySun = rSun(2)
zSun = rSun(3)
l_Sun = sqrt(rSun(1)**2 + rSun(2)**2 + rSun(3)**2)
! ---------------------------------------------------------------------------

! ---------------------------------------------------------------------------
! Moon terms
termMoon = (GMmoon / l_Moon**3) * (Re / l_Moon)**2
termMoon_x = termMoon * (5.0D0 * (zMoon/l_Moon)**2 - 1.0D0) * xMoon
termMoon_y = termMoon * (5.0D0 * (zMoon/l_Moon)**2 - 1.0D0) * yMoon
termMoon_z = termMoon * (5.0D0 * (zMoon/l_Moon)**2 - 3.0D0) * zMoon
! ---------------------------------------------------------------------------
! Sun terms
termSun = (GMsun / l_Sun**3) * (Re / l_Sun)**2
termSun_x = termSun * (5.0D0 * (zSun/l_Sun)**2 - 1.0D0) * xSun
termSun_y = termSun * (5.0D0 * (zSun/l_Sun)**2 - 1.0D0) * ySun
termSun_z = termSun * (5.0D0 * (zSun/l_Sun)**2 - 3.0D0) * zSun
! ---------------------------------------------------------------------------

! ---------------------------------------------------------------------------
! Indirect J2 effect
! ---------------------------------------------------------------------------
indirectJ2_coef = -1.0D0 * ( ( 3.0D0 * sqrt(5.0D0) ) / 2.0D0 ) * C20
! Acceleration cartesian components
ax = indirectJ2_coef * (termMoon_x + termSun_x)
ay = indirectJ2_coef * (termMoon_y + termSun_y)
az = indirectJ2_coef * (termMoon_z + termSun_z)
! ---------------------------------------------------------------------------
      a_iJ2(1) = ax
      a_iJ2(2) = ay
      a_iJ2(3) = az
! ---------------------------------------------------------------------------

END


!======================================================================!
  real function Math_Mod_Distance(x_a, y_a, z_a, x_b, y_b, z_b)
!----------------------------------------------------------------------!
!  Calculates distance between two points in three-dimensional space.  !
!----------------------------------------------------------------------!
  implicit none
!-----------------------------[Arguments]------------------------------!
  real :: x_a, y_a, z_a, x_b, y_b, z_b
!======================================================================!

  Math_Mod_Distance = sqrt(   (x_a-x_b)*(x_a-x_b) &
                            + (y_a-y_b)*(y_a-y_b) &
                            + (z_a-z_b)*(z_a-z_b) )

  end function


recursive function fib(n) result(f)
  implicit none
  integer :: f, n
  if (n == 0) then
    f = 0
  else if (n < 3) then
    f = 1
  else
    f = fib(n-1) + fib(n-2)
  end if
end function

! Notes
! -----
! Return type mismatch: https://stackoverflow.com/questions/24876500/error-return-type-mismatch-of-function-in-fortran-95
! when interface was not used
subroutine functional
  implicit none
  integer :: n
  character(6) :: c
  interface
    recursive function fib(x)
      integer :: fib, x
    end function
  end interface

  do n=0,30
    write (c, "(i6)") fib(n)
    print "(a6)", adjustl(c)
  end do
end subroutine

! Notes
! -----
! Left justifying integers/character arrays:  https://jblevins.org/log/leftjust
subroutine imperative
  implicit none
  integer :: a, b, n, t
  character(6) :: c
  a = 0
  b = 1
  do n=0,30
    write (c, "(i6)") a
    print '(a6)', adjustl(c)
    t = b
    b = a
    a = a + t
  end do
end subroutine

program main
  call functional
  call imperative
end program


cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
c
c               this is the end of the debugging code and the beginning
c               of the actual chebychev expansion routine
c
ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
c
c
c
        subroutine chebexps(itype,n,x,u,v,whts)
        implicit real *8 (a-h,o-z)
        save
        dimension x(1),whts(1),u(n,n),v(n,n)
c
c         this subroutine constructs the chebychev nodes
c         on the interval [-1,1], and the weights for the
c         corresponding order n quadrature. it also constructs
c         the matrix converting the coefficients
c         of a chebychev expansion into its values at the n
c         chebychev nodes. no attempt has been made to
c         make this code efficient, but its speed is normally
c         sufficient, and it is mercifully short.
c
c                 input parameters:
c
c  itype - the type of the calculation to be performed
c          itype=0 means that only the chebychev nodes are
c                  to be constructed.
c          itype=1 means that only the nodes and the weights
c                  are to be constructed
c          itype=2 means that the nodes, the weights, and
c                  the matrices u, v are to be constructed
c  n - the number of chebychev nodes and weights to be generated
c
c                 output parameters:
c
c  x - the order n chebychev nodes - computed independently
c          of the value of itype.
c  u - the n*n matrix converting the  values at of a polynomial of order
c         n-1 at n chebychev nodes into the coefficients of its
c         chebychev expansion - computed only in itype=2
c  v - the n*n matrix converting the coefficients
c         of an n-term chebychev expansion into its values at
c         n chebychev nodes (note that v is the inverse of u)
c          - computed only in itype=2
c  whts - the corresponding quadrature weights - computed only
c         if itype .ge. 1
c
c       . . . construct the chebychev nodes on the interval [-1,1]
c
        ZERO=0
        DONE=1
        pi=datan(done)*4
        h=pi/(2*n)
ccc        do 1200 i=n,1,-1
        do 1200 i=1,n
        t=(2*i-1)*h
        x(n-i+1)=dcos(t)
1200  CONTINUE
c
        if(itype .eq. 0) return
c
c        construct the weights of the quadrature
c        formula based on the chebychev nodes,
c        and also the matrix of the chebychev transform
c
c        . . . construct the first two rows of the matrix
c
        if(itype .le. 1) goto 1350
        do 1300 i=1,n
        u(1,i)=1
        u(2,i)=x(i)
 1300 continue
 1350 continue
c
c       construct all quadrature weights and the rest of the rows
c
        do 2000 i=1,n
c
c       construct the weight for the i-th node
c
        Tjm2=1
        Tjm1=x(i)
        whts(i)=2
c
        ic=-1
        do 1400 j=2,n-1
c
c       calculate the T_j(x(i))
c
        Tj=2*x(i)*Tjm1-Tjm2
c
        if(itype .eq. 2) u(j+1,i)=tj
c
        tjm2=tjm1
        tjm1=tj
c
c       calculate the contribution of this power to the
c       weight
c

        ic=-ic
        if(ic .lt. 0) goto 1400
        rint=-2*(done/(j+1)-done/(j-1))
        whts(i)=whts(i)-rint*tj
ccc        whts(i)=whts(i)+rint*tj
 1400 continue
        whts(i)=whts(i)/n
 2000 continue
           if(itype .ne. 2) return
c
c        now, normalize the matrix of the chebychev transform
c
        do 3000 i=1,n
c
        d=0
        do 2200 j=1,n
        d=d+u(i,j)**2
 2200 continue
        d=done/dsqrt(d)
        do 2400 j=1,n
        u(i,j)=u(i,j)*d
 2400 continue
 3000 continue
c
c        now, rescale the matrix
c
        ddd=2
        ddd=dsqrt(ddd)
        dd=n
        dd=done/dsqrt(dd/2)
        do 3400 i=1,n
        do 3200 j=1,n
        u(j,i)=u(j,i)*dd
 3200 continue
        u(1,i)=u(1,i)/ddd
 3400 continue
c
c        finally, construct the matrix v, converting the values at the
c        chebychev nodes into the coefficients of the chebychev
c        expansion
c
        dd=n
        dd=dd/2
        do 4000 i=1,n
        do 3800 j=1,n
        v(j,i)=u(i,j)*dd
 3800 continue
 4000 continue
c
        do 4600 i=1,n
        do 4400 j=1,n
c
        d=v(j,i)
        v(j,i)=u(j,i) *n/2
        u(j,i)=d/n*2
 4400 continue
 4600 continue
c
        do 5200 i=1,n
        v(1,i)=v(1,i)*2
 5200 continue
c
        do 5600 i=1,n
        do 5400 j=1,i-1
c
        d=u(j,i)
        u(j,i)=u(i,j)
        u(i,j)=d
c
        d=v(j,i)
        v(j,i)=v(i,j)
        v(i,j)=d
 5400 continue
 5600 continue
c
        return
        end
c
c
c
c
c
        subroutine chebinmt(n,ainte,adiff,x,whts,endinter,
     1      itype,w)
        implicit real *8 (a-h,o-z)
        save
        dimension ainte(1),w(1),x(1),whts(1),adiff(1),endinter(1)
c
c
c        for the user-specified n, this subroutine constructs
c        the matrices of spectral indefinite integration and/or
c        spectral differentiation on the n Chebychev nodes
c        on the interval [-1,1]. Actually, this is only a
c        memory management routine. All the actual work is done
c        by the subroutine legeinm0 (see)
c
c                           input parameters:
c
c  n - the number of Chebychev nodes on the interval [-1,1]
c  itype - the type of the calculation to be performed
c          EXPLANATION:
c       itype=1 means that only the matrix ainte will
c               be constructed
c       itype=2 means that only the matrix adiff will
c               be constructed
c       itype=3 means that both matrices ainte and adiff
c               will be constructed
c
c                           output paramaters:
c
c  ainte - the matrix of spectral indefinite integration on
c          the Chebychev nodes
c  adiff - the matrix of spectral differentiation on
c          the Chebychev nodes
c  x - the n Chebychev nodes on the intervl [-1,1]
c  whts - the n Chebychev weights on the interval [-1,1]
c  endinter - the interpolation coefficients converting the
c          values of a function at n Chebychev nodes into its
c          value at 1 (the right end of the interval)
c
c                           work arrays:
c
c  w - must be 3* n**2 + 2*n +50 *8 locations long
c
c        . . . allocate memory for the construction of the integrating
c              matrix
c
        ipolin=1
        lpolin=n+5
c
        ipolout=ipolin+lpolin
        lpolout=n+5
c
        iu=ipolout+lpolout
        lu=n**2+1
c
        iv=iu+lu
        lv=n**2+1
c
        iw=iv+lv
        lw=n**2+1
c
        ltot=iw+lw
c
c        construct the integrating matrix
c
        call chebinm0(n,ainte,adiff,w(ipolin),w(ipolout),
     1      x,whts,w(iu),w(iv),w(iw),itype,endinter)
c
        return
        end
c
c
c
c
c
        subroutine chebinm0(n,ainte,adiff,polin,polout,
     1      x,whts,u,v,w,itype,endinter)
        implicit real *8 (a-h,o-z)
        save
        dimension ainte(n,n),u(n,n),v(n,n),w(n,n),
     1      endinter(1),x(n),whts(n),polin(n),polout(n),
     2      adiff(n,n)
c
c        for the user-specified n, this subroutine constructs
c        the matrices of spectral indefinite integration and/or
c        spectral differentiation on the n Chebychev nodes
c        on the interval [-1,1]
c
c                           input parameters:
c
c  n - the number of Chebychev nodes on the interval [-1,1]
c  itype - the type of the calculation to be performed
c          EXPLANATION:
c       itype=1 means that only the matrix ainte will
c               be constructed
c       itype=2 means that only the matrix adiff will
c               be constructed
c       itype=3 means that both matrices ainte and adiff
c               will be constructed
c
c                           output paramaters:
c
c  ainte - the matrix of spectral indefinite integration on
c          the Chebychev nodes
c  adiff - the matrix of spectral differentiation on
c          the Chebychev nodes
c  x - the n Chebychev nodes on the intervl [-1,1]
c  whts - the n Chebychev weights on the interval [-1,1]
c
c                           work arrays:
c
c  polin, polout - must be n+3 real *8 locations each
c
c  u, v, w - must be n**2+1 real *8 locations each
c
c        . . . construct the matrices of the forward and inverse
c              Chebychev transforms
c
        itype2=2
        call chebexps(itype2,n,x,u,v,whts)
c
c        if the user so requested,
c        construct the matrix converting the coefficients of
c        the Chebychev series of a function into the coefficients
c        of the indefinite integral of that function
c
        if(itype. eq. 2) goto 2000
c
        do 1600 i=1,n
c
        do 1200 j=1,n
        polin(j)=0
 1200 continue
c
        polin(i)=1
        call chebinte(polin,n+1,polout)
c
        do 1400 j=1,n
cccc        ainte(i,j)=polout(j)
        ainte(j,i)=polout(j)
 1400 continue
c
 1600 continue
c
c        multiply the three, obtaining the integrating matrix
c
        call cheb_matmul(ainte,u,w,n)
        call cheb_matmul(v,w,ainte,n)
c
 2000 continue

cccc        return

c
c        if the user so requested,
c        construct the matrix converting the coefficients of
c        the Chebychev series of a function into the coefficients
c        of the derivative of that function
c
        if(itype. eq. 1) goto 3000
c
        do 2600 i=1,n
c
        do 2200 j=1,n+3
        polin(j)=0
 2200 continue
c
        polin(i)=1
        call chebdiff(polin,n+1,polout)
c
        polout(n)=0
        do 2400 j=1,n
cccc        adiff(i,j)=polout(j)
        adiff(j,i)=polout(j)
 2400 continue
c
 2600 continue
c
c        multiply the three, obtaining the differentiating matrix
c
cc        call cheb_matmula(adiff,v,w,n)
cc        call cheb_matamul(u,w,adiff,n)

        call cheb_matmul(adiff,u,w,n)
        call cheb_matmul(v,w,adiff,n)
c
 3000 continue
c
c        construct the vector of interpolation coefficients
c        converting the values of a polynomial at the Chebychev
c        nodes into its value at the right end of the interval
c
        do 3400 i=1,n
c
        d=0
        do 3200 j=1,n
        d=d+u(j,i)
 3200 continue
        endinter(i)=d
 3400 continue
c
        return
        end
c
c
c
c
c
        subroutine chebpol(x,n,pol,der)
        implicit real *8 (a-h,o-z)
c
        save
        d=dacos(x)
        pol=dcos(n*d)
        der=dsin(n*d)*n/dsqrt(1-x**2)
        return
        end
c
c
c
c
c
        subroutine chebpols(x,n,pols)
        implicit real *8 (a-h,o-z)
        save
        dimension pols(1)
c
        pkm1=1
        pk=x
c
        pk=1
        pkp1=x
c
c
c        if n=0 or n=1 - exit
c
        if(n .ge. 2) goto 1200
        pols(1)=1
        if(n .eq. 0) return
c
        pols(2)=x
        return
 1200 continue
c
        pols(1)=1
        pols(2)=x
c
c       n is greater than 2. conduct recursion
c
        do 2000 k=1,n-1
        pkm1=pk
        pk=pkp1
        pkp1=2*x*pk-pkm1
        pols(k+2)=pkp1
 2000 continue
c
        return
        end
c
c
c
c
c
        subroutine chebinte(polin,n,polout)
        implicit real *8 (a-h,o-z)
        save
        dimension polin(1),polout(1)
c
c       this subroutine computes the indefinite integral of the
c       Chebychev expansion polin getting the expansion polout
c
c
c                       input parameters:
c
c  polin - the Chebychev expansion to be integrated
c  n - the order of the expansion polin
c   IMPORTANT NOTE: n is {\bf the order of the expansion, which is
c         one less than the number of terms in the expansion!!}
c         also nothe that the order of the integrated expansion is
c         n+1 (who could think!)
c
c                       output parameters:
c
c  polout - the Chebychev expansion of the integral of the function
c         represented by the expansion polin
c
        do 1200 i=1,n+2
        polout(i)=0
 1200 continue
c
        polout(2)=polin(1)
        if(n .eq. 0) return
        polout(3)=polin(2)/4
        if(n .eq. 1) return
c
        do 2000 k=3,n
c
        polout(k+1)=polin(k)/(2*k)
        polout(k-1)=-polin(k)/(2*k-4)+polout(k-1)
c
 2000 continue
c
        dd=0
        sss=-1
        do 2200 k=2,n+1
c
        dd=dd+polout(k)*sss
        sss=-sss
 2200 continue
c
cccc        call prin2('dd=*',dd,1)
        polout(1)=-dd
c
        return
        end
c
c
c
c
c
        subroutine chebdiff(polin,n,polout)
        implicit real *8 (a-h,o-z)
        save
        dimension polin(1),polout(1)
c
c       this subroutine differentiates the Chebychev
c       expansion polin getting the expansion polout
c
c
c                       input parameters:
c
c  polin - the Chebychev expansion to be differentiated
c  n - the order of the expansion polin
c   IMPORTANT NOTE: n is {\bf the order of the expansion, which is
c         one less than the number of terms in the expansion!!}
c         also nothe that the order of the integrated expansion is
c         n+1 (who could think!)
c
c                       output parameters:
c
c  polout - the Chebychev expansion of the derivative of the function
c         represented by the expansion polin
c
        do 1200 i=1,n+1
        polout(i)=0
 1200 continue
c
        do 2000 k=1,n-1
c
        polout(n-k)=polout(n-k+2)+(n-k)*polin(n-k+1) *2
 2000 continue
        polout(1)=polout(1)/2
c
        return
        end
c
c
c
c
c
      SUBROUTINE chebexev(X,VAL,TEXP,N)
      IMPLICIT REAL *8 (A-H,O-Z)
        save
      REAL *8 TEXP(1)
C
C     This subroutine computes the value o a Chebychev
c     expansion with coefficients TEXP at point X in interval [-1,1]
C
c                input parameters:
c
C     X = evaluation point
C     TEXP = expansion coefficients
C     N  = order of expansion
c   IMPORTANT NOTE: n is {\bf the order of the expansion, which is
c         one less than the number of terms in the expansion!!}
c
c                output parameters:
c
C     VAL = computed value
C
        done=1
        pjm2=1
        pjm1=x
c
        val=texp(1)*pjm2+texp(2)*pjm1
c
        DO 600 J = 2,N
c
        pj= 2*x*pjm1-pjm2
        val=val+texp(j+1)*pj
c
        pjm2=pjm1
        pjm1=pj
 600   CONTINUE
c
        RETURN
        END
c
c
c
c
c
      SUBROUTINE CHFUNDER(X,VAL,der,TEXP,N)
C
C     This subroutine computes the value and the derivative
c     of a chebychev expansion with coefficients TEXP
C     at point X in interval [-1,1]
C
c                input parameters:
c
C     X = evaluation point
C     TEXP = expansion coefficients
C     N  = order of expansion
c   IMPORTANT NOTE: n is {\bf the order of the expansion, which is
c         one less than the number of terms in the expansion!!}
c
c                output parameters:
c
C     VAL = computed value
C     der = computed value of the derivative
C
      IMPLICIT REAL *8 (A-H,O-Z)
        save
      REAL *8 TEXP(1)
C
        done=1
        tjm2=1
        tjm1=x
        derjm2=0
        derjm1=1
c
        val=texp(1)*tjm2+texp(2)*tjm1
        der=texp(2)
c
      DO 600 J = 2,N
c
        tj=2*x*tjm1-tjm2
        val=val+texp(j+1)*tj
c
        derj=2*tjm1+2*x*derjm1-derjm2
        der=der+texp(j+1)*derj
c
        tjm2=tjm1
        tjm1=tj
        derjm2=derjm1
        derjm1=derj
 600   CONTINUE
c
      RETURN
      END
c
c
c
c
c
      SUBROUTINE CHebcval(X,VAL,TEXP,N)
C
C     This subroutine computes the value and the derivative
c     of a chebychev expansion with coefficients TEXP
C     at point X in interval [-1,1]
C
c                input parameters:
c
C     X = evaluation point
C     TEXP = expansion coefficients
C     N  = order of expansion
c   IMPORTANT NOTE: n is {\bf the order of the expansion, which is
c         one less than the number of terms in the expansion!!}
c
c                output parameters:
c
C     VAL = computed value
C     der = computed value of the derivative
C
      IMPLICIT REAL *8 (A-H,O-Z)
        save
      complex *16 TEXP(1),val
C
        done=1
        tjm2=1
        tjm1=x
c
        val=texp(1)*tjm2+texp(2)*tjm1
c
      DO 600 J = 2,N
c
        tj=2*x*tjm1-tjm2
        val=val+texp(j+1)*tj
c
        tjm2=tjm1
        tjm1=tj
 600   CONTINUE
c
      RETURN
      END
c
c
c
c
c
      SUBROUTINE CHebval(X,VAL,TEXP,N)
C
C     This subroutine computes the value and the derivative
c     of a chebychev expansion with coefficients TEXP
C     at point X in interval [-1,1]
C
c                input parameters:
c
C     X = evaluation point
C     TEXP = expansion coefficients
C     N  = order of expansion
c   IMPORTANT NOTE: n is {\bf the order of the expansion, which is
c         one less than the number of terms in the expansion!!}
c
c                output parameters:
c
C     VAL = computed value
C     der = computed value of the derivative
C
      IMPLICIT REAL *8 (A-H,O-Z)
        save
      real *8 TEXP(1),val
C
        done=1
        tjm2=1
        tjm1=x
c
        val=texp(1)*tjm2+texp(2)*tjm1
c
      DO 600 J = 2,N
c
        tj=2*x*tjm1-tjm2
        val=val+texp(j+1)*tj
c
        tjm2=tjm1
        tjm1=tj
 600   CONTINUE
c
      RETURN
      END
c
c
c
c
c
      SUBROUTINE CHFUNcDER(X,VAL,der,TEXP,N)
C
C     This subroutine computes the value and the derivative
c     of a chebychev expansion with coefficients TEXP
C     at point X in interval [-1,1]
C
c                input parameters:
c
C     X = evaluation point
C     TEXP = expansion coefficients
C     N  = order of expansion
c   IMPORTANT NOTE: n is {\bf the order of the expansion, which is
c         one less than the number of terms in the expansion!!}
c
c                output parameters:
c
C     VAL = computed value
C     der = computed value of the derivative
C
      IMPLICIT REAL *8 (A-H,O-Z)
        save
      complex *16 TEXP(1),val,der
C
        done=1
        tjm2=1
        tjm1=x
        derjm2=0
        derjm1=1
c
        val=texp(1)*tjm2+texp(2)*tjm1
        der=texp(2)
c
      DO 600 J = 2,N
c
        tj=2*x*tjm1-tjm2
        val=val+texp(j+1)*tj
c
        derj=2*tjm1+2*x*derjm1-derjm2
        der=der+texp(j+1)*derj
c
        tjm2=tjm1
        tjm1=tj
        derjm2=derjm1
        derjm1=derj
 600   CONTINUE
c
      RETURN
      END
c
c
c
c
c
        subroutine cheb_matmula(a,b,c,n)
        implicit real *8 (a-h,o-z)
        save
        dimension a(n,n),b(n,n),c(n,n)
c
        do 2000 i=1,n
        do 1800 j=1,n
        d=0
        do 1600 k=1,n
cccc        d=d+a(i,k)*b(k,j)
        d=d+a(i,k)*b(j,k)
 1600 continue
        c(i,j)=d
 1800 continue
 2000 continue
        return
        end
c
c
c
c
c
        subroutine cheb_matamul(a,b,c,n)
        implicit real *8 (a-h,o-z)
        save
        dimension a(n,n),b(n,n),c(n,n)
c
        do 2000 i=1,n
        do 1800 j=1,n
        d=0
        do 1600 k=1,n
cccc        d=d+a(i,k)*b(k,j)
        d=d+a(k,i)*b(k,j)

 1600 continue
        c(i,j)=d
 1800 continue
 2000 continue
        return
        end
c
c
c
c
c
        subroutine cheb_matmul(a,b,c,n)
        implicit real *8 (a-h,o-z)
        save
        dimension a(n,n),b(n,n),c(n,n)
c
        do 2000 i=1,n
        do 1800 j=1,n
        d=0
        do 1600 k=1,n
        d=d+a(i,k)*b(k,j)
 1600 continue
        c(i,j)=d
 1800 continue
 2000 continue
        return
        end
c
c
c
c
c
        subroutine chematrin(n,m,xs,amatrint,ts,w)
        implicit real *8 (a-h,o-z)
        save
        dimension amatrint(m,n),xs(1),w(1),ts(1)
c
c
c        This subroutine constructs the matrix interpolating
c        functions from the n-point Chebychev grid on the interval [-1,1]
c        to an arbitrary m-point grid (the nodes of the latter are
c        user-provided)
c
c                 Input parameters:
c
c  n - the number of interpolation nodes
c  m - the number of nodes to which the functions will be interpolated
c  xs - the points at which the function is to be interpolated
c
c                  Output parameters:
c
c  amatrint - the m \times n matrix conerting the values of a function
c        at the n Chebychev nodes into its values at m user-specified
c        (arbitrary) nodes
c  ts - the n Chebychev nodes on the interval [-1,1]
c
c                  Work arrays:
c
c  w - must be at least 2*n**2+n + 100 real *8 locations long
c

        icoefs=1
        lcoefs=n+2
c
        iu=icoefs+lcoefs
        lu=n**2+10
c
        iv=iu+lu
c
        ifinit=1
        do 2000 i=1,m
c
        call chevecin(n,xs(i),ts,w(iu),w(iv),w(icoefs),ifinit)
c
        do 1400 j=1,n
        amatrint(i,j)=w(j)
 1400 continue
c
        ifinit=0
 2000 continue
c
        return
        end

c
c
c
c
c
        subroutine chevecin(n,x,ts,u,v,coefs,ifinit)
        implicit real *8 (a-h,o-z)
        save
        dimension u(n,n),v(n,n),ts(1),coefs(1)
c
c        This subroutine constructs the coefficients of the
c        standard interpolation formula connecting the values of a
c        function at n Chebychev nodes on the interval [a,b] with
c        its value at the point x \in R^1
c
c                 Input parameters:
c
c  n - the number of interpolation nodes
c  x - the points at which the function is to be interpolated
c  ts - the n Chebychev nodes on the interval [-1,1]; please note that
c        it is an input parameter only if the parameter ifinit (see
c        below) has been set to 1; otherwise, it is an output parameter
c  u - the n*n matrix converting the  values at of a polynomial of order
c         n-1 at n Chebychev nodes into the coefficients of its
c        Chebychev expansion; please note that
c        it is an input parameter only if the parameter ifinit (see
c        below) has been set to 1; otherwise, it is an output parameter
c  ifinit - an integer parameter telling the subroutine whether it should
c        initialize the Chebychev expander;
c     ifinit=1 will cause the subroutine to perform the initialization
c     ifinit=0 will cause the subroutine to  skip the initialization
c
c                  Output parameters:
c
c  coefs - the interpolation coefficients
c
c                 Work arrays:
c
c  v - must be at least n*n real *8 locations long
c
c       . . . construct the n Chebychev nodes on the interval [-1,1];
c             also the corresponding Chebychev expansion-evaluation
c             matrices
c
        itype=2
        if(ifinit .ne.0) call chebexps(itype,n,ts,u,v,coefs)
c
c       evaluate the n Chebychev polynomials at the point where the
c       functions will have to be interpolated
c
        call chebpols(x,n+1,v)
c
c       apply the interpolation matrix to the ector of values
c       of polynomials from the right
c
        call chematvec(u,v,coefs,n)
        return
        end
c
c
c
c
c
        subroutine chematvec(a,x,y,n)
        implicit real *8 (a-h,o-z)
        save
        dimension a(n,n),x(n),y(n)
c
        do 1400 i=1,n
        d=0
        do 1200 j=1,n
        d=d+a(i,j)*x(j)
 1200 continue
        y(i)=d
 1400 continue
        return
        end


program tridiagnalmat
    !This program solves a tri diagonal matrix, A only has the diagonal matrix elements
    implicit none
    real, allocatable :: A(:,:), b(:), x(:)
    integer :: n,i

    print*, 'Give dimension of matrix' ; read*, n
    allocate(A(n,3), b(n),x(n))
    print*, 'Give matrix row-wise, only the tridiagonal terms with the first row being " 0 x x " and last being "x x 0"'
    do i=1,n
        read*, A(i,:)
    enddo
    if ((A(n,3) .ne. 0) .or. (A(1,1) .ne. 0) ) print*, "ERROR : Matrix non-conforming to the input format"
    print*, 'Give b'; read*, b
    print*, '--------------------Read complete, tridiagonal A: ---------------------'
    do i=1,n
        print*, A(i,:), b(i)
    enddo
    do i =2,n
        b(i) = b(i) - A(i,1)*b(i-1)/A(i-1,2)
        A(i,1:2) = A (i,1:2) - A(i,1)*A(i-1,2:3)/A(i-1,2)
    enddo
    do i=n-1,1,-1
 !       A(i,3) = A(i,3) - A(i+1,2) * (A(i,3)/A(i+1,2))  !unnecessary step, will not be used for solution, only for completeness
        b(i) = b(i) - b(i+1)*(A(i,3)/A(i+1,2))
    enddo
    do i=1,n
        x(i) = b(i)/A(i,2)
    enddo
    print*, "------------------------------------------------"; print*, "The solutions are:"
    print*, x
end program tridiagnalmat


module forlab_stats

    use stdlib_kinds, only: sp, dp, qp, int8, int16, int32, int64
    implicit none
    private

    public :: mean, var, std
    public :: rng, randu, randn

    interface mean
        !! mean computes the mean value of an array.
        module function mean_1_sp(x) result(mean)
            real(sp), dimension(:), intent(in) :: x
            real(sp) :: mean
        end function mean_1_sp
        module function mean_2_sp(A, dim) result(mean)
            real(sp), dimension(:), allocatable :: mean
            real(sp), dimension(:, :), intent(in) :: A
            integer, intent(in), optional :: dim
        end function mean_2_sp
        module function mean_1_dp(x) result(mean)
            real(dp), dimension(:), intent(in) :: x
            real(dp) :: mean
        end function mean_1_dp
        module function mean_2_dp(A, dim) result(mean)
            real(dp), dimension(:), allocatable :: mean
            real(dp), dimension(:, :), intent(in) :: A
            integer, intent(in), optional :: dim
        end function mean_2_dp
    end interface mean

    !> Version: Experimental
    !>
    !> Generate a normal distributed data scalar or vector.
    !> ([Specification](../page/specs/forlab_stats.html#randn))
    interface randn
        module function randn_0_sp(mean, std) result(random)
            real(sp), intent(in) :: mean, std
            real(sp) :: random
        end function randn_0_sp
        module function randn_1_sp(mean, std, ndim) result(random)
            real(sp), intent(in) :: mean, std
            integer, intent(in) :: ndim
            real(sp) :: random(ndim)
        end function randn_1_sp
        module function randn_0_dp(mean, std) result(random)
            real(dp), intent(in) :: mean, std
            real(dp) :: random
        end function randn_0_dp
        module function randn_1_dp(mean, std, ndim) result(random)
            real(dp), intent(in) :: mean, std
            integer, intent(in) :: ndim
            real(dp) :: random(ndim)
        end function randn_1_dp
    end interface randn

    !> Version: Experimental
    !>
    !> Generate an uniformly distributed data scalar or vector.
    !> ([Specification](../page/specs/forlab_stats.html#randomrandu))
    interface randu
        module function randu_0_rsp(start, end) result(random)
            real(sp), intent(in) :: start, end
            real(sp) :: random
        end function randu_0_rsp
        module function randu_1_rsp(start, end, ndim) result(random)
            real(sp), intent(in) :: start, end
            integer, intent(in) :: ndim
            real(sp) :: random(ndim)
        end function randu_1_rsp
        module function randu_0_rdp(start, end) result(random)
            real(dp), intent(in) :: start, end
            real(dp) :: random
        end function randu_0_rdp
        module function randu_1_rdp(start, end, ndim) result(random)
            real(dp), intent(in) :: start, end
            integer, intent(in) :: ndim
            real(dp) :: random(ndim)
        end function randu_1_rdp
        module function randu_0_iint8(start, end) result(random)
            integer(int8), intent(in) :: start, end
            integer(int8) :: random
        end function randu_0_iint8
        module function randu_1_iint8(start, end, ndim) result(random)
            integer(int8), intent(in) :: start, end
            integer, intent(in) :: ndim
            integer(int8) :: random(ndim)
        end function randu_1_iint8
        module function randu_0_iint16(start, end) result(random)
            integer(int16), intent(in) :: start, end
            integer(int16) :: random
        end function randu_0_iint16
        module function randu_1_iint16(start, end, ndim) result(random)
            integer(int16), intent(in) :: start, end
            integer, intent(in) :: ndim
            integer(int16) :: random(ndim)
        end function randu_1_iint16
        module function randu_0_iint32(start, end) result(random)
            integer(int32), intent(in) :: start, end
            integer(int32) :: random
        end function randu_0_iint32
        module function randu_1_iint32(start, end, ndim) result(random)
            integer(int32), intent(in) :: start, end
            integer, intent(in) :: ndim
            integer(int32) :: random(ndim)
        end function randu_1_iint32
        module function randu_0_iint64(start, end) result(random)
            integer(int64), intent(in) :: start, end
            integer(int64) :: random
        end function randu_0_iint64
        module function randu_1_iint64(start, end, ndim) result(random)
            integer(int64), intent(in) :: start, end
            integer, intent(in) :: ndim
            integer(int64) :: random(ndim)
        end function randu_1_iint64
    end interface randu

    interface
        module subroutine rng(seed)
            integer, intent(in), optional :: seed
        end subroutine rng
    end interface

    interface var
        !! `var` computes vector and matrix variances.
        !!([Specification](../module/forlab_var.html))
        real(sp) module function var_1_sp(x, w)
            real(sp), dimension(:), intent(in) :: x
            integer, intent(in), optional :: w
        end function var_1_sp
        module function var_2_sp(A, w, dim)
            real(sp), dimension(:), allocatable :: var_2_sp
            real(sp), dimension(:, :), intent(in) :: A
            integer, intent(in), optional :: w, dim
        end function var_2_sp
        real(dp) module function var_1_dp(x, w)
            real(dp), dimension(:), intent(in) :: x
            integer, intent(in), optional :: w
        end function var_1_dp
        module function var_2_dp(A, w, dim)
            real(dp), dimension(:), allocatable :: var_2_dp
            real(dp), dimension(:, :), intent(in) :: A
            integer, intent(in), optional :: w, dim
        end function var_2_dp
    end interface var
    interface std
        !! `std` computes vector and matrix standard deviations.
        !!([Specification](../module/forlab_var.html))
        real(sp) module function std_1_sp(x, w)
            real(sp), dimension(:), intent(in) :: x
            integer, intent(in), optional :: w
        end function std_1_sp
        module function std_2_sp(A, w, dim)
            real(sp), dimension(:), allocatable :: std_2_sp
            real(sp), dimension(:, :), intent(in) :: A
            integer, intent(in), optional :: w, dim
        end function std_2_sp
        real(dp) module function std_1_dp(x, w)
            real(dp), dimension(:), intent(in) :: x
            integer, intent(in), optional :: w
        end function std_1_dp
        module function std_2_dp(A, w, dim)
            real(dp), dimension(:), allocatable :: std_2_dp
            real(dp), dimension(:, :), intent(in) :: A
            integer, intent(in), optional :: w, dim
        end function std_2_dp
    end interface std

end module forlab_stats


C> Calculate a four point interpolation from i-1 to i+2
C> returns c array 4 of real*8 which are coeficients for
C> \f[
C>   f_i-c_1+c_2(r-r_i)
C>    +\frac{(c_3-c_2)(r-r_i)+c_1}{1+c_4(r-r_i) (r_{i+1}-r)}
C> \f]
C>
C> It's obvious that \f$ c_3=(f_{i+1}-f_i)/(r_{i+1}-r_i) \f$.
C> \f$ c_2 \f$ is adjustable and is chosen so to avoid possible singularities
C> in eqns solving for \f$ c_1 \f$ and \f$ c_4 \f$.
C> \f[
C>   c_2=\frac{f_{i+2}-f_{i+1}}{r_{i+2}-r_{i+1}}-\frac{f_i-f_{i-1}}{r_i-r_{i-1}}
C> \f]
C> and the sign is chosen so that it is opposite of
C> \f$ (f_{i+1}-f_{i-1})/(r_{i+1}-r_{i-1}) \f$.
C>
C> @param r the mesh the function is defined on
C> @param f the function to interpolate, defined on the meshpoint
C> @param nr the size of the function and meshpoint tables
C> @param i where to perform the interpolation based on four points i-1, i, i+1, i+2
C> @param c the coefictients for the rational interpoalting function
      subroutine fit(r,f,nr,i,c)
      implicit real*8 (a-h,o-z)
      real*8 r(nr),f(nr),c(4)
c does a four-point interpolation from i-1 to i+2
c returns c array 4 of real*8 which are coeficients for
c f(i)-c1+c2*(r-r(i))+((c3-c2)*(r-r(i))+c1)/(1+c4*(r-r(i))*(r(i+1)-r))
c
c It's obvious that c3=(f(i+1)-f(i))/(r(i+1)-r(i))
c c2 is adjustable and is chosen so to avoid possible singularities
c in eqns solving for c1 and c4.
c
c   c2=((f(i+2)-f(i+1))/(r(i+2)-r(i+1))-(f(i)-f(i-1))/(r(i)-r(i-1)))
c and the sign is chosen so that it is opposite of
c (f(i+1)-f(i-1))/(r(i+1)-r(i-1))
c

      if(i.lt.1) then
        write(6,'(''FIT: i<1'')')
!       call stop_with_backtrace('fit')
        stop 'fit'
      endif
      ip1=i+1
      if(ip1.gt.nr) then
	if(r(1).gt.r(nr)) then   ! wrap around
	  ip1=1
	else
	write(6,*) "FIT: i>n-1",i,nr
!       call stop_with_backtrace('fit')
	stop 'fit'
	endif
      endif
      dr=r(ip1)-r(i)
      if(dr.eq.0.d0) then
        write(6,'(''FIT: degenerate grid'')')
!       call stop_with_backtrace('fit')
        stop'fit'
      endif
      drv=f(ip1)-f(i)
      c(3)=drv/dr

c two point interpolation
      if(nr.eq.2) then
	c(1)=f(i)
	c(2)=0.d0
	c(4)=0.d0
	return
      endif

c fit the function to the two outside points
      if(i.gt.1) then
        i1=i-1
      else
        i1=min(4,nr)
      endif
      if(ip1.lt.nr) then
        i2=ip1+1
      else
        i2=max(nr-3,1)
      endif
c If nr=3 then i1=i2
      if(i1.ne.i2) then
	c(2)=(f(i2)-f(ip1))/(r(i2)-r(ip1))-(f(i1)-f(i))/(r(i1)-r(i))
	if(c(2)*(f(i2)-f(i1))*(r(i2)-r(i1)).gt.0.d0) c(2)=-c(2)
c solve the 2x2 equation for c(1) and c(4)
	h1=r(i1)-r(i)
	c0=f(i1)-f(i)
	c1=c0-c(3)*h1
	c2=c0-c(2)*h1
        h1=h1*(r(ip1)-r(i1))
	eqn12=-h1*c2
        h2=r(i2)-r(i)
	c0=f(i2)-f(i)
	c3=c0-c(3)*h2
	c4=c0-c(2)*h2
        h2=h2*(r(ip1)-r(i2))
	eqn22=-h2*c4
	gj=(c4-c2)*h1*h2
	if(gj.eq.0.d0) then
	  c(4)=0.d0
	else
	  c(1)=(c1*eqn22-c3*eqn12)/gj
	  c(4)=(c1*h2-c3*h1)/gj
	endif

c If the points are on a line or nearly a line then use linear
c interpolation
c check this by checking to see if the denominator 1+c4*(r-r(i))*(r(i+1)-r)
c can be zero or negative. The minimum is 1-c4*dr*dr/4
	gj=c(4)*dr*dr
        if(gj.gt.-4.d0.and.abs(gj).gt.1.d-14.and.gj.lt.1.d+14) then
	  c(1)=c(1)/c(4)
        else
          c(1)=f(i)
          c(4)=0.d0
        endif
      else  ! i1=i2
c set A4=0.5*(f(i)+f(i+1)) and do a 3 point fit
        fj=0.5d0*(f(i)+f(ip1))
        c(1)=f(i)-fj
	c(2)=0.d0
        rj=r(i)+0.5d0*dr
        if(abs(r(i1)-rj).gt.abs(r(i2)-rj)) i1=i2
        h1=r(i1)-r(i)
	c1=f(i1)-f(i)-c(3)*h1
        h1=h1*(r(ip1)-r(i1))
        if(f(i1).ne.fj) then
	  c(4)=-c1/((f(i1)-fj)*h1)
	  gj=c(4)*dr*dr
          if(gj.le.-4.d0.or.abs(gj).le.1.d-14.or.gj.ge.1.d+14) then
            c(1)=f(i)
            c(4)=0.d0
          endif
        else
	  c(1)=f(i)
	  c(4)=0.d0
        endif
      endif  ! f(i1)=f(i2)

      return
      end


program test_diag
use types, only: dp
use utils, only: assert
use linalg, only: diag, eye
use constants, only : i_
implicit none

real(dp), parameter :: eps = 1e-9_dp
real(dp) :: A(3,3), B(3,3)
complex(dp) :: C(3,3), D(3,3)

A = diag([1.0_dp, 1.0_dp, 1.0_dp])
call assert(maxval(abs(A-eye(3))) < eps)

A = diag([1.0_dp, 2.0_dp, 3.0_dp])
B = reshape([1,0,0,0,2,0,0,0,3], shape=[3,3])
call assert(maxval(abs(A - B)) < eps)

C = diag([1*i_, 2*i_, 3*i_])
D = i_*reshape([1,0,0,0,2,0,0,0,3], shape=[3,3])
call assert(maxval(abs(C - D)) < eps)
end program


PROGRAM  three
    IMPLICIT NONE
    REAL:: x, xe, beta, De, MorseVx, HarmonicVx
    CHARACTER*10:: filename
    INTEGER:: i, outunit
    xe = 0.74
    beta = 1.0
    De = 109.4 * 1.59 * (10**(-3.0))

    WRITE(filename, fmt = "(a, i0)") "output.", 1
    OPEN(UNIT = outunit, FILE = filename, FORM = "formatted")
    x = -4.2
    DO i = 1, 100
        x = x + 0.20
        MorseVx = De * (1 - EXP(-beta * (x - xe))) * (1 - EXP(-beta * (x - xe)))
        HarmonicVx = De * beta * beta * (x-xe) * (x-xe)
        WRITE(outunit, * ) x, MorseVx, HarmonicVx
    ENDDO
    CLOSE(outunit)
END


!================================================================================
! ActIII es un codigo para colocar particulas sobre una malla cuadrada separadas
! uniformemente.
! Autor: Martin Alejandro Paredes Sosa
!================================================================================

Module Control
  Logical :: Impar                               !Control Impar Logico(T/F)
  Real *8 :: sep                                 !Separacion de las particulas
End Module Control

subroutine CalcPos(i, Pos)

  Use Control
  Implicit None
  Integer :: i                                   !Contador
  Real *8 :: Pos                                 !Posiciones
  If (Impar) Then
     Pos = ((-1)**i)*((int((i-1)/2)*sep)+ (sep) )
  Else
     Pos = ((-1)**i)*((int((i-1)/2)*sep)+ (sep/2) ) !Calculo de Posicion Caso Par
  End If
End Subroutine CalcPos

Program ActIII

  Use Control
  Implicit None
  Real *8 :: l                                   !Longitud Malla
  Integer :: k, m                                !Contadores
  Integer :: N                                   !#Particulas
  Real *8 :: xPos, yPos                          !Posiciones Posibles para X y Y, Limitado a 500 Particulas Por Lado

  !Entrada de Datos
  Write(*,*) "Numero de Particulas Por Lado de la Malla"
  Read(*,*) N
  Write(*,*) "Longitud del Lado de la Malla"
  Read(*,*) l

  !Calculo de la Separacion Entre Particulas
  sep = l/N

  !Dectectando N Impar
  Impar = mod(N,2) /= 0

  Open(1,File="Output.dat")                      !Abriendo Archivo de Salida

  k = 1
  m = 1
  !Calculo y Escritura de las posiciones de la malla cuadrada
  Do While(k <= N)
     If (k==1 .AND. Impar) Then                  !Control Para N Impar
        xPos = 0                                 !Primera Posicion en el centro (x=0)
     Else If (K/=1 .AND. Impar) Then
        call CalcPos(k-1, xPos)                  !Calculando Posicion sobre X (Impar)
     Else
        Call CalcPos(k, xPos)                    !Calculando posicion sobre X
     End If

     Do while(m <= N)

        If(m==1 .AND. Impar) Then                !Control Para N Impar
           yPos = 0                              !Primera Posicion en el centro (y=0)
        Else If (m/=1 .AND. Impar) Then
           call CalcPos(m-1,  yPos)              !Calculando Posicion sobre Y (Impar)
        Else
           Call CalcPos(m, yPos)                 !Calculando Posición Sobre Y
        End If

        Write(1,*) xPos, yPos                    !Escribiendo en Salida
        m = m+1                                  !Avanzar Contador
     End Do

     m=1                                         !Reiniciar el Contador
     k = k+1                                     !Avanzar Contador
  End Do

  Close(1)

End Program ActIII


module expIntegral_module
USE nrtype
implicit none
private
public::expint
contains

 ! Numerical recipes routines removed; use code from UEB-Veg

 ! ****************** EXPONENTIAL INTEGRAL FUNCTION *****************************************
 ! From UEB-Veg
 ! Computes the exponential integral function for the given value
 FUNCTION EXPINT (LAI)
 REAL(DP) LAI
 REAL(DP) EXPINT
 REAL(DP) a0,a1,a2,a3,a4,a5,b1,b2,b3,b4
 real(dp),parameter :: verySmall=tiny(1.0_dp)     ! a very small number
 IF (LAI < verySmall)THEN
  EXPINT=1._dp

 ELSEIF (LAI.LE.1.0) THEN
  a0=-.57721566_dp
  a1=.99999193_dp
  a2=-.24991055_dp
  a3=.05519968_dp
  a4=-.00976004_dp
  a5=.00107857_dp

  EXPINT = a0+a1*LAI+a2*LAI**2+a3*LAI**3+a4*LAI**4+a5*LAI**5 - log(LAI)

 ELSE
  a1=8.5733287401_dp
  a2=18.0590169730_dp
  a3=8.6347637343_dp
  a4=.2677737343_dp
  b1=9.5733223454_dp
  b2=25.6329561486_dp
  b3=21.0996530827_dp
  b4=3.9584969228_dp

  EXPINT=(LAI**4+a1*LAI**3+a2*LAI**2+a3*LAI+a4)/ &
      ((LAI**4+b1*LAI**3+b2*LAI**2+b3*LAI+b4)*LAI*exp(LAI))

 END IF
 RETURN
 END FUNCTION EXPINT

END MODULE expIntegral_module


subroutine foo(a, n, m, b)
  implicit none

  real, intent(in) :: a(n, m)
  integer, intent(in) :: n, m
  real, intent(out) :: b(size(a, 1))

  integer :: i

  do i = 1, size(b)
    b(i) = sum(a(i,:))
  enddo
end subroutine

subroutine trans(x,y)
  implicit none
  real, intent(in), dimension(:,:) :: x
  real, intent(out), dimension( size(x,2), size(x,1) ) :: y
  integer :: N, M, i, j
  N = size(x,1)
  M = size(x,2)
  DO i=1,N
     do j=1,M
        y(j,i) = x(i,j)
     END DO
  END DO
end subroutine trans

subroutine flatten(x,y)
  implicit none
  real, intent(in), dimension(:,:) :: x
  real, intent(out), dimension( size(x) ) :: y
  integer :: N, M, i, j, k
  N = size(x,1)
  M = size(x,2)
  k = 1
  DO i=1,N
     do j=1,M
        y(k) = x(i,j)
        k = k + 1
     END DO
  END DO
end subroutine flatten


C$Procedure VHATIP ( "V-Hat", 3-d unit vector along V, in place )

      SUBROUTINE VHATIP ( V )

C$ Abstract
C
C      Scale a three-dimensional vector to unit length.
C
C$ Disclaimer
C
C     THIS SOFTWARE AND ANY RELATED MATERIALS WERE CREATED BY THE
C     CALIFORNIA INSTITUTE OF TECHNOLOGY (CALTECH) UNDER A U.S.
C     GOVERNMENT CONTRACT WITH THE NATIONAL AERONAUTICS AND SPACE
C     ADMINISTRATION (NASA). THE SOFTWARE IS TECHNOLOGY AND SOFTWARE
C     PUBLICLY AVAILABLE UNDER U.S. EXPORT LAWS AND IS PROVIDED "AS-IS"
C     TO THE RECIPIENT WITHOUT WARRANTY OF ANY KIND, INCLUDING ANY
C     WARRANTIES OF PERFORMANCE OR MERCHANTABILITY OR FITNESS FOR A
C     PARTICULAR USE OR PURPOSE (AS SET FORTH IN UNITED STATES UCC
C     SECTIONS 2312-2313) OR FOR ANY PURPOSE WHATSOEVER, FOR THE
C     SOFTWARE AND RELATED MATERIALS, HOWEVER USED.
C
C     IN NO EVENT SHALL CALTECH, ITS JET PROPULSION LABORATORY, OR NASA
C     BE LIABLE FOR ANY DAMAGES AND/OR COSTS, INCLUDING, BUT NOT
C     LIMITED TO, INCIDENTAL OR CONSEQUENTIAL DAMAGES OF ANY KIND,
C     INCLUDING ECONOMIC DAMAGE OR INJURY TO PROPERTY AND LOST PROFITS,
C     REGARDLESS OF WHETHER CALTECH, JPL, OR NASA BE ADVISED, HAVE
C     REASON TO KNOW, OR, IN FACT, SHALL KNOW OF THE POSSIBILITY.
C
C     RECIPIENT BEARS ALL RISK RELATING TO QUALITY AND PERFORMANCE OF
C     THE SOFTWARE AND ANY RELATED MATERIALS, AND AGREES TO INDEMNIFY
C     CALTECH AND NASA FOR ALL THIRD-PARTY CLAIMS RESULTING FROM THE
C     ACTIONS OF RECIPIENT IN THE USE OF THE SOFTWARE.
C
C$ Required_Reading
C
C     None.
C
C$ Keywords
C
C     VECTOR
C
C$ Declarations

      DOUBLE PRECISION   V ( 3 )

C$ Brief_I/O
C
C     VARIABLE  I/O  DESCRIPTION
C     --------  ---  --------------------------------------------------
C     V         I-O  Vector to be normalized/unit vector.
C
C$ Detailed_Input
C
C     V        This is any double precision, 3-dimensional vector.  If
C              this vector is the zero vector, this routine will detect
C              it, and will not attempt to divide by zero.
C
C$ Detailed_Output
C
C     V        V contains the unit vector in the direction of the input
C              vector.  If on input V represents the zero vector, then
C              V will be returned as the zero vector.
C
C$ Parameters
C
C     None.
C
C$ Exceptions
C
C     Error free.
C
C     1) The zero vector is returned if the input value of V is the
C        zero vector.
C
C$ Files
C
C     None.
C
C$ Particulars
C
C     This routine is provided for situation where it is convenient
C     to scale a vector to unit length in place rather than store
C     the result in a separate variable.  Note that the call
C
C        CALL VHAT ( V, V )
C
C     is not permitted by the ANSI Fortran 77 standard; this routine
C     can be called instead to achieve the same result.
C
C     VHATIP determines the magnitude of V and then, if the magnitude
C     is non-zero, divides each component of V by the magnitude.  This
C     process is highly stable over the whole range of 3-dimensional
C     vectors.
C
C$ Examples
C
C     The following table shows how selected vectors are mapped to
C     unit vectors
C
C     V on input            V on output
C     ------------------    ------------------
C     (5, 12, 0)            (5/13, 12/13, 0)
C     (1D-7, 2D-7, 2D-7)    (1/3, 2/3, 2/3)
C
C$ Restrictions
C
C     There is no known case whereby floating point overflow may occur.
C     Thus, no error recovery or reporting scheme is incorporated
C     into this subroutine.
C
C$ Author_and_Institution
C
C     N.J. Bachman    (JPL)
C     H.A. Neilan     (JPL)
C     W.M. Owen       (JPL)
C     W.L. Taber      (JPL)
C
C$ Literature_References
C
C     None.
C
C$ Version
C
C-    SPICELIB Version 1.1.0, 01-SEP-2005 (NJB) (HAN) (WMO) (WLT)
C
C-&

C$ Index_Entries
C
C     unitize a 3-dimensional vector in place
C
C-&

C
C     SPICELIB functions
C
      DOUBLE PRECISION      VNORM

C
C     Local variables
C
      DOUBLE PRECISION      VMAG

C
C     Obtain the magnitude of V.
C
      VMAG = VNORM ( V )

C
C     If VMAG is nonzero, then normalize. Note that this process is
C     numerically stable: overflow could only happen if VMAG were
C     small, but this could only happen if each component of V1 were
C     small. In fact, the magnitude of any vector is never less than
C     the magnitude of any component.
C
      IF ( VMAG .GT. 0.D0 ) THEN

         V(1) = V(1) / VMAG
         V(2) = V(2) / VMAG
         V(3) = V(3) / VMAG

      ELSE

         V(1) = 0.D0
         V(2) = 0.D0
         V(3) = 0.D0

      END IF

      RETURN
      END


!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
! BenchIT - Performance Measurement for Scientific Applications
! Contact: developer@benchit.org
!
! $Id: matmul.f90 1 2009-09-11 12:26:19Z william $
! $URL: svn+ssh://william@rupert.zih.tu-dresden.de/svn-base/benchit-root/BenchITv6/kernel/numerical/cannon/F95/MPI/0/double/matmul.f90 $
! For license details see COPYING in the package base directory
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
! Kernel: a MPI version of matrix-matrix multiplication
!         (cannon algotithm)
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!

SUBROUTINE multijk( matrixC, matrixA, matrixB, mA, nA, nB )
	INTEGER(kind=4) :: i, j, k, mA, nA, nB
	REAL(kind=8), DIMENSION(:, :) :: matrixC(mA,nB), matrixA(mA,nA), matrixB(nA,nB)

	DO i=1, mA
		DO j=1, nB
			DO k=1, nA
				matrixC(i,j) = matrixC(i,j) + matrixA(i,k)*matrixB(k,j)
			END DO
		END DO
	END DO

END SUBROUTINE multijk

SUBROUTINE multikj( matrixC, matrixA, matrixB, mA, nA, nB )
	INTEGER(kind=4) :: i, j, k, mA, nA, nB
	REAL(kind=8), DIMENSION(:, :) :: matrixC(mA,nB), matrixA(mA,nA), matrixB(nA,nB)

	DO i=1, mA
		DO k=1, nA
			DO j=1, nB
				matrixC(i,j) = matrixC(i,j) + matrixA(i,k)*matrixB(k,j)
			END DO
		END DO
	END DO

END SUBROUTINE multikj

SUBROUTINE multjik( matrixC, matrixA, matrixB, mA, nA, nB )
	INTEGER(kind=4) :: i, j, k, mA, nA, nB
	REAL(kind=8), DIMENSION(:, :) :: matrixC(mA,nB), matrixA(mA,nA), matrixB(nA,nB)

	DO j=1, nB
		DO i=1, mA
			DO k=1, nA
				matrixC(i,j) = matrixC(i,j) + matrixA(i,k)*matrixB(k,j)
			END DO
		END DO
	END DO

END SUBROUTINE multjik

SUBROUTINE multjki( matrixC, matrixA, matrixB, mA, nA, nB )
	INTEGER(kind=4) :: i, j, k, mA, nA, nB
	REAL(kind=8), DIMENSION(:, :) :: matrixC(mA,nB), matrixA(mA,nA), matrixB(nA,nB)

	DO j=1, nB
		DO k=1, nA
			DO i=1, mA
				matrixC(i,j) = matrixC(i,j) + matrixA(i,k)*matrixB(k,j)
			END DO
		END DO
	END DO

END SUBROUTINE multjki

SUBROUTINE multkij( matrixC, matrixA, matrixB, mA, nA, nB )
	INTEGER(kind=4) :: i, j, k, mA, nA, nB
	REAL(kind=8), DIMENSION(:, :) :: matrixC(mA,nB), matrixA(mA,nA), matrixB(nA,nB)

	DO k=1, nA
		DO i=1, mA
			DO j=1, nB
				matrixC(i,j) = matrixC(i,j) + matrixA(i,k)*matrixB(k,j)
			END DO
		END DO
	END DO

END SUBROUTINE multkij

SUBROUTINE multkji( matrixC, matrixA, matrixB, mA, nA, nB )
	INTEGER(kind=4) :: i, j, k, mA, nA, nB
	REAL(kind=8), DIMENSION(:, :) :: matrixC(mA,nB), matrixA(mA,nA), matrixB(nA,nB)

	DO k=1, nA
		DO j=1, nB
			DO i=1, mA
				matrixC(i,j) = matrixC(i,j) + matrixA(i,k)*matrixB(k,j)
			END DO
		END DO
	END DO

END SUBROUTINE multkji


       SUBROUTINE BoostX(expH,A,Ap)
c########################################################################
c                                                                       #
c  Makes Lorentz boost to X-axis direction!!                            #
c         'bet' is relative velocity                                    #
c       z            z'                                                 #
c        | (K)        |   (K')                                          #
c        |            |                                                 #
c        |            |                                                 #
c        |        x   |   --> bet                                       #
c         --------->   ------------> x'                                 #
c       /            /                                                  #
c      /            /                                                   #
c    y/          y'/                                                    #
c                                                                       #
c  expH = EXP(u) = Sqrt((1-bet)/(1+bet))                                #
c                                                                       #
c    x0'= x0*ch(u)-x*sh(u)                                              #
c    x' = x*ch(u) -x0*sh(u)                                             #
c    y' = y                                                             #
c    z' = z                                                             #
c                                                                       #
c  For a reversed transformation: expH <--> 1/expH (bet <--> -bet !)    #
c                                                                       #
c########################################################################
         IMPLICIT NONE
         INTEGER          i
         DOUBLE PRECISION A(0:3),Ap(0:3),At(0:3)
         DOUBLE PRECISION expH,A1pA0,A1mA0

         DO i=0,3
           At(i) = A(i)
         ENDDO

         A1pA0 = (At(1) + At(0))/2d0
         A1mA0 = (At(1) - At(0))/2d0

         Ap(0) = A1pA0/expH - A1mA0*expH
         Ap(1) = A1pA0/expH + A1mA0*expH
         Ap(2) = At(2)
         Ap(3) = At(3)

       RETURN
       END

       SUBROUTINE BoostZ(expH,A,Ap)
c#######################################################################
c                                                                      #
c  Makes Lorentz boost to Z-axis direction!!                           #
c         'bet' is relative velocity                                   #
c       y            y'                                                #
c        | (K)        |   (K')                                         #
c        |            |                                                #
c        |            |                                                #
c        |        z   |   --> bet  z'                                  #
c         --------->   ------------>                                   #
c       /            /                                                 #
c      /            /                                                  #
c    x/          x'/                                                   #
c                                                                      #
c  expH = EXP(u) = Sqrt((1-bet)/(1+bet))                               #
c                                                                      #
c    x0'= x0*ch(u)-x*sh(u)                                             #
c    x' = x                                                            #
c    y' = y                                                            #
c    z' = z*ch(u)-x0*sh(u)                                             #
c                                                                      #
c  For a reversed transformation: expH <--> 1/expH (bet <--> -bet !!)  #
c                                                                      #
c#######################################################################
         IMPLICIT NONE
         INTEGER          i
         DOUBLE PRECISION A(0:3),Ap(0:3),At(0:3)
         DOUBLE PRECISION expH,A3pA0,A3mA0

         DO i=0,3
           At(i) = A(i)
         ENDDO

         A3pA0 = (At(3) + At(0))/2d0
         A3mA0 = (At(3) - At(0))/2d0

         Ap(0) = A3pA0/expH - A3mA0*expH
         Ap(1) = At(1)
         Ap(2) = At(2)
         Ap(3) = A3pA0/expH + A3mA0*expH

       RETURN
       END

       SUBROUTINE RotateY(theta,A,Ap)
c###################################################
c  Makes rotation about Y-axis with theta angle!!  #
c         (  Clockwise direction..  )              #
c###################################################
         IMPLICIT NONE
         INTEGER          i
         DOUBLE PRECISION A(0:3),Ap(0:3),At(0:3)
         DOUBLE PRECISION cosTh,sinTh,theta

         DO i=0,3
           At(i) = A(i)
         ENDDO

         cosTh = Dcos(theta)
         sinTh = Dsin(theta)

         Ap(1) = At(1)*cosTh - At(3)*sinTh
         Ap(2) = At(2)
         Ap(3) = At(3)*cosTh + At(1)*sinTh

       RETURN
       END

       SUBROUTINE RotateX(theta,A,Ap)
c##################################################
c  Makes rotation about X-axis with theta angle!! #
c         (  Clockwise direction..  )             #
c##################################################
         IMPLICIT NONE
         INTEGER          i
         DOUBLE PRECISION A(0:3),Ap(0:3),At(0:3)
         DOUBLE PRECISION cosTh,sinTh,theta

         DO i=0,3
           At(i) = A(i)
         ENDDO

         cosTh = Dcos(theta)
         sinTh = Dsin(theta)

         Ap(1) = At(1)
         Ap(2) = At(2)*cosTh + At(3)*sinTh
         Ap(3) = At(3)*cosTh - At(2)*sinTh

       RETURN
       END

       SUBROUTINE RotateZ(theta,A,Ap)
c##################################################
c  Makes rotation about Z-axis with theta angle!! #
c         (  Clockwise direction..  )             #
c##################################################
         IMPLICIT NONE
         INTEGER          i
         DOUBLE PRECISION A(0:3),Ap(0:3),At(0:3)
         DOUBLE PRECISION cosTh,sinTh,theta

         DO i=0,3
           At(i) = A(i)
         ENDDO

         cosTh = Dcos(theta)
         sinTh = Dsin(theta)

         Ap(1) = At(1)*cosTh + At(2)*sinTh
         Ap(2) = At(2)*cosTh - At(1)*sinTh
         Ap(3) = At(3)

       RETURN
       END

       SUBROUTINE GetAngles(X,theta,ph)
c#############################################
c      Calculates the Polar(theta) and       #
c        Azimuthal(ph) angles of X           #
c#############################################
         IMPLICIT NONE
         DOUBLE PRECISION X(0:3),theta,ph
         DOUBLE PRECISION XyXx,Xmod
         INCLUDE 'MC_Declare.h'

         Xmod = Dsqrt(X(1)**2 + X(2)**2 + X(3)**2)

         IF (Xmod.EQ.0d0) THEN
            PRINT*,"ERROR IN GetAngles : ZERO VECTOR!!"
            STOP
         ELSE
            theta = Dacos(X(3)/Xmod)
            IF (X(1).EQ.0d0.AND.X(2).GT.0d0) THEN
               ph = pi/2d0
            ELSEIF (X(1).EQ.0d0.AND.X(2).LT.0d0) THEN
               ph = 3d0*pi/2d0
            ELSE
               XyXx = Datan(Dabs(X(2))/Dabs(X(1)))
               IF (X(1).GT.0d0.AND.X(2).GT.0d0) THEN
                  ph = XyXx
               ELSEIF (X(1).LT.0d0.AND.X(2).GT.0d0) THEN
                  ph = pi - XyXx
               ELSEIF (X(1).LT.0d0.AND.X(2).LT.0d0) THEN
                  ph = pi + XyXx
               ELSEIF (X(1).GT.0d0.AND.X(2).LT.0d0) THEN
                  ph = 2d0*pi - XyXx
               ELSE
                  PRINT*," "
                  PRINT*,"ERROR In GetAngles : INCOMPLETE LOGIC!!"
                  PRINT*," "
                  STOP
               ENDIF
            ENDIF
         ENDIF

       RETURN
       END

       DOUBLE PRECISION FUNCTION getAngleXY(x,y)
c###################################################
c            calculates the angle                  #
c         between x and y 3-vectors..              #
c###################################################
         IMPLICIT NONE
         DOUBLE PRECISION x(0:3),y(0:3),cosTh
         DOUBLE PRECISION xMod,yMod,scalProd1

         xMod = Dsqrt(x(1)**2+x(2)**2+x(3)**2)
         yMod = Dsqrt(y(1)**2+y(2)**2+y(3)**2)
         IF ((xMod.NE.0d0).AND.(yMod.NE.0d0)) THEN
            scalProd1  = x(1)*y(1)+x(2)*y(2)+x(3)*y(3)
            cosTh      = scalProd1/xMod/yMod
            getAngleXY = Dacos(cosTh)
         ELSE
            PRINT*,""
            PRINT*,"ERROR IN getAnglesXY() :"
            PRINT*,"      ONE OF THE 3-VECTOR HAS ZERO LENGTH !!"
            PRINT*,""
            STOP
         ENDIF

       RETURN
       END


!    Compute the matrix element on harmonic oscillator states
!             + k    l
!     < m | (a )  (a)  | n >
!

module mod_elem

  implicit none
  contains
    pure function elem(m, n, k, l)

      use, intrinsic :: iso_fortran_env
      implicit none

      integer(kind=int32), intent(in) :: m, n, k, l
      !real(kind=REAL128) :: elem
      real(kind=real64) :: elem

      integer(kind=int32) :: i

      elem = 0.

      if(m /= n - l + k) then
        return
      endif
      if(n < l) then
        return
      endif
      elem = 1.
      ! Apply creation operator
      do i = 0, l - 1
        !elem = elem * sqrt(real(n - i, 16))
        elem = elem * sqrt(real(n - i, 8))
      end do
      ! Apply anihilation operator
      do i = 1, k
        !elem = elem * sqrt(real(n - l + i, 16))
        elem = elem * sqrt(real(n - l + i, 8))
      end do

    end function elem

end module mod_elem


!Intrinsic_Function_Of_Array
program Intrinsic_Function_Of_Array
    implicit none

    INTEGER :: i, j
    INTEGER :: a(5), mat(3, 4)

    a = (/10, 50, 64, 75, 23/)

    mat = reshape((/1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11, 12/), (/3, 4/))

    print *, "One Dimension Matrices"
    do i = 1, 5
        print *, a(i)
    end do

    print *, ""

    print *, "Two Dimension Matrices"
    do i = 1, 3
        print *, (mat(i, j), j=1, 4)
    end do

    print *, ""

    print *, "The shape of a is ", shape(a)
    print *, "The shape of mat is ", shape(mat)

    print *, ""

    print *, "The size of a is ", size(a)
    print *, "The size of mat is ", size(mat)

    print *, ""

    print *, "The rank of a is ", rank(a)
    print *, "The rank of mat is ", rank(mat)

    print *, ""

    print *, "The sum of all element of a is ", sum(a)
    print *, "The sum of all element of mat is ", sum(mat)

    print *, ""

    print *, "The sum of all element of a greater than 40 is ", sum(a, a > 40)
    print *, "The sum of all element of mat less than 6 is ", sum(mat, mat < 6)

    print *, ""

    print *, "The product of all element of a is ", product(a)
    print *, "The product of all element of mat is ", product(mat)

    print *, ""

    print *, "The product of all element of a greater than 40 is ", product(a, a > 40)
    print *, "The product of all element of mat less than 6 is ", product(mat, mat < 6)

    print *, ""

    print *, "Number of element in a greater than 40 is ", count(a > 40)
    print *, "Number of element in mat less than 6 is ", count(mat < 6)

    print *, ""

    print *, "Maximum value in a is ", MAXVAL(a)
    print *, "Maximum value in mat is ", MAXVAL(mat)

    print *, ""

    print *, "Minimum value in a is ", MINVAL(a)
    print *, "Minimum value in mat is ", MINVAL(mat)

    print *, ""

    print *, "Is all value in a is greater than 40: ", all(a > 40)
    print *, "Is all value in mat is less than 20: ", all(mat < 20)

    print *, ""

    print *, "Is any value in a is less than 40: ", any(a < 40)
    print *, "Is any value in mat is greater than 20: ", any(mat > 20)

end program Intrinsic_Function_Of_Array


 SUBROUTINE shape7(a2,a3,shape,deriv)
 IMPLICIT NONE
 REAL (kind=8) a2,a3,shape(6),deriv(6,2)
 REAL (kind=8) a1

 a1 = 1d0-a2-a3

 shape(1) = (2d0*a1-1d0)*a1
 shape(2) = (2d0*a2-1d0)*a2
 shape(3) = (2d0*a3-1d0)*a3
 shape(4) = 4d0*a1*a2
 shape(5) = 4d0*a2*a3
 shape(6) = 4d0*a1*a3

 deriv(1,1) =  1d0-4d0*a1
 deriv(2,1) =  4d0*a2-1d0
 deriv(3,1) =  0d0
 deriv(4,1) =  4d0*(a1-a2)
 deriv(5,1) =  4d0*a3
 deriv(6,1) = -4d0*a3
 deriv(1,2) =  1d0-4d0*a1
 deriv(2,2) =  0d0
 deriv(3,2) =  4d0*a3-1d0
 deriv(4,2) = -4d0*a2
 deriv(5,2) =  4d0*a2
 deriv(6,2) =  4d0*(a1-a3)
 RETURN
 END SUBROUTINE shape7


! **************************************************************************
! ... eof.f90
! ... Quim Ballabrera, March 2013
! ...
! ... System Dynamics
! ...
! **************************************************************************

program eof

use sysdyn

implicit none

logical Zexist
integer i,j,k,Nv,Nt,step,rank,iu

real(dp) xsum,xsum2
real(dp), dimension(:), allocatable        :: Zm,Zs
real(dp), dimension(:,:), allocatable      :: Z,cov
real(dp), dimension(:), allocatable        :: Lambda,ev,pc
real(dp), dimension(:,:), allocatable      :: U
real(dp), dimension(:), allocatable        :: T

character(len=180) nfile,tfile,cfile,efile,pfile,mfile,sfile,xfile
character(len=180) rfile,line

namelist/nameof/tfile,     &
                cfile,     &
                efile,     &
                pfile,     &
                mfile,     &
                sfile,     &
                xfile

call header()

tfile = 'lorenz_simulation.dat'
mfile = 'lorenz.mean'
sfile = 'lorenz.stdv'
cfile = 'lorenz.cov'
rfile = 'lorenz.cor'
efile = 'lorenz.eof'
xfile = 'lorenz.spm'
pfile = 'lorenz.pc'

nfile = ''
CALL getarg(1,nfile)
inquire(file=nfile,exist=Zexist)

if (len_trim(nfile).gt.0) then
  if (Zexist) then
    write(*,*) 'Reading ', trim(nfile)
    iu = unitfree()
    open(iu,FILE=nfile,STATUS='old')
    rewind(iu)
    read(iu,nameof)
    close(iu)
  else
    call stop_error (1,'Namelist file not found')
  endif
endif

! ... Open input trajectory
! ...
iu = unitfree()
write(*,*) 'Opening file ', trim(tfile)
open(iu,file=tfile,status='old')
rewind(iu)
Nt = numlines(iu)

rewind(iu)
read(iu,'(A)') line
Nv = numwords(line) - 1

allocate (Z(Nv,Nt))
allocate (T(Nt))
allocate (Zs(Nv))
allocate (cov(Nv,Nv))

! ... Load the data:
! ...
rewind(iu)
do step=1,Nt
  READ(iu,*) T(step),Z(:,step)
enddo
close(iu)

! ... Long term mean:
! ...
allocate (Zm(Nv))
Zm(:) = 0.0D0
do step=1,Nt
  Zm(:) = Zm(:) + Z(:,step)
enddo
Zm(:) = Zm(:) / Nt

write(*,*) 'Saving long term mean ', trim(mfile)
open(iu,file=mfile,status='unknown')
rewind(iu)
write(iu,*) 0.0, SNGL(Zm)
close(iu)

! ... Anomalies:
! ...
do i=1,Nv
  Z(i,:) = Z(i,:) - Zm(i)
enddo

! ... Calculate the covariance matrix
! ...
do j=1,Nv
do i=j,Nv
  xsum = 0.0D0
  do k=1,Nt
    xsum = xsum + Z(i,k)*Z(j,k)
  enddo
  cov(i,j) = xsum / (Nt-1.0D0)
  cov(j,i) = cov(i,j)
enddo
enddo

write(*,*) 'Covariance : '
do i=1,Nv
  write(*,'(100F9.3)') cov(i,:)
enddo

write(*,*) 'Saving covariance matrix ', trim(cfile)
iu = unitfree()
open(iu,file=cfile,status='unknown')
rewind(iu)
write(iu,*) Nv, Nv
do j=1,Nv
  write(iu,*) cov(:,j)
enddo
close(iu)

! ... Standard deviation
! ...
do i=1,Nv
  Zs(i) = SQRT(DOT_PRODUCT(Z(i,:),Z(i,:))/(Nt-1.0D0))
enddo

write(*,*) 'Saving standard deviation ', trim(sfile)
open(iu,file=sfile,status='unknown')
rewind(iu)
write(iu,*) 0.0D0, SNGL(Zs)
close(iu)

! ... Scale the anomalies:
! ...
do i=1,Nv
  Z(i,:) = Z(i,:)/Zs(i)
enddo

! ... Calculate the correlation matrix
! ...
do j=1,Nv
do i=j,Nv
  xsum = 0.0D0
  do k=1,Nt
    xsum = xsum + Z(i,k)*Z(j,k)
  enddo
  cov(i,j) = xsum / (Nt-1.0D0)
  cov(j,i) = cov(i,j)
enddo
enddo

write(*,*)
write(*,*) 'Mean : '
write(*,*) SNGL(Zm)
write(*,*) 'Standard deviation : '
write(*,*) SNGL(Zs)
write(*,*) 'Correlation : '
do i=1,Nv
  write(*,'(100F9.3)') cov(i,:)
enddo

! ... Save the covariance matrix
! ...
write(*,*) 'Saving correlation matrix ', trim(rfile)
iu = unitfree()
open(iu,file=rfile,status='unknown')
rewind(iu)
write(iu,*) Nv, Nv
do j=1,Nv
  write(iu,*) cov(:,j)
enddo
close(iu)

! ... Just to be safe: print the trace of the covariance matrix:
! ...
xsum = 0.0D0
do i=1,Nv
do k=1,Nt
  xsum = xsum + Z(i,k)*Z(i,k)
enddo
enddo
write(*,*) 'Trace coavariance matrix (Z Z^T): ', xsum/(Nt-1.0D0)

! ... EOFs:
! ...
rank = MIN(nv,nt-1)
write(*,*) 'Rank: ', rank

allocate (U(Nv,rank))
allocate (Lambda(rank))

call get_the_eofs (Z,Nv,Nt,rank,U,Lambda)

! ... The covariance matrix seen by the EOFs: Cov = U Lambda U^T
! ...
xsum = 0.0D0
do i=1,Nv
do k=1,rank
  xsum = xsum + Lambda(k)*U(i,k)*U(i,k)
enddo
enddo
write(*,*) 'Trace coavariance matrix (U Lambda U^T): ', xsum

! ... Explained variance:
! ...
allocate (ev(rank))
xsum  = SUM(Lambda(:))
xsum2 = 0.0D0
do k=1,rank
  xsum2 = xsum2 + 100.0D0*Lambda(k)/xsum
  ev(k) = xsum2
enddo

write(*,*) 'Saving scpectrum file ', trim(xfile)
iu = unitfree()
open (iu,file=xfile,status='unknown')
rewind(iu)
do k=1,rank
  write(iu,'(i5,F18.5,2F9.3)') k, Lambda(k), 100.0*Lambda(k)/xsum, ev(k)
enddo
close(iu)

write(*,*) 'Saving the EOFs matrix ', trim(efile)
iu = unitfree()
open(iu,file=efile,status='unknown')
rewind(iu)
write(iu,*) Nv, rank
do k=1,rank
  write(iu,*) U(:,k)
enddo
close(iu)

! ... Principal components:
! ...
allocate (pc(rank))
write(*,*) 'Saving the PC matrix ', trim(pfile)
iu = unitfree()
open(iu,file=pfile,status='unknown')
rewind(iu)

do step=1,Nt
  do k=1,rank
    xsum = 0.0D0
    do i=1,Nv
      xsum = xsum + U(i,k)*Z(i,step)
    enddo
    pc(k) = xsum
  enddo
  write(iu,'(4F10.4)') T(step), pc(:)
enddo
close(iu)

call stop_error (0,'EOF Ok')
end program eof
! ...
! =====================================================================
! ...
SUBROUTINE get_the_eofs (Z,Nv,Nt,rank,U,Lambda)

use sysdyn

implicit none

integer Nv,Nt,rank
real(dp), dimension(Nv,Nt), intent(in)       :: Z
real(dp), dimension(Nv,rank), intent(out)    :: U
real(dp), dimension(rank), intent(out)       :: Lambda

integer Nm,k
real(dp), dimension(:), allocatable          :: DD
real(dp), dimension(:,:), allocatable        :: UU,VV

if (Nv.GE.Nt) then
  write(*,*) 'Singular Value Decomposition of Z ...'

  Nm = Nt
  allocate (UU(Nv,Nt))
  allocate (VV(Nt,Nt))
  allocate (DD(Nt))

  UU(:,:) = Z(:,:)
  call svdcmp (UU,Nv,Nt,Nv,Nt,DD,VV)

else
  write(*,*) 'Singular Value Decomposition of Z^T ...'

  Nm = Nv
  allocate (UU(Nv,Nv))
  allocate (VV(Nt,Nv))
  allocate (DD(Nv))

  VV = TRANSPOSE(Z)
  call svdcmp (VV,Nt,Nv,Nt,Nv,DD,UU)

endif

DD(:) = DD(:)**2
call eigsort (DD,Nm,UU,Nv)

IF (rank.GT.Nm) call stop_error(1,'ERROR: rank to large !!!!!')

! ... Output arrays:
! ...
do k=1,rank
  Lambda(k) = DD(k)/(Nt-1.0D0)
  U(:,k)    = UU(:,k)
enddo

deallocate (UU)
deallocate (VV)
deallocate (DD)

return
end
! ...
! ====================================================================
! ...


include 'testutil.i'

program test_laplacian
  use adjac
  use testutil
  implicit none

  integer, parameter :: n = 5

  double precision, dimension(n) :: y_value
  double precision, dimension(n,n) :: jac
  double precision, allocatable, dimension(:) :: jac_val
  integer, allocatable, dimension(:) :: jac_i, jac_j

  double precision, dimension(n) :: p, xval, dy, dy2
  type(adjac_double), dimension(n) :: x
  type(adjac_double), dimension(n) :: y
  integer i, j, nnz

  call adjac_reset()
  do j = 1, n
     call adjac_set_independent(x(j), dble(j), j)
  end do

  ! Some calculation, for example the Laplacian plus nonlinearity
  call laplacian(x, y)
  call adjac_get_value(y, y_value)
  write(*,*) y_value

  ! Dense jacobian
  call adjac_get_dense_jacobian(y, jac)
  do i = 1, n
     write(*,*) jac(i,:)
  end do

  ! Obtain jacobian in sparse coordinate (i, j, value) format
  write(*,*) '-- COO laplacian'
  call adjac_get_coo_jacobian(y, nnz, jac_val, jac_i, jac_j)
  do j = 1, nnz
     write(*,*) jac_i(j), jac_j(j), real(jac_val(j))
  end do

  ! Evaluate jacobian-vector products
  do j = 1, n
     p(j) = 1d0/(1 + j)
     xval(j) = dble(j)
  end do
  call adjac_reset(.true.)
  call adjac_set_independent(x, xval, p)
  call laplacian(x, y)
  call adjac_get_value(y, y_value, dy)
  dy2 = matmul(jac, p)

  if (maxval(abs(dy - dy2)) > 1d-12) then
     write(*,*) 'jac product FAIL'
  else
     write(*,*) 'jac product OK'
  end if
contains
  subroutine laplacian(x, y)
    implicit none
    type(adjac_double), dimension(:), intent(in) :: x
    type(adjac_double), dimension(:), intent(out) :: y
    integer :: n
    n = size(x)
    y(1) = x(1)
    y(n) = x(n)
    do j = 2, n-1
       y(j) = x(j-1) - 2d0*x(j) + x(j+1)
    end do
  end subroutine laplacian
end program test_laplacian