!*==cgegs.f90  processed by SPAG 7.51RB at 20:37 on  3 Mar 2022
!> \brief  CGEEVX computes the eigenvalues and, optionally, the left and/or right eigenvectors for GE matrices
!
!  =========== DOCUMENTATION ===========
!
! Online html documentation available at
!            http://www.netlib.org/lapack/explore-html/
!
!> \htmlonly
!> Download CGEGS + dependencies
!>
!> [TGZ]
!>
!> [ZIP]
!>
!> [TXT]
!> \endhtmlonly
!
!  Definition:
!  ===========
!
!       SUBROUTINE CGEGS( JOBVSL, JOBVSR, N, A, LDA, B, LDB, ALPHA, BETA,
!                         VSL, LDVSL, VSR, LDVSR, WORK, LWORK, RWORK,
!                         INFO )
!
!       .. Scalar Arguments ..
!       CHARACTER          JOBVSL, JOBVSR
!       INTEGER            INFO, LDA, LDB, LDVSL, LDVSR, LWORK, N
!       ..
!       .. Array Arguments ..
!       REAL               RWORK( * )
!       COMPLEX            A( LDA, * ), ALPHA( * ), B( LDB, * ),
!      $                   BETA( * ), VSL( LDVSL, * ), VSR( LDVSR, * ),
!      $                   WORK( * )
!       ..
!
!
!> \par Purpose:
!  =============
!>
!> \verbatim
!>
!> This routine is deprecated and has been replaced by routine CGGES.
!>
!> CGEGS computes the eigenvalues, Schur form, and, optionally, the
!> left and or/right Schur vectors of a complex matrix pair (A,B).
!> Given two square matrices A and B, the generalized Schur
!> factorization has the form
!>
!>    A = Q*S*Z**H,  B = Q*T*Z**H
!>
!> where Q and Z are unitary matrices and S and T are upper triangular.
!> The columns of Q are the left Schur vectors
!> and the columns of Z are the right Schur vectors.
!>
!> If only the eigenvalues of (A,B) are needed, the driver routine
!> CGEGV should be used instead.  See CGEGV for a description of the
!> eigenvalues of the generalized nonsymmetric eigenvalue problem
!> (GNEP).
!> \endverbatim
!
!  Arguments:
!  ==========
!
!> \param[in] JOBVSL
!> \verbatim
!>          JOBVSL is CHARACTER*1
!>          = 'N':  do not compute the left Schur vectors;
!>          = 'V':  compute the left Schur vectors (returned in VSL).
!> \endverbatim
!>
!> \param[in] JOBVSR
!> \verbatim
!>          JOBVSR is CHARACTER*1
!>          = 'N':  do not compute the right Schur vectors;
!>          = 'V':  compute the right Schur vectors (returned in VSR).
!> \endverbatim
!>
!> \param[in] N
!> \verbatim
!>          N is INTEGER
!>          The order of the matrices A, B, VSL, and VSR.  N >= 0.
!> \endverbatim
!>
!> \param[in,out] A
!> \verbatim
!>          A is COMPLEX array, dimension (LDA, N)
!>          On entry, the matrix A.
!>          On exit, the upper triangular matrix S from the generalized
!>          Schur factorization.
!> \endverbatim
!>
!> \param[in] LDA
!> \verbatim
!>          LDA is INTEGER
!>          The leading dimension of A.  LDA >= max(1,N).
!> \endverbatim
!>
!> \param[in,out] B
!> \verbatim
!>          B is COMPLEX array, dimension (LDB, N)
!>          On entry, the matrix B.
!>          On exit, the upper triangular matrix T from the generalized
!>          Schur factorization.
!> \endverbatim
!>
!> \param[in] LDB
!> \verbatim
!>          LDB is INTEGER
!>          The leading dimension of B.  LDB >= max(1,N).
!> \endverbatim
!>
!> \param[out] ALPHA
!> \verbatim
!>          ALPHA is COMPLEX array, dimension (N)
!>          The complex scalars alpha that define the eigenvalues of
!>          GNEP.  ALPHA(j) = S(j,j), the diagonal element of the Schur
!>          form of A.
!> \endverbatim
!>
!> \param[out] BETA
!> \verbatim
!>          BETA is COMPLEX array, dimension (N)
!>          The non-negative real scalars beta that define the
!>          eigenvalues of GNEP.  BETA(j) = T(j,j), the diagonal element
!>          of the triangular factor T.
!>
!>          Together, the quantities alpha = ALPHA(j) and beta = BETA(j)
!>          represent the j-th eigenvalue of the matrix pair (A,B), in
!>          one of the forms lambda = alpha/beta or mu = beta/alpha.
!>          Since either lambda or mu may overflow, they should not,
!>          in general, be computed.
!> \endverbatim
!>
!> \param[out] VSL
!> \verbatim
!>          VSL is COMPLEX array, dimension (LDVSL,N)
!>          If JOBVSL = 'V', the matrix of left Schur vectors Q.
!>          Not referenced if JOBVSL = 'N'.
!> \endverbatim
!>
!> \param[in] LDVSL
!> \verbatim
!>          LDVSL is INTEGER
!>          The leading dimension of the matrix VSL. LDVSL >= 1, and
!>          if JOBVSL = 'V', LDVSL >= N.
!> \endverbatim
!>
!> \param[out] VSR
!> \verbatim
!>          VSR is COMPLEX array, dimension (LDVSR,N)
!>          If JOBVSR = 'V', the matrix of right Schur vectors Z.
!>          Not referenced if JOBVSR = 'N'.
!> \endverbatim
!>
!> \param[in] LDVSR
!> \verbatim
!>          LDVSR is INTEGER
!>          The leading dimension of the matrix VSR. LDVSR >= 1, and
!>          if JOBVSR = 'V', LDVSR >= N.
!> \endverbatim
!>
!> \param[out] WORK
!> \verbatim
!>          WORK is COMPLEX array, dimension (MAX(1,LWORK))
!>          On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
!> \endverbatim
!>
!> \param[in] LWORK
!> \verbatim
!>          LWORK is INTEGER
!>          The dimension of the array WORK.  LWORK >= max(1,2*N).
!>          For good performance, LWORK must generally be larger.
!>          To compute the optimal value of LWORK, call ILAENV to get
!>          blocksizes (for CGEQRF, CUNMQR, and CUNGQR.)  Then compute:
!>          NB  -- MAX of the blocksizes for CGEQRF, CUNMQR, and CUNGQR;
!>          the optimal LWORK is N*(NB+1).
!>
!>          If LWORK = -1, then a workspace query is assumed; the routine
!>          only calculates the optimal size of the WORK array, returns
!>          this value as the first entry of the WORK array, and no error
!>          message related to LWORK is issued by XERBLA.
!> \endverbatim
!>
!> \param[out] RWORK
!> \verbatim
!>          RWORK is REAL array, dimension (3*N)
!> \endverbatim
!>
!> \param[out] INFO
!> \verbatim
!>          INFO is INTEGER
!>          = 0:  successful exit
!>          < 0:  if INFO = -i, the i-th argument had an illegal value.
!>          =1,...,N:
!>                The QZ iteration failed.  (A,B) are not in Schur
!>                form, but ALPHA(j) and BETA(j) should be correct for
!>                j=INFO+1,...,N.
!>          > N:  errors that usually indicate LAPACK problems:
!>                =N+1: error return from CGGBAL
!>                =N+2: error return from CGEQRF
!>                =N+3: error return from CUNMQR
!>                =N+4: error return from CUNGQR
!>                =N+5: error return from CGGHRD
!>                =N+6: error return from CHGEQZ (other than failed
!>                                               iteration)
!>                =N+7: error return from CGGBAK (computing VSL)
!>                =N+8: error return from CGGBAK (computing VSR)
!>                =N+9: error return from CLASCL (various places)
!> \endverbatim
!
!  Authors:
!  ========
!
!> \author Univ. of Tennessee
!> \author Univ. of California Berkeley
!> \author Univ. of Colorado Denver
!> \author NAG Ltd.
!
!> \date December 2016
!
!> \ingroup complexGEeigen
!
!  =====================================================================
      SUBROUTINE CGEGS(Jobvsl,Jobvsr,N,A,Lda,B,Ldb,Alpha,Beta,Vsl,Ldvsl,&
     &                 Vsr,Ldvsr,Work,Lwork,Rwork,Info)
      IMPLICIT NONE
!*--CGEGS228
!
!  -- LAPACK driver routine (version 3.7.0) --
!  -- LAPACK is a software package provided by Univ. of Tennessee,    --
!  -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
!     December 2016
!
!     .. Scalar Arguments ..
      CHARACTER Jobvsl , Jobvsr
      INTEGER Info , Lda , Ldb , Ldvsl , Ldvsr , Lwork , N
!     ..
!     .. Array Arguments ..
      REAL Rwork(*)
      COMPLEX A(Lda,*) , Alpha(*) , B(Ldb,*) , Beta(*) , Vsl(Ldvsl,*) , &
     &        Vsr(Ldvsr,*) , Work(*)
!     ..
!
!  =====================================================================
!
!     .. Parameters ..
      REAL ZERO , ONE
      PARAMETER (ZERO=0.0E0,ONE=1.0E0)
      COMPLEX CZERO , CONE
      PARAMETER (CZERO=(0.0E0,0.0E0),CONE=(1.0E0,0.0E0))
!     ..
!     .. Local Scalars ..
      LOGICAL ilascl , ilbscl , ilvsl , ilvsr , lquery
      INTEGER icols , ihi , iinfo , ijobvl , ijobvr , ileft , ilo ,     &
     &        iright , irows , irwork , itau , iwork , lopt , lwkmin ,  &
     &        lwkopt , nb , nb1 , nb2 , nb3
      REAL anrm , anrmto , bignum , bnrm , bnrmto , eps , safmin ,      &
     &     smlnum
!     ..
!     .. External Subroutines ..
      EXTERNAL CGEQRF , CGGBAK , CGGBAL , CGGHRD , CHGEQZ , CLACPY ,    &
     &         CLASCL , CLASET , CUNGQR , CUNMQR , XERBLA
!     ..
!     .. External Functions ..
      LOGICAL LSAME
      INTEGER ILAENV
      REAL CLANGE , SLAMCH
      EXTERNAL ILAENV , LSAME , CLANGE , SLAMCH
!     ..
!     .. Intrinsic Functions ..
      INTRINSIC INT , MAX
!     ..
!     .. Executable Statements ..
!
!     Decode the input arguments
!
      IF ( LSAME(Jobvsl,'N') ) THEN
         ijobvl = 1
         ilvsl = .FALSE.
      ELSEIF ( LSAME(Jobvsl,'V') ) THEN
         ijobvl = 2
         ilvsl = .TRUE.
      ELSE
         ijobvl = -1
         ilvsl = .FALSE.
      ENDIF
!
      IF ( LSAME(Jobvsr,'N') ) THEN
         ijobvr = 1
         ilvsr = .FALSE.
      ELSEIF ( LSAME(Jobvsr,'V') ) THEN
         ijobvr = 2
         ilvsr = .TRUE.
      ELSE
         ijobvr = -1
         ilvsr = .FALSE.
      ENDIF
!
!     Test the input arguments
!
      lwkmin = MAX(2*N,1)
      lwkopt = lwkmin
      Work(1) = lwkopt
      lquery = (Lwork==-1)
      Info = 0
      IF ( ijobvl<=0 ) THEN
         Info = -1
      ELSEIF ( ijobvr<=0 ) THEN
         Info = -2
      ELSEIF ( N<0 ) THEN
         Info = -3
      ELSEIF ( Lda<MAX(1,N) ) THEN
         Info = -5
      ELSEIF ( Ldb<MAX(1,N) ) THEN
         Info = -7
      ELSEIF ( Ldvsl<1 .OR. (ilvsl .AND. Ldvsl<N) ) THEN
         Info = -11
      ELSEIF ( Ldvsr<1 .OR. (ilvsr .AND. Ldvsr<N) ) THEN
         Info = -13
      ELSEIF ( Lwork<lwkmin .AND. .NOT.lquery ) THEN
         Info = -15
      ENDIF
!
      IF ( Info==0 ) THEN
         nb1 = ILAENV(1,'CGEQRF',' ',N,N,-1,-1)
         nb2 = ILAENV(1,'CUNMQR',' ',N,N,N,-1)
         nb3 = ILAENV(1,'CUNGQR',' ',N,N,N,-1)
         nb = MAX(nb1,nb2,nb3)
         lopt = N*(nb+1)
         Work(1) = lopt
      ENDIF
!
      IF ( Info/=0 ) THEN
         CALL XERBLA('CGEGS ',-Info)
         RETURN
      ELSEIF ( lquery ) THEN
         RETURN
      ENDIF
!
!     Quick return if possible
!
      IF ( N==0 ) RETURN
!
!     Get machine constants
!
      eps = SLAMCH('E')*SLAMCH('B')
      safmin = SLAMCH('S')
      smlnum = N*safmin/eps
      bignum = ONE/smlnum
!
!     Scale A if max element outside range [SMLNUM,BIGNUM]
!
      anrm = CLANGE('M',N,N,A,Lda,Rwork)
      ilascl = .FALSE.
      IF ( anrm>ZERO .AND. anrm<smlnum ) THEN
         anrmto = smlnum
         ilascl = .TRUE.
      ELSEIF ( anrm>bignum ) THEN
         anrmto = bignum
         ilascl = .TRUE.
      ENDIF
!
      IF ( ilascl ) THEN
         CALL CLASCL('G',-1,-1,anrm,anrmto,N,N,A,Lda,iinfo)
         IF ( iinfo/=0 ) THEN
            Info = N + 9
            RETURN
         ENDIF
      ENDIF
