      double complex function C0fa2m(t,qsq,msq)
C     C0(Pc,Pg,0,msq,msq)=
C     C0(tsq,0,qsq,0,msq,msq) (LT notation)
C     result for qsq<0,t<0 is
C     C0fa2m(t,qsq,msq)=(Li2(qsq/msq)-Li2(t/msq))/(t-qsq)

      implicit none
      include 'constants.f'
      double precision t,qsq,msq,r,omr,ddilog
      double complex lnrat,wlog,dilogt,dilogq

      r=1d0-qsq/msq
      omr=qsq/msq
      wlog=lnrat(msq-qsq,msq)
      if (omr .gt. one) then
         dilogq=dcmplx(pisqo6-ddilog(r))-wlog*dcmplx(log(omr))
      else
         dilogq=dcmplx(ddilog(omr))
      endif

      r=1d0-t/msq
      omr=t/msq
      wlog=lnrat(msq-t,msq)
      if (omr .gt. one) then
         dilogt=dcmplx(pisqo6-ddilog(r))-wlog*dcmplx(log(omr))
      else
         dilogt=dcmplx(ddilog(omr))
      endif
      C0fa2m=(dilogq-dilogt)/(t-qsq)
      return
      end


program test
  real(8) a
  write(*,*) tiny(a), huge(a), sqrt(2.0d0)
end program test


C NCLFORTSTART
      subroutine patcor1 (mlon,nlat,ntim,x,y,xmsg,ymsg,w, r, ier)

c compute the anomaly correlation: 1-dimensional weight array

c nomenclature:
c INPUT
c .    mlon, nlat  - dimension sizes
c .    x,y         - arrays/grids
c .    xmsg,ymsg   - missing codes [if none set to some value]
c .    w           - contains weights specified by user [eg: gaussian wgts]
c OUTPUT
c .    r           - anomaly (pattern) correlation
c .    ier         - error code
c .                  =0  no errors
c .                  =1  x or y contains all msg values
c .                  =2  x or y contains all constant values
c
      implicit none
c                                               !  INPUT
      integer  mlon, nlat, ntim, ier
      double precision x(mlon,nlat,ntim), y(mlon,nlat,ntim)
     $               , w(nlat), xmsg, ymsg
c                                               !  OUTPUT
      double precision r(ntim)
C NCLEND
c                                               !  LOCAL
      integer ml, nl, nt
      double precision xave , yave , wsum
      double precision xycov, xanom2, yanom2

      ier    = 0

      do nt=1,ntim

c wgted area mean

         xave = 0.0d0
         yave = 0.0d0
         wsum = 0.0d0
         do nl=1,nlat
           do ml=1,mlon
              if (x(ml,nl,nt).ne.xmsg .and. y(ml,nl,nt).ne.ymsg) then
                  xave = xave + w(nl)*x(ml,nl,nt)
                  yave = yave + w(nl)*y(ml,nl,nt)
                  wsum = wsum + w(nl)
              end if
           end do
         end do

c all missing?

         if (wsum.eq.0.0d0) then
             ier = 1
             r   = xmsg
             return
         end if

         xave = xave/wsum
         yave = yave/wsum

c covariance and anomalies

         xycov  = 0.0d0
         xanom2 = 0.0d0
         yanom2 = 0.0d0

         do nl=1,nlat
           do ml=1,mlon
              if (x(ml,nl,nt).ne.xmsg .and. y(ml,nl,nt).ne.ymsg) then
                  xycov  = xycov  + w(nl)*(x(ml,nl,nt)-xave)
     &                                   *(y(ml,nl,nt)-yave)
                  xanom2 = xanom2 + w(nl)*(x(ml,nl,nt)-xave)**2
                  yanom2 = yanom2 + w(nl)*(y(ml,nl,nt)-yave)**2
              end if
           end do
         end do

         if (xanom2.gt.0.0d0 .and. yanom2.gt.0.0d0) then
             r(nt)   = xycov/(sqrt(xanom2)*sqrt(yanom2))
         else
             ier = 2
             r(nt)   = xmsg
         end if

      end do

      return
      end
c ======================================================
C NCLFORTSTART
      subroutine patcor2 (mlon,nlat,ntim,x,y,xmsg,ymsg,w, r, ier)

c compute the anomaly correlation: 2-dimensional weight array

c nomenclature:
c INPUT
c .    mlon, nlat  - dimension sizes
c .    x,y         - arrays/grids
c .    xmsg,ymsg   - missing codes [if none set to some value]
c .    w           - contains weights specified by user [eg: POP area]
c OUTPUT
c .    r           - anomaly (pattern) correlation
c .    ier         - error code
c .                  =0  no errors
c .                  =1  x or y contains all msg values
c .                  =2  x or y contains all constant values
c
      implicit none
c                                               !  INPUT
      integer  mlon, nlat, ntim, ier
      double precision x(mlon,nlat,ntim), y(mlon,nlat,ntim),w(mlon,nlat)
     $               , xmsg, ymsg
c                                               !  OUTPUT
      double precision r
C NCLEND
c                                               !  LOCAL
      integer ml, nl, nt
      double precision xave , yave , wsum
      double precision xycov, xanom2, yanom2

      ier    = 0

      do nt=1,ntim

c wgted area mean

         xave = 0.0d0
         yave = 0.0d0
         wsum = 0.0d0
         do nl=1,nlat
           do ml=1,mlon
              if (x(ml,nl,nt).ne.xmsg .and. y(ml,nl,nt).ne.ymsg) then
                  xave = xave + w(ml,nl)*x(ml,nl,nt)
                  yave = yave + w(ml,nl)*y(ml,nl,nt)
                  wsum = wsum + w(ml,nl)
              end if
           end do
         end do

c all missing?

         if (wsum.eq.0.0d0) then
             ier = 1
             r   = xmsg
             return
         end if

         xave = xave/wsum
         yave = yave/wsum

c covariance and anomalies

         xycov  = 0.0d0
         xanom2 = 0.0d0
         yanom2 = 0.0d0

         do nl=1,nlat
           do ml=1,mlon
              if (x(ml,nl,nt).ne.xmsg .and. y(ml,nl,nt).ne.ymsg) then
                  xycov  = xycov  +w(ml,nl)*(x(ml,nl,nt)-xave)
     $                                     *(y(ml,nl,nt)-yave)
                  xanom2 = xanom2 +w(ml,nl)*(x(ml,nl,nt)-xave)**2
                  yanom2 = yanom2 +w(ml,nl)*(y(ml,nl,nt)-yave)**2
              end if
           end do
         end do

         if (xanom2.gt.0.0d0 .and. yanom2.gt.0.0d0) then
             r   = xycov/(sqrt(xanom2)*sqrt(yanom2))
         else
             ier = 2
             r   = xmsg
         end if

      end do

      return
      end


module mydefs

!    integer, parameter :: rk = selected_real_kind(15,307)
    integer, parameter :: sp =kind(1.0)
    integer, parameter :: dp = selected_real_kind(2*precision(1.0_sp))
    integer, parameter :: rk =selected_real_kind(2*precision(1.0_dp))
    integer, parameter :: ik = selected_int_kind(5)
    integer, parameter :: iw1=15, iw2=16, iw3=17, iw4=18
    real(rk), parameter :: pi = 3.141592653589793238462643383279502884197_rk
!    integer, parameter :: maxatoms=3, maxmodes=3, step=50
    real(rk), parameter :: autoaa = 0.52917721092_rk!, ssize = 0.05000_rk

end module mydefs


C$Procedure      CGV2EL ( Center and generating vectors to ellipse )

      SUBROUTINE CGV2EL ( CENTER, VEC1, VEC2, ELLIPS )

C$ Abstract
C
C     Form a SPICELIB ellipse from a center vector and two generating
C     vectors.
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     ELLIPSES
C
C$ Keywords
C
C     ELLIPSE
C     GEOMETRY
C
C$ Declarations

      INTEGER               UBEL
      PARAMETER           ( UBEL    =   9 )

      DOUBLE PRECISION      CENTER (    3 )
      DOUBLE PRECISION      VEC1   (    3 )
      DOUBLE PRECISION      VEC2   (    3 )
      DOUBLE PRECISION      ELLIPS ( UBEL )

C$ Brief_I/O
C
C     Variable  I/O  Description
C     --------  ---  --------------------------------------------------
C     CENTER,
C     VEC1,
C     VEC2       I   Center and two generating vectors for an ellipse.
C     ELLIPS     O   The SPICELIB ellipse defined by the input vectors.
C
C$ Detailed_Input
C
C     CENTER,
C     VEC1,
C     VEC2           are a center and two generating vectors defining
C                    an ellipse in three-dimensional space.  The
C                    ellipse is the set of points
C
C                       CENTER  +  cos(theta) VEC1  +  sin(theta) VEC2
C
C                    where theta ranges over the interval (-pi, pi].
C                    VEC1 and VEC2 need not be linearly independent.
C
C$ Detailed_Output
C
C     ELLIPS         is the SPICELIB ellipse defined by the input
C                    vectors.
C
C$ Parameters
C
C     None.
C
C$ Exceptions
C
C     1)  If VEC1 and VEC2 are linearly dependent, ELLIPS will be
C         degenerate.  SPICELIB ellipses are allowed to represent
C         degenerate geometric ellipses.
C
C$ Files
C
C     None.
C
C$ Particulars
C
C     SPICELIB ellipses serve to simplify calling sequences and reduce
C     the chance for error in declaring and describing argument lists
C     involving ellipses.
C
C     The set of ellipse conversion routines is
C
C        CGV2EL ( Center and generating vectors to ellipse )
C        EL2CGV ( Ellipse to center and generating vectors )
C
C$ Examples
C
C     1)  Find the intersecton of an ellipse with a plane.  The ellipse
C         is defined by the vectors CENTER, VEC1, and VEC2.  The plane
C         is defined by the normal vector N and the constant C.
C
C            C
C            C    Make a SPICELIB ellipse.  Make a plane while
C            C    we're at it.
C            C
C                 CALL CGV2EL ( CENTER, VEC1, VEC2,  ELLIPS  )
C                 CALL NVC2PL ( N,      C,           PLANE   )
C
C            C
C            C    Find the intersection of the ellipse and plane.
C            C    NXPTS is the number of intersection points; XPT1
C            C    and XPT2 are the points themselves.
C            C
C                 CALL INELPL ( ELLIPS, PLANE, NXPTS, XPT1, XPT2 )
C
C
C$ Restrictions
C
C     None.
C
C$ Literature_References
C
C     None.
C
C$ Author_and_Institution
C
C     N.J. Bachman   (JPL)
C
C$ Version
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, 02-NOV-1990 (NJB)
C
C-&

C$ Index_Entries
C
C     center and generating vectors to ellipse
C
C-&

C
C     SPICELIB functions
C
      LOGICAL               RETURN

C
C     Local parameters
C

C
C     SPICELIB ellipses contain a center vector, a semi-major
C     axis vector, and a semi-minor axis vector.  These are
C     located, respectively, in elements
C
C        CTRPOS through CTRPOS + 1
C
C        MAJPOS through MAJPOS + 1
C
C        MINPOS through MINPOS + 1
C
C
      INTEGER               CTRPOS
      PARAMETER           ( CTRPOS = 1 )

      INTEGER               MAJPOS
      PARAMETER           ( MAJPOS = 4 )

      INTEGER               MINPOS
      PARAMETER           ( MINPOS = 7 )

C
C     Standard SPICE error handling.
C
      IF ( RETURN () ) THEN
         RETURN
      ELSE
         CALL CHKIN ( 'CGV2EL' )
      END IF

C
C     The center of the ellipse is held in the first three elements.
C
      CALL VEQU ( CENTER, ELLIPS(CTRPOS) )

C
C     Find the semi-axes of the ellipse.  These may be degenerate.
C
      CALL SAELGV ( VEC1, VEC2, ELLIPS(MAJPOS), ELLIPS(MINPOS) )

      CALL CHKOUT ( 'CGV2EL' )
      RETURN
      END


module actual_conductivity_module

  use amrex_fort_module, only : rt => amrex_real
  use eos_type_module, only : eos_t
  use fundamental_constants_module

  implicit none

contains

  subroutine actual_conductivity_init()

    implicit none

  end subroutine actual_conductivity_init

  subroutine actual_conductivity(eos_state, therm_cond)

    use extern_probin_module, only: const_opacity

    type (eos_t), intent(in) :: eos_state
    real (kind=rt), intent(inout) :: therm_cond

    therm_cond = (16*sigma_SB*(eos_state%T)**3)/(3*const_opacity*eos_state%rho)

  end subroutine actual_conductivity

