subroutine example
   ! implied do loop to initialize a to values: 1,2,3,4,5,6,7,8,9,10
   ! integer :: a(10)= 42
   ! integer :: a = 42
   ! integer :: b(10)=(/(j,j=1,10)/)

   ! These two forms of syntax are equivalent... but they are not unparsed the same!
   ! integer :: b(10)=(/(j,j=1,9,2),(j,j=2,11,2)/)
   ! integer, dimension(10) :: a = 0,b=(/(j,j=1,9,2),(j,j=2,11,2)/)

   ! integer :: a = 0,b(10)=(/(j,j=1,9,2),(j,j=2,11,2)/)
     integer :: a = 0,b(10)=(/(j,j=1,9,2),(j,j=2,11,2)/)

   ! write (1) b (i,i=1,10)

end subroutine example


! RUN: %python %S/test_folding.py %s %flang_fc1
! Test folding of LBOUND and UBOUND

module m
  real :: a3(42:52)
  real :: empty(52:42, 2:3, 10:1)
  integer, parameter :: lba3(*) = lbound(a3)
  logical, parameter :: test_lba3 = all(lba3 == [42])
  type :: t
    real :: a
  end type
  type(t) :: ta(0:2)
  character(len=2) :: ca(-1:1)
  integer, parameter :: lbtadim = lbound(ta,1)
  logical, parameter :: test_lbtadim = lbtadim == 0
  integer, parameter :: ubtadim = ubound(ta,1)
  logical, parameter :: test_ubtadim = ubtadim == 2
  integer, parameter :: lbta1(*) = lbound(ta)
  logical, parameter :: test_lbta1 = all(lbta1 == [0])
  integer, parameter :: ubta1(*) = ubound(ta)
  logical, parameter :: test_ubta1 = all(ubta1 == [2])
  integer, parameter :: lbta2(*) = lbound(ta(:))
  logical, parameter :: test_lbta2 = all(lbta2 == [1])
  integer, parameter :: ubta2(*) = ubound(ta(:))
  logical, parameter :: test_ubta2 = all(ubta2 == [3])
  integer, parameter :: lbta3(*) = lbound(ta%a)
  logical, parameter :: test_lbta3 = all(lbta3 == [1])
  integer, parameter :: ubta3(*) = ubound(ta%a)
  logical, parameter :: test_ubta3 = all(ubta3 == [3])
  integer, parameter :: lbca1(*) = lbound(ca)
  logical, parameter :: test_lbca1 = all(lbca1 == [-1])
  integer, parameter :: ubca1(*) = ubound(ca)
  logical, parameter :: test_ubca1 = all(ubca1 == [1])
  integer, parameter :: lbca2(*) = lbound(ca(:)(1:1))
  logical, parameter :: test_lbca2 = all(lbca2 == [1])
  integer, parameter :: ubca2(*) = ubound(ca(:)(1:1))
  logical, parameter :: test_ubca2 = all(ubca2 == [3])
  integer, parameter :: lbfoo(*) = lbound(foo())
  logical, parameter :: test_lbfoo = all(lbfoo == [1,1])
  integer, parameter :: ubfoo(*) = ubound(foo())
  logical, parameter :: test_ubfoo = all(ubfoo == [2,3])

  integer, parameter :: lbs_empty(*) = lbound(empty)
  logical, parameter :: test_lbs_empty = all(lbs_empty == [1, 2, 1])
  integer, parameter :: ubs_empty(*) = ubound(empty)
  logical, parameter :: test_ubs_empty = all(ubs_empty == [0, 3, 0])
  logical, parameter :: test_lb_empty_dim = lbound(empty, 1) == 1
  logical, parameter :: test_ub_empty_dim = ubound(empty, 1) == 0
 contains
  function foo()
    real :: foo(2:3,4:6)
  end function
  subroutine test(n1,a1,a2)
    integer, intent(in) :: n1
    real, intent(in) :: a1(1:n1), a2(0:*)
    integer, parameter :: lba1(*) = lbound(a1)
    logical, parameter :: test_lba1 = all(lba1 == [1])
    integer, parameter :: lba2(*) = lbound(a2)
    logical, parameter :: test_lba2 = all(lba2 == [0])
  end subroutine
  subroutine test2
    real :: a(2:3,4:6)
    associate (b => a)
      block
        integer, parameter :: lbb(*) = lbound(b)
        logical, parameter :: test_lbb = all(lbb == [2,4])
        integer, parameter :: ubb(*) = ubound(b)
        logical, parameter :: test_ubb = all(ubb == [3,6])
      end block
    end associate
    associate (b => a + 0)
      block
        integer, parameter :: lbb(*) = lbound(b)
        logical, parameter :: test_lbb = all(lbb == [1,1])
        integer, parameter :: ubb(*) = ubound(b)
        logical, parameter :: test_ubb = all(ubb == [2,3])
      end block
    end associate
  end subroutine
  subroutine test3_bound_parameter
    ! Test [ul]bound with parameter arrays
    integer, parameter :: a1(1) = 0
    integer, parameter :: lba1(*) = lbound(a1)
    logical, parameter :: test_lba1 = all(lba1 == [1])
    integer, parameter :: uba1(*) = ubound(a1)
    logical, parameter :: test_uba1 = all(lba1 == [1])

    integer, parameter :: a2(0:1) = 0
    integer, parameter :: lba2(*) = lbound(a2)
    logical, parameter :: test_lba2 = all(lba2 == [0])
    integer, parameter :: uba2(*) = ubound(a2)
    logical, parameter :: test_uba2 = all(uba2 == [1])

    integer, parameter :: a3(-10:-5,1,4:6) = 0
    integer, parameter :: lba3(*) = lbound(a3)
    logical, parameter :: test_lba3 = all(lba3 == [-10, 1, 4])
    integer, parameter :: uba3(*) = ubound(a3)
    logical, parameter :: test_uba3 = all(uba3 == [-5, 1, 6])

    ! Exercise with DIM=
    logical, parameter :: test_lba3_dim = lbound(a3, 1) == -10 .and. &
         lbound(a3, 2) == 1 .and. &
         lbound(a3, 3) == 4
    logical, parameter :: test_uba3_dim = ubound(a3, 1) == -5 .and. &
         ubound(a3, 2) == 1 .and. &
         ubound(a3, 3) == 6
  end subroutine
  subroutine test4_bound_parentheses
    ! Test [ul]bound with (x) expressions
    integer :: a1(1) = 0
    logical, parameter :: test_lba1 = all(lbound((a1)) == [1])
    logical, parameter :: test_uba1 = all(ubound((a1)) == [1])
    integer :: a2(0:2) = 0
    logical, parameter :: test_lba2 = all(lbound((a2)) == [1])
    logical, parameter :: test_uba2 = all(ubound((a2)) == [3])
    integer :: a3(-1:0) = 0
    logical, parameter :: test_lba3 = all(lbound((a3)) == [1])
    logical, parameter :: test_uba3 = all(ubound((a3)) == [2])
    integer :: a4(-5:-1, 2:5) = 0
    logical, parameter :: test_lba4 = all(lbound((a4)) == [1, 1])
    logical, parameter :: test_uba4 = all(ubound((a4)) == [5, 4])

    ! Exercise with DIM=
    logical, parameter :: test_lba4_dim = lbound((a4), 1) == 1 .and. &
         lbound((a4), 2) == 1
    logical, parameter :: test_uba4_dim = ubound((a4), 1) == 5 .and. &
         ubound((a4), 2) == 4

    ! Exercise with parameter types
    integer, parameter :: pa1(1) = 0
    logical, parameter :: test_lbpa1 = all(lbound((pa1)) == [1])
    logical, parameter :: test_ubpa1 = all(ubound((pa1)) == [1])
    integer, parameter :: pa2(0:2) = 0
    logical, parameter :: test_lbpa2 = all(lbound((pa2)) == [1])
    logical, parameter :: test_ubpa2 = all(ubound((pa2)) == [3])
    integer, parameter :: pa3(-1:0) = 0
    logical, parameter :: test_lbpa3 = all(lbound((pa3)) == [1])
    logical, parameter :: test_ubpa3 = all(ubound((pa3)) == [2])
    integer, parameter :: pa4(-5:-1, 2:5) = 0
    logical, parameter :: test_lbpa4 = all(lbound((pa4)) == [1, 1])
    logical, parameter :: test_ubpa4 = all(ubound((pa4)) == [5, 4])

    ! Exercise with DIM=
    logical, parameter :: test_lbpa4_dim = lbound((pa4), 1) == 1 .and. &
         lbound((pa4), 2) == 1
    logical, parameter :: test_ubpa4_dim = ubound((pa4), 1) == 5 .and. &
         ubound((pa4), 2) == 4
  end
end


  program logicas

  implicit none
  logical :: a,b,c

  a = .true.
  b = .false.
  !NOT

  print*, .not.(a)
  print*, .not.(5<6)
  print*, .not..true.

  !OR
  print*, "......................................."
  print*, "OR"
  print*, "Dos: ", .true..or..true.
  print*, "Tres: ", .false..or..false..or..true.

  !AND

  print*, "......................................."
  print*, "Dos: ", .false..and..true.
  print*, "Dos: ", .true..and..true.
  print*, "Tres: ", .false..and..false..and..true.
  print*, "Tres: ", .true..and..true..and..true.

  !EQV

  print*, "......................................."
  print*, "EQV"
  print*, "False: ", .false..eqv..false.
  print*, "True: ", .true..eqv..true.

  !NEQV
  print*, "......................................."
  print*, "NEQV"
  print*, "False: ", .false..neqv..false.
  print*, "True: ", .true..neqv..true.

  !Combinadas

  print*, "......................................."
  print*, "Combinadas"
  print*, "Resultado 1: " , (.not.(5<3)).and.(7>1)
  print*, "Resultado 2: " , ((5>6).eqv.(6>10)).and.(4>3.or..false.)&
  &.and.(5>10.or.10>100)

  end program logicas


c { dg-do run }
      REAL DAT(2,5)
      DO I = 1, 5
         DAT(1,I) = I*1.6356-NINT(I*1.6356)
         DAT(2,I) = I
      ENDDO
      DO I = 1, 4
         DO J = I+1, 5
            IF (DAT(1,J) - DAT(1,I) .LT. 0.0) THEN
               DO K = 1, 2
                  TMP = DAT(K,I)
                  DAT(K,I) = DAT(K,J)
                  DAT(K,J) = TMP
               ENDDO
            ENDIF
         ENDDO
      ENDDO
      DO I = 1, 4
         IF (DAT(1,I) .GT. DAT(1,I+1)) CALL ABORT
      ENDDO
      END


C Test Fortran 77 I edit descriptor for output
C      (ANSI X3.9-1978 Section 13.5.9.1)
C
C Origin: David Billinghurst <David.Billinghurst@riotinto.com>
C
C { dg-do run }
C { dg-output "^" }

      write(*,'(I1)')    1  ! { dg-output "1(\n|\r\n|\r)" }
      write(*,'(I1)')   -1  ! { dg-output "\\*(\n|\r\n|\r)" }
      write(*,'(I2)')    2  ! { dg-output " 2(\n|\r\n|\r)" }
      write(*,'(I2)')   -2  ! { dg-output "-2(\n|\r\n|\r)" }
      write(*,'(I3)')    3  ! { dg-output "  3(\n|\r\n|\r)" }
      write(*,'(I3)')   -3  ! { dg-output " -3(\n|\r\n|\r)" }

      write(*,'(I2.0)')  0  ! { dg-output "  (\n|\r\n|\r)" }
      write(*,'(I1.1)')  4  ! { dg-output "4(\n|\r\n|\r)" }
      write(*,'(I1.1)') -4  ! { dg-output "\\*(\n|\r\n|\r)" }
      write(*,'(I2.1)')  5  ! { dg-output " 5(\n|\r\n|\r)" }
      write(*,'(I2.1)') -5  ! { dg-output "-5(\n|\r\n|\r)" }
      write(*,'(I2.2)')  6  ! { dg-output "06(\n|\r\n|\r)" }
      write(*,'(I2.2)') -6  ! { dg-output "\\*\\*(\n|\r\n|\r)" }
      write(*,'(I3.2)')  7  ! { dg-output " 07(\n|\r\n|\r)" }
      write(*,'(I3.2)') -7  ! { dg-output "-07(\n|\r\n|\r)" }

      end


! MIT License
!
! Copyright (c) 2010-present David A. Kopriva and other contributors: AUTHORS.md
!
! 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.
!
! HOHQMesh contains code that, to the best of our knowledge, has been released as
! public domain software:
! * `b3hs_hash_key_jenkins`: originally by Rich Townsend,
!    https://groups.google.com/forum/#!topic/comp.lang.fortran/RWoHZFt39ng, 2005
! * `fmin`: originally by George Elmer Forsythe, Michael A. Malcolm, Cleve B. Moler,
!    Computer Methods for Mathematical Computations, 1977
! * `spline`: originally by George Elmer Forsythe, Michael A. Malcolm, Cleve B. Moler,
!    Computer Methods for Mathematical Computations, 1977
! * `seval`: originally by George Elmer Forsythe, Michael A. Malcolm, Cleve B. Moler,
!    Computer Methods for Mathematical Computations, 1977
!
! --- End License
!
!////////////////////////////////////////////////////////////////////////
!
!      CurveTests.f90
!      Created: May 25, 2021 at 9:33 AM
!      By: David Kopriva
!
!////////////////////////////////////////////////////////////////////////
!
      SUBROUTINE TestCurves
         USE SMConstants
         USE SMCurveClass
         USE SMCircularArcClass
         USE SMParametricEquationCurveClass
         USE SMSplineCurveClass
         USE SMTopographyClass
         USE SMLineClass
         USE TestSuiteManagerClass
         USE FTAssertions
         USE SharedExceptionManagerModule
!
!        -----------------------------------------------------------------
!        Instantiate and test for correctness the differrent curve classes
!        -----------------------------------------------------------------
!
         IMPLICIT NONE

         REAL(KIND=RP)                           :: xExact(3)
         INTEGER                                 :: j
         REAL(KIND=RP)                           :: dt = 0.2_RP, t, e, tol = 1.0d-5
!
!        ---------------
!        Line definition
!        ---------------
!
         TYPE(SMLine)  :: line
         REAL(KIND=RP) :: xStart(3), xEnd(3), x(3)
!
!        -----------------------
!        Circular arc definition
!        -----------------------
!
         TYPE(SMCircularArc) :: circle
         REAL(KIND=RP)       :: xc, yc, zc, theta
!
!        ------------------------------
!        Parametric Equation definition
!        ------------------------------
!
         CHARACTER(LEN=EQUATION_STRING_LENGTH) :: sx = "f(t) = 0.2 + 1.3*cos(2*pi*t)"
         CHARACTER(LEN=EQUATION_STRING_LENGTH) :: sy = "f(t) = 0.05 + 0.3*sin(2*pi*t)"
         CHARACTER(LEN=EQUATION_STRING_LENGTH) :: sz = "f(t) = 0.0"
         TYPE(SMParametricEquationCurve)       :: curve
!
!        -----------------------
!        Spline Curve definition
!        -----------------------
!
         REAL(KIND=RP)       :: r(7), xA(7), yA(7), zA(7)
         TYPE(SMSplineCurve) :: spline

!
!        ---------
!        Test Line
!        ---------
!
         xStart = [1.1_RP,1.2_RP,0.0_RP] ; xEnd = [2.1_RP,3.2_RP,0.0_RP]
         CALL line % initWithStartEndNameAndID(xStart = xStart,       &
                                               xEnd   = xEnd,         &
                                               cName  = "Line Curve", &
                                               id     = 1)
         DO j = 1, 3
            t      = j*dt
            x      = line %positionAt(t)
            xExact = xStart*(1.0_RP - t) + xEnd*t
            e      = MAXVAL(ABS(x - xExact))
            CALL FTAssertEqual(expectedValue = 0.0_RP, &
                               actualValue   = e,      &
                               tol           = tol,    &
                               msg           = "Line evaluation error too large")
         END DO
         CALL destructLine(self = line)
