      SUBROUTINE MA02FD( X1, X2, C, S, INFO )
C
C     SLICOT RELEASE 5.7.
C
C     Copyright (c) 2002-2020 NICONET e.V.
C
C     PURPOSE
C
C     To compute the coefficients c and s (c^2 + s^2 = 1) for a modified
C     hyperbolic plane rotation, such that,
C
C         y1 := 1/c * x1 - s/c * x2 = sqrt(x1^2 - x2^2),
C         y2 :=  -s * y1 +  c  * x2 = 0,
C
C     given two real numbers x1 and x2, satisfying either x1 = x2 = 0,
C     or abs(x2) < abs(x1).
C
C     ARGUMENTS
C
C     Input/Output Parameters
C
C     X1      (input/output) DOUBLE PRECISION
C             On entry, the real number x1.
C             On exit, the real number y1.
C
C     X2      (input) DOUBLE PRECISION
C             The real number x2.
C             The values x1 and x2 should satisfy either x1 = x2 = 0, or
C             abs(x2) < abs(x1).
C
C     C       (output) DOUBLE PRECISION
C             The cosines c of the modified hyperbolic plane rotation.
C
C     S       (output) DOUBLE PRECISION
C             The sines s of the modified hyperbolic plane rotation.
C
C     Error Indicator
C
C     INFO    INTEGER
C             = 0:  succesful exit;
C             = 1:  if abs(x2) >= abs(x1) and either x1 <> 0 or x2 <> 0.
C
C     CONTRIBUTOR
C
C     D. Kressner, Technical Univ. Chemnitz, Germany, June 2000.
C
C     REVISIONS
C
C     V. Sima, Katholieke Univ. Leuven, Belgium, June 2000.
C
C     KEYWORDS
C
C     Orthogonal transformation, plane rotation.
C
C     *****************************************************************
C
C     .. Parameters ..
      DOUBLE PRECISION  ONE, ZERO
      PARAMETER         ( ONE = 1.0D0, ZERO = 0.0D0 )
C     .. Scalar Arguments ..
      DOUBLE PRECISION  X1, X2, C, S
      INTEGER           INFO
C     .. Intrinsic Functions ..
      INTRINSIC         ABS, SIGN, SQRT
C     .. Executable Statements ..
C
      IF ( ( X1.NE.ZERO .OR. X2.NE.ZERO ) .AND.
     $     ABS( X2 ).GE.ABS( X1 ) ) THEN
         INFO = 1
      ELSE
         INFO = 0
         IF ( X1.EQ.ZERO ) THEN
            S = ZERO
            C = ONE
         ELSE
            S = X2 / X1
C
C           No overflows could appear in the next statement; underflows
C           are possible if X2 is tiny and X1 is huge, but then
C              abs(C) = ONE - delta,
C           where delta is much less than machine precision.
C
            C  = SIGN( SQRT( ONE - S ) * SQRT( ONE + S ), X1 )
            X1 = C * X1
         END IF
      END IF
C
      RETURN
C *** Last line of MA02FD ***
      END


C ***********************************************************
C
      DOUBLE PRECISION FUNCTION DONTR5(I,N,X,CONT,XSOL,HSOL)
C ----------------------------------------------------------
C     THIS FUNCTION CAN BE USED FOR CONINUOUS OUTPUT. IT PROVIDES AN
C     APPROXIMATION TO THE I-TH COMPONENT OF THE SOLUTION DERIVATIVE AT .
C     X. IT GIVES THE VALUE OF THE COLLOCATION POLYNOMIAL, DEFINED FOR
C     THE LAST SUCCESSFULLY COMPUTED STEP (BY DELAY5).
C ----------------------------------------------------------
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      INTEGER, PARAMETER :: DP=kind(1D0)
      REAL(kind=DP), dimension(1), intent(in) ::  CONT
C --- REQUIRED CONSTANTS
      COMMON /CONSTN/C1,C2,C1M1,C2M1,C1MC2

      N2=2*N
      N3=3*N

      S=(X-XSOL)/HSOL

	DONTR5=(CONT(I+N)+
     &   (S-C2M1)*(CONT(I+N2)+CONT(I+N3)*(S-C1M1))+
     &    S*(CONT(I+N2)+CONT(I+N3)*(2.*S-C1M1-C2M1)))/HSOL

      RETURN
      END
C
C     END OF FUNCTION DONTR5
C
C ***********************************************************


c
c  . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . .
c  .                                                             .
c  .                  copyright (c) 1998 by UCAR                 .
c  .                                                             .
c  .       University Corporation for Atmospheric Research       .
c  .                                                             .
c  .                      all rights reserved                    .
c  .                                                             .
c  .                                                             .
c  .                         SPHEREPACK                          .
c  .                                                             .
c  . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . .
c
c
c ... file gradgs.f
c
c     this file includes documentation and code for
c     subroutine gradgs         i
c
c ... files which must be loaded with gradgec.f
c
c     sphcom.f, hrfft.f, shags.f,vhsgs.f
c
c     subroutine gradgs(nlat,nlon,isym,nt,v,w,idvw,jdvw,a,b,mdab,ndab,
c    +                  wvhsgs,lvhsgs,work,lwork,ierror)
c
C*PL*ERROR* Comment line too long
c     given the scalar spherical harmonic coefficients a and b, precomputed
C*PL*ERROR* Comment line too long
c     by subroutine shags for a scalar field sf, subroutine gradgs computes
c     an irrotational vector field (v,w) such that
c
c           gradient(sf) = (v,w).
c
c     v is the colatitudinal and w is the east longitudinal component
c     of the gradient.  i.e.,
c
c            v(i,j) = d(sf(i,j))/dtheta
c
c     and
c
c            w(i,j) = 1/sint*d(sf(i,j))/dlambda
c
c     at the gaussian colatitude point theta(i) (see nlat as input
c     parameter) and longitude lambda(j) = (j-1)*2*pi/nlon where
c     sint = sin(theta(i)).
c
c
c     input parameters
c
c     nlat   the number of points in the gaussian colatitude grid on the
C*PL*ERROR* Comment line too long
c            full sphere. these lie in the interval (0,pi) and are computed
C*PL*ERROR* Comment line too long
c            in radians in theta(1) <...< theta(nlat) by subroutine gaqd.
C*PL*ERROR* Comment line too long
c            if nlat is odd the equator will be included as the grid point
c            theta((nlat+1)/2).  if nlat is even the equator will be
c            excluded as a grid point and will lie half way between
c            theta(nlat/2) and theta(nlat/2+1). nlat must be at least 3.
c            note: on the half sphere, the number of grid points in the
c            colatitudinal direction is nlat/2 if nlat is even or
c            (nlat+1)/2 if nlat is odd.
c
c     nlon   the number of distinct londitude points.  nlon determines
c            the grid increment in longitude as 2*pi/nlon. for example
c            nlon = 72 for a five degree grid. nlon must be greater than
c            3.  the efficiency of the computation is improved when nlon
c            is a product of small prime numbers.
c
c
c     isym   this has the same value as the isym that was input to
c            subroutine shags to compute the arrays a and b from the
c            scalar field sf.  isym determines whether (v,w) are
c            computed on the full or half sphere as follows:
c
c      = 0
c
c           sf is not symmetric about the equator. in this case
c           the vector field (v,w) is computed on the entire sphere.
c           i.e., in the arrays  v(i,j),w(i,j) for i=1,...,nlat and
c           j=1,...,nlon.
c
c      = 1
c
c           sf is antisymmetric about the equator. in this case w is
c           antisymmetric and v is symmetric about the equator. w
c           and v are computed on the northern hemisphere only.  i.e.,
c           if nlat is odd they are computed for i=1,...,(nlat+1)/2
c           and j=1,...,nlon.  if nlat is even they are computed for
c           i=1,...,nlat/2 and j=1,...,nlon.
c
c      = 2
c
c           sf is symmetric about the equator. in this case w is
c           symmetric and v is antisymmetric about the equator. w
c           and v are computed on the northern hemisphere only.  i.e.,
c           if nlat is odd they are computed for i=1,...,(nlat+1)/2
c           and j=1,...,nlon.  if nlat is even they are computed for
c           i=1,...,nlat/2 and j=1,...,nlon.
c
c
c     nt     nt is the number of scalar and vector fields.  some
c            computational efficiency is obtained for multiple fields.
C*PL*ERROR* Comment line too long
c            the arrays a,b,v, and w can be three dimensional corresponding
c            to an indexed multiple array sf.  in this case, multiple
c            vector synthesis will be performed to compute each vector
c            field.  the third index for a,b,v, and w is the synthesis
c            index which assumes the values k = 1,...,nt.  for a single
c            synthesis set nt = 1.  the description of the remaining
C*PL*ERROR* Comment line too long
c            parameters is simplified by assuming that nt=1 or that a,b,v,
c            and w are two dimensional arrays.
c
c     idvw   the first dimension of the arrays v,w as it appears in
c            the program that calls gradgs. if isym = 0 then idvw
c            must be at least nlat.  if isym = 1 or 2 and nlat is
c            even then idvw must be at least nlat/2. if isym = 1 or 2
c            and nlat is odd then idvw must be at least (nlat+1)/2.
c
c     jdvw   the second dimension of the arrays v,w as it appears in
c            the program that calls gradgs. jdvw must be at least nlon.
c
c     a,b    two or three dimensional arrays (see input parameter nt)
c            that contain scalar spherical harmonic coefficients
C*PL*ERROR* Comment line too long
c            of the scalar field array sf as computed by subroutine shags.
c     ***    a,b must be computed by shags prior to calling gradgs.
c
c     mdab   the first dimension of the arrays a and b as it appears in
c            the program that calls gradgs (and shags). mdab must be at
c            least min0(nlat,(nlon+2)/2) if nlon is even or at least
c            min0(nlat,(nlon+1)/2) if nlon is odd.
c
c     ndab   the second dimension of the arrays a and b as it appears in
c            the program that calls gradgs (and shags). ndab must be at
c            least nlat.
c
c
c     wvhsgs an array which must be initialized by subroutine vhsgsi.
c            once initialized,
c            wvhsgs can be used repeatedly by gradgs as long as nlon
c            and nlat remain unchanged.  wvhsgs must not be altered
c            between calls of gradgs.
c
c
c     lvhsgs the dimension of the array wvhsgs as it appears in the
c            program that calls grradgs.  define
c
c               l1 = min0(nlat,nlon/2) if nlon is even or
c               l1 = min0(nlat,(nlon+1)/2) if nlon is odd
c
c            and
c
c               l2 = nlat/2        if nlat is even or
c               l2 = (nlat+1)/2    if nlat is odd
c
c            then lvhsgs must be at least
c
c                 l1*l2*(nlat+nlat-l1+1)+nlon+15+2*nlat
c
c
c     work   a work array that does not have to be saved.
c
c     lwork  the dimension of the array work as it appears in the
c            program that calls gradgs. define
c
c               l1 = min0(nlat,nlon/2) if nlon is even or
c               l1 = min0(nlat,(nlon+1)/2) if nlon is odd
c
c            and
c
c               l2 = nlat/2                  if nlat is even or
c               l2 = (nlat+1)/2              if nlat is odd
c
c            if isym = 0, lwork must be greater than or equal to
c
c               nlat*((2*nt+1)*nlon+2*l1*nt+1).
c
c            if isym = 1 or 2, lwork must be greater than or equal to
c
c               (2*nt+1)*l2*nlon+nlat*(2*l1*nt+1).
c
c
c     **************************************************************
c
c     output parameters
c
c
C*PL*ERROR* Comment line too long
c     v,w   two or three dimensional arrays (see input parameter nt) that
C*PL*ERROR* Comment line too long
c           contain an irrotational vector field such that the gradient of
c           the scalar field sf is (v,w).  w(i,j) is the east longitude
C*PL*ERROR* Comment line too long
c           component and v(i,j) is the colatitudinal component of velocity
C*PL*ERROR* Comment line too long
c           at gaussian colatitude and longitude lambda(j) = (j-1)*2*pi/nlon
c           the indices for v and w are defined at the input parameter
C*PL*ERROR* Comment line too long
c           isym.  the vorticity of (v,w) is zero.  note that any nonzero
C*PL*ERROR* Comment line too long
c           vector field on the sphere will be multiple valued at the poles
c           [reference swarztrauber].
c
c
c  ierror   = 0  no errors
c           = 1  error in the specification of nlat
c           = 2  error in the specification of nlon
c           = 3  error in the specification of isym
c           = 4  error in the specification of nt
c           = 5  error in the specification of idvw
c           = 6  error in the specification of jdvw
c           = 7  error in the specification of mdab
c           = 8  error in the specification of ndab
c           = 9  error in the specification of lvhsgs
c           = 10 error in the specification of lwork
c **********************************************************************
c
c
      SUBROUTINE DGRADGS(NLAT,NLON,ISYM,NT,V,W,IDVW,JDVW,A,B,MDAB,NDAB,
     +                  WVHSGS,LVHSGS,WORK,LWORK,IERROR)
      DOUBLE PRECISION V
      DOUBLE PRECISION W
      DOUBLE PRECISION A
      DOUBLE PRECISION B
      DOUBLE PRECISION WVHSGS
      DOUBLE PRECISION WORK
      DIMENSION V(IDVW,JDVW,NT),W(IDVW,JDVW,NT)
      DIMENSION A(MDAB,NDAB,NT),B(MDAB,NDAB,NT)
      DIMENSION WVHSGS(LVHSGS),WORK(LWORK)
