      MODULE m_kernel1
C..............................................................kernel1
c solution of 2 coupled equations (logariphmic mesh) for (l,\mu:|mu|>=l)
c 1->k1
c d/dxP1=[-k1]P1+exp(x)[e-v+2mc^2]/c^2Q1+exp(x)B/c^2\sigma_z[-1,-1]Q1
c d/dxQ1=[k1]Q1-exp(x)[e-v]P1+exp(x)B[\sigma_z[1,1]P1]
c notations:
c Pi=exp(x)*gi
c Qi=exp(x)*cfi
c \gamma=sqrt(k^2-(Z/c)^2)
c v=0.5[V(1/2)+V(-1/2)]
c b=0.5[V(1/2)-V(-1/2)]
c Rydberg units: in charge
c hartree units: com.
c NSOL= 1 -  2 equations
c ------------                                     a. shick KFA 1996
      CONTAINS
      SUBROUTINE kernel1(mrad,xmj,kap1,xx1,e,v,b,ri,dx,nmatch,nstart,
     +                   dp,dq,wp,wq)

c
      USE m_constants, ONLY : c_light
      USE m_diff
      IMPLICIT NONE
C     ..
C     .. Scalar Arguments ..
      INTEGER, INTENT (IN) :: mrad
      REAL dx,e,xmj
      INTEGER kap1,nmatch,nstart
C     ..
C     .. Array Arguments ..
      REAL b(mrad),dp(2,2,mrad),dq(2,2,mrad),ri(mrad),v(mrad),
     +     wp(2,2,mrad),wq(2,2,mrad),xx1(4)
C     ..
C     .. Local Scalars ..
      REAL abz,bh,bmn,bmnp1,bn,bnp1,c1,c2,c3,cc,csq,dp11,dp12,
     +     dp13,dp14,dq11,dq12,dq13,dq14,dxd8,expdxh,gk,gmk,p1c,
     +     q1c,r,vh,vmn,vmnp1,vn,vnp1,xk,xm
      INTEGER i,ir,j,jri,n,nrk
C     ..
C     .. Local Arrays ..
      REAL bm(mrad),p1(mrad),p1s(mrad),q1(mrad),q1s(mrad),vm(mrad)
C     ..
C     .. Intrinsic Functions ..
      INTRINSIC exp,real
C     ..
C     .. Data statements ..
      DATA abz/0.5/
C     ..
      cc = c_light(2.0)
c
      DO ir = 1,mrad
         p1(ir) = 0.0
         q1(ir) = 0.0
         p1s(ir) = 0.0
         q1s(ir) = 0.0
c
         DO i = 1,2
            DO j = 1,2
c
               wp(i,j,ir) = 0.0
               wq(i,j,ir) = 0.0
c
               dp(i,j,ir) = 0.0
               dq(i,j,ir) = 0.0
            END DO
         END DO
      END DO
C
      csq = cc*cc
      expdxh = exp(dx/2.0)
      dxd8 = dx/8.0
      jri = nmatch
      nrk = jri
      CALL diff(
     >          mrad,v,dx,jri,
     <          vm)
      CALL diff(
     >          mrad,b,dx,jri,
     <          bm)
      xk = real(kap1)
      xm = xmj
      gk = -xm/ (xk+abz)
      gmk = xm/ (xk-abz)
c
      r = ri(nstart)
      vn = v(nstart)
      vmn = vm(nstart)
      bn = b(nstart)
      bmn = bm(nstart)
      p1(nstart) = xx1(1)
      q1(nstart) = xx1(2)
c---->f.po solution of Dirac eq.
      c1 = vn/r**2 - e
      c2 = 1.0 - c1/csq
c      C2=2.0-C1/CSQ !H
      c3 = bn/r/r
      p1s(nstart) = -xk*p1(nstart) + r* (c2+c3/csq*gmk)*q1(nstart)
      q1s(nstart) = xk*q1(nstart) + r* ((c1+c3*gk)*p1(nstart))
C   *     THE RUNGE-KUTTA METHOD IS USED IN THE <NKR> FIRST STEPS    *  WAB02520
      n = nstart
c-> y1
   10 p1c = p1(n)
      q1c = q1(n)
c-> k1=f(x1,y1)
      dp11 = dx* (-xk*p1c+r* (c2+c3/csq*gmk)*q1c)
      dq11 = dx* (xk*q1c+r* ((c1+c3*gk)*p1c))
c-> y11=y1+0.5*k1
      p1c = p1c + 0.5*dp11
      q1c = q1c + 0.5*dq11
c-> x1'=x1+0.5h
      r = r*expdxh
c-> interpolation of V and B for x1'
      vnp1 = v(n+1)
      vmnp1 = vm(n+1)
      bnp1 = b(n+1)
      bmnp1 = bm(n+1)
      vh = (vn+vnp1)*0.5 + (vmn-vmnp1)*dxd8
      bh = (bn+bnp1)*0.5 + (bmn-bmnp1)*dxd8
