      SUBROUTINE VCC(X1,Y1,X2,Y2,NS,R2)
      IMPLICIT none
!
!   PROGRAM IN FORTRAN 77 TO CALCULATE THE VECTOR CORRELATION
!   COEFFICIENT OF JUPP AND MARDIA(BIOMETRIKA,1980).
!
!   THE FOLLOWING PROGRAM CALCULATES THE VECTOR CORRELATION BETWEEN
!   SEQUENCES OF TWO-DIMENSIONAL VECTORS. THESE VECTORS MUST BE
!   SPECIFIED IN TERMS OF THEIR U(X1,Y1) AND V(X2,Y2) COMPONENTS.
!   FOR TWO-DIMENSIONAL VECTORS, THE VECTOR CORRELATION COEFFICIENT
!   (SQUARED) WILL VARY BETWEEN 0.0(UNCORRELATED) AND 2.0
!   (COMPLETELY CORRELATED).
!
!   VECTOR CORRELATION COEFFICIENTS CALCULATED ACCORDING TO THE
!   FOLLOWING PROGRAM SHOULD BE ACCURATE TO AT LEAST THREE DECIMAL
!   PLACES USING SINGLE PRECISION ARITHMETIC.
!
!   NS IS THE SAMPLE SIZE - SAMPLE SIZES LESS THAN 8 ARE NOT
!   RECOMMENDED BECAUSE THE ASYMPTOTIC CHI-SQUARE DISTRIBUTION
!   BREAKS DOWN FOR SMALLER VALUES.
!
! Origin: Crosby, Breaker, Gemmill
!
! Maintenance: Robert Grumbine
! Dec 1998
!
      INTEGER NS
      REAL VAR1,VAR2,VAR3,VAR4,COV12,COV13,COV14,COV23,COV24,
     *COV34,X1(NS),Y1(NS),X2(NS),Y2(NS),R2
!
        CALL STAT1(X1,Y1,X2,Y2,NS,VAR1,VAR2,COV12)
        CALL STAT2(X1,Y1,X2,Y2,NS,VAR1,VAR3,COV13)
        CALL STAT3(X1,Y1,X2,Y2,NS,VAR1,VAR4,COV14)
        CALL STAT4(X1,Y1,X2,Y2,NS,VAR2,VAR3,COV23)
        CALL STAT5(X1,Y1,X2,Y2,NS,VAR2,VAR4,COV24)
        CALL STAT6(X1,Y1,X2,Y2,NS,VAR3,VAR4,COV34)
        CALL RSQ(VAR1,VAR2,VAR3,VAR4,COV12,COV13,COV14,COV23,
     *  COV24,COV34,R2)
      RETURN
      END
      SUBROUTINE STAT1(X1,Y1,X2,Y2,NS,VAR1,VAR2,COV12)
      IMPLICIT none
      INTEGER I, NS
      REAL VAR1,VAR2,COV12,SUMX1,SUMY1,SX1SQ,SY1SQ,SX1Y1,
     *X1(*),Y1(*),X2(*),Y2(*)
      SUMX1 = 0.0
      SUMY1 = 0.0
      SX1SQ = 0.0
      SY1SQ = 0.0
      SX1Y1 = 0.0
      DO I = 1,NS
        SUMX1 = SUMX1 + X1(I)
        SUMY1 = SUMY1 + Y1(I)
        SX1SQ = SX1SQ + X1(I)*X1(I)
        SY1SQ = SY1SQ + Y1(I)*Y1(I)
        SX1Y1 = SX1Y1 + X1(I)*Y1(I)
      ENDDO
      VAR1 = (FLOAT(NS) * SX1SQ - SUMX1 * SUMX1) / FLOAT(NS * (NS - 1))
      VAR2 = (FLOAT(NS) * SY1SQ - SUMY1 * SUMY1) / FLOAT(NS * (NS - 1))
      COV12 = (FLOAT(NS) * SX1Y1 - SUMX1 * SUMY1) / FLOAT(NS * (NS - 1))
      RETURN
      END
      SUBROUTINE STAT2(X1,Y1,X2,Y2,NS,VAR1,VAR3,COV13)
      IMPLICIT none
      INTEGER I, NS
      REAL VAR1,VAR3,COV13,SUMX1,SUMX2,SX1SQ,SX2SQ,SX1X2,
     *X1(*),Y1(*),X2(*),Y2(*)
      SUMX1 = 0.0
      SUMX2 = 0.0
      SX1SQ = 0.0
      SX2SQ = 0.0
      SX1X2 = 0.0
      DO I = 1,NS
        SUMX1 = SUMX1 + X1(I)
        SUMX2 = SUMX2 + X2(I)
        SX1SQ = SX1SQ + X1(I)*X1(I)
        SX2SQ = SX2SQ + X2(I)*X2(I)
        SX1X2 = SX1X2 + X1(I)*X2(I)
      ENDDO
      VAR1 = (FLOAT(NS) * SX1SQ - SUMX1 * SUMX1) / FLOAT(NS * (NS - 1))
      VAR3 = (FLOAT(NS) * SX2SQ - SUMX2 * SUMX2) / FLOAT(NS * (NS - 1))
      COV13 = (FLOAT(NS) * SX1X2 - SUMX1 * SUMX2) / FLOAT(NS * (NS - 1))
      RETURN
      END
      SUBROUTINE STAT3(X1,Y1,X2,Y2,NS,VAR1,VAR4,COV14)
      IMPLICIT none
      INTEGER I, NS
      REAL VAR1,VAR4,COV14,SUMX1,SUMY2,SX1SQ,SY2SQ,SX1Y2,
     *X1(*),Y1(*),X2(*),Y2(*)
      SUMX1 = 0.0
      SUMY2 = 0.0
      SX1SQ = 0.0
      SY2SQ = 0.0
      SX1Y2 = 0.0
      DO I = 1,NS
        SUMX1 = SUMX1 + X1(I)
        SUMY2 = SUMY2 + Y2(I)
        SX1SQ = SX1SQ + X1(I)*X1(I)
        SY2SQ = SY2SQ + Y2(I)*Y2(I)
        SX1Y2 = SX1Y2 + X1(I)*Y2(I)
      ENDDO
      VAR1 = (FLOAT(NS) * SX1SQ - SUMX1 * SUMX1) / FLOAT(NS * (NS - 1))
      VAR4 = (FLOAT(NS) * SY2SQ - SUMY2 * SUMY2) / FLOAT(NS * (NS - 1))
      COV14 = (FLOAT(NS) * SX1Y2 - SUMX1 * SUMY2) / FLOAT(NS * (NS - 1))
      RETURN
      END
      SUBROUTINE STAT4(X1,Y1,X2,Y2,NS,VAR2,VAR3,COV23)
      IMPLICIT none
      INTEGER I, NS
      REAL VAR2,VAR3,COV23,SUMY1,SUMX2,SY1SQ,SX2SQ,SY1X2,
     *X1(*),Y1(*),X2(*),Y2(*)
      SUMY1 = 0.0
      SUMX2 = 0.0
      SY1SQ = 0.0
      SX2SQ = 0.0
      SY1X2 = 0.0
      DO I = 1,NS
        SUMY1 = SUMY1 + Y1(I)
        SUMX2 = SUMX2 + X2(I)
        SY1SQ = SY1SQ + Y1(I)*Y1(I)
        SX2SQ = SX2SQ + X2(I)*X2(I)
        SY1X2 = SY1X2 + Y1(I)*X2(I)
      ENDDO
      VAR2 = (FLOAT(NS) * SY1SQ - SUMY1 * SUMY1) / FLOAT(NS * (NS - 1))
      VAR3 = (FLOAT(NS) * SX2SQ - SUMX2 * SUMX2) / FLOAT(NS * (NS - 1))
      COV23 = (FLOAT(NS) * SY1X2 - SUMY1 * SUMX2) / FLOAT(NS * (NS - 1))
      RETURN
      END
      SUBROUTINE STAT5(X1,Y1,X2,Y2,NS,VAR2,VAR4,COV24)
      IMPLICIT none
      INTEGER I, NS
      REAL VAR2,VAR4,COV24,SUMY1,SUMY2,SY1SQ,SY2SQ,SY1Y2,
     *X1(*),Y1(*),X2(*),Y2(*)
      SUMY1 = 0.0
      SUMY2 = 0.0
      SY1SQ = 0.0
      SY2SQ = 0.0
      SY1Y2 = 0.0
      DO I = 1,NS
        SUMY1 = SUMY1 + Y1(I)
        SUMY2 = SUMY2 + Y2(I)
        SY1SQ = SY1SQ + Y1(I)*Y1(I)
        SY2SQ = SY2SQ + Y2(I)*Y2(I)
        SY1Y2 = SY1Y2 + Y1(I)*Y2(I)
      ENDDO
      VAR2 = (FLOAT(NS) * SY1SQ - SUMY1 * SUMY1) / FLOAT(NS * (NS - 1))
      VAR4 = (FLOAT(NS) * SY2SQ - SUMY2 * SUMY2) / FLOAT(NS * (NS - 1))
      COV24 = (FLOAT(NS) * SY1Y2 - SUMY1 * SUMY2) / FLOAT(NS * (NS - 1))
      RETURN
      END
      SUBROUTINE STAT6(X1,Y1,X2,Y2,NS,VAR3,VAR4,COV34)
      IMPLICIT none
      INTEGER I, NS
      REAL VAR3,VAR4,COV34,SUMX2,SUMY2,SX2SQ,SY2SQ,SX2Y2,
     *X1(*),Y1(*),X2(*),Y2(*)
      SUMX2 = 0.0
      SUMY2 = 0.0
      SX2SQ = 0.0
      SY2SQ = 0.0
      SX2Y2 = 0.0
      DO I = 1,NS
        SUMX2 = SUMX2 + X2(I)
        SUMY2 = SUMY2 + Y2(I)
        SX2SQ = SX2SQ + X2(I)*X2(I)
        SY2SQ = SY2SQ + Y2(I)*Y2(I)
        SX2Y2 = SX2Y2 + X2(I)*Y2(I)
      ENDDO
      VAR3 = (FLOAT(NS) * SX2SQ - SUMX2 * SUMX2) / FLOAT(NS * (NS - 1))
      VAR4 = (FLOAT(NS) * SY2SQ - SUMY2 * SUMY2) / FLOAT(NS * (NS - 1))
      COV34 = (FLOAT(NS) * SX2Y2 - SUMX2 * SUMY2) / FLOAT(NS * (NS - 1))
      RETURN
      END
      SUBROUTINE RSQ(VAR1,VAR2,VAR3,VAR4,COV12,COV13,COV14,
     *COV23,COV24,COV34,R2)
      IMPLICIT none
      REAL R,R2,VAR1,VAR2,VAR3,VAR4,COV12,COV13,COV14,COV23,
     *COV24,COV34,A1,A2,A3,A4,A5,A6,A7,A8,B1,B2,B3,B4,B5,B6,
     *B7,B8,C,D,E,F,G,H,I,J,M,N,T1,T2,U1,U2,T,U,P
      A1 = VAR2 * COV13
      A2 = COV12 * COV23
      A3 = VAR4 * COV13
      A4 = COV34 * COV14
      A5 = VAR2 * COV14
      A6 = COV12 * COV24
      A7 = COV34 * COV13
      A8 = VAR3 * COV14
      B1 = COV12 * COV13
      B2 = VAR1 * COV23
      B3 = VAR4 * COV23
      B4 = COV34 * COV24
      B5 = COV12 * COV14
      B6 = VAR1 * COV24
      B7 = COV34 * COV23
      B8 = VAR3 * COV24
      C = A1 - A2
      D = A3 - A4
      E = A5 - A6
      F = A8 - A7
      G = B2 - B1
      H = B3 - B4
      I = B6 - B5
      J = B8 - B7
      M = C*D + E*F
      N = G*H + I*J
      T1 = VAR1 * VAR2
      T2 = COV12 * COV12
      U1 = VAR3 * VAR4
      U2 = COV34 * COV34
      T = T1 - T2
      U = U1 - U2
      P = T * U
      R2 = (M + N)/P
      R = SQRT(R2)
      RETURN
      END