!
!     Scale B if max element outside range [SMLNUM,BIGNUM]
!
      bnrm = CLANGE('M',N,N,B,Ldb,Rwork)
      ilbscl = .FALSE.
      IF ( bnrm>ZERO .AND. bnrm<smlnum ) THEN
         bnrmto = smlnum
         ilbscl = .TRUE.
      ELSEIF ( bnrm>bignum ) THEN
         bnrmto = bignum
         ilbscl = .TRUE.
      ENDIF
!
      IF ( ilbscl ) THEN
         CALL CLASCL('G',-1,-1,bnrm,bnrmto,N,N,B,Ldb,iinfo)
         IF ( iinfo/=0 ) THEN
            Info = N + 9
            RETURN
         ENDIF
      ENDIF
!
!     Permute the matrix to make it more nearly triangular
!
      ileft = 1
      iright = N + 1
      irwork = iright + N
      iwork = 1
      CALL CGGBAL('P',N,A,Lda,B,Ldb,ilo,ihi,Rwork(ileft),Rwork(iright), &
     &            Rwork(irwork),iinfo)
      IF ( iinfo/=0 ) THEN
         Info = N + 1
         GOTO 100
      ENDIF
!
!     Reduce B to triangular form, and initialize VSL and/or VSR
!
      irows = ihi + 1 - ilo
      icols = N + 1 - ilo
      itau = iwork
      iwork = itau + irows
      CALL CGEQRF(irows,icols,B(ilo,ilo),Ldb,Work(itau),Work(iwork),    &
     &            Lwork+1-iwork,iinfo)
      IF ( iinfo>=0 ) lwkopt = MAX(lwkopt,INT(Work(iwork))+iwork-1)
      IF ( iinfo/=0 ) THEN
         Info = N + 2
         GOTO 100
      ENDIF
!
      CALL CUNMQR('L','C',irows,icols,irows,B(ilo,ilo),Ldb,Work(itau),  &
     &            A(ilo,ilo),Lda,Work(iwork),Lwork+1-iwork,iinfo)
      IF ( iinfo>=0 ) lwkopt = MAX(lwkopt,INT(Work(iwork))+iwork-1)
      IF ( iinfo/=0 ) THEN
         Info = N + 3
         GOTO 100
      ENDIF
!
      IF ( ilvsl ) THEN
         CALL CLASET('Full',N,N,CZERO,CONE,Vsl,Ldvsl)
         CALL CLACPY('L',irows-1,irows-1,B(ilo+1,ilo),Ldb,Vsl(ilo+1,ilo)&
     &               ,Ldvsl)
         CALL CUNGQR(irows,irows,irows,Vsl(ilo,ilo),Ldvsl,Work(itau),   &
     &               Work(iwork),Lwork+1-iwork,iinfo)
         IF ( iinfo>=0 ) lwkopt = MAX(lwkopt,INT(Work(iwork))+iwork-1)
         IF ( iinfo/=0 ) THEN
            Info = N + 4
            GOTO 100
         ENDIF
      ENDIF
!
      IF ( ilvsr ) CALL CLASET('Full',N,N,CZERO,CONE,Vsr,Ldvsr)
!
!     Reduce to generalized Hessenberg form
!
      CALL CGGHRD(Jobvsl,Jobvsr,N,ilo,ihi,A,Lda,B,Ldb,Vsl,Ldvsl,Vsr,    &
     &            Ldvsr,iinfo)
      IF ( iinfo/=0 ) THEN
         Info = N + 5
         GOTO 100
      ENDIF
!
!     Perform QZ algorithm, computing Schur vectors if desired
!
      iwork = itau
      CALL CHGEQZ('S',Jobvsl,Jobvsr,N,ilo,ihi,A,Lda,B,Ldb,Alpha,Beta,   &
     &            Vsl,Ldvsl,Vsr,Ldvsr,Work(iwork),Lwork+1-iwork,        &
     &            Rwork(irwork),iinfo)
      IF ( iinfo>=0 ) lwkopt = MAX(lwkopt,INT(Work(iwork))+iwork-1)
      IF ( iinfo/=0 ) THEN
         IF ( iinfo>0 .AND. iinfo<=N ) THEN
            Info = iinfo
         ELSEIF ( iinfo>N .AND. iinfo<=2*N ) THEN
            Info = iinfo - N
         ELSE
            Info = N + 6
         ENDIF
         GOTO 100
      ENDIF
!
!     Apply permutation to VSL and VSR
!
      IF ( ilvsl ) THEN
         CALL CGGBAK('P','L',N,ilo,ihi,Rwork(ileft),Rwork(iright),N,Vsl,&
     &               Ldvsl,iinfo)
         IF ( iinfo/=0 ) THEN
            Info = N + 7
            GOTO 100
         ENDIF
      ENDIF
      IF ( ilvsr ) THEN
         CALL CGGBAK('P','R',N,ilo,ihi,Rwork(ileft),Rwork(iright),N,Vsr,&
     &               Ldvsr,iinfo)
         IF ( iinfo/=0 ) THEN
            Info = N + 8
            GOTO 100
         ENDIF
      ENDIF
!
!     Undo scaling
!
      IF ( ilascl ) THEN
         CALL CLASCL('U',-1,-1,anrmto,anrm,N,N,A,Lda,iinfo)
         IF ( iinfo/=0 ) THEN
            Info = N + 9
            RETURN
         ENDIF
         CALL CLASCL('G',-1,-1,anrmto,anrm,N,1,Alpha,N,iinfo)
         IF ( iinfo/=0 ) THEN
            Info = N + 9
            RETURN
         ENDIF
      ENDIF
!
      IF ( ilbscl ) THEN
         CALL CLASCL('U',-1,-1,bnrmto,bnrm,N,N,B,Ldb,iinfo)
         IF ( iinfo/=0 ) THEN
            Info = N + 9
            RETURN
         ENDIF
         CALL CLASCL('G',-1,-1,bnrmto,bnrm,N,1,Beta,N,iinfo)
         IF ( iinfo/=0 ) THEN
            Info = N + 9
            RETURN
         ENDIF
      ENDIF
!
 100  Work(1) = lwkopt
!
!
!     End of CGEGS
!
      END SUBROUTINE CGEGS


!=======================================================================
!  Copyright (c) 2002-2021 The ROMS/TOMS Group                         !
!    Licensed under a MIT/X style license                              !
!    See License_ROMS.txt                           Hernan G. Arango   !
!========================================== Alexander F. Shchepetkin ===
!                                                                      !
!  This module contains several all purpuse generic routines:          !
!                                                                      !
!  Routines:                                                           !
!                                                                      !
!    hindices      Finds model grid cell for any datum.                !
!    try_range     Binary search of model grid cell for any datum.     !
!    inside        Closed polygon datum search.                        !
!                                                                      !
!=======================================================================
!
      SUBROUTINE hindices (angler, Xgrd, Ygrd,                          &
     &                     Xpos, Ypos, Ipos, Jpos,                      &
     &                     Lm, Mm, Npos)
!
!=======================================================================
!                                                                      !
!  Given any geographical locations Xpos and Ypos, this routine finds  !
!  the corresponding array cell indices (Ipos, Jpos) of gridded  data  !
!  Xgrd and Ygrd containing each requested location. This indices are  !
!  usually used for interpolation.                                     !
!                                                                      !
!  On Input:                                                           !
!                                                                      !
!     angler      Gridded data angle between X-axis and true EAST      !
!                   (radians).                                         !
!     Xgrd        Gridded data X-locations (usually, longitude).       !
!     Ygrd        Gridded data Y-locations (usually, latitude).        !
!     Xpos        Requested X-locations to process (usually longitude).!
!     Ypos        Requested Y-locations to process (usually latitude). !
!                                                                      !
!  On Output:                                                          !
!                                                                      !
!     Ipos       Fractional I-cell index containing locations in data. !
!     Jpos       Fractional J-cell index containing locations in data. !
!                                                                      !
!  Calls:    try_Range                                                 !
!                                                                      !
!=======================================================================
!
!
!  Imported variable declarations.
!
      implicit none

      integer, intent(in) :: Lm, Mm, Npos
      !f2py integer, intent(in) :: Lm,Mm,Npos

      real(8), intent(in), dimension(Mm,Lm) :: angler, Xgrd, Ygrd
      !f2py real, intent(in), dimension(Mm,Lm) :: angler,Xgrd,Ygrd

      real(8), intent(in), dimension(Npos) :: Xpos, Ypos
      !f2py real, intent(in), dimension(Npos) :: Xpos, Ypos

      real(8), intent(out), dimension(Npos) :: Ipos, Jpos
      !f2py real, intent(out), dimension(Npos) :: Ipos, Jpos
!
!  Local variable declarations.
!
      logical :: found, foundi, foundj

      integer :: Imax, Imin, Jmax, Jmin, i, i0, j, j0, mp, np

      real(8) :: aa2, ang, bb2, diag2, dx, dy, phi
      real(8) :: xfac, xpp, yfac, ypp
      real(8), parameter :: IJspv = -999.0
      real(8), parameter :: Eradius = 6371315.0
      real(8), parameter :: pi = 3.14159265358979323846
      real(8), parameter :: deg2rad = pi / 180.0

      integer :: Is, Ie, Js, Je

      logical :: try_range

      Is = 1
      Ie = Mm
      Js = 1
      Je = Lm
!
!-----------------------------------------------------------------------
!  Determine grid cell indices containing requested position points.
!  Then, interpolate to fractional cell position.
!-----------------------------------------------------------------------
!
      DO np=1, Npos
         Ipos(np)=IJspv
         Jpos(np)=IJspv
!
!     Check each position to find if it falls inside the whole domain.
!     Once it is stablished that it inside, find the exact cell to which
!     it belongs by successively dividing the domain by a half (binary
!     search).
!
         found=try_range(Xgrd, Ygrd, Lm, Mm,                            &
     &        Is, Ie, Js, Je,                                           &
     &        Xpos(np), Ypos(np))
         IF (found) THEN
            Imin=Is
            Imax=Ie
            Jmin=Js
            Jmax=Je
            DO while (((Imax-Imin).gt.1).or.((Jmax-Jmin).gt.1))
               IF ((Imax-Imin).gt.1) THEN
                  i0=(Imin+Imax)/2
                  found=try_range(Xgrd, Ygrd, Lm, Mm,                   &
     &                 Imin, i0, Jmin, Jmax,                            &
     &                 Xpos(np), Ypos(np))
                  IF (found) THEN
                     Imax=i0
                  ELSE
                     Imin=i0
                  END IF
               END IF
               IF ((Jmax-Jmin).gt.1) THEN
                  j0=(Jmin+Jmax)/2
                  found=try_range(Xgrd, Ygrd, Lm, Mm,                   &
     &                 Imin, Imax, Jmin, j0,                            &
     &                 Xpos(np), Ypos(np))
                  IF (found) THEN
                     Jmax=j0
                  ELSE
                     Jmin=j0
                  END IF
               END IF
            END DO
            found=(Is.le.Imin).and.(Imin.le.Ie).and.                    &
     &           (Is.le.Imax).and.(Imax.le.Ie).and.                     &
     &           (Js.le.Jmin).and.(Jmin.le.Je).and.                     &
     &           (Js.le.Jmax).and.(Jmax.le.Je)
!
!     Knowing the correct cell, calculate the exact indices, accounting
!     for a possibly rotated grid.  If spherical, convert all positions
!     to meters first.
!
            IF (found) THEN
               yfac=Eradius*deg2rad
               xfac=yfac*COS(Ypos(np)*deg2rad)
               xpp=(Xpos(np)-Xgrd(Imin,Jmin))*xfac
               ypp=(Ypos(np)-Ygrd(Imin,Jmin))*yfac
!
!     Use Law of Cosines to get cell parallelogram "shear" angle.
!
               diag2=((Xgrd(Imin+1,Jmin)-Xgrd(Imin,Jmin+1))*xfac)**2+      &
     &              ((Ygrd(Imin+1,Jmin)-Ygrd(Imin,Jmin+1))*yfac)**2
               aa2=((Xgrd(Imin,Jmin)-Xgrd(Imin+1,Jmin))*xfac)**2+          &
     &              ((Ygrd(Imin,Jmin)-Ygrd(Imin+1,Jmin))*yfac)**2
               bb2=((Xgrd(Imin,Jmin)-Xgrd(Imin,Jmin+1))*xfac)**2+          &
     &              ((Ygrd(Imin,Jmin)-Ygrd(Imin,Jmin+1))*yfac)**2
               phi=ASIN((diag2-aa2-bb2)/(2.0*SQRT(aa2*bb2)))
!
!     Transform float position into curvilinear coordinates. Assume the
!     cell is rectanglar, for now.
!
               ang=angler(Imin,Jmin)
               dx=xpp*COS(ang)+ypp*SIN(ang)
               dy=ypp*COS(ang)-xpp*SIN(ang)
!
!     Correct for parallelogram.
!
               dx=dx+dy*TAN(phi)
               dy=dy/COS(phi)
!
!     Scale with cell side lengths to translate into cell indices.
!
               dx=MIN(MAX(0.0,dx/SQRT(aa2)),1.0)
               dy=MIN(MAX(0.0,dy/SQRT(bb2)),1.0)
               Ipos(np)=REAL(Imin-1,8)+dx
               Jpos(np)=REAL(Jmin-1,8)+dy
            END IF
         END IF
      END DO

      RETURN
      END SUBROUTINE hindices

      FUNCTION try_range (Xgrd, Ygrd,  Lm, Mm,                          &
     &                            Imin, Imax, Jmin, Jmax, Xo, Yo)