end module actual_conductivity_module


      SUBROUTINE MB03BC( K, AMAP, S, SINV, A, LDA1, LDA2, MACPAR, CV,
     $                   SV, DWORK )
C
C     SLICOT RELEASE 5.7.
C
C     Copyright (c) 2002-2020 NICONET e.V.
C
C     PURPOSE
C
C     To compute the product singular value decomposition of the K-1
C     triangular factors corresponding to a 2-by-2 product of K
C     factors in upper Hessenberg-triangular form.
C     For a general product of 2-by-2 triangular matrices
C
C                        S(2)        S(3)            S(K)
C            A = A(:,:,2)    A(:,:,3)    ... A(:,:,K),
C
C     Givens rotations are computed so that
C                                                          S(i)
C       [  CV(i-1) SV(i-1) ] [ A(1,1,i)(in)  A(1,2,i)(in) ]
C       [ -SV(i-1) CV(i-1) ] [     0         A(2,2,i)(in) ]
C                                      S(i)
C       [ A(1,1,i)(out) A(1,2,i)(out) ]    [  CV(i) SV(i) ]
C     = [     0         A(2,2,i)(out) ]    [ -SV(i) CV(i) ]
C
C     stays upper triangular and
C
C       [  CV(1) SV(1) ]       [ CV(K) -SV(K) ]
C       [ -SV(1) CV(1) ] * A * [ SV(K)  CV(K) ]
C
C     is diagonal.
C
C     ARGUMENTS
C
C     Input/Output Parameters
C
C     K       (input)  INTEGER
C             The number of factors.  K >= 1.
C
C     AMAP    (input) INTEGER array, dimension (K)
C             The map for accessing the factors, i.e., if AMAP(I) = J,
C             then the factor A_I is stored at the J-th position in A.
C
C     S       (input)  INTEGER array, dimension (K)
C             The signature array. Each entry of S must be 1 or -1.
C
C     SINV    (input) INTEGER
C             Signature multiplier. Entries of S are virtually
C             multiplied by SINV.
C
C     A       (input/output)  DOUBLE PRECISION array, dimension
C                             (LDA1,LDA2,K)
C             On entry, the leading 2-by-2-by-K part of this array must
C             contain a 2-by-2 product (implicitly represented by its K
C             factors) in upper Hessenberg-triangular form.
C             On exit, the leading 2-by-2-by-K part of this array
C             contains modified triangular factors such that their
C             product is diagonal.
C
C     LDA1    INTEGER
C             The first leading dimension of the array A.  LDA1 >= 2.
C
C     LDA2    INTEGER
C             The second leading dimension of the array A.  LDA2 >= 2.
C
C     MACPAR  (input)  DOUBLE PRECISION array, dimension (5)
C             Machine parameters:
C             MACPAR(1)  overflow threshold,         DLAMCH( 'O' );
C             MACPAR(2)  underflow threshold,        DLAMCH( 'U' );
C             MACPAR(3)  safe minimum,               DLAMCH( 'S' );
C             MACPAR(4)  relative machine precision, DLAMCH( 'E' );
C             MACPAR(5)  base of the machine,        DLAMCH( 'B' ).
C
C     CV      (output)  DOUBLE PRECISION array, dimension (K)
C             On exit, the first K elements of this array contain the
C             cosines of the Givens rotations.
C
C     SV      (output)  DOUBLE PRECISION array, dimension (K)
C             On exit, the first K elements of this array contain the
C             sines of the Givens rotations.
C
C     Workspace
C
C     DWORK   DOUBLE PRECISION array, dimension (3*(K-1))
C
C     METHOD
C
C     The product singular value decomposition of the K-1
C     triangular factors are computed as described in [1].
C
C     REFERENCES
C
C     [1] Bojanczyk, A. and Van Dooren, P.
C         On propagating orthogonal transformations in a product of 2x2
C         triangular matrices.
C         In Reichel, Ruttan and Varga: 'Numerical Linear Algebra',
C         pp. 1-9, 1993.
C
C     CONTRIBUTOR
C
C     D. Kressner, Technical Univ. Berlin, Germany, June 2001.
C
C     REVISIONS
C
C     V. Sima, Research Institute for Informatics, Bucharest, Romania,
C     July 2009, SLICOT Library version of the routine PLAPST.
C     V. Sima, Nov. 2010, Aug. 2011.
C
C     KEYWORDS
C
C     Eigenvalues, orthogonal transformation, singular values,
C     singular value decomposition.
C
C     ******************************************************************
C
C     .. Parameters ..
      DOUBLE PRECISION  ZERO, ONE, HALF, TWO
      PARAMETER         ( ZERO = 0.0D0, ONE = 1.0D0, HALF = 0.5D0,
     $                    TWO = 2.0D0 )
C     .. Scalar Arguments ..
      INTEGER           K, LDA1, LDA2, SINV
C     .. Array Arguments ..
      INTEGER           AMAP(*), S(*)
      DOUBLE PRECISION  A(LDA1,LDA2,*), CV(*), DWORK(*), MACPAR(*),
     $                  SV(*)
C     .. Local Scalars ..
      INTEGER           AI, I, PW, SCL
      DOUBLE PRECISION  A11, A12, A22, B11, B12, B22, BASE, CC, CL, CR,
     $                  EPS, MX, MX2, RMAX, RMIN, RMNS, RMXS, S11, S22,
     $                  SC, SFMN, SL, SR, SSMAX, SSMIN, T11, T12, T22,
     $                  TEMP, TWOS
C     .. External Subroutines ..
      EXTERNAL          DLARTG, DLASV2
C     .. Intrinsic Functions ..
      INTRINSIC         ABS, MAX, SQRT
C
C     .. Executable Statements ..
C
      RMAX = MACPAR(1)
      RMXS = SQRT( RMAX )
      RMIN = MACPAR(2)
      RMNS = SQRT( RMIN )
      SFMN = MACPAR(3)
      EPS  = MACPAR(4)
      BASE = MACPAR(5)
      TWOS = SQRT( TWO )
C
C     Compute the product of the 2-by-2 triangular matrices.
C
      PW  = 1
      T11 = ONE
      T12 = ZERO
      T22 = ONE
C
      DO 60  I = 2, K
         AI  = AMAP(I)
         A11 = A(1,1,AI)
         A12 = A(1,2,AI)
         A22 = A(2,2,AI)
         IF ( S(AI).NE.SINV ) THEN
            TEMP =  A11
            A11  =  A22
            A22  =  TEMP
            A12  = -A12
         END IF
C
C        A and T are scaled so that the elements of the resulting
C        product do not overflow.
C
         MX  = ABS( A11 ) / RMXS
         MX2 = ABS( T11 ) / RMXS
   10    CONTINUE
         IF ( MX*MX2.GE.ONE ) THEN
            IF (  MX.GE.ONE ) THEN
               MX  =  MX / BASE
               A11 = A11 / BASE
               A22 = A22 / BASE
               A12 = A12 / BASE
            END IF
            IF ( MX2.GE.ONE ) THEN
               MX2 = MX2 / BASE
               T11 = T11 / BASE
               T22 = T22 / BASE
               T12 = T12 / BASE
            END IF
            GOTO 10
         END IF
C
         MX  = ABS( A22 ) / RMXS
         MX2 = ABS( T22 ) / RMXS
   20    CONTINUE
         IF ( MX*MX2.GE.ONE ) THEN
            IF (  MX.GE.ONE ) THEN
               MX  = MX  / BASE
               A11 = A11 / BASE
               A22 = A22 / BASE
               A12 = A12 / BASE
            END IF
            IF ( MX2.GE.ONE ) THEN
               MX2 = MX2 / BASE
               T11 = T11 / BASE
               T22 = T22 / BASE
               T12 = T12 / BASE
            END IF
            GOTO 20
         END IF
C
         MX  = ABS( A12 ) / RMXS
         MX2 = ABS( T11 ) / RMXS
   30    CONTINUE
         IF ( MX*MX2.GE.HALF ) THEN
            IF (  MX.GE.HALF ) THEN
               MX  = MX  / BASE
               A11 = A11 / BASE
               A22 = A22 / BASE
               A12 = A12 / BASE
            END IF
            IF ( MX2.GE.HALF ) THEN
               MX2 = MX2 / BASE
               T11 = T11 / BASE
               T22 = T22 / BASE
               T12 = T12 / BASE
            END IF
            GOTO 30
         END IF
C
         MX  = ABS( A22 ) / RMXS
         MX2 = ABS( T12 ) / RMXS
   40    CONTINUE
         IF ( MX*MX2.GE.HALF ) THEN
            IF (  MX.GE.HALF ) THEN
               MX  = MX  / BASE
               A11 = A11 / BASE
               A22 = A22 / BASE
               A12 = A12 / BASE
            END IF
            IF ( MX2.GE.HALF ) THEN
               MX2 = MX2 / BASE
               T11 = T11 / BASE
               T22 = T22 / BASE
               T12 = T12 / BASE
            END IF
            GOTO 40
         END IF
C
C        Avoid underflow if possible.
C
         MX  = MAX( ABS( A11 ), ABS( A22 ), ABS( A12 ) )
         MX2 = MAX( ABS( T11 ), ABS( T22 ), ABS( T12 ) )
         IF ( MX.NE.ZERO .AND. MX2.NE.ZERO ) THEN
   50       CONTINUE
            IF ( ( MX.LE.( ONE/RMNS ) .AND. MX2.LE.RMNS ) .OR.
     $           ( MX.LE.RMNS .AND. MX2.LE.( ONE/RMNS ) ) )
     $      THEN
               IF ( MX.LE.MX2 ) THEN
                  MX  = MX  * BASE
                  A11 = A11 * BASE
                  A22 = A22 * BASE
                  A12 = A12 * BASE
               ELSE
                  MX2 = MX2 * BASE
                  T11 = T11 * BASE
                  T22 = T22 * BASE
                  T12 = T12 * BASE
               END IF
               GOTO 50
            END IF
         END IF
         T12 = T11 * A12 + T12 * A22
         T11 = T11 * A11
         T22 = T22 * A22
         IF ( I.LT.K ) THEN
            DWORK(PW)   = T11
            DWORK(PW+1) = T12
            DWORK(PW+2) = T22
            PW = PW + 3
         END IF
   60 CONTINUE
C
C     Compute the SVD of this product avoiding unnecessary
C     overflow/underflow in the singular values.
C
      TEMP = MAX( ABS( T11 / TWO ) + ABS( T12 / TWO ),
     $            ABS( T22 / TWO ) )
      IF ( TEMP.GT.( RMAX/( TWO * TWOS ) ) ) THEN
         TEMP = TEMP / BASE
         T11  =  T11 / BASE
         T12  =  T12 / BASE
         T22  =  T22 / BASE
      END IF
   70 CONTINUE
      IF ( TEMP.LT.( RMAX/( TWO * BASE * TWOS ) ) .AND.
     $     T11.NE.ZERO .AND. T22.NE.ZERO ) THEN
         SCL = 0
         IF ( ABS( T22 ).LE.TWOS * RMIN ) THEN
            SCL = 1
         ELSE IF ( EPS * ABS( T12 ).GT.ABS( T22 ) ) THEN
            IF ( SQRT( ABS( T11 ) ) * SQRT( ABS( T22 ) ).LE.
     $           ( SQRT( TWOS ) * RMNS ) * SQRT( ABS( T12 ) ) )
     $          SCL = 1
         ELSE
            IF ( ABS( T11 ).LE.TWOS * RMIN *
     $            ( ONE + ABS( T12 / T22 ) ) )
     $         SCL = 1
         END IF
         IF ( SCL.EQ.1 ) THEN
            TEMP = TEMP * BASE
            T11  =  T11 * BASE
            T12  =  T12 * BASE
            T22  =  T22 * BASE
            GOTO 70
         END IF
      END IF
C
      CALL DLASV2( T11, T12, T22, SSMIN, SSMAX, SR, CR, SL, CL )
C
C     Now, the last transformation is propagated to the front as
C     described in [1].
C
      S11 = T11
      S22 = T22
C
      CV(K) = CR
      SV(K) = SR
