cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
c...File cdnozg.f                                                      c
cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc

      program cdnozg

c        Computes the grid for a converging-diverging nozzle (CD Nozzle)
c        as described in AIAA-87-0355 by M.S. Liou.  Geometry and grid
c        are in units of inches.
c
c-----------------------------------------------------------------------

      Implicit none

      Integer nim, njm, nkm

      Parameter ( nim  = 501 )
      Parameter ( njm  = 151 )
      Parameter ( nkm  =  31 )

      Integer idim
      Integer i, j, k
      Integer ni, nj, nk

      Real farea
      Real pi
      Real xx, ax, rx
      Real spwall
      Real thetnz, thet
      Real sprmi, sprmax

      Real x (nim,njm,nkm)
      Real y (nim,njm,nkm)
      Real z (nim,njm,nkm)
      Real s (njm)

c-----------------------------------------------------------------------

c...Header.

      write(*,*) ' '
      write(*,*) '--- cdnozg ---'

c...Constants.

      pi = 4.0 * atan(1.0)

c...Specify dimension of domain.

      write(*,*) ' '
      write(*,*) 'Enter domain dimensions'
      write(*,*) '(1) 2D, (2) Axisymmetric, (3) Quasi-3D, (4) 3D'
      read (*,*) idim

c...Specify the dimensions of the grid.  For 3D (idim=4), a 5 degree
c...section of the nozzle is swept out.

      write(*,*) ' '

      if ( idim .eq. 4 ) then
        write(*,*) 'Enter ni, nj, nk'
        read (*,*) ni, nj, nk
        thetnz = 5.0 * pi / 180.0
      else
        nk = 1
        write(*,*) 'Enter ni, nj'
        read (*,*) ni, nj
      endif

c...Specify the wall spacing.

      write(*,*) ' '
      write(*,*) 'Enter the wall spacing (inches)'
      read (*,*) spwall

c...Generate the grid.

      open ( unit=7, file='rx.d', form='formatted', status='unknown' )

      sprmax = 0.0

      do  i = 1, ni

        xx = 10.0 * ( i - 1.0 ) / ( ni - 1.0 )
        ax = farea( xx )
        rx = sqrt( ax / pi )
        write(7,'(2(2x,f12.5))') xx, rx

c...    Compute the distribution of radial grid points.

        s(1)  = 0.0
        if     ( idim .eq. 1 ) then
          s(nj) = ax
          call sptanh ( nj, s, spwall, spwall, 0, 0 )
        elseif ( idim .eq. 2 ) then
          s(nj) = rx
          call sptanh ( nj, s, spwall, spwall, 0, 0 )
        elseif ( idim .eq. 3 ) then
          s(nj) = 1.0
          call speven ( nj, s )
        elseif ( idim .eq. 4 ) then
          s(nj) = rx
          call sptanh ( nj, s, spwall, spwall, 0, 0 )
        endif

        call gsprat ( s, nj, sprmi )
        if ( sprmi .gt. sprmax )  sprmax = sprmi

c...    Load grid.

        if     ( idim .eq. 1  .or.  idim .eq. 2 ) then
          do  j = 1, nj
            x(i,j,1) = xx
            y(i,j,1) = s(j)
            z(i,j,1) = 1.0
          enddo
        elseif ( idim .eq. 3 ) then
          do  j = 1, nj
            x(i,j,1) = xx
            y(i,j,1) = s(j)
            z(i,j,1) = rx
          enddo
        elseif ( idim .eq. 4 ) then
          do  j = 1, nj
            do  k = 1, nk
              thet     = thetnz * ( k - 1.0 ) / ( nk - 1.0 )
              x(i,j,k) = xx
              y(i,j,k) = s(j) * cos(thet)
              z(i,j,k) = s(j) * sin(thet)
            enddo
          enddo
        endif

      enddo

c...Write out grid quality statements.

      write (*,*) ' '
      write (*,*) 'sprmax = ', sprmax

c...Write out the grid as a Plot3d file.

      write (*,*) ' '
      write (*,*) 'Writing out grid (cdnoz.txt)'

c...  open ( unit=8, file='cdnoz.z', form='unformatted', status='unknown' )
c...  write(8) c cdnoz.z --zip --binary

      open(unit=8,file='cdnoz.txt',status='unknown',form='formatted')

      write (8,*) ni, nj, nk
      write (8,*) ((( x(i,j,k), i=1,ni), j=1,nj), k=1,nk),
     &          ((( y(i,j,k), i=1,ni), j=1,nj), k=1,nk),
     &          ((( z(i,j,k), i=1,ni), j=1,nj), k=1,nk)

c...End Statement.

      write (*,*) '     '
      write (*,*) '--- End of cdnozg ---'
      write (*,*) '     '

c-----------------------------------------------------------------------

      stop
      end

cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc

      function farea ( x )

c...Function for area of converging-divirging duct from aiaa-87-0355,
c...M.S. liou (reference 75).
c
c-----------------------------------------------------------------------

      Implicit none
      Real farea, x, pi

c-----------------------------------------------------------------------

      pi = 4.0 * atan(1.0)

      if ( x .lt. 5.0 ) then
        farea = 1.75 - 0.75 * cos( ( 0.2 * x - 1.0 ) * pi )
      else
        farea = 1.25 - 0.25 * cos( ( 0.2 * x - 1.0 ) * pi )
      endif

c-----------------------------------------------------------------------

      return
      end

cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
c...file  gsprat.f  ( grid spacing ratio )                             c
cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc

      subroutine gsprat ( s, n, sprmax )

c     Computes the maximum ratio between two grid points for a curve.
c
c-----------------------------------------------------------------------

      Integer i, n
      Real s(*), spa, spb, spr, sprmax

c-----------------------------------------------------------------------

      spa    = s(2) - s(1)
      spb    = s(3) - s(2)
      sprmax = max( spa, spb ) / min( spa, spb ) - 1.0

      do  i = 3, n - 1
        spa    = s(i) - s(i-1)
        spb    = s(i+1) - s(i)
        spr    = max( spa, spb ) / min( spa, spb ) - 1.0
        sprmax = max( sprmax, spr )
      enddo

c-----------------------------------------------------------------------

      return
      end

cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
c...file  speven.f  ( evenly spaced grid )                             c
cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc

      subroutine speven ( n, s )

c     Distributes s evenly given number of points, n, and the boundary
c     values, s(1) and s(n).
c
c     n       Number of points
c     s       Parametric variable
c
c-----------------------------------------------------------------------

      Implicit none

c.....Argument variables.

      Integer n

      Real s (n)

c.....Local variables.

      Integer i

c-----------------------------------------------------------------------

c.....Perform a uniform distribution.

      do  i = 2, n-1
        s(i) = s(1) + ( i - 1. ) * ( s(n) - s(1) ) / ( n - 1. )
      enddo

c-----------------------------------------------------------------------

      return
      end

cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
c   The subroutine sptanh is a front end for the routine vinkiter and  c
c   vink                                                               c
c                                                                      c
cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc

      subroutine sptanh ( lmax, s, dsae, dsbe, kase, nlast )

c      implicit double precision (a-h,o-z)

      dimension s(lmax)
      integer mxit

      smin = s(1)
      smax = s(lmax)

cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc

c.....VINKITER
c.....Vinokur's function creates a distribution of grid points which
c.....satisfy a specified derivative condition, but we require a delta-s
c.....constraint instead. These two values are equivalent only to first
c.....order, and hence, we resort to an iterative procedure to obtain
c.....more accurate delta-s's. Up to ten iterative sweeps are
c.....made. The first guess sets ds/dxi = delta-s. The next guess
c.....recalculates ds/dxi using the leading term in the truncation error
c.....(d2s/d(xi)**2). The next eight iterations use a 2-d secant
c.....algorithm to home in on the ds/dxi's at both ends which will give
c.....the correct delta-s.  In the cases where a single-sided
c.....stretching function is required, (kase = 1 or 2) a secant
c.....algorithm in 1-d is applied instead.
c.....Inputs:
c.....   kase = 0 -> delta-s specified on both ends so use a 2D secant
c.....               method to arrive at the values of dsa and dsb
c.....               that will satisfy ds1e and ds2e within roundoff.
c.....   kase = 1 -> delta-s specified at the last endpoint only, so
c.....               use a 1-D secant method to arrive at the value
c.....               of dsb that will satisfy dsbe within roundoff.
c.....   kase = 2 -> delta-s specified at the first endpoint only, so
c.....               use a 1-D secant method to arrive at the value
c.....               of dsa which will satisfy ds1e within roundoff.
c
c      subroutine vinkiter( s, lmax, smin, smax, dsae, dsbe,
c     &                     kase, nlast )
c
c#ifdef DP
c      implicit double precision (a-h,o-z)
c#endif

c      dimension s(*)
c      integer mxit

c#ifdef DP
c      tolmin2 = 1.0d-14
c#else
      tolmin2 = 1.0e-07
c#endif
      tolmin  = tolmin2 * tolmin2

      mxit = 20

      if ( kase .eq. 0 ) then

c........Initial guess, an = dsae, bn = dsbe.

         an2 = dsae
         bn2 = dsbe
         call vink(s,lmax,smin,smax,an2,bn2,esa,esb,kase )
         fn2 = esa / dsae - 1
         gn2 = esb / dsbe - 1

c........Second guess, calculate ds1 and ds2 from a truncated
c........Taylor Series.

         dssa = 2.*s(   1)-5.*s(     2)+4.*s(     3)   -s(     4)
         dssb = 2.*s(lmax)-5.*s(lmax-1)+4.*s(lmax-2)   -s(lmax-3)
         an1 = dsae-0.5*dssa
         bn1 = dsbe+0.5*dssb
         call vink(s,lmax,smin,smax,an1,bn1,esa,esb,kase )
         fn1 = esa/dsae - 1
         gn1 = esb/dsbe - 1
         an  = an1
         bn  = bn1

c........3rd thru nth guesses, use 2-d secant method.

         do 10 n = 3, mxit
c...........Calculate offset derivatives.
            call vink(s,lmax,smin,smax,an2,bn1,esa21,esb21,kase )
            call vink(s,lmax,smin,smax,an1,bn2,esa12,esb12,kase )
            fa = ( esa - esa21 )/dsae
            fb = ( esa - esa12 )/dsae
            ga = ( esb - esb21 )/dsbe
            gb = ( esb - esb12 )/dsbe
            den = fa*gb - fb*ga
            dela = -(an1 - an2)
            delb = -(bn1 - bn2)
c...........Stick with last guess if approaching roundoff.
            if ( abs(den) .lt. tolmin)then
               call vink(s,lmax,smin,smax,an,bn,esa,esb,kase )
               return
            end if
c...........Calculate next distribution.
            an = an1 + dela*(  gb*fn1 - fb*gn1 )/den
            bn = bn1 + delb*(- ga*fn1 + fa*gn1 )/den
            call vink(s,lmax,smin,smax,an,bn,esa,esb,kase )
            fn = esa/dsae - 1
            gn = esb/dsbe - 1
c...........Update n, n-1, n-2 and continue.
            an2 = an1
            bn2 = bn1
            an1 = an
            bn1 = bn
            fn1 = fn
            gn1 = gn
   10    continue

      else if ( kase .eq. 1 ) then

c........Initial guess, bn = dsbe.

         bn2 = dsbe
         call vink(s,lmax,smin,smax,dsae,bn2,esa,esb,kase )
         fn2 = esb/dsbe - 1

c........Second guess, calculate ds1 and ds2 from a truncated
c........Taylor Series.

         dssb = 2.*s(lmax)-5.*s(lmax-1)+4.*s(lmax-2)   -s(lmax-3)
         bn1 = dsbe-0.5*dssb
         call vink(s,lmax,smin,smax,dsae,bn1,esa,esb,kase )
         fn1 = esb/dsbe - 1
         bn = bn1

c........3rd thru nth guesses, use 1-d secant method.

         do 20 n = 3, mxit
c...........Stick with last guess if approaching roundoff.
            den = fn1-fn2
            if ( abs(den) .lt. tolmin2)then
               call vink(s,lmax,smin,smax,dsae,bn,esa,esb,kase )
               return
            end if
c...........Calculate next distribution.
            bn = bn1 - fn1*(bn1-bn2)/den
            call vink(s,lmax,smin,smax,dsae,bn,esa,esb,kase )
            fn = esb/dsbe - 1
c...........Update n, n-1, n-2 and continue.
            bn2 = bn1
            bn1 = bn
            fn2 = fn1
            fn1 = fn
   20    continue

      else if ( kase .eq. 2 ) then

c........Initial guess, an = dsae.

         an2 = dsae
         call vink(s,lmax,smin,smax,an2,dsbe,esa,esb,kase )
         fn2 = esa/dsae - 1

c........Second guess, calculate ds1 and ds2 from a truncated
c........Taylor Series.

         dssa = 2.*s(   1)-5.*s(     2)+4.*s(     3)   -s(     4)
         an1 = dsae-0.5*dssa
         call vink(s,lmax,smin,smax,an1,dsbe,esa,esb,kase )
         fn1 = esa/dsae - 1
         an = an1

c........3rd thru nth guesses, use 1-d secant method.

         do 30 n = 3, mxit
c...........Stick with last guess if approaching roundoff.
            den = fn1-fn2
            if(abs(den) .lt. tolmin2)then
               call vink(s,lmax,smin,smax,an,dsbe,esa,esb,kase )
               return
            end if
c...........Calculate next distribution.
            an = an1 - fn1*(an1-an2)/den
            call vink(s,lmax,smin,smax,an,dsbe,esa,esb,kase )
            fn = esa/dsae - 1
c...........Update n, n-1, n-2 and continue.
            an2 = an1
            an1 = an
            fn2 = fn1
            fn1 = fn
   30    continue

      end if

      return
      end

cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc

c.....VINK
c.....Distributes points on a curve so that specified derivatives
c.....at the edges are satisfied (from NASA CR 3313 by Vinokur, 1980).
c.....Vinokur's algorithm is designed to distribute a specified
c.....number of points along a curve, given the number of points,
c.....the length of the curve, and the deriviative conditions at
c.....both ends of the curve. In CFD applications, the user would
c.....usually rather specify the delta-s's at the ends of the curve,
c.....which are equivalent to the derivatives only to first order.
c.....Therefore, the user may wish to apply this algorithm iteratively
c.....to obtain an exact delta-s specification. Subroutine
c.....vinkiter will iterate on this scheme until the proper delta-s
c.....constraints are satisfied.
c.....Inputs:
c.....   lmax -> number of points on the curve
c.....   smin, smax -> beginning and end values of s
c.....   ds1,  ds2  -> the derivative end conditions input into
c.....                 Vinokur's function
c.....   kase = 0 -> satisfy delta-s on both ends
c.....        = 1 -> satisfy delta-s only at xi=ximax
c.....        = 2 -> satisfy delta-s only at xi=ximin
c.....Outputs:
c.....   s(xi) -> resulting s distribution from Vinokur's function
c.....   es1 -> ( s(ximin+1)-s(ximin) ) <-  calculated delta-s
c.....   es2 -> ( s(ximax)-s(ximax-1) ) <-
c.....Note:
c.....   Additionally, this version uses the approximate inverse
c.....   solution for y=sin(x)/x and y=sinh(x)/x rather than a Newton
c.....   iteration. The approximate solution was also taken from
c.....   NASA CR 3313.

      subroutine vink( s, lmax, smin, smax, ds1, ds2, es1, es2, kase )

c#ifdef DP
c      implicit double precision (a-h,o-z)
c#endif

      dimension s(*), d1(4,2), d2(4,2)

      pi = 4.0 * atan(1.0)

c.....Initialization.

      sdel = smax - smin
      s0 = sdel / real( lmax-1 ) / ds1
      s1 = sdel / real( lmax-1 ) / ds2
      b = sqrt( s0 * s1 )
      a = sqrt( s0 / s1 )
      if ( kase .eq. 1 ) then
         b = s1
      else if ( kase .eq. 2 ) then
         b = s0
      endif

