MODULE Readmodel
  implicit none
  character(len=6), parameter :: measurement='angcor'
  real :: rmin=0.1, rmax=2
  integer, parameter :: nlrg=3
  character(len=10), parameter :: clrg(3)=(/'highpcen','rmcg','blrg'/)
  character(len=100), parameter :: infname='data/redmapper.angcor.phys.new.'
  character(len=100), parameter :: inf2h='data/2halo_angcor.dat'
  character(len=1), parameter :: ccov='y',genNFW='n'
  character(len=5), parameter :: offmodel='gauss'
  double precision, parameter :: pi=3.1415926535897932384
  double precision, parameter :: z=0.25,omegam=0.3,gconst=4.3e-9,rhoc=3e4/(8*pi*gconst),rhom=rhoc*omegam*(1+z)**3

  integer :: npow
  integer, parameter :: npowlim=100
  double precision :: powlg_r(npowlim),powlg_obs(npowlim,nlrg),powlg_cov(npowlim,nlrg,nlrg),powlg_twohalo(npowlim),powlg_cov_inv(npowlim,nlrg,nlrg)
  double precision, parameter :: delv=200,m_fid=1.4d14,rvir_fid=(3*m_fid/(4*pi*delv*rhom))**(1./3.)
  double precision, parameter :: dchi=200
  double precision, parameter :: munit=1e14

contains

  subroutine read_powlg_obsdata()

    implicit none

    integer :: i,j,j2,n
    real :: xt,yt,et,covt,skip
    double precision :: xp(256),yp(256),yp2(256)
    character :: inf*100

    powlg_cov=0.
    do j=1,nlrg
       i=0
       inf=infname(1:len_trim(infname))//clrg(j)
       open(1,file=inf,status='old')
       do n=1,npowlim
          read(1,*,end=9) xt,yt,et
          xt=xt*1e-3  ! change unit from kpc/h to Mpc/h
          if (xt>rmin.and.xt<rmax) then
             i=i+1
             powlg_r(i)=xt
             powlg_obs(i,j)=yt
             powlg_cov(i,j,j)=et*et
          endif
       enddo
9      close(1)
       npow=i
    enddo

    if (ccov=='y') then
       do j=1,nlrg
          do j2=1,j-1
             inf=infname(1:len_trim(infname))//clrg(j)(1:len_trim(clrg(j)))//'_vs_'//clrg(j2)(1:len_trim(clrg(j2)))
             write(*,*) inf
             open(1,file=inf,status='old')
             i=0
             do n=1,npowlim
                read(1,*,end=8) xt,covt
                xt=xt*1e-3
                if (xt>rmin.and.xt<rmax) then
                   i=i+1
                   powlg_cov(i,j,j2)=covt*sqrt(powlg_cov(i,j,j)*powlg_cov(i,j2,j2))
                   powlg_cov(i,j2,j)=powlg_cov(i,j,j2)
                endif
             enddo
8            close(1)
             if (i/=npow) then
                write(*,*) 'strange',i,npow
                stop
             endif
          enddo
       enddo
    endif

    do i=1,npow
       call calcinvarray(powlg_cov(i,1:nlrg,1:nlrg),powlg_cov_inv(i,1:nlrg,1:nlrg),nlrg)
    enddo

    j=0
    open(1,file=inf2h,status='old')
    do n=1,128
       read(1,*) xt,yt
       if (xt>rmin.and.xt<rmax) then
          j=j+1
          xp(j)=xt
          yp(j)=yt
       endif
    enddo
    close(1)
    call spline(xp,yp,j,1d30,1d30,yp2)

    do i=1,npow
       call splint(xp,yp,yp2,j,powlg_r(i),powlg_twohalo(i))
    enddo

!!! when 2-halo terms are neglected,
!    powlg_twohalo=0.

  end subroutine read_powlg_obsdata

  subroutine masspro_singlemass(m,c,soff,fsub,y,qcen,ycomp)

    implicit none

    integer :: i,j
    double precision, intent(in) :: m,soff,fsub,c,qcen  ! m in unit of 10^14M_sun/h
    double precision, intent(out) :: y(1:npow),ycomp(1:npow,1:3)
    double precision :: rhalo,rs,mnfwc,ycen,yoff,xoff,fac,x
    integer, parameter :: nmax=256
    double precision :: logrmin,logrmax,dlogr
    double precision, dimension(nmax) :: xc,yc,yc2,ys,ys2

! factor
    fac=1e-12 ! for changinge the unit of scale from Mpc^2 to pc^-2

! halo size
    rhalo=(3*m*munit/(4*pi*delv*rhom))**(1./3.)

! halo core size
    rs=rhalo/c

! integral factor
    mnfwc=log(1+c)-c/(1+c)

! smoothing scale normalized by rs
    xoff=soff/rs

    logrmin=-4.d0
    logrmax=4.d0
    dlogr=(logrmax-logrmin)/nmax
    do i=1,nmax
       xc(i)=10**(logrmin+(i-0.5)*dlogr)
       yc(i)=nfw2(xc(i))
       ys(i)=yc(i)
    enddo

    call fftlog_smooth(xc,yc,nmax,2.d0,-4.d0,4.d0,0.d0)
    call spline(xc,yc,nmax,1d30,1d30,yc2)
    call fftlog_smooth(xc,ys,nmax,2.d0,-4.d0,4.d0,xoff)
    call spline(xc,ys,nmax,1d30,1d30,ys2)

    do i=1,npow
       x=powlg_r(i)/rs
       call splint(xc,yc,yc2,nmax,x,ycen)
       call splint(xc,ys,ys2,nmax,x,yoff)
       ycomp(i,1)=fac*m*munit*qcen*ycen/mnfwc/(2*pi*rs*rs)
       ycomp(i,2)=fac*m*munit*(1-qcen)*yoff/mnfwc/(2*pi*rs*rs)
       ycomp(i,3)=fac*m*fsub*munit/pi/powlg_r(i)**2
       y(i)=ycomp(i,1)+ycomp(i,2)+ycomp(i,3)
    enddo

  end subroutine masspro_singlemass

  subroutine masspro_mdist(camp,soff,fsub,y,qcen,ycomp,ispec)

!!! take into account the variation of halo mass

    implicit none

    integer :: i,j,im
    integer, parameter :: immax=30
    integer, intent(in) :: ispec
    double precision, intent(in) :: soff,fsub,camp,qcen
    double precision, intent(out) :: y(1:npow),ycomp(1:npow,1:3)
    double precision :: rhalo,rs,mnfwc,ycen,yoff,xoff,fac,x,amp,damp,m,fprob,c,msub
    integer, parameter :: nmax=256
    double precision :: logrmin,logrmax,dlogr
    double precision, dimension(nmax) :: xc,yc,yc2,ys,ys2,xcin,ycin,ysin

    logrmin=-4.d0
    logrmax=4.d0
    dlogr=(logrmax-logrmin)/nmax
    do i=1,nmax
       xcin(i)=10**(logrmin+(i-0.5)*dlogr)
       ycin(i)=nfw2(xcin(i))
       ysin(i)=ycin(i)
    enddo

    xc=xcin
    yc=ycin
    call fftlog_smooth(xc,yc,nmax,2.d0,-4.d0,4.d0,0.d0)
    call spline(xc,yc,nmax,1d30,1d30,yc2)

! factor
    fac=1e-12 ! for changinge the unit of scale from Mpc^2 to pc^-2

    if (clrg(ispec)=='highpcen') then
       open(1,file='data/mdist_highpcen_cen.dat',status='old')
    else
       open(1,file='data/mdist_RMCGneBCG_cen.dat',status='old')
    endif

    ycomp=0.d0
    do im=1,immax

       read(1,*) m,c,fprob
       if (fprob<1e-5) cycle
       c=camp*c

! halo size
       rhalo=(3*m/(4*pi*delv*rhom))**(1./3.)

! halo core size
       rs=rhalo/c

! integral factor
       mnfwc=log(1+c)-c/(1+c)

! smoothing scale normalized by rs
       xoff=(soff*rhalo)/rs

       xc=xcin
       ys=ysin

       call fftlog_smooth(xc,ys,nmax,2.d0,-4.d0,4.d0,xoff)
       call spline(xc,ys,nmax,1d30,1d30,ys2)

       damp=fprob*fac*m/mnfwc/(2*pi*rs*rs)
       amp=amp+damp
       do i=1,npow
          x=powlg_r(i)/rs
          call splint(xc,yc,yc2,nmax,x,ycen)
          call splint(xc,ys,ys2,nmax,x,yoff)
          ycomp(i,1)=ycomp(i,1)+damp*qcen*ycen
          ycomp(i,2)=ycomp(i,2)+damp*(1-qcen)*yoff
          ycomp(i,3)=ycomp(i,3)+fprob*fac*msub/(pi*powlg_r(i)**2)
       enddo
    enddo
    close(1)

    do i=1,npow
       y(i)=ycomp(i,1)+ycomp(i,2)+ycomp(i,3)
    enddo

  end subroutine masspro_mdist

  subroutine crosscorr_single(amp,rs,soff,y,qcen,ycomp)

    implicit none

    integer :: i
    double precision, intent(in) :: amp,rs,soff,qcen  ! m in unit of 10^14M_sun/h
    double precision, intent(out) :: y(1:npow),ycomp(1:npow,1:3)
    double precision :: c,mnfwc,xoff,x,ycen,yoff
    integer, parameter :: nmax=256
    double precision :: logrmin,logrmax,dlogr
    double precision, dimension(nmax) :: xc,yc,yc2

! halo/subhalo core size
    c=rvir_fid/rs

! integral factor
    mnfwc=log(1+c)-c/(1+c)

! smoothing scale normalized by rs
    xoff=soff/rs

    logrmin=-4.d0
    logrmax=4.d0
    dlogr=(logrmax-logrmin)/nmax
    do i=1,nmax
       xc(i)=10**(logrmin+(i-0.5)*dlogr)
       yc(i)=nfw2(xc(i))
    enddo

    call fftlog_smooth(xc,yc,nmax,0.d0,-4.d0,4.d0,xoff)
    call spline(xc,yc,nmax,1d30,1d30,yc2)

    do i=1,npow
       x=powlg_r(i)/rs
       call splint(xc,yc,yc2,nmax,x,yoff)
       ycen=nfw2(x)

       ycen=3*ycen
       yoff=3*yoff

       ycomp(i,1)=amp*qcen*ycen
       ycomp(i,2)=amp*(1-qcen)*yoff
       ycomp(i,3)=0.d0
       y(i)=ycomp(i,1)+ycomp(i,2)+ycomp(i,3)
    enddo

  end subroutine crosscorr_single

  subroutine crosscorr_mdist(ampin,camp,soff,y,qcen,ycomp,ispec)

    implicit none

    integer :: i,im
    integer, intent(in) :: ispec
    integer, parameter :: immax=30
    double precision, intent(in) :: ampin,camp,soff,qcen  ! m in unit of 10^14M_sun/h
    double precision, intent(out) :: y(1:npow),ycomp(1:npow,1:3)
    double precision :: m,c,rs,mnfwc,xoff,x,ycen,yoff,rhalo,fprob,amp,damp
    double precision :: coff,mnfwc_off,rs_off
    integer, parameter :: nmax=256
    double precision, parameter :: delc=1.676
    double precision :: logrmin,logrmax,dlogr
    double precision, dimension(nmax) :: xc,yc,yc2,xcin,ycin,ycoff
    double precision :: rave,fsum

    logrmin=-4.d0
    logrmax=4.d0
    dlogr=(logrmax-logrmin)/nmax
    do i=1,nmax
       xcin(i)=10**(logrmin+(i-0.5)*dlogr)
       ycin(i)=nfw2(xcin(i))
    enddo

    if (clrg(ispec)=='highpcen') then
       open(1,file='data/mdist_highpcen_cen.dat',status='old')
    else
       open(1,file='data/mdist_RMCGneBCG_cen.dat',status='old')
    endif

    ycomp=0.d0
    amp=0.d0

    rave=0.d0
    fsum=0.d0

    do im=1,immax

       read(1,*) m,c,fprob
       if (fprob<1e-5) cycle
       c=camp*c

! halo size
       rhalo=(3*m/(4*pi*delv*rhom))**(1./3.)

! halo core size
       rs=rhalo/c

! integral factor
       mnfwc=log(1+c)-c/(1+c)

! smoothing scale normalized by rs

       xc=xcin
       yc=ycin

       if (offmodel=='nfw') then
          coff=soff*c
          if (coff<1.) coff=1.
!
          mnfwc_off=log(1+coff)-coff/(1+coff)
          rs_off=rhalo/coff
          xoff=rs_off/rs
!
          do i=1,nmax
             ycoff(i)=nfw2(xc(i)/xoff)*(coff**2/(8*pi*pi*mnfwc))
