*> \brief \b DTPQRT2 computes a QR factorization of a real or complex "triangular-pentagonal" matrix, which is composed of a triangular block and a pentagonal block, using the compact WY representation for Q.
*
*  =========== DOCUMENTATION ===========
*
* Online html documentation available at
*            http://www.netlib.org/lapack/explore-html/
*
*> \htmlonly
*> Download DTPQRT2 + dependencies
*>
*> [TGZ]
*>
*> [ZIP]
*>
*> [TXT]
*> \endhtmlonly
*
*  Definition:
*  ===========
*
*       SUBROUTINE DTPQRT2( M, N, L, A, LDA, B, LDB, T, LDT, INFO )
*
*       .. Scalar Arguments ..
*       INTEGER   INFO, LDA, LDB, LDT, N, M, L
*       ..
*       .. Array Arguments ..
*       DOUBLE PRECISION   A( LDA, * ), B( LDB, * ), T( LDT, * )
*       ..
*
*
*> \par Purpose:
*  =============
*>
*> \verbatim
*>
*> DTPQRT2 computes a QR factorization of a real "triangular-pentagonal"
*> matrix C, which is composed of a triangular block A and pentagonal block B,
*> using the compact WY representation for Q.
*> \endverbatim
*
*  Arguments:
*  ==========
*
*> \param[in] M
*> \verbatim
*>          M is INTEGER
*>          The total number of rows of the matrix B.
*>          M >= 0.
*> \endverbatim
*>
*> \param[in] N
*> \verbatim
*>          N is INTEGER
*>          The number of columns of the matrix B, and the order of
*>          the triangular matrix A.
*>          N >= 0.
*> \endverbatim
*>
*> \param[in] L
*> \verbatim
*>          L is INTEGER
*>          The number of rows of the upper trapezoidal part of B.
*>          MIN(M,N) >= L >= 0.  See Further Details.
*> \endverbatim
*>
*> \param[in,out] A
*> \verbatim
*>          A is DOUBLE PRECISION array, dimension (LDA,N)
*>          On entry, the upper triangular N-by-N matrix A.
*>          On exit, the elements on and above the diagonal of the array
*>          contain the upper triangular matrix R.
*> \endverbatim
*>
*> \param[in] LDA
*> \verbatim
*>          LDA is INTEGER
*>          The leading dimension of the array A.  LDA >= max(1,N).
*> \endverbatim
*>
*> \param[in,out] B
*> \verbatim
*>          B is DOUBLE PRECISION array, dimension (LDB,N)
*>          On entry, the pentagonal M-by-N matrix B.  The first M-L rows
*>          are rectangular, and the last L rows are upper trapezoidal.
*>          On exit, B contains the pentagonal matrix V.  See Further Details.
*> \endverbatim
*>
*> \param[in] LDB
*> \verbatim
*>          LDB is INTEGER
*>          The leading dimension of the array B.  LDB >= max(1,M).
*> \endverbatim
*>
*> \param[out] T
*> \verbatim
*>          T is DOUBLE PRECISION array, dimension (LDT,N)
*>          The N-by-N upper triangular factor T of the block reflector.
*>          See Further Details.
*> \endverbatim
*>
*> \param[in] LDT
*> \verbatim
*>          LDT is INTEGER
*>          The leading dimension of the array T.  LDT >= max(1,N)
*> \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.
*
*> \date September 2012
*
*> \ingroup doubleOTHERcomputational
*
*> \par Further Details:
*  =====================
*>
*> \verbatim
*>
*>  The input matrix C is a (N+M)-by-N matrix
*>
*>               C = [ A ]
*>                   [ B ]
*>
*>  where A is an upper triangular N-by-N matrix, and B is M-by-N pentagonal
*>  matrix consisting of a (M-L)-by-N rectangular matrix B1 on top of a L-by-N
*>  upper trapezoidal matrix B2:
*>
*>               B = [ B1 ]  <- (M-L)-by-N rectangular
*>                   [ B2 ]  <-     L-by-N upper trapezoidal.
*>
*>  The upper trapezoidal matrix B2 consists of the first L rows of a
*>  N-by-N upper triangular matrix, where 0 <= L <= MIN(M,N).  If L=0,
*>  B is rectangular M-by-N; if M=L=N, B is upper triangular.
*>
*>  The matrix W stores the elementary reflectors H(i) in the i-th column
*>  below the diagonal (of A) in the (N+M)-by-N input matrix C
*>
*>               C = [ A ]  <- upper triangular N-by-N
*>                   [ B ]  <- M-by-N pentagonal
*>
*>  so that W can be represented as
*>
*>               W = [ I ]  <- identity, N-by-N
*>                   [ V ]  <- M-by-N, same form as B.
*>
*>  Thus, all of information needed for W is contained on exit in B, which
*>  we call V above.  Note that V has the same form as B; that is,
*>
*>               V = [ V1 ] <- (M-L)-by-N rectangular
*>                   [ V2 ] <-     L-by-N upper trapezoidal.
*>
*>  The columns of V represent the vectors which define the H(i)'s.
*>  The (M+N)-by-(M+N) block reflector H is then given by
*>
*>               H = I - W * T * W**T
*>
*>  where W^H is the conjugate transpose of W and T is the upper triangular
*>  factor of the block reflector.
*> \endverbatim
*>
*  =====================================================================
      SUBROUTINE DTPQRT2( M, N, L, A, LDA, B, LDB, T, LDT, INFO )
*
*  -- LAPACK computational routine (version 3.4.2) --
*  -- LAPACK is a software package provided by Univ. of Tennessee,    --
*  -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
*     September 2012
*
*     .. Scalar Arguments ..
      INTEGER   INFO, LDA, LDB, LDT, N, M, L
*     ..
*     .. Array Arguments ..
      DOUBLE PRECISION   A( LDA, * ), B( LDB, * ), T( LDT, * )
*     ..
*
*  =====================================================================
*
*     .. Parameters ..
      DOUBLE PRECISION  ONE, ZERO
      PARAMETER( ONE = 1.0, ZERO = 0.0 )
*     ..
*     .. Local Scalars ..
      INTEGER   I, J, P, MP, NP
      DOUBLE PRECISION   ALPHA
*     ..
*     .. External Subroutines ..
      EXTERNAL  DLARFG, DGEMV, DGER, DTRMV, XERBLA
*     ..
*     .. Intrinsic Functions ..
      INTRINSIC MAX, MIN
*     ..
*     .. Executable Statements ..
*
*     Test the input arguments
*
      INFO = 0
      IF( M.LT.0 ) THEN
         INFO = -1
      ELSE IF( N.LT.0 ) THEN
         INFO = -2
      ELSE IF( L.LT.0 .OR. L.GT.MIN(M,N) ) THEN
         INFO = -3
      ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
         INFO = -5
      ELSE IF( LDB.LT.MAX( 1, M ) ) THEN
         INFO = -7
      ELSE IF( LDT.LT.MAX( 1, N ) ) THEN
         INFO = -9
      END IF
      IF( INFO.NE.0 ) THEN
         CALL XERBLA( 'DTPQRT2', -INFO )
         RETURN
      END IF
*
*     Quick return if possible
*
      IF( N.EQ.0 .OR. M.EQ.0 ) RETURN
*
      DO I = 1, N
*
*        Generate elementary reflector H(I) to annihilate B(:,I)
*
         P = M-L+MIN( L, I )
         CALL DLARFG( P+1, A( I, I ), B( 1, I ), 1, T( I, 1 ) )
         IF( I.LT.N ) THEN
*
*           W(1:N-I) := C(I:M,I+1:N)^H * C(I:M,I) [use W = T(:,N)]
*
            DO J = 1, N-I
               T( J, N ) = (A( I, I+J ))
            END DO
            CALL DGEMV( 'T', P, N-I, ONE, B( 1, I+1 ), LDB,
     $                  B( 1, I ), 1, ONE, T( 1, N ), 1 )
*
*           C(I:M,I+1:N) = C(I:m,I+1:N) + alpha*C(I:M,I)*W(1:N-1)^H
*
            ALPHA = -(T( I, 1 ))
            DO J = 1, N-I
               A( I, I+J ) = A( I, I+J ) + ALPHA*(T( J, N ))
            END DO
            CALL DGER( P, N-I, ALPHA, B( 1, I ), 1,
     $           T( 1, N ), 1, B( 1, I+1 ), LDB )
         END IF
      END DO
*
      DO I = 2, N
*
*        T(1:I-1,I) := C(I:M,1:I-1)^H * (alpha * C(I:M,I))
*
         ALPHA = -T( I, 1 )

         DO J = 1, I-1
            T( J, I ) = ZERO
         END DO
         P = MIN( I-1, L )
         MP = MIN( M-L+1, M )
         NP = MIN( P+1, N )
*
*        Triangular part of B2
*
         DO J = 1, P
            T( J, I ) = ALPHA*B( M-L+J, I )
         END DO
         CALL DTRMV( 'U', 'T', 'N', P, B( MP, 1 ), LDB,
     $               T( 1, I ), 1 )
*
*        Rectangular part of B2
*
         CALL DGEMV( 'T', L, I-1-P, ALPHA, B( MP, NP ), LDB,
     $               B( MP, I ), 1, ZERO, T( NP, I ), 1 )
*
*        B1
*
         CALL DGEMV( 'T', M-L, I-1, ALPHA, B, LDB, B( 1, I ), 1,
     $               ONE, T( 1, I ), 1 )
*
*        T(1:I-1,I) := T(1:I-1,1:I-1) * T(1:I-1,I)
*
         CALL DTRMV( 'U', 'N', 'N', I-1, T, LDT, T( 1, I ), 1 )
*
*        T(I,I) = tau(I)
*
         T( I, I ) = T( I, 1 )
         T( I, 1 ) = ZERO
      END DO

*
*     End of DTPQRT2
*
      END


!----------------------------------------------------------------------*
! SUBROUTINE SSKYC                                                     *
! Authors: Daniel van Kraalingen                                       *
! Date   : 2-Jun-1993, Version 1.0                                     *
! Purpose: This subroutine estimates solar inclination and fluxes of   *
!          diffuse and direct irradiation at a particular time of      *
!          the day.                                                    *
!                                                                      *
! FORMAL PARAMETERS:  (I=input,O=output,C=control,IN=init,T=time)      *
! name   type meaning                                     units  class *
! ----   ---- -------                                     -----  ----- *
! HOUR    R4  Hour for which calculations should be done     h      I  *
! SOLCON  R4  Solar constant                               W/m2     I  *
! FRPAR   R4  Fraction of total shortwave irradiation        -      I  *
!             that is photosynthetically active (PAR)                  *
! DSINBE  R4  Daily integral of sine of solar height         s      I  *
!             corrected for lower transmission at low                  *
!             elevation                                                *
! SINLD   R4  Intermediate variable from SASTRO              -      I  *
! COSLD   R4  Intermediate variable from SASTRO              -      I  *
! RDD     R4  Daily shortwave radiation                   J/m2/d    I  *
! SINB    R4  Sine of solar inclination at HOUR              -      O  *
! RDPDR   R4  Instantaneous flux of direct photo-          W/m2     O  *
!             synthetically active radiation (PAR)                     *
! RDPDF   R4  Instantaneous flux of diffuse photo-         W/m2     O  *
!             synthetically active irradiation (PAR)                   *
!                                                                      *
! Fatal error checks: RDD <= 0                                         *
! Warnings          : ATMTR > 0.9                                      *
! Subprograms called: FATALERR                                         *
! File usage        : none                                             *
!----------------------------------------------------------------------*

      SUBROUTINE SSKYC (HOUR, SOLCON, FRPAR, DSINBE, SINLD, COSLD, RDD, &
                        SINB, RDPDR , RDPDF)
      IMPLICIT NONE

