************************************************************************
*                              S E C T P R O P                         *
*                                                          D. Everhart *
*                                                          06 SEP 2018 *
************************************************************************
* The MIT License (MIT)
*
* Copyright (c) 2018 Daniel Everhart
*
* Permission is hereby granted, free of charge, to any person obtaining
* a copy of this software and associated documentation files (the
* "Software"), to deal in the Software without restriction, including
* without limitation the rights to use, copy, modify, merge, publish,
* distribute, sublicense, and/or sell copies of the Software, and to
* permit persons to whom the Software is furnished to do so, subject
* to the following conditions:
*
* The above copyright notice and this permission notice shall be
* included in all copies or substantial portions of the Software.
*
* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
* EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
* MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT.
* IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY
* CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT,
* TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE
* SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.
*
*************************************************************************
* This program is to demonstrate the calculation of section properties
* of a general polygon.  To test this, the following closed form
* solution of a right triangle is used.
*
*
*                ^ |\
*                | | \
*                | |  \                   B*H**3   B*H**3
*                | |   \            Ix =  ------ - ------
*                | |    \                   12       18
*                | |     \
*                | |      \
*                | |       \              H*B**3   H*B**3
*                  |        \       Iy =  ------ - ------
*                H |         \              12       18
*                  |          \
*                | |    |      \
*                | |<-->|<---- 1/3 B
*                | |    |        \                      B**2 *  H**2
*                | |    +-----    \             Ixy = -  ------------
*                | |  CENT  ^      \                         72
*                | |        |       \
*                | |        |        \
*                | |                  \
*                | |      1/3 H        \
*                | |                    \
*                | |        |            \
*                v |________v_____________\
*                  <------- B --------->
*
************************************************************************
      PROGRAM SECTPROP
      IMPLICIT NONE
      INTEGER SIZE,STDOUT,STDIN,STDERR,I,J
      REAL B,H,ANG
      PARAMETER(SIZE=3,B=1.0,H=1.0,ANG=.78540,STDOUT=6,STDIN=5,STDERR=0)
      REAL POINTS(2,SIZE)
      REAL AREA,XCEN,YCEN,IXX,IYY,IXY
      REAL AINC,XI,XIP1,YI,YIP1
      DATA POINTS /
     &                     0.,    0.,
     &                      B,    0.,
     &                     0.,     H
     &                                      /
      DATA AREA,XCEN,YCEN,IXX,IYY,IXY/6*0.0/
      WRITE(STDOUT,9001)
*
      DO 1001 I=1,SIZE
 1001 WRITE(STDOUT,9002)(POINTS(J,I),J=1,2)
*
      DO 2001 I=1,SIZE
*
      XI = POINTS(1,I)
      YI = POINTS(2,I)
      IF (I.EQ.SIZE) THEN
      XIP1 = POINTS(1,1)
      YIP1 = POINTS(2,1)
      ELSE
      XIP1 = POINTS(1,I+1)
      YIP1 = POINTS(2,I+1)
      ENDIF
*
      AINC = XI * YIP1 - XIP1 * YI
      AREA = AREA + AINC
      XCEN = XCEN + AINC * (XI + XIP1)
      YCEN = YCEN + AINC * (YI + YIP1)
       IXX =  IXX + AINC * (YI**2.0 + YI*YIP1 + YIP1**2.0)
       IYY =  IYY + AINC * (XI**2.0 + XI*XIP1 + XIP1**2.0)
       IXY =  IXY + AINC * (XI*YIP1+2.0*XI*YI+2.0*XIP1*YIP1+XIP1*YI)
*
 2001 CONTINUE
*
      AREA = AREA /  2.0
      XCEN = XCEN /  6.0 / AREA
      YCEN = YCEN /  6.0 / AREA
       IXX =  IXX / 12.0
       IYY =  IYY / 12.0
       IXY =  IXY / 24.0
*
      WRITE(STDOUT,9003)
      WRITE(STDOUT,9004)
      WRITE(STDOUT,9002) AREA,XCEN,YCEN,IXX,IYY,IXY
*
      CALL INRTR2(AREA,XCEN,YCEN,IXX,IYY,IXY,0.0,0.0,XCEN,YCEN)
*
      WRITE(STDOUT,9005)
      WRITE(STDOUT,9004)
      WRITE(STDOUT,9002) AREA,XCEN,YCEN,IXX,IYY,IXY
*
      CALL T2DROT(IXX,IYY,IXY,ANG)
*
      WRITE(STDOUT,9006) ANG
      WRITE(STDOUT,9004)
      WRITE(STDOUT,9002) AREA,XCEN,YCEN,IXX,IYY,IXY
*
      AREA = 0.5 * B * H
      XCEN = B / 3.0
      YCEN = H / 3.0
      IXX  = 0.02777778 * B * H ** 3.0
      IYY  = 0.02777778 * H * B ** 3.0
      IXY  = - B ** 2.0 * H ** 2.0 / 72.0
*
      WRITE(STDOUT,9007)
      WRITE(STDOUT,9004)
      WRITE(STDOUT,9002) AREA,XCEN,YCEN,IXX,IYY,IXY
*
*
 8999 STOP
 9001 FORMAT(/'$**** VERTEX DATA')
 9002 FORMAT(5X,6F12.5)
 9003 FORMAT(/'$**** SECTION PROPERTY DATA')
 9004 FORMAT(5X,'    AREA    ','    XCEN    ','    YCEN    ',
     &          '     IXX    ','     IYY    ','     IXY    ')
 9005 FORMAT(/'$**** TRANSLATED SECTION PROPERTY DATA')
 9006 FORMAT(/'$**** ROTATED SECTION PROPERTY DATA, ',F6.4,' RADIANS')
 9007 FORMAT(/'$**** CLOSED FORM SECTION PROPERTY DATA')
      END PROGRAM SECTPROP
************************************************************************
*                             I N R T R 2
************************************************************************
* Translates inertias from one axis system to another.
*
************************************************************************
      SUBROUTINE INRTR2(AREA,XCEN,YCEN,IXX,IYY,IXY,XOLD,YOLD,XNEW,YNEW)
      IMPLICIT NONE
      REAL AREA,XCEN,YCEN,IXX,IYY,IXY,XOLD,YOLD,XNEW,YNEW
      REAL X,XP,Y,YP
*
      X  = XOLD - XCEN
      Y  = YOLD - YCEN
      XP = XNEW - XCEN
      YP = YNEW - YCEN
*     Ixy'= Ixy +  A   * ( x' * y' - x * y )
      IXY = IXY + AREA * ( XP * YP - X * Y )
*
*     Ixy'= Ixy +  A   * ( d' ** 2.0 - d ** 2.0 )
      IXX = IXX + AREA * ( YP ** 2.0 - Y ** 2.0 )
      IYY = IYY + AREA * ( XP ** 2.0 - X ** 2.0 )
 8999 RETURN
      END SUBROUTINE INRTR2
************************************************************************
*                             T 2 D R O T
************************************************************************
* Rotates a 2D tensor (eg: stress or inertia...)
*
************************************************************************
      SUBROUTINE T2DROT(TXX,TYY,TXY,RAD)
      IMPLICIT NONE
      REAL TXX,TYY,TXY,RAD
      REAL TMPP,TMPM,C2,S2
      TMPP = ( TXX + TYY ) / 2.0
      TMPM = ( TXX - TYY ) / 2.0
      C2 = COS( 2.0 * RAD )
      S2 = SIN( 2.0 * RAD )
      TXX = TMPP + TMPM * C2 - TXY * S2
      TYY = TMPP - TMPM * C2 + TXY * S2
      TXY = TMPM * S2 + TXY * C2
 8999 RETURN
      END SUBROUTINE T2DROT
************************************************************************


      subroutine penmanadj(grn_ind,year,month,day,penadj)

      parameter (pi = 3.14159)

      integer year,month,day,ndays,mdays(12)
      real grn_ind,penkmax,penkmin,penadj

      data mdays/286,317,346,11,41,72,102,133,164,194,225,255/

c------------------------------------------------------------
c Estimation of daily adjustment factors to Penman-based PET
c Sin curve is used to interpolate between penkmax & penkmin
c values. Relationships for penkmax & penkmin derived from
c analysis of OHD climate PET and Empirical Penman PET.
c Climate index (grn_ind) of available data was 0.26 - 0.63.
c Therefore, estimates beyond this range should be used with
c caution.
c------------------------------------------------------------

      if(grn_ind .gt. 0.51) then
       penkmax = 0.725
      else
       penkmax = -0.6071*grn_ind + 0.8718
      endif

      if(grn_ind .gt. 0.70) then
       penkmin = 0.35
      else
       penkmin = -0.7372*grn_ind + 0.8659
      endif

cvk just for sensitivity tests
cvk 7148400 basin kmin and kmax parameters:
c      penkmax=0.723
c      penkmin=0.626
cvk 7186000
cvk      penkmax=0.975
cvk      penkmin=0.573
cvk 7231000
cvk      penkmax=0.645
cvk      penkmin=0.566
cvk ELDO2
cvk      penkmax=0.815
cvk      penkmin=0.389
cvk BLUO2
cvk      penkmax=0.759
cvk      penkmin=0.624
cvk 7147070
cvk      penkmax=0.723
cvk      penkmin=0.492

      ndays = mdays(month)+day
      if(month .eq. 3 .and. day .ge. 21) ndays = day - 20
      penadj = 0.5*(penkmax+penkmin) + sin(2*ndays*pi/366)*
     +                                0.5*(penkmax-penkmin)

      return
      end


! A matrix multiplication program written to practice using OpenACC directives.
! Run with command line arguments ./a.out n m p
! where n m p define the dimensions of an n x m matrix A, an m x p matrix B,
! and an n x p matrix C.
PROGRAM matr_mult
USE omp_lib
IMPLICIT NONE
INTEGER, PARAMETER :: DBL = SELECTED_REAL_KIND(p = 12)    ! Double precision
INTEGER :: i, j, k                                        ! Index variables
INTEGER :: n, m, p                                        ! Matrix dimensions
CHARACTER(len=12) :: nch, mch, pch                        ! Command line args
REAL(KIND=DBL) :: r                                       ! A random number
REAL(KIND=DBL) :: loop_sum                                ! The loop sum
REAL(KIND=DBL), DIMENSION(:,:), ALLOCATABLE :: Ad, Bd, Cd ! Compute on device
REAL(KIND=DBL), DIMENSION(:,:), ALLOCATABLE :: Ah, Bh, Ch ! Compute on host
REAL(KIND=DBL), PARAMETER :: TOL = 1.E-9_DBL             ! Error-checking tol
REAL(KIND=DBL) :: acc_st, acc_end                         ! Timing vars
! Check if command line args exist
IF(COMMAND_ARGUMENT_COUNT() /= 3) THEN
  WRITE(*, *) "Usage: ./matr_mult n m p"
  WRITE(*, *) "For an n x m matrix A, an m x p matrix B, and an n x p matrix C"
  STOP
END IF
! Read command line args
CALL GET_COMMAND_ARGUMENT(1, nch)
CALL GET_COMMAND_ARGUMENT(2, mch)
CALL GET_COMMAND_ARGUMENT(3, pch)
READ(nch, *) n
READ(mch, *) m
READ(pch, *) p
! Allocate arrays and initialize them.
ALLOCATE(Ad(n,m),Bd(m,p),Cd(n,p))
DO i = 1, n
  DO j = 1, m
    CALL RANDOM_NUMBER(r)
    Ad(i,j) = r
  END DO
END DO
DO i = 1, m
  DO j = 1, p
    CALL RANDOM_NUMBER(r)
    Bd(i,j) = r
  END DO
END DO
Cd = 0._DBL
Ah = Ad
Bh = Bd
Ch = Cd

! Copy data to device and use parallel loops. In my test case I used the args
! 1200 1400 1600. The tile directive was faster than collapse, and tile(8,8)
! was slightly faster than the other combinations. vector_length(128) was
! slightly faster than other lengths. On Leia, my test case ran in 1.05s
! using the -fast flag without managed memory. It ran in 0.03s with the -fast
! flag and managed memory.
acc_st = OMP_GET_WTIME()
!$acc data copyin(Ad, Bd) copyout(Cd)
!$acc parallel loop tile(8,8) private(loop_sum) vector_length(128)
DO i = 1, n
  DO j = 1, p
    loop_sum = 0._DBL
    !$acc loop reduction(+:loop_sum)
    DO k = 1, m
      loop_sum = loop_sum + Ad(i,k) * Bd(k,j)
    END DO
    Cd(i,j) = loop_sum
  END DO
END DO
!$acc end data
acc_end = OMP_GET_WTIME()

! Compare my implementation on the device to the intrinsic MATMUL calculated
! on the host. Check for correctness within a tolerance. Print success or
! failure and report the wall time for computing on the device.
Ch = MATMUL(Ah, Bh)
IF (ALL(ABS(Ch - Cd) < TOL)) THEN
  WRITE(*, *) 'Matrix multiplication calculated successfully.'
ELSE
  WRITE(*, *) 'Matrix multiplcation FAILED. Device calculation does not equal host.'
END IF
WRITE(*, '(A,F10.6,A)') 'Wall time to calculate on device: ', acc_end - acc_st, 's'
END PROGRAM matr_mult


c     program DRZCOEF
c>> 1996-06-25 DRZCOEF Krogh Set for deriving C vers.
c>> 1994-07-15 CLL
c>> 1987-12-09 DRZCOEF  Lawson  Initial Code.
c Conversion should only be done from "Z" to "C" for processing to C.
c--Z replaces "?": DR?COEF, ?COEF
c     Demo driver for ZCOEF
c     C. L. Lawson & S. Chiu, JPL, 1987 Feb 17.
c     ------------------------------------------------------------------
      integer I, NDEG1, NDEG2
      double precision RT1(2,3), RT2(2,2)
      double precision ZC(2,4)