!             ycoff(i)=nfw2_truncate(xc(i)/xoff,coff)*(coff/(4*pi*pi*mnfwc))
          enddo
          call fftlog_smooth_nfw(xc,yc,ycoff,nmax,0.d0,-4.d0,4.d0)
       else
          xoff=(soff*rhalo)/rs
          call fftlog_smooth(xc,yc,nmax,0.d0,-4.d0,4.d0,xoff)
       endif
       call spline(xc,yc,nmax,1d30,1d30,yc2)

       rave=rave+soff*rhalo*fprob
       fsum=fsum+fprob

       damp=fprob*m/mnfwc/(6*pi*rs*rs)/rhom
       amp=amp+damp

       do i=1,npow
          x=powlg_r(i)/rs
          call splint(xc,yc,yc2,nmax,x,yoff)
          ycen=nfw2(x)

          ycen=3*ycen
          yoff=3*yoff

          ycomp(i,1)=ycomp(i,1)+damp*qcen*ycen
          ycomp(i,2)=ycomp(i,2)+damp*(1-qcen)*yoff
          ycomp(i,3)=ycomp(i,3)+0.d0
       enddo
    enddo
    close(1)

    rave=rave/fsum
!    write(*,*) rave

!    open(12,file='check_corr_nfw.dat',status='unknown')
!    do i=1,npow
!       write(12,*) powlg_r(i),ycomp(i,1)/qcen,ycomp(i,2)/(1-qcen)
!    enddo
!    close(12)
!    stop
!    write(*,*) amp,amp*ampin

    ycomp=ycomp/dchi*ampin

    do i=1,npow
       y(i)=ycomp(i,1)+ycomp(i,2)+ycomp(i,3)
    enddo

  end subroutine crosscorr_mdist

  subroutine crosscorr_mave(ampin,camp,soff,y,qcen,ycomp,ispec)

    implicit none

    integer :: i,im
    integer, intent(in) :: ispec
    integer, parameter :: immax=30
    double precision, intent(in) :: ampin,camp,soff,qcen  ! m in unit of 10^14M_sun/h
    double precision, intent(out) :: y(1:npow),ycomp(1:npow,1:3)
    double precision :: m,c,rs,mnfwc,xoff,x,ycen,yoff,rhalo,fprob,amp,damp,mt,ct
    integer, parameter :: nmax=256
    double precision, parameter :: delc=1.676
    double precision :: logrmin,logrmax,dlogr
    double precision, dimension(nmax) :: xc,yc,yc2,xcin,ycin

    logrmin=-4.d0
    logrmax=4.d0
    dlogr=(logrmax-logrmin)/nmax
    do i=1,nmax
       xcin(i)=10**(logrmin+(i-0.5)*dlogr)
       ycin(i)=nfw2(xcin(i))
    enddo

    if (clrg(ispec)=='highpcen') then
       open(1,file='data/mdist_highpcen_cen.dat',status='old')
    else
       open(1,file='data/mdist_RMCGneBCG_cen.dat',status='old')
    endif

    m=0.d0
    c=0.d0
    do im=1,immax
       read(1,*) mt,ct,fprob
       m=m+mt*fprob
       c=c+ct*fprob
    enddo
    close(1)

    ycomp=0.d0
    amp=0.d0

! halo size
    rhalo=(3*m/(4*pi*delv*rhom))**(1./3.)

! halo/subhalo core size
!       c=camp*gzmean**0.54*5.9*(delc/sigm(m))**(-0.35)
!    c=camp*7.85*(m/2e12)**-0.081*(1+z)**-0.71

! halo core size
    rs=rhalo/c

! integral factor
    mnfwc=log(1+c)-c/(1+c)

! smoothing scale normalized by rs
    xoff=(soff*rhalo)/rs

    xc=xcin
    yc=ycin

    call fftlog_smooth(xc,yc,nmax,0.d0,-4.d0,4.d0,xoff)
    call spline(xc,yc,nmax,1d30,1d30,yc2)

    damp=m/mnfwc/(6*pi*rs*rs)/rhom
    amp=amp+damp

    do i=1,npow
       x=powlg_r(i)/rs
       call splint(xc,yc,yc2,nmax,x,yoff)
       ycen=nfw2(x)

       ycen=3*ycen
       yoff=3*yoff

       ycomp(i,1)=ycomp(i,1)+damp*qcen*ycen
       ycomp(i,2)=ycomp(i,2)+damp*(1-qcen)*yoff
       ycomp(i,3)=ycomp(i,3)+0.d0
    enddo

    ycomp=ycomp/dchi*ampin

    do i=1,npow
       y(i)=ycomp(i,1)+ycomp(i,2)+ycomp(i,3)
    enddo

  end subroutine crosscorr_mave

  subroutine masspro_genNFW(m,c,soff,fsub,y,qcen,ycomp,alpha,beta)

    implicit none

    integer :: i,j
    double precision, intent(in) :: m,soff,fsub,c,qcen,alpha,beta  ! m in unit of 10^14M_sun/h
    double precision, intent(out) :: y(1:npow),ycomp(1:npow,1:3)
    double precision :: rhalo,rs,mnfwc,ycen,yoff,xoff,fac,x
    integer, parameter :: nmax=256
    double precision :: logrmin,logrmax,dlogr
    double precision, dimension(nmax) :: xc,yc,yc2,ys,ys2

! factor
    fac=1e-12 ! for changinge the unit of scale from Mpc^2 to pc^-2

! halo size
    rhalo=(3*m*munit/(4*pi*delv*rhom))**(1./3.)

! halo core size
    rs=rhalo/c

! integral factor for generalized NFW profile
    call mnfwc_genNFW(alpha,beta,c,mnfwc)

! smoothing scale normalized by rs
    xoff=soff/rs

    logrmin=-4.d0
    logrmax=4.d0
    dlogr=(logrmax-logrmin)/nmax
    do i=1,nmax
       xc(i)=10**(logrmin+(i-0.5)*dlogr)
! projected generalized NFW profile
       yc(i)=projected_genNFW(alpha,beta,xc(i))
       ys(i)=yc(i)
    enddo

    call fftlog_smooth(xc,yc,nmax,2.d0,-4.d0,4.d0,0.d0)
    call spline(xc,yc,nmax,1d30,1d30,yc2)
    call fftlog_smooth(xc,ys,nmax,2.d0,-4.d0,4.d0,xoff)
    call spline(xc,ys,nmax,1d30,1d30,ys2)

    do i=1,npow
       x=powlg_r(i)/rs
       call splint(xc,yc,yc2,nmax,x,ycen)
       call splint(xc,ys,ys2,nmax,x,yoff)
       ycomp(i,1)=fac*m*munit*qcen*ycen/mnfwc/(2*pi*rs*rs)
       ycomp(i,2)=fac*m*munit*(1-qcen)*yoff/mnfwc/(2*pi*rs*rs)
       ycomp(i,3)=fac*m*fsub*munit/pi/powlg_r(i)**2
       y(i)=ycomp(i,1)+ycomp(i,2)+ycomp(i,3)
    enddo

  end subroutine masspro_genNFW

  subroutine crosscorr_genNFW(amp,rs,soff,y,qcen,ycomp,alpha,beta)

    implicit none

    integer :: i
    double precision, intent(in) :: amp,rs,soff,qcen,alpha,beta
    double precision, intent(out) :: y(1:npow),ycomp(1:npow,1:3)
    double precision :: c,mnfwc,xoff,x,ycen,yoff
    integer, parameter :: nmax=256
    double precision :: logrmin,logrmax,dlogr
    double precision, dimension(nmax) :: xc,yc,yc2

! halo/subhalo core size
    c=rvir_fid/rs

! integral factor for generalized NFW
    call mnfwc_genNFW(alpha,beta,c,mnfwc)

! smoothing scale normalized by rs
    xoff=soff/rs

    logrmin=-4.d0
    logrmax=4.d0
    dlogr=(logrmax-logrmin)/nmax
    do i=1,nmax
       xc(i)=10**(logrmin+(i-0.5)*dlogr)
! projected generalized NFW profile
       yc(i)=projected_genNFW(alpha,beta,xc(i))
    enddo

    call fftlog_smooth(xc,yc,nmax,0.d0,-4.d0,4.d0,xoff)
    call spline(xc,yc,nmax,1d30,1d30,yc2)

    do i=1,npow
       x=powlg_r(i)/rs
       call splint(xc,yc,yc2,nmax,x,yoff)
! projected generalized NFW profile
       ycen=projected_genNFW(alpha,beta,x)
       ycomp(i,1)=amp*qcen*ycen/(2*pi*rs*rs)
       ycomp(i,2)=amp*(1-qcen)*yoff/(2*pi*rs*rs)
       ycomp(i,3)=0.d0
       y(i)=ycomp(i,1)+ycomp(i,2)+ycomp(i,3)
    enddo

  end subroutine crosscorr_genNFW

  subroutine mnfwc_genNFW(a,b,c,y)

    implicit none
    integer :: n
    integer, parameter :: nmax=100
    double precision, intent(in) :: a,b,c
    double precision :: x,y,dlnx
    double precision, parameter :: xmin=1d-2

    y=0.d0
    dlnx=log(c/xmin)/nmax
    do n=1,nmax
       x=xmin*exp(dlnx*(n-0.5))
       y=y+x**(3-b)/(1+x)**(a-b)*dlnx
    enddo

  end subroutine mnfwc_genNFW

  double precision function projected_genNFW(a,b,t)

    implicit none
    integer :: n
    integer, parameter :: nmax=100
    double precision, intent(in) :: a,b,t
    double precision :: r,z,dlnz,sigma,zmin=1.d-6,zmax=1.d6

    dlnz=log(zmax/zmin)/nmax
    sigma=0.d0
    do n=1,nmax
       z=zmin*exp(dlnz*(n-0.5))
       r=sqrt(t*t+z*z)
       sigma=sigma+z*dlnz/(r**b*(1+r)**(a-b))
    enddo
    projected_genNFW=sigma

  end function projected_genNFW

  double precision function nfw2int(x)

    implicit none
    double precision, intent(in) :: x

    if (abs(x-1)<1.e-8) then
       nfw2int=2*(1-log(2.))
    elseif (x<1) then
       nfw2int=2/x/x*(2/sqrt(1-x*x)*atanh(sqrt((1-x)/(1+x)))+log(x/2))
    else
       nfw2int=2/x/x*(2/sqrt(x*x-1)*atan(sqrt((x-1)/(x+1)))+log(x/2))
    endif
    nfw2int=nfw2int-nfw2(x)

  end function nfw2int

  double precision function nfw2int_truncate(x,c)

    implicit none
    double precision, intent(in) :: x,c
    double precision :: mnfwc

    if (abs(x-1)<1.e-8) then
       nfw2int_truncate=1/(3*(1+c))*((11*c+10)*sqrt(c*c-1)/(1+c)-6*c)+2*log((1+c)/(c+sqrt(c*c-1)))
    elseif (x<1) then
       nfw2int_truncate=1/(x*x*(1+c))*((2-x*x)*sqrt(c*c-x*x)/(1-x*x)-2*c)+2/x**2*log(x*(1+c)/(c+sqrt(c*c-x*x))) &
            +(2-3*x*x)/(x*x*(1-x*x)**1.5)*acosh((x*x+c)/(x*(1+c)))
    elseif (x>c) then
       mnfwc=log(1+c)-c/(1+c)
       nfw2int_truncate=2*mnfwc/x**2
    else
       nfw2int_truncate=1/(x*x*(1+c))*((2-x*x)*sqrt(c*c-x*x)/(1-x*x)-2*c)+2/x**2*log(x*(1+c)/(c+sqrt(c*c-x*x))) &
            -(2-3*x*x)/(x*x*(x*x-1)**1.5)*acos((x*x+c)/(x*(1+c)))
    endif

  end function nfw2int_truncate

  double precision function nfw2_truncate(x,c)

    implicit none
    double precision, intent(in) :: x,c

    if (abs(x-1)<1.e-8) then
       nfw2_truncate=sqrt(c*c-1)/(3*(1+c))*(1+1/(c+1))
    elseif (x<1) then
       nfw2_truncate=-sqrt(c*c-x*x)/(1-x*x)/(1+c)+(1-x*x)**(-1.5)*acosh((x*x+c)/(x*(1+c)))
    elseif (x<c) then
       nfw2_truncate=-sqrt(c*c-x*x)/(1-x*x)/(1+c)-(x*x-1)**(-1.5)*acos((x*x+c)/(x*(1+c)))
    else
       nfw2_truncate=0.
    endif

  end function nfw2_truncate

  double precision function nfw2(x)

    implicit none
    double precision, intent(in) :: x

    if (abs(x-1)<1.e-8) then
       nfw2=1./3.
    elseif (x<1) then
       nfw2=1/(x*x-1)*(1-2/sqrt(1-x*x)*atanh(sqrt((1-x)/(1+x))))
    else
       nfw2=1/(x*x-1)*(1-2/sqrt(x*x-1)*atan(sqrt((x-1)/(x+1))))
    endif

  end function nfw2

  double precision function acosh(x)

    double precision, intent(in) :: x
    acosh=log(x+sqrt(x*x-1))

  end function acosh

