 SUBROUTINE rubberps(pr,lb,model,stre,vec,r1,r2)

 ! calculates stiffness and stresses for rubber and elastomeric
 ! foam materials

 IMPLICIT NONE
 ! DUMMY arguments
 REAL(kind=8), INTENT(IN):: pr(12)    !(12) material constants
 REAL(kind=8), INTENT(IN OUT):: lb(3) !(3)  Principal stretches Eigenvalues of U
 INTEGER(kind=4), INTENT(IN) :: model   !Model
                                !1:      Arruda-Boyce
                                !2:      Mooney-Rivlin
                                !3:      Neo-Hooke
                                !4:      Ogden (N=1)
                                !5:      Ogden (N=2)
                                !6:      Ogden (N=3)
                                !7:      Polynomial (N=1)
                                !8:      Polynomial (N=2)
                                !9:      Polynomial (N=3)
                                !10:     Reduced Polynomial (N=1)
                                !11:     Reduced Polynomial (N=2)
                                !12:     Reduced Polynomial (N=3)
                                !13:     Van der Waals (not implemented yet)
                                !14:     Yeoh
                                !15:     Hyperfoam (N=1)
                                !16:     Hyperfoam (N=2)
                                !17:     Hyperfoam (N=3)
 REAL(kind=8), INTENT(OUT) :: stre(:)           !  2nd Piola-Kirchhoff stresses S11 S22 S12
 ! optional arguments
 REAL(kind=8), OPTIONAL, INTENT(OUT) :: vec(:)    !elasticity (stiffness) matrix in vector form
 REAL(kind=8), OPTIONAL, INTENT(IN):: r1,r2     ! first eigenvector in-plane components

 ! Local variables
 REAL(kind=8)  :: &
             bet(2),  &     !principal stresses
             lb2(3),lg(3,3),  &     !squared principal strains
             aux,i1,i2,a1,a2,a3,a4,a5,     & ! auxiliar terms
             d(2,2),          & ! first derivatives of invariants
             dd(2,3),         & ! second derivatives of invariants
             c(4),            & ! local elasticity matrix
             r11,r22,r12  !auxiliar rotation terms

 LOGICAL :: ci1, ci2     !  use first and second invariants

 INTEGER(kind=4) nterm,     & ! number of terms (sum) in the model
                 kode,      & ! model
                 i,j,k        ! index and pointers
 INTEGER(kind=4), PARAMETER :: ii(3) = (/ 1,3,6 /)

 !initializes Flags
 ci1 = .TRUE.       !compute I1 invariant derivatives
 ci2 = .FALSE.      !do NOT compute I2 derivatives

 kode        = model
 SELECT CASE (kode)
 CASE (2)  !Mooney-Rivlin
    ci2 = .TRUE.      !compute I2 derivatives
 CASE (4:6)  !Ogden
    nterm = kode - 3 !number of terms to be considered
    ci1 = .FALSE.
 CASE (7:9)  !Polynomial
    nterm = kode - 6 !number of terms to be considered
    ci2 = .TRUE.      !compute I2 derivatives
 CASE (10:12)!reduced polynomial
    nterm = kode - 9 !number of terms to be considered
 CASE (14)   !yeoh
    kode = 12        !reduced polynomial
    nterm = 3        !number of terms to be considered
 CASE (15:17)           !NOTE that isochoric approach is considered
    CALL runen2(' Hyperfoam not implemented for plane stress')
    !nterm = kode - 14 !number of terms to be considered
 END SELECT

 lb(3) = 1d0/(lb(1)*lb(2)) !impose incompresibility

 !  COMPUTE FIRST DERIVATIVES OF THE INVARIANTS IF NECESSARY
 lb2 = lb**2 !eigenvalues of the metric tensor
 IF( ci1 )THEN
   !   first derivatives of I1
   i1 = lb(1)**2+lb(2)**2+lb(3)**2                           !I1
   DO i=1,2
     d(i,1) = 2d0*lb(i)*(1d0-lb2(3)/lb2(i))          !I1,Li
   END DO
   IF( ci2 )THEN
     ! first derivatives of I2
     i2 = 1d0/lb2(3)+lb(3)*2*(lb2(1)+lb2(2))        !I2
     DO i=1,2
       d(i,2) = 2d0/lb(i)*(1d0/lb2(3)-1d0/lb2(i))   !I2,Li
     END DO
   END IF
 END IF

 ! COMPUTE FIRST DERIVATIVE OF THE STRAIN FUNCTION

 SELECT CASE (kode)
 CASE (1) !Arruda-Boyce
   a1 = pr(4)+i1*(pr(5)+i1*(pr(6)+i1*(pr(7)+i1*pr(8)))) !Phi,I1
   bet = a1*d(:,1)

 CASE (2) !Mooney-Rivlin

   bet = pr(1)*d(:,1) + pr(2)*d(:,2)

 CASE (3) !Neo-Hookean
   bet = pr(1)*d(:,1)

 CASE (4:6) !ogden
   bet = 0d0                               !initializes diagonal stresses
   k = 1                                   !pointer to properties array
   DO j=1,nterm                            !for each term
     a1 = pr(k+1)                          !exponent alpha
     lg(:,j) = lb**a1                      !l1^alpha_i
     bet = bet + pr(k)*(lg(1:2,j) - lg(3,j))
     k = k+2
   END DO
   bet = bet/lb(1:2)

 CASE ( 7: 9) !polynomial model
   i1 = i1 - 3d0   !I1 - 3
   i2 = i2 - 3d0   !I2 - 3
   a1 = pr(1)      !initializes Phi,I1
   a2 = pr(2)      !initializes Phi,I2
   IF( nterm > 1 )THEN
     a1 = a1+2d0*pr(3)*i1 +     pr(4)*i2          !Phi,I1
     a2 = a2+    pr(4)*i1 + 2d0*pr(5)*i2          !Phi,I2
   END IF
   IF( nterm > 2 )THEN
     a1 = a1+3d0*pr(6)*i1*i1 +2d0*pr(7)*i1*i2+    pr(8)*i2*i2 !Phi,I1
     a2 = a2+    pr(7)*i1*i1 +    pr(8)*i1*i2+3d0*pr(9)*i2*i2 !Phi,I2
   END IF
   bet = a1*d(:,1) + a2*d(:,2)

 CASE (10:12) !Reduced polynomial
   i1 = i1 - 3d0          !I1 -3
   a1 = 0d0                       !initializes Phi,I1
   DO i=1,nterm
     a1 = a1 + pr(ii(i))*i*i1**(i-1)   !Phi,I1
   END DO
   bet = a1*d(:,1)

 END SELECT

 !COMPUTE ELASTICITY MATRIX IF REQUIRED
 IF( PRESENT(vec) ) THEN  !compute tangent elasticity for plasticity

   IF( ci1 )THEN
     ! Second Derivatives of First Invariant
     DO i=1,2
       dd(i,i) = 2d0+6d0*lb2(3)/lb2(i)                !I1,Li,Li
     END DO
     dd(1,2) = 4d0*lb2(3)*lb(3)                       !I1,Li,Lj
     IF( ci2 )THEN
       !  Second Derivatives of Second Invariant
       DO i=1,2
         dd(i,3) = 2d0*(1d0/lb2(3)/lb2(i)+3d0/lb2(i)**2)  !I2,Li,Li
       END DO
       dd(2,1) = 4d0/lb(3)                                 !I2,Li,Lj
     END IF
   END IF

   SELECT CASE (kode)

   CASE (1) !Arruda-Boyce

     a2 = pr(5)+i1*(2d0*pr(6)+i1*(3d0*pr(7)+i1*4d0*pr(8))) !Phi,I1,i2
     DO i=1,2
       c(i) = a1*dd(i,i) + a2*d(i,1)**2
     END DO
     c(3) = a1*d(2,1) + a2*d(1,1)*d(2,1)

   CASE (2) !Mooney-Rivlin

     DO i=1,2
       c(i) = pr(1)*dd(i,i) + pr(2)*dd(i,3)
     END DO
     c(3) = pr(1)*dd(1,2) + pr(2)*dd(2,1)

   CASE (3) !Neo-Hookean

     DO i=1,2
       c(i) = pr(1)*dd(i,i)
     END DO
     c(3) = pr(1)*dd(1,2)

   CASE (4:6) !ogden
     c  = 0d0                               !initializes
     k = 1
     DO j=1,nterm                            !for each term
       a1 = pr(k+1)                          !exponent alpha
       a2 = a1-1                             !alpha -2
       aux = (a1+1d0)*lg(3,j)
       c(1) = c(1) + pr(k)*(a2*lg(1,j) + aux ) !DS1/L1
       c(2) = c(2) + pr(k)*(a2*lg(2,j) + aux ) !DS2/L2
       c(3) = c(3) + pr(k)*a1*lg(3,j)          !DS1/L2 = DS2/L1
       k = k+2
     END DO                                      !DS1/L1
     c(1) = c(1)/lb2(1)             !Df1/L1L1
     c(2) = c(2)/lb2(2)             !Df2/L2L2
     c(3) = c(3)*lb(3)              !Df1/L2

   CASE ( 7: 9) !polynomial model
     a3 = 0           !Initializes Phi,I1,I1
     a4 = 0           !Initializes Phi,I1,I2 = Phi,I2,I1
     a5 = 0           !Initializes Phi,I22,I2
     IF( nterm > 1 )THEN
       a3 = 2d0*pr(3)    !Phi,I1,I1
       a4 =     pr(4)    !Phi,I1,I2 = Phi,I2,I1
       a5 = 2d0*pr(5)    !Phi,I22,I2
     END IF
     IF( nterm > 2 )THEN
       a3 = a3+6d0*pr(6)*i1 +2d0*pr(7)*i2  !Phi,I1,I1
       a4 = a4+2d0*pr(7)*i1 +2d0*pr(8)*i2  !Phi,I1,I2 = Phi,I2,I1
       a5 = a5+2d0*pr(8)*i1 +6d0*pr(9)*i2  !Phi,I22,I2
     END IF
     DO i=1,2
       c(i) = a1*dd(i,i) + a2*dd(i,3) &
            + a3*d(i,1)**2 + 2d0*a4*d(i,1)*d(i,2) + a5*d(i,2)**2
     END DO
     c(3) = a1*dd(1,2) + a2*dd(2,1)   &
          + a3*d(1,1)*d(2,1)+a4*(d(1,1)*d(2,2)+d(1,2)*d(2,1))+a5*d(1,2)*d(2,2)

   CASE (10:12) !Reduced polynomial
     a3 = 0d0
     IF( nterm > 1 ) a3 = pr(3)*2d0
     IF( nterm > 3 ) a3 = a3 + pr(6)*3d0*i1
     DO i=1,2
       c(i) = a1*dd(i,i) + a3*d(i,1)**2
     END DO
     c(3) = a1*dd(1,2) + a3*d(1,1)*d(2,1)

   END SELECT

   stre(1:2) = bet*lb(1:2)                    !Kirchhoff stresses

   vec(1) = c(1)*lb2(1) + stre(1)             !DT1/L1
   vec(2) = c(3)/lb(3)                        !DT1/L2 = DT2/L1
   vec(3) = c(2)*lb2(2) + stre(2)             !DT2/L2

 ELSE
   !COMPUTE 2ND Piola Kirchhoff STRESSES IN DIAGONAL FORM
   bet = bet/lb(1:2)
   ! store the stress
   IF( PRESENT(r1) .AND. PRESENT(r2))THEN
     r11 = r1*r1         !factors for stress and matrix computation
     r22 = r2*r2
     r12 = r1*r2
     stre(1) = r11*bet(1) + r22*bet(2)    !(1,1)
     stre(2) = r22*bet(1) + r11*bet(2)    !(2,2)
     stre(3) = r12*(bet(1)-bet(2))        !(1,2)
   ELSE
     stre(1:2) = bet(1:2)
   END IF

 END IF

 RETURN
 END SUBROUTINE rubberps


! RESHAPE returns an array with a different shape than the source array.
! The optional ORDER argument changes the order of elements of SOURCE from the usual
! column major. The optional PAD fills the result, with recycling,
! after source is exhausted.
program test_reshape
implicit none
integer, allocatable :: v(:),m(:,:)
v = [1,2,3,4,5,6]
m = reshape(source=v,shape=[2,3])
! fill m by columns
print*,m(1,:) ! 1 3 5
print*,m(2,:) ! 2 4 6
m = reshape(source=v,shape=[2,3],order=[2,1])
! fill m by rows
print*,m(1,:) ! 1 2 3
print*,m(2,:) ! 4 5 6
m = reshape(source=[0,0],shape=[2,3],order=[2,1],pad=[1,-1])
! pad m with [1,-1] after exhausting source
print*,m(1,:) !  0 0  1
print*,m(2,:) ! -1 1 -1
m = reshape(source=v,shape=[2,3],order=[2,1],pad=[1,-1])
! here pad is unused because size(source) equals product(shape)
print*,m(1,:) !  1 2 3
print*,m(2,:) !  4 5 6
end program test_reshape


module assert

  use, intrinsic:: iso_fortran_env, only: sp=>real32, dp=>real64, qp=>real128, stderr=>error_unit
  use, intrinsic:: ieee_arithmetic
  implicit none
  private

  integer,parameter :: wp = dp

  public :: wp,isclose, assert_isclose

contains