!*********************************************************************
! This file is part of Polylogarithm.
!
! Polylogarithm is licenced under the MIT License.
!*********************************************************************

!*********************************************************************
!> @brief Clausen function \f$\operatorname{Cl}_2(\theta) = \operatorname{Im}(\operatorname{Li}_2(e^{i\theta}))\f$
!> @param x real angle
!> @return \f$\operatorname{Cl}_2(\theta)\f$
!> @author Alexander Voigt
!> Implemented as rational function approximation.
!*********************************************************************

double precision function dcl2(x)
  implicit none
  double precision :: x, y, z, z2, z4, p, q, p0, p1, h, sgn
  double precision, parameter :: PI = 3.14159265358979324D0
  double precision, parameter :: PI2 = 2*PI, PIH = PI/2, PI28 = PI*PI/8
  double precision, parameter :: cp(4) = (/ &
      1.3888888888888889D-2,                &
     -4.3286930203743071D-4,                &
      3.2779814789973427D-6,                &
     -3.6001540369575084D-9                 /)
  double precision, parameter :: cq(4) = (/ &
      1.0000000000000000D+0,                &
     -3.6166589746694121D-2,                &
      3.6015827281202639D-4,                &
     -8.3646182842184428D-7                 /)
  double precision, parameter :: cr(6) = (/ &
      6.4005702446195512D-1,                &
     -2.0641655351338783D-1,                &
      2.4175305223497718D-2,                &
     -1.2355955287855728D-3,                &
      2.5649833551291124D-5,                &
     -1.4783829128773320D-7                 /)
  double precision, parameter :: cs(6) = (/ &
      1.0000000000000000D+0,                &
     -2.5299102015666356D-1,                &
      2.2148751048467057D-2,                &
     -7.8183920462457496D-4,                &
      9.5432542196310670D-6,                &
     -1.8184302880448247D-8                 /)

  sgn = 1

  if (x .lt. 0) then
     x = -x
     sgn = -1
  endif

  if (x .ge. PI2) then
     x = mod(x, PI2)
  endif

  if (x .gt. PI) then
     p0 = 6.28125D0
     p1 = 0.0019353071795864769253D0
     x = (p0 - x) + p1
     sgn = -sgn
  endif

  if (x .eq. 0 .or. x .eq. PI) then
     dcl2 = 0
     return
  endif

  if (x .lt. PIH) then
    y = x*x
    z = y*y
    p = cp(1) + y * cp(2) + z * (cp(3) + y * cp(4))
    q = cq(1) + y * cq(2) + z * (cq(3) + y * cq(4))
    h = x*(1 - log(x) + y*p/q)
  else
    y = PI - x
    z = y*y - PI28
    z2 = z*z
    z4 = z2*z2
    p = cr(1) + z * cr(2) + z2 * (cr(3) + z * cr(4)) + &
        z4 * (cr(5) + z * cr(6))
    q = cs(1) + z * cs(2) + z2 * (cs(3) + z * cs(4)) + &
        z4 * (cs(5) + z * cs(6))
    h = y*p/q
  endif

  dcl2 = sgn*h

end function dcl2


! written by jxzou at 20180616

! This subroutine/program will first compute the U matrix between two sets of MO (coeff1 and lo_coeff1)
!  then apply U onto coeff2 and the result is stored in new_coeff2

!  For GNU compiler, use
! ------------------------------------------------------
!  f2py -m assoc_rot -c assoc_rot.f90 --link-lapack_opt
! ------------------------------------------------------
!  For INTEL compiler, use
! ---------------------------------------------------------------------------------------------
!  f2py -m assoc_rot -c assoc_rot.f90 --link-lapack_opt --fcompiler=intelem --compiler=intelem
! ---------------------------------------------------------------------------------------------

subroutine assoc_rot(nbf, nmo, coeff1, lo_coeff1, coeff2, new_coeff2)
 implicit none
 integer i, info
 integer nbf, nmo
!f2py intent(in) :: nbf, nmo
 integer, allocatable :: ipiv(:)
 real(kind=8) coeff1(nbf,nmo), lo_coeff1(nbf,nmo), coeff2(nbf,nmo)
 real(kind=8) new_coeff2(nbf,nmo)
!f2py intent(in,copy) :: coeff1, lo_coeff1
!f2py intent(in) :: coeff2
!f2py intent(out) :: new_coeff2
!f2py depend(nbf,nmo) coeff1, lo_coeff1, coeff2, new_coeff2

 ! mkl Syntax FORTRAN 77:
 ! ?getrf: Computes the LU factorization of a general m-by-n matrix
 ! call dgetrf(m, n, a, lda, ipiv, info)

 ! ?getrs: Solves a system of linear equations with an LU-factored square
 !  matrix, with multiple right-hand sides.
 ! call dgetrs(trans, n, nrhs, a, lda, ipiv, b, ldb, info)

 ! ?gemm: Computes a matrix-matrix product with general matrix
 ! call dgemm(transa, transb, m, n, k, alpha, a, lda, b, ldb, beta, c, ldc)

 ! find the unitary (orthogonal) matrix between coeff1 and lo_coeff1,
 !  where coeff1*U = lo_coeff1
 allocate(ipiv(min(nbf,nmo)))
 ipiv = 0
 call dgetrf(nbf, nmo, coeff1, nbf, ipiv, info)
 call dgetrs('N', nmo, nmo, coeff1, nbf, ipiv, lo_coeff1, nbf, info)
 deallocate(ipiv)

 ! reverse the coeff2
 forall(i = 1:nmo)
  coeff1(:,i) = coeff2(:,nmo-i+1)
 end forall
 coeff2 = coeff1
 ! rotate the coeff2
 new_coeff2 = 0d0
 call dgemm('N', 'N', nbf, nmo, nmo, 1d0, coeff2, nbf, lo_coeff1, nbf, 0d0, new_coeff2, nbf)
 ! reverse the coeff2 again
 forall(i = 1:nmo)
  coeff1(:,i) = new_coeff2(:,nmo-i+1)
 end forall
 new_coeff2 = coeff1
 return
end subroutine assoc_rot


      subroutine dchex(r,ldr,p,k,l,z,ldz,nz,c,s,job)
      integer ldr,p,k,l,ldz,nz,job
      double precision r(ldr,1),z(ldz,1),s(1)
      double precision c(1)
c
c     dchex updates the cholesky factorization
c
c                   a = trans(r)*r
c
c     of a positive definite matrix a of order p under diagonal
c     permutations of the form
c
c                   trans(e)*a*e
c
c     where e is a permutation matrix.  specifically, given
c     an upper triangular matrix r and a permutation matrix
c     e (which is specified by k, l, and job), dchex determines
c     a orthogonal matrix u such that
c
c                           u*r*e = rr,
c
c     where rr is upper triangular.  at the users option, the
c     transformation u will be multiplied into the array z.
c     if a = trans(x)*x, so that r is the triangular part of the
c     qr factorization of x, then rr is the triangular part of the
c     qr factorization of x*e, i.e. x with its columns permuted.
c     for a less terse description of what dchex does and how
c     it may be applied, see the linpack guide.
c
c     the matrix q is determined as the product u(l-k)*...*u(1)
c     of plane rotations of the form
c
c                           (    c(i)       s(i) )
c                           (                    ) ,
c                           (    -s(i)      c(i) )
c
c     where c(i) is double precision, the rows these rotations operate
c     on are described below.
c
c     there are two types of permutations, which are determined
c     by the value of job.
c
c     1. right circular shift (job = 1).
c
c         the columns are rearranged in the following order.
c
c                1,...,k-1,l,k,k+1,...,l-1,l+1,...,p.
c
c         u is the product of l-k rotations u(i), where u(i)
c         acts in the (l-i,l-i+1)-plane.
c
c     2. left circular shift (job = 2).
c         the columns are rearranged in the following order
c
c                1,...,k-1,k+1,k+2,...,l,k,l+1,...,p.
c
c         u is the product of l-k rotations u(i), where u(i)
c         acts in the (k+i-1,k+i)-plane.
c
c     on entry
c
c         r      double precision(ldr,p), where ldr.ge.p.
c                r contains the upper triangular factor
c                that is to be updated.  elements of r
c                below the diagonal are not referenced.
c
c         ldr    integer.
c                ldr is the leading dimension of the array r.
c
c         p      integer.
c                p is the order of the matrix r.
c
c         k      integer.
c                k is the first column to be permuted.
c
c         l      integer.
c                l is the last column to be permuted.
c                l must be strictly greater than k.
c
c         z      double precision(ldz,nz), where ldz.ge.p.
c                z is an array of nz p-vectors into which the
c                transformation u is multiplied.  z is
c                not referenced if nz = 0.
c
c         ldz    integer.
c                ldz is the leading dimension of the array z.
c
c         nz     integer.
c                nz is the number of columns of the matrix z.
c
c         job    integer.
c                job determines the type of permutation.
c                       job = 1  right circular shift.
c                       job = 2  left circular shift.
c
c     on return
c
c         r      contains the updated factor.
c
c         z      contains the updated matrix z.
c
c         c      double precision(p).
c                c contains the cosines of the transforming rotations.
c
c         s      double precision(p).
c                s contains the sines of the transforming rotations.
c
c     linpack. this version dated 08/14/78 .
c     g.w. stewart, university of maryland, argonne national lab.
c
c     dchex uses the following functions and subroutines.
c
c     blas drotg
c     fortran min0
c
      integer i,ii,il,iu,j,jj,km1,kp1,lmk,lm1
      double precision rjp1j,t
c
c     initialize
c
      km1 = k - 1
      kp1 = k + 1
      lmk = l - k
      lm1 = l - 1
c
c     perform the appropriate task.
c
      go to (10,130), job
c
c     right circular shift.
c
   10 continue
c
c        reorder the columns.
c
         do 20 i = 1, l
            ii = l - i + 1
            s(i) = r(ii,l)
   20    continue
         do 40 jj = k, lm1
            j = lm1 - jj + k
            do 30 i = 1, j
               r(i,j+1) = r(i,j)
   30       continue
            r(j+1,j+1) = 0.0d0
   40    continue
         if (k .eq. 1) go to 60
            do 50 i = 1, km1
               ii = l - i + 1
               r(i,k) = s(ii)
   50       continue
   60    continue
