*
*  Definition:
*  ===========
*
*       SUBROUTINE ZLASWLQ( M, N, MB, NB, A, LDA, T, LDT, WORK,
*                            LWORK, INFO)
*
*       .. Scalar Arguments ..
*       INTEGER           INFO, LDA, M, N, MB, NB, LDT, LWORK
*       ..
*       .. Array Arguments ..
*       COMPLEX*16        A( LDA, * ), T( LDT, * ), WORK( * )
*       ..
*
*
*> \par Purpose:
*  =============
*>
*> \verbatim
*>
*>          ZLASWLQ computes a blocked Short-Wide LQ factorization of a
*>          M-by-N matrix A, where N >= M:
*>          A = L * Q
*> \endverbatim
*
*  Arguments:
*  ==========
*
*> \param[in] M
*> \verbatim
*>          M is INTEGER
*>          The number of rows of the matrix A.  M >= 0.
*> \endverbatim
*>
*> \param[in] N
*> \verbatim
*>          N is INTEGER
*>          The number of columns of the matrix A.  N >= M >= 0.
*> \endverbatim
*>
*> \param[in] MB
*> \verbatim
*>          MB is INTEGER
*>          The row block size to be used in the blocked QR.
*>          M >= MB >= 1
*> \endverbatim
*> \param[in] NB
*> \verbatim
*>          NB is INTEGER
*>          The column block size to be used in the blocked QR.
*>          NB > M.
*> \endverbatim
*>
*> \param[in,out] A
*> \verbatim
*>          A is COMPLEX*16 array, dimension (LDA,N)
*>          On entry, the M-by-N matrix A.
*>          On exit, the elements on and bleow the diagonal
*>          of the array contain the N-by-N lower triangular matrix L;
*>          the elements above the diagonal represent Q by the rows
*>          of blocked V (see Further Details).
*>
*> \endverbatim
*>
*> \param[in] LDA
*> \verbatim
*>          LDA is INTEGER
*>          The leading dimension of the array A.  LDA >= max(1,M).
*> \endverbatim
*>
*> \param[out] T
*> \verbatim
*>          T is COMPLEX*16 array,
*>          dimension (LDT, N * Number_of_row_blocks)
*>          where Number_of_row_blocks = CEIL((N-M)/(NB-M))
*>          The blocked upper triangular block reflectors stored in compact form
*>          as a sequence of upper triangular blocks.
*>          See Further Details below.
*> \endverbatim
*>
*> \param[in] LDT
*> \verbatim
*>          LDT is INTEGER
*>          The leading dimension of the array T.  LDT >= MB.
*> \endverbatim
*>
*>
*> \param[out] WORK
*> \verbatim
*>         (workspace) COMPLEX*16 array, dimension (MAX(1,LWORK))
*>
*> \endverbatim
*> \param[in] LWORK
*> \verbatim
*>          The dimension of the array WORK.  LWORK >= MB*M.
*>          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] INFO
*> \verbatim
*>          INFO is INTEGER
*>          = 0:  successful exit
*>          < 0:  if INFO = -i, the i-th argument had an illegal value
*> \endverbatim
*
*  Authors:
*  ========
*
*> \author Univ. of Tennessee
*> \author Univ. of California Berkeley
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
*> \par Further Details:
*  =====================
*>
*> \verbatim
*> Short-Wide LQ (SWLQ) performs LQ by a sequence of orthogonal transformations,
*> representing Q as a product of other orthogonal matrices
*>   Q = Q(1) * Q(2) * . . . * Q(k)
*> where each Q(i) zeros out upper diagonal entries of a block of NB rows of A:
*>   Q(1) zeros out the upper diagonal entries of rows 1:NB of A
*>   Q(2) zeros out the bottom MB-N rows of rows [1:M,NB+1:2*NB-M] of A
*>   Q(3) zeros out the bottom MB-N rows of rows [1:M,2*NB-M+1:3*NB-2*M] of A
*>   . . .
*>
*> Q(1) is computed by GELQT, which represents Q(1) by Householder vectors
*> stored under the diagonal of rows 1:MB of A, and by upper triangular
*> block reflectors, stored in array T(1:LDT,1:N).
*> For more information see Further Details in GELQT.
*>
*> Q(i) for i>1 is computed by TPLQT, which represents Q(i) by Householder vectors
*> stored in columns [(i-1)*(NB-M)+M+1:i*(NB-M)+M] of A, and by upper triangular
*> block reflectors, stored in array T(1:LDT,(i-1)*M+1:i*M).
*> The last Q(k) may use fewer rows.
*> For more information see Further Details in TPQRT.
*>
*> For more details of the overall algorithm, see the description of
*> Sequential TSQR in Section 2.2 of [1].
*>
*> [1] “Communication-Optimal Parallel and Sequential QR and LU Factorizations,”
*>     J. Demmel, L. Grigori, M. Hoemmen, J. Langou,
*>     SIAM J. Sci. Comput, vol. 34, no. 1, 2012
*> \endverbatim
*>
*  =====================================================================
      SUBROUTINE ZLASWLQ( M, N, MB, NB, A, LDA, T, LDT, WORK, LWORK,
     $                  INFO)
*
*  -- LAPACK computational 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 ..
      INTEGER           INFO, LDA, M, N, MB, NB, LWORK, LDT
*     ..
*     .. Array Arguments ..
      COMPLEX*16        A( LDA, * ), WORK( * ), T( LDT, *)
*     ..
*
*  =====================================================================
*
*     ..
*     .. Local Scalars ..
      LOGICAL    LQUERY
      INTEGER    I, II, KK, CTR
*     ..
*     .. EXTERNAL FUNCTIONS ..
      LOGICAL            LSAME
      EXTERNAL           LSAME
*     .. EXTERNAL SUBROUTINES ..
      EXTERNAL           ZGELQT, ZTPLQT, XERBLA
*     .. INTRINSIC FUNCTIONS ..
      INTRINSIC          MAX, MIN, MOD
*     ..
*     .. EXECUTABLE STATEMENTS ..
*
*     TEST THE INPUT ARGUMENTS
*
      INFO = 0
*
      LQUERY = ( LWORK.EQ.-1 )
*
      IF( M.LT.0 ) THEN
        INFO = -1
      ELSE IF( N.LT.0 .OR. N.LT.M ) THEN
        INFO = -2
      ELSE IF( MB.LT.1 .OR. ( MB.GT.M .AND. M.GT.0 )) THEN
        INFO = -3
      ELSE IF( NB.LE.M ) THEN
        INFO = -4
      ELSE IF( LDA.LT.MAX( 1, M ) ) THEN
        INFO = -5
      ELSE IF( LDT.LT.MB ) THEN
        INFO = -8
      ELSE IF( ( LWORK.LT.M*MB) .AND. (.NOT.LQUERY) ) THEN
        INFO = -10
      END IF
      IF( INFO.EQ.0)  THEN
      WORK(1) = MB*M
      END IF
*
      IF( INFO.NE.0 ) THEN
        CALL XERBLA( 'ZLASWLQ', -INFO )
        RETURN
      ELSE IF (LQUERY) THEN
       RETURN
      END IF
*
*     Quick return if possible
*
      IF( MIN(M,N).EQ.0 ) THEN
          RETURN
      END IF
*
*     The LQ Decomposition
*
       IF((M.GE.N).OR.(NB.LE.M).OR.(NB.GE.N)) THEN
        CALL ZGELQT( M, N, MB, A, LDA, T, LDT, WORK, INFO)
        RETURN
       END IF
*
       KK = MOD((N-M),(NB-M))
       II=N-KK+1
*
*      Compute the LQ factorization of the first block A(1:M,1:NB)
*
       CALL ZGELQT( M, NB, MB, A(1,1), LDA, T, LDT, WORK, INFO)
       CTR = 1
*
       DO I = NB+1, II-NB+M , (NB-M)
*
*      Compute the QR factorization of the current block A(1:M,I:I+NB-M)
*
         CALL ZTPLQT( M, NB-M, 0, MB, A(1,1), LDA, A( 1, I ),
     $                  LDA, T(1, CTR * M + 1),
     $                  LDT, WORK, INFO )
         CTR = CTR + 1
       END DO
*
*     Compute the QR factorization of the last block A(1:M,II:N)
*
       IF (II.LE.N) THEN
        CALL ZTPLQT( M, KK, 0, MB, A(1,1), LDA, A( 1, II ),
     $                  LDA, T(1, CTR * M + 1), LDT,
     $                  WORK, INFO )
       END IF
*
      WORK( 1 ) = M * MB
      RETURN
*
*     End of ZLASWLQ
*
      END


*dk solid_angle_lg
C #####################################################################
C     PURPOSE -
C       find solid angle at 4 of the triangle (1,2,3)
C
C     INPUT ARGUMENTS -
C       x,y,z positions of the 4 points
C       ordering convention: (1,2,3) cyclic points at 4
C
C     OUTPUT ARGUMENTS -
C       solid angle
C       (units: stereradians or however you spell it: circle is 4pi)
C
C     CHANGE HISTORY -
C       $Log: solid_angle_lg.f,v $
C       Revision 2.00  2007/11/09 20:04:03  spchu
C       Import to CVS
C
CPVCS
CPVCS       Rev 1.0   Fri Sep 17 17:27:30 1999   jtg
CPVCS    Initial revision.
C #####################################################################

        subroutine solid_angle_lg(solid_angle
     &          ,x1,y1,z1, x2,y2,z2, x3,y3,z3, x4,y4,z4)

        implicit none

        integer MXN,MXEL
        parameter (MXN=3000,MXEL=10000)
        real*8 x1,y1,z1,x2,y2,z2,x3,y3,z3,x4,y4,z4
     &          ,solid_angle
     &          ,x(4),y(4),z(4)
     &          ,dx1,dy1,dz1,dx2,dy2,dz2,d11,d12,d22,cos_ang
        integer ii(4),k,i1,i2,i3,i4

c -----------------------------------------------------------------
c statement functions (may want to convert to in-line ...)

        real*8 crosx,crosy,crosz
        real*8 cx1,cy1,cz1,cx2,cy2,cz2,cx3,cy3,cz3

        crosx(cx1,cy1,cz1,cx2,cy2,cz2,cx3,cy3,cz3)
     &          =(cy2-cy1)*(cz3-cz1)-(cz2-cz1)*(cy3-cy1)
        crosy(cx1,cy1,cz1,cx2,cy2,cz2,cx3,cy3,cz3)
     &          =(cz2-cz1)*(cx3-cx1)-(cx2-cx1)*(cz3-cz1)
        crosz(cx1,cy1,cz1,cx2,cy2,cz2,cx3,cy3,cz3)
     &          =(cx2-cx1)*(cy3-cy1)-(cy2-cy1)*(cx3-cx1)

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

