!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!!!!!!! FEAST Expert Driver Example - Banded Storage
!!!!!!! solving Ax=ex with A complex-symmetric (non-Hermitian)
!!!!!!! James Kestyn, Eric Polizzi 2015
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
program pdriver

  implicit none

  include 'mpif.h'

!!!!!!!!!!!!!!!!! Feast declaration variable
  integer,dimension(64) :: feastparam
  integer :: loop
  character :: UPLO='F'
!!!!!!!!!!!!!!!!! Matrix declaration variable
  character(len=100) :: name
  integer :: n,nnz,kl,ku,LDA
  complex(kind=kind(1.0d0)),dimension(:,:),allocatable :: A

!!!!!!!!!!!!!!!!! Custom Contour
  integer :: ccN
  complex(kind=kind(1.0d0)),dimension(:),allocatable :: Zne, Wne, Zedge
  integer, dimension(:), allocatable :: Nedge, Tedge

!!!!!!!!!!!!!!!!! FEAST
  integer :: M0,M,info
  complex(kind=kind(1.0d0)) :: Emid
  double precision :: r,epsout
  double precision,dimension(:),allocatable :: resr ! residual
  complex(kind=kind(1.0d0)),dimension(:,:),allocatable :: XR ! eigenvectors
  complex(kind=kind(1.0d0)),dimension(:),allocatable :: E ! eigenvalues

!!!!!!!!!!!!!!!!! Others
  double precision :: rea,img
  integer :: t1,t2,tim
  integer :: i,j,k

!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! MPI!!!!!!!!!!!!!!!!!!!!
integer :: code,rank,nb_procs
  call MPI_INIT(code)
  call MPI_COMM_SIZE(MPI_COMM_WORLD,nb_procs,code)
  call MPI_COMM_RANK(MPI_COMM_WORLD,rank,code)

!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!!!!!!!!!!!!!!! read input file in coordinate format!!!!!!!
!!!!!!!!!!!!!!!!transform  in banded format directly !!!!!!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
  name='../../system4'

  !! find kl (ku=kl)
  kl=0
  open(10,file=trim(name),status='old')
  read(10,*) n,nnz
  do k=1,nnz
     read(10,*) i,j
     if ((i-j)>kl) kl=(i-j)
  end do
  close(10)

  !! form the banded matrix A
  allocate(A(2*kl+1,N))
  LDA=2*kl+1
  A=0.0d0
  open(10,file=trim(name),status='old')
  read(10,*) N,nnz
  do k=1,nnz
     read(10,*) i,j,rea,img
     A(kl+1+(i-j),j) = rea*(1.0d0,0.0d0) + img*(0.0d0,1.0d0)
  end do
  close(10)

!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!!!!!!!!!!!!!!!!!!!!!! INFORMATION ABOUT MATRIX !!!!!!!!!!!!!!!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
  if(rank==0) print *,'banded matrix -system4- size',n
  if(rank==0) print *,'bandwidth',kl

  call system_clock(t1,tim)
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!!!!!!!!!!!!!!!!!!! FEAST in banded format !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!

  call feastinit(feastparam)
  feastparam(1)=1
  feastparam(6)=1
  M0=50 !! M0>=M

  !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
  ! Create Custom Contour

  ccN = 3     !! number of pieces that make up contour
  allocate(Zedge(1:ccN))
  allocate(Nedge(1:ccN))
  allocate(Tedge(1:ccN))

  !!! Example contour - triangle
  Zedge = (/(0.10d0,0.410d0),(4.2d0,0.41d0),(4.2d0,-8.3d0)/)
  Tedge(:) = (/0,0,0/)
  Nedge(:) = (/6,6,18/)

  !! Note: user must specify total # of contour points and edit feastparam(8)
  feastparam(8) = sum(Nedge(1:ccN))
  allocate(Zne(1:feastparam(8))) !! Contains the complex valued contour points
  allocate(Wne(1:feastparam(8))) !! Contains the complex valued integrations weights

  !! Fill Zne/Wne
  call zfeast_customcontour(feastparam(8),ccN,Nedge,Tedge,Zedge,Zne,Wne)

if(rank==0)then
  print *,'---- Printing Countour ----'
  do i=1,feastparam(8)
     write(*,*)i,dble(Zne(i)),aimag(Zne(i))
  enddo
endif
  !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!

!!!!!!!!!!!!! ALLOCATE VARIABLE
  allocate(E(1:M0))     ! Eigenvalue
  allocate(XR(1:n,1:M0)) ! Eigenvectors
  allocate(resr(1:M0))   ! Residual (if needed)

!!!!!!!!!!!!!  FEAST

  if(rank==0) print *, 'Enter FEAST'
  call zfeast_sbevx(UPLO,N,kl,A,LDA,feastparam,epsout,loop,Emid,r,M0,E,XR,M,resr,info,Zne,Wne)

!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!!!!!!!!!! POST-PROCESSING !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
  call system_clock(t2,tim)
  if(rank==0) print *,'FEAST OUTPUT INFO',info
  if (info==0 .and. rank==0) then
     print *,'*************************************************'
     print *,'************** REPORT ***************************'
     print *,'*************************************************'
     print *,'SIMULATION TIME',(t2-t1)*1.0d0/tim
     print *,'# mode found/subspace',M,M0
     print *,'# iterations',loop
     print *,'TRACE',sum(E(1:M))
     print *,'Relative error on the Trace',epsout
     print *,'Eigenvalues/Residuals'
     do i=1,M
        print *,i,E(i),resr(i)
     enddo
  endif

  call MPI_FINALIZE(code)

end program pdriver


PROGRAM mscka

! Code converted using TO_F90 by Alan Miller
! Date: 2004-06-28  Time: 12:58:12

!     ============================================================
!     Purpose: This program computes the expansion coefficients
!     of the prolate and oblate spheroidal functions,
!     c2k, using subroutine SCKA
!     Input :  m  --- Mode parameter
!     n  --- Mode parameter
!     c  --- Spheroidal parameter
!     cv --- Characteristic value
!     KD --- Function code
!     KD=1 for prolate; KD=-1 for oblate
!     Output:  CK(k) --- Expansion coefficients ck;
!     CK(1), CK(2),... correspond to
!     c0, c2,...
!     Example: Compute the first 13 expansion coefficients C2k for
!     KD= 1, m=2, n=3, c=3.0 and cv=14.8277782138; and
!     KD=-1, m=2, n=3, c=3.0 and cv=8.80939392077

!     Coefficients of Prolate and oblate functions

!     k         C2k(c)              C2k(-ic)
!     ---------------------------------------------
!     0     .9173213327D+01     .2489664942D+02
!     1     .4718258929D+01    -.1205287032D+02
!     2     .9841212916D+00     .2410564082D+01
!     3     .1151870224D+00    -.2735821590D+00
!     4     .8733916403D-02     .2026057157D-01
!     5     .4663888254D-03    -.1061946315D-02
!     6     .1853910398D-04     .4158091152D-04
!     7     .5708084895D-06    -.1264400411D-05
!     8     .1402786472D-07     .3074963448D-07
!     9     .2817194508D-09    -.6120579463D-09
!     10     .4712094447D-11     .1015900041D-10
!     11     .6667838485D-13    -.1427953361D-12
!     12     .8087995432D-15     .1721924955D-14
!     ============================================================

IMPLICIT DOUBLE PRECISION (a-h,o-z)
DIMENSION ck(200),eg(200)
WRITE(*,*)'Please KD, m, n and c '
!     READ(*,*)KD,M,N,C
kd=1
m=2
n=3
c=3.0
CALL segv(m,n,c,kd,cv,eg)
WRITE(*,30)kd,m,n,c,cv
CALL scka(m,n,c,cv,kd,ck)
WRITE(*,*)
IF (kd == 1) THEN
  WRITE(*,*)'Coefficients of Prolate function'
  WRITE(*,*)
  WRITE(*,*)'   k            C2k(c)'
ELSE
  WRITE(*,*)'Coefficients of Oblate function'
  WRITE(*,*)
  WRITE(*,*)'   k           C2k(-ic)'
END IF
WRITE(*,*)'----------------------------'
nm=25+INT((n-m)/2+c)
DO  k=1,nm
  WRITE(*,20)k-1,ck(k)
END DO
20   FORMAT(2X,i3,4X,d18.10)
30   FORMAT(1X,3HKD=,i3,',  ',2HM=,i3,',  ',2HN=,i3,',  ',2HC=,  &
    f5.1,',  ',4HCV =,f18.10)
END PROGRAM mscka

SUBROUTINE scka(m,n,c,cv,kd,ck)

!     ======================================================
!     Purpose: Compute the expansion coefficients of the
!     prolate and oblate spheroidal functions, c2k
!     Input :  m  --- Mode parameter
!     n  --- Mode parameter
!     c  --- Spheroidal parameter
!     cv --- Characteristic value
!     KD --- Function code
!     KD=1 for prolate; KD=-1 for oblate
!     Output:  CK(k) --- Expansion coefficients ck;
!     CK(1), CK(2),... correspond to
!     c0, c2,...
!     ======================================================

INTEGER, INTENT(IN)                      :: m
INTEGER, INTENT(IN)                      :: n
DOUBLE PRECISION, INTENT(IN OUT)         :: c
DOUBLE PRECISION, INTENT(IN)             :: cv
INTEGER, INTENT(IN)                      :: kd
DOUBLE PRECISION, INTENT(OUT)            :: ck(200)
IMPLICIT DOUBLE PRECISION (a-h,o-z)

IF (c <= 1.0D-10) c=1.0D-10
nm=25+INT((n-m)/2+c)
cs=c*c*kd
ip=1
IF (n-m == 2*INT((n-m)/2)) ip=0
fs=1.0D0
f1=0.0D0
f0=1.0D-100
kb=0
ck(nm+1)=0.0D0
DO  k=nm,1,-1
  f=(((2.0D0*k+m+ip)*(2.0D0*k+m+1.0D0+ip)-cv+cs)*f0  &
      -4.0D0*(k+1.0D0)*(k+m+1.0D0)*f1)/cs
  IF (DABS(f) > DABS(ck(k+1))) THEN
    ck(k)=f
    f1=f0
    f0=f
    IF (DABS(f) > 1.0D+100) THEN
      DO  k1=nm,k,-1
        ck(k1)=ck(k1)*1.0D-100
      END DO
      f1=f1*1.0D-100
      f0=f0*1.0D-100
    END IF
  ELSE
    kb=k
    fl=ck(k+1)
    f1=1.0D0
    f2=0.25D0*((m+ip)*(m+ip+1.0)-cv+cs)/(m+1.0)*f1
    ck(1)=f1
    IF (kb == 1) THEN
      fs=f2
    ELSE IF (kb == 2) THEN
      ck(2)=f2
      fs=0.125D0*(((m+ip+2.0)*(m+ip+3.0)-cv+cs)*f2 -cs*f1)/(m+2.0)
    ELSE
      ck(2)=f2
      DO  j=3,kb+1
        f=0.25D0*(((2.0*j+m+ip-4.0)*(2.0*j+m+ip-  &
            3.0)-cv+cs)*f2-cs*f1)/((j-1.0)*(j+m-1.0))
        IF (j <= kb) ck(j)=f
        f1=f2
        f2=f
      END DO
      fs=f
    END IF
    EXIT
  END IF
END DO
20   su1=0.0D0
DO  k=1,kb
  su1=su1+ck(k)
END DO
su2=0.0D0
DO  k=kb+1,nm
  su2=su2+ck(k)
END DO
r1=1.0D0
DO  j=1,(n+m+ip)/2
  r1=r1*(j+0.5D0*(n+m+ip))
END DO
r2=1.0D0
DO  j=1,(n-m-ip)/2
  r2=-r2*j
END DO
IF (kb == 0) THEN
  s0=r1/(2.0D0**n*r2*su2)
ELSE
  s0=r1/(2.0D0**n*r2*(fl/fs*su1+su2))
END IF
DO  k=1,kb
  ck(k)=fl/fs*s0*ck(k)
END DO
DO  k=kb+1,nm
  ck(k)=s0*ck(k)
END DO
RETURN
END SUBROUTINE scka

SUBROUTINE segv(m,n,c,kd,cv,eg)

