 SUBROUTINE SPPSV_F95( A, B, UPLO, INFO )
!
!  -- LAPACK95 interface driver routine (version 3.0) --
!     UNI-C, Denmark; Univ. of Tennessee, USA; NAG Ltd., UK
!     September, 2000
!
!   .. USE STATEMENTS ..
    USE LA_PRECISION, ONLY: WP => SP
    USE LA_AUXMOD, ONLY: ERINFO, LSAME
    USE F77_LAPACK, ONLY: PPSV_F77 => LA_PPSV
!   .. IMPLICIT STATEMENT ..
    IMPLICIT NONE
!   .. SCALAR ARGUMENTS ..
    CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: UPLO
    INTEGER, INTENT(OUT), OPTIONAL :: INFO
!   .. ARRAY ARGUMENTS ..
    REAL(WP), INTENT(INOUT) :: A(:), B(:,:)
!----------------------------------------------------------------------
!
! Purpose
! =======
!
!    LA_PPSV computes the solution to a linear system of equations
! A*X = B, where A is real symmetric or complex Hermitian and, in either
! case, positive definite, and where X and B are rectangular matrices or
! vectors. A is stored in packed format. The Cholesky decomposition is
! used to factor A as
!      A = U^H*U if UPLO = 'U', or A = L*L^H if UPLO = 'L'
! where U is an upper triangular matrix and L is a lower triangular
! matrix (L = U^H ). The factored form of A is then used to solve the
! above system.
!
! =========
!
!       SUBROUTINE LA_PPSV( AP, B, UPLO=uplo, INFO=info )
!           <type>(<wp>), INTENT(INOUT) :: AP(:), <rhs>
!           CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: UPLO
!           INTEGER, INTENT(OUT), OPTIONAL :: INFO
!       where
!           <type> ::= REAL | COMPLEX
!           <wp>   ::= KIND(1.0) | KIND(1.0D0)
!           <rhs>  ::= B(:,:) | B(:)
!
! Arguments
! =========
!
! AP      (input/output) REAL or COMPLEX array, shape (:) with size(AP)
!         = n*(n+1)/2, where n is the order of A.
!         On entry, the upper or lower triangle of matrix A in packed
!         storage. The elements are stored columnwise as follows:
!          if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j<=n;
!          if UPLO = 'L', AP(i + (j-1)*(2n-j)/2) = A(i,j) for 1<=j<=i<=n.
!         On exit, the factor U or L from the Cholesky factorization
! 	  A = U^H*U or A = L*L^H , in the same storage format as A.
! B       (input/output) REAL or COMPLEX array, shape (:,:) with
!         size(B,1) = n or shape (:) with size(B) = n.
!         On entry, the matrix B.
!         On exit, the solution matrix X.
! UPLO    Optional, (input) CHARACTER(LEN=1)
!         = 'U': Upper triangle of A is stored;
!         = 'L': Lower triangle of A is stored.
!         Default value: 'U'.
! INFO    Optional (output) INTEGER.
!         = 0: successful exit.
!         < 0: if INFO = -i, the i-th argument had an illegal value.
!         > 0: if INFO = i, the leading minor of order i of A is not
! 	     positive definite, so the factorization could not be
! 	     completed and the solution could not be computed.
!         If INFO is not present and an error occurs, then the program is
! 	  terminated with an error message.
!------------------------------------------------------------------------
!   .. PARAMETERS ..
    CHARACTER(LEN=7), PARAMETER :: SRNAME = 'LA_PPSV'
!   .. LOCAL SCALARS ..
    CHARACTER(LEN=1) :: LUPLO
    INTEGER :: LINFO, N, NN, NRHS
    COMPLEX(WP) :: WW
!   .. INTRINSIC FUNCTIONS ..
    INTRINSIC SIZE, PRESENT, REAL, INT, AIMAG
!   .. EXECUTABLE STATEMENTS ..
    LINFO = 0; NN = SIZE(A); NRHS = SIZE(B,2)
    WW = (-1+SQRT(1+8*REAL(NN,WP)))*0.5; N = INT(WW)
    IF( PRESENT(UPLO) )THEN; LUPLO = UPLO; ELSE; LUPLO = 'U'; END IF
!   .. TEST THE ARGUMENTS
    IF( NN < 0 .OR. AIMAG(WW) /= 0 .OR. REAL(N,WP) /= REAL(WW) ) THEN; LINFO = -1
    ELSE IF( SIZE( B, 1 ) /= N .OR. NRHS < 0 ) THEN; LINFO = -2
    ELSE IF( .NOT.LSAME(LUPLO,'U') .AND. .NOT.LSAME(LUPLO,'L') )THEN; LINFO = -3
    ELSE IF ( N > 0 ) THEN
       CALL PPSV_F77( LUPLO, N, NRHS, A, B, N, LINFO )
    END IF
    CALL ERINFO( LINFO, SRNAME, INFO )
 END SUBROUTINE SPPSV_F95


module nrtype
  integer, parameter :: i1  = selected_int_kind(2)  ! 1-byte integer.
  integer, parameter :: i2  = selected_int_kind(4)  ! 2-byte integer.
  integer, parameter :: i4  = selected_int_kind(9)  ! 4-byte integer.
  integer, parameter :: i8  = selected_int_kind(18) ! 8-byte integer.
  integer, parameter :: i16 = selected_int_kind(22) ! 16-byte integer.
  integer, parameter :: sp  = kind(1.0)           ! Single precision real double.
  integer, parameter :: spc = kind((1.0,1.0))     ! Single precision complex double.
  integer, parameter :: dp  = kind(1.0d0)         ! Max precision real double.
  integer, parameter :: dpc = kind((1.0d0,1.0d0)) ! Max precision complex double.
  integer, parameter :: lgt = kind(.true.)        ! Logical true.
  integer, parameter :: lgf = kind(.false.)       ! Logical false.

  real(dp), parameter :: pi    = 3.141592653589793238462643383279502884197_dp
  real(dp), parameter :: pi2   = 1.57079632679489661923132169163975144209858_dp
  real(dp), parameter :: tau   = 6.283185307179586476925286766559005768394_dp
  real(dp), parameter :: sqrt2 = 1.41421356237309504880168872420969807856967_dp
  real(dp), parameter :: euler = 2.71828182845904523536028747135266249775725_dp
end module nrtype


subroutine EigValSym(ain, n, eval, ul)
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!
!	This subroutine will return the eigenvalues of the symmetric square
!	matrix Ain, ordered from greatest to least.
!
!	Calling Parameters
!		IN
!			Ain	Input symmetric matrix. By default, only the
!				upper portion is used.
!			n	Order of the matrix Ain.
!		OUT
!			eval	Vector of length n of the eigenvalues of Ain.
!		OPTIONAL
!			uplo	Use the upper 'U' or lower 'L' portion of the
!				input symmetric matrix.
!
!	Notes:
!
!	1.	The eigenvalues and eigenvectors are determined by reducing the matrix to
!			A = Z L Z = Q (S L S') Q'
!		by the two operations:
!
!		(1) The real symmetric square matrix is reduced to tridiagonal form
!			A = Q T Q'
!		where Q is orthogonal, and T is symmetric tridiagonal.
!		(2) The tridiagonal matrix is reduced to
!			T = S L S'
!
!		The eigenvalues of A correspond to L (which is a diagonal)
!
!	Dependencies: LAPACK, BLAS
!
!	Written by Mark Wieczorek June 2004.
!
!	Copyright (c) 2005, Mark A. Wieczorek
!	All rights reserved.
!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
	implicit none
	real*8, intent(in) ::	ain(:,:)
	integer, intent(in) ::	n
	real*8, intent(out) ::	eval(:)
	character, intent(in), optional :: ul
	integer, parameter ::	nb = 80, nbl = 10
	character ::	uplo
	real*8 ::	d(n), e(n), tau(n-1), work(nb*n), vl, vu, &
			abstol, w(n)
	real*8, allocatable ::	a(:,:), z(:,:)
	integer ::	lwork, info, il, iu, m, isuppz(2*n), liwork, iwork(nbl*n), i, astat(2)
	external	dsytrd, dstegr

	if (size(ain(:,1)) < n .or. size(ain(1,:)) < n) then
		print*, "Error --- EigValSym"
		print*, "AIN must be dimensioned as (N, N) where N is ", n
		print*, "Input array is dimensioned as ", size(ain(:,1)), size(ain(1,:))
		stop
	elseif(size(eval) < n) then
		print*, "Error --- EigValSym"
		print*, "EVAL must be dimensioned as (N) where N is ", n
		print*, "Input array is dimensioned as ", size(eval)
		stop
	endif

	allocate(a(n,n), stat = astat(1))
	allocate(z(n,n), stat = astat(2))

	if (astat(1) /= 0 .or. astat(2) /= 0) then
		print*, "Error --- EigValSym"
		print*, "Problem allocating arrays A and Z", astat(1), astat(2)
		stop
	endif

	lwork = nb*n
	liwork = nbl*n

	eval = 0.0d0
	a(1:n,1:n) = ain(1:n,1:n)

	if (present(ul)) then
		uplo = ul
	else
		uplo = "U"
	endif

	!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
	!
	!	Factor A = Q T Q'
	!
	!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!

	call dsytrd(uplo, n, a, n, d, e(1:n-1), tau, work, lwork, info)

	if (info /= 0) then
		print*, "Error --- EigValSym"
		print*, "Problem tri-diagonalizing input matrix"
		stop
	else
		if ( work(1) > dble(lwork) ) then
			print*, "Warning --- EigValSym"
			print*, "Consider changing value of nb to ", work(1)/n, " and recompile the SHTOOLS archive."
		endif
	endif

	!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
	!
	!	Factor T = S L S'
	!
	!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!

	abstol = 0.0d0

	call dstegr('n','a', n, d, e, vl, vu, il, iu, abstol, m,  w, &
			z, n, isuppz, work, lwork, iwork, liwork, info)

       	if (info /= 0) then
		print*, "Error --- EigValSym"
		print*, "Problem determining eigenvalues and eigenvectors of tridiagonal matrix."
		if (info==1) print*, "Internal error  in  DLARRE"
		if (info==2) print*, "Internal error in DLARRV"
		stop
	else
		if (work(1) > dble(lwork) ) then
			print*, "Warning --- EigValSym"
			print*, "Consider changing value of nb to ", work(1)/n, " and recompile the SHTOOLS archive."
		endif

		if (iwork(1) > liwork ) then
			print*, "Warning --- Eigsym"
			print*, "Consider changing value of nb to ", iwork(1)/n, " and recompile the SHTOOLS archive."
		endif
	endif

	! Reorder eigenvalues from greatest to least.

	do i=1, n
		eval(i) = w(n+1-i)
	enddo

	deallocate(a)
	deallocate(z)

end subroutine EigValSym


program xif
  do i=1,10
    do ipower=1,3
      print*,i,ipower,i**ipower
    end do
  end do
end program xif


      subroutine sqrf(a,mda,m,n,b,mdb,nb)
c----------------------------------------------------------------------
c       calculates qr factorization of a matrix a by using householder
c  transformations.  on output a is replaced by the upper triangular
c  matrix r and array b is overwritten by the product q(transpose)b.
c  this is a suitable way of solving well conditioned least squares
c  problems.  (see lawson and hanson, 1974)
c        this algorithm has only one frill.  vectors used to construct
c  householder transformations in the reduction are checked to see
c  if all elements of the vector are zero.  a householder
c  transformation of a zero vector is an identity transformation.
c  this routine skips these vectors in the reduction since the
c  reduction already complete for that column.  this is primarily
c  useful for problems where b has many columns as it is more
c  efficient in that case.
c
c  arguments-
c     a  - m by n matrix to be factored.  on output a will contain
c          the upper trapezoidal matrix (upper triangular when
c          m>n ) r of the qr factorization.
c          ( m>n or n<m permitted )
c     mda- leading dimension of a
c     m  - number of rows in a.
c     n  - number of columns in a.
c     b  - m by nb array of right hand sides for the least squares
c          problem to be solved.  on output b is overwritten by the
c          matrix product q(transpose)b.
c     mdb- leading dimension of b.
c     nb - number of columns in b = number of right hand sides to
c          solve for.
c
c  required subprograms
c     h12  -routine to calculate and implement householder
c           transformations.  (identical to subroutine h12 of
c           lawson and hanson, 1974)
c     test0-routine used to test for zero vectors.
c
c  language - 1977 ansi standard fortran
c  author   - gary l. pavlis
c  written  - may 1981
c----------------------------------------------------------------------
      integer mda,m,n,mdb,nb
      real a(mda,n),b(mdb,nb)
      external test0
      logical test0
c--used to hold scaling factor for householder transformations.
      real scale
c--j is a loop control variable
c--l is used to terminate decomposition properly for arbitrary
c--rectangular matrix.
      integer j,l
      l = min(m-1,n)
c--routine test0 tests for zero vectors.  returns a true value
c--if vector is all zeros.
c--first call to h12 calculates vector needed for implementing
c--a householder transformation and scaling constant.
c--second call to h12 implements the householder transformation
c--defined by first call.
      do 150 j=1,l
            if(.not.test0(m-j+1,a(j,j),1)) then
                call h12(1,j,j+1,m,a(1,j),1,scale,a(1,j+1),1,mda,n-j)
                call h12(2,j,j+1,m,a(1,j),1,scale,b,1,mdb,nb)
            endif
  150 continue
      return
      end

c $Id$


c
c     cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
      subroutine getclm(lmax,clm)
c     ================================================================
c
      implicit   none
c
      integer    lmax
      integer    l
      integer    m
      integer    m2
      integer    i
c
      real*8     clm((lmax+1)*(lmax+2)/2)
      real*8     fpi
      real*8     fnpi
      real*8     xfac
      real*8     one
      real*8     four
c
      parameter (one=1.0d0)
      parameter (four=4.0d0)
c
c     *****************************************************************
c     Coeficients for complex spherical harmonics......................
c     Calclates all the c(l,m)'s up to lmax............................
c
c                  [ (2*l+1)*(l-|m|)!]
c     c(l,m)=  sqrt[-----------------]
c                  [   4*pi*(l+|m|)! ]
c
c     *****************************************************************
c
c     =================================================================
      if(lmax.lt.0 ) then
         write(6,'('' GETCLM:: bad arguments: lmax='',i5)') lmax
         stop 'getclm'
      endif
c     =================================================================
c     begin calculation of c(l,m)'s....................................
c     =================================================================
      fpi=four*fnpi()
c     =================================================================
c     special case lmax=0..............................................
c     =================================================================
      clm(1)=sqrt(one/fpi)
      do l=1,lmax
         xfac=sqrt((2*l+1)/fpi)
         do m=0,l
            clm(l*(l+1)/2+m+1)=one
            m2=2*m
            do i=1,m2
               clm(l*(l+1)/2+m+1)=(l-m+i)*clm(l*(l+1)/2+m+1)
            enddo
c           ===========================================================
c           This version is consisten with (-1)**m being in Plm's......
c           See plglmax.f in this directory............................
c           ===========================================================
            clm(l*(l+1)/2+m+1)=xfac*sqrt(one/clm(l*(l+1)/2+m+1))
         enddo
      enddo
c
      return
      end


!----------------------------------------------------------------------
!----------------------------------------------------------------------
!   AUTO demo um2
!----------------------------------------------------------------------
!----------------------------------------------------------------------

      SUBROUTINE FUNC(NDIM,U,ICP,PAR,IJAC,F,DFDU,DFDP)
!     ---------- ----

      IMPLICIT NONE
      INTEGER, INTENT(IN) :: NDIM,ICP(*),IJAC
      DOUBLE PRECISION, INTENT(IN) :: U(NDIM),PAR(*)
      DOUBLE PRECISION, INTENT(OUT) :: F(NDIM)
      DOUBLE PRECISION, INTENT(INOUT) :: DFDU(NDIM,*),DFDP(NDIM,*)

      DOUBLE PRECISION eps, Period, x, y

        eps    = PAR(2)
        Period = PAR(11)

        x = U(1)
        y = U(2)

        F(1) =  Period * ( eps * x - y**3 )
        F(2) =  Period * (       y + x**3 )

      END SUBROUTINE FUNC
!----------------------------------------------------------------------

      SUBROUTINE STPNT(NDIM,U,PAR,T)
!     ---------- -----

      IMPLICIT NONE
      INTEGER, INTENT(IN) :: NDIM
      DOUBLE PRECISION, INTENT(INOUT) :: U(NDIM),PAR(*)
      DOUBLE PRECISION, INTENT(IN) :: T

      DOUBLE PRECISION, PARAMETER :: &
           theta = 0.25, &
           eps   = 0.5, &
           r0    = 0.1, &
           r1    = r0, &
           Period= 1.d-4
      DOUBLE PRECISION PI

       PI = 4*ATAN(1.D0)

       PAR(1:4) = (/theta,eps,r0,r1/)
       PAR(11)= Period

       U(1) = r0 * COS( 2.0D0 * PI * theta)
       U(2) = r0 * SIN( 2.0D0 * PI * theta)

      END SUBROUTINE STPNT
!----------------------------------------------------------------------

      SUBROUTINE BCND(NDIM,PAR,ICP,NBC,U0,U1,FB,IJAC,DBC)
!     ---------- ----

      IMPLICIT NONE
      INTEGER, INTENT(IN) :: NDIM,ICP(*),NBC,IJAC
      DOUBLE PRECISION, INTENT(IN) :: PAR(*),U0(NDIM),U1(NDIM)
      DOUBLE PRECISION, INTENT(OUT) :: FB(NBC)
      DOUBLE PRECISION, INTENT(INOUT) :: DBC(NBC,*)

      DOUBLE PRECISION x0, y0, x1, y1, PI, theta, r0, r1

        x0 = U0(1)
        y0 = U0(2)
        x1 = U1(1)
        y1 = U1(2)

        PI = 4*ATAN(1.D0)

        theta = PAR(1)
        r0  = PAR(3)
        r1  = PAR(4)

        FB(1) = x0 - r0 * COS( 2.0 * PI * theta)
        FB(2) = y0 - r0 * SIN( 2.0 * PI * theta)
        FB(3) = SQRT(x1**2 + y1**2) - r1

      END SUBROUTINE BCND
!----------------------------------------------------------------------
      SUBROUTINE ICND
      END SUBROUTINE ICND

      SUBROUTINE FOPT
      END SUBROUTINE FOPT

      SUBROUTINE PVLS
      END SUBROUTINE PVLS
!----------------------------------------------------------------------


C$Procedure      RECLAT ( Rectangular to latitudinal coordinates )

      SUBROUTINE RECLAT ( RECTAN, RADIUS, LONG, LAT )

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

      DOUBLE PRECISION   RECTAN ( 3 )
      DOUBLE PRECISION   RADIUS
      DOUBLE PRECISION   LONG
      DOUBLE PRECISION   LAT

C$ Brief_I/O
C
C     VARIABLE  I/O  DESCRIPTION
C     --------  ---  --------------------------------------------------
C     RECTAN     I   Rectangular coordinates of the point.
C     RADIUS     O   Distance of a point from the origin.
C     LONG       O   Longitude of point in radians.
C     LAT        O   Latitude of point in radians.
C
C$ Detailed_Input
C
C     RECTAN     The rectangular coordinates of a point.
C
C$ Detailed_Output
C
C     RADIUS     Distance of a point from the origin.
C
C                The units associated with RADIUS are those
C                associated with the input RECTAN.
C
C     LONG       Longitude of the input point.  This is the angle
C                between the prime meridian and the meridian
C                containing the point.  The direction of increasing
C                longitude is from the +X axis towards the +Y axis.
C
C                LONG is output in radians.  The range of LONG is
C                [ -pi, pi].
C
C
C     LAT        Latitude of the input point.  This is the angle from
C                the XY plane of the ray from the origin through the
C                point.
C
C                LAT is output in radians.  The range of LAT is
C                [-pi/2, pi/2].
C
C$ Parameters
C
C     None.
C
C$ Particulars
C
C     This routine returns the latitudinal coordinates of a point
C     whose position is input in rectangular coordinates.
C
C     Latitudinal coordinates are defined by a distance from a central
C     reference point, an angle from a reference meridian, and an angle
C     above the equator of a sphere centered at the central reference
C     point.
C
C$ Exceptions
C
C     Error free.
C
C     1) If the X and Y components of RECTAN are both zero, the
C        longitude is set to zero.
C
C     2) If RECTAN is the zero vector, longitude and latitude are
C        both set to zero.
C
C$ Files
C
C     None.
C
C$ Examples
C
C     Below are two tables.
C
C     Listed in the first table (under X(1), X(2) and X(3) ) are a
C     number of points whose rectangular coordinates are
C     taken from the set {-1, 0, 1}.
C
C     The results of the code fragment
C
C              CALL RECLAT ( X, R, LONG, LAT )
C        C
C        C     Use the SPICELIB routine CONVRT to convert the angular
C        C     quantities to degrees
C        C
C              CALL CONVRT ( LAT,  'RADIANS', 'DEGREES', LAT  )
C              CALL CONVRT ( LONG, 'RADIANS', 'DEGREES', LONG )
C
C     are listed to 4 decimal places in the second parallel table under
C     R (radius), LONG (longitude), and  LAT (latitude).
C
C
C       X(1)       X(2)     X(3)        R         LONG      LAT
C       --------------------------      --------------------------
C       0.0000     0.0000   0.0000      0.0000    0.0000    0.0000
C       1.0000     0.0000   0.0000      1.0000    0.0000    0.0000
C       0.0000     1.0000   0.0000      1.0000   90.0000    0.0000
C       0.0000     0.0000   1.0000      1.0000    0.0000   90.0000
C      -1.0000     0.0000   0.0000      1.0000  180.0000    0.0000
C       0.0000    -1.0000   0.0000      1.0000  -90.0000    0.0000
C       0.0000     0.0000  -1.0000      1.0000    0.0000  -90.0000
C       1.0000     1.0000   0.0000      1.4142   45.0000    0.0000
C       1.0000     0.0000   1.0000      1.4142    0.0000   45.0000
C       0.0000     1.0000   1.0000      1.4142   90.0000   45.0000
C       1.0000     1.0000   1.0000      1.7320   45.0000   35.2643
C
C
C$ Restrictions
C
C     None.
C
C$ Author_and_Institution
C
C     C.H. Acton      (JPL)
C     N.J. Bachman    (JPL)
C     W.L. Taber      (JPL)
C
C$ Literature_References
C
C     None.
C
C$ Version
C
C-    SPICELIB Version 1.0.2, 30-JUL-2003 (NJB) (CHA)
C
C        Various header changes were made to improve clarity.  Some
C        minor header corrections were made.
C
C-    SPICELIB Version 1.0.1, 10-MAR-1992 (WLT)
C
C        Comment section for permuted index source lines was added
C        following the header.
C
C-    SPICELIB Version 1.0.0, 31-JAN-1990 (WLT)
C
C-&

