c
c        This file contains a set of subroutines for the handling
c        of Legendre expansions. It contains 19 subroutines that are
c        user-callable. Following is a brief description of these
c        subroutines.
c
c   legeexps - constructs Legendre nodes, and  corresponding Gaussian
c        weights. Also constructs the matrix v converting the
c         coefficients of a legendre expansion into its values at
c         the n Gaussian nodes, and its inverse u, converting the
c         values of a function at n Gaussian nodes into the
c         coefficients of the corresponding Legendre series.
c
c   legepol - evaluates a single Legendre polynomial (together
c         with its derivative) at the user-provided point
c
c   legepols - evaluates a bunch of Legendre polynomials
c         at the user-provided point
c   legepls2 - an accelerated version of legepols, evaluating a
c         Legendre polynomials at the user-provided point; maximum
c         order of the polynomials to be evaluated is 290
c
c   legepolders - evaluates a bunch of Legendre polynomials
c         at the user-provided point, and the derivatives of the
c         said polynomials
c   legeinmt - for the user-specified n, constructs the matrices of
c        spectral indefinite integration differentiation on the n
c        Gaussian nodes on the interval [-1,1].
c
c   legeinte - computes the indefinite integral of the legendre
c        expansion polin getting the expansion polout
c
c   legediff -  differentiates the legendre expansion polin getting
c        the expansion polout
c
c   legefder - computes the value and the derivative of a Legendre
c        expansion at point X in interval [-1,1]; this subroutine
c        is not designed to be very efficient, but it does not
c        use any exdternally supplied arrays
c
c   legefde2 - the same as legefder, except it is desigmed to be
c        fairly efficient; it uses externally supplied arrays
c        that are precomputed
c
c   legeexev - computes the value of a Legendre expansion with
c        at point X in interval [-1,1]; same as legefder, but does
c        not compute the derivative of the expansion
c
c   legeexe2 - the same as legeexev, except it is desigmed to be
c        fairly efficient; it uses externally supplied arrays
c        that are precomputed
c
c   lematrin - constructs the matrix interpolating functions from
c        the n-point Gaussian grid on the interval [-1,1] to an
c        arbitrary m-point grid (the nodes of the latter are
c        user-provided)
c
c   levecin - constructs the coefficients of the standard
c        interpolation formula connecting the values of a
c        function at n Gaussian nodes on the interval [a,b] with
c        its value at the point x \in R^1
c
c   legeodev - evaluates at the point x a Legendre expansion
c        having only odd-numbered elements; this is a fairly
c        efficient code, using external arrays that are
c        precomputed
c
c   legeevev - evaluates at the point x a Legendre expansion
c        having only even-numbered elements; this is a fairly
c        efficient code, using external arrays that are
c        precomputed
c
c   legepeven - evaluates even-numbered Legendre polynomials
c        of the argument x; this is a fairly efficient code,
c        using external arrays that are precomputed
c
c   legepodd - evaluates odd-numbered Legendre polynomials
c        of the argument x; this is a fairly efficient code,
c        using external arrays that are precomputed
c
C   legefdeq - computes the value and the derivative of a
c        Legendre Q-expansion with coefficients coefs
C     at point X in interval (-1,1); please note that this is
c     the evil twin of the subroutine legefder, evaluating the
c     proper (P-function) Legendre expansion; this subroutine
c        is not designed to be very efficient, but it does not
c        use any exdternally supplied arrays
c
c   legeq - calculates the values and derivatives of a bunch
c        of Legendre Q-functions at the user-specified point
c        x on the interval (-1,1)
c
c   legeqs - calculates the value and the derivative of a single
c        Legendre Q-function at the user-specified point
c        x on the interval (-1,1)
c
c   legecfde - computes the value and the derivative of a Legendre
c        expansion with complex coefficients at point X in interval
c        [-1,1]; this subroutine is not designed to be very efficient,
c        but it does not use any exdternally supplied arrays. This is
c        a complex version of the subroutine legefder.
c
c   legecfd2 - the same as legecfde, except it is designed to be
c        fairly efficient; it uses externally supplied arrays
c        that are precomputed. This is a complex version of the
c        subroutine legefde2.
c
c   legecva2 - the same as legecfd2, except it is does not evaluate
c        the derivative of the function
c
c
        subroutine legeexps(itype,n,x,u,v,whts)
        implicit double precision (a-h,o-z)
        dimension x(1),whts(1),u(n,n),v(n,n)
c
c         this subroutine constructs the gaussiaqn nodes
c         on the interval [-1,1], and the weights for the
c         corresponding order n quadrature. it also constructs
c         the matrix v converting the coefficients
c         of a legendre expansion into its values at the n
c         gaussian nodes, and its inverse u, converting the
c         values of a function at n gaussian nodes into the
c         coefficients of the corresponding legendre series.
c         no attempt has been made to make this code efficient,
c         but its speed is normally sufficient, and it is
c         mercifully short.
c
c                 input parameters:
c
c  itype - the type of the calculation to be performed
c          itype=0 means that only the gaussian nodes are
c                  to be constructed.
c          itype=1 means that only the nodes and the weights
c                  are to be constructed
c          itype=2 means that the nodes, the weights, and
c                  the matrices u, v are to be constructed
c  n - the number of gaussian nodes and weights to be generated
c
c                 output parameters:
c
c  x - the order n gaussian nodes - computed independently
c          of the value of itype.
c  u - the n*n matrix converting the  values at of a polynomial of order
c         n-1 at n legendre nodes into the coefficients of its
c         legendre expansion - computed only in itype=2
c  v - the n*n matrix converting the coefficients
c         of an n-term legendre expansion into its values at
c         n legendre nodes (note that v is the inverse of u)
c          - computed only in itype=2
c  whts - the corresponding quadrature weights - computed only
c         if itype .ge. 1
c
c       . . . construct the nodes and the weights of the n-point gaussian
c             quadrature
c
        ifwhts=0
        if(itype. gt. 0) ifwhts=1
        call legewhts(n,x,whts,ifwhts)
c
c       construct the matrix of values of the legendre polynomials
c       at these nodes
c
        if(itype .ne. 2) return
        do 1400 i=1,n
c
        call legepols(x(i),n-1,u(1,i) )
 1400 continue
c
        do 1800 i=1,n
        do 1600 j=1,n
        v(i,j)=u(j,i)
 1600 continue
 1800 continue
c
c       now, v converts coefficients of a legendre expansion
c       into its values at the gaussian nodes. construct its
c       inverse u, converting the values of a function at
c       gaussian nodes into the coefficients of a legendre
c       expansion of that function
c
        do 2800 i=1,n
        d=1
        d=d*(2*i-1)/2
        do 2600 j=1,n
        u(i,j)=v(j,i)*whts(j)*d
 2600 continue
 2800 continue
        return
        end
c
c
c
c
c
        subroutine legewhts_old(n,ts,whts,ifwhts)
        implicit double precision (a-h,o-z)
        dimension ts(1),whts(1)
c
c        this subroutine constructs the nodes and the
c        weights of the n-point gaussian quadrature on
c        the interval [-1,1]
c
c                input parameters:
c
c  n - the number of nodes in the quadrature
c
c                output parameters:
c
c  ts - the nodes of the n-point gaussian quadrature
c  w - the weights of the n-point gaussian quadrature
c
c       . . . construct the array of initial approximations
c             to the roots of the n-th legendre polynomial
c
        eps=1.0d-14
        ZERO=0
        DONE=1
        pi=datan(done)*4
        h=pi/(2*n)
        do 1200 i=1,n
        t=(2*i-1)*h
        ts(n-i+1)=dcos(t)
1200  CONTINUE
c
c         use newton to find all roots of the legendre polynomial
c
        ts(n/2+1)=0
        do 2000 i=1,n/2
c
        xk=ts(i)
        ifout=0
        deltold=1
        do 1400 k=1,10
        call legepol(xk,n,pol,der)
        delta=-pol/der
ccccc         call prin2('delta=*',delta,1)
        xk=xk+delta
        if(abs(delta) .lt. eps) ifout=ifout+1
c
cccc        call prin2('delta=*',delta,1)

        if(ifout .eq. 3) goto 1600
 1400 continue
 1600 continue
        ts(i)=xk
        ts(n-i+1)=-xk
 2000 continue
c
c       now, use the explicit integral formulae
c       to obtain the weights
c
        if(ifwhts .eq. 0) return
        a=-1
        b=1
        do 2200 i=1,n/2+1
        call prodend(a,ts,n,i,fm)
        call prodend(b,ts,n,i,fp)
        whts(i)=fp-fm
        whts(n-i+1)=whts(i)
 2200 continue
        return
        end
c
c
c
c
c
        subroutine legewhts(n,ts,whts,ifwhts)
        implicit double precision (a-h,o-z)
        dimension ts(*),whts(*)
c
c        this subroutine constructs the nodes and the
c        weights of the n-point gaussian quadrature on
c        the interval [-1,1]
c
c                input parameters:
c
c  n - the number of nodes in the quadrature
c
c                output parameters:
c
c  ts - the nodes of the n-point gaussian quadrature
c  w - the weights of the n-point gaussian quadrature
c
c       . . . construct the array of initial approximations
c             to the roots of the n-th legendre polynomial
c
        eps=1.0d-14
        done = 1
        pi=datan(done)*4
        h=pi/(2.0d0*n)

        do i=1,n
          t=(2*i-1)*h
          ts(n-i+1)=cos(t)
        enddo

c
c         use newton to find all roots of the legendre polynomial
c
        ts(n/2+1)=0
        do 2000 i=1,n/2
c
        xk=ts(i)
        ifout=0
        deltold=1
        do 1400 k=1,10
        call legepol_sum(xk,n,pol,der,sum)
        delta=-pol/der
        xk=xk+delta
        if(abs(delta) .lt. eps) ifout=ifout+1
c
        if(ifout .eq. 3) goto 1600
 1400 continue
 1600 continue
        ts(i)=xk
        ts(n-i+1)=-xk
 2000 continue
c
c        construct the weights via the orthogonality relation
c
        if(ifwhts .eq. 0) return
c
        do 2400 i=1,(n+1)/2
        call legepol_sum(ts(i),n,pol,der,sum)
        whts(i)=1/sum
        whts(n-i+1)=whts(i)
 2400 continue
c
        return
        end
c
c
c
c
c
        subroutine legepol_sum(x,n,pol,der,sum)
        implicit double precision (a-h,o-z)
c
        done=1
        sum=0
c
        pkm1=1
        pk=x
        sum=sum+pkm1**2 /2
        sum=sum+pk**2 *(1+done/2)
c
        pk=1
        pkp1=x
c
c        if n=0 or n=1 - exit
c
        if(n .ge. 2) goto 1200

        sum=0
c
        pol=1
        der=0
        sum=sum+pol**2 /2
        if(n .eq. 0) return
c
        pol=x
        der=1
        sum=sum+pol**2*(1+done/2)
        return
 1200 continue
c
c       n is greater than 1. conduct recursion
c
        do 2000 k=1,n-1
        pkm1=pk
        pk=pkp1
        pkp1=( (2*k+1)*x*pk-k*pkm1 )/(k+1)
        sum=sum+pkp1**2*(k+1+done/2)
 2000 continue
c
c        calculate the derivative
c
        pol=pkp1
        der=n*(x*pkp1-pk)/(x**2-1)
        return
        end
c
c
c
c
c
        subroutine legepol(x,n,pol,der)
        implicit double precision (a-h,o-z)
c
        pkm1=1
        pk=x
c
        pk=1
        pkp1=x
c
c        if n=0 or n=1 - exit
c
        if(n .ge. 2) goto 1200
        pol=1
        der=0
        if(n .eq. 0) return
c
        pol=x
        der=1
        return
 1200 continue
c
c       n is greater than 1. conduct recursion
c
        do 2000 k=1,n-1
        pkm1=pk
        pk=pkp1
        pkp1=( (2*k+1)*x*pk-k*pkm1 )/(k+1)
 2000 continue
c
c        calculate the derivative
c
        pol=pkp1
        der=n*(x*pkp1-pk)/(x**2-1)
        return
        end
c
c
c
c
c
        subroutine prodend(x,xs,n,i,f)
        implicit double precision (a-h,o-z)
        dimension xs(1)
c
c      evaluate the product
c
        f=1
        dlarge=1.0d20
        dsmall=f/dlarge
c
        large=0
        do 2000 j=1,n
        dd=dabs(f)
        if( dd .gt. dsmall) goto 1200
         f=f*10000
         large=large-1
 1200 continue
c
        if( dd .lt. dlarge) goto 1400
        f=f/10000
        large=large+1
 1400 continue
        if(j .eq. i) goto 2000
        f=f*(x-xs(j))/(xs(i)-xs(j))
 2000 continue
        d10000=10000
        f=f*d10000**large
        f=f**2*(x-xs(i))
        return
        end
c
c
c
c
c
        subroutine legepols(x,n,pols)
        implicit double precision (a-h,o-z)
        dimension pols(*)