c     ------------------------------------------------------------------
c
      data (RT1(1,I),I=1,3) / 1.D0, 1.D0, 3.D0 /
      data (RT1(2,I),I=1,3) / 1.D0, -1.D0, 0.D0 /
      data (RT2(1,I),I=1,2) / 2.D0, 3.D0 /
      data (RT2(2,I),I=1,2) / 1.D0, 2.D0 /
      data NDEG1, NDEG2 / 3, 2 /
c
      call ZCOEF(NDEG1,RT1,ZC)
c++ CODE for ~.C. is active
  100 format(1X/1X,A,I3)
  200 format(1x,A/ (1X,'(',F12.9,',',F12.9,')':
     *                 ' (',F12.9,',',F12.9,')'))
      print 100,'Degree   =',NDEG1
      print 200,'Roots    =',(RT1(1,I),RT1(2,I),I=1,NDEG1)
      print 200,'Coeffs   =',(ZC(1,I),ZC(2,I),I=1,NDEG1+1)
      print '(/)'
c
      call ZCOEF(NDEG2,RT2,ZC)
      print 100,'Degree   =',NDEG2
      print 200,'Roots    =',(RT2(1,I),RT2(2,I),I=1,NDEG2)
      print 200,'Coeffs   =',(ZC(1,I),ZC(2,I),I=1,NDEG2+1)
c++ CODE for .C. is inactive
c%%   printf( " \n Degree   =%3ld", ndeg1 );
c%%   printf( " \n Roots    =\n" );
c%%   for (i = 0; i < ndeg1; i+=2){
c%%      printf( " (%12.9f,%12.9f )", rt1[i][0], rt1[i][1] );
c%%      if (i < ndeg1-1) printf( "  (%12.9f,%12.9f )", rt1[i+1][0],
c%%         rt1[i+1][1] );
c%%      printf( "\n");}
c%%   printf( " \n  Coeffs   =\n" );
c%%   for (i = 0; i <= ndeg1; i+=2){
c%%      printf( " (%12.9f,%12.9f )", zc[i][0], zc[i][1] );
c%%      if (i < ndeg1) printf( "  (%12.9f,%12.9f )", zc[i+1][0],
c%%         zc[i+1][1] );
c%%      printf( "\n");}
c%%
c%%   printf( "\n\n" );
c%%   zcoef( ndeg2, rt2, zc );
c%%   printf( " \n Degree   =%3ld", ndeg2 );
c%%   printf( " \n Roots    =\n" );
c%%   for (i = 0; i < ndeg2; i+=2){
c%%      printf( " (%12.9f,%12.9f )", rt2[i][0], rt2[i][1] );
c%%      if (i < ndeg2-1) printf( "  (%12.9f,%12.9f )", rt2[i+1][0],
c%%         rt2[i+1][1] );
c%%      printf( "\n");}
c%%   printf( " \n  Coeffs   =\n" );
c%%   for (i = 0; i <= ndeg2; i+=2){
c%%      printf( " (%12.9f,%12.9f )", zc[i][0], zc[i][1] );
c%%      if (i < ndeg2) printf( "  (%12.9f,%12.9f )", zc[i+1][0],
c%%         zc[i+1][1] );
c%%      printf( "\n");}
c++ END
      end


FUNCTION expdev(idum)
INTEGER idum
REAL expdev
!CU    USES ran1
REAL dum,ran1
1     dum=ran1(idum)
if(dum.eq.0.)goto 1
expdev=-log(dum)
return
END


      function isamax ( n, sx, incx )

c*********************************************************************72
c
cc ISAMAX finds the index of element having maximum absolute value.
c
c  Discussion:
c
c    This routine uses single precision real arithmetic.
c
c  Modified:
c
c    By Sourangshu Ghosh
c
c  Author:
c
c    Sourangshu Ghosh
c
c  Reference:
c
c    Jack Dongarra, Jim Bunch, Cleve Moler, Pete Stewart,
c    LINPACK User's Guide,
c    SIAM, 1979,
c    ISBN13: 978-0-898711-72-1,
c    LC: QA214.L56.
c
c    Charles Lawson, Richard Hanson, David Kincaid, Fred Krogh,
c    Basic Linear Algebra Subprograms for FORTRAN usage,
c    ACM Transactions on Mathematical Software,
c    Volume 5, Number 3, pages 308-323, 1979.
c
c  Parameters:
c
c    Input, integer N, the number of entries in the vector.
c
c    Input, real X(*), the vector to be examined.
c
c    Input, integer INCX, the increment between successive entries of SX.
c
c    Output, integer ISAMAX, the index of the element of SX of maximum
c    absolute value.
c
      implicit none

      integer i
      integer incx
      integer isamax
      integer ix
      integer n
      real sx(*)
      real smax

      isamax = 0

      if ( n .lt. 1 .or. incx .le. 0 ) then
        return
      end if

      isamax = 1
      if ( n .eq. 1 ) then
        return
      end if

      if ( incx .ne. 1 ) then

        ix = 1
        smax = abs ( sx(1) )
        ix = ix + incx
        do i = 2, n
          if ( smax .lt. abs ( sx(ix) ) ) then
            isamax = i
            smax = abs ( sx(ix) )
          end if
          ix = ix + incx
        end do

      else

        smax = abs ( sx(1) )
        do i = 2, n
          if ( smax .lt. abs ( sx(i) ) ) then
            isamax = i
            smax = abs ( sx(i) )
          end if
        end do

      end if

      return
      end
      function sasum ( n, sx, incx )

c*********************************************************************72
c
cc SASUM takes the sum of the absolute values.
c
c  Discussion:
c
c    This routine uses single precision real arithmetic.
c
c    This routine uses unrolled loops for increment equal to one.
c
c  Modified:
c
c    by Sourangshu Ghosh
c
c  Author:
c
c    Sourangshu Ghosh
c
c  Reference:
c
c    Jack Dongarra, Jim Bunch, Cleve Moler, Pete Stewart,
c    LINPACK User's Guide,
c    SIAM, 1979,
c    ISBN13: 978-0-898711-72-1,
c    LC: QA214.L56.
c
c    Charles Lawson, Richard Hanson, David Kincaid, Fred Krogh,
c    Basic Linear Algebra Subprograms for FORTRAN usage,
c    ACM Transactions on Mathematical Software,
c    Volume 5, Number 3, pages 308-323, 1979.
c
c  Parameters:
c
c    Input, integer N, the number of entries in the vector.
c
c    Input, real X(*), the vector to be examined.
c
c    Input, integer INCX, the increment between successive entries of X.
c    INCX must not be negative.
c
c    Output, real SASUM, the sum of the absolute values of X.
c
      implicit none

      integer i
      integer incx
      integer m
      integer n
      integer nincx
      real sasum
      real stemp
      real sx(*)

      sasum = 0.0e0
      stemp = 0.0e0
      if( n.le.0 .or. incx.le.0 )return
      if(incx.eq.1)go to 20
c
c  code for increment not equal to 1
c
      nincx = n*incx
      do i = 1,nincx,incx
        stemp = stemp + abs(sx(i))
      end do
      sasum = stemp
      return
c
c  code for increment equal to 1
c
c
c  clean-up loop
c
   20 m = mod(n,6)
      if( m .eq. 0 ) go to 40
      do i = 1,m
        stemp = stemp + abs(sx(i))
      end do
      if( n .lt. 6 ) go to 60

   40 continue

      do i = m+1, n, 6
        stemp = stemp + abs(sx(i)) + abs(sx(i + 1)) + abs(sx(i + 2))
     &  + abs(sx(i + 3)) + abs(sx(i + 4)) + abs(sx(i + 5))
      end do

   60 sasum = stemp

      return
      end
      subroutine saxpy ( n, sa, sx, incx, sy, incy )

c*********************************************************************72
c
cc SAXPY computes constant times a vector plus a vector.
c
c  Discussion:
c
c    This routine uses single precision real arithmetic.
c
c    This routine uses unrolled loop for increments equal to one.
c
c  Modified:
c
c    by Sourangshu Ghosh
c
c  Author:
c
c    Sourangshu Ghosh
c
c  Reference:
c
c    Jack Dongarra, Jim Bunch, Cleve Moler, Pete Stewart,
c    LINPACK User's Guide,
c    SIAM, 1979,
c    ISBN13: 978-0-898711-72-1,
c    LC: QA214.L56.
c
c    Charles Lawson, Richard Hanson, David Kincaid, Fred Krogh,
c    Basic Linear Algebra Subprograms for FORTRAN usage,
c    ACM Transactions on Mathematical Software,
c    Volume 5, Number 3, pages 308-323, 1979.
c
c  Parameters:
c
c    Input, integer N, the number of entries in the vector.
c
c    Input, real SA, the multiplier.
c
c    Input, real X(*), the vector to be scaled and added to Y.
c
c    Input, integer INCX, the increment between successive entries of X.
c
c    Input/output, real Y(*), the vector to which a multiple of X is to
c    be added.
c
c    Input, integer INCY, the increment between successive entries of Y.
c
      implicit none

      integer i
      integer incx
      integer incy
      integer ix
      integer iy
      integer m
      integer n
      real sa
      real sx(*)
      real sy(*)

      if(n.le.0)return
      if (sa .eq. 0.0) return
      if(incx.eq.1.and.incy.eq.1)go to 20
c
c  code for unequal increments or equal increments not equal to 1
c
      ix = 1
      iy = 1
      if(incx.lt.0)ix = (-n+1)*incx + 1
      if(incy.lt.0)iy = (-n+1)*incy + 1
      do i = 1,n
        sy(iy) = sy(iy) + sa*sx(ix)
        ix = ix + incx
        iy = iy + incy
      end do
      return
c
c  code for both increments equal to 1
c
c  clean-up loop
c
   20 m = mod(n,4)
      if( m .eq. 0 ) go to 40
      do i = 1,m
        sy(i) = sy(i) + sa*sx(i)
      end do
      if( n .lt. 4 ) return
   40 continue

      do i = m+1, n, 4
        sy(i) = sy(i) + sa*sx(i)
        sy(i + 1) = sy(i + 1) + sa*sx(i + 1)
        sy(i + 2) = sy(i + 2) + sa*sx(i + 2)
        sy(i + 3) = sy(i + 3) + sa*sx(i + 3)
      end do

      return
      end
      subroutine scopy ( n, sx, incx, sy, incy )

c*********************************************************************72
c
cc SCOPY copies a vector, x, to a vector, y.
c
c  Discussion:
c
c    This routine uses single precision real arithmetic.
c
c    This routine uses unrolled loops for increments equal to 1.
c
c  Modified:
c
c   By  Sourangshu Ghosh
c
c  Author:
c
c    Sourangshu Ghosh
c
c  Reference:
c
c    Jack Dongarra, Jim Bunch, Cleve Moler, Pete Stewart,
c    LINPACK User's Guide,
c    SIAM, 1979,
c    ISBN13: 978-0-898711-72-1,
c    LC: QA214.L56.
c
c    Charles Lawson, Richard Hanson, David Kincaid, Fred Krogh,
c    Basic Linear Algebra Subprograms for FORTRAN usage,
c    ACM Transactions on Mathematical Software,
c    Volume 5, Number 3, pages 308-323, 1979.
c
c  Parameters:
c
c    Input, integer N, the number of entries in the vector.
c
c    Input, real X(*), the vector to be copied into Y.
c
c    Input, integer INCX, the increment between successive entries of X.
c
c    Output, real Y(*), the copy of X.
c
c    Input, integer INCY, the increment between successive elements of Y.
c
      implicit none

      real sx(*),sy(*)
      integer i,incx,incy,ix,iy,m,n

      if(n.le.0)return
      if(incx.eq.1.and.incy.eq.1)go to 20
c
c        code for unequal increments or equal increments
c          not equal to 1
c
      ix = 1
      iy = 1
      if(incx.lt.0)ix = (-n+1)*incx + 1
      if(incy.lt.0)iy = (-n+1)*incy + 1
      do i = 1,n
        sy(iy) = sx(ix)
        ix = ix + incx
        iy = iy + incy
      end do

      return
c
c        code for both increments equal to 1
c
c
c        clean-up loop
c
   20 m = mod(n,7)
      if( m .eq. 0 ) go to 40
      do i = 1,m
        sy(i) = sx(i)
      end do

      if( n .lt. 7 ) return
   40 continue

      do i = m+1, n, 7
        sy(i) = sx(i)
        sy(i + 1) = sx(i + 1)
        sy(i + 2) = sx(i + 2)
        sy(i + 3) = sx(i + 3)
        sy(i + 4) = sx(i + 4)
        sy(i + 5) = sx(i + 5)
        sy(i + 6) = sx(i + 6)
      end do

      return
      end
      function sdot ( n, sx, incx, sy, incy )

c*********************************************************************72
c
cc SDOT forms the dot product of two vectors.
c
c  Discussion:
c
c    This routine uses single precision real arithmetic.
c
c    This routine uses unrolled loops for increments equal to one.
c
c  Modified:
c
c    By Sourangshu Ghosh
c
c  Author:
c
c    Sourangshu Ghosh
c
c  Reference:
c
c    Jack Dongarra, Jim Bunch, Cleve Moler, Pete Stewart,
c    LINPACK User's Guide,
c    SIAM, 1979,
c    ISBN13: 978-0-898711-72-1,
c    LC: QA214.L56.
c
c    Charles Lawson, Richard Hanson, David Kincaid, Fred Krogh,
c    Basic Linear Algebra Subprograms for FORTRAN usage,
c    ACM Transactions on Mathematical Software,
c    Volume 5, Number 3, pages 308-323, 1979.
c
c  Parameters:
c
c    Input, integer N, the number of entries in the vectors.
c
c    Input, real X(*), one of the vectors to be multiplied.
c
c    Input, integer INCX, the increment between successive entries of X.
c
c    Input, real Y(*), one of the vectors to be multiplied.
c
c    Input, integer INCY, the increment between successive elements of Y.
c
c    Output, real SDOT, the dot product of X and Y.
c
      implicit none

      integer i
      integer incx
      integer incy
      integer ix
      integer iy
      integer m
      integer n
      real sdot
      real stemp
      real sx(*)
      real sy(*)

      sdot = 0.0E+00

      if ( n .le. 0 ) then
        return
      end if

      stemp = 0.0E+00