c.....Calculate x based on value of B.

      if ( b .lt. 1.0 ) then

c........x is real.

         if ( b .lt. 0.26938972 ) then
            x = ( 1.0
     &          - b
     &          + b**2
     &          - ( 1.0 + PI ** 2.0 / 6.0 ) * b**3
     &          +  6.794732 * b**4
     &          - 13.205501 * b**5
     &          + 11.726095 * b**6 )
     &        * PI
         else
            c = 1.0 - b
            x = ( 1.0
     &          + 0.15 * c
     &          + 0.057321429 * c**2
     &          + 0.048774238 * c**3
     &          - 0.053337753 * c**4
     &          + 0.075845134 * c**5 )
     &        * sqrt( 6.0 * c )
         endif

      else if ( b .eq. 1.0 ) then

c........x is zero.

         x = 0.0

      else

c........x is imaginary.

         if ( b .lt. 2.7829681 ) then
            c = b - 1.0
            x = ( 1.0
     &          - 0.15 * c
     &          + 0.0573214290 * c**2
     &          - 0.0249072950 * c**3
     &          + 0.0077424461 * c**4
     &          - 0.0010794123 * c**5 )
     &        * sqrt( 6.0 * c )
         else
            v = log(b)
            w = 1.0 / b - 0.028527431
            x = v + ( 1.0 + 1.0 / v ) * log( 2.0*v ) - 0.02041793
     &        + 0.24902722 * w
     &        + 1.9496443 * w**2
     &        - 2.6294547 * w**3
     &        + 8.56795911 * w**4
         endif

      endif

c.....Distribute points along edge.

      if ( kase .eq. 1 .or. kase .eq. 2 ) then
         s(1   ) = 0.0
         s(lmax) = sdel
         do 9 i = 2, lmax-1
            j = lmax + 1 - i
            xi = real(i-1) / (lmax-1)
            if ( b .gt. 1.0001 ) then
               u1 = 1.0 + tanh( x/2.0 * ( xi - 1.0 ) )
     &                  / tanh( x/2.0 )
            else if ( b .lt. 0.9999 ) then
               u1 = 1.0 + tan ( x/2.0 * ( xi - 1.0 ) )
     &                  / tan ( x/2.0 )
            else
               u1 = xi * ( 1.0 - 0.5 * ( b - 1.0 ) * ( 1.0 - xi )
     &            * ( 2.0 - xi ) )
            endif
            u2 = sinh( xi*x ) / sinh( x )
            if ( kase .eq. 1 ) then
               fact = abs( ds1 )
               s(j) = ( ( 1.0 - fact ) * ( 1.0 - u1 )
     &              + fact * ( 1.0 - u2 ) ) * sdel
            else if ( kase .eq. 2 ) then
               fact = abs( ds2 )
               s(i) = ( ( 1.0 - fact ) * u1 + fact * u2 ) * sdel
            endif
    9    continue
      else
         do 5 i = 1, lmax
            xi = real(i-1) / real(lmax-1)
            cnum = x * ( xi-0.5 )
            cden = x / 2.0
            if ( b .lt. 0.9999 ) then
               cc = tan(cnum) / tan(cden)
               u = 0.5 * ( 1.0 + cc )
            else if ( b .ge. 0.9999 .and. b .le. 1.0001 ) then
               u = xi * ( 1.0 + 2.0 * ( b - 1.0 ) * ( xi - 0.5 )
     &           * ( 1.0 - xi ) )
            else if ( b .gt. 1.0001 ) then
               cc = tanh(cnum) / tanh(cden)
               u = 0.5 * ( 1.0 + cc )
            endif
            s(i) = u * sdel / ( a + ( 1.0 - a ) * u )
    5    continue
      endif

      do 8 l = 1, lmax
         s(l) = s(l) + smin
    8 continue
      es1 = s(   2) - s(     1)
      es2 = s(lmax) - s(lmax-1)

      return
      end


module jacobi_interface
  interface
    subroutine jacobi(a, b, u, eps, nmaxit, ier)
      implicit none

      real, dimension(:,:) :: a
      real, dimension(:) :: b, u
      real :: eps
      integer nmaxit, ier
    end subroutine
  end interface
end module


MODULE Mult_Normal
! Code converted using TO_F90 by Alan Miller
! Date: 2003-12-15  Time: 09:34:54

!     ALGORITHM AS285 APPL. STATIST. (1993) VOL.42, NO.3

!  FINDS THE PROBABILITY THAT A NORMALLY DISTRIBUTED RANDOM
!  N-VECTOR WITH MEAN 0 AND COVARIANCE COVAR FALLS
!  IN AREA ENCLOSED BY THE EXTERNAL USER-DEFINED FUNCTION F.

IMPLICIT NONE
INTEGER, SAVE  :: ix, iy, iz

CONTAINS

SUBROUTINE mulnor(covar, n, f, sdev, rhigh, init, iseed, t, work, prob,  &
    iter, ifault)

IMPLICIT NONE
REAL, INTENT(IN OUT)     :: covar(*)
INTEGER, INTENT(IN)      :: n
REAL, INTENT(IN)         :: sdev
REAL, INTENT(IN)         :: rhigh
INTEGER, INTENT(IN)      :: init
INTEGER, INTENT(IN OUT)  :: iseed
REAL, INTENT(IN OUT)     :: t(*)
REAL, INTENT(OUT)        :: work(n,*)
REAL, INTENT(OUT)        :: prob
INTEGER, INTENT(OUT)     :: iter
INTEGER, INTENT(OUT)     :: ifault

INTERFACE
  FUNCTION f(n, v) RESULT(fn_val)
    INTEGER, INTENT(IN)  :: n
    REAL, INTENT(IN)     :: v(:)
    REAL                 :: fn_val
  END FUNCTION f
END INTERFACE

INTEGER  :: init1, k, ii, kk, q, nn, nullty, i, j
REAL     :: p, var, cox

REAL, PARAMETER     :: zero = 0.0
INTEGER, PARAMETER  :: maxitr = 10000

ifault = 0
init1 = init
IF (init < 25) init1 = 25
IF (init > 1000) init1 = 1000
cox = 1.0 + 2.0/init1

!  FIND CHOLESKY DECOMPOSITION OF COVARIANCE MATRIX

nn = n*(n+1)/2
CALL chol(covar, n, nn, t, nullty, ifault)
q = n - nullty
ifault = ifault*ifault
IF (ifault /= 0) RETURN

!  TRANSPOSE CHOLESKY FACTOR, OMITTING COLUMNS OF ZEROES.
!  RESULTING VECTOR IS PACKED FORM OF T'J,
!  WRITTEN ROWWISE BEGINNING WITH LAST ROW.

DO  i = 1,n
  work(1:i,i) = zero
END DO
ii = 0
DO  i = 1,n
  DO  j = 1,i
    ii = ii + 1
    work(i,j) = t(ii)
  END DO
END DO
j = 0
DO  i = n,1,-1
  IF (j == nullty) EXIT
  IF (work(i,i) == zero) THEN
    j = j+1
    DO  k = i+1,n
      DO  kk = i, n-j
        work(k,kk) = work(k,kk+1)
      END DO
    END DO
  END IF
END DO

k = 0
DO  j = n,1,-1
  DO  i = 1, MIN(j,q)
    k = k + 1
    t(k) = work(j,i)
  END DO
END DO

!  TAKE PILOT SAMPLE; ESTIMATE VARIANCE OF PROB FROM ORTHP.

prob = zero
var = zero
DO  k=1,init1
  CALL orthp(f, rhigh, n, q, t, work, p, iseed, ifault)
  IF (ifault /= 0) RETURN
  prob = prob + p
  var = var + p*p
END DO
prob = prob/init1
var = var/init1 - prob*prob

iter = INT(cox*var/(sdev*sdev)) + 1
IF (iter > maxitr) ifault = 5

DO  k=init1+1, iter
  CALL orthp(f, rhigh, n, q, t, work, p, iseed, ifault)
  IF (ifault /= 0) RETURN
  prob = prob + (p - prob)/k
END DO

RETURN
END SUBROUTINE mulnor

SUBROUTINE chol(a, n, nn, u, nullty, ifault)

IMPLICIT NONE
INTEGER, INTENT(IN)   :: nn
REAL, INTENT(IN)      :: a(nn)
INTEGER, INTENT(IN)   :: n
REAL, INTENT(IN OUT)  :: u(nn)
INTEGER, INTENT(OUT)  :: nullty
INTEGER, INTENT(OUT)  :: ifault

REAL     :: eta2, x, w
INTEGER  :: j, k, ii, icol, l, kk, m, irow, i

REAL, PARAMETER  :: eta = 1.0E-05, zero = 0.0

! zabs(x) = ABS(x)
! zsqrt(x) = SQRT(x)

ifault = 1
IF (n <= 0) RETURN
ifault = 3
IF (nn /= n*(n+1)/2) RETURN
ifault = 2
nullty = 0
j = 1
k = 0
eta2 = eta*eta
ii = 0
DO  icol = 1,n
  ii = ii + icol
  x = eta2 * a(ii)
  l = 0
  kk = 0
  DO  irow = 1, icol
    kk = kk + irow
    k = k+1
    w = a(k)
    m = j
    DO  i = 1, irow
      l = l + 1
      IF (i == irow) EXIT
      w = w - u(l) * u(m)
      m = m + 1
    END DO
    IF (irow == icol) EXIT
    IF (u(l) == zero) GO TO 30
    u(k) = w / u(l)
    CYCLE
    30 IF (w * w > abs(x * a(kk))) RETURN
    u(k) = zero
  END DO
  IF (abs(w) <= abs(eta * a(k))) GO TO 60
  IF (w < zero) RETURN
  u(k) = sqrt(w)
  GO TO 70
  60 u(k) = zero
  nullty = nullty + 1
  70 j = j + icol
END DO
ifault = 0
RETURN
END SUBROUTINE chol

FUNCTION chiprb(x, df) RESULT(fn_val)

!  FINDS THE PROBABILITY THAT A CHI-SQUARED RANDOM VARIABLE
!  WITH DF DEGREES OF FREEDOM EXCEEDS X.
!  ADAPTED FROM HILL AND PIKE (1967) ALG. 299, CHI-SQUARED INTEGRAL,
!  COMM. ACM, VOL.10, 243-244.

IMPLICIT NONE
REAL, INTENT(IN)     :: x
INTEGER, INTENT(IN)  :: df
REAL                 :: fn_val

REAL     :: a, sqrta, y, c, e, z, s
INTEGER  :: odd, n2, i
!     REAL ERF

REAL, PARAMETER  :: rtpirp = 0.564189583547756
REAL, PARAMETER  :: big = 88.03, small = -85.2, zero = 0.0, one = 1.0, &
   half = 0.5

!  NOTE: IF THE FUNCTION "ERF" IS AVAILABLE, THE ABOVE STATEMENT
!  FUNCTION MAY BE REPLACED BY
!     ZERFP1(A) = ERF(A) + ONE

s = zero
IF (x > big) GO TO 50
s = one
IF (x < small) GO TO 50

a = half*x
y = EXP(-a)
odd = MOD(df,2)
IF (odd == 0) THEN
  s = y
  e = one
  z = zero
ELSE
  sqrta = SQRT(a)
  s = zerfp1(-sqrta)
  e = rtpirp/sqrta
  z = -half
END IF
IF (df < 3) GO TO 50

n2 = df/2 - 1 + odd
c = zero
DO  i = 1,n2
  z = z + 1
  e = e*(a/z)
  c = c + e
END DO
s = s + c*y

50 fn_val = s
RETURN
END FUNCTION chiprb

SUBROUTINE orthp(f, rhigh, n, q, t, z, prob, iseed, ifault)

!  FINDS THE PSEUDO-MONTE CARLO ESTIMATE OF PROB USING AN
!  ORTHONORMAL SYSTEM OF VECTORS.

IMPLICIT NONE
REAL, INTENT(IN)         :: rhigh
INTEGER, INTENT(IN)      :: n
INTEGER, INTENT(IN)      :: q
REAL, INTENT(IN)         :: t(*)
REAL, INTENT(IN OUT)     :: z(n,*)
REAL, INTENT(OUT)        :: prob
INTEGER, INTENT(IN OUT)  :: iseed
INTEGER, INTENT(OUT)     :: ifault

INTERFACE
  FUNCTION f(n, v) RESULT(fn_val)
    INTEGER, INTENT(IN)  :: n
    REAL, INTENT(IN)     :: v(:)
    REAL                 :: fn_val
  END FUNCTION f
END INTERFACE

INTEGER  :: i, j, k, jj, ii, qp1, qp2
REAL     :: s, a, b, r, fab

! EXTERNAL f
REAL, PARAMETER  :: zero = 0.0, rt2rcp = 0.707106781

prob = zero
qp1 = q+1
qp2 = q+2

!  PUT RANDOMLY ORIENTED ORTHONORMAL SYSTEM OF Q-VECTORS IN Z.

CALL rnortm(n,q, qp1, 1, 1, z(1,qp1), 1, z(1,qp1), iseed, z,  &
    z(1,qp1), fab, z(1,qp2), z(1,qp2), ifault)

!  REPLACE EACH COLUMN OF Z BY TRANS(CHOLESKY FACTOR)*J*COLUMN OF Z.

DO  i=1,q
  jj = 0
  DO  j = n,1,-1
    s = zero
    DO  k=1, MIN(j,q)
      jj = jj + 1
      s = s + t(jj)*z(k,i)
    END DO
    z(j,i) = s
  END DO
END DO

!  ESTIMATE THE PROBABILITY THAT N(0,COVAR) IS WITHIN THE BOUNDARY GIVEN BY F.

DO  i = 1,q
  a = zero
  b = rhigh
  CALL zerovc (f, r, a, b, n, z(1,i), z(1,qp2), ifault)
  prob = prob - chiprb(r*r, q)
END DO

DO  i = 1,q
  a = zero
  b = rhigh
  DO  k = 1,n
    z(k,qp1) = -z(k,i)
  END DO
  CALL zerovc (f, r, a, b, n, z(1,qp1), z(1,qp2), ifault)
  prob = prob - chiprb(r*r, q)
END DO

DO  i = 1,q-1
  DO  j = i+1,q
    DO  jj= -1,1,2
      DO  ii = -1,1,2
        DO  k=1,n
          z(k,qp1) = rt2rcp*(z(k,i)*ii + z(k,j)*jj)
        END DO
        a = zero
        b = rhigh
        CALL zerovc (f,r,a,b,n,z(1,qp1),z(1,qp2),ifault)
        prob = prob - chiprb(r*r,q)
      END DO
    END DO
  END DO
END DO
prob = prob/(2.0*q*q) + 1.0

RETURN
END SUBROUTINE orthp

SUBROUTINE rnortm(lda, n, np1, ibconf, nb, b, ndbi, dbi, iseed, a,  &
    chisq, fab, u, w, ifault)

!      ALGORITHM AS 127  APPL. STATIST.  (1978) VOL.27, NO.2

!      RNORTM GENERATES ORTHOGONAL MATRICES A FROM A DISTRIBUTION WITH
!      DENSITY FUNCTION DEFINED ON THE GROUP OF ORTHOGONAL MATRICES.
!      WHEN THE INPUT PARAMETER IBCONF = 1 THE MATRICES ARE
!      GENERATED FROM THE INVARIANT HAAR MEASURE.