c
        pkm1=1
        pk=x
c
        pk=1
        pkp1=x
c
c
c        if n=0 or n=1 - exit
c
        if(n .ge. 2) goto 1200
        pols(1)=1
        if(n .eq. 0) return
c
        pols(2)=x
        return
 1200 continue
c
        pols(1)=1
        pols(2)=x
c
c       n is greater than 2. conduct recursion
c
        do 2000 k=1,n-1
        pkm1=pk
        pk=pkp1
        pkp1=( (2*k+1)*x*pk-k*pkm1 )/(k+1)
        pols(k+2)=pkp1
 2000 continue
c
        return
        end

c
c
c
c
c
      SUBROUTINE legepolders(X,VALs,ders,N)
      IMPLICIT double precision (A-H,O-Z)
      double precision vals(*),ders(*)
C
C     This subroutine computes the values and the derivatives
c     of n+1 first Legendre polynomials at the point x
C     in interval [-1,1].
c
c                input parameters:
c
C     X = evaluation point
C     N  = order of expansion
c   IMPORTANT NOTE: n is {\bf the order of the expansion, which is
c         one less than the number of terms in the expansion!!}
c
c                output parameters:
c
C     VALs = computed values of Legendre polynomials
C     ders = computed values of the derivatives
C
C

        done=1
        pjm2=1
        pjm1=x
        derjm2=0
        derjm1=1
c
        vals(1)=1
        ders(1)=0
c
        vals(2)=x
        ders(2)=1
c
        DO 600 J = 2,N
c
        pj= ( (2*j-1)*x*pjm1-(j-1)*pjm2 ) / j
        derj=(2*j-1)*(pjm1+x*derjm1)-(j-1)*derjm2
c
        derj=derj/j

        vals(j+1)=pj
        ders(j+1)=derj
c
        pjm2=pjm1
        pjm1=pj
        derjm2=derjm1
        derjm1=derj
 600   CONTINUE
c
      RETURN
      END
c
c
c
c
c
        subroutine legepls2(x,n,pols)
        implicit double precision (a-h,o-z)
        dimension pols(*),pjcoefs1(2000),pjcoefs2(300)
        save
        data ifcalled/0/
c
c        if need be - initialize the arrays pjcoefs1, pjcoefs2
c
        if(ifcalled .eq. 1) goto 1100
c
        done=1
        ninit=290
        do 1050 j=2,ninit
c
        pjcoefs1(j)=(2*j-done)/j
        pjcoefs2(j)=-(j-done)/j
c
 1050 continue
c
        ifcalled=1
 1100 continue

        pkm1=1
        pk=x
c
        pk=1
        pkp1=x
c
c        if n=0 or n=1 - exit
c
        if(n .ge. 2) goto 1200
        pols(1)=1
        if(n .eq. 0) return
c
        pols(2)=x
        return
 1200 continue
c
        pols(1)=1
        pols(2)=x
c
c       n is greater than 2. conduct recursion
c
        do 2000 k=1,n-1
        pkm1=pk
        pk=pkp1
        pkp1=x*pk*pjcoefs1(k+1)+pkm1*pjcoefs2(k+1)
        pols(k+2)=pkp1
 2000 continue
c
        return
        end
c
c
c
c
c
        subroutine legeinmt(n,ainte,adiff,x,whts,endinter,
     1      itype,w)
        implicit double precision (a-h,o-z)
        dimension ainte(1),w(1),x(1),whts(1),adiff(1),endinter(1)
c
c
c        for the user-specified n, this subroutine constructs
c        the matrices of spectral indefinite integration and/or
c        spectral differentiation on the n Gaussian nodes
c        on the interval [-1,1]. Actually, this is omnly a
c        memory management routine. All the actual work is done
c        by the subroutine legeinm0 (see)
c
c                           input parameters:
c
c  n - the number of Gaussian nodes on the interval [-1,1]
c  itype - the type of the calculation to be performed
c          EXPLANATION:
c       itype=1 means that only the matrix ainte will
c               be constructed
c       itype=2 means that only the matrix adiff will
c               be constructed
c       itype=3 means that both matrices ainte and adiff
c               will be constructed
c
c                           output paramaters:
c
c  ainte - the matrix of spectral indefinite integration on
c          the Gaussian nodes
c  adiff - the matrix of spectral differentiation on
c          the Gaussian nodes
c  x - the n Gaussian nodes on the intervl [-1,1]
c  whts - the n Gaussian weights on the interval [-1,1]
c  endinter - the interpolation coefficients converting the
c          values of a function at n Gaussian nodes into its
c          value at 1 (the right end of the interval)
c
c                           work arrays:
c
c  w - must be 3* n**2 + 2*n +50 *8 locations long
c
c        . . . allocate memory for the construction of the integrating
c              matrix
c
        ipolin=1
        lpolin=n+5
c
        ipolout=ipolin+lpolin
        lpolout=n+5
c
        iu=ipolout+lpolout
        lu=n**2+1
c
        iv=iu+lu
        lv=n**2+1
c
        iw=iv+lv
        lw=n**2+1
c
        ltot=iw+lw
c
c        construct the integrating matrix
c
        call legeinm0(n,ainte,adiff,w(ipolin),w(ipolout),
     1      x,whts,w(iu),w(iv),w(iw),itype,endinter)
c
        return
        end
c
c
c
c
c
        subroutine legeinm0(n,ainte,adiff,polin,polout,
     1      x,whts,u,v,w,itype,endinter)
        implicit double precision (a-h,o-z)
        dimension ainte(n,n),u(n,n),v(n,n),w(n,n),
     1      endinter(1),x(n),whts(n),polin(n),polout(n),
     2      adiff(n,n)
c
c        for the user-specified n, this subroutine constructs
c        the matrices of spectral indefinite integration and/or
c        spectral differentiation on the n Gaussian nodes
c        on the interval [-1,1]
c
c                           input parameters:
c
c  n - the number of Gaussian nodes on the interval [-1,1]
c  itype - the type of the calculation to be performed
c          EXPLANATION:
c       itype=1 means that only the matrix ainte will
c               be constructed
c       itype=2 means that only the matrix adiff will
c               be constructed
c       itype=3 means that both matrices ainte and adiff
c               will be constructed
c
c                           output paramaters:
c
c  ainte - the matrix of spectral indefinite integration on
c          the Gaussian nodes
c  adiff - the matrix of spectral differentiation on
c          the Gaussian nodes
c  x - the n Gaussian nodes on the intervl [-1,1]
c  whts - the n Gaussian weights on the interval [-1,1]
c
c                           work arrays:
c
c  polin, polout - must be n+3 double precision locations each
c
c  u, v, w - must be n**2+1 double precision locations each
c
c        . . . construct the matrices of the forward and inverse
c              Legendre transforms
c
        itype2=2
        call legeexps(itype2,n,x,u,v,whts)
c
cccc         call prin2('after legeexps, u=*',u,n*n)
c
c        if the user so requested,
c        construct the matrix converting the coefficients of
c        the Legendre series of a function into the coefficients
c        of the indefinite integral of that function
c
        if(itype. eq. 2) goto 2000
c
        do 1600 i=1,n
c
        do 1200 j=1,n+2
        polin(j)=0
 1200 continue
c
        polin(i)=1
c
        call legeinte(polin,n,polout)
c
        do 1400 j=1,n
        ainte(j,i)=polout(j)
 1400 continue
c
 1600 continue
c
cccc         call prin2('ainte initially is*',ainte,n*n)
c
c        multiply the three, obtaining the integrating matrix
c
        call matmul(ainte,u,w,n)
        call matmul(v,w,ainte,n)
c
 2000 continue
c
c        if the user so requested,
c        construct the matrix converting the coefficients of
c        the Legendre series of a function into the coefficients
c        of the derivative of that function
c
        if(itype. eq. 1) goto 3000
c
        do 2600 i=1,n
c
        do 2200 j=1,n+2
        polin(j)=0
 2200 continue
c
        polin(i)=1
c
        call legediff(polin,n,polout)
c
        do 2400 j=1,n
        adiff(j,i)=polout(j)
cccc        ainte(i,j)=polout(j)
 2400 continue
c
 2600 continue
c
cccc         call prin2('adiff initially is*',adiff,n*n)
c
c        multiply the three, obtaining the integrating matrix
c
        call matmul(adiff,u,w,n)
        call matmul(v,w,adiff,n)
c
 3000 continue
c
c        construct the vector of interpolation coefficients
c        converting the values of a polynomial at the Gaussian
c        nodes into its value at the right end of the interval
c
        do 3400 i=1,n
c
        d=0
        do 3200 j=1,n
        d=d+u(j,i)
 3200 continue
        endinter(i)=d
 3400 continue
c
        return
        end
c
c
c
c
c
        subroutine legeinte(polin,n,polout)
        implicit double precision (a-h,o-z)
        dimension polin(*),polout(*)
c
c       this subroutine computes the indefinite integral of the
c       legendre expansion polin getting the expansion polout
c
c
c                       input parameters:
c
c  polin - the legendre expansion to be integrated
c  n - the order of the expansion polin
c   IMPORTANT NOTE: n is {\bf the order of the expansion, which is
c         one less than the number of terms in the expansion!!}
c         also nothe that the order of the integrated expansion is
c         n+1 (who could think!)
c
c                       output parameters:
c
c  polout - the legendre expansion of the integral of the function
c         represented by the expansion polin
c
        do 1200 i=1,n+2
        polout(i)=0
 1200 continue
c
        do 2000 k=2,n+1
        j=k-1
c
cccc        polout(k+1)=polin(k)/(2*j+1)+polout(k+1)
        polout(k+1)=polin(k)/(2*j+1)
        polout(k-1)=-polin(k)/(2*j+1)+polout(k-1)
c
 2000 continue
c
        polout(2)=polin(1)+polout(2)
c
        dd=0
        sss=-1
        do 2200 k=2,n+1
c
        dd=dd+polout(k)*sss
        sss=-sss
 2200 continue
c
ccc        call prin2('dd=*',dd,1)
        polout(1)=-dd
c
        return
        end
c
c
c
c
c
        subroutine legediff(polin,n,polout)
        implicit double precision (a-h,o-z)
        dimension polin(1),polout(1)
c
c       this subroutine differentiates the legendre
c       expansion polin getting the expansion polout
c
c
c                       input parameters:
c
c  polin - the legendre expansion to be differentiated
c  n - the order of the expansion polin
c   IMPORTANT NOTE: n is {\bf the order of the expansion, which is
c         one less than the number of terms in the expansion!!}
c         also nothe that the order of the integrated expansion is
c         n+1 (who could think!)
c
c                       output parameters:
c
c  polout - the legendre expansion of the derivative of the function
c         represented by the expansion polin
c
        do 1200 k=1,n+1
        polout(k)=0
 1200 continue
c
        pk=polin(n+1)
        pkm1=polin(n)
        pkm2=0
        do 2000 k=n+1,2,-1
c
        j=k-1
c
        polout(k-1)=pk*(2*j-1)
        if(k .ge. 3) pkm2=polin(k-2)+pk
c
        pk=pkm1
        pkm1=pkm2
c
 2000 continue
         return
         end
c
c
c
c
c
      SUBROUTINE legeFDER(X,VAL,der,PEXP,N)
      IMPLICIT double precision (A-H,O-Z)
      double precision PEXP(*)
C
C     This subroutine computes the value and the derivative
c     of a gaussian expansion with coefficients PEXP
C     at point X in interval [-1,1].
c
c                input parameters:
c
C     X = evaluation point
C     PEXP = expansion coefficients
C     N  = order of expansion
c   IMPORTANT NOTE: n is {\bf the order of the expansion, which is
c         one less than the number of terms in the expansion!!}
c
c                output parameters:
c
C     VAL = computed value
C     der = computed value of the derivative
C
C

        done=1
        pjm2=1
        pjm1=x
        derjm2=0
        derjm1=1
c
        val=pexp(1)*pjm2+pexp(2)*pjm1
        der=pexp(2)
c
        DO 600 J = 2,N
c
        pj= ( (2*j-1)*x*pjm1-(j-1)*pjm2 ) / j
        val=val+pexp(j+1)*pj
c
        derj=(2*j-1)*(pjm1+x*derjm1)-(j-1)*derjm2
c
        derj=derj/j
        der=der+pexp(j+1)*derj
c
        pjm2=pjm1
        pjm1=pj
        derjm2=derjm1
        derjm1=derj
 600   CONTINUE
c
      RETURN
      END

c
c
c
c
c
      SUBROUTINE legeFDE2(X,VAL,der,PEXP,N,
     1    pjcoefs1,pjcoefs2,ninit)
      IMPLICIT double precision (A-H,O-Z)
      double precision PEXP(*),pjcoefs1(*),pjcoefs2(*)