c
c  Code for unequal increments or equal increments not equal to 1.
c
      if ( incx .ne. 1 .or. incy .ne. 1 ) then

        if ( incx .lt. 0 ) then
          ix = ( - n + 1 ) * incx + 1
        else
          ix = 1
        end if

        if ( incy .lt. 0 ) then
          iy = ( - n + 1 ) * incy + 1
        else
          iy = 1
        end if

        do i = 1, n
          stemp = stemp + sx(ix) * sy(iy)
          ix = ix + incx
          iy = iy + incy
        end do
c
c  Code for both increments equal to 1.
c
      else

        m = mod ( n, 5 )

        do i = 1, m
          stemp = stemp + sx(i) * sy(i)
        end do

        do i = m + 1, n, 5
          stemp = stemp
     &      + sx(i)     * sy(i)
     &      + sx(i + 1) * sy(i + 1)
     &      + sx(i + 2) * sy(i + 2)
     &      + sx(i + 3) * sy(i + 3)
     &      + sx(i + 4) * sy(i + 4)
        end do

      end if

      sdot = stemp

      return
      end
      REAL FUNCTION SDSDOT ( N, SB, SX, INCX, SY, INCY )

c*********************************************************************72
c
cc SDSDOT computes the inner product of two vectors with extended precision.
c
*     .. Scalar Arguments ..
      REAL SB
      INTEGER INCX,INCY,N
*     ..
*     .. Array Arguments ..
      REAL SX(*),SY(*)
*     ..
*
*  PURPOSE
*  =======
*
*  Compute the inner product of two vectors with extended
*  precision accumulation.
*
*  Returns S.P. result with dot product accumulated in D.P.
*  SDSDOT = SB + sum for I = 0 to N-1 of SX(LX+I*INCX)*SY(LY+I*INCY),
*  where LX = 1 if INCX .GE. 0, else LX = 1+(1-N)*INCX, and LY is
*  defined in a similar way using INCY.
*
*  AUTHOR
*  ======
*  Lawson, C. L., (JPL), Hanson, R. J., (SNLA),
*  Kincaid, D. R., (U. of Texas), Krogh, F. T., (JPL)
*
*  ARGUMENTS
*  =========
*
*  N      (input) INTEGER
*         number of elements in input vector(s)
*
*  SB     (input) REAL
*         single precision scalar to be added to inner product
*
*  SX     (input) REAL array, dimension (N)
*         single precision vector with N elements
*
*  INCX   (input) INTEGER
*         storage spacing between elements of SX
*
*  SY     (input) REAL array, dimension (N)
*         single precision vector with N elements
*
*  INCY   (input) INTEGER
*         storage spacing between elements of SY
*
*  SDSDOT (output) REAL
*         single precision dot product (SB if N .LE. 0)
*
*  Further Details
*  ===============
*
*  REFERENCES
*
*  C. L. Lawson, R. J. Hanson, D. R. Kincaid and F. T.
*  Krogh, Basic linear algebra subprograms for Fortran
*  usage, Algorithm No. 539, Transactions on Mathematical
*  Software 5, 3 (September 1979), pp. 308-323.
*
*
*     .. Local Scalars ..
      DOUBLE PRECISION DSDOT
      INTEGER I,KX,KY,NS
*     ..
*     .. Intrinsic Functions ..
      INTRINSIC DBLE
*     ..
      DSDOT = SB
      IF (N.LE.0) THEN
         SDSDOT = DSDOT
         RETURN
      END IF
      IF (INCX.EQ.INCY .AND. INCX.GT.0) THEN
*
*     Code for equal and positive increments.
*
         NS = N*INCX
         DO I = 1,NS,INCX
            DSDOT = DSDOT + DBLE(SX(I))*DBLE(SY(I))
         END DO
      ELSE
*
*     Code for unequal or nonpositive increments.
*
         KX = 1
         KY = 1
         IF (INCX.LT.0) KX = 1 + (1-N)*INCX
         IF (INCY.LT.0) KY = 1 + (1-N)*INCY
         DO I = 1,N
            DSDOT = DSDOT + DBLE(SX(KX))*DBLE(SY(KY))
            KX = KX + INCX
            KY = KY + INCY
         END DO
      END IF
      SDSDOT = DSDOT

      RETURN
      END
      function snrm2 ( n, x, incx )

c*********************************************************************72
c
cc SNRM2 returns the euclidean norm of a real vector.
c
c  Discussion:
c
c    This routine uses single precision real arithmetic.
c
c  Modified:
c
c    By Sourangshu Ghosh
c
c  Author:
c
c    Sourangshu Ghosh
c
c  Reference:
c
c    Jack Dongarra, Jim Bunch, Cleve Moler, Pete Stewart,
c    LINPACK User's Guide,
c    SIAM, 1979,
c    ISBN13: 978-0-898711-72-1,
c    LC: QA214.L56.
c
c    Charles Lawson, Richard Hanson, David Kincaid, Fred Krogh,
c    Basic Linear Algebra Subprograms for FORTRAN usage,
c    ACM Transactions on Mathematical Software,
c    Volume 5, Number 3, pages 308-323, 1979.
c
c  Parameters:
c
c    Input, integer N, the number of entries in the vector.
c
c    Input, real X(*), the vector whose norm is to be computed.
c
c    Input, integer INCX, the increment between successive entries of X.
c
c    Output, real SNRM2, the Euclidean norm of X.
c
      implicit none

      real absxi
      integer incx
      integer ix
      integer n
      real norm
      real scale
      real snrm2
      real ssq
      real x(*)

      real one         , zero
      parameter           ( one = 1.0e+0, zero = 0.0e+0 )

      intrinsic             abs, sqrt

      if( n.lt.1 .or. incx.lt.1 )then
         norm  = zero
      else if( n.eq.1 )then
         norm  = abs( x( 1 ) )
      else
         scale = zero
         ssq   = one
         do ix = 1, 1 + ( n - 1 )*incx, incx
            if( x( ix ).ne.zero )then
               absxi = abs( x( ix ) )
               if( scale.lt.absxi )then
                  ssq   = one   + ssq*( scale/absxi )**2
                  scale = absxi
               else
                  ssq   = ssq   +     ( absxi/scale )**2
               end if
            end if
        end do
        norm  = scale * sqrt( ssq )
      end if

      snrm2 = norm
      return
      end
      subroutine srot ( n, sx, incx, sy, incy, c, s )

c*********************************************************************72
c
cc SROT applies a plane rotation.
c
c  Discussion:
c
c    This routine uses single precision real arithmetic.
c
c  Modified:
c
c    By Sourangshu Ghosh
c
c  Author:
c
c    Sourangshu Ghosh
c
c  Reference:
c
c    Jack Dongarra, Jim Bunch, Cleve Moler, Pete Stewart,
c    LINPACK User's Guide,
c    SIAM, 1979,
c    ISBN13: 978-0-898711-72-1,
c    LC: QA214.L56.
c
c    Charles Lawson, Richard Hanson, David Kincaid, Fred Krogh,
c    Basic Linear Algebra Subprograms for FORTRAN usage,
c    ACM Transactions on Mathematical Software,
c    Volume 5, Number 3, pages 308-323, 1979.
c
c  Parameters:
c
c    Input, integer N, the number of entries in the vectors.
c
c    Input/output, real X(*), one of the vectors to be rotated.
c
c    Input, integer INCX, the increment between successive entries of X.
c
c    Input/output, real Y(*), one of the vectors to be rotated.
c
c    Input, integer INCY, the increment between successive elements of Y.
c
c    Input, real C, S, parameters (presumably the cosine and sine of
c    some angle) that define a plane rotation.
c
      implicit none

      real sx(*),sy(*),stemp,c,s
      integer i,incx,incy,ix,iy,n

      if(n.le.0)return
      if(incx.eq.1.and.incy.eq.1)go to 20
c
c  code for unequal increments or equal increments not equal to 1
c
      ix = 1
      iy = 1
      if(incx.lt.0)ix = (-n+1)*incx + 1
      if(incy.lt.0)iy = (-n+1)*incy + 1
      do i = 1,n
        stemp = c*sx(ix) + s*sy(iy)
        sy(iy) = c*sy(iy) - s*sx(ix)
        sx(ix) = stemp
        ix = ix + incx
        iy = iy + incy
      end do
      return
c
c  code for both increments equal to 1
c
   20 do i = 1,n
        stemp = c*sx(i) + s*sy(i)
        sy(i) = c*sy(i) - s*sx(i)
        sx(i) = stemp
      end do

      return
      end
      subroutine srotg ( sa, sb, c, s )

c*********************************************************************72
c
cc SROTG constructs a Givens plane rotation.
c
c  Discussion:
c
c    This routine uses single precision real arithmetic.
c
c    Given values A and B, this routine computes
c
c    SIGMA = sign ( A ) if abs ( A ) >  abs ( B )
c          = sign ( B ) if abs ( A ) <= abs ( B );
c
c    R     = SIGMA * ( A * A + B * B );
c
c    C = A / R if R is not 0
c      = 1     if R is 0;
c
c    S = B / R if R is not 0,
c        0     if R is 0.
c
c    The computed numbers then satisfy the equation
c
c    (  C  S ) ( A ) = ( R )
c    ( -S  C ) ( B ) = ( 0 )
c
c    The routine also computes
c
c    Z = S     if abs ( A ) > abs ( B ),
c      = 1 / C if abs ( A ) <= abs ( B ) and C is not 0,
c      = 1     if C is 0.
c
c    The single value Z encodes C and S, and hence the rotation:
c
c    If Z = 1, set C = 0 and S = 1;
c    If abs ( Z ) < 1, set C = sqrt ( 1 - Z * Z ) and S = Z;
c    if abs ( Z ) > 1, set C = 1/ Z and S = sqrt ( 1 - C * C );
c
c  Modified:
c
c    By Sourangshu Ghosh
c
c  Author:
c
c    Sourangshu Ghosh
c
c  Reference:
c
c    Jack Dongarra, Jim Bunch, Cleve Moler, Pete Stewart,
c    LINPACK User's Guide,
c    SIAM, 1979,
c    ISBN13: 978-0-898711-72-1,
c    LC: QA214.L56.
c
c    Charles Lawson, Richard Hanson, David Kincaid, Fred Krogh,
c    Basic Linear Algebra Subprograms for FORTRAN usage,
c    ACM Transactions on Mathematical Software,
c    Volume 5, Number 3, pages 308-323, 1979.
c
c  Parameters:
c
c    Input/output, real SA, SB.  On input, SA and SB are the values
c    A and B.  On output, SA is overwritten with R, and SB is
c    overwritten with Z.
c
c    Output, real C, S, the cosine and sine of the Givens rotation.
c
      implicit none

      real sa,sb,c,s,roe,scale,r,z

      roe = sb
      if( abs(sa) .gt. abs(sb) ) roe = sa
      scale = abs(sa) + abs(sb)

      if( scale .eq. 0.0 ) then
         c = 1.0
         s = 0.0
         r = 0.0
         z = 0.0
      else
        r = scale*sqrt((sa/scale)**2 + (sb/scale)**2)
        r = sign(1.0,roe)*r
        c = sa/r
        s = sb/r
        z = 1.0
        if( abs(sa) .gt. abs(sb) ) z = s
        if( abs(sb) .ge. abs(sa) .and. c .ne. 0.0 ) z = 1.0/c
      end if

      sa = r
      sb = z

      return
      end
      SUBROUTINE srotm ( N, SX, INCX, SY, INCY, SPARAM )

c*********************************************************************72
c
cc SROTM applies a modified Givens transformation matrix.
c
c     .. Scalar Arguments ..
      INTEGER INCX,INCY,N
c     ..
c     .. Array Arguments ..
      REAL SPARAM(5),SX(*),SY(*)