c
c        calculate the rotations.
c
         t = s(1)
         do 70 i = 1, lmk
            call drotg(s(i+1),t,c(i),s(i))
            t = s(i+1)
   70    continue
         r(k,k) = t
         do 90 j = kp1, p
            il = max0(1,l-j+1)
            do 80 ii = il, lmk
               i = l - ii
               t = c(ii)*r(i,j) + s(ii)*r(i+1,j)
               r(i+1,j) = c(ii)*r(i+1,j) - s(ii)*r(i,j)
               r(i,j) = t
   80       continue
   90    continue
c
c        if required, apply the transformations to z.
c
         if (nz .lt. 1) go to 120
         do 110 j = 1, nz
            do 100 ii = 1, lmk
               i = l - ii
               t = c(ii)*z(i,j) + s(ii)*z(i+1,j)
               z(i+1,j) = c(ii)*z(i+1,j) - s(ii)*z(i,j)
               z(i,j) = t
  100       continue
  110    continue
  120    continue
      go to 260
c
c     left circular shift
c
  130 continue
c
c        reorder the columns
c
         do 140 i = 1, k
            ii = lmk + i
            s(ii) = r(i,k)
  140    continue
         do 160 j = k, lm1
            do 150 i = 1, j
               r(i,j) = r(i,j+1)
  150       continue
            jj = j - km1
            s(jj) = r(j+1,j+1)
  160    continue
         do 170 i = 1, k
            ii = lmk + i
            r(i,l) = s(ii)
  170    continue
         do 180 i = kp1, l
            r(i,l) = 0.0d0
  180    continue
c
c        reduction loop.
c
         do 220 j = k, p
            if (j .eq. k) go to 200
c
c              apply the rotations.
c
               iu = min0(j-1,l-1)
               do 190 i = k, iu
                  ii = i - k + 1
                  t = c(ii)*r(i,j) + s(ii)*r(i+1,j)
                  r(i+1,j) = c(ii)*r(i+1,j) - s(ii)*r(i,j)
                  r(i,j) = t
  190          continue
  200       continue
            if (j .ge. l) go to 210
               jj = j - k + 1
               t = s(jj)
               call drotg(r(j,j),t,c(jj),s(jj))
  210       continue
  220    continue
c
c        apply the rotations to z.
c
         if (nz .lt. 1) go to 250
         do 240 j = 1, nz
            do 230 i = k, lm1
               ii = i - km1
               t = c(ii)*z(i,j) + s(ii)*z(i+1,j)
               z(i+1,j) = c(ii)*z(i+1,j) - s(ii)*z(i,j)
               z(i,j) = t
  230       continue
  240    continue
  250    continue
  260 continue
      return
      end


MODULE VTMOP_FUNC_MOD

CONTAINS

SUBROUTINE CONVEX(X, F, IFLAG)
! Multiobjective test function whose component functions are each
! quadratics. Let D denote the number of design variables and let P
! denote the number of objectives. Then D must be greater than P >= 2,
! and the recommended bounds are 0 < X(:) < 1. Both D and P are
! assumed based on the dimensions of X(:) and F(:).
!
! For I = 1, ..., P, F(I) = ||X - 0.5e_I - 0.1e||^2, where e_I is the Ith
! standard basis vector and e = (1, ..., 1).
!
!
! On input:
!
! X(:) is a real valued design point in R^D.
!
!
! On output:
!
! P(:) is a real valued objective point P = F(X).
!
! IFLAG is an error flag. With the following error codes:
!     0 : Successful evaluation of DTLZ3
!    -1 : The design dimension D is not legal
!    -2 : The objective dimension P is not legal
!
USE REAL_PRECISION, ONLY : R8
IMPLICIT NONE
! Input parameters.
REAL(KIND=R8), INTENT(IN) :: X(:) ! Input design vector.
REAL(KIND=R8), INTENT(OUT) :: F(:) ! Output objective vector.
INTEGER, INTENT(OUT) :: IFLAG ! Error flag.
! Local variables.
INTEGER :: D, P ! Problem dimensions.
INTEGER :: I ! Loop indexing variables.
REAL(KIND=R8) :: E(SIZE(X,1)) ! Vector of standard basis vectors.
! Get problem dimensions.
D = SIZE(X,1)
P = SIZE(F,1)
! Throw errors for illegal inputs.
IFLAG = 0
IF (D < 1) THEN
   IFLAG = -1
   RETURN
END IF
IF (D < P) THEN
   IFLAG = -2
   RETURN
END IF
! Compute each component function.
DO I = 1, P
   ! Set E(:) = 0.5e_I + 0.1e.
   E(:) = 0.1_R8
   E(I) = 0.6_R8
   ! Compute the value of F(I).
   F(I) = DOT_PRODUCT(X(:) - E(:), X(:) - E(:))
END DO
RETURN
END SUBROUTINE CONVEX

SUBROUTINE DTLZ1(X, F, IFLAG)
! Multiobjective test function with a planar Pareto front. Let D
! denote the number of design variables and let P denote the number
! of objectives. Then it is a requirement that D >= P >= 2, and
! the recommended bounds are 0 < X(:) < 1. Both D and P are
! assumed based on the dimensions of X(:) and F(:).
!
! Credit for the design of this test function goes to
!
! K. Deb, L. Thiele, M. Laumanns, and E. Zitzler. 2005. Scalable test
! problems for evolutionary multiobjective optimization. In Evolutionary
! multiobjective optimization (pp. 105-145). Springer, London.
!
!
! On input:
!
! X(:) is a real valued design point in R^D.
!
!
! On output:
!
! P(:) is a real valued objective point P = F(X).
!
! IFLAG is an error flag. With the following error codes:
!     0 : Successful evaluation of DTLZ3
!    -1 : The design dimension D is not legal
!    -2 : The objective dimension P is not legal
!
USE REAL_PRECISION, ONLY : R8
IMPLICIT NONE
! Input parameters.
REAL(KIND=R8), INTENT(IN) :: X(:) ! Input design vector.
REAL(KIND=R8), INTENT(OUT) :: F(:) ! Output objective vector.
INTEGER, INTENT(OUT) :: IFLAG ! Error flag.
! Local variables.
INTEGER :: D, P ! Problem dimensions.
INTEGER :: I, J ! Loop indexing variables.
REAL(KIND=R8) :: PI ! Constant value of pi.
! Get problem dimensions.
D = SIZE(X,1)
P = SIZE(F,1)
! Compute the value of PI.
PI = 4.0_R8 * ATAN(1.0_R8)
! Throw errors for illegal inputs.
IFLAG = 0
IF (D < 1) THEN
   IFLAG = -1
   RETURN
END IF
IF (D < P) THEN
   IFLAG = -2
   RETURN
END IF
! Get the first objective value.
F(1) = 0.5_R8 * (1.0_R8 + G(X))
DO J = 1, P-1
   F(1) = F(1) * X(J)
END DO
! Get other objective values.
DO I = 2, P
   F(I) = 0.5_R8 * (1.0_R8 + G(X)) * (1.0_R8 - X(P-I+1))
   DO J = 1, P-I
      F(I) = F(I) * X(J)
   END DO
END DO
RETURN

CONTAINS

FUNCTION G(Z)
! A scalar valued kernel function G_2, which produces many local Pareto
! fonts in the landscape of DTLZ1.
! Parameters.
REAL(KIND=R8), INTENT(IN) :: Z(:) ! Input vector.
REAL(KIND=R8) :: G ! Output scalar.
! Local variables.
INTEGER :: K
! Compute the kernel function G(Z) for DTLZ1.
G = 2.0_R8 * ( REAL(D-P,KIND=R8) + 1.0_R8 + &
                 DOT_PRODUCT(Z(P:D) - 0.6_R8, Z(P:D) - 0.6_R8) )
DO K = P, D
   G = G - 2.0_R8 * COS(20.0_R8 * PI * (Z(K) - 0.6_R8))
END DO
RETURN
END FUNCTION G

END SUBROUTINE DTLZ1

SUBROUTINE DTLZ2(X, F, IFLAG)
! Multiobjective test function with a concave global Pareto front, shaped
! like the unit sphere restricted to the positive orthant. Let D denote the
! number of design variables and let P denote the number of objectives.
! Then it is a requirement that D >= P >= 2, and the recommended bounds
! are 0 < X(:) < 1. Both D and P are assumed based on the dimensions
! of X(:) and F(:).
!
! Credit for the design of this test function goes to
!
! K. Deb, L. Thiele, M. Laumanns, and E. Zitzler. 2005. Scalable test
! problems for evolutionary multiobjective optimization. In Evolutionary
! multiobjective optimization (pp. 105-145). Springer, London.
!
!
! On input:
!
! X(:) is a real valued design point in R^D.
!
!
! On output:
!
! P(:) is a real valued objective point P = F(X).
!
! IFLAG is an error flag. With the following error codes:
!     0 : Successful evaluation of DTLZ3
!    -1 : The design dimension D is not legal
!    -2 : The objective dimension P is not legal
!
USE REAL_PRECISION, ONLY : R8
IMPLICIT NONE
! Input parameters.
REAL(KIND=R8), INTENT(IN) :: X(:) ! Input design vector.
REAL(KIND=R8), INTENT(OUT) :: F(:) ! Output objective vector.
INTEGER, INTENT(OUT) :: IFLAG ! Error flag.
! Local variables.
INTEGER :: D, P ! Problem dimensions.
INTEGER :: I, J ! Loop indexing variables.
REAL(KIND=R8) :: PI ! Constant value of pi.
! Get problem dimensions.
D = SIZE(X,1)
P = SIZE(F,1)
! Compute the value of PI.
PI = 4.0_R8 * ATAN(1.0_R8)
! Throw errors for illegal inputs.
IFLAG = 0
IF (D < 1) THEN
   IFLAG = -1
   RETURN
END IF
IF (D < P) THEN
   IFLAG = -2
   RETURN
END IF
! Get the first objective value.
F(1) = 1.0_R8 + G(X)
DO J = 1, P-1
   F(1) = F(1) * COS(PI * X(J) / 2.0_R8)
END DO
! Get other objective values.
DO I = 1, P-1
   F(I+1) = (1.0_R8 + G(X)) * SIN(PI * X(P-I) / 2.0_R8)
   DO J = 1, P-I-1
      F(I+1) = F(I+1) * COS(PI * X(J) / 2.0_R8)
   END DO
END DO
!IF (F(P) < 0.1_R8) IFLAG = -1 ! Tests taboo list when uncommented.
RETURN

CONTAINS

FUNCTION G(Z)
! A scalar valued kernel function G, which produces a single global/local
! Pareto front for DTLZ2.
! Parameters.
REAL(KIND=R8), INTENT(IN) :: Z(:) ! Input vector.
REAL(KIND=R8) :: G ! Output scalar.
! Compute the kernel function G(Z) for DTLZ3.
G = DOT_PRODUCT(Z(P:D) - 0.6_R8, Z(P:D) - 0.6_R8)
RETURN
END FUNCTION G

END SUBROUTINE DTLZ2