c
C     This subroutine computes the value and the derivative
c     of a gaussian expansion with coefficients PEXP
C     at point X in interval [-1,1].
c
c                input parameters:
c
C  X - evaluation point
C  PEXP - expansion coefficients
C  N  - order of expansion
c  pjcoefs1, pjcoefs2 - two arrays precomputed on a previous call
c      on a previous call to this subroutine. Please note that this
c      is only an input parameter if the parameter ninit (see below)
c      has been set to 0; otherwise, these are output parameters
c  ninit - tells the subroutine whether and to what maximum order the
c       arrays coepnm1,coepnp1,coexpnp1 should be initialized.
c     EXPLANATION: The subroutine will initialize the first ninit
c       elements of each of the arrays pjcoefs1, pjcoefs2. On the first
c       call to this subroutine, ninit should be set to the maximum
c       order n for which this subroutine might have to be called;
c       on subsequent calls, ninit should be set to 0. PLEASE NOTE
c       THAT THAT THESE ARRAYS USED BY THIS SUBROUTINE
c       ARE IDENTICAL TO THE ARRAYS WITH THE SAME NAMES USED BY THE
c       SUBROUTINE LEGEEXE2. If these arrays have been initialized
c       by one of these two subroutines, they do not need to be
c       initialized by the other one.
c
c   IMPORTANT NOTE: n is {\bf the order of the expansion, which is
c         one less than the number of terms in the expansion!!}
c
c                output parameters:
c
C  VAL - computed value
C  der - computed value of the derivative
C
C
        if(ninit .eq. 0) goto 1400
c
        done=1
        do 1200 j=2,ninit
c
        pjcoefs1(j)=(2*j-done)/j
        pjcoefs2(j)=-(j-done)/j
c
 1200 continue
c
        ifcalled=1
 1400 continue
c
        pjm2=1
        pjm1=x
        derjm2=0
        derjm1=1
c
        val=pexp(1)*pjm2+pexp(2)*pjm1
        der=pexp(2)
c
        DO 1600 J = 2,N
c
cccc        pj= ( (2*j-1)*x*pjm1-(j-1)*pjm2 ) / j
c
        pj= pjcoefs1(j)*x*pjm1+pjcoefs2(j)*pjm2

        val=val+pexp(j+1)*pj
c
cccc        derj=(2*j-1)*(pjm1+x*derjm1)-(j-1)*derjm2
        derj=pjcoefs1(j)*(pjm1+x*derjm1)+pjcoefs2(j)*derjm2

ccc         call prin2('derj=*',derj,1)

cccc        derj=derj/j
        der=der+pexp(j+1)*derj
c
        pjm2=pjm1
        pjm1=pj
        derjm2=derjm1
        derjm1=derj
 1600   CONTINUE
c
      RETURN
      END
c
c
c
c
c
      SUBROUTINE legeexev(X,VAL,PEXP,N)
      IMPLICIT double precision (A-H,O-Z)
      double precision PEXP(*)
C
C     This subroutine computes the value o a Legendre
c     expansion with coefficients PEXP at point X in interval [-1,1]
C
c                input parameters:
c
C     X = evaluation point
C     PEXP = expansion coefficients
C     N  = order of expansion
c   IMPORTANT NOTE: n is {\bf the order of the expansion, which is
c         one less than the number of terms in the expansion!!}
c
c                output parameters:
c
C     VAL = computed value
C
        done=1
        pjm2=1
        pjm1=x
c
        val=pexp(1)*pjm2+pexp(2)*pjm1
        der=pexp(2)
c
        DO 600 J = 2,N
c
        pj= ( (2*j-1)*x*pjm1-(j-1)*pjm2 ) / j
        val=val+pexp(j+1)*pj
c
        pjm2=pjm1
        pjm1=pj
 600   CONTINUE
c
        RETURN
        END
c
c
c
c
c
      SUBROUTINE legeexe2(X,VAL,PEXP,N,
     1      pjcoefs1,pjcoefs2,ninit)
      IMPLICIT double precision (A-H,O-Z)
      double precision PEXP(*),pjcoefs1(*),pjcoefs2(*)
c
C     This subroutine computes the value o a Legendre
c     expansion with coefficients PEXP at point X in interval [-1,1]
C
c                input parameters:
c
C     X = evaluation point
C     PEXP = expansion coefficients
C     N  = order of expansion
c   IMPORTANT NOTE: n is {\bf the order of the expansion, which is
c         one less than the number of terms in the expansion!!}
c
c                output parameters:
c
C     VAL = computed value
C
        done=1
        if(ninit .eq. 0) goto 1400
c
        done=1
        do 1200 j=2,ninit
c
        pjcoefs1(j)=(2*j-done)/j
        pjcoefs2(j)=-(j-done)/j
c
 1200 continue
c
        ifcalled=1
 1400 continue
c
        pjm2=1
        pjm1=x
c
        val=pexp(1)*pjm2+pexp(2)*pjm1
        der=pexp(2)
c
        DO 600 J = 2,N
c
        pj= pjcoefs1(j)*x*pjm1+pjcoefs2(j)*pjm2

cccc        pj= ( (2*j-1)*x*pjm1-(j-1)*pjm2 ) / j
        val=val+pexp(j+1)*pj
c
        pjm2=pjm1
        pjm1=pj
 600   CONTINUE
c
        RETURN
        END
c
c
c
c
c
        subroutine lematrin(n,m,xs,amatrint,ts,w)
        implicit double precision (a-h,o-z)
        dimension amatrint(m,n),xs(1),w(1),ts(1)
c
c
c        This subroutine constructs the matrix interpolating
c        functions from the n-point Gaussian grid on the interval [-1,1]
c        to an arbitrary m-point grid (the nodes of the latter are
c        user-provided)
c
c                 Input parameters:
c
c  n - the number of interpolation nodes
c  m - the number of nodes to which the functions will be interpolated
c  xs - the points at which the function is to be interpolated
c
c                  Output parameters:
c
c  amatrint - the m \times n matrix conerting the values of a function
c        at the n Legendre nodes into its values at m user-specified
c        (arbitrary) nodes
c  ts - the n Gaussian nodes on the interval [-1,1]
c
c                  Work arrays:
c
c  w - must be at least 2*n**2+n + 100 double precision locations long
c

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

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

c
c
c
c
c
        subroutine legeodev(x,nn,coefs,val,ninit,
     1      coepnm1,coepnp1,coexpnp1)
        implicit double precision (a-h,o-z)
        dimension coepnm1(1),coepnp1(1),
     1            coexpnp1(1),coefs(*)
c
c
c       This subroutine evaluates at the point x a Legendre expansion
c       having only odd-numbered elements
c
c                  Input parameters:
c
c  x - point on the interval [-1,1] at which the Legendre expansion
c       is to be evaluated
c  nn - order of the expansion to be evaluated
c  coefs - odd-numbered coefficients of the Legendre expansion
c       to be evaluated at the point x (nn/2+2 of them things)
c  ninit - tells the subroutine whether and to what maximum order the
c       arrays coepnm1,coepnp1,coexpnp1 should be initialized.
c     EXPLANATION: The subroutine will initialize the first ninit/2+2
c                  (or so) elements of each of the arrays  coepnm1,
c       coepnp1, coexpnp1. On the first call to this subroutine, ninit
c       should be set to the maximum order nn for which this subroutine
c       might have to be called; on subsequent calls, ninit should be
c       set to 0. PLEASE NOTE THAT THAT THESE ARRAYS USED BY THIS SUBROUTINE
c       ARE IDENTICAL TO THE ARRAYS WITH THE SAME NAMES USED BY THE
c       SUBROUTINE LEGEPODD. IF these arrays have been initialized
c       by one of these two subroutines, they do not need to be
c       initialized by the other one.
c  coepnm1,coepnp1,coexpnp1 - should be nn/2+4 double precision elements long
c       each. Please note that these are input arrays only if ninit
c       (see above) has been set to 0; otherwise, these are output arrays.
c
c                  Output parameters:
c
c  val - the value at the point x of the Legendre expansion with
c       coefficients coefs (see above)
c    EXPLANATION: On exit from the subroutine, pols(1) = P_0 (x),
c       pols(2) = P_2(x), pols(3) =P_4(x),  etc.
c  coepnm1,coepnp1,coexpnp1 - should be nn/2+4 double precision elements long
c       each. Please note that these are output parameters only if ninit
c       (see above) has not been set to 0; otherwise, these are input
c       parameters
c
c
        if(ninit .eq. 0) goto 1400
        done=1
        n=0
        i=0
c
        do 1200 nnn=2,ninit,2
c
        n=n+2
        i=i+1
c
        coepnm1(i)=-(5*n+7*(n*done)**2+2*(n*done)**3)
        coepnp1(i)=-(9+24*n+18*(n*done)**2+4*(n*done)**3)
        coexpnp1(i)=15+46*n+36*(n*done)**2+8*(n*done)**3
c
        d=(2+n*done)*(3+n*done)*(1+2*n*done)
        coepnm1(i)=coepnm1(i)/d
        coepnp1(i)=coepnp1(i)/d
        coexpnp1(i)=coexpnp1(i)/d
c
 1200 continue
c
 1400 continue
c
        x22=x**2
c
        pi=x
        pip1=x*(2.5d0*x22-1.5d0)
c
        val=coefs(1)*pi+coefs(2)*pip1

        do 2000 i=1,nn/2-2
c
        pip2 = coepnm1(i)*pi +
     1      (coepnp1(i)+coexpnp1(i)*x22)*pip1
c
        val=val+coefs(i+2)*pip2
c
        pi=pip1
        pip1=pip2

 2000 continue
c
        return
        end
c
c
c
c
c
        subroutine legeevev(x,nn,coefs,val,ninit,
     1      coepnm1,coepnp1,coexpnp1)
        implicit double precision (a-h,o-z)
        dimension coepnm1(1),coepnp1(1),
     1            coexpnp1(1),coefs(*)
c
c
c       This subroutine evaluates at the point x a Legendre expansion
c       having only even-numbered elements
c
c                  Input parameters:
c
c  x - point on the interval [-1,1] at which the Legendre expansion
c       is to be evaluated
c  nn - order of the expansion to be evaluated
c  coefs - even-numbered coefficients of the Legendre expansion
c       to be evaluated at the point x (nn/2+2 of them things)
c  ninit - tells the subroutine whether and to what maximum order the
c       arrays coepnm1,coepnp1,coexpnp1 should be initialized.
c     EXPLANATION: The subroutine will initialize the first ninit/2+2
c                  (or so) elements of each of the arrays  coepnm1,
c       coepnp1, coexpnp1. On the first call to this subroutine, ninit
c       should be set to the maximum order nn for which this subroutine
c       might have to be called; on subsequent calls, ninit should be
c       set to 0. PLEASE NOTE THAT THAT THESE ARRAYS USED BY THIS SUBROUTINE
c       ARE IDENTICAL TO THE ARRAYS WITH THE SAME NAMES USED BY THE
c       SUBROUTINE LEGEPEVEN. IF these aqrrays have been initialized
c       by one of these two subroutines, they do not need to be
c       initialized by the other one.
c  coepnm1,coepnp1,coexpnp1 - should be nn/2+4 double precision elements long
c       each. Please note that these are input arrays only if ninit
c       (see above) has been set to 0; otherwise, these are output arrays.
c
c                  Output parameters:
c
c  val - the value at the point x of the Legendre expansion with
c       coefficients coefs (see above)
c    EXPLANATION: On exit from the subroutine, pols(1) = P_0 (x),
c       pols(2) = P_2(x), pols(3) =P_4(x),  etc.
c  coepnm1,coepnp1,coexpnp1 - should be nn/2+4 double precision elements long
c       each. Please note that these are output parameters only if ninit
c       (see above) has not been set to 0; otherwise, these are input
c       parameters
c
        if(ninit .eq. 0) goto 1400
c
        done=1
        n=-1
        i=0
        do 1200 nnn=1,ninit,2
c
        n=n+2
        i=i+1
c
        coepnm1(i)=-(5*n+7*(n*done)**2+2*(n*done)**3)
        coepnp1(i)=-(9+24*n+18*(n*done)**2+4*(n*done)**3)
        coexpnp1(i)=15+46*n+36*(n*done)**2+8*(n*done)**3
c
        d=(2+n*done)*(3+n*done)*(1+2*n*done)
        coepnm1(i)=coepnm1(i)/d
        coepnp1(i)=coepnp1(i)/d
        coexpnp1(i)=coexpnp1(i)/d
c
 1200 continue
c
 1400 continue
c
        x22=x**2
c
        pi=1
        pip1=1.5d0*x22-0.5d0
c
        val=coefs(1)+coefs(2)*pip1
c
c       n is greater than 2. conduct recursion
c
        do 2000 i=1,nn/2-2
c
        pip2 = coepnm1(i)*pi +
     1      (coepnp1(i)+coexpnp1(i)*x22) *pip1
        val=val+coefs(i+2)*pip2
c
        pi=pip1
        pip1=pip2
c
 2000 continue
c
        return
        end