!     =========================================================
!     Purpose: Compute the characteristic values of spheroidal
!     wave functions
!     Input :  m  --- Mode parameter
!     n  --- Mode parameter
!     c  --- Spheroidal parameter
!     KD --- Function code
!     KD=1 for Prolate; KD=-1 for Oblate
!     Output:  CV --- Characteristic value for given m, n and c
!     EG(L) --- Characteristic value for mode m and n'
!     ( L = n' - m + 1 )
!     =========================================================

INTEGER, INTENT(IN)                      :: m
INTEGER, INTENT(IN)                      :: n
DOUBLE PRECISION, INTENT(IN)             :: c
INTEGER, INTENT(IN)                      :: kd
DOUBLE PRECISION, INTENT(OUT)            :: cv
DOUBLE PRECISION, INTENT(OUT)            :: eg(200)
IMPLICIT DOUBLE PRECISION (a-h,o-z)
DIMENSION b(100),h(100),d(300),e(300),f(300),cv0(100),a(300) ,g(300)

IF (c < 1.0D-10) THEN
  DO  i=1,n
    eg(i)=(i+m)*(i+m-1.0D0)
  END DO
ELSE
  icm=INT((n-m+2)/2)
  nm=10+INT(0.5*(n-m)+c)
  cs=c*c*kd
  DO  l=0,1
    DO  i=1,nm
      IF (l == 0) k=2*(i-1)
      IF (l == 1) k=2*i-1
      dk0=m+k
      dk1=m+k+1
      dk2=2*(m+k)
      d2k=2*m+k
      a(i)=(d2k+2.0)*(d2k+1.0)/((dk2+3.0)*(dk2+5.0))*cs
      d(i)=dk0*dk1+(2.0*dk0*dk1-2.0*m*m-1.0)/((dk2-1.0) *(dk2+3.0))*cs
      g(i)=k*(k-1.0)/((dk2-3.0)*(dk2-1.0))*cs
    END DO
    DO  k=2,nm
      e(k)=DSQRT(a(k-1)*g(k))
      f(k)=e(k)*e(k)
    END DO
    f(1)=0.0D0
    e(1)=0.0D0
    xa=d(nm)+DABS(e(nm))
    xb=d(nm)-DABS(e(nm))
    nm1=nm-1
    DO  i=1,nm1
      t=DABS(e(i))+DABS(e(i+1))
      t1=d(i)+t
      IF (xa < t1) xa=t1
      t1=d(i)-t
      IF (t1 < xb) xb=t1
    END DO
    DO  i=1,icm
      b(i)=xa
      h(i)=xb
    END DO
    DO  k=1,icm
      DO  k1=k,icm
        IF (b(k1) < b(k)) THEN
          b(k)=b(k1)
          EXIT
        END IF
      END DO
      35      IF (k /= 1.AND.h(k) < h(k-1)) h(k)=h(k-1)
      DO WHILE (1==1)
        40       x1=(b(k)+h(k))/2.0D0
        cv0(k)=x1
        IF (DABS((b(k)-h(k))/x1) < 1.0D-14) EXIT
        j=0
        s=1.0D0
        DO  i=1,nm
          IF (s == 0.0D0) s=s+1.0D-30
          t=f(i)/s
          s=d(i)-t-x1
          IF (s < 0.0D0) j=j+1
        END DO
        IF (j < k) THEN
          h(k)=x1
        ELSE
          b(k)=x1
          IF (j >= icm) THEN
            b(icm)=x1
          ELSE
            IF (h(j+1) < x1) h(j+1)=x1
            IF (x1 < b(j)) b(j)=x1
          END IF
        END IF
      END DO
      50      cv0(k)=x1
      IF (l == 0) eg(2*k-1)=cv0(k)
      IF (l == 1) eg(2*k)=cv0(k)
    END DO
  END DO
END IF
70   cv=eg(n-m+1)
RETURN
END SUBROUTINE segv


!-----------------------------------------------------------------------
      program test
      implicit none
      include 'ceed/fortran.h'

      integer ceed,err,i,j
      integer b,p
      parameter(p=4)
      real*8 collograd1d(36),x2(6)
      real*8 grad1d(16),qref(6)
      integer*8 gradoffset,qoffset
      real*8 sum

      character arg*32

      call getarg(1,arg)

      call ceedinit(trim(arg)//char(0),ceed,err)

!     Already collocated, GetCollocatedGrad will return grad1d
      call ceedbasiscreatetensorh1lagrange(ceed,1,1,p,p,ceed_gauss_lobatto,b,&
     & err)
      call ceedbasisgetcollocatedgrad(b,collograd1d,err)
      call ceedbasisgetgrad1d(b,grad1d,gradoffset,err)
      do i=0,p-1
        do j=1,p
          if (abs(collograd1d(j+p*i)-grad1d(j+p*i+gradoffset))>1.0D-13) then
! LCOV_EXCL_START
            write(*,*) 'Error in collocated gradient ',collograd1d(j+p*i),' != ',&
     &       grad1d(j+p*i+gradoffset)
! LCOV_EXCL_STOP
          endif
        enddo
      enddo
      call ceedbasisdestroy(b,err)

!     Q = P, not already collocated
      call ceedbasiscreatetensorh1lagrange(ceed,1,1,p,p,ceed_gauss,b,err)
      call ceedbasisgetcollocatedgrad(b,collograd1d,err)

      call ceedbasisgetqref(b,qref,qoffset,err)
      do i=1,p
        x2(i)=qref(i+qoffset)*qref(i+qoffset)
      enddo

      do i=0,p-1
        sum=0
        do j=1,p
            sum=sum+collograd1d(j+p*i)*x2(j)
        enddo
        if (abs(sum-2*qref(i+1+qoffset))>1.0D-13) then
! LCOV_EXCL_START
            write(*,*) 'Error in collocated gradient ',sum,' != ',&
            &       2*qref(i+1+qoffset)
! LCOV_EXCL_STOP
        endif
      enddo
      call ceedbasisdestroy(b,err)

!     Q = P + 2, not already collocated
      call ceedbasiscreatetensorh1lagrange(ceed,1,1,p,p+2,ceed_gauss,b,err)
      call ceedbasisgetcollocatedgrad(b,collograd1d,err)

      call ceedbasisgetqref(b,qref,qoffset,err)
      do i=1,p+2
        x2(i)=qref(i+qoffset)*qref(i+qoffset)
      enddo

      do i=0,p+1
        sum=0
        do j=1,p+2
            sum=sum+collograd1d(j+(p+2)*i)*x2(j)
        enddo
        if (abs(sum-2*qref(i+1+qoffset))>1.0D-13) then
! LCOV_EXCL_START
            write(*,*) 'Error in collocated gradient ',sum,' != ',&
     &       2*qref(i+1+qoffset)
! LCOV_EXCL_STOP
        endif
      enddo
      call ceedbasisdestroy(b,err)

      call ceeddestroy(ceed,err)

      end
!-----------------------------------------------------------------------


!> @ingroup is_sorted
!>
!> @brief
!> Checks if a vector of real values is sorted.
!>
!> @details
!> Checks if a vector of real values is sorted according to the specified ordering.
!>
!> @retval sorted
!> Indicated if the vector of real values is sorted according to the specified ordering.
!>
!> | Value | Meaning                  |
!> |:-----:|:------------------------ |
!> | true  | The vector is sorted     |
!> | false | The vector is not sorted |
!>
!> @param vec
!> The vector of real values to be checked for being sorted.
!>
!> @param ascending
!> Indicates if the ordering to be checked for is ascending or decending.
!>
!> | Value | Meaning         |
!> |:-----:|:--------------- |
!> | true  | Ascending order |
!> | false | Decending order |
!>
!> @note
!> An empty or single value vector is considered sorted.
!>
!> @author Arin R. Bratt
!> @date 12/07/2014

pure function is_sorted_real(vec,ascending) result(sorted)

  ! Parameters
  real, intent(in) :: vec(:)
  logical, intent(in) :: ascending

  ! Result
  logical :: sorted

  ! Check ascending and call the right function.
  if (ascending) then
     sorted = is_sorted_asc_real(vec)
  else
     sorted = is_sorted_dec_real(vec)
  end if

end function is_sorted_real


!> Module for complex overloading
module MOD_COMPLEXIFY
!!===========================================================================!!
implicit none
!!===========================================================================!!
public :: &
  operator (.ge.),&
  operator (.gt.),&
  operator (.le.),&
  operator (.lt.),&
  sign           ,&
  norm2          ,&
  atan2          ,&
  abs            ,&
  dot_product    ,&
  log10
!!===========================================================================!!
private
character(len=*), parameter :: this_mod_name = 'mod_complexify'
!!===========================================================================!!
!! Interfaces
!!===========================================================================!!
interface operator (.ge.)
  module procedure ge_rc
  module procedure ge_cr
  module procedure ge_cc
  module procedure ge_ci
  module procedure ge_ic
end interface
interface operator (.gt.)
  module procedure gt_rc
  module procedure gt_cr
  module procedure gt_cc
  module procedure gt_ci
  module procedure gt_ic
end interface
interface operator (.le.)
  module procedure le_rc
  module procedure le_cr
  module procedure le_cc
  module procedure le_ci
  module procedure le_ic
end interface
interface operator (.lt.)
  module procedure lt_rc
  module procedure lt_cr
  module procedure lt_cc
  module procedure lt_ci
  module procedure lt_ic
end interface

interface sign
  module procedure sign_rc
end interface

interface norm2
  module procedure norm2_c
end interface

interface atan2
  module procedure atan2_cc
end interface

interface abs
  module procedure abs_c
end interface

interface dot_product
  module procedure dot_product_c
end interface

interface log10
  module procedure log10_c
end interface
!!===========================================================================!!
contains
!!===========================================================================!!
logical function ge_rc(val1,val2)
  character(len=*),parameter :: this_sub_name = 'ge_rc'

  real(8),intent(in) :: val1
  complex(8),intent(in) :: val2

  if (val1 .ge. real(val2)) then
    ge_rc = .True.
  else
    ge_rc = .False.
  endif
end function ge_rc

logical function ge_cr(val1,val2)
  character(len=*),parameter :: this_sub_name = 'ge_cr'

  complex(8),intent(in) :: val1
  real(8),intent(in) :: val2

  if (real(val1) .ge. val2) then
    ge_cr = .True.
  else
    ge_cr = .False.
  endif
end function ge_cr

logical function ge_cc(val1,val2)
  character(len=*),parameter :: this_sub_name = 'ge_cc'

  complex(8),intent(in) :: val1
  complex(8),intent(in) :: val2

  if (real(val1) .ge. real(val2)) then
    ge_cc = .True.
  else
    ge_cc = .False.
  endif
end function ge_cc

logical function ge_ci(val1,val2)
  character(len=*),parameter :: this_sub_name = 'ge_ci'

  complex(8),intent(in) :: val1
  integer,intent(in) :: val2

  if (real(val1) .ge. val2) then
    ge_ci = .True.
  else
    ge_ci = .False.
  endif
end function ge_ci

logical function ge_ic(val1,val2)
  character(len=*),parameter :: this_sub_name = 'ge_ic'

  integer,intent(in) :: val1
  complex(8),intent(in) :: val2

  if (val1 .ge. real(val2)) then
    ge_ic = .True.
  else
    ge_ic = .False.
  endif
end function ge_ic

logical function gt_rc(val1,val2)
  character(len=*),parameter :: this_sub_name = 'gt_rc'

  real(8),intent(in) :: val1
  complex(8),intent(in) :: val2

  if (val1 .gt. real(val2)) then
    gt_rc = .True.
  else
    gt_rc = .False.
  endif
end function gt_rc

logical function gt_cr(val1,val2)
  character(len=*),parameter :: this_sub_name = 'gt_cr'

  complex(8),intent(in) :: val1
  real(8),intent(in) :: val2

  if (real(val1) .gt. val2) then
    gt_cr = .True.
  else
    gt_cr = .False.
  endif
end function gt_cr

logical function gt_cc(val1,val2)
  character(len=*),parameter :: this_sub_name = 'gt_cc'

  complex(8),intent(in) :: val1
  complex(8),intent(in) :: val2

  if (real(val1) .gt. real(val2)) then
    gt_cc = .True.
  else
    gt_cc = .False.
  endif
end function gt_cc

logical function gt_ci(val1,val2)
  character(len=*),parameter :: this_sub_name = 'gt_ci'

  complex(8),intent(in) :: val1
  integer,intent(in) :: val2

  if (real(val1) .gt. val2) then
    gt_ci = .True.
  else
    gt_ci = .False.
  endif
end function gt_ci

logical function gt_ic(val1,val2)
  character(len=*),parameter :: this_sub_name = 'gt_ic'

  integer,intent(in) :: val1
  complex(8),intent(in) :: val2

  if (val1 .gt. real(val2)) then
    gt_ic = .True.
  else
    gt_ic = .False.
  endif
end function gt_ic

logical function le_rc(val1,val2)
  character(len=*),parameter :: this_sub_name = 'le_rc'

  real(8),intent(in) :: val1
  complex(8),intent(in) :: val2

  if (val1 .le. real(val2)) then
    le_rc = .True.
  else
    le_rc = .False.
  endif
end function le_rc

logical function le_cr(val1,val2)
  character(len=*),parameter :: this_sub_name = 'le_cr'

  complex(8),intent(in) :: val1
  real(8),intent(in) :: val2

  if (real(val1) .le. val2) then
    le_cr = .True.
  else
    le_cr = .False.
  endif
end function le_cr

logical function le_cc(val1,val2)
  character(len=*),parameter :: this_sub_name = 'le_cc'

  complex(8),intent(in) :: val1
  complex(8),intent(in) :: val2

  if (real(val1) .le. real(val2)) then
    le_cc = .True.
  else
    le_cc = .False.
  endif
end function le_cc

logical function le_ci(val1,val2)
  character(len=*),parameter :: this_sub_name = 'le_ci'

  complex(8),intent(in) :: val1
  integer,intent(in) :: val2

  if (real(val1) .le. val2) then
    le_ci = .True.
  else
    le_ci = .False.
  endif
end function le_ci

logical function le_ic(val1,val2)
  character(len=*),parameter :: this_sub_name = 'le_ic'

  integer,intent(in) :: val1
  complex(8),intent(in) :: val2

  if (val1 .le. real(val2)) then
    le_ic = .True.
  else
    le_ic = .False.
  endif
end function le_ic

logical function lt_rc(val1,val2)
  character(len=*),parameter :: this_sub_name = 'lt_rc'

  real(8),intent(in) :: val1
  complex(8),intent(in) :: val2

  if (val1 .lt. real(val2)) then
    lt_rc = .True.
  else
    lt_rc = .False.
  endif
end function lt_rc

logical function lt_cr(val1,val2)
  character(len=*),parameter :: this_sub_name = 'lt_cr'

  complex(8),intent(in) :: val1
  real(8),intent(in) :: val2

  if (real(val1) .lt. val2) then
    lt_cr = .True.
  else
    lt_cr = .False.
  endif
end function lt_cr

logical function lt_cc(val1,val2)
  character(len=*),parameter :: this_sub_name = 'lt_cc'

  complex(8),intent(in) :: val1
  complex(8),intent(in) :: val2

  if (real(val1) .lt. real(val2)) then
    lt_cc = .True.
  else
    lt_cc = .False.
  endif
end function lt_cc

logical function lt_ci(val1,val2)
  character(len=*),parameter :: this_sub_name = 'lt_ci'

  complex(8),intent(in) :: val1
  integer,intent(in) :: val2

  if (real(val1) .lt. val2) then
    lt_ci = .True.
  else
    lt_ci = .False.
  endif
end function lt_ci

logical function lt_ic(val1,val2)
  character(len=*),parameter :: this_sub_name = 'lt_ic'

  integer,intent(in) :: val1
  complex(8),intent(in) :: val2

  if (val1 .lt. real(val2)) then
    lt_ic = .True.
  else
    lt_ic = .False.
  endif
end function lt_ic

function sign_rc(val1,val2)
  character(len=*),parameter :: this_sub_name = 'sign_rc'

  real(8),intent(in) :: val1
  complex(8),intent(in) :: val2

  real(8) :: sign_rc

  sign_rc = sign(val1,real(val2))
end function sign_rc

function norm2_c(val)
  character(len=*),parameter :: this_sub_name = 'norm2'

  complex(8),dimension(:),intent(in) :: val

  real(8) :: norm_real
  real(8) :: norm_complex

  real(8) :: norm2_c

  norm_real = norm2(real(val))
  norm_complex = norm2(aimag(val))

  norm2_c = (norm_real**2 + norm_complex**2)**(0.5)
end function norm2_c

function atan2_cc(val1,val2)
  character(len=*),parameter :: this_sub_name = 'atan2_cc'

  complex(8),intent(in) :: val1
  complex(8),intent(in) :: val2

  complex(8) :: atan2_cc

  real(8) :: r1
  real(8) :: c1
  real(8) :: r2
  real(8) :: c2

  r1 = real(val1)
  c1 = aimag(val1)
  r2 = real(val2)
  c2 = aimag(val2)

  if ((r1 .ne. 0) .or. (r2 .ne. 0)) then
    atan2_cc = cmplx(atan2(r1,r2),(r2*c1-r1*c2)/(r1**2+r2**2),8)
  else
    atan2_cc = cmplx(atan2(r1,r2),0.0,8)
  endif
end function atan2_cc

function abs_c(val)
  character(len=*),parameter :: this_sub_name = 'abs_c'

  complex(8),intent(in) :: val

  complex(8) :: abs_c

  if (real(val) .lt. 0) then
    abs_c = cmplx(-real(val),-aimag(val),8)
  else
    abs_c = val
  endif

end function abs_c

function dot_product_c(val1,val2)
  character(len=*),parameter :: this_sub_name = 'dot_product_c'

  complex(8),dimension(:),intent(in) :: val1
  complex(8),dimension(:),intent(in) :: val2

  complex(8) :: dot_product_c

  integer :: N_elem_1
  integer :: N_elem_2
  integer :: iElem

  N_elem_1 = size(val1)
  N_elem_2 = size(val2)

  dot_product_c = 0

  do iElem = 1,N_elem_1
    dot_product_c = dot_product_c + val1(iElem)*val2(iElem)
  enddo
end function dot_product_c

function log10_c(val)
  character(len=*),parameter :: this_sub_name = 'log10_c'

  complex(8),intent(in) :: val
  complex(8) :: log10_c

  log10_c = log(val)/log(10.0_8)

end function log10_c
end module MOD_COMPLEXIFY


       subroutine derx_1(q3, q4)

!----------------------------------------------------------- !
!               F. Califano, 2006                            !
!  First x-derivative by FFT (periodic boundary conditions)  !
!----------------------------------------------------------- !

!**************************************************
!  MPI PARALLEL VERSION: VALENTINI-FAGANELLO 2009
!*************************************************

use parameter_mod
use box_mod
use deriv_mod

IMPLICIT NONE

integer :: i

REAL(dp),DIMENSION (nx) :: q3, q4

!do i = 1, nx
!q3(i) = exp(x(i))
!enddo

!     Soluzione del sistema lineare tridiagonale fattorizzato LU
!     Differenze finite compatte 3x5

    do i = 3, nx2
     q4(i) = a_1_3x5 * (q3(i+1) - q3(i-1)) + b_1_3x5 * (q3(i+2) - q3(i-2))
    enddo

!     Differenze finite compatte 3x3 in i=2, nx-1

    q4(2)   = a_1_3x3 * (q3(3) - q3(1))
    q4(nx1) = a_1_3x3 * (q3(nx) - q3(nx2))

SELECT CASE (ibc) ! *** 1 = free, 2 = fixed ***

 CASE (1)

!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!     FREE boundary condition (left and right), I derivative, i=1, i=nx  !
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!

     q4(1)  = a_1_bc * q3(1) + b_1_bc * q3(2) &
            + c_1_bc * q3(3) + d_1_bc * q3(4)

     q4(nx) = - a_1_bc * q3(nx)  - b_1_bc * q3(nx1) &
              - c_1_bc * q3(nx2) - d_1_bc * q3(nx3)

    CALL  DGTTRS(TRANS,nx,NRHS,dm_1,dd_1,dp_1,dw_1,ipv_d,q4,ndb,INFO)

      if (info > 0 .or. info < 0) then
      write(*,*) 'Problemi soluzione, info:', info
      stop
      endif

 CASE (2)

!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!    Derivata nulla al bordo (left and right), I derivative, i=1, i=nx  !
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!

    q4(1)  = 0.0
    q4(nx) = 0.0

    CALL  DGTTRS(TRANS,nx,NRHS,wm_1,wd_1,wp_1,ww_1,ipv_w,q4,ndb,INFO)

      if (info > 0 .or. info < 0) then
      write(*,*) 'Problemi soluzione, info:', info
      stop
      endif

 CASE (3)

!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!    Derivata costante al bordo (left and right), I derivative, i=1, i=nx  !
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!

    q4(1)  = 0.0
    q4(nx) = 0.0

    CALL  DGTTRS(TRANS,nx,NRHS,qm_1,qd_1,qp_1,qq_1,ipv_q,q4,ndb,INFO)

      if (info > 0 .or. info < 0) then
      write(*,*) 'Problemi soluzione, info:', info
      stop
      endif

 CASE (4)

!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!    Boundary Condition Basate sulle caratteristiche                       !
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!

! in avanzamento e' attiva subroutine BC, per ora poniamo
! la derivata in 1,nx e' calcolata con i punti interni
! e serve solo per poter calcolare la derivata in 2,nx-1

     q4(1)  = a_1_bc * q3(1) + b_1_bc * q3(2) &
            + c_1_bc * q3(3) + d_1_bc * q3(4)

     q4(nx) = - a_1_bc * q3(nx)  - b_1_bc * q3(nx1) &
              - c_1_bc * q3(nx2) - d_1_bc * q3(nx3)

    CALL  DGTTRS(TRANS,nx,NRHS,dm_1,dd_1,dp_1,dw_1,ipv_d,q4,ndb,INFO)

      if (info > 0 .or. info < 0) then
      write(*,*) 'Problemi soluzione, info:', info
      stop
      endif

  END SELECT

!write(*,*) 'derivata numerica'
!write(*,*) q4(1)
!write(*,*) 'valore analitico'
!write(*,*) exp(x(1))

!write(*,*) 'derivata numerica'
!write(*,*) q4(10)
!write(*,*) 'valore analitico'
!write(*,*) exp(x(10))

!write(*,*) 'derivata numerica'
!write(*,*) q4(nx)
!write(*,*) 'valore analitico'
!write(*,*) exp(x(nx))
!call syncronize()
!stop

end subroutine


MODULE bberf_module ! error function

  PRIVATE
  PUBLIC :: bberf
  PUBLIC :: bberfc

CONTAINS

!------------------------------------------------------
! written by J. Iwata
!------------------------------------------------------

  FUNCTION bberf( x )
    implicit none
    real(8) :: bberf
    real(8),intent(IN) :: x
#ifdef _NO_ERF_
    bberf=1.0d0-ccerf(x) ! if buil-in erf is not avaialbe
#else
    bberf=erf(x)
#endif
  END FUNCTION bberf

  FUNCTION bberfc( x )
    implicit none
    real(8) :: bberfc
    real(8),intent(IN) :: x
#ifdef _NO_ERF_
    bberfc=ccerf(x) ! if buil-in erfc is not avaialbe
#else
    bberfc=erfc(x)
#endif
  END FUNCTION bberfc

  FUNCTION ccerf( x )
    implicit none
    real(8) :: ccerf
    real(8),intent(IN) :: x
    real(8),parameter :: pi = 3.141592653589793d0
    real(8) :: y,alpha,tny,eps,delta
    real(8) :: ai,bi,f0,f1,C0,C1,D0,D1,a0
    integer :: nmax,i

    if ( abs(x) < 0.1d0 ) then
       ccerf=1.0d0-2.0d0/sqrt(pi)*(x-x**3/3.0d0+0.1d0*x**5 &
                  -x**7/42.0d0+x**9/216.0d0-x**11/1320.0d0 )
       return
    end if

    nmax  = 100000
    eps   = epsilon(1.0d0)
    tny   = tiny(1.0d0)
    alpha = 0.5d0

    y = x*x

    f0 = tny
    C0 = f0
    D0 = 0.0d0
    a0 = 1.0d0

    do i=1,nmax
       bi = y + 2.0d0*i - 1.0d0 - alpha
       ai = -(i-1)*(i-1-alpha) + a0
       ai = -(i-1)*(i-1.5d0) + a0
       D1 = bi + ai*D0
       if ( D1 == 0.0d0 ) D1=tny
       C1 = bi + ai/C0
       if ( C1 == 0.0d0 ) C1=tny
       D1 = 1.0d0/D1
       delta = C1*D1
       f1 = f0*delta
       if ( abs(delta-1.0d0) < eps ) exit
       f0 = f1
       C0 = C1
       D0 = D1
       a0 = 0.0d0
    end do

    ccerf = sign( f1*exp(-y)*sqrt(y/pi), x ) + 1.0d0-sign(1.0d0,x)

  END FUNCTION ccerf

END MODULE bberf_module


      SUBROUTINE DACCUM (A,LDA,N,B,LDB,NB,IR1, NROWS, NCOUNT)
c Copyright (c) 1996 California Institute of Technology, Pasadena, CA.
c ALL RIGHTS RESERVED.
c Based on Government Sponsored Research NAS7-03001.
c>> 1996-03-30 DACCUM Krogh   Added external statement.
C>> 1994-11-11 DACCUM Krogh   Declared all vars.
C>> 1994-10-20 DACCUM Krogh  Changes to use M77CON
C>> 1987-11-24 DACCUM Lawson  Initial code.
c--D replaces "?": ?ACCUM, ?ROTG, ?HTCC, ?NRM2
c     Sequential accumulation of rows of data for a linear least
c     squares problem.  Using Givens orthogonal transformations when
c     NROWS is small and Householder orthogonal transformations when
c     NROWS is larger.
c
c        On first call user must set IR1 = 1.  On each return this subr
c     will update IR1 to min(IR1+NROWS, N+2).  The user should not alter
c     IR1 while processing data for the same case.
c
c        On all calls, including the first, the user sets NROWS to
c     indicate the number of rows of new data being provided.  The user
c     must put the new data in rows IR1 through IR1 + NROWS - 1 of the
c     arrays A() and B().  On return, with IR1 updated to
c     min(IR1+NROWS, N+2), the first IR1-1 rows of A() will contain
c     transformed data on and to the right of the diagonal, and zeros
c     to the left of the diagonal.  The first IR1-1 rows of B() will
c     also contain transformed data.
c     ------------------------------------------------------------------
c     Reference: C. L. Lawson & R. J. Hanson,
c                Solving Least Squares Problems, Prentice-Hall, 1974.
c     Original code by R. J. Hanson, JPL, Sept 11, 1968.
c     Adapted to Fortran 77 for the JPL MATH77 library
c     by Lawson, 6/2/87.
c     ------------------------------------------------------------------
c                      Subroutine arguments
c
c     A(,)  [inout]
c     LDA   [in]
c     N     [in]
c     B(,)  [inout]
c     LDB   [in]
c     NB    [in]
c     IR1   [inout]
c     NROWS  [in]
c     NCOUNT  [out]
c     ------------------------------------------------------------------
c     Subprograms called directly: DHTCC, DNRM2, DROTG, IERM1, IERV1
c     ------------------------------------------------------------------
      external DNRM2
      integer    IR1, NB, L1, LAST, LDA, LDB, N, NROWS, MARK
      integer    M, IP, IROW, J, I, NCOUNT
      double precision  DNRM2
      double precision  A(LDA,N), B(LDB,NB), UPARAM, ZERO
      double precision CFAC, SFAC, TEMP
      parameter(ZERO = 0.0D0, MARK = 2)
c     ------------------------------------------------------------------
C
      if (NROWS .le. 0) return
C
      M=IR1+NROWS-1
      if(M .gt. LDA .or. M .gt. LDB) then
         call IERM1('DACCUM',1,0,
     *   'Require LDA .ge. M and LDB .ge M where M = IR1+NROWS-1',
     *   'IR1',IR1, ',')
         call IERV1('NROWS',NROWS, ',')
         call IERV1('LDA',LDA, ',')
         call IERV1('LDB',LDB, '.')
         return
      endif
      if(M .le. N) then
         LAST = M-1
      else
         LAST = N
      endif
c
      if(NROWS .le. MARK) then
c      - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
c           Use Givens transformation for better efficiency when the
c           number of rows being introduced is .le. MARK.
c
         do 50 IP = 1, LAST
            L1 = max(IR1, IP+1)
            do 30 IROW = L1, M
               call DROTG(A(IP,IP), A(IROW,IP), CFAC, SFAC)
               A(IROW,IP) = ZERO
               do 10 J = IP+1,N
                  TEMP = A(IP,J)
                  A(IP,J)   =   CFAC * TEMP + SFAC * A(IROW,J)
                  A(IROW,J) =  -SFAC * TEMP + CFAC * A(IROW,J)
   10          continue
               do 20 J = 1,NB
                  TEMP = B(IP,J)
                  B(IP,J)   =   CFAC * TEMP + SFAC * B(IROW,J)
                  B(IROW,J) =  -SFAC * TEMP + CFAC * B(IROW,J)
   20          continue
   30       continue
   50    continue
c        - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
      else
c        - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
c                 Use Householder transformations
c                 when the number of rows being introduced exceeds MARK.
c
         do 80 IP = 1, LAST
            L1 = max(IR1, IP+1)
            call DHTCC (1,IP,L1,M,A(1,IP),UPARAM,
     *                           A(1,min(IP+1,N)),LDA,N-IP)
            call DHTCC (2, IP, L1, M, A(1,IP),UPARAM,
     *                           B(1,1),LDB,NB)
C
C                      Clear elements just made implicitly zero.
C
            do 60 I = L1, min(M,N+1)
               A(I,IP)=ZERO
   60       continue
   80    continue
c        - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
      endif
c
      if(IR1 .eq. 1) then
         NCOUNT = NROWS
      else
         NCOUNT = NCOUNT + NROWS
      endif
      IR1=min(IR1 + NROWS, N+2)
      if (M .le. N+1) return
C
C     Pack lengths of B() column vectors below row N
C     to single locations each.
C
      do 90 J=1,NB
         B(N+1,J) = DNRM2 (M-N, B(N+1,J), 1)
   90 continue
      return
      end


      subroutine eddf(nang, ang, xi, sum0, sum2)
c
c***********************************************************************
c     calculate zeroth and second moment of specific intensity
c.......................................................................
c     called by: eddfac
c***********************************************************************
c
      include'titan.imp'
c
      dimension ang(1), xi(1)
c
      do 1 i = 1, nang - 1
c
c     equation ef48
c
      sum0 = sum0 + 0.5D0 * (xi(i) + xi(i+1)) * (ang(i+1) - ang(i))
c
c     equation ef50
c
      sum2 = sum2
     .            + (xi(i) * ang(i+1) - xi(i+1) * ang(i))
     .            * (ang(i)**2 + ang(i) * ang(i+1) + ang(i+1)**2) / 3.D0
     .
     .            + (xi(i+1) - xi(i)) * (ang(i)    + ang(i+1))
     .                                * (ang(i)**2 + ang(i+1)**2) / 4.D0
    1 continue
c
      return
      end


      SUBROUTINE TAVISPAK3X(EA,FCN,A,B,C,LUERR,IERR)
      IMPLICIT REAL*8 (A-H,O-Z)
C
C THIS ROUTINE SOLVES FOR THE A,B,C COEFFICIENTS OF THE FUNCTION
C
C        FCN = A*COS(EA) + B*SIN(EA) - C
C
C WHICH IS USED TO APPROXIMATE THE RAM AND SHADOW FUNCTIONS. THREE
C PAIRS OF ECCENTRIC ANOMALY AND FUNCTION VALUES ARE INPUT AND THE
C CURVE PASSES THROUGH THEM.
C
C VARIABLE DIM TYPE I/O DESCRIPTION
C -------- --- ---- --- -----------
C
C EA        3   R*8  I  EA(I) IS THE ECCENTRIC ANOMALY VALUE ASSOCIATED
C                       WITH THE RAM OR SHADOW FUNCTION VALUE FCN(I).
C
C FCN       3   R*8  I  FCN(I) IS THE RAM OR SHADOW FUNCTION VALUE. THE
C                       THREE (EA(I),FCN(I)) PAIRS ARE USED TO DEFINE
C                       THE  A*COS(EA) + B*SIN(EA) - C  CURVE.
C
C A         1   R*8  O  THE 'A' COEFFICIENT IN THE EXPRESSION
C
C B         1   R*8  O  THE 'B' COEFFICIENT IN THE EXPRESSION
C
C C         1   R*8  O  THE 'C' COEFFICIENT IN THE EXPRESSION
C
C IERR      1   I*4  O  = 0, NO ERRORS.
C                       = OTHERWISE, NUMERICAL ERROR. NO A,B,C RETURNED.
C
C***********************************************************************
C
C CODED BY C PETRUZZO GSFC/742 1/86
C    MODIFIED....
C
C***********************************************************************
C
      REAL*8 EA(3),FCN(3)
      REAL*8 A13/-1.D0/, A23/-1.D0/, A33/-1.D0/
      REAL*8 DEGRAD / 57.29577951308232D0 /
C
      DET(A11,A21,A31,A12,A22,A32) =
     *   A11*A22*A33 + A12*A23*A31 + A13*A21*A32
     *  -A31*A22*A13 - A21*A12*A33 - A11*A32*A23
C
      IBUG = 0
      LUBUG = 19
C
      IF(IBUG.NE.0) WRITE(LUBUG,8501) (EA(I)*DEGRAD,I=1,3),FCN
 8501 FORMAT(' TAVISPAK3X DEBUG. INPUT='/,
     *       '        EA=',3G16.8/,
     *       '       FCN=',3G16.8)
C
C THE SHADOW OR RAM FUNCTION DEFINES WHEN A TARGET SATISFIES THE
C AVAILABILITY REQUIREMENT.  WHEN THE FUNCTION IS POSITIVE, IT IS
C AVAILABLE.  WHEN NEGATIVE, IT IS NOT AVAILABLE.  WE APPROXIMATE THE
C FUNCTION BY  FCN = A*COS(EA) + B*SIN(EA) - C.  WE HAVE THREE (EA,FCN)
C PAIRS, SO WE CAN SOLVE FOR A, B, AND C.
C
C
C INITIALIZE
C
      IERR = 0
      COS1 = DCOS(EA(1))
      COS2 = DCOS(EA(2))
      COS3 = DCOS(EA(3))
      SIN1 = DSIN(EA(1))
      SIN2 = DSIN(EA(2))
      SIN3 = DSIN(EA(3))
C
C SOLVE FOR THE A, B, AND C CONSTANTS.
C
      D =  DET( COS1,   COS2,   COS3,   SIN1,   SIN2,   SIN3 )
      IF(DABS(D).LT.1.D-15) THEN
        IERR = 9
        IF(IBUG.NE.0) WRITE(LUBUG,8607) D
 8607   FORMAT(/,' TAVISPAK3X. BAD D-VALUE. VALUE=',G23.16)
        GO TO 9999
        END IF
      AN = DET( FCN(1), FCN(2), FCN(3), SIN1,   SIN2,   SIN3 )
      BN = DET( COS1,   COS2,   COS3,   FCN(1), FCN(2), FCN(3) )
      A = AN/D
      B = BN/D
      C = A * COS1  +  B * SIN1  -  FCN(1)
      IF(IBUG.NE.0) THEN
        TEST1 = A*COS1 + B*SIN1 - C - FCN(1)
        TEST2 = A*COS2 + B*SIN2 - C - FCN(2)
        TEST3 = A*COS3 + B*SIN3 - C - FCN(3)
        WRITE(LUBUG,8602) D,AN,BN,A,B,C,TEST1,TEST2,TEST3
 8602   FORMAT(' TAVISPAK3X DEBUG 8602.'/,
     *       '    D,AN,BN=',3G16.8/,
     *       '    A,B,C=  ',3G16.8/,
     *       '    TEST1,TEST2,TEST3=',3G16.8)
        END IF
C
      IF(IBUG.NE.0) WRITE(LUBUG,8606) A,B,C
 8606 FORMAT(' TAVISPAK3X RETURNING.  A,B,C=',3G15.7)
C
 9999 CONTINUE
      RETURN
      END


!
! Hyperbolic step functions for differentiable replacement of IF statements
!
!
! CREATION HISTORY:
!       Written by:     Paul van Delst, 09-Nov-2010
!                       paul.vandelst@noaa.gov
!

MODULE Hyperbolic_Step

  ! -----------------
  ! Environment setup
  ! -----------------
  ! Module use
  USE Type_Kinds, ONLY: fp
  ! Disable implicit typing
  IMPLICIT NONE

  ! ------------
  ! Visibilities
  ! ------------
  PRIVATE
  PUBLIC :: Step
  PUBLIC :: Step_TL
  PUBLIC :: Step_AD

  ! -----------------
  ! Module parameters
  ! -----------------
  CHARACTER(*), PARAMETER :: MODULE_VERSION_ID = &
  '$Id$'
  ! Literals
  REAL(fp), PARAMETER :: ZERO   = 0.0_fp
  REAL(fp), PARAMETER :: POINT5 = 0.5_fp
  REAL(fp), PARAMETER :: ONE    = 1.0_fp
  ! X-input maximum value
  REAL(fp), PARAMETER :: XCUTOFF = 70.0_fp

CONTAINS

!--------------------------------------------------------------------------------
!:sdoc+:
!
! NAME:
!       Step
!
! PURPOSE:
!       Subroutine to compute a hyperbolic, differentiable, step function:
!
!         g(x) = 0.5(1 + TANH(x))
!
!       NOTE: No input checking of the validity of the x-argument for use
!             with TANH() is done.
!
! CALLING SEQUENCE:
!       CALL Step( x, g )
!
!
! INPUTS:
!       x:      The function abscissa.
!               UNITS:      N/A
!               TYPE:       REAL(fp)
!               DIMENSION:  Scalar
!               ATTRIBUTES: INTENT(IN)
!
! OUTPUTS:
!       g:      The hyperbolic step function value.
!               UNITS:      N/A
!               TYPE:       REAL(fp)
!               DIMENSION:  Scalar
!               ATTRIBUTES: INTENT(OUT)
!
!:sdoc-:
!--------------------------------------------------------------------------------

  SUBROUTINE Step( x, g )
    REAL(fp), INTENT(IN)  :: x
    REAL(fp), INTENT(OUT) :: g
    g = POINT5 * ( ONE + TANH(x) )
  END SUBROUTINE Step

!--------------------------------------------------------------------------------
!:sdoc+:
!
! NAME:
!       Step_TL
!
! PURPOSE:
!       Subroutine to compute the tangent-linear form of a hyperbolic,
!       differentiable, step function:
!
!         g(x) = 0.5(1 + TANH(x))
!
!       NOTE: Computations are only performed for input |x| < 70 to avoid
!             infinite result for COSH().
!
! CALLING SEQUENCE:
!       CALL Step_TL( x, x_TL, g_TL )
!
!
! INPUTS:
!       x:      The function abscissa.
!               UNITS:      N/A
!               TYPE:       REAL(fp)
!               DIMENSION:  Scalar
!               ATTRIBUTES: INTENT(IN)
!
!       x_TL:   The tangent-linear abscissa.
!               UNITS:      N/A
!               TYPE:       REAL(fp)
!               DIMENSION:  Scalar
!               ATTRIBUTES: INTENT(IN)
!
! OUTPUTS:
!       g_TL:   The tangent-linear hyperbolic step function value.
!               UNITS:      N/A
!               TYPE:       REAL(fp)
!               DIMENSION:  Scalar
!               ATTRIBUTES: INTENT(OUT)
!
!:sdoc-:
!--------------------------------------------------------------------------------

  SUBROUTINE Step_TL( x, x_TL, g_TL )
    REAL(fp), INTENT(IN)  :: x, x_TL
    REAL(fp), INTENT(OUT) :: g_TL
    IF ( ABS(x) < XCUTOFF ) THEN
      g_TL = POINT5 * x_TL / COSH(x)**2
    ELSE
      g_TL = ZERO
    END IF
  END SUBROUTINE Step_TL

!--------------------------------------------------------------------------------
!:sdoc+:
!
! NAME:
!       Step_AD
!
! PURPOSE:
!       Subroutine to compute the adjoint of a hyperbolic, differentiable,
!       step function:
!
!         g(x) = 0.5(1 + TANH(x))
!
!       NOTE: Computations are only performed for input |x| < 70 to avoid
!             infinite result for COSH().
!
! CALLING SEQUENCE:
!       CALL Step_AD( x, g_AD, x_AD )
!
!
! INPUTS:
!       x:      The function abscissa.
!               UNITS:      N/A
!               TYPE:       REAL(fp)
!               DIMENSION:  Scalar
!               ATTRIBUTES: INTENT(IN)
!
!       g_AD:   The adjoint hyperbolic step function value.
!               NOTE: *** SET TO ZERO UPON EXIT ***
!               UNITS:      N/A
!               TYPE:       REAL(fp)
!               DIMENSION:  Scalar
!               ATTRIBUTES: INTENT(IN OUT)
!
! OUTPUTS:
!       x_AD:   The adjoint abscissa.
!               NOTE: *** MUST CONTAIN VALUE UPON ENTRY ***
!               UNITS:      N/A
!               TYPE:       REAL(fp)
!               DIMENSION:  Scalar
!               ATTRIBUTES: INTENT(IN OUT)
!
!:sdoc-:
!--------------------------------------------------------------------------------

  SUBROUTINE Step_AD( x, g_AD, x_AD )
    REAL(fp), INTENT(IN)     :: x
    REAL(fp), INTENT(IN OUT) :: g_AD  ! AD Input
    REAL(fp), INTENT(IN OUT) :: x_AD  ! AD Output
    IF ( ABS(x) < XCUTOFF ) THEN
      x_AD = x_AD + POINT5 * g_AD / COSH(x)**2
    END IF
    g_AD = ZERO
  END SUBROUTINE Step_AD

END MODULE Hyperbolic_Step


** Part of the LLVM Project, under the Apache License v2.0 with LLVM Exceptions.
** See https://llvm.org/LICENSE.txt for license information.
** SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception

*   Intrinsics and generics - AINT, DINT, ..., CABS.

	parameter(n = 23)
	integer rslts(n), expect(n)
	real  rrslts(n), rexpect(n)
	equivalence (rslts, rrslts), (expect, rexpect)

	double precision d3, d349, d36
	complex c43

	data i234 / 234 /
	data x349, xn39 / 3.49, -3.9 /
	data d3, d349, d36 / 3d0, 3.49d0, 3.6d0 /
	data c43  / (4.0, 3.0) /

c ---- tests 1 - 5:  AINT, DINT:

	data (rexpect(i), i = 1, 5) /2.0, -3.0, -2.0, 3.0, 2.0 /
	rrslts(1) = aint(2.1)
	rrslts(2) = aint(xn39)
	rrslts(3) = sngl( aint(-2.9D0) )
	rrslts(4) = aint(d36)
	rrslts(5) = sngl( dint(2.0d0) )

c ---- tests 6 - 13: ANINT, DNINT, NINT, IDNINT:

	data (rexpect(i), i = 6, 9) / 3.0, -4.0, 249653.0, 3.0 /
	rrslts(6) = anint( 2.5 )
	rrslts(7) = anint( xn39 )
	rrslts(8) = sngl( anint(249653.1d0) )
	rrslts(9) = sngl( dnint(d349) )

	data (expect(i), i = 10, 13) / 23, -4, 4, 4 /
	rslts(10) = nint(22.5)
	rslts(11) = nint(xn39)
	rslts(12) = nint(d36 + .41)
	rslts(13) = idnint(.39 + d36)

c ---- tests 14 - 23: IABS, ABS, DABS, CABS:

	data (expect(i), i = 14, 16) / 5, 234, 234 /
	rslts(14) = iabs(-5)
	rslts(15) = iabs(i234)
	rslts(16) = abs( - i234 )

	data (rexpect(i), i = 17, 21) /
     +        23.47, 3.49, 2.341d-3, 2.0, +2.3d0 /
	rrslts(17) = abs(-23.47)
	rrslts(18) = abs(x349)
	rrslts(19) = sngl( abs(2.341d-3) )
	rrslts(20) = sngl( abs(1.0 - d3) )
	rrslts(21) = dabs(-2.3d0)

	data expect(22), expect(23) / 130, 50 /
	rslts(22) = nint(10 * cabs((-12.0, 5.0)))
	rslts(23) = nint(10 * abs( c43 ))

c ---- check results:

	call check(rslts, expect, n)

	end


!------------------------------------------------------------------------------
!------------------------------------------------------------------------------
!   pen :    Coupled pendula (or rotations in coupled Josephson junctions)
!------------------------------------------------------------------------------
!------------------------------------------------------------------------------

      SUBROUTINE FUNC(NDIM,U,ICP,PAR,IJAC,F,DFDU,DFDP)
!     ---------- ----

      IMPLICIT NONE
      INTEGER, INTENT(IN) :: NDIM, ICP(*), IJAC
      DOUBLE PRECISION, INTENT(IN) :: U(NDIM), PAR(*)
      DOUBLE PRECISION, INTENT(OUT) :: F(NDIM)
      DOUBLE PRECISION, INTENT(INOUT) :: DFDU(NDIM,NDIM), DFDP(NDIM,*)

      DOUBLE PRECISION GAMMA,EPS,RI,PH1,PH2,PS1,PS2

       GAMMA = PAR(1)
       EPS   = PAR(2)
       RI    = PAR(3)

       PH1=U(1)
       PH2=U(2)
       PS1=U(3)
       PS2=U(4)

       F(1)= PS1
       F(2)= PS2
       F(3)= -EPS*PS1 - SIN(PH1) + RI + GAMMA*(PH2-PH1)
       F(4)= -EPS*PS2 - SIN(PH2) + RI + GAMMA*(PH1-PH2)

      END SUBROUTINE FUNC

      SUBROUTINE STPNT(NDIM,U,PAR,T)
!     ---------- -----

      IMPLICIT NONE
      INTEGER, INTENT(IN) :: NDIM
      DOUBLE PRECISION, INTENT(INOUT) :: U(NDIM),PAR(*)
      DOUBLE PRECISION, INTENT(IN) :: T

      DOUBLE PRECISION GAMMA,EPS,RI

       GAMMA=0.175
       EPS=0.1
       RI=0.4
       PAR(1)=GAMMA
       PAR(2)=EPS
       PAR(3)=RI

! Set the actual period (since the data in pen.dat have scaled time variable)
         PAR(11)=1.5738797205

      END SUBROUTINE STPNT

      SUBROUTINE BCND
      END SUBROUTINE BCND

      SUBROUTINE ICND
      END SUBROUTINE ICND

      SUBROUTINE FOPT
      END SUBROUTINE FOPT

      SUBROUTINE PVLS
      END SUBROUTINE PVLS


module quicksort

! sort routine to arrange array elements from smallest to largest
!
! grabbed from A millers web site http://users.bigpond.net.au/amiller/
! Quick sort routine from:
! Brainerd, W.S., Goldberg, C.H. & Adams, J.C. (1990) "Programmer's Guide to
! Fortran 90", McGraw-Hill  ISBN 0-07-000248-7, pages 149-150.
! Modified by Alan Miller to include an associated integer array which gives
! the positions of the elements in the original order.
! pjr added module declaration
! mvr modified integer array to intent inout - may now be any integer
!     array that gets sorted along with associated real array

implicit none
save
private
public quick_sort
contains

RECURSIVE SUBROUTINE quick_sort(list, order)

use shr_kind_mod, only: r4 => shr_kind_r4
implicit none

REAL(r4), DIMENSION (:), INTENT(INOUT)  :: list
INTEGER, DIMENSION (:), INTENT(INOUT)  :: order

! Local variable
INTEGER :: i

CALL quick_sort_1(1, SIZE(list))

CONTAINS

RECURSIVE SUBROUTINE quick_sort_1(left_end, right_end)

implicit none
INTEGER, INTENT(IN) :: left_end, right_end

!     Local variables
INTEGER             :: i, j, itemp
REAL(r4)                :: reference, temp
INTEGER, PARAMETER  :: max_simple_sort_size = 6

IF (right_end < left_end + max_simple_sort_size) THEN
  ! Use interchange sort for small lists
  CALL interchange_sort(left_end, right_end)

ELSE
  ! Use partition ("quick") sort
  reference = list((left_end + right_end)/2)
  i = left_end - 1; j = right_end + 1

  DO
    ! Scan list from left end until element >= reference is found
    DO
      i = i + 1
      IF (list(i) >= reference) EXIT
    END DO
    ! Scan list from right end until element <= reference is found
    DO
      j = j - 1
      IF (list(j) <= reference) EXIT
    END DO

    IF (i < j) THEN
      ! Swap two out-of-order elements
      temp = list(i); list(i) = list(j); list(j) = temp
      itemp = order(i); order(i) = order(j); order(j) = itemp
    ELSE IF (i == j) THEN
      i = i + 1
      EXIT
    ELSE
      EXIT
    END IF
  END DO

  IF (left_end < j) CALL quick_sort_1(left_end, j)
  IF (i < right_end) CALL quick_sort_1(i, right_end)
END IF

END SUBROUTINE quick_sort_1

SUBROUTINE interchange_sort(left_end, right_end)

implicit none
INTEGER, INTENT(IN) :: left_end, right_end

!     Local variables
INTEGER             :: i, j, itemp
REAL(r4)                :: temp

DO i = left_end, right_end - 1
  DO j = i+1, right_end
    IF (list(i) > list(j)) THEN
      temp = list(i); list(i) = list(j); list(j) = temp
      itemp = order(i); order(i) = order(j); order(j) = itemp
    END IF
  END DO
END DO

END SUBROUTINE interchange_sort

END SUBROUTINE quick_sort

end module quicksort


c     program DRDSFIT
c>> 1996-07-03 DRDSFIT Krogh Special code for C conversion.
c>> 1996-06-19 DRDSFIT Krogh Changes in formats for C conversion.
c>> 1996-05-28 DRDSFIT Krogh Added external & removed Fortran 90 syntax
c>> 1994-10-19 DRDSFIT Krogh Changes to use M77CON
c>> 1992-11-18 DRDSFIT CLL   Changed order of arguments in DSFIT.
c>> 1992-10-29 C. L. Lawson, JPL
c    Demonstration driver for DSFIT, DSVAL, DSQUAD, DSTOP, DPVAL, DPQUAD
c     ------------------------------------------------------------------
c--D replaces "?": DR?SFIT, ?SFIT, ?SVAL, ?SQUAD, ?STOP, ?PVAL, ?PQUAD
c--&                 ?PRPL
c     ------------------------------------------------------------------
c++ Code for .C. is inactive
c%%   long int k;
c++ End
      integer I, IERR, NXY, KORDER, MPC, NCOEF, NDERIV, NPC, NT, LDW
      parameter(NXY = 12, NCOEF=8, KORDER=4, NT = NCOEF+KORDER,LDW = 10)
      parameter(MPC = NCOEF-KORDER+1)
      external DSVAL, DSQUAD, DPVAL, DPQUAD
      double precision BDIF(NCOEF*KORDER), DSVAL, DSQUAD, DPVAL, DPQUAD
      double precision BCOEF(NCOEF), PCOEF(MPC*KORDER)
      double precision SD(1), SIGFAC, TKNOTS(NT), W(LDW,KORDER+1)
      double precision X(NXY), XI(MPC+1), Y(NXY), YFIT, Z
      character IMAGE*31
      data X / 2.D0, 4.D0, 6.D0, 8.D0,10.D0,12.D0,
     *        14.D0,16.D0,18.D0,20.D0,22.D0,24.D0/
      data Y /2.2D0,4.0D0,5.0D0,4.6D0,2.8D0,2.7D0,
     *        3.8D0,5.1D0,6.1D0,6.3D0,5.0D0,2.0D0/
      data TKNOTS / 4*2.0D0, 6.4D0, 10.8D0, 15.2D0, 19.6D0, 4*24.0D0 /
      data NDERIV / 0 /
      data SD(1) / -1.0D0 /
c     ------------------------------------------------------------------
      print'('' DRDSFIT''/ '' Demo driver for DSFIT, DSVAL, DSQUAD,'',
     *  '' DSTOP, DPVAL, DPQUAD'')'
      print'(/''   KORDER ='',i3,'',  NCOEF ='',i3)', KORDER, NCOEF
c++ Code for ~.C. is active
      print'(''   TKNOTS() = '',4f10.5/(14x,4f10.5))',
     *   (TKNOTS(I), I = 1, NT)
c++ Code for .C. is inactive
c%%     printf( "\n   TKNOTS() = ");
c%%     for (i = 1; i <= NT+3; i+=4){
c%%        for (k = i; k <= min( i+3, NT ); k++)
c%%           printf( "%10.5f", Tknots[k] );
c%%        if (i + 3 < NT) printf( "\n              ");}
c++ End
      call DSFIT(X, Y, SD, NXY, KORDER, NCOEF, TKNOTS, BCOEF,
     *           SIGFAC,IERR, LDW, W)
c++ Code for ~.C. is active
      print'(/'' After call to DSFIT:''/''   IERR ='',i5,
     *  '',  SIGFAC ='', f10.5 //''   BCOEF() = '',
     *  4f10.5/(13x,4f10.5))', IERR, SIGFAC, (BCOEF(I),I=1,NCOEF)