SUBROUTINE spline(x,y,n,yp1,ypn,y2)
  IMPLICIT NONE
  INTEGER, INTENT(in) :: n
  DOUBLE PRECISION, INTENT(in) :: yp1,ypn
  DOUBLE PRECISION, DIMENSION(n), INTENT(in) :: x,y
  DOUBLE PRECISION, DIMENSION(n), INTENT(out) :: y2
  INTEGER, parameter :: NMAX=1500
  INTEGER :: i,k
  DOUBLE PRECISION :: p,qn,sig,un
  DOUBLE PRECISION, DIMENSION(NMAX) :: u
  if (yp1>.99e30) then
     y2(1)=0.
     u(1)=0.
  else
     y2(1)=-0.5
     u(1)=(3./(x(2)-x(1)))*((y(2)-y(1))/(x(2)-x(1))-yp1)
  endif
  do i=2,n-1
     sig=(x(i)-x(i-1))/(x(i+1)-x(i-1))
     p=sig*y2(i-1)+2.
     y2(i)=(sig-1.)/p
     u(i)=(6.*((y(i+1)-y(i))/(x(i+1)-x(i))-(y(i)-y(i-1))/(x(i)-x(i-1))) &
          /(x(i+1)-x(i-1))-sig*u(i-1))/p
  enddo
  if (ypn>.99e30) then
     qn=0.
     un=0.
  else
     qn=0.5
     un=(3./(x(n)-x(n-1)))*(ypn-(y(n)-y(n-1))/(x(n)-x(n-1)))
  endif
  y2(n)=(un-qn*u(n-1))/(qn*y2(n-1)+1.)
  do k=n-1,1,-1
     y2(k)=y2(k)*y2(k+1)+u(k)
  enddo

END SUBROUTINE spline

! *********************************************************************
SUBROUTINE splint(xa,ya,y2a,n,x,y)
! *********************************************************************
  IMPLICIT NONE
  INTEGER, INTENT(in) :: n
  DOUBLE PRECISION, INTENT(in) :: x
  DOUBLE PRECISION, INTENT(in), DIMENSION(n) :: xa, y2a, ya
  DOUBLE PRECISION, INTENT(out) :: y
  INTEGER :: k,khi,klo
  DOUBLE PRECISION :: a,b,h

  klo=1
  khi=n
  do
     k=(khi+klo)/2
     if(xa(k)>x)then
        khi=k
     else
        klo=k
     endif
     if (khi-klo<=1) exit
  end do
  h=xa(khi)-xa(klo)
  if (h==0.) then
     write(*,*) 'bad xa input in splint'
     stop
  endif
  a=(xa(khi)-x)/h
  b=(x-xa(klo))/h
  y=a*ya(klo)+b*ya(khi)+((a**3-a)*y2a(klo)+(b**3-b)*y2a(khi))*(h**2)/6.

END SUBROUTINE splint

subroutine calcinvarray(covorg,incov,nmax)

!     read the data of cov(nmax,nmax)
!     and output their inversed array incov(nmax,nmax)
!      format of array is
!          1, 1, array(1,1)
!          2, 1, array(2,1)
!          3, 1, array(3,1)
!               ...
!          1, 2, array(1,2)
!          2, 2, array(2,2)
!               ...
!          nmax-1,nmax,array(nmax-1,nmax)
!          nmax,nmax,array(nmax,nmax)
!
!      data type of array is real*8
!
  implicit none

  integer, intent(in) ::  nmax
  double precision, intent(in) :: covorg(nmax,nmax)
  double precision, intent(out) :: incov(nmax,nmax)
  double precision :: cov(nmax,nmax)
  integer ::  k, nx, ny, indx(nmax)
  double precision :: d, col(nmax)

  cov=covorg
  call ludcmp(cov,nmax,nmax,indx,d)
  do ny=1,nmax
     col=0.d0
     col(ny)=1.d0
     call lubksb(cov,nmax,nmax,indx,col)
     do nx=1,nmax
        incov(nx,ny)=col(nx)
     enddo
  enddo

end subroutine calcinvarray

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

SUBROUTINE ludcmp(a,n,np,indx,d)
  IMPLICIT NONE
  INTEGER, INTENT(IN) :: n, np
  INTEGER, INTENT(OUT) :: indx(n)
  INTEGER, PARAMETER :: NMAX=1300
  DOUBLE PRECISION, INTENT(OUT) :: d
  DOUBLE PRECISION, INTENT(INOUT) :: a(np,np)
  DOUBLE PRECISION, PARAMETER :: TINY=1.0d-20
  INTEGER :: i,imax,j,k
  DOUBLE PRECISION :: aamax,dum,sum,vv(NMAX)

  d=1.
  do i=1,n
     aamax=0.d0
     do j=1,n
        if (abs(a(i,j))>aamax) aamax=abs(a(i,j))
     enddo
     if (aamax==0.) then
        write(*,*) 'singular matrix in ludcmp'
        stop
     endif
     vv(i)=1./aamax
  enddo
  do j=1,n
     do i=1,j-1
        sum=a(i,j)
        do k=1,i-1
           sum=sum-a(i,k)*a(k,j)
        enddo
        a(i,j)=sum
     enddo
     aamax=0.
     do i=j,n
        sum=a(i,j)
        do k=1,j-1
           sum=sum-a(i,k)*a(k,j)
        enddo
        a(i,j)=sum
        dum=vv(i)*abs(sum)
        if (dum.ge.aamax) then
           imax=i
           aamax=dum
        endif
     enddo
     if (j/=imax)then
        do k=1,n
           dum=a(imax,k)
           a(imax,k)=a(j,k)
           a(j,k)=dum
        enddo
        d=-d
        vv(imax)=vv(j)
     endif
     indx(j)=imax
     if (a(j,j)==0.) a(j,j)=TINY
     if (j/=n) then
        dum=1./a(j,j)
        do i=j+1,n
           a(i,j)=a(i,j)*dum
        enddo
     endif
  enddo

END SUBROUTINE ludcmp

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

SUBROUTINE lubksb(a,n,np,indx,b)
  INTEGER, INTENT(IN) :: n,np
  INTEGER, INTENT(IN) :: indx(n)
  DOUBLE PRECISION, INTENT(IN) :: a(np,np)
  DOUBLE PRECISION, INTENT(INOUT) :: b(n)
  INTEGER :: i,ii,j,ll
  DOUBLE PRECISION :: sum

  ii=0
  do i=1,n
     ll=indx(i)
     sum=b(ll)
     b(ll)=b(i)
     if (ii/=0) then
        do j=ii,i-1
           sum=sum-a(i,j)*b(j)
        enddo
     else if (sum/=0.) then
        ii=i
     endif
     b(i)=sum
  enddo
  do i=n,1,-1
     sum=b(i)
     do j=i+1,n
        sum=sum-a(i,j)*b(j)
     enddo
     b(i)=sum/a(i,i)
  enddo

END SUBROUTINE lubksb

subroutine fftlog_smooth(x,y,n,mu,logrmin,logrmax,rad)

  implicit none

!!!  n must be smaller than NMAX
  integer :: n
  integer, parameter :: NMAX=4096
  integer :: lnblnk
  character :: inf*100,outf*100
  integer :: dir,i,kropt
  logical :: ok
  double precision :: x(n),y(n),rad,yorg
  double precision :: dlnr,dlogr,k,kr,logkc,logrc,logrmax,logrmin,nc,q,r,rk,mu
  double precision :: wsave(2*NMAX+3*(NMAX/2)+19)
  real :: criden,angdis
  character :: type*1,comp*1

  q=0.d0
  kr=1.d0
  kropt=2

! forward transform

  dir=1

  logrc=(logrmin+logrmax)/2.d0

  nc=dble(n+1)/2.d0
  dlogr=(logrmax-logrmin)/n
  dlnr=dlogr*log(10.d0)

  do i=1,n
     y(i)=y(i)*x(i)
  enddo

  call fhti(n,0.d0,q,dlnr,kr,kropt,wsave,ok)
  if (.not.ok) then
     write(*,*) 'strange'
     stop
  endif
  logkc=log10(kr)-logrc
  call fht(n,y,dir,wsave)

! add Gaussian window functions
  do i=1,n
     x(i)=10.d0**(logkc+(i-nc)*dlogr)
     y(i)=y(i)*exp(-0.5*(rad*x(i))**2)
  enddo

!     backward transform

  q=0.d0
  kr=1.d0
  kropt=2

  dir=-1

  call fhti(n,mu,q,dlnr,kr,kropt,wsave,ok)
  if (.not.ok) then
     write(*,*) 'strange'
     stop
  endif
  logrc=log10(kr)-logkc
  call fht(n,y,dir,wsave)

  do i=1,n
     x(i)=10.d0**(logrc+(i-nc)*dlogr)
     y(i)=y(i)/x(i)
  enddo

end subroutine fftlog_smooth

subroutine fftlog_smooth_nfw(x,y,yoff,n,mu,logrmin,logrmax)

  implicit none

!!!  n must be smaller than NMAX
  integer :: n
  integer, parameter :: NMAX=4096
  integer :: lnblnk
  character :: inf*128,outf*128
  integer :: dir,i,kropt
  logical :: ok
  double precision :: x(n),y(n),yoff(n),filter
  double precision :: dlnr,dlogr,k,kr,logkc,logrc,logrmax,logrmin,nc,q,r,rk,mu,qoff
  double precision :: wsave(2*NMAX+3*(NMAX/2)+19),wsave_off(2*NMAX+3*(NMAX/2)+19)
  real :: criden,angdis
  character :: type*1,comp*1

  q=0.d0
  kr=1.d0
  kropt=2

!  forward transform

  dir=1

  logrc=(logrmin+logrmax)/2.d0

  nc=dble(n+1)/2.d0
  dlogr=(logrmax-logrmin)/n
  dlnr=dlogr*log(10.d0)

  do i=1,n
     y(i)=y(i)*x(i)
     yoff(i)=yoff(i)*x(i)
  enddo

  call fhti(n,0.d0,q,dlnr,kr,kropt,wsave,ok)
  call fhti(n,0.d0,qoff,dlnr,kr,kropt,wsave_off,ok)
  if (.not.ok) then
     write(*,*) 'strange'
     stop
  endif
  logkc=log10(kr)-logrc
  call fht(n,y,dir,wsave)
  call fht(n,yoff,dir,wsave_off)

  do i=1,n
     x(i)=10.d0**(logkc+(i-nc)*dlogr)
     if (i<n/4) then
        filter=1
     else
        filter=(yoff(i)/x(i))/(yoff(n/4)/x(n/4))
     endif
     y(i)=y(i)*filter
  enddo

!     backward transform

  q=0.d0
  kr=1.d0
  kropt=2

  dir=-1

  call fhti(n,mu,q,dlnr,kr,kropt,wsave,ok)
  if (.not.ok) then
     write(*,*) 'strange'
     stop
  endif
  logrc=log10(kr)-logkc
  call fht(n,y,dir,wsave)

  do i=1,n
     x(i)=10.d0**(logrc+(i-nc)*dlogr)
     y(i)=y(i)/x(i)
  enddo

end subroutine fftlog_smooth_nfw

end MODULE Readmodel


!***********************************/
!	Name:移動先の格子を補間するための補間データ提供元格子検索
!	Alias:OInterpolatedLocalGrid
!	Description:
!	Type:Geom,CellCenter
!	Input:Geom,CC
!	Output:CC%PrimitiveVariable
!	Note:1~3次元すべてに対応済み
!	Author:Akitaka Toyota
!	Date:2017.11.16
!	Update:2017.11.16
!	Other:
!***********************************/
subroutine OInterpolateGlobalGrid(Geom,OSG,MG,UCC,CC)
    use StructVar_Mod
    use LoopVar_Mod
    implicit none

    type(Geometry), intent(inout) :: Geom
    type(OverSetGrid), intent(in) :: OSG
    type(MoveGrid), intent(in) :: MG
    type(CellCenter), intent(in) :: UCC
    type(CellCenter), intent(inout) :: CC

    double precision, allocatable :: SCellCoordinate(:),Moment(:)
    double precision :: InverseDistanceSum, InverseDistance
    integer :: iContent
    integer :: iGCell
    allocate(SCellCoordinate(3),Moment(5))

    iXmax = max(1,Geom%CellNumber(1))
    iYmax = max(1,Geom%CellNumber(2))
    iZmax = max(1,Geom%CellNumber(3))

    Geom%Interpolated= 0

    do iGCell=1, iXmax*iYmax*iZmax !Global格子のすべてのセルについて
        if(OSG%FrequencyDistribution(iGCell) /= 0) then !if the cell need to interpolate
            InverseDistanceSum = 0.0d0
            Moment = 0.0d0

            !この構造格子の座標は
            iCenterX = iGCell - int(iGCell/iXmax)*iXmax
            iCenterY = int(iGCell/iXmax)
            SCellCoordinate(1) = Geom%Bound(1,1) + 2.0d0 * Geom%Width(1,1,1) * (dble(iCenterX)-1.0d0)
            SCellCoordinate(2) = Geom%Bound(1,1) + 2.0d0 * Geom%Width(1,1,1) * (dble(iCenterY)-1.0d0)
            SCellCoordinate(3) = 0.0d0

            do iContent=1, OSG%FrequencyDistribution(iGCell)
                iAdjacentCell = OSG%RelatedS2U(iGCell,iContent)

                InverseDistance = 1.0d0/sqrt(sum((MG%NSR%C%NextCoordsInG(iAdjacentCell,1:3) - SCellCoordinate(1:3))**2))

                InverseDistanceSum = InverseDistanceSum + InverseDistance
                !(距離の逆数)*(物理量)!!(距離) 近いほど影響が大きい
                Moment = Moment + InverseDistance * UCC%ConservedQuantity(:,iAdjacentCell,1,1)
            end do

            CC%ConservedQuantity(1:3,iCenterX,iCenterY,1) = Moment(1:3)/InverseDistanceSum
            CC%ConservedQuantity(4,iCenterX,iCenterY,1) = Moment(5)/InverseDistanceSum
            Geom%Interpolated(iCenterX,iCenterY,1) = 1
        end if
    end do