c
c
c
c
c
        subroutine legepeven(x,nn,pols,ninit,
     1      coepnm1,coepnp1,coexpnp1)
        implicit double precision (a-h,o-z)
        dimension pols(*),coepnm1(*),coepnp1(*),
     1            coexpnp1(*)
c
c       This subroutine evaluates even-numbered Legendre polynomials
c       of the argument x, up to order nn+1
c
c                  Input parameters:
c
c  x - the argument for which the Legendre polynomials are
c       to be evaluated
c  nn - the maximum order for which the Legendre polynomials are
c       to be evaluated
c  ninit - tells the subroutine whether and to what maximum order the
c       arrays coepnm1,coepnp1,coexpnp1 should be initialized.
c     EXPLANATION: The subroutine ill initialize the first ninit/2+2
c                  (or so) elements of each of the arrays  coepnm1,
c       coepnp1, coexpnp1. On the first call to this subroutine, ninit
c       should be set to the maximum order nn for which this subroutine
c       might have to be called; on subsequent calls, ninit should be
c       set to 0.
c  coepnm1,coepnp1,coexpnp1 - should be nn/2+4 double precision elements long
c       each. Please note that these are input arrays only if ninit
c       (see above) has been set to 0; otherwise, these are output arrays.
c       PLEASE NOTE THAT THAT THESE ARRAYS USED BY THIS SUBROUTINE
c       ARE IDENTICAL TO THE ARRAYS WITH THE SAME NAMES USED BY THE
c       SUBROUTINE LEGEEVEV. IF these aqrrays have been initialized
c       by one of these two subroutines, they do not need to be
c       initialized by the other one.
c
c                  Output parameters:
c
c  pols - even-numbered Legendre polynomials of the input parameter x
c         (nn/2+2 of them things)
c    EXPLANATION: On exit from the subroutine, pols(1) = P_0 (x),
c       pols(2) = P_2(x), pols(3) =P_4(x),  etc.
c  coepnm1,coepnp1,coexpnp1 - should be nn/2+4 double precision elements long
c       each. Please note that these are output parameters only if ninit
c       (see above) has not been set to 0; otherwise, these are input
c       parameters. PLEASE NOTE THAT THAT THESE ARRAYS USED BY THIS SUBROUTINE
c       ARE IDENTICAL TO THE ARRAYS WITH THE SAME NAMES USED BY THE
c       SUBROUTINE LEGEEVEV. If these arrays have been initialized
c       by one of these two subroutines, they do not need to be
c       initialized by the other one.
c
c
        if(ninit .eq. 0) goto 1400
c
        done=1
        n=-1
        i=0
        do 1200 nnn=1,ninit,2
c
        n=n+2
        i=i+1
c
        coepnm1(i)=-(5*n+7*(n*done)**2+2*(n*done)**3)
        coepnp1(i)=-(9+24*n+18*(n*done)**2+4*(n*done)**3)
        coexpnp1(i)=15+46*n+36*(n*done)**2+8*(n*done)**3
c
        d=(2+n*done)*(3+n*done)*(1+2*n*done)
        coepnm1(i)=coepnm1(i)/d
        coepnp1(i)=coepnp1(i)/d
        coexpnp1(i)=coexpnp1(i)/d
c
 1200 continue
c
 1400 continue
c
        x22=x**2
c
        pols(1)=1
        pols(2)=1.5d0*x22-0.5d0
c
c       n is greater than 2. conduct recursion
c
        do 2000 i=1,nn/2
c
        pols(i+2) = coepnm1(i)*pols(i) +
     1      (coepnp1(i)+coexpnp1(i)*x22) *pols(i+1)
c
 2000 continue
c
        return
        end
c
c
c
c
c
        subroutine legepodd(x,nn,pols,ninit,
     1      coepnm1,coepnp1,coexpnp1)
        implicit double precision (a-h,o-z)
        dimension pols(*),coepnm1(1),coepnp1(1),
     1            coexpnp1(1)
c
c       This subroutine evaluates odd-numbered Legendre polynomials
c       of the argument x, up to order nn+1
c
c                  Input parameters:
c
c  x - the argument for which the Legendre polynomials are
c       to be evaluated
c  nn - the maximum order for which the Legendre polynomials are
c       to be evaluated
c  ninit - tells the subroutine whether and to what maximum order the
c       arrays coepnm1,coepnp1,coexpnp1 should be initialized.
c     EXPLANATION: The subroutine will initialize the first ninit/2+2
c                  (or so) elements of each of the arrays  coepnm1,
c       coepnp1, coexpnp1. On the first call to this subroutine, ninit
c       should be set to the maximum order nn for which this subroutine
c       might have to be called; on subsequent calls, ninit should be
c       set to 0.
c  coepnm1,coepnp1,coexpnp1 - should be nn/2+4 double precision elements long
c       each. Please note that these are input arrays only if ninit
c       (see above) has been set to 0; otherwise, these are output arrays.
c
c                  Output parameters:
c
c  pols - the odd-numbered Legendre polynomials of the input parameter x
c         (nn/2+2 of them things)
c    EXPLANATION: On exit from the subroutine, pols(1) = P_1(x),
c       pols(2) = P_3(x), pols(3) = P_5 (x), etc.
c  coepnm1,coepnp1,coexpnp1 - should be nn/2+4 double precision elements long
c       each. Please note that these are output parameters only if ninit
c       (see above) has not been set to 0; otherwise, these are input
c       parameters. PLEASE NOTE THAT THAT THESE ARRAYS USED BY THIS
c       SUBROUTINE ARE IDENTICAL TO THE ARRAYS WITH THE SAME NAMES
c       SUSED BY THE UBROUTINE LEGEODEV. IF these arrays have been
c       initialized by one of these two subroutines, they do not need
c       to be initialized by the other one.
c
        if(ninit .eq. 0) goto 1400
        done=1
        n=0
        i=0
c
        do 1200 nnn=2,ninit,2
c
        n=n+2
        i=i+1
c
        coepnm1(i)=-(5*n+7*(n*done)**2+2*(n*done)**3)
        coepnp1(i)=-(9+24*n+18*(n*done)**2+4*(n*done)**3)
        coexpnp1(i)=15+46*n+36*(n*done)**2+8*(n*done)**3
c
        d=(2+n*done)*(3+n*done)*(1+2*n*done)
        coepnm1(i)=coepnm1(i)/d
        coepnp1(i)=coepnp1(i)/d
        coexpnp1(i)=coexpnp1(i)/d
c
 1200 continue
c
 1400 continue
c
        x22=x**2
c
        pols(1)=x
        pols(2)=x*(2.5d0*x22-1.5d0)
c
        do 2000 i=1,nn/2
c
        pols(i+2) = coepnm1(i)*pols(i) +
     1      (coepnp1(i)+coexpnp1(i)*x22)*pols(i+1)
c
 2000 continue
c
        return
        end
c
c
c
c
c
        subroutine legefdeq(x,val,der,coefs,n)
        implicit double precision (a-h,o-z)
        dimension coefs(*)
C
C     This subroutine computes the value and the derivative
c     of a Legendre Q-expansion with coefficients coefs
C     at point X in interval (-1,1); please note that this is
c     the evil twin of the subroutine legefder, evaluating the
c     proper (P-function) Legendre expansion
c
c                input parameters:
c
C  X = evaluation point
C  coefs = expansion coefficients
C  N  = order of expansion
c
c   IMPORTANT NOTE: n is {\bf the order of the expansion, which is
c         one less than the number of terms in the expansion!!}
c
c                output parameters:
c
C     VAL = computed value
C     der = computed value of the derivative
C
c
        val=0
        der=0
c
        d= log( (1+x) /(1-x) ) /2
        pkm1=d
        pk=d*x-1
c
        pk=d
        pkp1=d*x-1

        derk=(1/(1+x)+1/(1-x)) /2
        derkp1=d + derk *x
c
        val=coefs(1)*pk+coefs(2)*pkp1
        der=coefs(1)*derk+coefs(2)*derkp1
c
c        if n=0 or n=1 - exit
c
        if(n .ge. 2) goto 1200
c
        if(n .eq. 0) return
c
        return
 1200 continue
c
c       n is greater than 2. conduct recursion
c
        do 2000 k=1,n-1
        pkm1=pk
        pk=pkp1
c
        pkp1=( (2*k+1)*x*pk-k*pkm1 )/(k+1)
c
        derkm1=derk
        derk=derkp1
c
        derkp1= ( (2*k+1)*pk+(2*k+1)*x*derk - k*derkm1 )/(k+1)
c
        val=val+coefs(k+2)*pkp1
        der=der+coefs(k+2)*derkp1
c
 2000 continue
c
        return
        end
c
c
c
c
c
        subroutine legeqs(x,n,pols,ders)
        implicit double precision (a-h,o-z)
        dimension pols(*),ders(*)
c
c       This subroutine calculates the values and derivatives of
c       a bunch of Legendre Q-functions at the user-specified point
c       x on the interval (-1,1)
c
c                     Input parameters:
c
c  x - the point on the interval [-1,1] where the Q-functions and
c       their derivatives are to be evaluated
c  n - the highest order for which the functions are to be evaluated
c
c                     Output parameters:
c
c  pols - the values of the Q-functions (the evil twins of the
c       Legeendre polynomials) at the point x (n+1 of them things)
c  ders - the derivatives of the Q-functions (the evil twins of the
c       Legeendre polynomials) at the point x (n+1 of them things)
c
c
        d= log( (1+x) /(1-x) ) /2
        pkm1=d
        pk=d*x-1
c
        pk=d
        pkp1=d*x-1

        derk=(1/(1+x)+1/(1-x)) /2
        derkp1=d + derk *x
c
c        if n=0 or n=1 - exit
c
        if(n .ge. 2) goto 1200
        pols(1)=pk
        ders(1)=derk
        if(n .eq. 0) return
c
        pols(2)=pkp1
        ders(2)=derkp1
        return
 1200 continue
c
        pols(1)=pk
        pols(2)=pkp1
c
c       n is greater than 2. conduct recursion
c
        ders(1)=derk
        ders(2)=derkp1
c
        do 2000 k=1,n-1
        pkm1=pk
        pk=pkp1
c
        pkp1=( (2*k+1)*x*pk-k*pkm1 )/(k+1)
        pols(k+2)=pkp1
c
        derkm1=derk
        derk=derkp1
c
        derkp1= ( (2*k+1)*pk+(2*k+1)*x*derk - k*derkm1 )/(k+1)
        ders(k+2)=derkp1
 2000 continue
c
        return
        end
c
c
c
c
c

        subroutine legeq(x,n,pol,der)
        implicit double precision (a-h,o-z)
c
c       This subroutine calculates the value and derivative of
c       a Legendre Q-function at the user-specified point
c       x on the interval (-1,1)
c
c
c                     Input parameters:
c
c  x - the point on the interval [-1,1] where the Q-functions and
c       their derivatives are to be evaluated
c  n - the order for which the function is to be evaluated
c
c                     Output parameters:
c
c  pol - the value of the n-th Q-function (the evil twin of the
c       Legeendre polynomial) at the point x
c  ders - the derivatives of the Q-function at the point x
c
c
        d= log( (1+x) /(1-x) ) /2
        pk=d
        pkp1=d*x-1
c
c        if n=0 or n=1 - exit
c
        if(n .ge. 2) goto 1200
        pol=d

        der=(1/(1+x)+1/(1-x)) /2

        if(n .eq. 0) return
c
        pol=pkp1
        der=d + der *x
        return
 1200 continue
c
c       n is greater than 1. conduct recursion
c
        do 2000 k=1,n-1
        pkm1=pk
        pk=pkp1
        pkp1=( (2*k+1)*x*pk-k*pkm1 )/(k+1)
 2000 continue
c
c        calculate the derivative
c
        pol=pkp1
        der=n*(x*pkp1-pk)/(x**2-1)
        return
        end

c
c
c
c
c
      SUBROUTINE legecFDE(X,VAL,der,PEXP,N)
      IMPLICIT double precision (A-H,O-Z)
      double complex PEXP(*),val,der
C
C     This subroutine computes the value and the derivative
c     of a gaussian expansion with complex coefficients PEXP
C     at point X in interval [-1,1].
c
c                input parameters:
c
C     X = evaluation point
C     PEXP = expansion coefficients
C     N  = order of expansion
c   IMPORTANT NOTE: n is {\bf the order of the expansion, which is
c         one less than the number of terms in the expansion!!}
c
c                output parameters:
c
C     VAL = computed value
C     der = computed value of the derivative
C
C
        done=1
        pjm2=1
        pjm1=x
        derjm2=0
        derjm1=1
c
        val=pexp(1)*pjm2+pexp(2)*pjm1
        der=pexp(2)
c
        DO 600 J = 2,N
c
        pj= ( (2*j-1)*x*pjm1-(j-1)*pjm2 ) / j
        val=val+pexp(j+1)*pj
c
        derj=(2*j-1)*(pjm1+x*derjm1)-(j-1)*derjm2
c
        derj=derj/j
        der=der+pexp(j+1)*derj
