program euler
  integer, dimension(:), allocatable :: fibs

  integer, dimension(:), allocatable :: updated_fibs

  integer sum, i

  allocate(fibs(2))

  fibs = (/0, 1/)

  do while (fibs(size(fibs)) + fibs(size(fibs) - 1) < 4000000)
    allocate(updated_fibs(size(fibs) + 1))

    updated_fibs(1:size(fibs)) = fibs

    updated_fibs(size(fibs) + 1) = fibs(size(fibs)) + fibs(size(fibs) - 1)

    deallocate(fibs)

    allocate(fibs(size(updated_fibs)))

    fibs = updated_fibs

    deallocate(updated_fibs)
  end do

  sum = 0

  do i = 1, size(fibs)
    if ((mod(fibs(i), 2) == 0)) then
      sum = sum + fibs(i)
    endif
  end do

  write(*, '(i7)') sum
end program euler


program Caesar_Cipher
  implicit none

  integer, parameter :: key = 3
  character(43) :: message = "The five boxing wizards jump quickly"

  write(*, "(2a)") "Original message  = ", message
  call encrypt(message)
  write(*, "(2a)") "Encrypted message = ", message
  call decrypt(message)
  write(*, "(2a)") "Decrypted message = ", message

contains

subroutine encrypt(text)
  character(*), intent(inout) :: text
  integer :: i

  do i = 1, len(text)
    select case(text(i:i))
      case ('A':'Z')
        text(i:i) = achar(modulo(iachar(text(i:i)) - 65 + key, 26) + 65)
      case ('a':'z')
        text(i:i) = achar(modulo(iachar(text(i:i)) - 97 + key, 26) + 97)
    end select
  end do
end subroutine

subroutine decrypt(text)
  character(*), intent(inout) :: text
  integer :: i

  do i = 1, len(text)
    select case(text(i:i))
      case ('A':'Z')
        text(i:i) = achar(modulo(iachar(text(i:i)) - 65 - key, 26) + 65)
      case ('a':'z')
        text(i:i) = achar(modulo(iachar(text(i:i)) - 97 - key, 26) + 97)
    end select
  end do
end subroutine

end program Caesar_Cipher


      DOUBLE PRECISION FUNCTION slDSEPV (V1, V2)
*+
*     - - - - - -
*      D S E P V
*     - - - - - -
*
*  Angle between two vectors.
*
*  (double precision)
*
*  Given:
*     V1      d(3)    first vector
*     V2      d(3)    second vector
*
*  The result is the angle, in radians, between the two vectors.  It
*  is always positive.
*
*  Notes:
*
*  1  There is no requirement for the vectors to be unit length.
*
*  2  If either vector is null, zero is returned.
*
*  3  The simplest formulation would use dot product alone.  However,
*     this would reduce the accuracy for angles near zero and pi.  The
*     algorithm uses both cross product and dot product, which maintains
*     accuracy for all sizes of angle.
*
*  Called:  slDVXV, slDVN, slDVDV
*
*  Last revision:   14 June 2005
*
*  Copyright P.T.Wallace.  All rights reserved.
*
*  License:
*    This program is free software; you can redistribute it and/or modify
*    it under the terms of the GNU General Public License as published by
*    the Free Software Foundation; either version 2 of the License, or
*    (at your option) any later version.
*
*    This program is distributed in the hope that it will be useful,
*    but WITHOUT ANY WARRANTY; without even the implied warranty of
*    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
*    GNU General Public License for more details.
*
*    You should have received a copy of the GNU General Public License
*    along with this program (see SLA_CONDITIONS); if not, write to the
*    Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
*    Boston, MA  02110-1301  USA
*
*  Copyright (C) 1995 Association of Universities for Research in Astronomy Inc.
*-

      IMPLICIT NONE

      DOUBLE PRECISION V1(3),V2(3)

      DOUBLE PRECISION V1XV2(3),WV(3),S,C
      DOUBLE PRECISION slDVDV

*  Modulus of cross product = sine multiplied by the two moduli.
      CALL slDVXV(V1,V2,V1XV2)
      CALL slDVN(V1XV2,WV,S)

*  Dot product = cosine multiplied by the two moduli.
      C = slDVDV(V1,V2)

*  Angle between the vectors.
      IF ( S.NE.0D0 .OR. C.NE.0D0 ) THEN
         slDSEPV = ATAN2(S,C)
      ELSE
         slDSEPV = 0D0
      END IF

      END


subroutine leapfrog(km, jm, im, afc, xinc, x, xold, x_out, xold_out)

! computes a leapfrog time step with Asselin filter of strength afc

implicit none

! In
integer, intent(in)   :: km, jm, im
!f2py intent(hide) km, jm, im
real(8)               :: afc
real(8), intent(in), dimension(km,jm,im) :: xinc, x, xold

!Out
real(8), intent(out), dimension(km,jm,im) :: x_out, xold_out

! Local
real, dimension(km,jm,im) :: xnew

! time step
xnew = xold + xinc

! Asselin filter
xold_out = x + afc*(xold + xnew - 2.*x)
!xold_out = xold

! update
x_out = xnew

end subroutine leapfrog

!--------------------------------------------------------------------------
subroutine asselin(km, jm, im, afc, xnew, x, xold, x_out, xold_out)

! Updates variables using Asselin filter of strength afc

integer, intent(in)                      :: km, jm, im
!f2py intent(in,hide) km,jm,im
real(8), intent(in)                      :: afc
real(8), intent(in), dimension(km,jm,im) :: xnew, x, xold
real(8), intent(out), dimension(km,jm,im) :: x_out, xold_out

! Asselin filter
xold_out = x + afc*(xold + xnew - 2.*x)

! update
x_out = xnew

end subroutine asselin


! Calculates the concordance index (C-index) between two series
! of event times. The first is the real survival times from
! the experimental data, and the other is the predicted survival
! times from a model of some kind.
!
! The concordance index is a value between 0 and 1 where,
! 0.5 is the expected result from random predictions,
! 1.0 is perfect concordance and,
! 0.0 is perfect anti-concordance (multiply predictions with -1 to get 1.0)
!
! Parameters:
!   event_times: a (nx1) array of observed survival times.
!   predicted_event_times: a (nx1) array of predicted survival times.
!   event_observed: a (nx1) array of censorship flags, 1 if observed,
!                   0 if not. Default assumes all observed.
function concordance_index (event_times, predictions, event_observed, rows) result(cindex)
  double precision :: cindex, paircount, csum
  integer, intent(in) :: rows
  double precision, dimension(rows), intent(in) :: event_times, predictions, event_observed
  double precision :: time_a, pred_a, event_a, time_b, pred_b, event_b
  integer :: a, b
  logical :: valid_pair

  ! Default values
  paircount = 0
  csum = 0
  cindex = 0

  do a=1, rows-1
    time_a = event_times(a)
    pred_a = predictions(a)
    event_a = event_observed(a)
    ! Start at a+1 to avoid double counting
    do b=a+1, rows
      time_b = event_times(b)
      pred_b = predictions(b)
      event_b = event_observed(b)

      ! Check if it's a valid comparison
      if (event_a == 1 .and. event_b == 1) then
        ! Two events can always be compared
        valid_pair = .true.
      else if (event_a == 1 .and. time_a < time_b) then
        ! If b is censored, then a must have event first
        valid_pair = .true.
      else if (event_b == 1 .and. time_b < time_a) then
        ! If a is censored, then b must have event first
        valid_pair = .true.
      else
        ! Not valid to compare this pair
        valid_pair = .false.
      end if

      if (valid_pair) then
        paircount = paircount + 1

        ! Check concordance
        if (pred_a == pred_b) then
          csum = csum + 0.5
        else if (time_a < time_b .and. pred_a < pred_b) then
          csum = csum + 1.0
        else if (time_b < time_a .and. pred_b < pred_a) then
          csum =csum + 1.0
        !else
        ! csum = csum + 0
        end if
      end if
    end do
  end do

  ! Calculate c-index.
  if (paircount > 0) then
    cindex = csum / paircount
  else
    cindex = 0.5
  end if

end function concordance_index


      PROGRAM xpolint
C     driver for routine polint
      INTEGER NP
      REAL PI
      PARAMETER(NP=10,PI=3.1415926)
      INTEGER i,n,nfunc
      REAL dy,f,x,y,xa(NP),ya(NP)
      write(*,*) 'Generation of interpolation tables'
      write(*,*) ' ... sin(x)    0<x<PI'
      write(*,*) ' ... exp(x)    0<x<1 '
      write(*,*) 'How many entries go in these tables? (note: N<10)'
      read(*,*) n
      do 14 nfunc=1,2
        if (nfunc.eq.1) then
          write(*,*) 'sine function from 0 to PI'
          do 11 i=1,n
            xa(i)=i*PI/n
            ya(i)=sin(xa(i))
11        continue
        else if (nfunc.eq.2) then
          write(*,*) 'exponential function from 0 to 1'
          do 12 i=1,n
            xa(i)=i*1.0/n
            ya(i)=exp(xa(i))
12        continue
        else
          stop
        endif
        write(*,'(t10,a1,t20,a4,t28,a12,t46,a5)')
     *       'x','f(x)','interpolated','error'
        do 13 i=1,10
          if (nfunc.eq.1) then
            x=(-0.05+i/10.0)*PI
            f=sin(x)
          else if (nfunc.eq.2) then
            x=(-0.05+i/10.0)
            f=exp(x)
          endif
          call polint(xa,ya,n,x,y,dy)
          write(*,'(1x,3f12.6,e15.4)') x,f,y,dy
13      continue
        write(*,*) '***********************************'
        write(*,*) 'Press RETURN'
        read(*,*)
14    continue
      END

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


	FUNCTION PR_THTE  ( pres, tmpc, dwpc )
C************************************************************************
C* PR_THTE								*
C*									*
C* This function computes THTE from PRES, TMPC, DWPC.  In the		*
C* calculation, MIXR depends on PRES and DWPC; TLCL depends on 		*
C* TMPC and DWPC.  The following equation is used:			*
C*									*
C*           THTE = THTAM * EXP [ ( 3.376/TLCL - .00254 ) *		*
C*                                ( MIXR * ( 1 + .81*.001*MIXR ) ) ]	*
C*									*
C*                THTAM = potential temperature of moist air		*
C*                      = TMPK * (1000 / PRES) ** E			*
C*                    E = RKAPPA * ( 1 - ( .28 * .001 * MIXR ) )	*
C*									*
C* Bolton.								*
C*									*
C* REAL PR_THTE  ( PRES, TMPC, DWPC )					*
C*									*
C* Input parameters:							*
C*	PRES   		REAL   		Pressure in millibars		*
C*	TMPC		REAL		Temperature in Celsius		*
C*	DWPC   		REAL		Dewpoint in Celsius		*
C*									*
C* Output parameters:							*
C*	PR_THTE		REAL   		Equivalent potential temp in K	*
C**									*
C* Log:									*
C* M. desJardins/GSFC	1983	Original source code			*
C* M. Goodman/RDS	3/84	Added PR_TMCK				*
C* I. Graffman/RDS	11/84 	changed .2854 to 2./7.			*
C* I. Graffman/RDS	12/87 	use GEMPAK4 constant file		*
C* G. Huffman/GSC       8/88    Documentation; check PRES .le. 0,	*
C*				missing RMIX				*
C************************************************************************
        INCLUDE   	'GEMPRM.PRM'
        INCLUDE   	'ERMISS.FNC'
C------------------------------------------------------------------------
C*      Check for missing values.
C
	IF  ( ERMISS ( pres ) .or. ERMISS ( tmpc ) .or.
     +	      ERMISS ( dwpc ) .or. ( pres .le. 0. ) )  THEN
	    PR_THTE = RMISSD
	  ELSE
C
C*	    Find mixing ratio; check for bad values.
C
	    rmix = PR_MIXR  ( dwpc, pres )
	    IF  ( ERMISS ( rmix ) )  THEN
		PR_THTE = RMISSD
		RETURN
	    END IF
C
C*	    Change degrees Celsius to Kelvin.
C
	    tmpk = PR_TMCK ( tmpc )
C
C*	    Calculate  THETA-M  (theta for moist air)
C
	    E = RKAPPA * (1. - (.28 * .001 * rmix) )
	    thtam = tmpk * (1000. / pres) ** e
C
C*	    Find the temperature at the LCL.
C
	    tlcl = PR_TLCL ( tmpc, dwpc )
	    e = ((3.376 /tlcl) - .00254) * (rmix * (1. + .81*.001*rmix))
	    PR_THTE = thtam * EXP (e)
	END IF
C*
	RETURN
	END


!================================================================================
! CONSTRUCCION DE UNA CONFIGURACION INICIAL ALEATORIA EN CELDA TRIDIMENSIONAL
! SIN TRASLAPES
! Autor: Martin Paredes Sosa
!================================================================================

Module cte
  Implicit None
  Real, Parameter :: sigma = 1.0
  Real :: Dens, BoxL
  Integer :: N
End Module cte