!
!        -----------
!        Test circle
!        -----------
!
         CALL circle % initWithParametersNameAndID(center     = [1.1_RP,1.1_RP,0.0_RP], &
                                                   radius     = 1.3_RP,                 &
                                                   startAngle = 0.1_RP,                 &
                                                   endAngle   = PI,                     &
                                                   cName      = "Circle",               &
                                                   id         = 1)
         DO j = 1,3
            t      = j*dt
            theta  = 0.1_RP + t*(PI - 0.1_RP)
            x      = circle % positionAt(t)
            xc     = 1.1_RP + 1.3_RP*COS(theta)
            yc     = 1.1_RP + 1.3_RP*SIN(theta)
            xExact = [xc,yc,0.0_RP]
            e      = MAXVAL(ABS(x - xExact))
            CALL FTAssertEqual(expectedValue = 0.0_RP, &
                               actualValue   = e,      &
                               tol           = tol,    &
                               msg           = "Circle evaluation error too large")
         END DO
         CALL destructCircularArc(self = circle)
!
!        ------------------------------
!        Parametric equation curve test
!        ------------------------------
!
         CALL curve % initWithEquationsNameAndID(xEqn      = sx,                &
                                                 yEqn      = sy,                &
                                                 zEqn      = sz,                &
                                                 curveName = "Parametric Curve",&
                                                 id        = 1)
         CALL FTAssert(test = .NOT.catch(), msg = "Equation has errors")

         DO j = 1, 3
            t      = j*dt
            x      = curve % positionAt(t)
            xc     = 0.2_RP + 1.3_RP*cos(2.0_RP*pi*t)
            yc     = 0.05_RP + 0.3_RP*sin(2.0_RP*pi*t)
            xExact = [xc,yc,0.0_RP]
            e      = MAXVAL(ABS(x - xExact))
            CALL FTAssertEqual(expectedValue = 0.0_RP, &
                               actualValue   = e,      &
                               tol           = tol,    &
                               msg           = "Equation evaluation error too large")
         END DO
         CALL destructPECurve(self = curve)
!
!        ----------------------------------------------------
!        Spline curve test. A cubic function should be exact.
!        ----------------------------------------------------
!
         DO j = 1, 7
            t = 1.0_RP - (j-1)/6.0_RP ! to define a counterclockwise curve
            r(j) =  t
            xA(j) = t**3
            yA(j) = t**2
            zA(j) = t
         END DO
         CALL spline % initWithPointsNameAndID(t         = r,              &
                                               x         = xA,             &
                                               y         = yA,             &
                                               z         = zA,             &
                                               curveName = "Spline Curve", &
                                               id        = 1)
         DO j = 1, 3
            t      = j*dt
            x      = spline % positionAt(t)
            xc     = t**3
            yc     = t**2
            zc     = t
            xExact = [xc,yc,zc]
            e      = MAXVAL(ABS(x - xExact))
            CALL FTAssertEqual(expectedValue = 0.0_RP, &
                               actualValue   = e,      &
                               tol           = tol,    &
                               msg           = "Spline error too large")
         END DO

      END SUBROUTINE TestCurves


      SUBROUTINE TSRFAC	(nplot, IERROR)
C
C LATEST REVISION	 MARCH 1984
C
C PURPOSE		 TO PROVIDE A SIMPLE DEMONSTRATION OF
C			 SRFACE	AND TO TEST SRFACE ON A	SINGLE
C			 PROBLEM
C
C USAGE			 CALL TSRFAC (IERROR)
C
C ARGUMENTS
c +noao: additional input parameter
c			 nplot
c		 	   = 1, EZSRF is demonstrated
c			   = 2, SRFACE is demonstrated
c
C
C ON OUTPUT		 IERROR
C			   AN INTEGER VARIABLE
C			   = 0,	IF THE TEST IS SUCCESSFUL,
C			   = 1,	OTHERWISE
C
C I/O			 IF THE	TEST IS	SUCCESSFUL, THE	MESSAGE
C
C			   SRFACE TEST SUCCESSFUL  . . .  SEE PLOT TO
C			   VERIFY PERFORMANCE
C
C			 IS PRINTED ON UNIT 6.
C
C			 IN ADDITION, TWO FRAMES CONTAINING THE
C			 SURFACE PLOT ARE PRODUCED ON THE MACHINE
C			 GRAPHICS DEVICE.  IN ORDER TO DETERMINE
C			 IF THE	TEST WAS SUCCESSFUL, IT	IS
C			 NECESSARY TO EXAMINE THESE PLOTS.
C
C PRECISION		 SINGLE
C
C REQUIRED LIBRARY	 SRFACE
C FILES
C
C LANGUAGE		 FORTRAN
C
C HISTORY		 FIRST WRITTEN IN APRIL	1979, CONVERTED	TO
C			 FORTRAN 77 AND	GKS IN MARCH 1984.
C
C ALGORITHM		 THE FUNCTION
C
C			   Z(X,Y) = .25*(X + Y + 1./((X-.1)**2+Y**2+.09)
C					  - 1./((X+.1)**2+Y**2+.09))
C
C			 IS EVALUATED FOR
C			   X = -1. TO 1. IN INCREMENTS OF .1 AND
C			   Y = -1.2 TO 1.2 IN INCREMENTS OF .1.
C			 TSRFAC	CALLS SUBROUTINES EZSRFC AND SRFACE
C			 ONCE.	EACH CALL PRODUCES A SURFACE PLOT
C			 OF THE	ARRAY Z.
C
C PORTABILITY		 ANSI FORTRAN 77
C
C XX CONTAINS THE X-DIRECTION COORDINATE VALUES	FOR Z(X,Y),  YY	CONTAINS
C THE Y-DIRECTION COORDINATE VALUES FOR	Z(X,Y),	 Z CONTAINS THE	FUNCTION
C VALUES,  S CONTAINS VALUES FOR THE LINE OF SIGHT FOR ENTRY SRFACE,
C WORK IS A WORK ARRAY,	 ANGH CONTAINS THE ANGLE IN DEGREES IN THE X-Y
C PLANE	TO THE LINE OF SIGHT,  ANGV CONTAINS THE ANGLE IN DEGREES FROM
C THE X-Y PLANE	TO THE LINE OF SIGHT.
C
      REAL	      XX(21)	 ,YY(25)     ,Z(21,25)	 ,S(6)	     ,
     1		      WORK(1096)
C
      DATA  S(1), S(2),	S(3), S(4), S(5), S(6)/
     1	    -8.0, -6.0,	 3.0,  0.0,  0.0,  0.0/
C
      DATA  ANGH/45./, ANGV/15./
C
C SPECIFY COORDINATES FOR PLOT TITLES.	ON AN ABSTRACT GRID WHERE
C THE COORDINATES RANGE	FROM 0.	TO 1., THE VALUES CX AND CY
C DEFINE THE CENTER OF THE TITLE STRING.
C
      DATA CX/.405/, CY/.97/
C
C INITIALIZE ERROR PARAMETER
C
      IERROR = 0
C
C FILL XX AND YY COORDINATE ARRAYS AND Z FUNCTION VALUE	ARRAY
C
      DO  20 I=1,21
	 X = .1*FLOAT(I-11)
	 XX(I) = X
	 DO  10	J=1,25
	    Y =	.1*FLOAT(J-13)
	    YY(J) = Y
	    Z(I,J) = (X+Y+1./((X-.1)**2+Y**2+.09)-
     1					    1./((X+.1)**2+Y**2+.09))*.25
   10	 CONTINUE
   20 CONTINUE
C
C SELECT NORMALIZATION TRANSFORMATION 0
C
      CALL GSELNT(0)
C
C EZSRFC DEMO
C
C LABEL	THE PLOT FOR ENTRY EZSRFC
C
C SET TEXT ALIGNMENT TO	CENTER THE STRING AT THE STRING	CENTER
C AND IN THE VERTICAL CENTER
C
      CALL GSTXAL(2,3)
C
C SET CHARACTER	HEIGHT
C
      CALL GSCHH(.016)
C
C PLOT CHARACTERS
C
      if (nplot .eq. 1) then
      CALL GTX(CX,CY,'DEMONSTRATION PLOT FOR EZSRFC ENTRY OF SRFACE')
      CALL EZSRFC (Z,21,25,ANGH,ANGV,WORK)
      endif
C
C
C SRFACE DEMO
C
C LABEL	THE PLOT FOR ENTRY SRFACE
C
C SET TEXT ALIGNMENT TO	CENTER THE STRING AT THE STRING	CENTER
C AND IN THE VERTICAL CENTER
C
      CALL GSTXAL(2,3)
C
C SET CHARACTER	HEIGHT
C
      CALL GSCHH(.016)
C
C PLOT CHARACTERS
C
      if (nplot .eq. 2) then
      CALL GTX(CX,CY,'DEMONSTRATION PLOT FOR SRFACE ENTRY OF SRFACE')
      CALL SRFACE (XX,YY,Z,WORK,21,21,25,S,0.)
      endif
C
c     WRITE (6,1001)
C
      RETURN
C
C1001 FORMAT ('	    SRFACE TEST	SUCCESSFUL',24X,
C    1	      'SEE PLOT	TO VERIFY PERFORMANCE')
C
      END


! { dg-do run }
! This tests a few reshape PRs.
program resh
  implicit none
  real, dimension (2,3) :: a,c
  real, dimension (12) :: b
  type foo
    real :: r
  end type foo
  type(foo), dimension (2,3) :: ar
  type(foo), dimension (12) :: br

  character (len=80) line1, line2, line3
  integer :: i

  ! PR 21108:  This used to give undefined results.
  b = (/(i,i=1,12)/)
  a = reshape(b(1:12:2),shape(a),order=(/2,1/))
  c = reshape(b(1:12:2),shape(a),order=(/2,1/))
  if (any (a /= c)) STOP 1

  ! Test generic reshape
  br%r = b
  ar = reshape(br(1:12:2),shape(a),order=(/2,1/))
  if (any (ar%r /= a)) STOP 2

  ! Test callee-allocated memory with a write statement
  write (line1,'(6F8.3)') reshape(b(1:12:2),shape(a),order=(/2,1/))
  write (line2,'(6F8.3)') a
  if (line1 /= line2 ) STOP 3
  write (line3,'(6F8.3)') reshape(br(1:12:2),shape(ar),order=(/2,1/))
  if (line1 /= line3 ) STOP 4
end


! { dg-do run }
!
! PR 45961: [4.6 Regression] [OOP] Problem with polymorphic type-bound operators
!
! Contributed by Mark Rashid <mmrashid@ucdavis.edu>

MODULE DAT_MOD

  TYPE :: DAT
    INTEGER :: NN
  CONTAINS
    PROCEDURE :: LESS_THAN
    GENERIC :: OPERATOR (.LT.) => LESS_THAN
  END TYPE DAT

CONTAINS

  LOGICAL FUNCTION LESS_THAN(A, B)
    CLASS (DAT), INTENT (IN) :: A, B
    LESS_THAN = (A%NN .LT. B%NN)
  END FUNCTION LESS_THAN

END MODULE DAT_MOD

MODULE NODE_MOD
  USE DAT_MOD

  TYPE NODE
    INTEGER :: KEY
    CLASS (DAT), POINTER :: PT
  CONTAINS
    PROCEDURE :: LST
    GENERIC :: OPERATOR (.LT.) => LST
  END TYPE NODE

CONTAINS

  LOGICAL FUNCTION LST(A, B)
    CLASS (NODE), INTENT (IN) :: A, B
    IF (A%KEY .GT. 0 .AND. B%KEY .GT. 0) THEN
      LST = (A%KEY .LT. B%KEY)
    ELSE
      LST = (A%PT .LT. B%PT)
    END IF
  END FUNCTION LST

END MODULE NODE_MOD

PROGRAM TEST
  USE NODE_MOD
  IMPLICIT NONE

  CLASS (DAT), POINTER :: POINTA => NULL(), POINTB => NULL()
  CLASS (NODE), POINTER :: NDA => NULL(), NDB => NULL()

  ALLOCATE (DAT :: POINTA)
  ALLOCATE (DAT :: POINTB)
  ALLOCATE (NODE :: NDA)
  ALLOCATE (NODE :: NDB)

  POINTA%NN = 5
  NDA%PT => POINTA
  NDA%KEY = 2
  POINTB%NN = 10
  NDB%PT => POINTB
  NDB%KEY = 3

  if (.NOT. NDA .LT. NDB) call abort()
END


!=======================================================================
!
!  Calculate the rate of molecular hydrogen (H2) formation on grains
!  using the treatment of Cazaux & Tielens (2002, ApJ, 575, L29) and
!  Cazaux & Tielens (2004, ApJ, 604, 222).
!
!-----------------------------------------------------------------------
FUNCTION H2_FORMATION_RATE(GAS_TEMPERATURE,GRAIN_TEMPERATURE) RESULT(RATE)

   USE HEALPIX_TYPES
   IMPLICIT NONE

   REAL(KIND=DP) :: RATE
   REAL(KIND=DP), INTENT(IN) :: GAS_TEMPERATURE,GRAIN_TEMPERATURE

   REAL(KIND=DP) :: THERMAL_VELOCITY,STICKING_COEFFICIENT,TOTAL_CROSS_SECTION
   REAL(KIND=DP) :: FLUX,FACTOR1,FACTOR2,EPSILON
   REAL(KIND=DP) :: SILICATE_FORMATION_EFFICIENCY,GRAPHITE_FORMATION_EFFICIENCY
   REAL(KIND=DP) :: SILICATE_CROSS_SECTION,SILICATE_MU,SILICATE_E_S,SILICATE_E_H2,SILICATE_E_HP,SILICATE_E_HC,SILICATE_NU_H2,SILICATE_NU_HC
   REAL(KIND=DP) :: GRAPHITE_CROSS_SECTION,GRAPHITE_MU,GRAPHITE_E_S,GRAPHITE_E_H2,GRAPHITE_E_HP,GRAPHITE_E_HC,GRAPHITE_NU_H2,GRAPHITE_NU_HC

!  Mean thermal velocity of hydrogen atoms (cm s^-1)
   THERMAL_VELOCITY=1.45D5*SQRT(GAS_TEMPERATURE/1.0D2)

!  Calculate the thermally averaged sticking coefficient of hydrogen atoms on grains,
!  as given by Hollenbach & McKee (1979, ApJS, 41, 555, eqn 3.7)
   STICKING_COEFFICIENT=1.0D0/(1.0D0+0.04D0*SQRT(GAS_TEMPERATURE+GRAIN_TEMPERATURE) &
                    & + 0.2D0*(GAS_TEMPERATURE/1.0D2)+0.08D0*(GAS_TEMPERATURE/1.0D2)**2)

   FLUX=1.0D-10 ! Flux of H atoms in monolayers per second (mLy s^-1)

   TOTAL_CROSS_SECTION=6.273D-22 ! Total mixed grain cross section per H nucleus (cm^-2/nucleus)
   SILICATE_CROSS_SECTION=8.473D-22 ! Silicate grain cross section per H nucleus (cm^-2/nucleus)
   GRAPHITE_CROSS_SECTION=7.908D-22 ! Graphite grain cross section per H nucleus (cm^-2/nucleus)

!  Silicate grain properties
   SILICATE_MU=0.005D0   ! Fraction of newly formed H2 that stays on the grain surface
   SILICATE_E_S=110.0D0  ! Energy of the saddle point between a physisorbed and a chemisorbed site (K)
   SILICATE_E_H2=320.0D0 ! Desorption energy of H2 molecules (K)
   SILICATE_E_HP=450.0D0 ! Desorption energy of physisorbed H atoms (K)
   SILICATE_E_HC=3.0D4   ! Desorption energy of chemisorbed H atoms (K)
   SILICATE_NU_H2=3.0D12 ! Vibrational frequency of H2 molecules in surface sites (s^-1)
   SILICATE_NU_HC=1.3D13 ! Vibrational frequency of H atoms in their surface sites (s^-1)

   FACTOR1=SILICATE_MU*FLUX/(2*SILICATE_NU_H2*EXP(-SILICATE_E_H2/GRAIN_TEMPERATURE))

   FACTOR2=1.0D0*(1.0D0+SQRT((SILICATE_E_HC-SILICATE_E_S)/(SILICATE_E_HP-SILICATE_E_S)))**2 &
        & /4.0D0*EXP(-SILICATE_E_S/GRAIN_TEMPERATURE)

   EPSILON=1.0D0/(1.0D0+SILICATE_NU_HC/(2*FLUX)*EXP(-1.5*SILICATE_E_HC/GRAIN_TEMPERATURE) &
              & *(1.0D0+SQRT((SILICATE_E_HC-SILICATE_E_S)/(SILICATE_E_HP-SILICATE_E_S)))**2)

   SILICATE_FORMATION_EFFICIENCY=1.0D0/(1.0D0+FACTOR1+FACTOR2)*EPSILON