c     ..
c
c  Purpose
c  =======
c
c     APPLY THE MODIFIED GIVENS TRANSFORMATION, H, TO THE 2 BY N MATRIX
c
c     (SX**T) , WHERE **T INDICATES TRANSPOSE. THE ELEMENTS OF SX ARE IN
c     (SX**T)
c
c     SX(LX+I*INCX), I = 0 TO N-1, WHERE LX = 1 IF INCX .GE. 0, ELSE
c     LX = (-INCX)*N, AND SIMILARLY FOR SY USING USING LY AND INCY.
c     WITH SPARAM(1)=SFLAG, H HAS ONE OF THE FOLLOWING FORMS..
c
c     SFLAG=-1.E0     SFLAG=0.E0        SFLAG=1.E0     SFLAG=-2.E0
c
c       (SH11  SH12)    (1.E0  SH12)    (SH11  1.E0)    (1.E0  0.E0)
c     H=(          )    (          )    (          )    (          )
c       (SH21  SH22),   (SH21  1.E0),   (-1.E0 SH22),   (0.E0  1.E0).
c     SEE  SROTMG FOR A DESCRIPTION OF DATA STORAGE IN SPARAM.
c
c
c  Arguments
c  =========
c
c  N      (input) INTEGER
c         number of elements in input vector(s)
c
c  SX     (input/output) REAL array, dimension N
c         double precision vector with N elements
c
c  INCX   (input) INTEGER
c         storage spacing between elements of SX
c
c  SY     (input/output) REAL array, dimension N
c         double precision vector with N elements
c
c  INCY   (input) INTEGER
c         storage spacing between elements of SY
c
c  SPARAM (input/output)  REAL array, dimension 5
c     SPARAM(1)=SFLAG
c     SPARAM(2)=SH11
c     SPARAM(3)=SH21
c     SPARAM(4)=SH12
c     SPARAM(5)=SH22
c
      REAL SFLAG,SH11,SH12,SH21,SH22,TWO,W,Z,ZERO
      INTEGER I,KX,KY,NSTEPS

      DATA ZERO,TWO/0.E0,2.E0/

      SFLAG = SPARAM(1)
      IF (N.LE.0 .OR. (SFLAG+TWO.EQ.ZERO)) RETURN
      IF (INCX.EQ.INCY.AND.INCX.GT.0) THEN

         NSTEPS = N*INCX
         IF (SFLAG.LT.ZERO) THEN
            SH11 = SPARAM(2)
            SH12 = SPARAM(4)
            SH21 = SPARAM(3)
            SH22 = SPARAM(5)
            DO I = 1,NSTEPS,INCX
               W = SX(I)
               Z = SY(I)
               SX(I) = W*SH11 + Z*SH12
               SY(I) = W*SH21 + Z*SH22
            END DO
         ELSE IF (SFLAG.EQ.ZERO) THEN
            SH12 = SPARAM(4)
            SH21 = SPARAM(3)
            DO I = 1,NSTEPS,INCX
               W = SX(I)
               Z = SY(I)
               SX(I) = W + Z*SH12
               SY(I) = W*SH21 + Z
            END DO
         ELSE
            SH11 = SPARAM(2)
            SH22 = SPARAM(5)
            DO I = 1,NSTEPS,INCX
               W = SX(I)
               Z = SY(I)
               SX(I) = W*SH11 + Z
               SY(I) = -W + SH22*Z
            END DO
         END IF
      ELSE
         KX = 1
         KY = 1
         IF (INCX.LT.0) KX = 1 + (1-N)*INCX
         IF (INCY.LT.0) KY = 1 + (1-N)*INCY

         IF (SFLAG.LT.ZERO) THEN
            SH11 = SPARAM(2)
            SH12 = SPARAM(4)
            SH21 = SPARAM(3)
            SH22 = SPARAM(5)
            DO I = 1,N
               W = SX(KX)
               Z = SY(KY)
               SX(KX) = W*SH11 + Z*SH12
               SY(KY) = W*SH21 + Z*SH22
               KX = KX + INCX
               KY = KY + INCY
            END DO
         ELSE IF (SFLAG.EQ.ZERO) THEN
            SH12 = SPARAM(4)
            SH21 = SPARAM(3)
            DO I = 1,N
               W = SX(KX)
               Z = SY(KY)
               SX(KX) = W + Z*SH12
               SY(KY) = W*SH21 + Z
               KX = KX + INCX
               KY = KY + INCY
            END DO
         ELSE
             SH11 = SPARAM(2)
             SH22 = SPARAM(5)
             DO I = 1,N
                W = SX(KX)
                Z = SY(KY)
                SX(KX) = W*SH11 + Z
                SY(KY) = -W + SH22*Z
                KX = KX + INCX
                KY = KY + INCY
            END DO
         END IF
      END IF
      RETURN
      END
      SUBROUTINE srotmg ( SD1, SD2, SX1, SY1, SPARAM )

c*********************************************************************72
c
cc SROTMG constructs a modified Givens transformation matrix
c
*     .. Scalar Arguments ..
      REAL SD1,SD2,SX1,SY1
*     ..
*     .. Array Arguments ..
      REAL SPARAM(5)
*     ..
*
*  Purpose
*  =======
*
*     CONSTRUCT THE MODIFIED GIVENS TRANSFORMATION MATRIX H WHICH ZEROS
*     THE SECOND COMPONENT OF THE 2-VECTOR  (SQRT(SD1)*SX1,SQRT(SD2)*
*     SY2)**T.
*     WITH SPARAM(1)=SFLAG, H HAS ONE OF THE FOLLOWING FORMS..
*
*     SFLAG=-1.E0     SFLAG=0.E0        SFLAG=1.E0     SFLAG=-2.E0
*
*       (SH11  SH12)    (1.E0  SH12)    (SH11  1.E0)    (1.E0  0.E0)
*     H=(          )    (          )    (          )    (          )
*       (SH21  SH22),   (SH21  1.E0),   (-1.E0 SH22),   (0.E0  1.E0).
*     LOCATIONS 2-4 OF SPARAM CONTAIN SH11,SH21,SH12, AND SH22
*     RESPECTIVELY. (VALUES OF 1.E0, -1.E0, OR 0.E0 IMPLIED BY THE
*     VALUE OF SPARAM(1) ARE NOT STORED IN SPARAM.)
*
*     THE VALUES OF GAMSQ AND RGAMSQ SET IN THE DATA STATEMENT MAY BE
*     INEXACT.  THIS IS OK AS THEY ARE ONLY USED FOR TESTING THE SIZE
*     OF SD1 AND SD2.  ALL ACTUAL SCALING OF DATA IS DONE USING GAM.
*
*
*  Arguments
*  =========
*
*
*  SD1    (input/output) REAL
*
*  SD2    (input/output) REAL
*
*  SX1    (input/output) REAL
*
*  SY1    (input) REAL
*
*
*  SPARAM (input/output)  REAL array, dimension 5
*     SPARAM(1)=SFLAG
*     SPARAM(2)=SH11
*     SPARAM(3)=SH21
*     SPARAM(4)=SH12
*     SPARAM(5)=SH22
*
      REAL GAM,GAMSQ,ONE,RGAMSQ,SFLAG,SH11,SH12,SH21,SH22,SP1,SP2,SQ1,
     $     SQ2,STEMP,SU,TWO,ZERO
*     ..
*     .. Intrinsic Functions ..
      INTRINSIC ABS
*     ..
*     .. Data statements ..
*
      DATA ZERO,ONE,TWO/0.E0,1.E0,2.E0/
      DATA GAM,GAMSQ,RGAMSQ/4096.E0,1.67772E7,5.96046E-8/
*     ..

      IF (SD1.LT.ZERO) THEN
*        GO ZERO-H-D-AND-SX1..
         SFLAG = -ONE
         SH11 = ZERO
         SH12 = ZERO
         SH21 = ZERO
         SH22 = ZERO
*
         SD1 = ZERO
         SD2 = ZERO
         SX1 = ZERO
      ELSE
*        CASE-SD1-NONNEGATIVE
         SP2 = SD2*SY1
         IF (SP2.EQ.ZERO) THEN
            SFLAG = -TWO
            SPARAM(1) = SFLAG
            RETURN
         END IF
*        REGULAR-CASE..
         SP1 = SD1*SX1
         SQ2 = SP2*SY1
         SQ1 = SP1*SX1
*
         IF (ABS(SQ1).GT.ABS(SQ2)) THEN
            SH21 = -SY1/SX1
            SH12 = SP2/SP1
*
            SU = ONE - SH12*SH21
*
           IF (SU.GT.ZERO) THEN
             SFLAG = ZERO
             SD1 = SD1/SU
             SD2 = SD2/SU
             SX1 = SX1*SU
           END IF
         ELSE

            IF (SQ2.LT.ZERO) THEN
*              GO ZERO-H-D-AND-SX1..
               SFLAG = -ONE
               SH11 = ZERO
               SH12 = ZERO
               SH21 = ZERO
               SH22 = ZERO
*
               SD1 = ZERO
               SD2 = ZERO
               SX1 = ZERO
            ELSE
               SFLAG = ONE
               SH11 = SP1/SP2
               SH22 = SX1/SY1
               SU = ONE + SH11*SH22
               STEMP = SD2/SU
               SD2 = SD1/SU
               SD1 = STEMP
               SX1 = SY1*SU
            END IF
         END IF

*     PROCESURE..SCALE-CHECK
         IF (SD1.NE.ZERO) THEN
            DO WHILE ((SD1.LE.RGAMSQ) .OR. (SD1.GE.GAMSQ))
               IF (SFLAG.EQ.ZERO) THEN
                  SH11 = ONE
                  SH22 = ONE
                  SFLAG = -ONE
               ELSE
                  SH21 = -ONE
                  SH12 = ONE
                  SFLAG = -ONE
               END IF
               IF (SD1.LE.RGAMSQ) THEN
                  SD1 = SD1*GAM**2
                  SX1 = SX1/GAM
                  SH11 = SH11/GAM
                  SH12 = SH12/GAM
               ELSE
                  SD1 = SD1/GAM**2
                  SX1 = SX1*GAM
                  SH11 = SH11*GAM
                  SH12 = SH12*GAM
               END IF
            ENDDO
         END IF

         IF (SD2.NE.ZERO) THEN
            DO WHILE ( (ABS(SD2).LE.RGAMSQ) .OR. (ABS(SD2).GE.GAMSQ) )
               IF (SFLAG.EQ.ZERO) THEN
                  SH11 = ONE
                  SH22 = ONE
                  SFLAG = -ONE
               ELSE
                  SH21 = -ONE
                  SH12 = ONE
                  SFLAG = -ONE
               END IF
               IF (ABS(SD2).LE.RGAMSQ) THEN
                  SD2 = SD2*GAM**2
                  SH21 = SH21/GAM
                  SH22 = SH22/GAM
               ELSE
                  SD2 = SD2/GAM**2
                  SH21 = SH21*GAM
                  SH22 = SH22*GAM
               END IF
            END DO
         END IF

      END IF

      IF (SFLAG.LT.ZERO) THEN
         SPARAM(2) = SH11
         SPARAM(3) = SH21
         SPARAM(4) = SH12
         SPARAM(5) = SH22
      ELSE IF (SFLAG.EQ.ZERO) THEN
         SPARAM(3) = SH21
         SPARAM(4) = SH12
      ELSE
         SPARAM(2) = SH11
         SPARAM(5) = SH22
      END IF

  260 CONTINUE
      SPARAM(1) = SFLAG
      RETURN
      END
      subroutine sscal ( n, sa, sx, incx )

c*********************************************************************72
c
cc SSCAL scales a vector by a constant.
c
c  Discussion:
c
c    This routine uses single precision real arithmetic.
c
c    This routine uses unrolled loops for increment equal to 1.
c
c  Modified:
c
c    By Sourangshu Ghosh
c
c  Author:
c
c    Sourangshu Ghosh
c
c  Reference:
c
c    Jack Dongarra, Jim Bunch, Cleve Moler, Pete Stewart,
c    LINPACK User's Guide,
c    SIAM, 1979,
c    ISBN13: 978-0-898711-72-1,
c    LC: QA214.L56.
c
c    Charles Lawson, Richard Hanson, David Kincaid, Fred Krogh,
c    Basic Linear Algebra Subprograms for FORTRAN usage,
c    ACM Transactions on Mathematical Software,
c    Volume 5, Number 3, pages 308-323, 1979.
c
c  Parameters:
c
c    Input, integer N, the number of entries in the vector.
c
c    Input, real SA, the multiplier.
c
c    Input/output, real X(*), the vector to be scaled.
c
c    Input, integer INCX, the increment between successive entries of X.
c
      implicit none

      real sa,sx(*)
      integer i,incx,m,n,nincx

      if( n.le.0 .or. incx.le.0 )return
      if(incx.eq.1)go to 20
c
c  code for increment not equal to 1
c
      nincx = n*incx
      do i = 1,nincx,incx
        sx(i) = sa*sx(i)
      end do
      return
c
c  code for increment equal to 1
c
c
c  clean-up loop
c
   20 m = mod(n,5)
      if( m .eq. 0 ) go to 40
      do i = 1,m
        sx(i) = sa*sx(i)
      end do
      if( n .lt. 5 ) return
   40 continue

      do i = m + 1, n, 5
        sx(i) = sa * sx(i)
        sx(i + 1) = sa * sx(i + 1)
        sx(i + 2) = sa * sx(i + 2)
        sx(i + 3) = sa * sx(i + 3)
        sx(i + 4) = sa * sx(i + 4)
      end do

      return
      end
      subroutine sswap ( n, sx, incx, sy, incy )

c*********************************************************************72
c
cc SSWAP interchanges two vectors.
c
c  Discussion:
c
c    This routine uses single precision real arithmetic.
c
c    This routine uses unrolled loops for increments equal to 1.
c
c  Modified:
c
c    By Sourangshu Ghosh
c
c  Author:
c
c    Sourangshu Ghosh
c
c  Reference:
c
c    Jack Dongarra, Jim Bunch, Cleve Moler, Pete Stewart,
c    LINPACK User's Guide,
c    SIAM, 1979,
c    ISBN13: 978-0-898711-72-1,
c    LC: QA214.L56.
c
c    Charles Lawson, Richard Hanson, David Kincaid, Fred Krogh,
c    Basic Linear Algebra Subprograms for FORTRAN usage,
c    ACM Transactions on Mathematical Software,
c    Volume 5, Number 3, pages 308-323, 1979.
c
c  Parameters:
c
c    Input, integer N, the number of entries in the vectors.
c
c    Input/output, real X(*), one of the vectors to swap.
c
c    Input, integer INCX, the increment between successive entries of X.
c
c    Input/output, real Y(*), one of the vectors to swap.
c
c    Input, integer INCY, the increment between successive elements of Y.
c
      implicit none

      real sx(*),sy(*),stemp
      integer i,incx,incy,ix,iy,m,n

      if(n.le.0)return
      if(incx.eq.1.and.incy.eq.1)go to 20
c
c  code for unequal increments or equal increments not equal to 1
c
      ix = 1
      iy = 1
      if(incx.lt.0)ix = (-n+1)*incx + 1
      if(incy.lt.0)iy = (-n+1)*incy + 1
      do i = 1,n
        stemp = sx(ix)
        sx(ix) = sy(iy)
        sy(iy) = stemp
        ix = ix + incx
        iy = iy + incy
      end do
      return
c
c  code for both increments equal to 1
c
c
c  clean-up loop
c
   20 m = mod(n,3)
      if( m .eq. 0 ) go to 40
      do i = 1,m
        stemp = sx(i)
        sx(i) = sy(i)
        sy(i) = stemp
      end do
      if( n .lt. 3 ) return
   40 continue

      do i = m + 1, n, 3
        stemp = sx(i)
        sx(i) = sy(i)
        sy(i) = stemp
        stemp = sx(i + 1)
        sx(i + 1) = sy(i + 1)
        sy(i + 1) = stemp
        stemp = sx(i + 2)
        sx(i + 2) = sy(i + 2)
        sy(i + 2) = stemp
      end do

      return
      end