c++ Code for .C. is inactive
c%%     printf( "\n After call to DSFIT:\n   IERR =%5ld,  SIGFAC ="
c%%        "%10.5f\n\n   BCOEF() = ", ierr, sigfac);
c%%     for (i = 1; i <= NCOEF+3; i+=4){
c%%        for (k = i; k <= min( i+3, NCOEF ); k++)
c%%           printf( "%10.5f", Bcoef[k] );
c%%        if (i + 3 < NCOEF) printf( "\n             ");}
c++ End
      print'(/'' Evaluating fitted spline function using DSVAL:'')'
      print'(/
     * ''    I    X       Y       YFIT  R=Y-YFIT               YFIT''/)'

      do 20 I=1,NXY
       YFIT=  DSVAL(KORDER, NCOEF, TKNOTS, BCOEF, X(I), NDERIV)
       call DPRPL(YFIT, '*', IMAGE, 31, 1.9d0, 6.3d0, .true.)
       print'(3x,i2,f6.0,2f9.3,f10.3,3x,a31)',
     *    I, X(I), Y(I), YFIT, Y(I)-YFIT, IMAGE
   20 continue

      Z = DSQUAD(KORDER, NCOEF, TKNOTS, BCOEF, 5.0d0, 20.0d0)
      print'(/'' Integral from 5.0  to 20.0 using DSQUAD:'',f12.5)',Z

      call DSTOP(KORDER, NCOEF, TKNOTS, BCOEF, BDIF, NPC, XI, PCOEF)
      print'(/
     * '' Using DSTOP to convert from B-spline basis to power basis.'')'
      print'(''        NPC ='',i3)',NPC