!     Formal parameters
      REAL HOUR, SOLCON, FRPAR, DSINBE, SINLD, COSLD, RDD
      REAL SINB, RDPDR, RDPDF

!     Local parameters
      REAL ATMTR, FRDIF, SOLHM, TMPR1

!     Hour on day that solar height is at maximum
      PARAMETER (SOLHM=12.)
      SAVE         ! TAOLI

      IF (RDD.LE.0.) CALL FATALERR &
         ('SSKYC','total shortwave irradiation <= zero')

      ATMTR  = 0.
      FRDIF  = 0.
      RDPDF = 0.
      RDPDR = 0.

!     Sine of solar inclination, 0.2617993 is 15 degrees in radians
      SINB = SINLD+COSLD*COS ((HOUR-SOLHM)*0.2617993)

      IF (SINB.GT.0.) THEN
!        Sun is above the horizon

         TMPR1 = RDD*SINB*(1.+0.4*SINB)/DSINBE
         ATMTR = TMPR1/(SOLCON*SINB)

         IF (ATMTR.GT.0.9) WRITE (*,'(A,G12.5,A)') &
             ' WARNING from SSKYC: ATMTR =',ATMTR,', value very large'

         IF (ATMTR.LE.0.22) THEN
            FRDIF = 1.
         ELSE IF (ATMTR.GT.0.22 .AND. ATMTR.LE.0.35) THEN
            FRDIF = 1.-6.4*(ATMTR-0.22)**2
         ELSE
            FRDIF = 1.47-1.66*ATMTR
         END IF

!        Apply lower limit to fraction diffuse
         FRDIF = MAX (FRDIF, 0.15+0.85*(1.-EXP (-0.1/SINB)))

!        Diffuse and direct PAR
         RDPDF = TMPR1*FRPAR*FRDIF
         RDPDR = TMPR1*FRPAR*(1.-FRDIF)

      END IF

      RETURN
      END


C$Procedure      VMINUG ( Minus V, "-V", general dimension )

      SUBROUTINE VMINUG ( VIN, NDIM, VOUT )

C$ Abstract
C
C     Negate a double precision vector of arbitrary dimension.
C
C$ Disclaimer
C
C     THIS SOFTWARE AND ANY RELATED MATERIALS WERE CREATED BY THE
C     CALIFORNIA INSTITUTE OF TECHNOLOGY (CALTECH) UNDER A U.S.
C     GOVERNMENT CONTRACT WITH THE NATIONAL AERONAUTICS AND SPACE
C     ADMINISTRATION (NASA). THE SOFTWARE IS TECHNOLOGY AND SOFTWARE
C     PUBLICLY AVAILABLE UNDER U.S. EXPORT LAWS AND IS PROVIDED "AS-IS"
C     TO THE RECIPIENT WITHOUT WARRANTY OF ANY KIND, INCLUDING ANY
C     WARRANTIES OF PERFORMANCE OR MERCHANTABILITY OR FITNESS FOR A
C     PARTICULAR USE OR PURPOSE (AS SET FORTH IN UNITED STATES UCC
C     SECTIONS 2312-2313) OR FOR ANY PURPOSE WHATSOEVER, FOR THE
C     SOFTWARE AND RELATED MATERIALS, HOWEVER USED.
C
C     IN NO EVENT SHALL CALTECH, ITS JET PROPULSION LABORATORY, OR NASA
C     BE LIABLE FOR ANY DAMAGES AND/OR COSTS, INCLUDING, BUT NOT
C     LIMITED TO, INCIDENTAL OR CONSEQUENTIAL DAMAGES OF ANY KIND,
C     INCLUDING ECONOMIC DAMAGE OR INJURY TO PROPERTY AND LOST PROFITS,
C     REGARDLESS OF WHETHER CALTECH, JPL, OR NASA BE ADVISED, HAVE
C     REASON TO KNOW, OR, IN FACT, SHALL KNOW OF THE POSSIBILITY.
C
C     RECIPIENT BEARS ALL RISK RELATING TO QUALITY AND PERFORMANCE OF
C     THE SOFTWARE AND ANY RELATED MATERIALS, AND AGREES TO INDEMNIFY
C     CALTECH AND NASA FOR ALL THIRD-PARTY CLAIMS RESULTING FROM THE
C     ACTIONS OF RECIPIENT IN THE USE OF THE SOFTWARE.
C
C$ Required_Reading
C
C     None.
C
C$ Keywords
C
C     VECTOR
C
C$ Declarations

      INTEGER            NDIM
      DOUBLE PRECISION   VIN   ( NDIM )
      DOUBLE PRECISION   VOUT  ( NDIM )

C$ Brief_I/O
C
C     VARIABLE  I/O  DESCRIPTION
C     --------  ---  --------------------------------------------------
C     VIN        I   NDIM-dimensional double precision vector to
C                    be negated.
C     NDIM       I   Dimension of VIN (and also VOUT).
C     VOUT       O   NDIM-dimensional double precision vector equal to
C                    -VIN.
C
C$ Detailed_Input
C
C     VIN      is double precision vector of arbitrary size.
C
C     NDIM     is the dimension of VIN and VOUT.
C
C$ Detailed_Output
C
C     VOUT    is a double precision vector which contains the negation
C             of VIN.
C
C$ Parameters
C
C     None.
C
C$ Exceptions
C
C     Error free.
C
C$ Files
C
C     None.
C
C$ Particulars
C
C     For each value of the index I from 1 to NDIM, VMINUG negates VIN
C     by the expression:
C
C        VOUT(I) = - VIN(I)
C
C$ Examples
C
C     Let VIN = ( -10.0D0, 15.0D0, -5.0D0, 20.0D0 )
C
C     The call
C
C        CALL VMINUG ( VIN, 4, VOUT )
C
C     negates all of the components of the vector VIN.
C     The vector VOUT then contains the components
C
C        VOUT = ( 10.0D0, -15.0D0, 5.0D0, -20.0D0 )
C
C$ Restrictions
C
C     None.
C
C$ Literature_References
C
C     None.
C
C$ Author_and_Institution
C
C     W.M. Owen       (JPL)
C
C$ Version
C
C-    SPICELIB Version 1.0.2, 23-APR-2010 (NJB)
C
C        Header correction: assertions that the output
C        can overwrite the input have been removed.
C
C-    SPICELIB Version 1.0.1, 10-MAR-1992 (WLT)
C
C        Comment section for permuted index source lines was added
C        following the header.
C
C-    SPICELIB Version 1.0.0, 31-JAN-1990 (WMO)
C
C-&

C$ Index_Entries
C
C     negate an n-dimensional vector
C
C-&

      INTEGER I
C
      DO I = 1, NDIM
         VOUT(I) = -VIN(I)
      END DO

      RETURN
      END


    !
    ! This program may be freely redistributed under the
    ! condition that the copyright notices (including this
    ! entire header) are not removed, and no compensation
    ! is received through use of the software.  Private,
    ! research, and institutional use is free.  You may
    ! distribute modified versions of this code UNDER THE
    ! CONDITION THAT THIS CODE AND ANY MODIFICATIONS MADE
    ! TO IT IN THE SAME FILE REMAIN UNDER COPYRIGHT OF THE
    ! ORIGINAL AUTHOR, BOTH SOURCE AND OBJECT CODE ARE
    ! MADE FREELY AVAILABLE WITHOUT CHARGE, AND CLEAR
    ! NOTICE IS GIVEN OF THE MODIFICATIONS.  Distribution
    ! of this code as part of a commercial system is
    ! permissible ONLY BY DIRECT ARRANGEMENT WITH THE
    ! AUTHOR.  (If you are not directly supplying this
    ! code to a customer, and you are instead telling them
    ! how they can obtain it for free, then you are not
    ! required to make any arrangement with me.)
    !
    ! Disclaimer:  Neither I nor: Columbia University, the
    ! National Aeronautics and Space Administration, nor
    ! the Massachusetts Institute of Technology warrant
    ! or certify this code in any way whatsoever.  This
    ! code is provided "as-is" to be used at your own risk.
    !
    !

    !
    ! ROOT1D.f90: find the "roots" of degree-k polynomials.
    !
    ! Darren Engwirda
    ! 25-Mar-2019
    ! de2363 [at] columbia [dot] edu
    !
    !

    pure subroutine roots_2(aa,bb,cc,xx,haveroot)

    !
    ! solve:: aa * xx**2 + bb * xx**1 + cc = +0.0 .
    !

        implicit none

    !------------------------------------------- arguments !
        real*8 , intent( in) :: aa,bb,cc
        real*8 , intent(out) :: xx(1:2)
        logical, intent(out) :: haveroot

    !------------------------------------------- variables !
        real*8 :: sq,ia,a0,b0,c0,x0

        real*8, parameter :: rt = +1.d-14

        a0 = abs(aa)
        b0 = abs(bb)
        c0 = abs(cc)

        sq = bb * bb - 4.0d+0 * aa * cc

        if (sq .ge. 0.0d+0) then

            sq = sqrt (sq)

            xx(1) =  - bb + sq
            xx(2) =  - bb - sq

            x0 = max(abs(xx(1)), &
        &            abs(xx(2)))

            if (a0 .gt. (rt*x0)) then

    !-------------------------------------- degree-2 roots !

            haveroot =  .true.

            ia = 0.5d+0   / aa

            xx(1) = xx(1) * ia
            xx(2) = xx(2) * ia

            else &
        &   if (b0 .gt. (rt*c0)) then

    !-------------------------------------- degree-1 roots !

            haveroot =  .true.

            xx(1) =  - cc / bb
            xx(2) =  - cc / bb

            else

            haveroot = .false.

            end if

        else

            haveroot = .false.

        end if

        return

    end subroutine


      SUBROUTINE MB03XS( JOBU, N, A, LDA, QG, LDQG, U1, LDU1, U2, LDU2,
     $                   WR, WI, DWORK, LDWORK, INFO )