!  Graphite grain properties
   GRAPHITE_MU=0.005D0   ! Fraction of newly formed H2 that stays on the grain surface
   GRAPHITE_E_S=260.0D0  ! Energy of the saddle point between a physisorbed and a chemisorbed site (K)
   GRAPHITE_E_H2=520.0D0 ! Desorption energy of H2 molecules (K)
   GRAPHITE_E_HP=800.0D0 ! Desorption energy of physisorbed H atoms (K)
   GRAPHITE_E_HC=3.0D4   ! Desorption energy of chemisorbed H atoms (K)
   GRAPHITE_NU_H2=3.0D12 ! Vibrational frequency of H2 molecules in surface sites (s^-1)
   GRAPHITE_NU_HC=1.3D13 ! Vibrational frequency of H atoms in their surface sites (s^-1)

   FACTOR1=GRAPHITE_MU*FLUX/(2*GRAPHITE_NU_H2*EXP(-GRAPHITE_E_H2/GRAIN_TEMPERATURE))

   FACTOR2=1.0D0*(1.0D0+SQRT((GRAPHITE_E_HC-GRAPHITE_E_S)/(GRAPHITE_E_HP-GRAPHITE_E_S)))**2 &
        & /4.0D0*EXP(-GRAPHITE_E_S/GRAIN_TEMPERATURE)

   EPSILON=1.0D0/(1.0D0+GRAPHITE_NU_HC/(2*FLUX)*EXP(-1.5*GRAPHITE_E_HC/GRAIN_TEMPERATURE) &
              & *(1.0D0+SQRT((GRAPHITE_E_HC-GRAPHITE_E_S)/(GRAPHITE_E_HP-GRAPHITE_E_S)))**2)

   GRAPHITE_FORMATION_EFFICIENCY=1.0D0/(1.0D0+FACTOR1+FACTOR2)*EPSILON

!!$!  Use the tradional rate, with a simple temperature dependence based on the
!!$!  thermal velocity of the H atoms in the gas and neglecting any temperature
!!$!  dependency of the formation and sticking efficiencies
!!$   RATE=3.0D-18*SQRT(GAS_TEMPERATURE)

!!$!  Use the treatment of de Jong (1977, A&A, 55, 137, p140 right column).
!!$!  The second exponential dependence on the gas temperature reduces the
!!$!  efficiency at high temperatures and so prevents runaway H2 formation
!!$!  heating at high temperatures:
!!$!
!!$!  k_H2 = 3E-18 * T^0.5 * exp(-T/1000)   [cm3/s]
!!$!
!!$   RATE=3.0D-18*SQRT(GAS_TEMPERATURE)*EXP(-(GAS_TEMPERATURE/1.0D3))

!!$!  Use the treatment of Tielens & Hollenbach (1985, ApJ, 291, 722, eqn 4)
!!$   RATE=0.5D0*THERMAL_VELOCITY*TOTAL_CROSS_SECTION*STICKING_COEFFICIENT

!  Use the treatment of Cazaux & Tielens (2002, ApJ, 575, L29) and
!  Cazaux & Tielens (2004, ApJ, 604, 222)
   RATE=0.5D0*THERMAL_VELOCITY*(SILICATE_CROSS_SECTION*SILICATE_FORMATION_EFFICIENCY &
    & + GRAPHITE_CROSS_SECTION*GRAPHITE_FORMATION_EFFICIENCY)*STICKING_COEFFICIENT

!!$!  Use the expression given by Markus Rollig during the February 2012 Leiden workshop
!!$   RATE=0.5D0*THERMAL_VELOCITY &
!!$      & *(SILICATE_CROSS_SECTION/((1.0D0 + 6.998D24/EXP(1.5*SILICATE_E_HC/GRAIN_TEMPERATURE)) &
!!$      & *(1.0D0 + 1.0D0/(EXP(SILICATE_E_HP/GRAIN_TEMPERATURE) &
!!$      & *(0.427D0/EXP((SILICATE_E_HP-SILICATE_E_S)/GRAIN_TEMPERATURE) + 2.5336D-14*SQRT(GRAIN_TEMPERATURE))))) &
!!$      & + GRAPHITE_CROSS_SECTION/((1.0D0 + 4.610D24/EXP(1.5*GRAPHITE_E_HC/GRAIN_TEMPERATURE)) &
!!$      & *(1.0D0 + 1.0D0/(EXP(GRAPHITE_E_HP/GRAIN_TEMPERATURE) &
!!$      & *(0.539D0/EXP((GRAPHITE_E_HP-GRAPHITE_E_S)/GRAIN_TEMPERATURE) + 5.6334D-14*SQRT(GRAIN_TEMPERATURE)))))) &
!!$      & *STICKING_COEFFICIENT

   RETURN
END FUNCTION H2_FORMATION_RATE
!=======================================================================


!------------------------------------------------------------------------------
! MODULE: kde
!
!> @author
!> Pavel Junker
!
! DESCRIPTION:
!> implementation of vanilla kernel density estimation and Zdravko Botev's ada-
! ptive kernel density estimation algorithm (https://www.mathworks.com/matlabce
! ntral/fileexchange/58312-kernel-density-estimator-for-high-dimensions)
!
! REVISION HISTORY:
! 13.03.2021 - Initial Version
!------------------------------------------------------------------------------
module kde
	use omp_lib
	implicit none
	private

	integer, parameter :: DP = kind(0.D0), DP_SIZE = sizeof(0.0D0)

	real(kind=DP), parameter :: eps = epsilon(0.0D0)

	public :: botev_get_estimate, kde_get_estimate

contains

	subroutine botev_get_estimate(mu, w, sig, det, d, gam, n, lam, X, grid, &
								  grid_n, runs, estimate, h)
		integer, intent(in) :: d, gam, n, grid_n, runs
		real(kind=DP), intent(in) :: lam, grid(d,grid_n), X(d,n)
		real(kind=DP), intent(out) :: estimate(grid_n), h, mu(d,gam), w(gam), &
		                              sig(d,d,gam), det(gam)
		real(kind=DP), external :: dlantr
		! locals
		integer, parameter :: ent_count = 100, max_iter = 1000
		integer :: i, j, k, idx(ent_count) = [(i, i=1,ent_count)]
		real(kind=DP) :: xRinv(d,n), p(n,gam), psig(n,gam), density(n), &
		                 xSig(n), temp(grid_n), curv, ent_c, mesh(d,grid_n), &
		                 density_old(ent_count), stopa(gam)

		! these act as parameters and are never changed
		real(kind=DP) :: norm_const, konst, lam2

		! some neccessary initialization
		density(idx) = 1
		norm_const = 1d0/sqrt(8d0*atan(1d0))**d
		konst = 16d0*n*sqrt(atan(1d0))**2d0
		lam2 = sqrt(1/lam)**d

		! it's assumed samples are ordered randomly
		mu = X(:,1:gam)
		h = 0.1d0*lam*n**(-real(d,kind=DP)/(d+4))
		sig = 0
		do i=1,d
			call random_number(sig(i,i,:))
			sig(i,i,:) = (0.1 + 0.9 * sig(i,i,:)) * h * lam**2
		end do
		call random_number(w)
		w = w / sum(w)
		det = 1
		ent_c = 10

		!$OMP PARALLEL PRIVATE(i,j,k,xRinv,xSig)
		k = 1
		main_loop : do

			!$OMP DO
			do i=1,gam
				call dpotrf('L', d, sig(:,:,i), d, j)
				det(i) = 1
				do j=1,d
					det(i) = det(i) * sig(j,j,i)
				end do
				call dtrtri('L','N',d,sig(:,:,i),d,j)
				stopa(i) = dlantr('F','L','N',d,d,sig(:,:,i),d,curv)**2
				do j=1,n
					xRinv(:,j) = X(:,j) - mu(:,i)
				end do
				call dtrmm('L','L','N','N',d,n,1d0,sig(:,:,i),d,xRinv,d)
				xSig = norm2(xRinv,dim=1)**2d0
				p(:,i) = w(i) / det(i) * &
				         exp(-0.5 * xSig - 0.5 * stopa(i) * h**2d0)
				call dtrmm('L','L','T','N',d,n,lam2,sig(:,:,i),d,xRinv,d)
				xSig = norm2(xRinv,dim=1)**2d0 ! + eps
				psig(:,i) = p(:,i) * xSig
			end do
			!$OMP END DO

			if (abs(ent_c - 1) < 1e-6 .or. k == max_iter) exit main_loop

			!$OMP BARRIER

			!$OMP SINGLE
			! ent_c = product(density(idx))
			density_old = density(idx)
			density = sum(p,dim=2) + eps
			!$OMP END SINGLE
			!$OMP DO
			do i=1,gam
				p(:,i) = p(:,i) / density
			end do
			!$OMP END DO

			!$OMP SINGLE
			! ent_c = ent_c / max(product(density(idx)),eps)
			ent_c = 1
			! dividing product(density(idx)) before and after updating
			! density does not cut it, since it tends to underflow for
			! large enough idx
			do j=1,ent_count
				ent_c = ent_c * density(idx(j)) / density_old(j)
			end do
			w = sum(p,dim=1)
			!$OMP END SINGLE
			!$OMP DO
			do i=1,gam
				! adjust for possibility of w(i) being zero
				! openMP does not permit simple use of 'cycle'
				if (w(i) /= 0) then
					mu(:,i) = matmul(X,p(:,i)) / w(i)

					do concurrent (j=1:n)
						xRinv(:,j) = X(:,j) - mu(:,i)
					end do
					do concurrent (j=1:d)
						xRinv(j,:) = xRinv(j,:) * sqrt(p(:,i))
					end do

					sig(:,:,i) = matmul(xRinv, transpose(xRinv))

					sig(:,:,i) = sig(:,:,i) / w(i)
					do j=1,d
						sig(j,j,i) = sig(j,j,i) + h**2
					end do
				end if
			end do
			!$OMP END DO

			!$OMP SINGLE
			xSig = sum(psig,dim=2)/density
			curv = sum(xSig)/n
			h = (curv*konst)**(-real(1,kind=DP)/(d+2))
			w = w / sum(w)
			!$OMP END SINGLE
			k = k + 1

		end do main_loop
		!$OMP MASTER
		write(*,"('done, k : ', i0)") k
		!$OMP END MASTER
		!$OMP END PARALLEL

		! actually obtaining the estimate
		estimate = 0
		!$OMP PARALLEL DO PRIVATE(j,mesh,temp) REDUCTION(+ : estimate)
		do i=1,gam
			do concurrent (j=1:grid_n)
				mesh(:,j) = grid(:,j) - mu(:,i)
			end do
			call dtrmm('L','L','N','N',d,grid_n,1d0,sig(:,:,i),d,mesh,d)
			temp = -0.5d0 * norm2(mesh,dim=1)**2d0
			estimate = estimate + w(i) * norm_const / det(i) * exp(temp)
		end do
		!$OMP END PARALLEL DO

		!end associate

	end subroutine botev_get_estimate

	! vanilla KDE with fixed bandwidth isotropic kernel
	subroutine kde_get_estimate(d, n, X, grid, grid_n, estimate, gam, bandwidth)
		integer, intent(in) :: d, n, grid_n
		integer, optional, intent(in) :: gam
		real(kind=DP), intent(in) :: grid(d,grid_n), X(d,n)
		real(kind=DP), optional, intent(in) :: bandwidth
		real(kind=DP), intent(out) :: estimate(grid_n)
		! locals
		real(kind=DP), parameter :: konst = 1d0/sqrt(8d0*atan(1d0))
		real(kind=DP) :: h, det, temp(grid_n), mesh(d,grid_n)
		integer :: num_kernels, i, j

		if(present(gam)) then
			num_kernels = gam
		else
			num_kernels = n
		end if

		if(present(bandwidth)) then
			h = bandwidth
		else
			h = (4.0D0/(d+2)/n)**(1.0D0/(d+4))
		end if

		det = konst**d/n/h**d

		estimate = 0
		!$OMP PARALLEL DO PRIVATE(j,mesh,temp) REDUCTION(+ : estimate)
		do i=1,num_kernels
			do concurrent(j=1:grid_n)
				mesh(:,j) = grid(:,j) - X(:,i)
			end do
			temp = -0.5d0 * (norm2(mesh,dim=1)/h) ** 2
			estimate = estimate + det * exp(temp)
		end do
		!$OMP END PARALLEL DO

	end subroutine kde_get_estimate

end module kde


      SUBROUTINE bessik(x,xnu,ri,rk,rip,rkp)
      INTEGER MAXIT
      REAL ri,rip,rk,rkp,x,xnu,XMIN
      DOUBLE PRECISION EPS,FPMIN,PI
      PARAMETER (EPS=1.e-10,FPMIN=1.e-30,MAXIT=10000,XMIN=2.,
     *PI=3.141592653589793d0)
CU    USES beschb
      INTEGER i,l,nl
      DOUBLE PRECISION a,a1,b,c,d,del,del1,delh,dels,e,f,fact,fact2,ff,
     *gam1,gam2,gammi,gampl,h,p,pimu,q,q1,q2,qnew,ril,ril1,rimu,rip1,
     *ripl,ritemp,rk1,rkmu,rkmup,rktemp,s,sum,sum1,x2,xi,xi2,xmu,xmu2
      if(x.le.0..or.xnu.lt.0.) pause 'bad arguments in bessik'
      nl=int(xnu+.5d0)
      xmu=xnu-nl
      xmu2=xmu*xmu
      xi=1.d0/x
      xi2=2.d0*xi
      h=xnu*xi
      if(h.lt.FPMIN)h=FPMIN
      b=xi2*xnu
      d=0.d0
      c=h
      do 11 i=1,MAXIT
        b=b+xi2
        d=1.d0/(b+d)
        c=b+1.d0/c
        del=c*d
        h=del*h
        if(abs(del-1.d0).lt.EPS)goto 1
11    continue
      pause 'x too large in bessik; try asymptotic expansion'
1     continue
      ril=FPMIN
      ripl=h*ril
      ril1=ril
      rip1=ripl
      fact=xnu*xi
      do 12 l=nl,1,-1
        ritemp=fact*ril+ripl
        fact=fact-xi
        ripl=fact*ritemp+ril
        ril=ritemp
12    continue
      f=ripl/ril
      if(x.lt.XMIN) then
        x2=.5d0*x
        pimu=PI*xmu
        if(abs(pimu).lt.EPS)then
          fact=1.d0
        else
          fact=pimu/sin(pimu)
        endif
        d=-log(x2)
        e=xmu*d
        if(abs(e).lt.EPS)then
          fact2=1.d0
        else
          fact2=sinh(e)/e
        endif
        call beschb(xmu,gam1,gam2,gampl,gammi)
        ff=fact*(gam1*cosh(e)+gam2*fact2*d)
        sum=ff
        e=exp(e)
        p=0.5d0*e/gampl
        q=0.5d0/(e*gammi)
        c=1.d0
        d=x2*x2
        sum1=p
        do 13 i=1,MAXIT
          ff=(i*ff+p+q)/(i*i-xmu2)
          c=c*d/i
          p=p/(i-xmu)
          q=q/(i+xmu)
          del=c*ff
          sum=sum+del
          del1=c*(p-i*ff)
          sum1=sum1+del1
          if(abs(del).lt.abs(sum)*EPS)goto 2
13      continue
        pause 'bessk series failed to converge'
