FUNCTION dcosint(xvalue) RESULT(fn_val)

!   This program calculates the value of the cosine-integral
!   defined as

!   DCOSINT(x) = Gamma + Ln(x) + Integral (0 to x) [cos(t)-1]/t  dt

!                where Gamma is Euler's constant.

!   The code uses rational approximations with a maximum accuracy of 20sf.

!   INPUT PARAMETER:

!     XVALUE - DOUBLE PRECISION - The argument to the function

!   MACHINE-DEPENDENT PARAMETERS:

!     XLOW - DOUBLE PRECISION - The absolute value below which
!                                   DCOSINT( x ) = gamma + LN(x) ,
!                               to machine precision.
!                               The recommended value is SQRT(2*EPSNEG)

!     XHIGH1 - DOUBLE PRECISION - The value above which
!                                    DCOSINT(x) = sin(x)/x - cos(x)/x^2
!                                 to machine precision.
!                                 The recommended value is SQRT(6/EPSNEG)

!     XHIGH2 - DOUBLE PRECISION - The value above which the trig. functions
!                                 cannot be accurately determined.
!                                 The value of the function is
!                                        DCOSINT(x) = 0.0
!                                 The recommended value is pi/EPS.

!      Values of EPS and EPSNEG for certain machine/compiler
!      combinations can be found in the paper

!      W.J. CODY  Algorithm 665: MACHAR: A subroutine to dynamically
!      determine machine parameters, ACM Trans. Math. Soft. 14 (1988) 303-311.

!      The current code gives numerical values for XLOW,XHIGH1,XHIGH2
!      suitable for machines whose arithmetic conforms to the IEEE
!      standard. The codes will probably work on other machines
!      but might overflow or underflow for certain arguments.

!   AUTHOR: Allan MacLeod
!           Dept. of Mathematics and Statistics
!           University of Paisley
!           Scotland
!           (e-mail: macl_ms0@paisley.ac.uk)

IMPLICIT NONE
INTEGER, PARAMETER    :: dp = SELECTED_REAL_KIND(14, 60)
REAL (dp), INTENT(IN) :: xvalue
REAL (dp)             :: fn_val

! Local variables
INTEGER   :: i
REAL (dp) :: cx, dif, fival, gival, logval, root, sum, sumden, sumnum, &
             sx, x, xsq

!   DATA VALUES

REAL (dp), PARAMETER :: zero = 0.0_dp, one = 1.0_dp, three = 3.0_dp, &
                        six = 6.0_dp, twelve = 12.0_dp
REAL (dp), PARAMETER :: gamma = 0.57721566490153286060_dp
REAL (dp), PARAMETER :: logl1 = 0.046875_dp, logl2 = 0.25_dp

!   MACHINE-DEPENDENT PARAMETERS (SUITABLE FOR IEEE MACHINES)

REAL (dp), PARAMETER :: xlow = 1.48996E-8_dp, xhigh1 = 2.324953E8_dp,  &
                        xhigh2 = 1.4148475E16_dp

!  VALUES FOR COS-INTEGRAL FOR 0 < X <= 3

REAL (dp), PARAMETER :: ac1n(0:5) = (/ -0.24607411378767540707_dp,   &
         0.72113492241301534559E-2_dp, -0.11867127836204767056E-3_dp,  &
         0.90542655466969866243E-6_dp, -0.34322242412444409037E-8_dp,  &
         0.51950683460656886834E-11_dp /)
REAL (dp), PARAMETER :: ac1d(0:5) = (/ 1.0_dp, 0.12670095552700637845E-1_dp, &
                 0.78168450570724148921E-4_dp, 0.29959200177005821677E-6_dp, &
                 0.73191677761328838216E-9_dp, 0.94351174530907529061E-12_dp /)

!  VALUES FOR COS-INTEGRAL FOR 3 < X <= 6

REAL (dp), PARAMETER :: ac2n(0:7) = (/ -0.15684781827145408780_dp,     &
        0.66253165609605468916E-2_dp,  -0.12822297297864512864E-3_dp,  &
        0.12360964097729408891E-5_dp,  -0.66450975112876224532E-8_dp,  &
        0.20326936466803159446E-10_dp, -0.33590883135343844613E-13_dp, &
        0.23686934961435015119E-16_dp /)
REAL (dp), PARAMETER :: ac2d(0:6) = (/ 1.0_dp, 0.96166044388828741188E-2_dp,  &
                 0.45257514591257035006E-4_dp, 0.13544922659627723233E-6_dp,  &
                 0.27715365686570002081E-9_dp, 0.37718676301688932926E-12_dp, &
                 0.27706844497155995398E-15_dp /)

!  VALUES FOR FI(X) FOR 6 <= X <= 12

REAL (dp), PARAMETER :: afn1(0:7) = (/ 0.99999999962173909991E0_dp,  &
          0.36451060338631902917E3_dp, 0.44218548041288440874E5_dp,  &
          0.22467569405961151887E7_dp, 0.49315316723035561922E8_dp,  &
          0.43186795279670283193E9_dp, 0.11847992519956804350E10_dp, &
          0.45573267593795103181E9_dp /)
REAL (dp), PARAMETER :: afd1(0:7) = (/ 1.0_dp, 0.36651060273229347594E3_dp,  &
                  0.44927569814970692777E5_dp, 0.23285354882204041700E7_dp,  &
                  0.53117852017228262911E8_dp, 0.50335310667241870372E9_dp,  &
                  0.16575285015623175410E10_dp, 0.11746532837038341076E10_dp /)

!   VALUES OF GI(X) FOR 6 <= X <=12

REAL (dp), PARAMETER :: agn1(0:8) = (/ 0.99999999920484901956E0_dp,  &
         0.51385504875307321394E3_dp,  0.92293483452013810811E5_dp,  &
         0.74071341863359841727E7_dp,  0.28142356162841356551E9_dp,  &
         0.49280890357734623984E10_dp, 0.35524762685554302472E11_dp, &
         0.79194271662085049376E11_dp, 0.17942522624413898907E11_dp /)
REAL (dp), PARAMETER :: agd1(0:8) = (/ 1.0_dp,  0.51985504708814870209E3_dp,  &
                  0.95292615508125947321E5_dp,  0.79215459679762667578E7_dp,  &
                  0.31977567790733781460E9_dp,  0.62273134702439012114E10_dp, &
                  0.54570971054996441467E11_dp, 0.18241750166645704670E12_dp, &
                  0.15407148148861454434E12_dp /)

!   VALUES FOR FI(X) FOR X > 12

REAL (dp), PARAMETER :: afn2(0:7) = (/ 0.19999999999999978257E1_dp,   &
          0.22206119380434958727E4_dp, 0.84749007623988236808E6_dp,   &
          0.13959267954823943232E9_dp, 0.10197205463267975592E11_dp,  &
          0.30229865264524075951E12_dp, 0.27504053804288471142E13_dp, &
          0.21818989704686874983E13_dp /)
REAL (dp), PARAMETER :: afd2(0:7) = (/ 1.0_dp,  0.11223059690217167788E4_dp,  &
                  0.43685270974851313242E6_dp,  0.74654702140658116258E8_dp,  &
                  0.58580034751805687471E10_dp, 0.20157980379272098841E12_dp, &
                  0.26229141857684496445E13_dp, 0.87852907334918467516E13_dp /)

!   VALUES FOR GI(X) FOR X > 12

REAL (dp), PARAMETER :: agn2(0:8) = (/  0.59999999999999993089E1_dp,  &
          0.96527746044997139158E4_dp,  0.56077626996568834185E7_dp,  &
          0.15022667718927317198E10_dp, 0.19644271064733088465E12_dp, &
          0.12191368281163225043E14_dp, 0.31924389898645609533E15_dp, &
          0.25876053010027485934E16_dp, 0.12754978896268878403E16_dp /)
REAL (dp), PARAMETER :: agd2(0:8) = (/ 1.0_dp,  0.16287957674166143196E4_dp,  &
                  0.96636303195787870963E6_dp,  0.26839734750950667021E9_dp,  &
                  0.37388510548029219241E11_dp, 0.26028585666152144496E13_dp,  &
                  0.85134283716950697226E14_dp, 0.11304079361627952930E16_dp,  &
                  0.42519841479489798424E16_dp /)

!   VALUES FOR AN APPROXIMATION TO LN(X/ROOT)

REAL (dp), PARAMETER :: p(0:2) = (/   0.83930008362695945726E1_dp,  &
        -0.65306663899493304675E1_dp, 0.569155722227490223_dp /)
REAL (dp), PARAMETER :: q(0:1) = (/ 0.41965004181347972847E1_dp,  &
                                   -0.46641666676862479585E1_dp /)

!   VALUES OF THE FIRST TWO ROOTS OF THE COSINE-INTEGRAL

REAL (dp), PARAMETER :: rt1n = 631.0_dp, rt1d = 1024.0_dp, &
                        rt1r = 0.29454812071623379711E-3_dp
REAL (dp), PARAMETER :: rt2n = 3465.0_dp, rt2d = 1024.0_dp, &
                        rt2r = 0.39136005118642639785E-3_dp

!   START COMPUTATION

x = xvalue
IF ( x <= zero ) THEN
  fn_val = zero
  RETURN
END IF
IF ( x <= six ) THEN

!   CODE FOR 3 < X < =  6

  IF ( x > three ) THEN
    sumnum = zero
    sumden = zero
    xsq = x * x
    DO i = 7 , 0 , -1
      sumnum = sumnum * xsq + ac2n( i )
    END DO
    DO i = 6 , 0 , -1
      sumden = sumden * xsq + ac2d( i )
    END DO
    root = rt2n / rt2d
    dif = ( x - root ) - rt2r
    sum = root + rt2r
    IF ( ABS(dif) < logl2 ) THEN
      cx = dif / ( sum + x )
      xsq = cx * cx
      sx = p(0) + xsq * ( p(1) + xsq * p(2) )
      sx = sx / ( q(0) + xsq * ( q(1) + xsq ) )
      logval = cx * sx
    ELSE
      logval = LOG( x / sum )
    END IF
    fn_val = logval + dif * ( x + sum ) * sumnum / sumden
  ELSE

!   CODE FOR 0 < X < =  3

    IF ( x > xlow ) THEN
      sumnum = zero
      sumden = zero
      xsq = x * x
      DO i = 5 , 0 , -1
        sumnum = sumnum * xsq + ac1n( i )
        sumden = sumden * xsq + ac1d( i )
      END DO
      root = rt1n / rt1d
      dif = ( x - root ) - rt1r
      sum = root + rt1r
      IF ( ABS(dif) < logl1 ) THEN
        cx = dif / ( sum + x )
        xsq = cx * cx
        sx = p(0) + xsq * ( p(1) + xsq * p(2) )
        sx = sx / ( q(0) + xsq * ( q(1) + xsq ) )
        logval = cx * sx
      ELSE
        logval = LOG( x / sum )
      END IF
      fn_val = logval + dif * ( x + sum ) * sumnum / sumden
    ELSE
      fn_val = gamma + LOG( x )
    END IF
  END IF
END IF

!   CODE FOR 6 < X < =  12

IF ( x > six .AND. x <= twelve ) THEN
  sumnum = zero
  sumden = zero
  xsq = one / ( x * x )
  DO i = 7 , 0 , -1
    sumnum = sumnum * xsq + afn1( i )
    sumden = sumden * xsq + afd1( i )
  END DO
  fival = sumnum / ( x * sumden )
  sumnum = zero
  sumden = zero
  DO i = 8 , 0 , -1
    sumnum = sumnum * xsq + agn1( i )
    sumden = sumden * xsq + agd1( i )
  END DO
  gival = xsq * sumnum / sumden
  fn_val = fival * SIN( x ) - gival * COS( x )
END IF

!   CODE FOR X > 12

IF ( x > twelve ) THEN
  IF ( x > xhigh2 ) THEN
    fn_val = zero
  ELSE
    cx = COS( x )
    sx = SIN( x )
    xsq = one / ( x * x )
    IF ( x > xhigh1 ) THEN
      fn_val = sx / x - cx * xsq
    ELSE
      sumnum = zero
      sumden = zero
      DO i = 7 , 0 , -1
        sumnum = sumnum * xsq + afn2( i )
        sumden = sumden * xsq + afd2( i )
      END DO
      fival = ( one - xsq * sumnum / sumden ) / x
      sumnum = zero
      sumden = zero
      DO i = 8 , 0 , -1
        sumnum = sumnum * xsq + agn2( i )
        sumden = sumden * xsq + agd2( i )
      END DO
      gival = ( one - xsq * sumnum / sumden ) * xsq
      fn_val = sx * fival - cx * gival
    END IF
  END IF
END IF

RETURN
END FUNCTION dcosint


program while_01
implicit none
integer :: i, j
i = 1
j = 0
do while (i < 11)
    j = j + i
    i = i + 1
end do
if (j /= 55) error stop
if (i /= 11) error stop

i = 1
j = 0
do while (i <= 10)
    j = j + i
    i = i + 1
end do
if (j /= 55) error stop
if (i /= 11) error stop

i = 1
j = 0
do while (i < 1)
    j = j + i
    i = i + 1
end do
if (j /= 0) error stop
if (i /= 1) error stop
end


! { dg-do run }
! PR51634 - Handle allocatable components correctly in expressions
! involving typebound operators. From comment 2 of PR but using
! classes throughout.
!
! Reported by Tobias Burnus  <burnus@gcc.gnu.org>
!
module soop_stars_class
  implicit none
  type soop_stars
    real, dimension(:), allocatable :: position,velocity
  contains
    procedure :: total
    procedure :: mult
    procedure :: assign
    generic :: operator(+) => total
    generic :: operator(*) => mult
    generic :: assignment(=) => assign
  end type