C
      DO 80  I = K, 2, -1
         AI = AMAP(I)
         IF ( S(AI).EQ.SINV ) THEN
            A11 = A(1,1,AI)
            A12 = A(1,2,AI)
            A22 = A(2,2,AI)
         ELSE
            A11 =  A(2,2,AI)
            A12 = -A(1,2,AI)
            A22 =  A(1,1,AI)
         END IF
         IF ( I.GT.2 ) THEN
            PW = PW - 3
            T11 = DWORK(PW)
            T12 = DWORK(PW+1)
            T22 = DWORK(PW+2)
            IF ( ABS( SR * CL * S22 ).LT.ABS( SL * CR * S11 ) ) THEN
               B11 =  T22
               B22 =  T11
               B12 = -T12
               CC  =  CL
               SC  =  SL
            ELSE
               B11 = A11
               B12 = A12
               B22 = A22
               CC  = CR
               SC  = SR
            END IF
            MX = MAX( ABS( B11 ), ABS( B12 ), ABS( B22 ) )
            IF ( MX.GT.RMAX / TWO ) THEN
               B11 = B11 / TWO
               B22 = B22 / TWO
               B12 = B12 / TWO
            END IF
            CALL DLARTG( B11 * CC + B12 * SC, SC * B22, CC, SC, TEMP )
         ELSE
            CC = CL
            SC = SL
         END IF
         IF ( ABS( SC ).LT.SFMN * ABS( A22 ) ) THEN
            A(1,1,AI) = SC * SR * A22 + CC * ( CR * A11 + SR * A12 )
         ELSE
            A(1,1,AI) = ( A22 / SC ) * SR
         END IF
         IF ( ABS( SR ).LT.SFMN * ABS( A11 ) ) THEN
            A(2,2,AI) = SC * SR * A11 + CR * ( CC * A22 - SC * A12 )
         ELSE
            A(2,2,AI) = ( A11 / SR ) * SC
         END IF
         A(1,2,AI) = ( A12 * CR - A11 * SR ) * CC + A22 * CR * SC
         IF ( S(AI).NE.SINV ) THEN
            TEMP      =  A(1,1,AI)
            A(1,1,AI) =  A(2,2,AI)
            A(2,2,AI) =  TEMP
            A(1,2,AI) = -A(1,2,AI)
         END IF
         CR = CC
         SR = SC
         CV(I-1) = CR
         SV(I-1) = SR
         S11 = T11
         S22 = T22
   80 CONTINUE
C
      CV(1) = CL
      SV(1) = SL
C
      RETURN
C *** Last line of MB03BC ***
      END


      double complex function C0DDHK(s12,s34,msq)
      implicit none
C-----Author: R.K.Ellis July 2012
C-----The scalar triangle function taken from
C-----Djouadi,Driesen,Hollik,Kraft arXiv:hep-ph/9701342v1, Eq(5)
      double precision s12,s34,msq,tauZ,tauH
      double complex FFF
c      double complex qlC0DDHK
      tauZ=4d0*msq/s34
      tauH=4d0*msq/s12
      C0DDHK=-2d0*tauZ*tauH/(tauZ-tauH)*(FFF(tauZ)-FFF(tauH))
C-----changed sign in order to agree with normal QCDLoop definition of scalar integral
      C0DDHK=-C0DDHK/(4d0*msq)

c      write(6,*) C0DDHK
c      C0DDHK=qlC0DDHK(s12,s34,msq)
c      write(6,*) C0DDHK
c      pause
      return
      end

      double complex function C2DDHK(s12,s34,msq)
      implicit none
C-----Author: R.K.Ellis July 2012
C-----The combination of triangle functions taken from
C-----Djouadi,Driesen,Hollik,Kraft arXiv:hep-ph/9701342v1, Eq(5)
      double precision s12,s34,msq,tauZ,tauH
      double complex FFF,GGG
c      double complex qlC2DDHK
      tauZ=4d0*msq/s34
      tauH=4d0*msq/s12
      C2DDHK=dcmplx(tauZ*tauH/(2d0*(tauZ-tauH)))
     & +tauZ*tauH**2/(2d0*(tauZ-tauH)**2)
     & *(tauZ*(FFF(tauZ)-FFF(tauH))+2d0*(GGG(tauZ)-GGG(tauH)))
C-----changed sign in order to agree with QCDLoop result
      C2DDHK=-C2DDHK/(4d0*msq)

c      write(6,*) C2DDHK
c      C2DDHK=qlC2DDHK(s12,s34,msq)
c      write(6,*) C2DDHK
c      pause

      return
      end

      double complex function FFF(tau)
      implicit none
C-----Author: R.K.Ellis July 2012
C-----The basic triangle function taken from
C-----Djouadi,Driesen,Hollik,Kraft arXiv:hep-ph/9701342v1, Eq(6)
      double precision xlog,tau,rttauinv,rtomtau,pi
      pi=2d0*asin(1d0)
      if (tau .ge. 1d0) then
      rttauinv=1d0/sqrt(tau)
      FFF=dcmplx(asin(rttauinv)**2)
      else
      rtomtau=sqrt(1d0-tau)
      xlog=log((1d0+rtomtau)/(1d0-rtomtau))
      FFF=-0.25d0*dcmplx(xlog,-pi)**2
      endif
      return
      end

      double complex function GGG(tau)
      implicit none
C-----Author: R.K.Ellis July 2012
C-----The other needed function taken from
C-----Djouadi,Driesen,Hollik,Kraft arXiv:hep-ph/9701342v1, Eq(7)
      double precision tau,rttauinv,rtomtau,pi,xlog
      pi=2d0*asin(1d0)
      if (tau .ge. 1d0) then
      rtomtau=sqrt(tau-1d0)
      rttauinv=1d0/sqrt(tau)
      GGG=dcmplx(rtomtau*asin(rttauinv))
      else
      rtomtau=sqrt(1d0-tau)
      xlog=log((1d0+rtomtau)/(1d0-rtomtau))
      GGG=rtomtau/2d0*dcmplx(xlog,-pi)
      endif
      return
      end


      double complex function Ftriangle(x)
      implicit none
      include 'constants.f'
      double precision x,y
      double complex arg
      y=1d0-4d0*x
      if (y .gt. 0d0) then
      arg=dcmplx((1d0+sqrt(y))/(1d0-sqrt(y)))
      Ftriangle=+dcmplx(0.5d0)*(log(arg)-impi)**2
      elseif (y .le. 0d0) then
      Ftriangle=-dcmplx(2d0)*dcmplx(asin(half/sqrt(x)))**2
      endif
      return
      end


 SUBROUTINE core06ps( eprop, pprop, matdef, pflow, &
                      vps, beta, epstl,istop, s1,s2, ehs)
 !-------------------------------------------------------------------
 !
 !     calculates  elasto-plastic stresses for rubber in plane stress
 !
 !-------------------------------------------------------------------
 USE lispa0
 IMPLICIT NONE

 INTEGER (kind=4),PARAMETER :: mitep=5
 REAL (kind=8)   ,PARAMETER :: toler=1d-4

 INTEGER (kind=4), INTENT(IN) :: matdef    !constitutive model (strain energy)
 INTEGER (kind=4), INTENT(IN OUT) :: istop
 REAL (kind=8), INTENT(IN) :: eprop(12), & !elastic properties
                              pprop(2)     !plastic properties
 LOGICAL, INTENT(OUT) :: pflow
 REAL (kind=8), INTENT(IN OUT) :: epstl,  & !effective plastic strain
                                  vps(3), & !elastic stretchings
                                  beta(:)   !principal stresses
 REAL (kind=8), OPTIONAL :: ehs(3), &       !elastic strains (Hencky)
                            s1,s2           !principal direction 1

 !Local variables
 INTEGER (kind=4) :: iterp
 REAL (kind=8) :: lambda,yield,efstp,glambd,hard,epstlo, &
                  vpso(2),dbl(3),vect(2),preys

 INTERFACE
   INCLUDE 'rubberps.h'
 END INTERFACE

 pflow = .FALSE.  !initialize to no plastic flow

 !Phase   i : set up yield limit
 preys = pprop(1) + pprop(2)*epstl
 !Phase  ii : calculate the stress and equivalent  stress (elastic predictor)
 CALL rubberps(eprop,vps,matdef,beta,vec=dbl)
 efstp = SQRT(beta(1)**2+beta(2)**2-beta(1)*beta(2))  ! |beta|
 !Phase iii : check IF the current gauss point has plastified
 yield = efstp - preys           !yield function |beta| -  k

 IF (yield/preys > toler) THEN   !The state is plastic

   !Phase   iv : calculate the plastic multiplier
   ! Newton-Raphson iteration consistency condition
   ! Initialization
   vect(1) = (beta(1)-beta(2)/2d0) / efstp    !yield surface normal
   vect(2) = (beta(2)-beta(1)/2d0) / efstp    !yield surface normal
   vpso    = vps(1:2)                         !keep trial elastic stretches
   epstlo = epstl               !previous equivalent plastic strain
   lambda = 0d0                 !initializes consistency parameter
   iterp  = 0                   !initializes iterations

   DO                     !loop until convergence
     iterp = iterp + 1          !update iteration number
     !computation of plastic multiplier increment
     hard = pprop(2) +  &
            vect(1)*dbl(1)*vect(1)+vect(2)*dbl(3)*vect(2)+2d0*vect(1)*dbl(2)*vect(2)
     glambd = yield/hard         !plastic multiplier increment
     !updates variables
     lambda = lambda + glambd             !plastic multiplier
     epstl  = epstlo + lambda             !effective plastic strain
     preys = pprop(1) + pprop(2)*epstl    !yield limit
     vps(1) = vpso(1) * EXP(-lambda*vect(1))    !elastic principal stretchings
     vps(2) = vpso(2) * EXP(-lambda*vect(2))    !elastic principal stretchings

     ! calculate the stress and equivalent  stress (elastic predictor)
     CALL rubberps(eprop,vps,matdef,beta,vec=dbl)
     efstp = SQRT(beta(1)**2+beta(2)**2-beta(1)*beta(2))  ! |beta|

     !Phase vi : check IF the current gauss point has plastified
     yield = efstp - preys

     !check to end iteration
     IF (ABS(yield/preys) < toler) EXIT
     IF(iterp <= mitep) CYCLE
     WRITE(lures,"(' Program will be stopped. No convergence in', &
                 & ' the RETURN algorithm')",ERR=9999)
     istop = 1
     RETURN
   END DO
   pflow = .TRUE.  !Plastic flow

 END IF
 !       phase viii : compute deviatoric elastic strains (twice)
 IF( PRESENT(s1).AND.PRESENT(s2))THEN
   vect = beta(1:2)
   beta(1) = s1*vect(1)*s1 + s2*vect(2)*s2          !(1,1)
   beta(2) = s2*vect(1)*s2 + s1*vect(2)*s1          !(2,2)
   beta(3) = s1*vect(1)*s2 - s2*vect(2)*s1          !(1,2)
   IF( pflow .AND. PRESENT( ehs ) )THEN
     vect = LOG(vps(1:2))*2d0
     ehs(1) = s1*vect(1)*s1 + s2*vect(2)*s2         !(1,1)
     ehs(2) = s2*vect(1)*s2 + s1*vect(2)*s1         !(2,2)
     ehs(3) = s1*vect(1)*s2 - s2*vect(2)*s1         !(1,2)
   END IF
 END IF

 RETURN
 9999 CALL runen2('')
 END SUBROUTINE core06ps


      module e3metric_m
c
        use e3if_defs_m
c
        implicit none
c
      contains
c
      subroutine e3metric(shg, dxdxi,shgl,xl)
c
        real*8, dimension(:,:,:), pointer, intent(out) :: dxdxi, shg
        real*8, dimension(:,:,:), pointer, intent(in)  :: xl, shgl
c
        integer :: n, nshl
        real*8  :: dxidx(npro,nsd,nsd), WdetJ(npro), tmp(npro)
c
        call calc_deform_grad(dxdxi,xl,shgl)