return
end subroutine OInterpolateGlobalGrid


      FUNCTION GAMMLN(XX)
      REAL*8 COF(6),STP,HALF,ONE,FPF,X,TMP,SER
      DATA COF,STP/76.18009173D0,-86.50532033D0,24.01409822D0,
     *    -1.231739516D0,.120858003D-2,-.536382D-5,2.50662827465D0/
      DATA HALF,ONE,FPF/0.5D0,1.0D0,5.5D0/
      X=XX-ONE
      TMP=X+FPF
      TMP=(X+HALF)*LOG(TMP)-TMP
      SER=ONE
      DO 11 J=1,6
        X=X+ONE
        SER=SER+COF(J)/X
11    CONTINUE
      GAMMLN=TMP+LOG(STP*SER)
      RETURN
      END


! *********************************************************************
! Programme de calcul de matrice de scattering
! Couplage Grill Plasma avec differents cas poloidaux
! *********************************************************************
program coupl_plasma_version3
      ! Physics and mathematics constants
      Use aloha_constants
      ! Simulation configuration variables
      ! TODO : this module should not exist. It exists in replacement of the F77 "Common", but it makes
      ! the code quite complicated to follow...
      !       Common /err/ epsabs
      !       Common /nlim/ nlimit
      !       Common /dims/ b,z
      !       Common /idem/ bcte
      !       Common /onde/ k0
      !       Common /plasma/ X0,D0
      !       Common /integration/ max_nz
      Use aloha_config, Only : epsabs, nlimit, b, z, bcte, k0, X0, D0, max_nz, Gmax, Nmhm, Nmem
      ! aloha main routines
      Use aloha_sgrill

      Implicit None

      Integer       :: ios,i,j,intg,ni!,nlimit,nbgp!,q
      Integer       :: T_grill, D_guide_max
      Real(kind=wp) :: T_grill_r, D_guide_max_r

      ! JH 03/10/08 : Pour lire les donnees ascii, on a besoin d'utiliser des variables reelles.
      ! Lorsqu'il s'agit en réalité d'eniter, on devra les caster comme tels une fois les
      ! valeurs reelles lues.
      Real(kind=wp) :: Pg_r,Nmh_r,Nme_r
      Integer       :: Pg, Nmh, Nme
        !,Nmhgn,Nmegn,Nmheg,Nmhegn,prhe!,prhegn ! JH 17/04/2008 Integer->Real pour comp. F90
      !Integer :: Pgg(5),Nmhg(5),Nmeg(5),Nmhg1(5)!,prheg(5)
      Integer :: ok!,preg(5,60)!,prhg(5,60)

      Real(kind=wp) :: f,epsrel !k0,,epsabs
      Real(kind=wp) :: a!,b(60),z(60)!,bc!,b0!,e(60)!,ei!,ac
      Real(kind=wp) :: n0,nc,Dn!,D0,X0,max_nz

      Integer         , allocatable, dimension(:)   :: prh, pre
      Complex(kind=wp), allocatable, dimension(:,:) :: S, Spr
      Complex(kind=wp), allocatable, dimension(:,:) :: K_cpl
      Complex(kind=wp), allocatable, dimension(:,:) :: RZheg, RZhegpr

      Integer, parameter :: VERSION = 3

!       Open(10,File='par_grill.dat',Status='unknown',Form='formatted')
      Open(unit=10, file='par_grill.dat', status='old', form='formatted', action='read', position='rewind', iostat=ios) ! JH 17/04/2008 unknow->old
      if (ios /= 0) then
        write (*,*) "[ERROR] : erreur lecture fichier par_grill.dat"
        stop
      end if

      Read(10,*) Nmh_r
      Read(10,*) Nme_r
      Nmh = int(Nmh_r)! cast readed real variables into integer
      Nme = int(Nme_r)! cast readed real variables into integer
      Read(10,*) f
      Read(10,*) n0
      Read(10,*) Dn
      Read(10,*) Pg_r ! Nombre total de guides sur une ligne poloidale
      Pg = int(Pg_r)! cast readed real variables into integer
      Read(10,*) a
      Read(10,*) (b(i),i=1,Pg) ! Attention : la taille max de b,z est définie dans aloha_config (bouahhhh!!! c'est pas beau !)
        write(*,*) 'size(b)=',size(b)

      Read(10,*) (z(i),i=1,Pg)
      Read(10,*) T_grill_r
      Read(10,*) D_guide_max_r
      T_grill = int(T_grill_r)! cast readed real variables into integer
      D_guide_max = int(D_guide_max_r)! cast readed real variables into integer
      Read(10,*) epsrel
      Read(10,*) max_nz

      Rewind 10
      Close(10)

      ! copy read values to shared memory through aloha_config module variables :
      k0=2.*pi*f/cl
      D0=k0*n0/Dn
      nc=(2.*pi*f)**2*me*Eps0/qe**2
      X0=n0/nc
      Nmhm=Nmh
      Nmem=Nme

      ! TODO : intg is not use anymore
      intg=4 ! Mode d'integration numerique
      nlimit=0
      ni = 32
      epsabs=0.

      ! Initialisation des matrices
      allocate(    S((Nme+Nmh)*Pg,(Nme+Nmh)*Pg), stat=ok)
      allocate(K_cpl((Nme+Nmh)*Pg,(Nme+Nmh)*Pg), stat=ok)
      allocate(RZheg((Nme+Nmh)*Pg,(Nme+Nmh)*Pg), stat=ok)

      allocate(    Spr(Pg,Pg), stat=ok)
      allocate(RZhegpr(Pg,Pg), stat=ok)

      allocate(pre(Pg), prh(Pg), stat=ok)

      Call SMGrill(VERSION, intg,ni,epsrel,T_grill,D_guide_max, &
                    Nmh, Nme, Pg, a, prh, pre, &
                    S, RZheg, Spr, RZhegpr, K_cpl)

! ------------------------------------------------------
      ! Sauvegarde des resultats pour matlab
      write(*,*) "Sauvegarde des resultats..."

      Open(10,File='S_plasma.dat', Status='replace', Form='unformatted')

      Write(10) ((real(S(i,j))     ,i=1,(Nme+Nmh)*Pg), j=1,(Nme+Nmh)*Pg)
      Write(10) ((aimag(S(i,j))    ,i=1,(Nme+Nmh)*Pg), j=1,(Nme+Nmh)*Pg)
      Write(10) ((real(RZheg(i,j)) ,i=1,(Nme+Nmh)*Pg), j=1,(Nme+Nmh)*Pg)
      Write(10) ((aimag(RZheg(i,j)),i=1,(Nme+Nmh)*Pg), j=1,(Nme+Nmh)*Pg)
      Write(10) ((real(K_cpl(i,j)) ,i=1,(Nme+Nmh)*Pg), j=1,(Nme+Nmh)*Pg)
      Write(10) ((aimag(K_cpl(i,j)),i=1,(Nme+Nmh)*Pg), j=1,(Nme+Nmh)*Pg)

      Close(10)

      ! ecriture des resultats dans un fichier texte
      Open(20,File='S_plasma2.dat', Status='replace', Form='formatted')
      ! header
      write(20,*) '==================== ALOHA result file ===================='
      write(20,*) '\t\t S \t\t RZheg \t\t K_cpl '
      ! ecriture des resultats en colonnes
      do i=1,size(S,1)
        do j=1,size(S,2)
            write(20,*) S(i,j), RZheg(i,j), K_cpl(i,j)
        end do
      end do
      write(*,*) 'Premiers elements de la matrice S plasma S1j'
      write(*,*) S(1,1), S(1,2), S(1,3), S(1,4), S(1,5), S(1,6), S(1,7)

! i=1,(Nme+Nmh)*Pg), j=1,(Nme+Nmh)*Pg)
!       Write(20,*) ((RZheg(i,j),i=1,(Nme+Nmh)*Pg), j=1,(Nme+Nmh)*Pg)
!       Write(20,*) ((K_cpl(i,j),i=1,(Nme+Nmh)*Pg), j=1,(Nme+Nmh)*Pg)

      Close(20)

      Stop
end program coupl_plasma_version3
! Fin du programme principal


      SUBROUTINE SB04OD( REDUCE, TRANS, JOBD, M, N, A, LDA, B, LDB, C,
     $                   LDC, D, LDD, E, LDE, F, LDF, SCALE, DIF, P,
     $                   LDP, Q, LDQ, U, LDU, V, LDV, IWORK, DWORK,
     $                   LDWORK, INFO )