contains
  function mult(lhs,rhs)
    class(soop_stars) ,intent(in) :: lhs
    real ,intent(in) :: rhs
    class(soop_stars), allocatable :: mult
    type(soop_stars) :: tmp
    tmp = soop_stars (lhs%position*rhs, lhs%velocity*rhs)
    allocate (mult, source = tmp)
  end function

  function total(lhs,rhs)
    class(soop_stars) ,intent(in) :: lhs,rhs
    class(soop_stars), allocatable :: total
    type(soop_stars) :: tmp
    tmp = soop_stars (lhs%position + rhs%position, &
                      lhs%velocity + rhs%velocity)
    allocate (total, source = tmp)
  end function

  subroutine assign(lhs,rhs)
    class(soop_stars), intent(in) :: rhs
    class(soop_stars), intent(out) :: lhs
    lhs%position = rhs%position
    lhs%velocity = rhs%velocity
  end subroutine
end module

program main
  use soop_stars_class ,only : soop_stars
  implicit none
  class(soop_stars), allocatable :: fireworks
  real :: dt
  allocate (fireworks, source = soop_stars ([1,2,3], [4,5,6]))
  dt = 5
  fireworks = fireworks + fireworks*dt
  if (any (fireworks%position .ne. [6, 12, 18])) STOP 1
  if (any (fireworks%velocity .ne. [24, 30, 36])) STOP 2
end program


program test2

    use mpi

    use quadrature, only: trapezoid
    use functions, only: f, fevals_proc, k

    implicit none
    real(kind=8) :: a,b,int_true, int_approx, int_sub, dx_sub
    real(kind=8) :: ab_sub(2)   ! to hold a and b for each subinterval

    integer :: i,j,jj,n_proc,proc_num, num_procs,ierr,n,fevals_total,nsub
    integer, dimension(MPI_STATUS_SIZE) :: status
    logical :: debug

    debug = .false.

    call MPI_INIT(ierr)
    call MPI_COMM_SIZE(MPI_COMM_WORLD, num_procs, ierr)
    call MPI_COMM_RANK(MPI_COMM_WORLD, proc_num, ierr)

    ! All processes set these values so we don't have to broadcast:
    k = 1.d3   ! functions module variable
    a = 0.d0
    b = 2.d0
    int_true = (b-a) + (b**4 - a**4) / 4.d0 - (1.d0/k) * (cos(k*b) - cos(k*a))
    n = 1000   ! points per subinterval
    nsub = num_procs - 1   ! number of subintervals

    ! Each process keeps track of number of fevals:
    fevals_proc = 0

    if (proc_num==0) then
        print '("Using ",i3," processes")', num_procs
        print '("true integral: ", es22.14)', int_true
        print *, " "  ! blank line

        int_approx = 0.d0  ! initialize variable for accumulating integral

        endif

    call MPI_BARRIER(MPI_COMM_WORLD,ierr) ! wait for process 0 to print

    ! -----------------------------------------
    ! code for Master (Processor 0):
    ! -----------------------------------------

    if (proc_num == 0) then

      dx_sub = (b-a) / nsub

      do j=1,nsub
        ab_sub(1) = a + (j-1)*dx_sub
        ab_sub(2) = a + j*dx_sub
        call MPI_SEND(ab_sub, 2, MPI_DOUBLE_PRECISION, j, j, &
                      MPI_COMM_WORLD, ierr)
        enddo

      do j=1,nsub
          call MPI_RECV(int_sub, 1, MPI_DOUBLE_PRECISION, &
                        MPI_ANY_SOURCE, MPI_ANY_TAG, &
                        MPI_COMM_WORLD, status, ierr)
          jj = status(MPI_TAG)
          if (debug) then
              print *,"+++ int_sub, int_approx: ",int_sub, int_approx
              endif
          int_approx = int_approx + int_sub

          enddo
        endif

    ! -----------------------------------------
    ! code for Workers (Processors 1, 2, ...):
    ! -----------------------------------------
    if (proc_num /= 0) then

        call MPI_RECV(ab_sub, 2, MPI_DOUBLE_PRECISION, &
                      0, MPI_ANY_TAG, &
                      MPI_COMM_WORLD, status, ierr)

        j = status(MPI_TAG)   ! this is the subinterval number

        if (debug) then
            print '("+++ Process ",i4,"  received message with tag ",i6)', &
               proc_num, j       ! for debugging
            endif

        int_sub = trapezoid(f,ab_sub(1),ab_sub(2),n)

        call MPI_SEND(int_sub, 1, MPI_DOUBLE_PRECISION, &
                    0, j, MPI_COMM_WORLD, ierr)

        endif

    call MPI_BARRIER(MPI_COMM_WORLD,ierr) ! wait for all process to print

    ! print the number of function evaluations by each thread:
    print '("fevals by Process ",i2,": ",i13)',  proc_num, fevals_proc

    call MPI_BARRIER(MPI_COMM_WORLD,ierr) ! wait for all process to print

    call MPI_REDUCE(fevals_proc, fevals_total, 1, MPI_INTEGER, MPI_SUM, 0, &
                    MPI_COMM_WORLD, ierr)

    if (proc_num==0) then
        print '("Trapezoid approximation with ",i8," total points: ",es22.14)',&
                nsub*n, int_approx
        print '("Total number of fevals: ",i10)', fevals_total
        endif

    call MPI_FINALIZE(ierr)

end program test2


! ==================================================================================
!   Purpose: This subroutine computes roots of the water-wave dispersion equation
!             in finite water depth, by using a higher-order iterative method
!
!  License:
!
!    This routine is part of FinGreen3D.
!
!    FinGreen3D is a free software package: you can redistribute it and/or modify it
!    under the terms of the GNU Lesser General Public License as published by the
!    Free Software Foundation, either version 3 of the License, or (at your option)
!    any later version.
!
!    You should have received a copy of the GNU General Public License (either V3
!    or later), along with FinGreen3D. If not, see <http://www.gnu.org/licenses/>.
!
!  Author:
!
!    Yingyi Liu on Mar.23, 2017
!
!  Reference:
!
!    Yingyi Liu, Shigeo Yoshida, Liang Sun, Junliang Gao
!    FinGreen3D: An efficient open-source package for computing free-surface
!    Green's function in finite water depth using new region-decomposition
!    strategy with applications to wave-structure interactions
!    Computer Physics Communications, 2016
!
!    J.N. Newman
!    Numerical solutions of the water-wave dispersion relation
!    Applied Ocean Research 12 (1990) 14-18
!
!  Parameters:
!      Input:   NRT --- Integer, the number of roots required
!                W   --- Real, wave angular frequency
!                H   --- Real, water depth (h>0)
!      Output:  WVN --- Real, an array storing roots of the dispersion equation
! ==================================================================================

      SUBROUTINE DISPERSION(WVN,NRT,W,H)
!
!   Evaluation of the roots of the following equations
!   by higher-order iterative method
!   first root stored in WVN is from Eq. (i)
!   the rest roots are from Eq. (ii)
!   i) w*w/g = k tanh ( kh )
!   ii) -w*w/g = Um tan ( Umh )
!

      IMPLICIT NONE
      INTEGER,INTENT(IN):: NRT
      REAL*8,INTENT(IN):: W,H
      REAL*8,INTENT(OUT):: WVN(1:NRT)
      INTEGER I, M
      REAL*8 T,X,U,Y,DNM,G,PI
      REAL*8 FUN,DFUN,D2FUN,TRIAL,EXX

      DATA G,PI/9.807d0,3.141592653589793d0/

!------------------------------------------------------------------
! I. calculation of wave number (root of Eq. (i))
!------------------------------------------------------------------
!
!   initialize iteration by an accurate Chebyshev approximation
!   if y=x, use the approximation directly insteady of iteration
!   to avoid the singularity in the denomenator of the transcendental
!   function; otherwise, do the iterative procedure.
!
      X=W*W*H/G
      IF (X.GT.0.D0.AND.X.LE.2.D0) THEN
       Y=DSQRT(X)*(0.9994D0+0.1701D0*X+0.0305*X*X)
      ELSE
       T=X*DEXP(-2.D0*X)
       Y=X+2.D0*T-6.D0*T*T
      ENDIF

      IF (DABS(Y-X).LT.1.E-10) THEN
       WVN(1)=X/H
      ELSE
       M=0
       EXX=1.D0
       DO WHILE (EXX.GT.1.0D-10)
        TRIAL=Y
        DNM=TRIAL*TRIAL-X*X
        FUN=DLOG((TRIAL+X)/(TRIAL-X))/2.D0-TRIAL
        DFUN=-X/DNM-1.D0
        D2FUN=2.D0*X*TRIAL/(DNM*DNM)
        Y=TRIAL-FUN/DFUN*(1.D0+(FUN/DFUN)*(D2FUN/DFUN)/2.D0)
        EXX=DABS(Y-TRIAL)
        M=M+1
       ENDDO
       WVN(1)=Y/H
      ENDIF

!------------------------------------------------------------------
! II. calcultion of roots of Eq. (ii), which characterizes
!     the evanescene modes in eigenfucntion
!------------------------------------------------------------------
!
!   initialize iteration by a suitable starting approximation
!
      U=3.D0*X/(7.D0+3.D0*X)
      T=0.0159D0+0.1032D0*U+4.3152D0*U*U-2.8768D0*U*U*U
!
!   perform iterative procedure to find exact solution of Um (m=1,..NRT-1)
!   of the transcendental equation Eq. (ii)
!
      DO I=2,NRT
       M=0
       EXX=1.D0
       DO WHILE (EXX.GT.1.0D-10)
        TRIAL=T
        Y=(I-1)*PI-TRIAL
        DNM=Y*Y+X*X
        FUN=ATAN2(X,Y)-TRIAL
        DFUN=X/DNM-1.D0
        D2FUN=2.D0*X*TRIAL/(DNM*DNM)
        T=TRIAL-FUN/DFUN*(1.D0+(FUN/DFUN)*(D2FUN/DFUN)/2.D0)
        EXX=DABS(T-TRIAL)
        M=M+1
       ENDDO
       Y=(I-1)*PI-T
       WVN(I)=Y/H
       T=T-PI*X/(X*X+PI*I*(PI*(I-1)-T))
      ENDDO

      END SUBROUTINE DISPERSION


! Program to test SELECTED_INT_KIND intrinsic function.
Program test_si_kind
  integer*1 i1
  integer*2 i2
  integer*4 i4
  integer*8 i8
  integer res
  real t

  t = huge (i1)
  t = log10 (t)
  res = selected_int_kind (int (t))
  if (res .ne. 1) call abort

  t = huge (i2)
  t = log10 (t)
  res = selected_int_kind (int (t))
  if (res .ne. 2) call abort

  t = huge (i4)
  t = log10 (t)
  res = selected_int_kind (int (t))
  if (res .ne. 4) call abort

  t = huge (i8)
  t = log10 (t)
  res = selected_int_kind (int (t))
  if (res .ne. 8) call abort

  i4 = huge (i4)
  res = selected_int_kind (i4)
  if (res .ne. (-1)) call abort

end program


!! ketot is matrix elements of -1/2 d^2/dx^2 in sinc function basis

subroutine sineDVR(ketot,fdtot, points,gridpoints,spacing)
  implicit none
  integer,intent(in) :: gridpoints
  real*8,intent(in) :: spacing
  real*8,intent(out) :: ketot(1-gridpoints:gridpoints-1),points(gridpoints),&
       fdtot(1-gridpoints:gridpoints-1)
  integer :: i
  real*8 ::  mypi

  myPi   = 4d0*atan(1d0)

  do i=1,gridpoints
     points(i) = i*spacing
  enddo

  points(:)=points(:)-(points(1)+points(gridpoints))/2d0

  do i=1-gridpoints,gridpoints-1
     if (i==0) then
        ketot(i) = myPi**2/3.d0
        fdtot(i) = 0d0
     else
        ketot(i) = 2.d0/real(i,8)**2 * (-1)**(i)
        fdtot(i) = 1d0/real(i,8) * (-1)**(i)
     endif
  enddo

  ketot=ketot/2.d0/spacing**2
  fdtot=fdtot/spacing

end subroutine sineDVR


program Map
  implicit none

  real :: t
  integer :: i

  do i = 0, 10
    t = Maprange((/0.0, 10.0/), (/-1.0, 0.0/), real(i))
    write(*,*) i, " maps to ", t
  end do

contains

function Maprange(a, b, s)
  real :: Maprange
  real, intent(in) :: a(2), b(2), s

  Maprange = (s-a(1)) * (b(2)-b(1)) / (a(2)-a(1)) + b(1)

end function Maprange
end program Map