Program ConfigIni
  Use cte
  Implicit None
  Real :: Dim, xRan, yRan, zRan, xij, yij, zij, dist
  Real, Allocatable, Dimension(:) :: X,Y,Z  !POSICIONES DE LAS PARTICULAS
  Integer :: i, j                              !CONTADOR

  !PEDIR DENSIDAD Y NUMERO DE PARTICULAS
  Write(*,*) "INGRESE EL NUMERO DE PARTICULAS"
  Read(*,*) N
  Write(*,*) "INGRESE CONCENTRACION REDUCIDA"
  Read(*,*) Dens

  !CALCULANDO DIMENSIONES DE LA CAJA
  Dim = 1.0/3.0
  BoxL = (1.0*N/Dens )**Dim
  Write(*,*) "LONGITUD DE LA CELDA:", BoxL

  Allocate( X(n),Y(n),z(n) )
  Open (1, File = "PosPart.dat" )

  Colocar: Do i=1, N           !BUSCAR LA POSICION ALEATORIA PARA LAS PARTICULAS
  2  Call Random_Number(xRan)  !VALOR ALEATORIO DE POSICION X \
     Call Random_Number(yRan)  !VALOR ALEATORIO DE POSICION Y | TENTATIVO
     Call Random_Number(zRan)  !VALOR ALEATORIO DE POSICION Z /
     !Write(*,*) xRan, yRan, zRan   !DEBUG

     !COLOCAR DENTRO DE LA CELDA
     X(i) = (xRan-0.5)*(BoxL-1)                    !\
     Y(i) = (yRan-0.5)*(BoxL-1)                    !|   [-(BoxL-1)/2 , (BoxL-1)/2]
     Z(i) = (zRan-0.5)*(BoxL-1)                    !/
     !Write(*,*) X(i), Y(i), Z(i)               !DEBUG

     Traslape: Do j=1 , i-1

        xij = X(i) - X(j)              !CALCULANDO LA DISTANCIA ENTRE PARTICULAS
        yij = Y(i) - Y(j)
        zij = Z(i) - Z(j)
        !Write(*,*) i,j,xij, yij, zij !DEBUG
        dist = xij*xij + yij*yij + zij*zij
        DectTras: If(dist .LE. sigma ) Then
          !Write(*,*) "TRASLAPE", i, j  !DEBUG
          GO TO 2
        End If DectTras

     End Do Traslape

     Write(1,*) X(i), Y(i), Z(i) !GUARDANDO EN ARCHIVO LA POSICION

  End Do Colocar

  Deallocate(X,Y,Z)
  Close(1)

End Program ConfigIni


!> Module for physical/mathematical parameters
MODULE physical_params_mod
  USE kind_params_mod
  IMPLICIT none

  PUBLIC

  !> Pi =  4.0*ATAN(1.0)
  REAL(go_wp), save :: pi
  !> 2 x Pi
  REAL(go_wp), save :: tpi

contains

  subroutine physical_params_init
    implicit none

    pi = 4.0_go_wp*ATAN(1.0_go_wp)
    tpi = pi + pi

    write (*,*) 'PI set to: ',pi

  end subroutine physical_params_init

END MODULE physical_params_mod


      DOUBLE PRECISION FUNCTION sla_DSEPV (V1, V2)
*+
*     - - - - - -
*      D S E P V
*     - - - - - -
*
*  Angle between two vectors.
*
*  (double precision)
*
*  Given:
*     V1      d(3)    first vector
*     V2      d(3)    second vector
*
*  The result is the angle, in radians, between the two vectors.  It
*  is always positive.
*
*  Notes:
*
*  1  There is no requirement for the vectors to be unit length.
*
*  2  If either vector is null, zero is returned.
*
*  3  The simplest formulation would use dot product alone.  However,
*     this would reduce the accuracy for angles near zero and pi.  The
*     algorithm uses both cross product and dot product, which maintains
*     accuracy for all sizes of angle.
*
*  Called:  sla_DVXV, sla_DVN, sla_DVDV
*
*  Last revision:   7 May 2000
*
*  Copyright P.T.Wallace.  All rights reserved.
*
*  License:
*    This program is free software; you can redistribute it and/or modify
*    it under the terms of the GNU General Public License as published by
*    the Free Software Foundation; either version 2 of the License, or
*    (at your option) any later version.
*
*    This program is distributed in the hope that it will be useful,
*    but WITHOUT ANY WARRANTY; without even the implied warranty of
*    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
*    GNU General Public License for more details.
*
*    You should have received a copy of the GNU General Public License
*    along with this program (see SLA_CONDITIONS); if not, write to the
*    Free Software Foundation, Inc., 59 Temple Place, Suite 330,
*    Boston, MA  02111-1307  USA
*
*-

      IMPLICIT NONE

      DOUBLE PRECISION V1(3),V2(3)

      DOUBLE PRECISION V1XV2(3),WV(3),S,C
      DOUBLE PRECISION sla_DVDV

*  Modulus of cross product = sine multiplied by the two moduli.
      CALL sla_DVXV(V1,V2,V1XV2)
      CALL sla_DVN(V1XV2,WV,S)

*  Dot product = cosine multiplied by the two moduli.
      C = sla_DVDV(V1,V2)

*  Angle between the vectors.
      IF (S.NE.0D0) THEN
         sla_DSEPV = ATAN2(S,C)
      ELSE
         sla_DSEPV = 0D0
      END IF

      END


!Module for calculating the acceleration and the Velocity Verlet for objects. See Theory section of the report for details about the
!calculations.

module dynamics_mod
        use file_mod
contains
        !Acceleration calculation subroutine. Calculates acceleration according to Theory in report. Takes object as argument and
        !returns objects acceleration.
        type(vector) function get_acc(obj)
                implicit none
                integer::i
                type(vector)::r,F
                type(object),target,intent(inout)::obj
                F=vector(0,0,0)

                !Go through and sum all the gravitational forces effecting the given object
                do i=1, size(system)
                       !If-condition to avoid calculating gravity caused by the given object (division by zero)
                       if(obj%description.ne.system(i)%description) then
                               r=system(i)%pos-obj%pos
                               F=F+r*(G*obj%mass*system(i)%mass/vectorlen(r)**3)
                       end if
                end do

                !Acceration
                get_acc=F/obj%mass
        end function get_acc
        !Subroutine for the Velocity Verlet
        subroutine update_sys()
                !Variables _temp are used to calculate and store temporary values.
                implicit none
                integer::i
                type(vector)::pos_temp,vel_temp,acc_temp
                real(rk)::dt

                !Time step from input instructions
                dt=instr(1)

                !Go through all the objects in the system and calculate the VV for them.
                do i=1, size(system)
                        pos_temp=system(i)%pos+system(i)%vel*dt+system(i)%acc*(dt*dt*0.5)
                        acc_temp=get_acc(system(i))
                        vel_temp=system(i)%vel+(system(i)%acc+acc_temp)*(dt*0.5)
                        system(i)%pos=pos_temp
                        system(i)%vel=vel_temp
                        system(i)%acc=acc_temp
                end do
        end subroutine update_sys
end module


      SUBROUTINE vectorize(mag, angle, x, y, npts)
C     Given magnitude and angle in degrees, compute x and y equivalents.
C     Robert Grumbine 5 April 1994.
C     LAST MODIFIED 8 April 1994.

      IMPLICIT none

      INTEGER npts
      REAL mag(npts), angle(npts), x(npts), y(npts)

      INTEGER i
      REAL pi, rpdg

      pi = ATAN(1.)*4.
      rpdg = pi / 180.
      DO i = 1, npts
        x(i) = mag(i)*COS(rpdg*angle(i))
        y(i) = mag(i)*SIN(rpdg*angle(i))
      ENDDO

      RETURN
      END


      double precision function drandsc(ix)

C     This is the random number generator of Schrage:
C     L. Schrage, A more portable Fortran random number generator, ACM
C     Transactions on Mathematical Software 5 (1979), 132-138.

      double precision ix
      double precision a,p,b15,b16,xhi,xalo,leftlo,fhi,k
      data a/16807.d0/,b15/32768.d0/,b16/65536.d0/,p/2147483647.d0/

      xhi= ix/b16

      xhi= xhi - dmod(xhi,1.d0)

      xalo= (ix-xhi*b16)*a

      leftlo= xalo/b16

      leftlo= leftlo - dmod(leftlo,1.d0)

      fhi= xhi*a + leftlo

      k= fhi/b15

      k= k - dmod(k,1.d0)

      ix= (((xalo-leftlo*b16)-p)+(fhi-k*b15)*b16)+k

      if (ix.lt.0) ix= ix + p

      drandsc= ix*4.656612875d-10

      return

      end


program P14583
    implicit none
    real(8) :: h, v, t, width, height
    read *, h, v
    t = atan2(v, h) / 2
    width = h / cos(t) / 2
    height = sqrt(h * h + v * v) * sin(t)
    write (*, '(F0.2)') width, height
end program P14583


SUBROUTINE vecpro(v1,v2,v3)
!*****************************************************************************
!
!**** tridimensional vectorial product of two vectors  v1 x v2 -> v3
!
!*****************************************************************************
IMPLICIT NONE

  !--- Dummy variables
  REAL(kind=8),INTENT(IN) :: v1(3), v2(3)
  REAL(kind=8),INTENT(OUT):: v3(3)

  v3(1) = v1(2)*v2(3) - v1(3)*v2(2)   !First component of vectorial product
  v3(2) = v1(3)*v2(1) - v1(1)*v2(3)   !Second component of vectorial product
  v3(3) = v1(1)*v2(2) - v1(2)*v2(1)   !Third component of vectorial product

RETURN
END SUBROUTINE vecpro


! **********************************************
!  August 1, 2012
! **********************************************
!
! This subroutine computes three residuals for each computed root, lambda,
! of a polynomial P(x). It is also capable of applying an arbitrary number
! of Newton iterations to each computed root.
!
! The residuals are |P(lambda)/P'(lambda)|, |P(lambda)/P'(lambda)/lambda|, and
! ||Cv-lambda v||/||C||/||v||, in the inifinity norm where C is the Companion Matrix
! and v is the eigenvectro associated with lambda.
!
! **************************************************************
!
! Input variables:
!
! POLY         complex array of length DEGREE, containing the nonleading
!              coefficients of P (ordered with decreasing degree)
!
! DEGREE       degree of polynomial
!
!
! ROOTS        complex array of length DEGREE, containing the roots
!              of Poly
!
! NEWTNUM      a non-negative integer specifying the number of Newton iterations
!              zero is acceptable.
!
! Output variables:
!
! RESIDUALS    double precision array of dimension (DEGREE,3*(NEWTNUM+1)).
!	       each row of RESIDUALS corresponds to one root of POLY.
!	       columns are in sets of three, with the columns 1, 2 and 3 corresponding
!	       to the three residuals mentioned above respectively. Every set of three
!              columns corresponds to a Newton iteration except for the first one.
!
! ***************************************************************

subroutine rescheck(degree,poly,roots,newtnum,residuals)

	implicit none

	integer, intent(in) :: degree,newtnum
	complex(kind(1d0)), intent(in) :: poly(degree)
	double precision, intent(inout) :: residuals(degree,3*(newtnum+1))
	complex(kind(1d0)), intent(inout) :: roots(degree)

	integer ii,jj,kk
	double precision :: Cnorm
	complex(kind(1d0)) :: f, fprime, lambda

	! Matrix infinity norms
	Cnorm = 0d0
	do ii=1,degree
		Cnorm = Cnorm + abs(poly(ii))
	end do

	Cnorm = max(1d0,Cnorm)

	! Function evaluations and Newton Corrections
	do ii=1,degree

		! Roots inside or on the unit circle
		if(abs(roots(ii)) <= 1d0)then
		do jj=1,(newtnum+1)
			! function evals
			lambda = roots(ii)
			f = lambda + poly(1)
			fprime = complex(dble(degree),0d0)*f - poly(1)
			do kk=2,(degree-1)
				f = lambda*f + poly(kk)
				fprime = lambda*fprime + complex(dble(degree-kk),0d0)*poly(kk)
			end do
			f = f*lambda + poly(degree)

			! Store residuals
			residuals(ii,3*(jj-1)+1) = abs(f/fprime)
			residuals(ii,3*(jj-1)+2) = abs(f/fprime/lambda)
			residuals(ii,3*(jj-1)+3) = abs(f)/Cnorm

			! Newton correction
			if((newtnum+1-jj) > 0)then
				lambda = lambda - f/fprime
				roots(ii) = lambda
			end if
		end do

		! Roots outside the unit circle
		else
		do jj=1,(newtnum+1)
			! function evals
			lambda = complex(1d0,0d0)/roots(ii)
			f = poly(degree)*lambda + poly(degree-1)
			fprime = complex(dble(degree),0d0)*f - poly(degree-1)
			do kk=2,(degree-1)
				f = lambda*f + poly(degree-kk)
				fprime = lambda*fprime + complex(dble(degree-kk),0d0)*poly(degree-kk)
			end do
			f = f*lambda + complex(1d0,0d0)

			! Store residuals
			residuals(ii,3*(jj-1)+1) = abs(f/fprime*roots(ii)*roots(ii))
			residuals(ii,3*(jj-1)+2) = abs(f/fprime*roots(ii))
			residuals(ii,3*(jj-1)+3) = abs(f)*roots(ii)/Cnorm

			! Newton correction
			if((newtnum+1-jj) > 0)then
				lambda = lambda - f/fprime
				roots(ii) = complex(1d0,0d0)/lambda
			end if
		end do
		end if

	end do