!
!=======================================================================
!                                                                      !
!  Given a grided domain with matrix coordinates Xgrd and Ygrd, this   !
!  function finds if the point (Xo,Yo)  is inside the box defined by   !
!  the requested corners (Imin,Jmin) and (Imax,Jmax). It will return   !
!  logical switch  try_range=.TRUE.  if (Xo,Yo) is inside, otherwise   !
!  it will return false.                                               !
!                                                                      !
!  Calls:   inside                                                     !
!                                                                      !
!=======================================================================
!
!
!  Imported variable declarations.
!
      integer, intent(in) :: Imin, Imax, Jmin, Jmax

      real(8), intent(in), dimension(Mm, Lm) :: Xgrd
      real(8), intent(in), dimension(Mm, Lm) :: Ygrd

      real(8), intent(in) :: Xo, Yo

!
!  Local variable declarations.
!
      integer ::  Nb, i, j, shft, ic

      real(8), dimension(2*(Jmax-Jmin+Imax-Imin)+1) :: Xb, Yb
      logical :: try_range, inside

!
!-----------------------------------------------------------------------
!  Define closed polygon.
!-----------------------------------------------------------------------
!
!  Note that the last point (Xb(Nb),Yb(Nb)) does not repeat first
!  point (Xb(1),Yb(1)).  Instead, in function inside, it is implied
!  that the closing segment is (Xb(Nb),Yb(Nb))-->(Xb(1),Yb(1)). In
!  fact, function inside sets Xb(Nb+1)=Xb(1) and Yb(Nb+1)=Yb(1).
!
      Nb=2*(Jmax-Jmin+Imax-Imin)
      shft=1-Imin
      DO i=Imin,Imax-1
        Xb(i+shft)=Xgrd(i,Jmin)
        Yb(i+shft)=Ygrd(i,Jmin)
      END DO
      shft=1-Jmin+Imax-Imin
      DO j=Jmin,Jmax-1
        Xb(j+shft)=Xgrd(Imax,j)
        Yb(j+shft)=Ygrd(Imax,j)
      END DO
      shft=1+Jmax-Jmin+2*Imax-Imin
      DO i=Imax,Imin+1,-1
        Xb(shft-i)=Xgrd(i,Jmax)
        Yb(shft-i)=Ygrd(i,Jmax)
      END DO
      shft=1+2*Jmax-Jmin+2*(Imax-Imin)
      DO j=Jmax,Jmin+1,-1
        Xb(shft-j)=Xgrd(Imin,j)
        Yb(shft-j)=Ygrd(Imin,j)
      END DO
!
!-----------------------------------------------------------------------
!  Check if point (Xo,Yo) is inside of the defined polygon.
!-----------------------------------------------------------------------
!
      try_range=inside(Nb, Xb, Yb, Xo, Yo)
      RETURN
      END FUNCTION try_range

      FUNCTION inside (Nb, Xb, Yb, Xo, Yo)
!
!=======================================================================
!                                                                      !
!  Given the vectors Xb and Yb of size Nb, defining the coordinates    !
!  of a closed polygon,  this function find if the point (Xo,Yo) is    !
!  inside the polygon.  If the point  (Xo,Yo)  falls exactly on the    !
!  boundary of the polygon, it still considered inside.                !
!                                                                      !
!  This algorithm does not rely on the setting of  Xb(Nb)=Xb(1) and    !
!  Yb(Nb)=Yb(1).  Instead, it assumes that the last closing segment    !
!  is (Xb(Nb),Yb(Nb)) --> (Xb(1),Yb(1)).                               !
!                                                                      !
!  Reference:                                                          !
!                                                                      !
!    Reid, C., 1969: A long way from Euclid. Oceanography EMR,         !
!      page 174.                                                       !
!                                                                      !
!  Algorithm:                                                          !
!                                                                      !
!  The decision whether the point is  inside or outside the polygon    !
!  is done by counting the number of crossings from the ray (Xo,Yo)    !
!  to (Xo,-infinity), hereafter called meridian, by the boundary of    !
!  the polygon.  In this counting procedure,  a crossing is counted    !
!  as +2 if the crossing happens from "left to right" or -2 if from    !
!  "right to left". If the counting adds up to zero, then the point    !
!  is outside.  Otherwise,  it is either inside or on the boundary.    !
!                                                                      !
!  This routine is a modified version of the Reid (1969) algorithm,    !
!  where all crossings were counted as positive and the decision is    !
!  made  based on  whether the  number of crossings is even or odd.    !
!  This new algorithm may produce different results  in cases where    !
!  Xo accidentally coinsides with one of the (Xb(k),k=1:Nb) points.    !
!  In this case, the crossing is counted here as +1 or -1 depending    !
!  of the sign of (Xb(k+1)-Xb(k)).  Crossings  are  not  counted if    !
!  Xo=Xb(k)=Xb(k+1).  Therefore, if Xo=Xb(k0) and Yo>Yb(k0), and if    !
!  Xb(k0-1) < Xb(k0) < Xb(k0+1),  the crossing is counted twice but    !
!  with weight +1 (for segments with k=k0-1 and k=k0). Similarly if    !
!  Xb(k0-1) > Xb(k0) > Xb(k0+1), the crossing is counted twice with    !
!  weight -1 each time.  If,  on the other hand,  the meridian only    !
!  touches the boundary, that is, for example, Xb(k0-1) < Xb(k0)=Xo    !
!  and Xb(k0+1) < Xb(k0)=Xo, then the crossing is counted as +1 for    !
!  segment k=k0-1 and -1 for segment k=k0, resulting in no crossing.   !
!                                                                      !
!  Note 1: (Explanation of the logical condition)                      !
!                                                                      !
!  Suppose  that there exist two points  (x1,y1)=(Xb(k),Yb(k))  and    !
!  (x2,y2)=(Xb(k+1),Yb(k+1)),  such that,  either (x1 < Xo < x2) or    !
!  (x1 > Xo > x2).  Therefore, meridian x=Xo intersects the segment    !
!  (x1,y1) -> (x2,x2) and the ordinate of the point of intersection    !
!  is:                                                                 !
!                                                                      !
!                 y1*(x2-Xo) + y2*(Xo-x1)                              !
!             y = -----------------------                              !
!                          x2-x1                                       !
!                                                                      !
!  The mathematical statement that point  (Xo,Yo)  either coinsides    !
!  with the point of intersection or lies to the north (Yo>=y) from    !
!  it is, therefore, equivalent to the statement:                      !
!                                                                      !
!         Yo*(x2-x1) >= y1*(x2-Xo) + y2*(Xo-x1),   if   x2-x1 > 0      !
!  or                                                                  !
!         Yo*(x2-x1) <= y1*(x2-Xo) + y2*(Xo-x1),   if   x2-x1 < 0      !
!                                                                      !
!  which, after noting that  Yo*(x2-x1) = Yo*(x2-Xo + Xo-x1) may be    !
!  rewritten as:                                                       !
!                                                                      !
!        (Yo-y1)*(x2-Xo) + (Yo-y2)*(Xo-x1) >= 0,   if   x2-x1 > 0      !
!  or                                                                  !
!        (Yo-y1)*(x2-Xo) + (Yo-y2)*(Xo-x1) <= 0,   if   x2-x1 < 0      !
!                                                                      !
!  and both versions can be merged into  essentially  the condition    !
!  that (Yo-y1)*(x2-Xo)+(Yo-y2)*(Xo-x1) has the same sign as x2-x1.    !
!  That is, the product of these two must be positive or zero.         !
!                                                                      !
!=======================================================================
!
!  Imported variable declarations.
!
      integer, intent(in) :: Nb

      real(8), intent(in) :: Xo, Yo

      real(8), intent(inout) :: Xb(Nb+1), Yb(Nb+1)
!
!  Local variable declarations.
!
      integer, parameter :: Nstep =128

      integer :: crossings, i, inc, k, kk, nc

      integer, dimension(Nstep) :: Sindex

      real(8) :: dx1, dx2, dxy

      logical :: inside
!
!-----------------------------------------------------------------------
!  Find intersections.
!-----------------------------------------------------------------------
!
!  Set crossings counter and close the contour of the polygon.
!
      crossings=0
      Xb(Nb+1)=Xb(1)
      Yb(Nb+1)=Yb(1)
!
!  The search is optimized.  First select the indices of segments
!  where Xb(k) is different from Xb(k+1) and Xo falls between them.
!  Then, further investigate these segments in a separate loop.
!  Doing it in two stages takes less time because the first loop is
!  pipelined.
!
      DO kk=0,Nb-1,Nstep
        nc=0
        DO k=kk+1,MIN(kk+Nstep,Nb)
           IF (((Xb(k+1)-Xo)*(Xo-Xb(k)).ge.0.0).and.                     &
     &          (Xb(k).ne.Xb(k+1))) THEN
            nc=nc+1
            Sindex(nc)=k
          END IF
        END DO
        DO i=1,nc
          k=Sindex(i)
          IF (Xb(k).ne.Xb(k+1)) THEN
            dx1=Xo-Xb(k)
            dx2=Xb(k+1)-Xo
            dxy=dx2*(Yo-Yb(k))-dx1*(Yb(k+1)-Yo)
            inc=0
            IF ((Xb(k).eq.Xo).and.(Yb(k).eq.Yo)) THEN
              crossings=1
              goto 10
            ELSE IF (((dx1.eq.0.0).and.(Yo.ge.Yb(k  ))).or.             &
     &              ((dx2.eq.0.0).and.(Yo.ge.Yb(k+1)))) THEN
              inc=1
            ELSE IF ((dx1*dx2.gt.0.0).and.                              &
     &              ((Xb(k+1)-Xb(k))*dxy.ge.0.0)) THEN  ! see note 1
              inc=2
            END IF
            IF (Xb(k+1).gt.Xb(k)) THEN
              crossings=crossings+inc
            ELSE
              crossings=crossings-inc
            END IF
          END IF
        END DO
      END DO
!
!  Determine if point (Xo,Yo) is inside of closed polygon.
!
  10  IF (crossings.eq.0) THEN
        inside=.FALSE.
      ELSE
        inside=.TRUE.
      END IF
      RETURN
      END FUNCTION inside


program SpheretoCircle
  implicit none

!!! PROGRAM THAT READS IN PARTICLE COORDS FROM SLM SIMULATIONS AND OUTPUTS A PLANE OF THOSE AS CIRCLES FOR COOLING SIMULATIONS

  double precision, dimension(:,:), allocatable :: Particles
  integer, dimension(:,:), allocatable :: Inside
  integer :: numparticles, i, counter, j, k,  Nx, Ny, Nz, NodesTotal
  double precision :: length, width, height, powderdensity, distance, gridlength, avgheight, avgradius, refinements, middleY, hx, hy, hz, stopheight
  double precision, dimension(:), allocatable :: Radius, Xcoord, Ycoord, Zcoord

  ! Create output file
  open(unit=100,file='InsidePoints.dat')
  write(unit=100,fmt='(A)') 'Title = Points inside vs. outside of the particles'

  ! Read in particle coordinates
  open(unit=110,file='PowderDepositionShankarMPFinal2800.dat')
  read(unit=110,fmt='(I10)') numparticles

  length = 0.00040D0*1.0e3 ! [m]
  width = 0.00080D0*1.0e3
  height = 0.00350D0*1.0e3
  stopheight = 0.5D0
  middleY = width / 2.0

  !!Allocate and define variables
  allocate(Particles(numparticles,4))
  allocate(Radius(numparticles))

  ! Reads in x, y, z, radius of each particle (in [mm])
  do i=1,numparticles
     read(unit=110,fmt='(F13.8,2x,F13.8,2x,F13.8,2x,F13.8,2x,I10,2x,F13.6)') Particles(i,1), Particles(i,2), Particles(i,3), Particles(i,4)
  end do

  close(unit=110)

  Radius(:) = Particles(:,4)

  ! Create Nodes and generate grid mesh - all coords in [mm]
  refinements = 5.0
  gridlength = minval(Radius) / refinements
  avgheight = sum(Particles(:,3)) / (1.0*numparticles)
  avgradius = sum(Radius) / (1.0*numparticles)
  Nx = ceiling(length/gridlength)+1
  Ny = ceiling(width/gridlength)+1
  !Nz = ceiling(2.0*avgradius/gridlength)
  Nz = ceiling(stopheight/gridlength)+1 ! goal is to get particles fully stacked up to 0.5 mm in height

  hx = length / (Nx-1.0)
  hy = width / (Ny-1.0)
  hz = stopheight / (Nz-1.0)

  print *, avgRadius, hx, hz

  ! 2D planar determination of whether particles reside within a sphere
  NodesTotal = (Nx)*(Nz)
  allocate(Xcoord(Nx))
  !allocate(Ycoord(NodesTotal))
  allocate(Zcoord(Nz))
  allocate(Inside(Nx,Nz))
  Inside(:,:) = 0
  counter = 1

  ! assign vector of coordinates
  do i = 1,Nx
     Xcoord(i) = (i-1.0)*hx
  end do

  do i = 1,Nz
     Zcoord(i) = (i-1.0)*hz
  end do