C$ Index_Entries
C
C     rectangular to latitudinal coordinates
C
C-&

C$ Revisions
C
C-     Beta Version 1.0.1, 1-Feb-1989 (WLT)
C
C      Example section of header upgraded.
C
C-&
      DOUBLE PRECISION X
      DOUBLE PRECISION Y
      DOUBLE PRECISION Z
      DOUBLE PRECISION BIG

C
C     Store rectangular coordinates in temporary variables
C
      BIG = MAX ( DABS(RECTAN(1)), DABS(RECTAN(2)), DABS(RECTAN(3)) )

      IF ( BIG .GT. 0 ) THEN

         X      = RECTAN(1) / BIG
         Y      = RECTAN(2) / BIG
         Z      = RECTAN(3) / BIG

         RADIUS = BIG * DSQRT (X*X + Y*Y + Z*Z)

         LAT    = DATAN2 ( Z, DSQRT(X*X + Y*Y) )

         X      = RECTAN(1)
         Y      = RECTAN(2)

         IF (X.EQ.0.D0 .AND. Y.EQ.0.D0) THEN
            LONG = 0.D0
         ELSE
            LONG = DATAN2 (Y,X)
         END IF

      ELSE
         RADIUS = 0.0D0
         LAT    = 0.D0
         LONG   = 0.D0
      END IF

      RETURN
      END


      program markov
c-----------------------------------------------------------------------
c
c program to generate a Markov chain matrix (to test eigenvalue routines
c or algorithms for singular systems (in which case use I-A ))
c the matrix models  simple random walk on a triangular grid.
c see additional comments in subroutine.
c -----
c just compile this segment and link to the rest of sparskit
c (uses subroutine prtmt from MATGEN)
c will create a matrix in the HARWELL/BOEING format and put it in
c the file markov.mat
c
c-----------------------------------------------------------------------
      parameter (nmax=5000, nzmax= 4*nmax)
      real*8 a(nzmax)
      integer ja(nzmax), ia(nmax+1)
c
      character title*72,key*8,type*3
      open (unit=11,file='markov.mat')
c
c read - in grid size - will not accept too large grids.
c
      write (6,'(17hEnter grid-size: ,$)')
      read *, m
      if (m*(m+1) .gt. 2*nmax ) then
         print *, ' m too large - unable to produce matrix '
         stop
      endif
c
c call generator.
c
      call markgen (m, n, a, ja, ia)
c-----------------------------------------------------------------------
      title=' Test matrix from SPARSKIT - markov chain model           '
      key = 'randwk01'
      type = 'rua'
      iout = 11
      job = 2
      ifmt = 10
      call prtmt (n, n, a, ja, ia, x,'NN',title,
     *     key, type,ifmt, job, iout)
      stop
      end
c
      subroutine markgen (m, n, a, ja, ia)