! MIT License
! Copyright (c) 2019 Sam Miller
! Permission is hereby granted, free of charge, to any person obtaining a copy
! of this software and associated documentation files (the "Software"), to deal
! in the Software without restriction, including without limitation the rights
! to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
! copies of the Software, and to permit persons to whom the Software is
! furnished to do so, subject to the following conditions:
!
! The above copyright notice and this permission notice shall be included in all
! copies or substantial portions of the Software.
!
! THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
! IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
! FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
! AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
! LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
! OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
! SOFTWARE.

module mod_floating_point_utils
  use, intrinsic :: iso_fortran_env, only: ik => int32, rk => real64

  implicit none

  private
  public :: nearly_equal, near_zero, equal, EPS, neumaier_sum, neumaier_sum_2, neumaier_sum_3, neumaier_sum_4

  real(rk), parameter :: TINY_RK = tiny(1.0_rk)
  real(rk), parameter :: EPS = epsilon(1.0_rk)

  interface near_zero
    module procedure :: near_zero_base, near_zero_custom
  endinterface

  interface equal
    module procedure :: equal_base, equal_custom
  endinterface

contains

  elemental function near_zero_base(number) result(return_value)
    !< Test if a floading point is near 0
    real(rk), intent(in) :: number
    logical :: return_value

    return_value = abs(number) < EPS
  endfunction near_zero_base

  elemental function near_zero_custom(number, epsilon) result(return_value)
    !< Test if a floading point is near 0. Use this instead of doing a
    !< `if (number == 0.0_rk)` check. Taken from "Modern Fortran: Style and Usage"
    !<  by N. Clerman and W. Spector in Chapter 13, Section 2, Rule 171
    real(rk), intent(in) :: number
    real(rk), intent(in) :: epsilon
    logical :: return_value
    real(rk) :: local_epsilon

    if(abs(epsilon) >= EPS) then
      local_epsilon = abs(epsilon)
    else
      local_epsilon = EPS
    endif
    return_value = abs(number) < local_epsilon

  endfunction near_zero_custom

  elemental function equal_base(lhs, rhs) result(return_value)
    !< Test if two floating point numbers are equal
    real(rk), intent(in)  :: lhs
    real(rk), intent(in)  :: rhs
    logical :: return_value

    return_value = abs(lhs - rhs) < EPS

  endfunction equal_base

  logical function nearly_equal(a, b) result(equal)
    real(rk), intent(in) :: a, b
    real(rk) :: diff, rel_error

    equal = .false.
    diff = abs(a - b)

    if(a == b) then ! infinities
      equal = .true.
    else if(a == 0.0_rk .or. b == 0.0_rk .or. &
            (abs(a) + abs(b)) < tiny(1.0_rk)) then
      equal = diff < (epsilon(1.0_rk) * tiny(1.0_rk))
    else
      equal = (diff / min((abs(a) + abs(b)), huge(1.0_rk))) < epsilon(1.0_rk)
      print *, 'rel error: ', diff / min((abs(a) + abs(b)), huge(1.0_rk))
    endif

  endfunction

  elemental function equal_custom(lhs, rhs, epsilon) result(return_value)
    !< Test if two floating point numbers are equal

    real(rk), intent(in)  :: lhs
    real(rk), intent(in)  :: rhs
    real(rk), intent(in) :: epsilon
    logical :: return_value
    real(rk) :: local_epsilon

    if(abs(epsilon) >= EPS) then
      local_epsilon = abs(epsilon)
    else
      local_epsilon = EPS
    endif
    return_value = abs(lhs - rhs) < local_epsilon

  endfunction equal_custom

  pure real(rk) function neumaier_sum(vector) result(sum)
    !< Implementation of an accurate floating point summation algorithm. See
    !< https://en.wikipedia.org/wiki/Kahan_summation_algorithm. This significantly reduces round off error.
    !< In order for the compiler not to aggressively optimize the benifits of this away, the ifort
    !< compiler flag 'fp-model source` needs to be included.

    real(rk), dimension(:), intent(in) :: vector

    integer(ik) :: i
    real(rk) :: c ! accumulator
    real(rk) :: t ! total

    c = 0.0_rk
    sum = 0.0_rk

    do i = 1, size(vector)
      t = sum + vector(i)
      if(abs(sum) >= abs(vector(i))) then
        c = c + ((sum - t) + vector(i)) ! If sum is bigger, low-order digits of vector(i) are lost.
      else
        c = c + ((vector(i) - t) + sum) ! Else low-order digits of sum are lost.
      endif
      sum = t
    enddo
    sum = sum + c
  endfunction neumaier_sum

  pure real(rk) function neumaier_sum_2(vector) result(sum)
    !< Implementation of an accurate floating point summation algorithm. See
    !< https://en.wikipedia.org/wiki/Kahan_summation_algorithm. This significantly reduces round off error.
    !< In order for the compiler not to aggressively optimize the benifits of this away, the ifort
    !< compiler flag 'fp-model source` needs to be included.

    real(rk), dimension(2), intent(in) :: vector

    integer(ik) :: i
    real(rk) :: c ! accumulator
    real(rk) :: t ! total

    c = 0.0_rk
    sum = 0.0_rk

    do i = 1, 2
      t = sum + vector(i)
      if(abs(sum) >= abs(vector(i))) then
        c = c + ((sum - t) + vector(i)) ! If sum is bigger, low-order digits of vector(i) are lost.
      else
        c = c + ((vector(i) - t) + sum) ! Else low-order digits of sum are lost.
      endif
      sum = t
    enddo
    sum = sum + c
  endfunction neumaier_sum_2

  pure real(rk) function neumaier_sum_3(vector) result(sum)
    !< Implementation of an accurate floating point summation algorithm. See
    !< https://en.wikipedia.org/wiki/Kahan_summation_algorithm. This significantly reduces round off error.
    !< In order for the compiler not to aggressively optimize the benifits of this away, the ifort
    !< compiler flag 'fp-model source` needs to be included.

    real(rk), dimension(3), intent(in) :: vector

    integer(ik) :: i
    real(rk) :: c ! accumulator
    real(rk) :: t ! total

    c = 0.0_rk
    sum = 0.0_rk

    do i = 1, 3
      t = sum + vector(i)
      if(abs(sum) >= abs(vector(i))) then
        c = c + ((sum - t) + vector(i)) ! If sum is bigger, low-order digits of vector(i) are lost.
      else
        c = c + ((vector(i) - t) + sum) ! Else low-order digits of sum are lost.
      endif
      sum = t
    enddo
    sum = sum + c
  endfunction neumaier_sum_3

  pure real(rk) function neumaier_sum_4(vector) result(sum)
    !< Implementation of an accurate floating point summation algorithm. See
    !< https://en.wikipedia.org/wiki/Kahan_summation_algorithm. This significantly reduces round off error.
    !< In order for the compiler not to aggressively optimize the benifits of this away, the ifort
    !< compiler flag 'fp-model source` needs to be included.

    real(rk), dimension(4), intent(in) :: vector

    integer(ik) :: i
    real(rk) :: c ! accumulator
    real(rk) :: t ! total

    c = 0.0_rk
    sum = 0.0_rk

    do i = 1, 4
      t = sum + vector(i)
      if(abs(sum) >= abs(vector(i))) then
        c = c + ((sum - t) + vector(i)) ! If sum is bigger, low-order digits of vector(i) are lost.
      else
        c = c + ((vector(i) - t) + sum) ! Else low-order digits of sum are lost.
      endif
      sum = t
    enddo
    sum = sum + c
  endfunction neumaier_sum_4

endmodule mod_floating_point_utils


Real Function s1535(srt)
  Save
  s0 = 2.424
  s1535 = 0.
  If (srt<=s0) Return
  s1535 = 2.*0.102*(srt-s0)/(0.058+(srt-s0)**2)
  Return
End Function s1535


! ********************************************************************************
! tav_abs.f90
! ********************************************************************************
! computation of the average transmittivity at the leaf surface within a given
! solid angle. teta is the incidence solid angle (in radian). The average angle
! that works in most cases is 40deg*pi/180. ref is the refaction index.
! ********************************************************************************
! Stern F. (1964), Transmission of isotropic radiation across an interface between
! two dielectrics, Applied Optics, 3:111-113.
! Allen W.A. (1973), Transmission of isotropic light across a dielectric surface in
! two and three dimensions, Journal of the Optical Society of America, 63:664-666.
! ********************************************************************************
! version (12 April 2015)
! ********************************************************************************