c++ Code for ~.C. is active
      print'(''       XI() = '',4f10.5/(14x,4f10.5))',(XI(I),I=1,NPC+1)
      print'(''    PCOEF() = '',4f10.5/(14x,4f10.5))',
     *   (PCOEF(I),I=1,NPC*KORDER)
c++ Code for .C. is inactive
c%%   printf( "       XI() = ");
c%%   for (i = 1; i <= (npc + 1); i+=4){
c%%      for (k = i; k <= min( i+3, npc+1 ); k++)
c%%           printf( "%10.5f", Xi[k] );
c%%      if (i <= npc) printf( "\n              ");}
c%%   printf( "\n    PCOEF() = ");
c%%   for (i = 1; i <= (npc*KORDER); i+=4){
c%%      for (k = i; k <= min( i+3, npc*KORDER ); k++)
c%%           printf( "%10.5f", Pcoef[k] );
c%%      if (i < npc*KORDER) printf( "\n              ");}
c++ End
      print'(/'' Evaluating fitted spline function using DPVAL:'')'
      print'(/
     * ''    I    X       Y       YFIT  R=Y-YFIT               YFIT''/)'

      do 40 I=1,NXY
       YFIT=  DPVAL(KORDER, NPC, XI, PCOEF, X(I), NDERIV)
       call DPRPL(YFIT, '*', IMAGE, 31, 1.9d0, 6.3d0, .true.)
       print'(3x,i2,f6.0,2f9.3,f10.3,3x,a31)',
     *    I, X(I), Y(I), YFIT, Y(I)-YFIT, IMAGE
   40 continue

      Z = DPQUAD(KORDER, NPC, XI, PCOEF, 5.0d0, 20.0d0)
      print'(/'' Integral from 5.0  to 20.0 using DPQUAD:'',f12.5)',Z
      end