elemental logical function isclose(actual, desired, rtol, atol, equal_nan)
! inputs
! ------
! actual: value "measured"
! desired: value "wanted"
! rtol: relative tolerance
! atol: absolute tolerance
! equal_nan: consider NaN to be equal?
!
!  rtol overrides atol when both are specified
!
! https://www.python.org/dev/peps/pep-0485/#proposed-implementation
! https://github.com/PythonCHB/close_pep/blob/master/is_close.py

  real(wp), intent(in) :: actual, desired
  real(wp), intent(in), optional :: rtol, atol
  logical, intent(in), optional :: equal_nan

  real(wp) :: r,a
  logical :: n

  r = merge(rtol, 1e-5_wp, present(rtol))
  a = merge(atol, 0._wp, present(atol))
  n = merge(equal_nan, .false., present(equal_nan))

  !print*,r,a,n,actual,desired

!--- sanity check
  if ((r < 0._wp).or.(a < 0._wp)) error stop 'tolerances must be non-negative'
!--- simplest case
  isclose = (actual == desired)
  if (isclose) return
!--- equal nan
  isclose = n.and.(ieee_is_nan(actual).and.ieee_is_nan(desired))
  if (isclose) return
!--- Inf /= -Inf, unequal NaN
  if (.not.ieee_is_finite(actual) .or. .not.ieee_is_finite(desired)) return
!--- floating point closeness check
  isclose = abs(actual-desired) <= max(r * max(abs(actual), abs(desired)), a)

end function isclose

impure elemental subroutine assert_isclose(actual, desired, rtol, atol, equal_nan, err_msg)
! inputs
! ------
! actual: value "measured"
! desired: value "wanted"
! rtol: relative tolerance
! atol: absolute tolerance
! equal_nan: consider NaN to be equal?
! err_msg: message to print on mismatch
!
! rtol overrides atol when both are specified

  real(wp), intent(in) :: actual, desired
  real(wp), intent(in), optional :: rtol, atol
  logical, intent(in), optional :: equal_nan
  character(*), intent(in), optional :: err_msg

  if (.not.isclose(actual,desired,rtol,atol,equal_nan)) then
    write(stderr,*) merge(err_msg,'',present(err_msg)),': actual',actual,'desired',desired
    error stop
  endif

end subroutine assert_isclose

end module assert


      PROGRAM xkstwo
C     driver for routine kstwo
      INTEGER N1,N2
      REAL EPS
      PARAMETER(N1=2000,N2=1000,EPS=0.1)
      INTEGER i,idum,j
      REAL d,data1(N1),data2(N2),factr,gasdev,prob,var
      idum=-1357
      do 11 j=1,N1
        data1(j)=gasdev(idum)
11    continue
      write(*,'(/1x,t6,a,t26,a,t46,a/)')
     *     'Variance Ratio','K-S Statistic','Probability'
      do 13 i=1,11
        var=1.0+(i-1)*EPS
        factr=sqrt(var)
        do 12 j=1,N2
          data2(j)=factr*gasdev(idum)
12      continue
        call kstwo(data1,N1,data2,N2,d,prob)
        write(*,'(1x,f15.6,f19.6,e20.4)') var,d,prob
13    continue
      END

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


! { dg-do run }
! { dg-options "-fno-range-check" }
! { dg-add-options ieee }
! { dg-skip-if "NaN not supported" { spu-*-* } }
!
! PR fortran/34318
!
! Infinity and NaN were not properly written to the .mod file.
!
module nonordinal
  implicit none
  real, parameter :: inf = 1./0., nan = 0./0., minf = -1./0.0
end module nonordinal

program a
  use nonordinal
  implicit none
  character(len=20) :: str
  if (log(abs(inf))  < huge(inf)) STOP 1
  if (log(abs(minf)) < huge(inf)) STOP 2
  if (.not. isnan(nan)) STOP 3
  write(str,"(sp,f10.2)") inf
  if (adjustl(str) /= "+Infinity") STOP 4
  write(str,*) minf
  if (adjustl(str) /= "-Infinity") STOP 5
  write(str,*) nan
  if (adjustl(str) /= "NaN") STOP 6
end program a


module constants
use types, only: dp
implicit none
private
public pi, e_, i_, bohr2ang, ang2bohr, Ha2eV, kB, K2au, density2gcm3, u2au, &
    s2au, kJmol2Ha

! Constants contain more digits than double precision, so that
! they are rounded correctly. Single letter constants contain underscore so
! that they do not clash with user variables ("e" and "i" are frequently used as
! loop variables)
real(dp), parameter :: pi    = 3.1415926535897932384626433832795_dp
real(dp), parameter :: e_    = 2.7182818284590452353602874713527_dp
complex(dp), parameter :: i_ = (0, 1)

real(dp), parameter :: Na = 6.02214129e23_dp ! Avogadro constant
! Standard uncertainty      0.00000027 (Source: 2010 CODATA)
real(dp), parameter :: Ha2eV = 27.21138505_dp    ! 1 Ha = (1 * Ha2eV) eV
! Standard uncertainty is       0.00000060 eV (Source: 2010 CODATA)

real(dp), parameter :: J2Ha = 2.29371248e17_dp  ! 1 J = (1 * J2Ha) Ha
! Standard uncertainty is     0.00000010 eV (Source: 2010 CODATA)

! Reduced Planck constant
real(dp), parameter :: hbar = 1.054571726e-34_dp  ! [J s]
! Standard uncertainty is     0.000000047 eV (Source: 2010 CODATA)

! Covert Ha to cm^{-1} (energy equivalent)
! 1 Ha = (1 * Ha2invcm) cm^{-1}
real(dp), parameter :: Ha2invcm = 219474.6313708_dp
! Standard uncertainty is              0.0000011 cm^{-1} (Source: 2010 CODATA)

real(dp), parameter :: kB = 1.3806488e-23_dp ! Boltzmann constant [J/K]
! Standard uncertainty is   0.0000013 J/K (Source: 2010 CODATA)

real(dp), parameter :: me = 9.10938291e-31_dp  ! electron rest mass [kg]
! Standard uncertainty is   0.00000040 eV (Source: 2010 CODATA)

! Converts K to a.u.:
real(dp), parameter :: K2au = J2Ha*kB ! 1 K = (1 * K2au) a.u.

! Conversion between Bohr (Hartree atomic units) and Angstrom
real(dp), parameter :: bohr2ang = 0.529177249_dp
real(dp), parameter :: ang2bohr = 1 / bohr2ang

! Converts eV to kcal/mol, it is assumed, that the number in eV is given per
! molecule.  1 eV = (1 * eV2kcalmol) kcal/mol
real(dp), parameter :: kcalmol2kJmol = 4.184_dp
real(dp), parameter :: kJmol2Ha = 1000 * J2Ha / Na

! Converts density from a.u. to g/cm^3
real(dp), parameter :: density2gcm3 = me*1e3_dp / (bohr2ang*1e-8_dp)**3

! Converts u (atomic mass unit) to a.u.
real(dp), parameter :: u2au = 1 / (Na * me * 1e3_dp)

! Converts s to a.u.
real(dp), parameter :: s2au = 1 / (J2Ha*hbar)

end module

! stolen from: https://github.com/certik/hfsolver/blob/master/src/constants.f90


! =============================================================================
!                       Test Jacobi diagonalisation
!
!       This unit test checks compares the Jacobi diagonalisation with
!       NumPy (numpy.linalg.eigh) (version 1.20.2)
! =============================================================================
program test_jacobi_2
    use unit_test
    use constants, only : zero
    use jacobi
    implicit none

    double precision     :: error
    integer              :: n, k, num
    double precision     :: V(3, 3)
    double precision     :: B(3, 3), D(3)
    double precision     :: Q(3, 3), EV(3) ! reference

    error = zero

    call fopen

    do n = 1, num

        call read_next_line

        call jacobi_diagonalise(B, D, V)

        ! check eigenvalues
        error = max(error, dabs(EV(1) - D(1)) &
                         + dabs(EV(2) - D(2)) &
                         + dabs(EV(3) - D(3)))

        ! check eigenvectors
        do k = 1, 3
            if (Q(1, k) / V(1, k) < zero) then
                ! opposite sign
                Q(:, k) = - Q(:, k)
            endif
            error = max(error, sum(dabs(Q(:, k) - V(:, k))))
        enddo
    enddo

    call fclose

    call print_result_dp('Test Jacobi 2', error, atol=dble(1.0e-12))

    contains

        subroutine fopen
            call open_file('../share/B.asc', 1234)
            read(1234, *) num

            call open_file('../share/V.asc', 1235)
            read(1235, *) n

            if (num .ne. n) then
                ! we do not perform this test
                stop
            endif

            call open_file('../share/D.asc', 1236)
            read(1236, *) n

            if (num .ne. n) then
                ! we do not perform this test
                stop
            endif
        end subroutine fopen

        subroutine open_file(fname, unit)
            character(*), intent(in) :: fname
            integer,      intent(in) :: unit
            logical                  :: exists = .false.

            inquire(file=fname, exist=exists)
            if (.not. exists) then
                call fclose
                ! we do not perform this test
                stop
            endif
            open(unit=unit, file=fname)
        end subroutine open_file

        subroutine fclose
            integer :: unit
            ! 20 October 2021
            ! https://stackoverflow.com/questions/31941681/check-whether-file-has-been-opened-already

            inquire(file='../share/B.asc', number=unit)
            if (unit == 1234) then
                close(1234)
            endif

            inquire(file='../share/V.asc', number=unit)
            if (unit == 1235) then
                close(1235)
            endif

            inquire(file='../share/D.asc', number=unit)
            if (unit == 1236) then
                close(1236)
            endif
        end subroutine fclose

        subroutine read_next_line
            ! B matrix
            read(1234, *) B(1, 1), B(1, 2), B(1, 3), B(2, 2), B(2, 3), B(3, 3)
            B(2, 1) = B(1, 2)
            B(3, 1) = B(1, 3)
            B(3, 2) = B(2, 3)

            ! eigenvectors
            read(1235, *) Q(:, 1), Q(:, 2), Q(:, 3)

            ! eigenvalues
            read(1236, *) EV(1), EV(2), EV(3)
        end subroutine read_next_line

end program test_jacobi_2


*DECK HQR2
      SUBROUTINE HQR2 (NM, N, LOW, IGH, H, WR, WI, Z, IERR)
C***BEGIN PROLOGUE  HQR2
C***PURPOSE  Compute the eigenvalues and eigenvectors of a real upper
C            Hessenberg matrix using QR method.
C***LIBRARY   SLATEC (EISPACK)
C***CATEGORY  D4C2B
C***TYPE      SINGLE PRECISION (HQR2-S, COMQR2-C)
C***KEYWORDS  EIGENVALUES, EIGENVECTORS, EISPACK
C***AUTHOR  Smith, B. T., et al.
C***DESCRIPTION
C
C     This subroutine is a translation of the ALGOL procedure HQR2,
C     NUM. MATH. 16, 181-204(1970) by Peters and Wilkinson.
C     HANDBOOK FOR AUTO. COMP., VOL.II-LINEAR ALGEBRA, 372-395(1971).
C
C     This subroutine finds the eigenvalues and eigenvectors
C     of a REAL UPPER Hessenberg matrix by the QR method.  The
C     eigenvectors of a REAL GENERAL matrix can also be found
C     if  ELMHES  and  ELTRAN  or  ORTHES  and  ORTRAN  have
C     been used to reduce this general matrix to Hessenberg form
C     and to accumulate the similarity transformations.
C
C     On INPUT
C
C        NM must be set to the row dimension of the two-dimensional
C          array parameters, H and Z, as declared in the calling
C          program dimension statement.  NM is an INTEGER variable.
C
C        N is the order of the matrix H.  N is an INTEGER variable.
C          N must be less than or equal to NM.
C
C        LOW and IGH are two INTEGER variables determined by the
C          balancing subroutine  BALANC.  If  BALANC  has not been
C          used, set LOW=1 and IGH equal to the order of the matrix, N.
C
C        H contains the upper Hessenberg matrix.  H is a two-dimensional
C          REAL array, dimensioned H(NM,N).
C
C        Z contains the transformation matrix produced by  ELTRAN
C          after the reduction by  ELMHES, or by  ORTRAN  after the
C          reduction by  ORTHES, if performed.  If the eigenvectors
C          of the Hessenberg matrix are desired, Z must contain the
C          identity matrix.  Z is a two-dimensional REAL array,
C          dimensioned Z(NM,M).
C
C     On OUTPUT
C
C        H has been destroyed.
C
C        WR and WI contain the real and imaginary parts, respectively,
C          of the eigenvalues.  The eigenvalues are unordered except
C          that complex conjugate pairs of values appear consecutively
C          with the eigenvalue having the positive imaginary part first.
C          If an error exit is made, the eigenvalues should be correct
C          for indices IERR+1, IERR+2, ..., N.  WR and WI are one-
C          dimensional REAL arrays, dimensioned WR(N) and WI(N).
C
C        Z contains the real and imaginary parts of the eigenvectors.
C          If the J-th eigenvalue is real, the J-th column of Z
C          contains its eigenvector.  If the J-th eigenvalue is complex
C          with positive imaginary part, the J-th and (J+1)-th
C          columns of Z contain the real and imaginary parts of its
C          eigenvector.  The eigenvectors are unnormalized.  If an
C          error exit is made, none of the eigenvectors has been found.
C
C        IERR is an INTEGER flag set to
C          Zero       for normal return,
C          J          if the J-th eigenvalue has not been
C                     determined after a total of 30*N iterations.
C                     The eigenvalues should be correct for indices
C                     IERR+1, IERR+2, ..., N, but no eigenvectors are
C                     computed.
C
C     Calls CDIV for complex division.
C
C     Questions and comments should be directed to B. S. Garbow,
C     APPLIED MATHEMATICS DIVISION, ARGONNE NATIONAL LABORATORY
C     ------------------------------------------------------------------
C
C***REFERENCES  B. T. Smith, J. M. Boyle, J. J. Dongarra, B. S. Garbow,
C                 Y. Ikebe, V. C. Klema and C. B. Moler, Matrix Eigen-
C                 system Routines - EISPACK Guide, Springer-Verlag,
C                 1976.
C***ROUTINES CALLED  CDIV
C***REVISION HISTORY  (YYMMDD)
C   760101  DATE WRITTEN
C   890531  Changed all specific intrinsics to generic.  (WRB)
C   890831  Modified array declarations.  (WRB)
C   890831  REVISION DATE from Version 3.2
C   891214  Prologue converted to Version 4.0 format.  (BAB)
C   920501  Reformatted the REFERENCES section.  (WRB)
C***END PROLOGUE  HQR2
C
      INTEGER I,J,K,L,M,N,EN,II,JJ,LL,MM,NA,NM,NN
      INTEGER IGH,ITN,ITS,LOW,MP2,ENM2,IERR
      REAL H(NM,*),WR(*),WI(*),Z(NM,*)
      REAL P,Q,R,S,T,W,X,Y,RA,SA,VI,VR,ZZ,NORM,S1,S2
      LOGICAL NOTLAS