c-----------------------------------------------------------------------
c matrix generator for a markov model of a random walk on a triang. grid
c-----------------------------------------------------------------------
c this subroutine generates a test matrix that models a random
c walk on a triangular grid. This test example was used by
c G. W. Stewart ["{SRRIT} - a FORTRAN subroutine to calculate the
c dominant invariant subspaces of a real matrix",
c Tech. report. TR-514, University of Maryland (1978).] and in a few
c papers on eigenvalue problems by Y. Saad [see e.g. LAA, vol. 34,
c pp. 269-295 (1980) ]. These matrices provide reasonably easy
c test problems for eigenvalue algorithms. The transpose of the
c matrix  is stochastic and so it is known that one is an exact
c eigenvalue. One seeks the eigenvector of the transpose associated
c with the eigenvalue unity. The problem is to calculate the
c steady state probability distribution of the system, which is
c the eigevector associated with the eigenvalue one and scaled in
c such a way that the sum all the components is equal to one.
c-----------------------------------------------------------------------
c parameters
c------------
c on entry :
c----------
c m     = integer. number of points in each direction.
c
c on return:
c----------
c n     = integer. The dimension of the matrix. (In fact n is known
c         to be equal to (m(m+1))/2      )
c a,
c ja,
c ia    = the matrix stored in CSR format.
c
c-----------------------------------------------------------------------
c Notes: 1) the code will actually compute the transpose of the
c stochastic matrix that contains the transition probibilities.
c        2) It should also be possible to have a matrix generator
c with an additional parameter (basically redefining `half' below
c to be another parameter and changing the rest accordingly, but
c this is not as simple as it sounds). This is not likely to provide
c any more interesting matrices.
c-----------------------------------------------------------------------
      real*8 a(*), cst, pd, pu, half
      integer ja(*), ia(*)
c-----------------------------------------------------------------------
      data half/0.5d0/
c
      cst = half/real(m-1)
c
c     --- ix counts the grid point (natural ordering used), i.e.,
c     --- the row number of the matrix.
c
      ix = 0
      jax = 1
      ia(1) = jax
c
c     sweep y coordinates
c
      do 20 i=1,m
         jmax = m-i+1
c
c     sweep x coordinates
c
         do 10 j=1,jmax
            ix = ix + 1
            if (j .eq. jmax) goto 2
            pd = cst*real(i+j-1)
c
c     north
c
            a(jax) = pd
            if (i.eq. 1) a(jax) = a(jax)+pd
            ja(jax) =  ix + 1
            jax = jax+1
c     east
            a(jax) = pd
            if (j .eq. 1) a(jax) = a(jax)+pd
            ja(jax) = ix + jmax
            jax = jax+1
c     south
 2          pu = half - cst*real(i+j-3)
            if ( j .gt. 1) then
               a(jax) = pu
               ja(jax) = ix-1
               jax = jax+1
            endif
c     west
            if ( i .gt. 1) then
               a(jax) = pu
               ja(jax) = ix - jmax - 1
               jax = jax+1
            endif
            ia(ix+1) = jax
 10      continue
 20   continue
      n = ix
      return
      end


SUBROUTINE lqmns(m,n,x,qm,qd)

! Code converted using TO_F90 by Alan Miller
! Date: 2002-04-11  Time: 17:03:56

!**************************************************************

!       ========================================================
!       Purpose: Compute associated Legendre functions Qmn(x)
!                and Qmn'(x) for a given order
!       Input :  x --- Argument of Qmn(x)
!                m --- Order of Qmn(x),  m = 0,1,2,...
!                n --- Degree of Qmn(x), n = 0,1,2,...
!       Output:  QM(n) --- Qmn(x)
!                QD(n) --- Qmn'(x)
!       ========================================================

INTEGER, INTENT(IN)                      :: m
INTEGER, INTENT(IN)                      :: n
DOUBLE PRECISION, INTENT(IN)             :: x
DOUBLE PRECISION, INTENT(OUT)            :: qm(0:n)
DOUBLE PRECISION, INTENT(OUT)            :: qd(0:n)
IMPLICIT DOUBLE PRECISION (a-h,o-z)

DO  k=0,n
  qm(k)=0.0D0
  qd(k)=0.0D0
END DO
IF (DABS(x) == 1.0D0) THEN
  DO  k=0,n
    qm(k)=1.0D+300
    qd(k)=1.0D+300
  END DO
  RETURN
END IF
ls=1
IF (DABS(x) > 1.0D0) ls=-1
xq=DSQRT(ls*(1.0D0-x*x))
q0=0.5D0*DLOG(DABS((x+1.0)/(x-1.0)))
q00=q0
q10=-1.0D0/xq
q01=x*q0-1.0D0
q11=-ls*xq*(q0+x/(1.0D0-x*x))
qf0=q00
qf1=q10
DO  k=2,m
  qm0=-2.0D0*(k-1.0)/xq*x*qf1-ls*(k-1.0)*(2.0-k)*qf0
  qf0=qf1
  qf1=qm0
END DO
IF (m == 0) qm0=q00
IF (m == 1) qm0=q10
qm(0)=qm0
IF (DABS(x) < 1.0001D0) THEN
  IF (m == 0.AND.n > 0) THEN
    qf0=q00
    qf1=q01
    DO  k=2,n
      qf2=((2.0*k-1.0D0)*x*qf1-(k-1.0)*qf0)/k
      qm(k)=qf2
      qf0=qf1
      qf1=qf2
    END DO
  END IF
  qg0=q01
  qg1=q11
  DO  k=2,m
    qm1=-2.0D0*(k-1.0)/xq*x*qg1-ls*k*(3.0-k)*qg0
    qg0=qg1
    qg1=qm1
  END DO
  IF (m == 0) qm1=q01
  IF (m == 1) qm1=q11
  qm(1)=qm1
  IF (m == 1.AND.n > 1) THEN
    qh0=q10
    qh1=q11
    DO  k=2,n
      qh2=((2.0*k-1.0D0)*x*qh1-k*qh0)/(k-1.0)
      qm(k)=qh2
      qh0=qh1
      qh1=qh2
    END DO
  ELSE IF (m >= 2) THEN
    qg0=q00
    qg1=q01
    qh0=q10
    qh1=q11
    DO  l=2,n
      q0l=((2.0D0*l-1.0D0)*x*qg1-(l-1.0D0)*qg0)/l
      q1l=((2.0*l-1.0D0)*x*qh1-l*qh0)/(l-1.0D0)
      qf0=q0l
      qf1=q1l
      DO  k=2,m
        qmk=-2.0D0*(k-1.0)/xq*x*qf1-ls*(k+l-1.0)* (l+2.0-k)*qf0
        qf0=qf1
        qf1=qmk
      END DO
      qm(l)=qmk
      qg0=qg1
      qg1=q0l
      qh0=qh1
      qh1=q1l
    END DO
  END IF
ELSE
  IF (DABS(x) > 1.1) THEN
    km=40+m+n
  ELSE
    km=(40+m+n)*INT(-1.0-1.8*LOG(x-1.0))
  END IF
  qf2=0.0D0
  qf1=1.0D0
  DO  k=km,0,-1
    qf0=((2.0*k+3.0D0)*x*qf1-(k+2.0-m)*qf2)/(k+m+1.0)
    IF (k <= n) qm(k)=qf0
    qf2=qf1
    qf1=qf0
  END DO
  DO  k=0,n
    qm(k)=qm(k)*qm0/qf0
  END DO
END IF
IF (DABS(x) < 1.0D0) THEN
  DO  k=0,n
    qm(k)=(-1)**m*qm(k)
  END DO
END IF
qd(0)=((1.0D0-m)*qm(1)-x*qm(0))/(x*x-1.0)
DO  k=1,n
  qd(k)=(k*x*qm(k)-(k+m)*qm(k-1))/(x*x-1.0)
END DO
RETURN
END SUBROUTINE lqmns


      PROGRAM TCM2
C==================================================================
C       Modélisation des transferts de chaleur & matière
C       ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
C                         (1°partie)
C
C Modifié le 02.04.97
C==================================================================
C Tableaux : . u      : champ des températures aux noeuds
C            . S      : matrice à inverser (implicite)
C            . s1, s2 : contiennent la décomposition LU de S
C            . g      : second membre du système EF
C
C Scalaires : . L,A       : caractéristiques géométriques du milieu
C             . cond,rhoc : caractéristiques thermiques du milieu
C             . h,Tf      : coeeficient de convection et
C                           température du fluide en x=0.
C             . N         : nombre d'éléments finis
C             . TMAX      : temps maximum
C             . ITMAX     : Nbre de pas de temps à effectuer
C             . ISAV      : Nbre de pas de temps entre deux sauv.
C             . dx,dt     :
C==================================================================
C
      IMPLICIT REAL*8(A-H,O-Z)
      REAL*8 L
C
      PARAMETER(NN=1000)
C
      DIMENSION u(NN),S(3,NN),g(NN),s1(NN),s2(NN)
C
C------------------------------------------------------------------
C
C     Initialisation
C     --------------
C
C     - matériau
C
      A     = 1.0D-2
      L     = 2.0
      cond  = 0.01
      rhoc  = 1.0
      uu    = 0.05
C
C     - conditions limites
C
      T0 = 20.0
      TL = 0.0
C
C     - intégrateur
C
      N     = 40
      TMAX  = 40
      ITMAX = 1000
      ISAV  = 100

      dx = L/DBLE(N)
      dt = TMAX/DBLE(ITMAX)
      Pe=DABS(uu)*dx*rhoc/cond

      WRITE(*,120)dx,TL,cond,dt,T0,rhoc,cond/rhoc
      WRITE(*,*)'Peclet de merde =',Pe
      WRITE(*,*)
      WRITE(*,*)'theta [0-1] ? :'
      READ(*,*)theta
      alpha=1.0D0/DTANH(Pe/2.0D0)-2.0D0/Pe
      WRITE(*,*)'alpha opti    =',alpha
      WRITE(*,*)'alpha [0-1] ? :'
      READ(*,*)alpha
      WRITE(*,*)'<SPACE>'
      READ(*,*)
C
C     Ouverture ficher resultat
C     -------------------------
      OPEN(UNIT=1,FILE='res.m',STATUS='UNKNOWN')
C
C     Initialisation des températures
C     -------------------------------
      DO i=1,N+1
         u(i)=0.0D0
      ENDDO
      u(1)=T0
      u(N+1)=TL
C
C     Calcul de S
C     -----------
      a1 = cond*A/dx
      a2 = rhoc*A*dx/6.0D0
      a3 = rhoc*uu*A/2.0D0

      CALL EVALS(a1,a2,a3,theta,S,NN,s1,s2,N,dt,alpha)
C
C------------------------------------------------------------------
C                    Boucle des pas de temps
C------------------------------------------------------------------
C
      IT   = 0
      NSAV = 0
      NO=0
      DO i=1,N+1
         WRITE(1,*)'u(',i,',',NO+1,')=',u(i),';'
         WRITE(1,*)'t(',NO+1,')=',IT*dt,';'
      ENDDO
C
 10   CONTINUE
      IT=IT+1
      NSAV=NSAV+1
C
C     Calcul de g (second membre)
C     ---------------------------
      call EVALG(a1,a2,a3,u,T0,TL,theta,NN,g,N,dt,alpha)
C
C     Calcul de u(IT)
C     ----------------
      u(2)=g(2)
      DO i=3,N
         u(i)=g(i)-s2(i)*u(i-1)
      ENDDO
C
      u(N) = u(N)/s1(N)
      DO i=N-1,2,-1
         u(i)=(u(i)-S(1,i)*u(i+1))/s1(i)
      ENDDO
C
C     Sauvegarde vers MATLAB
C     ----------------------
      IF(NSAV.EQ.ISAV) THEN
         NSAV=0
         NO=NO+1
         DO i=1,N+1
            WRITE(1,*)' u(',i,',',NO+1,')=',u(i),';'
            WRITE(1,*)'t(',NO+1,')=',IT*dt,';'
         ENDDO
         WRITE(*,100)IT,IT*dt,u(1)
      ENDIF
C
      IF(IT.NE.ITMAX) GOTO 10
C
C------------------------------------------------------------------
C                         Fin de boucle
C------------------------------------------------------------------
C
C     Fermeture du fichier
C     --------------------
      WRITE(1,*)'dx=',dx,';L=',L,';'
      WRITE(1,*)'cond=',cond,';uu=',uu,';'
      WRITE(1,*)'rhoc=',rhoc,';'
      WRITE(1,*)'T0=',T0,';TL=',TL,';'
      WRITE(1,*)'plot(0:dx:L,u)'
      CLOSE(UNIT=1)
C
      WRITE(*,110)
C
C==================================================================
C
 100  FORMAT(' pas : ',I5,'    temps : ',D10.4, '    T(1) :',D10.4)
 110  FORMAT(/'  Execution teminee !     resultats dans res.m')
 120  FORMAT(/' dx :',D10.4,'   TL :',D10.4,'   k    :',D10.4,
     #       /' dt :',D10.4,'   T0 :',D10.4,'   rhoc :',D10.4,
     #       '   eta :',D10.4,/ )
C
      END


program brisi
  COMPLEX*16 :: a(3), b(3)

  a(1) = dcmplx(1,1)
  a(2) = dcmplx(0,1)
  a(3) = dcmplx(1,2)
  b(1) = dcmplx(3,1)
  b(2) = dcmplx(1,7)
  b(3) = dcmplx(0,6)

  print *, dot_product(a,b)
  print *, zdotc(3,a,1,b,1)

end program brisi


!-----------------------------------------------------------------------
!
! RAdS Jan12.
! Copyright (C) 2011-2014 by Rodrigo Alvares de Souza.
! Mail: <rsouza01@gmail.com>. Web: "http://www.astro.iag.usp.br/~rsouza/".
! This program may be copied and/or distributed freely. See the
! _ terms and conditions in the files in the doc/ subdirectory.
!
!
! MODULE: solver_module
!
!> @author
!> Rodrigo Souza
!
! DESCRIPTION:
!> Runge-kutta related routines
!
!-----------------------------------------------------------------------
module solver_module
use global_constants
use config_module
use tov_module

    implicit none

    contains

    !---------------------------------------------------------------------------
    ! DESCRIPTION:
    !> The hard work
    !---------------------------------------------------------------------------

    subroutine process_calculations(parameters, error)
    implicit none
        !Parameters
        type(ConfigParameters) :: parameters
        integer :: error

        integer :: j = 0
        double precision :: t = 0

        !Variables that hold the integrations values for a single call to Runge-Kutta
        double precision :: Y(N_DIFF_EQUATIONS)

        !Variables that hold the physical relevant values
        double precision :: V(N_VARIABLES)

        t = j * parameters%diff_eq_step

        call set_initial_conditions(parameters, Y, V)

        if(.not. parameters%output_summary_only) then
            call print_header_output(parameters, t, V)
        end if

        do while ( j < parameters%max_rk_steps .and. (.not. can_stop(parameters, t, Y, V)))

            !In the first iteration, it must show the initial conditions.
            if(.not. parameters%output_summary_only) then
                call print_formated_output(parameters, t, V)
            end if

            call runge_kutta_4(parameters, t, Y, V)

            call process_specific_calculations(parameters, t, Y, V)

            j = j + 1

            t = j * parameters%diff_eq_step

        end do

        if(.not. parameters%output_summary_only) then
            call print_footer_output(parameters, t, V)
        end if

        call print_summary(parameters, t, V)

    end subroutine process_calculations

    !---------------------------------------------------------------------------
    ! DESCRIPTION:
    !> The hard work
    !---------------------------------------------------------------------------

    subroutine process_calculations_variable_step_size(parameters, error)
    implicit none
        !Parameters
        type(ConfigParameters) :: parameters
        integer :: error

        integer :: j = 0
        double precision :: t = 0

        !Variables that hold the integrations values for a single call to Runge Kutta
        double precision :: Y(N_DIFF_EQUATIONS)

        !Variables that hold the physical relevant values
        double precision :: V(N_VARIABLES)

        logical :: flag = .true.

        double precision :: calculated_h = 0.

        calculated_h = parameters%max_diff_eq_step

        t = j * calculated_h

        call set_initial_conditions(parameters, Y, V)

        if(.not. parameters%output_summary_only) then
            call print_header_output(parameters, t, V)
        end if

        do while ( flag .eqv. .true. .and. j < parameters%max_rk_steps .and. (.not. can_stop(parameters, t, Y, V)))

            !In the first iteration, it must show the initial conditions.
            if(.not. parameters%output_summary_only) then
                call print_formated_output(parameters, t, V)
            end if

            call runge_kutta_fehlberg(parameters, t, Y, V, calculated_h, flag)

            call process_specific_calculations(parameters, t, Y, V)

            j = j + 1

            t = j * calculated_h

        end do

        if(.not. parameters%output_summary_only) then
            call print_footer_output(parameters, t, V)
        end if

        call print_summary(parameters, t, V)

    end subroutine process_calculations_variable_step_size

    !---------------------------------------------------------------------------
    ! DESCRIPTION:
    !> runge_kutta_fehlberg
    !---------------------------------------------------------------------------
    subroutine runge_kutta_fehlberg(parameters, t, Y, V, calculated_h, flag)
    implicit none

        type(ConfigParameters) :: parameters
        double precision :: t, Y(N_DIFF_EQUATIONS), V(N_VARIABLES)
        logical :: flag

        double precision :: k1(N_DIFF_EQUATIONS), k2(N_DIFF_EQUATIONS), &
                            k3(N_DIFF_EQUATIONS), k4(N_DIFF_EQUATIONS), &
                            k5(N_DIFF_EQUATIONS), k6(N_DIFF_EQUATIONS)

        integer :: equationNumber
        double precision :: t_linha, calculated_h
        logical :: Rs_leq_TOL = .true. !R's < TOL
        double precision :: R(N_DIFF_EQUATIONS), delta, average_R

        t_linha = t

        !Small adjustment for t=0 in order to avoid the singularity
        if (t == 0.) then
            t_linha = t + calculated_h * 0.001
        end if

        !write (*,'(A)') '----------------------------------------'
        !1st step
        !write (*,'(A)'),'Eq.             K1'
        !write (*,'(A)') '--- --------------'
        do equationNumber = 1, N_DIFF_EQUATIONS, 1
            k1(equationNumber) = calculated_h * derivative(parameters, t_linha, Y, V, equationNumber)
        !    write (*,'(i3, f15.7)') , equationNumber, k1(equationNumber)
        end do

        !2nd step
        !write (*,'(A)'),'Eq.             K2'
        !write (*,'(A)') '--- --------------'
        do equationNumber = 1, N_DIFF_EQUATIONS, 1
            k2(equationNumber) = calculated_h * derivative(parameters, t_linha + calculated_h/4., Y + k1/4., V, equationNumber)
        !    write (*,'(i3, f15.7)') , equationNumber, k2(equationNumber)
        end do

        !3rd step
        !write (*,'(A)'),'Eq.             K3'
        !write (*,'(A)') '--- --------------'
        do equationNumber = 1, N_DIFF_EQUATIONS, 1
            k3(equationNumber) = calculated_h * derivative(parameters, &
                t_linha + 3.*calculated_h/8.,  &
                Y + 3.*k1/32.  + 9.*k2/32., &
                V, equationNumber)
        !    write (*,'(i3, f15.7)') , equationNumber, k3(equationNumber)
        end do

        !4th step
        !write (*,'(A)'),'Eq.             K4'
        !write (*,'(A)') '--- --------------'
        do equationNumber = 1, N_DIFF_EQUATIONS, 1
            k4(equationNumber) = calculated_h * derivative(parameters, &
                t_linha + (12./13.)*calculated_h,  &
                Y + (1932./2197)*k1 - (7200./2197)*k2 + (7296./2197.)*k3, &
                V, equationNumber)
        !    write (*,'(i3, f15.7)') , equationNumber, k4(equationNumber)
        end do

        !5th step
        !write (*,'(A)'),'Eq.             K4'
        !write (*,'(A)') '--- --------------'
        do equationNumber = 1, N_DIFF_EQUATIONS, 1
            k5(equationNumber) = calculated_h * derivative(parameters, &
                t_linha + calculated_h, &
                Y + (439./216.)*k1 - 8.*k2 + (3680./513)*k3 - (845./4104.)*k4, &
                V, equationNumber)
        !    write (*,'(i3, f15.7)') , equationNumber, k5(equationNumber)
        end do

        !6th step
        !write (*,'(A)'),'Eq.             K4'
        !write (*,'(A)') '--- --------------'
        do equationNumber = 1, N_DIFF_EQUATIONS, 1
            k6(equationNumber) = calculated_h * derivative(parameters, &
                t_linha + 0.5*calculated_h,  &
                Y - (8./27.)*k1 - 2.*k2 - (3544./2565.)*k3 - (1859./4104.)*k4 - (11./40.)*k5, &
                V, equationNumber)
        !    write (*,'(i3, f15.7)') , equationNumber, k6(equationNumber)
        end do

        !Calculations
        do equationNumber = 1, N_DIFF_EQUATIONS, 1
            R(equationNumber) = (1./calculated_h) * abs( &
                (1./360.)*k1(equationNumber) - &
                (128./4275.) * k2(equationNumber) - &
                (2197./75240.) * k4(equationNumber) + &
                (1./50.) * k5(equationNumber) + &
                (2./55.)*k6(equationNumber));

            !write (*,*) 'R(', equationNumber, ') = ', R(equationNumber)
            if(R(equationNumber) > parameters%interpolation_tolerance) then
                Rs_leq_TOL = .false.
            end if

            average_R = R(equationNumber) / N_DIFF_EQUATIONS

        end do

        if(Rs_leq_TOL .eqv. .true.) then
            do equationNumber = 1, N_DIFF_EQUATIONS, 1
                Y(equationNumber) = Y(equationNumber) + &
                    (25./216.)*k1(equationNumber) + &
                    (1408./2565.)*k3(equationNumber) + &
                    (2197./4104.)*k4(equationNumber) + &
                    (1./5.)*k5(equationNumber)
            end do

            calculated_h = parameters%diff_eq_step

        end if

        delta = 0.84 * (parameters%interpolation_tolerance / average_R)** (1./4.)

        if(delta < 0.1) then
            calculated_h = 0.1 * calculated_h
        elseif(delta >= 4.) then
            calculated_h = 4. * calculated_h
        else
            calculated_h = delta * calculated_h
        end if

        if(calculated_h > parameters%max_diff_eq_step) then
            calculated_h = parameters%max_diff_eq_step
        end if

        if (calculated_h < parameters%min_diff_eq_step) then
            flag = .false.
        end if

    end subroutine runge_kutta_fehlberg

    !---------------------------------------------------------------------------
    ! DESCRIPTION:
    !> runge_kutta_4
    !---------------------------------------------------------------------------
    subroutine runge_kutta_4(parameters, t, Y, V)
    implicit none

        type(ConfigParameters) :: parameters
        double precision :: t, Y(N_DIFF_EQUATIONS), V(N_VARIABLES)

        double precision :: k1(N_DIFF_EQUATIONS), k2(N_DIFF_EQUATIONS), &
                            k3(N_DIFF_EQUATIONS), k4(N_DIFF_EQUATIONS)

        integer :: equationNumber
        double precision :: t_linha, h

        h = parameters%diff_eq_step
        t_linha = t

        !Small adjustment for t=0 in order to avoid the singularity
        if (t == 0.) then
            t_linha = t + parameters%diff_eq_step * 0.001
        end if

        !write (*,'(A)') '----------------------------------------'
        !1st step
        !write (*,'(A)'),'Eq.             K1'
        !write (*,'(A)') '--- --------------'
        do equationNumber = 1, N_DIFF_EQUATIONS, 1
            k1(equationNumber) = h * derivative(parameters, t_linha, Y, V, equationNumber)
        !    write (*,'(i3, f15.7)') , equationNumber, k1(equationNumber)
        end do

        !2nd step
        !write (*,'(A)'),'Eq.             K2'
        !write (*,'(A)') '--- --------------'
        do equationNumber = 1, N_DIFF_EQUATIONS, 1
            k2(equationNumber) = h * derivative(parameters, t_linha + h/2., Y + k1/2., V, equationNumber)
        !    write (*,'(i3, f15.7)') , equationNumber, k2(equationNumber)
        end do

        !3rd step
        !write (*,'(A)'),'Eq.             K3'
        !write (*,'(A)') '--- --------------'
        do equationNumber = 1, N_DIFF_EQUATIONS, 1
            k3(equationNumber) = h * derivative(parameters, t_linha + h/2.,  Y + k2/2., V, equationNumber)
        !    write (*,'(i3, f15.7)') , equationNumber, k3(equationNumber)
        end do

        !4th step
        !write (*,'(A)'),'Eq.             K4'
        !write (*,'(A)') '--- --------------'
        do equationNumber = 1, N_DIFF_EQUATIONS, 1
            k4(equationNumber) = h * derivative(parameters, t_linha + h,  Y + k3, V, equationNumber)
        !    write (*,'(i3, f15.7)') , equationNumber, k4(equationNumber)
        end do

        !Calculations
        do equationNumber = 1, N_DIFF_EQUATIONS, 1
            Y(equationNumber) = Y(equationNumber) + ( k1(equationNumber) + 2. * k2(equationNumber) + &
                2. * k3(equationNumber) + k4(equationNumber)) / 6.;
        end do

        !write (*,'(A)') '----------------------------------------'
        !write (*,'(A)'),'         t          Massa        Pressao'
        !write (*,'(A)') '---------- -------------- --------------'

        !write (*,'(f10.5, f15.7 f15.7)') , t, Y(1), Y(2)
        !write (*,'(A)') '----------------------------------------'

    end subroutine runge_kutta_4

end module solver_module


program tridiag

    implicit none
    integer, parameter :: n = 5
    integer :: nrhs,ldb,info,i
    real(kind=8) :: dl(n-1), du(n-1), d(n),  b(n,1)

    do i=1,n
        d(i) = float(i)
        enddo

    do i=1,n-1
        dl(i) = 10.d0*i
        du(i) = 100.d0*(i+1)
        enddo

    b = reshape((/201.d0, 312.d0, 423.d0, 534.d0, 45.d0 /), (/5,1/))

    ! or it also works if you declare b(n) to be 1-dimensional, and then use:
    ! b = (/201.d0, 312.d0, 423.d0, 534.d0, 45.d0 /)

    ldb = n
    nrhs = 1

    ! solve the system:
    call dgtsv(n, nrhs, dl, d, du, b, ldb, info)

    if (info /= 0) then
        print *, "*** Problem with solver, info = ",info
        stop
        endif

    ! on return, b is the solution:
    print *, 'x = ', b

end program tridiag


      double complex function A43ggppmp(e1,p2,p3,e4,za,zb,zab,zba)
      implicit none
C-----Authors: John Campbell and Keith Ellis, November 2011
C---- taken from arXiv:1101.5947 [hep-ph], Eq. (5,53)
      include 'constants.f'
      include 'masses.f'
      include 'zprods_decl.f'
      include 'zabprods_decl.f'
      include 'sprods_com.f'
      include 'epinv.f'
      include 'scale.f'
      double precision mt2,beta,xlog
      double complex BSYALggppmphp,BSYARggppmphp,BSYALslggpppm
      double complex BSYA0ggppmp,lnrat,Vslc
      integer e1,p2,p3,e4,e1p,e4p

      mt2=mt**2
      beta=sqrt(1d0-4d0*mt2/s(p2,p3))
      xlog=log((1d0-beta)/(1d0+beta))/beta
C---- arXiv:1101.5947 [hep-ph], Eq. (52)
c----   with an extra minus sign to account for A4;3 -> -Vslc, c.f. Eq. (53))
      Vslc=-dcmplx(epinv)*
     & (+s(1,p2)/s(p2,p3)*(lnrat(musq,-s(1,p2))+lnrat(mt2,-s(1,p2)))
     &  +s(1,p3)/s(p2,p3)*(lnrat(musq,-s(1,p3))+lnrat(mt2,-s(1,p3)))
     & +lnrat(musq,-s(p2,p3))+(1d0-2d0*mt2/s(p2,p3))*xlog)

c--- perform the swaps 5 <-> 7 and 6 <-> 8
      e1p=12-e1
      e4p=14-e4

      A43ggppmp=(
     &  Vslc*(BSYA0ggppmp(e1,p2,p3,e4,za,zb,zab,zba)
     &       -BSYA0ggppmp(e1p,p3,p2,e4p,zb,za,zba,zab))
     & +BSYALggppmphp(e1,p2,p3,e4,za,zb,zab,zba)
     & -BSYALggppmphp(e1p,p3,p2,e4p,zb,za,zba,zab)
     & +BSYARggppmphp(e1,p2,p3,e4,za,zb,zab,zba)
     & -BSYARggppmphp(e1p,p3,p2,e4p,zb,za,zba,zab)
     & +BSYALslggpppm(e1,p2,e4,p3,za,zb,zab,zba)
     & -BSYALslggpppm(e1p,p3,e4p,p2,zb,za,zba,zab))

      return
      end


 MODULE GDSWZD_POLAR_STEREO_MOD
!$$$  MODULE DOCUMENTATION BLOCK
!
! $Revision: 74917 $
!
! MODULE:  GDSWZD_POLAR_STEREO_MOD  GDS WIZARD MODULE FOR POLAR
!                                   STEREOGRAPHIC AZIMUTHAL GRIDS.
!   PRGMMR: GAYNO     ORG: W/NMC23       DATE: 2015-01-21
!
! ABSTRACT: - CONVERT FROM EARTH TO GRID COORDINATES OR VICE VERSA
!             (SPHERICAL OR ELLIPTICAL EARTH).
!           - COMPUTE VECTOR ROTATION SINES AND COSINES.
!             (SPHERICAL OR ELLIPTICAL EARTH).
!           - COMPUTE MAP JACOBIANS (SPHERICAL EARTH).
!           - COMPUTE GRID BOX AREA (SPHERICAL EARTH).
!
! PROGRAM HISTORY LOG:
!   2015-01-21  GAYNO   INITIAL VERSION FROM A MERGER OF
!                       ROUTINES GDSWIZ05 AND GDSWZD05.
!   2015-09-17  GAYNO   RENAME MODULE AS "GDSWZD_POLAR_STEREO_MOD"
!
! USAGE:  "USE GDSWZD_POLAR_STEREO_MOD"  THEN CALL THE PUBLIC DRIVER
!         ROUTINE "GDSWZD_POLAR_STEREO".
!
! ATTRIBUTES:
!   LANGUAGE: FORTRAN 90
!
!$$$
!
 IMPLICIT NONE

 PRIVATE

 PUBLIC                          :: GDSWZD_POLAR_STEREO

 REAL,             PARAMETER     :: PI=3.14159265358979
 REAL,             PARAMETER     :: DPR=180./PI
 REAL,             PARAMETER     :: PI2=PI/2.0
 REAL,             PARAMETER     :: PI4=PI/4.0

 INTEGER                         :: IROT

 REAL                            :: DE2, DXS, DYS
 REAL                            :: E2, RERTH , H, ORIENT

 CONTAINS

 SUBROUTINE GDSWZD_POLAR_STEREO(IGDTNUM,IGDTMPL,IGDTLEN,IOPT,NPTS, &
                                FILL,XPTS,YPTS,RLON,RLAT,NRET, &
                                CROT,SROT,XLON,XLAT,YLON,YLAT,AREA)
!$$$  SUBPROGRAM DOCUMENTATION BLOCK
!
! SUBPROGRAM:  GDSWZD_POLAR_STEREO   GDS WIZARD FOR POLAR STEREOGRAPHIC
!                                    AZIMUTHAL
!   PRGMMR: IREDELL       ORG: W/NMC23       DATE: 96-04-10
!
! ABSTRACT: THIS SUBPROGRAM DECODES THE GRIB 2 GRID DEFINITION
!           TEMPLATE (PASSED IN INTEGER FORM AS DECODED BY THE
!           NCEP G2 LIBRARY) AND RETURNS ONE OF THE FOLLOWING:
!             (IOPT=+1) EARTH COORDINATES OF SELECTED GRID COORDINATES
!             (IOPT=-1) GRID COORDINATES OF SELECTED EARTH COORDINATES
!           WORKS FOR POLAR STEREOGRAPHIC AZIMUTHAL PROJECTIONS.
!           IF THE SELECTED COORDINATES ARE MORE THAN ONE GRIDPOINT
!           BEYOND THE THE EDGES OF THE GRID DOMAIN, THEN THE RELEVANT
!           OUTPUT ELEMENTS ARE SET TO FILL VALUES.
!           THE ACTUAL NUMBER OF VALID POINTS COMPUTED IS RETURNED TOO.
!           OPTIONALLY, THE VECTOR ROTATIONS, MAP JACOBIANS, AND
!           GRID BOX AREAS MAY BE RETURNED AS WELL.  ROUTINE WORKS
!           FOR BOTH SPHERICAL AND ELLIPTICAL EARTHS WITH THE
!           EXCEPTION OF THE MAP JACOBIANS AND GRID BOX AREAS, WHICH
!           ARE ONLY COMPUTED FOR SPHERICAL EARTHS.  TO COMPUTE
!           THE VECTOR ROTATIONS, THE OPTIONAL ARGUMENTS 'SROT' AND 'CROT'
!           MUST BE PRESENT.  TO COMPUTE THE MAP JACOBIANS, THE
!           OPTIONAL ARGUMENTS 'XLON', 'XLAT', 'YLON', 'YLAT' MUST BE PRESENT.
!           TO COMPUTE THE GRID BOX AREAS, THE OPTIONAL ARGUMENT
!           'AREA' MUST BE PRESENT.
!
! PROGRAM HISTORY LOG:
!   96-04-10  IREDELL
!   97-10-20  IREDELL  INCLUDE MAP OPTIONS
!   09-05-13  GAYNO    ENSURE AREA ALWAYS POSITIVE
! 2015-01-21  GAYNO    MERGER OF GDSWIZ05 AND GDSWZD05.  MAKE
!                      CROT,SORT,XLON,XLAT,YLON,YLAT AND AREA
!                      OPTIONAL ARGUMENTS.  MAKE PART OF A MODULE.
!                      MOVE VECTOR ROTATION, MAP JACOBIAN AND GRID
!                      BOX AREA COMPUTATIONS TO SEPARATE SUBROUTINES.
!                      INCLUDE OPTION FOR ELLIPTICAL EARTHS.
! 2015-07-13  GAYNO    CONVERT TO GRIB 2. REPLACE GRIB 1 KGDS ARRAY
!                      WITH GRIB 2 GRID DEFINITION TEMPLATE ARRAY.
!                      RENAME ROUTINE AS "GDSWZD_POLAR_STEREO".
!
! USAGE:   CALL GDSWZD_POLAR_STEREO(IGDTNUM,IGDTMPL,IGDTLEN,IOPT,NPTS,
!    &                              FILL,XPTS,YPTS,RLON,RLAT,NRET,
!    &                              CROT,SROT,XLON,XLAT,YLON,YLAT,AREA)
!
!   INPUT ARGUMENT LIST:
!     IGDTNUM  - INTEGER GRID DEFINITION TEMPLATE NUMBER.
!                CORRESPONDS TO THE GFLD%IGDTNUM COMPONENT OF THE
!                NCEP G2 LIBRARY GRIDMOD DATA STRUCTURE.
!                MUST BE "20" FOR POLAR STEREOGRAPHIC GRIDS.
!     IGDTMPL  - INTEGER (IGDTLEN) GRID DEFINITION TEMPLATE ARRAY.
!                CORRESPONDS TO THE GFLD%IGDTMPL COMPONENT OF THE
!                NCEP G2 LIBRARY GRIDMOD DATA STRUCTURE FOR SECTION
!                THREE:
!                 (1):  SHAPE OF EARTH, OCTET 15
!                 (2):  SCALE FACTOR OF SPHERICAL EARTH RADIUS,
!                       OCTET 16
!                 (3):  SCALED VALUE OF RADIUS OF SPHERICAL EARTH,
!                       OCTETS 17-20
!                 (4):  SCALE FACTOR OF MAJOR AXIS OF ELLIPTICAL EARTH,
!                       OCTET 21
!                 (5):  SCALED VALUE OF MAJOR AXIS OF ELLIPTICAL EARTH,
!                       OCTETS 22-25
!                 (6):  SCALE FACTOR OF MINOR AXIS OF ELLIPTICAL EARTH,
!                       OCTET 26
!                 (7):  SCALED VALUE OF MINOR AXIS OF ELLIPTICAL EARTH,
!                       OCTETS 27-30
!                 (8):  NUMBER OF POINTS ALONG X-AXIS, OCTETS 31-34
!                 (9):  NUMBER OF POINTS ALONG Y-AXIS, OCTETS 35-38
!                 (10): LATITUDE OF FIRST GRID POINT, OCTETS 39-42
!                 (11): LONGITUDE OF FIRST GRID POINT, OCTETS 43-46
!                 (12): RESOLUTION AND COMPONENT FLAGS, OCTET 47
!                 (13): TRUE LATITUDE, OCTETS 48-51
!                 (14): ORIENTATION LONGITUDE, OCTETS 52-55
!                 (15): X-DIRECTION GRID LENGTH, OCTETS 56-59
!                 (16): Y-DIRECTION GRID LENGTH, OCTETS 60-63
!                 (17): PROJECTION CENTER FLAG, OCTET 64
!                 (18): SCANNING MODE FLAGS, OCTET 65
!     IGDTLEN  - INTEGER NUMBER OF ELEMENTS (18) OF THE GRID DEFINITION
!                TEMPLATE ARRAY.  CORRESPONDS TO THE GFLD%IGDTLEN
!                COMPONENT OF THE NCEP G2 LIBRARY GRIDMOD DATA STRUCTURE.
!     IOPT     - INTEGER OPTION FLAG
!                (+1 TO COMPUTE EARTH COORDS OF SELECTED GRID COORDS)
!                (-1 TO COMPUTE GRID COORDS OF SELECTED EARTH COORDS)
!     NPTS     - INTEGER MAXIMUM NUMBER OF COORDINATES
!     FILL     - REAL FILL VALUE TO SET INVALID OUTPUT DATA
!                (MUST BE IMPOSSIBLE VALUE; SUGGESTED VALUE: -9999.)
!     XPTS     - REAL (NPTS) GRID X POINT COORDINATES IF IOPT>0
!     YPTS     - REAL (NPTS) GRID Y POINT COORDINATES IF IOPT>0
!     RLON     - REAL (NPTS) EARTH LONGITUDES IN DEGREES E IF IOPT<0
!                (ACCEPTABLE RANGE: -360. TO 360.)
!     RLAT     - REAL (NPTS) EARTH LATITUDES IN DEGREES N IF IOPT<0
!                (ACCEPTABLE RANGE: -90. TO 90.)
!
!   OUTPUT ARGUMENT LIST:
!     XPTS     - REAL (NPTS) GRID X POINT COORDINATES IF IOPT<0
!     YPTS     - REAL (NPTS) GRID Y POINT COORDINATES IF IOPT<0
!     RLON     - REAL (NPTS) EARTH LONGITUDES IN DEGREES E IF IOPT>0
!     RLAT     - REAL (NPTS) EARTH LATITUDES IN DEGREES N IF IOPT>0
!     NRET     - INTEGER NUMBER OF VALID POINTS COMPUTED
!     CROT     - REAL, OPTIONAL (NPTS) CLOCKWISE VECTOR ROTATION COSINES
!     SROT     - REAL, OPTIONAL (NPTS) CLOCKWISE VECTOR ROTATION SINES
!                (UGRID=CROT*UEARTH-SROT*VEARTH;
!                 VGRID=SROT*UEARTH+CROT*VEARTH)
!     XLON     - REAL, OPTIONAL (NPTS) DX/DLON IN 1/DEGREES
!     XLAT     - REAL, OPTIONAL (NPTS) DX/DLAT IN 1/DEGREES
!     YLON     - REAL, OPTIONAL (NPTS) DY/DLON IN 1/DEGREES
!     YLAT     - REAL, OPTIONAL (NPTS) DY/DLAT IN 1/DEGREES
!     AREA     - REAL, OPTIONAL (NPTS) AREA WEIGHTS IN M**2
!                (PROPORTIONAL TO THE SQUARE OF THE MAP FACTOR)
!
! ATTRIBUTES:
!   LANGUAGE: FORTRAN 90
!
!$$$
 IMPLICIT NONE
!
 INTEGER,          INTENT(IN   ) :: IGDTNUM, IGDTLEN
 INTEGER,          INTENT(IN   ) :: IGDTMPL(IGDTLEN)
 INTEGER,          INTENT(IN   ) :: IOPT, NPTS
 INTEGER,          INTENT(  OUT) :: NRET
!
 REAL,             INTENT(IN   ) :: FILL
 REAL,             INTENT(INOUT) :: RLON(NPTS),RLAT(NPTS)
 REAL,             INTENT(INOUT) :: XPTS(NPTS),YPTS(NPTS)
 REAL, OPTIONAL,   INTENT(  OUT) :: CROT(NPTS),SROT(NPTS)
 REAL, OPTIONAL,   INTENT(  OUT) :: XLON(NPTS),XLAT(NPTS)
 REAL, OPTIONAL,   INTENT(  OUT) :: YLON(NPTS),YLAT(NPTS),AREA(NPTS)
!
 INTEGER                         :: IM, JM, IPROJ
 INTEGER                         :: ISCAN, JSCAN, ITER, N
!
 LOGICAL                         :: ELLIPTICAL, LROT, LMAP, LAREA
!
 REAL                            :: ALAT, ALAT1, ALONG, DIFF
 REAL                            :: DI, DJ, DE
 REAL                            :: DX, DY
 REAL                            :: DR, E, E_OVER_2, HI, HJ
 REAL                            :: MC, SLAT, SLATR
 REAL                            :: RLAT1, RLON1, RHO, T, TC
 REAL                            :: XMAX, XMIN, YMAX, YMIN
 REAL                            :: XP, YP, DR2
! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
 IF(PRESENT(CROT)) CROT=FILL
 IF(PRESENT(SROT)) SROT=FILL
 IF(PRESENT(XLON)) XLON=FILL
 IF(PRESENT(XLAT)) XLAT=FILL
 IF(PRESENT(YLON)) YLON=FILL
 IF(PRESENT(YLAT)) YLAT=FILL
 IF(PRESENT(AREA)) AREA=FILL
! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
! IS THIS A POLAR STEREOGRAPHIC GRID?
 IF(IGDTNUM/=20)THEN
   CALL POLAR_STEREO_ERROR(IOPT,FILL,RLAT,RLON,XPTS,YPTS,NPTS)
   RETURN
 ENDIF
! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
 CALL EARTH_RADIUS(IGDTMPL,IGDTLEN,RERTH,E2)
! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
! IS THE EARTH RADIUS AND ECCENTICITY DEFINED?
 IF(RERTH<0..OR.E2<0.0) THEN
   CALL POLAR_STEREO_ERROR(IOPT,FILL,RLAT,RLON,XPTS,YPTS,NPTS)
   RETURN
 ENDIF
! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
 ELLIPTICAL=.FALSE.  ! ELLIPTICAL EARTH
 IF(E2>0.0)ELLIPTICAL=.TRUE.
 IM=IGDTMPL(8)
 JM=IGDTMPL(9)
 RLAT1=FLOAT(IGDTMPL(10))*1.E-6
 RLON1=FLOAT(IGDTMPL(11))*1.E-6
 IROT=MOD(IGDTMPL(12)/8,2)
 SLAT=FLOAT(ABS(IGDTMPL(13)))*1.E-6
 SLATR=SLAT/DPR
 ORIENT=FLOAT(IGDTMPL(14))*1.E-6
 DX=FLOAT(IGDTMPL(15))*1.E-3
 DY=FLOAT(IGDTMPL(16))*1.E-3
 IPROJ=MOD(IGDTMPL(17)/128,2)
 ISCAN=MOD(IGDTMPL(18)/128,2)
 JSCAN=MOD(IGDTMPL(18)/64,2)
 H=(-1.)**IPROJ
 HI=(-1.)**ISCAN
 HJ=(-1.)**(1-JSCAN)
 DXS=DX*HI
 DYS=DY*HJ
!
! FIND X/Y OF POLE
 IF (.NOT.ELLIPTICAL) THEN
   DE=(1.+SIN(SLATR))*RERTH
   DR=DE*COS(RLAT1/DPR)/(1+H*SIN(RLAT1/DPR))
   XP=1-H*SIN((RLON1-ORIENT)/DPR)*DR/DXS
   YP=1+COS((RLON1-ORIENT)/DPR)*DR/DYS
   DE2=DE**2
 ELSE
   E=SQRT(E2)
   E_OVER_2=E*0.5
   ALAT=H*RLAT1/DPR
   ALONG = (RLON1-ORIENT)/DPR
   T=TAN(PI4-ALAT/2.)/((1.-E*SIN(ALAT))/  &
     (1.+E*SIN(ALAT)))**(E_OVER_2)
   TC=TAN(PI4-SLATR/2.)/((1.-E*SIN(SLATR))/  &
     (1.+E*SIN(SLATR)))**(E_OVER_2)
   MC=COS(SLATR)/SQRT(1.0-E2*(SIN(SLATR)**2))
   RHO=RERTH*MC*T/TC
   YP = 1.0 + RHO*COS(H*ALONG)/DYS
   XP = 1.0 - RHO*SIN(H*ALONG)/DXS
 ENDIF ! ELLIPTICAL
 XMIN=0
 XMAX=IM+1
 YMIN=0
 YMAX=JM+1
 NRET=0
 IF(PRESENT(CROT).AND.PRESENT(SROT))THEN
   LROT=.TRUE.
 ELSE
   LROT=.FALSE.
 ENDIF
 IF(PRESENT(XLON).AND.PRESENT(XLAT).AND.PRESENT(YLON).AND.PRESENT(YLAT))THEN
   LMAP=.TRUE.
 ELSE
   LMAP=.FALSE.
 ENDIF
 IF(PRESENT(AREA))THEN
   LAREA=.TRUE.
 ELSE
   LAREA=.FALSE.
 ENDIF
! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
!  TRANSLATE GRID COORDINATES TO EARTH COORDINATES
 IF(IOPT.EQ.0.OR.IOPT.EQ.1) THEN
   IF(.NOT.ELLIPTICAL)THEN
!$OMP PARALLEL DO PRIVATE(N,DI,DJ,DR2) REDUCTION(+:NRET) SCHEDULE(STATIC)
     DO N=1,NPTS
       IF(XPTS(N).GE.XMIN.AND.XPTS(N).LE.XMAX.AND. &
          YPTS(N).GE.YMIN.AND.YPTS(N).LE.YMAX) THEN
         DI=(XPTS(N)-XP)*DXS
         DJ=(YPTS(N)-YP)*DYS
         DR2=DI**2+DJ**2
         IF(DR2.LT.DE2*1.E-6) THEN
           RLON(N)=0.
           RLAT(N)=H*90.
         ELSE
           RLON(N)=MOD(ORIENT+H*DPR*ATAN2(DI,-DJ)+3600,360.)
           RLAT(N)=H*DPR*ASIN((DE2-DR2)/(DE2+DR2))
         ENDIF
           NRET=NRET+1
           IF(LROT) CALL POLAR_STEREO_VECT_ROT(RLON(N),CROT(N),SROT(N))
           IF(LMAP) CALL POLAR_STEREO_MAP_JACOB(RLON(N),RLAT(N), &
                                            XLON(N),XLAT(N),YLON(N),YLAT(N),DR2)
           IF(LAREA) CALL POLAR_STEREO_GRID_AREA(RLAT(N),AREA(N),DR2)
       ELSE
         RLON(N)=FILL
         RLAT(N)=FILL
       ENDIF
     ENDDO
!$OMP END PARALLEL DO
   ELSE ! ELLIPTICAL
!$OMP PARALLEL DO PRIVATE(N,DI,DJ,RHO,T,ALONG,ALAT1,ALAT,DIFF) REDUCTION(+:NRET) SCHEDULE(STATIC)
     DO N=1,NPTS
       IF(XPTS(N).GE.XMIN.AND.XPTS(N).LE.XMAX.AND.  &
          YPTS(N).GE.YMIN.AND.YPTS(N).LE.YMAX) THEN
         DI=(XPTS(N)-XP)*DXS
         DJ=(YPTS(N)-YP)*DYS
         RHO=SQRT(DI*DI+DJ*DJ)
         T=(RHO*TC)/(RERTH*MC)
         IF(ABS(YPTS(N)-YP)<0.01)THEN
           IF(DI>0.0) ALONG=ORIENT+H*90.0
           IF(DI<=0.0) ALONG=ORIENT-H*90.0
         ELSE
           ALONG=ORIENT+H*ATAN(DI/(-DJ))*DPR
           IF(DJ>0) ALONG=ALONG+180.
         END IF
         ALAT1=PI2-2.0*ATAN(T)
         DO ITER=1,10
           ALAT = PI2 - 2.0*ATAN(T*(((1.0-E*SIN(ALAT1))/  &
                 (1.0+E*SIN(ALAT1)))**(E_OVER_2)))
           DIFF = ABS(ALAT-ALAT1)*DPR
           IF (DIFF < 0.000001) EXIT
           ALAT1=ALAT
         ENDDO
         RLAT(N)=H*ALAT*DPR
         RLON(N)=ALONG
         IF(RLON(N)<0.0) RLON(N)=RLON(N)+360.
         IF(RLON(N)>360.0) RLON(N)=RLON(N)-360.0
         NRET=NRET+1
         IF(LROT) CALL POLAR_STEREO_VECT_ROT(RLON(N),CROT(N),SROT(N))
       ELSE
         RLON(N)=FILL
         RLAT(N)=FILL
       ENDIF
     ENDDO
!$OMP END PARALLEL DO
   ENDIF ! ELLIPTICAL
! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
!  TRANSLATE EARTH COORDINATES TO GRID COORDINATES
 ELSEIF(IOPT.EQ.-1) THEN
   IF(.NOT.ELLIPTICAL)THEN
!$OMP PARALLEL DO PRIVATE(N,DR,DR2) REDUCTION(+:NRET) SCHEDULE(STATIC)
     DO N=1,NPTS
       IF(ABS(RLON(N)).LE.360.AND.ABS(RLAT(N)).LE.90.AND. &
                                     H*RLAT(N).NE.-90) THEN
         DR=DE*TAN((90-H*RLAT(N))/2/DPR)
         DR2=DR**2
         XPTS(N)=XP+H*SIN((RLON(N)-ORIENT)/DPR)*DR/DXS
         YPTS(N)=YP-COS((RLON(N)-ORIENT)/DPR)*DR/DYS
         IF(XPTS(N).GE.XMIN.AND.XPTS(N).LE.XMAX.AND. &
            YPTS(N).GE.YMIN.AND.YPTS(N).LE.YMAX) THEN
           NRET=NRET+1
           IF(LROT) CALL POLAR_STEREO_VECT_ROT(RLON(N),CROT(N),SROT(N))
           IF(LMAP) CALL POLAR_STEREO_MAP_JACOB(RLON(N),RLAT(N), &
                                            XLON(N),XLAT(N),YLON(N),YLAT(N),DR2)
           IF(LAREA) CALL POLAR_STEREO_GRID_AREA(RLAT(N),AREA(N),DR2)
         ELSE
           XPTS(N)=FILL
           YPTS(N)=FILL
         ENDIF
       ELSE
         XPTS(N)=FILL
         YPTS(N)=FILL
       ENDIF
     ENDDO
!$OMP END PARALLEL DO
   ELSE  ! ELLIPTICAL CASE
!$OMP PARALLEL DO PRIVATE(N,ALAT,ALONG,T,RHO) REDUCTION(+:NRET) SCHEDULE(STATIC)
     DO N=1,NPTS
       IF(ABS(RLON(N)).LE.360.AND.ABS(RLAT(N)).LE.90.AND.  &
                                      H*RLAT(N).NE.-90) THEN
         ALAT = H*RLAT(N)/DPR
         ALONG = (RLON(N)-ORIENT)/DPR
         T=TAN(PI4-ALAT*0.5)/((1.-E*SIN(ALAT))/  &
           (1.+E*SIN(ALAT)))**(E_OVER_2)
         RHO=RERTH*MC*T/TC
         XPTS(N)= XP + RHO*SIN(H*ALONG) / DXS
         YPTS(N)= YP - RHO*COS(H*ALONG) / DYS
         IF(XPTS(N).GE.XMIN.AND.XPTS(N).LE.XMAX.AND.  &
            YPTS(N).GE.YMIN.AND.YPTS(N).LE.YMAX) THEN
           NRET=NRET+1
           IF(LROT) CALL POLAR_STEREO_VECT_ROT(RLON(N),CROT(N),SROT(N))
         ELSE
           XPTS(N)=FILL
           YPTS(N)=FILL
         ENDIF
       ELSE
         XPTS(N)=FILL
         YPTS(N)=FILL
       ENDIF
     ENDDO
!$OMP END PARALLEL DO
   ENDIF
 ENDIF
! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
 END SUBROUTINE GDSWZD_POLAR_STEREO
! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
 SUBROUTINE POLAR_STEREO_ERROR(IOPT,FILL,RLAT,RLON,XPTS,YPTS,NPTS)
!$$$  SUBPROGRAM DOCUMENTATION BLOCK
!
! SUBPROGRAM:  POLAR_STEREO_ERROR    ERROR HANDLER
!   PRGMMR: GAYNO       ORG: W/NMC23       DATE: 2015-07-13
!
! ABSTRACT: UPON AN ERROR, THIS SUBPROGRAM ASSIGNS
!           A "FILL" VALUE TO THE OUTPUT FIELDS.

! PROGRAM HISTORY LOG:
! 2015-07-13  GAYNO     INITIAL VERSION
!
! USAGE:    CALL POLAR_STEREO_ERROR(IOPT,FILL,RLAT,RLON,XPTS,YPTS,NPTS)
!
!   INPUT ARGUMENT LIST:
!     IOPT     - INTEGER OPTION FLAG
!                (+1 TO COMPUTE EARTH COORDS OF SELECTED GRID COORDS)
!                (-1 TO COMPUTE GRID COORDS OF SELECTED EARTH COORDS)
!     NPTS     - INTEGER MAXIMUM NUMBER OF COORDINATES
!     FILL     - REAL FILL VALUE TO SET INVALID OUTPUT DATA
!                (MUST BE IMPOSSIBLE VALUE; SUGGESTED VALUE: -9999.)
!   OUTPUT ARGUMENT LIST:
!     RLON     - REAL (NPTS) EARTH LONGITUDES IN DEGREES E IF IOPT<0
!     RLAT     - REAL (NPTS) EARTH LATITUDES IN DEGREES N IF IOPT<0
!     XPTS     - REAL (NPTS) GRID X POINT COORDINATES IF IOPT>0
!     YPTS     - REAL (NPTS) GRID Y POINT COORDINATES IF IOPT>0
!
! ATTRIBUTES:
!   LANGUAGE: FORTRAN 90
!
!$$$
 IMPLICIT NONE
!
 INTEGER, INTENT(IN   ) :: IOPT, NPTS
!
 REAL,    INTENT(IN   ) :: FILL
 REAL,    INTENT(  OUT) :: RLAT(NPTS),RLON(NPTS)
 REAL,    INTENT(  OUT) :: XPTS(NPTS),YPTS(NPTS)
! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
 IF(IOPT>=0) THEN
   RLON=FILL
   RLAT=FILL
 ENDIF
 IF(IOPT<=0) THEN
   XPTS=FILL
   YPTS=FILL
 ENDIF
! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
 END SUBROUTINE POLAR_STEREO_ERROR
!
 SUBROUTINE POLAR_STEREO_VECT_ROT(RLON, CROT, SROT)
!$$$  SUBPROGRAM DOCUMENTATION BLOCK
!
! SUBPROGRAM:  POLAR_STEREO_VECT_ROT   VECTOR ROTATION FIELDS FOR
!                                      POLAR STEREOGRAPHIC GRIDS.
!
!   PRGMMR: GAYNO     ORG: W/NMC23       DATE: 2015-01-21
!
! ABSTRACT: THIS SUBPROGRAM COMPUTES THE VECTOR ROTATION SINES AND
!           COSINES FOR A POLAR STEREOGRAPHIC AZIMUTHAL GRID.
!
! PROGRAM HISTORY LOG:
! 2015-01-21  GAYNO    INITIAL VERSION
! 2015-09-17  GAYNO    RENAME AS "POLAR_STEREO_VECT_ROT"
!
! USAGE:    CALL POLAR_STEREO_VECT_ROT(RLON,CROT,SROT)
!
!   INPUT ARGUMENT LIST:
!     RLON     - GRID POINT LONGITUDE IN DEGREES (REAL)
!
!   OUTPUT ARGUMENT LIST:
!     CROT     - CLOCKWISE VECTOR ROTATION COSINES (REAL)
!     SROT     - CLOCKWISE VECTOR ROTATION SINES (REAL)
!                (UGRID=CROT*UEARTH-SROT*VEARTH;
!                 VGRID=SROT*UEARTH+CROT*VEARTH)
!
! ATTRIBUTES:
!   LANGUAGE: FORTRAN 90
!
!$$$
!
 IMPLICIT NONE

 REAL,             INTENT(IN   ) :: RLON
 REAL,             INTENT(  OUT) :: CROT, SROT

 IF(IROT.EQ.1) THEN
   CROT=H*COS((RLON-ORIENT)/DPR)
   SROT=SIN((RLON-ORIENT)/DPR)
 ELSE
   CROT=1.
   SROT=0.
 ENDIF

 END SUBROUTINE POLAR_STEREO_VECT_ROT
!
 SUBROUTINE POLAR_STEREO_MAP_JACOB(RLON,RLAT,XLON,XLAT,YLON,YLAT,DR2)
!$$$  SUBPROGRAM DOCUMENTATION BLOCK
!
! SUBPROGRAM:  POLAR_STEREO_MAP_JACOB  MAP JACOBIANS FOR
!                                      POLAR STEREOGRAPHIC GRIDS.
!
!   PRGMMR: GAYNO     ORG: W/NMC23       DATE: 2015-01-21
!
! ABSTRACT: THIS SUBPROGRAM COMPUTES THE MAP JACOBIANS FOR
!           A POLAR STEREOGRAPHIC AZIMUTHAL GRID (SPHERICAL
!           EARTH).
!
! PROGRAM HISTORY LOG:
! 2015-01-21  GAYNO    INITIAL VERSION
! 2015-09-17  GAYNO    RENAME AS "POLAR_STEREO_MAP_JACOB"
!
! USAGE:  CALL POLAR_STEREO_MAP_JACOB(RLON,RLAT,XLON,XLAT,YLON,YLAT,DR2)
!
!   INPUT ARGUMENT LIST:
!     RLON     - LONGITUDE IN DEGREES (REAL)
!     RLAT     - LATITUDE IN DEGREES (REAL)
!     DR2      - SQUARED DISTANCE FROM POLE (REAL)
!
!   OUTPUT ARGUMENT LIST:
!     XLON     - DX/DLON IN 1/DEGREES (REAL)
!     XLAT     - DX/DLAT IN 1/DEGREES (REAL)
!     YLON     - DY/DLON IN 1/DEGREES (REAL)
!     YLAT     - DY/DLAT IN 1/DEGREES (REAL)
!
! ATTRIBUTES:
!   LANGUAGE: FORTRAN 90
!
!$$$
!
 IMPLICIT NONE

 REAL,             INTENT(IN   ) :: RLON, RLAT, DR2
 REAL,             INTENT(  OUT) :: XLON, XLAT, YLON, YLAT

 REAL                            :: CLAT, DE, DR

 IF(DR2.LT.DE2*1.E-6) THEN
   DE=SQRT(DE2)
   XLON=0.
   XLAT=-SIN((RLON-ORIENT)/DPR)/DPR*DE/DXS/2
   YLON=0.
   YLAT=H*COS((RLON-ORIENT)/DPR)/DPR*DE/DYS/2
 ELSE
   DR=SQRT(DR2)
   CLAT=COS(RLAT/DPR)
   XLON=H*COS((RLON-ORIENT)/DPR)/DPR*DR/DXS
   XLAT=-SIN((RLON-ORIENT)/DPR)/DPR*DR/DXS/CLAT
   YLON=SIN((RLON-ORIENT)/DPR)/DPR*DR/DYS
   YLAT=H*COS((RLON-ORIENT)/DPR)/DPR*DR/DYS/CLAT
 ENDIF

 END SUBROUTINE POLAR_STEREO_MAP_JACOB
!
 SUBROUTINE POLAR_STEREO_GRID_AREA(RLAT, AREA, DR2)
!$$$  SUBPROGRAM DOCUMENTATION BLOCK
!
! SUBPROGRAM:  POLAR_STEREO_GRID_AREA  GRID BOX AREA FOR
!                                      POLAR STEREOGRAPHIC GRIDS
!
!   PRGMMR: GAYNO     ORG: W/NMC23       DATE: 2015-01-21
!
! ABSTRACT: THIS SUBPROGRAM COMPUTES THE GRID BOX AREA FOR
!           A POLAR STEREOGRAPHIC AZIMUTHAL GRID (SPHERICAL
!           EARTH).
!
! PROGRAM HISTORY LOG:
! 2015-01-21  GAYNO    INITIAL VERSION
! 2015-09-17  GAYNO    RENAME AS "POLAR_STEREO_GRID_AREA".
!
! USAGE:  CALL POLAR_STEREO_GRID_AREA(RLAT,AREA)
!
!   INPUT ARGUMENT LIST:
!     RLAT     - LATITUDE OF GRID POINT IN DEGREES (REAL)
!     DR2      - SQUARED DISTANCE FROM POLE (REAL)
!
!   OUTPUT ARGUMENT LIST:
!     AREA     - AREA WEIGHTS IN M**2 (REAL)
!
! ATTRIBUTES:
!   LANGUAGE: FORTRAN 90
!
!$$$
!
 IMPLICIT NONE

 REAL,             INTENT(IN   ) :: RLAT, DR2
 REAL,             INTENT(  OUT) :: AREA

 REAL                            :: CLAT

 IF(DR2.LT.DE2*1.E-6) THEN
   AREA=RERTH**2*ABS(DXS)*ABS(DYS)*4/DE2
 ELSE
   CLAT=COS(RLAT/DPR)
   AREA=RERTH**2*CLAT**2*ABS(DXS)*ABS(DYS)/DR2
 ENDIF

 END SUBROUTINE POLAR_STEREO_GRID_AREA

 END MODULE GDSWZD_POLAR_STEREO_MOD


      SUBROUTINE EVALAB(A,b,x,N)
C
      IMPLICIT REAL*8(A-H,O-Z)
      DIMENSION A(*),b(N),x(N)
      REAL*8 l
C
      l=360.0
C
      RAC2=DSQRT(2.0D0)
C
C     Calcul de A
C     -----------
      DO i=1,21
         A(i)=0.0D0
      ENDDO
      A(1)  = 2*l * 1.0  / x(1)**3
      A(3)  = 2*l * 1.0  / x(2)**3
      A(6)  = 2*l * RAC2 / x(3)**3
      A(10) = 2*l * 1.0  / x(4)**3
      A(15) = 2*l * RAC2 / x(5)**3
      A(21) = 2*l * RAC2 / x(6)**3
C
C     Calcul de b
C     -----------
      b(1) = 3*l * 1.0  / x(1)**2
      b(2) = 3*l * 1.0  / x(2)**2
      b(3) = 3*l * RAC2 / x(3)**2
      b(4) = 3*l * 1.0  / x(4)**2
      b(5) = 3*l * RAC2 / x(5)**2
      b(6) = 3*l * RAC2 / x(6)**2
C
      RETURN
      END


      SUBROUTINE MB03ED( N, PREC, A, LDA, B, LDB, D, LDD, Q1, LDQ1, Q2,
     $                   LDQ2, Q3, LDQ3, DWORK, LDWORK, INFO )
C
C     SLICOT RELEASE 5.5.
C
C     Copyright (c) 2002-2012 NICONET e.V.
C
C     PURPOSE
C
C     To compute orthogonal matrices Q1, Q2, Q3 for a real 2-by-2 or
C     4-by-4 regular pencil
C
C                    ( A11  0  ) ( B11  0  )     (  0  D12 )
C       aAB - bD = a (         ) (         ) - b (         ),        (1)
C                    (  0  A22 ) (  0  B22 )     ( D21  0  )
C
C     such that Q3' A Q2 and Q2' B Q1 are upper triangular, Q3' D Q1 is
C     upper quasi-triangular, and the eigenvalues with negative real
C     parts (if there are any) are allocated on the top. The notation M'
C     denotes the transpose of the matrix M. The submatrices A11, A22,
C     B11, B22 and D12 are upper triangular. If D21 is 2-by-2, then all
C     other blocks are nonsingular and the product
C        -1        -1    -1        -1
C     A22   D21 B11   A11   D12 B22   has a pair of complex conjugate
C     eigenvalues.
C
C     ARGUMENTS
C
C     Input/Output Parameters
C
C     N       (input) INTEGER
C             The order of the input pencil, N = 2 or N = 4.
C
C     PREC    (input) DOUBLE PRECISION
C             The machine precision, (relative machine precision)*base.
C             See the LAPACK Library routine DLAMCH.
C
C     A       (input) DOUBLE PRECISION array, dimension (LDA, N)
C             The leading N-by-N upper triangular part of this array
C             must contain the upper triangular matrix A of the pencil
C             aAB - bD. The strictly lower triangular part and the
C             entries of the (1,2) block are not referenced.
C
C     LDA     INTEGER
C             The leading dimension of the array A.  LDA >= N.
C
C     B       (input) DOUBLE PRECISION array, dimension (LDB, N)
C             The leading N-by-N upper triangular part of this array
C             must contain the upper triangular matrix B of the pencil
C             aAB - bD. The strictly lower triangular part and the
C             entries of the (1,2) block are not referenced.
C
C     LDB     INTEGER
C             The leading dimension of the array B.  LDB >= N.
C
C     D       (input/output) DOUBLE PRECISION array, dimension (LDD, N)
C             On entry, the leading N-by-N part of this array must
C             contain the matrix D of the pencil aAB - bD.
C             On exit, if N = 4, the leading N-by-N part of this array
C             contains the transformed matrix D in real Schur form.
C             If N = 2, this array is unchanged on exit.
C
C     LDD     INTEGER
C             The leading dimension of the array D.  LDD >= N.
C
C     Q1      (output) DOUBLE PRECISION array, dimension (LDQ1, N)
C             The leading N-by-N part of this array contains the first
C             orthogonal transformation matrix.
C
C     LDQ1    INTEGER
C             The leading dimension of the array Q1.  LDQ1 >= N.
C
C     Q2      (output) DOUBLE PRECISION array, dimension (LDQ2, N)
C             The leading N-by-N part of this array contains the second
C             orthogonal transformation matrix.
C
C     LDQ2    INTEGER
C             The leading dimension of the array Q2.  LDQ2 >= N.
C
C     Q3      (output) DOUBLE PRECISION array, dimension (LDQ3, N)
C             The leading N-by-N part of this array contains the third
C             orthogonal transformation matrix.
C
C     LDQ3    INTEGER
C             The leading dimension of the array Q3.  LDQ3 >= N.
C
C     Workspace
C
C     DWORK   DOUBLE PRECISION array, dimension (LDWORK)
C             If N = 2, then DWORK is not referenced.
C
C     LDWORK  INTEGER
C             The dimension of the array DWORK.
C             If N = 4, then LDWORK >= 79. For good performance LDWORK
C             should be generally larger.
C             If N = 2, then LDWORK >= 0.
C
C     Error Indicator
C
C     INFO    INTEGER
C             = 0: succesful exit;
C             = 1: the QZ iteration failed in the LAPACK routine DGGES;
C             = 2: another error occured during execution of DGGES.
C
C     METHOD
C
C     The algorithm uses orthogonal transformations as described on page
C     20 in [2].
C
C     REFERENCES
C
C     [1] Benner, P., Byers, R., Mehrmann, V. and Xu, H.
C         Numerical computation of deflating subspaces of skew-
C         Hamiltonian/Hamiltonian pencils.
C         SIAM J. Matrix Anal. Appl., 24 (1), pp. 165-190, 2002.
C
C     [2] Benner, P., Byers, R., Losse, P., Mehrmann, V. and Xu, H.
C         Numerical Solution of Real Skew-Hamiltonian/Hamiltonian
C         Eigenproblems.
C         Tech. Rep., Technical University Chemnitz, Germany,
C         Nov. 2007.
C
C     NUMERICAL ASPECTS
C
C     The algorithm is numerically backward stable.
C
C     CONTRIBUTOR
C
C     Matthias Voigt, Fakultaet fuer Mathematik, Technische Universitaet
C     Chemnitz, October 22, 2008.
C
C     REVISIONS
C
C     V. Sima, Aug. 2009 (SLICOT version of the routine DBTFSX).
C     V. Sima, Oct. 2009, Nov. 2009, Oct. 2010, Nov. 2010.
C     M. Voigt, Jan. 2012.
C
C     KEYWORDS
C
C     Eigenvalue exchange, matrix pencil, upper (quasi-)triangular
C     matrix.
C
C     ******************************************************************
C
C     .. Parameters ..
      DOUBLE PRECISION   ZERO, ONE
      PARAMETER          ( ZERO = 0.0D+0, ONE = 1.0D+0 )
C
C     .. Scalar Arguments ..
      INTEGER            INFO, LDA, LDB, LDD, LDQ1, LDQ2, LDQ3, LDWORK,
     $                   N
      DOUBLE PRECISION   PREC
C
C     .. Array Arguments ..
      DOUBLE PRECISION   A( LDA, * ), B( LDB, * ), D( LDD, * ),
     $                   DWORK( * ), Q1( LDQ1, * ), Q2( LDQ2, * ),
     $                   Q3( LDQ3, * )
C
C     .. Local Scalars ..
      LOGICAL            COMPG
      INTEGER            IDUM, IEVS, IWRK
      DOUBLE PRECISION   A11, A22, B11, B22, CO, D12, D21, SI, TMP
C
C     .. Local Arrays ..
      LOGICAL            BWORK( 4 )
      DOUBLE PRECISION   DUM( 1 )
C
C     .. External Functions ..
      LOGICAL            SB02OW
      EXTERNAL           SB02OW
C
C     .. External Subroutines ..
      EXTERNAL           DCOPY, DGEQR2, DGGES, DLACPY, DLARTG, DORG2R,
     $                   DTRMM
C
C     .. Intrinsic Functions ..
      INTRINSIC          ABS, SIGN, SQRT
C
C     .. Executable Statements ..
C
C     For efficiency, the input arguments are not tested.
C
      INFO = 0
C
C     Computations.
C
      IF( N.EQ.4 ) THEN
         DUM( 1 ) = ZERO
         CALL DCOPY( 16, DUM, 0, DWORK, 1 )
         DWORK(  1 ) = B( 1, 1 )
         DWORK(  5 ) = B( 1, 2 )
         DWORK(  6 ) = B( 2, 2 )
         DWORK( 11 ) = B( 3, 3 )
         DWORK( 15 ) = B( 3, 4 )
         DWORK( 16 ) = B( 4, 4 )
         CALL DTRMM( 'Left', 'Upper', 'No Transpose', 'NonUnit', 2, 4,
     $               ONE, A, LDA, DWORK, N )
         CALL DTRMM( 'Left', 'Upper', 'No Transpose', 'NonUnit', 2, 2,
     $               ONE, A( 3, 3 ), LDA, DWORK( 11 ), N )
         IEVS = N*N  + 1
         IWRK = IEVS + 3*N
         CALL DGGES( 'Vector Computation', 'Vector Computation',
     $               'Sorted', SB02OW, N, D, LDD, DWORK, N, IDUM,
     $               DWORK( IEVS ), DWORK( IEVS+N ), DWORK( IEVS+2*N ),
     $               Q3, LDQ3, Q1, LDQ1, DWORK( IWRK ), LDWORK-IWRK+1,
     $               BWORK, INFO )
         IF( INFO.NE.0 ) THEN
            IF( INFO.GE.1 .AND. INFO.LE.4 ) THEN
               INFO = 1
               RETURN
            ELSE IF ( INFO.NE.6 ) THEN
               INFO = 2
               RETURN
            ELSE
               INFO = 0
            END IF
         END IF
         CALL DLACPY( 'Full', N, N, Q1, LDQ1, Q2, LDQ2 )
         CALL DTRMM(  'Left', 'Upper', 'No Transpose', 'NonUnit', 2, 4,
     $                ONE, B, LDB, Q2, LDQ2 )
         CALL DTRMM(  'Left', 'Upper', 'No Transpose', 'NonUnit', 2, 4,
     $                ONE, B( 3, 3 ), LDB, Q2( 3, 1 ), LDQ2 )
         CALL DGEQR2( N, N, Q2, LDQ2, DWORK, DWORK( N+1 ), INFO )
         CALL DORG2R( N, N, N, Q2, LDQ2, DWORK, DWORK( N+1 ), INFO )
      ELSE
C
C        The pencil has infinite eigenvalues. The code decides this when
C        A or B is (numerically) singular. Although the numerical
C        singularity of A*B with respect to PREC is detected, the
C        eigenvalues will not be infinite, but large, when neither A
C        nor B is (numerically) singular. This allows a more accurate
C        computation of the transformed A and B (using Q1, Q2, and Q3),
C        as well as of the eigenvalues.
C
         A11   = ABS( A( 1, 1 ) )
         A22   = ABS( A( 2, 2 ) )
         B11   = ABS( B( 1, 1 ) )
         B22   = ABS( B( 2, 2 ) )
         D21   = ABS( D( 2, 1 ) )
         D12   = ABS( D( 1, 2 ) )
         COMPG = .FALSE.
         IF( A11*B11.LE.PREC*A22*B22 ) THEN
            IF(  A11.LE.PREC*A22 ) THEN
               Q1( 1, 1 ) = ONE
               Q1( 2, 1 ) = ZERO
               Q1( 1, 2 ) = ZERO
               Q1( 2, 2 ) = ONE
               Q2( 1, 1 ) = ONE
               Q2( 2, 1 ) = ZERO
               Q2( 1, 2 ) = ZERO
               Q2( 2, 2 ) = ONE
               Q3( 1, 1 ) = ZERO
               Q3( 2, 1 ) = -ONE
               Q3( 1, 2 ) = -ONE
               Q3( 2, 2 ) = ZERO
            ELSE IF( B11.LE.PREC*B22 ) THEN
               Q1( 1, 1 ) = -ONE
               Q1( 2, 1 ) = ZERO
               Q1( 1, 2 ) = ZERO
               Q1( 2, 2 ) = -ONE
               Q2( 1, 1 ) = ZERO
               Q2( 2, 1 ) = ONE
               Q2( 1, 2 ) = ONE
               Q2( 2, 2 ) = ZERO
               Q3( 1, 1 ) = ZERO
               Q3( 2, 1 ) = ONE
               Q3( 1, 2 ) = ONE
               Q3( 2, 2 ) = ZERO
            ELSE
               COMPG = .TRUE.
            END IF
         ELSE IF( A22*B22.LE.PREC*A11*B11 ) THEN
            IF( A22.LE.PREC*A11 ) THEN
               Q1( 1, 1 ) = ZERO
               Q1( 2, 1 ) = ONE
               Q1( 1, 2 ) = ONE
               Q1( 2, 2 ) = ZERO
               Q2( 1, 1 ) = ZERO
               Q2( 2, 1 ) = ONE
               Q2( 1, 2 ) = ONE
               Q2( 2, 2 ) = ZERO
               Q3( 1, 1 ) = -ONE
               Q3( 2, 1 ) = ZERO
               Q3( 1, 2 ) = ZERO
               Q3( 2, 2 ) = -ONE
            ELSE IF( B22.LE.PREC*B11 ) THEN
               Q1( 1, 1 ) = ZERO
               Q1( 2, 1 ) = -ONE
               Q1( 1, 2 ) = -ONE
               Q1( 2, 2 ) = ZERO
               Q2( 1, 1 ) = ONE
               Q2( 2, 1 ) = ZERO
               Q2( 1, 2 ) = ZERO
               Q2( 2, 2 ) = ONE
               Q3( 1, 1 ) = ONE
               Q3( 2, 1 ) = ZERO
               Q3( 1, 2 ) = ZERO
               Q3( 2, 2 ) = ONE
            ELSE
               COMPG = .TRUE.
            END IF
C
C        The pencil has a double zero eigenvalue.
C
         ELSE IF( D21.LE.PREC*D12 ) THEN
            Q1( 1, 1 ) = ONE
            Q1( 2, 1 ) = ZERO
            Q1( 1, 2 ) = ZERO
            Q1( 2, 2 ) = ONE
            Q2( 1, 1 ) = ONE
            Q2( 2, 1 ) = ZERO
            Q2( 1, 2 ) = ZERO
            Q2( 2, 2 ) = ONE
            Q3( 1, 1 ) = ONE
            Q3( 2, 1 ) = ZERO
            Q3( 1, 2 ) = ZERO
            Q3( 2, 2 ) = ONE
         ELSE IF( D12.LE.PREC*D21 ) THEN
            Q1( 1, 1 ) = ZERO
            Q1( 2, 1 ) = ONE
            Q1( 1, 2 ) = ONE
            Q1( 2, 2 ) = ZERO
            Q2( 1, 1 ) = ZERO
            Q2( 2, 1 ) = ONE
            Q2( 1, 2 ) = ONE
            Q2( 2, 2 ) = ZERO
            Q3( 1, 1 ) = ZERO
            Q3( 2, 1 ) = ONE
            Q3( 1, 2 ) = ONE
            Q3( 2, 2 ) = ZERO
         ELSE
            COMPG = .TRUE.
         END IF
C
         IF( COMPG ) THEN
C
C           The pencil has real eigenvalues.
C
            CALL DLARTG( SIGN( ONE, A( 1, 1 )*B( 1, 1 )*A( 2, 2 )*
     $                   B( 2, 2 ) )*SQRT( A22*B22*D12 ),
     $                   SQRT( A11*B11*D21 ), CO, SI, TMP )
            Q1( 1, 1 ) =  CO
            Q1( 2, 1 ) = -SI
            Q1( 1, 2 ) =  SI
            Q1( 2, 2 ) =  CO
            CALL DLARTG( SIGN( ONE, A( 1, 1 )*A( 2, 2 ) )*
     $                   SQRT( A22*B11*D12 ), SQRT( A11*B22*D21 ), CO,
     $                   SI, TMP )
            Q2( 1, 1 ) =  CO
            Q2( 2, 1 ) = -SI
            Q2( 1, 2 ) =  SI
            Q2( 2, 2 ) =  CO
            CALL DLARTG( SQRT( A11*B11*D12 ), SQRT( A22*B22*D21 ), CO,
     $                   SI, TMP )
            Q3( 1, 1 ) =  CO
            Q3( 2, 1 ) = -SI
            Q3( 1, 2 ) =  SI
            Q3( 2, 2 ) =  CO
         END IF
      END IF
C
      RETURN
C *** Last line of MB03ED ***
      END


If you had to write 10-12 lines of code (excl. declarations) showing
the strengths and diversity of Modern Fortran to a newbie, what could
that be? Not necessarily solving any real problem, just showing the
capabilities of the language.

Beliavsky

@Arjen has shown 4 how to use recursion and the array functionality of
Fortran (pack, array sections, vectorized comparisons) to write quicksort
very concisely. Here is a lightly modified code of his, with a driver.

module qsort_mod
implicit none
contains
pure recursive function qsort(data) result(sorted)
real, intent(in) :: data(:)
real             :: sorted(size(data))
if (size(data) > 1) then
   sorted = [qsort(pack(data(2:),data(2:)<data(1))), data(1), &
             qsort(pack(data(2:),data(2:)>=data(1)))]
else
   sorted = data
end if
end function qsort
end module qsort_mod
!
program main
use qsort_mod, only: qsort
implicit none
real :: x(10)
call random_seed()
call random_number(x)
write (*,"(a10,*(1x,f0.3))") "initial",x
write (*,"(a10,*(1x,f0.3))") "sorted",qsort(x)
end program main

sample output:

   initial .869 .394 .228 .657 .793 .416 .494 .657 .851 .471
    sorted .228 .394 .416 .471 .494 .657 .657 .793 .851 .869

Edit: With the newly approved conditional expressions 2, the body of the function can be just one line:

sorted = (size(data) > 1 ? &
      sorted = [qsort(pack(data(2:),data(2:)<data(1))), data(1), &
                qsort(pack(data(2:),data(2:)>=data(1)))] : &
      data )

FortranFan
22h

    … With the newly approved conditional expressions , the body of the function can be just one line:

    sorted = (size(data) > 1 ? &
          sorted = [qsort(pack(data(2:),data(2:)<data(1))), data(1), &
                    qsort(pack(data(2:),data(2:)>=data(1)))] : &
          data )

You mean

sorted = (size(data) > 1 ? &
! if size(data) > 1 condition is true
   [qsort(pack(data(2:),data(2:)<data(1))), data(1), &
       qsort(pack(data(2:),data(2:)>=data(1)))] :  &
! or else
    data )

FortranFan
20h

Well, if one wanted to simply show the strength and diversity of modern
Fortran, especially in terms of Fortran being an evolving multiparadigm
language with focus on numerical computing and performance, a silly
illustrator can also be as follows, it’s not as short as you seek but
not all that long either:

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
end

You will notice the example builds on recent newbie discussions on this forum with

    recursion to determine a number sequence, the Fibonacci series here,
    the use of structured programming in program flow,
    modular programming with auto-generated explicit interfaces to procedures,
    the use of explicit INTENTs with procedure parameters,
    along with functional programming aspects to process arrays elementally,
    it combines that with object-oriented design to establish a “store” of number sequences,
    it hints at templated programming via a parameterized type for the store, and
    it employs parallel programming toward the calculations to stock that store of sequences

So you can see there is a lot going on in there that touches upon many
of the facilities now available in Fortran.

Here’s the expected output using one processor that outputs the
first 40 elements (5 per parallel compute image times 8 images) in the
Fibonacci sequence:

    C:\Temp>ifort /standard-semantics /Qcoarray:shared /Qcoarray-num-images=8 e.f90
    Intel(R) Fortran Intel(R) 64 Compiler Classic for applications running on Intel(R) 64, Version 2021.3.0 Build 20210609_000000
    Copyright (C) 1985-2021 Intel Corporation. All rights reserved.

    Microsoft (R) Incremental Linker Version 14.29.30038.1
    Copyright (C) Microsoft Corporation. All rights reserved.

    -out:e.exe
    -subsystem:console
    e.obj

    C:\Temp>e.exe
    0 1 1 2 3 5 8 13 21 34 55 89 144 233 377 610 987 1597 2584 4181 6765 10946 17711 28657 46368 75025 121393 196418 317811 514229 832040 1346269 2178309 3524578 5702887 9227465 14930352 24157817 39088169 63245986

msz59

Thanks a lot for great samples! @FortranFan, could you please remind me what does len in
integer, len :: n = 5 mean? My memory seems to have a hole at this very place :slight_smile:
FortranFan
7h

    @FortranFan, could you please remind me what does len in
    integer, len :: n = 5 mean? My memory seems to have a hole at this very place

It refers to the length-type parameter of a parameterized type. It
has some similarity in terms of semantics and syntax with length of a
CHARACTER intrinsic type as in character(len= and how one works with
that parameter. The use of such types can help to some degree with
“genericization” of one’s methods (procedures) e.g., a subroutine
that can reverse any string, or as shown above, filling a store of number
sequences of any length.

The standard document itself, or “Modern Fortran Explained”, or some
of the vendor language reference sites are good places to peruse if you
want to look up further.

Federchen

Only a code snippet though, but it’s taken from my today’s
prototyping, coarray (runtime) parallel code as well. Spin-wait loops
are usually inside synchronization routines; here it’s taken to the
parallel logic codes to allow the programmer to do some calculation
there instead of leaving the coarray image just idle waiting for the
synchronization to complete.

Naming conventions are a matter of taste, but Fortran makes it easy to
implement features with very few lines of code and keep things readable,
I would say.

!*****
  case (Enum_ImageType % ControlImage) ! on the control image
    control_FinishedFragmentedMethod: block
      integer(OOOGglob_kint), dimension (1:intNumberOfExecutingImages, 1:2) :: intA_ExecutingImageAndFMValue
      integer(OOOGglob_kint) :: intNumberOfSuccessfulRemoteNotifys
      !
      ! wait until all the execute images do signal that they are in state FinishedFragmentedMethod:
      spin_wait: do
        !********* local abort timer (time limit) for the spin-wait loop:
        call system_clock(count = intTime2); reaTimeShift = real(intTime2-intTime1) / reaCountRate
        if (reaTimeShift > reaTimeLimitInSec) logNotifyFailure = .true. ! time limit exceeded
        !*********
        if (nofy_SyncFragmentedMethod % IsNotifyWait (intFragmentedMethodNotifyStatus, &
            intNumberOfExecutingImages, intA_ExecutingImageNumbers, &
            intNumberOfSuccessfulRemoteNotifys = intNumberOfSuccessfulRemoteNotifys, &
            intA_RemoteImageAndItsScalarIntegerValueToTransfer = intA_ExecutingImageAndFMValue, &
            logNoSpinWaitLoop = .true.)) then
          ! IsNotifyWait was successfull, no further action is required
        else ! the IsNotifyWait did fail
          logNotifyFailure = .true.
        end if
        if (intNumberOfSuccessfulRemoteNotifys == intNumberOfExecutingImages) exit spin_wait ! successfull
        if (logNotifyFailure) exit spin_wait ! non-successfull
      end do spin_wait
      !
      write(*,*) '==============================================================================='
      write(*,*) 'On the contol image, the newly collected and now adjusted FMValues: ', intA_ExecutingImageAndFMValue(:,2)
      write(*,*) '==============================================================================='
      write(*,*) 'Number Of Successful Remote Notifys: ', intNumberOfSuccessfulRemoteNotifys
      !
      if (logNotifyFailure) return ! non-successfull
    end block control_FinishedFragmentedMethod
  !*****
  end select finished_fragmented_method

msz59
2h

    The standard document itself, or “Modern Fortran Explained” ,
    or some of the vendor language reference sites are good places to
    peruse if you want to look up further.

Thanks a lot for refreshing my memory, indeed PDTs come with len or kind
attributes to type parameters. Following your advise I checked MFE and,
incidentally, found an erroneous code snippet there, namely Figure 13.2
on p. 282:

  type character_with_max_length(maxlen, kind)
    integer, len :: maxlen
    integer, kind :: kind = selected_char_kind('default')
    integer       :: length = 0
    character(kind) :: value(maxlen)     ! ERROR 1
  end type

  type(character_with_max_length(100)) :: name

  name = character_with_max_length(100)('John Hancock')  ! ERROR 2

1 - as is, it defines value to be a maxlen-elements array of characters
instead of a character object of len=maxlen; it should probably read
character(maxlen, kind) :: value

2 - this error is reported by ifort; , 'John Hancock' is interpreted
(positionally) as value for length component and thus the component value
is not set (though it should be, as there is no default given). To fix
it, one can add explicit component name: (value='John Hancock')

With ERROR 2 fixed, ERROR 1 shows only in runtime, segfaulting the program
(ifort version 2021.3.0 on Ubuntu 20.04), though I am not quite sure
why. Outside of type constructor, an array of characters may be assigned
with a longer string, resulting in all elements of the array being set
to ‘J’. Probably inside the constructor, the type compatibility
requirements are stricter. But if it is really so, it should probably
be reported during compile time (?)


c*****************************************************************************
c Unit test program TLLSQ.F for subroutine LLSQ
c Ported to UNIX 11/10/1992
c ier=0 indicates success during individual runs...
c*****************************************************************************
      include 'VICMAIN_FOR'
      subroutine main44
      real*4       x(2,2), qr(5,3)
      integer*4    m, n, ip, ifail, ipiv(2)
      real*4       a(3,2) /1.1, 1.2, 1.0, 0.9, 1.0, 1.0/
      real*4       b(3,2) /2.2, 2.3, 2.1, 4.4, 4.6, 4.2/
      real*4       eps/1.e-7/
      character*80 msg

c  1.1  0.9  2.2
c  1.2  1.0  2.3
c  1.0  1.0  2.1
c*****************************************************************************
c  Fortran test
c*****************************************************************************
      call xvmessage('Testing FORTRAN-callable LLSQ',' ')
      m = 3
      n = 2
      ip = 2
      ifail = 1

      call llsq(a,b,m,n,ip,x,ipiv,eps,ifail,qr)

      if (ifail.eq.0) go to 20
      write (msg,99996) ifail
      call xvmessage(msg,' ')
      return
20    continue
      call xvmessage('output should be 1.301 0.7935 2.602 1.587',' ')
      call prnt(7,4,x,'first run = .')

c  check error handling

      call xvmessage('test error handling. should get ier=1', ' ')
      call zia(a,3)

      call llsq(a,b,m,n,ip,x,ipiv,eps,ifail,qr)

      write (msg,99996) ifail
      call xvmessage(msg,' ')

c*****************************************************************************
c C test
c*****************************************************************************
      call xvmessage('Testing C-callable LLSQ',' ')
      m = 3
      n = 2
      ip = 2
      ifail = 1
      a(1,1) = 1.1
      a(2,1) = 1.2
      a(3,1) = 1.0
      a(1,2) = 0.9
      a(2,2) = 1.0
      a(3,2) = 1.0
      b(1,1) = 2.2
      b(2,1) = 2.3
      b(3,1) = 2.1
      b(1,2) = 4.4
      b(2,2) = 4.6
      b(3,2) = 4.2

      call tzllsq(a,b,m,n,ip,x,ipiv,eps,ifail,qr)

      if (ifail.eq.0) go to 40
      write (msg,99996) ifail
      call xvmessage(msg,' ')
      return
40    continue
      call xvmessage('output should be 1.301 0.7935 2.602 1.587',' ')
      call prnt(7,4,x,'C-callable output = .')

c  check error handling

      call xvmessage('error handling test. should get ier=1', ' ')
      call zia(a,3)

      call tzllsq(a,b,m,n,ip,x,ipiv,eps,ifail,qr)

      write (msg,99996) ifail
      call xvmessage(msg,' ')

      return
99996 format ('error in llsq, ifail =  ' , i2)
      end