subroutine tav_abs(theta,refr,res)

    use mod_dataSpec_wavelength
    IMPLICIT none
    REAL*8, intent(in) :: theta, refr(nw)
    REAL*8, intent(out) :: res(nw)

    REAL*8 :: pi, thetarad
    REAL*8 :: refr2(nw)
    REAL*8 :: ax(nw),bx(nw),b0(nw),b1(nw),b2(nw)
    REAL*8 :: ts(nw),tp(nw),tp1(nw),tp2(nw),tp3(nw),tp4(nw),tp5(nw)

    pi       = atan(1.)*4.
    thetarad = pi*theta/180.

    if (theta.eq.0.) then
        res=4.*refr/(refr+1.)**2
        return
    endif

    refr2 = refr*refr
    ax    = (refr+1.)**2/2.
    bx    = -(refr2-1.)**2/4.

    if (thetarad.eq.pi/2.) then
        b1=0.
    else
        b1=dsqrt((sin(thetarad)**2-(refr2+1.)/2.)**2+bx)
    endif
    b2  = sin(thetarad)**2-(refr2+1.)/2.
    b0  = b1-b2
    ts  = (bx**2/(6.*b0**3)+bx/b0-b0/2.)-(bx**2/(6.*ax**3)+bx/ax-ax/2.)
    tp1 = -2.*refr2*(b0-ax)/(refr2+1.)**2
    tp2 = -2.*refr2*(refr2+1.)*dlog(b0/ax)/(refr2-1.)**2
    tp3 = refr2*(1./b0-1./ax)/2.
    tp4 = 16.*refr2**2*(refr2**2+1.)*dlog((2.*(refr2+1.)*b0-(refr2-1.)**2)/ &
        (2.*(refr2+1.)*ax-(refr2-1.)**2))/((refr2+1.)**3*(refr2-1.)**2)
    tp5 = 16.*refr2**3*(1./(2.*(refr2+1.)*b0-((refr2-1.)**2))-1./(2.*(refr2+1.) &
        *ax-(refr2-1.)**2))/(refr2+1.)**3
    tp  = tp1+tp2+tp3+tp4+tp5
    res = (ts+tp)/(2.*sin(thetarad)**2)

    return
    end


      subroutine resid_betagd(n_Lamx,n_beta,np1_Lamx,np1_beta,x,Nx,eta,h
     &t,mus,myzero,phys_bdy,res)
      implicit none
      integer i
      integer Nx
      real*8 eta
      real*8 ht
      real*8 mus
      real*8 myzero
      real*8 n_Lamx(Nx)
      real*8 n_beta(Nx)
      real*8 np1_Lamx(Nx)
      real*8 np1_beta(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 = (-0.1D1 * n_beta(i) + np1_beta(i)) / ht - 0.5000000000000000D
     #0 * mus * np1_Lamx(i) + 0.5000000000000000D0 * eta * np1_beta(i) -
     # 0.5000000000000000D0 * mus * n_Lamx(i) + 0.5000000000000000D0 * e
     #ta * n_beta(i)
      res = res + qb**2
      end do
      endif
      do i=2, Nx-1, 1
      qb = (-0.1D1 * n_beta(i) + np1_beta(i)) / ht - 0.5000000000000000D
     #0 * mus * np1_Lamx(i) + 0.5000000000000000D0 * eta * np1_beta(i) -
     # 0.5000000000000000D0 * mus * n_Lamx(i) + 0.5000000000000000D0 * e
     #ta * n_beta(i)
      res = res + qb**2
      end do
      if (phys_bdy(2) .eq. 1) then
      do i=Nx, Nx, 1
      qb = np1_beta(i) + myzero * x(i)
      res = res + qb**2
      end do
      endif
      res = sqrt(res/(1*Nx))
      END


program secante
    implicit none
    character(len=10) :: arg
    integer :: iter = 1000
    real , parameter ::  epsilon = 0.001
    real ::  fx=0,x, a, b,number, fa, fb  !f(x)=((x)*x - number'
                                    !flinha(x) = g(x) = x**3 - 2.0*sin(x)'

    call getarg(1, arg)
    read (arg, '(f10.0)') number
    !do 20 i=1, 2, 1
    !20 continue

    a = 0
    b = number + 1

    fa = (a)*a - number
    fb = (b)*b - number
    x = fb - fa

    do while (iter  >= 0)
        if (b /= a) then
            fx = b - (fb * (b-a))/x
        end if
        a = b
        b = fx
        fa = (a)*a - number
        fb = (b)*b - number
        x = fb - fa
        iter = iter -1
    end do
print '("A raiz é: "(f0.2))' , fx
end program secante


    Program zunmbr_example

!     ZUNMBR Example Program Text

!     Copyright (c) 2018, Numerical Algorithms Group (NAG Ltd.)
!     For licence see
!       https://github.com/numericalalgorithmsgroup/LAPACK_Examples/blob/master/LICENCE.md

!     .. Use Statements ..
      Use lapack_example_aux, Only: nagf_blas_zmload, &
        nagf_file_print_matrix_complex_gen_comp
      Use lapack_interfaces, Only: zgebrd, zgelqf, zgeqrf, zlacpy, zunglq, &
        zungqr, zunmbr
      Use lapack_precision, Only: dp
!     .. Implicit None Statement ..
      Implicit None
!     .. Parameters ..
      Complex (Kind=dp), Parameter :: zero = (0.0E0_dp, 0.0E0_dp)
      Integer, Parameter :: nin = 5, nout = 6
!     .. Local Scalars ..
      Integer :: i, ic, ifail, info, lda, ldph, ldu, lwork, m, n
!     .. Local Arrays ..
      Complex (Kind=dp), Allocatable :: a(:, :), ph(:, :), tau(:), taup(:), &
        tauq(:), u(:, :), work(:)
      Real (Kind=dp), Allocatable :: d(:), e(:)
      Character (1) :: clabs(1), rlabs(1)
!     .. Executable Statements ..
      Write (nout, *) 'ZUNMBR Example Program Results'
!     Skip heading in data file
      Read (nin, *)
      Do ic = 1, 2
        Read (nin, *) m, n
        lda = m
        ldph = n
        ldu = m
        lwork = 64*(m+n)
        Allocate (a(lda,n), ph(ldph,n), tau(n), taup(n), tauq(n), u(ldu,n), &
          work(lwork), d(n), e(n-1))

!       Read A from data file

        Read (nin, *)(a(i,1:n), i=1, m)

        If (m>=n) Then

!         Compute the QR factorization of A
          Call zgeqrf(m, n, a, lda, tau, work, lwork, info)

!         Copy A to U
          Call zlacpy('Lower', m, n, a, lda, u, ldu)

!         Form Q explicitly, storing the result in U
          Call zungqr(m, n, n, u, ldu, tau, work, lwork, info)

!         Copy R to PH (used as workspace)
          Call zlacpy('Upper', n, n, a, lda, ph, ldph)

!         Set the strictly lower triangular part of R to zero
          Call nagf_blas_zmload('Lower', n-1, n-1, zero, zero, ph(2,1), ldph)

!         Bidiagonalize R
          Call zgebrd(n, n, ph, ldph, d, e, tauq, taup, work, lwork, info)

!         Update Q, storing the result in U
          Call zunmbr('Q', 'Right', 'No transpose', m, n, n, ph, ldph, tauq, &
            u, ldu, work, lwork, info)

!         Print bidiagonal form and matrix Q

          Write (nout, *)
          Write (nout, *) 'Example 1: bidiagonal matrix B'
          Write (nout, *) 'Diagonal'
          Write (nout, 100) d(1:n)
          Write (nout, *) 'Superdiagonal'
          Write (nout, 100) e(1:n-1)
          Write (nout, *)
          Flush (nout)

!         ifail: behaviour on error exit
!                =0 for hard exit, =1 for quiet-soft, =-1 for noisy-soft
          ifail = 0
          Call nagf_file_print_matrix_complex_gen_comp('General', ' ', m, n, &
            u, ldu, 'Bracketed', 'F7.4', 'Example 1: matrix Q', 'Integer', &
            rlabs, 'Integer', clabs, 80, 0, ifail)

        Else

!         Compute the LQ factorization of A
          Call zgelqf(m, n, a, lda, tau, work, lwork, info)

!         Copy A to PH
          Call zlacpy('Upper', m, n, a, lda, ph, ldph)

!         Form Q explicitly, storing the result in PH
          Call zunglq(n, n, m, ph, ldph, tau, work, lwork, info)

!         Copy L to U (used as workspace)
          Call zlacpy('Lower', m, m, a, lda, u, ldu)

!         Set the strictly upper triangular part of L to zero
          Call nagf_blas_zmload('Upper', m-1, m-1, zero, zero, u(1,2), ldu)

!         Bidiagonalize L
          Call zgebrd(m, m, u, ldu, d, e, tauq, taup, work, lwork, info)

!         Update P**H, storing the result in PH
          Call zunmbr('P', 'Left', 'Conjugate transpose', m, n, m, u, ldu, &
            taup, ph, ldph, work, lwork, info)

!         Print bidiagonal form and matrix P**H

          Write (nout, *)
          Write (nout, *) 'Example 2: bidiagonal matrix B'
          Write (nout, *) 'Diagonal'
          Write (nout, 100) d(1:m)
          Write (nout, *) 'Superdiagonal'
          Write (nout, 100) e(1:m-1)
          Write (nout, *)
          Flush (nout)

          ifail = 0
          Call nagf_file_print_matrix_complex_gen_comp('General', ' ', m, n, &
            ph, ldph, 'Bracketed', 'F7.4', 'Example 2: matrix P**H', &
            'Integer', rlabs, 'Integer', clabs, 80, 0, ifail)

        End If
        Deallocate (a, ph, tau, taup, tauq, u, work, d, e)
      End Do

100   Format (3X, (8F8.4))
    End Program


program jacobi_omp
!! https://nanohub.org/resources/19384/download/Directive_Based_Programming.pdf

use, intrinsic :: iso_fortran_env, only : int64
implicit none (type, external)

integer(int64) :: tic, toc, trate
real :: err, tol
real, allocatable, dimension(:,:) :: A, Anew
integer :: i, j, m, n, iter, iter_max
real, parameter :: pi=4*atan(1.)

call system_clock(count_rate=trate)

m = 100
n = 200

tol = 0.01

iter_max = 1000000
iter = 0
err = 1.

allocate(A(0:n+1,0:m+1), Anew(n,m))

call random_number(A)

call system_clock(tic)

do while ( err > tol .and. iter < iter_max )
  err = 0.

  !$omp parallel do shared(m,n,Anew,A) reduction(max:err)
  do j=1,m
    do i=1,n
      Anew(i,j) = 0.25 * (A(i+1, j)   + A(i-1, j) + &
                          A(i  , j-1) + A(i  , j+1))

      err = max(err, Anew(i, j) - A(i,j))
    end do
  end do

  !$omp parallel do shared(m,n,Anew,A)
  do j=1,m-2
    do i=1,n-2
      A(i,j) = Anew(i,j)
    end do
  end do

  iter = iter +1
  if (mod(iter, 100) == 0) print*,iter,err
end do

call system_clock(toc)

print *, (toc-tic)*1000./trate, iter

end program


program thomas_algo
implicit none
                                                !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
                                                !ad     : ABOVE DIAGONAL             !
                                                !d      : DIAGONAL                   !
                                                !bd     : BELOW DIAGONAL             !
                                                !y      : ASSUMED FUNCTION           !
                                                !z      : RHS VALUE OF MATRIX        !
                                                !a      : ABOVE DIAGONAL VALUES      !
                                                !b      : DIAGONAL VALUES            !
                                                !c      : BELOW DIAGONAL VALUES      !
                                                !j      : FILLING ABOVE DIAGONAL     !
                                                !k      : FILLING BELOW DIAGONAL     !
                                                !l      : FILLING MAIN DIAGONAL      !
                                                !e      : BACKWARD SUBSTITTION       !
                                                !q      : NO. OF DISCRITISING POINTS !
                                                !N      :DIMENSION OF MATRIX & DISCRITISATION POINT !
                                                !A,bBig    :FILLING OF ARRAY,UPPER &LOWER LIMIT OF F^N !
                                                !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
real,allocatable :: ad(:),d(:),bd(:)
real,allocatable :: x(:),y(:),Z(:)
real,allocatable  :: points(:)
integer:: i,j,k,l,o,p,r,t,q,v,m(1000)
real :: aBig,bBig,delx,error
integer:: a,b,c
integer:: e,N
!filling the array
!print*,"tell me the dimension of tridioagonal matrix and also no.of discritisation points"
!read*,N
!print*,"tell me the upper and lowerlimit of function please"
!read*,aBig,bBig
delx=(bBig-aBig)/(N)
do i=1,size(m)
  m(i)=10*i
end do
!PRINT*,m
do p=1,size(m)
N=m(p)  !number of values to interpolate after creating the polynomial
!N=4
bBig =1
aBig =0
!FOR ALL VALUES OF n POINTS

allocate (points(1:N))

allocate (y(1:N))
allocate (ad(1:N-1))
allocate (d(1:N))
allocate (bd(2:N))
allocate (x(1:N))
allocate (Z(1:N))

                do q = 1,N
points(q) = (aBig+(bBig-aBig)/N)*q
!print*,'THE PPOINTS ARE?:',points(q)
        end do
!the exact value of function
                do r = 1,N
y(r) = 1/(1+25* points(r)**2)
!print*, 'exact =', y(r)
!y(r) = x**2
        end do

!print*,"tell me the values of above diagonal please"
!read*,a
a = -1
!print*,"tell me the values of main diagonal please"
!read*,b
b =4
!print*,"tell me the values of below diagonal please"
!read*,c
c = -1
                do j = 1, N-1
ad(j) =a
        end do
!print*,"above diagonal elements =", ad
                do k= 2,N
bd(k) =c
        end do
!print*,"below diagonal elements =", bd
                do l = 1,N
d(l) =b
        end do
!print*,"main diagonal elements =", d
                do o = 1,N
!Z(o) = -50 *points(o)*abs(bBig-aBig)/((N-1)*(25*points(o)**2 +1)**2)
Z(o) = 50*((75*points(o)**2 -1))  / (25*(points(o)**2 +1)**3)
!print*,'f',  'x:',z(o)
!Z(o) = 2*points(o)**2
!z(o) = 2 * x
        end do
!FOR FORWARD ELLIMINATION
!print*,'first z',z(1)
                do i =2,N
Z(i) = Z(i) - bd(i)/d(i-1) * Z(i-1)
!print*,' rhs new =',z(i)
end do
do v= 2,N
d(v) =d(v) - bd(v)/d(v-1) * ad(v-1)
!print*,'d ' ,d(v)
        end do
!print*,size(x)
!INITIALISING CERTAIN VALUES!
x(N) =Z(N)/d(N)
!FOR BACKWARD SUBSTITUTION!
            !    do e = N,2,-1

!x(e) = (x(e) - x(e+1)*ad(e))/d(e)
!print*,'the value of all x =' ,x(k)
!end do

do e = N,2,-1
x(e-1) =(Z(e-1) - x(e)*ad(e-1))/d(e-1)
        end do
!print*,"unknown values for the given function is =",x
!print*,
!ANALYSING ERROR!
!do t = 1,N
!error(t) = y(t) - x(t)
!end do
error =abs((sum(y)-sum(x))/size(x))
print*,N,error

deallocate (points,ad,d,bd,Z,x,y)

end do !p loop

end program thomas_algo


      SUBROUTINE DREALFT(DATA,N,ISIGN)
!
! Double-precision version of Numerical recipes REALFT routine.
!
      implicit none
      integer n, isign
      real*8 DATA(n)
!local variables
      integer i,i1,i2,i3,i4,n2p3
      REAL*8 WR,WI,WPR,WPI,WTEMP,THETA,c1,c2,h1i,h1r,h2i,h2r,wis,wrs

      THETA=3.141592653589793D0/DBLE(N/2)
      C1=0.5d00
      IF (ISIGN.EQ.1) THEN
         C2=-0.5d00
         CALL dFOUR1(DATA,N/2,+1)
      ELSE
         C2=0.5d00
         THETA=-THETA
      ENDIF
      WPR=-2.0D0*DSIN(0.5D0*THETA)**2
      WPI=DSIN(THETA)
      WR=1.0D0+WPR
      WI=WPI
      N2P3=N+3
      DO 11 I=2,N/4
         I1=2*I-1
         I2=I1+1
         I3=N2P3-I2
         I4=I3+1
         WRS= (WR)
         WIS= (WI)
         H1R=C1*(DATA(I1)+DATA(I3))
         H1I=C1*(DATA(I2)-DATA(I4))
         H2R=-C2*(DATA(I2)+DATA(I4))
         H2I=C2*(DATA(I1)-DATA(I3))
         DATA(I1)=H1R+WRS*H2R-WIS*H2I
         DATA(I2)=H1I+WRS*H2I+WIS*H2R
         DATA(I3)=H1R-WRS*H2R+WIS*H2I
         DATA(I4)=-H1I+WRS*H2I+WIS*H2R
         WTEMP=WR
         WR=WR*WPR-WI*WPI+WR
         WI=WI*WPR+WTEMP*WPI+WI
 11   CONTINUE
      IF (ISIGN.EQ.1) THEN
         H1R=DATA(1)
         DATA(1)=H1R+DATA(2)
         DATA(2)=H1R-DATA(2)
      ELSE
         H1R=DATA(1)
         DATA(1)=C1*(H1R+DATA(2))
         DATA(2)=C1*(H1R-DATA(2))
         CALL dFOUR1(DATA,N/2,-1)
      ENDIF
      RETURN
      END SUBROUTINE DREALFT


    program demo_minval
    implicit none
    integer :: i
    character(len=*),parameter :: g='(3x,*(g0,1x))'

    integer,save :: ints(3,5)= reshape([&
           1,  -2,   3,   4,   5,  &
          10,  20, -30,  40,  50,  &
          11,  22,  33, -44,  55  &
    ],shape(ints),order=[2,1])

    integer,save :: box(3,5,2)

       box(:,:,1)=ints
       box(:,:,2)=-ints

       write(*,*)'Given the array'
       write(*,'(1x,*(g4.4,1x))') &
       & (ints(i,:),new_line('a'),i=1,size(ints,dim=1))

       write(*,*)'What is the smallest element in the array?'
       write(*,g) minval(ints),'at <',minloc(ints),'>'

       write(*,*)'What is the smallest element in each column?'
       write(*,g) minval(ints,dim=1)

       write(*,*)'What is the smallest element in each row?'
       write(*,g) minval(ints,dim=2)

       ! notice the shape of the output has less columns
       ! than the input in this case
       write(*,*)'What is the smallest element in each column,'
       write(*,*)'considering only those elements that are'
       write(*,*)'greater than zero?'
       write(*,g) minval(ints, dim=1, mask = ints > 0)

       write(*,*)&
       & 'if everything is false a zero-sized array is NOT returned'
       write(*,*) minval(ints, dim=1, mask = .false.)
       write(*,*)'even for a zero-sized input'
       write(*,g) minval([integer ::], dim=1, mask = .false.)

       write(*,*)'a scalar answer for everything false is huge()'
       write(*,g) minval(ints, mask = .false.)
       write(*,g) minval([integer ::], mask = .false.)

       write(*,*)'some calls with three dimensions'
       write(*,g) minval(box, mask = .true. )
       write(*,g) minval(box, dim=1, mask = .true. )

       write(*,g) minval(box, dim=2, mask = .true. )
       write(*,g) 'shape of answer is ', &
       & shape(minval(box, dim=2, mask = .true. ))

    end program demo_minval


! { dg-do run }
! Tests the fix for PR24519, in which assignments with the same
! range of an assumed shape array, on the lhs and rhs, would be
! treated as causing a dependency.
!
! Contributed by Paul.Thomas  <pault@gcc.gnu.org>
!
  integer, parameter :: n = 100
  real :: x(n, n), v
  x = 1
  v = 0.1
  call foo (x, v)
  if (abs(sum (x) -  91.10847) > 1e-3) print *, sum (x)
contains
  subroutine foo (b, d)
    real :: b(:, :)
    real :: temp(n), c, d
    integer :: j, k
    do k = 1, n
      temp = b(:,k)
      do j = 1, n
        c = b(k,j)*d
        b(:,j) = b(:,j)-temp*c  ! This was the offending assignment.
        b(k,j) = c
      end do
    end do
  end subroutine foo
end


!  This program converts fahrenheit to celcius

PROGRAM FtoC

  IMPLICIT none
  REAL  :: C, F

  WRITE(6,*) 'Please enter the temperature in fahrenheit'
  WRITE(6,*) 'to be converted to celcius'
  READ(5,*) F
  C = (5.0/9.0)*(F-32.0)
  WRITE(6,*) F,' fahrenheit = ',C,' celcius'

END PROGRAM FtoC


      subroutine weight(a,n1a,nrow,ncol,dx)
c--------------------------------------------------------------------
c     this program weights the a matrix prior to singular value
c  decomposition in a manner appropriate to the quadrature scheme
c  used.  this version yields the equivalent of integration by
c  simpson's rule.  the routine assumes the rows of a contain the
c  discretized functions.  if the number of rows of a is not an odd
c  number (a requirement of simpson's rule) the effective range over
c  which the integration is performed is decreased by one.  this is
c  permisable for the travel time problem for which this code was
c  written but in general it may not be acceptable.
c
c  arguments-
c
c     a-matrix of discretized functions
c     n1a-first dimension of a in calling program
c     nrow-actual number of rows of a
c     ncol-number of columns in a
c     dx-discretizing interval
c  alternate entry point-unweigh
c     unweigh does the inverse of weight.  that is it returns the
c     functions to their unscaled discretized form
c--------------------------------------------------------------------
      dimension a(n1a,ncol)
      even=sqrt(4.*dx/3.)
      odd=sqrt(2.*dx/3.)
      epoint=sqrt(dx/3.)
c--make sure the number of points is odd.
      if(mod(nrow,2).eq.0) then
           nrange=nrow-1
      else
           nrange=nrow
      endif
c--now do the scaling.
      do 200 j=1,ncol
           a(1,j)=a(1,j)*epoint
           do 100 i=2,nrange-1
                if(mod(i,2).eq.0) then
                     a(i,j)=even*a(i,j)
                else
                     a(i,j)=odd*a(i,j)
                endif
  100      continue
           a(nrange,j)=a(nrange,j)*epoint
  200 continue
      return
      entry unweigh(a,n1a,nrow,ncol,dx)
      even=sqrt(4.*dx/3.)
      odd=sqrt(2.*dx/3.)
      epoint=sqrt(dx/3.)
c--make sure the number of points is odd.
      if(mod(nrow,2).eq.0) then
           nrange=nrow-1
      else
           nrange=nrow
      endif
c--now do the scaling.
      do 400 j=1,ncol
           a(1,j)=a(1,j)/epoint
           do 300 i=2,nrange-1
                if(mod(i,2).eq.0) then
                     a(i,j)=a(i,j)/even
                else
                     a(i,j)=a(i,j)/odd
                endif
  300      continue
           a(nrange,j)=a(nrange,j)/epoint
  400 continue
      return
      end

c $Id$


      PROGRAM xmedfit
C     driver for routine medfit
      INTEGER NPT
      REAL SPREAD
      PARAMETER(NPT=100,SPREAD=0.1)
      INTEGER i,idum,mwt
      REAL a,abdev,b,chi2,gasdev,q,siga,sigb,x(NPT),y(NPT),sig(NPT)
      idum=-1984
      do 11 i=1,NPT
        x(i)=0.1*i
        y(i)=-2.0*x(i)+1.0+SPREAD*gasdev(idum)
        sig(i)=SPREAD
11    continue
      mwt=1
      call fit(x,y,NPT,sig,mwt,a,b,siga,sigb,chi2,q)
      write(*,'(/1x,a)') 'According to routine FIT the result is:'
      write(*,'(1x,t5,a,f8.4,t20,a,f8.4)') 'A = ',a,'Uncertainty: ',
     *     siga
      write(*,'(1x,t5,a,f8.4,t20,a,f8.4)') 'B = ',b,'Uncertainty: ',
     *     sigb
      write(*,'(1x,t5,a,f8.4,a,i4,a)') 'Chi-squared: ',chi2,
     *     ' for ',NPT,' points'
      write(*,'(1x,t5,a,f8.4)') 'Goodness-of-fit: ',q
      write(*,'(/1x,a)') 'According to routine MEDFIT the result is:'
      call medfit(x,y,NPT,a,b,abdev)
      write(*,'(1x,t5,a,f8.4)') 'A = ',a
      write(*,'(1x,t5,a,f8.4)') 'B = ',b
      write(*,'(1x,t5,a,f8.4)') 'Absolute deviation (per DATA point): '
     *     ,abdev
      write(*,'(1x,t5,a,f8.4,a)') '(note: Gaussian SPREAD is',SPREAD,')'
      END

NR-Functions/Numerical Recipes- Example & Functions/Examples/xmedfit.for


C$Procedure  CHBIGR ( Chebyshev expansion integral )

      SUBROUTINE CHBIGR ( DEGP, CP, X2S, X, P, ITGRLP )

C$ Abstract
C
C     Evaluate an indefinite integral of a Chebyshev expansion at a
C     specified point X. The constant of integration is selected to
C     make the integral zero when X equals the abscissa value X2S(1).
C     Return the value of the input expansion at X as well.
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     CHEBYSHEV
C     EPHEMERIS
C     INTEGRAL
C     MATH
C
C$ Declarations

      IMPLICIT NONE

      INTEGER               DEGP
      DOUBLE PRECISION      CP     ( * )
      DOUBLE PRECISION      X2S    ( 2 )
      DOUBLE PRECISION      X
      DOUBLE PRECISION      P
      DOUBLE PRECISION      ITGRLP

C$ Brief_I/O
C
C     Variable  I/O  Description
C     --------  ---  --------------------------------------------------
C     DEGP       I   Degree of input Chebyshev expansion.
C     CP         I   Chebyshev coefficients of input expansion.
C     X2S        I   Transformation parameters.
C     X          I   Abscissa value of evaluation.
C     P          O   Input expansion evaluated at X.
C     ITGRLP     O   Integral evaluated at X.
C
C$ Detailed_Input
C
C     DEGP       is the degree of the input Chebyshev expansion.
C
C     CP         is an array containing the coefficients of the input
C                Chebyshev expansion. The coefficient of the Ith
C                Chebyshev polynomial is contained in element CP(I+1),
C                for I = 1 : DEGP+1.
C
C     X2S        is an array containing the "transformation parameters"
C                of the domain of the expansion. Element X2S(1)
C                contains the midpoint of the interval on which the
C                input expansion is defined; X2S(2) is one-half of the
C                length of this interval; this value is called the
C                interval's "radius."
C
C                The input expansion defines a function f(X) on the
C                interval
C
C                   [ X2S(1)-X2S(2),  X2S(1)+X2S(2) ]
C
C                as follows:
C
C                   Define S = ( X - X2S(1) ) / X2S(2)
C
C
C                                  DEGP+1
C                                  __
C                                  \
C                   f(X) = g(S)  = /  CP(k)  T   (S)
C                                  --         k-1
C                                  k=1
C
C
C     X          is the abscissa value at which the function defined by
C                the input expansion and its integral are to be
C                evaluated. Normally X should lie in the closed
C                interval
C
C                   [ X2S(1)-X2S(2),  X2S(1)+X2S(2) ]
C
C                See the Restrictions section below.
C
C$ Detailed_Output
C
C     P,
C     ITGRLP     Define S and f(X) as above in the description of the
C                input argument X2S. Then P is f(X), and ITGRLP is
C                an indefinite integral of f(X), evaluated at X.
C
C                The indefinite integral satisfies
C
C                   d(ITGRLP)/dX     = f(X)
C
C                and
C
C                   ITGRLP( X2S(1) ) = 0
C
C$ Parameters
C
C     None.
C
C$ Exceptions
C
C     1)  If the input degree is negative, the error
C         SPICE(INVALDDEGREE) is signaled.
C
C     2)  If the input interval radius is non-positive, the error
C         SPICE(INVALIDRADIUS) is signaled.
C
C$ Files
C
C     None.
C
C$ Particulars
C
C     Let
C
C        T ,  n = 0, ...
C         n
C
C     represent the nth Chebyshev polynomial of the first kind:
C
C        T (x) = cos( n*arccos(x) )
C         n
C
C     The input coefficients represent the Chebyshev expansion
C
C                       DEGP+1
C                       __
C                       \
C        f(X) = g(S)  = /  CP(k)  T   (S)
C                       --         k-1
C                       k=1
C
C     where
C
C        S = ( X - X2S(1) ) / X2S(2)
C
C     This routine evaluates and returns the value at X of an
C     indefinite integral F(X), where
C
C        dF(X)/dX    = f(X)  for all X in
C                            [X2S(1)-X2S(2), X2S(1)+X2S(2)]
C
C        F( X2S(1) ) = 0
C
C     The value at X of the input expansion
C
C        f(X)
C
C     is returned as well.
C
C     Note that numerical problems may result from applying this
C     routine to abscissa values outside of the interval defined
C     by the input parameters X2S(*). See the Restrictions section.
C
C     To evaluate Chebyshev expansions and their derivatives, use the
C     SPICELIB routines CHBINT or CHBDER.
C
C     This routine supports the SPICELIB SPK type 20 and PCK type 20
C     evaluators SPKE20 and PCKE20.
C
C$ Examples
C
C     The numerical results shown for this example may differ across
C     platforms. The results depend on the SPICE kernels used as
C     input, the compiler and supporting libraries, and the machine
C     specific arithmetic implementation.
C
C     1)  Let the domain of a polynomial to be evaluated be the
C         closed interval
C
C            [20, 30]
C
C         Let the input expansion represent the polynomial
C
C                             6
C            f(X)  = g(S) = 5S
C
C         where
C
C            S     = (X - 20)/10
C
C         Let F(X) be an indefinite integral of f(X) such that
C
C            F(20) = 0
C
C         Evaluate
C
C            f(30) and F(30)
C
C
C        Example code begins here.
C
C              PROGRAM EX1
C              IMPLICIT NONE
C        C
C        C     Local variables
C        C
C              DOUBLE PRECISION      CP    ( 6 )
C              DOUBLE PRECISION      X
C              DOUBLE PRECISION      X2S   ( 2 )
C              DOUBLE PRECISION      P
C              DOUBLE PRECISION      ITGRLP
C
C              INTEGER               DEGP
C
C        C
C        C     Let our domain be the interval [10, 30].
C        C
C              X2S(1) = 20.D0
C              X2S(2) = 10.D0
C        C
C        C     Assign the expansion coefficients.
C        C
C              DEGP  = 5
C
C              CP(1) = 0.D0
C              CP(2) = 3.75D0
C              CP(3) = 0D0
C              CP(4) = 1.875D0
C              CP(5) = 0.D0
C              CP(6) = 0.375D0
C
C        C
C        C     Evaluate the function and its integral at X = 30.
C        C
C              X = 30.D0
C
C              CALL CHBIGR ( DEGP, CP, X2S, X, P, ITGRLP )
C
C        C
C        C     We make the change of variables
C        C
C        C        S(X) = (1/10) * ( X - 20 )
C        C
C        C     The expansion represents the polynomial
C        C
C        C                         5
C        C        f(X) = g(S) = 6*S
C        C
C        C     An indefinite integral of the expansion is
C        C
C        C                                    6
C        C        F(X) = G(S) * dX/dS = 10 * S
C        C
C        C     where G is defined on the interval [-1, 1]. The result
C        C     should be (due to the change of variables)
C        C
C        C          (G(1)  - G(0) ) * dX/dS
C        C
C        C        = (F(30) - F(20)) * 10
C        C
C        C        = 10
C        C
C        C     The value of the expansion at X should be
C        C
C        C        f(20) = g(1) = 6
C        C
C              WRITE (*,*) 'ITGRLP = ', ITGRLP
C              WRITE (*,*) 'P      = ', P
C
C              END
C
C
C     When this program was executed on a PC/Linux/gfortran platform,
C     the output was:
C
C        ITGRLP =   10.0000000000000000
C        P      =    6.0000000000000000
C
C
C$ Restrictions
C
C     1)  The value (X-X2S(1)) / X2S(2) normally should lie within the
C         interval -1:1 inclusive, that is, the closed interval
C         [-1, 1]. Chebyshev polynomials increase rapidly in magnitude
C         as a function of distance of abscissa values from this
C         interval.
C
C         In typical SPICE applications, where the input expansion
C         represents position, velocity, or orientation, abscissa
C         values that map to points outside of [-1, 1] due to round-off
C         error will not cause numeric exceptions.
C
C     2)  No checks for floating point overflow are performed.
C
C     3)  Significant accumulated round-off error can occur for input
C         expansions of excessively high degree. This routine imposes
C         no limits on the degree of the input expansion; users must
C         verify that the requested computation provides appropriate
C         accuracy.
C
C$ Literature_References
C
C     1)  "Numerical Recipes -- The Art of Scientific Computing" by
C         William H. Press, Brian P. Flannery, Saul A. Teukolsky,
C         Willam T. Vetterling. (See Clenshaw's Recurrence Formula.)
C
C     2)  Chebyshev polynomials. (2013, September 28). In Wikipedia,
C         The Free Encyclopedia. Retrieved 01:23, November 23, 2013,
C         from http://en.wikipedia.org/w/index.php?title=
C         Chebyshev_polynomials&oldid=574881046
C
C$ Author_and_Institution
C
C     N.J. Bachman    (JPL)
C
C$ Version
C
C-    SPICELIB Version 1.0.0, 03-DEC-2013 (NJB)
C
C-&