C
C***FIRST EXECUTABLE STATEMENT  HQR2
      IERR = 0
      NORM = 0.0E0
      K = 1
C     .......... STORE ROOTS ISOLATED BY BALANC
C                AND COMPUTE MATRIX NORM ..........
      DO 50 I = 1, N
C
         DO 40 J = K, N
   40    NORM = NORM + ABS(H(I,J))
C
         K = I
         IF (I .GE. LOW .AND. I .LE. IGH) GO TO 50
         WR(I) = H(I,I)
         WI(I) = 0.0E0
   50 CONTINUE
C
      EN = IGH
      T = 0.0E0
      ITN = 30*N
C     .......... SEARCH FOR NEXT EIGENVALUES ..........
   60 IF (EN .LT. LOW) GO TO 340
      ITS = 0
      NA = EN - 1
      ENM2 = NA - 1
C     .......... LOOK FOR SINGLE SMALL SUB-DIAGONAL ELEMENT
C                FOR L=EN STEP -1 UNTIL LOW DO -- ..........
   70 DO 80 LL = LOW, EN
         L = EN + LOW - LL
         IF (L .EQ. LOW) GO TO 100
         S = ABS(H(L-1,L-1)) + ABS(H(L,L))
         IF (S .EQ. 0.0E0) S = NORM
         S2 = S + ABS(H(L,L-1))
         IF (S2 .EQ. S) GO TO 100
   80 CONTINUE
C     .......... FORM SHIFT ..........
  100 X = H(EN,EN)
      IF (L .EQ. EN) GO TO 270
      Y = H(NA,NA)
      W = H(EN,NA) * H(NA,EN)
      IF (L .EQ. NA) GO TO 280
      IF (ITN .EQ. 0) GO TO 1000
      IF (ITS .NE. 10 .AND. ITS .NE. 20) GO TO 130
C     .......... FORM EXCEPTIONAL SHIFT ..........
      T = T + X
C
      DO 120 I = LOW, EN
  120 H(I,I) = H(I,I) - X
C
      S = ABS(H(EN,NA)) + ABS(H(NA,ENM2))
      X = 0.75E0 * S
      Y = X
      W = -0.4375E0 * S * S
  130 ITS = ITS + 1
      ITN = ITN - 1
C     .......... LOOK FOR TWO CONSECUTIVE SMALL
C                SUB-DIAGONAL ELEMENTS.
C                FOR M=EN-2 STEP -1 UNTIL L DO -- ..........
      DO 140 MM = L, ENM2
         M = ENM2 + L - MM
         ZZ = H(M,M)
         R = X - ZZ
         S = Y - ZZ
         P = (R * S - W) / H(M+1,M) + H(M,M+1)
         Q = H(M+1,M+1) - ZZ - R - S
         R = H(M+2,M+1)
         S = ABS(P) + ABS(Q) + ABS(R)
         P = P / S
         Q = Q / S
         R = R / S
         IF (M .EQ. L) GO TO 150
         S1 = ABS(P) * (ABS(H(M-1,M-1)) + ABS(ZZ) + ABS(H(M+1,M+1)))
         S2 = S1 + ABS(H(M,M-1)) * (ABS(Q) + ABS(R))
         IF (S2 .EQ. S1) GO TO 150
  140 CONTINUE
C
  150 MP2 = M + 2
C
      DO 160 I = MP2, EN
         H(I,I-2) = 0.0E0
         IF (I .EQ. MP2) GO TO 160
         H(I,I-3) = 0.0E0
  160 CONTINUE
C     .......... DOUBLE QR STEP INVOLVING ROWS L TO EN AND
C                COLUMNS M TO EN ..........
      DO 260 K = M, NA
         NOTLAS = K .NE. NA
         IF (K .EQ. M) GO TO 170
         P = H(K,K-1)
         Q = H(K+1,K-1)
         R = 0.0E0
         IF (NOTLAS) R = H(K+2,K-1)
         X = ABS(P) + ABS(Q) + ABS(R)
         IF (X .EQ. 0.0E0) GO TO 260
         P = P / X
         Q = Q / X
         R = R / X
  170    S = SIGN(SQRT(P*P+Q*Q+R*R),P)
         IF (K .EQ. M) GO TO 180
         H(K,K-1) = -S * X
         GO TO 190
  180    IF (L .NE. M) H(K,K-1) = -H(K,K-1)
  190    P = P + S
         X = P / S
         Y = Q / S
         ZZ = R / S
         Q = Q / P
         R = R / P
C     .......... ROW MODIFICATION ..........
         DO 210 J = K, N
            P = H(K,J) + Q * H(K+1,J)
            IF (.NOT. NOTLAS) GO TO 200
            P = P + R * H(K+2,J)
            H(K+2,J) = H(K+2,J) - P * ZZ
  200       H(K+1,J) = H(K+1,J) - P * Y
            H(K,J) = H(K,J) - P * X
  210    CONTINUE
C
         J = MIN(EN,K+3)
C     .......... COLUMN MODIFICATION ..........
         DO 230 I = 1, J
            P = X * H(I,K) + Y * H(I,K+1)
            IF (.NOT. NOTLAS) GO TO 220
            P = P + ZZ * H(I,K+2)
            H(I,K+2) = H(I,K+2) - P * R
  220       H(I,K+1) = H(I,K+1) - P * Q
            H(I,K) = H(I,K) - P
  230    CONTINUE
C     .......... ACCUMULATE TRANSFORMATIONS ..........
         DO 250 I = LOW, IGH
            P = X * Z(I,K) + Y * Z(I,K+1)
            IF (.NOT. NOTLAS) GO TO 240
            P = P + ZZ * Z(I,K+2)
            Z(I,K+2) = Z(I,K+2) - P * R
  240       Z(I,K+1) = Z(I,K+1) - P * Q
            Z(I,K) = Z(I,K) - P
  250    CONTINUE
C
  260 CONTINUE
C
      GO TO 70
C     .......... ONE ROOT FOUND ..........
  270 H(EN,EN) = X + T
      WR(EN) = H(EN,EN)
      WI(EN) = 0.0E0
      EN = NA
      GO TO 60
C     .......... TWO ROOTS FOUND ..........
  280 P = (Y - X) / 2.0E0
      Q = P * P + W
      ZZ = SQRT(ABS(Q))
      H(EN,EN) = X + T
      X = H(EN,EN)
      H(NA,NA) = Y + T
      IF (Q .LT. 0.0E0) GO TO 320
C     .......... REAL PAIR ..........
      ZZ = P + SIGN(ZZ,P)
      WR(NA) = X + ZZ
      WR(EN) = WR(NA)
      IF (ZZ .NE. 0.0E0) WR(EN) = X - W / ZZ
      WI(NA) = 0.0E0
      WI(EN) = 0.0E0
      X = H(EN,NA)
      S = ABS(X) + ABS(ZZ)
      P = X / S
      Q = ZZ / S
      R = SQRT(P*P+Q*Q)
      P = P / R
      Q = Q / R
C     .......... ROW MODIFICATION ..........
      DO 290 J = NA, N
         ZZ = H(NA,J)
         H(NA,J) = Q * ZZ + P * H(EN,J)
         H(EN,J) = Q * H(EN,J) - P * ZZ
  290 CONTINUE
C     .......... COLUMN MODIFICATION ..........
      DO 300 I = 1, EN
         ZZ = H(I,NA)
         H(I,NA) = Q * ZZ + P * H(I,EN)
         H(I,EN) = Q * H(I,EN) - P * ZZ
  300 CONTINUE
C     .......... ACCUMULATE TRANSFORMATIONS ..........
      DO 310 I = LOW, IGH
         ZZ = Z(I,NA)
         Z(I,NA) = Q * ZZ + P * Z(I,EN)
         Z(I,EN) = Q * Z(I,EN) - P * ZZ
  310 CONTINUE
C
      GO TO 330
C     .......... COMPLEX PAIR ..........
  320 WR(NA) = X + P
      WR(EN) = X + P
      WI(NA) = ZZ
      WI(EN) = -ZZ
  330 EN = ENM2
      GO TO 60
C     .......... ALL ROOTS FOUND.  BACKSUBSTITUTE TO FIND
C                VECTORS OF UPPER TRIANGULAR FORM ..........
  340 IF (NORM .EQ. 0.0E0) GO TO 1001
C     .......... FOR EN=N STEP -1 UNTIL 1 DO -- ..........
      DO 800 NN = 1, N
         EN = N + 1 - NN
         P = WR(EN)
         Q = WI(EN)
         NA = EN - 1
         IF (Q) 710, 600, 800
C     .......... REAL VECTOR ..........
  600    M = EN
         H(EN,EN) = 1.0E0
         IF (NA .EQ. 0) GO TO 800
C     .......... FOR I=EN-1 STEP -1 UNTIL 1 DO -- ..........
         DO 700 II = 1, NA
            I = EN - II
            W = H(I,I) - P
            R = H(I,EN)
            IF (M .GT. NA) GO TO 620
C
            DO 610 J = M, NA
  610       R = R + H(I,J) * H(J,EN)
C
  620       IF (WI(I) .GE. 0.0E0) GO TO 630
            ZZ = W
            S = R
            GO TO 700
  630       M = I
            IF (WI(I) .NE. 0.0E0) GO TO 640
            T = W
            IF (T .NE. 0.0E0) GO TO 635
            T = NORM
  632       T = 0.5E0*T
            IF (NORM + T .GT. NORM) GO TO 632
            T = 2.0E0*T
  635       H(I,EN) = -R / T
            GO TO 700
C     .......... SOLVE REAL EQUATIONS ..........
  640       X = H(I,I+1)
            Y = H(I+1,I)
            Q = (WR(I) - P) * (WR(I) - P) + WI(I) * WI(I)
            T = (X * S - ZZ * R) / Q
            H(I,EN) = T
            IF (ABS(X) .LE. ABS(ZZ)) GO TO 650
            H(I+1,EN) = (-R - W * T) / X
            GO TO 700
  650       H(I+1,EN) = (-S - Y * T) / ZZ
  700    CONTINUE
C     .......... END REAL VECTOR ..........
         GO TO 800
C     .......... COMPLEX VECTOR ..........
  710    M = NA
C     .......... LAST VECTOR COMPONENT CHOSEN IMAGINARY SO THAT
C                EIGENVECTOR MATRIX IS TRIANGULAR ..........
         IF (ABS(H(EN,NA)) .LE. ABS(H(NA,EN))) GO TO 720
         H(NA,NA) = Q / H(EN,NA)
         H(NA,EN) = -(H(EN,EN) - P) / H(EN,NA)
         GO TO 730
  720    CALL CDIV(0.0E0,-H(NA,EN),H(NA,NA)-P,Q,H(NA,NA),H(NA,EN))
  730    H(EN,NA) = 0.0E0
         H(EN,EN) = 1.0E0
         ENM2 = NA - 1
         IF (ENM2 .EQ. 0) GO TO 800
C     .......... FOR I=EN-2 STEP -1 UNTIL 1 DO -- ..........
         DO 790 II = 1, ENM2
            I = NA - II
            W = H(I,I) - P
            RA = 0.0E0
            SA = H(I,EN)
C
            DO 760 J = M, NA
               RA = RA + H(I,J) * H(J,NA)
               SA = SA + H(I,J) * H(J,EN)
  760       CONTINUE
C
            IF (WI(I) .GE. 0.0E0) GO TO 770
            ZZ = W
            R = RA
            S = SA
            GO TO 790
  770       M = I
            IF (WI(I) .NE. 0.0E0) GO TO 780
            CALL CDIV(-RA,-SA,W,Q,H(I,NA),H(I,EN))
            GO TO 790
C     .......... SOLVE COMPLEX EQUATIONS ..........
  780       X = H(I,I+1)
            Y = H(I+1,I)
            VR = (WR(I) - P) * (WR(I) - P) + WI(I) * WI(I) - Q * Q
            VI = (WR(I) - P) * 2.0E0 * Q
            IF (VR .NE. 0.0E0 .OR. VI .NE. 0.0E0) GO TO 783
            S1 = NORM * (ABS(W)+ABS(Q)+ABS(X)+ABS(Y)+ABS(ZZ))
            VR = S1
  782       VR = 0.5E0*VR
            IF (S1 + VR .GT. S1) GO TO 782
            VR = 2.0E0*VR
  783       CALL CDIV(X*R-ZZ*RA+Q*SA,X*S-ZZ*SA-Q*RA,VR,VI,
     1                H(I,NA),H(I,EN))
            IF (ABS(X) .LE. ABS(ZZ) + ABS(Q)) GO TO 785
            H(I+1,NA) = (-RA - W * H(I,NA) + Q * H(I,EN)) / X
            H(I+1,EN) = (-SA - W * H(I,EN) - Q * H(I,NA)) / X
            GO TO 790
  785       CALL CDIV(-R-Y*H(I,NA),-S-Y*H(I,EN),ZZ,Q,
     1                H(I+1,NA),H(I+1,EN))
  790    CONTINUE