c
c.... compute the inverse of deformation gradient
c
       dxidx(:,1,1) =   dxdxi(:,2,2) * dxdxi(:,3,3)
     &                - dxdxi(:,3,2) * dxdxi(:,2,3)
       dxidx(:,1,2) =   dxdxi(:,3,2) * dxdxi(:,1,3)
     &                - dxdxi(:,1,2) * dxdxi(:,3,3)
       dxidx(:,1,3) =  dxdxi(:,1,2) * dxdxi(:,2,3)
     &                - dxdxi(:,1,3) * dxdxi(:,2,2)
       tmp          = one / ( dxidx(:,1,1) * dxdxi(:,1,1)
     &                       + dxidx(:,1,2) * dxdxi(:,2,1)
     &                       + dxidx(:,1,3) * dxdxi(:,3,1) )
       dxidx(:,1,1) = dxidx(:,1,1) * tmp
       dxidx(:,1,2) = dxidx(:,1,2) * tmp
       dxidx(:,1,3) = dxidx(:,1,3) * tmp
       dxidx(:,2,1) = (dxdxi(:,2,3) * dxdxi(:,3,1)
     &                - dxdxi(:,2,1) * dxdxi(:,3,3)) * tmp
       dxidx(:,2,2) = (dxdxi(:,1,1) * dxdxi(:,3,3)
     &                - dxdxi(:,3,1) * dxdxi(:,1,3)) * tmp
       dxidx(:,2,3) = (dxdxi(:,2,1) * dxdxi(:,1,3)
     &                - dxdxi(:,1,1) * dxdxi(:,2,3)) * tmp
       dxidx(:,3,1) = (dxdxi(:,2,1) * dxdxi(:,3,2)
     &                - dxdxi(:,2,2) * dxdxi(:,3,1)) * tmp
       dxidx(:,3,2) = (dxdxi(:,3,1) * dxdxi(:,1,2)
     &                - dxdxi(:,1,1) * dxdxi(:,3,2)) * tmp
       dxidx(:,3,3) = (dxdxi(:,1,1) * dxdxi(:,2,2)
     &                - dxdxi(:,1,2) * dxdxi(:,2,1)) * tmp
c
c       WdetJ = Qwt(lcsyst,intp) / tmp
c
c.... compute the global gradient of shape-functions
c
       nshl = size(shgl,3)
c
       do n = 1, nshl
          shg(:,n,1) = shgl(:,1,n) * dxidx(:,1,1) +
     &                 shgl(:,2,n) * dxidx(:,2,1) +
     &                 shgl(:,3,n) * dxidx(:,3,1)
          shg(:,n,2) = shgl(:,1,n) * dxidx(:,1,2) +
     &                 shgl(:,2,n) * dxidx(:,2,2) +
     &                 shgl(:,3,n) * dxidx(:,3,2)
          shg(:,n,3) = shgl(:,1,n) * dxidx(:,1,3) +
     &                 shgl(:,2,n) * dxidx(:,2,3) +
     &                 shgl(:,3,n) * dxidx(:,3,3)
       enddo

       return
c
      end subroutine e3metric
c
      subroutine calc_deform_grad(dxdxi,xl,shgl)
c
        real*8, dimension(:,:,:), intent(out) :: dxdxi
        real*8, dimension(:,:,:), intent(in)  :: xl, shgl
c
        integer :: npro,nenl,nsd,n,i,j
c
        npro = size(xl,1)
        nenl = size(xl,2)
        nsd  = size(xl,3)
c
        dxdxi = zero
c
        do n = 1, nenl
          do i = 1, nsd
            do j = 1, nsd
              dxdxi(:,i,j) = dxdxi(:,i,j) + xl(:,n,i)*shgl(:,j,n)
            enddo
          enddo
        enddo
c
      end subroutine calc_deform_grad