C
C     SLICOT RELEASE 5.5.
C
C     Copyright (c) 2002-2012 NICONET e.V.
C
C     PURPOSE
C
C     To compute the eigenvalues and real skew-Hamiltonian Schur form of
C     a skew-Hamiltonian matrix,
C
C                   [  A   G  ]
C             W  =  [       T ],
C                   [  Q   A  ]
C
C     where A is an N-by-N matrix and G, Q are N-by-N skew-symmetric
C     matrices. Specifically, an orthogonal symplectic matrix U is
C     computed so that
C
C               T       [  Aout  Gout  ]
C              U W U =  [            T ] ,
C                       [    0   Aout  ]
C
C     where Aout is in Schur canonical form (as returned by the LAPACK
C     routine DHSEQR). That is, Aout is block upper triangular with
C     1-by-1 and 2-by-2 diagonal blocks; each 2-by-2 diagonal block has
C     its diagonal elements equal and its off-diagonal elements of
C     opposite sign.
C
C     Optionally, the matrix U is returned in terms of its first N/2
C     rows
C
C                      [  U1   U2 ]
C                  U = [          ].
C                      [ -U2   U1 ]
C
C     ARGUMENTS
C
C     Mode Parameters
C
C     JOBU    CHARACTER*1
C             Specifies whether matrix U is computed or not, as follows:
C             = 'N': transformation matrix U is not computed;
C             = 'U': transformation matrix U is computed.
C
C     Input/Output Parameters
C
C     N       (input) INTEGER
C             The order of the matrix A.  N >= 0.
C
C     A       (input/output) DOUBLE PRECISION array, dimension (LDA,N)
C             On entry, the leading N-by-N part of this array must
C             contain the matrix A.
C             On exit, the leading N-by-N part of this array contains
C             the matrix Aout in Schur canonical form.
C
C     LDA     INTEGER
C             The leading dimension of the array A.  LDA >= MAX(1,N).
C
C     QG      (input/output) DOUBLE PRECISION array, dimension
C                            (LDQG,N+1)
C             On entry, the leading N-by-N+1 part of this array must
C             contain in columns 1:N the strictly lower triangular part
C             of the matrix Q and in columns 2:N+1 the strictly upper
C             triangular part of the matrix G.
C             On exit, the leading N-by-N+1 part of this array contains
C             in columns 2:N+1 the strictly upper triangular part of the
C             skew-symmetric matrix Gout. The part which contained the
C             matrix Q is set to zero.
C             Note that the parts containing the diagonal and the first
C             superdiagonal of this array are not overwritten by zeros
C             only if JOBU = 'U' or LDWORK >= 2*N*N - N.
C
C     LDQG    INTEGER
C             The leading dimension of the array QG.  LDQG >= MAX(1,N).
C
C     U1      (output) DOUBLE PRECISION array, dimension (LDU1,N)
C             On exit, if JOBU = 'U', the leading N-by-N part of this
C             array contains the matrix U1.
C             If JOBU = 'N', this array is not referenced.
C
C     LDU1    INTEGER
C             The leading dimension of the array U1.
C             LDU1 >= MAX(1,N),  if JOBU = 'U';
C             LDU1 >= 1,         if JOBU = 'N'.
C
C     U2      (output) DOUBLE PRECISION array, dimension (LDU2,N)
C             On exit, if JOBU = 'U', the leading N-by-N part of this
C             array contains the matrix U2.
C             If JOBU = 'N', this array is not referenced.
C
C     LDU2    INTEGER
C             The leading dimension of the array U2.
C             LDU2 >= MAX(1,N),  if JOBU = 'U';
C             LDU2 >= 1,         if JOBU = 'N'.
C
C     WR      (output) DOUBLE PRECISION array, dimension (N)
C     WI      (output) DOUBLE PRECISION array, dimension (N)
C             The real and imaginary parts, respectively, of the
C             eigenvalues of Aout, which are half of the eigenvalues
C             of W. The eigenvalues are stored in the same order as on
C             the diagonal of Aout, with WR(i) = Aout(i,i) and, if
C             Aout(i:i+1,i:i+1) is a 2-by-2 diagonal block, WI(i) > 0
C             and WI(i+1) = -WI(i).
C
C     Workspace
C
C     DWORK   DOUBLE PRECISION array, dimension (LDWORK)
C             On exit, if INFO = 0,  DWORK(1)  returns the optimal value
C             of LDWORK.
C             On exit, if  INFO = -14,  DWORK(1)  returns the minimum
C             value of LDWORK.
C
C     LDWORK  INTEGER
C             The length of the array DWORK.
C             LDWORK >= MAX(1,(N+5)*N),      if JOBU = 'U';
C             LDWORK >= MAX(1,5*N,(N+1)*N),  if JOBU = 'N'.
C
C             If LDWORK = -1, then a workspace query is assumed;
C             the routine only calculates the optimal size of the
C             DWORK array, returns this value as the first entry of
C             the DWORK array, and no error message related to LDWORK
C             is issued by XERBLA.
C
C     Error Indicator
C
C     INFO    INTEGER
C             = 0:  successful exit;
C             < 0:  if INFO = -i, the i-th argument had an illegal
C                   value;
C             > 0:  if INFO = i, DHSEQR failed to compute all of the
C                   eigenvalues.  Elements 1:ILO-1 and i+1:N of WR
C                   and WI contain those eigenvalues which have been
C                   successfully computed. The matrix A (and QG) has
C                   been partially reduced; namely, A is upper
C                   Hessenberg in the rows and columns ILO through i.
C                   (See DHSEQR for details.)
C
C     METHOD
C
C     First, using the SLICOT Library routine MB04RB, an orthogonal
C     symplectic matrix UP is computed so that
C
C                T      [  AP  GP  ]
C            UP W UP =  [        T ]
C                       [  0   AP  ]
C
C     is in Paige/Van Loan form. Next, the LAPACK routine DHSEQR is
C     applied to the matrix AP to compute an orthogonal matrix V so
C     that Aout = V'*AP*V is in Schur canonical form.
C     Finally, the transformations
C
C                       [ V  0 ]
C             U =  UP * [      ],     Gout = V'*G*V,
C                       [ 0  V ]
C
C     using the SLICOT Library routine MB01LD for the latter, are
C     performed.
C
C     REFERENCES
C
C     [1] Van Loan, C.F.
C         A symplectic method for approximating all the eigenvalues of
C         a Hamiltonian matrix.
C         Linear Algebra and its Applications, 61, pp. 233-251, 1984.
C
C     [2] Kressner, D.
C         Block algorithms for orthogonal symplectic factorizations.
C         BIT, 43 (4), pp. 775-790, 2003.
C
C     CONTRIBUTORS
C
C     D. Kressner (Technical Univ. Berlin, Germany) and
C     P. Benner (Technical Univ. Chemnitz, Germany), December 2003.
C
C     REVISIONS
C
C     V. Sima, Nov. 2011 (SLICOT version of the HAPACK routine DSHES).
C     V. Sima, Oct. 2012.
C
C     KEYWORDS
C
C     Schur form, eigenvalues, skew-Hamiltonian matrix.
C
C     ******************************************************************
C
C     .. Parameters ..
      DOUBLE PRECISION  ZERO, ONE
      PARAMETER         ( ZERO = 0.0D0, ONE = 1.0D0 )
C     .. Scalar Arguments ..
      CHARACTER         JOBU
      INTEGER           INFO, LDA, LDQG, LDU1, LDU2, LDWORK, N
C     .. Array Arguments ..
      DOUBLE PRECISION  A(LDA,*), DWORK(*), QG(LDQG,*), U1(LDU1,*),
     $                  U2(LDU2,*), WI(*), WR(*)
C     .. Local Scalars ..
      LOGICAL           COMPU, LQUERY, SCALEW
      INTEGER           I, I1, I2, IERR, ILO, INXT, NN, PBAL, PCS, PDV,
     $                  PDW, PHO, PTAU, WRKMIN, WRKOPT
      DOUBLE PRECISION  BIGNUM, CSCALE, EPS, SMLNUM, WNRM
C     .. External Function ..
      LOGICAL           LSAME
      DOUBLE PRECISION  DLAMCH, MA02ID
      EXTERNAL          DLAMCH, LSAME, MA02ID
C     .. External Subroutines ..
      EXTERNAL          DCOPY, DHSEQR, DLABAD, DLACPY, DLASCL, DLASET,
     $                  DSCAL, DSWAP, MB01LD, MB04DI, MB04DS, MB04QS,
     $                  MB04RB, XERBLA
C     .. Intrinsic Functions ..
      INTRINSIC         DBLE, INT, MAX, MIN, SQRT
C
C     .. Executable Statements ..
C
C     Check the scalar input parameters.
C
      INFO  = 0
      COMPU = LSAME( JOBU, 'U' )
C
      NN = N*N
      IF ( COMPU ) THEN
         WRKMIN = MAX( 1, NN + 5*N )
      ELSE
         WRKMIN = MAX( 1, 5*N, NN + N )
      END IF
      WRKOPT = WRKMIN
C
      IF ( .NOT.COMPU .AND. .NOT.LSAME( JOBU, 'N' ) ) THEN
         INFO = -1
      ELSE IF ( N.LT.0 ) THEN
         INFO = -2
      ELSE IF (  LDA.LT.MAX( 1,N ) ) THEN
         INFO = -4
      ELSE IF ( LDQG.LT.MAX( 1,N ) ) THEN
         INFO = -6
      ELSE IF ( LDU1.LT.1 .OR. ( COMPU .AND. LDU1.LT.N ) ) THEN
         INFO = -8
      ELSE IF ( LDU2.LT.1 .OR. ( COMPU .AND. LDU2.LT.N ) ) THEN
         INFO = -10
      ELSE
         LQUERY = LDWORK.EQ.-1
         IF ( LDWORK.LT.WRKMIN .AND. .NOT.LQUERY ) THEN
            DWORK(1) = DBLE( WRKMIN )
            INFO = -14
         ELSE IF( LQUERY ) THEN
            IF ( N.EQ.0 ) THEN
               DWORK(1) = ONE
            ELSE
               I = 4*N
               CALL MB04RB( N, 1, A, LDA, QG, LDQG, DWORK, DWORK, DWORK,
     $                      -1, IERR )
               WRKOPT = MAX( WRKOPT, INT( DWORK(1) ) + I )
               CALL DHSEQR( 'Schur', 'Initialize', N, 1, N, A, LDA, WR,
     $                      WI, DWORK, N, DWORK, -1, IERR )
               IF ( COMPU ) THEN
                  I = I + NN
                  WRKOPT = MAX( WRKOPT, INT( DWORK(1) ) + I )
                  CALL MB04QS( 'N', 'N', 'N', N, N, 1, DWORK, N, QG,
     $                         LDQG, U1, LDU1, U2, LDU2, DWORK, DWORK,
     $                         DWORK, -1, IERR )
               ELSE
                  I = NN
                  WRKOPT = MAX( WRKOPT, 2*NN - N )
               END IF
               DWORK(1) = MAX( WRKMIN, WRKOPT, INT( DWORK(1) ) + I )
            END IF
            RETURN
         END IF
      END IF
C
C     Return if there were illegal values.
C
      IF ( INFO.NE.0 ) THEN
         CALL XERBLA( 'MB03XS', -INFO )
         RETURN
      END IF
C
C     Quick return if possible.
C
      IF ( N.EQ.0 ) THEN
         DWORK(1) = ONE
         RETURN
      END IF
C
C     Get machine constants.
C
      EPS    = DLAMCH( 'P' )
      SMLNUM = DLAMCH( 'S' )
      BIGNUM = ONE / SMLNUM
      CALL DLABAD( SMLNUM, BIGNUM )
      SMLNUM = SQRT( SMLNUM ) / EPS
      BIGNUM = ONE / SMLNUM
C
C     Scale W if max element outside range [SMLNUM,BIGNUM].
C
      WNRM = MA02ID( 'Skew-Hamiltonian', 'Max-Norm', N, A, LDA, QG,
     $               LDQG, DWORK )
      SCALEW = .FALSE.
      IF ( WNRM.GT.ZERO .AND. WNRM.LT.SMLNUM ) THEN
         SCALEW = .TRUE.
         CSCALE = SMLNUM
      ELSE IF ( WNRM.GT.BIGNUM ) THEN
         SCALEW = .TRUE.
         CSCALE = BIGNUM
      END IF
      IF( SCALEW ) THEN
         CALL DLASCL( 'General', 0, 0, WNRM, CSCALE, N, N, A, LDA,
     $                IERR )
         IF ( N.GT.1 ) THEN
            CALL DLASCL( 'Lower', 0, 0, WNRM, CSCALE, N-1, N-1, QG(2,1),
     $                   LDQG, IERR )
            CALL DLASCL( 'Upper', 0, 0, WNRM, CSCALE, N-1, N-1, QG(1,3),
     $                   LDQG, IERR )
         END IF
      END IF
C
C     Permute to make W closer to skew-Hamiltonian Schur form.
C     Workspace:  need   N.
C
      PBAL = 1
      CALL MB04DS( 'Permute', N, A, LDA, QG, LDQG, ILO, DWORK(PBAL),
     $             IERR )
