c=====================================================================72
      subroutine princip(a,ye,ee, ierr)
      real*8 a(3,3), ye(3), ee(3,3)
      real*8 P,Q,R, aa, bb, pi, modulus, argument, ae(3,3), y
      real*8 fNorm, temp, x1, x2, x3, theta, ddot
      logical debug
      debug = .false.

cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
c    Solve for eigenvalues
cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
      ! Calculate P, Q, R invarients of eigenvalue equations
      P = a(1,1) + a(2,2) + a(3,3)
      Q = a(1,1)*a(2,2) - a(1,2)*a(2,1) +
     1    a(1,1)*a(3,3) - a(1,3)*a(3,1) +
     1    a(2,2)*a(3,3) - a(2,3)*a(3,2)
      R = a(1,1)*a(2,2)*a(3,3) - a(1,1)*a(2,3)*a(3,2) +
     1    a(1,2)*a(2,3)*a(3,1) - a(1,2)*a(2,1)*a(3,3) +
     1    a(1,3)*a(2,1)*a(3,2) - a(1,3)*a(2,2)*a(3,1)

      if(debug) write (6,*) 'PQR =', P, Q, R

      ! Solve eigenvalue equation:  det(Sd-yI) = -(y**3) + P*(y**2) - Q*y + R = 0
      ! => y**3 + p*(y**2) + q*y + r = 0
      ! where p = -P   q = Q   r = -R
      ! Let y = x - p/3 = x + P/3
      ! solve:  x**3 + a*x + b = 0
      ! where a = (3*q - p**2)/3  b = (2*p**3 - 9*p*q + 27*r)/27
      aa = (3.0d0 * Q - P*P) / 3.0d0
      bb = (9.0d0*P*Q  - 2.0d0*P*P*P - 27.0d0 * R) / 27.0d0

      if(.not. (aa .lt. 0.0d0)) then
c      write (6,*) "=============================================="
c        write (6,*) 'aa,bb =', aa, bb
c        do i=1,3
c          write (6,*) "a(i,j): ",(a(i,j),j=1,3)
c        enddo
c        write (6,*) "P = ", P
c        write (6,*) "Q = ", Q
c        write (6,*) "aa = (3.0d0 * Q - P*P) / 3.0d0"
c        write (6,*) "aa = ", aa
c        write (6,*) "aa > 0 in a symmetric matix"
c      write (6,*) "=============================================="
c        ierr = -1

        ierr = 0
        do i = 1, 3
          do j = 1, 3
            ee(i,j) = 0.0d+00
          enddo
          ye(i) = 0.0d+00
          ee(i,i) = 1.0d+00
        enddo
        return
      endif

      pi = 2.0d0 * acos(0.0d0)
      modulus = 2.0d0 * sqrt(-aa / 3.0d0)
      argument = 3.0d0 * bb / (aa * modulus)
      if(argument .ge. 1.0d0) then
        theta = 0.0d0
      else if(argument .le. -1.0d0) then
        theta = pi
      else
        theta = acos(argument) / 3.0d0
      endif

      if(debug) write (6,*) 'Modulus,theta =', modulus,theta
      if(debug) write (6,*) '3.0d0*bb/(aa*modulus) =', argument

       x1 = modulus * cos(theta)
       x2 = modulus * cos(theta + 2.0d0 * pi / 3.0d0)
       x3 = modulus * cos(theta + 4.0d0 * pi / 3.0d0)

      if(debug) write (6,*) 'x123 =', x1,x2,x3

       ye(1) = x1 + P / 3.0d0
       ye(2) = x2 + P / 3.0d0
       ye(3) = x3 + P / 3.0d0

      if(debug) write (6,*) 'ye123 =', (ye(i),i=1,3)

       ! Sort: largest to smallest
       do i = 1, 2
         imax = i
         do j = i+1, 3
           if(ye(j) .gt. ye(imax)) imax = j
         enddo
         if(imax .ne. i) then
           temp = ye(i)
           ye(i) = ye(imax)
           ye(imax) = temp
         endif
       enddo

cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
c     Now solve for eigenvectors
cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
      ! eigenvalues 1 & 3 are farthest appart in value
      do ign = 1, 3, 2
        y = ye(ign)
        do j=1,3
        do i=1,3
          ae(i,j) = a(i,j)
          if(i .eq. j) ae(i,j) = a(i,j) - y
        enddo
        enddo

        if(debug) then
        write (6,*) 'ign=', ign
        do i=1,3
          write (6,*) (ae(i,j),j=1,3)
        enddo
        write (6,*) ' '
        endif

        ! Find 1st pivot
        a1max = -1.0d0
        do j=1,3
        do i=1,3
          if(abs(ae(i,j)) .gt. a1max) then
            a1max = abs(ae(i,j))
            i1    = i
            j1    = j
          endif
        enddo
        enddo

        ! reduce column of pivot (j1)
        do i=1,3
          if(i .ne. i1) then
            factor = ae(i,j1) / ae(i1,j1)
            do j=1,3
              ae(i,j) = ae(i,j) - factor * ae(i1,j)
            enddo
          endif
        enddo

        if(debug) then
          write (6,*) 'i1,j1=', i1,j1
          do i=1,3
            write (6,*) (ae(i,j),j=1,3)
          enddo
          write (6,*) ' '
         endif

        ! Find 2nd pivot
        a2max = -1.0d0
        do j=1,3
        do i=1,3
          if(abs(ae(i,j)).gt.a2max .and. i.ne.i1 .and. j.ne.j1) then
            a2max = abs(ae(i,j))
            i2    = i
            j2    = j
          endif
        enddo
        enddo

        ! Find remaining column
        if(j1.ne.1 .and. j2.ne.1) j3 = 1
        if(j1.ne.2 .and. j2.ne.2) j3 = 2
        if(j1.ne.3 .and. j2.ne.3) j3 = 3

c        write (6,*) 'j123=', j1, j2, j3

        ! Can now solve for eigenvector (ae(i2,j1) was row reduced to 0)
        ! 0 =                        ae(i2,j2)*ee(j2,ign) + ae(i2,j3)*ee(j3,ign)
        ! 0 = ae(i1,j1)*ee(j1,ign) + ae(i1,j2)*ee(j2,ign) + ae(i1,j3)*ee(j3,ign)
        !
        ee(j3,ign) = 1.0
        ee(j2,ign) = -ae(i2,j3)/ae(i2,j2)
        ee(j1,ign) = -(ae(i1,j2)*ee(j2,ign) + ae(i1,j3)*ee(j3,ign))
     1             /  ae(i1,j1)

        if(debug) then
          write (6,998) "ee       =", (ee(j,ign), j=1,3)
          write (6,998) "ae(i1,:) =", (ae(i1, j), j=1,3)
998       format(a10, 3f10.5)
          write (6,*) ' '
          write (6,*) ' '
        endif

c        ireduce = 1
c        do i=ireduce+1,3
c          factor = ae(i,ireduce) / ae(ireduce,ireduce)
c          do j=1,3
c            ae(i,j) = ae(i,j) - factor * a(ireduce,j)
c          enddo
c        enddo
c        ee(2,ign) = 1.0d0
c        ee(3,ign) = -ae(2,2) /ae(2,3)
c        ee(1,ign) = -(ae(1,2)*ee(2,ign) + ae(1,3)*ee(3,ign)) / ae(1,1)

         call dnormalize(ee(1,ign))
      enddo

      if(debug) then
        write (6,*) "before graham-shmidtt for ee3:  ee1, ee3"
        write (6,*) (ee(i,1),i=1,3)
        write (6,*) (ee(i,3),i=1,3)
        write (6,*) " "
      endif

      ! Make sure e3 is normal to e1
      d13 = ddot(ee(1,1),ee(1,3))
      do i=1,3
        ee(i,3) = ee(i,3) - d13*ee(i,1)
      enddo

      if(debug) then
        write (6,*) "after ee3 = ee3 - d13*ee1:  ee1 then ee3"
        write (6,*) "d13 = ", d13
        write (6,*) (ee(i,1),i=1,3)
        write (6,*) (ee(i,3),i=1,3)
        write (6,*) " "
      endif

      call dnormalize(ee(1,3))

      if(debug) then
        write (6,*) "after normailize ee3:  ee3"
        write (6,*) (ee(i,3),i=1,3)
        write (6,*) " "
      endif

      ! Construct e2 normal to e1 and e3
      ee(1,2) = ee(2,3)*ee(3,1) - ee(3,3)*ee(2,1)
      ee(2,2) = ee(3,3)*ee(1,1) - ee(1,3)*ee(3,1)
      ee(3,2) = ee(1,3)*ee(2,1) - ee(2,3)*ee(1,1)

      if(debug) then
        write (6,*) "before  normailization of ee2:  ee2"
        write (6,*) (ee(i,2),i=1,3)
        write (6,*) " "
      endif

      call dnormalize(ee(1,2))
      if(debug) write (6,*) "anorm ee2:", (ee(i,2),i=1,3)
      if(debug) then
        write (6,*) "after  normailization of ee2:  ee2"
        write (6,*) (ee(i,2),i=1,3)
        write (6,*) " "
      endif

      ierr = 0
      return
      end

c---------------------------------------------------------------------72
      subroutine dnormalize(v)
      real*8 v(3), fNorm
      fNorm = 1.0d0 / sqrt(v(1)**2+v(2)**2+v(3)**2)
      v(1) = fNorm * v(1)
      v(2) = fNorm * v(2)
      v(3) = fNorm * v(3)
      return
      end

c---------------------------------------------------------------------72
      real*8 function ddot(a,b)
      real*8 a(3),b(3)
      ddot = a(1)*b(1) + a(2)*b(2) + a(3)*b(3)
      return
      end

c---------------------------------------------------------------------72


