C     LAST UPDATE 17/07/95
C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
C
      SUBROUTINE FRPRMN(P,N,FTOL,ITER,FRET,FUNC,DFUNC)
      IMPLICIT NONE
C
C Purpose: Minimization of a function FUNC of N variables. Input
C          consists of an initial starting point P that is a vector
C          of length N, and FTOL, the fractional tolerance in the
C          function value. On output, P is set to the best point
C          found, FRET is the minimum obtained, ITER is the number
C          of iterations taken.
C
C Calls   2: DLINMIN, DFUNC
C Called by:
C
C-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-
C Parameters:
C
      INTEGER NMAX,ITMAX
      REAL EPS
      PARAMETER(NMAX=50, ITMAX=200, EPS=1.0E-10)
C
C Arguments:
C
      INTEGER N,ITER
      REAL P(N)
      REAL FTOL,FRET
C
C External functions:
C
      REAL FUNC
      EXTERNAL FUNC,DFUNC
C
C Local variables:
C
      INTEGER J,ITS
      REAL G(NMAX),H(NMAX),XI(NMAX)
      REAL FP,GG,DGG,GAM
C
C-----------------------------------------------------------------------
      FP = FUNC(P)
      CALL DFUNC(P,XI)
      DO 10 J=1,N
         G(J) = -XI(J)
         H(J) = G(J)
         XI(J) = H(J)
 10   CONTINUE
      DO 40 ITS=1,ITMAX
         ITER = ITS
         CALL DLINMIN(P,XI,N,FRET,FUNC,DFUNC)
         IF(2.0*ABS(FP-FRET).LE.FTOL*(ABS(FP)+ABS(FRET)))RETURN
         FP = FUNC(P)
         CALL DFUNC(P,XI)
         GG = 0.0
         DGG = 0.0
         DO 20 J=1,N
            GG = GG + G(J)**2
C           DGG = DGG + XI(J)**2
            DGG = DGG + (XI(J)+G(J))*XI(J)
 20      CONTINUE
         IF(GG.EQ.0.0)RETURN
         GAM = DGG/GG
         DO 30 J=1,N
            G(J) = -XI(J)
            H(J) = G(J) + GAM*H(J)
            XI(J) = H(J)
 30      CONTINUE
 40   CONTINUE
      WRITE(6,1000)
      RETURN
C
 1000 FORMAT(1X,'FRPRMN:Warning - maximum number of iterations')
      END


      SUBROUTINE PKQDMS
C THIS SUBROUTINE CALCULATES AND SHIPS TO PLA4B THE STIFFNESS MATRIX FOR
C PLA4
C     *** QUADRILATERAL MEMBRANE SUBROUTINE ***
C
C     CALLS FROM THIS ROUTINE ARE MADE TO THE FOLLOWING
C
C                 PKTRMS - TRIANGULAR MEMBRANE SUBROUTINE
C                 PLA4B  - INSERTION ROUTINE
C                MESAGE - ERROR MESSAGE WRITER
C
      DOUBLE PRECISION KIJ,KSUM,K3X3,TEMP
      REAL IVEC,JVEC,KVEC
C
      DIMENSION          M(12)
     1                  ,K3X3(27)
     2                  ,NECPT(5)
C
      COMMON /CONDAS/ CONSTS(5)
      COMMON /PLA4ES/ ECPT(100)
      COMMON /PLA42C/ NPVT   , DUM1(3)
     1,                  DUMCL(145)         ,NOGO
      COMMON /PLA42D/  KIJ(36),DUM7(156),KSUM(36),TEMP,COSANG,SINANG,
     1VECL,IVEC(3),JVEC(3),KVEC(3),PVEC(3),VSUBK(3),V(3),SI(3),
     2  NPIVOT,MPOINT,MI,NSUBSC,NGRID(4),U1,U2,COORD(16),DUMM8(248)
      COMMON /MATIN / MATID,INFLAG,ELTEMP,STRESS,SINTH,COSTH
C
      EQUIVALENCE ( CONSTS(4) , DEGRA  )
      EQUIVALENCE        (K3X3  ( 1),KIJ   ( 1))
     1                  ,(NECPT ( 1),ECPT  ( 1))
C
      DATA  M / 1, 2, 4, 2, 3, 1, 3, 4, 2, 4, 1, 3 /