! **
! * Provides a demo model to be solved by the non-concave EGM algorithm. The input model is taken as is from Fella (2011).
! **
module demo_fella11
    use kinds, only: dp
    use ncegm, only: ncegm_model,ncegm_setup,ncegm_solve
    use grids, only: build_grid
    use tauchen, only: tauchen_discretize
    implicit none
    private
    save
    public :: start_demo_fella2011

    ! *******************************************************************************************************
    ! ** Model parameters (Fella, 2011)
    ! *******************************************************************************************************

    integer, parameter              :: len_a_grid = 400                     ! asset grid size
    real (dp), parameter            :: theta= .77d0                         ! non-durables weight
    real (dp), parameter            :: tau  = 0.d0                          ! .2435d0! intratemporal elast.
    real (dp), parameter            :: kappa  = .075d0                      ! flow of house servic.
    real (dp), parameter            :: bita= 0.93d0                         ! discount factor

    real (dp), parameter            :: rho_yp = .977d0
    real (dp), parameter            :: mu0_yp = 0.d0
    real (dp), parameter            :: sigma_yp = .024d0

    real (dp), parameter            :: rho_yt= .0d0
    real (dp), parameter            :: mu0_yt = .0d0
    real (dp), parameter            :: sigma_yt = .063d0
    real (dp), parameter            :: downp= .2d0                          ! downpayment ratio
    real (dp), parameter            :: gamma_= .06d0                        ! percentage transaction cost

    ! *******************************************************************************************************
    ! ** Numerical parameters
    ! *******************************************************************************************************
    real (dp), parameter            :: min_a= 0.d0                          ! lower bound on assets
    real (dp), parameter            :: max_a= 25.d0                         ! upper bound on assets
    real (dp), parameter            :: min_h= 1.d-2                         ! lower bound on housing size
    real (dp), parameter            :: max_h = 10.0                         ! upper bound on housing
    integer, parameter              :: len_yp_grid = 7                      ! persistent shock grid size
    real(dp), parameter             :: cover_yp = 3.d0                      ! cover 3 sd each side
    integer, parameter              :: len_yt_grid = 7                      ! persistent shock grid size
    real(dp), parameter             :: cover_yt = 3.d0                      ! cover 3 sd each side
    integer, parameter              :: len_h_grid = 7                       ! number of housing choices
    integer, parameter              :: len_y_grid = len_yp_grid*len_yt_grid ! Income grid

    ! *******************************************************************************************************
    ! ** Grids
    ! *******************************************************************************************************
    real(dp), dimension(len_a_grid)                       :: a_grid
    real(dp), dimension(len_h_grid)                       :: sd_grid
    real(dp), dimension(len_y_grid)                       :: z_grid
    real(dp), dimension(len_y_grid,len_y_grid)            :: z_transition

    contains

        ! **
        ! * Sets up and solves the model from Fella (2011)
        ! **
        subroutine start_demo_fella2011()
            type(ncegm_model) :: m
            logical           :: status
            real(dp), dimension(len_a_grid, len_h_grid, len_y_grid), target   :: vfguess

            ! Setup the grids
            a_grid = build_grid(len_a_grid, min_a, max_a,2)
            sd_grid = build_grid(len_h_grid, min_h, max_h,0)
            call fella_create_zgrid_and_transition(z_grid, z_transition)

            ! Compute an initial guess for the value function
            vfguess = vfinitialguess()

            ! Allocate the grids and arrays of the model
            allocate(m%a_grid(len_a_grid),m%d_grid(len_h_grid),m%s_grid(len_h_grid),m%z_grid(len_y_grid))
            allocate(m%V_initial(len_a_grid,len_h_grid,len_y_grid))
            allocate(m%z_transition(len_y_grid,len_y_grid))

            ! Specify return function and derivatives
            m%F=>u
            m%dF=>du
            m%d2F=>d2u
            ! Specify budget constraint Lambda and, optionally, its derivative
            m%Lambda => Lambda
            m%dLambda => dLambda
            ! Specify transition function for state variable s
            m%Psi=>Psi
            ! Specify Markov matrix for the transition of the stochastic variable z
            m%z_transition=z_transition
            ! Specify the grids for A, D, S and Z (note that the grids for D and S are the same)
            m%a_grid=a_grid
            m%d_grid=sd_grid
            m%s_grid=sd_grid
            m%z_grid=z_grid
            ! Specify an initial guess for the value function
            m%V_initial=vfguess
            ! Finally, specify discount factor beta
            m%beta=bita
            m%state_independent_foc_and_f=.TRUE.

            call ncegm_setup(m,status)
            if (status) call ncegm_solve()

        end subroutine start_demo_fella2011

        ! *******************************************************************************************************
        ! ** Model functions
        ! *******************************************************************************************************

        function u(c,d,s,z)
            real(dp), dimension(:), intent(in)  :: c
            real(dp), intent(in)                :: d,s,z
            real(dp), dimension(size(c))        :: u
            if (tau.NE.0.d0) then
              u = LOG(theta*c**tau+(1.d0-theta)*(kappa*d)**tau)/tau
            else
              u = theta*LOG(c)+(1.d0-theta)*LOG(kappa*d)
            end if
        end function u

        function du(c,d,s,z)
            real(dp), dimension(:), intent(in)  :: c
            real(dp), intent(in)                :: d,s,z
            real(dp), dimension(size(c))        :: du

            du = theta*c**(tau-1.d0)/(theta*c**tau+(1.d0-theta)*(kappa*d)**tau)
        end function du

        function d2u(c,d,s,z)
            real(dp), dimension(:), intent(in)  :: c
            real(dp), intent(in)                :: d,s,z
            real(dp), dimension(size(c))        :: d2u

            d2u = (-tau*((theta*c**(tau-1))/(theta*c**tau+(1-theta)*(kappa*d)**tau))**2 + (tau-1)*theta*c**(tau-2)/(theta*c**tau+(1-theta)*(kappa*d)**tau))
        end function d2u

        function Lambda(a,d,s,z)
            real(dp), dimension(:), intent(in) :: a
            real(dp), intent(in)               :: d,s,z
            real(dp), dimension(size(a))       :: Lambda
            real(dp)                           :: trans_cost
            if (s.NE.d) then
                trans_cost = gamma_*d
            else
                trans_cost = 0.d0
            end if
            Lambda = (1.d0+6.d-2)*( a-(1.d0-downp)*s) + s- downp*d + z - trans_cost
        end function Lambda

        function dLambda(a,d,s,z)
            real(dp), dimension(:), intent(in) :: a
            real(dp), intent(in)               :: d,s,z
            real(dp), dimension(size(a))       :: dLambda
            real(dp)                           :: trans_cost
            dLambda = 1.d0+6.d-2
        end function dLambda

        function Psi(s_index,d_index,z_index)
            integer, intent(in)                :: s_index, d_index, z_index
            integer                            :: Psi
            Psi = d_index ! new state is equal to current period's discrete choice d
        end function

        ! *******************************************************************************************************
        ! ** Helper functions to set up the model
        ! *******************************************************************************************************

        ! **
        ! * Creates the grid for the stochastic variable z consisting of the sum of two AR(1) variables discretized using Tauchen (1986)'s method.
        ! *
        ! * Output:
        ! *     - zgrid: the grid for Z
        ! *     - transition_matrix: the Markov matrix for Z
        ! **
        subroutine fella_create_zgrid_and_transition(zgrid, transition_matrix)
            real(dp), dimension(len_y_grid), intent(out)             :: zgrid
            real(dp), dimension(len_y_grid,len_y_grid), intent(out)  :: transition_matrix

            real(dp), dimension(:), allocatable                      :: yp_grid, yt_grid
            real(dp), dimension(:,:), allocatable                    :: pi_yt, picum_yt, pi_yp, picum_yp

            integer                                                  :: i1, j1, i2, j2, index

            allocate(yp_grid(len_yp_grid),pi_yp(len_yp_grid,len_yp_grid),picum_yp(len_yp_grid,len_yp_grid))
            allocate(yt_grid(len_yt_grid),pi_yt(len_yt_grid,len_yt_grid),picum_yt(len_yt_grid,len_yt_grid))

            call tauchen_discretize(yp_grid,pi_yp,picum_yp,rho_yp,mu0_yp,sigma_yp,len_yp_grid,cover_yp)
            call tauchen_discretize(yt_grid,pi_yt,picum_yt,rho_yt,mu0_yt,sigma_yt,len_yt_grid,cover_yt)

            do i1 = 1,len_yp_grid
                do j1 = 1,len_yt_grid
                    index = len_yt_grid*(i1-1) + j1
                    zgrid(index) = yp_grid(i1) + yt_grid(j1)
                end do
            end do
            zgrid = exp(zgrid)

            ! Transition matrix for z
            do i1 = 1, size(pi_yp,1)
                do i2 = 1, size(pi_yt,1)
                    do j1 = 1, size(pi_yp,2)
                        do j2 = 1, size(pi_yt,2)
                            transition_matrix((i1-1)*size(pi_yt,1)+i2,(j1-1)*size(pi_yt,2)+j2) = pi_yp(i1,j1)*pi_yt(i2,j2)
                        end do
                    end do
                end do
            end do

        end subroutine

        ! **
        ! * Computes an initial guess for the value function by assuming the household consumes 2% of its assets plus its earned income.
        ! *
        ! * Return value: initial guess for the value function
        ! **
        function vfinitialguess() result(guess)
            real(dp), dimension(len_a_grid, len_h_grid, len_y_grid)   :: guess
            integer                                                   :: i1, i2
            real(dp), dimension(len_a_grid)                           :: c_guess

            do i1 = 1,len_y_grid
              c_guess(:) =  2.d-2*a_grid(:) + z_grid(i1)
              do i2 = 1,len_h_grid
                guess(:,i2,i1) = u(c_guess, sd_grid(i2), sd_grid(i2), z_grid(i1))
              end do
            end do
        end function

end module demo_fella11


program next_up
    use, intrinsic :: ieee_arithmetic
    use, intrinsic :: iso_fortran_env, only : DP => REAL64
    implicit none
    real :: x, next_x
    integer :: e

    do e = -37, 37
        x = 10.0**e
        next_x = ieee_next_after(x, x + 1.0)
        print '(4E15.7)', x, next_x, next_x - x, (next_x - x)/x
    end do
end program next_up


! Objetivo: Resolver a Eq. -g_div_k*t+(v0_sin_theta+g_div_k)/k*&
! (1.0-exp_menoskt) usando rtsafe para determinar o alcance.

MODULE altura_projetil
	REAL :: exp_menoskt,v0_sin_theta,k,g_div_k
CONTAINS
	SUBROUTINE funcd(t,altura_funct,deriv_funct)
		USE nrtype
		IMPLICIT none
		REAL, INTENT(IN) :: t
		REAL, INTENT(OUT) :: altura_funct,deriv_funct
		exp_menoskt= exp(-k*t)
		altura_funct=-g_div_k*t+(v0_sin_theta+g_div_k)/k*(1.0-exp_menoskt)
		deriv_funct=-g_div_k+(v0_sin_theta+g_div_k)*exp_menoskt
	END SUBROUTINE funcd
	FUNCTION altura_funct(t)
		USE nrtype
		REAL, INTENT(IN) :: t
		exp_menoskt= exp(-k*t)
		altura_funct=-g_div_k*t+(v0_sin_theta+g_div_k)/k*(1.0-exp_menoskt)
	END FUNCTION
END MODULE
PROGRAM arremesso
	USE altura_projetil
	USE nrtype
	USE nr, ONLY: rtsafe
	IMPLICIT none
	INTEGER,PARAMETER :: theta_x_R=8,k_x_R=9,pontos=300,pt_menos_1=pontos-1
	REAL, PARAMETER :: g=9.81,v0=600.0
	INTEGER :: theta_1,theta_2,theta_3,k1,k2
	REAL :: theta, t,t_1,t_2, R,v0_sob_k
	INTEGER,PARAMETER :: val_interv_k=10,interv_theta=7,interv_theta_mais1=&
				interv_theta+1
	REAL, PARAMETER :: v0_quad_g=(v0**2)/g,theta0=0.0,theta_final=PIO2,&
				k_inicial=0.0, k_final=0.1
	REAL, PARAMETER :: variacao_theta=theta_final-theta0,variacao_k=&
			k_final-k_inicial,variacao_theta_1=variacao_theta/REAL(pt_menos_1)
	REAL, PARAMETER :: variacao_k1=variacao_k/REAL(val_interv_k),precisao=1.0e-5
	REAL, PARAMETER :: variacao_k2=variacao_k/REAL(pt_menos_1),variacao_theta_2=&
						variacao_theta/REAL(interv_theta_mais1)
	LOGICAL :: succes

	OPEN(unit=theta_x_R,file="Theta_vs_R.dat")
	OPEN(unit=k_x_R,file="k_vs_R.dat")
! R vs theta, com k no intervalo [0, 0,1] (11 valores equidistantes)
! Inicialmente para k igual a zero
	theta=theta0
	DO theta_1=1,pontos
		v0_sin_theta=v0*sin(theta)
		R=v0_quad_g*sin(2.0*theta)
		WRITE(unit=theta_x_R,fmt=*) theta/PIO2,R
		theta=theta+variacao_theta_1
	END DO
	WRITE(unit=theta_x_R,fmt=*)
! Agora para k diferente de zero
	k=k_inicial
	DO k1=1,val_interv_k
		k=k+variacao_k1
		g_div_k=g/k
		v0_sob_k=v0/k
		theta=theta0
		R=0.0
		WRITE(unit=theta_x_R,fmt=*) theta/PIO2,R
		theta=theta+variacao_theta_1
		v0_sin_theta = v0*sin(theta)
		t_1=v0_sin_theta/g
		t_2=2.0*t_1
		DO theta_2=1,pontos
			CALL zbrac(altura_funct,t_1,t_2,succes)
			T=rtsafe(funcd,t_1,t_2,precisao)
			R=v0_sob_k*cos(theta)*(1.0-exp(-k*T))
			WRITE(unit=theta_x_R,fmt=*) theta/PIO2,R,T,t_1,t_2
			theta=theta+variacao_theta_1
			v0_sin_theta = v0*sin(theta)
			t_1=T-0.1
			t_2=T+0.1
		END DO
		WRITE(unit=theta_x_R,fmt=*)
	END DO
! R vs k[0, 0,1], com theta no intervalo (0, pi/2) (7 valores equidistantes)
	theta=theta0
	DO theta_3=1,interv_theta
! Inicialmente para k igual a zero
		theta=theta+variacao_theta_2
		v0_sin_theta=v0*sin(theta)
		k=k_inicial
		R=v0_quad_g*sin(2.0*theta)
		WRITE(unit=k_x_R,fmt=*) k,R