C
C     SLICOT RELEASE 5.7.
C
C     Copyright (c) 2002-2020 NICONET e.V.
C
C     PURPOSE
C
C     To solve for R and L one of the generalized Sylvester equations
C
C        A * R - L * B = scale * C )
C                                  )                                 (1)
C        D * R - L * E = scale * F )
C
C     or
C
C        A' * R + D' * L = scale * C    )
C                                       )                            (2)
C        R * B' + L * E' = scale * (-F) )
C
C     where A and D are M-by-M matrices, B and E are N-by-N matrices and
C     C, F, R and L are M-by-N matrices.
C
C     The solution (R, L) overwrites (C, F). 0 <= SCALE <= 1 is an
C     output scaling factor chosen to avoid overflow.
C
C     The routine also optionally computes a Dif estimate, which
C     measures the separation of the spectrum of the matrix pair (A,D)
C     from the spectrum of the matrix pair (B,E), Dif[(A,D),(B,E)].
C
C     ARGUMENTS
C
C     MODE PARAMETERS
C
C     REDUCE  CHARACTER*1
C             Indicates whether the matrix pairs (A,D) and/or (B,E) are
C             to be reduced to generalized Schur form as follows:
C             = 'R':  The matrix pairs (A,D) and (B,E) are to be reduced
C                     to generalized (real) Schur canonical form;
C             = 'A':  The matrix pair (A,D) only is to be reduced
C                     to generalized (real) Schur canonical form,
C                     and the matrix pair (B,E) already is in this form;
C             = 'B':  The matrix pair (B,E) only is to be reduced
C                     to generalized (real) Schur canonical form,
C                     and the matrix pair (A,D) already is in this form;
C             = 'N':  The matrix pairs (A,D) and (B,E) are already in
C                     generalized (real) Schur canonical form, as
C                     produced by LAPACK routine DGGES.
C
C     TRANS   CHARACTER*1
C             Indicates which of the equations, (1) or (2), is to be
C             solved as follows:
C             = 'N':  The generalized Sylvester equation (1) is to be
C                     solved;
C             = 'T':  The "transposed" generalized Sylvester equation
C                     (2) is to be solved.
C
C     JOBD    CHARACTER*1
C             Indicates whether the Dif estimator is to be computed as
C             follows:
C             = '1':  Only the one-norm-based Dif estimate is computed
C                     and stored in DIF;
C             = '2':  Only the Frobenius norm-based Dif estimate is
C                     computed and stored in DIF;
C             = 'D':  The equation (1) is solved and the one-norm-based
C                     Dif estimate is computed and stored in DIF;
C             = 'F':  The equation (1) is solved and the Frobenius norm-
C                     based Dif estimate is computed and stored in DIF;
C             = 'N':  The Dif estimator is not required and hence DIF is
C                     not referenced. (Solve either (1) or (2) only.)
C             JOBD is not referenced if TRANS = 'T'.
C
C     Input/Output Parameters
C
C     M       (input) INTEGER
C             The order of the matrices A and D and the number of rows
C             of the matrices C, F, R and L.  M >= 0.
C
C     N       (input) INTEGER
C             The order of the matrices B and E and the number of
C             columns of the matrices C, F, R and L.  N >= 0.
C             No computations are performed if N = 0 or M = 0, but SCALE
C             and DIF (if JOB <> 'N') are set to 1.
C
C     A       (input/output) DOUBLE PRECISION array, dimension (LDA,M)
C             On entry, the leading M-by-M part of this array must
C             contain the coefficient matrix A of the equation; A must
C             be in upper quasi-triangular form if REDUCE = 'B' or 'N'.
C             On exit, the leading M-by-M part of this array contains
C             the upper quasi-triangular form of A.
C
C     LDA     INTEGER
C             The leading dimension of array A.  LDA >= MAX(1,M).
C
C     B       (input/output) DOUBLE PRECISION array, dimension (LDB,N)
C             On entry, the leading N-by-N part of this array must
C             contain the coefficient matrix B of the equation; B must
C             be in upper quasi-triangular form if REDUCE = 'A' or 'N'.
C             On exit, the leading N-by-N part of this array contains
C             the upper quasi-triangular form of B.
C
C     LDB     INTEGER
C             The leading dimension of array B.  LDB >= MAX(1,N).
C
C     C       (input/output) DOUBLE PRECISION array, dimension (LDC,N)
C             On entry, the leading M-by-N part of this array must
C             contain the right-hand side matrix C of the first equation
C             in (1) or (2).
C             On exit, if JOBD = 'N', 'D' or 'F', the leading M-by-N
C             part of this array contains the solution matrix R of the
C             problem; if JOBD = '1' or '2' and TRANS = 'N', the leading
C             M-by-N part of this array contains the solution matrix R
C             achieved during the computation of the Dif estimate.
C
C     LDC     INTEGER
C             The leading dimension of array C.  LDC >= MAX(1,M).
C
C     D       (input/output) DOUBLE PRECISION array, dimension (LDD,M)
C             On entry, the leading M-by-M part of this array must
C             contain the coefficient matrix D of the equation; D must
C             be in upper triangular form if REDUCE = 'B' or 'N'.
C             On exit, the leading M-by-M part of this array contains
C             the upper triangular form of D.
C
C     LDD     INTEGER
C             The leading dimension of array D.  LDD >= MAX(1,M).
C
C     E       (input/output) DOUBLE PRECISION array, dimension (LDE,N)
C             On entry, the leading N-by-N part of this array must
C             contain the coefficient matrix E of the equation; E must
C             be in upper triangular form if REDUCE = 'A' or 'N'.
C             On exit, the leading N-by-N part of this array contains
C             the upper triangular form of E.
C
C     LDE     INTEGER
C             The leading dimension of array E.  LDE >= MAX(1,N).
C
C     F       (input/output) DOUBLE PRECISION array, dimension (LDF,N)
C             On entry, the leading M-by-N part of this array must
C             contain the right-hand side matrix F of the second
C             equation in (1) or (2).
C             On exit, if JOBD = 'N', 'D' or 'F', the leading M-by-N
C             part of this array contains the solution matrix L of the
C             problem; if JOBD = '1' or '2' and TRANS = 'N', the leading
C             M-by-N part of this array contains the solution matrix L
C             achieved during the computation of the Dif estimate.
C
C     LDF     INTEGER
C             The leading dimension of array F.  LDF >= MAX(1,M).
C
C     SCALE   (output) DOUBLE PRECISION
C             The scaling factor in (1) or (2). If 0 < SCALE < 1, C and
C             F hold the solutions R and L, respectively, to a slightly
C             perturbed system, but the computed generalized (real)
C             Schur canonical form matrices P'*A*Q, U'*B*V, P'*D*Q and
C             U'*E*V (see METHOD), or input matrices A, B, D, and E (if
C             already reduced to these forms), have not been changed.
C             If SCALE = 0, C and F hold the solutions R and L,
C             respectively, to the homogeneous system with C = F = 0.
C             Normally, SCALE = 1.
C
C     DIF     (output) DOUBLE PRECISION
C             If TRANS = 'N' and JOBD <> 'N', then DIF contains the
C             value of the Dif estimator, which is an upper bound of
C                                                    -1
C             Dif[(A,D),(B,E)] = sigma_min(Z) = 1/||Z  ||, in either the
C             one-norm, or Frobenius norm, respectively (see METHOD).
C             Otherwise, DIF is not referenced.
C
C     P       (output) DOUBLE PRECISION array, dimension (LDP,*)
C             If REDUCE = 'R' or 'A', then the leading M-by-M part of
C             this array contains the (left) transformation matrix used
C             to reduce (A,D) to generalized Schur form.
C             Otherwise, P is not referenced and can be supplied as a
C             dummy array (i.e. set parameter LDP = 1 and declare this
C             array to be P(1,1) in the calling program).
C
C     LDP     INTEGER
C             The leading dimension of array P.
C             LDP >= MAX(1,M) if REDUCE = 'R' or 'A',
C             LDP >= 1        if REDUCE = 'B' or 'N'.
C
C     Q       (output) DOUBLE PRECISION array, dimension (LDQ,*)
C             If REDUCE = 'R' or 'A', then the leading M-by-M part of
C             this array contains the (right) transformation matrix used
C             to reduce (A,D) to generalized Schur form.
C             Otherwise, Q is not referenced and can be supplied as a
C             dummy array (i.e. set parameter LDQ = 1 and declare this
C             array to be Q(1,1) in the calling program).
C
C     LDQ     INTEGER
C             The leading dimension of array Q.
C             LDQ >= MAX(1,M) if REDUCE = 'R' or 'A',
C             LDQ >= 1        if REDUCE = 'B' or 'N'.
C
C     U       (output) DOUBLE PRECISION array, dimension (LDU,*)
C             If REDUCE = 'R' or 'B', then the leading N-by-N part of
C             this array contains the (left) transformation matrix used
C             to reduce (B,E) to generalized Schur form.
C             Otherwise, U is not referenced and can be supplied as a
C             dummy array (i.e. set parameter LDU = 1 and declare this
C             array to be U(1,1) in the calling program).
C
C     LDU     INTEGER
C             The leading dimension of array U.
C             LDU >= MAX(1,N) if REDUCE = 'R' or 'B',
C             LDU >= 1        if REDUCE = 'A' or 'N'.
C
C     V       (output) DOUBLE PRECISION array, dimension (LDV,*)
C             If REDUCE = 'R' or 'B', then the leading N-by-N part of
C             this array contains the (right) transformation matrix used
C             to reduce (B,E) to generalized Schur form.
C             Otherwise, V is not referenced and can be supplied as a
C             dummy array (i.e. set parameter LDV = 1 and declare this
C             array to be V(1,1) in the calling program).
C
C     LDV     INTEGER
C             The leading dimension of array V.
C             LDV >= MAX(1,N) if REDUCE = 'R' or 'B',
C             LDV >= 1        if REDUCE = 'A' or 'N'.
C
C     Workspace
C
C     IWORK   INTEGER array, dimension (M+N+6)
C
C     DWORK   DOUBLE PRECISION array, dimension (LDWORK)
C             On exit, if INFO = 0, DWORK(1) returns the optimal value
C             of LDWORK.
C
C     LDWORK  INTEGER
C             The length of the array DWORK.
C             If TRANS = 'N' and JOBD = 'D' or 'F', then
C                LDWORK = MAX(1,11*MN,10*MN+23,2*M*N) if REDUCE = 'R';
C                LDWORK = MAX(1,11*M, 10*M+23, 2*M*N) if REDUCE = 'A';
C                LDWORK = MAX(1,11*N, 10*N+23, 2*M*N) if REDUCE = 'B';
C                LDWORK = MAX(1,2*M*N)                if REDUCE = 'N',
C             where MN = max(M,N).
C             Otherwise, the term 2*M*N above should be omitted.
C             For optimum performance LDWORK should be larger.
C
C             If LDWORK = -1  a workspace query is assumed; the
C             routine only calculates the optimal size of the DWORK
C             array, returns this value as the first entry of the DWORK
C             array, and no error message is issued by XERBLA.
C
C     Error Indicator
C
C     INFO    INTEGER
C             = 0:  successful exit;
C             < 0:  if INFO = -i, the i-th argument had an illegal
C                   value;
C             = 1:  if REDUCE <> 'N' and either (A,D) and/or (B,E)
C                   cannot be reduced to generalized Schur form;
C             = 2:  if REDUCE = 'N' and either A or B is not in
C                   upper quasi-triangular form;
C             = 3:  if a singular matrix was encountered during the
C                   computation of the solution matrices R and L, that
C                   is (A,D) and (B,E) have common or close eigenvalues.
C
C     METHOD
C
C     For the case TRANS = 'N', and REDUCE = 'R' or 'N', the algorithm
C     used by the routine consists of four steps (see [1] and [2]) as
C     follows:
C
C        (a) if REDUCE = 'R', then the matrix pairs (A,D) and (B,E) are
C            transformed to generalized Schur form, i.e. orthogonal
C            matrices P, Q, U and V are computed such that P' * A * Q
C            and U' * B * V are in upper quasi-triangular form and
C            P' * D * Q and U' * E * V are in upper triangular form;
C        (b) if REDUCE = 'R', then the matrices C and F are transformed
C            to give P' * C * V and P' * F * V respectively;
C        (c) if REDUCE = 'R', then the transformed system
C
C            P' * A * Q * R1 - L1 * U' * B * V = scale * P' * C * V
C            P' * D * Q * R1 - L1 * U' * E * V = scale * P' * F * V
C
C            is solved to give R1 and L1; otherwise, equation (1) is
C            solved to give R and L directly. The Dif estimator
C            is also computed if JOBD <> 'N'.
C        (d) if REDUCE = 'R', then the solution is transformed back
C            to give R = Q * R1 * V' and L = P * L1 * U'.
C
C     By using Kronecker products, equation (1) can also be written as
C     the system of linear equations Z * x = scale*y (see [1]), where
C
C            | I*A    I*D  |
C        Z = |             |.
C            |-B'*I  -E'*I |
C
C                                              -1
C     If JOBD <> 'N', then a lower bound on ||Z  ||, in either the one-
C     norm or Frobenius norm, is computed, which in most cases is
C     a reliable estimate of the true value. Notice that since Z is a
C     matrix of order 2 * M * N, the exact value of Dif (i.e., in the
C     Frobenius norm case, the smallest singular value of Z) may be very
C     expensive to compute.
C
C     The case TRANS = 'N', and REDUCE = 'A' or 'B', is similar, but
C     only one of the matrix pairs should be reduced and the
C     calculations simplify.
C
C     For the case TRANS = 'T', and REDUCE = 'R' or 'N', the algorithm
C     is similar, but the steps (b), (c), and (d) are as follows:
C
C        (b) if REDUCE = 'R', then the matrices C and F are transformed
C            to give Q' * C * V and P' * F * U respectively;
C        (c) if REDUCE = 'R', then the transformed system
C
C            Q' * A' * P * R1 + Q' * D' * P * L1 =  scale * Q' * C * V
C            R1 * V' * B' * U + L1 * V' * E' * U = -scale * P' * F * U
C
C            is solved to give R1 and L1; otherwise, equation (2) is
C            solved to give R and L directly.
C        (d) if REDUCE = 'R', then the solution is transformed back
C            to give R = P * R1 * V' and L = P * L1 * V'.
C
C     REFERENCES
C
C     [1] Kagstrom, B. and Westin, L.
C         Generalized Schur Methods with Condition Estimators for
C         Solving the Generalized Sylvester Equation.
C         IEEE Trans. Auto. Contr., 34, pp. 745-751, 1989.
C     [2] Kagstrom, B. and Westin, L.
C         GSYLV - Fortran Routines for the Generalized Schur Method with
C         Dif Estimators for Solving the Generalized Sylvester
C         Equation.
C         Report UMINF-132.86, Institute of Information Processing,
C         Univ. of Umea, Sweden, July 1987.
C     [3] Golub, G.H., Nash, S. and Van Loan, C.F.
C         A Hessenberg-Schur Method for the Problem AX + XB = C.
C         IEEE Trans. Auto. Contr., AC-24, pp. 909-913, 1979.
C     [4] Kagstrom, B. and Van Dooren, P.
C         Additive Decomposition of a Transfer Function with respect to
C         a Specified Region.
C         In: "Signal Processing, Scattering and Operator Theory, and
C         Numerical Methods" (Eds. M.A. Kaashoek et al.).
C         Proceedings of MTNS-89, Vol. 3, pp. 469-477, Birkhauser Boston
C         Inc., 1990.
C     [5] Kagstrom, B. and Van Dooren, P.
C         A Generalized State-space Approach for the Additive
C         Decomposition of a Transfer Matrix.
C         Report UMINF-91.12, Institute of Information Processing, Univ.
C         of Umea, Sweden, April 1991.
C
C     NUMERICAL ASPECTS
C
C     The algorithm is backward stable. A reliable estimate for the
C     condition number of Z in the Frobenius norm, is (see [1])
C
C        K(Z) = SQRT(  ||A||**2 + ||B||**2 + ||C||**2 + ||D||**2 )/DIF.
C
C     If mu is an upper bound on the relative error of the elements of
C     the matrices A, B, C, D, E and F, then the relative error in the
C     actual solution is approximately mu * K(Z).
C
C     The relative error in the computed solution (due to rounding
C     errors) is approximately EPS * K(Z), where EPS is the machine
C     precision (see LAPACK Library routine DLAMCH).
C
C     FURTHER COMMENTS
C
C     For applications of the generalized Sylvester equation in control
C     theory, see [4] and [5].
C
C     CONTRIBUTORS
C
C     Release 3.0: V. Sima, Katholieke Univ. Leuven, Belgium, Aug. 1997.
C     Supersedes Release 2.0 routine SB04CD by Bo Kagstrom and Lars
C     Westin.
C
C     REVISIONS
C
C     V. Sima, Katholieke Univ. Leuven, Belgium, May 1999, Dec. 1999,
C     May 2009, Apr. 2014.
C
C     KEYWORDS
C
C     Generalized eigenvalue problem, orthogonal transformation, real
C     Schur form, Sylvester equation.
C
C     ******************************************************************
C
C     .. Parameters ..
      DOUBLE PRECISION  ZERO, ONE
      PARAMETER         ( ZERO = 0.0D0, ONE = 1.0D0 )
