       PROGRAM POTEN1_3D
C++::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::
C
C  This program calculates a Schwarzschild's model
C  of a triaxial galaxy using De Zeeuw's approximation (1983)
C   and projects the density on one of the principal planes
C
C JLP Version of 10-10-86
C--::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::
C
	PARAMETER (IDIM=1000)
	PARAMETER (IDIM1=50)
	IMPLICIT DOUBLE PRECISION (A-H,O-Z)
	REAL*4 IMAGE(IDIM,IDIM)
	REAL*8 PHI(0:IDIM1,0:IDIM1,0:IDIM1)
	REAL*8 RHO(0:IDIM1,0:IDIM1,0:IDIM1)
	CHARACTER NAME*40,COMMENTS*80,ANS*1,AGAIN*1
	COMMON/POT1/PI,QQ,PP,PASX,PASY,PASZ
C
	PI=3.14159265358979323846
C
C GRAV=6.670 E-8 in dyn.cm2.g-2  (C.G.S.), but like QUINN
C we take GRAV=1.
	GRAV=1.D0

	PRINT *,' PROGRAM POTEN VERSION OF JUNE 8th 1986'

C Inquire the format of the files :
	CALL JLP_INQUIFMT

	OPEN(1,FILE='poten.log',STATUS='unknown',
     1	ACCESS='SEQUENTIAL')
C
C  Input of the parameters
C
10	FORMAT(A)

	PRINT *,' NUMBER OF POINTS FOR THE MODEL (LESS THAN 50)?'
	READ(5,*) NPTS
1000	WRITE (6,335)
335	FORMAT(' Enter P, Q : ',$)
	READ (5,*) PP,QQ
	PRINT *,' ENTER PASX, PASY, PASZ :'
	READ(5,*) PASX,PASY,PASZ

	WRITE(1,340),PP,QQ,PASX,PASY,PASZ
340	FORMAT(4X,'P =',F8.3,'  Q =',F8.3,5X,'PASX, PASY, PASZ :',
     1	3(F9.3,2X),/)

C Calculates C1 and C3

	PP2=PP*PP
	QQ2=QQ*QQ
	PP3=PP2*PP
	QQ3=QQ2*QQ
	ASYM2=2.D0*PP2*QQ2-PP2-QQ2
	SYM2=PP2*QQ2+PP2+QQ2
	SYM3=1.D0+PP3+QQ3

	D1=ASYM2/(14.D0*SYM2)
	D2=(1.D0-(3.D0/SYM3))/6.D0
	D3=(PP2-QQ2)/(28.D0*SYM2)
	D4=(PP3-QQ3)/(12.D0*SYM3)

C	C1=(4.D0/35.D0)*ASYM2/RRR
C	C3=(2.D0/35.D0)*(PP2-QQ2)/RRR

	C1=(D1**0.6)*(D2**0.4)
	C2=(D1/D2)**0.4
	C3=(D3**0.6)*(D4**0.4)
	C4=(D3/D4)**0.4

	CTE1=(4.D0/PI)/(4*PI*GRAV)

	WRITE(1,341) C1,C2,C3,C4
341	FORMAT(4X,'C1 =',E12.5,'  C2 =',E12.5,
     1	'C3 =',E12.5,'  C4 =',E12.5,/,/,11X,'X',
     1	13X,'Y',13X,'Z',10X,'PHI(X,Y,Z)',7X,'RHO(X,Y,Z)',/)

	DO 100 IX=0,NPTS
	X=FLOAT(IX)*PASX
	X2=X*X

	DO 100 IY=0,NPTS
	Y=FLOAT(IY)*PASY
	Y2=Y*Y

	DO 100 IZ=0,NPTS
	Z=FLOAT(IZ)*PASZ
	Z2=Z*Z

	RAD2=X2+Y2+Z2
	IF(RAD2.EQ.0.) RAD2=1.E-12
	RAD=DSQRT(RAD2)

C Calculating U, V and W

	URAD=(-1.D0/RAD)*DLOG(RAD+DSQRT(1+RAD2))+1.D0
	VRAD=(-1.D0*C1*RAD2)/((1.D0+C2*RAD2)**1.5)
	WRAD=(-1.D0*C3*RAD2)/((1.D0+C4*RAD2)**1.5)

C Remember :CTE1=(4.D0/PI)/(4*PI*GRAV)
C
	FRAD=1.D0/((1.D0+RAD2)**1.5)
	GRAD=3.D0*C1*C2*(7.D0+2.D0*C2*RAD2)*RAD2/
     1	((1.D0+C2*RAD2)**3.5)
	HRAD=3.D0*C3*C4*(7.D0+2.D0*C4*RAD2)*RAD2/
     1	((1.D0+C4*RAD2)**3.5)

	AA=(2.D0*Z2-X2-Y2)/(2.D0*RAD2)
	BB=3.D0*(X2-Y2)/RAD2

C
	PHI(IX,IY,IZ)=URAD-AA*VRAD+BB*WRAD
	RHO(IX,IY,IZ)=FRAD-AA*GRAD+BB*HRAD

	IF(IY.EQ.1.AND.IZ.EQ.1)THEN
	WRITE(1,342)X,Y,Z,PHI(IX,IY,IZ),RHO(IX,IY,IZ)
	ENDIF
342	FORMAT(2X,3(F12.3,2X),4X,E12.5,4X,E12.5)

100	CONTINUE

	NPL=2*NPTS+1
	NL=2*NPTS+1

	PRINT *,' DO YOU WANT TO STORE THE IMAGE OF THE DENSITY'

	PRINT *,' PROJECTED ON THE XY PLANE ?'
	READ(5,10) ANS
	IF(ANS.EQ.'Y') THEN
	FACT=1.E+04
	CALL PROJECT(RHO,NPTS,IDIM1,IMAGE,IDIM,FACT,1)
        WRITE(6,*) 'Output file: '
        READ(5,10) NAME
	COMMENTS=' '
	CALL JLP_WRITEIMAG(IMAGE,NPL,NL,IDIM,NAME,COMMENTS)
	ENDIF

	PRINT *,' PROJECTED ON THE YZ PLANE ?'
	READ(5,10) ANS
	IF(ANS.EQ.'Y') THEN
	FACT=1.E+04
	CALL PROJECT(RHO,NPTS,IDIM1,IMAGE,IDIM,FACT,2)
        WRITE(6,*) 'Output file: '
        READ(5,10) NAME
	COMMENTS=' '
	CALL JLP_WRITEIMAG(IMAGE,NPL,NL,IDIM,NAME,COMMENTS)
	ENDIF

	PRINT *,' PROJECTED ON THE ZX PLANE ?'
	READ(5,10) ANS
	IF(ANS.EQ.'Y') THEN
	FACT=1.E+04
	CALL PROJECT(RHO,NPTS,IDIM1,IMAGE,IDIM,FACT,3)
        WRITE(6,*) 'Output file: '
        READ(5,10) NAME
	COMMENTS=' '
	CALL JLP_WRITEIMAG(IMAGE,NPL,NL,IDIM,NAME,COMMENTS)
	ENDIF

	PRINT *,' DO YOU WANT TO STORE THE IMAGE OF THE POTENTIAL?'

	PRINT *,' 1: IN THE PLANE X,Y ?'
	READ(5,10) ANS
	IF(ANS.EQ.'Y') THEN
	FACT=-1.
	CALL PLANE(PHI,NPTS,IDIM1,IMAGE,IDIM,FACT,1)
        WRITE(6,*) 'Output file: '
        READ(5,10) NAME
	COMMENTS=' '
	CALL JLP_WRITEIMAG(IMAGE,NPL,NL,IDIM,NAME,COMMENTS)
	ENDIF

	PRINT *,' 1: IN THE PLANE Y,Z ?'
	READ(5,10) ANS
	IF(ANS.EQ.'Y') THEN
	FACT=-1.
	CALL PLANE(PHI,NPTS,IDIM1,IMAGE,IDIM,FACT,2)
        WRITE(6,*) 'Output file: '
        READ(5,10) NAME
	COMMENTS=' '
	CALL JLP_WRITEIMAG(IMAGE,NPL,NL,IDIM,NAME,COMMENTS)
	ENDIF

	PRINT *,' 1: IN THE PLANE Z,X ?'
	READ(5,10) ANS
	IF(ANS.EQ.'Y') THEN
	FACT=-1.
	CALL PLANE(PHI,NPTS,IDIM1,IMAGE,IDIM,FACT,3)
        WRITE(6,*) 'Output file: '
        READ(5,10) NAME
	COMMENTS=' '
	CALL JLP_WRITEIMAG(IMAGE,NPL,NL,IDIM,NAME,COMMENTS)
	ENDIF

C
999	CLOSE(1)
	PRINT *,' Output in "poten.log".'
	STOP
	END
C
C

	SUBROUTINE PROJECT(RHO,NPTS,IDIM1,IMAGE,IDIM,FACT,IOPT)
C****************************************************
C	Subroutine PROJECT to project the density on one
C	of the planes XY (IOPT=1), YZ (IOPT=2) or ZX (IOPT=3)
C********************************************************
	IMPLICIT DOUBLE PRECISION (A-H,O-Z)
	REAL*8 RHO(0:IDIM1,0:IDIM1,0:IDIM1)
	REAL*4 IMAGE(IDIM,IDIM)
	COMMON/POT1/PI,QQ,PP,PASX,PASY,PASZ
C
C  Projects the density on the plane XY
C
	IF(IOPT.EQ.1) THEN

	DO 101 IX=0,NPTS
	DO 101 IY=0,NPTS
	RRR=0.D0

	DO IZ=0,NPTS
	RRR=2*RHO(IX,IY,IZ)*PASZ+RRR
	END DO
	RRR=RRR*FACT

	IXX=NPTS+IX+1
	IYY=NPTS+IY+1
	IMAGE(IXX,IYY)=SNGL(RRR)
	IXX=NPTS-IX+1
	IYY=IY+NPTS+1
	IMAGE(IXX,IYY)=SNGL(RRR)
	IXX=NPTS-IX+1
	IYY=NPTS-IY+1
	IMAGE(IXX,IYY)=SNGL(RRR)
	IXX=NPTS+IX+1
	IYY=NPTS-IY+1
	IMAGE(IXX,IYY)=SNGL(RRR)

101	CONTINUE
	ENDIF

C
C  Projects the density on the plane YZ
C
	IF(IOPT.EQ.2) THEN

	DO 102 IX=0,NPTS
	DO 102 IY=0,NPTS
	RRR=0.D0

	DO IZ=1,NPTS
	RRR=2*RHO(IZ,IX,IY)*PASX+RRR
	END DO
	RRR=RRR*FACT

	IXX=NPTS+IX+1
	IYY=NPTS+IY+1
	IMAGE(IXX,IYY)=SNGL(RRR)
	IXX=NPTS-IX+1
	IYY=IY+NPTS+1
	IMAGE(IXX,IYY)=SNGL(RRR)
	IXX=NPTS-IX+1
	IYY=NPTS-IY+1
	IMAGE(IXX,IYY)=SNGL(RRR)
	IXX=NPTS+IX+1
	IYY=NPTS-IY+1
	IMAGE(IXX,IYY)=SNGL(RRR)

102	CONTINUE
	ENDIF

C
C  Projects the density on the plane ZX
C
	IF(IOPT.EQ.3) THEN

	DO 103 IX=0,NPTS
	DO 103 IY=0,NPTS
	RRR=0.D0

	DO IZ=0,NPTS
	RRR=2*RHO(IY,IZ,IX)*PASY+RRR
	END DO
	RRR=RRR*FACT

	IXX=NPTS+IX+1
	IYY=NPTS+IY+1
	IMAGE(IXX,IYY)=SNGL(RRR)
	IXX=NPTS-IX+1
	IYY=IY+NPTS+1
	IMAGE(IXX,IYY)=SNGL(RRR)
	IXX=NPTS-IX+1
	IYY=NPTS-IY+1
	IMAGE(IXX,IYY)=SNGL(RRR)
	IXX=NPTS+IX+1
	IYY=NPTS-IY+1
	IMAGE(IXX,IYY)=SNGL(RRR)

103	CONTINUE
	ENDIF

	RETURN
	END

	SUBROUTINE PLANE(PHI,NPTS,IDIM1,IMAGE,IDIM,FACT,IOPT)
C****************************************************
C	Subroutine PLANE to create an image of the potential
C	in the plane chosen by the user.
C	 If IOPT=1 plane X,Y
C	 If IOPT=2 plane Y,Z
C	 If IOPT=3 plane Z,X
C********************************************************
	IMPLICIT DOUBLE PRECISION (A-H,O-Z)
	REAL*8 PHI(0:IDIM1,0:IDIM1,0:IDIM1)
	REAL*4 IMAGE(IDIM,IDIM)
	COMMON/POT1/PI,QQ,PP,PASX,PASY,PASZ

C Projection on the XY plane
C
	IF(IOPT.EQ.1)THEN
	IZ=0
	DO 101 IX=0,NPTS
	DO 101 IY=0,NPTS
	RRR=PHI(IX,IY,IZ)
	IXX=NPTS+IX+1
	IYY=NPTS+IY+1
	IMAGE(IXX,IYY)=SNGL(RRR)
	IXX=NPTS-IX+1
	IYY=IY+NPTS+1
	IMAGE(IXX,IYY)=SNGL(RRR)
	IXX=NPTS-IX+1
	IYY=NPTS-IY+1
	IMAGE(IXX,IYY)=SNGL(RRR)
	IXX=NPTS+IX+1
	IYY=NPTS-IY+1
	IMAGE(IXX,IYY)=SNGL(RRR)
101	CONTINUE
	ENDIF

C Projection on the YZ plane
C
	IF(IOPT.EQ.2)THEN
	IZ=0
	DO 102 IX=0,NPTS
	DO 102 IY=0,NPTS
	RRR=PHI(IZ,IX,IY)
	IXX=NPTS+IX+1
	IYY=NPTS+IY+1
	IMAGE(IXX,IYY)=SNGL(RRR)
	IXX=NPTS-IX+1
	IYY=IY+NPTS+1
	IMAGE(IXX,IYY)=SNGL(RRR)
	IXX=NPTS-IX+1
	IYY=NPTS-IY+1
	IMAGE(IXX,IYY)=SNGL(RRR)
	IXX=NPTS+IX+1
	IYY=NPTS-IY+1
	IMAGE(IXX,IYY)=SNGL(RRR)
102	CONTINUE
	ENDIF