! Agora para k diferente de zero
		t_1=v0_sin_theta/g
		t_2=2.0*t_1
		DO k2=1,pt_menos_1
			k=k+variacao_k2
			g_div_k=g/k
			v0_sob_k=v0/k
			CALL zbrac(altura_funct,t_1,t_2,succes)
			T=rtsafe(funcd,t_1,t_2,precisao)
			R=v0*cos(theta)/k*(1.0-exp(-k*T))
			WRITE(unit=k_x_R,fmt=*) k,R
			v0_sin_theta=v0*sin(theta)
			t_1=T-0.1
			t_2=T+0.1
		END DO
		WRITE(unit=k_x_R,fmt=*)
	END DO
	CLOSE(unit=theta_x_R)
	CLOSE(unit=k_x_R)
END PROGRAM arremesso


!
!  See deeming.py for info. This file contains 2 Fortran implimentations
!  of the deeming periodogram algorithm
subroutine periodogram(time, value, freqs, nt, nf , numprocs, amps)

! periodogram calculates the Deeming periodogram of the datapoints contained
! in the arrays time, value at the frequencies contained in freqs
! This subroutine is meant for f2py wrapping as well as a testbed of openMP
! within a python environment

    use omp_lib
    implicit none

    ! sizes of time and frequency arrays
    integer :: nt, nf, id
    ! arrays
    double precision time(nt), value(nt)
    double precision freqs(nf), amps(nf)
    integer :: numprocs, f
    double precision :: pi, realpart, imagpart

    pi = 3.1415926535897931D0
    realpart = 0.0D0
    imagpart = 0.0D0

! Add compiler directives so f2py knows what to do

!f2py intent(in) time
!f2py intent(in) value

!f2py intent(in) nt
!f2py depend(nt) time
!f2py depend(nt) value

!f2py intent(in) freqs
!f2py intent(in) nf
!f2py depend(nf) freqs

!f2py intent(in) numprocs
!f2py intent(out) amps

    call OMP_SET_NUM_THREADS(numprocs)

    !$OMP PARALLEL DO &
    !$OMP DEFAULT(SHARED) PRIVATE(f,realpart, imagpart)
    do f = 1, nf
        ! calculate real and imaginary parts
        realpart = sum((value*dcos(2.0D0*pi*freqs(f)*time)))
        imagpart = sum((value*dsin(2.0D0*pi*freqs(f)*time)))

        ! calculate the amplitude
        amps(f) = 2.0D0*dsqrt(realpart**2 + imagpart**2)/nt
    end do
    !$OMP END PARALLEL DO

end subroutine

subroutine periodogram2(time, value, freqs, nt, nf , numprocs, amps)

! periodogram calculates the Deeming periodogram of the datapoints contained
! in the arrays time, value at the frequencies contained in freqs
! This subroutine is meant for f2py wrapping as well as a testbed of openMP
! within a python environment

    use omp_lib
    implicit none

    ! sizes of time and frequency arrays
    integer :: nt, nf, id
    ! arrays
    double precision time(nt), value(nt)
    double precision freqs(nf), amps(nf)
    integer :: numprocs, f, d
    double precision :: pi, realpart, imagpart

    pi = 3.1415926535897931D0
    realpart = 0.0D0
    imagpart = 0.0D0

! Add compiler directives so f2py knows what to do

!f2py threadsafe
!f2py intent(in) time
!f2py intent(in) value

!f2py intent(in) nt
!f2py depend(nt) time
!f2py depend(nt) value

!f2py intent(in) freqs
!f2py intent(in) nf
!f2py depend(nf) freqs

!f2py intent(in) numprocs
!f2py intent(out) amps

    call OMP_SET_NUM_THREADS(numprocs)

    !$OMP PARALLEL DO &
    !$OMP DEFAULT(SHARED) PRIVATE(f,realpart, imagpart)
    do f = 1, nf
        ! calculate real and imaginary parts
        do d = 1, nt
            realpart = realpart + value(d)*dcos(2.0D0*pi*freqs(f)*time(d))
            imagpart = imagpart + value(d)*dsin(2.0D0*pi*freqs(f)*time(d))
        end do

        ! calculate the amplitude
        amps(f) = 2.0D0*dsqrt(realpart*realpart + imagpart*imagpart)/nt

        realpart = 0.0D0
        imagpart = 0.0D0
    end do
    !$OMP END PARALLEL DO

end subroutine


!------------------------------------------------------------------------
!  RK4 SOLVER for a system of ODEs                                      |
!  Course:  AE305                                                       |
!------------------------------------------------------------------------
module data
	integer, parameter :: neq=2
	real*8, parameter :: rho_p=1140., a=5.55e-5 ! ..., ..., ...
end module

program sysRK4
	use data
	real*8 :: y(neq)
	character*40 :: fname

!..read the input data
	write(*,'(/(a))',advance='no')' Enter the step size and the end point :>'
	read(*,*) dt,tmax
!..open the output file
	write(*,'(a)',advance='no')' Enter the output file name [solution.dat]:>'
	read(*,'(a)') fname
	if( fname .eq. ' ') fname = 'solution.dat'
	open(1,file=fname,form='formatted')

!..set the initial conditions
	time = 0.
!~ 	y(1) = ...
!~ 	y(2) = ...
	write(1,'(6E14.5)') time,(y(i),i=1,neq)

!..solution loop
	DO WHILE (time .lt. tmax)
		call SRK4(time,dt,y)
		time = time + dt
		write(1,'(6E14.5)') time,(y(i),i=1,neq)
	ENDDO

	close(1)
	stop
end

!------------------------------------------------------------------------
subroutine SRK4(time,dt,y)
      use data
	real*8 :: y(neq),ytmp(neq),k1(neq),k2(neq),k3(neq),k4(neq)
	dt2 = 0.5*dt

	call odes(time,y,k1)
	do i = 1,neq
         ytmp(i)  = y(i) + k1(i)*dt2
	enddo
!~ 	call ODES( ... )
!~ 	...
!~ 	...

!..obtain the solution at t+dt and update y for the next step
	do i = 1,neq
		phi  = (k1(i) + 2*(k2(i)+k3(i)) + k4(i))/6.
		y(i) = y(i) + phi*dt
	enddo

	return
	end

!------------------------------------------------------------------------
subroutine ODEs(time,y,f)
      use data
	real*8 :: y(neq),f(neq)

!..define the ODE's & return the slopes in the "f" array

!~ 	f(1) = ...
!~ 	f(2) = ...

	return
end


      program P0214
c>> 1997-10-02 Krogh Generate plots for ch02-02.tex
      integer MAXPT
      real RMAXPT, XA, XB, XSIZE, YSIZE
      real YMIN
      real PI2
      parameter (MAXPT=101, RMAXPT=101.E0)
      parameter (XA = 0.0E0, XB = 12.0E0)
      parameter (XSIZE=3.2E0, YSIZE=2.5E0)
      parameter (YMIN=-2.0E0)
      parameter (PI2=1.57079632679489E0)
      real DX, OPT(23), X(MAXPT), Y(MAXPT, 3)
      external SCI, SCIN, SSI
      real SCI, SCIN, SSI
      integer I
      character COPT*63
      real PLOUNI, PLOTXT, PLONY, PLOBOR, PLOYMX, PLOANL
      parameter (PLOUNI=1.E0, PLOTXT=14.E0, PLONY=2.E0, PLOBOR=4.E0,
     1   PLOYMX=9.E0, PLOANL=16.E0)
      data OPT / 0.E0, PLONY, RMAXPT, 3.E0, PLOANL, PI2, 1924.E0,
     1   PLOTXT, 1.3E0, 1.9E0, 360.E0, PLOTXT, 4.3E0, -.6E0, 0.E0,
     1   PLOTXT, 7.E0, 2.8E0, 0.E0, PLOYMX, YMIN, 4.E0,
     2   0.E0 /
c               1111111111222222222233333333334444444444555555555556666
c      1234567890123456789012345678901234567890123456789012345678901234
      data COPT /
     1'F{pl02-14.tex}[cr]{$\frac{\pi}{2}$}{Si$(x)$}{Ci$(x)$}{Cin$(x)$}'
     2/
c
      DX = (XB - XA) / (MAXPT-1)
      do 100 I = 1, MAXPT
         X(I) = real(I-1) * DX
         if (X(I) .eq. 0.E0) X(I) = 1.E-3
         Y(I,1) = SSI(X(I))
         Y(I,2) = SCI(X(I))
         Y(I,3) = SCIN(X(I))
  100 continue
      call SPLOT(XSIZE, YSIZE, X, MAXPT, Y, OPT, COPT)
      stop
      end


      SUBROUTINE CELLVECT
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!! Generates the vectors used to convert fractionals to
!! Cartesians and cartesians to fractionals
!! Using the cell parameters a,b
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!

      USE header_file
      IMPLICIT NONE

      REAL(kind = double) :: DET
      REAL(kind = double), DIMENSION(3,3) :: DUMMY1,DUMMY2
      INTEGER :: I,J

!!! EA is on x-axis so is (a,0,0)

      EFC(1,1) = ALEN
      EFC(1,2) = BLEN*COS(GAMMA) + DELTA
      EFC(1,3) = CLEN*COS(GAMMA)

!!! EB lies in xy plane at an angle gamma to x

      EFC(2,1) = 0.0D0
      EFC(2,2) = BLEN*SIN(GAMMA)
      EFC(2,3) = CLEN*(COS(ALPHA) -(COS(GAMMA)*COS(BETA)))/SIN(GAMMA)

!!! EC points into space and has components in all directions

      EFC(3,1) = 0.0D0
      EFC(3,2) = 0.0D0
      EFC(3,3) = CLEN - CLEN*COS(BETA)*COS(BETA) +                        &
      &           CLEN*((COS(ALPHA) - COS(ALPHA)*COS(BETA)) / SIN(GAMMA)) &
      &               *((COS(ALPHA)-COS(ALPHA)*COS(BETA))/SIN(GAMMA))

!!! copy EFC array elements to dummy1 matrix

        DO I = 1,3
          DO J = 1,3
            DUMMY1(I,J) = EFC(I,J)
          END DO
        END DO

        CALL INVERT(DUMMY1,DUMMY2)

!!! copy dummy2 array elements to ECF matrix

        DO I = 1,3
          DO J = 1,3
            ECF(I,J) = DUMMY2(I,J)
          END DO
        END DO

      END SUBROUTINE


PROGRAM EXAMPLE
  IMPLICIT NONE
  INTEGER :: exponent, factor

  WRITE(*,*) "Enter exponent of Mersenne number"
  READ(*,*) exponent
  factor = Mfactor(exponent)
  IF (factor == 0) THEN
    WRITE(*,*) "No Factor found"
  ELSE
    WRITE(*,"(A,I0,A,I0)") "M", exponent, " has a factor: ", factor
  END IF

CONTAINS

FUNCTION isPrime(number)
!   code omitted - see [[Primality by Trial Division]]
END FUNCTION

FUNCTION  Mfactor(p)
  INTEGER :: Mfactor
  INTEGER, INTENT(IN) :: p
  INTEGER :: i, k,  maxk, msb, n, q

  DO i = 30, 0 , -1
    IF(BTEST(p, i)) THEN
      msb = i
      EXIT
    END IF
  END DO

  maxk = 16384  / p     ! limit for k to prevent overflow of 32 bit signed integer
  DO k = 1, maxk
    q = 2*p*k + 1
    IF (.NOT. isPrime(q)) CYCLE
    IF (MOD(q, 8) /= 1 .AND. MOD(q, 8) /= 7) CYCLE
    n = 1
    DO i = msb, 0, -1
      IF (BTEST(p, i)) THEN
        n = MOD(n*n*2, q)
      ELSE
        n = MOD(n*n, q)
      ENDIF
    END DO
    IF (n == 1) THEN
      Mfactor = q
      RETURN
    END IF
  END DO
  Mfactor = 0
END FUNCTION
END PROGRAM EXAMPLE