!!$! 2D planar porosity calc
!!$NodesTotal = (Nx+1)*(Ny+1)
!!$allocate(Xcoord(NodesTotal))
!!$allocate(Ycoord(NodesTotal))
!!$allocate(Zcoord(NodesTotal))
!!$allocate(Points(NodesTotal))
!!$Points(:) = 0.0D0
!!$counter = 1
!!$do i = 1,Nx+1
!!$   do j = 1,Ny+1
!!$      Xcoord(counter) = (i-1)*gridlength
!!$      Ycoord(counter) = (j-1)*gridlength
!!$      Zcoord(counter) = avgRadius
!!$      counter = counter + 1
!!$   end do
!!$end do

  ! Check to see which grid points lie within a sphere
  do i = 1,Nx
     do k = 1,Nz
        j = 1
        do while ((j <= numparticles) .AND. (Inside(i,k) < 0.5))
           distance = ((Xcoord(i)-Particles(j,1))**2.0 + (middleY-Particles(j,2))**2.0 + (Zcoord(k)-Particles(j,3))**2.0)**0.5
           if (distance <= Radius(j)) then
              Inside(i,k) = 1
           end if
           j = j+1
        end do
     end do
 !    print *, i
  end do

  ! Output data to Tecplot file
  write(100,*) 'Variables="X","Y","Inside"'
  write(100,*) 'Zone I=',Nx, 'J=',Nz, 'F=POINT'

  do i = 1,Nx
     do k = 1,Nz
        write(unit=100,fmt='(F13.6,2x,F13.6,2x,I6)') Xcoord(i), Zcoord(k), Inside(i,k)
     end do
  end do

  close(unit=100)

  ! Determine approximate density of particles
  powderdensity = sum(sum(Inside,1))*1.0 / (1.0*NodesTotal)

  print *, 'Density is ', powderdensity
  print *, 'Nx, Nz, numparticles', Nx, Nz, numparticles

end program SpheretoCircle


      DOUBLE PRECISION FUNCTION DADOTB( A, B )
      DOUBLE PRECISION A(3), B(3)
C*****
C  DOUBLE PRECISION VERSION
C
C  DOT PRODUCT  A . B
C*****
      DADOTB = A(1)*B(1) + A(2)*B(2) + A(3)*B(3)
      RETURN
      END


*     TB01ND EXAMPLE PROGRAM TEXT
*     Copyright (c) 2002-2020 NICONET e.V.
*
*     .. Parameters ..
      INTEGER          NIN, NOUT
      PARAMETER        ( NIN = 5, NOUT = 6 )
      INTEGER          NMAX, PMAX
      PARAMETER        ( NMAX = 20, PMAX = 20 )
      INTEGER          LDA, LDC, LDU, LDWORK
      PARAMETER        ( LDA = NMAX, LDC = PMAX, LDU = NMAX,
     $                   LDWORK = NMAX )
*     .. Local Scalars ..
      INTEGER          I, INFO, J, N, P
      CHARACTER*1      JOBU, UPLO
*     .. Local Arrays ..
      DOUBLE PRECISION A(LDA,NMAX), C(LDC,NMAX), U(LDU,NMAX),
     $                 DWORK(LDWORK)
*     .. External Functions ..
      LOGICAL          LSAME
      EXTERNAL         LSAME
*     .. External Subroutines ..
      EXTERNAL         TB01ND
*     .. Executable Statements ..
*
      WRITE ( NOUT, FMT = 99999 )
*     Skip the heading in the data file and read the data.
      READ ( NIN, FMT = '()' )
      READ ( NIN, FMT = * ) N, P, JOBU, UPLO
      IF ( N.LE.0 .OR. N.GT.NMAX ) THEN
         WRITE ( NOUT, FMT = 99993 ) N
      ELSE
         READ ( NIN, FMT = * ) ( ( A(I,J), I = 1,N ), J = 1,N )
         IF ( P.LE.0 .OR. P.GT.PMAX ) THEN
            WRITE ( NOUT, FMT = 99992 ) P
         ELSE
            READ ( NIN, FMT = * ) ( ( C(I,J), J = 1,N ), I = 1,P )
            IF ( LSAME( JOBU, 'U' ) )
     $         READ ( NIN, FMT = * ) ( ( U(I,J), J = 1,N ), I = 1,N )
*           Reduce the pair (A,C) to observer Hessenberg form.
            CALL TB01ND( JOBU, UPLO, N, P, A, LDA, C, LDC, U, LDU,
     $                   DWORK, INFO )
*
            IF ( INFO.NE.0 ) THEN
               WRITE ( NOUT, FMT = 99998 ) INFO
            ELSE
               WRITE ( NOUT, FMT = 99997 )
               DO 60 I = 1, N
                  WRITE ( NOUT, FMT = 99996 ) ( A(I,J), J = 1,N )
   60          CONTINUE
               WRITE ( NOUT, FMT = 99995 )
               DO 80 I = 1, P
                  WRITE ( NOUT, FMT = 99996 ) ( C(I,J), J = 1,N )
   80          CONTINUE
               IF ( LSAME( JOBU, 'I' ).OR.LSAME( JOBU, 'U' ) ) THEN
                  WRITE ( NOUT, FMT = 99994 )
                  DO 100 I = 1, N
                     WRITE ( NOUT, FMT = 99996 ) ( U(I,J), J = 1,N )
  100             CONTINUE
               END IF
            END IF
         END IF
      END IF
      STOP
*
99999 FORMAT (' TB01ND EXAMPLE PROGRAM RESULTS',/1X)
99998 FORMAT (' INFO on exit from TB01ND = ',I2)
99997 FORMAT (' The transformed state transition matrix is ')
99996 FORMAT (20(1X,F8.4))
99995 FORMAT (/' The transformed output matrix is ')
99994 FORMAT (/' The transformation matrix that reduces (A,C) to obser',
     $       'ver Hessenberg form is ')
99993 FORMAT (/' N is out of range.',/' N = ',I5)
99992 FORMAT (/' P is out of range.',/' P = ',I5)
      END


*     AB13CD EXAMPLE PROGRAM TEXT
*     Copyright (c) 2002-2020 NICONET e.V.
*
*     .. Parameters ..
      INTEGER          NIN, NOUT
      PARAMETER        ( NIN = 5, NOUT = 6 )
      INTEGER          NMAX, MMAX, PMAX
      PARAMETER        ( NMAX = 10, MMAX = 10, PMAX = 10 )
      INTEGER          LDA, LDB, LDC, LDD
      PARAMETER        ( LDA = NMAX, LDB = NMAX, LDC = PMAX,
     $                   LDD = PMAX )
      INTEGER          LIWORK
      PARAMETER        ( LIWORK = NMAX )
      INTEGER          LCWORK
      PARAMETER        ( LCWORK = ( NMAX + MMAX )*( NMAX + PMAX ) +
     $                              3*MAX( MMAX, PMAX ) )
      INTEGER          LDWORK
      PARAMETER        ( LDWORK = 4*NMAX*NMAX + 2*MMAX*MMAX +
     $                            2*PMAX*PMAX + 3*NMAX*MMAX +
     $                            2*NMAX*PMAX + MMAX*PMAX + 10*NMAX +
     $                            6*MAX( MMAX, PMAX ) )
*     .. Local Scalars ..
      DOUBLE PRECISION FPEAK, HNORM, TOL
      INTEGER          I, INFO, J, M, N, NP
*     .. Local Arrays ..
      LOGICAL          BWORK(2*NMAX)
      INTEGER          IWORK(LIWORK)
      DOUBLE PRECISION A(LDA,NMAX), B(LDB,MMAX), C(LDC,NMAX),
     $                 D(LDD,MMAX), DWORK(LDWORK)
      COMPLEX*16       CWORK( LCWORK )
*     .. External Functions ..
      DOUBLE PRECISION AB13CD
      EXTERNAL         AB13CD
*     .. Intrinsic Functions ..
      INTRINSIC        MAX
*     .. Executable Statements ..
*
      WRITE ( NOUT, FMT = 99999 )
*     Skip the heading in the data file and read the data.
      READ ( NIN, FMT = '()' )
      READ ( NIN, FMT = * ) N, M, NP
      IF ( N.LT.0 .OR. N.GT.NMAX ) THEN
         WRITE ( NOUT, FMT = 99990 ) N
      ELSE IF ( M.LT.0 .OR. M.GT.MMAX ) THEN
         WRITE ( NOUT, FMT = 99989 ) M
      ELSE IF ( NP.LT.0 .OR. NP.GT.PMAX ) THEN
         WRITE ( NOUT, FMT = 99988 ) NP
      ELSE
         READ ( NIN, FMT = * ) ( ( A(I,J), J = 1,N ), I = 1,N )
         READ ( NIN, FMT = * ) ( ( B(I,J), J = 1,M ), I = 1,N )
         READ ( NIN, FMT = * ) ( ( C(I,J), J = 1,N ), I = 1,NP )
         READ ( NIN, FMT = * ) ( ( D(I,J), J = 1,M ), I = 1,NP )
         READ ( NIN, FMT = * ) TOL
*        Computing the Hinf norm
         HNORM = AB13CD( N, M, NP, A, LDA, B, LDB, C, LDC, D, LDD, TOL,
     $                   IWORK, DWORK, LDWORK, CWORK, LCWORK, BWORK,
     $                   INFO )
*
         IF ( INFO.EQ.0 ) THEN
            WRITE ( NOUT, FMT = 99997 )
            WRITE ( NOUT, FMT = 99991 ) HNORM
            FPEAK = DWORK(2)
            WRITE ( NOUT, FMT = 99996 )
            WRITE ( NOUT, FMT = 99991 ) FPEAK
         ELSE
            WRITE( NOUT, FMT = 99998 ) INFO
         END IF
      END IF
      STOP
*
99999 FORMAT (' AB13CD EXAMPLE PROGRAM RESULTS',/1X)
99998 FORMAT (/' INFO on exit from AB13CD =',I2)
99997 FORMAT (/' The H_infty norm of the system is'/)
99996 FORMAT (/' The peak frequency is'/)
99992 FORMAT (10(1X,F8.4))
99991 FORMAT (D17.10)
99990 FORMAT (/' N is out of range.',/' N = ',I5)
99989 FORMAT (/' M is out of range.',/' M = ',I5)
99988 FORMAT (/' NP is out of range.',/' NP = ',I5)
      END


program test_sto_mg
use types, only: dp
use sto, only: stoints2, get_basis2
use utils, only: assert
use radialscf, only: doscf, kinetic_energy
use hfprint, only: printall, printlam
implicit none

integer, allocatable :: nl(:, :), nbfl(:)
real(dp), allocatable :: zl(:, :), focc(:, :)

real(dp), allocatable :: S(:, :, :), T(:, :, :), V(:, :, :), slater(:, :)
integer :: n, Z, m, Nscf, Lmax, ndof
real(dp) :: alpha, Etot, tolE, tolP, Ekin
real(dp), allocatable :: H(:, :, :), P_(:, :, :), C(:, :, :), lam(:, :)

allocate(nbfl(0:2), nl(8, 0:2), zl(8, 0:2), focc(3, 0:2))
nbfl = 0
focc = 0
focc(:3, 0) = [2, 2, 2]
focc(:1, 1) = [6]
nbfl(0) = 8
nl(:8, 0) = [1, 2, 2, 3, 3, 3, 3, 4]
zl(:8, 0) = [12._dp, 13.6_dp, 9.3_dp, 6.5_dp, 4.2_dp, 1.4_dp, 0.9_dp, 2.5_dp]
nbfl(1) = 8
nl(:8, 1) = [2, 2, 2, 3, 3, 3, 3, 4]
zl(:8, 1) = [12.5_dp, 9.2_dp, 6._dp, 0.5_dp, 5.3_dp, 3.7_dp, 2.5_dp, 1.2_dp]
nbfl(2) = 8
nl(:8, 2) = [3, 3, 3, 3, 4, 4, 4, 4]
zl(:8, 2) = [12.8_dp, 9.6_dp, 6.4_dp, 0.75_dp, 5.2_dp, 3.6_dp, 2.1_dp, 1.4_dp]

Z = 12
tolE = 1e-10_dp
tolP = 1e-4_dp
alpha = 0.6_dp
Nscf = 100

n = maxval(nbfl)
Lmax = ubound(nbfl, 1)
ndof = sum(nbfl)
print *, "total  DOFs =", ndof
allocate(H(n, n, 0:Lmax), S(n, n, 0:Lmax), T(n, n, 0:Lmax), V(n, n, 0:Lmax))
m = ndof*(ndof+1)/2
allocate(slater(m*(m+1)/2, 0:2*Lmax))
call stoints2(Z, nbfl, nl, zl, S, T, V, slater)

allocate(P_(n, n, 0:Lmax), C(n, n, 0:Lmax), lam(n, 0:Lmax))

H = T + V

print *, "SCF cycle:"
call doscf(nbfl, H, slater, S, focc, Nscf, tolE, tolP, alpha, C, P_, lam, Etot)
Ekin = kinetic_energy(nbfl, P_, T)
call printall(nbfl, nl, zl, lam, C, Ekin, Etot)
call printlam(nbfl, lam, Ekin, Etot)

call assert(abs(Etot - (-199.61259393_dp)) < 1e-8_dp)
call assert(abs(Ekin - (+199.62293919_dp)) < 1e-8_dp)
call assert(all(abs(lam(:3, 0) - [-49.029177_dp, -3.765885_dp, &
    -0.252718_dp]) < 1e-6_dp))
call assert(all(abs(lam(:1, 1) - [-2.280821_dp]) < 1e-6_dp))

end program


      SUBROUTINE ZWRSK(ZRR, ZRI, FNU, KODE, N, YR, YI, NZ, CWR, CWI,
     * TOL, ELIM, ALIM)