C     .......... END COMPLEX VECTOR ..........
  800 CONTINUE
C     .......... END BACK SUBSTITUTION.
C                VECTORS OF ISOLATED ROOTS ..........
      DO 840 I = 1, N
         IF (I .GE. LOW .AND. I .LE. IGH) GO TO 840
C
         DO 820 J = I, N
  820    Z(I,J) = H(I,J)
C
  840 CONTINUE
C     .......... MULTIPLY BY TRANSFORMATION MATRIX TO GIVE
C                VECTORS OF ORIGINAL FULL MATRIX.
C                FOR J=N STEP -1 UNTIL LOW DO -- ..........
      DO 880 JJ = LOW, N
         J = N + LOW - JJ
         M = MIN(J,IGH)
C
         DO 880 I = LOW, IGH
            ZZ = 0.0E0
C
            DO 860 K = LOW, M
  860       ZZ = ZZ + Z(I,K) * H(K,J)
C
            Z(I,J) = ZZ
  880 CONTINUE
C
      GO TO 1001
C     .......... SET ERROR -- NO CONVERGENCE TO AN
C                EIGENVALUE AFTER 30*N ITERATIONS ..........
 1000 IERR = EN
 1001 RETURN
      END


! ----------------------------- BEGIN FORK --------------------------
      SUBROUTINE FORK(LX,CX,SIGNI)
! FAST FOURIER                                  2/15/69
!                          LX
!    CX(K) = SQRT(1.0/LX)* SUM (CX(J)*EXP(2*PI*SIGNI*I*(J-1)*(K-1)/LX))
!                          J=1                        FOR K=1,2,...,LX
!
!  THE SCALING BETWEEN FFT AND EQUIVALENT CONTINUUM OUTPUTS
!  IS AS FOLLOWS.
!
!
!     GOING FROM TIME TO FREQUENCY:
!             F(W)=DT*SQRT(LX)*CX(K)
!
!                  WHERE W(K)=2.0*PI*(K-1)*DF

!                  and    DF = 1/(LX*DT)
!
!
!     GOING FROM FREQUENCY TO TIME, WHERE THE FREQUENCY
!     SPECTRUM IS GIVEN BY THE DIGITIZED CONTINUUM SPECTRUM:
!
!             F(T)=DF*SQRT(LX)*CX(K)
!
!                  WHERE T(K)=(K-1)*DT
!
!
!  THE RESULT OF THE SEQUENCE...TIME TO FREQUENCY,POSSIBLE MODIFICATIONS
!  OF THE SPECTRUM (FOR FILTERING,ETC.), BACK TO TIME...
!  REQUIRES NO SCALING.
!
!
!  THIS VERSION HAS A SLIGHT MODIFICATION TO SAVE SOME TIME...
!  IT TAKES THE FACTOR 3.1415926*SIGNI/L OUTSIDE A DO LOOP (D.BOORE 12/8
!  FOLLOWING A SUGGESTION BY HENRY SWANGER).
!

! Some brief notes on usage:

! "signi" is a real variable and should be called either with the value "+1.0"
! of "-1.0".  The particular value used depends on the conventions being used
! in the application (e.g., see Aki and Richards, 1980, Box 5.2, pp. 129--130).