2       continue
        rkmu=sum
        rk1=sum1*xi2
      else
        b=2.d0*(1.d0+x)
        d=1.d0/b
        delh=d
        h=delh
        q1=0.d0
        q2=1.d0
        a1=.25d0-xmu2
        c=a1
        q=c
        a=-a1
        s=1.d0+q*delh
        do 14 i=2,MAXIT
          a=a-2*(i-1)
          c=-a*c/i
          qnew=(q1-b*q2)/a
          q1=q2
          q2=qnew
          q=q+c*qnew
          b=b+2.d0
          d=1.d0/(b+a*d)
          delh=(b*d-1.d0)*delh
          h=h+delh
          dels=q*delh
          s=s+dels
          if(abs(dels/s).lt.EPS)goto 3
14      continue
        pause 'bessik: failure to converge in cf2'
3       continue
        h=a1*h
        rkmu=sqrt(PI/(2.d0*x))*exp(-x)/s
        rk1=rkmu*(xmu+x+.5d0-h)*xi
      endif
      rkmup=xmu*xi*rkmu-rk1
      rimu=xi/(f*rkmu-rkmup)
      ri=(rimu*ril1)/ril
      rip=(rimu*rip1)/ril
      do 15 i=1,nl
        rktemp=(xmu+i)*xi2*rk1+rkmu
        rkmu=rk1
        rk1=rktemp
15    continue
      rk=rkmu
      rkp=xnu*xi*rkmu-rk1
      return
      END


      SUBROUTINE MB01TD( N, A, LDA, B, LDB, DWORK, INFO )
C
C     SLICOT RELEASE 5.7.
C
C     Copyright (c) 2002-2020 NICONET e.V.
C
C     PURPOSE
C
C     To compute the matrix product A * B, where A and B are upper
C     quasi-triangular matrices (that is, block upper triangular with
C     1-by-1 or 2-by-2 diagonal blocks) with the same structure.
C     The result is returned in the array B.
C
C     ARGUMENTS
C
C     Input/Output Parameters
C
C     N       (input) INTEGER
C             The order of the matrices A and B.  N >= 0.
C
C     A       (input) DOUBLE PRECISION array, dimension (LDA,N)
C             The leading N-by-N part of this array must contain the
C             upper quasi-triangular matrix A. The elements below the
C             subdiagonal are not referenced.
C
C     LDA     INTEGER
C             The leading dimension of the array A.  LDA >= max(1,N).
C
C     B       (input/output) DOUBLE PRECISION array, dimension (LDB,N)
C             On entry, the leading N-by-N part of this array must
C             contain the upper quasi-triangular matrix B, with the same
C             structure as matrix A.
C             On exit, the leading N-by-N part of this array contains
C             the computed product A * B, with the same structure as
C             on entry.
C             The elements below the subdiagonal are not referenced.
C
C     LDB     INTEGER
C             The leading dimension of the array B.  LDB >= max(1,N).
C
C     Workspace
C
C     DWORK   DOUBLE PRECISION array, dimension (N-1)
C
C     Error Indicator
C
C     INFO    INTEGER
C             = 0:  successful exit;
C             < 0:  if INFO = -i, the i-th argument had an illegal
C                   value;
C             = 1:  if the matrices A and B have not the same structure,
C                   and/or A and B are not upper quasi-triangular.
C
C     METHOD
C
C     The matrix product A * B is computed column by column, using
C     BLAS 2 and BLAS 1 operations.
C
C     FURTHER COMMENTS
C
C     This routine can be used, for instance, for computing powers of
C     a real Schur form matrix.
C
C     CONTRIBUTOR
C
C     V. Sima, Katholieke Univ. Leuven, Belgium, June 1998.
C
C     REVISIONS
C
C     V. Sima, Feb. 2000.
C
C     KEYWORDS
C
C     Elementary matrix operations, matrix operations.
C
C     ******************************************************************
C
C     .. Parameters ..
      DOUBLE PRECISION  ZERO, ONE
      PARAMETER         ( ZERO = 0.0D0, ONE = 1.0D0 )
C     .. Scalar Arguments ..
      INTEGER           INFO, LDA, LDB, N
C     .. Array Arguments ..
      DOUBLE PRECISION  A(LDA,*), B(LDB,*), DWORK(*)
C     .. Local Scalars ..
      INTEGER           I, J, JMIN, JMNM
C     .. External Subroutines ..
      EXTERNAL          DAXPY, DTRMV, XERBLA
C     .. Intrinsic Functions ..
      INTRINSIC         MAX, MIN
C
C     .. Executable Statements ..
C
C     Test the input scalar arguments.
C
      INFO  = 0
      IF( N.LT.0 ) THEN
         INFO = -1
      ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
         INFO = -3
      ELSE IF( LDB.LT.MAX( 1, N ) ) THEN
         INFO = -5
      END IF
C
      IF ( INFO.NE.0 ) THEN
C
C        Error return.
C
         CALL XERBLA( 'MB01TD', -INFO )
         RETURN
      END IF
C
C     Quick return, if possible.
C
      IF ( N.EQ.0 ) THEN
         RETURN
      ELSE IF ( N.EQ.1 ) THEN
         B(1,1) = A(1,1)*B(1,1)
         RETURN
      END IF
C
C     Test the upper quasi-triangular structure of A and B for identity.
C
      DO 10 I = 1, N - 1
         IF ( A(I+1,I).EQ.ZERO ) THEN
            IF ( B(I+1,I).NE.ZERO ) THEN
               INFO = 1
               RETURN
            END IF
         ELSE IF ( I.LT.N-1 ) THEN
            IF ( A(I+2,I+1).NE.ZERO ) THEN
               INFO = 1
               RETURN
            END IF
         END IF
   10 CONTINUE
C
      DO 30 J = 1, N
         JMIN = MIN( J+1,  N )
         JMNM = MIN( JMIN, N-1 )
C
C        Compute the contribution of the subdiagonal of A to the
C        j-th column of the product.
C
         DO 20 I = 1, JMNM
            DWORK(I) = A(I+1,I)*B(I,J)
   20    CONTINUE
C
C        Multiply the upper triangle of A by the j-th column of B,
C        and add to the above result.
C
         CALL DTRMV( 'Upper', 'No transpose', 'Non-unit', JMIN, A, LDA,
     $               B(1,J), 1 )
         CALL DAXPY( JMNM, ONE, DWORK, 1, B(2,J), 1 )
   30 CONTINUE
C
      RETURN
C *** Last line of MB01TD ***
      END


      real*8 function wavecalc(point,npt,c)
c******************************************************************************
c     this routine returns the wavelength of a given channel number
c******************************************************************************

      implicit real*8 (a-h,o-z)
      real*4 point
      real*8 c(9)

      if (c(9) .eq. 1.) go to 20
      if (c(9) .eq. 2.) go to 40
      if (c(9) .eq. 3.) go to 30

c*****no wavelength solution exists
      if (c(1).eq.0. .or. c(2).eq.0.) then
         wavecalc = point

c*****an ordinary polynomial solution
      else
         dn = point
         wavecalc = c(1)+dn*(c(2)+dn*(c(3)+dn*(c(4)+
     .                   dn*(c(5)+dn*c(6)))))
      endif
      return

c*****a Chebyshev polynomial solution
20    xpt = (2.*point-real(npt+1))/real(npt-1)
      wavecalc = c(1) +
     .           c(2)*xpt +
     .           c(3)*(2.*xpt**2-1.) +
     .           c(4)*xpt*(4.*xpt**2-3.) +
     .           c(5)*(8.*xpt**4-8.*xpt**2+1.) +
     .           c(6)*xpt*(16.*xpt**4-20.*xpt**2+5.)
      return

c*****a spline3 solution
30    s = (point-1.)/(real(npt)-1.)*c(8)
      j = int(s)
      a = real(j+1) - s
      b = s - real(j)
      z0 = a**3
      z1 = 1. + 3.*a*(1.+a*b)
      z2 = 1. + 3.*b*(1.+a*b)
      z3 = b**3
      wavecalc = c(j+1)*z0 + c(j+2)*z1 + c(j+3)*z2 + c(j+4)*z3
      return

c*****a Legendre polynomial solution
40    xpt = (2.*point-real(npt+1))/real(npt-1)
      wavecalc = c(1) + c(2)*xpt
      return

      end


SUBROUTINE tqli(d,e,z)
  USE nrtype; USE nrutil, ONLY : assert_eq,nrerror
  USE nr, ONLY : pythag
  IMPLICIT NONE
  REAL(SP), DIMENSION(:), INTENT(INOUT) :: d,e
  REAL(SP), DIMENSION(:,:), OPTIONAL, INTENT(INOUT) :: z
  INTEGER(I4B) :: i,iter,l,m,n,ndum
  REAL(SP) :: b,c,dd,f,g,p,r,s
  REAL(SP), DIMENSION(size(e)) :: ff
  n=assert_eq(size(d),size(e),'tqli: n')
  if (present(z)) ndum=assert_eq(n,size(z,1),size(z,2),'tqli: ndum')
  e(:)=eoshift(e(:),1)
  do l=1,n
     iter=0
     iterate: do
        do m=l,n-1
           dd=abs(d(m))+abs(d(m+1))
           if (abs(e(m))+dd == dd) exit
        end do
        if (m == l) exit iterate
        if (iter == 30) call nrerror('too many iterations in tqli')
        iter=iter+1
        g=(d(l+1)-d(l))/(2.0_sp*e(l))
        r=pythag(g,1.0_sp)
        g=d(m)-d(l)+e(l)/(g+sign(r,g))
        s=1.0
        c=1.0
        p=0.0
        do i=m-1,l,-1
           f=s*e(i)
           b=c*e(i)
           r=pythag(f,g)
           e(i+1)=r
           if (r == 0.0) then
              d(i+1)=d(i+1)-p
              e(m)=0.0
              cycle iterate
           end if
           s=f/r
           c=g/r
           g=d(i+1)-p
           r=(d(i)-g)*s+2.0_sp*c*b
           p=s*r
           d(i+1)=g+p
           g=c*r-b
           if (present(z)) then
              ff(1:n)=z(1:n,i+1)
              z(1:n,i+1)=s*z(1:n,i)+c*ff(1:n)
              z(1:n,i)=c*z(1:n,i)-s*ff(1:n)
           end if
        end do
        d(l)=d(l)-p
        e(l)=g
        e(m)=0.0
     end do iterate
  end do
END SUBROUTINE tqli


      subroutine tnorm(r,ceig,lfno)
      implicit none
      integer*4 i,j
      integer*4 ,intent(in):: lfno
      real*8 ,intent(inout):: r(6,6)
      real*8 sa,sb,a,s,cost,sint,s1,s2,s3,b,v(6,2)
      complex*16 ,intent(out):: ceig(6)
      complex*16 cc
      do i=1,5,2
        if(imag(ceig(i)) .eq. 0.d0)then
          sa=sum(r(:,i)**2)
          sb=sum(r(:,i+1)**2)
          a=sqrt(sqrt(sa/sb))
          r(:,i  )=r(:,i  )/a
          r(:,i+1)=r(:,i+1)*a
        endif
        s=0.d0
        do j=1,5,2
          s=s+r(j,i)*r(j+1,i+1)-r(j,i+1)*r(j+1,i)
        enddo
        sa=sqrt(abs(s))
        if(s .gt. 0.d0)then
          sb=sa
        elseif(s .eq. 0.d0)then
          if(lfno .ne. 0)then
            write(lfno,*)'???-tnorm-Unstable transfer matrix.'
          endif
          sa=1.d0
          sb=1.d0
        else
          sb=-sa
          ceig(i  )=conjg(ceig(i  ))
          ceig(i+1)=conjg(ceig(i+1))
        endif
        r(:,i  )=r(:,i  )/sa
        r(:,i+1)=r(:,i+1)/sb
      enddo
      s1=(r(5,1)*r(6,2)-r(5,2)*r(6,1))**2
      s2=(r(5,3)*r(6,4)-r(5,4)*r(6,3))**2
      s3=(r(5,5)*r(6,6)-r(5,6)*r(6,5))**2
      j=maxloc((/s1,s2,s3/),1)*2-1
      if(j .ne. 5)then
        v=r(:,5:6)
        r(:,5:6)=r(:,j:j+1)
        r(:,j:j+1)=v
        cc=ceig(5)
        ceig(5)=ceig(j)
        ceig(j)=cc
        cc=ceig(6)
        ceig(6)=ceig(j+1)
        ceig(j+1)=cc
      endif
      s1=(r(1,1)*r(2,2)-r(1,2)*r(2,1))**2
      s2=(r(1,3)*r(2,4)-r(1,4)*r(2,3))**2
      if(s2 .gt. s1)then
        v=r(:,1:2)
        r(:,1:2)=r(:,3:4)
        r(:,3:4)=v
        cc=ceig(1)
        ceig(1)=ceig(3)
        ceig(3)=cc
        cc=ceig(2)
        ceig(2)=ceig(4)
        ceig(4)=cc
      endif
      do i=1,5,2
        if(imag(ceig(i)) .ne. 0.d0)then
          a=hypot(r(i,i),r(i,i+1))
          cost=r(i,i  )/a
          sint=r(i,i+1)/a
          v(:,1)=r(:,i)
          r(:,i  )= v(:,1)*cost+r(:,i+1)*sint
          r(:,i+1)=-v(:,1)*sint+r(:,i+1)*cost
        else
          a=r(i,i)
          if(a .ne. 0.d0)then
            b=r(i,i+1)
            r(:,i+1)=r(:,i+1)*a-b*r(:,i)
            r(:,i  )=r(:,i  )/a
          endif
        endif
      enddo
c     call tsymp(r)
      return
      end