c
      end module e3metric_m


      subroutine init_ctfm2(x,Nx,lv,rv,res)
      implicit none
      integer i
      integer Nx
      real*8 lv
      real*8 rv
      real*8 x(Nx)
      real*8 res(Nx)
      real*8 qb
      do i=1, Nx, 1
      qb = exp(x(i)) - 0.1D1 * exp(lv) + (0.1D1 / (0.1D1 - 0.1D1 * x(i)
     #/ rv) - 0.1D1 / (0.1D1 - 0.1D1 * lv / rv)) ** (rv - 0.1D1 * x(i) +
     # 0.1D1)
      res(i)=qb
      end do
      END


module poisson_example_mod

    use precision_mod, only: wp
    use source_mod, only: source_term
    use poisson_mod, only: Lattice, init_Lattice

    implicit none
    private

    public :: pb_src, init_pb_src, poisson_example, analytical_solution

    type, extends(source_term) :: pb_src ! poisson boltzmann source
        real(wp) :: k
    contains
        procedure :: eval
    end type

contains

    function init_pb_src(k) result(this)
        real(wp), intent(in) :: k
        type(pb_src) :: this
        this%k = k
    end function

    real(wp) function eval(this,u,x)
        class(pb_src), intent(in) :: this
        real(wp), intent(in) :: u
        real(wp), intent(in) :: x
        eval = this%k**2*u
    end function

!>  Returns analytical solution of $\Delta u = k^2 u$ on
!   the domain $\[0,1\]$ with constant Dirichlet boundary conditions
!   $u(0) = 1$, $u(1) = 1$.
!
!   See Eq. (3.4) in paper by Chai and Shi (2008)
!
    elemental function analytical_solution(x,k) result(u)
        real(wp), intent(in) :: x
        real(wp), intent(in) :: k
        real(wp) :: u

        u = (exp(k) - 1.0_wp)/(exp(k) - exp(-k))*exp(-k*x) + &
           & (1.0_wp - exp(-k))/(exp(k) - exp(-k))*exp(k*x)
    end function

    subroutine poisson_example(k,nx,steps,check,tol)
        real(wp), intent(in) :: k
        integer, intent(in) :: nx, steps, check
        real(wp) :: tol

        real(wp), allocatable :: uold(:), u(:)
        real(wp) :: gre, omega
        type(Lattice) :: latt
        type(pb_src), target :: mysrc
        integer :: i, step

        ! Initalize density arrays
        allocate(uold(nx),u(nx))
        uold = 0.0_wp; uold([1,nx]) = 1._wp

        ! Create source term
        mysrc = init_pb_src(k)

        ! Create lattice
        omega = 1.0_wp
        latt = init_Lattice(nx=nx,uinit=uold,omega=omega,src=mysrc)

        time_loop: do step = 1, steps

            call latt%collide_and_stream()

            call latt%set_left_neem(1.0_wp)
            call latt%set_right_neem(1.0_wp)

            ! Check convergence
            if (mod(step,check) == 0) then
                call latt%get_macroscopic_values(u)
                gre = sum(abs(u-uold))/sum(abs(u)) ! global relative error
                uold = u
                write(*,*) "step = ", step, "error = ", gre
                if (gre < tol) exit time_loop
            end if

            call latt%prep_next_step()
        end do time_loop

        call latt%output("poisson_results.txt")

    end subroutine

end module

module reaction_example_mod

    use precision_mod, only: wp
    use source_mod, only: source_term
    use poisson_mod, only: Lattice, init_Lattice

    implicit none
    private

    public :: reaction_example

    type, extends(source_term) :: rc_src ! poisson boltzmann source
        real(wp) :: Th
    contains
        procedure :: eval
    end type

contains

    function init_rc_src(Th) result(this)
        real(wp), intent(in) :: Th
        type(rc_src) :: this
        this%Th = Th
    end function

    real(wp) function eval(this,u,x)
        class(rc_src), intent(in) :: this
        real(wp), intent(in) :: u
        real(wp), intent(in) :: x
        eval = this%Th**2*u
    end function

    subroutine reaction_example(Th,nx,steps,check,tol)
        real(wp), intent(in) :: Th
        integer, intent(in) :: nx
        integer, intent(in) :: steps
        integer, intent(in) :: check
        real(wp), intent(in) :: tol

        real(wp), allocatable :: uold(:), u(:)
        real(wp) :: interval(2), gre, omega, rval
        type(Lattice) :: latt

        type(rc_src), target :: mysrc

        integer :: i, step

        ! Initalize density arrays
        allocate(uold(nx),u(nx))
        uold = 0.0_wp;
        u = uold

        ! Create source term
        mysrc = init_rc_src(Th)

        ! Create lattice
        omega = 1.0_wp
        latt = init_Lattice(nx=nx,uinit=uold,omega=omega,src=mysrc)

        time_loop: do step = 1, steps

            call latt%collide_and_stream(uout=u)

            ! Boundaries
            call latt%set_left_neem(1.0_wp)
            rval = (4.0_wp*u(nx-1) - u(nx-2))/3.0_wp ! one-sided finite difference
            call latt%set_right_neem(rval)

            ! Convergence check
            if (mod(step,check) == 0) then
                gre = sum(abs(u-uold))/sum(abs(u)) ! global relative error
                uold = u
                write(*,*) "step = ", step, "error = ", gre
                if (gre < tol) exit time_loop
            end if

            call latt%prep_next_step()
        end do time_loop

        call latt%output("reaction_results.txt")

    end subroutine

end module

program main

    use precision_mod, only: wp
    use poisson_example_mod, only: poisson_example
    use reaction_example_mod, only: reaction_example

    real(wp) :: tol

    tol = epsilon(tol) ! Set tolerance

    write(*,*) "Poisson example"
    call poisson_example(k=27.79_wp,nx=101,steps=1000000,check=5000,tol=tol)

    write(*,*) ""
    write(*,*) "Reaction example"
    call reaction_example(Th=1.0_wp,nx=101,steps=1000000,check=5000,tol=tol)

end program


! file contains code which creates the hydrogen's orbitals.
!
! Dependencies:
!
! 	A SHTOOLS 4.4 tool and its dependencies are required to
!	calculate Legendre's associated polynomials. See the link
!	below for installation and more information.
!
!	https://shtools.oca.eu/shtools/
!
! Licenses:
!
!	This file is subject to the terms and conditions defined in
!	file 'LICENSE', which is part of this source code.
!
	program atomOrb
		implicit none
		integer, parameter :: n = 4, l = 1, m = 1
		real, parameter    :: dx = 0.0 , dy = 60.0, dz = 60.0
		real, parameter    :: dr = 0.2, dtheta = 0.2, icr = 1.05
		integer, parameter :: points = 50000

		integer            :: rDiv, thetaDiv, i
		real :: theta, r, w, max, pi
		real :: angDF, radDF
		real :: wave2Max, psi2
		real :: rAbs, thetaVal
		real :: rVector(3)

		pi = 4.0 * atan(1.0)

		call init_random_seed()

		rDiv = int(rAbs((/ dx, dy, dz /)) / dr) + 1
		thetaDiv = int(2.0 * pi / dtheta) + 1
		max = wave2max((/dx,dy,dz/), (/n,l,m/), rDiv, thetaDiv)

		do while (i <= points)
		CALL RANDOM_NUMBER(w)
			w = w * max * icr
			call fillVector(rVector, dx, dy, dz)
			r = rAbs(rVector)
			theta = thetaVal(rVector)
			psi2 = radDF(n, l, r) * angDF(l, m, theta)
			if(w < psi2) then
				write(*,*) rVector,  w
				i = i + 1
			end if
		end do
	end program atomOrb

	function wave2max(coordRange, nlm, rDiv, thetaDiv)
		implicit none
		interface
		function radDF(n, l, r)
			implicit none
			! dummy arguments
			real :: radDF
			! local variables
			integer :: n, l, Z = 1
			integer :: k
			real :: r, r0, a0 = 0.52917721067
			real*8 :: normTermSquared, radialTerm
			real*8 :: arr(6), sum
		end function radDF
		end interface

		interface
		function angDF(l, m, theta)
		use SHTOOLS
		! function result
		implicit none
		! dummy arguments
		real :: angDF

		! local variables
		integer 			  :: l, m, arrayindex
		real*8                            :: z, normRoot
		real*8, dimension ((l+1)*(l+2)/2) :: p
		real 				  :: theta, pi
		end function angDF
		end interface

		real :: wave2Max

		real :: coordRange(3)
		integer :: nlm(3), rDiv, thetaDiv
		real :: rmax, sum, dr, dtheta, pi, curr(2)
		real :: maxValue, r, theta, calc
		integer :: i, j

		pi = 4.0 * atan(1.0)

		do i = 1, 3, 1
			sum = sum + coordRange(i) ** 2.0
		end do

		rmax = sqrt(sum)

		dr = rMax / (1.0 * rDiv)
		dTheta = pi / (1.0 * thetaDiv)
		maxValue = 0.0

		do i = 0, rDiv, 1
			r = i * dr
			do j = 0, thetaDiv, 1
				theta = j * dtheta
				curr(1) = angDF(nlm(2), nlm(3), theta)
				curr(2) = radDF(nlm(1), nlm(2), r)
				calc = curr(1) * curr(2)

				if(calc > maxValue) then
					maxValue = calc
				end if
			end do
		end do

		wave2max = maxValue
	end function

	subroutine fillVector(r, dx, dy, dz)
	real, intent(out) :: r(3)
	real :: dx, dy, dz

	CALL RANDOM_NUMBER(r(1))
	r(1) = dx * (r(1) - 0.5)

	CALL RANDOM_NUMBER(r(2))
	r(2) = dy * (r(2) - 0.5)

	CALL RANDOM_NUMBER(r(3))
	r(3) = dz * (r(3) - 0.5)

	end subroutine

	function rAbs(r)
		implicit none
		real :: rAbs
		real :: r(3)

		rAbs = sqrt(r(1)**2+r(2)**2+r(3)**2)

	end function

	function thetaVal(r)
		implicit none

		real :: thetaVal
		real :: r(3), sum
		integer :: i

		do i = 1, 3, 1
			sum = sum + r(i) ** 2.0
		end do

		thetaVal = acos(r(3) / sqrt(sum))

	end function thetaVal

	function radDF(n, l, r)
		implicit none
		INTERFACE
		   FUNCTION Factorial(n)
		     INTEGER*8 :: Factorial
		     INTEGER, INTENT(IN) :: n
		   END FUNCTION Factorial
		END INTERFACE

		! dummy arguments
		real :: radDF
		! local variables
		integer :: n, l, Z = 1
		integer :: k
		real :: r, r0, a0 = 0.52917721067
		real*8 :: normTermSquared, radialTerm, arr(6), sum

		r0 = 2.0 * Z/(n * a0) * r
		sum = 0.0

		do k = 0, n - l - 1, 1
			arr(1) = (-1.0) ** (k + 1)
			arr(2) = factorial(n + l) ** 2.0
			arr(3) = factorial(n - l - 1 - k)
			arr(4) = factorial(2 * l + 1 + k)
			arr(5) = factorial(k)
			arr(6) = r0 ** k
			sum = sum+arr(1)*arr(2)/(arr(3)*arr(4)*arr(5))*arr(6)
		end do

		arr(:) = 0.0
		arr(1) = (2.0 * Z / (n * a0)) ** 3.0
		arr(2) = factorial(n - l - 1)
		arr(3) = 2.0 * n
		arr(4) = factorial(n + l) ** 3.0

		normTermSquared = arr(1)*arr(2)/(arr(3)*arr(4))

		radialTerm = exp(-r0 / 2.0) * (r0 ** l);

		radDF = (sum * radialTerm) ** 2.0
		radDF = radDF * normTermSquared
	end function radDF

	function angDF (l, m, theta)
	use SHTOOLS
	! function result
	implicit none
	INTERFACE
	   FUNCTION Factorial(n)
	     INTEGER*8 :: Factorial
	     INTEGER, INTENT(IN) :: n
	   END FUNCTION Factorial
	END INTERFACE

	! dummy arguments
	real :: angDF

	! local variables
	integer 				:: l, m, arrayindex
	real*8                                  :: z, normRoot
	real*8, dimension ((l + 1) * (l + 2)/2) :: p
	real 					:: theta, pi

	z = cos(theta)
	call PLegendreA (p, l, z)
	arrayindex = PlmIndex (l, m)

	pi = 4.0 * atan(1.0)
	normRoot = 1.0 * factorial(l - m)/ factorial(l + m)
	normRoot = normRoot * (2.0 * l + 1.0)/(4.0 * pi)

	angDF = normRoot * p(arrayIndex) ** 2.0

	end function angDF

! Evaluate the factorial
! This was adapted from a post from user gsal at jun 2, 2015 to a
! Physics Forums, and visited in March 2019. See link bellow.

! Reference https://www.physicsforums.com/threads/factorial-fortran-90.816501/

	RECURSIVE FUNCTION Factorial(n)  RESULT(Fact)

	IMPLICIT NONE
	INTEGER*8 :: Fact
	INTEGER, INTENT(IN) :: n

	IF (n == 0) THEN
	   Fact = 1
	ELSE
	   Fact = n * Factorial(n-1)
	END IF

	END FUNCTION Factorial

! Initialize a pseudo-random number sequence
! This subroutine is a partial copy found on the link below
! and visited in March 2019.

! https://gcc.gnu.org/onlinedocs/gcc-4.2.3/gfortran/RANDOM_005fSEED.html

! Description:
!    Restarts or queries the state of the pseudorandom number
!    generator used by RANDOM_NUMBER.

	subroutine init_random_seed()

	integer :: i, n, clock
	integer, dimension(:), allocatable :: seed

	call RANDOM_SEED(size = n)
	allocate(seed(n))

	call SYSTEM_CLOCK(COUNT=clock)

	seed = clock + 37 * (/ (i - 1, i = 1, n) /)

	call RANDOM_SEED(PUT = seed)
	deallocate (seed)

	end subroutine


program test
use mpfunmod
use mpmodule
implicit none
integer i, ndp, nchx
parameter (ndp = 100000)
type (mp_real) t1, t2
character*1 chx(ndp+200)

call mpinit (ndp)
mpoud = ndp
t1 = mppic / 10.d0
t2 = cos (t1)**2 + sin(t1)**2
write (6, *) 'cos(t1)^2 + sin(t1)^2 ='
call mpwrite (6, t2)
write (6, *) 'pi to ', ndp, ' digits ='

 call mpwrite (6, mppic)

!   This code does the equivalent of the previous line with mpwrite, but is much
!   faster in execution (note however this requires the character*1 line above):

call mpoutcx (mppic%mpr, chx, nchx, mpnwx)
write (6, '(78a1)') (chx(i), i = 1, nchx)

stop
end


	program efflength
c
c	see page 35 of Wind N.B. Vol 2 for derivation
c		L is monopole length, R is radius of spherical spacecraft
c		efflratio is ratio of effective length to L
c		ratiolr is ratio of L to R
c
	DO I = 1,50
	  RATIOLR = .1*I
	  EFFLRATIO  = (1. + 1./RATIOLR)**2 + 2./(RATIOLR)**3/(1. +
     1		1./RATIOLR) - 3./(RATIOLR**2)
	  PRINT*,RATIOLR,EFFLRATIO,(1. + 2./RATIOLR)
	ENDDO
	  RATIOLR = 41.67			! WIND X
	  EFFLRATIO  = (1. + 1./RATIOLR)**2 + 2./(RATIOLR)**3/(1. +
     1		1./RATIOLR) - 3./(RATIOLR**2)
	  PRINT*,RATIOLR,EFFLRATIO,(1. + 2./RATIOLR)
	  RATIOLR = 6.25
	  EFFLRATIO  = (1. + 1./RATIOLR)**2 + 2./(RATIOLR)**3/(1. +
     1		1./RATIOLR) - 3./(RATIOLR**2)
	  PRINT*,RATIOLR,EFFLRATIO,(1. + 2./RATIOLR)
	  RATIOLR = 4.4/.9
	  EFFLRATIO  = (1. + 1./RATIOLR)**2 + 2./(RATIOLR)**3/(1. +
     1		1./RATIOLR) - 3./(RATIOLR**2)
	  PRINT*,RATIOLR,EFFLRATIO,(1. + 2./RATIOLR)
	STOP
	END


! Created by EverLookNeverSee@GitHub on 4/22/20.
! This program add up all even numbers between 1 to user input.

program sum_of_evens
    implicit none
    ! defining variables
    integer :: number, i, sum = 0
    ! getting user input
1   print *, "Please enter a positive integer number:"
    read *, number
    ! Edge case
    if (number <= 0) then
        print *, "Invalid input!"
        goto 1
    end if
    do i = 1, number
        if (mod(i, 2) /= 0) then
            cycle   ! skipp all odd numbers
        end if
        sum = sum + i
    end do
    print *, "Sum:", sum
end program sum_of_evens


C$Procedure                     HALFPI ( Half the value of pi )

      DOUBLE PRECISION FUNCTION HALFPI ( )

C$ Abstract
C
C     Return half the value of pi (the ratio of the circumference of
C     a circle to its diameter).
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     CONSTANTS
C
C$ Declarations
C
C     None.
C
C$ Brief_I/O
C
C     The function returns half the value of pi.
C
C$ Detailed_Input
C
C     None.
C
C$ Detailed_Output
C
C     The function returns half the value of pi (the ratio of
C     a circle's circumference to its diameter), determined by
C     the ACOS function. That is,
C
C           HALFPI = ACOS ( -1.D0 ) * 0.5D0
C
C$ Parameters
C
C     None.
C
C$ Exceptions
C
C     Error free.
C
C$ Files
C
C     None.
C
C$ Particulars
C
C     The first time the function is referenced, the value is computed
C     as shown above. The value is saved, and returned directly upon
C     subsequent reference.
C
C$ Examples
C
C     The subroutine shown below illustrates the use of HALFPI.
C
C                 SUBROUTINE BFTRAN ( RA, DEC, W, TIPM )
C
C           C
C           C     Compute the transformation from inertial to body
C           C     fixed coordinates, given the directions of the north
C           C     pole and prime meridian of the body.
C           C
C                 DOUBLE PRECISION    RA
C                 DOUBLE PRECISION    DEC
C                 DOUBLE PRECISION    W
C                 DOUBLE PRECISION    TIPM ( 3,3 )
C
C           C
C           C     SPICELIB functions
C           C
C                 DOUBLE PRECISION    HALFPI
C
C           C
C           C     The transformation is defined by the compound
C           C     rotation
C           C
C           C        [W] [pi/2 - Dec] [RA + pi/2]
C           C           3            1           3
C           C
C                 CALL ROTATE (       RA + HALFPI(),  3, TIPM)
C                 CALL ROTMAT (TIPM,  HALFPI() - DEC, 1, TIPM)
C                 CALL ROTMAT (TIPM,  W,              3, TIPM)
C
C                 RETURN
C                 END
C
C$ Restrictions
C
C     None.
C
C$ Literature_References
C
C     None.
C
C$ Author_and_Institution
C
C     J. Diaz del Rio (ODC Space)
C     W.L. Taber      (JPL)
C     I.M. Underwood  (JPL)
C
C$ Version
C
C-     SPICELIB Version 1.0.2, 08-APR-2015 (JDR)
C
C         Minor edit to example comments eliminating typos.
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 (WLT) (IMU)
C
C-&

C$ Index_Entries
C
C     half the value of pi
C
C-&

C
C     Local variables
C
      DOUBLE PRECISION      VALUE
      SAVE                  VALUE

C
C     Initial values
C
      DATA                  VALUE      / 0.D0 /

C
C     What is there to say?
C
      IF ( VALUE .EQ. 0.D0 ) THEN
         VALUE = ACOS ( -1.D0 ) * 0.5D0
      END IF

      HALFPI = VALUE

      RETURN
      END


module KuraNetwork
    use iso_fortran_env, only: real64
    implicit none

    type KuramotoNetwork
       integer :: nnodes
       integer :: nedges
       real(kind=real64)            :: couple_constant
       real(kind=real64), dimension(:),allocatable :: p
       real(kind=real64), dimension(:),allocatable :: swap
       integer,dimension(:),allocatable            :: Bt_csr !IncidenceMatrix
    end type

    interface KuramotoNetwork
        module procedure KNConstructor
    end interface
    ! TODO: Constructor that allocates tmp(nnodes)
contains
    type(KuramotoNetwork) function KNConstructor(nnodes,nedges,couple_constant)
        implicit none
        integer::nnodes
        integer::nedges
        real(real64)::couple_constant
        KNConstructor%nnodes = nnodes
        KNConstructor%nedges = nedges
        KNConstructor%couple_constant = couple_constant
        allocate(KNConstructor%p(nnodes))
        allocate(KNConstructor%swap(nedges))
        allocate(KNConstructor%Bt_csr(nedges*2))

    end function KNConstructor

    subroutine f(this,t,x,dx)
        ! dx .= p .-  coupling_constant .* (B * sin.(B_t * x))
        implicit none

        class(KuramotoNetwork), intent(inout) :: this

        real(kind=real64), intent(in)      :: t
        real(kind=real64), intent(in), dimension(:)     :: x
        real(kind=real64), intent(out), dimension(:)  :: dx
        integer :: i
        associate( nedges => this%nedges,&
                   nnodes => this%nnodes,&
                   col_index => this%Bt_csr,&
                   omega => this%p,&
                   couple_constant => this%couple_constant,&
                   y => this%swap)
        y = 0
        do concurrent (i =1:nedges)
             y(i) = sin(x(col_index((i-1)*2+2)) - x(col_index((i-1)*2+1)))
        end do
        dx = 0
        do i = 1,nedges ! treat the csr as a csc to transpose it
            associate(idx_s => col_index((i-1)*2+1),&
                  idx_k => col_index((i-1)*2+2)&
                  )
            dx(idx_s) = dx(idx_s) - y(i)
            dx(idx_k) = dx(idx_k) + y(i)
            end associate
        end do
        do concurrent (i = 1:nnodes) ! now dx = B*sin(B_t*x)
            dx(i) = omega(i) - couple_constant * dx(i)
        end do
        ! Now dx .= p .- coupling_constant .* (B*sin.(Bt*x))

    end associate
    end subroutine f
end module KuraNetwork


      PROGRAM LA_SSYEV_EXAMPLE

!  -- LAPACK95 EXAMPLE DRIVER ROUTINE (VERSION 1.0) --
!     UNI-C, DENMARK
!     DECEMBER, 1999
!
!  .. "Use Statements" ..
      USE LA_PRECISION, ONLY: WP => SP
      USE F95_LAPACK, ONLY: LA_SYEV, LA_SYEVD
!  .. "Implicit Statement" ..
      IMPLICIT NONE
!  .. "Local Scalars" ..
      INTEGER :: I, J, INFO, N
!  .. "Local Arrays" ..
      REAL(WP), ALLOCATABLE :: A(:,:), AA(:,:), W(:)
!  .. "Executable Statements" ..
      WRITE (*,*) 'LA_SYEV Example Program Results'
      N = 5
      ALLOCATE( A(N,N), AA(N,N), W(N) )

      OPEN(UNIT=21,FILE='syev.ma',STATUS='UNKNOWN')
      DO J=1,N
         DO I=1,N
            READ(21,*) A(I,J)
         ENDDO
      ENDDO
      CLOSE(21)

      AA=TRANSPOSE(A)

      WRITE(*,*)'Matrix A:'
      DO I=1,N;
         WRITE(*,"(5(F9.5))") A(I,:);
      ENDDO

      WRITE(*,*) 'CALL LA_SYEV( A, W )'
      CALL LA_SYEV(  A, W)
      WRITE(*,*) 'W on exit : '
      DO I=1,N
      WRITE(*,"(5(F10.5))") W(I)
      ENDDO

      WRITE(*,*)
      WRITE(*,*)' * EXAMPLE 2 * '

      WRITE(*,*)'Matrix A:'
      DO I=1,N;
         WRITE(*,"(5(F9.5))") AA(I,:);
      ENDDO

      WRITE(*,*) "CALL LA_SYEVD( A, W, 'V', 'L', INFO )"
      CALL LA_SYEVD( AA, W, 'V', 'L', INFO )

      WRITE(*,*) 'A on exit : '
      DO I=1,N;
         WRITE(*,"(5(E14.6))") AA(I,:);
      ENDDO

      WRITE(*,*) 'W on exit : '
      DO I=1,N
      WRITE(*,"(5(F10.5))") W(I)
      ENDDO

      WRITE(*,*) ' INFO = ', INFO

      END PROGRAM LA_SSYEV_EXAMPLE


subroutine mg_error(phi_prev, phi, nx, ny, xi, xf, error_phi)
use kind_parameters
implicit none

integer, intent(in):: nx, ny, xi, xf
real(kind=dp), intent(in), dimension(nx,xi-1:xf+1):: phi_prev, phi
real(kind=dp), intent(out), dimension(nx,xi-1:xf+1):: error_phi
integer:: i, j

! Calculate the residual r = f - Au, where u is the guessed value
! Input
! u      Matrix for variables
! f      Right Hand Side
! hx     grid spacing in x direction
! hy     grid spacing in y direction
!
! Output
! r      Residual

! Author: Pratanu Roy
! History:
! First Written: July 20, 2012
! Modified: Feb 11, 2013

do j = xi,xf

    do i = 2,nx-1

        error_phi(i,j) = phi(i,j) - phi_prev(i,j)

    end do

end do

call exchange_data(error_phi, nx, xi, xf)

end subroutine


c======================================================================
      function bilinearintegral(xim,xip,yjm,yjp,x1,x2,y1,y2,dxx,dyy,
     &                                              z11,z12,z21,z22)
c======================================================================

      implicit none

*     !i/o
      double precision xim,xip,yjm,yjp,x1,x2,y1,y2,dxx,dyy,
     &                                                z11,z12,z21,z22
      double precision bilinearintegral

*     !local
      double precision xlow,ylow,xhi,yhi,area,sumxi,sumeta,a,b,c,d

c#######################################################################
c
c         bilinearintegral integrates the bilinear with values z##
c         over the rectangular region xim <= x <= xip, and
c                                     yjm <= y <= yjp

c                                          written by David L George
c                                          Vancouver, WA April 2010
c#######################################################################

*     !integrate the portion of the bilinear intersected with the
c     !rectangular cell analytically.

c     !find limits of integral (this should already be true?)
      xlow = max(xim,x1)
      ylow = max(yjm,y1)
      xhi  = min(xip,x2)
      yhi =  min(yjp,y2)

*     !find the area of integration
      area = (yhi-ylow)*(xhi-xlow)
      sumxi = (xhi + xlow - 2.d0*x1)/dxx
      sumeta = (yhi + ylow - 2.d0*y1)/dyy

*     !find coefficients of bilinear a*xi + b*eta + c*xi*eta + d
      a = z21-z11
      b = z12-z11
      c = z22-z21-z12+z11
      d = z11

      bilinearintegral = (0.5d0*(a*sumxi + b*sumeta)
     &                     + 0.25d0*c*sumxi*sumeta + d)*area

      return

      end function

c======================================================================
      function bilinearintegral_s(xim,xip,yjm,yjp,x1,x2,y1,y2,dxx,dyy,
     &                                      z11,z12,z21,z22)
c======================================================================

      use geoclaw_module, only: r2d => rad2deg, d2r => deg2rad
      use geoclaw_module, only: Rearth => earth_radius

      implicit none

*     !i/o
      double precision xim,xip,yjm,yjp,x1,x2,y1,y2,dxx,dyy,
     &                                 z11,z12,z21,z22
      double precision bilinearintegral_s

*     !local
      double precision xlo,ylo,xhi,yhi,delx,dely,a,b,c,d
      double precision xdiffhi,xdifflo,ydiffhi,ydifflo,xdiff2
      double precision adsinint,cbsinint

c#######################################################################
c
c         bilinearintegral integrates the bilinear with values z##
c         over the rectangular region xim <= x <= xip, and
c                                     yjm <= y <= yjp
c         integration is actually done on the surface of a sphere

c                                          written by David L George
c                                          Vancouver, WA April 2010
c#######################################################################

*     !integrate the portion of the bilinear intersected with the
c     !rectangular cell analytically.
c     !find limits of integral (this should already be true?)
      xlo = max(xim,x1)
      ylo = max(yjm,y1)
      xhi  = min(xip,x2)
      yhi =  min(yjp,y2)
      delx = xhi - xlo
      dely = yhi - ylo

*     !find terms for the integration
      xdiffhi = xhi - x1
      xdifflo = xlo - x1
      ydiffhi = yhi - y1
      ydifflo = ylo - y1
      xdiff2 = 0.5d0*(xdiffhi**2 - xdifflo**2)

      cbsinint = (r2d*cos(d2r*yhi) + ydiffhi*sin(d2r*yhi))
     &            -(r2d*cos(d2r*ylo) + ydifflo*sin(d2r*ylo))

      adsinint = r2d*(sin(d2r*yhi) - sin(d2r*ylo))

*     !find coefficients of bilinear a*xi + b*eta + c*xi*eta + d
      a = (z21-z11)/dxx
      b = (z12-z11)/dyy
      c = (z22-z21-z12+z11)/(dxx*dyy)
      d = z11

      bilinearintegral_s = ((a*xdiff2 + d*delx)*adsinint
     &            + r2d*(c*xdiff2 + b*delx)*cbsinint)*(Rearth*d2r)**2

      return

      end function


!======================================================================!
  REAL FUNCTION DistR(rA,zA,rB,zB)
!----------------------------------------------------------------------!
!  Calculates distance between two points.                             !
!----------------------------------------------------------------------!
  IMPLICIT NONE
!-----------------------------[Parameters]-----------------------------!
  REAL :: rA,zA,rB,zB
!--------------------------------[CVS]---------------------------------!
!  $Id: Dist.f90,v 1.5 2002/10/30 16:29:31 niceno Exp $
!  $Source: /home/muhamed/.CVSROOT/T-Rex/Library/Dist.f90,v $
!======================================================================!

  DistR=sqrt( (rA-rB)*(rA-rB) + (zA-zB)*(zA-zB) )

  END FUNCTION DistR


PROGRAM test_sinc
!
!  Purpose:
!    To test the sinc function sinc(x)
!
IMPLICIT NONE

! Data dictionary: declare function types
REAL :: sinc             ! sinc function

! Data dictionary: declare variable types & definitions
REAL :: x                ! Input value to evaluate

! Get value to evaluate
WRITE (*,*) 'Enter x: '
READ (*,*) x

! Write answer.
WRITE (*,'(1X,A,F8.5)') 'sinc(x) = ', sinc(x)

END PROGRAM test_sinc


      subroutine toFourier
      use fourier_lib
      implicit none
c
c   Do Fourier transform integrations needed to convert data on a
c   theta, zeta grid [stored in array f(i=1,nznt)] to a set
c   of Fourier amplitudes [stored in array fnm(mn=1,mnmx)].
c   Typically, the number of grid points in each direction needs
c   to be > 3*number of modes used in each direction to avoid
c   aliasing errors(implies nznt > 9*mnmx).
c
c      do mn=1,mnmx     !loop over Fourier modes
c       fnm(mn) = 0.
c      do i=1,nznt      !loop over theta,zeta grid
c       if(sin_type .eq. 1 .and. cos_type .eq. 0) then
c         fnm(mn) = fnm(mn) + f(i)*sin_toF(i,mn)
c       else if(sin_type .eq. 0 .and. cos_type .eq. 1) then
c         fnm(mn) = fnm(mn) + f(i)*cos_toF(i,mn)
c       endif
c      end do
c      end do
c
       if(sin_type .eq. 1 .and. cos_type .eq. 0) then
         fnm = matmul(f,sin_toF)
       else if(sin_type .eq. 0 .and. cos_type .eq. 1) then
         fnm = matmul(f,cos_toF)
       endif
c
      return
      end
c
      subroutine old_toFourier
      use fourier_lib
      implicit none
      real(kind=rprec) dum,dnorm
c
c   Do Fourier transform integrations needed to convert data on a
c   theta, zeta grid [stored in array f(i=1,nznt)] to a set
c   of Fourier amplitudes [stored in array fnm(mn=1,mnmx)].
c   Typically, the number of grid points in each direction needs
c   to be > 3*number of modes used in each direction to avoid
c   aliasing errors(implies nznt > 9*mnmx).
c
      do mn=1,mnmx     !loop over Fourier modes
       fnm(mn) = 0.
c       dnorm = 2.*real(nfp)/real(nznt)
       dnorm = 2./real(nznt)
       dum = abs(rn(mn)) + abs(rm(mn))
       if(nint(dum) .eq. 0) dnorm = .5*dnorm
      do i=1,nznt      !loop over theta,zeta grid
c       arg = -rn(mn)*ztgrd(i) + rm(mn)*thtgrd(i)
       if(sin_type .eq. 1 .and. cos_type .eq. 0) then
         fnm(mn) = fnm(mn) + f(i)*sin_ar(i,mn)*dnorm
       else if(sin_type .eq. 0 .and. cos_type .eq. 1) then
         fnm(mn) = fnm(mn) + f(i)*cos_ar(i,mn)*dnorm
       endif
      end do
      end do
c
      return
      end
c
      subroutine toReal
c
c    Convert Fourier mode representation [stored in array anm(mn=1,mnmx)]
c    to values of function on a regularly spaced 2D grid
c    [stored in array f(i=1,nznt)].
c
      use fourier_lib
      implicit none
      do i=1,nznt
      f(i) = 0.
        do mn=1,mnmx
         if(sin_type .eq. 1 .and. cos_type .eq. 0) then
          f(i) = f(i) + anm(mn)*sin_ar(i,mn)
         else if(sin_type .eq. 0 .and. cos_type .eq. 1) then
          f(i) = f(i) + anm(mn)*cos_ar(i,mn)
         endif
        end do
       end do
      end
c
c
c
      subroutine dbydth
c
c    Take the theta derivative of the input Fourier amplitude array, fnm
c    and place the result in the output Fourier amplitude array, anm.
c    Changes to the sin/cos parity are reflected through the sin_type and
c    cos_type variables.
c
      use fourier_lib
      implicit none
      do i=1,mnmx
         if(sin_type .eq. 1 .and. cos_type .eq. 0) then
          anm(i) = rm(i)*fnm(i)
         else if(sin_type .eq. 0 .and. cos_type .eq. 1) then
          anm(i) = -rm(i)*fnm(i)
         endif
        end do
        if(sin_type .eq. 1 .and. cos_type .eq. 0) then
          sin_type = 0; cos_type = 1
         else if(sin_type .eq. 0 .and. cos_type .eq. 1) then
          sin_type = 1; cos_type = 0
        endif
       end
c
c
c
      subroutine dbydzt
c
c    Take the zeta derivative of the input Fourier amplitude array, fnm
c    and place the result in the output Fourier amplitude array, anm.
c    Changes to the sin/cos parity are reflected through the sin_type and
c    cos_type variables.
c
      use fourier_lib
      implicit none
      do i=1,mnmx
         if(sin_type .eq. 1 .and. cos_type .eq. 0) then
          anm(i) = -rn(i)*fnm(i)
          else if(sin_type .eq. 0 .and. cos_type .eq. 1) then
          anm(i) = rn(i)*fnm(i)
         endif
        end do
        if(sin_type .eq. 1 .and. cos_type .eq. 0) then
          sin_type = 0; cos_type = 1
         else if(sin_type .eq. 0 .and. cos_type .eq. 1) then
          sin_type = 1; cos_type = 0
        endif
       end


      subroutine dnherm2(x,nx,y,ny,fherm,nf2,ilinx,iliny,ier)
C
C  create a data set for Hermite interpolation, based on simple
C  numerical differentiation using the given grid.  The grid should
C  be "approximately" evenly spaced.
C
C  2d routine
C
C  input:
C
C  nf2.gt.nx expected!
C
      integer nx,ny,nf2                 ! array dimensions
      real x(nx)                        ! x coordinate array
      real y(ny)                        ! y coordinate array
      real fherm(0:3,nf2,ny)            ! data/Hermite array
C
C  fherm(0,i,j) = function value f at x(i),y(j)  **on input**
C
C  fherm(1,i,j) = derivative df/dx at x(i),y(j)  **on output**
C  fherm(2,i,j) = derivative df/dy at x(i),y(j)  **on output**
C  fherm(3,i,j) = derivative d2f/dxdy at x(i),y(j)  **on output**
C
C  addl output:
C    ilinx=1 if x axis is evenly spaced
C    iliny=1 if y axis is evenly spaced
C    ier=0 if no error:
C      x, y must both be strict ascending
C      nf2.ge.nx is required.
C
C----------------------------
c
      ier=0
c
      call splinck(x,nx,ilinx,1.0e-3,ierx)
      if(ierx.ne.0) ier=2
c
      if(ier.eq.2) then
         write(6,'('' ?dnherm2:  x axis not strict ascending'')')
      endif
c
      call splinck(y,ny,iliny,1.0e-3,iery)
      if(iery.ne.0) ier=3
c
      if(ier.eq.3) then
         write(6,'('' ?dnherm2:  y axis not strict ascending'')')
      endif
c
      if(nf2.lt.nx) then
         ier=4
         write(6,*) '?dnherm2:  fherm array dimension too small.'
      endif
C
      if(ier.ne.0) return
C
      do iy=1,ny
c
         iyp=min(ny,iy+1)
         iym=max(1,iy-1)
c
         do ix=1,nx
c
            ixp=min(nx,ix+1)
            ixm=max(1,ix-1)
c
c  x diffs in vicinity
c
            zd=(fherm(0,ixp,iy)-fherm(0,ixm,iy))/(x(ixp)-x(ixm))
c
            fherm(1,ix,iy)=zd
c
c  y diffs in vicinity
c
            zd=(fherm(0,ix,iyp)-fherm(0,ix,iym))/(y(iyp)-y(iym))
c
            fherm(2,ix,iy)=zd
c
c  xy cross derivs (except at corners, iedge=2)
c
            fherm(3,ix,iy)=(fherm(0,ixp,iyp)-fherm(0,ixm,iyp)
     >         -fherm(0,ixp,iym)+fherm(0,ixm,iym))/
     >         ((x(ixp)-x(ixm))*(y(iyp)-y(iym)))
c
         enddo
      enddo
C
      return
      end


      SUBROUTINE MB02SD( N, H, LDH, IPIV, INFO )
C
C     SLICOT RELEASE 5.7.
C
C     Copyright (c) 2002-2020 NICONET e.V.
C
C     PURPOSE
C
C     To compute an LU factorization of an n-by-n upper Hessenberg
C     matrix H using partial pivoting with row interchanges.
C
C     ARGUMENTS
C
C     Input/Output Parameters
C
C     N       (input) INTEGER
C             The order of the matrix H.  N >= 0.
C
C     H       (input/output) DOUBLE PRECISION array, dimension (LDH,N)
C             On entry, the n-by-n upper Hessenberg matrix to be
C             factored.
C             On exit, the factors L and U from the factorization
C             H = P*L*U; the unit diagonal elements of L are not stored,
C             and L is lower bidiagonal.
C
C     LDH     INTEGER
C             The leading dimension of the array H.  LDH >= max(1,N).
C
C     IPIV    (output) INTEGER array, dimension (N)
C             The pivot indices; for 1 <= i <= N, row i of the matrix
C             was interchanged with row IPIV(i).
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, U(i,i) is exactly zero. The
C                   factorization has been completed, but the factor U
C                   is exactly singular, and division by zero will occur
C                   if it is used to solve a system of equations.
C
C     METHOD
C
C     The factorization has the form
C        H = P * L * U
C     where P is a permutation matrix, L is lower triangular with unit
C     diagonal elements (and one nonzero subdiagonal), and U is upper
C     triangular.
C
C     This is the right-looking Level 1 BLAS version of the algorithm
C     (adapted after DGETF2).
C
C     REFERENCES
C
C     -
C
C     NUMERICAL ASPECTS
C                                2
C     The algorithm requires 0( N ) operations.
C
C     CONTRIBUTOR
C
C     V. Sima, Katholieke Univ. Leuven, Belgium, June 1998.
C
C     REVISIONS
C
C     V. Sima, Research Institute for Informatics, Bucharest, Oct. 2000,
C     Jan. 2005.
C
C     KEYWORDS
C
C     Hessenberg form, matrix algebra.
C
C     ******************************************************************
C
C     .. Parameters ..
      DOUBLE PRECISION  ZERO
      PARAMETER         ( ZERO = 0.0D+0 )
C     .. Scalar Arguments ..
      INTEGER           INFO, LDH, N
C     .. Array Arguments ..
      INTEGER           IPIV(*)
      DOUBLE PRECISION  H(LDH,*)
C     .. Local Scalars ..
      INTEGER           J, JP
C     .. External Subroutines ..
      EXTERNAL          DAXPY, DSWAP, XERBLA
C     .. Intrinsic Functions ..
      INTRINSIC         ABS, MAX
C     ..
C     .. Executable Statements ..
C
C     Check the scalar input parameters.
C
      INFO = 0
      IF( N.LT.0 ) THEN
         INFO = -1
      ELSE IF( LDH.LT.MAX( 1, N ) ) THEN
         INFO = -3
      END IF
      IF( INFO.NE.0 ) THEN
         CALL XERBLA( 'MB02SD', -INFO )
         RETURN
      END IF
C
C     Quick return if possible.
C
      IF( N.EQ.0 )
     $   RETURN
C
      DO 10 J = 1, N
C
C        Find pivot and test for singularity.
C
         JP = J
         IF ( J.LT.N ) THEN
            IF ( ABS( H( J+1, J ) ).GT.ABS( H( J, J ) ) )
     $         JP = J + 1
         END IF
         IPIV( J ) = JP
         IF( H( JP, J ).NE.ZERO ) THEN
C
C           Apply the interchange to columns J:N.
C
            IF( JP.NE.J )
     $         CALL DSWAP( N-J+1, H( J, J ), LDH, H( JP, J ), LDH )
C
C           Compute element J+1 of J-th column.
C
            IF( J.LT.N )
     $         H( J+1, J ) = H( J+1, J )/H( J, J )
C
         ELSE IF( INFO.EQ.0 ) THEN
C
            INFO = J
         END IF
C
         IF( J.LT.N ) THEN
C
C           Update trailing submatrix.
C
            CALL DAXPY( N-J, -H( J+1, J ), H( J, J+1 ), LDH,
     $                  H( J+1, J+1 ), LDH )
         END IF
   10 CONTINUE
      RETURN
C *** Last line of MB02SD ***
      END


*> \brief \b CGLMTS
*
*  =========== DOCUMENTATION ===========
*
* Online html documentation available at
*            http://www.netlib.org/lapack/explore-html/
*
*  Definition:
*  ===========
*
*       SUBROUTINE CGLMTS( N, M, P, A, AF, LDA, B, BF, LDB, D, DF,
*                          X, U, WORK, LWORK, RWORK, RESULT )
*
*       .. Scalar Arguments ..
*       INTEGER            LDA, LDB, LWORK, M, P, N
*       REAL               RESULT
*       ..
*       .. Array Arguments ..
*       REAL               RWORK( * )
*       COMPLEX            A( LDA, * ), AF( LDA, * ), B( LDB, * ),
*      $                   BF( LDB, * ), D( * ), DF( * ), U( * ),
*      $                   WORK( LWORK ), X( * )
*
*
*> \par Purpose:
*  =============
*>
*> \verbatim
*>
*> CGLMTS tests CGGGLM - a subroutine for solving the generalized
*> linear model problem.
*> \endverbatim
*
*  Arguments:
*  ==========
*
*> \param[in] N
*> \verbatim
*>          N is INTEGER
*>          The number of rows of the matrices A and B.  N >= 0.
*> \endverbatim
*>
*> \param[in] M
*> \verbatim
*>          M is INTEGER
*>          The number of columns of the matrix A.  M >= 0.
*> \endverbatim
*>
*> \param[in] P
*> \verbatim
*>          P is INTEGER
*>          The number of columns of the matrix B.  P >= 0.
*> \endverbatim
*>
*> \param[in] A
*> \verbatim
*>          A is COMPLEX array, dimension (LDA,M)
*>          The N-by-M matrix A.
*> \endverbatim
*>
*> \param[out] AF
*> \verbatim
*>          AF is COMPLEX array, dimension (LDA,M)
*> \endverbatim
*>
*> \param[in] LDA
*> \verbatim
*>          LDA is INTEGER
*>          The leading dimension of the arrays A, AF. LDA >= max(M,N).
*> \endverbatim
*>
*> \param[in] B
*> \verbatim
*>          B is COMPLEX array, dimension (LDB,P)
*>          The N-by-P matrix A.
*> \endverbatim
*>
*> \param[out] BF
*> \verbatim
*>          BF is COMPLEX array, dimension (LDB,P)
*> \endverbatim
*>
*> \param[in] LDB
*> \verbatim
*>          LDB is INTEGER
*>          The leading dimension of the arrays B, BF. LDB >= max(P,N).
*> \endverbatim
*>
*> \param[in] D
*> \verbatim
*>          D is COMPLEX array, dimension( N )
*>          On input, the left hand side of the GLM.
*> \endverbatim
*>
*> \param[out] DF
*> \verbatim
*>          DF is COMPLEX array, dimension( N )
*> \endverbatim
*>
*> \param[out] X
*> \verbatim
*>          X is COMPLEX array, dimension( M )
*>          solution vector X in the GLM problem.
*> \endverbatim
*>
*> \param[out] U
*> \verbatim
*>          U is COMPLEX array, dimension( P )
*>          solution vector U in the GLM problem.
*> \endverbatim
*>
*> \param[out] WORK
*> \verbatim
*>          WORK is COMPLEX array, dimension (LWORK)
*> \endverbatim
*>
*> \param[in] LWORK
*> \verbatim
*>          LWORK is INTEGER
*>          The dimension of the array WORK.
*> \endverbatim
*>
*> \param[out] RWORK
*> \verbatim
*>          RWORK is REAL array, dimension (M)
*> \endverbatim
*>
*> \param[out] RESULT
*> \verbatim
*>          RESULT is REAL
*>          The test ratio:
*>                           norm( d - A*x - B*u )
*>            RESULT = -----------------------------------------
*>                     (norm(A)+norm(B))*(norm(x)+norm(u))*EPS
*> \endverbatim
*
*  Authors:
*  ========
*
*> \author Univ. of Tennessee
*> \author Univ. of California Berkeley
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
*> \date November 2011
*
*> \ingroup complex_eig
*
*  =====================================================================
      SUBROUTINE CGLMTS( N, M, P, A, AF, LDA, B, BF, LDB, D, DF,
     $                   X, U, WORK, LWORK, RWORK, RESULT )
*
*  -- LAPACK test routine (version 3.4.0) --
*  -- LAPACK is a software package provided by Univ. of Tennessee,    --
*  -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
*     November 2011
*
*     .. Scalar Arguments ..
      INTEGER            LDA, LDB, LWORK, M, P, N
      REAL               RESULT
*     ..
*     .. Array Arguments ..
      REAL               RWORK( * )
      COMPLEX            A( LDA, * ), AF( LDA, * ), B( LDB, * ),
     $                   BF( LDB, * ), D( * ), DF( * ), U( * ),
     $                   WORK( LWORK ), X( * )
*
*  ====================================================================
*
*     .. Parameters ..
      REAL               ZERO
      PARAMETER          ( ZERO = 0.0E+0 )
      COMPLEX            CONE
      PARAMETER          ( CONE = 1.0E+0 )
*     ..
*     .. Local Scalars ..
      INTEGER            INFO
      REAL               ANORM, BNORM, EPS, XNORM, YNORM, DNORM, UNFL
*     ..
*     .. External Functions ..
      REAL               SCASUM, SLAMCH, CLANGE
      EXTERNAL           SCASUM, SLAMCH, CLANGE
*     ..
*     .. External Subroutines ..
      EXTERNAL           CLACPY
*
*     .. Intrinsic Functions ..
      INTRINSIC          MAX
*     ..
*     .. Executable Statements ..
*
      EPS = SLAMCH( 'Epsilon' )
      UNFL = SLAMCH( 'Safe minimum' )
      ANORM = MAX( CLANGE( '1', N, M, A, LDA, RWORK ), UNFL )
      BNORM = MAX( CLANGE( '1', N, P, B, LDB, RWORK ), UNFL )
*
*     Copy the matrices A and B to the arrays AF and BF,
*     and the vector D the array DF.
*
      CALL CLACPY( 'Full', N, M, A, LDA, AF, LDA )
      CALL CLACPY( 'Full', N, P, B, LDB, BF, LDB )
      CALL CCOPY( N, D, 1, DF, 1 )
*
*     Solve GLM problem
*
      CALL CGGGLM( N, M, P, AF, LDA, BF, LDB, DF, X, U, WORK, LWORK,
     $             INFO )
*
*     Test the residual for the solution of LSE
*
*                       norm( d - A*x - B*u )
*       RESULT = -----------------------------------------
*                (norm(A)+norm(B))*(norm(x)+norm(u))*EPS
*
      CALL CCOPY( N, D, 1, DF, 1 )
      CALL CGEMV( 'No transpose', N, M, -CONE, A, LDA, X, 1, CONE,
     $            DF, 1 )
*
      CALL CGEMV( 'No transpose', N, P, -CONE, B, LDB, U, 1, CONE,
     $            DF, 1 )
*
      DNORM = SCASUM( N, DF, 1 )
      XNORM = SCASUM( M, X, 1 ) + SCASUM( P, U, 1 )
      YNORM = ANORM + BNORM
*
      IF( XNORM.LE.ZERO ) THEN
         RESULT = ZERO
      ELSE
         RESULT =  ( ( DNORM / YNORM ) / XNORM ) /EPS
      END IF
*
      RETURN
*
*     End of CGLMTS
*
      END


SUBROUTINE p84(input_file,output_file)
!-------------------------------------------------------------------------
! Program 8.4 Plane or axisymmetric transient analysis using 4-node
!             rectangular quadrilaterals. Mesh numbered in x(r)- or y(z)-
!             direction. Implicit time integration using the "theta"
!             method.
!-------------------------------------------------------------------------
 USE main
 USE geom
 IMPLICIT NONE
 CHARACTER(len=60),INTENT(IN) :: input_file
 CHARACTER(len=60),INTENT(OUT) :: output_file
 INTEGER,PARAMETER::iwp=SELECTED_REAL_KIND(15)
 INTEGER::fixed_freedoms,i,iel,j,nci,ndim=2,nels,neq,nip=4,nlen,nn,nod=4, &
   npri,np_types,nres,nstep,ntime,nxe,nye
 REAL(iwp)::det,dtim,one=1.0_iwp,penalty=1.0e20_iwp,theta,time,           &
   zero=0.0_iwp
 CHARACTER(len=15)::argv,dir,element='quadrilateral',type_2d
!-----------------------dynamic arrays------------------------------------
 INTEGER,ALLOCATABLE::etype(:),g_num(:,:),node(:),num(:),kdiag(:)
 REAL(iwp),ALLOCATABLE::bp(:),coord(:,:),der(:,:),deriv(:,:),fun(:),      &
   gc(:),g_coord(:,:),jac(:,:),kay(:,:),kc(:,:),kv(:),loads(:),newlo(:),  &
   ntn(:,:),mm(:,:),points(:,:),prop(:,:),storbp(:),value(:),weights(:),  &
   x_coords(:),y_coords(:)
!-------------------------input and initialisation------------------------

 OPEN(10,FILE=input_file)
 OPEN(11,FILE=output_file)
 READ(10,*)type_2d,dir,nxe,nye,np_types
 CALL mesh_size(element,nod,nels,nn,nxe,nye)
 neq=nn
 ALLOCATE(points(nip,ndim),weights(nip),kay(ndim,ndim),coord(nod,ndim),   &
   fun(nod),jac(ndim,ndim),g_coord(ndim,nn),der(ndim,nod),deriv(ndim,nod),&
   mm(nod,nod),g_num(nod,nels),kc(nod,nod),ntn(nod,nod),num(nod),         &
   etype(nels),kdiag(neq),loads(0:neq),newlo(0:neq),x_coords(nxe+1),      &
   y_coords(nye+1),prop(ndim,np_types),gc(ndim))
 READ(10,*)prop
 etype=1
 if(np_types>1)read(10,*)etype
 READ(10,*)x_coords,y_coords
 READ(10,*)dtim,nstep,theta,npri,nres,ntime
 kdiag=0
! ----------loop the elements to set up global geometry and kdiag --------
 elements_1: DO iel=1,nels
   CALL geom_rect(element,iel,x_coords,y_coords,coord,num,dir)
   g_num(:,iel)=num
   g_coord(:,num)=TRANSPOSE(coord)
   CALL fkdiag(kdiag,num)
 END DO elements_1
 CALL mesh(g_coord,g_num,argv,nlen,12)
 DO i=2,neq
   kdiag(i)=kdiag(i)+kdiag(i-1)
 END DO
 ALLOCATE(kv(kdiag(neq)),bp(kdiag(neq)))
 WRITE(11,'(2(a,i5))')                                                    &
   " There are",neq," equations and the skyline storage is",kdiag(neq)
 CALL sample(element,points,weights)
 bp=zero
 kv=zero
 gc=one
!-----------------------global conductivity and "mass" matrix assembly----
 elements_2: DO iel=1,nels
   kay=zero
   DO i=1,ndim
     kay(i,i)=prop(i,etype(iel))
   END DO
   num=g_num(:,iel)
   coord=TRANSPOSE(g_coord(:,num))
   kc=zero
   mm=zero
   gauss_pts: DO i=1,nip
     CALL shape_der(der,points,i)
     CALL shape_fun(fun,points,i)
     jac=MATMUL(der,coord)
     det=determinant(jac)
     CALL invert(jac)
     deriv=MATMUL(jac,der)
     if(type_2d=='axisymmetric')gc=MATMUL(fun,coord)
     kc=kc+MATMUL(MATMUL(TRANSPOSE(deriv),kay),deriv)*det*weights(i)*gc(1)
     CALL cross_product(fun,fun,ntn)
     mm=mm+ntn*det*weights(i)*gc(1)
   END DO gauss_pts
   CALL fsparv(kv,kc,num,kdiag)
   CALL fsparv(bp,mm,num,kdiag)
 END DO elements_2
 kv=kv*theta*dtim
 bp=bp+kv
 kv=bp-kv/theta
!-----------------------specify initial and boundary values---------------
 READ(10,*)loads(1:)
 loads(0)=zero
 READ(10,*)fixed_freedoms
 IF(fixed_freedoms/=0)then
   ALLOCATE(node(fixed_freedoms),value(fixed_freedoms),                   &
            storbp(fixed_freedoms))
   READ(10,*)(node(i),value(i),i=1,fixed_freedoms)
   bp(kdiag(node))=bp(kdiag(node))+penalty
   storbp=bp(kdiag(node))
 END IF
!-----------------------factorise equations-------------------------------
 CALL sparin(bp,kdiag)
!-----------------------time stepping loop--------------------------------
 WRITE(11,'(/a,i3,a)')"    Time      Pressure (node",nres,")"
 WRITE(11,'(2e12.4)')0.0,loads(nres)
 timesteps: DO j=1,nstep
   time=j*dtim
   CALL linmul_sky(kv,loads,newlo,kdiag)
   IF(fixed_freedoms/=0)newlo(node)=storbp*value
   CALL spabac(bp,newlo,kdiag)
   loads=newlo
   IF(nod==4.AND.j==ntime)THEN
     READ(10,*)nci
     CALL contour(loads,g_coord,g_num,nci,argv,nlen,13)
     END IF
   IF(j/npri*npri==j)WRITE(11,'(2e12.4)')time,loads(nres)
 END DO timesteps

END SUBROUTINE p84


      SUBROUTINE VECROT(ROTMTX,VECIN,VECOUT)
      IMPLICIT REAL*8 (A-H,O-Z)
C
C  THIS ROUTINE USES A 3-BY-3 MATRIX TO ROTATE A VECTOR TO ANOTHER
C  VECTOR.
C
C  VAR     DIM  TYPE  I/O  DESCRIPTION
C  ---     ---  ----  ---  -----------
C
C  ROTMTX  3,3  R*8   I    ROTATION MATRIX.
C
C  VECIN   3    R*8   I    VECTOR TO BE ROTATED.
C
C  VECOUT  3    R*8   O    VECTOR RESULTING FROM ROTATION.
C
C
C
C***********************************************************************
C
C  CODED BY C PETRUZZO. 6/82.
C  MODIFIED............
C
C***********************************************************************
C
      REAL*8 ROTMTX(3,3),VECIN(3),VECOUT(3),TEMP(3)
C
      TEMP(1) = ROTMTX(1,1)*VECIN(1) + ROTMTX(1,2)*VECIN(2) +
     1             ROTMTX(1,3)*VECIN(3)
      TEMP(2) = ROTMTX(2,1)*VECIN(1) + ROTMTX(2,2)*VECIN(2) +
     1             ROTMTX(2,3)*VECIN(3)
      TEMP(3) = ROTMTX(3,1)*VECIN(1) + ROTMTX(3,2)*VECIN(2) +
     1             ROTMTX(3,3)*VECIN(3)
C
      VECOUT(1)=TEMP(1)
      VECOUT(2)=TEMP(2)
      VECOUT(3)=TEMP(3)
C
      RETURN
      END


use std
implicit none

type(IO_) :: f
type(Math_) :: math
integer(int32) :: num_sampling = 1300 ! =12 : aliasing, =1000: HQ wave
real(real64),allocatable   :: t(:), Ft(:)

! from t=-100 ~ 100, 1000 sampling
t = linspace([0.0d0,10.0d0],num_sampling)

! create sampling wave
Ft = zeros(num_sampling)
Ft(:) = sin(2.0d0*Math%PI*t) ! sin( 2*PI*t )

! Export as txt file
call f%open("sin_wave_hq.txt","w")
call f%write(t,Ft)
call f%close()

! show
call f%plot("sin_wave_hq.txt","with lines")

end