IMPLICIT NONE
INTEGER, INTENT(IN)      :: lda
INTEGER, INTENT(IN)      :: n
INTEGER, INTENT(IN)      :: np1
INTEGER, INTENT(IN)      :: ibconf
INTEGER, INTENT(IN)      :: nb
REAL, INTENT(IN OUT)     :: b(nb)
INTEGER, INTENT(IN)      :: ndbi
REAL, INTENT(IN OUT)     :: dbi(ndbi)
INTEGER, INTENT(IN OUT)  :: iseed
REAL, INTENT(OUT)        :: a(lda,n)
REAL, INTENT(IN OUT)     :: chisq(n)
REAL, INTENT(OUT)        :: fab
REAL, INTENT(OUT)        :: u(np1)
REAL, INTENT(OUT)        :: w(n)
INTEGER, INTENT(OUT)     :: ifault

REAL    :: ul, wl, wil, wwil, t2, hv, hw
INTEGER :: i, j, l, np1l
INTEGER :: lp1

REAL, PARAMETER  :: zero = 0.0, one = 1.0

!      STATEMENT FUNCTIONS FOR DOUBLE PRECISION
!      DOUBLE PRECISION SQRT, SIGN, ABS
!      SQRT(UL) = DSQRT(UL)
!      SIGN(UL, WL) = DSIGN(UL, WL)
!      ABS(UL) = DABS(UL)

!      SECTION 1 INITIALIZATION

ifault = 0
GO TO 4

!      ERROR RETURNS

2 ifault = 2
RETURN

!      INITIALIZE DENSITY, H(STORED IN A), AND IBSUB

4 fab = one
DO  i=1,n
  a(i,1:n) = zero
  a(i,i) = one
END DO

!      CONSTRUCT  A  ONE COLUMN AT A TIME

DO  l=1,n
  np1l = np1 - l

!      SECTION 2
!      CONSTRUCT U(L...N) UNIFORMLY DISTRIBUTED ON THE SURFACE OF THE
!      (N+1-L)-SPHERE OF RADIUS UL = SQRT(CHISQ(L)).

  CALL normal(u(l), np1l+1, iseed, chisq(l))
  ul = SQRT(chisq(l))
  IF (ul == zero) GO TO 2
  IF (l == n) GO TO 301

!      SECTION 3
!      CALCULATE  W = B*U  AND STORE ITS LENGTH IN WL.
!      SIGN OF WL PREVENTS LOSS OF SIGNIFICANCE IN WWIL.

!      B IS IDENTITY

  wl = SIGN(ul,-u(l))
  DO  j=l,n
    w(j) = u(j)
  END DO

!      SECTION 4
!      PROJECT  W  ONTO ORTHOGOANL COMPLEMENT OF FIRST L-1
!      COLUMNS OF A, NORMALIZE, AND STORE IN L COLUMN OF A.
!      A(L) = H(L) * W * WIL
!      CALCULATE PROJECTION MATRIX H(L) FOR ORTHOGOANL
!      COMPLEMENT OF FIRST L COLUMNS OF A AND STORE IN LAST
!      N-L COLUMNS OF A.

  lp1 = l+1
  wil = one/wl
  wwil = one/(wl - w(l))
  DO  i=1,n
    t2 = zero
    DO  j=l,n
      t2 = t2 + a(i,j) * w(j)
    END DO
    hv = t2 * wil
    hw = (hv - a(i,l)) * wwil
    a(i,l) = hv
    DO  j = lp1, n
      a(i,j) = a(i,j) - hw*w(j)
    END DO
  END DO

!      END OF L COLUMN OF MATRIX A

!      SECTION 5
!      WHEN L = N ONLY SIGN NEEDS TO BE CHOSEN
!      REMEMBER MATRIX H(N) IS STORED IN N COLUMN OF A.

  301 IF (u(l) > zero) CYCLE
  DO  i=1,n
    a(i,l) = -a(i,l)
  END DO

!      FAB = ABS(B(LAST) * DBI(N)*FAB)

END DO
fab = ABS(fab)

RETURN
END SUBROUTINE rnortm

SUBROUTINE zerovc (f, r, r0, r1, n, v, y, ifault)

!  CALCULATES THE SOLUTION R TO F(R*V) = 0.

IMPLICIT NONE
REAL, INTENT(OUT)     :: r
REAL, INTENT(IN OUT)  :: r0
REAL, INTENT(IN OUT)  :: r1
INTEGER, INTENT(IN)   :: n
REAL, INTENT(IN)      :: v(n)
REAL, INTENT(OUT)     :: y(n)
INTEGER, INTENT(OUT)  :: ifault

INTERFACE
  FUNCTION f(n, v) RESULT(fn_val)
    INTEGER, INTENT(IN)  :: n
    REAL, INTENT(IN)     :: v(:)
    REAL                 :: fn_val
  END FUNCTION f
END INTERFACE

INTEGER  :: j
REAL     :: f0, f1, fr
REAL, PARAMETER     :: half = 0.5, eta = 1.0E-05
INTEGER, PARAMETER  :: niter = 500

y(1:n) = r0*v(1:n)
f0 = f(n,y)
y(1:n) = r1*v(1:n)
f1 = f(n,y)
IF (SIGN(half,f1) == SIGN(half,f0)) THEN
  ifault = 3
  RETURN
END IF
DO  j = 1,niter
  r = r1 - f1*(r1-r0)/(f1-f0)
  y(1:n) = r*v(1:n)
  fr = f(n, y)
  IF (abs(r-r1) < eta) GO TO 50
  IF (SIGN(half,fr) /= SIGN(half,f1)) THEN
    r0=r1
    f0=f1
  ELSE
    f0 = f0 * half
  END IF
  r1 = r
  f1 = fr
END DO
ifault = 6

50 RETURN
END SUBROUTINE zerovc

FUNCTION zerfp1(a) RESULT(fn_val)
IMPLICIT NONE
REAL, INTENT(IN)  :: a
REAL              :: fn_val

REAL, PARAMETER  :: sqrt2 = 1.41421356237309

fn_val = 2.0*alnorm(sqrt2*a, .false.)
RETURN
END FUNCTION zerfp1

SUBROUTINE normal(u, np1, iseed, chisq)

!  GENERATES AN (NP1-1)-VECTOR OF INDEPENDENT NORMAL VARIATES IN U.
!  ON OUTPUT, CHISQ CONTAINS THE SQUARED LENGTH OF THE VECTOR.

IMPLICIT NONE

INTEGER, INTENT(IN)      :: np1
REAL, INTENT(OUT)        :: u(np1)
INTEGER, INTENT(IN OUT)  :: iseed
REAL, INTENT(OUT)        :: chisq

INTEGER  :: i, ifault

! COMMON /rand/ ix,iy,iz
REAL, PARAMETER  :: zero = 0.0

chisq = zero
DO  i = 1, np1-1
  CALL ppnd(random(), ifault, u(i))
  chisq = chisq + u(i)*u(i)
END DO
RETURN
END SUBROUTINE normal

SUBROUTINE ppnd(p, ifault, fn_val)

!  ALGORITHM AS 111  APPL. STATIST. (1977), VOL.26, NO.1

!  PRODUCES NORMAL DEVIATE CORRESPONDING TO LOWER TAIL AREA OF P
!  REAL VERSION FOR EPS = 2 **(-31)
!  THE HASH SUMS ARE THE SUMS OF THE MODULI OF THE COEFFICIENTS
!  THEY HAVE NO INHERENT MEANINGS BUT ARE INCLUDED FOR USE IN
!  CHECKING TRANSCRIPTIONS
!  STANDARD FUNCTIONS ABS, ALOG AND SQRT ARE USED

IMPLICIT NONE
REAL, INTENT(IN)      :: p
INTEGER, INTENT(OUT)  :: ifault
REAL, INTENT(OUT)     :: fn_val

REAL :: q, r

REAL, PARAMETER  :: zero = 0.0E0, half = 0.5E0, one = 1.0E0
REAL, PARAMETER  :: split = 0.42E0
REAL, PARAMETER  :: a0 = 2.50662823884E0
REAL, PARAMETER  :: a1 = -18.61500062529E0
REAL, PARAMETER  :: a2 = 41.39119773534E0
REAL, PARAMETER  :: a3 = -25.44106049637E0
REAL, PARAMETER  :: b1 = -8.47351093090E0
REAL, PARAMETER  :: b2 = 23.08336743743E0
REAL, PARAMETER  :: b3 = -21.06224101826E0
REAL, PARAMETER  :: b4 = 3.13082909833E0
REAL, PARAMETER  :: c0 = -2.78718931138E0
REAL, PARAMETER  :: c1 = -2.29796479134E0
REAL, PARAMETER  :: c2 = 4.85014127135E0
REAL, PARAMETER  :: c3 = 2.32121276858E0
REAL, PARAMETER  :: d1 = 3.54388924762E0
REAL, PARAMETER  :: d2 = 1.63706781897E0

ifault = 0
q = p - half
IF (ABS(q) > split) GO TO 1
r = q*q
fn_val = q * (((a3*r + a2)*r + a1) * r + a0) /  &
    ((((b4*r + b3)*r + b2) * r + b1) * r + one)
RETURN

1 r = p
IF (q > zero)r = one - p
IF (r <= zero) GO TO 2
r = SQRT(-LOG(r))
fn_val = (((c3 * r + c2) * r + c1) * r + c0)/ ((d2*r + d1) * r + one)
IF (q < zero) fn_val = -fn_val
RETURN

2 ifault = 1
fn_val = zero
RETURN
END SUBROUTINE ppnd

FUNCTION random() RESULT(fn_val)

!  ALGORITHM AS 183  APPL. STATIST. (1982) VOL. 31, NO. 2

!  RETURNS A PSEUDO-RANDOM NUMBER RECTANGULARLY DISTRIBUTED BETWEEN 0 AND 1.

!  IX, IY, AND IZ SHOULD BE SET TO INTEGER VALUES BETWEEN
!  1 AND 30000 BEFORE FIRST ENTRY

!  INTEGER ARITHMETIC UP TO 30323 IS REQUIRED

REAL  :: fn_val

! INTEGER :: ix, iy, iz
! COMMON /rand/ ix,iy,iz

ix = 171 * MOD(ix, 177) - 2 * (ix / 177)
iy = 172 * MOD(iy, 176) - 35 * (iy / 176)
iz = 170 * MOD(iz, 178) - 63 * (iz / 178)

IF (ix < 0) ix = ix + 30269
IF (iy < 0) iy = iy + 30307
IF (iz < 0) iz = iz + 30323

fn_val = MOD(REAL(ix)/30269.0 + REAL(iy)/30307.0 + REAL(iz)/30323.0, 1.0)
RETURN
END FUNCTION random

FUNCTION alnorm(x, upper) RESULT(fn_val)

!  ALGORITHM AS 66  APPL. STATIST. (1973) VOL. 22, NO. 3

!  EVALUATES THE TAIL AREA OF THE STANDARDIZED NORMAL CURVE
!  FROM X TO INFINITY IF UPPER IS .TRUE. OR
!  FROM MINUS INFINITY TO X IF UPPER IS .FALSE.

REAL, INTENT(IN)     :: x
LOGICAL, INTENT(IN)  :: upper
REAL                 :: fn_val

REAL     :: z, y
LOGICAL  :: up

!  LTONE AND UTZERO MUST BE SET TO SUIT THE PARTICULAR COMPUTER
!  (SEE INTRODUCTORY TEXT)

REAL, PARAMETER  :: ltone = 7.0, utzero = 18.66
REAL, PARAMETER  :: zero = 0.0, half = 0.5, one = 1.0, con = 1.28

up = upper
z = x
IF (z >= zero) GO TO 10
up = .NOT. up
z = -z
10    IF (z <= ltone .OR. up .AND. z <= utzero) GO TO 20
fn_val = zero
GO TO 40
20 y = half *z * z
IF (z > con) GO TO 30

fn_val = half - z*(0.398942280444 - 0.399903438504 * y /  &
    (y + 5.75885480458 - 29.8213557808 / (y + 2.62433121679 + 48.6959930692 /  &
    (y + 5.92885724438))))
GO TO 40

30 fn_val = 0.398942280385 * EXP(-y) / (z - 3.8052E-08 + 1.00000615302 /  &
    (z + 3.98064794E-4 + 1.98615381364 / (z - 0.151679116635 + 5.29330324926 /  &
    (z + 4.8385912808 - 15.1508972451 /  &
    (z + 0.742380924027 + 30.789933034 / (z + 3.99019417011))))))

40 IF (.NOT. up) fn_val = one - fn_val
RETURN
END FUNCTION alnorm

END MODULE Mult_Normal

PROGRAM Driver285
!  DRIVING PROGRAM

! Code converted using TO_F90 by Alan Miller
! Date: 2003-12-15  Time: 12:20:56

USE Mult_Normal
IMPLICIT NONE

REAL     :: covar(1275), work(50,52), t(1275)
INTEGER  :: iseed, n, ifault, j, iter, init, nn, nullty
REAL     :: sdev, prob, rhigh
! COMMON /rand/ ix,iy,iz

REAL, PARAMETER  :: eta = 1.0E-5

INTERFACE
  FUNCTION f1(n,v) RESULT(fn_val)
    IMPLICIT NONE
    INTEGER, INTENT(IN)  :: n
    REAL, INTENT(IN)     :: v(:)
    REAL                 :: fn_val
  END FUNCTION f1

  FUNCTION f2(n,v) RESULT(fn_val)
    IMPLICIT NONE
    INTEGER, INTENT(IN)  :: n
    REAL, INTENT(IN)     :: v(:)
    REAL                 :: fn_val
  END FUNCTION f2

  FUNCTION f3(n,v) RESULT(fn_val)
    IMPLICIT NONE
    INTEGER, INTENT(IN)  :: n
    REAL, INTENT(IN)     :: v(:)
    REAL                 :: fn_val
  END FUNCTION f3

  FUNCTION f4(n,v) RESULT(fn_val)
    IMPLICIT NONE
    INTEGER, INTENT(IN)  :: n
    REAL, INTENT(IN)     :: v(:)
    REAL                 :: fn_val
  END FUNCTION f4

  FUNCTION f5(n,v) RESULT(fn_val)
    IMPLICIT NONE
    INTEGER, INTENT(IN)  :: n
    REAL, INTENT(IN)     :: v(:)
    REAL                 :: fn_val
  END FUNCTION f5

  FUNCTION f6(n,v) RESULT(fn_val)
    IMPLICIT NONE
    INTEGER, INTENT(IN)  :: n
    REAL, INTENT(IN)     :: v(:)
    REAL                 :: fn_val
  END FUNCTION f6
END INTERFACE

! READ IN COVARIANCE AND INITIALIZE RANDOM NORMAL GENERATOR.

OPEN(1, file='FORT.1', status='old')
READ (1, *) n, sdev, rhigh, init, ix, iy, iz
READ (1, *) (covar(j),j=1,n*(n+1)/2)

!  FIND SMALLEST NONZERO EIGENVALUE OF COVARIANCE MATRIX

nn = n*(n+1)/2
CALL chol(covar, n, nn, t, nullty, ifault)
CALL tdiag(n, eta, covar, work(1,1), work(1,2), work(1,3), ifault)
CALL lrvt(n, eta, work(1,1), work(1,2), work(1,3), ifault)
rhigh = rhigh/SQRT(work(nullty+1,1))

! Run through the supplied functions F1 ... F6

DO n = 2, 5
  CALL mulnor(covar, n, f1, sdev, rhigh, init, iseed, t, work, prob, iter, ifault)
  WRITE(*, *) 'Function F1, with n = ', n
  WRITE(*, *) 'ESTIMATED PROBABILITY IS', prob, 'WITH IFAULT = ', ifault
  WRITE(*, *) 'ITER = ',iter
END DO

n = 2
CALL mulnor(covar, n, f2, sdev, rhigh, init, iseed, t, work, prob, iter, ifault)
WRITE(*, *)
WRITE(*, *) 'Function F2'
WRITE(*, *) 'ESTIMATED PROBABILITY IS', prob, 'WITH IFAULT = ', ifault
WRITE(*, *) 'ITER = ',iter

