MODULE MODEL
    use READ_DATA
    IMPLICIT NONE
    INTEGER,DIMENSION(:),ALLOCATABLE:: visited_node
    CONTAINS
    FUNCTION  DISTANCE(i,j) !UPDATED
        INTEGER i,j
        INTEGER a,b
        REAL*8 distance,pi
        pi=dacos(-1d0)
        distance = 0d0
        IF(distance_definition.eq.1)THEN
                ! Arc distance with PBC
                 a=abs(j-i) ; b=n_spins-abs((j-i))
                 distance = dfloat(min(a,b))*distance_factor
        ELSE IF (distance_definition.eq.2)THEN
                ! Chord distance with PBC
                 distance =dfloat(n_spins)*sin(pi*dfloat(abs(i-j))/dfloat(n_spins))/pi
        END IF
    END FUNCTION
    SUBROUTINE COUPLING_MATRIX() !UPDATED
        IMPLICIT NONE
        INTEGER :: i,j,l,k,number_of_interactions,visit,n_iter
        REAL*8 ::probability_number,A_min,A_max,A_mid,Z_min,Z_max,Z_mid,norm_ct
        REAL :: random1,random2,pi,r1279
        LOGICAL :: repeated,accepted_j,connected
        pi=acos(-1.)
        ALLOCATE(visited_node(n_spins))
        n_iter=0
        connected=.FALSE.
        IF(is_initial_seed.eqv..TRUE.)THEN
                OPEN(41,FILE='interact_metrix.dat')
        END IF
        IF (matrix_definition.eq.1)THEN
                DO WHILE ((connected.eqv..FALSE.).and.(n_iter.lt.1000))
                n_iter=n_iter+1
                !+++++++++++++++++++++++++++++++++++++++++++++++
                !  NORMALIZATION CONSTANT
                !+++++++++++++++++++++++++++++++++++++++++++++++
                norm_ct=0d0
                DO j=2,n_spins
                        norm_ct=norm_ct+distance(1,j)**(-power_interactions)
                END DO

                !+++++++++++++++++++++++++++++++++++++++++++++++++++++++
                !  COUPLING MATRIX
                !+++++++++++++++++++++++++++++++++++++++++++++++++++++++

                number_neighbours=0
                eff_neigh=0
                spin_interaction=0.

                number_of_interactions=int(real(coordination_number*n_spins)/real(2))
                DO l=1,number_of_interactions
                        ! Choose random i
                        random1=r1279()
                        i=mod(int(real(n_spins)*random1),n_spins)+1
                        accepted_j=.FALSE.
                        DO WHILE (accepted_j.eqv..FALSE.)
                                !Choose random j
                                random2=r1279()
                                j=mod(int(real(n_spins)*random2),n_spins)+1
                                !Chech that is different form i and the
                                !interaction in not assigned
                                repeated=.FALSE.
                                DO k=1,number_neighbours(i)!If this interaction was assinged before, go to next pair
                                         IF(eff_neigh(i,k).eq.j)repeated=.TRUE.
                                END DO
                                IF(i.ne.j)THEN
                                        probability_number=(distance(i,j)**(-power_interactions))/norm_ct
                                END IF
                                random1=r1279()
                                IF((real(random1,8).lt.probability_number).and.(i.ne.j).and.(repeated.eqv..FALSE.))THEN
                                        !Valid interaction
                                        accepted_j=.TRUE.
                                        number_neighbours(i)=number_neighbours(i)+1
                                        number_neighbours(j)=number_neighbours(j)+1
                                        eff_neigh(i,number_neighbours(i))=j
                                        eff_neigh(j,number_neighbours(j))=i
                                        IF (interaction_definition.eq.1) THEN
                                                ! +-1 interaction
                                                ! distribution
                                                random1=r1279()
                                                IF (random1.lt.0.5) THEN
                                                        spin_interaction(i,number_neighbours(i))=1.
                                                        spin_interaction(j,number_neighbours(j))=1.
                                                ELSE
                                                        spin_interaction(i,number_neighbours(i))=-1.
                                                        spin_interaction(j,number_neighbours(j))=-1.
                                                END IF
                                        ELSE IF(interaction_definition.eq.2)THEN
                                                ! Gausian interaction distribution
                                                random1=r1279()
                                                random2=r1279()
                                                spin_interaction(i,number_neighbours(i))=sqrt(-2.*log(random1))*cos(2.*pi*random2)
                                                spin_interaction(j,number_neighbours(j))=spin_interaction(i,number_neighbours(i))
                                        ENDIF
                                        IF(is_initial_seed.eqv..TRUE.)THEN
                                                WRITE(41,*)i,j,spin_interaction(i,number_neighbours(i))
                                        END IF
                                END IF
                        END DO
                END DO
                visit=1
                visited_node=0
                CALL CHECK_CONNECTED_GRAPH(visit)
                !print*,'visited nodes',sum(visited_node)
                IF(sum(visited_node).eq.n_spins)THEN
                        connected=.TRUE.
                        print*,'connected graph found with',n_iter,'iterations'
                END IF
                END DO
                OPEN(40, FILE='seeds_used.dat', action='write',status='unknown',position='append')
                WRITE(40,*)read_seed,real(sum(number_neighbours))/real(n_spins),power_interactions,&
                &n_spins
                close(40)
        ELSE IF (matrix_definition.eq.2)THEN
                DO WHILE ((connected.eqv..FALSE.).and.(n_iter.lt.1000))
                n_iter=n_iter+1
                !+++++++++++++++++++++++++++++++++++++++++++++++++++++++
                !   COMPUTING LOWER BOUND FOR A
                !+++++++++++++++++++++++++++++++++++++++++++++++++++++++
                probability_number=0d0
                DO j=2,n_spins
                        probability_number=probability_number+(1d0/(distance(1,j)**power_interactions))
                END DO
                A_min=dfloat(coordination_number)/probability_number
                !+++++++++++++++++++++++++++++++++++++++++++++++++++++++
                !   COMPUTING Z
                !+++++++++++++++++++++++++++++++++++++++++++++++++++++++
                probability_number=0d0
                DO j=2,n_spins
                        probability_number=probability_number+(1d0-exp(-A_min/(distance(1,j)**power_interactions)))
                END DO
                Z_min=probability_number
                !+++++++++++++++++++++++++++++++++++++++++++++++++++++++
                !   COMPUTING A FOR MAXIMUM Z
                !+++++++++++++++++++++++++++++++++++++++++++++++++++++++
                A_max=A_min
                DO i=1,500
                        probability_number=0d0
                        DO j=2,n_spins
                                probability_number=probability_number+(1d0-exp(-A_max/(distance(1,j)**power_interactions)))
                        END DO
                        IF (probability_number.gt.dfloat(coordination_number)) THEN
                                Z_max=probability_number
                                exit
                        END IF
                        A_max=A_max+1d-1*A_max
                END DO
                !+++++++++++++++++++++++++++++++++++++++++++++++++++++++
                !   FINDING THE BEST A
                !+++++++++++++++++++++++++++++++++++++++++++++++++++++++
                DO i=1,500
                        A_mid=(A_max+A_min)/2d0

                        probability_number=0d0
                        DO j=2,n_spins
                                probability_number=probability_number+(1d0-exp(-A_mid/(distance(1,j)**power_interactions)))
                        END DO
                        Z_mid=probability_number

                        IF (Z_mid.gt.dfloat(coordination_number))THEN
                                A_max=A_mid
                                Z_max=Z_mid

                        ELSE IF (Z_mid.lt.dfloat(coordination_number))THEN
                                A_min=A_mid
                                Z_min=Z_mid
                        END IF
                        IF(abs(Z_max-Z_min).le.1d-5)THEN
                                exit
                        END IF
                END DO
                probability_number=0d0
                DO j=2,n_spins
                        probability_number=probability_number+(1d0-exp(-A_mid/(distance(1,j)**power_interactions)))
                END DO

                !+++++++++++++++++++++++++++++++++++++++++++++++++++++++
                !  COUPLING MATRIX
                !+++++++++++++++++++++++++++++++++++++++++++++++++++++++
                number_neighbours=0
                eff_neigh=0
                spin_interaction=0.

                DO i=1,n_spins
                        DO j=i+1,n_spins
                                repeated=.FALSE.
                                DO k=1,number_neighbours(i)!If this interaction was assinged before, go to next pair
                                        IF(eff_neigh(i,k).eq.j) repeated=.TRUE.
                                END DO
                                IF(i.ne.j)THEN
                                        probability_number=1d0-exp(-A_mid/(distance(i,j)**power_interactions))
                                END IF
                                random1=r1279()
                                IF((real(random1,8).lt.probability_number).and.(i.ne.j).and.(repeated.eqv..FALSE.))THEN
                                        !Valid interaction
                                        number_neighbours(i)=number_neighbours(i)+1
                                        number_neighbours(j)=number_neighbours(j)+1
                                        eff_neigh(i,number_neighbours(i))=j
                                        eff_neigh(j,number_neighbours(j))=i
                                        IF (interaction_definition.eq.1) THEN
                                                ! +-1 interaction
                                                ! distribution
                                                random1=r1279()
                                                IF (random1.lt.0.5) THEN
                                                        spin_interaction(i,number_neighbours(i))=1.
                                                        spin_interaction(j,number_neighbours(j))=1.
                                                ELSE
                                                        spin_interaction(i,number_neighbours(i))=-1.
                                                        spin_interaction(j,number_neighbours(j))=-1.
                                                END IF
                                        ELSE IF(interaction_definition.eq.2)THEN
                                                ! Gausian interaction
                                                ! distribution
                                                random1=r1279()
                                                random2=r1279()
                                                spin_interaction(i,number_neighbours(i))=sqrt(-2.*log(random1))*cos(2.*pi*random2)
                                                spin_interaction(j,number_neighbours(j))=spin_interaction(i,number_neighbours(i))

                                        ENDIF
                                        IF(is_initial_seed.eqv..TRUE.)THEN
                                                WRITE(41,*)i,j,spin_interaction(i,number_neighbours(i))
                                        END IF
                                END IF
                        END DO
                END DO
                visit=1
                visited_node=0
                CALL CHECK_CONNECTED_GRAPH(visit)
                !stop
                !print*,'visited nodes',sum(visited_node)
                IF(sum(visited_node).eq.n_spins)THEN
                        connected=.TRUE.
                        print*,'connected graph with',n_iter,'iterations'
                END IF
                END DO
                OPEN(40, FILE='seeds_used.dat', action='write',status='unknown',position='append')
                WRITE(40,*)read_seed,A_mid,real(sum(number_neighbours))/real(n_spins),power_interactions,&
                &n_spins
                close(40)
        ENDIF
        IF(is_initial_seed.eqv..TRUE.)THEN
                WRITE(41,*)'#####################'
                close(41)
        END IF
    END SUBROUTINE
    RECURSIVE SUBROUTINE CHECK_CONNECTED_GRAPH(to_visit)
        IMPLICIT NONE
        INTEGER :: to_visit,i,next_visit
        visited_node(to_visit)=1
        DO i=1,number_neighbours(to_visit)
                !print*,to_visit,eff_neigh(to_visit,i),visited_node(eff_neigh(to_visit,i))
                IF (visited_node(eff_neigh(to_visit,i)).eq.0)then
                        next_visit=eff_neigh(to_visit,i)
                        CALL CHECK_CONNECTED_GRAPH(next_visit)
                END IF
        END DO
     END SUBROUTINE
END MODULE MODEL


C  *********************** IPERPLANE *************************************
C  construction of the surface L(x,y,z) necessary to obtain second order
C  accuracy  in the FV reconstruction
C ************************************************************************
C
      subroutine iperplane(flag_shoot, xb,yb,zb,xl,yl,zl,
     1                     ubar,ul, ux,uy,uz,const)

      implicit none
      integer flag_shoot, j, info, ipiv(4)
      real*8  xb,yb,zb, xl(4), yl(4), zl(4), ubar, ul(4)
      real*8  ux,uy,uz,const
      real*8  x11,x21,x31,y12,y22,y32,z13,z23,z33,a(4,4),b(4)
      real*8  u11,u12,u13, det_face, det

      if (flag_shoot.eq.2) then