c
c     check input parameters
c
      IERROR = 1
      IF (NLAT.LT.3) RETURN
      IERROR = 2
      IF (NLON.LT.4) RETURN
      IERROR = 3
      IF (ISYM.LT.0 .OR. ISYM.GT.2) RETURN
      IERROR = 4
      IF (NT.LT.0) RETURN
      IERROR = 5
      IMID = (NLAT+1)/2
      IF ((ISYM.EQ.0.AND.IDVW.LT.NLAT) .OR.
     +    (ISYM.NE.0.AND.IDVW.LT.IMID)) RETURN
      IERROR = 6
      IF (JDVW.LT.NLON) RETURN
      IERROR = 7
      MMAX = MIN0(NLAT, (NLON+1)/2)
      IF (MDAB.LT.MIN0(NLAT, (NLON+2)/2)) RETURN
      IERROR = 8
      IF (NDAB.LT.NLAT) RETURN
      IERROR = 9
c
c     verify minimum saved work space length
c
      IDZ = (MMAX* (NLAT+NLAT-MMAX+1))/2
      LZIMN = IDZ*IMID
      LGDMIN = LZIMN + LZIMN + NLON + 15
      IF (LVHSGS.LT.LGDMIN) RETURN
      IERROR = 10
c
c     verify minimum unsaved work space length
c
      MN = MMAX*NLAT*NT
      IDV = NLAT
      IF (ISYM.NE.0) IDV = IMID
      LNL = NT*IDV*NLON
      LWKMIN = LNL + LNL + IDV*NLON + 2*MN + NLAT
      IF (LWORK.LT.LWKMIN) RETURN
      IERROR = 0
c
c     set work space pointers
c
      IBR = 1
      IBI = IBR + MN
      IS = IBI + MN
      IWK = IS + NLAT
      LIWK = LWORK - 2*MN - NLAT
      CALL DGRADGS1(NLAT,NLON,ISYM,NT,V,W,IDVW,JDVW,WORK(IBR),WORK(IBI),
     +             MMAX,WORK(IS),MDAB,NDAB,A,B,WVHSGS,LVHSGS,WORK(IWK),
     +             LIWK,IERROR)
      RETURN
      END

      SUBROUTINE DGRADGS1(NLAT,NLON,ISYM,NT,V,W,IDVW,JDVW,BR,BI,MMAX,
     +                   SQNN,MDAB,NDAB,A,B,WVHSGS,LVHSGS,WK,LWK,IERROR)
      DOUBLE PRECISION V
      DOUBLE PRECISION W
      DOUBLE PRECISION BR
      DOUBLE PRECISION BI
      DOUBLE PRECISION SQNN
      DOUBLE PRECISION A
      DOUBLE PRECISION B
      DOUBLE PRECISION WVHSGS
      DOUBLE PRECISION WK
      DOUBLE PRECISION FN
      DOUBLE PRECISION CR
      DOUBLE PRECISION CI
      DIMENSION V(IDVW,JDVW,NT),W(IDVW,JDVW,NT)
      DIMENSION BR(MMAX,NLAT,NT),BI(MMAX,NLAT,NT),SQNN(NLAT)
      DIMENSION A(MDAB,NDAB,NT),B(MDAB,NDAB,NT)
      DIMENSION WVHSGS(LVHSGS),WK(LWK)
c
c     preset coefficient multiplyers in vector
c
      DO 1 N = 2,NLAT
          FN = DBLE(N-1)
          SQNN(N) = SQRT(FN* (FN+1.D0))
    1 CONTINUE
c
c     compute multiple vector fields coefficients
c
      DO 2 K = 1,NT
c
c     preset br,bi to 0.0
c
          DO 3 N = 1,NLAT
              DO 4 M = 1,MMAX
                  BR(M,N,K) = 0.0D0
                  BI(M,N,K) = 0.0D0
    4         CONTINUE
    3     CONTINUE
c
c     compute m=0 coefficients
c
          DO 5 N = 2,NLAT
              BR(1,N,K) = SQNN(N)*A(1,N,K)
              BI(1,N,K) = SQNN(N)*B(1,N,K)
    5     CONTINUE
c
c     compute m>0 coefficients
c
          DO 6 M = 2,MMAX
              DO 7 N = M,NLAT
                  BR(M,N,K) = SQNN(N)*A(M,N,K)
                  BI(M,N,K) = SQNN(N)*B(M,N,K)
    7         CONTINUE
    6     CONTINUE
    2 CONTINUE
c
c     set ityp for irrotational vector synthesis to compute gradient
c
      IF (ISYM.EQ.0) THEN
          ITYP = 1
      ELSE IF (ISYM.EQ.1) THEN
          ITYP = 4
      ELSE IF (ISYM.EQ.2) THEN
          ITYP = 7
      END IF
c
c     vector sythesize br,bi into (v,w) (cr,ci are dummy variables)
c
      CALL DVHSGS(NLAT,NLON,ITYP,NT,V,W,IDVW,JDVW,BR,BI,CR,CI,MMAX,NLAT,
     +           WVHSGS,LVHSGS,WK,LWK,IERROR)
      RETURN
      END


!---------------------------------------------------!
! Copyright (c) 2017 Shunsuke A. Sato               !
! Released under the MIT license                    !
! https://opensource.org/licenses/mit-license.php   !
!---------------------------------------------------!
subroutine hpsi_sp(u,hu,v)
  use global_variables
  implicit none
  real(dp) :: u(0:Nx),hu(0:Nx),tu(0-4:Nx+4),v(0:Nx)
! finite difference
  real(dp) :: c0,c1,c2,c3,c4
  integer :: ix

  c0=-0.5d0*cN0/(dx**2)
  c1=-0.5d0*cN1/(dx**2)
  c2=-0.5d0*cN2/(dx**2)
  c3=-0.5d0*cN3/(dx**2)
  c4=-0.5d0*cN4/(dx**2)

  tu = 0d0
  tu(0:Nx) = u(0:Nx)
  do ix = 0,Nx
    hu(ix) = c0*tu(ix) &
      + c1*(tu(ix+1)+tu(ix-1)) &
      + c2*(tu(ix+2)+tu(ix-2)) &
      + c3*(tu(ix+3)+tu(ix-3)) &
      + c4*(tu(ix+4)+tu(ix-4))
  end do

  hu(:) = hu(:) + v(:)*u(:)

  return