c-> k2=f(x1',y11)
      c1 = vh/r/r - e
      c2 = 1.0 - c1/csq
c      C2=2.0-C1/CSQ !H
      c3 = bh/r/r
C                                                                       WAB02850
      dp12 = dx* (-xk*p1c+r* (c2+c3/csq*gmk)*q1c)
      dq12 = dx* (xk*q1c+r* ((c1+c3*gk)*p1c))
c-> y12=y1+0.5*k2 (y12=y11-0.5*k1+0.5*k2)
      p1c = p1c + 0.5* (dp12-dp11)
      q1c = q1c + 0.5* (dq12-dq11)
c-> k3=f(x1',y12)
      dp13 = dx* (-xk*p1c+r* (c2+c3/csq*gmk)*q1c)
      dq13 = dx* (xk*q1c+r* ((c1+c3*gk)*p1c))
c-> y13=y1+k3 (y13=y12-0.5*k2+k3)
      p1c = p1c + dp13 - 0.5*dp12
      q1c = q1c - 0.5*dq12 + dq13
c-> x2=x1+h
      n = n + 1
      r = ri(n)
c-> k4=f(x2,y13)
      c1 = vnp1/r/r - e
      c2 = 1.0 - c1/csq
c      C2=2.0-C1/CSQ !H
      c3 = bnp1/r/r
c
      dp14 = dx* (-xk*p1c+r* (c2+c3/csq*gmk)*q1c)
      dq14 = dx* (xk*q1c+r* ((c1+c3*gk)*p1c))
c-> y2=y1+1/6*(k1+2*k2+2*k3+k4)
      p1(n) = p1(n-1) + (dp11+2.0* (dp12+dp13)+dp14)/6.0
      q1(n) = q1(n-1) + (dq11+2.0* (dq12+dq13)+dq14)/6.0
c-> f(x2,y2)
      p1s(n) = -xk*p1(n) + r* (c2+c3/csq*gmk)*q1(n)
      q1s(n) = xk*q1(n) + r* ((c1+c3*gk)*p1(n))
c-> redefinition of V ind B (2->1)
      vn = vnp1
      bn = bnp1
      vmn = vmnp1
      bmn = bmnp1
C                                                                       WAB03340
      IF (n-nrk.LT.0) GOTO 10
c---->Milne's method off now!
      DO ir = 1,mrad
         wp(1,1,ir) = p1(ir)
         wq(1,1,ir) = q1(ir)
c
         dp(1,1,ir) = p1s(ir)
         dq(1,1,ir) = q1s(ir)
      END DO

      END SUBROUTINE kernel1
      END MODULE m_kernel1


      SUBROUTINE SVBKSB(U, W, V, M, N, MP, NP, B, X)
      USE stel_kinds
      IMPLICIT NONE
C-----------------------------------------------
C   D u m m y   A r g u m e n t s
C-----------------------------------------------
      INTEGER M, N, MP, NP
      REAL(rprec), DIMENSION(MP,NP) :: U
      REAL(rprec), DIMENSION(NP) :: W
      REAL(rprec), DIMENSION(NP,NP) :: V
      REAL(rprec), DIMENSION(MP) :: B
      REAL(rprec), DIMENSION(NP) :: X
C-----------------------------------------------
C   L o c a l   P a r a m e t e r s
C-----------------------------------------------
      REAL(rprec) :: zero = 0
C-----------------------------------------------
C   L o c a l   V a r i a b l e s
C-----------------------------------------------
      INTEGER :: J
      REAL(rprec), DIMENSION(MP*NP) :: TMP
      REAL(rprec) :: S
C-----------------------------------------------
      IF (M .GT. MP) STOP 'M > MP IN SVBKSB'
      IF (N .GT. NP) STOP 'N > NP IN SVBKSB'

      DO J = 1, N
         S = zero
         IF (W(J) .ne. zero) THEN
            S = SUM(U(:M,J)*B(:M))
            S = S/W(J)
         ENDIF
         TMP(J) = S
      END DO
      DO J = 1, N
         S = SUM(V(J,:N)*TMP(:N))
         X(J) = S
      END DO

      END SUBROUTINE SVBKSB


program problem51
  use euler
  implicit none
  integer*8 :: p,hits,temp
  integer   :: bitmask,tempdigits
  integer*1 :: d
  logical   :: enable
  integer, parameter :: limit=8

  do p=2,huge(p)
     if (.not. is_prime(p)) cycle
     bitmask=1
     do while(workable(p,bitmask)) ! bitmask "<=" than prime
        hits=0
        enable=.false.
        do d=0,9
           temp=replace(p,d,bitmask)
           if (is_prime(temp) .and. workable(temp,bitmask)) then ! prime, "<=" bitmask
              if (p==temp) enable=.true.                         ! make sure prime is part of family
              hits=hits+1                                        ! bitmask "<=" than temp
           end if
           if (hits>=limit .and. enable) go to 100
        end do
        bitmask=bitmask+1
     end do
  end do

100 continue
  print *, p

contains

  pure function workable(number,bitmask)
    implicit none
    integer*8, intent(in) :: number
    integer, intent(in)   :: bitmask
    integer*8             :: temp1
    integer               :: temp2
    logical               :: workable

    temp1=number
    temp2=bitmask
    workable=.true.
    do while(temp1>0)
       temp1=temp1/10
       temp2=temp2/2
    end do

    if (temp2>0) then
       workable=.false.
    end if

  end function workable

  pure function replace(number,digit,bitmask)
    implicit none
    integer*8, intent(in) :: number
    integer*1, intent(in) :: digit
    integer, intent(in)   :: bitmask
    integer               :: temp1,i
    integer*8             :: temp2,replace

    temp1=bitmask
    temp2=number
    replace=number
    i=0
    do while (temp2>0)
       if (mod(temp1,2) == 1) then ! if bit asserted
          replace=replace-(mod(temp2,10)*(10**i))
          replace=replace+(digit*(10**i))
       end if
       temp1=temp1/2
       temp2=temp2/10
       i=i+1
    end do

  end function replace

end program problem51


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

       subroutine pinvr(c)

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

c---------------------------------------------------------------------
c   block-diagonal matrix-vector multiplication
c---------------------------------------------------------------------

       include 'header.h'

       integer i, j, k, c
       double precision r1, r2, r3, r4, r5, t1, t2

c---------------------------------------------------------------------
c      treat only one cell
c---------------------------------------------------------------------
       do   k = start(3,c), cell_size(3,c)-end(3,c)-1
          do   j = start(2,c), cell_size(2,c)-end(2,c)-1
             do   i = start(1,c), cell_size(1,c)-end(1,c)-1

                r1 = rhs(i,j,k,1,c)
                r2 = rhs(i,j,k,2,c)
                r3 = rhs(i,j,k,3,c)
                r4 = rhs(i,j,k,4,c)
                r5 = rhs(i,j,k,5,c)

                t1 = bt * r1
                t2 = 0.5d0 * ( r4 + r5 )

                rhs(i,j,k,1,c) =  bt * ( r4 - r5 )
                rhs(i,j,k,2,c) = -r3
                rhs(i,j,k,3,c) =  r2
                rhs(i,j,k,4,c) = -t1 + t2
                rhs(i,j,k,5,c) =  t1 + t2
             end do
          end do
       end do

       return
       end


CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C Add post-stretch to look-up table
C
      SUBROUTINE POST_STRETCH(lut,nchar2,prt2)
      IMPLICIT NONE
      INTEGER*2 LUT(-32768:32767)
      INTEGER*4 NCHAR2
      CHARACTER*80 PRT2

      COMMON/C3/INMIN,INMAX,DNMIN,DNMAX
      INTEGER*4 INMIN,INMAX,DNMIN,DNMAX

      REAL*4 A,B,RTRUNC
      INTEGER*4 IDN,LVAL,HVAL,IPARM(2),ICOUNT,IDEF
  810 FORMAT ('Post-stretch:',I7,' to',I7,' and',I7,' to',I7)

      CALL XVPARM('POST',iparm,icount,idef,2)
      IF (ICOUNT.LT.2) RETURN
      CALL XVMESSAGE(' ',' ')
      CALL XVMESSAGE('*** POST-STRETCH OPTION ***',' ')
      LVAL = IPARM(1)
      HVAL = IPARM(2)
      IF (LVAL.LT.DNMIN .OR. HVAL.LT.DNMIN) THEN
         CALL XVMESSAGE('Post-stretch parameter less than dnmin',' ')
         CALL XVMESSAGE('Parameter reset to dnmin',' ')
         IF (LVAL.LT.DNMIN) LVAL=DNMIN
         IF (HVAL.LT.DNMIN) HVAL=DNMIN
      ENDIF
      IF (LVAL.GT.DNMAX .OR. HVAL.GT.DNMAX) THEN
         CALL XVMESSAGE('Post-stretch parameter exceeds dnmax',' ')
         CALL XVMESSAGE('Parameter reset to dnmax',' ')
         IF (LVAL.GT.DNMAX) LVAL=DNMAX
         IF (HVAL.GT.DNMAX) HVAL=DNMAX
      ENDIF
      IF (LVAL.EQ.HVAL) THEN
         CALL XVMESSAGE('***Err - post values specified are equal',' ')
         CALL ABEND
      ENDIF

C     ....Compute composite lookup table
      A = FLOAT(HVAL-LVAL)/FLOAT(DNMAX-DNMIN)
      B = -A*DNMIN + LVAL
      DO IDN=INMIN,INMAX
         LUT(IDN) = RTRUNC(A*LUT(IDN) + B)
      ENDDO
      WRITE (PRT2,810) DNMIN,LVAL,DNMAX,HVAL
      NCHAR2 = 52
      CALL XVMESSAGE(PRT2,' ')
      RETURN
      END


CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C Check the grid size (INC) by computing the approximate transformation (a,b)
C using the four corner points (x,y).  The type of interpolation chosen
C is as follows:
C  INTERP=0  Zero out this quadrant
C  INTERP=1  Use exact formula for entire quadrant
C  INTERP=2  Use approximate formula for entire quadrant
C  INTERP=3  Use fixed offsed (DL,DS)
C
      SUBROUTINE CHECK_GRIDSIZE(INCLUDE,LBEG,SBEG,
     &		a,b,inc,address,interp)
      IMPLICIT NONE
      INTEGER*4 INCLUDE,LBEG,SBEG,INC,INTERP,ADDRESS
      REAL*4 A(4),B(4)

      INTEGER*4 IND,INDS(4),IERR,I,Xo,Yo,X(4),Y(4)
      REAL*8 U(4),V(4),Uo,Vo,Uop,Vop,ERR

      X(1) = SBEG
      Y(1) = LBEG

   20 X(2) = X(1) + INC - 1
      Y(2) = Y(1)
      X(3) = X(2)
      Y(3) = Y(2) + INC - 1
      X(4) = X(1)
      Y(4) = Y(3)
      IERR = 0

C     ....Project 4 corners using exact equations
      DO 10 I=1,4
      CALL PSUB(INCLUDE,Y(I),X(I),v(i),u(i),inds(i))
      IF (INDS(I).NE.1) THEN		!If point is off the target,
         IF (INC.GT.4) THEN		!reduce grid size if possible.
            INC = INC/2
            ADDRESS = 10*ADDRESS + 1
            GOTO 20
         ENDIF
         IERR = IERR + 1
      ENDIF
   10 CONTINUE

      IF (IERR.GT.0) GOTO 980

C     ....Compute approximate transformation (a,b) by fitting four corners
   25 CALL FINDT (X,Y,U,V,a,b,ind)

C     ....Calculate midpoint of square using exact and approx transform
      Xo = 0.5*(X(1) + X(2))
      Yo = 0.5*(Y(1) + Y(4))
      CALL PSUB(INCLUDE,Yo,Xo,vo,uo,ind)		!Exact

      Uop = A(1) + A(2)*Xo + A(3)*Yo + A(4)*Xo*Yo	!Approximate
      Vop = B(1) + B(2)*Xo + B(3)*Yo + B(4)*Xo*Yo

C     ....Difference between exact and approximate location of midpoint
      ERR = SQRT((Vo-Vop)**2 + (Uo-Uop)**2)
      IF (ERR.GT.0.5) GOTO 970
      INTERP = 2
      RETURN

C     ...Here if grid size is too large
  970 IF (INC.GT.4) THEN	!Reduce grid size if possible
         INC = INC/2
         ADDRESS = 10*ADDRESS + 1
         GOTO 20
      ELSE
         INTERP = 1		!Otherwise, use exact equations
      ENDIF
      RETURN
C
C     ....Here if INC=4 and some points are off the planet
  980 IF (IERR.LT.4) THEN		!If at least one point is on the planet
         INTERP = 1			!use exact equation for entire quadrant
      ELSE				!If completely off target body and
         INTERP = 0			!background not included, skip square
         IF (INCLUDE.EQ.1) INTERP=3	!Else, use fixed offset
      ENDIF
      RETURN
      END


!*************************************************************************
 SUBROUTINE near_sca_hard_near_scheme(rj, nip, ntrain) bind(C, name="acoustic_generate_near_sca")
  use, intrinsic :: iso_c_binding
  use global_com
  !use global_dim,only:rj
  use global_geom,only:nsupan,sunod
  use gaussintegraldata
  !implicit none
  integer::p,i,k,kkk,nnn,mmm
  integer::nodes_sn(nnpt)
  REAL(kind=dp)::vos1(2),vos2(2),vos3(2),vcsik(2),vcsis(2),jacobk
  REAL(kind=dp)::vus(3),vvs(3),vipps(3),vobp(3),vippsk(3)
  REAL(kind=dp)::dthe,dphi,phi_degree,the_degree
  REAL(kind=dp),dimension(3)::vekk,vethe,vephi
  integer::kph,kth
  !complex(kind=dp)::jdotp_the,jdotp_phi,esca_the1,esca_phi1
  !complex(kind=dp)::esca_the,esca_phi
  complex(kind=dp)::nearsca_hard,temp,temp_N1,temp_N2
  REAL(kind=dp)::ipolatork
  REAL(kind=dp)::vrrr(3),rrr, vrrrk(3),rrrk ,rpf(3)
  !integer::IPIV(nipp)
  REAL(kind=dp)::rNodes_src(3,nnpt),unitVec(3),unitVec0(3),nCapDotR,nCapDotRf

  REAL(kind=dp)::coeffs(nipp,nipp),rp0(3),zeta10,zeta20,up0,vp0,&
                jacobo0,jacobo
    complex(c_double_complex), dimension(ntrain*nip):: rj

  vos1=(/1.0_dp,0.0_dp/)  !right angle triangle vertex points in (u,v) space
  vos2=(/0.0_dp,1.0_dp/)  !the first number is u value, the second number is v value
  vos3=(/0.0_dp,0.0_dp/)

  CALL findPolyCoeffs(alphas,betas,gammas,nipp,coeffs)

  OPEN(unit=5702,file='near_sca_hard_near_scheme_OldBasis_1_120.out')

  IF (nthe_nf==1) THEN
     dthe=0.0_dp
  ELSE
     dthe=(the_end_degree_nf-the_sta_degree_nf)/REAL(nthe_nf-1,dp)
  ENDIF

  IF (nphi_nf==1) THEN
     dphi=0.0_dp
  ELSE
     dphi=(phi_end_degree_nf-phi_sta_degree_nf)/REAL(nphi_nf-1,dp)
  ENDIF

  DO kph=1,nphi_nf ! Loop over phi
     phi_degree=phi_sta_degree_nf+(kph-1)*dphi ! Compute phi
     vephi(1)=-sin(phi_degree*pid/180.0_dp)
     vephi(2)=cos(phi_degree*pid/180.0_dp)
     vephi(3)=0.0_dp

     DO kth=1,nthe_nf ! Loop over theta
        the_degree=the_sta_degree_nf+(kth-1)*dthe ! Compute theta
        ! Compute r,phi,and theta directed unit vectors.
        vekk(1)=sin(the_degree*pid/180.0_dp)*cos(phi_degree*pid/180.0_dp)
        vekk(2)=sin(the_degree*pid/180.0_dp)*sin(phi_degree*pid/180.0_dp)
        vekk(3)=cos(the_degree*pid/180.0_dp)
        vethe(1)=cos(the_degree*pid/180.0_dp)*cos(phi_degree*pid/180.0_dp)
        vethe(2)=cos(the_degree*pid/180.0_dp)*sin(phi_degree*pid/180.0_dp)
        vethe(3)=-sin(the_degree*pid/180.0_dp)

        vobp(1)=rnfobp*sin(the_degree*pid/180.0_dp)*cos(phi_degree*pid/180.0_dp)  !observation point position
        vobp(2)=rnfobp*sin(the_degree*pid/180.0_dp)*sin(phi_degree*pid/180.0_dp)
        vobp(3)=rnfobp*cos(the_degree*pid/180.0_dp)

        nearsca_hard=(0.0_dp,0.0_dp)

        DO p=1,ntriangle
           nodes_sn(:)=nsupan(:,p)
           rNodes_src(:,:) = sunod(:,nodes_sn)

           DO i=1,nipp

               DO k=1,nhdgqp_far
                  vcsik = alphas11(k)*vos1+betas11(k)*vos2+gammas11(k)*vos3
                  CALL mapGaussPtTo3Ddomain(vcsik(1),vcsik(2),nnpt,rNodes_src,vippsk)
                  CALL calcUnitNormal(vcsik(1),vcsik(2),nnpt,rNodes_src,unitVec)
                  CALL basis_function(vcsik,nipp,coeffs,i,ipolatork)
                  !CALL calcJacobian(vcsik(1),vcsik(2),nnpt,rNodes_src,jacobk)

                  vrrrk(:)=vobp(:)-vippsk(:)
                  rrrk=SQRT(DOT_PRODUCT(vrrrk,vrrrk))        !|r-rp|
                  nCapDotR = DOT_PRODUCT(unitVec,vrrrk)

                  nearsca_hard = nearsca_hard + ws11(k)*0.5_dp/(4.0_dp*pid)*nCapDotR*(exp(cjvk*rrrk)/&
                                   (rrrk**3))*(1.0_dp-cjvk*rrrk)*rj((p-1)*nipp+i)*ipolatork !*jacobk

               ENDDO

           ENDDO

        ENDDO

        WRITE(5702,*) the_degree, phi_degree, REAL(nearsca_hard), AIMAG(nearsca_hard), ABS(nearsca_hard)

     ENDDO
  ENDDO

  CLOSE(5702)

  PRINT*,"Calculations for hard near scattered field near scheme are done!"

  RETURN
END SUBROUTINE near_sca_hard_near_scheme
!*************************************************************************


	subroutine sub_ref(outunit,signal,number,srate,ref_volt,equiv_db,
     $				dcoffset,ierr)

c routine to calculate the reference voltage and equivalent pressure level
c (in dB) from a pure tone signal
c                                              June 26 1990
	real signal(1)
	integer outunit

	ierr = 0

c let's NOT assume we have integer numbers of cycles
c let's average 5 points to try to find the zero crossing
c (simpler than drawing a line?)
c	do istart=1,number-4
c	   do i=1,5

c I'm assuming we have steady state, so we can start at the beginning
c except I don't trust the first sample, so I'll junk that one
	rn = float(number-1)
c Then again, let's assume we know the frequency and the step rate accurately
c (accurately enough for dBA, etc)
	print *,' What frequency is this tone?'
	read *,cal_freq
c how many samples per cycle?
	samppcycl = srate / cal_freq
	isamppcycl = int(samppcycl)
c how many complete cycles in our signal?
	ncycles = int(rn/samppcycl)
c and that's how many samples?
	nsamp = nint(ncycles*samppcycl)

c initialize the D.C. component
	dc = 0.0
c initialize the RMS component
	tempms = 0.0
c initialize the maximum and minimum values (I'm going to find a max. and
c a min. for each "cycle" {as close as I can judge it with a discrete series}
c and average them across the complete NCYCLES)
	sigmax = 0.0
	sigmin = 0.0
	icycle = 1
c I'm junking the first sample, remember
	nextcycl = (int(icycle*samppcycl)) + 1
c assume positive and negative numbers (so start cycle max. and min. at zero)
	cycmax = 0.
	cycmin = 0.
	do inow = 2,nsamp+1
	   tempms = tempms + signal(inow)**2
	   dc = dc + signal(inow)
	   cycmax = amax1(cycmax,signal(inow))
	   cycmin = amin1(cycmin,signal(inow))
	   if (inow .ge. nextcycl) then
	      sigmax = sigmax + cycmax
	      sigmin = sigmin + cycmin
	      icycle = icycle+1
	      nextcycl = (int(icycle*samppcycl)) + 1
	      cycmax = 0.
	      cycmin = 0.
	   endif
	enddo

	sigmax = sigmax/ncycles
	sigmin = sigmin/ncycles
	rms = sqrt(tempms/nsamp)
	dcoffset = dc/nsamp

	print *,' What rms dB level is this tone?'
	read *,dblevel

	ref_volt = rms
	equiv_db = dblevel

	write (outunit,*) ' cal. factors',sigmax,sigmin,rms,dcoffset

	return

	end


module multiDOFsystemClass
    use fem
    use SeismicAnalysisClass
    implicit none

    type :: multiDOFsystem_
        type(FEMDomain_),pointer :: femdomain
        type(LinearSolver_) :: solver
        real(real64),allocatable :: m(:)
        real(real64),allocatable :: c(:)
        real(real64),allocatable :: k(:)
        real(real64),allocatable :: f(:)
        real(real64),allocatable :: u(:)
        real(real64),allocatable :: v(:)
        real(real64),allocatable :: a(:)
        real(real64) :: Newmark_beta = 0.25d0
        real(real64) :: Newmark_gamma= 0.50d0
        integer(int32) :: itr=0
    contains
        procedure :: init => initmultiDOFsystem
        procedure :: solve => solvemultiDOFsystem
    end type
contains

! #####################################################################
subroutine initmultiDOFsystem(obj,femdomain)
    class(multiDOFsystem_),intent(inout) :: obj
    type(FEMDomain_),target :: femdomain
    if(associated(obj%femdomain) ) then
        nullify(obj%femdomain)
    endif

    ! check type.
    ! dimension should be 1
    if(femdomain%mesh%empty() )then
        call print("ERROR :: importDomainmultiDOFsystem >> mesh is empty!")
        stop
    endif

    if(femdomain%nd() /=1 )then
        call print("ERROR :: importDomainmultiDOFsystem >> dimension should be 1")
        stop
    endif

    obj%femdomain => femdomain

    obj%m = zeros(femdomain%nn() )
    obj%c = zeros(femdomain%nn() )
    obj%k = zeros(femdomain%nn() )
    obj%f = zeros(femdomain%nn() )
    obj%u = zeros(femdomain%nn() )
    obj%v = zeros(femdomain%nn() )
    obj%a = zeros(femdomain%nn() )
    obj%Newmark_beta = 0.25d0
    obj%Newmark_gamma = 0.500d0

end subroutine
! #####################################################################

! #####################################################################
subroutine solvemultiDOFsystem(obj,dt,FixNodeId,displacement,Solver,powerSpectre)
    class(multiDOFsystem_),intent(inout) :: obj
    type(SeismicAnalysis_) :: seismic
    real(real64),intent(in) :: dt
    real(real64),intent(in) :: displacement
    integer(int32),intent(in) :: FixNodeId
    character(*),intent(in) :: Solver
    logical,optional,intent(in) :: powerSpectre ! compute powerSpectreResponceFunction under no-dumping.

    real(real64),allocatable :: Amat(:,:),bvec(:),u_upd(:),v_upd(:),a_upd(:),G_j(:),omega(:),power(:)
    real(real64),allocatable :: Mmat(:,:)
    real(real64),allocatable :: Cmat(:,:)
    real(real64),allocatable :: Kmat(:,:)

    integer(int32) :: i,j,n
    n = obj%femdomain%nn()

    ! solve 1-step
    Mmat = zeros(n,n)
    Cmat = zeros(n,n)
    Kmat = zeros(n,n)

    ! (1) create matrices and vectors
    i = 1
    Mmat(i,i  ) = obj%m(i)

    Kmat(i,i  ) = obj%k(i) + obj%k(i+1)
    Kmat(i,i+1) = - obj%k(i+1)

    Cmat(i,i  ) = obj%c(i) + obj%c(i+1)
    Cmat(i,i+1) = - obj%c(i+1)

    do i=2,n-1
        Mmat(i,i  ) = obj%m(i)

        Kmat(i,i-1) = - obj%k(i)
        Kmat(i,i  ) = obj%k(i) + obj%k(i+1)
        Kmat(i,i+1) = - obj%k(i+1)

        Cmat(i,i-1) = - obj%c(i)
        Cmat(i,i  ) = obj%c(i) + obj%c(i+1)
        Cmat(i,i+1) = - obj%c(i+1)
    enddo
    i = n
    Mmat(i,i  ) = obj%m(i)

    Kmat(i,i-1) = - obj%k(i)
    Kmat(i,i  ) = obj%k(i)

    Cmat(i,i-1) = - obj%c(i)
    Cmat(i,i  ) = obj%c(i)

    !
    if(present(powerSpectre) )then
        if(powerSpectre)then
            ! compute power-spectre Response function
            ! (K_ij - w^2 M_ij)^{-1} G_j = I_j
            omega = linspace([0.0d0,100.0d0],1000)
            power = zeros(size(omega))
            do i=1,size(omega)
                obj%solver%A = Kmat(:,:) - omega(i)*omega(i)*Mmat(:,:)
                obj%solver%b = G_j
                obj%solver%b = 1.0d0
                call obj%solver%solve("GaussJordan")
                power(i) = dble(abs(dot_product( obj%solver%x,obj%solver%x )))
            enddo
            print *, "Need Debug solvemultiDOFsystem"
            stop
        endif
    endif

    ! (2) set matrices and vectors

    obj%solver%A = seismic%getNewmarkBetaMatrix(&
        M=Mmat, &
        C=Cmat, &
        K=Kmat, &
        beta=obj%newmark_beta,&
        gamma=obj%newmark_gamma,&
        dt=dt)

    obj%solver%b = seismic%getNewmarkBetaVector(M=Mmat,&
        C=Cmat,       &
        u_n=obj%u,    &
        v_n=obj%v,    &
        a_n=obj%a,    &
        force=obj%f,  &
        beta=obj%newmark_beta,&
        gamma=obj%newmark_gamma,&
        dt=dt)
    obj%solver%x = zeros(n)

    call obj%solver%fix(nodeid=FixNodeId,entryvalue=displacement)

    !call print(obj%solver%a)

    call obj%solver%solve(Solver)

    u_upd = obj%solver%x

    v_upd = seismic%updateVelocityNewmarkBeta(u=u_upd,u_n=obj%u,v_n=obj%v,a_n=obj%a,&
        gamma=obj%newmark_gamma,beta=obj%newmark_beta,dt=dt)
    a_upd = seismic%updateAccelNewmarkBeta(u=u_upd,u_n=obj%u,v_n=obj%v,a_n=obj%a,&
        gamma=obj%newmark_gamma,beta=obj%newmark_beta,dt=dt)

        !if(obj%itr==10)then
        !    stop
        !endif

!    if(obj%itr==3470)then
!        print *, "u"
!        print *, u_upd
!        print *, "v"
!        print *, v_upd
!        print *, "a"
!        print *, a_upd
!        stop
!    endif

    obj%u = u_upd
    obj%v = v_upd
    obj%a = a_upd

end subroutine
! #####################################################################

end module


      SUBROUTINE LINCOA (N,NPT,M,A,IA,B,X,RHOBEG,RHOEND,IPRINT,
     1  MAXFUN,W)
      IMPLICIT REAL*8 (A-H,O-Z)
      DIMENSION A(IA,*),B(*),X(*),W(*)
C
C     This subroutine seeks the least value of a function of many variables,
C       subject to general linear inequality constraints, by a trust region
C       method that forms quadratic models by interpolation. Usually there
C       is much freedom in each new model after satisfying the interpolation
C       conditions, which is taken up by minimizing the Frobenius norm of
C       the change to the second derivative matrix of the model. One new
C       function value is calculated on each iteration, usually at a point
C       where the current model predicts a reduction in the least value so
C       far of the objective function subject to the linear constraints.
C       Alternatively, a new vector of variables may be chosen to replace
C       an interpolation point that may be too far away for reliability, and
C       then the new point does not have to satisfy the linear constraints.
C       The arguments of the subroutine are as follows.
C
C     N must be set to the number of variables and must be at least two.
C     NPT must be set to the number of interpolation conditions, which is
C       required to be in the interval [N+2,(N+1)(N+2)/2]. Typical choices
C       of the author are NPT=N+6 and NPT=2*N+1. Larger values tend to be
C       highly inefficent when the number of variables is substantial, due
C       to the amount of work and extra difficulty of adjusting more points.
C     M must be set to the number of linear inequality constraints.
C     A is a matrix whose columns are the constraint gradients, which are
C       required to be nonzero.
C     IA is the first dimension of the array A, which must be at least N.
C     B is the vector of right hand sides of the constraints, the J-th
C       constraint being that the scalar product of A(.,J) with X(.) is at
C       most B(J). The initial vector X(.) is made feasible by increasing
C       the value of B(J) if necessary.
C     X is the vector of variables. Initial values of X(1),X(2),...,X(N)
C       must be supplied. If they do not satisfy the constraints, then B
C       is increased as mentioned above. X contains on return the variables
C       that have given the least calculated F subject to the constraints.
C     RHOBEG and RHOEND must be set to the initial and final values of a
C       trust region radius, so both must be positive with RHOEND<=RHOBEG.
C       Typically, RHOBEG should be about one tenth of the greatest expected
C       change to a variable, and RHOEND should indicate the accuracy that
C       is required in the final values of the variables.
C     The value of IPRINT should be set to 0, 1, 2 or 3, which controls the
C       amount of printing. Specifically, there is no output if IPRINT=0 and
C       there is output only at the return if IPRINT=1. Otherwise, the best
C       feasible vector of variables so far and the corresponding value of
C       the objective function are printed whenever RHO is reduced, where
C       RHO is the current lower bound on the trust region radius. Further,
C       each new value of F with its variables are output if IPRINT=3.
C     MAXFUN must be set to an upper bound on the number of calls of CALFUN,
C       its value being at least NPT+1.
C     W is an array used for working space. Its length must be at least
C       M*(2+N) + NPT*(4+N+NPT) + N*(9+3*N) + MAX [ M+3*N, 2*M+N, 2*NPT ].
C       On return, W(1) is set to the final value of F, and W(2) is set to
C       the total number of function evaluations plus 0.5.
C
C     SUBROUTINE CALFUN (N,X,F) has to be provided by the user. It must set
C       F to the value of the objective function for the variables X(1),
C       X(2),...,X(N). The value of the argument F is positive when CALFUN
C       is called if and only if the current X satisfies the constraints
C       to working accuracy.
C
C     Check that N, NPT and MAXFUN are acceptable.
C
      ZERO=0.0D0
      SMALLX=1.0D-6*RHOEND
      NP=N+1
      NPTM=NPT-NP
      IF (N .LE. 1) THEN
          PRINT 10
   10     FORMAT (/4X,'Return from LINCOA because N is less than 2.')
          GOTO 80
      END IF
      IF (NPT .LT. N+2 .OR. NPT .GT. ((N+2)*NP)/2) THEN
          PRINT 20
   20     FORMAT (/4X,'Return from LINCOA because NPT is not in',
     1      ' the required interval.')
          GOTO 80
      END IF
      IF (MAXFUN .LE. NPT) THEN
          PRINT 30
   30     FORMAT (/4X,'Return from LINCOA because MAXFUN is less',
     1      ' than NPT+1.')
          GOTO 80
      END IF
C
C     Normalize the constraints, and copy the resultant constraint matrix
C       and right hand sides into working space, after increasing the right
C       hand sides if necessary so that the starting point is feasible.
C
      IAMAT=MAX0(M+3*N,2*M+N,2*NPT)+1
      IB=IAMAT+M*N
      IFLAG=0
      IF (M .GT. 0) THEN
          IW=IAMAT-1
          DO 60 J=1,M
          SUM=ZERO
          TEMP=ZERO
          DO 40 I=1,N
          SUM=SUM+A(I,J)*X(I)
   40     TEMP=TEMP+A(I,J)**2
          IF (TEMP .EQ. ZERO) THEN
              PRINT 50
   50         FORMAT (/4X,'Return from LINCOA because the gradient of',
     1          ' a constraint is zero.')
              GOTO 80
          END IF
          TEMP=DSQRT(TEMP)
          IF (SUM-B(J) .GT. SMALLX*TEMP) IFLAG=1
          W(IB+J-1)=DMAX1(B(J),SUM)/TEMP
          DO 60 I=1,N
          IW=IW+1
   60     W(IW)=A(I,J)/TEMP
      END IF
      IF (IFLAG .EQ. 1) THEN
          IF (IPRINT .GT. 0) PRINT 70
   70     FORMAT (/4X,'LINCOA has made the initial X feasible by',
     1      ' increasing part(s) of B.')
      END IF
C
C     Partition the working space array, so that different parts of it can be
C     treated separately by the subroutine that performs the main calculation.
C
      NDIM=NPT+N
      IXB=IB+M
      IXP=IXB+N
      IFV=IXP+N*NPT
      IXS=IFV+NPT
      IXO=IXS+N
      IGO=IXO+N
      IHQ=IGO+N
      IPQ=IHQ+(N*NP)/2
      IBMAT=IPQ+NPT
      IZMAT=IBMAT+NDIM*N
      ISTP=IZMAT+NPT*NPTM
      ISP=ISTP+N
      IXN=ISP+NPT+NPT
      IAC=IXN+N
      IRC=IAC+N
      IQF=IRC+M
      IRF=IQF+N*N
      IPQW=IRF+(N*NP)/2
C
C     The above settings provide a partition of W for subroutine LINCOB.
C
      CALL LINCOB (N,NPT,M,W(IAMAT),W(IB),X,RHOBEG,RHOEND,IPRINT,
     1  MAXFUN,W(IXB),W(IXP),W(IFV),W(IXS),W(IXO),W(IGO),W(IHQ),
     2  W(IPQ),W(IBMAT),W(IZMAT),NDIM,W(ISTP),W(ISP),W(IXN),W(IAC),
     3  W(IRC),W(IQF),W(IRF),W(IPQW),W)
   80 RETURN
      END


      SUBROUTINE DSPEVX(JOBZ, RANGE, UPLO, N, AP, VL, VU, IL, IU, ABSTOL, M, W&
         , Z, LDZ, WORK, IWORK, IFAIL, INFO)
!-----------------------------------------------
!   M o d u l e s
!-----------------------------------------------
      USE vast_kind_param, ONLY:  DOUBLE
!...Translated by Pacific-Sierra Research 77to90  4.3E  21:52:17  11/14/01
!...Switches:
!-----------------------------------------------
!   I n t e r f a c e   B l o c k s
!-----------------------------------------------
      USE lsame_I
      USE dlamch_I
      USE dlansp_I
      USE dcopy_I
      USE dopgtr_I
      USE dopmtr_I
      USE dscal_I
      USE dsptrd_I
      USE dstebz_I
      USE dstein_I
      USE dsteqr_I
      USE dsterf_I
      USE dswap_I
      USE xerbla_I
      IMPLICIT NONE
!-----------------------------------------------
!   D u m m y   A r g u m e n t s
!-----------------------------------------------
      INTEGER  :: N
      INTEGER  :: IL
      INTEGER  :: IU
      INTEGER  :: M
      INTEGER  :: LDZ
      INTEGER  :: INFO
      REAL(DOUBLE) , INTENT(IN) :: VL
      REAL(DOUBLE) , INTENT(IN) :: VU
      REAL(DOUBLE) , INTENT(IN) :: ABSTOL
      CHARACTER  :: JOBZ
      CHARACTER  :: RANGE
      CHARACTER  :: UPLO
      INTEGER  :: IWORK(*)
      INTEGER  :: IFAIL(*)
      REAL(DOUBLE)  :: AP(*)
      REAL(DOUBLE)  :: W(*)
      REAL(DOUBLE)  :: Z(LDZ,*)
      REAL(DOUBLE)  :: WORK(*)
!-----------------------------------------------
!   L o c a l   P a r a m e t e r s
!-----------------------------------------------
      REAL(DOUBLE), PARAMETER :: ZERO = 0.0D0
      REAL(DOUBLE), PARAMETER :: ONE = 1.0D0
!-----------------------------------------------
!   L o c a l   V a r i a b l e s
!-----------------------------------------------
      INTEGER :: I, IINFO, IMAX, INDD, INDE, INDEE, INDIBL, INDISP, INDIWO, &
         INDTAU, INDWRK, ISCALE, ITMP1, J, JJ, NSPLIT
      REAL(DOUBLE) :: ABSTLL, ANRM, BIGNUM, EPS, RMAX, RMIN, SAFMIN, SIGMA, &
         SMLNUM, TMP1, VLL, VUU
      LOGICAL :: ALLEIG, INDEIG, VALEIG, WANTZ
      CHARACTER :: ORDER
!-----------------------------------------------
!   I n t r i n s i c  F u n c t i o n s
!-----------------------------------------------
      INTRINSIC MIN, SQRT
!-----------------------------------------------
!
!  -- LAPACK driver routine (version 2.0) --
!     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
!     Courant Institute, Argonne National Lab, and Rice University
!     September 30, 1994
!
!     .. Scalar Arguments ..
!     ..
!     .. Array Arguments ..
!     ..
!
!  Purpose
!  =======
!
!  DSPEVX computes selected eigenvalues and, optionally, eigenvectors
!  of a real symmetric matrix A in packed storage.  Eigenvalues/vectors
!  can be selected by specifying either a range of values or a range of
!  indices for the desired eigenvalues.
!
!  Arguments
!  =========
!
!  JOBZ    (input) CHARACTER*1
!          = 'N':  Compute eigenvalues only;
!          = 'V':  Compute eigenvalues and eigenvectors.
!
!  RANGE   (input) CHARACTER*1
!          = 'A': all eigenvalues will be found;
!          = 'V': all eigenvalues in the half-open interval (VL,VU]
!                 will be found;
!          = 'I': the IL-th through IU-th eigenvalues will be found.
!
!  UPLO    (input) CHARACTER*1
!          = 'U':  Upper triangle of A is stored;
!          = 'L':  Lower triangle of A is stored.
!
!  N       (input) INTEGER
!          The order of the matrix A.  N >= 0.
!
!  AP      (input/output) DOUBLE PRECISION array, dimension (N*(N+1)/2)
!          On entry, the upper or lower triangle of the symmetric matrix
!          A, packed columnwise in a linear array.  The j-th column of A
!          is stored in the array AP as follows:
!          if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j;
!          if UPLO = 'L', AP(i + (j-1)*(2*n-j)/2) = A(i,j) for j<=i<=n.
!
!          On exit, AP is overwritten by values generated during the
!          reduction to tridiagonal form.  If UPLO = 'U', the diagonal
!          and first superdiagonal of the tridiagonal matrix T overwrite
!          the corresponding elements of A, and if UPLO = 'L', the
!          diagonal and first subdiagonal of T overwrite the
!          corresponding elements of A.
!
!  VL      (input) DOUBLE PRECISION
!  VU      (input) DOUBLE PRECISION
!          If RANGE='V', the lower and upper bounds of the interval to
!          be searched for eigenvalues. VL < VU.
!          Not referenced if RANGE = 'A' or 'I'.
!
!  IL      (input) INTEGER
!  IU      (input) INTEGER
!          If RANGE='I', the indices (in ascending order) of the
!          smallest and largest eigenvalues to be returned.
!          1 <= IL <= IU <= N, if N > 0; IL = 1 and IU = 0 if N = 0.
!          Not referenced if RANGE = 'A' or 'V'.
!
!  ABSTOL  (input) DOUBLE PRECISION
!          The absolute error tolerance for the eigenvalues.
!          An approximate eigenvalue is accepted as converged
!          when it is determined to lie in an interval [a,b]
!          of width less than or equal to
!
!                  ABSTOL + EPS *   max( |a|,|b| ) ,
!
!          where EPS is the machine precision.  If ABSTOL is less than
!          or equal to zero, then  EPS*|T|  will be used in its place,
!          where |T| is the 1-norm of the tridiagonal matrix obtained
!          by reducing AP to tridiagonal form.
!
!          Eigenvalues will be computed most accurately when ABSTOL is
!          set to twice the underflow threshold 2*DLAMCH('S'), not zero.
!          If this routine returns with INFO>0, indicating that some
!          eigenvectors did not converge, try setting ABSTOL to
!          2*DLAMCH('S').
!
!          See "Computing Small Singular Values of Bidiagonal Matrices
!          with Guaranteed High Relative Accuracy," by Demmel and
!          Kahan, LAPACK Working Note #3.
!
!  M       (output) INTEGER
!          The total number of eigenvalues found.  0 <= M <= N.
!          If RANGE = 'A', M = N, and if RANGE = 'I', M = IU-IL+1.
!
!  W       (output) DOUBLE PRECISION array, dimension (N)
!          If INFO = 0, the selected eigenvalues in ascending order.
!
!  Z       (output) DOUBLE PRECISION array, dimension (LDZ, max(1,M))
!          If JOBZ = 'V', then if INFO = 0, the first M columns of Z
!          contain the orthonormal eigenvectors of the matrix A
!          corresponding to the selected eigenvalues, with the i-th
!          column of Z holding the eigenvector associated with W(i).
!          If an eigenvector fails to converge, then that column of Z
!          contains the latest approximation to the eigenvector, and the
!          index of the eigenvector is returned in IFAIL.
!          If JOBZ = 'N', then Z is not referenced.
!          Note: the user must ensure that at least max(1,M) columns are
!          supplied in the array Z; if RANGE = 'V', the exact value of M
!          is not known in advance and an upper bound must be used.
!
!  LDZ     (input) INTEGER
!          The leading dimension of the array Z.  LDZ >= 1, and if
!          JOBZ = 'V', LDZ >= max(1,N).
!
!  WORK    (workspace) DOUBLE PRECISION array, dimension (8*N)
!
!  IWORK   (workspace) INTEGER array, dimension (5*N)
!
!  IFAIL   (output) INTEGER array, dimension (N)
!          If JOBZ = 'V', then if INFO = 0, the first M elements of
!          IFAIL are zero.  If INFO > 0, then IFAIL contains the
!          indices of the eigenvectors that failed to converge.
!          If JOBZ = 'N', then IFAIL is not referenced.
!
!  INFO    (output) INTEGER
!          = 0:  successful exit
!          < 0:  if INFO = -i, the i-th argument had an illegal value
!          > 0:  if INFO = i, then i eigenvectors failed to converge.
!                Their indices are stored in array IFAIL.
!
!  =====================================================================
!
!     .. Parameters ..
!     ..
!     .. Local Scalars ..
!     ..
!     .. External Functions ..
!     ..
!     .. External Subroutines ..
!     ..
!     .. Intrinsic Functions ..
!     ..
!     .. Executable Statements ..
!
!     Test the input parameters.
!
      WANTZ = LSAME(JOBZ,'V')
      ALLEIG = LSAME(RANGE,'A')
      VALEIG = LSAME(RANGE,'V')
      INDEIG = LSAME(RANGE,'I')
!
      INFO = 0
      IF (.NOT.(WANTZ .OR. LSAME(JOBZ,'N'))) THEN
         INFO = -1
      ELSE IF (.NOT.(ALLEIG .OR. VALEIG .OR. INDEIG)) THEN
         INFO = -2
      ELSE IF (.NOT.(LSAME(UPLO,'L') .OR. LSAME(UPLO,'U'))) THEN
         INFO = -3
      ELSE IF (N < 0) THEN
         INFO = -4
      ELSE IF (VALEIG .AND. N>0 .AND. VU<=VL) THEN
         INFO = -7
      ELSE IF (INDEIG .AND. IL<1) THEN
         INFO = -8
      ELSE IF (INDEIG .AND. (IU<MIN(N,IL) .OR. IU>N)) THEN
         INFO = -9
      ELSE IF (LDZ<1 .OR. WANTZ .AND. LDZ<N) THEN
         INFO = -14
      ENDIF
!
      IF (INFO /= 0) THEN
         CALL XERBLA ('DSPEVX', (-INFO))
         RETURN
      ENDIF
!
!     Quick return if possible
!
      M = 0
      IF (N == 0) RETURN
!
      IF (N == 1) THEN
         IF (ALLEIG .OR. INDEIG) THEN
            M = 1
            W(1) = AP(1)
         ELSE
            IF (VL<AP(1) .AND. VU>=AP(1)) THEN
               M = 1
               W(1) = AP(1)
            ENDIF
         ENDIF
         IF (WANTZ) Z(1,1) = ONE
         RETURN
      ENDIF
!
!     Get machine constants.
!
      SAFMIN = DLAMCH('Safe minimum')
      EPS = DLAMCH('Precision')
      SMLNUM = SAFMIN/EPS
      BIGNUM = ONE/SMLNUM
      RMIN = SQRT(SMLNUM)
      RMAX = MIN(SQRT(BIGNUM),ONE/SQRT(SQRT(SAFMIN)))
!
!     Scale matrix to allowable range, if necessary.
!
      ISCALE = 0
      ABSTLL = ABSTOL
      IF (VALEIG) THEN
         VLL = VL
         VUU = VU
      ENDIF
      ANRM = DLANSP('M',UPLO,N,AP,WORK)
      IF (ANRM>ZERO .AND. ANRM<RMIN) THEN
         ISCALE = 1
         SIGMA = RMIN/ANRM
      ELSE IF (ANRM > RMAX) THEN
         ISCALE = 1
         SIGMA = RMAX/ANRM
      ENDIF
      IF (ISCALE == 1) THEN
         CALL DSCAL ((N*(N + 1))/2, SIGMA, AP, 1)
         IF (ABSTOL > 0) ABSTLL = ABSTOL*SIGMA
         IF (VALEIG) THEN
            VLL = VL*SIGMA
            VUU = VU*SIGMA
         ENDIF
      ENDIF
!
!     Call DSPTRD to reduce symmetric packed matrix to tridiagonal form.
!
      INDTAU = 1
      INDE = INDTAU + N
      INDD = INDE + N
      INDWRK = INDD + N
      CALL DSPTRD (UPLO, N, AP, WORK(INDD), WORK(INDE), WORK(INDTAU), IINFO)
!
!     If all eigenvalues are desired and ABSTOL is less than or equal
!     to zero, then call DSTERF or DOPGTR and SSTEQR.  If this fails
!     for some eigenvalue, then try DSTEBZ.
!
      IF ((ALLEIG .OR. INDEIG .AND. IL==1 .AND. IU==N) .AND. ABSTOL<=ZERO) THEN
         CALL DCOPY (N, WORK(INDD), 1, W, 1)
         INDEE = INDWRK + 2*N
         IF (.NOT.WANTZ) THEN
            CALL DCOPY (N - 1, WORK(INDE), 1, WORK(INDEE), 1)
            CALL DSTERF (N, W, WORK(INDEE), INFO)
         ELSE
            CALL DOPGTR (UPLO, N, AP, WORK(INDTAU), Z, LDZ, WORK(INDWRK), IINFO&
               )
            CALL DCOPY (N - 1, WORK(INDE), 1, WORK(INDEE), 1)
            CALL DSTEQR (JOBZ, N, W, WORK(INDEE), Z, LDZ, WORK(INDWRK), INFO)
            IF (INFO == 0) THEN
               IFAIL(:N) = 0
            ENDIF
         ENDIF
         IF (INFO == 0) THEN
            M = N
            GO TO 20
         ENDIF
         INFO = 0
      ENDIF
!
!     Otherwise, call DSTEBZ and, if eigenvectors are desired, SSTEIN.
!
      IF (WANTZ) THEN
         ORDER = 'B'
      ELSE
         ORDER = 'E'
      ENDIF
      INDIBL = 1
      INDISP = INDIBL + N
      INDIWO = INDISP + N
      CALL DSTEBZ (RANGE, ORDER, N, VLL, VUU, IL, IU, ABSTLL, WORK(INDD), WORK(&
         INDE), M, NSPLIT, W, IWORK(INDIBL), IWORK(INDISP), WORK(INDWRK), IWORK&
         (INDIWO), INFO)
!
      IF (WANTZ) THEN
         CALL DSTEIN (N, WORK(INDD), WORK(INDE), M, W, IWORK(INDIBL), IWORK(&
            INDISP), Z, LDZ, WORK(INDWRK), IWORK(INDIWO), IFAIL, INFO)
!
!        Apply orthogonal matrix used in reduction to tridiagonal
!        form to eigenvectors returned by DSTEIN.
!
         CALL DOPMTR ('L', UPLO, 'N', N, M, AP, WORK(INDTAU), Z, LDZ, WORK(&
            INDWRK), INFO)
      ENDIF
!
!     If matrix was scaled, then rescale eigenvalues appropriately.
!
   20 CONTINUE
      IF (ISCALE == 1) THEN
         IF (INFO == 0) THEN
            IMAX = M
         ELSE
            IMAX = INFO - 1
         ENDIF
         CALL DSCAL (IMAX, ONE/SIGMA, W, 1)
      ENDIF
!
!     If eigenvalues are not in order, then sort them, along with
!     eigenvectors.
!
      IF (WANTZ) THEN
         DO J = 1, M - 1
            I = 0
            TMP1 = W(J)
            DO JJ = J + 1, M
               IF (W(JJ) >= TMP1) CYCLE
               I = JJ
               TMP1 = W(JJ)
            END DO
!
            IF (I == 0) CYCLE
            ITMP1 = IWORK(INDIBL+I-1)
            W(I) = W(J)
            IWORK(INDIBL+I-1) = IWORK(INDIBL+J-1)
            W(J) = TMP1
            IWORK(INDIBL+J-1) = ITMP1
            CALL DSWAP (N, Z(1,I), 1, Z(1,J), 1)
            IF (INFO == 0) CYCLE
            ITMP1 = IFAIL(I)
            IFAIL(I) = IFAIL(J)
            IFAIL(J) = ITMP1
         END DO
      ENDIF
!
      RETURN
!
!     End of DSPEVX
!
      END SUBROUTINE DSPEVX


      subroutine colloc(aleft,aright,lbegin,iorder,ntimes,addbrk,relerr)
c  from  * a practical guide to splines *  by c. de boor
chapter xv, example. solution of an ode by collocation.
calls colpnt, difequ(ppvalu(interv)), knots, eqblok(putit(difequ*,
c     bsplvd(bsplvb)))), slvblk(various subprograms), bsplpp(bsplvb*),
c     newnot
c
c******  i n p u t  ******
c  aleft, aright  endpoints of interval of approximation
c  lbegin   initial number of polynomial pieces in the approximation.
c           a uniform breakpoint sequence is chosen.
c  iorder   order of polynomial pieces in the approximation
c  ntimes   number of passes through  n e w n o t  to be made
c  addbrk   the number (possibly fractional) of breaks to be added per
c           pass through newnot. e.g., if addbrk = .33334, then a break-
c           point will be added at every third pass through newnot.
c  relerr   a tolerance. newton iteration is stopped if the difference
c           between the b-coeffs of two successive iterates is no more
c           than  relerr*(absol.largest b-coefficient).
c
c******  p r i n t e d   o u t p u t  ******
c     consists of the pp-representation of the approximate solution,
c     and of the error at selected points.
c
c******  m e t h o d  ******
c  the m-th order ordinary differential equation with  m  side condit-
c  ions, to be specified in subroutine  d i f e q u , is solved approx-
c  imately by collocation.
c  the approximation  f  to the solution  g  is pp of order  k+m  with
c  l  pieces and  m-1 continuous derivatives.  f  is determined by the
c  requirement that it satisfy the d.e. at  k  points per interval (to
c  be specified in  c o l p n t ) and the  m  side conditions.
c     this usually nonlinear system of equations for  f  is solved by
c  newton's method. the resulting linear system for the b-coeffs of an
c  iterate is constructed appropriately in  e q b l o k  and then solved
c  in  s l v b l k , a program designed to solve  a l m o s t  b l o c k
c  d i a g o n a l  linear systems efficiently.
c     there is an opportunity to attempt improvement of the breakpoint
c  sequence (both in number and location) through use of  n e w n o t .
c
      integer npiece
      parameter (npiece=100)
      integer iorder,lbegin,ntimes,   i,iflag,ii,integs(3,npiece),iside
     *                  ,iter,itermx,k,kmax,kpm,l,lenblk,lnew,m,n,nbloks
     *                  ,ndim,ncoef,nncoef,npiece,nt
      parameter (ndim=200,kmax=20,ncoef=npiece*kmax,lenblk=ncoef)
C     integer iorder,lbegin,ntimes,   i,iflag,ii,integs(3,100),iside
C    *            ,iter,itermx,k,kpm,l,lnew,m,n,nbloks,ncoef,nncoef,nt
C     data ncoef,lenblk / 2000,2000 /
      real addbrk,aleft,aright,relerr,   a(ndim),amax,asave(ndim)
     *     ,b(ndim),bloks(lenblk),break,coef,dx,err,rho,t(ndim)
     *     ,templ(lenblk),temps(ndim),xside
C     real addbrk,aleft,aright,relerr,   a(200),amax,asave(200)
C    *     ,b(200),bloks(2000),break,coef,dx,err,rho,t(200)
C    *     ,templ(2000),temps(200),xside
      equivalence (bloks,templ)
      common /approx/ break(npiece), coef(ncoef), l,kpm
C     common /approx/ break(100), coef(2000), l,kpm
      common /side/ m, iside, xside(10)
      common /other/ itermx,k,rho(kmax-1)
c
      kpm = iorder
      if (lbegin*kpm .gt. ncoef)        go to 999
c  *** set the various parameters concerning the particular dif.equ.
c     including a first approx. in case the de is to be solved by
c     iteration ( itermx .gt. 0) .
      call difequ (1, temps(1), temps )
c  *** obtain the  k  collocation points for the standard interval.
      k = kpm - m
      call colpnt ( k, rho )
c  *** the following five statements could be replaced by a read in or-
c     der to obtain a specific (nonuniform) spacing of the breakpnts.
      dx = (aright - aleft)/float(lbegin)
      temps(1) = aleft
      do 4 i=2,lbegin
    4    temps(i) = temps(i-1) + dx
      temps(lbegin+1) = aright
c  *** generate, in knots, the required knots t(1),...,t(n+kpm).
      call knots ( temps, lbegin, kpm, t, n )
      nt = 1
c  *** generate the almost block diagonal coefficient matrix  bloks  and
c     right side  b  from collocation equations and side conditions.
c     then solve via  slvblk , obtaining the b-representation of the ap-
c     proximation in  t , a ,  n  , kpm  .
   10    call eqblok(t,n,kpm,temps,a,bloks,lenblk,integs,nbloks,b)
         call slvblk(bloks,integs,nbloks,b,temps,a,iflag)
         iter = 1
         if (itermx .le. 1)             go to 30
c  *** save b-spline coeff. of current approx. in  asave , then get new
c     approx. and compare with old. if coeff. are more than  relerr
c     apart (relatively) or if no. of iterations is less than  itermx ,
c     continue iterating.
   20       call bsplpp(t,a,n,kpm,templ,break,coef,l)
            do 25 i=1,n
   25          asave(i) = a(i)
            call eqblok(t,n,kpm,temps,a,bloks,lenblk,integs,nbloks,b)
            call slvblk(bloks,integs,nbloks,b,temps,a,iflag)
            err = 0.
            amax = 0.
            do 26 i=1,n
               amax = amax1(amax,abs(a(i)))
   26          err = amax1(err,abs(a(i)-asave(i)))
            if (err .le. relerr*amax)   go to 30
            iter = iter+1
            if (iter .lt. itermx)       go to 20
c  *** iteration (if any) completed. print out approx. based on current
c     breakpoint sequence, then try to improve the sequence.
   30    print 630,kpm,l,n,(break(i),i=2,l)
  630    format(47h approximation from a space of splines of order,i3
     *         ,4h on ,i3,11h intervals,/13h of dimension,i4
     *         ,16h.  breakpoints -/(5e20.10))
         if (itermx .gt. 0)  print 635,iter,itermx
  635    format(6h after,i3,3h of,i3,20h allowed iterations,)
         call bsplpp(t,a,n,kpm,templ,break,coef,l)
         print 637
  637    format(46h the pp representation of the approximation is)
         do 38 i=1,l
            ii = (i-1)*kpm
   38       print 638, break(i),(coef(ii+j),j=1,kpm)
  638    format(f9.3,e13.6,10e11.3)
c  *** the following call is provided here for possible further analysis
c     of the approximation specific to the problem being solved.
c     it is, of course, easily omitted.
         call difequ ( 4, temps(1), temps )
c
         if (nt .gt. ntimes)            return
c  *** from the pp-rep. of the current approx., obtain in  newnot  a new
c     (and possibly better) sequence of breakpoints, adding (on the ave-
c     rage)  a d d b r k  breakpoints per pass through newnot.
         lnew = lbegin + ifix(float(nt)*addbrk)
         if (lnew*kpm .gt. ncoef)       go to 999
         call newnot(break,coef,l,kpm,temps,lnew,templ)
         call knots(temps,lnew,kpm,t,n)
         nt = nt + 1
                                        go to 10
  999 nncoef = ncoef
      print 699,nncoef
  699 format(11h **********/23h the assigned dimension,i5
     *      ,25h for  coef  is too small.)
                                        return
      end


      subroutine lesq (x,y,ro,m,b,n)
C...subroutine     lesq      01/09/73
C...subroutine     lesq      01/09/78
      dimension x(1),y(1),ro(1),a(36),b(6),v(11)
      ma=iabs(m)
      na=iabs(n)
      l=2*na-1
      if (n)  9,17,1
   1  do 2 k=1,l
   2  v(k)=0.
      do 6 j=1,ma
      rx=1.
      if (m.gt.0) rx=ro(j)
      do 6 k=1,l
      if (k.gt.1) rx=rx*x(j)
   6  v(k)=v(k)+rx
      j=1
      do 8 i=1,na
      l=i-j
      jk=j+na-1
      do 7 k=j,jk
   7  a(k)=v(k+l)
   8  j=j+na
      call sminv (a,v,na)
   9  continue
      do 10 k=1,na
  10  v(k)=0.
      do 14 j=1,ma
      rx=1.
      if(m.gt.0) rx=ro(j)
      do 14 k=1,na
      if (k.gt.1) rx=rx*x(j)
  14  v(k)=v(k)+y(j)*rx
      do 15 k=1,na
  15  b(k)=0.
      do 16 i=1,na
      do 16 j=1,na
  16  b(i)=b(i)+a(i+(j-1)*na)*v(j)
  17  return
      end


      SUBROUTINE rkck(y,dydx,n,x,h,yout,yerr,derivs)
      INTEGER n,NMAX
      REAL h,x,dydx(n),y(n),yerr(n),yout(n)
      EXTERNAL derivs
      PARAMETER (NMAX=50)
CU    USES derivs
      INTEGER i
      REAL ak2(NMAX),ak3(NMAX),ak4(NMAX),ak5(NMAX),ak6(NMAX),
     *ytemp(NMAX),A2,A3,A4,A5,A6,B21,B31,B32,B41,B42,B43,B51,B52,B53,
     *B54,B61,B62,B63,B64,B65,C1,C3,C4,C6,DC1,DC3,DC4,DC5,DC6
      PARAMETER (A2=.2,A3=.3,A4=.6,A5=1.,A6=.875,B21=.2,B31=3./40.,
     *B32=9./40.,B41=.3,B42=-.9,B43=1.2,B51=-11./54.,B52=2.5,
     *B53=-70./27.,B54=35./27.,B61=1631./55296.,B62=175./512.,
     *B63=575./13824.,B64=44275./110592.,B65=253./4096.,C1=37./378.,
     *C3=250./621.,C4=125./594.,C6=512./1771.,DC1=C1-2825./27648.,
     *DC3=C3-18575./48384.,DC4=C4-13525./55296.,DC5=-277./14336.,
     *DC6=C6-.25)
      do 11 i=1,n
        ytemp(i)=y(i)+B21*h*dydx(i)
11    continue
      call derivs(x+A2*h,ytemp,ak2)
      do 12 i=1,n
        ytemp(i)=y(i)+h*(B31*dydx(i)+B32*ak2(i))
12    continue
      call derivs(x+A3*h,ytemp,ak3)
      do 13 i=1,n
        ytemp(i)=y(i)+h*(B41*dydx(i)+B42*ak2(i)+B43*ak3(i))
13    continue
      call derivs(x+A4*h,ytemp,ak4)
      do 14 i=1,n
        ytemp(i)=y(i)+h*(B51*dydx(i)+B52*ak2(i)+B53*ak3(i)+B54*ak4(i))
14    continue
      call derivs(x+A5*h,ytemp,ak5)
      do 15 i=1,n
        ytemp(i)=y(i)+h*(B61*dydx(i)+B62*ak2(i)+B63*ak3(i)+B64*ak4(i)+
     *B65*ak5(i))
15    continue
      call derivs(x+A6*h,ytemp,ak6)
      do 16 i=1,n
        yout(i)=y(i)+h*(C1*dydx(i)+C3*ak3(i)+C4*ak4(i)+C6*ak6(i))
16    continue
      do 17 i=1,n
        yerr(i)=h*(DC1*dydx(i)+DC3*ak3(i)+DC4*ak4(i)+DC5*ak5(i)+DC6*
     *ak6(i))
17    continue
      return
      END


      double complex function vv(st,j1,j2,j3,j4,j5,j6)
************************************************************************
*     Author: R.K. Ellis                                               *
*     July, 1998.                                                      *
************************************************************************
      include 'constants.f'
      include 'sprods_com.f'
      include 'scale.f'
      include 'epinv.f'
      integer j1,j2,j3,j4,j5,j6
      double complex Lnrat,xl12,xl34,xl23,xl56
      character*2 st

      xl12=Lnrat(musq,-s(j1,j2))
      xl34=Lnrat(musq,-s(j3,j4))

      if ((st .eq. 'pp') .or. (st .eq. 'pm')) then

c   Vpm =Vpp=
c     - 2*epinv^2   + epinv* ( 2/3 - xlog12 - xlog34 )
c     + 10/9 - 1/2*xlog12^2 - 1/2*xlog34^2 + 13/6*xlog23 - 3/2*xlog56
c   Vsl =
c    -2*epinv^2 + epinv* ( - 3 - xlog12 - xlog34 )
c    -15/2 - 3/2*xlog12 - 1/2*xlog12^2 - 3/2*xlog34 - 1/2*xlog34^2

      xl23=Lnrat(musq,-s(j2,j3))
      xl56=Lnrat(musq,-s(j5,j6))
      vv =-epinv*(two*epinv-two/three+xl12+xl34)
     . +10d0/9d0-0.5d0*(xl12**2+xl34**2)+13d0/6d0*xl23-1.5d0*xl56

      elseif (st .eq. 'sl') then
      vv=
     & -epinv*(two*epinv+three+xl12+xl34)
     & -7.5d0-1.5d0*(xl12+xl34)-0.5d0*(xl12**2+xl34**2)

      endif

      end


    !-------------------------------------------------------------------------------------------------------------
    !
    !> \file    CompExcessGibbsEnergyQKTO.f90
    !> \brief   Compute the partial molar excess Gibbs energy of mixing of solution phase constituents in a QKTO
    !!           solution phase.
    !> \author  M.H.A. Piro
    !> \sa      CompExcessGibbsEnergy.f90
    !> \sa      CompExcessGibbsEnergyRKMP.f90
    !> \sa      CompExcessGibbsEnergySUBL.f90
    !> \date    June 13, 2012
    !
    !
    ! Revisions:
    ! ==========
    !
    !   Date            Programmer          Description of change
    !   ----            ----------          ---------------------
    !   06/13/2012      M.H.A. Piro         Original code.
    !
    !
    ! Purpose:
    ! ========
    !
    !> \details The purpose of this subroutine is to compute the partial molar excess Gibbs energy of mixing
    !! (dPartialExcessGibbs) of all constituents in a non-ideal solution phase designated as 'QKTO'
    !! (Quasi-chemical Kohlter-TOop).  The PolyRegular subroutine computes the excess Gibbs energy of mixing of
    !! a regular solution sub-system (see PolyRegular for a definition) and the KohlerInterpolate subroutine
    !! performs a Kohler interpolation of a sub-system to a phase.
    !!
    !! The molar excess Gibbs energy of mixing of a binary sub-system for a QKTO model is:
    !!
    !! \f$ g_{\lambda,z}^{ex} = L_z x_1^a x_2^b \f$
    !!
    !! where \f$ L_z \f$ is the mixing parameter, \f$ x_1 \f$ and \f$ x_2 \f$ are the mole fractions for
    !! constituents 1 and 2 in the binary term and \f$ a \f$ and \f$ b \f$ are the exponents for constituents
    !! 1 and 2, respectively.
    !!
    !! The molar excess Gibbs energy of mixing for solution phase \f$ \lambda \f$ using Kohler's interpolation
    !! scheme gives
    !!
    !! \f$ g_{\lambda}^{ex} = (x_1 + x_2)^2 g_{\lambda,z}^{ex} \f$
    !!
    !! Similarly, the molar excess Gibbs energy of mixing of a ternary sub-system for a QKTO model is:
    !!
    !! \f$ g_{\lambda,z}^{ex} = L_z x_1^a x_2^b x_3^c \f$
    !!
    !! which is related to the molar excess Gibbs energy of mixing of the phase via Kohler's interpolation:
    !!
    !! \f$ g_{\lambda}^{ex} = (x_1 + x_2 + x_3)^2 g_{\lambda,z}^{ex} \f$
    !!
    !
    ! Pertinent variables:
    ! ====================
    !
    !> \param[in] iSolnIndex    Absolute index of a solution phase
    !
    ! nSpeciesPhase             Highest index number of a species in a particular solution phase
    ! nParam                    Number of parameters
    ! iParam                    Index number of a parameter.
    ! dChemicalPotential        The estimated chemical potential vector.  To be precise, this is defined as the
    !                           molar Gibbs energy of the pure species minus the proper chemical potential
    !                           defined by the element potentials.
    ! dPartialExcessGibbs       Partial molar excess Gibbs energy of mixing of species.
    ! dPartialExcessGibbsLast   Partial molar excess Gibbs energy of mixing of species from the last iteration.
    ! dMolFraction              Current estimated mole fraction.
    !
    !-------------------------------------------------------------------------------------------------------------

subroutine CompExcessGibbsEnergyQKTO(iSolnIndex)

    USE ModuleThermo
    USE ModuleGEMSolver

    implicit none

    integer                       :: iParam, iSolnIndex

    ! Return control to the parent subroutine if there aren't any interaction parameters for this phase:
    if ((nParamPhase(iSolnIndex) - nParamPhase(iSolnIndex-1) == 0).OR. &
        (cSolnPhaseType(iSolnIndex) /= 'QKTO')) return

    ! Loop through all interaction parameters in this phase:
    do iParam = nParamPhase(iSolnIndex-1)+1, nParamPhase(iSolnIndex)
        ! Compute the partial molar excess Gibbs energy of each sub-system in a regular solution phase:
        ! Now also performs interpolation
        call PolyRegularQKTO(iSolnIndex,iParam)
    end do

    return

end subroutine CompExcessGibbsEnergyQKTO

    !-------------------------------------------------------------------------------------------------------------
    !
    ! Purpose
    ! =======
    !
    !> \details The purpose of this subroutine is to compute the partial molar excess Gibbs energy of
    !! mixing of species in a regular sub-system.  Note that the effective quantity (i.e., "y") is represented
    !! relative to the particular parameter of interest and differs from that of the phase as a whole.
    !!
    !! For more information on the derivation of the thermodynamic equations used in this subroutine,
    !! refer to the following paper:
    !!
    !!        A.D. Pelton and C.W. Bale, "Computational Techniques for the Treatment
    !!        of Thermodynamic Data in Multicomponent Systems and the Calculation of
    !!        Phase Equilibria," CALPHAD, V. 1, N. 3 (1977) 253-273.
    !!
    !
    ! Pertinent Variables
    ! ===================
    !
    !> \param[in]  iSolnIndex       Integer scalar of the solution index.
    !> \param[in]  iParam           Integer scalar of the parameter index.
    !> \param[out] xT               Sum of mole fractions of actual constituents in solution phase
    !> \param[out] dGParam          Excess Gibbs energy of sub-system
    !> \param[out] dPartialGParam   Partial excess Gibbs energy of a constituent in the sub-system
    !
    ! y                             A double real vector representing the equivalent mole fractions of each
    !                                constituent in the sub-system (parameter).
    ! zT                            A double real scalar representing the sum of exponents in the sub-system.
    !
    !-------------------------------------------------------------------------------------------------------------

subroutine PolyRegularQKTO(iSolnIndex,iParam)

    USE ModuleThermo
    USE ModuleGEMSolver
    USE ModuleThermoIO

    implicit None

    integer                       :: i, j, zT, iParam, iSolnIndex, iGroup1, iGroup2, iGroupTemp, nSpeciesParam, p, q, r, a, b, c
    real(8)                       :: xT, dGex, dXi1, dXi2, dXiDen, dDgex
    real(8), dimension(nSpeciesPhase(iSolnIndex) - nSpeciesPhase(iSolnIndex-1)) :: y, dPartialGParam
    logical, dimension(nSpeciesPhase(iSolnIndex) - nSpeciesPhase(iSolnIndex-1)) :: lAsymmetric1, lAsymmetric2

    ! Initialize variables:
    xT             = 0D0
    y              = 0D0
    zT             = 0
    dPartialGParam = 0D0
    dXi1           = 0D0
    dXi2           = 0D0
    lAsymmetric1   = .FALSE.
    lAsymmetric2   = .FALSE.
    nSpeciesParam  = iRegularParam(iParam,1)
    a = iRegularParam(iParam,2)
    b = iRegularParam(iParam,3)
    p = iRegularParam(iParam,nSpeciesParam+2)
    q = iRegularParam(iParam,nSpeciesParam+3)
    ! Set ternary parameters initially to 0, so that they may be used for any case
    c = 0
    r = 0
    if (nSpeciesParam == 3) then
        c = iRegularParam(iParam,4)
        r = iRegularParam(iParam,nSpeciesParam+4)
    end if

    ! Get chemical groups of first two species
    iGroup1 = INT(dQKTOParams(nSpeciesPhase(iSolnIndex-1) + a,2))
    iGroup2 = INT(dQKTOParams(nSpeciesPhase(iSolnIndex-1) + b,2))

    ! Calculate symmetry of all species with these first two
    ! Count them as asymmetric with respect to themselves
    lAsymmetric1(a) = .TRUE.
    lAsymmetric2(b) = .TRUE.
    ! If they are equal, everything else will be symmetric
    if (iGroup1 /= iGroup2) then
        do j = nSpeciesPhase(iSolnIndex-1) + 1, nSpeciesPhase(iSolnIndex)
            i = j - nSpeciesPhase(iSolnIndex-1)
            iGroupTemp = INT(dQKTOParams(j,2))
            if      (iGroupTemp == iGroup1) then
                lAsymmetric1(i) = .TRUE.
            else if (iGroupTemp == iGroup2) then
                lAsymmetric2(i) = .TRUE.
            end if
        end do
    end if

    ! Compute sum of equivalent fractions
    do j = nSpeciesPhase(iSolnIndex-1) + 1, nSpeciesPhase(iSolnIndex)
        i = j - nSpeciesPhase(iSolnIndex-1)
        xT = xT + dMolFraction(j) * dQKTOParams(j,1)
    end do
    if (xT <= 0D0) return

    ! Compute the equivalent mole fractions
    do j = nSpeciesPhase(iSolnIndex-1) + 1, nSpeciesPhase(iSolnIndex)
        i = j - nSpeciesPhase(iSolnIndex-1)
        y(i) = dMolFraction(j) * dQKTOParams(j,1) / xT
    end do

    ! Now calculate xis and sigma
    do j = nSpeciesPhase(iSolnIndex-1) + 1, nSpeciesPhase(iSolnIndex)
        i = j - nSpeciesPhase(iSolnIndex-1)
        if      (lAsymmetric1(i)) then
            dXi1 = dXi1 + y(i)
        else if (lAsymmetric2(i)) then
            dXi2 = dXi2 + y(i)
        end if
    end do

    dXiDen = dXi1 + dXi2

    ! ChemSage guide says only symmetric ternaries are allowed, but I'm not sure if this is still true
    ! Anyway, we haven't seen any others yet
    ! Also the textbook equations for ternaries don't reproduce the symmetry in FactSage, so for now
    ! I'm just implementing symmetric ternary explicitly
    ! I will still try to make this easy to change later
    if (nSpeciesParam == 3) then
        dXi1 = y(a)
        dXi2 = y(b)
        dXiDen = y(a) + y(b) + y(c)
        ! Force reset of all symmetry arrays, this will enforce the ternary is treated as symmetric no matter the groups
        lAsymmetric1   = .FALSE.
        lAsymmetric2   = .FALSE.
        lAsymmetric1(a) = .TRUE.
        lAsymmetric2(b) = .TRUE.
    end if

    ! Calculate g^excess for binary part
    dGex = dExcessGibbsParam(iParam) * (dXi1**(p - 1)) * (dXi2**(q - 1)) / (dXiDen ** (p + q + r - nSpeciesParam))
    dGex = dGex * y(a) * y(b) * xT

    ! Include ternary factor if present
    if (nSpeciesParam == 3) then
        ! Trying to write this parallel to binary
        dGex = dGex * y(c)**(r - 1)
        dGex = dGex * y(c)
    end if

    do j = nSpeciesPhase(iSolnIndex-1) + 1, nSpeciesPhase(iSolnIndex)
        i = j - nSpeciesPhase(iSolnIndex-1)
        dDgex = -1D0 / xT
        if      (lAsymmetric1(i)) then
            dDgex = dDgex + (p - 1) / dXi1 - (p + q + r - nSpeciesParam) / dXiDen
        else if (lAsymmetric2(i)) then
            dDgex = dDgex + (q - 1) / dXi2 - (p + q + r - nSpeciesParam) / dXiDen
        end if
        if      (i == a) then
            dDgex = dDgex + 1D0 / y(a) / xT
        else if (i == b) then
            dDgex = dDgex + 1D0 / y(b) / xT
        else if (i == c) then
            dDgex = dDgex + 1D0 / y(c) / xT
        end if
        ! Ternary part of derivative
        if (nSpeciesParam == 3) then
            dDgex = dDgex - 1D0 / xT
            if (i == c) then
                dDgex = dDgex + (r - 1) / y(c) - (p + q + r - nSpeciesParam) / dXiDen
            end if
        end if
        dPartialExcessGibbs(j) = dPartialExcessGibbs(j) + dDgex * dGex * dQKTOParams(j,1)
    end do

    return

end subroutine PolyRegularQKTO


c--- Generates 2->4 phase space with (12) a Breit-Wigner around
c--- the Higgs mass
      subroutine gen5h(r,p,wt5,*)
      implicit none
      include 'constants.f'
      include 'mxdim.f'
      include 'debug.f'
      include 'masses.f'
      include 'phasemin.f'
      include 'process.f'
      include 'breit.f'
      include 'x1x2.f'
      integer nu
      double precision r(mxdim)
      double precision wt5,p1(4),p2(4),p3(4),p4(4),p5(4),p6(4),p7(4)
      double precision p(mxpart,4),rtshat
      double precision pswt,xjac
      double precision s12,wt12,ymax,yave
      include 'energy.f'

      wt5=0d0

      if (case .ne. 'HZZqgI') then
c--- this is the usual case
        call breitw(r(9),0d0,sqrts**2,hmass,hwidth,s12,wt12)
      else
c--- this is the HZZqgI case (cf. gen4handc.f)
        if (hmass .lt. mass2+mass3-hwidth*5d0) then
          call breitw(r(9),0d0,sqrts**2,hmass,10d0,s12,wt12)
        else
          call breitw(r(9),0d0,sqrts**2,hmass,hwidth,s12,wt12)
        endif
      endif

      rtshat=dsqrt(s12)
      ymax=dlog(sqrts/rtshat)
      yave=ymax*(two*r(10)-1d0)
      xjac=two*ymax*wt12

      xx(1)=rtshat/sqrts*exp(+yave)
      xx(2)=rtshat/sqrts*exp(-yave)

      if   ((xx(1) .gt. 1d0)
     & .or. (xx(2) .gt. 1d0)
     & .or. (xx(1) .lt. xmin)
     & .or. (xx(2) .lt. xmin)) then
c      write(6,*) 'problems with xx(1),xx(2) in gen4h',xx(1),xx(2)
      return 1
      endif

      p1(4)=-0.5d0*xx(1)*sqrts
      p1(1)=0d0
      p1(2)=0d0
      p1(3)=-0.5d0*xx(1)*sqrts

      p2(4)=-0.5d0*xx(2)*sqrts
      p2(1)=0d0
      p2(2)=0d0
      p2(3)=+0.5d0*xx(2)*sqrts

      call phase5h(r,p1,p2,p3,p4,p5,p6,p7,pswt)

      do nu=1,4
      p(1,nu)=p1(nu)
      p(2,nu)=p2(nu)
      p(3,nu)=p3(nu)
      p(4,nu)=p4(nu)
      p(5,nu)=p5(nu)
      p(6,nu)=p6(nu)
      p(7,nu)=p7(nu)
      enddo

      wt5=xjac*pswt/sqrts**2

      if (debug) write(6,*) 'wt5 in gen5h',wt5
      return

c 999  return 1
      end


module m_vvacis
  !     **********************************************************
  !     g.ne.0 coefficients of vacuum coulomb potential          *
  !     due to the interstitial charge density inside slab       *
  !                                   c.l.fu, r.podloucky        *
  !     **********************************************************
  !     modified for thick films to avoid underflows gb`06
  !---------------------------------------------------------------
  contains

  subroutine vvacis( stars, vacuum, sym, cell, psq, input, field, vxy )

    use m_constants
    use m_types
    implicit none

    type(t_input),  intent(in)  :: input
    type(t_field),  intent(in)  :: field
    type(t_vacuum), intent(in)  :: vacuum
    type(t_sym),    intent(in)  :: sym
    type(t_stars),  intent(in)  :: stars
    type(t_cell),   intent(in)  :: cell
    complex,        intent(in)  :: psq(stars%ng3)
    complex,        intent(out) :: vxy(vacuum%nmzxyd,stars%ng2-1,2)

    complex                     :: arg, c_ph, sumr(2)
    real                        :: dh, g, qz, sign, signz, vcons, z, e_m, arg_r, arg_i
    integer                     :: i2d, ig3n, imz, imzxy, ivac, k1, k2, kz, m0, nrec2, nrz, nz
    intrinsic exp

    vxy(:,:,:) = cmplx( 0., 0. )
    dh = cell%z1
    m0 = -stars%mx3
    if ( sym%zrfs ) m0 = 0
    do  nrec2 = 2, stars%ng2
      k1 = stars%kv2(1,nrec2)
      k2 = stars%kv2(2,nrec2)
      g = stars%sk2(nrec2)
      if ( field%efield%dirichlet ) then
        vcons = 2.0 * tpi_const / ( g * sinh( g * 2.0 * ( field%efield%zsigma + dh ) ) )
        arg_r = g * ( dh + field%efield%zsigma + dh )
      else ! neumann
        vcons = tpi_const / g
        arg_r = exp_save( - 2 * dh * g )
      end if
      do ivac = 1, vacuum%nvac
        sumr(ivac) = ( 0.0, 0.0 )
        sign = 3. - 2. * ivac
        do kz = m0, stars%mx3
          ig3n = stars%ig(k1,k2,kz)
          ! use only stars within the g_max sphere
          if ( ig3n /= 0 ) then
            c_ph = stars%rgphs(k1,k2,kz)
            nz = 1
            if (sym%zrfs) nz = stars%nstr(ig3n) / stars%nstr2(nrec2)
            qz = kz * cell%bmat(3,3)
            ! sum over gz-stars
            do  nrz = 1, nz
              signz = 3. - 2. * nrz
              if ( field%efield%dirichlet ) then
                ! prefactor
                arg = exp( - ImagUnit * signz * qz * dh ) / ( 2 * ( g ** 2 + qz ** 2 ) ) * psq(ig3n)
                if ( ivac == 1 ) then
                  sumr(ivac) = sumr(ivac) + c_ph * exp( - arg_r ) * arg * ( &                           ! c_ph not tested in this case
                      ( - exp( 2 * g * ( field%efield%zsigma + dh ) ) + exp( 2 * ( ImagUnit * signz * qz * dh + arg_r ) ) ) * ( g - ImagUnit * signz * qz ) &
                    + ( - exp( 2 * g * dh ) + exp( 2 * ImagUnit * signz * qz * dh ) )                                       * ( g + ImagUnit * signz * qz ) )
                else
                  sumr(ivac) = sumr(ivac) + c_ph * arg * ( &
                    exp(   arg_r ) * ( g + ImagUnit * signz * qz ) &
                    + exp( - arg_r ) * ( g - ImagUnit * signz * qz ) &
                    + 2 * exp( 2 * ImagUnit * signz * qz * dh ) &
                    * ( - g * cosh( g * ( - field%efield%zsigma ) ) &
                      + ImagUnit * signz * qz * sinh( - g * field%efield%zsigma ) ) )
                end if
              else
                arg = g + sign * ImagUnit * signz * qz
                arg_i = sign * signz * qz * dh
                sumr(ivac) = sumr(ivac) + c_ph * psq(ig3n) * ( cos( arg_i ) * ( 1 - arg_r ) + ImagUnit * sin( arg_i ) * ( 1 + arg_r ) ) / arg
              end if
            enddo
          endif
        enddo
        z = 0 ! moved cell%z1 into above equations
        do imz = 1, vacuum%nmzxy
          if ( field%efield%dirichlet ) then
            e_m = sinh( g * ( field%efield%zsigma - z ) )
          else ! neumann
            e_m = exp_save( - g * z )
          end if
          vxy(imz,nrec2-1,ivac) = vxy(imz,nrec2-1,ivac) + vcons * sumr(ivac) * e_m
          z = z + vacuum%delz
        enddo
      enddo
    enddo

  end subroutine vvacis

  pure real function exp_save(x)
    ! replace exp by a function that does not under/overflow

    implicit none
    real, intent(in) :: x
    real, parameter  :: maxexp = log( 2.0 ) * maxexponent( 2.0 )
    real, parameter  :: minexp = log( 2.0 ) * minexponent( 2.0 )

    if ( abs(x) > minexp .and. abs(x) < maxexp ) then
      exp_save = exp( x )
    else
      if ( x > 0 ) then
        if ( x > minexp ) then
          exp_save = exp( maxexp )
        else
          exp_save = exp( minexp )
        endif
      else
        if ( -x > minexp ) then
          exp_save = exp( -maxexp )
        else
          exp_save = exp( -minexp )
        endif
      endif
    endif
  end function exp_save

end module m_vvacis


module maxent

  use types, only: dp

  implicit none

contains

  function outer(x, y)
    real(dp), dimension(:), intent(in) :: x
    real(dp), dimension(:), intent(in) :: y
    real(dp), dimension(size(x), size(y)) :: outer

    integer :: i, j

    do concurrent (i = 1:size(x), j = 1:size(y))
       outer(i, j) = x(i) * y(j)
    end do
  end function outer

  subroutine fit(rowValues, rowWeights, colValues, colWeights, mu)
    integer, dimension(:), intent(in) :: rowValues
    integer, dimension(size(rowValues)), intent(in) :: rowWeights
    integer, dimension(:), intent(in) :: colValues
    integer, dimension(size(colValues)), intent(in) :: colWeights
    real(dp), dimension(size(rowValues) + size(colValues)), intent(out), target :: mu

    character(len=60) :: task, csave
    logical :: lsave(4)
    integer :: isave(44)
    real(dp) :: dsave(29)
    integer :: n, m
    real(dp) :: f
    real(dp), dimension(size(rowValues) + size(colValues)), target :: g
    real(dp), dimension(size(rowValues) + size(colValues)) :: l, u
    integer, dimension(size(rowValues) + size(colValues)) :: nbd
    real(dp), allocatable  :: wa(:)
    integer,  allocatable  :: iwa(:)

    real(dp), dimension(size(rowValues)) :: row_violations
    real(dp), dimension(size(colValues)) :: col_violations
    real(dp), dimension(size(rowValues), size(colValues)) :: P, eA
    integer :: nrows, ncols

    real(dp), dimension(:), pointer :: mu_rows
    real(dp), dimension(:), pointer :: mu_cols

    real(dp), dimension(:), pointer :: g_rows
    real(dp), dimension(:), pointer :: g_cols

    nrows = size(rowValues)
    ncols = size(colValues)

    mu_rows(1:nrows) => mu(:nrows)
    mu_cols(1:ncols) => mu(nrows+1:)

    g_rows(1:nrows) => g(:nrows)
    g_cols(1:ncols) => g(nrows+1:)

    mu = 0
    task = 'START'
    n = size(mu)
    m = 10
    nbd = 0

    allocate(wa(2*m*n + 5*n + 11*m*m + 8*m))
    allocate(iwa(3*n))

    do while (task(1:2) .eq. 'FG' .or. task .eq. 'NEW_X' .or. task .eq. 'START')
       !call setulb(n, m, mu, l, u, nbd, f, g, 1.d+7, 1.d-5, wa, &
       call setulb(n, m, mu, l, u, nbd, f, g, 1.d+1, 1.d-5, wa, &
            iwa, task, 0, csave, lsave, &
            isave, dsave)

       if (task(1:2) .eq. 'FG') then
          eA = outer(exp(mu_rows), exp(mu_cols))
          P = 1.0d0 / (eA + 1)

          row_violations = rowWeights * (matmul(P, colWeights) - rowValues)
          col_violations = colWeights * (matmul(rowWeights, P) - colValues)
          f = -1 * (dot_product(mu_rows, row_violations) &
               + dot_product(mu_cols, col_violations) &
               + dot_product(rowWeights, matmul(log(eA) * eA / (eA + 1) - log(eA + 1), colWeights)))

          g_rows = -1 * row_violations
          g_cols = -1 * col_violations
       end if
    end do

    deallocate(wa)
    deallocate(iwa)

  end subroutine fit

end module maxent


      PROGRAM ASSOCIATE_EXAMPLE

        REAL :: MYREAL, X, Y, THETA, A
        X = 0.42
        Y = 0.35
        MYREAL = 9.1
        THETA = 1.5
        A = 0.4

        ASSOCIATE ( Z => EXP(-(X**2+Y**2)) * COS(THETA), V => MYREAL)
          PRINT *, A+Z, A-Z, V
          V = V * 4.6
        END ASSOCIATE

        PRINT *, MYREAL

      END PROGRAM ASSOCIATE_EXAMPLE


      program readWriteInfo
!
!     This program contains examples of the matrix file read and write routines
!
      use mqc_gaussian
!
!
!     Variable Declarations...
!
      implicit none
      character(len=:),allocatable::fileName,newMatFile

      type(mqc_gaussian_unformatted_matrix_file)::fileInfo
      integer::iOut=6,iPrint=2,nBasis,nAlpha,nBeta
      type(mqc_scf_integral)::mo_coefficients,overlap
      type(mqc_matrix)::sh2AtMp,shlTyp,nPrmSh,prmExp,conCoef,conCoTwo,shCoor
!
      write(iOut,*)
      write(iOut,*) 'MQC Read-Write Examples'
      write(iOut,*)
      write(iOut,*) 'L. M. Thompson, 2017.'
      write(iOut,*)
!
!     Command line arguments can be returned as strings of correctly allocated length using
!     mqc_get_command_argument
!
      call mqc_get_command_argument(1,fileName)
!
!     The header can be loaded from the file using the load procedure.
!
      call fileInfo%load(filename)
!
!     Using the getArray procedure, matrix file arrays can be read in exactly as found in the
!     matrix file.
!
      call fileInfo%getArray('SHELL TO ATOM MAP',sh2AtMp)
      call fileInfo%getArray('SHELL TYPES',shlTyp)
      call fileInfo%getArray('NUMBER OF PRIMITIVES PER SHELL',nPrmSh)
      call fileInfo%getArray('PRIMITIVE EXPONENTS',prmExp)
      call fileInfo%getArray('CONTRACTION COEFFICIENTS',conCoef)
      call fileInfo%getArray('P(S=P) CONTRACTION COEFFICIENTS',conCoTwo)
      call fileInfo%getArray('COORDINATES OF EACH SHELL',shCoor)
!
!     The getESTObj procedure allows certain matrix file arrays to be simultaneously read and
!     organized into spin blocks. Arrays are automatically be ordered regardless of whether the
!     matrix file contains RHF, UHF, GHF and/or complex integrals.
!
      call fileInfo%getESTObj('overlap',est_integral=overlap)
      call fileInfo%getESTObj('mo coefficients',est_integral=mo_coefficients)
!
!     EST objects can be printed in exactly the same way as MQC objects. The output will be
!     automatically adjusted depending on the wavefunction/density type.
!
      call overlap%print(iOut,'Overlap')
      call mo_coefficients%print(iOut,'MO coefficients')
!
!     The getVal procedure allows certain scalar values to be retrieved from the matrix file.
!
      nBasis = fileInfo%getVal('nBasis')
      nAlpha = fileInfo%getVal('nAlpha')
      nBeta = fileInfo%getVal('nBeta')
!
!     EST objects can be multiplied and transposed with each other, as well as with MQC variables.
!
      call mqc_print_integral(matmul(transpose(mo_coefficients),matmul(overlap,mo_coefficients)),iOut,'MO overlap')
!
!     A new matrix file can be created with the header information stored in fileinfo.
!
      call mqc_get_command_argument(2,newMatFile)
      call fileinfo%create(newMatFile)
!
!     Matrix file arrays can be output to the new matrix file using the writeArray procedure.
!
      call fileInfo%writeArray('SHELL TO ATOM MAP',sh2AtMp)
      call fileInfo%writeArray('SHELL TYPES',shlTyp)
      call fileInfo%writeArray('NUMBER OF PRIMITIVES PER SHELL',nPrmSh)
      call fileInfo%writeArray('PRIMITIVE EXPONENTS',prmExp)
      call fileInfo%writeArray('CONTRACTION COEFFICIENTS',conCoef)
      call fileInfo%writeArray('P(S=P) CONTRACTION COEFFICIENTS',conCoTwo)
      call fileInfo%writeArray('COORDINATES OF EACH SHELL',shCoor)
!
!     EST objects can be written using the writeESTObj procedure. This is automatically written
!     to the matrix file depending on the spin blocks present, but can be specified manually with
!     the optional override argument.
!
      call fileinfo%writeESTObj('density',est_integral=(matmul(mo_coefficients,transpose(mo_coefficients))), &
        override='spin')
      call fileinfo%writeESTObj('mo coefficients',est_integral=mo_coefficients,override='general')
!
 999  end program readWriteInfo


module easy_tc_module
    use :: util_api, only : dictionary

    use :: algorithms_api, only : contract

    implicit none
    private

    public :: run_easy_tc

contains
    subroutine run_easy_tc()

        call run_real_mm_default()
        call run_complex_mm_default()
        call run_real_rank3_default()

        call run_real_rank3_with_options()
    end subroutine run_easy_tc

    subroutine run_real_mm_default()

        real, dimension(10,10) :: a, b, c

        call populate_real_matrix(a); call populate_real_matrix(b)
        call contract(c, a, b, "c(m,n)=a(m,k)*b(k,n)")
    end subroutine run_real_mm_default

    subroutine run_complex_mm_default()

        complex, dimension(10,10) :: a, b, c

        call populate_complex_matrix(a); call populate_complex_matrix(b)
        call contract(c, a, b, "c(m,n)=a(m,k)*b(k,n)")
    end subroutine run_complex_mm_default

    subroutine run_real_rank3_default()

        real, dimension(10,10) :: c
        real, dimension(10,10,10) :: a, b

        call populate_real_rank3(a); call populate_real_rank3(b)
        call contract(c, a, b, "c(p,q)=a(p,r,s)*b(q,s,r)")
    end subroutine run_real_rank3_default

    subroutine run_real_rank3_with_options()

        real, dimension(10,10) :: c
        real, dimension(10,10,10) :: a, b
        type(dictionary) :: options

        options = dictionary()
        call options%set_value("contraction_driver", "unbuffered_ttgt")
        call options%set_value("unbuffered_ttgt-mm_driver", "intrinsic")
        call options%set_value("unbuffered_ttgt-permute_driver", "loops")

        call populate_real_rank3(a); call populate_real_rank3(b)
        call contract(c, a, b, "c(p,q)=a(p,r,s)*b(q,s,r)", options=options)
    end subroutine run_real_rank3_with_options

    subroutine populate_real_matrix(a)
        real, dimension(:,:), intent(inout) :: a

        call random_number(a)
    end subroutine populate_real_matrix

    subroutine populate_real_rank3(a)
        real, dimension(:,:,:), intent(inout) :: a

        call random_number(a)
    end subroutine populate_real_rank3

    subroutine populate_complex_matrix(a)
        complex, dimension(:,:), intent(inout) :: a

        real, dimension(:,:), allocatable :: a_real, a_imag

        allocate(a_real(size(a,1), size(a,2)))
        allocate(a_imag(size(a,1), size(a,2)))

        call random_number(a_real)
        call random_number(a_imag)
        a = cmplx(a_real, a_imag)
    end subroutine populate_complex_matrix
end module easy_tc_module


      PROGRAM FTEX01D
C
C  Example of CURV1DP, CURV2DP, CURVDDP, CURVIDP.
C
C  Define dimensions, declare arrays.
C
      PARAMETER (IDIM=11,IOUT=201)
      DOUBLE PRECISION X
      DOUBLE PRECISION Y
      DOUBLE PRECISION YP
      DOUBLE PRECISION TEMP
      DOUBLE PRECISION XO
      DOUBLE PRECISION YO
      DOUBLE PRECISION YD
      DOUBLE PRECISION YI
      DOUBLE PRECISION SLP1
      DOUBLE PRECISION SLPN
      DOUBLE PRECISION SIGMA
      DOUBLE PRECISION XINC
      DOUBLE PRECISION CURV2DP
      DOUBLE PRECISION CURVDDP
      DOUBLE PRECISION CURVIDP
      DIMENSION X(IDIM),Y(IDIM),YP(IDIM),TEMP(IDIM,2)
      DIMENSION XO(IOUT),YO(IOUT),YD(IOUT),YI(IOUT)
C
C Specify the input data.
C
C
      DATA X/0.00D0,2.00D0,5.00D0,8.00D0,10.00D0,13.00D0,15.00D0,
     +     18.00D0,21.00D0,23.00D0,30.00D0/
      DATA Y/1.00D0,0.81D0,0.00D0,-0.81D0,-1.00D0,-0.84D0,-0.56D0,
     +     0.04D0,0.73D0,1.18D0,2.0D0/
C
C  Call CURV1DP setup, specifying that the derivatives should be
C  zero at the end points.
C
      SLP1 = 0.D0
      SLPN = 0.D0
      ISLPSW = 0
      SIGMA = 1.D0
      CALL CURV1DP(IDIM,X,Y,SLP1,SLPN,ISLPSW,YP,TEMP,SIGMA,IERR)
C
C  Call CURV2DP and calculate the interpolated values, the derivatives,
C  and the integrals.
C
      XINC = 30.D0/ (IOUT-1)
      DO 10 I = 1,IOUT
          XO(I) = (I-1)*XINC
          YO(I) = CURV2DP(XO(I),IDIM,X,Y,YP,SIGMA)
          YD(I) = CURVDDP(XO(I),IDIM,X,Y,YP,SIGMA)
          YI(I) = CURVIDP(XO(1),XO(I),IDIM,X,Y,YP,SIGMA)
   10 CONTINUE
C
C This next section plots the data. You must have a double precision
C version of NCAR Graphics in order for this section to compile and
C run correctly.  For now, it is commented out.
C
C  Draw a plot of the interpolated functions and mark the original points.
C
C      CALL DRWFT1(IDIM,X,Y,IOUT,XO,YO,YD,YI)
C
      STOP
      END
C      SUBROUTINE DRWFT1(II,X,Y,IO,XO,YO,YD,YI)
C
C Define the error file, the Fortran unit number, the workstation type,
C and the workstation ID to be used in calls to GKS routines.
C
C     PARAMETER (IERRF=6, LUNIT=2, IWTYPE=1,  IWKID=1)   ! NCGM
C     PARAMETER (IERRF=6, LUNIT=2, IWTYPE=8,  IWKID=1)   ! X Windows
C     PARAMETER (IERRF=6, LUNIT=2, IWTYPE=11, IWKID=1)   ! PDF
C     PARAMETER (IERRF=6, LUNIT=2, IWTYPE=20, IWKID=1)   ! PostScript
C
C     PARAMETER (IERRF=6, LUNIT=2, IWTYPE=1,  IWKID=1)
C
C      DOUBLE PRECISION X
C      DOUBLE PRECISION Y
C      DOUBLE PRECISION XO
C      DOUBLE PRECISION YO
C      DOUBLE PRECISION YD
C      DOUBLE PRECISION YI
C      DOUBLE PRECISION YPOS_TOP
C      DOUBLE PRECISION YB
C      DOUBLE PRECISION YT
C
C      DATA YPOS_TOP/0.88D0/
C
C  Open GKS, open and activate a workstation.
C
C      CALL GOPKS(IERRF,ISZDM)
C      CALL GOPWK(IWKID,LUNIT,IWTYPE)
C      CALL GACWK(IWKID)
C
C  Define a color table.
C
C      CALL GSCR(IWKID,0,1.0D0,1.0D0,1.0D0)
C      CALL GSCR(IWKID,1,0.0D0,0.0D0,0.0D0)
C      CALL GSCR(IWKID,2,1.0D0,0.0D0,0.0D0)
C      CALL GSCR(IWKID,3,0.0D0,1.0D0,0.0D0)
C      CALL GSCR(IWKID,4,0.0D0,0.0D0,1.0D0)
C      CALL GSCLIP(0)
C
C  Plot main title.
C
C      CALL PLCHHQ(0.50D0,0.95D0,
C     +     ':F25:Demo for CURVDP, CURVDDP, CURVIDP',
C     +     0.030D0,0.D0,0.D0)
C
C  Graph the interpolated function values and mark the original
C  input data points.
C
C      YB = -1.0D0
C      YT = 2.0D0
C      CALL BKGFT1(YPOS_TOP,'Function',YB,YT)
C      CALL GRIDAL(6,5,3,1,1,1,10,0.0D0,YB)
C
C  Mark the original data points.
C
C      CALL GSMKSC(2.D0)
C      CALL GSPMCI(4)
C      CALL GSLWSC(1.D0)
C      CALL GPM(II,X,Y)
C
C  Graph the interpolated function values.
C
C      CALL GPL(IO,XO,YO)
C
C  Graph the derivative.
C
C      YB = -0.3D0
C      YT = 0.3D0
C      CALL BKGFT1(YPOS_TOP-0.3D0,'Derivative',YB,YT)
C      CALL GRIDAL(6,5,3,1,1,1,10,0.0D0,YB)
C      CALL GPL(IO,XO,YD)
C      CALL GSPLCI(1)
C
C  Graph the integral.
C
C      YB = -6.0D0
C      YT = 10.0D0
C      CALL BKGFT1(YPOS_TOP-0.6D0,'Integral',YB,YT)
C      CALL GRIDAL(6,5,4,1,1,1,10,0.0D0,YB)
C      CALL GPL(IO,XO,YI)
C      CALL GSPLCI(1)
C      CALL FRAME
C
C      CALL GDAWK(IWKID)
C      CALL GCLWK(IWKID)
C      CALL GCLKS
C
C      RETURN
C      END
C      SUBROUTINE BKGFT1(YPOS,LABEL,YB,YT)
C      DOUBLE PRECISION YPOS
C      DOUBLE PRECISION YB
C      DOUBLE PRECISION YT
C      DOUBLE PRECISION XX
C      DOUBLE PRECISION YY
C      DIMENSION XX(2),YY(2)
C      CHARACTER*(*) LABEL
C
C      CALL SET(0.D0,1.D0,0.D0,1.D0,0.D0,1.D0,0.D0,1.D0,1)
C      CALL PCSETI('FN',21)
C      CALL PLCHHQ(0.20D0,YPOS-0.03D0,LABEL,0.025D0,0.D0,-1.D0)
C      CALL SET(0.13D0,0.93D0,YPOS-0.2D0,YPOS,0.0D0,30.0D0,YB,YT,1)
C      XX(1) = 0.D0
C      XX(2) = 30.D0
C      YY(1) = 0.D0
C      YY(2) = 0.D0
C      CALL GSPLCI(2)
C      CALL GPL(2,XX,YY)
C      CALL GSPLCI(1)
C
C      CALL GASETI('LTY',1)
C      CALL PCSETI('FN',21)
C      CALL GASETR('XLS',0.02D0)
C      CALL GASETC('XLF','(I3)')
C      CALL GASETR('YLS',0.02D0)
C      CALL GASETC('YLF','(F5.1)')
C      CALL GASETR('XMJ',0.02D0)
C      CALL GASETR('YMJ',0.02D0)
C
C      RETURN
C      END


SUBROUTINE clawpack46_qinit(meqn,mbc,mx,my,mz,xlower,ylower,zlower, &
        dx,dy,dz, q,maux,aux)
    IMPLICIT NONE

    INTEGER :: meqn, mbc, mx, my, mz, maux
    DOUBLE PRECISION :: xlower, ylower, zlower, dx, dy, dz
    DOUBLE PRECISION ::   q(1-mbc:mx+mbc, 1-mbc:my+mbc,1-mbc:mz+mbc,meqn)
    DOUBLE PRECISION :: aux(1-mbc:mx+mbc, 1-mbc:my+mbc,1-mbc:mz+mbc,maux)

    INTEGER :: i, j, k, mq
    DOUBLE PRECISION :: xlow, ylow, zlow, w

    integer :: blockno

    blockno = 0

    DO mq = 1,meqn
        do k = 1-mbc,mz+mbc
            zlow = zlower + (k-1)*dz
            DO j = 1-mbc,my+mbc
                ylow = ylower + (j-1)*dy
                DO i = 1-mbc,mx+mbc
                    xlow = xlower + (i-1)*dx
                    CALL cellave3(blockno,xlow,ylow,zlow,dx,dy,dz,w)
                    q(i,j,k,1) = w
                end do
            ENDDO
        ENDDO
    ENDDO

END SUBROUTINE clawpack46_qinit


module numeric_kinds
  ! named constants for 4, 2, and 1 byte integers:
  integer, parameter :: &
       i4b = selected_int_kind(9), &
       i2b = selected_int_kind(4), &
       i1b = selected_int_kind(2)
  ! single, double and quadruple precision reals:
  integer, parameter :: &
       sp = kind(1.0), &
       dp = selected_real_kind(2 * precision(1.0_sp)), &
       qp = selected_real_kind(2 * precision(1.0_dp))
end module numeric_kinds


!***********************************************************************************************************************************
! UNIT:
!
!  (MODULE) MR_ERRORS_NONLINEAR_EQN_SOLVE
!
! PURPOSE:
!
!   TO DEFINE THE UNIQUE ERROR PARAMETERS IN THE PROJECT INIBATHYGEN.
!
! DEFINITION OF VARIABLES:
!
!
!
! RECORD OF REVISIONS:
!
!      DATE       |    PROGRAMMER    |    DESCRIPTION OF CHANGE
!      ====       |    ==========    |    =====================
!   20XX-XX-XX    |     DR. HYDE     |    ORIGINAL CODE.
!
!***********************************************************************************************************************************
  MODULE MR_ERRORS_NONLINEAR_EQN_SOLVE

    IMPLICIT NONE

    INTEGER , PARAMETER :: ERROR_BISECT_SOLVE_NO_UNIQUE_ROOT_IN_REGION = -2001

    INTEGER , PARAMETER :: ERROR_NEWTON_SOLVE_ZERO_DERIVATIVE          = -2011
    INTEGER , PARAMETER :: ERROR_NEWTON_SOLVE_MAX_NUMBER_OF_ITERATION  = -2012

  END MODULE MR_ERRORS_NONLINEAR_EQN_SOLVE


*DECK SGEEV
      SUBROUTINE SGEEV (A, LDA, N, E, V, LDV, WORK, JOB, INFO)
C***BEGIN PROLOGUE  SGEEV
C***PURPOSE  Compute the eigenvalues and, optionally, the eigenvectors
C            of a real general matrix.
C***LIBRARY   SLATEC
C***CATEGORY  D4A2
C***TYPE      SINGLE PRECISION (SGEEV-S, CGEEV-C)
C***KEYWORDS  EIGENVALUES, EIGENVECTORS, GENERAL MATRIX
C***AUTHOR  Kahaner, D. K., (NBS)
C           Moler, C. B., (U. of New Mexico)
C           Stewart, G. W., (U. of Maryland)
C***DESCRIPTION
C
C     Abstract
C      SGEEV computes the eigenvalues and, optionally,
C      the eigenvectors of a general real matrix.
C
C     Call Sequence Parameters-
C       (The values of parameters marked with * (star) will be changed
C         by SGEEV.)
C
C        A*      REAL(LDA,N)
C                real nonsymmetric input matrix.
C
C        LDA     INTEGER
C                set by the user to
C                the leading dimension of the real array A.
C
C        N       INTEGER
C                set by the user to
C                the order of the matrices A and V, and
C                the number of elements in E.
C
C        E*      COMPLEX(N)
C                on return from SGEEV, E contains the eigenvalues of A.
C                See also INFO below.
C
C        V*      COMPLEX(LDV,N)
C                on return from SGEEV, if the user has set JOB
C                = 0        V is not referenced.
C                = nonzero  the N eigenvectors of A are stored in the
C                first N columns of V.  See also INFO below.
C                (Note that if the input matrix A is nearly degenerate,
C                 V may be badly conditioned, i.e., may have nearly
C                 dependent columns.)
C
C        LDV     INTEGER
C                set by the user to
C                the leading dimension of the array V if JOB is also
C                set nonzero.  In that case, N must be .LE. LDV.
C                If JOB is set to zero, LDV is not referenced.
C
C        WORK*   REAL(2N)
C                temporary storage vector.  Contents changed by SGEEV.
C
C        JOB     INTEGER
C                set by the user to
C                = 0        eigenvalues only to be calculated by SGEEV.
C                           Neither V nor LDV is referenced.
C                = nonzero  eigenvalues and vectors to be calculated.
C                           In this case, A & V must be distinct arrays.
C                           Also, if LDA .GT. LDV, SGEEV changes all the
C                           elements of A thru column N.  If LDA < LDV,
C                           SGEEV changes all the elements of V through
C                           column N. If LDA = LDV, only A(I,J) and V(I,
C                           J) for I,J = 1,...,N are changed by SGEEV.
C
C        INFO*   INTEGER
C                on return from SGEEV the value of INFO is
C                = 0  normal return, calculation successful.
C                = K  if the eigenvalue iteration fails to converge,
C                     eigenvalues K+1 through N are correct, but
C                     no eigenvectors were computed even if they were
C                     requested (JOB nonzero).
C
C      Error Messages
C           No. 1  recoverable  N is greater than LDA
C           No. 2  recoverable  N is less than one.
C           No. 3  recoverable  JOB is nonzero and N is greater than LDV
C           No. 4  warning      LDA > LDV, elements of A other than the
C                               N by N input elements have been changed.
C           No. 5  warning      LDA < LDV, elements of V other than the
C                               N x N output elements have been changed.
C
C***REFERENCES  (NONE)
C***ROUTINES CALLED  BALANC, BALBAK, HQR, HQR2, ORTHES, ORTRAN, SCOPY,
C                    SCOPYM, XERMSG
C***REVISION HISTORY  (YYMMDD)
C   800808  DATE WRITTEN
C   890531  Changed all specific intrinsics to generic.  (WRB)
C   890531  REVISION DATE from Version 3.2
C   891214  Prologue converted to Version 4.0 format.  (BAB)
C   900315  CALLs to XERROR changed to CALLs to XERMSG.  (THJ)
C   900326  Removed duplicate information from DESCRIPTION section.
C           (WRB)
C***END PROLOGUE  SGEEV
      INTEGER I,IHI,ILO,INFO,J,JB,JOB,K,KM,KP,L,LDA,LDV,
     1        MDIM,N
      REAL A(*),E(*),WORK(*),V(*)
C***FIRST EXECUTABLE STATEMENT  SGEEV
      IF (N .GT. LDA) CALL XERMSG ('SLATEC', 'SGEEV', 'N .GT. LDA.', 1,
     +   1)
      IF (N .GT. LDA) RETURN
      IF (N .LT. 1) CALL XERMSG ('SLATEC', 'SGEEV', 'N .LT. 1', 2, 1)
      IF(N .LT. 1) RETURN
      IF(N .EQ. 1 .AND. JOB .EQ. 0) GO TO 35
      MDIM = LDA
      IF(JOB .EQ. 0) GO TO 5
      IF (N .GT. LDV) CALL XERMSG ('SLATEC', 'SGEEV',
     +   'JOB .NE. 0 AND N .GT. LDV.', 3, 1)
      IF(N .GT. LDV) RETURN
      IF(N .EQ. 1) GO TO 35
C
C       REARRANGE A IF NECESSARY WHEN LDA.GT.LDV AND JOB .NE.0
C
      MDIM = MIN(LDA,LDV)
      IF (LDA .LT. LDV) CALL XERMSG ('SLATEC', 'SGEEV',
     +   'LDA.LT.LDV,  ELEMENTS OF V OTHER THAN THE N BY N OUTPUT ' //
     +   'ELEMENTS HAVE BEEN CHANGED.', 5, 0)
      IF(LDA.LE.LDV) GO TO 5
      CALL XERMSG ('SLATEC', 'SGEEV',
     +   'LDA.GT.LDV, ELEMENTS OF A OTHER THAN THE N BY N INPUT ' //
     +   'ELEMENTS HAVE BEEN CHANGED.', 4, 0)
      L = N - 1
      DO 4 J=1,L
         M = 1+J*LDV
         K = 1+J*LDA
         CALL SCOPY(N,A(K),1,A(M),1)
    4 CONTINUE
    5 CONTINUE
C
C     SCALE AND ORTHOGONAL REDUCTION TO HESSENBERG.
C
      CALL BALANC(MDIM,N,A,ILO,IHI,WORK(1))
      CALL ORTHES(MDIM,N,ILO,IHI,A,WORK(N+1))
      IF(JOB .NE. 0) GO TO 10
C
C     EIGENVALUES ONLY
C
      CALL HQR(LDA,N,ILO,IHI,A,E(1),E(N+1),INFO)
      GO TO 30
C
C     EIGENVALUES AND EIGENVECTORS.
C
   10 CALL ORTRAN(MDIM,N,ILO,IHI,A,WORK(N+1),V)
      CALL HQR2(MDIM,N,ILO,IHI,A,E(1),E(N+1),V,INFO)
      IF (INFO .NE. 0) GO TO 30
      CALL BALBAK(MDIM,N,ILO,IHI,WORK(1),N,V)
C
C     CONVERT EIGENVECTORS TO COMPLEX STORAGE.
C
      DO 20 JB = 1,N
         J=N+1-JB
         I=N+J
         K=(J-1)*MDIM+1
         KP=K+MDIM
         KM=K-MDIM
         IF(E(I).GE.0.0E0) CALL SCOPY(N,V(K),1,WORK(1),2)
         IF(E(I).LT.0.0E0) CALL SCOPY(N,V(KM),1,WORK(1),2)
         IF(E(I).EQ.0.0E0) CALL SCOPY(N,0.0E0,0,WORK(2),2)
         IF(E(I).GT.0.0E0) CALL SCOPY(N,V(KP),1,WORK(2),2)
         IF(E(I).LT.0.0E0) CALL SCOPYM(N,V(K),1,WORK(2),2)
         L=2*(J-1)*LDV+1
         CALL SCOPY(2*N,WORK(1),1,V(L),1)
   20 CONTINUE
C
C     CONVERT EIGENVALUES TO COMPLEX STORAGE.
C
   30 CALL SCOPY(N,E(1),1,WORK(1),1)
      CALL SCOPY(N,E(N+1),1,E(2),2)
      CALL SCOPY(N,WORK(1),1,E(1),2)
      RETURN
C
C     TAKE CARE OF N=1 CASE
C
   35 E(1) = A(1)
      E(2) = 0.E0
      INFO = 0
      IF(JOB .EQ. 0) RETURN
      V(1) = A(1)
      V(2) = 0.E0
      RETURN
      END


PROGRAM kinds
!
!  Purpose:
!    To determine the kinds of single and double precision real
!    values on a particular computer.
!
IMPLICIT NONE

! Write out the kinds of single & double precision values
WRITE (*,'(" The KIND for single precision is",I2)') KIND(0.0)
WRITE (*,'(" The KIND for double precision is",I2)') KIND(0.0D0)

END PROGRAM kinds