C  interpolant constructed considering the 4 neighbouring tetrahedra of the
C  refering tetrahedron
            x11= xl(1) -xl(2)
            x21= xl(2) -xl(3)
            x31= xl(3) -xl(4)
            y12= yl(1) -yl(2)
            y22= yl(2) -yl(3)
            y32= yl(3) -yl(4)
            z13= zl(1) -zl(2)
            z23= zl(2) -zl(3)
            z33= zl(3) -zl(4)
            u11= ul(1) -ul(2)
            u12= ul(2) -ul(3)
            u13= ul(3) -ul(4)
            det_face= det(x11,y12,z13,x21,y22,z23,x31,y32,z33)
            ux= det(u11,y12,z13,u12,y22,z23,u13,y32,z33)/det_face
            uy= det(x11,u11,z13,x21,u12,z23,x31,u13,z33)/det_face
            uz= det(x11,y12,u11,x21,y22,u12,x31,y32,u13)/det_face
            const =ubar-ux*xb-uy*yb - uz*zb
       else if (flag_shoot.eq.4) then
C  MLS interpolant:
C  interpolant minimizing the values at the 4 neighbours and at the refering
C  tetrahedron with the least square method
            a(1,1)= xb**2
            a(2,1)= xb*yb
            a(3,1)= xb*zb
            a(2,2)= yb**2
            a(3,2)= yb*zb
            a(3,3)= zb**2
            a(1,4)= xb
            a(2,4)= yb
            a(3,4)= zb
            a(4,4) = 5.0d0
            b(1) = ubar*xb
            b(2) = ubar*yb
            b(3)= ubar*zb
            b(4)=ubar
            do j=1,4
             a(1,1)=a(1,1) + xl(j)**2
             a(2,1) = a(2,1) + xl(j)*yl(j)
             a(3,1)= a(3,1) + xl(j)*zl(j)
             a(2,2)= a(2,2) + yl(j)**2
             a(3,2)= a(3,2) + yl(j)*zl(j)
             a(3,3) =  a(3,3)+ zl(j)**2
             a(1,4)= a(1,4)+xl(j)
             a(2,4)= a(2,4)+yl(j)
             a(3,4)= a(3,4)+zl(j)
             b(1)= b(1) + ul(j)*xl(j)
             b(2)= b(2) + ul(j)*yl(j)
             b(3)= b(3) + ul(j)*zl(j)
             b(4) = b(4) + ul(j)
            end do
             a(1,2) = a(2,1)
             a(1,3)=a(3,1)
             a(2,3)=a(3,2)
             a(4,1)=a(1,4)
             a(4,2)=a(2,4)
             a(4,3)=a(3,4)
            call  dgetrf(4,4,a,4,ipiv,info)
            call  dgetrs('N',4,1,a,4,ipiv,b,4,info)
            ux=b(1)
            uy=b(2)
            uz=b(3)
            const =ubar-ux*xb-uy*yb - uz*zb
           end if

         return
         end


module erlang_dist
  implicit none
  integer, private, parameter :: erl_max = 10

contains

  function logpdf_erlang(n, rate, x) result(result)
    use gamma
    integer, intent(in) :: n
    double precision, intent(in) :: rate, x
    double precision :: result
    result = n * log(rate) + (n-1) * log(x) - rate * x - logfact(n-1)
  end function logpdf_erlang

  function pdf_erlang(n, rate, x) result(result)
    integer, intent(in) :: n
    double precision, intent(in) :: rate, x
    double precision :: result
    result = exp(logpdf_erlang(n, rate, x))
  end function pdf_erlang

  function cdf_erlang(n, rate, x) result(result)
    use gamma
    use gamma_dist
    integer, intent(in) :: n
    double precision, intent(in) :: rate, x
    double precision :: result
    integer :: i
    double precision :: w

    if (n <= erl_max) then
      w = 1.0d0
      do i = 1, n-1
        w = w + (rate* x)**i / fact(i)
      end do
      result = 1.0d0 - exp(-rate*x) * w
    else
      result = cdf_gamma(n+1.0d0, rate, x, loggamma(n+1.0d0))
    end if
  end function cdf_erlang

  function ccdf_erlang(n, rate, x) result(result)
    use gamma
    use gamma_dist
    integer, intent(in) :: n
    double precision, intent(in) :: rate, x
    double precision :: result
    integer :: i
    double precision :: w

    if (n <= erl_max) then
      w = 1.0d0
      do i = 1, n-1
        w = w + (rate* x)**i / fact(i)
      end do
      result = exp(-rate*x) * w
    else
      result = ccdf_gamma(n+1.0d0, rate, x, loggamma(n+1.0d0))
    end if
  end function ccdf_erlang

end module erlang_dist