n = 4
CALL mulnor(covar, n, f3, sdev, rhigh, init, iseed, t, work, prob, iter, ifault)
WRITE(*, *)
WRITE(*, *) 'Function F3'
WRITE(*, *) 'ESTIMATED PROBABILITY IS', prob, 'WITH IFAULT = ', ifault
WRITE(*, *) 'ITER = ',iter

n = 3
CALL mulnor(covar, n, f4, sdev, rhigh, init, iseed, t, work, prob, iter, ifault)
WRITE(*, *)
WRITE(*, *) 'Function F4'
WRITE(*, *) 'ESTIMATED PROBABILITY IS', prob, 'WITH IFAULT = ', ifault
WRITE(*, *) 'ITER = ',iter

n = 2
CALL mulnor(covar, n, f5, sdev, rhigh, init, iseed, t, work, prob, iter, ifault)
WRITE(*, *)
WRITE(*, *) 'Function F5'
WRITE(*, *) 'ESTIMATED PROBABILITY IS', prob, 'WITH IFAULT = ', ifault
WRITE(*, *) 'ITER = ',iter

n = 2
CALL mulnor(covar, n, f6, sdev, rhigh, init, iseed, t, work, prob, iter, ifault)
WRITE(*, *)
WRITE(*, *) 'Function F6'
WRITE(*, *) 'ESTIMATED PROBABILITY IS', prob, 'WITH IFAULT = ', ifault
WRITE(*, *) 'ITER = ',iter

STOP

CONTAINS

SUBROUTINE tdiag(n, tol, a, d, e, z, ifault)

IMPLICIT NONE
INTEGER, INTENT(IN)   :: n
REAL, INTENT(IN)      :: tol
REAL, INTENT(IN)      :: a(*)
REAL, INTENT(OUT)     :: d(n)
REAL, INTENT(OUT)     :: e(n)
REAL, INTENT(OUT)     :: z(n,n)
INTEGER, INTENT(OUT)  :: ifault

REAL     :: f, g, h, hh
INTEGER  :: i, j, k, l, i1, j1

REAL, PARAMETER  :: zero = 0.0, one = 1.0

ifault = 1
IF (n <= 1) RETURN
ifault = 0
k = 0
DO  i=1,n
  DO  j=1,i
    k = k+1
    z(i,j) = a(k)
  END DO
END DO
i=n
DO  i1=2,n
  l = i-2
  f = z(i,i-1)
  g=zero
  IF (l < 1) GO TO 25
  DO  k=1,l
    g=g + z(i,k)**2
  END DO
  25 h=g + f*f

  IF (g > tol) GO TO 30
  e(i)=f
  d(i)=zero
  GO TO 65

  30 l=l+1
  g=SQRT(h)
  IF (f >= zero) g=-g
  e(i) = g
  h = h-f*g
  z(i,i-1)=f-g
  f=zero
  DO  j=1,l
    z(j,i) = z(i,j)/h
    g = zero

    DO  k=1,j
      g = g + z(j,k) *z(i,k)
    END DO
    IF (j >= l)GO TO 47
    j1  = j+1
    DO  k=j1,l
      g=g + z(k,j)*z(i,k)
    END DO

    47 e(j)=g/h
    f = f+g*z(j,i)
  END DO

  hh = f/(h+h)

  DO  j=1,l
    f=z(i,j)
    g=e(j)-hh*f
    e(j)=g
    DO  k=1,j
      z(j,k) = z(j,k) - f*e(k) - g*z(i,k)
    END DO
  END DO
  d(i)=h
  65    i=i-1
END DO
d(1) = zero
e(1) = zero

DO  i=1,n
  l=i-1
  IF (d(i) == zero .OR. l == 0) GO TO 100
  DO  j=1,l
    g=zero
    DO  k=1,l
      g=g + z(i,k)*z(k,i)
    END DO
    DO  k=1,l
      z(k,j) = z(k,j) - g*z(k,i)
    END DO
  END DO
  100   d(i) = z(i,i)
  z(i,i) = one
  IF (l == 0) CYCLE
  DO  j=1,l
    z(i,j) = zero
    z(j,i) = zero
  END DO
END DO
RETURN
END SUBROUTINE tdiag

SUBROUTINE lrvt(n, precis, d, e, z, ifault)

IMPLICIT NONE
INTEGER, INTENT(IN)   :: n
REAL, INTENT(IN)      :: precis
REAL, INTENT(IN OUT)  :: d(n)
REAL, INTENT(OUT)     :: e(n)
REAL, INTENT(IN OUT)  :: z(n,n)
INTEGER, INTENT(OUT)  :: ifault

REAL     :: b, c, f, g, h, p, pr, r, s
INTEGER  :: i, j, k, l, n1, jj, m1, m, i1

INTEGER, PARAMETER  :: mits = 30
REAL, PARAMETER     :: zero = 0.0, one = 1.0, two = 2.0

ifault = 2
IF (n <= 1) RETURN
ifault = 1
n1 = n-1
DO  i=2,n
  e(i-1) = e(i)
END DO
e(n) = zero
b = zero
f = zero
DO  l=1,n
  jj=0
  h = precis * (ABS(d(l)) + ABS(e(l)))
  IF (b < h) b = h

  DO  m1=l,n
    m=m1
    IF (ABS(e(m)) <= b) EXIT
  END DO
  IF (m == l) GO TO 85
  40 IF (jj == mits) RETURN
  jj = jj+1

  p = (d(l+1) - d(l))/(two*e(l))
  r = SQRT(p*p + one)
  pr = p + r
  IF (p < zero) pr = p - r
  h = d(l) - e(l)/pr
  DO  i=l,n
    d(i) = d(i)-h
  END DO
  f=f+h

  p=d(m)
  c=one
  s=zero
  m1=m-1
  i=m
  DO  i1=l,m1
    j=i
    i=i-1
    g=c*e(i)
    h=c*p
    IF(ABS(p) >= ABS(e(i))) GO TO 60
    c = p/e(i)
    r = SQRT(c*c+one)
    e(j) = s*e(i)*r
    s = one/r
    c = c/r
    GO TO 70

    60 c=e(i)/p
    r=SQRT(c*c+one)
    e(j) = s*p*r
    s=c/r
    c=one/r
    70 p=c*d(i)-s*g
    d(j)=h + s*(c*g + s*d(i))

    DO  k=1,n
      h=z(k,j)
      z(k,j) = s*z(k,i) + c*h
      z(k,i) = c*z(k,i) - s*h
    END DO
  END DO
  e(l)=s*p
  d(l)=c*p
  IF (ABS(e(l)) > b) GO TO 40
  85 d(l) = d(l) + f
END DO

DO  i=1,n1
  k=i
  p=d(i)
  i1=i+1
  DO  j=i1,n
    IF (d(j) >= p) CYCLE
    k=j
    p=d(j)
  END DO
  IF (k == i) CYCLE
  d(k) = d(i)
  d(i) = p
  DO  j=1,n
    p=z(j,i)
    z(j,i)=z(j,k)
    z(j,k)=p
  END DO
END DO
ifault=0
RETURN
END SUBROUTINE lrvt

END PROGRAM Driver285

FUNCTION f1(n,v) RESULT(fn_val)

! Code converted using TO_F90 by Alan Miller
! Date: 2003-12-15  Time: 13:39:21

IMPLICIT NONE
INTEGER, INTENT(IN)  :: n
REAL, INTENT(IN)     :: v(:)
REAL                 :: fn_val

REAL, PARAMETER  :: cubsz = 3.0
INTEGER  :: i

!  BOUNDARY OF REGION IS AN N-DIMENSIONAL CUBE.
!  CUBSZ IS THE DISTANCE FROM THE ORIGIN TO THE SIDE OF THE CUBE

fn_val = 0.0
DO  i = 1,n
  fn_val = MAX(fn_val, ABS(v(i)))
END DO
fn_val = fn_val - cubsz
RETURN
END FUNCTION f1

FUNCTION f2(n,v) RESULT(fn_val)

IMPLICIT NONE
INTEGER, INTENT(IN)  :: n
REAL, INTENT(IN)     :: v(:)
REAL                 :: fn_val

REAL     :: b(10)
INTEGER  :: i, j, k

!  THE BOUNDARY IS AN ELLIPSOID OF THE FORM X'AX + BX + C = 0
!  THE UPPER TRIANGLE OF A IS STORED COLUMN-WISE IN PACKED FORM.
!  IN THIS EXAMPLE, A = INVERSE (1  .3), B = 0, C = -1.
!                               (.3  1)

REAL, PARAMETER  :: a(3) = (/ 1.0989011, -.32967033, 1.0989011 /)
REAL, PARAMETER  :: c = -1.0

b(1:2) = 0.0
fn_val = c
k = 0
DO  i = 1,n
  k = k + 1
  fn_val = fn_val + (v(i)**2)*a(k)
  DO  j = i+1,n
    k = k + 1
    fn_val = fn_val + 2.0*v(i)*v(j)*a(k)
  END DO
END DO
fn_val = fn_val + DOT_PRODUCT(b(1:n), v(1:n))
RETURN
END FUNCTION f2

FUNCTION f3(n,v) RESULT(fn_val)

IMPLICIT NONE
INTEGER, INTENT(IN)  :: n
REAL, INTENT(IN)     :: v(:)
REAL                 :: fn_val

INTEGER  :: i
REAL     :: temp

!  RECTANGLE IS GIVEN BY A < V < B FOR EACH COORDINATE.
!  THIS SUBROUTINE MAY ALSO BE USED TO CALCULATE THE CDF BY
!  MAKING THE APPROPRIATE SIDES OF THE RECTANGLE SUFFICIENTLY LARGE.
!  THIS EXAMPLE IS THE FOUR-DIMENSIONAL RECTANGLE DEFINED
!  BY  -INFINITY (ALMOST) < V(I) < 2 FOR EACH I.

REAL, PARAMETER  :: a(4) = (/ -20.0, -20.0, -20.0, -20.0 /)
REAL, PARAMETER  :: b(4) = (/ 2.0, 2.0, 2.0, 2.0 /)

fn_val = -1.0
DO  i=1,n
  IF (v(i) > 0.0) THEN
    temp = v(i) - b(i)
  ELSE
    temp = a(i) - v(i)
  END IF
  fn_val  = MAX(fn_val, temp)
END DO
RETURN
END FUNCTION f3

FUNCTION f4(n,v) RESULT(fn_val)

IMPLICIT NONE
INTEGER, INTENT(IN)  :: n
REAL, INTENT(IN)     :: v(:)
REAL                 :: fn_val

REAL, PARAMETER  :: radsq = 4.0
INTEGER  :: i

!  BOUNDARY IS SPHERE OF RADIUS SQRT(RADSQ).

fn_val = 0.0
DO  i = 1,n
  fn_val = fn_val + v(i)*v(i)
END DO
fn_val = fn_val - radsq
RETURN
END FUNCTION f4

FUNCTION f5(n,v) RESULT(fn_val)

IMPLICIT NONE
INTEGER, INTENT(IN)  :: n
REAL, INTENT(IN)     :: v(:)
REAL                 :: fn_val

INTEGER  :: i, j
REAL     :: temp

!  A CONVEX POLYTOPE WITH P FACES IS DEFINED BY THE INEQUALITIES
!  A(1,I)*V(1) + A(2,I)*V(2) +...+ A(N,I)*V(N) <= 1
!  FOR I=1,...,P.

!  THE FIGURE IN THIS DEMONSTRATION PROGRAM IS THE
!  REGULAR PENTAGON WITH DISTANCE FROM CENTER TO POINT = 1.

INTEGER, PARAMETER  :: p = 5
REAL, PARAMETER     :: a(2,5) = RESHAPE( (/ 0.726542528, -1.0,  &
    1.175570504, 0.381966011, 0.0, 1.236067978, -0.726542528, -1.0,  &
    -1.175570504, 0.381966011 /), (/ 2, 5 /) )

fn_val = -1.0
DO  j=1,n
  fn_val = fn_val + a(j,1)*v(j)
END DO
DO  i=2,p
  temp = -1.0
  DO  j=1,n
    temp = temp + a(j,i)*v(j)
  END DO
  fn_val = MAX(fn_val, temp)
END DO
RETURN
END FUNCTION f5

FUNCTION f6(n,v) RESULT(fn_val)

IMPLICIT NONE
INTEGER, INTENT(IN)  :: n
REAL, INTENT(IN)     :: v(:)
REAL                 :: fn_val

INTEGER  :: i, j, INDEX
REAL     :: x(2), tangnt

!  THE FIGURE IN THIS DEMONSTRATION PROGRAM IS THE
!  REGULAR PENTAGRAM WITH DISTANCE FROM CENTER TO POINT = 2.618.

INTEGER, PARAMETER  :: p = 5
REAL, PARAMETER     :: tang(5) = (/  &
    -1.376381921, -0.3249196962329, 0.3249196962329, 1.376381921, 0.0 /)
REAL, PARAMETER     :: a(2,5) = RESHAPE( (/ -0.726542528, -1.0,  &
    1.175570504, 0.381966011, 0.726542528, -1.0, 0.0, 1.236067978,  &
    1.175570504, 0.381966011 /), (/ 2, 5 /) )

x(1) = ABS(v(1))
x(2) = v(2)
INDEX = p
IF (x(1) == 0.0) THEN
  INDEX = 3
ELSE
  tangnt = x(2)/x(1)
  DO  i=1,p
    IF (tangnt <= tang(i)) THEN
      INDEX = i
      EXIT
    END IF
  END DO
END IF

fn_val = -1.0
DO  j=1,2
  fn_val = fn_val + a(j,INDEX)*x(j)
END DO

RETURN
END FUNCTION f6


! -*- coding: utf-8 -*-
program k_means
  use mod_force_raise
  use mod_sub
  implicit none

  real(8),allocatable :: xn(:, :)
  real(8),allocatable :: mu(:, :)
  integer :: i
  integer :: k
  integer :: n
  integer,allocatable :: numk(:)
  integer,allocatable :: gk(:)
  integer,allocatable :: tmp_gk(:)
  real(8),allocatable :: tmp_mu(:, :)
  integer :: seedsize
  integer,allocatable :: seed(:)

  ! this code is k==3 only

  n = 10
  k = 3
  n = n*k
  allocate(xn(2, n))
  allocate(mu(2, k))
  allocate(tmp_mu(2, k))
  allocate(gk(n))
  allocate(tmp_gk(n))
  allocate(numk(k))

  call random_seed(size=seedsize)
  allocate(seed(seedsize))
  call random_seed(get=seed)

  write(*,*) "seedsize", seedsize
  write(*,*) "seed", seed

  call random_number(xn)

  xn(1, n/3+1:2*n/3) = xn(1, n/3+1:2*n/3) + 1d0 ! k==3 only
  xn(1, 2*n/3+1:n) = xn(1, 2*n/3+1:n) + 2d0 ! k==3 only
  do i = 1, n
     write(*,*) 'i, xn(i)', i, xn(:, i)
  end do

  mu(:, 1:k) = xn(:, 1:k)

  tmp_gk = 0
  tmp_mu = 0d0
  do i = 1, 100
     write(*,*) 'loop', i, 'is started'
     call grouping(xn, mu, gk)
     call mean_group(xn, mu, gk, numk)
     if(sum(gk) .eq. sum(tmp_gk) .and. sum(mu) .eq. sum(tmp_mu)) exit
     tmp_gk = gk
     tmp_mu = mu
  end do

  do i = 1, n
     write(*,*) 'i, gk(i), xn(i)', i, gk(i), xn(:, i)
  end do

  do i = 1, k
     write(*,*) 'i, numk(i), mu(i)', i, numk(i), mu(:, i)
  end do