SUBROUTINE DTLZ3(X, F, IFLAG)
! Multiobjective test function with a concave global Pareto front, shaped
! like the unit sphere restricted to the positive orthant. Let D denote the
! number of design variables and let P denote the number of objectives.
! Then it is a requirement that D >= P >= 2, and the recommended bounds
! are 0 < X(:) < 1. Both D and P are assumed based on the dimensions
! of X(:) and F(:). There are 3^(1+P-D)-1 local Pareto fronts, where
! a multiobjective optimization algorithm could get stuck.
!
! Credit for the design of this test function goes to
!
! K. Deb, L. Thiele, M. Laumanns, and E. Zitzler. 2005. Scalable test
! problems for evolutionary multiobjective optimization. In Evolutionary
! multiobjective optimization (pp. 105-145). Springer, London.
!
!
! On input:
!
! X(:) is a real valued design point in R^D.
!
!
! On output:
!
! P(:) is a real valued objective point P = F(X).
!
! IFLAG is an error flag. With the following error codes:
!     0 : Successful evaluation of DTLZ3
!    -1 : The design dimension D is not legal
!    -2 : The objective dimension P is not legal
!
USE REAL_PRECISION, ONLY : R8
IMPLICIT NONE
! Input parameters.
REAL(KIND=R8), INTENT(IN) :: X(:) ! Input design vector.
REAL(KIND=R8), INTENT(OUT) :: F(:) ! Output objective vector.
INTEGER, INTENT(OUT) :: IFLAG ! Error flag.
! Local variables.
INTEGER :: D, P ! Problem dimensions.
INTEGER :: I, J ! Loop indexing variables.
REAL(KIND=R8) :: PI ! Constant value of pi.
! Get problem dimensions.
D = SIZE(X,1)
P = SIZE(F,1)
! Compute the value of PI.
PI = 4.0_R8 * ATAN(1.0_R8)
! Throw errors for illegal inputs.
IFLAG = 0
IF (D < 1) THEN
   IFLAG = -1
   RETURN
END IF
IF (D < P) THEN
   IFLAG = -2
   RETURN
END IF
! Get the first objective value.
F(1) = 1.0_R8 + G(X)
DO J = 1, P-1
   F(1) = F(1) * COS(PI * X(J) / 2.0_R8)
END DO
! Get other objective values.
DO I = 1, P-1
   F(I+1) = (1.0_R8 + G(X)) * SIN(PI * X(P-I) / 2.0_R8)
   DO J = 1, P-I-1
      F(I+1) = F(I+1) * COS(PI * X(J) / 2.0_R8)
   END DO
END DO
!IF (F(P) < 0.1_R8) IFLAG = -1 ! Tests taboo list when uncommented.
RETURN

CONTAINS

FUNCTION G(Z)
! A scalar valued kernel function G, which produces many local Pareto
! fonts in the landscape of DTLZ3.
! Parameters.
REAL(KIND=R8), INTENT(IN) :: Z(:) ! Input vector.
REAL(KIND=R8) :: G ! Output scalar.
! Local variables.
INTEGER :: K
! Compute the kernel function G(Z) for DTLZ3.
G = 2.0_R8 * ( REAL(D-P,KIND=R8) + 1.0_R8 + &
                 DOT_PRODUCT(Z(P:D) - 0.6_R8, Z(P:D) - 0.6_R8) )
DO K = P, D
   G = G - 2.0_R8 * COS(20.0_R8 * PI * (Z(K) - 0.6_R8))
END DO
RETURN
END FUNCTION G

END SUBROUTINE DTLZ3

SUBROUTINE DTLZ5(X, F, IFLAG)
! Multiobjective test function with a 2D concave global Pareto curve,
! embedded in a higher-dimensional objective space. Let D denote the
! number of design variables and let P denote the number of objectives.
! Then it is a requirement that D >= P >= 2, and the recommended bounds
! are 0 < X(:) < 1. Both D and P are assumed based on the dimensions
! of X(:) and F(:).
!
! Credit for the design of this test function goes to
!
! K. Deb, L. Thiele, M. Laumanns, and E. Zitzler. 2005. Scalable test
! problems for evolutionary multiobjective optimization. In Evolutionary
! multiobjective optimization (pp. 105-145). Springer, London.
!
!
! On input:
!
! X(:) is a real valued design point in R^D.
!
!
! On output:
!
! P(:) is a real valued objective point P = F(X).
!
! IFLAG is an error flag. With the following error codes:
!     0 : Successful evaluation of DTLZ3
!    -1 : The design dimension D is not legal
!    -2 : The objective dimension P is not legal
!
USE REAL_PRECISION, ONLY : R8
IMPLICIT NONE
! Input parameters.
REAL(KIND=R8), INTENT(IN) :: X(:) ! Input design vector.
REAL(KIND=R8), INTENT(OUT) :: F(:) ! Output objective vector.
INTEGER, INTENT(OUT) :: IFLAG ! Error flag.
! Local variables.
INTEGER :: D, P ! Problem dimensions.
INTEGER :: I, J ! Loop indexing variables.
REAL(KIND=R8) :: GX ! Kernel function value.
REAL(KIND=R8) :: PI ! Constant value of pi.
REAL(KIND=R8) :: THETA(SIZE(F,1)-1) ! Vector of auxiliary variables.
! Get problem dimensions.
D = SIZE(X,1)
P = SIZE(F,1)
! Compute the value of PI.
PI = 4.0_R8 * ATAN(1.0_R8)
! Throw errors for illegal inputs.
IFLAG = 0
IF (D < 1) THEN
   IFLAG = -1
   RETURN
END IF
IF (D < P) THEN
   IFLAG = -2
   RETURN
END IF
! Compute the kernel function value.
GX = DOT_PRODUCT(X(P:D)-0.6_R8, X(P:D)-0.6_R8)
! Compute the first objective value and the auxiliary variables.
THETA(1) = PI * X(1) / 2.0_R8
F(1) = (1.0_R8 + GX) * COS(THETA(1))
DO J = 2, P-1
   ! Compute the auxiliary variable THETA(J).
   THETA(J) = (PI / 2.0_R8) * (1.0_R8 + 2.0_R8 * GX * X(J)) / &
              (2.0_R8 * (1.0_R8 + GX))
   ! Use THETA(J) to compute the first objective function.
   F(1) = F(1) * COS(THETA(J))
END DO
! Compute the remaining objective values.
DO I = 1, P-1
   F(I+1) = (1.0_R8 + GX) * SIN(THETA(P-I))
   DO J = 1, P-I-1
      F(I+1) = F(I+1) * COS(THETA(J))
   END DO
END DO
RETURN
END SUBROUTINE DTLZ5

SUBROUTINE DTLZ7(X, F, IFLAG)
! Multiobjective test function with a discontinuous Pareto front. Let D
! denote the number of design variables and let P denote the number of
! objectives. Then it is a requirement that D >= P >= 2, and the
! recommended bounds are 0 < X(:) < 1. Both D and P are assumed based
! on the dimensions of X(:) and F(:).
!
! Credit for the design of this test function goes to
!
! K. Deb, L. Thiele, M. Laumanns, and E. Zitzler. 2005. Scalable test
! problems for evolutionary multiobjective optimization. In Evolutionary
! multiobjective optimization (pp. 105-145). Springer, London.
!
!
! On input:
!
! X(:) is a real valued design point in R^D.
!
!
! On output:
!
! P(:) is a real valued objective point P = F(X).
!
! IFLAG is an error flag. With the following error codes:
!     0 : Successful evaluation of DTLZ3
!    -1 : The design dimension D is not legal
!    -2 : The objective dimension P is not legal
!
USE REAL_PRECISION, ONLY : R8
IMPLICIT NONE
! Input parameters.
REAL(KIND=R8), INTENT(IN) :: X(:) ! Input design vector.
REAL(KIND=R8), INTENT(OUT) :: F(:) ! Output objective vector.
INTEGER, INTENT(OUT) :: IFLAG ! Error flag.
! Local variables.
INTEGER :: D, P ! Problem dimensions.
INTEGER :: I ! Loop indexing variables.
REAL(KIND=R8) :: GX ! Value of kernel function G(X).
REAL(KIND=R8) :: HX ! Value of kernel function H(X).
REAL(KIND=R8) :: PI ! Constant value of pi.
! Get problem dimensions.
D = SIZE(X,1)
P = SIZE(F,1)
! Compute the value of PI.
PI = 4.0_R8 * ATAN(1.0_R8)
! Throw errors for illegal inputs.
IFLAG = 0
IF (D < 1) THEN
   IFLAG = -1
   RETURN
END IF
IF (D < P) THEN
   IFLAG = -2
   RETURN
END IF
! Compute the kernel functions G and H.
GX = 1.0_R8 + 9.0_R8 * SUM(ABS(X(P:D)-0.6_R8), DIM=1) / (REAL(D-P+1, KIND=R8))
HX = REAL(P, KIND=R8)
DO I = 1, P-1
   HX = HX - ( (X(I) / (1.0_R8 + GX)) * (1.0_R8 + SIN(3.0_R8 * PI * X(I))) )
END DO
! Compute the first M-1 objective values.
DO I = 1, P-1
   F(I) = X(I)
END DO
! Compute the final objective value.
F(P) = (1.0_R8 + GX) * HX
RETURN
END SUBROUTINE DTLZ7

END MODULE VTMOP_FUNC_MOD


      subroutine fadpt(x,y,z,mat,nvec,time,f)
C #####################################################################
C
C     PURPOSE -
C
C        Adaption function for smoothing algorithms.  This is the
C        'gyroscope' function wherein the function has large
C        second derivatives near each of three rings in the
C        three coordinate planes.
C
C     INPUT ARGUMENTS -
C
C        X,Y,Z - Input spatial coordinate arrays.
C        MAT - Material type arrays.  (This is for cases where the
C              function value depends BOTH on position and material
C              type.)
C        NV - Length of spatial arrays.  (Evaluate function at each
C             spatial coordinate.)
C        TIME  - Current time (for time dependent adaption).
C
C     OUTPUT ARGUMENTS -
C
C        F - Array of adaption function values.
C
C     CHANGE HISTORY -
C
C ######################################################################
      implicit none

      integer lenptr
      parameter (lenptr=1000000)

      real*8 x(lenptr),y(lenptr),z(lenptr),f(lenptr)
      integer nvec, i, mat(lenptr)
      real*8 r0,z0,epssq,r,dsq,x0,y0,time

c.... Radius of rings

      r0=0.5

c.... Center of rings

      x0=0.
      y0=0.
      z0=0.

c.... Square of epsilon.  The function does not go to infinity
c.... on the ring because epsilon is nonzero.  More precisely, the
c.... function is
c....                      f(x,y,z)=1/( d(x,y,z)**2 +epsilon**2 ).
c....
c.... That is, the function is 1 divided by the smallest distance
c.... to any of the three rings (squared) plus epsilon squared.
c.... This implies that the 'characteristic length' of the function
c.... AT each of the rings is epsilon.

      epssq=.1**2

c.... Loop over vector of input values and compute function values.

      do i=1,nvec

         r=sqrt(x(i)**2+y(i)**2)
         dsq=(r-r0)**2+(z(i)-z0)**2

         r=sqrt(y(i)**2+z(i)**2)
         dsq=min(dsq,(r-r0)**2+(x(i)-x0)**2)

         r=sqrt(z(i)**2+x(i)**2)
         dsq=min(dsq,(r-r0)**2+(y(i)-y0)**2)

         f(i)=1./(dsq+epssq)

      enddo

      return
      end