c solid angle from "area of spherical triangle" formula:
c for triangle on sphere of radius r, area of triangle is
c   area = (a_1+a_2+a_3-pi)*r*r
c where a_j=angle of j-th corner in tangent plane at that corner
c [I don't guarantee this is the most efficient coding]

c note: the sum of the solid angles of a tetrahedron should
c lie in range pi to 2*pi (? I think...),
c sum of solid angles around an interior point = 4*pi (tested)

        ! ..........................................
        ! convert to vectors for convenience
        ! and so code below could be inserted elsewhere
        ! with, eg, ii(j)=itet(j,iel) from itet relation
        ! (per coding commented out with "c|el|" below)

        x(1)=x1
        x(2)=x2
        x(3)=x3
        x(4)=x4
        y(1)=y1
        y(2)=y2
        y(3)=y3
        y(4)=y4
        z(1)=z1
        z(2)=z2
        z(3)=z3
        z(4)=z4
        do k=1,4
         ii(k)=k
        enddo

        ! ..........................................
        ! calc solid angle

c|el|   do iel=1,nelements
c|el|    do j=1,4
c|el|     if (mod(j,2).eq.0) then
c|el|      ii(1)=itet(j,iel)
c|el|      ii(2)=itet(1+mod(j,4),iel)
c|el|     else
c|el|      ii(2)=itet(j,i)
c|el|      ii(1)=itet(1+mod(j,4),i)
c|el|     endif
c|el|     ii(3)=itet(1+mod(j+1,4),i)
c|el|     ii(4)=itet(1+mod(j+2,4),i)
c|el|    enddo

        ! may want to change to pi from data statement....
        solid_angle=-3.14159265358d0

        i4=ii(4)
        do k=1,3

          i1=ii(k)
          i2=ii(1+mod(k,3))
          i3=ii(1+mod(k+1,3))

          dx1=crosx(x(i4),y(i4),z(i4)
     &                  ,x(i3),y(i3),z(i3),x(i1),y(i1),z(i1))
          dy1=crosy(x(i4),y(i4),z(i4)
     &                  ,x(i3),y(i3),z(i3),x(i1),y(i1),z(i1))
          dz1=crosz(x(i4),y(i4),z(i4)
     &                  ,x(i3),y(i3),z(i3),x(i1),y(i1),z(i1))
          dx2=crosx(x(i4),y(i4),z(i4)
     &                  ,x(i3),y(i3),z(i3),x(i2),y(i2),z(i2))
          dy2=crosy(x(i4),y(i4),z(i4)
     &                  ,x(i3),y(i3),z(i3),x(i2),y(i2),z(i2))
          dz2=crosz(x(i4),y(i4),z(i4)
     &                  ,x(i3),y(i3),z(i3),x(i2),y(i2),z(i2))

          d11=(dx1*dx1+dy1*dy1+dz1*dz1)
          d22=(dx2*dx2+dy2*dy2+dz2*dz2)
          d12=(dx1*dx2+dy1*dy2+dz1*dz2)

          cos_ang=d12/dsqrt(d11*d22)
          solid_angle=solid_angle + dacos(cos_ang)

          ! note the assumption has been made that this angle is
          ! between 0-180 degrees (ie, the triangle was correctly oriented)
          ! should be tested in general by also calculating the sine

        enddo
        ! write(*,*) solid_angle/(4.d0*3.14159265358d0)

c|el|    s_ang(1+mod(j+2,4),iel)=solid_angle
c|el|   enddo

        ! ..........................................
        return
        end


C
C $Id: nggsog.f,v 1.4 2008-07-27 00:17:18 haley Exp $
C
C                Copyright (C)  2000
C        University Corporation for Atmospheric Research
C                All Rights Reserved
C
C The use of this Software is governed by a License Agreement.
C
      SUBROUTINE NGGSOG (SLAT,SLON,SRAD,ALAT,ALON)
C
C This routine returns, in the arrays ALAT and ALON, the latitudes and
C longitudes of 6 points on the surface of the globe, defining a five-
C pointed star.  The last point returned is a copy of the first.  The
C star is centered at the point with latitude SLAT and longitude SLON
C and has a radius of approximately SRAD.  SLAT, SLON, and SRAD are all
C measured in degrees.
C
        DIMENSION ALAT(6),ALON(6)
C
C The array ANGL defines the directions to the points of the star.
C
        DIMENSION ANGL(6)
C
        DATA ANGL / 162. , 18. , -126. , 90. , -54. , 162. /
C
C Define multiplicative constants to convert from degrees to radians
C and from radians to degrees.
C
        DATA DTOR / .017453292519943 /
        DATA RTOD / 57.2957795130823 /
C
C Get the latitudes and longitudes for the caller.
C
        DO 101 IPNT=1,6
          UCRD=1.
          VCRD=TAN(DTOR*SRAD)*COS(DTOR*ANGL(IPNT))
          WCRD=TAN(DTOR*SRAD)*SIN(DTOR*ANGL(IPNT))
          TEMP=SQRT(UCRD*UCRD+VCRD*VCRD+WCRD*WCRD)
          UCRD=UCRD/TEMP
          VCRD=VCRD/TEMP
          WCRD=WCRD/TEMP
          CALL NGRITD (2,-SLAT,UCRD,VCRD,WCRD)
          CALL NGRITD (3, SLON,UCRD,VCRD,WCRD)
          ALAT(IPNT)=RTOD*ASIN(WCRD)
          ALON(IPNT)=RTOD*ATAN2(VCRD,UCRD)
  101   CONTINUE
C
C Done.
C
        RETURN
C
      END


module operators
  !  This module contains functions that evaluates the effect of operators on
  !  the wave functions
  use precision
  use globals
  interface operator (.a.)
     !  This operator (a) is the annihilation operator
     !
     !  expectation_a is the function that caclulates <y|a|y>
     !  oper_a is the function that calculates a|y>
     module procedure expectation_a
     module procedure oper_a
  end interface
  interface operator (.ad.)
     !  This operator (ad) is the creation operator
     !
     !  expectation_ad is the function that caclulates <y|ad|y>
     !  oper_ad is the function that calculates ad|y>
     module procedure expectation_ad
     module procedure oper_ad
  end interface
  interface operator (+)
     !  This overloads the operator + to apply to wave functions.
     !
     !  add_wave_fn adds co-efficients of the wave functions together
     module procedure add_wave_fn
  end interface
  interface operator (*)
     !  This overload the operator * to apply to wave functions.
     !
     !  scalar_mult_wave_fn multiplies the co-efficients of a wave function
     !    by a scalar
     !  wave_fn_mult_scalar multiplies the co-efficients of a wave function
     !    by a scalar
     module procedure scalar_mult_wave_fn
     module procedure wave_fn_mult_scalar
  end interface

contains

  function add_wave_fn(y1,y2) result(tmpy)
    !  This function add the co-efficients of wave functions together
    !
    !  y1 and y2 are the input wave functions to add together
    !  tmpy is the result of the operation
    type(wave_fn), intent(in) :: y1, y2
    type(wave_fn) :: tmpy
    if (y1%in_basis%alpha /= y2%in_basis%alpha .or. y1%in_basis%n /= y2%in_basis%n) then

       write(*,*) 'Can not add two wave functions that are dissimilar'
    else

       tmpy%in_basis=y1%in_basis
       allocate(tmpy%co_eff(tmpy%in_basis%n))
       tmpy%co_eff=y1%co_eff + y2%co_eff
    end if
  end function add_wave_fn
  function scalar_mult_wave_fn(a,y) result(tmpy)
    !  This multiplies the co-efficients of a wave function by a scalar
    !
    !  a is the scalar to multiply the wave function by
    !  y is the wave function to be multiplied by the scalar
    !  tmpy is the result of the operation
    type(wave_fn), intent(in) :: y
    complex(cdp), intent(in) :: a
    type(wave_fn) :: tmpy
    tmpy%in_basis=y%in_basis
    allocate(tmpy%co_eff(0:tmpy%in_basis%n))
    tmpy%co_eff=a*y%co_eff
  end function scalar_mult_wave_fn
  function wave_fn_mult_scalar(y,a) result(tmpy)

    !  This multiplies the co-efficients of a wave function by a scalar
    !
    !  a is the scalar to multiply the wave function by
    !  y is the wave function to be multiplied by the scalar
    !  tmpy is the result of the operation

    type(wave_fn), intent(in) :: y
    complex(cdp), intent(in) :: a
    type(wave_fn) :: tmpy

    tmpy%in_basis=y%in_basis

    allocate(tmpy%co_eff(0:tmpy%in_basis%n))

    tmpy%co_eff=a*y%co_eff
  end function wave_fn_mult_scalar

  function oper_a(y) result(tmpy)
    !  This func calculates a|y> and returns the appropriate value
    !
    !  y is the wave function is the operation a|y>
    !  tmpy is the result of the operation
    !  loop is used to loop over all the co-efficients in the wave function
    !  alpha is the point that the basis is centered at
    type(wave_fn), intent(in) :: y
    type(wave_fn) :: tmpy
    integer(isp) :: loop
    complex(cdp) :: alpha
    tmpy%in_basis = y%in_basis
    alpha = y%in_basis%alpha

    allocate(tmpy%co_eff(0:tmpy%in_basis%n))
    tmpy%co_eff=cmplx(0)
    do loop=0,tmpy%in_basis%n-1

       tmpy%co_eff(loop) = sqrt(dble(loop+1))*y%co_eff(loop+1) + alpha*y%co_eff(loop)
    end do
    tmpy%co_eff(tmpy%in_basis%n) = alpha*y%co_eff(y%in_basis%n)
  end function oper_a
  function expectation_a(y1,y2) result(alpha)

    !  This func calculates the expectation value of <y|a|y>
    !
    !  y1 and y2 are the wave functions for the operation <y1|a|y2>
    !  alpha is the point that the basis of y2 is centered upon
    !  loop is used to loop over the co-efficients of the wave functions
    !  minn is the minimum number of basis states of the two wave functions

    type(wave_fn), intent(in) :: y1, y2
    complex(cdp) :: alpha
    integer(isp) :: loop, minn
    minn=min(y1%in_basis%n,y2%in_basis%n)

    alpha=y2%in_basis%alpha

    do loop=0,minn-1

       alpha=alpha + sqrt(dble(loop+1))*conjg(y1%co_eff(loop))*y2%co_eff(loop+1)

    end do

  end function expectation_a

  function oper_ad(y) result(tmpy)
    !  This func calculates ad|y> and returns the appropriate value
    !
    !  y is the wave function is the operation ad|y>
    !  tmpy is the result of the operation
    !  loop is used to loop over all the co-efficients in the wave function
    !  alpha is the point that the basis is centered at
    type(wave_fn), intent(in) :: y
    type(wave_fn) :: tmpy
    integer(isp) :: loop
    complex(cdp) :: alpha
    tmpy%in_basis = y%in_basis
    alpha=y%in_basis%alpha

    allocate(tmpy%co_eff(0:tmpy%in_basis%n))
    tmpy%co_eff=cmplx(0)
    do loop=1,tmpy%in_basis%n

       tmpy%co_eff(loop) = sqrt(dble(loop))*y%co_eff(loop-1) + conjg(alpha)*y%co_eff(loop)
    end do
    tmpy%co_eff(0) = conjg(alpha)*y%co_eff(0)
  end function oper_ad
  function expectation_ad(y1,y2) result(alpha)

    !  This func calculates the expectation value of <y|ad|y>
    !
    !  y1 and y2 are the wave functions for the operation <y1|ad|y2>
    !  alpha is the conjugate of the point the basis of y2 is centered upon
    !  loop is used to loop over the co-efficients of the wave functions
    !  minn is the minimum number of basis states of the two wave functions

    type(wave_fn), intent(in) :: y1, y2
    complex(cdp) :: alpha
    integer(isp) :: loop,minn
    minn=min(y1%in_basis%n,y2%in_basis%n)

    alpha=conjg(y2%in_basis%alpha)

    do loop=1,minn

       alpha=alpha + sqrt(dble(loop))*conjg(y1%co_eff(loop))*y2%co_eff(loop-1)

    end do

  end function expectation_ad
  function normalisation(y) result(norm)
    !  This function will return a constant to normalise a wave function
    !
    !  y is the wave function that is needed to be normalised
    !  norm is the constant that will normalise the wave function y
    type(wave_fn), intent(in) :: y
    real(fdp) :: norm
    norm = real(sqrt(sum(y%co_eff*conjg(y%co_eff))))
  end function normalisation

end module operators


program shiju
	real*8 v1,v2,v3,h1,h2,a1,a2,x0,x,t,t0
	v1=500;v2=1200;v3=3600;h1=20;h2=10
	open(13,file="shiju-3")
	t0=2*h1/(v1*(1-(v1/v3)**2)**0.5)+2*h2/(v2*(1-(v2/v3)**2)**0.5)
	x0=2*h1*v1/v3/(1-(v1/v3)**2)**0.5+2*h2*v2/v3/(1-(v2/v3)**2)**0.5
	write(13,"(3a13)")"t","x","zheshe"
	do i=1,2
		t=t0+(x0*i-x0)/v3
		x=x0*i
		write(13,"(2f13.6)")t,x
	end do
	write(13,"(3a13)")"t","x","fanshe"
	a1=0
	do i=1,20
		t=2*h1/(1-sin(0.1*i)**2)**0.5/v1
		t=t+2*h2/(1-(sin(0.1*i)*v2/v1)**2)**0.5/v2
		x=2*h1*sin(0.1*i)/(1-sin(0.1*i)**2)**0.5
		x=x+2*h2*(sin(0.1*i)*v2/v1)/(1-(sin(0.1*i)*v2/v1)**2)**0.5
		write(13,"(2f13.6)")t,x
	end do

	close(13)
end program shiju


      SUBROUTINE TC04AD( LERI, M, P, INDEX, PCOEFF, LDPCO1, LDPCO2,
     $                   QCOEFF, LDQCO1, LDQCO2, N, RCOND, A, LDA, B,
     $                   LDB, C, LDC, D, LDD, IWORK, DWORK, LDWORK,
     $                   INFO )
C
C     SLICOT RELEASE 5.7.
C
C     Copyright (c) 2002-2020 NICONET e.V.
C
C     PURPOSE
C
C     To find a state-space representation (A,B,C,D) with the same
C     transfer matrix T(s) as that of a given left or right polynomial
C     matrix representation, i.e.
C
C        C*inv(sI-A)*B + D = T(s) = inv(P(s))*Q(s) = Q(s)*inv(P(s)).
C
C     ARGUMENTS
C
C     Mode Parameters
C
C     LERI    CHARACTER*1
C             Indicates whether a left polynomial matrix representation
C             or a right polynomial matrix representation is input as
C             follows:
C             = 'L':  A left matrix fraction is input;
C             = 'R':  A right matrix fraction is input.
C
C     Input/Output Parameters
C
C     M       (input) INTEGER
C             The number of system inputs.  M >= 0.
C
C     P       (input) INTEGER
C             The number of system outputs.  P >= 0.
C
C     INDEX   (input) INTEGER array, dimension (MAX(M,P))
C             If LERI = 'L', INDEX(I), I = 1,2,...,P, must contain the
C             maximum degree of the polynomials in the I-th row of the
C             denominator matrix P(s) of the given left polynomial
C             matrix representation.
C             If LERI = 'R', INDEX(I), I = 1,2,...,M, must contain the
C             maximum degree of the polynomials in the I-th column of
C             the denominator matrix P(s) of the given right polynomial
C             matrix representation.
C
C     PCOEFF  (input) DOUBLE PRECISION array, dimension
C             (LDPCO1,LDPCO2,kpcoef), where kpcoef = MAX(INDEX(I)) + 1.
C             If LERI = 'L' then porm = P, otherwise porm = M.
C             The leading porm-by-porm-by-kpcoef part of this array must
C             contain the coefficients of the denominator matrix P(s).
C             PCOEFF(I,J,K) is the coefficient in s**(INDEX(iorj)-K+1)
C             of polynomial (I,J) of P(s), where K = 1,2,...,kpcoef; if
C             LERI = 'L' then iorj = I, otherwise iorj = J.
C             Thus for LERI = 'L', P(s) =
C             diag(s**INDEX(I))*(PCOEFF(.,.,1)+PCOEFF(.,.,2)/s+...).
C             If LERI = 'R', PCOEFF is modified by the routine but
C             restored on exit.
C
C     LDPCO1  INTEGER
C             The leading dimension of array PCOEFF.
C             LDPCO1 >= MAX(1,P) if LERI = 'L',
C             LDPCO1 >= MAX(1,M) if LERI = 'R'.
C
C     LDPCO2  INTEGER
C             The second dimension of array PCOEFF.
C             LDPCO2 >= MAX(1,P) if LERI = 'L',
C             LDPCO2 >= MAX(1,M) if LERI = 'R'.
C
C     QCOEFF  (input) DOUBLE PRECISION array, dimension
C             (LDQCO1,LDQCO2,kpcoef)
C             If LERI = 'L' then porp = M, otherwise porp = P.
C             The leading porm-by-porp-by-kpcoef part of this array must
C             contain the coefficients of the numerator matrix Q(s).
C             QCOEFF(I,J,K) is defined as for PCOEFF(I,J,K).
C             If LERI = 'R', QCOEFF is modified by the routine but
C             restored on exit.
C
C     LDQCO1  INTEGER
C             The leading dimension of array QCOEFF.
C             LDQCO1 >= MAX(1,P)   if LERI = 'L',
C             LDQCO1 >= MAX(1,M,P) if LERI = 'R'.
C
C     LDQCO2  INTEGER
C             The second dimension of array QCOEFF.
C             LDQCO2 >= MAX(1,M)   if LERI = 'L',
C             LDQCO2 >= MAX(1,M,P) if LERI = 'R'.
C
C     N       (output) INTEGER
C             The order of the resulting state-space representation.
C                          porm
C             That is, N = SUM INDEX(I).
C                          I=1
C
C     RCOND   (output) DOUBLE PRECISION
C             The estimated reciprocal of the condition number of the
C             leading row (if LERI = 'L') or the leading column (if
C             LERI = 'R') coefficient matrix of P(s).
C             If RCOND is nearly zero, P(s) is nearly row or column
C             non-proper.
C
C     A       (output) DOUBLE PRECISION array, dimension (LDA,N)
C             The leading N-by-N part of this array contains the state
C             dynamics matrix A.
C
C     LDA     INTEGER
C             The leading dimension of array A.  LDA >= MAX(1,N).
C
C     B       (output) DOUBLE PRECISION array, dimension (LDB,MAX(M,P))
C             The leading N-by-M part of this array contains the
C             input/state matrix B; the remainder of the leading
C             N-by-MAX(M,P) part is used as internal workspace.
C
C     LDB     INTEGER
C             The leading dimension of array B.  LDB >= MAX(1,N).
C
C     C       (output) DOUBLE PRECISION array, dimension (LDC,N)
C             The leading P-by-N part of this array contains the
C             state/output matrix C; the remainder of the leading
C             MAX(M,P)-by-N part is used as internal workspace.
C
C     LDC     INTEGER
C             The leading dimension of array C.  LDC >= MAX(1,M,P).
C
C     D       (output) DOUBLE PRECISION array, dimension (LDD,MAX(M,P))
C             The leading P-by-M part of this array contains the direct
C             transmission matrix D; the remainder of the leading
C             MAX(M,P)-by-MAX(M,P) part is used as internal workspace.
C
C     LDD     INTEGER
C             The leading dimension of array D.  LDD >= MAX(1,M,P).
C
C     Workspace
C
C     IWORK   INTEGER array, dimension (2*MAX(M,P))
C
C     DWORK   DOUBLE PRECISION array, dimension (LDWORK)
C             On exit, if INFO = 0, DWORK(1) returns the optimal value
C             of LDWORK.
C
C     LDWORK  INTEGER
C             The length of the array DWORK.
C             LDWORK >= MAX(1,MAX(M,P)*(MAX(M,P)+4)).
C             For optimum performance LDWORK should be larger.
C
C     Error Indicator
C
C     INFO    INTEGER
C             = 0:  successful exit;
C             < 0:  if INFO = -i, the i-th argument had an illegal
C                   value;
C             = 1:  if P(s) is not row (if LERI = 'L') or column
C                   (if LERI = 'R') proper. Consequently, no state-space
C                   representation is calculated.
C
C     METHOD
C
C     The method for a left matrix fraction will be described here;
C     right matrix fractions are dealt with by obtaining the dual left
C     polynomial matrix representation and constructing an equivalent
C     state-space representation for this. The first step is to check
C     if the denominator matrix P(s) is row proper; if it is not then
C     the routine returns with the Error Indicator (INFO) set to 1.
C     Otherwise, Wolovich's Observable  Structure Theorem is used to
C     construct a state-space representation (A,B,C,D) in observable
C     companion form. The sizes of the blocks of matrix A and matrix C
C     here are precisely the row degrees of P(s), while their
C     'non-trivial' columns are given easily from its coefficients.
C     Similarly, the matrix D is obtained from the leading coefficients
C     of P(s) and of the numerator matrix Q(s), while matrix B is given
C     by the relation Sbar(s)B = Q(s) - P(s)D, where Sbar(s) is a
C     polynomial matrix whose (j,k)(th) element is given by
C
C                  j-u(k-1)-1
C               ( s           , j = u(k-1)+1,u(k-1)+2,....,u(k)
C     Sbar    = (
C        j,k    (           0 , otherwise
C
C             k
C     u(k) = SUM d , k = 1,2,...,M and d ,d ,...,d  are the
C            i=1  i                     1  2      M
C     controllability indices. For convenience in solving this, C' and B
C     are initially set up to contain the coefficients of P(s) and Q(s),
C     respectively, stored by rows.
C
C     REFERENCES
C
C     [1] Wolovich, W.A.
C         Linear Multivariate Systems, (Theorem 4.3.3).
C         Springer-Verlag, 1974.
C
C     NUMERICAL ASPECTS
C                               3
C     The algorithm requires 0(N ) operations.
C
C     CONTRIBUTOR
C
C     Release 3.0: V. Sima, Katholieke Univ. Leuven, Belgium, Dec. 1996.
C     Supersedes Release 2.0 routine TC01BD by T.W.C.Williams, Kingston
C     Polytechnic, United Kingdom, March 1982.
C
C     REVISIONS
C
C     February 22, 1998 (changed the name of TC01ND).
C     May 12, 1998.
C
C     KEYWORDS
C
C     Coprime matrix fraction, elementary polynomial operations,
C     polynomial matrix, state-space representation, transfer matrix.
C
C     ******************************************************************
C
C     .. Parameters ..
      DOUBLE PRECISION  ZERO, ONE
      PARAMETER         ( ZERO = 0.0D0, ONE = 1.0D0 )
C     .. Scalar Arguments ..
      CHARACTER         LERI
      INTEGER           INFO, LDA, LDB, LDC, LDD, LDPCO1, LDPCO2,
     $                  LDQCO1, LDQCO2, LDWORK, M, N, P
      DOUBLE PRECISION  RCOND
C     .. Array Arguments ..
      INTEGER           INDEX(*), IWORK(*)
      DOUBLE PRECISION  A(LDA,*), B(LDB,*), C(LDC,*), D(LDD,*),
     $                  DWORK(*), PCOEFF(LDPCO1,LDPCO2,*),
     $                  QCOEFF(LDQCO1,LDQCO2,*)
C     .. Local Scalars ..
      LOGICAL           LLERI
      INTEGER           I, IA, IBIAS, J, JA, JC, JW, JWORK, LDW, K,
     $                  KPCOEF, KSTOP, MAXIND, MINDEX, MWORK, PWORK,
     $                  WRKOPT
      DOUBLE PRECISION  DWNORM
C     .. External Functions ..
      LOGICAL           LSAME
      DOUBLE PRECISION  DLAMCH, DLANGE
      EXTERNAL          LSAME, DLAMCH, DLANGE
C     .. External Subroutines ..
      EXTERNAL          AB07MD, DCOPY, DGECON, DGEMM, DGETRF, DGETRI,
     $                  DGETRS, DLACPY, DLASET, TC01OD, XERBLA
C     .. Intrinsic Functions ..
      INTRINSIC         INT, MAX
C     .. Executable Statements ..
C
      INFO = 0
      LLERI = LSAME( LERI, 'L' )
      MINDEX = MAX( M, P )
C
C     Test the input scalar arguments.
C
      IF( .NOT.LLERI .AND. .NOT.LSAME( LERI, 'R' ) ) THEN
         INFO = -1
      ELSE IF( M.LT.0 ) THEN
         INFO = -2
      ELSE IF( P.LT.0 ) THEN
         INFO = -3
      ELSE IF( ( LLERI .AND. LDPCO1.LT.MAX( 1, P ) ) .OR.
     $    ( .NOT.LLERI .AND. LDPCO1.LT.MAX( 1, M ) ) ) THEN
         INFO = -6
      ELSE IF( ( LLERI .AND. LDPCO2.LT.MAX( 1, P ) ) .OR.
     $    ( .NOT.LLERI .AND. LDPCO2.LT.MAX( 1, M ) ) ) THEN
         INFO = -7
      ELSE IF( ( LLERI .AND. LDQCO1.LT.MAX( 1, P ) ) .OR.
     $    ( .NOT.LLERI .AND. LDQCO1.LT.MAX( 1, MINDEX ) ) ) THEN
         INFO = -9
      ELSE IF( ( LLERI .AND. LDQCO2.LT.MAX( 1, M ) ) .OR.
     $    ( .NOT.LLERI .AND. LDQCO2.LT.MAX( 1, MINDEX ) ) ) THEN
         INFO = -10
      END IF
C
      N = 0
      IF ( INFO.EQ.0 ) THEN
         IF ( LLERI ) THEN
            PWORK = P
            MWORK = M
         ELSE
            PWORK = M
            MWORK = P
         END IF
C
         MAXIND = 0
         DO 10 I = 1, PWORK
            N = N + INDEX(I)
            IF ( INDEX(I).GT.MAXIND ) MAXIND = INDEX(I)
   10    CONTINUE
         KPCOEF = MAXIND + 1
      END IF
C
      IF( LDA.LT.MAX( 1, N ) ) THEN
         INFO = -14
      ELSE IF( LDB.LT.MAX( 1, N ) ) THEN
         INFO = -16
      ELSE IF( LDC.LT.MAX( 1, MINDEX ) ) THEN
         INFO = -18
      ELSE IF( LDD.LT.MAX( 1, MINDEX ) ) THEN
         INFO = -20
      ELSE IF( LDWORK.LT.MAX( 1, MINDEX*( MINDEX + 4 ) ) ) THEN
         INFO = -23
      END IF
C
      IF ( INFO.NE.0 ) THEN
C
C        Error return.
C
         CALL XERBLA( 'TC04AD', -INFO )
         RETURN
      END IF
C
C     Quick return if possible.
C
      IF ( M.EQ.0 .OR. P.EQ.0 ) THEN
         N = 0
         RCOND = ONE
         DWORK(1) = ONE
         RETURN
      END IF
C
      IF ( .NOT.LLERI ) THEN
C
C        Initialization for right matrix fraction: obtain the dual
C        system.
C
         CALL TC01OD( 'R', M, P, KPCOEF, PCOEFF, LDPCO1, LDPCO2,
     $                QCOEFF, LDQCO1, LDQCO2, INFO )
      END IF
C
C     Store leading row coefficient matrix of P(s).
C
      LDW = MAX( 1, PWORK )
      CALL DLACPY( 'Full', PWORK, PWORK, PCOEFF, LDPCO1, DWORK, LDW )
C
C     Check if P(s) is row proper: if not, exit.
C
      DWNORM = DLANGE( '1-norm', PWORK, PWORK, DWORK, LDW, DWORK )
C
      CALL DGETRF( PWORK, PWORK, DWORK, LDW, IWORK, INFO )
C
C     Workspace: need  PWORK*(PWORK + 4).
C
C     (Note: Comments in the code beginning "Workspace:" describe the
C     minimal amount of real workspace needed at that point in the
C     code, as well as the preferred amount for good performance.
C     NB refers to the optimal block size for the immediately
C     following subroutine, as returned by ILAENV.)
C
      JWORK = LDW*PWORK + 1
C
      CALL DGECON( '1-norm', PWORK, DWORK, LDW, DWNORM, RCOND,
     $             DWORK(JWORK), IWORK(PWORK+1), INFO )
C
      WRKOPT = MAX( 1, PWORK*(PWORK + 4) )
C
      IF ( RCOND.LE.DLAMCH( 'Epsilon' ) ) THEN
C
C        Error return: P(s) is not row proper.
C
         INFO = 1
         RETURN
      ELSE
C
C        Calculate the order of equivalent state-space representation,
C        and initialize A.
C
         CALL DLASET( 'Full', N, N, ZERO, ZERO, A, LDA )
C
         DWORK(JWORK) = ONE
         IF ( N.GT.1 ) CALL DCOPY( N-1, DWORK(JWORK), 0, A(2,1), LDA+1 )
C
C        Find the PWORK ordered 'non-trivial' columns row by row,
C        in PWORK row blocks, the I-th having INDEX(I) rows.
C
         IBIAS = 2
C
         DO 50 I = 1, PWORK
            KSTOP = INDEX(I) + 1
            IF ( KSTOP.NE.1 ) THEN
               IBIAS = IBIAS + INDEX(I)
C
C              These rows given from the lower coefficients of row I
C              of P(s).
C
               DO 40 K = 2, KSTOP
                  IA = IBIAS - K
C
                  DO 20 J = 1, PWORK
                     DWORK(JWORK+J-1) = -PCOEFF(I,J,K)
   20             CONTINUE
C
                  CALL DGETRS( 'Transpose', PWORK, 1, DWORK, LDW,
     $                         IWORK, DWORK(JWORK), LDW, INFO )
C
                  JA = 0
C
                  DO 30 J = 1, PWORK
                     IF ( INDEX(J).NE.0 ) THEN
                        JA = JA + INDEX(J)
                        A(IA,JA) = DWORK(JWORK+J-1)
                     END IF
   30             CONTINUE
C
C                 Also, set up B and C (temporarily) for use when
C                 finding B.
C
                  CALL DCOPY( MWORK, QCOEFF(I,1,K), LDQCO1, B(IA,1),
     $                        LDB )
                  CALL DCOPY( PWORK, PCOEFF(I,1,K), LDPCO1, C(1,IA), 1 )
   40          CONTINUE
C
            END IF
   50    CONTINUE
C
C        Calculate D from the leading coefficients of P and Q.
C
         CALL DLACPY( 'Full', PWORK, MWORK, QCOEFF, LDQCO1, D, LDD )
C
         CALL DGETRS( 'No transpose', PWORK, MWORK, DWORK, LDW, IWORK,
     $                D, LDD, INFO )
C
C        For B and C as set up above, desired B = B - (C' * D).
C
         CALL DGEMM( 'Transpose', 'No transpose', N, MWORK, PWORK, -ONE,
     $               C, LDC, D, LDD, ONE, B, LDB )
C
C        Finally, calculate C: zero, apart from ...
C
         CALL DLASET( 'Full', PWORK, N, ZERO, ZERO, C, LDC )
C
C        PWORK ordered 'non-trivial' columns, equal to those
C        of inv(DWORK).
C
C        Workspace: need   PWORK*(PWORK + 1);
C                   prefer PWORK*PWORK + PWORK*NB.
C
         CALL DGETRI( PWORK, DWORK, LDW, IWORK, DWORK(JWORK),
     $                LDWORK-JWORK+1, INFO )
C
         WRKOPT = MAX( WRKOPT, INT( DWORK(JWORK) )+JWORK-1 )
         JC = 0
         JW = 1
C
         DO 60 J = 1, PWORK
            IF ( INDEX(J).NE.0 ) THEN
               JC = JC + INDEX(J)
               CALL DCOPY( PWORK, DWORK(JW), 1, C(1,JC), 1 )
            END IF
            JW = JW + LDW
   60    CONTINUE
C
      END IF
C
C     For right matrix fraction, return to original (dual of dual)
C     system.
C
      IF ( .NOT.LLERI ) THEN
         CALL TC01OD( 'L', MWORK, PWORK, KPCOEF, PCOEFF, LDPCO1,
     $                LDPCO2, QCOEFF, LDQCO1, LDQCO2, INFO )
C
C        Also, obtain dual of state-space representation.
C
         CALL AB07MD( 'D', N, MWORK, PWORK, A, LDA, B, LDB, C, LDC, D,
     $                LDD, INFO )
      END IF
C
C     Set optimal workspace dimension.
C
      DWORK(1) = WRKOPT
C
      RETURN
C *** Last line of TC04AD ***
      END


      REAL*8 FUNCTION TIMLOC(TSEC50,SCPOS,KCOORD,KREFSUN)
      IMPLICIT REAL*8 (A-H,O-Z)
C
C  THIS ROUTINE COMPUTES THE LOCAL TIME AT THE MERIDIAN ABOVE WHICH
C  THE S/C IS LOCATED. THE LOCAL TIME IS REFERENCED TO THE FICTITIOUS
C  MEAN SUN OR TO THE TRUE SUN, DEPENDING UPON THE VALUE OF KREFSUN.
C
C  VARIABLE  DIM TYPE I/O  DESCRIPTION
C  --------  --- ---- ---  -----------
C
C  TSEC50     1  R*8   I   TIME ASSOCIATED WITH THE S/C POSITION. IN
C                          SECONDS SINCE 1/1/50, 00:00:00 UT.
C
C  SCPOS      3  R*8   I   THE SPACECRAFT GEOCENTRIC POSITION VECTOR.
C                          MAY BE IN ANY LENGTH UNITS.
C
C  KCOORD     1  I*4   I   FLAG IDENTIFYING THE COORDINATE SYSTEM IN
C                          WHICH SCPOS IS GIVEN.
C
C                          = 1, MEAN OF 1950.0
C                          = 2, MEAN OF DATE, DATE=TSEC50
C                          = 3, TRUE OF DATE, DATE=TSEC50
C                          = OTHERWISE, USED AS THOUGH =3 WERE ENTERED.
C
C  KREFSUN    1  I*4   I   FLAG INDICATING WHETHER THE MEAN SUN OR TRUE
C                          SUN IS TO BE USED.
C
C                          = 0, USE FICTITIOUS MEAN SUN. THE LOCAL TIME
C                               IS COMPUTED USING THE TIME AT GREENWICH
C                               PLUS A TIME DIFFERENCE BASED ON THE
C                               S/C LONGITUDE RELATIVE TO GREENWICH,
C                               EACH 15.0 DEGREES OF LONGITUDE BEING
C                               EQUIVALENT TO ONE HOUR IN TIME.
C
C                          = OTHERWISE, USE TRUE SUN. THE LOCAL TIME IS
C                               COMPUTED USING 12:00 NOON AS THE TIME
C                               AT THE SUN MERIDIAN AND ADDING A TIME
C                               DIFFERENCE BASED ON THE S/C AND SUN
C                               RIGHT ASCENSION DIFFERENCE, EACH 15.0
C                               DEGREES OF LONGITUDE BEING EQUIVALENT
C                               TO ONE HOUR IN TIME.
C
C  TIMLOC     1  R*8   O   LOCAL TIME IN SECONDS. THE RANGE IS
C                          0.D0 TO 86400.D0
C
C                          EXAMPLE, 18:00:00 IN LOCAL TIME IS
C                                     TIMLOC=64800.0 SECONDS.
C
C***********************************************************************
C
C  BY C PETRUZZO, GSFC/470.3, 5/83.
C            MODIFIED... CJP 6/85. MAJOR REWRITE TO DELETE CLUMSY CODE,
C                                  USE SUBSEQUENTLY CODED ROUTINES, AND
C                                  MAKE IT MORE READABLE.
C
C***********************************************************************
C
C
      REAL*8 SCPOS(3),SUNPOS(3),SCTOD(3)
      REAL*8 SECDAY/86400.D0/,SECHAFDAY/43200.D0/
      REAL*8 TSUNLAST/-1.D10/,TGHALAST/-1.D10/
      REAL*8 TWOPI  / 6.283185307179586D0 /
      REAL*8 DEGRAD / 57.29577951308232D0 /
C
      IBUG = 0
      LUBUG = 19
C
      IF(IBUG.NE.0) WRITE(LUBUG,1001)
     *     PAKTIM50(TSEC50),SCPOS,KCOORD,KREFSUN
 1001 FORMAT(/,' TIMLOC DEBUG. ENTRY INFO:  TIME=',G23.16/,
     *         ' SCPOS=',3G15.8,'  KCOORD,KREFSUN=',2I3)
C
C INITIALIZE
C
      IF(KCOORD.GE.1 .AND.KCOORD.LE.3) THEN
        ICOORD = KCOORD
      ELSE
        ICOORD = 3
        END IF
C
C    CONVERT INPUT POSITION COORDINATES TO TRUE OF DATE.
      IF(ICOORD.EQ.1) THEN        ! M50 TO TOD
        CALL VECM50TOD(TSEC50,1,SCPOS,SCTOD)
      ELSE IF(ICOORD.EQ.2) THEN   ! MDT TO TOD
        CALL VECMDTTOD(TSEC50,1,SCPOS,SCTOD)
      ELSE                        ! ALREADY TOD
        SCTOD(1) = SCPOS(1)
        SCTOD(2) = SCPOS(2)
        SCTOD(3) = SCPOS(3)
        END IF
C
C    GET S/C RIGHT ASCENSION
      CALL XYZSPH(-1,SCRA,DUM,DUM,SCTOD,1.D0)
      IF(IBUG.NE.0) WRITE(LUBUG,1002) SCRA*DEGRAD,SCTOD
 1002 FORMAT(' TIMLOC DEBUG. SCRA(TOD)=',F8.3/,'   SCTOD=',3G16.8)
C
C
C COMPUTE THE LOCAL TIME
C
      IF(KREFSUN.EQ.0) THEN
C
C      FOR MEAN SOLAR TIME.
C       METHOD: GET THE RIGHT ASCENSION OF THE GREENWICH MERIDIAN,
C       CONVERT THE DIFFERENCE IN RIGHT ASCENSIONS TO A TIME DIFFERENCE,
C       ADD THE TIME DIFFERENCE TO THE TIME AT GREENWICH TO GET THE
C       LOCAL TIME AT THE S/C.
C
        IF(TSEC50.NE.TGHALAST) GHA = GHANGL(TSEC50,1)
        TGHALAST = TSEC50
        TDIFF = EQVANG(SCRA-GHA)/TWOPI * SECDAY
        TIMLOC = DMOD( TSEC50 + TDIFF, SECDAY )
        IF(IBUG.NE.0) WRITE(LUBUG,1003) GHA*DEGRAD,TDIFF,TIMLOC
 1003   FORMAT(' TIMLOC DEBUG. GHA=',F8.3,'  TDIFF,TIMLOC=',2G16.8)
C
      ELSE
C      FOR TRUE SOLAR TIME
C       METHOD: GET THE SUN'S RIGHT ASCENSION, CONVERT THE DIFFERENCE
C       IN RIGHT ASCENSIONS TO A TIME DIFFERENCE, ADD THE TIME
C       DIFFERENCE TO THE TIME AT SUN MERIDIAN(=12:00 NOON) TO GET
C       THE LOCAL TIME AT THE S/C.
C
        IF(TSEC50.NE.TSUNLAST) CALL SOLTOD(TSEC50,SUNPOS,0)
        TSUNLAST = TSEC50
        CALL XYZSPH(-1,SUNRA,DUM,DUM,SUNPOS,1.D0)
        TDIFF = EQVANG(SCRA-SUNRA)/TWOPI * SECDAY
        TIMLOC = DMOD( SECHAFDAY + TDIFF, SECDAY )
        IF(IBUG.NE.0) WRITE(LUBUG,1004) SUNRA*DEGRAD,TDIFF,TIMLOC
 1004   FORMAT(' TIMLOC DEBUG. SUNRA=',F8.3,'  TDIFF,TIMLOC=',2G16.8)
C
        END IF
C
      RETURN
      END


program extract_SM_results_for_web
! compile with the command:
! gfortran extract_SM_results_for_web.f90 -o extract_SM_results_for_web -L. -lHB

 implicit none
 ! SM functions from the HiggsBounds library
 double precision :: SMBR_HWW
 double precision :: SMBR_HZZ
 double precision :: SMBR_Hbb
 double precision :: SMBR_Htautau
 double precision :: SMBR_Hgamgam
 double precision :: SMBR_Hgg
 double precision :: SMGamma_h
 double precision :: SMGamma_tWpb

 double precision :: SMBR_HZgam
 double precision :: SMBR_Htoptop
 double precision :: SMBR_Hcc
 double precision :: SMBR_Hss
 double precision :: SMBR_Hmumu

 double precision :: SMCS_tev_HW
 double precision :: SMCS_tev_HZ
 double precision :: SMCS_tev_gg_H
 double precision :: SMCS_tev_bb_H
 double precision :: SMCS_tev_vbf_H
 double precision :: SMCS_tev_bg_Hb
 double precision :: SMCS_tev_ttH

 double precision :: SMCS_lhc7_HW
 double precision :: SMCS_lhc7_HZ
 double precision :: SMCS_lhc7_gg_H
 !double precision :: SMCS_lhc7_bb_H !not in code yet
 double precision :: SMCS_lhc7_vbf_H
 !double precision :: SMCS_lhc7_bg_Hb !not in code yet
 double precision :: SMCS_lhc7_ttH

 double precision :: SMCS_lhc8_HW
 double precision :: SMCS_lhc8_HZ
 double precision :: SMCS_lhc8_gg_H
 !double precision :: SMCS_lhc8_bb_H !not in code yet
 double precision :: SMCS_lhc8_vbf_H
 !double precision :: SMCS_lhc8_bg_Hb !not in code yet
 double precision :: SMCS_lhc8_ttH

 ! internal
 double precision :: Mhi,mt
 integer :: number_args
 character(LEN=100) :: temp
 character(LEN=9) :: f_out
 double precision :: SMtemp
 integer :: iargc

 number_args = IARGC()

 if(number_args.ne.1)then
  stop 'program extract_SM_results_for_web has wrong number of arguments'
 endif

 temp=""
 call GETARG(1,temp)
 read(temp,*) Mhi

 mt=173.1D0

 ! call subroutine initialize_HiggsBounds with dummy arguments
 call initialize_HiggsBounds(1,0,'LandH')

 write(*,*)''
 write(*,*)'~ some of the Standard Model quantities used internally in HiggsBounds ~'
 write(*,*)''
 write(*,*)'For a SM Higgs with a mass (in GeV) of ',Mhi
 write(*,*)'the SM branching ratios are'

 f_out='(a,G16.6)'

 SMtemp=              SMBR_HWW(Mhi)     ; call flush(6)
 write(*,fmt=f_out)'  SMBR_HWW      = ' , SMtemp
 SMtemp=              SMBR_HZZ(Mhi)     ; call flush(6)
 write(*,fmt=f_out)'  SMBR_HZZ      = ' , SMtemp
 SMtemp=              SMBR_Hbb(Mhi)     ; call flush(6)
 write(*,fmt=f_out)'  SMBR_Hbb      = ' , SMtemp
 SMtemp=              SMBR_Htautau(Mhi) ; call flush(6)
 write(*,fmt=f_out)'  SMBR_Htautau  = ' , SMtemp
 SMtemp=              SMBR_Hgamgam(Mhi) ; call flush(6)
 write(*,fmt=f_out)'  SMBR_Hgamgam  = ' , SMtemp
 SMtemp=              SMBR_Hgg(Mhi)     ; call flush(6)
 write(*,fmt=f_out)'  SMBR_Hgg      = ' , SMtemp

 SMtemp=              SMBR_HZgam(Mhi)     ; call flush(6)
 write(*,fmt=f_out)'  SMBR_HZgam    = ' , SMtemp
 SMtemp=              SMBR_HZZ(Mhi)     ; call flush(6)
 write(*,fmt=f_out)'  SMBR_Htoptop  = ' , SMtemp
 SMtemp=              SMBR_Hcc(Mhi)     ; call flush(6)
 write(*,fmt=f_out)'  SMBR_Hcc      = ' , SMtemp
 SMtemp=              SMBR_Hss(Mhi)     ; call flush(6)
 write(*,fmt=f_out)'  SMBR_Hss      = ' , SMtemp
 SMtemp=              SMBR_Hmumu(Mhi)     ; call flush(6)
 write(*,fmt=f_out)'  SMBR_Hmumu    = ' , SMtemp

 write(*,*)'the total SM decay width (in Gev) is'
 SMtemp=              SMGamma_h(Mhi)    ; call flush(6)
 write(*,fmt=f_out)'  SMGamma_h     = ' , SMtemp ; call flush(6)

 write(*,*)'the SM top decay width (in Gev) into a W boson and b quark is'
 SMtemp=              SMGamma_tWpb(mt)    ; call flush(6)
 write(*,fmt=f_out)'  SMGamma_tWpb     = ' , SMtemp ; call flush(6)
 write(*,*)'     for a top mass of ',mt

 write(*,*)'the SM Tevatron hadronic cross sections (in pb) are'

 SMtemp=              SMCS_tev_HW(Mhi)    ; call flush(6)
 write(*,fmt=f_out)'  SMCS_tev_HW        = ' , SMtemp
 SMtemp=              SMCS_tev_HZ(Mhi)    ; call flush(6)
 write(*,fmt=f_out)'  SMCS_tev_HZ        = ' , SMtemp
 SMtemp=              SMCS_tev_gg_H(Mhi)    ; call flush(6)
 write(*,fmt=f_out)'  SMCS_tev_gg_H      = ' , SMtemp
 SMtemp=              SMCS_tev_bb_H(Mhi)    ; call flush(6)
 write(*,fmt=f_out)'  SMCS_tev_bb_H      = ' , SMtemp
 SMtemp=              SMCS_tev_vbf_H(Mhi)    ; call flush(6)
 write(*,fmt=f_out)'  SMCS_tev_vbf_H     = ' , SMtemp
 SMtemp=              SMCS_tev_bg_Hb(Mhi)    ; call flush(6)
 write(*,fmt=f_out)'  SMCS_tev_bg_Hb     = ' , SMtemp
 SMtemp=              SMCS_tev_ttH(Mhi)      ; call flush(6)
 write(*,fmt=f_out)'  SMCS_tev_ttH       = ' , SMtemp

 write(*,*)'the SM LHC hadronic cross sections (in pb) at 7TeV are'

 SMtemp=              SMCS_lhc7_HW(Mhi)    ; call flush(6)
 write(*,fmt=f_out)'  SMCS_lhc7_HW       = ' , SMtemp
 SMtemp=              SMCS_lhc7_HZ(Mhi)    ; call flush(6)
 write(*,fmt=f_out)'  SMCS_lhc7_HZ       = ' , SMtemp
 SMtemp=              SMCS_lhc7_gg_H(Mhi)    ; call flush(6)
 write(*,fmt=f_out)'  SMCS_lhc7_gg_H     = ' , SMtemp
 !SMtemp=              SMCS_lhc7_bb_H(Mhi)    ; call flush(6)
 !write(*,fmt=f_out)'  SMCS_lhc7_bb_H     = ' , SMtemp
 SMtemp=              SMCS_lhc7_vbf_H(Mhi)    ; call flush(6)
 write(*,fmt=f_out)'  SMCS_lhc7_vbf_H    = ' , SMtemp
 !SMtemp=              SMCS_lhc7_bg_Hb(Mhi)    ; call flush(6)
 !write(*,fmt=f_out)'  SMCS_lhc7_bg_Hb    = ' , SMtemp
 SMtemp=              SMCS_lhc7_ttH(Mhi)      ; call flush(6)
 write(*,fmt=f_out)'  SMCS_lhc7_ttH      = ' , SMtemp

 write(*,*)'the SM LHC hadronic cross sections (in pb) at 8TeV are'

 SMtemp=              SMCS_lhc8_HW(Mhi)    ; call flush(6)
 write(*,fmt=f_out)'  SMCS_lhc8_HW       = ' , SMtemp
 SMtemp=              SMCS_lhc8_HZ(Mhi)    ; call flush(6)
 write(*,fmt=f_out)'  SMCS_lhc8_HZ       = ' , SMtemp
 SMtemp=              SMCS_lhc8_gg_H(Mhi)    ; call flush(6)
 write(*,fmt=f_out)'  SMCS_lhc8_gg_H     = ' , SMtemp
 !SMtemp=              SMCS_lhc7_bb_H(Mhi)    ; call flush(6)
 !write(*,fmt=f_out)'  SMCS_lhc7_bb_H     = ' , SMtemp
 SMtemp=              SMCS_lhc8_vbf_H(Mhi)    ; call flush(6)
 write(*,fmt=f_out)'  SMCS_lhc8_vbf_H    = ' , SMtemp
 !SMtemp=              SMCS_lhc7_bg_Hb(Mhi)    ; call flush(6)
 !write(*,fmt=f_out)'  SMCS_lhc7_bg_Hb    = ' , SMtemp
 SMtemp=              SMCS_lhc8_ttH(Mhi)      ; call flush(6)
 write(*,fmt=f_out)'  SMCS_lhc8_ttH      = ' , SMtemp

 !write(*,*)
 !write(*,*)'These results were obtained from'
 !write(*,*)'the program HDECAY (arXiv:hep-ph/9704448)'
 !write(*,*)'and cross sections collated by the'
 !write(*,*)'and the TeV4LHC Higgs Working Group(arXiv:hep-ph/0612172)'
 write(*,*)
 write(*,*)'See HiggsBounds manual for definitions and references.'
 write(*,*)
 write(*,*)'Note that, for the majority of SM quantities used internally by HiggsBounds,'
 write(*,*)'we make use of existing calculations, including the program HDECAY (arXiv:hep-ph/9704448),'
 write(*,*)'those collated by the TeV4LHC Higgs Working Group (arXiv:hep-ph/0612172)'
 write(*,*)'and those collated by the LHC Higgs Cross Section Working Group (arXiv:1101.0593).'
 write(*,*)
 write(*,*)'For a full list of the appropriate references in .bib and .bbl format, see'
 write(*,*)'http://projects.hepforge.org/higgsbounds/downloads.html'

 call finish_HiggsBounds

end program extract_SM_results_for_web


      SUBROUTINE BB03AD(DEF, NR, DPAR, IPAR, VEC, N, M, E, LDE, A, LDA,
     1                  Y, LDY, B, LDB, X, LDX, U, LDU, NOTE, DWORK,
     2                  LDWORK, INFO)
C
C     SLICOT RELEASE 5.5.
C
C     Copyright (c) 2002-2012 NICONET e.V.
C
C     PURPOSE
C
C     To generate benchmark examples of (generalized) continuous-time
C     Lyapunov equations
C
C        T           T
C       A  X  E  +  E  X A  =  Y .
C
C     In some examples, the right hand side has the form
C
C                T
C       Y  =  - B  B
C
C     and the solution can be represented as a product of Cholesky
C     factors
C
C              T
C       X  =  U  U .
C
C     E, A, Y, X, and U are real N-by-N matrices, and B is M-by-N. Note
C     that E can be the identity matrix. For some examples, B, X, or U
C     are not provided.
C
C     This routine is an implementation of the benchmark library
C     CTLEX (Version 1.0) described in [1].
C
C     ARGUMENTS
C
C     Mode Parameters
C
C     DEF     CHARACTER*1
C             Specifies the kind of values used as parameters when
C             generating parameter-dependent and scalable examples
C             (i.e., examples with NR(1) = 2, 3, or 4):
C             DEF = 'D' or 'd': Default values are used.
C             DEF = 'N' or 'n': Values set in DPAR and IPAR are used.
C             This parameter is not referenced if NR(1) = 1.
C             Note that the scaling parameter of examples with
C             NR(1) = 3 or 4 is considered as a regular parameter in
C             this context.
C
C     Input/Output Parameters
C
C     NR      (input) INTEGER array, dimension 2
C             Specifies the index of the desired example according
C             to [1].
C             NR(1) defines the group:
C                   1 : parameter-free problems of fixed size
C                   2 : parameter-dependent problems of fixed size
C                   3 : parameter-free problems of scalable size
C                   4 : parameter-dependent problems of scalable size
C             NR(2) defines the number of the benchmark example
C             within a certain group according to [1].
C
C     DPAR    (input/output) DOUBLE PRECISION array, dimension 2
C             On entry, if DEF = 'N' or 'n' and the desired example
C             depends on real parameters, then the array DPAR must
C             contain the values for these parameters.
C             For an explanation of the parameters see [1].
C             For Example 4.1, DPAR(1) and DPAR(2) define 'r' and 's',
C             respectively.
C             For Example 4.2, DPAR(1) and DPAR(2) define 'lambda' and
C             's', respectively.
C             For Examples 4.3 and 4.4, DPAR(1) defines the parameter
C             't'.
C             On exit, if DEF = 'D' or 'd' and the desired example
C             depends on real parameters, then the array DPAR is
C             overwritten by the default values given in [1].
C
C     IPAR    (input/output) INTEGER array of DIMENSION at least 1
C             On entry, if DEF = 'N' or 'n' and the desired example
C             depends on integer parameters, then the array IPAR must
C             contain the values for these parameters.
C             For an explanation of the parameters see [1].
C             For Examples 4.1, 4.2, and 4.3, IPAR(1) defines 'n'.
C             For Example 4.4, IPAR(1) defines 'q'.
C             On exit, if DEF = 'D' or 'd' and the desired example
C             depends on integer parameters, then the array IPAR is
C             overwritten by the default values given in [1].
C
C     VEC     (output) LOGICAL array, dimension 8
C             Flag vector which displays the availability of the output
C             data:
C             VEC(1) and VEC(2) refer to N and M, respectively, and are
C             always .TRUE.
C             VEC(3) is .TRUE. iff E is NOT the identity matrix.
C             VEC(4) and VEC(5) refer to A and Y, respectively, and are
C             always .TRUE.
C             VEC(6) is .TRUE. iff B is provided.
C             VEC(7) is .TRUE. iff the solution matrix X is provided.
C             VEC(8) is .TRUE. iff the Cholesky factor U is provided.
C
C     N       (output) INTEGER
C             The actual state dimension, i.e., the order of the
C             matrices E and A.
C
C     M       (output) INTEGER
C             The number of rows in the matrix B. If B is not provided
C             for the desired example, M = 0 is returned.
C
C     E       (output) DOUBLE PRECISION array, dimension (LDE,N)
C             The leading N-by-N part of this array contains the
C             matrix E.
C             NOTE that this array is overwritten (by the identity
C             matrix), if VEC(3) = .FALSE.
C
C     LDE     INTEGER
C             The leading dimension of array E.  LDE >= N.
C
C     A       (output) DOUBLE PRECISION array, dimension (LDA,N)
C             The leading N-by-N part of this array contains the
C             matrix A.
C
C     LDA     INTEGER
C             The leading dimension of array A.  LDA >= N.
C
C     Y       (output) DOUBLE PRECISION array, dimension (LDY,N)
C             The leading N-by-N part of this array contains the
C             matrix Y.
C
C     LDY     INTEGER
C             The leading dimension of array Y.  LDY >= N.
C
C     B       (output) DOUBLE PRECISION array, dimension (LDB,N)
C             The leading M-by-N part of this array contains the
C             matrix B.
C
C     LDB     INTEGER
C             The leading dimension of array B.  LDB >= M.
C
C     X       (output) DOUBLE PRECISION array, dimension (LDX,N)
C             The leading N-by-N part of this array contains the
C             matrix X.
C
C     LDX     INTEGER
C             The leading dimension of array X.  LDX >= N.
C
C     U       (output) DOUBLE PRECISION array, dimension (LDU,N)
C             The leading N-by-N part of this array contains the
C             matrix U.
C
C     LDU     INTEGER
C             The leading dimension of array U.  LDU >= N.
C
C     NOTE    (output) CHARACTER*70
C             String containing short information about the chosen
C             example.
C
C     Workspace
C
C     DWORK   DOUBLE PRECISION array, dimension (LDWORK)
C
C     LDWORK  INTEGER
C             The length of the array DWORK.
C             For Examples 4.1 and 4.2., LDWORK >= 2*IPAR(1) is
C             required.
C             For the other examples, no workspace is needed, i.e.,
C             LDWORK >= 1.
C
C     Error Indicator
C
C     INFO    INTEGER
C             = 0:  successful exit;
C             < 0:  if INFO = -i, the i-th argument had an illegal
C                   value; in particular, INFO = -3 or -4 indicates
C                   that at least one of the parameters in DPAR or
C                   IPAR, respectively, has an illegal value.
C
C     REFERENCES
C
C     [1]  D. Kressner, V. Mehrmann, and T. Penzl.
C          CTLEX - a Collection of Benchmark Examples for Continuous-
C          Time Lyapunov Equations.
C          SLICOT Working Note 1999-6, 1999.
C
C     NUMERICAL ASPECTS
C
C     None
C
C     CONTRIBUTOR
C
C     D. Kressner, V. Mehrmann, and T. Penzl (TU Chemnitz)
C
C     For questions concerning the collection or for the submission of
C     test examples, please contact Volker Mehrmann
C     (Email: volker.mehrmann@mathematik.tu-chemnitz.de).
C
C     REVISIONS
C
C     June 1999, V. Sima.
C
C     KEYWORDS
C
C     continuous-time Lyapunov equations
C
C     ********************************************************************
C
C     .. Parameters ..
      DOUBLE PRECISION  ZERO, ONE, TWO, FOUR
      PARAMETER         (ZERO = .0D0, ONE = .1D1, TWO = .2D1,
     1                   FOUR = .4D1)
C     .. Scalar Arguments ..
      CHARACTER         DEF
      CHARACTER*70      NOTE
      INTEGER           INFO, LDA, LDB, LDE, LDU, LDWORK, LDX, LDY, M, N
C     .. Array Arguments ..
      LOGICAL           VEC(8)
      INTEGER           IPAR(*), NR(*)
      DOUBLE PRECISION  A(LDA,*), B(LDB,*), DPAR(*), DWORK(LDWORK),
     1                  E(LDE,*), U(LDU,*), X(LDX,*), Y(LDY,*)
C     .. Local Scalars ..
      INTEGER           I, J, K
      DOUBLE PRECISION  TEMP, TTM1, TTP1, TWOBYN
C     .. Local Arrays ..
      LOGICAL           VECDEF(8)
C     .. External Functions ..
C     . BLAS .
      DOUBLE PRECISION  DDOT
      EXTERNAL          DDOT
C     . LAPACK .
      LOGICAL           LSAME
      EXTERNAL          LSAME
C     .. External Subroutines ..
C     . BLAS .
      EXTERNAL          DGEMV, DGER, DAXPY
C     . LAPACK .
      EXTERNAL          DLASET
C     .. Intrinsic Functions ..
      INTRINSIC         DBLE, MIN, MOD
C     .. Data Statements ..
C     . default values for availabilities .
      DATA VECDEF /.TRUE., .TRUE., .FALSE., .TRUE.,
     1             .TRUE., .FALSE., .FALSE., .FALSE./
C
C     .. Executable Statements ..
C
      INFO = 0
      DO 10  I = 1, 8
        VEC(I) = VECDEF(I)
  10  CONTINUE
C
      IF (NR(1) .EQ. 4) THEN
        IF (.NOT. (LSAME(DEF,'D') .OR. LSAME(DEF,'N'))) THEN
          INFO = -1
          RETURN
        END IF
C
        IF (NR(2) .EQ. 1) THEN
          NOTE = 'CTLEX: Example 4.1'
          IF (LSAME(DEF,'D')) THEN
            IPAR(1) = 10
            DPAR(1) = .15D1
            DPAR(2) = .15D1
          END IF
          IF ((DPAR(1) .LE. ONE) .OR. (DPAR(2) .LE. ONE)) INFO = -3
          IF (IPAR(1) .LT. 2) INFO = -4
          N = IPAR(1)
          M = 1
          IF (LDE .LT. N) INFO = -9
          IF (LDA .LT. N) INFO = -11
          IF (LDY .LT. N) INFO = -13
          IF (LDB .LT. M) INFO = -15
          IF (LDX .LT. N) INFO = -17
          IF (LDWORK .LT. N*2) INFO = -22
          IF (INFO .NE. 0) RETURN
C
          VEC(6) = .TRUE.
          VEC(7) = .TRUE.
          TWOBYN = TWO / DBLE( N )
          CALL DLASET('A', N, N, ZERO, ONE, E, LDE)
          CALL DLASET('A', N, N, ZERO, ZERO, A, LDA)
          CALL DLASET('A', N, N, ZERO, ZERO, Y, LDY)
          CALL DLASET('A', M, N, ZERO, ZERO, B, LDB)
          CALL DLASET('A', N, N, ZERO, ZERO, X, LDX)
          DO 30  J = 1, N
            TEMP = DPAR(1) ** (J-1)
            A(J,J) = -TEMP
            DWORK(J) = ONE
            DO 20  I = 1, N
              X(I,J) = DBLE( I*J ) / (TEMP + DPAR(1)**(I-1))
  20        CONTINUE
  30      CONTINUE
C         H1 * A
          CALL DGEMV('T', N,N, ONE, A, LDA, DWORK,1, ZERO, DWORK(N+1),1)
          CALL DGER(N, N, -TWOBYN, DWORK, 1, DWORK(N+1), 1, A, LDA)
C         A * H1
          CALL DGEMV('N', N,N, ONE, A, LDA, DWORK,1, ZERO, DWORK(N+1),1)
          CALL DGER(N, N, -TWOBYN, DWORK(N+1), 1, DWORK, 1, A, LDA)
C         H1 * X
          CALL DGEMV('T', N,N, ONE, X, LDX, DWORK,1, ZERO, DWORK(N+1),1)
          CALL DGER(N, N, -TWOBYN, DWORK, 1, DWORK(N+1), 1, X, LDX)
C         X * H1
          CALL DGEMV('N', N,N, ONE, X, LDX, DWORK,1, ZERO, DWORK(N+1),1)
          CALL DGER(N, N, -TWOBYN, DWORK(N+1), 1, DWORK, 1, X, LDX)
C         S A INV(S), INV(S) X INV(S), B INV(S)
          DO 50  J = 1, N
            B(1,J) = DBLE( J-N-1 ) / (DPAR(2)**(J-1))
            DO 40  I = 1, N
              X(I,J) = X(I,J) / (DPAR(2)**(I+J-2))
              A(I,J) = A(I,J) * (DPAR(2)**(I-J))
  40        CONTINUE
            DWORK(J) = ONE - TWO * MOD(J,2)
  50      CONTINUE
C         H2 * A
          CALL DGEMV('T', N,N, ONE, A, LDA, DWORK,1, ZERO, DWORK(N+1),1)
          CALL DGER(N, N, -TWOBYN, DWORK, 1, DWORK(N+1), 1, A, LDA)
C         A * H2
          CALL DGEMV('N', N,N, ONE, A, LDA, DWORK,1, ZERO, DWORK(N+1),1)
          CALL DGER(N, N, -TWOBYN, DWORK(N+1), 1, DWORK, 1, A, LDA)
C         H2 * X
          CALL DGEMV('T', N,N, ONE, X, LDX, DWORK,1, ZERO, DWORK(N+1),1)
          CALL DGER(N, N, -TWOBYN, DWORK, 1, DWORK(N+1), 1, X, LDX)
C         X * H2
          CALL DGEMV('N', N,N, ONE, X, LDX, DWORK,1, ZERO, DWORK(N+1),1)
          CALL DGER(N, N, -TWOBYN, DWORK(N+1), 1, DWORK, 1, X, LDX)
C         B * H2
          CALL DAXPY(N, -TWOBYN * DDOT(N, B, LDB, DWORK, 1), DWORK, 1,
     1               B, LDB)
C         Y = -B' * B
          CALL DGER(N ,N, -ONE, B, LDB, B, LDB, Y, LDY)
C
        ELSE IF (NR(2) .EQ. 2) THEN
          NOTE = 'CTLEX: Example 4.2'
          IF (LSAME(DEF,'D')) THEN
            IPAR(1) = 10
            DPAR(1) = -.5D0
            DPAR(2) = .15D1
          END IF
          IF ((DPAR(1) .GE. ZERO) .OR. (DPAR(2) .LE. ONE)) INFO = -3
          IF (IPAR(1) .LT. 2) INFO = -4
          N = IPAR(1)
          M = 1
          IF (LDE .LT. N) INFO = -9
          IF (LDA .LT. N) INFO = -11
          IF (LDY .LT. N) INFO = -13
          IF (LDB .LT. M) INFO = -15
          IF (LDWORK .LT. N*2) INFO = -22
          IF (INFO .NE. 0) RETURN
C
          VEC(6) = .TRUE.
          TWOBYN = TWO / DBLE( N )
          CALL DLASET('A', N, N, ZERO, ONE, E, LDE)
          CALL DLASET('A', N, N, ZERO, DPAR(1), A, LDA)
          CALL DLASET('A', N, N, ZERO, ZERO, Y, LDY)
          CALL DLASET('A', M, N, -TWOBYN, ONE - TWOBYN, B, LDB)
          DO 60  I = 1, N-1
            DWORK(I) = ONE
            A(I,I+1) = ONE
  60      CONTINUE
          DWORK(N) = ONE
C         H1 * A
          CALL DGEMV('T', N,N, ONE, A, LDA, DWORK,1, ZERO, DWORK(N+1),1)
          CALL DGER(N, N, -TWOBYN, DWORK, 1, DWORK(N+1), 1, A, LDA)
C         A * H1
          CALL DGEMV('N', N,N, ONE, A, LDA, DWORK,1, ZERO, DWORK(N+1),1)
          CALL DGER(N, N, -TWOBYN, DWORK(N+1), 1, DWORK, 1, A, LDA)
C         S A INV(S), B INV(S)
          DO 80  J = 1, N
            B(1,J) = B(1,J) / (DPAR(2)**(J-1))
            DO 70  I = 1, N
              A(I,J) = A(I,J) * (DPAR(2)**(I-J))
  70        CONTINUE
            DWORK(J) = ONE - TWO * MOD(J,2)
  80      CONTINUE
C         H2 * A
          CALL DGEMV('T', N,N, ONE, A, LDA, DWORK,1, ZERO, DWORK(N+1),1)
          CALL DGER(N, N, -TWOBYN, DWORK, 1, DWORK(N+1), 1, A, LDA)
C         A * H2
          CALL DGEMV('N', N,N, ONE, A, LDA, DWORK,1, ZERO, DWORK(N+1),1)
          CALL DGER(N, N, -TWOBYN, DWORK(N+1), 1, DWORK, 1, A, LDA)
C         B * H2
          CALL DAXPY(N, -TWOBYN * DDOT(N, B, LDB, DWORK, 1), DWORK, 1,
     1               B, LDB)
C         Y = -B' * B
          CALL DGER(N ,N, -ONE, B, LDB, B, LDB, Y, LDY)
C
        ELSE IF (NR(2) .EQ. 3) THEN
          NOTE = 'CTLEX: Example 4.3'
          IF (LSAME(DEF,'D')) THEN
            IPAR(1) = 10
            DPAR(1) = .1D2
          END IF
          IF (DPAR(1) .LT. ZERO) INFO = -3
          IF (IPAR(1) .LT. 2) INFO = -4
          N = IPAR(1)
          M = 0
          IF (LDE .LT. N) INFO = -9
          IF (LDA .LT. N) INFO = -11
          IF (LDY .LT. N) INFO = -13
          IF (LDX .LT. N) INFO = -17
          IF (INFO .NE. 0) RETURN
C
          VEC(3) = .TRUE.
          VEC(7) = .TRUE.
          TEMP = TWO ** (-DPAR(1))
          CALL DLASET('U', N, N, ZERO, ZERO, E, LDE)
          CALL DLASET('L', N, N, TEMP, ONE, E, LDE)
          CALL DLASET('L', N, N, ZERO, ZERO, A, LDA)
          CALL DLASET('U', N, N, ONE, ZERO, A, LDA)
          CALL DLASET('A', N, N, ONE, ONE, X, LDX)
          DO 90  I = 1, N
            A(I,I) = DBLE( I - 1 ) + TEMP
  90      CONTINUE
          Y(1,1) = TWO * TEMP + TWO * DBLE( N-1 ) * TEMP**2
          TTP1 = TWO * DBLE( N+1 ) * TEMP + TWO - TEMP**2
          TTM1 = TWO * DBLE( N-1 ) * TEMP + TWO - TEMP**2
          DO 100  I = 2, N
            Y(I,1) = Y(1,1) + DBLE( I-1 ) * TTM1
 100      CONTINUE
          DO 120  J = 2, N
            DO 110  I = 1, N
              Y(I,J) = Y(I,1) + DBLE( J-1 ) * (TTP1 - FOUR * I * TEMP)
 110        CONTINUE
 120     CONTINUE
C
        ELSE IF (NR(2) .EQ. 4) THEN
          NOTE = 'CTLEX: Example 4.4'
          IF (LSAME(DEF,'D')) THEN
            IPAR(1) = 10
            DPAR(1) = .15D1
          END IF
          IF (DPAR(1) .LT. ONE) INFO = -3
          IF (IPAR(1) .LT. 1) INFO = -4
          N = IPAR(1) * 3
          M = 1
          IF (LDE .LT. N) INFO = -9
          IF (LDA .LT. N) INFO = -11
          IF (LDY .LT. N) INFO = -13
          IF (LDB .LT. M) INFO = -15
          IF (INFO .NE. 0) RETURN
C
          VEC(3) = .TRUE.
          VEC(6) = .TRUE.
          CALL DLASET('A', N, N, ZERO, ZERO, E, LDE)
          CALL DLASET('A', N, N, ZERO, ZERO, A, LDA)
          DO 150  I = 1, IPAR(1)
            TEMP  = -DPAR(1)**I
            DO 140  J = 1, I - 1
              DO 130  K = 0, 2
                A(N - I*3+3, J*3-K) = TEMP
                A(N - I*3+2, J*3-K) = TWO * TEMP
 130          CONTINUE
 140        CONTINUE
            A(N - I*3+3, I*3-2) = TEMP
            A(N - I*3+2, I*3-2) = TWO * TEMP
            A(N - I*3+2, I*3-1) = TWO * TEMP
            A(N - I*3+2, I*3  ) = TEMP
            A(N - I*3+1, I*3  ) = TEMP
 150      CONTINUE
          DO 170  J = 1, N
            IF (J .GT. 1) CALL DAXPY(N, ONE, A(J-1,1), LDA, A(J,1), LDA)
            B(1, J) = DBLE( J )
            DO 160  I = 1, N
              E(I,N-J+1) = DBLE( MIN( I, J ) )
              Y(I,J) = -DBLE( I*J )
 160        CONTINUE
 170      CONTINUE
C
        ELSE
          INFO = -2
        END IF
      ELSE
        INFO = -2
      END IF
C
      RETURN
C *** Last Line of BB03AD ***
      END


subroutine solve_laplace_pa(source,nsd,nn,nn_solid,ien,ne,nen,x_fluid,node_sbc,nn_sbc,I_fluid,flag_fnode,&
		ne_local,ien_local,nn_local,node_local,send_address,ad_length,&
		global_com,nn_global_com,local_com,nn_local_com)
! 1 decide interior, outer, boundary fluid nodes
! 2 set id matrix for laplace equation
! 3 sovle for laplace equation
use delta_nonuniform, only: cnn, ncnn
use mpi_variables
implicit none
include 'mpif.h'
real(8) source(nsd,nn)
integer nsd
integer nn
integer nn_solid
integer ien(nen,ne)
integer ne
integer nen
integer node_sbc(nn_sbc)
integer nn_sbc
real(8) x_fluid(nsd,nn)
real(8) I_fluid(nn)
integer flag_fnode(nn)
!----------------------
integer flag_node(nn)
integer flag_el(ne)
integer i
integer j
integer inn
integer count_el
integer node
real(8) dg(nn)
integer lp_id(nn)
real(8) p_inter(nn)
real(8) w_inter(nn)
integer icount
real(8) time
!--------------------
integer ne_local
integer ien_local(ne_local)
integer nn_local
integer node_local(nn_local)
integer ad_length
integer send_address(ad_length,2)
integer nn_global_com
integer global_com(nn_global_com)  ! global node index for communication
integer nn_local_com
integer local_com(nn_local_com)  ! local index in the communication region on each processor

flag_node(:)=0 ! set out node
flag_el(:)=0
p_inter(:)=0.0
w_inter(:)=0.0
dg(:)=0.0

lp_id(:)=0
I_fluid(:)=0.0

do i=1,nn_solid
	do j=1,ncnn(i)
		node=cnn(j,i)
		flag_node(node)=1 ! set interior node
		I_fluid(node)=1.0
	end do
end do

do i=1,nn_sbc
	inn=node_sbc(i)
	do j=1,ncnn(inn)
		node=cnn(j,inn)
		flag_node(node)=2 ! set boundary node
		I_fluid(node)=0.0
		lp_id(node) = 1 ! set id vector for laplace eq
	end do
end do
!------------------------
! reset inside boundary based on fnode
do i=1,nn
        if (flag_fnode(i) == 1) then
                I_fluid(i)=1.0
!                flag_node(i)=1
		lp_id(i) = 0
        end if
end do

time = mpi_wtime()
call block_Laplace(x_fluid,I_fluid,p_inter,w_inter,ien,ien_local,ne_local,source)

! commute residual for each processor
call communicate_res_ad_sub(p_inter,1,nn,send_address,ad_length)
call communicate_res_ad_sub(w_inter,1,nn,send_address,ad_length)

call setid_pa(p_inter,1,nn,lp_id,node_local,nn_local)
time = mpi_wtime() - time
if (myid == 0) write(*,*) 'Laplace block time', time

call gmres_Laplace_pa(x_fluid,I_fluid,w_inter,p_inter,dg,ien,lp_id,&
	ne_local,ien_local,nn_local,node_local,send_address,ad_length,&
	global_com,nn_global_com,local_com,nn_local_com)

!do i=1,nn

if (myid == 0)	write(*,*) 'dg', maxval(dg(:)), minval(dg(:))
!end do

dg(:) = abs(dg(:)) / maxval(dg(:))

    I_fluid(:)=dg(:)+I_fluid(:)

return

end


!***********************************/
!	Name:Sutherland's lawに基づき粘度を求めるプログラム
!	Alias:UGetLaminarViscosity_mk2
!	Description:
!	Type:
!	Input:
!	Output:
!	Note:
!	Author:Akitaka Toyota
!	Date:2018.11.13
!	Update:-
!	Other:
!***********************************/
subroutine UGetLaminarViscosity_mk2(UConf, UG, UCC, UCE)
    use StructVar_Mod
    use LoopVar_Mod
    use FrequentOperation
    use ConstantVar_Mod, gamma => SpecificOfHeatRatio
    implicit none
    type(Configulation), intent(in) :: UConf
    type(UnstructuredGrid), intent(in) :: UG
    type(CellCenter), intent(inout) :: UCC
    type(CellEdge), intent(inout) :: UCE
    double precision :: Mu0, SC1, Mach2, Tinflow
    double precision :: EdgeTemparature
    double precision :: FrontLength, BackLength
    logical :: debug = .true.

    Mach2 = MachNumber ** 2
    if(UConf%UseSutherlandLaw == 0) then
        UCE%LaminarViscosity = 1.0d0
        if(debug == .true.) then
            do iCell = 1, UG%GI%RealCells
                UCC%LaminarViscosity(iCell,1,1) = (UCE%LaminarViscosity(UG%Tri%Edge(iCell,1),1,1)+UCE%LaminarViscosity(UG%Tri%Edge(iCell,2),1,1)+UCE%LaminarViscosity(UG%Tri%Edge(iCell,3),1,1)) / 3.0
                UCC%EddyViscosity(iCell,1,1) = (UCE%EddyViscosity(UG%Tri%Edge(iCell,1),1,1)+UCE%EddyViscosity(UG%Tri%Edge(iCell,2),1,1)+UCE%EddyViscosity(UG%Tri%Edge(iCell,3),1,1)) / 3.0
            end do
        end if

    else
        Mu0 = 1.0d0
        Tinflow = gamma * UG%GM%BC%InFlowVariable(5) / UG%GM%BC%InFlowVariable(1)
        SC1 = SutherlandTemperature_S / ReferenceTemperature_Tref

        !　セル中心で温度・粘性・速度ノルム求める
        do iCell = 1, UG%GI%AllCells
            UCC%Temparature(iCell, 1, 1) = gamma * UCC%PrimitiveVariable(5, iCell, 1, 1) / UCC%PrimitiveVariable(1, iCell, 1, 1) * Gmin1
            UCC%LaminarViscosity(iCell,1,1) = SutherlandViscosity(UCC%Temparature(iCell,1,1), Tinflow)
        end do

        do iEdge = 1, UG%GI%Edges
            iBackCell = UG%Line%Cell(iEdge,2,1)
            if(iBackCell > UG%GI%RealCells) then
                UCE%LaminarViscosity(iEdge,1,1) = 0.5d0 * (UCC%LaminarViscosity(iFrontCell,1,1) + UCC%LaminarViscosity(iBackCell,1,1))
            else
                call GetLengthBetweenEdge(UG,iEdge,iFrontCell,iBackCell,FrontLength,BackLength)
                UCE%LaminarViscosity(iEdge,1,1) = (FrontLength * UCC%LaminarViscosity(iFrontCell,1,1) &
                                             &  +  BackLength * UCC%LaminarViscosity(iBackCell,1,1))  &
                                             &  / (FrontLength + BackLength)

            end if
        end do
    end if

    return
end subroutine UGetLaminarViscosity_mk2


C     ******************************************************************
C     ******************************************************************

      subroutine dogleg(n,g,hnnz,hlin,hcol,hval,l,pd,delta,p,dlinfo)

      implicit none

C     SCALAR ARGUMENTS
      logical pd
      integer dlinfo,hnnz,n
      double precision delta,l

C     ARRAY ARGUMENTS
      integer hcol(hnnz),hlin(hnnz)
      double precision g(n),hval(hnnz),p(n)

C     Compute approximate minimizer of the quadratic model using Dogleg
C     method when the Hessian is positive definite and Cauchy point
C     otherwise.

C     dlinfo:
C
C     0: successfull exit. Both H and g are null;
C     1: successfull exit.

      include "dim.par"
      include "machconst.inc"
      include "outtyp.inc"

C     LOCAL SCALARS
      integer col,i,lin
      double precision a,b,c,d,delta2,geucn,geucn2,gthg,pbeucn2,
     +        pueucn,pueucn2,putpb,r

C     LOCAL ARRAYS
      double precision pu(nmax)
C     Presentation

      if ( iprintinn .ge. 5 ) then
C          write(* ,1000)
          write(10,1000)
      end if

C     Initialization

      dlinfo = 1
      delta2 = delta**2

C     If H is not positive definite, compute Cauchy point

      if ( .not. pd ) then
          go to 100
      end if

      pbeucn2 = 0.0d0
      do i = 1,n
          pbeucn2 = pbeucn2 + p(i)**2
      end do

C     If Newton step is inside the trust region, this step is taken

      if ( pbeucn2 .le. delta2 ) then
          go to 500
      end if

C     If Newton step is outside the trust region, compute the
C     unconstrained minimizer pu of the quadratic function

C     Compute g^T H g

      do i = 1,n
          pu(i) = 0.0d0
      end do

      do i = 1,hnnz
          lin = hlin(i)
          col = hcol(i)

c         pu(lin) = pu(lin) + hval(i) * g(col)
c         if ( lin .ne. col ) then
c             pu(col) = pu(col) + hval(i) * g(lin)
c         end if

          if ( lin .eq. col ) then
              pu(lin) = pu(lin) + ( hval(i) + l ) * g(col)
          else
              pu(lin) = pu(lin) + hval(i) * g(col)
              pu(col) = pu(col) + hval(i) * g(lin)
          end if
      end do

      gthg = 0.0d0
      do i = 1,n
          gthg = gthg + g(i) * pu(i)
      end do

C     Compute g^T g.

      geucn2 = 0.0d0
      do i = 1,n
          geucn2 = geucn2 + g(i)**2
      end do

C     Compute pu

      do i = 1,n
          pu(i) = - geucn2 * g(i) / gthg
      end do

C     If uncontrained minimizer is outside the trust region, it is
C     truncated at the border

      pueucn2 = 0.0d0
      do i = 1,n
          pueucn2 = pueucn2 + pu(i)**2
      end do
      pueucn = sqrt( pueucn2 )

      if ( pueucn2 .ge. delta2 ) then
          r = delta / pueucn
          do i = 1,n
              p(i) = r * pu(i)
          end do
          go to 500
      end if

C     Compute step length in directions pu and pb. Direction p is a
C     linear combination of pu and pb. To compute the step length in
C     each direction, we have to solve (in r):
C     \| pu + (r - 1) (pb - pu) \|^2 = delta^2.

      putpb = 0.0d0
      do i = 1,n
          putpb = putpb + pu(i) * p(i)
      end do

      a = pbeucn2 + pueucn2 - 2.0d0 * putpb
      b = - 2.0d0 * pbeucn2 - 4.0d0 * pueucn2 + 6.0d0 * putpb
      c = pbeucn2 + 4.0d0 * pueucn2 - 4.0d0 * putpb - (delta**2)
      d = b**2 - 4.0d0 * a * c

      if ( ( 2.0d0 * abs( a ) .lt. macheps23 ) .or.
     +     ( d .lt. 0.0d0 ) ) then
          go to 200
      end if

      r = (- b + sqrt( d )) / (2.0d0 * a)

      if ( ( r .lt. 1.0d0 ) .or. ( r .gt. 2.0d0 ) ) then
          r = (- b - sqrt( d )) / (2.0d0 * a)
      end if
      r = r - 1.0d0

      do i = 1,n
          p(i) = r * p(i) + (1.0d0 - r) * pu(i)
      end do

      go to 500

C     Compute Cauchy point, when H is not positive definite

 100  continue

C     Compute g^T H g

      do i = 1,n
          pu(i) = 0.0d0
      end do

      do i = 1,hnnz
          lin = hlin(i)
          col = hcol(i)

c         pu(lin) = pu(lin) + hval(i) * g(col)
c         if ( lin .ne. col ) then
c             pu(col) = pu(col) + hval(i) * g(lin)
c         end if

          if ( lin .eq. col ) then
              pu(lin) = pu(lin) + ( hval(i) + l ) * g(col)
          else
              pu(lin) = pu(lin) + hval(i) * g(col)
              pu(col) = pu(col) + hval(i) * g(lin)
          end if
      end do

      gthg = 0.0d0
      do i = 1,n
          gthg = gthg + g(i) * pu(i)
      end do

C     Compute g^T g

      geucn2 = 0.0d0
      do i = 1,n
          geucn2 = geucn2 + g(i)**2
      end do
      geucn = sqrt( geucn2 )

C     Compute step length

 200  if ( abs( gthg ) .le. macheps23 .and. geucn .le. macheps23 ) then

          dlinfo = 0

          if ( iprintinn .ge. 5 ) then
C              write(* ,1020)
              write(10,1020)
          end if

          return
      end if

C     Compute p = coef * g

      if ( gthg .le. 0.0d0 .or. geucn2 * geucn .lt. delta * gthg ) then
          do i = 1,n
              p(i) = - delta * g(i) / geucn
          end do
      else
          do i = 1,n
              p(i) = - geucn2 * g(i) / gthg
          end do
      end if

C     Termination

 500  continue

      if ( iprintinn .ge. 5 ) then
C          write(* ,1010)
          write(10,1010)
      end if

      if ( iprintinn .ge. 5 .and. nprint .ne. 0 ) then
C          write(*, 1030) min0(n,nprint),(p(i),i=1,min0(n,nprint))
          write(10,1030) min0(n,nprint),(p(i),i=1,min0(n,nprint))
      end if

 1000 format(/,5X,'Computation of Dogleg direction.')
 1010 format(  5X,'Dogleg computed successfully.')
 1020 format(  5X,'Null direction was computed.')
 1030 format(/,5X,'Dogleg direction (first ',I7,' components): ',
     +       /,1(5X,6(1X,1P,D11.4)))

      end

C     ******************************************************************
C     ******************************************************************

C     Compute approximate minimizer of the quadratic model using Dogleg
C     method when the Hessian is positive definite and Cauchy point
C     otherwise.

C     On Entry
C
C     n        integer
C              dimension
C
C     g        double precision g(n)
C              vector used to define the quadratic function
C
C     hnnz     integer
C              number of nonzero elements of H
C
C     hlin     integer hlin(hnnz)
C              row indices of nonzero elements of H
C
C     hcol     integer hcol(hnnz)
C              column indices of nonzero elements of H
C
C     hval     double precision hval(hnnz)
C              nonzero elements of H, that is,
C              H(hlin(i),hcol(i)) = hval(i). Since H is symmetric, just
C              one element H(i,j) or H(j,i) must appear in its sparse
C              representation. If more than one pair corresponding to
C              the same position of H appears in the sparse
C              representation, the multiple entries will be summed.
C              If any hlin(i) or hcol(i) is out of range, the entry will
C              be ignored
C
C     pd       logical
C              indicates if the last Cholesky decomposition of moresor
C              was successfull. That is, if the last matrix used by
C              moresor was positive definite
C
C     delta    double precision
C              trust-region radius
C
C     On Return
C
C     p        double precision p(n)
C              solution to problem
C              minimize     psi(w)
C              subjected to ||w|| <= delta
C
C     dlinfo   integer
C              This output parameter tells what happened in this
C              subroutine, according to the following conventions:
C
C              0 = successfull exit. Both H and g are null;
C
C              1 = successfull exit.