! { dg-do run }
!
! Check simplification of MERGE.
!

  INTEGER, PARAMETER :: array(3) = [1, 2, 3]
  LOGICAL, PARAMETER :: mask(3)  = [ .TRUE., .FALSE., .TRUE. ]

  INTEGER, PARAMETER :: scalar_1 = MERGE (1, 0, .TRUE.)
  INTEGER, PARAMETER :: scalar_2 = MERGE (0, 1, .FALSE.)

  INTEGER, PARAMETER :: array_1(3) = MERGE (array, 0, .TRUE.)
  INTEGER, PARAMETER :: array_2(3) = MERGE (array, 0, .FALSE.)
  INTEGER, PARAMETER :: array_3(3) = MERGE (0, array, .TRUE.)
  INTEGER, PARAMETER :: array_4(3) = MERGE (0, array, .FALSE.)
  INTEGER, PARAMETER :: array_5(3) = MERGE (1, 0, mask)
  INTEGER, PARAMETER :: array_6(3) = MERGE (array, -array, mask)

  INTEGER, PARAMETER :: array_7(3) = MERGE ([1,2,3], -array, mask)

  IF (scalar_1 /= 1 .OR. scalar_2 /= 1) CALL abort
  IF (.NOT. ALL (array_1 == array)) CALL abort
  IF (.NOT. ALL (array_2 == [0, 0, 0])) CALL abort
  IF (.NOT. ALL (array_3 == [0, 0, 0])) CALL abort
  IF (.NOT. ALL (array_4 == array)) CALL abort
  IF (.NOT. ALL (array_5 == [1, 0, 1])) CALL abort
  IF (.NOT. ALL (array_6 == [1, -2, 3])) CALL abort
END


! examples/Fortran/lsmr.f90 - Example code for SPRAL_LSMR package
program spral_lsmr_example
    use  spral_lsmr
    implicit none

    integer, parameter :: wp = kind( 1.0d+0 )

    type ( lsmr_keep )    :: keep
    type ( lsmr_options ) :: options
    type ( lsmr_inform )  :: inform

    integer :: ptr(4), row(9)
    real(wp) :: b(5), u(5), v(3), val(9), x(3)

    integer :: action, m, n, stat

    ! Data for matrix:
    ! ( 1.0     -1.0 )
    ! (     2.0      )
    ! ( 2.0      2.0 )
    ! ( 5.0 3.0 -2.0 )
    ! (          6.0 )
    m = 5; n = 3
    ptr(1:n+1)        = (/ 1,               4,         6,                 10 /)
    row(1:ptr(n+1)-1) = (/ 1,     3,   4,   2,   4,    1,   3,    4,   5 /)
    val(1:ptr(n+1)-1) = (/ 1.0, 2.0, 5.0, 2.0, 3.0, -1.0, 2.0, -2.0, 6.0 /)
    ! Data for rhs b
    b(1:m) = (/ 1.0, 1.0, 1.0, 1.0, 1.0 /)

    ! prepare for LSMR calls (using no preconditioning and default
    ! settings, except switch off diagnostic printing)
    options%unit_diagnostics = -1
    action = 0
    u(1:m) = b(1:m)

    do

       call lsmr_solve(action, m, n, u, v, x, keep, options, inform)

       if (action.eq.0) then
          ! we are done.
          write (*,'(a,i3,a,i3)') ' Exit LSMR with inform%flag = ',inform%flag,&
            ' and inform%itn = ',inform%itn
          write (*,'(a)') ' LS solution is:'
          write (*,'(10f10.2)') x(1:n)
          exit

      else if (action.eq.1) then

            ! Compute v = v + A'*u without altering u
             call matrix_mult_trans(m,n,ptr,row,val,u,v)

      else if (action.eq.2) then

            ! Compute u = u + A*v  without altering v
            call matrix_mult(m,n,ptr,row,val,v,u)

      end if

   end do

   call lsmr_free(keep,stat)

  contains
!**************************************************************
      ! Takes b and computes u = u + A * v (A in CSC format)

      subroutine matrix_mult(m,n,ptr,row,val,v,u)

      integer,  intent(in) :: m,n
      integer,  intent(in) :: ptr(n+1),row(:)
      real(wp), intent(in) :: val(:),v(n)
      real(wp), intent(inout) :: u(m)

      integer:: i,j,k
      real(wp) :: temp

         do j = 1,n
            temp = v(j)
            do k = ptr(j),ptr(j+1)-1
                i = row(k)
                u(i) = u(i) + val(k)*temp
            end do
         end do

      end subroutine matrix_mult

!**************************************************************
      ! Takes b and computes v = v + A^T * u (A in CSC format)

      subroutine matrix_mult_trans(m,n,ptr,row,val,u,v)

      integer,  intent(in) :: m,n
      integer,  intent(in) :: ptr(n+1),row(:)
      real(wp), intent(in) :: val(:),u(m)
      real(wp), intent(inout) :: v(n)

      integer:: i,j,k
      real(wp) :: sum

         do j = 1,n
            sum = 0.0_wp
            do k = ptr(j),ptr(j+1)-1
               i = row(k)
               sum = sum + val(k)*u(i)
            end do
            v(j) = v(j) + sum
         end do

      end subroutine matrix_mult_trans

end program spral_lsmr_example


c The following is the IDL version of the regression routine by Bevington
c Some modification have been made to the book version in regard to the input
c X array and the data type of some of the arrays.