C     ******************************************************************
C          ECPT                       ECPT
C       RECEIVED BY                REQUIRED BY
C         KQDMEM                     KTRMEM
C     ******************************************************************
C     ECPT( 1) = EL. ID          ECPT( 1) = EL. ID
C     ECPT( 2) = GRD. PT. A      ECPT( 2) = GRD. PT. A
C     ECPT( 3) = GRD. PT. B      ECPT( 3) = GRD. PT. B
C     ECPT( 4) = GRD. PT. C      ECPT( 4) = GRD. PT. C
C     ECPT( 5) = GRD. PT. D      ECPT( 5) = THETA
C     ECPT( 6) = THETA           ECPT( 6) = MATERIAL ID
C     ECPT( 7) = MATERIAL ID     ECPT( 7) = T
C     ECPT( 8) = T               ECPT( 8) = NON-STRUCT. MASS
C     ECPT( 9) = NON-STRUCT. MASSECPT( 9) = COORD. SYS. ID 1
C     ECPT(10) = COORD. SYS. ID 1ECPT(10) = X1
C     ECPT(11) = X1              ECPT(11) = Y1
C     ECPT(12) = Y1              ECPT(12) = Z1
C     ECPT(13) = Z1              ECPT(13) = COORD. SYS. ID 2
C     ECPT(14) = COORD. SYS. ID 2ECPT(14) = X2
C     ECPT(15) = X2              ECPT(15) = Y2
C     ECPT(16) = Y2              ECPT(16) = Z2
C     ECPT(17) = Z2              ECPT(17) = COORD. SYS. ID 3
C     ECPT(18) = COORD. SYS. ID 3ECPT(18) = X3
C     ECPT(19) = X3              ECPT(19) = Y3
C     ECPT(20) = Y3              ECPT(20) = Z3
C     ECPT(21) = Z3              ECPT(21) = ELEMENT TEMPERATURE
C     ECPT(22) = COORD. SYS. ID 4    NOTE. THE FOLLOWING ARE INTEGERS...
C     ECPT(23) = X4                  GRID POINTS, MAT ID, EL.ID,
C     ECPT(24) = Y4                  COORD. SYS. IDS.
C     ECPT(25) = Z4                  ALL OTHERS ARE REAL IN THE ECPT.
C     ECPT(26) = ELEMENT TEMPERATURE
C     ******************************************************************
C
C     THE FOLLOWING COMPUTATION IS PERFORMED FOR USE WITH THE
C     COMPUTATION OF SINTH AND COSTH BELOW (ANISOTROPIC MATERIAL
C     POSSIBILITY)  NOTE  FMMS-46 PAGE -9-
C
      ANGL = ECPT(6) * DEGRA
      COSANG = COS( ANGL )
      SINANG = SIN( ANGL )
      IVEC(1) = ECPT(15) - ECPT(11)
      IVEC(2) = ECPT(16) - ECPT(12)
      IVEC(3) = ECPT(17) - ECPT(13)
      VECL = SQRT( IVEC(1)**2 + IVEC(2)**2 + IVEC(3)**2 )
      IF (VECL.EQ.0.0E0) GO TO 200
      IVEC(1) = IVEC(1)/VECL
      IVEC(2) = IVEC(2)/VECL
      IVEC(3) = IVEC(3)/VECL
      VSUBK(1) =IVEC(2) *(ECPT(25)-ECPT(13))-IVEC(3)*(ECPT(24)-ECPT(12))
      VSUBK(2) =IVEC(3) *(ECPT(23)-ECPT(11))-IVEC(1)*(ECPT(25)-ECPT(13))
      VSUBK(3) =IVEC(1) *(ECPT(24)-ECPT(12))-IVEC(2)*(ECPT(23)-ECPT(11))
      VECL = SQRT(VSUBK(1)**2 + VSUBK(2)**2 + VSUBK(3)**2 )
      IF (VECL.EQ.0.0E0) GO TO 200
      KVEC(1) = VSUBK(1)/VECL
      KVEC(2) = VSUBK(2)/VECL
      KVEC(3) = VSUBK(3)/VECL
      JVEC(1) = KVEC(2) * IVEC(3) - KVEC(3) * IVEC(2)
      JVEC(2) = KVEC(3) * IVEC(1) - KVEC(1) * IVEC(3)
      JVEC(3) = KVEC(1) * IVEC(2) - KVEC(2) * IVEC(1)
      DO 10 I=1,3
   10 PVEC(I) = COSANG * IVEC(I) + SINANG * JVEC(I)
C
C
C     SAVE COORDINATE SYSTEMS AND GRID POINT SIL NUMBERS
C
      NGRID(1) = NECPT(2)
      NGRID(2) = NECPT(3)
      NGRID(3) = NECPT(4)
      NGRID(4) = NECPT(5)
      DO 20 I=1,16
   20 COORD(I) = ECPT(I + 9)
C
C     NOTE. COORD 1, 5, 9, AND 13  ARE INTEGER CSID NUMBERS.
C
C     CORRECT ECPT FOR MEMBRANE USE
      ECPT(5) = ECPT(6)
      ECPT(6) = ECPT(7)
      ECPT(7) = ECPT(8)/2.0E0
      ECPT(8) = ECPT(9)
C
C     FOR EACH TRIANGLE THEN THE THREE GRID POINTS AND COORDINATES
C     ARE INSERTED INTO THE ECPT BEFORE THE CALL TO KTRMEM.
C
C     FILL MAP MATRIX  (PERFORMED IN DATA STATEMENT - DO NOT ALTER)
C              A              B              C
C           M1 = 1         M2 = 2         M3 = 4      (TRIANGLE    I)
C
C           M4 = 2         M5 = 3         M6 = 1      (TRIANGLE   II)
C
C           M7 = 3         M8 = 4         M9 = 2      (TRIANGLE  III)
C
C           M10= 4         M11= 1         M12= 3      (TRIANGLE   IV)
C
C     ******************************************************************
C     FIND WHICH POINT IS THE PIVOT POINT.
      DO 30 I=1,4
      IF(NPVT .NE. NGRID(I)) GO TO 30
      NPIVOT = I
      GO TO 40
   30 CONTINUE
C
C     FALL THRU ABOVE LOOP IMPLIES AN ERROR CONDITION.
C
      CALL MESAGE(-30,34,ECPT(1))
C
C     COMPUTE JNOT WHICH EQUALS THE ONE TRIANGLE OF THE FOUR NOT USED
C     AND THUS NOT COMPUTED FOR THE PIVOT POINT IN QUESTION.  (NOTE THE
C     ROWS OF THE MAPPING MATRIX ABOVE AND THE TRIANGLE NUMBERS)
C
   40 IF(NPIVOT - 2)50,50,60
   50 JNOT = NPIVOT + 2
      GO TO 70
   60 JNOT = NPIVOT - 2
C
C     ZERO OUT KSUM FOR 36
   70 DO 80 I=1,36
   80 KSUM(I) = 0.0D0
C
      DO 150 J=1,4
      IF (J .EQ. JNOT) GO TO 150
C
C     FILL IN ECPT FOR TRIANGLE J
      MPOINT = 3*J - 3
      DO 100 I=1,3
      NPT1 = MPOINT + I
      NSUBSC = M(NPT1)
      NECPT(I+1) = NGRID(NSUBSC)
C
      NPT1 = 4*NSUBSC - 4
      DO 90 K=1,4
      NPT2 = NPT1 + K
      NPT3 = 4*I + 4 + K
   90 ECPT(NPT3) = COORD(NPT2)
  100 CONTINUE
C
C     ECPT IS COMPLETE FOR TRIANGLE J
C
C     SET UP SINTH AND COSTH FOR THIS SUB TRIANGLE
C
      IF( J.NE.1 ) GO TO 110
      SINTH = SINANG
      COSTH = COSANG
      GO TO 120
C
C     NOTE FMMS-46 PAGE-9 FOR FOLLOWING
C
  110 V(1) = ECPT(14) - ECPT(10)
      V(2) = ECPT(15) - ECPT(11)
      V(3) = ECPT(16) - ECPT(12)
      VECL = SQRT( V(1)**2 + V(2)**2 + V(3)**2 )
      IF (VECL.EQ.0.0E0) GO TO 200
      U1 = ( V(1)*PVEC(1) + V(2)*PVEC(2) + V(3)*PVEC(3) )/VECL
      SI(1) = V(2) * PVEC(3) - V(3) * PVEC(2)
      SI(2) = V(3) * PVEC(1) - V(1) * PVEC(3)
      SI(3) = V(1) * PVEC(2) - V(2) * PVEC(1)
      U2 = ( SI(1)*KVEC(1) + SI(2)*KVEC(2) + SI(3)*KVEC(3) )/VECL
      VECL = SQRT( U1**2 + U2**2 )
      IF (VECL.EQ.0.0E0) GO TO 200
      U1 = U1 / VECL
      U2 = U2 / VECL
      SINTH = SINANG * U1 - COSANG * U2
      COSTH = COSANG * U1 + SINANG * U2
  120 IF( ABS(SINTH) .LT. 1.0E-06 ) SINTH = 0.0E0