c This file contains two algorithms for the logarithm of the gamma function.
c Algorithm AS 245 is the faster (but longer) and gives an accuracy of about
c 10-12 significant decimal digits except for small regions around X = 1 and
c X = 2, where the function goes to zero.
c The second algorithm is not part of the AS algorithms.   It is slower but
c gives 14 or more significant decimal digits accuracy, except around X = 1
c and X = 2.   The Lanczos series from which this algorithm is derived is
c interesting in that it is a convergent series approximation for the gamma
c function, whereas the familiar series due to De Moivre (and usually wrongly
c called Stirling's approximation) is only an asymptotic approximation, as
c is the true and preferable approximation due to Stirling.
c
c
c
      DOUBLE PRECISION FUNCTION ALNGAM(XVALUE, IFAULT)
C
C     ALGORITHM AS245  APPL. STATIST. (1989) VOL. 38, NO. 2
C
C     Calculation of the logarithm of the gamma function
C
      INTEGER IFAULT
      DOUBLE PRECISION ALR2PI, FOUR, HALF, ONE, ONEP5, R1(9), R2(9),
     +          R3(9), R4(5), TWELVE, X, X1, X2, XLGE, XLGST, XVALUE,
     +          Y, ZERO
C
C     Coefficients of rational functions
C
      DATA R1/-2.66685 51149 5D0, -2.44387 53423 7D1,
     +        -2.19698 95892 8D1,  1.11667 54126 2D1,
     +         3.13060 54762 3D0,  6.07771 38777 1D-1,
     +         1.19400 90572 1D1,  3.14690 11574 9D1,
     +         1.52346 87407 0D1/
      DATA R2/-7.83359 29944 9D1, -1.42046 29668 8D2,
     +         1.37519 41641 6D2,  7.86994 92415 4D1,
     +         4.16438 92222 8D0,  4.70668 76606 0D1,
     +         3.13399 21589 4D2,  2.63505 07472 1D2,
     +         4.33400 02251 4D1/
      DATA R3/-2.12159 57232 3D5,  2.30661 51061 6D5,
     +         2.74647 64470 5D4, -4.02621 11997 5D4,
     +        -2.29660 72978 0D3, -1.16328 49500 4D5,
     +        -1.46025 93751 1D5, -2.42357 40962 9D4,
     +        -5.70691 00932 4D2/
      DATA R4/ 2.79195 31791 8525D-1, 4.91731 76105 05968D-1,
     +         6.92910 59929 1889D-2, 3.35034 38150 22304D0,
     +         6.01245 92597 64103D0/
C
C     Fixed constants
C
      DATA ALR2PI/9.18938 53320 4673D-1/, FOUR/4.D0/, HALF/0.5D0/,
     +     ONE/1.D0/, ONEP5/1.5D0/, TWELVE/12.D0/, ZERO/0.D0/
C
C     Machine-dependant constants.
C     A table of values is given at the top of page 399 of the paper.
C     These values are for the IEEE double-precision format for which
C     B = 2, t = 53 and U = 1023 in the notation of the paper.
C
      DATA XLGE/5.10D6/, XLGST/1.D+305/
C
      X = XVALUE
      ALNGAM = ZERO
C
C     Test for valid function argument
C
      IFAULT = 2
      IF (X .GE. XLGST) RETURN
      IFAULT = 1
      IF (X .LE. ZERO) RETURN
      IFAULT = 0
C
C     Calculation for 0 < X < 0.5 and 0.5 <= X < 1.5 combined
C
      IF (X .LT. ONEP5) THEN
        IF (X .LT. HALF) THEN
          ALNGAM = -LOG(X)
          Y = X + ONE
C
C     Test whether X < machine epsilon
C
          IF (Y .EQ. ONE) RETURN
        ELSE
          ALNGAM = ZERO
          Y = X
          X = (X - HALF) - HALF
        END IF
        ALNGAM = ALNGAM + X * ((((R1(5)*Y + R1(4))*Y + R1(3))*Y
     +                + R1(2))*Y + R1(1)) / ((((Y + R1(9))*Y + R1(8))*Y
     +                + R1(7))*Y + R1(6))
        RETURN
      END IF
C
C     Calculation for 1.5 <= X < 4.0
C
      IF (X .LT. FOUR) THEN
        Y = (X - ONE) - ONE
        ALNGAM = Y * ((((R2(5)*X + R2(4))*X + R2(3))*X + R2(2))*X
     +              + R2(1)) / ((((X + R2(9))*X + R2(8))*X + R2(7))*X
     +              + R2(6))
        RETURN
      END IF
C
C     Calculation for 4.0 <= X < 12.0
C
      IF (X .LT. TWELVE) THEN
        ALNGAM = ((((R3(5)*X + R3(4))*X + R3(3))*X + R3(2))*X + R3(1)) /
     +            ((((X + R3(9))*X + R3(8))*X + R3(7))*X + R3(6))
        RETURN
      END IF
C
C     Calculation for X >= 12.0
C
      Y = LOG(X)
      ALNGAM = X * (Y - ONE) - HALF * Y + ALR2PI
      IF (X .GT. XLGE) RETURN
      X1 = ONE / X
      X2 = X1 * X1
      ALNGAM = ALNGAM + X1 * ((R4(3)*X2 + R4(2))*X2 + R4(1)) /
     +              ((X2 + R4(5))*X2 + R4(4))
      RETURN
      END
c
c
c
c
        double precision function lngamma(z, ier)
c
c       Uses Lanczos-type approximation to ln(gamma) for z > 0.
c       Reference:
c            Lanczos, C. 'A precision approximation of the gamma
c                    function', J. SIAM Numer. Anal., B, 1, 86-96, 1964.
c       Accuracy: About 14 significant digits except for small regions
c                 in the vicinity of 1 and 2.
c
c       Programmer: Alan Miller
c                   CSIRO Division of Mathematics & Statistics
c
c       N.B. It is assumed that the Fortran compiler supports long
c            variable names, including the underline character.   Some
c            compilers will not accept the 'implicit none' statement
c            below.
c
c       Latest revision - 17 April 1988
c
        implicit none
        double precision a(9), z, lnsqrt2pi, tmp
        integer ier, j
        data a/0.9999999999995183d0, 676.5203681218835d0,
     +         -1259.139216722289d0, 771.3234287757674d0,
     +         -176.6150291498386d0, 12.50734324009056d0,
     +         -0.1385710331296526d0, 0.9934937113930748d-05,
     +         0.1659470187408462d-06/
c
        data lnsqrt2pi/0.91893 85332 04672 7d0/
c
        if (z .le. 0.d0) then
          ier = 1
          return
        end if
        ier = 0
c
        lngamma = 0.d0
        tmp = z + 7.d0
        do 10 j = 9, 2, -1
          lngamma = lngamma + a(j)/tmp
          tmp = tmp - 1.d0
   10   continue
        lngamma = lngamma + a(1)
        lngamma = log(lngamma) + lnsqrt2pi - (z+6.5d0) +
     +                               (z-0.5d0)*log(z+6.5d0)
        end


c************* "synth.sub.ftn" ---> binded with "synth.ftn" *********

c====================================================================
c      calculate generalized elastic moduli  (called by "synth.ftn")
c       after a rotation about symmetry axes;
c   note that this subroutine cannot calculate rotation about
c   an axis other than symmetry axes.
c
c *** The 3 axes of crystal are x1 (N), x2 (E), and x3 (Down) in
c *** the right-hand system. The crystal is then rotated clockwisely
c *** by the input angle.
c ***
c
c====================================================================
      subroutine elast  (ifiso,rho,dm,ifsym,azim,c)

c      implicit real*8 (a-h,o-z)
      dimension c(3,3,3,3),d(3,3,3,3)
      real*4  ce(6,6)

      pi=3.1415926536d0
      rad=pi/180.d0

c-----------------------------------------------------------------
c   set initial state :
c   horizontal (a-b) plane, propagation in symmetry plane.
c      ma=1, ifsym=1
c-----------------------------------------------------------------
      ma=1
      ifsym=1
      do 1 n=1,3
      do 1 m=1,3
      do 1 k=1,3
      do 1 j=1,3
    1 c(j,k,m,n)=0.d0
      do 2 j=1,6
      do 2 i=1,6
    2 ce(i,j)=0.
c--------------------------------------------------------------------
c        read in elastic moduli in (gpa = 10**9 pa);
c     =====>1 mbar = 100 gpa
c--------------------------------------------------------------------
      read(1,*)
      read(1,*)ifiso,rho,dm
      read(1,*)ce(1,1),ce(1,2),ce(1,3),ce(1,4),ce(1,5),ce(1,6),
     &                 ce(2,2),ce(2,3),ce(2,4),ce(2,5),ce(2,6),
     &                         ce(3,3),ce(3,4),ce(3,5),ce(3,6),
     &                                 ce(4,4),ce(4,5),ce(4,6),
     &                                         ce(5,5),ce(5,6),
     &                                                 ce(6,6)

      write(*,*) ce(1,1), ce(2,2), ce(3,3), ce(4,4), ce(5,5), ce(6,6)

c------------------------------------------------------------------
c       dump ce(m,n) to c(i,j,k,l)
c------------------------------------------------------------------
      call dump(ce,c)

c-------------------------------------------------------------------
c        generate constants to a total of 81
c-------------------------------------------------------------------
      do 90 i=1,3
      do 90 j=i,3
      do 90 m=i,3
      do 90 n=m,3
      c(i,j,n,m)=c(i,j,m,n)
      c(j,i,m,n)=c(i,j,m,n)
      c(j,i,n,m)=c(i,j,m,n)

      c(m,n,i,j)=c(i,j,m,n)
      c(n,m,i,j)=c(i,j,n,m)
      c(m,n,j,i)=c(j,i,m,n)
   90 c(n,m,j,i)=c(j,i,n,m)

      if(ifiso.eq.1)return

c--------------------------------------------------------------------
c         *** this layer is anisotropic ***
c     choose the desired horizontal symmetry plane :
c           ma=1  test (a-b) plane; skip rotation.
c           ma=2  test (b-c) plane
c           ma=3  test (c-a) plane
c--------------------------------------------------------------------
      print *,' azimuthal variation in (1) a-b (2) b-c (3) c-a ?'
      read(5,*)ma

      if(ma.eq.2)then
c-------to form b-c, form c-b then rotate 90 degrees.
      lx=2
      th0=90.
      call elast_rotate (lx,th0,c,d)
      lx=3
      th0=-90.
      call elast_rotate (lx,th0,c,d)

      else if(ma.eq.3)then

c-------to form c-a, form a-c then rotate 90 degrees.
      lx=1
      th0=90.
      call elast_rotate (lx,th0,c,d)
      lx=3
      th0=90.
      call elast_rotate (lx,th0,c,d)

      end if

c---------------------------------------------------------------
c          global dip of the original a-axis
c  we do this prior to the azimuthal rotation, so the dip of the
c  original a-axis is fixed relative to the original coordinates.
c  in other words, for propagation in absolute N, old a-axis is
c  dipping down; for propagation in E, old a-axis is dipping to
c  the left. the later azimuthal rotation is done about new x3.
c---------------------------------------------------------------
      print *,'dip of a-axis = ?'
      read(*,*)dip
      if(dip.ne.0.)then
      lx=2
      th0=-dip
      call elast_rotate (lx,th0,c,d)
      end if

c---------------------------------------------------------------
c   now, rotate (1,2,3) about lx=3 to (by) the desired azimuth
c        and generate new c(3,3,3,3); lx=3 is + down.
c---------------------------------------------------------------
      print *,'=======> azimuth from x1 (or a-axis) = ?'
      read(*,*)azim

      if(azim.eq.0.)return

      if(azim.ne.0. .and. azim.ne.90.)ifsym=2

      lx=3
      call elast_rotate (lx,azim,c,d)
      return
      end

      subroutine dump(ce,c)
c      implicit real*8 (a-h,o-z)
      dimension  c(3,3,3,3)
      real*4  ce(6,6)
      c(1,1,1,1)=ce(1,1)
      c(1,1,2,2)=ce(1,2)
      c(1,1,3,3)=ce(1,3)
      c(1,1,2,3)=ce(1,4)
      c(1,1,1,3)=ce(1,5)
      c(1,1,1,2)=ce(1,6)

      c(2,2,2,2)=ce(2,2)
      c(2,2,3,3)=ce(2,3)
      c(2,2,2,3)=ce(2,4)
      c(1,3,2,2)=ce(2,5)
      c(1,2,2,2)=ce(2,6)

      c(3,3,3,3)=ce(3,3)
      c(2,3,3,3)=ce(3,4)
      c(1,3,3,3)=ce(3,5)
      c(1,2,3,3)=ce(3,6)

      c(2,3,2,3)=ce(4,4)
      c(1,3,2,3)=ce(4,5)
      c(1,2,2,3)=ce(4,6)

      c(1,3,1,3)=ce(5,5)
      c(1,2,1,3)=ce(5,6)

      c(1,2,1,2)=ce(6,6)

      return
      end

      subroutine elast_rotate (lx,th0,c,d)
c---------------------------------------------------------------

c   rotate the coordinates (1,2,3) about rotation axis lx by an
c   angle th0 to a new coordinates (1',2',3'),
c   and convert c(i,j,k,l) to c'(i,j,k,l) in the new coordinates.

c      input  : c(3,3,3,3), rotation axis lx, rotation angle th0.
c      output : c(3,3,3,3) at new rotated coordinate.

c    in 2-D system, this is just rotation by a 2-D tensor :

c                 x1'= cos(1',1)*x1+cos(1',2)*x2
c                 x2'= cos(2',1)*x1+cos(2',2)*x2

c    in 4-index, 3-D system, this is :

c                    c'(m1,m2,m3,m4) =

c    SUM  cos(m1,k1)*cos(m2,k2)*cos(m3,k3)*cos(m4,k4)*c(k1,k2,k3,k4)
c   k1=1,3
c   k2=1,3
c   k3=1,3
c   k4=1,3

c      where m refers to axis no. in prime system
c        and k refers to axis no. in original system.

c            for lx=3

c     if m=k=3,      cos(m,k)=1             e.g., cos(3',3)
c     if m=k.ne.3,   cos(m,k)=cos(theta)    e.g., cos(1',1)
c                                                 cos(2',2)
c     if m=lperm(3)  cos(m,k)=sin(theta),   e.g., cos(1',2)
c     else           cos(m,k)=-sin(theta)   e.g., cos(2',1)

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

      dimension c(3,3,3,3),d(3,3,3,3),lperm(3)
      rad=3.1415926536d0/180.d0
      lperm(1)=2
      lperm(2)=3
      lperm(3)=1

      co=cos(th0*rad)
      si=sin(th0*rad)

      do 150 m1=1,3
      do 150 m2=1,3
      do 150 m3=1,3
      do 150 m4=1,3

      d(m1,m2,m3,m4)=0.

      do 140 k1=1,3

       if(k1.eq.m1)then

          if(k1.eq.lx)then
          d1=1.
          else
          d1=co
          end if

       else if (m1.eq.lx.or.k1.eq.lx)then
          d1=0.
       else if (m1.eq.lperm(lx))then
          d1=si
       else
          d1=-si
       end if

      do 140 k2=1,3

       if(k2.eq.m2)then

          if(k2.eq.lx)then
          d2=1.
          else
          d2=co
          end if

       else if (m2.eq.lx.or.k2.eq.lx)then
          d2=0.
       else if (m2.eq.lperm(lx))then
          d2=si
       else
          d2=-si
       end if

      do 140 k3=1,3

       if(k3.eq.m3)then

          if(k3.eq.lx)then
          d3=1.
          else
          d3=co
          end if

       else if (m3.eq.lx.or.k3.eq.lx)then
          d3=0.
       else if (m3.eq.lperm(lx))then
          d3=si
       else
          d3=-si
       end if

      do 140 k4=1,3

       if(k4.eq.m4)then

          if(k4.eq.lx)then
          d4=1.
          else
          d4=co
          end if

       else if (m4.eq.lx.or.k4.eq.lx)then
          d4=0.
       else if (m4.eq.lperm(lx))then
          d4=si
       else
          d4=-si
       end if

      d(m1,m2,m3,m4)=d(m1,m2,m3,m4)+d1*d2*d3*d4*c(k1,k2,k3,k4)

  140 continue

  150 continue

c--------------------- new elastic moduli -------------------------
      do 160 k1=1,3
      do 160 k2=1,3
      do 160 k3=1,3
      do 160 k4=1,3
  160 c(k1,k2,k3,k4)=d(k1,k2,k3,k4)

      return
      end

c---------------------------------------------------------------------
c       called by "synth" to create a 6-degree polynomial for q3
c                q3 : vertical slowness
c---------------------------------------------------------------------
      subroutine polyf (c,av,rho,p,polyq)
      implicit real*8 (a-h,o-z)
      real*8  neg1,neg2,neg3,p(3,3,0:2),polyq(0:6)
      real*4  c(3,3,3,3),rho
      do 10 n=0,6
   10 polyq(n)=0.d0

      q1=1.d0/av
      q3=1.d0
      do 100 j=1,3
      do 100 m=1,3
      p(j,m,0)=c(j,1,m,1)*q1*q1
      p(j,m,1)=( c(j,1,m,3)+c(j,3,m,1) )*q1*q3
      p(j,m,2)=c(j,3,m,3)*q3*q3
  100 continue
      do 101 j=1,3
  101 p(j,j,0)=p(j,j,0)-rho

      do 140 i=0,2
      do 140 j=0,2
      do 140 k=0,2
      m=i+j+k
      pos1=p(1,1,i)*p(2,2,j)*p(3,3,k)
  140 polyq(m)=polyq(m)+pos1
      do 150 i=0,2
      do 150 j=0,2
      do 150 k=0,2
      m=i+j+k
      pos2=p(2,1,i)*p(3,2,j)*p(1,3,k)
  150 polyq(m)=polyq(m)+pos2
      do 160 i=0,2
      do 160 j=0,2
      do 160 k=0,2
      m=i+j+k
      pos3=p(1,2,i)*p(2,3,j)*p(3,1,k)
  160 polyq(m)=polyq(m)+pos3
      do 170 i=0,2
      do 170 j=0,2
      do 170 k=0,2
      m=i+j+k
      neg1=p(1,3,i)*p(2,2,j)*p(3,1,k)
  170 polyq(m)=polyq(m)-neg1
      do 180 i=0,2
      do 180 j=0,2
      do 180 k=0,2
      m=i+j+k
      neg2=p(2,3,i)*p(3,2,j)*p(1,1,k)
  180 polyq(m)=polyq(m)-neg2
      do 190 i=0,2
      do 190 j=0,2
      do 190 k=0,2
      m=i+j+k
      neg3=p(1,2,i)*p(2,1,j)*p(3,3,k)
  190 polyq(m)=polyq(m)-neg3
      return
      end

c--------------------------------------------------------------------
c          bairstow's algarithm : called by "synth"
c--------------------------------------------------------------------
      subroutine bairs (n,a,solu)
      implicit real*8 (a-h,o-z)
      real*8 a(13),b(13),c(13),denom,o,r,s,delr,dels,tol,tolp,
     -       xr1,xi1,xr2,xi2,solu(2,13)
      complex solu4

      np3=n+3

c--------- set initial guess r=0, s=0;  tol0=1.d-7  tolp0=1.d-7% -----
      tol0=1.d-20
      tolp0=1.d-20
      b(1)=0.
      b(2)=0.
      c(1)=0.
      c(2)=0.
      kr=0
      r=0.
      s=0.
   80 write(21,'( /''tolp='',e7.2,''%'',3x,''**new solutions**'')')
     &tolp0*100.
      tol=tol0
      tolp=tolp0
   81 write(21,'(1x,''iterations :'')')

      do 20 i=1,80
      do 10 j=3,np3
      b(j)=a(j)+r*b(j-1)+s*b(j-2)
   10 c(j)=b(j)+r*c(j-1)+s*c(j-2)
      denom=c(n+1)*c(n+1)-c(n+2)*c(n)
      if(denom.ne.0.d0)go to 12
      r=r+1.d0
      s=s+1.d0
      go to 81
   12 delr=(-b(n+2)*c(n+1)+b(n+3)*c(n))/denom
      dels=(-c(n+1)*b(n+3)+c(n+2)*b(n+2))/denom
      r=r+delr
      s=s+dels
      if(dabs(r).lt.1.d-40)r=0.d0
      if(dabs(s).lt.1.d-40)s=0.d0

      mr=0
      if(r.eq.0.d0)then
      if(dabs(delr).lt.tol)mr=1
      else
      if(dabs(delr/r).lt.tolp)mr=1
      end if

      ms=0
      if(s.eq.0.d0)then
      if(dabs(dels).lt.tol)ms=1
      else
      if(dabs(dels/s).lt.tolp)ms=1
      end if

      if(mr.eq.1.and.ms.eq.1)go to 21
   20 continue
      print *,'accuracy not met in 80 iterations --> relax'
      tolp=tolp*10.
      write(21,'(1x,''accuracy not met in 80 steps==> relax'')')
      write(21,'(1x,''tolp='',e7.2,''%'')')tolp*100.
      go to 81

c===================================================================
c  now, the 1st quradratic equation has been factored from
c  the original polynomial : find the roots (may be complex)
c===================================================================
   21 write(21,'(15x,''satistied at step '',i2)')i
      write(21,'(''quadratic form that was factored out='')')
      o=1.d0
      write(21,'(e14.6,'' xx +'',e14.6,'' x +'',e14.6)')o,-r,-s
      call root(o,-r,-s,xr1,xi1,xr2,xi2)
      kr=kr+1
      solu(1,kr)=xr1
      solu(2,kr)=xi1

      kr=kr+1
      solu(1,kr)=xr2
      solu(2,kr)=xi2
      write(21,1001)xr1,xi1,xr2,xi2
 1001 format('roots=','(',2e23.15,')',/6x,'(',2e23.15,')')

c===================================================================
c  here, the reduced equation is checked against 3 possibilities:
c  (1)degree=1 (2)degree=2 (3)degree>2.
c===================================================================
      n=n-2
      if(n-2)22,23,24
c(1)--------- reduced equation is of degree 1
   22 continue
      write(21,'(''reduced linear form='')')
      write(21,'(e14.6,'' xx +'',e14.6,'' x +'',e14.6)')b(n+2),
     &b(n+3)
      xr1=-b(n+3)/b(n+2)
      kr=kr+1
      solu(1,kr)=xr1
      solu(2,kr)=0.
      write(21,*)solu(1,kr),solu(2,kr)

      return

c(2)--------- reduced equation is of degree 2
   23 continue
      write(21,'( /''reduced quadratic form='')')
      write(21,'(e14.6,'' xx +'',e14.6,'' x +'',e14.6)')b(n+1),
     &  b(n+2),b(n+3)
      call root(b(n+1),b(n+2),b(n+3),xr1,xi1,xr2,xi2)
      kr=kr+1
      solu(1,kr)=xr1
      solu(2,kr)=xi1
      write(21,1001)xr1,xi1,xr2,xi2

      kr=kr+1
      solu(1,kr)=xr2
      solu(2,kr)=xi2

      return

c(3)--------- degree > 2; set coeffs. into "a" and get next factor
   24 np3=n+3
      do 30 i=3,np3
   30 a(i)=b(i)
      write(21,'( /''reduced equation='')')
      write(21,'(5e14.5)')(a(i),i=3,np3)

c====================================================================
c       this is the case : a(3)*(xxxx) + a(5)*(xx) + a(7) :
c       degree 4 equation for x but quadratic for x*x.
c---------------------------------------------------------------------

      if(n.ne.4)go to 80
      if(dabs(a(4)).gt.1.d-30.and.dabs(a(6)).gt.1.d-30)go to 80
        call root(a(3),a(5),a(7),xr1,xi1,xr2,xi2)
        kr=kr+1
      write(21,1002)xr1,xi1,xr2,xi2
 1002 format('x**2= ','(',2e23.15,')',/6x,'(',2e23.15,')')

c--------------------------------------------------------------------
c  now, xr1,xi1; xr2,xi2 are solution to the 4th degree equation.
c  before take the square-root of the solutions, check if they
c  are complex. if they are, make them complex of real*4 and use
c  "csqrt" to obtain the solution.
c--------------------------------------------------------------------
c------------ 1st solution
      if(dabs(xi1).gt.1.d-7)then
        solu4=cmplx(xr1,xi1)
        solu4=csqrt(solu4)
        solu(1,kr)=real(solu4)
        solu(2,kr)=aimag(solu4)
      else if(xr1.gt.0.)then
        solu(1,kr)=dsqrt(xr1)
        solu(2,kr)=0.
      else
        solu(1,kr)=0.
        solu(2,kr)=dsqrt(-xr1)
      end if

        kr=kr+1
        solu(1,kr)=-solu(1,kr-1)
        solu(2,kr)=-solu(2,kr-1)

c------------ 2nd solution
        kr=kr+1
      if(dabs(xi2).gt.1.d-7)then
        solu4=cmplx(xr2,xi2)
        solu4=csqrt(solu4)
        solu(1,kr)=real(solu4)
        solu(2,kr)=aimag(solu4)
      else if(xr2.gt.0.)then
        solu(1,kr)=dsqrt(xr2)
        solu(2,kr)=0.
      else
        solu(1,kr)=0.
        solu(2,kr)=dsqrt(-xr2)
      end if

        kr=kr+1
        solu(1,kr)=-solu(1,kr-1)
        solu(2,kr)=-solu(2,kr-1)

        return

      end

      subroutine root(a,b,c,xr1,xi1,xr2,xi2)
c--------------------------------------------------
c        root of a(x*x) + b(x) + c = 0.
c--------------------------------------------------
      implicit real*8 (a-h,o-z)
c------this criterion is set particularly for calculating "q3"
      tol=1.d-20
      t=b*b-4.d0*a*c

      abst=dabs(t)
      sqabst=dsqrt(abst)
      if(b.eq.0.d0)then
      write(21,'(''b='',e23.15,'' sqrt(bb-4ac)='',e23.15)')b,sqabst
      ratio=1
      else
      ratio=dabs(sqabst/b)
      write(21,'('' sqrt(bb-4ac)/b = '',e23.15)')ratio
      end if

        if(ratio.gt.1.d-7)then
        tt=sqabst
        else
        tt=0.d0
        end if

        if(t.lt.0.d0)then
c--------------------------- complex roots
        xr1=-b/(2.d0*a)
        xi1=tt/(2.d0*a)
        xr2=xr1
        xi2=-xi1
        else
c--------------------------- real roots
        xr1=(-b+tt)/(2.*a)
        xr2=(-b-tt)/(2.*a)
        xi1=0.d0
        xi2=0.d0
        end if

      return
      end

      subroutine frank (l,p,q3,f,ifiso,ifsym)
c--------------------------------------------------------
c              called by "synth"
c--------------------------------------------------------
      implicit real*8 (a-h,o-z)
      integer max,min
      dimension p(3,3,0:2),q3(6),f(3,3,6)
      do 100 n=1,6
      q6=q3(n)*q3(n)
      do 90  m=1,3
      do 90  j=1,3
   90 f(j,m,n)=p(j,m,0)+p(j,m,1)*q3(n)+p(j,m,2)*q6
  100 continue

c---------------------------------------------------------------------
c     to separate "sh" in isotropic medium in order to get [f] :
c                           a b 0
c                  [f] :    c d 0
c                           0 0 e
c----------------------------------------------------------------
      do 200 n=1,6

      do 180 i=1,3
      temp=f(i,2,n)
      f(i,2,n)=f(i,3,n)
  180 f(i,3,n)=temp
      do 190 j=1,3
      temp=f(2,j,n)
      f(2,j,n)=f(3,j,n)
  190 f(3,j,n)=temp

  200 continue

      if(ifsym.eq.2)go to 888

c---------------------------------------------------------------------
c        for iso-  and  aniso-in-symmetry layers
c        vertical slownesses are arranged in the order of
c              p+  p-  sv+  sv-  sh+  sh-
c   but,  "q3" may not be in this order when sorted out from "bairs"
c               ======> check and rearrange [f] and [q3]
c     q3(n) which makes f(3,3,n) non-zero correspond to "p"
c     q3(n) which makes f(3,3,n) zero correspond to "sh"
c---------------------------------------------------------------------
      tmax= dabs(f(3,3,1))
      max=1
      do 20 n=3,5,2
      if( dabs(f(3,3,n)).gt.tmax)then
      tmax= dabs(f(3,3,n))
      max=n
      end if
   20 continue
      if(max.eq.1)go to 29
      do 14 i=1,3
      do 14 j=1,3
      temp=f(i,j,1)
      f(i,j,1)=f(i,j,max)
      f(i,j,max)=temp
      temp=f(i,j,2)
      f(i,j,2)=f(i,j,max+1)
   14 f(i,j,max+1)=temp
      temp=q3(1)
      q3(1)=q3(max)
      q3(max)=temp
      temp=q3(2)
      q3(2)=q3(max+1)
      q3(max+1)=temp
c---------------------------------------------------------------------
c     now, max f(3,3,n) in n=1,2; search for the min and put in n=5,6
c---------------------------------------------------------------------
   29 if( dabs(f(3,3,3)).lt. dabs(f(3,3,5)))then

      do 17 i=1,3
      do 17 j=1,3
      temp=f(i,j,3)
      f(i,j,3)=f(i,j,5)
      f(i,j,5)=temp
      temp=f(i,j,4)
      f(i,j,4)=f(i,j,6)
   17 f(i,j,6)=temp
      temp=q3(3)
      q3(3)=q3(5)
      q3(5)=temp
      temp=q3(4)
      q3(4)=q3(6)
      q3(6)=temp

      end if

  888 write(21,'(1x,'' "q3" : rearranged vertical slowness='')')
      do 101 n=1,6
  101 write(21,'(1x,f20.8)')q3(n)

c---------------- write up f matrix ?

c      write(21,'(1x,''f='')')
c      do 95 n=1,6
c      write(21,*)n
c      do 95 i1=1,3
c   95 write(21,'(1x,3e13.5)')(f(i1,j1,n)   ,j1=1,3)

      return
      end

      subroutine angle(l,q1,q3)
c----------------------------------------------------------
c    "angle" called by synth to calculate the incidence angle
c            for each waves in each layer, knowing q1 and q3.
c     first determine velocity by  sqrt(1/v*v-q1*q1)=q3;
c     then use q3=cos(i)/v
c-----------------------------------------------------------
      implicit real*8 (a-h,o-z)
      dimension q3(6)

      rad=180.d0/3.1415926536d0

      sqq1=q1*q1
      vp=1.d0/dsqrt(sqq1+q3(1)*q3(1))
      vs1=1.d0/dsqrt(sqq1+q3(3)*q3(3))
      vs2=1.d0/dsqrt(sqq1+q3(5)*q3(5))

      tp=dacos(vp*q3(1))
      ts1=dacos(vs1*q3(3))
      ts2=dacos(vs2*q3(5))

      write(21,'(''incidence angle of P, S1, S2 :'')')
      write(21,'(3f7.3)')tp*rad,ts1*rad,ts2*rad

      return
      end

      subroutine plriz (l,f,a,ifiso,ifsym)
c====================================================================
c                       called by "synth"
c       calculate "polarization vector" <a> for corresponding "q3"
c             <a>=<x1,x3,x2>=<x,z,y>==<u,w,v>
c====================================================================
c                  for incident "p" wave :
c     in isotropic layer or in symmetry plane of anisotropic layer,
c     f(1,3,n)=f(2,3,n)=f(3,1,n)=f(3,2,n)=0,        so
c                        "p","sv" are separateed from "sh"
c     in isotropic layer, only q3 for n=1,2 lead f(3,3,n) non-zero;
c     therefore <a> for "p" = <a1,a3,0>
c     q3 for n=3,4,5,6 all lead f(3,3,n)=0.  but we shold determine
c     <a> for "sv" from the upperleft 2 by 2 submatrix, which will also
c     have a form of <a1,a3,0>, and <a> for "sh" is ought to be <0,0,1>.
c                        however,
c     in symmetry plane of aniso-layer, n=1,2 plus n=3,4 "or" n=5,6
c     lead f(3,3,n) non-zero, so <a> for "p" & "sv" can be determined
c     as <a1,a3,0>;    "sh", corresponding to those q3(n) that make
c     f(3,3,n) zero, has <a>=<0,0,1>
c
c     in off-symmetry plane of aniso-layer,  <a> for one "p" wave and
c     "two shear waves" are determined through the whole 3 by 3 [f]
c--------------------------------------------------------------------
      implicit real*8 (a-h,o-z)
      dimension  f(3,3,6),a(3,6),d(6)

      if(ifsym.ne.1)go to 700
c--------------------------------------------------------------------
c             in symmetry plane, "sh" needs special treatment
c--------------------------------------------------------------------
      do 10 n=1,6
   10 d(n)= dsqrt(f(1,1,n)*f(1,1,n)+f(1,2,n)*f(1,2,n))

      do 13 n=1,4
      a(1,n)= f(1,2,n)/d(n)
      a(3,n)=-f(1,1,n)/d(n)
   13 a(2,n)=0.d0

c------------------- in "frank", n=5,6 has been arranged for "sh"
      do 15 n=5,6
      a(1,n)=0.
      a(3,n)=0.
   15 a(2,n)=1.

      go to 801
c-------------------------------------------------------------------
c        anisotropic medium
c-------------------------------------------------------------------
  700 do 800 n=1,6
      d(1)=f(2,2,n)*f(3,3,n)-f(2,3,n)*f(3,2,n)
      d(3)=f(2,3,n)*f(3,1,n)-f(2,1,n)*f(3,3,n)
      d(2)=f(2,1,n)*f(3,2,n)-f(2,2,n)*f(3,1,n)
      d0= dsqrt(d(1)*d(1)+d(3)*d(3)+d(2)*d(2))
      a(1,n)=d(1)/d0
      a(3,n)=d(3)/d0
  800 a(2,n)=d(2)/d0

  801 write(21,*)
      write(21,'(''check if the polarization gives "0"'')')
      mmm=0
      do 400 n=1,6
      do 300 i=1,3
      d(i)=0.
      d(i)=d(i)+f(i,1,n)*a(1,n)+f(i,2,n)*a(3,n)+f(i,3,n)*a(2,n)
      if( dabs(d(i)).gt.1.d-5)then
      print *,dabs(d(i)),'==>polarization vectors are not correct'
      mmm=1
      end if
  300 continue
  400 write(21,'(3e15.6)')( dabs(d(i)) , i=1,3)

      write(21,'(''===(x,y,z) of polarization vectors==='')')
      do 200 n=1,6
  200 write(21,'(3f20.8)')(a(jj,n),jj=1,3)
c      if(mmm.eq.1)stop

      return
      end

      subroutine conti (nl,l,a,c,av,q3,e,einv,aa)
c--------------------------------------------------------------------
c                called by "synth"
c--------------------------------------------------------------------
      implicit real*8 (a-h,o-z)
      dimension  q3(6),e(6,6),a(3,6),einv(6,6),e1(6,6)
c           [c] is real*4 generated by sub "elast"
c           [aa] will be multipled by complex variables
      real*4  c(3,3,3,3),aa(6,6,6)

c-------------------------------------------
c                     calculate [e]
c----------------------------------------u1
      do 101 n=1,6
  101 e(1,n)=a(1,n)
c----------------------------------------u3
      do 102 n=1,6
  102 e(2,n)=a(3,n)
c----------------------------------------t33
      do 103 n=1,6
      e(3,n)=0.
      do 103 m=1,3
  103 e(3,n)=e(3,n)+a(m,n)*(c(3,3,m,1)+c(3,3,m,3)*av*q3(n))
c----------------------------------------t31
      do 104 n=1,6
      e(4,n)=0.
      do 104 m=1,3
  104 e(4,n)=e(4,n)+a(m,n)*(c(3,1,m,1)+c(3,1,m,3)*av*q3(n))
c----------------------------------------u2
      do 105 n=1,6
  105 e(5,n)=a(2,n)
c----------------------------------------t32
      do 106 n=1,6
      e(6,n)=0.
      do 106 m=1,3
  106 e(6,n)=e(6,n)+a(m,n)*(c(3,2,m,1)+c(3,2,m,3)*av*q3(n))

c=====================================================================
c                     calculate "inverse-e"
c               save 'e' before calling 'gauss'
c=====================================================================
      write(21,'('' e-matrix='')')
      do 116 i=1,6
      write(21,'(6f12.5)')(e(i,j),j=1,6)
      do 116 j=1,6
  116 e1(i,j)=e(i,j)

      do 118 j=1,6
      do 117 i=1,6
  117 einv(i,j)=0.
  118 einv(j,j)=1.

      call gauss (e1,einv,6,6,6)

c--------- IMSL subroutine
c     call linv1f (e1,6,6,einv,9,wk,ier)
c----------IMSL subroutine for complex [e].
c     call leq2c (e, 6, 6, einv, 6, 6,   0,wa,wk,ier)

      do 206 i=1,6
      do 206 j=1,6
       if(dabs( einv(i,j) ) .lt. 1.d-30) einv(i,j)=0.d0
  206 continue

c*****************************************************************
      if(l.eq.nl)return
c=====================================================================
c        construct a matrix [aa] for the phase effects between
c        interfaces.  no phase change in the bottom half space.

c     [ aa(i,j,k) ] < phase(l,n,freq) > = [ al(l,i,k,freq) ]
c=====================================================================

      do 555 k=1,6
      do 555 i=1,6
      do 555 n=1,6
      aa(i,n,k)=e(i,n)*einv(n,k)
  555 continue

      return
      end

      subroutine gauss (a,b,n,nr,ndim)
c----------------------------------------------

c      gaussian elimination method with pivoting

c                   solve [a][x]=[b] ;  solution will be in [b]
c          n=number of equations=number of unknowns
c          nr=number of rhs vectors=number of columns of [b]
c          ndim=first dimension of [a] and [b] claimed
c               in calling program

c----------------------------------------------
      implicit real*8 (a-h,o-z)
      dimension a(ndim,n),b(ndim,nr)

      np1=n+1
c-------------- now pivoting and decomposition
      do 200 i=1,n-1

      ipvt=i
      ip1=i+1
      do 10 j=ip1,n
      if( dabs(a(ipvt,i)) .lt. dabs(a(j,i)) )ipvt=j
   10 continue

      if( dabs(a(ipvt,i)) .lt. 1.d-6) go to 99
      if(ipvt.eq.i)go to 50

c------------------------- switch
      do 20 jcol=i,n
      save=a(i,jcol)
      a(i,jcol)=a(ipvt,jcol)
   20 a(ipvt,jcol)=save
      do 21 jcol=1,nr
      save=b(i,jcol)
      b(i,jcol)=b(ipvt,jcol)
   21 b(ipvt,jcol)=save

   50 do 100 jrow=ip1,n
      if(a(jrow,i).eq.0.)go to 100
      ratio=a(jrow,i)/a(i,i)
      do 30 kcol=ip1,n
   30 a(jrow,kcol)=a(jrow,kcol)-ratio*a(i,kcol)
      do 31 kcol=1,nr
   31 b(jrow,kcol)=b(jrow,kcol)-ratio*b(i,kcol)
  100 continue

  200 continue

      if(dabs(a(n,n)) .lt. 1.d-6)go to 99
c--------------- now, backsubstitution : solve for each rhs vector.

      do 500 kcol=1,nr

      b(n,kcol)=b(n,kcol)/a(n,n)
      do 400 j=2,n
      nvbl=np1-j
      l=nvbl+1
      value=b(nvbl,kcol)
      do 300 k=l,n
      value=value-a(nvbl,k)*b(k,kcol)
  300 continue
      b(nvbl,kcol)=value/a(nvbl,nvbl)
  400 continue

  500 continue
      return

   99 print *,'pivot=',dabs(a(n,n)),'n=',n,'program stops!!!'
      return
      end

      subroutine cgauss (a,b,n,nr,ndim)
c----------------------------------------------
c                 complex, single precision
c      gaussian elimination method with pivoting
c                   solve [a][x]=[b] ;  solution will be in [b]
c          n=number of equations=number of unknowns
c          nr=number of rhs vectors=number of columns of [b]
c          ndim=first dimension of [a] and [b] claimed
c               in calling program
c----------------------------------------------
      complex a(ndim,n),b(ndim,nr),save,ratio,value

      np1=n+1
c-------------- now pivoting and decomposition
      do 200 i=1,n-1

      ipvt=i
      ip1=i+1
      do 10 j=ip1,n
      if( cabs(a(ipvt,i)) .lt. cabs(a(j,i)) )ipvt=j
   10 continue

      if( cabs(a(ipvt,i)) .lt. 1.e-6) go to 99
      if(ipvt.eq.i)go to 50

c------------------------- switch
      do 20 jcol=i,n
      save=a(i,jcol)
      a(i,jcol)=a(ipvt,jcol)
   20 a(ipvt,jcol)=save
      do 21 jcol=1,nr
      save=b(i,jcol)
      b(i,jcol)=b(ipvt,jcol)
   21 b(ipvt,jcol)=save

   50 do 100 jrow=ip1,n
      if(a(jrow,i).eq.0.)go to 100
      ratio=a(jrow,i)/a(i,i)
      do 30 kcol=ip1,n
   30 a(jrow,kcol)=a(jrow,kcol)-ratio*a(i,kcol)
      do 31 kcol=1,nr
   31 b(jrow,kcol)=b(jrow,kcol)-ratio*b(i,kcol)
  100 continue

  200 continue

      if(cabs(a(n,n)) .lt. 1.e-6)go to 99
c--------------- now, backsubstitution : solve for each rhs vector.

      do 500 kcol=1,nr

      b(n,kcol)=b(n,kcol)/a(n,n)
      do 400 j=2,n
      nvbl=np1-j
      l=nvbl+1
      value=b(nvbl,kcol)
      do 300 k=l,n
      value=value-a(nvbl,k)*b(k,kcol)
  300 continue
      b(nvbl,kcol)=value/a(nvbl,nvbl)
  400 continue

  500 continue
      return

   99 print *,'pivot=',cabs(a(n,n)),'cn=',n,'program stops!!!!'

      return
      end


module functionh
implicit none
contains
	real*16 function h(z) result(t)
		real*16 :: z

		t = (1.0 / (z ** z)) - z - 1.0
	end function h

	real*16 function dhdz(z) result(t)
		real*16 :: z

		t = -((z ** z) * (1.0 + log(z)) + 1.0)
	end function dhdz

	real*16 function minusdhdz(z) result(t)
		real*16 :: z

		t = (z ** z) * (1.0 + log(z)) + 1.0
	end function minusdhdz
end module functionh

program crap
use functionh
implicit none
! x will be in [e - 1, e]
	real*16 :: z = 0.5
	integer :: step

	write(*, *) 0, z, 1.0 / z
	do step = 1, 64
!		z = z - h(z) / dhdz(z)
		z = z + h(z) / minusdhdz(z)
		write(*, *) step, z, 1.0 / z
	end do
end program crap


C ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
C                       Fluides géophysiques  v14         (11.04.96)
C                       -------------------------
C   . Red Black
C   . Calcul des vitesses
C   . Sauvegarde tous les X pas de temps
C ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++

C ------------------------------------------------------------------
C                            Declarations
C ------------------------------------------------------------------
      double precision U, g, f
      integer pasx, pasy, pasx2, Nmax
      parameter(U=1D-1, g=1D-2, f=1D-4)
      parameter(pasx=31, pasx2=32, pasy=31)
      integer i, j, n, fin, compt, startj, start, save, fsave, saveu
      double precision pi, h0, L, T, Lx, Ly, Bu, Ro, Et, w
      double precision dx, dy, dt, tol, x(pasx2), y(pasx), kmoy
      double precision temp1, temp2, temp3, temp4, temp5, erreur
      double precision eta(pasx2,pasy), b(pasx2,pasy), q(pasx2,pasy)
      double precision aeta1, aeta2, jacob(pasx2,pasy), deta(pasx2,2)
      double precision leta(pasx2,pasy), v1(pasx2,pasy), v2(pasx2,pasy)

C ------------------------------------------------------------------
C                            Donnees
C ------------------------------------------------------------------

      write(*,*)'L (5000)?'
      read(*,*)L
      write(*,*)'Lx/L (5)?'
      read(*,*)Lx

      pi    = acos(-1.)
      h0    = 1D2
      T     = L/U
      Ly    = amin1((3./4.+g*h0/(2.*f*U*L)), 4.)
      Bu    = g*h0/(f*L)**2
      Ro    = U/(f*L)
      Et    = 1/(f*T)
      dx    = 2.*Lx/(pasx-1)
      dt    = dx*dx/2.
      dy    = 2.*Ly/(pasy-1)
      kmoy  = 0.
      save  = 1

      write(*,*)'Ly/L =',Ly,'(',(3./4.+g*h0/(2.*f*U*L)),')'
      write(*,*)'Bu   =',Bu,'Ro   =',Ro
      write(*,*)'dx   =',dx,' ; dy   =',dy
      write(*,*)'pasx =',pasx,' ; pasy =',pasy
      write(*,*)'T    =',T,'dH   =',f*L*U/g
      write(*,*)'dt (max) =',dt,'sec.'
      write(*,*)'Le canal fait ',2*Lx*L,'mètres de long'
      write(*,*)'           et ',2*Ly*L,'mètres de large'
      write(*,*)'tol (1D-6)?'
      read(*,*)tol
      write(*,*)'w (1.825)?'
      read(*,*)w
      write(*,*)'dt (2D-2)?'
      read(*,*)dt
      write(*,*)'Nmax (100)?'
      read(*,*)Nmax
      write(*,*)'fsave (Nmax)?'
      read(*,*)fsave
      write(*,*)'save U (1 = oui)?'
      read(*,*)saveu

      if(fsave.GT.Nmax) then
         fsave=Nmax
      endif

      write(*,*)
      write(*,*)'Un pas de temps =',T*dt,'sec.'

C ------------------------------------------------------------------
C                      Calcul du profil initial
C ------------------------------------------------------------------

      do 10 i=2,pasx+1
         x(i)=(i-2)*dx
10    continue
      x(1)=x(pasx)
      x(2)=x(pasx+1)

      do 20 j=1,pasy
         y(j)=-Ly+(j-1)*dy
20    continue

      temp1 = g*h0/f/L/U
      do 30 i=1,pasx+1
         temp2 = 0.01*sin(pi*x(i)/Lx)
         do 30 j=1,pasy
            if(abs(y(j)).LT.1) then
               eta(i,j)=temp1*temp2-0.5*y(j)**2*(1+temp2)
            else
               eta(i,j)=temp1*temp2+(0.5-abs(y(j)))*(1+temp2)
            endif
30    continue

C ------------------------------------------------------------------
C       Ouverture du fichier RES.M et sauv. le profil initial
C ------------------------------------------------------------------

      open (UNIT = 1, FILE = 'res_orig.m', STATUS ='unknown')

      do 111 i=2,pasx+1
         do 111 j=1,pasy
            write(1,*)'a(',(save-1)*pasx+i-1,',',j,')=',eta(i,j),';'
111   continue

C ------------------------------------------------------------------
C            Boucle principale (progression dans le temps)
C ------------------------------------------------------------------

      do 40 n=1,Nmax
      write(*,*)'Pas de temps n :',n

C        ------------------------------------
C        -- Calcul de Beta et du laplacien --
C        ------------------------------------

C        -- Interieur --

      do 50 i=2,pasx
         do 50 j=2,pasy-1
            temp1=(eta(i-1,j)+eta(i+1,j)-2*eta(i,j))/(dx*dx)
     *            +(eta(i,j-1)+eta(i,j+1)-2*eta(i,j))/(dy*dy)
            temp2=((eta(i+1,j)-eta(i-1,j))/(2*dx))**2
     *            +((eta(i,j+1)-eta(i,j-1))/(2*dy))**2
            b(i,j)=(Bu+Ro*eta(i,j))*temp1+Ro/2*temp2
            q(i,j)=temp1
50    continue

C        -- Bords y --

      do 60 i=2,pasx
         j=1
         temp1=(eta(i-1,j)+eta(i+1,j)-2*eta(i,j))/(dx*dx)
     *         +(eta(i,j)+eta(i,j+2)-2*eta(i,j+1))/(dy*dy)
         temp2=((eta(i+1,j)-eta(i-1,j))/(2*dx))**2
     *         +((4*eta(i,j+1)-eta(i,j+2)-3*eta(i,j))/(2*dy))**2
         b(i,j)=(Bu+Ro*eta(i,j))*temp1+Ro/2*temp2
         q(i,j)=temp1
         j=pasy
         temp1=(eta(i-1,j)+eta(i+1,j)-2*eta(i,j))/(dx*dx)
     *         +(eta(i,j)+eta(i,j-2)-2*eta(i,j-1))/(dy*dy)
         temp2=((eta(i+1,j)-eta(i-1,j))/(2*dx))**2
     *         +((-4*eta(i,j-1)+eta(i,j-2)+3*eta(i,j))/(2*dy))**2
         b(i,j)=(Bu+Ro*eta(i,j))*temp1+Ro/2*temp2
         q(i,j)=temp1
60    continue

C        -- Ajout des lignes i=1 et i=pasx+1 --

      do 70 j=1,pasy
         b(1,j)=b(pasx,j)
         b(pasx+1,j)=b(2,j)
         q(1,j)=q(pasx,j)
         q(pasx+1,j)=q(2,j)
70    continue

C        ------------------------
C        -- Calcul du Jacobien --
C        ------------------------

      do 80 i=2,pasx
         do 80 j=2,pasy-1
         temp1=((eta(i+1,j)-eta(i-1,j))*(b(i,j+1)-b(i,j-1))-
     *          (eta(i,j+1)-eta(i,j-1))*(b(i+1,j)-b(i-1,j)))/4/dx/dy
         temp2=(eta(i+1,j)*(b(i+1,j+1)-b(i+1,j-1))-eta(i-1,j)*
     *          (b(i-1,j+1)-b(i-1,j-1))-eta(i,j+1)*(b(i+1,j+1)
     *          -b(i-1,j+1))+eta(i,j-1)*(b(i+1,j-1)-b(i-1,j-1)))
     *          /4/dx/dy
         temp3=(b(i,j+1)*(eta(i+1,j+1)-eta(i-1,j+1))-b(i,j-1)*
     *          (eta(i+1,j-1)-eta(i-1,j-1))-b(i+1,j)*(eta(i+1,j+1)-
     *          eta(i+1,j-1))+b(i-1,j)*(eta(i-1,j+1)-eta(i-1,j-1)))
     *          /4/dx/dy
         jacob(i,j)=(temp1+temp2+temp3)/3
80    continue

C        -- Ajout des lignes i=1 et i=pasx+1 --

      do 90 j=1,pasy
         jacob(1,j)=jacob(pasx,j)
         jacob(pasx+1,j)=jacob(2,j)
90    continue

C        -----------------
C        -- Calcul de q --
C        -----------------

      do 100 i=1,pasx+1
        do 100 j=1,pasy
           q(i,j)=Bu*q(i,j)-eta(i,j)
           q(i,j)=q(i,j)-Ro/Et*dt*jacob(i,j)
100   continue

C        ----------------------------------------
C        -- Calcul de d(eta)/dy pour les bords --
C        ----------------------------------------

      do 110 i=1,pasx+1
         deta(i,1)=(4*eta(i,2)-eta(i,3)-3*eta(i,1))/(2*dy)
         deta(i,2)=(-4*eta(i,pasy-1)+eta(i,pasy-2)+3*eta(i,pasy))
     *              /(2*dy)
110   continue

C        ---------------
C        -- Red Black --
C        ---------------

      fin=0
      compt=0
120   compt=compt+1
      fin=1
C                 - Deux passages alternes -
      do 130 startj=1,2
         start=startj
C                       - Red Black -
         do 140 i=2,pasx
            do 150 j=start+1,pasy-1,2
               temp1=-2/dx**2-2/dy**2-1/Bu
               temp1=(q(i,j)/Bu-(eta(i+1,j)+eta(i-1,j))/dx**2
     *               -(eta(i,j+1)+eta(i,j-1))/dy**2)/temp1
               temp1=eta(i,j)+w*(temp1-eta(i,j))
               if(abs(eta(i,j)).GT.0) then
                  erreur=abs((temp1-eta(i,j))/eta(i,j))
                  if(erreur.GT.tol) then
                     fin=0
                  endif
               endif
               eta(i,j)=temp1
150         continue

            if(start.EQ.2) then
               start=1
            else
               start=2
            endif
140      continue

         do 160 j=1,pasy
            eta(1,j)=eta(pasx,j)
            eta(pasx+1,j)=eta(2,j)
160      continue

130   continue

C                  - Conditions aux limites -
      aeta1=eta(1,1)
      aeta2=eta(1,pasy)

      do 170 i=2,pasx
         j=1
         temp1=(eta(i+1,j)-aeta1)/(2*dx)
         temp2=(eta(i,j+2)-2*eta(i,j+1))/dy**2
          d1=(eta(i+1,j)-aeta1)/(2*dx)
          d2=(eta(i+1,j+1)-eta(i-1,j+1))/(2*dx)
          d3=(eta(i+1,j+2)-eta(i-1,j+2))/(2*dx)
         temp3=(4*d2-d3-3*d1)/(2*dy)
         temp4=-3*Et/(2*dy*dt)+3*Ro*temp3/(2*dy)+Ro*temp1/dy**2
         temp5=(temp1-Et*((4*eta(i,j+1)-eta(i,j+2))/(2*dy*dt)-
     *         deta(i,1)/dt)-Ro*temp1*temp2+Ro*temp3*
     *         (4*eta(i,j+1)-eta(i,j+2))/(2*dy))/temp4
         temp5=eta(i,j)+w*(temp5-eta(i,j))
         if(abs(eta(i,j)).GT.0) then
            erreur=abs((temp5-eta(i,j))/eta(i,j))
            if(erreur.GT.tol) then
               fin=0
            endif
         endif
         aeta1=eta(i,j)
         eta(i,j)=temp5

         j=pasy
         temp1=(eta(i+1,j)-aeta2)/(2*dx)
         temp2=(eta(i,j-2)-2*eta(i,j-1))/dy**2
          d1=(eta(i+1,j)-aeta2)/(2*dx)
          d2=(eta(i+1,j-1)-eta(i-1,j-1))/(2*dx)
          d3=(eta(i+1,j-2)-eta(i-1,j-2))/(2*dx)
         temp3=(-4*d2+d3+3*d1)/(2*dy)
         temp4=3*Et/(2*dy*dt)-3*Ro*temp3/(2*dy)+Ro*temp1/dy**2
         temp5=(temp1-Et*((-4*eta(i,j-1)+eta(i,j-2))/(2*dy*dt)
     *         -deta(i,2)/dt)-Ro*temp1*temp2+Ro*temp3*
     *         (-4*eta(i,j-1)+eta(i,j-2))/(2*dy))/temp4
         temp5=eta(i,j)+w*(temp5-eta(i,j))
         if(abs(eta(i,j)).GT.0) then
            erreur=abs((temp5-eta(i,j))/eta(i,j))
            if(erreur.GT.tol) then
               fin=0
            endif
         endif
         aeta2=eta(i,j)
         eta(i,j)=temp5
170   continue
C                         -  Periodicite -
      do 180 j=1,pasy
         eta(1,j)=eta(pasx,j)
         eta(pasx+1,j)=eta(2,j)
180   continue

      if(fin.EQ.0) goto 120

      write(*,*)'    no it. =',compt
      kmoy=kmoy+compt

C        ----------------------------------------------
C        -- Copie de eta (futur calcul des vitesses) --
C        ----------------------------------------------

      if(n.EQ.save*fsave-1) then
         do 190 i=1,pasx2
            do 190 j=1,pasy
               leta(i,j)=eta(i,j)
190      continue
      endif

C        -------------------------
C        -- Calcul des vitesses --
C        -------------------------
      if(saveu.EQ.1) then
      if(n.EQ.save*fsave) then
      do 210 i=2,pasx
         do 200 j=2,pasy-1

C                        - u (interieur) -

            temp1=(eta(i,j+1)-eta(i,j-1))/2/dy
            temp2=(eta(i+1,j)-eta(i-1,j))/2/dx
            temp3=(leta(i+1,j)-leta(i-1,j))/2/dx
            temp4=(eta(i+1,j+1)-eta(i-1,j+1)-eta(i+1,j-1)
     *            +eta(i-1,j-1))/(4*dy*dy)
            temp5=(eta(i+1,j)+eta(i-1,j)-2*eta(i,j))/(dx*dx)
            v1(i,j)=-temp1-Et*(temp2-temp3)/dt-Ro*
     *             (temp2*temp4-temp1*temp5)

C                        - v (interieur) -

            temp3=(leta(i,j+1)-leta(i,j-1))/2/dy
            temp5=(eta(i,j+1)+eta(i,j-1)-2*eta(i,j))/(dy*dy)
            v2(i,j)=temp2-Et*(temp1-temp3)/dt-Ro*
     *             (temp2*temp5-temp1*temp4)
200       continue
          j=1

C                          - u (j=1) -

            temp1=(4*eta(i,j+1)-eta(i,j+2)-3*eta(i,j))/2/dy
            temp2=(eta(i+1,j)-eta(i-1,j))/2/dx
            temp3=(leta(i+1,j)-leta(i-1,j))/2/dx
             d1=temp2
             d2=(eta(i+1,j+1)-eta(i-1,j+1))/(2*dx)
             d3=(eta(i+1,j+2)-eta(i-1,j+2))/(2*dx)
            temp4=(4*d2-d3-3*d1)/(2*dy)
            temp5=(eta(i+1,j)+eta(i-1,j)-2*eta(i,j))/(dx*dx)
            v1(i,j)=-temp1-Et*(temp2-temp3)/dt-Ro*
     *             (temp2*temp4-temp1*temp5)

C                          - v (j=1) -

            temp3=(4*leta(i,j+1)-leta(i,j+2)-3*leta(i,j))/2/dy
            temp5=(eta(i,j+2)+eta(i,j)-2*eta(i,j+1))/(dy*dy)
            v2(i,j)=temp2-Et*(temp1-temp3)/dt-Ro*
     *             (temp2*temp5-temp1*temp4)
          j=pasy

C                         - u (j=pasy) -

            temp1=(-4*eta(i,j-1)+eta(i,j-2)+3*eta(i,j))/2/dy
            temp2=(eta(i+1,j)-eta(i-1,j))/2/dx
            temp3=(leta(i+1,j)-leta(i-1,j))/2/dx
             d1=temp2
             d2=(eta(i+1,j-1)-eta(i-1,j-1))/(2*dx)
             d3=(eta(i+1,j-2)-eta(i-1,j-2))/(2*dx)
            temp4=(-4*d2+d3+3*d1)/(2*dy)
            temp5=(eta(i+1,j)+eta(i-1,j)-2*eta(i,j))/(dx*dx)
            v1(i,j)=-temp1-Et*(temp2-temp3)/dt-Ro*
     *             (temp2*temp4-temp1*temp5)

C                         - v (j=pasy) -

            temp3=(-4*leta(i,j-1)+leta(i,j-2)+3*leta(i,j))/2/dy
            temp5=(eta(i,j-2)+eta(i,j)-2*eta(i,j-1))/(dy*dy)
            v2(i,j)=temp2-Et*(temp1-temp3)/dt-Ro*
     *             (temp2*temp5-temp1*temp4)
210   continue

C                         - periodicite -
      do 220 j=1,pasy
         v1(pasx+1,j)=v1(2,j)
         v2(pasx+1,j)=v2(2,j)
220   continue
      endif
      endif

C        --------------------------------
C        -- Resultats (save -> Matlab) --
C        --------------------------------

      if(n.EQ.save*fsave) then
         do 31 i=2,pasx+1
            do 31 j=1,pasy
               write(1,*)'a(',(save)*pasx+i-1,',',j,')=',eta(i,j),';'
               if(saveu.EQ.1) then
                  write(1,*)'u(',(save)*pasx+i-1,',',j,')=',v1(i,j),';'
                  write(1,*)'v(',(save)*pasx+i-1,',',j,')=',v2(i,j),';'
               endif
31       continue
         save=save+1
      endif

40    continue
      close (UNIT=1)

C ------------------------------------------------------------------
C                     Commentaires finaux
C ------------------------------------------------------------------

      write(*,*)'Calcul effectué sur ',Nmax*T*dt,'sec.'
      write(*,*)'Nb itérations (moy) ',kmoy/Nmax
      write(*,*)'Résultats dans RES.M'

      end


      subroutine polyg (x,y,sl,m,th)
       n=m
      xn = x
      yn = y
      th0 = th * 0.01745
      call move	(x,y,0)
      if (n) 10,100,20
   10 th1=-6.2832 / n
      th2= -th1	* 2.0
      n= -n
      do 11 i =	1,n
      xn = xn +	sl* cos(th0)
      yn = yn +	sl* sin(th0)
      call move	(xn,yn,1)
      th0 = th0	+ th1
      xn = xn +sl * cos(th0)
      yn = yn +	sl * sin(th0)
      call move	(xn,yn,1)
   11 th0 = th0	+ th2
  100 return
   20 th1 =6.2832 / n
      do 21  i = 1,n
      xn = xn +	sl * cos(th0)
      yn = yn +sl * sin(th0)
      call  move (xn,yn,1)
   21 th0 = th0	+ th1
      return
      end


 	SUBROUTINE GMERLM  ( mproj, np, xl, yl, anglr1, xm, ym, iret )
C************************************************************************
C* GMERLM								*
C* 									*
C* This subroutine converts a point from x, y coordinates to		*
C* map coordinates for the general Mercator.  See Cylindrical class	*
C* for the normal Mercator projection.					*
C* 									*
C* GMERLM  ( MPROJ, NP, XL, YL, ANGLR1, XM, YM, IRET )			*
C*									*
C* Input parameters:							*
C*	MPROJ		INTEGER		Projection type ( not used )	*
C*	NP		INTEGER		Number of points		*
C* 	XL(*) 		REAL		X coordinates			*
C* 	YL(*) 		REAL		Y coordinates			*
C*	ANGLR1		REAL		Center longitude		*
C* 									*
C* Output parameters:							*
C* 	XM(*)		REAL		Latitudes			*
C* 	YM(*)		REAL		Longitudes			*
C*	IRET		INTEGER		Return code			*
C** 									*
C* Log:									*
C* B. Doty/RDS		 4/87	GEMPLT Version 4			*
C* M. desJardins/GSFC	 6/88	Documentation				*
C* K. Brill/NMC		 4/91	Check for ATAN ( 0, 0 )			*
C* K. Brill/NMC		10/92	Make it so input & output can be same	*
C************************************************************************
	INCLUDE		'ERROR.PRM'
	INCLUDE		'GEMPRM.PRM'
C*
	REAL		xm (*), ym (*), xl (*), yl (*)
C------------------------------------------------------------------------
	iret = NORMAL
C*
	DO  i = 1, np
	    xmm    = ASIN ( SIN ( yl (i) ) / COSH ( xl (i) ) )
	    xxx    = SINH ( xl (i) )
	    yyy    = COS  ( yl (i) )
	    IF ( xxx .eq. 0.0 .and. yyy .eq. 0.0 ) THEN
		ym (i) = anglr1
	    ELSE
	        ym (i) = anglr1 + ATAN2 ( xxx, yyy )
	    END IF
	    xm (i) = xmm    * RTD
	    ym (i) = ym (i) * RTD
	END DO
C*
	RETURN
	END


module Player
  implicit none

contains

subroutine Init(candidates)
  integer, intent(in out) :: candidates(:)
  integer :: a, b, c, d, n

           n = 0
thousands: do a = 1, 9
hundreds:    do b = 1, 9
tens:          do c = 1, 9
units:           do d = 1, 9
                   if (b == a) cycle hundreds
                   if (c == b .or. c == a) cycle tens
                   if (d == c .or. d == b .or. d == a) cycle units
                   n = n + 1
                   candidates(n) = a*1000 + b*100 + c*10 + d
                 end do units
               end do tens
             end do hundreds
           end do thousands

end subroutine init

subroutine Evaluate(bulls, cows, guess, candidates)
  integer, intent(in) :: bulls, cows, guess
  integer, intent(in out) :: candidates(:)
  integer :: b, c, s, i, j
  character(4) :: n1, n2

  write(n1, "(i4)") guess
  do i = 1, size(candidates)
    if (candidates(i) == 0) cycle
    b = 0
    c = 0
    write(n2, "(i4)") candidates(i)
    do j = 1, 4
      s = index(n1, n2(j:j))
      if(s /= 0) then
        if(s == j) then
          b = b + 1
        else
          c = c + 1
        end if
      end if
    end do
    if(.not.(b == bulls .and. c == cows)) candidates(i) = 0
  end do
end subroutine Evaluate

function Nextguess(candidates)
  integer :: Nextguess
  integer, intent(in out) :: candidates(:)
  integer :: i

  nextguess = 0
  do i = 1, size(candidates)
    if(candidates(i) /= 0) then
      nextguess = candidates(i)
      candidates(i) = 0
      return
     end if
  end do
end function
end module Player

program Bulls_Cows
  use Player
  implicit none

  integer :: bulls, cows, initial, guess
  integer :: candidates(3024) = 0
  real :: rnum

! Fill candidates array with all possible number combinations
  call Init(candidates)

! Random initial guess
  call random_seed
  call random_number(rnum)
  initial = 3024 * rnum + 1
  guess = candidates(initial)
  candidates(initial) = 0

  do
    write(*, "(a, i4)") "My guess is ", guess
    write(*, "(a)", advance = "no") "Please score number of Bulls and Cows: "
    read*, bulls, cows
    write(*,*)
    if (bulls == 4) then
      write(*, "(a)") "Solved!"
      exit
    end if

! We haven't found the solution yet so evaluate the remaining candidates
! and eliminate those that do not match the previous score given
    call Evaluate(bulls, cows, guess, candidates)

! Get the next guess from the candidates that are left
    guess = Nextguess(candidates)
    if(guess == 0) then
! If we get here then no solution is achievable from the scores given or the program is bugged
      write(*, "(a)") "Sorry! I can't find a solution. Possible mistake in the scoring"
      exit
    end if
  end do
end program


c=======================================================================
c
c     subroutine ALLOCTESTRFR
c
c     Max. parameters for Allocation strategies with risk-free asset
c       - Max. target return
c       - Max. relative targer return
c       - Min. volatility
c       - Min. VaR
c       - Min. CVaR
c
c-----------------------------------------------------------------------
      SUBROUTINE alloctestrfr ( n, cov, rho, rfr, rhob, alpha,
     &                          neq, nin, ccst, bcst,
     &                          cinf, csup, cinfrfr, csuprfr,
     &                          iwork, dwork,
     &                          targetmax, deltamax,
     &                          volmin, varmin, cvarmin,
     &                          info)
c-----------------------------------------------------------------------
c
c     INPUT
c       n         : portfolio size                               integer
c       cov       : covariance matrix (n*n)                       double
c       rho       : mean returns vector (n)                       double
c       rfr       : risk-free rate                                double
c       rhob      : mean return of index                          double
c       alpha     : confidence level parameter (0<alpha<1)        double
c       neq       : number equality constraints                  integer
c       nin       : number inequality constraints                integer
c       ccst      : matrix of constraints (nasset*(neq+nin))      double
c       bcst      : vector initial of constraints (neq+nin)       double
c       cinf      : lower bound (n)                               double
c       csup      : upper bound (n)                               double
c       cinfrfr   : risk-free asset lower bound                   double
c       csuprfr   : risk-free asset upper bound                   double
c
c     WORKSPACE
c       iwork     : 6*n + 2*nin + neq + 13                       integer
c       dwork     : n*(9*n+2*neq+2*nin+27)+7*nin+5*neq+41         double
c
c     OUTPUT
c       targetmax : maximum target return (MV)                    double
c       deltamax  : maximum relative target return (IT)           double
c       volmin    : minimum volatility                            double
c       varmin    : minimum Value-at-Risk (VaR)                   double
c       cvarmin   : minimum Conditional Value-at-Risk (CVaR)      double
c       info      : diagnostic argument                          integer
c
c-----------------------------------------------------------------------
c
      IMPLICIT NONE
c
c     arguments i/o
      INTEGER n, info, neq, nin
      DOUBLE PRECISION rfr, rhob, alpha, targetmax, deltamax, volmin,
     &                 varmin, cvarmin, cinfrfr, csuprfr
      DOUBLE PRECISION cov(*), rho(*), cinf(*), csup(*), ccst(*),bcst(*)
c
c     workspaces
      INTEGER iwork(*)
      DOUBLE PRECISION dwork(*)
c
c     local variables
      INTEGER i, nbc, infotmp
      INTEGER piw, piclass, pdw, pdwopt, pdQ
      DOUBLE PRECISION mu, sigma, lagr, wrf, kappa, p, q, zc,
     &                 targetmin, EPS, ZERO, PI, DELTA
      PARAMETER (ZERO = 0.D0, PI = 3.1415926535898)
      PARAMETER (EPS = 1.E-15, DELTA = 1.E-8)
c
c     external functions
      DOUBLE PRECISION dinvnr
      EXTERNAL dinvnr
c
c     external subroutines
      EXTERNAL allocmvrfr, allocrbrfr, OVTMCV, IMX, EXARET
c
c-----------------------------------------------------------------------
c
c     initializations
      info = 0
      targetmax = 0.0
      deltamax  = 0.0
      volmin    = 0.0
      varmin    = 0.0
      cvarmin   = 0.0
c
c     pointers for integer work space : iwork
c     ---------------------------------------
      piclass = 1
c     piclass : pointer for asset claasification (n)
      piw     = piclass + ( n )
c     piw     : workspace 2*nbc + 5*n + 2*nin + neq + 11
c     Total size of iwork array = 6*n + 2*nin + neq + 13
c
c     pointers for double precision work space  : dwork
c     -------------------------------------------------
      pdwopt = 1
c     pdwopt : pointer for wopt ( n )
      pdQ    = pdwopt + ( n )
c     pdQ    : pointer for cov. matrix (n*n)
      pdw    = pdQ + ( n*n )
c     pdw    : workspace
c                nbc*(nbc+21)/2
c              + n*(8*n+2*neq+2*nin+26)+ 7*nin+5*neq+30
c              = n*(8*n+2*neq+2*nin+26)+ 7*nin+5*neq+41
c     Total size of dwork array = n*(9*n+2*neq+2*nin+27)+7*nin+5*neq+41
c
c-----------------------------------------------------------------------
c
c     min. volatility
      mu = -1.0E+15
      CALL allocmvrfr ( n, cov, rho, rfr,
     &                  neq, nin, ccst, bcst,
     &                  cinf, csup, cinfrfr, csuprfr, mu,
     &                  iwork(piw), dwork(pdw),
     &                  dwork(pdwopt), wrf, infotmp )
      IF (infotmp .LT. 0) info = infotmp
c
c     sqrt[w'*cov*w] (portfolio volatility)
      CALL OVTMCV ( n, cov, dwork(pdwopt), volmin)
      IF (volmin .GT. EPS) THEN
        volmin = SQRT(volmin) + DELTA
      ELSE
        volmin  = 0.0
      ENDIF
      CALL EXARET(n,rho,dwork(pdwopt),mu,infotmp)
      IF (infotmp.LT.0) RETURN
      targetmin = mu + wrf*rfr - DELTA
c
c     max. return: max[rho'*w]
      kappa = 0.0
      CALL IMX ( n, n, dwork(pdQ), ZERO )
      nbc = 1
      DO i = 1,n
        iwork(piclass + i - 1) = 1
      ENDDO
      sigma =  1.0E+15
      CALL allocrbrfr ( n, cov, dwork(pdQ), kappa, rho, rfr,
     &                  neq, nin, ccst, bcst,
     &                  cinf, csup, cinfrfr, csuprfr,
     &                  nbc, iwork(piclass), sigma,
     &                  iwork(piw), dwork(pdw),
     &                  dwork(pdwopt), wrf, lagr,
     &                  infotmp )
      IF (infotmp .LT. 0) info = infotmp
c
c     min return
      CALL EXARET ( n, rho, dwork(pdwopt), mu, infotmp )
      targetmax = mu + wrf*rfr
      deltamax = targetmax - rhob
c
c     test if: 0 < alpha < 1
      IF ((alpha .LT. EPS).OR.(alpha .GT. (1.0-EPS))) THEN
        info = -102
        RETURN
      ENDIF
c
c     computing inverse of the N(0,1) cumulative distribution
c     call the function dinvnr(p,q)
      p = alpha
      q = 1. - p
      zc = dinvnr(p,q)
c
c     case zc=0
      IF (ABS(zc) .GT. EPS) THEN
        zc = 1.0/zc
      ELSE
        varmin  = 0.0
        cvarmin = 0.0
        RETURN
      ENDIF
c
c     computing Normal -VaR := max[0, min(1, -zc*volatility - mean)]
      varmin = - volmin * zc + targetmin
      varmin = MIN(varmin, 1.)
      varmin = MAX(varmin, -1.)
c
c     coeff := [sqrt(2*pi)*exp[(zc/2)^2]*(1-alpha)]^(-1)
      zc = SQRT(2.0*PI)*EXP(((zc*zc)/4.0))*(1.0 - alpha)
c
c     computing Normal Conditional Value-at-Risk
c     CVaR := max[0, min(1, -coeff*volatility - mean)]
      cvarmin = - volmin * zc + targetmin
      cvarmin = MIN(cvarmin, 1.)
      cvarmin = MAX(cvarmin, -1.)
      RETURN
      END


           program demo_trailz
           use, intrinsic :: iso_fortran_env, only : integer_kinds, &
           & int8, int16, int32, int64
           implicit none
           integer(kind=int64) :: i, value
             write(*,*)'Default integer:'
             write(*,*)'bit_size=',bit_size(0)
             write(*,'(1x,i3,1x,i3,1x,b0)')-1,trailz(1),-1
             write(*,'(1x,i3,1x,i3,1x,b0)')0,trailz(0),0
             write(*,'(1x,i3,1x,i3,1x,b0)')1,trailz(1),1
             write(*,'(" huge(0)=",i0,1x,i0,1x,b0)') &
             & huge(0),trailz(huge(0)),huge(0)
             write(*,*)
             write(*,*)'integer(kind=int64):'

             do i=-1,62,5
                value=2**i
                write(*,'(1x,i19,1x,i3)')value,trailz(value)
             enddo
             value=huge(i)
             write(*,'(1x,i19,1x,i3,"(huge(0_int64))")')value,trailz(value)

             do i=-1,62,5
                value=2**i
                write(*,'(1x,i3,2x,b64.64)')i,value
             enddo
             value=huge(i)
             write(*,'(1x,a,1x,b64.64)') "huge",value

           end program demo_trailz


program kidou_ex2_7b
  implicit none
  integer::n
  real(8)::pi,e,l,u

  pi=4.0d0*atan(1.0d0)
  e=0.967
  l=(10d0/180)*pi

  u=l
  n=0
  write(*,*) n,(u/pi)*180
  do n=1,50
     u=l+e*sin(u)
     write(*,*) n,(u/pi)*180
  end do

end program kidou_ex2_7b


c-------------------------------------------------------------
c PROGRAM	      : main
c-------------------------------------------------------------

      program main
      implicit none
      integer i, n, step
      real*8 gamma, en, answer, error
      real*8 result, tol, false_position

      write(*,*)'Enter n, gamma, answer'
      read(*,*) n, gamma, answer

      en = -0.1d0
      step = 10
      tol = 1.0d0/step

      write(*,*) '--------------------------------------------'
      write(*,*) 'Molecular Vibrations : Quadratic Potential'
      write(*,*) ' '
      write(*,*) 'step = step size for simpson integration'
      write(*,*) 'tol = tolerance for false position method'
      write(*,*) 'n = ',n
      write(*,*) 'gamma = ',gamma
      write(*,*) 'Energy = Quantised energy level En'
      write(*,*) '--------------------------------------------'
      write(*,*) '    step     tol        Energy         Error'
      write(*,*) '--------------------------------------------'

      do 100 i = 0, 5, +1
            result  = false_position(n, gamma, step, en, tol)
            error = dabs(answer - result)
            write(*,20) step, tol, result, error
20          format(i8, f9.7, f14.10, e14.6)
            step = step*10
            tol = 1.0d0/step
100   continue

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

      end

c-------------------------------------------------------------
c FUNCTION        : xin
c-------------------------------------------------------------

      double precision function xin(en)
      implicit none
      real*8 en

      xin = (3.0d0-dsqrt(en + 1.0d0))/2.0d0
      return

      end

c-------------------------------------------------------------
c FUNCTION        : xout
c-------------------------------------------------------------

      double precision function xout(en)
      implicit none
      real*8 en

      xout = (3.0d0+dsqrt(en + 1.0d0))/2.0d0
      return

      end

c-------------------------------------------------------------
c FUNCTION        : f
c-------------------------------------------------------------

      double precision function f(en, n, gamma, step)
      implicit none
      integer*4 n, step
      real*8 xin, xout, simpson
      real*8 en, gamma, xi, xo, pi

      pi = 4*atan(1.0d0)
      xi = xin(en)
      xo = xout(en)

      f = gamma*simpson(step,xi,xo,en) - pi*(dfloat(n) + 0.5d0)
      return

      end

c-------------------------------------------------------------
c FUNCTION        : g
c PURPOSE         : integrand
c-------------------------------------------------------------

      double precision function g(en, x)
      implicit none
      real*8 en, x, v, arg

      arg = en - v(x)

      if (dabs(arg) .lt. 1.0E-14) then
        g = 0.0d0
      else
        g = dsqrt(arg)
      endif
      return

      end

c-------------------------------------------------------------
c FUNCTION        : v
c PURPOSE         : potential
c-------------------------------------------------------------

      double precision function v(x)
      implicit none
      real*8 x

      v = 4*(x-1)*(x-2)
      return

      end

c-------------------------------------------------------------
c FUNCTION        : simpson
c-------------------------------------------------------------

      double precision function simpson(step, a, b, en)
      implicit none
      integer*4 step, i, factor
      real*8 a, b, en
      real*8 h, sum, x, g

      i = 0
      factor = 4
      sum = 0.0d0
      x = 0.0d0
      h = (b-a)/dfloat(step)

      do 300 i = 1, (step-1), +1
            x = a+i*h
            if (factor .eq. 2) then
                  sum = sum + 2.0d0*g(en,x)
                  factor = 4
            else
                  sum = sum + 4.0d0*g(en,x)
                  factor = 2
            endif
300   continue
      sum = sum + g(en,a) + g(en,b)
      sum = (h*sum)/3.0d0

      simpson = sum
      return

      end

c-------------------------------------------------------------
c FUNCTION  : false_position
c PURPOSE   : calculates and returns the root of the function
c           : f, after position x1, to a tolerance of tolx
c           : using the false position method. The parameter
c           : step determines the accuracy to which the function
c           : f can be calculated to.
c-------------------------------------------------------------

      double precision function false_position(n,gamma,step,
     > start,tolx)
      implicit none
      integer*4 step, n
      real*8 start, tolx, gamma
      real*8 f
      real*8 x1, x2, f1, f2, x3, f3, h

      h = 0.3d0

      x1 = start
      x2 = x1 + h
      f1 = f(x1,n,gamma,step)
      f2 = f(x2,n,gamma,step)

      do while (f1*f2 .ge. 0.0d0)
            x2 = x2 + h
            f2 = f(x2,n,gamma,step)
90          format(f15.8, f15.8)
      end do

      x3 = x2 - f2*(x2-x1)/(f2-f1)
      f3 = f(x3,n,gamma,step)

      do while (dabs(f3) .gt. tolx)
            if (f1*f3 .lt. 0.0d0) then
                  x2 = x3
            else
                  x1 = x3
            endif
            f1 = f(x1,n,gamma,step)
            f2 = f(x2,n,gamma,step)
            x3 = x2 - f2*(x2-x1)/(f2-f1)
            f3 = f(x3,n,gamma,step)
      end do

      false_position = x3
      return

      end


MODULE Solve_Real_Poly
! CACM Algorithm 493 by Jenkins & Traub

! Compliments of netlib   Sat Jul 26 11:57:43 EDT 1986

! Code converted using TO_F90 by Alan Miller
! Date: 2003-06-02  Time: 10:42:22

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

! COMMON /global/ p, qp, k, qk, svk, sr, si, u, v, a, b, c, d, a1,  &
!    a2, a3, a6, a7, e, f, g, h, szr, szi, lzr, lzi, eta, are, mre, n, nn

REAL (dp), ALLOCATABLE, SAVE  :: p(:), qp(:), k(:), qk(:), svk(:)
REAL (dp), SAVE               :: sr, si, u, v, a, b, c, d, a1, a2, a3, a6,  &
                                 a7, e, f, g, h, szr, szi, lzr, lzi
REAL, SAVE                    :: eta, are, mre
INTEGER, SAVE                 :: n, nn

PRIVATE
PUBLIC  :: dp, rpoly

CONTAINS

SUBROUTINE rpoly(op, degree, zeror, zeroi, fail)

! Finds the zeros of a real polynomial
! op  - double precision vector of coefficients in order of
!       decreasing powers.
! degree   - integer degree of polynomial.
! zeror, zeroi - output double precision vectors of real and imaginary parts
!                of the zeros.
! fail  - output logical parameter, true only if leading coefficient is zero
!         or if rpoly has found fewer than degree zeros.
!         In the latter case degree is reset to the number of zeros found.

! To change the size of polynomials which can be solved, reset the dimensions
! of the arrays in the common area and in the following declarations.
! The subroutine uses single precision calculations for scaling, bounds and
! error calculations.  All calculations for the iterations are done in
! double precision.

REAL (dp), INTENT(IN)    :: op(:)
INTEGER, INTENT(IN OUT)  :: degree
REAL (dp), INTENT(OUT)   :: zeror(:), zeroi(:)
LOGICAL, INTENT(OUT)     :: fail

REAL (dp), ALLOCATABLE   :: temp(:)
REAL, ALLOCATABLE        :: pt(:)

REAL (dp) :: t, aa, bb, cc, factor
REAL      :: lo, MAX, MIN, xx, yy, cosr, sinr, xxx, x, sc, bnd,  &
             xm, ff, df, dx, infin, smalno, base
INTEGER   :: cnt, nz, i, j, jj, l, nm1
LOGICAL   :: zerok

! The following statements set machine constants used in various parts of the
! program.  The meaning of the four constants are...
! eta     the maximum relative representation error which can be described
!         as the smallest positive floating point number such that
!         1.d0+eta is greater than 1.
! infiny  the largest floating-point number.
! smalno  the smallest positive floating-point number if the exponent range
!         differs in single and REAL (dp) then smalno and infin should
!         indicate the smaller range.
! base    the base of the floating-point number system used.

base = RADIX(0.0)
eta = EPSILON(1.0)
infin = HUGE(0.0)
smalno = TINY(0.0)

! are and mre refer to the unit error in + and * respectively.
! They are assumed to be the same as eta.
are = eta
mre = eta
lo = smalno / eta

! Initialization of constants for shift rotation
xx = SQRT(0.5)
yy = -xx
cosr = -.069756474
sinr = .99756405
fail = .false.
n = degree
nn = n + 1

! Algorithm fails if the leading coefficient is zero.
IF (op(1) == 0.d0) THEN
  fail = .true.
  degree = 0
  RETURN
END IF

! Remove the zeros at the origin if any
10 IF (op(nn) == 0.0D0) THEN
  j = degree - n + 1
  zeror(j) = 0.d0
  zeroi(j) = 0.d0
  nn = nn - 1
  n = n - 1
  GO TO 10
END IF

! Allocate various arrays

IF (ALLOCATED(p)) DEALLOCATE(p, qp, k, qk, svk)
ALLOCATE( p(nn), qp(nn), k(nn), qk(nn), svk(nn), temp(nn), pt(nn) )

! Make a copy of the coefficients
p(1:nn) = op(1:nn)

! Start the algorithm for one zero
30 IF (n <= 2) THEN
  IF (n < 1) RETURN

! calculate the final zero or pair of zeros
  IF (n /= 2) THEN
    zeror(degree) = -p(2) / p(1)
    zeroi(degree) = 0.0D0
    RETURN
  END IF
  CALL quad(p(1), p(2), p(3), zeror(degree-1), zeroi(degree-1),  &
            zeror(degree), zeroi(degree))
  RETURN
END IF

! Find largest and smallest moduli of coefficients.
MAX = 0.
MIN = infin
DO  i = 1, nn
  x = ABS( REAL(p(i)) )
  IF (x > MAX) MAX = x
  IF (x /= 0. .AND. x < MIN) MIN = x
END DO

! Scale if there are large or very small coefficients computes a scale
! factor to multiply the coefficients of the polynomial.
! The scaling is done to avoid overflow and to avoid undetected underflow
! interfering with the convergence criterion.
! The factor is a power of the base
sc = lo / MIN
IF (sc <= 1.0) THEN
  IF (MAX < 10.) GO TO 60
  IF (sc == 0.) sc = smalno
ELSE
  IF (infin/sc < MAX) GO TO 60
END IF
l = LOG(sc) / LOG(base) + .5
factor = (base*1.0D0) ** l
IF (factor /= 1.d0) THEN
  p(1:nn) = factor * p(1:nn)
END IF

! compute lower bound on moduli of zeros.
60 pt(1:nn) = ABS(p(1:nn))
pt(nn) = -pt(nn)

! compute upper estimate of bound
x = EXP((LOG(-pt(nn)) - LOG(pt(1))) / n)
IF (pt(n) /= 0.) THEN
! if newton step at the origin is better, use it.
  xm = -pt(nn) / pt(n)
  IF (xm < x) x = xm
END IF

! chop the interval (0,x) until ff .le. 0
80 xm = x * .1
ff = pt(1)
DO  i = 2, nn
  ff = ff * xm + pt(i)
END DO
IF (ff > 0.) THEN
  x = xm
  GO TO 80
END IF
dx = x

! do newton iteration until x converges to two decimal places
100 IF (ABS(dx/x) > .005) THEN
  ff = pt(1)
  df = ff
  DO  i = 2, n
    ff = ff * x + pt(i)
    df = df * x + ff
  END DO
  ff = ff * x + pt(nn)
  dx = ff / df
  x = x - dx
  GO TO 100
END IF
bnd = x

! compute the derivative as the intial k polynomial
! and do 5 steps with no shift
nm1 = n - 1
DO  i = 2, n
  k(i) = (nn-i) * p(i) / n
END DO
k(1) = p(1)
aa = p(nn)
bb = p(n)
zerok = k(n) == 0.d0
DO  jj = 1, 5
  cc = k(n)
  IF (.NOT.zerok) THEN
! use scaled form of recurrence if value of k at 0 is nonzero
    t = -aa / cc
    DO  i = 1, nm1
      j = nn - i
      k(j) = t * k(j-1) + p(j)
    END DO
    k(1) = p(1)
    zerok = ABS(k(n)) <= ABS(bb) * eta * 10.
  ELSE
! use unscaled form of recurrence
    DO  i = 1, nm1
      j = nn - i
      k(j) = k(j-1)
    END DO
    k(1) = 0.d0
    zerok = k(n) == 0.d0
  END IF
END DO

! save k for restarts with new shifts
temp(1:n) = k(1:n)

! loop to select the quadratic  corresponding to each
! new shift
DO  cnt = 1, 20
! Quadratic corresponds to a double shift to a non-real point and its complex
! conjugate.  The point has modulus bnd and amplitude rotated by 94 degrees
! from the previous shift
  xxx = cosr * xx - sinr * yy
  yy = sinr * xx + cosr * yy
  xx = xxx
  sr = bnd * xx
  si = bnd * yy
  u = -2.0D0 * sr
  v = bnd

! second stage calculation, fixed quadratic
  CALL fxshfr(20*cnt,nz)
  IF (nz /= 0) THEN

! The second stage jumps directly to one of the third stage iterations and
! returns here if successful.
! Deflate the polynomial, store the zero or zeros and return to the main
! algorithm.
    j = degree - n + 1
    zeror(j) = szr
    zeroi(j) = szi
    nn = nn - nz
    n = nn - 1
    p(1:nn) = qp(1:nn)
    IF (nz == 1) GO TO 30
    zeror(j+1) = lzr
    zeroi(j+1) = lzi
    GO TO 30
  END IF

! If the iteration is unsuccessful another quadratic
! is chosen after restoring k
  k(1:nn) = temp(1:nn)
END DO

! Return with failure if no convergence with 20 shifts
fail = .true.
degree = degree - n
RETURN
END SUBROUTINE rpoly

SUBROUTINE fxshfr(l2, nz)

! Computes up to  l2  fixed shift k-polynomials, testing for convergence in
! the linear or quadratic case.  Initiates one of the variable shift
! iterations and returns with the number of zeros found.
! l2 - limit of fixed shift steps
! nz - number of zeros found

INTEGER, INTENT(IN)   :: l2
INTEGER, INTENT(OUT)  :: nz

REAL (dp) :: svu, svv, ui, vi, s
REAL      :: betas, betav, oss, ovv, ss, vv, ts, tv, ots, otv, tvv, tss
INTEGER   :: TYPE, j, iflag
LOGICAL   :: vpass, spass, vtry, stry

nz = 0
betav = .25
betas = .25
oss = sr
ovv = v

! Evaluate polynomial by synthetic division
CALL quadsd(nn, u, v, p, qp, a, b)
CALL calcsc(TYPE)
DO  j = 1, l2
! calculate next k polynomial and estimate v
  CALL nextk(TYPE)
  CALL calcsc(TYPE)
  CALL newest(TYPE, ui, vi)
  vv = vi

! Estimate s
  ss = 0.
  IF (k(n) /= 0.d0) ss = -p(nn) / k(n)
  tv = 1.
  ts = 1.
  IF (j /= 1 .AND. TYPE /= 3) THEN
! Compute relative measures of convergence of s and v sequences
    IF (vv /= 0.) tv = ABS((vv-ovv)/vv)
    IF (ss /= 0.) ts = ABS((ss-oss)/ss)

! If decreasing, multiply two most recent convergence measures
    tvv = 1.
    IF (tv < otv) tvv = tv * otv
    tss = 1.
    IF (ts < ots) tss = ts * ots

! Compare with convergence criteria
    vpass = tvv < betav
    spass = tss < betas
    IF (spass .OR. vpass) THEN

! At least one sequence has passed the convergence test.
! Store variables before iterating
      svu = u
      svv = v
      svk(1:n) = k(1:n)
      s = ss

! Choose iteration according to the fastest converging sequence
      vtry = .false.
      stry = .false.
      IF (spass .AND. ((.NOT.vpass) .OR. tss < tvv)) GO TO 40
      20 CALL quadit(ui, vi, nz)
      IF (nz > 0) RETURN

! Quadratic iteration has failed. flag that it has
! been tried and decrease the convergence criterion.
      vtry = .true.
      betav = betav * .25

! Try linear iteration if it has not been tried and
! the s sequence is converging
      IF (stry.OR.(.NOT.spass)) GO TO 50
      k(1:n) = svk(1:n)
      40 CALL realit(s, nz, iflag)
      IF (nz > 0) RETURN

! Linear iteration has failed.  Flag that it has been
! tried and decrease the convergence criterion
      stry = .true.
      betas = betas * .25
      IF (iflag /= 0) THEN

! If linear iteration signals an almost double real
! zero attempt quadratic interation
        ui = -(s+s)
        vi = s * s
        GO TO 20
      END IF

! Restore variables
      50 u = svu
      v = svv
      k(1:n) = svk(1:n)

! Try quadratic iteration if it has not been tried
! and the v sequence is converging
      IF (vpass .AND. (.NOT.vtry)) GO TO 20

! Recompute qp and scalar values to continue the second stage
      CALL quadsd(nn, u, v, p, qp, a, b)
      CALL calcsc(TYPE)
    END IF
  END IF
  ovv = vv
  oss = ss
  otv = tv
  ots = ts
END DO
RETURN
END SUBROUTINE fxshfr

SUBROUTINE quadit(uu, vv, nz)

! Variable-shift k-polynomial iteration for a quadratic factor, converges
! only if the zeros are equimodular or nearly so.
! uu,vv - coefficients of starting quadratic
! nz - number of zero found

REAL (dp), INTENT(IN)  :: uu
REAL (dp), INTENT(IN)  :: vv
INTEGER, INTENT(OUT)   :: nz

REAL (dp) :: ui, vi
REAL      :: mp, omp, ee, relstp, t, zm
INTEGER   :: TYPE, i, j
LOGICAL   :: tried

nz = 0
tried = .false.
u = uu
v = vv
j = 0

! Main loop
10 CALL quad(1.d0, u, v, szr, szi, lzr, lzi)

! Return if roots of the quadratic are real and not
! close to multiple or nearly equal and  of opposite sign.
IF (ABS(ABS(szr)-ABS(lzr)) > .01D0*ABS(lzr)) RETURN

! Evaluate polynomial by quadratic synthetic division
CALL quadsd(nn, u, v, p, qp, a, b)
mp = ABS(a-szr*b) + ABS(szi*b)

! Compute a rigorous  bound on the rounding error in evaluting p
zm = SQRT(ABS( REAL(v)))
ee = 2. * ABS( REAL(qp(1)))
t = -szr * b
DO  i = 2, n
  ee = ee * zm + ABS( REAL(qp(i)) )
END DO
ee = ee * zm + ABS( REAL(a) + t)
ee = (5.*mre+4.*are) * ee - (5.*mre+2.*are) * (ABS( REAL(a)  + t) +  &
     ABS( REAL(b))*zm) + 2. * are * ABS(t)

! Iteration has converged sufficiently if the
! polynomial value is less than 20 times this bound
IF (mp <= 20.*ee) THEN
  nz = 2
  RETURN
END IF
j = j + 1

! Stop iteration after 20 steps
IF (j > 20) RETURN
IF (j >= 2) THEN
  IF (.NOT.(relstp > .01 .OR. mp < omp .OR. tried)) THEN

! A cluster appears to be stalling the convergence.
! five fixed shift steps are taken with a u,v close to the cluster
    IF (relstp < eta) relstp = eta
    relstp = SQRT(relstp)
    u = u - u * relstp
    v = v + v * relstp
    CALL quadsd(nn, u, v, p, qp, a, b)
    DO  i = 1, 5
      CALL calcsc(TYPE)
      CALL nextk(TYPE)
    END DO
    tried = .true.
    j = 0
  END IF
END IF
omp = mp

! Calculate next k polynomial and new u and v
CALL calcsc(TYPE)
CALL nextk(TYPE)
CALL calcsc(TYPE)
CALL newest(TYPE,ui,vi)

! If vi is zero the iteration is not converging
IF (vi == 0.d0) RETURN
relstp = ABS((vi-v)/vi)
u = ui
v = vi
GO TO 10
END SUBROUTINE quadit

SUBROUTINE realit(sss,nz,iflag)

! Variable-shift h polynomial iteration for a real
! zero.
! sss   - starting iterate
! nz    - number of zero found
! iflag - flag to indicate a pair of zeros near real axis.

REAL (dp), INTENT(IN OUT)  :: sss
INTEGER, INTENT(OUT)       :: nz, iflag

REAL (dp) :: pv, kv, t, s
REAL      :: ms, mp, omp, ee
INTEGER   :: i, j

nz = 0
s = sss
iflag = 0
j = 0

! Main loop
10 pv = p(1)

! Evaluate p at s
qp(1) = pv
DO  i = 2, nn
  pv = pv * s + p(i)
  qp(i) = pv
END DO
mp = ABS(pv)

! Compute a rigorous bound on the error in evaluating p
ms = ABS(s)
ee = (mre/(are+mre)) * ABS( REAL(qp(1)))
DO  i = 2, nn
  ee = ee * ms + ABS( REAL(qp(i)))
END DO

! Iteration has converged sufficiently if the
! polynomial value is less than 20 times this bound
IF (mp <= 20.*((are+mre)*ee - mre*mp)) THEN
  nz = 1
  szr = s
  szi = 0.d0
  RETURN
END IF
j = j + 1

! Stop iteration after 10 steps
IF (j > 10) RETURN
IF (j >= 2) THEN
  IF (ABS(t) <= .001*ABS(s-t) .AND. mp > omp) THEN
! A cluster of zeros near the real axis has been encountered,
! return with iflag set to initiate a quadratic iteration
    iflag = 1
    sss = s
    RETURN
  END IF
END IF

! Return if the polynomial value has increased significantly
omp = mp

! Compute t, the next polynomial, and the new iterate
kv = k(1)
qk(1) = kv
DO  i = 2, n
  kv = kv * s + k(i)
  qk(i) = kv
END DO
IF (ABS(kv) > ABS(k(n))*10.*eta) THEN
! Use the scaled form of the recurrence if the value of k at s is nonzero
  t = -pv / kv
  k(1) = qp(1)
  DO  i = 2, n
    k(i) = t * qk(i-1) + qp(i)
  END DO
ELSE
! Use unscaled form
  k(1) = 0.0D0
  DO  i = 2, n
    k(i) = qk(i-1)
  END DO
END IF
kv = k(1)
DO  i = 2, n
  kv = kv * s + k(i)
END DO
t = 0.d0
IF (ABS(kv) > ABS(k(n))*10.*eta) t = -pv / kv
s = s + t
GO TO 10
END SUBROUTINE realit

SUBROUTINE calcsc(TYPE)

! This routine calculates scalar quantities used to
! compute the next k polynomial and new estimates of
! the quadratic coefficients.
! type - integer variable set here indicating how the
! calculations are normalized to avoid overflow

INTEGER, INTENT(OUT)  :: TYPE

! Synthetic division of k by the quadratic 1,u,v
CALL quadsd(n, u, v, k, qk, c, d)
IF (ABS(c) <= ABS(k(n))*100.*eta) THEN
  IF (ABS(d) <= ABS(k(n-1))*100.*eta) THEN
    TYPE = 3
! type=3 indicates the quadratic is almost a factor of k
    RETURN
  END IF
END IF

IF (ABS(d) >= ABS(c)) THEN
  TYPE = 2
! type=2 indicates that all formulas are divided by d
  e = a / d
  f = c / d
  g = u * b
  h = v * b
  a3 = (a+g) * e + h * (b/d)
  a1 = b * f - a
  a7 = (f+u) * a + h
  RETURN
END IF
TYPE = 1
! type=1 indicates that all formulas are divided by c
e = a / c
f = d / c
g = u * e
h = v * b
a3 = a * e + (h/c+g) * b
a1 = b - a * (d/c)
a7 = a + g * d + h * f
RETURN
END SUBROUTINE calcsc

SUBROUTINE nextk(TYPE)

! Computes the next k polynomials using scalars computed in calcsc.

INTEGER, INTENT(IN)  :: TYPE

REAL (dp) :: temp
INTEGER   :: i

IF (TYPE /= 3) THEN
  temp = a
  IF (TYPE == 1) temp = b
  IF (ABS(a1) <= ABS(temp)*eta*10.) THEN
! If a1 is nearly zero then use a special form of the recurrence
    k(1) = 0.d0
    k(2) = -a7 * qp(1)
    DO  i = 3, n
      k(i) = a3 * qk(i-2) - a7 * qp(i-1)
    END DO
    RETURN
  END IF

! Use scaled form of the recurrence
  a7 = a7 / a1
  a3 = a3 / a1
  k(1) = qp(1)
  k(2) = qp(2) - a7 * qp(1)
  DO  i = 3, n
    k(i) = a3 * qk(i-2) - a7 * qp(i-1) + qp(i)
  END DO
  RETURN
END IF

! Use unscaled form of the recurrence if type is 3
k(1) = 0.d0
k(2) = 0.d0
DO  i = 3, n
  k(i) = qk(i-2)
END DO
RETURN
END SUBROUTINE nextk

SUBROUTINE newest(TYPE,uu,vv)

! Compute new estimates of the quadratic coefficients
! using the scalars computed in calcsc.

INTEGER, INTENT(IN)     :: TYPE
REAL (dp), INTENT(OUT)  :: uu
REAL (dp), INTENT(OUT)  :: vv

REAL (dp) :: a4, a5, b1, b2, c1, c2, c3, c4, temp

! Use formulas appropriate to setting of type.
IF (TYPE /= 3) THEN
  IF (TYPE /= 2) THEN
    a4 = a + u * b + h * f
    a5 = c + (u+v*f) * d
  ELSE
    a4 = (a+g) * f + h
    a5 = (f+u) * c + v * d
  END IF

! Evaluate new quadratic coefficients.
  b1 = -k(n) / p(nn)
  b2 = -(k(n-1)+b1*p(n)) / p(nn)
  c1 = v * b2 * a1
  c2 = b1 * a7
  c3 = b1 * b1 * a3
  c4 = c1 - c2 - c3
  temp = a5 + b1 * a4 - c4
  IF (temp /= 0.d0) THEN
    uu = u - (u*(c3+c2)+v*(b1*a1+b2*a7)) / temp
    vv = v * (1.+c4/temp)
    RETURN
  END IF
END IF

! If type=3 the quadratic is zeroed
uu = 0.d0
vv = 0.d0
RETURN
END SUBROUTINE newest

SUBROUTINE quadsd(nn, u, v, p, q, a, b)

! Divides p by the quadratic  1,u,v  placing the
! quotient in q and the remainder in a,b.

INTEGER, INTENT(IN)     :: nn
REAL (dp), INTENT(IN)   :: u, v, p(nn)
REAL (dp), INTENT(OUT)  :: q(nn), a, b

REAL (dp)  :: c
INTEGER    :: i

b = p(1)
q(1) = b
a = p(2) - u * b
q(2) = a
DO  i = 3, nn
  c = p(i) - u * a - v * b
  q(i) = c
  b = a
  a = c
END DO
RETURN
END SUBROUTINE quadsd

SUBROUTINE quad(a, b1, c, sr, si, lr, li)

! Calculate the zeros of the quadratic a*z**2+b1*z+c.
! The quadratic formula, modified to avoid overflow, is used to find the
! larger zero if the zeros are real and both zeros are complex.
! The smaller real zero is found directly from the product of the zeros c/a.

REAL (dp), INTENT(IN)             :: a, b1, c
REAL (dp), INTENT(OUT)            :: sr, si, lr, li

REAL (dp) :: b, d, e

IF (a /= 0.d0) GO TO 20
sr = 0.d0
IF (b1 /= 0.d0) sr = -c / b1
lr = 0.d0
10 si = 0.d0
li = 0.d0
RETURN

20 IF (c == 0.d0) THEN
  sr = 0.d0
  lr = -b1 / a
  GO TO 10
END IF

! Compute discriminant avoiding overflow
b = b1 / 2.d0
IF (ABS(b) >= ABS(c)) THEN
  e = 1.d0 - (a/b) * (c/b)
  d = SQRT(ABS(e)) * ABS(b)
ELSE
  e = a
  IF (c < 0.d0) e = -a
  e = b * (b/ABS(c)) - e
  d = SQRT(ABS(e)) * SQRT(ABS(c))
END IF
IF (e >= 0.d0) THEN

! Real zeros
  IF (b >= 0.d0) d = -d
  lr = (-b+d) / a
  sr = 0.d0
  IF (lr /= 0.d0) sr = (c/lr) / a
  GO TO 10
END IF
! complex conjugate zeros
sr = -b / a
lr = sr
si = ABS(d/a)
li = -si
RETURN
END SUBROUTINE quad

END MODULE Solve_Real_Poly

PROGRAM test_rpoly
USE Solve_Real_Poly
IMPLICIT NONE

REAL (dp)  :: p(50), zr(50), zi(50)
INTEGER    :: degree, i
LOGICAL    :: fail

WRITE(*, 5000)
degree = 10
p(1) = 1._dp
p(2) = -55._dp
p(3) = 1320._dp
p(4) = -18150._dp
p(5) = 157773._dp
p(6) = -902055._dp
p(7) = 3416930._dp
p(8) = -8409500._dp
p(9) = 12753576._dp
p(10) = -10628640._dp
p(11) = 3628800._dp

CALL rpoly(p, degree, zr, zi, fail)
IF (fail) THEN
  WRITE(*, *) ' ** Failure by RPOLY **'
ELSE
  WRITE(*, '(a/ (2g23.15))') ' Real part           Imaginary part',  &
                             (zr(i), zi(i), i=1,degree)
END IF

! This test provided by Larry Wigton

WRITE(*, *)
WRITE(*, *) "Now try case where 1 is an obvious root"
degree = 5
p(1) = 8.D0
p(2) = -8.D0
p(3) = 16.D0
p(4) = -16.D0
p(5) = 8.D0
p(6) = -8.D0

CALL rpoly(p, degree, zr, zi, fail)
IF (fail) THEN
  WRITE(*, *) ' ** Failure by RPOLY **'
ELSE
  WRITE(*, *) ' Real part           Imaginary part'
  WRITE(*, '(2g23.15)') (zr(i), zi(i), i=1,degree)
END IF

STOP

5000 FORMAT (' EXAMPLE 1. POLYNOMIAL WITH ZEROS 1,2,...,10.')

END PROGRAM test_rpoly


!==========================================================================
elemental function gsw_pt_from_pot_enthalpy_ice_poly (pot_enthalpy_ice)
!==========================================================================
!
!  Calculates the potential temperature of ice (whose reference sea
!  pressure is zero dbar) from the potential enthalpy of ice.  This is a
!  compuationally efficient polynomial fit to the potential enthalpy of
!  ice.
!
!  pot_enthalpy_ice  =  potential enthalpy of ice                  [ J/kg ]
!
!  pt0_ice  =  potential temperature of ice (ITS-90)              [ deg C ]
!--------------------------------------------------------------------------

use gsw_mod_kinds

implicit none

real (r8), intent(in) :: pot_enthalpy_ice

real (r8) :: gsw_pt_from_pot_enthalpy_ice_poly

real (r8), parameter :: q0 = 2.533588268773218e2_r8
real (r8), parameter :: q1 = 2.594351081876611e-3_r8
real (r8), parameter :: q2 = 1.765077810213815e-8_r8
real (r8), parameter :: q3 = 7.768070564290540e-14_r8
real (r8), parameter :: q4 = 2.034842254277530e-19_r8
real (r8), parameter :: q5 = 3.220014531712841e-25_r8
real (r8), parameter :: q6 = 2.845172809636068e-31_r8
real (r8), parameter :: q7 = 1.094005878892950e-37_r8

! The error of this fit ranges between -5e-5 and 2e-4 deg C over the potential
! temperature range of -100 to 2 deg C, or the potential enthalpy range of
! -5.7 x 10^5 to -3.3 x 10^5 J/kg.

gsw_pt_from_pot_enthalpy_ice_poly = q0 &
         + pot_enthalpy_ice*(q1 + pot_enthalpy_ice*(q2 + pot_enthalpy_ice*(q3 &
         + pot_enthalpy_ice*(q4 + pot_enthalpy_ice*(q5 + pot_enthalpy_ice*(q6 &
         + pot_enthalpy_ice*q7))))))

return
end function

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