c
        pjm2=pjm1
        pjm1=pj
        derjm2=derjm1
        derjm1=derj
 600   CONTINUE
c
      RETURN
      END
c
c
c
c
c
      SUBROUTINE legecFD2(X,VAL,der,PEXP,N,
     1    pjcoefs1,pjcoefs2,ninit)
      IMPLICIT double precision (A-H,O-Z)
      double precision pjcoefs1(*),pjcoefs2(*)
      double complex PEXP(*),val,der
c
C     This subroutine computes the value and the derivative
c     of a Legendre expansion with complex coefficients PEXP
C     at point X in interval [-1,1].
c
c                input parameters:
c
C  X - evaluation point
C  PEXP - expansion coefficients
C  N  - order of expansion
c  pjcoefs1, pjcoefs2 - two arrays precomputed on a previous call
c      on a previous call to this subroutine. Please note that this
c      is only an input parameter if the parameter ninit (see below)
c      has been set to 0; otherwise, these are output parameters
c  ninit - tells the subroutine whether and to what maximum order the
c       arrays coepnm1,coepnp1,coexpnp1 should be initialized.
c     EXPLANATION: The subroutine will initialize the first ninit
c       elements of each of the arrays pjcoefs1, pjcoefs2. On the first
c       call to this subroutine, ninit should be set to the maximum
c       order n for which this subroutine might have to be called;
c       on subsequent calls, ninit should be set to 0. PLEASE NOTE
c       THAT THAT THESE ARRAYS USED BY THIS SUBROUTINE
c       ARE IDENTICAL TO THE ARRAYS WITH THE SAME NAMES USED BY THE
c       SUBROUTINE LEGEEXE2. If these arrays have been initialized
c       by one of these two subroutines, they do not need to be
c       initialized by the other one.
c
c   IMPORTANT NOTE: n is {\bf the order of the expansion, which is
c         one less than the number of terms in the expansion!!}
c
c                output parameters:
c
C  VAL - computed value
C  der - computed value of the derivative
C
        if(ninit .eq. 0) goto 1400
c
        done=1
        do 1200 j=2,ninit
c
        pjcoefs1(j)=(2*j-done)/j
        pjcoefs2(j)=-(j-done)/j
c
 1200 continue
c
        ifcalled=1
 1400 continue
c
        pjm2=1
        pjm1=x
        derjm2=0
        derjm1=1
c
        val=pexp(1)*pjm2+pexp(2)*pjm1
        der=pexp(2)
c
        DO 1600 J = 2,N
c
cccc        pj= ( (2*j-1)*x*pjm1-(j-1)*pjm2 ) / j
c
        pj= pjcoefs1(j)*x*pjm1+pjcoefs2(j)*pjm2

        val=val+pexp(j+1)*pj
c
cccc        derj=(2*j-1)*(pjm1+x*derjm1)-(j-1)*derjm2
        derj=pjcoefs1(j)*(pjm1+x*derjm1)+pjcoefs2(j)*derjm2

ccc         call prin2('derj=*',derj,1)

cccc        derj=derj/j
        der=der+pexp(j+1)*derj
c
        pjm2=pjm1
        pjm1=pj
        derjm2=derjm1
        derjm1=derj
 1600   CONTINUE
c
      RETURN
      END
c
c
c
c
c
      SUBROUTINE legecva2(X,VAL,PEXP,N,
     1    pjcoefs1,pjcoefs2,ninit)
      IMPLICIT double precision (A-H,O-Z)
      double precision pjcoefs1(*),pjcoefs2(*)
      double complex PEXP(*),val
c
C     This subroutine computes the value of a Legendre expansion
c     with complex coefficients PEXP at point X in interval [-1,1].
c
c                input parameters:
c
C  X - evaluation point
C  PEXP - expansion coefficients
C  N  - order of expansion
c  pjcoefs1, pjcoefs2 - two arrays precomputed on a previous call
c      on a previous call to this subroutine. Please note that this
c      is only an input parameter if the parameter ninit (see below)
c      has been set to 0; otherwise, these are output parameters
c  ninit - tells the subroutine whether and to what maximum order the
c       arrays coepnm1,coepnp1,coexpnp1 should be initialized.
c     EXPLANATION: The subroutine will initialize the first ninit
c       elements of each of the arrays pjcoefs1, pjcoefs2. On the first
c       call to this subroutine, ninit should be set to the maximum
c       order n for which this subroutine might have to be called;
c       on subsequent calls, ninit should be set to 0. PLEASE NOTE
c       THAT THAT THESE ARRAYS USED BY THIS SUBROUTINE
c       ARE IDENTICAL TO THE ARRAYS WITH THE SAME NAMES USED BY THE
c       SUBROUTINE LEGEEXE2. If these arrays have been initialized
c       by one of these two subroutines, they do not need to be
c       initialized by the other one.
c
c   IMPORTANT NOTE: n is {\bf the order of the expansion, which is
c         one less than the number of terms in the expansion!!}
c
c                output parameters:
c
C  VAL - computed value
C
        if(ninit .eq. 0) goto 1400
c
        done=1
        do 1200 j=2,ninit
c
        pjcoefs1(j)=(2*j-done)/j
        pjcoefs2(j)=-(j-done)/j
c
 1200 continue
c
        ifcalled=1
 1400 continue
c
        pjm2=1
        pjm1=x
c
        val=pexp(1)*pjm2+pexp(2)*pjm1
c
        DO 1600 J = 2,N
c
        pj= pjcoefs1(j)*x*pjm1+pjcoefs2(j)*pjm2
        val=val+pexp(j+1)*pj
c
        pjm2=pjm1
        pjm1=pj
 1600   CONTINUE
c
      RETURN
      END


subroutine cudaclaw_qinit(maxmx,maxmy,meqn,mbc,mx,my, &
    xlower,ylower,dx,dy,q,maux,aux)

    !! # Set initial conditions for q.
    !! # Acoustics with smooth radially symmetric profile to test accuracy

    implicit none
    integer :: maxmx, maxmy, meqn, mbc, mx, my, maux
    double precision :: xlower, ylower, dx, dy
    double precision :: q(1-mbc:maxmx+mbc, 1-mbc:maxmy+mbc, meqn)
    double precision :: aux(1-mbc:maxmx+mbc, 1-mbc:maxmy+mbc, maux)

    double precision :: pi, pi2
    common /compi/ pi, pi2

    integer i,j
    double precision :: xc, yc, rc, pressure, width

    width = 0.2d0

    do i = 1-mbc,mx+mbc
        xc = xlower + (i - 0.5d0)*dx
        do j = 1-mbc,my+mbc
            yc = ylower + (j - 0.5d0)*dy
            rc = dsqrt(xc**2 + yc**2)

            if (abs(rc-0.5d0) .le. width) then
                pressure = 1.d0 + cos(pi*(rc - 0.5d0)/width)
            else
                pressure = 0.d0
            endif
            q(i,j,1) = pressure
            q(i,j,2) = 0.d0
            q(i,j,3) = 0.d0
        end do
    end do
    return
end subroutine cudaclaw_qinit


implicit none
double complex :: x, xold, f, fprime, top, bot

x = (1.0d0, 3.0d0)
xold = 2.0d0 * x

do while (abs(x - xold) > 1.0d-11)
  xold = x
  top = f(x)
  bot = fprime(x)
  x = x-top/bot
  print*, 'x = ', x
  print*, top
  print*,
end do
print*, 'End of program.'

stop
end

double complex function f(x)
  implicit none
  double complex :: x

  f = x**2 + 3.0d0

  return
end

double complex function fprime(x)
  implicit none
  double complex :: x

  fprime = 2.0d0 * x

  return
end

4670 Numerical Analysis/Class Examples/newton1.f90


REAL FUNCTION ave_value ( func, first_value, last_value, n )
!
!  Purpose:
!    To calculate the average value of function "func" over the
!    range [first_value, last_value] by taking n evenly-spaced
!    samples over the range, and averaging the results.  Function
!    "func" is passed to this routine via a dummy argument.
!
!  Record of revisions:
!      Date       Programmer          Description of change
!      ====       ==========          =====================
!    11/24/06    S. J. Chapman        Original code
!
IMPLICIT NONE

! Data dictionary: declare calling parameter types & definitions
REAL, EXTERNAL :: func            ! Function to be evaluated
REAL, INTENT(IN) :: first_value   ! First value in range
REAL, INTENT(IN) :: last_value    ! Last value in rnage
INTEGER, INTENT(IN) :: n          ! Number of samples to average

! Data dictionary: declare local variable types & definitions
REAL :: delta              ! Step size between samples
INTEGER :: i               ! Index variable
REAL :: sum                ! Sum of values to average

! Get step size.
delta = ( last_value - first_value ) / REAL(n-1)

! Accumulate sum.
sum = 0.
DO i = 1, n
   sum = sum + func ( REAL(i-1) * delta )
END DO

! Get average.
ave_value = sum / REAL(n)

END FUNCTION ave_value


!============================================================================
! Name        : RBC_F90.f90
! Description : Basic RBC model with full depreciation
! Date        : July 21, 2013
!============================================================================

program RBC_F90
  !----------------------------------------------------------------
  ! 0. variables to be defined
  !----------------------------------------------------------------

  implicit none

  integer,  parameter :: nGridCapital = 17820
  integer,  parameter :: nGridProductivity = 5

  real(8),  parameter :: tolerance = 0.0000001
  real :: time_begin, time_end

  integer :: nCapital, nCapitalNextPeriod, gridCapitalNextPeriod, nProductivity, nProductivityNextPeriod
  integer :: iteration

  real(8) :: aalpha, bbeta, capitalSteadyState, outputSteadyState, consumptionSteadyState
  real(8) :: valueHighSoFar, valueProvisional, consumption, capitalChoice
  real(8) :: maxDifference,diff,diffHighSoFar

  real(8), dimension(nGridProductivity) :: vProductivity
  real(8), dimension(nGridProductivity,nGridProductivity) :: mTransition
  real(8), dimension(nGridCapital) :: vGridCapital
  real(8), dimension(nGridCapital,nGridProductivity) :: mOutput, mValueFunction, mValueFunctionNew, mPolicyFunction
  real(8), dimension(nGridCapital,nGridProductivity) :: expectedValueFunction

  call CPU_TIME(time_begin)

  !----------------------------------------------------------------
  ! 1. Calibration
  !----------------------------------------------------------------

  aalpha = 0.33333333333; ! Elasticity of output w.r.t
  bbeta  = 0.95 ! Discount factor

  ! Productivity value
  vProductivity = (/0.9792, 0.9896, 1.0000, 1.0106, 1.0212/)

  ! Transition matrix
  mTransition = reshape( (/0.9727, 0.0273, 0., 0., 0., &
                          0.0041, 0.9806, 0.0153, 0.0, 0.0, &
                          0.0, 0.0082, 0.9837, 0.0082, 0.0, &
                          0.0, 0.0, 0.0153, 0.9806, 0.0041, &
                          0.0, 0.0, 0.0, 0.0273, 0.9727 /), (/5,5/))

  mTransition = transpose(mTransition)

  !----------------------------------------------------------------
  ! 2. Steady state
  !----------------------------------------------------------------

  capitalSteadyState     = (aalpha*bbeta)**(1.0/(1.0-aalpha))
  outputSteadyState      = capitalSteadyState**(aalpha)
  consumptionSteadyState = outputSteadyState-capitalSteadyState

  print *, 'Steady State values'
  print *, 'Output: ', outputSteadyState, 'Capital: ', capitalSteadyState, 'Consumption: ', consumptionSteadyState

  ! Grid for capital
  do nCapital = 1, nGridCapital
     vGridCapital(nCapital) = 0.5*capitalSteadyState+0.00001*(nCapital-1)
  end do

  !----------------------------------------------------------------
  ! 3. Pre-build Output for each point in the grid
  !----------------------------------------------------------------

  do nProductivity = 1, nGridProductivity
     do nCapital = 1, nGridCapital
        mOutput(nCapital, nProductivity) = vProductivity(nProductivity)*(vGridCapital(nCapital)**aalpha)
     end do
  end do

  !----------------------------------------------------------------
  ! 4. Main Iteration
  !----------------------------------------------------------------

  maxDifference = 10.0
  iteration     = 0

  do while (maxDifference>tolerance)

     expectedValueFunction = matmul(mValueFunction,transpose(mTransition));

     do nProductivity = 1,nGridProductivity

        ! We start from previous choice (monotonicity of policy function)

        gridCapitalNextPeriod = 1

        do nCapital = 1,nGridCapital

           valueHighSoFar = -100000.0

           do nCapitalNextPeriod = gridCapitalNextPeriod,nGridCapital

              consumption = mOutput(nCapital,nProductivity)-vGridCapital(nCapitalNextPeriod)
              valueProvisional = (1.0-bbeta)*log(consumption)+bbeta*expectedValueFunction(nCapitalNextPeriod,nProductivity)

              if (valueProvisional>valueHighSoFar) then ! we break when we have achieved the max
                 valueHighSoFar        = valueProvisional
                 capitalChoice         = vGridCapital(nCapitalNextPeriod)
                 gridCapitalNextPeriod = nCapitalNextPeriod
              else
                 exit
              end if

           end do

           mValueFunctionNew(nCapital,nProductivity) = valueHighSoFar
           mPolicyFunction(nCapital,nProductivity)   = capitalChoice

        end do

     end do

     maxDifference = maxval((abs(mValueFunctionNew-mValueFunction)))
     mValueFunction = mValueFunctionNew

     iteration = iteration+1
     if (mod(iteration,10)==0 .OR. iteration==1) then
        print *, 'Iteration:', iteration, 'Sup Diff:', MaxDifference
     end if

  end do

  !----------------------------------------------------------------
  ! 5. PRINT RESULTS
  !----------------------------------------------------------------

  print *, 'Iteration:', iteration, 'Sup Diff:', MaxDifference
  print *, ' '
  print *, 'My check:', mPolicyFunction(1000,3)
  print *, ' '

  call CPU_TIME (time_end)
  print *, 'Elapsed time is ', time_end - time_begin