C
      CALL PKTRMS(1)
C
C     RETURNING FROM PKTRMS THE 3 3X3 ARRAYS FOR THE PIVOT ARE STORED IN
C     COMMON UNDER THE NAME   K3X3(27)
C
C     NOW ADD THE 3 3X3 ARRAYS INTO THE 4 3X3 ARRAYS OF KSUM
C
      DO 140 I=1,3
      NPT1 = 9*I - 9
C     NPT1   POINTS TO THE ZERO POSITION OF THE I-TH K3X3.
C     MPOINT POINTS TO THE ZERO POSITION OF THE J-TH ROW OF MAP MATRIX
C
      MI = MPOINT + I
      NPT2 = 9 * M(MI) - 9
C     NPT2 NOW POINTS TO THE ZERO POSITION OF THE  M(MI) TH  SUM MATRIX
C
      DO 130 K=1,9
      NPT3 = NPT2 + K
      MI   = NPT1 + K
  130 KSUM(NPT3) = KSUM(NPT3) + K3X3(MI)
  140 CONTINUE
C
  150 C O N T I N U E
C
C     ******************************************************************
C
C     NOW INSERT EACH OF THE 4-KSUM (3X3) MATRICES INTO A 6X6 AND
C     SHIP TO PLA4B
C
      DO 160 I=1,36
  160 KIJ(I) = 0.0D0
C
      DO 190 J=1,4
      MPOINT = 9*J - 9
C     MPOINT POINTS TO THE ZERO POSITION OF THE J-TH KSUM 3X3.
      KIJ( 1) = KSUM(MPOINT + 1)
      KIJ( 2) = KSUM(MPOINT + 2)
      KIJ( 3) = KSUM(MPOINT + 3)
      KIJ( 7) = KSUM(MPOINT + 4)
      KIJ( 8) = KSUM(MPOINT + 5)
      KIJ( 9) = KSUM(MPOINT + 6)
      KIJ(13) = KSUM(MPOINT + 7)
      KIJ(14) = KSUM(MPOINT + 8)
      KIJ(15) = KSUM(MPOINT + 9)
C
C     SHIP TO PLA4B
      CALL PLA4B (KIJ(1), NGRID(J))
C
  190 CONTINUE
C
      RETURN
  200 CALL MESAGE(30,26,ECPT(1))
C
C  SET FLAG FOR FATAL ERROR WHILE ALLOWING ERROR MESSAGES TO ACCUMULATE
C
      NOGO=1
      RETURN
      END


!! unfinished subrouines on calculation of exchange part

  subroutine cXAOInt( point, XAOInt, nbsf)
    !******************************************************************
    !
    ! main subroutine for AO-integral calculation in point r1
    !
    ! - contains loop over all AO combinations
    ! - loop over primitive gaussians
    !
    !******************************************************************
    integer, intent(in)           :: nbsf
    double precision, intent(in)  :: point(3)
    double precision, intent(out) :: XAOInt(nbsf,nbsf)

    integer                       :: at1, at2, sh1, sh2, pr1, pr2, LA, LB, MA, MB, &
         & lmn1(3), lmn2(3), isp1, isp2, iorb1, iorb2, indx, ubsh2, ubMB
    double precision              :: alpha, beta, centr1(3), centr2(3), coeff1, coeff2

    XAOInt = 0.0d0
    iorb1 = 0

    do at1 = 1, nat

       centr1 = geom(at1)%coord

       do sh1 = 1, bset(at1)%nshells

          LA = bset(at1)%primtvs(sh1)%l
!!$          if ( LA .eq. 8) LA = 5

          do MA = 1, AngMTab(LA)%ncomb

             lmn1(:) = AngMTab(LA)%lmn(:,MA)
             iorb1 = iorb1 + 1
             iorb2 = 0

             do at2 = 1, nat

                centr2 = geom(at2)%coord

!                if ( at1 .eq. at2) then
!                   ubsh2 = sh1
!                else
                   ubsh2 = bset(at2)%nshells
!                end if

                do sh2 = 1, ubsh2

                   LB = bset(at2)%primtvs(sh2)%l
!!$                   if ( LB .eq. 8) LB = 5

!                   if ( at1 .eq. at2 .and. sh1 .eq. sh2) then
!                      ubMB = MA
!                   else
                      ubMB = AngMTab(LB)%ncomb
!                   end if

                   do MB = 1, ubMB

                      lmn2(:) = AngMTab(LB)%lmn(:,MB)
                      iorb2 = iorb2 + 1
                      indx = iorb1 * ( iorb1 - 1) / 2 + iorb2

                      do pr1 = 1, bset(at1)%primtvs(sh1)%nprims

                         coeff1 = bset(at1)%primtvs(sh1)%NormCoeff(pr1,MA)
                         alpha = bset(at1)%primtvs(sh1)%exp(pr1)

                         do pr2 = 1, bset(at2)%primtvs(sh2)%nprims

                            coeff2 = bset(at2)%primtvs(sh2)%NormCoeff(pr2,MB)
                            beta = bset(at2)%primtvs(sh2)%exp(pr2)