C Projection on the XY plane
C
	IF(IOPT.EQ.3)THEN
	IZ=0
	DO 103 IX=0,NPTS
	DO 103 IY=0,NPTS
	RRR=PHI(IY,IZ,IX)
	IXX=NPTS+IX+1
	IYY=NPTS+IY+1
	IMAGE(IXX,IYY)=SNGL(RRR)
	IXX=NPTS-IX+1
	IYY=IY+NPTS+1
	IMAGE(IXX,IYY)=SNGL(RRR)
	IXX=NPTS-IX+1
	IYY=NPTS-IY+1
	IMAGE(IXX,IYY)=SNGL(RRR)
	IXX=NPTS+IX+1
	IYY=NPTS-IY+1
	IMAGE(IXX,IYY)=SNGL(RRR)
103	CONTINUE
	ENDIF

	RETURN
	END
C********************************************************************
C         IFAIL=0
C         CALL D01GAF(RAD1,Y,NPTS,S(J),ERR(J),IFAIL)
C D01GAF integrates Y(RAD1). Method of GILL and MILLER
C Comp. Journal 15, pp. 80-83, 1972. An algorithm for the integration
C of unequally spaced data.
C 	RAD1: all distinct in either ascending or descending order
C	S(J) : (output) estimate of the integral
C	ERR(J) : (output) estimate of the uncertainty in the integral
C


module fqs_utility_basic

    use fqs_types,      only: wp

    implicit none

    private

    public check_division_scalar

contains

    elemental function check_division_scalar(num,den) result(ok)
        real(wp), intent(in) :: num
        real(wp), intent(in) :: den
        logical              :: ok
        if ((exponent(num) - exponent(den) >= maxexponent(num)) .or. (den == 0.0_wp)) then
            ok = .false.
        else
            ok = .true.
        end if
    end function check_division_scalar

end module fqs_utility_basic


! =============================================================================
! Name        : main_mo_sampling.f90
! Author      : Giovanni Dalmasso
! Contacts	  : giovanni.dalmasso@ufz.de - http://www.ufz.de/index.php?en=30665
!               Department of Computational Hydrosystems CHS - UZF Leipzig
! Date	      : Apr 16, 2013
! Version     : 1.0
! Copyright   : 2012-2013 Giovanni Dalmasso
! Description : main for testing mo_sampling.f90
! =============================================================================

program main_mo_sampling

    use mo_kind,            only    :   i4, sp
    use mo_ansi_colors, only: color, c_red, c_green
    use mo_sampling,        only    :   random, lhs, setupxor
    use mo_xor4096,         only    :   n_save_state

    implicit none

    integer(i4),    dimension(:),   allocatable ::  seed                ! seed
    integer(i4),    dimension(:,:), allocatable ::  save_the_setup_rnd  ! xor variable rnd
    integer(i4),    dimension(:,:), allocatable ::  save_the_setup_lhs  ! xor variable lhs
    real(sp)                                    ::  test                ! test variable
    real(sp),       dimension(:,:), allocatable ::  randomTest          ! random sampling
    real(sp),       dimension(:,:), allocatable ::  lhsTest             ! lhs sampling
    logical                                     ::  isgood              ! test variable
    logical,        dimension(:),   allocatable ::  dist                ! flag to chose between unif or gauss

    integer(i4),    parameter                   ::  Nsample = 10000_i4  ! number of samples
    integer(i4),    parameter                   ::  Npar = 3_i4         ! number of parameters

    if ( allocated(randomTest) ) deallocate(randomTest)
    if ( allocated(lhsTest) ) deallocate(lhsTest)
    if ( allocated(save_the_setup_rnd) ) deallocate(save_the_setup_rnd)
    if ( allocated(save_the_setup_lhs) ) deallocate(save_the_setup_lhs)
    if ( allocated(dist) ) deallocate(dist)
    if ( allocated(seed) ) deallocate(seed)
    allocate( randomTest(Nsample, Npar) )
    allocate( lhsTest(Nsample, Npar) )
    allocate( save_the_setup_rnd(Npar, n_save_state) )
    allocate( save_the_setup_lhs(Npar, n_save_state) )
    allocate( dist(Npar) )
    allocate( seed(Npar) )

    isgood = .true.  ! test variable
    test = 1.0e6_sp  ! test variable

    ! distributions
    dist = (/ .false., .true., .false. /)
    ! seed
    seed = (/ 100_i4, 200_i4, 300_i4 /)

    ! setup xor4096 with distributions
    call setupxor( Npar, dist, save_the_setup_rnd, seed=seed )
    ! test random sampling
    randomTest = random( Nsample, Npar, save_the_setup_rnd, dist=dist )
    ! isgood test
    if ( any(nint(randomTest(1,:)*test) .ne. (/ 641292_i4, 227264_i4, 161895_i4 /)) ) isgood = .false.    ! test

    ! setup xor4096
    call setupxor( Npar, save_the_setup_lhs, seed=seed )
    ! test Latin Hypercube Sampling
    lhsTest = lhs( Nsample, Npar, save_the_setup_lhs, dist=dist )
    print*, 'Ha01 ', lhsTest(1,:)*test
    if ( any(nint(lhsTest(1,:)*test) .ne. (/ 634054_i4, 736906_i4, 633938_i4 /)) ) isgood = .false.    ! test

    ! Is the program running properly?
    write(*,*) ''
    write(*,*) '------------------------------------------'
    if (isgood) then
        write(*,*) 'mo_sampling.f90 ', color('o.k.', c_green)
    else
        write(*,*) 'mo_sampling.f90 ', color('failed!', c_red)
    endif
    write(*,*) '-------------------END---------------------'

end program main_mo_sampling


!>
!! @file
!! This file is part of SeisSol.
!!
!! @section LICENSE
!! Copyright (c) SeisSol Group
!! All rights reserved.
!!
!! Redistribution and use in source and binary forms, with or without
!! modification, are permitted provided that the following conditions are met:
!!
!! 1. Redistributions of source code must retain the above copyright notice,
!!    this list of conditions and the following disclaimer.
!!
!! 2. Redistributions in binary form must reproduce the above copyright notice,
!!    this list of conditions and the following disclaimer in the documentation
!!    and/or other materials provided with the distribution.
!!
!! 3. Neither the name of the copyright holder nor the names of its
!!    contributors may be used to endorse or promote products derived from this
!!    software without specific prior written permission.
!!
!! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
!! AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
!! IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
!! ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE
!! LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
!! CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
!! SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
!! INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
!! CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
!! ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
!! POSSIBILITY OF SUCH DAMAGE.

module gauss_mod
  integer, parameter, private :: rk=kind(1.)!set to default single precision
  integer, parameter, private :: ik=kind(1) !set to default integer
contains
  subroutine gauss_jacobi(a,b,xes,weights)
    use, intrinsic :: iso_fortran_env, only : error_unit
    real,intent(in) :: a,b
    real,intent(out):: xes(:),weights(size(xes))
    integer,parameter :: dk=kind(1.d0)
    integer :: it,i1,i2,M
    real :: ab,a_b
    real(dk) :: o1,o2,o3,q,d,y,yd,f
    real(dk), parameter :: one=1.d0,two=2.d0,half=0.5d0,quart=0.25d0
    real(dk), parameter :: pi=3.1415926535897932384626433832795028841971694d0
    integer , parameter :: nt=20
    character(len=38), parameter ::message='gauss-jacobi: iteration limit exeeded '
    M=size(xes);ab=a+b;a_b=a-b;f=fexp();yd=two;it=1
    do i1=1,M
       y=cos((half*a + i1 - quart)/(half*(one + a + b) + M)*pi)
       do it=1,nt
          d = two + a+b
          o1 = (a_b + d*y)*half; o2 = one
          do i2=2,M
             o3 = o2;o2=o1;d=a+b+2*i2
             o1 = (-o3*(two*(a + i2 - 1)*(b + i2 - 1)*d) + o2*((d - one) &
                  & *(a*a - b*b + d*(d - two)*y)))/(2*i2*(i2 + a+b)*(d - two))
          enddo
          q = (M*(a - b - d*y)*o1 + two*(M + a)*(M + b)*o2)/ &
               & (d*(one - y*y)); yd = y; y = yd - o1/q
          if(converged())exit
       enddo
       xes(i1) = y ; weights(i1) = f*d*2.**(a+b)/(q*o2)
       if(it>nt)write(error_unit,*)message
    enddo
    return
  contains
    logical function converged()
      converged = (abs(y - yd)<epsilon(y)*one)
    end function converged
    real(dk) function fexp()
      fexp = exp(log_gamma(a + M) + log_gamma(b + M) &
           &   - log_gamma(M + one) - log_gamma(M + a + b + one))
    end function fexp
  end subroutine gauss_jacobi
  subroutine gausslegendre(a,b,x,w)
    implicit none
    !dummies:
    real(rk),intent(in) :: a,b
    real(rk),intent(out):: x(:),w(size(x))
    !locals:
    real(rk), parameter:: env=epsilon(1._rk)*100._rk,pi=acos(-1.0_rk)
    integer :: j,N,NH
    real(rk):: pop,x1,x2,s
    N=size(x);NH=(N+1)/2
    x2 =(b+a)*0.5_rk; x1=(b-a)*0.5_rk
    do j=1,NH
       s = cos(pi*(j-.25_rk)/(.5_rk+N))
       call subint(s,pop,N)
       x(j)=x2-x1*s;x(N+1-j)=x2+x1*s
       w(j)=2._rk*x1/((1._rk-s*s)*pop*pop); w(N+1-j)=2._rk*x1/((1._rk-s*s)*pop*pop)
    enddo
    return
  contains
    subroutine subint(s,pop,N)
      implicit none
      real(rk),intent(inout):: s,pop
      integer(ik),intent(in) :: N
      real(rk) :: pmo,pmt,pmth,sone
      integer(ik) :: j
      real(rk), parameter:: env=epsilon(1._rk)*100._rk
      sone=2._rk
      do while(abs(s-sone) > env)
         pmo=1._rk; pmt=0._rk
         do j=1,N
            pmth=pmt; pmt =pmo;
            pmo =((2._rk*j-1._rk)*s*pmt-(j-1._rk)*pmth)/j
         enddo
         sone=s;pop=N*(s*pmo-pmt)/(s*s-1._rk); s=sone-pmo/pop
      enddo
    end subroutine subint
  end subroutine gausslegendre

end module gauss_mod


    program demo_all
    implicit none
    logical l
       l = all([.true., .true., .true.])
       print *, l
       call section

    contains

    subroutine section
    integer a(2,3), b(2,3)
      a = 1
      b = 1
      b(2,2) = 2
      print *, all(a .eq. b, 1)
      print *, all(a .eq. b, 2)
    end subroutine section
    end program demo_all


C
C-----------------------------------------------------------------------
C-----------------------------------------------------------------------
C  BLAS-1 routines needed in the computation of Floquet multipliers
C-----------------------------------------------------------------------
C-----------------------------------------------------------------------
      DOUBLE PRECISION FUNCTION DASUM(N,DX,INCX)
*     .. Scalar Arguments ..
      INTEGER INCX,N
*     ..
*     .. Array Arguments ..
      DOUBLE PRECISION DX(*)
*     ..
*
*  Purpose
*  =======
*
*     takes the sum of the absolute values.
*     jack dongarra, linpack, 3/11/78.
*     modified 3/93 to return if incx .le. 0.
*     modified 12/3/93, array(1) declarations changed to array(*)
*
*
*     .. Local Scalars ..
      DOUBLE PRECISION DTEMP
      INTEGER I,M,MP1,NINCX
*     ..
*     .. Intrinsic Functions ..
      INTRINSIC DABS,MOD
*     ..
      DASUM = 0.0d0
      DTEMP = 0.0d0
      IF (N.LE.0 .OR. INCX.LE.0) RETURN
      IF (INCX.EQ.1) GO TO 20
*
*        code for increment not equal to 1
*
      NINCX = N*INCX
      DO 10 I = 1,NINCX,INCX
          DTEMP = DTEMP + DABS(DX(I))
   10 CONTINUE
      DASUM = DTEMP
      RETURN
*
*        code for increment equal to 1
*
*
*        clean-up loop
*
   20 M = MOD(N,6)
      IF (M.EQ.0) GO TO 40
      DO 30 I = 1,M
          DTEMP = DTEMP + DABS(DX(I))
   30 CONTINUE
      IF (N.LT.6) GO TO 60
   40 MP1 = M + 1
      DO 50 I = MP1,N,6
          DTEMP = DTEMP + DABS(DX(I)) + DABS(DX(I+1)) + DABS(DX(I+2)) +
     +            DABS(DX(I+3)) + DABS(DX(I+4)) + DABS(DX(I+5))
   50 CONTINUE
   60 DASUM = DTEMP
      RETURN
      END
C
C-----------------------------------------------------------------------
C-----------------------------------------------------------------------
      SUBROUTINE DCOPY(N,DX,INCX,DY,INCY)
*     .. Scalar Arguments ..
      INTEGER INCX,INCY,N
*     ..
*     .. Array Arguments ..
      DOUBLE PRECISION DX(*),DY(*)
*     ..
*
*  Purpose
*  =======
*
*     copies a vector, x, to a vector, y.
*     uses unrolled loops for increments equal to one.
*     jack dongarra, linpack, 3/11/78.
*     modified 12/3/93, array(1) declarations changed to array(*)
*
*
*     .. Local Scalars ..
      INTEGER I,IX,IY,M,MP1
*     ..
*     .. Intrinsic Functions ..
      INTRINSIC MOD
*     ..
      IF (N.LE.0) RETURN
      IF (INCX.EQ.1 .AND. INCY.EQ.1) GO TO 20
*
*        code for unequal increments or equal increments
*          not equal to 1
*
      IX = 1
      IY = 1
      IF (INCX.LT.0) IX = (-N+1)*INCX + 1
      IF (INCY.LT.0) IY = (-N+1)*INCY + 1
      DO 10 I = 1,N
          DY(IY) = DX(IX)
          IX = IX + INCX
          IY = IY + INCY
   10 CONTINUE
      RETURN
*
*        code for both increments equal to 1
*
*
*        clean-up loop
*
   20 M = MOD(N,7)
      IF (M.EQ.0) GO TO 40
      DO 30 I = 1,M
          DY(I) = DX(I)
   30 CONTINUE
      IF (N.LT.7) RETURN
   40 MP1 = M + 1
      DO 50 I = MP1,N,7
          DY(I) = DX(I)
          DY(I+1) = DX(I+1)
          DY(I+2) = DX(I+2)
          DY(I+3) = DX(I+3)
          DY(I+4) = DX(I+4)
          DY(I+5) = DX(I+5)
          DY(I+6) = DX(I+6)
   50 CONTINUE
      RETURN
      END
C
C-----------------------------------------------------------------------
C-----------------------------------------------------------------------
      DOUBLE PRECISION FUNCTION DNRM2 ( N, X, INCX )
*     .. Scalar Arguments ..
      INTEGER                           INCX, N
*     .. Array Arguments ..
      DOUBLE PRECISION                  X( * )