end subroutine


      DOUBLE PRECISION FUNCTION CHEVAL(N,A,T)
C
C   This function evaluates a Chebyshev series, using the
C   Clenshaw method with Reinsch modification, as analysed
C   in the paper by Oliver.
C
C   INPUT PARAMETERS
C
C       N - INTEGER - The no. of terms in the sequence
C
C       A - DOUBLE PRECISION ARRAY, dimension 0 to N - The coefficients of
C           the Chebyshev series
C
C       T - DOUBLE PRECISION - The value at which the series is to be
C           evaluated
C
C
C   REFERENCES
C
C        "An error analysis of the modified Clenshaw method for
C         evaluating Chebyshev and Fourier series" J. Oliver,
C         J.I.M.A., vol. 20, 1977, pp379-391
C
C
C MACHINE-DEPENDENT CONSTANTS: NONE
C
C
C INTRINSIC FUNCTIONS USED;
C
C    ABS
C
C
C AUTHOR:  Dr. Allan J. MacLeod,
C          Dept. of Mathematics and Statistics,
C          University of Paisley ,
C          High St.,
C          PAISLEY,
C          SCOTLAND
C
C
C LATEST MODIFICATION:   21 December , 1992
C
C
      INTEGER I,N
      DOUBLE PRECISION A(0:N),D1,D2,HALF,T,TEST,TT,TWO,U0,U1,U2,ZERO
      INTRINSIC ABS
      DATA ZERO,HALF/ 0.0 D 0 , 0.5 D 0 /
      DATA TEST,TWO/ 0.6 D 0 , 2.0 D 0 /
      U1 = ZERO
C
C   If ABS ( T )  < 0.6 use the standard Clenshaw method
C
      IF ( ABS( T ) .LT. TEST ) THEN
         U0 = ZERO
         TT = T + T
         DO 100 I = N , 0 , -1
            U2 = U1
            U1 = U0
            U0 = TT * U1 + A( I ) - U2
 100     CONTINUE
         CHEVAL =  ( U0 - U2 ) / TWO
      ELSE
C
C   If ABS ( T )  > =  0.6 use the Reinsch modification
C
         D1 = ZERO
C
C   T > =  0.6 code
C
         IF ( T .GT. ZERO ) THEN
            TT =  ( T - HALF ) - HALF
            TT = TT + TT
            DO 200 I = N , 0 , -1
               D2 = D1
               U2 = U1
               D1 = TT * U2 + A( I ) + D2
               U1 = D1 + U2
 200        CONTINUE
            CHEVAL =  ( D1 + D2 ) / TWO
         ELSE
C
C   T < =  -0.6 code
C
            TT =  ( T + HALF ) + HALF
            TT = TT + TT
            DO 300 I = N , 0 , -1
               D2 = D1
               U2 = U1
               D1 = TT * U2 + A( I ) - D2
               U1 = D1 - U2
 300        CONTINUE
            CHEVAL =  ( D1 - D2 ) / TWO
         ENDIF
      ENDIF
      RETURN
      END


*DECK HWSCYL
      SUBROUTINE HWSCYL (A, B, M, MBDCND, BDA, BDB, C, D, N, NBDCND,
     +   BDC, BDD, ELMBDA, F, IDIMF, PERTRB, IERROR, W)
C***BEGIN PROLOGUE  HWSCYL
C***PURPOSE  Solve a standard finite difference approximation
C            to the Helmholtz equation in cylindrical coordinates.
C***LIBRARY   SLATEC (FISHPACK)
C***CATEGORY  I2B1A1A
C***TYPE      SINGLE PRECISION (HWSCYL-S)
C***KEYWORDS  CYLINDRICAL, ELLIPTIC, FISHPACK, HELMHOLTZ, PDE
C***AUTHOR  Adams, J., (NCAR)
C           Swarztrauber, P. N., (NCAR)
C           Sweet, R., (NCAR)
C***DESCRIPTION
C
C     Subroutine HWSCYL solves a finite difference approximation to the
C     Helmholtz equation in cylindrical coordinates:
C
C          (1/R)(d/dR)(R(dU/dR)) + (d/dZ)(dU/dZ)
C
C                                + (LAMBDA/R**2)U = F(R,Z)
C
C     This modified Helmholtz equation results from the Fourier
C     transform of the three-dimensional Poisson equation.
C
C     * * * * * * * *    Parameter Description     * * * * * * * * * *
C
C             * * * * * *   On Input    * * * * * *
C
C     A,B
C       The range of R, i.e., A .LE. R .LE. B.  A must be less than B
C       and A must be non-negative.
C
C     M
C       The number of panels into which the interval (A,B) is
C       subdivided.  Hence, there will be M+1 grid points in the
C       R-direction given by R(I) = A+(I-1)DR, for I = 1,2,...,M+1,
C       where DR = (B-A)/M is the panel width. M must be greater than 3.
C
C     MBDCND
C       Indicates the type of boundary conditions at R = A and R = B.
C
C       = 1  If the solution is specified at R = A and R = B.
C       = 2  If the solution is specified at R = A and the derivative of
C            the solution with respect to R is specified at R = B.
C       = 3  If the derivative of the solution with respect to R is
C            specified at R = A (see note below) and R = B.
C       = 4  If the derivative of the solution with respect to R is
C            specified at R = A (see note below) and the solution is
C            specified at R = B.
C       = 5  If the solution is unspecified at R = A = 0 and the
C            solution is specified at R = B.
C       = 6  If the solution is unspecified at R = A = 0 and the
C            derivative of the solution with respect to R is specified
C            at R = B.
C
C       NOTE:  If A = 0, do not use MBDCND = 3 or 4, but instead use
C              MBDCND = 1,2,5, or 6  .
C
C     BDA
C       A one-dimensional array of length N+1 that specifies the values
C       of the derivative of the solution with respect to R at R = A.
C       When MBDCND = 3 or 4,
C
C            BDA(J) = (d/dR)U(A,Z(J)), J = 1,2,...,N+1  .
C
C       When MBDCND has any other value, BDA is a dummy variable.
C
C     BDB
C       A one-dimensional array of length N+1 that specifies the values
C       of the derivative of the solution with respect to R at R = B.
C       When MBDCND = 2,3, or 6,
C
C            BDB(J) = (d/dR)U(B,Z(J)), J = 1,2,...,N+1  .
C
C       When MBDCND has any other value, BDB is a dummy variable.
C
C     C,D
C       The range of Z, i.e., C .LE. Z .LE. D.  C must be less than D.
C
C     N
C       The number of panels into which the interval (C,D) is
C       subdivided.  Hence, there will be N+1 grid points in the
C       Z-direction given by Z(J) = C+(J-1)DZ, for J = 1,2,...,N+1,
C       where DZ = (D-C)/N is the panel width. N must be greater than 3.
C
C     NBDCND
C       Indicates the type of boundary conditions at Z = C and Z = D.
C
C       = 0  If the solution is periodic in Z, i.e., U(I,1) = U(I,N+1).
C       = 1  If the solution is specified at Z = C and Z = D.
C       = 2  If the solution is specified at Z = C and the derivative of
C            the solution with respect to Z is specified at Z = D.
C       = 3  If the derivative of the solution with respect to Z is
C            specified at Z = C and Z = D.
C       = 4  If the derivative of the solution with respect to Z is
C            specified at Z = C and the solution is specified at Z = D.
C
C     BDC
C       A one-dimensional array of length M+1 that specifies the values
C       of the derivative of the solution with respect to Z at Z = C.
C       When NBDCND = 3 or 4,
C
C            BDC(I) = (d/dZ)U(R(I),C), I = 1,2,...,M+1  .
C
C       When NBDCND has any other value, BDC is a dummy variable.
C
C     BDD
C       A one-dimensional array of length M+1 that specifies the values
C       of the derivative of the solution with respect to Z at Z = D.
C       When NBDCND = 2 or 3,
C
C            BDD(I) = (d/dZ)U(R(I),D), I = 1,2,...,M+1  .
C
C       When NBDCND has any other value, BDD is a dummy variable.
C
C     ELMBDA
C       The constant LAMBDA in the Helmholtz equation.  If
C       LAMBDA .GT. 0, a solution may not exist.  However, HWSCYL will
C       attempt to find a solution.  LAMBDA must be zero when
C       MBDCND = 5 or 6  .
C
C     F
C       A two-dimensional array that specifies the values of the right
C       side of the Helmholtz equation and boundary data (if any).  For
C       I = 2,3,...,M and J = 2,3,...,N
C
C            F(I,J) = F(R(I),Z(J)).
C
C       On the boundaries F is defined by
C
C            MBDCND   F(1,J)            F(M+1,J)
C            ------   ---------         ---------
C
C              1      U(A,Z(J))         U(B,Z(J))
C              2      U(A,Z(J))         F(B,Z(J))
C              3      F(A,Z(J))         F(B,Z(J))   J = 1,2,...,N+1
C              4      F(A,Z(J))         U(B,Z(J))
C              5      F(0,Z(J))         U(B,Z(J))
C              6      F(0,Z(J))         F(B,Z(J))
C
C            NBDCND   F(I,1)            F(I,N+1)
C            ------   ---------         ---------
C
C              0      F(R(I),C)         F(R(I),C)
C              1      U(R(I),C)         U(R(I),D)
C              2      U(R(I),C)         F(R(I),D)   I = 1,2,...,M+1
C              3      F(R(I),C)         F(R(I),D)
C              4      F(R(I),C)         U(R(I),D)
C
C       F must be dimensioned at least (M+1)*(N+1).
C
C       NOTE
C
C       If the table calls for both the solution U and the right side F
C       at a corner then the solution must be specified.
C
C     IDIMF
C       The row (or first) dimension of the array F as it appears in the
C       program calling HWSCYL.  This parameter is used to specify the
C       variable dimension of F.  IDIMF must be at least M+1  .
C
C     W
C       A one-dimensional array that must be provided by the user for
C       work space.  W may require up to 4*(N+1) +
C       (13 + INT(log2(N+1)))*(M+1) locations.  The actual number of
C       locations used is computed by HWSCYL and is returned in location
C       W(1).
C
C
C             * * * * * *   On Output     * * * * * *
C
C     F
C       Contains the solution U(I,J) of the finite difference
C       approximation for the grid point (R(I),Z(J)), I = 1,2,...,M+1,
C       J = 1,2,...,N+1  .
C
C     PERTRB
C       If one specifies a combination of periodic, derivative, and
C       unspecified boundary conditions for a Poisson equation
C       (LAMBDA = 0), a solution may not exist.  PERTRB is a constant,
C       calculated and subtracted from F, which ensures that a solution
C       exists.  HWSCYL then computes this solution, which is a least
C       squares solution to the original approximation.  This solution
C       plus any constant is also a solution.  Hence, the solution is
C       not unique.  The value of PERTRB should be small compared to the
C       right side F.  Otherwise, a solution is obtained to an
C       essentially different problem.  This comparison should always
C       be made to insure that a meaningful solution has been obtained.
C
C     IERROR
C       An error flag which indicates invalid input parameters.  Except
C       for numbers 0 and 11, a solution is not attempted.
C
C       =  0  No error.
C       =  1  A .LT. 0  .
C       =  2  A .GE. B.
C       =  3  MBDCND .LT. 1 or MBDCND .GT. 6  .
C       =  4  C .GE. D.
C       =  5  N .LE. 3
C       =  6  NBDCND .LT. 0 or NBDCND .GT. 4  .
C       =  7  A = 0, MBDCND = 3 or 4  .
C       =  8  A .GT. 0, MBDCND .GE. 5  .
C       =  9  A = 0, LAMBDA .NE. 0, MBDCND .GE. 5  .
C       = 10  IDIMF .LT. M+1  .
C       = 11  LAMBDA .GT. 0  .
C       = 12  M .LE. 3
C
C       Since this is the only means of indicating a possibly incorrect
C       call to HWSCYL, the user should test IERROR after the call.
C
C     W
C       W(1) contains the required length of W.
C
C *Long Description:
C
C     * * * * * * *   Program Specifications    * * * * * * * * * * * *
C
C     Dimension of   BDA(N+1),BDB(N+1),BDC(M+1),BDD(M+1),F(IDIMF,N+1),
C     Arguments      W(see argument list)
C
C     Latest         June 1, 1976
C     Revision
C
C     Subprograms    HWSCYL,GENBUN,POISD2,POISN2,POISP2,COSGEN,MERGE,
C     Required       TRIX,TRI3,PIMACH
C
C     Special        NONE
C     Conditions
C
C     Common         NONE
C     Blocks
C
C     I/O            NONE
C
C     Precision      Single
C
C     Specialist     Roland Sweet
C
C     Language       FORTRAN
C
C     History        Standardized September 1, 1973
C                    Revised April 1, 1976
C
C     Algorithm      The routine defines the finite difference
C                    equations, incorporates boundary data, and adjusts
C                    the right side of singular systems and then calls
C                    GENBUN to solve the system.
C
C     Space          5818(decimal) = 13272(octal) locations on the NCAR
C     Required       Control Data 7600
C
C     Timing and        The execution time T on the NCAR Control Data
C     Accuracy       7600 for subroutine HWSCYL is roughly proportional
C                    to M*N*log2(N), but also depends on the input
C                    parameters NBDCND and MBDCND.  Some typical values
C                    are listed in the table below.
C                       The solution process employed results in a loss
C                    of no more than three significant digits for N and
C                    M as large as 64.  More detailed information about
C                    accuracy can be found in the documentation for
C                    subroutine GENBUN which is the routine that
C                    solves the finite difference equations.
C
C
C                       M(=N)    MBDCND    NBDCND    T(MSECS)
C                       -----    ------    ------    --------
C
C                        32        1         0          31
C                        32        1         1          23
C                        32        3         3          36
C                        64        1         0         128
C                        64        1         1          96
C                        64        3         3         142
C
C     Portability    American National Standards Institute FORTRAN.
C                    The machine dependent constant PI is defined in
C                    function PIMACH.
C
C     Required       COS
C     Resident
C     Routines
C
C     Reference      Swarztrauber, P. and R. Sweet, 'Efficient FORTRAN
C                    Subprograms for the Solution of Elliptic Equations'
C                    NCAR TN/IA-109, July, 1975, 138 pp.
C
C     * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
C
C***REFERENCES  P. N. Swarztrauber and R. Sweet, Efficient Fortran
C                 subprograms for the solution of elliptic equations,
C                 NCAR TN/IA-109, July 1975, 138 pp.
C***ROUTINES CALLED  GENBUN
C***REVISION HISTORY  (YYMMDD)
C   801001  DATE WRITTEN
C   890531  Changed all specific intrinsics to generic.  (WRB)
C   890531  REVISION DATE from Version 3.2
C   891214  Prologue converted to Version 4.0 format.  (BAB)
C   920501  Reformatted the REFERENCES section.  (WRB)
C***END PROLOGUE  HWSCYL
C
C
      DIMENSION       F(IDIMF,*)
      DIMENSION       BDA(*)     ,BDB(*)     ,BDC(*)     ,BDD(*)     ,
     1                W(*)