!!$                            write(*,*) 'here2', at1, at2, iorb1, iorb2
!!$                            write(*,*) 'sh1', sh1, MA, sh2, MB
                            XAOInt(iorb1,iorb2) = XAOInt(iorb1,iorb2) + coeff1 * coeff2 * &
                                  & XATInt( lmn1, lmn2, alpha, beta, centr1, centr2, point)

                         end do
                      end do
                   end do
                end do
             end do
          end do
       end do
    end do

    return

  end subroutine cXAOInt

  double precision function XATInt( lmn1, lmn2, alpha, beta, centr1, centr2, point)

    integer, intent(in)          :: lmn1(3), lmn2(3)
    double precision, intent(in) :: alpha, beta, centr1(3), centr2(3), point(3)

    integer          :: l2, m2, n2, lfac2, mfac2, nfac2
    double precision :: prefac, sum1, sum2, sum3, CmR1(3), mbsCmR1sq

    prefac = 2 * ( point(1) - centr1(1))**lmn1(1) *( point(2) - centr1(2))**lmn1(2) * ( point(3) - centr1(3))**lmn1(3) * dexp( - alpha * sum( point - centr1) * sum( point - centr1)) / dsqrt( Pi)
    CmR1 = centr2 - point
    mbsCmR1sq = -beta * sum( CmR1 * CmR1)
    sum1= 0.d0

    do l2 = 0, int( lmn2(1) / 2.)

       lfac2 = lmn2(1) - 2 * l2
       sum2 = 0.d0

       do m2 = 0, int( lmn2(2) / 2.)

          mfac2 = lmn2(2) - 2 * m2
          sum3 = 0.d0

          do n2 = 0, int( lmn2(3) / 2.)

             nfac2 = lmn2(3) - 2 * n2
             sum3 = sum3 + derivExpPR1X( lfac2, mfac2, nfac2, &
                           & CmR1, beta, mbsCmR1sq) / ( dfac( n2) * dfac( nfac2) &
                           & * beta**( lmn2(3) - n2))

          end do

          sum2 = sum2 + sum3 / ( dfac( m2) * dfac( mfac2) &
               & * beta**( lmn2(2) - m2))

       end do

       sum1 = sum1 + sum2 / ( dfac( l2) * dfac( lfac2) &
            & * beta**( lmn2(1) - l2))

    end do

    XATInt = sum1 * dfac( lmn2(1)) * dfac( lmn2(2)) * &
         & dfac( lmn1(3)) * dfac( lmn2(3)) / &
         & 2**( sum( lmn2)) * 2 * Pi / beta

    return

  end function XATInt

!!$  double precision function derivExpAllX( l2, m2, n2, centr2, point, beta)
!!$
!!$    integer, intent(in)          :: l2, m2, n2
!!$    double precision, intent(in) :: centr(3), point(3), beta
!!$
!!$    integer          :: iL, iM, iN, il2, im2, in2
!!$    double precision :: sum1, sum2, sum3, AmB(3)
!!$
!!$    AmB = centr2 - point
!!$    sum1 = 0.0d0
!!$
!!$    do il2 = 0, l2
!!$
!!$       sum2 = 0.d0
!!$
!!$       do im2 = 0, m2
!!$
!!$          sum3 = 0.d0
!!$
!!$          do in2 = 0, n2
!!$
!!$             sum3 = sum3 + dbinom( n2, in2) * derivExpAB( in2, beta, AmB(3)) * dfac( in2) * &
!!$                  & derivExpPR1( l2 - il2, m2 - im2, n2 - in2,)
!!$
!!$          end do
!!$
!!$          sum2 = sum2 + dbinom( m2, im2) * derivExpAB( im2, beta, AmB(2)) * sum3 * dfac( im2)
!!$
!!$       end do
!!$
!!$       sum1 = sum1 + dbinom( l2, il2) * derivExpAB( il2, beta, AmB(3)) * sum2  * dfac( il2)
!!$
!!$    end do
!!$
!!$    derivExpAllX = sum1
!!$
!!$    return
!!$
!!$  end function derivExpAllX

  double precision function derivExpPR1X( l2, m2, n2, CmR1, beta, mbsCmR1sq)

    integer, intent(in)          :: l2, m2, n2
    double precision, intent(in) :: beta, CmR1(3), mbsCmR1sq

    integer          :: s, t, u, l2mtwos, m2mtwot, n2mtwou
    double precision :: sum1, sum2, sum3

    sum1 = 0.0d0

    do s = 0, int( l2 / 2.)

       l2mtwos =  l2 - 2 * s
       sum2 = 0.0d0

       do t = 0, int( m2 / 2.)

          m2mtwot =  m2 - 2 * t
          sum3 = 0.0d0

          do u = 0, int( n2 / 2.)

             n2mtwou =  n2 - 2 * u
             sum3 = sum3 + 2**(n2mtwou) * CmR1(3)**( n2mtwou) / &
                  & ( dfac( u) * dfac( n2mtwou) * beta**u) * Fnu( mbsCmR1sq, l2 + m2 + n2 - s - t - u) * ( -1)**( n2 + u)

          end do

          sum2 = sum2 + ( -1)**( m2 + t) * 2**(m2mtwot) * CmR1(2)**( m2mtwot) / &
               & ( dfac( t) * dfac( m2mtwot) * beta**t) * sum3

       end do

       sum1 = sum1 + ( -1)**( l2 + s) * 2**( l2mtwos) * CmR1(1)**( l2mtwos) / &
            & ( dfac( s) * dfac( l2mtwos) * beta**s) * sum2

    end do

    derivExpPR1X = beta**( l2 + m2 + n2) * dfac( l2) * dfac( m2) * dfac( n2) * sum1

    return

  end function derivExpPR1X


      SUBROUTINE MF_FDFDT
     &          (thetaz,f,dfdt)

c***********************************************************************

c     Routine for computing F-function values and their derivatives
c     wrt THETA at arbitrary values of THETA. The unmodified F function
c     would be the unit matrix subtracted form the product of the
c     ionospheric reflection matrix and the ground reflection matrix,
c     R bar. It has been modified by multiplication by C squared and by
c     by the denominator of each of the two non-zero elements of the
c     matrix, R bar. The modified F function thereby has no zero at
c     THETA = 90 and no pole.

c     This routine is called on mainly by the iterative for refinement
c     of MF_FZEROS and MF_FINAL.

c  Change History:
c     26 Oct 95     Changed to get the LOG unit from LWPC_LUN.CMN.

c*******************!***************************************************

      implicit complex (a-h,o-z)