C 2 JAN 95 ...CRI... MSTP S/W CONVERSION (VICAR PORTING)
C
      INCLUDE 'VICMAIN_FOR'
      SUBROUTINE MAIN44
C  IBIS ROUTINE IBISREGR
C
C  PURPOSE:
C	IBISREGR PERFORMS A SERIES OF MULTIPLE REGRESSION ANALYSES
C       ON VARIOUS COMBINATIONS OF COLUMNS IN AN IBIS TABULAR FILE,
C       SEARCHING FOR OPTIMAL FITS.

C  THIS PROGRAM IS BASED ON PROGRAM 'IBISSTAT'

	IMPLICIT NONE

	INTEGER	MAXCOLLEN, MAXTOTLEN, MAXCOLS, MAXSOLNS
	PARAMETER( MAXCOLLEN = 500, MAXTOTLEN=10000, MAXCOLS=40)
	PARAMETER( MAXSOLNS = 20)

	INTEGER	UNIT, OUTUNIT, STATUS, COUNT, DEF, IBIS, OUTIBIS
	INTEGER	CLEN, NCOL, NINCOLS, MAXINCOLS, MININC, MAXINC
	INTEGER INCOLNO(MAXCOLS), INCOLS(MAXCOLS), TEMP(2)
	INTEGER BESTCOLS(MAXCOLS,MAXSOLNS), MBEST(MAXSOLNS)
	INTEGER	I, J, K, M, N, BUFPTR, DEPCOL, ERR, IPIV(MAXCOLS+1)
	INTEGER	NBEST, NBEST1, ICOL, JCOL

	REAL ALLDATA(MAXCOLLEN,MAXCOLS), OUTDATA(MAXCOLLEN)
	REAL DATA(MAXTOTLEN), DATA2(MAXTOTLEN)
	REAL RESID(MAXCOLLEN), BESTRES( MAXCOLLEN, MAXSOLNS)
	REAL DEPDATA(MAXCOLLEN), DEPDATA2(MAXCOLLEN), WORK(MAXTOTLEN)
	REAL BESTRSQ(MAXSOLNS), BESTSIG(MAXSOLNS)
	REAL SOLUTION(MAXCOLS+1), BESTSOL( MAXCOLS+1, MAXSOLNS)
	REAL INTERVALS(MAXCOLS+1), SSR, RSQUARED, SEE, EPSILON

	LOGICAL NOPRINT, XVPTST, EITHER, BOTH, RSONLY, SDONLY

	CHARACTER*8  COLNAMES(MAXCOLS), DEPNAME
	CHARACTER*80 STRING
	CHARACTER*16 FSTR,TMP1,TMP2

C---------------------------------------------------------------------
        CALL IFMESSAGE('IBISREGR version 2-JAN-95')
        CALL XVEACTION('SA',' ')

	NOPRINT = XVPTST( 'NOPRINT')
	BOTH = XVPTST( 'BOTH')
	EITHER = XVPTST( 'EITHER')
	RSONLY = XVPTST( 'RSQUARED')
	SDONLY = XVPTST( 'STDERR')

C		OPEN IBIS INTERFACE FILE
        CALL XVUNIT(UNIT, 'INP', 1, STATUS, ' ')

	CALL IBIS_FILE_OPEN(UNIT,IBIS,'READ',0,0,' ',' ',STATUS)
        IF (STATUS.NE.1) CALL IBIS_SIGNAL_U(UNIT,STATUS,1)
        CALL IBIS_FILE_GET(IBIS,'NC',NCOL,1,1)
        CALL IBIS_FILE_GET(IBIS,'NR',CLEN,1,1)

	N = CLEN
	IF (N .LT. 2)  CALL MABEND('COLUMN LENGTH TOO SHORT')
	IF (N .GT. MAXCOLLEN)  CALL MABEND('COLUMN LENGTH TOO LONG')

	CALL XVPARM( 'COLNAMES', COLNAMES, COUNT, DEF, MAXCOLS)
	DO I = COUNT+1, NCOL
	    IF (I.LE.9) THEN
		WRITE( COLNAMES(I), '(A6,I1)') 'COLUMN', I
	    ELSE
		WRITE( COLNAMES(I), '(A6,I2)') 'COLUMN', I
	    ENDIF
	ENDDO

C  GET THE DATA FOR THE DEPENDANT VARIABLE:
	CALL XVPARM( 'DEPCOL', DEPCOL, COUNT, DEF, 1)
	IF (COUNT.EQ.0) DEPCOL = NCOL
	CALL XVPARM( 'DEPNAME', DEPNAME, COUNT, DEF, 1)
	IF (COUNT.EQ.0) DEPNAME = COLNAMES(DEPCOL)
	CALL IBIS_COLUMN_READ(IBIS,DEPDATA,DEPCOL,1,CLEN,STATUS)
        IF (STATUS.NE.1) CALL IBIS_SIGNAL(IBIS,STATUS,1)

C  COLUMNS TO SEARCH THROUGH FOR INDEPENDENT VARIABLES:
	CALL XVPARM( 'COLS', INCOLNO, MAXINCOLS, DEF, MAXCOLS)
	IF (MAXINCOLS.EQ.0) THEN
	  MAXINCOLS = NCOL-1
	  J = 0
	  DO I = 1,NCOL
	    IF (I.NE.DEPCOL) THEN
	      J = J+1
	      INCOLNO(J) = I
	    ENDIF
	  ENDDO
	ENDIF

C  GET MINIMUM/MAXIMUM NUMBER OF COLUMN COMBINATIONS TO TRY:
	CALL XVPARM( 'COLRANGE', TEMP, COUNT, DEF, 2)
	IF (COUNT.EQ.0) THEN
	  MININC = 2
	  MAXINC = MAXINCOLS
        ELSE
	  MININC = TEMP(1)
	  MAXINC = TEMP(2)
	ENDIF
	IF (MAXINC.GT.MAXINCOLS) CALL MABEND('RANGE TOO HIGH')

	IF ((MAXINCOLS+1)*N .GT. MAXTOTLEN)
     +			CALL MABEND('TOO MUCH DATA FOR BUFFER')
	IF (N .LT. MAXINC+1)  CALL MABEND('NOT ENOUGH ROWS OF DATA')

C  READ ALL THE COLUMN DATA TO BE SEARCHED INTO WORKING BUFFER:
	DO I = 1,MAXINCOLS
	   CALL IBIS_COLUMN_READ(IBIS,ALLDATA(1,I),INCOLNO(I),
     +                           1,N,STATUS)
           IF (STATUS.NE.1) CALL IBIS_SIGNAL(IBIS,STATUS,1)
	ENDDO

	CALL XVPARM( 'NBEST', NBEST, I, DEF, 1)
	IF (NBEST.GT.MAXSOLNS) CALL MABEND('NBEST TOO BIG')

	CALL XVMESSAGE('MULTIPLE REGRESSION SEARCH',' ')
	WRITE( STRING, '(2A)') 'DEPENDENT VARIABLE: ', DEPNAME
	CALL XVMESSAGE(STRING,' ')

C  START LOOPING OVER ALL POSSIBLE COMBINATIONS OF BETWEEN 'MININC'
C  AND 'MAXINC' COLUMNS.  WE MUST STORE THE 'NBEST' BEST SOLUTIONS.
	DO I = 1,NBEST
	  BESTRSQ(I) = -1.E30
	  BESTSIG(I) = 1.E30
	ENDDO

C  OUTERMOST LOOP IS OVER THE NUMBER OF COLUMNS, 'NINCOLS', WHICH VARIES
C   FROM 'MININC' TO 'MAXINC'.
C  THEN WE LOOP OVER THE COMBINATIONS OF COLUMNS, VARYING THE LAST
C   ONE MOST RAPIDLY AND THE FIRST ONE LEAST RAPIDLY.  (THIS CORRESPONDS
C   TO 'NINCOLS' EMBEDDED DO-LOOPS.)

	NINCOLS = MININC
100	DO I = 1,NINCOLS			! BEGIN LOOP OVER # COLUMNS
	  INCOLS(I) = I
	ENDDO

C  BEGIN LOOP OVER COLUMNS:
C  PERFORM LEAST-SQS FIT FOR CURRENT 'INCOLS' COMBINATION:
200	IF (.NOT. NOPRINT) THEN
	  CALL XVMESSAGE(' ',' ')
	  WRITE( STRING, '(A6)') 'COLS: '
          J=7
     	  DO I=1,NINCOLS
	     WRITE(STRING(J+3*(I-1):J+3*(I-1)+2),'(I3)')
     *              INCOLNO(INCOLS(I))
          ENDDO
	  CALL XVMESSAGE(STRING,' ')
	ENDIF

	DO I = 1, N
	  DATA(I) = 1.0
	ENDDO
	DO I = 1, NINCOLS
	  BUFPTR = I*N + 1
	  CALL MVE( 7, N, ALLDATA(1,INCOLS(I)), DATA(BUFPTR),1,1)
	ENDDO
	M = NINCOLS + 1

	DO I = 1, N*M
	  DATA2(I) = DATA(I)
	ENDDO
	DO I = 1, N
	  DEPDATA2(I) = DEPDATA(I)
	ENDDO

	EPSILON = 1.0E-7
	CALL LLSQ( DATA2, DEPDATA2, N, M, 1,
     +			SOLUTION, IPIV, EPSILON, ERR, WORK)
	IF (ERR.NE.0) CALL MABEND('** COLUMNS ARE DEPENDENT **')
	SSR = WORK(1)

	CALL CALCRES( DATA, DEPDATA, SOLUTION, RESID, N, M, SSR)

	CALL REGSTAT (DATA, DEPDATA, N, M, SSR, SEE, RSQUARED, INTERVALS)

	IF (.NOT. NOPRINT) THEN
	  CALL XVMESSAGE(' ',' ')
	  WRITE (STRING, '(A)')
     +			' VARIABLE     COEFFICIENT         ERROR'
	  CALL XVMESSAGE(STRING,' ')
          TMP1=FSTR(SOLUTION(1),12,6)
          TMP2=FSTR(INTERVALS(1),12,6)
	  WRITE (STRING, '(A,3X,A12,3X,A12)') '  CONSTANT', TMP1,TMP2
	  CALL XVMESSAGE(STRING,' ')
	  DO I = 2, M
             TMP1=FSTR(SOLUTION(I),12,6)
             TMP2=FSTR(INTERVALS(I),12,6)
	     WRITE (STRING, '(2X,A,3X,A12,3X,A12)')
     +		    COLNAMES( INCOLNO(INCOLS(I-1))), TMP1,TMP2
	     CALL XVMESSAGE(STRING,' ')
	  ENDDO
	  CALL XVMESSAGE(' ',' ')
	  WRITE (STRING, '(A,F7.4)') 'R SQUARED = ', RSQUARED
	  CALL XVMESSAGE(STRING,' ')
          TMP1=FSTR(SEE,11,4)
	  WRITE (STRING, '(A,A11)') 'STD ERR OF EST = ', TMP1
	  CALL XVMESSAGE(STRING,' ')
	ENDIF