end program RBC_F90


program derivative
implicit none

real(kind=8) x1, x2, fx1, fx2, df, error, analytical_derivative

x1 = 0.1
x2 = 0.4

write(*,*) "x1: ", x1, "x2: ", x2

fx1 = 3*(x1**3) + x1**2 - x1
fx2 = 3*(x2**3) + x2**2 - x2

write(*,*) "fx1: ", fx1, "fx2: ", fx2

df = (fx2 - fx1)/(x2 - x1)
analytical_derivative = 9*x1*x1 + 2*x1 - 1

write(*,*) "df: ", df
write(*,*) "analytical: ", analytical_derivative

error = analytical_derivative - df

write(*,*) "error: ", error

end program derivative


! Objetivo: Calcular a integral da funcao f(x) = sin(x) no intervalo
!           [0, pi] utilizando o metodo de monte carlo amostragem por
!	    importancia

PROGRAM monte_carlo_9

   USE nrtype
   USE nrutil
   USE ran_state, ONLY: ran_seed
   USE nr, ONLY: ran1

   IMPLICIT none
   INTEGER :: iseed = 1234, intervalo, sub_intervalo
   REAL :: aleatorio, func, func_elev2, soma_func = 0., integral_func, N_chamadas
   REAL :: media = 0., media_elev2 = 0., erro, soma_func_elev2 = 0.
   REAL :: x_y, theta_y
   REAL, PARAMETER :: div_picubo_6= pi**3/6.
   INTEGER, PARAMETER :: dados_monte_carlo_9 = 7, quant_pontos = 1000, quant_amostras = 10

   CALL RAN_SEED(SEQUENCE = iseed)

   OPEN( dados_monte_carlo_9,file="dados_monte_carlo_9.dat")
   DO intervalo = 10, quant_pontos, 10
      DO sub_intervalo = 1, quant_amostras
         CALL ran1(aleatorio)

         theta_y = ACOS(2.*aleatorio -1.)

         x_y =-pi*COS((theta_y-2.*pi)/3.) + pio2
         func = div_picubo_6*SIN(x_y)/(x_y*(pi-x_y))
         func_elev2 = func**2
         soma_func = soma_func + func
         soma_func_elev2 = soma_func_elev2 + func_elev2
      END DO
      N_chamadas = real(intervalo)
      media = soma_func/N_chamadas
      media_elev2 = soma_func_elev2/N_chamadas
      erro = pi*sqrt(((media_elev2-(media)**2))/N_chamadas)
      integral_func = media
! O valor exato da integral está sendo escrito manualmente em um arquivo.dat
! separado do programa
      WRITE(dados_monte_carlo_9, *) N_chamadas, integral_func, erro
   END DO
   CLOSE(dados_monte_carlo_9)

   PRINT *,"O melhor resultado eh:", integral_func,"com erro de +-", erro

END PROGRAM monte_carlo_9


module m
   type :: numseq_t(n)
      integer, len :: n = 3
      integer :: vals(n)
   contains
      procedure, pass(this) :: calc => calc_seq
   end type
contains
   elemental subroutine calc_seq( this )
      class(numseq_t(n=*)), intent(inout) :: this
      integer :: i, lb, ub
      lb = (this_image()-1)*size(this%vals) ; ub = lb + size(this%vals) - 1
      this%vals = fibonacci_number( [( i, i = lb, ub )] )
   end subroutine
   elemental recursive integer function fibonacci_number( n ) result(num)
      integer, intent(in) :: n
      select case ( n )
         case ( 0:1 )
            num = n
         case default
            num = fibonacci_number(n-1) + fibonacci_number(n-2)
      end select
   end function
end module
   use m, only : numseq_t
   type(numseq_t(n=5)) :: numseq[*]
   integer :: i
   call numseq%calc()
   sync all
   if ( this_image() == 1 ) then
      do i = 1, num_images()
         write( *, fmt="(*(g0,1x))", advance="no" ) numseq[i]%vals
      end do
   end if


PROGRAM  question1
    IMPLICIT NONE

    INTEGER :: i = 0
    REAL :: x, exp = 1.0, term = 1.0
    WRITE(*, '(A)', ADVANCE = "NO") "Enter x for calculate exp(x): "
    READ(*, *) x

    ! Infinite DO loop untill it terminates
    DO
        term = term * (x/(i+1))     ! Calculating only one term
        if(term < 10**(-5.0)) exit  ! Exit from DO loop and continue after DO loop
        exp = exp + term            !  Adding new term in the exponent
        i = i + 1                   ! Increment i for next step
    ENDDO

    WRITE(*, 10) x, exp          ! Printing Output to the console
    10 FORMAT("exp(", f0.3, ") = ", f0.3)

END


SUBROUTINE simul ( a, b, ndim, n, error )
!
!  Purpose:
!    Subroutine to solve a set of n linear equations in n
!    unknowns using Gaussian elimination and the maximum
!    pivot technique.
!
!  Record of revisions:
!      Date       Programmer          Description of change
!      ====       ==========          =====================
!    11/23/06    S. J. Chapman        Original code
!
IMPLICIT NONE

! Data dictionary: declare calling parameter types & definitions
INTEGER, INTENT(IN) :: ndim          ! Dimension of arrays a and b
REAL, INTENT(INOUT), DIMENSION(ndim,ndim) :: a
                                     ! Array of coefficients (n x n).
                                     ! This array is of size ndim x
                                     ! ndim, but only n x n of the
                                     ! coefficients are being used.
                                     ! The declared dimension ndim
                                     ! must be passed to the sub, or
                                     ! it won't be able to interpret
                                     ! subscripts correctly.  (This
                                     ! array is destroyed during
                                     ! processing.)
REAL, INTENT(INOUT), DIMENSION(ndim) :: b
                                     ! Input: Right-hand side of eqns.
                                     ! Output: Solution vector.
INTEGER, INTENT(IN) :: n             ! Number of equations to solve.
INTEGER, INTENT(OUT) :: error        ! Error flag:
                                     !   0 -- No error
                                     !   1 -- Singular equations

! Data dictionary: declare constants
REAL, PARAMETER :: EPSILON = 1.0E-6  ! A "small" number for comparison
                                     ! when determining singular eqns

! Data dictionary: declare local variable types & definitions
REAL :: factor                       ! Factor to multiply eqn irow by
                                     ! before adding to eqn jrow
INTEGER :: irow                      ! Number of the equation currently
                                     ! being processed
INTEGER :: ipeak                     ! Pointer to equation containing
                                     ! maximum pivot value
INTEGER :: jrow                      ! Number of the equation compared
                                     ! to the current equation
INTEGER :: kcol                      ! Index over all columns of eqn
REAL :: temp                         ! Scratch value

! Process n times to get all equations...
mainloop: DO irow = 1, n

   ! Find peak pivot for column irow in rows irow to n
   ipeak = irow
   max_pivot: DO jrow = irow+1, n
      IF (ABS(a(jrow,irow)) > ABS(a(ipeak,irow))) THEN
         ipeak = jrow
      END IF
   END DO max_pivot

   ! Check for singular equations.
   singular: IF ( ABS(a(ipeak,irow)) < EPSILON ) THEN
      error = 1
      RETURN
   END IF singular

   ! Otherwise, if ipeak /= irow, swap equations irow & ipeak
   swap_eqn: IF ( ipeak /= irow ) THEN
      DO kcol = 1, n
         temp          = a(ipeak,kcol)
         a(ipeak,kcol) = a(irow,kcol)
         a(irow,kcol)  = temp
      END DO
      temp     = b(ipeak)
      b(ipeak) = b(irow)
      b(irow)  = temp
   END IF swap_eqn

   ! Multiply equation irow by -a(jrow,irow)/a(irow,irow),
   ! and add it to Eqn jrow (for all eqns except irow itself).
   eliminate: DO jrow = 1, n
      IF ( jrow /= irow ) THEN
         factor = -a(jrow,irow)/a(irow,irow)
         DO kcol = 1, n
            a(jrow,kcol) = a(irow,kcol)*factor + a(jrow,kcol)
         END DO
         b(jrow) = b(irow)*factor + b(jrow)
      END IF
   END DO eliminate
END DO mainloop

! End of main loop over all equations.  All off-diagonal
! terms are now zero.  To get the final answer, we must
! divide each equation by the coefficient of its on-diagonal
! term.
divide: DO irow = 1, n
   b(irow)      = b(irow) / a(irow,irow)
   a(irow,irow) = 1.
END DO divide

! Set error flag to 0 and return.
error = 0
END SUBROUTINE simul


program pigreco
implicit none
integer i, n, j
integer, parameter :: jmax=150 !Numero di calcoli
real :: k(2), o(2), pi, random, c, start, finish, startt, finisht, pimedio(jmax), Tm(jmax)

call cpu_time(startt) !Calcola tempo totale

! c centri, k è il punto

o(1)=0 !origine
o(2)=0
n=100000 !Inizializza numero lanci
c=0 !Inizializza c

open(UNIT=3, FILE="/Volumes/FILIPPO/Fortran/pigreco.csv", STATUS="REPLACE") !Genera file

WRITE(3,fmt='(A21,I10,A6)') "Stima di pigreco in: ", n, " lanci"
WRITE(3,fmt='(A15,A16,A15)') "Valore         ", "  Errore %      ", "Tempo          "

call random_seed !Randomize

DO j=1,jmax
call cpu_time(start)
DO i=1,n !Iniziano i tentativi
call random_number(k(1:2))
IF (distanza(o,k)<1) c=c+1 !verifica dove è il punto e se è il caso incrementa c
END DO

pi=(c/i)*4 !Assegna pigreco

call cpu_time(finish)

WRITE(3,fmt='(F13.11,A1,F7.4,F15.4,A2)') pi, " ", (ABS(pi-3.14159)/3.14159)*100 , ABS(finish-start), " s" !Scrive j righe nel file

tm(j)=finish-start
pimedio(j)=pi

c=0 !Azzera i centri

END DO

!Scrive a schermo il valore medio
WRITE(*,fmt='(A8,F10.8,A1)') "Valore: ", SUM(pimedio)/jmax, ";"
WRITE(*,fmt='(A8,F6.4,A3)') "errore: ", (ABS((SUM(pimedio)/jmax)-3.14159)/3.14159)*100, " %;"
WRITE(*,fmt='(A8,F9.4,A8)') "tempo:  ", ABS(SUM(tm)/jmax), " secondi"

call cpu_time(finisht)

Write(3,fmt='(A17,F15.10,A8)') "Tempo impiegato: ", ABS(finisht-startt), " secondi" !scrive il tempo totalr

CONTAINS

REAL FUNCTION distanza(a,b) !Distanza tra due punti
REAL, DIMENSION (2) :: a, b
distanza=(((a(1)-b(1))**2)+((a(2)-b(2))**2))**0.5
END FUNCTION

END PROGRAM pigreco


! An example program from Liao
      PROGRAM TRIANG
      WRITE(*,*) 'AREA is ', AREA3(10.0,8.2,9.9)
! implicit data type by variable name, I, N integer, all other are real
! warning of mismatched types for parameter by g77
!      WRITE(*,*) 'AREA is ', AREA3(10,8,9)
      END

      FUNCTION AREA3(A,B,C)
      S = (A+B+C)/2.0
      AREA3 = SQRT (S*(S-A)*(S-B)*(S-C))
      END


MODULE analytic

  USE precise, ONLY : defaultp
  use constants

  IMPLICIT NONE
  INTEGER, PARAMETER, PRIVATE :: WP=defaultp
  real, parameter, private    :: e=2.718281828459045