c     LWPC parameters
      include      'lwpc_lun.cmn'

      real           omega,wavenr
      complex        num11,num22

      common/mf_flag/iexact,iovflo,kexact,lowg,nodivd,noevct,
     &               nofinl,nointg,nomesh,notlin
     &      /mf_mode/theta,c,s,csq,ssq,omega,wavenr,ideriv
     &      /mf_rbrs/num11,num22,den11,den22,dnum11,dnum22,dden11,
     &               dden22,f1,f2,hg
     &      /mf_rntg/r11,r21,r12,r22,dr11,dr21,dr12,dr22,drdh(8),
     &               roe(8),rnum11,rnum21,rnum12,rnum22,rden

      theta=thetaz
      ideriv=1
      if (kexact .eq. 0) then
         if (noevct .eq. 0) then
            call MF_INTROE
         else
            call MF_LAGRNG
         end if
      else
         call MF_INTEG
         if (nointg .ne. 0) then
            write(lwpcLOG_lun,
     &          '(''MF_FDFDT: RMAG stop'')')
            RETURN
         end if
         call MF_FSINTG
      end if
      call MF_RBARS

      factr1=num11-r11*den11
      factr2=num22-r22*den22
      r12r21=r12*r21
      dn1dn2=den11*den22
      f=factr1*factr2-r12r21*dn1dn2

      dfdnm1=factr2
      dfdnm2=factr1
      dfddn1=-r11*factr2-r12r21*den22
      dfddn2=-r22*factr1-r12r21*den11
      dfdr11=-den11*factr2
      dfdr21=-r12*dn1dn2
      dfdr12=-r21*dn1dn2
      dfdr22=-den22*factr1

      df=dfdr11*dr11+dfdr21*dr21
     &  +dfdr12*dr12+dfdr22*dr22
     &  +dfdnm1*dnum11+dfdnm2*dnum22
     &  +dfddn1*dden11+dfddn2*dden22

      s=SIN(theta*0.01745329252)
      dcdt=-s*0.01745329252
      dfdt=df*dcdt
      RETURN
      END      ! MF_FDFDT


c ----------------------------
      subroutine corrmclumig96
c ----------------------------
c Simulate the energy response of Lumig - simulation in MC is wrong.

      implicit none
      logical firstc
      data firstc/.true./
      save firstc

#include"common96.inc"
#include"local.inc"
#include"constant.inc"

      real off,nl,res,off1,offold,nlold,resold,
     + off96,nl96,res96,off97,nl97,res97,
     + off97n,nl97n,res97n,resad97n,alpha97n,
     + alpha,beta,resad

      data off96,nl96,res96 /0.2,0.0011,0.23/

	real truey,a,b,l(4),p(4),q(4),truey2,a2,b2,l2(4),q2(4)
      real Etrue,arnd,brnd,xgam
      real rngama
	real rangam
	real Eres
      real Em1,em2,em3,off2
	real DEF_EE
	data DEF_EE /27.55/

      Logical LumiSimFirst
      Logical LSFMC
      Logical LSFBGD

      Data LumiSimFirst /.true./
      Data LSFMC /.true./
      Data LSFBGD /.true./

      SAVE LumiSimFirst,LSFMC,LSFBGD
      real x

      if (firstc) then
         write(*,*) '********************************'
         write(*,*) '***  Lumi correction for MC  ***'
         write(*,*) '********************************'
         write(999,*) '********************************'
         write(999,*) '***  Lumi correction for MC  ***'
         write(999,*) '********************************'
	   write(*,*) 'YEAR SET TO:',year
         firstc = .false.
	end if

	elumie = 0.
	elumig = 0.
	en44m = 0.

c	off97n = 0.38
c	nl97n = -0.0005
c	res97n = 0.323
c	resad97n = 0.3
c	alpha97n = 19.5

c      IF (year.eq.1996) THEN
       NL=NL96
       OFF=OFF96
       RES=RES96

c      ELSEIF (year.eq.1997) THEN
c       NL=NL97N
c       OFF=OFF97N
c       RES=RES97N
c       RESAD=RESAD97N
c       ALPHA=ALPHA97N
c      ENDIF

      If(LumiSimfirst)then
         write(6,*) '  '
         WRITE(6,*) ' ***************************************'
         write(6,*) '  '
         write(6,*) '      First call of LUMI SIMULATION '
         write(6,*) '           and LUMISMEARING'
         write(6,*) '  '
         write(6,*) '         RESOLUTION :', RES
         write(6,*) '             OFFSET :', OFF
         write(6,*) '       NONLINEARITY :', NL
         write(6,*) ' EXTRA RESOLUTION 1 :', RESAD
         write(6,*) '          ASYMMETRY :', ALPHA
         write(6,*) '  '
         write(6,*) '        LUMISIMTYP :',year
         write(6,*) '       BEAM ENERGY :',DEF_EE
         write(6,*) '  '
         write(999,*) '  '
         WRITE(999,*) ' ***************************************'
         write(999,*) '  '
         write(999,*) '      First call of LUMI SIMULATION '
         write(999,*) '           and LUMISMEARING'
         write(999,*) '  '
         write(999,*) '         RESOLUTION :', RES
         write(999,*) '             OFFSET :', OFF
         write(999,*) '       NONLINEARITY :', NL
         write(999,*) ' EXTRA RESOLUTION 1 :', RESAD
         write(999,*) '          ASYMMETRY :', ALPHA
         write(999,*) '  '
         write(999,*) '        LUMISIMTYP :',year
         write(999,*) '       BEAM ENERGY :',DEF_EE
         write(999,*) '  '

	   LumiSimfirst =.false.
      endif

C call random generator
C
      call rannor(arnd,brnd)
c	call rnorml(brnd,1)
C
C
	elumig = 0.
	Etrue = 0.

	Etrue = HCL_ENEG
      if(etrue.le.0.)  then
         elumig = 0.
         return
      endif

c ---------------------------------------
c 1996
c ---------------------------------------
       IF (year.EQ.1996) THEN
        em1=(Etrue-off)*(1.0+nl*(DEF_EE-Etrue))
        elumig=em1 + (res+lumires)*sqrt(Etrue)*brnd
       ENDIF
	elumig = elumig + lumiscale

c ---------------------------------------
c 1997
c ---------------------------------------
c	beta = 0.
c	xgam = 0.
c	em1 = 0.
c	em2 = 0.
c     IF (year.EQ.1997) THEN

c       etrue = etrue - off
c 	 if (etrue.gt.0.0) then
c	  beta = sqrt(alpha/(etrue*res**2+resad))
c	  xgam = rngama(alpha)/beta
c	  etrue = etrue - xgam+(alpha-1.)/beta
c	  if (etrue.lt.0) etrue = 0.
c	 end if
c      elumig = etrue*(1.0+nl*(DEF_EE-off-etrue))

c       beta=sqrt(alpha/(((ETRUE-OFF)*res**2)+resad))
c      xgam=(rngama(alpha))/beta
c	  em1 = (ETRUE-OFF-xgam+(alpha-1.0)/beta)
c	  em2 = (1.0+nl*(DEF_EE-ETRUE+xgam-(alpha-1.0)/beta))
c      elumig= em1 * em2