C***FIRST EXECUTABLE STATEMENT  HWSCYL
      IERROR = 0
      IF (A .LT. 0.) IERROR = 1
      IF (A .GE. B) IERROR = 2
      IF (MBDCND.LE.0 .OR. MBDCND.GE.7) IERROR = 3
      IF (C .GE. D) IERROR = 4
      IF (N .LE. 3) IERROR = 5
      IF (NBDCND.LE.-1 .OR. NBDCND.GE.5) IERROR = 6
      IF (A.EQ.0. .AND. (MBDCND.EQ.3 .OR. MBDCND.EQ.4)) IERROR = 7
      IF (A.GT.0. .AND. MBDCND.GE.5) IERROR = 8
      IF (A.EQ.0. .AND. ELMBDA.NE.0. .AND. MBDCND.GE.5) IERROR = 9
      IF (IDIMF .LT. M+1) IERROR = 10
      IF (M .LE. 3) IERROR = 12
      IF (IERROR .NE. 0) RETURN
      MP1 = M+1
      DELTAR = (B-A)/M
      DLRBY2 = DELTAR/2.
      DLRSQ = DELTAR**2
      NP1 = N+1
      DELTHT = (D-C)/N
      DLTHSQ = DELTHT**2
      NP = NBDCND+1
C
C     DEFINE RANGE OF INDICES I AND J FOR UNKNOWNS U(I,J).
C
      MSTART = 2
      MSTOP = M
      GO TO (104,103,102,101,101,102),MBDCND
  101 MSTART = 1
      GO TO 104
  102 MSTART = 1
  103 MSTOP = MP1
  104 MUNK = MSTOP-MSTART+1
      NSTART = 1
      NSTOP = N
      GO TO (108,105,106,107,108),NP
  105 NSTART = 2
      GO TO 108
  106 NSTART = 2
  107 NSTOP = NP1
  108 NUNK = NSTOP-NSTART+1
C
C     DEFINE A,B,C COEFFICIENTS IN W-ARRAY.
C
      ID2 = MUNK
      ID3 = ID2+MUNK
      ID4 = ID3+MUNK
      ID5 = ID4+MUNK
      ID6 = ID5+MUNK
      ISTART = 1
      A1 = 2./DLRSQ
      IJ = 0
      IF (MBDCND.EQ.3 .OR. MBDCND.EQ.4) IJ = 1
      IF (MBDCND .LE. 4) GO TO 109
      W(1) = 0.
      W(ID2+1) = -2.*A1
      W(ID3+1) = 2.*A1
      ISTART = 2
      IJ = 1
  109 DO 110 I=ISTART,MUNK
         R = A+(I-IJ)*DELTAR
         J = ID5+I
         W(J) = R
         J = ID6+I
         W(J) = 1./R**2
         W(I) = (R-DLRBY2)/(R*DLRSQ)
         J = ID3+I
         W(J) = (R+DLRBY2)/(R*DLRSQ)
         K = ID6+I
         J = ID2+I
         W(J) = -A1+ELMBDA*W(K)
  110 CONTINUE
      GO TO (114,111,112,113,114,112),MBDCND
  111 W(ID2) = A1
      GO TO 114
  112 W(ID2) = A1
  113 W(ID3+1) = A1*ISTART
  114 CONTINUE
C
C     ENTER BOUNDARY DATA FOR R-BOUNDARIES.
C
      GO TO (115,115,117,117,119,119),MBDCND
  115 A1 = W(1)
      DO 116 J=NSTART,NSTOP
         F(2,J) = F(2,J)-A1*F(1,J)
  116 CONTINUE
      GO TO 119
  117 A1 = 2.*DELTAR*W(1)
      DO 118 J=NSTART,NSTOP
         F(1,J) = F(1,J)+A1*BDA(J)
  118 CONTINUE
  119 GO TO (120,122,122,120,120,122),MBDCND
  120 A1 = W(ID4)
      DO 121 J=NSTART,NSTOP
         F(M,J) = F(M,J)-A1*F(MP1,J)
  121 CONTINUE
      GO TO 124
  122 A1 = 2.*DELTAR*W(ID4)
      DO 123 J=NSTART,NSTOP
         F(MP1,J) = F(MP1,J)-A1*BDB(J)
  123 CONTINUE
C
C     ENTER BOUNDARY DATA FOR Z-BOUNDARIES.
C
  124 A1 = 1./DLTHSQ
      L = ID5-MSTART+1
      GO TO (134,125,125,127,127),NP
  125 DO 126 I=MSTART,MSTOP
         F(I,2) = F(I,2)-A1*F(I,1)
  126 CONTINUE
      GO TO 129
  127 A1 = 2./DELTHT
      DO 128 I=MSTART,MSTOP
         F(I,1) = F(I,1)+A1*BDC(I)
  128 CONTINUE
  129 A1 = 1./DLTHSQ
      GO TO (134,130,132,132,130),NP
  130 DO 131 I=MSTART,MSTOP
         F(I,N) = F(I,N)-A1*F(I,NP1)
  131 CONTINUE
      GO TO 134
  132 A1 = 2./DELTHT
      DO 133 I=MSTART,MSTOP
         F(I,NP1) = F(I,NP1)-A1*BDD(I)
  133 CONTINUE
  134 CONTINUE
C
C     ADJUST RIGHT SIDE OF SINGULAR PROBLEMS TO INSURE EXISTENCE OF A
C     SOLUTION.
C
      PERTRB = 0.
      IF (ELMBDA) 146,136,135
  135 IERROR = 11
      GO TO 146
  136 W(ID5+1) = .5*(W(ID5+2)-DLRBY2)
      GO TO (146,146,138,146,146,137),MBDCND
  137 W(ID5+1) = .5*W(ID5+1)
  138 GO TO (140,146,146,139,146),NP
  139 A2 = 2.
      GO TO 141
  140 A2 = 1.
  141 K = ID5+MUNK
      W(K) = .5*(W(K-1)+DLRBY2)
      S = 0.
      DO 143 I=MSTART,MSTOP
         S1 = 0.
         NSP1 = NSTART+1
         NSTM1 = NSTOP-1
         DO 142 J=NSP1,NSTM1
            S1 = S1+F(I,J)
  142    CONTINUE
         K = I+L
         S = S+(A2*S1+F(I,NSTART)+F(I,NSTOP))*W(K)
  143 CONTINUE
      S2 = M*A+(.75+(M-1)*(M+1))*DLRBY2
      IF (MBDCND .EQ. 3) S2 = S2+.25*DLRBY2
      S1 = (2.+A2*(NUNK-2))*S2
      PERTRB = S/S1
      DO 145 I=MSTART,MSTOP
         DO 144 J=NSTART,NSTOP
            F(I,J) = F(I,J)-PERTRB
  144    CONTINUE
  145 CONTINUE
  146 CONTINUE
C
C     MULTIPLY I-TH EQUATION THROUGH BY DELTHT**2 TO PUT EQUATION INTO
C     CORRECT FORM FOR SUBROUTINE GENBUN.
C
      DO 148 I=MSTART,MSTOP
         K = I-MSTART+1
         W(K) = W(K)*DLTHSQ
         J = ID2+K
         W(J) = W(J)*DLTHSQ
         J = ID3+K
         W(J) = W(J)*DLTHSQ
         DO 147 J=NSTART,NSTOP
            F(I,J) = F(I,J)*DLTHSQ
  147    CONTINUE
  148 CONTINUE
      W(1) = 0.
      W(ID4) = 0.
C
C     CALL GENBUN TO SOLVE THE SYSTEM OF EQUATIONS.
C
      CALL GENBUN (NBDCND,NUNK,1,MUNK,W(1),W(ID2+1),W(ID3+1),IDIMF,
     1             F(MSTART,NSTART),IERR1,W(ID4+1))
      W(1) = W(ID4+1)+3*MUNK
      IF (NBDCND .NE. 0) GO TO 150
      DO 149 I=MSTART,MSTOP
         F(I,NP1) = F(I,1)
  149 CONTINUE
  150 CONTINUE
      RETURN
      END