C  SEE IF THIS IS ONE OF THE 'NBEST' SOLUTIONS:
	DO I = 1,NBEST
	  IF ( (BOTH .AND. RSQUARED.GT.BESTRSQ(I) .AND.
     &        SEE.LT.BESTSIG(I))
     &	  .OR. (EITHER .AND. (RSQUARED.GT.BESTRSQ(I) .OR.
     &	        SEE.LT.BESTSIG(I)))
     &	  .OR. (RSONLY .AND. RSQUARED.GT.BESTRSQ(I))
     &	  .OR. (SDONLY .AND. SEE.LT.BESTSIG(I))) THEN
	    GO TO 300
	  ENDIF
	ENDDO
	GO TO 310
300	DO J = NBEST,I+1,-1
	  BESTRSQ(J) = BESTRSQ(J-1)
	  BESTSIG(J) = BESTSIG(J-1)
	  MBEST(J) = MBEST(J-1)
	  CALL MVE( 4, NINCOLS, BESTCOLS(1,J-1), BESTCOLS(1,J),1,1)
	  CALL MVE( 7, NINCOLS+1, BESTSOL(1,J-1), BESTSOL(1,J),1,1)
	  CALL MVE( 7, N, BESTRES(1,J-1), BESTRES(1,J),1,1)
	ENDDO
	BESTRSQ(I) = RSQUARED
	BESTSIG(I) = SEE
	MBEST(I) = NINCOLS+1
	DO J = 1,NINCOLS
	  BESTCOLS(J,I) = INCOLNO( INCOLS(J))
	ENDDO
	DO J = 1,NINCOLS+1
	  BESTSOL(J,I) = SOLUTION(J)
	ENDDO
	CALL MVE( 7, N, RESID, BESTRES(1,I),1,1)

310	DO ICOL = NINCOLS,1,-1
	  IF (INCOLS(ICOL) .LT. MAXINCOLS-NINCOLS+ICOL) GO TO 400
	ENDDO
	GO TO 500		! END OF ALL COMBINATIONS OF CURRENT # COL'S

400	INCOLS(ICOL) = INCOLS(ICOL)+1
	DO JCOL = ICOL+1,NINCOLS
	  INCOLS(JCOL) = INCOLS(JCOL-1)+1
	ENDDO
	GO TO 200				! END LOOP OVER COLUMNS

500	NINCOLS = NINCOLS+1			! END LOOP OVER NUMBER OF COL'S
	IF (NINCOLS.LE.MAXINC) GO TO 100

C  OUTPUT THE 'NBEST' BEST SOLUTIONS TO DISK & TERMINAL:

C  FIRST CHECK THAT THERE WERE AT LEAST 'NBEST' SOLUTIONS:
	DO I = 1,NBEST
	  IF (BESTRSQ(I).GT.0.) NBEST1 = I
	ENDDO
	NBEST = NBEST1

	CALL XVPCNT( 'OUT', COUNT)
	IF (COUNT.GE.1) THEN
C  OPEN CORRECT SIZED IBIS OUTPUT FILE
           CALL XVUNIT(OUTUNIT, 'OUT', 1, STATUS, ' ')

	   CALL IBIS_FILE_OPEN(OUTUNIT,OUTIBIS,'WRITE',3*NBEST,N,
     *                         ' ',' ',STATUS)
           IF (STATUS.NE.1) CALL IBIS_SIGNAL_U(OUTUNIT,STATUS,1)

	   DO J = 1,NBEST
              CALL IBIS_COLUMN_SET(OUTIBIS,'FORMAT','FULL',3*J-2,STATUS)
              CALL IBIS_COLUMN_WRITE(OUTIBIS,BESTCOLS(1,J),3*J-2,
     +                       2,MBEST(J)+1,status)
              IF (STATUS.NE.1) CALL IBIS_SIGNAL(OUTIBIS,STATUS,1)
	      CALL ZIA( OUTDATA, MAXINC+1)
	      DO I = 1, MBEST(J)
	         OUTDATA(I) = BESTSOL(I,J)
	      ENDDO
              CALL IBIS_COLUMN_WRITE(OUTIBIS,OUTDATA,3*J-1,
     +                       1,MBEST(J),status)
              IF (STATUS.NE.1) CALL IBIS_SIGNAL(OUTIBIS,STATUS,1)
              CALL IBIS_COLUMN_WRITE(OUTIBIS,BESTRES(1,J),3*J,
     +                       1,N,status)
              IF (STATUS.NE.1) CALL IBIS_SIGNAL(OUTIBIS,STATUS,1)
	   ENDDO
	   CALL IBIS_FILE_CLOSE(OUTIBIS,' ',STATUS)
           IF (STATUS.NE.1) CALL IBIS_SIGNAL_U(OUTUNIT,STATUS,1)
	ENDIF

        CALL XVMESSAGE(' ',' ')
	CALL XVMESSAGE('BEST SOLUTIONS FOUND:',' ')

	DO J = 1,NBEST
	  CALL XVMESSAGE(' ',' ')
	  M = MBEST(J)-1
	  WRITE( STRING, '(A6)') 'COLS: '
          K=7
     	  DO I=1,M
	     WRITE(STRING(K+3*(I-1):K+3*(I-1)+2),'(I3)') BESTCOLS(I,J)
          ENDDO
	  CALL XVMESSAGE(STRING,' ')
          TMP1=FSTR(BESTSIG(J),11,4)
	  WRITE( STRING, '(A,F7.4,A,A11)') 'R SQUARED = ', BESTRSQ(J),
     &	   '  STD ERR = ', TMP1
	  CALL XVMESSAGE(STRING,' ')
	ENDDO

	CALL IBIS_FILE_CLOSE(IBIS,' ',STATUS)
        IF (STATUS.NE.1) CALL IBIS_SIGNAL_U(UNIT,STATUS,1)

	RETURN
	END

	CHARACTER*16 FUNCTION FSTR( VALUE, FIELDWIDTH, NDECIMALS)
	IMPLICIT NONE
	REAL	VALUE
	INTEGER	FIELDWIDTH, NDECIMALS

	IF ( ABS(VALUE) .GE. 10**(FIELDWIDTH-NDECIMALS-2) .OR.
     +	    ( ABS(VALUE) .LT. 0.1**NDECIMALS .AND. VALUE .NE. 0.0) ) THEN
           IF (FIELDWIDTH .EQ. 11) THEN
	      WRITE( FSTR, '(E11.4)', ERR=100 )  VALUE
	   ELSE
	      WRITE( FSTR, '(E12.6)', ERR=100 )  VALUE
           END IF
	ELSE
           IF (FIELDWIDTH .EQ. 11) THEN
	      WRITE( FSTR, '(F11.4)', ERR=100 )  VALUE
	   ELSE
	      WRITE( FSTR, '(F12.6)', ERR=100 )  VALUE
           END IF
	ENDIF
	RETURN

100	FSTR = '****************'
	RETURN
	END

	SUBROUTINE REGSTAT(C, Y, N, M, SSR, SEE, RSQUARED, INTERVALS)
	IMPLICIT NONE
	INTEGER	N, M
	REAL	C(N,M), Y(N), SSR, SEE, RSQUARED, INTERVALS(M)
	INTEGER	I, J, K, L, ERR, WORK2(41), WORK3(41)
	REAL	A(41*41), SUM, EPS, WORK1(41)
	REAL	MEAN, SUMSQR

	SUM = 0.0
	DO I = 1, N
	    SUM = SUM + Y(I)
	ENDDO
	MEAN = SUM/N
	SUMSQR = 0.0
	DO I = 1, N
	    SUMSQR = SUMSQR + (Y(I) - MEAN)**2
	ENDDO
	RSQUARED = (SUMSQR - SSR) / SUMSQR
	SEE = SQRT(SSR/(N-M))

C		CALCULATE CONFIDENCE INTERVALS FOR THE REGRESSION COEFS
	L = 1
	DO J = 1, M
	    DO K = 1, M
		SUM = 0.0
		DO I = 1, N
		    SUM = SUM + C(I,J)*C(I,K)
		ENDDO
		A(L) = SUM
		L = L + 1
	    ENDDO
	ENDDO

	EPS = 1.0E-7
	CALL MINV (A, M, EPS, ERR, WORK1, WORK2, WORK3)
	IF (ERR .NE. 0) CALL MABEND ('SINGULAR MATRIX')

	DO K = 1, M
	    INTERVALS(K) = SEE*SQRT(A(K+M*(K-1)))
	ENDDO

	RETURN
	END

	SUBROUTINE CALCRES( A, B, X, RES, N, M, SSR)
	IMPLICIT NONE
	INTEGER	I,J,  N,M
	REAL	A(N,M), B(N), X(M), RES(N), SSR, SUM

	DO I = 1, N
	    SUM = B(I)
	    DO J = 1, M
		SUM = SUM - A(I,J)*X(J)
	    ENDDO
	    RES(I) = SUM
	ENDDO

	SSR = 0.0
	DO I = 1, N
	    SSR = SSR + RES(I)**2
	ENDDO

	RETURN
	END

      SUBROUTINE MINV( A,N,E,K,X,J2,I2)
C*     MATRIX INVERSION ROUTINE-FORMULATED BY E. G. CLAYTON
C
C      A--SQUARE ARRAY (SINGLE PRECISION) CONTAINING ORIGINAL MATRIX
C      N--ORDER OF ORIGINAL MATRIX
C      E--TEST CRITERION FOR NEAR ZERO DIVISOR
C      K--LOCATION FOR SINGULARITY OR ILL-CONDITION INDICATOR
C         K=0 =) MATRIX NONSINGULAR.
C         K=1 =) MATRIX SINGULAR (OR ILL-CONDITIONED)
C      X--A WORK VECTOR OF SIZE N
C      J2--AN INTEGER WORK VECTOR OF SIZE N
C      I2--AN INTEGER WORK VECTOR OF SIZE N
C
      DIMENSION A(N,N),X(N),J2(N),I2(N)
C
C     INITIALIZATION
C
      K=1
      I2(1)=0
      J2(1)=0
C
C     BEGIN COMPUTATION OF INVERSE
C
      DO 15 L=1,N
      L1=L-1
      IF(L1.EQ.0)L1=1
      BIGA=-1.0
C
C     LOOK FOR THE ELEMENT OF GREATEST ABSOLUTE VALUE,CHOOSING
C     ONE FROM A ROW AND COLUMN NOT PREVIOUSLY USED.
C
      DO 5 I=1,N
      DO 1 I3=1,L1
      IF(I .EQ. I2(I3))  GO TO 5
    1 CONTINUE
      DO 4 J=1,N
      DO 2 I3=1,L1
      IF(J .EQ. J2(I3))  GO TO 4
    2 CONTINUE
      AT=ABS(A(I,J))
      IF(BIGA .GE. AT)  GO TO 4
      BIGA=AT
      J1=J
      I1=I
    4 CONTINUE
    5 CONTINUE
C
C     TAG THE ROW AND COLUMN FROM WHICH THE ELEMENT IS CHOSEN.
C
      J2(L)=J1
      I2(L)=I1
      DIV=A(I1,J1)
C
C     TEST ELEMENT AGAINST ZERO CRITERION
      IF(ABS(DIV) .LE. E)  GO TO 221