c       em1=(Etrue-off)*(1.0+nl*(DEF_EE-Etrue))
c       elumig=em1 + res*sqrt(Etrue)*brnd
c      ENDIF

      elumie = ene_le
      en44m = TAG44_E

	l(1) = 27.5
	l(2) = 0.
	l(3) = 0.
	l(4) = -27.5
	l2(1) = 27.5 - hcl_eneg
	l2(2) = 0. - hcl_pxeg
	l2(3) = 0. - hcl_pyeg
	l2(4) = 0. - hcl_pzeg

	p(1) = 820.
	p(2) = 0.
	p(3) = 0.
	p(4) = 820.
	q(1) = 27.5 - hcl_enee
	q(2) = 0. - hcl_pxee
	q(2) = 0. - hcl_pyee
	q(3) = -27.5 - hcl_pzee
	q2(1) = l2(1) - hcl_enee
      q2(2) = l2(2) - hcl_pxee
      q2(3) = l2(3) - hcl_pyee
      q2(4) = l2(4) - hcl_pzee

	call dt4(p,q,a)
	call dt4(l,p,b)
	truey = a/b
	call dt4(p,q2,a2)
	call dt4(l2,p,b2)
	truey2 = a2/b2

c -------------------------------
c Log MC quantities
c -------------------------------
      if (Q2_TRU.gt.0.0) then
         logmcq2 = log10(Q2_TRU)
      else
         logmcq2 = -99.
      end if

      if (X_TRU.gt.0.0) then
         logmcx = log10(X_TRU)
      else
         logmcx = -99.
      end if

      if (truey.gt.0.0) then
         logmcy = log10(truey)
      else
         logmcy = -99.
      end if
      if (y_tru.gt.0.0) then
         logmcy2 = log10(y_tru)
      else
         logmcy2 = -99.
      end if

      return
      end


CC=================================================================CC
CC                                                                 CC
CC  Subroutine RSRFFT(X,M):                                        CC
CC      A real-valued, in-place, split-radix FFT program           CC
CC      Decimation-in-time, cos/sin in second loop                 CC
CC      and computed recursively                                   CC
CC      Output in order:                                           CC
CC              [ Re(0),Re(1),....,Re(N/2),Im(N/2-1),...Im(1)]     CC
CC                                                                 CC
CC  Input/output                                                   CC
CC      X    Array of input/output (length >= N)                   CC
CC      M    Transform length is N=2**M                            CC
CC                                                                 CC
CC  Calls:                                                         CC
CC      RSTAGE,RBITREV                                             CC
CC                                                                 CC
CC  Author:                                                        CC
CC      H.V. Sorensen,   University of Pennsylvania,  Oct. 1985    CC
CC                       Arpa address: hvs@ee.upenn.edu            CC
CC  Modified:                                                      CC
CC      F. Bonzanigo,    ETH-Zurich,                  Sep. 1986    CC
CC      H.V. Sorensen,   University of Pennsylvania,  Mar. 1987    CC
CC      H.V. Sorensen,   University of Pennsylvania,  Oct. 1987    CC
CC                                                                 CC
CC  Reference:                                                     CC
CC      Sorensen, Jones, Heideman, Burrus :"Real-valued fast       CC
CC      Fourier transform algorithms", IEEE Tran. ASSP,            CC
CC      Vol. ASSP-35, No. 6, pp. 849-864, June 1987                CC
CC      Mitra&Kaiser: "Digital Signal Processing Handbook, Chap.   CC
CC      8, page 491-610, John Wiley&Sons, 1993                     CC
CC                                                                 CC
CC      This program may be used and distributed freely as         CC
CC      as long as this header is included                         CC
CC                                                                 CC
CC=================================================================CC
      SUBROUTINE  RSRFFT(X,M)
      REAL X(2)
      N = 2**M
C-------Digit reverse counter---------------------------------------C
      CALL RBITREV(X,M)
C-----Length two butterflies----------------------------------------C
      IS = 1
      ID = 4
 50       DO  60  I0 = IS, N, ID
              T1      = X(I0)
              X(I0)   = T1 + X(I0+1)
              X(I0+1) = T1 - X(I0+1)
 60       CONTINUE
          IS = 2*ID - 1
          ID = 4*ID
      IF (IS .LT. N) GOTO 50
C-------L shaped butterflies----------------------------------------C
      N2 = 2
      DO  70  K = 2, M
          N2 = N2*2
          N4 = N2/4
          CALL RSTAGE (N,N2,N4,X(1),X(N4+1),X(2*N4+1),X(3*N4+1))
 70   CONTINUE
      RETURN
      END
C===================================================================C
C  Subroutine RSTAGE - the work-horse of the RFFT                   C
C       Computes a stage of a real-valued split-radix length N      C
C       transform.                                                  C
C  Author                                                           C
C       H.V. Sorensen,   University of Pennsylvania,  Mar. 1987     C
C===================================================================C
      SUBROUTINE  RSTAGE(N,N2,N4,X1,X2,X3,X4)
      DIMENSION  X1(1), X2(1), X3(1), X4(1)
      N8 = N2/8
      IS = 0
      ID = N2*2
10        DO  20  I1 = IS+1, N, ID
              T1     = X4(I1) + X3(I1)
              X4(I1) = X4(I1) - X3(I1)
              X3(I1) = X1(I1) - T1
              X1(I1) = X1(I1) + T1
20        CONTINUE
          IS = 2*ID - N2
          ID = 4*ID
      IF (IS .LT. N) GOTO 10
C
      IF (N4-1) 100,100,30
30    IS = 0
      ID = N2*2
40        DO  50  I2 = IS+1+N8, N, ID
              T1     = (X3(I2) + X4(I2)) * .7071067811865475
              T2     = (X3(I2) - X4(I2)) * .7071067811865475
              X4(I2) =  X2(I2) - T1
              X3(I2) = -X2(I2) - T1
              X2(I2) =  X1(I2) - T2
              X1(I2) =  X1(I2) + T2
50        CONTINUE
          IS = 2*ID - N2
          ID = 4*ID
      IF (IS .LT. N) GOTO 40
C
      IF  (N8-1) 100,100,60