!
!     CalculiX - A 3-dimensional finite element program
!     Copyright (C) 1998-2020 Guido Dhondt
!
!     This program is free software; you can redistribute it and/or
!     modify it under the terms of the GNU General Public License as
!     published by the Free Software Foundation(version 2);
!
!
!     This program is distributed in the hope that it will be useful,
!     but WITHOUT ANY WARRANTY; without even the implied warranty of
!     MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
!     GNU General Public License for more details.
!
!     You should have received a copy of the GNU General Public License
!     along with this program; if not, write to the Free Software
!     Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
!
C
C  1.TASK          INTERPOLATION OF A TWO DIMENSIONAL FUNCTION DEFINED POINT BY POINT
C  *********       THE X COORDINATES ARE USER SPECIFIED.
c                  THE INTERPOLATION TYPE CAN BE INDEPENDANTLY CHOSEN IN THE TWO DIRECTIONS
C                  EITHER CONSTANT, LINEAR OR DOUBLE QUADRATIC.
C                  BEYOND THE FIELD OF INTERPOLATION AN EXTRAOLATION IS CARRIED OUT.
C                  FOR ALL FOUR EXTRAPOLATION DIRECTIONS DIFFERENT EXTRAPOLATION METHOD
C                 (C ONSTANT,LINEAR,QUADRATIC) CAN BE CHOSEN, WHICH ORDER MUST NOT BE HIGHER
C                  THAN THE IONTERPOLATION ORDER
C
C  2.UP-AUFRUF     CALL TWODINT(T,LSP,IART,XA,YA,ZA,NA,IEXP,IER)
C  ***********                 T = MATRIX OF THE SAMPLE POINTS FORMATED AS FOLLOW
C                                  T(1,1) = NX + NY * 0.001
C                                         NX = NUMBER OF LINES T
C                                         NY = NUMBER OF COLUMNS T
C                                  T(1,2) ... T(1,NY)
C                                        VECTOR OF THE Y COORDINATES OF THE T MATRIX
C                                  T(2,1) ... T(NX,1)
C                                         VECTOR OF THE X COORDINATES OF THE T MATRIX
C                                  REST  OF T-MATRIX:
C                                          POINT(X,Y) OF THE T MATRIX
C
C                              LSP  = COLUMN STEPOF  T
C                              IART = TYPE OF INTERPOLATION
C                                     IART = INTX * 10 + INTY
C                                     INTX INTERPOLATION TYPE IN X-DIRECTION
C                                     INTY INTERPOLATION TYPE IN Y-DIRECTION
C                              XA = VECTOR OF THE X COORDINATES OF THE VALUE TO BE INTERPOLATED
C                              YA = VECTOR OF THE Y COORDINATES OF THE VALUE TO BE INTERPOLATED
C                              ZA = VECTOR OF THE INTERPOLATED VALUES
C                              NA = ACTUAL LENGTH OF THE 3 PREVIOUS VECTORS
C                              IEXP = TWO ELEMENT VECTOR CONTRAINING THE TYPE OF EXTRAPOLATION
C                                      CHOSEN BEYOND THE INTERPOLATION DOMAIN
C                                     IEXP(1): EXTRAPOLATION IN X-DIRECTION
C                                     IEXP(1) = IEXPX1 * 10 + IEXPXN
C                                     IEXPX1: EXTRAPOLATION BENEATH THE FIRST POINT
C                                     IEXPXN: EXTRAPOLATION BEYOND THE LAST POINT
C                                     IEXP(2): EXTRAPOLATION IN Y-DIRECTION
C                                     IEXP(2) = IEXPY1 * 10 + IEXPYN
C                                     SAME METHOD AS FOR IEXP(1):
C                              IER = ERROR CODE
C                                     IER = 0: NORMAL PROCEEDING
C                                     IER = -1: ERROR  INPUTDATA
C
C                           REMARK: CHOICE OF THE INTER- EXTRAPOLATION TYPE  IART AND IEXP -
C                         --------             ASSIGNEMENT OF  INTX,INTY,IEXPX1,
C                                       IEXPXN,IEXPY1,IEXPYN:
C                                        = 0 :   CONSTANT
C                                        = 1 :   LINEAR
C                                        = 2 :   DOUBLE QUADRATIC FROM
C                                                THE  SECOND UNTIL PENULTIMATE
C                                                INTERVAL IN THE INTERPOLATION MATRIX T,OTHERWISE QUADRATIC
C
C 3.RESTRICTIONS   THE SAMPLING POINT VECTORS (X UND Y COORDINATES
C ***************  OF THE MATRICX T MUST BE  STRICTLY MONOTONIC INCREASING SORTED
C                  THE PARAMETER FOR THE TYPE OF EXTRAPOLATION
c                  MUST NOT BE GREATER THAN THE ONE FOR TH EINTERPOLATION TYPE
C                  OTHERWISE THE  VALUE IS AUTOMATICALLY ADAPTATED
C                  IF THE NUMBER OF THE SAMPLING POINTS FOR THE REQUIRED TYPE OF INTERPOLATION IS TOO SMALL,
C                  THE DEGREE OF INTERPOLATION WILL BE ACCORDINGLY ADAPTATED
C
C  4.USED UP'S     ONEDINT (ONE DIMENSIONAL INTERPOLATION ANALOG TO THIS PROGRAMM)
C

      SUBROUTINE TWODINT (T,LSP,IART,XA,YA,ZA,NA,IEXP,IER)
      implicit none
      INTEGER IEXP(2),IYU,IYO,IXU,IXO,IDX,IDY,LL,INPY,IEXPX1,IEXPXN,
     &  IEXPY1,IEXPYN,LX,LY,INPX,IART,LSP,IER,NX,NY,L,NA,one
      REAL*8 T(LSP,1),XA(1),YA(1),ZA(1)
      REAL*8 Z1(4),Z2(4)
C      ENTRY ZWEINT (T,LSP,IART,XA,YA,ZA,NA,IEXP,IER)
      IER = 0
      one=1
      NX = T(1,1)
      NY = (T(1,1)-NX)*1000 + 0.1d0
C
C TESTING INPUT
C--------------
      IF ((NX-2).lt.0) then
         go to 900
      elseif((nx-2).eq.0) then
         go to 30
      else
         go to 10
      endif
   10 DO 20 L = 3,NX
   20 IF ((T(L,1)-T(L-1,1)) .LE. 0) GO TO 900
   30 IF ((NY-2).lt.0) then
         go to 900
      elseif((ny-2).eq.0) then
         go to 60
      else
         go to 40
      endif
   40 DO 50 L = 3,NY
   50 IF ((T(1,L)-T(1,L-1)) .LE. 0) GO TO 900
   60 IF (NA .LE. 0) GO TO 900
C
C DEFINING THE CONTROL VALUES
C---------------------------
      INPX = IART/10
      INPY = IART - INPX*10 + 0.1d0
      IEXPX1 = IEXP(1)/10
      IEXPXN = IEXP(1) - IEXPX1*10
      IEXPY1 = IEXP(2)/10
      IEXPYN = IEXP(2) - IEXPY1*10
      IF (NX-2 .LT. INPX) INPX = NX - 2
      IF (NY-2 .LT. INPY) INPY = NY - 2
      IF (IEXPX1 .GT. INPX) IEXPX1 = INPX
      IF (IEXPXN .GT. INPX) IEXPXN = INPX
      IF (IEXPY1 .GT. INPY) IEXPY1 = INPY
      IF (IEXPYN .GT. INPY) IEXPYN = INPY
C
C SUCCESSIVE PROCESSING THE INTERPOLATION EXIGENCES
C-------------------------------------------------------
      DO 400 L = 1,NA
      LX = 2
C
C SETTING REFERENCE POINTS (LX,LY)
C---------------------------------
  200 IF (XA(L) .LT. T(LX,1)) GO TO 220
      LX = LX + 1
      IF ((LX-NX).le.0) then
         go to 200
      else
         go to 210
      endif
  210 LX = NX
  220 DO 230 LY = 2,NY
  230 IF (YA(L) .LT. T(1,LY)) GO TO 235
      LY = NY
  235 IYU = LY - INPY
      IYO = LY + INPY - 1
      IF (IYU .GE. 2) GO TO 240
      IYU = 2
      IYO = IYU + INPY
  240 IF (IYO .GT. NY) IYO = NY
      IXU = LX - INPX
      IXO = LX + INPX - 1
      IF (IXU .GE. 2) GO TO 245
      IXU = 2
      IXO = IXU + INPX
  245 IF (IXO .GT. NX) IXO = NX
      IDX = IXO - IXU + 1
      IF (IXU .LT. IXO) GO TO 270
      IF (IYU .LT. IYO) GO TO 250
C
C CONSTANT INTERPOLATION
C------------------------
      IF (LX .GT. 2 .AND. XA(L) .LT. T(NX,1)) LX = LX - 1
      IF (LY .GT. 2 .AND. YA(L) .LT. T(1,NY)) LY = LY - 1
      ZA(L) = T(LX,LY)
      GO TO 400
C
C LINEAR AND  QUADRATIC INTERPOLATION USING ONEDINT (ONEDIMENSIONAL)
C---------------------------------------------------------------------
C
C INTERPOLATION ONLY IN Y-DIRECTION
C
  250 IDY = 0
      DO 260 LL = IYU,IYO
      IDY = IDY + 1
      Z1(IDY) = T(1,LL)
  260 Z2(IDY) = T(LX,LL)
      GO TO 300
C
C INTERPOLATION ONLY IN X-DIRECTION
C
  270 IF (IYU .LT. IYO) GO TO 280
      CALL ONEDINT(T(IXU,1),T(IXU,LY),IDX,XA(L),ZA(L),one,INPX,IEXP(1),
     1           IER)
      IF (IER.eq.0) then
         go to 400
      else
         go to 900
      endif
C
C 1.INTERPOLATION STEP IN X-DIRECTION
C
  280 IDY = 0
      DO 290 LL = IYU,IYO
      IDY = IDY + 1
      Z1(IDY) = T(1,LL)
      CALL ONEDINT (T(IXU,1),T(IXU,LL),IDX,XA(L),Z2(IDY),one,INPX,
     1    IEXP(1),IER)
      IF (IER.eq.0) then
         go to 290
      else
         go to 900
      endif
  290 CONTINUE
C
C 1.OR 2.INTERPOLATION STEP IN Y-DIRECTION
C
  300 CALL ONEDINT (Z1,Z2,IDY,YA(L),ZA(L),one,INPY,IEXP(2),IER)
      IF (IER.eq.0) then
         go to 400
      else
         go to 900
      endif
C
C RETURN BY NORMAL PROCEEDING
C--------------------------------
  400 CONTINUE
      IER = 0
      RETURN
C
C ERROR RETURN
C-------------
  900 IER = -1
      RETURN
      END


module mod_lnf

     use mod_kinds, only : int4,dp

     contains

       real(kind=dp) function lnf(z)
         real(kind=dp)  :: z
         ! Locals
         real(kind=dp), dimension(11), parameter :: c0 = [0.16427423239836267e+5_dp, -0.48589401600331902e+5_dp, &
                                                          0.55557391003815523e+5_dp, -0.30964901015912058e+5_dp, &
                                                          0.87287202992571788e+4_dp, -0.11714474574532352e+4_dp, &
                                                          0.63103078123601037e+2_dp, -0.93060589791758878e+0_dp, &
                                                          0.13919002438227877e-2_dp,-0.45006835613027859e-8_dp,&
                                                          0.13069587914063262e-9_dp]
         real(kind=dp) :: a,b,cp
         integer(kind=int4) :: i
         ! Exec code
         a = 1.0_dp
         cp = 2.5066282746310005_dp
         b = z+10.5_dp
         b = (z+0.5_dp)*log(b)-b
         do i=1, 11
            z = z+1.0_dp
            a = a+c0(i)/z
         end do
         lnf = b+log(cp*a)

    end function lnf

end module mod_lnf


      MODULE m_gaussp
!**************************************************************
!     generates gaussian points to exactly integrate spherical
!     harmonics up to lmax, i.e., (lm|l'm') for l,l'<=lmax
!     number of points = (2*lmax+1)*(lmax+1 + mod(lmax+1,2))
!**************************************************************
      CONTAINS
      SUBROUTINE gaussp(
     >                  lmax,
     <                  vgauss,wt)

      USE m_grule
      USE m_constants
      IMPLICIT NONE

      INTEGER, INTENT (IN)  :: lmax
      REAL,    INTENT (OUT) :: vgauss(3,*),wt(*) ! points/weights

      INTEGER :: ngpt,nphi,i,j,k
      REAL    :: delphi,phi,rxy
      REAL    :: xx(lmax/2+1),w(lmax/2+1)

!   determine the number of points cos(theta); ngpt always even
      ngpt= lmax+1 + mod(lmax+1,2)
      CALL grule(            ! outputs ngpt/2 points
     >           ngpt,
     <           xx,w)

!  in phi, use nyquist frequency, i.e.,  2*(lmax+1)
      nphi = 2*lmax+1
      delphi = 2.0*pi_const/nphi

      j = 0
      DO i = 1, ngpt/2
         rxy=sqrt(1.0-xx(i)*xx(i))
         DO k=1,nphi
            phi=k*delphi
            j=j+1
            vgauss(1,j) = rxy*cos(phi)
            vgauss(2,j) = rxy*sin(phi)
            vgauss(3,j) = xx(i)
            wt(j) = w(i)*delphi
            j=j+1
            vgauss(1,j) = vgauss(1,j-1)
            vgauss(2,j) = vgauss(2,j-1)
            vgauss(3,j) = -xx(i)
            wt(j) = w(i)*delphi
         ENDDO
      ENDDO

      RETURN
      END SUBROUTINE gaussp
      END MODULE m_gaussp


C     LAST UPDATE 18/09/96
C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
C
      REAL FUNCTION ODFNRM(D,S)
      IMPLICIT NONE
C
C Purpose: Evaluate the integral of the orientation distribution
C          function multiplied by the sine of the angle for the
C          purposes normalization. A = 1 + D, B = -D.
C
C Calls 0:
C
C-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-
C Parameters:
C
      REAL PI,SMAX,SMIN
      PARAMETER(PI=3.14159265,SMAX=100.0,SMIN=1.0)
C
C Arguments:
C
      REAL D,S
C
C Local scalars:
C
      REAL AMB,ONEMS
C
C-----------------------------------------------------------------------
      ODFNRM = 0.0
C
C========Check S and reset if necessary
C
      IF(S.LT.SMIN)S = SMIN
      IF(S.GT.SMAX)S = SMAX
C
C========Check that the distribution is non-uniform
C
      IF(D.GT.0.0)THEN
         AMB = 1.0 + 2.0*D
C
C========Check for S > 1.0 or use alternative method
C
         IF(S.GT.1.0)THEN
            ONEMS = 1.0 - S
            ODFNRM = 2.0*PI*(AMB**ONEMS-1.0)/(D*ONEMS)
         ELSE
            ODFNRM = 2.0*PI*LOG(AMB)/D
         ENDIF
      ELSE
         ODFNRM = 4.0*PI
      ENDIF
      RETURN
      END


	REAL*4 FUNCTION
     . SURVPOWER(ALPHA,M1,M2,A,F,N,M,R,ALT)
	IMPLICIT NONE
C
C-Description-----------------------------------------------------------
C
C  Function:
C	Determine POWER for survival data.
C
C  Input (provided by user):
C	ALPHA	Type I error (two tailed)
C	M1	Median survival time on control treatment
C	M2	Median survival time on experimantal treatment
C	R=M2/M1 Ratio of median survival times for experimental subjects
C		relative to controls -or-
C		Relative hazard (risk) of the control treatment relative
C		to the experimental treatment
C	ALT	1 if input requires M1 and M2
C		2 if input requires M1 and R
C	A	The accrual time during which patients are recruited into
C		the study
C	F	Additional follow-up time after the end of patient
C		recruitment
C	N	Number of experimental patients
C     M	Ratio of control to experimental patients
C  Output:
C	POWER	The probability of correctly rejecting the null
C		hypothesis of equal treatment survival times given
C		N experimental patients, M controls per experimental
C		patient, type I	error probability ALPHA, and true
C		median survival ratio R.
C
C       SURVPOWER.OUT
C		If user chooses, a file of power calculations is
C		output over a range of alternative hypotheses.  The
C		variables output are: ALPHA,M1,M2,A,F,N,M,POWER where
C		M2 is the varied value.  There is one record for each
C		value of M2.  Each value is seperated by a space.
C  Reference:
C	Schoenfeld DA, Richter JR: "Nomograms for Calculating the
C	Number of Patients Needed for a Clinical Trial With Survival
C	as an Endpoint" Biometrics 1982; 38: 163-170.
C
C  Notes:
C   .	This routine was written by Dale Plummer
C   .	Designed by Dr. William Dupont
C   .	Schoenfeld and Richter define BETA to equal the study power
C	rather than the type II error.  Otherwise the notation used
C	in this program is analogous to that used by these authors.
C
C-Declarations----------------------------------------------------------
C
C
C  Functions
C
	REAL ZCRVALUE
	DOUBLE PRECISION PHI
C
C  Locals
C
      REAL ALPHA,M1,M2,R,A,F,N,M
	INTEGER ALT
      REAL PA,GF,P,ZALPHA,POWER,SIGMA,DELTA,MM
C
C-Code------------------------------------------------------------------
C
	IF (ALT.EQ.1) THEN
	    R=M2/M1
	ELSE
	    M2=R*M1
	END IF
	IF (A.EQ.0) A=F*0.00004
C
C    Do the real work.
C
	MM=(M1+M2)/2.
	PA=(1.-EXP(-LOG(2.)*A/MM))/(LOG(2.)*A/MM)
	GF=EXP(-LOG(2.)*F/MM)
	P=1.-PA*GF
	SIGMA=SQRT((1.+1./M)/P)
	DELTA=LOG(R)/SIGMA
	ZALPHA=ZCRVALUE(ALPHA/2.)
	POWER=PHI(DELTA*SQRT(N)-ZALPHA)+PHI(-DELTA*SQRT(N)-ZALPHA)
	SURVPOWER=POWER
	RETURN
	END


!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!!*******************************************************!!
!! Objetivo: escrever um programa que resolva um sistema !!
!!      não linear pelo método de Newton-Raphson         !!
!! Aluna: Laura Simonassi Raso de Paiva                  !!
!! Matrícula: 180021885                                  !!
!! Data: 28/10/2019                                      !!
!! Ultima modificação: 31/10/2019                        !!
!!*******************************************************!!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!

module vg
real(kind=8), dimension(3,3) :: Mat_Int
real(kind=8), dimension(3,3) :: L, U
real(kind=8), dimension(3)   :: b,y
real(kind=8), dimension(3)   :: s                     !Delta
real(kind=8), dimension(3,3) :: F_linha
real(kind=8), dimension(3)   :: F_negativa
real(kind=8)                 :: x1,x2,x3
end module vg

!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!!*******************************************************!!
!!      Programa que resolve sistemas não lineares       !!
!!*******************************************************!!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!Temos que o sistema linear a ser resolvido é:
!x1²+x2²+x3²=9
!x1x2x3=1
!x1+x2-x3²=0

program sistema
use vg
implicit none
real(kind=8):: x1_ant,x2_ant,x3_ant

!Chute inicial para as raízes
x1=1.0d0
x2=2.0d0
x3=3.0d0

call derivadaf
call negativaf

!Nomeação para decomposição LU
Mat_Int=F_linha
b=F_negativa

do
  x1_ant=x1
  x2_ant=x2
  x3_ant=x3

  call lu
  call calcula_solucao
   x1=x1+s(1)
   x2=x2+s(2)
   x3=x3+s(3)

  if ((abs((x1-x1_ant)/x1_ant)<=1d-10) .and.(abs((x2-x2_ant)/x2_ant)<=1d-10).and. (abs((x3-x3_ant)/x3_ant)<=1d-10))  exit

   call derivadaf
   call negativaf
   Mat_Int=F_linha
   b=F_negativa
end do

open(unit=1, file='resultados.txt', status='new')
write(1,*)'A resolucao do sistema nao linear resulta nas raizes x1=',x1,'x2=',x2,'x3=',x3
close(1)

end program sistema

!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!!*******************************************************!!
!!        Definição das funções por subrotinas           !!
!!*******************************************************!!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!

subroutine derivadaf
use vg
implicit none
F_linha(1,1)=2.0d0*x1
F_linha(1,2)=2.0d0*x2
F_linha(1,3)=2.0d0*x3
F_linha(2,1)=x2*x3
F_linha(2,2)=x1*x3
F_linha(2,3)=x1*x2
F_linha(3,1)=1.0d0
F_linha(3,2)=1.0d0
F_linha(3,3)=-2.0d0*x3
return
end subroutine derivadaf

subroutine negativaf
use vg
implicit none
F_negativa(1)=-(x1**2.0d0)-(x2**2.0d0)-(x3**2.0d0) + 9.0d0
F_negativa(2)=-(x1*x2*x3) + 1.0d0
F_negativa(3)=-x1-x2+(x3**2.0d0)
return
end subroutine negativaf

!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!!******************************************************************************************!!
!!  Vamos usar o exercício 3 para resolver o sistema linear, mas agora para dimensão 3      !!
!!******************************************************************************************!!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!

!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!!*********************************************!!
!! Subrotina que realiza a decomposição Lu     !!
!!*********************************************!!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!

subroutine lu
use vg
implicit none
real(kind=8):: coef
integer :: i,j,k

!Definição dos elementos de L e U como nulos, para iniciar a decomposição.
L=0.0
U=0.0

do k=1,2
 do i=k+1,3
  coef=Mat_Int(i,k)/Mat_Int(k,k)
  L(i,k)=coef
  Mat_Int(i,k)=0
   do j=k+1,3
    Mat_Int(i,j)=Mat_Int(i,j)-coef*Mat_Int(k,j)
   end do
  end do
end do

!Diagonal de L=1
do i=1,3
 L(i,i)=1.0
end do

do j=1,3
 do i=1,j
  U(i,j)=Mat_Int(i,j)
 end do
end do

return
end subroutine lu

!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!!*****************************************************!!
!!   Subrotina que realiza os cálculos na resolução    !!
!!                  do sistema linear                  !!
!!*****************************************************!!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!

subroutine calcula_solucao
use vg
implicit none
integer :: i,j

!Primeiramente, fazemos em que Ly=b e utilizamos a substituição progressiva
!Primeiro termo de y
 y(1)=b(1)/L(1,1)
!Definição vetor y
 do i=2,3
  y(i)=b(i)
  do j=1, i-1
   y(i)=y(i)-L(i,j)*y(j)
  end do
  y(i)=y(i)/L(i,i)
 end do

!Em seguida, usamos a definição Us=y
s(3)=y(3)/U(3,3)
 do i=2,1,-1!Devido a substituição regressiva
  s(i)=y(i)
  do j=i+1,3
   s(i)=s(i)-U(i,j)*s(j)
  end do
  s(i)=s(i)/U(i,i)
 end do
return
end subroutine calcula_solucao


program test_sin2
use iso_fortran_env, only: dp => real64
use lfortran_intrinsic_sin, only: sin2 => sin
implicit none
real(dp) :: x, s1, s2, err, err_max
integer :: i
x = sin(1.5_dp)
if (abs(x - 0.997494996_dp) > 1e-5_dp) error stop
x = sin(20.0_dp)
if (abs(x - 0.9129452507276277_dp) > 1e-5_dp) error stop
print *, "i  x  err"
err_max = 0
do i = 1, 2000
    x = i*0.01_dp - 10
    s1 = sin2(x)
    s2 = sin(x)
    err = abs(s1-s2)
    if (err > err_max) err_max = err
    print *, i, x, err
end do
print *
print *, "Maximum error:", err_max
if (err_max > 1e-15_dp) error stop "Maximum error too large"

! Large number
x = 2e10_dp+0.5_dp
s1 = sin2(x); s2 = sin(x); err = abs(s1-s2)
print *, x, err

x = 2e33_dp+0.5_dp
s1 = sin2(x); s2 = sin(x); err = abs(s1-s2)
print *, x, err
end program


SUBROUTINE time_GPSweek (mjd , GPS_week, GPS_wsec, GPSweek_mod1024)

! ----------------------------------------------------------------------
! Subroutine:     time_GPSweek.f90
! ----------------------------------------------------------------------
! Purpose:
!  Convert GPS time to GPS Week number and seconds
! ----------------------------------------------------------------------
! Input arguments:
! - mjd:                Modified Julian Day number in GPS time (including fraction of the day)
!
! Output arguments:
! - GPS_week:           GPS Week number
! - GPS_day :           Day since start of GPS Week
! - GPS_wsec:           Seconds since start of GPS Week
! ----------------------------------------------------------------------
! Dr. Thomas Papanikolaou, Geoscience Australia            December 2015
! ----------------------------------------------------------------------

      USE mdl_precision
      IMPLICIT NONE

! ----------------------------------------------------------------------
! Dummy arguments declaration
! ----------------------------------------------------------------------
! IN
      REAL (KIND = prec_d), INTENT(IN) :: mjd
! OUT
      INTEGER (KIND = prec_int8) , INTENT(OUT) :: GPS_week, GPSweek_mod1024
      REAL (KIND = prec_d), INTENT(OUT) :: GPS_wsec
      !REAL (KIND = prec_d), INTENT(OUT) :: GPS_day
! ----------------------------------------------------------------------

! ----------------------------------------------------------------------
! Local variables declaration
! ----------------------------------------------------------------------
      REAL (KIND = prec_d) :: GPS_day
      INTEGER  J_flag
!      IY, IM, , ID
      DOUBLE PRECISION DJM0
      DOUBLE PRECISION mjd_1980, mjd_1999, delta_days, GPS_week_0
! ----------------------------------------------------------------------

! ----------------------------------------------------------------------
! The GPS Week Number field is modulo 1024 :
! ----------------------------------------------------------------------
! GPS_wn = 0    | 06 Jan. 1980
! GPS_wn = 1023 | 15 Aug. 1999
! GPS_wn = 0    | 22 Aug. 1999      | modulo 1024
! GPS_wn = 1    | 29 Aug. 1999
! ----------------------------------------------------------------------

! ----------------------------------------------------------------------
! 06 Jan. 1980 : GPS_week = 0
      CALL iau_CAL2JD ( 1980, 01, 06, DJM0, mjd_1980, J_flag )
! ----------------------------------------------------------------------
! Rollover to 0
! 22 Aug. 1999 : GPS_week = 0
      CALL iau_CAL2JD ( 1999, 08, 22, DJM0, mjd_1999, J_flag )
! ----------------------------------------------------------------------

! ----------------------------------------------------------------------
! Days since GPS weeks start epoch i.e. 06 Jan. 1980
      delta_days = mjd - mjd_1980
      !delta_days = mjd - mjd_1999
! ----------------------------------------------------------------------

! ----------------------------------------------------------------------
! GPS Week since 6 Jan. 1980
      GPS_week_0 = delta_days / 7.0D0

! GPS Week number | Modulo 1024
      GPSweek_mod1024 = MOD ( INT(GPS_week_0) , 1024)

! GPS Week (according to IGS numbering)
      GPS_week = INT(GPS_week_0)
! ----------------------------------------------------------------------

! ----------------------------------------------------------------------
! Day since start of GPS week (including fraction of the day)
      !GPS_day =  (GPS_week_0 - INT(GPS_week_0)) * 7D0
      GPS_day = delta_days - GPS_week * 7.D0
! ----------------------------------------------------------------------

! ----------------------------------------------------------------------
! Seconds since start of GPS week
      !GPS_wsec = (GPS_week_0 - INT(GPS_week_0)) * 7.0D0 * 86400.0D0
      GPS_wsec = GPS_day *    86400.0D0
! ----------------------------------------------------------------------
        !print *,"mjd       ", mjd
      !print *,"mjd_1980  ", mjd_1980
      !print *,"delta_days", delta_days
      !print *,"GPS_week_0", GPS_week_0
      !print *,"GPS_week  ", GPS_week
      !print *,"GPS_wsec  ", GPS_wsec
      !print *,"GPS_day   ", GPS_day
      !print *,"          "

END


program test

  ! Import dependencies
  use lapack, only : dgetrf
  use linear_algebra , only : eig, eigvals, svdvals, svd

  implicit none

  integer, parameter   :: ntrials = 100
  real(8), allocatable :: L(:,:)
  real(8)              :: l1norm(ntrials), l2norm(ntrials), linfnorm(ntrials)
  real(8)              :: ratio(ntrials,2)
  real(8)              :: condn(ntrials)
  real(8)              :: avg(2), avgcond
  integer              :: matsize
  integer              :: trial

  ! Open file handle for output
  open(11, file='problem4.dat')
  write(11,'(4A20)') 'm', 'L1Norm/L2Norm', 'L2Norm/LinfNorm', 'kappa'

  ! For increasing matrix size
  do matsize = 1000, 10000, 1000

     ! Memory allocations
     allocate(L(matsize,matsize))

     ! Conduct 100 random trials for statistics
     do trial = 1, ntrials

        call get_random_lower(L)

        ! Get the 2 norm condition number
        condn(trial) = cond(L,2)

        l1norm(trial)   = matnorm(L, 1)
        l2norm(trial)   = matnorm(L, 2)
        linfnorm(trial) = matnorm(L, 0)

     end do

     ratio(:,1) = l1norm/l2norm
     ratio(:,2) = l2norm/linfnorm

     ! Average the values
     avg(1) = sum(ratio(:,1))/dble(ntrials)
     avg(2) = sum(ratio(:,2))/dble(ntrials)
     avgcond = sum(condn)/dble(ntrials)

     ! Write output
     write(11,*) matsize, avg(1), avg(2), avgcond
     print *,  matsize, avg(1), avg(2), avgcond

     ! Free resources
     deallocate(L)

  end do

  close(11)

contains

  function random_normal(mean,stdev) result(c)

    real(8), intent(in) :: mean,stdev
    real(8)             :: c, r, theta
    real(8)             :: temp(2)
    real(8), parameter  :: pi = 4.d0*datan(1.d0)

    call random_number(temp)

    r = (-2.0d0*log(temp(1)))**0.5
    theta = 2.0d0*pi*temp(2)

    c = mean+stdev*r*sin(theta)

  end function random_normal

  subroutine get_random_lower(L)

    real(8), intent(inout) :: L(:,:)
    integer :: i, j, m, n

    m = size(L,1)
    n = size(L,2)

    do i = 1, m
       do j = 1, i
          L(i,j) = random_normal(0.0d0, sqrt(dble(m)))
       end do
    end do

  end subroutine get_random_lower

  !===================================================================!
  ! Implement vector p-norm
  !===================================================================!

  pure real(8) function vecnorm(x, p)

    real(8), intent(in) :: x(:)
    integer, intent(in) :: p
    integer             :: length, k

    ! initialize value
    vecnorm = 0.0d0

    length = size(x)
    if ( p .eq. 0 ) then
       vecnorm = maxval(abs(x))
    else
       do k = 1, length
          vecnorm = vecnorm + abs(x(k))**dble(p)
       end do
       vecnorm = vecnorm**(1.0d0/dble(p))
    end if

  end function vecnorm

  !===================================================================!
  ! Implement Matrix p-norm
  !===================================================================!

  pure real(8) function matnorm(A, p)

    real(8), intent(in) :: A(:,:)
    integer, intent(in) :: p
    integer             :: length, k
    real(8) :: w(size(A,1))

    ! Create a unit vector
    w = 1.0d0
    w = w/vecnorm(w,p)

    ! Get the matrix vector product
    w = matmul(A,w)

    matnorm = vecnorm(w,p)

  end function matnorm

  !===================================================================!
  ! Implement Matrix p-cond
  !===================================================================!

  real(8) function cond(A, p)

    real(8), intent(in) :: A(:,:)
    integer, intent(in) :: p
    integer             :: length, k
    real(8) :: w(size(A,1))

    ! Get singular values
    w = svdvals(A)

    ! find the condition number
    cond = maxval(w)/minval(w)

  end function cond

end program test


!-----------------------------------------------------------------------------!
! \file   kba_equations/Parameters.f90
! \author Thomas M. Evans
! \date   Thur Jan 24 13:59:01 2008
! \brief  Parameters for FORTRAN kernels in KBA.
! \note   Copyright (C) 2008 Oak Ridge National Laboratory, UT-Battelle, LLC
!-----------------------------------------------------------------------------!
! $Id: Parameters.f90,v 1.2 2009/07/23 18:45:16 9te Exp $
!-----------------------------------------------------------------------------!

module Parameters

  implicit none

  ! Single precision control.
  integer, parameter :: SHORT  = selected_int_kind(3)
  integer, parameter :: SINGLE = selected_real_kind(5)
  integer, parameter :: DOUBLE = selected_real_kind(14)

  ! Indices
  integer, parameter :: I = 1
  integer, parameter :: J = 2
  integer, parameter :: K = 3

  ! Fractions.
  real(DOUBLE), parameter :: zero        = 0.0_DOUBLE
  real(DOUBLE), parameter :: one         = 1.0_DOUBLE
  real(DOUBLE), parameter :: two         = 2.0_DOUBLE
  real(DOUBLE), parameter :: three       = 3.0_DOUBLE
  real(DOUBLE), parameter :: four        = 4.0_DOUBLE
  real(DOUBLE), parameter :: one_half    = one / 2.0_DOUBLE
  real(DOUBLE), parameter :: one_third   = one / 3.0_DOUBLE
  real(DOUBLE), parameter :: one_fourth  = one / 4.0_DOUBLE
  real(DOUBLE), parameter :: one_fifth   = one / 5.0_DOUBLE
  real(DOUBLE), parameter :: one_sixth   = one / 6.0_DOUBLE
  real(DOUBLE), parameter :: one_seventh = one / 7.0_DOUBLE
  real(DOUBLE), parameter :: one_eighth  = one / 8.0_DOUBLE

  ! Constants.
  real(DOUBLE), parameter :: pi          = 3.1415926535897931159979635_DOUBLE
  real(DOUBLE), parameter :: two_pi      = two * pi
  real(DOUBLE), parameter :: four_pi     = four * pi
  real(DOUBLE), parameter :: inv_two_pi  = one / two_pi
  real(DOUBLE), parameter :: inv_four_pi = one / four_pi

  ! Huge constant.
  real(DOUBLE), parameter :: huge = 1.0e14

  ! Size of mesh in each direction.
  integer, save :: im, jm, km

end module Parameters

!-----------------------------------------------------------------------------!
! Set the dimensionality of the mesh in each direction.

subroutine set_dimensions(im_in, jm_in, km_in)

  use Parameters, only : im, jm, km
  implicit none

  integer, intent(in) :: im_in, jm_in, km_in

  im = im_in
  jm = jm_in
  km = km_in

end subroutine set_dimensions

!-----------------------------------------------------------------------------!
!                           end of Parameters.f90
!-----------------------------------------------------------------------------!


subroutine apply_linearized_pde_operator(t, r, p, output)

! For the PDE r_t = g(r), calculates g'[r](p), i.e. the linearization
! of g, about r, applied to perturbation p
!
! Args:
!   t: Time at which the operator is evaluated.
!   r: Base function of the linearization.
!   p: Perturbation to which the linearized operator is applied.
!   output: g'[r](p), calculated here.

    implicit none

    integer :: mx, mbc, meqn
    double precision :: dx, x_lower
    common /claw_config/ mx, mbc, x_lower, dx, meqn

    double precision, intent(in) :: t
    double precision, dimension(1-mbc:mx+mbc, meqn), intent(in) :: r, p
    double precision, dimension(1-mbc:mx+mbc, meqn), intent(out) :: output

    double precision, dimension(1-mbc:mx+mbc, meqn) :: temp1, temp2

    double precision :: epsilon
    double precision, external :: l2_norm
    integer :: ix, ieqn

    double precision :: err, local_err
    integer :: i_max

!     epsilon = 1d-4 * l2_norm(r) / l2_norm(p)
    epsilon = sqrt((1 + l2_norm(r)) * 1d-16) / l2_norm(p)

!     epsilon = 0.d0
!     do ieqn = 1, meqn
!         do ix = 1, mx
!             epsilon = epsilon + abs(r(ix, ieqn))
!         end do
!     end do
!     epsilon = 1.d-4 * (epsilon / (mx * l2_norm(p)) + 1.d0)

    temp1 = r + epsilon * p
    call apply_pde_operator(t, temp1, output)
    temp1 = r - epsilon * p
    call apply_pde_operator(t, temp1, temp2)

    do ieqn = 1, meqn
        do ix = 1, mx
            output(ix, ieqn) = (output(ix, ieqn) - temp2(ix, ieqn)) / (2 * epsilon)
        end do
    end do

!     temp1 = r + epsilon * p
!     call apply_pde_operator(t, temp1, output)
!     temp1 = r
!     call apply_pde_operator(t, temp1, temp2)
!
!     do ieqn = 1, meqn
!         do ix = 1, mx
!             output(ix, ieqn) = (output(ix, ieqn) - temp2(ix, ieqn)) / epsilon
!         end do
!     end do

!     ! Hack check for linear problem
!     call apply_pde_operator(t, p, temp1)
!     err = 0.d0
!     do ix = 1, mx
!         local_err = abs(temp1(ix, 1) - output(ix, 1))
!         if (local_err > err) then
!             err = local_err
!             i_max = ix
!         end if
!     end do
!     print *, mx, epsilon, i_max, err
!     print *, r(i_max-2:i_max+2, 1)
!     print *, p(i_max-2:i_max+2, 1)
!     print *, ''

end subroutine apply_linearized_pde_operator


module local_routines
    !! Test the convergence of the code in a periodic domain
    use global_mod, only: dp, ip, wall_elevation, pi
    use domain_mod, only: domain_type, STG, UH, VH, ELV
    use read_raster_mod, only: multi_raster_type
    use logging_mod, only: log_output_unit
    implicit none

    contains

    subroutine set_initial_conditions(domain)
        class(domain_type), intent(inout):: domain
        integer(ip):: i, j
        real(dp), allocatable:: x(:), y(:)

        ! Make space for x/y coordinates, at which we will look-up the rasters
        allocate(x(domain%nx(1)), y(domain%nx(1)))
        x = domain%x

        ! Set stage and elevation row-by-row.
        do j = 1, domain%nx(2)
            y = domain%y(j)
            domain%U(:,j,ELV) = 2.0_dp - sin(2*pi*x) - cos(2*pi*y)
            domain%U(:,j,STG) = domain%U(:,j,ELV) + 10.0_dp + exp(sin(2*pi*x))*cos(2*pi*y)
            domain%U(:,j,UH) = sin(cos(2*pi*x))*sin(2*pi*y)
            domain%U(:,j,VH) = cos(2*pi*x)*cos(sin(2*pi*y))
        end do

        deallocate(x,y)

        ! Ensure stage >= elevation
        domain%U(:,:,STG) = max(domain%U(:,:,STG), domain%U(:,:,ELV) + 1.0e-07_dp)

        write(log_output_unit,*) 'Stage range is: ', minval(domain%U(:,:,STG)), maxval(domain%U(:,:,STG))
        write(log_output_unit,*) 'Elev range is: ', minval(domain%U(:,:,ELV)), maxval(domain%U(:,:,ELV))

    end subroutine

end module

!@!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!

program periodic_convergence
    !! Test the convergence of the code in a periodic domain

    use global_mod, only: ip, dp, default_nonlinear_timestepping_method
    use domain_mod, only: domain_type
    use multidomain_mod, only: multidomain_type
    use timer_mod, only: timer_type
    use logging_mod, only: log_output_unit
    use stop_mod, only: generic_stop
    use local_routines
    implicit none

    ! Type holding all domains
    type(multidomain_type) :: md

    ! Local timing object
    type(timer_type) :: program_timer

    ! Change this to decrease the cell size by mesh_refine (i.e. for convergence testing)
    character(len=32) :: mesh_refine_input
    integer(ip) :: mesh_refine

    ! Approx timestep between outputs
    real(dp) :: approximate_writeout_frequency = 0.005_dp
    real(dp) :: final_time = 0.06_dp
    real(dp) :: my_dt

    ! Length/width
    real(dp), parameter, dimension(2):: global_lw = [1.0_dp, 1.0_dp]
    ! Lower-left corner coordinate
    real(dp), parameter, dimension(2):: global_ll = [0.0_dp, 0.0_dp]
    ! grid size (number of x/y cells)
    integer(ip), dimension(2):: global_nx

    ! Number of domains in model; loop variable
    integer(ip):: nd, j

    call get_command_argument(1, mesh_refine_input)
    read(mesh_refine_input, '(I4)') mesh_refine

    my_dt = 4e-04_dp/mesh_refine
    global_nx = [100_ip, 100_ip]*mesh_refine + 1

    ! Set the model name
    md%output_basedir = './OUTPUTS/'

    call program_timer%timer_start('setup')

#ifdef SPHERICAL
    write(log_output_unit,*) 'Code assumes cartesian coordinates, but SPHERICAL is defined'
    call generic_stop
#endif

    ! Set periodic boundary condition
    md%periodic_xs = [0.0_dp, 1.0_dp]
    md%periodic_ys = [0.0_dp, 1.0_dp]

    ! nd domains in this model
    nd = 1
    allocate(md%domains(nd))

    !
    ! Setup basic metadata
    !

    ! Linear domain
    md%domains(1)%lw = global_lw
    md%domains(1)%lower_left =global_ll
    md%domains(1)%nx = global_nx
    md%domains(1)%dx = md%domains(1)%lw/md%domains(1)%nx
    md%domains(1)%dx_refinement_factor = 1.0_dp
    md%domains(1)%timestepping_refinement_factor = 1_ip
    md%domains(1)%timestepping_method = default_nonlinear_timestepping_method ! Do not use linear!

    ! Allocate domains and prepare comms
    call md%setup()
    call md%memory_summary()

    ! Set initial conditions
    do j = 1, size(md%domains)
        call set_initial_conditions(md%domains(j))
    end do
    call md%make_initial_conditions_consistent()

    ! NOTE: For stability in 'null' regions, we set them to 'high land' that
    ! should be inactive.
    call md%set_null_regions_to_dry()

    write(log_output_unit,*) 'End setup'

    call program_timer%timer_end('setup')
    call program_timer%timer_start('evolve')

#ifdef COARRAY
    sync all
    flush(log_output_unit)
#endif

    !
    ! Evolve the code
    !
    do while (.true.)

        call md%write_outputs_and_print_statistics(approximate_writeout_frequency = 4.0e-04_dp, timing_tol=my_dt/3.0_dp)

        if (md%domains(1)%time > final_time) exit

        call md%evolve_one_step(my_dt)

    end do

    call program_timer%timer_end('evolve')
    call md%finalise_and_print_timers

    write(log_output_unit,*) ''
    write(log_output_unit, *) 'Program timer'
    write(log_output_unit, *) ''
    call program_timer%print(log_output_unit)
end program


module math_func_mod
    use, intrinsic :: iso_fortran_env, only : REAL64
    use math_func_interface
    implicit none

    private
    type, public :: func_record
        procedure(math_func), pointer, nopass :: f => null()
        character(len=50) :: name
    end type func_record
    type(func_record), public, dimension(9) :: functions
    public :: setup

contains

    subroutine setup()
        implicit none
        functions(1)%f => f7
        functions(1)%name = 'x + x'
        functions(2)%f => f6
        functions(2)%name = "x*x"
        functions(3)%f => f8
        functions(3)%name = "2.13/x"
        functions(4)%f => f1
        functions(4)%name = "x**2"
        functions(5)%f => f5
        functions(5)%name = "x**2.1D00"
        functions(6)%f => f2
        functions(6)%name = "sqrt(x)"
        functions(7)%f => f3
        functions(7)%name = "exp(x)"
        functions(8)%f => f4
        functions(8)%name = "erf(x)"
        functions(9)%f => f9
        functions(9)%name = "x*x + x"
    end subroutine setup

    function f1(x) result(r)
        implicit none
        real(kind=REAL64), intent(in) :: x
        real(kind=REAL64) :: r
        r = x**2
    end function f1

    function f2(x) result(r)
        implicit none
        real(kind=REAL64), intent(in) :: x
        real(kind=REAL64) :: r
        r = sqrt(x)
    end function f2

    function f3(x) result(r)
        implicit none
        real(kind=REAL64), intent(in) :: x
        real(kind=REAL64) :: r
        r = exp(x)
    end function f3

    function f4(x) result(r)
        implicit none
        real(kind=REAL64), intent(in) :: x
        real(kind=REAL64) :: r
        r = erf(x)
    end function f4

    function f5(x) result(r)
        implicit none
        real(kind=REAL64), intent(in) :: x
        real(kind=REAL64) :: r
        r = x**2.1D00
    end function f5

    function f6(x) result(r)
        implicit none
        real(kind=REAL64), intent(in) :: x
        real(kind=REAL64) :: r
        r = x*x
    end function f6

    function f7(x) result(r)
        implicit none
        real(kind=REAL64), intent(in) :: x
        real(kind=REAL64) :: r
        r = x + x
    end function f7

    function f8(x) result(r)
        implicit none
        real(kind=REAL64), intent(in) :: x
        real(kind=REAL64) :: r
        r = 2.13/x
    end function f8

    function f9(x) result(r)
        implicit none
        real(kind=REAL64), intent(in) :: x
        real(kind=REAL64) :: r
        r = x*x + x
    end function f9

end module math_func_mod


PROGRAM two
    IMPLICIT NONE
    REAL:: sumlnX, sumlnY, sumlnXSqure, sumlnXY, b, lnA
    REAL, DIMENSION(5):: x, y
    INTEGER:: n, i
    n = 5
    sumlnX = 0.0
    sumlnY = 0.0
    sumlnXSqure = 0.0
    sumlnXY = 0.0
    DO i = 1, n
        READ(*, *) x(i), y(i)
        sumlnX = sumlnX + log(x(i))
        sumlnY = sumlnY + log(y(i))
        sumlnXY = sumlnXY + log(x(i)) * log(y(i))
        sumlnXSqure = sumlnXSqure + log(x(i)) * log(x(i))
    ENDDO

    b = (n*sumlnXY - sumlnX * sumlnY) / (n * sumlnXSqure - sumlnX * sumlnX)
    lnA = (1.0/n) * (sumlnY - b * sumlnX)

    WRITE(*, *) b, lnA
END


MODULE m_legendre

! ----------------------------------------------------------------------
! MODULE: m_legendre.f03
! ----------------------------------------------------------------------
! Purpose:
!  Module for calling the legendre subroutine
!
! Subroutines contained within the module:
! - legendre
! ----------------------------------------------------------------------
! Author :	Dr. Thomas Papanikolaou
!			Cooperative Research Centre for Spatial Information, Australia
! Created:	16 November 2017
! ----------------------------------------------------------------------

      IMPLICIT NONE
      !SAVE

Contains

SUBROUTINE legendre (phi, nmax, Pnm_norm)

! ---------------------------------------------------------------------------
! Subroutine:  legendre
! ---------------------------------------------------------------------------
! Purpose:
!  Computation of the Normalized Associated Legendre functions
!  Evaluation of Legendre functions is based on recurrence relations
! ---------------------------------------------------------------------------
! Input arguments:
! - phi:				Spherical latitude (radians)
! - nmax:				Maximum degree expansion
!
! Output declaration to module:
! - mdl_legendre.f90:	Module used for the definition of the output arguments
!						as dynamic allocatable arrays
! Output arguments:
! - Pnm_norm:			Normalized Associated Legendre functions up to degree n
! ---------------------------------------------------------------------------
! Author :	Dr. Thomas Papanikolaou, Cooperative Research Centre for Spatial Information, Australia
! Created:	September 2015
! ----------------------------------------------------------------------
! Last modified:
! - Dr. Thomas Papanikolaou, 16 November 2017:
!	Upgraded from Fortran 90 to Fortran 2003 for considering the
!	Fortran 2003 advantages in dynamic memory allocation
! ----------------------------------------------------------------------

      USE mdl_precision
      USE mdl_num
!     USE of Allocatable Arrays
!      USE mdl_legendre
      IMPLICIT NONE

! ----------------------------------------------------------------------
! Dummy arguments declaration
! ----------------------------------------------------------------------
! IN
      INTEGER (KIND = prec_int8), INTENT(IN) :: nmax
      REAL (KIND = prec_q), INTENT(IN) :: phi
! OUT
      REAL (KIND = prec_q), INTENT(OUT), DIMENSION(:,:), ALLOCATABLE :: Pnm_norm
! ----------------------------------------------------------------------

! ----------------------------------------------------------------------
! Local variables declaration
! ----------------------------------------------------------------------
      INTEGER (KIND = prec_int2) :: AllocateStatus
      INTEGER (KIND = prec_int8) :: n, m
      REAL (KIND = prec_q) :: pi
      REAL (KIND = prec_q) :: theta, c, s
      REAL (KIND = prec_q) :: Poo_norm, P10_norm, P11_norm, P_f1, P_f2, P_f3
! ----------------------------------------------------------------------

! ----------------------------------------------------------------------
! Allocatable arrays
! ----------------------------------------------------------------------
      ALLOCATE (Pnm_norm(nmax+1,nmax+1), STAT = AllocateStatus)
!      print *,"Pnm_norm AllocateStatus=", AllocateStatus
      IF (AllocateStatus /= 0) THEN
         PRINT *, "Error: Not enough memory"
         PRINT *, "Error: SUBROUTINE legendre.f"
         PRINT *, "Error: Allocatable Array: Pnm_norm, Nmax =", nmax
!         STOP "*** Not enough memory ***"
      END IF
! ----------------------------------------------------------------------

! ----------------------------------------------------------------------
! Set Pnm to zero matrice as initialization
      DO n = 0 , nmax
      	DO m = 0 , nmax
      		Pnm_norm (n+1 , m+1) = 0D0
      	END DO
      END DO
! ----------------------------------------------------------------------

! ----------------------------------------------------------------------
! Numerical Constants
      pi = PI_global
! ----------------------------------------------------------------------

! %u = sin(phi);
      theta = pi/2D0 - phi
      c = cos(theta)
      s = sin(theta)

      Poo_norm = 1D0
      P10_norm = sqrt(3D0) * c
      P11_norm = sqrt(3D0) * s

! -------------------------------------------------------------------------
! Normalized Associated Legendre functions (Pnm_Norm) for order m=0 and
! variable degree n
! -------------------------------------------------------------------------
      DO n = 0 , nmax
          if (n==0) THEN
              Pnm_norm(n+1,0+1) = Poo_norm
          else if (n==1) THEN
              Pnm_norm(n+1,0+1) = P10_norm
          else
              P_f1 = sqrt(1D0*(2*n-1)) * c * Pnm_norm(n-1+1,0+1)
              Pnm_norm(n+1,0+1) = (sqrt(1D0*(2*n+1)) / n) *                 &
     		  (P_f1 - ((n-1) / sqrt(1D0*(2*n-3)) ) * Pnm_norm(n-2+1,0+1))
          end IF
      end DO
! -------------------------------------------------------------------------

! -------------------------------------------------------------------------
! Normalized functions for equal degree n and order m
! -------------------------------------------------------------------------
      DO n = 1 , nmax
          if (n == 1) THEN
              Pnm_norm(n+1,n+1) = P11_norm
          else
              Pnm_norm(n+1,n+1) = ( sqrt(1D0*(2*n+1)) / sqrt(2D0*n) )       &
     		  * s * Pnm_norm(n-1+1,n-1+1)
          end IF
      end DO
! -------------------------------------------------------------------------

! -------------------------------------------------------------------------
! Normalized functions for variable degree n and order m
! -------------------------------------------------------------------------
      DO n = 2 , nmax
          DO m = 1 , n
! -------------------------------------------------------------------------
			  ! Case:  m = n - 1
              if (n == (m+1)) THEN
                      Pnm_norm(n+1,m+1) = sqrt(1D0*(2*n+1)) * c * Pnm_norm(n-1+1,m+1)
! -------------------------------------------------------------------------
			  ! Case:  n > m+1
              else if (n > (m+1)) THEN
				  ! General case : n, m
                  P_f2 = sqrt( 1D0*(2*n-1) ) * c * Pnm_norm(n-1+1,m+1)
                  P_f3 = sqrt( (1D0* (n-1+m)*(n-1-m) ) / (1D0*(2*n-3) ) ) * Pnm_norm(n-2+1,m+1)
                  !Pnm_norm(n+1,m+1) = ( sqrt(1D0*(2*n+1)) / sqrt(1D0* (n+m)*(n-m)) ) * (P_f2 - P_f3)
                  Pnm_norm(n+1,m+1) = sqrt( (1D0*(2*n+1)) / (1D0*(n+m)*(n-m)) ) * (P_f2 - P_f3)
              end IF
! -------------------------------------------------------------------------
!      		  Print *, "Pnm ij=", Pnm_norm(n+1,m+1)
          end DO
      end DO
! -------------------------------------------------------------------------

END Subroutine

END Module


program well
use special, only: spherical_bessel_jn_zeros
use dftatom
implicit none

! For potential well, we need to set Z=0:
integer, parameter :: Z = 0
! Mesh parameters:
real(dp), parameter :: r_min = 1e-7_dp, r_max = 10, a = 2.7e6_dp
integer, parameter :: NN = 5000

real(dp), parameter :: c = 137.035999037_dp, eps = 1e-12_dp
integer :: n, l, relat, converged
real(dp) :: r(NN+1), u(size(r)), Ein, E, E_exact, error, P(size(r)), Q(size(r))
real(dp) :: Rp(NN+1)
real(dp) :: Emin_init, Emax_init
real(dp), allocatable :: zeros(:, :)

R = mesh_exp(r_min, r_max, a, NN)
Rp = mesh_exp_deriv(r_min, r_max, a, NN)
u = 0

allocate(zeros(10, 0:7))
zeros = spherical_bessel_jn_zeros(7, 10, 1e-13_dp)
print *, "Infinite spherical potential well"
print *, "Mesh parameters (r_min, r_max, a, N):"
print "(ES10.2, F10.2, ES10.2, I10)", r_min, r_max, a, NN
print *
print "(A3, A3, A15, A15, A10)", "n", "l", "E", "E_exact", "Error"
print *
do n = 1, 7
    do l = 0, n-1
        relat = 0
        E_exact = (zeros(n-l, l) / r_max)**2 / 2
        Ein = 10
        Emin_init = 0
        Emax_init = 100
        call solve_radial_eigenproblem(n, l, Ein, eps, 100, r, rp, u, &
            Z, c, relat, .false., Emin_init, Emax_init, converged, E, P, Q)
        error = abs(E - E_exact)
        if (converged /= 0) call stop_error("Not converged")
        print "(I3, I3, F15.6, F15.6, ES10.2)", n, l, E, E_exact, error
        if (error > 1e-6_dp) call stop_error("Error is higher than 1e-6")
    end do
end do
end program