C$ Index_Entries
C
C     integral of chebyshev_polynomial_expansion
C     integrate chebyshev_polynomial_expansion
C
C-&

C
C     SPICELIB functions
C
      LOGICAL               RETURN
C
C     Local variables
C
      DOUBLE PRECISION      A2
      DOUBLE PRECISION      ADEGP1
      DOUBLE PRECISION      ADEGP2
      DOUBLE PRECISION      AI
      DOUBLE PRECISION      C0
      DOUBLE PRECISION      F      ( 3 )
      DOUBLE PRECISION      S
      DOUBLE PRECISION      S2
      DOUBLE PRECISION      W      ( 3 )
      DOUBLE PRECISION      Z      ( 3 )

      INTEGER               I
      INTEGER               NTERMS

C
C     Test RETURN but don't check in. Use discovery check-in.
C
      IF ( RETURN() ) THEN
         RETURN
      END IF

C
C     Check the expansion degree.
C
      IF ( DEGP .LT. 0 )  THEN

         CALL CHKIN  ( 'CHBIGR'                                )
         CALL SETMSG ( 'Expansion degree must be non-negative '
     .   //            'but was #.'                            )
         CALL ERRINT ( '#', DEGP                               )
         CALL SIGERR ( 'SPICE(INVALIDDEGREE)'                  )
         CALL CHKOUT ( 'CHBIGR'                                )
         RETURN

      END IF

C
C     Check the radius of the domain interval.
C
      IF ( X2S(2) .LE. 0.D0 )  THEN

         CALL CHKIN  ( 'CHBIGR'                            )
         CALL SETMSG ( 'Interval radius must be positive '
     .   //            'but was #.'                        )
         CALL ERRDP  ( '#', X2S(2)                         )
         CALL SIGERR ( 'SPICE(INVALIDRADIUS)'              )
         CALL CHKOUT ( 'CHBIGR'                            )
         RETURN

      END IF

      NTERMS = DEGP + 1

C
C     Background
C     ==========
C
C
C     Let
C
C        T ,  n = 0, ...
C         n
C
C     represent the nth Chebyshev polynomial of the first kind:
C
C        T (x) = cos( n*arccos(x) )
C         n
C
C     These polynomials satisfy the recurrence relationship
C
C        T   (x) = 2x T (x)  -  T   (x),  n = 2, ...
C         n+1          n         n-1
C
C     The Chebyshev polynomials of the second kind are denoted by
C
C        U ,  n = 0, ...
C         n
C
C     where
C
C        U (x) = 1
C         0
C
C        U (x) = 2x
C         1
C
C        U   (x) = 2x U (x)  -  U   (x),  n = 2, ...
C         n+1          n         n-1
C
C
C     The integration formula (1) below is based on several
C     identities:
C
C
C        T (x)        = (1/2) * ( U (x) - U   (x) ),  n = 2, ...    (B1)
C         n                        n       n-2
C
C
C        d(T (x))/dx  =  n U   (x),   n = 1, ...                    (B2)
C           n               n-1
C
C
C                                 d(T   (x))/dx   d(T   (x))/dx
C                                    n+1             n-1
C        T (x)        = (1/2) * ( ------------- - ------------- ),
C         n                             n+1             n-1
C
C                                     n = 2, ...                    (B3)
C
C
C     Identity (B1) can be proved via mathematical induction. Using
C     (B1) and the Chebyshev recurrence formulas for both kinds of
C     polynomials, identity (B2) can also be proved via mathematical
C     induction. Identity (B3) follows directly from the combination of
C     (B1) and (B2).
C
C     Formula (1) below follows from (B3).
C
C
C     Algorithm
C     =========
C
C     In the discussion below, all Chebyshev polynomials are of the
C     first kind.
C
C     Let the notation
C
C        I( f )
C
C     represent the indefinite integral of a function f.
C
C     The key formula we use below is
C
C                              T          T
C                               n+1        n-1
C        I ( T  ) = (1/2) * ( ------  -  ------ )  +  C,  for n > 1  (1)
C             n                 n+1        n-1
C
C     where C is a constant of integration. Applying (1) to a Chebyshev
C     expansion
C
C               N+1
C               __
C               \
C        f(x) = /  a  T   (x)                                        (2)
C               --  k  k-1
C               k=1
C
C     we have
C
C                               N+1
C                               __       T (x)    T   (x)
C                               \         k        k-2
C        I( f(x) ) =      (1/2) /  a (   ------ - -------  )
C                               --  k       k       k-2
C                               k=3
C
C                    + a T (x) + ( a  / 4 ) T (x) + C ,   for N > 1 (3a)
C                       1 1         2        2       0
C
C     or
C
C        I( f(x) ) = C  + a T (x),   for N = 1                      (3b)
C                     0    1 1
C
C     where
C
C        C
C         0
C
C     is a constant of integration. Then by grouping coefficients of
C     the Chebyshev polynomials, we have
C
C
C                           N+2
C                           __
C                           \
C        I( f(x) ) = C  +   /  A  T   (x),  for N >= 0               (4)
C                     0     --  k  k-1
C                           k=2
C
C     where
C
C        A    = a   -  (1/2)a           for N >= 2,    or
C         2      1           3
C
C        A    = a                       for N <= 1                  (5a)
C         2      1
C
C                 1
C        A    = ------ ( a  -  a    )   for k = 3, ... , N (N>=3)   (5b)
C         k     2(k-1)    k-1   k+1
C
C                1
C        A    = ---- a                  for N >= 2                  (5c)
C         N+1    2N   N
C
C                 1
C        A    = ------ a                for N >= 1                  (5d)
C         N+2   2(N+1)  N+1
C
C
C     Note that (5b) does not conflict with (5c) or (5d) for N < 3,
C     since (5b) is applicable only when N >= 3.
C
C
C     We'll compute the sums
C
C                           N+2
C                           __
C                           \
C        I( f(x) ) - C  =   /  A  T   (x)                            (6)
C                     0     --  k  k-1
C                           k=2
C
C               N+2
C               __
C               \
C        C  = - /  A  T   (0)                                        (7)
C         0     --  k  k-1
C               k=2
C
C     and
C
C               N+1
C               __
C               \
C        f(x) = /  a  T   (x)
C               --  k  k-1
C               k=1
C
C
C     using Clenshaw's recurrence formula. Note that in the above
C     equations, N is the degree of the input expansion, which is
C     given by the input argument DEGP.
C
C     Transform the independent variable X to the interval
C
C        [-1, 1]
C
C     Call the result S.
C
C     Note we've already checked that X2S(2) is positive.
C
      S     = (X-X2S(1)) / X2S(2)
      S2    = 2.0D0 * S

C
C     Pre-compute the coefficients of the integral expansion
C     that are known at this point. The terms A2, ADEGP1, and
C     ADEGP2 correspond to the variables
C
C        A , A   , A
C         2   N+1   N+2
C
C     above and are set according to equations 5a, 5c, and 5d.
C
      IF ( NTERMS .GE. 3 ) THEN

         A2 = CP(1) - 0.5D0*CP(3)
      ELSE
         A2 = CP(1)
      END IF

C
C     Initialize the two highest-indexed coefficients of
C     the integral expansion.
C
      ADEGP1 = 0.D0
      ADEGP2 = 0.D0

      IF ( DEGP .GE. 2 ) THEN

         ADEGP1 = 0.5D0 * CP(DEGP) / DEGP

      END IF

      IF ( DEGP .GE. 1 ) THEN

         ADEGP2 = 0.5D0 * CP(DEGP+1) / (DEGP+1)

      END IF

C
C     The three quantities we'll compute require different numbers of
C     loop iterations: the integrals at X and at 0 require that I be
C     initialized to DEGP+2, while the input expansion requires that I
C     be initialized to DEGP+1. Since we wish to save on loop overhead
C     by performing the respective loop body actions in parallel, we
C     perform the integral computations for I = DEGP+2 prior to the
C     start of the loop.
C
C     Since F(1) and F(2) would normally be initialized to 0 prior to
C     the start of the loop, after the first loop pass, F would have
C     the contents assigned below.
C
      F(3) = 0.D0
      F(2) = 0.D0
C
C     The initial value of F(1) is the highest-order coefficient of
C     the integral's expansion.
C
      IF ( DEGP .EQ. 0 ) THEN
         F(1) = A2
      ELSE
         F(1) = ADEGP2
      END IF
C
C     We also want to evaluate [I(f)](0); we'll use this to
C     make the integral 0 at x = 0. We'll use the terms
C     Z(*) to evaluate the expansion of the integral at x = 0.
C
      Z(3) = 0.D0
      Z(2) = 0.D0
      Z(1) = F(1)
C
C     We'll use the terms W(*) to evaluate the input expansion.
C
      W(1) = 0.D0
      W(2) = 0.D0

C
C     NTERMS is DEGP+1.
C
      I = NTERMS

      DO WHILE ( I .GT. 1 )
C
C        The variable AI represents A(I), which is the Ith coefficient
C        of the Chebyshev expansion of the indefinite integral. AI is
C        set according to formulas 5a-c above.
C
         IF ( I .EQ. 2 ) THEN

            AI = A2

         ELSE IF ( I .LT. NTERMS ) THEN
C
C           AI is A ; I >= 3; DEGP >= 3.
C                  I
C
            AI = 0.5D0 * ( CP(I-1) - CP(I+1) ) / (I-1)

         ELSE
C
C           AI is A      ; I = NTERMS.
C                  DEGP+1
C
            AI = ADEGP1

         END IF

         F(3) = F(2)
         F(2) = F(1)
         F(1) = AI     + ( S2*F(2)  - F(3) )

         Z(3) = Z(2)
         Z(2) = Z(1)
         Z(1) = AI     - Z(3)

         W(3) = W(2)
         W(2) = W(1)
         W(1) = CP(I)  + ( S2*W(2)  - W(3) )

         I    = I - 1

      END DO

C
C     C0 is the negative of the input expansion evaluated at x=0, and
C     that expansion value is
C
C        0*Z(1) - Z(2)
C
C     The other terms are computed as in CHBINT.
C
      C0      =                    Z(2)
      ITGRLP  = C0    +   S*F(1) - F(2)
      P       = CP(1) + ( S*W(1) - W(2) )

C
C     Scale the integral to account for the change of variables
C     (from the original domain to [-1,1]). The scale factor is
C
C        dX/dS = X2S(2)
C
      ITGRLP = X2S(2) * ITGRLP

      RETURN
      END


! { dg-do run }
! Contributed by Dominique Dhumieres <dominiq@lps.ens.fr>

character(15) :: str="+ .339  567+2"
real, parameter :: should_be = .339567e2
real, parameter :: eps = 10 * epsilon (should_be)
real :: x, y

read(str,'(BN,F15.6)') x
print *, x
read(str,'(G15.7)') y
print *, y

if (abs (x - should_be) > eps .or. abs (y - should_be) > eps) then
  call abort ()
end if

end


      subroutine aspect(deglat,azm,avgsl)

c
c     +++PURPOSE+++
c     This subroutine calculates the aspect of the hill slope
c     relative to the sun angle which impinges upon it.  This
c     information is needed in order to calculate the amount of
c     solar radiation striking the sloping surface.
c
c     Author(s): Cully Hession and Bruce Lucord, USDA-ARS-NCSRL
c                Revised by John Witte, UofMn WCES @ USDA-ARS-NCSRL
c     Date: 03/22/93

c     Verified and tested by Reza Savabi, USDA-ARS, NSERL 317-494-5051
c                          August 1994
c     +++ARGUMENT DECLARATIONS+++
      real avgsl, azm, deglat, D1
cd    Added by S. Dun, Jan 17, 2006
cd    For multiple OFEs lateral flow
cd    End adding
c
c     +++ARGUMENT DEFINITIONS+++
c     avgsl  - The slope of the equivalent slope surface (m/m).
c     azm    - Direction slope is facing. Units are degrees from North.
c     deglat - Latitude of the slope segment. Measured in degrees from
c              the equator (positive values = N; negative values =S)
c
c     +++COMMON BLOCKS+++
cd    Added by S. Dun, Jan 17, 2006
cd    For multiple OFEs lateral flow
      include 'pmxelm.inc'
cd    End adding
      include  'cangie.inc'
c     modify:  radinc, radlat, eqlat, delong
      include 'cstruc.inc'
c
c     +++LOCAL VARIABLES+++
      real     rdaz, pi
c
c     +++LOCAL DEFINITIONS+++
c     rdaz   - Land aspect of the slope segment in units of radians.
c     pi     - The estimated value of pi = 22/7.
c
c     +++END SPECIFICATIONS+++

c -- Convert avgsl and azimuth to radians...
c -- Make sure that avgsl is in units of decimal percent!

      pi = 3.141593
cd    Modified by S. Dun 01/08/2004, then 01/17/2006 for adding (iplane)
cd      radinc = atan(avgsl) * pi / 180.0
      radinc(iplane) = atan(avgsl)
cd    End modifying
      rdaz  = azm * pi / 180.0
      radlat = deglat * pi / 180.0

c -- Calculate the Equivalent Lat. and Long values...

      eqlat = asin(cos(radinc(iplane)) * sin(radlat) +
     1         (sin(radinc(iplane))* cos(radlat) * cos(rdaz)))
c
cd    Modified by S. Dun, Nov 07, 2006
c     In responsing Erin Brooks PMET crash, adding in the alternative routines
c     (supplemental functions) for steep slope at high latitude
c
c      delong = atan( (sin(radinc(ipofe)) * sin(rdaz)) /
c     1        (cos(radinc(ipofe))* cos(radlat) -
c     1         sin(radinc(ipofe)) * sin(radlat) * cos(rdaz)) )
c
      D1 = cos(radinc(iplane))* cos(radlat) -
     1         sin(radinc(iplane)) * sin(radlat) * cos(rdaz)
c
      If (D1.lt. 1.e-10) D1 =  1.e-10
c
       delong = atan( (sin(radinc(iplane)) * sin(rdaz)) / D1)
c
      if (D1 .lt. 0) delong = delong + pi
cd    End modifying
      return
      end