C***BEGIN PROLOGUE  ZWRSK
C***REFER TO  ZBESI,ZBESK
C
C     ZWRSK COMPUTES THE I BESSEL FUNCTION FOR RE(Z).GE.0.0 BY
C     NORMALIZING THE I FUNCTION RATIOS FROM ZRATI BY THE WRONSKIAN
C
C***ROUTINES CALLED  D1MACH,ZBKNU,ZRATI,AZABS
C***END PROLOGUE  ZWRSK
C     COMPLEX CINU,CSCL,CT,CW,C1,C2,RCT,ST,Y,ZR
      DOUBLE PRECISION ACT, ACW, ALIM, ASCLE, CINUI, CINUR, CSCLR, CTI,
     * CTR, CWI, CWR, C1I, C1R, C2I, C2R, ELIM, FNU, PTI, PTR, RACT,
     * STI, STR, TOL, YI, YR, ZRI, ZRR, AZABS, D1MACH
      INTEGER I, KODE, N, NW, NZ
      DIMENSION YR(N), YI(N), CWR(2), CWI(2)
C-----------------------------------------------------------------------
C     I(FNU+I-1,Z) BY BACKWARD RECURRENCE FOR RATIOS
C     Y(I)=I(FNU+I,Z)/I(FNU+I-1,Z) FROM CRATI NORMALIZED BY THE
C     WRONSKIAN WITH K(FNU,Z) AND K(FNU+1,Z) FROM CBKNU.
C-----------------------------------------------------------------------
      NZ = 0
      CALL ZBKNU(ZRR, ZRI, FNU, KODE, 2, CWR, CWI, NW, TOL, ELIM, ALIM)
      IF (NW.NE.0) GO TO 50
      CALL ZRATI(ZRR, ZRI, FNU, N, YR, YI, TOL)
C-----------------------------------------------------------------------
C     RECUR FORWARD ON I(FNU+1,Z) = R(FNU,Z)*I(FNU,Z),
C     R(FNU+J-1,Z)=Y(J),  J=1,...,N
C-----------------------------------------------------------------------
      CINUR = 1.0D0
      CINUI = 0.0D0
      IF (KODE.EQ.1) GO TO 10
      CINUR = DCOS(ZRI)
      CINUI = DSIN(ZRI)
   10 CONTINUE
C-----------------------------------------------------------------------
C     ON LOW EXPONENT MACHINES THE K FUNCTIONS CAN BE CLOSE TO BOTH
C     THE UNDER AND OVERFLOW LIMITS AND THE NORMALIZATION MUST BE
C     SCALED TO PREVENT OVER OR UNDERFLOW. CUOIK HAS DETERMINED THAT
C     THE RESULT IS ON SCALE.
C-----------------------------------------------------------------------
      ACW = AZABS(CWR(2),CWI(2))
      ASCLE = 1.0D+3*D1MACH(1)/TOL
      CSCLR = 1.0D0
      IF (ACW.GT.ASCLE) GO TO 20
      CSCLR = 1.0D0/TOL
      GO TO 30
   20 CONTINUE
      ASCLE = 1.0D0/ASCLE
      IF (ACW.LT.ASCLE) GO TO 30
      CSCLR = TOL
   30 CONTINUE
      C1R = CWR(1)*CSCLR
      C1I = CWI(1)*CSCLR
      C2R = CWR(2)*CSCLR
      C2I = CWI(2)*CSCLR
      STR = YR(1)
      STI = YI(1)