C
C     Reduce to Paige/Van Loan form.
C     Workspace:  need   5*N-1.
C
      PCS  =   N + PBAL
      PTAU = 2*N + PCS
      PDW  =   N + PTAU
      CALL MB04RB( N, ILO, A, LDA, QG, LDQG, DWORK(PCS), DWORK(PTAU),
     $             DWORK(PDW), LDWORK-PDW+1, IERR )
      WRKOPT = MAX( WRKOPT, INT( DWORK(PDW) ) + PDW - 1 )
      IF ( COMPU ) THEN
C
C        Copy information about Householder vectors to workspace.
C
         PHO = PDW
         PDW = PDW + NN
         CALL DLACPY( 'L', N, N, A, LDA, DWORK(PHO), N )
C
C        Perform QR iteration, accumulating Schur vectors in U1.
C        Workspace:  need   N*N + 5*N;
C                    prefer larger.
C
         CALL DHSEQR( 'Schur', 'Initialize', N, MIN( ILO, N ), N, A,
     $                LDA, WR, WI, U1, LDU1, DWORK(PDW), LDWORK-PDW+1,
     $                INFO )
         WRKOPT = MAX( WRKOPT, INT( DWORK(PDW) ) + PDW - 1 )
C
C        Update G = V'*G*V.
C
         CALL MB01LD( 'Upper', 'Transpose', N, N, ZERO, ONE, QG(1,2),
     $                 LDQG, U1, LDU1, QG(1,2), LDQG, U2, NN, IERR )
C
C        Apply orthogonal symplectic matrix from PVL reduction to [V;0].
C        Workspace:  need   N*N + 5*N;
C                    prefer larger.
C
         CALL DSCAL(  N-1, -ONE, DWORK(PCS+1), 2 )
         CALL DLASET( 'All', N, N, ZERO, ZERO, U2, LDU2 )
         CALL MB04QS( 'No Transpose', 'No Transpose', 'No Transpose', N,
     $                N, ILO, DWORK(PHO), N, QG, LDQG, U1, LDU1, U2,
     $                LDU2, DWORK(PCS), DWORK(PTAU), DWORK(PDW),
     $                LDWORK-PDW+1, IERR )
         WRKOPT = MAX( WRKOPT, INT( DWORK(PDW) ) + PDW - 1 )
C
C        Annihilate Q.
C
         IF ( N.GT.1 )
     $      CALL DLASET( 'Lower', N-1, N-1, ZERO, ZERO, QG(2,1), LDQG )
C
C        Undo balancing.
C
         CALL MB04DI( 'Permute', 'Positive', N, ILO, DWORK(PBAL), N, U1,
     $                LDU1, U2, LDU2, IERR )
      ELSE
C
C        Perform QR iteration, accumulating Schur vectors in DWORK.
C        Workspace:  need   N*N + N;
C                    prefer larger.
C
         PDV = 1
         PDW = NN + PDV
         CALL DHSEQR( 'Schur', 'Initialize', N, MIN( ILO, N ), N, A,
     $                LDA, WR, WI, DWORK(PDV), N, DWORK(PDW),
     $                LDWORK-PDW+1, INFO )
         WRKOPT = MAX( WRKOPT, INT( DWORK(PDW) ) + PDW - 1 )
C
C        Update G = V'*G*V.
C        Workspace:  need   N*N + N;
C                    prefer N*N + N*(N-1).
C
         CALL MB01LD( 'Upper', 'Transpose', N, N, ZERO, ONE, QG(1,2),
     $                LDQG, DWORK(PDV), N, QG(1,2), LDQG, DWORK(PDW),
     $                LDWORK-PDW+1, IERR )
         WRKOPT = MAX( WRKOPT, 2*NN - N )
C
C        Annihilate Q.
C
         IF ( N.GT.1 )
     $      CALL DLASET( 'Lower', N-1, N-1, ZERO, ZERO, QG(2,1), LDQG )
      END IF
C
      IF ( SCALEW ) THEN
C
C        Undo scaling for the skew-Hamiltonian Schur form.
C
         CALL DLASCL( 'Hessenberg', 0, 0, CSCALE, WNRM, N, N, A, LDA,
     $                IERR )
         IF ( N.GT.1 ) THEN
            CALL DLASCL( 'Upper', 0, 0, CSCALE, WNRM, N-1, N-1, QG(1,3),
     $                   LDQG, IERR )
         END IF
         CALL DCOPY( N, A, LDA+1, WR, 1 )
C
         IF ( CSCALE.EQ.SMLNUM ) THEN
C
C           If scaling back towards underflow, adjust WI if an
C           offdiagonal element of a 2-by-2 block in the Schur form
C           underflows.
C
            IF( INFO.GT.0 ) THEN
               I1 = INFO + 1
               CALL DLASCL( 'General', 0, 0, CSCALE, WNRM, ILO-1, 1, WI,
     $                      MAX( ILO-1, 1 ), IERR )
            ELSE
               I1 = ILO
            END IF
            I2   = N - 1
            INXT = I1 - 1
            DO 10 I = I1, I2
               IF ( I.LT.INXT )
     $            GO TO 10
               IF ( WI(I).EQ.ZERO ) THEN
                  INXT = I + 1
               ELSE
                  IF ( A(I+1,I).EQ.ZERO ) THEN
                     WI(I)   = ZERO
                     WI(I+1) = ZERO
                  ELSE IF ( A(I,I+1).EQ.ZERO )
     $                  THEN
                     WI(I)   = ZERO
                     WI(I+1) = ZERO
                     IF ( I.GT.1 )
     $                  CALL DSWAP( I-1, A(1,I), 1, A(1,I+1), 1 )
                     IF( N.GT.I+1 )
     $                  CALL DSWAP( N-I-1, A(I,I+2), LDA,
     $                              A(I+1,I+2), LDA )
                     A(I,I+1)  = A(I+1,I)
                     A(I+1,I ) = ZERO
C
                     CALL DSWAP( I-1, QG(1,I+2), 1, QG(1,I+1), 1 )
                     IF ( N.GT.I+1 )
     $                  CALL DSWAP( N-I-1, QG(I+1,I+3), LDQG, QG(I,I+3),
     $                              LDQG )
                     QG(I,I+2) = -QG(I,I+2)
                     IF ( COMPU ) THEN
                        CALL DSWAP( N, U1(1,I), 1, U1(1,I+1), 1 )
                        CALL DSWAP( N, U2(1,I), 1, U2(1,I+1), 1 )
                     END IF
                  END IF
                  INXT = I + 2
               END IF
   10       CONTINUE
         END IF
C
C        Undo scaling for imaginary parts of the eigenvalues.
C
         CALL DLASCL( 'General', 0, 0, CSCALE, WNRM, N-INFO, 1,
     $                WI(INFO+1), MAX( N-INFO, 1 ), IERR )
      END IF
C
      DWORK(1) = DBLE( WRKOPT )
C
      RETURN
C *** Last line of MB03XS ***
      END


       SUBROUTINE W3FB05(XI,XJ,XMESHL,ORIENT,ALAT,ALONG)
C$$$   SUBPROGRAM  DOCUMENTATION  BLOCK
C
C SUBPROGRAM: W3FB05         GRID COORDINATES TO LATITUDE, LONGITUDE
C   AUTHOR: JONES,R.E.       ORG: W345       DATE: 86-07-17
C
C ABSTRACT: CONVERTS THE COORDINATES OF A LOCATION FROM THE GRID(I,J)
C   COORDINATE SYSTEM OVERLAID ON THE POLAR STEREOGRAPHIC MAP PROJEC-
C   TION TRUE AT 60 DEGREES N OR S LATITUDE TO THE NATURAL COORDINATE
C   SYSTEM OF LATITUDE/LONGITUDE ON THE EARTH. W3FB05 IS THE REVERSE
C   OF W3FB04.
C
C PROGRAM HISTORY LOG:
C   86-07-17  R.E.JONES
C   89-11-01  R.E.JONES   CHANGE TO CRAY CFT77 FORTRAN
C
C USAGE:  CALL W3FB05 (XI, XJ, XMESHL, ORIENT, ALAT, ALONG)
C
C   INPUT VARIABLES:
C     NAMES  INTERFACE DESCRIPTION OF VARIABLES AND TYPES
C     ------ --------- -----------------------------------------------
C     XI     ARG LIST  I OF THE POINT RELATIVE TO THE NORTH OR S. POLE
C     XJ     ARG LIST  J OF THE POINT RELATIVE TO THE NORTH OR S. POLE
C     XMESHL ARG LIST  MESH LENGTH OF GRID IN KM AT 60 DEGREES(<0 IF SH)
C                   (190.5 LFM GRID, 381.0 NH PE GRID,-381.0 SH PE GRID)
C     ORIENT ARG LIST  ORIENTATION WEST LONGITUDE OF THE GRID
C                    (105.0 LFM GRID, 80.0 NH PE GRID, 260.0 SH PE GRID)
C
C   OUTPUT VARIABLES:
C     NAMES  INTERFACE DESCRIPTION OF VARIABLES AND TYPES
C     ------ --------- -----------------------------------------------
C     ALAT   ARG LIST  LATITUDE IN DEGREES  (<0 IF SH)
C     ALONG  ARG LIST  WEST LONGITUDE IN DEGREES
C
C   SUBPROGRAMS CALLED:
C     NAMES                                                   LIBRARY
C     ------------------------------------------------------- --------
C     ASIN   ATAN2                                            SYSLIB
C
C   REMARKS: ALL PARAMETERS IN THE CALLING STATEMENT MUST BE
C     REAL. THE RANGE OF ALLOWABLE LATITUDES IS FROM A POLE TO
C     30 DEGREES INTO THE OPPOSITE HEMISPHERE.
C     THE GRID USED IN THIS SUBROUTINE HAS ITS ORIGIN (I=0,J=0)
C     AT THE POLE, SO IF THE USER'S GRID HAS ITS ORIGIN AT A POINT
C     OTHER THAN A POLE, A TRANSLATION IS REQUIRED TO GET I AND J FOR
C     INPUT INTO W3FB05. THE SUBROUTINE GRID IS ORIENTED SO THAT
C     GRIDLINES OF I=CONSTANT ARE PARALLEL TO A WEST LONGITUDE SUP-
C     PLIED BY THE USER. THE EARTH'S RADIUS IS TAKEN TO BE 6371.2 KM.
C
C   WARNING: THIS CODE WILL NOT VECTORIZE, IT IS NORMALY USED IN A
C            DOUBLE DO LOOP WITH W3FT01, W3FT00, ETC. TO VECTORIZE IT,
C            PUT IT IN LINE, PUT W3FT01, W3FT00, ETC. IN LINE.
C
C   LANGUAGE: CRAY CFT77 FORTRAN
C   MACHINE:  CRAY Y-MP8/832
C
C$$$
C
      DATA  DEGPRD/57.2957795/
      DATA  EARTHR/6371.2/
C
      GI2   = ((1.86603 * EARTHR) / (XMESHL))**2
      R2    = XI * XI + XJ * XJ
C
      IF (R2.EQ.0.0) THEN
        ALONG = 0.0
        ALAT  = 90.0
        IF (XMESHL.LT.0.0) ALAT = -ALAT
        RETURN
      ELSE
        ALAT  = ASIN((GI2 - R2) / (GI2 + R2)) * DEGPRD
        ANGLE = DEGPRD * ATAN2(XJ,XI)
        IF (ANGLE.LT.0.0) ANGLE = ANGLE + 360.0
      ENDIF
C
      IF (XMESHL.GE.0.0) THEN
        ALONG = 270.0 + ORIENT - ANGLE
C
      ELSE
C
        ALONG = ANGLE + ORIENT - 270.0
        ALAT  = -(ALAT)
      ENDIF