end program k_means


      SUBROUTINE obtain_theta(alpha, iotac, thetacn, nsurf, npt,
     1   zetang, thetang, lambdath)
      USE stel_kinds
      USE normalize_data, ONLY: lasym_v                                     ! 110909 RS: logical for Asymmetric input (if TRUE)
      USE ballooning_data
      USE general_dimensions
      USE fmesh_quantities
      IMPLICIT NONE
!-----------------------------------------------
!   D u m m y   A r g u m e n t s
!-----------------------------------------------
      INTEGER, INTENT(IN):: nsurf, npt
      REAL(rprec), INTENT(IN) :: iotac, alpha, thetacn
      REAL(rprec), INTENT(IN), DIMENSION(npt):: zetang
      REAL(rprec), INTENT(OUT), DIMENSION(npt):: thetang,
     1   lambdath
!-----------------------------------------------
!   L o c a l   V a r i a b l e s
!-----------------------------------------------
      REAL(rprec), PARAMETER :: guard_band = 0.95_dp
      INTEGER :: j, lj, l, kj
      REAL(rprec):: lambda0, dlambda0, ccosi, ssine, arg,
     1   aux1, theta0, dtheta, fun0, dfun0
!-----------------------------------------------

      theta_loop: DO l = 1, npt
         aux1 = iotac*zetang(l) + alpha
         IF(l == 1)  THEN
           theta0 = thetacn
         ELSE
          theta0 = thetang(l-1)
         ENDIF

!
!        Use Newton-Raphson to find angle theta that is the zero of
!        F(theta) = theta + lambda(theta) - (alpha + iota*zeta)
!
         newton_raphson: DO kj = 1, jnewton_max
           lambda0 = 0
           dlambda0 = 0

           fourier: DO j = 1, mnmax_v

             arg = xm_v(j)*theta0-xn_v(j)*zetang(l)
             ssine = SIN(arg)
             ccosi = COS(arg)
             lj = mnmax_v*(nsurf-1)+j
             lambda0 = lambda0 + lmnsf(lj)*ssine                            ! Fourier invert lambda and d(lambda)/dtheta
             IF (lasym_v) lambda0 = lambda0 + lmncf(lj)*ccosi               ! 110909 RS: Asymmetric input
             dlambda0 = dlambda0 + xm_v(j)*lmnsf(lj)*ccosi
             IF (lasym_v) dlambda0 = dlambda0 - xm_v(j)*lmncf(lj)*ssine     ! 110909 RS: Asymmetric input

           ENDDO fourier

           fun0 = theta0 - aux1 + lambda0
           dfun0 = 1 + dlambda0

           IF (kj .ge. jnewton_max/2) dfun0 = MAX(dfun0, guard_band)        ! Added by SPH (10/00)

           dtheta = fun0/dfun0
           theta0 = theta0 - dtheta

           IF (ABS(dtheta) < newton_tol) THEN
             thetang(l) = theta0
             lambdath(l) = dlambda0
             EXIT
           ELSE IF (kj == jnewton_max) THEN
             !STOP 'COBRA: NEWTON fails!'
             lfail_balloon = .true.
             RETURN
           ENDIF

         ENDDO newton_raphson

      ENDDO theta_loop

      END SUBROUTINE obtain_theta


! mpiexec -np 4 bin/Debug/WGFM_test2.exe
program mainWGF
    use meshread_mod
    use linalg_mod
    use WGFM_matrices
    use mpi
    implicit none

    real(8), parameter :: pi = 4d0 * atan(1d0)
    complex(8), parameter :: IU = (0d0, 1d0)

    ! Variables
    type(Mesh) :: msh

    complex(8), allocatable :: ZMat(:, :)       ! WGFM matrix
    complex(8), allocatable :: eigen_array(:)   ! list of eigenvalues
    integer :: n_eigen    ! number of eigenvalues

    ! MPI variables
    integer :: ierr, N_procs, id

    ! Parameters
    real(8), parameter :: ep0 = 1d0 / (35950207149.4727056d0 * PI)  ! vacuum permittivity [F/m]
    real(8), parameter :: mu0 = PI * 4d-7                           ! vacuum permeability [H/m]
    real(8), parameter :: k0 = 2*PI          ! free-space wavenumber [1/m]

    real(8), parameter :: ep1_r = 4d0         ! upper half-space relative permittivity
    real(8), parameter :: ep2_r = 1d0         ! lower half-space relative permittivity
    real(8), parameter :: ep1 = ep0*ep1_r     ! upper half-space permittivity [F/m]
    real(8), parameter :: mu1 = mu0           ! upper half-space permeability [H/m]
    real(8), parameter :: ep2 = ep0*ep2_r     ! lower half-space permittivity [F/m]
    real(8), parameter :: mu2 = mu0           ! lower half-space permeability [H/m]

    real(8), parameter :: w = k0 / sqrt(ep0 * mu0)   ! angular frequency [rad/s]
    real(8), parameter :: k1 = w * sqrt(ep1 * mu1)  ! upper half-space wavenumber [1/m]
    real(8), parameter :: k2 = w * sqrt(ep2 * mu2)  ! lower half-space wavenumber [1/m]

    character(len=150), parameter ::  &
        file_msh = '/home/rodrigo/Dropbox/Rodrigo-Carlos/Meshes/dipoleMeshes/planeA6h0312.msh'
    character(len=150), parameter :: file_eig = 'results/eig312_e41.txt'
    character(len=150), parameter :: file_eig_pre = 'results/eig_pre312_e41.txt'
    real(8), parameter :: win_radius = 6d0      ! Window radius
    real(8), parameter :: win_cparam = 0.7d0    ! Window 'c' parameter

    !************************************************************************************
    ! MPI init
    call mpi_init(ierr)
    call mpi_comm_size(MPI_COMM_WORLD, N_procs, ierr)
    call mpi_comm_rank(MPI_COMM_WORLD, id, ierr)
    print *, "Total processes:", N_procs, "Process id:", id

    ! Set window type and size
    call set_circ_window(win_radius, win_cparam)

    ! Load mesh
    call load_gmsh(file_msh, msh)

    ! Compute WGFM matrix
    if (id == 0) print *, "WGFM matrix, ", 'nEdges: ', msh%nbEdg
    call genWGFMMat(msh, w, k1, k2, ep1, ep2, mu1, mu2, ZMat)
    if (id == 0) print *, "done"

    ! MPI is no longer needed
    call MPI_Finalize(ierr)

    if (id == 0) then
        ! Example
        !allocate(ZMat(3, 3))
        !ZMat = reshape([1d0, 3d0, 2d0, 2d0, 2d0, 1d0, 3d0, 1d0, 3d0], [3, 3])

        n_eigen = size(ZMat, 1)
        allocate(eigen_array(n_eigen))

        ! Compute eigenvalues
        print *, "eigenvalues.."
        call eig(eigen_array, ZMat, n_eigen)
        print *, "done"

        ! Save data
        call save_eigenvalues(eigen_array, file_eig)

        ! Compute eigenvalues for the preconditioned system
        print *, "(preconditioned) eigenvalues.."
        call apply_diag_precond(ZMat)
        call eig(eigen_array, ZMat, n_eigen)
        print *, "done"

        ! Save data
        call save_eigenvalues(eigen_array, file_eig_pre)
    end if

contains
    subroutine save_eigenvalues(eigen_array, filename)
        complex(8), intent(in) :: eigen_array(:)
        character(len=*), intent(in) :: filename
        integer, parameter :: file_id = 1
        integer :: n

        ! Print to file. Format:
        ! real(eig(1)), imag(eig(1))
        ! real(eig(2)), imag(eig(2))
        ! etc
        open(unit=file_id, file=filename, status="REPLACE", action="WRITE")
        do n = 1, size(eigen_array)
            write(file_id, *) dreal(eigen_array(n)), dimag(eigen_array(n))
        end do
        close(file_id)
    end subroutine save_eigenvalues

    subroutine apply_diag_precond(matrix)
        complex(8), intent(inout) :: matrix(:, :)
        integer :: i
        do i = 1, size(matrix, 1)
            matrix(i,:) = matrix(i,:) / matrix(i,i)
        end do
    end subroutine apply_diag_precond
end program


      PROGRAM CSEX07
C
C  Do a 2D approximation using a list of output coordinates.
C
C
C  The dimensionality of the problem.
C
      PARAMETER (NDIM=2)
C
C  The number of input data points.
C
      PARAMETER (NDATA=500)
C
C  The number of output data points in the X coordinate direction.
C
      PARAMETER (NX=29)
C
C  The number of output data points in the Y coordinate direction.
C
      PARAMETER (NY=25)
C
C  The number of output data points.
C
      PARAMETER (NO=NX*NY)
C
C  Specifty the number of knots in the X direction.
C
      PARAMETER (N1=10)
C
C  Specifty the number of knots in the Y direction.
C
      PARAMETER (N2=10)
C
C  The size of the workspace.
C
      PARAMETER (NCF=N1*N2, NWRK=NCF*(NCF+3))
C
C Define the error file, the Fortran unit number, the workstation type,
C and the workstation ID to be used in calls to GKS routines.
C
C     PARAMETER (IERRF=6, LUNIT=2, IWTYPE=1,  IWKID=1)   ! NCGM
C     PARAMETER (IERRF=6, LUNIT=2, IWTYPE=8,  IWKID=1)   ! X Windows
C     PARAMETER (IERRF=6, LUNIT=2, IWTYPE=11, IWKID=1)   ! PDF
C     PARAMETER (IERRF=6, LUNIT=2, IWTYPE=20, IWKID=1)   ! PostScript
C
      PARAMETER (IERRF=6, LUNIT=2, IWTYPE=1,  IWKID=1)
C
C  Dimension the arrays.
C
      DIMENSION XDATA(NDIM,NDATA),YDATA(NDATA),NODES(NDIM),WORK(NWRK)
      DATA XMIN,YMIN,XMAX,YMAX / -1.4, -1.2, 1.4, 1.2/
      REAL XO(NO),  YO(NO), OUTPUT(NO)
      REAL XP(NX),  YP(NY), OPLOT(NX,NY)
C
C  Create the data array for the surface.
C
      DO 10 I=1,NDATA
        XDATA(1,I) = XMIN+(XMAX-XMIN)*DSRND1()
        XDATA(2,I) = YMIN+(YMAX-YMIN)*DSRND1()
        YDATA(I)   = XDATA(1,I) + XDATA(2,I)
        T1 = 1.0/((ABS(XDATA(1,I)-0.1))**2.75 +
     +                     ABS(XDATA(2,I))**2.75+0.09)
        T2 = 1.0/((ABS(XDATA(1,I)+0.1))**2.75 +
     +                     ABS(XDATA(2,I))**2.75+0.09)
        YDATA(I) = 0.3*(YDATA(I)+T1-T2)
   10 CONTINUE
C
C  Create the output arrays.
C
      INDX = 0
      DO 103 J=1,NY
        DO 104 I=1,NX
          INDX = INDX+1
          XO(INDX) = XMIN+(REAL(I-1)/REAL(NX-1))*(XMAX-XMIN)
          YO(INDX) = YMIN+(REAL(J-1)/REAL(NY-1))*(YMAX-YMIN)
  104   CONTINUE
  103 CONTINUE
C
C  Specify the numbers of nodes in each coordinate.
C
      NODES(1) = N1
      NODES(2) = N2
C
      CALL CSA2LS (NDATA,XDATA,YDATA,NODES,NO,XO,YO,
     +             OUTPUT,NWRK,WORK,IER)
C
C  Plot the 2D surface approximation.
C
C Open GKS and define the foreground and background color.
C
      CALL GOPKS (IERRF, ISZDM)
      CALL GOPWK (IWKID, LUNIT, IWTYPE)
      CALL GACWK (IWKID)
C
C  Convert the linear output array to a 2D array.
C
      DO 21 I=1,NX
        DO 22 J=1,NY
            OPLOT(I,J) = OUTPUT((J-1)*NX + I)
   22   CONTINUE
   21 CONTINUE
C
C  Create the output grid for plotting.
C
      DO 105 I=1,NX
        XP(I) = XMIN+(REAL(I-1)/REAL(NX-1))*(XMAX-XMIN)
  105 CONTINUE
      DO 106 J=1,NY
        YP(J) = YMIN+(REAL(J-1)/REAL(NY-1))*(YMAX-YMIN)
  106 CONTINUE
C
C  Plot the surface.
C
      CALL TDEZ2D(NX, NY, XP, YP, OPLOT, 2.5, -154., 80., 6)
      CALL FRAME()
C
C Close GKS.
C
      CALL GDAWK (IWKID)
      CALL GCLWK (IWKID)
      CALL GCLKS
C
      STOP
      END
      REAL FUNCTION DSRND1()
C
C  Portable random number generator.
C
      PARAMETER (MPLIER=16807,MODLUS=2147483647,MOBYMP=127773,
     +           MOMDMP=2836)
C
      INTEGER HVLUE, LVLUE, TESTV, NEXTN
      SAVE    NEXTN
      DATA JSEED,IFRST/123456789,0/
C
      IF (IFRST .EQ. 0) THEN
        NEXTN = JSEED
        IFRST = 1
      ENDIF
C
      HVLUE = NEXTN / MOBYMP
      LVLUE = MOD(NEXTN, MOBYMP)
      TESTV = MPLIER*LVLUE - MOMDMP*HVLUE
      IF (TESTV .GT. 0) THEN
        NEXTN = TESTV
      ELSE
        NEXTN = TESTV + MODLUS
      ENDIF
      DSRND1 = REAL(NEXTN)/REAL(MODLUS)
C
      RETURN
      END


!!## FUNCTION: RGBA_Exp1
MODULE FUN_RGBA_Exp1
!!### PURPOSE
!! Get a Experimental color scheme in RGBA format with
!! components <R,G,B,A> all in $[0,1]$.

!!### USAGE
!
!      RGBA = RGBA_Exp1( X  [,ro] [,beta] [,gamma] [,alpha] )
!
!! where <RGBA(1:4)> is an array containing each of the components
!! in that order, <X> is the input intensity to generate the color
!! for and <ro(1:5)>, <beta(1:5)>, <gamma(1:5)>, and <alpha(1:5)>
!! are optional 5-part factors used to generate the componets,
!! if present.

!!### METHOD
!! Each component <R,G,B,A> is calculated based on the intensity provided,
!! <X>, and 5-part factors <ro,gamma,beta,alpha>, respectively.
!!
!! The formula for component $R$ is based on intensity $X$
!! and 5-part factors, $\{ \ro_i | i=1,..,5 \}$, as follows:
!!
!!   $$ R = {\ro_1}^{\ro_2 + \ro_3*\abs{ X - \ro_4 }^{\ro_5} } $$
!!
!! The formulas for the other components $G,B,A$ are calculated the
!! same way, using $\gamma,\beta,\alpha$ instead.

!!### COMMENTS
!! To fix a component $Y$ at a certain value $Z$ provide
!! $Z={y_1}^{y_2}$ and $y_3=0$.

!!### EXTERNAL KINDS
USE KND_IntrinsicTypes,ONLY: KIND_Rsp,KIND_Rdp !!((01-A-KND_IntrinsicTypes.f90))

!!### DEFAULT IMPLICIT
IMPLICIT NONE

!!### DEFAULT ACCESS
PRIVATE

!!### PROCEDURE OVERLOADING
INTERFACE RGBA_Exp1
 MODULE PROCEDURE RGBA_Exp1_Rsp
 MODULE PROCEDURE RGBA_Exp1_Rdp
END INTERFACE

!!### PUBLIC ACCESS LIST
PUBLIC :: RGBA_Exp1

!!## MODULE PROCEDURES
CONTAINS

!!### FUNCTION: RGBA_Exp1_Rsp
FUNCTION RGBA_Exp1_Rsp( X , ro , gamma , beta , alpha ) RESULT(RGBA)
!!#### LOCAL KINDS
USE KND_IntrinsicTypes,ONLY: KIND_R=>KIND_Rsp  !!((01-A-KND_IntrinsicTypes.f90))
INCLUDE "04-B-FUN_RGBA_Exp1.f90.hdr"
!!--begin--
INCLUDE "04-B-FUN_RGBA_Exp1.f90.bdy"
!!--end--
END FUNCTION