end subroutine hpsi_sp


      subroutine resid_eqipsi(n_a1,n_alpha,n_beta,n_iPHI,n_iPI,n_ipsi,np
     &1_a1,np1_alpha,np1_beta,np1_iPHI,np1_iPI,np1_ipsi,x,Nx,ht,myzero,z
     &epsdis,phys_bdy,res)
      implicit none
      integer i
      integer Nx
      real*8 ht
      real*8 myzero
      real*8 zepsdis
      real*8 n_a1(Nx)
      real*8 n_alpha(Nx)
      real*8 n_beta(Nx)
      real*8 n_iPHI(Nx)
      real*8 n_iPI(Nx)
      real*8 n_ipsi(Nx)
      real*8 np1_a1(Nx)
      real*8 np1_alpha(Nx)
      real*8 np1_beta(Nx)
      real*8 np1_iPHI(Nx)
      real*8 np1_iPI(Nx)
      real*8 np1_ipsi(Nx)
      real*8 x(Nx)
      integer phys_bdy(2)
      real*8 res
      real*8 qb
      res = 0.0D0
      if (phys_bdy(1) .eq. 1) then
      do i=1, 1, 1
      qb = np1_ipsi(i) - 0.1333333333333333D1 * np1_ipsi(i + 1) + 0.3333
     #333333333333D0 * np1_ipsi(i + 2)
      res = res + qb**2
      end do
      endif
      if (phys_bdy(1) .eq. 1) then
      do i=2, 2, 1
      qb = (-0.1D1 * n_ipsi(i) + np1_ipsi(i)) / ht - 0.5000000000000000D
     #0 * np1_alpha(i) / np1_a1(i) * np1_iPI(i) - 0.5000000000000000D0 *
     # np1_beta(i) * np1_iPHI(i) - 0.5000000000000000D0 * n_alpha(i) / n
     #_a1(i) * n_iPI(i) - 0.5000000000000000D0 * n_beta(i) * n_iPHI(i) +
     # 0.3125000000000000D-1 * zepsdis / ht * (0.7D1 * np1_ipsi(i) + np1
     #_ipsi(i + 2) - 0.4D1 * np1_ipsi(i + 1) - 0.4D1 * np1_ipsi(i - 1))
     #+ 0.3125000000000000D-1 * zepsdis / ht * (0.7D1 * n_ipsi(i) + n_ip
     #si(i + 2) - 0.4D1 * n_ipsi(i + 1) - 0.4D1 * n_ipsi(i - 1))
      res = res + qb**2
      end do
      endif
      do i=3, Nx-2, 1
      qb = (-0.1D1 * n_ipsi(i) + np1_ipsi(i)) / ht - 0.5000000000000000D
     #0 * np1_alpha(i) / np1_a1(i) * np1_iPI(i) - 0.5000000000000000D0 *
     # np1_beta(i) * np1_iPHI(i) - 0.5000000000000000D0 * n_alpha(i) / n
     #_a1(i) * n_iPI(i) - 0.5000000000000000D0 * n_beta(i) * n_iPHI(i) +
     # 0.3125000000000000D-1 * zepsdis / ht * (0.6D1 * np1_ipsi(i) + np1
     #_ipsi(i + 2) + np1_ipsi(i - 2) - 0.4D1 * np1_ipsi(i + 1) - 0.4D1 *
     # np1_ipsi(i - 1)) + 0.3125000000000000D-1 * zepsdis / ht * (0.6D1
     #* n_ipsi(i) + n_ipsi(i + 2) + n_ipsi(i - 2) - 0.4D1 * n_ipsi(i + 1
     #) - 0.4D1 * n_ipsi(i - 1))
      res = res + qb**2
      end do
      do i=Nx-1, Nx-1, 1
      qb = (-0.1D1 * n_ipsi(i) + np1_ipsi(i)) / ht - 0.5000000000000000D
     #0 * np1_alpha(i) / np1_a1(i) * np1_iPI(i) - 0.5000000000000000D0 *
     # np1_beta(i) * np1_iPHI(i) - 0.5000000000000000D0 * n_alpha(i) / n
     #_a1(i) * n_iPI(i) - 0.5000000000000000D0 * n_beta(i) * n_iPHI(i)
      res = res + qb**2
      end do
      if (phys_bdy(2) .eq. 1) then
      do i=Nx, Nx, 1
      qb = (-0.1D1 * n_ipsi(i) + np1_ipsi(i)) / ht - 0.1D1 * myzero * x(
     #i)
      res = res + qb**2
      end do
      endif
      res = sqrt(res/(1*Nx))
      END


	INTEGER*4 FUNCTION
     . SURVSIZE(ALPHA,POWER,M1,M2,A,F,M,R,ALT)
	IMPLICIT NONE
C
C-Description-----------------------------------------------------------
C
C  Function:
C	Determine the sample size needed to produce a specified level
C	of statistical power for survival data.
C
C  Input (provided by user):
C	ALPHA	Type I error probability (two tailed)
C	POWER	The desired statistical power',
C	M1	Median survival time on control treatment
C	M2	Median survival time on experimantal treatment
C	R=M2/M1 Ratio of median survival times for experimental subjects
C		relative to controls -or-
C		Relative hazard (risk) of the control treatment relative
C		to the experimental treatment
C	ALT	1 if input requires M1 and M2
C		2 if input requires M1 and R
C	A	The accrual time during which patients are recruited into
C		the study
C	F	Additional follow-up time after the end of patient
C		recruitment
C	M	Ratio of control to experimental patients
C  Output:
C		Number of experimental patients that must be recruited
C		in order to be able to detect a true ratio of median
C		survival times R with type I error probability ALPHA and power
C		POWER
C  Reference:
C	Schoenfeld DA, Richter JR: "Nomograms for Calculating the
C	Number of Patients Needed for a Clinical Trial With Survival
C	as an Endpoint" Biometrics 1982; 38: 163-170.
C
C  Notes:
C   .	This routine was written by Dale Plummer
C   .	Designed by William Dupont
C   .	Schoenfeld and Richter define BETA to equal the study power
C	rather than the type II error.  Otherwise the notation used
C	in this program is analogous to that used by these authors.
C
C-Declarations----------------------------------------------------------
C
C
C  Functions
C
	REAL*4 ZCRVALUE
C
C  Locals
C
	REAL*4 ALPHA,BETA,M1,M2,R,A,F,M
	INTEGER*4 ALT
	REAL*4 PA,GF,P,ZALPHA,ZBETA,MM,POWER
C
C-Code------------------------------------------------------------------
C
	IF (ALT.EQ.1) THEN
C	    ' Enter ALPHA, POWER, M1, M2, A, F, and M:  '
	    R=M2/M1
	ELSE
C	    ' Enter ALPHA, POWER, M1, R, A, F, and M:  '
	    M2=R*M1
	END IF
	IF (A.EQ.0) A=F*0.00004
C
C    Check for errors.  Return -999 if any found.
C
	IF (R.EQ.1.0) THEN
	    SURVSIZE=-999
		RETURN
	END IF
C
C    Do the real work.
C
	BETA=1.-POWER
	MM=(M1+M2)/2.
	PA=(1.-EXP(-LOG(2.)*A/MM))/(LOG(2.)*A/MM)
	GF=EXP(-LOG(2.)*F/MM)
	P=1.-PA*GF
	ZALPHA=ZCRVALUE(ALPHA/2.)
	ZBETA=ZCRVALUE(BETA)
	SURVSIZE=NINT( (ZALPHA+ZBETA)**2 * ((1.+1./M)/P)/(LOG(R))**2 )
	RETURN
	END


module linearsolvers
   implicit none
      integer,parameter :: ndf=2 !number of degrees of freedom
      integer,parameter :: dimen=1 !dimention of problem

      integer,parameter::inp=1 !input file
      integer,parameter::out=2 !output file
      integer,parameter::msh=3 !mesh file
      integer,parameter::bnd=4 !boundary file
      integer,parameter::tec=5 !the techplot file
      integer,parameter::dat=6 !mesh file itech
      integer,parameter::cur=8 !curve file
      integer,parameter::csv=11 !comma seperated file
      integer,parameter::vtu=13 !output file
      integer,parameter::OUTPUT_UNIT=7

   ! the default value for the smallest pivot that will be accepted
   ! using the linearsolvers subroutines.  pivots smaller than this
   ! threshold will cause premature termination of the linear equation
   ! solver and return false as the return value of the function.

   real*8, parameter :: default_smallest_pivot = 1.0e-6

contains

    FUNCTION SAWTOOTH(TIME)
    IMPLICIT NONE
    REAL*8::TIME,SAWTOOTH
    SAWTOOTH=4*(ABS(TIME+0.25-FLOOR(TIME+0.75))-0.25)
    ENDFUNCTION SAWTOOTH

      subroutine lapack_gesv(a,b)
      implicit none
      integer, parameter :: nmax=1000

! ============================================================================
! name        : lapack solver compact
! author      : amir
! version     :
! copyright   : your copyright notice
! description : this solves a * x=b and put the solution
! into the b vector
! ============================================================================

real*8::a(:,:),b(:)
integer::n, nrhs, lda, ldb, info
integer,allocatable::ipiv(:)

n=size(b)
nrhs=1
lda=n
ldb=n;
allocate(ipiv(n))

call dgesv(n, nrhs, a, lda, ipiv, b, ldb, info)

endsubroutine lapack_gesv

    SUBROUTINE CONJGRAD_SOLVER(A,B,X)
    IMPLICIT NONE
    REAL*8,DIMENSION(:),INTENT(IN)::B
    REAL*8,DIMENSION(:)::X
    REAL*8,DIMENSION(:,:),INTENT(IN)::A
    REAL*8,DIMENSION(:),ALLOCATABLE :: P,R,AP
    REAL*8::RSOLD,RSNEW,ALPHA
    INTEGER::DIMEN
! ========================CONVERGENCE VARIABLES
    INTEGER::CG_ITERS,CG_LIMIT
    LOGICAL::CG_CONVERGED
    REAL*8::CG_TOL
! ================================================================

    DIMEN=SIZE(B)
    CG_TOL=1E-5
    CG_LIMIT=500
    CG_ITERS=0

    ALLOCATE(R(DIMEN),P(DIMEN),AP(DIMEN))
    R=B-MATMUL(A,X)
    P=R
    RSOLD=DOT_PRODUCT(R,R)

 PCG: DO; CG_ITERS=CG_ITERS+1;
    AP=MATMUL(A,P)
    ALPHA=RSOLD/DOT_PRODUCT(P,AP)
    X=X+ALPHA*P
    R=R-ALPHA*AP
    RSNEW=DOT_PRODUCT(R,R)
    CG_CONVERGED=(SQRT(RSNEW).LT.CG_TOL)
    IF(CG_CONVERGED.OR.CG_ITERS==CG_LIMIT)EXIT
       P=R+(RSNEW/RSOLD)*P;
       RSOLD=RSNEW;
     END DO PCG
     WRITE(1,*) CG_ITERS
    ENDSUBROUTINE CONJGRAD_SOLVER

    SUBROUTINE CONJGRAD_SOLVER_K(K,F,U)
    IMPLICIT NONE
    REAL*8,DIMENSION(:),INTENT(IN)::F
    REAL*8,DIMENSION(:)::U
    REAL*8,DIMENSION(:,:),INTENT(IN)::K
    REAL*8,DIMENSION(:),ALLOCATABLE :: P,R,Q
    REAL*8::RSOLD,RSNEW,ALPHA,BETA,RTR
    INTEGER::DIMEN
! ========================CONVERGENCE VARIABLES
    INTEGER::CG_ITERS,CG_LIMIT
    LOGICAL::CG_CONVERGED
    REAL*8::CG_TOL
! ================================================================

    DIMEN=SIZE(F)
    CG_TOL=1E-5
    CG_LIMIT=DIMEN*2
    CG_ITERS=0

    ALLOCATE(P(DIMEN),Q(DIMEN),R(DIMEN))
    R=F-MATMUL(K,U)
    P=R

 PCG: DO;
    CG_ITERS=CG_ITERS+1;
!     WRITE(1,*)CG_ITERS
    Q=MATMUL(K,P)
    RTR=DOT_PRODUCT(R,R)
    ALPHA=RTR/DOT_PRODUCT(P,Q)

    U=U+ALPHA*P
    R=R-ALPHA*Q
    BETA=DOT_PRODUCT(R,R)/RTR
    P=R+BETA*P

    CG_CONVERGED=(SQRT(DOT_PRODUCT(R,R)).LT.CG_TOL)
    IF(CG_CONVERGED.OR.CG_ITERS==CG_LIMIT)EXIT
     END DO PCG

     WRITE(1,*)CG_ITERS
    ENDSUBROUTINE CONJGRAD_SOLVER_k

   ! Use Gaussian elimination to calculate the solution to the linear
   ! system, A x = b.  No partial pivoting is done.  If the threshold
   ! argument is present, it is used as the smallest allowable pivot
   ! encountered in the computation; otherwise, DEFAULT_SMALLEST_PIVOT,
   ! defined in this module, is used as the default threshold.  The status
   ! of the computation is a logical returned by the function indicating
   ! the existence of a unique solution (.true.), or the nonexistence of
   ! a unique solution or threshold passed (.false.).

   ! Note that this is an inappropriate method for some linear systems.
   ! In particular, the linear system, M x = b, where M = 10e-12 I, will
   ! cause this routine to fail due to the presence of small pivots.
   ! However, this system is perfectly conditioned, with solution x = b.

   function gaussianElimination( A, b, x, threshold )
      implicit none
      logical gaussianElimination
      real*8, dimension( :, : ), intent( in ) :: A   ! Assume the shape of A.
      real*8, dimension( : ), intent( in ) ::  b     ! Assume the shape of b.
      real*8, dimension( : ), intent( out ) :: x     ! Assume the shape of x.

      ! The optional attribute specifies that the indicated argument
      ! is not required to be present in a call to the function.  The
      ! presence of optional arguments, such as threshold, may be checked
      ! using the intrinsic logical function, present (see below).

      REAL*8, optional, intent( in ) :: threshold

      integer i, j   ! Local index variables.
      integer N      ! Order of the linear system.
      real m         ! Multiplier.
      real :: smallestPivot = DEFAULT_SMALLEST_PIVOT

      ! Pointers to the appropriate rows of the matrix during the elmination.
      REAL*8, dimension( : ), pointer :: pivotRow
      REAL*8, dimension( : ), pointer :: currentRow

      ! Copies of the input arguments.  These copies are modified during
      ! the computation.
      ! The target attribute is used to indicate that the specified
      ! variable may be the target of a pointer.  Rows of ACopy are targets
      ! of pivotRow and currentRow, defined above.

      REAL*8, dimension( size( A, 1 ), size( A, 2) ), target :: ACopy
      REAL*8, dimension( size( b ) ) :: bCopy

      ! Status of the computation.  The return value of the function.
      logical successful
      ! Change the smallestPivot if the threshold argument was included.
      if ( present( threshold ) ) smallestPivot = abs( threshold )

      ! Setup the order of the system by using the intrinsic function size.
      ! size returns the number of elements in the specified dimension of
      ! an array or the total number of elements if the dimension is not
      ! specified.  Also assume that a unique solution exists initially.

      N = size( b )
      ACopy = A
      bCopy = b
      successful = .true.

      ! Begin the Gaussian elimination algorithm.
      ! Note the use of array sections in the following loops.  These
      ! eliminate the need for many do loops that are common in Fortran
      ! 77 code.
      ! Pointers are also used below and enhance the readability of the
      ! elimination process.

      ! Begin with the first row.

      i = 1

      ! Reduce the system to upper triangular.
      do while ( ( successful ) .and. ( i <= N-1 ) )

         ! The following statement is called pointer assignment and uses
         ! the pointer assignment operator `=>'.  This causes pivotRow
         ! to be an alias for the ith row of ACopy.  Note that this does
         ! not cause any movement of data.

         ! Assign the pivot row.
         pivotRow => ACopy( i, : )

         ! Verify that the current pivot is not smaller than smallestPivot.
         successful = abs( pivotRow( i ) ) >= smallestPivot

         if ( successful ) then

        ! Eliminate the entries in the pivot column below the pivot row.

        do j = i+1, N
           ! Assign the current row.
           currentRow => ACopy( j, : )

               ! Calculate the multiplier.
               m = currentRow( i ) / pivotRow( i )

               ! Perform the elimination step on currentRow and right
               ! hand side, bCopy.
               currentRow = m * pivotRow - currentRow
               bCopy( j ) = m * bCopy( i ) - bCopy( j )
        end do

         end if

         ! Move to the next row.
         i = i + 1

      end do

      ! Check the last pivot.
      pivotRow => ACopy( N, : )
      if ( successful ) successful = abs( pivotRow( N ) ) >= smallestPivot

      if ( successful ) then
         do i = N, 2, -1   ! Backward substitution.

            ! Determine the ith unknown, x( i ).
            x( i ) = bCopy( i ) / ACopy( i, i )

            ! Substitute the now known value of x( i ), reducing the order of
            ! the system by 1.
            bCopy = bCopy - x( i ) * ACopy( :, i )

         end do
      end if

      ! Determine the value of x( 1 ) as a special case.
      if ( successful ) x( 1 ) = bCopy( 1 ) / ACopy( 1, 1 )

      ! Prepare the return value of the function.
      gaussianElimination = successful

   end function gaussianElimination

   ! The LU decomposition of a matrix may be represented in a compact form
   ! existing in a single matrix, M,  if the assignments M=L and M=U are
   ! done (in that order).  The diagonal entries in L are assumed to be
   ! unity so that no storage space is necessary.  Instead, the diagonal
   ! of M is used to hold the diagonal entries of U.  This is a common
   ! method of storing the LU decomposition of a matrix.

   ! The algorithm belows makes an additional assumption concerning the
   ! pivots or diagonal elements of U.  Computation terminates if one of
   ! these pivots is smaller than the given or default threshold.  In this
   ! case, the LU decomposition is not formed.  Note that this algorithm
   ! successfully terminates if such an LU can be computed.  In this case
   ! the coefficient matrix, A, is nonsingular.  (No attempt for recovery,
   ! such as permutation of rows, is done.)

   ! Compute the LU decomposition of A, storing the result in LU so that
   ! A is not overwritten.  If the threshold argument is present, it is used
   ! as the smallest allowable pivot encountered in the computation;
   ! otherwise, DEFAULT_SMALLEST_PIVOT, defined in this module, is used as
   ! the default threshold during the computation.  The status of the
   ! computation is a logical returned by the function indicating the
   ! success (.true.) or failure (.false.) of the factorization
   ! After the computation, LU will contain the multipliers below the main
   ! diagonal (L) and the result after elimination on and above the main
   ! diagonal (U), so that A = L * U.

   function LUFactor ( A, LU, threshold )
      implicit none
      logical LUFactor
      REAL*8, dimension( :, : ), intent( in ) :: A
      REAL*8, dimension( :, : ), intent( out ) :: LU
      REAL*8, optional, intent( in ) :: threshold

      integer k, i
      integer N
      logical successful   ! Status of the computation.
      real :: smallestPivot = DEFAULT_SMALLEST_PIVOT

      ! Reassign the smallestPivot, set the order of the system, and
      ! copy A into LU as it will be written to during the factorization.

      if ( present( threshold ) ) smallestPivot = abs( threshold )
      N = size( A, 1 )
      LU = A

      ! Begin the LU factorization algorithm.
      ! The status of the computation is initially successful.
      successful = .true.

      k = 1   ! Begin with the first column.
      do while ( ( successful ) .and. ( k <= N-1 ) )

         ! Verify that the kth pivot is not smaller than smallestPivot.
         successful = abs( LU( k, k ) ) >= smallestPivot

         if ( successful ) then
            ! Calculate the multipliers (L) for the current column.
            LU( k+1:N, k ) = LU( k+1:N, k ) / LU( k, k )

            ! Perform elimination on the upper portion of the matrix (U).
            do i = k+1, N
               LU( i, k+1:N ) = LU( i, k+1:N ) - LU( i, k ) * LU( k, k+1:N )
            enddo

            k = k + 1   ! Move to the next column.
         end if

      enddo

      ! Prepare the return value of the function.
      LUFactor = successful

   end function LUFactor

   ! Let A = L*U where LU represents the LU decomposition of A stored in the
   ! format produced by LUFactor, A, L, U in R**(NxN).
   ! Solve the linear system, A x = b, using the LU decomposition of A stored
   ! in LU.  Since LU is the LU decomposition of A, A is nonsingular.
   ! Consequently, the columns of A constitute a basis for R**N.   So, there
   ! must exist a unique solution to the linear system A x = b.
   ! LUSolve returns the solution to this linear system.

   function LUSolve( LU, b ) result( x )
      implicit none
      REAL*8, dimension( :, : ), intent( in ) :: LU
      REAL*8, dimension( : ), intent( in ) :: b
      REAL*8, dimension( size( b ) ) :: x

      integer k
      integer N
      REAL*8, dimension( size( b ) ) :: bCopy

      ! Determine the order of the system and store a copy of b in bCopy
      ! as it is written during the computation.
      N = size( b )
      bCopy = b

      ! Assume LU is in the form of LU and solve the system in two steps.
      ! First, using forward elmination to solve L y = b, then using
      ! backward elmination to solve U x = y.  In both cases, the right
      ! hand side is overwritten with the solution as it is computed.

      ! Forward elimination.  Store the solution into the right hand side.
      do k = 1, N-1
         bCopy( k+1:N ) = bCopy( k+1:N ) - bCopy( k ) * LU( k+1:N, k )
      end do

      ! Backward elimination.  Store the solution into the right hand side.
      do k = N, 2, -1
         bCopy( k ) = bcopy( k ) / LU( k, k )
         bCopy( 1:k-1 ) = bCopy( 1:k-1 ) - bCopy( k ) * LU( 1:k-1, k )
      end do

      ! Solve for the 1st unknown as a special case.
      bCopy( 1 ) = bCopy( 1 ) / LU( 1, 1 )

      ! Assign a return value for the function via its result variable, x.
      x = bCopy

   end function LUSolve

   ! Output A in Matlab format, using name in the Matlab assignment statement.
   subroutine printMatrix( A, name )
      implicit none
      real*8, dimension( :, : ) :: A   ! Assume the shape of A.
      character name  ! Name for use in assignment, ie, name = ......

      integer n, m, i, j

      OPEN (OUTPUT_UNIT,file='matrixes_out.out')
      n = size( A, 1 )
      m = size( A, 2 )

      write(OUTPUT_UNIT, fmt="(a1,a5)", advance = "no" ) name, ' = [ '

      ! Output the matrix, except for the last row, which needs no `;'.
      do i = 1, n-1

         ! Output current row.
         do j = 1, m-1
            write( OUTPUT_UNIT, fmt="(f10.6,a2)", advance = "no" ) A( i, j ), ', '
         end do

         ! Output last element in row and end current row.
         write( OUTPUT_UNIT, fmt="(f10.6,a1)" ) A( i, m ), ';'

      end do

      ! Output the last row.
      do j = 1, m-1
         write( OUTPUT_UNIT, fmt="(f10.6,a2)", advance = "no" ) A( i, j ), ', '
      end do

      ! Output last element in row and end.
      write( OUTPUT_UNIT, fmt="(f10.6,a1)" ) A( i, m ), ']'

   end subroutine printMatrix

   subroutine printMatrix_int( A, name )
      implicit none
      integer, dimension( :, : ) :: A   ! Assume the shape of A.
      character name  ! Name for use in assignment, ie, name = ......

      integer n, m, i, j

      n = size( A, 1 )
      m = size( A, 2 )
    OPEN (OUTPUT_UNIT,file='matrixes_out.out')
      write( OUTPUT_UNIT, fmt="(a1,a5)", advance = "no" ) name, ' = [ '

      ! Output the matrix, except for the last row, which needs no `;'.
      do i = 1, n-1

         ! Output current row.
         do j = 1, m-1
            write( OUTPUT_UNIT, fmt="(I3,a2)", advance = "no" ) A( i, j ), ', '
         end do

         ! Output last element in row and end current row.
         write( OUTPUT_UNIT, fmt="(I3,a2)" ) A( i, m ), ';'

      end do

      ! Output the last row.
      do j = 1, m-1
         write( OUTPUT_UNIT, fmt="(I3,a2)", advance = "no" ) A( i, j ), ', '
      end do

      ! Output last element in row and end.
      write( 7, fmt="(I3,a2)" ) A( i, m ), ']'

   end subroutine printMatrix_int

   ! Output b in Matlab format, using name in the Matlab assignment statement.
   subroutine printVector_int( b, name )
      implicit none
      integer, dimension( : ) :: b   ! Assume the shape of b.
      character name   ! Name for use in assignment, ie, name = ......

      integer n, i
    OPEN (OUTPUT_UNIT,file='matrixes_out.out')
      n = size( b )

      write( OUTPUT_UNIT, fmt="(a1,a5)", advance = "no" ) name, ' = [ '

      do i = 1, n-1
         write( OUTPUT_UNIT, fmt = "(i3,a2)", advance = "no" ) b( i ), ', '
      end do

      write( OUTPUT_UNIT, fmt = "(i3,a2)" ) b( n ), ']'''

   end subroutine printVector_int

     subroutine printVector( b, name )
      implicit none
      REAL*8, dimension( : ) :: b   ! Assume the shape of b.
      character name   ! Name for use in assignment, ie, name = ......

      integer n, i

      n = size( b )
    OPEN (OUTPUT_UNIT,file='matrixes_out.out')

      write( OUTPUT_UNIT, fmt="(a1,a5)", advance = "no" ) name, ' = [ '

      do i = 1, n-1
         write( OUTPUT_UNIT, fmt = "(E14.5,a2)", advance = "no" ) b( i ), ', '
      end do

      write( OUTPUT_UNIT, fmt = "(E14.5,a2)" ) b( n ), ']'''

   end subroutine printVector

      SUBROUTINE SLVUNSYM(A,NRMAX,NCMAX,N,ITERM)
!C     _________________________________________________________________
!C
!C       Solver for BANDED UNSYMMETRIC system of algebraic equations
!C     ______________________________________________________________
!C
      IMPLICIT REAL*8 (A-H,O-Z)
      IMPLICIT INTEGER (I-N)
      INTEGER::NRMAX,NCMAX,N,ITERM
      REAL*8::A(NRMAX,NCMAX)
      CERO=1.0D-15
      PARE=CERO**2
      NBND=2*ITERM
      NBM=NBND-1
!C
!C     Begin elimination of the lower left
!C
      DO 80 I=1,N
      IF (DABS(A(I,ITERM)).LT.CERO) GO TO 10
      GO TO 20
   10 IF (DABS(A(I,ITERM)).LT.PARE) GO TO 110
   20 JLAST=MIN0(I+ITERM-1,N)
      L=ITERM+1
      DO 40 J=I,JLAST
      L=L-1
      IF (DABS(A(J,L)).LT.PARE) GO TO 40
      B=A(J,L)
      DO 30 K=L,NBND
   30 A(J,K)=A(J,K)/B
      IF (I.EQ.N) GO TO 90
   40 CONTINUE
      L=0
      JFIRST=I+1
      IF (JLAST.LE.I) GO TO 80
      DO 70 J=JFIRST,JLAST
      L=L+1
      IF (DABS(A(J,ITERM-L)).LT.PARE) GO TO 70
      DO 50 K=ITERM,NBM
   50 A(J,K-L)=A(J-L,K)-A(J,K-L)
      A(J,NBND)=A(J-L,NBND)-A(J,NBND)
      IF (I.GE.N-ITERM+1) GO TO 70
      DO 60 K=1,L
   60 A(J,NBND-K)=-A(J,NBND-K)
   70 CONTINUE
   80 CONTINUE
   90 L=ITERM-1
      DO 100 I=2,N
      DO 100 J=1,L
      IF (N+1-I+J.GT.N) GO TO 100
      A(N+1-I,NBND)=A(N+1-I,NBND)-A(N+1-I+J,NBND)*A(N+1-I,ITERM+J)
  100 CONTINUE
      RETURN
  110 WRITE (*,140) I,A(I,ITERM)
  140 FORMAT (/,2X,'Computation stopped in SLVUNSYM because zero appears on the main diagonal *** Eqn no. and value:',I5,E12.4)
      ENDSUBROUTINE SLVUNSYM

! -------------------------- MODULE cg.f90 ----------------------------

!************************************************************************
!*                                                                      *
!* Conjugate Gradient Method (CG Method)                                *
!* -------------------------------------                                *
!*                                                                      *
!* Programming language: ANSI C                                         *
!* Compiler:             Turbo C 2.0                                    *
!* Computer:             IBM PS/2 70 with 80387                         *
!* Sources:              [BUNS85], [SCHW], [MAES84]                     *
!* Author:               Juergen Dietel, Computer Center, RWTH Aachen   *
!* Date:                 7.31.1992                                      *
!*                                                                      *
!*             F90 version by J-P Moreau (without dynamic allocations). *
!*                                (www.jpmoreau.fr)                     *
!************************************************************************
Subroutine cg_method (    &     ! Conjugate Gradient Method
                       n, &     ! Size of the linear system
                       a, &     ! System matrix
                       y, &     ! right hand side
                       x, &     ! solution vector
                       fehler & ! error code
                     )
! original name: cg_verfahren()
integer::n
real*8, parameter :: ZERO=0.d0, MACH_EPS=2.d-16
real*8  a(0:n-1,0:n-1),x(0:n-1),y(0:n-1)
integer fehler
!************************************************************************
!* CG solves the linear system                                          *
!*                         A * X = Y                                    *
!* for a symmetric, positive definite matrix A via the conjugate        *
!* gradient method.                                                     *
!*                                                                      *
!* Input parameters:                                                    *
!* =================                                                    *
!* n  Size of the linear system                                         *
!* a  [0..n-1,0..n-1] system matrix A. Only the upper triangle of A is  *
!*    used.                                                             *
!* y  [0..n-1] vector of the right hand side                            *
!*                                                                      *
!* Output parameters:                                                   *
!* ==================                                                   *
!* x  [0..n-1] vector giving the solution                               *
!*                                                                      *
!* Return value:                                                        *
!* =============                                                        *
!* = 0: all is ok                                                       *
!* = 1: n < 2 or other disallowed input parameters                      *
!* = 2: memory exceeded                                                 *
!*                                                                      *
!************************************************************************
  real*8 d(0:n-1), &   ! (0..n-1) auxiliary vectors d and g
         g(0:n-1), &
         AmalD(0:n-1)  ! (0..n-1) auxiliary vector A * d
  real*8 alpha,    &   ! coefficient
         beta,     &   ! coefficient
         dividend, &   ! numerator and denominator of a fraction
         divisor,  &   ! respectively, used to compute alpha, beta
         hilf,     &   ! auxiliary variables
         hilf2,    &
         abstand,  &   ! distance of two successive approximations
                       ! for the solution vector x (taken in the
                       ! euclidean norm)
         xnorm         ! euklidean norm of x
  integer k, i, j      ! loop variables

  if (n < 2) then      ! invalid parameter?
    fehler=1
    return
  end if

  !------------------------------------------------------------------
  ! start with x at the origin
  !------------------------------------------------------------------
  do i = n - 1, 0, -1
    x(i) = ZERO
  end do

  !------------------------------------------------------------------
  ! initialize  d and g :
  ! d = -g = -(a*x - y) = y (since x = 0)
  !------------------------------------------------------------------
  do i = n - 1, 0, -1
    hilf = y(i)
    d(i) = hilf
    g(i) = -hilf
  end do

  !------------------------------------------------------------------
  ! perform at most n steps of the CG Method
  !------------------------------------------------------------------
  do k = n, 0, -1

    !----------------------------------------------------------------
    ! compute new alpha:
    ! alpha = -(d(transp) * g) / (d(transp) * (a * d))
    !----------------------------------------------------------------

    dividend = ZERO
    divisor  = ZERO

    do i = n - 1, 0, -1
      dividend = dividend + d(i) * g(i)
      hilf = ZERO
      do j = 0, i-1
        hilf = hilf + a(j,i) * d(j)
      end do
      do j = i, n-1
        hilf = hilf + a(i,j) * d(j)
      end do
      AmalD(i) = hilf
      divisor = divisor + d(i) * hilf
    end do

    if (divisor.eq.ZERO) then
      fehler=0
      return
    end if

    alpha = -dividend / divisor

    !----------------------------------------------------------------
    ! compute the norm of x und  alpha * d  and find a new x:
    ! x  =  x + alpha * d, then check whether x is close enough,
    ! in order to stop the process before n complete steps
    !----------------------------------------------------------------
    xnorm   = ZERO
    abstand = ZERO

    do i = n - 1, 0, -1
      hilf =  x(i)
      xnorm   = xnorm + hilf*hilf
      hilf2   =  alpha * d(i)
      abstand = abstand + hilf2*hilf2
      x(i)    =  hilf + hilf2
    end do

    if (abstand < MACH_EPS * xnorm) then
      fehler=0
      return
    end if

    !----------------------------------------------------------------
    ! compute new g:   g  =  g + alpha * (a * d)
    !----------------------------------------------------------------
    do i = n - 1, 0, -1
      g(i) = g(i) + alpha * AmalD(i)
    end do

    !----------------------------------------------------------------
    ! compute new beta :
    ! beta = (g(transp) * (a * d)) / (d(transp) * (a * d))
    !----------------------------------------------------------------
    dividend = ZERO
    do i = n - 1, 0, -1
      dividend = dividend + g(i) * AmalD(i)
    end do

    beta = dividend / divisor

    !----------------------------------------------------------------
    ! compute new d :   d  =  - g + beta * d
    !----------------------------------------------------------------
    do i = n - 1, 0, -1
      d(i) = -g(i) + beta * d(i)
    end do

  end do  !k loop

  fehler=0
  return
endSubroutine cg_method

! ---------------------------- END cg.cpp --------------------------

subroutine Gaussian_Elimination_Solver(a,y)
    integer :: k,i
    real*8::a(:,:),y(:)
    integer::n
    n=size(a,dim=1)

    do k = 1, n-1
        a(k+1: n, k) = a(k+1: n, k) / a(k, k)

        a(k+1: n, k+1: n) = a(k+1: n, k+1: n) - &
                matmul(a(k+1: n, k: k), a(k: k, k+1: n))
    end do

    ! L x = f  =>  x = L \ f
    do i = 1, n
        y(i) = y(i) - dot_product(a(i, 1: i-1), y(1: i-1))
    end do

    ! U y = x  =>  y = U \ x
    do i = n, 1, -1
        y(i) = y(i) - dot_product(a(i, i+1: n), y(i+1: n))
        y(i) = y(i) / a(i, i)
    end do

end subroutine Gaussian_Elimination_Solver

      FUNCTION NORM_VECT(A)
      REAL*8::A(:),NORM_VECT
      NORM_VECT=SQRT(DOT_PRODUCT(A,A))
      END FUNCTION NORM_VECT

      SUBROUTINE TENSOR_TRANSFORM_RANK_1(TRANSFORMATION,TENSOR_LOCAL_COORD,TENSOR_GLOBAL_COORD)
!-------------------------------------------------------------------
!This will transform the tensor from local into the global coordinate
!it used the transformation tensor to present the tensor that is
!represented in local coordinate in the local coordinate
!-------------------------------------------------------------------
      IMPLICIT NONE
! ----------------------------------------------------------
      REAL*8,INTENT(IN) :: TRANSFORMATION(3,3) ! TRANSFORMATION TENSOR
      REAL*8,INTENT(IN) :: TENSOR_LOCAL_COORD(3) ! LOCAL COORDINATE TENSOR
      REAL*8,INTENT(OUT) :: TENSOR_GLOBAL_COORD(3) ! GLOBAL COORDINATE TENSOR
      INTEGER :: I,J ! The counter integers
! ----------------------------------------------------------
      TENSOR_GLOBAL_COORD=0.0D0 !INITIALIZING TENSOR
! ----------------------------------------------------------
!   IMPLEMENTING THE SYMMETRY
    DO  I=1,3
    DO  J=1,3
    TENSOR_GLOBAL_COORD(I)=TENSOR_GLOBAL_COORD(I)+TRANSFORMATION(I,J)*TENSOR_LOCAL_COORD(J)
    ENDDO;ENDDO
      ENDSUBROUTINE TENSOR_TRANSFORM_RANK_1
!===================================================================
!
      SUBROUTINE TENSOR_TRANSFORM_RANK_2(TRANSFORMATION,TENSOR_LOCAL_COORD,TENSOR_GLOBAL_COORD)
!-------------------------------------------------------------------
!This will transform the tensor from local into the global coordinate
!it used the transformation tensor to present the tensor that is
!represented in local coordinate in the local coordinate
!-------------------------------------------------------------------
      IMPLICIT NONE
! ----------------------------------------------------------
      REAL*8,INTENT(IN) :: TRANSFORMATION(3,3) ! TRANSFORMATION TENSOR
      REAL*8,INTENT(IN) :: TENSOR_LOCAL_COORD(3,3) ! LOCAL COORDINATE TENSOR
      REAL*8,INTENT(OUT) :: TENSOR_GLOBAL_COORD(3,3) ! GLOBAL COORDINATE TENSOR
      INTEGER :: I,J,K,L! The counter integers
! ----------------------------------------------------------
      TENSOR_GLOBAL_COORD=0.0D0 !INITIALIZING TENSOR
! ----------------------------------------------------------
    DO  I=1,3
    DO  J=1,3
    DO  K=1,3
    DO  L=1,3
    TENSOR_GLOBAL_COORD(I,J)=TENSOR_GLOBAL_COORD(I,J)+TRANSFORMATION(I,K)*TRANSFORMATION(J,L)*TENSOR_LOCAL_COORD(K,L)
    ENDDO;ENDDO;ENDDO;ENDDO

      ENDSUBROUTINE TENSOR_TRANSFORM_RANK_2

!===================================================================
      SUBROUTINE ROTATION(XLOCAL,QTRANSFORM)
!====================================================================
      ! THE PhD THESIS OF AMIR SOHRABI MOLLAYOUSEF
      ! Programmer(s):Amir Sohrabi
      ! Objective: to find the rotation tensor for a given point with respect
      ! to the origin of the problem. This transformation matrix is to be used
      ! in non linear electromechancial analysis of telescopic actoator
!=====================================================================
      IMPLICIT NONE
!=====================================================================
      REAL*8 :: XLOCAL(3) ! THIS IS THE COORDINATE OF THE POINT OF INTEREST
      REAL*8 :: QTRANSFORM(3,3) ! THIS IS THE TRANSFORMTION MATRIX
      REAL*8 :: RADIOUS,EUCLI_NORM ! THIS IS THE TRANSFORMTION MATRIX
      INTEGER::DIMENSIONV,INPUT_UNIT
!=====================================================================
      INPUT_UNIT=2
!      OPEN(INPUT_UNIT,file='INPUT_UNIT.TXT')
!      READ(INPUT_UNIT,*)XLOCAL(:)
      QTRANSFORM=0.0D0
      DIMENSIONV=3
      RADIOUS=SQRT(DOT_PRODUCT(XLOCAL,XLOCAL))

      IF (RADIOUS>0) THEN
      QTRANSFORM(1,1)=XLOCAL(1)/RADIOUS
      QTRANSFORM(1,2)=XLOCAL(2)/RADIOUS
      QTRANSFORM(2,1)=-XLOCAL(2)/RADIOUS
      QTRANSFORM(2,2)=XLOCAL(1)/RADIOUS
      QTRANSFORM(3,3)=1
      ENDIF

!     ================================================================
!                           FORMATS
!     ================================================================
  100 FORMAT(3E14.5)
      ENDSUBROUTINE ROTATION

!     ===============================================================
!                       TRACE OF A 3X3 TENSOR
!     ===============================================================

      FUNCTION TRACE(A)
      REAL*8::A(:,:),TRACE
      INTEGER::I
      TRACE=0.0D0;
      DO I=1,SIZE(A,DIM=1);TRACE=TRACE+A(I,I);ENDDO
      END FUNCTION TRACE

      FUNCTION MATMUL_EPZ(EPZ,ELECT)
      REAL*8::ELECT(3),EPZ(3,3,3),MATMUL_EPZ(3,3)
      INTEGER::I,J,K
      MATMUL_EPZ=0.0D0;
      DO I=1,3;
      DO J=1,3;
      DO K=1,3;
      MATMUL_EPZ(I,J)=MATMUL_EPZ(I,J)+EPZ(K,I,J)*ELECT(K)
      ENDDO;ENDDO;ENDDO
      END FUNCTION MATMUL_EPZ

      FUNCTION MATMUL_D_EPZ(EPZ,STRAN)
      REAL*8::MATMUL_D_EPZ(3),EPZ(3,3,3),STRAN(3,3)
      INTEGER::I,J,K
      MATMUL_D_EPZ=0.0D0;
      DO I=1,3;
      DO J=1,3;
      DO K=1,3;
      MATMUL_D_EPZ(K)=MATMUL_D_EPZ(K)+EPZ(K,I,J)*STRAN(I,J)
      ENDDO;ENDDO;ENDDO
      END FUNCTION MATMUL_D_EPZ

!***********************************************************************************************************************************
!  M33INV  -  Compute the inverse of a 3x3 matrix.
!
!  A       = input 3x3 matrix to be inverted
!  AINV    = output 3x3 inverse of matrix A
!  OK_FLAG = (output) .TRUE. if the input matrix could be inverted, and .FALSE. if the input matrix is singular.
!***********************************************************************************************************************************

      SUBROUTINE M33INV (A, AINV,DET, OK_FLAG)

      IMPLICIT NONE

      DOUBLE PRECISION, DIMENSION(3,3), INTENT(IN)  :: A
      DOUBLE PRECISION, DIMENSION(3,3), INTENT(OUT) :: AINV
      LOGICAL, INTENT(OUT) :: OK_FLAG

      DOUBLE PRECISION, PARAMETER :: EPS = 1.0D-10
      DOUBLE PRECISION :: DET
      DOUBLE PRECISION, DIMENSION(3,3) :: COFACTOR

      DET =   A(1,1)*A(2,2)*A(3,3)  &
            - A(1,1)*A(2,3)*A(3,2)  &
            - A(1,2)*A(2,1)*A(3,3)  &
            + A(1,2)*A(2,3)*A(3,1)  &
            + A(1,3)*A(2,1)*A(3,2)  &
            - A(1,3)*A(2,2)*A(3,1)

      IF (ABS(DET) .LE. EPS) THEN
         AINV = 0.0D0
         OK_FLAG = .FALSE.
         RETURN
      END IF

      COFACTOR(1,1) = +(A(2,2)*A(3,3)-A(2,3)*A(3,2))
      COFACTOR(1,2) = -(A(2,1)*A(3,3)-A(2,3)*A(3,1))
      COFACTOR(1,3) = +(A(2,1)*A(3,2)-A(2,2)*A(3,1))
      COFACTOR(2,1) = -(A(1,2)*A(3,3)-A(1,3)*A(3,2))
      COFACTOR(2,2) = +(A(1,1)*A(3,3)-A(1,3)*A(3,1))
      COFACTOR(2,3) = -(A(1,1)*A(3,2)-A(1,2)*A(3,1))
      COFACTOR(3,1) = +(A(1,2)*A(2,3)-A(1,3)*A(2,2))
      COFACTOR(3,2) = -(A(1,1)*A(2,3)-A(1,3)*A(2,1))
      COFACTOR(3,3) = +(A(1,1)*A(2,2)-A(1,2)*A(2,1))

      AINV = TRANSPOSE(COFACTOR) / DET
      OK_FLAG = .TRUE.

      RETURN

      END SUBROUTINE M33INV

!     ================================================================
!                 NORM OF A VECTOR
!     ================================================================
      FUNCTION NORM_MATRIX(A)
      INTEGER::I,J
      REAL*8::A(:,:),NORM_MATRIX

      NORM_MATRIX=0.0D0
      DO I=1,SIZE(A,DIM=1);DO J=1,SIZE(A,DIM=2);
      NORM_MATRIX=NORM_MATRIX+A(I,J)*A(I,J)
      ENDDO;ENDDO

      END FUNCTION NORM_MATRIX

!     ================================================================
!                 MACAULAY BRACKETS
!     ================================================================
      FUNCTION MACAULAY(A)
      INTEGER::MACAULAY
      REAL*8::A
      MACAULAY=0
      IF (A>=0)THEN
       MACAULAY=1
      ENDIF
      END FUNCTION MACAULAY

!     ================================================================
!                 UNIT VECTOR IN THE DIRECTION OF A VECTOR
!     ================================================================
      FUNCTION UNIT_VECT(A)
      REAL*8::A(:)
      REAL*8,ALLOCATABLE :: UNIT_VECT(:)

      ALLOCATE(UNIT_VECT(SIZE(A)))
      UNIT_VECT=0.0D0

      UNIT_VECT=A/NORM_VECT(A)

      IF(NORM_VECT(A).EQ.0)UNIT_VECT=0.0D0

      END FUNCTION UNIT_VECT

      subroutine elapsedtime (END_STAMP_V,START_STAMP_V)
      integer ( kind = 4 )START_STAMP_V(8),END_STAMP_V(8),values(8),SECONDS,MINUTES,HOURS,MILISECONDS,START_STAMP,END_STAMP,ELAPSED_TIME

      MILISECONDS=mod(END_STAMP_V(8)-START_STAMP_V(8),100)
      SECONDS=mod(END_STAMP_V(7)-START_STAMP_V(7),60)
      MINUTES=mod(END_STAMP_V(6)-START_STAMP_V(6),60)
      HOURS=END_STAMP_V(5)-START_STAMP_V(5)
      write ( *,'(1X,a,2x,i2,a1,i4.4,a1,i4.4,a1,i4.4)' )'Elapsed Time=', HOURS,':',MINUTES,':',SECONDS,'.',ABS(MILISECONDS)
      endsubroutine elapsedtime

subroutine timestamp ( )

!*****************************************************************************80
!
!! TIMESTAMP prints the current YMDHMS date as a time stamp.
!
!  Example:
!
!    May 31 2001   9:45:54.872 AM
!
!  Licensing:
!
!    This code is distributed under the GNU LGPL license.
!
!  Modified:
!
!    26 February 2005
!
!  Author:
!
!    John Burkardt
!
!  Parameters:
!
!    None
!
  implicit none

  character ( len = 8 ) ampm
  integer d
  integer h
  integer m
  integer mm
  character ( len = 9 ), parameter, dimension(12) :: month = (/ &
    'January  ', 'February ', 'March    ', 'April    ', &
    'May      ', 'June     ', 'July     ', 'August   ', &
    'September', 'October  ', 'November ', 'December ' /)
  integer n
  integer s
  integer values(8)
  integer y

  call date_and_time ( values = values )

  y = values(1)
  m = values(2)
  d = values(3)
  h = values(5)
  n = values(6)
  s = values(7)
  mm = values(8)

  if ( h < 12 ) then
    ampm = 'AM'
  else if ( h == 12 ) then
    if ( n == 0 .and. s == 0 ) then
      ampm = 'Noon'
    else
      ampm = 'PM'
    end if
  else
    h = h - 12
    if ( h < 12 ) then
      ampm = 'PM'
    else if ( h == 12 ) then
      if ( n == 0 .and. s == 0 ) then
        ampm = 'Midnight'
      else
        ampm = 'AM'
      end if
    end if
  end if

  write ( *, '(a,1x,i2,1x,i4,2x,i2,a1,i2.2,a1,i2.2,a1,i3.3,1x,a)' ) &
    trim ( month(m) ), d, y, h, ':', n, ':', s, '.', mm, trim ( ampm )

  return
end

    end module linearsolvers


a = reshape ((/(i * i, i = 1, 100)/), (/10, 10/))


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

*   Intrinsics & generics - MOD, SIGN, DIM, DPROD.

	program p
	parameter (n = 32)
	integer rslts(n), expect(n)
	double precision d2, dn5

	data i0, i2, i5, i19, i7 / 0, 2, 5, 19, 7 /
	data x2, x4, x7 / 2.0, 4.0, 7.0 /
	data d2, dn5    / 2.0d0, -5.0d0 /

c --- tests 1 - 5: INTEGER MOD operation:

	rslts(1) = mod('7fffffff'x, 2)
	rslts(2) = mod('7ffffffe'x, i2)
	rslts(3) = mod(i2, i2) + mod(i19, 5) + mod(0, i19)
	rslts(4) = i2 * mod(i0, i19+7) + (i19 - mod(i19, i2))
	rslts(5) = mod(-7, 5) +  mod(-i7, 2 * i2 + 1)

c --- tests 6 - 10: REAL MOD operation:

	rslts(6) = mod(4.0, 2.0) - mod(-x4, x2)
	rslts(7) = amod(x2, x2+x2)
	rslts(8) = ifix( amod(x7, x4) )
	rslts(9) = amod(2.341, float(2)) * 100
	rslts(10) = 100 * mod(2.341, float(i2))

c --- tests 11 - 13: DOUBLE PRECISION MOD operation:

	rslts(11) = idint(dmod(5.0d0, 2.0d0))
	rslts(12) = idint( mod(dn5, -d2) )
	rslts(13) = dn5 + dmod(d2, d2)

c --- tests 14 - 17: INTEGER SIGN operation:

	rslts(14) = isign(3, 4) + isign(-8, -1)
	rslts(15) = sign(99, 0) + sign(-6, 1)
	rslts(sign(16, i2)) = isign(i2, 1)
	rslts(17) = isign(-i2, i19*i2) * sign(i19, -i2)

c --- tests 18 - 22: REAL and DOUBLE PRECISION SIGN operation:

	rslts(18) = sign(2.0, 4.0) + sign(8.0, -1.0)
	rslts(19) = sign(x7, -x4) * sign(x2*x2, x4)

	rslts(20) = idint( dsign(2.0d0, -1.0d0) )
	rslts(21) = idint( sign(dn5, d2 - d2) )
	rslts(22) = 0

c --- tests 23 - 29: DIM operation:

	rslts(23) = idim(i5, i2) + i19
	rslts(24) = dim(i2, i5) * i5
	rslts(25) = dim(i5*i2, i2 + i2)

	rslts(26) = dim(x7, x4)
	rslts(27) = 2.0 + dim(x4, x4+x4)

	rslts(28) = idint( ddim(dn5, d2) )
	rslts(29) = idint( dim(3.0d0, dn5 * 2.0) + 1)

c --- tests 30 - 32: DPROD operation:

	rslts(30) = idint(dprod(x2, x2))
	rslts(31) = dprod(-3.0, 2.0)
	rslts(32) = dprod(x2*x2, x4+x4)

c --- check results:

	call check(rslts, expect, n)

	data expect / 1, 0, 4, 18, -4,
     +                0, 2, 3, 34, 34,
     +                1, -1, -5,
     +                -5, 105, 2, -38,
c        tests 18 - 22:
     +                -6, -28, -2, 5, 0,
c        tests 23 - 29:
     +                22, 0, 6, 3, 2, 0, 14,
     +                4, -6, 32              /
	end


*DECK SGECO
      SUBROUTINE SGECO (A, LDA, N, IPVT, RCOND, Z)
C***BEGIN PROLOGUE  SGECO
C***PURPOSE  Factor a matrix using Gaussian elimination and estimate
C            the condition number of the matrix.
C***LIBRARY   SLATEC (LINPACK)
C***CATEGORY  D2A1
C***TYPE      SINGLE PRECISION (SGECO-S, DGECO-D, CGECO-C)
C***KEYWORDS  CONDITION NUMBER, GENERAL MATRIX, LINEAR ALGEBRA, LINPACK,
C             MATRIX FACTORIZATION
C***AUTHOR  Moler, C. B., (U. of New Mexico)
C***DESCRIPTION
C
C     SGECO factors a real matrix by Gaussian elimination
C     and estimates the condition of the matrix.
C
C     If  RCOND  is not needed, SGEFA is slightly faster.
C     To solve  A*X = B , follow SGECO by SGESL.
C     To compute  INVERSE(A)*C , follow SGECO by SGESL.
C     To compute  DETERMINANT(A) , follow SGECO by SGEDI.
C     To compute  INVERSE(A) , follow SGECO by SGEDI.
C
C     On Entry
C
C        A       REAL(LDA, N)
C                the matrix to be factored.
C
C        LDA     INTEGER
C                the leading dimension of the array  A .
C
C        N       INTEGER
C                the order of the matrix  A .
C
C     On Return
C
C        A       an upper triangular matrix and the multipliers
C                which were used to obtain it.
C                The factorization can be written  A = L*U , where
C                L  is a product of permutation and unit lower
C                triangular matrices and  U  is upper triangular.
C
C        IPVT    INTEGER(N)
C                an integer vector of pivot indices.
C
C        RCOND   REAL
C                an estimate of the reciprocal condition of  A .
C                For the system  A*X = B , relative perturbations
C                in  A  and  B  of size  EPSILON  may cause
C                relative perturbations in  X  of size  EPSILON/RCOND .
C                If  RCOND  is so small that the logical expression
C                           1.0 + RCOND .EQ. 1.0
C                is true, then  A  may be singular to working
C                precision.  In particular,  RCOND  is zero  if
C                exact singularity is detected or the estimate
C                underflows.
C
C        Z       REAL(N)
C                a work vector whose contents are usually unimportant.
C                If  A  is close to a singular matrix, then  Z  is
C                an approximate null vector in the sense that
C                NORM(A*Z) = RCOND*NORM(A)*NORM(Z) .
C
C***REFERENCES  J. J. Dongarra, J. R. Bunch, C. B. Moler, and G. W.
C                 Stewart, LINPACK Users' Guide, SIAM, 1979.
C***ROUTINES CALLED  SASUM, SAXPY, SDOT, SGEFA, SSCAL
C***REVISION HISTORY  (YYMMDD)
C   780814  DATE WRITTEN
C   890531  Changed all specific intrinsics to generic.  (WRB)
C   890831  Modified array declarations.  (WRB)
C   890831  REVISION DATE from Version 3.2
C   891214  Prologue converted to Version 4.0 format.  (BAB)
C   900326  Removed duplicate information from DESCRIPTION section.
C           (WRB)
C   920501  Reformatted the REFERENCES section.  (WRB)
C***END PROLOGUE  SGECO
      INTEGER LDA,N,IPVT(*)
      REAL A(LDA,*),Z(*)
      REAL RCOND
C
      REAL SDOT,EK,T,WK,WKM
      REAL ANORM,S,SASUM,SM,YNORM
      INTEGER INFO,J,K,KB,KP1,L
C
C     COMPUTE 1-NORM OF A
C
C***FIRST EXECUTABLE STATEMENT  SGECO
      ANORM = 0.0E0
      DO 10 J = 1, N
         ANORM = MAX(ANORM,SASUM(N,A(1,J),1))
   10 CONTINUE
C
C     FACTOR
C
      CALL SGEFA(A,LDA,N,IPVT,INFO)
C
C     RCOND = 1/(NORM(A)*(ESTIMATE OF NORM(INVERSE(A)))) .
C     ESTIMATE = NORM(Z)/NORM(Y) WHERE  A*Z = Y  AND  TRANS(A)*Y = E .
C     TRANS(A)  IS THE TRANSPOSE OF A .  THE COMPONENTS OF  E  ARE
C     CHOSEN TO CAUSE MAXIMUM LOCAL GROWTH IN THE ELEMENTS OF W  WHERE
C     TRANS(U)*W = E .  THE VECTORS ARE FREQUENTLY RESCALED TO AVOID
C     OVERFLOW.
C
C     SOLVE TRANS(U)*W = E
C
      EK = 1.0E0
      DO 20 J = 1, N
         Z(J) = 0.0E0
   20 CONTINUE
      DO 100 K = 1, N
         IF (Z(K) .NE. 0.0E0) EK = SIGN(EK,-Z(K))
         IF (ABS(EK-Z(K)) .LE. ABS(A(K,K))) GO TO 30
            S = ABS(A(K,K))/ABS(EK-Z(K))
            CALL SSCAL(N,S,Z,1)
            EK = S*EK
   30    CONTINUE
         WK = EK - Z(K)
         WKM = -EK - Z(K)
         S = ABS(WK)
         SM = ABS(WKM)
         IF (A(K,K) .EQ. 0.0E0) GO TO 40
            WK = WK/A(K,K)
            WKM = WKM/A(K,K)
         GO TO 50
   40    CONTINUE
            WK = 1.0E0
            WKM = 1.0E0
   50    CONTINUE
         KP1 = K + 1
         IF (KP1 .GT. N) GO TO 90
            DO 60 J = KP1, N
               SM = SM + ABS(Z(J)+WKM*A(K,J))
               Z(J) = Z(J) + WK*A(K,J)
               S = S + ABS(Z(J))
   60       CONTINUE
            IF (S .GE. SM) GO TO 80
               T = WKM - WK
               WK = WKM
               DO 70 J = KP1, N
                  Z(J) = Z(J) + T*A(K,J)
   70          CONTINUE
   80       CONTINUE
   90    CONTINUE
         Z(K) = WK
  100 CONTINUE
      S = 1.0E0/SASUM(N,Z,1)
      CALL SSCAL(N,S,Z,1)
C
C     SOLVE TRANS(L)*Y = W
C
      DO 120 KB = 1, N
         K = N + 1 - KB
         IF (K .LT. N) Z(K) = Z(K) + SDOT(N-K,A(K+1,K),1,Z(K+1),1)
         IF (ABS(Z(K)) .LE. 1.0E0) GO TO 110
            S = 1.0E0/ABS(Z(K))
            CALL SSCAL(N,S,Z,1)
  110    CONTINUE
         L = IPVT(K)
         T = Z(L)
         Z(L) = Z(K)
         Z(K) = T
  120 CONTINUE
      S = 1.0E0/SASUM(N,Z,1)
      CALL SSCAL(N,S,Z,1)
C
      YNORM = 1.0E0
C
C     SOLVE L*V = Y
C
      DO 140 K = 1, N
         L = IPVT(K)
         T = Z(L)
         Z(L) = Z(K)
         Z(K) = T
         IF (K .LT. N) CALL SAXPY(N-K,T,A(K+1,K),1,Z(K+1),1)
         IF (ABS(Z(K)) .LE. 1.0E0) GO TO 130
            S = 1.0E0/ABS(Z(K))
            CALL SSCAL(N,S,Z,1)
            YNORM = S*YNORM
  130    CONTINUE
  140 CONTINUE
      S = 1.0E0/SASUM(N,Z,1)
      CALL SSCAL(N,S,Z,1)
      YNORM = S*YNORM
C
C     SOLVE  U*Z = V
C
      DO 160 KB = 1, N
         K = N + 1 - KB
         IF (ABS(Z(K)) .LE. ABS(A(K,K))) GO TO 150
            S = ABS(A(K,K))/ABS(Z(K))
            CALL SSCAL(N,S,Z,1)
            YNORM = S*YNORM
  150    CONTINUE
         IF (A(K,K) .NE. 0.0E0) Z(K) = Z(K)/A(K,K)
         IF (A(K,K) .EQ. 0.0E0) Z(K) = 1.0E0
         T = -Z(K)
         CALL SAXPY(K-1,T,A(1,K),1,Z(1),1)
  160 CONTINUE
C     MAKE ZNORM = 1.0
      S = 1.0E0/SASUM(N,Z,1)
      CALL SSCAL(N,S,Z,1)
      YNORM = S*YNORM
C
      IF (ANORM .NE. 0.0E0) RCOND = YNORM/ANORM
      IF (ANORM .EQ. 0.0E0) RCOND = 0.0E0
      RETURN
      END


c     program DRDEVUN
c>> 1994-10-19 DRDEVUN  Krogh  Changes to use M77CON
c>> 1992-04-23 DRDEVUN  CLL   Declaring all variables.
c>> 1992-03-04 DRDEVUN  Krogh Initial version.
c     Demonstrate unsymmetric eigenvalue subroutine DEVUN.
c     ------------------------------------------------------------------
c--D replaces "?": DR?EVUN, ?EVUN, ?VECP
c     ------------------------------------------------------------------
      integer I, KASE, LDA, N
      parameter (LDA = 3)
      integer IFLAG(LDA)
      double precision A(LDA,LDA,3), VR(LDA), VI(LDA)
c
      data (A(1,I,1), I=1,3) / -954.0d0, -464.0d0, -2088.0d0 /
      data (A(2,I,1), I=1,3) /  792.0d0,  387.0d0,  1728.0d0 /
      data (A(3,I,1), I=1,3) /  264.0d0,  128.0d0,   579.0d0 /
c
      data (A(1,I,2), I=1,3) / 4.0d0, 1.0d0, 1.0d0 /
      data (A(2,I,2), I=1,3) / 2.0d0, 4.0d0, 1.0d0 /
      data (A(3,I,2), I=1,3) / 0.0d0, 1.0d0, 4.0d0 /
c
      data (A(1,I,3), I=1,3) /  8.0d0, -1.0d0, -5.0d0 /
      data (A(2,I,3), I=1,3) / -4.0d0,  4.0d0, -2.0d0 /
      data (A(3,I,3), I=1,3) / 18.0d0, -5.0d0, -7.0d0 /
      data N / LDA /
c     ------------------------------------------------------------------
      print*,'DRDEVUN..  Demo driver for DEVUN.'
      do 10 KASE = 1, 3
         print '(/a,i2)',' Beginning Case =', KASE
         call DEVUN(A(1, 1, KASE), LDA, N, VR, VI, IFLAG)
         print '(a,i2)',' IFLAG(1) =', IFLAG(1)
         if (IFLAG(1) .le. 2) then
            call DVECP(VR, N, ' Real part of the eigenvalues')
            call DVECP(VI, N, ' Imaginary part of the eigenvalues')
         else
            print '(/a)',' Failure in DEVUN.'
         end if
   10 continue
      stop
      end


c fishpk33 from portlib                                  12/30/83
c
c     * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
c     *                                                               *
c     *                        f i s h p a k                          *
c     *                                                               *
c     *                                                               *
c     *     a package of fortran subprograms for the solution of      *
c     *                                                               *
c     *      separable elliptic partial differential equations        *
c     *                                                               *
c     *                  (version 3.1 , october 1980)                  *
c     *                                                               *
c     *                             by                                *
c     *                                                               *
c     *        john adams, paul swarztrauber and roland sweet         *
c     *                                                               *
c     *                             of                                *
c     *                                                               *
c     *         the national center for atmospheric research          *
c     *                                                               *
c     *                boulder, colorado  (80307)  u.s.a.             *
c     *                                                               *
c     *                   which is sponsored by                       *
c     *                                                               *
c     *              the national science foundation                  *
c     *                                                               *
c     * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
c
c     program to illustrate the use of hstssp to solve poisson"s
c     equation
c
c             (1/sin(theta))(d/dtheta)(sin(theta)*du/dtheta) +
c
c    (1/sin(theta)**2)(d/dphi)(du/dphi) = 2 - 6*(sin(theta)*sin(phi))**2
c     on the northern hemisphere subject to equatorial symmetry, i.e.
c     the derivative of the solution at theta = pi/2 is zero.  a
c     5-degree grid is to be used.
c
c     the exact solution is not unique.  any function of the form
c
c           u(theta,phi) = (sin(theta)*sin(phi))**2 + constant
c
c     is a solution.
c
      program thstssp
      dimension       f(18,72)   ,bdb(72)    ,sint(18)   ,sinp(72)   ,
     1                w(630)
      dimension bda(1), bdc(1), bdd(1)
c
c     the value of idimf is the first dimension of f. w is dimensioned
c     (13 + int(log2(n)))*m + 4*n
c
      pi = pimach(dum)
      a = 0.
      b = pi/2.
      m = 18
      mbdcnd = 6
      c = 0.
      d = 2.*pi
      n = 72
      nbdcnd = 0
      elmbda = 0.
      idimf = 18
c
c     generate sines for use in subsequent computations
c
      dtheta = b/float(m)
      do 101 i=1,m
         sint(i) = sin((float(i)-0.5)*dtheta)
  101 continue
      dphi = d/float(n)
      do 102 j=1,n
         sinp(j) = sin((float(j)-0.5)*dphi)
  102 continue
c
c     compute right side of equation and store in f
c
      do 104 j=1,n
         do 103 i=1,m
            f(i,j) = 2.-6.*(sint(i)*sinp(j))**2
  103    continue
  104 continue
c
c     store derivative data at the equator
c
      do 105 j=1,n
         bdb(j) = 0.
  105 continue
c
c     bda, bdc, and bdd are dummy variables.
c
      call hstssp (a,b,m,mbdcnd,bda,bdb,c,d,n,nbdcnd,bdc,bdd,elmbda,f,
     1             idimf,pertrb,ierror,w)
c
c     compute discretization error. since problem is singular, the
c     solution must be normalized.
c
      err = 0.
      do 107 j=1,n
         do 106 i=1,m
            z = abs(f(i,j)-(sint(i)*sinp(j))**2-f(1,1))
            if (z .gt. err) err = z
  106    continue
  107 continue
c
      print 1001 , ierror,pertrb,err,w(1)
      stop
c
 1001 format (1h1,20x,25hsubroutine hstssp example///
     1        10x,46hthe output from the ncar control data 7600 was//
     2        32x,10hierror = 0/32x,20hpertrb = 6.35830e-04/
     3        18x,34hdiscretization error = 3.37523e-03/
     4        12x,32hrequired length of w array = 540//
     5        10x,32hthe output from your computer is//
     6        32x,8hierror =,i2/32x,8hpertrb =,e12.5/
     7        18x,22hdiscretization error =,e12.5/
     8        12x,28hrequired length of w array =,f4.0)
c
      end
c     solution must be normalized.


!!# FUNCTION MODULE: <FUN_FactorialInt>
MODULE FUN_FactorialInt

!!## PURPOSE
!! Defines function FactorialInt(k) which returns a integer for integer k.
!! If the factorial is beyond the range of the integer k then 0 is returned.

!!## DETAILS
!! @ The kind of FactorialInt(k) is equal to the kind of k.
!! @ A check is made to make sure k has a factorial that is less than HUGE(k).

!!## EXTERNAL KINDS
USE KND_IntrinsicTypes,ONLY: KIND_I1,KIND_I2,KIND_I4,KIND_I8 !!((01-A-KND_IntrinsicTypes.f90))

!!## GLOBAL PROCEDURE
USE FUN_Error                                                !!((04-A-FUN_Error.f90))

!!## DEFAULT IMPLICIT
IMPLICIT NONE

!!## DEFAULT ACCESS
PRIVATE

!! @ maximum integer-only factorial
INTEGER(KIND_I1),PARAMETER :: MAX_I1 = 5_KIND_I1  !maximum integer factorial for INTEGER(1)
INTEGER(KIND_I2),PARAMETER :: MAX_I2 = 7_KIND_I2  !maximum integer factorial for INTEGER(2)
INTEGER(KIND_I4),PARAMETER :: MAX_I4 = 13_KIND_I4 !maximum integer factorial for INTEGER(4)
INTEGER(KIND_I8),PARAMETER :: MAX_I8 = 20_KIND_I8 !maximum integer factorial for INTEGER(8)
PUBLIC :: MAX_I1,MAX_I2,MAX_I4,MAX_I8

!!## FUNCTION OVERLOADING
INTERFACE FactorialInt
 MODULE PROCEDURE FactorialInt_I1
 MODULE PROCEDURE FactorialInt_I2
 MODULE PROCEDURE FactorialInt_I4
 MODULE PROCEDURE FactorialInt_I8
END INTERFACE

!!## PUBLIC ACCESS
PUBLIC :: FactorialInt

!!## CONTAINED PROCEDURES
CONTAINS

PURE ELEMENTAL FUNCTION FactorialInt_I1( x ) RESULT(y)
USE KND_IntrinsicTypes,ONLY: KIND_I=>KIND_I1                 !!((01-A-KND_IntrinsicTypes.f90))
INTEGER(KIND_I),PARAMETER :: MAX = MAX_I1
INCLUDE "05-B-FUN_FactorialInt.f90.hdr"
!!--begin--
INCLUDE "05-B-FUN_FactorialInt.f90.bdy"
!!--end--
ENDFUNCTION

PURE ELEMENTAL FUNCTION FactorialInt_I2( x ) RESULT(y)
USE KND_IntrinsicTypes,ONLY: KIND_I=>KIND_I2                 !!((01-A-KND_IntrinsicTypes.f90))
INTEGER(KIND_I),PARAMETER :: MAX = MAX_I2
INCLUDE "05-B-FUN_FactorialInt.f90.hdr"
!!--begin--
INCLUDE "05-B-FUN_FactorialInt.f90.bdy"
!!--end--
ENDFUNCTION

PURE ELEMENTAL FUNCTION FactorialInt_I4( x ) RESULT(y)
USE KND_IntrinsicTypes,ONLY: KIND_I=>KIND_I4                 !!((01-A-KND_IntrinsicTypes.f90))
INTEGER(KIND_I),PARAMETER :: MAX = MAX_I4
INCLUDE "05-B-FUN_FactorialInt.f90.hdr"
!!--begin--
INCLUDE "05-B-FUN_FactorialInt.f90.bdy"
!!--end--
ENDFUNCTION

PURE ELEMENTAL FUNCTION FactorialInt_I8( x ) RESULT(y)
USE KND_IntrinsicTypes,ONLY: KIND_I=>KIND_I8                 !!((01-A-KND_IntrinsicTypes.f90))
INTEGER(KIND_I),PARAMETER :: MAX = MAX_I8
INCLUDE "05-B-FUN_FactorialInt.f90.hdr"
!!--begin--
INCLUDE "05-B-FUN_FactorialInt.f90.bdy"
!!--end--
ENDFUNCTION

ENDMODULE


MODULE multidim_arrays

  IMPLICIT NONE

CONTAINS

  FUNCTION inner_prod(n,a,b) RESULT(y)
    INTEGER, INTENT(in) :: n
    INTEGER, INTENT(in), dimension(n) :: a, b
    INTEGER :: y
    y = DOT_PRODUCT(a,b)
  END FUNCTION inner_prod

  ! Test assumed size
  FUNCTION inner_prod_2(n,a,b) RESULT(y)
    INTEGER, INTENT(in) :: n
    INTEGER, INTENT(in), DIMENSION(*) :: a
    INTEGER, INTENT(in) :: b(*)
    INTEGER :: y
    y = DOT_PRODUCT(a(1:n),b(1:n))
  END FUNCTION inner_prod_2

  SUBROUTINE mat_vec_mult(m,n,A,b,Ab)
    INTEGER, INTENT(in) :: m,n, b(n)
    INTEGER, INTENT(in), DIMENSION(m,n) :: A
    INTEGER, INTENT(out) :: Ab(m)
    Ab = MATMUL(A,b)
  END SUBROUTINE mat_vec_mult

  SUBROUTINE three_d_array_test(A)
    INTEGER, INTENT(out) :: A(4,3,2)

    INTEGER :: i,j,k
    DO k=1,2
      DO j=1,3
        DO i=1,4
          A(i,j,k) = (i+j)**k
        END DO
      END DO
    END DO
  END SUBROUTINE three_d_array_test

END MODULE multidim_arrays