! Time to frequency:
! In calling routine,
!
!       do i = 1, lx
!         cx(i) = CMPLX(y(i), 0.0)
!       end do
!  where y(i) is the time series and lx is a power of 2
!
!  After calling Fork with the complex array specified above, the following
! symmetries exist:
!
!        cx(1)        = dc value (f = 0 * df, where df = 1.0/(lx*dt))
!        cx(lx/2 + 1) = value at Nyquist (f = (lx/2+1-1)*df = 1.0/(2*dt))
!        cx(lx)       = CONJG(cx(2))
!        cx(lx-1)     = CONJG(cx(3))
!         |           =      |
!        cx(lx-i+2)   = CONJG(cx(i))
!         |           =      |
!        cx(lx/2+2)   = CONJG(cx(lx/2))
!
! where "CONJG" is the Fortran complex conjugate intrinsic function
!
! This symmetry MUST be preserved if modifications are made in the frequency
! domain and another call to Fork (with a different sign for signi) is used
! to go back to the time domain.  If the symmetry is not preserved, then the
! time domain array will have nonzero imaginary components.  There is one case
! where advantage can be taken of this, and that is to find the Hilbert
! transform and the window of a time series with only two calls to Fork (there
! is a short note in BSSA {GET REFERENCE} discussing this trick, which amounts
! to zeroing out the last half of the array and multiplying all but the dc and
! Nyquist values by 2.0; in the time domain, REAL(cx(i)) and AIMAG(cx(i))
! contain the filtered (if a filter was applied) and Hilbert transform of the
! filtered time series, respectively, while CABS(cx(i)) and ATAN2(AIMAG(cx(i)),
! REAL(cx(i))) are the window and instantaneous phase of the filtered time
! series, respectively.

! Some references:

! Farnbach, J.S. (1975). The complex envelope in seismic signal analysis,
! BSSA 65, 951--962.
! He states that the factor of 2 is applied for i = 2...npw2/2 (his indices
! start at 0, I've added 1), which is different than the next reference:

! Mitra, S.K. (2001). Digital Signal Processing, McGraw-Hill, New York.
! He gives an algorithm on p. 794 (eq. 11.81), in which the factor of 2 is
! applied from 0 frequency to just less than Nyquist.

!
! The easiest way to ensure the proper symmetry is to zero out the
! last half of the array (as discussed above), but the following is what
! I usually use:
! modify (filter) only half
! of the cx array:
!
!       do i = 1, lx/2
!         cx(i) = filter(i)*cx(i)
!       end do
!
! where "filter(i)" is a possibly complex filter function (and recall that
! the frequency corresponding to i is f = float(i-1)*df).  After this, fill out
! the last half of the array using
!
!       do i = lx/2+2, lx
!         cx(i) = CONJG(cx(lx+2-j))
!       end do
!
! Note that nothing is done with the Nyquist value.  I assume (but am not sure!)
! that this value should be 0.0
!
! Dates: xx/xx/xx - Written by Norm Brenner(?), Jon Claerbout(?)
!        12/21/00 - Replaced hardwired value of pi with pi evaluated here,
!                     and added comments regarding usage.  Also deleted
!                     dimension specification of cx(lx) and replace it with
!                     cx(*) in the type specification statement.  I also
!                     cleaned up the formatting of the subroutine.
!        08/28/01 - Added comment about variable "signi" being real, and
!                   added "float" in equations for "sc" and "temp", although
!                   not strictly required.
!        06/19/02 - Added some comments about computing envelopes and
!                   instantaneous frequencies
!        01/19/15 - Modernize code (get rid of go to statements)

      complex cx(*),carg,cexp,cw,ctemp

      pi = 4.0*atan(1.0)

      j=1
      sc=sqrt(1./real(lx))

      do i=1,lx

        if (i <= j) then
          ctemp=cx(j)*sc
          cx(j)=cx(i)*sc
          cx(i)=ctemp
        end if

        m=lx/2

        DO
          if (j <= m) EXIT
          j=j-m
          m=m/2
          if (m < 1) EXIT
        END DO

        j = j + m

      end do

      l=1
      DO WHILE (l < lx)
        istep=2*l
        temp= pi * signi/real(l)

        do m=1,l
          carg=(0.,1.)*temp*(m-1)
          cw=cexp(carg)
          do i=m,lx,istep
            ctemp=cw*cx(i+l)
            cx(i+l)=cx(i)-ctemp
            cx(i)=cx(i)+ctemp
          end do
        end do

        l=istep
      END DO

! Previous code (as of 18 July 2010):
!      pi = 4.0*atan(1.0)
!
!      j=1
!      sc=sqrt(1./float(lx))
!
!      do i=1,lx
!        if(i.gt.j) go to 2
!        ctemp=cx(j)*sc
!        cx(j)=cx(i)*sc
!        cx(i)=ctemp
!2       m=lx/2
!3       if(j.le.m) go to 5
!        j=j-m
!        m=m/2
!        if(m.ge.1) go to 3
!5       j=j+m
!      end do
!
!      l=1
!6     istep=2*l
!      temp= pi * signi/float(l)
!
!      do m=1,l
!        carg=(0.,1.)*temp*(m-1)
!        cw=cexp(carg)
!        do i=m,lx,istep
!          ctemp=cw*cx(i+l)
!          cx(i+l)=cx(i)-ctemp
!          cx(i)=cx(i)+ctemp
!        end do
!      end do
!
!      l=istep
!      if(l.lt.lx) go to 6

      return
      end
! ----------------------------- END FORK --------------------------


C/*   15 JUNE 77  ..JEK..    INITIAL RELEASE */
      SUBROUTINE REALTR(A,B,N,ISN)
C  IF ISN=1, THIS SUBROUTINE COMPLETES THE FOURIER TRANSFORM
C    OF 2*N REAL DATA VALUES, WHERE THE ORIGINAL DATA VALUES ARE
C    STORED ALTERNATELY IN ARRAYS A AND B, AND ARE FIRST
C    TRANSFORMED BY A COMPLEX FOURIER TRANSFORM OF DIMENSION N.
C    THE COSINE COEFFICIENTS ARE IN A(1),A(2),...A(N+1) AND
C    THE SINE COEFFICIENTS ARE IN B(1),B(2),...B(N+1).
C    A TYPICAL CALLING SEQUENCE IS
C      CALL FFT(A,B,N,N,N,1)
C      CALL REALTR(A,B,N,1)
C    THE RESULTS SHOULD BE MULTIPLIED BY 0.5/N TO GIVE THE
C    USUAL SCALING OF COEFFICIENTS.
C  IF ISN=-1, THE INVERSE TRANSFORMATION IS DONE, THE FIRST STEP
C    IN EVALUATING A REAL FOURIER SERIES.
C    A TYPICAL CALLING SEQUENCE IS
C      CALL REALTR(A,B,N,-1)
C      CALL FFT(A,B,N,N,N,-1)
C    THE RESULTS SHOULD BE MULTIPLIED BY 0.5 TO GIVE THE USUAL
C    SCALING, AND THE TIME DOMAIN RESULTS ALTERNATE IN ARRAYS A
C    AND B, I.E. A(1),B(1),A(2),B(2),...A(N),B(N).
C  THE DATA MAY ALTERNATIVELY BE STORED IN A SINGLE COMPLEX
C    ARRAY A, THEN THE MAGNITUDE OF ISN CHANGED TO TWO TO
C    GIVE THE CORRECT INDEXING INCREMENT AND A(2) USED TO
C    PASS THE INITIAL ADDRESS FOR THE SEQUENCE OF IMAGINARY
C    VALUES, E.G.
C      CALL FFT(A,A(2),N,N,N,2)
C      CALL REALTR(A,A(2),N,2)
C    IN THIS CASE, THE COSINE AND SINE COEFFICIENTS ALTERNATE IN A.
C  BY R. C. SINGLETON, STANFORD RESEARCH INSTITUTE, OCT. 1968
      DIMENSION A(1),B(1)
      REAL IM
      INC=IABS(ISN)
      NK=N*INC+2
      NH=NK/2
      SD=2.0*ATAN(1.0)/FLOAT(N)
      CD=2.0*SIN(SD)**2
      SD=SIN(SD+SD)
      SN=0.0
      IF(ISN .LT. 0) GO TO 30
      CN=1.0
      A(NK-1)=A(1)
      B(NK-1)=B(1)
   10 DO 20 J=1,NH,INC
      K=NK-J
      AA=A(J)+A(K)
      AB=A(J)-A(K)
      BA=B(J)+B(K)
      BB=B(J)-B(K)
      RE=CN*BA+SN*AB
      IM=SN*BA-CN*AB
      B(K)=IM-BB
      B(J)=IM+BB
      A(K)=AA-RE
      A(J)=AA+RE
      AA=CN-(CD*CN+SD*SN)
      SN=(SD*CN-CD*SN)+SN
C  THE FOLLOWING THREE STATEMENTS COMPENSATE FOR TRUNCATION
C    ERROR.  IF ROUNDED ARITHMETIC IS USED, SUBSTITUTE
C  20 CN=AA
      CN=0.5/(AA**2+SN**2)+0.5
      SN=CN*SN
   20 CN=CN*AA
      RETURN
   30 CN=-1.0
      SD=-SD
      GO TO 10
      END


c
c  . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . .
c  .                                                             .
c  .                  copyright (c) 1998 by UCAR                 .
c  .                                                             .
c  .       University Corporation for Atmospheric Research       .
c  .                                                             .
c  .                      all rights reserved                    .
c  .                                                             .
c  .                                                             .
c  .                         SPHEREPACK                          .
c  .                                                             .
c  . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . .
c
c
c
c ... file isfvpes.f
c
c     this file includes documentation and code for
c     subroutine isfvpes          i
c
c ... files which must be loaded with isfvpes.f
c
c     sphcom.f, hrfft.f, vhses.f,shaes.f
c
c
c     subroutine isfvpes(nlat,nlon,isym,nt,sf,vp,idv,jdv,as,bs,av,bv,
c    +                   mdb,ndb,wvhses,lvhses,work,lwork,ierror)
c
c     given the scalar spherical harmonic coefficients as,bs precomputed
C*PL*ERROR* Comment line too long
c     by shaes for the scalar stream function sf and av,bv precomputed by
C*PL*ERROR* Comment line too long
c     shaes for the scalar velocity potenital vp, subroutine isfvpes computes
c     the vector field (v,w) corresponding to sf and vp.  w is the east
C*PL*ERROR* Comment line too long
c     longitudinal and v is the colatitudinal component of the vector field.
C*PL*ERROR* Comment line too long
c     (v,w) is expressed in terms of sf,vp by the helmholtz relations (in
c     mathematical spherical coordinates):
c
c          v = -1/sin(theta)*d(vp)/dlambda + d(st)/dtheta
c
c          w =  1/sin(theta)*d(st)/dlambda + d(vp)/dtheta
c
c     required legendre functions are stored rather than recomputed as
c     they are in subroutine isfvpes.  v(i,j) and w(i,j) are given at
c     colatitude
c
c            theta(i) = (i-1)*pi/(nlat-1)
c
c     and east longitude
c
c            lambda(j) = (j-1)*2*pi/nlon
c
c     on the sphere (pi=4.0*atan(1.0)).
c
c
c     input parameters
c
c     nlat   the number of colatitudes on the full sphere including the
c            poles. for example, nlat = 37 for a five degree grid.
c            nlat determines the grid increment in colatitude as
c            pi/(nlat-1).  if nlat is odd the equator is located at
c            grid point i=(nlat+1)/2. if nlat is even the equator is
c            located half way between points i=nlat/2 and i=nlat/2+1.
c            nlat must be at least 3. note: on the half sphere, the
c            number of grid points in the colatitudinal direction is
c            nlat/2 if nlat is even or (nlat+1)/2 if nlat is odd.
c
c     nlon   the number of distinct londitude points.  nlon determines
c            the grid increment in longitude as 2*pi/nlon. for example
c            nlon = 72 for a five degree grid. nlon must be greater than
c            3.  the efficiency of the computation is improved when nlon
c            is a product of small prime numbers.
c
c
c     isym   a parameter which determines whether the vector field is
c            computed on the full or half sphere as follows:
c
c      = 0
c
c            the symmetries/antsymmetries described in isym=1,2 below
c            do not exist in sf,vp about the equator.  in this case v
c            and w are not necessarily symmetric or antisymmetric about
c            equator.  v and w are computed on the entire sphere.
c            i.e., in arrays sf(i,j),vp(i,j) for i=1,...,nlat and
c            j=1,...,nlon.
c
c      = 1
c
c            vp is antisymmetric and sf is symmetric about the equator.
c            in this case v is symmetric and w antisymmetric about
c            the equator and are computed for the northern hemisphere
c            only.  i.e., if nlat is odd the v(i,j),w(i,j) are computed
c            for i=1,...,(nlat+1)/2 and for j=1,...,nlon.  if nlat is
c            even then v(i,j),w(i,j) are computed for i=1,...,nlat/2
c            and j=1,...,nlon.
c
c      = 2
c
c            vp is symmetric and sf is antisymmetric about the equator.
c            in this case v is antisymmetric and w symmetric about
c            the equator and are computed for the northern hemisphere
c            only.  i.e., if nlat is odd the v(i,j),w(i,j) are computed
c            for i=1,...,(nlat+1)/2 and for j=1,...,nlon.  if nlat is
c            even then v(i,j),w(i,j) are computed for i=1,...,nlat/2
c            and j=1,...,nlon.
c
c     nt     nt is the number of scalar and vector fields.  some
C*PL*ERROR* Comment line too long
c            computational efficiency is obtained for multiple fields. arrays
C*PL*ERROR* Comment line too long
c            can be three dimensional corresponding to an indexed multiple
c            vector field.  in this case multiple vector synthesis will
c            be performed to compute (v,w) for each field.  the
c            third index is the synthesis index which assumes the values
c            k=1,...,nt.  for a single synthesis set nt = 1.  the
c            description of the remaining parameters is simplified by
C*PL*ERROR* Comment line too long
c            assuming that nt=1 or that all the arrays are two dimensional.
c
c     idv    the first dimension of the arrays v,w as it appears in
c            the program that calls isfvpes. if isym = 0 then idv
c            must be at least nlat.  if isym = 1 or 2 and nlat is
c            even then idv must be at least nlat/2. if isym = 1 or 2
c            and nlat is odd then idv must be at least (nlat+1)/2.
c
c     jdv    the second dimension of the arrays v,w as it appears in
c            the program that calls isfvpes. jdv must be at least nlon.
c
c     as,bs  two or three dimensional arrays (see input parameter nt)
c            that contain the spherical harmonic coefficients of
c            the scalar field sf as computed by subroutine shaes.
c
c     av,bv  two or three dimensional arrays (see input parameter nt)
c            that contain the spherical harmonic coefficients of
c            the scalar field vp as computed by subroutine shaes.
c
c     mdb    the first dimension of the arrays as,bs,av,bv as it
c            appears in the program that calls isfvpes. mdb must be at
c            least min0(nlat,(nlon+2)/2) if nlon is even or at least
c            min0(nlat,(nlon+1)/2) if nlon is odd.
c
c     ndb    the second dimension of the arrays as,bs,av,bv as it
c            appears in the program that calls isfvpes. ndb must be at
c            least nlat.
c
c     wvhses an array which must be initialized by subroutine vhsesi.
c            once initialized, wvhses can be used repeatedly by isfvpes
c            as long as nlon and nlat remain unchanged.  wvhses must
c            not bel altered between calls of isfvpes.
c
c
c     lvhses the dimension of the array wvhses as it appears in the
c            program that calls isfvpes. define
c
c               l1 = min0(nlat,nlon/2) if nlon is even or
c               l1 = min0(nlat,(nlon+1)/2) if nlon is odd
c
c            and
c
c               l2 = nlat/2        if nlat is even or
c               l2 = (nlat+1)/2    if nlat is odd
c
c            then lvhses must be at least
c
c               l1*l2*(nlat+nlat-l1+1)+nlon+15
c
c
c
c     work   a work array that does not have to be saved.
c
c     lwork  the dimension of the array work as it appears in the
c            program that calls isfvpes. define
c
c               l1 = min0(nlat,nlon/2) if nlon is even or
c               l1 = min0(nlat,(nlon+1)/2) if nlon is odd
c
c            and
c
c               l2 = nlat/2                    if nlat is even or
c               l2 = (nlat+1)/2                if nlat is odd
c
c            if isym=0 then lwork must be at least
c
c                       nlat*((2*nt+1)*nlon + 4*l1*nt + 1)
c
c            if isym=1 or 2 then lwork must be at least
c
c                       (2*nt+1)*l2*nlon + nlat*(4*l1*nt + 1)
c
c
c     **************************************************************
c
c     output parameters
c
c    v,w    two or three dimensional arrays (see input parameter nt)
c           that contains the vector field corresponding to the stream
c           function sf and velocity potential vp whose coefficients,
c           as,bs (for sf) and av,bv (for vp), were precomputed by
c           subroutine shaes.  v(i,j) and w(i,j) are given at the
c           colatitude point
c
c                theta(i) = (i-1)*pi/(nlat-1)
c
c           and longitude point
c
c                lambda(j) = (j-1)*2*pi/nlon
c
C*PL*ERROR* Comment line too long
c           the index ranges are defined above at the input parameter isym.
c
c
c    ierror = 0  no errors
c           = 1  error in the specification of nlat
c           = 2  error in the specification of nlon
c           = 3  error in the specification of isym
c           = 4  error in the specification of nt
c           = 5  error in the specification of idv
c           = 6  error in the specification of jdv
c           = 7  error in the specification of mdb
c           = 8  error in the specification of ndb
c           = 9  error in the specification of lvhses
c           = 10 error in the specification of lwork
c **********************************************************************
c
      SUBROUTINE DISFVPES(NLAT,NLON,ISYM,NT,V,W,IDV,JDV,AS,BS,AV,BV,MDB,
     +                   NDB,WVHSES,LVHSES,WORK,LWORK,IERROR)
      IMPLICIT NONE
      INTEGER NLAT,NLON,ISYM,NT,IDV,JDV,MDB,NDB,LVHSES,LWORK,IERROR
      DOUBLE PRECISION V(IDV,JDV,NT),W(IDV,JDV,NT)
      DOUBLE PRECISION AS(MDB,NDB,NT),BS(MDB,NDB,NT)
      DOUBLE PRECISION AV(MDB,NDB,NT),BV(MDB,NDB,NT)
      DOUBLE PRECISION WVHSES(LVHSES),WORK(LWORK)
      INTEGER L1,L2,MN,IS,LWK,IWK
      INTEGER IBR,IBI,ICR,ICI
c
c     check input parameters
c
      IERROR = 1
      IF (NLAT.LT.3) RETURN
      IERROR = 2
      IF (NLON.LT.4) RETURN
      IERROR = 3
      IF (ISYM.LT.0 .OR. ISYM.GT.2) RETURN
      IERROR = 4
      IF (NT.LT.0) RETURN
      IERROR = 5
      L2 = (NLAT+1)/2
      IF ((ISYM.EQ.0.AND.IDV.LT.NLAT) .OR.
     +    (ISYM.GT.0.AND.IDV.LT.L2)) RETURN
      IERROR = 6
      IF (JDV.LT.NLON) RETURN
      IERROR = 7
      L1 = MIN0(NLAT, (NLON+1)/2)
      IF (MDB.LT.MIN0(NLAT, (NLON+2)/2)) RETURN
      IERROR = 8
      IF (NDB.LT.NLAT) RETURN
      IERROR = 9
      L1 = MIN0(NLAT, (NLON+2)/2)
      IF (LVHSES.LT.L1*L2* (NLAT+NLAT-L1+1)+NLON+15) RETURN
      IERROR = 10
      IF (ISYM.EQ.0) THEN
          IF (LWORK.LT.NLAT* ((2*NT+1)*NLON+4*L1*NT+1)) RETURN
      ELSE
          IF (LWORK.LT. (2*NT+1)*NLON+NLAT* (4*L1*NT+1)) RETURN
      END IF
c
c     set first dimension for br,bi,cr,ci (as requried by vhses)
c
      MN = L1*NLAT*NT
      IERROR = 0
c
c     set work space pointers
c
      IBR = 1
      IBI = IBR + MN
      ICR = IBI + MN
      ICI = ICR + MN
      IS = ICI + MN
      IWK = IS + NLAT
      LWK = LWORK - 4*MN - NLAT
      CALL DISFVPES1(NLAT,NLON,ISYM,NT,V,W,IDV,JDV,AS,BS,AV,BV,MDB,NDB,
     +              WORK(IBR),WORK(IBI),WORK(ICR),WORK(ICI),L1,WORK(IS),
     +              WVHSES,LVHSES,WORK(IWK),LWK,IERROR)
      RETURN
      END

      SUBROUTINE DISFVPES1(NLAT,NLON,ISYM,NT,V,W,IDV,JDV,AS,BS,AV,BV,
     +                     MDB,NDB,BR,BI,CR,CI,MAB,FNN,WVHSES,LVHSES,
     +                     WK,LWK,IERROR)
      IMPLICIT NONE
      INTEGER NLAT,NLON,ISYM,NT,IDV,JDV,MDB,NDB,MAB,LVHSES,LWK,IERROR
      DOUBLE PRECISION V(IDV,JDV,NT),W(IDV,JDV,NT)
      DOUBLE PRECISION AS(MDB,NDB,NT),BS(MDB,NDB,NT)
      DOUBLE PRECISION AV(MDB,NDB,NT),BV(MDB,NDB,NT)
      DOUBLE PRECISION BR(MAB,NLAT,NT),BI(MAB,NLAT,NT)
      DOUBLE PRECISION CR(MAB,NLAT,NT),CI(MAB,NLAT,NT)
      DOUBLE PRECISION WVHSES(LVHSES),WK(LWK),FNN(NLAT)
      INTEGER N,M,MMAX,K,ITYP
c
c     set coefficient multiplyers
c
      DO N = 2,NLAT
          FNN(N) = -SQRT(DBLE(N* (N-1)))
      END DO
      MMAX = MIN0(NLAT, (NLON+1)/2)
c
c     compute (v,w) coefficients from as,bs,av,bv
c
      DO K = 1,NT
          DO N = 1,NLAT
              DO M = 1,MAB
                  BR(M,N,K) = 0.0D0
                  BI(M,N,K) = 0.0D0
                  CR(M,N,K) = 0.0D0
                  CI(M,N,K) = 0.0D0
              END DO
          END DO
c
c     compute m=0 coefficients
c
          DO N = 2,NLAT
              BR(1,N,K) = -FNN(N)*AV(1,N,K)
              BI(1,N,K) = -FNN(N)*BV(1,N,K)
              CR(1,N,K) = FNN(N)*AS(1,N,K)
              CI(1,N,K) = FNN(N)*BS(1,N,K)
          END DO
c
c     compute m>0 coefficients using vector spherepack value for mmax
c
          DO M = 2,MMAX
              DO N = M,NLAT
                  BR(M,N,K) = -FNN(N)*AV(M,N,K)
                  BI(M,N,K) = -FNN(N)*BV(M,N,K)
                  CR(M,N,K) = FNN(N)*AS(M,N,K)
                  CI(M,N,K) = FNN(N)*BS(M,N,K)
              END DO
          END DO
      END DO
c
c     synthesize br,bi,cr,ci into (v,w)
c
      IF (ISYM.EQ.0) THEN
          ITYP = 0
      ELSE IF (ISYM.EQ.1) THEN
          ITYP = 3
      ELSE IF (ISYM.EQ.2) THEN
          ITYP = 6
      END IF
      CALL DVHSES(NLAT,NLON,ITYP,NT,V,W,IDV,JDV,BR,BI,CR,CI,MAB,NLAT,
     +           WVHSES,LVHSES,WK,LWK,IERROR)
      RETURN
      END


! { dg-do  run }
! { dg-options "-ffrontend-optimize" }
! PR 66111 - this used to ICE with matmul inlining.
! Original test case by Mikael Morin.

implicit none
  integer, parameter :: n = 4
  integer, dimension(n, n) :: a, b, c
  integer, dimension(n*n)  :: p, res, res2
  integer, dimension(n)    :: v

  integer :: i

  p = [ +59, -53, +47, -43, &
        -37, +31, -29, +23, &
        +19, -17, +13, -11, &
        - 7, + 5, - 3, + 2  ]
  a = reshape(p, shape(a))
  b = reshape([(i, i=1, size(a))], shape(b))
  v = [ 3, 1, 2, 4]
  c = matmul(a, b)
  res = [ + 14, - 22, + 16, - 22, &
          +150, -158, +128, -138, &
          +286, -294, +240, -254, &
          +422, -430, +352, -370  ]
  !print *,c
  if (any(c /= reshape(res, shape(c)))) STOP 1
  c(:,v) = matmul(a, b)
  if (any(c(:,v) /= reshape(res, shape(c)))) STOP 2
  c(v,:) = matmul(a, b)
  if (any(c(v,:) /= reshape(res, shape(c)))) STOP 3

  c = matmul(a(:,v),b(v,:))
  if (any(c /= reshape(res, shape(c)))) STOP 4
end


!> Module that defines the double precision and single
!! precision kinds.
MODULE kinds
  SAVE

  !single-precision kind
  INTEGER, PARAMETER :: sp = selected_real_kind( 6, 37 )

  !double-precision kind
  INTEGER, PARAMETER :: dp = selected_real_kind( 15, 307 )

END MODULE kinds


program months
  implicit none
  integer  :: n, month(12)
  logical  :: leap

  leap = .true.

  do n = 1, 12
     if (mod(n, 2) .ne. 0 .and. n .lt. 8) then     ! Pre-August, odd
        month(n) = 31
     elseif (mod(n, 2) .eq. 0 .and. n .ge. 8) then ! Post-July, even
        month(n) = 31
     else
        month(n) = 30
     endif
  enddo

  select case(leap)
     case(.true.)
        month(2) = 29
     case default
        month(2) = 28
  end select

  do n = 1, 12
     print *, month(n)
  enddo

end program months


program expr_04
implicit none
integer :: x
x = 2**4;
if (x /= 16) error stop
x = 2.**4;
if (x /= 16) error stop
x = 2**4.;
if (x /= 16) error stop
x = 2.**4.;
if (x /= 16) error stop
end program


      program HybridComp13
      integer i
      integer j
      real*8 a(5, 5)
      real*8 cst(5)
      cst (1) = 1.0
      cst (2) = 2.0
      cst (3) = 3.0
      cst (4) = 4.0
      cst (5) = 5.0
      do 10 i = 1, 5
         do j = 1, 5
            a(i,j) = cst(i) * 2.4E38
         enddo
 10   continue
      do i = 1, 5
         do j = 1, 5
            write(*, 100) a(i,j)
 100        format(D19.12)
         enddo
      enddo
      end


!!# MODULE <<FUN_NormInfty>>
MODULE FUN_NormInfty

!!## PURPOSE
!! Defines the $L^\infty$ norm of <A>, with optional weight <W>.

!!## DETAILS
!! The $L^\infty$ norm is a discrete norm of the form.
!!
!! $$ L^\infty(A) = \max_i | A_i | W_i $$
!!
!! Where for example $A_i$ could be average values
!! $A_i = \frac{1}{\Delta x_i} \int_{a_i}^{b_i} A(x) dx$
!! and the weights $W_i = \Delta x_i$ returned from a finite
!! volume solution of a PDE.

!!## USAGE
!
!       s = NormInfty( A [,W] )
!

!!## REFERENCES
!
![1] Weisstein, Eric W. "L2-Norm." From MathWorld--A Wolfram Web Resource.
!    http://mathworld.wolfram.com/L2-Norm.html

!!## OWNER
![1] Wieselquist, William W. (william.wieselquist AT gmail.com)
!    July 8, 2006 - present

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

!!## DEFAULT IMPLICIT
IMPLICIT NONE

!!## DEFAULT ACCESS
PRIVATE

!!## NormInfty PROCEDURE OVERLOADING
INTERFACE NormInfty
 MODULE PROCEDURE NormInfty_A1_Rsp
 MODULE PROCEDURE NormInfty_A2_Rsp
 MODULE PROCEDURE NormInfty_A3_Rsp
 MODULE PROCEDURE NormInfty_A4_Rsp
 MODULE PROCEDURE NormInfty_A5_Rsp
 MODULE PROCEDURE NormInfty_A6_Rsp
 MODULE PROCEDURE NormInfty_A7_Rsp

 MODULE PROCEDURE NormInfty_A1_Rdp
 MODULE PROCEDURE NormInfty_A2_Rdp
 MODULE PROCEDURE NormInfty_A3_Rdp
 MODULE PROCEDURE NormInfty_A4_Rdp
 MODULE PROCEDURE NormInfty_A5_Rdp
 MODULE PROCEDURE NormInfty_A6_Rdp
 MODULE PROCEDURE NormInfty_A7_Rdp
END INTERFACE
INTERFACE NormInfty
 MODULE PROCEDURE NormInfty_A1W1_Rsp
 MODULE PROCEDURE NormInfty_A2W2_Rsp
 MODULE PROCEDURE NormInfty_A3W3_Rsp
 MODULE PROCEDURE NormInfty_A4W4_Rsp
 MODULE PROCEDURE NormInfty_A5W5_Rsp
 MODULE PROCEDURE NormInfty_A6W6_Rsp
 MODULE PROCEDURE NormInfty_A7W7_Rsp

 MODULE PROCEDURE NormInfty_A1W1_Rdp
 MODULE PROCEDURE NormInfty_A2W2_Rdp
 MODULE PROCEDURE NormInfty_A3W3_Rdp
 MODULE PROCEDURE NormInfty_A4W4_Rdp
 MODULE PROCEDURE NormInfty_A5W5_Rdp
 MODULE PROCEDURE NormInfty_A6W6_Rdp
 MODULE PROCEDURE NormInfty_A7W7_Rdp
END INTERFACE

!!## PUBLIC ACCESS LIST
PUBLIC :: NormInfty

!## MODULE PROCEDURES
CONTAINS

!!### L-2 Norm for single precision
PURE FUNCTION NormInfty_A1_Rsp(A) RESULT(s)
USE KND_IntrinsicTypes,ONLY: KIND_R=>KIND_Rsp  !!((01-A-KND_IntrinsicTypes.f90))
REAL(KIND_R),INTENT(IN) :: A(:)
REAL(KIND_R) :: s
!!--begin--
s = MAXVAL( ABS( A ) )
!!--end--
END FUNCTION

PURE FUNCTION NormInfty_A2_Rsp(A) RESULT(s)
USE KND_IntrinsicTypes,ONLY: KIND_R=>KIND_Rsp  !!((01-A-KND_IntrinsicTypes.f90))
REAL(KIND_R),INTENT(IN) :: A(:,:)
REAL(KIND_R) :: s
!!--begin--
s = MAXVAL( ABS( A ) )
!!--end--
END FUNCTION

PURE FUNCTION NormInfty_A3_Rsp(A) RESULT(s)
USE KND_IntrinsicTypes,ONLY: KIND_R=>KIND_Rsp  !!((01-A-KND_IntrinsicTypes.f90))
REAL(KIND_R),INTENT(IN) :: A(:,:,:)
REAL(KIND_R) :: s
!!--begin--
s = MAXVAL( ABS( A ) )
!!--end--
END FUNCTION

PURE FUNCTION NormInfty_A4_Rsp(A) RESULT(s)
USE KND_IntrinsicTypes,ONLY: KIND_R=>KIND_Rsp  !!((01-A-KND_IntrinsicTypes.f90))
REAL(KIND_R),INTENT(IN) :: A(:,:,:,:)
REAL(KIND_R) :: s
!!--begin--
s = MAXVAL( ABS( A ) )
!!--end--
END FUNCTION

PURE FUNCTION NormInfty_A5_Rsp(A) RESULT(s)
USE KND_IntrinsicTypes,ONLY: KIND_R=>KIND_Rsp  !!((01-A-KND_IntrinsicTypes.f90))
REAL(KIND_R),INTENT(IN) :: A(:,:,:,:,:)
REAL(KIND_R) :: s
!!--begin--
s = MAXVAL( ABS( A ) )
!!--end--
END FUNCTION

PURE FUNCTION NormInfty_A6_Rsp(A) RESULT(s)
USE KND_IntrinsicTypes,ONLY: KIND_R=>KIND_Rsp  !!((01-A-KND_IntrinsicTypes.f90))
REAL(KIND_R),INTENT(IN) :: A(:,:,:,:,:,:)
REAL(KIND_R) :: s
!!--begin--
s = MAXVAL( ABS( A ) )
!!--end--
END FUNCTION

PURE FUNCTION NormInfty_A7_Rsp(A) RESULT(s)
USE KND_IntrinsicTypes,ONLY: KIND_R=>KIND_Rsp  !!((01-A-KND_IntrinsicTypes.f90))
REAL(KIND_R),INTENT(IN) :: A(:,:,:,:,:,:,:)
REAL(KIND_R) :: s
!!--begin--
s = MAXVAL( ABS( A ) )
!!--end--
END FUNCTION

!!### L-2 Norm for double precision
PURE FUNCTION NormInfty_A1_Rdp(A) RESULT(s)
USE KND_IntrinsicTypes,ONLY: KIND_R=>KIND_Rdp  !!((01-A-KND_IntrinsicTypes.f90))
REAL(KIND_R),INTENT(IN) :: A(:)
REAL(KIND_R) :: s
!!--begin--
s = MAXVAL( ABS( A ) )
!!--end--
END FUNCTION

PURE FUNCTION NormInfty_A2_Rdp(A) RESULT(s)
USE KND_IntrinsicTypes,ONLY: KIND_R=>KIND_Rdp  !!((01-A-KND_IntrinsicTypes.f90))
REAL(KIND_R),INTENT(IN) :: A(:,:)
REAL(KIND_R) :: s
!!--begin--
s = MAXVAL( ABS( A ) )
!!--end--
END FUNCTION

PURE FUNCTION NormInfty_A3_Rdp(A) RESULT(s)
USE KND_IntrinsicTypes,ONLY: KIND_R=>KIND_Rdp  !!((01-A-KND_IntrinsicTypes.f90))
REAL(KIND_R),INTENT(IN) :: A(:,:,:)
REAL(KIND_R) :: s
!!--begin--
s = MAXVAL( ABS( A ) )
!!--end--
END FUNCTION

PURE FUNCTION NormInfty_A4_Rdp(A) RESULT(s)
USE KND_IntrinsicTypes,ONLY: KIND_R=>KIND_Rdp  !!((01-A-KND_IntrinsicTypes.f90))
REAL(KIND_R),INTENT(IN) :: A(:,:,:,:)
REAL(KIND_R) :: s
!!--begin--
s = MAXVAL( ABS( A ) )
!!--end--
END FUNCTION

PURE FUNCTION NormInfty_A5_Rdp(A) RESULT(s)
USE KND_IntrinsicTypes,ONLY: KIND_R=>KIND_Rdp  !!((01-A-KND_IntrinsicTypes.f90))
REAL(KIND_R),INTENT(IN) :: A(:,:,:,:,:)
REAL(KIND_R) :: s
!!--begin--
s = MAXVAL( ABS( A ) )
!!--end--
END FUNCTION

PURE FUNCTION NormInfty_A6_Rdp(A) RESULT(s)
USE KND_IntrinsicTypes,ONLY: KIND_R=>KIND_Rdp  !!((01-A-KND_IntrinsicTypes.f90))
REAL(KIND_R),INTENT(IN) :: A(:,:,:,:,:,:)
REAL(KIND_R) :: s
!!--begin--
s = MAXVAL( ABS( A ) )
!!--end--
END FUNCTION

PURE FUNCTION NormInfty_A7_Rdp(A) RESULT(s)
USE KND_IntrinsicTypes,ONLY: KIND_R=>KIND_Rdp  !!((01-A-KND_IntrinsicTypes.f90))
REAL(KIND_R),INTENT(IN) :: A(:,:,:,:,:,:,:)
REAL(KIND_R) :: s
!!--begin--
s = MAXVAL( ABS( A ) )
!!--end--
END FUNCTION

!!### L-2 Norm for single precision
PURE FUNCTION NormInfty_A1W1_Rsp(A,W) RESULT(s)
USE KND_IntrinsicTypes,ONLY: KIND_R=>KIND_Rsp  !!((01-A-KND_IntrinsicTypes.f90))
REAL(KIND_R),INTENT(IN) :: A(:),W(:)
REAL(KIND_R) :: s
!!--begin--
s = MAXVAL( ABS(A) * W )
!!--end--
END FUNCTION

PURE FUNCTION NormInfty_A2W2_Rsp(A,W) RESULT(s)
USE KND_IntrinsicTypes,ONLY: KIND_R=>KIND_Rsp  !!((01-A-KND_IntrinsicTypes.f90))
REAL(KIND_R),INTENT(IN) :: A(:,:),W(:,:)
REAL(KIND_R) :: s
!!--begin--
s = MAXVAL( ABS(A) * W )
!!--end--
END FUNCTION

PURE FUNCTION NormInfty_A3W3_Rsp(A,W) RESULT(s)
USE KND_IntrinsicTypes,ONLY: KIND_R=>KIND_Rsp  !!((01-A-KND_IntrinsicTypes.f90))
REAL(KIND_R),INTENT(IN) :: A(:,:,:),W(:,:,:)
REAL(KIND_R) :: s
!!--begin--
s = MAXVAL( ABS(A) * W )
!!--end--
END FUNCTION

PURE FUNCTION NormInfty_A4W4_Rsp(A,W) RESULT(s)
USE KND_IntrinsicTypes,ONLY: KIND_R=>KIND_Rsp  !!((01-A-KND_IntrinsicTypes.f90))
REAL(KIND_R),INTENT(IN) :: A(:,:,:,:),W(:,:,:,:)
REAL(KIND_R) :: s
!!--begin--
s = MAXVAL( ABS(A) * W )
!!--end--
END FUNCTION

PURE FUNCTION NormInfty_A5W5_Rsp(A,W) RESULT(s)
USE KND_IntrinsicTypes,ONLY: KIND_R=>KIND_Rsp  !!((01-A-KND_IntrinsicTypes.f90))
REAL(KIND_R),INTENT(IN) :: A(:,:,:,:,:),W(:,:,:,:,:)
REAL(KIND_R) :: s
!!--begin--
s = MAXVAL( ABS(A) * W )
!!--end--
END FUNCTION

PURE FUNCTION NormInfty_A6W6_Rsp(A,W) RESULT(s)
USE KND_IntrinsicTypes,ONLY: KIND_R=>KIND_Rsp  !!((01-A-KND_IntrinsicTypes.f90))
REAL(KIND_R),INTENT(IN) :: A(:,:,:,:,:,:),W(:,:,:,:,:,:)
REAL(KIND_R) :: s
!!--begin--
s = MAXVAL( ABS(A) * W )
!!--end--
END FUNCTION

PURE FUNCTION NormInfty_A7W7_Rsp(A,W) RESULT(s)
USE KND_IntrinsicTypes,ONLY: KIND_R=>KIND_Rsp  !!((01-A-KND_IntrinsicTypes.f90))
REAL(KIND_R),INTENT(IN) :: A(:,:,:,:,:,:,:),W(:,:,:,:,:,:,:)
REAL(KIND_R) :: s
!!--begin--
s = MAXVAL( ABS(A) * W )
!!--end--
END FUNCTION

!!### L-2 Norm for double precision
PURE FUNCTION NormInfty_A1W1_Rdp(A,W) RESULT(s)
USE KND_IntrinsicTypes,ONLY: KIND_R=>KIND_Rdp  !!((01-A-KND_IntrinsicTypes.f90))
REAL(KIND_R),INTENT(IN) :: A(:),W(:)
REAL(KIND_R) :: s
!!--begin--
s = MAXVAL( ABS(A) * W )
!!--end--
END FUNCTION

PURE FUNCTION NormInfty_A2W2_Rdp(A,W) RESULT(s)
USE KND_IntrinsicTypes,ONLY: KIND_R=>KIND_Rdp  !!((01-A-KND_IntrinsicTypes.f90))
REAL(KIND_R),INTENT(IN) :: A(:,:),W(:,:)
REAL(KIND_R) :: s
!!--begin--
s = MAXVAL( ABS(A) * W )
!!--end--
END FUNCTION

PURE FUNCTION NormInfty_A3W3_Rdp(A,W) RESULT(s)
USE KND_IntrinsicTypes,ONLY: KIND_R=>KIND_Rdp  !!((01-A-KND_IntrinsicTypes.f90))
REAL(KIND_R),INTENT(IN) :: A(:,:,:),W(:,:,:)
REAL(KIND_R) :: s
!!--begin--
s = MAXVAL( ABS(A) * W )
!!--end--
END FUNCTION

PURE FUNCTION NormInfty_A4W4_Rdp(A,W) RESULT(s)
USE KND_IntrinsicTypes,ONLY: KIND_R=>KIND_Rdp  !!((01-A-KND_IntrinsicTypes.f90))
REAL(KIND_R),INTENT(IN) :: A(:,:,:,:),W(:,:,:,:)
REAL(KIND_R) :: s
!!--begin--
s = MAXVAL( ABS(A) * W )
!!--end--
END FUNCTION

PURE FUNCTION NormInfty_A5W5_Rdp(A,W) RESULT(s)
USE KND_IntrinsicTypes,ONLY: KIND_R=>KIND_Rdp  !!((01-A-KND_IntrinsicTypes.f90))
REAL(KIND_R),INTENT(IN) :: A(:,:,:,:,:),W(:,:,:,:,:)
REAL(KIND_R) :: s
!!--begin--
s = MAXVAL( ABS(A) * W )
!!--end--
END FUNCTION

PURE FUNCTION NormInfty_A6W6_Rdp(A,W) RESULT(s)
USE KND_IntrinsicTypes,ONLY: KIND_R=>KIND_Rdp  !!((01-A-KND_IntrinsicTypes.f90))
REAL(KIND_R),INTENT(IN) :: A(:,:,:,:,:,:),W(:,:,:,:,:,:)
REAL(KIND_R) :: s
!!--begin--
s = MAXVAL( ABS(A) * W )
!!--end--
END FUNCTION

PURE FUNCTION NormInfty_A7W7_Rdp(A,W) RESULT(s)
USE KND_IntrinsicTypes,ONLY: KIND_R=>KIND_Rdp  !!((01-A-KND_IntrinsicTypes.f90))
REAL(KIND_R),INTENT(IN) :: A(:,:,:,:,:,:,:),W(:,:,:,:,:,:,:)
REAL(KIND_R) :: s
!!--begin--
s = MAXVAL( ABS(A) * W )
!!--end--
END FUNCTION

END MODULE


!	Copyright (c) 2016 Yousef Naranjani
!	Email: yo.na1118@gmail.com
!	Please read the Readme.txt file to get started
PROGRAM MOPSOtools
	USE ProblemBank

	IMPLICIT NONE

	INTEGER:: i, j, gen, seed, time(8), funCnt = 0
	INTEGER::fpLog, fpPF, fpPS, fpProgress	! output file references
	REAL::RAND

	!!!!!!!!!!!!!!! Choose the proper problem settings here  !!!!!!!!!!!!!!!!!!!
	!INCLUDE 'in/MOP1circles2D.INC'
	INCLUDE 'in/MOP2Fonseca.INC'
	!INCLUDE 'in/MOP3Poloni.INC'
	!INCLUDE 'in/MOP4Kursawe.INC'
	!INCLUDE 'in/MOP5Viennet.INC'
	!INCLUDE 'in/ZDT3_10D.INC'
	!INCLUDE 'in/MOP_C4_Tanaka.INC'

	PRINT*,'Starting up!'
	! IDs for the output files
	fpLog = 10
	fpPF = 11
	fpPS = 12
	fpProgress = 13

	CALL CPU_TIME(t00)
	! for OpenMP: seconds = omp_get_wtime ( )

!	CALL execute_command_line('mkdir -p out/' // trim( probName ) )
	CALL system('mkdir -p out/' // trim( probName ))
	IF (generateReport) OPEN(UNIT = fpLog, 		FILE = ('out/'//trim( probName )//'/log.dat'))
	OPEN(UNIT = fpPF, 		FILE = ('out/'//trim( probName )//'/PF.dat'))
	OPEN(UNIT = fpPS, 		FILE = ('out/'//trim( probName )//'/PS.dat'))
	IF (intermResults) OPEN(UNIT = fpProgress,	FILE = ('out/'//trim( probName )//'/progress.dat'))

	IF (generateReport) CALL DATE_AND_TIME(values=time)
	seed = 1000*time(7)+time(8)
	CALL SRAND(seed)

!	initialize and evaluate the population
	DO i = 1, pops
		DO j = 1, NP
			pop((i-1)*NP+j) = RAND(0) * (ub(j)-lb(j)) + lb(j)
		ENDDO
	ENDDO
!	function evaluations
	CALL evaluate(fit, violations, pop, NF, NP, pops, funCnt, f)

!	initializing the archive
	CALL gBestUpdate(popArchive, fitArchive, violArchive, partPosArchive, indArchive, &
		pop, fit, violations, NP, NF, pops, maxArchive, &
		hyperSpace, hyperLen, lbFit, ubFit, N)
!	initializing the local best
	popPbest(1:NP*pops) = pop(1:NP*pops)
	fitPbest(1:NF*pops) = fit(1:NF*pops)
	violPbest(1:pops) = violations(1:pops)

!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!  THE FLIGHT CYCLE !!!!!!!!!!!!!!!!!!!!!!!!!!!!!
	DO gen = 1, gens

		IF (generateReport) THEN
			WRITE(fpLog,"('Generation: ',I5,' began. Archive length: ', I5)") gen,indArchive
		END IF

		! choosing the leaders from Archive for velocity update
		CALL rouletteWheelSelection(lead, hyperSpace, hyperLen, indArchive, pops,&
					partPosArchive)

		! update the velocity here
		CALL velocityUpdate(velocity, pop, popPbest, popArchive, maxArchive, lead, pops, NP)

		! Updating the population
		pop(1:NP*pops) = pop(1:NP*pops) + velocity(1:NP*pops)

		! Correcting the individuals that are out of bound
		CALL keepIn(pop, velocity, lb, ub, NP, pops)

		! include mutation operator here
		CALL mutate(pop, pops, NP, gen, gens, mutRate, lb, ub)

		IF (generateReport) CALL CPU_TIME(t20)
		!	function evaluations
		CALL evaluate(fit, violations, pop, NF, NP, pops, funCnt, f)
		IF (generateReport) THEN
			CALL CPU_TIME(t21)
			WRITE(fpLog,"('Function Eval: ',F10.2,' s')") t21-t20
		END IF

		!	updating the archive

		CALL gBestUpdate(popArchive, fitArchive, violArchive, partPosArchive, indArchive, &
			pop, fit, violations, NP, NF, pops, maxArchive, &
			hyperSpace, hyperLen, lbFit, ubFit, N)

		!	updating the local best
		CALL pBestUpdate(popPbest, fitPbest, violPbest, pop, fit, violations, NP, NF, pops)

		!	write to progress
		IF ((intermResults.EQV. .TRUE.).AND.(MOD(gen,intermResultsInterval)==0)) THEN
			CALL writeTOfileProgress(fpProgress,	popArchive, fitArchive, &
									violArchive, gen, indArchive, NP, NF)
		END IF

		IF (generateReport) THEN
			CALL CPU_TIME(t11)
			WRITE(fpLog,"('Generation: ',I5,' finished in ',F10.2,' s')") gen,t11-t10
		END IF

	END DO

	CALL CPU_TIME(t01)
	IF (generateReport) WRITE(fpLog,"('Total time: ',F10.2,' s')")t01-t00

	CALL writeTOfile(fpPF, fitArchive, NF, indArchive)
	CALL writeTOfile(fpPS, popArchive, NP, indArchive)

	IF (generateReport) CLOSE(fpLog)
	CLOSE(fpPF)
	CLOSE(fpPS)
	IF (intermResults) CLOSE(fpProgress)

	PRINT*,'Done! Time=',t01-t00,' ,',indArchive, ' solutions found'

END PROGRAM MOPSOtools


      PROGRAM LA_SGTSV_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_GTSV
!  .."Implicit Statement" ..
      IMPLICIT NONE
!  .. "Local Scalars" ..
      INTEGER :: I, INFO, N, NRHS
      INTEGER, ALLOCATABLE :: IPIV(:)
!  .. Local Arrays ..
      REAL(WP), ALLOCATABLE :: DL(:), D(:), DU(:), B(:,:),X(:,:)
!  .. "Executable Statements" ..
      WRITE (*,*) 'GTSV Example Program Results.'
      N = 6; NRHS = 3

      ALLOCATE(DL(N-1),D(N),DU(N-1),B(N,NRHS), X(N,NRHS), IPIV(N) )

      OPEN(UNIT=21,FILE='gtsv.ma',STATUS='UNKNOWN')
          DO I=1,N-1
          READ(21,'(F2.0)') DL(I)
          ENDDO
          DO I=1,N
          READ(21,'(F2.0)') D(I)
          ENDDO
          DO I=1,N-1
          READ(21,'(F2.0)') DU(I)
          ENDDO
      CLOSE(21)

      WRITE(*,*)'DU :'
      WRITE(*,"(I3,1X)") INT(DU(:));

      WRITE(*,*)'D :'
      WRITE(*,"(I3,1X)") INT(D(:));

      WRITE(*,*)'DL :'
      WRITE(*,"(I3,1X)") INT(DL(:));

      DO I = 2, N-1; B(I,:) = DL(I-1) + D(I) + DU(I); ENDDO
      B(1,:) = D(1) + DU(1);B(N,:) = DL(N-1) + D(N)
      DO I = 1, NRHS; B(:,I) = B(:,I)*I; ENDDO

      WRITE(*,*) 'The RHS matrix B:'
      DO I=1,N; WRITE(*,"(3(I3,1X))") INT(B(I,:)); ENDDO

      WRITE(*,*) ' CALL LA_GTSV(DL, D, DU, B, INFO)'
      CALL LA_GTSV(DL, D, DU, B, INFO )

      WRITE(*,*)'DL on exit: '
      WRITE(*,"(F8.5)") DL(:);
      WRITE(*,*)'D on exit: '
      WRITE(*,"(F8.5)") D(:);
      WRITE(*,*)'DU on exit: '
      WRITE(*,"(F8.5)") DU(:);
      WRITE(*,*)'B on exit: '
      DO I=1,N; WRITE(*,"(6(F8.5))") B(I,:); ENDDO

      WRITE(*,*)'INFO = ',INFO

      DEALLOCATE(DL,D,DU,B,X)

      END PROGRAM LA_SGTSV_EXAMPLE


      subroutine boost(mass,p1,p_in,p_out)
c     take momenta p_in in frame in which particle one is at rest with mass
c     "mass"
c     and convert to frame in which particle one has fourvector p1
      implicit none
      double precision mass,p1(4),p_in(4),p_out(4)
      double precision gam,beta(1:3),bdotp,one
      parameter(one=1d0)
      integer j,k
      if (mass.le.0d0) return
      gam=p1(4)/mass
      bdotp=0d0
      do j=1,3
      beta(j)=-p1(j)/p1(4)
      bdotp=bdotp+p_in(j)*beta(j)
      enddo
      p_out(4)=gam*(p_in(4)-bdotp)
      do k=1,3
      p_out(k)=p_in(k)+gam*beta(k)*(gam/(gam+one)*bdotp-p_in(4))
      enddo
      return
      end


C
C     ..................................................................
C
C        SUBROUTINE MULTR
C
C        PURPOSE
C           PERFORM A MULTIPLE LINEAR REGRESSION ANALYSIS FOR A
C           DEPENDENT VARIABLE AND A SET OF INDEPENDENT VARIABLES.  THIS
C           SUBROUTINE IS NORMALLY USED IN THE PERFORMANCE OF MULTIPLE
C           AND POLYNOMIAL REGRESSION ANALYSES.
C
C        USAGE
C           CALL MULTR (N,K,XBAR,STD,D,RX,RY,ISAVE,B,SB,T,ANS)
C
C        DESCRIPTION OF PARAMETERS
C           N     - NUMBER OF OBSERVATIONS.
C           K     - NUMBER OF INDEPENDENT VARIABLES IN THIS REGRESSION.
C           XBAR  - INPUT VECTOR OF LENGTH M CONTAINING MEANS OF ALL
C                   VARIABLES. M IS NUMBER OF VARIABLES IN OBSERVATIONS.
C           STD   - INPUT VECTOR OF LENGTH M CONTAINING STANDARD DEVI-
C                   ATIONS OF ALL VARIABLES.
C           D     - INPUT VECTOR OF LENGTH M CONTAINING THE DIAGONAL OF
C                   THE MATRIX OF SUMS OF CROSS-PRODUCTS OF DEVIATIONS
C                   FROM MEANS FOR ALL VARIABLES.
C           RX    - INPUT MATRIX (K X K) CONTAINING THE INVERSE OF
C                   INTERCORRELATIONS AMONG INDEPENDENT VARIABLES.
C           RY    - INPUT VECTOR OF LENGTH K CONTAINING INTERCORRELA-
C                   TIONS OF INDEPENDENT VARIABLES WITH DEPENDENT
C                   VARIABLE.
C           ISAVE - INPUT VECTOR OF LENGTH K+1 CONTAINING SUBSCRIPTS OF
C                   INDEPENDENT VARIABLES IN ASCENDING ORDER.  THE
C                   SUBSCRIPT OF THE DEPENDENT VARIABLE IS STORED IN
C                   THE LAST, K+1, POSITION.
C           B     - OUTPUT VECTOR OF LENGTH K CONTAINING REGRESSION
C                   COEFFICIENTS.
C           SB    - OUTPUT VECTOR OF LENGTH K CONTAINING STANDARD
C                   DEVIATIONS OF REGRESSION COEFFICIENTS.
C           T     - OUTPUT VECTOR OF LENGTH K CONTAINING T-VALUES.
C           ANS   - OUTPUT VECTOR OF LENGTH 10 CONTAINING THE FOLLOWING
C                   INFORMATION..
C                   ANS(1)  INTERCEPT
C                   ANS(2)  MULTIPLE CORRELATION COEFFICIENT
C                   ANS(3)  STANDARD ERROR OF ESTIMATE
C                   ANS(4)  SUM OF SQUARES ATTRIBUTABLE TO REGRES-
C                           SION (SSAR)
C                   ANS(5)  DEGREES OF FREEDOM ASSOCIATED WITH SSAR
C                   ANS(6)  MEAN SQUARE OF SSAR
C                   ANS(7)  SUM OF SQUARES OF DEVIATIONS FROM REGRES-
C                           SION (SSDR)
C                   ANS(8)  DEGREES OF FREEDOM ASSOCIATED WITH SSDR
C                   ANS(9)  MEAN SQUARE OF SSDR
C                   ANS(10) F-VALUE
C
C        REMARKS
C           N MUST BE GREATER THAN K+1.
C
C        SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED
C           NONE
C
C        METHOD
C           THE GAUSS-JORDAN METHOD IS USED IN THE SOLUTION OF THE
C           NORMAL EQUATIONS.  REFER TO W. W. COOLEY AND P. R. LOHNES,
C           'MULTIVARIATE PROCEDURES FOR THE BEHAVIORAL SCIENCES',
C           JOHN WILEY AND SONS, 1962, CHAPTER 3, AND B. OSTLE,
C           'STATISTICS IN RESEARCH', THE IOWA STATE COLLEGE PRESS,
C           1954, CHAPTER 8.
C
C     ..................................................................
C
      SUBROUTINE MULTR (N,K,XBAR,STD,D,RX,RY,ISAVE,B,SB,T,ANS)
	IMPLICIT DOUBLE PRECISION (A-H)
	IMPLICIT DOUBLE PRECISION (O-Z)
      DIMENSION XBAR(1),STD(1),D(1),RX(1),RY(1),ISAVE(1),B(1),SB(1),
     1          T(1),ANS(20)
C
C        ...............................................................
C
C        IF A DOUBLE PRECISION VERSION OF THIS ROUTINE IS DESIRED, THE
C        C IN COLUMN 1 SHOULD BE REMOVED FROM THE DOUBLE PRECISION
C        STATEMENT WHICH FOLLOWS.
C
C     DOUBLE PRECISION XBAR,STD,D,RX,RY,B,SB,T,ANS,RM,BO,SSAR,SSDR,SY,
C    1                 FN,FK,SSARM,SSDRM,F,DSQRT,DABS
C
C        THE C MUST ALSO BE REMOVED FROM DOUBLE PRECISION STATEMENTS
C        APPEARING IN OTHER ROUTINES USED IN CONJUNCTION WITH THIS
C        ROUTINE.
C
C        THE DOUBLE PRECISION VERSION OF THIS SUBROUTINE MUST ALSO
C        CONTAIN DOUBLE PRECISION FORTRAN FUNCTIONS.  SQRT AND ABS IN
C        STATEMENTS 122, 125, AND 135 MUST BE CHANGED TO DSQRT AND DABS.
C
C        ...............................................................
C
      MM=K+1
C
C        BETA WEIGHTS
C
      DO 100 J=1,K
  100 B(J)=0.0
      DO 110 J=1,K
      L1=K*(J-1)
      DO 110 I=1,K
      L=L1+I
  110 B(J)=B(J)+RY(I)*RX(L)
      RM=0.0
      BO=0.0
      L1=ISAVE(MM)
C
C        COEFFICIENT OF DETERMINATION
C
      DO 120 I=1,K
      RM=RM+B(I)*RY(I)
C
C        REGRESSION COEFFICIENTS
C
      L=ISAVE(I)
      B(I)=B(I)*(STD(L1)/STD(L))
C
C        INTERCEPT
C
  120 BO=BO+B(I)*XBAR(L)
      BO=XBAR(L1)-BO
C
C        SUM OF SQUARES ATTRIBUTABLE TO REGRESSION
C
      SSAR=RM*D(L1)
C
C        MULTIPLE CORRELATION COEFFICIENT
C
  122 RM= DSQRT( DABS(RM))
C
C        SUM OF SQUARES OF DEVIATIONS FROM REGRESSION
C
      SSDR=D(L1)-SSAR
C
C        VARIANCE OF ESTIMATE
C
      FN=N-K-1
      SY=SSDR/FN
C
C        STANDARD DEVIATIONS OF REGRESSION COEFFICIENTS
C
      DO 130 J=1,K
      L1=K*(J-1)+J
      L=ISAVE(J)
  125 SB(J)= DSQRT( DABS((RX(L1)/D(L))*SY))
C
C        COMPUTED T-VALUES
C
  130 T(J)=B(J)/SB(J)
C
C        STANDARD ERROR OF ESTIMATE
C
  135 SY= DSQRT( DABS(SY))
C
C        F VALUE
C
      FK=K
      SSARM=SSAR/FK
      SSDRM=SSDR/FN
      F=SSARM/SSDRM
C
      ANS(1)=BO
      ANS(2)=RM
      ANS(3)=SY
      ANS(4)=SSAR
      ANS(5)=FK
      ANS(6)=SSARM
      ANS(7)=SSDR
      ANS(8)=FN
      ANS(9)=SSDRM
      ANS(10)=F
      RETURN
      END


      SUBROUTINE slCMBN ( NSEL, NCAND, LIST, J )
*+
*     - - - - - -
*      C O M B N
*     - - - - - -
*
*  Generate the next combination, a subset of a specified size chosen
*  from a specified number of items.
*
*  Given:
*     NSEL     i        number of items (subset size)
*     NCAND    i        number of candidates (set size)
*
*  Given and returned:
*     LIST     i(NSEL)  latest combination, LIST(1)=0 to initialize
*
*  Returned:
*     J        i        status: -1 = illegal NSEL or NCAND
*                                0 = OK
*                               +1 = no more combinations available
*
*  Notes:
*
*  1) NSEL and NCAND must both be at least 1, and NSEL must be less
*     than or equal to NCAND.
*
*  2) This routine returns, in the LIST array, a subset of NSEL integers
*     chosen from the range 1 to NCAND inclusive, in ascending order.
*     Before calling the routine for the first time, the caller must set
*     the first element of the LIST array to zero (any value less than 1
*     will do) to cause initialization.
*
*  2) The first combination to be generated is:
*
*        LIST(1)=1, LIST(2)=2, ..., LIST(NSEL)=NSEL
*
*     This is also the combination returned for the "finished" (J=1)
*     case.
*
*     The final permutation to be generated is:
*
*        LIST(1)=NCAND, LIST(2)=NCAND-1, ..., LIST(NSEL)=NCAND-NSEL+1
*
*  3) If the "finished" (J=1) status is ignored, the routine
*     continues to deliver combinations, the pattern repeating
*     every NCAND!/(NSEL!*(NCAND-NSEL)!) calls.
*
*  4) The algorithm is by R.F.Warren-Smith (private communication).
*
*  P.T.Wallace   Starlink   25 August 1999
*
*  Copyright (C) 1999 Rutherford Appleton Laboratory
*
*  License:
*    This program is free software; you can redistribute it and/or modify
*    it under the terms of the GNU General Public License as published by
*    the Free Software Foundation; either version 2 of the License, or
*    (at your option) any later version.
*
*    This program is distributed in the hope that it will be useful,
*    but WITHOUT ANY WARRANTY; without even the implied warranty of
*    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
*    GNU General Public License for more details.
*
*    You should have received a copy of the GNU General Public License
*    along with this program (see SLA_CONDITIONS); if not, write to the
*    Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
*    Boston, MA  02110-1301  USA
*
*  Copyright (C) 1995 Association of Universities for Research in Astronomy Inc.
*-

      IMPLICIT NONE

      INTEGER NSEL,NCAND,LIST(NSEL),J

      INTEGER I,LISTI,NMAX,M
      LOGICAL MORE

*  Validate, and set status.
      IF (NSEL.LT.1.OR.NCAND.LT.1.OR.NSEL.GT.NCAND) THEN
         J = -1
         GO TO 9999
      ELSE
         J = 0
      END IF

*  Just starting?
      IF (LIST(1).LT.1) THEN

*     Yes: return 1,2,3...
         DO I=1,NSEL
            LIST(I) = I
         END DO

      ELSE

*     No: find the first selection that we can increment.

*     Start with the first list item.
         I = 1

*     Loop.
         MORE = .TRUE.
         DO WHILE (MORE)

*        Current list item.
            LISTI = LIST(I)

*        Is this the final list item?
            IF (I.GE.NSEL) THEN

*           Yes:  comparison value is number of candidates plus one.
               NMAX = NCAND+1
            ELSE

*           No:  comparison value is next list item.
               NMAX = LIST(I+1)
            END IF

*        Can the current item be incremented?
            IF (NMAX-LISTI.GT.1) THEN

*           Yes:  increment it.
               LIST(I) = LISTI+1

*           Reinitialize the preceding items.
               DO M=1,I-1
                  LIST(M) = M
               END DO

*           Break.
               MORE = .FALSE.
            ELSE

*           Can't increment the current item:  is it the final one?
               IF (I.GE.NSEL) THEN

*              Yes:  set the status.
                  J = 1

*              Restart the sequence.
                  DO I=1,NSEL
                     LIST(I) = I
                  END DO

*              Break.
                  MORE = .FALSE.
               ELSE

*              No:  next list item.
                  I = I+1
               END IF
            END IF
         END DO
      END IF
 9999 CONTINUE

      END