c FUNCTION REGRESS,X,Y,W,YFIT,A0,SIGMA,FTEST,R,RMUL,CHISQ
c;
c;+
c; NAME:
c;	REGRESS
c; PURPOSE:
c;	Multiple linear regression fit.
c;	Fit the function:
c;	Y(i) = A0 + A(0)*X(0,i) + A(1)*X(1,i) + ... +
c;		A(Nterms-1)*X(Nterms-1,i)
c; CATEGORY:
c;	G2 - Correlation and regression analysis.
c; CALLING SEQUENCE:
c;	Coeff = REGRESS(X,Y,W,YFIT,A0,SIGMA,FTEST,RMUL,CHISQ)
c; INPUTS:
c;	X = array of independent variable data.  X must
c;		be dimensioned (Nterms, Npoints) where there are Nterms
c;		coefficients to be found (independent variables) and
c;		Npoints of samples.
c;	Y = vector of dependent variable points, must
c;		have Npoints elements.
c;	W = vector of weights for each equation, must
c;		be a Npoints elements vector.  For no
c;		weighting, set w(i) = 1., for instrumental weighting
c;		w(i) = 1/standard_deviation(Y(i)), for statistical
c;		weighting w(i) = 1./Y(i)
c;
c; OUTPUTS:
c;	Function result = coefficients = vector of
c;		Nterms elements.  Returned as a column
c;		vector.
c;
c; OPTIONAL OUTPUT PARAMETERS:
c;	Yfit = array of calculated values of Y, Npoints
c;		elements.
c;	A0 = Constant term.
c;	Sigma = Vector of standard deviations for
c;		coefficients.
c;	Ftest = value of F for test of fit.
c;	Rmul = multiple linear correlation coefficient.
c;	R = Vector of linear correlation coefficient.
c;	Chisq = Reduced weighted chi squared.
c; COMMON BLOCKS:
c;	None.
c; SIDE EFFECTS:
c;	None.
c; RESTRICTIONS:
c;	None.
c; PROCEDURE:
c;	Adapted from the program REGRES, Page 172,
c;		Bevington, Data Reduction and Error Analysis for the
c;		Physical Sciences, 1969.
c;
c; MODIFICATION HISTORY:
c;	Written, DMS, RSI, September, 1982.
c;-
c;
c SY = SIZE(Y)		;GET DIMENSIONS OF X AND Y.
c SX = SIZE(X)
c IF (N_ELEMENTS(W) NE SY(1)) OR (SX(0) NE 2) OR (SY(1) NE SX(2)) THEN BEGIN
c	PRINT,'REGRESS - Incompatible arrays'
c	RETURN,0
c	ENDIF
c;
c NTERM = SX(1)		;# OF TERMS
c NPTS = SY(1)		;# OF OBSERVATIONS
c ;
c SW = TOTAL(W)		;SUM OF WEIGHTS
c YMEAN = TOTAL(Y*W)/SW	;Y MEAN
c XMEAN = (X * (REPLICATE(1.,NTERM) # W)) # REPLICATE(1./SW,NPTS)
c WMEAN = SW/NPTS
c WW = W/WMEAN
c ;
c NFREE = NPTS-1		;DEGS OF FREEDOM
c SIGMAY = SQRT(TOTAL(WW * (Y-YMEAN)^2)/NFREE) ;W*(Y(I)-YMEAN)
c XX = X- XMEAN # REPLICATE(1.,NPTS)	;X(J,I) - XMEAN(I)
c WX = REPLICATE(1.,NTERM) # WW * XX	;W(I)*(X(J,I)-XMEAN(I))
c SIGMAX = SQRT( XX*WX # REPLICATE(1./NFREE,NPTS)) ;W(I)*(X(J,I)-XM)*(X(K,I)-XM)
c R = WX #(Y - YMEAN) / (SIGMAX * SIGMAY * NFREE)
c ARRAY = INVERT((WX # TRANSPOSE(XX))/(NFREE * SIGMAX #SIGMAX))
c A = (R # ARRAY)*(SIGMAY/SIGMAX)		;GET COEFFICIENTS
c YFIT = A # X				;COMPUTE FIT
c A0 = YMEAN - TOTAL(A*XMEAN)		;CONSTANT TERM
c YFIT = YFIT + A0			;ADD IT IN
c FREEN = NPTS-NTERM-1 > 1		;DEGS OF FREEDOM, AT LEAST 1.
c CHISQ = TOTAL(WW*(Y-YFIT)^2)*WMEAN/FREEN ;WEIGHTED CHI SQUARED
c SIGMA = SQRT(ARRAY(INDGEN(NTERM)*(NTERM+1))/WMEAN/(NFREE*SIGMAX^2)) ;ERROR TERM
c RMUL = TOTAL(A*R*SIGMAX/SIGMAY)		;MULTIPLE LIN REG COEFF
c IF RMUL LT 1. THEN FTEST = RMUL/NTERM / ((1.-RMUL)/FREEN) ELSE FTEST=1.E6
c RMUL = SQRT(RMUL)
c RETURN,A
c END

      subroutine regren (x, ndim1, ndim2, y, weight, npts, nterms, yfit,
     *a0, a, sigmaa, chisqr)
      double precision sum, ymean, sigma, chisq
      integer npts, nterms
      double precision x(ndim1,ndim2),y(1),yfit(1)
      double precision r(20), array(20,20), sigmax(20), xmean(20)
      double precision chisqr, a0, a(1)
      real weight(1), sigmaa(1)
      real sigma0, ftest, freen, free1, rmul
      real fnpts, det, varnce, wmean, freej
      integer i, j, k
c
c initialize sums and arrays
c
11    sum=0.
      ymean=0.
      sigma=0.
      chisq=0.
      rmul=0.
      do 17 i=1,npts
17    yfit(i)=0.
21    do 28 j=1,nterms
      xmean(j)=0.
      sigmax(j)=0.
      r(j)=0.
      a(j)=0.
      sigmaa(j)=0.
      do 28 k=1,nterms
28    array(j,k)=0.
c
c accumulate weighted sums
c
30    do 50 i=1,npts
      sum=sum+weight(i)
      ymean=ymean+weight(i)*y(i)
      do 44 j=1,nterms
44    xmean(j)=xmean(j)+weight(i)*x(j,i)
50    continue
51    ymean=ymean/sum
      do 53 j=1,nterms
53    xmean(j)=xmean(j)/sum
      fnpts=npts
      wmean=sum/fnpts
      do 57 i=1,npts
57    weight(i)=weight(i)/wmean
c
c accumulate matrices r and array
c
61    do 67 i=1,npts
      sigma=sigma+weight(i)*(y(i)-ymean)**2
      do 67 j=1,nterms
      sigmax(j)=sigmax(j)+weight(i)*(x(j,i)-xmean(j))**2
      r(j)=r(j)+weight(i)*(x(j,i)-xmean(j))*(y(i)-ymean)
      do 67 k=1,j
67    array(j,k)=array(j,k)+weight(i)*(x(j,i)-xmean(j))*
     *(x(k,i)-xmean(k))
71    free1=npts-1
72    sigma=dsqrt(sigma/free1)
      do 78 j=1,nterms
74    sigmax(j)=dsqrt(sigmax(j)/free1)
      r(j)=r(j)/(free1*sigmax(j)*sigma)
      do 78 k=1,j
      array(j,k)=array(j,k)/(free1*sigmax(j)*sigmax(k))
78    array(k,j)=array(j,k)
c
c invert symmetric matrix
c
81    call minv20 (array,nterms,det)
      if (det) 101,91,101
91    a0=0.
      sigma0=0.
      rmul=0.
      chisqr=0.
      ftest=0.
      goto 150
c
c calculate coefficients, fit, and chi square
c
101   a0=ymean
102   do 108 j=1,nterms
      do 104 k=1,nterms
104   a(j)=a(j)+r(k)*array(j,k)
105   a(j)=a(j)*sigma/sigmax(j)
106   a0=a0-a(j)*xmean(j)
107   do 108 i=1,npts
108   yfit(i)=yfit(i)+a(j)*x(j,i)
111   do 113 i=1,npts
      yfit(i)=yfit(i)+a0
113   chisq=chisq+weight(i)*(y(i)-yfit(i))**2
      freen=npts-nterms-1
115   chisqr=chisq*wmean/freen
c
c calculate uncertainties
c
124   varnce=chisqr
131   do 133 j=1,nterms
132   sigmaa(j)=array(j,j)*varnce/(free1*sigmax(j)**2)
      sigmaa(j)=sqrt(sigmaa(j))
133   rmul=rmul+a(j)*r(j)*sigmax(j)/sigma
      freej=nterms
c +noao: When rmul = 1, the following division (stmt 135) would blow up.
c        It has been changed so ftest is set to -99999. in this case.
      if (1. - rmul) 135, 935, 135
135   ftest=(rmul/freej)/((1.-rmul)/freen)
      goto 136
935   ftest = -99999.
c -noao
136   rmul=sqrt(rmul)
141   sigma0=varnce/fnpts
      do 145 j=1,nterms
      do 145 k=1,nterms
145   sigma0=sigma0+varnce*xmean(j)*xmean(k)*array(j,k)/
     *(free1*sigmax(j)*sigmax(k))
146   sigma0=sqrt(sigma0)
150   return
      end
c subroutine matinv.f
c
c source
c   bevington, pages 302-303.
c
c purpose
c   invert a symmetric matrix and calculate its determinant
c
c usage
c   call matinv (array, norder, det)
c
c description of parameters
c   array  - input matrix which is replaced by its inverse
c   norder - degree of matrix (order of determinant)
c   det    - determinant of input matrix
c
c subroutines and function subprograms required
c   none
c
c comment
c   dimension statement valid for norder up to 20
c
	subroutine minv20 (array,norder,det)
	double precision array,amax,save
	dimension array(20,20),ik(20),jk(20)
c
10	det=1.
11	do 100 k=1,norder
c
c find largest element array(i,j) in rest of matrix
c
	amax=0.
21	do 30 i=k,norder
	do 30 j=k,norder
23	if (dabs(amax)-dabs(array(i,j))) 24,24,30
24	amax=array(i,j)
	ik(k)=i
	jk(k)=j
30	continue
c
c interchange rows and columns to put amax in array(k,k)
c
31	if (amax) 41,32,41
32	det=0.
	goto 140
41	i=ik(k)
	if (i-k) 21,51,43
43	do 50 j=1,norder
	save=array(k,j)
	array(k,j)=array(i,j)
50	array(i,j)=-save
51	j=jk(k)
	if (j-k) 21,61,53
53	do 60 i=1,norder
	save=array(i,k)
	array(i,k)=array(i,j)
60	array(i,j)=-save
c
c accumulate elements of inverse matrix
c
61	do 70 i=1,norder
	if (i-k) 63,70,63
63	array(i,k)=-array(i,k)/amax
70	continue
71	do 80 i=1,norder
	do 80 j=1,norder
	if (i-k) 74,80,74
74	if (j-k) 75,80,75
75	array(i,j)=array(i,j)+array(i,k)*array(k,j)
80	continue
81	do 90 j=1,norder
	if (j-k) 83,90,83
83	array(k,j)=array(k,j)/amax
90	continue
	array(k,k)=1./amax
100	det=det*amax
c
c restore ordering of matrix
c
101	do 130 l=1,norder
	k=norder-l+1
	j=ik(k)
	if (j-k) 111,111,105
105	do 110 i=1,norder
	save=array(i,k)
	array(i,k)=-array(i,j)
110	array(i,j)=save
111	i=jk(k)
	if (i-k) 130,130,113
113	do 120 j=1,norder
	save=array(k,j)
	array(k,j)=-array(i,j)
120	array(i,j)=save
130	continue
140	return
	end


!*****************************************************************************************
!> author: Jacob Williams
!  date: 11/21/2015
!
!  Test program for the CRTBP routines.

    program crtbp_propagation_test

    use fortran_astrodynamics_toolkit
    use pyplot_module, only: pyplot

    implicit none

    real(wp),parameter :: mu_earth = 398600.436233_wp    !! \( \mu_{Earth} ~ (\mathrm{km}^3/\mathrm{s}^2) \)
    real(wp),parameter :: mu_moon  = 4902.800076_wp      !! \( \mu_{Moon}  ~ (\mathrm{km}^3/\mathrm{s}^2) \)
    real(wp),parameter :: mu_sun   = 132712440017.987_wp !! \( \mu_{Sun}   ~ (\mathrm{km}^3/\mathrm{s}^2) \)

    integer,parameter  :: n  = 6         !! number of state variables
    real(wp),parameter :: t0 = 0.0_wp    !! initial time (normalized)
    real(wp),parameter :: tf = 50.0_wp   !! final time (normalized)
    real(wp),parameter :: dt = 0.01_wp   !! time step (normalized)

    !< initial state (normalized)
    !< see: [Celestial Mechanics Notes Set 4: The Circular Restricted Three Body Problem](http://cosweb1.fau.edu/~jmirelesjames/hw4Notes.pdf), p.40.
    real(wp),dimension(n),parameter :: x0 = [ 0.30910452642073_wp, &
                                              0.07738174525518_wp, &
                                              0.0_wp,              &
                                             -0.72560796964234_wp, &
                                              1.55464233412773_wp, &
                                              0.0_wp               ]

    real(wp),dimension(:),allocatable :: x_crtbp,y_crtbp,z_crtbp
    real(wp)              :: mu    !! CRTPB parameter
    real(wp)              :: c     !! CRTPB Jacobi constant
    type(rk8_10_class)    :: prop  !! integrator
    real(wp),dimension(n) :: xf    !! final state
    type(pyplot)          :: plt   !! for making the plot
    real(wp),dimension(6) :: x0_km
    real(wp),dimension(6) :: x_zvc
    integer :: i,j,nx,ny
    real(wp) :: x,y
    real(wp),dimension(:),allocatable   :: x_vec
    real(wp),dimension(:),allocatable   :: y_vec
    real(wp),dimension(:,:),allocatable :: c_mat
    real(wp) :: x_L1,x_L2,x_L3
    real(wp),dimension(2) :: xy_L4,xy_L5
    integer :: istat

    !for zero-velocity countours:
    real(wp),parameter  :: xmin  = -2.0_wp
    real(wp),parameter  :: xmax  = 2.0_wp
    real(wp),parameter  :: xstep = 0.01_wp
    real(wp),parameter  :: ymin  = -2.0_wp
    real(wp),parameter  :: ymax  = 2.0_wp
    real(wp),parameter  :: ystep = 0.01_wp

    call unnormalize_variables(mu_earth,mu_moon,384400.0_wp,x_crtbp=x0,x=x0_km)

    write(*,*) ''
    write(*,*) ' initial state in km,km/s: '
    write(*,'(*(F30.16,1X))') x0_km
    write(*,*) ''

    !compute the CRTBP parameter & Jacobi constant:
    mu = compute_crtpb_parameter(mu_earth,mu_moon)
    c  = compute_jacobi_constant(mu,x0)

    !*************************************************
    !compute the zero velocity surface for the c

    !Just get the number of elements by counting...
    i=0
    nx=0
    do
        i=i+1
        x = xmin + (i-1)*xstep
        if (x>xmax) exit
        nx = nx + 1
    end do
    j=0
    ny=0
    do
        j=j+1
        y = ymin + (j-1)*ystep
        if (y>ymax) exit
        ny = ny + 1
    end do

    !size the arrays:
    allocate(x_vec(nx))
    allocate(y_vec(ny))
    allocate(c_mat(nx,ny))

    !compute the jacobi constant for each combo:
    do i = 1, nx
        x = xmin + (i-1)*xstep
        x_vec(i) = x
        do j = 1, ny
            y = ymin + (j-1)*ystep
            if (i==1) y_vec(j) = y
            x_zvc(1:3) = [x,y,zero]
            x_zvc(4:6) = zero
            c_mat(i,j) = compute_jacobi_constant(mu,x_zvc)
        end do
    end do

    !*************************************************
    !compute the libration point locations:

    call compute_libration_points(mu,x_L1,x_L2,x_L3,xy_L4,xy_L5)

    write(*,*) ''
    write(*,*) 'mu:  ', mu
    write(*,*) 'x_L1:', x_L1
    write(*,*) 'x_L2:', x_L2
    write(*,*) 'x_L3:', x_L3
    write(*,*) ''

    !*************************************************
    !integrate:
    call prop%initialize(n,func,report)
    call prop%integrate(t0,x0,dt,tf,xf)

    !plot the 2D trajectory, zero-velocity curves, and libration point locations:
    call plt%initialize(grid=.true.,xlabel='x [km]',ylabel='y [km]',&
                            title='CRTBP Example',legend=.false.,figsize=[10,10],&
                            use_numpy=.true.,axis_equal=.true.)

    !trajectory:
    call plt%add_plot(x_crtbp,y_crtbp,label='trajectory',linestyle='b-',linewidth=2,istat=istat)
    !libration point locations:
    call plt%add_plot([x_L1],[zero],        label='L1',linestyle='rx',markersize=3,linewidth=3,istat=istat)
    call plt%add_plot([x_L2],[zero],        label='L2',linestyle='rx',markersize=3,linewidth=3,istat=istat)
    call plt%add_plot([x_L3],[zero],        label='L3',linestyle='rx',markersize=3,linewidth=3,istat=istat)
    call plt%add_plot([xy_L4(1)],[xy_L4(2)],label='L4',linestyle='rx',markersize=3,linewidth=3,istat=istat)
    call plt%add_plot([xy_L5(1)],[xy_L5(2)],label='L5',linestyle='rx',markersize=3,linewidth=3,istat=istat)
    !zero-velocity curve (for this jacobi constant):
    call plt%add_contour(x_vec, y_vec, c_mat, &
                            linestyle='-', linewidth=2, levels=[c], color='r',istat=istat)
    call plt%savefig('crtbp_test.png',istat=istat)
    call plt%destroy()

    contains

    subroutine func(me,t,x,xdot)  !! CRTBP derivative function
    implicit none
    class(rk_class),intent(inout)        :: me
    real(wp),intent(in)                  :: t
    real(wp),dimension(me%n),intent(in)  :: x
    real(wp),dimension(me%n),intent(out) :: xdot

    call crtbp_derivs(mu,x,xdot)

    end subroutine func

    subroutine report(me,t,x)  !! report function
    implicit none
    class(rk_class),intent(inout)       :: me
    real(wp),intent(in)                 :: t
    real(wp),dimension(me%n),intent(in) :: x

    !write(*,'(*(F30.16,1X))') t, x, compute_jacobi_constant(mu,x)

    if (allocated(x_crtbp)) then
        x_crtbp  = [x_crtbp, x(1)]
        y_crtbp  = [y_crtbp, x(2)]
        z_crtbp  = [z_crtbp, x(3)]
    else
        x_crtbp  = [x(1)]
        y_crtbp  = [x(2)]
        z_crtbp  = [x(3)]
    end if

    end subroutine report

    end program crtbp_propagation_test
!*****************************************************************************************


MODULE PARAM
	USE NRTYPE
	IMPLICIT NONE
	!-----------------------------------------------------------
	COMPLEX(DP), PARAMETER :: im = (0,1)
	INTEGER :: N, M, NS, NABL, NZ, MX, NELT, ITER, KU, KL, NDIAG, NN
	INTEGER, ALLOCATABLE, DIMENSION(:) :: IMAT, JMAT, IJA
	REAL(DP) :: C0, L, H, HABL, F, ZS, ABL, K0, lmbda0, Dz, Dr, A0, A2, B, TI, TF, THRESH, ERR
	REAL(DP), ALLOCATABLE, DIMENSION(:) :: LPG, LPG2
	REAL(DP), ALLOCATABLE, DIMENSION(:,:) :: LP, LP2
	REAL(DP) :: H0, X0, S, XL, XR, ANGLE, THETA
	REAL(DP), ALLOCATABLE, DIMENSION(:) :: LIN, TERR, TERR1, TERR2
	COMPLEX(DP) :: ALPHA, P0, TAU1, TAU2, SIGMA1, SIGMA2, IMP, R
	COMPLEX(DP), ALLOCATABLE, DIMENSION(:) :: ALT, C, K, DK2, VALMAT, TEMP
	COMPLEX(DP), ALLOCATABLE, DIMENSION(:,:) :: PHI, P, T, D, M1, M2, MAT, I, E
	TYPE(SPRS2_DP), SAVE :: SPMAT, SP1, SP2
	!-----------------------------------------------------------
END MODULE PARAM


*> \brief \b SGET07
*
*  =========== DOCUMENTATION ===========
*
* Online html documentation available at
*            http://www.netlib.org/lapack/explore-html/
*
*  Definition:
*  ===========
*
*       SUBROUTINE SGET07( TRANS, N, NRHS, A, LDA, B, LDB, X, LDX, XACT,
*                          LDXACT, FERR, CHKFERR, BERR, RESLTS )
*
*       .. Scalar Arguments ..
*       CHARACTER          TRANS
*       LOGICAL            CHKFERR
*       INTEGER            LDA, LDB, LDX, LDXACT, N, NRHS
*       ..
*       .. Array Arguments ..
*       REAL               A( LDA, * ), B( LDB, * ), BERR( * ), FERR( * ),
*      $                   RESLTS( * ), X( LDX, * ), XACT( LDXACT, * )
*       ..
*
*
*> \par Purpose:
*  =============
*>
*> \verbatim
*>
*> SGET07 tests the error bounds from iterative refinement for the
*> computed solution to a system of equations op(A)*X = B, where A is a
*> general n by n matrix and op(A) = A or A**T, depending on TRANS.
*>
*> RESLTS(1) = test of the error bound
*>           = norm(X - XACT) / ( norm(X) * FERR )
*>
*> A large value is returned if this ratio is not less than one.
*>
*> RESLTS(2) = residual from the iterative refinement routine
*>           = the maximum of BERR / ( (n+1)*EPS + (*) ), where
*>             (*) = (n+1)*UNFL / (min_i (abs(op(A))*abs(X) +abs(b))_i )
*> \endverbatim
*
*  Arguments:
*  ==========
*
*> \param[in] TRANS
*> \verbatim
*>          TRANS is CHARACTER*1
*>          Specifies the form of the system of equations.
*>          = 'N':  A * X = B     (No transpose)
*>          = 'T':  A**T * X = B  (Transpose)
*>          = 'C':  A**H * X = B  (Conjugate transpose = Transpose)
*> \endverbatim
*>
*> \param[in] N
*> \verbatim
*>          N is INTEGER
*>          The number of rows of the matrices X and XACT.  N >= 0.
*> \endverbatim
*>
*> \param[in] NRHS
*> \verbatim
*>          NRHS is INTEGER
*>          The number of columns of the matrices X and XACT.  NRHS >= 0.
*> \endverbatim
*>
*> \param[in] A
*> \verbatim
*>          A is REAL array, dimension (LDA,N)
*>          The original n by n matrix A.
*> \endverbatim
*>
*> \param[in] LDA
*> \verbatim
*>          LDA is INTEGER
*>          The leading dimension of the array A.  LDA >= max(1,N).
*> \endverbatim
*>
*> \param[in] B
*> \verbatim
*>          B is REAL array, dimension (LDB,NRHS)
*>          The right hand side vectors for the system of linear
*>          equations.
*> \endverbatim
*>
*> \param[in] LDB
*> \verbatim
*>          LDB is INTEGER
*>          The leading dimension of the array B.  LDB >= max(1,N).
*> \endverbatim
*>
*> \param[in] X
*> \verbatim
*>          X is REAL array, dimension (LDX,NRHS)
*>          The computed solution vectors.  Each vector is stored as a
*>          column of the matrix X.
*> \endverbatim
*>
*> \param[in] LDX
*> \verbatim
*>          LDX is INTEGER
*>          The leading dimension of the array X.  LDX >= max(1,N).
*> \endverbatim
*>
*> \param[in] XACT
*> \verbatim
*>          XACT is REAL array, dimension (LDX,NRHS)
*>          The exact solution vectors.  Each vector is stored as a
*>          column of the matrix XACT.
*> \endverbatim
*>
*> \param[in] LDXACT
*> \verbatim
*>          LDXACT is INTEGER
*>          The leading dimension of the array XACT.  LDXACT >= max(1,N).
*> \endverbatim
*>
*> \param[in] FERR
*> \verbatim
*>          FERR is REAL array, dimension (NRHS)
*>          The estimated forward error bounds for each solution vector
*>          X.  If XTRUE is the true solution, FERR bounds the magnitude
*>          of the largest entry in (X - XTRUE) divided by the magnitude
*>          of the largest entry in X.
*> \endverbatim
*>
*> \param[in] CHKFERR
*> \verbatim
*>          CHKFERR is LOGICAL
*>          Set to .TRUE. to check FERR, .FALSE. not to check FERR.
*>          When the test system is ill-conditioned, the "true"
*>          solution in XACT may be incorrect.
*> \endverbatim
*>
*> \param[in] BERR
*> \verbatim
*>          BERR is REAL array, dimension (NRHS)
*>          The componentwise relative backward error of each solution
*>          vector (i.e., the smallest relative change in any entry of A
*>          or B that makes X an exact solution).
*> \endverbatim
*>
*> \param[out] RESLTS
*> \verbatim
*>          RESLTS is REAL array, dimension (2)
*>          The maximum over the NRHS solution vectors of the ratios:
*>          RESLTS(1) = norm(X - XACT) / ( norm(X) * FERR )
*>          RESLTS(2) = BERR / ( (n+1)*EPS + (*) )
*> \endverbatim
*
*  Authors:
*  ========
*
*> \author Univ. of Tennessee
*> \author Univ. of California Berkeley
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
*> \ingroup single_lin
*
*  =====================================================================
      SUBROUTINE SGET07( TRANS, N, NRHS, A, LDA, B, LDB, X, LDX, XACT,
     $                   LDXACT, FERR, CHKFERR, BERR, RESLTS )
*
*  -- LAPACK test routine --
*  -- LAPACK is a software package provided by Univ. of Tennessee,    --
*  -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
*
*     .. Scalar Arguments ..
      CHARACTER          TRANS
      LOGICAL            CHKFERR
      INTEGER            LDA, LDB, LDX, LDXACT, N, NRHS
*     ..
*     .. Array Arguments ..
      REAL               A( LDA, * ), B( LDB, * ), BERR( * ), FERR( * ),
     $                   RESLTS( * ), X( LDX, * ), XACT( LDXACT, * )
*     ..
*
*  =====================================================================
*
*     .. Parameters ..
      REAL               ZERO, ONE
      PARAMETER          ( ZERO = 0.0E+0, ONE = 1.0E+0 )
*     ..
*     .. Local Scalars ..
      LOGICAL            NOTRAN
      INTEGER            I, IMAX, J, K
      REAL               AXBI, DIFF, EPS, ERRBND, OVFL, TMP, UNFL, XNORM
*     ..
*     .. External Functions ..
      LOGICAL            LSAME
      INTEGER            ISAMAX
      REAL               SLAMCH
      EXTERNAL           LSAME, ISAMAX, SLAMCH
*     ..
*     .. Intrinsic Functions ..
      INTRINSIC          ABS, MAX, MIN
*     ..
*     .. Executable Statements ..
*
*     Quick exit if N = 0 or NRHS = 0.
*
      IF( N.LE.0 .OR. NRHS.LE.0 ) THEN
         RESLTS( 1 ) = ZERO
         RESLTS( 2 ) = ZERO
         RETURN
      END IF
*
      EPS = SLAMCH( 'Epsilon' )
      UNFL = SLAMCH( 'Safe minimum' )
      OVFL = ONE / UNFL
      NOTRAN = LSAME( TRANS, 'N' )
*
*     Test 1:  Compute the maximum of
*        norm(X - XACT) / ( norm(X) * FERR )
*     over all the vectors X and XACT using the infinity-norm.
*
      ERRBND = ZERO
      IF( CHKFERR ) THEN
         DO 30 J = 1, NRHS
            IMAX = ISAMAX( N, X( 1, J ), 1 )
            XNORM = MAX( ABS( X( IMAX, J ) ), UNFL )
            DIFF = ZERO
            DO 10 I = 1, N
               DIFF = MAX( DIFF, ABS( X( I, J )-XACT( I, J ) ) )
 10         CONTINUE
*
            IF( XNORM.GT.ONE ) THEN
               GO TO 20
            ELSE IF( DIFF.LE.OVFL*XNORM ) THEN
               GO TO 20
            ELSE
               ERRBND = ONE / EPS
               GO TO 30
            END IF
*
 20         CONTINUE
            IF( DIFF / XNORM.LE.FERR( J ) ) THEN
               ERRBND = MAX( ERRBND, ( DIFF / XNORM ) / FERR( J ) )
            ELSE
               ERRBND = ONE / EPS
            END IF
 30      CONTINUE
      END IF
      RESLTS( 1 ) = ERRBND
*
*     Test 2:  Compute the maximum of BERR / ( (n+1)*EPS + (*) ), where
*     (*) = (n+1)*UNFL / (min_i (abs(op(A))*abs(X) +abs(b))_i )
*
      DO 70 K = 1, NRHS
         DO 60 I = 1, N
            TMP = ABS( B( I, K ) )
            IF( NOTRAN ) THEN
               DO 40 J = 1, N
                  TMP = TMP + ABS( A( I, J ) )*ABS( X( J, K ) )
   40          CONTINUE
            ELSE
               DO 50 J = 1, N
                  TMP = TMP + ABS( A( J, I ) )*ABS( X( J, K ) )
   50          CONTINUE
            END IF
            IF( I.EQ.1 ) THEN
               AXBI = TMP
            ELSE
               AXBI = MIN( AXBI, TMP )
            END IF
   60    CONTINUE
         TMP = BERR( K ) / ( ( N+1 )*EPS+( N+1 )*UNFL /
     $         MAX( AXBI, ( N+1 )*UNFL ) )
         IF( K.EQ.1 ) THEN
            RESLTS( 2 ) = TMP
         ELSE
            RESLTS( 2 ) = MAX( RESLTS( 2 ), TMP )
         END IF
   70 CONTINUE
*
      RETURN
*
*     End of SGET07
*
      END


    Program zcgesv_example

!     ZCGESV Example Program Text

!     Copyright (c) 2018, Numerical Algorithms Group (NAG Ltd.)
!     For licence see
!       https://github.com/numericalalgorithmsgroup/LAPACK_Examples/blob/master/LICENCE.md

!     .. Use Statements ..
      Use lapack_interfaces, Only: zcgesv
      Use lapack_precision, Only: sp, dp
!     .. Implicit None Statement ..
      Implicit None
!     .. Parameters ..
      Integer, Parameter :: nin = 5, nout = 6
!     .. Local Scalars ..
      Integer :: i, info, iter, j, lda, ldb, ldx, n, r
!     .. Local Arrays ..
      Complex (Kind=dp), Allocatable :: a(:, :), b(:, :), work(:), x(:, :)
      Complex (Kind=sp), Allocatable :: swork(:)
      Real (Kind=dp), Allocatable :: rwork(:)
      Integer, Allocatable :: ipiv(:)
!     .. Executable Statements ..
      Write (nout, *) 'ZCGESV Example Program Results'
      Write (nout, *)
!     Skip heading in data file
      Read (nin, *)
      Read (nin, *) n, r
      lda = n
      ldb = n
      ldx = n
      Allocate (a(lda,n), b(ldb,r), work(n*r), x(ldx,r), swork(n*(n+ &
        r)), ipiv(n), rwork(n))

!     Read A and B from data file

      Read (nin, *)(a(i,1:n), i=1, n)
      Read (nin, *)(b(i,1:r), i=1, n)

!     Solve the equations Ax = b for x

      Call zcgesv(n, r, a, lda, ipiv, b, ldb, x, ldx, work, swork, rwork, &
        iter, info)

      If (info==0) Then

!       Print solution

        Write (nout, *) 'Solution'
        Write (nout, 100)((x(i,r),j=1,r), i=1, n)

!       Print pivot indices

        Write (nout, *)
        Write (nout, *) 'Pivot indices'
        Write (nout, 110) ipiv(1:n)

      Else
        Write (nout, 120) 'The (', info, ',', info, ')', &
          ' element of the factor U is zero'
      End If

100   Format ((3X,4(' (',F7.4,',',F7.4,')',:)))
110   Format (1X, 7I11)
120   Format (1X, A, I3, A, I3, A, A)
    End Program


      SUBROUTINE RICNWT(A,NA,B,NB,H,NH,Q,NQ,R,NR,F,NF,P,NP,IOP,IDENT,DI
     1SC,FNULL,DUMMY)
C
C   PURPOSE:
C      Solve either the continuous or discrete steady-state Riccati
C      equation by the Newton algorithms described by Kleinman and
C      Hewer.
C
C   REFERENCES:
C      Kleinman, David L.: On an Iterative Technique for Riccati Equa-
C        tion Computations. IEEE Trans. Autom. Control, vol. AC-13, no.
C        1, Feb. 1968, pp. 114-115.
C      Hewer, Gary A.: An Iterative Technique for the Computation of
C        the Steady State Gains for the Discrete Optimal Regulator.
C        IEEE Trans. Autom. Control, vol. AC-16, no. 4, Aug. 1971,
C        pp. 382-383.
C      Kantorovich, L.V.; and Akilov, G.P. (D. E. Brown, trans.): Func-
C        tional Analysis in Normed Spaces. A.P. Robertson, ed., Mac-
C        Millan Co., 1964.
C      Sandell, Nils R., Jr.: On Newton's Method for Riccati Equation
C        Solution. IEEE Trans. Autom. Control, vol. AC-19, no. 3, June
C        1974, pp. 254-255.
C      Kwakernaak, Huibert; and Sivan, Raphael: Linear Optimal Control
C        Systems. John Wiley & Sons, Inc., c. 1972.
C
C   Subroutines employed by RICNWT: ADD, BARSTW, BILIN, DPOCO, DPOSL,
C      EQUATE, GELIM, LNCNT, MAXEL, MULT, PRNT, SCALE, SUBT, SUM,
C      SYMPDS, TRANP, UNITY
C   Subroutines employing RICNWT: ASYREG
C
      IMPLICIT REAL*8 (A-H,O-Z)
      DIMENSION A(1),B(1),Q(1),R(1),F(1),P(1),DUMMY(1)
      DIMENSION NA(2),NB(2),NQ(2),NR(2),NF(2),NP(2),IOP(3)
      DIMENSION H(1),NH(2),IOPT(2)
      LOGICAL  IDENT,DISC,FNULL,SYM
      COMMON/TOL/EPSAM,EPSBM,IACM
      COMMON/CONV/SUMCV,MAXSUM,RICTCV,SERCV
C
      I=1
      IOPT(1)=0
      SYM = .TRUE.
C
      N = NA(1)**2
      N1 = N +1
      IF( .NOT. DISC) N1 = NA(1)*NR(1) + 1
      N2= N1+N
      N3= N2+N
      N4 = N3+N
C
      IF( IOP(1) .EQ. 0 )  GO TO 210
      CALL LNCNT(4)
      IF(.NOT. DISC)WRITE(6,100)
      IF( DISC )WRITE(6,150)
  100 FORMAT(BZ,//' PROGRAM TO SOLVE CONTINUOUS STEADY-STATE RICCATI EQU
     1ATION BY THE NEWTON ALGORITHM'/)
  150 FORMAT(//' PROGRAM TO SOLVE DISCRETE STEADY-STATE RICCATI EQUATION
     1 BY THE NEWTON ALGORITHM'/)
      CALL PRNT(A,NA,' A  ',1)
      CALL PRNT(B,NB,' B  ',1)
      CALL PRNT(Q,NQ,' Q  ',1)
      IF( .NOT. IDENT )GO TO 185
      CALL LNCNT(3)
      WRITE(6,180)
  180 FORMAT(/' H IS AN IDENTITY MATRIX'/)
      GO TO 200
  185 CONTINUE
      CALL PRNT(H,NH,' H  ',1)
      CALL MULT(Q,NQ,H,NH,DUMMY,NH)
      CALL TRANP(H,NH,DUMMY(N2),NP)
      CALL MULT(DUMMY(N2),NP,DUMMY,NH,Q,NQ)
      CALL LNCNT(3)
      WRITE(6,195)
  195 FORMAT(/' MATRIX (H TRANSPOSE)QH '/)
      CALL PRNT(Q,NQ,'HTQH',1)
  200 CONTINUE
      CALL PRNT(R,NR,' R  ',1)
      IF( FNULL )  GO TO 210
      CALL LNCNT(3)
      WRITE(6,205)
  205 FORMAT(/' INITIAL F MATRIX'/)
      CALL PRNT(F,NF,' F  ',1)
C
  210 CONTINUE
      IF((IOP(1) .NE. 0)  .OR. IDENT)  GO TO 220
      CALL MULT(Q,NQ,H,NH,DUMMY,NH)
      CALL TRANP(H,NH,DUMMY(N2),NP)
      CALL MULT(DUMMY(N2),NP,DUMMY,NH,Q,NQ)
  220 CONTINUE
C
      IF (DISC) GO TO 900
C
      CALL TRANP(B,NB,P,NP)
      CALL EQUATE(R,NR,DUMMY,NR)
      CALL SYMPDS(NR(1),NR(1),DUMMY,NR(2),P,IOPT,IOPT,DET,ISCALE,DUMMY(N
     11),IERR)
      IF(IERR .NE. 0) GO TO 240
C      GENERATE R-INVERSE
      CALL UNITY(P,NR)
      CALL GELIM(NR(1),NR(1),DUMMY,NR(2),P,DUMMY(N2),0,DUMMY(N1),IERR)
      IF(IERR.EQ.0) GO TO 250
  240 CALL LNCNT(3)
      WRITE(6,225)
  225 FORMAT(/' IN RICNWT, A MATRIX WHICH IS  NOT SYMMETRIC POSITIVE DE
     1FINITE HAS BEEN SUBMITTED TO  SYMPDS'/)
      RETURN
C
  250 CONTINUE
C     CALCULATE (R-INVERSE)*(B-TRANSPOSE) AND STORE IN DUMMY(N1)
      CALL TRANP(B,NB,DUMMY(N2),NF)
      CALL EQUATE(P,NR,DUMMY,NR)
      CALL MULT(DUMMY,NR,DUMMY(N2),NF,DUMMY(N1),NF)
      CALL PRNT(DUMMY,NR,'RINV',1)
C
      IF(FNULL) GO TO 300
C
C     GENERATE THE RECURSIVE EQUATION FOR THE INITIAL RUN
      CALL MULT(B,NB,F,NF,DUMMY(N2),NA)
      CALL SUBT(A,NA,DUMMY(N2),NA,DUMMY(N2),NA)
      CALL TRANP(DUMMY(N2),NA,DUMMY(N3),NA)
      CALL EQUATE(DUMMY(N3),NA,DUMMY(N2),NA)
      CALL MULT(R,NR,F,NF,DUMMY(N3),NF)
      CALL TRANP(F,NF,P,NP)
      CALL MULT(P,NP,DUMMY(N3),NF,DUMMY(N4),NA)
      CALL TRANP(DUMMY(N4),NA,DUMMY(N3),NA)
      CALL ADD(DUMMY(N4),NA,DUMMY(N3),NA,DUMMY(N3),NA)
      CALL SCALE(DUMMY(N3),NA,DUMMY(N3),NA,0.5D0)
      CALL ADD(DUMMY(N3),NA,Q,NQ,P,NP)
      CALL SCALE(P,NP,P,NP,-1.0D0)
      GO TO 350
C
  300 CONTINUE
      CALL TRANP(A,NA,DUMMY(N2),NA)
      CALL SCALE(Q,NQ,P,NP,-1.0D0)
C
  350 CONTINUE
      IF(IOP(3) .NE. 0) GO TO 400
      EPSA= EPSAM
      CALL BARSTW(DUMMY(N2),NA,B,NB,P,NP,IOPT,SYM,EPSA,EPSA,DUMMY(N3))
      GO TO 450
C
  400 CONTINUE
      IOPT(2)=1
      CALL BILIN(DUMMY(N2),NA,B,NB,P,NP,IOPT,SCLE,SYM,DUMMY(N3))
C
  450 CONTINUE
      CALL EQUATE(P,NP,DUMMY(N2),NP)
      IF(IOP(2).EQ. 0) GO TO 550
      CALL LNCNT(3)
      WRITE(6,500) I
  500 FORMAT(/' ITERATION  ',I5/)
      CALL PRNT(P,NP,' P  ',1)
C
  550 CONTINUE
C     GENERATE THE RECURSIVE EQUATION ON THE LOOP
      CALL MULT(DUMMY(N1),NF,P,NP,DUMMY(N3),NF)
      CALL EQUATE(DUMMY(N3),NF,F,NF)
      CALL MULT(R,NR,F,NF,DUMMY(N3),NF)
      CALL TRANP(F,NF,P,NP)
      CALL MULT(P,NP,DUMMY(N3),NF,DUMMY(N4),NA)
      CALL TRANP(DUMMY(N4),NA,DUMMY(N3),NA)
      CALL ADD(DUMMY(N4),NA,DUMMY(N3),NA,DUMMY(N3),NA)
      CALL SCALE(DUMMY(N3),NA,DUMMY(N3),NA,0.5D0)
      CALL ADD(DUMMY(N3),NA,Q,NQ,P,NP)
      CALL SCALE(P,NP,P,NP,-1.0D0)
      CALL MULT(B,NB,F,NF,DUMMY(N3),NA)
      CALL SUBT(A,NA,DUMMY(N3),NA,DUMMY(N4),NA)
      CALL TRANP(DUMMY(N4),NA,DUMMY(N3),NA)
C
      IF(IOP(3) .NE. 0 ) GO TO 650
      CALL BARSTW(DUMMY(N3),NA,B,NB,P,NP,IOPT,SYM,EPSA,EPSA,DUMMY(N4))
      GO TO 675
C
  650 CONTINUE
      CALL BILIN(DUMMY(N3),NA,B,NB,P,NP,IOPT,SCLE,SYM,DUMMY(N4))
C
  675 CONTINUE
      I=I+1
      CALL MAXEL(DUMMY(N2),NA,ANORM1)
      CALL SUBT(P,NP,DUMMY(N2),NA,DUMMY(N3),NA)
      CALL MAXEL(DUMMY(N3),NA,ANORM2)
      IF(ANORM1 .GT. 1.0) GO TO 700
      IF( ANORM2/ANORM1 .LT. RICTCV ) GO TO 800
      GO TO 750
C
  700 CONTINUE
      IF( ANORM2 .LT. RICTCV ) GO TO 800
C
  750 CONTINUE
      IF( I .LE. 101) GO TO 450
      CALL LNCNT(3)
      WRITE(6,775)
  775 FORMAT(/' THE SUBROUTINE RICNWT HAS EXCEEDED 100 ITERATIONS WITHO
     1UT CONVERGENCE'/)
      IOP(1) = 1
C
  800 CONTINUE
      CALL MULT(DUMMY(N1),NF,P,NP,F,NF)
      GO TO 1300
C
  900 CONTINUE
      IF( .NOT. FNULL ) GO TO 950
C
      CALL EQUATE(Q,NQ,P,NP)
      CALL EQUATE(A,NA,DUMMY(N1),NA)
      CALL TRANP(A,NA,DUMMY(N2),NA)
      GO TO 1000
  925 CONTINUE
C
      I=I+1
      CALL EQUATE(P,NP,DUMMY,NP)
  950 CONTINUE
C
      CALL MULT(R,NR,F,NF,DUMMY(N1),NF)
      CALL TRANP(F,NF,P,NP)
      CALL MULT(P,NP,DUMMY(N1),NF,DUMMY(N2),NA)
      CALL TRANP(DUMMY(N2),NA,DUMMY(N1),NA)
      CALL ADD(DUMMY(N1),NA,DUMMY(N2),NA,DUMMY(N1),NA)
      CALL SCALE(DUMMY(N1),NA,DUMMY(N1),NA,0.5D0)
      CALL ADD(Q,NQ,DUMMY(N1),NA,P,NP)
      CALL MULT(B,NB,F,NF,DUMMY(N1),NA)
      CALL SUBT(A,NA,DUMMY(N1),NA,DUMMY(N1),NA)
      CALL TRANP(DUMMY(N1),NA,DUMMY(N2),NA)
C
 1000 CONTINUE
      CALL SUM(DUMMY(N2),NA,P,NP,DUMMY(N1),NA,IOPT,SYM,DUMMY(N3))
      IF(IOP(2) .EQ. 0) GO TO 1100
      CALL LNCNT(3)
      WRITE(6,500) I
      CALL PRNT(P,NP,' P  ',1)
C
 1100 CONTINUE
      CALL MULT(P,NP,A,NA,DUMMY(N1),NA)
      CALL MULT(P,NP,B,NB,DUMMY(N2),NB)
      CALL TRANP(B,NB,DUMMY(N3),NF)
      CALL MULT(DUMMY(N3),NF,DUMMY(N1),NA,F,NF)
      CALL MULT(DUMMY(N3),NF,DUMMY(N2),NB,DUMMY(N1),NR)
      CALL TRANP(DUMMY(N1),NR,DUMMY(N2),NR)
      CALL ADD(DUMMY(N1),NR,DUMMY(N2),NR,DUMMY(N1),NR)
      CALL SCALE(DUMMY(N1),NR,DUMMY(N1),NR,0.5D0)
      CALL ADD(R,NR,DUMMY(N1),NR,DUMMY(N1),NR)
C
C   * * * CALL TO MATHLIB FUNCTIONS * * *
      CALL DPOCO(DUMMY(N1),NR(1),NR(1),RCOND,DUMMY(N2),IERR)
      IF(IERR .EQ. 0) GO TO 1150
      CALL LNCNT(3)
      WRITE(6,1125)
 1125 FORMAT(/' IN RICNWT, A MATRIX WHICH IS NOT POSITIVE DEFINITE HAS B
     1EEN SUBMITTED TO DPOCO'/)
      RETURN
C
 1150 CONTINUE
      NT = 1
      DO 1175 M1 = 1,NA(1)
         CALL DPOSL(DUMMY(N1),NR(1),NR(1),F(NT))
         NT = NT + NR(1)
 1175 CONTINUE
      IF( I .EQ. 1) GO TO 925
      CALL MAXEL(DUMMY,NA,ANORM1)
      CALL SUBT(P,NP,DUMMY,NA,DUMMY(N1),NA)
      CALL MAXEL(DUMMY(N1),NA,ANORM2)
      IF( ANORM1 .GT. 1) GO TO 1200
      IF( ANORM2/ANORM1 .LT. RICTCV ) GO TO 1300
      GO TO 1250
 1200 CONTINUE
      IF( ANORM2 .LT. RICTCV ) GO TO 1300
C
 1250 CONTINUE
      IF( I .LE. 101) GO TO  925
      CALL LNCNT(3)
      WRITE(6,775)
      IOP(1) = 1
C
 1300 CONTINUE
      IF(IOP(1) .EQ. 0 ) RETURN
      CALL LNCNT(4)
      WRITE(6,1350) I
 1350 FORMAT(//' FINAL VALUES OF P AND F AFTER',I5,' ITERATIONS TO CONVE
     1RGE'/)
      CALL PRNT(P,NP,' P  ',1)
      CALL PRNT(F,NF,' F  ',1)
C
      RETURN
      END


c
c	function subroutine for computing time in Julian centuries
c
c	itime(1)=yyyyddd		year (yyyy) and day-of-year (ddd)
c	itime(2)=msec		miliseconds of day in UT
c
	function t0(itime,iyr,iday,ut)
	integer*4 itime(2),iyr,iday
	real ut,t0,rmjd,fracday
c
c get time in Julian centuries
	IYR=itime(1)/1000
	IDAY=itime(1)-IYR*1000
	ut=itime(2)/3600000.0
	fracday=ut/24.0
c
c	RMJD=44238.0+FLOAT(IYR-1980)*365.+
c     &		FLOAT((IYR-1977)/4)+FLOAT(IDAY)
c  rmjd = modified Julian day = time measured in days from 00:00UT November 17, 1858
	rmjd=45.0+float(iyr-1859)*365.0 + (float((iyr-1861)/4)+1.0)
     &		+ float(iday) -1.0 + fracday
	T0=(RMJD-51544.5)/36525.0
c
	return
	end