!!### FUNCTION: RGBA_Exp1_Rdp
FUNCTION RGBA_Exp1_Rdp( X , ro , gamma , beta , alpha ) RESULT(RGBA)
USE KND_IntrinsicTypes,ONLY: KIND_R=>KIND_Rdp  !!((01-A-KND_IntrinsicTypes.f90))
INCLUDE "04-B-FUN_RGBA_Exp1.f90.hdr"
!!--begin--
INCLUDE "04-B-FUN_RGBA_Exp1.f90.bdy"
!!--end--
END FUNCTION

END MODULE


      FUNCTION BESSYP (N,X)
      IMPLICIT NONE
      REAL *8 X,BESSYP,BESSY
      INTEGER N
      IF (N.EQ.0) THEN
        BESSYP=-BESSY(1,X)
      ELSE IF(X.EQ.0.D0) THEN
        X=1.D-30
      ELSE
        BESSYP=BESSY(N-1,X)-(DFLOAT(N)/X)*BESSY(N,X)
      ENDIF
      RETURN
      END


      PROGRAM LA_CHPEVX_EXAMPLE

!  -- LAPACK95 EXAMPLE DRIVER ROUTINE (VERSION 1.0) --
!     UNI-C, DENMARK
!     DECEMBER, 1999
!
!  .. "Use Statements" ..
      USE LA_PRECISION, ONLY: WP => SP
      USE F95_LAPACK, ONLY: LA_HPEVX
!  .. "Implicit Statement" ..
      IMPLICIT NONE
!  .. "Local Scalars" ..
      INTEGER :: I, J, N
      REAL(WP), ALLOCATABLE :: W(:)
!  .. "Local Arrays" ..
      COMPLEX(WP), ALLOCATABLE :: A(:), AA(:), Z(:,:)
!  .. "Intrinsic Functions" ..
      INTRINSIC AIMAG, INT
!  .. "Executable Statements" ..
      WRITE (*,*) 'LA_HPEVX Example Program Results'
      N = 5
      ALLOCATE( A(N*(N+1)/2), AA(N*(N+1)/2), W(N), Z(N,N) )

      OPEN(UNIT=21,FILE='hpev.ma',STATUS='UNKNOWN')
      DO J=1,N*(N+1)/2
         READ(21,*) A(J)
      ENDDO
      CLOSE(21)

      WRITE(*,*)'Matrix A:'
      DO I=1,N*(N+1)/2
         WRITE(*,"((I3,1X,'+',1X,I3,'i',1X))") INT(A(I)), INT(AIMAG(A(I)))
      ENDDO

      WRITE(*,*) "CALL LA_HPEVX( A, W, IL=2, IU=5, ABSTOL=1.0E-5_WP ) "
      CALL LA_HPEVX( A, W, IL=2, IU=5, ABSTOL=1.0E-5_WP )

      WRITE(*,*) 'W on exit : '
      DO I=1,N
      WRITE(*,"(5(F9.5))") W(I)
      ENDDO

      END PROGRAM LA_CHPEVX_EXAMPLE


program main

  use pmodule
  use lancelot_simple_double
  implicit none

  !
  ! Variable declaration
  !

  integer :: exitcode, print_level, i, j, iterations, its, k, &
       nprobs, iargc, numarg, probnumber
  integer*8 :: mypos
  integer, parameter :: input = 47
  real (kind = wp) :: x(20), fx, lower(20), upper(20), w(4), maxerror, &
       maxerror_array(10000), PP(4,4,1428), PE(4,4), DXPE(4,4), normdif, t1, t2
  real (kind = wp), parameter :: eps = 1.e-3_wp
  double precision :: dlange
  character(len=9) :: teste, filename
  character(len=19) :: outfilename
  character(len=5) :: option
  character(len=80) :: arg
  ! due to a bug in GALAHAD, the objective function subroutine MUST be
  ! called probfun.
  external :: probfun, grad, hess, dlange

  ! ============================================================
  !

  ! The user must call findingaleph.f90 with the following command:
  !
  ! ./findingaleph <argument> <opt-arg>
  !
  ! If <argument> is 'pairs', we will read the file with the bacterial data, pairs.txt or new_bact.txt
  ! If <argument> is 'pmatf', we will read the files with random data. There are 10 files,
  ! called matrizes01.txt--matrizes10.txt
  ! <opt-arg> is the number of the problem we wish to read. There are 100 million problems.
  ! The actual reading of these problems is done in pmodule.f90

  numarg = iargc()
  if ( numarg .lt. 1 ) then
     print *, "Error! The first argument must be the pairs or pmatf option."
     stop
  else
     call getarg(1,arg)
     read(arg,'(A5)') option
     if ( option .eq. 'pairs' ) then
        !
        ! Reading file with matrices from bacterial data.
        !
        probnumber = 1
        !nprobs = 1428 ! for pairs.txt
        !nprobs = 9512 ! for newbact.txt
        nprobs = 2275 ! for p2275_aa.txt, p2275_aa1.txt, p2275_aa2.txt
     elseif ( option .eq. 'pmatf' ) then
        !
        ! Reading file with matrices from random data.
        !
        if ( numarg .eq. 2 ) then
           call getarg(2,arg)
           read(arg,'(i9)') probnumber
           if (( probnumber .lt. 1) .or. ( probnumber .gt. 100000000 )) then
              print *, "Error! Problem number must be between 1 and 100000000."
           else
              nprobs = probnumber
           endif
        else
           probnumber = 1
           nprobs = 1
        endif
        !filename = 'pmatf.txt'
        !filename = "matrizes.txt" ! this is not used. pmodule is responsible
                                   ! for reading these matrices.
     else
        print *, "Unknown option. Must be \'pairs\' or \'pmatf\'."
        stop
     endif
  endif

  call cpu_time(t1)

  ! x is a 20-element vector with E stored in x as
  !
  ! x(4+j+(i-1)*4) = E(i,j)
  !
  ! such that E is stored by rows:
  !
  ! x(5)  x(6)  x(7)  x(8)
  ! x(9)  x(10) x(11) x(12)
  ! x(13) x(14) x(15) x(16)
  ! x(17) x(18) x(19) x(20)

  maxerror_array = zero

  do k = probnumber,nprobs
     ! readpfile(k,option) reads the P matrix for problem k from the master file
     ! located at findingaleph/data/matrizesnn.txt, where nn is 01 through 10
     ! (depending on the number of the problem).
     call readpfile(k,option)
     ! Bound constraints
     lower = zero
     upper = 1.0e20_wp
     do j = 1,4
        do i = 1,4
           lower(4+j+(i-1)*4) = -P(i,j)
           upper(4+j+(i-1)*4) = 1-P(i,j)
        enddo
     enddo
     lower(4) = one
     upper(4) = one

     ! Initial point
     x = one

     ! Call solver
     call lancelot_simple(20, x, fx, exitcode, my_fun = probfun, my_grad = grad, &
          my_hess = hess, bl = lower, bu = upper, neq = 10, nin = 0, &
          iters = iterations, maxit = 1000, gradtol = eps, feastol = eps, &
          print_level = 0)

     ! PE is P+E
     do i = 1,4
        do j = 1,4
           PE(i,j) = P(i,j) + x(4+j+(i-1)*4)
        enddo
     enddo
     !DXPE is diag(x)*(P+E)
     DXPE(1,1:4) = PE(1,1:4)*x(1)
     DXPE(2,1:4) = PE(2,1:4)*x(2)
     DXPE(3,1:4) = PE(3,1:4)*x(3)
     DXPE(4,1:4) = PE(4,1:4) ! x(4) = one

     ! Persymmetric error
     maxerror = max(abs(DXPE(1,3)-DXPE(2,4)), abs(DXPE(1,2)-DXPE(3,4)), &
          abs(DXPE(1,1)-DXPE(4,4)), abs(DXPE(2,2)-DXPE(3,3)), &
          abs(DXPE(2,1)-DXPE(4,3)), abs(DXPE(3,1)-DXPE(4,2)))
     if ( option .eq. 'pairs' ) then
        maxerror_array(k) = maxerror
     endif

     ! writepfile(k, x, option) writes the solution x(1:20) for problem k in the
     ! file pefilenn.txt, where nn is 01 through 10, depending on the problem
     ! number (agrees with matrizesnn.txt) if options is 'pmatf'. If options is
     ! 'pairs', the output file is called 'pefilepairs.txt'.
     call writepefile(k, x, option)

     !
     ! Print outcome for each problem
     !

     write(*,*) ""
     write(*,'(A)') "===================================================="
     write(*,'(A,i9)') "             Problem ",k
     write(*,'(A)') ""
     normdif = DLANGE('f',4,4,P(1:4,1:4)-PE,4,w)
     write(*,'(A,4g15.7)') "x = ", (x(j), j = 1,4)
     write(*,'(A,g12.7)') "norm(P-(P+E),fro) = ", normdif
     write(*,'(A,g12.7)') "maxerror = ", maxerror
     write(*,'(A,i3)') "LANCELOT_SIMPLE exit code: ", exitcode
     write(*,'(A)') "===================================================="

  enddo
  if ( option .eq. 'pairs' ) then
     print *, "Maximum error for all problems: ", maxval(maxerror_array)
     print *, "Mean error for all problems: ", sum(maxerror_array)/9512!1428.0_wp
  endif

  call cpu_time(t2)

  print *, "Elapsed time: ", t2-t1

  !
  !  Exit
  !

  ! if ( exitcode .ne. 0 ) then
  !    print *, "Exitcode = ", exitcode
  !    stop -1
  ! else
  !    stop
  ! endif

  stop

  ! ============================================================
  ! ============================================================

end program main

! ============================================================

subroutine probfun(x, fx, i)

  use pmodule
  implicit none

  real (kind = wp), intent(in) :: x(:)
  real (kind = wp), intent(out) :: fx
  integer, optional :: i
  integer :: j,k

  ! x(1:4) is x_i
  ! x(5:20) is E(i,j), such that x(4+j+(i-1)*n) = E(i,j)

  fx = zero
  if ( .not. present(i) ) then
     ! Objective function
     fx = sum(x(5:20)**2)
  else
     select case (i)
        ! Equality constraints
        case(1)
           fx = x(1)*(P(1,1)+x(5)) - x(4)*(P(4,4)+x(20))
        case(2)
           fx = x(1)*(P(1,2)+x(6)) - x(3)*(P(3,4)+x(16))
        case(3)
           fx = x(1)*(P(1,3)+x(7)) - x(2)*(P(2,4)+x(12))
        case(4)
           fx = x(2)*(P(2,1)+x(9)) - x(4)*(P(4,3)+x(19))
        case(5)
           fx = x(2)*(P(2,2)+x(10)) - x(3)*(P(3,3)+x(15))
        case(6)
           fx = x(3)*(P(3,1)+x(13)) - x(4)*(P(4,2)+x(18))
        case(7)
           fx = sum(x(5:8))
        case(8)
           fx = sum(x(9:12))
        case(9)
           fx = sum(x(13:16))
        case(10)
           fx = sum(x(17:20))
     end select
  endif
  return
end subroutine probfun

subroutine grad(x, gradx, i)

  use pmodule
  implicit none

  real (kind = wp), intent(in) :: x(:)
  real (kind = wp), intent(out) :: gradx(:)
  integer :: j, k
  integer, optional :: i

  ! x(1:4) is x_i
  ! x(5:20) is E(i,j), such that x(4+j+(i-1)*n) = E(i,j)

  gradx = zero
  if ( .not. present(i) ) then
     gradx(5:20) = 2.0_wp*x(5:20)
  else
     select case (i)
        ! Equality constraints
        case(1)
           !c = x(1)*(P(1,1)+x(5)) - x(4)*(P(4,4)+x(20))
           gradx(1) = P(1,1)+x(5)
           gradx(4) = -P(4,4)-x(20)
           gradx(5) = x(1)
           gradx(20) = -x(4)
        case(2)
           !c = x(1)*(P(1,2)+x(6)) - x(3)*(P(3,4)+x(16))
           gradx(1) = P(1,2)+x(6)
           gradx(3) = -P(3,4)-x(20)
           gradx(6) = x(1)
           gradx(16) = -x(3)
        case(3)
           !c = x(1)*(P(1,3)+x(7)) - x(2)*(P(2,4)+x(12))
           gradx(1) = P(1,3)+x(7)
           gradx(2) = -P(2,4)-x(12)
           gradx(7) = x(1)
           gradx(12) = -x(2)
        case(4)
           !c = x(2)*(P(2,1)+x(9)) - x(4)*(P(4,3)+x(19))
           gradx(2) = P(2,1)+x(9)
           gradx(4) = -P(4,3)-x(19)
           gradx(9) = x(2)
           gradx(19) = -x(4)
        case(5)
           !c = x(2)*(P(2,2)+x(10)) - x(3)*(P(3,3)+x(15))
           gradx(2) = P(2,2)+x(10)
           gradx(3) = -P(3,3)-x(15)
           gradx(10) = x(2)
           gradx(15) = -x(3)
        case(6)
           !c = x(3)*(P(3,1)+x(13)) - x(4)*(P(4,2)+x(18))
           gradx(3) = P(3,1)+x(13)
           gradx(4) = -P(4,2)-x(18)
           gradx(13) = x(3)
           gradx(18) = -x(4)
        case(7)
           !c = sum(x(5:8))
           gradx(5:8) = one
        case(8)
           !c = sum(x(9:12))
           gradx(9:12) = one
        case(9)
           !c = sum(x(13:16))
           gradx(13:16) = one
        case(10)
           !c = sum(x(17:20))
           gradx(17:20) = one
     end select
  endif
  return
end subroutine grad