!---------------------------------------------------------------------!
! OWNER: Ithaca Combustion Enterprise, LLC                            !
! COPYRIGHT: © 2012, Ithaca Combustion Enterprise, LLC                !
! LICENSE: BSD 3-Clause License (The complete text of the license can !
!  be found in the `LICENSE-ICE.txt' file included in the ISAT-CK7    !
!  source directory.)                                                 !
!---------------------------------------------------------------------!

subroutine ell_pt_hyper( n, c, gg, p, xh, v )

!  Given an ellipsoid E (centered at c) and a point p, determine the
!  hyperplane H which is the perpendicular bisector of the line c-p
!  in the transformed space in which E is the unit ball.

!  E is defined by:  (x-c)^T * G * G^T * (x-c) <= 1.  The array
!  gg contains the lower triangular n x n matrix G in packed format.

!  The hyperplane H is defined by v^T * ( x - xh  ) = 0, where v is
!  a unit vector.  The quantity s(x) = v^T * ( x - xh  ) is the signed
!  distance of the point x from the hyperplane: s(c) is negative, and
!  s(p) is positive.

!  S.B. Pope  6/4/2006
implicit none

integer, parameter      :: k_dp = kind(1.d0)
integer, intent(in)     :: n
real(k_dp), intent(in)  :: c(n), gg((n*(n+1))/2), p(n)
real(k_dp), intent(out) :: xh(n), v(n)

real(k_dp) :: vsq

xh = 0.5d0 * ( c + p )
v  = p-c
call dtpmv( 'L', 'T', 'N', n, gg, v, 1 )  !   = G * G^T * [p-c]
call dtpmv( 'L', 'N', 'N', n, gg, v, 1 )

vsq = sum( v * v )
if( vsq > 0.d0 ) then
   v = v / sqrt( vsq )
   return
endif

write(0,*)'ell_pt_hyper: vsq = 0.d0'
stop

end subroutine ell_pt_hyper


c gmm01f
c  THIS FILE IS PART OF THE ORIGINAL GMM01F DISTRIBUTION
c
c  This subroutine is originally written by D.W. Mackowski
c  (taken from Mackowski's multisphere-scattering code scsmfo1b.for
c  released to public by the author at 8/1999).
c  Very slightly modified for fitting into this code.
c  Yu-lin Xu   12/2000
c
      subroutine rotcoef(cbe,nmax)
      include 'gmm01f.par'
      parameter (nmp=np*(np+2))
      implicit double precision (a-h,o-z)
      double precision dk0(-2*np:2*np),dk01(-2*np:2*np)
      common/rot/bcof(0:np+2),dc(-np:np,0:nmp)
      common/fnr/fnr(0:2*(np+2))
      sbe=dsqrt((1.d0+cbe)*(1.d0-cbe))
      cbe2=.5d0*(1.d0+cbe)
      sbe2=.5d0*(1.d0-cbe)
      in=1
      dk0(0)=1.d0
      sben=1.d0
      dc(0,0)=1.d0
      dk01(0)=0.d0
      do n=1,nmax
         nn1=n*(n+1)
         in=-in
         sben=sben*sbe/2.d0
         dk0(n)=dble(in)*sben*bcof(n)
         dk0(-n)=dble(in)*dk0(n)
         dk01(n)=0.d0
         dk01(-n)=0.d0
         dc(0,nn1+n)=dk0(n)
         dc(0,nn1-n)=dk0(-n)
         do k=-n+1,n-1
            kn=nn1+k
            dkt=dk01(k)
            dk01(k)=dk0(k)
            dk0(k)=(cbe*dble(n+n-1)*dk01(k)-fnr(n-k-1)*fnr(n+k-1)*dkt)
     1             /(fnr(n+k)*fnr(n-k))
            dc(0,kn)=dk0(k)
         enddo
         im=1
         do m=1,n
            im=-im
            fmn=1.d0/fnr(n-m+1)/fnr(n+m)
            m1=m-1
            dkm0=0.d0
            do k=-n,n
               kn=nn1+k
               dkm1=dkm0
               dkm0=dc(m1,kn)
               if(k.eq.n) then
                  dkn1=0.d0
               else
                  dkn1=dc(m1,kn+1)
               endif
               dc(m,kn)=(fnr(n+k)*fnr(n-k+1)*cbe2*dkm1
     1           -fnr(n-k)*fnr(n+k+1)*sbe2*dkn1
     1              -dble(k)*sbe*dc(m1,kn))*fmn
               dc(-m,nn1-k)=dble((-1)**(k)*im)*dc(m,kn)
            enddo
         enddo
      enddo
      return
      end


      subroutine ccmat(cc,orient1,theta)

ccc   makes 2x2 matrix cc to convert a vector pair of field measurements
ccc   made in directions orient1(1),orient1(2) into a standard (right handed,
ccc   with z pointing down) system of orthogonal coordinates with the x-axis
ccc   pointing in the direction theta.  All angles are given in degrees
ccc   relative to a common reference direction (usually geographic or
ccc   geomagnetic north).  Positive angles correspond to clockwise rotation
ccc   This works even if the original measurements are not orthogonal

      real pi
      parameter(pi = 3.141592654)
      real cc(2,2),theta,orient1(2),pc,det,temp

      pc = pi/180
ccc   matrix to convert vector components from standard (rotated) orthogonal
ccc   coordinate system to arbitrary (not necessarily orthogonal)
ccc   measurement coordinate system

      cc(1,1)=cos((orient1(1)-theta)*pc)
      cc(2,1)=cos((orient1(2)-theta)*pc)
      cc(1,2)=sin((orient1(1)-theta)*pc)
      cc(2,2)=sin((orient1(2)-theta)*pc)

ccc   we want the inverse of this ... Use Kramers rule

      det = cc(1,1)*cc(2,2)-cc(1,2)*cc(2,1)
      temp = cc(1,1)
      cc(1,1) = cc(2,2)/det
      cc(2,2) = temp/det
      cc(1,2) = -cc(1,2)/det
      cc(2,1) = -cc(2,1)/det

      return
      end
ccc_____________________________________________________________________
ccc
      subroutine cctf(u,nt,nvec,ipair,npair,orient,theta)
ccc   change coordinates of components of complex vectors in U(nt,nvec)
ccc   for NPAIR pairs of channels listed in array IPAIR
ccc   orientations of all channels are in ORIENT as usual
ccc   and the x-axis of the new (orthogonal) output coordinate system
ccc   is in the direction THETA

      real orient(2,nt),theta,cc(2,2),orient1(2)
      integer ipair(2,npair),nt,nvec,npair,i,k
      complex u(nt,nvec),u1(2)

      do i =1,npair
         orient1(1) = orient(1,ipair(1,i))
         orient1(2) = orient(1,ipair(2,i))
         call ccmat(cc,orient1,theta)
         do k = 1,nvec
            u1(1) = cc(1,1)*u(ipair(1,i),k)+cc(1,2)*u(ipair(2,i),k)
            u1(2) = cc(2,1)*u(ipair(1,i),k)+cc(2,2)*u(ipair(2,i),k)
            u(ipair(1,i),k) = u1(1)
            u(ipair(2,i),k) = u1(2)
         enddo
      enddo

      return
      end
c______________________________________________________________________
c
      subroutine cc_geog(u,nt,nvec,nsta,ih,ie,orient,theta,e_and_h)

ccc   convert pairs of Hx/Hy and Ex/EY eigenvector components
ccc      into a standard coordinate system  (replaces old geogcor)
ccc    THIS assumes that orient is expressed relative to the same
ccc    FIXED direction as theta
ccc   If e_and_h is .true. , rotate both E and H channels (so ie needs
ccc    to be defined)  If .false.  ie is not referred to

      real orient(2,nt),theta
      integer ih(*),ie(*),ipair(2,500),npair,nt,nvec,ista,nsta
      complex u(nt,nvec)
      logical e_and_h

      npair = 0
      do ista = 1,nsta
         if(ie(ista) - ih(ista) .ge. 2) then
ccc         at least two H at station ista ... assume first two are Hx/Hy
            npair = npair + 1
            ipair(1,npair) = ih(ista)
            ipair(2,npair) = ih(ista)+1
         endif
         if(e_and_h) then
            if(ih(ista+1) - ie(ista) .ge. 2) then
ccc            at least two E at station ista ... assume first two are Ex/Ey
               npair = npair + 1
               ipair(1,npair) = ie(ista)
               ipair(2,npair) = ie(ista)+1
            endif
         endif
      enddo
      call cctf(u,nt,nvec,ipair,npair,orient,theta)

      return
      end
ccc_____________________________________________________________________
ccc
      subroutine ccsdm(s,nt,ipair,npair,orient,theta)
ccc   change coordinates of elements of complex SDM in S
ccc   for NPAIR pairs of channels listed in array IPAIR
ccc   orientations of all channels are in ORIENT as usual
ccc   and the x-axis of the new (orthogonal) output coordinate system
ccc   is in the direction THETA

      real orient(2,nt),theta,cc(2,2),orient1(2)
      integer ipair(2,npair),ii(2),sindex,nt,npair,i,k,l
      complex S(*),s1(2),sc1(2)

      do i =1,npair
         orient1(1) = orient(1,ipair(1,i))
         orient1(2) = orient(1,ipair(2,i))
         call ccmat(cc,orient1,theta)

ccc      multiply on left by 2x2 transformation matrix for each pair
ccc      loop over columns  (NOTE : loop needs to go backwards
ccc       wto keep from overwriting input SDM prematrurely
         do k = nt,1,-1
            do l = 1,2
               ii(l) = ipair(l,i)
               if(ii(l) .ge. k) then
                  s1(l) = s(sindex(ii(l),k))
               else
                  s1(l) = conjg(s(sindex(k,ii(l))))
               endif
            enddo

            sc1(1) = cc(1,1)*s1(1)+cc(1,2)*s1(2)
            sc1(2) = cc(2,1)*s1(1)+cc(2,2)*s1(2)
            do l = 1,2
               if(ii(l) .ge. k) then
                  s(sindex(ii(l),k)) = sc1(l)
               endif
            enddo
         enddo

ccc      multiply on right by transposes of 2x2 transformation matrix
ccc      for each pair
ccc      loop over rows
         do k = 1,nt
            do l = 1,2
               ii(l) = ipair(l,i)
               if(k.ge. ii(l)) then
                  s1(l) = s(sindex(k,ii(l)))
               else
                  s1(l) = conjg(s(sindex(ii(l),k)))
               endif
            enddo

            sc1(1) = cc(1,1)*s1(1)+cc(1,2)*s1(2)
            sc1(2) = cc(2,1)*s1(1)+cc(2,2)*s1(2)
            do l = 1,2
               if(k.ge.ii(l)) then
                  s(sindex(k,ii(l))) = sc1(l)
               endif
            enddo
         enddo
      enddo

      return
      end


      REAL             FUNCTION SMPVAL (P, NDEG, X)
c Copyright (c) 1996 California Institute of Technology, Pasadena, CA.
c ALL RIGHTS RESERVED.
c Based on Government Sponsored Research NAS7-03001.
C>> 1994-10-20 SMPVAL Krogh  Changes to use M77CON
C>> 1994-04-20 SMPVAL CLL Making DP and SP versions similar.
C>> 1987-12-09 SMPVAL Lawson  Initial code.
C     Evaluation of polynomial using monomial basis and a
c     linear transformation of the argument.
C     C.L.LAWSON, JPL, 1974 NOV 19
c     ------------------------------------------------------------------
c--S replaces "?": ?MPVAL
c     ------------------------------------------------------------------
      integer j, ndeg
      real             p(*), x, u
c     ------------------------------------------------------------------
      SMPVAL=0.0e0
      u=(x-p(1))/p(2)
      do 20 j = ndeg, 0, -1
          SMPVAL=SMPVAL*u + p(j+3)
   20 continue
      end


      module MOD_AMBIPOLAR
      real*8,parameter :: ak=1.38062259d-16  ! Boltzmann constant
      !*** VA Must be private for the final version
      real*8,allocatable,dimension(:) :: VA  ! Ambipolar Velocity I3.3, I4.7

      contains
      subroutine writeData(fname,data)
        character*(*) :: fname
        real*8 :: data(:)
        ifl=1012
        print *,'write file "dd-'//fname//'"'
        open(ifl,file='dd-'//fname,status='replace')
        write(ifl,'(e15.6)') data
        close(ifl)
      end subroutine

      pure function gradient(X,Y)
        real*8,dimension(:),intent(in) :: X,Y
        real*8,dimension(size(X)) :: gradient
        integer :: N

        N=size(X);
        if(N /= size(Y)) then
          gradient=0./0.
        elseif (N==1) then
          gradient=0
        else
          gradient(1) = (Y(2)-Y(1))/(X(2)-X(1))
          gradient(2:N-1) = (Y(3:N)-Y(1:N-2))/(X(3:N)-X(1:N-2))
          gradient(N) = (Y(N)-Y(N-1))/(X(N)-X(N-1))
        endif
      end function
      !*********************************************************************!
      !* Calculate the ambipolar diffusion velocity                        *!
      !* See I: Fontenla, Avrett & Loeser "Energy Balance in the Solar     *!
      !* Transition Region. I. Hydrostatic Thermal Models with Ambipolar   *!
      !* Diffusion, Astro Jour. 355 p.700-718, 1-June-1990                 *!
      !*                                                                   *!
      !**********************************************************************!
      subroutine AMBIPOLAR(ND,N,T,ENTOT,RNE,LEVEL,RADIUS,POPNUM,RSTAR,timer)
      use UTILS,       only:assert
      use MOD_GRADIFF, only:gradiff
      use MOD_TICTOC , only:writeToc
      implicit none;
      integer,intent(in) :: ND,N,  timer
      real*8,intent(in) :: RSTAR
      real*8,intent(in),dimension(ND)  :: T,ENTOT,RNE,RADIUS
      real*8,intent(in),dimension(ND,N):: POPNUM
      character,intent(in) :: LEVEL(:)*10 !* Name of Levels needed as a safeguard
      real*8,dimension(ND) :: XIO !* degree of ionization n_p/n_1 (I3.2)
      real*8,dimension(ND) :: press !* pressure due to hydrogen atoms, protons and electrons corresponding to this protons
      real*8,dimension(ND) :: Dx,DT !* see I3.1, I3.2
      integer,parameter :: LEVEL_H1 = 2   !** Index of the H1 Level
      integer,parameter :: LEVEL_H2 = 12  !** Index of the H2 Level
      real*8 :: DIFF(ND)

      integer :: ifl;

      if(.not.allocated(VA)) allocate(VA(ND))
      call assert(size(LEVEL)>=LEVEL_H2,'ambipolar:Level to small.')
      call assert(LEVEL(LEVEL_H1)=='H I......1','ambipolar:H I.')
      call assert(LEVEL(LEVEL_H2)=='H II......','ambipolar: H II')

      press= ENTOT*(1.D0+RNE)*ak*T
      Dx = 90.7*T**(1.76)/press  ! p 704, I3.1

      XIO  = POPNUM(:,LEVEL_H2)/POPNUM(:,LEVEL_H1)
      DT=64.1d0*(T**(1.76d0))/press*
     &      (XIO+2.57d0-4d3/(T*sqrt(XIO)))/(XIO+2d-2/XIO)  ! p. 704, I 3.2
      !*** Calculate VA, the ambipolar velocity = Dx*d(ln(XIO))/dz+DT*d(ln(T))/dz
      !call GRADIFF(ND,log(XIO),DIFF,RADIUS)
      VA = Dx*gradient(RADIUS,log(XIO))+DT*gradient(RADIUS,log(T))
      VA=VA/RSTAR  ! VA in cm/s

      !*** DEBUG from here on***
!      ifl=1012
!      open(ifl,file='VELO.AMBI',status='replace')
!      write(ifl,'(e12.3)') VA
!      close(ifl)
      print *,'AMBIV time: '//writeTOC(timer)
      print '("AMBIV: " 4e12.4e3)',VA
      end subroutine
      end module


c=======================================================================
c
c     subroutine COKURT
c
c     Empirical CoKurtosis matrix, p by (p*p)
c
c                            n
c                        1  ---         -             -             -             -
c     cokurt(i,j,k,l) = --- \   [X(t,i)-X(i)]*[X(t,j)-X(j)]*[X(t,k)-X(k)]*[X(t,l)-X(l)]
c                        n  /
c                           ---
c                           t=1
c     where
c
c                  n
c       -      1  ---
c       X(j) = -  \   X(i,j) for j = 1,...,p
c              n  /
c                 ---
c                 i=1
c
c-----------------------------------------------------------------------
      SUBROUTINE cokurt ( n, p, X, dwork, cokurtosis, info)
c-----------------------------------------------------------------------
c
c     INPUT
c       n           : number of value(s) (n > 1)                 integer
c       p           : number of asset(s) (p >= 1)                integer
c       X           : value(s) (n*p)                              double
c
c     WORKSPACE
c       dwork       : vector( p*n +p)                             double
c
c     OUTPUT
c        cokurtosis : empirical cokurtosis matrix (p*p*p*p)       double
c        info       : diagnostic argument                        integer
c
c     CALL
c        TENSORK    : estimation of co-Skewness[k] matrix
c
c-----------------------------------------------------------------------
c
      IMPLICIT NONE
c
c     arguments i/o
      INTEGER n, p, info
      DOUBLE PRECISION X(*), cokurtosis(*)
c
c     workspaces
      DOUBLE PRECISION dwork(*)
c
c     local variables
      INTEGER k, l, pdtensor, pdHk
c
c     external subroutines
      EXTERNAL TENSORKK, YM
c
c-----------------------------------------------------------------------
c
c     initialisations
      info = 0
c
c     pointers for double precision work space  : dwork
c     -------------------------------------------------
      pdtensor = 1
c     pdtensor: pointer for TENSORKK (p)
      pdHk     = pdtensor + ( p )
c     pdHk    : pointer for Hk tensor ( p*p )
c
c     Total size of dwork array = p*(p + 1)
c
c----------------------------------------------------------------------
c
c     loop
      DO k = 1,p
        DO l = 1,p
c           tensor H[k]
            CALL TENSORKK (n,p,k,l,X,dwork(pdtensor),dwork(pdHk),info)
            IF (info .LT. 0) RETURN
c
            CALL YM ( p, p, dwork(pdHk),
     &                cokurtosis(1+(l-1)*p*p + (k-1)*p*p*p) )
        ENDDO
      ENDDO
c
      RETURN
      END


Real Function xrho(srt)
  Save
  pmass = 0.9383
  rmass = 0.77
  trho = 0.151
  xrho = 0.000000001
  If (srt<=2.67) Return
  esmin = 2.*0.9383 + rmass - trho/2.
  es = srt
  xrho0 = 0.24*(es-esmin)/(1.4+(es-esmin)**2)
  xrho = 3.*xrho0
  Return
End Function xrho


      SUBROUTINE SYSSLV
C
C   PURPOSE:
C      Solve the linear system Ax = b, where A is an n x n (n <= 5)
C      matrix and b is n-dimensional vector.  Solution is by Crout re-
C      duction.  The matrix A, the vector b, and order n are contained
C      in the arrays A, B, and the variable N of the COMMON block
C      SLVBLK.
C
C   REFERENCES:
C      Bartels, R.H.; and Stewart, G.W.: Algorithm 432 - Solution of
C        the Matrix Equation AX + XB = C.  Commun. ACM, vol. 15, no. 9,
C        Sept. 1972, pp. 820-826.
C
C   Subroutines employed by SYSSLV: None
C   Subroutines employing SYSSLV: SHRSLV, SYMSLV
C
      IMPLICIT REAL*8 (A-H,O-Z)
      COMMON/SLVBLK/A(5,5),B(5),N
      REAL*8 MAX
    1 NM1 = N - 1
      N1 = N+1
C
C COMPUTE THE LU FACTORIZATION OF A.
C
      DO 80 K=1,N
        KM1 = K-1
        IF(K.EQ.1) GO TO 20
        DO 10 I=K,N
          DO 10 J=1,KM1
            A(I,K) = A(I,K) - A(I,J)*A(J,K)
   10   CONTINUE
   20   IF(K.EQ.N) GO TO 100
        KP1 = K+1
      MAX = DABS(A(K,K))
        INTR = K
        DO 30 I=KP1,N
          AA = DABS(A(I,K))
          IF(AA .LE. MAX) GO TO 30
          MAX = AA
          INTR = I
   30   CONTINUE
        IF(MAX .EQ. 0.) STOP
        A(N1,K) = INTR
        IF(INTR .EQ. K) GO TO 50
        DO 40 J=1,N
          TEMP = A(K,J)
          A(K,J) = A(INTR,J)
          A(INTR,J) = TEMP
   40   CONTINUE
   50   DO 80 J=KP1,N
          IF(K.EQ.1) GO TO 70
          DO 60 I=1,KM1
            A(K,J) = A(K,J) - A(K,I)*A(I,J)
   60     CONTINUE
   70     A(K,J) = A(K,J)/A(K,K)
   80 CONTINUE
C
C INTERCHANGE THE COMPONENTS OF B.
C
  100 DO 110 J=1,NM1
        INTR = A(N1,J)
        IF(INTR .EQ. J) GO TO 110
        TEMP = B(J)
        B(J) = B(INTR)
        B(INTR) = TEMP
  110 CONTINUE
C
C SOLVE LX = B.
C
  200 B(1) = B(1)/A(1,1)
      DO 220 I=2,N
        IM1 = I-1
        DO 210 J=1,IM1
          B(I) = B(I) - A(I,J)*B(J)
  210   CONTINUE
        B(I) = B(I)/A(I,I)
  220 CONTINUE
C
C SOLVE UX = B.
C
  300 DO 310 II=1,NM1
          I = NM1-II+1
        I1 = I+1
        DO 310 J=I1,N
          B(I) = B(I) - A(I,J)*B(J)
  310 CONTINUE
      RETURN
      END


      SUBROUTINE DT_TESTROT(Pi,Po,Phi,Mode)

      IMPLICIT NONE
      INTEGER j , Mode
      DOUBLE PRECISION Phi , Pi , Po , rot
      SAVE

      DIMENSION rot(3,3) , Pi(3) , Po(3)

      IF ( Mode.EQ.1 ) THEN
         rot(1,1) = 1.D0
         rot(1,2) = 0.D0
         rot(1,3) = 0.D0
         rot(2,1) = 0.D0
         rot(2,2) = COS(Phi)
         rot(2,3) = -SIN(Phi)
         rot(3,1) = 0.D0
         rot(3,2) = SIN(Phi)
         rot(3,3) = COS(Phi)
      ELSE IF ( Mode.EQ.2 ) THEN
         rot(1,1) = 0.D0
         rot(1,2) = 1.D0
         rot(1,3) = 0.D0
         rot(2,1) = COS(Phi)
         rot(2,2) = 0.D0
         rot(2,3) = -SIN(Phi)
         rot(3,1) = SIN(Phi)
         rot(3,2) = 0.D0
         rot(3,3) = COS(Phi)
      ELSE IF ( Mode.EQ.3 ) THEN
         rot(1,1) = 0.D0
         rot(2,1) = 1.D0
         rot(3,1) = 0.D0
         rot(1,2) = COS(Phi)
         rot(2,2) = 0.D0
         rot(3,2) = -SIN(Phi)
         rot(1,3) = SIN(Phi)
         rot(2,3) = 0.D0
         rot(3,3) = COS(Phi)
      ELSE IF ( Mode.EQ.4 ) THEN
         rot(1,1) = 1.D0
         rot(2,1) = 0.D0
         rot(3,1) = 0.D0
         rot(1,2) = 0.D0
         rot(2,2) = COS(Phi)
         rot(3,2) = -SIN(Phi)
         rot(1,3) = 0.D0
         rot(2,3) = SIN(Phi)
         rot(3,3) = COS(Phi)
      ELSE
         STOP ' TESTROT: mode not supported!'
      END IF
      DO j = 1 , 3
         Po(j) = rot(j,1)*Pi(1) + rot(j,2)*Pi(2) + rot(j,3)*Pi(3)
      END DO

      END SUBROUTINE


Subroutine SHMTVarOpt0(l, tapers, lwin, kmax, Sff, var_opt, var_unit, weight_opt, unweighted_covar, nocross)
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!
!	Given the first Kmax tapers of an matrix TAPERS, and an input global power spectrum
!	Sff, this subroutine will compute the variance of the multitaper spectral estimate
!	assuming that the weights are equal to 1/kmax, and by using the optimal weights that
!	minimize the variance. This routine will only work for zonal tapers.
!
!	Calling Parameters
!		IN
!			l		Spherical harmonic degree to compute variances.
!			tapers		An array of (lwin+1,lwin+1) zonal tapers (arranged in columns).
!			lwin		Maximum spherical harmonic degree of the bandlimited tapers.
!			kmax 		Maximum number of tapers to be used in making the
!					spectral estimate.
!			Sff		Known global power spectrum of the unwindowed field.
!		OUT
!			var_opt		Array of dimension kmax containing the variance computed using the
!					optimal weights when using the first 1 to kmax tapers.
!			var_unit	Array of dimension kmax containg the variance computed using
!					equal weights when using the first 1 to kmax tapers.
!		OPTIONAL(out)
!			weight_opt	Matrix of dimension (kmax, kmax) containing the numerical values of the
!					optimal weights to be applied to each spectral estimate (arranged by columns).
!			unweighted_covar	Covariance matrix.
!		OPTIONAL(in)
!			nocross		If present and equal to 1, then the off-diagonal terms of the covariance
!					matrix will be assumed to be zero.
!
!	Dependencies: SHSjkPG0, SSYSV (LAPACK)
!
!	Copyright (c) 2006, Mark A. Wieczorek
!	All rights reserved.
!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!

	use SHTOOLS, only: SHSjkPG0

	implicit none
	real*8, intent(in) ::	tapers(:,:), Sff(:)
	real*8, intent(out) ::	var_opt(:), var_unit(:)
	integer, intent(in) ::	l, lwin, kmax
	real*8, intent(out), optional ::	weight_opt(:,:), unweighted_covar(:,:)
	integer, intent(in), optional ::	nocross
	integer, parameter ::	nb = 64
	real*8 ::		Fij(kmax, kmax), ww(kmax), bb(kmax+1), MM(kmax+1, kmax+1), work((kmax+1)*nb)
	integer ::	i,j, m, k, ipiv(kmax+1), info, lwork
	external :: 	DSYSV_

	if (size(Sff) < l+lwin + 1) then
		print*, "Error --- SHMTVarOpt0"
		print*, "Sff must be dimensioned (L+LWIN+1) where L and LWIN are ", l, lwin
		print*, "Input array is dimensioned ", size(Sff)
		stop
	elseif (size(tapers(:,1)) < lwin+1 .or. size(tapers(1,:)) < kmax) then
		print*, "Error --- SHMTVarOpt0"
		print*, "TAPERS must be dimensioned as (LWIN+1, KMAX) where LWIN and KMAX are ", lwin, kmax
		print*, "Input array is dimensioned ", size(tapers(:,1)), size(tapers(1,:))
		stop
	elseif ( size(var_opt) < kmax) then
		print*, "Error --- SHMTVarOpt0"
		print*, "VAR_OPT must be dimensioned (KMAX) where KMAX is ",  kmax
		print*, "Input array is dimensioned ",  size(var_opt)
		stop
	elseif ( size(var_unit) < kmax) then
		print*, "Error --- SHMTVarOpt0"
		print*, "VAR_UNIT must be dimensioned (KMAX) where KMAX is ",  kmax
		print*, "Input array is dimensioned ",  size(var_unit)
		stop
	endif

	if (present(weight_opt)) then
		if (size(weight_opt(:,1)) < kmax .or. size(weight_opt(1,:)) < kmax) then
			print*, "Error --- SHMTVarOpt0"
			print*, "WEIGHT_OPT must be dimensioned (KMAX, KMAX) where KMAX is ", kmax
			stop
		endif
	endif

	if (present(unweighted_covar)) then
		if (size(unweighted_covar(:,1)) < kmax .or. size(unweighted_covar(1,:)) < kmax) then
			print*, "Error --- SHMTVarOpt0"
			print*, "UNWEIGHTED_COVAR must be dimensioned (KMAX, KMAX) where KMAX is ", kmax
			print*, "Input array is dimensioned ", size(unweighted_covar(:,1)), size(unweighted_covar(1,:))
			stop
		endif
	endif

	if (present(nocross)) then
		if (nocross .ne. 1 .and. nocross .ne. 0) then
			print*, "Error --- SHMTVarOpt0"
			print*, "NOCROSS must be either 0 (use all elements of covariance matrix) or"
			print*, "1 (set off-diagonal elements of covariance matrix to zero)."
			print*, "Input value is ", nocross
			stop
		endif
	endif

	Fij = 0.0d0

	lwork = (kmax+1)*nb

	var_opt = 0.0d0
	var_unit = 0.0d0

	if (present(weight_opt)) then
		weight_opt = 0.0d0
	endif

	!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
	!
	!	Calculate matrix Fij, bb
	!
	!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!

	if (present(nocross)) then

		if (nocross==1) then

			do i=1, kmax, 1
				m=0
				Fij(i,i) = Fij(i,i) + 2.0d0*SHSjkPG0(Sff, i, i, l, m, tapers, lwin)**2
				do m=1, l, 1
					Fij(i,i) = Fij(i,i) + 4.0d0*SHSjkPG0(Sff, i, i, l, m, tapers, lwin)**2
				enddo
			enddo

		else
			do i=1, kmax, 1
				do j=i, kmax, 1
					m=0
					Fij(i,j) = Fij(i,j) + 2.0d0*SHSjkPG0(Sff, i, j, l, m, tapers, lwin)**2
					do m=1, l, 1
						Fij(i,j) = Fij(i,j) + 4.0d0*SHSjkPG0(Sff, i, j, l, m, tapers, lwin)**2
					enddo
					if (i/=j) Fij(j,i) = Fij(i,j)
				enddo
			enddo

		endif

	else

		do i=1, kmax, 1
			do j=i, kmax, 1
				m=0
				Fij(i,j) = Fij(i,j) + 2.0d0*SHSjkPG0(Sff, i, j, l, m, tapers, lwin)**2
				do m=1, l, 1
					Fij(i,j) = Fij(i,j) + 4.0d0*SHSjkPG0(Sff, i, j, l, m, tapers, lwin)**2
				enddo
				if (i/=j) Fij(j,i) = Fij(i,j)
			enddo
		enddo

	endif

	if (present(unweighted_covar)) then
		unweighted_covar = 0.0d0
		unweighted_covar(1:kmax, 1:kmax) = Fij(1:kmax,1:kmax)
	endif

	!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
	!
	!	Calculate variance using equal weights
	!
	!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!

	do k=1, kmax
		var_unit(k) = sum(Fij(1:k,1:k)) / dble(k)**2
	enddo

	!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
	!
	!	Calculate optimal weights and variance using optimal weights
	!
	!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!

	do k=1, kmax
		MM(1:k,1:k) = 2.0d0 * Fij(1:k,1:k)
		MM(k+1,1:k) = 1.0d0
		MM(1:k,k+1) = 1.0d0
		MM(k+1,k+1) = 0.0d0
		bb(1:k) = 0.0d0
		bb(k+1) = 1.0d0

		call DSYSV_("u", k+1, 1, MM, kmax+1, ipiv,  bb,  kmax+1,  work,  lwork, info)
		if (info /=0) then
			print*, "Error --- SHMTVarOpt0"
			print*, "Problem with call to DSYSV."
			print*, "DSYSV info = ", info
			stop
		endif

		if (work(1)/(k+1) > nb) then
			print*, "Warning --- SHMTVarOpt0"
			print*, "The optimal size of nb is ", work(1)/(k+1)
			print*, "Present size is ", nb
			print*, "Please consider changing this parameter and recompiling SHTOOLS."
		endif

		do i=1, k
			ww(i) = bb(i)
		enddo

		if (present(weight_opt)) then
			weight_opt(1:k,k) = ww(1:k)
		endif

		do i=1, k
			do j=1, k
				var_opt(k) = var_opt(k) + ww(i)*ww(j)*Fij(i,j)
			enddo
		enddo

	enddo

end subroutine SHMTVarOpt0


      program wave2d
      use module_vernieuw
!*****************************************!
!* 2d shallow-water model                *!
!*                                       *!
!* including:                            *!
!* - horizontal pressure-gradient force  *!
!* - shapiro filter                      *!
!* - flooding algorithm                  *!
!*                                       *!
!* author: j. kaempf, 2008               *!
!*****************************************!
use sub
! local parameters
integer(4), parameter :: nx=500
integer(4), parameter :: ny=500
      real :: dt
      real :: dx
      real :: dy
      real :: eps
      real, dimension(0:ny+1,0:nx+1) :: eta
      real, dimension(0:ny+1,0:nx+1) :: etan
      real :: g
      real, dimension(0:ny+1,0:nx+1) :: h
      real :: hmin
      real, dimension(0:ny+1,0:nx+1) :: hzero
      integer :: j
      integer :: k
      real, dimension(0:ny+1,0:nx+1) :: u
      real, dimension(0:ny+1,0:nx+1) :: un
      real, dimension(0:ny+1,0:nx+1) :: v
      real, dimension(0:ny+1,0:nx+1) :: vn
      integer, dimension(0:ny+1,0:nx+1) :: wet
real :: hmax
real :: time
real :: dtmax
real :: c
real :: lambda
integer :: n
integer :: ntot
integer :: nout
integer :: dummy
! set local parameters
! runtime parameters
ntot = 10000
! output parameter
!nout = 5
! set epsilon for Shapiro filter
eps = 0.05
call init(hmin,dx,dy,dt,g,j,k,hzero,eta,etan,h,wet,u,un,v,vn)

!**********
!debug
open(90,file ='debug.dat',form='formatted')
! output of initial eta distribution
open(10,file ='eta0.dat',form='formatted')
  do j = 0,ny+1
    write(10,'(101F12.6)')(eta(j,k),k=0,nx+1)
  end do
close(10)
! output of initial layer thickness distribution
open(10,file ='h0.dat',form='formatted')
  do j = 0,ny+1
    write(10,'(101F12.6)')(hzero(j,k),k=0,nx+1)
  end do
close(10)
! determine maximum water depth
hmax = 0.
do j = 1,ny
do k = 1,nx
  hmax = max(hmax,h(j,k))
end do
end do
! maximum phase speed
dummy = 0
c = sqrt(2*g*hmax)
!
write(6,*)"c = ",c
! determine stability parameter
lambda = dt*sqrt(g*hmax)/min(dx,dy)
write(6,*)"lambda = ",lambda
if(lambda > 1)then
  write(6,*) "This will not work. Do you know why?"
  stop
end if
! open files for output
open(10,file ='eta.dat',form='formatted')
open(20,file ='h.dat',form='formatted')
open(30,file ='u.dat',form='formatted')
open(40,file ='v.dat',form='formatted')
do j = 26,26
do k = 26,26
eta(j,k) = 1.0
end do
end do
!---------------------------
! simulation loop
!---------------------------
do n = 1,ntot
time = real(n)*dt
! call predictor
  call dyn(j,k,dx,g,eta,dt,dy,un,u,wet,v,vn,h,etan)

! updating including Shapiro filter
  call shapiro(j,k,wet,etan,eps,eta)

      call vernieuw(dt,dx,dy,eps,eta,etan,g,h,hmin,hzero,j,k,u,un,v,vn,wet)

! data output
! Only write once at the end
!if(mod(n,nout)==0)then
!  DO j = 1,ny
!    WRITE(10,'(101F12.6)')(eta(j,k),k=1,nx)
!    WRITE(20,'(101F12.6)')(h(j,k),k=1,nx)
!    WRITE(30,'(101F12.6)')(u(j,k),k=1,nx)
!    WRITE(40,'(101F12.6)')(v(j,k),k=1,nx)
!  END DO
!  WRITE(6,*)"Data output at time = ",time/60.0," min"
!endif
end do
!write results only once at the end....
do j = 0,ny+1
  write(10,'(101F12.6)')(eta(j,k),k=0,nx+1)
  write(20,'(101F12.6)')(h(j,k)  ,k=0,nx+1)
  write(30,'(101F12.6)')(u(j,k)  ,k=0,nx+1)
  write(40,'(101F12.6)')(v(j,k)  ,k=0,nx+1)
end do
write(6,*)"Data output at time = ",time/60.0," min"
end program wave2d


module numerical_analysis
    use unary
    use quantum
    implicit none
    real(8), parameter :: eps = 0.0000001
    real, parameter :: M = 9.109e-31, H = 1.054e-34, BR = 5.29e-11, max_step = 1000000
    real :: rs = 6
contains
    function f(x0, n_max, l_max) result (y)
        implicit none
        integer :: l_max, n_max
        real :: x0, y
        y = x0 * rs**2 - 1 + unary_function(0.0, rs, x0, n_max, l_max, BR)
    end function f

    function iterations_method(a1, b1, n_max, l_max) result(res)
        implicit none
        real :: a, b, f_a, f_b, xm, f_xm, a1, b1
        integer :: l_max, n_max, k = 0
        real :: x0, x1, iter = 0, res
        a = a1
        b= b1
        f_a = f(a, n_max, l_max)
        f_b = f(b, n_max, l_max)
        if(f_a * f_b >0) then
            print *, 'There is no root '
        end if
        do while (abs(b - a)>eps .and. k<max_step)
            xm = (a + b) / 2
            f_xm = f(xm, n_max, l_max)
            if(f_a * f_xm<=0) then
                b = xm
                f_b = f_xm
            else
                a = xm
                f_a = f_xm
            end if
            k = k + 1
        end do
        res = (a + b) / 2
        print *, 'Root is in the ' , res
    end function iterations_method
end module numerical_analysis


        subroutine iddr_rsvd(m,n,matvect,p1t,p2t,p3t,p4t,
     1                       matvec,p1,p2,p3,p4,krank,u,v,s,ier,w)
c
c       constructs a rank-krank SVD  u diag(s) v^T  approximating a,
c       where matvect is a routine which applies a^T
c       to an arbitrary vector, and matvec is a routine
c       which applies a to an arbitrary vector;
c       u is an m x krank matrix whose columns are orthonormal,
c       v is an n x krank matrix whose columns are orthonormal,
c       and diag(s) is a diagonal krank x krank matrix whose entries
c       are all nonnegative. This routine uses a randomized algorithm.
c
c       input:
c       m -- number of rows in a
c       n -- number of columns in a
c       matvect -- routine which applies the transpose
c                  of the matrix to be SVD'd
c                  to an arbitrary vector; this routine must have
c                  a calling sequence of the form
c
c                  matvect(m,x,n,y,p1t,p2t,p3t,p4t),
c
c                  where m is the length of x,
c                  x is the vector to which the transpose
c                  of the matrix is to be applied,
c                  n is the length of y,
c                  y is the product of the transposed matrix and x,
c                  and p1t, p2t, p3t, and p4t are user-specified
c                  parameters
c       p1t -- parameter to be passed to routine matvect
c       p2t -- parameter to be passed to routine matvect
c       p3t -- parameter to be passed to routine matvect
c       p4t -- parameter to be passed to routine matvect
c       matvec -- routine which applies the matrix to be SVD'd
c                 to an arbitrary vector; this routine must have
c                 a calling sequence of the form
c
c                 matvec(n,x,m,y,p1,p2,p3,p4),
c
c                 where n is the length of x,
c                 x is the vector to which the matrix is to be applied,
c                 m is the length of y,
c                 y is the product of the matrix and x,
c                 and p1, p2, p3, and p4 are user-specified parameters
c       p1 -- parameter to be passed to routine matvec
c       p2 -- parameter to be passed to routine matvec
c       p3 -- parameter to be passed to routine matvec
c       p4 -- parameter to be passed to routine matvec
c       krank -- rank of the SVD being constructed
c
c       output:
c       u -- matrix of orthonormal left singular vectors of a
c       v -- matrix of orthonormal right singular vectors of a
c       s -- array of singular values of a
c       ier -- 0 when the routine terminates successfully;
c              nonzero otherwise
c
c       work:
c       w -- must be at least (krank+1)*(2*m+4*n)+25*krank**2
c            real*8 elements long
c
c       _N.B._: The algorithm used by this routine is randomized.
c
        implicit none
        integer m,n,krank,lw,ilist,llist,iproj,lproj,icol,lcol,
     1          iwork,lwork,ier
        real*8 p1t,p2t,p3t,p4t,p1,p2,p3,p4,u(m,krank),v(n,krank),
     1         s(krank),w((krank+1)*(2*m+4*n)+25*krank**2)
        external matvect,matvec
c
c
c       Allocate memory in w.
c
        lw = 0
c
        ilist = lw+1
        llist = n
        lw = lw+llist
c
        iproj = lw+1
        lproj = krank*(n-krank)
        lw = lw+lproj
c
        icol = lw+1
        lcol = m*krank
        lw = lw+lcol
c
        iwork = lw+1
        lwork = (krank+1)*(m+3*n)+26*krank**2
        lw = lw+lwork
c
c
        call iddr_rsvd0(m,n,matvect,p1t,p2t,p3t,p4t,
     1                  matvec,p1,p2,p3,p4,krank,u,v,s,ier,
     2                  w(ilist),w(iproj),w(icol),w(iwork))
c
c
        return
        end
c
c
c
c


c     # ---------------------------------------------------
c     # QEXACT - returns exact solution to transport problem
c     #
c     #                q_t + \div (u(x,y,t) q) = 0
c     #
c     # Format :
c     #                qe = QEXACT(x,y,t,flow_flag)
c     #
c     # Input arguments :
c     #
c     # (x,y,t)     : Specifies the time and location where the exact
c     #               solution is desired.
c     # flow_flag   : Set to 0 for divergent-free flow fields and set to
c     #               1 for divergent flow fields.
c     #
c     #
c     # This routine requires three auxiliary functions :
c     #
c     #    call  velocity_components(x,y,t,u)
c     #
c     # which should compute velocity components (u(1),u(2)) in
c     # terms of spherical basis functions (not normalized)
c     #
c     # The user must also supply a divergence function
c     #
c     #         divu = map_divergence(x,y,t)
c     #
c     # that computes the divergence of the velocity field.
c     #
c     # Finally, the user needs to supply a function that computes the
c     # initial conditions
c     #
c     #              q0 = q0_init(x,y)
c     #
c     # The solution proceeds in two steps. If we are solving an
c     # divergent-free problem, we only need to evolve (x(t), y(t))
c     # backwards to the initial time.
c     #
c     # If we have a compressible problem, we first evolve (x(t),y(t))
c     # back to a starting location (x0,y0), and  then evolve x,y, and q
c     # from  the starting location back to final position.
c     # back to final position.
c     #
c     # --------------------------------------------------------

      double precision function qexact(x,y,tfinal,flow_flag)
      implicit none

      external qexact_rhs
      external solout

      double precision x,y,tfinal
      integer flow_flag

      double precision xc0, yc0, t0
      double precision q0_init, q0

      double precision sigma(4), rtol, atol
      integer itol, iout

      integer Nmax, lwork,nrdens, liwork
      parameter(Nmax=4, nrdens=0)
      parameter(lwork=8*Nmax+5*nrdens+21)
      parameter(liwork=nrdens+21)

      double precision work(lwork), rpar(1)
      integer iwork(liwork), ipar(2), idid

      double precision tol

      logical evolve_q

      integer i

c     # ------------------------------------------
c     # Numerical parameters
c     # ------------------------------------------
      itol = 0
      rtol = 1.d-14
      atol = 1.d-14
      iout = 0

      do i = 1,20
          work(i) = 0
          iwork(i) = 0
      enddo

c     # Evolve from t=t0 to t=tfinal
      t0 = 0

c     # Initial conditions for ODE
      sigma(1) = x
      sigma(2) = y

c     # Needed for backward trace
      rpar(1) = tfinal

c     # Tracing backwards
      ipar(1) = 0

c     # This traces the velocity field back to the origin.
      call dopri5(2,qexact_rhs,t0,sigma,tfinal,
     &            rtol,atol,itol,
     &            solout,iout, work,lwork,iwork,liwork,
     &            rpar,ipar,idid)

      if (idid .ne. 1) then
          write(6,*) 'DOPRI5 : idid .ne. 1'
          stop
      endif

c     # Initial position in [0,1]x[0,1]
      xc0 = sigma(1)
      yc0 = sigma(2)

c     # Get initial condition in computational coordinates (xc0,yc0)
      q0 =  q0_init(xc0,yc0)

c     # Evolve q along characteristics for divergent case
      evolve_q = flow_flag == 1
      if (evolve_q) then
c         # Variable coefficient case
c         # We now need to evolve q along with (x,y), starting from
c         # from (xc0,yc0)
          sigma(1) = xc0
          sigma(2) = yc0
          sigma(3) = q0

          do i = 1,20
              work(i) = 0
              iwork(i) = 0
          enddo

c         # Tracing forwards
          ipar(1) = 1

          t0 = 0
          call dopri5(3,qexact_rhs,t0,sigma,tfinal,
     &                rtol,atol,itol,
     &                solout,iout, work,lwork,iwork,liwork,
     &                rpar,ipar,idid)

          if (idid .ne. 1) then
              write(6,*) 'DOPRI5 : idid .ne. 1'
              stop
          endif

          tol = 1e-12
          if (abs(sigma(1)-x) .gt. tol) then
              write(6,*) 'qexact.f : Did not evolve x correctly'
              write(6,100) xc0,yc0
              write(6,100) x,y
              write(6,100) sigma(1), sigma(2)
              write(6,105) abs(x-sigma(1)), abs(y-sigma(2))
              stop
          endif
          if (abs(sigma(2)-y) .gt. tol) then
              write(6,*) 'qexact.f : Did not evolve y correctly'
              write(6,100) xc0,yc0
              write(6,100) x,y
              write(6,100) sigma(1), sigma(2)
              write(6,105) abs(x-sigma(1)), abs(y-sigma(2))
              stop
          endif
100       format(2F24.16)
105       format(2E24.4)

          qexact = sigma(3)
      else
          qexact = q0
      endif

      end

c     # ---------------------------------------------------------------
      subroutine solout(nr,xold,x,y,n,con,icomp,nd,rpar,ipar,irtrn)
      dimension y(n),con(5*nd),icomp(nd)

c     # Dummy routine

      end

      subroutine qexact_rhs(n,t,sigma,f,rpar,ipar)
      implicit none

      integer n, ipar(1)
      double precision t, sigma(n), f(n), rpar(1)
      double precision x,y, u(2), tt, tfinal
      double precision q, divu, map_divergence
      integer idir

      idir = ipar(1)

      x = sigma(1)
      y = sigma(2)

      if (idir .eq. 0) then
          tfinal = rpar(1)
          tt = tfinal - t
      else
          tt = t
      endif

      call velocity_components_cart(x,y,tt,u)

      if (idir .eq. 0) then
c         # We are tracing back to initial position
          f(1) = -u(1)
          f(2) = -u(2)
      else
c         # We are evolving q along characteristics starting
c         # from initial position found above
          q = sigma(3)
          divu = map_divergence(x,y,t)

          f(1) = u(1)
          f(2) = u(2)
          f(3) = -divu*q
      endif
      end


*> \brief \b SPTT01
*
*  =========== DOCUMENTATION ===========
*
* Online html documentation available at
*            http://www.netlib.org/lapack/explore-html/
*
*  Definition:
*  ===========
*
*       SUBROUTINE SPTT01( N, D, E, DF, EF, WORK, RESID )
*
*       .. Scalar Arguments ..
*       INTEGER            N
*       REAL               RESID
*       ..
*       .. Array Arguments ..
*       REAL               D( * ), DF( * ), E( * ), EF( * ), WORK( * )
*       ..
*
*
*> \par Purpose:
*  =============
*>
*> \verbatim
*>
*> SPTT01 reconstructs a tridiagonal matrix A from its L*D*L'
*> factorization and computes the residual
*>    norm(L*D*L' - A) / ( n * norm(A) * EPS ),
*> where EPS is the machine epsilon.
*> \endverbatim
*
*  Arguments:
*  ==========
*
*> \param[in] N
*> \verbatim
*>          N is INTEGTER
*>          The order of the matrix A.
*> \endverbatim
*>
*> \param[in] D
*> \verbatim
*>          D is REAL array, dimension (N)
*>          The n diagonal elements of the tridiagonal matrix A.
*> \endverbatim
*>
*> \param[in] E
*> \verbatim
*>          E is REAL array, dimension (N-1)
*>          The (n-1) subdiagonal elements of the tridiagonal matrix A.
*> \endverbatim
*>
*> \param[in] DF
*> \verbatim
*>          DF is REAL array, dimension (N)
*>          The n diagonal elements of the factor L from the L*D*L'
*>          factorization of A.
*> \endverbatim
*>
*> \param[in] EF
*> \verbatim
*>          EF is REAL array, dimension (N-1)
*>          The (n-1) subdiagonal elements of the factor L from the
*>          L*D*L' factorization of A.
*> \endverbatim
*>
*> \param[out] WORK
*> \verbatim
*>          WORK is REAL array, dimension (2*N)
*> \endverbatim
*>
*> \param[out] RESID
*> \verbatim
*>          RESID is REAL
*>          norm(L*D*L' - A) / (n * norm(A) * EPS)
*> \endverbatim
*
*  Authors:
*  ========
*
*> \author Univ. of Tennessee
*> \author Univ. of California Berkeley
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
*> \date November 2011
*
*> \ingroup single_lin
*
*  =====================================================================
      SUBROUTINE SPTT01( N, D, E, DF, EF, WORK, RESID )
*
*  -- LAPACK test routine (version 3.4.0) --
*  -- LAPACK is a software package provided by Univ. of Tennessee,    --
*  -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
*     November 2011
*
*     .. Scalar Arguments ..
      INTEGER            N
      REAL               RESID
*     ..
*     .. Array Arguments ..
      REAL               D( * ), DF( * ), E( * ), EF( * ), WORK( * )
*     ..
*
*  =====================================================================
*
*     .. Parameters ..
      REAL               ONE, ZERO
      PARAMETER          ( ONE = 1.0E+0, ZERO = 0.0E+0 )
*     ..
*     .. Local Scalars ..
      INTEGER            I
      REAL               ANORM, DE, EPS
*     ..
*     .. External Functions ..
      REAL               SLAMCH
      EXTERNAL           SLAMCH
*     ..
*     .. Intrinsic Functions ..
      INTRINSIC          ABS, MAX, REAL
*     ..
*     .. Executable Statements ..
*
*     Quick return if possible
*
      IF( N.LE.0 ) THEN
         RESID = ZERO
         RETURN
      END IF
*
      EPS = SLAMCH( 'Epsilon' )
*
*     Construct the difference L*D*L' - A.
*
      WORK( 1 ) = DF( 1 ) - D( 1 )
      DO 10 I = 1, N - 1
         DE = DF( I )*EF( I )
         WORK( N+I ) = DE - E( I )
         WORK( 1+I ) = DE*EF( I ) + DF( I+1 ) - D( I+1 )
   10 CONTINUE
*
*     Compute the 1-norms of the tridiagonal matrices A and WORK.
*
      IF( N.EQ.1 ) THEN
         ANORM = D( 1 )
         RESID = ABS( WORK( 1 ) )
      ELSE
         ANORM = MAX( D( 1 )+ABS( E( 1 ) ), D( N )+ABS( E( N-1 ) ) )
         RESID = MAX( ABS( WORK( 1 ) )+ABS( WORK( N+1 ) ),
     $           ABS( WORK( N ) )+ABS( WORK( 2*N-1 ) ) )
         DO 20 I = 2, N - 1
            ANORM = MAX( ANORM, D( I )+ABS( E( I ) )+ABS( E( I-1 ) ) )
            RESID = MAX( RESID, ABS( WORK( I ) )+ABS( WORK( N+I-1 ) )+
     $              ABS( WORK( N+I ) ) )
   20    CONTINUE
      END IF
*
*     Compute norm(L*D*L' - A) / (n * norm(A) * EPS)
*
      IF( ANORM.LE.ZERO ) THEN
         IF( RESID.NE.ZERO )
     $      RESID = ONE / EPS
      ELSE
         RESID = ( ( RESID / REAL( N ) ) / ANORM ) / EPS
      END IF
*
      RETURN
*
*     End of SPTT01
*
      END


      subroutine density(x,y,z,rho)

      implicit none

      real*8 x,y,z,rho

      real*8 w,w2,r,r2,h0,h

      real*8 zf

c***** calculate some distances for use in setting up density
c***** structure. Note that distances are in units of xmax, ymax, and zmax
c***** as called from the loop over cells in gridset.f
      w2=x*x+y*y
      w=sqrt(w2)
      r2=w2+z*z
      r=sqrt(r2)

c***** Set up uniform density sphere within the grid
      if(r.gt.1.) then
        rho=0.
      else
        rho=1.
      endif

      return
      end


      program sssimp
c
c     This example program is intended to illustrate the
c     simplest case of using ARPACK in considerable detail.
c     This code may be used to understand basic usage of ARPACK
c     and as a template for creating an interface to ARPACK.
c
c     This code shows how to use ARPACK to find a few eigenvalues
c     (lambda) and corresponding eigenvectors (x) for the standard
c     eigenvalue problem:
c
c                        A*x = lambda*x
c
c     where A is an n by n real symmetric matrix.
c
c     The main points illustrated here are
c
c        1) How to declare sufficient memory to find NEV
c           eigenvalues of largest magnitude.  Other options
c           are available.
c
c        2) Illustration of the reverse communication interface
c           needed to utilize the top level ARPACK routine SSAUPD
c           that computes the quantities needed to construct
c           the desired eigenvalues and eigenvectors(if requested).
c
c        3) How to extract the desired eigenvalues and eigenvectors
c           using the ARPACK routine SSEUPD.
c
c     The only thing that must be supplied in order to use this
c     routine on your problem is to change the array dimensions
c     appropriately, to specify WHICH eigenvalues you want to compute
c     and to supply a matrix-vector product
c
c                         w <-  Av
c
c     in place of the call to AV( ) below.
c
c     Once usage of this routine is understood, you may wish to explore
c     the other available options to improve convergence, to solve generalized
c     problems, etc.  Look at the file ex-sym.doc in DOCUMENTS directory.
c     This codes implements
c
c\Example-1
c     ... Suppose we want to solve A*x = lambda*x in regular mode,
c         where A is derived from the central difference discretization
c         of the 2-dimensional Laplacian on the unit square with
c         zero Dirichlet boundary condition.
c     ... OP = A  and  B = I.
c     ... Assume "call av (n,x,y)" computes y = A*x
c     ... Use mode 1 of SSAUPD.
c
c\BeginLib
c
c\Routines called:
c     ssaupd  ARPACK reverse communication interface routine.
c     sseupd  ARPACK routine that returns Ritz values and (optionally)
c             Ritz vectors.
c     snrm2   Level 1 BLAS that computes the norm of a vector.
c     saxpy   Level 1 BLAS that computes y <- alpha*x+y.
c
c\Author
c     Richard Lehoucq
c     Danny Sorensen
c     Chao Yang
c     Dept. of Computational &
c     Applied Mathematics
c     Rice University
c     Houston, Texas
c
c\SCCS Information: @(#)
c FILE: ssimp.F   SID: 2.6   DATE OF SID: 10/17/00   RELEASE: 2
c
c\Remarks
c     1. None
c
c\EndLib
c
c-----------------------------------------------------------------------
c
c     %------------------------------------------------------%
c     | Storage Declarations:                                |
c     |                                                      |
c     | The maximum dimensions for all arrays are            |
c     | set here to accommodate a problem size of            |
c     | N .le. MAXN                                          |
c     |                                                      |
c     | NEV is the number of eigenvalues requested.          |
c     |     See specifications for ARPACK usage below.       |
c     |                                                      |
c     | NCV is the largest number of basis vectors that will |
c     |     be used in the Implicitly Restarted Arnoldi      |
c     |     Process.  Work per major iteration is            |
c     |     proportional to N*NCV*NCV.                       |
c     |                                                      |
c     | You must set:                                        |
c     |                                                      |
c     | MAXN:   Maximum dimension of the A allowed.          |
c     | MAXNEV: Maximum NEV allowed.                         |
c     | MAXNCV: Maximum NCV allowed.                         |
c     %------------------------------------------------------%
c
      integer          maxn, maxnev, maxncv, ldv
      parameter       (maxn=256, maxnev=10, maxncv=25,
     $                 ldv=maxn )
c
c     %--------------%
c     | Local Arrays |
c     %--------------%
c
      Real
     &                 v(ldv,maxncv), workl(maxncv*(maxncv+8)),
     &                 workd(3*maxn), d(maxncv,2), resid(maxn),
     &                 ax(maxn)
      logical          select(maxncv)
      integer          iparam(11), ipntr(11)
c
c     %---------------%
c     | Local Scalars |
c     %---------------%
c
      character        bmat*1, which*2
      integer          ido, n, nev, ncv, lworkl, info, ierr,
     &                 j, nx, ishfts, maxitr, mode1, nconv
      logical          rvec
      Real
     &                 tol, sigma
c
c     %------------%
c     | Parameters |
c     %------------%
c
      Real
     &                 zero
      parameter        (zero = 0.0E+0)
c
c     %-----------------------------%
c     | BLAS & LAPACK routines used |
c     %-----------------------------%
c
      Real
     &                 snrm2
      external         snrm2, saxpy
c
c     %--------------------%
c     | Intrinsic function |
c     %--------------------%
c
      intrinsic        abs
c
c     %-----------------------%
c     | Executable Statements |
c     %-----------------------%
c
c     %-------------------------------------------------%
c     | The following include statement and assignments |
c     | initiate trace output from the internal         |
c     | actions of ARPACK.  See debug.doc in the        |
c     | DOCUMENTS directory for usage.  Initially, the  |
c     | most useful information will be a breakdown of  |
c     | time spent in the various stages of computation |
c     | given by setting msaupd = 1.                    |
c     %-------------------------------------------------%
c
      include 'debug.h'
      ndigit = -3
      logfil = 6
      msgets = 0
      msaitr = 0
      msapps = 0
      msaupd = 1
      msaup2 = 0
      mseigt = 0
      mseupd = 0
c
c     %-------------------------------------------------%
c     | The following sets dimensions for this problem. |
c     %-------------------------------------------------%
c
      nx = 10
      n = nx*nx
c
c     %-----------------------------------------------%
c     |                                               |
c     | Specifications for ARPACK usage are set       |
c     | below:                                        |
c     |                                               |
c     |    1) NEV = 4  asks for 4 eigenvalues to be   |
c     |       computed.                               |
c     |                                               |
c     |    2) NCV = 20 sets the length of the Arnoldi |
c     |       factorization                           |
c     |                                               |
c     |    3) This is a standard problem              |
c     |         (indicated by bmat  = 'I')            |
c     |                                               |
c     |    4) Ask for the NEV eigenvalues of          |
c     |       largest magnitude                       |
c     |         (indicated by which = 'LM')           |
c     |       See documentation in SSAUPD for the     |
c     |       other options SM, LA, SA, LI, SI.       |
c     |                                               |
c     | Note: NEV and NCV must satisfy the following  |
c     | conditions:                                   |
c     |              NEV <= MAXNEV                    |
c     |          NEV + 1 <= NCV <= MAXNCV             |
c     %-----------------------------------------------%
c
      nev   = 4
      ncv   = 20
      bmat  = 'I'
      which = 'LM'
c
      if ( n .gt. maxn ) then
         print *, ' ERROR with _SSIMP: N is greater than MAXN '
         go to 9000
      else if ( nev .gt. maxnev ) then
         print *, ' ERROR with _SSIMP: NEV is greater than MAXNEV '
         go to 9000
      else if ( ncv .gt. maxncv ) then
         print *, ' ERROR with _SSIMP: NCV is greater than MAXNCV '
         go to 9000
      end if
c
c     %-----------------------------------------------------%
c     |                                                     |
c     | Specification of stopping rules and initial         |
c     | conditions before calling SSAUPD                    |
c     |                                                     |
c     | TOL  determines the stopping criterion.             |
c     |                                                     |
c     |      Expect                                         |
c     |           abs(lambdaC - lambdaT) < TOL*abs(lambdaC) |
c     |               computed   true                       |
c     |                                                     |
c     |      If TOL .le. 0,  then TOL <- macheps            |
c     |           (machine precision) is used.              |
c     |                                                     |
c     | IDO  is the REVERSE COMMUNICATION parameter         |
c     |      used to specify actions to be taken on return  |
c     |      from SSAUPD. (See usage below.)                |
c     |                                                     |
c     |      It MUST initially be set to 0 before the first |
c     |      call to SSAUPD.                                |
c     |                                                     |
c     | INFO on entry specifies starting vector information |
c     |      and on return indicates error codes            |
c     |                                                     |
c     |      Initially, setting INFO=0 indicates that a     |
c     |      random starting vector is requested to         |
c     |      start the ARNOLDI iteration.  Setting INFO to  |
c     |      a nonzero value on the initial call is used    |
c     |      if you want to specify your own starting       |
c     |      vector (This vector must be placed in RESID.)  |
c     |                                                     |
c     | The work array WORKL is used in SSAUPD as           |
c     | workspace.  Its dimension LWORKL is set as          |
c     | illustrated below.                                  |
c     |                                                     |
c     %-----------------------------------------------------%
c
      lworkl = ncv*(ncv+8)
      tol = zero
      info = 0
      ido = 0
c
c     %---------------------------------------------------%
c     | Specification of Algorithm Mode:                  |
c     |                                                   |
c     | This program uses the exact shift strategy        |
c     | (indicated by setting PARAM(1) = 1).              |
c     | IPARAM(3) specifies the maximum number of Arnoldi |
c     | iterations allowed.  Mode 1 of SSAUPD is used     |
c     | (IPARAM(7) = 1). All these options can be changed |
c     | by the user. For details see the documentation in |
c     | SSAUPD.                                           |
c     %---------------------------------------------------%
c
      ishfts = 1
      maxitr = 300
      mode1 = 1
c
      iparam(1) = ishfts
c
      iparam(3) = maxitr
c
      iparam(7) = mode1
c
c     %------------------------------------------------%
c     | M A I N   L O O P (Reverse communication loop) |
c     %------------------------------------------------%
c
 10   continue
c
c        %---------------------------------------------%
c        | Repeatedly call the routine SSAUPD and take |
c        | actions indicated by parameter IDO until    |
c        | either convergence is indicated or maxitr   |
c        | has been exceeded.                          |
c        %---------------------------------------------%
c
         call ssaupd ( ido, bmat, n, which, nev, tol, resid,
     &                 ncv, v, ldv, iparam, ipntr, workd, workl,
     &                 lworkl, info )
c
         if (ido .eq. -1 .or. ido .eq. 1) then
c
c           %--------------------------------------%
c           | Perform matrix vector multiplication |
c           |              y <--- OP*x             |
c           | The user should supply his/her own   |
c           | matrix vector multiplication routine |
c           | here that takes workd(ipntr(1)) as   |
c           | the input, and return the result to  |
c           | workd(ipntr(2)).                     |
c           %--------------------------------------%
c
            call av (nx, workd(ipntr(1)), workd(ipntr(2)))
c
c           %-----------------------------------------%
c           | L O O P   B A C K to call SSAUPD again. |
c           %-----------------------------------------%
c
            go to 10
c
         end if
c
c     %----------------------------------------%
c     | Either we have convergence or there is |
c     | an error.                              |
c     %----------------------------------------%
c
      if ( info .lt. 0 ) then
c
c        %--------------------------%
c        | Error message. Check the |
c        | documentation in SSAUPD. |
c        %--------------------------%
c
         print *, ' '
         print *, ' Error with _saupd, info = ', info
         print *, ' Check documentation in _saupd '
         print *, ' '
c
      else
c
c        %-------------------------------------------%
c        | No fatal errors occurred.                 |
c        | Post-Process using SSEUPD.                |
c        |                                           |
c        | Computed eigenvalues may be extracted.    |
c        |                                           |
c        | Eigenvectors may be also computed now if  |
c        | desired.  (indicated by rvec = .true.)    |
c        |                                           |
c        | The routine SSEUPD now called to do this  |
c        | post processing (Other modes may require  |
c        | more complicated post processing than     |
c        | mode1.)                                   |
c        |                                           |
c        %-------------------------------------------%
c
          rvec = .true.
c
          call sseupd ( rvec, 'All', select, d, v, ldv, sigma,
     &         bmat, n, which, nev, tol, resid, ncv, v, ldv,
     &         iparam, ipntr, workd, workl, lworkl, ierr )
c
c         %----------------------------------------------%
c         | Eigenvalues are returned in the first column |
c         | of the two dimensional array D and the       |
c         | corresponding eigenvectors are returned in   |
c         | the first NCONV (=IPARAM(5)) columns of the  |
c         | two dimensional array V if requested.        |
c         | Otherwise, an orthogonal basis for the       |
c         | invariant subspace corresponding to the      |
c         | eigenvalues in D is returned in V.           |
c         %----------------------------------------------%
c
          if ( ierr .ne. 0) then
c
c            %------------------------------------%
c            | Error condition:                   |
c            | Check the documentation of SSEUPD. |
c            %------------------------------------%
c
             print *, ' '
             print *, ' Error with _seupd, info = ', ierr
             print *, ' Check the documentation of _seupd. '
             print *, ' '
c
          else
c
             nconv =  iparam(5)
             do 20 j=1, nconv
c
c               %---------------------------%
c               | Compute the residual norm |
c               |                           |
c               |   ||  A*x - lambda*x ||   |
c               |                           |
c               | for the NCONV accurately  |
c               | computed eigenvalues and  |
c               | eigenvectors.  (iparam(5) |
c               | indicates how many are    |
c               | accurate to the requested |
c               | tolerance)                |
c               %---------------------------%
c
                call av(nx, v(1,j), ax)
                call saxpy(n, -d(j,1), v(1,j), 1, ax, 1)
                d(j,2) = snrm2(n, ax, 1)
                d(j,2) = d(j,2) / abs(d(j,1))
c
 20          continue
c
c            %-----------------------------%
c            | Display computed residuals. |
c            %-----------------------------%
c
             call smout(6, nconv, 2, d, maxncv, -6,
     &            'Ritz values and relative residuals')
          end if
c
c         %-------------------------------------------%
c         | Print additional convergence information. |
c         %-------------------------------------------%
c
          if ( info .eq. 1) then
             print *, ' '
             print *, ' Maximum number of iterations reached.'
             print *, ' '
          else if ( info .eq. 3) then
             print *, ' '
             print *, ' No shifts could be applied during implicit',
     &                ' Arnoldi update, try increasing NCV.'
             print *, ' '
          end if
c
          print *, ' '
          print *, ' _SSIMP '
          print *, ' ====== '
          print *, ' '
          print *, ' Size of the matrix is ', n
          print *, ' The number of Ritz values requested is ', nev
          print *, ' The number of Arnoldi vectors generated',
     &             ' (NCV) is ', ncv
          print *, ' What portion of the spectrum: ', which
          print *, ' The number of converged Ritz values is ',
     &               nconv
          print *, ' The number of Implicit Arnoldi update',
     &             ' iterations taken is ', iparam(3)
          print *, ' The number of OP*x is ', iparam(9)
          print *, ' The convergence criterion is ', tol
          print *, ' '
c
      end if
c
c     %---------------------------%
c     | Done with program sssimp. |
c     %---------------------------%
c
 9000 continue
c
      end
c
c ------------------------------------------------------------------
c     matrix vector subroutine
c
c     The matrix used is the 2 dimensional discrete Laplacian on unit
c     square with zero Dirichlet boundary condition.
c
c     Computes w <--- OP*v, where OP is the nx*nx by nx*nx block
c     tridiagonal matrix
c
c                  | T -I          |
c                  |-I  T -I       |
c             OP = |   -I  T       |
c                  |        ...  -I|
c                  |           -I T|
c
c     The subroutine TV is called to computed y<---T*x.
c
      subroutine av (nx, v, w)
      integer           nx, j, lo, n2
      Real
     &                  v(nx*nx), w(nx*nx), one, h2
      parameter         ( one = 1.0E+0 )
c
      call tv(nx,v(1),w(1))
      call saxpy(nx, -one, v(nx+1), 1, w(1), 1)
c
      do 10 j = 2, nx-1
         lo = (j-1)*nx
         call tv(nx, v(lo+1), w(lo+1))
         call saxpy(nx, -one, v(lo-nx+1), 1, w(lo+1), 1)
         call saxpy(nx, -one, v(lo+nx+1), 1, w(lo+1), 1)
  10  continue
c
      lo = (nx-1)*nx
      call tv(nx, v(lo+1), w(lo+1))
      call saxpy(nx, -one, v(lo-nx+1), 1, w(lo+1), 1)
c
c     Scale the vector w by (1/h^2), where h is the mesh size
c
      n2 = nx*nx
      h2 = one / real((nx+1)*(nx+1))
      call sscal(n2, one/h2, w, 1)
      return
      end
c
c-------------------------------------------------------------------
      subroutine tv (nx, x, y)
c
      integer           nx, j
      Real
     &                  x(nx), y(nx), dd, dl, du
c
      Real
     &                  one, four
      parameter         (one = 1.0E+0, four = 4.0E+0)
c
c     Compute the matrix vector multiplication y<---T*x
c     where T is a nx by nx tridiagonal matrix with DD on the
c     diagonal, DL on the subdiagonal, and DU on the superdiagonal.
c
c
      dd  = four
      dl  = -one
      du  = -one
c
      y(1) =  dd*x(1) + du*x(2)
      do 10 j = 2,nx-1
         y(j) = dl*x(j-1) + dd*x(j) + du*x(j+1)
 10   continue
      y(nx) =  dl*x(nx-1) + dd*x(nx)
      return
      end


program test6
  use SparseKit
  implicit none
  type(Sparse) :: matrix
  type(Sparse) :: inverseMatrix
  type(Sparse) :: transposeMatrix
  type(Sparse) :: verification

  matrix = sparse( nnz = 12, rows = 4)

  call matrix%append( val =    4.d0, row = 1, col = 1)
  call matrix%append( val =    1.d0, row = 1, col = 2)
  call matrix%append( val =   60.d0, row = 1, col = 3)
  call matrix%append( val =   -5.d0, row = 1, col = 4)
  call matrix%append( val =  300.d0, row = 2, col = 2)
  call matrix%append( val = -675.d0, row = 2, col = 3)
  call matrix%append( val =  420.d0, row = 2, col = 4)
  call matrix%append( val =   60.d0, row = 3, col = 1)
  call matrix%append( val =    1.d0, row = 3, col = 3)
  call matrix%append( val =  -35.d0, row = 4, col = 1)
  call matrix%append( val =  420.d0, row = 4, col = 2)
  call matrix%append( val =  700.d0, row = 4, col = 4)

  call matrix%makeCRS

  print'(/,A)','Matrix'
  call matrix%printAll

  print'(/,A)','Transpose matrix'
  transposeMatrix = transpose(matrix)
  call transposeMatrix%printAll

  !print'(/,A)','Inverse GMRESD Algorithm  matrix'
  !inverseMatrix = inverseGMRESD(matrix)
  !call inverseMatrix%printAll

  !print'(/,A)','Verification'
  !verification = matrix*inverseMatrix
  !call verification%printAll

end program test6

tests/test6 - Inversa y transpuesta/main.f90


  subroutine gsf(            &
     maxm,   maxi,   u,      &
     plm_0,  plm_m,  plm_p)

!-----------------------------------------------------------
! Subroutine:
!   gsf
!
! Purpose:
!   Calculates the generalized spherical functions needed for the
!   expansion of the phase matrix.
!
! Output:
!
!   p(l,m,n) given as
!
!        plm_0 with n is 0
!        plm_m with n is negative
!        plm_p with n is positive
!
!   with l = 0,..,maxleg; m = l,..,maxleg.
!   For example, the first are given by
!
!    l   p(l,m,n)
!   -----------------------------------------------------
!    0   p(0,0,0)  = 1
!    1   p(1,0,0)  = costheta
!    2   p(2,0,0)  = 0.50*[3(costheta)**2 - 1]
!    0   p(0,0,+2) = p(0,0,-2) =  0
!    1   p(1,0,+2) = p(1,0,-2) =  0
!    2   p(2,0,+2) = p(2,0,-2) = -0.25*sqrt(6)*[1-(costheta)**2]
!    0   p(0,2,+2) = p(0,2,-2) =  0
!    1   p(1,2,+2) = p(0,2,-2) =  0
!    2   p(2,2,+2) = 0.25*[1 + 2costheta + costheta**2]
!    2   p(2,2,-2) = 0.25*[1 - 2costheta + costheta**2]
!    .     ...
!    .     etc.
!   -----------------------------------------------------
!
! Reference:
!   de Haan et al 1987, A&A 183, 371-391 for more details.
!-------------------------------------------------------------------

  implicit none

  integer,parameter::dp=selected_real_kind(8) !double precision

  integer,intent(in):: &
     maxm, &
     maxi

  real(kind=dp),intent(in):: &
     u(maxi) !all geometries

  integer::i,m,l,n,msmurf0,msmurf,istat

  real(kind=dp),dimension(:,:),allocatable:: &
     plm_p2, &
     plm_m2

  real(kind=dp):: &
     twom,   binfac, rootu, urootm, binf2, ln_bin2m, &
     bin2m2, fac1m,  fac1p, fac2,   fac3

! prevent crash for large m
  real(kind=dp):: &
     precisiondummy, &
     epslo,          &
     epshi

! generalized spherical functions
  real(kind=dp),intent(out):: &
     plm_0(0:maxm,0:maxm,maxi), &
     plm_m(0:maxm,0:maxm,maxi), &
     plm_p(0:maxm,0:maxm,maxi)

!----------------------------------------------------------------------------
!  Prevent crash for large m by truncating
!----------------------------------------------------------------------------

   epslo = tiny(precisiondummy)
   epshi = huge(precisiondummy)

!  overule, seting smaller range
   epslo = 1.d-100
   epshi = 1.d+100

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

   allocate( &
      plm_p2(0:maxm,0:maxm), &
      plm_m2(0:maxm,0:maxm), &
      stat=istat)

!----------------------------------------------------------------------------
! Start loop over angles
!----------------------------------------------------------------------------

  do i = 1,maxi

!    Initialization

     do m=0,maxm
        do l=0,maxm
           plm_0(m,l,i) = 0.d0
           plm_p2(m,l)  = 0.d0
           plm_m2(m,l)  = 0.d0
        enddo
     enddo

     msmurf0 = maxm
     msmurf  = maxm

     do m=0,maxm

!       Compute the binomial factor 2m above m needed in Eq.(77)
!       of de Haan et al. 87

        ln_bin2m = dlog(1.d0) !take ln to prevent blowing up
        do n=1,m
           ln_bin2m = ln_bin2m + dlog(dble(n+m)/dble(n))
        enddo
        if((exp(0.5d0*ln_bin2m).gt.epshi).and.(m.gt.2))then
           msmurf0 = m
           goto 123  ! if too large
        endif

        twom = 2.d0**(-dble(m))
        if((twom.lt.epslo).and.(m.gt.2))then
            msmurf0 = m  !if twom to small, break out of loop
            goto 123
        endif

        binfac = twom * exp(0.5d0*ln_bin2m)

        rootu = sqrt(abs(1.d0-u(i)**2))**dble(m)
        if((rootu.lt.epslo).and.(m.gt.2))then
            msmurf0 = m
            goto 123 ! if rootu to smal, break out of loop
        endif

!       Start with the generalized spherical function p^m_{m,0}
!       Eq. (77) and ignore factor i
        if(m.eq.0)then
           plm_0(m,m,i) = binfac
        else
           plm_0(m,m,i) = binfac*rootu
        endif

!!      If plm_0 too small, break out of loop
        if((abs(plm_0(m,m,i)).lt.epslo).and.(m.gt.2).and. &
            (u(i).ne.1.d0))then
             msmurf0 = m
             goto 123
        endif

     enddo
 123 continue

     msmurf0 = maxm

     do m=0,msmurf0
        do l = m,msmurf0-1
           if(l.ne.0)then
              plm_0(m,l+1,i) = (2.d0*dble(l)+1.d0)*u(i)*plm_0(m,l,i) - &
                                 sqrt(dble(l)**2-dble(m)**2)* &
                                   plm_0(m,l-1,i)
           else
              plm_0(m,l+1,i) = (2.d0*dble(l)+1.d0)*u(i)*plm_0(m,l,i)
           endif

           plm_0(m,l+1,i) = plm_0(m,l+1,i)/ &
                              sqrt(dble(l+1)**2-dble(m)**2)
        enddo
     enddo

!    Generalized spherical function p^2_{m,+2} and p^2_{m,-2}
!    for m = 0,1,2

     plm_p2(0,2) = -1.d0/4.d0*sqrt(6.d0)*(1.d0-u(i)**2)
     plm_m2(0,2) =  plm_p2(0,2)

     plm_p2(1,2) =  1.d0/2.d0*sqrt(1.d0-u(i)**2)*(1.d0+u(i))
     plm_m2(1,2) = -1.d0/2.d0*sqrt(1.d0-u(i)**2)*(1.d0-u(i))

     plm_p2(2,2) = -1.d0/4.d0*(1.d0+u(i))**2
     plm_m2(2,2) = -1.d0/4.d0*(1.d0-u(i))**2

     do m = 3,maxm

!       Compute the binomial factor 2m above m-2 needed in
!       Eq.(80) of de Haan et al. 87

        ln_bin2m = dlog(1.d0) !take ln to prevent blowing up
        do n=1,m
           ln_bin2m = ln_bin2m + dlog(dble(n+m)/dble(n))
        enddo
        if((exp(0.5d0*ln_bin2m).gt.epshi).and.(m.gt.2))then
            msmurf = m
            goto 234 ! if too large
        endif

        twom = 2.d0**(-1.d0*dble(m))
        if((twom.lt.epslo).and.(m.gt.2))then
            msmurf = m
            goto 234 ! if too large
        endif

        binfac =  twom*exp(0.5d0*ln_bin2m)

        bin2m2 =  exp(ln_bin2m)* &
                     dble(m)*dble(m-1)/(dble(m+1)*dble(m+2))
        binf2  = -twom*sqrt(bin2m2)

        rootu  =  sqrt(abs(1.d0-u(i)**2))
        urootm =  rootu**dble(m-2)
        if((urootm.lt.epslo).and.(m.gt.2))then
            msmurf = m
            goto 234
        endif

        plm_m2(m,m) = binf2*urootm*(1.d0-u(i))*(1.d0-u(i))
        plm_p2(m,m) = binf2*urootm*(1.d0+u(i))*(1.d0+u(i))

!!      If plm_m2 & plm_p2 too small, break out of loop
        if(((abs(plm_m2(m,m)).lt.epslo).or. &
             (abs(plm_p2(m,m)).lt.epslo)).and.(m.gt.2))then
               msmurf = m
               goto 234
        endif

     enddo
 234 continue

     if(u(i).eq.1.d0) msmurf = maxm

!!   write(*,*) i,msmurf,msmurf0

     do m=0,msmurf     !maxm
        do l = 0,msmurf-1 !maxm-1

           if(l.ge.max(m,2))then

              fac1m = (2.d0*dble(l)+1.d0)* &
                         (dble(l)*dble(l+1)*u(i)-2.d0*dble(m))
              fac1p = (2.d0*dble(l)+1.d0)* &
                         (dble(l)*dble(l+1)*u(i)+2.d0*dble(m))
              fac2  =  dble(l+1)*sqrt((dble(l)**2.d0-4.d0)* &
                          (dble(l)**2.d0-dble(m)**2.d0))
              fac3  =  1.d0/( &
                          (dble(l)*sqrt(dble(l+1)**2.d0-4.d0)* &
                            (dble(l+1)**2.d0-dble(m)**2.d0))  )

              plm_p2(m,l+1) = fac3*(fac1m*plm_p2(m,l)-fac2*plm_p2(m,l-1))
              plm_m2(m,l+1) = fac3*(fac1p*plm_m2(m,l)-fac2*plm_m2(m,l-1))

           endif

        enddo
     enddo

!    Finally, the general spherical function  p^2_{m,+} and  p^2_{m,-}

     do m = 0,msmurf
         do l = 0,msmurf
            plm_p(m,l,i) = 1.d0/2.d0*(plm_m2(m,l)+plm_p2(m,l))
            plm_m(m,l,i) = 1.d0/2.d0*(plm_m2(m,l)-plm_p2(m,l))
         enddo
      enddo

  enddo

  deallocate(plm_p2,plm_m2)

  return
  end subroutine gsf