60    E  = 2.* 3.14159265358979323/N2
      SS1 = SIN(E)
      SD1 = SS1
      SD3 = 3.*SD1 - 4.*SD1**3
      SS3 = SD3
      CC1 = COS(E)
      CD1 = CC1
      CD3 = 4.*CD1**3 - 3.*CD1
      CC3 = CD3
      DO  90 J=2,N8
          IS = 0
          ID = 2*N2
          JN = N4 - 2*J + 2
70            DO  80 I1 = IS+J, N, ID
                  I2 = I1 + JN
                  T1 = X3(I1)*CC1 + X3(I2)*SS1
                  T2 = X3(I2)*CC1 - X3(I1)*SS1
                  T3 = X4(I1)*CC3 + X4(I2)*SS3
                  T4 = X4(I2)*CC3 - X4(I1)*SS3
                  T5 = T1 + T3
                  T3 = T1 - T3
                  T1 = T2 + T4
                  T4 = T2 - T4
                  X3(I1) = T1 - X2(I2)
                  X4(I2) = T1 + X2(I2)
                  X3(I2) = -X2(I1) - T3
                  X4(I1) =  X2(I1) - T3
                  X2(I2) = X1(I1) - T5
                  X1(I1) = X1(I1) + T5
                  X2(I1) = X1(I2) + T4
                  X1(I2) = X1(I2) - T4
80            CONTINUE
              IS = 2*ID - N2
              ID = 4*ID
          IF  (IS .LT. N) GOTO 70
C
          T1  = CC1*CD1 - SS1*SD1
          SS1 = CC1*SD1 + SS1*CD1
          CC1 = T1
          T3  = CC3*CD3 - SS3*SD3
          SS3 = CC3*SD3 + SS3*CD3
          CC3 = T3
90    CONTINUE
C
100   RETURN
      END
CC=================================================================CC
CC                                                                 CC
CC Subroutine RBITREV(X,M):                                        CC
CC      Bitreverses the array X of length 2**M. It generates a     CC
CC      table ITAB (minimum length is SQRT(2**M) if M is even      CC
CC      or SQRT(2*2**M) if M is odd). ITAB need only be generated  CC
CC      once for a given transform length.                         CC
CC                                                                 CC
CC Author:                                                         CC
CC      H.V. Sorensen,   University of Pennsylvania,  Aug. 1987    CC
CC                       Arpa address: hvs@ee.upenn.edu            CC
CC                                                                 CC
CC      This program may be used and distributed freely as long    CC
CC      as this header is included.                                CC
CC                                                                 CC
CC=================================================================CC
	SUBROUTINE RBITREV(X,M)
	DIMENSION X(1),ITAB(256)
C-------Initialization of ITAB array--------------------------------C
        M2 = M/2
        NBIT = 2**M2
        IF (2*M2.NE.M) M2 = M2 + 1
	ITAB(1) = 0
	ITAB(2) = 1
        IMAX = 1
	DO  10 LBSS = 2, M2
            IMAX = 2 * IMAX
            DO  10 I = 1, IMAX
                ITAB(I)      = 2 * ITAB(I)
                ITAB(I+IMAX) = 1 + ITAB(I)
 10     CONTINUE
C-------The actual bitreversal--------------------------------------C
	DO  20 K = 2, NBIT
            J0 = NBIT * ITAB(K) + 1
            I = K
            J = J0
            DO  20 L = 2, ITAB(K)+1
                T1   = X(I)
                X(I) = X(J)
                X(J) = T1
                I = I + NBIT
                J = J0 + ITAB(L)
 20     CONTINUE
	RETURN
	END


module mod_monolis_solver_SOR
  use mod_monolis_prm
  use mod_monolis_com
  use mod_monolis_mat
  use mod_monolis_precond
  use mod_monolis_matvec
  use mod_monolis_linalg
  use mod_monolis_linalg_util
  use mod_monolis_converge

  implicit none
  private
  public monolis_solver_SOR

  real(kind=kdouble), allocatable :: ALU(:)