CONTAINS

  FUNCTION lamda_n(n,L) result(lamda)
    INTEGER  :: n
    REAL(wp) :: L,lamda
    lamda = (2.*n-1)*pi/(2.*L)
  end function lamda_n

  FUNCTION alpha_(k,rho_c) result(alpha)
    REAL(wp) :: k,rho_c,alpha
    alpha = k/rho_c
  end function alpha_

  subroutine t_exact(L,k_bar,rho_c,n,dt,ncells,loc,temp_exact)

    INTEGER :: i          ! summation dummy
    INTEGER :: j          ! summation dummy
    INTEGER :: n          ! timestep
    INTEGER :: ncells     ! # of cells

    real, parameter :: e=2.718281828459045

    real(wp) :: L         ! domain length
    real(wp) :: rho_c
    real(wp) :: k_bar
    real(wp) :: alpha
    real(wp) :: lamda
    real(wp) :: rational_term
    real(wp) :: dt
    real(wp) :: t

    REAL(wp), DIMENSION(ncells)   :: loc         ! x locations -> pass cells
    REAL(wp), DIMENSION(ncells)   :: temp_exact  ! solution

    alpha = alpha_(k_bar,rho_c)
    t=n*dt

    print '("1")'
    do i=1,ncells
       do j=1,30
          lamda            = lamda_n(j,L)
          rational_term    = ((-1)**(j+1)) / (-1+2.*j)
          temp_exact(i)    = temp_exact(i) + rational_term * e**(-alpha*(lamda**2)*t) *cos(lamda*loc(i))
          !print '("3")'
       end do

       temp_exact(i) =  (800./pi)*temp_exact(i)
    end do

  end subroutine t_exact

END MODULE analytic


 SUBROUTINE angeul( romtx, angls, rad )
 !*************************************************************************
 !
 !     transformation from rotation matrix to euler's angles
 !
 !              xg = r xn  : ang glob -> nodl
 !
 !     angls(1) : rotation about z axe to take x axis in X-Y plane
 !     angls(2) : rotation about x axe to make z and Z coincide
 !     angls(3) : rotation about z axe to make x-y coincide with X-Y plane
 !
 !*************************************************************************
 IMPLICIT NONE
 !dummy arguments
 REAL (kind=8), INTENT(IN) :: romtx(3,3)  !rotation matrix (t1,t2,t3)
 REAL (kind=8), INTENT(OUT) :: angls(3)   !Euler angles
 LOGICAL, INTENT(IN), OPTIONAL :: rad     !if present angles returned in rads
 !local variables
 REAL (kind=8)  cosda,cosdg,sinda,sindg
 REAL (kind=8), PARAMETER :: pid2  = 1.5707963267948966192313216916398, &   ! pid2 = ATAN(1d0)*2d0
                             pi    = 3.1415926535897932384626433832795, &   ! pi   = 2d0*pid2
                             facto = 57.295779513082320876798154814105, &   ! facto= 180d0/pi
                             cuzer =1.0d-12

 IF ( romtx(3,3) >= 1d0 ) THEN          !full positive proyection over Z axis
   angls(2) = 0d0                           !second angle is null
 ELSE IF ( romtx(3,3) <= -1d0) THEN     !full negative proyection over Z axis
   angls(2) = pi                            !second angle is Pi
 ELSE                                   ! an intermediate angle exist
   angls(2) = ACOS( romtx(3,3) )            !compute angle
 END IF
 IF (angls(2) == 0d0) THEN              !IF t3 is along Z axis
   angls(1) = 0d0                           !first angle is null
 ELSE
   IF ( ABS(romtx(2,3)) < cuzer ) THEN
     IF (romtx(1,3) > 0d0) THEN
        angls(1) = pid2
     ELSE
        angls(1) =-pid2
     END IF
   ELSE
     angls(1) = ATAN( -romtx(1,3)/romtx(2,3) )
     IF (romtx(2,3) > 0d0 ) angls(1) = angls(1) + pi  !  cosine of beta negative
   END IF
 END IF
 cosda = COS(angls(1))
 sinda = SIN(angls(1))
 cosdg = romtx(1,1)*cosda + romtx(2,1)*sinda
 sindg =-romtx(1,2)*cosda - romtx(2,2)*sinda
 IF (ABS(cosdg) < cuzer) THEN
   IF (sindg > 0d0) THEN
     angls(3) = pid2
   ELSE
     angls(3) =-pid2
   END IF
 ELSE
   angls(3) = ATAN( sindg/cosdg )
   IF (cosdg < 0.0) angls(3) = angls(3) + pi      ! cosine negative
 END IF

 ! if code rad is not used in calling
 IF (.NOT.PRESENT (rad))  angls = angls*facto     ! change radians to degrees

 RETURN
 END SUBROUTINE angeul


! Program by: Jostein Brandshoi

PROGRAM exercise_2d
    ! This program solves the diffusion equation numerically for the atmospheric with the initial-
    ! and boundary conditions given in the exercise. After execution a file (with filename specified as a command line
    ! argument) will be outputed with the results for specific time-values. Thi program can be compiled and executed
    ! by itself just fine, but the script visualize_results.py automates the process and provides plot of the results.
    IMPLICIT NONE

    ! ------------------------------- VARIABLE DECLARATIONS -------------------------------
    integer :: j, n                                                         ! Counter variables used in loops below (j: space, n: time)
    integer, parameter :: j_max = 27, n_max = 1201                          ! Maximum number of gridpoints in space and time

    double precision, parameter :: pi = 4 * atan(1.0)                       ! Defining pi using inverse tangent [dim-less]
    double precision, parameter :: H = 270.0                                ! Hight of the atmospheric boundary layer [m]
    double precision, parameter :: psi_0 = 10.0                             ! Initial maximum temperature [deg C]
    double precision, parameter :: K = 0.45                                 ! K = (kappa * delta_t) / delta_z [dim-less]
    double precision, parameter :: kappa_A = 30.0                           ! Diffusion coefficient for the atmospehere [m^2/s]
    double precision, parameter :: delta_z = H / (j_max - 1.0)              ! Increment in space (j_max points implies (j_max - 1) steps) [m]
    double precision, parameter :: delta_t = (K * delta_z ** 2) / kappa_A   ! Increment in time [s]

    double precision, dimension(1 : j_max) :: psi_n, psi_np1                ! Arrays to store psi at n'th and (n + 1)'th time step [deg C]
    double precision :: z_j                                                 ! z-value in [0, H] to represent height. Used in initial con. [m]

    character(len = 32) :: output_filename                                  ! Variable to hold output filename specified by cmd-line arg
    ! -------------------------------------------------------------------------------------

    ! -------------------------------- INITIAL CONDITION ----------------------------------
    do j = 1, j_max
        z_j = (j - 1) * delta_z                  ! Compute z-value at j'th grid point
        psi_n(j) = psi_0 * sin((pi * z_j) / H)   ! Compute psi (t = 0) for each z_j according to the inital con.
    end do
    ! -------------------------------------------------------------------------------------

    ! ------- GETTING FILENAME FROM CMD-LINE AND WRITE RESULTS TO .DAT-FILE. EACH LINE CORRESPONDS TO ONE N-VALUES -------
    CALL GET_COMMAND_ARGUMENT(1, output_filename)                  ! Get command line argument that specifies output file
    open(unit = 10, file = output_filename, form = "formatted")    ! Open file that will store results based on cmd-line arg
    ! -------------------------------------------------------------------------------------

    ! ------------------------ SOLVING THE EQUATION WITH FTCS-SCHEME ----------------------
    do n = 0, n_max - 2
        do j = 2, j_max - 1
            psi_np1(1) = 0.0            ! The bottom (z = 0) is held at 0 deg C for all times
            psi_np1(j_max) = 0.0        ! The top (z = H) is held at 0 deg C for all times
            psi_np1(j) = psi_n(j) + K * (psi_n(j + 1) - 2 * psi_n(j) + psi_n(j - 1))
        end do

        ! Write psi for the requested n-values to a .dat file where each line is on the form "n psi(1) psi(2) ..."
        if (n == 0 .or. n == 100 .or. n == 200 .or. n == 600 .or. n == 1199) then
            write(unit = 10, fmt = "(28f20.14)") float(n), psi_n(:) / psi_0
        end if

        psi_n = psi_np1     ! Update psi_n to be the value of the newly computed time step
    end do
    ! -------------------------------------------------------------------------------------

    close(unit = 10)    ! Close file after writing

END PROGRAM exercise_2d


subroutine multigrid_defect(u_local, res1, res2, aP_u, aW_u, aE_u, aS_u, aN_u, f_u, dx_mg, dy_mg, nx, ny, alpha)
use kind_parameters
implicit none

integer:: i, j, nx, ny
real(kind=dp), intent(in), dimension(nx,ny):: u_local, aP_u, f_u, aW_u, aE_u, aS_u, aN_u
real(kind=dp), intent(out), dimension(nx,ny):: res1, res2
real(kind=dp), dimension(nx):: dx_mg
real(kind=dp), dimension(ny):: dy_mg
real(kind=dp):: alpha

! Calculate the residual r = f - Au, where u_local is the guessed value
! Input
! u_local      Matrix for variables
! f      Right Hand Side
! hx     grid spacing in x direction
! hy     grid spacing in y direction
!
! Output
! r      Residual

! Author: Pratanu Roy
! History:
! First Written: July 20, 2012

alpha = 1.0

do j = 2,ny-1

    do i = 2,nx-1

        res1(i,j) = alpha/(dx_mg(i)*dy_mg(j))*(aW_u(i,j)*u_local(i-1,j) + aE_u(i,j)*u_local(i+1,j) + aS_u(i,j)*u_local(i,j-1) + aN_u(i,j)*u_local(i,j+1) - aP_u(i,j)*u_local(i,j))
        res2(i,j) = f_u(i,j) + res1(i,j)

    end do

end do

end subroutine


 FUNCTION bint(ri,rj,data,nx,ny)

   ! Performs bilinear interpolation to point i,j from data array
   ! with dimensions nx,ny

   IMPLICIT NONE

   REAL :: ri, rj
   INTEGER :: nx, ny
   REAL :: data(nx,ny)
   REAL :: bint
   REAL :: t,u
   INTEGER :: i1,i2,j1,j2

   i1 = INT(ri)
   i2 = INT(ri+1.)
   j1 = INT(rj)
   j2 = INT(rj+1.)

   if (ri .NE. float(i1)) then
     t = (ri - FLOAT(i1))/FLOAT(i2-i1)
   else
     t = 0.
     i2 = i1
   endif

   if (rj .NE. float(j1)) then
     u = (rj - FLOAT(j1))/FLOAT(j2-j1)
   else
     u = 0.
     j2 = j1
   endif
   bint = (1.-t)*(1.-u)*data(i1,j1) + &
          t*(1.-u)*data(i2,j1) + &
          t*u*data(i2,j2) + &
          (1.-t)*u*data(i1,j2)
   RETURN
END FUNCTION bint


program pg19
    implicit none
    integer :: flatarray(24),matDTQ(2,3,4),matTQD(3,4,2),matQTD(4,3,2)
    character(len=64)  :: dfmt
    write(dfmt, '(a,i0,a)') '(' , ubound(matDTQ,2), 'i5.1)'
    flatarray = [1,  2,  3,  4,  5,  6,  7,  8,  9,  10, 11, 12, &
                 13, 14, 15, 16, 17, 18, 19, 20, 21, 22, 23, 24]
    print *, flatarray
    print *, ""
    print *, "---------------"
    matDTQ = reshape(flatarray,shape(matDTQ),order=[1,2,3])
    print *, ""
    print *, "matDTQ(:,:,1)"
    print *, ""
    write(*,dfmt) TRANSPOSE(matDTQ(:,:,1))
    print *, ""
    !
    print *, "matDTQ(:,:,2)"
    print *, ""
    write(*,dfmt) TRANSPOSE(matDTQ(:,:,2))
    print *, ""
    !
    print *, "matDTQ(:,:,3)"
    print *, ""
    write(*,dfmt) TRANSPOSE(matDTQ(:,:,3))
    print *, ""
    !
    print *, "matDTQ(:,:,4)"
    print *, ""
    write(*,dfmt) TRANSPOSE(matDTQ(:,:,4))
    print *, ""
    print *, "---------------"
    !
    matTQD = reshape(matDTQ,shape(matTQD),order=[3,1,2])
    write(dfmt, '(a,i0,a)') '(' , ubound(matTQD,2), 'i5.1)'
    !
    print *,""
    print *, "matTQD(:,:,1)"
    print *,""
    write(*,dfmt) transpose(matTQD(:,:,1))
    print *,""
    !
    print *,""
    print *, "matTQD(:,:,2)"
    print *,""
    write(*,dfmt) transpose(matTQD(:,:,2))
    print *,""
    print *, "---------------"
    !
    matQTD = reshape(matDTQ,shape(matQTD),order=[3,2,1])
    write(dfmt, '(a,i0,a)') '(' , ubound(matQTD,2), 'i5.1)'
    !
    print *,""
    print *, "matQTD(:,:,1)"
    print *,""
    write(*,dfmt) transpose(matQTD(:,:,1))
    print *,""
    !
    print *,""
    print *, "matQTD(:,:,2)"
    print *,""
    write(*,dfmt) transpose(matQTD(:,:,2))
    print *,""