C     .. Scalar Arguments ..
      CHARACTER         JOBD, REDUCE, TRANS
      INTEGER           INFO, LDA, LDB, LDC, LDD, LDE, LDF, LDP, LDQ,
     $                  LDU, LDV, LDWORK, M, N
      DOUBLE PRECISION  DIF, SCALE
C     .. Array Arguments ..
      INTEGER           IWORK(*)
      DOUBLE PRECISION  A(LDA,*), B(LDB,*), C(LDC,*), D(LDD,*),
     $                  DWORK(*), E(LDE,*), F(LDF,*), P(LDP,*),
     $                  Q(LDQ,*), U(LDU,*), V(LDV,*)
C     .. Local Scalars ..
      LOGICAL           LJOB1, LJOB2, LJOBD, LJOBDF, LJOBF, LQUERY,
     $                  LREDRA, LREDRB, LREDUA, LREDUB, LREDUC, LREDUR,
     $                  LTRANN, SUFWRK
      INTEGER           I, IJOB, MINWRK, MN, NBC, NBR, NC, NR, WRKOPT
C     .. Local Arrays ..
      LOGICAL           BWORK(1)
C     .. External Functions ..
      LOGICAL           LSAME, SELECT
      EXTERNAL          LSAME, SELECT
C     .. External Subroutines ..
      EXTERNAL          DGGES, DGEMM, DLACPY, DTGSYL, XERBLA
C     .. Intrinsic Functions ..
      INTRINSIC         INT, MAX, MIN
C     .. Executable Statements ..
C
      INFO = 0
      MN   = MAX( M, N )
      LREDUR = LSAME( REDUCE, 'R' )
      LREDUA = LSAME( REDUCE, 'A' )
      LREDUB = LSAME( REDUCE, 'B' )
      LREDRA = LREDUR.OR.LREDUA
      LREDRB = LREDUR.OR.LREDUB
      LREDUC = LREDRA.OR.LREDUB
      LQUERY = LDWORK.EQ.-1
      IF ( LREDUR ) THEN
         MINWRK = MAX( 1, 11*MN, 10*MN+23  )
      ELSE IF ( LREDUA ) THEN
         MINWRK = MAX( 1, 11*M, 10*M+23 )
      ELSE IF ( LREDUB ) THEN
         MINWRK = MAX( 1, 11*N, 10*N+23 )
      ELSE
         MINWRK = 1
      END IF
      LTRANN = LSAME( TRANS,  'N' )
      IF ( LTRANN ) THEN
         LJOB1  = LSAME( JOBD, '1' )
         LJOB2  = LSAME( JOBD, '2' )
         LJOBD  = LSAME( JOBD, 'D' )
         LJOBF  = LSAME( JOBD, 'F' )
         LJOBDF = LJOB1.OR.LJOB2.OR.LJOBD.OR.LJOBF
         IF ( LJOBD.OR.LJOBF )
     $      MINWRK = MAX( MINWRK, 2*M*N )
      END IF
C
C     Test the input scalar arguments.
C
      IF( .NOT.LREDUC .AND. .NOT.LSAME( REDUCE, 'N' ) ) THEN
         INFO = -1
      ELSE IF( .NOT.LTRANN .AND. .NOT.LSAME( TRANS, 'T' ) ) THEN
         INFO = -2
      ELSE IF( LTRANN ) THEN
         IF( .NOT.LJOBDF .AND. .NOT.LSAME( JOBD, 'N' ) )
     $      INFO = -3
      END IF
      IF( M.LT.0 ) THEN
         INFO = -4
      ELSE IF( N.LT.0 ) THEN
         INFO = -5
      ELSE IF( LDA.LT.MAX( 1, M ) ) THEN
         INFO = -7
      ELSE IF( LDB.LT.MAX( 1, N ) ) THEN
         INFO = -9
      ELSE IF( LDC.LT.MAX( 1, M ) ) THEN
         INFO = -11
      ELSE IF( LDD.LT.MAX( 1, M ) ) THEN
         INFO = -13
      ELSE IF( LDE.LT.MAX( 1, N ) ) THEN
         INFO = -15
      ELSE IF( LDF.LT.MAX( 1, M ) ) THEN
         INFO = -17
      ELSE IF( LDP.LT.1 .OR. LREDRA .AND. LDP.LT.M ) THEN
         INFO = -21
      ELSE IF( LDQ.LT.1 .OR. LREDRA .AND. LDQ.LT.M ) THEN
         INFO = -23
      ELSE IF( LDU.LT.1 .OR. LREDRB .AND. LDU.LT.N ) THEN
         INFO = -25
      ELSE IF( LDV.LT.1 .OR. LREDRB .AND. LDV.LT.N ) THEN
         INFO = -27
      ELSE
         IF( LQUERY ) THEN
            WRKOPT = MAX( M*N, MINWRK )
            IF ( LREDUC ) THEN
               IF ( .NOT.LREDUB ) THEN
                  CALL DGGES( 'V', 'V', 'N', SELECT, M, A, LDA, D, LDD,
     $                        I, DWORK, DWORK, DWORK, P, LDP, Q, LDQ,
     $                        DWORK, -1, BWORK, INFO )
                  WRKOPT = MAX( WRKOPT, INT( DWORK(1) ) + 3*M )
               END IF
               IF ( .NOT.LREDUA ) THEN
                  CALL DGGES( 'V', 'V', 'N', SELECT, N, B, LDB, E, LDE,
     $                        I, DWORK, DWORK, DWORK, U, LDU, V, LDV,
     $                        DWORK, -1, BWORK, INFO )
                  WRKOPT = MAX( WRKOPT, INT( DWORK(1) ) + 3*N )
               END IF
            END IF
            DWORK(1) = WRKOPT
         END IF
         IF( LDWORK.LT.MINWRK .AND. .NOT.LQUERY )
     $      INFO = -30
      END IF
C
      IF ( INFO.NE.0 ) THEN
C
C        Error return.
C
         CALL XERBLA( 'SB04OD', -INFO )
         RETURN
      ELSE IF( LQUERY ) THEN
         RETURN
      END IF
C
C     Quick return if possible.
C
      IF ( N.EQ.0 .OR. M.EQ.0 ) THEN
         SCALE = ONE
         DWORK(1) = ONE
         IF ( LTRANN ) THEN
            IF ( LJOBDF )
     $         DIF = ONE
         END IF
         RETURN
      END IF
      WRKOPT = MINWRK
      SUFWRK = LDWORK.GE.M*N
C
C     STEP 1: Reduce (A,D) and/or (B,E) to generalized Schur form.
C
C     (Note: Comments in the code beginning "Workspace:" describe the
C     minimal amount of real workspace needed at that point in the
C     code, as well as the preferred amount for good performance.
C     NB refers to the optimal block size for the immediately
C     following subroutine, as returned by ILAENV.)
C
      IF ( LREDUC ) THEN
C
         IF ( .NOT.LREDUB ) THEN
C
C           Reduce (A,D) to generalized Schur form.
C           Workspace:  need   MAX(11*M,10*M+23);
C                       prefer larger.
C           The second term is needed due to an error in DGGES; it would
C           not be needed for the value 'Not ordered' of SORT argument.
C
            CALL DGGES( 'Vectors left', 'Vectors right', 'Not ordered',
     $                  SELECT, M, A, LDA, D, LDD, I, DWORK, DWORK(M+1),
     $                  DWORK(2*M+1), P, LDP, Q, LDQ, DWORK(3*M+1),
     $                  LDWORK-3*M, BWORK, INFO )
C
            IF ( INFO.NE.0 ) THEN
               INFO = 1
               RETURN
            END IF
            WRKOPT = MAX( WRKOPT, INT( DWORK(3*M+1) ) + 3*M )
         END IF
         IF ( .NOT.LREDUA ) THEN
C
C           Reduce (B,E) to generalized Schur form.
C           Workspace:  need   MAX(11*N,10*N+23);
C                       prefer larger.
C
            CALL DGGES( 'Vectors left', 'Vectors right', 'Not ordered',
     $                  SELECT, N, B, LDB, E, LDE, I, DWORK, DWORK(N+1),
     $                  DWORK(2*N+1), U, LDU, V, LDV, DWORK(3*N+1),
     $                  LDWORK-3*N, BWORK, INFO )
C
            IF ( INFO.NE.0 ) THEN
               INFO = 1
               RETURN
            END IF
            WRKOPT = MAX( WRKOPT, INT( DWORK(3*N+1) ) + 3*N )
         END IF
      END IF
C
      IF (.NOT.LREDUR ) THEN
C
C        Set INFO = 2 if A and/or B are/is not in quasi-triangular form.
C
         IF (.NOT.LREDUA ) THEN
            I = 1
C
   20       CONTINUE
            IF ( I.LE.M-2 ) THEN
               IF ( A(I+1,I).NE.ZERO ) THEN
                  IF ( A(I+2,I+1).NE.ZERO ) THEN
                     INFO = 2
                     RETURN
                  ELSE
                     I = I + 1
                  END IF
               END IF
               I = I + 1
               GO TO 20
            END IF
         END IF
C
         IF (.NOT.LREDUB ) THEN
            I = 1
C
   40       CONTINUE
            IF ( I.LE.N-2 ) THEN
               IF ( B(I+1,I).NE.ZERO ) THEN
                  IF ( B(I+2,I+1).NE.ZERO ) THEN
                     INFO = 2
                     RETURN
                  ELSE
                     I = I + 1
                  END IF
               END IF
               I = I + 1
               GO TO 40
            END IF
         END IF
      END IF
C
C     STEP 2: Modify right hand sides (C,F).
C
      IF ( LREDUC ) THEN
         WRKOPT = MAX( WRKOPT, M*N )
         IF ( SUFWRK ) THEN
C
C           Enough workspace for a BLAS 3 calculation.
C
            IF ( LTRANN ) THEN
C
C              Equation (1).
C
               IF ( .NOT.LREDUB ) THEN
                  CALL DGEMM( 'Transpose', 'No transpose', M, N, M, ONE,
     $                        P, LDP, C, LDC, ZERO, DWORK, M )
               ELSE
                  CALL DLACPY( 'All', M, N, C, LDC, DWORK, M )
               END IF
               IF ( .NOT.LREDUA ) THEN
                  CALL DGEMM( 'No transpose', 'No transpose', M, N, N,
     $                        ONE, DWORK, M, V, LDV, ZERO, C, LDC )
               ELSE
                  CALL DLACPY( 'All', M, N, DWORK, M, C, LDC )
               END IF
               IF ( .NOT.LREDUB ) THEN
                  CALL DGEMM( 'Transpose', 'No transpose', M, N, M, ONE,
     $                        P, LDP, F, LDF, ZERO, DWORK, M )
               ELSE
                  CALL DLACPY( 'All', M, N, F, LDF, DWORK, M )
               END IF
               IF ( .NOT.LREDUA ) THEN
                  CALL DGEMM( 'No transpose', 'No transpose', M, N, N,
     $                        ONE, DWORK, M, V, LDV, ZERO, F, LDF )
               ELSE
                  CALL DLACPY( 'All', M, N, DWORK, M, F, LDF )
               END IF
            ELSE