C
C     PERFORM THE COMPUTATIONS
C
      OOD = 1./DIV
      DO 7 J=1,N
      A(I1,J)=A(I1,J)*OOD
    7 CONTINUE
      A(I1,J1)=OOD
      DO 11 I=1,N
      IF(I1 .EQ. I)  GO TO 11
      DO 10 J=1,N
      IF(J1 .EQ. J)  GO TO 10
      A(I,J)=A(I,J)-A(I1,J)*A(I,J1)
   10 CONTINUE
   11 CONTINUE
      DO 14 I=1,N
      IF(I1 .EQ. I)  GO TO 14
      A(I,J1)=-A(I,J1)*A(I1,J1)
   14 CONTINUE
   15 CONTINUE
C
C     COMPUTATION COMPLETE AT THIS POINT
C     UNSCRAMBLE THE INVERSE
C
      DO 18 J=1,N
      DO 16 I=1,N
      I1=I2(I)
      J1=J2(I)
      X(J1)=A(I1,J)
   16 CONTINUE
      DO 17 I=1,N
      A(I,J)=X(I)
17    CONTINUE
   18 CONTINUE
      DO 21 I=1,N
      DO 19 J=1,N
      I1=I2(J)
      J1=J2(J)
      X(I1)=A(I,J1)
   19 CONTINUE
      DO 20 J=1,N
      A(I,J)=X(J)
   20 CONTINUE
   21 CONTINUE
      K=0
  221 RETURN
      END


*> \brief \b DLARTGS generates a plane rotation designed to introduce a bulge in implicit QR iteration for the bidiagonal SVD problem.
*
*  =========== DOCUMENTATION ===========
*
* Online html documentation available at
*            http://www.netlib.org/lapack/explore-html/
*
*> \htmlonly
*> Download DLARTGS + dependencies
*>
*> [TGZ]
*>
*> [ZIP]
*>
*> [TXT]
*> \endhtmlonly
*
*  Definition:
*  ===========
*
*       SUBROUTINE DLARTGS( X, Y, SIGMA, CS, SN )
*
*       .. Scalar Arguments ..
*       DOUBLE PRECISION        CS, SIGMA, SN, X, Y
*       ..
*
*
*> \par Purpose:
*  =============
*>
*> \verbatim
*>
*> DLARTGS generates a plane rotation designed to introduce a bulge in
*> Golub-Reinsch-style implicit QR iteration for the bidiagonal SVD
*> problem. X and Y are the top-row entries, and SIGMA is the shift.
*> The computed CS and SN define a plane rotation satisfying
*>
*>    [  CS  SN  ]  .  [ X^2 - SIGMA ]  =  [ R ],
*>    [ -SN  CS  ]     [    X * Y    ]     [ 0 ]
*>
*> with R nonnegative.  If X^2 - SIGMA and X * Y are 0, then the
*> rotation is by PI/2.
*> \endverbatim
*
*  Arguments:
*  ==========
*
*> \param[in] X
*> \verbatim
*>          X is DOUBLE PRECISION
*>          The (1,1) entry of an upper bidiagonal matrix.
*> \endverbatim
*>
*> \param[in] Y
*> \verbatim
*>          Y is DOUBLE PRECISION
*>          The (1,2) entry of an upper bidiagonal matrix.
*> \endverbatim
*>
*> \param[in] SIGMA
*> \verbatim
*>          SIGMA is DOUBLE PRECISION
*>          The shift.
*> \endverbatim
*>
*> \param[out] CS
*> \verbatim
*>          CS is DOUBLE PRECISION
*>          The cosine of the rotation.
*> \endverbatim
*>
*> \param[out] SN
*> \verbatim
*>          SN is DOUBLE PRECISION
*>          The sine of the rotation.
*> \endverbatim
*
*  Authors:
*  ========
*
*> \author Univ. of Tennessee
*> \author Univ. of California Berkeley
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
*> \ingroup auxOTHERcomputational
*
*  =====================================================================
      SUBROUTINE DLARTGS( X, Y, SIGMA, CS, SN )
*
*  -- LAPACK computational routine --
*  -- LAPACK is a software package provided by Univ. of Tennessee,    --
*  -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
*
*     .. Scalar Arguments ..
      DOUBLE PRECISION        CS, SIGMA, SN, X, Y
*     ..
*
*  ===================================================================
*
*     .. Parameters ..
      DOUBLE PRECISION        NEGONE, ONE, ZERO
      PARAMETER          ( NEGONE = -1.0D0, ONE = 1.0D0, ZERO = 0.0D0 )
*     ..
*     .. Local Scalars ..
      DOUBLE PRECISION        R, S, THRESH, W, Z
*     ..
*     .. External Subroutines ..
      EXTERNAL           DLARTGP
*     ..
*     .. External Functions ..
      DOUBLE PRECISION        DLAMCH
      EXTERNAL           DLAMCH
*     .. Executable Statements ..
*
      THRESH = DLAMCH('E')
*
*     Compute the first column of B**T*B - SIGMA^2*I, up to a scale
*     factor.
*
      IF( (SIGMA .EQ. ZERO .AND. ABS(X) .LT. THRESH) .OR.
     $          (ABS(X) .EQ. SIGMA .AND. Y .EQ. ZERO) ) THEN
         Z = ZERO
         W = ZERO
      ELSE IF( SIGMA .EQ. ZERO ) THEN
         IF( X .GE. ZERO ) THEN
            Z = X
            W = Y
         ELSE
            Z = -X
            W = -Y
         END IF
      ELSE IF( ABS(X) .LT. THRESH ) THEN
         Z = -SIGMA*SIGMA
         W = ZERO
      ELSE
         IF( X .GE. ZERO ) THEN
            S = ONE
         ELSE
            S = NEGONE
         END IF
         Z = S * (ABS(X)-SIGMA) * (S+SIGMA/X)
         W = S * Y
      END IF
*
*     Generate the rotation.
*     CALL DLARTGP( Z, W, CS, SN, R ) might seem more natural;
*     reordering the arguments ensures that if Z = 0 then the rotation
*     is by PI/2.
*
      CALL DLARTGP( W, Z, SN, CS, R )
*
      RETURN
*
*     End DLARTGS
*
      END


PROGRAM MAIN
    USE QR_mod
    USE wrtmat_mod
    USE upmatrix_mod
    IMPLICIT NONE
    INTEGER(4)::m,n,i
    CHARACTER(20):: words
    REAL(4),ALLOCATABLE::A(:,:),Q(:,:),R(:,:)
    REAL(4),ALLOCATABLE::b(:,:)
    !----------------------------------------
    ! read the input file and make the matrix
    OPEN(99,FILE='input')
    DO
        READ(99,'(A80)',END=100) words
        IF(words=='m =') READ(99,*) m
        IF(words=='n =') READ(99,*) n
        IF(words=='A =') then
            ALLOCATE(A(m,n))
            DO i=1,m
                READ(99,*) A(i,1:n)
            END DO
        END IF
        IF(words=='bt=') then
            ALLOCATE(b(m,1))
            READ(99,*) b(1:m,1)
        END IF
    END DO
100 CLOSE(99)
    !----------------------------------------
    !----------------------------------------
    !do A=QR,then b=Qt*b,next x=b*R-1, print A,b,Q,R,x in the output file
    OPEN(100,file='output')
    WRITE(*,*)'A='
    WRITE(100,*)'A='
    CALL wrtmat(A)
    WRITE(*,*)'b='
    WRITE(100,*)'b='
    CALL wrtmat(b)
    ALLOCATE(Q(m,m))
    ALLOCATE(R(m,n))
    CALL makeQR(m,n,A,Q,R) !make Q,R,st A=QR
    WRITE(*,*)'R='
    WRITE(100,*)'R='
    CALL wrtmat(R)
    WRITE(*,*)'Q='
    WRITE(100,*)'Q='
    CALL wrtmat(Q)
    b=MATMUL(transpose(Q),b) !caculate b=Qt*b
    CALL upmatrix(R,b)       !CALCULATE THE Rx=b ,then b=x
    WRITE(*,*)'x='
    WRITE(100,*)'x='
    CALL wrtmat(b)
    CLOSE(100)
    !---------------------------------------
    DEALLOCATE(b)
    DEALLOCATE(A)
    DEALLOCATE(Q)
    DEALLOCATE(R)
END PROGRAM


SUBROUTINE cgamma(mo, z, w)
!-----------------------------------------------------------------------

!        EVALUATION OF THE COMPLEX GAMMA AND LOGGAMMA FUNCTIONS

!                        ---------------

!     MO IS AN INTEGER, Z A COMPLEX ARGUMENT, AND W A COMPLEX VARIABLE.

!                 W = GAMMA(Z)       IF MO = 0
!                 W = LN(GAMMA(Z))   OTHERWISE

!-----------------------------------------------------------------------
!     WRITTEN BY ALFRED H. MORRIS, JR.
!        NAVAL SURFACE WARFARE CENTER
!        DAHLGREN, VIRGINIA

!     This version, in a subset of Fortran 90, prepared by
!     Alan.Miller @ vic.cmis.csiro.au
!     http://www.ozemail.com.au/~milleraj

!     This version is accurate to within 5 in the 14th significant
!     decimal digit.
!-----------------------------------------------------------------------

IMPLICIT NONE
INTEGER, PARAMETER :: dp = SELECTED_REAL_KIND(14, 60)

INTEGER, INTENT(IN)       :: mo
COMPLEX (dp), INTENT(IN)  :: z
COMPLEX (dp), INTENT(OUT) :: w

! Local variables
COMPLEX (dp) :: eta, eta2, sum
REAL (dp), PARAMETER :: c0(12) = (/ .833333333333333E-01_dp,  &
          -.277777777777778E-02_dp, .793650793650794E-03_dp,  &
          -.595238095238095E-03_dp, .841750841750842E-03_dp,  &
          -.191752691752692E-02_dp, .641025641025641E-02_dp,  &
          -.295506535947712E-01_dp, .179644372368831_dp,      &
          -1.39243221690590_dp,     13.4028640441684_dp,      &
          -156.848284626002_dp /), pi = 3.14159265358979_dp,  &
    pi2  = 6.28318530717959_dp, alpi = 1.14472988584940_dp,  &
    hl2p = .918938533204673_dp, half = 0.5_dp
REAL (dp)  :: a, a1, a2, c, cn, cut, d, eps, et, e2t, h1, h2, s, sn, &
              s1, s2, t, t1, t2, u, u1, u2, v1, v2, w1, w2, x, y, y2
INTEGER    :: j, k, l, m, max, n, nm1
!---------------------------
!     ALPI = LOG(PI)
!     HL2P = 0.5 * LOG(2*PI)
!---------------------------

!     ****** MAX AND EPS ARE MACHINE DEPENDENT CONSTANTS.
!            MAX IS THE LARGEST POSITIVE INTEGER THAT MAY
!            BE USED, AND EPS IS THE SMALLEST REAL NUMBER
!            SUCH THAT 1.0 + EPS > 1.0.

!                      MAX = IPMPAR(3)
max = HUGE(3)
eps = EPSILON(1.0_dp)

!---------------------------
x = REAL(z, KIND=dp)
y = AIMAG(z)
IF (x < 0.0_dp) THEN
!-----------------------------------------------------------------------
!            CASE WHEN THE REAL PART OF Z IS NEGATIVE
!-----------------------------------------------------------------------
  y = ABS(y)
  t = -pi * y
  et = EXP(t)
  e2t = et * et