c
c  . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . .
c  .                                                             .
c  .                  copyright (c) 1998 by UCAR                 .
c  .                                                             .
c  .       University Corporation for Atmospheric Research       .
c  .                                                             .
c  .                      all rights reserved                    .
c  .                                                             .
c  .                                                             .
c  .                         SPHEREPACK3.0                       .
c  .                                                             .
c  . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . .
c
c
c
c ... file shagc.f
c
c     this file contains code and documentation for subroutines
c     shagc and shagci
c
c ... files which must be loaded with shagc.f
c
c     sphcom.f, hrfft.f, gaqd.f
c
c
c     subroutine shagc(nlat,nlon,isym,nt,g,idg,jdg,a,b,mdab,ndab,
c    +                 wshagc,lshagc,work,lwork,ierror)
c
c     subroutine shagc performs the spherical harmonic analysis
c     on the array g and stores the result in the arrays a and b.
c     the analysis is performed on a gaussian grid in colatitude
c     and an equally spaced grid in longitude.  the associated
c     legendre functions are recomputed rather than stored as they
c     are in subroutine shags.  the analysis is described below
c     at output parameters a,b.
c
c     input parameters
c
c     nlat   the number of points in the gaussian colatitude grid on the
c            full sphere. these lie in the interval (0,pi) and are compu
c            in radians in theta(1),...,theta(nlat) by subroutine gaqd.
c            if nlat is odd the equator will be included as the grid poi
c            theta((nlat+1)/2).  if nlat is even the equator will be
c            excluded as a grid point and will lie half way between
c            theta(nlat/2) and theta(nlat/2+1). nlat must be at least 3.
c            note: on the half sphere, the number of grid points in the
c            colatitudinal direction is nlat/2 if nlat is even or
c            (nlat+1)/2 if nlat is odd.
c
c     nlon   the number of distinct londitude points.  nlon determines
c            the grid increment in longitude as 2*pi/nlon. for example
c            nlon = 72 for a five degree grid. nlon must be greater
c            than or equal to 4. the efficiency of the computation is
c            improved when nlon is a product of small prime numbers.
c
c     isym   = 0  no symmetries exist about the equator. the analysis
c                 is performed on the entire sphere.  i.e. on the
c                 array g(i,j) for i=1,...,nlat and j=1,...,nlon.
c                 (see description of g below)
c
c            = 1  g is antisymmetric about the equator. the analysis
c                 is performed on the northern hemisphere only.  i.e.
c                 if nlat is odd the analysis is performed on the
c                 array g(i,j) for i=1,...,(nlat+1)/2 and j=1,...,nlon.
c                 if nlat is even the analysis is performed on the
c                 array g(i,j) for i=1,...,nlat/2 and j=1,...,nlon.
c
c
c            = 2  g is symmetric about the equator. the analysis is
c                 performed on the northern hemisphere only.  i.e.
c                 if nlat is odd the analysis is performed on the
c                 array g(i,j) for i=1,...,(nlat+1)/2 and j=1,...,nlon.
c                 if nlat is even the analysis is performed on the
c                 array g(i,j) for i=1,...,nlat/2 and j=1,...,nlon.
c
c     nt     the number of analyses.  in the program that calls shagc,
c            the arrays g,a and b can be three dimensional in which
c            case multiple analyses will be performed.  the third
c            index is the analysis index which assumes the values
c            k=1,...,nt.  for a single analysis set nt=1. the
c            discription of the remaining parameters is simplified
c            by assuming that nt=1 or that the arrays g,a and b
c            have only two dimensions.
c
c     g      a two or three dimensional array (see input parameter
c            nt) that contains the discrete function to be analyzed.
c            g(i,j) contains the value of the function at the gaussian
c            point theta(i) and longitude point phi(j) = (j-1)*2*pi/nlon
c            the index ranges are defined above at the input parameter
c            isym.
c
c     idg    the first dimension of the array g as it appears in the
c            program that calls shagc. if isym equals zero then idg
c            must be at least nlat.  if isym is nonzero then idg must
c            be at least nlat/2 if nlat is even or at least (nlat+1)/2
c            if nlat is odd.
c
c     jdg    the second dimension of the array g as it appears in the
c            program that calls shagc. jdg must be at least nlon.
c
c     mdab   the first dimension of the arrays a and b as it appears
c            in the program that calls shagc. mdab must be at least
c            min0((nlon+2)/2,nlat) if nlon is even or at least
c            min0((nlon+1)/2,nlat) if nlon is odd
c
c     ndab   the second dimension of the arrays a and b as it appears
c            in the program that calls shaec. ndab must be at least nlat
c
c     wshagc an array which must be initialized by subroutine shagci.
c            once initialized, wshagc can be used repeatedly by shagc.
c            as long as nlat and nlon remain unchanged.  wshagc must
c            not be altered between calls of shagc.
c
c     lshagc the dimension of the array wshagc as it appears in the
c            program that calls shagc. define
c
c               l1 = min0(nlat,(nlon+2)/2) if nlon is even or
c               l1 = min0(nlat,(nlon+1)/2) if nlon is odd
c
c            and
c
c               l2 = nlat/2        if nlat is even or
c               l2 = (nlat+1)/2    if nlat is odd
c
c            then lshagc must be at least
c
c                  nlat*(2*l2+3*l1-2)+3*l1*(1-l1)/2+nlon+15
c
c
c     work   a work array that does not have to be saved.
c
c     lwork  the dimension of the array work as it appears in the
c            program that calls shagc. define
c
c               l1 = min0(nlat,(nlon+2)/2) if nlon is even or
c               l1 = min0(nlat,(nlon+1)/2) if nlon is odd
c
c            and
c
c               l2 = nlat/2        if nlat is even or
c               l2 = (nlat+1)/2    if nlat is odd
c
c            if isym is zero then lwork must be at least
c
c                      nlat*(nlon*nt+max0(3*l2,nlon))
c
c            if isym is not zero then lwork must be at least
c
c                      l2*(nlon*nt+max0(3*nlat,nlon))
c
c     **************************************************************
c
c     output parameters
c
c     a,b    both a,b are two or three dimensional arrays (see input
c            parameter nt) that contain the spherical harmonic
c            coefficients in the representation of g(i,j) given in the
c            discription of subroutine shagc. for isym=0, a(m,n) and
c            b(m,n) are given by the equations listed below. symmetric
c            versions are used when isym is greater than zero.
c
c     definitions
c
c     1. the normalized associated legendre functions
c
c     pbar(m,n,theta) = sqrt((2*n+1)*factorial(n-m)/(2*factorial(n+m)))
c                       *sin(theta)**m/(2**n*factorial(n)) times the
c                       (n+m)th derivative of (x**2-1)**n with respect
c                       to x=cos(theta).
c
c     2. the fourier transform of g(i,j).
c
c     c(m,i)          = 2/nlon times the sum from j=1 to j=nlon of
c                       g(i,j)*cos((m-1)*(j-1)*2*pi/nlon)
c                       (the first and last terms in this sum
c                       are divided by 2)
c
c     s(m,i)          = 2/nlon times the sum from j=2 to j=nlon of
c                       g(i,j)*sin((m-1)*(j-1)*2*pi/nlon)
c
c
c     3. the gaussian points and weights on the sphere
c        (computed by subroutine gaqd).
c
c        theta(1),...,theta(nlat) (gaussian pts in radians)
c        wts(1),...,wts(nlat) (corresponding gaussian weights)
c
c     4. the maximum (plus one) longitudinal wave number
c
c            mmax = min0(nlat,(nlon+2)/2) if nlon is even or
c            mmax = min0(nlat,(nlon+1)/2) if nlon is odd.
c
c
c     then for m=0,...,mmax-1 and n=m,...,nlat-1 the arrays a,b
c     are given by
c
c     a(m+1,n+1)     =  the sum from i=1 to i=nlat of
c                       c(m+1,i)*wts(i)*pbar(m,n,theta(i))
c
c     b(m+1,n+1)      = the sum from i=1 to nlat of
c                       s(m+1,i)*wts(i)*pbar(m,n,theta(i))
c
c     ierror = 0  no errors
c            = 1  error in the specification of nlat
c            = 2  error in the specification of nlon
c            = 3  error in the specification of isym
c            = 4  error in the specification of nt
c            = 5  error in the specification of idg
c            = 6  error in the specification of jdg
c            = 7  error in the specification of mdab
c            = 8  error in the specification of ndab
c            = 9  error in the specification of lshagc
c            = 10 error in the specification of lwork
c
c
c ****************************************************************
c
c     subroutine shagci(nlat,nlon,wshagc,lshagc,dwork,ldwork,ierror)
c
c     subroutine shagci initializes the array wshagc which can then
c     be used repeatedly by subroutines shagc. it precomputes
c     and stores in wshagc quantities such as gaussian weights,
c     legendre polynomial coefficients, and fft trigonometric tables.
c
c     input parameters
c
c     nlat   the number of points in the gaussian colatitude grid on the
c            full sphere. these lie in the interval (0,pi) and are compu
c            in radians in theta(1),...,theta(nlat) by subroutine gaqd.
c            if nlat is odd the equator will be included as the grid poi
c            theta((nlat+1)/2).  if nlat is even the equator will be
c            excluded as a grid point and will lie half way between
c            theta(nlat/2) and theta(nlat/2+1). nlat must be at least 3.
c            note: on the half sphere, the number of grid points in the
c            colatitudinal direction is nlat/2 if nlat is even or
c            (nlat+1)/2 if nlat is odd.
c
c     nlon   the number of distinct londitude points.  nlon determines
c            the grid increment in longitude as 2*pi/nlon. for example
c            nlon = 72 for a five degree grid. nlon must be greater
c            than or equal to 4. the efficiency of the computation is
c            improved when nlon is a product of small prime numbers.
c
c     wshagc an array which must be initialized by subroutine shagci.
c            once initialized, wshagc can be used repeatedly by shagc
c            as long as nlat and nlon remain unchanged.  wshagc must
c            not be altered between calls of shagc.
c
c     lshagc the dimension of the array wshagc as it appears in the
c            program that calls shagc. define
c
c               l1 = min0(nlat,(nlon+2)/2) if nlon is even or
c               l1 = min0(nlat,(nlon+1)/2) if nlon is odd
c
c            and
c
c               l2 = nlat/2        if nlat is even or
c               l2 = (nlat+1)/2    if nlat is odd
c
c            then lshagc must be at least
c
c                  nlat*(2*l2+3*l1-2)+3*l1*(1-l1)/2+nlon+15
c
c     dwork   a double precision work array that does not have to be saved.
c
c     ldwork  the dimension of the array dwork as it appears in the
c            program that calls shagci. ldwork must be at least
c
c                nlat*(nlat+4)
c
c     output parameter
c
c     wshagc an array which must be initialized before calling shagc or
c            once initialized, wshagc can be used repeatedly by shagc or
c            as long as nlat and nlon remain unchanged.  wshagc must not
c            altered between calls of shagc.
c
c     ierror = 0  no errors
c            = 1  error in the specification of nlat
c            = 2  error in the specification of nlon
c            = 3  error in the specification of lshagc
c            = 4  error in the specification of ldwork
c            = 5  failure in gaqd to compute gaussian points
c                 (due to failure in eigenvalue routine)
c
c
c ****************************************************************
      subroutine shagc(nlat,nlon,isym,nt,g,idg,jdg,a,b,mdab,ndab,
     1                    wshagc,lshagc,work,lwork,ierror)
c     subroutine shagc performs the spherical harmonic analysis on
c     a gaussian grid on the array(s) in g and returns the coefficients
c     in array(s) a,b. the necessary legendre polynomials are computed
c     as needed in this version.
c
      dimension g(idg,jdg,1),a(mdab,ndab,1),b(mdab,ndab,1),
     1          wshagc(lshagc),work(lwork)
c     check input parameters
      ierror = 1
      if (nlat.lt.3) return
      ierror = 2
      if (nlon.lt.4) return
      ierror = 3
      if (isym.lt.0 .or.isym.gt.2) return
      ierror = 4
      if (nt.lt.1) return
c     set upper limit on m for spherical harmonic basis
      l = min0((nlon+2)/2,nlat)
c     set gaussian point nearest equator pointer
      late = (nlat+mod(nlat,2))/2
c     set number of grid points for analysis/synthesis
      lat = nlat
      if (isym.ne.0) lat = late
      ierror = 5
      if (idg.lt.lat) return
      ierror = 6
      if (jdg.lt.nlon) return
      ierror = 7
      if(mdab .lt. l) return
      ierror = 8
      if(ndab .lt. nlat) return
      l1 = l
      l2 = late
      ierror = 9
c     check permanent work space length
      if (lshagc .lt. nlat*(2*l2+3*l1-2)+3*l1*(1-l1)/2+nlon+15)return
      ierror = 10
c     check temporary work space length
      if (isym.eq.0) then
      if(lwork.lt.nlat*(nlon*nt+max0(3*l2,nlon))) return
      else
c     isym.ne.0
      if(lwork.lt.l2*(nlon*nt+max0(3*nlat,nlon))) return
      end if
      ierror = 0
c     starting address for gaussian wts in shigc and fft values
      iwts = 1
      ifft = nlat+2*nlat*late+3*(l*(l-1)/2+(nlat-l)*(l-1))+1
c     set pointers for internal storage of g and legendre polys
      ipmn = lat*nlon*nt+1
      call shagc1(nlat,nlon,l,lat,isym,g,idg,jdg,nt,a,b,mdab,ndab,
     1wshagc,wshagc(iwts),wshagc(ifft),late,work(ipmn),work)
      return
      end
      subroutine shagc1(nlat,nlon,l,lat,mode,gs,idg,jdg,nt,a,b,mdab,
     1                  ndab,w,wts,wfft,late,pmn,g)
      dimension gs(idg,jdg,nt),a(mdab,ndab,nt),
     1          b(mdab,ndab,nt),g(lat,nlon,nt)
      dimension w(1),wts(nlat),wfft(1),pmn(nlat,late,3)
c     set gs array internally in shagc1
      do 100 k=1,nt
      do 100 j=1,nlon
      do 100 i=1,lat
      g(i,j,k) = gs(i,j,k)
  100 continue
c     do fourier transform
      do 101 k=1,nt
      call hrfftf(lat,nlon,g(1,1,k),lat,wfft,pmn)
  101 continue
c     scale result
      sfn = 2.0/float(nlon)
      do 102 k=1,nt
      do 102 j=1,nlon
      do 102 i=1,lat
      g(i,j,k) = sfn*g(i,j,k)
  102 continue