C-----------------------------------------------------------------------
C     CINU=CINU*(CONJG(CT)/CABS(CT))*(1.0D0/CABS(CT) PREVENTS
C     UNDER- OR OVERFLOW PREMATURELY BY SQUARING CABS(CT)
C-----------------------------------------------------------------------
      PTR = STR*C1R - STI*C1I
      PTI = STR*C1I + STI*C1R
      PTR = PTR + C2R
      PTI = PTI + C2I
      CTR = ZRR*PTR - ZRI*PTI
      CTI = ZRR*PTI + ZRI*PTR
      ACT = AZABS(CTR,CTI)
      RACT = 1.0D0/ACT
      CTR = CTR*RACT
      CTI = -CTI*RACT
      PTR = CINUR*RACT
      PTI = CINUI*RACT
      CINUR = PTR*CTR - PTI*CTI
      CINUI = PTR*CTI + PTI*CTR
      YR(1) = CINUR*CSCLR
      YI(1) = CINUI*CSCLR
      IF (N.EQ.1) RETURN
      DO 40 I=2,N
        PTR = STR*CINUR - STI*CINUI
        CINUI = STR*CINUI + STI*CINUR
        CINUR = PTR
        STR = YR(I)
        STI = YI(I)
        YR(I) = CINUR*CSCLR
        YI(I) = CINUI*CSCLR
   40 CONTINUE
      RETURN
   50 CONTINUE
      NZ = -1
      IF(NW.EQ.(-2)) NZ=-2
      RETURN
      END


module mod_primitive_linearized_euler
    use mod_kinds,      only: rk, ik
    use mod_constants,  only: HALF, ONE, TWO, ZERO, PI
    implicit none

    !
    ! Azimuthal orther
    !
    !integer(ik) :: mod_m = 2    ! Could get set by boundary conditions
    integer(ik) :: mod_m = 0    ! Could get set by boundary conditions
    integer(ik) :: mod_n = 1    ! Could get set by boundary conditions

    !
    ! Nondimensionalization
    !
    real(rk), parameter :: u_r    = 1._rk
    real(rk), parameter :: rho_r  = 1._rk
    real(rk), parameter :: l_r    = 1._rk

    real(rk), parameter :: gam       = 1.4_rk
    !real(rk), parameter :: omega = 1432.945684_rk * TWO * PI
    !real(rk), parameter :: omega     = 956._rk * TWO * PI
    real(rk), parameter :: omega     = ZERO
    !real(rk), parameter :: omega     = 3441.9548_rk
    real(rk), parameter :: thickness = 0.5_rk
    real(rk), parameter :: eps       = 2300_rk

    !
    ! Dimensional mean flow
    !
    real(rk), parameter :: rho_d = 1.2212179_rk
    real(rk), parameter :: u_d   = 0._rk
    real(rk), parameter :: v_d   = 0._rk
    real(rk), parameter :: w_d   = 103.2586448_rk
    real(rk), parameter :: p_d   = 103341.6659_rk

!    !
!    ! Nondimensional mean flow
!    !
!    real(rk), parameter :: rho_c  = rho_d  * (l_r/(rho_r*u_r))
!    real(rk), parameter :: rhou_c = rhou_d * (l_r/(rho_r*u_r*u_r))
!    real(rk), parameter :: rhov_c = rhov_d * (l_r/(rho_r*u_r*u_r))
!    real(rk), parameter :: rhow_c = rhow_d * (l_r/(rho_r*u_r*u_r))
!    real(rk), parameter :: rhoE_c = rhoE_d * (l_r/(rho_r*u_r*u_r*u_r))

    !
    ! Mean primitives
    !
    real(rk), parameter :: rhobar = rho_d
    real(rk), parameter :: ubar   = u_d
    real(rk), parameter :: vbar   = v_d
    real(rk), parameter :: wbar   = w_d
    real(rk), parameter :: pbar   = p_d
    real(rk), parameter :: cbar   = sqrt(gam * pbar / rhobar)
    real(rk), parameter :: Mbar   = ubar/cbar

    !
    ! A-Matrix
    !
    real(rk), parameter :: rho_1_rho = ubar
    real(rk), parameter :: rho_1_u   = rhobar
    real(rk), parameter :: rho_1_v   = ZERO
    real(rk), parameter :: rho_1_w   = ZERO
    real(rk), parameter :: rho_1_p   = ZERO

    real(rk), parameter :: u_1_rho   = ZERO
    real(rk), parameter :: u_1_u     = ubar
    real(rk), parameter :: u_1_v     = ZERO
    real(rk), parameter :: u_1_w     = ZERO
    real(rk), parameter :: u_1_p     = ONE/rhobar

    real(rk), parameter :: v_1_rho   = ZERO
    real(rk), parameter :: v_1_u     = ZERO
    real(rk), parameter :: v_1_v     = ubar
    real(rk), parameter :: v_1_w     = ZERO
    real(rk), parameter :: v_1_p     = ZERO

    real(rk), parameter :: w_1_rho   = ZERO
    real(rk), parameter :: w_1_u     = ZERO
    real(rk), parameter :: w_1_v     = ZERO
    real(rk), parameter :: w_1_w     = ubar
    real(rk), parameter :: w_1_p     = ZERO

    real(rk), parameter :: p_1_rho   = ZERO
    real(rk), parameter :: p_1_u     = gam*pbar
    real(rk), parameter :: p_1_v     = ZERO
    real(rk), parameter :: p_1_w     = ZERO
    real(rk), parameter :: p_1_p     = ubar

    !
    ! B-Matrix
    !
    real(rk), parameter :: rho_2_rho = vbar
    real(rk), parameter :: rho_2_u   = ZERO
    real(rk), parameter :: rho_2_v   = rhobar
    real(rk), parameter :: rho_2_w   = ZERO
    real(rk), parameter :: rho_2_p   = ZERO

    real(rk), parameter :: u_2_rho   = ZERO
    real(rk), parameter :: u_2_u     = vbar
    real(rk), parameter :: u_2_v     = ZERO
    real(rk), parameter :: u_2_w     = ZERO
    real(rk), parameter :: u_2_p     = ZERO

    real(rk), parameter :: v_2_rho   = ZERO
    real(rk), parameter :: v_2_u     = ZERO
    real(rk), parameter :: v_2_v     = vbar
    real(rk), parameter :: v_2_w     = ZERO
    real(rk), parameter :: v_2_p     = ONE/rhobar

    real(rk), parameter :: w_2_rho   = ZERO
    real(rk), parameter :: w_2_u     = ZERO
    real(rk), parameter :: w_2_v     = ZERO
    real(rk), parameter :: w_2_w     = vbar
    real(rk), parameter :: w_2_p     = ZERO

    real(rk), parameter :: p_2_rho   = ZERO
    real(rk), parameter :: p_2_u     = ZERO
    real(rk), parameter :: p_2_v     = gam*pbar
    real(rk), parameter :: p_2_w     = ZERO
    real(rk), parameter :: p_2_p     = vbar

    !
    ! C-Matrix
    !
    real(rk), parameter :: rho_3_rho = wbar
    real(rk), parameter :: rho_3_u   = ZERO
    real(rk), parameter :: rho_3_v   = ZERO
    real(rk), parameter :: rho_3_w   = rhobar
    real(rk), parameter :: rho_3_p   = ZERO

    real(rk), parameter :: u_3_rho   = ZERO
    real(rk), parameter :: u_3_u     = wbar
    real(rk), parameter :: u_3_v     = ZERO
    real(rk), parameter :: u_3_w     = ZERO
    real(rk), parameter :: u_3_p     = ZERO

    real(rk), parameter :: v_3_rho   = ZERO
    real(rk), parameter :: v_3_u     = ZERO
    real(rk), parameter :: v_3_v     = wbar
    real(rk), parameter :: v_3_w     = ZERO
    real(rk), parameter :: v_3_p     = ZERO

    real(rk), parameter :: w_3_rho   = ZERO
    real(rk), parameter :: w_3_u     = ZERO
    real(rk), parameter :: w_3_v     = ZERO
    real(rk), parameter :: w_3_w     = wbar
    real(rk), parameter :: w_3_p     = ONE/rhobar

    real(rk), parameter :: p_3_rho   = ZERO
    real(rk), parameter :: p_3_u     = ZERO
    real(rk), parameter :: p_3_v     = ZERO
    real(rk), parameter :: p_3_w     = gam*pbar
    real(rk), parameter :: p_3_p     = wbar

!    !
!    ! D-Matrix
!    !
!    real(rk), parameter :: s1_rho = ZERO
!    real(rk), parameter :: s1_u   = ZERO
!    real(rk), parameter :: s1_v   = ZERO
!    real(rk), parameter :: s1_w   = ZERO
!    real(rk), parameter :: s1_p   = ZERO
!
!    real(rk), parameter :: s2_rho = vbar*vbar/(rhobar*r)
!    real(rk), parameter :: s2_u   = wbar
!    real(rk), parameter :: s2_v   = ZERO
!    real(rk), parameter :: s2_w   = ZERO
!    real(rk), parameter :: s2_p   = ZERO
!
!    real(rk), parameter :: s3_rho = ZERO
!    real(rk), parameter :: s3_u   = ZERO
!    real(rk), parameter :: s3_v   = wbar
!    real(rk), parameter :: s3_w   = ZERO
!    real(rk), parameter :: s3_p   = ZERO
!
!    real(rk), parameter :: s4_rho = ZERO
!    real(rk), parameter :: s4_u   = ZERO
!    real(rk), parameter :: s4_v   = ZERO
!    real(rk), parameter :: s4_w   = wbar
!    real(rk), parameter :: s4_p   = ONE/rhobar
!
!    real(rk), parameter :: s5_rho = ZERO
!    real(rk), parameter :: s5_u   = ZERO
!    real(rk), parameter :: s5_v   = ZERO
!    real(rk), parameter :: s5_w   = gam*pbar
!    real(rk), parameter :: s5_p   = wbar

contains

end module mod_primitive_linearized_euler


	real function dE_dt(E,Ne,Te)

	implicit none
	real E,Ne,Te,L,z
	real*8 v,ve,x,z_d
	real*8 Lncoul,Lncoul0,const,const1
	real*8 cve,cv
	real*8 fct_F,fct_G,fzero,erf_d
	data Lncoul0/16.47435303047670d0/
	data const/8.308124389799321d-19/
	data const1/5.185521124430914d-6/
	data cve/5.505711034864502d3/
	data cv/5.930968920239551d5/

c	debye=sqrt(eps0*kb*te/ne/qe**2)
c	Lncoul=log(8*pi*eps0*kb*te/qe**2/gamma*debye)=log(8*pi*(eps0*kb)**(3/2)/qe**3/gamma)+3/2*log(Te)-1/2*log(Ne)
	Lncoul=Lncoul0+1.5*log(Te)-.5*Log(Ne)

c	ve=sqrt(2*kb/me*Te)
	ve=cve*sqrt(Te)
c	v=sqrt(2*qe/me*E)
	v=cv*sqrt(E)

	x=v/ve

c	omega2= qe**2/eps0/me*Ne
c	dE_dx=1e6/2/pi**1.5/eps0*omega2*qe**2/ve*(Lncoul*(sqrt(pi)/2*erf_d(x)./x-2*exp(-x.^2))+G)/v
c	dE_dx=1e6/2/pi**1.5/eps0**2*qe**4/me*Ne/ve*(Lncoul*(sqrt(pi)/2*erf_d(x)./x-2*exp(-x.^2))+G)/v
	dE_dt=max(0.d0,const*Ne*(Lncoul*fct_F(x)+fct_G(x))/ve/v)

c	dE_dt=1/2/pi**1.5/eps0**2*qe**3/me*Ne/ve*(Lncoul*(sqrt(pi)/2*erf_d(x)./x-2*exp(-x.^2))+G)
c	dE_dt=max(0.d0,const1*Ne*(Lncoul*fct_F(x)+fct_G(x))/ve)

	return
	end

        real*8 function fct_G(x)

        implicit none
        integer n1,n2,n3,i
        parameter (n1=16,n2=9,n3=10)
        real*8 x1,x2
        parameter(x1=4.d0,x2=10.d0)
        real*8 x,x_1
        real*8 p_G1(n1),p_G2(n2),p_G3(n3)
        real*8 sqrt_pi3_2,sqrt2_3
        data sqrt_pi3_2,sqrt2_3/2.65868077635827d0,1.12246204830937d0/

        data p_G1/ -0.00002048624814d0,  0.00069046243775d0,
     &             -0.01043544684716d0,  0.09303613548637d0,
     &             -0.54086367860165d0,  2.13603106149447d0,
     &             -5.77733935730334d0, 10.50893913422101d0,
     &            -12.34413794791237d0,  9.24815805250947d0,
     &             -6.08981347536415d0,  5.07702299840575d0,
     &             -0.54863842550586d0, -3.12958804967662d0,
     &             -0.00398280232498d0,  1.07727401230231d0/

        data p_G2/-0.00000033809574d0, 0.00002062408644d0,
     &            -0.00054924836885d0, 0.00835350728231d0,
     &            -0.07952212228605d0, 0.48638957620716d0,
     &            -1.86840995049315d0, 4.05569648338900d0,
     &            -2.77845422485329d0/

        data p_G3/-0.00000056862955d0, 0.00003089756689d0,
     &            -0.00072947821499d0, 0.00982615690014d0,
     &            -0.08342833064046d0, 0.46621855866187d0,
     &            -1.74464065804196d0, 4.41458930978275d0,
     &            -8.05865486553700d0,-0.70055029305823d0/

        if (x.le.x1) then
          fct_G=p_G1(1)
          do i=2,n1
            fct_G=fct_G*x+p_G1(i)
          enddo
        elseif (x.le.x2) then
          fct_G=p_G2(1)
          do i=2,n2
            fct_G=fct_G*x+p_G2(i)
          enddo
        else
          x_1=x/10.
          fct_G=p_G3(1)
          do i=2,n3
            fct_G=fct_G*x_1+p_G3(i)
          enddo
          fct_G=log(sqrt2_3*x)/x*sqrt_pi3_2-exp(fct_G)
        endif

        return
        end

	real*8 function fct_F(x)

	implicit none

	real*8 x,erf_d
	real*8 sqrtpi_2
	data sqrtpi_2/0.88622692545276d0/

	if (x.ne.0.d0) then
	  fct_F=sqrtpi_2*erf_d(x)/x-2.d0*exp(-x**2)
	else
	  fct_F=-1.d0
	endif
	return
	end

	real function fzero(Ne,Te)

c	fonction calculant la racine de dE_dt=0 pour 5<=Lncoul<=25
	implicit none
	integer n0,i
	parameter (n0=16)
	real Ne,Te
	real*8 x,x_1,Lncoul
	real*8 Lncoul0,kb_qe,p_zero(n0)
	data Lncoul0/16.47435303047670d0/
	data kb_qe/8.617385692256675d-5/
        data p_zero/-0.00000001747884d0,0.00000070827925d0,
     &              -0.00001324818763d0,0.00015159023895d0,
     &              -0.00118445573920d0,0.00667249752758d0,
     &              -0.02783941459867d0,0.08672516052003d0,
     &              -0.19951250008517d0,0.32512866229200d0,
     &              -0.33163827045288d0,0.10773434490681d0,
     &               0.20475850700617d0,-0.23539720452491d0,
     &              -0.10085290532879d0,1.27475858388761d0/

	x=log(Lncoul0+1.5d0*log(Te)-.5d0*log(Ne))

        fzero=p_zero(1)
        do i=2,n0
          fzero=fzero*x+p_zero(i)
        enddo
	fzero=kb_qe*fzero**2*Te

	return
	end

	real*8 function erf_d(x)
	real*8 x

	erf_d=x
	return
	end


*
*     ------------------------------------------------------------------
*                       A V E R P
*     ------------------------------------------------------------------
*
*     Add the deviations to the average energy for a partially filled
*       p- shell
*
      SUBROUTINE AVERP(J,K,N,A)
      IMPLICIT DOUBLE PRECISION(A-H,O-Z)
      INTEGER F2PP2(3),F2PP3(3)
      DIMENSION IAVS(3),IAVV(3)
      COMMON/CONSTS/ZERO,TENTH,HALF,ONE,TWO,THREE,FOUR,SEVEN,ELEVEN,EPS
      DATA IAVS/1,0,-2/
      DATA IAVV/1,0,25/
*             ... p2 coefficients
      DATA F2PP2/12,-3,3/
*             ... p3 coefficients
      DATA F2PP3/-9,6,0/
      A=ZERO
      IF (MOD(K,2) .NE. 0) RETURN
      IF (K .GT. 2) RETURN
      IDV=0
      IVV=25
      KK=K+1
      IF (N .EQ. 1 .OR. N .EQ. 5) THEN
        IF (J .NE. 4) RETURN
      ELSEIF (N .EQ. 2 .OR. N .EQ. 4) THEN
        IF (K .EQ. 2) THEN
          JJ=J-5
          IDV=F2PP2(JJ)
        END IF
      ELSEIF (N .EQ. 3) THEN
        IF (K .EQ. 2) THEN
          JJ=J-2
          IDV=F2PP3(JJ)
        END IF
      ELSEIF (N .EQ. 6) THEN
        IF (J .NE. 6) RETURN
      END IF
      A=DBLE(IAVS(KK)*N*(N-1))*HALF/DBLE(IAVV(KK))+DBLE(IDV)/DBLE(IVV)
      RETURN
      END


\\ Calculate the Fib for x, the result is printed to stdio.
\\ Be careful not to make x too large; it'll
\\ take a long time to calculate. Try 9 or 10...

: fib (x -- )
    dup 1 > if
            dup
            1 - recurse
            swap 2 - recurse
            +
    then .
;


      SUBROUTINE setup_booz(ntorsum, ns, mnmax, ohs,
     1   xmb, xnb, sfull, scl, mboz, nboz, mnboz, nu2_b,
     2   nu_boz, nv_boz, nfp, lasym)
      USE stel_kinds
      USE booz_persistent, ONLY: xm
      IMPLICIT NONE
C-----------------------------------------------
C   D u m m y   A r g u m e n t s
C-----------------------------------------------
      INTEGER, INTENT(in) :: ns, mnmax, mboz, nboz, nu2_b,
     1                       nu_boz, nv_boz, nfp
      INTEGER, INTENT(inout) :: mnboz
      REAL(rprec) :: ohs
      INTEGER, INTENT(out), DIMENSION(0:1)   :: ntorsum
      REAL(rprec), INTENT(out),  DIMENSION(mnboz) :: xmb, xnb, scl
      REAL(rprec), INTENT(out), DIMENSION(ns) :: sfull
      LOGICAL, INTENT(in) :: lasym
C-----------------------------------------------
C   L o c a l   P a r a m e t e r s
C-----------------------------------------------
      REAL(rprec), PARAMETER :: one = 1
C-----------------------------------------------
C   L o c a l   V a r i a b l e s
C-----------------------------------------------
      INTEGER :: mnboz0, n2, m, n1, n, i
      REAL(rprec) :: fac, hs
C-----------------------------------------------
!
!     SETUP BOOZER M,N ARRAYS
!
      mnboz0 = 0
      n2 = nboz
      DO m = 0, mboz-1
         n1 = -nboz
         IF (m .eq. 0) n1 = 0
         DO n = n1, n2
            mnboz0 = mnboz0 + 1
            IF (mnboz0 .gt. mnboz) THEN
               STOP 'mnboz exceeds limit in booz xform'
            END IF
            xnb(mnboz0) = n*nfp
            xmb(mnboz0) = m
         END DO
      END DO

      IF (mnboz0 .ne. mnboz) mnboz = mnboz0

!     SCALE FACTOR FOR NORMALIZATION OF FOURIER TRANSFORMS

      IF (lasym) THEN
         fac = 2.0_dp/(nu_boz*nv_boz)
      ELSE
         fac = 2.0_dp/((nu2_b-1)*nv_boz)
      END IF

      scl(:mnboz) = fac

      WHERE (NINT(xnb(:mnboz)).eq.0 .and. NINT(xmb(:mnboz)).eq.0)
     1   scl(:mnboz) = fac/2

      ntorsum(0) = 0
      ntorsum(1) = 0

      DO i=1,mnmax
        IF (NINT(xm(i)) .eq. 0) ntorsum(0) = ntorsum(0)+1
        IF (NINT(xm(i)) .le. 1) ntorsum(1) = ntorsum(1)+1
      END DO

      ohs = (ns-1)
      hs = one/ohs
      DO i=2,ns
        sfull(i) = SQRT(hs*(i-1))
      END DO

      END SUBROUTINE setup_booz


      SUBROUTINE PCPOEQU( N, A, IA, JA, DESCA, SR, SC, SCOND, AMAX,
     $                    INFO )
*
*  -- ScaLAPACK routine (version 1.7) --
*     University of Tennessee, Knoxville, Oak Ridge National Laboratory,
*     and University of California, Berkeley.
*     May 1, 1997
*
*     .. Scalar Arguments ..
      INTEGER            IA, INFO, JA, N
      REAL               AMAX, SCOND
*     ..
*     .. Array Arguments ..
      INTEGER            DESCA( * )
      REAL               SC( * ), SR( * )
      COMPLEX            A( * )
*     ..
*
*  Purpose
*  =======
*
*  PCPOEQU computes row and column scalings intended to
*  equilibrate a distributed Hermitian positive definite matrix
*  sub( A ) = A(IA:IA+N-1,JA:JA+N-1) and reduce its condition number
*  (with respect to the two-norm).  SR and SC contain the scale
*  factors, S(i) = 1/sqrt(A(i,i)), chosen so that the scaled distri-
*  buted matrix B with elements B(i,j) = S(i)*A(i,j)*S(j) has ones on
*  the  diagonal.  This choice of SR and SC puts the condition number
*  of B within a factor N of the smallest possible condition number
*  over all possible diagonal scalings.
*
*  The scaling factor are stored along process rows in SR and along
*  process columns in SC. The duplication of information simplifies
*  greatly the application of the factors.
*
*  Notes
*  =====
*
*  Each global data object is described by an associated description
*  vector.  This vector stores the information required to establish
*  the mapping between an object element and its corresponding process
*  and memory location.
*
*  Let A be a generic term for any 2D block cyclicly distributed array.
*  Such a global array has an associated description vector DESCA.
*  In the following comments, the character _ should be read as
*  "of the global array".
*
*  NOTATION        STORED IN      EXPLANATION
*  --------------- -------------- --------------------------------------
*  DTYPE_A(global) DESCA( DTYPE_ )The descriptor type.  In this case,
*                                 DTYPE_A = 1.
*  CTXT_A (global) DESCA( CTXT_ ) The BLACS context handle, indicating
*                                 the BLACS process grid A is distribu-
*                                 ted over. The context itself is glo-
*                                 bal, but the handle (the integer
*                                 value) may vary.
*  M_A    (global) DESCA( M_ )    The number of rows in the global
*                                 array A.
*  N_A    (global) DESCA( N_ )    The number of columns in the global
*                                 array A.
*  MB_A   (global) DESCA( MB_ )   The blocking factor used to distribute
*                                 the rows of the array.
*  NB_A   (global) DESCA( NB_ )   The blocking factor used to distribute
*                                 the columns of the array.
*  RSRC_A (global) DESCA( RSRC_ ) The process row over which the first
*                                 row of the array A is distributed.
*  CSRC_A (global) DESCA( CSRC_ ) The process column over which the
*                                 first column of the array A is
*                                 distributed.
*  LLD_A  (local)  DESCA( LLD_ )  The leading dimension of the local
*                                 array.  LLD_A >= MAX(1,LOCr(M_A)).
*
*  Let K be the number of rows or columns of a distributed matrix,
*  and assume that its process grid has dimension p x q.
*  LOCr( K ) denotes the number of elements of K that a process
*  would receive if K were distributed over the p processes of its
*  process column.
*  Similarly, LOCc( K ) denotes the number of elements of K that a
*  process would receive if K were distributed over the q processes of
*  its process row.
*  The values of LOCr() and LOCc() may be determined via a call to the
*  ScaLAPACK tool function, NUMROC:
*          LOCr( M ) = NUMROC( M, MB_A, MYROW, RSRC_A, NPROW ),
*          LOCc( N ) = NUMROC( N, NB_A, MYCOL, CSRC_A, NPCOL ).
*  An upper bound for these quantities may be computed by:
*          LOCr( M ) <= ceil( ceil(M/MB_A)/NPROW )*MB_A
*          LOCc( N ) <= ceil( ceil(N/NB_A)/NPCOL )*NB_A
*
*  Arguments
*  =========
*
*  N       (global input) INTEGER
*          The number of rows and columns to be operated on i.e the
*          order of the distributed submatrix sub( A ). N >= 0.
*
*  A       (local input) COMPLEX pointer into the local memory to an
*          array of local dimension ( LLD_A, LOCc(JA+N-1) ), the
*          N-by-N Hermitian positive definite distributed matrix
*          sub( A ) whose scaling factors are to be computed.  Only the
*          diagonal elements of sub( A ) are referenced.
*
*  IA      (global input) INTEGER
*          The row index in the global array A indicating the first
*          row of sub( A ).
*
*  JA      (global input) INTEGER
*          The column index in the global array A indicating the
*          first column of sub( A ).
*
*  DESCA   (global and local input) INTEGER array of dimension DLEN_.
*          The array descriptor for the distributed matrix A.
*
*  SR      (local output) REAL array, dimension LOCr(M_A)
*          If INFO = 0, SR(IA:IA+N-1) contains the row scale factors
*          for sub( A ). SR is aligned with the distributed matrix A,
*          and replicated across every process column. SR is tied to the
*          distributed matrix A.
*
*  SC      (local output) REAL array, dimension LOCc(N_A)
*          If INFO = 0, SC(JA:JA+N-1) contains the column scale factors
*          for A(IA:IA+M-1,JA:JA+N-1). SC is aligned with the distribu-
*          ted matrix A, and replicated down every process row. SC is
*          tied to the distributed matrix A.
*
*  SCOND   (global output) REAL
*          If INFO = 0, SCOND contains the ratio of the smallest SR(i)
*          (or SC(j)) to the largest SR(i) (or SC(j)), with
*          IA <= i <= IA+N-1 and JA <= j <= JA+N-1. If SCOND >= 0.1
*          and AMAX is neither too large nor too small, it is not worth
*          scaling by SR (or SC).
*
*  AMAX    (global output) REAL
*          Absolute value of largest matrix element.  If AMAX is very
*          close to overflow or very close to underflow, the matrix
*          should be scaled.
*
*  INFO    (global output) INTEGER
*          = 0:  successful exit
*          < 0:  If the i-th argument is an array and the j-entry had
*                an illegal value, then INFO = -(i*100+j), if the i-th
*                argument is a scalar and had an illegal value, then
*                INFO = -i.
*          > 0:  If INFO = K, the K-th diagonal entry of sub( A ) is
*                nonpositive.
*
*  =====================================================================
*
*     .. Parameters ..
      INTEGER            BLOCK_CYCLIC_2D, CSRC_, CTXT_, DLEN_, DTYPE_,
     $                   LLD_, MB_, M_, NB_, N_, RSRC_
      PARAMETER          ( BLOCK_CYCLIC_2D = 1, DLEN_ = 9, DTYPE_ = 1,
     $                     CTXT_ = 2, M_ = 3, N_ = 4, MB_ = 5, NB_ = 6,
     $                     RSRC_ = 7, CSRC_ = 8, LLD_ = 9 )
      REAL               ZERO, ONE
      PARAMETER          ( ZERO = 0.0E+0, ONE = 1.0E+0 )
*     ..
*     .. Local Scalars ..
      CHARACTER          ALLCTOP, COLCTOP, ROWCTOP
      INTEGER            IACOL, IAROW, ICOFF, ICTXT, ICURCOL, ICURROW,
     $                   IDUMM, II, IIA, IOFFA, IOFFD, IROFF, J, JB, JJ,
     $                   JJA, JN, LDA, LL, MYCOL, MYROW, NP, NPCOL,
     $                   NPROW, NQ
      REAL               AII, SMIN
*     ..
*     .. Local Arrays ..
      INTEGER            DESCSC( DLEN_ ), DESCSR( DLEN_ )
*     ..
*     .. External Subroutines ..
      EXTERNAL           BLACS_GRIDINFO, CHK1MAT, DESCSET, IGAMN2D,
     $                   INFOG2L, PCHK1MAT, PB_TOPGET, PXERBLA,
     $                   SGAMN2D, SGAMX2D, SGSUM2D
*     ..
*     .. External Functions ..
      INTEGER            ICEIL, NUMROC
      REAL               PSLAMCH
      EXTERNAL           ICEIL, NUMROC, PSLAMCH
*     ..
*     .. Intrinsic Functions ..
      INTRINSIC          MAX, MIN, MOD, REAL, SQRT
*     ..
*     .. Executable Statements ..
*
*     Get grid parameters
*
      ICTXT = DESCA( CTXT_ )
      CALL BLACS_GRIDINFO( ICTXT, NPROW, NPCOL, MYROW, MYCOL )
*
*     Test the input parameters.
*
      INFO = 0
      IF( NPROW.EQ.-1 ) THEN
         INFO = -(500+CTXT_)
      ELSE
         CALL CHK1MAT( N, 1, N, 1, IA, JA, DESCA, 5, INFO )
         CALL PCHK1MAT( N, 1, N, 1, IA, JA, DESCA, 5, 0, IDUMM, IDUMM,
     $                  INFO )
      END IF
*
      IF( INFO.NE.0 ) THEN
         CALL PXERBLA( ICTXT, 'PCPOEQU', -INFO )
         RETURN
      END IF
*
*     Quick return if possible
*
      IF( N.EQ.0 ) THEN
         SCOND = ONE
         AMAX = ZERO
         RETURN
      END IF
*
      CALL PB_TOPGET( ICTXT, 'Combine', 'All', ALLCTOP )
      CALL PB_TOPGET( ICTXT, 'Combine', 'Rowwise', ROWCTOP )
      CALL PB_TOPGET( ICTXT, 'Combine', 'Columnwise', COLCTOP )
*
*     Compute some local indexes
*
      CALL INFOG2L( IA, JA, DESCA, NPROW, NPCOL, MYROW, MYCOL, IIA, JJA,
     $              IAROW, IACOL )
      IROFF = MOD( IA-1, DESCA( MB_ ) )
      ICOFF = MOD( JA-1, DESCA( NB_ ) )
      NP = NUMROC( N+IROFF, DESCA( MB_ ), MYROW, IAROW, NPROW )
      NQ = NUMROC( N+ICOFF, DESCA( NB_ ), MYCOL, IACOL, NPCOL )
      IF( MYROW.EQ.IAROW )
     $   NP = NP - IROFF
      IF( MYCOL.EQ.IACOL )
     $   NQ = NQ - ICOFF
      JN = MIN( ICEIL( JA, DESCA( NB_ ) ) * DESCA( NB_ ), JA+N-1 )
      LDA = DESCA( LLD_ )
*
*     Assign descriptors for SR and SC arrays
*
      CALL DESCSET( DESCSR, N, 1, DESCA( MB_ ), 1, 0, 0, ICTXT,
     $               MAX( 1, NP ) )
      CALL DESCSET( DESCSC, 1, N, 1, DESCA( NB_ ), 0, 0, ICTXT, 1 )
*
*     Initialize the scaling factors to zero.
*
      DO 10 II = IIA, IIA+NP-1
         SR( II ) = ZERO
   10 CONTINUE
*
      DO 20 JJ = JJA, JJA+NQ-1
         SC( JJ ) = ZERO
   20 CONTINUE
*
*     Find the minimum and maximum diagonal elements.
*     Handle first block separately.
*
      II = IIA
      JJ = JJA
      JB = JN-JA+1
      SMIN = ONE / PSLAMCH( ICTXT, 'S' )
      AMAX = ZERO
*
      IOFFA = II+(JJ-1)*LDA
      IF( MYROW.EQ.IAROW .AND. MYCOL.EQ.IACOL ) THEN
         IOFFD = IOFFA
         DO 30 LL = 0, JB-1
            AII = REAL( A( IOFFD ) )
            SR( II+LL ) = AII
            SC( JJ+LL ) = AII
            SMIN = MIN( SMIN, AII )
            AMAX = MAX( AMAX, AII )
            IF( AII.LE.ZERO .AND. INFO.EQ.0 )
     $         INFO = LL + 1
            IOFFD = IOFFD + LDA + 1
   30    CONTINUE
      END IF
*
      IF( MYROW.EQ.IAROW ) THEN
         II = II + JB
         IOFFA = IOFFA + JB
      END IF
      IF( MYCOL.EQ.IACOL ) THEN
         JJ = JJ + JB
         IOFFA = IOFFA + JB*LDA
      END IF
      ICURROW = MOD( IAROW+1, NPROW )
      ICURCOL = MOD( IACOL+1, NPCOL )
*
*     Loop over remaining blocks of columns
*
      DO 50 J = JN+1, JA+N-1, DESCA( NB_ )
         JB = MIN( N-J+JA, DESCA( NB_ ) )
*
         IF( MYROW.EQ.ICURROW .AND. MYCOL.EQ.ICURCOL ) THEN
            IOFFD = IOFFA
            DO 40 LL = 0, JB-1
               AII = REAL( A( IOFFD ) )
               SR( II+LL ) = AII
               SC( JJ+LL ) = AII
               SMIN = MIN( SMIN, AII )
               AMAX = MAX( AMAX, AII )
               IF( AII.LE.ZERO .AND. INFO.EQ.0 )
     $            INFO = J + LL - JA + 1
               IOFFD = IOFFD + LDA + 1
   40       CONTINUE
         END IF
*
         IF( MYROW.EQ.ICURROW ) THEN
            II = II + JB
            IOFFA = IOFFA + JB
         END IF
         IF( MYCOL.EQ.ICURCOL ) THEN
            JJ = JJ + JB
            IOFFA = IOFFA + JB*LDA
         END IF
         ICURROW = MOD( ICURROW+1, NPROW )
         ICURCOL = MOD( ICURCOL+1, NPCOL )
*
   50 CONTINUE
*
*     Compute scaling factors
*
      CALL SGSUM2D( ICTXT, 'Columnwise', COLCTOP, 1, NQ, SC( JJA ),
     $              1, -1, MYCOL )
      CALL SGSUM2D( ICTXT, 'Rowwise', ROWCTOP, NP, 1, SR( IIA ),
     $              MAX( 1, NP ), -1, MYCOL )
*
      CALL SGAMX2D( ICTXT, 'All', ALLCTOP, 1, 1, AMAX, 1, IDUMM, IDUMM,
     $              -1, -1, MYCOL )
      CALL SGAMN2D( ICTXT, 'All', ALLCTOP, 1, 1, SMIN, 1, IDUMM, IDUMM,
     $              -1, -1, MYCOL )
*
      IF( SMIN.LE.ZERO ) THEN
*
*        Find the first non-positive diagonal element and return.
*
         CALL IGAMN2D( ICTXT, 'All', ALLCTOP, 1, 1, INFO, 1, II, JJ, -1,
     $                 -1, MYCOL )
         RETURN
*
      ELSE
*
*        Set the scale factors to the reciprocals
*        of the diagonal elements.
*
         DO 60 II = IIA, IIA+NP-1
            SR( II ) = ONE / SQRT( SR( II ) )
   60    CONTINUE
*
         DO 70 JJ = JJA, JJA+NQ-1
            SC( JJ ) = ONE / SQRT( SC( JJ ) )
   70    CONTINUE
*
*        Compute SCOND = min(S(I)) / max(S(I))
*
         SCOND = SQRT( SMIN ) / SQRT( AMAX )
*
      END IF
*
      RETURN
*
*     End of PCPOEQU
*
      END


c     program DRSASINH
c>> 2001-05-22 DRSASINH Krogh Minor change for making .f90 version.
c>> 1996-06-26 DRSASINH Krogh Changed code to simplify conversion to C.
c>> 1996-05-28 DRSASINH Krogh Added external state. & moved up formats
c>> 1994-10-19 DRSASINH Krogh  Changes to use M77CON
c>> 1988-11-17 DRSASINH CLL
c--S replaces "?": DR?ASINH,?ASINH,?ACOSH,?ATANH,?ACTNH,?ASECH,?ACSCH
c
      integer I
      real             X1(3),X2(3)
      external SASINH,SACOSH,SATANH,SACTNH,SASECH,SACSCH
      real             SASINH,SACOSH,SATANH,SACTNH,SASECH,SACSCH
c
      data X1/0.1e0, 0.5e0, 0.9e0/
      data X2/1.1e0, 10.0e0, 100.0e0/
c
   10 format('     X',11X,'SASINH',10X,'SATANH',10X,
     *  'SASECH',10X,'SACSCH')
   20 format('    ',3('-'),10X,4(6('-'),10X))
   30 format('     X',11X,'SASINH',10X,'SACOSH',10X,
     *  'SACTNH',10X,'SACSCH')
c
      print 10
      print 20
      do 40 I = 1, 3
         print '(1X,F6.2,1X,4F16.6)', X1(I),SASINH(X1(I)),
     *      SATANH(X1(I)), SASECH(X1(I)),SACSCH(X1(I))
   40 continue
      print '('' ''/)'
      print 30
      print 20
      do 50 I = 1, 3
         print  '(1X,F6.2,1X,4F16.6)', X2(I),SASINH(X2(I)),
     *      SACOSH(X2(I)), SACTNH(X2(I)),SACSCH(X2(I))
   50 continue
      stop
      end


program test_sparse
use types, only: dp
use sparse, only: coo2dense, dense2coo, getnnz, coo2csr, &
    csr_has_canonical_format, csr_sum_duplicates, csr_sort_indices, &
    coo2csr_canonical, csr_matvec, csr_getvalue
use utils, only: assert

real(dp), allocatable :: A(:, :), B(:, :), Ax(:), Bx(:), x(:), y(:)
integer, allocatable :: Ai(:), Aj(:), Bp(:), Bj(:)
integer :: nnz

allocate(A(4, 4), B(4, 4))
A = reshape([1, 7, 0, 0, &
             0, 2, 8, 0, &
             5, 0, 3, 9, &
             0, 6, 0, 4], [4, 4], order=[2, 1])
nnz = getnnz(A)
allocate(Ai(nnz), Aj(nnz), Ax(nnz))
call dense2coo(A, Ai, Aj, Ax)
call assert(all(Ai == [1, 3, 1, 2, 4, 2, 3, 3, 4]))
call assert(all(Aj == [1, 1, 2, 2, 2, 3, 3, 4, 4]))
call assert(all(abs(Ax - [1, 5, 7, 2, 6, 8, 3, 9, 4]) < 1e-12_dp))
call coo2dense(Ai, Aj, Ax, B)
call assert(all(abs(A-B) < 1e-12_dp))
allocate(Bp(maxval(Ai)+1), Bj(size(Ai)), Bx(size(Ai)))
call coo2csr(Ai, Aj, Ax, Bp, Bj, Bx)
call assert(all(Bp-1 == [0, 2, 4, 7, 9]))
call assert(all(Bj-1 == [0, 1, 1, 2, 0, 2, 3, 1, 3]))
call assert(all(abs(Bx - [1, 7, 2, 8, 5, 3, 9, 6, 4]) < 1e-12_dp))
call assert(csr_has_canonical_format(Bp, Bj))
deallocate(A, B, Ai, Aj, Ax, Bp, Bj, Bx)

allocate(A(4, 5), B(4, 5))
A = reshape([1, 7, 0, 0, 1, &
             0, 2, 8, 0, 2, &
             5, 0, 3, 9, 3, &
             0, 6, 0, 4, 4], [4, 5], order=[2, 1])
nnz = getnnz(A)
allocate(Ai(nnz), Aj(nnz), Ax(nnz))
call dense2coo(A, Ai, Aj, Ax)
call assert(all(Ai == [1, 3, 1, 2, 4, 2, 3, 3, 4, 1, 2, 3, 4]))
call assert(all(Aj == [1, 1, 2, 2, 2, 3, 3, 4, 4, 5, 5, 5, 5]))
call assert(all(abs(Ax - [1, 5, 7, 2, 6, 8, 3, 9, 4, 1, 2, 3, 4]) < 1e-12_dp))
call coo2dense(Ai, Aj, Ax, B)
call assert(all(abs(A-B) < 1e-12_dp))
allocate(Bp(maxval(Ai)+1), Bj(size(Ai)), Bx(size(Ai)))
call coo2csr(Ai, Aj, Ax, Bp, Bj, Bx)
call assert(all(Bp == [1, 4, 7, 11, 14]))
call assert(all(Bj == [1, 2, 5, 2, 3, 5, 1, 3, 4, 5, 2, 4, 5]))
call assert(all(abs(Bx - [1, 7, 1, 2, 8, 2, 5, 3, 9, 3, 6, 4, 4]) < 1e-12_dp))
call assert(csr_has_canonical_format(Bp, Bj))
allocate(x(5), y(4))
x = [1, 2, 3, 4, 5]
y = csr_matvec(Bp, Bj, Bx, x)
call assert(all(abs(y-matmul(A, x)) < 1e-12_dp))
deallocate(A, B, Ai, Aj, Ax, Bp, Bj, Bx, x, y)

allocate(Ai(6), Aj(6), Ax(6), A(3, 4), B(3, 4))
Ai = [1, 2, 3, 1, 2, 2]
Aj = [1, 3, 2, 1, 4, 3]
Ax = [1, 2, 3, 4, 1, 5]
call coo2dense(Ai, Aj, Ax, B)
A = reshape([5, 0, 0, 0, &
             0, 0, 7, 1, &
             0, 3, 0, 0], [3, 4], order=[2, 1])
call assert(all(abs(A-B) < 1e-12_dp))
allocate(Bp(maxval(Ai)+1), Bj(size(Ai)), Bx(size(Ai)))
call coo2csr(Ai, Aj, Ax, Bp, Bj, Bx)
call assert(all(Bp == [1, 3, 6, 7]))
call assert(all(Bj == [1, 1, 3, 4, 3, 2]))
call assert(all(abs(Bx - [1, 4, 2, 1, 5, 3]) < 1e-12_dp))
call assert(.not. csr_has_canonical_format(Bp, Bj))
call csr_sort_indices(Bp, Bj, Bx)
call assert(all(Bp == [1, 3, 6, 7]))
call assert(all(Bj == [1, 1, 3, 3, 4, 2]))
call assert(all(abs(Bx - [1, 4, 2, 5, 1, 3]) < 1e-12_dp))
call csr_sum_duplicates(Bp, Bj, Bx)
nnz = Bp(size(Bp))-1
call assert(all(Bp == [1, 2, 4, 5]))
call assert(all(Bj(:nnz) == [1, 3, 4, 2]))
call assert(all(abs(Bx(:nnz) - [5, 7, 1, 3]) < 1e-12_dp))
call assert(csr_has_canonical_format(Bp, Bj(:nnz)))

call coo2csr_canonical(Ai, Aj, Ax, Bp, Bj, Bx)
call assert(all(Bp == [1, 2, 4, 5]))
call assert(all(Bj == [1, 3, 4, 2]))
call assert(all(abs(Bx - [5, 7, 1, 3]) < 1e-12_dp))
call assert(csr_has_canonical_format(Bp, Bj))

call assert(abs(csr_getvalue(Bp, Bj, Bx, 1, 1) - 5) < tiny(1._dp))
call assert(abs(csr_getvalue(Bp, Bj, Bx, 1, 2) - 0) < tiny(1._dp))
call assert(abs(csr_getvalue(Bp, Bj, Bx, 1, 3) - 0) < tiny(1._dp))
call assert(abs(csr_getvalue(Bp, Bj, Bx, 1, 4) - 0) < tiny(1._dp))
call assert(abs(csr_getvalue(Bp, Bj, Bx, 2, 1) - 0) < tiny(1._dp))
call assert(abs(csr_getvalue(Bp, Bj, Bx, 2, 2) - 0) < tiny(1._dp))
call assert(abs(csr_getvalue(Bp, Bj, Bx, 2, 3) - 7) < tiny(1._dp))
call assert(abs(csr_getvalue(Bp, Bj, Bx, 2, 4) - 1) < tiny(1._dp))
call assert(abs(csr_getvalue(Bp, Bj, Bx, 3, 1) - 0) < tiny(1._dp))
call assert(abs(csr_getvalue(Bp, Bj, Bx, 3, 2) - 3) < tiny(1._dp))
call assert(abs(csr_getvalue(Bp, Bj, Bx, 3, 3) - 0) < tiny(1._dp))
call assert(abs(csr_getvalue(Bp, Bj, Bx, 3, 4) - 0) < tiny(1._dp))

deallocate(A, B, Ai, Aj, Ax, Bp, Bj, Bx)

end


!   --------------------------------------------------------------------
!   DMET DELUX 2000	Subrutine	akalk
!   --------------------------------------------------------------------
!   HENSIKT :
!   Beregner hydrodynamiske tilleggskoeffisienter for hiv
!
!   METODE :
!   Tar inn konstanter fra lektergeometri og frekvensvektor. Regner om
!   frekvens tilpasset avleste kurver i lærebok. Bruker innlagte polynomer
!   til å beregne tilleggsmasse for todimensjonale striper av lekter.
!   Sender resultatmatriser for begge lektere videre til beregning av
!   transferfunksjoner.Skriver resultatfil som kan plottes ved kjøring
!   for visuell kontroll.
!
!   KALLESEKVENS:
!   CALL akalk(n,nl,rho,g,omega,L,Br,D,A33,A55)
!
!   PARAMETERE:
!   Navn	I/O	Type			Innhold/Beskrivelse
!   ....................................................................
!   omega	I	flyttals vektor		bølgefrekvens
!   n		I	heltall			antall frekvensintervaller
!   nl		I/O	heltall			antall lektere
!   k		I	flyttalls vektor	bølgetall
!   zeta_an	I	flyttalls vektor	bølgeamplitude
!   hs		I	heltall	  		signifikant bølgehøyde
!   tp		I	heltall			midlere periode
!   gamma	I	heltall			toppethetsfaktor
!   pi		I	flyttall		pi
!   g		I/O	flyttall		tyngdelfeltsakselerasjon
!   sn		O	flyttall		spekterverdi
!   a		I/O	heltall			nedre frekvensverdi
!   b		I/O	heltall			øvre frekvensverdi
!   A33		I/O	flyttalls matrise	tilleggsmasse hiv
!   A55		I/O 	flyttalls matrise	tilleggsmasse stamp
!   B33		I/O	flyttalls matrise	demping hiv
!   B55		I/O	flyttalls matrise	demping stamp
!   C33		I/O	flyttalls vektor	fjørkoeffisient hiv
!   C55		I/O	flyttalls vektor	fjærkoeffisient stamp
!   L		I/O	heltalls vektor		lengde på lekter
!   Br		I/O 	heltalls vektor		bredde på lekter
!   D		I/O	flyttalls vektor	dypgang på lekter
!   H		I/O	flyttalls vektor	dybde i riss for lekter
!   M		I/O	flyttalls vektor	masse lekter
!   GML		I/O	flyttalls vektor	langskips metasenter
!   pi		I/O	flyttall		pi
!   rho		I/O	flyttal			tetthet sjøvann
!   g		I/O	flyttall		tyngdeakselerasjonen
!
!
!   INTERNE VARIABLE:
!   Navn			Funksjon
!   .....................................................................
!   i				tellevariabler
!   oomegaA,oomegaB		omregning av frekvens
!   A33plot			plotteverdi avlest tilleggsmasse
!
!   SKRIVEFILER:
!   Navn			Eventuell beskrivelse
!   .....................................................................
!   A33plot.txt			skriver resultat for visuell kontroll
!
!
!   --------------------------------------------------------------------
!
!   Programmert av:	     Tor Erik Larsen
!   Dato/Versjon  : 	     27.04.15 / 1.0
!
!   --------------------------------------------------------------------

!Starter subrutine og erklærer alle variable og vektorer
SUBROUTINE akalk(n,nl,rho,g,omega,L,Br,D,A33,A55)
IMPLICIT NONE
INTEGER::i,n,nl
REAL::rho,g
DOUBLE PRECISION,DIMENSION(1:n)::omega,oomegaA,oomegaB
REAL,DIMENSION(1:nl)::L,Br,D,M,GML
REAL,DIMENSION(1:n,1:nl)::A33,A55,A33plot

!Beregner x-aksen for koeffisientene
DO i=1,n
   oomegaA(i)=omega(i)*SQRT(Br(1)/(2.0*g))
   oomegaB(i)=omega(i)*SQRT(Br(2)/(2.0*g))
END DO

!Beregner A33_2D for lekter A, sjettegradspolynom
DO i = 1,n
   IF (oomegaA(i) < 2.0) THEN
   A33plot(i,1) = ( &
        -1.8169*oomegaA(i)**5 + 11.493*oomegaA(i)**4 - 28.060*oomegaA(i)**3 &
        + 32.823*oomegaA(i)**2 - 17.894*oomegaA(i)**1 + 4.3851 &
        )
ELSE
   A33plot(i,1) = 1.15
END IF
END DO

!Beregner A33_2D for lekter B, femtegradspolynom
DO  i = 1,n
   IF (oomegaB(i) <2.0) THEN
   A33plot(i,2) = (&
        1.0534*oomegaB(i)**6 - 8.207*oomegaB(i)**5 &
        + 26.398*oomegaB(i)**4 - 45.717*oomegaB(i)**3 &
        + 46.022*oomegaB(i)**2 -25.507*oomegaB(i)**1  &
        + 7.4189 &
        )
ELSE
   A33plot(i,2) = 1.9
END IF
END DO

!Beregner fullengde A33 ved å gange A33_2D med lengde
DO i=1,n
   A33(i,1) = L(1) * A33plot(i,1)*(rho*Br(1)*D(1))
   A33(i,2) = L(2) * A33plot(i,2)*(rho*Br(2)*D(2))
END DO

!Beregner A55 for begge lektere
DO i=1,n
   A55(i,1) = (L(1)**2 / 12) * A33(i,1)
   A55(i,2) = (L(2)**2 / 12) * A33(i,2)
END DO

!Bygger plottefil for å sjekke om koeffisientene er regnet riktig
OPEN(13,FILE="A33plot.txt",ACTION="WRITE",STATUS="UNKNOWN")
DO i=1,n
   WRITE(13,*), oomegaA(i),A33plot(i,1),oomegaB(i), A33plot(i,2)
END DO
CLOSE(13)

!Gir tilbake kontrollen til hovedprogram og avslutter subrutine
RETURN
END SUBROUTINE