subroutine hess(x,H,i)

  use pmodule, only : wp, one, zero
  implicit none

  ! Documentation excerpt from Galahad - lancelot_simple:
  !
  !      "If, additionally, the second-derivative matrix of f at X can be      !
  !      computed, the (optional) input argument MY_HESS must be               !
  !      specified and given the name of the user-supplied routine computing   !
  !      the Hessian, whose interface must be of the form                      !
  !                                                                            !
  !       HESSPROB( X, H )                                                     !
  !                                                                            !
  !      where H is a double precision vector of size n*(n+1)/2 in which the   !
  !      subroutine returns the entries of the upper triangular part of the    !
  !      Hessian of f at X, stored by columns.'

  integer:: j, k
  real(kind=wp), intent(in) :: x(:)
  real(kind=wp), intent(out) :: H(:)
  integer, optional :: i

  ! x(1:4) is x_i
  ! x(5:20) is E(i,j), such that x(4+j+(i-1)*n) = E(i,j)

  ! H is stored such that for k <= j
  ! H(k,j) = H(j*(j-1)/2 + k)
  !
  ! H(1) H(2) H(4)  H(7)
  !      H(3) H(5)  H(8)
  !           H(6)  H(9)
  !                H(10) ...
  !*H is 20x20

  H = zero
  if ( .not. present(i) ) then
     ! Hessian of the objective function sum(x(1:16)**2)
     ! Fill the diagonal for x(5:20)
     ! H([15 21 28 36 45 55 66 78 91 105 120 136 153 171 190 210])
     H(15) = 2.0_wp
     H(21) = 2.0_wp
     H(28) = 2.0_wp
     H(36) = 2.0_wp
     H(45) = 2.0_wp
     H(55) = 2.0_wp
     H(66) = 2.0_wp
     H(78) = 2.0_wp
     H(91) = 2.0_wp
     H(105) = 2.0_wp
     H(120) = 2.0_wp
     H(136) = 2.0_wp
     H(153) = 2.0_wp
     H(171) = 2.0_wp
     H(190) = 2.0_wp
     H(210) = 2.0_wp
  else
     select case (i)
        ! Equality constraints
     case(1)
        !c = x(1)*(P(1,1)+x(5)) - x(4)*(P(4,4)+x(20))
        !gradx(1) = P(1,1)+x(5)
        !gradx(4) = -P(4,4)-x(20)
        !gradx(5) = x(1)
        !gradx(20) = -x(4)
        !H(1,5) = 1 = H(11)
        !H(4,20) = -1 = H(194)
        !j = 5
        !k = 1
        ! 5*4/2+1 = 11
        H(11) = one
        !j = 20
        !k = 4
        ! 20*19/2+4 = 194
        H(194) = -one
     case(2)
        !c = x(1)*(P(1,2)+x(6)) - x(3)*(P(3,4)+x(16))
        !gradx(1) = P(1,2)+x(6)
        !gradx(3) = -P(3,4)-x(20)
        !gradx(6) = x(1)
        !gradx(16) = -x(3)
        ! H(1,6) = 1 = H(16)
        ! H(3,16) = -1 = H(123)
        !j = 6
        !k = 1
        ! 6*5/2+1 = 16
        H(16) = one
        !j = 16
        !k = 3
        ! 16*15/2+3 = 123
        H(123) = -one
     case(3)
        !c = x(1)*(P(1,3)+x(7)) - x(2)*(P(2,4)+x(12))
        !gradx(1) = P(1,3)+x(7)
        !gradx(2) = -P(2,4)-x(12)
        !gradx(7) = x(1)
        !gradx(12) = -x(2)
        ! H(1,7) = 1 = H(22)
        ! H(2,12) = -1 = H(68)
        !j = 7
        !k = 1
        ! 7*6/2+1 = 22
        H(22) = one
        !j = 12
        !k = 2
        ! 12*11/2+2 = 68
        H(68) = -one
     case(4)
        !c = x(2)*(P(2,1)+x(9)) - x(4)*(P(4,3)+x(19))
        !gradx(2) = P(2,1)+x(9)
        !gradx(4) = -P(4,3)-x(19)
        !gradx(9) = x(2)
        !gradx(19) = -x(4)
        !H(2,9) = 1 = H(38)
        !H(4,19) = -1 = H(175)
        !j = 9
        !k = 2
        ! 9*8/2+2 = 38
        H(38) = one
        !j = 19
        !k = 4
        ! 19*18/2+4 = 175
        H(175) = -one
     case(5)
        !c = x(2)*(P(2,2)+x(10)) - x(3)*(P(3,3)+x(15))
        !gradx(2) = P(2,2)+x(10)
        !gradx(3) = -P(3,3)-x(15)
        !gradx(10) = x(2)
        !gradx(15) = -x(3)
        !H(2,10) = 1 = H(47)
        !H(3,15) = -1 = H(108)
        !j = 10
        !k = 2
        ! 10*9/2+2 = 47
        H(47) = one
        !j = 15
        !k = 3
        ! 15*14/2+3 = 108
        H(108) = -one
     case(6)
        !c = x(3)*(P(3,1)+x(13)) - x(4)*(P(4,2)+x(18))
        !gradx(3) = P(3,1)+x(13)
        !gradx(4) = -P(4,2)-x(18)
        !gradx(13) = x(3)
        !gradx(18) = -x(4)
        !H(3,13) = 1 = H(81)
        !H(4,18) = -1 = H(157)
        !j = 13
        !k = 3
        ! 13*12/2+k = 81
        H(81) = one
        !j = 18
        !k = 4
        ! 18*17/2+4 = 157
        H(157) = -one
     end select
  endif
  return
end subroutine hess


! { dg-do compile }
! { dg-options "" }
program test
  implicit none

!!!!!! INTEGER BASE !!!!!!
  print *, 0**0
  print *, 0**1
  print *, 0**(-1) ! { dg-error "Division by zero" }
  print *, 0**(huge(0))
  print *, 0**(-huge(0)-1) ! { dg-error "Division by zero" }
  print *, 0**(2_8**32)
  print *, 0**(-(2_8**32)) ! { dg-error "Division by zero" }

  print *, 1**huge(0)
  print *, 1**(-huge(0)-1)
  print *, 1**huge(0_8)
  print *, 1**(-huge(0_8)-1_8)
  print *, (-1)**huge(0)
  print *, (-1)**(-huge(0)-1)
  print *, (-1)**huge(0_8)
  print *, (-1)**(-huge(0_8)-1_8)

  print *, 2**huge(0) ! { dg-error "Arithmetic overflow" }
  print *, 2**huge(0_8) ! { dg-error "Arithmetic overflow" }
  print *, (-2)**huge(0) ! { dg-error "Arithmetic overflow" }
  print *, (-2)**huge(0_8) ! { dg-error "Arithmetic overflow" }

  print *, 2**(-huge(0)-1)
  print *, 2**(-huge(0_8)-1_8)
  print *, (-2)**(-huge(0)-1)
  print *, (-2)**(-huge(0_8)-1_8)

!!!!!! REAL BASE !!!!!!
  print *, 0.0**(-1) ! { dg-error "Arithmetic overflow" }
  print *, 0.0**(-huge(0)-1) ! { dg-error "Arithmetic overflow" }
  print *, 2.0**huge(0) ! { dg-error "Arithmetic overflow" }
  print *, nearest(1.0,-1.0)**(-huge(0)) ! { dg-error "Arithmetic overflow" }

!!!!!! COMPLEX BASE !!!!!!
  print *, (2.0,-4.3)**huge(0) ! { dg-error "Arithmetic overflow" }
  print *, (2.0,-4.3)**huge(0_8) ! { dg-error "Arithmetic overflow" }
  print *, (2.0,-4.3)**(-huge(0))
  print *, (2.0,-4.3)**(-huge(0_8))

end program test


      subroutine wscal(n,sr,si,xr,xi,incx)
c!but
c
c     cette subroutine wscal multiplie une contante complexe s
c     (dont la partie reelle est rangee dans sr et la partie
c     imaginaire dans si) par un vecteur x (dont les parties
c     reelles de ses composantes sont rangees dans xr et les
c     parties imaginaires dans xi). le resultat reste dans x.
c
c!liste d'appel
c
c      subroutine wscal(n,sr,si,xr,xi,incx)
c
c     n: entier, taille du vecteur x.
c
c     sr, si: double precision, parties reelle et imaginaire
c     de s.
c
c     xr, xi: vecteurs double precision, contiennent,
c     respectivement, les parties reelles et imaginaires des
c     composants du vecteur x.
c
c     incx: entier, increment entre deux composantes consecutives
c     de x.
c
c!routines auxilieres
c
c     wmul
c
c!auteur
c
c     cleve moler.
c
c!
c     Copyright INRIA
      double precision sr,si,xr(*),xi(*)
      if (n .le. 0) return
      ix = 1
      do 10 i = 1, n
         call wmul(sr,si,xr(ix),xi(ix),xr(ix),xi(ix))
         ix = ix + incx
   10 continue
      return
      end


PROGRAM fib_omp
  USE omp_lib
  IMPLICIT NONE
  INTEGER :: fib
  INTEGER :: N, res
  REAL(kind=8) :: t_start, t_end
  N=44
  t_start = omp_get_wtime()
  !$OMP PARALLEL DEFAULT(none) SHARED(N,res)
  !$OMP SINGLE
  res=fib(N)
  !$OMP END SINGLE
  !$OMP END PARALLEL
  t_end = omp_get_wtime()

  WRITE(*,*) "result = ",res
  WRITE(*,*) "Expended wall clock time = ",t_end-t_start

END PROGRAM fib_omp

RECURSIVE FUNCTION fib(n) RESULT(res)
  IMPLICIT NONE

  INTEGER, INTENT(IN) :: n
  INTEGER :: res

  INTEGER :: x,y

  IF (n<2) THEN
     res=n
  ELSE IF (n<20) THEN
     x = fib(n-1)
     y = fib(n-2)
     res=x+y
  ELSE
     !$OMP TASK DEFAULT(none) SHARED(x,n)
     x = fib(n-1)
     !$OMP END TASK
     !$OMP TASK DEFAULT(none) SHARED(y,n)
     y = fib(n-2)
     !$OMP END TASK
     !$OMP TASKWAIT
     res=x+y
  END IF
END FUNCTION fib


      SUBROUTINE DSMTH9(X,WRK,NI,NJ,P,Q,XMSG,LWRAP,IER)
      DOUBLE PRECISION PO4
      DOUBLE PRECISION QO4
      DOUBLE PRECISION TERM1
      DOUBLE PRECISION TERM2

      LOGICAL LWRAP
      INTEGER NI,NJ,IER
      DOUBLE PRECISION X(NI,NJ),WRK(NI,NJ),P,Q,XMSG
c***********************************************************************
c modified j. olson routine
c***********************************************************************
c
c this routine does 9-point smoothing using the equation:
c
c   f0 = f0 + (p/4)*(f2+f4+f6+f8-4*f0) + (q/4)*(f1+f3+f5+f7-4*f0)
c
c  where the grid is:
c
c      1-------------8---------------7
c      |             |               |
c      |             |               |
c      |             |               |
c      |             |               |
c      2-------------0---------------6
c      |             |               |
c      |             |               |
c      |             |               |
c      |             |               |
c      3-------------4---------------5
c
c   arguments :
c .
c .   x        - 2-d input/output array
c .   wrk      - 2-d work array
c .   ni       - dimension
c .   nj       - dimension
c .   p        - first  weight (suggested value of  0.50)
c .   q        - second weight (suggested value of  0.25)
c .   xmsg     - value of missing points
c .   lwrap    - logical flag to include wraparound points in smoothing
c .              if lwrap = .true. , smooth left and right endpoints
c .              if lwrap = .false., no smoothing
c .
c  notes:
c
c       1)  if a point or any of its neighbors is missing, the point is
c           not smoothed
c       2)  this routine does not smooth the edges, just the interior
C*PL*ERROR* Comment line too long
c           with the exception that the left and right edges are smoothed
c           when "lwrap" is true.
c       3)  array has to have at least 3 points in each direction
c       4)  smoothed results are returned via the original input array
c
c***********************************************************************

c determine if size of array is sufficient

      IER = 0
      IF (NI.LT.3 .OR. NJ.LT.3) THEN
          IER = 1
          WRITE (*,FMT='(/,'' sub smth9: error'',2i5)') NI,NJ
          RETURN
      END IF

      PO4 = P/4.D0
      QO4 = Q/4.D0

c set the wrk array to msg

      DO I = 1,NI
          DO J = 1,NJ
              WRK(I,J) = XMSG
          END DO
      END DO

c are endpoints to be smoothed?

      IF (LWRAP) THEN
          NIB = 1
          NIE = NI
      ELSE
          NIB = 2
          NIE = NI - 1
      END IF
      NJB = 2
      NJE = NJ - 1

c  smooth

      DO J = NJB,NJE
          DO I = NIB,NIE
              JM1 = J - 1
              JP1 = J + 1
              IM1 = I - 1
              IP1 = I + 1
              IF (IM1.LT.1) IM1 = NI
              IF (IP1.GT.NI) IP1 = 1

              IF (X(I,J).EQ.XMSG .OR. X(IM1,JP1).EQ.XMSG .OR.
     +            X(IM1,J).EQ.XMSG .OR. X(IM1,JM1).EQ.XMSG .OR.
     +            X(I,JM1).EQ.XMSG .OR. X(IP1,JM1).EQ.XMSG .OR.
     +            X(IP1,J).EQ.XMSG .OR. X(IP1,JP1).EQ.XMSG .OR.
     +            X(I,JP1).EQ.XMSG) THEN
C original (unsmoothed) value
                  WRK(I,J) = X(I,J)
              ELSE
                  TERM1 = PO4* (X(IM1,J)+X(I,JM1)+X(IP1,J)+X(I,JP1)-
     +                    4.D0*X(I,J))
                  TERM2 = QO4* (X(IM1,JP1)+X(IM1,JM1)+X(IP1,JM1)+
     +                    X(IP1,JP1)-4.D0*X(I,J))
                  WRK(I,J) = X(I,J) + TERM1 + TERM2
              END IF
          END DO
      END DO

c transfer back to original array

      DO J = NJB,NJE
          DO I = NIB,NIE
              X(I,J) = WRK(I,J)
          END DO
      END DO

      RETURN
      END


      PROGRAM xpearsn
C     driver for routine pearsn
      INTEGER i
      REAL prob,r,z
      REAL dose(10),spore(10)
      DATA dose/56.1,64.1,70.0,66.6,82.,91.3,90.,99.7,115.3,110./
      DATA spore/0.11,0.4,0.37,0.48,0.75,0.66,0.71,1.2,1.01,0.95/
      write(*,'(1x,a)')
     *     'Effect of Gamma Rays on Man-in-the-Moon Marigolds'
      write(*,'(1x,a,t29,a)') 'Count Rate (cpm)','Pollen Index'
      do 11 i=1,10
        write(*,'(1x,f10.2,f25.2)') dose(i),spore(i)
11    continue
      call pearsn(dose,spore,10,r,prob,z)
      write(*,'(/1x,t24,a,t38,a)') 'PEARSN','Expected'
      write(*,'(1x,a,t18,2e15.6)') 'Corr. Coeff.',r,0.906959
      write(*,'(1x,a,t18,2e15.6)') 'Probability',prob,0.292650e-3
      write(*,'(1x,a,t18,2e15.6/)') 'Fisher''s Z',z,1.51011
      END

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


!! Copyright (C) 2016 Patrick N. Raanes
!!
!! Composed from qg.f90

module interface_mod
  use qgstep_mod
  use parameters_mod, only: dt, M, N, scheme, dtout
  use qgflux_mod
  use utils_mod, only: STRLEN

contains

  subroutine step(t, PSI, prmfname)
    real(8), intent(inout) :: t
    real(8), dimension(N, M), intent(inout) :: PSI
    character(STRLEN) :: prmfname

    ! 1st axis (len N) is the x-axis
    ! 2nd axis (len M) is the y-axis (curl = sin(...y))
    real(8), dimension(N, M) :: Q
    real(8) :: tstop

    call parameters_read(prmfname)

    tstop = t + dtout

    call laplacian(PSI, dx, dy, Q)
    Q = Q - F * PSI

    do while (t < tstop)
       if (strcmp(scheme, '2ndorder') == 0) then
          call qg_step_2ndorder(t, PSI, Q)
       elseif (strcmp(scheme, 'rk4') == 0) then
          call qg_step_rk4(t, PSI, Q)
       elseif (strcmp(scheme, 'dp5') == 0) then
          call qg_step_dp5(t, PSI, Q)
       else
          write(stdout, *) 'Error: unknown scheme "', trim(scheme), '"'
          stop
       end if
    end do
    call calc_psi(PSI, Q, PSI)
  end subroutine step

end module interface_mod


SUBROUTINE count_cores()
    USE OMP_LIB
    implicit none

    WRITE(*,*) "Number of cores: ", OMP_GET_MAX_THREADS()
    RETURN
END SUBROUTINE

SUBROUTINE dimentionMatrix(dimen, io_key)
implicit none

    integer :: num1, num2
    integer(kind=4)::dimen, io_key
    CHARACTER(100) :: arg1char, arg2char

    IF(COMMAND_ARGUMENT_COUNT().NE.2)THEN
        WRITE(*,*)'Error. Parameters are required!. Ej. 1000 1'
        STOP
    ENDIF

    CALL GET_COMMAND_ARGUMENT(1,arg1char)
    CALL GET_COMMAND_ARGUMENT(2,arg2char)

    READ(arg1char,*) num1
    READ(arg2char,*) num2

    dimen = num1
    io_key = num2

    WRITE(*,*) "Matrix Dimension: ", dimen, " x ", dimen

END SUBROUTINE