*     ..
*
*  DNRM2 returns the euclidean norm of a vector via the function
*  name, so that
*
*     DNRM2 := sqrt( x'*x )
*
*
*
*  -- This version written on 25-October-1982.
*     Modified on 14-October-1993 to inline the call to DLASSQ.
*     Sven Hammarling, Nag Ltd.
*
*
*     .. Parameters ..
      DOUBLE PRECISION      ONE         , ZERO
      PARAMETER           ( ONE = 1.0D+0, ZERO = 0.0D+0 )
*     .. Local Scalars ..
      INTEGER               IX
      DOUBLE PRECISION      ABSXI, NORM, SCALE, SSQ
*     .. Intrinsic Functions ..
      INTRINSIC             ABS, SQRT
*     ..
*     .. Executable Statements ..
      IF( N.LT.1 .OR. INCX.LT.1 )THEN
         NORM  = ZERO
      ELSE IF( N.EQ.1 )THEN
         NORM  = ABS( X( 1 ) )
      ELSE
         SCALE = ZERO
         SSQ   = ONE
*        The following loop is equivalent to this call to the LAPACK
*        auxiliary routine:
*        CALL DLASSQ( N, X, INCX, SCALE, SSQ )
*
         DO 10, IX = 1, 1 + ( N - 1 )*INCX, INCX
            IF( X( IX ).NE.ZERO )THEN
               ABSXI = ABS( X( IX ) )
               IF( SCALE.LT.ABSXI )THEN
                  SSQ   = ONE   + SSQ*( SCALE/ABSXI )**2
                  SCALE = ABSXI
               ELSE
                  SSQ   = SSQ   +     ( ABSXI/SCALE )**2
               END IF
            END IF
   10    CONTINUE
         NORM  = SCALE * SQRT( SSQ )
      END IF
*
      DNRM2 = NORM
      RETURN
*
*     End of DNRM2.
*
      END
C
C-----------------------------------------------------------------------
C-----------------------------------------------------------------------
      DOUBLE PRECISION FUNCTION DDOT(N,DX,INCX,DY,INCY)
C
C     FORMS THE DOT PRODUCT OF TWO VECTORS.
C     USES UNROLLED LOOPS FOR INCREMENTS EQUAL TO ONE.
C     JACK DONGARRA, LINPACK, 3/11/78.
C
      DOUBLE PRECISION DX(1),DY(1),DTEMP
      INTEGER I,INCX,INCY,IX,IY,M,MP1,N
C
      DDOT = 0.0D0
      DTEMP = 0.0D0
      IF(N.LE.0)RETURN
      IF(INCX.EQ.1.AND.INCY.EQ.1)GO TO 20
C
C        CODE FOR UNEQUAL INCREMENTS OR EQUAL INCREMENTS
C          NOT EQUAL TO 1
C
      IX = 1
      IY = 1
      IF(INCX.LT.0)IX = (-N+1)*INCX + 1
      IF(INCY.LT.0)IY = (-N+1)*INCY + 1
      DO 10 I = 1,N
        DTEMP = DTEMP + DX(IX)*DY(IY)
        IX = IX + INCX
        IY = IY + INCY
   10 CONTINUE
      DDOT = DTEMP
      RETURN
C
C        CODE FOR BOTH INCREMENTS EQUAL TO 1
C
C
C        CLEAN-UP LOOP
C
   20 M = MOD(N,5)
      IF( M .EQ. 0 ) GO TO 40
      DO 30 I = 1,M
        DTEMP = DTEMP + DX(I)*DY(I)
   30 CONTINUE
      IF( N .LT. 5 ) GO TO 60
   40 MP1 = M + 1
      DO 50 I = MP1,N,5
        DTEMP = DTEMP + DX(I)*DY(I) + DX(I + 1)*DY(I + 1) +
     *   DX(I + 2)*DY(I + 2) + DX(I + 3)*DY(I + 3) + DX(I + 4)*DY(I + 4)
   50 CONTINUE
   60 DDOT = DTEMP
      RETURN
      END
C
C-----------------------------------------------------------------------
C-----------------------------------------------------------------------
      SUBROUTINE DROTM(N,DX,INCX,DY,INCY,DPARAM)
*     .. Scalar Arguments ..
      INTEGER INCX,INCY,N
*     ..
*     .. Array Arguments ..
      DOUBLE PRECISION DPARAM(5),DX(1),DY(1)
*     ..
*
*  Purpose
*  =======
*
*     APPLY THE MODIFIED GIVENS TRANSFORMATION, H, TO THE 2 BY N MATRIX
*
*     (DX**T) , WHERE **T INDICATES TRANSPOSE. THE ELEMENTS OF DX ARE IN
*     (DY**T)
*
*     DX(LX+I*INCX), I = 0 TO N-1, WHERE LX = 1 IF INCX .GE. 0, ELSE
*     LX = (-INCX)*N, AND SIMILARLY FOR SY USING LY AND INCY.
*     WITH DPARAM(1)=DFLAG, H HAS ONE OF THE FOLLOWING FORMS..
*
*     DFLAG=-1.D0     DFLAG=0.D0        DFLAG=1.D0     DFLAG=-2.D0
*
*       (DH11  DH12)    (1.D0  DH12)    (DH11  1.D0)    (1.D0  0.D0)
*     H=(          )    (          )    (          )    (          )
*       (DH21  DH22),   (DH21  1.D0),   (-1.D0 DH22),   (0.D0  1.D0).
*     SEE DROTMG FOR A DESCRIPTION OF DATA STORAGE IN DPARAM.
*
*  Arguments
*  =========
*
*  N      (input) INTEGER
*         number of elements in input vector(s)
*
*  DX     (input/output) DOUBLE PRECISION array, dimension N
*         double precision vector with 5 elements
*
*  INCX   (input) INTEGER
*         storage spacing between elements of DX
*
*  DY     (input/output) DOUBLE PRECISION array, dimension N
*         double precision vector with N elements
*
*  INCY   (input) INTEGER
*         storage spacing between elements of DY
*
*  DPARAM (input/output)  DOUBLE PRECISION array, dimension 5
*     DPARAM(1)=DFLAG
*     DPARAM(2)=DH11
*     DPARAM(3)=DH21
*     DPARAM(4)=DH12
*     DPARAM(5)=DH22
*
*  =====================================================================
*
*     .. Local Scalars ..
      DOUBLE PRECISION DFLAG,DH11,DH12,DH21,DH22,TWO,W,Z,ZERO
      INTEGER I,KX,KY,NSTEPS
*     ..
*     .. Data statements ..
      DATA ZERO,TWO/0.D0,2.D0/
*     ..
*
      DFLAG = DPARAM(1)
      IF (N.LE.0 .OR. (DFLAG+TWO.EQ.ZERO)) GO TO 140
      IF (.NOT. (INCX.EQ.INCY.AND.INCX.GT.0)) GO TO 70
*
      NSTEPS = N*INCX
      IF (DFLAG) 50,10,30
   10 CONTINUE
      DH12 = DPARAM(4)
      DH21 = DPARAM(3)
      DO 20 I = 1,NSTEPS,INCX
          W = DX(I)
          Z = DY(I)
          DX(I) = W + Z*DH12
          DY(I) = W*DH21 + Z
   20 CONTINUE
      GO TO 140
   30 CONTINUE
      DH11 = DPARAM(2)
      DH22 = DPARAM(5)
      DO 40 I = 1,NSTEPS,INCX
          W = DX(I)
          Z = DY(I)
          DX(I) = W*DH11 + Z
          DY(I) = -W + DH22*Z
   40 CONTINUE
      GO TO 140
   50 CONTINUE
      DH11 = DPARAM(2)
      DH12 = DPARAM(4)
      DH21 = DPARAM(3)
      DH22 = DPARAM(5)
      DO 60 I = 1,NSTEPS,INCX
          W = DX(I)
          Z = DY(I)
          DX(I) = W*DH11 + Z*DH12
          DY(I) = W*DH21 + Z*DH22
   60 CONTINUE
      GO TO 140
   70 CONTINUE
      KX = 1
      KY = 1
      IF (INCX.LT.0) KX = 1 + (1-N)*INCX
      IF (INCY.LT.0) KY = 1 + (1-N)*INCY
*
      IF (DFLAG) 120,80,100
   80 CONTINUE
      DH12 = DPARAM(4)
      DH21 = DPARAM(3)
      DO 90 I = 1,N
          W = DX(KX)
          Z = DY(KY)
          DX(KX) = W + Z*DH12
          DY(KY) = W*DH21 + Z
          KX = KX + INCX
          KY = KY + INCY
   90 CONTINUE
      GO TO 140
  100 CONTINUE
      DH11 = DPARAM(2)
      DH22 = DPARAM(5)
      DO 110 I = 1,N
          W = DX(KX)
          Z = DY(KY)
          DX(KX) = W*DH11 + Z
          DY(KY) = -W + DH22*Z
          KX = KX + INCX
          KY = KY + INCY
  110 CONTINUE
      GO TO 140
  120 CONTINUE
      DH11 = DPARAM(2)
      DH12 = DPARAM(4)
      DH21 = DPARAM(3)
      DH22 = DPARAM(5)
      DO 130 I = 1,N
          W = DX(KX)
          Z = DY(KY)
          DX(KX) = W*DH11 + Z*DH12
          DY(KY) = W*DH21 + Z*DH22
          KX = KX + INCX
          KY = KY + INCY
  130 CONTINUE
  140 CONTINUE
      RETURN
      END
C
C-----------------------------------------------------------------------
C-----------------------------------------------------------------------
      SUBROUTINE  DSCAL(N,DA,DX,INCX)
C
C     SCALES A VECTOR BY A CONSTANT.
C     USES UNROLLED LOOPS FOR INCREMENT EQUAL TO ONE.
C     JACK DONGARRA, LINPACK, 3/11/78.
C
      DOUBLE PRECISION DA,DX(1)
      INTEGER I,INCX,M,MP1,N,NINCX
C
      IF(N.LE.0)RETURN
      IF(INCX.EQ.1)GO TO 20
C
C        CODE FOR INCREMENT NOT EQUAL TO 1
C
      NINCX = N*INCX
      DO 10 I = 1,NINCX,INCX
        DX(I) = DA*DX(I)
   10 CONTINUE
      RETURN
C
C        CODE FOR INCREMENT EQUAL TO 1
C
C
C        CLEAN-UP LOOP
C
   20 M = MOD(N,5)
      IF( M .EQ. 0 ) GO TO 40
      DO 30 I = 1,M
        DX(I) = DA*DX(I)
   30 CONTINUE
      IF( N .LT. 5 ) RETURN
   40 MP1 = M + 1
      DO 50 I = MP1,N,5
        DX(I) = DA*DX(I)
        DX(I + 1) = DA*DX(I + 1)
        DX(I + 2) = DA*DX(I + 2)
        DX(I + 3) = DA*DX(I + 3)
        DX(I + 4) = DA*DX(I + 4)
   50 CONTINUE
      RETURN
      END
C
C-----------------------------------------------------------------------
C-----------------------------------------------------------------------
      INTEGER FUNCTION IDAMAX(N,DX,INCX)
C
C     FINDS THE INDEX OF ELEMENT HAVING MAX. ABSOLUTE VALUE.
C     JACK DONGARRA, LINPACK, 3/11/78.
C
      DOUBLE PRECISION DX(1),DMAX
      INTEGER I,INCX,IX,N
C
      IDAMAX = 0
      IF( N .LT. 1 ) RETURN
      IDAMAX = 1
      IF(N.EQ.1)RETURN
      IF(INCX.EQ.1)GO TO 20
C
C        CODE FOR INCREMENT NOT EQUAL TO 1
C
      IX = 1
      DMAX = DABS(DX(1))
      IX = IX + INCX
      DO 10 I = 2,N
         IF(DABS(DX(IX)).LE.DMAX) GO TO 5
         IDAMAX = I
         DMAX = DABS(DX(IX))
    5    IX = IX + INCX
   10 CONTINUE
      RETURN
C
C        CODE FOR INCREMENT EQUAL TO 1
C
   20 DMAX = DABS(DX(1))
      DO 30 I = 2,N
         IF(DABS(DX(I)).LE.DMAX) GO TO 30
         IDAMAX = I
         DMAX = DABS(DX(I))
   30 CONTINUE
      RETURN
      END
C
C-----------------------------------------------------------------------
C-----------------------------------------------------------------------
      SUBROUTINE DAXPY(N,DA,DX,INCX,DY,INCY)
C
C     CONSTANT TIMES A VECTOR PLUS A VECTOR.
C     USES UNROLLED LOOPS FOR INCREMENTS EQUAL TO ONE.
C     JACK DONGARRA, LINPACK, 3/11/78.
C
      DOUBLE PRECISION DX(1),DY(1),DA
      INTEGER I,INCX,INCY,M,MP1,N
C
      IF(N.LE.0)RETURN
      IF (DA .EQ. 0.0D0) RETURN
      IF(INCX.EQ.1.AND.INCY.EQ.1)GO TO 20
C
C        CODE FOR UNEQUAL INCREMENTS OR EQUAL INCREMENTS
C          NOT EQUAL TO 1
C
      IX = 1
      IY = 1
      IF(INCX.LT.0)IX = (-N+1)*INCX + 1
      IF(INCY.LT.0)IY = (-N+1)*INCY + 1
      DO 10 I = 1,N
        DY(IY) = DY(IY) + DA*DX(IX)
        IX = IX + INCX
        IY = IY + INCY
   10 CONTINUE
      RETURN
C
C        CODE FOR BOTH INCREMENTS EQUAL TO 1
C
C
C        CLEAN-UP LOOP
C
   20 M = MOD(N,4)
      IF( M .EQ. 0 ) GO TO 40
      DO 30 I = 1,M
        DY(I) = DY(I) + DA*DX(I)
   30 CONTINUE
      IF( N .LT. 4 ) RETURN
   40 MP1 = M + 1
      DO 50 I = MP1,N,4
        DY(I) = DY(I) + DA*DX(I)
        DY(I + 1) = DY(I + 1) + DA*DX(I + 1)
        DY(I + 2) = DY(I + 2) + DA*DX(I + 2)
        DY(I + 3) = DY(I + 3) + DA*DX(I + 3)
   50 CONTINUE
      RETURN
      END
C
C-----------------------------------------------------------------------
C-----------------------------------------------------------------------
      SUBROUTINE  DROT (N,DX,INCX,DY,INCY,C,S)
C
C     APPLIES A PLANE ROTATION.
C     JACK DONGARRA, LINPACK, 3/11/78.
C
      DOUBLE PRECISION DX(1),DY(1),DTEMP,C,S
      INTEGER I,INCX,INCY,IX,IY,N
C
      IF(N.LE.0)RETURN
      IF(INCX.EQ.1.AND.INCY.EQ.1)GO TO 20
C
C       CODE FOR UNEQUAL INCREMENTS OR EQUAL INCREMENTS NOT EQUAL
C         TO 1
C
      IX = 1
      IY = 1
      IF(INCX.LT.0)IX = (-N+1)*INCX + 1
      IF(INCY.LT.0)IY = (-N+1)*INCY + 1
      DO 10 I = 1,N
        DTEMP = C*DX(IX) + S*DY(IY)
        DY(IY) = C*DY(IY) - S*DX(IX)
        DX(IX) = DTEMP
        IX = IX + INCX
        IY = IY + INCY
   10 CONTINUE
      RETURN
C
C       CODE FOR BOTH INCREMENTS EQUAL TO 1
C
   20 DO 30 I = 1,N
        DTEMP = C*DX(I) + S*DY(I)
        DY(I) = C*DY(I) - S*DX(I)
        DX(I) = DTEMP
   30 CONTINUE
      RETURN
      END
C
C-----------------------------------------------------------------------
C-----------------------------------------------------------------------
      SUBROUTINE  DSWAP (N,DX,INCX,DY,INCY)
C
C     INTERCHANGES TWO VECTORS.
C     USES UNROLLED LOOPS FOR INCREMENTS EQUAL ONE.
C     JACK DONGARRA, LINPACK, 3/11/78.
C
      DOUBLE PRECISION DX(1),DY(1),DTEMP
      INTEGER I,INCX,INCY,IX,IY,M,MP1,N
C
      IF(N.LE.0)RETURN
      IF(INCX.EQ.1.AND.INCY.EQ.1)GO TO 20
C
C       CODE FOR UNEQUAL INCREMENTS OR EQUAL INCREMENTS NOT EQUAL
C         TO 1
C
      IX = 1
      IY = 1
      IF(INCX.LT.0)IX = (-N+1)*INCX + 1
      IF(INCY.LT.0)IY = (-N+1)*INCY + 1
      DO 10 I = 1,N
        DTEMP = DX(IX)
        DX(IX) = DY(IY)
        DY(IY) = DTEMP
        IX = IX + INCX
        IY = IY + INCY
   10 CONTINUE
      RETURN
C
C       CODE FOR BOTH INCREMENTS EQUAL TO 1
C
C
C       CLEAN-UP LOOP
C
   20 M = MOD(N,3)
      IF( M .EQ. 0 ) GO TO 40
      DO 30 I = 1,M
        DTEMP = DX(I)
        DX(I) = DY(I)
        DY(I) = DTEMP
   30 CONTINUE
      IF( N .LT. 3 ) RETURN
   40 MP1 = M + 1
      DO 50 I = MP1,N,3
        DTEMP = DX(I)
        DX(I) = DY(I)
        DY(I) = DTEMP
        DTEMP = DX(I + 1)
        DX(I + 1) = DY(I + 1)
        DY(I + 1) = DTEMP
        DTEMP = DX(I + 2)
        DX(I + 2) = DY(I + 2)
        DY(I + 2) = DTEMP
   50 CONTINUE
      RETURN
      END
C
C-----------------------------------------------------------------------
C-----------------------------------------------------------------------
C  BLAS-2 routines needed in the computation of Floquet multipliers
C-----------------------------------------------------------------------
C-----------------------------------------------------------------------
      SUBROUTINE XERBLA ( SRNAME, INFO )
*     ..    Scalar Arguments ..
      INTEGER            INFO
      CHARACTER*6        SRNAME
*     ..
*
*  Purpose
*  =======
*
*  XERBLA  is an error handler for the Level 2 BLAS routines.
*
*  It is called by the Level 2 BLAS routines if an input parameter is
*  invalid.
*
*  Installers should consider modifying the STOP statement in order to
*  call system-specific exception-handling facilities.
*
*  Parameters
*  ==========
*
*  SRNAME - CHARACTER*6.
*           On entry, SRNAME specifies the name of the routine which
*           called XERBLA.
*
*  INFO   - INTEGER.
*           On entry, INFO specifies the position of the invalid
*           parameter in the parameter-list of the calling routine.
*
*
*  Auxiliary routine for Level 2 Blas.
*
*  Written on 20-July-1986.
*
*     .. Executable Statements ..
*
      WRITE (*,99999) SRNAME, INFO
*
      STOP
*
99999 FORMAT ( ' ** On entry to ', A6, ' parameter number ', I2,
     $         ' had an illegal value' )
*
*     End of XERBLA.
*
      END
C
C-----------------------------------------------------------------------
C-----------------------------------------------------------------------
      LOGICAL FUNCTION LSAME ( CA, CB )
*     .. Scalar Arguments ..
      CHARACTER*1            CA, CB
*     ..
*
*  Purpose
*  =======
*
*  LSAME  tests if CA is the same letter as CB regardless of case.
*  CB is assumed to be an upper case letter. LSAME returns .TRUE. if
*  CA is either the same as CB or the equivalent lower case letter.
*
*  N.B. This version of the routine is only correct for ASCII code.
*       Installers must modify the routine for other character-codes.
*
*       For EBCDIC systems the constant IOFF must be changed to -64.
*       For CDC systems using 6-12 bit representations, the system-
*       specific code in comments must be activated.
*
*  Parameters
*  ==========
*
*  CA     - CHARACTER*1
*  CB     - CHARACTER*1
*           On entry, CA and CB specify characters to be compared.
*           Unchanged on exit.
*
*
*  Auxiliary routine for Level 2 Blas.
*
*  -- Written on 20-July-1986
*     Richard Hanson, Sandia National Labs.
*     Jeremy Du Croz, Nag Central Office.
*
*     .. Parameters ..
      INTEGER                IOFF
      PARAMETER            ( IOFF=32 )
*     .. Intrinsic Functions ..
      INTRINSIC              ICHAR
*     .. Executable Statements ..
*
*     Test if the characters are equal
*
      LSAME = CA .EQ. CB
*
*     Now test for equivalence
*
      IF ( .NOT.LSAME ) THEN
         LSAME = ICHAR(CA) - IOFF .EQ. ICHAR(CB)
      END IF
*
      RETURN
*
*  The following comments contain code for CDC systems using 6-12 bit
*  representations.
*
*     .. Parameters ..
*     INTEGER                ICIRFX
*     PARAMETER            ( ICIRFX=62 )
*     .. Scalar Arguments ..
*     CHARACTER*1            CB
*     .. Array Arguments ..
*     CHARACTER*1            CA(*)
*     .. Local Scalars ..
*     INTEGER                IVAL
*     .. Intrinsic Functions ..
*     INTRINSIC              ICHAR, CHAR
*     .. Executable Statements ..
*
*     See if the first character in string CA equals string CB.
*
*     LSAME = CA(1) .EQ. CB .AND. CA(1) .NE. CHAR(ICIRFX)
*
*     IF (LSAME) RETURN
*
*     The characters are not identical. Now check them for equivalence.
*     Look for the 'escape' character, circumflex, followed by the
*     letter.
*
*     IVAL = ICHAR(CA(2))
*     IF (IVAL.GE.ICHAR('A') .AND. IVAL.LE.ICHAR('Z')) THEN
*        LSAME = CA(1) .EQ. CHAR(ICIRFX) .AND. CA(2) .EQ. CB
*     END IF
*
*     RETURN
*
*     End of LSAME.
*
      END
C
C-----------------------------------------------------------------------
C-----------------------------------------------------------------------
      SUBROUTINE DGEMV(TRANS,M,N,ALPHA,A,LDA,X,INCX,BETA,Y,INCY)
*     .. Scalar Arguments ..
      DOUBLE PRECISION ALPHA,BETA
      INTEGER INCX,INCY,LDA,M,N
      CHARACTER TRANS
*     ..
*     .. Array Arguments ..
      DOUBLE PRECISION A(LDA,*),X(*),Y(*)
*     ..
*
*  Purpose
*  =======
*
*  DGEMV  performs one of the matrix-vector operations
*
*     y := alpha*A*x + beta*y,   or   y := alpha*A'*x + beta*y,
*
*  where alpha and beta are scalars, x and y are vectors and A is an
*  m by n matrix.
*
*  Arguments
*  ==========
*
*  TRANS  - CHARACTER*1.
*           On entry, TRANS specifies the operation to be performed as
*           follows:
*
*              TRANS = 'N' or 'n'   y := alpha*A*x + beta*y.
*
*              TRANS = 'T' or 't'   y := alpha*A'*x + beta*y.
*
*              TRANS = 'C' or 'c'   y := alpha*A'*x + beta*y.
*
*           Unchanged on exit.
*
*  M      - INTEGER.
*           On entry, M specifies the number of rows of the matrix A.
*           M must be at least zero.
*           Unchanged on exit.
*
*  N      - INTEGER.
*           On entry, N specifies the number of columns of the matrix A.
*           N must be at least zero.
*           Unchanged on exit.
*
*  ALPHA  - DOUBLE PRECISION.
*           On entry, ALPHA specifies the scalar alpha.
*           Unchanged on exit.
*
*  A      - DOUBLE PRECISION array of DIMENSION ( LDA, n ).
*           Before entry, the leading m by n part of the array A must
*           contain the matrix of coefficients.
*           Unchanged on exit.
*
*  LDA    - INTEGER.
*           On entry, LDA specifies the first dimension of A as declared
*           in the calling (sub) program. LDA must be at least
*           max( 1, m ).
*           Unchanged on exit.
*
*  X      - DOUBLE PRECISION array of DIMENSION at least
*           ( 1 + ( n - 1 )*abs( INCX ) ) when TRANS = 'N' or 'n'
*           and at least
*           ( 1 + ( m - 1 )*abs( INCX ) ) otherwise.
*           Before entry, the incremented array X must contain the
*           vector x.
*           Unchanged on exit.
*
*  INCX   - INTEGER.
*           On entry, INCX specifies the increment for the elements of
*           X. INCX must not be zero.
*           Unchanged on exit.
*
*  BETA   - DOUBLE PRECISION.
*           On entry, BETA specifies the scalar beta. When BETA is
*           supplied as zero then Y need not be set on input.
*           Unchanged on exit.
*
*  Y      - DOUBLE PRECISION array of DIMENSION at least
*           ( 1 + ( m - 1 )*abs( INCY ) ) when TRANS = 'N' or 'n'
*           and at least
*           ( 1 + ( n - 1 )*abs( INCY ) ) otherwise.
*           Before entry with BETA non-zero, the incremented array Y
*           must contain the vector y. On exit, Y is overwritten by the
*           updated vector y.
*
*  INCY   - INTEGER.
*           On entry, INCY specifies the increment for the elements of
*           Y. INCY must not be zero.
*           Unchanged on exit.
*
*
*  Level 2 Blas routine.
*
*  -- Written on 22-October-1986.
*     Jack Dongarra, Argonne National Lab.
*     Jeremy Du Croz, Nag Central Office.
*     Sven Hammarling, Nag Central Office.
*     Richard Hanson, Sandia National Labs.
*
*
*     .. Parameters ..
      DOUBLE PRECISION ONE,ZERO
      PARAMETER (ONE=1.0D+0,ZERO=0.0D+0)
*     ..
*     .. Local Scalars ..
      DOUBLE PRECISION TEMP
      INTEGER I,INFO,IX,IY,J,JX,JY,KX,KY,LENX,LENY
*     ..
*     .. External Functions ..
      LOGICAL LSAME
      EXTERNAL LSAME
*     ..
*     .. External Subroutines ..
      EXTERNAL XERBLA
*     ..
*     .. Intrinsic Functions ..
      INTRINSIC MAX
*     ..
*
*     Test the input parameters.
*
      INFO = 0
      IF (.NOT.LSAME(TRANS,'N') .AND. .NOT.LSAME(TRANS,'T') .AND.
     +    .NOT.LSAME(TRANS,'C')) THEN
          INFO = 1
      ELSE IF (M.LT.0) THEN
          INFO = 2
      ELSE IF (N.LT.0) THEN
          INFO = 3
      ELSE IF (LDA.LT.MAX(1,M)) THEN
          INFO = 6
      ELSE IF (INCX.EQ.0) THEN
          INFO = 8
      ELSE IF (INCY.EQ.0) THEN
          INFO = 11
      END IF
      IF (INFO.NE.0) THEN
          CALL XERBLA('DGEMV ',INFO)
          RETURN
      END IF
*
*     Quick return if possible.
*
      IF ((M.EQ.0) .OR. (N.EQ.0) .OR.
     +    ((ALPHA.EQ.ZERO).AND. (BETA.EQ.ONE))) RETURN
*
*     Set  LENX  and  LENY, the lengths of the vectors x and y, and set
*     up the start points in  X  and  Y.
*
      IF (LSAME(TRANS,'N')) THEN
          LENX = N
          LENY = M
      ELSE
          LENX = M
          LENY = N
      END IF
      IF (INCX.GT.0) THEN
          KX = 1
      ELSE
          KX = 1 - (LENX-1)*INCX
      END IF
      IF (INCY.GT.0) THEN
          KY = 1
      ELSE
          KY = 1 - (LENY-1)*INCY
      END IF
*
*     Start the operations. In this version the elements of A are
*     accessed sequentially with one pass through A.
*
*     First form  y := beta*y.
*
      IF (BETA.NE.ONE) THEN
          IF (INCY.EQ.1) THEN
              IF (BETA.EQ.ZERO) THEN
                  DO 10 I = 1,LENY
                      Y(I) = ZERO
   10             CONTINUE
              ELSE
                  DO 20 I = 1,LENY
                      Y(I) = BETA*Y(I)
   20             CONTINUE
              END IF
          ELSE
              IY = KY
              IF (BETA.EQ.ZERO) THEN
                  DO 30 I = 1,LENY
                      Y(IY) = ZERO
                      IY = IY + INCY
   30             CONTINUE
              ELSE
                  DO 40 I = 1,LENY
                      Y(IY) = BETA*Y(IY)
                      IY = IY + INCY
   40             CONTINUE
              END IF
          END IF
      END IF
      IF (ALPHA.EQ.ZERO) RETURN
      IF (LSAME(TRANS,'N')) THEN
*
*        Form  y := alpha*A*x + y.
*
          JX = KX
          IF (INCY.EQ.1) THEN
              DO 60 J = 1,N
                  IF (X(JX).NE.ZERO) THEN
                      TEMP = ALPHA*X(JX)
                      DO 50 I = 1,M
                          Y(I) = Y(I) + TEMP*A(I,J)
   50                 CONTINUE
                  END IF
                  JX = JX + INCX
   60         CONTINUE
          ELSE
              DO 80 J = 1,N
                  IF (X(JX).NE.ZERO) THEN
                      TEMP = ALPHA*X(JX)
                      IY = KY
                      DO 70 I = 1,M
                          Y(IY) = Y(IY) + TEMP*A(I,J)
                          IY = IY + INCY
   70                 CONTINUE
                  END IF
                  JX = JX + INCX
   80         CONTINUE
          END IF
      ELSE
*
*        Form  y := alpha*A'*x + y.
*
          JY = KY
          IF (INCX.EQ.1) THEN
              DO 100 J = 1,N
                  TEMP = ZERO
                  DO 90 I = 1,M
                      TEMP = TEMP + A(I,J)*X(I)
   90             CONTINUE
                  Y(JY) = Y(JY) + ALPHA*TEMP
                  JY = JY + INCY
  100         CONTINUE
          ELSE
              DO 120 J = 1,N
                  TEMP = ZERO
                  IX = KX
                  DO 110 I = 1,M
                      TEMP = TEMP + A(I,J)*X(IX)
                      IX = IX + INCX
  110             CONTINUE
                  Y(JY) = Y(JY) + ALPHA*TEMP
                  JY = JY + INCY
  120         CONTINUE
          END IF
      END IF
*
      RETURN
*
*     End of DGEMV .
*
      END
C
C-----------------------------------------------------------------------
C-----------------------------------------------------------------------
      SUBROUTINE DTRMV(UPLO,TRANS,DIAG,N,A,LDA,X,INCX)
*     .. Scalar Arguments ..
      INTEGER INCX,LDA,N
      CHARACTER DIAG,TRANS,UPLO
*     ..
*     .. Array Arguments ..
      DOUBLE PRECISION A(LDA,*),X(*)
*     ..
*
*  Purpose
*  =======
*
*  DTRMV  performs one of the matrix-vector operations
*
*     x := A*x,   or   x := A'*x,
*
*  where x is an n element vector and  A is an n by n unit, or non-unit,
*  upper or lower triangular matrix.
*
*  Arguments
*  ==========
*
*  UPLO   - CHARACTER*1.
*           On entry, UPLO specifies whether the matrix is an upper or
*           lower triangular matrix as follows:
*
*              UPLO = 'U' or 'u'   A is an upper triangular matrix.
*
*              UPLO = 'L' or 'l'   A is a lower triangular matrix.
*
*           Unchanged on exit.
*
*  TRANS  - CHARACTER*1.
*           On entry, TRANS specifies the operation to be performed as
*           follows:
*
*              TRANS = 'N' or 'n'   x := A*x.
*
*              TRANS = 'T' or 't'   x := A'*x.
*
*              TRANS = 'C' or 'c'   x := A'*x.
*
*           Unchanged on exit.
*
*  DIAG   - CHARACTER*1.
*           On entry, DIAG specifies whether or not A is unit
*           triangular as follows:
*
*              DIAG = 'U' or 'u'   A is assumed to be unit triangular.
*
*              DIAG = 'N' or 'n'   A is not assumed to be unit
*                                  triangular.
*
*           Unchanged on exit.
*
*  N      - INTEGER.
*           On entry, N specifies the order of the matrix A.
*           N must be at least zero.
*           Unchanged on exit.
*
*  A      - DOUBLE PRECISION array of DIMENSION ( LDA, n ).
*           Before entry with  UPLO = 'U' or 'u', the leading n by n
*           upper triangular part of the array A must contain the upper
*           triangular matrix and the strictly lower triangular part of
*           A is not referenced.
*           Before entry with UPLO = 'L' or 'l', the leading n by n
*           lower triangular part of the array A must contain the lower
*           triangular matrix and the strictly upper triangular part of
*           A is not referenced.
*           Note that when  DIAG = 'U' or 'u', the diagonal elements of
*           A are not referenced either, but are assumed to be unity.
*           Unchanged on exit.
*
*  LDA    - INTEGER.
*           On entry, LDA specifies the first dimension of A as declared
*           in the calling (sub) program. LDA must be at least
*           max( 1, n ).
*           Unchanged on exit.
*
*  X      - DOUBLE PRECISION array of dimension at least
*           ( 1 + ( n - 1 )*abs( INCX ) ).
*           Before entry, the incremented array X must contain the n
*           element vector x. On exit, X is overwritten with the
*           tranformed vector x.
*
*  INCX   - INTEGER.
*           On entry, INCX specifies the increment for the elements of
*           X. INCX must not be zero.
*           Unchanged on exit.
*
*
*  Level 2 Blas routine.
*
*  -- Written on 22-October-1986.
*     Jack Dongarra, Argonne National Lab.
*     Jeremy Du Croz, Nag Central Office.
*     Sven Hammarling, Nag Central Office.
*     Richard Hanson, Sandia National Labs.
*
*
*     .. Parameters ..
      DOUBLE PRECISION ZERO
      PARAMETER (ZERO=0.0D+0)
*     ..
*     .. Local Scalars ..
      DOUBLE PRECISION TEMP
      INTEGER I,INFO,IX,J,JX,KX
      LOGICAL NOUNIT
*     ..
*     .. External Functions ..
      LOGICAL LSAME
      EXTERNAL LSAME
*     ..
*     .. External Subroutines ..
      EXTERNAL XERBLA
*     ..
*     .. Intrinsic Functions ..
      INTRINSIC MAX
*     ..
*
*     Test the input parameters.
*
      INFO = 0
      IF (.NOT.LSAME(UPLO,'U') .AND. .NOT.LSAME(UPLO,'L')) THEN
          INFO = 1
      ELSE IF (.NOT.LSAME(TRANS,'N') .AND. .NOT.LSAME(TRANS,'T') .AND.
     +         .NOT.LSAME(TRANS,'C')) THEN
          INFO = 2
      ELSE IF (.NOT.LSAME(DIAG,'U') .AND. .NOT.LSAME(DIAG,'N')) THEN
          INFO = 3
      ELSE IF (N.LT.0) THEN
          INFO = 4
      ELSE IF (LDA.LT.MAX(1,N)) THEN
          INFO = 6
      ELSE IF (INCX.EQ.0) THEN
          INFO = 8
      END IF
      IF (INFO.NE.0) THEN
          CALL XERBLA('DTRMV ',INFO)
          RETURN
      END IF
*
*     Quick return if possible.
*
      IF (N.EQ.0) RETURN
*
      NOUNIT = LSAME(DIAG,'N')
*
*     Set up the start point in X if the increment is not unity. This
*     will be  ( N - 1 )*INCX  too small for descending loops.
*
      IF (INCX.LE.0) THEN
          KX = 1 - (N-1)*INCX
      ELSE IF (INCX.NE.1) THEN
          KX = 1
      END IF
*
*     Start the operations. In this version the elements of A are
*     accessed sequentially with one pass through A.
*
      IF (LSAME(TRANS,'N')) THEN
*
*        Form  x := A*x.
*
          IF (LSAME(UPLO,'U')) THEN
              IF (INCX.EQ.1) THEN
                  DO 20 J = 1,N
                      IF (X(J).NE.ZERO) THEN
                          TEMP = X(J)
                          DO 10 I = 1,J - 1
                              X(I) = X(I) + TEMP*A(I,J)
   10                     CONTINUE
                          IF (NOUNIT) X(J) = X(J)*A(J,J)
                      END IF
   20             CONTINUE
              ELSE
                  JX = KX
                  DO 40 J = 1,N
                      IF (X(JX).NE.ZERO) THEN
                          TEMP = X(JX)
                          IX = KX
                          DO 30 I = 1,J - 1
                              X(IX) = X(IX) + TEMP*A(I,J)
                              IX = IX + INCX
   30                     CONTINUE
                          IF (NOUNIT) X(JX) = X(JX)*A(J,J)
                      END IF
                      JX = JX + INCX
   40             CONTINUE
              END IF
          ELSE
              IF (INCX.EQ.1) THEN
                  DO 60 J = N,1,-1
                      IF (X(J).NE.ZERO) THEN
                          TEMP = X(J)
                          DO 50 I = N,J + 1,-1
                              X(I) = X(I) + TEMP*A(I,J)
   50                     CONTINUE
                          IF (NOUNIT) X(J) = X(J)*A(J,J)
                      END IF
   60             CONTINUE
              ELSE
                  KX = KX + (N-1)*INCX
                  JX = KX
                  DO 80 J = N,1,-1
                      IF (X(JX).NE.ZERO) THEN
                          TEMP = X(JX)
                          IX = KX
                          DO 70 I = N,J + 1,-1
                              X(IX) = X(IX) + TEMP*A(I,J)
                              IX = IX - INCX
   70                     CONTINUE
                          IF (NOUNIT) X(JX) = X(JX)*A(J,J)
                      END IF
                      JX = JX - INCX
   80             CONTINUE
              END IF
          END IF
      ELSE
*
*        Form  x := A'*x.
*
          IF (LSAME(UPLO,'U')) THEN
              IF (INCX.EQ.1) THEN
                  DO 100 J = N,1,-1
                      TEMP = X(J)
                      IF (NOUNIT) TEMP = TEMP*A(J,J)
                      DO 90 I = J - 1,1,-1
                          TEMP = TEMP + A(I,J)*X(I)
   90                 CONTINUE
                      X(J) = TEMP
  100             CONTINUE
              ELSE
                  JX = KX + (N-1)*INCX
                  DO 120 J = N,1,-1
                      TEMP = X(JX)
                      IX = JX
                      IF (NOUNIT) TEMP = TEMP*A(J,J)
                      DO 110 I = J - 1,1,-1
                          IX = IX - INCX
                          TEMP = TEMP + A(I,J)*X(IX)
  110                 CONTINUE
                      X(JX) = TEMP
                      JX = JX - INCX
  120             CONTINUE
              END IF
          ELSE
              IF (INCX.EQ.1) THEN
                  DO 140 J = 1,N
                      TEMP = X(J)
                      IF (NOUNIT) TEMP = TEMP*A(J,J)
                      DO 130 I = J + 1,N
                          TEMP = TEMP + A(I,J)*X(I)
  130                 CONTINUE
                      X(J) = TEMP
  140             CONTINUE
              ELSE
                  JX = KX
                  DO 160 J = 1,N
                      TEMP = X(JX)
                      IX = JX
                      IF (NOUNIT) TEMP = TEMP*A(J,J)
                      DO 150 I = J + 1,N
                          IX = IX + INCX
                          TEMP = TEMP + A(I,J)*X(IX)
  150                 CONTINUE
                      X(JX) = TEMP
                      JX = JX + INCX
  160             CONTINUE
              END IF
          END IF
      END IF
*
      RETURN
*
*     End of DTRMV .
*
      END
C
C-----------------------------------------------------------------------
C-----------------------------------------------------------------------
      SUBROUTINE DGER  ( M, N, ALPHA, X, INCX, Y, INCY, A, LDA )
*     .. Scalar Arguments ..
      DOUBLE PRECISION   ALPHA
      INTEGER            INCX, INCY, LDA, M, N
*     .. Array Arguments ..
      DOUBLE PRECISION   A( LDA, * ), X( * ), Y( * )
*     ..
*
*  Purpose
*  =======
*
*  DGER   performs the rank 1 operation
*
*     A := alpha*x*y' + A,
*
*  where alpha is a scalar, x is an m element vector, y is an n element
*  vector and A is an m by n matrix.
*
*  Parameters
*  ==========
*
*  M      - INTEGER.
*           On entry, M specifies the number of rows of the matrix A.
*           M must be at least zero.
*           Unchanged on exit.
*
*  N      - INTEGER.
*           On entry, N specifies the number of columns of the matrix A.
*           N must be at least zero.
*           Unchanged on exit.
*
*  ALPHA  - DOUBLE PRECISION.
*           On entry, ALPHA specifies the scalar alpha.
*           Unchanged on exit.
*
*  X      - DOUBLE PRECISION array of dimension at least
*           ( 1 + ( m - 1 )*abs( INCX ) ).
*           Before entry, the incremented array X must contain the m
*           element vector x.
*           Unchanged on exit.
*
*  INCX   - INTEGER.
*           On entry, INCX specifies the increment for the elements of
*           X. INCX must not be zero.
*           Unchanged on exit.
*
*  Y      - DOUBLE PRECISION array of dimension at least
*           ( 1 + ( n - 1 )*abs( INCY ) ).
*           Before entry, the incremented array Y must contain the n
*           element vector y.
*           Unchanged on exit.
*
*  INCY   - INTEGER.
*           On entry, INCY specifies the increment for the elements of
*           Y. INCY must not be zero.
*           Unchanged on exit.
*
*  A      - DOUBLE PRECISION array of DIMENSION ( LDA, n ).
*           Before entry, the leading m by n part of the array A must
*           contain the matrix of coefficients. On exit, A is
*           overwritten by the updated matrix.
*
*  LDA    - INTEGER.
*           On entry, LDA specifies the first dimension of A as declared
*           in the calling (sub) program. LDA must be at least
*           max( 1, m ).
*           Unchanged on exit.
*
*
*  Level 2 Blas routine.
*
*  -- Written on 22-October-1986.
*     Jack Dongarra, Argonne National Lab.
*     Jeremy Du Croz, Nag Central Office.
*     Sven Hammarling, Nag Central Office.
*     Richard Hanson, Sandia National Labs.
*
*
*     .. Parameters ..
      DOUBLE PRECISION   ZERO
      PARAMETER        ( ZERO = 0.0D+0 )
*     .. Local Scalars ..
      DOUBLE PRECISION   TEMP
      INTEGER            I, INFO, IX, J, JY, KX
*     .. External Subroutines ..
      EXTERNAL           XERBLA
*     .. Intrinsic Functions ..
      INTRINSIC          MAX
*     ..
*     .. Executable Statements ..
*
*     Test the input parameters.
*
      INFO = 0
      IF     ( M.LT.0 )THEN
         INFO = 1
      ELSE IF( N.LT.0 )THEN
         INFO = 2
      ELSE IF( INCX.EQ.0 )THEN
         INFO = 5
      ELSE IF( INCY.EQ.0 )THEN
         INFO = 7
      ELSE IF( LDA.LT.MAX( 1, M ) )THEN
         INFO = 9
      END IF
      IF( INFO.NE.0 )THEN
         CALL XERBLA( 'DGER  ', INFO )
         RETURN
      END IF
*
*     Quick return if possible.
*
      IF( ( M.EQ.0 ).OR.( N.EQ.0 ).OR.( ALPHA.EQ.ZERO ) )
     $   RETURN
*
*     Start the operations. In this version the elements of A are
*     accessed sequentially with one pass through A.
*
      IF( INCY.GT.0 )THEN
         JY = 1
      ELSE
         JY = 1 - ( N - 1 )*INCY
      END IF
      IF( INCX.EQ.1 )THEN
         DO 20, J = 1, N
            IF( Y( JY ).NE.ZERO )THEN
               TEMP = ALPHA*Y( JY )
               DO 10, I = 1, M
                  A( I, J ) = A( I, J ) + X( I )*TEMP
   10          CONTINUE
            END IF
            JY = JY + INCY
   20    CONTINUE
      ELSE
         IF( INCX.GT.0 )THEN
            KX = 1
         ELSE
            KX = 1 - ( M - 1 )*INCX
         END IF
         DO 40, J = 1, N
            IF( Y( JY ).NE.ZERO )THEN
               TEMP = ALPHA*Y( JY )
               IX   = KX
               DO 30, I = 1, M
                  A( I, J ) = A( I, J ) + X( IX )*TEMP
                  IX        = IX        + INCX
   30          CONTINUE
            END IF
            JY = JY + INCY
   40    CONTINUE
      END IF
*
      RETURN
*
*     End of DGER  .
*
      END
C
C-----------------------------------------------------------------------
C-----------------------------------------------------------------------
C  BLAS-3 routines needed in the computation of Floquet multipliers
C-----------------------------------------------------------------------
C-----------------------------------------------------------------------
      SUBROUTINE DGEMM ( TRANSA, TRANSB, M, N, K, ALPHA, A, LDA, B, LDB,
     $                   BETA, C, LDC )
*     .. Scalar Arguments ..
      CHARACTER*1        TRANSA, TRANSB
      INTEGER            M, N, K, LDA, LDB, LDC
      DOUBLE PRECISION   ALPHA, BETA
*     .. Array Arguments ..
      DOUBLE PRECISION   A( LDA, * ), B( LDB, * ), C( LDC, * )
*     ..
*
*  Purpose
*  =======
*
*  DGEMM  performs one of the matrix-matrix operations
*
*     C := alpha*op( A )*op( B ) + beta*C,
*
*  where  op( X ) is one of
*
*     op( X ) = X   or   op( X ) = X',
*
*  alpha and beta are scalars, and A, B and C are matrices, with op( A )
*  an m by k matrix,  op( B )  a  k by n matrix and  C an m by n matrix.
*
*  Parameters
*  ==========
*
*  TRANSA - CHARACTER*1.
*           On entry, TRANSA specifies the form of op( A ) to be used in
*           the matrix multiplication as follows:
*
*              TRANSA = 'N' or 'n',  op( A ) = A.
*
*              TRANSA = 'T' or 't',  op( A ) = A'.
*
*              TRANSA = 'C' or 'c',  op( A ) = A'.
*
*           Unchanged on exit.
*
*  TRANSB - CHARACTER*1.
*           On entry, TRANSB specifies the form of op( B ) to be used in
*           the matrix multiplication as follows:
*
*              TRANSB = 'N' or 'n',  op( B ) = B.
*
*              TRANSB = 'T' or 't',  op( B ) = B'.
*
*              TRANSB = 'C' or 'c',  op( B ) = B'.
*
*           Unchanged on exit.
*
*  M      - INTEGER.
*           On entry,  M  specifies  the number  of rows  of the  matrix
*           op( A )  and of the  matrix  C.  M  must  be at least  zero.
*           Unchanged on exit.
*
*  N      - INTEGER.
*           On entry,  N  specifies the number  of columns of the matrix
*           op( B ) and the number of columns of the matrix C. N must be
*           at least zero.
*           Unchanged on exit.
*
*  K      - INTEGER.
*           On entry,  K  specifies  the number of columns of the matrix
*           op( A ) and the number of rows of the matrix op( B ). K must
*           be at least  zero.
*           Unchanged on exit.
*
*  ALPHA  - DOUBLE PRECISION.
*           On entry, ALPHA specifies the scalar alpha.
*           Unchanged on exit.
*
*  A      - DOUBLE PRECISION array of DIMENSION ( LDA, ka ), where ka is
*           k  when  TRANSA = 'N' or 'n',  and is  m  otherwise.
*           Before entry with  TRANSA = 'N' or 'n',  the leading  m by k
*           part of the array  A  must contain the matrix  A,  otherwise
*           the leading  k by m  part of the array  A  must contain  the
*           matrix A.
*           Unchanged on exit.
*
*  LDA    - INTEGER.
*           On entry, LDA specifies the first dimension of A as declared
*           in the calling (sub) program. When  TRANSA = 'N' or 'n' then
*           LDA must be at least  max( 1, m ), otherwise  LDA must be at
*           least  max( 1, k ).
*           Unchanged on exit.
*
*  B      - DOUBLE PRECISION array of DIMENSION ( LDB, kb ), where kb is
*           n  when  TRANSB = 'N' or 'n',  and is  k  otherwise.
*           Before entry with  TRANSB = 'N' or 'n',  the leading  k by n
*           part of the array  B  must contain the matrix  B,  otherwise
*           the leading  n by k  part of the array  B  must contain  the
*           matrix B.
*           Unchanged on exit.
*
*  LDB    - INTEGER.
*           On entry, LDB specifies the first dimension of B as declared
*           in the calling (sub) program. When  TRANSB = 'N' or 'n' then
*           LDB must be at least  max( 1, k ), otherwise  LDB must be at
*           least  max( 1, n ).
*           Unchanged on exit.
*
*  BETA   - DOUBLE PRECISION.
*           On entry,  BETA  specifies the scalar  beta.  When  BETA  is
*           supplied as zero then C need not be set on input.
*           Unchanged on exit.
*
*  C      - DOUBLE PRECISION array of DIMENSION ( LDC, n ).
*           Before entry, the leading  m by n  part of the array  C must
*           contain the matrix  C,  except when  beta  is zero, in which
*           case C need not be set on entry.
*           On exit, the array  C  is overwritten by the  m by n  matrix
*           ( alpha*op( A )*op( B ) + beta*C ).
*
*  LDC    - INTEGER.
*           On entry, LDC specifies the first dimension of C as declared
*           in  the  calling  (sub)  program.   LDC  must  be  at  least
*           max( 1, m ).
*           Unchanged on exit.
*
*
*  Level 3 Blas routine.
*
*  -- Written on 8-February-1989.
*     Jack Dongarra, Argonne National Laboratory.
*     Iain Duff, AERE Harwell.
*     Jeremy Du Croz, Numerical Algorithms Group Ltd.
*     Sven Hammarling, Numerical Algorithms Group Ltd.
*
*
*     .. External Functions ..
      LOGICAL            LSAME
      EXTERNAL           LSAME
*     .. External Subroutines ..
      EXTERNAL           XERBLA
*     .. Intrinsic Functions ..
      INTRINSIC          MAX
*     .. Local Scalars ..
      LOGICAL            NOTA, NOTB
      INTEGER            I, INFO, J, L, NCOLA, NROWA, NROWB
      DOUBLE PRECISION   TEMP
*     .. Parameters ..
      DOUBLE PRECISION   ONE         , ZERO
      PARAMETER        ( ONE = 1.0D+0, ZERO = 0.0D+0 )
*     ..
*     .. Executable Statements ..
*
*     Set  NOTA  and  NOTB  as  true if  A  and  B  respectively are not
*     transposed and set  NROWA, NCOLA and  NROWB  as the number of rows
*     and  columns of  A  and the  number of  rows  of  B  respectively.
*
      NOTA  = LSAME( TRANSA, 'N' )
      NOTB  = LSAME( TRANSB, 'N' )
      IF( NOTA )THEN
         NROWA = M
         NCOLA = K
      ELSE
         NROWA = K
         NCOLA = M
      END IF
      IF( NOTB )THEN
         NROWB = K
      ELSE
         NROWB = N
      END IF
*
*     Test the input parameters.
*
      INFO = 0
      IF(      ( .NOT.NOTA                 ).AND.
     $         ( .NOT.LSAME( TRANSA, 'C' ) ).AND.
     $         ( .NOT.LSAME( TRANSA, 'T' ) )      )THEN
         INFO = 1
      ELSE IF( ( .NOT.NOTB                 ).AND.
     $         ( .NOT.LSAME( TRANSB, 'C' ) ).AND.
     $         ( .NOT.LSAME( TRANSB, 'T' ) )      )THEN
         INFO = 2
      ELSE IF( M  .LT.0               )THEN
         INFO = 3
      ELSE IF( N  .LT.0               )THEN
         INFO = 4
      ELSE IF( K  .LT.0               )THEN
         INFO = 5
      ELSE IF( LDA.LT.MAX( 1, NROWA ) )THEN
         INFO = 8
      ELSE IF( LDB.LT.MAX( 1, NROWB ) )THEN
         INFO = 10
      ELSE IF( LDC.LT.MAX( 1, M     ) )THEN
         INFO = 13
      END IF
      IF( INFO.NE.0 )THEN
         CALL XERBLA( 'DGEMM ', INFO )
         RETURN
      END IF
*
*     Quick return if possible.
*
      IF( ( M.EQ.0 ).OR.( N.EQ.0 ).OR.
     $    ( ( ( ALPHA.EQ.ZERO ).OR.( K.EQ.0 ) ).AND.( BETA.EQ.ONE ) ) )
     $   RETURN
*
*     And if  alpha.eq.zero.
*
      IF( ALPHA.EQ.ZERO )THEN
         IF( BETA.EQ.ZERO )THEN
            DO 20, J = 1, N
               DO 10, I = 1, M
                  C( I, J ) = ZERO
   10          CONTINUE
   20       CONTINUE
         ELSE
            DO 40, J = 1, N
               DO 30, I = 1, M
                  C( I, J ) = BETA*C( I, J )
   30          CONTINUE
   40       CONTINUE
         END IF
         RETURN
      END IF
*
*     Start the operations.
*
      IF( NOTB )THEN
         IF( NOTA )THEN
*
*           Form  C := alpha*A*B + beta*C.
*
            DO 90, J = 1, N
               IF( BETA.EQ.ZERO )THEN
                  DO 50, I = 1, M
                     C( I, J ) = ZERO
   50             CONTINUE
               ELSE IF( BETA.NE.ONE )THEN
                  DO 60, I = 1, M
                     C( I, J ) = BETA*C( I, J )
   60             CONTINUE
               END IF
               DO 80, L = 1, K
                  IF( B( L, J ).NE.ZERO )THEN
                     TEMP = ALPHA*B( L, J )
                     DO 70, I = 1, M
                        C( I, J ) = C( I, J ) + TEMP*A( I, L )
   70                CONTINUE
                  END IF
   80          CONTINUE
   90       CONTINUE
         ELSE
*
*           Form  C := alpha*A'*B + beta*C
*
            DO 120, J = 1, N
               DO 110, I = 1, M
                  TEMP = ZERO
                  DO 100, L = 1, K
                     TEMP = TEMP + A( L, I )*B( L, J )
  100             CONTINUE
                  IF( BETA.EQ.ZERO )THEN
                     C( I, J ) = ALPHA*TEMP
                  ELSE
                     C( I, J ) = ALPHA*TEMP + BETA*C( I, J )
                  END IF
  110          CONTINUE
  120       CONTINUE
         END IF
      ELSE
         IF( NOTA )THEN
*
*           Form  C := alpha*A*B' + beta*C
*
            DO 170, J = 1, N
               IF( BETA.EQ.ZERO )THEN
                  DO 130, I = 1, M
                     C( I, J ) = ZERO
  130             CONTINUE
               ELSE IF( BETA.NE.ONE )THEN
                  DO 140, I = 1, M
                     C( I, J ) = BETA*C( I, J )
  140             CONTINUE
               END IF
               DO 160, L = 1, K
                  IF( B( J, L ).NE.ZERO )THEN
                     TEMP = ALPHA*B( J, L )
                     DO 150, I = 1, M
                        C( I, J ) = C( I, J ) + TEMP*A( I, L )
  150                CONTINUE
                  END IF
  160          CONTINUE
  170       CONTINUE
         ELSE
*
*           Form  C := alpha*A'*B' + beta*C
*
            DO 200, J = 1, N
               DO 190, I = 1, M
                  TEMP = ZERO
                  DO 180, L = 1, K
                     TEMP = TEMP + A( L, I )*B( J, L )
  180             CONTINUE
                  IF( BETA.EQ.ZERO )THEN
                     C( I, J ) = ALPHA*TEMP
                  ELSE
                     C( I, J ) = ALPHA*TEMP + BETA*C( I, J )
                  END IF
  190          CONTINUE
  200       CONTINUE
         END IF
      END IF
*
      RETURN
*
*     End of DGEMM .
*
      END
C
C-----------------------------------------------------------------------
C-----------------------------------------------------------------------
      SUBROUTINE DTRMM(SIDE,UPLO,TRANSA,DIAG,M,N,ALPHA,A,LDA,B,LDB)
*     .. Scalar Arguments ..
      DOUBLE PRECISION ALPHA
      INTEGER LDA,LDB,M,N
      CHARACTER DIAG,SIDE,TRANSA,UPLO
*     ..
*     .. Array Arguments ..
      DOUBLE PRECISION A(LDA,*),B(LDB,*)
*     ..
*
*  Purpose
*  =======
*
*  DTRMM  performs one of the matrix-matrix operations
*
*     B := alpha*op( A )*B,   or   B := alpha*B*op( A ),
*
*  where  alpha  is a scalar,  B  is an m by n matrix,  A  is a unit, or
*  non-unit,  upper or lower triangular matrix  and  op( A )  is one  of
*
*     op( A ) = A   or   op( A ) = A'.
*
*  Arguments
*  ==========
*
*  SIDE   - CHARACTER*1.
*           On entry,  SIDE specifies whether  op( A ) multiplies B from
*           the left or right as follows:
*
*              SIDE = 'L' or 'l'   B := alpha*op( A )*B.
*
*              SIDE = 'R' or 'r'   B := alpha*B*op( A ).
*
*           Unchanged on exit.
*
*  UPLO   - CHARACTER*1.
*           On entry, UPLO specifies whether the matrix A is an upper or
*           lower triangular matrix as follows:
*
*              UPLO = 'U' or 'u'   A is an upper triangular matrix.
*
*              UPLO = 'L' or 'l'   A is a lower triangular matrix.
*
*           Unchanged on exit.
*
*  TRANSA - CHARACTER*1.
*           On entry, TRANSA specifies the form of op( A ) to be used in
*           the matrix multiplication as follows:
*
*              TRANSA = 'N' or 'n'   op( A ) = A.
*
*              TRANSA = 'T' or 't'   op( A ) = A'.
*
*              TRANSA = 'C' or 'c'   op( A ) = A'.
*
*           Unchanged on exit.
*
*  DIAG   - CHARACTER*1.
*           On entry, DIAG specifies whether or not A is unit triangular
*           as follows:
*
*              DIAG = 'U' or 'u'   A is assumed to be unit triangular.
*
*              DIAG = 'N' or 'n'   A is not assumed to be unit
*                                  triangular.
*
*           Unchanged on exit.
*
*  M      - INTEGER.
*           On entry, M specifies the number of rows of B. M must be at
*           least zero.
*           Unchanged on exit.
*
*  N      - INTEGER.
*           On entry, N specifies the number of columns of B.  N must be
*           at least zero.
*           Unchanged on exit.
*
*  ALPHA  - DOUBLE PRECISION.
*           On entry,  ALPHA specifies the scalar  alpha. When  alpha is
*           zero then  A is not referenced and  B need not be set before
*           entry.
*           Unchanged on exit.
*
*  A      - DOUBLE PRECISION array of DIMENSION ( LDA, k ), where k is m
*           when  SIDE = 'L' or 'l'  and is  n  when  SIDE = 'R' or 'r'.
*           Before entry  with  UPLO = 'U' or 'u',  the  leading  k by k
*           upper triangular part of the array  A must contain the upper
*           triangular matrix  and the strictly lower triangular part of
*           A is not referenced.
*           Before entry  with  UPLO = 'L' or 'l',  the  leading  k by k
*           lower triangular part of the array  A must contain the lower
*           triangular matrix  and the strictly upper triangular part of
*           A is not referenced.
*           Note that when  DIAG = 'U' or 'u',  the diagonal elements of
*           A  are not referenced either,  but are assumed to be  unity.
*           Unchanged on exit.
*
*  LDA    - INTEGER.
*           On entry, LDA specifies the first dimension of A as declared
*           in the calling (sub) program.  When  SIDE = 'L' or 'l'  then
*           LDA  must be at least  max( 1, m ),  when  SIDE = 'R' or 'r'
*           then LDA must be at least max( 1, n ).
*           Unchanged on exit.
*
*  B      - DOUBLE PRECISION array of DIMENSION ( LDB, n ).
*           Before entry,  the leading  m by n part of the array  B must
*           contain the matrix  B,  and  on exit  is overwritten  by the
*           transformed matrix.
*
*  LDB    - INTEGER.
*           On entry, LDB specifies the first dimension of B as declared
*           in  the  calling  (sub)  program.   LDB  must  be  at  least
*           max( 1, m ).
*           Unchanged on exit.
*
*
*  Level 3 Blas routine.
*
*  -- Written on 8-February-1989.
*     Jack Dongarra, Argonne National Laboratory.
*     Iain Duff, AERE Harwell.
*     Jeremy Du Croz, Numerical Algorithms Group Ltd.
*     Sven Hammarling, Numerical Algorithms Group Ltd.
*
*
*     .. External Functions ..
      LOGICAL LSAME
      EXTERNAL LSAME
*     ..
*     .. External Subroutines ..
      EXTERNAL XERBLA
*     ..
*     .. Intrinsic Functions ..
      INTRINSIC MAX
*     ..
*     .. Local Scalars ..
      DOUBLE PRECISION TEMP
      INTEGER I,INFO,J,K,NROWA
      LOGICAL LSIDE,NOUNIT,UPPER
*     ..
*     .. Parameters ..
      DOUBLE PRECISION ONE,ZERO
      PARAMETER (ONE=1.0D+0,ZERO=0.0D+0)
*     ..
*
*     Test the input parameters.
*
      LSIDE = LSAME(SIDE,'L')
      IF (LSIDE) THEN
          NROWA = M
      ELSE
          NROWA = N
      END IF
      NOUNIT = LSAME(DIAG,'N')
      UPPER = LSAME(UPLO,'U')
*
      INFO = 0
      IF ((.NOT.LSIDE) .AND. (.NOT.LSAME(SIDE,'R'))) THEN
          INFO = 1
      ELSE IF ((.NOT.UPPER) .AND. (.NOT.LSAME(UPLO,'L'))) THEN
          INFO = 2
      ELSE IF ((.NOT.LSAME(TRANSA,'N')) .AND.
     +         (.NOT.LSAME(TRANSA,'T')) .AND.
     +         (.NOT.LSAME(TRANSA,'C'))) THEN
          INFO = 3
      ELSE IF ((.NOT.LSAME(DIAG,'U')) .AND. (.NOT.LSAME(DIAG,'N'))) THEN
          INFO = 4
      ELSE IF (M.LT.0) THEN
          INFO = 5
      ELSE IF (N.LT.0) THEN
          INFO = 6
      ELSE IF (LDA.LT.MAX(1,NROWA)) THEN
          INFO = 9
      ELSE IF (LDB.LT.MAX(1,M)) THEN
          INFO = 11
      END IF
      IF (INFO.NE.0) THEN
          CALL XERBLA('DTRMM ',INFO)
          RETURN
      END IF
*
*     Quick return if possible.
*
      IF (M.EQ.0 .OR. N.EQ.0) RETURN
*
*     And when  alpha.eq.zero.
*
      IF (ALPHA.EQ.ZERO) THEN
          DO 20 J = 1,N
              DO 10 I = 1,M
                  B(I,J) = ZERO
   10         CONTINUE
   20     CONTINUE
          RETURN
      END IF
*
*     Start the operations.
*
      IF (LSIDE) THEN
          IF (LSAME(TRANSA,'N')) THEN
*
*           Form  B := alpha*A*B.
*
              IF (UPPER) THEN
                  DO 50 J = 1,N
                      DO 40 K = 1,M
                          IF (B(K,J).NE.ZERO) THEN
                              TEMP = ALPHA*B(K,J)
                              DO 30 I = 1,K - 1
                                  B(I,J) = B(I,J) + TEMP*A(I,K)
   30                         CONTINUE
                              IF (NOUNIT) TEMP = TEMP*A(K,K)
                              B(K,J) = TEMP
                          END IF
   40                 CONTINUE
   50             CONTINUE
              ELSE
                  DO 80 J = 1,N
                      DO 70 K = M,1,-1
                          IF (B(K,J).NE.ZERO) THEN
                              TEMP = ALPHA*B(K,J)
                              B(K,J) = TEMP
                              IF (NOUNIT) B(K,J) = B(K,J)*A(K,K)
                              DO 60 I = K + 1,M
                                  B(I,J) = B(I,J) + TEMP*A(I,K)
   60                         CONTINUE
                          END IF
   70                 CONTINUE
   80             CONTINUE
              END IF
          ELSE
*
*           Form  B := alpha*A'*B.
*
              IF (UPPER) THEN
                  DO 110 J = 1,N
                      DO 100 I = M,1,-1
                          TEMP = B(I,J)
                          IF (NOUNIT) TEMP = TEMP*A(I,I)
                          DO 90 K = 1,I - 1
                              TEMP = TEMP + A(K,I)*B(K,J)
   90                     CONTINUE
                          B(I,J) = ALPHA*TEMP
  100                 CONTINUE
  110             CONTINUE
              ELSE
                  DO 140 J = 1,N
                      DO 130 I = 1,M
                          TEMP = B(I,J)
                          IF (NOUNIT) TEMP = TEMP*A(I,I)
                          DO 120 K = I + 1,M
                              TEMP = TEMP + A(K,I)*B(K,J)
  120                     CONTINUE
                          B(I,J) = ALPHA*TEMP
  130                 CONTINUE
  140             CONTINUE
              END IF
          END IF
      ELSE
          IF (LSAME(TRANSA,'N')) THEN
*
*           Form  B := alpha*B*A.
*
              IF (UPPER) THEN
                  DO 180 J = N,1,-1
                      TEMP = ALPHA
                      IF (NOUNIT) TEMP = TEMP*A(J,J)
                      DO 150 I = 1,M
                          B(I,J) = TEMP*B(I,J)
  150                 CONTINUE
                      DO 170 K = 1,J - 1
                          IF (A(K,J).NE.ZERO) THEN
                              TEMP = ALPHA*A(K,J)
                              DO 160 I = 1,M
                                  B(I,J) = B(I,J) + TEMP*B(I,K)
  160                         CONTINUE
                          END IF
  170                 CONTINUE
  180             CONTINUE
              ELSE
                  DO 220 J = 1,N
                      TEMP = ALPHA
                      IF (NOUNIT) TEMP = TEMP*A(J,J)
                      DO 190 I = 1,M
                          B(I,J) = TEMP*B(I,J)
  190                 CONTINUE
                      DO 210 K = J + 1,N
                          IF (A(K,J).NE.ZERO) THEN
                              TEMP = ALPHA*A(K,J)
                              DO 200 I = 1,M
                                  B(I,J) = B(I,J) + TEMP*B(I,K)
  200                         CONTINUE
                          END IF
  210                 CONTINUE
  220             CONTINUE
              END IF
          ELSE
*
*           Form  B := alpha*B*A'.
*
              IF (UPPER) THEN
                  DO 260 K = 1,N
                      DO 240 J = 1,K - 1
                          IF (A(J,K).NE.ZERO) THEN
                              TEMP = ALPHA*A(J,K)
                              DO 230 I = 1,M
                                  B(I,J) = B(I,J) + TEMP*B(I,K)
  230                         CONTINUE
                          END IF
  240                 CONTINUE
                      TEMP = ALPHA
                      IF (NOUNIT) TEMP = TEMP*A(K,K)
                      IF (TEMP.NE.ONE) THEN
                          DO 250 I = 1,M
                              B(I,K) = TEMP*B(I,K)
  250                     CONTINUE
                      END IF
  260             CONTINUE
              ELSE
                  DO 300 K = N,1,-1
                      DO 280 J = K + 1,N
                          IF (A(J,K).NE.ZERO) THEN
                              TEMP = ALPHA*A(J,K)
                              DO 270 I = 1,M
                                  B(I,J) = B(I,J) + TEMP*B(I,K)
  270                         CONTINUE
                          END IF
  280                 CONTINUE
                      TEMP = ALPHA
                      IF (NOUNIT) TEMP = TEMP*A(K,K)
                      IF (TEMP.NE.ONE) THEN
                          DO 290 I = 1,M
                              B(I,K) = TEMP*B(I,K)
  290                     CONTINUE
                      END IF
  300             CONTINUE
              END IF
          END IF
      END IF
*
      RETURN
*
*     End of DTRMM .
*
      END


! Skip this on platforms that don't have the vectorization instructions
! to handle complex types.  This test is very slow on these platforms so
! skipping is better then running it unvectorized.
! { dg-skip-if "" { ia64-*-* sparc*-*-* } }
! It can be slow on some x86 CPUs.
! { dg-timeout-factor 2 }
program mymatmul
  implicit none
  integer, parameter :: kp = 4
  integer, parameter :: n = 400
  real(kp), dimension(n,n) :: rr, ri
  complex(kp), dimension(n,n) :: a,b,c
  real :: t1, t2
  integer :: i, j, k
  common // a,b,c

  do j = 1, n
     do k = 1, n
        do i = 1, n
           c(i,j) = c(i,j) + a(i,k) * b(k,j)
        end do
     end do
  end do

end program mymatmul

! { dg-final { scan-tree-dump "vectorized 1 loops" "vect" } }


!	Get integer weights for weighted sum.
!	skillname is the array of factor names.
!	numcatobs is the array of numbers of categories in items.
!	slopedim is the array of dimensions for each factor and item.
!	weightnames are names of weights and weights are weights.
subroutine getweights(skillname,numcatobs,slopedim,weightnames,weights)
implicit none
interface
    subroutine readweights(weightname,weight)
        implicit none
        character(len=32),intent(inout)::weightname
        integer,intent(inout)::weight(:)
    end subroutine readweights
end interface
character(len=32),intent(in)::skillname(:)
integer,intent(in)::numcatobs(:),slopedim(:,:)
character(len=32),intent(out)::weightnames(:)
integer,intent(out)::weights(:,:)
!	buff is a buffer.
!	weightname is used for a nameless group.
character(len=4)::buff
character(len=32)::weightname
!	cat counts categories.
!	count weights.
!	counter finds position in weight.
!	io is error flag.
!	item counts items.
!
integer::cat,count,counter,io,item
!	weight to be read.
integer,allocatable::weight(:)

allocate(weight(size(weights,1)),stat=io)
if(io/=0)stop 'Allocation for category weights failed.'

weights=0
if(size(skillname)>=size(weightnames))then
	weightnames=skillname(1:size(weightnames))
	if(size(skillname)>size(weightnames))then
		if(size(weightnames)>1)then
			weightnames(size(weightnames))='Remainder'
		else
			weightnames(1)='Total'
		end if
	end if
	counter=0
	do item=1,size(numcatobs)
		do count=1,size(skillname)
			do cat=1,numcatobs(item)
				if(slopedim(count,item)>0)weights(counter+cat,min(count,size(weightnames)))=cat-1
			end do

		end do
		counter=counter+numcatobs(item)
	end do
else
	weightnames(1:size(skillname))=skillname
	counter=0
	do item=1,size(numcatobs)
		do count=1,size(skillname)
			do cat=1,numcatobs(item)
				if(slopedim(count,item)>0)weights(counter+cat,count)=cat-1
			end do

		end do
		counter=counter+numcatobs(item)
	end do
	do count=size(skillname)+1,size(weightnames)
		if(count==size(skillname)+1.and.count>2)then
			weightnames(count)='Total'
			counter=0
			do item=1,size(numcatobs)
				do cat=1,numcatobs(item)
					weights(counter+cat,count)=cat-1
				end do
				counter=counter+numcatobs(item)
			end do
		else
			write(buff,'(i4)') count
			weightnames(count)='Sum_'//trim(adjustl(buff))
		end if
	end do
end if

do count=1,size(weightnames)
	weightname=weightnames(count)
	weight=weights(:,count)
	call readweights(weightname,weight)
	weightnames(count)=weightname
	weights(:,count)=weight
end do

return
end subroutine getweights
subroutine readweights(weightname,weight)
    implicit none
    character(len=32),intent(inout)::weightname
    integer,intent(inout)::weight(:)
    integer::io
    namelist/readweight/weightname,weight
    read(*,nml=readweight,iostat=io)
    if(io/=0)stop "Weights not read successfully."

    return
end subroutine readweights


      integer function ifac(n)
c
c n !
c
      implicit none

      include 'stdunit.h'

      integer, intent(in) ::
     &     n
      integer ::
     &     k

      if( n .lt. 0 ) then
        ifac = 0
        write(lulog,*)
     &       ' warning: faculty of negative number set to zero'
      else
c
        ifac = 1
        do k = 2,n
          ifac = ifac * k
        end do
      end if
c
      return
      end


! ##################################################################################################################################
! Begin MIT license text.
! _______________________________________________________________________________________________________

! Copyright 2019 Dr William R Case, Jr (dbcase29@gmail.com)

! Permission is hereby granted, free of charge, to any person obtaining a copy of this software and
! associated documentation files (the "Software"), to deal in the Software without restriction, including
! without limitation the rights to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
! copies of the Software, and to permit persons to whom the Software is furnished to do so, subject to
! the following conditions:

! The above copyright notice and this permission notice shall be included in all copies or substantial
! portions of the Software and documentation.

! THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS
! OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
! FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
! AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
! LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
! OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN
! THE SOFTWARE.
! _______________________________________________________________________________________________________

! End MIT license text.

      SUBROUTINE SOLVE_UO0

! Solves KOO*UO0 = PO for matrix UO0

      USE PENTIUM_II_KIND, ONLY       :  BYTE, LONG, DOUBLE
      USE IOUNT1, ONLY                :  WRT_LOG, ERR, F04, F06, L2F, LINK2F, L2F_MSG
      USE SCONTR, ONLY                :  BLNK_SUB_NAM, FACTORED_MATRIX, FATAL_ERR, KOO_SDIA, NDOFO, NSUB, NTERM_KOO, NTERM_PO
      USE TIMDAT, ONLY                :  TSEC
      USE SUBR_BEGEND_LEVELS, ONLY    :  SOLVE_UO0_BEGEND
      USE CONSTANTS_1, ONLY           :  ZERO, ONE
      USE PARAMS, ONLY                :  PRTUO0, SOLLIB, SPARSE_FLAVOR
      USE SPARSE_MATRICES, ONLY       :  I_PO, J_PO, PO, I_KOO, J_KOO, KOO
      USE COL_VECS, ONLY              :  UO0_COL
      USE LAPACK_LIN_EQN_DPB

! Interface module not needed for subr DPBTRS. This is "CONTAIN'ed" in module LAPACK_LIN_EQN_DPB, which is "USE'd" above

      USE SOLVE_UO0_USE_IFs

      IMPLICIT NONE

      CHARACTER, PARAMETER            :: CR13 = CHAR(13)   ! This causes a carriage return simulating the "+" action in a FORMAT
      CHARACTER(LEN=LEN(BLNK_SUB_NAM)):: SUBR_NAME = 'SOLVE_UO0'
      CHARACTER( 1*BYTE)              :: NULL_COL          ! 'Y' if a col of KAO(transpose) is null
      CHARACTER(22*BYTE)              :: MODNAM1           ! Name to write to screen to describe module being run

      INTEGER(LONG)                   :: I,J               ! DO loop indices or counters
      INTEGER(LONG)                   :: INFO              ! Info on success of SuperLU solve
      INTEGER(LONG)                   :: OUNT(2)           ! File units to write messages to. Input to subr UNFORMATTED_OPEN
      INTEGER(LONG), PARAMETER        :: SUBR_BEGEND = SOLVE_UO0_BEGEND

      REAL(DOUBLE)                    :: NULL_SCALE_FACS(NDOFO)
                                                           ! LAPACK_S values not used so null this vector
      REAL(DOUBLE)                    :: INOUT_COL(NDOFO)  ! Temp variable for one col of load matrix PO

! **********************************************************************************************************************************
      IF (WRT_LOG >= SUBR_BEGEND) THEN
         CALL OURTIM
         WRITE(F04,9001) SUBR_NAME,TSEC
 9001    FORMAT(1X,A,' BEGN ',F10.3)
      ENDIF

! **********************************************************************************************************************************
! Make units for writing errors the screen and output file

      OUNT(1) = ERR
      OUNT(2) = F06

! For SOLLIB = BANDED, Subr REDUCE_KFF_TO_KAA should have done the decomp of KOO, so here we run FBS over the columns of PO to get
! UO0. First make sure that ABAND (KOO triangular factor) was successfully generated when SOLVE_GOA was run.

      IF (SOLLIB == 'BANDED  ') THEN
         IF (FACTORED_MATRIX(1:3) /= 'KOO') THEN
            WRITE(ERR,2504) SUBR_NAME, FACTORED_MATRIX
            WRITE(F06,2504) SUBR_NAME, FACTORED_MATRIX
            FATAL_ERR = FATAL_ERR + 1
            CALL OUTA_HERE ( 'Y' )
         ENDIF
      ENDIF

! Open file for writing UO0
                                                           ! Write GOA matrix to file L2F
      CALL FILE_OPEN ( L2F, LINK2F, OUNT, 'REPLACE', L2F_MSG, 'WRITE_STIME', 'UNFORMATTED', 'WRITE', 'REWIND', 'Y', 'N', 'Y' )

! **********************************************************************************************************************************
! Solve for UO0 by looping on columns of PO ("loads") to get columns of UO0 ("displs")

!xx   WRITE(SC1, * )                                       ! Advance 1 line for screen messages

      CALL ALLOCATE_COL_VEC ( 'UO0_COL', NDOFO, SUBR_NAME )
      DO J = 1,NSUB

         DO I=1,NDOFO
            INOUT_COL(I)       = ZERO                      ! Initialize INOUT_COL since GET_SPARSE_CRS_COL won't
            NULL_SCALE_FACS(I) = ZERO                      ! Initialize these (not used here snce KOO not equilibrated
         ENDDO
         NULL_COL = 'Y'
         CALL GET_SPARSE_CRS_COL ( 'PO',J, NTERM_PO, NDOFO, NSUB, I_PO, J_PO, PO, ONE, INOUT_COL, NULL_COL )

         IF (NULL_COL == 'N') THEN                         ! Solve for UO0_COL

            CALL OURTIM
            MODNAM1 = '    Solve for UO0 col '
            WRITE(SC1,12345,ADVANCE='NO') MODNAM1, J, NSUB, CR13
                                                           ! FBS should not equilibrate since KOO was prevented from equilibrating
            IF      (SOLLIB == 'BANDED  ') THEN

               CALL FBS_LAPACK ( 'N', NDOFO, KOO_SDIA, NULL_SCALE_FACS, INOUT_COL )

            ELSE IF (SOLLIB == 'SPARSE  ') THEN

               IF (SPARSE_FLAVOR(1:7) == 'SUPERLU') THEN

                  INFO = 0
                  CALL FBS_SUPRLU ( SUBR_NAME, 'KOO', NDOFO, NTERM_KOO, I_KOO, J_KOO, KOO, J, INOUT_COL, INFO )

               ELSE

                  FATAL_ERR = FATAL_ERR + 1
                  WRITE(ERR,9991) SUBR_NAME, 'SPARSE_FLAVOR'
                  WRITE(F06,9991) SUBR_NAME, 'SPARSE_FLAVOR'
                  CALL OUTA_HERE ( 'Y' )

               ENDIF

           ELSE

               FATAL_ERR = FATAL_ERR + 1
               WRITE(ERR,9991) SUBR_NAME, 'SOLLIB'
               WRITE(F06,9991) SUBR_NAME, 'SOLLIB'
               CALL OUTA_HERE ( 'Y' )

            ENDIF

            DO I=1,NDOFO
               UO0_COL(I) = INOUT_COL(I)
            ENDDO

         ELSE

            DO I=1,NDOFO
               UO0_COL(I) = ZERO
            ENDDO

         ENDIF

! Write UO0 for this S/C to L2F

         DO I=1,NDOFO
            WRITE(L2F) UO0_COL(I)
         ENDDO

         IF (PRTUO0 > 0) THEN
            WRITE(F06,201) J
            CALL WRITE_VECTOR ( 'UO0 = KOO(-1)*PO', 'DISPL', NDOFO, UO0_COL)
         ENDIF

      ENDDO

      WRITE(SC1,*) CR13

      CALL DEALLOCATE_COL_VEC ( 'UO0_COL' )

      CALL FILE_CLOSE ( L2F, LINK2F, 'KEEP', 'Y' )

! **********************************************************************************************************************************
      IF (WRT_LOG >= SUBR_BEGEND) THEN
         CALL OURTIM
         WRITE(F04,9002) SUBR_NAME,TSEC
 9002    FORMAT(1X,A,' END  ',F10.3)
      ENDIF

      RETURN

! **********************************************************************************************************************************
  201 FORMAT(59X,'COLUMN',I6)

 2504 FORMAT(' *ERROR  2504: PROGRAMMING ERROR IN SUBROUTINE ',A                                                                   &
                    ,/,14X,' THE NAME OF MATRIX THAT HAS BEEN DECOMPOSED INTO TRIANGULAR FACTORS SHOULD BE "KOO".'                 &
                    ,/,14X,' HOWEVER, IT IS NAMED "',A,'". CANNOT CONTINUE')

 9991 FORMAT(' *ERROR  9991: PROGRAMMING ERROR IN SUBROUTINE ',A                                                                   &
                    ,/,14X,A, ' = ',A,' NOT PROGRAMMED ',A)

12345 FORMAT(3X,A,I8,' of ',I8,A)

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

      END SUBROUTINE SOLVE_UO0


program fd3d
    use derivative_mod_gpu
    implicit none
    integer, parameter  :: dp = kind(1.d0)
    real(dp), parameter :: two_pi = 8.d0 * atan(1.d0)

    integer  :: n(3), num_iters, itime
    real(dp) :: length, dl, dl_inv
    real(dp) :: factors(5)
    real(dp) :: timer(2)
    real(dp), dimension(:, :, :), allocatable :: u, du, du_exact

    call box_init('der3d.nml')
    call allocate_arrays()
    call initial_condition()
    call set_factors()

    !$acc data copy(u,du,n,factors)
    write(*,*) "Profiling start"
    call cpu_time(timer(1))
    do itime = 0, num_iters
         call derivative_gpu_dev(u,du,n(1),n(2),n(3),factors)
        ! call derivative_halo()
        ! call derivative_mod()
        ! call derivative_mod_ver2()
    end do
    call cpu_time(timer(2))
    !$acc end data
    write (*, *) 'time taken :', timer(2) - timer(1), 'error :', maxval(du_exact - du)
    write(*,*) "Profiling end"

contains

    subroutine box_init(filename)
        character(*), intent(in) :: filename
        namelist /box_nml/ n, length, num_iters

        open (unit=10, file=filename, status='old')
        read (10, nml=box_nml)
        close (10)

        length = length * two_pi
        dl = length / n(1)
        dl_inv = 1.d0 / dl
    end subroutine box_init

    subroutine set_factors()
        factors = dl_inv * (1.d0 / 12.d0)*[1, -8, 0, 8, -1]
    end subroutine set_factors

    subroutine allocate_arrays()
        allocate (u(-1:n(1) + 2, -1:n(2) + 2, -1:n(3) + 2))
        allocate (du(n(1), n(2), n(3)))
        allocate (du_exact(n(1), n(2), n(3)))

        u = 0.d0
        du = 0.d0
        du_exact = 0.d0
    end subroutine allocate_arrays

    subroutine initial_condition()
        integer  :: i, j, k
        real(dp) :: x, y, z

        u(:, :, :) = 0.d0
        du_exact(:, :, :) = 0.d0

        do k = 1, n(3)
            z = dl * (k - 1)
            do j = 1, n(2)
                y = dl * (j - 1)
                do i = 1, n(1)
                    x = dl * (i - 1)
                    u(i, j, k)        = sin(x) + sin(y) + sin(z)
                    du_exact(i, j, k) = cos(x) + cos(y) + cos(z)
                end do
            end do
        end do

        ! Periodic boundary conditions
        u(0,:,:)      = u(n(1),:,:)
        u(-1,:,:)     = u(n(1)-1,:,:)
        u(n(1)+1,:,:) = u(1,:,:)
        u(n(1)+2,:,:) = u(2,:,:)

        u(:,0,:)      = u(:,n(2),:)
        u(:,-1,:)     = u(:,n(2)-1,:)
        u(:,n(2)+1,:) = u(:,1,:)
        u(:,n(2)+2,:) = u(:,2,:)

        u(:,:,0)      = u(:,:,n(3))
        u(:,:,-1)     = u(:,:,n(3)-1)
        u(:,:,n(3)+1) = u(:,:,1)
        u(:,:,n(3)+2) = u(:,:,2)
    end subroutine initial_condition

    subroutine derivative_halo()
        integer  :: i, j, k

        !$acc parallel loop collapse(3) present(u,du,n,factors)
        !!$acc parallel loop  vector_length(128) num_workers(4) collapse(3) present(u,du,n,factors)
        do k = 1, n(3)
            do j = 1, n(2)
                do i = 1, n(1)
                    du(i, j, k) = (u(i - 2, j, k) + u(i, j - 2, k) + u(i, j, k - 2)) * factors(1) + &
                                  (u(i - 1, j, k) + u(i, j - 1, k) + u(i, j, k - 1)) * factors(2) + &
                                  (u(i, j, k)     + u(i, j, k)     + u(i, j, k)    ) * factors(3) + &
                                  (u(i + 1, j, k) + u(i, j + 1, k) + u(i, j, k + 1)) * factors(4) + &
                                  (u(i + 2, j, k) + u(i, j + 2, k) + u(i, j, k + 2)) * factors(5)
                end do
            end do
        end do
        !$acc end parallel
    end subroutine derivative_halo

    subroutine derivative_mod()
        integer :: i, j, k
        integer :: l, xn(5), yn(5), zn(5)

        !$acc parallel loop collapse(3) present(u,du,n,factors) private(xn,yn,zn)
        do k = 1, n(3)
            do j = 1, n(2)
                do i = 1, n(1)
                    do l = -2, 2
                        xn(l + 3) = mod(i + l + n(1) - 1, n(1)) + 1
                        yn(l + 3) = mod(j + l + n(2) - 1, n(2)) + 1
                        zn(l + 3) = mod(k + l + n(3) - 1, n(3)) + 1
                    end do
                    du(i, j, k) = (u(xn(1), j, k) + u(i, yn(1), k) + u(i, j, zn(1))) * factors(1) + &
                                  (u(xn(2), j, k) + u(i, yn(2), k) + u(i, j, zn(2))) * factors(2) + &
                                  (u(xn(3), j, k) + u(i, yn(3), k) + u(i, j, zn(3))) * factors(3) + &
                                  (u(xn(4), j, k) + u(i, yn(4), k) + u(i, j, zn(4))) * factors(4) + &
                                  (u(xn(5), j, k) + u(i, yn(5), k) + u(i, j, zn(5))) * factors(5)
                end do
            end do
        end do
        !$acc end parallel
    end subroutine derivative_mod

    subroutine derivative_mod_ver2()
        integer :: i, j, k
        integer :: l, xn, yn, zn
        real(dp) :: duijk

        !$acc parallel loop collapse(3) present(u,du,n,factors)
        do k = 1, n(3)
            do j = 1, n(2)
                do i = 1, n(1)
                    duijk = 0.0_dp
                    do l = -2, 2
                        xn    = mod(i + l + n(1) - 1, n(1)) + 1
                        yn    = mod(j + l + n(2) - 1, n(2)) + 1
                        zn    = mod(k + l + n(3) - 1, n(3)) + 1
                        duijk = duijk + (u(xn, j, k) + u(i, yn, k) + u(i, j, zn)) * factors(l+3)
                    end do
                    du(i,j,k) =  duijk
                end do
            end do
        end do
        !$acc end parallel
    end subroutine derivative_mod_ver2

end program fd3d