C    Copyright(C) 2014-2017 National Technology & Engineering Solutions of
C    Sandia, LLC (NTESS).  Under the terms of Contract DE-NA0003525 with
C    NTESS, the U.S. Government retains certain rights in this software.
C
C    Redistribution and use in source and binary forms, with or without
C    modification, are permitted provided that the following conditions are
C    met:
C
C    * Redistributions of source code must retain the above copyright
C       notice, this list of conditions and the following disclaimer.
C
C    * Redistributions in binary form must reproduce the above
C      copyright notice, this list of conditions and the following
C      disclaimer in the documentation and/or other materials provided
C      with the distribution.
C
C    * Neither the name of NTESS nor the names of its
C      contributors may be used to endorse or promote products derived
C      from this software without specific prior written permission.
C
C    THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
C    "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
C    LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
C    A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
C    OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
C    SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
C    LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
C    DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
C    THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
C    (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
C    OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
C

C $Id: dstort.f,v 1.2 2000/11/13 15:39:04 gdsjaar Exp $
C $Log: dstort.f,v $
C Revision 1.2  2000/11/13 15:39:04  gdsjaar
C Cleaned up unused variables and labels.
C
C Removed some real to int conversion warnings.
C
C Revision 1.1.1.1  1990/11/30 11:06:27  gdsjaar
C FASTQ Version 2.0X
C
c Revision 1.1  90/11/30  11:06:25  gdsjaar
c Initial revision
c
C
CC* FILE: [.PAVING]DSTORT.FOR
CC* MODIFIED BY: TED BLACKER
CC* MODIFICATION DATE: 7/6/90
CC* MODIFICATION: COMPLETED HEADER INFORMATION
C
      SUBROUTINE DSTORT (X1, X2, X3, X4, Y1, Y2, Y3, Y4, VALUE)
C***********************************************************************
C
C  SUBROUTINE DSTORT = CALCULATES A DISTORTION METRIC FOR AN ELEMENT
C                    USING THE IDEAS IN THE PAPER BY ODDY, 1988.
C
C***********************************************************************
C
C  SETUP THE JACOBIAN MATRIX
C
      XJ11 = (X1 * .125) + (X2 * .375) - (X3 * .375) - (X4 * .125)
      XJ12 = (Y1 * .125) + (Y2 * .375) - (Y3 * .375) - (Y4 * .125)
      XJ21 = - (X1 * .375) + (X2 * .375) + (X3 * .125) - (X4 * .125)
      XJ22 = - (Y1 * .375) + (Y2 * .375) + (Y3 * .125) - (Y4 * .125)
C
C  NORMALIZE THE JACOBIAN WITH RESPECT TO THE ELEMENT SIZE
C
      DETERM = (XJ11 * XJ22) - (XJ12 * XJ21)
      IF (DETERM .LE. 0.) THEN
         VALUE = 1.0E10
         RETURN
      ENDIF
      FACTOR = 1. / SQRT (DETERM)
      XJ11 = XJ11 * FACTOR
      XJ12 = XJ12 * FACTOR
      XJ21 = XJ21 * FACTOR
      XJ22 = XJ22 * FACTOR
C
C  NOW USE THE SECOND INVARIANT OF GREEN'S STRAIN
C
      C11 = XJ11*XJ11 + XJ21*XJ21
      C12 = XJ11*XJ12 + XJ21*XJ22
      C22 = XJ12*XJ12 + XJ22*XJ22
C
      VALUE = C11**2 + 2.*(C12**2) + C22**2 -
     &   (.5 * (C11+C22)**2 )
      VALUE = AMAX1 (VALUE, 0.)
C
      RETURN
C
      END


module fractions

  real*8, allocatable, save, public   :: polres(:,:)

! Using the continuous fraction aproximation to the fermi dirac function

  public :: fermi_dirac
  public :: cfermi_dirac
  public :: matsubara
  public :: expfrac
  public :: get_residues
  public :: frac_fd

  contains

  function fermi_dirac(x) result (fd)

    use constants,    only : kboltz
    use param,        only : fdtemp

    implicit none

    real*8, intent(in)  :: x
    real*8              :: fd, y

    y = x/(kboltz*fdtemp)
    fd = 1.0/(exp(y) + 1.0)

  end function fermi_dirac

  function cfermi_dirac(x) result (fd)

    use constants,    only : kboltz
    use param,        only : fdtemp

    implicit none

    complex*16, intent(in)  :: x
    complex*16              :: fd, y

    y = x/(kboltz*fdtemp)
    fd = 1.0/(exp(y) + 1.0)

  end function cfermi_dirac

  function matsubara(x) result (mats)

    use constants,    only : kboltz, twopi
    use param,        only : fdtemp, npoles

    implicit none

    integer                 :: ipol
    complex*16, intent(in)  :: x
    complex*16              :: mats, y
    real*8                  :: pi

    y = x/(kboltz*fdtemp)
    pi = twopi/2.0
    mats = 0.5
    do ipol = 1, npoles
       mats = mats - 2.0*y/(y**2.0+((2.0*ipol-1.0)**2)*(pi**2.0))
    end do

  end function matsubara

  function expfrac(x) result (efr)

    use constants,    only : kboltz
    use param,        only : fdtemp, npoles

    implicit none

    complex*16, intent(in)  :: x
    complex*16              :: efr, y

    y = x/(kboltz*fdtemp)
    efr = 1.0/(1.0 + (1.0+(y/npoles))**npoles)

  end function expfrac

  subroutine get_residues()

    use constants,          only : kboltz
    use utilities,          only : rutility_diag
    use param,              only : npoles, fdtemp

    implicit none

    real*8          :: A(npoles*2,npoles*2), B(npoles*2,npoles*2), &
                       D(npoles*2,npoles*2), eig(npoles*2), tmp(2)
    integer         :: ipol, ipol1

    A = 0.0
    B = 0.0
    D = 0.0

    do ipol = 1, npoles*2
       A(ipol,ipol) = real(2*ipol - 1)
    end do

    do ipol = 1, npoles*2 - 1
       B(ipol+1,ipol) = 0.5
       B(ipol,ipol+1) = 0.5
    end do

    do ipol = 1, npoles*2
       A(ipol,ipol) = 1.0/sqrt(A(ipol,ipol))
    end do

    D = matmul(A,matmul(B,A))

    call rutility_diag(D,eig,npoles*2)

    allocate(polres(2,npoles*2))

    do ipol = 1, npoles*2
       polres(1,ipol) = 1/eig(ipol)
       polres(2,ipol) = -(1.0/4.0)*(D(1,ipol)/eig(ipol))**2
    end do

    do ipol = 1, 2*npoles - 1
       do ipol1 = ipol + 1, 2*npoles
          if (polres(1,ipol) > polres(1,ipol1)) then
             tmp(:) = polres(:,ipol)
             polres(:,ipol) = polres(:,ipol1)
             polres(:,ipol1) = tmp(:)
          end if
       end do
    end do

  end subroutine get_residues

  function frac_fd(x) result (frac)

    use constants,             only : kboltz, cmplx_i
    use param,                 only : npoles, fdtemp

    complex*16, intent(in) :: x
    complex*16             :: frac, y
    integer                :: ipol

    y = x/(kboltz*fdtemp)

    frac = 0.5
    do ipol = 1, npoles
       frac = frac + polres(2,ipol+npoles)/(y-cmplx_i*polres(1,ipol+npoles)) + &
                     polres(2,ipol+npoles)/(y+cmplx_i*polres(1,ipol+npoles))
    end do

  end function frac_fd

end module fractions


C<8, 8>(i, j) = A<8>(i);

C<4, 8>(i, j) = A<4, 8, 4>(i, j, i);

C<20, 16>(i, j) = A<20, 8>(i, k) * B<8, 16>(k, j);

C<8, 4, 7>(n, k, l) = A<8, 16, 9>(n, c, l+r) * W<4, 16, 3>(k, c, r);

C<8, 4, 7>(n, k, l) = A<8, 16, 23>(n, c, l*3+r*2) * W<4, 16, 3>(k, c, r);


*DECK SQRDC
      SUBROUTINE SQRDC (X, LDX, N, P, QRAUX, JPVT, WORK, JOB)
C***BEGIN PROLOGUE  SQRDC
C***PURPOSE  Use Householder transformations to compute the QR
C            factorization of an N by P matrix.  Column pivoting is a
C            users option.
C***LIBRARY   SLATEC (LINPACK)
C***CATEGORY  D5
C***TYPE      SINGLE PRECISION (SQRDC-S, DQRDC-D, CQRDC-C)
C***KEYWORDS  LINEAR ALGEBRA, LINPACK, MATRIX, ORTHOGONAL TRIANGULAR,
C             QR DECOMPOSITION
C***AUTHOR  Stewart, G. W., (U. of Maryland)
C***DESCRIPTION
C
C     SQRDC uses Householder transformations to compute the QR
C     factorization of an N by P matrix X.  Column pivoting
C     based on the 2-norms of the reduced columns may be
C     performed at the user's option.
C
C     On Entry
C
C        X       REAL(LDX,P), where LDX .GE. N.
C                X contains the matrix whose decomposition is to be
C                computed.
C
C        LDX     INTEGER.
C                LDX is the leading dimension of the array X.
C
C        N       INTEGER.
C                N is the number of rows of the matrix X.
C
C        P       INTEGER.
C                P is the number of columns of the matrix X.
C
C        JPVT    INTEGER(P).
C                JPVT contains integers that control the selection
C                of the pivot columns.  The K-th column X(K) of X
C                is placed in one of three classes according to the
C                value of JPVT(K).
C
C                   If JPVT(K) .GT. 0, then X(K) is an initial
C                                      column.
C
C                   If JPVT(K) .EQ. 0, then X(K) is a free column.
C
C                   If JPVT(K) .LT. 0, then X(K) is a final column.
C
C                Before the decomposition is computed, initial columns
C                are moved to the beginning of the array X and final
C                columns to the end.  Both initial and final columns
C                are frozen in place during the computation and only
C                free columns are moved.  At the K-th stage of the
C                reduction, if X(K) is occupied by a free column,
C                it is interchanged with the free column of largest
C                reduced norm.  JPVT is not referenced if
C                JOB .EQ. 0.
C
C        WORK    REAL(P).
C                WORK is a work array.  WORK is not referenced if
C                JOB .EQ. 0.
C
C        JOB     INTEGER.
C                JOB is an integer that initiates column pivoting.
C                If JOB .EQ. 0, no pivoting is done.
C                If JOB .NE. 0, pivoting is done.
C
C     On Return
C
C        X       X contains in its upper triangle the upper
C                triangular matrix R of the QR factorization.
C                Below its diagonal X contains information from
C                which the orthogonal part of the decomposition
C                can be recovered.  Note that if pivoting has
C                been requested, the decomposition is not that
C                of the original matrix X but that of X
C                with its columns permuted as described by JPVT.
C
C        QRAUX   REAL(P).
C                QRAUX contains further information required to recover
C                the orthogonal part of the decomposition.
C
C        JPVT    JPVT(K) contains the index of the column of the
C                original matrix that has been interchanged into
C                the K-th column, if pivoting was requested.
C
C***REFERENCES  J. J. Dongarra, J. R. Bunch, C. B. Moler, and G. W.
C                 Stewart, LINPACK Users' Guide, SIAM, 1979.
C***ROUTINES CALLED  SAXPY, SDOT, SNRM2, SSCAL, SSWAP
C***REVISION HISTORY  (YYMMDD)
C   780814  DATE WRITTEN
C   890531  Changed all specific intrinsics to generic.  (WRB)
C   890831  Modified array declarations.  (WRB)
C   890831  REVISION DATE from Version 3.2
C   891214  Prologue converted to Version 4.0 format.  (BAB)
C   900326  Removed duplicate information from DESCRIPTION section.
C           (WRB)
C   920501  Reformatted the REFERENCES section.  (WRB)
C***END PROLOGUE  SQRDC
      INTEGER LDX,N,P,JOB
      INTEGER JPVT(*)
      REAL X(LDX,*),QRAUX(*),WORK(*)
C
      INTEGER J,JP,L,LP1,LUP,MAXJ,PL,PU
      REAL MAXNRM,SNRM2,TT
      REAL SDOT,NRMXL,T
      LOGICAL NEGJ,SWAPJ
C
C***FIRST EXECUTABLE STATEMENT  SQRDC
      PL = 1
      PU = 0
      IF (JOB .EQ. 0) GO TO 60
C
C        PIVOTING HAS BEEN REQUESTED.  REARRANGE THE COLUMNS
C        ACCORDING TO JPVT.
C
         DO 20 J = 1, P
            SWAPJ = JPVT(J) .GT. 0
            NEGJ = JPVT(J) .LT. 0
            JPVT(J) = J
            IF (NEGJ) JPVT(J) = -J
            IF (.NOT.SWAPJ) GO TO 10
               IF (J .NE. PL) CALL SSWAP(N,X(1,PL),1,X(1,J),1)
               JPVT(J) = JPVT(PL)
               JPVT(PL) = J
               PL = PL + 1
   10       CONTINUE
   20    CONTINUE
         PU = P
         DO 50 JJ = 1, P
            J = P - JJ + 1
            IF (JPVT(J) .GE. 0) GO TO 40
               JPVT(J) = -JPVT(J)
               IF (J .EQ. PU) GO TO 30
                  CALL SSWAP(N,X(1,PU),1,X(1,J),1)
                  JP = JPVT(PU)
                  JPVT(PU) = JPVT(J)
                  JPVT(J) = JP
   30          CONTINUE
               PU = PU - 1
   40       CONTINUE
   50    CONTINUE
   60 CONTINUE
C
C     COMPUTE THE NORMS OF THE FREE COLUMNS.
C
      IF (PU .LT. PL) GO TO 80
      DO 70 J = PL, PU
         QRAUX(J) = SNRM2(N,X(1,J),1)
         WORK(J) = QRAUX(J)
   70 CONTINUE
   80 CONTINUE
C
C     PERFORM THE HOUSEHOLDER REDUCTION OF X.
C
      LUP = MIN(N,P)
      DO 200 L = 1, LUP
         IF (L .LT. PL .OR. L .GE. PU) GO TO 120
C
C           LOCATE THE COLUMN OF LARGEST NORM AND BRING IT
C           INTO THE PIVOT POSITION.
C
            MAXNRM = 0.0E0
            MAXJ = L
            DO 100 J = L, PU
               IF (QRAUX(J) .LE. MAXNRM) GO TO 90
                  MAXNRM = QRAUX(J)
                  MAXJ = J
   90          CONTINUE
  100       CONTINUE
            IF (MAXJ .EQ. L) GO TO 110
               CALL SSWAP(N,X(1,L),1,X(1,MAXJ),1)
               QRAUX(MAXJ) = QRAUX(L)
               WORK(MAXJ) = WORK(L)
               JP = JPVT(MAXJ)
               JPVT(MAXJ) = JPVT(L)
               JPVT(L) = JP
  110       CONTINUE
  120    CONTINUE
         QRAUX(L) = 0.0E0
         IF (L .EQ. N) GO TO 190
C
C           COMPUTE THE HOUSEHOLDER TRANSFORMATION FOR COLUMN L.
C
            NRMXL = SNRM2(N-L+1,X(L,L),1)
            IF (NRMXL .EQ. 0.0E0) GO TO 180
               IF (X(L,L) .NE. 0.0E0) NRMXL = SIGN(NRMXL,X(L,L))
               CALL SSCAL(N-L+1,1.0E0/NRMXL,X(L,L),1)
               X(L,L) = 1.0E0 + X(L,L)
C
C              APPLY THE TRANSFORMATION TO THE REMAINING COLUMNS,
C              UPDATING THE NORMS.
C
               LP1 = L + 1
               IF (P .LT. LP1) GO TO 170
               DO 160 J = LP1, P
                  T = -SDOT(N-L+1,X(L,L),1,X(L,J),1)/X(L,L)
                  CALL SAXPY(N-L+1,T,X(L,L),1,X(L,J),1)
                  IF (J .LT. PL .OR. J .GT. PU) GO TO 150
                  IF (QRAUX(J) .EQ. 0.0E0) GO TO 150
                     TT = 1.0E0 - (ABS(X(L,J))/QRAUX(J))**2
                     TT = MAX(TT,0.0E0)
                     T = TT
                     TT = 1.0E0 + 0.05E0*TT*(QRAUX(J)/WORK(J))**2
                     IF (TT .EQ. 1.0E0) GO TO 130
                        QRAUX(J) = QRAUX(J)*SQRT(T)
                     GO TO 140
  130                CONTINUE
                        QRAUX(J) = SNRM2(N-L,X(L+1,J),1)
                        WORK(J) = QRAUX(J)
  140                CONTINUE
  150             CONTINUE
  160          CONTINUE
  170          CONTINUE
C
C              SAVE THE TRANSFORMATION.
C
               QRAUX(L) = X(L,L)
               X(L,L) = -NRMXL
  180       CONTINUE
  190    CONTINUE
  200 CONTINUE
      RETURN
      END


*> \brief \b dladivquad performs complex division in real arithmetic, avoiding unnecessary overflow.
*
*  =========== DOCUMENTATION ===========
*
* Online html documentation available at
*            http://www.netlib.org/lapack/explore-html/
*
*> \htmlonly
*> Download dladivquad + dependencies
*>
*> [TGZ]
*>
*> [ZIP]
*>
*> [TXT]
*> \endhtmlonly
*
*  Definition:
*  ===========
*
*       SUBROUTINE dladivquad( A, B, C, D, P, Q )
*
*       .. Scalar Arguments ..
*       real*16   A, B, C, D, P, Q
*       ..
*
*
*> \par Purpose:
*  =============
*>
*> \verbatim
*>
*> dladivquad performs complex division in  real arithmetic
*>
*>                       a + i*b
*>            p + i*q = ---------
*>                       c + i*d
*>
*> The algorithm is due to Michael Baudin and Robert L. Smith
*> and can be found in the paper
*> "A Robust Complex Division in Scilab"
*> \endverbatim
*
*  Arguments:
*  ==========
*
*> \param[in] A
*> \verbatim
*>          A is real*16
*> \endverbatim
*>
*> \param[in] B
*> \verbatim
*>          B is real*16
*> \endverbatim
*>
*> \param[in] C
*> \verbatim
*>          C is real*16
*> \endverbatim
*>
*> \param[in] D
*> \verbatim
*>          D is real*16
*>          The scalars a, b, c, and d in the above expression.
*> \endverbatim
*>
*> \param[out] P
*> \verbatim
*>          P is real*16
*> \endverbatim
*>
*> \param[out] Q
*> \verbatim
*>          Q is real*16
*>          The scalars p and q in the above expression.
*> \endverbatim
*
*  Authors:
*  ========
*
*> \author Univ. of Tennessee
*> \author Univ. of California Berkeley
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
*> \date January 2013
*
*> \ingroup auxOTHERauxiliary
*
*  =====================================================================
      SUBROUTINE dladivquad( A, B, C, D, P, Q )
*
*  -- LAPACK auxiliary routine (version 3.5.0) --
*  -- LAPACK is a software package provided by Univ. of Tennessee,    --
*  -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
*     January 2013
*
*     .. Scalar Arguments ..
      real*16   A, B, C, D, P, Q
*     ..
*
*  =====================================================================
*
*     .. Parameters ..
      real*16   BS
      PARAMETER          ( BS = 2.0q0 )
      real*16   HALF
      PARAMETER          ( HALF = 0.5q0 )
      real*16   TWO
      PARAMETER          ( TWO = 2.0q0 )
*
*     .. Local Scalars ..
      real*16   AA, BB, CC, DD, AB, CD, S, OV, UN, BE, EPS
*     ..
*     .. External Functions ..
      real*16   dlamchquad
      EXTERNAL           dlamchquad
*     ..
*     .. External Subroutines ..
      EXTERNAL           dladivquad1
*     ..
*     .. Intrinsic Functions ..
      INTRINSIC          ABS, MAX
*     ..
*     .. Executable Statements ..
*
      AA = A
      BB = B
      CC = C
      DD = D
      AB = MAX( ABS(A), ABS(B) )
      CD = MAX( ABS(C), ABS(D) )
      S = 1.0q0

      OV = dlamchquad( 'Overflow threshold' )
      UN = dlamchquad( 'Safe minimum' )
      EPS = dlamchquad( 'Epsilon' )
      BE = BS / (EPS*EPS)

      IF( AB >= HALF*OV ) THEN
         AA = HALF * AA
         BB = HALF * BB
         S  = TWO * S
      END IF
      IF( CD >= HALF*OV ) THEN
         CC = HALF * CC
         DD = HALF * DD
         S  = HALF * S
      END IF
      IF( AB <= UN*BS/EPS ) THEN
         AA = AA * BE
         BB = BB * BE
         S  = S / BE
      END IF
      IF( CD <= UN*BS/EPS ) THEN
         CC = CC * BE
         DD = DD * BE
         S  = S * BE
      END IF
      IF( ABS( D ).LE.ABS( C ) ) THEN
         CALL dladivquad1(AA, BB, CC, DD, P, Q)
      ELSE
         CALL dladivquad1(BB, AA, DD, CC, P, Q)
         Q = -Q
      END IF
      P = P * S
      Q = Q * S
*
      RETURN
*
*     End of dladivquad
*
      END

      SUBROUTINE dladivquad1( A, B, C, D, P, Q )
*
*  -- LAPACK auxiliary routine (version 3.5.0) --
*  -- LAPACK is a software package provided by Univ. of Tennessee,    --
*  -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
*     January 2013
*
*     .. Scalar Arguments ..
      real*16   A, B, C, D, P, Q
*     ..
*
*  =====================================================================
*
*     .. Parameters ..
      real*16   ONE
      PARAMETER          ( ONE = 1.0q0 )
*
*     .. Local Scalars ..
      real*16   R, T
*     ..
*     .. External Functions ..
      real*16   dladivquad2
      EXTERNAL           dladivquad2
*     ..
*     .. Executable Statements ..
*
      R = D / C
      T = ONE / (C + D * R)
      P = dladivquad2(A, B, C, D, R, T)
      A = -A
      Q = dladivquad2(B, A, C, D, R, T)
*
      RETURN
*
*     End of dladivquad1
*
      END

      real*16 FUNCTION dladivquad2( A, B, C, D, R, T )
*
*  -- LAPACK auxiliary routine (version 3.5.0) --
*  -- LAPACK is a software package provided by Univ. of Tennessee,    --
*  -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
*     January 2013
*
*     .. Scalar Arguments ..
      real*16   A, B, C, D, R, T
*     ..
*
*  =====================================================================
*
*     .. Parameters ..
      real*16   ZERO
      PARAMETER          ( ZERO = 0.0q0 )
*
*     .. Local Scalars ..
      real*16   BR
*     ..
*     .. Executable Statements ..
*
      IF( R.NE.ZERO ) THEN
         BR = B * R
         if( BR.NE.ZERO ) THEN
            dladivquad2 = (A + BR) * T
         ELSE
            dladivquad2 = A * T + (B * T) * R
         END IF
      ELSE
         dladivquad2 = (A + D * (B / C)) * T
      END IF
*
      RETURN
*
*     End of dladivquad12
*
      END


C**********************************************************************
C    SIMPLE HISTOGRAMMING PACKAGE --  SIMPLIFIED VERSION OF HBOOK
C    BY Michelangelo Mangano    NOVEMBER 1988
C    LAST REVISED NOVEMBER 9, 1988
C    LAST REVISED JUNE 12, 1989  (ADD SCATTER PLOTS)
C    LAST REVISED oct 1990 (Add multi-plots on one page, routines MULTITOP,
C         			MTFILL,...)
C    LAST REVISED Jun 2003 by FM: passed to double precision AND
C    included the date for linux
C    LAST REVISED Jun 2008 by OM: add inverse function
C    LAST REVISED Oct 2009 by AP/OM: possibility of multiple independent
C                        set of histo.
C**********************************************************************
C
C Fills up to 200 histograms with up to 100 bins.
C Gives a data file (to be specified in the calling program by assigning
C a file name to unit 98) and a topdrawer file (to be specified in the
C calling program by assigning a file name to unit 99).
C
C INITIALIZATION:
C Call once INIHIST; this just resets a few counters and logicals
C Call MBOOK(M,N,'TITLE',DEL,XMIN,XMAX) for each histogram to be booked.
C M (an integer) is the label of the histogram object (by default M=1)
C N (an integer) is the label of the histogram;
C 'TITLE' is the name of the histogram (no more then 100 characters);
C DEL (real*8) is the bin size;
C XMIN (real*8) is the lower limit of the first bin;
C XMAX (real*8)is the upper limit of the last  bin
C Example:
C      call mbook(1,2,'pt distribution',1.,10,70)
C This call initializes histogram number 2, called 'pt distribution';
C The bin size will be 1. (possibly GeV, if that's what you want), the
C first bin being  10<x<11. and the last one being 69.<x<70
C
C FILLING:
C When it's time, call MFILL(M,N,X,Y); this will add Y (real*8) to the bin
C in which X (real*8) happens to be, within histogram (M,N).
C
C PLAYING AROUND:
C At the end of the day you may want to sum, divide, cancel, etc.etc.
C various histograms (bin by bin). Then you call MOPERA(M,I,'O',J,K,X,Y).
C The 1-character string O can take the following values:
C +  : sums       X*(hist I) with Y*(hist J) and puts the result in hist K;
C -  : subtracts  X*(hist I) with Y*(hist J) and puts the result in hist K;
C *  : multiplies X*(hist I) with Y*(hist J) and puts the result in hist K;
C /  : divides    X*(hist I) with Y*(hist J) and puts the result in hist K;
C I  : inverses hist I and put the results [X*(1/I)]  in hist K;
C F  : multiplies hist I by the factor X, and puts the result in hist K;
C R  : takes the square root of  hist  I, and puts the result in hist K;if
C      the value at a given bin is less than or equal to 0, puts 0 in K
C S  : takes the square      of  hist  I, and puts the result in hist K;
C L  : takes the log_10 of  hist  I, and puts the result in hist K; if the
C      value at a given bin is less than or equal to 0, puts 0 in K
C M  : statistical analysis; if I contains the weights (let's say WGT),
C      J contains variable times weight (F*WGT) and K contains the
C      variable squared times the weight (F**2*WGT), then, after using 'M',
C      J will contain the average value of the variable <F> and K will
C      contain the sigma of the average: sigma=sqrt(<F**2>-<F>**2).
C      If WGT=1. for all the entries, then it is enough to put I=J, and
C      it is not necessary to book a hist with the weights.
C V  : estimates errors for vegas evaluation of differential distributions.
C      Fill I with the values of
C      the functions do integrate times the Vegas weight (fun*wgt); fill
C      J with fun**2*wgt; then K will contain an estimate of the error
C      of the integration. Putting X=1/(#of iterations) performs the
C      avegare over the iterations, and gives the right normalization to
C      the differential distribution, I, and to the errors, K. J stays the same.
C
C FINAL ACCOUNTING:
C Now we can finalize our histograms; MFINAL(M,N) will calculate the integral
C of the histogram (M,N), the mean value of the X variable and its RMS.
C If we now want to renormalize the hist's, we can call MNORM(M,N,X), which
C will normalize the integral to X  -- CAUTION: do not call MNORM before
C MFINAL, it will blow up.
C
C OUTPUT:
C To get a .dat file containing the values of the histograms, together with
C some information (like integral, mean values, etc.etc.) call MPRINT(N),
C for each hist N that you want in the .dat file. Before the call to MPRINT
C you want to open unit 98 and give it a name:
C     OPEN(UNIT=98,NAME='NAME.DAT',STATUS='NEW')
C If you want a topdrawer file with a plot of the hist values, call
C MTOP(M,N,L,'X','Y','SCALE').
c The points of the plot will be taken from histogram
C (M,N), the error bars from histogram (M,L). 'SCALE', character*(*), determines
C the scale for y, logarithmic or linear (SCALE=LOG,LIN).
C If you do not want error bars, keep
C a histogram of zeros, or just call a hist that had not been booked.
C X will appear as a 'bottom title', and Y will appear as a 'left title'.
C The top title is by default the name of the histogram itself.
C A little box below the plot will contain some information on the plot
C itself. Before calling MTOP,
C     OPEN(UNIT=99,NAME='NAME.TOP',STATUS='NEW')
C--------------------------------------------------------------------------
C
C  COMMON/HISTO/  Histogram N
C
C   BOOK(N,M),      Three-letter character-string: 'NO' if histogram was not
C		  Booked, 'YES' otherwise
C   TITLE(N,M),     Title of the histogram
C
C   HMIN(N,M),      Min value of x range
C   HMAX(N,M),      Max value of x range
C   HDEL(N,M),      Bin width
C   NBIN(N,M),      Total number of bins
C   USCORE(N,M),    Total integral of underscores with x < HMIN(N,M)
C   OSCORE(N,M),    Total integral of onderscores with x > HMAX(N,M)
C   IUSCORE(N,M),   Number of entries with x < HMIN(N,M)
C   IOSCORE(N,M),   Number of entries with x > HMAX(N,M)
C   IENT(N,M),      Total number of entries within x range HMIN(N,M)<x<HMAX(N,M)
C   HINT(N,M),      Integral of the histogram within HMIN(N,M)<x<HMAX(N,M)
C   HAVG(N,M),      Average value of x, weighted over the x range of the histo
C   HSIG(N,M),      Quadratic dispersion of x around the average
C   HIST(N,L,M),    Value of bin L-th
C   XHIS(N,L,M),    Central x value of bin L-th
C   IHIS(N,L,M),    Number of entries within bin L-th
C   NHIST(M)         Total number of booked histograms
C
      SUBROUTINE INIHIST
C*************************************************************
c     initialization
      IMPLICIT NONE
      include 'dbook.inc'
c
c     LOCAL
c
      INTEGER I,J
C
C     START
C
      DO J=1, NHistoVar
      NHist(J)=0
      DO  I=1,NHistoByVar
      BOOK(I,J)=' NO'
      ENDDO
      ENDDO
      END

      SUBROUTINE MBOOK(M,N,TIT,DEL,XMIN,XMAX)
C*************************************************************
      IMPLICIT NONE
C
C     ARGUMENTS
C
      INTEGER N,M
      CHARACTER*20 TIT
      REAL*8 DEL,XMIN,XMAX
C
C     GLOBAL
C
      include 'dbook.inc'
C
C     LOCAL
C
      INTEGER I,J
C
C     START
C
      IF(M.gt.NHistovar.or.abs(N).gt.NHistobyvar) THEN
         Write(*,*) 'histogram input exceeded definition range'
         Write(*,*) 'input',M,N,' for limit ',Nhistovar,NHistoByVar
         STOP
      endif
      NHIST(M) = MAX(N,NHIST(M))
      IF(BOOK(N,M)(1:1).EQ.'Y') THEN
	 CALL MWARN('MBOOK')
         WRITE(*,*) 'Histogram',N,M,TITLE(N,M),' already in use. '
         WRITE(*,*) 'superseded by ',TIT
      ENDIF
      BOOK(N,M) = 'YES'
      TITLE(N,M) = ' '//TIT
1     HDEL(N,M) = DEL
      NBIN(N,M) = INT((XMAX-XMIN)/DEL+0.00001d0)
      IF(NBIN(N,M).GT.NHistoBin) THEN
	WRITE(*,*) 'TOO MANY BINS (',NBIN(N,M),') REQUIRED IN HIST ',N,M
	WRITE(*,*) 'RE-ENTER BIN SIZE DELTA (OLD BIN = ',DEL,' ):'
	READ(*,*) DEL
	GO TO 1
      ENDIF
      HMIN(N,M) = XMIN
      HMAX(N,M) = NBIN(N,M)*DEL+XMIN
      IF(abs(HMAX(N,M)-XMAX).gt.0.001d0) THEN
	 CALL MWARN('MBOOK')
         WRITE(*,*)
     #'Histogram ', TIT, ' Change of upper limit:',xmax,'-->',HMAX(N,M)
      ENDIF
      IENT(N,M) = 0
      IUSCORE(N,M) = 0
      IOSCORE(N,M) = 0
      USCORE(N,M) = 0
      OSCORE(N,M) = 0
      HAVG(N,M) = 0
      HINT(N,M) = 0
      HSIG(N,M) = 0
      DO I=1,NBIN(N,M)
         XHIS(N,I,M)=HMIN(N,M)+HDEL(N,M)*(DFLOAT(I)-0.5d0)
         IHIS(N,I,M)=0
         HIST(N,I,M)=0
      ENDDO
      END

      SUBROUTINE MFILL(M,N,X,Y)
C*************************************************************
      IMPLICIT NONE
C
C     ARGUMENTS
C
      INTEGER N,M
      REAL*8 X,Y
C
C     LOCAL
C
      REAL*8 XI
      INTEGER I
C
C     GLOBAL
C
      INCLUDE 'dbook.inc'
c
c     START
c
      IF(X.LT.HMIN(N,M)) THEN
         USCORE(N,M) = USCORE(N,M) + Y
         IUSCORE(N,M) = IUSCORE(N,M) + 1
      ELSEIF(X.GT.HMAX(N,M)) THEN
         OSCORE(N,M) = OSCORE(N,M) + Y
         IOSCORE(N,M) = IOSCORE(N,M) + 1
      ELSE
         XI=((X-HMIN(N,M))/HDEL(N,M))+1
         I=INT(XI)
         IENT(N,M)=IENT(N,M)+1
         IHIS(N,I,M)=IHIS(N,I,M)+1
         HIST(N,I,M)=HIST(N,I,M)+Y
      ENDIF
      END

      SUBROUTINE MINTEG(MN,NIN,NOUT,IDIR,IPOW)
C*************************************************************
C If IPOW=1 performs the integral of the distribution contained in histogram
C NIN up to the value specified by the abscissa (if IDIR=1) or from this
C value on (if IDIR=-1). The resulting integral distribution is put into
C NOUT, which is automatically booked if NOUT.ne.NIN .  Choosing IPOW=2
C the routine will return the square root of the integral of the squares,
C as is required, for example, for the propagation of the mean quadratic error
C of a given distribution. Overscores and underscores are included.
      IMPLICIT NONE
C
C     ARGUMENTS
C
      INTEGER NIN,NOUT,IDIR,IPOW,MN
C
C     GLOBAL
C
      INCLUDE 'dbook.inc'
c
c     LOCAL
c
      INTEGER M,I,L
      CHARACTER*14  C
      DIMENSION C(2)
      DATA C/' INTEG BELOW X',' INTEG ABOVE X'/
C
C     EXTERNAL
C
      REAL*8 SUMPOW
C
C     START
C
      M = NBIN(NIN,MN)
      I = (IDIR + 3)/2
      IF(NOUT.NE.NIN) THEN
      	CALL MBOOK(MN,NOUT,TITLE(NIN,MN)//C(I),
     &                HDEL(NIN,MN),HMIN(NIN,MN),HMAX(NIN,MN))
      ENDIF
      IF(IDIR.EQ.1) THEN
         HIST(NOUT,1,MN) = SUMPOW(HIST(NIN,1,MN),USCORE(NIN,MN),IPOW)
         IHIS(NOUT,1,MN) = IHIS(NIN,1,MN) + IUSCORE(NIN,MN)
         XHIS(NOUT,1,MN) = XHIS(NIN,1,MN) + HDEL(NIN,MN)/2
         DO L=2,M
            HIST(NOUT,L,MN) = SUMPOW(HIST(NIN,L,MN),HIST(NOUT,L-1,MN),IPOW)
            IHIS(NOUT,L,MN) = IHIS(NIN,L,MN) + IHIS(NOUT,L-1,MN)
            XHIS(NOUT,L,MN) = XHIS(NIN,L,MN) + HDEL(NIN,MN)/2
         ENDDO
         OSCORE(NOUT,MN) = SUMPOW(OSCORE(NIN,MN),HIST(NIN,M,MN),IPOW)
         IOSCORE(NOUT,MN) = IOSCORE(NIN,MN) + IHIS(NIN,M,MN)
      ELSEIF(IDIR.EQ.-1) THEN
         HIST(NOUT,M,MN) = SUMPOW(HIST(NIN,M,MN),OSCORE(NIN,MN),IPOW)
         IHIS(NOUT,M,MN) = IHIS(NIN,M,MN) + IOSCORE(NIN,MN)
         XHIS(NOUT,M,MN) = XHIS(NIN,M,MN) - HDEL(NIN,MN)/2
         DO L=M-1,1,-1
            HIST(NOUT,L,MN) = SUMPOW(HIST(NIN,L,MN),HIST(NOUT,L+1,MN),IPOW)
            IHIS(NOUT,L,MN) = IHIS(NIN,L,MN) + IHIS(NOUT,L+1,MN)
            XHIS(NOUT,L,MN) = XHIS(NIN,L,MN) - HDEL(NIN,MN)/2
         ENDDO
         USCORE(NOUT,MN) = SUMPOW(USCORE(NIN,MN),HIST(NIN,MN,1),IPOW)
         IUSCORE(NOUT,MN) = IUSCORE(NIN,MN)+IHIS(NIN,MN,1)
      ELSE
         CALL MWARN('MINTEG')
         WRITE(*,*) 'Wrong idir in minteg: OPERATION NOT PERFORMED'
         RETURN
      ENDIF
      END

      REAL*8 FUNCTION SUMPOW(X,Y,IPOW)
C*************************************************************
      IMPLICIT NONE
C
C     ARGUMENTS
C
      REAL*8 X,Y
      INTEGER IPOW
C
C     START
C
      IF(IPOW.EQ.1) THEN
         SUMPOW = X + Y
      ELSEIF(IPOW.EQ.2) THEN
         SUMPOW = DSQRT(X**2+Y**2)
      ELSEIF(IPOW.EQ.0) THEN
         CALL MWARN('SUMPOW')
         WRITE(*,*)'Error: IPOW=0 not allowed in SUMPOW'
      ELSE
         SUMPOW = (X**IPOW+Y**IPOW)**(1./IPOW)
      ENDIF
      END

      SUBROUTINE MOPERA(M,I,OPER,J,K,X,Y)
C*************************************************************
      IMPLICIT NONE
C
C     ARGUMENTS
C
      INTEGER M,I,J,K
      CHARACTER OPER*1
      REAL*8 X,Y
C
C     LOCAL
C
      REAL*8 XXX,XSUM,XSUMSQ,XNORM,XAVG,XSQAVG
      INTEGER L
C
C     GLOBAL
C
      INCLUDE 'dbook.inc'
C
C     START
C
      IF(NBIN(I,M).NE.NBIN(J,M).AND.(OPER.EQ.'+'.OR.OPER.EQ.'-'.OR.OPER.EQ.
     &    '*'.OR.OPER.EQ.'/'.OR.OPER.EQ.'M'.OR.OPER.EQ.'A')) THEN
	  CALL MWARN('MOPERA')
          WRITE(*,*) M,I,J
  20      FORMAT(' ****** INCOMPATIBLE OPERATION HIST ',I2,' &',I2,
     &    '*******'/)
          RETURN
      ENDIF
      IF(OPER.EQ.'E') THEN
c If I contains the accumulated weights, J the accumulated squares of the
c weights and IHIS(J,1) the number of accumulated entries, 'E' will add
c the average value of I to K and will put in J the quadratic dispersion.
         IF(IHIS(J,1,M).NE.0) THEN
            XXX = 1./IHIS(J,1,M)
         ELSE
            XXX = 0
         ENDIF
         DO L=1,NBIN(I,M)
            XSUM   = HIST(I,L,M)
            XSUMSQ = HIST(J,L,M)
            HIST(K,L,M)=HIST(K,L,M) + XXX*HIST(I,L,M)
            HIST(J,L,M)=XXX*DSQRT(ABS(XSUMSQ-XSUM**2*XXX))
         ENDDO
         IENT(K,M)=IENT(K,M)+IENT(I,M)
         XSUM = USCORE(I,M)
         XSUMSQ = USCORE(J,M)
         USCORE(K,M) = USCORE(K,M)+XXX*XSUM
         USCORE(J,M) = XXX*DSQRT(ABS(XSUMSQ-XSUM**2*XXX))
         XSUM = OSCORE(I,M)
         XSUMSQ = OSCORE(J,M)
         OSCORE(K,M) = OSCORE(K,M)+XXX*XSUM
         OSCORE(J,M) = XXX*DSQRT(ABS(XSUMSQ-XSUM**2*XXX))
      ELSEIF(OPER.EQ.'Q') THEN
         DO L=1,NBIN(I,M)
            HIST(K,L,M) = SQRT(HIST(J,L,M)**2+HIST(I,L,M)**2)
         ENDDO
         USCORE(K,M) = SQRT(USCORE(J,M)**2+USCORE(I,M)**2)
         OSCORE(K,M) = SQRT(OSCORE(J,M)**2+OSCORE(I,M)**2)
      ELSEIF(OPER.EQ.'A') THEN
         DO L=1,NBIN(I,M)
            HIST(J,L,M) = HIST(J,L,M) + HIST(I,L,M)
            IHIS(J,L,M) = IHIS(J,L,M) + IHIS(I,L,M)
            HIST(K,L,M) = HIST(K,L,M) + HIST(I,L,M)**2
            IHIS(K,L,M) = IHIS(K,L,M) + 1
            IENT(K,M) = IENT(K,M)+1
            HIST(I,L,M) = 0
            IHIS(I,L,M) = 0
         ENDDO
         IENT(J,M) = IENT(J,M)+IENT(I,M)
         IUSCORE(J,M) = IUSCORE(J,M) + IUSCORE(I,M)
         USCORE(J,M) = USCORE(J,M) + USCORE(I,M)
         IOSCORE(J,M) = IOSCORE(J,M) + IOSCORE(I,M)
         OSCORE(J,M) = OSCORE(J,M) + OSCORE(I,M)
         IUSCORE(K,M) = IUSCORE(K,M) + 1
         USCORE(K,M) = USCORE(K,M) + USCORE(I,M)**2
         IOSCORE(K,M) = IOSCORE(K,M) + 1
         OSCORE(K,M) = OSCORE(K,M) + OSCORE(I,M)**2
         IENT(I,M) = 0
         IUSCORE(I,M) = 0
         IOSCORE(I,M) = 0
         USCORE(I,M) = 0
         OSCORE(I,M) = 0
      ELSE
        DO L=1,NBIN(I,M)
      	IF(OPER.EQ.'+') THEN
       	  HIST(K,L,M)=X*HIST(I,L,M) + Y*HIST(J,L,M)
      	ELSEIF(OPER.EQ.'-') THEN
      	  HIST(K,L,M)=X*HIST(I,L,M) - Y*HIST(J,L,M)
      	ELSEIF(OPER.EQ.'*') THEN
      	  HIST(K,L,M)=X*HIST(I,L,M) * Y*HIST(J,L,M)
      	ELSEIF(OPER.EQ.'/') THEN
          IF(Y.EQ.0..OR.HIST(J,L,M).EQ.0.) THEN
            HIST(K,L,M)=0.
          ELSE
            HIST(K,L,M)=X*HIST(I,L,M) / (Y*HIST(J,L,M))
          ENDIF
      	ELSEIF(OPER.EQ.'I') THEN
          IF(HIST(I,L,M).EQ.0.) THEN
            HIST(K,L,M)=0.
          ELSE
            HIST(K,L,M)=X/HIST(I,L,M)
          ENDIF
       	ELSEIF(OPER.EQ.'F') THEN
      	  HIST(K,L,M)=X*HIST(I,L,M)
      	ELSEIF(OPER.EQ.'R') THEN
          IF(HIST(I,L,M).GT.0.) THEN
            HIST(K,L,M)=X*DSQRT(HIST(I,L,M))
          ELSE
            HIST(K,L,M)=0.
          ENDIF
      	ELSEIF(OPER.EQ.'S') THEN
          HIST(K,L,M)=X*HIST(I,L,M)**2
      	ELSEIF(OPER.EQ.'L') THEN
          IF(HIST(I,L,M).EQ.0..OR.J.EQ.0.) THEN
             HIST(K,L,M)=0.
           ELSE
             HIST(K,L,M)=X*LOG10(Y*HIST(I,L,M))
           ENDIF
      	ELSEIF(OPER.EQ.'M') THEN
           IF(I.NE.J) XNORM=HIST(I,L,M)
           IF(I.EQ.J) XNORM=DFLOAT(IHIS(J,L,M))
           IF(XNORM.NE.0.) THEN
             XAVG=HIST(J,L,M)/XNORM
             HIST(K,L,M)=
     &       DSQRT(ABS(-XAVG**2+HIST(K,L,M)/XNORM)/DFLOAT(IHIS(I,L,M)))
             HIST(J,L,M)=XAVG
           ELSE
             HIST(K,L,M)=0.
             HIST(J,L,M)=0.
           ENDIF
      	ELSEIF(OPER.EQ.'V') THEN
           XAVG=HIST(I,L,M)*X
           XSQAVG=HIST(J,L,M)*X
           XNORM=DFLOAT(IHIS(I,L,M))*X
           IF(XNORM.NE.0.) THEN
              HIST(K,L,M)=DSQRT(ABS(XSQAVG-XAVG**2)/XNORM)
              HIST(I,L,M)=XAVG
           ELSE
              HIST(K,L,M)=0.
           ENDIF
      	ELSE
	 CALL MWARN('MOPERA')
         WRITE(*,*) OPER
   5     FORMAT(' ****** OPERATION ="',A1,'" UNKNOWN ********'/)
         RETURN
        ENDIF
        ENDDO
      	IF(OPER.EQ.'+') THEN
       	  USCORE(K,M)=X*USCORE(I,M) + Y*USCORE(J,M)
       	  OSCORE(K,M)=X*OSCORE(I,M) + Y*OSCORE(J,M)
      	ELSEIF(OPER.EQ.'-') THEN
      	  USCORE(K,M)=X*USCORE(I,M) - Y*USCORE(J,M)
      	  OSCORE(K,M)=X*OSCORE(I,M) - Y*OSCORE(J,M)
      	ELSEIF(OPER.EQ.'*') THEN
      	  USCORE(K,M)=X*USCORE(I,M) * Y*USCORE(J,M)
      	  OSCORE(K,M)=X*OSCORE(I,M) * Y*OSCORE(J,M)
      	ELSEIF(OPER.EQ.'/') THEN
          IF(Y.EQ.0..OR.USCORE(J,M).EQ.0.) THEN
            USCORE(K,M)=0.
          ELSE
            USCORE(K,M)=X*USCORE(I,M) / (Y*USCORE(J,M))
          ENDIF
          IF(Y.EQ.0..OR.OSCORE(J,M).EQ.0.) THEN
            OSCORE(K,M)=0.
          ELSE
            OSCORE(K,M)=X*OSCORE(I,M) / (Y*OSCORE(J,M))
          ENDIF
      	ELSEIF(OPER.EQ.'I') THEN
          IF(X.EQ.0..OR.USCORE(I,M).EQ.0.) THEN
            USCORE(K,M)=0.
          ELSE
            USCORE(K,M)=X / (USCORE(I,M))
          ENDIF
          IF(X.EQ.0..OR.OSCORE(I,M).EQ.0.) THEN
            OSCORE(K,M)=0.
          ELSE
            OSCORE(K,M)=X / (OSCORE(I,M))
          ENDIF
       	ELSEIF(OPER.EQ.'F') THEN
      	  USCORE(K,M)=X*USCORE(I,M)
      	  OSCORE(K,M)=X*OSCORE(I,M)
      	ELSEIF(OPER.EQ.'R') THEN
          IF(USCORE(I,M).GT.0.) THEN
            USCORE(K,M)=X*DSQRT(USCORE(I,M))
          ELSE
            USCORE(K,M)=0.
          ENDIF
          IF(OSCORE(I,M).GT.0.) THEN
            OSCORE(K,M)=X*DSQRT(OSCORE(I,M))
          ELSE
            OSCORE(K,M)=0.
          ENDIF
      	ELSEIF(OPER.EQ.'S') THEN
          USCORE(K,M)=X*USCORE(I,M)**2
          OSCORE(K,M)=X*OSCORE(I,M)**2
      	ELSEIF(OPER.EQ.'L') THEN
          IF(USCORE(I,M).EQ.0..OR.J.EQ.0.) THEN
             USCORE(K,M)=0.
           ELSE
             USCORE(K,M)=X*LOG10(Y*USCORE(I,M))
           ENDIF
          IF(OSCORE(I,M).EQ.0..OR.J.EQ.0.) THEN
             OSCORE(K,M)=0.
           ELSE
             OSCORE(K,M)=X*LOG10(Y*OSCORE(I,M))
           ENDIF
        ENDIF
      ENDIF
      RETURN
      END

      SUBROUTINE MZERO(M,N)
C*************************************************************
      IMPLICIT NONE
C
C     ARGUMENTS
C
      INTEGER M,N
C
C     LOCAL
C
      INTEGER I
C
C     GLOBAL
C
      INCLUDE 'dbook.inc'
C
C     START
C
      BOOK(N,M)='RES'
      IENT(N,M)=0
      IUSCORE(N,M)=0
      IOSCORE(N,M)=0
      HAVG(N,M)=0.
      HINT(N,M)=0.
      DO 1 I=1,NBIN(N,M)
   1  HIST(N,I,M)=0.
      END

      SUBROUTINE MRESET(M,N)
C*************************************************************
      IMPLICIT NONE
C
C     ARGUMENTS
C
      INTEGER M,N
C
C     GLOBAL
C
      INCLUDE 'dbook.inc'
C
C     START
C
      BOOK(N,M)='RES'
      END

      SUBROUTINE PUTTAG(M,J,NAME)
C*************************************************************
c Per marcare un istogramma
      IMPLICIT NONE
C
C     ARGUMENTS
C
      CHARACTER*20 NAME
      INTEGER M,J
C
C     GLOBAL
C
      INCLUDE 'dbook.inc'
C
C     LOCAL
C
      CHARACTER*20 TAG
C
C     START
C
      BOOK(J,M) = NAME
      RETURN
      ENTRY GETTAG(M,J,TAG)
      TAG = BOOK(J,M)
      END

      SUBROUTINE MFINAL(M,N)
C*************************************************************
      IMPLICIT NONE
C
C     ARGUMENTS
C
      INTEGER M,N
C
C     LOCAL
C
      INTEGER J,IF
      REAL*8 AVG,XIN,SIG,X
C
C     GLOBAL
C
      INCLUDE 'dbook.inc'
C
C     START
C
      AVG=0
      XIN=0
      SIG=0
      IF=0
      DO J=1,NBIN(N,M)
         X=HIST(N,J,M)
 	 AVG=AVG+X*XHIS(N,J,M)
         XIN=XIN+X
	 IF(X.NE.0) IF=1
      ENDDO
      IF(XIN.EQ.0) GO TO 10
      AVG = AVG/XIN
      DO J=1,NBIN(N,M)
         SIG=HIST(N,J,M)*(XHIS(N,J,M)-AVG)**2+SIG
      ENDDO
      SIG=DSQRT(ABS(SIG/XIN))
 10   CONTINUE
      HINT(N,M) = XIN
      HAVG(N,M) = AVG
      HSIG(N,M) = SIG
      IF(IF.EQ.0) BOOK(N,M)='RES'
      END

      SUBROUTINE MNORM(M,N,X)
C*************************************************************
      IMPLICIT NONE
C
C     ARGUMENTS
C
      INTEGER M,N
      REAL*8  X
C
C     GLOBAL
C
      INCLUDE 'dbook.inc'
C
C     LOCAL
C
      INTEGER I
      REAL*8 Y
C
C     START
C
      IF(BOOK(N,M)(:1).NE.'Y')RETURN
      IF(HINT(N,M).EQ.0.) THEN
	CALL MWARN('MNORM')
	WRITE(*,*)' INTEGRAL HIST ',N,M,' IS ZERO: CANNOT RENORMALIZE'
	RETURN
      ELSE
	Y=X/HINT(N,M)
      ENDIF
      DO 1, I=1,NBIN(N,M)
    1 HIST(N,I,M)=HIST(N,I,M)*Y
      HINT(N,M)=X
      OSCORE(N,M)=OSCORE(N,M)*Y
      USCORE(N,M)=USCORE(N,M)*Y
      END

      SUBROUTINE MPRINT(M,N)
C*************************************************************
      IMPLICIT NONE
C
C     ARGUMENTS
C
      INTEGER M,N
C
C     LOCAL
C
      INTEGER INI,J
C
C     GLOBAL
C
      INCLUDE 'dbook.inc'
C
C     START
C
      DATA INI/0/
      IF(INI.EQ.0) THEN
c     CALL IDATE(IMON,IDAY,IYEAR)
c     CALL TIME(CTIME)
      INI=1
      ENDIF
      IF(BOOK(N,M)(:1).NE.'Y') RETURN
C      WRITE(98,7) N,IYEAR,IMON,IDAY,CTIME(1:5)
      WRITE(98,*) TITLE(N,M)
      DO 1 J=1,NBIN(N,M)
      IF(HIST(N,J,M).GT.-1d-99.and.HIST(N,J,M).LT.1d-99) GO TO 1
      WRITE(98,'(3X,F10.4,2X,E15.4)')
     &                            XHIS(N,J,M),HIST(N,J,M)
    1 CONTINUE
      WRITE(98,15) HAVG(N,M),HSIG(N,M),HINT(N,M)
      WRITE(98,20) IENT(N,M),IUSCORE(N,M),IOSCORE(N,M)
C    7 FORMAT(4X,'HIST = ',I3,'   19',I2,'-',I2,'-',I2,1X,A5/)
   10 FORMAT(4X,2E10.3)
   15 FORMAT(/' AVG =',E10.3,4X,' RMS =',E10.3,' INTEGRAL =',E10.3,/)
   20 FORMAT(' ENTRIES=',I5,4X,'UNDERSCORE=',I5,4x,'OVERSCORE=',I5,//)
      END

      SUBROUTINE MTOP(V,N,M,BTIT,LTIT,SCALE)
C*************************************************************
      IMPLICIT NONE
C
C     ARGUMENTS
C
      INTEGER V,N,M
      CHARACTER*20 LTIT,BTIT
      CHARACTER*3 SCALE
C
C     GLOBAL
C
      INCLUDE 'dbook.inc'
C
C     LOCAL
C
      INTEGER INI,J
      real*8 maxbin
C
C     START
C
      DATA INI/0/
      IF(INI.EQ.0) THEN
c      CALL IDATE(IMON,IDAY,IYEAR)
c      CALL TIME(CTIME)
      INI=1
      ENDIF
      IF(BOOK(N,V)(:1).NE.'Y') RETURN
      WRITE(99,100) TITLE(N,V),BTIT,LTIT,SCALE,HMIN(N,V),HMAX(N,V)
  100 FORMAT( /1x,
     &' SET WINDOW Y 2.5 TO 9.'/,1X,
     &' SET WINDOW X 2.5 TO 10.'/,1X,
     &' SET FONT DUPLEX '/1X,
     &' SET SYMBOL 5O SIZE 1.8'/,1X,
     &' TITLE TOP ','"',A20,'"',/1X,
     &' TITLE BOTTOM ','"',A20,'"',/1X,
     &' TITLE LEFT ','"',A20,'"',/1X,
     &' SET SCALE Y ',A,/1X,
     &' (SET TICKS TOP OFF)   '/1x,
     &' SET LIMITS X ',F10.5,' ',F10.5,/1X,
     &' SET ORDER X Y DY ')
      maxbin=0d0
      DO J=1,NBIN(N,V)
         maxbin=max(maxbin,abs(HIST(N,J,V)))
      ENDDO
      DO 1 J=1,NBIN(N,V)
c         IF(abs(HIST(N,J)).le.maxbin*10d-7) GO TO 1
      IF(HIST(N,J,V).lt.1d-99.and.HIST(N,J,V).gt.-1d-99) THEN
      WRITE(99,'(3X,F10.4,2(2X,E15.4))')
     &                            XHIS(N,J,V), 0d0, HIST(M,J,V)
      ELSE
      WRITE(99,'(3X,F10.4,2(2X,E15.4))')
     &                            XHIS(N,J,V),HIST(N,J,V),HIST(M,J,V)
      ENDIF
    1 CONTINUE
      WRITE(99,200)
  200 FORMAT('   HISTO')
      WRITE(99,300) HINT(N,V),HAVG(N,V),HSIG(N,V),IENT(N,V),IUSCORE(N,V)
     &   ,IOSCORE(N,V)
  300 FORMAT( /1x,
     &' BOX 6.25 1.0 SIZE 7.5 0.8'/,1X,
     &' SET WINDOW Y 0. TO 2.'/,1X,
     &' SET TITLE SIZE -1.5'/1X,
     &' SET FONT DUPLEX '/1X,
     &' TITLE 2.8 1.2 "INT =',1PE10.3,'   AVG =',1PE10.3,
     &             '   RMS =',1PE10.3,'"',/1X,
     &' TITLE 2.8 0.9 "Entries =',I8,2x,'Undersc =',I6,2X
     &                                 ,'Oversc =',I6,'"',/1X,
     &' SET TITLE SIZE -2')
      WRITE(99,400)
  400 FORMAT('   NEW PLOT')
      END

      SUBROUTINE MULTITOP(V,NH,NE,N,M,BTIT,LTIT,SCA)
C*************************************************************
      IMPLICIT NONE
C
C     ARGUMENTS
C
      INTEGER NH,NE,N,M,V
      CHARACTER*20 LTIT,BTIT
      CHARACTER*3 SCA
C
C     GLOBAL
C
      INCLUDE 'dbook.inc'
C
C     LOCAL
C
      REAL*8 YTIT,XTIT,FEXP,FMAX,FMIN,X,XMX,FMX,FMN
      REAL*8 YU,XU,YL,XL,YTIT0,YD,XTIT0,TITX,TITS,TICS,SRED,XD
      INTEGER IBIN,IPNS,J,I,NOLD,IFRAME,IFRMAX,IP,NS,MOLD
      INTEGER INI
C
C     START
C
      CHARACTER SCALE*3
      CHARACTER*7  PLOT(4)
      DATA PLOT/'SOLID','DASHES','DOTS','DOTDASH'/
C  PLOT SIZE, CORNERS
      REAL*8 WIDTH,HEIGHT,XCORN,YCORN
      DATA WIDTH,HEIGHT/11.5,8.5/,XCORN,YCORN/1.5,1./
C  PLOT VERSUS TEXT FRACTION
      REAL*8 XPFRAC,YPFRAC,XTFRAC,YTFRAC
      DATA XPFRAC,YPFRAC/0.75,0.75/,XTFRAC,YTFRAC/0.25,0.25/
C  DEFAULT SIZES
      REAL*8 TIC0,LAB0,TIT0,LABS
      DATA TIT0,LAB0,TIC0/-3,-3,0.06/
      DATA INI/0/
      IF(INI.EQ.0) THEN
c      CALL IDATE(IMON,IDAY,IYEAR)
c      CALL TIME(CTIME)
      IFRAME=0
C      WRITE(99,71) IYEAR,IMON,IDAY,CTIME(1:5)
C   71 FORMAT(4X,' (   19',I2,' -',I2,' -',I2,1X,A5/)
      INI=1
      ENDIF
      IF(SCA.EQ.'REF') THEN
	IFRAME=0
	RETURN
      ENDIF
      IF(BOOK(NH,V)(:1).NE.'Y') RETURN
      IFRMAX=N*M
      IFRAME=IFRAME+1
      IF(IFRAME.GT.IFRMAX.OR.N.NE.NOLD.OR.M.NE.MOLD) THEN
      	IFRAME=1
        WRITE(99,202)
C        WRITE(99,1) IMON,IDAY,CTIME(1:5)
C  1     FORMAT(' SET FONT DUPLEX',/,'  SET TITLE SIZE 2',/,
C     +      ' TITLE 12.8 9 ANGLE -90 ','" MLM   ',I2,'-',I2,1X,A5,'"')
      ENDIF
      IF(IFRAME.EQ.1) THEN
    	I=1
	J=1
      ELSEIF(IFRAME.LE.IFRMAX) THEN
	IF(I.LE.N) I=I+1
        IF(I.GT.N) THEN
		I=1
		J=J+1
	ENDIF
      ENDIF
      IF(N.EQ.NOLD) GO TO 10
      NS=N-1
      XD=WIDTH/DFLOAT(N)
      SRED=DSQRT(DFLOAT(N*M))
      TITS=TIT0/SRED
      LABS=LAB0/SRED
      TICS=TIC0/SRED
      XTIT0=0.55*XPFRAC*XD
      NOLD=N
10    IF(M.EQ.MOLD) GO TO 20
      YD=HEIGHT/DFLOAT(M)
      YTIT0=0.06*YD
      MOLD=M
20    CONTINUE
      XL=(I-1)*XD + XCORN
      YL=(M-J)*YD + YCORN
      XU=XL+XD*XPFRAC
      YU=YL+YD*YPFRAC
      IP=0
      FMN=MAX(HINT(NH,V)*NBIN(NH,V),1.E12)
      FMX=-FMN
      XMX=0.
      DO IBIN=1,NBIN(NH,V)
	X=HIST(NH,IBIN,V)
      	IF(X.NE.0.) FMX=MAX(FMX,X)
      	IF(X.NE.0.) FMN=MIN(FMN,X)
	XMX=MAX(XMX,ABS(X))
      ENDDO
      IF(XMX.EQ.0.) GO TO 203
      SCALE=SCA
50    IF(SCALE.EQ.'LIN') THEN
	IF(FMN.GE.0.)	FMIN=0.
	IF(FMN.LT.0.)	FMIN=FMN*1.3
	IF(FMX.GT.0.)	FMAX=FMX*1.3
	IF(FMX.LT.0.)	FMAX=0.
      ELSEIF(SCALE.EQ.'LOG') THEN
        IF(FMN.LE.0.) THEN
	     	SCALE='LIN'
		GO TO 50
	ENDIF
	FMIN=LOG10(FMN)
	FMAX=LOG10(FMX)
       	FEXP=AINT(FMAX+(FMAX-FMIN)*0.2+1)
	FMIN=10.**AINT(LOG10(FMN))
	IF(FMIN.GT.FMX) FMIN=FMIN/10.
	FMAX=10.**(FEXP)
      ENDIF
      WRITE(99,100) TITS,LABS,TICS,XL,XU,YL,YU
100   FORMAT(2X,'SET FONT DUPLEX',/,
     *       2X,'SET TITLE SIZE ',F8.4,/,
     *       2X,'SET LABEL SIZE ',F8.4,/,
     *       2X,'SET TICKS TOP OFF SIZE ',F8.4,/,
     *       2X,'SET WINDOW X ',F8.4,' TO ',F8.4,/,
     *       2X,'SET WINDOW Y ',F8.4,' TO ',F8.4)
      XTIT=XL+XTIT0
      YTIT=YU+YTIT0
      WRITE(99,101) XL,YTIT,TITLE(NH,V)(1:20)
101   FORMAT('  TITLE ',2(F8.4,1X),'"',A,'"')
      YTIT=YTIT-2.*YTIT0
      WRITE(99,102) XTIT,YTIT,HINT(NH,V)
102   FORMAT('  TITLE ',2(F8.4,1X),'" INT=',1PE10.3,'"')
      YTIT=YTIT-YTIT0
      WRITE(99,103) XTIT,YTIT,IENT(NH,V)
103   FORMAT('  TITLE ',2(F8.4,1X),'" ENT=',I9,'"')
      YTIT=YTIT-YTIT0
      IF(USCORE(NH,V).NE.0.) THEN
        WRITE(99,104) XTIT,YTIT,USCORE(NH,V)
104     FORMAT('  TITLE ',2(F8.4,1X),'" UFL=',1PE10.3,'"')
        YTIT=YTIT-YTIT0
      ENDIF
      IF(OSCORE(NH,V).NE.0.) THEN
        WRITE(99,105) XTIT,YTIT,OSCORE(NH,V)
105     FORMAT('  TITLE ',2(F8.4,1X),'" OFL=',1PE10.3,'"')
        YTIT=YTIT-YTIT0
      ENDIF
      WRITE(99,106) XTIT,YTIT,XU,YTIT,XTIT,YTIT,XTIT,YU
106   FORMAT(2X,'SET ORD X Y ',/,2(F8.4,1X),/,2(F8.4,1X),/,
     *       2X,'JOIN TEXT',/,
     *       2X,2(F8.4,1X),/,2(F8.4,1X),/,
     *       2X,'JOIN TEXT')
      WRITE(99,108) TITS*1.5
108   FORMAT(2X,'SET TITLE SIZE ',F8.4)
      WRITE(99,107) BTIT,XL-0.75*XD*XTFRAC,YL+(YU-YL)/3.,LTIT,SCALE,
     * HMIN(NH,V),HMAX(NH,V),FMIN,FMAX
107   FORMAT(
     &' TITLE BOTTOM ','"',A,'"',/1X,
     &' TITLE ',f10.5,f10.5,' ANGLE 90 ','"',A,'"',/1X,
     &' SET SCALE Y ',A,/1X,
     &' SET TICKS TOP OFF   '/1x,
     &' SET LIMITS X ',F10.5,' ',F10.5,/1X,
     &' SET LIMITS Y ',1PE10.3,' ',1PE10.3,/1X,
     &' SET ORDER X Y DY')
C
C  END HEADER , FILL TOPDRAWER WITH DATA
C
      ENTRY MTFILL(V,NH,NE,N,M,BTIT,LTIT,SCA)
      IP=IP+1
      IF(IP.GT.4) IP=1
      WRITE(99,110) TITLE(NH,V),HINT(NH,V),IENT(NH,V)
110   FORMAT(' ( ',A,/,' ( INT=',1PE10.3,'  ENTRIES=',I12)
      DO 200 IBIN=1,NBIN(NH,V)
      IF(HIST(NH,IBIN,V).EQ.0..AND.HIST(NE,IBIN,V).EQ.0.) GO TO 200
      WRITE(99,'(3X,F10.4,2(2X,E15.4))')
     &          XHIS(NH,IBIN,V),HIST(NH,IBIN,V),HIST(NE,IBIN,V)
200   CONTINUE
      WRITE(99,201)  PLOT(IP)
      IF(BOOK(NE,V).NE.'NO')   WRITE(99,*)  '  PLOT'
201   FORMAT(2X,'HIST ',A)
202   FORMAT('   NEW PLOT',/,/)
203   RETURN
      END

      SUBROUTINE MWARN(ROUT)
C*************************************************************
      CHARACTER*(*) ROUT
      WRITE(*,*) '***********************************************'
      WRITE(*,*) '***** WARNING CALLED FROM ROUTINE ',ROUT,':'
      END

C*******************************************************************
C     END OF THE HISTOGRAMMING PACKAGE
C*******************************************************************