C
C              Equation (2).
C
               IF ( .NOT.LREDUB ) THEN
                  CALL DGEMM( 'Transpose', 'No transpose', M, N, M, ONE,
     $                        Q, LDQ, C, LDC, ZERO, DWORK, M )
               ELSE
                  CALL DLACPY( 'All', M, N, C, LDC, DWORK, M )
               END IF
               IF ( .NOT.LREDUA ) THEN
                  CALL DGEMM( 'No transpose', 'No transpose', M, N, N,
     $                        ONE, DWORK, M, V, LDV, ZERO, C, LDC )
               ELSE
                  CALL DLACPY( 'All', M, N, DWORK, M, C, LDC )
               END IF
               IF ( .NOT.LREDUB ) THEN
                  CALL DGEMM( 'Transpose', 'No transpose', M, N, M, ONE,
     $                        P, LDP, F, LDF, ZERO, DWORK, M )
               ELSE
                  CALL DLACPY( 'All', M, N, F, LDF, DWORK, M )
               END IF
               IF ( .NOT.LREDUA ) THEN
                  CALL DGEMM( 'No transpose', 'No transpose', M, N, N,
     $                        ONE, DWORK, M, U, LDU, ZERO, F, LDF )
               ELSE
                  CALL DLACPY( 'All', M, N, DWORK, M, F, LDF )
               END IF
            END IF
         ELSE
C
C           Use BLAS 3 calculations in a loop.
C
            IF ( LTRANN ) THEN
C
C              Equation (1).
C
               IF ( .NOT.LREDUB ) THEN
                  NBC = LDWORK/M
C
                  DO 60 I = 1, N, NBC
                     NC = MIN( NBC, N-I+1 )
                     CALL DGEMM(  'Transpose', 'No transpose', M, NC, M,
     $                            ONE, P, LDP, C(1,I), LDC, ZERO, DWORK,
     $                            M )
                     CALL DLACPY( 'All', M, NC, DWORK, M, C(1,I), LDC )
   60             CONTINUE
C
               END IF
               IF ( .NOT.LREDUA ) THEN
                  NBR = LDWORK/N
C
                  DO 80 I = 1, M, NBR
                     NR = MIN( NBR, M-I+1 )
                     CALL DGEMM(  'No transpose', 'No transpose', NR, N,
     $                            N, ONE, C(I,1), LDC, V, LDV, ZERO,
     $                            DWORK, NR )
                     CALL DLACPY( 'All', NR, N, DWORK, NR, C(I,1), LDC )
   80             CONTINUE
C
               END IF
               IF ( .NOT.LREDUB ) THEN
C
                  DO 100 I = 1, N, NBC
                     NC = MIN( NBC, N-I+1 )
                     CALL DGEMM(  'Transpose', 'No transpose', M, NC, M,
     $                            ONE, P, LDP, F(1,I), LDF, ZERO, DWORK,
     $                            M )
                     CALL DLACPY( 'All', M, NC, DWORK, M, F(1,I), LDF )
  100             CONTINUE
C
               END IF
               IF ( .NOT.LREDUA ) THEN
C
                  DO 120 I = 1, M, NBR
                     NR = MIN( NBR, M-I+1 )
                     CALL DGEMM(  'No transpose', 'No transpose', NR, N,
     $                            N, ONE, F(I,1), LDF, V, LDV, ZERO,
     $                            DWORK, NR )
                     CALL DLACPY( 'All', NR, N, DWORK, NR, F(I,1), LDF )
  120             CONTINUE
C
               END IF
            ELSE
C
C              Equation (2).
C
               IF ( .NOT.LREDUB ) THEN
                  NBC = LDWORK/M
C
                  DO 140 I = 1, N, NBC
                     NC = MIN( NBC, N-I+1 )
                     CALL DGEMM(  'Transpose', 'No transpose', M, NC, M,
     $                            ONE, Q, LDQ, C(1,I), LDC, ZERO, DWORK,
     $                            M )
                     CALL DLACPY( 'All', M, NC, DWORK, M, C(1,I), LDC )
  140             CONTINUE
C
               END IF
               IF ( .NOT.LREDUA ) THEN
                  NBR = LDWORK/N
C
                  DO 160 I = 1, M, NBR
                     NR = MIN( NBR, M-I+1 )
                     CALL DGEMM(  'No transpose', 'No transpose', NR, N,
     $                            N, ONE, C(I,1), LDC, V, LDV, ZERO,
     $                            DWORK, NR )
                     CALL DLACPY( 'All', NR, N, DWORK, NR, C(I,1), LDC )
  160             CONTINUE
C
               END IF
               IF ( .NOT.LREDUB ) THEN
C
                  DO 180 I = 1, N, NBC
                     NC = MIN( NBC, N-I+1 )
                     CALL DGEMM(  'Transpose', 'No transpose', M, NC, M,
     $                            ONE, P, LDP, F(1,I), LDF, ZERO, DWORK,
     $                            M )
                     CALL DLACPY( 'All', M, NC, DWORK, M, F(1,I), LDF )
  180             CONTINUE
C
               END IF
               IF ( .NOT.LREDUA ) THEN
C
                  DO 200 I = 1, M, NBR
                     NR = MIN( NBR, M-I+1 )
                     CALL DGEMM(  'No transpose', 'No transpose', NR, N,
     $                            N, ONE, F(I,1), LDF, U, LDU, ZERO,
     $                            DWORK, NR )
                     CALL DLACPY( 'All', NR, N, DWORK, NR, F(I,1), LDF )
  200             CONTINUE
C
               END IF
            END IF
         END IF
      END IF
C
C     STEP 3: Solve the transformed system and compute the Dif
C             estimator.
C
      IF ( LTRANN ) THEN
         IF ( LJOBD ) THEN
            IJOB = 1
         ELSE IF ( LJOBF ) THEN
            IJOB = 2
         ELSE IF ( LJOB1 ) THEN
            IJOB = 3
         ELSE IF ( LJOB2 ) THEN
            IJOB = 4
         ELSE
            IJOB = 0
         END IF
      ELSE
         IJOB = 0
      END IF
C
C     Workspace:  need 2*M*N if TRANS = 'N' and JOBD = 'D' or 'F';
C                      1, otherwise.
C
      CALL DTGSYL( TRANS, IJOB, M, N, A, LDA, B, LDB, C, LDC, D, LDD,
     $             E, LDE, F, LDF, SCALE, DIF, DWORK, LDWORK, IWORK,
     $             INFO )
      IF ( INFO.NE.0 ) THEN
         INFO = 3
         RETURN
      END IF
C
C     STEP 4: Back transformation of the solution.
C
      IF ( LREDUC ) THEN
         IF (SUFWRK ) THEN
C
C           Enough workspace for a BLAS 3 calculation.
C
            IF ( LTRANN ) THEN
C
C              Equation (1).
C
               IF ( .NOT.LREDUB ) THEN
                  CALL DGEMM( 'No transpose', 'No transpose', M, N, M,
     $                        ONE, Q, LDQ, C, LDC, ZERO, DWORK, M )
               ELSE
                  CALL DLACPY( 'All', M, N, C, LDC, DWORK, M )
               END IF
               IF ( .NOT.LREDUA ) THEN
                  CALL DGEMM( 'No transpose', 'Transpose', M, N, N, ONE,
     $                        DWORK, M, V, LDV, ZERO, C, LDC )
               ELSE
                  CALL DLACPY( 'All', M, N, DWORK, M, C, LDC )
               END IF
               IF ( .NOT.LREDUB ) THEN
                  CALL DGEMM( 'No transpose', 'No transpose', M, N, M,
     $                        ONE, P, LDP, F, LDF, ZERO, DWORK, M )
               ELSE
                  CALL DLACPY( 'All', M, N, F, LDF, DWORK, M )
               END IF
               IF ( .NOT.LREDUA ) THEN
                  CALL DGEMM( 'No transpose', 'Transpose', M, N, N, ONE,
     $                        DWORK, M, U, LDU, ZERO, F, LDF )
               ELSE
                  CALL DLACPY( 'All', M, N, DWORK, M, F, LDF )
               END IF
            ELSE
C
C              Equation (2).
C
               IF ( .NOT.LREDUB ) THEN
                  CALL DGEMM( 'No transpose', 'No transpose', M, N, M,
     $                        ONE, P, LDP, C, LDC, ZERO, DWORK, M )
               ELSE
                  CALL DLACPY( 'All', M, N, C, LDC, DWORK, M )
               END IF
               IF ( .NOT.LREDUA ) THEN
                  CALL DGEMM( 'No transpose', 'Transpose', M, N, N,
     $                        ONE, DWORK, M, V, LDV, ZERO, C, LDC )
               ELSE
                  CALL DLACPY( 'All', M, N, DWORK, M, C, LDC )
               END IF
               IF ( .NOT.LREDUB ) THEN
                  CALL DGEMM( 'No transpose', 'No transpose', M, N, M,
     $                        ONE, P, LDP, F, LDF, ZERO, DWORK, M )
               ELSE
                  CALL DLACPY( 'All', M, N, F, LDF, DWORK, M )
               END IF
               IF ( .NOT.LREDUA ) THEN
                  CALL DGEMM( 'No transpose', 'Transpose', M, N, N,
     $                        ONE, DWORK, M, V, LDV, ZERO, F, LDF )
               ELSE
                  CALL DLACPY( 'All', M, N, DWORK, M, F, LDF )
               END IF
            END IF
         ELSE
C
C           Use BLAS 3 calculations in a loop.
C
            IF ( LTRANN ) THEN
C
C              Equation (1).
C
               IF ( .NOT.LREDUB ) THEN
C
                  DO 220 I = 1, N, NBC
                     NC = MIN( NBC, N-I+1 )
                     CALL DGEMM(  'No transpose', 'No transpose', M, NC,
     $                            M, ONE, Q, LDQ, C(1,I), LDC, ZERO,
     $                            DWORK, M )
                     CALL DLACPY( 'All', M, NC, DWORK, M, C(1,I), LDC )
  220             CONTINUE
C
               END IF
               IF ( .NOT.LREDUA ) THEN
C
                  DO 240 I = 1, M, NBR
                     NR = MIN( NBR, M-I+1 )
                     CALL DGEMM(  'No transpose', 'Transpose', NR, N, N,
     $                            ONE, C(I,1), LDC, V, LDV, ZERO, DWORK,
     $                            NR )
                     CALL DLACPY( 'All', NR, N, DWORK, NR, C(I,1), LDC )
  240             CONTINUE
C
               END IF
               IF ( .NOT.LREDUB ) THEN
C
                  DO 260 I = 1, N, NBC
                     NC = MIN( NBC, N-I+1 )
                     CALL DGEMM(  'No transpose', 'No transpose', M, NC,
     $                            M, ONE, P, LDP, F(1,I), LDF, ZERO,
     $                            DWORK, M )
                     CALL DLACPY( 'All', M, NC, DWORK, M, F(1,I), LDF )
  260             CONTINUE
C
               END IF
               IF ( .NOT.LREDUA ) THEN
C
                  DO 280 I = 1, M, NBR
                     NR = MIN( NBR, M-I+1 )
                     CALL DGEMM(  'No transpose', 'Transpose', NR, N, N,
     $                            ONE, F(I,1), LDF, U, LDU, ZERO, DWORK,
     $                            NR )
                     CALL DLACPY( 'All', NR, N, DWORK, NR, F(I,1), LDF )
  280             CONTINUE
C
               END IF
            ELSE
C
C              Equation (2).
C
               IF ( .NOT.LREDUB ) THEN
C
                  DO 300 I = 1, N, NBC
                     NC = MIN( NBC, N-I+1 )
                     CALL DGEMM(  'No transpose', 'No transpose', M, NC,
     $                            M, ONE, P, LDP, C(1,I), LDC, ZERO,
     $                            DWORK, M )
                     CALL DLACPY( 'All', M, NC, DWORK, M, C(1,I), LDC )
  300             CONTINUE
C
               END IF
               IF ( .NOT.LREDUA ) THEN
C
                  DO 320 I = 1, M, NBR
                     NR = MIN( NBR, M-I+1 )
                     CALL DGEMM(  'No transpose', 'Transpose', NR, N, N,
     $                            ONE, C(I,1), LDC, V, LDV, ZERO, DWORK,
     $                            NR )
                     CALL DLACPY( 'All', NR, N, DWORK, NR, C(I,1), LDC )
  320             CONTINUE
C
               END IF
               IF ( .NOT.LREDUB ) THEN
C
                  DO 340 I = 1, N, NBC
                     NC = MIN( NBC, N-I+1 )
                     CALL DGEMM(  'No transpose', 'No transpose', M, NC,
     $                            M, ONE, P, LDP, F(1,I), LDF, ZERO,
     $                            DWORK, M )
                     CALL DLACPY( 'All', M, NC, DWORK, M, F(1,I), LDF )
  340             CONTINUE
C
               END IF
               IF ( .NOT.LREDUA ) THEN
C
                  DO 360 I = 1, M, NBR
                     NR = MIN( NBR, M-I+1 )
                     CALL DGEMM(  'No transpose', 'Transpose', NR, N, N,
     $                            ONE, F(I,1), LDF, V, LDV, ZERO, DWORK,
     $                            NR )
                     CALL DLACPY( 'All', NR, N, DWORK, NR, F(I,1), LDF )
  360             CONTINUE