!     SET  A1 = (1 + E2T)/2  AND  A2 = (1 - E2T)/2

  a1 = half * (1.0_dp + e2t)
  t2 = t + t
  IF (t2 >= -0.15_dp) THEN
    a2 = -half * rexp(t2)
  ELSE
    a2 = half * (half + (half - e2t))
  END IF

!     COMPUTE SIN(PI*X) AND COS(PI*X)

  IF (ABS(x) >= MIN(REAL(MAX), 1.0_dp/eps)) GO TO 70
  k = ABS(x)
  u = x + k
  k = MOD(k,2)
  IF (u <= -half) THEN
    u = half + (half + u)
    k = k + 1
  END IF
  u = pi * u
  sn = SIN(u)
  cn = COS(u)
  IF (k == 1) THEN
    sn = -sn
    cn = -cn
  END IF

!     SET  H1 + H2*I  TO  PI/SIN(PI*Z)  OR  LOG(PI/SIN(PI*Z))

  a1 = sn * a1
  a2 = cn * a2
  a = a1 * a1 + a2 * a2
  IF (a == 0.0_dp) GO TO 70
  IF (mo == 0) THEN

    h1 = a1 / a
    h2 = -a2 / a
    c = pi * et
    h1 = c * h1
    h2 = c * h2
  ELSE

    h1 = (alpi+t) - half * LOG(a)
    h2 = -ATAN2(a2,a1)
  END IF
  IF (AIMAG(z) >= 0.0_dp) THEN
    x = 1.0_dp - x
    y = -y
  ELSE
    h2 = -h2
    x = 1.0_dp - x
  END IF
END IF
!-----------------------------------------------------------------------
!           CASE WHEN THE REAL PART OF Z IS NONNEGATIVE
!-----------------------------------------------------------------------
w1 = 0.0_dp
w2 = 0.0_dp
n = 0
t = x
y2 = y * y
a = t * t + y2
cut = 36.0_dp
IF (eps > 1.e-8_dp) cut = 16.0_dp
IF (a < cut) THEN
  IF (a == 0.0_dp) GO TO 70
  10 n = n + 1
  t = t + 1.0_dp
  a = t * t + y2
  IF (a < cut) GO TO 10

!     LET S1 + S2*I BE THE PRODUCT OF THE TERMS (Z+J)/(Z+N)

  u1 = (x*t+y2) / a
  u2 = y / a
  s1 = u1
  s2 = n * u2
  IF (n >= 2) THEN
    u = t / a
    nm1 = n - 1
    DO j = 1, nm1
      v1 = u1 + j * u
      v2 = (n-j) * u2
      c = s1 * v1 - s2 * v2
      d = s1 * v2 + s2 * v1
      s1 = c
      s2 = d
    END DO
  END IF

!     SET  W1 + W2*I = LOG(S1 + S2*I)  WHEN MO IS NONZERO

  s = s1 * s1 + s2 * s2
  IF (mo /= 0) THEN
    w1 = half * LOG(s)
    w2 = ATAN2(s2,s1)
  END IF
END IF

!     SET  V1 + V2*I = (Z - 0.5) * LOG(Z + N) - Z

t1 = half * LOG(a) - 1.0_dp
t2 = ATAN2(y,t)
u = x - half
v1 = (u*t1-half) - y * t2
v2 = u * t2 + y * t1

!     LET A1 + A2*I BE THE ASYMPTOTIC SUM

eta = CMPLX(t/a, -y/a, KIND=dp)
eta2 = eta * eta
m = 12
IF (a >= 289.0_dp) m = 6
IF (eps > 1.e-8) m = m / 2
sum = CMPLX(c0(m), 0.0_dp, KIND=dp)
l = m
DO j = 2, m
  l = l - 1
  sum = CMPLX(c0(l), 0.0_dp, KIND=dp) + sum * eta2
END DO
sum = sum * eta
a1 = REAL(sum, KIND=dp)
a2 = AIMAG(sum)
!-----------------------------------------------------------------------
!                 GATHERING TOGETHER THE RESULTS
!-----------------------------------------------------------------------
w1 = (((a1 + hl2p) - w1) + v1) - n
w2 = (a2 - w2) + v2
IF (REAL(z, KIND=dp) < 0.0_dp) GO TO 50
IF (mo == 0) THEN

!     CASE WHEN THE REAL PART OF Z IS NONNEGATIVE AND MO = 0

  a = EXP(w1)
  w1 = a * COS(w2)
  w2 = a * SIN(w2)
  IF (n == 0) GO TO 60
  c = (s1*w1 + s2*w2) / s
  d = (s1*w2 - s2*w1) / s
  w1 = c
  w2 = d
  GO TO 60
END IF

!     CASE WHEN THE REAL PART OF Z IS NONNEGATIVE AND MO IS NONZERO.
!     THE ANGLE W2 IS REDUCED TO THE INTERVAL -PI < W2 <= PI.

40 IF (w2 <= pi) THEN
  k = half - w2 / pi2
  w2 = w2 + pi2 * k
  GO TO 60
END IF
k = w2 / pi2 - half
w2 = w2 - pi2 * REAL(k+1)
IF (w2 <= -pi) w2 = pi
GO TO 60

!     CASE WHEN THE REAL PART OF Z IS NEGATIVE AND MO IS NONZERO

50 IF (mo /= 0) THEN
  w1 = h1 - w1
  w2 = h2 - w2
  GO TO 40
END IF

!     CASE WHEN THE REAL PART OF Z IS NEGATIVE AND MO = 0

a = EXP(-w1)
t1 = a * COS(-w2)
t2 = a * SIN(-w2)
w1 = h1 * t1 - h2 * t2
w2 = h1 * t2 + h2 * t1
IF (n /= 0) THEN
  c = w1 * s1 - w2 * s2
  d = w1 * s2 + w2 * s1
  w1 = c
  w2 = d
END IF

!     TERMINATION

60 w = CMPLX(w1, w2, KIND=dp)
RETURN
!-----------------------------------------------------------------------
!             THE REQUESTED VALUE CANNOT BE COMPUTED
!-----------------------------------------------------------------------
70 w = (0.0_dp, 0.0_dp)
RETURN

CONTAINS

FUNCTION rexp(x) RESULT(fn_val)
!-----------------------------------------------------------------------
!            EVALUATION OF THE FUNCTION EXP(X) - 1
!-----------------------------------------------------------------------
REAL (dp), INTENT(IN) :: x
REAL (dp)             :: fn_val

! Local variables
REAL (dp), PARAMETER           :: p1 =  .914041914819518E-09_dp,  &
    p2 = .238082361044469E-01_dp, q1 = -.499999999085958_dp,      &
    q2 = .107141568980644_dp,     q3 = -.119041179760821E-01_dp,  &
    q4 = .595130811860248E-03_dp
REAL (dp) :: e
!-----------------------
IF (ABS(x) <= 0.15_dp) THEN
  fn_val = x * (((p2*x + p1)*x + 1.0_dp) /  &
           ((((q4*x + q3)*x + q2)*x + q1)*x + 1.0_dp))
  RETURN
END IF

IF (x >= 0.0_dp) THEN
  e = EXP(x)
  fn_val = e * (half + (half - 1.0_dp/e))
  RETURN
END IF
IF (x >= -37.0_dp) THEN
  fn_val = (EXP(x) - half) - half
  RETURN
END IF
fn_val = -1.0_dp
RETURN
END FUNCTION rexp

END SUBROUTINE cgamma


subroutine residuo(a, b, u, r)

implicit none

real, dimension(:,:), intent(in) :: a
real, dimension(:), intent(in) :: b
real, dimension(:), intent(in) :: u

real, dimension(:), intent(inout) :: r

integer :: n, i

n = size(b)

r = matmul(A,u) - b

print*,
print*, 'Residuo: ', sqrt(dot_product(r,r))
print*, r(:)
print*,

end subroutine


subroutine area(r,a)

    use constants, only: pi
    implicit none
    real(kind=8), intent(in) :: r
    real(kind=8), intent(in) :: a

    a = pi * r**2

end subroutine area


C******************************************************************************
C FILE: omp_mm.f
C DESCRIPTION:
C   OpenMp Example - Matrix Multiply - Fortran Version
C   Demonstrates a matrix multiply using OpenMP. Threads share row iterations
C   according to a predefined chunk size.
C AUTHOR: Blaise Barney
C LAST REVISED: 1/5/04 Blaise Barney
C******************************************************************************

      PROGRAM MATMULT

      INTEGER  NRA, NCA, NCB, TID, NTHREADS, I, J, K, CHUNK,
     +         OMP_GET_NUM_THREADS, OMP_GET_THREAD_NUM
C     number of rows in matrix A
      PARAMETER (NRA=62)
C     number of columns in matrix A
      PARAMETER (NCA=15)
C     number of columns in matrix B
      PARAMETER (NCB=7)

      REAL*8 A(NRA,NCA), B(NCA,NCB), C(NRA,NCB)

C     Set loop iteration chunk size
      CHUNK = 10

C     Spawn a parallel region explicitly scoping all variables
!$OMP PARALLEL SHARED(A,B,C,NTHREADS,CHUNK) PRIVATE(TID,I,J,K)
      TID = OMP_GET_THREAD_NUM()
      IF (TID .EQ. 0) THEN
        NTHREADS = OMP_GET_NUM_THREADS()
        PRINT *, 'Starting matrix multiple example with', NTHREADS,
     +           'threads'
        PRINT *, 'Initializing matrices'
      END IF

C     Initialize matrices
!$OMP DO SCHEDULE(STATIC, CHUNK)
      DO 30 I=1, NRA
        DO 30 J=1, NCA
          A(I,J) = (I-1)+(J-1)
  30  CONTINUE
!$OMP DO SCHEDULE(STATIC, CHUNK)
      DO 40 I=1, NCA
        DO 40 J=1, NCB
          B(I,J) = (I-1)*(J-1)
  40  CONTINUE
!$OMP DO SCHEDULE(STATIC, CHUNK)
      DO 50 I=1, NRA
        DO 50 J=1, NCB
          C(I,J) = 0
  50  CONTINUE

C     Do matrix multiply sharing iterations on outer loop
C     Display who does which iterations for demonstration purposes
      PRINT *, 'Thread', TID, 'starting matrix multiply...'
!$OMP DO SCHEDULE(STATIC, CHUNK)
      DO 60 I=1, NRA
      PRINT *, 'Thread', TID, 'did row', I
        DO 60 J=1, NCB
          DO 60 K=1, NCA
            C(I,J) = C(I,J) + A(I,K) * B(K,J)
  60  CONTINUE

C     End of parallel region
!$OMP END PARALLEL

C     Print results
      PRINT *, '******************************************************'
      PRINT *, 'Result Matrix:'
      DO 90 I=1, NRA
        DO 80 J=1, NCB
          WRITE(*,70) C(I,J)
  70      FORMAT(2x,f8.2,$)
  80      CONTINUE
          PRINT *, ' '
  90      CONTINUE
      PRINT *, '******************************************************'
      PRINT *, 'Done.'

      END