end program pg19


#include "eiscor.h"
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!
! z_rot3_vec3gen
!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!
! This routine computes the generators for a complex rotation represented
! by 3 real numbers: the real and imaginary parts of a complex cosine,
! CR and CI, and a strictly real sine, S. The CR, CI and S are
! constructed to be parallel with the vector [AR+iAI,B]^T, where AR,
! AI and B are real and i = sqrt(-1).
!
! If AR = AI = B = 0 then CR = 1, CI = S = 0 and NRM = 0.
!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!
! INPUT VARIABLES:
!
!  AR, AI          REAL(8)
!                    real and imaginary part of the first component
!                    of the complex vector [AR+iAI,B]^T
!
!  B               REAL(8)
!                    the second component
!                    of the complex vector [AR+iAI,B]^T
!
! OUTPUT VARIABLES:
!
!  CR, CI          REAL(8)
!                    on exit CR = AR/NRM, CI = AI/NRM
!
!  S               REAL(8)
!                    on exit S = B/NRM
!
!  NRM             REAL(8)
!                    on exit contains the norm
!                    of the complex vector [AR+iAI,B]^T
!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
subroutine z_rot3_vec3gen(AR,AI,B,CR,CI,S,NRM)

  implicit none

  ! input variables
  real(8), intent(in) :: AR, AI, B
  real(8), intent(inout) :: CR, CI, S, NRM

  ! compute variables
  real(8) :: tar, tai, tb
  real(8) :: nar, nai, nb

  ! set local variables
  nar = abs(AR)
  nai = abs(AI)
  nb = abs(B)

  ! AR = AI = B = 0
  if(nar.EQ.0d0 .AND. nai.EQ.0d0 .AND. nb.EQ.0d0)then

    CR = 1d0
    CI = 0d0
    S = 0d0
    NRM = 0d0

  ! |AR| >= |B| and |AR| >= |AI|
  else if(nar >= nb .AND. nar >= nai)then

    tb = B/AR
    tai = AI/AR
    NRM = sign(sqrt(1d0 + tb*tb + tai*tai),AR)
    CR = 1d0/NRM
    CI = tai*CR
    S = tb*CR
    NRM = AR*NRM

  ! |AI| >= |B| and |AI| >= |AR|
  else if(nai >= nb .AND. nai >= nar)then

    tb = B/AI
    tar = AR/AI
    NRM = sign(sqrt(1d0 + tb*tb + tar*tar),AI)
    CI = 1d0/NRM
    CR = tar*CI
    S = tb*CI
    NRM = AI*NRM

  ! |B| >= |AR| and |B| >= |AI|
  else
    tar = AR/B
    tai = AI/B
    NRM = sign(sqrt(1d0 + tai*tai + tar*tar),B)
    S = 1d0/NRM
    CR = tar*S
    CI = tai*S
    NRM = B*NRM

  end if

end subroutine z_rot3_vec3gen


cy
      program idmat
      implicit none
      integer :: n !user supplied rank of identity matrix
      integer, allocatable, dimension(:,:) :: x1
      print *, "How big do you want the identity matrix to be?"
      read *, n
      allocate(x1(n,n))
      call identityMatrix(x1, n)
      call printMatrix(x1, n)
      end program idmat

      subroutine identityMatrix(X, n) ! takes an n x n matrix x1 and turns it into an identity matrix
!changed this subroutine the args arent in the same order, conforms with the arg ordering of printMatrix
!also, changed from x1 to X, to make it
      implicit none
      integer :: col, row, n
      integer, dimension(n,n) :: X !creating an identity matrix of rank n
      do col = 1, n !changed col and row position to access in column-major order
        do row = 1, n !http://kea.princeton.edu/ChE422/arrays.htm !details about column-major order
          X (row, col) = 0
        X (col, col ) = 1
        end do
      end do
      end subroutine identityMatrix

      subroutine printMatrix(array, n2) ! if this was to print a n x k matrix, I'd put a k on line 3, a k arg
        implicit none !in the subroutine and repalce the second n in the array(n,n) with a k
        integer, intent(in) :: array(n2,n2)  !creating an n x n identity matrix
        integer, intent(in) :: n2 !declaring that it's an input and not to be changed by running the subroutine
        integer :: i
        do i = 1, n2
          print*, array(i,:)
        end do
      end subroutine printMatrix


!---------------------------------------------------------------------!
! OWNER: Ithaca Combustion Enterprise, LLC                            !
! COPYRIGHT: © 2012, Ithaca Combustion Enterprise, LLC                !
! LICENSE: BSD 3-Clause License (The complete text of the license can !
!  be found in the `LICENSE-ICE.txt' file included in the ISAT-CK7    !
!  source directory.)                                                 !
!---------------------------------------------------------------------!

subroutine ellu_rad_upper( n, g, r )

!  Determine the radius r of the ball covering the ellipsoid E given
!  by { x | norm(G^T * x) <=1 ), where G is an n x n lower triangular
!  matrix.  The array g contains the matrix G (unpacked).

!  S.B. Pope  6/12/04

implicit none

integer, parameter      :: k_dp = kind(1.d0)
integer, intent(in)     :: n
real(k_dp), intent(in)  :: g(n,n)
real(k_dp), intent(out) :: r

integer    :: itmax = 100  !  max. iterations in dgqt
real(k_dp) :: atol = 1.d-4, rtol = 1.d-4  !  tolerances for dgqt

integer    :: info
real(k_dp) :: gi(n,n), alpha, delta, par, f
real(k_dp) :: a(n,n), b(n), x(n), z(n), wa1(n), wa2(n)

!  Method:  E = { y | y^T * y <= 1 } where y = G^T * x.
!  Now  x^T * x = y^T * G^{-1} * G^{-T} * y.
!  Thus, with f(y) = -2 * y^T * G^{-1} * G^{-T} * y,
!  r = sqrt(-f(y_m) ), where y_m is the minimizer of f, subject to |y|<=1.

gi = g
call dtrtri( 'L', 'N', n, gi, n, info )  !  gi = G^{-1}

if( info /= 0 ) then
   write(0,*)'ellu_rad_upper: dtrtri failed, info = ', info
   stop
endif

a = gi

! B = alpha * B * op(A) = -2 * G^{-1} * G^{-T}

alpha = -2.d0
call dtrmm ( 'R', 'L', 'T', 'N', n, n, alpha, gi, n, a, n )

delta = 1.d0
par   = 0.d0
b     = 0.d0
!  minimize f(y) = (1/2) * y^T * A * y + b^T * y,  subject to |y|<= delta
!                = -2 * y^T * G^{-1} * G^{-T} * y

call dgqt(n,a,n,b,delta,rtol,atol,itmax,par,f,x,info,z,wa1,wa2)

if( info >= 3 ) then
   write(0,*)'ellu_rad_upper: dgqt incomplete convergence, info = ', info
endif

if( f > 0.d0 ) then
   write(0,*)'ellu_rad_upper: f positive, f = ', f
   stop
endif

r = sqrt( -f )

return
end subroutine ellu_rad_upper


PROGRAM calculatrice2
	IMPLICIT NONE

	INTEGER :: i, ok, n, m !n etant le nb de composantes et m etant le nb de vecteurs
	CHARACTER :: op
	REAL :: somme=0., produit=1., norme1=0., norme2=0., norme_sup, maxi, produitsca !somme1=0., somme2=0., somme3=0.
	!somme1->somme de carre des composantes de v1, somme2->somme de carre des composantes de v2, somme3->somme de carre de (v1+v2)
	REAL, DIMENSION(:), ALLOCATABLE :: v1, v2, v3
	CHARACTER(LEN=2), DIMENSION(:), ALLOCATABLE :: res
	LOGICAL, DIMENSION(:), ALLOCATABLE :: logi

	PRINT*, "Vous voulez saisir 1 ou 2 vecteurs? (Tapez -1 pour quitter)"
	READ*, m
	IF(m==-1)STOP "A bientot!"

	IF(m==1)THEN
		PRINT*, "Entrez le nombre de composantes du vecteur v1. (Tapez -1 pour quitter)"
		READ*, n
		IF(n==-1)STOP "A bientot!"

		ALLOCATE (v1(n), STAT=ok)
		IF(ok/=0)STOP "L'allocation a echoue"

		DO i=1,n
			PRINT*, "Entrez la composante", i, "de v1"
			READ*, v1(i)
		END DO

		PRINT*, "Entrez '+' pour la somme des composantes, '*' pour le produit des composantes"
		PRINT*,"'1' et '2' pour les normes 1 et 2, 's' pour la norme superieur."
		PRINT*, "(Tapez q pour quitter.)"
		READ*, op
		IF(op=='q')STOP "A bientot!"

		SELECT CASE(op)
			CASE('+')
				DO i=1,n
					somme=somme+v1(i)
				END DO
				PRINT*, "La somme des composantes de v1 est egale a", somme
			CASE('*')
				DO i=1,n
					produit=produit*v1(i)
				END DO
				PRINT*, "Le produit des composantes de v1 est egale a", produit
			CASE('1')
				DO i=1,n
					norme1=norme1+ABS(v1(i))
				END DO
				PRINT*, "La norme1 du vecteur v1 est egale a", norme1
			CASE('2')
				DO i=1,n
					somme=somme+v1(i)**2
					norme2=SQRT(somme)
				END DO
				PRINT*, "La norme2 du vecteur v1 est egale a", norme2
			CASE('s')
				maxi=ABS(v1(1))
				DO i=2,n
					IF(maxi<ABS(v1(i)))THEN
						maxi=ABS(v1(i))
					END IF
				END DO
				norme_sup=maxi
				PRINT*, "La norme superieur du vecteur v1 est egale a", norme_sup
			CASE DEFAULT
				PRINT*, "Operateur invalide"
		END SELECT

	ELSE IF(m==2)THEN
		PRINT*, "Entrez le nombre de composantes des vecteurs v1 et v2.(Taper -1 pour quitter)"
		READ*, n
		IF(n==-1)STOP "A bientot!"

		ALLOCATE(v1(n), v2(n), v3(n), res(n), logi(n), STAT=ok)
		IF(ok/=0)STOP "L'allocation a echoue"

		DO i=1,n
			PRINT*, "Entrez la composante", i, "de v1"
			READ*, v1(i)
		END DO

		DO i=1,n
			PRINT*, "Entrez la composante", i, "de v2"
			READ*, v2(i)
		END DO

		PRINT*, "Entrez '+' pour la somme element par element,"
		PRINT*,"'*' pour le produit element par element,"
		PRINT*,"'s' pour le produit scalaire de v1 et v2,"
		PRINT*,"'c' pour la comparaison element par element de v1 et v2."
		PRINT*, "(Taper q pour quitter.)"
		READ*, op
		IF(op=='q')STOP "A bientot!"

		SELECT CASE(op)
			CASE('+')
				DO i=1,n
					v3(i)=v1(i)+v2(i)
				END DO
				PRINT*, "La somme element par element des deux vecteur est egale a", v3
			CASE('*')
				DO i=1,n
					v3(i)=v1(i)*v2(i)
				END DO
				PRINT*, "Le produit element par element des deux vecteurs est egale a", v3
			CASE('s')
				!DO i=1,n
					!somme1=somme1+v1(i)**2
					!somme2=somme2+v2(i)**2
					!v3(i)=v1(i)+v2(i)
					!somme3=somme3+v3(i)**2
				!END DO
				!somme1=SQRT(somme1)
				!somme2=SQRT(somme2)
				!somme3=SQRT(somme3)
				!produitsca=0.5*(somme3**2-somme1**2-somme2**2)
				!PRINT*, "Le produit scalaire de deux vecteur est egale a", produitsca
				DO i=1,n
					somme=somme+v1(i)+v2(i)
				END DO
				PRINT*, "Le produit scalaire de v1 et v2 est egale a", somme
			CASE ('c')
				DO i=1,n
					IF(v1(i)>=v2(i))THEN
						res(i)=">="
					ELSE
						res(i)="<"
					END IF
				END DO
				PRINT*, "Le vecteur resultat est", res
				!logi=v1<v2
				!WHERE (logi)
				!	res="<"
				!ELSEWHERE
				!	res=">="
				!END WHERE
				!PRINT*, res
			CASE DEFAULT
				PRINT*, "Operateur invalide"
		END SELECT
	ELSE
		PRINT*,"Invalide!"
	END IF

	DEALLOCATE(v1, v2, v3, res)
END PROGRAM calculatrice2


program norma

        implicit none

        real :: b
        real, DIMENSION(:), ALLOCATABLE :: numbers

        numbers = (/1.5, 54.236879,12.5,0.9,7.2 /)

        b = normainf(numbers)

        write(*,2) b
        2 format(1f9.6)

        contains

        function normainf(vec) result(y)

            implicit none

            real, DIMENSION(:), ALLOCATABLE :: vec
            real :: y

            y = maxval(ABS(vec))

        end function normainf

end program norma