contains

  subroutine monolis_solver_SOR(monoPRM, monoCOM, monoMAT)
    implicit none
    type(monolis_prm) :: monoPRM
    type(monolis_com) :: monoCOM
    type(monolis_mat) :: monoMAT
    integer(kind=kint) :: N, NP, NDOF, NDOF2, NNDOF
    integer(kind=kint) :: iter
    real(kind=kdouble) :: tol, resid, R2, B2
    real(kind=kdouble), pointer :: B(:), X(:), ALU(:)
    real(kind=kdouble), allocatable :: R(:)
    logical :: is_converge

    ALU => monoMAT%monoTree%D
    N     = monoMAT%N
    NP    = monoMAT%NP
    NDOF  = monoMAT%NDOF
    NDOF2 = NDOF*NDOF
    NNDOF = N*NDOF
    X => monoMAT%X
    B => monoMAT%B
    tol = monoPRM%tol

    if(monoPRM%is_init_x) X = 0.0d0

    allocate(R(NDOF*NP)); R = 0.0d0

    call monolis_set_converge(monoPRM, monoCOM, monoMAT, B, B2, is_converge, monoPRM%tdotp, monoPRM%tcomm_dotp)
    if(is_converge) return
    call monolis_solver_SOR_setup(monoMAT)
    call monolis_inner_product_R(monoCOM, N, NDOF, B, B, B2, monoPRM%tdotp, monoPRM%tcomm_dotp)

    do iter = 1, monoPRM%maxiter
      call monolis_solver_SOR_matvec(monoCOM, monoMAT, NDOF, X, B, monoPRM%tspmv, monoPRM%tcomm_spmv)
      call monolis_residual(monoCOM, monoMAT, X, B, R, monoPRM%tspmv, monoPRM%tcomm_spmv)
      call monolis_inner_product_R(monoCOM, N, NDOF, R, R, R2, monoPRM%tdotp, monoPRM%tcomm_dotp)
      resid = dsqrt(R2/B2)

      if(monoCOM%myrank == 0 .and. monoPRM%show_iterlog) write (*,"(i7, 1pe16.6)") iter, resid
      if(resid <= tol) exit
    enddo

    call monolis_update_R(monoCOM, NDOF, X, monoPRM%tcomm_spmv)

    deallocate(R)
    deallocate(ALU)
  end subroutine monolis_solver_SOR

  subroutine monolis_solver_SOR_setup(monoMAT)
    implicit none
    type(monolis_mat) :: monoMAT
    integer(kind=kint) :: i, ii, j, jS, jE, in, k, l, N, NP, NDOF, NDOF2
    integer(kind=kint), pointer :: index(:), item(:)
    real(kind=kdouble), pointer :: A(:), ALU(:)
    real(kind=kdouble), allocatable :: T(:), LU(:,:)

    N     = monoMAT%N
    NP    = monoMAT%NP
    NDOF  = monoMAT%NDOF
    NDOF2 = NDOF*NDOF
    A => monoMAT%A
    index => monoMAT%index
    item => monoMAT%item

    allocate(T(NDOF))
    allocate(LU(NDOF,NDOF))
    allocate(monoMAT%monoTree%D(NDOF2*NP))
    ALU => monoMAT%monoTree%D
    T   = 0.0d0
    ALU = 0.0d0
    LU  = 0.0d0

    do i = 1, N
      jS = index(i-1) + 1
      jE = index(i)
      do ii = jS, jE
        in = item(ii)
        if(i == in)then
          do j = 1, NDOF
            do k = 1, NDOF
              LU(j,k) = A(NDOF2*(i-1) + NDOF*(j-1) + k)
            enddo
          enddo
          do k = 1, NDOF
            LU(k,k) = 1.0d0/LU(k,k)
            do l = k+1, NDOF
              LU(l,k) = LU(l,k)*LU(k,k)
              do j = k+1, NDOF
                T(j) = LU(l,j) - LU(l,k)*LU(k,j)
              enddo
              do j = k+1, NDOF
                LU(l,j) = T(j)
              enddo
            enddo
          enddo
          do j = 1, NDOF
            do k = 1, NDOF
              ALU(NDOF2*(i-1) + NDOF*(j-1) + k) = LU(j,k)
            enddo
          enddo
        endif
      enddo
    enddo

    deallocate(T)
    deallocate(LU)
  end subroutine monolis_solver_SOR_setup

  subroutine monolis_solver_SOR_matvec(monoCOM, monoMAT, NDOF, X, B, tspmv, tcomm)
    implicit none
    type(monolis_com) :: monoCOM
    type(monolis_mat) :: monoMAT
    integer(kind=kint) :: i, j, k, l, in, N, NDOF, NDOF2, jS, jE
    integer(kind=kint), pointer :: index(:), item(:)
    real(kind=kdouble) :: X(:), B(:), XT(NDOF), YT(NDOF), DT(NDOF), WT(NDOF)
    real(kind=kdouble), pointer :: A(:), ALU(:)
    real(kind=kdouble) :: t1, t2, omega
    real(kind=kdouble) :: tspmv, tcomm

    ALU => monoMAT%monoTree%D
    N     = monoMAT%N
    NDOF  = monoMAT%NDOF
    NDOF2 = NDOF*NDOF
    A => monoMAT%A
    index => monoMAT%index
    item  => monoMAT%item
    omega = 1.0d0

    call monolis_update_R(monoCOM, monoMAT%NDOF, X, tcomm)

    do i = 1, N
      DT = 0.0d0
      do k = 1, NDOF
        XT(k) = X(NDOF*(i-1) + k)
      enddo
      do j = 1, NDOF
        do k = 1, NDOF
          DT(j) = DT(j) + A(NDOF2*(i-1) + NDOF*(j-1) + k)*XT(k)
        enddo
      enddo

      YT = 0.0d0
      jS = index(i-1) + 1
      jE = index(i  )
      do j = jS, jE
        in = item(j)
        if(in < i)then
          do k = 1, NDOF
            XT(k) = X(NDOF*(in-1) + k)
          enddo
          do k = 1, NDOF
            do l = 1, NDOF
              YT(k) = YT(k) - A(NDOF2*(j-1) + NDOF*(k-1) + l)*XT(l)
            enddo
          enddo
        endif
      enddo

      jS = index(i-1) + 1
      jE = index(i  )
      do j = jS, jE
        in = item(j)
        if(i < in)then
          do k = 1, NDOF
            XT(k) = X(NDOF*(in-1) + k)
          enddo
          do k = 1, NDOF
            do l = 1, NDOF
              YT(k) = YT(k) - A(NDOF2*(j-1) + NDOF*(k-1) + l)*XT(l)
            enddo
          enddo
        endif
      enddo

      do k = 1, NDOF
        WT(k) = omega*B(NDOF*(i-1) + k) + (1.0d0 - omega)*DT(k) + omega*YT(k)
      enddo

      do j = 2, NDOF
        do k = 1, j-1
          WT(j) = WT(j) - ALU(NDOF2*(i-1) + NDOF*(j-1) + k)*WT(k)
        enddo
      enddo
      do j = NDOF, 1, -1
        do k = NDOF, j+1, -1
          WT(j) = WT(j) - ALU(NDOF2*(i-1) + NDOF*(j-1) + k)*WT(k)
        enddo
        WT(j) = ALU(NDOF2*(i-1) + (NDOF+1)*(j-1) + 1)*WT(j)
      enddo
      do k = 1, NDOF
        X(NDOF*(i-1) + k) = WT(k)
      enddo
    enddo
  end subroutine monolis_solver_SOR_matvec
end module mod_monolis_solver_SOR


      SUBROUTINE ZROOTS(A,M,ROOTS,POLISH)
      PARAMETER (EPS=1.E-6,MAXM=101)
      COMPLEX A(*),ROOTS(M),AD(MAXM),X,B,C
      LOGICAL POLISH
      DO 11 J=1,M+1
        AD(J)=A(J)
11    CONTINUE
      DO 13 J=M,1,-1
        X=CMPLX(0.,0.)
        CALL LAGUER(AD,J,X,EPS,.FALSE.)
        IF(ABS(AIMAG(X)).LE.2.*EPS**2*ABS(REAL(X))) X=CMPLX(REAL(X),0.)
        ROOTS(J)=X
        B=AD(J+1)
        DO 12 JJ=J,1,-1
          C=AD(JJ)
          AD(JJ)=B
          B=X*B+C
12      CONTINUE
13    CONTINUE
      IF (POLISH) THEN
        DO 14 J=1,M
          CALL LAGUER(A,M,ROOTS(J),EPS,.TRUE.)
14      CONTINUE
      ENDIF
      DO 16 J=2,M
        X=ROOTS(J)
        DO 15 I=J-1,1,-1
          IF(REAL(ROOTS(I)).LE.REAL(X))GO TO 10
          ROOTS(I+1)=ROOTS(I)
15      CONTINUE
        I=0
10      ROOTS(I+1)=X
16    CONTINUE
      RETURN
      END