C
      IF (ALONG.LT.0.0)   ALONG = ALONG + 360.0
      IF (ALONG.GE.360.0) ALONG = ALONG - 360.0
C
      RETURN
C
      END


!
!     CalculiX - A 3-dimensional finite element program
!     Copyright (C) 1998-2018 Guido Dhondt
!
!     This program is free software; you can redistribute it and/or
!     modify it under the terms of the GNU General Public License as
!     published by the Free Software Foundation(version 2);
!
!
!     This program is distributed in the hope that it will be useful,
!     but WITHOUT ANY WARRANTY; without even the implied warranty of
!     MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
!     GNU General Public License for more details.
!
!     You should have received a copy of the GNU General Public License
!     along with this program; if not, write to the Free Software
!     Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
!
      subroutine user_network_element_p1(node1,node2,nodem,nelem,lakon,
     &     kon,ipkon,nactdog,identity,ielprop,prop,iflag,v,xflow,f,
     &     nodef,idirf,df,cp,R,physcon,dvi,numf,set,co,vold,mi,ttime,
     &     time,iaxial,iplausi)
!
!     UP1 element: mass flow = c * dsqrt(pt2-pt1)
!
!     f:= c * dsqrt(pt2-pt1) - mass flow
!
!     for this element it is known that the flow direction
!     has to correspond to the pressure drop
!
!     INPUT:
!
!     node1              first node in element topology
!     node2              third node in element topology
!     nodem              second node in element topology (middle node)
!     nelem              element number
!     lakon(i)           label of element i
!     kon                connectivity list of all elements; the topology
!                        of element i starts at kon(ipkon(i))
!     ipkon(i)           pointer of element i into list kon
!     nactdog(j,i)       global degree of freedom in the network
!                        equation system of local dof j (0,1 or 2 for
!                        networks) of node i. If nactdog(j,i)=0 the
!                        variable is known
!     ielprop(i)         pointer for element i into field prop. The
!                        properties for element i start at
!                        prop(ielprop(i)+1,...)
!     prop               field of all properties
!     iflag              indicates what information should be returned
!                        by the routine:
!                        0: identity
!                        1: xflow
!                        2: numf, nodef, idirf, f, df
!                        3: none
!     v(0..mi(2),i)      values at node i in the current network
!                        iteration (0=total temperature,
!                        1=mass flow, 2=total pressure for network nodes,
!                        0=temperature, 1..3=displacements for structural
!                        nodes)
!     cp                 specific heat at constant pressure corresponding
!                        to a mean static temperature across the element
!     R                  specific gas constant
!     physcon(1..)       physical constants (e.g. physcon(1) is absolute
!                        zero in the unit systemof the user; cf. the
!                        user's manual for the other entries)
!     dvi                dynamical viscosity corresponding
!                        to a mean static temperature across the element
!     set(i)             set name corresponding to set i
!     co(1..3,i)         coordinates of node i in the global system
!     vold(0..mi(2),i)   values at node i at the start of the current network
!                        iterations (0=total temperature,
!                        1=mass flow, 2=total pressure for network nodes,
!                        0=temperature, 1..3=displacements for structural
!                        nodes)
!     mi(2)              max degree of freedom per node (max over all
!                        nodes) in fields like v(0:mi(2))...; the other
!                        values of mi are not relevant here
!     ttime              total time at the end of the current
!                        thermo-mechanical increment. To reach the end
!                        of this increment several thermo-mechanical
!                        iterations are performed. For each of these
!                        iterations a loop of network iterations is
!                        performed
!     time               step time a the end of the current thermo-
!                        mechanical increment
!     iaxial             number of times the current structure fits into
!                        360 degrees
!     iplausi            flag telling whether any plausibility checks
!                        have been violated up to entry in this routine
!                        0: plausibility checks not satisfied
!                        1: plausibility checks (if any) are satisfied
!
!
!     OUTPUT:
!
!     identity           if .true. the user_network_element routine is
!                        not needed (all variables known)
!     xflow              mass flow
!     f                  value of the element equation
!     nodef              nodes corresponding to the variables in the
!                        element equation
!     idirf              degrees of freedom corresponding to the variables
!                        in the element equation
!     df                 derivatives of the element equation w.r.t. its
!                        variables
!     numf               number of variables in the element equation
!     iplausi            flag telling whether any plausibility checks
!                        were violated at return time from this routine
!                        0: plausibility checks not satisfied
!                        1: plausibility checks (if any) are satisfied
!                        only feasible change within this routine is from
!                        1 to 0.
!
      implicit none
!
      logical identity
      character*8 lakon(*)
      character*81 set(*)
!
      integer nelem,nactdog(0:3,*),node1,node2,nodem,numf,
     &     ielprop(*),nodef(*),idirf(*),iflag,ipkon(*),kon(*),
     &     iaxial,mi(*),inv,index,icase,iplausi
!
      real*8 prop(*),v(0:mi(2),*),xflow,f,df(*),R,cp,physcon(*),dvi,
     &     co(3,*),vold(0:mi(2),*),ttime,time,xmach,xflow_oil,Tt1,Tt2,
     &     reynolds,pt1,pt2,kappa,c,a,d,pi,T1,T2
!
      intent(in) node1,node2,nodem,nelem,lakon,
     &     kon,ipkon,nactdog,ielprop,prop,iflag,v,
     &     cp,R,physcon,dvi,set,co,vold,mi,ttime,
     &     time,iaxial
!
      intent(inout) xflow,f,df,identity,nodef,idirf,numf,iplausi
!
      pi=4.d0*datan(1.d0)
      if(iflag.eq.0) then
!
!        called by envtemp.f:
!
!        check whether element equation is needed (this is the
!        case if identity=.false.
!
         identity=.true.
!
         if(nactdog(2,node1).ne.0)then
            identity=.false.
         elseif(nactdog(2,node2).ne.0)then
            identity=.false.
         elseif(nactdog(1,nodem).ne.0)then
            identity=.false.
         endif
!
      elseif(iflag.eq.1)then
!
!        called by initialnet.f:
!
!        calculation of the mass flow if everything else is known
!
         index=ielprop(nelem)
         c=prop(index+2)
!
         pt1=v(2,node1)
         pt2=v(2,node2)
         if(pt1.ge.pt2) then
            inv=1
         else
            inv=-1
            pt1=v(2,node2)
            pt2=v(2,node1)
         endif
!
         xflow=c*dsqrt(pt1-pt2)
!
      elseif(iflag.eq.2)then
!
!        called by resultnet.f and mafillnet.f
!
         numf=3
         index=ielprop(nelem)
!
         pt1=v(2,node1)
         pt2=v(2,node2)
         if(pt1.ge.pt2) then
!
!           flow direction corresponds to element orientation
!
            inv=1
            xflow=v(1,nodem)*iaxial
            nodef(1)=node1
            nodef(2)=nodem
            nodef(3)=node2
         else
!
!           flow direction does not correspond to element orientation
!
            inv=-1
            pt1=v(2,node2)
            pt2=v(2,node1)
            xflow=-v(1,nodem)*iaxial
            nodef(1)=node2
            nodef(2)=nodem
            nodef(3)=node1
         endif
!
         idirf(1)=2
         idirf(2)=1
         idirf(3)=2
!
!        nodef and idirf show that the variables are (if inv=1):
!        1. total pressure in node 1
!        2. mass flow
!        3. total pressure in node 2
!
         c=prop(index+2)
!
         f=c*dsqrt(pt1-pt2)-xflow
         df(1)=c/(2.d0*dsqrt(pt1-pt2))
         df(2)=-1.d0*inv
         df(3)=-df(1)
!
!     output
!
      elseif(iflag.eq.3) then
!
!        called by flowoutput.f
!
!        storage in the .net-file
!
         index=ielprop(nelem)
         a=prop(index+1)
         kappa=(cp/(cp-R))
         icase=1
!
         pt1=v(2,node1)
         pt2=v(2,node2)
         if(pt1.ge.pt2) then
            inv=1
            xflow=v(1,nodem)*iaxial
            Tt1=v(0,node1)-physcon(1)
            Tt2=v(0,node2)-physcon(1)
         else
            inv=-1
            pt1=v(2,node2)
            pt2=v(2,node1)
            xflow=-v(1,nodem)*iaxial
            Tt1=v(0,node2)-physcon(1)
            Tt2=v(0,node1)-physcon(1)
         endif
!
!        calculation of the static temperatures
!
         if(lakon(nelem)(3:3).eq.'P') then
!
!           "pipe"-like element: total and static temperatures
!           differ
!
            call ts_calc(xflow,Tt1,pt1,kappa,r,A,T1,icase)
            call ts_calc(xflow,Tt2,pt2,kappa,r,A,T2,icase)
         else
!
!           "chamber-connecting"-like element: total and static
!           temperatures are equal
!
            T1=Tt1
            T2=Tt2
         endif
!
!     calculation of the dynamic viscosity
!
         if(dabs(dvi).lt.1d-30) then
            write(*,*) '*ERROR in orifice: '
            write(*,*) '       no dynamic viscosity defined'
            write(*,*) '       dvi= ',dvi
            call exit(201)
         endif
!
         index=ielprop(nelem)
         kappa=(cp/(cp-R))
         a=prop(index+1)
         d=dsqrt(a*4/Pi)
         reynolds=dabs(xflow)*d/(dvi*a)
         xmach=dsqrt(((pt1/pt2)**((kappa-1.d0)/kappa)-1.d0)*2.d0/
     &          (kappa-1.d0))
!
         xflow_oil=0.d0
!
         write(1,*) ''
         write(1,55) ' from node ',node1,
     &   ' to node ', node2,' :   air massflow rate = '
     &,inv*xflow,' ',
     &   ', oil massflow rate = ',xflow_oil,' '
!
         if(inv.eq.1) then
            write(1,56)'       Inlet node ',node1,' :   Tt1 = ',Tt1,
     &           '  , Ts1 = ',T1,'  , Pt1 = ',pt1, ' '
!
            write(1,*)'             Element ',nelem,lakon(nelem)
            write(1,57)'             dyn.visc = ',dvi,'  , Re = '
     &           ,reynolds,', M = ',xmach
!
            write(1,56)'      Outlet node ',node2,' :   Tt2 = ',Tt2,
     &           '  , Ts2 = ',T2,'  , Pt2 = ',pt2,' '
!
         else if(inv.eq.-1) then
            write(1,56)'       Inlet node ',node2,':    Tt1 = ',Tt1,
     &           '  , Ts1 = ',T1,' , Pt1 = ',pt1, ' '
     &
            write(1,*)'             element R    ',set(numf)(1:30)
            write(1,57)'             dyn.visc. = ',dvi,' , Re ='
     &           ,reynolds,', M = ',xmach
!
            write(1,56)'      Outlet node ',node1,':    Tt2 = ',Tt2,
     &           '  , Ts2 = ',T2,'  , Pt2 = ',pt2, ' '
         endif
!
      endif
!
 55   format(1x,a,i6,a,i6,a,e11.4,a,a,e11.4,a)
 56   format(1x,a,i6,a,e11.4,a,e11.4,a,e11.4,a)
 57   format(1x,a,e11.4,a,e11.4,a,e11.4)
!
!     degree of freedom 2 is the mass flow dof (cf. field idirf)
!
      xflow=xflow/iaxial
      df(2)=df(2)*iaxial
!
      return
      end


      subroutine rootfr
	!! This subroutine distributes dead root mass through the soil profile
	!! code developed by Armen R. Kemanian in 2008
	!! March, 2009 further adjustments expected

	use parm

	real*8 :: sol_thick(sol_nly(ihru))
	real*8 :: cum_rd, cum_d, cum_rf, x1, x2
	integer :: k, l, jj

	jj = ihru

      if (stsol_rd(jj) < 1.e-6) then
         rtfr(1) = 1
         return
      endif

	! Normalized Root Density = 1.15*exp[-11.7*NRD] + 0.022, where NRD = normalized rooting depth
	! Parameters of Normalized Root Density Function from Dwyer et al 19xx
	a = 1.15
	b = 11.7
	c = 0.022
	d = 0.12029 ! Integral of Normalized Root Distribution Function
				! from 0 to 1 (normalized depth) = 0.12029

	l = 0
	k = 0
	cum_d = 0.
	cum_rf = 0.
         sol_thick(:) = 0.
         rtfr = 0.

	do l=1, sol_nly(jj)
	  if (l == 1) then
	    sol_thick(l) = sol_z(l,jj)
	  else
	    sol_thick(l) = sol_z(l,jj) - sol_z(l-1,jj)
	  end if

	  cum_d = cum_d + sol_thick(l)
	  if (cum_d >= stsol_rd(jj)) cum_rd = stsol_rd(jj)
	  if (cum_d < stsol_rd(jj)) cum_rd = cum_d
	  x1 = (cum_rd - sol_thick(l)) / stsol_rd(jj)
	  x2 = cum_rd / stsol_rd(jj)
           xx1 = -b * x1
	  if (xx1 > 20.) xx1 = 20.
           xx2 = -b * x2
           if (xx2 > 20.) xx2 = 20.
	  rtfr(l)=(a/b*(Exp(xx1) - Exp(xx2)) + c *(x2 - x1)) / d
           xx = cum_rf
	  cum_rf = cum_rf + rtfr(l)
           if (cum_rf > 1.) then
	    rtfr(l) = 1. - xx
             cum_rf = 1.0
           end if
	  k = l
	  if (cum_rd >= stsol_rd(jj)) Exit

	end do

	!!	 ensures that cumulative fractional root distribution = 1
	do l=1, sol_nly(jj)
		rtfr(l) = rtfr(l) / cum_rf
		If (l == k) Exit ! exits loop on the same layer as the previous loop
	end do

	end subroutine


      subroutine  electra(ro,t,ye,ee,pe,se
     a                   ,eer,eet,per,pet,ser,set,keyps)
      implicit real*8 (a-h,o-z)
      common  /nunu/  nu,dnudr,dnudb,eta,detadnu,nup
      data facen,facpr,facs,rg /2.037300d+24,1.358200d+24,1.686304d-10
     1,8.314339d+07/
      data a1,a2,a3,a4 /2.059815d-03,-7.027778d-03
     1,4.219747d-02,-1.132427d+00/
      beta=facs*t
      b32=b12*beta
      u=(f62/f52)**2
      dudnu=2.0d0*u*(df62/f62-df52/f52)
      x=beta*u
      f=1.0d0+x*(2.5d0+x*(2.0d0+0.5d0*x))
      df=2.5d0+x*(4.0d0+1.5d0*x)
      dfdb=u*df
      fi32=f32+(f-1.0d0)*f52/u
      dfidnu=dfidu*dudnu+df32+(f-1.0d0)*df52/u
      dfidb=dfdb*f52/u
      dfidbet=dfidb+dfidnu*dnudb
      gs=sqrt(g)
      dg=0.75d0*gs
      dgdb=u*dg
      dgdu=beta*dg
      gi32=f32+(g-1.0d0)*f52/u
      dgidu=(u*dgdu-g+1.0d0)*f52/us
      dgidnu=dgidu*dudnu+df32+(g-1.0d0)*df52/u
      dgidb=dgdb*f52/u
      dgidbet=dgidb+dgidnu*dnudb
      dgidroe=dgidnu*dnudr
      em=facen*b52*fi32
      demdbet=facen*b32*(2.5d0*fi32+beta*dfidbet)
      dpmdbet=facpr*b32*(2.5d0*gi32+beta*dgidbet)
      demdroe=facen*b52*dfidroe
      dpmdroe=facpr*b52*dgidroe
      call  divine(nup,fp12,dfp12,s12)
      s42=2.0d0
      call  divine(nup,fp42,dfp42,s42)
      eer=(ye*(demdroe+depdroe)-(em+ep)/ro)/ro
      eet=facs*(demdbet+depdbet)/ro
      per=ye*(dpmdroe+dppdroe)
      pet=facs*(dpmdbet+dppdbet)
      end


      SUBROUTINE TG01ID( JOBOBS, COMPQ, COMPZ, N, M, P, A, LDA, E, LDE,
     $                   B, LDB, C, LDC, Q, LDQ, Z, LDZ, NOBSV, NIUOBS,
     $                   NLBLCK, CTAU, TOL, IWORK, DWORK, INFO )
C
C     SLICOT RELEASE 5.7.
C
C     Copyright (c) 2002-2020 NICONET e.V.
C
C     PURPOSE
C
C     To compute orthogonal transformation matrices Q and Z which
C     reduce the N-th order descriptor system (A-lambda*E,B,C)
C     to the form
C
C                ( Ano  * )             ( Eno  * )           ( Bno )
C       Q'*A*Z = (        ) ,  Q'*E*Z = (        ) ,  Q'*B = (     ) ,
C                ( 0   Ao )             ( 0   Eo )           ( Bo  )
C
C          C*Z = ( 0   Co ) ,
C
C     where the NOBSV-th order descriptor system (Ao-lambda*Eo,Bo,Co)
C     is a finite and/or infinite observable. The pencil
C     Ano - lambda*Eno is regular of order N-NOBSV and contains the
C     unobservable finite and/or infinite eigenvalues of the pencil
C     A-lambda*E.
C
C     For JOBOBS = 'O' or 'I', the pencil ( Eo-lambda*Ao ) has full
C                                         (      Co      )
C     column rank NOBSV for all finite lambda and is in a staircase form
C     with
C                     _      _            _      _
C                   ( Ek,k   Ek,k-1   ... Ek,2   Ek,1   )
C                   ( _      _            _      _      )
C       ( Eo ) =    ( Ek-1,k Ek-1,k-1 ... Ek-1,2 Ek-1,1 ) ,  (1)
C       ( Co )      (     ...         ... _      _      )
C                   (  0       0      ... E1,2   E1,1   )
C                   (                            _      )
C                   (  0       0      ... 0      E0,1   )
C                     _          _      _
C                   ( Ak,k  ...  Ak,2   Ak,1 )
C                   (       ...  _      _    )
C         Ao      = (   0   ...  A2,2   A2,1 ) ,             (2)
C                   (                   _    )
C                   (   0   ...    0    A1,1 )
C           _
C     where Ei-1,i is a CTAU(i-1)-by-CTAU(i) full column rank matrix
C                            _
C     (with CTAU(0) = P) and Ai,i is a CTAU(i)-by-CTAU(i)
C     upper triangular matrix.
C
C     For JOBOBS = 'F', the pencil ( Ao-lambda*Eo ) has full
C                                  (      Co      )
C     column rank NOBSV for all finite lambda and is in a staircase form
C     with
C                     _      _            _      _
C                   ( Ak,k   Ak,k-1   ... Ak,2   Ak,1   )
C                   ( _      _            _      _      )
C       ( Ao ) =    ( Ak-1,k Ak-1,k-1 ... Ak-1,2 Ak-1,1 ) ,  (3)
C       ( Co )      (     ...         ... _      _      )
C                   (  0       0      ... A1,2   A1,1   )
C                   (                            _      )
C                   (  0       0      ... 0      A0,1   )
C                     _          _      _
C                   ( Ek,k  ...  Ek,2   Ek,1 )
C                   (       ...  _      _    )
C         Eo      = (   0   ...  E2,2   E2,1 ) ,             (4)
C                   (                   _    )
C                   (   0   ...    0    E1,1 )
C           _
C     where Ai-1,i is a CTAU(i-1)-by-CTAU(i) full column rank matrix
C                            _
C     (with CTAU(0) = P) and Ei,i is a CTAU(i)-by-CTAU(i)
C     upper triangular matrix.
C
C     For JOBOBS = 'O', the (N-NOBSV)-by-(N-NOBSV) regular pencil
C     Ano - lambda*Eno has the form
C
C                         ( Afno - lambda*Efno         *          )
C      Ano - lambda*Eno = (                                       ) ,
C                         (        0           Aino - lambda*Eino )
C
C     where:
C       1) the NIUOBS-by-NIUOBS regular pencil Aino - lambda*Eino,
C          with Aino upper triangular and nonsingular, contains the
C          unobservable infinite eigenvalues of A - lambda*E;
C       2) the (N-NOBSV-NIUOBS)-by-(N-NOBSV-NIUOBS) regular pencil
C          Afno - lambda*Efno, with Efno upper triangular and
C          nonsingular, contains the unobservable finite
C          eigenvalues of A - lambda*E.
C
C     Note: The significance of the two diagonal blocks can be
C           interchanged by calling the routine with the
C           arguments A and E interchanged. In this case,
C           Aino - lambda*Eino contains the unobservable zero
C           eigenvalues of A - lambda*E, while Afno - lambda*Efno
C           contains the unobservable nonzero finite and infinite
C           eigenvalues of A - lambda*E.
C
C     For JOBOBS = 'F', the pencil Ano - lambda*Eno has the form
C
C        Ano - lambda*Eno = Afno - lambda*Efno ,
C
C     where the regular pencil Afno - lambda*Efno, with Efno
C     upper triangular and nonsingular, contains the unobservable
C     finite eigenvalues of A - lambda*E.
C
C     For JOBOBS = 'I', the pencil Ano - lambda*Eno has the form
C
C        Ano - lambda*Eno = Aino - lambda*Eino ,
C
C     where the regular pencil Aino - lambda*Eino, with Aino
C     upper triangular and nonsingular, contains the unobservable
C     nonzero finite and infinite eigenvalues of A - lambda*E.
C
C     The left and/or right orthogonal transformations Q and Z
C     performed to reduce the system matrices can be optionally
C     accumulated.
C
C     The reduced order descriptor system (Ao-lambda*Eo,Bo,Co) has
C     the same transfer-function matrix as the original system
C     (A-lambda*E,B,C).
C
C     ARGUMENTS
C
C     Mode Parameters
C
C     JOBOBS   CHARACTER*1
C             = 'O':  separate both finite and infinite unobservable
C                     eigenvalues;
C             = 'F':  separate only finite unobservable eigenvalues;
C             = 'I':  separate only nonzero finite and infinite
C                     unobservable eigenvalues.
C
C     COMPQ   CHARACTER*1
C             = 'N':  do not compute Q;
C             = 'I':  Q is initialized to the unit matrix, and the
C                     orthogonal matrix Q is returned;
C             = 'U':  Q must contain an orthogonal matrix Q1 on entry,
C                     and the product Q1*Q is returned.
C
C     COMPZ   CHARACTER*1
C             = 'N':  do not compute Z;
C             = 'I':  Z is initialized to the unit matrix, and the
C                     orthogonal matrix Z is returned;
C             = 'U':  Z must contain an orthogonal matrix Z1 on entry,
C                     and the product Z1*Z is returned.
C
C     Input/Output Parameters
C
C     N       (input) INTEGER
C             The dimension of the descriptor state vector; also the
C             order of square matrices A and E, the number of rows of
C             matrix B, and the number of columns of matrix C.  N >= 0.
C
C     M       (input) INTEGER
C             The dimension of descriptor system input vector; also the
C             number of columns of matrix B.  M >= 0.
C
C     P       (input) INTEGER
C             The dimension of descriptor system output vector; also the
C             number of rows of matrix C.  P >= 0.
C
C     A       (input/output) DOUBLE PRECISION array, dimension (LDA,N)
C             On entry, the leading N-by-N part of this array must
C             contain the N-by-N state matrix A.
C             On exit, the leading N-by-N part of this array contains
C             the transformed state matrix Q'*A*Z,
C
C                                ( Ano  *  )
C                       Q'*A*Z = (         ) ,
C                                ( 0    Ao )
C
C             where Ao is NOBSV-by-NOBSV and Ano is
C             (N-NOBSV)-by-(N-NOBSV).
C             If JOBOBS = 'F', the matrix ( Ao ) is in the observability
C                                         ( Co )
C             staircase form (3).
C             If JOBOBS = 'O' or 'I', the submatrix Ao is upper
C             triangular.
C             If JOBOBS = 'O', the submatrix Ano has the form
C
C                             ( Afno   *  )
C                       Ano = (           ) ,
C                             (  0   Aino )
C
C             where the NIUOBS-by-NIUOBS matrix Aino is nonsingular and
C             upper triangular.
C             If JOBOBS = 'I', Ano is nonsingular and upper triangular.
C
C     LDA     INTEGER
C             The leading dimension of array A.  LDA >= MAX(1,N).
C
C     E       (input/output) DOUBLE PRECISION array, dimension (LDE,N)
C             On entry, the leading N-by-N part of this array must
C             contain the N-by-N descriptor matrix E.
C             On exit, the leading N-by-N part of this array contains
C             the transformed state matrix Q'*E*Z,
C
C                                ( Eno  *  )
C                       Q'*E*Z = (         ) ,
C                                ( 0    Eo )
C
C             where Eo is NOBSV-by-NOBSV and Eno is
C             (N-NOBSV)-by-(N-NOBSV).
C             If JOBOBS = 'O' or 'I', the matrix ( Eo ) is in the
C                                                ( Co )
C             observability staircase form (1).
C             If JOBOBS = 'F', the submatrix Eo is upper triangular.
C             If JOBOBS = 'O', the Eno matrix has the form
C
C                             ( Efno   *  )
C                       Eno = (           ) ,
C                             (  0   Eino )
C
C             where the NIUOBS-by-NIUOBS matrix Eino is nilpotent
C             and the (N-NOBSV-NIUOBS)-by-(N-NOBSV-NIUOBS) matrix Efno
C             is nonsingular and upper triangular.
C             If JOBOBS = 'F', Eno is nonsingular and upper triangular.
C
C     LDE     INTEGER
C             The leading dimension of array E.  LDE >= MAX(1,N).
C
C     B       (input/output) DOUBLE PRECISION array, dimension
C             (LDB,MAX(M,P))
C             On entry, the leading N-by-M part of this array must
C             contain the N-by-M input matrix B.
C             On exit, the leading N-by-M part of this array contains
C             the transformed input matrix Q'*B.
C
C     LDB     INTEGER
C             The leading dimension of array B.
C             LDB >= MAX(1,N) if M > 0 or LDB >= 1 if M = 0.
C
C     C       (input/output) DOUBLE PRECISION array, dimension (LDC,N)
C             On entry, the leading P-by-N part of this array must
C             contain the state/output matrix C.
C             On exit, the leading P-by-N part of this array contains
C             the transformed matrix
C
C                     C*Z = (  0   Co ) ,
C
C             where Co is P-by-NOBSV.
C             If JOBOBS = 'O' or 'I', the matrix ( Eo ) is in the
C                                                ( Co )
C             observability staircase form (1).
C             If JOBOBS = 'F', the matrix ( Ao ) is in the observability
C                                         ( Co )
C             staircase form (3).
C
C     LDC     INTEGER
C             The leading dimension of array C.  LDC >= MAX(1,M,P).
C
C     Q       (input/output) DOUBLE PRECISION array, dimension (LDQ,N)
C             If COMPQ = 'N': Q is not referenced.
C             If COMPQ = 'I': on entry, Q need not be set;
C                             on exit, the leading N-by-N part of this
C                             array contains the orthogonal matrix Q,
C                             where Q' is the product of transformations
C                             which are applied to A, E, and B on
C                             the left.
C             If COMPQ = 'U': on entry, the leading N-by-N part of this
C                             array must contain an orthogonal matrix
C                             Qc;
C                             on exit, the leading N-by-N part of this
C                             array contains the orthogonal matrix
C                             Qc*Q.
C
C     LDQ     INTEGER
C             The leading dimension of array Q.
C             LDQ >= 1,        if COMPQ = 'N';
C             LDQ >= MAX(1,N), if COMPQ = 'U' or 'I'.
C
C     Z       (input/output) DOUBLE PRECISION array, dimension (LDZ,N)
C             If COMPZ = 'N': Z is not referenced.
C             If COMPZ = 'I': on entry, Z need not be set;
C                             on exit, the leading N-by-N part of this
C                             array contains the orthogonal matrix Z,
C                             which is the product of transformations
C                             applied to A, E, and C on the right.
C             If COMPZ = 'U': on entry, the leading N-by-N part of this
C                             array must contain an orthogonal matrix
C                             Zc;
C                             on exit, the leading N-by-N part of this
C                             array contains the orthogonal matrix
C                             Zc*Z.
C
C     LDZ     INTEGER
C             The leading dimension of array Z.
C             LDZ >= 1,        if COMPZ = 'N';
C             LDZ >= MAX(1,N), if COMPZ = 'U' or 'I'.
C
C     NOBSV   (output) INTEGER
C             The order of the reduced matrices Ao and Eo, and the
C             number of columns of reduced matrix Co; also the order of
C             observable part of the pair (C, A-lambda*E).
C
C     NIUOBS  (output) INTEGER
C             For JOBOBS = 'O', the order of the reduced matrices
C             Aino and Eino; also the number of unobservable
C             infinite eigenvalues of the pencil A - lambda*E.
C             For JOBOBS = 'F' or 'I', NIUOBS has no significance
C             and is set to zero.
C
C     NLBLCK  (output) INTEGER
C             For JOBOBS = 'O' or 'I', the number k, of full column rank
C                    _
C             blocks Ei-1,i in the staircase form of the pencil
C             (Eo-lambda*Ao) (see (1) and (2)).
C             (    Co      )
C             For JOBOBS = 'F', the number k, of full column rank blocks
C             _
C             Ai-1,i in the staircase form of the pencil (Ao-lambda*Eo)
C                                                        (     Co     )
C             (see (3) and (4)).
C
C     CTAU    (output) INTEGER array, dimension (N)
C             CTAU(i), for i = 1, ..., NLBLCK, is the column dimension
C                                           _         _
C             of the full column rank block Ei-1,i or Ai-1,i in the
C             staircase form (1) or (3) for JOBOBS = 'O' or 'I', or
C             for JOBOBS = 'F', respectively.
C
C     Tolerances
C
C     TOL     DOUBLE PRECISION
C             The tolerance to be used in rank determinations when
C             transforming (A'-lambda*E',C')'. If the user sets TOL > 0,
C             then the given value of TOL is used as a lower bound for
C             reciprocal condition numbers in rank determinations; a
C             (sub)matrix whose estimated condition number is less than
C             1/TOL is considered to be of full rank.  If the user sets
C             TOL <= 0, then an implicitly computed, default tolerance,
C             defined by  TOLDEF = N*N*EPS,  is used instead, where EPS
C             is the machine precision (see LAPACK Library routine
C             DLAMCH).  TOL < 1.
C
C     Workspace
C
C     IWORK   INTEGER array, dimension (P)
C
C     DWORK   DOUBLE PRECISION array, dimension (MAX(N,2*P))
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
C     METHOD
C
C     The subroutine is based on the dual of the reduction
C     algorithms of [1].
C
C     REFERENCES
C
C     [1] A. Varga
C         Computation of Irreducible Generalized State-Space
C         Realizations.
C         Kybernetika, vol. 26, pp. 89-106, 1990.
C
C     NUMERICAL ASPECTS
C
C     The algorithm is numerically backward stable and requires
C     0( N**3 )  floating point operations.
C
C     FURTHER COMMENTS
C
C     If the system matrices A, E and C are badly scaled, it is
C     generally recommendable to scale them with the SLICOT routine
C     TG01AD, before calling TG01ID.
C
C     CONTRIBUTOR
C
C     A. Varga, German Aerospace Center, DLR Oberpfaffenhofen.
C     March 1999. Based on the RASP routine RPDSCF.
C
C     REVISIONS
C
C     July 1999, V. Sima, Research Institute for Informatics, Bucharest.
C     May 2003, March 2004, V. Sima.
C
C     KEYWORDS
C
C     Observability, minimal realization, orthogonal canonical form,
C     orthogonal transformation.
C
C     ******************************************************************
C
C     .. Parameters ..
      DOUBLE PRECISION   ONE
      PARAMETER          ( ONE = 1.0D0 )
C     .. Scalar Arguments ..
      CHARACTER          COMPQ, COMPZ, JOBOBS
      INTEGER            INFO, LDA, LDB, LDC, LDE, LDQ, LDZ,
     $                   M, N, NIUOBS, NLBLCK, NOBSV, P
      DOUBLE PRECISION   TOL
C     .. Array Arguments ..
      INTEGER            CTAU( * ), IWORK( * )
      DOUBLE PRECISION   A( LDA, * ), B( LDB, * ), C( LDC, *  ),
     $                   DWORK( * ), E( LDE, * ), Q( LDQ, * ),
     $                   Z( LDZ, * )
C     .. Local Scalars ..
      CHARACTER          JOBQ, JOBZ
      LOGICAL            FINOBS, ILQ, ILZ, INFOBS
      INTEGER            I, ICOMPQ, ICOMPZ, LBA, LBE, NR
C     .. Local Arrays ..
      DOUBLE PRECISION   DUM(1)
C     .. External Functions ..
      LOGICAL            LSAME
      EXTERNAL           LSAME
C     .. External Subroutines ..
      EXTERNAL           AB07MD, DSWAP, MA02BD, MA02CD, TB01XD,
     $                   TG01HX, XERBLA
C     .. Intrinsic Functions ..
      INTRINSIC          MAX
C
C     .. Executable Statements ..
C
C     Decode JOBOBS.
C
      IF( LSAME( JOBOBS, 'O') ) THEN
         FINOBS = .TRUE.
         INFOBS = .TRUE.
      ELSE IF( LSAME( JOBOBS, 'F') ) THEN
         FINOBS = .TRUE.
         INFOBS = .FALSE.
      ELSE IF( LSAME( JOBOBS, 'I') ) THEN
         FINOBS = .FALSE.
         INFOBS = .TRUE.
      ELSE
         FINOBS = .FALSE.
         INFOBS = .FALSE.
      END IF
C
C     Decode COMPQ.
C
      IF( LSAME( COMPQ, 'N' ) ) THEN
         ILQ = .FALSE.
         ICOMPQ = 1
      ELSE IF( LSAME( COMPQ, 'U' ) ) THEN
         ILQ = .TRUE.
         ICOMPQ = 2
      ELSE IF( LSAME( COMPQ, 'I' ) ) THEN
         ILQ = .TRUE.
         ICOMPQ = 3
      ELSE
         ICOMPQ = 0
      END IF
C
C     Decode COMPZ.
C
      IF( LSAME( COMPZ, 'N' ) ) THEN
         ILZ = .FALSE.
         ICOMPZ = 1
      ELSE IF( LSAME( COMPZ, 'U' ) ) THEN
         ILZ = .TRUE.
         ICOMPZ = 2
      ELSE IF( LSAME( COMPZ, 'I' ) ) THEN
         ILZ = .TRUE.
         ICOMPZ = 3
      ELSE
         ICOMPZ = 0
      END IF
C
C     Test the input scalar parameters.
C
      INFO = 0
      IF( .NOT.FINOBS .AND. .NOT.INFOBS ) THEN
         INFO = -1
      ELSE IF( ICOMPQ.LE.0 ) THEN
         INFO = -2
      ELSE IF( ICOMPZ.LE.0 ) THEN
         INFO = -3
      ELSE IF( N.LT.0 ) THEN
         INFO = -4
      ELSE IF( M.LT.0 ) THEN
         INFO = -5
      ELSE IF( P.LT.0 ) THEN
         INFO = -6
      ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
         INFO = -8
      ELSE IF( LDE.LT.MAX( 1, N ) ) THEN
         INFO = -10
      ELSE IF( LDB.LT.1 .OR. ( M.GT.0 .AND. LDB.LT.N ) ) THEN
         INFO = -12
      ELSE IF( LDC.LT.MAX( 1, M, P ) ) THEN
         INFO = -14
      ELSE IF( ( ILQ .AND. LDQ.LT.N ) .OR. LDQ.LT.1 ) THEN
         INFO = -16
      ELSE IF( ( ILZ .AND. LDZ.LT.N ) .OR. LDZ.LT.1 ) THEN
         INFO = -18
      ELSE IF( TOL.GE.ONE ) THEN
         INFO = -23
      END IF
      IF( INFO.NE.0 ) THEN
         CALL XERBLA( 'TG01ID', -INFO )
         RETURN
      END IF
C
      JOBQ = COMPQ
      JOBZ = COMPZ
C
C     Build the dual system.
C
      CALL AB07MD( 'Z', N, M, P, A, LDA, B, LDB, C, LDC, DUM, 1,
     $             INFO )
      DO 10 I = 2, N
         CALL DSWAP( I-1, E(I,1), LDE, E(1,I), 1 )
   10 CONTINUE
C
      IF( FINOBS ) THEN
C
C        Perform finite observability form reduction.
C
         CALL TG01HX( JOBZ, JOBQ, N, N, P, M, N, MAX( 0, N-1 ), A, LDA,
     $                E, LDE, B, LDB, C, LDC, Z, LDZ, Q, LDQ, NR,
     $                NLBLCK, CTAU, TOL, IWORK, DWORK, INFO )
         IF( NLBLCK.GT.1 ) THEN
            LBA = CTAU(1) + CTAU(2) - 1
         ELSE IF( NLBLCK.EQ.1 ) THEN
            LBA = CTAU(1) - 1
         ELSE
            LBA = 0
         END IF
         IF( ILQ ) JOBQ = 'U'
         IF( ILZ ) JOBZ = 'U'
         LBE = 0
      ELSE
         NR = N
         LBA = MAX( 0, N-1 )
         LBE = LBA
      END IF
C
      IF( INFOBS ) THEN
C
C        Perform infinite observability form reduction.
C
         CALL TG01HX( JOBZ, JOBQ, N, N, P, M, NR, LBA, E, LDE,
     $                A, LDA, B, LDB, C, LDC, Z, LDZ, Q, LDQ, NOBSV,
     $                NLBLCK, CTAU, TOL, IWORK, DWORK, INFO )
         IF( FINOBS ) THEN
            NIUOBS = NR - NOBSV
         ELSE
            NIUOBS = 0
         END IF
         IF( NLBLCK.GT.1 ) THEN
            LBE = CTAU(1) + CTAU(2) - 1
         ELSE IF( NLBLCK.EQ.1 ) THEN
            LBE = CTAU(1) - 1
         ELSE
            LBE = 0
         END IF
         LBA = 0
      ELSE
         NOBSV = NR
         NIUOBS = 0
      END IF
C
C     Compute the pertransposed dual system exploiting matrix shapes.
C
      LBA = MAX( LBA, NIUOBS-1, N-NOBSV-NIUOBS-1 )
      IF ( P.EQ.0 .OR. NR.EQ.0 )
     $   LBE = MAX( 0, N - 1 )
      CALL TB01XD( 'Z', N, P, M, LBA, MAX( 0, N-1 ), A, LDA, B, LDB,
     $             C, LDC, DUM, 1, INFO )
      CALL MA02CD( N, LBE, MAX( 0, N-1 ), E, LDE )
      IF( ILZ ) CALL MA02BD( 'Right', N, N, Z, LDZ )
      IF( ILQ ) CALL MA02BD( 'Right', N, N, Q, LDQ )
      RETURN
C *** Last line of TG01ID ***
      END


subroutine getfsq(gcr, gcz, gnormr, gnormz, gnorm, mprecon)

      use stel_kinds, only: dp
      use name0, only: czero
      use name1, only: mnd1
      use scalars, only: ns

      implicit none

      real(kind=dp), intent(in)  :: gcr(ns,0:mnd1,2)
      real(kind=dp), intent(in)  :: gcz(ns,0:mnd1,2)
      real(kind=dp), intent(out) :: gnormr
      real(kind=dp), intent(out) :: gnormz
      real(kind=dp), intent(in)  :: gnorm
      integer,       intent(in)  :: mprecon

      integer :: jsmax, mn, js

      gnormr = czero
      gnormz = czero

      jsmax = (ns-1) + mprecon
      do mn = 0, mnd1
        do js = 1, jsmax
          gnormr = gnormr + gnorm * (gcr(js,mn,1)**2 + gcr(js,mn,2)**2)
          gnormz = gnormz + gnorm * (gcz(js,mn,1)**2 + gcz(js,mn,2)**2)
        end do
      end do

      return
end


program Maxwell_3D
   implicit none
   integer, parameter :: NX = 256
   integer, parameter :: NY = 256
   integer, parameter :: NZ = 256

   real, parameter :: C2 = 2.997924562d8 * 2.997924562d8
   real, parameter :: PI = 3.14159265358979323846
   real, parameter :: MU = 4.000d-7 * PI

   real, parameter :: dx = 1.0
   real, parameter :: dy = 1.0
   real, parameter :: dz = 1.0

   real, dimension(NX,NY,NZ) :: Bx, By, Bz
   real, dimension(NX,NY,NZ) :: Ex, Ey, Ez
   real, dimension(NX,NY,NZ) :: Jx, Jy, Jz

   real :: dt = 1.0d-3
   integer :: it, nt = 1

   print *, "initializing ..."
   call start_clock()
   call initialize()
   call stop_clock()

   do it = 1, nt
      print *, "running timestep ", it, " ..."
      call start_clock()
      call solve(dt)
      call stop_clock()
   end do

   stop

contains

subroutine solve(dt)
   real, intent(in) :: dt

   !--------------------------------------------------------------------
   !           Magnetic Fields (Bx,By,Bz)
   !--------------------------------------------------------------------

   Bx = Bx + dt * (cshift(Ey,dim=3,shift=+1) - Ey) / dz                &
           - dt * (cshift(Ez,dim=2,shift=+1) - Ez) / dy

   By = By + dt * (cshift(Ez,dim=1,shift=+1) - Ez) / dx                &
           - dt * (cshift(Ex,dim=3,shift=+1) - Ex) / dz

   Bz = Bz + dt * (cshift(Ex,dim=2,shift=+1) - Ex) / dy                &
           - dt * (cshift(Ey,dim=1,shift=+1) - Ey) / dx

   !--------------------------------------------------------------------
   !           Electric Fields (Bx,By,Bz)
   !--------------------------------------------------------------------

   Ex = Ex + (C2 * dt) * (Bz - cshift(Bz,dim=2,shift=-1)) / dy         &
           - (C2 * dt) * (By - cshift(By,dim=3,shift=-1)) / dz         &
           - (C2 * dt) * (MU * Jx)

   Ey = Ey + (C2 * dt) * (Bx - cshift(Bx,dim=3,shift=-1)) / dz         &
           - (C2 * dt) * (Bz - cshift(Bz,dim=1,shift=-1)) / dx         &
           - (C2 * dt) * (MU * Jy)

   Ez = Ez + (C2 * dt) * (By - cshift(By,dim=1,shift=-1)) / dx         &
           - (C2 * dt) * (Bx - cshift(Bx,dim=2,shift=-1)) / dy         &
           - (C2 * dt) * (MU * Jz)

end subroutine solve

!
! TODO try to make initial conditions reasonable
!
subroutine initialize()
   Bx = 1.
   By = 0.0
   Bz = 0.0

   Ex = 0.0
   Ey = 0.0
   Ez = 0.0

   Jx = 3.0e-9
   Jy = 0.0
   Jz = 0.0
end subroutine initialize

end program Maxwell_3D


!**********************************************************************************************************************************
!
!  Name        : RTB
!  Language    : Fortran 90
!
!  Description : 制限三体問題のゼロ速度曲線を描く
!
!
!  Input
!    Arguments   a  : 中心星と惑星の距離
!                nu : 質量比
!    Terminal  : none
!    File      : none
!
!  Output
!    Arguments : none
!    Terminal  : none
!    File      : out.dat, out1.dat-out7.dat
!
!  Invocation  : none
!
!  Notes       : none
!**********************************************************************************************************************************

PROGRAM RTB
  IMPLICIT NONE

  ! Constants
  REAL                       :: nu                   ! m2/(m1+m2)

  ! Internal
  DOUBLE PRECISION :: r1,r2     ! 中心星(惑星)からポテンシャルを求める座標までの距離
  DOUBLE PRECISION :: x         ! 位置座標
  DOUBLE PRECISION :: u         ! 回転座標系でのポテンシャル
  INTEGER          :: i,j,num
  ! Dimension
  DOUBLE PRECISION,DIMENSION(4000,2) :: S = 0D0

  write(*,*) "m1/(m1+m2)"
  read(*,*) nu

  num=0
  do i = 1,4000
    num = num + 1
    x = -2.00D0 + 0.001D0*i
    r1 = abs(x + nu)
    r2 = abs(x - (1-nu))
    u = ( (1-nu)/r1 + nu/r2 + 0.5*(x**2) )
    S(num,1) = x
    S(num,2) = u
  end do

  num=0
  open(10, file="out.dat", status="unknown")
  do num=1,4000
    write(10,*) S(num,1),S(num,2)
  end do
  close(10)

END PROGRAM


      subroutine crosscorr (ishift,rxy,xcross,ycross,npx)
c******************************************************************************
c     This routine determines the correlation of array 'x' and array 'y',
c     comparing array elements 'i' in 'x' with elements 'i+ishift';
c     the number of points in each array is assumed to be equal.
c******************************************************************************

      implicit real*8 (a-h,o-z)
      real*4 xcross(100000),ycross(100000)
      real*8 xsum,ysum,xysum,x2sum,y2sum,covar,varx,vary
      real*8 xx,yy

      xsum = 0.
      ysum = 0.
      xysum = 0.
      x2sum = 0.
      y2sum = 0.
      if (ishift .ge. 0) then
         minpt = 1
         maxpt = npx - ishift
      else
         minpt = iabs(ishift) + 1
         maxpt = npx
      endif

      do 10 i=minpt,maxpt
         xx = xcross(i)
         yy = ycross(i+ishift)
         xsum = xsum + xx
         ysum = ysum + yy
         xysum = xysum + xx*yy
         x2sum = x2sum + xx*xx
10       y2sum = y2sum + yy*yy

      xn = real(maxpt - minpt + 1)
      covar = xn*xysum - xsum*ysum
      varx = dsqrt(xn*x2sum - xsum*xsum)
      vary = dsqrt(xn*y2sum - ysum*ysum)
      rxy = sngl(covar/(varx*vary))

      return
      end