SUBROUTINE outputMatrix(m, n_matrix, name_file)
implicit none
    real(kind=8),allocatable::m(:,:)
    character(len = 15) :: name_file
    real::aux
    integer :: n_matrix, i, j, n

    n = n_matrix
    allocate(m(n,n))

    open(1, file = name_file, status='new')
    call random_seed()
    !$OMP PARALLEL DO
    do i = 1, n
        do j = 1, n
            call random_number(m(i, j))
            write(1,*)  m(i,j)
        end do
    end do
    !$OMP END PARALLEL DO
    close(1)
END SUBROUTINE

SUBROUTINE ioMatrix(m, n_matrix, name_file)
    implicit none
        real(kind=8),allocatable::m(:,:)
        character(len = 15) :: name_file
        integer :: n_matrix, i, j, n

        n = n_matrix
        allocate(m(n,n))

        open(1, file = name_file, status='new')
        call random_seed()
        !$OMP PARALLEL DO
        do i = 1, n
            do j = 1, n
                call random_number(m(i, j))
                write(1,*)  m(i,j)
            end do
        end do
        !$OMP END PARALLEL DO
        close(1)

        ! opening file for reading
        open (2, file = name_file, status = 'old')
        !$OMP PARALLEL DO
        do i = 1,n
            do j = 1, n
                read(2,*) m(i,j)
            end do
        end do
        !$OMP END PARALLEL DO
        close(2)
END SUBROUTINE

PROGRAM matrixMultiplication
implicit none

    integer(kind=4)::n=10, key=0 ! 10 by default
    real(kind=8),allocatable::a(:,:),b(:,:),c(:,:),d(:,:),e(:,:)
    real(kind=8)::alpha,beta
    integer(kind=4)::i,j,k,lda,ldb,lde
    real(kind=4)::start, finish, var_triple, var_matmul, var_dgemm

    WRITE(*,*)'****Parallel Matrix Multiplication****'
    call count_cores()

    !   validate input
    call dimentionMatrix(n, key)
    !   allocate memory
    allocate(a(n,n),b(n,n),c(n,n),d(n,n),e(n,n))
    alpha=1.0;beta=1.0
    lda = n; ldb = n; lde = n

    IF(key.EQ.1)THEN

        call cpu_time(start)

        call ioMatrix(a, n, 'data1.dat')
        call ioMatrix(b, n, 'data2.dat')

        call cpu_time(finish)

        write(unit=6,fmt=100) "Time to create matrix: ",finish-start," s."

    ELSE

        call cpu_time(start)

        call random_seed()
        do j=1, n
            do i=1, n
                call random_number(a(i,j))
                call random_number(b(i,j))
            enddo
        enddo

        call cpu_time(finish)
        write(unit=6,fmt=100) "Time to create matrix: ",finish-start," s."

    ENDIF

    !---------------------------------------------------------------------
    ! a) triple do-loop.
    call cpu_time(start)
    c=0.0D0

    !$OMP PARALLEL DO
    do j=1, n
        do i=1, n
            do k=1, n
                c(i,j)=c(i,j)+a(i,k)*b(k,j)
            enddo
        enddo
    enddo
    !$OMP END PARALLEL DO

    call cpu_time(finish)
    write(unit=6,fmt=100) "Triple do-loop with threads: ",finish-start," s."
    var_triple = (finish-start)

    !---------------------------------------------------------------------
    ! b) matmul(a,b).
    call cpu_time(start)
    d=0.0D0
    d=matmul(a,b)
    call cpu_time(finish)
    write(unit=6,fmt=100) "Matmul(a,b): ",finish-start," s."
    var_matmul = (finish-start)

    !---------------------------------------------------------------------
    ! c) dgemm - INTEL MKL.
    call cpu_time(start)
    e=0.0D0
    call dgemm("N","N",n,n,n,alpha,a,lda,b,ldb,beta,e,lde)
    call cpu_time(finish)
    write(unit=6,fmt=100) "DGEMM: ",finish-start," s."
    var_dgemm = (finish-start)

    !---------------------------------------------------------------------
    open (1, file = 'data_times.dat', action='write', position='append') !check the file
    write(1, *) nint(n * 1000.0) * 1E-3,var_triple,var_matmul,var_dgemm
    close(1)

    deallocate(a,b,c,d,e)

    stop
    100 format(A,F8.3,A)

END PROGRAM


! { dg-do run }
! { dg-require-effective-target fortran_large_real }

module testmod
  integer,parameter :: k = selected_real_kind (precision (0.0_8) + 1)
contains
  subroutine testoutput (a,b,length,f)
    real(kind=k),intent(in) :: a
    real(kind=8),intent(in) ::  b
    integer,intent(in) :: length
    character(len=*),intent(in) :: f

    character(len=length) :: ca
    character(len=length) :: cb

    write (ca,f) a
    write (cb,f) b
    if (ca /= cb) call abort
  end subroutine testoutput

  subroutine outputstring (a,f,s)
    real(kind=k),intent(in) :: a
    character(len=*),intent(in) :: f
    character(len=*),intent(in) :: s

    character(len=len(s)) :: c

    write (c,f) a
    if (c /= s) call abort
  end subroutine outputstring
end module testmod

! Testing I/O of large real kinds (larger than kind=8)
program test
  use testmod
  implicit none

  real(kind=k) :: x
  character(len=20) :: c1, c2

  call testoutput (0.0_k,0.0_8,40,'(F40.35)')

  call testoutput (1.0_k,1.0_8,40,'(F40.35)')
  call testoutput (0.1_k,0.1_8,15,'(F15.10)')
  call testoutput (1e10_k,1e10_8,15,'(F15.10)')
  call testoutput (7.51e100_k,7.51e100_8,15,'(F15.10)')
  call testoutput (1e-10_k,1e-10_8,15,'(F15.10)')
  call testoutput (7.51e-100_k,7.51e-100_8,15,'(F15.10)')

  call testoutput (-1.0_k,-1.0_8,40,'(F40.35)')
  call testoutput (-0.1_k,-0.1_8,15,'(F15.10)')
  call testoutput (-1e10_k,-1e10_8,15,'(F15.10)')
  call testoutput (-7.51e100_k,-7.51e100_8,15,'(F15.10)')
  call testoutput (-1e-10_k,-1e-10_8,15,'(F15.10)')
  call testoutput (-7.51e-100_k,-7.51e-100_8,15,'(F15.10)')

  x = huge(x)
  call outputstring (2*x,'(F20.15)','           +Infinity')
  call outputstring (-2*x,'(F20.15)','           -Infinity')

  write (c1,'(G20.10E5)') x
  write (c2,'(G20.10E5)') -x
  if (c2(1:1) /= '-') call abort
  c2(1:1) = ' '
  if (c1 /= c2) call abort

  x = tiny(x)
  call outputstring (x,'(F20.15)','   0.000000000000000')
  call outputstring (-x,'(F20.15)','   0.000000000000000')

  write (c1,'(G20.10E5)') x
  write (c2,'(G20.10E5)') -x
  if (c2(1:1) /= '-') call abort
  c2(1:1) = ' '
  if (c1 /= c2) call abort
end program test

! { dg-final { cleanup-modules "testmod" } }


! { dg-do compile }
!
! PR fortran/66257
! Check that typebound function calls are accepted as actual argument.
!
MODULE test_class
  IMPLICIT NONE
  PRIVATE
  PUBLIC:: test

  INTEGER, PARAMETER :: dp  = SELECTED_REAL_KIND(15)

  TYPE test
      PRIVATE
      CONTAINS
          PRIVATE
              PROCEDURE, PUBLIC:: E
              PROCEDURE, PUBLIC:: Om
  END TYPE test

CONTAINS

  ELEMENTAL FUNCTION E (self, a)
    IMPLICIT NONE
    CLASS(test), INTENT(IN):: self
    REAL(kind=dp), INTENT(IN):: a
    REAL(kind=dp):: E

    E = a
  END FUNCTION E

  ELEMENTAL FUNCTION Om (self, z)
    IMPLICIT NONE
    CLASS(test), INTENT(IN):: self
    REAL(kind=dp), INTENT(IN):: z
    REAL(kind=dp):: Om

    Om = self%E(self%E(z))
    Om = log10(self%E(z))
  END FUNCTION Om
END MODULE test_class


c { dg-do run }
      program foo
      complex(kind=8)      z0, z1, z2

      z0 = dcmplx(0.,.5)
      z1 = 1./z0
      if (z1 .ne. dcmplx(0.,-2)) STOP 1

      z0 = 10.*z0
      if (z0 .ne. dcmplx(0.,5.)) STOP 2

      z2 = cmplx(1.,2.)
      z1 = z0/z2
      if (z1 .ne. dcmplx(2.,1.)) STOP 3

      z1 = z0*z2
      if (z1 .ne. dcmplx(-10.,5.)) STOP 4
      end


!   =====================================================
subroutine rpt2(ixy,imp,maxm,meqn,mwaves,maux,mbc,mx,ql,qr,aux1,aux2,aux3,asdq,bmasdq,bpasdq)
!   =====================================================
    implicit double precision (a-h,o-z)

!     # Riemann solver in the transverse direction for the acoustics equations.

!     # Split asdq into down-going flux bmasdq and up-going flux bpasdq.

    dimension     ql(meqn, 1-mbc:maxm+mbc)
    dimension     qr(meqn, 1-mbc:maxm+mbc)
    dimension   asdq(meqn, 1-mbc:maxm+mbc)
    dimension bmasdq(meqn, 1-mbc:maxm+mbc)
    dimension bpasdq(meqn, 1-mbc:maxm+mbc)

!     # density, bulk modulus, and sound speed, and impedence of medium:
!     # (should be set in setprob.f)
    common /cparam/ rho,bulk,cc,zz

    if (ixy == 1) then
        mu = 2
        mv = 3
    else
        mu = 3
        mv = 2
    endif

    do 20 i = 2-mbc, mx+mbc
        a1 = (-asdq(1,i) + zz*asdq(mv,i)) / (2.d0*zz)
        a2 = (asdq(1,i) + zz*asdq(mv,i)) / (2.d0*zz)

    !        # The down-going flux difference bmasdq is the product  -c * wave

        bmasdq(1,i) = cc * a1*zz
        bmasdq(mu,i) = 0.d0
        bmasdq(mv,i) = -cc * a1

    !        # The up-going flux difference bpasdq is the product  c * wave

        bpasdq(1,i) = cc * a2*zz
        bpasdq(mu,i) = 0.d0
        bpasdq(mv,i) = cc * a2

    20 END DO

    return
    end subroutine rpt2


      REAL FUNCTION DS1900 (YEAR,DAY)

!     calculate number of days since Jan 1, 1900

      REAL YEAR, DAY
      SAVE

      DS1900 = (YEAR-1900.)*365.+DAY+REAL (INT(YEAR+3.-1900.)/4)

      RETURN
      END


      DOUBLE PRECISION FUNCTION DLGAMA(X)
C***********************************************************************
C*                                                                     *
C*  FORTRAN CODE WRITTEN FOR INCLUSION IN IBM RESEARCH REPORT RC20525, *
C*  'FORTRAN ROUTINES FOR USE WITH THE METHOD OF L-MOMENTS, VERSION 3' *
C*                                                                     *
C*  J. R. M. HOSKING                                                   *
C*  IBM RESEARCH DIVISION                                              *
C*  T. J. WATSON RESEARCH CENTER                                       *
C*  YORKTOWN HEIGHTS                                                   *
C*  NEW YORK 10598, U.S.A.                                             *
C*                                                                     *
C*  VERSION 3     AUGUST 1996                                          *
C*                                                                     *
C***********************************************************************
C
C  LOGARITHM OF GAMMA FUNCTION
C
C  BASED ON ALGORITHM ACM291, COMMUN. ASSOC. COMPUT. MACH. (1966)
C
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      DATA SMALL,CRIT,BIG,TOOBIG/1D-7,13D0,1D9,2D36/
C
C         C0 IS 0.5*LOG(2*PI)
C         C1...C7 ARE THE COEFFTS OF THE ASYMPTOTIC EXPANSION OF DLGAMA
C
      DATA C0,C1,C2,C3,C4,C5,C6,C7/
     *   0.91893 85332 04672 742D 0,  0.83333 33333 33333 333D-1,
     *  -0.27777 77777 77777 778D-2,  0.79365 07936 50793 651D-3,
     *  -0.59523 80952 38095 238D-3,  0.84175 08417 50841 751D-3,
     *  -0.19175 26917 52691 753D-2,  0.64102 56410 25641 026D-2/
C
C         S1 IS -(EULER'S CONSTANT), S2 IS PI**2/12
C
      DATA S1/-0.57721 56649 01532 861D 0/
      DATA S2/ 0.82246 70334 24113 218D 0/
C
      DATA ZERO/0D0/,HALF/0.5D0/,ONE/1D0/,TWO/2D0/
      DLGAMA=ZERO
      IF(X.LE.ZERO)GOTO 1000
      IF(X.GT.TOOBIG)GOTO 1000
C
C         USE SMALL-X APPROXIMATION IF X IS NEAR 0, 1 OR 2
C
      IF(DABS(X-TWO).GT.SMALL)GOTO 10
      DLGAMA=DLOG(X-ONE)
      XX=X-TWO
      GOTO 20
   10 IF(DABS(X-ONE).GT.SMALL)GOTO 30
      XX=X-ONE
   20 DLGAMA=DLGAMA+XX*(S1+XX*S2)
      RETURN
   30 IF(X.GT.SMALL)GOTO 40
      DLGAMA=-DLOG(X)+S1*X
      RETURN
C
C         REDUCE TO DLGAMA(X+N) WHERE X+N.GE.CRIT
C
   40 SUM1=ZERO
      Y=X
      IF(Y.GE.CRIT)GOTO 60
      Z=ONE
   50 Z=Z*Y
      Y=Y+ONE
      IF(Y.LT.CRIT)GOTO 50
      SUM1=SUM1-DLOG(Z)
C
C         USE ASYMPTOTIC EXPANSION IF Y.GE.CRIT
C
   60 SUM1=SUM1+(Y-HALF)*DLOG(Y)-Y+C0
      SUM2=ZERO
      IF(Y.GE.BIG)GOTO 70
      Z=ONE/(Y*Y)
      SUM2=((((((C7*Z+C6)*Z+C5)*Z+C4)*Z+C3)*Z+C2)*Z+C1)/Y
   70 DLGAMA=SUM1+SUM2
      RETURN
C
 1000 WRITE(6,7000)X
      RETURN
C
 7000 FORMAT(' *** ERROR *** ROUTINE DLGAMA :',
     *  ' ARGUMENT OUT OF RANGE :',D24.16)
      END


SUBROUTINE convert(x0, y0, dx, dy, x, y, npts, dir, dist)
  IMPLICIT none

  INTEGER npts
  REAL x0(npts), y0(npts), x(npts), y(npts)
  REAL dx(npts), dy(npts)
  REAL dir(npts), dist(npts)

  REAL kmtonm
  PARAMETER (kmtonm = 1. /  1.852 )

  REAL xp(npts), yp(npts)
  REAL dxnm(npts), dynm(npts)
  REAL dummy, wdir, arcdis
  INTEGER i

  xp = x0 + dx
  yp = y0 + dy
  DO i = 1, npts
    dxnm(i) = kmtonm * arcdis(x0(i), y0(i), xp(i), y0(i))
    dynm(i) = kmtonm * arcdis(x0(i), y0(i), x0(i), yp(i))
    dxnm(i) = SIGN(dxnm(i), x0(i)-xp(i))
    dynm(i) = SIGN(dynm(i), y0(i)-yp(i))

    dir(i)  = wdir(-dxnm(i), -dynm(i), dummy)
    dist(i) = kmtonm * arcdis(x0(i), y0(i), x(i), y(i))
  ENDDO

  RETURN
END SUBROUTINE convert