C
               END IF
            END IF
         END IF
      END IF
C
      DWORK(1) = WRKOPT
C
      RETURN
C *** Last line of SB04OD ***
      END


      subroutine dqc25s(f,a,b,bl,br,alfa,beta,ri,rj,rg,rh,result,
     *   abserr,resasc,integr,nev)
c***begin prologue  dqc25s
c***date written   810101   (yymmdd)
c***revision date  830518   (yymmdd)
c***category no.  h2a2a2
c***keywords  25-point clenshaw-curtis integration
c***author  piessens,robert,appl. math. & progr. div. - k.u.leuven
c           de doncker,elise,appl. math. & progr. div. - k.u.leuven
c***purpose  to compute i = integral of f*w over (bl,br), with error
c            estimate, where the weight function w has a singular
c            behaviour of algebraico-logarithmic type at the points
c            a and/or b. (bl,br) is a part of (a,b).
c***description
c
c        integration rules for integrands having algebraico-logarithmic
c        end point singularities
c        standard fortran subroutine
c        double precision version
c
c        parameters
c           f      - double precision
c                    function subprogram defining the integrand
c                    f(x). the actual name for f needs to be declared
c                    e x t e r n a l  in the driver program.
c
c           a      - double precision
c                    left end point of the original interval
c
c           b      - double precision
c                    right end point of the original interval, b.gt.a
c
c           bl     - double precision
c                    lower limit of integration, bl.ge.a
c
c           br     - double precision
c                    upper limit of integration, br.le.b
c
c           alfa   - double precision
c                    parameter in the weight function
c
c           beta   - double precision
c                    parameter in the weight function
c
c           ri,rj,rg,rh - double precision
c                    modified chebyshev moments for the application
c                    of the generalized clenshaw-curtis
c                    method (computed in subroutine dqmomo)
c
c           result - double precision
c                    approximation to the integral
c                    result is computed by using a generalized
c                    clenshaw-curtis method if b1 = a or br = b.
c                    in all other cases the 15-point kronrod
c                    rule is applied, obtained by optimal addition of
c                    abscissae to the 7-point gauss rule.
c
c           abserr - double precision
c                    estimate of the modulus of the absolute error,
c                    which should equal or exceed abs(i-result)
c
c           resasc - double precision
c                    approximation to the integral of abs(f*w-i/(b-a))
c
c           integr - integer
c                    which determines the weight function
c                    = 1   w(x) = (x-a)**alfa*(b-x)**beta
c                    = 2   w(x) = (x-a)**alfa*(b-x)**beta*log(x-a)
c                    = 3   w(x) = (x-a)**alfa*(b-x)**beta*log(b-x)
c                    = 4   w(x) = (x-a)**alfa*(b-x)**beta*log(x-a)*
c                                 log(b-x)
c
c           nev    - integer
c                    number of integrand evaluations
c***references  (none)
c***routines called  dqcheb,dqk15w
c***end prologue  dqc25s
c
      double precision a,abserr,alfa,b,beta,bl,br,centr,cheb12,cheb24,
     *  dabs,dc,dlog,f,factor,fix,fval,hlgth,resabs,resasc,result,res12,
     *  res24,rg,rh,ri,rj,u,dqwgts,x
      integer i,integr,isym,nev
c
      dimension cheb12(13),cheb24(25),fval(25),rg(25),rh(25),ri(25),
     *  rj(25),x(11)
c
      external f,dqwgts
c
c           the vector x contains the values cos(k*pi/24)
c           k = 1, ..., 11, to be used for the computation of the
c           chebyshev series expansion of f.
c
      data x(1) / 0.9914448613 7381041114 4557526928 563d0 /
      data x(2) / 0.9659258262 8906828674 9743199728 897d0 /
      data x(3) / 0.9238795325 1128675612 8183189396 788d0 /
      data x(4) / 0.8660254037 8443864676 3723170752 936d0 /
      data x(5) / 0.7933533402 9123516457 9776961501 299d0 /
      data x(6) / 0.7071067811 8654752440 0844362104 849d0 /
      data x(7) / 0.6087614290 0872063941 6097542898 164d0 /
      data x(8) / 0.5000000000 0000000000 0000000000 000d0 /
      data x(9) / 0.3826834323 6508977172 8459984030 399d0 /
      data x(10) / 0.2588190451 0252076234 8898837624 048d0 /
      data x(11) / 0.1305261922 2005159154 8406227895 489d0 /
c
c           list of major variables
c           -----------------------
c
c           fval   - value of the function f at the points
c                    (br-bl)*0.5*cos(k*pi/24)+(br+bl)*0.5
c                    k = 0, ..., 24
c           cheb12 - coefficients of the chebyshev series expansion
c                    of degree 12, for the function f, in the
c                    interval (bl,br)
c           cheb24 - coefficients of the chebyshev series expansion
c                    of degree 24, for the function f, in the
c                    interval (bl,br)
c           res12  - approximation to the integral obtained from cheb12
c           res24  - approximation to the integral obtained from cheb24
c           dqwgts - external function subprogram defining
c                    the four possible weight functions
c           hlgth  - half-length of the interval (bl,br)
c           centr  - mid point of the interval (bl,br)
c
c***first executable statement  dqc25s
      nev = 25
      if(bl.eq.a.and.(alfa.ne.0.0d+00.or.integr.eq.2.or.integr.eq.4))
     * go to 10
      if(br.eq.b.and.(beta.ne.0.0d+00.or.integr.eq.3.or.integr.eq.4))
     * go to 140
c
c           if a.gt.bl and b.lt.br, apply the 15-point gauss-kronrod
c           scheme.
c
c
      call dqk15w(f,dqwgts,a,b,alfa,beta,integr,bl,br,
     *    result,abserr,resabs,resasc)
      nev = 15
      go to 270
c
c           this part of the program is executed only if a = bl.
c           ----------------------------------------------------
c
c           compute the chebyshev series expansion of the
c           following function
c           f1 = (0.5*(b+b-br-a)-0.5*(br-a)*x)**beta
c                  *f(0.5*(br-a)*x+0.5*(br+a))
c
   10 hlgth = 0.5d+00*(br-bl)
      centr = 0.5d+00*(br+bl)
      fix = b-centr
      fval(1) = 0.5d+00*f(hlgth+centr)*(fix-hlgth)**beta
      fval(13) = f(centr)*(fix**beta)
      fval(25) = 0.5d+00*f(centr-hlgth)*(fix+hlgth)**beta
      do 20 i=2,12
        u = hlgth*x(i-1)
        isym = 26-i
        fval(i) = f(u+centr)*(fix-u)**beta
        fval(isym) = f(centr-u)*(fix+u)**beta
   20 continue
      factor = hlgth**(alfa+0.1d+01)
      result = 0.0d+00
      abserr = 0.0d+00
      res12 = 0.0d+00
      res24 = 0.0d+00
      if(integr.gt.2) go to 70
      call dqcheb(x,fval,cheb12,cheb24)
c
c           integr = 1  (or 2)
c
      do 30 i=1,13
        res12 = res12+cheb12(i)*ri(i)
        res24 = res24+cheb24(i)*ri(i)
   30 continue
      do 40 i=14,25
        res24 = res24+cheb24(i)*ri(i)
   40 continue
      if(integr.eq.1) go to 130
c
c           integr = 2
c
      dc = dlog(br-bl)
      result = res24*dc
      abserr = dabs((res24-res12)*dc)
      res12 = 0.0d+00
      res24 = 0.0d+00
      do 50 i=1,13
        res12 = res12+cheb12(i)*rg(i)
        res24 = res12+cheb24(i)*rg(i)
   50 continue
      do 60 i=14,25
        res24 = res24+cheb24(i)*rg(i)
   60 continue
      go to 130
c
c           compute the chebyshev series expansion of the
c           following function
c           f4 = f1*log(0.5*(b+b-br-a)-0.5*(br-a)*x)
c
   70 fval(1) = fval(1)*dlog(fix-hlgth)
      fval(13) = fval(13)*dlog(fix)
      fval(25) = fval(25)*dlog(fix+hlgth)
      do 80 i=2,12
        u = hlgth*x(i-1)
        isym = 26-i
        fval(i) = fval(i)*dlog(fix-u)
        fval(isym) = fval(isym)*dlog(fix+u)
   80 continue
      call dqcheb(x,fval,cheb12,cheb24)
c
c           integr = 3  (or 4)
c
      do 90 i=1,13
        res12 = res12+cheb12(i)*ri(i)
        res24 = res24+cheb24(i)*ri(i)
   90 continue
      do 100 i=14,25
        res24 = res24+cheb24(i)*ri(i)
  100 continue
      if(integr.eq.3) go to 130
c
c           integr = 4
c
      dc = dlog(br-bl)
      result = res24*dc
      abserr = dabs((res24-res12)*dc)
      res12 = 0.0d+00
      res24 = 0.0d+00
      do 110 i=1,13
        res12 = res12+cheb12(i)*rg(i)
        res24 = res24+cheb24(i)*rg(i)
  110 continue
      do 120 i=14,25
        res24 = res24+cheb24(i)*rg(i)
  120 continue
  130 result = (result+res24)*factor
      abserr = (abserr+dabs(res24-res12))*factor
      go to 270
c
c           this part of the program is executed only if b = br.
c           ----------------------------------------------------
c
c           compute the chebyshev series expansion of the
c           following function
c           f2 = (0.5*(b+bl-a-a)+0.5*(b-bl)*x)**alfa
c                *f(0.5*(b-bl)*x+0.5*(b+bl))
c
  140 hlgth = 0.5d+00*(br-bl)
      centr = 0.5d+00*(br+bl)
      fix = centr-a
      fval(1) = 0.5d+00*f(hlgth+centr)*(fix+hlgth)**alfa
      fval(13) = f(centr)*(fix**alfa)
      fval(25) = 0.5d+00*f(centr-hlgth)*(fix-hlgth)**alfa
      do 150 i=2,12
        u = hlgth*x(i-1)
        isym = 26-i
        fval(i) = f(u+centr)*(fix+u)**alfa
        fval(isym) = f(centr-u)*(fix-u)**alfa
  150 continue
      factor = hlgth**(beta+0.1d+01)
      result = 0.0d+00
      abserr = 0.0d+00
      res12 = 0.0d+00
      res24 = 0.0d+00
      if(integr.eq.2.or.integr.eq.4) go to 200
c
c           integr = 1  (or 3)
c
      call dqcheb(x,fval,cheb12,cheb24)
      do 160 i=1,13
        res12 = res12+cheb12(i)*rj(i)
        res24 = res24+cheb24(i)*rj(i)
  160 continue
      do 170 i=14,25
        res24 = res24+cheb24(i)*rj(i)
  170 continue
      if(integr.eq.1) go to 260
c
c           integr = 3
c
      dc = dlog(br-bl)
      result = res24*dc
      abserr = dabs((res24-res12)*dc)
      res12 = 0.0d+00
      res24 = 0.0d+00
      do 180 i=1,13
        res12 = res12+cheb12(i)*rh(i)
        res24 = res24+cheb24(i)*rh(i)
  180 continue
      do 190 i=14,25
        res24 = res24+cheb24(i)*rh(i)
  190 continue
      go to 260
c
c           compute the chebyshev series expansion of the
c           following function
c           f3 = f2*log(0.5*(b-bl)*x+0.5*(b+bl-a-a))
c
  200 fval(1) = fval(1)*dlog(hlgth+fix)
      fval(13) = fval(13)*dlog(fix)
      fval(25) = fval(25)*dlog(fix-hlgth)
      do 210 i=2,12
        u = hlgth*x(i-1)
        isym = 26-i
        fval(i) = fval(i)*dlog(u+fix)
        fval(isym) = fval(isym)*dlog(fix-u)
  210 continue
      call dqcheb(x,fval,cheb12,cheb24)
c
c           integr = 2  (or 4)
c
      do 220 i=1,13
        res12 = res12+cheb12(i)*rj(i)
        res24 = res24+cheb24(i)*rj(i)
  220 continue
      do 230 i=14,25
        res24 = res24+cheb24(i)*rj(i)
  230 continue
      if(integr.eq.2) go to 260
      dc = dlog(br-bl)
      result = res24*dc
      abserr = dabs((res24-res12)*dc)
      res12 = 0.0d+00
      res24 = 0.0d+00
c
c           integr = 4
c
      do 240 i=1,13
        res12 = res12+cheb12(i)*rh(i)
        res24 = res24+cheb24(i)*rh(i)
  240 continue
      do 250 i=14,25
        res24 = res24+cheb24(i)*rh(i)
  250 continue
  260 result = (result+res24)*factor
      abserr = (abserr+dabs(res24-res12))*factor
  270 return
      end