c     compute using gaussian quadrature
c     a(n,m) = s (ga(theta,m)*pnm(theta)*sin(theta)*dtheta)
c     b(n,m) = s (gb(theta,m)*pnm(theta)*sin(theta)*dtheta)
c     here ga,gb are the cos(phi),sin(phi) coefficients of
c     the fourier expansion of g(theta,phi) in phi.  as a result
c     of the above fourier transform they are stored in array
c     g as follows:
c     for each theta(i) and k= l-1
c     ga(0),ga(1),gb(1),ga(2),gb(2),...,ga(k-1),gb(k-1),ga(k)
c     correspond to (in the case nlon=l+l-2)
c     g(i,1),g(i,2),g(i,3),g(i,4),g(i,5),...,g(i,2l-4),g(i,2l-3),g(i,2l-
c     initialize coefficients to zero
      do 103 k=1,nt
      do 103 np1=1,nlat
      do 103 mp1=1,l
      a(mp1,np1,k) = 0.0
      b(mp1,np1,k) = 0.0
  103 continue
c     set m+1 limit on b(m+1) calculation
      lm1 = l
      if (nlon .eq. l+l-2) lm1 = l-1
      if (mode.eq.0) then
c     for full sphere (mode=0) and even/odd reduction:
c     overwrite g(i) with (g(i)+g(nlat-i+1))*wts(i)
c     overwrite g(nlat-i+1) with (g(i)-g(nlat-i+1))*wts(i)
      nl2 = nlat/2
      do 104 k=1,nt
      do 104 j=1,nlon
      do 105 i=1,nl2
      is = nlat-i+1
      t1 = g(i,j,k)
      t2 = g(is,j,k)
      g(i,j,k) = wts(i)*(t1+t2)
      g(is,j,k) = wts(i)*(t1-t2)
  105 continue
c     adjust equator if necessary(nlat odd)
      if (mod(nlat,2).ne.0) g(late,j,k) = wts(late)*g(late,j,k)
  104 continue
c     set m = 0 coefficients first
      m = 0
      call legin(mode,l,nlat,m,w,pmn,km)
      do 106 k=1,nt
      do 106 i=1,late
      is = nlat-i+1
      do 107 np1=1,nlat,2
c     n even
      a(1,np1,k) = a(1,np1,k)+g(i,1,k)*pmn(np1,i,km)
  107 continue
      do 108 np1=2,nlat,2
c     n odd
      a(1,np1,k) = a(1,np1,k)+g(is,1,k)*pmn(np1,i,km)
  108 continue
  106 continue
c     compute coefficients for which b(m,n) is available
      do 109 mp1=2,lm1
      m = mp1-1
      mp2 = m+2
c     compute pmn for all i and n=m,...,l-1
      call legin(mode,l,nlat,m,w,pmn,km)
      do 110 k=1,nt
      do 111 i=1,late
      is = nlat-i+1
c     n-m even
      do 112 np1=mp1,nlat,2
      a(mp1,np1,k) = a(mp1,np1,k)+g(i,2*m,k)*pmn(np1,i,km)
      b(mp1,np1,k) = b(mp1,np1,k)+g(i,2*m+1,k)*pmn(np1,i,km)
  112 continue
c     n-m odd
      do 113 np1=mp2,nlat,2
      a(mp1,np1,k) = a(mp1,np1,k)+g(is,2*m,k)*pmn(np1,i,km)
      b(mp1,np1,k) = b(mp1,np1,k)+g(is,2*m+1,k)*pmn(np1,i,km)
  113 continue
  111 continue
  110 continue
  109 continue
      if (nlon .eq. l+l-2) then
c     compute a(l,np1) coefficients only
      m = l-1
      call legin(mode,l,nlat,m,w,pmn,km)
      do 114 k=1,nt
      do 114 i=1,late
      is = nlat-i+1
c     n-m even
      do 124 np1=l,nlat,2
      a(l,np1,k) = a(l,np1,k)+0.5*g(i,nlon,k)*pmn(np1,i,km)
  124 continue
      lp1 = l+1
c     n-m odd
      do 125 np1=lp1,nlat,2
      a(l,np1,k) = a(l,np1,k)+0.5*g(is,nlon,k)*pmn(np1,i,km)
  125 continue
  114 continue
      end if
      else
c     half sphere
c     overwrite g(i) with wts(i)*(g(i)+g(i)) for i=1,...,nlate/2
      nl2 = nlat/2
      do 116  k=1,nt
      do 116 j=1,nlon
      do 115 i=1,nl2
      g(i,j,k) = wts(i)*(g(i,j,k)+g(i,j,k))
  115 continue
c     adjust equator separately if a grid point
      if (nl2.lt.late) g(late,j,k) = wts(late)*g(late,j,k)
  116 continue
c     set m = 0 coefficients first
      m = 0
      call legin(mode,l,nlat,m,w,pmn,km)
      ms = 1
      if (mode.eq.1) ms = 2
      do 117 k=1,nt
      do 117 i=1,late
      do 117 np1=ms,nlat,2
      a(1,np1,k) = a(1,np1,k)+g(i,1,k)*pmn(np1,i,km)
  117 continue
c     compute coefficients for which b(m,n) is available
      do 118 mp1=2,lm1
      m = mp1-1
      ms = mp1
      if (mode.eq.1) ms = mp1+1
c     compute pmn for all i and n=m,...,nlat-1
      call legin(mode,l,nlat,m,w,pmn,km)
      do 119 k=1,nt
      do 119 i=1,late
      do 119 np1=ms,nlat,2
      a(mp1,np1,k) = a(mp1,np1,k)+g(i,2*m,k)*pmn(np1,i,km)
      b(mp1,np1,k) = b(mp1,np1,k)+g(i,2*m+1,k)*pmn(np1,i,km)
  119 continue
  118 continue
      if (nlon.eq.l+l-2) then
c     compute coefficient a(l,np1) only
      m = l-1
      call legin(mode,l,nlat,m,w,pmn,km)
      ns = l
      if (mode.eq.1) ns = l+1
      do 120 k=1,nt
      do 120 i=1,late
      do 120 np1=ns,nlat,2
      a(l,np1,k) = a(l,np1,k)+0.5*g(i,nlon,k)*pmn(np1,i,km)
  120 continue
      end if
      end if
      return
      end
      subroutine shagci(nlat,nlon,wshagc,lshagc,dwork,ldwork,ierror)
c     this subroutine must be called before calling shagc with
c     fixed nlat,nlon. it precomputes quantites such as the gaussian
c     points and weights, m=0,m=1 legendre polynomials, recursion
c     recursion coefficients.
      dimension wshagc(lshagc)
      double precision dwork(ldwork)
      ierror = 1
      if (nlat.lt.3) return
      ierror = 2
      if (nlon.lt.4) return
c     set triangular truncation limit for spherical harmonic basis
      l = min0((nlon+2)/2,nlat)
c     set equator or nearest point (if excluded) pointer
      late = (nlat+mod(nlat,2))/2
      l1 = l
      l2 = late
      ierror = 3
c     check permanent work space length
      if (lshagc .lt. nlat*(2*l2+3*l1-2)+3*l1*(1-l1)/2+nlon+15)return
      ierror = 4
      if (ldwork.lt.nlat*(nlat+4))return
      ierror = 0
c     set pointers
      i1 = 1
      i2 = i1+nlat
      i3 = i2+nlat*late
      i4 = i3+nlat*late
      i5 = i4+l*(l-1)/2 +(nlat-l)*(l-1)
      i6 = i5+l*(l-1)/2 +(nlat-l)*(l-1)
      i7 = i6+l*(l-1)/2 +(nlat-l)*(l-1)
c     set indices in temp work for double precision gaussian wts and pts
      idth = 1
      idwts = idth+nlat
      iw = idwts+nlat
      call shagci1(nlat,nlon,l,late,wshagc(i1),wshagc(i2),wshagc(i3),
     1wshagc(i4),wshagc(i5),wshagc(i6),wshagc(i7),dwork(idth),
     2dwork(idwts),dwork(iw),ierror)
      if (ierror.ne.0) ierror = 5
      return
      end
      subroutine shagci1(nlat,nlon,l,late,wts,p0n,p1n,abel,bbel,cbel,
     1                  wfft,dtheta,dwts,work,ier)
      dimension wts(nlat),p0n(nlat,late),p1n(nlat,late),abel(1),bbel(1),
     1 cbel(1),wfft(1)
      double precision pb,dtheta(nlat),dwts(nlat),work(*)
c     compute the nlat  gaussian points and weights, the
c     m=0,1 legendre polys for gaussian points and all n,
c     and the legendre recursion coefficients
c     define index function used in storing
c     arrays for recursion coefficients (functions of (m,n))
c     the index function indx(m,n) is defined so that
c     the pairs (m,n) map to [1,2,...,indx(l-1,l-1)] with no
c     "holes" as m varies from 2 to n and n varies from 2 to l-1.
c     (m=0,1 are set from p0n,p1n for all n)
c     define for 2.le.n.le.l-1
      indx(m,n) = (n-1)*(n-2)/2+m-1
c     define index function for l.le.n.le.nlat
      imndx(m,n) = l*(l-1)/2+(n-l-1)*(l-1)+m-1
c     preset quantites for fourier transform
      call hrffti(nlon,wfft)
c     compute double precision gaussian points and weights
c     lw = 4*nlat*(nlat+1)+2
      lw = nlat*(nlat+2)
      call gaqd(nlat,dtheta,dwts,work,lw,ier)
      if (ier.ne.0) return
c     store gaussian weights single precision to save computation
c     in inner loops in analysis
      do 100 i=1,nlat
      wts(i) = dwts(i)
  100 continue
c     initialize p0n,p1n using double precision dnlfk,dnlft
      do 101 np1=1,nlat
      do 101 i=1,late
      p0n(np1,i) = 0.0
      p1n(np1,i) = 0.0
  101 continue
c     compute m=n=0 legendre polynomials for all theta(i)
      np1 = 1
      n = 0
      m = 0
      call dnlfk(m,n,work)
      do 103 i=1,late
      call dnlft(m,n,dtheta(i),work,pb)
      p0n(1,i) = pb
  103 continue
c     compute p0n,p1n for all theta(i) when n.gt.0
      do 104 np1=2,nlat
      n = np1-1
      m = 0
      call dnlfk(m,n,work)
      do 105 i=1,late
      call dnlft(m,n,dtheta(i),work,pb)
      p0n(np1,i) = pb
  105 continue
c     compute m=1 legendre polynomials for all n and theta(i)
      m = 1
      call dnlfk(m,n,work)
      do 106 i=1,late
      call dnlft(m,n,dtheta(i),work,pb)
      p1n(np1,i) = pb
  106 continue
  104 continue
c     compute and store swarztrauber recursion coefficients
c     for 2.le.m.le.n and 2.le.n.le.nlat in abel,bbel,cbel
      do 107 n=2,nlat
      mlim = min0(n,l)
      do 107 m=2,mlim
      imn = indx(m,n)
      if (n.ge.l) imn = imndx(m,n)
      abel(imn)=sqrt(float((2*n+1)*(m+n-2)*(m+n-3))/
     1               float(((2*n-3)*(m+n-1)*(m+n))))
      bbel(imn)=sqrt(float((2*n+1)*(n-m-1)*(n-m))/
     1               float(((2*n-3)*(m+n-1)*(m+n))))
      cbel(imn)=sqrt(float((n-m+1)*(n-m+2))/
     1               float(((n+m-1)*(n+m))))
  107 continue
      return
      end


module module_velnw

contains

      subroutine velnw(km,jm,im,dxs,ro,p,u,dt,f,dys,v,g,dzs,w,h)
      use params_common_sn!, only : ip, jp, kp !, only : ip, jp, kp
      integer, intent(In) :: km
      integer, intent(In) :: jm
      integer, intent(In) :: im
      real, dimension(0:ip), intent(In) :: dxs
      real, intent(In) :: ro
      real, dimension(0:ip+2,0:jp+2,0:kp+1), intent(In) :: p
      real, dimension(0:ip+1,-1:jp+1,0:kp+1), intent(InOut) :: u
      real, intent(In) :: dt
      real, dimension(0:ip,0:jp,0:kp), intent(In) :: f
      real, dimension(0:jp), intent(In) :: dys
      real, dimension(0:ip+1,-1:jp+1,0:kp+1), intent(InOut) :: v
      real, dimension(0:ip,0:jp,0:kp), intent(In) :: g
      real, dimension(-1:kp+2), intent(In) :: dzs
      real, dimension(0:ip+1,-1:jp+1,-1:kp+1), intent(InOut) :: w
      real, dimension(0:ip,0:jp,0:kp), intent(In) :: h
      integer :: k
      integer :: j
      integer :: i
      real :: pz
!
!
! --u velocity
      do k=1,km
      do j=1,jm
      do i=1,im
        pz   = (-p(i,j,k)+p(i+1,j,k))/ro/dxs(i)
        u(i,j,k)=u(i,j,k)+dt*(f(i,j,k)-pz)
        u(i,j,k)=u(i,j,k)
   end do
      end do
      end do
! --v velocity
      do k=1,km
      do j=1,jm
      do i=1,im
        pz   = (-p(i,j,k)+p(i,j+1,k))/ro/dys(j)
!         if (k.eq.km/2 .and. j.eq.jm/2 .and. i.eq.im/2) then
!             print *,'timestep', p(i,j,k),p(i,j+1,k),v(i,j,k),v(i,j,k)
!      &       +dt*(g(i,j,k)-pz)
!         end if
        v(i,j,k)=v(i,j,k)+dt*(g(i,j,k)-pz)
        v(i,j,k)=v(i,j,k)
   end do
      end do
      end do
! --w velocity
      do k=1,km-1
      do j=1,jm
      do i=1,im
        pz   = (-p(i,j,k)+p(i,j,k+1))/ro/dzs(k)
        w(i,j,k)=w(i,j,k)+dt*(h(i,j,k)-pz)
        w(i,j,k)=w(i,j,k)
   end do
      end do
      end do
!
      return
      end subroutine velnw

end module module_velnw


module types
implicit none
private
public dp

integer, parameter :: dp=kind(0d0)

end module

module find_fit_module

! This module contains a general function find_fit() for a nonlinear least
! squares fitting. The function can fit any nonlinear expression to any data.

use minpack_module, only: lmdif1
use types, only: dp
implicit none
private
public find_fit

contains

subroutine find_fit(data_x, data_y, expr, pars)
! Fits the (data_x, data_y) arrays with the function expr(x, pars).
! The user can provide any nonlinear function 'expr' depending on any number of
! parameters 'pars' and it must return the evaluated expression on the
! array 'x'. The arrays 'data_x' and 'data_y' must have the same
! length.
real(dp), intent(in) :: data_x(:), data_y(:)
interface
    function expr(x, pars) result(y)
    use types, only: dp
    implicit none
    real(dp), intent(in) :: x(:), pars(:)
    real(dp) :: y(size(x))
    end function
end interface
real(dp), intent(inout) :: pars(:)

real(dp) :: tol, fvec(size(data_x))
integer :: iwa(size(pars)), info, m, n
real(dp), allocatable :: wa(:)

tol = sqrt(epsilon(1._dp))
m = size(fvec)
n = size(pars)
allocate(wa(m*n + 5*n + m))
call lmdif1(fcn, m, n, pars, fvec, tol, info, iwa, wa, size(wa))
if (info /= 1) stop "failed to converge"

contains

subroutine fcn(m, n, x, fvec, iflag)
integer, intent(in) :: m, n
integer, intent(inout) :: iflag
real(dp), intent(in) :: x(n)
real(dp), intent(out) :: fvec(m)
! Suppress compiler warning:
fvec(1) = iflag
fvec = data_y - expr(data_x, x)
end subroutine

end subroutine

end module

program example_primes

! Find a nonlinear fit of the form a*x*log(b + c*x) to a list of primes.

use find_fit_module, only: find_fit
use types, only: dp
implicit none

real(dp) :: pars(3)
real(dp), parameter :: y(*) = [2, 3, 5, 7, 11, 13, 17, 19, 23, 29, 31, &
    37, 41, 43, 47, 53, 59, 61, 67, 71]
integer :: i
pars = [1._dp, 1._dp, 1._dp]
call find_fit([(real(i, dp), i=1,size(y))], y, expression, pars)
print *, pars

contains

function expression(x, pars) result(y)
real(dp), intent(in) :: x(:), pars(:)
real(dp) :: y(size(x))
real(dp) :: a, b, c
a = pars(1)
b = pars(2)
c = pars(3)
y = a*x*log(b + c*x)
end function

end program


      SUBROUTINE tutest(data1,n1,data2,n2,t,prob)
      INTEGER n1,n2
      REAL prob,t,data1(n1),data2(n2)
CU    USES avevar,betai
      REAL ave1,ave2,df,var1,var2,betai
      call avevar(data1,n1,ave1,var1)
      call avevar(data2,n2,ave2,var2)
      t=(ave1-ave2)/sqrt(var1/n1+var2/n2)
      df=(var1/n1+var2/n2)**2/((var1/n1)**2/(n1-1)+(var2/n2)**2/(n2-1))
      prob=betai(0.5*df,0.5,df/(df+t**2))
      return
      END

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


module plane42rect

    !! This module contains subroutines specific to the plane42 element
    !!
    !! The plane42 element has 4 nodes. Each node has 2 degrees-of-freedom,
    !! namely, displacement along the \(x\)- and \(y\)-coordinate directions.
    !!
    !! The nodes are numbered counter-clockwise as indicated below. The
    !! figure also shows how the element edges are labelled. For example,
    !! edge 1 is the edge between element node 1 and 2.
    !!
    !!       N4    E3    N3
    !!          o------o
    !!          |      |
    !!       E4 |      | E2
    !!          |      |
    !!          o------o
    !!       N1    E1    N2
    !!
    !!
    !! `N1` = element node 1, `N2` = element node 2, etc
    !! `E1` = element face 1, `E2` = element face 2, etc

    use types
    implicit none
    save

    private
    public :: plane42rect_ke, plane42rect_re, plane42rect_ss

contains

    subroutine plane42rect_ke(xe, young, nu, thk, ke)

        !! This subroutine constructs the stiffness matrix for
        !! a rectangular 4-noded quad element.

        real(wp), intent(in) :: young
            !! Young's Modulus for this element
        real(wp), intent(in) :: nu
            !! Poisson's Ratio for this element
        real(wp), intent(in) :: thk
            !! Thickness of this element

        real(wp), dimension(:), intent(in) :: xe
            !! Nodal coordinates of this element in undeformed configuration
            !!
            !! * `xe(1:2)` = \((x,y)\)-coordinates of element node 1
            !! * `xe(3:4)` = \((x,y)\)-coordinates of element node 1
            !! * `xe(5:6)` = \((x,y)\)-coordinates of element node 2
            !! * `xe(7:8)` = \((x,y)\)-coordinates of element node 2
            !!
            !! See also [[plane42rect]]
        real(wp), dimension(:,:), intent(out) :: ke
            !! Stiffness matrix

        real(wp) :: cmat(3,3), fact, aa, bb
        real(wp) :: t1, t2, t3, t4, t5, t6, t9, t11, t13, t15, &
                        t16, t17, t18, t19, t22, t25, t29, t33, &
                        t34, t38, t42, t43, t47, t51, t55, t56, &
                        t57, t58, t59, t62, t66, t70, t74, t78, &
                        t82, t86, t90, t94, t98, t102, t106, t110
        real(wp) :: d11, d12, d13, d22, d23, d33

        aa = (xe(3)-xe(1))/2
        bb = (xe(8)-xe(2))/2

        ! build constitutive matrix (plane stress)
        cmat = 0
        fact = young/(1-nu**2)
        cmat(1,1) = fact
        cmat(1,2) = fact*nu
        cmat(2,1) = fact*nu
        cmat(2,2) = fact
        cmat(3,3) = fact*(1-nu)/2

        d11 = cmat(1,1)
        d12 = cmat(1,2)
        d13 = cmat(1,3)
        d22 = cmat(2,2)
        d23 = cmat(2,3)
        d33 = cmat(3,3)

        t1 = bb**2
        t2 = t1*d11
        t3 = 2*t2
        t4 = aa**2
        t5 = t4*d33
        t6 = 2*t5
        t9 = 3*d13*aa*bb
        t11 = 1/aa
        t13 = 1/bb
        t15 = (t3+t6+t9)*t11*t13/6
        t16 = d13*t1
        t17 = 4*t16
        t18 = t4*d23
        t19 = 4*t18
        t22 = 3*d12*aa*bb
        t25 = 3*aa*d33*bb
        t29 = (t17+t19+t22+t25)*t11*t13/12
        t33 = (-t3+t5)*t11*t13/6
        t34 = 2*t18
        t38 = (-t17+t34+t22-t25)*t11*t13/12
        t42 = (t2+t5+t9)*t11*t13/6
        t43 = 2*t16
        t47 = (t43+t34+t22+t25)*t11*t13/12
        t51 = (-t2+t6)*t11*t13/6
        t55 = (-t43+t19+t22-t25)*t11*t13/12
        t56 = d33*t1
        t57 = 2*t56
        t58 = t4*d22
        t59 = 2*t58
        t62 = 3*aa*d23*bb
        t66 = (t57+t59+t62)*t11*t13/6
        t70 = (-t17+t34-t22+t25)*t11*t13/12
        t74 = (-t57+t58)*t11*t13/6
        t78 = (t56+t58+t62)*t11*t13/6
        t82 = (-t43+t19-t22+t25)*t11*t13/12
        t86 = (-t56+t59)*t11*t13/6
        t90 = (t3+t6-t9)*t11*t13/6
        t94 = (t17+t19-t22-t25)*t11*t13/12
        t98 = (t2+t5-t9)*t11*t13/6
        t102 = (t43+t34-t22-t25)*t11*t13/12
        t106 = (t57+t59-t62)*t11*t13/6
        t110 = (t56+t58-t62)*t11*t13/6
        ke(1,1) = t15
        ke(1,2) = t29
        ke(1,3) = t33
        ke(1,4) = t38
        ke(1,5) = -t42
        ke(1,6) = -t47
        ke(1,7) = -t51
        ke(1,8) = -t55
        ke(2,1) = t29
        ke(2,2) = t66
        ke(2,3) = t70
        ke(2,4) = t74
        ke(2,5) = -t47
        ke(2,6) = -t78
        ke(2,7) = -t82
        ke(2,8) = -t86
        ke(3,1) = t33
        ke(3,2) = t70
        ke(3,3) = t90
        ke(3,4) = t94
        ke(3,5) = -t51
        ke(3,6) = -t82
        ke(3,7) = -t98
        ke(3,8) = -t102
        ke(4,1) = t38
        ke(4,2) = t74
        ke(4,3) = t94
        ke(4,4) = t106
        ke(4,5) = -t55
        ke(4,6) = -t86
        ke(4,7) = -t102
        ke(4,8) = -t110
        ke(5,1) = -t42
        ke(5,2) = -t47
        ke(5,3) = -t51
        ke(5,4) = -t55
        ke(5,5) = t15
        ke(5,6) = t29
        ke(5,7) = t33
        ke(5,8) = t38
        ke(6,1) = -t47
        ke(6,2) = -t78
        ke(6,3) = -t82
        ke(6,4) = -t86
        ke(6,5) = t29
        ke(6,6) = t66
        ke(6,7) = t70
        ke(6,8) = t74
        ke(7,1) = -t51
        ke(7,2) = -t82
        ke(7,3) = -t98
        ke(7,4) = -t102
        ke(7,5) = t33
        ke(7,6) = t70
        ke(7,7) = t90
        ke(7,8) = t94
        ke(8,1) = -t55
        ke(8,2) = -t86
        ke(8,3) = -t102
        ke(8,4) = -t110
        ke(8,5) = t38
        ke(8,6) = t74
        ke(8,7) = t94
        ke(8,8) = t106

        ke = ke*thk
    end subroutine plane42rect_ke
!
!--------------------------------------------------------------------------------------------------
!
    subroutine plane42rect_re(xe, eface, fe, thk, re)

        !! This subroutine computes the element load vector due
        !! to surface traction (traction is always perpendicular
        !! to element face).

        ! inputs:
        ! xe		nodal coordniates
        ! eface		face number
        ! fe		pressure value
        ! thk		thickness
        ! re		element load vector (output)

        integer, intent(in) :: eface
            !! Element face where traction (pressure) is applied

        real(wp), intent(in) :: fe
            !! Value of surface traction (pressure)
        real(wp), intent(in) :: thk
            !! Thickness of this element
        real(wp), dimension(:), intent(in) :: xe
            !! Nodal coordinates of this element in undeformed configuration (see also [[plane42rect_ke]])
        real(wp), intent(out) :: re(8)
            !! Element force vector
            !!
            !! * `re(1:2)` = \((f_x^1, f_y^1)\) force at element node 1 in \(x\)- and y-direction
            !! * `re(3:4)` = \((f_x^2, f_y^2)\) force at element node 1 in \(x\)- and y-direction
            !! * etc...
        real(wp) :: aa, bb, nface(2,8), f(2)

        aa = (xe(3)-xe(1))/2
        bb = (xe(8)-xe(2))/2

        nface = 0
        f = 0
        if (eface == 1) then
            nface(1,1) = aa
            nface(1,3) = aa
            nface(2,2) = aa
            nface(2,4) = aa
            f(2) = fe
        elseif (eface == 2) then
            nface(1,3) = bb
            nface(1,5) = bb
            nface(2,4) = bb
            nface(2,6) = bb
            f(1) = -fe
        elseif (eface == 3) then
            nface(1,5) = aa
            nface(1,7) = aa
            nface(2,6) = aa
            nface(2,8) = aa
            f(2) = -fe
        elseif (eface == 4) then
            nface(1,1) = bb
            nface(1,7) = bb
            nface(2,2) = bb
            nface(2,8) = bb
            f(1) = fe
        endif

        re = matmul(transpose(nface), f) * thk

    end subroutine plane42rect_re
!
!--------------------------------------------------------------------------------------------------
!
    subroutine plane42rect_ss(xe, de, young, nu, estress, estrain, element_evaluation_x, element_evaluation_y)

        !! This subrotuine computes the element stress and strain (The location inside the element
        !! where stress and and strain is evaluated, is defined inside the subroutine).

        real(wp), intent(in) :: young
            !! Young's Modulus for this element
        real(wp), intent(in) :: nu
            !! Poisson's Ratio for this element
        real(wp), intent(in) :: element_evaluation_x, element_evaluation_y
            !! Point of evaluation for continuum elements
        real(wp), dimension(:), intent(in)  :: xe
            !! Nodal coordinates of this element in undeformed configuration (see also [[plane42rect_ke]])
        real(wp), dimension(:), intent(in)  :: de
            !! Displacement field
            !!
            !! * `de(1:2)` = displacement of element node 1 along \(x\)- and \(y\)-axis, respectively
            !! * `de(3:4)` = displacement of element node 2 along \(x\)- and \(y\)-axis, respectively
            !! * etc...
        real(wp), dimension(:), intent(out) :: estress
            !! Stress at a point inside the element
            !!
            !! * `estress(1)` = \(\sigma_{11}\)
            !! * `estress(2)` = \(\sigma_{22}\)
            !! * `estress(3)` = \(\sigma_{12}\)
        real(wp), dimension(:), intent(out) :: estrain
            !! Strain at a point inside the element
            !!
            !! * `estrain(1)` = \(\epsilon_{11}\)
            !! * `estrain(2)` = \(\epsilon_{22}\)
            !! * `estrain(3)` = \(\epsilon_{12}\)
        real(wp) :: bmat(3, 8), cmat(3, 3)
        real(wp) :: factc, factb, aa, bb

		! Element dimensions
        aa = (xe(3)-xe(1))/2
        bb = (xe(8)-xe(2))/2

        ! Build strain-displacement matrix
        bmat = 0
        factb = 1/(4*aa*bb)

        bmat(1,1) = factb*(-bb+element_evaluation_y)
        bmat(3,1) = factb*(-aa+element_evaluation_x)
        bmat(2,2) = bmat(3,1)
        bmat(3,2) = bmat(1,1)

        bmat(1,3) = factb*( bb-element_evaluation_y)
        bmat(3,3) = factb*(-aa-element_evaluation_x)
        bmat(2,4) = bmat(3,3)
        bmat(3,4) = bmat(1,3)

        bmat(1,5) = factb*(bb+element_evaluation_y)
        bmat(3,5) = factb*(aa+element_evaluation_x)
        bmat(2,6) = bmat(3,5)
        bmat(3,6) = bmat(1,5)

        bmat(1,7) = factb*(-bb-element_evaluation_y)
        bmat(3,7) = factb*( aa-element_evaluation_x)
        bmat(2,8) = bmat(3,7)
        bmat(3,8) = bmat(1,7)

        ! Compute element strain
        estrain = matmul(bmat, de)

        ! Build constitutive matrix (plane stress)
        cmat = 0
        factc = young/(1-nu**2)
        cmat(1,1) = factc
        cmat(1,2) = factc*nu
        cmat(2,1) = factc*nu
        cmat(2,2) = factc
        cmat(3,3) = factc*(1-nu)/2

        ! Compute element stress
        estress = matmul(cmat, estrain)

        ! Compute principal stress and direction
        ! print *, "stress:",estress
    end subroutine plane42rect_ss

end module plane42rect


 SUBROUTINE princi(ndime,i,ll)
 !
 ! Compute principal values and directions of a 3-D 2nd order tensor
 ! used to compute principal values and directions of INERTIA tensor
 ! NOT adequate for Cauchy-Green tensor
 ! not very efficient but called once in a run
 !
 IMPLICIT NONE
 INTEGER (kind=4),INTENT (IN) :: ndime !problem dimension, MUST be 3
 REAL (kind=8), INTENT(IN OUT) :: i(ndime,ndime), & ! inertia tensor in global system (IN)
                                  ll(ndime,ndime)   ! local system at the node (IN)

 REAL (kind=8),PARAMETER :: pi = 3.14159265358979
 INTEGER (kind=4) :: k,lg(1)
 REAL (kind=8) :: i1,i2,i3,i13,phi,lp(3),la,a(2,2),det,l(3,3),pr(3)

 !     compute mean value and deviator tensor
 i1   = (i(1,1) + i(2,2) + i(3,3))     ! I1
 i13  = i1/3d0                         ! I1/3
 i(1,1) = i(1,1) -i13                  ! deviator tensor
 i(2,2) = i(2,2) -i13
 i(3,3) = i(3,3) -i13
 !     compute principal values
 i2  =SQRT(4d0*( - i(1,1)*i(2,2) - i(1,1)*i(3,3) - i(2,2)*i(3,3)  &  ! (4/3 I2)^(1/2)
                 + i(1,2)**2     + i(1,3)**2     + i(2,3)**2 )/3d0)
 i3  = i(1,1)*i(2,2)*i(3,3) + 2*i(1,2)*i(2,3)*i(3,1)  &              !third inv (det)
      -i(1,1)*i(2,3)**2 - i(2,2)*i(1,3)**2 - i(3,3)*i(1,2)**2
 IF(i2/i1 < 1.e-6)THEN     !all eigenvalues are almost equal
   i(1,1) = i(1,1) + i13
   i(2,2) = i(2,2) + i13
   i(3,3) = i(3,3) + i13
   ll(:,1) = (/ 1d0, 0d0, 0d0 /)
   ll(:,2) = (/ 0d0, 1d0, 0d0 /)
   ll(:,3) = (/ 0d0, 0d0, 1d0 /)
   RETURN
 END IF
 phi = ASIN(-4d0*i3/(i2**3))/3d0          !angle
 lp(1) = i2*SIN(phi+2d0/3d0*pi)         !largest root
 lp(2) = i2*SIN(phi)                    !interm. root
 lp(3) = i2*SIN(phi+4d0/3d0*pi)         !smallest root
 !     compute firt and third principal directions
 DO k=1,3,2  !principal directions 1 & 3
   !  first option, use the first two equations
   a(1,1) = i(1,1) - lp(k)
   a(1,2) = i(1,2)
   a(2,1) = i(2,1)
   a(2,2) = i(2,2) - lp(k)
   det = a(1,1)*a(2,2) - a(1,2)*a(2,1)
   IF( ABS(det) > 1d-8)THEN
     i1  = (-i(1,3)*a(2,2)+i(2,3)*a(1,2) )/det
     i2  = ( i(1,3)*a(2,1)-i(2,3)*a(1,1) )/det
     i3  = 1d0
     la  = SQRT(i1**2+i2**2+i3**2)
     l(1,k)  = i1/la
     l(2,k)  = i2/la
     l(3,k)  = i3/la
   ELSE
     ! second option, use  the last two equations
     a(1,1) = i(2,2) - lp(k)
     a(1,2) = i(2,3)
     a(2,1) = i(3,2)
     a(2,2) = i(3,3) - lp(k)
     det = a(1,1)*a(2,2) - a(1,2)*a(2,1)
     IF( ABS(det) > 1d-8)THEN
       i1  = 1d0
       i2  = (-i(2,1)*a(2,2)+i(3,1)*a(1,2) )/det
       i3  = ( i(2,1)*a(2,1)-i(3,1)*a(1,1) )/det
       la  = SQRT(i1**2+i2**2+i3**2)
       l(1,k)  = i1/la
       l(2,k)  = i2/la
       l(3,k)  = i3/la
     ELSE
       ! Third option, use  the first and third equations
       a(1,1) = i(1,1) - lp(k)
       a(1,2) = i(1,3)
       a(2,1) = i(3,1)
       a(2,2) = i(3,3) - lp(k)
       det = a(1,1)*a(2,2) - a(1,2)*a(2,1)
       IF( ABS(det) > 1d-8)THEN
         i1  = (-i(1,2)*a(2,2)+i(3,2)*a(1,2) )/det
         i2  = 1d0
         i3  = ( i(1,2)*a(2,1)-i(3,2)*a(1,1) )/det
         la  = SQRT(i1**2+i2**2+i3**2)
         l(1,k)  = i1/la
         l(2,k)  = i2/la
         l(3,k)  = i3/la
       ELSE
         RETURN
       END IF
     END IF
   END IF
 END DO
 ! compute second direction using the vectorial product (det = 1)
 CALL vecpro(l(1,3),l(1,1),l(1,2))
 !Reorder directions to minimize rotations with respecto to input matrix LL
 ! select 1st direction
 pr(1) = DOT_PRODUCT(l(:,1),ll(:,1))     !cos 1-1
 pr(2) = DOT_PRODUCT(l(:,2),ll(:,1))     !cos 2-1
 pr(3) = DOT_PRODUCT(l(:,3),ll(:,1))     !cos 3-1
 lg = MAXLOC( ABS(pr) )           !direction with larger component along original X1 direction
 IF( lg(1) == 2 )THEN               !if it is the second
   lp =  (/  lp(2), lp(3), lp(1) /)                     !shift
   IF( pr(lg(1)) > 0d0 )THEN
     l  = RESHAPE((/ l(:,2),l(:,3),l(:,1) /),(/3,3/))
   ELSE
     l  =-RESHAPE((/ l(:,2),l(:,3),l(:,1) /),(/3,3/))
   END IF
 ELSE IF ( lg(1) == 3 )THEN         !if it is the third
   lp =         (/  lp(3), lp(1), lp(2) /)
   IF( pr(lg(1)) > 0d0 )THEN
     l  = RESHAPE((/ l(:,3),l(:,1),l(:,2) /),(/3,3/))
   ELSE
     l  =-RESHAPE((/ l(:,3),l(:,1),l(:,2) /),(/3,3/))
   END IF
 END IF
 ! select 2nd direction
 pr(2) = DOT_PRODUCT(l(:,2),ll(:,2))  !cos 2-2
 pr(3) = DOT_PRODUCT(l(:,3),ll(:,2))  !cos 3-2
 IF( ABS(pr(3)) > ABS(pr(2)) )THEN    !compare 2nd component of the 2-3 directions
   lp(2:3) =         (/   lp(3),  lp(2) /)          !swap if necessary
   IF( pr(3) > 0d0 )THEN
     l(:,2:3) = RESHAPE((/ l(:,3),-l(:,2) /),(/3,2/))
   ELSE
     l(:,2:3) = RESHAPE((/-l(:,3), l(:,2) /),(/3,2/))
   END IF
 END IF
 ! pass principal values
 i(1,1) = lp(1) + i13
 i(2,2) = lp(2) + i13
 i(3,3) = lp(3) + i13
 ll = l
 RETURN
 END SUBROUTINE princi


function boxmuller(n, m)
  real(4) :: n, m
  real(4) :: boxmuller
  real(4) :: pi = 3.14159265359

  boxmuller = sqrt(-2.0*log(n)) * cos(2.0*pi*m)
end function boxmuller

function normrand(mu, sigma)
  real(rk) :: mu, sigma
  real(rk) :: normrand

  normrand = boxmuller(rand(), rand()) * sigma + mu
end function normrand

! Monte Carlo fit
subroutine fitlinemc(xdata, ydata, n, sigma, a, b, sa, sb, ag, bg)
  real(rk), allocatable :: xdata(:)
  real(rk), allocatable :: ydata(:)
  real(rk), allocatable :: sigma(:)

  integer :: n, i, ii, sn
  real(rk) :: a, b, sa, sb
  real(rk) :: am, bm, pm
  real(rk) :: sq, sql, ra, rb, ag, bg

  a = ag
  b = bg
  sa = 0.0
  sb = 0.0
  sql = 100000000.0

  sn = 1
  am = 0.0
  bm = 0.0

  do ii = 1, 50000000
     sq = 0.0

     !ra = a + (rand() - 0.5) * a * 0.0001
     !rb = b + (rand() - 0.5) * b * 0.0001
     ra = normrand(a, sqrt(sa))
     rb = normrand(b, sqrt(sb))

     i = 1
     do while (i <= n)
        sq = sq + (normrand(ydata(i), sigma(i)) - (ra + rb * xdata(i)))**2 / (sigma(i)**2)
        i = i + 1
     end do

     if (sq < sql) then
        a = ra
        b = rb

        sn = sn + 1

        pm = am
        am = am + (a - am) / sn
        sa = sa + ((a - pm) * (a - am) - sa) / sn

        pm = bm
        bm = bm + (b - bm) / sn
        sb = sb + ((b - pm) * (b - bm) - sb) / sn

        sql = sq
     end if
  end do

  sa = sqrt(sa)
  sb = sqrt(sb)
end subroutine fitlinemc


      PROGRAM xpowell
C     driver for routine powell
      INTEGER NDIM
      REAL FTOL
      PARAMETER(NDIM=3,FTOL=1.0E-6)
      INTEGER i,iter,np
      REAL fret,p(NDIM),xi(NDIM,NDIM)
      np=NDIM
      DATA xi/1.0,0.0,0.0,0.0,1.0,0.0,0.0,0.0,1.0/
      DATA p/1.5,1.5,2.5/
      call powell(p,xi,NDIM,np,FTOL,iter,fret)
      write(*,'(/1x,a,i3)') 'Iterations:',iter
      write(*,'(/1x,a/1x,3f12.6)') 'Minimum found at: ',(p(i),i=1,NDIM)
      write(*,'(/1x,a,f12.6)') 'Minimum function value =',fret
      write(*,'(/1x,a)') 'True minimum of function is at:'
      write(*,'(1x,3f12.6/)') 1.0,2.0,3.0
      END
      REAL FUNCTION func(x)
      REAL bessj0,x(3)
      func=0.5-bessj0((x(1)-1.0)**2+(x(2)-2.0)**2+(x(3)-3.0)**2)
      END

NR-Functions/Numerical Recipes- Example & Functions/Examples/xpowell.for


module Mod_sldsup_calculateAU
  use typre
  implicit none

  contains

  subroutine getAU_S(nd,tn,mu,J,b,gdev,AU)
      integer(ip),          intent(in)    :: nd,tn
      real(rp),             intent(in)    :: mu,J,gdev(tn),b(nd,nd)
      real(rp),             intent(inout) :: AU(tn)
      real(rp)    :: i(tn),b_ii
      real(rp)    :: C(tn),bvoigt(tn)

      call get2ndIITensor_voigt(nd,tn,i)
      call trace(nd,b,b_ii)
      call getVoigtStress(tn,nd,b,bvoigt)

      !Stress tensor term: (b - (b_ll/nd)*i)_ij
      C = (bvoigt - (b_ii/nd)*i)

      !A(U): (J/2mu)*S_ij -0.5(b-(b_ll/nd)*i)_ij
      AU  = 0.5_rp*((J/mu)*gdev-C)

  end subroutine

  subroutine getAU_S_OSGS(nd,tn,mu,b,gdev,AU)
      integer(ip),          intent(in)    :: nd,tn
      real(rp),             intent(in)    :: mu,gdev(tn),b(nd,nd)
      real(rp),             intent(inout) :: AU(tn)
      real(rp)    :: i(tn),b_ii
      real(rp)    :: C(tn),bvoigt(tn)

      call get2ndIITensor_voigt(nd,tn,i)
      call trace(nd,b,b_ii)
      call getVoigtStress(tn,nd,b,bvoigt)

      !Stress tensor term: (b - (b_ll/nd)*i)_ij
      C = (bvoigt - (b_ii/nd)*i)

      !A(U): (J/2mu)*S_ij -0.5(b-(b_ll/nd)*i)_ij
      AU  = -0.5_rp*C

  end subroutine

  end module