      SUBROUTINE STKSE(INWIN,ISTKWN,IENERG,NSAMPS,IDIV)
C   STKSE IS THE HOST VERSION OF STKSEM, WHICH CALCULATES THE MEAN ENERGY
C  OF A BUNCH OF TRACES AS WELL AS FORMING A STACKED TRACE.
C
C COPYRIGHTED BY PAUL HENKART 23 JANUARY 1983
C
C ARGUMENTS:
C INWIN - THE INDEX OF APMEM OF THE BEGINNING OF THE WINDOW TO STACK.
C ISTKWN - THE INDEX OF APMEM OF WHERE THE STACKED WINDOW STARTS.
C IENERG - THE INDEX OF APMEM OF WHERE TO PUT THE ENERGY OF THE INPUT WINDOW.
C NSAMPS - THE NUMBER OF SAMPLES IN THE WINDOW.
C IDIV   - THE INDEX OF A WORD IN APMEM THAT IS THE COUNT OF WINDOWS (I.E. ADD
C          TO IT)
C
       COMMON /APMEM/ A(32766)
C
      J=INWIN-1
      K=ISTKWN-1
      ENERGY=0.
      DO 100 I=1,NSAMPS
      A(K+I)=A(K+I)+A(J+I)                                              ! /* STACK THE WINDOW
100   ENERGY=ENERGY+A(J+I)*A(J+I)
      A(IENERG)=A(IENERG)+ENERGY
      A(IDIV)=A(IDIV)+1.
c      PRINT 111,J,K,IENERG,IDIV,A(IENERG),A(IDIV)
c111   FORMAT(' IN STKSE',4I8,2F12.5)
      RETURN
      END


Subroutine energy(e, temp)
  Implicit Double Precision (A-H, O-Z)
  External ran1
  Common /para2/xmp, xmu, alpha, rscut2, cutof2
  Common /rndm3/iseedp
  Save
  iseed = iseedp
1000 Continue
  e = ran1(iseed)
  e = e*ran1(iseed)
  e = e*ran1(iseed)
  If (e<=0D0) Goto 1000
  e = -temp*log(e)
  If (ran1(iseed)>exp((e-dsqrt(e**2+xmp**2))/temp)) Then
     Goto 1000
  End If
  Return
End Subroutine energy


      program type16
      real a, b

      read *, a

      a = amax1(a+1., 4., 5.)

      b = 3.

      if(a.lt.b-0.5) then
         print *, 'a is small'
      else
         print *, 'a is big'
      endif

      end


program main
    use mpi
    implicit none

    integer, parameter :: manager = 0, MAX_ROWS = 1000, MAX_COLS = 1000
    integer :: rank, numprocs, ierr, status(MPI_STATUS_SIZE)
    integer :: i, j, row, rows, cols, numsent, sender, row_tag, end_signal_tag
    double precision :: A(MAX_ROWS, MAX_COLS), B(MAX_COLS), C(MAX_ROWS), buffer(MAX_COLS)
    double precision :: dot_product

    rows = 100
    cols = 100
    dot_product = 0.0d0
    end_signal_tag = 0

    call MPI_INIT(ierr)
    call MPI_COMM_RANK(MPI_COMM_WORLD, rank, ierr)
    call MPI_COMM_SIZE(MPI_COMM_WORLD, numprocs, ierr)

    if ( rank .eq. manager ) then

        ! 1. Initialize A, B, C
        call random_seed()
        call random_number(A)
        call random_number(B)
        C = 0.0d0

        ! 2. Send vector B to all workers
        call MPI_BCAST(B, cols, MPI_DOUBLE_PRECISION, manager, MPI_COMM_WORLD, ierr)

        ! 3. send a tagged row to each worker process
        numsent = 0
        do i = 1, min(numprocs - 1, rows)
            ! create the row
            do j = 1, cols
                buffer(j) = A(i, j)
            end do

            call  MPI_SEND(buffer, cols, MPI_DOUBLE_PRECISION, i, i, MPI_COMM_WORLD, ierr)
            numsent = numsent + 1
        end do

        ! 4. Receive dot product dot_productwer from workers
        do i = 1, rows
            call MPI_RECV(dot_product, 1, MPI_DOUBLE_PRECISION, MPI_ANY_SOURCE, MPI_ANY_TAG, MPI_COMM_WORLD, status, ierr)

            ! since row is tagged, row == tag
            row_tag = status(MPI_TAG)
            C(row_tag) = dot_product
            sender  = status(MPI_SOURCE)

            ! Send next row
            if ( numsent .lt. rows ) then

                do j = 1, cols
                    buffer(j) = A(numsent+1, j)
                end do

                call MPI_SEND(buffer, cols, MPI_DOUBLE_PRECISION, sender, numsent+1, MPI_COMM_WORLD, ierr)
                numsent = numsent + 1

            ! Or send the end signal when no more work to do
            else
                call MPI_SEND(MPI_BOTTOM, 0, MPI_DOUBLE_PRECISION, sender, end_signal_tag, MPI_COMM_WORLD, ierr)
            end if

        end do

        ! 5. Print the results of C
        do i = 1, cols
            print *, "C(", i, ") = ", C(i)
        end do

    else

        ! Receive row from manager and compute the dot product
        call MPI_BCAST(B, cols, MPI_DOUBLE_PRECISION, manager, MPI_COMM_WORLD, ierr)

        do
            call MPI_RECV(buffer, cols, MPI_DOUBLE_PRECISION, manager, MPI_ANY_TAG, MPI_COMM_WORLD, status, ierr)

            ! check for end signal, i.e. the tag is 0
            if (status(MPI_TAG) .eq. 0) exit

            ! otherwise, carry on the task at hand
            row = status(MPI_TAG)
            do i = 1, cols
                dot_product = dot_product+buffer(i)*b(i)
            end do

            call MPI_SEND(dot_product, 1, MPI_DOUBLE_PRECISION, manager, row, MPI_COMM_WORLD, ierr)
        end do

    end if

    call MPI_FINALIZE(ierr)

end program main


c { dg-do run }
c  intrinsic-unix-erf.f
c
c Test Bessel function intrinsics.
c These functions are only available if provided by system
c
c     David Billinghurst <David.Billinghurst@riotinto.com>
c
      real x, a
      double precision dx, da
      logical fail
      common /flags/ fail
      fail = .false.

      x = 0.6
      dx = x
c     ERF  - error function
      a = 0.6038561
      da = a
      call c_r(ERF(x),a,'ERF(real)')
      call c_d(ERF(dx),da,'ERF(double)')
      call c_d(DERF(dx),da,'DERF(double)')

c     ERFC  - complementary error function
      a = 1.0 - a
      da = a
      call c_r(ERFC(x),a,'ERFC(real)')
      call c_d(ERFC(dx),da,'ERFC(double)')
      call c_d(DERFC(dx),da,'DERFC(double)')

      if ( fail ) call abort()
      end

      subroutine failure(label)
c     Report failure and set flag
      character*(*) label
      logical fail
      common /flags/ fail
      write(6,'(a,a,a)') 'Test ',label,' FAILED'
      fail = .true.
      end

      subroutine c_r(a,b,label)
c     Check if REAL a equals b, and fail otherwise
      real a, b
      character*(*) label
      if ( abs(a-b) .gt. 1.0e-5 ) then
         call failure(label)
         write(6,*) 'Got ',a,' expected ', b
      end if
      end

      subroutine c_d(a,b,label)
c     Check if DOUBLE PRECISION a equals b, and fail otherwise
      double precision a, b
      character*(*) label
      if ( abs(a-b) .gt. 1.0d-5 ) then
         call failure(label)
         write(6,*) 'Got ',a,' expected ', b
      end if
      end


! { dg-do run }
! { dg-options "-fno-inline" }

  module m1
    contains
    recursive function fact (x) result (res)
      !$acc routine
      integer, intent(in) :: x
      integer :: res
      if (x < 1) then
         res = 1
      else
         res = x * fact (x - 1)
      end if
    end function fact
  end module m1
  use m1
  integer, parameter :: n = 10
  integer :: a(n), i
  !$acc parallel
  !$acc loop
  do i = 1, n
     a(i) = fact (i)
  end do
  !$acc end parallel
  do i = 1, n
     if (a(i) .ne. fact(i)) call abort
  end do
end


C***********************************************************************
C*
C*	Copyright 1996, University Corporation for Atmospheric Research.
C*
C*	prring.f
C*
C*	Radar ring drawing functions.
C*
C*	History:
C*
C*	11/96	COMET	Original copy
C*	 5/97	COMET	Added gprintf to support logging.
C*	 3/98	COMET	Allow for station ids with different string lengths.
C*	 1/01	Unidata	Updated call to GCIRCL
C*
C************************************************************************
C************************************************************************

	subroutine dist ( slat, slon, distance, length, iret )

	REAL		slat, slon, distance, length
	INTEGER		iret

	REAL		meters

C* This subroutine computes the distance in N coordinate system from a
C* point outward along an arc on a sphere.

	INCLUDE		'GEMPRM.PRM'

	meters = distance * 1000.

C*	Compute arc endpoints.

	theta = RTD * meters / RADIUS

	rlon = slon
	rlat = slat + theta

C*	Convert endpoint positions to normalize coordinates.

	CALL GTRANS  ( 'M', 'N', 1, slat, slon, sx, sy, ier )
	CALL GTRANS  ( 'M', 'N', 1, rlat, rlon, rx, ry, ier )

	dx = sx - rx
	dy = sy - ry

C*	Determine arc length in normalize coordinates.

	length = SQRT ( dx**2 + dy**2 )

	return
	end

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

	SUBROUTINE prring ( nstns, stations, stid, slat, slon,
     +                      color, nrings, rincr, rmin, units,
     +                      verbose, iret )

	INCLUDE		'GEMPRM.PRM'
C*
	CHARACTER*(*)	stations, stid, units
	INTEGER		color, verbose
	REAL		slat(*), slon(*)

	CHARACTER	stn*8, blank*2, buf*40, output*60
	REAL		sx(LLSTFL), sy(LLSTFL)
	REAL		kmpermi, kmpernm
C*
	INTEGER		ixof (10), iyof (10)
C*
	DATA		ixof  / 0, 0, 2, 2,  0,  2, 0,  0, 0,  0 /
	DATA		iyof  / 2, 0, 2, 0, -2, -2, 4, -4, 2, -2 /
	DATA		kmpermi, kmpernm / 1.609, 1.85 /
C
C*	Here, we are assuming that the character 'stations' is a single
C*	string containing a list of station ids. Each id is 3
C*	characters long and separated by a single space.
C
C*
C------------------------------------------------------------------------
	iret = 0
	blank = ' ' // char(0)

	if ( verbose .gt. 0 )
     +         call gfprints ( 'prring'//char(0), blank )
	if ( verbose .gt. 1 ) then
	    call gfprinti ( ' nstns = ' // char(0), nstns )
	    call gfprints ( ' stations = ' // char(0), stations )
	    call gfprints ( ' stid = ' // char(0), stid )
	    call gfprinti ( ' color = ' // char(0), color )
	    call gfprinti ( ' nrings = ' // char(0), nrings )
	    call gfprintf ( ' rincr = ' // char(0), rincr )
	    call gfprintf ( ' rmin = ' // char(0), rmin )
	    call gfprints ( ' units = ' // char(0), units )
	    call gfprinti ( ' iret = ' // char(0), iret )
	end if

	if ( verbose .gt. 2 ) then
	    do i=1, nstns
		write (buf,'(i8,2(1x,f10.4))' ) i, slat(i), slon(i)
		output = '  i, lat, lon = ' // buf
		call gfprints ( '  ' // char(0), output//char(0) )
	  end do
	end if

C
C*	Set color.
C
	CALL GSCOLR  ( color, ier )
C
C*	"Force" the color to be set. The preceeding GSCOLR sets the new
C*	color in a common block and subsequent calls to plotting routines
C*	calls DSCOLR which changes the color in the device. But the GCIRCL
C*	routine called below does not do this (bug) so, calling DSCOLR
C*	will force the color to change right now. If this is ever fixed
C*	in GEMPAK, then this call to DSCOLR can be removed.
C
	CALL DSCOLR ( color, icol, ier )
C
C*	Convert to plot coordinates.
C
	CALL GTRANS  ( 'M', 'P', nstns, slat, slon, sx, sy, ier )
C
C*	Plot radar rings.
C
	ibeg = 1
	iend = ibeg

	do i=1, nstns
C
C*	Get the next station.
C
	    do while ( stations(iend:iend) .ne. ' ' )
		iend = iend + 1
	    end do
	    len = iend - ibeg

	    stn = stations(ibeg:iend)

C
C*	If only one station is to be plotted check for that station.
C
	    if ( stid .eq. 'ALL' .or.
     +	       ( stid .ne. 'ALL' .and.
     +           stn(1:len) .eq. stid ) ) then

	    	do j=1, nrings
C
C*	Check map boundaries.
C
	            if ( ( sx(i) .gt. 0 .and. sx(i) .lt. 1 ) .and.
     +                   ( sy(i) .gt. 0 .and. sy(i) .lt. 1 ) ) then

		        drad = rincr * ( j-1 ) + rmin

C		Chiz/Unidata changed this, GCIRCL change in 5.6
C	                CALL DIST ( slat(i), slon(i), drad, rlen,
C     +                                                       iret )
C		        if ( units .eq. 'mi' ) rlen = kmpermi * rlen
C		        if ( units .eq. 'nm' ) rlen = kmpernm * rlen
C
C		        CALL GCIRCL ( 'M', slat(i), slon(i), rlen,
C     +                           1, iret )

			rlen = drad
			if ( units .eq. 'mi' ) rlen = kmpermi * rlen
			if ( units .eq. 'nm' ) rlen = kmpernm * rlen
		        CALL GCIRCL ( 'M', slat(i), slon(i),
     +				slat(i) + (rlen / 111.111), slon(i),
     +                           10, iret )
		endif

	    enddo
	    endif
C
C*	Got to the start of the next station.
C
	    do while ( stations(iend:iend) .eq. ' ' )
		iend = iend + 1
	    end do
	    ibeg = iend
	enddo
C*
C	CALL GFLUSH ( iret )
C*
	if ( verbose .gt. 0 ) call gfprinti (
     +  'returning from prring - iret = '//char(0), iret )
	RETURN
	END


      SUBROUTINE SGETRFNP( M, N, A, LDA, INFO )
!
!  -- LAPACK computational routine (version 3.4.0) --
!  -- LAPACK is a software package provided by Univ. of Tennessee,    --
!  -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
!     November 2011
!
!     .. Scalar Arguments ..
      INTEGER            INFO, LDA, M, N
!     ..
!     .. Array Arguments ..
      REAL*4             A( LDA, * )
!     ..
!
!  =====================================================================
!
!     .. Parameters ..
      REAL*4             ONE, ZERO
      PARAMETER          ( ONE = 1.0+0, ZERO = 0.0+0 )
!     ..
!     .. Local Scalars ..
      REAL*4             SFMIN
      INTEGER            I, J, JP
!     ..
!     .. External Functions ..
      REAL*4             SLAMCH
      INTEGER            IDAMAX
      EXTERNAL           SLAMCH, IDAMAX
!     ..
!     .. External Subroutines ..
      EXTERNAL           SGER, SSCAL, SSWAP, XERBLA
!     ..
!     .. Intrinsic Functions ..
      INTRINSIC          MAX, MIN
!     ..
!     .. Executable Statements ..
!
!     Test the input parameters.
!
      INFO = 0
      IF( M.LT.0 ) THEN
         INFO = -1
      ELSE IF( N.LT.0 ) THEN
         INFO = -2
      ELSE IF( LDA.LT.MAX( 1, M ) ) THEN
         INFO = -4
      END IF
      IF( INFO.NE.0 ) THEN
         CALL XERBLA( 'SGETRFNP', -INFO )
         RETURN
      END IF
!
!     Quick return if possible
!
      IF( M.EQ.0 .OR. N.EQ.0 ) RETURN
!
!     Compute machine safe minimum
!
      SFMIN = SLAMCH('S')
!
      DO 10 J = 1, MIN ( M, N )
         JP = J
         IF( A( JP, J ).NE.ZERO ) THEN
!
!           Compute elements J+1:M of J-th column.
!
            IF( J.LT.M ) THEN
               IF( ABS(A( J, J )) .GE. SFMIN ) THEN
                  CALL SSCAL( M-J, ONE / A( J, J ), A( J+1, J ), 1 )
               ELSE
                 DO 20 I = 1, M-J
                    A( J+I, J ) = A( J+I, J ) / A( J, J )
   20            CONTINUE
               END IF
            END IF
!
         ELSE IF( INFO.EQ.0 ) THEN
!
            INFO = J
         END IF
!
         IF( J.LT.MIN( M, N ) ) THEN
!
!           Update trailing submatrix.
!
            CALL SGER( M-J, N-J, -ONE, A( J+1, J ), 1,&
                       A( J, J+1 ),LDA,A( J+1, J+1 ), LDA )
         END IF
   10 CONTINUE
      RETURN
!
!     End of SGETRFNP
!
      END

      SUBROUTINE SGETRF( M, N, A, LDA, IPIV, INFO )
!
!  -- LAPACK computational routine (version 3.4.0) --
!  -- LAPACK is a software package provided by Univ. of Tennessee,    --
!  -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
!     November 2011
!
!     .. Scalar Arguments ..
      INTEGER            INFO, LDA, M, N
!     ..
!     .. Array Arguments ..
      INTEGER            IPIV( * )
      REAL*4             A( LDA, * )
!     ..
!
!  =====================================================================
!
!     .. Parameters ..
      REAL*4             ONE
      PARAMETER          ( ONE = 1.0E+0 )
!     ..
!     .. Local Scalars ..
      INTEGER            I, IINFO, J, JB, NB
!     ..
!     .. External Subroutines ..
      EXTERNAL           SGEMM, SGETF2, SLASWP, STRSM, XERBLA
!     ..
!     .. External Functions ..
      INTEGER            ILAENV
      EXTERNAL           ILAENV
!     ..
!     .. Intrinsic Functions ..
      INTRINSIC          MAX, MIN
!     ..
!     .. Executable Statements ..
!
!     Test the input parameters.
!
      INFO = 0
      IF( M.LT.0 ) THEN
         INFO = -1
      ELSE IF( N.LT.0 ) THEN
         INFO = -2
      ELSE IF( LDA.LT.MAX( 1, M ) ) THEN
         INFO = -4
      END IF
      IF( INFO.NE.0 ) THEN
         CALL XERBLA( 'SGETRF', -INFO )
         RETURN
      END IF
!
!     Quick return if possible
!
      IF( M.EQ.0 .OR. N.EQ.0 ) RETURN
!
!     Determine the block size for this environment.
!
      NB = ILAENV( 1, 'SGETRF', ' ', M, N, -1, -1 )
      IF( NB.LE.1 .OR. NB.GE.MIN( M, N ) ) THEN
!
!        Use unblocked code.
!
         CALL SGETF2( M, N, A, LDA, IPIV, INFO )
      ELSE
!
!        Use blocked code.
!
         DO 20 J = 1, MIN( M, N ), NB
            JB = MIN( MIN( M, N )-J+1, NB )
!
!           Factor diagonal and subdiagonal blocks and test for exact
!           singularity.
!
            CALL SGETF2( M-J+1, JB, A( J, J ), LDA, IPIV( J ), IINFO )
!
!           Adjust INFO and the pivot indices.
!
            IF( INFO.EQ.0 .AND. IINFO.GT.0 ) INFO = IINFO + J - 1
            DO 10 I = J, MIN( M, J+JB-1 )
               IPIV( I ) = J - 1 + IPIV( I )
   10       CONTINUE
!
!           Apply interchanges to columns 1:J-1.
!
            CALL SLASWP( J-1, A, LDA, J, J+JB-1, IPIV, 1 )
!
            IF( J+JB.LE.N ) THEN
!
!              Apply interchanges to columns J+JB:N.
!
               CALL SLASWP( N-J-JB+1, A( 1, J+JB ), LDA, J, J+JB-1,&
                            IPIV, 1 )
!
!              Compute block row of U.
!
               CALL STRSM( 'Left', 'Lower', 'No transpose', 'Unit', JB,&
                           N-J-JB+1, ONE, A( J, J ), LDA, A( J, J+JB ),&
                           LDA )
               IF( J+JB.LE.M ) THEN
!
!                 Update trailing submatrix.
!
                  CALL SGEMM( 'No transpose', 'No transpose', M-J-JB+1,&
                              N-J-JB+1, JB, -ONE, A( J+JB, J ), LDA,&
                              A( J, J+JB ), LDA, ONE, A( J+JB, J+JB ),&
                              LDA )
               END IF
            END IF
   20    CONTINUE
      END IF
      RETURN
!
!     End of SGETRF
!
      END
      SUBROUTINE SGETF2( M, N, A, LDA, IPIV, INFO )
!
!  -- LAPACK computational routine (version 3.4.0) --
!  -- LAPACK is a software package provided by Univ. of Tennessee,    --
!  -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
!     November 2011
!
!     .. Scalar Arguments ..
      INTEGER            INFO, LDA, M, N
!     ..
!     .. Array Arguments ..
      INTEGER            IPIV( * )
      REAL*4             A( LDA, * )
!     ..
!
!  =====================================================================
!
!     .. Parameters ..
      REAL*4             ONE, ZERO
      PARAMETER          ( ONE = 1.0E+0, ZERO = 0.0E+0 )
!     ..
!     .. Local Scalars ..
      REAL*4             SFMIN
      INTEGER            I, J, JP
!     ..
!     .. External Functions ..
      REAL*4             SLAMCH
      INTEGER            IDAMAX
      EXTERNAL           SLAMCH, IDAMAX
!     ..
!     .. External Subroutines ..
      EXTERNAL           SGER, SSCAL, SSWAP, XERBLA
!     ..
!     .. Intrinsic Functions ..
      INTRINSIC          MAX, MIN
!     ..
!     .. Executable Statements ..
!
!     Test the input parameters.
!
      INFO = 0
      IF( M.LT.0 ) THEN
         INFO = -1
      ELSE IF( N.LT.0 ) THEN
         INFO = -2
      ELSE IF( LDA.LT.MAX( 1, M ) ) THEN
         INFO = -4
      END IF
      IF( INFO.NE.0 ) THEN
         CALL XERBLA( 'SGETF2', -INFO )
         RETURN
      END IF
!
!     Quick return if possible
!
      IF( M.EQ.0 .OR. N.EQ.0 ) RETURN
!
!     Compute machine safe minimum
!
      SFMIN = SLAMCH('S')
!
      DO 10 J = 1, MIN( M, N )
!
!        Find pivot and test for singularity.
!
         JP = J - 1 + IDAMAX( M-J+1, A( J, J ), 1 )
         IPIV( J ) = JP
         IF( A( JP, J ).NE.ZERO ) THEN
!
!           Apply the interchange to columns 1:N.
!
            IF(JP.NE.J) CALL SSWAP( N, A( J, 1 ), LDA, A( JP, 1 ), LDA )
!
!           Compute elements J+1:M of J-th column.
!
            IF( J.LT.M ) THEN
               IF( ABS(A( J, J )) .GE. SFMIN ) THEN
                  CALL SSCAL( M-J, ONE / A( J, J ), A( J+1, J ), 1 )
               ELSE
                 DO 20 I = 1, M-J
                    A( J+I, J ) = A( J+I, J ) / A( J, J )
   20            CONTINUE
               END IF
            END IF
!
         ELSE IF( INFO.EQ.0 ) THEN
!
            INFO = J
         END IF
!
         IF( J.LT.MIN( M, N ) ) THEN
!
!           Update trailing submatrix.
!
            CALL SGER( M-J, N-J, -ONE, A( J+1, J ), 1, A( J, J+1 ), &
                       LDA, A( J+1, J+1 ), LDA )
         END IF
   10 CONTINUE
      RETURN
!
!     End of SGETF2
!
      END

      SUBROUTINE SLASWP( N, A, LDA, K1, K2, IPIV, INCX )
!
!  -- LAPACK auxiliary routine (version 3.4.0) --
!  -- LAPACK is a software package provided by Univ. of Tennessee,    --
!  -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
!     November 2011
!
!     .. Scalar Arguments ..
      INTEGER            INCX, K1, K2, LDA, N
!     ..
!     .. Array Arguments ..
      INTEGER            IPIV( * )
      REAL*4             A( LDA, * )
!     ..
!
! =====================================================================
!
!     .. Local Scalars ..
      INTEGER            I, I1, I2, INC, IP, IX, IX0, J, K, N32
      REAL*4             TEMP
!     ..
!     .. Executable Statements ..
!
!     Interchange row I with row IPIV(I) for each of rows K1 through K2.
!
      IF( INCX.GT.0 ) THEN
         IX0 = K1
         I1 = K1
         I2 = K2
         INC = 1
      ELSE IF( INCX.LT.0 ) THEN
         IX0 = 1 + ( 1-K2 )*INCX
         I1 = K2
         I2 = K1
         INC = -1
      ELSE
         RETURN
      END IF
!
      N32 = ( N / 32 )*32
      IF( N32.NE.0 ) THEN
         DO 30 J = 1, N32, 32
            IX = IX0
            DO 20 I = I1, I2, INC
               IP = IPIV( IX )
               IF( IP.NE.I ) THEN
                  DO 10 K = J, J + 31
                     TEMP = A( I, K )
                     A( I, K ) = A( IP, K )
                     A( IP, K ) = TEMP
   10             CONTINUE
               END IF
               IX = IX + INCX
   20       CONTINUE
   30    CONTINUE
      END IF
      IF( N32.NE.N ) THEN
         N32 = N32 + 1
         IX = IX0
         DO 50 I = I1, I2, INC
            IP = IPIV( IX )
            IF( IP.NE.I ) THEN
               DO 40 K = N32, N
                  TEMP = A( I, K )
                  A( I, K ) = A( IP, K )
                  A( IP, K ) = TEMP
   40          CONTINUE
            END IF
            IX = IX + INCX
   50    CONTINUE
      END IF
!
      RETURN
!
!     End of SLASWP
!
      END
      SUBROUTINE STRSM(SIDE,UPLO,TRANSA,DIAG,M,N,ALPHA,A,LDA,B,LDB)
!
!  -- Reference BLAS level3 routine (version 3.4.0) --
!  -- Reference BLAS is a software package provided by Univ. of Tennessee,    --
!  -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
!     November 2011
!
!     .. Scalar Arguments ..
      REAL*4           ALPHA
      INTEGER LDA,LDB,M,N
      CHARACTER DIAG,SIDE,TRANSA,UPLO
!     ..
!     .. Array Arguments ..
      REAL*4           A(LDA,*),B(LDB,*)
!     ..
!
!  =====================================================================
!
!     .. External Functions ..
      LOGICAL LSAME
      EXTERNAL LSAME
!     ..
!     .. External Subroutines ..
      EXTERNAL XERBLA
!     ..
!     .. Intrinsic Functions ..
      INTRINSIC MAX
!     ..
!     .. Local Scalars ..
      REAL*4           TEMP
      INTEGER I,INFO,J,K,NROWA
      LOGICAL LSIDE,NOUNIT,UPPER
!     ..
!     .. Parameters ..
      REAL*4           ONE,ZERO
      PARAMETER (ONE=1.0E+0,ZERO=0.0E+0)
!     ..
!
!     Test the input parameters.
!
      LSIDE = LSAME(SIDE,'L')
      IF (LSIDE) THEN
          NROWA = M
      ELSE
          NROWA = N
      END IF
      NOUNIT = LSAME(DIAG,'N')
      UPPER = LSAME(UPLO,'U')
!
      INFO = 0
      IF ((.NOT.LSIDE) .AND. (.NOT.LSAME(SIDE,'R'))) THEN
          INFO = 1
      ELSE IF ((.NOT.UPPER) .AND. (.NOT.LSAME(UPLO,'L'))) THEN
          INFO = 2
      ELSE IF ((.NOT.LSAME(TRANSA,'N')) .AND. &
               (.NOT.LSAME(TRANSA,'T')) .AND. &
               (.NOT.LSAME(TRANSA,'C'))) THEN
          INFO = 3
      ELSE IF ((.NOT.LSAME(DIAG,'U')) .AND. (.NOT.LSAME(DIAG,'N'))) THEN
          INFO = 4
      ELSE IF (M.LT.0) THEN
          INFO = 5
      ELSE IF (N.LT.0) THEN
          INFO = 6
      ELSE IF (LDA.LT.MAX(1,NROWA)) THEN
          INFO = 9
      ELSE IF (LDB.LT.MAX(1,M)) THEN
          INFO = 11
      END IF
      IF (INFO.NE.0) THEN
          CALL XERBLA('STRSM ',INFO)
          RETURN
      END IF
!
!     Quick return if possible.
!
      IF (M.EQ.0 .OR. N.EQ.0) RETURN
!
!     And when  alpha.eq.zero.
!
      IF (ALPHA.EQ.ZERO) THEN
          DO 20 J = 1,N
              DO 10 I = 1,M
                  B(I,J) = ZERO
   10         CONTINUE
   20     CONTINUE
          RETURN
      END IF
!
!     Start the operations.
!
      IF (LSIDE) THEN
          IF (LSAME(TRANSA,'N')) THEN
!
!           Form  B := alpha*inv( A )*B.
!
              IF (UPPER) THEN
                  DO 60 J = 1,N
                      IF (ALPHA.NE.ONE) THEN
                          DO 30 I = 1,M
                              B(I,J) = ALPHA*B(I,J)
   30                     CONTINUE
                      END IF
                      DO 50 K = M,1,-1
                          IF (B(K,J).NE.ZERO) THEN
                              IF (NOUNIT) B(K,J) = B(K,J)/A(K,K)
                              DO 40 I = 1,K - 1
                                  B(I,J) = B(I,J) - B(K,J)*A(I,K)
   40                         CONTINUE
                          END IF
   50                 CONTINUE
   60             CONTINUE
              ELSE
                  DO 100 J = 1,N
                      IF (ALPHA.NE.ONE) THEN
                          DO 70 I = 1,M
                              B(I,J) = ALPHA*B(I,J)
   70                     CONTINUE
                      END IF
                      DO 90 K = 1,M
                          IF (B(K,J).NE.ZERO) THEN
                              IF (NOUNIT) B(K,J) = B(K,J)/A(K,K)
                              DO 80 I = K + 1,M
                                  B(I,J) = B(I,J) - B(K,J)*A(I,K)
   80                         CONTINUE
                          END IF
   90                 CONTINUE
  100             CONTINUE
              END IF
          ELSE
!
!           Form  B := alpha*inv( A**T )*B.
!
              IF (UPPER) THEN
                  DO 130 J = 1,N
                      DO 120 I = 1,M
                          TEMP = ALPHA*B(I,J)
                          DO 110 K = 1,I - 1
                              TEMP = TEMP - A(K,I)*B(K,J)
  110                     CONTINUE
                          IF (NOUNIT) TEMP = TEMP/A(I,I)
                          B(I,J) = TEMP
  120                 CONTINUE
  130             CONTINUE
              ELSE
                  DO 160 J = 1,N
                      DO 150 I = M,1,-1
                          TEMP = ALPHA*B(I,J)
                          DO 140 K = I + 1,M
                              TEMP = TEMP - A(K,I)*B(K,J)
  140                     CONTINUE
                          IF (NOUNIT) TEMP = TEMP/A(I,I)
                          B(I,J) = TEMP
  150                 CONTINUE
  160             CONTINUE
              END IF
          END IF
      ELSE
          IF (LSAME(TRANSA,'N')) THEN
!
!           Form  B := alpha*B*inv( A ).
!
              IF (UPPER) THEN
                  DO 210 J = 1,N
                      IF (ALPHA.NE.ONE) THEN
                          DO 170 I = 1,M
                              B(I,J) = ALPHA*B(I,J)
  170                     CONTINUE
                      END IF
                      DO 190 K = 1,J - 1
                          IF (A(K,J).NE.ZERO) THEN
                              DO 180 I = 1,M
                                  B(I,J) = B(I,J) - A(K,J)*B(I,K)
  180                         CONTINUE
                          END IF
  190                 CONTINUE
                      IF (NOUNIT) THEN
                          TEMP = ONE/A(J,J)
                          DO 200 I = 1,M
                              B(I,J) = TEMP*B(I,J)
  200                     CONTINUE
                      END IF
  210             CONTINUE
              ELSE
                  DO 260 J = N,1,-1
                      IF (ALPHA.NE.ONE) THEN
                          DO 220 I = 1,M
                              B(I,J) = ALPHA*B(I,J)
  220                     CONTINUE
                      END IF
                      DO 240 K = J + 1,N
                          IF (A(K,J).NE.ZERO) THEN
                              DO 230 I = 1,M
                                  B(I,J) = B(I,J) - A(K,J)*B(I,K)
  230                         CONTINUE
                          END IF
  240                 CONTINUE
                      IF (NOUNIT) THEN
                          TEMP = ONE/A(J,J)
                          DO 250 I = 1,M
                              B(I,J) = TEMP*B(I,J)
  250                     CONTINUE
                      END IF
  260             CONTINUE
              END IF
          ELSE
!
!           Form  B := alpha*B*inv( A**T ).
!
              IF (UPPER) THEN
                  DO 310 K = N,1,-1
                      IF (NOUNIT) THEN
                          TEMP = ONE/A(K,K)
                          DO 270 I = 1,M
                              B(I,K) = TEMP*B(I,K)
  270                     CONTINUE
                      END IF
                      DO 290 J = 1,K - 1
                          IF (A(J,K).NE.ZERO) THEN
                              TEMP = A(J,K)
                              DO 280 I = 1,M
                                  B(I,J) = B(I,J) - TEMP*B(I,K)
  280                         CONTINUE
                          END IF
  290                 CONTINUE
                      IF (ALPHA.NE.ONE) THEN
                          DO 300 I = 1,M
                              B(I,K) = ALPHA*B(I,K)
  300                     CONTINUE
                      END IF
  310             CONTINUE
              ELSE
                  DO 360 K = 1,N
                      IF (NOUNIT) THEN
                          TEMP = ONE/A(K,K)
                          DO 320 I = 1,M
                              B(I,K) = TEMP*B(I,K)
  320                     CONTINUE
                      END IF
                      DO 340 J = K + 1,N
                          IF (A(J,K).NE.ZERO) THEN
                              TEMP = A(J,K)
                              DO 330 I = 1,M
                                  B(I,J) = B(I,J) - TEMP*B(I,K)
  330                         CONTINUE
                          END IF
  340                 CONTINUE
                      IF (ALPHA.NE.ONE) THEN
                          DO 350 I = 1,M
                              B(I,K) = ALPHA*B(I,K)
  350                     CONTINUE
                      END IF
  360             CONTINUE
              END IF
          END IF
      END IF
!
      RETURN
!
!     End of STRSM .
!
      END
      SUBROUTINE SGEMM(TRANSA,TRANSB,M,N,K,ALPHA,A,LDA,B,LDB,BETA,C,LDC)
!
!  -- Reference BLAS level3 routine (version 3.4.0) --
!  -- Reference BLAS is a software package provided by Univ. of Tennessee,    --
!  -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
!     November 2011
!
!     .. Scalar Arguments ..
      REAL*4           ALPHA,BETA
      INTEGER K,LDA,LDB,LDC,M,N
      CHARACTER TRANSA,TRANSB
!     ..
!     .. Array Arguments ..
      REAL*4           A(LDA,*),B(LDB,*),C(LDC,*)
!     ..
!
!  =====================================================================
!
!     .. External Functions ..
      LOGICAL LSAME
      EXTERNAL LSAME
!     ..
!     .. External Subroutines ..
      EXTERNAL XERBLA
!     ..
!     .. Intrinsic Functions ..
      INTRINSIC MAX
!     ..
!     .. Local Scalars ..
      REAL*4           TEMP
      INTEGER I,INFO,J,L,NCOLA,NROWA,NROWB
      LOGICAL NOTA,NOTB
!     ..
!     .. Parameters ..
      REAL*4           ONE,ZERO
      PARAMETER (ONE=1.0E+0,ZERO=0.0E+0)
!     ..
!
!     Set  NOTA  and  NOTB  as  true if  A  and  B  respectively are not
!     transposed and set  NROWA, NCOLA and  NROWB  as the number of rows
!     and  columns of  A  and the  number of  rows  of  B  respectively.
!
      NOTA = LSAME(TRANSA,'N')
      NOTB = LSAME(TRANSB,'N')
      IF (NOTA) THEN
          NROWA = M
          NCOLA = K
      ELSE
          NROWA = K
          NCOLA = M
      END IF
      IF (NOTB) THEN
          NROWB = K
      ELSE
          NROWB = N
      END IF
!
!     Test the input parameters.
!
      INFO = 0
      IF ((.NOT.NOTA) .AND. (.NOT.LSAME(TRANSA,'C')) .AND. &
          (.NOT.LSAME(TRANSA,'T'))) THEN
          INFO = 1
      ELSE IF ((.NOT.NOTB) .AND. (.NOT.LSAME(TRANSB,'C')) .AND. &
               (.NOT.LSAME(TRANSB,'T'))) THEN
          INFO = 2
      ELSE IF (M.LT.0) THEN
          INFO = 3
      ELSE IF (N.LT.0) THEN
          INFO = 4
      ELSE IF (K.LT.0) THEN
          INFO = 5
      ELSE IF (LDA.LT.MAX(1,NROWA)) THEN
          INFO = 8
      ELSE IF (LDB.LT.MAX(1,NROWB)) THEN
          INFO = 10
      ELSE IF (LDC.LT.MAX(1,M)) THEN
          INFO = 13
      END IF
      IF (INFO.NE.0) THEN
          CALL XERBLA('SGEMM ',INFO)
          RETURN
      END IF
!
!     Quick return if possible.
!
      IF ((M.EQ.0) .OR. (N.EQ.0) .OR. &
          (((ALPHA.EQ.ZERO).OR. (K.EQ.0)).AND. (BETA.EQ.ONE))) RETURN
!
!     And if  alpha.eq.zero.
!
      IF (ALPHA.EQ.ZERO) THEN
          IF (BETA.EQ.ZERO) THEN
              DO 20 J = 1,N
                  DO 10 I = 1,M
                      C(I,J) = ZERO
   10             CONTINUE
   20         CONTINUE
          ELSE
              DO 40 J = 1,N
                  DO 30 I = 1,M
                      C(I,J) = BETA*C(I,J)
   30             CONTINUE
   40         CONTINUE
          END IF
          RETURN
      END IF
!
!     Start the operations.
!
      IF (NOTB) THEN
          IF (NOTA) THEN
!
!           Form  C := alpha*A*B + beta*C.
!
              DO 90 J = 1,N
                  IF (BETA.EQ.ZERO) THEN
                      DO 50 I = 1,M
                          C(I,J) = ZERO
   50                 CONTINUE
                  ELSE IF (BETA.NE.ONE) THEN
                      DO 60 I = 1,M
                          C(I,J) = BETA*C(I,J)
   60                 CONTINUE
                  END IF
                  DO 80 L = 1,K
                      IF (B(L,J).NE.ZERO) THEN
                          TEMP = ALPHA*B(L,J)
                          DO 70 I = 1,M
                              C(I,J) = C(I,J) + TEMP*A(I,L)
   70                     CONTINUE
                      END IF
   80             CONTINUE
   90         CONTINUE
          ELSE
!
!           Form  C := alpha*A**T*B + beta*C
!
              DO 120 J = 1,N
                  DO 110 I = 1,M
                      TEMP = ZERO
                      DO 100 L = 1,K
                          TEMP = TEMP + A(L,I)*B(L,J)
  100                 CONTINUE
                      IF (BETA.EQ.ZERO) THEN
                          C(I,J) = ALPHA*TEMP
                      ELSE
                          C(I,J) = ALPHA*TEMP + BETA*C(I,J)
                      END IF
  110             CONTINUE
  120         CONTINUE
          END IF
      ELSE
          IF (NOTA) THEN
!
!           Form  C := alpha*A*B**T + beta*C
!
              DO 170 J = 1,N
                  IF (BETA.EQ.ZERO) THEN
                      DO 130 I = 1,M
                          C(I,J) = ZERO
  130                 CONTINUE
                  ELSE IF (BETA.NE.ONE) THEN
                      DO 140 I = 1,M
                          C(I,J) = BETA*C(I,J)
  140                 CONTINUE
                  END IF
                  DO 160 L = 1,K
                      IF (B(J,L).NE.ZERO) THEN
                          TEMP = ALPHA*B(J,L)
                          DO 150 I = 1,M
                              C(I,J) = C(I,J) + TEMP*A(I,L)
  150                     CONTINUE
                      END IF
  160             CONTINUE
  170         CONTINUE
          ELSE
!
!           Form  C := alpha*A**T*B**T + beta*C
!
              DO 200 J = 1,N
                  DO 190 I = 1,M
                      TEMP = ZERO
                      DO 180 L = 1,K
                          TEMP = TEMP + A(L,I)*B(J,L)
  180                 CONTINUE
                      IF (BETA.EQ.ZERO) THEN
                          C(I,J) = ALPHA*TEMP
                      ELSE
                          C(I,J) = ALPHA*TEMP + BETA*C(I,J)
                      END IF
  190             CONTINUE
  200         CONTINUE
          END IF
      END IF
!
      RETURN
!
!     End of SGEMM .
!
      END
      SUBROUTINE SSWAP(N,SX,INCX,SY,INCY)
!
!  -- Reference BLAS level1 routine (version 3.4.0) --
!  -- Reference BLAS is a software package provided by Univ. of Tennessee,    --
!  -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
!     November 2011
!
!     .. Scalar Arguments ..
      INTEGER INCX,INCY,N
!     ..
!     .. Array Arguments ..
      REAL SX(*),SY(*)
!     ..
!
!  =====================================================================
!
!     .. Local Scalars ..
      REAL STEMP
      INTEGER I,IX,IY,M,MP1
!     ..
!     .. Intrinsic Functions ..
      INTRINSIC MOD
!     ..
      IF (N.LE.0) RETURN
      IF (INCX.EQ.1 .AND. INCY.EQ.1) THEN
!
!       code for both increments equal to 1
!
!
!       clean-up loop
!
         M = MOD(N,3)
         IF (M.NE.0) THEN
            DO I = 1,M
               STEMP = SX(I)
               SX(I) = SY(I)
               SY(I) = STEMP
            END DO
            IF (N.LT.3) RETURN
         END IF
         MP1 = M + 1
         DO I = MP1,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
      ELSE
!
!       code for unequal increments or equal increments not equal
!         to 1
!
         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
      END IF
      RETURN
      END
      SUBROUTINE SSCAL(N,SA,SX,INCX)
!
!  -- Reference BLAS level1 routine (version 3.4.0) --
!  -- Reference BLAS is a software package provided by Univ. of Tennessee,    --
!  -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
!     November 2011
!
!     .. Scalar Arguments ..
      REAL SA
      INTEGER INCX,N
!     ..
!     .. Array Arguments ..
      REAL SX(*)
!     ..
!
!  =====================================================================
!
!     .. Local Scalars ..
      INTEGER I,M,MP1,NINCX
!     ..
!     .. Intrinsic Functions ..
      INTRINSIC MOD
!     ..
      IF (N.LE.0 .OR. INCX.LE.0) RETURN
      IF (INCX.EQ.1) THEN
!
!        code for increment equal to 1
!
!
!        clean-up loop
!
         M = MOD(N,5)
         IF (M.NE.0) THEN
            DO I = 1,M
               SX(I) = SA*SX(I)
            END DO
            IF (N.LT.5) RETURN
         END IF
         MP1 = M + 1
         DO I = MP1,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
      ELSE
!
!        code for increment not equal to 1
!
         NINCX = N*INCX
         DO I = 1,NINCX,INCX
            SX(I) = SA*SX(I)
         END DO
      END IF
      RETURN
      END
      SUBROUTINE SGER(M,N,ALPHA,X,INCX,Y,INCY,A,LDA)
!
!  -- Reference BLAS level2 routine (version 3.4.0) --
!  -- Reference BLAS is a software package provided by Univ. of Tennessee,    --
!  -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
!     November 2011
!
!     .. Scalar Arguments ..
      REAL ALPHA
      INTEGER INCX,INCY,LDA,M,N
!     ..
!     .. Array Arguments ..
      REAL A(LDA,*),X(*),Y(*)
!     ..
!
!  =====================================================================
!
!     .. Parameters ..
      REAL ZERO
      PARAMETER (ZERO=0.0E+0)
!     ..
!     .. Local Scalars ..
      REAL TEMP
      INTEGER I,INFO,IX,J,JY,KX
!     ..
!     .. External Subroutines ..
      EXTERNAL XERBLA
!     ..
!     .. Intrinsic Functions ..
      INTRINSIC MAX
!     ..
!
!     Test the input parameters.
!
      INFO = 0
      IF (M.LT.0) THEN
          INFO = 1
      ELSE IF (N.LT.0) THEN
          INFO = 2
      ELSE IF (INCX.EQ.0) THEN
          INFO = 5
      ELSE IF (INCY.EQ.0) THEN
          INFO = 7
      ELSE IF (LDA.LT.MAX(1,M)) THEN
          INFO = 9
      END IF
      IF (INFO.NE.0) THEN
          CALL XERBLA('SGER  ',INFO)
          RETURN
      END IF
!
!     Quick return if possible.
!
      IF ((M.EQ.0) .OR. (N.EQ.0) .OR. (ALPHA.EQ.ZERO)) RETURN
!
!     Start the operations. In this version the elements of A are
!     accessed sequentially with one pass through A.
!
      IF (INCY.GT.0) THEN
          JY = 1
      ELSE
          JY = 1 - (N-1)*INCY
      END IF
      IF (INCX.EQ.1) THEN
          DO 20 J = 1,N
              IF (Y(JY).NE.ZERO) THEN
                  TEMP = ALPHA*Y(JY)
                  DO 10 I = 1,M
                      A(I,J) = A(I,J) + X(I)*TEMP
   10             CONTINUE
              END IF
              JY = JY + INCY
   20     CONTINUE
      ELSE
          IF (INCX.GT.0) THEN
              KX = 1
          ELSE
              KX = 1 - (M-1)*INCX
          END IF
          DO 40 J = 1,N
              IF (Y(JY).NE.ZERO) THEN
                  TEMP = ALPHA*Y(JY)
                  IX = KX
                  DO 30 I = 1,M
                      A(I,J) = A(I,J) + X(IX)*TEMP
                      IX = IX + INCX
   30             CONTINUE
              END IF
              JY = JY + INCY
   40     CONTINUE
      END IF
!
      RETURN
!
!     End of SGER  .
!
      END
      INTEGER FUNCTION ISAMAX(N,SX,INCX)
!
!  -- Reference BLAS level1 routine (version 3.4.0) --
!  -- Reference BLAS is a software package provided by Univ. of Tennessee,    --
!  -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
!     November 2011
!
!     .. Scalar Arguments ..
      INTEGER INCX,N
!     ..
!     .. Array Arguments ..
      REAL SX(*)
!     ..
!
!  =====================================================================
!
!     .. Local Scalars ..
      REAL SMAX
      INTEGER I,IX
!     ..
!     .. Intrinsic Functions ..
      INTRINSIC ABS
!     ..
      ISAMAX = 0
      IF (N.LT.1 .OR. INCX.LE.0) RETURN
      ISAMAX = 1
      IF (N.EQ.1) RETURN
      IF (INCX.EQ.1) THEN
!
!        code for increment equal to 1
!
         SMAX = ABS(SX(1))
         DO I = 2,N
            IF (ABS(SX(I)).GT.SMAX) THEN
               ISAMAX = I
               SMAX = ABS(SX(I))
            END IF
         END DO
      ELSE
!
!        code for increment not equal to 1
!
         IX = 1
         SMAX = ABS(SX(1))
         IX = IX + INCX
         DO I = 2,N
            IF (ABS(SX(IX)).GT.SMAX) THEN
               ISAMAX = I
               SMAX = ABS(SX(IX))
            END IF
            IX = IX + INCX
         END DO
      END IF
      RETURN
      END
      REAL             FUNCTION SLAMCH( CMACH )
!
!  -- LAPACK auxiliary routine (version 3.4.0) --
!  -- LAPACK is a software package provided by Univ. of Tennessee,    --
!  -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
!     November 2011
!
!     .. Scalar Arguments ..
      CHARACTER          CMACH
!     ..
!
! =====================================================================
!
!     .. Parameters ..
      REAL               ONE, ZERO
      PARAMETER          ( ONE = 1.0E+0, ZERO = 0.0E+0 )
!     ..
!     .. Local Scalars ..
      REAL               RND, EPS, SFMIN, SMALL, RMACH
!     ..
!     .. External Functions ..
      LOGICAL            LSAME
      EXTERNAL           LSAME
!     ..
!     .. Intrinsic Functions ..
      INTRINSIC          DIGITS, EPSILON, HUGE, MAXEXPONENT
      INTRINSIC          MINEXPONENT, RADIX, TINY
!     ..
!     .. Executable Statements ..
!
!
!     Assume rounding, not chopping. Always.
!
      RND = ONE
!
      IF( ONE.EQ.RND ) THEN
         EPS = EPSILON(ZERO) * 0.5
      ELSE
         EPS = EPSILON(ZERO)
      END IF
!
      IF( LSAME( CMACH, 'E' ) ) THEN
         RMACH = EPS
      ELSE IF( LSAME( CMACH, 'S' ) ) THEN
         SFMIN = TINY(ZERO)
         SMALL = ONE / HUGE(ZERO)
         IF( SMALL.GE.SFMIN ) THEN
!
!           Use SMALL plus a bit, to avoid the possibility of rounding
!           causing overflow when computing  1/sfmin.
!
            SFMIN = SMALL*( ONE+EPS )
         END IF
         RMACH = SFMIN
      ELSE IF( LSAME( CMACH, 'B' ) ) THEN
         RMACH = RADIX(ZERO)
      ELSE IF( LSAME( CMACH, 'P' ) ) THEN
         RMACH = EPS * RADIX(ZERO)
      ELSE IF( LSAME( CMACH, 'N' ) ) THEN
         RMACH = DIGITS(ZERO)
      ELSE IF( LSAME( CMACH, 'R' ) ) THEN
         RMACH = RND
      ELSE IF( LSAME( CMACH, 'M' ) ) THEN
         RMACH = MINEXPONENT(ZERO)
      ELSE IF( LSAME( CMACH, 'U' ) ) THEN
         RMACH = tiny(zero)
      ELSE IF( LSAME( CMACH, 'L' ) ) THEN
         RMACH = MAXEXPONENT(ZERO)
      ELSE IF( LSAME( CMACH, 'O' ) ) THEN
         RMACH = HUGE(ZERO)
      ELSE
         RMACH = ZERO
      END IF
!
      SLAMCH = RMACH
      RETURN
!
!     End of SLAMCH
!
      END
      REAL             FUNCTION SLAMC3( A, B )
!
!  -- LAPACK auxiliary routine (version 3.4.0) --
!     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
!     November 2010
!
!     .. Scalar Arguments ..
      REAL               A, B
!     ..
! =====================================================================
!
!     .. Executable Statements ..
!
      SLAMC3 = A + B
!
      RETURN
!
!     End of SLAMC3
!
      END


! -----------------------------------------------------------------
! Programmer(s): Cody J. Balos @ LLNL
! -----------------------------------------------------------------
! Acknowledgements: Based on idaAkzoNob_ASAi_dns.c by Radu Serban
! and Cosmin Petra @ LLNL.
! -----------------------------------------------------------------
! SUNDIALS Copyright Start
! Copyright (c) 2002-2022, Lawrence Livermore National Security
! and Southern Methodist University.
! All rights reserved.
!
! See the top-level LICENSE and NOTICE files for details.
!
! SPDX-License-Identifier: BSD-3-Clause
! SUNDIALS Copyright End
! -----------------------------------------------------------------
! Adjoint sensitivity example problem
!
! This IVP is a stiff system of 6 non-linear DAEs of index 1. The
! problem originates from Akzo Nobel Central research in Arnhern,
! The Netherlands, and describes a chemical process in which 2
! species are mixed, while carbon dioxide is continuously added.
! See http://pitagora.dm.uniba.it/~testset/report/chemakzo.pdf
!
! FIDAS also computes the sensitivities with respect to initial
! conditions of the following quantity:
!   G = int_t0^t1 y1 dt
! The sensitivity of G is the solution of the adjoint system at t0.
! -----------------------------------------------------------------

module dae_mod
  use, intrinsic :: iso_c_binding
  implicit none

  ! problem parameters
  integer(c_long), parameter :: NEQ   = 6
  integer(c_long), parameter :: STEPS = 150
  real(c_double),  parameter :: T0    = 0.0d0
  real(c_double),  parameter :: TF    = 180.d0
  real(c_double),  parameter :: RTOL  = 1e-08
  real(c_double),  parameter :: ATOL  = 1e-10
  real(c_double),  parameter :: RTOLB = 1e-06
  real(c_double),  parameter :: ATOLB = 1e-08
  real(c_double),  parameter :: RTOLQ = 1e-10
  real(c_double),  parameter :: ATOLQ = 1e-12

  ! problem constants
  real(c_double) :: ZERO    = 0.0d0
  real(c_double) :: QUARTER = 0.25d0
  real(c_double) :: HALF    = 0.5d0
  real(c_double) :: ONE     = 1.0d0
  real(c_double) :: TWO     = 2.0d0
  real(c_double) :: FOUR    = 4.0d0
  real(c_double) :: EIGHT   = 8.0d0

  ! problem data
  real(c_double) :: k1, k2, k3, k4
  real(c_double) :: K, klA, Ks, pCO2, H

contains

  integer(c_int) function res(t, nv_yy, nv_yd, nv_resval, userdata) &
    result(retval) bind(C,name='res')
    use, intrinsic :: iso_c_binding
    use fsundials_nvector_mod
    implicit none

    ! function arguments
    real(c_double), value :: t
    type(N_Vector)        :: nv_yy, nv_yd, nv_resval
    type(c_ptr)           :: userdata

    ! local variables
    real(c_double)          :: y1, y2, y3, y4, y5, y6
    real(c_double)          :: yd1, yd2, yd3, yd4, yd5
    real(c_double)          :: r1, r2, r3, r4, r5, Fin
    real(c_double), pointer :: yy(:), yd(:), resval(:)

    yy     => FN_VGetArrayPointer(nv_yy)
    yd     => FN_VGetArrayPointer(nv_yd)
    resval => FN_VGetArrayPointer(nv_resval)

    y1 = yy(1)
    y2 = yy(2)
    y3 = yy(3)
    y4 = yy(4)
    y5 = yy(5)
    y6 = yy(6)

    yd1 = yd(1)
    yd2 = yd(2)
    yd3 = yd(3)
    yd4 = yd(4)
    yd5 = yd(5)

    r1  = k1 * (y1**4) * sqrt(y2)
    r2  = k2 * y3 * y4
    r3  = k2/K * y1 * y5
    r4  = k3 * y1 * y4 * y4
    r5  = k4 * y6 * y6 * sqrt(y2)
    Fin = klA * ( pCO2/H - y2 )

    resval(1) = yd1 + TWO*r1 - r2 + r3 + r4
    resval(2) = yd2 + HALF*r1 + r4 + HALF*r5 - Fin
    resval(3) = yd3 - r1 + r2 - r3
    resval(4) = yd4 + r2 - r3 + TWO*r4
    resval(5) = yd5 - r2 + r3 - r5
    resval(6) = Ks*y1*y4 - y6

    retval = 0
    return
  end function res

  integer(c_int) function rhsQ(t, nv_yy, nv_yp, nv_qdot, userdata) &
    result(retval) bind(C,name='rhsQ')
    use, intrinsic :: iso_c_binding
    use fsundials_nvector_mod
    implicit none

    ! function arguments
    real(c_double), value :: t
    type(N_Vector)        :: nv_yy, nv_yp, nv_qdot
    type(c_ptr)           :: userdata

    ! local variables
    real(c_double), pointer :: qdot(:), yy(:)

    qdot => FN_VGetArrayPointer(nv_qdot)
    yy   => FN_VGetArrayPointer(nv_yy)
    qdot(1) = yy(1)

    retval = 0
    return
  end function rhsQ

  integer(c_int) function resB(tt, nv_yy, nv_yp, nv_yyB, nv_ypB, nv_rrB, userdata) &
    result(retval) bind(C,name='resB')
    use, intrinsic :: iso_c_binding
    use fsundials_nvector_mod
    implicit none

    ! function arguments
    real(c_double), value :: tt
    type(N_Vector)        :: nv_yy, nv_yp, nv_yyB, nv_ypB, nv_rrB
    type(c_ptr)           :: userdata

    ! local variables
    real(c_double) :: y1, y2, y3, y4, y5, y6
    real(c_double) :: yB1, yB2, yB3, yB4, yB5, yB6
    real(c_double) :: ypB1, ypB2, ypB3, ypB4, ypB5
    real(c_double) :: y2tohalf, y1to3, k2overK, tmp1, tmp2
    real(c_double), pointer :: yy(:), yyB(:), ypB(:), rrb(:)

    yy  => FN_VGetArrayPointer(nv_yy)
    yyB => FN_VGetArrayPointer(nv_yyB)
    ypB => FN_VGetArrayPointer(nv_ypB)
    rrB => FN_VGetArrayPointer(nv_rrB)

    y1 = yy(1)
    y2 = yy(2)
    y3 = yy(3)
    y4 = yy(4)
    y5 = yy(5)
    y6 = yy(6)

    yB1 = yyB(1)
    yB2 = yyB(2)
    yB3 = yyB(3)
    yB4 = yyB(4)
    yB5 = yyB(5)
    yB6 = yyB(6)

    ypB1 = ypB(1)
    ypB2 = ypB(2)
    ypB3 = ypB(3)
    ypB4 = ypB(4)
    ypB5 = ypB(5)

    y2tohalf = sqrt(y2)
    y1to3 = y1*y1*y1
    k2overK = k2/K

    tmp1 = k1* y1to3 * y2tohalf
    tmp2 = k3*y4*y4
    rrB(1) = 1 +  ypB1 - (EIGHT*tmp1 + k2overK*y5 + tmp2)*yB1 &
           - (TWO*tmp1+tmp2)*yB2 + (FOUR*tmp1+k2overK*y5)*yB3 &
           + k2overK*y5*(yB4-yB5) - TWO*tmp2*yB4 + Ks*y4*yB6

    tmp1 = k1 * y1*y1to3 * (y2tohalf/y2)
    tmp2 = k4 * y6*y6 * (y2tohalf/y2)
    rrB(2) = ypB2 - tmp1*yB1 - (QUARTER*tmp1 + QUARTER*tmp2 + klA)*yB2 &
           + HALF*tmp1*yB3 + HALF*tmp2*yB5

    rrB(3) = ypB3 + k2*y4*(yB1-yB3-yB4+yB5)

    tmp1 = k3*y1*y4
    tmp2 = k2*y3
    rrB(4) = ypB4 + (tmp2-TWO*tmp1)*yB1 - TWO*tmp1*yB2 - tmp2*yB3 &
           - (tmp2+FOUR*tmp1)*yB4 + tmp2*yB5 + Ks*y1*yB6

    rrB(5) = ypB5 - k2overK*y1*(yB1-yB3-yB4+yB5)

    rrB(6) = k4*y6*y2tohalf*(2*yB5-yB2) - yB6

    retval = 0
    return
  end function resB

  subroutine PrintOutput(nv_yB, nv_ypB)
    use, intrinsic :: iso_c_binding
    use fsundials_nvector_mod
    implicit none

    ! function arguments
    type(N_Vector) :: nv_yB, nv_ypB
    real(c_double), pointer :: yB(:)

    yB => FN_VGetArrayPointer(nv_yB)

    write(*,'(1x,A,es12.4)') "dG/dy0:         ", yB(1)
    write(*,'(1x,A,es12.4)') "                ", yB(2)
    write(*,'(1x,A,es12.4)') "                ", yB(3)
    write(*,'(1x,A,es12.4)') "                ", yB(4)
    write(*,'(1x,A,es12.4)') "                ", yB(5)
    write(*,'(1x,A,es12.4)') "                ", yB(6)
    write(*,*) "--------------------------------------------------------"
    write(*,*) ""

  end subroutine

end module dae_mod

! Main program
program main
  use, intrinsic :: iso_c_binding
  use fsundials_context_mod
  use fidas_mod                  ! Fortran interface to IDA
  use fnvector_serial_mod        ! Fortran interface to serial N_Vector
  use fsunmatrix_dense_mod       ! Fortran interface to dense SUNMatrix
  use fsunlinsol_dense_mod       ! Fortran interface to dense SUNLinearSolver
  use fsundials_matrix_mod       ! Fortran interface to generic SUNMatrix
  use fsundials_nvector_mod      ! Fortran interface to generic N_Vector
  use fsundials_linearsolver_mod ! Fortran interface to generic SUNLinearSolver
  use dae_mod                    ! DAE problem module
  implicit none

  ! Local variables
  type(c_ptr)                    :: sunctx
  type(c_ptr)                    :: mem, memB
  integer(c_int)                 :: ncheck(1), retval
  real(c_double)                 :: time(1)
  integer(c_long)                :: nst(1), nstB(1)
  integer(c_int)                 :: indexB(1)
  real(c_double),        pointer :: yy(:), q(:)
  type(N_Vector),        pointer :: nv_yy, nv_yp, nv_rr, nv_q
  real(c_double),        pointer :: ypB(:)
  type(N_Vector),        pointer :: nv_yB, nv_ypB
  type(SUNMatrix),       pointer :: A, AB
  type(SUNLinearSolver), pointer :: LS, LSB

  ! Consistent IC for  y, y'.
  real(c_double) :: y01 = 0.444d0
  real(c_double) :: y02 = 0.00123d0
  real(c_double) :: y03 = 0.0d0
  real(c_double) :: y04 = 0.007d0
  real(c_double) :: y05 = 0.0d0

  write(*,*) ""
  write(*,*) "Adjoint Sensitivity Example for Akzo-Nobel Chemical Kinetics"
  write(*,*) "-------------------------------------------------------------"
  write(*,*) "Sensitivity of G = int_t0^tf (y1) dt with respect to IC."
  write(*,*) "-------------------------------------------------------------"
  write(*,*) ""

  ! Fill problem data with the appropriate values for coefficients.
  k1   = 18.7d0
  k2   = 0.58d0
  k3   = 0.09d0
  k4   = 0.42d0
  K    = 34.4d0
  klA  = 3.3d0
  Ks   = 115.83d0
  pCO2 = 0.9d0
  H    = 737.0d0

  ! Create the SUNDIALS simulation context
  retval = FSUNContext_Create(c_null_ptr, sunctx)
  call check_retval(retval, "FSUNContext_Create")

  ! Allocate N-vectors.
  nv_yy => FN_VNew_Serial(NEQ, sunctx)
  nv_yp => FN_VNew_Serial(NEQ, sunctx)

  ! Set IC
  yy    => FN_VGetArrayPointer(nv_yy)
  yy(1) = y01
  yy(2) = y02
  yy(3) = y03
  yy(4) = y04
  yy(5) = y05
  yy(6) = Ks * y01 * y04

  ! Get y' = - res(t0, y, 0)
  call FN_VConst(ZERO, nv_yp)

  nv_rr  => FN_VNew_Serial(NEQ, sunctx)
  retval = res(T0, nv_yy, nv_yp, nv_rr, c_null_ptr)
  call FN_VScale(-ONE, nv_rr, nv_yp)
  call FN_VDestroy(nv_rr)

  ! Create and initialize q0 for quadratures.
  nv_q => FN_VNew_Serial(1_8, sunctx)
  if (.not. associated(nv_q)) then
    write(*,*) 'ERROR: FN_VNew_Serial returned NULL'
    stop 1
  end if

  q    => FN_VGetArrayPointer(nv_q)
  if (.not. associated(q)) then
    write(*,*) 'ERROR: FN_VGetArrayPointer returned NULL'
    stop 1
  end if
  q(1) = ZERO

  ! Call FIDACreate and FIDAInit to initialize FIDA memory
  mem    = FIDACreate(sunctx)
  if (.not. c_associated(mem)) then
    write(*,*) 'ERROR: FIDACreate returned NULL'
    stop 1
  end if

  retval = FIDAInit(mem, c_funloc(res), T0, nv_yy, nv_yp)
  call check_retval(retval, "FIDAInit")

  ! Set tolerances.
  retval = FIDASStolerances(mem, RTOL, ATOL)
  call check_retval(retval, "FIDASStolerances")

  ! Create dense SUNMatrix for use in linear solves
  A => FSUNDenseMatrix(NEQ, NEQ, sunctx)
  if (.not. associated(A)) then
    write(*,*) 'ERROR: FSUNDenseMatrix returned NULL'
    stop 1
  end if

  ! Create dense SUNLinearSolver object
  LS => FSUNLinSol_Dense(nv_yy, A, sunctx)
  if (.not. associated(LS)) then
    write(*,*) 'ERROR: FSUNLinSol_Dense returned NULL'
    stop 1
  end if

  ! Attach the matrix and linear solver
  retval = FIDASetLinearSolver(mem, LS, A)
  call check_retval(retval, "FIDASetLinearSolver")

  ! Initialize QUADRATURE(S).
  retval = FIDAQuadInit(mem, c_funloc(rhsQ), nv_q)
  call check_retval(retval, "FIDAQuadInit")

  ! Set tolerances and error control for quadratures.
  retval = FIDAQuadSStolerances(mem, RTOLQ, ATOLQ)
  call check_retval(retval, "FIDAQuadSStolerances")

  retval = FIDASetQuadErrCon(mem, 1)
  call check_retval(retval, "FIDASetQuadErrCon")

  ! Prepare ADJOINT.
  retval = FIDAAdjInit(mem, STEPS, IDA_HERMITE)
  call check_retval(retval, "FIDAAdjInit")

  ! FORWARD run.
  write(*,'(1x,A)',advance='no') "Forward integration ... "
  retval = FIDASolveF(mem, TF, time, nv_yy, nv_yp, IDA_NORMAL, ncheck)
  call check_retval(retval, "FIDASolveF")
  retval = FIDAGetNumSteps(mem, nst)
  write(*,'(A,i6,A)') "done ( nst = ", nst, " )"
  retval = FIDAGetQuad(mem, time, nv_q)

  write(*,'(1x,A,F24.16)') "G:          ", q(1)
  write(*,*) "--------------------------------------------------------"
  write(*,*) ""

  ! BACKWARD run

  ! Initialize yB
  nv_yB => FN_VNew_Serial(NEQ, sunctx)
  if (.not. associated(nv_yB)) then
    write(*,*) 'ERROR: FN_VNew_Serial returned NULL'
    stop 1
  end if
  call FN_VConst(ZERO, nv_yB)

  nv_ypB => FN_VNew_Serial(NEQ, sunctx)
  if (.not. associated(nv_ypB)) then
    write(*,*) 'ERROR: FN_VNew_Serial returned NULL'
    stop 1
  end if
  call FN_VConst(ZERO, nv_ypB)
  ypB    => FN_VGetArrayPointer(nv_ypB)
  ypB(1) = -ONE

  retval = FIDACreateB(mem, indexB)
  call check_retval(retval, "FIDACreateB")

  retval = FIDAInitB(mem, indexB(1), c_funloc(resB), TF, nv_yB, nv_ypB)
  call check_retval(retval, "FIDAInitB")

  retval = FIDASStolerancesB(mem, indexB(1), RTOLB, ATOLB)
  call check_retval(retval, "FIDASStolerancesB")

  retval = FIDASetMaxNumStepsB(mem, indexB(1), 1000_8)
  call check_retval(retval, "FIDASetMaxNumStepsB")

  ! Create dense SUNMatrix for use in linear solves
  AB => FSUNDenseMatrix(NEQ, NEQ, sunctx)
  if (.not. associated(AB)) then
    write(*,*) 'ERROR: FSUNDenseMatrix returned NULL'
    stop 1
  end if

  ! Create dense SUNLinearSolver object
  LSB => FSUNLinSol_Dense(nv_yB, AB, sunctx)
  if (.not. associated(LSB)) then
    write(*,*) 'ERROR: FSUNLinSol_Dense returned NULL'
    stop 1
  end if

  ! Attach the matrix and linear solver
  retval = FIDASetLinearSolverB(mem, indexB(1), LSB, AB)
  call check_retval(retval, "FIDASetLinearSolverB")

  ! Do the backward integration
  write(*,'(1x,A)',advance='no') "Backward integration ... "
  retval = FIDASolveB(mem, T0, IDA_NORMAL)
  call check_retval(retval, "FIDASolveB")
  memB   = FIDAGetAdjIDABmem(mem, indexB(1))
  retval = FIDAGetNumSteps(memB, nstB)
  write(*,'(A,i6,A)') "done ( nst = ", nstB, " )"
  retval = FIDAGetB(mem, indexB(1), time, nv_yB, nv_ypB)

  ! Print the solution
  call PrintOutput(nv_yB, nv_ypB)

  ! Free memory
  call FIDAFree(mem)
  retval = FSUNLinSolFree(LS)
  retval = FSUNLinSolFree(LSB)
  call FSUNMatDestroy(A)
  call FSUNMatDestroy(AB)
  call FN_VDestroy(nv_yy)
  call FN_VDestroy(nv_yp)
  call FN_VDestroy(nv_yB)
  call FN_VDestroy(nv_ypB)
  call FN_VDestroy(nv_q)
  retval = FSUNContext_Free(sunctx)

end program

subroutine check_retval(retval, name)
  use, intrinsic :: iso_c_binding

  character(len=*) :: name
  integer(c_int)   :: retval

  if (retval /= 0) then
    write(*,'(A,A,A)') 'ERROR: ', name,' returned nonzero'
    stop 1
  end if
end subroutine


module ttaux_lib
 use tt_lib
 implicit none
 double precision,parameter,private :: tpi=6.28318530717958647692528676655900577d0

 interface ones
  module procedure dtt_ones, ztt_ones
 end interface
 interface zeros
  module procedure dtt_zeros, ztt_zeros
 end interface
 interface unit
  module procedure dtt_unit_i,dtt_unit_ii,dtt_unit_d,dtt_unit_d1
  module procedure ztt_unit_i,ztt_unit_ii,ztt_unit_d,ztt_unit_d1
 end interface
 interface rnd
  module procedure dtt_rnd, ztt_rnd, ttind_rnd
 end interface
 interface random ! ttamen compatibility, dammit
  module procedure dtt_rnd, ztt_rnd
 end interface
 interface mirror
  module procedure dtt_mirror, ztt_mirror
 end interface
 interface reverse
  module procedure dtt_rev, ztt_rev, ttind_rev
 end interface
 interface double
  module procedure dtt_double, ztt_double
 end interface
 interface push
  module procedure dtt_push
 end interface

contains

! ONES ZEROS
 subroutine dtt_ones(arg)
 ![tt] array of ones
  implicit none
  type(dtt),intent(inout) :: arg
  character(len=*),parameter :: subnam='dtt_ones'
  integer :: l,m,k
  l=arg%l;m=arg%m
  if(m.lt.l)return
  if(.not.all(arg%n(l:m)>0))then;write(*,*)subnam,': n: ',arg%n(l:m);stop;endif
  arg%r(l-1:m)=1
  call alloc(arg)
  do k=l,m; arg%u(k)%p=1.d0; end do
 end subroutine
 subroutine ztt_ones(arg)
 ![tt] array of ones
  implicit none
  type(ztt),intent(inout) :: arg
  character(len=*),parameter :: subnam='ztt_ones'
  integer :: l,m,k
  l=arg%l;m=arg%m
  if(m.lt.l)return
  if(.not.all(arg%n(l:m)>0))then;write(*,*)subnam,': n: ',arg%n(l:m);stop;endif
  arg%r(l-1:m)=1
  call alloc(arg)
  do k=l,m; arg%u(k)%p=(1.d0,0.d0); end do
 end subroutine

 subroutine dtt_zeros(arg)
 ![tt] array of zeros
  implicit none
  type(dtt),intent(inout) :: arg
  character(len=*),parameter :: subnam='dtt_zeros'
  integer :: l,m,k
  l=arg%l;m=arg%m
  if(m.lt.l)return
  if(.not.all(arg%n(l:m)>0))then;write(*,*)subnam,': n: ',arg%n(l:m);stop;endif
  arg%r(l-1:m)=1
  call alloc(arg)
  do k=l,m; arg%u(k)%p=0.d0; end do
 end subroutine
 subroutine ztt_zeros(arg)
 ![tt] array of zeros
  implicit none
  type(ztt),intent(inout) :: arg
  character(len=*),parameter :: subnam='ztt_zeros'
  integer :: l,m,k
  l=arg%l;m=arg%m
  if(m.lt.l)return
  if(.not.all(arg%n(l:m)>0))then;write(*,*)subnam,': n: ',arg%n(l:m);stop;endif
  arg%r(l-1:m)=1
  call alloc(arg)
  do k=l,m; arg%u(k)%p=(0.d0,0.d0); end do
 end subroutine

! UNIT
 subroutine dtt_unit_i(arg,i)
  ! unit element in position given by 1 <= i <= 2^d
  implicit none
  type(dtt),intent(inout) :: arg
  integer :: i
  character(len=*),parameter :: subnam='dtt_unit_i'
  integer :: l,m,k,ind(tt_size)
  l=arg%l;m=arg%m
  if(m.lt.l)then;write(*,*)subnam,': set arg%l and arg%m before calling'; return; endif
  if(.not.all(arg%n(l:m)>0))then;write(*,*)subnam,': n: ',arg%n(l:m);stop;endif
  call mindex(i,arg%n(l:m),ind(1:m-l+1))
  call dtt_unit_ii(arg,ind)
 end subroutine
 subroutine ztt_unit_i(arg,i)
  implicit none
  type(ztt),intent(inout) :: arg
  integer :: i
  character(len=*),parameter :: subnam='ztt_unit_i'
  integer :: l,m,k,ind(tt_size)
  l=arg%l;m=arg%m
  if(m.lt.l)then;write(*,*)subnam,': set arg%l and arg%m before calling'; return; endif
  if(.not.all(arg%n(l:m)>0))then;write(*,*)subnam,': n: ',arg%n(l:m);stop;endif
  call mindex(i,arg%n(l:m),ind(1:m-l+1))
  call ztt_unit_ii(arg,ind)
 end subroutine

 subroutine dtt_unit_ii(arg,ind)
  ! unit element in position given by ind(1:m-l+1)
  implicit none
  type(dtt),intent(inout) :: arg
  integer :: ind(:)
  character(len=*),parameter :: subnam='dtt_unit_ii'
  integer :: l,m,k
  l=arg%l;m=arg%m
  if(m.lt.l)then;write(*,*)subnam,': set arg%l and arg%m before calling'; return; endif
  if(.not.all(arg%n(l:m)>0))then;write(*,*)subnam,': n: ',arg%n(l:m);stop;endif
  if(any(ind(1:m-l+1)<=0).or.any(ind(1:m-l+1)>arg%n(l:m)))then;write(*,*)subnam,': wrong index: ',ind;stop;endif
  arg%r(l-1:m)=1; call alloc(arg)
  do k=l,m; arg%u(k)%p=0.d0; arg%u(k)%p(1,ind(k-l+1),1)=1.d0; end do
 end subroutine
 subroutine ztt_unit_ii(arg,ind)
  implicit none
  type(ztt),intent(inout) :: arg
  integer :: ind(:)
  character(len=*),parameter :: subnam='ztt_unit_ii'
  integer :: l,m,k
  l=arg%l;m=arg%m
  if(m.lt.l)then;write(*,*)subnam,': set arg%l and arg%m before calling'; return; endif
  if(.not.all(arg%n(l:m)>0))then;write(*,*)subnam,': n: ',arg%n(l:m);stop;endif
  if(any(ind(1:m-l+1)<=0).or.any(ind(1:m-l+1)>arg%n(l:m)))then;write(*,*)subnam,': wrong index: ',ind;stop;endif
  arg%r(l-1:m)=1; call alloc(arg)
  do k=l,m; arg%u(k)%p=(0.d0,0.d0); arg%u(k)%p(1,ind(k-l+1),1)=(1.d0,0.d0); end do
 end subroutine

 subroutine dtt_unit_d(arg,x)
  implicit none
  type(dtt),intent(inout) :: arg
  double precision,intent(in) :: x
  double precision :: xx(1)
  xx=x; call dtt_unit_d1(arg,xx)
 end subroutine
 subroutine ztt_unit_d(arg,x)
  implicit none
  type(ztt),intent(inout) :: arg
  double precision,intent(in) :: x
  double precision :: xx(1)
  xx=x; call ztt_unit_d1(arg,xx)
 end subroutine

 subroutine dtt_unit_d1(arg,x)
  implicit none
  type(dtt),intent(inout) :: arg
  double precision,intent(in) :: x(:)
  character(len=*),parameter :: subnam='dtt_unit_d1'
  integer :: l,m,r(0:tt_size),n(tt_size), id,dd,i,j,k,pos,mm,ind(tt_size)=0
  double precision :: xx
  l=arg%l; m=arg%m; r=arg%r; n=arg%n; dd=size(x)
  if(m.lt.l)then;write(*,*)subnam,': set arg%l and arg%m before calling'; return; endif
  if(.not.all(arg%n(l:m)>0))then;write(*,*)subnam,': n: ',arg%n(l:m);stop;endif
  if(l.gt.m)return
  arg%r(l-1:m)=1; call alloc(arg)
  mm=(m-l+1)/dd
  do id=1,dd
   xx=x(id)
   if(xx.lt.0.d0)return
   if(xx.gt.1.d0)xx=xx-int(xx)
   do j=1,mm
    pos=l+(id-1)*mm+mm-j
    i=int(n(pos)*xx)
    if(i.eq.n(pos))i=n(pos)-1
    ind(pos-l+1)=i+1
    xx=xx*n(pos)-i
   end do
  end do
  do k=l,m; arg%u(k)%p=0.d0; arg%u(k)%p(1,ind(k-l+1),1)=1.d0; end do
 end subroutine
 subroutine ztt_unit_d1(arg,x)
  implicit none
  type(ztt),intent(inout) :: arg
  double precision,intent(in) :: x(:)
  character(len=*),parameter :: subnam='ztt_unit_d1'
  integer :: l,m,r(0:tt_size),n(tt_size), id,dd,i,j,k,pos,mm,ind(tt_size)=0
  double precision :: xx
  l=arg%l; m=arg%m; r=arg%r; n=arg%n; dd=size(x)
  if(m.lt.l)then;write(*,*)subnam,': set arg%l and arg%m before calling'; return; endif
  if(.not.all(arg%n(l:m)>0))then;write(*,*)subnam,': n: ',arg%n(l:m);stop;endif
  if(l.gt.m)return
  arg%r(l-1:m)=1; call alloc(arg)
  mm=(m-l+1)/dd
  do id=1,dd
   xx=x(id)
   if(xx.lt.0.d0)return
   if(xx.gt.1.d0)xx=xx-int(xx)
   do j=1,mm
    pos=l+(id-1)*mm+mm-j
    i=int(n(pos)*xx)
    if(i.eq.n(pos))i=n(pos)-1
    ind(pos-l+1)=i+1
    xx=xx*n(pos)-i
   end do
  end do
  do k=l,m; arg%u(k)%p=(0.d0,0.d0); arg%u(k)%p(1,ind(k-l+1),1)=(1.d0,0.d0); end do
 end subroutine

! RND
 subroutine dtt_rnd(arg)
  ![tt] random array with prescribed sizes and ranks
  use rnd_lib
  implicit none
  type(dtt),intent(inout) :: arg
  character(len=*),parameter :: subnam='dtt_rnd'
  integer :: l,m,k
  l=arg%l;m=arg%m
  if(m.lt.l)return
  if(.not.all(arg%n(l:m)>0))then;write(*,*)subnam,': n: ',arg%n(l:m);stop;endif
  if(.not.all(arg%r(l-1:m)>0))then;write(*,*)subnam,': r: ',arg%r(l-1:m);stop;endif
  call alloc(arg)
  do k=l,m
   call random(arg%u(k)%p)
  end do
 end subroutine
 subroutine ztt_rnd(arg)
  ![tt] random array with prescribed sizes and ranks
  use rnd_lib
  implicit none
  type(ztt),intent(inout) :: arg
  character(len=*),parameter :: subnam='ztt_rnd'
  integer :: l,m,k
  l=arg%l;m=arg%m
  if(m.lt.l)return
  if(.not.all(arg%n(l:m)>0))then;write(*,*)subnam,': n: ',arg%n(l:m);stop;endif
  if(.not.all(arg%r(l-1:m)>0))then;write(*,*)subnam,': r: ',arg%r(l-1:m);stop;endif
  call alloc(arg)
  do k=l,m
   call random(arg%u(k)%p)
  end do
 end subroutine
 subroutine ttind_rnd(arg)
  use rnd_lib
  implicit none
  type(ttind),intent(inout) :: arg
  character(len=*),parameter :: subnam='ttind_rnd'
  integer :: l,m,k
  l=1;m=arg%m
  if(m.lt.l)return
  if(.not.all(arg%n(l:m)>0))then;write(*,*)subnam,': n: ',arg%n(l:m);stop;endif
  do k=l,m
   arg%p(k)=irnd(arg%n(k))
  end do
 end subroutine

 subroutine dtt_sin(arg,alpha,beta)
  ![bitt] sine function
  implicit none
  type(dtt),intent(inout) :: arg
  double precision,intent(in),optional :: alpha,beta
  double precision :: alp,bet
  if(present(alpha))then;alp=alpha;else;alp=1.d0;endif
  if(present(beta))then;bet=beta;else;bet=0.d0;endif
  call dtt_cos(arg,alp,bet-tpi/4)
 end subroutine
 subroutine dtt_cos(arg,alpha,beta)
  ![bitt] cosine function
  implicit none
  type(dtt),intent(inout) :: arg
  double precision,intent(in),optional :: alpha,beta
  double precision :: alp,bet,ca,sa
  integer :: r,k,l,m
  if(present(alpha))then;alp=alpha;else;alp=1.d0;endif
  if(present(beta))then;bet=beta;else;bet=0.d0;endif
  m=arg%m; l=arg%l
  arg%n(l:m)=2;  arg%r(l-1)=1;arg%r(l:m-1)=2;arg%r(m)=1;
  call alloc(arg)
  arg%u(l)%p(1,:,:)=reshape( (/dcos(bet), dcos(alp+bet), -dsin(bet), -dsin(alp+bet) /), [2,2] )
  do k=l+1,m-1
   alp=alp*2; ca=dcos(alp); sa=dsin(alp)
   arg%u(k)%p=reshape( (/1.d0, 0.d0, ca, sa, 0.d0, 1.d0, -sa, ca /), [2,2,2] )
  end do
  alp=alp*2
  arg%u(m)%p(:,:,1)=reshape( (/1.d0, 0.d0, dcos(alp), dsin(alp) /), [2,2])
 end subroutine
 subroutine dtt_cossin(arg,alpha,beta)
  ![bitt] cosine and sine function, r(d)=2
  implicit none
  type(dtt),intent(inout) :: arg
  double precision,intent(in),optional :: alpha,beta
  double precision :: alp,bet,ca,sa
  integer :: r,k,l,m
  if(present(alpha))then;alp=alpha;else;alp=1.d0;endif
  if(present(beta))then;bet=beta;else;bet=0.d0;endif
  m=arg%m; l=arg%l
  arg%n(l:m)=2;  arg%r(l-1)=1;arg%r(l:m)=2
  call alloc(arg)
  arg%u(l)%p(1,:,:)=reshape( (/dcos(bet), dcos(alp+bet), -dsin(bet), -dsin(alp+bet) /), [2,2] )
  do k=l+1,m
   alp=alp*2; ca=dcos(alp); sa=dsin(alp)
   arg%u(k)%p=reshape( (/1.d0, 0.d0, ca, sa, 0.d0, 1.d0, -sa, ca /), [2,2,2] )
  end do
  arg%u(m)%p(:,:,2)=-arg%u(m)%p(:,:,2)
 end subroutine

! MIRROR
 subroutine dtt_mirror(arg,part)
  implicit none
  type(dtt),intent(inout) :: arg
  integer,intent(in),optional :: part(2)
  integer :: l,m,p,i,j,k,r(0:tt_size),n(tt_size)
  l=arg%l;m=arg%m;r=arg%r;n=arg%n
  if(present(part))then;l=part(1);m=part(2);endif
  do p=l,m
   forall(i=1:r(p-1),j=1:n(p)/2,k=1:r(p))
    ! swap arg%u(p)%p(i,j,k) <-> arg%u(p)%p(i,n(p)-j+1,k)
    arg%u(p)%p(i,j,k)=arg%u(p)%p(i,j,k)+arg%u(p)%p(i,n(p)-j+1,k)
    arg%u(p)%p(i,n(p)-j+1,k)=arg%u(p)%p(i,j,k)-arg%u(p)%p(i,n(p)-j+1,k)
    arg%u(p)%p(i,j,k)=arg%u(p)%p(i,j,k)-arg%u(p)%p(i,n(p)-j+1,k)
   end forall
  end do
 end subroutine
 subroutine ztt_mirror(arg,part)
  implicit none
  type(ztt),intent(inout) :: arg
  integer,intent(in),optional :: part(2)
  integer :: l,m,p,i,j,k,r(0:tt_size),n(tt_size)
  l=arg%l;m=arg%m;r=arg%r;n=arg%n
  if(present(part))then;l=part(1);m=part(2);endif
  do p=l,m
   forall(i=1:r(p-1),j=1:n(p)/2,k=1:r(p))
    ! swap arg%u(p)%p(i,j,k) <-> arg%u(p)%p(i,n(p)-j+1,k)
    arg%u(p)%p(i,j,k)=arg%u(p)%p(i,j,k)+arg%u(p)%p(i,n(p)-j+1,k)
    arg%u(p)%p(i,n(p)-j+1,k)=arg%u(p)%p(i,j,k)-arg%u(p)%p(i,n(p)-j+1,k)
    arg%u(p)%p(i,j,k)=arg%u(p)%p(i,j,k)-arg%u(p)%p(i,n(p)-j+1,k)
   end forall
  end do
 end subroutine

! REVERSE
 subroutine dtt_rev(arg)
  implicit none
  type(dtt),intent(inout) :: arg
  type(dtt) :: tmp
  integer :: l,m,k
  l=arg%l;m=arg%m
  if(l.gt.m)return
  tmp%l=l;tmp%m=m
  forall(k=l-1:m)tmp%r(k)=arg%r(m-k+l-1)
  forall(k=l:m)tmp%n(k)=arg%n(m-k+l)
  call alloc(tmp)
  do k=l,m; call trans(4,arg%u(k)%p,tmp%u(m-k+l)%p); end do
  arg=tmp
  call dealloc(tmp)
 end subroutine
 subroutine ztt_rev(arg)
  implicit none
  type(ztt),intent(inout) :: arg
  type(ztt) :: tmp
  integer :: l,m,k
  l=arg%l;m=arg%m
  if(l.gt.m)return
  tmp%l=l;tmp%m=m
  forall(k=l-1:m)tmp%r(k)=arg%r(m-k+l-1)
  forall(k=l:m)tmp%n(k)=arg%n(m-k+l)
  call alloc(tmp)
  do k=l,m; call trans(4,arg%u(k)%p,tmp%u(m-k+l)%p); end do
  arg=tmp
  call dealloc(tmp)
 end subroutine
 subroutine ttind_rev(arg)
  implicit none
  type(ttind),intent(inout) :: arg
  integer :: m,k,q
  m=arg%m
  if(m.le.0)return
  do k=1,m/2
   q=m-k+1
   arg%n(k)=arg%n(k)+arg%n(q); arg%n(q)=arg%n(k)-arg%n(q); arg%n(k)=arg%n(k)-arg%n(q)
   arg%p(k)=arg%p(k)+arg%p(q); arg%p(q)=arg%p(k)-arg%p(q); arg%p(k)=arg%p(k)-arg%p(q)
  end do
 end subroutine

! DOUBLE
 subroutine dtt_double(arg)
  implicit none
  ! a -> [a a]
  type(dtt),intent(inout) :: arg
  character(len=*),parameter :: subnam='dtt_double'
  integer :: l,m,r,i,j,k,info
  l=arg%l; m=arg%m; r=arg%r(m)
  if(associated(arg%u(m+1)%p))then
   !write(*,*)subnam,': next core is already allocated'
   deallocate(arg%u(m+1)%p)
  end if
  allocate(arg%u(m+1)%p(r,2,r),stat=info)
  if(info.ne.0)then;write(*,*)subnam,': allocation fail';stop;endif
  forall(i=1:r,j=1:2,k=1:r)arg%u(m+1)%p(i,j,k)=0.d0
  forall(i=1:r,j=1:2      )arg%u(m+1)%p(i,j,i)=1.d0
  arg%m=m+1; arg%n(m+1)=2; arg%r(m+1)=r
 end subroutine
 subroutine ztt_double(arg)
  implicit none
  ! a -> [a a]
  type(ztt),intent(inout) :: arg
  character(len=*),parameter :: subnam='ztt_double'
  integer :: l,m,r,i,j,k,info
  l=arg%l; m=arg%m; r=arg%r(m)
  if(associated(arg%u(m+1)%p))then
   !write(*,*)subnam,': next core is already allocated'
   deallocate(arg%u(m+1)%p)
  end if
  allocate(arg%u(m+1)%p(r,2,r),stat=info)
  if(info.ne.0)then;write(*,*)subnam,': allocation fail';stop;endif
  forall(i=1:r,j=1:2,k=1:r)arg%u(m+1)%p(i,j,k)=(0.d0,0.d0)
  forall(i=1:r,j=1:2      )arg%u(m+1)%p(i,j,i)=(1.d0,0.d0)
  arg%m=m+1; arg%n(m+1)=2; arg%r(m+1)=r
 end subroutine

! AP
 subroutine dtt_ap(arg,alpha,beta)
  ![bitt] arythmetic progression
  implicit none
  type (dtt),intent(inout) :: arg
  double precision,intent(in),optional :: alpha,beta
  character(len=*),parameter :: subnam ='dtt_ap'
  double precision :: alp,bet
  integer :: l,m,k
  alp=1.d0;if(present(alpha))alp=alpha
  bet=0.d0;if(present(beta))bet=beta
  l=arg%l;m=arg%m
  if(m.lt.l)return
  arg%r(l-1)=1;arg%r(l:m-1)=2;arg%r(m)=1;arg%n(l:m)=2
  call alloc(arg)
  arg%u(l)%p=reshape( (/2.d0,2.d0,bet,alp+bet/) ,[1,2,2])
  do k=l+1,m-1
   arg%u(k)%p=reshape( (/2.d0,0.d0,2.d0,0.d0,0.d0,1.d0,alp,1.d0/) ,[2,2,2])
  end do
  arg%u(m)%p=reshape( (/0.d0,1.d0,alp,1.d0/) ,[2,2,1])
 end subroutine

 subroutine dtt_push(arg,dir,new)
  implicit none
  type(dtt),intent(inout),target :: arg
  character(len=1),intent(in),optional :: dir
  double precision,intent(in),optional :: new
  character(len=*),parameter :: subnam='dtt_push'
  type(dtt) :: tmp
  double precision :: val
  integer :: l,m,k,p,i,j,d,info,ind(tt_size)
  integer,pointer :: r(:),n(:)
  double precision,allocatable :: x(:),y(:)
  tmp%l=arg%l; tmp%m=arg%m; l=arg%l; m=arg%m; if(l.gt.m)return
  if(arg%r(l-1).ne.1)then;write(*,*)subnam,': left border rank should be 1';stop;endif
  if(arg%r(m).ne.1)then;write(*,*)subnam,': right border rank should be 1';stop;endif
  !if(.not.all(arg%n(l:m)==2))then;write(*,*)subnam,': not bitt on input';stop;endif
  d=+1
  if(present(dir))then
   select case(dir)
    case('r','R');d=+1
    case('l','L');d=-1
    case default;write(*,*)subnam,': illegal dir: ',dir;stop
   end select
  end if
  if(present(new))then
   val=new
  else
   select case(d)
    case(+1);ind(l:m)=arg%n(l:m);val=tijk(arg,ind(l:m))
    case(-1);ind(l:m)=1;val=tijk(arg,ind(l:m))
    case default;write(*,*)subnam,': illegal d:',d;stop
   end select
  end if
  r=>arg%r; n=>arg%n
  tmp%r(l:m-1)=r(l:m-1)+1;tmp%r(l-1)=r(l-1);tmp%r(m)=r(m);tmp%n(l:m)=n(l:m)
  call alloc(tmp)
  allocate(x(maxval(r(l-1:m))),y(maxval(r(l-1:m))*maxval(n(l:m))),stat=info)
  if(info.ne.0)then;write(*,*)subnam,': cannot allocate';stop;endif

  forall(i=1:r(l-1),j=1:n(l),k=1:r(l)+1)tmp%u(l)%p(i,j,k)=0.d0
  do p=l+1,m
   forall(i=1:r(p-1),j=1:n(p),k=1:r(p))tmp%u(p)%p(i,j,k)=arg%u(p)%p(i,j,k)
  end do
  do p=l+1,m-1
   forall(           j=1:n(p),k=1:r(p))tmp%u(p)%p(r(p-1)+1,j,k)=0.d0
   forall(i=1:r(p-1),j=1:n(p)         )tmp%u(p)%p(i,j,r(p)+1)=0.d0
   forall(           j=1:n(p)         )tmp%u(p)%p(r(p-1)+1,j,r(p)+1)=0.d0
  end do

  select case(d)
   case(+1)
    forall(i=1:r(l-1),j=2:n(l),k=1:r(l))tmp%u(l)%p(i,j,k)=arg%u(l)%p(i,j-1,k)
    x(1:r(l))=arg%u(l)%p(1,n(l),:)
    tmp%u(l)%p(1,1,r(l)+1)=1.d0
    do p=l+1,m-1;tmp%u(p)%p(r(p-1)+1,1,r(p)+1)=1.d0;enddo
    tmp%u(m)%p(r(m-1)+1,1,r(m))=val
    do p=l+1,m
     call dgemv('t',r(p-1),n(p)*r(p),1.d0,arg%u(p)%p,r(p-1),x,1,0.d0,y,1)
     forall(j=1:n(p)-1,k=1:r(p))tmp%u(p)%p(r(p-1)+1,j+1,k)=y(j+(k-1)*n(p))
     forall(k=1:r(p))x(k)=y(k*n(p))
    end do
   case(-1)
    forall(i=1:r(l-1),j=1:n(l)-1,k=1:r(l))tmp%u(l)%p(i,j,k)=arg%u(l)%p(i,j+1,k)
    x(1:r(l))=arg%u(l)%p(1,1,:)
    tmp%u(l)%p(1,n(l),r(l)+1)=1.d0
    do p=l+1,m-1;tmp%u(p)%p(r(p-1)+1,n(p),r(p)+1)=1.d0;enddo
    tmp%u(m)%p(r(m-1)+1,n(m),r(m))=val
    do p=l+1,m
     call dgemv('t',r(p-1),n(p)*r(p),1.d0,arg%u(p)%p,r(p-1),x,1,0.d0,y,1)
     forall(j=2:n(p),k=1:r(p))tmp%u(p)%p(r(p-1)+1,j-1,k)=y(j+(k-1)*n(p))
     forall(k=1:r(p))x(k)=y(1+(k-1)*n(p))
    end do
   case default
    write(*,*)subnam,': illegal d: ',d
    stop
  end select
  arg=tmp;call dealloc(tmp)
  deallocate(x,y)
 end subroutine

 subroutine dtt_goup(arg)
  ![bitt] add leading bit by linear interpolation
  implicit none
  type(dtt),intent(inout),target :: arg
  character(len=*),parameter :: subnam='dtt_goup'
  type(dtt) :: tmp
  integer :: k,l,m,i,j,p,info
  integer,pointer :: r(:),n(:)
  double precision,allocatable :: x(:),y(:)
  tmp%l=arg%l; tmp%m=arg%m+1; l=arg%l; m=arg%m
  if(l.gt.m)return
  if(arg%r(l-1).ne.1)then;write(*,*)subnam,': left border rank should be 1';stop;endif
  if(.not.all(arg%n(l:m)==2))then;write(*,*)subnam,': not bitt on input';stop;endif
  r=>arg%r; n=>arg%n
  tmp%r(l-1)=1;tmp%r(l:m)=arg%r(l-1:m-1)+1;tmp%r(m+1)=arg%r(m); tmp%n(l:m+1)=2
  call alloc(tmp)

  allocate(x(maxval(r(l-1:m-1))),y(maxval(r(l-1:m-1))),stat=info)
  if(info.ne.0)then;write(*,*)subnam,': cannot allocate: ',info;stop;endif

  tmp%u(l)%p=reshape( (/1.d0, 0.5d0, 0.d0, 0.5d0/), [1,2,2])

  tmp%u(l+1)%p(1,1,1:r(l))=arg%u(l)%p(1,1,:); tmp%u(l+1)%p(1,1,1+r(l))=0.d0
  tmp%u(l+1)%p(2,1,1:r(l))=arg%u(l)%p(1,2,:); tmp%u(l+1)%p(2,1,1+r(l))=0.d0
  tmp%u(l+1)%p(1,2,1:r(l))=arg%u(l)%p(1,2,:); tmp%u(l+1)%p(1,2,1+r(l))=0.d0
  tmp%u(l+1)%p(2,2,1:r(l))=0.d0;              tmp%u(l+1)%p(2,2,1+r(l))=1.d0
  x(1:r(l))=arg%u(l)%p(1,1,:)

  do k=l+1,m
   forall(i=1:r(k-1),p=1:2,j=1:r(k)) tmp%u(k+1)%p(i,p,j)=arg%u(k)%p(i,p,j)
   call dgemv('t',r(k-1),r(k),1.d0,arg%u(k)%p(1,2,1),r(k-1)*2,x,1,0.d0,y,1)
   tmp%u(k+1)%p(1+r(k-1),1,1:r(k))=y(1:r(k))
   tmp%u(k+1)%p(1+r(k-1),2,1:r(k))=0.d0
   if(k.lt.m)then
    forall(i=1:r(k-1),p=1:2) tmp%u(k+1)%p(i,p,r(k)+1)=0.d0
    tmp%u(k+1)%p(1+r(k-1),1,  r(k)+1)=0.d0
    tmp%u(k+1)%p(1+r(k-1),2,  r(k)+1)=1.d0
    call dgemv('t',r(k-1),r(k),1.d0,arg%u(k)%p,r(k-1)*2,x,1,0.d0,y,1)
    x(1:r(k))=y(1:r(k))
   end if
  end do
  arg=tmp
  call dealloc(tmp)
  deallocate(x,y)
 end subroutine

end module


      subroutine es_ini
c
      include 'bgdata.inc'
c
c *** Create tables of the saturation vapor pressure (mb) with up to
c        two decimal figures of accuraccy:
c
      do it=15000,45000
         t=it*0.01
         p1 = 11.344-0.0303998*t
         p2 = 3.49149-1302.8844/t
         c1 = 23.832241-5.02808*alog10(t)
         esat(it) = 10.**(c1-1.3816E-7*10.**p1+
     .               8.1328E-3*10.**p2-2949.076/t)
         es(it) = 610.78*exp(17.269*(t-273.16)/(t-35.86))
      enddo
c
      return
      end


      subroutine runY_0000lll(k,l,Xtwiddle,Gtwiddle,Shat7zz,N0)
      implicit none
C---  Expression for extension of Eq. 5.60a
C---  Calculates D00llll
C---  Small terms of order Xtwiddle(0,k)*Diiiii,Xtwiddle(0,0)*Diiiiii
C---  Denominator Gtwiddle(k,l)
      include 'pvDnames.f'
      include 'pvDv.f'
      include 'Darraydef.f'
      include 'Darrays.f'
      integer ep,N0,k,l,np
      parameter(np=3)
      double precision Xtwiddle(0:np,0:np),Gtwiddle(np,np)
      double complex Shat7zz(np,z4max,-2:0)

      do ep=-2,0
      Dv(dzzzziii(z3(l,l,l))+N0,ep)=
     . (Gtwiddle(k,1)*Shat7zz(1,z4(l,l,l,l),ep)
     . +Gtwiddle(k,2)*Shat7zz(2,z4(l,l,l,l),ep)
     . +Gtwiddle(k,3)*Shat7zz(3,z4(l,l,l,l),ep)
     . +Xtwiddle(k,0)*Dv(dzziiii(z4(l,l,l,l))+N0,ep)
     . -Xtwiddle(0,0)*Dv(dzziiiii(z5(k,l,l,l,l))+N0,ep))
     . /(8d0*Gtwiddle(k,l))
      enddo

      return
      end


SUBROUTINE nmnim(k)
!
IMPLICIT NONE
!
INCLUDE 'p1werm.inc'
INCLUDE 'chumus.inc'
INCLUDE 'cfert.inc'
INCLUDE 'csoil.inc'
!
! Subroutine arguments
!
INTEGER :: k
!
! Local variables
!
REAL :: amin1
REAL :: ca,cnr,cnrf,cpr,cprf,cs,decr,hmp,r4,rdc,rm2,rmn,rmp,rwn,tkg,xx
!
!     + + + purpose + + +
!     this subroutine estimates daily n and p mineralization and immobilization
!     considering fresh organic material (crop residue) and active and stable
!     humus material. goto statements in the original code were replaced by if-
!     then-else statements as required by wepp coding convention.
!
!     + + + keywords + + +
!     mineralization
!
!     + + + common blocks + + +

! local includes
!     include 'cenvr.inc'

!     + + + local variables + + +

!
!     + + + end of specifications + + +
!
!     convert residue to kg/ha.
cmn = 0.0003
tkg = rsd(k)*1000.
!     calculate parts of eq. 2.153
cs = sqrt(cdg*sut)
!     this section of code calculates amount of n&p mineralized from humus.
!     calculate n that becomes part of the stable n pool using eq. 2.159.
!     this eq. is not the same as in the manual--->(-1.0) added.
rwn = .1E-4*(wmn(k)*(1./rtn(k)-1.)-wn(k))
!     add rwn to the stable organic n pool (wn(k)).
wn(k) = wn(k) + rwn
wim = 0.
wip = 0.
!     calculate amount of n mineralized from the active n pool. this eq is
!     not the same as in the manual--->bd*bd left out.
!     next line replaced by the line following it
!     hmn=cmn*cs*wmn(k)/(bdp(k)*bdp(k))
hmn = cmn*cs*wmn(k)
!     calculate mineralized p (hmp) in the following 2 lines.
xx = wn(k) + wmn(k)
hmp = 1.4*hmn*wp(k)/xx

!     calculate n&p mineralization from humus when there is not enough residue
!      if (tkg.le.1.) then
!        calculate remaining amount of humus
!         hum(k)=hum(k)*(1.-hmn/xx)
!        subtract n flow to stable pool(rwn) and humus mineralized n(hmn) from
!        the active n pool (wmn)
!         wmn(k)=wmn(k)-hmn-rwn
!        subtract humus p from stable organic pool
!         wp(k)=wp(k)-hmp
!         rmnr=hmn
!        add humus n to the no3_n supply
!         wno3(k)=wno3(k)+rmnr
!        add humus p to the labile p supply
!         ap(k)=ap(k)+hmp
!         wmp=hmp
!      else
!        calculate n&p mineral./immobil. from fresh residue and humus material
!        this section of code calculates n & p mineralization from fresh om
!        numerator of eq 2.155
r4 = .58*tkg
!        calculate c:n ratio
cnr = r4/(fon(k)+wno3(k))
!        calculate c:p ratio
cpr = r4/(fop(k)+ap(k))
!        calculate cnp (c:n and c:p ratio factor)--eq 2.154
cnrf = 1.
IF (cnr.GT.25.) cnrf = exp(-.693*(cnr-25.)/25.)
cprf = 1.
IF (cpr.GT.200.) cprf = exp(-.693*(cpr-200.)/200.)
ca = amin1(cnrf,cprf)
!        calculate the decay rate constant using eq. 2.153
!        rc=0.05 is it constant ? when does it become 0.8 and 0.0095 ?
!        new code added to determine residue composition factor
!         if (rsdi(k).le.0.) rsdi(k)=1.
!         rfom=rsd(k)/rsdi(k)
!         if (rfom.ge.0.8) rc=0.8
!         if (rfom.lt.0.8) rc=0.05
!         if (rfom.lt.0.1) rc=0.0095
rc = 0.05
!        end of new code additions
decr = rc*ca*cs
!        calculate n mineralization rate using eq. 2.152
rmn = decr*fon(k)
!        calculate p mineralization rate using eq. 2.152
rmp = decr*fop(k)
!        calculate 20% of fresh om n
rm2 = .2*rmn
!        calculate amount of remaining humus
hum(k) = hum(k)*(1.+(rm2-hmn)/xx)
!        update amount of active humus n pool
wmn(k) = wmn(k) + rm2 - hmn - rwn
!        update amount of stable organic n pool
wp(k) = wp(k) - hmp + .2*rmp
!        calulate amount of decayed residue
rdc = decr*tkg
!        update amount of residue and convert to t/ha
rsd(k) = .001*(tkg-rdc)
!        calculate net minerlized n
rmnr = .8*rmn + hmn
!        calculate net mineralized p
wmp = .8*rmp + hmp

!        wim=amax1(.0232*rdc-rmn,0.)
!        wim=amin1(rmnr+wno3(k),wim)
!        wip=amax1(.0029*rdc-rmp,0.)
!        wip=amin1(wmp+ap(k),wip)

!        add immobilized p and subtract mineralized p to fresh organic p pool
fop(k) = fop(k) + wip - rmp
!        add immobilized n and subtract mineralized n to fresh organic n pool
fon(k) = fon(k) + wim - rmn
!        update total no3_n in soil layer
wno3(k) = wno3(k) - wim + rmnr
!        update total labile p in soil layer
ap(k) = ap(k) - wip + wmp
!        keep running totals of mineralized n & p from fresh residue(rmn*.8,
!        rmp*.8) and humus(hmn,hmp)
trmn = trmn + .8*rmn
trmp = trmp + .8*rmp
thmn = thmn + hmn
thmp = thmp + hmp

!
!     + + + local variable definitions + + +
!     ca (cnp) - takes the value of 1.0,cnrf or cprf whichever is the smallest
!     cmn (cmn) - humus rate constant(1/d) - 2.160
!     cnr (cnr) - c:n ratio in a soil layer -  2.155
!     cnrf (cnp) - c:n ratio factor -  2.154
!     cpr (cpr) - c:p ratio in a soil layer -  2.156
!     cprf (cnp) - c:p ratio factor -  2.154
!     cs - temp and soil moisture factor of - 2.153
!     decr (dcr) - decay rate constant for fresh organic matter -  2.153
!     hmp (hmp) - amount of p mineralized from humus - kg/ha/d
!     r4 - numerator of - 2.155
!     rc (rc) - residue decomposition factor (.8,.05,.0095)
!     rdc - amount of decayed residue from fresh residue - kg/ha
!     rm2 - 20% of n mineralized from fersh residue - kg/ha/day
!     rmn (rmn) - amount of n mineralized from fresh residue - kg/ha/d - 2.152
!     rmp - amount of p mineralized from fresh residue - kg/ha/d - 2.152
!     rwn (ron) - flow rate between active and stable humus n pools - kg/ha/d
!     tkg - residue - kg/ha
!     xx - sum of active and stable n pools
!
!
!     + + + output formats + + +
 1000 FORMAT (1x,2(i3,1x),11(f7.3,1x))
!      endif

!     write(37,2000)jd,k,wno3(k),ap(k),fon(k),rmn,rmp,hmn,hmp,trmn,trmp,
!    1thmn,thmp
!     write(312,2001)jd,k,cnr,cpr,cnrf,cprf,ca,decr,cs,cdg,sut
!     write(313,2002)jd,k,hum(k),wmn(k),wn(k),wp(k),rwn,rmnr,wmp
!2001 format (1x,2(i3,1x),9(f8.3,1x))
!2002 format (1x,2(i3,1x),7(f10.5,1x))
!
END SUBROUTINE nmnim

Project Documents/Source Code Original/Nmnim.f90


      SUBROUTINE SB04MW( M, D, IPR, INFO )
C
C     SLICOT RELEASE 5.7.
C
C     Copyright (c) 2002-2020 NICONET e.V.
C
C     PURPOSE
C
C     To solve a linear algebraic system of order M whose coefficient
C     matrix is in upper Hessenberg form, stored compactly, row-wise.
C
C     ARGUMENTS
C
C     Input/Output Parameters
C
C     M       (input) INTEGER
C             The order of the system.  M >= 0.
C
C     D       (input/output) DOUBLE PRECISION array, dimension
C             (M*(M+1)/2+2*M)
C             On entry, the first M*(M+1)/2 + M elements of this array
C             must contain an upper Hessenberg matrix, stored compactly,
C             row-wise, and the next M elements must contain the right
C             hand side of the linear system, as set by SLICOT Library
C             routine SB04MY.
C             On exit, the content of this array is updated, the last M
C             elements containing the solution with components
C             interchanged (see IPR).
C
C     IPR     (output) INTEGER array, dimension (2*M)
C             The leading M elements contain information about the
C             row interchanges performed for solving the system.
C             Specifically, the i-th component of the solution is
C             specified by IPR(i).
C
C     Error Indicator
C
C     INFO    INTEGER
C             = 0:  successful exit;
C             = 1:  if a singular matrix was encountered.
C
C     METHOD
C
C     Gaussian elimination with partial pivoting is used. The rows of
C     the matrix are not actually permuted, only their indices are
C     interchanged in array IPR.
C
C     REFERENCES
C
C     [1] Golub, G.H., Nash, S. and Van Loan, C.F.
C         A Hessenberg-Schur method for the problem AX + XB = C.
C         IEEE Trans. Auto. Contr., AC-24, pp. 909-913, 1979.
C
C     NUMERICAL ASPECTS
C
C     None.
C
C     CONTRIBUTORS
C
C     Release 3.0: V. Sima, Katholieke Univ. Leuven, Belgium, Sep. 1997.
C     Supersedes Release 2.0 routine SB04AW by G. Golub, S. Nash, and
C     C. Van Loan, Stanford University, California, United States of
C     America, January 1982.
C
C     REVISIONS
C
C     -
C
C     KEYWORDS
C
C     Hessenberg form, orthogonal transformation, real Schur form,
C     Sylvester equation.
C
C     ******************************************************************
C
      DOUBLE PRECISION  ZERO
      PARAMETER         ( ZERO = 0.0D0 )
C     .. Scalar Arguments ..
      INTEGER           INFO, M
C     .. Array Arguments ..
      INTEGER           IPR(*)
      DOUBLE PRECISION  D(*)
C     .. Local Scalars ..
      INTEGER           I, I1, IPRM, IPRM1, K, M1, M2, MPI
      DOUBLE PRECISION  D1, D2, MULT
C     .. External Subroutines ..
      EXTERNAL          DAXPY
C     .. Intrinsic Functions ..
      INTRINSIC         ABS
C     .. Executable Statements ..
C
      INFO = 0
      M1   = ( M*( M + 3 ) )/2
      M2   = M + M
      MPI  = M
      IPRM = M1
      M1   = M
      I1   = 1
C
      DO 20 I = 1, M
         MPI = MPI + 1
         IPRM = IPRM + 1
         IPR(MPI) = I1
         IPR(I) = IPRM
         I1 = I1 + M1
         IF ( I.GT.1 ) M1 = M1 - 1
   20 CONTINUE
C
      M1  = M - 1
      MPI = M
C
C     Reduce to upper triangular form.
C
      DO 40 I = 1, M1
         I1  = I + 1
         MPI = MPI + 1
         IPRM  = IPR(MPI)
         IPRM1 = IPR(MPI+1)
         D1 = D(IPRM)
         D2 = D(IPRM1)
         IF ( ABS( D1 ).LE.ABS( D2 ) ) THEN
C
C           Permute the row indices.
C
            K = IPRM
            IPR(MPI) = IPRM1
            IPRM = IPRM1
            IPRM1 = K
            K = IPR(I)
            IPR(I) = IPR(I1)
            IPR(I1) = K
            D1 = D2
         END IF
C
C        Check singularity.
C
         IF ( D1.EQ.ZERO ) THEN
            INFO = 1
            RETURN
         END IF
C
         MULT  = -D(IPRM1)/D1
         IPRM1 = IPRM1 + 1
         IPR(MPI+1) = IPRM1
C
C        Annihilate the subdiagonal elements of the matrix.
C
         D(IPR(I1)) = D(IPR(I1)) + MULT*D(IPR(I))
         CALL DAXPY( M-I, MULT, D(IPRM+1), 1, D(IPRM1), 1 )
   40 CONTINUE
C
C     Check singularity.
C
      IF ( D(IPR(M2)).EQ.ZERO ) THEN
         INFO = 1
         RETURN
      END IF
C
C     Back substitution.
C
      D(IPR(M)) = D(IPR(M))/D(IPR(M2))
      MPI = M2
C
      DO 80 I = M1, 1, -1
         MPI  = MPI - 1
         IPRM = IPR(MPI)
         IPRM1 = IPRM
         MULT = ZERO
C
         DO 60 I1 = I + 1, M
            IPRM1 = IPRM1 + 1
            MULT = MULT + D(IPR(I1))*D(IPRM1)
   60    CONTINUE
C
         D(IPR(I)) = ( D(IPR(I)) - MULT )/D(IPRM)
   80 CONTINUE
C
      RETURN
C *** Last line of SB04MW ***
      END